;;;; standard library ;;; void (def (void . rest) "Return the constant `#<void>` while ignoring any arguments. `#<void>` is mainly used when a function has side effects but does not produce any meaningful value to return, so even though `T` or `NIL` could be returned instead, in case of `#<void>` alone, REPL will not print it." #.(void)) (def (void? x) "Return `T` if `x` is `#<void>`, `NIL` otherwise." (eq? x #.(void))) ;;; syntax environment (unless (bound? '*syntax-environment*) (def *syntax-environment* (table))) (def (set-syntax! s v) (put! *syntax-environment* s v)) (def (get-syntax s) (get *syntax-environment* s NIL)) (defmacro (defmacro form . body) (let* {[doc+body (separate-doc-from-body body)] [doc (car doc+body)] [body (cdr doc+body)]} (when doc (sym-set-doc (car form) doc (cdr form))) `(void (set-syntax! ',(car form) (λ ,(cdr form) ,@body))))) (defmacro (letrec binds . body) `((λ ,(map car binds) ,.(map (λ (b) `(set! ,@b)) binds) ,@body) ,.(map void binds))) (defmacro (let binds . body) (let ((lname NIL)) (when (sym? binds) (set! lname binds) (set! binds (car body)) (set! body (cdr body))) (let ((thelambda `(λ ,(map (λ (c) (if (cons? c) (car c) c)) binds) ,@body)) (theargs (map (λ (c) (if (cons? c) (cadr c) (void))) binds))) (cons (if lname `(letrec ((,lname ,thelambda)) ,lname) thelambda) theargs)))) (defmacro (cond . clauses) (def (cond-clauses->if lst) (if (atom? lst) NIL (let ((clause (car lst))) (if (or (eq? (car clause) 'else) (eq? (car clause) T)) (if (not (cdr clause)) (car clause) (cons 'begin (cdr clause))) (if (not (cdr clause)) ; test by itself (list 'or (car clause) (cond-clauses->if (cdr lst))) ; test => expression (if (eq? (cadr clause) '=>) (if (1arg-lambda? (caddr clause)) ; test => (λ (x) ...) (let ((var (caadr (caddr clause)))) `(let ((,var ,(car clause))) (if ,var ,(cons 'begin (cddr (caddr clause))) ,(cond-clauses->if (cdr lst))))) ; test => proc `(let ((b# ,(car clause))) (if b# (,(caddr clause) b#) ,(cond-clauses->if (cdr lst))))) (list 'if (car clause) (cons 'begin (cdr clause)) (cond-clauses->if (cdr lst))))))))) (cond-clauses->if clauses)) ;;; props ;; This is implemented in a slightly different fashion as expected:;;;; *properties* : key → { symbol → value };;;; The assumption here is that keys will most likely be the same across multiple symbols;; so it makes more sense to reduce the number of subtables for the *properties* table.(unless (bound? '*properties*) (def *properties* (table))) (def (putprop symbol key val) "Associate a property value with the symbol." :doc-group prop :doc-see getprop (let ((kt (get *properties* key NIL))) (unless kt (let ((ta (table))) (put! *properties* key ta) (set! kt ta))) (put! kt symbol val) val)) (def (getprop symbol key (def NIL)) "Return a property value associated with the symbol or `def` if missing." :doc-group prop :doc-see putprop (let ((kt (get *properties* key NIL))) (or (and kt (get kt symbol def)) def))) (def (remprop symbol key) "Remove a property value associated with the symbol." :doc-group prop (let ((kt (get *properties* key NIL))) (and kt (has? kt symbol) (del! kt symbol)))) ;;; documentation (def (separate-doc-from-body body (doc NIL)) "Take a list of terms and return a pair `(doc . body)`, where the first element contains a list of documentation-related terms, and the second contains the rest of the terms." :doc-group doc (def (doc? kw) (and (> (length kw) 5) (eq? (aref kw 1) #\d) (eq? (aref kw 2) #\o) (eq? (aref kw 3) #\c) (eq? (aref kw 4) #\-))) (let {[hd (car body)] [tl (cdr body)]} (cond [(and (str? hd) (not doc) tl) (separate-doc-from-body tl (cons hd doc))] [(and doc (keyword? hd) (doc? (str hd))) (separate-doc-from-body (cdr tl) (cons (cons hd (car tl)) doc))] [else (cons (reverse doc) body)]))) (def (sym-set-doc symbol doc-seq . formals-list) "Set the documentation for the symbol." :doc-group doc (let* {[doc-only (str? doc-seq)] [doc (if doc-only doc-seq (car doc-seq))] [extra (if doc-only NIL (cdr doc-seq))]} (when (and (bound? 'str-join) doc) (let* {[lines (str-split doc "\n")] [hd (car lines)] [tl (cdr lines)] [snd (any (λ (s) (and (> (length s) 0) (eq? (aref s 0) #\space) s)) tl)] [indent (and snd (- (length snd) (length (str-trim snd " " ""))))] [trimmed (and snd (map (λ (s) (if (<= indent (length s)) (str-sub s indent) s)) tl))] [final (str-join (cons hd trimmed) "\n")]} (putprop symbol '*doc* final) (when extra (putprop symbol '*doc-extra* extra)))) (when (cons? formals-list) (let* {[existing (getprop symbol '*formals-list*)] ; filter out duplicates [to-add (filter (λ (formals) (not (member formals existing))) formals-list)]} (putprop symbol '*formals-list* (append existing to-add)))) (void))) ;; chicken and egg - properties defined before sym-set-doc(sym-set-doc '*properties* '("All properties of symbols recorded with `putprop` are recorded in this table." :doc-group prop)) (def (help-print-header term sigs (:kind NIL) (:lpad "")) "Format and print signature(s) of the term for `(help term)` output." :doc-group doc (if sigs (for-each (λ (sig) (princ lpad) (print (cons term sig)) (newline)) sigs) (begin (princ lpad) (if kind (princ (caddr term) " (group)") (print term)) (newline))) (newline)) (defmacro (help term (kind NIL) (:print-header help-print-header)) "Display documentation the specified term, if available. The optional parameter `kind` can be set to `group` to show documentation for the specified group instead of a single term. All available documentation groups can be displayed with `(help groups)`." :doc-group doc (let* {[doc-extra-term (and kind (cons (sym ":doc-" kind) term))] [docterm (if kind (list 'doc kind term) term)] [doc (getprop docterm '*doc*)] [formals-list (getprop docterm '*formals-list*)]} (def (print-sig term sigs lpad) (if sigs (for-each (λ (sig) (newline) (princ lpad) (print (cons term sig))) sigs) (begin (newline) (princ lpad) (print term)))) (def (first-line s) (let* {[nl (str-find s "\n")]} (if nl (str-sub s 0 nl) s))) (def (doc-group? k) (and (cons? k) (eq? (car k) 'doc) (eq? (cadr k) 'group))) (def (doc-extra-term? k) (and (atom? k) (member doc-extra-term (getprop k '*doc-extra*)))) (def (table-keys-filter-sort tbl pred) (sort (table-foldl (λ (k _ z) (if (pred k) (cons k z) z)) NIL tbl) <)) (if (eq? term 'groups) (for-each (λ (k) (princ (caddr k) ": " (first-line (getprop k '*doc*))) (newline)) (table-keys-filter-sort (get *properties* '*doc*) doc-group?)) (if (or doc formals-list) (begin (print-header docterm formals-list :kind kind) (let* {[extra (getprop docterm '*doc-extra*)] [fmt (filter (λ (v) (eq? (car v) :doc-fmt)) extra)] [see (filter (λ (v) (eq? (car v) :doc-see)) extra)]} (when doc (princ (foldl (λ (fmt doc) ((cdr fmt) doc)) doc fmt)) (newline)) (when see (newline) (princ "See also:") (newline) (for-each (λ (v) (print-sig (cdr v) (getprop (cdr v) '*formals-list*) " ")) see) (newline))) (when kind (newline) (princ "Members:") (newline) (for-each (λ (k) (print-sig k (getprop k '*formals-list*) " ")) (table-keys-filter-sort (get *properties* '*doc*) doc-extra-term?)) (newline)) (void)) (begin (princ "no help for " (if kind (str kind " ") "") term) (when (and (not kind) (sym? term) (not (bound? term))) (princ " (undefined)")) (newline)))) (void))) ;;; standard procedures (def (member item lst) (cond ((equal? (car lst) item) lst) (lst (member item (cdr lst))))) (def (memv item lst) (cond ((eqv? (car lst) item) lst) (lst (memv item (cdr lst))))) (def (assoc item lst) (cond ((equal? (caar lst) item) (car lst)) (lst (assoc item (cdr lst))))) (def (assv item lst) (cond ((eqv? (caar lst) item) (car lst)) (lst (assv item (cdr lst))))) (doc-group compare "Comparison operators.") (def (> a . rest) "Return `T` if the arguments are in strictly decreasing order (previous one is greater than the next one)." :doc-group compare (let loop ((a a) (rest rest)) (or (not rest) (and (< (car rest) a) (loop (car rest) (cdr rest))))))(defmacro (> a . rest) `(< ,.(reverse rest) ,a)) (def (<= a . rest) "Return `T` if the arguments are in non-decreasing order (previous one is less than or equal to the next one)." :doc-group compare (let loop ((a a) (rest rest)) (or (not rest) (unless (or (< (car rest) a) (nan? a)) (loop (car rest) (cdr rest)))))) (def (>= a . rest) "Return `T` if the arguments are in non-increasing order (previous one is greater than or equal to the next one)." :doc-group compare (let loop ((a a) (rest rest)) (or (not rest) (unless (or (< a (car rest)) (nan? a)) (loop (car rest) (cdr rest)))))) (def (negative? x) "Return `T` if `x` is negative." :doc-group compare (< x 0)) (def (zero? x) "Return `T` if `x` is zero." :doc-group compare (= x 0)) (def (positive? x) "Return `T` if `x` is greater than zero." :doc-group compare (> x 0)) (def (even? x) (= (logand x 1) 0)) (def (odd? x) (not (even? x))) (def (identity x) "Return `x`." x) (def (1+ n) "Equivalent to `(+ n 1)`." (+ n 1)) (def (1- n) "Equivalent to `(- n 1)`." (- n 1)) (def (div x y) (+ (div0 x y) (or (and (< x 0) (or (and (< y 0) 1) -1)) 0))) (def (mod0 x y) (- x (* (div0 x y) y))) (def (mod x y) (- x (* (div x y) y))) (def (random n) (if (int? n) (mod (rand) n) (* (rand-double) n))) (def (abs x) (if (< x 0) (- x) x)) (def (max x0 . xs) (if xs (foldl (λ (a b) (if (< a b) b a)) x0 xs) x0)) (def (min x0 . xs) (if xs (foldl (λ (a b) (if (< a b) a b)) x0 xs) x0)) (def (rune? x) (eq? (typeof x) 'rune)) (def (arr? x) (or (vec? x) (let ((tx (typeof x))) (and (cons? tx) (eq? (car tx) 'arr))))) (def (closure? x) (and (fn? x) (not (builtin? x)))) (def (caar x) (car (car x)))(def (cdar x) (cdr (car x)))(def (cddr x) (cdr (cdr x)))(def (caaar x) (car (car (car x))))(def (caadr x) (car (car (cdr x))))(def (cadar x) (car (cdr (car x))))(def (caddr x) (car (cdr (cdr x))))(def (cdaar x) (cdr (car (car x))))(def (cdadr x) (cdr (car (cdr x))))(def (cddar x) (cdr (cdr (car x))))(def (cdddr x) (cdr (cdr (cdr x))))(def (caaaar x) (car (car (car (car x)))))(def (caaadr x) (car (car (car (cdr x)))))(def (caadar x) (car (car (cdr (car x)))))(def (caaddr x) (car (car (cdr (cdr x)))))(def (cadaar x) (car (cdr (car (car x)))))(def (cadadr x) (car (cdr (car (cdr x)))))(def (caddar x) (car (cdr (cdr (car x)))))(def (cadddr x) (car (cdr (cdr (cdr x)))))(def (cdaaar x) (cdr (car (car (car x)))))(def (cdaadr x) (cdr (car (car (cdr x)))))(def (cdadar x) (cdr (car (cdr (car x)))))(def (cdaddr x) (cdr (car (cdr (cdr x)))))(def (cddaar x) (cdr (cdr (car (car x)))))(def (cddadr x) (cdr (cdr (car (cdr x)))))(def (cdddar x) (cdr (cdr (cdr (car x)))))(def (cddddr x) (cdr (cdr (cdr (cdr x))))) (let ((*values* (list '*values*))) (set! values (λ vs (if (and (cons? vs) (not (cdr vs))) (car vs) (cons *values* vs)))) (set! call-with-values (λ (producer consumer) (let ((res (producer))) (if (and (cons? res) (eq? *values* (car res))) (apply consumer (cdr res)) (consumer res)))))) ;;; list utilities (def (every pred lst) (or (atom? lst) (and (pred (car lst)) (every pred (cdr lst))))) (def (any pred lst) (and (cons? lst) (or (pred (car lst)) (any pred (cdr lst))))) (def (list? a) (or (not a) (and (cons? a) (list? (cdr a))))) (def (list-tail lst n) (if (<= n 0) lst (list-tail (cdr lst) (- n 1)))) (def (list-head lst n) (and (> n 0) (cons (car lst) (list-head (cdr lst) (- n 1))))) (def (list-ref lst n) (car (list-tail lst n))) (doc-group list "Working with lists.") (def (length= lst n) "Perform a bounded length test. Use this instead of `(= (length lst) n)`, since it avoids unnecessary work and always terminates." :doc-group list (cond ((< n 0) NIL) ((= n 0) (atom? lst)) ((atom? lst) (= n 0)) (else (length= (cdr lst) (- n 1))))) Lines 1–500 of 1567. Load more
;;;; standard library ;;; void (def (void . rest) "Return the constant `#<void>` while ignoring any arguments. `#<void>` is mainly used when a function has side effects but does not produce any meaningful value to return, so even though `T` or `NIL` could be returned instead, in case of `#<void>` alone, REPL will not print it." #.(void)) (def (void? x) "Return `T` if `x` is `#<void>`, `NIL` otherwise." (eq? x #.(void))) ;;; syntax environment (unless (bound? '*syntax-environment*) (def *syntax-environment* (table))) (def (set-syntax! s v) (put! *syntax-environment* s v)) (def (get-syntax s) (get *syntax-environment* s NIL)) (defmacro (defmacro form . body) (let* {[doc+body (separate-doc-from-body body)] [doc (car doc+body)] [body (cdr doc+body)]} (when doc (sym-set-doc (car form) doc (cdr form))) `(void (set-syntax! ',(car form) (λ ,(cdr form) ,@body))))) (defmacro (letrec binds . body) `((λ ,(map car binds) ,.(map (λ (b) `(set! ,@b)) binds) ,@body) ,.(map void binds))) (defmacro (let binds . body) (let ((lname NIL)) (when (sym? binds) (set! lname binds) (set! binds (car body)) (set! body (cdr body))) (let ((thelambda `(λ ,(map (λ (c) (if (cons? c) (car c) c)) binds) ,@body)) (theargs (map (λ (c) (if (cons? c) (cadr c) (void))) binds))) (cons (if lname `(letrec ((,lname ,thelambda)) ,lname) thelambda) theargs)))) (defmacro (cond . clauses) (def (cond-clauses->if lst) (if (atom? lst) NIL (let ((clause (car lst))) (if (or (eq? (car clause) 'else) (eq? (car clause) T)) (if (not (cdr clause)) (car clause) (cons 'begin (cdr clause))) (if (not (cdr clause)) ; test by itself (list 'or (car clause) (cond-clauses->if (cdr lst))) ; test => expression (if (eq? (cadr clause) '=>) (if (1arg-lambda? (caddr clause)) ; test => (λ (x) ...) (let ((var (caadr (caddr clause)))) `(let ((,var ,(car clause))) (if ,var ,(cons 'begin (cddr (caddr clause))) ,(cond-clauses->if (cdr lst))))) ; test => proc `(let ((b# ,(car clause))) (if b# (,(caddr clause) b#) ,(cond-clauses->if (cdr lst))))) (list 'if (car clause) (cons 'begin (cdr clause)) (cond-clauses->if (cdr lst))))))))) (cond-clauses->if clauses)) ;;; props ;; This is implemented in a slightly different fashion as expected: ;; ;; *properties* : key → { symbol → value } ;; ;; The assumption here is that keys will most likely be the same across multiple symbols ;; so it makes more sense to reduce the number of subtables for the *properties* table. (unless (bound? '*properties*) (def *properties* (table))) (def (putprop symbol key val) "Associate a property value with the symbol." :doc-group prop :doc-see getprop (let ((kt (get *properties* key NIL))) (unless kt (let ((ta (table))) (put! *properties* key ta) (set! kt ta))) (put! kt symbol val) val)) (def (getprop symbol key (def NIL)) "Return a property value associated with the symbol or `def` if missing." :doc-group prop :doc-see putprop (let ((kt (get *properties* key NIL))) (or (and kt (get kt symbol def)) def))) (def (remprop symbol key) "Remove a property value associated with the symbol." :doc-group prop (let ((kt (get *properties* key NIL))) (and kt (has? kt symbol) (del! kt symbol)))) ;;; documentation (def (separate-doc-from-body body (doc NIL)) "Take a list of terms and return a pair `(doc . body)`, where the first element contains a list of documentation-related terms, and the second contains the rest of the terms." :doc-group doc (def (doc? kw) (and (> (length kw) 5) (eq? (aref kw 1) #\d) (eq? (aref kw 2) #\o) (eq? (aref kw 3) #\c) (eq? (aref kw 4) #\-))) (let {[hd (car body)] [tl (cdr body)]} (cond [(and (str? hd) (not doc) tl) (separate-doc-from-body tl (cons hd doc))] [(and doc (keyword? hd) (doc? (str hd))) (separate-doc-from-body (cdr tl) (cons (cons hd (car tl)) doc))] [else (cons (reverse doc) body)]))) (def (sym-set-doc symbol doc-seq . formals-list) "Set the documentation for the symbol." :doc-group doc (let* {[doc-only (str? doc-seq)] [doc (if doc-only doc-seq (car doc-seq))] [extra (if doc-only NIL (cdr doc-seq))]} (when (and (bound? 'str-join) doc) (let* {[lines (str-split doc "\n")] [hd (car lines)] [tl (cdr lines)] [snd (any (λ (s) (and (> (length s) 0) (eq? (aref s 0) #\space) s)) tl)] [indent (and snd (- (length snd) (length (str-trim snd " " ""))))] [trimmed (and snd (map (λ (s) (if (<= indent (length s)) (str-sub s indent) s)) tl))] [final (str-join (cons hd trimmed) "\n")]} (putprop symbol '*doc* final) (when extra (putprop symbol '*doc-extra* extra)))) (when (cons? formals-list) (let* {[existing (getprop symbol '*formals-list*)] ; filter out duplicates [to-add (filter (λ (formals) (not (member formals existing))) formals-list)]} (putprop symbol '*formals-list* (append existing to-add)))) (void))) ;; chicken and egg - properties defined before sym-set-doc (sym-set-doc '*properties* '("All properties of symbols recorded with `putprop` are recorded in this table." :doc-group prop)) (def (help-print-header term sigs (:kind NIL) (:lpad "")) "Format and print signature(s) of the term for `(help term)` output." :doc-group doc (if sigs (for-each (λ (sig) (princ lpad) (print (cons term sig)) (newline)) sigs) (begin (princ lpad) (if kind (princ (caddr term) " (group)") (print term)) (newline))) (newline)) (defmacro (help term (kind NIL) (:print-header help-print-header)) "Display documentation the specified term, if available. The optional parameter `kind` can be set to `group` to show documentation for the specified group instead of a single term. All available documentation groups can be displayed with `(help groups)`." :doc-group doc (let* {[doc-extra-term (and kind (cons (sym ":doc-" kind) term))] [docterm (if kind (list 'doc kind term) term)] [doc (getprop docterm '*doc*)] [formals-list (getprop docterm '*formals-list*)]} (def (print-sig term sigs lpad) (if sigs (for-each (λ (sig) (newline) (princ lpad) (print (cons term sig))) sigs) (begin (newline) (princ lpad) (print term)))) (def (first-line s) (let* {[nl (str-find s "\n")]} (if nl (str-sub s 0 nl) s))) (def (doc-group? k) (and (cons? k) (eq? (car k) 'doc) (eq? (cadr k) 'group))) (def (doc-extra-term? k) (and (atom? k) (member doc-extra-term (getprop k '*doc-extra*)))) (def (table-keys-filter-sort tbl pred) (sort (table-foldl (λ (k _ z) (if (pred k) (cons k z) z)) NIL tbl) <)) (if (eq? term 'groups) (for-each (λ (k) (princ (caddr k) ": " (first-line (getprop k '*doc*))) (newline)) (table-keys-filter-sort (get *properties* '*doc*) doc-group?)) (if (or doc formals-list) (begin (print-header docterm formals-list :kind kind) (let* {[extra (getprop docterm '*doc-extra*)] [fmt (filter (λ (v) (eq? (car v) :doc-fmt)) extra)] [see (filter (λ (v) (eq? (car v) :doc-see)) extra)]} (when doc (princ (foldl (λ (fmt doc) ((cdr fmt) doc)) doc fmt)) (newline)) (when see (newline) (princ "See also:") (newline) (for-each (λ (v) (print-sig (cdr v) (getprop (cdr v) '*formals-list*) " ")) see) (newline))) (when kind (newline) (princ "Members:") (newline) (for-each (λ (k) (print-sig k (getprop k '*formals-list*) " ")) (table-keys-filter-sort (get *properties* '*doc*) doc-extra-term?)) (newline)) (void)) (begin (princ "no help for " (if kind (str kind " ") "") term) (when (and (not kind) (sym? term) (not (bound? term))) (princ " (undefined)")) (newline)))) (void))) ;;; standard procedures (def (member item lst) (cond ((equal? (car lst) item) lst) (lst (member item (cdr lst))))) (def (memv item lst) (cond ((eqv? (car lst) item) lst) (lst (memv item (cdr lst))))) (def (assoc item lst) (cond ((equal? (caar lst) item) (car lst)) (lst (assoc item (cdr lst))))) (def (assv item lst) (cond ((eqv? (caar lst) item) (car lst)) (lst (assv item (cdr lst))))) (doc-group compare "Comparison operators.") (def (> a . rest) "Return `T` if the arguments are in strictly decreasing order (previous one is greater than the next one)." :doc-group compare (let loop ((a a) (rest rest)) (or (not rest) (and (< (car rest) a) (loop (car rest) (cdr rest)))))) (defmacro (> a . rest) `(< ,.(reverse rest) ,a)) (def (<= a . rest) "Return `T` if the arguments are in non-decreasing order (previous one is less than or equal to the next one)." :doc-group compare (let loop ((a a) (rest rest)) (or (not rest) (unless (or (< (car rest) a) (nan? a)) (loop (car rest) (cdr rest)))))) (def (>= a . rest) "Return `T` if the arguments are in non-increasing order (previous one is greater than or equal to the next one)." :doc-group compare (let loop ((a a) (rest rest)) (or (not rest) (unless (or (< a (car rest)) (nan? a)) (loop (car rest) (cdr rest)))))) (def (negative? x) "Return `T` if `x` is negative." :doc-group compare (< x 0)) (def (zero? x) "Return `T` if `x` is zero." :doc-group compare (= x 0)) (def (positive? x) "Return `T` if `x` is greater than zero." :doc-group compare (> x 0)) (def (even? x) (= (logand x 1) 0)) (def (odd? x) (not (even? x))) (def (identity x) "Return `x`." x) (def (1+ n) "Equivalent to `(+ n 1)`." (+ n 1)) (def (1- n) "Equivalent to `(- n 1)`." (- n 1)) (def (div x y) (+ (div0 x y) (or (and (< x 0) (or (and (< y 0) 1) -1)) 0))) (def (mod0 x y) (- x (* (div0 x y) y))) (def (mod x y) (- x (* (div x y) y))) (def (random n) (if (int? n) (mod (rand) n) (* (rand-double) n))) (def (abs x) (if (< x 0) (- x) x)) (def (max x0 . xs) (if xs (foldl (λ (a b) (if (< a b) b a)) x0 xs) x0)) (def (min x0 . xs) (if xs (foldl (λ (a b) (if (< a b) a b)) x0 xs) x0)) (def (rune? x) (eq? (typeof x) 'rune)) (def (arr? x) (or (vec? x) (let ((tx (typeof x))) (and (cons? tx) (eq? (car tx) 'arr))))) (def (closure? x) (and (fn? x) (not (builtin? x)))) (def (caar x) (car (car x))) (def (cdar x) (cdr (car x))) (def (cddr x) (cdr (cdr x))) (def (caaar x) (car (car (car x)))) (def (caadr x) (car (car (cdr x)))) (def (cadar x) (car (cdr (car x)))) (def (caddr x) (car (cdr (cdr x)))) (def (cdaar x) (cdr (car (car x)))) (def (cdadr x) (cdr (car (cdr x)))) (def (cddar x) (cdr (cdr (car x)))) (def (cdddr x) (cdr (cdr (cdr x)))) (def (caaaar x) (car (car (car (car x))))) (def (caaadr x) (car (car (car (cdr x))))) (def (caadar x) (car (car (cdr (car x))))) (def (caaddr x) (car (car (cdr (cdr x))))) (def (cadaar x) (car (cdr (car (car x))))) (def (cadadr x) (car (cdr (car (cdr x))))) (def (caddar x) (car (cdr (cdr (car x))))) (def (cadddr x) (car (cdr (cdr (cdr x))))) (def (cdaaar x) (cdr (car (car (car x))))) (def (cdaadr x) (cdr (car (car (cdr x))))) (def (cdadar x) (cdr (car (cdr (car x))))) (def (cdaddr x) (cdr (car (cdr (cdr x))))) (def (cddaar x) (cdr (cdr (car (car x))))) (def (cddadr x) (cdr (cdr (car (cdr x))))) (def (cdddar x) (cdr (cdr (cdr (car x))))) (def (cddddr x) (cdr (cdr (cdr (cdr x))))) (let ((*values* (list '*values*))) (set! values (λ vs (if (and (cons? vs) (not (cdr vs))) (car vs) (cons *values* vs)))) (set! call-with-values (λ (producer consumer) (let ((res (producer))) (if (and (cons? res) (eq? *values* (car res))) (apply consumer (cdr res)) (consumer res)))))) ;;; list utilities (def (every pred lst) (or (atom? lst) (and (pred (car lst)) (every pred (cdr lst))))) (def (any pred lst) (and (cons? lst) (or (pred (car lst)) (any pred (cdr lst))))) (def (list? a) (or (not a) (and (cons? a) (list? (cdr a))))) (def (list-tail lst n) (if (<= n 0) lst (list-tail (cdr lst) (- n 1)))) (def (list-head lst n) (and (> n 0) (cons (car lst) (list-head (cdr lst) (- n 1))))) (def (list-ref lst n) (car (list-tail lst n))) (doc-group list "Working with lists.") (def (length= lst n) "Perform a bounded length test. Use this instead of `(= (length lst) n)`, since it avoids unnecessary work and always terminates." :doc-group list (cond ((< n 0) NIL) ((= n 0) (atom? lst)) ((atom? lst) (= n 0)) (else (length= (cdr lst) (- n 1)))))