├── .gitignore ├── init └── scheme │ ├── read.sld │ ├── case-lambda.sld │ ├── write.sld │ ├── process-context.sld │ ├── cxr.sld │ ├── file.sld │ └── base.sld ├── test ├── test.sld └── nqueens.scm ├── Makefile ├── LICENSE ├── README.md ├── main.scm ├── r7expander ├── syntactic-closure.sld └── library.sld ├── extlib ├── pp.scm └── srfi │ └── 1.sld └── init.scm /.gitignore: -------------------------------------------------------------------------------- 1 | r7expander.scm -------------------------------------------------------------------------------- /init/scheme/read.sld: -------------------------------------------------------------------------------- 1 | (define-library (scheme read) 2 | (export read) 3 | (import (only (r7expander native) read))) 4 | -------------------------------------------------------------------------------- /test/test.sld: -------------------------------------------------------------------------------- 1 | (define-library (foo bar) 2 | (import (scheme base)) 3 | (begin 4 | (define x 1) 5 | (let ((y 2)) 6 | (+ x y)))) 7 | -------------------------------------------------------------------------------- /init/scheme/case-lambda.sld: -------------------------------------------------------------------------------- 1 | (define-library (scheme case-lambda) 2 | (export case-lambda) 3 | (import (only (r7expander builtin) 4 | case-lambda))) 5 | -------------------------------------------------------------------------------- /init/scheme/write.sld: -------------------------------------------------------------------------------- 1 | (define-library (scheme write) 2 | (export write 3 | write-simple 4 | write-shared 5 | display) 6 | (import (only (r7expander native) 7 | write 8 | write-simple 9 | write-shared 10 | display))) 11 | -------------------------------------------------------------------------------- /init/scheme/process-context.sld: -------------------------------------------------------------------------------- 1 | (define-library (scheme process-context) 2 | (export command-line 3 | emergency-exit 4 | exit 5 | get-environment-variable 6 | get-environment-variables) 7 | (import (only (r7expander native) 8 | command-line 9 | emergency-exit 10 | exit 11 | get-environment-variable 12 | get-environment-variables))) 13 | -------------------------------------------------------------------------------- /init/scheme/cxr.sld: -------------------------------------------------------------------------------- 1 | (define-library (scheme cxr) 2 | (export caaar caadr cadar caddr 3 | cdaar cdadr cddar cdddr 4 | caaaar caaadr caadar caaddr 5 | cadaar cadadr caddar cadddr 6 | cdaaar cdaadr cdadar cdaddr 7 | cddaar cddadr cdddar cddddr) 8 | (import (only (r7expander native) 9 | caaar caadr cadar caddr 10 | cdaar cdadr cddar cdddr 11 | caaaar caaadr caadar caaddr 12 | cadaar cadadr caddar cadddr 13 | cdaaar cdaadr cdadar cdaddr 14 | cddaar cddadr cdddar cddddr))) 15 | -------------------------------------------------------------------------------- /init/scheme/file.sld: -------------------------------------------------------------------------------- 1 | (define-library (scheme file) 2 | (export call-with-input-file call-with-output-file 3 | delete-file file-exists? 4 | open-binary-input-file open-binary-output-file 5 | open-input-file open-output-file 6 | with-input-from-file with-output-to-file) 7 | (import (only (r7expander native) 8 | call-with-input-file call-with-output-file 9 | delete-file file-exists? 10 | open-binary-input-file open-binary-output-file 11 | open-input-file open-output-file 12 | with-input-from-file with-output-to-file))) 13 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | GOSH = env GAUCHE_KEYWORD_IS_SYMBOL=1 gosh 2 | RUN_SCRIPT = $(GOSH) -l ./r7expander/syntactic-closure.sld -l ./r7expander/library.sld -- 3 | RUN_COMPILED = $(GOSH) -u scheme.base -- 4 | OPTS = -l ./extlib/srfi/1.sld -l ./r7expander/syntactic-closure.sld -l ./r7expander/library.sld main.scm 5 | 6 | r7expander.scm: r7expander/syntactic-closure.sld r7expander/library.sld extlib/srfi/1.sld extlib/pp.scm init/*/*.sld init.scm main.scm 7 | $(RUN_SCRIPT) ./main.scm $(OPTS) > expander1.scm 8 | $(RUN_COMPILED) ./expander1.scm $(OPTS) > expander2.scm 9 | diff expander1.scm expander2.scm || { echo "compilation results unmatched"; exit 1; } 10 | echo "#!/usr/bin/env -S GAUCHE_KEYWORD_IS_SYMBOL=1 gosh -u scheme.base -u srfi.1 --" > r7expander.scm 11 | cat expander1.scm >> r7expander.scm 12 | chmod +x r7expander.scm 13 | $(RM) expander1.scm expander2.scm 14 | 15 | clean: 16 | $(RM) ./r7expander.scm 17 | 18 | .PHONY: clean 19 | 20 | -------------------------------------------------------------------------------- /test/nqueens.scm: -------------------------------------------------------------------------------- 1 | ;;; NQUEENS -- Compute number of solutions to 8-queens problem. 2 | 3 | (import (scheme base) 4 | (scheme write)) 5 | 6 | (define (nqueens n) 7 | 8 | (define (dec-to n) 9 | (let loop ((i n) (l '())) 10 | (if (= i 0) l (loop (- i 1) (cons i l))))) 11 | 12 | (define (try x y z) 13 | (if (null? x) 14 | (if (null? y) 15 | 1 16 | 0) 17 | (+ (if (ok? (car x) 1 z) 18 | (try (append (cdr x) y) '() (cons (car x) z)) 19 | 0) 20 | (try (cdr x) (cons (car x) y) z)))) 21 | 22 | (define (ok? row dist placed) 23 | (if (null? placed) 24 | #t 25 | (and (not (= (car placed) (+ row dist))) 26 | (not (= (car placed) (- row dist))) 27 | (ok? row (+ dist 1) (cdr placed))))) 28 | 29 | (try (dec-to n) '() '())) 30 | 31 | (display (nqueens 8)) 32 | (newline) 33 | 34 | ;;; This program is taken from https://wiki.call-cc.org/chicken-compilation-process. 35 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Permission is hereby granted, free of charge, to any 2 | person obtaining a copy of this software and associated 3 | documentation files (the "Software"), to deal in the 4 | Software without restriction, including without 5 | limitation the rights to use, copy, modify, merge, 6 | publish, distribute, sublicense, and/or sell copies of 7 | the Software, and to permit persons to whom the Software 8 | is furnished to do so, subject to the following 9 | conditions: 10 | 11 | The above copyright notice and this permission notice 12 | shall be included in all copies or substantial portions 13 | of the Software. 14 | 15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF 16 | ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED 17 | TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A 18 | PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT 19 | SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY 20 | CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION 21 | OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR 22 | IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER 23 | DEALINGS IN THE SOFTWARE. -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # TL;DR 2 | 3 | ```scheme 4 | ;;; test.sld 5 | (define-library (foo bar) 6 | (import (scheme base)) 7 | (begin 8 | (define x 1) 9 | (let ((y 2)) 10 | (+ x y)))) 11 | ``` 12 | 13 | ```shell 14 | $ make 15 | $ ./r7expander.scm -l test.sld 16 | (begin 17 | (define foo.bar:x 1) 18 | ((lambda (%y.0) (+ foo.bar:x %y.0)) 2)) 19 | > 20 | ``` 21 | 22 | # r7expander: a macro expander for R7RS 23 | 24 | r7expander is a macro expander for R7RS. 25 | This expander implements an expander for R7RS macros and libraries. 26 | Given a r7rs program or library, it will 27 | 28 | 1. resolve library import sets and manage export sets, 29 | 2. rename local/global variables, and 30 | 3. expand all macros. 31 | 32 | r7expander is inspired by Al Petrosky's alexpander. 33 | Similarly to his system, r7expander is a simple data-in data-out program. 34 | Some differences are listed below: 35 | 36 | - Main part of the program is implemented as reusable R7RS libraries. 37 | - It deals with the library system. 38 | - Technically, it uses syntactic closures as basic blocks of hygienic expansion. 39 | 40 | Produced programs will be valid R5RS programs that may contain R5RS primitives 41 | 42 | - function calls, variables, constants, 43 | - if, quote, set!, lambda, define (only binary ones), begin, 44 | 45 | together with 46 | 47 | - parameterize, 48 | - define-record-type, and 49 | - case-lambda. 50 | 51 | Internal definitions are not translated into letrec* because outputs can have internal define-record-type, which we don't know how to expand into internal (ordinary) definitions. 52 | 53 | # Implementation notes 54 | 55 | Non-standard built-in libraries listed below: 56 | 57 | - `(r7expander builtin)` exports basic keywords such as `define` and `lambda`. 58 | - `(r7expander native)` exports all native procedures available. 59 | 60 | #### License 61 | 62 | 63 | Licensed under MIT license. 64 | 65 | 66 |
67 | 68 | 69 | Unless you explicitly state otherwise, any contribution intentionally submitted 70 | for inclusion in r7expander by you shall be licensed as above, without any additional terms or conditions. 71 | -------------------------------------------------------------------------------- /main.scm: -------------------------------------------------------------------------------- 1 | ;;; Run the script with either of the followings: 2 | ;;; 1. $ env GAUCHE_KEYWORD_IS_SYMBOL=1 gosh -l ./r7expander/syntactic-closure.sld -l ./r7expander/library.sld -- ./main.scm 3 | ;;; 2. $ csc -R r7rs -prologue r7expander/syntactic-closure.sld -prologue r7expander/library.sld main.scm && ./main 4 | 5 | (import (scheme base) 6 | (scheme file) 7 | (scheme read) 8 | (scheme write) 9 | (scheme process-context) 10 | (r7expander library)) 11 | 12 | ;;; for init.scm 13 | (import (r7expander syntactic-closure) 14 | (scheme cxr) 15 | (srfi 1)) 16 | 17 | (include "extlib/pp.scm") 18 | 19 | (define (file->list filename) 20 | (call-with-input-file filename 21 | (lambda (port) 22 | (let loop ((form (read port)) (acc '())) 23 | (if (eof-object? form) 24 | (reverse acc) 25 | (loop (read port) (cons form acc))))))) 26 | 27 | (define (load-library-from-file filename) 28 | (let ((forms (file->list filename))) 29 | (unless (and (= (length forms) 1) 30 | (list? (car forms)) 31 | (>= (length (car forms)) 2) 32 | (eq? (caar forms) 'define-library)) 33 | (error "malformed library file")) 34 | (expand-library (car forms)))) 35 | 36 | (define (load-program-from-file filename) 37 | (let ((forms (file->list filename))) 38 | (expand-program forms))) 39 | 40 | (include "init.scm") 41 | 42 | (define repl-environment 43 | (make-toplevel-environment 44 | (lambda (id) 45 | (string->symbol 46 | (string-append 47 | "r7rs.repl:" 48 | (symbol->string id)))))) 49 | 50 | (define (start-repl) 51 | (expand-repl '(import (scheme base)) repl-environment) 52 | (let loop () 53 | (display "> ") 54 | (flush-output-port) 55 | (let ((form (read))) 56 | (unless (eof-object? form) 57 | (pretty-print (expand-repl form repl-environment)) 58 | (loop))))) 59 | 60 | (let loop ((opts (cdr (command-line)))) 61 | (cond 62 | ((null? opts) 63 | (start-repl)) 64 | ((equal? (car opts) "-l") 65 | (pretty-print (load-library-from-file (cadr opts))) 66 | (loop (cddr opts))) 67 | ((and (null? (cdr opts))) 68 | (pretty-print (load-program-from-file (car opts)))) 69 | (else 70 | (error "invalid command line arguments" opts)))) 71 | -------------------------------------------------------------------------------- /r7expander/syntactic-closure.sld: -------------------------------------------------------------------------------- 1 | ;;; Hygienic macro expander 2 | 3 | (define-library (r7expander syntactic-closure) 4 | (export syntactic-closure? make-syntactic-closure 5 | make-identifier identifier? identifier=? 6 | close-syntax unwrap-syntax 7 | assq-environment extend-environment extend-environment! 8 | expander? make-expander install-expander! 9 | make-toplevel-environment toplevel-environment? 10 | current-toplevel-environment with-toplevel-environment 11 | install-toplevel-binding! 12 | current-meta-environment with-meta-environment 13 | expand 14 | capture-syntactic-environment sc-macro-transformer rsc-macro-transformer 15 | er-macro-transformer) 16 | (import (scheme base) 17 | (scheme case-lambda) 18 | (srfi 1)) 19 | (begin 20 | (define-record-type environment 21 | (make-environment base frame renamer) ; at toplevel all symbols (but identifiers) are bound 22 | environment? 23 | (base enclosing-environment) 24 | (frame environment-frame set-environment-frame!) 25 | (renamer environment-renamer)) 26 | 27 | (define (make-toplevel-environment renamer) 28 | (make-environment #f '() renamer)) 29 | 30 | (define (toplevel-environment? env) 31 | (not (enclosing-environment env))) 32 | 33 | (define current-toplevel-environment 34 | (make-parameter #f)) 35 | 36 | (define (with-toplevel-environment top-env thunk) 37 | (parameterize ((current-toplevel-environment top-env)) 38 | (thunk))) 39 | 40 | (define (assq-environment id env) 41 | (let ((frame (environment-frame env))) 42 | (or (assq id frame) 43 | (if (toplevel-environment? env) 44 | (and (symbol? id) 45 | (let ((new-name ((environment-renamer env) id))) 46 | (set-environment-frame! env (alist-cons id new-name frame)) 47 | (assq-environment id env))) 48 | (assq-environment id (enclosing-environment env)))))) 49 | 50 | (define (install-toplevel-binding! id name top-env) 51 | (let ((frame (environment-frame top-env))) 52 | (set-environment-frame! top-env (alist-cons id name frame)))) 53 | 54 | (define-record-type syntactic-closure-type 55 | (make-syntactic-closure env free form) 56 | syntactic-closure? 57 | (env syntactic-closure-environment) 58 | (free syntactic-closure-free-names) 59 | (form syntactic-closure-form)) 60 | 61 | (define (close-syntax form env) 62 | (make-syntactic-closure env '() form)) 63 | 64 | (define (unwrap-syntax obj) 65 | (cond 66 | ((syntactic-closure? obj) 67 | (unwrap-syntax (syntactic-closure-form obj))) 68 | ((pair? obj) 69 | (cons (unwrap-syntax (car obj)) (unwrap-syntax (cdr obj)))) 70 | ((vector? obj) 71 | (vector-map unwrap-syntax obj)) 72 | (else 73 | obj))) 74 | 75 | (define (make-identifier id env) 76 | (close-syntax id env)) 77 | 78 | (define (identifier? obj) 79 | (or (symbol? obj) 80 | (and (syntactic-closure? obj) 81 | (identifier? (syntactic-closure-form obj))))) 82 | 83 | (define (identifier=? id1 env1 id2 env2) 84 | (eq? (expand id1 env1) (expand id2 env2))) 85 | 86 | (define generate-name 87 | (let ((n 0)) 88 | (lambda (id) 89 | (let ((m n)) 90 | (set! n (+ n 1)) 91 | (string->symbol 92 | (string-append 93 | "%" 94 | (symbol->string (unwrap-syntax id)) 95 | "." 96 | (number->string m))))))) 97 | 98 | (define (extend-environment! id env) 99 | (unless (and (toplevel-environment? env) (symbol? id)) 100 | (let ((frame (environment-frame env))) 101 | (cond 102 | ((assq id frame) 103 | (error "duplicate binding" id)) 104 | (else 105 | (let ((name (generate-name id))) 106 | (set-environment-frame! env (alist-cons id name frame)))))))) 107 | 108 | (define (extend-environment ids env) 109 | (let ((new-env (make-environment env '() #f))) 110 | (for-each 111 | (lambda (id) 112 | (extend-environment! id new-env)) 113 | ids) 114 | new-env)) 115 | 116 | (define-record-type expander 117 | (make-expander transformer environment) expander? 118 | (transformer expander-transformer) 119 | (environment expander-environment)) 120 | 121 | (define (install-expander! keyword expander env) 122 | (extend-environment! keyword env) 123 | (let ((cell (assq-environment keyword env))) 124 | (set-cdr! cell expander))) 125 | 126 | (define current-meta-environment 127 | (make-parameter #f)) 128 | 129 | (define (with-meta-environment meta-env thunk) 130 | (parameterize ((current-meta-environment meta-env)) 131 | (thunk))) 132 | 133 | (define expand 134 | (let () 135 | (define (expand form env) 136 | (let expand ((form form)) 137 | (cond 138 | ((identifier? form) (expand-identifier form env)) 139 | ((syntactic-closure? form) (expand-syntactic-closure form env)) 140 | ((and (pair? form) (list? form)) 141 | (if (identifier? (car form)) 142 | (let ((e (expand (car form)))) 143 | (if (expander? e) 144 | (expand-macro e form env) 145 | `(,e ,@(map expand (cdr form))))) 146 | (map expand form))) 147 | ((not (pair? form)) form) 148 | (else 149 | (error "invalid expression" form))))) 150 | 151 | (define (expand-macro expander form env) 152 | (let ((transformer (expander-transformer expander)) 153 | (meta-env (expander-environment expander))) 154 | (with-meta-environment meta-env 155 | (lambda () 156 | (transformer form env))))) 157 | 158 | (define (expand-syntactic-closure sc env) 159 | (expand (syntactic-closure-form sc) 160 | (make-environment 161 | (syntactic-closure-environment sc) 162 | (map (lambda (id) `(,id . ,(expand id env))) 163 | (syntactic-closure-free-names sc)) 164 | #f))) 165 | 166 | (define (expand-identifier id env) 167 | (cond ((assq-environment id env) => cdr) 168 | (else (expand-identifier 169 | (syntactic-closure-form id) 170 | (syntactic-closure-environment id))))) 171 | 172 | (case-lambda 173 | ((form) 174 | (expand form (current-toplevel-environment))) 175 | ((form env) 176 | (expand form env))))) 177 | 178 | (define (make-singular-form proc) 179 | (let ((expander (make-expander (lambda (form env) (proc env)) (current-meta-environment)))) 180 | (let ((env (make-toplevel-environment (lambda (id) (error "logic flaw"))))) 181 | (extend-environment! 'foo env) 182 | (install-expander! 'foo expander env) 183 | `(,(make-identifier 'foo env))))) 184 | 185 | (define (capture-syntactic-environment proc) 186 | (make-singular-form 187 | (lambda (env) 188 | (expand (proc env) env)))) 189 | 190 | (define (sc-macro-transformer proc) 191 | (lambda (form env) 192 | (expand (proc form env) (current-meta-environment)))) 193 | 194 | (define (rsc-macro-transformer proc) 195 | (lambda (form env) 196 | (expand (proc form (current-meta-environment)) env))) 197 | 198 | (define (er-macro-transformer proc) 199 | (lambda (form env) 200 | (let ((table '())) 201 | (let ((rename (lambda (x) 202 | (cond 203 | ((assq x table) => cdr) 204 | (else (let ((id (make-identifier x (current-meta-environment)))) 205 | (set! table (alist-cons x id table)) 206 | id))))) 207 | (compare (lambda (x y) 208 | (identifier=? x env y env)))) 209 | (expand (proc form rename compare) env))))))) 210 | 211 | ;;; Local Variables: 212 | ;;; eval: (put 'with-toplevel-environment 'scheme-indent-function 1) 213 | ;;; eval: (put 'with-meta-environment 'scheme-indent-function 1) 214 | ;;; End: 215 | -------------------------------------------------------------------------------- /r7expander/library.sld: -------------------------------------------------------------------------------- 1 | ;;; R7RS expander 2 | 3 | ;;; toplevel mutable states: 4 | ;;; - library-table 5 | ;;; - feature-list 6 | 7 | ;;; TODO 8 | ;;; - check import collision 9 | ;;; - check if exported symbols are defined 10 | 11 | (define-library (r7expander library) 12 | (export expand-library expand-program expand-repl expand-toplevel 13 | make-library with-library current-library library-exists? 14 | library-import library-export 15 | feature-list) 16 | (import (scheme base) 17 | (scheme cxr) 18 | (scheme read) 19 | (scheme file) 20 | (srfi 1) 21 | (r7expander syntactic-closure)) 22 | (begin 23 | (define (make-r7rs-toplevel-environment prefix) 24 | (make-toplevel-environment 25 | (lambda (id) 26 | (string->symbol 27 | (string-append 28 | prefix 29 | (symbol->string id)))))) 30 | 31 | (define-record-type library-object 32 | (make-library-object environment exports) library-object? 33 | (environment library-object-environment) 34 | (exports library-object-exports set-library-object-exports!)) 35 | 36 | (define library-table 37 | '()) 38 | 39 | (define (assoc-library spec) 40 | (assoc spec library-table)) 41 | 42 | (define current-library 43 | (make-parameter #f)) 44 | 45 | (define (with-library spec thunk) 46 | (parameterize ((current-library spec)) 47 | (let ((env (library-environment (current-library)))) 48 | (with-toplevel-environment env thunk)))) 49 | 50 | (define make-library 51 | (let () 52 | (define (make-library spec) 53 | (let ((env (make-r7rs-toplevel-environment (mangle-library-spec spec)))) 54 | (let ((obj (make-library-object env '()))) 55 | (set! library-table (alist-cons spec obj library-table))))) 56 | 57 | (define (mangle-library-spec spec) 58 | (let rec ((spec spec)) 59 | (if (null? spec) 60 | "" 61 | (string-append 62 | (cond 63 | ((symbol? (car spec)) 64 | (symbol->string (car spec))) 65 | ((number? (car spec)) 66 | (number->string (car spec)))) 67 | (if (null? (cdr spec)) 68 | ":" 69 | (string-append 70 | "." 71 | (rec (cdr spec)))))))) 72 | 73 | make-library)) 74 | 75 | (define (library-environment spec) 76 | (cond ((assoc-library spec) => 77 | (lambda (cell) 78 | (library-object-environment (cdr cell)))) 79 | (else 80 | (error "library not found" spec)))) 81 | 82 | (define (library-exports spec) 83 | (cond ((assoc-library spec) => 84 | (lambda (cell) 85 | (library-object-exports (cdr cell)))) 86 | (else 87 | (error "library not found" spec)))) 88 | 89 | (define (library-exists? spec) 90 | (and (assoc-library spec) #t)) 91 | 92 | (define (expand-library form) 93 | (let ((spec (cadr form))) 94 | (make-library spec) 95 | (with-library spec 96 | (lambda () 97 | (let ((decls (cddr form))) 98 | (let ((forms (append-map interpret-library-declaration decls))) 99 | (expand-toplevel forms))))))) 100 | 101 | (define (interpret-library-declaration decl) 102 | (case (car decl) 103 | ((begin) 104 | (cdr decl)) 105 | ((import) 106 | (for-each library-import (cdr decl)) 107 | '()) 108 | ((export) 109 | (for-each library-export (cdr decl)) 110 | '()) 111 | ((cond-expand) 112 | (interpret-cond-expand (cdr decl))) 113 | ((include) 114 | (files->list (cdr decl))) 115 | ((include-library-declarations) 116 | (append-map interpret-library-declaration (files->list (cdr decl)))))) 117 | 118 | (define library-import 119 | (let () 120 | (define (library-import spec) 121 | (let ((name-map (make-name-map spec))) 122 | (let ((env (current-toplevel-environment))) 123 | (for-each 124 | (lambda (c) 125 | (install-toplevel-binding! (car c) (cdr c) env)) ; TODO redefinition of macros 126 | name-map)))) 127 | 128 | (define (make-name-map spec) 129 | (case (car spec) 130 | ((prefix) 131 | (let ((name-map (make-name-map (cadr spec)))) 132 | (map (lambda (c) 133 | (let ((nickname 134 | (string->symbol 135 | (string-append 136 | (symbol->string (caddr spec)) 137 | (symbol->string (car c)))))) 138 | (cons nickname (cdr c)))) 139 | name-map))) 140 | ((only) 141 | (let ((name-map (make-name-map (cadr spec)))) 142 | (let ((args (cddr spec))) 143 | (map (lambda (v) (assq v name-map)) args)))) 144 | ((except) 145 | (let loop ((name-map (make-name-map (cadr spec))) (args (cddr spec))) 146 | (if (null? args) 147 | name-map 148 | (loop (alist-delete (car args) name-map) (cdr args))))) 149 | ((rename) 150 | (let loop ((name-map (make-name-map (cadr spec))) (args (cddr spec))) 151 | (map (lambda (c) 152 | (let loop ((args (cddr spec))) 153 | (cond 154 | ((null? args) c) 155 | ((eq? (car c) (caar args)) (cons (cadar args) (cdr c))) 156 | (else (loop (cdr args)))))) 157 | name-map))) 158 | (else 159 | (let ((exports (library-exports spec)) 160 | (env (library-environment spec))) 161 | (map (lambda (cell) 162 | (let ((nickname (car cell)) (id (cdr cell))) 163 | (let ((name (cdr (assq-environment id env)))) 164 | `(,nickname . ,name)))) 165 | exports))))) 166 | 167 | library-import)) 168 | 169 | (define (library-export spec) 170 | (let-values 171 | (((id nickname) 172 | (if (symbol? spec) 173 | (values spec spec) 174 | (values (cadr spec) (caddr spec))))) 175 | (let ((obj (cdr (assoc-library (current-library))))) 176 | (let ((exports (library-object-exports obj))) 177 | (set-library-object-exports! obj (alist-cons nickname id exports)))))) 178 | 179 | (define feature-list 180 | '()) 181 | 182 | (define (interpret-cond-expand clauses) ; follows srfi-0 semantics 183 | (let loop ((clauses clauses)) 184 | (if (null? clauses) 185 | (error "unfulfilled cond-expand") 186 | (let ((c (caar clauses))) 187 | (if (or (eq? c 'else) 188 | (let test ((c c)) 189 | (if (symbol? c) 190 | (memq c feature-list) 191 | (case (car c) 192 | ((library) 193 | (library-exists? (cadr c))) 194 | ((not) 195 | (not (test (cadr c)))) 196 | ((and) 197 | (let loop ((cs (cdr c))) 198 | (or (null? cs) 199 | (and (test (car cs)) 200 | (loop (cdr cs)))))) 201 | ((or) 202 | (let loop ((cs (cdr c))) 203 | (and (pair? cs) 204 | (or (test (car cs)) 205 | (loop (cdr cs)))))))))) 206 | (append-map interpret-library-declaration (cdar clauses)) 207 | (loop (cdr clauses))))))) 208 | 209 | (define (files->list filenames) 210 | (let loop ((filenames filenames) (acc '())) 211 | (if (null? filenames) 212 | (reverse acc) 213 | (loop (cdr filenames) 214 | (call-with-input-file (car filenames) 215 | (lambda (port) 216 | (let loop ((form (read port)) (acc acc)) 217 | (if (eof-object? form) 218 | acc 219 | (loop (read port) (cons form acc)))))))))) 220 | 221 | (define (expand-program forms) 222 | (let ((env (make-r7rs-toplevel-environment "r7expander.program:"))) 223 | (with-toplevel-environment env 224 | (lambda () 225 | (let loop ((forms forms)) 226 | (cond 227 | ((and (pair? (car forms)) 228 | (eq? (caar forms) 'import) 229 | (eq? (cdr (assq-environment 'import env)) 'r7expander.program:import)) ; FIXME 230 | (for-each library-import (cdar forms)) 231 | (loop (cdr forms))) 232 | (else 233 | (expand-toplevel forms)))))))) 234 | 235 | (define (expand-repl form env) 236 | (with-toplevel-environment env 237 | (lambda () 238 | (cond 239 | ((and (list? form) (eq? (car form) 'import)) ; FIXME 240 | (for-each library-import (cdr form)) 241 | '(begin)) 242 | (else 243 | (expand-toplevel (list form))))))) 244 | 245 | (define expand-toplevel 246 | (let () 247 | (define (expand-toplevel forms) 248 | (let ((forms (map expand forms))) 249 | (let ((forms (let flatten ((form `(begin ,@forms))) 250 | (if (and (pair? form) (eq? (car form) 'begin)) 251 | (append-map flatten (cdr form)) 252 | (list form))))) 253 | (let ((forms (map (lambda (form) (post-expand form #t)) forms))) 254 | (if (= (length forms) 1) 255 | (car forms) 256 | `(begin . ,forms)))))) 257 | 258 | (define (post-expand form allow-definition?) 259 | (cond 260 | ((symbol? form) 261 | form) 262 | ((vector? form) 263 | `',form) 264 | ((expander? form) 265 | (error "invalid use of keyword" form)) 266 | ((not (list? form)) 267 | form) 268 | (else 269 | (case (car form) 270 | ((quote) 271 | form) 272 | ((begin) 273 | (when (null? (cdr form)) 274 | (error "malformed begin" form)) 275 | `(begin ,@(map (lambda (form) (post-expand form #f)) (cdr form)))) 276 | ((define) 277 | (unless allow-definition? 278 | (error "invalid definition" form)) 279 | `(define ,(cadr form) ,(post-expand (caddr form) #f))) 280 | ((define-record-type) 281 | (unless allow-definition? 282 | (error "invalid record type definition" form)) 283 | form) 284 | ((lambda) 285 | `(lambda ,(cadr form) 286 | ,@(map (lambda (form) (post-expand form #t)) (cddr form)))) 287 | (else 288 | (map (lambda (form) (post-expand form #f)) form)))))) 289 | 290 | expand-toplevel)))) 291 | 292 | ;;; Local Variables: 293 | ;;; eval: (put 'with-library 'scheme-indent-function 1) 294 | ;;; eval: (put 'with-toplevel-environment 'scheme-indent-function 1) 295 | ;;; eval: (put 'install-keyword! 'scheme-indent-function 1) 296 | ;;; End: 297 | -------------------------------------------------------------------------------- /extlib/pp.scm: -------------------------------------------------------------------------------- 1 | ; File: "pp.scm" (c) 1991, Marc Feeley 2 | 3 | ; 'generic-write' is a procedure that transforms a Scheme data value (or 4 | ; Scheme program expression) into its textual representation. The interface 5 | ; to the procedure is sufficiently general to easily implement other useful 6 | ; formatting procedures such as pretty printing, output to a string and 7 | ; truncated output. 8 | ; 9 | ; Parameters: 10 | ; 11 | ; OBJ Scheme data value to transform. 12 | ; DISPLAY? Boolean, controls whether characters and strings are quoted. 13 | ; WIDTH Extended boolean, selects format: 14 | ; #f = single line format 15 | ; integer > 0 = pretty-print (value = max nb of chars per line) 16 | ; OUTPUT Procedure of 1 argument of string type, called repeatedly 17 | ; with successive substrings of the textual representation. 18 | ; This procedure can return #f to stop the transformation. 19 | ; 20 | ; The value returned by 'generic-write' is undefined. 21 | ; 22 | ; Examples: 23 | ; 24 | ; (write obj) = (generic-write obj #f #f display-string) 25 | ; (display obj) = (generic-write obj #t #f display-string) 26 | ; 27 | ; where display-string = (lambda (s) (for-each write-char (string->list s)) #t) 28 | 29 | (define (generic-write obj display? width output) 30 | 31 | (define (read-macro? l) 32 | (define (length1? l) (and (pair? l) (null? (cdr l)))) 33 | (let ((head (car l)) (tail (cdr l))) 34 | (case head 35 | ((quote quasiquote unquote unquote-splicing) (length1? tail)) 36 | (else #f)))) 37 | 38 | (define (read-macro-body l) 39 | (cadr l)) 40 | 41 | (define (read-macro-prefix l) 42 | (let ((head (car l)) (tail (cdr l))) 43 | (case head 44 | ((quote) "'") 45 | ((quasiquote) "`") 46 | ((unquote) ",") 47 | ((unquote-splicing) ",@")))) 48 | 49 | (define (out str col) 50 | (and col (output str) (+ col (string-length str)))) 51 | 52 | (define (wr obj col) 53 | 54 | (define (wr-expr expr col) 55 | (if (read-macro? expr) 56 | (wr (read-macro-body expr) (out (read-macro-prefix expr) col)) 57 | (wr-lst expr col))) 58 | 59 | (define (wr-lst l col) 60 | (if (pair? l) 61 | (let loop ((l (cdr l)) (col (wr (car l) (out "(" col)))) 62 | (and col 63 | (cond ((pair? l) (loop (cdr l) (wr (car l) (out " " col)))) 64 | ((null? l) (out ")" col)) 65 | (else (out ")" (wr l (out " . " col))))))) 66 | (out "()" col))) 67 | 68 | (cond ((pair? obj) (wr-expr obj col)) 69 | ((null? obj) (wr-lst obj col)) 70 | ((vector? obj) (wr-lst (vector->list obj) (out "#" col))) 71 | ((boolean? obj) (out (if obj "#t" "#f") col)) 72 | ((number? obj) (out (number->string obj) col)) 73 | ((symbol? obj) (out (symbol->string obj) col)) 74 | ((procedure? obj) (out "#[procedure]" col)) 75 | ((string? obj) (if display? 76 | (out obj col) 77 | (let loop ((i 0) (j 0) (col (out "\"" col))) 78 | (if (and col (< j (string-length obj))) 79 | (let ((c (string-ref obj j))) 80 | (if (or (char=? c #\\) 81 | (char=? c #\")) 82 | (loop j 83 | (+ j 1) 84 | (out "\\" 85 | (out (substring obj i j) 86 | col))) 87 | (loop i (+ j 1) col))) 88 | (out "\"" 89 | (out (substring obj i j) col)))))) 90 | ((char? obj) (if display? 91 | (out (make-string 1 obj) col) 92 | (out (case obj 93 | ((#\space) "space") 94 | ((#\newline) "newline") 95 | (else (make-string 1 obj))) 96 | (out "#\\" col)))) 97 | ((input-port? obj) (out "#[input-port]" col)) 98 | ((output-port? obj) (out "#[output-port]" col)) 99 | ((eof-object? obj) (out "#[eof-object]" col)) 100 | (else (out "#[unknown]" col)))) 101 | 102 | (define (pp obj col) 103 | 104 | (define (spaces n col) 105 | (if (> n 0) 106 | (if (> n 7) 107 | (spaces (- n 8) (out " " col)) 108 | (out (substring " " 0 n) col)) 109 | col)) 110 | 111 | (define (indent to col) 112 | (and col 113 | (if (< to col) 114 | (and (out (make-string 1 #\newline) col) (spaces to 0)) 115 | (spaces (- to col) col)))) 116 | 117 | (define (pr obj col extra pp-pair) 118 | (if (or (pair? obj) (vector? obj)) ; may have to split on multiple lines 119 | (let ((result '()) 120 | (left (min (+ (- (- width col) extra) 1) max-expr-width))) 121 | (generic-write obj display? #f 122 | (lambda (str) 123 | (set! result (cons str result)) 124 | (set! left (- left (string-length str))) 125 | (> left 0))) 126 | (if (> left 0) ; all can be printed on one line 127 | (out (reverse-string-append result) col) 128 | (if (pair? obj) 129 | (pp-pair obj col extra) 130 | (pp-list (vector->list obj) (out "#" col) extra pp-expr)))) 131 | (wr obj col))) 132 | 133 | (define (pp-expr expr col extra) 134 | (if (read-macro? expr) 135 | (pr (read-macro-body expr) 136 | (out (read-macro-prefix expr) col) 137 | extra 138 | pp-expr) 139 | (let ((head (car expr))) 140 | (if (symbol? head) 141 | (let ((proc (style head))) 142 | (if proc 143 | (proc expr col extra) 144 | (if (> (string-length (symbol->string head)) 145 | max-call-head-width) 146 | (pp-general expr col extra #f #f #f pp-expr) 147 | (pp-call expr col extra pp-expr)))) 148 | (pp-list expr col extra pp-expr))))) 149 | 150 | ; (head item1 151 | ; item2 152 | ; item3) 153 | (define (pp-call expr col extra pp-item) 154 | (let ((col* (wr (car expr) (out "(" col)))) 155 | (and col 156 | (pp-down (cdr expr) col* (+ col* 1) extra pp-item)))) 157 | 158 | ; (item1 159 | ; item2 160 | ; item3) 161 | (define (pp-list l col extra pp-item) 162 | (let ((col (out "(" col))) 163 | (pp-down l col col extra pp-item))) 164 | 165 | (define (pp-down l col1 col2 extra pp-item) 166 | (let loop ((l l) (col col1)) 167 | (and col 168 | (cond ((pair? l) 169 | (let ((rest (cdr l))) 170 | (let ((extra (if (null? rest) (+ extra 1) 0))) 171 | (loop rest 172 | (pr (car l) (indent col2 col) extra pp-item))))) 173 | ((null? l) 174 | (out ")" col)) 175 | (else 176 | (out ")" 177 | (pr l 178 | (indent col2 (out "." (indent col2 col))) 179 | (+ extra 1) 180 | pp-item))))))) 181 | 182 | (define (pp-general expr col extra named? pp-1 pp-2 pp-3) 183 | 184 | (define (tail1 rest col1 col2 col3) 185 | (if (and pp-1 (pair? rest)) 186 | (let* ((val1 (car rest)) 187 | (rest (cdr rest)) 188 | (extra (if (null? rest) (+ extra 1) 0))) 189 | (tail2 rest col1 (pr val1 (indent col3 col2) extra pp-1) col3)) 190 | (tail2 rest col1 col2 col3))) 191 | 192 | (define (tail2 rest col1 col2 col3) 193 | (if (and pp-2 (pair? rest)) 194 | (let* ((val1 (car rest)) 195 | (rest (cdr rest)) 196 | (extra (if (null? rest) (+ extra 1) 0))) 197 | (tail3 rest col1 (pr val1 (indent col3 col2) extra pp-2))) 198 | (tail3 rest col1 col2))) 199 | 200 | (define (tail3 rest col1 col2) 201 | (pp-down rest col2 col1 extra pp-3)) 202 | 203 | (let* ((head (car expr)) 204 | (rest (cdr expr)) 205 | (col* (wr head (out "(" col)))) 206 | (if (and named? (pair? rest)) 207 | (let* ((name (car rest)) 208 | (rest (cdr rest)) 209 | (col** (wr name (out " " col*)))) 210 | (tail1 rest (+ col indent-general) col** (+ col** 1))) 211 | (tail1 rest (+ col indent-general) col* (+ col* 1))))) 212 | 213 | (define (pp-expr-list l col extra) 214 | (pp-list l col extra pp-expr)) 215 | 216 | (define (pp-lambda expr col extra) 217 | (pp-general expr col extra #f pp-expr-list #f pp-expr)) 218 | 219 | (define (pp-if expr col extra) 220 | (pp-general expr col extra #f pp-expr #f pp-expr)) 221 | 222 | (define (pp-cond expr col extra) 223 | (pp-call expr col extra pp-expr-list)) 224 | 225 | (define (pp-case expr col extra) 226 | (pp-general expr col extra #f pp-expr #f pp-expr-list)) 227 | 228 | (define (pp-and expr col extra) 229 | (pp-call expr col extra pp-expr)) 230 | 231 | (define (pp-let expr col extra) 232 | (let* ((rest (cdr expr)) 233 | (named? (and (pair? rest) (symbol? (car rest))))) 234 | (pp-general expr col extra named? pp-expr-list #f pp-expr))) 235 | 236 | (define (pp-begin expr col extra) 237 | (pp-general expr col extra #f #f #f pp-expr)) 238 | 239 | (define (pp-do expr col extra) 240 | (pp-general expr col extra #f pp-expr-list pp-expr-list pp-expr)) 241 | 242 | ; define formatting style (change these to suit your style) 243 | 244 | (define indent-general 2) 245 | 246 | (define max-call-head-width 5) 247 | 248 | (define max-expr-width 50) 249 | 250 | (define (style head) 251 | (case head 252 | ((lambda let* letrec define) pp-lambda) 253 | ((if set!) pp-if) 254 | ((cond) pp-cond) 255 | ((case) pp-case) 256 | ((and or) pp-and) 257 | ((let) pp-let) 258 | ((begin) pp-begin) 259 | ((do) pp-do) 260 | (else #f))) 261 | 262 | (pr obj col 0 pp-expr)) 263 | 264 | (if width 265 | (out (make-string 1 #\newline) (pp obj 0)) 266 | (wr obj 0))) 267 | 268 | ; (reverse-string-append l) = (apply string-append (reverse l)) 269 | 270 | (define (reverse-string-append l) 271 | 272 | (define (rev-string-append l i) 273 | (if (pair? l) 274 | (let* ((str (car l)) 275 | (len (string-length str)) 276 | (result (rev-string-append (cdr l) (+ i len)))) 277 | (let loop ((j 0) (k (- (- (string-length result) i) len))) 278 | (if (< j len) 279 | (begin 280 | (string-set! result k (string-ref str j)) 281 | (loop (+ j 1) (+ k 1))) 282 | result))) 283 | (make-string i))) 284 | 285 | (rev-string-append l 0)) 286 | 287 | ; (object->string obj) returns the textual representation of 'obj' as a 288 | ; string. 289 | ; 290 | ; Note: (write obj) = (display (object->string obj)) 291 | 292 | (define (object->string obj) 293 | (let ((result '())) 294 | (generic-write obj #f #f (lambda (str) (set! result (cons str result)) #t)) 295 | (reverse-string-append result))) 296 | 297 | ; (object->limited-string obj limit) returns a string containing the first 298 | ; 'limit' characters of the textual representation of 'obj'. 299 | 300 | (define (object->limited-string obj limit) 301 | (let ((result '()) (left limit)) 302 | (generic-write obj #f #f 303 | (lambda (str) 304 | (let ((len (string-length str))) 305 | (if (> len left) 306 | (begin 307 | (set! result (cons (substring str 0 left) result)) 308 | (set! left 0) 309 | #f) 310 | (begin 311 | (set! result (cons str result)) 312 | (set! left (- left len)) 313 | #t))))) 314 | (reverse-string-append result))) 315 | 316 | ; (pretty-print obj port) pretty prints 'obj' on 'port'. The current 317 | ; output port is used if 'port' is not specified. 318 | 319 | (define (pretty-print obj . opt) 320 | (let ((port (if (pair? opt) (car opt) (current-output-port)))) 321 | (generic-write obj #f 79 (lambda (s) (display s port) #t)))) 322 | 323 | ; (pretty-print-to-string obj) returns a string with the pretty-printed 324 | ; textual representation of 'obj'. 325 | 326 | (define (pretty-print-to-string obj) 327 | (let ((result '())) 328 | (generic-write obj #f 79 (lambda (str) (set! result (cons str result)) #t)) 329 | (reverse-string-append result))) 330 | -------------------------------------------------------------------------------- /init/scheme/base.sld: -------------------------------------------------------------------------------- 1 | (define-library (scheme base) 2 | (export 3 | ;; 4.1.2. Literal expressions 4 | quote 5 | ;; 4.1.4. Procedures 6 | lambda 7 | ;; 4.1.5. Conditionals 8 | if 9 | ;; 4.1.6. Assignments 10 | set! 11 | ;; 4.1.7. Inclusion 12 | include 13 | ;; 4.2.1. Conditionals 14 | cond else => case and or when unless cond-expand library 15 | ;; 4.2.2. Binding constructs 16 | let let* letrec letrec* let-values let*-values 17 | ;; 4.2.3. Sequencing 18 | begin 19 | ;; 4.2.4. Iteration 20 | do 21 | ;; 4.2.6. Dynamic bindings 22 | make-parameter parameterize 23 | ;; 4.2.7. Exception handling 24 | guard 25 | ;; 4.2.8. Quasiquotation 26 | quasiquote unquote unquote-splicing 27 | ;; 4.3.1. Binding constructs for syntactic keywords 28 | let-syntax letrec-syntax 29 | ;; 4.3.2 Pattern language 30 | syntax-rules _ ... 31 | ;; 4.3.3. Signaling errors in macro transformers 32 | syntax-error 33 | ;; 5.3. Variable definitions 34 | define 35 | ;; 5.3.3. Multiple-value definitions 36 | define-values 37 | ;; 5.4. Syntax definitions 38 | define-syntax 39 | ;; 5.5 Record-type definitions 40 | define-record-type 41 | ;; 6.1. Equivalence predicates 42 | eq? eqv? equal? 43 | ;; 6.2. Numbers 44 | number? complex? real? rational? integer? 45 | exact? inexact? exact-integer? 46 | exact inexact 47 | = < > <= >= 48 | zero? positive? negative? odd? even? 49 | min max + - * / abs 50 | floor-quotient floor-remainder floor/ 51 | truncate-quotient truncate-remainder truncate/ 52 | (rename truncate-quotient quotient) 53 | (rename truncate-remainder remainder) 54 | (rename floor-remainder modulo) 55 | gcd lcm 56 | numerator denominator 57 | floor ceiling truncate round 58 | rationalize 59 | exact-integer-sqrt square expt 60 | number->string string->number 61 | ;; 6.3. Booleans 62 | boolean? boolean=? not 63 | ;; 6.4 Pairs and lists 64 | pair? cons car cdr set-car! set-cdr! 65 | caar cadr cdar cddr 66 | null? list? make-list list 67 | length append reverse list-tail 68 | list-ref list-set! 69 | list-copy 70 | memq memv member 71 | assq assv assoc 72 | ;; 6.5. Symbols 73 | symbol? symbol=? symbol->string string->symbol 74 | ;; 6.6. Characters 75 | char? char->integer integer->char 76 | char=? char? char<=? char>=? 77 | ;; 6.7. Strings 78 | string? string make-string 79 | string-length string-ref string-set! 80 | string=? string? string<=? string>=? 81 | (rename string-copy substring) 82 | string-append 83 | string->list list->string 84 | string-copy string-copy! string-fill! 85 | ;; 6.8. Vectors 86 | vector? vector make-vector 87 | vector-length vector-ref vector-set! 88 | list->vector vector->list 89 | string->vector vector->string 90 | vector-copy vector-copy! vector-append vector-fill! 91 | ;; 6.9. Bytevectors 92 | bytevector? make-bytevector bytevector 93 | bytevector-length bytevector-u8-ref bytevector-u8-set! 94 | bytevector-copy bytevector-copy! bytevector-append 95 | utf8->string string->utf8 96 | ;; 6.10. Control features 97 | procedure? apply 98 | map for-each 99 | string-map string-for-each 100 | vector-map vector-for-each 101 | call-with-current-continuation 102 | (rename call-with-current-continuation call/cc) 103 | values call-with-values 104 | dynamic-wind 105 | ;; 6.11. Exceptions 106 | with-exception-handler 107 | raise raise-continuable error 108 | error-object? error-object-message error-object-irritants 109 | read-error? file-error? 110 | ;; 6.13. Input and output 111 | current-input-port current-output-port current-error-port 112 | call-with-port 113 | port? input-port? output-port? textual-port? binary-port? 114 | input-port-open? output-port-open? 115 | close-port close-input-port close-output-port 116 | open-input-string open-output-string get-output-string 117 | open-input-bytevector open-output-bytevector get-output-bytevector 118 | eof-object? eof-object 119 | read-char peek-char char-ready? read-line read-string 120 | read-u8 peek-u8 u8-ready? read-bytevector read-bytevector! 121 | newline write-char write-string write-u8 write-bytevector 122 | flush-output-port) 123 | 124 | (import (rename 125 | (only (r7expander builtin) 126 | lambda define quote if set! begin 127 | let-syntax letrec-syntax define-syntax syntax-error 128 | syntax-rules _ ... 129 | include if-expand 130 | define-record-type parameterize) 131 | (define define*))) 132 | 133 | (import (only (r7expander native) 134 | ;; 4.2.6. Dynamic bindings 135 | make-parameter 136 | ;; 6.1. Equivalence predicates 137 | eq? eqv? equal? 138 | ;; 6.2. Numbers 139 | number? complex? real? rational? integer? 140 | exact? inexact? exact-integer? 141 | exact inexact 142 | = < > <= >= 143 | zero? positive? negative? odd? even? 144 | min max + - * / abs 145 | floor-quotient floor-remainder floor/ 146 | truncate-quotient truncate-remainder truncate/ 147 | gcd lcm 148 | numerator denominator 149 | floor ceiling truncate round 150 | rationalize 151 | exact-integer-sqrt square expt 152 | number->string string->number 153 | ;; 6.3. Booleans 154 | boolean? boolean=? not 155 | ;; 6.4 Pairs and lists 156 | pair? cons car cdr set-car! set-cdr! 157 | caar cadr cdar cddr 158 | null? list? make-list list 159 | length append reverse list-tail 160 | list-ref list-set! 161 | list-copy 162 | memq memv member 163 | assq assv assoc 164 | ;; 6.5. Symbols 165 | symbol? symbol=? symbol->string string->symbol 166 | ;; 6.6. Characters 167 | char? char->integer integer->char 168 | char=? char? char<=? char>=? 169 | ;; 6.7. Strings 170 | string? string make-string 171 | string-length string-ref string-set! 172 | string=? string? string<=? string>=? 173 | string-append 174 | string->list list->string 175 | string-copy string-copy! string-fill! 176 | ;; 6.8. Vectors 177 | vector? vector make-vector 178 | vector-length vector-ref vector-set! 179 | list->vector vector->list 180 | string->vector vector->string 181 | vector-copy vector-copy! vector-append vector-fill! 182 | ;; 6.9. Bytevectors 183 | bytevector? make-bytevector bytevector 184 | bytevector-length bytevector-u8-ref bytevector-u8-set! 185 | bytevector-copy bytevector-copy! bytevector-append 186 | utf8->string string->utf8 187 | ;; 6.10. Control features 188 | procedure? apply 189 | map for-each 190 | string-map string-for-each 191 | vector-map vector-for-each 192 | call-with-current-continuation 193 | values call-with-values 194 | dynamic-wind 195 | ;; 6.11. Exceptions 196 | with-exception-handler 197 | raise raise-continuable error 198 | error-object? error-object-message error-object-irritants 199 | read-error? file-error? 200 | ;; 6.13. Input and output 201 | current-input-port current-output-port current-error-port 202 | call-with-port 203 | port? input-port? output-port? textual-port? binary-port? 204 | input-port-open? output-port-open? 205 | close-port close-input-port close-output-port 206 | open-input-string open-output-string get-output-string 207 | open-input-bytevector open-output-bytevector get-output-bytevector 208 | eof-object? eof-object 209 | read-char peek-char char-ready? read-line read-string 210 | read-u8 peek-u8 u8-ready? read-bytevector read-bytevector! 211 | newline write-char write-string write-u8 write-bytevector 212 | flush-output-port)) 213 | (begin 214 | (define-syntax define 215 | (syntax-rules () 216 | ((define (identifier . formals) . body) 217 | (define identifier 218 | (lambda formals . body))) 219 | ((define identifier expr) 220 | (define* identifier expr)))) 221 | 222 | (define-syntax cond 223 | (syntax-rules (else =>) 224 | ((cond) 225 | (if #f #f)) 226 | ((cond (else expr ...)) 227 | (begin expr ...)) 228 | ((cond (test => proc) clause ...) 229 | (let ((tmp test)) 230 | (if tmp 231 | (proc tmp) 232 | (cond clause ...)))) 233 | ((cond (test) clause ...) 234 | (or test 235 | (cond clause ...))) 236 | ((cond (test expr ...) clause ...) 237 | (if test 238 | (begin expr ...) 239 | (cond clause ...))))) 240 | 241 | (define-syntax case 242 | (syntax-rules () 243 | ((case key0 clause0 ...) 244 | (letrec-syntax 245 | ((case-aux 246 | (syntax-rules ::: (else =>) 247 | ((_ key) 248 | (if #f #f)) 249 | ((_ key (else expr :::)) 250 | (begin expr :::)) 251 | ((_ key (else => proc)) 252 | (proc key)) 253 | ((_ key ((atoms :::) => proc) clause :::) 254 | (if (memv key '(atoms :::)) 255 | (proc key) 256 | (case-aux key clause :::))) 257 | ((_ key ((atoms :::) expr :::) clause :::) 258 | (if (memv key '(atoms :::)) 259 | (begin expr :::) 260 | (case-aux key clause :::)))))) 261 | (let ((tmp key0)) 262 | (case-aux tmp clause0 ...)))))) 263 | 264 | (define-syntax and 265 | (syntax-rules () 266 | ((and) #t) 267 | ((and form) form) 268 | ((and form rest ...) 269 | (if form 270 | (and rest ...) 271 | #f)))) 272 | 273 | (define-syntax or 274 | (syntax-rules () 275 | ((or) #f) 276 | ((or form) form) 277 | ((or form rest ...) 278 | (let ((tmp form)) 279 | (if tmp 280 | tmp 281 | (or rest ...)))))) 282 | 283 | (define-syntax when 284 | (syntax-rules () 285 | ((when test expr ...) 286 | (if test 287 | (begin expr ...))))) 288 | 289 | (define-syntax unless 290 | (syntax-rules () 291 | ((unless test expr ...) 292 | (when (not test) expr ...)))) 293 | 294 | (define-syntax cond-expand ; follows R7RS semantics 295 | (syntax-rules (else library and or not) 296 | ((cond-expand) 297 | (if #f #f)) 298 | ((cond-expand (else expr ...)) 299 | (begin expr ...)) 300 | ((cond-expand ((and) expr ...) clause ...) 301 | (begin expr ...)) 302 | ((cond-expand ((and test1 test2 ...) expr ...) clause ...) 303 | (cond-expand 304 | (test1 305 | (cond-expand 306 | ((and test2 ...) 307 | expr ...) 308 | clause ...)) 309 | clause ...)) 310 | ((cond-expand ((or) expr ...) clause ...) 311 | (cond-expand 312 | clause ...)) 313 | ((cond-expand ((or test1 test2 ...) expr ...) clause ...) 314 | (cond-expand 315 | (test1 expr ...) 316 | ((or test2 ...) expr ...) 317 | clause ...)) 318 | ((cond-expand ((not test) expr ...) clause ...) 319 | (cond-expand 320 | (test 321 | (cond-expand clause ...)) 322 | (else 323 | expr ...))) 324 | ((cond-expand ((library spec) expr ...) clause ...) 325 | (if-expand (library spec) 326 | (begin expr ...) 327 | (cond-expand clause ...))) 328 | ((cond-expand (feature expr ...) clause ...) 329 | (if-expand feature 330 | (begin expr ...) 331 | (cond-expand clause ...))))) 332 | 333 | (define-syntax let 334 | (syntax-rules () 335 | ((let ((var init) ...) body ...) 336 | ((lambda (var ...) 337 | body ...) 338 | init ...)) 339 | ((let loop ((var init) ...) body ...) 340 | (letrec ((loop (lambda (var ...) 341 | body ...))) 342 | (loop init ...))))) 343 | 344 | (define-syntax let* 345 | (syntax-rules () 346 | ((let* () body ...) 347 | (let () body ...)) 348 | ((let* ((var init) rest ...) body ...) 349 | (let ((var init)) 350 | (let* (rest ...) body ...))))) 351 | 352 | (define-syntax letrec 353 | (syntax-rules () 354 | ((letrec ((var0 init0) ...) body0 ...) 355 | (letrec-syntax 356 | ((letrec-aux 357 | (syntax-rules ::: () 358 | ((_ () (tmp :::) ((var init) :::) . body) 359 | (let ((var (if #f #f)) :::) 360 | (let ((tmp init) :::) 361 | (set! var tmp) 362 | ::: 363 | (let () . body)))) 364 | ((_ (var vars :::) tmps bindings . body) 365 | (letrec-aux (vars :::) (newtmp . tmps) bindings . body))))) 366 | (letrec-aux (var0 ...) () ((var0 init0) ...) body0 ...))))) 367 | 368 | (define-syntax letrec* 369 | (syntax-rules () 370 | ((letrec* ((var init) ...) body ...) 371 | (let ((var (if #f #f)) ...) 372 | (set! var init) 373 | ... 374 | (let () 375 | body ...))))) 376 | 377 | (define-syntax let-values 378 | (syntax-rules () 379 | ((let-values ((formals0 init0) ...) body0 ...) 380 | (letrec-syntax 381 | ((lv-aux 382 | (syntax-rules ::: () 383 | ((_ () () bindings . body) 384 | (let bindings . body)) 385 | ((_ new-formals ((() init) . rest) bindings . body) 386 | (call-with-values (lambda () init) 387 | (lambda new-formals 388 | (lv-aux () rest bindings . body)))) 389 | ((_ (tmp :::) (((x . y) init) . rest) bindings . body) 390 | (lv-aux (tmp ::: new-tmp) ((y init) . rest) ((x new-tmp) . bindings) . body)) 391 | ((_ (tmp :::) ((x init) . rest) bindings . body) 392 | (lv-aux (tmp ::: . new-tmp) ((() init) . rest) ((x new-tmp) . bindings) . body))))) 393 | (lv-aux () ((formals0 init0) ...) () body0 ...))))) 394 | 395 | (define-syntax let*-values 396 | (syntax-rules () 397 | ((let*-values () body ...) 398 | (let () body ...)) 399 | ((let*-values ((formals init) rest ...) body ...) 400 | (let-values ((formals init)) 401 | (let*-values (rest ...) body ...))))) 402 | 403 | (define-syntax do 404 | (syntax-rules () 405 | ((do ((var init step ...) ...) 406 | (test epilogue ...) 407 | form ...) 408 | (let loop ((var init) ...) 409 | (if test 410 | (begin (if #f #f) epilogue ...) 411 | (begin form ... (loop (begin var step ...) ...))))))) 412 | 413 | (define-syntax guard 414 | (syntax-rules () 415 | ((guard (var0 clause0 ...) body0 ...) 416 | (letrec-syntax 417 | ((guard-aux 418 | (syntax-rules ::: (else =>) 419 | ((_ reraise) 420 | reraise) 421 | ((_ reraise (else expr :::)) 422 | (begin expr :::)) 423 | ((_ reraise (test => proc) clause :::) 424 | (let ((tmp test)) 425 | (if tmp 426 | (proc tmp) 427 | (guard-aux reraise clause :::)))) 428 | ((_ reraise (test) clause :::) 429 | (or test 430 | (guard-aux reraise clause :::))) 431 | ((_ reraise (test expr :::) clause :::) 432 | (if test 433 | (begin expr :::) 434 | (guard-aux reraise clause :::)))))) 435 | ((call/cc 436 | (lambda (guard-k) 437 | (with-exception-handler 438 | (lambda (condition) 439 | ((call/cc 440 | (lambda (handler-k) 441 | (guard-k 442 | (lambda () 443 | (let ((var0 condition)) 444 | (guard-aux (handler-k 445 | (lambda () 446 | (raise-continuable condition))) 447 | clause0 ...)))))))) 448 | (lambda () 449 | (call-with-values (lambda () body0 ...) 450 | (lambda args 451 | (guard-k (lambda () 452 | (apply values args)))))))))))))) 453 | 454 | (define-syntax quasiquote ; taken from EIOD 455 | (syntax-rules (unquote unquote-splicing quasiquote) 456 | ((quasiquote (quasiquote x) . d) 457 | (list 'quasiquote (quasiquote x d))) 458 | ((quasiquote (unquote x)) 459 | x) 460 | ((quasiquote (unquote x) d) 461 | (list 'unquote (quasiquote x . d))) 462 | ((quasiquote ((unquote-splicing x) . y)) 463 | (append x (quasiquote y))) 464 | ((quasiquote (unquote-splicing x) d) 465 | (list 'unquote-splicing (quasiquote x . d))) 466 | ((quasiquote (x . y) . d) 467 | (cons (quasiquote x . d) (quasiquote y . d))) 468 | ;; ((quasiquote #(x ...) . d) 469 | ;; (vector (quasiquote x . d) ...)) 470 | ((quasiquote x . d) 471 | 'x))) 472 | 473 | (define-syntax define-values 474 | (syntax-rules () 475 | ((define-values formals init) 476 | (define-values-aux formals () () init)))) 477 | 478 | (define-syntax define-values-aux ; use define-syntax because letrec-syntax creates an environment 479 | (syntax-rules () 480 | ((_ () new-formals ((var tmp) ...) init) 481 | (begin 482 | (define var (if #f #f)) 483 | ... 484 | (define dummy 485 | (call-with-values (lambda () init) 486 | (lambda new-formals 487 | (set! var tmp) 488 | ...))))) 489 | ((_ (x . y) (tmp ...) bindings init) 490 | (define-values-aux y (tmp ... new-tmp) ((x new-tmp) . bindings) init)) 491 | ((_ x (tmp ...) bindings init) 492 | (define-values-aux () (tmp ... . new-tmp) ((x new-tmp) . bindings) init)))))) 493 | -------------------------------------------------------------------------------- /init.scm: -------------------------------------------------------------------------------- 1 | (make-library '(r7expander builtin)) 2 | (with-library '(r7expander builtin) 3 | (lambda () 4 | (define (install-builtin! keyword transformer) 5 | (let ((env (current-toplevel-environment))) 6 | (let ((expander (make-expander transformer env))) 7 | (install-expander! keyword expander env))) 8 | (library-export keyword)) 9 | 10 | (for-each library-export '(syntax-rules _ ...)) 11 | 12 | (install-builtin! 'lambda 13 | (lambda (form env) 14 | (unless (>= (length form) 3) 15 | (error "malformed lambda" form)) 16 | (let ((formals (cadr form)) 17 | (body (cddr form))) 18 | (let ((formal-list 19 | (let loop ((formals formals) (acc '())) 20 | (cond ((null? formals) 21 | acc) 22 | ((pair? formals) 23 | (and (identifier? (car formals)) 24 | (loop (cdr formals) `(,(car formals) . ,acc)))) 25 | (else 26 | (and (identifier? formals) 27 | `(,formals . ,acc))))))) 28 | (unless formal-list 29 | (error "invalid formal arguments" formals)) 30 | (let ((new-env (extend-environment formal-list env))) 31 | `(lambda ,(let rec ((formals formals)) 32 | (cond 33 | ((null? formals) 34 | '()) 35 | ((pair? formals) 36 | `(,(expand (car formals) new-env) . ,(rec (cdr formals)))) 37 | (else 38 | (expand formals new-env)))) 39 | ,@(let ((body (map (lambda (form) (expand form new-env)) body))) 40 | (define (expand-definition form) 41 | (cond 42 | ((not (pair? form))) 43 | ((eq? (car form) 'quote)) 44 | ((eq? (car form) 'lambda)) 45 | ((eq? (car form) 'define) 46 | (let ((body (expand (list-ref form 2) new-env))) 47 | (list-set! form 2 body) 48 | (expand-definition body))) 49 | (else 50 | (for-each expand-definition form)))) 51 | 52 | (for-each expand-definition body) 53 | 54 | (let () 55 | (define (definition? form) 56 | (cond 57 | ((not (pair? form)) #f) 58 | ((eq? (car form) 'define)) 59 | ((eq? (car form) 'define-record-type)) 60 | ((eq? (car form) 'begin) (every definition? (cdr form))) 61 | (else #f))) 62 | 63 | (define (splice-definition definition) 64 | (case (car definition) 65 | ((define define-record-type) `(,definition)) 66 | (else (append-map splice-definition (cdr definition))))) 67 | 68 | (let loop ((rest body) (definitions '())) 69 | (cond 70 | ((null? rest) 71 | (error "expression required" (last body))) 72 | ((definition? (car rest)) 73 | (loop (cdr rest) 74 | `(,(splice-definition (car rest)) . ,definitions))) 75 | (else 76 | (append (apply append (reverse definitions)) rest)))))))))))) 77 | 78 | (install-builtin! 'define 79 | (lambda (form env) 80 | (unless (and (= (length form) 3) 81 | (identifier? (cadr form))) 82 | (error "malformed define" form)) 83 | (let ((formal (cadr form)) 84 | (expr (caddr form))) 85 | (extend-environment! formal env) 86 | `(define ,(expand formal env) 87 | ,(if (toplevel-environment? env) 88 | (expand expr env) 89 | expr))))) ; expand later on 90 | 91 | (install-builtin! 'define-record-type 92 | (lambda (form env) 93 | (unless (and (>= (length form) 4) 94 | (identifier? (list-ref form 1)) 95 | (list? (list-ref form 2)) 96 | (every identifier? (list-ref form 2)) 97 | (identifier? (list-ref form 3)) 98 | (every (lambda (field-spec) 99 | (and (list? field-spec) 100 | (every identifier? field-spec) 101 | (let ((l (length field-spec))) 102 | (or (= l 2) (= l 3))))) 103 | (list-tail form 4)) 104 | (let ((fields (map car (list-tail form 4)))) 105 | (every (lambda (formal) 106 | (memq formal fields)) 107 | (cdr (list-ref form 2))))) 108 | (error "malformed define-record-type" form)) 109 | (let ((type (list-ref form 1)) 110 | (constructor (car (list-ref form 2))) 111 | (formals (cdr (list-ref form 2))) 112 | (predicate (list-ref form 3)) 113 | (field-specs (list-tail form 4))) 114 | (extend-environment! type env) 115 | (extend-environment! constructor env) 116 | (extend-environment! predicate env) 117 | (for-each 118 | (lambda (field-spec) 119 | (extend-environment! (list-ref field-spec 1) env) 120 | (when (= (length field-spec) 3) 121 | (extend-environment! (list-ref field-spec 2) env))) 122 | field-specs) 123 | (let ((new-env (extend-environment (map car field-specs) env))) 124 | `(define-record-type ,(expand type env) 125 | (,(expand constructor env) ,@(map (lambda (formal) (expand formal new-env)) formals)) 126 | ,(expand predicate env) 127 | ,@(map 128 | (lambda (field-spec) 129 | (if (= (length field-spec) 2) 130 | `(,(expand (car field-spec) new-env) 131 | ,(expand (cadr field-spec) env)) 132 | `(,(expand (car field-spec) new-env) 133 | ,(expand (cadr field-spec) env) 134 | ,(expand (caddr field-spec) env)))) 135 | field-specs)))))) 136 | 137 | (install-builtin! 'quote 138 | (lambda (form env) 139 | (unless (= (length form) 2) 140 | (error "malformed quote" form)) 141 | (let ((obj (unwrap-syntax (cadr form)))) 142 | `',obj))) 143 | 144 | (install-builtin! 'if 145 | (lambda (form env) 146 | (case (length form) 147 | ((3) 148 | `(if ,(expand (cadr form) env) 149 | ,(expand (caddr form) env))) 150 | ((4) 151 | `(if ,(expand (cadr form) env) 152 | ,(expand (caddr form) env) 153 | ,(expand (cadddr form) env))) 154 | (else 155 | (error "malformed if" form))))) 156 | 157 | (install-builtin! 'set! 158 | (lambda (form env) 159 | (unless (and (= (length form) 3) 160 | (identifier? (cadr form))) 161 | (error "malformed set!" form)) 162 | `(set! ,(expand (cadr form) env) 163 | ,(expand (caddr form) env)))) 164 | 165 | (install-builtin! 'begin 166 | (lambda (form env) 167 | (let ((forms (cdr form))) 168 | `(begin ,@(map (lambda (form) (expand form env)) forms))))) 169 | 170 | (install-builtin! 'parameterize 171 | (lambda (form env) 172 | (unless (and (>= (length form) 3) 173 | (list? (cadr form)) 174 | (every (lambda (binding) 175 | (= (length binding) 2)) 176 | (cadr form))) 177 | (error "malformed parameterize" form)) 178 | `(parameterize ,(map (lambda (binding) 179 | (list (expand (car binding) env) 180 | (expand (cadr binding) env))) 181 | (cadr form)) 182 | ,(expand `((,(make-identifier 'lambda (current-meta-environment)) () 183 | ,@(cddr form))) 184 | env)))) 185 | 186 | (let () 187 | (define (interpret-transformer-spec spec env) 188 | (cond ((and (identifier? (car spec)) 189 | (identifier=? (car spec) env 'syntax-rules (current-meta-environment))) 190 | (make-expander (interpret-syntax-rules spec) env)) 191 | (else 192 | (error "unknown transformer spec" spec)))) 193 | 194 | (define (interpret-syntax-rules spec) 195 | (er-macro-transformer 196 | (lambda (form rename compare) 197 | 198 | ;; missing features: 199 | ;; - placeholder 200 | ;; - vector 201 | ;; - more syntax check (e.g. non-linearity of pattern variables) 202 | 203 | (define-values (ellipsis literals rules) 204 | (if (list? (cadr spec)) 205 | (values (make-identifier '... (current-meta-environment)) (cadr spec) (cddr spec)) 206 | (values (cadr spec) (caddr spec) (cdddr spec)))) 207 | 208 | ;; p ::= var | constant | (p . p) | (p . p) 209 | 210 | (define-syntax case-pattern 211 | (syntax-rules (variable-pattern constant-pattern ellipsis-pattern pair-pattern) 212 | ((_ pat 213 | ((variable-pattern var) . var-body) 214 | ((constant-pattern obj) . const-body) 215 | ((ellipsis-pattern rep succ) . ellipsis-body) 216 | ((pair-pattern head tail) . pair-body)) 217 | (let ((tmp pat)) 218 | (cond ((identifier? tmp) (let ((var tmp)) . var-body)) 219 | ((not (pair? tmp)) (let ((obj tmp)) . const-body)) 220 | ((and (pair? (cdr pat)) 221 | (identifier? (cadr pat)) 222 | (compare (cadr pat) ellipsis)) 223 | (let ((rep (car pat)) (succ (cddr pat))) . ellipsis-body)) 224 | (else (let ((head (car tmp)) (tail (cdr tmp))) . pair-body))))))) 225 | 226 | (define (pattern-variables pat) ; pattern -> ((var . depth)) 227 | (let go ((pat pat) (depth 0) (acc '())) 228 | (case-pattern pat 229 | ((variable-pattern var) (alist-cons var depth acc)) 230 | ((constant-pattern obj) acc) 231 | ((ellipsis-pattern rep-pat succ-pat) (go rep-pat (+ depth 1) (go succ-pat depth acc))) 232 | ((pair-pattern car-pat cdr-pat) (go car-pat depth (go cdr-pat depth acc)))))) 233 | 234 | (define (syntax-check pattern template) ; pattern * template -> undefined 235 | (let ((pattern-variables (pattern-variables pattern)) 236 | (template-variables (pattern-variables template))) 237 | (for-each 238 | (lambda (var-depth-in-template) 239 | (let ((var (car var-depth-in-template))) 240 | (let ((var-depth-in-pattern (assq var pattern-variables))) 241 | (when var-depth-in-pattern 242 | (unless (= (cdr var-depth-in-template) (cdr var-depth-in-pattern)) 243 | (error "syntax-rules: malformed rule" 244 | `(,pattern ,template) 245 | (unwrap-syntax (car var-depth-in-template)))))))) 246 | template-variables))) 247 | 248 | (define (pattern-match pat form) ; pattern * obj -> ((var . obj)) 249 | (call/cc 250 | (lambda (return) 251 | (let match ((pat pat) (form form)) 252 | (let* ((acc '()) (push! (lambda (x) (set! acc (cons x acc))))) 253 | (let walk ((pat pat) (form form)) 254 | (case-pattern pat 255 | ((variable-pattern var) 256 | (if (memq var literals) ; comparing literal identifiers using eq? 257 | (unless (and (identifier? form) 258 | (compare form (rename var))) 259 | (return #f)) 260 | (push! `(,var . ,form)))) 261 | ((constant-pattern obj) 262 | (unless (equal? pat form) 263 | (return #f))) 264 | ((ellipsis-pattern rep-pat succ-pat) 265 | (let () 266 | (define (reverse* x) 267 | (let loop ((x x) (acc '())) 268 | (if (pair? x) 269 | (loop (cdr x) (cons (car x) acc)) 270 | (values acc x)))) 271 | (let-values (((rev-pat last-pat) (reverse* succ-pat)) 272 | ((rev-form last-form) (reverse* form))) 273 | (walk last-pat last-form) 274 | (let ((rep-form (let loop ((rev-pat rev-pat) (rev-form rev-form)) 275 | (cond ((null? rev-pat) (reverse rev-form)) 276 | ((null? rev-form) (return #f)) 277 | (else (walk (car rev-pat) (car rev-form)) 278 | (loop (cdr rev-pat) (cdr rev-form))))))) 279 | (if (null? rep-form) 280 | (let ((variables (map car (pattern-variables rep-pat)))) 281 | (for-each 282 | (lambda (var) 283 | (push! `(,var . ()))) 284 | variables)) 285 | (let ((substs (map (lambda (obj) (match rep-pat obj)) rep-form))) 286 | (let ((variables (map car (car substs)))) 287 | (for-each 288 | (lambda (var) 289 | (push! `(,var . ,(map (lambda (subst) (cdr (assq var subst))) substs)))) 290 | variables)))))))) 291 | ((pair-pattern car-pat cdr-pat) 292 | (unless (pair? form) 293 | (return #f)) 294 | (walk car-pat (car form)) 295 | (walk cdr-pat (cdr form))))) 296 | acc))))) 297 | 298 | (define (rewrite-template template subst) ; template * ((var . obj)) -> obj 299 | (let rewrite ((template template)) 300 | (case-pattern template 301 | ((variable-pattern var) 302 | (cond 303 | ((assq var subst) => cdr) 304 | (else (rename var)))) 305 | ((constant-pattern obj) 306 | obj) 307 | ((ellipsis-pattern rep-templ succ-templ) 308 | (let ((vars-in-templ (map car (pattern-variables rep-templ)))) 309 | (let ((vars-to-unroll (filter (lambda (var) (assq var subst)) vars-in-templ))) 310 | (let ((vals-to-unroll (map (lambda (var) (cdr (assq var subst))) vars-to-unroll))) 311 | (let ((new-substs (apply map (lambda vals (map cons vars-to-unroll vals)) vals-to-unroll))) 312 | (append (map (lambda (subst) (rewrite-template rep-templ subst)) new-substs) 313 | (rewrite succ-templ))))))) 314 | ((pair-pattern car-templ cdr-templ) 315 | (cons (rewrite car-templ) 316 | (rewrite cdr-templ)))))) 317 | 318 | (let loop ((rules rules)) 319 | (if (null? rules) 320 | (error "no rule matched" form) 321 | (let ((rule (car rules))) 322 | (let ((pattern (car rule)) 323 | (template (cadr rule))) 324 | (syntax-check pattern template) 325 | (let ((subst (pattern-match pattern form))) 326 | (if subst 327 | (rewrite-template template subst) 328 | (loop (cdr rules))))))))))) 329 | 330 | (install-builtin! 'let-syntax 331 | (lambda (form env) 332 | (let ((bindings (cadr form)) 333 | (body (cddr form))) 334 | (let ((keywords (map car bindings)) 335 | (transformer-specs (map cadr bindings))) 336 | (let ((expanders (map (lambda (spec) (interpret-transformer-spec spec env)) transformer-specs))) 337 | (let ((new-env (extend-environment '() env))) 338 | (for-each 339 | (lambda (keyword expander) 340 | (install-expander! keyword expander new-env)) 341 | keywords expanders) 342 | (expand `((,(make-identifier 'lambda (current-meta-environment)) () ,@body)) new-env))))))) 343 | 344 | (install-builtin! 'letrec-syntax 345 | (lambda (form env) 346 | (let ((bindings (cadr form)) 347 | (body (cddr form))) 348 | (let ((keywords (map car bindings)) 349 | (transformer-specs (map cadr bindings))) 350 | (let ((new-env (extend-environment '() env))) 351 | (let ((expanders (map (lambda (spec) (interpret-transformer-spec spec new-env)) transformer-specs))) 352 | (for-each 353 | (lambda (keyword expander) 354 | (install-expander! keyword expander new-env)) 355 | keywords expanders) 356 | (expand `((,(make-identifier 'lambda (current-meta-environment)) () ,@body)) new-env))))))) 357 | 358 | (install-builtin! 'define-syntax 359 | (lambda (form env) 360 | (let ((keyword (cadr form)) 361 | (transformer-spec (caddr form))) 362 | (let ((expander (interpret-transformer-spec transformer-spec env))) 363 | (install-expander! keyword expander env) 364 | '(begin))))) 365 | 366 | (install-builtin! 'syntax-error 367 | (lambda (form _) 368 | (unless (and (>= (length form) 2) 369 | (string? (cadr form))) 370 | (error "malformed syntax-error" form)) 371 | (apply error (cdr form))))) 372 | 373 | (install-builtin! 'include 374 | (er-macro-transformer 375 | (lambda (form rename compare) 376 | (unless (every string? (cdr form)) 377 | (error "malformed include" form)) 378 | (let ((forms (let loop ((filenames (cdr form)) (acc '())) 379 | (if (null? filenames) 380 | (reverse acc) 381 | (loop (cdr filenames) 382 | (call-with-input-file (car filenames) 383 | (lambda (port) 384 | (let loop ((form (read port)) (acc acc)) 385 | (if (eof-object? form) 386 | acc 387 | (loop (read port) (cons form acc))))))))))) 388 | `(,(rename 'begin) ,@forms))))) 389 | 390 | (install-builtin! 'if-expand 391 | (er-macro-transformer 392 | (lambda (form rename compare) 393 | (unless (= (length form) 4) 394 | (error "malformed if-expand" form)) 395 | (let ((condition (cadr form))) 396 | (if (and (pair? condition) 397 | (compare (car condition) (rename 'library))) 398 | (if (library-exists? (unwrap-syntax (cadr condition))) 399 | (list-ref form 2) 400 | (list-ref form 3)) 401 | (if (memq (unwrap-syntax condition) feature-list) 402 | (list-ref form 2) 403 | (list-ref form 3))))))) 404 | 405 | (install-builtin! 'case-lambda 406 | (lambda (form env) 407 | `(case-lambda 408 | ,@(map (lambda (formal-body) 409 | (cdr (expand `(,(make-identifier 'lambda (current-meta-environment)) 410 | ,@formal-body) 411 | env))) 412 | (cdr form))))))) 413 | 414 | (make-library '(r7expander native)) 415 | (with-library '(r7expander native) 416 | (lambda () 417 | (define (install-native! keyword) 418 | (let ((env (current-toplevel-environment))) 419 | (install-toplevel-binding! keyword keyword env)) 420 | (library-export keyword)) 421 | 422 | (for-each install-native! 423 | '(;; (scheme base) 424 | ;; 4.2.6. Dynamic bindings 425 | make-parameter 426 | ;; 6.1. Equivalence predicates 427 | eq? eqv? equal? 428 | ;; 6.2. Numbers 429 | number? complex? real? rational? integer? 430 | exact? inexact? exact-integer? 431 | exact inexact 432 | = < > <= >= 433 | zero? positive? negative? odd? even? 434 | min max + - * / abs 435 | floor-quotient floor-remainder floor/ 436 | truncate-quotient truncate-remainder truncate/ 437 | gcd lcm 438 | numerator denominator 439 | floor ceiling truncate round 440 | rationalize 441 | exact-integer-sqrt square expt 442 | number->string string->number 443 | ;; 6.3. Booleans 444 | boolean? boolean=? not 445 | ;; 6.4 Pairs and lists 446 | pair? cons car cdr set-car! set-cdr! 447 | caar cadr cdar cddr 448 | null? list? make-list list 449 | length append reverse list-tail 450 | list-ref list-set! 451 | list-copy 452 | memq memv member 453 | assq assv assoc 454 | ;; 6.5. Symbols 455 | symbol? symbol=? symbol->string string->symbol 456 | ;; 6.6. Characters 457 | char? char->integer integer->char 458 | char=? char? char<=? char>=? 459 | ;; 6.7. Strings 460 | string? string make-string 461 | string-length string-ref string-set! 462 | string=? string? string<=? string>=? 463 | string-append 464 | string->list list->string 465 | string-copy string-copy! string-fill! 466 | ;; 6.8. Vectors 467 | vector? vector make-vector 468 | vector-length vector-ref vector-set! 469 | list->vector vector->list 470 | string->vector vector->string 471 | vector-copy vector-copy! vector-append vector-fill! 472 | ;; 6.9. Bytevectors 473 | bytevector? make-bytevector bytevector 474 | bytevector-length bytevector-u8-ref bytevector-u8-set! 475 | bytevector-copy bytevector-copy! bytevector-append 476 | utf8->string string->utf8 477 | ;; 6.10. Control features 478 | procedure? apply 479 | map for-each 480 | string-map string-for-each 481 | vector-map vector-for-each 482 | call-with-current-continuation 483 | values call-with-values 484 | dynamic-wind 485 | ;; 6.11. Exceptions 486 | with-exception-handler 487 | raise raise-continuable error 488 | error-object? error-object-message error-object-irritants 489 | read-error? file-error? 490 | ;; 6.13. Input and output 491 | current-input-port current-output-port current-error-port 492 | call-with-port 493 | port? input-port? output-port? textual-port? binary-port? 494 | input-port-open? output-port-open? 495 | close-port close-input-port close-output-port 496 | open-input-string open-output-string get-output-string 497 | open-input-bytevector open-output-bytevector get-output-bytevector 498 | eof-object? eof-object 499 | read-char peek-char char-ready? read-line read-string 500 | read-u8 peek-u8 u8-ready? read-bytevector read-bytevector! 501 | newline write-char write-string write-u8 write-bytevector 502 | flush-output-port 503 | ;; (scheme cxr) 504 | caaar caadr cadar caddr 505 | cdaar cdadr cddar cdddr 506 | caaaar caaadr caadar caaddr 507 | cadaar cadadr caddar cadddr 508 | cdaaar cdaadr cdadar cdaddr 509 | cddaar cddadr cdddar cddddr 510 | ;; (scheme file) 511 | call-with-input-file call-with-output-file 512 | delete-file file-exists? 513 | open-binary-input-file open-binary-output-file 514 | open-input-file open-output-file 515 | with-input-from-file with-output-to-file 516 | ;; (scheme process-context) 517 | command-line 518 | emergency-exit 519 | exit 520 | get-environment-variable 521 | get-environment-variables 522 | ;; (scheme read) 523 | read 524 | ;; (scheme write) 525 | write write-simple write-shared display)))) 526 | 527 | (load-library-from-file "init/scheme/base.sld") 528 | (set! feature-list (cons 'r7rs feature-list)) 529 | (load-library-from-file "init/scheme/case-lambda.sld") 530 | (load-library-from-file "init/scheme/cxr.sld") 531 | (load-library-from-file "init/scheme/file.sld") 532 | (load-library-from-file "init/scheme/process-context.sld") 533 | (load-library-from-file "init/scheme/read.sld") 534 | (load-library-from-file "init/scheme/write.sld") 535 | -------------------------------------------------------------------------------- /extlib/srfi/1.sld: -------------------------------------------------------------------------------- 1 | ;;; SRFI-1 list-processing library -*- Scheme -*- 2 | ;;; Reference implementation 3 | ;;; 4 | ;;; Copyright (c) 1998, 1999 by Olin Shivers. You may do as you please with 5 | ;;; this code as long as you do not remove this copyright notice or 6 | ;;; hold me liable for its use. Please send bug reports to shivers@ai.mit.edu. 7 | ;;; -Olin 8 | 9 | ;; Packaged for R7RS as (scheme list) by Peter Lane, 2017 10 | 11 | (define-library (srfi 1) 12 | (export 13 | xcons list-tabulate cons* 14 | proper-list? circular-list? dotted-list? not-pair? null-list? list= 15 | circular-list length+ 16 | iota 17 | first second third fourth fifth sixth seventh eighth ninth tenth 18 | car+cdr 19 | take drop 20 | take-right drop-right 21 | take! drop-right! 22 | split-at split-at! 23 | last last-pair 24 | zip unzip1 unzip2 unzip3 unzip4 unzip5 25 | count 26 | append! append-reverse append-reverse! concatenate concatenate! 27 | unfold fold pair-fold reduce 28 | unfold-right fold-right pair-fold-right reduce-right 29 | append-map append-map! map! pair-for-each filter-map map-in-order 30 | filter partition remove 31 | filter! partition! remove! 32 | find find-tail any every list-index 33 | take-while drop-while take-while! 34 | span break span! break! 35 | delete delete! 36 | alist-cons alist-copy 37 | delete-duplicates delete-duplicates! 38 | alist-delete alist-delete! 39 | reverse! 40 | lset<= lset= lset-adjoin 41 | lset-union lset-intersection lset-difference lset-xor lset-diff+intersection 42 | lset-union! lset-intersection! lset-difference! lset-xor! lset-diff+intersection! 43 | ) 44 | (import (scheme base) 45 | (scheme case-lambda) 46 | (scheme cxr)) 47 | 48 | (begin 49 | 50 | ;;; This is a library of list- and pair-processing functions. I wrote it after 51 | ;;; carefully considering the functions provided by the libraries found in 52 | ;;; R4RS/R5RS Scheme, MIT Scheme, Gambit, RScheme, MzScheme, slib, Common 53 | ;;; Lisp, Bigloo, guile, T, APL and the SML standard basis. It is a pretty 54 | ;;; rich toolkit, providing a superset of the functionality found in any of 55 | ;;; the various Schemes I considered. 56 | 57 | ;;; This implementation is intended as a portable reference implementation 58 | ;;; for SRFI-1. See the porting notes below for more information. 59 | ;;; A note on recursion and iteration/reversal: 60 | ;;; Many iterative list-processing algorithms naturally compute the elements 61 | ;;; of the answer list in the wrong order (left-to-right or head-to-tail) from 62 | ;;; the order needed to cons them into the proper answer (right-to-left, or 63 | ;;; tail-then-head). One style or idiom of programming these algorithms, then, 64 | ;;; loops, consing up the elements in reverse order, then destructively 65 | ;;; reverses the list at the end of the loop. I do not do this. The natural 66 | ;;; and efficient way to code these algorithms is recursively. This trades off 67 | ;;; intermediate temporary list structure for intermediate temporary stack 68 | ;;; structure. In a stack-based system, this improves cache locality and 69 | ;;; lightens the load on the GC system. Don't stand on your head to iterate! 70 | ;;; Recurse, where natural. Multiple-value returns make this even more 71 | ;;; convenient, when the recursion/iteration has multiple state values. 72 | 73 | ;;; Porting: 74 | ;;; This is carefully tuned code; do not modify casually. 75 | ;;; - It is careful to share storage when possible; 76 | ;;; - Side-effecting code tries not to perform redundant writes. 77 | ;;; 78 | ;;; That said, a port of this library to a specific Scheme system might wish 79 | ;;; to tune this code to exploit particulars of the implementation. 80 | ;;; The single most important compiler-specific optimisation you could make 81 | ;;; to this library would be to add rewrite rules or transforms to: 82 | ;;; - transform applications of n-ary procedures (e.g. LIST=, CONS*, APPEND, 83 | ;;; LSET-UNION) into multiple applications of a primitive two-argument 84 | ;;; variant. 85 | ;;; - transform applications of the mapping functions (MAP, FOR-EACH, FOLD, 86 | ;;; ANY, EVERY) into open-coded loops. The killer here is that these 87 | ;;; functions are n-ary. Handling the general case is quite inefficient, 88 | ;;; requiring many intermediate data structures to be allocated and 89 | ;;; discarded. 90 | ;;; - transform applications of procedures that take optional arguments 91 | ;;; into calls to variants that do not take optional arguments. This 92 | ;;; eliminates unnecessary consing and parsing of the rest parameter. 93 | ;;; 94 | ;;; These transforms would provide BIG speedups. In particular, the n-ary 95 | ;;; mapping functions are particularly slow and cons-intensive, and are good 96 | ;;; candidates for tuning. I have coded fast paths for the single-list cases, 97 | ;;; but what you really want to do is exploit the fact that the compiler 98 | ;;; usually knows how many arguments are being passed to a particular 99 | ;;; application of these functions -- they are usually explicitly called, not 100 | ;;; passed around as higher-order values. If you can arrange to have your 101 | ;;; compiler produce custom code or custom linkages based on the number of 102 | ;;; arguments in the call, you can speed these functions up a *lot*. But this 103 | ;;; kind of compiler technology no longer exists in the Scheme world as far as 104 | ;;; I can see. 105 | ;;; 106 | ;;; Note that this code is, of course, dependent upon standard bindings for 107 | ;;; the R5RS procedures -- i.e., it assumes that the variable CAR is bound 108 | ;;; to the procedure that takes the car of a list. If your Scheme 109 | ;;; implementation allows user code to alter the bindings of these procedures 110 | ;;; in a manner that would be visible to these definitions, then there might 111 | ;;; be trouble. You could consider horrible kludgery along the lines of 112 | ;;; (define fact 113 | ;;; (let ((= =) (- -) (* *)) 114 | ;;; (letrec ((real-fact (lambda (n) 115 | ;;; (if (= n 0) 1 (* n (real-fact (- n 1))))))) 116 | ;;; real-fact))) 117 | ;;; Or you could consider shifting to a reasonable Scheme system that, say, 118 | ;;; has a module system protecting code from this kind of lossage. 119 | ;;; 120 | ;;; This code does a fair amount of run-time argument checking. If your 121 | ;;; Scheme system has a sophisticated compiler that can eliminate redundant 122 | ;;; error checks, this is no problem. However, if not, these checks incur 123 | ;;; some performance overhead -- and, in a safe Scheme implementation, they 124 | ;;; are in some sense redundant: if we don't check to see that the PROC 125 | ;;; parameter is a procedure, we'll find out anyway three lines later when 126 | ;;; we try to call the value. It's pretty easy to rip all this argument 127 | ;;; checking code out if it's inappropriate for your implementation -- just 128 | ;;; nuke every call to CHECK-ARG. 129 | ;;; 130 | ;;; On the other hand, if you *do* have a sophisticated compiler that will 131 | ;;; actually perform soft-typing and eliminate redundant checks (Rice's systems 132 | ;;; being the only possible candidate of which I'm aware), leaving these checks 133 | ;;; in can *help*, since their presence can be elided in redundant cases, 134 | ;;; and in cases where they are needed, performing the checks early, at 135 | ;;; procedure entry, can "lift" a check out of a loop. 136 | ;;; 137 | ;;; Finally, I have only checked the properties that can portably be checked 138 | ;;; with R5RS Scheme -- and this is not complete. You may wish to alter 139 | ;;; the CHECK-ARG parameter checks to perform extra, implementation-specific 140 | ;;; checks, such as procedure arity for higher-order values. 141 | ;;; 142 | ;;; The code has only these non-R4RS dependencies: 143 | ;;; A few calls to an ERROR procedure; 144 | ;;; Uses of the R5RS multiple-value procedure VALUES and the m-v binding 145 | ;;; RECEIVE macro (which isn't R5RS, but is a trivial macro). 146 | ;;; Many calls to a parameter-checking procedure check-arg: 147 | ;;; (define (check-arg pred val caller) 148 | ;;; (let lp ((val val)) 149 | ;;; (if (pred val) val (lp (error "Bad argument" val pred caller))))) 150 | ;;; A few uses of the LET-OPTIONAL and :OPTIONAL macros for parsing 151 | ;;; optional arguments. 152 | ;;; 153 | ;;; Most of these procedures use the NULL-LIST? test to trigger the 154 | ;;; base case in the inner loop or recursion. The NULL-LIST? function 155 | ;;; is defined to be a careful one -- it raises an error if passed a 156 | ;;; non-nil, non-pair value. The spec allows an implementation to use 157 | ;;; a less-careful implementation that simply defines NULL-LIST? to 158 | ;;; be NOT-PAIR?. This would speed up the inner loops of these procedures 159 | ;;; at the expense of having them silently accept dotted lists. 160 | 161 | ;;; A note on dotted lists: 162 | ;;; I, personally, take the view that the only consistent view of lists 163 | ;;; in Scheme is the view that *everything* is a list -- values such as 164 | ;;; 3 or "foo" or 'bar are simply empty dotted lists. This is due to the 165 | ;;; fact that Scheme actually has no true list type. It has a pair type, 166 | ;;; and there is an *interpretation* of the trees built using this type 167 | ;;; as lists. 168 | ;;; 169 | ;;; I lobbied to have these list-processing procedures hew to this 170 | ;;; view, and accept any value as a list argument. I was overwhelmingly 171 | ;;; overruled during the SRFI discussion phase. So I am inserting this 172 | ;;; text in the reference lib and the SRFI spec as a sort of "minority 173 | ;;; opinion" dissent. 174 | ;;; 175 | ;;; Many of the procedures in this library can be trivially redefined 176 | ;;; to handle dotted lists, just by changing the NULL-LIST? base-case 177 | ;;; check to NOT-PAIR?, meaning that any non-pair value is taken to be 178 | ;;; an empty list. For most of these procedures, that's all that is 179 | ;;; required. 180 | ;;; 181 | ;;; However, we have to do a little more work for some procedures that 182 | ;;; *produce* lists from other lists. Were we to extend these procedures to 183 | ;;; accept dotted lists, we would have to define how they terminate the lists 184 | ;;; produced as results when passed a dotted list. I designed a coherent set 185 | ;;; of termination rules for these cases; this was posted to the SRFI-1 186 | ;;; discussion list. I additionally wrote an earlier version of this library 187 | ;;; that implemented that spec. It has been discarded during later phases of 188 | ;;; the definition and implementation of this library. 189 | ;;; 190 | ;;; The argument *against* defining these procedures to work on dotted 191 | ;;; lists is that dotted lists are the rare, odd case, and that by 192 | ;;; arranging for the procedures to handle them, we lose error checking 193 | ;;; in the cases where a dotted list is passed by accident -- e.g., when 194 | ;;; the programmer swaps a two arguments to a list-processing function, 195 | ;;; one being a scalar and one being a list. For example, 196 | ;;; (member '(1 3 5 7 9) 7) 197 | ;;; This would quietly return #f if we extended MEMBER to accept dotted 198 | ;;; lists. 199 | ;;; 200 | ;;; The SRFI discussion record contains more discussion on this topic. 201 | 202 | (define (check-arg pred val caller) 203 | (let lp ((val val)) 204 | (if (pred val) val (error "Bad argument" val pred caller)))) 205 | 206 | (define-syntax receive ; from SRFI-8 (c) John David Stone, 1999 207 | (syntax-rules () 208 | ((receive formals expression body ...) 209 | (call-with-values (lambda () expression) 210 | (lambda formals body ...))))) 211 | 212 | ;; simple handling of optional argument 213 | (define (:optional lis default) 214 | (if (null? lis) 215 | default 216 | (car lis))) 217 | 218 | 219 | ;;; Constructors 220 | ;;;;;;;;;;;;;;;; 221 | 222 | ;;; Occasionally useful as a value to be passed to a fold or other 223 | ;;; higher-order procedure. 224 | (define (xcons d a) (cons a d)) 225 | 226 | ;;;; Recursively copy every cons. 227 | ;(define (tree-copy x) 228 | ; (let recur ((x x)) 229 | ; (if (not (pair? x)) x 230 | ; (cons (recur (car x)) (recur (cdr x)))))) 231 | 232 | ;(define (list . ans) ans) ; R4RS 233 | 234 | ;;; Make a list of length LEN. Elt i is (PROC i) for 0 <= i < LEN. 235 | 236 | (define (list-tabulate len proc) 237 | (check-arg (lambda (n) (and (integer? n) (>= n 0))) len list-tabulate) 238 | (check-arg procedure? proc list-tabulate) 239 | (do ((i (- len 1) (- i 1)) 240 | (ans '() (cons (proc i) ans))) 241 | ((< i 0) ans))) 242 | 243 | ;;; (cons* a1 a2 ... an) = (cons a1 (cons a2 (cons ... an))) 244 | ;;; (cons* a1) = a1 (cons* a1 a2 ...) = (cons a1 (cons* a2 ...)) 245 | ;;; 246 | ;;; (cons first (unfold not-pair? car cdr rest values)) 247 | 248 | (define (cons* first . rest) 249 | (let recur ((x first) (rest rest)) 250 | (if (pair? rest) 251 | (cons x (recur (car rest) (cdr rest))) 252 | x))) 253 | 254 | ;;; (unfold not-pair? car cdr lis values) 255 | 256 | ;;; IOTA count [start step] (start start+step ... start+(count-1)*step) 257 | 258 | (define iota 259 | (case-lambda 260 | ((count) 261 | (iota count 0 1)) 262 | ((count start) 263 | (iota count start 1)) 264 | ((count start step) 265 | (check-arg integer? count iota) 266 | (if (< count 0) (error "Negative step count" iota count)) 267 | (check-arg number? start iota) 268 | (check-arg number? step iota) 269 | (let loop ((n 0) (r '())) 270 | (if (= n count) 271 | (reverse r) 272 | (loop (+ 1 n) 273 | (cons (+ start (* n step)) r))))))) 274 | 275 | ;;; I thought these were lovely, but the public at large did not share my 276 | ;;; enthusiasm... 277 | ;;; :IOTA to (0 ... to-1) 278 | ;;; :IOTA from to (from ... to-1) 279 | ;;; :IOTA from to step (from from+step ...) 280 | 281 | ;;; IOTA: to (1 ... to) 282 | ;;; IOTA: from to (from+1 ... to) 283 | ;;; IOTA: from to step (from+step from+2step ...) 284 | 285 | ;(define (%parse-iota-args arg1 rest-args proc) 286 | ; (let ((check (lambda (n) (check-arg integer? n proc)))) 287 | ; (check arg1) 288 | ; (if (pair? rest-args) 289 | ; (let ((arg2 (check (car rest-args))) 290 | ; (rest (cdr rest-args))) 291 | ; (if (pair? rest) 292 | ; (let ((arg3 (check (car rest))) 293 | ; (rest (cdr rest))) 294 | ; (if (pair? rest) (error "Too many parameters" proc arg1 rest-args) 295 | ; (values arg1 arg2 arg3))) 296 | ; (values arg1 arg2 1))) 297 | ; (values 0 arg1 1)))) 298 | ; 299 | ;(define (iota: arg1 . rest-args) 300 | ; (receive (from to step) (%parse-iota-args arg1 rest-args iota:) 301 | ; (let* ((numsteps (floor (/ (- to from) step))) 302 | ; (last-val (+ from (* step numsteps)))) 303 | ; (if (< numsteps 0) (error "Negative step count" iota: from to step)) 304 | ; (do ((steps-left numsteps (- steps-left 1)) 305 | ; (val last-val (- val step)) 306 | ; (ans '() (cons val ans))) 307 | ; ((<= steps-left 0) ans))))) 308 | ; 309 | ; 310 | ;(define (:iota arg1 . rest-args) 311 | ; (receive (from to step) (%parse-iota-args arg1 rest-args :iota) 312 | ; (let* ((numsteps (ceiling (/ (- to from) step))) 313 | ; (last-val (+ from (* step (- numsteps 1))))) 314 | ; (if (< numsteps 0) (error "Negative step count" :iota from to step)) 315 | ; (do ((steps-left numsteps (- steps-left 1)) 316 | ; (val last-val (- val step)) 317 | ; (ans '() (cons val ans))) 318 | ; ((<= steps-left 0) ans))))) 319 | 320 | 321 | 322 | (define (circular-list val1 . vals) 323 | (let ((ans (cons val1 vals))) 324 | (set-cdr! (last-pair ans) ans) 325 | ans)) 326 | 327 | ;;; ::= () ; Empty proper list 328 | ;;; | (cons ) ; Proper-list pair 329 | ;;; Note that this definition rules out circular lists -- and this 330 | ;;; function is required to detect this case and return false. 331 | 332 | (define (proper-list? x) 333 | (let lp ((x x) (lag x)) 334 | (if (pair? x) 335 | (let ((x (cdr x))) 336 | (if (pair? x) 337 | (let ((x (cdr x)) 338 | (lag (cdr lag))) 339 | (and (not (eq? x lag)) (lp x lag))) 340 | (null? x))) 341 | (null? x)))) 342 | 343 | 344 | ;;; A dotted list is a finite list (possibly of length 0) terminated 345 | ;;; by a non-nil value. Any non-cons, non-nil value (e.g., "foo" or 5) 346 | ;;; is a dotted list of length 0. 347 | ;;; 348 | ;;; ::= ; Empty dotted list 349 | ;;; | (cons ) ; Proper-list pair 350 | 351 | (define (dotted-list? x) 352 | (let lp ((x x) (lag x)) 353 | (if (pair? x) 354 | (let ((x (cdr x))) 355 | (if (pair? x) 356 | (let ((x (cdr x)) 357 | (lag (cdr lag))) 358 | (and (not (eq? x lag)) (lp x lag))) 359 | (not (null? x)))) 360 | (not (null? x))))) 361 | 362 | (define (circular-list? x) 363 | (let lp ((x x) (lag x)) 364 | (and (pair? x) 365 | (let ((x (cdr x))) 366 | (and (pair? x) 367 | (let ((x (cdr x)) 368 | (lag (cdr lag))) 369 | (or (eq? x lag) (lp x lag)))))))) 370 | 371 | (define (not-pair? x) (not (pair? x))) ; Inline me. 372 | 373 | ;;; This is a legal definition which is fast and sloppy: 374 | ;;; (define null-list? not-pair?) 375 | ;;; but we'll provide a more careful one: 376 | (define (null-list? l) 377 | (cond ((pair? l) #f) 378 | ((null? l) #t) 379 | (else (error "null-list?: argument out of domain" l)))) 380 | 381 | 382 | (define (list= = . lists) 383 | (or (null? lists) ; special case 384 | (let lp1 ((list-a (car lists)) (others (cdr lists))) 385 | (or (null? others) 386 | (let ((list-b-orig (car others)) 387 | (others (cdr others))) 388 | (if (eq? list-a list-b-orig) ; EQ? => LIST= 389 | (lp1 list-b-orig others) 390 | (let lp2 ((list-a list-a) (list-b list-b-orig)) 391 | (if (null-list? list-a) 392 | (and (null-list? list-b) 393 | (lp1 list-b-orig others)) 394 | (and (not (null-list? list-b)) 395 | (= (car list-a) (car list-b)) 396 | (lp2 (cdr list-a) (cdr list-b))))))))))) 397 | 398 | 399 | 400 | ;;; R4RS, so commented out. 401 | ;(define (length x) ; LENGTH may diverge or 402 | ; (let lp ((x x) (len 0)) ; raise an error if X is 403 | ; (if (pair? x) ; a circular list. This version 404 | ; (lp (cdr x) (+ len 1)) ; diverges. 405 | ; len))) 406 | 407 | (define (length+ x) ; Returns #f if X is circular. 408 | (let lp ((x x) (lag x) (len 0)) 409 | (if (pair? x) 410 | (let ((x (cdr x)) 411 | (len (+ len 1))) 412 | (if (pair? x) 413 | (let ((x (cdr x)) 414 | (lag (cdr lag)) 415 | (len (+ len 1))) 416 | (and (not (eq? x lag)) (lp x lag len))) 417 | len)) 418 | len))) 419 | 420 | (define (zip list1 . more-lists) (apply map list list1 more-lists)) 421 | 422 | 423 | ;;; Selectors 424 | ;;;;;;;;;;;;; 425 | 426 | ;;; R4RS non-primitives: 427 | ;(define (caar x) (car (car x))) 428 | ;(define (cadr x) (car (cdr x))) 429 | ;(define (cdar x) (cdr (car x))) 430 | ;(define (cddr x) (cdr (cdr x))) 431 | ; 432 | ;(define (caaar x) (caar (car x))) 433 | ;(define (caadr x) (caar (cdr x))) 434 | ;(define (cadar x) (cadr (car x))) 435 | ;(define (caddr x) (cadr (cdr x))) 436 | ;(define (cdaar x) (cdar (car x))) 437 | ;(define (cdadr x) (cdar (cdr x))) 438 | ;(define (cddar x) (cddr (car x))) 439 | ;(define (cdddr x) (cddr (cdr x))) 440 | ; 441 | ;(define (caaaar x) (caaar (car x))) 442 | ;(define (caaadr x) (caaar (cdr x))) 443 | ;(define (caadar x) (caadr (car x))) 444 | ;(define (caaddr x) (caadr (cdr x))) 445 | ;(define (cadaar x) (cadar (car x))) 446 | ;(define (cadadr x) (cadar (cdr x))) 447 | ;(define (caddar x) (caddr (car x))) 448 | ;(define (cadddr x) (caddr (cdr x))) 449 | ;(define (cdaaar x) (cdaar (car x))) 450 | ;(define (cdaadr x) (cdaar (cdr x))) 451 | ;(define (cdadar x) (cdadr (car x))) 452 | ;(define (cdaddr x) (cdadr (cdr x))) 453 | ;(define (cddaar x) (cddar (car x))) 454 | ;(define (cddadr x) (cddar (cdr x))) 455 | ;(define (cdddar x) (cdddr (car x))) 456 | ;(define (cddddr x) (cdddr (cdr x))) 457 | 458 | 459 | (define first car) 460 | (define second cadr) 461 | (define third caddr) 462 | (define fourth cadddr) 463 | (define (fifth x) (car (cddddr x))) 464 | (define (sixth x) (cadr (cddddr x))) 465 | (define (seventh x) (caddr (cddddr x))) 466 | (define (eighth x) (cadddr (cddddr x))) 467 | (define (ninth x) (car (cddddr (cddddr x)))) 468 | (define (tenth x) (cadr (cddddr (cddddr x)))) 469 | 470 | (define (car+cdr pair) (values (car pair) (cdr pair))) 471 | 472 | ;;; take & drop 473 | 474 | (define (take lis k) 475 | (check-arg integer? k take) 476 | (let recur ((lis lis) (k k)) 477 | (if (zero? k) '() 478 | (cons (car lis) 479 | (recur (cdr lis) (- k 1)))))) 480 | 481 | (define (drop lis k) 482 | (check-arg integer? k drop) 483 | (let iter ((lis lis) (k k)) 484 | (if (zero? k) lis (iter (cdr lis) (- k 1))))) 485 | 486 | (define (take! lis k) 487 | (check-arg integer? k take!) 488 | (if (zero? k) '() 489 | (begin (set-cdr! (drop lis (- k 1)) '()) 490 | lis))) 491 | 492 | ;;; TAKE-RIGHT and DROP-RIGHT work by getting two pointers into the list, 493 | ;;; off by K, then chasing down the list until the lead pointer falls off 494 | ;;; the end. 495 | 496 | (define (take-right lis k) 497 | (check-arg integer? k take-right) 498 | (let lp ((lag lis) (lead (drop lis k))) 499 | (if (pair? lead) 500 | (lp (cdr lag) (cdr lead)) 501 | lag))) 502 | 503 | (define (drop-right lis k) 504 | (check-arg integer? k drop-right) 505 | (let recur ((lag lis) (lead (drop lis k))) 506 | (if (pair? lead) 507 | (cons (car lag) (recur (cdr lag) (cdr lead))) 508 | '()))) 509 | 510 | ;;; In this function, LEAD is actually K+1 ahead of LAG. This lets 511 | ;;; us stop LAG one step early, in time to smash its cdr to (). 512 | (define (drop-right! lis k) 513 | (check-arg integer? k drop-right!) 514 | (let ((lead (drop lis k))) 515 | (if (pair? lead) 516 | 517 | (let lp ((lag lis) (lead (cdr lead))) ; Standard case 518 | (if (pair? lead) 519 | (lp (cdr lag) (cdr lead)) 520 | (begin (set-cdr! lag '()) 521 | lis))) 522 | 523 | '()))) ; Special case dropping everything -- no cons to side-effect. 524 | 525 | ;(define (list-ref lis i) (car (drop lis i))) ; R4RS 526 | 527 | ;;; These use the APL convention, whereby negative indices mean 528 | ;;; "from the right." I liked them, but they didn't win over the 529 | ;;; SRFI reviewers. 530 | ;;; K >= 0: Take and drop K elts from the front of the list. 531 | ;;; K <= 0: Take and drop -K elts from the end of the list. 532 | 533 | ;(define (take lis k) 534 | ; (check-arg integer? k take) 535 | ; (if (negative? k) 536 | ; (list-tail lis (+ k (length lis))) 537 | ; (let recur ((lis lis) (k k)) 538 | ; (if (zero? k) '() 539 | ; (cons (car lis) 540 | ; (recur (cdr lis) (- k 1))))))) 541 | ; 542 | ;(define (drop lis k) 543 | ; (check-arg integer? k drop) 544 | ; (if (negative? k) 545 | ; (let recur ((lis lis) (nelts (+ k (length lis)))) 546 | ; (if (zero? nelts) '() 547 | ; (cons (car lis) 548 | ; (recur (cdr lis) (- nelts 1))))) 549 | ; (list-tail lis k))) 550 | ; 551 | ; 552 | ;(define (take! lis k) 553 | ; (check-arg integer? k take!) 554 | ; (cond ((zero? k) '()) 555 | ; ((positive? k) 556 | ; (set-cdr! (list-tail lis (- k 1)) '()) 557 | ; lis) 558 | ; (else (list-tail lis (+ k (length lis)))))) 559 | ; 560 | ;(define (drop! lis k) 561 | ; (check-arg integer? k drop!) 562 | ; (if (negative? k) 563 | ; (let ((nelts (+ k (length lis)))) 564 | ; (if (zero? nelts) '() 565 | ; (begin (set-cdr! (list-tail lis (- nelts 1)) '()) 566 | ; lis))) 567 | ; (list-tail lis k))) 568 | 569 | (define (split-at x k) 570 | (check-arg integer? k split-at) 571 | (let recur ((lis x) (k k)) 572 | (if (zero? k) (values '() lis) 573 | (receive (prefix suffix) (recur (cdr lis) (- k 1)) 574 | (values (cons (car lis) prefix) suffix))))) 575 | 576 | (define (split-at! x k) 577 | (check-arg integer? k split-at!) 578 | (if (zero? k) (values '() x) 579 | (let* ((prev (drop x (- k 1))) 580 | (suffix (cdr prev))) 581 | (set-cdr! prev '()) 582 | (values x suffix)))) 583 | 584 | 585 | (define (last lis) (car (last-pair lis))) 586 | 587 | (define (last-pair lis) 588 | (check-arg pair? lis last-pair) 589 | (let lp ((lis lis)) 590 | (let ((tail (cdr lis))) 591 | (if (pair? tail) (lp tail) lis)))) 592 | 593 | 594 | ;;; Unzippers -- 1 through 5 595 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 596 | 597 | (define (unzip1 lis) (map car lis)) 598 | 599 | (define (unzip2 lis) 600 | (let recur ((lis lis)) 601 | (if (null-list? lis) (values lis lis) ; Use NOT-PAIR? to handle 602 | (let ((elt (car lis))) ; dotted lists. 603 | (receive (a b) (recur (cdr lis)) 604 | (values (cons (car elt) a) 605 | (cons (cadr elt) b))))))) 606 | 607 | (define (unzip3 lis) 608 | (let recur ((lis lis)) 609 | (if (null-list? lis) (values lis lis lis) 610 | (let ((elt (car lis))) 611 | (receive (a b c) (recur (cdr lis)) 612 | (values (cons (car elt) a) 613 | (cons (cadr elt) b) 614 | (cons (caddr elt) c))))))) 615 | 616 | (define (unzip4 lis) 617 | (let recur ((lis lis)) 618 | (if (null-list? lis) (values lis lis lis lis) 619 | (let ((elt (car lis))) 620 | (receive (a b c d) (recur (cdr lis)) 621 | (values (cons (car elt) a) 622 | (cons (cadr elt) b) 623 | (cons (caddr elt) c) 624 | (cons (cadddr elt) d))))))) 625 | 626 | (define (unzip5 lis) 627 | (let recur ((lis lis)) 628 | (if (null-list? lis) (values lis lis lis lis lis) 629 | (let ((elt (car lis))) 630 | (receive (a b c d e) (recur (cdr lis)) 631 | (values (cons (car elt) a) 632 | (cons (cadr elt) b) 633 | (cons (caddr elt) c) 634 | (cons (cadddr elt) d) 635 | (cons (car (cddddr elt)) e))))))) 636 | 637 | 638 | ;;; append! append-reverse append-reverse! concatenate concatenate! 639 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 640 | 641 | (define (append! . lists) 642 | ;; First, scan through lists looking for a non-empty one. 643 | (let lp ((lists lists) (prev '())) 644 | (if (not (pair? lists)) prev 645 | (let ((first (car lists)) 646 | (rest (cdr lists))) 647 | (if (not (pair? first)) (lp rest first) 648 | 649 | ;; Now, do the splicing. 650 | (let lp2 ((tail-cons (last-pair first)) 651 | (rest rest)) 652 | (if (pair? rest) 653 | (let ((next (car rest)) 654 | (rest (cdr rest))) 655 | (set-cdr! tail-cons next) 656 | (lp2 (if (pair? next) (last-pair next) tail-cons) 657 | rest)) 658 | first))))))) 659 | 660 | ;;; APPEND is R4RS. 661 | ;(define (append . lists) 662 | ; (if (pair? lists) 663 | ; (let recur ((list1 (car lists)) (lists (cdr lists))) 664 | ; (if (pair? lists) 665 | ; (let ((tail (recur (car lists) (cdr lists)))) 666 | ; (fold-right cons tail list1)) ; Append LIST1 & TAIL. 667 | ; list1)) 668 | ; '())) 669 | 670 | ;(define (append-reverse rev-head tail) (fold cons tail rev-head)) 671 | 672 | ;(define (append-reverse! rev-head tail) 673 | ; (pair-fold (lambda (pair tail) (set-cdr! pair tail) pair) 674 | ; tail 675 | ; rev-head)) 676 | 677 | ;;; Hand-inline the FOLD and PAIR-FOLD ops for speed. 678 | 679 | (define (append-reverse rev-head tail) 680 | (let lp ((rev-head rev-head) (tail tail)) 681 | (if (null-list? rev-head) tail 682 | (lp (cdr rev-head) (cons (car rev-head) tail))))) 683 | 684 | (define (append-reverse! rev-head tail) 685 | (let lp ((rev-head rev-head) (tail tail)) 686 | (if (null-list? rev-head) tail 687 | (let ((next-rev (cdr rev-head))) 688 | (set-cdr! rev-head tail) 689 | (lp next-rev rev-head))))) 690 | 691 | 692 | (define (concatenate lists) (reduce-right append '() lists)) 693 | (define (concatenate! lists) (reduce-right append! '() lists)) 694 | 695 | ;;; Fold/map internal utilities 696 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 697 | ;;; These little internal utilities are used by the general 698 | ;;; fold & mapper funs for the n-ary cases . It'd be nice if they got inlined. 699 | ;;; One the other hand, the n-ary cases are painfully inefficient as it is. 700 | ;;; An aggressive implementation should simply re-write these functions 701 | ;;; for raw efficiency; I have written them for as much clarity, portability, 702 | ;;; and simplicity as can be achieved. 703 | ;;; 704 | ;;; I use the dreaded call/cc to do local aborts. A good compiler could 705 | ;;; handle this with extreme efficiency. An implementation that provides 706 | ;;; a one-shot, non-persistent continuation grabber could help the compiler 707 | ;;; out by using that in place of the call/cc's in these routines. 708 | ;;; 709 | ;;; These functions have funky definitions that are precisely tuned to 710 | ;;; the needs of the fold/map procs -- for example, to minimize the number 711 | ;;; of times the argument lists need to be examined. 712 | 713 | ;;; Return (map cdr lists). 714 | ;;; However, if any element of LISTS is empty, just abort and return '(). 715 | (define (%cdrs lists) 716 | (call-with-current-continuation 717 | (lambda (abort) 718 | (let recur ((lists lists)) 719 | (if (pair? lists) 720 | (let ((lis (car lists))) 721 | (if (null-list? lis) (abort '()) 722 | (cons (cdr lis) (recur (cdr lists))))) 723 | '()))))) 724 | 725 | (define (%cars+ lists last-elt) ; (append! (map car lists) (list last-elt)) 726 | (let recur ((lists lists)) 727 | (if (pair? lists) (cons (caar lists) (recur (cdr lists))) (list last-elt)))) 728 | 729 | ;;; LISTS is a (not very long) non-empty list of lists. 730 | ;;; Return two lists: the cars & the cdrs of the lists. 731 | ;;; However, if any of the lists is empty, just abort and return [() ()]. 732 | 733 | (define (%cars+cdrs lists) 734 | (call-with-current-continuation 735 | (lambda (abort) 736 | (let recur ((lists lists)) 737 | (if (pair? lists) 738 | (receive (list other-lists) (car+cdr lists) 739 | (if (null-list? list) (abort '() '()) ; LIST is empty -- bail out 740 | (receive (a d) (car+cdr list) 741 | (receive (cars cdrs) (recur other-lists) 742 | (values (cons a cars) (cons d cdrs)))))) 743 | (values '() '())))))) 744 | 745 | ;;; Like %CARS+CDRS, but we pass in a final elt tacked onto the end of the 746 | ;;; cars list. What a hack. 747 | (define (%cars+cdrs+ lists cars-final) 748 | (call-with-current-continuation 749 | (lambda (abort) 750 | (let recur ((lists lists)) 751 | (if (pair? lists) 752 | (receive (list other-lists) (car+cdr lists) 753 | (if (null-list? list) (abort '() '()) ; LIST is empty -- bail out 754 | (receive (a d) (car+cdr list) 755 | (receive (cars cdrs) (recur other-lists) 756 | (values (cons a cars) (cons d cdrs)))))) 757 | (values (list cars-final) '())))))) 758 | 759 | ;;; Like %CARS+CDRS, but blow up if any list is empty. 760 | (define (%cars+cdrs/no-test lists) 761 | (let recur ((lists lists)) 762 | (if (pair? lists) 763 | (receive (list other-lists) (car+cdr lists) 764 | (receive (a d) (car+cdr list) 765 | (receive (cars cdrs) (recur other-lists) 766 | (values (cons a cars) (cons d cdrs))))) 767 | (values '() '())))) 768 | 769 | 770 | ;;; count 771 | ;;;;;;;;; 772 | (define (count pred list1 . lists) 773 | (check-arg procedure? pred count) 774 | (if (pair? lists) 775 | 776 | ;; N-ary case 777 | (let lp ((list1 list1) (lists lists) (i 0)) 778 | (if (null-list? list1) i 779 | (receive (as ds) (%cars+cdrs lists) 780 | (if (null? as) i 781 | (lp (cdr list1) ds 782 | (if (apply pred (car list1) as) (+ i 1) i)))))) 783 | 784 | ;; Fast path 785 | (let lp ((lis list1) (i 0)) 786 | (if (null-list? lis) i 787 | (lp (cdr lis) (if (pred (car lis)) (+ i 1) i)))))) 788 | 789 | ;;; fold/unfold 790 | ;;;;;;;;;;;;;;; 791 | 792 | (define (unfold-right p f g seed . maybe-tail) 793 | (check-arg procedure? p unfold-right) 794 | (check-arg procedure? f unfold-right) 795 | (check-arg procedure? g unfold-right) 796 | (let lp ((seed seed) (ans (:optional maybe-tail '()))) 797 | (if (p seed) ans 798 | (lp (g seed) 799 | (cons (f seed) ans))))) 800 | 801 | 802 | (define (unfold p f g seed . maybe-tail-gen) 803 | (check-arg procedure? p unfold) 804 | (check-arg procedure? f unfold) 805 | (check-arg procedure? g unfold) 806 | (if (pair? maybe-tail-gen) 807 | 808 | (let ((tail-gen (car maybe-tail-gen))) 809 | (if (pair? (cdr maybe-tail-gen)) 810 | (apply error "Too many arguments" unfold p f g seed maybe-tail-gen) 811 | 812 | (let recur ((seed seed)) 813 | (if (p seed) (tail-gen seed) 814 | (cons (f seed) (recur (g seed))))))) 815 | 816 | (let recur ((seed seed)) 817 | (if (p seed) '() 818 | (cons (f seed) (recur (g seed))))))) 819 | 820 | 821 | (define (fold kons knil lis1 . lists) 822 | (check-arg procedure? kons fold) 823 | (if (pair? lists) 824 | (let lp ((lists (cons lis1 lists)) (ans knil)) ; N-ary case 825 | (receive (cars+ans cdrs) (%cars+cdrs+ lists ans) 826 | (if (null? cars+ans) ans ; Done. 827 | (lp cdrs (apply kons cars+ans))))) 828 | 829 | (let lp ((lis lis1) (ans knil)) ; Fast path 830 | (if (null-list? lis) ans 831 | (lp (cdr lis) (kons (car lis) ans)))))) 832 | 833 | 834 | (define (fold-right kons knil lis1 . lists) 835 | (check-arg procedure? kons fold-right) 836 | (if (pair? lists) 837 | (let recur ((lists (cons lis1 lists))) ; N-ary case 838 | (let ((cdrs (%cdrs lists))) 839 | (if (null? cdrs) knil 840 | (apply kons (%cars+ lists (recur cdrs)))))) 841 | 842 | (let recur ((lis lis1)) ; Fast path 843 | (if (null-list? lis) knil 844 | (let ((head (car lis))) 845 | (kons head (recur (cdr lis)))))))) 846 | 847 | 848 | (define (pair-fold-right f zero lis1 . lists) 849 | (check-arg procedure? f pair-fold-right) 850 | (if (pair? lists) 851 | (let recur ((lists (cons lis1 lists))) ; N-ary case 852 | (let ((cdrs (%cdrs lists))) 853 | (if (null? cdrs) zero 854 | (apply f (append! lists (list (recur cdrs))))))) 855 | 856 | (let recur ((lis lis1)) ; Fast path 857 | (if (null-list? lis) zero (f lis (recur (cdr lis))))))) 858 | 859 | (define (pair-fold f zero lis1 . lists) 860 | (check-arg procedure? f pair-fold) 861 | (if (pair? lists) 862 | (let lp ((lists (cons lis1 lists)) (ans zero)) ; N-ary case 863 | (let ((tails (%cdrs lists))) 864 | (if (null? tails) ans 865 | (lp tails (apply f (append! lists (list ans))))))) 866 | 867 | (let lp ((lis lis1) (ans zero)) 868 | (if (null-list? lis) ans 869 | (let ((tail (cdr lis))) ; Grab the cdr now, 870 | (lp tail (f lis ans))))))) ; in case F SET-CDR!s LIS. 871 | 872 | 873 | ;;; REDUCE and REDUCE-RIGHT only use RIDENTITY in the empty-list case. 874 | ;;; These cannot meaningfully be n-ary. 875 | 876 | (define (reduce f ridentity lis) 877 | (check-arg procedure? f reduce) 878 | (if (null-list? lis) ridentity 879 | (fold f (car lis) (cdr lis)))) 880 | 881 | (define (reduce-right f ridentity lis) 882 | (check-arg procedure? f reduce-right) 883 | (if (null-list? lis) ridentity 884 | (let recur ((head (car lis)) (lis (cdr lis))) 885 | (if (pair? lis) 886 | (f head (recur (car lis) (cdr lis))) 887 | head)))) 888 | 889 | 890 | 891 | ;;; Mappers: append-map append-map! pair-for-each map! filter-map map-in-order 892 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 893 | 894 | (define (append-map f lis1 . lists) 895 | (really-append-map append-map append f lis1 lists)) 896 | (define (append-map! f lis1 . lists) 897 | (really-append-map append-map! append! f lis1 lists)) 898 | 899 | (define (really-append-map who appender f lis1 lists) 900 | (check-arg procedure? f who) 901 | (if (pair? lists) 902 | (receive (cars cdrs) (%cars+cdrs (cons lis1 lists)) 903 | (if (null? cars) '() 904 | (let recur ((cars cars) (cdrs cdrs)) 905 | (let ((vals (apply f cars))) 906 | (receive (cars2 cdrs2) (%cars+cdrs cdrs) 907 | (if (null? cars2) vals 908 | (appender vals (recur cars2 cdrs2)))))))) 909 | 910 | ;; Fast path 911 | (if (null-list? lis1) '() 912 | (let recur ((elt (car lis1)) (rest (cdr lis1))) 913 | (let ((vals (f elt))) 914 | (if (null-list? rest) vals 915 | (appender vals (recur (car rest) (cdr rest))))))))) 916 | 917 | 918 | (define (pair-for-each proc lis1 . lists) 919 | (check-arg procedure? proc pair-for-each) 920 | (if (pair? lists) 921 | 922 | (let lp ((lists (cons lis1 lists))) 923 | (let ((tails (%cdrs lists))) 924 | (if (pair? tails) 925 | (begin (apply proc lists) 926 | (lp tails))))) 927 | 928 | ;; Fast path. 929 | (let lp ((lis lis1)) 930 | (if (not (null-list? lis)) 931 | (let ((tail (cdr lis))) ; Grab the cdr now, 932 | (proc lis) ; in case PROC SET-CDR!s LIS. 933 | (lp tail)))))) 934 | 935 | ;;; We stop when LIS1 runs out, not when any list runs out. 936 | (define (map! f lis1 . lists) 937 | (check-arg procedure? f map!) 938 | (if (pair? lists) 939 | (let lp ((lis1 lis1) (lists lists)) 940 | (if (not (null-list? lis1)) 941 | (receive (heads tails) (%cars+cdrs/no-test lists) 942 | (set-car! lis1 (apply f (car lis1) heads)) 943 | (lp (cdr lis1) tails)))) 944 | 945 | ;; Fast path. 946 | (pair-for-each (lambda (pair) (set-car! pair (f (car pair)))) lis1)) 947 | lis1) 948 | 949 | 950 | ;;; Map F across L, and save up all the non-false results. 951 | (define (filter-map f lis1 . lists) 952 | (check-arg procedure? f filter-map) 953 | (if (pair? lists) 954 | (let recur ((lists (cons lis1 lists))) 955 | (receive (cars cdrs) (%cars+cdrs lists) 956 | (if (pair? cars) 957 | (cond ((apply f cars) => (lambda (x) (cons x (recur cdrs)))) 958 | (else (recur cdrs))) ; Tail call in this arm. 959 | '()))) 960 | 961 | ;; Fast path. 962 | (let recur ((lis lis1)) 963 | (if (null-list? lis) lis 964 | (let ((tail (recur (cdr lis)))) 965 | (cond ((f (car lis)) => (lambda (x) (cons x tail))) 966 | (else tail))))))) 967 | 968 | 969 | ;;; Map F across lists, guaranteeing to go left-to-right. 970 | ;;; NOTE: Some implementations of R5RS MAP are compliant with this spec; 971 | ;;; in which case this procedure may simply be defined as a synonym for MAP. 972 | 973 | (define (map-in-order f lis1 . lists) 974 | (check-arg procedure? f map-in-order) 975 | (if (pair? lists) 976 | (let recur ((lists (cons lis1 lists))) 977 | (receive (cars cdrs) (%cars+cdrs lists) 978 | (if (pair? cars) 979 | (let ((x (apply f cars))) ; Do head first, 980 | (cons x (recur cdrs))) ; then tail. 981 | '()))) 982 | 983 | ;; Fast path. 984 | (let recur ((lis lis1)) 985 | (if (null-list? lis) lis 986 | (let ((tail (cdr lis)) 987 | (x (f (car lis)))) ; Do head first, 988 | (cons x (recur tail))))))) ; then tail. 989 | 990 | 991 | 992 | ;;; filter, remove, partition 993 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 994 | ;;; FILTER, REMOVE, PARTITION and their destructive counterparts do not 995 | ;;; disorder the elements of their argument. 996 | 997 | ;; This FILTER shares the longest tail of L that has no deleted elements. 998 | ;; If Scheme had multi-continuation calls, they could be made more efficient. 999 | 1000 | (define (filter pred lis) ; Sleazing with EQ? makes this 1001 | (check-arg procedure? pred filter) ; one faster. 1002 | (let recur ((lis lis)) 1003 | (if (null-list? lis) lis ; Use NOT-PAIR? to handle dotted lists. 1004 | (let ((head (car lis)) 1005 | (tail (cdr lis))) 1006 | (if (pred head) 1007 | (let ((new-tail (recur tail))) ; Replicate the RECUR call so 1008 | (if (eq? tail new-tail) lis 1009 | (cons head new-tail))) 1010 | (recur tail)))))) ; this one can be a tail call. 1011 | 1012 | 1013 | ;;; Another version that shares longest tail. 1014 | ;(define (filter pred lis) 1015 | ; (receive (ans no-del?) 1016 | ; ;; (recur l) returns L with (pred x) values filtered. 1017 | ; ;; It also returns a flag NO-DEL? if the returned value 1018 | ; ;; is EQ? to L, i.e. if it didn't have to delete anything. 1019 | ; (let recur ((l l)) 1020 | ; (if (null-list? l) (values l #t) 1021 | ; (let ((x (car l)) 1022 | ; (tl (cdr l))) 1023 | ; (if (pred x) 1024 | ; (receive (ans no-del?) (recur tl) 1025 | ; (if no-del? 1026 | ; (values l #t) 1027 | ; (values (cons x ans) #f))) 1028 | ; (receive (ans no-del?) (recur tl) ; Delete X. 1029 | ; (values ans #f)))))) 1030 | ; ans)) 1031 | 1032 | 1033 | 1034 | ;(define (filter! pred lis) ; Things are much simpler 1035 | ; (let recur ((lis lis)) ; if you are willing to 1036 | ; (if (pair? lis) ; push N stack frames & do N 1037 | ; (cond ((pred (car lis)) ; SET-CDR! writes, where N is 1038 | ; (set-cdr! lis (recur (cdr lis))); the length of the answer. 1039 | ; lis) 1040 | ; (else (recur (cdr lis)))) 1041 | ; lis))) 1042 | 1043 | 1044 | ;;; This implementation of FILTER! 1045 | ;;; - doesn't cons, and uses no stack; 1046 | ;;; - is careful not to do redundant SET-CDR! writes, as writes to memory are 1047 | ;;; usually expensive on modern machines, and can be extremely expensive on 1048 | ;;; modern Schemes (e.g., ones that have generational GC's). 1049 | ;;; It just zips down contiguous runs of in and out elts in LIS doing the 1050 | ;;; minimal number of SET-CDR!s to splice the tail of one run of ins to the 1051 | ;;; beginning of the next. 1052 | 1053 | (define (filter! pred lis) 1054 | (check-arg procedure? pred filter!) 1055 | (let lp ((ans lis)) 1056 | (cond ((null-list? ans) ans) ; Scan looking for 1057 | ((not (pred (car ans))) (lp (cdr ans))) ; first cons of result. 1058 | 1059 | ;; ANS is the eventual answer. 1060 | ;; SCAN-IN: (CDR PREV) = LIS and (CAR PREV) satisfies PRED. 1061 | ;; Scan over a contiguous segment of the list that 1062 | ;; satisfies PRED. 1063 | ;; SCAN-OUT: (CAR PREV) satisfies PRED. Scan over a contiguous 1064 | ;; segment of the list that *doesn't* satisfy PRED. 1065 | ;; When the segment ends, patch in a link from PREV 1066 | ;; to the start of the next good segment, and jump to 1067 | ;; SCAN-IN. 1068 | (else (letrec ((scan-in (lambda (prev lis) 1069 | (if (pair? lis) 1070 | (if (pred (car lis)) 1071 | (scan-in lis (cdr lis)) 1072 | (scan-out prev (cdr lis)))))) 1073 | (scan-out (lambda (prev lis) 1074 | (let lp ((lis lis)) 1075 | (if (pair? lis) 1076 | (if (pred (car lis)) 1077 | (begin (set-cdr! prev lis) 1078 | (scan-in lis (cdr lis))) 1079 | (lp (cdr lis))) 1080 | (set-cdr! prev lis)))))) 1081 | (scan-in ans (cdr ans)) 1082 | ans))))) 1083 | 1084 | 1085 | 1086 | ;;; Answers share common tail with LIS where possible; 1087 | ;;; the technique is slightly subtle. 1088 | 1089 | (define (partition pred lis) 1090 | (check-arg procedure? pred partition) 1091 | (let recur ((lis lis)) 1092 | (if (null-list? lis) (values lis lis) ; Use NOT-PAIR? to handle dotted lists. 1093 | (let ((elt (car lis)) 1094 | (tail (cdr lis))) 1095 | (receive (in out) (recur tail) 1096 | (if (pred elt) 1097 | (values (if (pair? out) (cons elt in) lis) out) 1098 | (values in (if (pair? in) (cons elt out) lis)))))))) 1099 | 1100 | 1101 | 1102 | ;(define (partition! pred lis) ; Things are much simpler 1103 | ; (let recur ((lis lis)) ; if you are willing to 1104 | ; (if (null-list? lis) (values lis lis) ; push N stack frames & do N 1105 | ; (let ((elt (car lis))) ; SET-CDR! writes, where N is 1106 | ; (receive (in out) (recur (cdr lis)) ; the length of LIS. 1107 | ; (cond ((pred elt) 1108 | ; (set-cdr! lis in) 1109 | ; (values lis out)) 1110 | ; (else (set-cdr! lis out) 1111 | ; (values in lis)))))))) 1112 | 1113 | 1114 | ;;; This implementation of PARTITION! 1115 | ;;; - doesn't cons, and uses no stack; 1116 | ;;; - is careful not to do redundant SET-CDR! writes, as writes to memory are 1117 | ;;; usually expensive on modern machines, and can be extremely expensive on 1118 | ;;; modern Schemes (e.g., ones that have generational GC's). 1119 | ;;; It just zips down contiguous runs of in and out elts in LIS doing the 1120 | ;;; minimal number of SET-CDR!s to splice these runs together into the result 1121 | ;;; lists. 1122 | 1123 | (define (partition! pred lis) 1124 | (check-arg procedure? pred partition!) 1125 | (if (null-list? lis) (values lis lis) 1126 | 1127 | ;; This pair of loops zips down contiguous in & out runs of the 1128 | ;; list, splicing the runs together. The invariants are 1129 | ;; SCAN-IN: (cdr in-prev) = LIS. 1130 | ;; SCAN-OUT: (cdr out-prev) = LIS. 1131 | (letrec ((scan-in (lambda (in-prev out-prev lis) 1132 | (let lp ((in-prev in-prev) (lis lis)) 1133 | (if (pair? lis) 1134 | (if (pred (car lis)) 1135 | (lp lis (cdr lis)) 1136 | (begin (set-cdr! out-prev lis) 1137 | (scan-out in-prev lis (cdr lis)))) 1138 | (set-cdr! out-prev lis))))) ; Done. 1139 | 1140 | (scan-out (lambda (in-prev out-prev lis) 1141 | (let lp ((out-prev out-prev) (lis lis)) 1142 | (if (pair? lis) 1143 | (if (pred (car lis)) 1144 | (begin (set-cdr! in-prev lis) 1145 | (scan-in lis out-prev (cdr lis))) 1146 | (lp lis (cdr lis))) 1147 | (set-cdr! in-prev lis)))))) ; Done. 1148 | 1149 | ;; Crank up the scan&splice loops. 1150 | (if (pred (car lis)) 1151 | ;; LIS begins in-list. Search for out-list's first pair. 1152 | (let lp ((prev-l lis) (l (cdr lis))) 1153 | (cond ((not (pair? l)) (values lis l)) 1154 | ((pred (car l)) (lp l (cdr l))) 1155 | (else (scan-out prev-l l (cdr l)) 1156 | (values lis l)))) ; Done. 1157 | 1158 | ;; LIS begins out-list. Search for in-list's first pair. 1159 | (let lp ((prev-l lis) (l (cdr lis))) 1160 | (cond ((not (pair? l)) (values l lis)) 1161 | ((pred (car l)) 1162 | (scan-in l prev-l (cdr l)) 1163 | (values l lis)) ; Done. 1164 | (else (lp l (cdr l))))))))) 1165 | 1166 | 1167 | ;;; Inline us, please. 1168 | (define (remove pred l) (filter (lambda (x) (not (pred x))) l)) 1169 | (define (remove! pred l) (filter! (lambda (x) (not (pred x))) l)) 1170 | 1171 | 1172 | 1173 | ;;; Here's the taxonomy for the DELETE/ASSOC/MEMBER functions. 1174 | ;;; (I don't actually think these are the world's most important 1175 | ;;; functions -- the procedural FILTER/REMOVE/FIND/FIND-TAIL variants 1176 | ;;; are far more general.) 1177 | ;;; 1178 | ;;; Function Action 1179 | ;;; --------------------------------------------------------------------------- 1180 | ;;; remove pred lis Delete by general predicate 1181 | ;;; delete x lis [=] Delete by element comparison 1182 | ;;; 1183 | ;;; find pred lis Search by general predicate 1184 | ;;; find-tail pred lis Search by general predicate 1185 | ;;; member x lis [=] Search by element comparison 1186 | ;;; 1187 | ;;; assoc key lis [=] Search alist by key comparison 1188 | ;;; alist-delete key alist [=] Alist-delete by key comparison 1189 | 1190 | (define (delete x lis . maybe-=) 1191 | (let ((= (:optional maybe-= equal?))) 1192 | (filter (lambda (y) (not (= x y))) lis))) 1193 | 1194 | (define (delete! x lis . maybe-=) 1195 | (let ((= (:optional maybe-= equal?))) 1196 | (filter! (lambda (y) (not (= x y))) lis))) 1197 | 1198 | 1199 | ;;; right-duplicate deletion 1200 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 1201 | ;;; delete-duplicates delete-duplicates! 1202 | ;;; 1203 | ;;; Beware -- these are N^2 algorithms. To efficiently remove duplicates 1204 | ;;; in long lists, sort the list to bring duplicates together, then use a 1205 | ;;; linear-time algorithm to kill the dups. Or use an algorithm based on 1206 | ;;; element-marking. The former gives you O(n lg n), the latter is linear. 1207 | 1208 | (define (delete-duplicates lis . maybe-=) 1209 | (let ((elt= (:optional maybe-= equal?))) 1210 | (check-arg procedure? elt= delete-duplicates) 1211 | (let recur ((lis lis)) 1212 | (if (null-list? lis) lis 1213 | (let* ((x (car lis)) 1214 | (tail (cdr lis)) 1215 | (new-tail (recur (delete x tail elt=)))) 1216 | (if (eq? tail new-tail) lis (cons x new-tail))))))) 1217 | 1218 | (define (delete-duplicates! lis maybe-=) 1219 | (let ((elt= (:optional maybe-= equal?))) 1220 | (check-arg procedure? elt= delete-duplicates!) 1221 | (let recur ((lis lis)) 1222 | (if (null-list? lis) lis 1223 | (let* ((x (car lis)) 1224 | (tail (cdr lis)) 1225 | (new-tail (recur (delete! x tail elt=)))) 1226 | (if (eq? tail new-tail) lis (cons x new-tail))))))) 1227 | 1228 | 1229 | ;;; alist stuff 1230 | ;;;;;;;;;;;;;;; 1231 | 1232 | (define (alist-cons key datum alist) (cons (cons key datum) alist)) 1233 | 1234 | (define (alist-copy alist) 1235 | (map-in-order (lambda (elt) (cons (car elt) (cdr elt))) 1236 | alist)) 1237 | 1238 | (define (alist-delete key alist . maybe-=) 1239 | (let ((= (:optional maybe-= equal?))) 1240 | (filter (lambda (elt) (not (= key (car elt)))) alist))) 1241 | 1242 | (define (alist-delete! key alist . maybe-=) 1243 | (let ((= (:optional maybe-= equal?))) 1244 | (filter! (lambda (elt) (not (= key (car elt)))) alist))) 1245 | 1246 | 1247 | ;;; find find-tail take-while drop-while span break any every list-index 1248 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 1249 | 1250 | (define (find pred list) 1251 | (cond ((find-tail pred list) => car) 1252 | (else #f))) 1253 | 1254 | (define (find-tail pred list) 1255 | (check-arg procedure? pred find-tail) 1256 | (let lp ((list list)) 1257 | (and (not (null-list? list)) 1258 | (if (pred (car list)) list 1259 | (lp (cdr list)))))) 1260 | 1261 | (define (take-while pred lis) 1262 | (check-arg procedure? pred take-while) 1263 | (let recur ((lis lis)) 1264 | (if (null-list? lis) '() 1265 | (let ((x (car lis))) 1266 | (if (pred x) 1267 | (cons x (recur (cdr lis))) 1268 | '()))))) 1269 | 1270 | (define (drop-while pred lis) 1271 | (check-arg procedure? pred drop-while) 1272 | (let lp ((lis lis)) 1273 | (if (null-list? lis) '() 1274 | (if (pred (car lis)) 1275 | (lp (cdr lis)) 1276 | lis)))) 1277 | 1278 | (define (take-while! pred lis) 1279 | (check-arg procedure? pred take-while!) 1280 | (if (or (null-list? lis) (not (pred (car lis)))) '() 1281 | (begin (let lp ((prev lis) (rest (cdr lis))) 1282 | (if (pair? rest) 1283 | (let ((x (car rest))) 1284 | (if (pred x) (lp rest (cdr rest)) 1285 | (set-cdr! prev '()))))) 1286 | lis))) 1287 | 1288 | (define (span pred lis) 1289 | (check-arg procedure? pred span) 1290 | (let recur ((lis lis)) 1291 | (if (null-list? lis) (values '() '()) 1292 | (let ((x (car lis))) 1293 | (if (pred x) 1294 | (receive (prefix suffix) (recur (cdr lis)) 1295 | (values (cons x prefix) suffix)) 1296 | (values '() lis)))))) 1297 | 1298 | (define (span! pred lis) 1299 | (check-arg procedure? pred span!) 1300 | (if (or (null-list? lis) (not (pred (car lis)))) (values '() lis) 1301 | (let ((suffix (let lp ((prev lis) (rest (cdr lis))) 1302 | (if (null-list? rest) rest 1303 | (let ((x (car rest))) 1304 | (if (pred x) (lp rest (cdr rest)) 1305 | (begin (set-cdr! prev '()) 1306 | rest))))))) 1307 | (values lis suffix)))) 1308 | 1309 | 1310 | (define (break pred lis) (span (lambda (x) (not (pred x))) lis)) 1311 | (define (break! pred lis) (span! (lambda (x) (not (pred x))) lis)) 1312 | 1313 | (define (any pred lis1 . lists) 1314 | (check-arg procedure? pred any) 1315 | (if (pair? lists) 1316 | 1317 | ;; N-ary case 1318 | (receive (heads tails) (%cars+cdrs (cons lis1 lists)) 1319 | (and (pair? heads) 1320 | (let lp ((heads heads) (tails tails)) 1321 | (receive (next-heads next-tails) (%cars+cdrs tails) 1322 | (if (pair? next-heads) 1323 | (or (apply pred heads) (lp next-heads next-tails)) 1324 | (apply pred heads)))))) ; Last PRED app is tail call. 1325 | 1326 | ;; Fast path 1327 | (and (not (null-list? lis1)) 1328 | (let lp ((head (car lis1)) (tail (cdr lis1))) 1329 | (if (null-list? tail) 1330 | (pred head) ; Last PRED app is tail call. 1331 | (or (pred head) (lp (car tail) (cdr tail)))))))) 1332 | 1333 | 1334 | ;(define (every pred list) ; Simple definition. 1335 | ; (let lp ((list list)) ; Doesn't return the last PRED value. 1336 | ; (or (not (pair? list)) 1337 | ; (and (pred (car list)) 1338 | ; (lp (cdr list)))))) 1339 | 1340 | (define (every pred lis1 . lists) 1341 | (check-arg procedure? pred every) 1342 | (if (pair? lists) 1343 | 1344 | ;; N-ary case 1345 | (receive (heads tails) (%cars+cdrs (cons lis1 lists)) 1346 | (or (not (pair? heads)) 1347 | (let lp ((heads heads) (tails tails)) 1348 | (receive (next-heads next-tails) (%cars+cdrs tails) 1349 | (if (pair? next-heads) 1350 | (and (apply pred heads) (lp next-heads next-tails)) 1351 | (apply pred heads)))))) ; Last PRED app is tail call. 1352 | 1353 | ;; Fast path 1354 | (or (null-list? lis1) 1355 | (let lp ((head (car lis1)) (tail (cdr lis1))) 1356 | (if (null-list? tail) 1357 | (pred head) ; Last PRED app is tail call. 1358 | (and (pred head) (lp (car tail) (cdr tail)))))))) 1359 | 1360 | (define (list-index pred lis1 . lists) 1361 | (check-arg procedure? pred list-index) 1362 | (if (pair? lists) 1363 | 1364 | ;; N-ary case 1365 | (let lp ((lists (cons lis1 lists)) (n 0)) 1366 | (receive (heads tails) (%cars+cdrs lists) 1367 | (and (pair? heads) 1368 | (if (apply pred heads) n 1369 | (lp tails (+ n 1)))))) 1370 | 1371 | ;; Fast path 1372 | (let lp ((lis lis1) (n 0)) 1373 | (and (not (null-list? lis)) 1374 | (if (pred (car lis)) n (lp (cdr lis) (+ n 1))))))) 1375 | 1376 | ;;; Reverse 1377 | ;;;;;;;;;;; 1378 | 1379 | ;R4RS, so not defined here. 1380 | ;(define (reverse lis) (fold cons '() lis)) 1381 | 1382 | ;(define (reverse! lis) 1383 | ; (pair-fold (lambda (pair tail) (set-cdr! pair tail) pair) '() lis)) 1384 | 1385 | (define (reverse! lis) 1386 | (let lp ((lis lis) (ans '())) 1387 | (if (null-list? lis) ans 1388 | (let ((tail (cdr lis))) 1389 | (set-cdr! lis ans) 1390 | (lp tail lis))))) 1391 | 1392 | ;;; Lists-as-sets 1393 | ;;;;;;;;;;;;;;;;; 1394 | 1395 | ;;; This is carefully tuned code; do not modify casually. 1396 | ;;; - It is careful to share storage when possible; 1397 | ;;; - Side-effecting code tries not to perform redundant writes. 1398 | ;;; - It tries to avoid linear-time scans in special cases where constant-time 1399 | ;;; computations can be performed. 1400 | ;;; - It relies on similar properties from the other list-lib procs it calls. 1401 | ;;; For example, it uses the fact that the implementations of MEMBER and 1402 | ;;; FILTER in this source code share longest common tails between args 1403 | ;;; and results to get structure sharing in the lset procedures. 1404 | 1405 | (define (%lset2<= = lis1 lis2) (every (lambda (x) (member x lis2 =)) lis1)) 1406 | 1407 | (define (lset<= = . lists) 1408 | (check-arg procedure? = lset<=) 1409 | (or (not (pair? lists)) ; 0-ary case 1410 | (let lp ((s1 (car lists)) (rest (cdr lists))) 1411 | (or (not (pair? rest)) 1412 | (let ((s2 (car rest)) (rest (cdr rest))) 1413 | (and (or (eq? s2 s1) ; Fast path 1414 | (%lset2<= = s1 s2)) ; Real test 1415 | (lp s2 rest))))))) 1416 | 1417 | (define (lset= = . lists) 1418 | (check-arg procedure? = lset=) 1419 | (or (not (pair? lists)) ; 0-ary case 1420 | (let lp ((s1 (car lists)) (rest (cdr lists))) 1421 | (or (not (pair? rest)) 1422 | (let ((s2 (car rest)) 1423 | (rest (cdr rest))) 1424 | (and (or (eq? s1 s2) ; Fast path 1425 | (and (%lset2<= = s1 s2) (%lset2<= = s2 s1))) ; Real test 1426 | (lp s2 rest))))))) 1427 | 1428 | 1429 | (define (lset-adjoin = lis . elts) 1430 | (check-arg procedure? = lset-adjoin) 1431 | (fold (lambda (elt ans) (if (member elt ans =) ans (cons elt ans))) 1432 | lis elts)) 1433 | 1434 | 1435 | (define (lset-union = . lists) 1436 | (check-arg procedure? = lset-union) 1437 | (reduce (lambda (lis ans) ; Compute ANS + LIS. 1438 | (cond ((null? lis) ans) ; Don't copy any lists 1439 | ((null? ans) lis) ; if we don't have to. 1440 | ((eq? lis ans) ans) 1441 | (else 1442 | (fold (lambda (elt ans) (if (any (lambda (x) (= x elt)) ans) 1443 | ans 1444 | (cons elt ans))) 1445 | ans lis)))) 1446 | '() lists)) 1447 | 1448 | (define (lset-union! = . lists) 1449 | (check-arg procedure? = lset-union!) 1450 | (reduce (lambda (lis ans) ; Splice new elts of LIS onto the front of ANS. 1451 | (cond ((null? lis) ans) ; Don't copy any lists 1452 | ((null? ans) lis) ; if we don't have to. 1453 | ((eq? lis ans) ans) 1454 | (else 1455 | (pair-fold (lambda (pair ans) 1456 | (let ((elt (car pair))) 1457 | (if (any (lambda (x) (= x elt)) ans) 1458 | ans 1459 | (begin (set-cdr! pair ans) pair)))) 1460 | ans lis)))) 1461 | '() lists)) 1462 | 1463 | 1464 | (define (lset-intersection = lis1 . lists) 1465 | (check-arg procedure? = lset-intersection) 1466 | (let ((lists (delete lis1 lists eq?))) ; Throw out any LIS1 vals. 1467 | (cond ((any null-list? lists) '()) ; Short cut 1468 | ((null? lists) lis1) ; Short cut 1469 | (else (filter (lambda (x) 1470 | (every (lambda (lis) (member x lis =)) lists)) 1471 | lis1))))) 1472 | 1473 | (define (lset-intersection! = lis1 . lists) 1474 | (check-arg procedure? = lset-intersection!) 1475 | (let ((lists (delete lis1 lists eq?))) ; Throw out any LIS1 vals. 1476 | (cond ((any null-list? lists) '()) ; Short cut 1477 | ((null? lists) lis1) ; Short cut 1478 | (else (filter! (lambda (x) 1479 | (every (lambda (lis) (member x lis =)) lists)) 1480 | lis1))))) 1481 | 1482 | 1483 | (define (lset-difference = lis1 . lists) 1484 | (check-arg procedure? = lset-difference) 1485 | (let ((lists (filter pair? lists))) ; Throw out empty lists. 1486 | (cond ((null? lists) lis1) ; Short cut 1487 | ((memq lis1 lists) '()) ; Short cut 1488 | (else (filter (lambda (x) 1489 | (every (lambda (lis) (not (member x lis =))) 1490 | lists)) 1491 | lis1))))) 1492 | 1493 | (define (lset-difference! = lis1 . lists) 1494 | (check-arg procedure? = lset-difference!) 1495 | (let ((lists (filter pair? lists))) ; Throw out empty lists. 1496 | (cond ((null? lists) lis1) ; Short cut 1497 | ((memq lis1 lists) '()) ; Short cut 1498 | (else (filter! (lambda (x) 1499 | (every (lambda (lis) (not (member x lis =))) 1500 | lists)) 1501 | lis1))))) 1502 | 1503 | 1504 | (define (lset-xor = . lists) 1505 | (check-arg procedure? = lset-xor) 1506 | (reduce (lambda (b a) ; Compute A xor B: 1507 | ;; Note that this code relies on the constant-time 1508 | ;; short-cuts provided by LSET-DIFF+INTERSECTION, 1509 | ;; LSET-DIFFERENCE & APPEND to provide constant-time short 1510 | ;; cuts for the cases A = (), B = (), and A eq? B. It takes 1511 | ;; a careful case analysis to see it, but it's carefully 1512 | ;; built in. 1513 | 1514 | ;; Compute a-b and a^b, then compute b-(a^b) and 1515 | ;; cons it onto the front of a-b. 1516 | (receive (a-b a-int-b) (lset-diff+intersection = a b) 1517 | (cond ((null? a-b) (lset-difference = b a)) 1518 | ((null? a-int-b) (append b a)) 1519 | (else (fold (lambda (xb ans) 1520 | (if (member xb a-int-b =) ans (cons xb ans))) 1521 | a-b 1522 | b))))) 1523 | '() lists)) 1524 | 1525 | 1526 | (define (lset-xor! = . lists) 1527 | (check-arg procedure? = lset-xor!) 1528 | (reduce (lambda (b a) ; Compute A xor B: 1529 | ;; Note that this code relies on the constant-time 1530 | ;; short-cuts provided by LSET-DIFF+INTERSECTION, 1531 | ;; LSET-DIFFERENCE & APPEND to provide constant-time short 1532 | ;; cuts for the cases A = (), B = (), and A eq? B. It takes 1533 | ;; a careful case analysis to see it, but it's carefully 1534 | ;; built in. 1535 | 1536 | ;; Compute a-b and a^b, then compute b-(a^b) and 1537 | ;; cons it onto the front of a-b. 1538 | (receive (a-b a-int-b) (lset-diff+intersection! = a b) 1539 | (cond ((null? a-b) (lset-difference! = b a)) 1540 | ((null? a-int-b) (append! b a)) 1541 | (else (pair-fold (lambda (b-pair ans) 1542 | (if (member (car b-pair) a-int-b =) ans 1543 | (begin (set-cdr! b-pair ans) b-pair))) 1544 | a-b 1545 | b))))) 1546 | '() lists)) 1547 | 1548 | 1549 | (define (lset-diff+intersection = lis1 . lists) 1550 | (check-arg procedure? = lset-diff+intersection) 1551 | (cond ((every null-list? lists) (values lis1 '())) ; Short cut 1552 | ((memq lis1 lists) (values '() lis1)) ; Short cut 1553 | (else (partition (lambda (elt) 1554 | (not (any (lambda (lis) (member elt lis =)) 1555 | lists))) 1556 | lis1)))) 1557 | 1558 | (define (lset-diff+intersection! = lis1 . lists) 1559 | (check-arg procedure? = lset-diff+intersection!) 1560 | (cond ((every null-list? lists) (values lis1 '())) ; Short cut 1561 | ((memq lis1 lists) (values '() lis1)) ; Short cut 1562 | (else (partition! (lambda (elt) 1563 | (not (any (lambda (lis) (member elt lis =)) 1564 | lists))) 1565 | lis1)))) 1566 | 1567 | )) 1568 | --------------------------------------------------------------------------------