diff --git a/README.md b/README.md index 76435467a..03b8cfa01 100644 --- a/README.md +++ b/README.md @@ -46,34 +46,34 @@ Procedures for each standard are provided by the following R7RS-style libraries: |:--------:|--------------| | R4RS | [`(scheme r4rs)`](./basis/r4rs.ss) | R5RS | [`(scheme r5rs)`](./basis/r5rs.ss) -| R7RS | [`(scheme base)`](./basis/r7rs.ss) [`(scheme box)`](./basis/r7rs.ss) [`(scheme case-lambda)`](./basis/r7rs.ss) [`(scheme char)`](./basis/r7rs.ss) [`(scheme complex)`](./basis/r7rs.ss) [`(scheme cxr)`](./basis/r7rs.ss) [`(scheme eval)`](./basis/r7rs.ss) [`(scheme file)`](./basis/r7rs.ss) [`(scheme inexact)`](./basis/r7rs.ss) [`(scheme lazy)`](./basis/r7rs.ss) [`(scheme load)`](./basis/r7rs.ss) [`(scheme process-context)`](./basis/r7rs.ss) [`(scheme read)`](./basis/r7rs.ss) [`(scheme repl)`](./basis/r7rs.ss) [`(scheme time)`](./basis/r7rs.ss) [`(scheme write)`](./basis/r7rs.ss) +| R7RS | [`(scheme base)`](./basis/r7rs.ss) [`(scheme box)`](./basis/r7rs.ss) [`(scheme case-lambda)`](./basis/r7rs.ss) [`(scheme char)`](./basis/r7rs.ss) [`(scheme complex)`](./basis/r7rs.ss) [`(scheme cxr)`](./basis/r7rs.ss) [`(scheme eval)`](./basis/r7rs.ss) [`(scheme file)`](./basis/r7rs.ss) [`(scheme inexact)`](./basis/r7rs.ss) [`(scheme lazy)`](./basis/r7rs.ss) [`(scheme list)`](./basis/r7rs.ss) [`(scheme load)`](./basis/r7rs.ss) [`(scheme process-context)`](./basis/r7rs.ss) [`(scheme read)`](./basis/r7rs.ss) [`(scheme repl)`](./basis/r7rs.ss) [`(scheme time)`](./basis/r7rs.ss) [`(scheme write)`](./basis/r7rs.ss) ### SRFIs -| Number | Title | Library name | Note | -|--------------------------------------------------------:|--------------------------------------------------------|-------------------------------------|-----------------------------------| -| [ 0](https://srfi.schemers.org/srfi-0/srfi-0.html) | Feature-based conditional expansion construct | [`(srfi 0)`](./basis/srfi-0.ss) | R7RS 4.2.1 | -| [ 1](https://srfi.schemers.org/srfi-1/srfi-1.html) | List Library | [`(srfi 1)`](./basis/srfi-1.ss) | | -| [ 4](https://srfi.schemers.org/srfi-4/srfi-4.html) | Homogeneous numeric vector datatypes | [`(srfi 4)`](./basis/srfi-4.ss) | R7RS 6.9 | -| [ 6](https://srfi.schemers.org/srfi-6/srfi-6.html) | Basic String Ports | [`(srfi 6)`](./basis/srfi-6.ss) | R7RS 6.13 | -| [ 8](https://srfi.schemers.org/srfi-8/srfi-8.html) | receive: Binding to multiple values | [`(srfi 8)`](./basis/srfi-8.ss) | | -| [ 9](https://srfi.schemers.org/srfi-9/srfi-9.html) | Defining Record Types | [`(srfi 9)`](./basis/srfi-9.ss) | R7RS 5.5 | -| [ 10](https://srfi.schemers.org/srfi-10/srfi-10.html) | #, external form | | | -| [ 11](https://srfi.schemers.org/srfi-11/srfi-11.html) | Syntax for receiving multiple values | [`(srfi 11)`](./basis/srfi-11.ss) | R7RS 4.2.2 | -| [ 16](https://srfi.schemers.org/srfi-16/srfi-16.html) | Syntax for procedures of variable arity | [`(srfi 16)`](./basis/srfi-16.ss) | R7RS 4.2.9 | -| [ 23](https://srfi.schemers.org/srfi-23/srfi-23.html) | Error reporting mechanism | [`(srfi 23)`](./basis/srfi-23.ss) | R7RS 6.11 | -| [ 30](https://srfi.schemers.org/srfi-30/srfi-30.html) | Nested Multi-line Comments | | R7RS 2.2 | -| [ 31](https://srfi.schemers.org/srfi-31/srfi-31.html) | A special form rec for recursive evaluation | [`(srfi 31)`](./basis/srfi-31.ss) | | -| [ 34](https://srfi.schemers.org/srfi-34/srfi-34.html) | Exception Handling for Programs | [`(srfi 34)`](./basis/srfi-34.ss) | R7RS 6.11 | -| [ 38](https://srfi.schemers.org/srfi-38/srfi-38.html) | External Representation for Data With Shared Structure | [`(srfi 38)`](./basis/srfi-38.ss) | R7RS 6.13.3 | -| [ 39](https://srfi.schemers.org/srfi-39/srfi-39.html) | Parameter objects | [`(srfi 39)`](./basis/srfi-39.ss) | R7RS 4.2.6 | -| [ 45](https://srfi.schemers.org/srfi-45/srfi-45.html) | Primitives for Expressing Iterative Lazy Algorithms | [`(srfi 45)`](./basis/srfi-45.ss) | R7RS 4.2.5 | -| [ 62](https://srfi.schemers.org/srfi-62/srfi-62.html) | S-expression comments | | R7RS 2.2 | -| [ 78](https://srfi.schemers.org/srfi-78/srfi-78.html) | Lightweight testing | [`(srfi 78)`](./basis/srfi-78.ss) | Except `check-ec` | -| [ 87](https://srfi.schemers.org/srfi-87/srfi-87.html) | => in case clauses | | R7RS 4.2.1 | -| [ 98](https://srfi.schemers.org/srfi-98/srfi-98.html) | An interface to access environment variables | [`(srfi 98)`](./basis/srfi-98.ss) | R7RS 6.14 | -| [111](https://srfi.schemers.org/srfi-111/srfi-111.html) | Boxes | [`(srfi 111)`](./basis/srfi-111.ss) | [`(scheme box)`](./basis/r7rs.ss) | -| [149](https://srfi.schemers.org/srfi-149/srfi-149.html) | Basic syntax-rules template extensions | [`(srfi 149)`](./basis/srfi-149.ss) | R7RS 4.3.2 | +| Number | Title | Library name | Note | +|--------------------------------------------------------:|--------------------------------------------------------|-------------------------------------|------------------------------------| +| [ 0](https://srfi.schemers.org/srfi-0/srfi-0.html) | Feature-based conditional expansion construct | [`(srfi 0)`](./basis/srfi-0.ss) | R7RS 4.2.1 | +| [ 1](https://srfi.schemers.org/srfi-1/srfi-1.html) | List Library | [`(srfi 1)`](./basis/srfi-1.ss) | [`(scheme list)`](./basis/r7rs.ss) | +| [ 4](https://srfi.schemers.org/srfi-4/srfi-4.html) | Homogeneous numeric vector datatypes | [`(srfi 4)`](./basis/srfi-4.ss) | R7RS 6.9 | +| [ 6](https://srfi.schemers.org/srfi-6/srfi-6.html) | Basic String Ports | [`(srfi 6)`](./basis/srfi-6.ss) | R7RS 6.13 | +| [ 8](https://srfi.schemers.org/srfi-8/srfi-8.html) | receive: Binding to multiple values | [`(srfi 8)`](./basis/srfi-8.ss) | | +| [ 9](https://srfi.schemers.org/srfi-9/srfi-9.html) | Defining Record Types | [`(srfi 9)`](./basis/srfi-9.ss) | R7RS 5.5 | +| [ 10](https://srfi.schemers.org/srfi-10/srfi-10.html) | #, external form | | | +| [ 11](https://srfi.schemers.org/srfi-11/srfi-11.html) | Syntax for receiving multiple values | [`(srfi 11)`](./basis/srfi-11.ss) | R7RS 4.2.2 | +| [ 16](https://srfi.schemers.org/srfi-16/srfi-16.html) | Syntax for procedures of variable arity | [`(srfi 16)`](./basis/srfi-16.ss) | R7RS 4.2.9 | +| [ 23](https://srfi.schemers.org/srfi-23/srfi-23.html) | Error reporting mechanism | [`(srfi 23)`](./basis/srfi-23.ss) | R7RS 6.11 | +| [ 30](https://srfi.schemers.org/srfi-30/srfi-30.html) | Nested Multi-line Comments | | R7RS 2.2 | +| [ 31](https://srfi.schemers.org/srfi-31/srfi-31.html) | A special form rec for recursive evaluation | [`(srfi 31)`](./basis/srfi-31.ss) | | +| [ 34](https://srfi.schemers.org/srfi-34/srfi-34.html) | Exception Handling for Programs | [`(srfi 34)`](./basis/srfi-34.ss) | R7RS 6.11 | +| [ 38](https://srfi.schemers.org/srfi-38/srfi-38.html) | External Representation for Data With Shared Structure | [`(srfi 38)`](./basis/srfi-38.ss) | R7RS 6.13.3 | +| [ 39](https://srfi.schemers.org/srfi-39/srfi-39.html) | Parameter objects | [`(srfi 39)`](./basis/srfi-39.ss) | R7RS 4.2.6 | +| [ 45](https://srfi.schemers.org/srfi-45/srfi-45.html) | Primitives for Expressing Iterative Lazy Algorithms | [`(srfi 45)`](./basis/srfi-45.ss) | R7RS 4.2.5 | +| [ 62](https://srfi.schemers.org/srfi-62/srfi-62.html) | S-expression comments | | R7RS 2.2 | +| [ 78](https://srfi.schemers.org/srfi-78/srfi-78.html) | Lightweight testing | [`(srfi 78)`](./basis/srfi-78.ss) | Except `check-ec` | +| [ 87](https://srfi.schemers.org/srfi-87/srfi-87.html) | => in case clauses | | R7RS 4.2.1 | +| [ 98](https://srfi.schemers.org/srfi-98/srfi-98.html) | An interface to access environment variables | [`(srfi 98)`](./basis/srfi-98.ss) | R7RS 6.14 | +| [111](https://srfi.schemers.org/srfi-111/srfi-111.html) | Boxes | [`(srfi 111)`](./basis/srfi-111.ss) | [`(scheme box)`](./basis/r7rs.ss) | +| [149](https://srfi.schemers.org/srfi-149/srfi-149.html) | Basic syntax-rules template extensions | [`(srfi 149)`](./basis/srfi-149.ss) | R7RS 4.3.2 | ## Installation @@ -91,7 +91,7 @@ Procedures for each standard are provided by the following R7RS-style libraries: cmake -B build -DCMAKE_BUILD_TYPE=Release cd build make package -sudo apt install build/meevax_0.5.35_amd64.deb +sudo apt install build/meevax_0.5.59_amd64.deb ``` or @@ -123,9 +123,9 @@ sudo rm -rf /usr/local/share/meevax | Target Name | Description |-------------|------------- -| `all` | Build shared-library `libmeevax.0.5.35.so` and executable `meevax` +| `all` | Build shared-library `libmeevax.0.5.59.so` and executable `meevax` | `test` | Test executable `meevax` -| `package` | Generate debian package `meevax_0.5.35_amd64.deb` +| `package` | Generate debian package `meevax_0.5.59_amd64.deb` | `install` | Copy files into `/usr/local` directly ## Usage diff --git a/VERSION b/VERSION index 0defa4dc0..9904b4381 100644 --- a/VERSION +++ b/VERSION @@ -1 +1 @@ -0.5.35 +0.5.59 diff --git a/basis/] b/basis/] new file mode 100644 index 000000000..e69de29bb diff --git a/basis/r7rs.ss b/basis/r7rs.ss index 1738f4a7e..22353c49b 100644 --- a/basis/r7rs.ss +++ b/basis/r7rs.ss @@ -2,7 +2,7 @@ (import (only (meevax core) include include-case-insensitive) (only (meevax error) error-object? read-error? file-error?) (only (meevax macro-transformer) er-macro-transformer) - (only (meevax list) make-list) + (only (meevax list) make-list list-copy) (only (meevax number) exact-integer? exact-integer-square-root) (only (meevax port) binary-port? eof-object flush get-output-u8vector open-input-u8vector open-output-u8vector open? port? standard-error-port standard-input-port standard-output-port textual-port?) (prefix (meevax read) %) @@ -191,13 +191,6 @@ (define (list-set! xs k x) (set-car! (list-tail xs k) x)) - (define (list-copy x) - (let list-copy ((x x)) - (if (pair? x) - (cons (car x) - (list-copy (cdr x))) - x))) - (define symbol=? eqv?) (define bytevector? u8vector?) @@ -472,6 +465,29 @@ (import (srfi 45)) (export delay (rename lazy delay-force) force promise? (rename eager make-promise))) +(define-library (scheme list) + (import (srfi 1)) + (export cons list xcons cons* make-list list-tabulate list-copy circular-list + iota pair? null? proper-list? circular-list? dotted-list? not-pair? + null-list? list= car cdr caar cadr cdar cddr caaar caadr cadar caddr + cdaar cdadr cddar cdddr caaaar caaadr caadar caaddr cadaar cadadr + caddar cadddr cdaaar cdaadr cdadar cdaddr cddaar cddadr cdddar cddddr + list-ref first second third fourth fifth sixth seventh eighth ninth + tenth car+cdr take take! take-right drop drop-right drop-right! + split-at split-at! last last-pair length length+ append append! + concatenate concatenate! reverse reverse! append-reverse + append-reverse! zip unzip1 unzip2 unzip3 unzip4 unzip5 count map map! + filter-map map-in-order fold fold-right unfold unfold-right pair-fold + pair-fold-right reduce reduce-right append-map append-map! for-each + pair-for-each filter filter! partition partition! remove remove! memq + memv member find find-tail any every list-index take-while + take-while! drop-while span span! break break! delete delete! + delete-duplicates delete-duplicates! assq assv assoc alist-cons + alist-copy alist-delete alist-delete! lset<= lset= lset-adjoin + lset-union lset-union! lset-intersection lset-intersection! + lset-difference lset-difference! lset-xor lset-xor! + lset-diff+intersection lset-diff+intersection! set-car! set-cdr!)) + (define-library (scheme load) (import (only (scheme r5rs) load)) (export load)) diff --git a/basis/srfi-1.ss b/basis/srfi-1.ss index d5d71bc1a..c7e791bf9 100644 --- a/basis/srfi-1.ss +++ b/basis/srfi-1.ss @@ -7,923 +7,896 @@ |# (define-library (srfi 1) - (import (scheme base) - (scheme cxr) - (srfi 8)) - - (export cons list xcons cons* make-list list-tabulate list-copy circular-list - iota pair? null? proper-list? circular-list? dotted-list? not-pair? - null-list? list= car cdr caar cadr cdar cddr caaar caadr cadar caddr - cdaar cdadr cddar cdddr caaaar caaadr caadar caaddr cadaar cadadr - caddar cadddr cdaaar cdaadr cdadar cdaddr cddaar cddadr cdddar cddddr - list-ref first second third fourth fifth sixth seventh eighth ninth - tenth car+cdr take drop take-right drop-right take! drop-right! - split-at split-at! last last-pair length length+ append concatenate - reverse append! concatenate! reverse! append-reverse append-reverse! - zip unzip1 unzip2 unzip3 unzip4 unzip5 count map for-each fold unfold - pair-fold reduce fold-right unfold-right pair-fold-right reduce-right - append-map append-map! map! pair-for-each filter-map map-in-order - filter partition remove filter! partition! remove! member memq memv - find find-tail any every list-index take-while drop-while take-while! - span break span! break! delete delete-duplicates delete! - delete-duplicates! assoc assq assv alist-cons alist-copy alist-delete - alist-delete! lset<= lset= lset-adjoin lset-union lset-union! - lset-intersection lset-intersection! lset-difference lset-difference! - lset-xor lset-xor! lset-diff+intersection lset-diff+intersection! + (import (only (meevax boolean) not) + (only (meevax core) begin call-with-current-continuation! define if lambda letrec quote set!) + (only (meevax list) + alist-cons alist-copy append append! append-reverse append-reverse! + assq assv circular-list circular-list? concatenate concatenate! + dotted-list? drop drop-right drop-right! eighth fifth first fourth + iota last last-pair length length+ list list? list-copy list-ref + make-list memq memv ninth null? null-list? reverse reverse! second + seventh sixth take take! take-right tenth third) + (only (meevax pair) + car cdr caar cadr cdar cddr caaar caadr cadar caddr cdaar cdadr + cddar cdddr caaaar caaadr caadar caaddr cadaar cadadr caddar cadddr + cdaaar cdaadr cdadar cdaddr cddaar cddadr cdddar cddddr cons cons* + not-pair? pair? set-car! set-cdr! xcons) + (only (scheme r5rs) + cond and or let let* eqv? eq? equal? = < zero? + - member assoc + apply map for-each values) + (only (srfi 8) receive) + (only (srfi 23) error)) + + (export ; Constructors + cons list xcons cons* make-list list-tabulate list-copy circular-list + iota + + ; Predicates + pair? null? proper-list? circular-list? dotted-list? not-pair? + null-list? list= + + ; Selectors + car cdr caar cadr cdar cddr caaar caadr cadar caddr cdaar cdadr cddar + cdddr caaaar caaadr caadar caaddr cadaar cadadr caddar cadddr cdaaar + cdaadr cdadar cdaddr cddaar cddadr cdddar cddddr + list-ref + first second third fourth fifth sixth seventh eighth ninth tenth + car+cdr + take take! take-right + drop drop-right drop-right! + split-at split-at! + last last-pair + + ; Miscellaneous: length, append, concatenate, reverse, zip & count + length length+ + append append! + concatenate concatenate! + reverse reverse! + append-reverse append-reverse! + zip unzip1 unzip2 unzip3 unzip4 unzip5 + count + + ; Fold, unfold & map + map map! filter-map map-in-order + fold fold-right + unfold unfold-right + pair-fold pair-fold-right + reduce reduce-right + append-map append-map! + for-each pair-for-each + + ; Filtering & partitioning + filter filter! + partition partition! + remove remove! + + ; Searching + memq memv member + find find-tail + any every list-index + take-while take-while! + drop-while + span span! + break break! + + ; Deleting + delete delete! + delete-duplicates delete-duplicates! + + ; Association lists + assq assv assoc alist-cons alist-copy alist-delete alist-delete! + + ; Set operations on lists + lset<= lset= + lset-adjoin + lset-union lset-union! + lset-intersection lset-intersection! + lset-difference lset-difference! + lset-xor lset-xor! + lset-diff+intersection lset-diff+intersection! + + ; Primitive side-effects set-car! set-cdr!) - (begin (define (xcons x y) - (cons y x)) - - (define (tree-copy x) - (letrec ((tree-copy (lambda (x) - (if (not (pair? x)) x - (cons (tree-copy (car x)) - (tree-copy (cdr x))))))) - (tree-copy x))) - - (define (list-tabulate len proc) - (do ((i (- len 1) (- i 1)) - (ans '() (cons (proc i) ans))) - ((< i 0) ans))) - - (define (cons* x . xs) - (let cons* ((x x) - (xs xs)) - (if (pair? xs) - (cons x (cons* (car xs) - (cdr xs))) - x))) - - (define (circular-list val1 . vals) - (let ((ans (cons val1 vals))) - (set-cdr! (last-pair ans) ans) - ans)) - - (define (iota count . maybe-start+step) - (if (< count 0) (error "Negative step count" iota count)) - (let-optionals maybe-start+step ((start 0) (step 1)) - (let loop ((n 0) (r '())) - (if (= n count) - (reverse r) - (loop (+ 1 n) - (cons (+ start (* n step)) r)))))) + (begin (define (list-tabulate k f) + (let recur ((i 0)) + (if (< i k) + (cons (f i) + (recur (+ i 1))) + '()))) (define proper-list? list?) - (define (dotted-list? x) - (let rec ((x x) (lag x)) - (if (pair? x) - (let ((x (cdr x))) - (if (pair? x) - (let ((x (cdr x)) - (lag (cdr lag))) - (and (not (eq? x lag)) (rec x lag))) - (not (null? x)))) - (not (null? x))))) - - (define (circular-list? x) - (let rec ((x x) - (y x)) - (and (pair? x) - (let ((x (cdr x))) - (and (pair? x) - (let ((x (cdr x)) - (y (cdr y))) - (or (eq? x y) - (rec x y)))))))) - - (define (not-pair? x) (not (pair? x))) - - (define (null-list? x) - (cond ((pair? x) #f) - ((null? x) #t) - (else (error "argument out of domain" (list 'null-list? x))))) - - (define (list= = . lists) - (or (null? lists) ; special case - (let lp1 ((list-a (car lists)) - (others (cdr lists))) - (or (null? others) - (let ((list-b (car others)) - (others (cdr others))) - (if (eq? list-a list-b) ; EQ? => LIST= - (lp1 list-b others) - (let lp2 ((pair-a list-a) - (pair-b list-b)) - (if (null-list? pair-a) - (and (null-list? pair-b) - (lp1 list-b others)) - (and (not (null-list? pair-b)) - (= (car pair-a) - (car pair-b)) - (lp2 (cdr pair-a) - (cdr pair-b))))))))))) - - (define first car) - - (define second cadr) - - (define third caddr) - - (define fourth cadddr) - - (define (fifth x) - (car (cddddr x))) - - (define (sixth x) - (cadr (cddddr x))) - - (define (seventh x) - (caddr (cddddr x))) - - (define (eighth x) - (cadddr (cddddr x))) - - (define (ninth x) - (car (cddddr (cddddr x)))) - - (define (tenth x) - (cadr (cddddr (cddddr x)))) + (define (list= x=? . xss) + (or (null? xss) + (let outer ((xs (car xss)) + (xss (cdr xss))) + (or (null? xss) + (let ((ys (car xss)) + (xss (cdr xss))) + (if (eq? xs ys) + (outer ys xss) + (let inner ((a xs) + (b ys)) + (if (null-list? a) + (and (null-list? b) + (outer ys xss)) + (and (not (null-list? b)) + (x=? (car a) + (car b)) + (inner (cdr a) + (cdr b))))))))))) (define (car+cdr pair) (values (car pair) (cdr pair))) - (define (take x k) - (let rec ((x x) - (k k)) - (if (zero? k) '() - (cons (car x) - (rec (cdr x) (- k 1)))))) - - (define (take! x k) + (define (split-at xs k) (if (zero? k) - (begin (set-cdr! (drop x (- k 1)) '()) x))) - - (define (drop x k) - (let rec ((x x) (k k)) - (if (zero? k) x - (rec (cdr x) (- k 1))))) - - (define (drop! lis k) - (if (negative? k) - (let ((nelts (+ k (length lis)))) - (if (zero? nelts) '() - (begin (set-cdr! (list-tail lis (- nelts 1)) '()) - lis))) - (list-tail lis k))) - - (define (take-right x k) - (let lp ((lag x) - (lead (drop x k))) - (if (pair? lead) - (lp (cdr lag) - (cdr lead)) - lag))) - - (define (drop-right x k) - (let rec ((lag x) (lead (drop x k))) - (if (pair? lead) - (cons (car lag) - (rec (cdr lag) (cdr lead))) - '()))) - - (define (drop-right! x k) - (let ((lead (drop x k))) - (if (pair? lead) - (let rec ((lag x) - (lead (cdr lead))) - (if (pair? lead) - (rec (cdr lag) - (cdr lead)) - (begin (set-cdr! lag '()) x))) - '()))) - - (define (split-at x k) - (let recur ((lis x) (k k)) - (if (zero? k) (values '() lis) - (receive (prefix suffix) (recur (cdr lis) (- k 1)) - (values (cons (car lis) prefix) suffix))))) + (values '() xs) + (receive (a b) (split-at (cdr xs) + (- k 1)) + (values (cons (car xs) + a) + b)))) (define (split-at! x k) (if (zero? k) (values '() x) - (let* ((prev (drop x (- k 1))) - (suffix (cdr prev))) - (set-cdr! prev '()) + (let* ((prefix-last (drop x (- k 1))) + (suffix (cdr prefix-last))) + (set-cdr! prefix-last '()) (values x suffix)))) - (define (last x) (car (last-pair x))) - - (define (last-pair lis) - (let rec ((lis lis)) - (let ((tail (cdr lis))) - (if (pair? tail) (rec tail) lis)))) - - (define (length+ x) ; Returns #f if X is circular. - (let rec ((x x) (lag x) (len 0)) - (if (pair? x) - (let ((x (cdr x)) - (len (+ len 1))) - (if (pair? x) - (let ((x (cdr x)) - (lag (cdr lag)) - (len (+ len 1))) - (and (not (eq? x lag)) (rec x lag len))) - len)) - len))) - - (define (append! . lists) - (let lp ((lists lists) (prev '())) ; First, scan through lists looking for a non-empty one. - (if (not (pair? lists)) prev - (let ((first (car lists)) - (rest (cdr lists))) - (if (not (pair? first)) (lp rest first) - (let lp2 ((tail-cons (last-pair first)) ; Now, do the splicing. - (rest rest)) - (if (pair? rest) - (let ((next (car rest)) - (rest (cdr rest))) - (set-cdr! tail-cons next) - (lp2 (if (pair? next) (last-pair next) tail-cons) - rest)) - first))))))) - - (define (concatenate xs) - (reduce-right append '() xs)) - - (define (concatenate! xs) - (reduce-right append! '() xs)) - - (define (reverse! lis) - (let lp ((lis lis) (ans '())) - (if (null-list? lis) ans - (let ((tail (cdr lis))) - (set-cdr! lis ans) - (lp tail lis))))) - - (define (append-reverse rev-head tail) - (let lp ((rev-head rev-head) (tail tail)) - (if (null-list? rev-head) tail - (lp (cdr rev-head) (cons (car rev-head) tail))))) - - (define (append-reverse! rev-head tail) - (let lp ((rev-head rev-head) (tail tail)) - (if (null-list? rev-head) tail - (let ((next-rev (cdr rev-head))) - (set-cdr! rev-head tail) - (lp next-rev rev-head))))) - - (define (zip list1 . more-lists) - (apply map list list1 more-lists)) - - (define (unzip1 lis) - (map car lis)) - - (define (unzip2 lis) - (let recur ((lis lis)) - (if (null-list? lis) (values lis lis) ; Use NOT-PAIR? to handle - (let ((elt (car lis))) ; dotted lists. - (receive (a b) (recur (cdr lis)) - (values (cons (car elt) a) - (cons (cadr elt) b))))))) - - (define (unzip3 lis) - (let recur ((lis lis)) - (if (null-list? lis) (values lis lis lis) - (let ((elt (car lis))) - (receive (a b c) (recur (cdr lis)) - (values (cons (car elt) a) - (cons (cadr elt) b) - (cons (caddr elt) c))))))) - - (define (unzip4 lis) - (let recur ((lis lis)) - (if (null-list? lis) (values lis lis lis lis) - (let ((elt (car lis))) - (receive (a b c d) (recur (cdr lis)) - (values (cons (car elt) a) - (cons (cadr elt) b) - (cons (caddr elt) c) - (cons (cadddr elt) d))))))) - - (define (unzip5 lis) - (let recur ((lis lis)) - (if (null-list? lis) (values lis lis lis lis lis) - (let ((elt (car lis))) - (receive (a b c d e) (recur (cdr lis)) - (values (cons (car elt) a) - (cons (cadr elt) b) - (cons (caddr elt) c) - (cons (cadddr elt) d) - (cons (car (cddddr elt)) e))))))) - - (define (count pred list1 . lists) - (if (pair? lists) - (let lp ((list1 list1) (lists lists) (i 0)) - (if (null-list? list1) i - (receive (as ds) (%cars+cdrs lists) - (if (null? as) i - (lp (cdr list1) ds - (if (apply pred (car list1) as) (+ i 1) i)))))) - (let lp ((lis list1) (i 0)) - (if (null-list? lis) i - (lp (cdr lis) (if (pred (car lis)) (+ i 1) i)))))) - - (define (fold kons knil lis1 . lists) - (if (pair? lists) - (let lp ((lists (cons lis1 lists)) (ans knil)) - (receive (cars+ans cdrs) (%cars+cdrs+ lists ans) - (if (null? cars+ans) ans ; Done. - (lp cdrs (apply kons cars+ans))))) - (let lp ((lis lis1) (ans knil)) - (if (null-list? lis) ans - (lp (cdr lis) (kons (car lis) ans)))))) - - (define (unfold p f g seed . maybe-tail-gen) - (if (pair? maybe-tail-gen) - (let ((tail-gen (car maybe-tail-gen))) - (if (pair? (cdr maybe-tail-gen)) - (apply error "Too many arguments" unfold p f g seed maybe-tail-gen) - (let recur ((seed seed)) - (if (p seed) (tail-gen seed) - (cons (f seed) (recur (g seed))))))) + (define (zip x . xs) + (apply map list x xs)) + + (define (unzip1 xs) + (map car xs)) + + (define (unzip2 xs) + (let unzip2 ((xs xs)) + (if (null-list? xs) + (values xs xs) + (let ((x (car xs))) + (receive (a b) (unzip2 (cdr xs)) + (values (cons (car x) a) + (cons (cadr x) b))))))) + + (define (unzip3 xs) + (let unzip3 ((xs xs)) + (if (null-list? xs) + (values xs xs xs) + (let ((x (car xs))) + (receive (a b c) (unzip3 (cdr xs)) + (values (cons (car x) a) + (cons (cadr x) b) + (cons (caddr x) c))))))) + + (define (unzip4 xs) + (let unzip4 ((xs xs)) + (if (null-list? xs) + (values xs xs xs xs) + (let ((x (car xs))) + (receive (a b c d) (unzip4 (cdr xs)) + (values (cons (car x) a) + (cons (cadr x) b) + (cons (caddr x) c) + (cons (cadddr x) d))))))) + + (define (unzip5 xs) + (let unzip5 ((xs xs)) + (if (null-list? xs) + (values xs xs xs xs xs) + (let ((x (car xs))) + (receive (a b c d e) (unzip5 (cdr xs)) + (values (cons (car x) a) + (cons (cadr x) b) + (cons (caddr x) c) + (cons (cadddr x) d) + (cons (car (cddddr x)) e))))))) + + (define (count satisfy? x . xs) + (if (pair? xs) + (let recur ((x x) + (xs xs) + (i 0)) + (if (null-list? x) + i + (receive (as ds) (%cars+cdrs xs) + (if (null? as) i + (recur (cdr x) + ds + (if (apply satisfy? (car x) as) + (+ i 1) + i)))))) + (let recur ((x x) + (i 0)) + (if (null-list? x) + i + (recur (cdr x) + (if (satisfy? (car x)) + (+ i 1) + i)))))) + + (define (fold f z x . xs) + (if (pair? xs) + (let recur ((xs (cons x xs)) + (ans z)) + (receive (cars+ans cdrs) (%cars+cdrs+ xs ans) + (if (null? cars+ans) + ans + (recur cdrs (apply f cars+ans))))) + (let recur ((x x) + (ans z)) + (if (null-list? x) + ans + (recur (cdr x) + (f (car x) ans)))))) + + (define (unfold p f g seed . generate) + (if (pair? generate) + (let ((generate (car generate))) + (let recur ((seed seed)) + (if (p seed) + (generate seed) + (cons (f seed) + (recur (g seed)))))) (let recur ((seed seed)) - (if (p seed) '() - (cons (f seed) (recur (g seed))))))) - - (define (pair-fold f zero lis1 . lists) - (if (pair? lists) - (let lp ((lists (cons lis1 lists)) (ans zero)) - (let ((tails (%cdrs lists))) - (if (null? tails) ans - (lp tails (apply f (append! lists (list ans))))))) - - (let lp ((lis lis1) (ans zero)) - (if (null-list? lis) ans - (let ((tail (cdr lis))) - (lp tail (f lis ans))))))) - - (define (reduce f ridentity lis) - (if (null-list? lis) ridentity - (fold f (car lis) (cdr lis)))) - - (define (fold-right f knil x . xs) + (if (p seed) + '() + (cons (f seed) + (recur (g seed))))))) + + (define (pair-fold f z x . xs) + (if (pair? xs) + (let recur ((xs (cons x xs)) + (ans z)) + (let ((tails (%cdrs xs))) + (if (null? tails) + ans + (recur tails (apply f (append! xs (list ans))))))) + (let recur ((x x) + (ans z)) + (if (null-list? x) + ans + (let ((tail (cdr x))) + (recur tail (f x ans))))))) + + (define (reduce f ridentity x) + (if (null-list? x) + ridentity + (fold f (car x) (cdr x)))) + + (define (fold-right f z x . xs) + (if (pair? xs) + (let recur ((xs (cons x xs))) + (let ((cdrs (%cdrs xs))) + (if (null? cdrs) + z + (apply f (%cars+ xs (recur cdrs)))))) + (let recur ((xs x)) + (if (null-list? xs) + z + (let ((x (car xs))) + (f x (recur (cdr xs)))))))) + + (define (unfold-right p f g seed . tail) + (let recur ((seed seed) + (ans (if (pair? tail) + (car tail) + '()))) + (if (p seed) + ans + (recur (g seed) + (cons (f seed) ans))))) + + (define (pair-fold-right f z x . xs) (if (pair? xs) - (letrec ((recur (lambda (lists) - ((lambda (cdrs) - (if (null? cdrs) knil - (apply f (%cars+ lists (recur cdrs))))) - (%cdrs lists))))) - (recur (cons x xs))) - (letrec ((recur (lambda (x) - (if (null-list? x) knil - ((lambda (head) - (f head (recur (cdr x)))) - (car x)))))) - (recur x)))) - - (define (unfold-right p f g seed . maybe-tail) - (let lp ((seed seed) - (ans (if (pair? maybe-tail) (car maybe-tail) '()))) - (if (p seed) ans - (lp (g seed) - (cons (f seed) ans))))) - - (define (pair-fold-right f zero lis1 . lists) - (if (pair? lists) - (let recur ((lists (cons lis1 lists))) - (let ((cdrs (%cdrs lists))) - (if (null? cdrs) zero - (apply f (append! lists (list (recur cdrs))))))) - (let recur ((lis lis1)) - (if (null-list? lis) zero (f lis (recur (cdr lis))))))) - - (define (reduce-right f ridentity lis) - (if (null-list? lis) ridentity - (let recur ((head (car lis)) (lis (cdr lis))) - (if (pair? lis) - (f head (recur (car lis) (cdr lis))) - head)))) - - (define (append-map f lis1 . lists) - (really-append-map append-map append f lis1 lists)) - - (define (append-map! f lis1 . lists) - (really-append-map append-map! append! f lis1 lists)) - - (define (really-append-map who appender f lis0 lists) - (if (pair? lists) - (receive (cars cdrs) (%cars+cdrs (cons lis1 lists)) - (if (null? cars) '() - (let recur ((cars cars) (cdrs cdrs)) - (let ((vals (apply f cars))) - (receive (cars2 cdrs2) (%cars+cdrs cdrs) - (if (null? cars2) vals - (appender vals (recur cars2 cdrs2)))))))) - (if (null-list? lis1) '() - (let recur ((elt (car lis1)) (rest (cdr lis1))) - (let ((vals (f elt))) - (if (null-list? rest) vals - (appender vals (recur (car rest) (cdr rest))))))))) - - (define (map! f lis1 . lists) - (if (pair? lists) - (let lp ((lis1 lis1) (lists lists)) - (if (not (null-list? lis1)) - (receive (heads tails) (%cars+cdrs/no-test lists) - (set-car! lis1 (apply f (car lis1) heads)) - (lp (cdr lis1) tails)))) - (pair-for-each (lambda (pair) (set-car! pair (f (car pair)))) lis1)) - lis1) - - (define (pair-for-each proc lis1 . lists) - (if (pair? lists) - (let lp ((lists (cons lis1 lists))) - (let ((tails (%cdrs lists))) + (let recur ((xs (cons x xs))) + (let ((cdrs (%cdrs xs))) + (if (null? cdrs) + z + (apply f (append! xs (list (recur cdrs))))))) + (let recur ((x x)) + (if (null-list? x) + z + (f x (recur (cdr x))))))) + + (define (reduce-right f ridentity xs) + (if (null-list? xs) + ridentity + (let reduce-right ((x (car xs)) + (xs (cdr xs))) + (if (pair? xs) + (f x (reduce-right (car xs) + (cdr xs))) + x)))) + + (define (append-map f x . xs) + (%append-map append-map append f x xs)) + + (define (append-map! f x . xs) + (%append-map append-map! append! f x xs)) + + (define (%append-map who appender f x xs) + (if (pair? xs) + (receive (cars cdrs) (%cars+cdrs (cons x xs)) + (if (null? cars) + '() + (let recur ((cars cars) + (cdrs cdrs)) + (let ((vals (apply f cars))) + (receive (cars2 cdrs2) (%cars+cdrs cdrs) + (if (null? cars2) + vals + (appender vals (recur cars2 cdrs2)))))))) + (if (null-list? x) + '() + (let recur ((x (car x)) + (xs (cdr x))) + (let ((vals (f x))) + (if (null-list? xs) + vals + (appender vals + (recur (car xs) + (cdr xs))))))))) + + (define (map! f x . xs) + (if (pair? xs) + (let recur ((x x) + (xs xs)) + (if (not (null-list? x)) + (receive (heads tails) (%cars+cdrs/no-test xs) + (set-car! x (apply f (car x) heads)) + (recur (cdr x) + tails)))) + (pair-for-each (lambda (pair) + (set-car! pair (f (car pair)))) + x)) + x) + + (define (pair-for-each f x . xs) + (if (pair? xs) + (let recur ((xs (cons x xs))) + (let ((tails (%cdrs xs))) (if (pair? tails) - (begin (apply proc lists) - (lp tails))))) - (let lp ((lis lis1)) - (if (not (null-list? lis)) - (let ((tail (cdr lis))) - (proc lis) - (lp tail)))))) - - (define (filter-map f lis1 . lists) - (if (pair? lists) - (let recur ((lists (cons lis1 lists))) - (receive (cars cdrs) (%cars+cdrs lists) - (if (pair? cars) - (cond ((apply f cars) => (lambda (x) (cons x (recur cdrs)))) - (else (recur cdrs))) ; Tail call in this arm. - '()))) - (let recur ((lis lis1)) - (if (null-list? lis) lis - (let ((tail (recur (cdr lis)))) - (cond ((f (car lis)) => (lambda (x) (cons x tail))) + (begin (apply f xs) + (recur tails))))) + (let recur ((x x)) + (if (not (null-list? x)) + (let ((tail (cdr x))) + (f x) + (recur tail)))))) + + (define (filter-map f x . xs) + (if (pair? xs) + (let recur ((xs (cons x xs))) + (receive (cars cdrs) (%cars+cdrs xs) + (if (pair? cars) + (cond ((apply f cars) => (lambda (x) (cons x (recur cdrs)))) + (else (recur cdrs))) + '()))) + (let recur ((x x)) + (if (null-list? x) x + (let ((tail (recur (cdr x)))) + (cond ((f (car x)) => (lambda (x) (cons x tail))) (else tail))))))) - (define (map-in-order f lis1 . lists) - (if (pair? lists) - (let recur ((lists (cons lis1 lists))) - (receive (cars cdrs) (%cars+cdrs lists) - (if (pair? cars) - (let ((x (apply f cars))) - (cons x (recur cdrs))) - '()))) - (let recur ((lis lis1)) - (if (null-list? lis) lis - (let ((tail (cdr lis)) - (x (f (car lis)))) + (define (map-in-order f x . xs) + (if (pair? xs) + (let recur ((xs (cons x xs))) + (receive (cars cdrs) (%cars+cdrs xs) + (if (pair? cars) + (let ((x (apply f cars))) + (cons x (recur cdrs))) + '()))) + (let recur ((x x)) + (if (null-list? x) x + (let ((tail (cdr x)) + (x (f (car x)))) (cons x (recur tail))))))) - (define (filter pred lis) - (let recur ((lis lis)) - (if (null-list? lis) lis - (let ((head (car lis)) - (tail (cdr lis))) - (if (pred head) + (define (filter satisfy? x) + (let recur ((x x)) + (if (null-list? x) + x + (let ((head (car x)) + (tail (cdr x))) + (if (satisfy? head) (let ((new-tail (recur tail))) - (if (eq? tail new-tail) lis + (if (eq? tail new-tail) + x (cons head new-tail))) (recur tail)))))) - ; (define (filter pred lis) ; Another version that shares longest tail. - ; (receive (ans no-del?) - ; (let recur ((l l)) - ; (if (null-list? l) (values l #t) - ; (let ((x (car l)) - ; (tl (cdr l))) - ; (if (pred x) - ; (receive (ans no-del?) (recur tl) - ; (if no-del? - ; (values l #t) - ; (values (cons x ans) #f))) - ; (receive (ans no-del?) (recur tl) ; Delete X. - ; (values ans #f)))))) - ; ans)) - - (define (partition pred lis) - (let recur ((lis lis)) - (if (null-list? lis) (values lis lis) ; Use NOT-PAIR? to handle dotted lists. - (let ((elt (car lis)) - (tail (cdr lis))) - (receive (in out) (recur tail) - (if (pred elt) - (values (if (pair? out) (cons elt in) lis) out) - (values in (if (pair? in) (cons elt out) lis)))))))) - - (define (remove satisfy? x) - (filter (lambda (y) (not (satisfy? y))) x)) - - ; Things are much simpler if you are willing to push N stack frames & do N - ; set-cdr! writes, where N is the length of the answer. - (define (filter! pred lis) - (let recur ((lis lis)) - (if (pair? lis) - (cond ((pred (car lis)) - (set-cdr! lis (recur (cdr lis))) - lis) - (else (recur (cdr lis)))) - lis))) - - ; (define (filter! pred lis) - ; (let lp ((ans lis)) - ; (cond ((null-list? ans) ans) - ; ((not (pred (car ans))) (lp (cdr ans))) - ; (else (letrec ((scan-in (lambda (prev lis) - ; (if (pair? lis) - ; (if (pred (car lis)) - ; (scan-in lis (cdr lis)) - ; (scan-out prev (cdr lis)))))) - ; (scan-out (lambda (prev lis) - ; (let lp ((lis lis)) - ; (if (pair? lis) - ; (if (pred (car lis)) - ; (begin (set-cdr! prev lis) - ; (scan-in lis (cdr lis))) - ; (lp (cdr lis))) - ; (set-cdr! prev lis)))))) - ; (scan-in ans (cdr ans)) - ; ans))))) - - (define (partition! pred lis) - (if (null-list? lis) - (values lis lis) - (letrec ((scan-in (lambda (in-prev out-prev lis) - (let lp ((in-prev in-prev) (lis lis)) - (if (pair? lis) - (if (pred (car lis)) - (lp lis (cdr lis)) - (begin (set-cdr! out-prev lis) - (scan-out in-prev lis (cdr lis)))) - (set-cdr! out-prev lis))))) - (scan-out (lambda (in-prev out-prev lis) - (let lp ((out-prev out-prev) (lis lis)) - (if (pair? lis) - (if (pred (car lis)) - (begin (set-cdr! in-prev lis) - (scan-in lis out-prev (cdr lis))) - (lp lis (cdr lis))) - (set-cdr! in-prev lis)))))) - (if (pred (car lis)) - (let lp ((prev-l lis) (l (cdr lis))) - (cond ((not (pair? l)) (values lis l)) - ((pred (car l)) (lp l (cdr l))) + (define (filter! satisfy? xs) + (let recur ((xs xs)) + (if (pair? xs) + (cond ((satisfy? (car xs)) + (set-cdr! xs (recur (cdr xs))) + xs) + (else (recur (cdr xs)))) + xs))) + + (define (partition satisfy? xs) + (let recur ((xs xs)) + (if (null-list? xs) + (values xs xs) + (let ((x (car xs))) + (receive (a b) (recur (cdr xs)) + (if (satisfy? x) + (values (if (pair? b) + (cons x a) + xs) + b) + (values a + (if (pair? a) + (cons x b) + xs)))))))) + + (define (partition! satisfy? xs) + (if (null-list? xs) + (values xs xs) + (letrec ((scan-in (lambda (in-prev out-prev xs) + (let recur ((in-prev in-prev) + (xs xs)) + (if (pair? xs) + (if (satisfy? (car xs)) + (recur xs (cdr xs)) + (begin (set-cdr! out-prev xs) + (scan-out in-prev xs (cdr xs)))) + (set-cdr! out-prev xs))))) + (scan-out (lambda (in-prev out-prev xs) + (let recur ((out-prev out-prev) + (xs xs)) + (if (pair? xs) + (if (satisfy? (car xs)) + (begin (set-cdr! in-prev xs) + (scan-in xs out-prev (cdr xs))) + (recur xs (cdr xs))) + (set-cdr! in-prev xs)))))) + (if (satisfy? (car xs)) + (let recur ((prev-l xs) + (l (cdr xs))) + (cond ((not (pair? l)) + (values xs l)) + ((satisfy? (car l)) + (recur l (cdr l))) (else (scan-out prev-l l (cdr l)) - (values lis l)))) - (let lp ((prev-l lis) (l (cdr lis))) - (cond ((not (pair? l)) (values l lis)) - ((pred (car l)) + (values xs l)))) + (let recur ((prev-l xs) + (l (cdr xs))) + (cond ((not (pair? l)) + (values l xs)) + ((satisfy? (car l)) (scan-in l prev-l (cdr l)) - (values l lis)) - (else (lp l (cdr l))))))))) + (values l xs)) + (else (recur l (cdr l))))))))) - (define (remove! satisfy? x) - (filter! (lambda (y) (not (satisfy? y))) x)) + (define (remove satisfy? xs) + (filter (lambda (x) + (not (satisfy? x))) + xs)) - (define (find pred list) - (cond ((find-tail pred list) => car) + (define (remove! satisfy? xs) + (filter! (lambda (x) + (not (satisfy? x))) + xs)) + + (define (find satisfy? xs) + (cond ((find-tail satisfy? xs) => car) (else #f))) - (define (find-tail pred list) - (let lp ((list list)) - (and (not (null-list? list)) - (if (pred (car list)) list - (lp (cdr list)))))) - - (define (any pred lis1 . lists) - (if (pair? lists) - (receive (heads tails) (%cars+cdrs (cons lis1 lists)) - (and (pair? heads) - (let lp ((heads heads) (tails tails)) - (receive (next-heads next-tails) (%cars+cdrs tails) - (if (pair? next-heads) - (or (apply pred heads) (lp next-heads next-tails)) - (apply pred heads)))))) - (and (not (null-list? lis1)) - (let lp ((head (car lis1)) (tail (cdr lis1))) + (define (find-tail satisfy? xs) + (let recur ((xs xs)) + (and (not (null-list? xs)) + (if (satisfy? (car xs)) + xs + (recur (cdr xs)))))) + + (define (any satisfy? x . xs) + (if (pair? xs) + (receive (cars cdrs) (%cars+cdrs (cons x xs)) + (and (pair? cars) + (let recur ((cars cars) + (cdrs cdrs)) + (receive (next-cars next-cdrs) (%cars+cdrs cdrs) + (if (pair? next-cars) + (or (apply satisfy? cars) + (recur next-cars + next-cdrs)) + (apply satisfy? cars)))))) + (and (not (null-list? x)) + (let recur ((head (car x)) + (tail (cdr x))) (if (null-list? tail) - (pred head) - (or (pred head) (lp (car tail) (cdr tail)))))))) - - (define (every pred lis1 . lists) - (if (pair? lists) - (receive (heads tails) (%cars+cdrs (cons lis1 lists)) - (or (not (pair? heads)) - (let lp ((heads heads) (tails tails)) - (receive (next-heads next-tails) (%cars+cdrs tails) - (if (pair? next-heads) - (and (apply pred heads) (lp next-heads next-tails)) - (apply pred heads)))))) - (or (null-list? lis1) - (let lp ((head (car lis1)) (tail (cdr lis1))) + (satisfy? head) + (or (satisfy? head) + (recur (car tail) + (cdr tail)))))))) + + (define (every satisfy? x . xs) + (if (pair? xs) + (receive (heads tails) (%cars+cdrs (cons x xs)) + (or (not (pair? heads)) + (let recur ((heads heads) + (tails tails)) + (receive (next-heads next-tails) (%cars+cdrs tails) + (if (pair? next-heads) + (and (apply satisfy? heads) + (recur next-heads next-tails)) + (apply satisfy? heads)))))) + (or (null-list? x) + (let recur ((head (car x)) + (tail (cdr x))) (if (null-list? tail) - (pred head) - (and (pred head) (lp (car tail) (cdr tail)))))))) - - (define (list-index pred lis1 . lists) - (if (pair? lists) - (let lp ((lists (cons lis1 lists)) (n 0)) - (receive (heads tails) (%cars+cdrs lists) - (and (pair? heads) - (if (apply pred heads) n - (lp tails (+ n 1)))))) - (let lp ((lis lis1) (n 0)) - (and (not (null-list? lis)) - (if (pred (car lis)) n (lp (cdr lis) (+ n 1))))))) - - (define (take-while pred lis) - (let recur ((lis lis)) - (if (null-list? lis) '() - (let ((x (car lis))) - (if (pred x) - (cons x (recur (cdr lis))) - '()))))) + (satisfy? head) + (and (satisfy? head) + (recur (car tail) + (cdr tail)))))))) - (define (drop-while pred lis) - (let lp ((lis lis)) - (if (null-list? lis) '() - (if (pred (car lis)) - (lp (cdr lis)) - lis)))) + (define (list-index satisfy? x . xs) + (if (pair? xs) + (let recur ((xs (cons x xs)) + (n 0)) + (receive (heads tails) (%cars+cdrs xs) + (and (pair? heads) + (if (apply satisfy? heads) + n + (recur tails (+ n 1)))))) + (let recur ((xs x) + (n 0)) + (and (not (null-list? xs)) + (if (satisfy? (car xs)) + n + (recur (cdr xs) + (+ n 1))))))) + + (define (take-while satisfy? xs) + (let recur ((xs xs)) + (if (null-list? xs) + '() + (let ((x (car xs))) + (if (satisfy? x) + (cons x (recur (cdr xs))) + '()))))) - (define (take-while! pred lis) - (if (or (null-list? lis) (not (pred (car lis)))) '() - (begin (let lp ((prev lis) (rest (cdr lis))) + (define (take-while! satisfy? xs) + (if (or (null-list? xs) + (not (satisfy? (car xs)))) + '() + (begin (let recur ((prev xs) + (rest (cdr xs))) (if (pair? rest) (let ((x (car rest))) - (if (pred x) (lp rest (cdr rest)) + (if (satisfy? x) + (recur rest (cdr rest)) (set-cdr! prev '()))))) - lis))) - - (define (span pred lis) - (let recur ((lis lis)) - (if (null-list? lis) (values '() '()) - (let ((x (car lis))) - (if (pred x) - (receive (prefix suffix) (recur (cdr lis)) - (values (cons x prefix) suffix)) - (values '() lis)))))) - - (define (break break? x) - (span (lambda (x) (not (break? x))) x)) - - (define (span! pred lis) - (if (or (null-list? lis) (not (pred (car lis)))) (values '() lis) - (let ((suffix (let lp ((prev lis) (rest (cdr lis))) - (if (null-list? rest) rest + xs))) + + (define (drop-while satisfy? xs) + (let recur ((xs xs)) + (if (null-list? xs) + '() + (if (satisfy? (car xs)) + (recur (cdr xs)) + xs)))) + + (define (span satisfy? xs) + (let recur ((xs xs)) + (if (null-list? xs) + (values '() '()) + (let ((x (car xs))) + (if (satisfy? x) + (receive (a b) (recur (cdr xs)) + (values (cons x a) b)) + (values '() xs)))))) + + (define (span! satisfy? xs) + (if (or (null-list? xs) + (not (satisfy? (car xs)))) + (values '() xs) + (let ((suffix (let recur ((prev xs) + (rest (cdr xs))) + (if (null-list? rest) + rest (let ((x (car rest))) - (if (pred x) (lp rest (cdr rest)) + (if (satisfy? x) + (recur rest (cdr rest)) (begin (set-cdr! prev '()) rest))))))) - (values lis suffix)))) + (values xs suffix)))) + + (define (break break? x) + (span (lambda (x) + (not (break? x))) + x)) (define (break! break? x) - (span! (lambda (x) (not (break? x))) x)) - - (define (delete x lis . maybe-=) - (let ((= (if (pair? maybe-=) (car maybe-=) equal?))) - (filter (lambda (y) (not (= x y))) lis))) - - (define (delete-duplicates lis . maybe-=) - (let ((elt= (if (pair? maybe-=) (car maybe-=) equal?))) - (let recur ((lis lis)) - (if (null-list? lis) lis - (let* ((x (car lis)) - (tail (cdr lis)) - (new-tail (recur (delete x tail elt=)))) - (if (eq? tail new-tail) lis (cons x new-tail))))))) - - (define (delete! x lis . maybe-=) - (let ((= (if (pair? maybe-=) (car maybe-=) equal?))) - (filter! (lambda (y) (not (= x y))) lis))) - - (define (delete-duplicates! lis maybe-=) - (let ((elt= (if (pair? maybe-=) (car maybe-=) equal?))) - (let recur ((lis lis)) - (if (null-list? lis) lis - (let* ((x (car lis)) - (tail (cdr lis)) - (new-tail (recur (delete! x tail elt=)))) - (if (eq? tail new-tail) lis (cons x new-tail))))))) - - (define (alist-cons key datum alist) - (cons (cons key datum) alist)) - - (define (alist-copy alist) - (map (lambda (each) - (cons (car each) - (cdr each))) - alist)) - - (define (alist-delete key alist . maybe-=) - (let ((= (if (pair? maybe-=) (car maybe-=) equal?))) - (filter (lambda (elt) (not (= key (car elt)))) alist))) - - (define (alist-delete! key alist . maybe-=) - (let ((= (if (pair? maybe-=) (car maybe-=) equal?))) - (filter! (lambda (elt) (not (= key (car elt)))) alist))) - - (define (lset<= = . lists) - (or (not (pair? lists)) ; 0-ary case - (let lp ((s1 (car lists)) (rest (cdr lists))) - (or (not (pair? rest)) - (let ((s2 (car rest)) (rest (cdr rest))) - (and (or (eq? s2 s1) ; Fast path - (%lset2<= = s1 s2)) ; Real test - (lp s2 rest))))))) - - (define (lset= = . lists) - (or (not (pair? lists)) ; 0-ary case - (let lp ((s1 (car lists)) (rest (cdr lists))) - (or (not (pair? rest)) - (let ((s2 (car rest)) - (rest (cdr rest))) - (and (or (eq? s1 s2) ; Fast path - (and (%lset2<= = s1 s2) (%lset2<= = s2 s1))) ; Real test - (lp s2 rest))))))) - - (define (lset-adjoin = lis . elts) - (fold (lambda (elt ans) (if (member elt ans =) ans (cons elt ans))) - lis elts)) - - (define (lset-union = . lists) - (reduce (lambda (lis ans) ; Compute ANS + LIS. - (cond ((null? lis) ans) ; Don't copy any lists - ((null? ans) lis) ; if we don't have to. - ((eq? lis ans) ans) - (else - (fold (lambda (elt ans) (if (any (lambda (x) (= x elt)) ans) - ans - (cons elt ans))) - ans lis)))) - '() lists)) - - (define (lset-union! = . lists) - (reduce (lambda (lis ans) ; Splice new elts of LIS onto the front of ANS. - (cond ((null? lis) ans) ; Don't copy any lists - ((null? ans) lis) ; if we don't have to. - ((eq? lis ans) ans) - (else - (pair-fold (lambda (pair ans) - (let ((elt (car pair))) - (if (any (lambda (x) (= x elt)) ans) - ans - (begin (set-cdr! pair ans) pair)))) - ans lis)))) - '() lists)) - - (define (lset-intersection = lis1 . lists) - (let ((lists (delete lis1 lists eq?))) ; Throw out any LIS1 vals. - (cond ((any null-list? lists) '()) ; Short cut - ((null? lists) lis1) ; Short cut + (span! (lambda (x) + (not (break? x))) + x)) + + (define (delete x xs . x=?) + (let ((x=? (if (pair? x=?) + (car x=?) + equal?))) + (filter (lambda (y) + (not (x=? x y))) + xs))) + + (define (delete! x xs . x=?) + (let ((x=? (if (pair? x=?) + (car x=?) + equal?))) + (filter! (lambda (y) + (not (x=? x y))) + xs))) + + (define (delete-duplicates xs . x=?) + (let ((x=? (if (pair? x=?) + (car x=?) + equal?))) + (let recur ((x:xs xs)) + (if (null-list? x:xs) + '() + (let* ((x (car x:xs)) + (xs (cdr x:xs)) + (ys (recur (delete x xs x=?)))) + (if (eq? xs ys) + x:xs + (cons x ys))))))) + + (define (delete-duplicates! xs . x=?) + (let ((x=? (if (pair? x=?) + (car x=?) + equal?))) + (let recur ((x:xs xs)) + (if (null-list? x:xs) + '() + (let* ((x (car x:xs)) + (xs (cdr x:xs)) + (ys (recur (delete! x xs x=?)))) + (if (eq? xs ys) + x:xs + (cons x ys))))))) + + (define (alist-delete key alist . key=?) + (let ((key=? (if (pair? key=?) + (car key=?) + equal?))) + (filter (lambda (x) + (not (key=? key (car x)))) + alist))) + + (define (alist-delete! key alist . key=?) + (let ((key=? (if (pair? key=?) + (car key=?) + equal?))) + (filter! (lambda (x) + (not (key=? key (car x)))) + alist))) + + (define (lset<= x=? . xss) + (or (not (pair? xss)) + (let recur ((xs (car xss)) + (xss (cdr xss))) + (or (not (pair? xss)) + (let ((ys (car xss)) + (xss (cdr xss))) + (and (or (eq? xs ys) + (%lset2<= x=? xs ys)) + (recur ys xss))))))) + + (define (lset= x=? . xss) + (or (not (pair? xss)) + (let recur ((xs (car xss)) + (xss (cdr xss))) + (or (not (pair? xss)) + (let ((ys (car xss)) + (xss (cdr xss))) + (and (or (eq? xs ys) + (and (%lset2<= x=? xs ys) + (%lset2<= x=? ys xs))) + (recur ys xss))))))) + + (define (lset-adjoin x=? xs . ys) + (fold (lambda (y xs) + (if (member y xs x=?) + xs + (cons y xs))) + xs + ys)) + + (define (lset-union x=? . xss) + (reduce (lambda (xs ys) + (cond ((null? xs) ys) + ((null? ys) xs) + ((eq? xs ys) ys) + (else (fold (lambda (x ys) + (if (any (lambda (y) + (x=? x y)) + ys) + ys + (cons x ys))) + ys + xs)))) + '() + xss)) + + (define (lset-union! x=? . xss) + (reduce (lambda (xs ys) + (cond ((null? xs) ys) + ((null? ys) xs) + ((eq? xs ys) ys) + (else (pair-fold (lambda (x:xs ys) + (let ((x (car x:xs))) + (if (any (lambda (y) + (x=? x y)) + ys) + ys + (begin (set-cdr! x:xs ys) + x:xs)))) + ys + xs)))) + '() + xss)) + + (define (lset-intersection x=? xs . xss) + (let ((xss (delete xs xss eq?))) + (cond ((any null-list? xss) '()) + ((null? xss) xs) (else (filter (lambda (x) - (every (lambda (lis) (member x lis =)) lists)) - lis1))))) - - (define (lset-intersection! = lis1 . lists) - (let ((lists (delete lis1 lists eq?))) ; Throw out any LIS1 vals. - (cond ((any null-list? lists) '()) ; Short cut - ((null? lists) lis1) ; Short cut + (every (lambda (xs) + (member x xs x=?)) + xss)) + xs))))) + + (define (lset-intersection! x=? xs . xss) + (let ((xss (delete xs xss eq?))) + (cond ((any null-list? xss) '()) + ((null? xss) xs) (else (filter! (lambda (x) - (every (lambda (lis) (member x lis =)) lists)) - lis1))))) - - (define (lset-difference = lis1 . lists) - (let ((lists (filter pair? lists))) ; Throw out empty lists. - (cond ((null? lists) lis1) ; Short cut - ((memq lis1 lists) '()) ; Short cut + (every (lambda (xs) + (member x xs x=?)) + xss)) + xs))))) + + (define (lset-difference x=? xs . xss) + (let ((xss (filter pair? xss))) + (cond ((null? xss) xs) + ((memq xs xss) '()) (else (filter (lambda (x) - (every (lambda (lis) (not (member x lis =))) - lists)) - lis1))))) - - (define (lset-difference! = lis1 . lists) - (let ((lists (filter pair? lists))) ; Throw out empty lists. - (cond ((null? lists) lis1) ; Short cut - ((memq lis1 lists) '()) ; Short cut + (every (lambda (xs) + (not (member x xs x=?))) + xss)) + xs))))) + + (define (lset-difference! x=? xs . xss) + (let ((xss (filter pair? xss))) + (cond ((null? xss) xs) + ((memq xs xss) '()) (else (filter! (lambda (x) - (every (lambda (lis) (not (member x lis =))) - lists)) - lis1))))) - - (define (lset-xor = . lists) - (reduce (lambda (b a) ; Compute A xor B: - ;; Note that this code relies on the constant-time - ;; short-cuts provided by LSET-DIFF+INTERSECTION, - ;; LSET-DIFFERENCE & APPEND to provide constant-time short - ;; cuts for the cases A = (), B = (), and A eq? B. It takes - ;; a careful case analysis to see it, but it's carefully - ;; built in. - - ;; Compute a-b and a^b, then compute b-(a^b) and - ;; cons it onto the front of a-b. - (receive (a-b a-int-b) (lset-diff+intersection = a b) - (cond ((null? a-b) (lset-difference = b a)) - ((null? a-int-b) (append b a)) - (else (fold (lambda (xb ans) - (if (member xb a-int-b =) ans (cons xb ans))) - a-b - b))))) - '() lists)) - - (define (lset-xor! = . lists) - (reduce (lambda (b a) ; Compute A xor B: - ;; Note that this code relies on the constant-time - ;; short-cuts provided by LSET-DIFF+INTERSECTION, - ;; LSET-DIFFERENCE & APPEND to provide constant-time short - ;; cuts for the cases A = (), B = (), and A eq? B. It takes - ;; a careful case analysis to see it, but it's carefully - ;; built in. - - ;; Compute a-b and a^b, then compute b-(a^b) and - ;; cons it onto the front of a-b. - (receive (a-b a-int-b) (lset-diff+intersection! = a b) - (cond ((null? a-b) (lset-difference! = b a)) - ((null? a-int-b) (append! b a)) - (else (pair-fold (lambda (b-pair ans) - (if (member (car b-pair) a-int-b =) ans - (begin (set-cdr! b-pair ans) b-pair))) - a-b - b))))) - '() lists)) - - (define (lset-diff+intersection = lis1 . lists) - (cond ((every null-list? lists) (values lis1 '())) ; Short cut - ((memq lis1 lists) (values '() lis1)) ; Short cut - (else (partition (lambda (elt) - (not (any (lambda (lis) (member elt lis =)) - lists))) - lis1)))) - - (define (lset-diff+intersection! = lis1 . lists) - (cond ((every null-list? lists) (values lis1 '())) ; Short cut - ((memq lis1 lists) (values '() lis1)) ; Short cut - (else (partition! (lambda (elt) - (not (any (lambda (lis) (member elt lis =)) - lists))) - lis1)))) - ) - - (begin ; Return (map cdr lists). - ; However, if any element of LISTS is empty, just abort and return '(). - (define (%cdrs xs) + (every (lambda (xs) + (not (member x xs x=?))) + xss)) + xs))))) + + (define (lset-xor x=? . xss) + (reduce (lambda (b a) + (receive (a-b a^b) (lset-diff+intersection x=? a b) + (cond ((null? a-b) (lset-difference x=? b a)) + ((null? a^b) (append b a)) + (else (fold (lambda (x xs) + (if (member x a^b x=?) + xs + (cons x xs))) + a-b + b))))) + '() + xss)) + + (define (lset-xor! x=? . xss) + (reduce (lambda (b a) + (receive (a-b a^b) (lset-diff+intersection! x=? a b) + (cond ((null? a-b) (lset-difference! x=? b a)) + ((null? a^b) (append! b a)) + (else (pair-fold (lambda (x:xs ys) + (if (member (car x:xs) a^b x=?) + ys + (begin (set-cdr! x:xs ys) + x:xs))) + a-b + b))))) + '() + xss)) + + (define (lset-diff+intersection x=? xs . xss) + (cond ((every null-list? xss) + (values xs '())) + ((memq xs xss) + (values '() xs)) + (else (partition (lambda (x) + (not (any (lambda (xs) + (member x xs x=?)) + xss))) + xs)))) + + (define (lset-diff+intersection! x=? xs . xss) + (cond ((every null-list? xss) + (values xs '())) + ((memq xs xss) + (values '() xs)) + (else (partition! (lambda (x) + (not (any (lambda (xs) + (member x xs x=?)) + xss))) + xs))))) + + (begin (define (%cdrs xss) (call-with-current-continuation! (lambda (abort) - (letrec ((recur (lambda (xs) - (if (pair? xs) - ((lambda (x) - (if (null-list? x) - (abort '()) - (cons (cdr x) - (recur (cdr xs))))) - (car xs)) - '())))) - (recur xs))))) - - (define (%cars+ lists last-elt) ; (append! (map car lists) (list last-elt)) - (letrec ((recur (lambda (lists) - (if (pair? lists) - (cons (caar lists) - (recur (cdr lists))) - (list last-elt))))) - (recur lists))) - - (define (%cars+cdrs lists) + (let recur ((xss xss)) + (if (pair? xss) + (let ((xs (car xss))) + (if (null-list? xs) + (abort '()) + (cons (cdr xs) + (recur (cdr xss))))) + '()))))) + + (define (%cars+ xss cars) + (let recur ((xss xss)) + (if (pair? xss) + (cons (caar xss) + (recur (cdr xss))) + (list cars)))) + + (define (%cars+cdrs xss) (call-with-current-continuation! (lambda (abort) - (let recur ((lists lists)) - (if (pair? lists) - (receive (list other-lists) (car+cdr lists) - (if (null-list? list) (abort '() '()) ; LIST is empty -- bail out - (receive (a d) (car+cdr list) - (receive (cars cdrs) (recur other-lists) - (values (cons a cars) (cons d cdrs)))))) - (values '() '())))))) - - (define (%cars+cdrs+ lists cars-final) + (let recur ((xss xss)) + (if (pair? xss) + (receive (xs xss) (car+cdr xss) + (if (null-list? xs) + (abort '() + '()) + (receive (a d) (car+cdr xs) + (receive (cars cdrs) (recur xss) + (values (cons a cars) + (cons d cdrs)))))) + (values '() + '())))))) + + (define (%cars+cdrs+ xss cars) (call-with-current-continuation! (lambda (abort) - (let recur ((lists lists)) - (if (pair? lists) - (receive (list other-lists) (car+cdr lists) - (if (null-list? list) (abort '() '()) ; LIST is empty -- bail out - (receive (a d) (car+cdr list) - (receive (cars cdrs) (recur other-lists) - (values (cons a cars) (cons d cdrs)))))) - (values (list cars-final) '())))))) - - (define (%cars+cdrs/no-test lists) - (let recur ((lists lists)) - (if (pair? lists) - (receive (list other-lists) (car+cdr lists) - (receive (a d) (car+cdr list) - (receive (cars cdrs) (recur other-lists) - (values (cons a cars) (cons d cdrs))))) - (values '() '())))) - - (define (%lset2<= = lis1 lis2) - (every (lambda (x) (member x lis2 =)) lis1)))) + (let recur ((xss xss)) + (if (pair? xss) + (receive (xs xss) (car+cdr xss) + (if (null-list? xs) + (abort '() + '()) + (receive (a d) (car+cdr xs) + (receive (cars cdrs) (recur xss) + (values (cons a cars) + (cons d cdrs)))))) + (values (list cars) + '())))))) + + (define (%cars+cdrs/no-test xss) + (let recur ((xss xss)) + (if (pair? xss) + (receive (xs xss) (car+cdr xss) + (receive (a d) (car+cdr xs) + (receive (cars cdrs) (recur xss) + (values (cons a cars) + (cons d cdrs))))) + (values '() + '())))) + + (define (%lset2<= x=? xs ys) + (every (lambda (x) + (member x ys x=?)) + xs)))) diff --git a/configure/README.md b/configure/README.md index 245acfa70..fae35493a 100644 --- a/configure/README.md +++ b/configure/README.md @@ -46,34 +46,34 @@ Procedures for each standard are provided by the following R7RS-style libraries: |:--------:|--------------| | R4RS | [`(scheme r4rs)`](./basis/r4rs.ss) | R5RS | [`(scheme r5rs)`](./basis/r5rs.ss) -| R7RS | [`(scheme base)`](./basis/r7rs.ss) [`(scheme box)`](./basis/r7rs.ss) [`(scheme case-lambda)`](./basis/r7rs.ss) [`(scheme char)`](./basis/r7rs.ss) [`(scheme complex)`](./basis/r7rs.ss) [`(scheme cxr)`](./basis/r7rs.ss) [`(scheme eval)`](./basis/r7rs.ss) [`(scheme file)`](./basis/r7rs.ss) [`(scheme inexact)`](./basis/r7rs.ss) [`(scheme lazy)`](./basis/r7rs.ss) [`(scheme load)`](./basis/r7rs.ss) [`(scheme process-context)`](./basis/r7rs.ss) [`(scheme read)`](./basis/r7rs.ss) [`(scheme repl)`](./basis/r7rs.ss) [`(scheme time)`](./basis/r7rs.ss) [`(scheme write)`](./basis/r7rs.ss) +| R7RS | [`(scheme base)`](./basis/r7rs.ss) [`(scheme box)`](./basis/r7rs.ss) [`(scheme case-lambda)`](./basis/r7rs.ss) [`(scheme char)`](./basis/r7rs.ss) [`(scheme complex)`](./basis/r7rs.ss) [`(scheme cxr)`](./basis/r7rs.ss) [`(scheme eval)`](./basis/r7rs.ss) [`(scheme file)`](./basis/r7rs.ss) [`(scheme inexact)`](./basis/r7rs.ss) [`(scheme lazy)`](./basis/r7rs.ss) [`(scheme list)`](./basis/r7rs.ss) [`(scheme load)`](./basis/r7rs.ss) [`(scheme process-context)`](./basis/r7rs.ss) [`(scheme read)`](./basis/r7rs.ss) [`(scheme repl)`](./basis/r7rs.ss) [`(scheme time)`](./basis/r7rs.ss) [`(scheme write)`](./basis/r7rs.ss) ### SRFIs -| Number | Title | Library name | Note | -|--------------------------------------------------------:|--------------------------------------------------------|-------------------------------------|-----------------------------------| -| [ 0](https://srfi.schemers.org/srfi-0/srfi-0.html) | Feature-based conditional expansion construct | [`(srfi 0)`](./basis/srfi-0.ss) | R7RS 4.2.1 | -| [ 1](https://srfi.schemers.org/srfi-1/srfi-1.html) | List Library | [`(srfi 1)`](./basis/srfi-1.ss) | | -| [ 4](https://srfi.schemers.org/srfi-4/srfi-4.html) | Homogeneous numeric vector datatypes | [`(srfi 4)`](./basis/srfi-4.ss) | R7RS 6.9 | -| [ 6](https://srfi.schemers.org/srfi-6/srfi-6.html) | Basic String Ports | [`(srfi 6)`](./basis/srfi-6.ss) | R7RS 6.13 | -| [ 8](https://srfi.schemers.org/srfi-8/srfi-8.html) | receive: Binding to multiple values | [`(srfi 8)`](./basis/srfi-8.ss) | | -| [ 9](https://srfi.schemers.org/srfi-9/srfi-9.html) | Defining Record Types | [`(srfi 9)`](./basis/srfi-9.ss) | R7RS 5.5 | -| [ 10](https://srfi.schemers.org/srfi-10/srfi-10.html) | #, external form | | | -| [ 11](https://srfi.schemers.org/srfi-11/srfi-11.html) | Syntax for receiving multiple values | [`(srfi 11)`](./basis/srfi-11.ss) | R7RS 4.2.2 | -| [ 16](https://srfi.schemers.org/srfi-16/srfi-16.html) | Syntax for procedures of variable arity | [`(srfi 16)`](./basis/srfi-16.ss) | R7RS 4.2.9 | -| [ 23](https://srfi.schemers.org/srfi-23/srfi-23.html) | Error reporting mechanism | [`(srfi 23)`](./basis/srfi-23.ss) | R7RS 6.11 | -| [ 30](https://srfi.schemers.org/srfi-30/srfi-30.html) | Nested Multi-line Comments | | R7RS 2.2 | -| [ 31](https://srfi.schemers.org/srfi-31/srfi-31.html) | A special form rec for recursive evaluation | [`(srfi 31)`](./basis/srfi-31.ss) | | -| [ 34](https://srfi.schemers.org/srfi-34/srfi-34.html) | Exception Handling for Programs | [`(srfi 34)`](./basis/srfi-34.ss) | R7RS 6.11 | -| [ 38](https://srfi.schemers.org/srfi-38/srfi-38.html) | External Representation for Data With Shared Structure | [`(srfi 38)`](./basis/srfi-38.ss) | R7RS 6.13.3 | -| [ 39](https://srfi.schemers.org/srfi-39/srfi-39.html) | Parameter objects | [`(srfi 39)`](./basis/srfi-39.ss) | R7RS 4.2.6 | -| [ 45](https://srfi.schemers.org/srfi-45/srfi-45.html) | Primitives for Expressing Iterative Lazy Algorithms | [`(srfi 45)`](./basis/srfi-45.ss) | R7RS 4.2.5 | -| [ 62](https://srfi.schemers.org/srfi-62/srfi-62.html) | S-expression comments | | R7RS 2.2 | -| [ 78](https://srfi.schemers.org/srfi-78/srfi-78.html) | Lightweight testing | [`(srfi 78)`](./basis/srfi-78.ss) | Except `check-ec` | -| [ 87](https://srfi.schemers.org/srfi-87/srfi-87.html) | => in case clauses | | R7RS 4.2.1 | -| [ 98](https://srfi.schemers.org/srfi-98/srfi-98.html) | An interface to access environment variables | [`(srfi 98)`](./basis/srfi-98.ss) | R7RS 6.14 | -| [111](https://srfi.schemers.org/srfi-111/srfi-111.html) | Boxes | [`(srfi 111)`](./basis/srfi-111.ss) | [`(scheme box)`](./basis/r7rs.ss) | -| [149](https://srfi.schemers.org/srfi-149/srfi-149.html) | Basic syntax-rules template extensions | [`(srfi 149)`](./basis/srfi-149.ss) | R7RS 4.3.2 | +| Number | Title | Library name | Note | +|--------------------------------------------------------:|--------------------------------------------------------|-------------------------------------|------------------------------------| +| [ 0](https://srfi.schemers.org/srfi-0/srfi-0.html) | Feature-based conditional expansion construct | [`(srfi 0)`](./basis/srfi-0.ss) | R7RS 4.2.1 | +| [ 1](https://srfi.schemers.org/srfi-1/srfi-1.html) | List Library | [`(srfi 1)`](./basis/srfi-1.ss) | [`(scheme list)`](./basis/r7rs.ss) | +| [ 4](https://srfi.schemers.org/srfi-4/srfi-4.html) | Homogeneous numeric vector datatypes | [`(srfi 4)`](./basis/srfi-4.ss) | R7RS 6.9 | +| [ 6](https://srfi.schemers.org/srfi-6/srfi-6.html) | Basic String Ports | [`(srfi 6)`](./basis/srfi-6.ss) | R7RS 6.13 | +| [ 8](https://srfi.schemers.org/srfi-8/srfi-8.html) | receive: Binding to multiple values | [`(srfi 8)`](./basis/srfi-8.ss) | | +| [ 9](https://srfi.schemers.org/srfi-9/srfi-9.html) | Defining Record Types | [`(srfi 9)`](./basis/srfi-9.ss) | R7RS 5.5 | +| [ 10](https://srfi.schemers.org/srfi-10/srfi-10.html) | #, external form | | | +| [ 11](https://srfi.schemers.org/srfi-11/srfi-11.html) | Syntax for receiving multiple values | [`(srfi 11)`](./basis/srfi-11.ss) | R7RS 4.2.2 | +| [ 16](https://srfi.schemers.org/srfi-16/srfi-16.html) | Syntax for procedures of variable arity | [`(srfi 16)`](./basis/srfi-16.ss) | R7RS 4.2.9 | +| [ 23](https://srfi.schemers.org/srfi-23/srfi-23.html) | Error reporting mechanism | [`(srfi 23)`](./basis/srfi-23.ss) | R7RS 6.11 | +| [ 30](https://srfi.schemers.org/srfi-30/srfi-30.html) | Nested Multi-line Comments | | R7RS 2.2 | +| [ 31](https://srfi.schemers.org/srfi-31/srfi-31.html) | A special form rec for recursive evaluation | [`(srfi 31)`](./basis/srfi-31.ss) | | +| [ 34](https://srfi.schemers.org/srfi-34/srfi-34.html) | Exception Handling for Programs | [`(srfi 34)`](./basis/srfi-34.ss) | R7RS 6.11 | +| [ 38](https://srfi.schemers.org/srfi-38/srfi-38.html) | External Representation for Data With Shared Structure | [`(srfi 38)`](./basis/srfi-38.ss) | R7RS 6.13.3 | +| [ 39](https://srfi.schemers.org/srfi-39/srfi-39.html) | Parameter objects | [`(srfi 39)`](./basis/srfi-39.ss) | R7RS 4.2.6 | +| [ 45](https://srfi.schemers.org/srfi-45/srfi-45.html) | Primitives for Expressing Iterative Lazy Algorithms | [`(srfi 45)`](./basis/srfi-45.ss) | R7RS 4.2.5 | +| [ 62](https://srfi.schemers.org/srfi-62/srfi-62.html) | S-expression comments | | R7RS 2.2 | +| [ 78](https://srfi.schemers.org/srfi-78/srfi-78.html) | Lightweight testing | [`(srfi 78)`](./basis/srfi-78.ss) | Except `check-ec` | +| [ 87](https://srfi.schemers.org/srfi-87/srfi-87.html) | => in case clauses | | R7RS 4.2.1 | +| [ 98](https://srfi.schemers.org/srfi-98/srfi-98.html) | An interface to access environment variables | [`(srfi 98)`](./basis/srfi-98.ss) | R7RS 6.14 | +| [111](https://srfi.schemers.org/srfi-111/srfi-111.html) | Boxes | [`(srfi 111)`](./basis/srfi-111.ss) | [`(scheme box)`](./basis/r7rs.ss) | +| [149](https://srfi.schemers.org/srfi-149/srfi-149.html) | Basic syntax-rules template extensions | [`(srfi 149)`](./basis/srfi-149.ss) | R7RS 4.3.2 | ## Installation diff --git a/include/meevax/kernel/heterogeneous.hpp b/include/meevax/kernel/heterogeneous.hpp index 939e83903..04b22723b 100644 --- a/include/meevax/kernel/heterogeneous.hpp +++ b/include/meevax/kernel/heterogeneous.hpp @@ -51,7 +51,7 @@ inline namespace kernel auto compare([[maybe_unused]] Top const* top) const -> bool override { - if constexpr (is_equality_comparable_v) + if constexpr (is_equality_comparable_v) { if (auto const* bound = dynamic_cast(top); bound) { @@ -75,7 +75,7 @@ inline namespace kernel auto write(std::ostream & os) const -> std::ostream & override { - if constexpr (is_output_streamable_v) + if constexpr (is_output_streamable_v) { return os << static_cast(*this); } @@ -87,7 +87,7 @@ inline namespace kernel auto operator []([[maybe_unused]] std::size_t k) const -> heterogeneous const& override { - if constexpr (is_array_subscriptable_v) + if constexpr (is_array_subscriptable_v) { return static_cast(*this)[k]; } @@ -96,6 +96,18 @@ inline namespace kernel throw std::runtime_error(lexical_cast("no viable array subscript operator for ", demangle(type()))); } } + + auto operator []([[maybe_unused]] std::size_t k) -> heterogeneous & override + { + if constexpr (is_array_subscriptable_v) + { + return static_cast(*this)[k]; + } + else + { + throw std::runtime_error(lexical_cast("no viable array subscript operator for ", demangle(type()))); + } + } }; public: @@ -236,6 +248,18 @@ inline namespace kernel } } + inline auto operator [](std::size_t k) -> heterogeneous & + { + if (dereferenceable() and *this) + { + return get()->operator [](k); + } + else + { + throw std::runtime_error(lexical_cast("no viable array subscript operator for ", demangle(type()))); + } + } + friend auto operator <<(std::ostream & os, heterogeneous const& datum) -> std::ostream & { return datum.write(os); diff --git a/include/meevax/kernel/list.hpp b/include/meevax/kernel/list.hpp index 3b8b6c0cd..887e59413 100644 --- a/include/meevax/kernel/list.hpp +++ b/include/meevax/kernel/list.hpp @@ -18,6 +18,7 @@ #define INCLUDED_MEEVAX_KERNEL_LIST_HPP #include +#include namespace meevax { @@ -90,27 +91,62 @@ inline namespace kernel inline auto cons = [](auto&&... xs) constexpr { - return (xs | ...); + return (std::forward(xs) | ...); }; inline auto list = [](auto&&... xs) constexpr { - return (xs | ... | unit); + return (std::forward(xs) | ... | unit); }; - inline auto xcons = [](auto&& d, auto&& a) constexpr + inline auto xcons = [](auto&& x, auto&& y) constexpr { - return cons(std::forward(a), std::forward(d)); + return cons(std::forward(y), + std::forward(x)); }; auto make_list(std::size_t, object const& = unit) -> object; + auto iota(std::size_t, object const& = e0, object const& = e1) -> object; + + template + auto last_pair(T&& x) -> decltype(x) + { + return cdr(x).template is() ? last_pair(cdr(std::forward(x))) : std::forward(x); + } + + template + auto last(T&& x) -> decltype(x) + { + return car(last_pair(std::forward(x))); + } + + template + auto circulate(T&& x) + { + cdr(last_pair(std::forward(x))) = x; + } + + template + auto circular_list(Ts&&... xs) + { + let x = list(std::forward(xs)...); + circulate(x); + return x; + } + auto is_list(object const&) -> bool; + auto is_circular_list(object const&) -> bool; + + auto is_dotted_list(object const&) -> bool; + + auto list_copy(object const&) -> object; + template auto tail(T&& x, std::size_t size) -> decltype(x) { - return 0 < size ? tail(cdr(std::forward(x)), --size) : x; + return 0 < size ? tail(cdr(std::forward(x)), --size) : std::forward(x); } template @@ -119,27 +155,38 @@ inline namespace kernel return car(tail(std::forward(xs)...)); } - auto last(object const&) -> object const&; - auto take(object const&, std::size_t) -> object; + auto take(object &, std::size_t) -> object; + + auto take_right(object const&, std::size_t) -> object const&; + + auto drop(object const&, std::size_t) -> object const&; + + auto drop(object &, std::size_t) -> object &; + + auto drop_right(object const&, std::size_t) -> object; + + auto drop_right(object &, std::size_t) -> object; + auto length(object const&) -> std::size_t; auto append(object const&, object const&) -> object; - auto reverse(object const&, object const& = unit) -> object; + auto append(object &, object const&) -> object &; + + auto append_reverse(object const&, object const&) -> object; + + auto append_reverse(object &, object const&) -> object; + + auto reverse(object const&) -> object; + + auto reverse(object &) -> object; template auto map(F f, object const& xs) -> object { - if (xs.is()) - { - return cons(f(car(xs)), map(f, cdr(xs))); - } - else - { - return unit; - } + return xs.is() ? cons(f(car(xs)), map(f, cdr(xs))) : unit; } auto memq(object const&, object const&) -> object const&; @@ -150,6 +197,10 @@ inline namespace kernel auto assv(object const&, object const&) -> object const&; + auto alist_cons(object const&, object const&, object const&) -> object; + + auto alist_copy(object const&) -> object; + template auto filter(F test, object const& xs) -> object { diff --git a/include/meevax/kernel/pair.hpp b/include/meevax/kernel/pair.hpp index 6157bf986..614470329 100644 --- a/include/meevax/kernel/pair.hpp +++ b/include/meevax/kernel/pair.hpp @@ -52,14 +52,14 @@ inline namespace kernel struct pair : public std::pair { - template + template struct forward_iterator { using iterator_category = std::forward_iterator_tag; using value_type = object; - using reference = std::add_lvalue_reference_t, value_type>>; + using reference = std::add_lvalue_reference_t, value_type>>; using pointer = std::add_pointer_t; @@ -67,7 +67,7 @@ inline namespace kernel using size_type = std::size_t; - using node_type = std::conditional_t; + using node_type = std::conditional_t; node_type current = nullptr; @@ -92,7 +92,7 @@ inline namespace kernel auto operator ++() -> decltype(auto) { - if (current = current->second.get(); current == initial) + if (current = current->second.get(); current == initial or (current and current->type() != typeid(pair))) { current = nullptr; } @@ -141,6 +141,8 @@ inline namespace kernel virtual auto operator [](std::size_t) const -> object const&; + virtual auto operator [](std::size_t) -> object &; + constexpr auto begin() noexcept { return iterator(this); diff --git a/include/meevax/kernel/syntactic_environment.hpp b/include/meevax/kernel/syntactic_environment.hpp index 9bb728b36..f77338d19 100644 --- a/include/meevax/kernel/syntactic_environment.hpp +++ b/include/meevax/kernel/syntactic_environment.hpp @@ -1016,7 +1016,7 @@ inline namespace kernel free_variables); }); - xs = cons(cons(free_variable, inject), xs); + xs = alist_cons(free_variable, inject, xs); } return xs; diff --git a/include/meevax/kernel/vector.hpp b/include/meevax/kernel/vector.hpp index fb8a7215f..c257161ad 100644 --- a/include/meevax/kernel/vector.hpp +++ b/include/meevax/kernel/vector.hpp @@ -39,6 +39,8 @@ inline namespace kernel {} auto operator [](std::size_t) const -> object const&; + + auto operator [](std::size_t) -> object &; }; auto operator ==(heterogeneous_vector const&, heterogeneous_vector const&) -> bool; diff --git a/include/meevax/memory/pointer_set.hpp b/include/meevax/memory/pointer_set.hpp index 26468e057..ee88d719f 100644 --- a/include/meevax/memory/pointer_set.hpp +++ b/include/meevax/memory/pointer_set.hpp @@ -18,6 +18,7 @@ #define INCLUDED_MEEVAX_MEMORY_POINTER_SET_HPP #include +#include #include #include #include diff --git a/src/kernel/boot.cpp b/src/kernel/boot.cpp index 9c1f08869..b1b7386b7 100644 --- a/src/kernel/boot.cpp +++ b/src/kernel/boot.cpp @@ -558,7 +558,73 @@ inline namespace kernel library.define("make-list", [](let const& xs) { - return make_list(xs[0].as(), 1 < length(xs) ? xs[1] : f); + switch (length(xs)) + { + case 1: + return make_list(xs[0].as()); + + case 2: + return make_list(xs[0].as(), xs[1]); + + default: + throw error(make("procedure make-list takes one or two arugments, but got"), xs); + } + }); + + library.define("iota", [](let const& xs) + { + switch (length(xs)) + { + case 1: + return iota(xs[0].as()); + + case 2: + return iota(xs[0].as(), xs[1]); + + case 3: + return iota(xs[0].as(), xs[1], xs[2]); + + default: + throw error(make("procedure iota takes one to three arugments, but got"), xs); + } + }); + + library.define("circular-list?", [](let const& xs) + { + return is_circular_list(xs[0]); + }); + + library.define("circular-list", [](let & xs) + { + circulate(xs); + return xs; + }); + + library.define("dotted-list?", [](let const& xs) + { + return is_dotted_list(xs[0]); + }); + + library.define("null-list?", [](let const& xs) + { + if (is_list(xs[0]) or is_circular_list(xs[0])) + { + return xs[0].is(); + } + else + { + throw error(make("procedure null-list? takes a proper-list or a circular-list, but got"), xs); + } + }); + + library.define("last", [](let const& xs) -> auto const& + { + return last(xs[0]); + }); + + library.define("last-pair", [](let const& xs) -> auto const& + { + return last_pair(xs[0]); }); library.define("length", [](let const& xs) @@ -566,9 +632,29 @@ inline namespace kernel return make(length(xs[0])); }); + library.define("length+", [](let const& xs) + { + return is_circular_list(xs[0]) ? f : make(length(xs[0])); + }); + library.define("append", [](let const& xs) { - return std::accumulate(std::begin(xs), std::end(xs), unit, append); + return std::accumulate(xs.begin(), xs.end(), unit, [](let const& x, let const& y) { return append(x, y); }); + }); + + library.define("append!", [](let & xs) + { + return std::accumulate(xs.begin(), xs.end(), unit, [](let & x, let const& y) { return append(x, y); }); + }); + + library.define("append-reverse", [](let const& xs) + { + return append_reverse(xs[0], xs[1]); + }); + + library.define("append-reverse!", [](let & xs) + { + return append_reverse(xs[0], xs[1]); }); library.define("reverse", [](let const& xs) @@ -576,6 +662,26 @@ inline namespace kernel return reverse(xs[0]); }); + library.define("reverse!", [](let & xs) + { + return reverse(xs[0]); + }); + + library.define("concatenate", [](let const& xs) + { + return std::accumulate(xs[0].begin(), xs[0].end(), unit, [](let const& x, let const& y) { return append(x, y); }); + }); + + library.define("concatenate!", [](let & xs) + { + return std::accumulate(xs[0].begin(), xs[0].end(), unit, [](let & x, let const& y) { return append(x, y); }); + }); + + library.define("list-copy", [](let const& xs) + { + return list_copy(xs[0]); + }); + library.define("list-tail", [](let const& xs) -> auto const& { return tail(xs[0], xs[1].as()); @@ -586,6 +692,86 @@ inline namespace kernel return xs[0][xs[1].as()]; }); + library.define("first", [](let const& xs) -> decltype(auto) + { + return xs[0][0]; + }); + + library.define("second", [](let const& xs) -> decltype(auto) + { + return xs[0][1]; + }); + + library.define("third", [](let const& xs) -> decltype(auto) + { + return xs[0][2]; + }); + + library.define("fourth", [](let const& xs) -> decltype(auto) + { + return xs[0][3]; + }); + + library.define("fifth", [](let const& xs) -> decltype(auto) + { + return xs[0][4]; + }); + + library.define("sixth", [](let const& xs) -> decltype(auto) + { + return xs[0][5]; + }); + + library.define("seventh", [](let const& xs) -> decltype(auto) + { + return xs[0][6]; + }); + + library.define("eighth", [](let const& xs) -> decltype(auto) + { + return xs[0][7]; + }); + + library.define("ninth", [](let const& xs) -> decltype(auto) + { + return xs[0][8]; + }); + + library.define("tenth", [](let const& xs) -> decltype(auto) + { + return xs[0][9]; + }); + + library.define("take", [](let const& xs) + { + return take(xs[0], xs[1].as()); + }); + + library.define("take!", [](let & xs) + { + return take(xs[0], xs[1].as()); + }); + + library.define("take-right", [](let const& xs) + { + return take_right(xs[0], xs[1].as()); + }); + + library.define("drop", [](let const& xs) + { + return drop(xs[0], xs[1].as()); + }); + + library.define("drop-right", [](let const& xs) + { + return drop_right(xs[0], xs[1].as()); + }); + + library.define("drop-right!", [](let & xs) + { + return drop_right(xs[0], xs[1].as()); + }); + library.define("memq", [](let const& xs) -> auto const& { return memq(xs[0], xs[1]); @@ -605,6 +791,16 @@ inline namespace kernel { return assv(xs[0], xs[1]); }); + + library.define("alist-cons", [](let const& xs) + { + return alist_cons(xs[0], xs[1], xs[2]); + }); + + library.define("alist-copy", [](let const& xs) + { + return alist_copy(xs[0]); + }); }); define("(meevax number)", [](library & library) @@ -884,11 +1080,46 @@ inline namespace kernel return xs[0].is(); }); + library.define("not-pair?", [](let const& xs) + { + return not xs[0].is(); + }); + library.define("cons", [](let const& xs) { return cons(xs[0], xs[1]); }); + library.define("cons*", [](let & xs) + { + if (xs.is()) + { + throw error(make("procedure cons* takes at least one arugments, but got"), xs); + } + else if (cdr(xs).is()) + { + return xs[0]; + } + else + { + auto node = xs.get(); + + while (not cddr(*node).is()) + { + node = cdr(*node).get(); + } + + cdr(*node) = cadr(*node); + + return xs; + } + }); + + library.define("xcons", [](let const& xs) + { + return cons(xs[1], xs[0]); + }); + library.define("car", [](let const& xs) -> auto const& { return car(xs[0]); }); library.define("cdr", [](let const& xs) -> auto const& { return cdr(xs[0]); }); @@ -1536,9 +1767,9 @@ inline namespace kernel { if (auto const position = std::string_view(*iter).find_first_of("="); position != std::string::npos) { - alist = cons(cons(make(std::string(*iter, position)), - make(std::string(*iter + position + 1))), - alist); + alist = alist_cons(make(std::string(*iter, position)), + make(std::string(*iter + position + 1)), + alist); } } @@ -1598,7 +1829,7 @@ inline namespace kernel library.define("vector-set!", [](let & xs) { - xs[0].as().vector[xs[1].as()] = xs[2]; + xs[0][xs[1].as()] = xs[2]; }); library.define("vector->list", [](let const& xs) diff --git a/src/kernel/environment.cpp b/src/kernel/environment.cpp index 83c4f00d4..b33dcf7d4 100644 --- a/src/kernel/environment.cpp +++ b/src/kernel/environment.cpp @@ -218,18 +218,17 @@ inline namespace kernel auto environment::import(object const& import_set) -> void { - for (let const& identity : resolve(import_set)) + for (let const& immigrant : resolve(import_set)) { - assert(identity.is()); + assert(immigrant.is()); - if (not is_truthy(std::as_const(*this).identify(car(identity), unit, unit)) or interactive) + if (let const& inhabitant = std::as_const(*this).identify(car(immigrant), unit, unit); inhabitant == f or interactive) { - define(car(identity), - cdr(identity)); + second = cons(immigrant, second); } - else + else if (immigrant != inhabitant) { - throw error(make("in a program or library declaration, it is an error to import the same identifier more than once with different bindings"), identity); + throw error(make("in a program or library declaration, it is an error to import the same identifier more than once with different bindings"), immigrant); } } } diff --git a/src/kernel/list.cpp b/src/kernel/list.cpp index 174c8cc08..2789fc490 100644 --- a/src/kernel/list.cpp +++ b/src/kernel/list.cpp @@ -23,7 +23,26 @@ inline namespace kernel { auto make_list(std::size_t size, object const& x) -> object { - return 0 < size ? cons(x, make_list(--size, x)) : unit; + if (0 < size) + { + return cons(x, make_list(--size, x)); + } + else + { + return unit; + } + } + + auto iota(std::size_t count, object const& start, object const& step) -> object + { + if (0 < count) + { + return cons(start, iota(count - 1, start + step, step)); + } + else + { + return unit; + } } auto is_list(object const& x0, object const& y0) -> bool @@ -53,19 +72,183 @@ inline namespace kernel return is_list(xs, xs); } - auto last(object const& xs) -> object const& + auto is_circular_list(object const& x0, object const& y0) -> bool + { + if (x0.is()) + { + if (let const& x1 = cdr(x0); x1.is()) + { + let const& x2 = cdr(x1), + y1 = cdr(y0); + + return eq(x2, y1) or is_circular_list(x2, y1); + } + else + { + return false; + } + } + else + { + return false; + } + } + + auto is_circular_list(object const& xs) -> bool { - return cdr(xs).is() ? last(cdr(xs)) : car(xs); + return is_circular_list(xs, xs); } - auto take(object const& x, std::size_t size) -> object + auto is_dotted_list(object const& x0, object const& y0) -> bool { - return 0 < size ? cons(car(x), take(cdr(x), --size)) : unit; + if (x0.is()) + { + if (let const& x1 = cdr(x0); x1.is()) + { + let const& x2 = cdr(x1), + y1 = cdr(y0); + + return not eq(x2, y1) and is_dotted_list(x2, y1); + } + else + { + return not x1.is(); + } + } + else + { + return not x0.is(); + } } - auto length(object const& xs) -> std::size_t + auto is_dotted_list(object const& xs) -> bool { - return std::distance(xs.begin(), xs.end()); + return is_dotted_list(xs, xs); + } + + auto list_copy(object const& xs) -> object + { + if (xs.is()) + { + return cons(car(xs), list_copy(cdr(xs))); + } + else + { + return xs; + } + } + + auto take(object const& x, std::size_t k) -> object + { + if (0 < k) + { + return cons(car(x), take(cdr(x), k - 1)); + } + else + { + return unit; + } + } + + auto take(object & x, std::size_t k) -> object + { + if (0 < k) + { + cdr(drop(x, k - 1)) = unit; + return x; + } + else + { + return unit; + } + } + + auto take_right(object const& x, object const& y) -> object const& + { + if (y.is()) + { + return take_right(cdr(x), cdr(y)); + } + else + { + return x; + } + } + + auto take_right(object const& x, std::size_t k) -> object const& + { + return take_right(x, drop(x, k)); + } + + auto drop(object const& x, std::size_t k) -> object const& + { + if (0 < k) + { + return drop(cdr(x), k - 1); + } + else + { + return x; + } + } + + auto drop(object & x, std::size_t k) -> object & + { + if (0 < k) + { + return drop(cdr(x), k - 1); + } + else + { + return x; + } + } + + auto drop_right(object const& x, object const& y) -> object + { + if (y.is()) + { + return cons(car(x), drop_right(cdr(x), cdr(y))); + } + else + { + return unit; + } + } + + auto drop_right(object const& x, std::size_t k) -> object + { + return drop_right(x, drop(x, k)); + } + + auto drop_right(object & x, object const& y) -> void + { + if (y.is()) + { + drop_right(cdr(x), cdr(y)); + } + else + { + cdr(x) = unit; + } + } + + auto drop_right(object & x, std::size_t k) -> object + { + if (let const y = drop(x, k); y.is()) + { + drop_right(x, cdr(y)); + return x; + } + else + { + return unit; + } + } + + auto length(object const& x) -> std::size_t + { + return std::distance(x.begin(), x.end()); } auto append(object const& x, object const& y) -> object @@ -80,6 +263,51 @@ inline namespace kernel } } + auto append(object & x, object const& y) -> object & + { + if (x.is()) + { + return x = y; + } + else if (y.is()) + { + return x; + } + else + { + cdr(last_pair(x)) = y; + return x; + } + } + + auto append_reverse(object const& x, object const& y) -> object + { + if (x.is()) + { + return y; + } + else + { + return append_reverse(cdr(x), cons(car(x), y)); + } + } + + auto append_reverse(object & x, object const& y) -> object + { + if (x.is()) + { + return y; + } + else + { + let const cdr_x = cdr(x); + + cdr(x) = y; + + return append_reverse(cdr_x, x); + } + } + auto reverse(object const& xs, object const& a) -> object { if (xs.is()) @@ -92,6 +320,32 @@ inline namespace kernel } } + auto reverse(object const& xs) -> object + { + return reverse(xs, unit); + } + + auto reverse(object & xs, object const& a) -> object + { + if (xs.is()) + { + return a; + } + else + { + let tail = cdr(xs); + + cdr(xs) = a; + + return reverse(tail, xs); + } + } + + auto reverse(object & xs) -> object + { + return reverse(xs, unit); + } + auto memq(object const& x, object const& xs) -> object const& { if (xs.is()) @@ -168,6 +422,20 @@ inline namespace kernel } } + auto alist_cons(object const& key, object const& datum, object const& alist) -> object + { + return cons(cons(key, datum), alist); + } + + auto alist_copy(object const& alist) -> object + { + return map([](auto&& x) + { + return cons(car(x), cdr(x)); + }, + alist); + } + auto longest_common_tail(let const& a, let const& b) -> object const& { if (a.is() or b.is() or eq(a, b)) diff --git a/src/kernel/pair.cpp b/src/kernel/pair.cpp index 79227c57b..3dfc20da4 100644 --- a/src/kernel/pair.cpp +++ b/src/kernel/pair.cpp @@ -46,22 +46,14 @@ inline namespace kernel return 0 < k ? second[--k] : first; } - auto operator <<(std::ostream & os, pair const& datum) -> std::ostream & + auto pair::operator [](std::size_t k) -> object & { - auto is_circular_list = [&]() - { - for (auto rest = datum.second.get(); rest; rest = rest->second.get()) - { - if (rest == &datum) - { - return true; - } - } - - return false; - }; + return 0 < k ? second[--k] : first; + } - if (is_circular_list()) + auto operator <<(std::ostream & os, pair const& datum) -> std::ostream & + { + if (is_circular_list(cdr(datum))) { auto n = reinterpret_cast(&datum); diff --git a/src/kernel/vector.cpp b/src/kernel/vector.cpp index 0eb1b7597..ada6da730 100644 --- a/src/kernel/vector.cpp +++ b/src/kernel/vector.cpp @@ -39,6 +39,11 @@ inline namespace kernel return vector[index]; } + auto heterogeneous_vector::operator [](std::size_t index) -> object & + { + return vector[index]; + } + auto operator ==(heterogeneous_vector const& v, heterogeneous_vector const& u) -> bool { return std::equal(std::begin(v.vector), std::end(v.vector), diff --git a/src/main.cpp b/src/main.cpp index b4e9aaab3..33a6a6424 100644 --- a/src/main.cpp +++ b/src/main.cpp @@ -29,6 +29,7 @@ auto main(int const argc, char const* const* const argv) -> int if (e.configure(argc, argv); e.interactive) { e.import("(scheme base)"_r); + e.import("(scheme box)"_r); e.import("(scheme case-lambda)"_r); e.import("(scheme char)"_r); e.import("(scheme complex)"_r); @@ -37,6 +38,7 @@ auto main(int const argc, char const* const* const argv) -> int e.import("(scheme file)"_r); e.import("(scheme inexact)"_r); e.import("(scheme lazy)"_r); + e.import("(scheme list)"_r); e.import("(scheme load)"_r); e.import("(scheme process-context)"_r); e.import("(scheme read)"_r); diff --git a/test/collector.cpp b/test/collector.cpp index 928ee9314..18c1dfca2 100644 --- a/test/collector.cpp +++ b/test/collector.cpp @@ -139,18 +139,6 @@ auto main() -> int assert(gc.count() == gc_count + 3); - auto circular_list = [](auto&&... xs) - { - let x = list(std::forward(xs)...); - - if (auto const length = std::distance(std::cbegin(x), std::cend(x)); 0 < length) - { - cdr(std::next(std::begin(x), length - 1)) = x; - } - - return x; - }; - return circular_list(a, b, c); }; diff --git a/test/srfi-1.ss b/test/srfi-1.ss new file mode 100644 index 000000000..5fe09ed9f --- /dev/null +++ b/test/srfi-1.ss @@ -0,0 +1,422 @@ +(import (scheme base) + (scheme cxr) + (scheme process-context) + (scheme write) + (srfi 1) + (srfi 78)) + +(check (cons 'a 'b) => '(a . b)) + +(check (list 'a 'b 'c) => '(a b c)) + +(check (xcons 'a 'b) => '(b . a)) + +(check (cons* 'a) => 'a) +(check (cons* 'a 'b) => '(a . b)) +(check (cons* 'a 'b 'c) => '(a b . c)) + +(check (make-list 2 'a) => '(a a)) + +(check (list-tabulate 4 (lambda (x) x)) => '(0 1 2 3)) +(check (list-tabulate 4 number->string) => '("0" "1" "2" "3")) + +(check (list-copy '(a b c)) => '(a b c)) + +(check (circular-list 'a) => '#1=(a . #1#)) +(check (circular-list 'a 'b) => '#1=(a b . #1#)) +(check (circular-list 'a 'b 'c) => '#1=(a b c . #1#)) + +(check (iota 5) => '(0 1 2 3 4)) +(check (iota 5 0 -0.1) (=> (lambda (x y) (list= = x y))) '(0 -0.1 -0.2 -0.3 -0.4)) + +(check (pair? 'a) => #f) +(check (pair? '(a . b)) => #t) +(check (pair? '(a b . c)) => #t) +(check (pair? '(a b c)) => #t) + +(check (null? '()) => #t) +(check (null? '(a)) => #f) +(check (null? '(a . b)) => #f) +(check (null? '(a b . c)) => #f) +(check (null? 'a) => #f) +(check (null? 1) => #f) + +(check (proper-list? '()) => #t) +(check (proper-list? '(a . b)) => #f) +(check (proper-list? '(a b . c)) => #f) +(check (proper-list? '(a b c)) => #t) +(check (proper-list? 'a) => #f) +(check (proper-list? 1) => #f) + +(check (circular-list? '(a b c)) => #f) +(check (circular-list? '#1=(a b c . #1#)) => #t) + +(check (dotted-list? '(a . b)) => #t) +(check (dotted-list? '(a b . c)) => #t) +(check (dotted-list? '(a b c)) => #f) + +(check (not-pair? 'a) => #t) +(check (not-pair? '(a . b)) => #f) +(check (not-pair? '(a b . c)) => #f) +(check (not-pair? '(a b c)) => #f) + +(check (null-list? '()) => #t) +(check (null-list? '(a b c)) => #f) +(check (null-list? '#1=(a b c . #1#)) => #f) + +(check (list= eq? '(a b c) '(a b c)) => #t) +(check (list= eq? '(a b c) '(a B c)) => #f) +(check (list= eqv? '(1 2 3) '(1.0 2.0 3.0)) => #f) +(check (list= = '(1 2 3) '(1.0 2.0 3.0)) => #t) +(check (list= eqv? '((a b) (c d) (e f)) '((a b) (c d) (e f))) => #f) +(check (list= equal? '((a b) (c d) (e f)) '((a b) (c d) (e f))) => #t) + +(check (car '((((aaaa . daaa) adaa . ddaa) (aada . dada) adda . ddda) ((aaad . daad) adad . ddad) (aadd . dadd) addd . dddd)) => '(((aaaa . daaa) adaa . ddaa) (aada . dada) adda . ddda)) +(check (cdr '((((aaaa . daaa) adaa . ddaa) (aada . dada) adda . ddda) ((aaad . daad) adad . ddad) (aadd . dadd) addd . dddd)) => '(((aaad . daad) adad . ddad) (aadd . dadd) addd . dddd)) +(check (caar '((((aaaa . daaa) adaa . ddaa) (aada . dada) adda . ddda) ((aaad . daad) adad . ddad) (aadd . dadd) addd . dddd)) => '((aaaa . daaa) adaa . ddaa)) +(check (cadr '((((aaaa . daaa) adaa . ddaa) (aada . dada) adda . ddda) ((aaad . daad) adad . ddad) (aadd . dadd) addd . dddd)) => '((aaad . daad) adad . ddad)) +(check (cdar '((((aaaa . daaa) adaa . ddaa) (aada . dada) adda . ddda) ((aaad . daad) adad . ddad) (aadd . dadd) addd . dddd)) => '((aada . dada) adda . ddda)) +(check (cddr '((((aaaa . daaa) adaa . ddaa) (aada . dada) adda . ddda) ((aaad . daad) adad . ddad) (aadd . dadd) addd . dddd)) => '((aadd . dadd) addd . dddd)) +(check (caaar '((((aaaa . daaa) adaa . ddaa) (aada . dada) adda . ddda) ((aaad . daad) adad . ddad) (aadd . dadd) addd . dddd)) => '(aaaa . daaa)) +(check (caadr '((((aaaa . daaa) adaa . ddaa) (aada . dada) adda . ddda) ((aaad . daad) adad . ddad) (aadd . dadd) addd . dddd)) => '(aaad . daad)) +(check (cadar '((((aaaa . daaa) adaa . ddaa) (aada . dada) adda . ddda) ((aaad . daad) adad . ddad) (aadd . dadd) addd . dddd)) => '(aada . dada)) +(check (caddr '((((aaaa . daaa) adaa . ddaa) (aada . dada) adda . ddda) ((aaad . daad) adad . ddad) (aadd . dadd) addd . dddd)) => '(aadd . dadd)) +(check (cdaar '((((aaaa . daaa) adaa . ddaa) (aada . dada) adda . ddda) ((aaad . daad) adad . ddad) (aadd . dadd) addd . dddd)) => '(adaa . ddaa)) +(check (cdadr '((((aaaa . daaa) adaa . ddaa) (aada . dada) adda . ddda) ((aaad . daad) adad . ddad) (aadd . dadd) addd . dddd)) => '(adad . ddad)) +(check (cddar '((((aaaa . daaa) adaa . ddaa) (aada . dada) adda . ddda) ((aaad . daad) adad . ddad) (aadd . dadd) addd . dddd)) => '(adda . ddda)) +(check (cdddr '((((aaaa . daaa) adaa . ddaa) (aada . dada) adda . ddda) ((aaad . daad) adad . ddad) (aadd . dadd) addd . dddd)) => '(addd . dddd)) +(check (caaaar '((((aaaa . daaa) adaa . ddaa) (aada . dada) adda . ddda) ((aaad . daad) adad . ddad) (aadd . dadd) addd . dddd)) => 'aaaa) +(check (caaadr '((((aaaa . daaa) adaa . ddaa) (aada . dada) adda . ddda) ((aaad . daad) adad . ddad) (aadd . dadd) addd . dddd)) => 'aaad) +(check (caadar '((((aaaa . daaa) adaa . ddaa) (aada . dada) adda . ddda) ((aaad . daad) adad . ddad) (aadd . dadd) addd . dddd)) => 'aada) +(check (caaddr '((((aaaa . daaa) adaa . ddaa) (aada . dada) adda . ddda) ((aaad . daad) adad . ddad) (aadd . dadd) addd . dddd)) => 'aadd) +(check (cadaar '((((aaaa . daaa) adaa . ddaa) (aada . dada) adda . ddda) ((aaad . daad) adad . ddad) (aadd . dadd) addd . dddd)) => 'adaa) +(check (cadadr '((((aaaa . daaa) adaa . ddaa) (aada . dada) adda . ddda) ((aaad . daad) adad . ddad) (aadd . dadd) addd . dddd)) => 'adad) +(check (caddar '((((aaaa . daaa) adaa . ddaa) (aada . dada) adda . ddda) ((aaad . daad) adad . ddad) (aadd . dadd) addd . dddd)) => 'adda) +(check (cadddr '((((aaaa . daaa) adaa . ddaa) (aada . dada) adda . ddda) ((aaad . daad) adad . ddad) (aadd . dadd) addd . dddd)) => 'addd) +(check (cdaaar '((((aaaa . daaa) adaa . ddaa) (aada . dada) adda . ddda) ((aaad . daad) adad . ddad) (aadd . dadd) addd . dddd)) => 'daaa) +(check (cdaadr '((((aaaa . daaa) adaa . ddaa) (aada . dada) adda . ddda) ((aaad . daad) adad . ddad) (aadd . dadd) addd . dddd)) => 'daad) +(check (cdadar '((((aaaa . daaa) adaa . ddaa) (aada . dada) adda . ddda) ((aaad . daad) adad . ddad) (aadd . dadd) addd . dddd)) => 'dada) +(check (cdaddr '((((aaaa . daaa) adaa . ddaa) (aada . dada) adda . ddda) ((aaad . daad) adad . ddad) (aadd . dadd) addd . dddd)) => 'dadd) +(check (cddaar '((((aaaa . daaa) adaa . ddaa) (aada . dada) adda . ddda) ((aaad . daad) adad . ddad) (aadd . dadd) addd . dddd)) => 'ddaa) +(check (cddadr '((((aaaa . daaa) adaa . ddaa) (aada . dada) adda . ddda) ((aaad . daad) adad . ddad) (aadd . dadd) addd . dddd)) => 'ddad) +(check (cdddar '((((aaaa . daaa) adaa . ddaa) (aada . dada) adda . ddda) ((aaad . daad) adad . ddad) (aadd . dadd) addd . dddd)) => 'ddda) +(check (cddddr '((((aaaa . daaa) adaa . ddaa) (aada . dada) adda . ddda) ((aaad . daad) adad . ddad) (aadd . dadd) addd . dddd)) => 'dddd) + +(let ((x '(1 2 3 4 5 6 7 8 9 10))) + (let recurse ((i 0)) + (if (< i (length x)) + (begin (check (list-ref x i) => (+ i 1)) + (recurse (+ i 1)))))) + +(check (first '(a b c d e f g h i j)) => 'a) +(check (second '(a b c d e f g h i j)) => 'b) +(check (third '(a b c d e f g h i j)) => 'c) +(check (fourth '(a b c d e f g h i j)) => 'd) +(check (fifth '(a b c d e f g h i j)) => 'e) +(check (sixth '(a b c d e f g h i j)) => 'f) +(check (seventh '(a b c d e f g h i j)) => 'g) +(check (eighth '(a b c d e f g h i j)) => 'h) +(check (ninth '(a b c d e f g h i j)) => 'i) +(check (tenth '(a b c d e f g h i j)) => 'j) + +(call-with-values (lambda () + (car+cdr '(a . b))) + (lambda (x y) + (check x => 'a) + (check y => 'b))) + +(let ((x '(a b c d e))) (check (take x 0) => '()) (check x => '(a b c d e))) +(let ((x '(a b c d e))) (check (take! x 0) => '()) (check x => '(a b c d e))) +(let ((x '(a b c d e))) (check (take x 1) => '(a)) (check x => '(a b c d e))) +(let ((x '(a b c d e))) (check (take! x 1) => '(a)) (check x => '(a))) +(let ((x '(a b c d e))) (check (take x 2) => '(a b)) (check x => '(a b c d e))) +(let ((x '(a b c d e))) (check (take! x 2) => '(a b)) (check x => '(a b))) +(let ((x '(a b c d e))) (check (take x 3) => '(a b c)) (check x => '(a b c d e))) +(let ((x '(a b c d e))) (check (take! x 3) => '(a b c)) (check x => '(a b c))) +(let ((x '(a b c d e))) (check (take x 4) => '(a b c d)) (check x => '(a b c d e))) +(let ((x '(a b c d e))) (check (take! x 4) => '(a b c d)) (check x => '(a b c d))) +(let ((x '(a b c d e))) (check (take x 5) => '(a b c d e)) (check x => '(a b c d e))) +(let ((x '(a b c d e))) (check (take! x 5) => '(a b c d e)) (check x => '(a b c d e))) + +(check (drop '(a b c d e) 0) => '(a b c d e)) +(check (drop '(a b c d e) 1) => '(b c d e)) +(check (drop '(a b c d e) 2) => '(c d e)) +(check (drop '(a b c d e) 3) => '(d e)) +(check (drop '(a b c d e) 4) => '(e)) +(check (drop '(a b c d e) 5) => '()) + +(check (take-right '(a b c d e) 0) => '()) +(check (take-right '(a b c d e) 1) => '(e)) +(check (take-right '(a b c d e) 2) => '(d e)) +(check (take-right '(a b c d e) 3) => '(c d e)) +(check (take-right '(a b c d e) 4) => '(b c d e)) +(check (take-right '(a b c d e) 5) => '(a b c d e)) +(check (take-right '(a b c . x) 0) => 'x) +(check (take-right '(a b c . x) 1) => '(c . x)) +(check (take-right '(a b c . x) 2) => '(b c . x)) +(check (take-right '(a b c . x) 3) => '(a b c . x)) + +(let ((x '(a b c d e))) (check (drop-right x 0) => '(a b c d e)) (check x => '(a b c d e))) +(let ((x '(a b c d e))) (check (drop-right! x 0) => '(a b c d e)) (check x => '(a b c d e))) +(let ((x '(a b c d e))) (check (drop-right x 1) => '(a b c d)) (check x => '(a b c d e))) +(let ((x '(a b c d e))) (check (drop-right! x 1) => '(a b c d)) (check x => '(a b c d))) +(let ((x '(a b c d e))) (check (drop-right x 2) => '(a b c)) (check x => '(a b c d e))) +(let ((x '(a b c d e))) (check (drop-right! x 2) => '(a b c)) (check x => '(a b c))) +(let ((x '(a b c d e))) (check (drop-right x 3) => '(a b)) (check x => '(a b c d e))) +(let ((x '(a b c d e))) (check (drop-right! x 3) => '(a b)) (check x => '(a b))) +(let ((x '(a b c d e))) (check (drop-right x 4) => '(a)) (check x => '(a b c d e))) +(let ((x '(a b c d e))) (check (drop-right! x 4) => '(a)) (check x => '(a))) +(let ((x '(a b c d e))) (check (drop-right x 5) => '()) (check x => '(a b c d e))) +(let ((x '(a b c d e))) (check (drop-right! x 5) => '()) (check x => '(a b c d e))) +(let ((x '(a b c . z))) (check (drop-right x 0) => '(a b c)) (check x => '(a b c . z))) +(let ((x '(a b c . z))) (check (drop-right! x 0) => '(a b c)) (check x => '(a b c))) +(let ((x '(a b c . z))) (check (drop-right x 1) => '(a b)) (check x => '(a b c . z))) +(let ((x '(a b c . z))) (check (drop-right! x 1) => '(a b)) (check x => '(a b))) +(let ((x '(a b c . z))) (check (drop-right x 2) => '(a)) (check x => '(a b c . z))) +(let ((x '(a b c . z))) (check (drop-right! x 2) => '(a)) (check x => '(a))) +(let ((x '(a b c . z))) (check (drop-right x 3) => '()) (check x => '(a b c . z))) +(let ((x '(a b c . z))) (check (drop-right! x 3) => '()) (check x => '(a b c . z))) + +(let ((x '(a b c d e f g h))) (check (call-with-values (lambda () (split-at x 3)) (lambda (x xs) (list x xs))) => '((a b c) (d e f g h))) (check x => '(a b c d e f g h))) +(let ((x '(a b c d e f g h))) (check (call-with-values (lambda () (split-at! x 3)) (lambda (x xs) (list x xs))) => '((a b c) (d e f g h))) (check x => '(a b c))) + +(check (last '(a)) => 'a) +(check (last '(a b)) => 'b) +(check (last '(a b c)) => 'c) + +(check (last-pair '(a)) => '(a)) +(check (last-pair '(a b)) => '(b)) +(check (last-pair '(a b c)) => '(c)) +(check (last-pair '(a b c . d)) => '(c . d)) + +(check (length '(a b c)) => 3) +(check (length '(a b . c)) => 2) + +(check (length+ '(a b c)) => 3) +(check (length+ '(a b . c)) => 2) +(check (length+ '#1=(a b c . #1#)) => #f) + +(let ((x '(a)) (y '(b))) (check (append x y) => '(a b)) (check x => '(a)) (check y => '(b))) +(let ((x '(a)) (y '(b))) (check (append! x y) => '(a b)) (check x => '(a b)) (check y => '(b))) +(let ((x '(a)) (y '(b c d))) (check (append x y) => '(a b c d)) (check x => '(a)) (check y => '(b c d))) +(let ((x '(a)) (y '(b c d))) (check (append! x y) => '(a b c d)) (check x => '(a b c d)) (check y => '(b c d))) +(let ((x '(a (b))) (y '((c)))) (check (append x y) => '(a (b) (c))) (check x => '(a (b))) (check y => '((c)))) +(let ((x '(a (b))) (y '((c)))) (check (append! x y) => '(a (b) (c))) (check x => '(a (b) (c))) (check y => '((c)))) +(let ((x '(a b)) (y '(c . d))) (check (append x y) => '(a b c . d)) (check x => '(a b)) (check y => '(c . d))) +(let ((x '(a b)) (y '(c . d))) (check (append! x y) => '(a b c . d)) (check x => '(a b c . d)) (check y => '(c . d))) +(let ((x '()) (y 'a)) (check (append x y) => 'a) (check x => '()) (check y => 'a)) +(let ((x '()) (y 'a)) (check (append! x y) => 'a) (check x => '()) (check y => 'a)) + +(check (append '(a b)) => '(a b)) +(check (append! '(a b)) => '(a b)) +(check (append) => '()) +(check (append!) => '()) + +(let ((x '((1 2 3) (4 5 6) (7 8 9)))) (check (concatenate x) => '(1 2 3 4 5 6 7 8 9)) (check x => '((1 2 3) (4 5 6) (7 8 9)))) +(let ((x '((1 2 3) (4 5 6) (7 8 9)))) (check (concatenate! x) => '(1 2 3 4 5 6 7 8 9)) (check x => '((1 2 3 4 5 6 7 8 9) (4 5 6 7 8 9) (7 8 9)))) +(let ((x '((1 2 3) (4 5 6) (7 . ...)))) (check (concatenate x) => '(1 2 3 4 5 6 7 . ...)) (check x => '((1 2 3) (4 5 6) (7 . ...)))) +(let ((x '((1 2 3) (4 5 6) (7 . ...)))) (check (concatenate! x) => '(1 2 3 4 5 6 7 . ...)) (check x => '((1 2 3 4 5 6 7 . ...) (4 5 6 7 . ...) (7 . ...)))) +(let ((x '((1 2 3) (4 5 6) ...))) (check (concatenate x) => '(1 2 3 4 5 6 . ...)) (check x => '((1 2 3) (4 5 6) ...))) +(let ((x '((1 2 3) (4 5 6) ...))) (check (concatenate! x) => '(1 2 3 4 5 6 . ...)) (check x => '((1 2 3 4 5 6 . ...) (4 5 6 . ...) ...))) + +(let ((x '(a b c))) (check (reverse x) => '(c b a)) (check x => '(a b c))) +(let ((x '(a b c))) (check (reverse! x) => '(c b a)) (check x => '(a))) +(let ((x '(a (b c) d (e (f))))) (check (reverse x) => '((e (f)) d (b c) a)) (check x => '(a (b c) d (e (f))))) +(let ((x '(a (b c) d (e (f))))) (check (reverse! x) => '((e (f)) d (b c) a)) (check x => '(a))) + +(let ((x '(3 2 1)) (y '(4 5 6))) (check (append-reverse x y) => '(1 2 3 4 5 6)) (check x => '(3 2 1)) (check y => '(4 5 6))) +(let ((x '(3 2 1)) (y '(4 5 6))) (check (append-reverse! x y) => '(1 2 3 4 5 6)) (check x => '(3 4 5 6)) (check y => '(4 5 6))) + +(check (zip '(one two three) '(1 2 3) '(odd even odd even odd even odd even)) => '((one 1 odd) (two 2 even) (three 3 odd))) +(check (zip '(1 2 3)) => '((1) (2) (3))) +(check (zip '(3 1 4 1) (circular-list #f #t)) => '((3 #f) (1 #t) (4 #f) (1 #t))) + +(call-with-values (lambda () (unzip1 '((1 one ONE a A) (2 two TWO b B) (3 three THREE c C) (4 four FOUR d D) (5 five FIVE e E)))) (lambda xs (check xs => '((1 2 3 4 5))))) +(call-with-values (lambda () (unzip2 '((1 one ONE a A) (2 two TWO b B) (3 three THREE c C) (4 four FOUR d D) (5 five FIVE e E)))) (lambda xs (check xs => '((1 2 3 4 5) (one two three four five))))) +(call-with-values (lambda () (unzip3 '((1 one ONE a A) (2 two TWO b B) (3 three THREE c C) (4 four FOUR d D) (5 five FIVE e E)))) (lambda xs (check xs => '((1 2 3 4 5) (one two three four five) (ONE TWO THREE FOUR FIVE))))) +(call-with-values (lambda () (unzip4 '((1 one ONE a A) (2 two TWO b B) (3 three THREE c C) (4 four FOUR d D) (5 five FIVE e E)))) (lambda xs (check xs => '((1 2 3 4 5) (one two three four five) (ONE TWO THREE FOUR FIVE) (a b c d e))))) +(call-with-values (lambda () (unzip5 '((1 one ONE a A) (2 two TWO b B) (3 three THREE c C) (4 four FOUR d D) (5 five FIVE e E)))) (lambda xs (check xs => '((1 2 3 4 5) (one two three four five) (ONE TWO THREE FOUR FIVE) (a b c d e) (A B C D E))))) + +(check (count even? '(3 1 4 1 5 9 2 5 6)) => 3) +(check (count < '(1 2 4 8) '(2 4 6 8 10 12 14 16)) => 3) +(check (count < '(3 1 4 1) (circular-list 1 10)) => 2) + +(check (fold + 0 '(1 2 3 4 5 6 7 8 9 10)) => 55) +(check (fold cons '() '(a b c)) => '(c b a)) +(check (fold cons* '() '(a b c) '(1 2 3 4 5)) => '(c 3 b 2 a 1)) +(check (fold (lambda (x k) (if (symbol? x) (+ k 1) k)) 0 '(1 a 2 b 3 c)) => 3) +(check (fold (lambda (s k) (max k (string-length s))) 0 '("one" "two" "three")) => 5) + +(check (fold-right cons '() '(a b c)) => '(a b c)) +(check (fold-right cons* '() '(a b c) '(1 2 3 4 5)) => '(a 1 b 2 c 3)) +(check (fold-right (lambda (x xs) (if (even? x) (cons x xs) xs)) '() '(1 2 3 4 5)) => '(2 4)) + +(check (pair-fold (lambda (x xs) (set-cdr! x xs) x) '() '(a b c)) => '(c b a)) + +(check (pair-fold-right cons '() '(a b c)) => '((a b c) (b c) (c))) + +(check (reduce max 42 '(1 2 3 4 5 6 7 8 9 10)) => 10) +(check (reduce max 42 '(1)) => 1) +(check (reduce max 42 '()) => 42) + +(check (reduce-right append '() '((a b c) (d e f) (g h i))) => '(a b c d e f g h i)) +(check (reduce-right append '(x y z) '((a b c) (d e f) (g h i))) => '(a b c d e f g h i)) +(check (reduce-right append '(x y z) '((a b c))) => '(a b c)) +(check (reduce-right append '(x y z) '()) => '(x y z)) + +(check (unfold (lambda (x) (< 10 x)) square (lambda (x) (+ x 1)) 1) => '(1 4 9 16 25 36 49 64 81 100)) +(check (unfold null-list? car cdr '(a b c)) => '(a b c)) +(check (unfold not-pair? car cdr '(a b c) values) => '(a b c)) +(check (unfold not-pair? car cdr '(a b c . d) values) => '(a b c . d)) +(check (unfold null-list? car cdr '(a b c) (lambda (x) '(d e f))) => '(a b c d e f)) + +(check (unfold-right zero? square (lambda (x) (- x 1)) 10) => '(1 4 9 16 25 36 49 64 81 100)) +(check (unfold-right null-list? car cdr '(a b c)) => '(c b a)) +(check (unfold-right null-list? car cdr '(c b a) '(d e f)) => '(a b c d e f)) + +(check (map cadr '((a b) (d e) (g h))) => '(b e h)) +(check (map! cadr '((a b) (d e) (g h))) => '(b e h)) +(check (map-in-order cadr '((a b) (d e) (g h))) => '(b e h)) +(check (map (lambda (n) (expt n n)) '(1 2 3 4 5)) => '(1 4 27 256 3125)) +(check (map! (lambda (n) (expt n n)) '(1 2 3 4 5)) => '(1 4 27 256 3125)) +(check (map-in-order (lambda (n) (expt n n)) '(1 2 3 4 5)) => '(1 4 27 256 3125)) +(check (map + '(1 2 3) '(4 5 6)) => '(5 7 9)) +(check (map! + '(1 2 3) '(4 5 6)) => '(5 7 9)) +(check (map-in-order + '(1 2 3) '(4 5 6)) => '(5 7 9)) +(check (map + '(3 1 4 1) (circular-list 1 0)) => '(4 1 5 1)) +(check (map! + '(3 1 4 1) (circular-list 1 0)) => '(4 1 5 1)) +(check (map-in-order + '(3 1 4 1) (circular-list 1 0)) => '(4 1 5 1)) +(check (let ((count 0)) (map (lambda (ignored) (set! count (+ count 1)) count) '(a b))) => '(1 2)) +(check (let ((count 0)) (map! (lambda (ignored) (set! count (+ count 1)) count) '(a b))) => '(1 2)) +(check (let ((count 0)) (map-in-order (lambda (ignored) (set! count (+ count 1)) count) '(a b))) => '(1 2)) + +(check (let ((v (make-vector 5))) (for-each (lambda (i) (vector-set! v i (* i i))) '(0 1 2 3 4)) v) => #(0 1 4 9 16)) + +(check (append-map! (lambda (x) (list x (- x))) '(1 3 8)) => '(1 -1 3 -3 8 -8)) + +(check (filter-map (lambda (x) (and (number? x) (* x x))) '(a 1 b 3 c 7)) => '(1 9 49)) + +(check (parameterize ((current-output-port (open-output-string ""))) + (pair-for-each (lambda (pair) + (display pair)) + '(a b c)) + (get-output-string (current-output-port))) + => "(a b c)(b c)(c)") + +(check (filter even? '(0 7 8 8 43 -4)) => '(0 8 8 -4)) +(check (filter! even? '(0 7 8 8 43 -4)) => '(0 8 8 -4)) + +(call-with-values (lambda () (partition symbol? '(one 2 3 four five 6))) (lambda (x y) (check x => '(one four five)) (check y => '(2 3 6)))) +(call-with-values (lambda () (partition! symbol? '(one 2 3 four five 6))) (lambda (x y) (check x => '(one four five)) (check y => '(2 3 6)))) + +(check (remove even? '(0 7 8 8 43 -4)) => '(7 43)) +(check (remove! even? '(0 7 8 8 43 -4)) => '(7 43)) + +(check (find even? '(3 1 4 1 5 9)) => 4) + +(check (find-tail even? '(3 1 37 -8 -5 0 0)) => '(-8 -5 0 0)) +(check (find-tail even? '(3 1 37 -5)) => #f) + +(check (take-while even? '(2 18 3 10 22 9)) => '(2 18)) +(check (take-while! even? '(2 18 3 10 22 9)) => '(2 18)) +(check (drop-while even? '(2 18 3 10 22 9)) => '(3 10 22 9)) + +(call-with-values (lambda () (span even? '(2 18 3 10 22 9))) (lambda (x y) (check x => '(2 18)) (check y => '(3 10 22 9)))) +(call-with-values (lambda () (span! even? '(2 18 3 10 22 9))) (lambda (x y) (check x => '(2 18)) (check y => '(3 10 22 9)))) + +(call-with-values (lambda () (break even? '(3 1 4 1 5 9))) (lambda (x y) (check x => '(3 1)) (check y => '(4 1 5 9)))) +(call-with-values (lambda () (break! even? '(3 1 4 1 5 9))) (lambda (x y) (check x => '(3 1)) (check y => '(4 1 5 9)))) + +(check (any integer? '(a 3 b 2.7)) => #t) +(check (any integer? '(a 3.1 b 2.7)) => #f) +(check (any < '(3 1 4 1 5) '(2 7 1 8 2)) => #t) + +(check (every integer? '(1 2 3)) => #t) +(check (every integer? '(1 2 3.14)) => #f) +(check (every integer? '(1 2 3) '(4 5 6 7)) => #t) +(check (every integer? '(1 2 3) '(4 5 6 7.0)) => #t) +(check (every integer? '(1 2 3) (circular-list 4)) => #t) + +(check (list-index even? '(3 1 4 1 5 9)) => 2) +(check (list-index < '(3 1 4 1 5 9 2 5 6) '(2 7 1 8 2)) => 1) +(check (list-index = '(3 1 4 1 5 9 2 5 6) '(2 7 1 8 2)) => #f) + +(check (memq 'a '(a b c)) => '(a b c)) +(check (memq 'b '(a b c)) => '(b c)) +(check (memq 'a '(b c d)) => #f) +(check (memq (list 'a) '(b (a) c)) => #f) +(check (member (list 'a) '(b (a) c)) => '((a) c)) +(check (memq 101 '(100 101 102)) => #f) +(check (memv 101 '(100 101 102)) => '(101 102)) + +(check (delete 2 '(1 2 3)) => '(1 3)) +(check (delete! 2 '(1 2 3)) => '(1 3)) + +(check (delete-duplicates '(a b a c a b c z)) => '(a b c z)) +(check (delete-duplicates! '(a b a c a b c z)) => '(a b c z)) +(check (delete-duplicates '((a . 3) (b . 7) (a . 9) (c . 1)) (lambda (x y) (eq? (car x) (car y)))) => '((a . 3) (b . 7) (c . 1))) +(check (delete-duplicates! '((a . 3) (b . 7) (a . 9) (c . 1)) (lambda (x y) (eq? (car x) (car y)))) => '((a . 3) (b . 7) (c . 1))) + +(check (assq 'a '((a 1) (b 2) (c 3))) => '(a 1)) +(check (assq 'b '((a 1) (b 2) (c 3))) => '(b 2)) +(check (assq 'd '((a 1) (b 2) (c 3))) => #f) +(check (assq (list 'a) '(((a)) ((b)) ((c)))) => #f) +(check (assoc (list 'a) '(((a)) ((b)) ((c)))) => '((a))) +(check (assq 5 '((2 3) (5 7) (11 13))) => #f) +(check (assv 5 '((2 3) (5 7) (11 13))) => '(5 7)) + +(check (alist-cons 'a 1 '((b . 2) (c . 3))) => '((a . 1) (b . 2) (c . 3))) + +(check (alist-copy '((a . 1) (b . 2) (c . 3))) => '((a . 1) (b . 2) (c . 3))) + +(check (alist-delete 'a '((a 1) (b 2) (c 3))) => '((b 2) (c 3))) +(check (alist-delete! 'a '((a 1) (b 2) (c 3))) => '((b 2) (c 3))) +(check (alist-delete 'b '((a 1) (b 2) (c 3))) => '((a 1) (c 3))) +(check (alist-delete! 'b '((a 1) (b 2) (c 3))) => '((a 1) (c 3))) +(check (alist-delete 'c '((a 1) (b 2) (c 3))) => '((a 1) (b 2))) +(check (alist-delete! 'c '((a 1) (b 2) (c 3))) => '((a 1) (b 2))) + +(check (lset= eq? '(b e a) '(a e b) '(e e b a)) => #t) +(check (lset= eq? '(a)) => #t) +(check (lset= eq?) => #t) + +(check (lset<= eq? '(a) '(a b a) '(a b c c)) => #t) +(check (lset<= eq? '(a)) => #t) +(check (lset<= eq?) => #t) + +(check (lset-adjoin eq? '(a b c d c e) 'a 'e 'i 'o 'u) => '(u o i a b c d c e)) + +(check (lset-union eq? '(a b c d e) '(a e i o u)) => '(u o i a b c d e)) +(check (lset-union! eq? '(a b c d e) '(a e i o u)) => '(u o i a b c d e)) +(check (lset-union eq? '(a a c) '(x a x)) => '(x a a c)) +(check (lset-union! eq? '(a a c) '(x a x)) => '(x a a c)) +(check (lset-union eq?) => '()) +(check (lset-union! eq?) => '()) +(check (lset-union eq? '(a b c)) => '(a b c)) +(check (lset-union! eq? '(a b c)) => '(a b c)) + +(check (lset-intersection eq? '(a b c d e) '(a e i o u)) => '(a e)) +(check (lset-intersection! eq? '(a b c d e) '(a e i o u)) => '(a e)) +(check (lset-intersection eq? '(a x y a) '(x a x z)) => '(a x a)) +(check (lset-intersection! eq? '(a x y a) '(x a x z)) => '(a x a)) +(check (lset-intersection eq? '(a b c)) => '(a b c)) +(check (lset-intersection! eq? '(a b c)) => '(a b c)) + +(check (lset-difference eq? '(a b c d e) '(a e i o u)) => '(b c d)) +(check (lset-difference! eq? '(a b c d e) '(a e i o u)) => '(b c d)) +(check (lset-difference eq? '(a b c)) => '(a b c)) +(check (lset-difference! eq? '(a b c)) => '(a b c)) + +(check (lset-xor eq? '(a b c d e) '(a e i o u)) => '(u o i b c d)) +(check (lset-xor! eq? '(a b c d e) '(a e i o u)) => '(u o i b c d)) +(check (lset-xor eq?) => '()) +(check (lset-xor! eq?) => '()) +(check (lset-xor eq? '(a b c d e)) => '(a b c d e)) +(check (lset-xor! eq? '(a b c d e)) => '(a b c d e)) + +(call-with-values (lambda () (lset-diff+intersection eq? '(a b c d e) '(a e i o u))) (lambda (x y) (check x => '(b c d)) (check y => '(a e)))) +(call-with-values (lambda () (lset-diff+intersection! eq? '(a b c d e) '(a e i o u))) (lambda (x y) (check x => '(b c d)) (check y => '(a e)))) + +(check-report) + +(exit (check-passed? 408))