prelude.scm (25694 bytes)
1 ; prelude.scm -- R7RS-small procedures written in the chip Scheme itself. 2 ; host.lisp sends this file to the chip REPL one line at a time: keep one form per line. 3 (define (not x) (if x #f #t)) 4 (define (caar x) (car (car x))) 5 (define (cadr x) (car (cdr x))) 6 (define (cdar x) (cdr (car x))) 7 (define (cddr x) (cdr (cdr x))) 8 (define (caddr x) (car (cddr x))) 9 (define (list . xs) xs) 10 (define (length l) (let loop ((l l) (n 0)) (if (pair? l) (loop (cdr l) (+ n 1)) n))) 11 (define (reverse l) (let loop ((l l) (acc '())) (if (pair? l) (loop (cdr l) (cons (car l) acc)) acc))) 12 (define (append2 a b) (if (pair? a) (cons (car a) (append2 (cdr a) b)) b)) 13 (define (append . ls) (cond ((null? ls) '()) ((null? (cdr ls)) (car ls)) (else (append2 (car ls) (apply append (cdr ls)))))) 14 (define (list-tail l k) (if (= k 0) l (list-tail (cdr l) (- k 1)))) 15 (define (list-ref l k) (car (list-tail l k))) 16 (define (map1 f l) (if (pair? l) (cons (f (car l)) (map1 f (cdr l))) '())) 17 (define (any-null? ls) (cond ((null? ls) #f) ((null? (car ls)) #t) (else (any-null? (cdr ls))))) 18 (define (map f . ls) (if (null? (cdr ls)) (map1 f (car ls)) (if (any-null? ls) '() (cons (apply f (map1 car ls)) (apply map f (map1 cdr ls)))))) 19 (define (for-each f . ls) (if (any-null? ls) #t (begin (apply f (map1 car ls)) (apply for-each f (map1 cdr ls))))) 20 (define (equal? a b) (cond ((and (pair? a) (pair? b)) (and (equal? (car a) (car b)) (equal? (cdr a) (cdr b)))) ((and (string? a) (string? b)) (= 0 (%string-compare a b))) ((and (vector? a) (vector? b)) (equal? (vector->list a) (vector->list b))) ((and (bytevector? a) (bytevector? b)) (equal? (%bytevector->list a) (%bytevector->list b))) (else (eqv? a b)))) 21 (define (mem= same? x l) (cond ((null? l) #f) ((same? x (car l)) l) (else (mem= same? x (cdr l))))) 22 (define (memq x l) (mem= eq? x l)) 23 (define (memv x l) (mem= eqv? x l)) 24 (define (member x l) (mem= equal? x l)) 25 (define (ass= same? x l) (cond ((null? l) #f) ((same? x (car (car l))) (car l)) (else (ass= same? x (cdr l))))) 26 (define (assq x l) (ass= eq? x l)) 27 (define (assv x l) (ass= eqv? x l)) 28 (define (assoc x l) (ass= equal? x l)) 29 (define (zero? n) (= n 0)) 30 (define (positive? n) (> n 0)) 31 (define (negative? n) (< n 0)) 32 (define (odd? n) (not (= 0 (remainder n 2)))) 33 (define (even? n) (= 0 (remainder n 2))) 34 (define (abs n) (if (< n 0) (- n) n)) 35 (define (max x . r) (let loop ((m x) (r r) (i (inexact? x))) (if (null? r) (if i (inexact m) m) (loop (if (> (car r) m) (car r) m) (cdr r) (or i (inexact? (car r))))))) 36 (define (min x . r) (let loop ((m x) (r r) (i (inexact? x))) (if (null? r) (if i (inexact m) m) (loop (if (< (car r) m) (car r) m) (cdr r) (or i (inexact? (car r))))))) 37 (define (numerator q) (if (exact? q) (%numerator q) (inexact (%numerator (exact q))))) 38 (define (denominator q) (if (exact? q) (%denominator q) (inexact (%denominator (exact q))))) 39 (define (exact->inexact z) (inexact z)) 40 (define (inexact->exact z) (exact z)) 41 (define (finite? z) (not (or (nan? z) (infinite? z)))) 42 (define (gcd . ns) (if (null? ns) 0 (let loop ((a (abs (car ns))) (r (cdr ns))) (if (null? r) a (loop (let g ((a a) (b (abs (car r)))) (if (= b 0) a (g b (remainder a b)))) (cdr r)))))) 43 (define (lcm . ns) (if (null? ns) 1 (let loop ((a (abs (car ns))) (r (cdr ns))) (if (null? r) a (loop (if (= a 0) 0 (quotient (abs (* a (car r))) (gcd a (car r)))) (cdr r)))))) 44 (define (square n) (* n n)) 45 (define (boolean=? a b) (eq? a b)) 46 (define (symbol=? a b) (eq? a b)) 47 (define (list? l) (let loop ((slow l) (fast l)) (cond ((null? fast) #t) ((not (pair? fast)) #f) ((null? (cdr fast)) #t) ((not (pair? (cdr fast))) #f) (else (let ((fast (cddr fast)) (slow (cdr slow))) (if (eq? fast slow) #f (loop slow fast))))))) 48 (define (list-copy l) (if (pair? l) (cons (car l) (list-copy (cdr l))) l)) 49 (define (make-list k . fill) (let loop ((k k) (acc '())) (if (= k 0) acc (loop (- k 1) (cons (if (null? fill) #f (car fill)) acc))))) 50 (define (string->list s . r) (%string->list s (if (pair? r) (car r) 0) (if (and (pair? r) (pair? (cdr r))) (cadr r) (string-length s)))) 51 (define (vector->list v . r) (%vector->list v (if (pair? r) (car r) 0) (if (and (pair? r) (pair? (cdr r))) (cadr r) (vector-length v)))) 52 (define (substring s start end) (%substring s start end)) 53 (define (string-copy s . r) (%substring s (if (pair? r) (car r) 0) (if (and (pair? r) (pair? (cdr r))) (cadr r) (string-length s)))) 54 (define (string-append . ss) (let loop ((acc "") (ss ss)) (if (null? ss) acc (loop (%string-append2 acc (car ss)) (cdr ss))))) 55 (define (string . cs) (list->string cs)) 56 (define (%chain cmp ok? xs) (let loop ((xs xs)) (cond ((null? (cdr xs)) #t) ((ok? (cmp (car xs) (cadr xs))) (loop (cdr xs))) (else #f)))) 57 (define (string=? . ss) (%chain %string-compare zero? ss)) 58 (define (string<? . ss) (%chain %string-compare negative? ss)) 59 (define (string>? . ss) (%chain %string-compare positive? ss)) 60 (define (string<=? . ss) (%chain %string-compare (lambda (n) (<= n 0)) ss)) 61 (define (string>=? . ss) (%chain %string-compare (lambda (n) (>= n 0)) ss)) 62 (define (%ccmp a b) (- (char->integer a) (char->integer b))) 63 (define (char=? . cs) (%chain %ccmp zero? cs)) 64 (define (char<? . cs) (%chain %ccmp negative? cs)) 65 (define (char>? . cs) (%chain %ccmp positive? cs)) 66 (define (char<=? . cs) (%chain %ccmp (lambda (n) (<= n 0)) cs)) 67 (define (char>=? . cs) (%chain %ccmp (lambda (n) (>= n 0)) cs)) 68 (define (char-upper-case? c) (let ((n (char->integer c))) (and (>= n 65) (<= n 90)))) 69 (define (char-lower-case? c) (let ((n (char->integer c))) (and (>= n 97) (<= n 122)))) 70 (define (char-alphabetic? c) (or (char-upper-case? c) (char-lower-case? c))) 71 (define (char-numeric? c) (let ((n (char->integer c))) (and (>= n 48) (<= n 57)))) 72 (define (char-whitespace? c) (if (memv (char->integer c) '(32 9 10 12 13)) #t #f)) 73 (define (char-upcase c) (if (char-lower-case? c) (integer->char (- (char->integer c) 32)) c)) 74 (define (char-downcase c) (if (char-upper-case? c) (integer->char (+ (char->integer c) 32)) c)) 75 (define (char-foldcase c) (char-downcase c)) 76 (define (digit-value c) (if (char-numeric? c) (- (char->integer c) 48) #f)) 77 (define (vector . xs) (list->vector xs)) 78 (define (vector-fill! v x . r) (let loop ((i (if (pair? r) (car r) 0))) (if (< i (if (and (pair? r) (pair? (cdr r))) (cadr r) (vector-length v))) (begin (vector-set! v i x) (loop (+ i 1)))))) 79 (define (vector-copy v . r) (list->vector (apply vector->list v r))) 80 (define (vector-append . vs) (list->vector (apply append (map vector->list vs)))) 81 (define (vector-map f . vs) (list->vector (apply map f (map vector->list vs)))) 82 (define (vector-for-each f . vs) (apply for-each f (map vector->list vs))) 83 (define (string-map f . ss) (list->string (apply map f (map string->list ss)))) 84 (define (string-for-each f . ss) (apply for-each f (map string->list ss))) 85 (define (vector->string v . r) (list->string (apply vector->list v r))) 86 (define (string->vector s . r) (list->vector (apply string->list s r))) 87 (define (bytevector . bs) (list->bytevector bs)) 88 (define (bytevector->list b) (%bytevector->list b)) 89 (define (bytevector-copy b . r) (let ((l (%bytevector->list b))) (list->bytevector (list-head (list-tail l (if (pair? r) (car r) 0)) (- (if (and (pair? r) (pair? (cdr r))) (cadr r) (length l)) (if (pair? r) (car r) 0)))))) 90 (define (list-head l k) (if (= k 0) '() (cons (car l) (list-head (cdr l) (- k 1))))) 91 (define (bytevector-append . bs) (list->bytevector (apply append (map %bytevector->list bs)))) 92 (define (utf8->string b) (list->string (map integer->char (%bytevector->list b)))) 93 (define (string->utf8 s) (list->bytevector (map char->integer (string->list s)))) 94 (define (floor x) (cond ((exact-integer? x) x) ((exact? x) (let ((n (numerator x)) (d (denominator x))) (if (>= n 0) (quotient n d) (- (quotient (+ (- n) d -1) d))))) (else (let ((t (%ftruncate x))) (if (> t x) (- t 1) t))))) 95 (define (ceiling x) (- (floor (- x)))) 96 (define (truncate x) (cond ((exact-integer? x) x) ((exact? x) (quotient (numerator x) (denominator x))) (else (%ftruncate x)))) 97 (define (round x) (let* ((f (floor x)) (diff (- x f))) (cond ((< diff 1/2) f) ((> diff 1/2) (+ f 1)) ((even? (exact f)) f) (else (+ f 1))))) 98 (define (%isqrt n) (if (< n 2) n (let loop ((x n)) (let ((y (quotient (+ x (quotient n x)) 2))) (if (>= y x) x (loop y)))))) 99 (define (sqrt x) (cond ((and (exact-integer? x) (>= x 0)) (let ((s (%isqrt x))) (if (= (* s s) x) s (%fsqrt x)))) ((and (exact? x) (>= x 0)) (let ((a (sqrt (numerator x))) (b (sqrt (denominator x)))) (if (and (exact? a) (exact? b)) (/ a b) (%fsqrt x)))) (else (%fsqrt x)))) 100 (define (exact-integer-sqrt n) (let ((s (%isqrt n))) (list s (- n (* s s))))) 101 (define (%cicmp a b) (- (char->integer (char-foldcase a)) (char->integer (char-foldcase b)))) 102 (define (char-ci=? . cs) (%chain %cicmp zero? cs)) 103 (define (char-ci<? . cs) (%chain %cicmp negative? cs)) 104 (define (char-ci>? . cs) (%chain %cicmp positive? cs)) 105 (define (char-ci<=? . cs) (%chain %cicmp (lambda (n) (<= n 0)) cs)) 106 (define (char-ci>=? . cs) (%chain %cicmp (lambda (n) (>= n 0)) cs)) 107 ; ---- item 4: syntax, control and data abstractions, written as procedural macros ---- 108 ; A macro is a box made by %macro around a procedure from the whole form to its expansion; 109 ; eval expands it before evaluating. syntax-rules builds such a procedure (not hygienic). 110 (define (cadddr x) (car (cdddr x))) 111 (define (cdddr x) (cdr (cddr x))) 112 (define (cddddr x) (cdr (cdddr x))) 113 114 (define (%qq x depth) 115 (cond ((vector? x) (list 'list->vector (%qq (vector->list x) depth))) 116 ((not (pair? x)) (list 'quote x)) 117 ((eq? (car x) 'unquote) 118 (if (= depth 0) (cadr x) (list 'list ''unquote (%qq (cadr x) (- depth 1))))) 119 ((eq? (car x) 'quasiquote) (list 'list ''quasiquote (%qq (cadr x) (+ depth 1)))) 120 ((and (pair? (car x)) (eq? (caar x) 'unquote-splicing) (= depth 0)) 121 (list 'append (cadr (car x)) (%qq (cdr x) depth))) 122 (else (list 'cons (%qq (car x) depth) (%qq (cdr x) depth))))) 123 (define-syntax quasiquote (%macro (lambda (f) (%qq (cadr f) 0)))) 124 125 ; syntax-rules: match patterns (with ellipsis, literals, _) and fill templates. 126 (define (%sr-vars pat lits ell) 127 (cond ((symbol? pat) (if (or (memq pat lits) (eq? pat ell) (eq? pat '_)) '() (list pat))) 128 ((pair? pat) (append (%sr-vars (car pat) lits ell) (%sr-vars (cdr pat) lits ell))) 129 ((vector? pat) (%sr-vars (vector->list pat) lits ell)) 130 (else '()))) 131 (define (%sr-match pat form lits ell b) 132 (cond ((not b) #f) 133 ((symbol? pat) 134 (cond ((memq pat lits) (if (eq? pat form) b #f)) 135 ((eq? pat '_) b) 136 (else (cons (cons pat form) b)))) 137 ((and (pair? pat) (pair? (cdr pat)) (eq? (cadr pat) ell)) 138 (let* ((tail (cddr pat)) (tn (let loop ((t tail) (n 0)) (if (pair? t) (loop (cdr t) (+ n 1)) n))) 139 (fn (let loop ((f form) (n 0)) (if (pair? f) (loop (cdr f) (+ n 1)) n)))) 140 (if (< fn tn) #f 141 (let loop ((f form) (k (- fn tn)) (ms '())) 142 (if (> k 0) 143 (let ((m (%sr-match (car pat) (car f) lits ell (list (cons '%ok #t))))) 144 (if m (loop (cdr f) (- k 1) (cons m ms)) #f)) 145 (let ((ms (reverse ms))) 146 (%sr-match tail f lits ell 147 (append (map (lambda (v) (cons v (cons '%seq (map (lambda (m) (cdr (assq v m))) ms)))) 148 (%sr-vars (car pat) lits ell)) 149 b)))))))) 150 ((pair? pat) (and (pair? form) (%sr-match (cdr pat) (cdr form) lits ell (%sr-match (car pat) (car form) lits ell b)))) 151 ((null? pat) (if (null? form) b #f)) 152 ((vector? pat) (and (vector? form) (%sr-match (vector->list pat) (vector->list form) lits ell b))) 153 (else (if (equal? pat form) b #f)))) 154 (define (%sr-seq? v) (and (pair? v) (eq? (car v) '%seq))) 155 (define (%sr-expand t b ell) 156 (cond ((symbol? t) (let ((p (assq t b))) (if p (cdr p) t))) 157 ((and (pair? t) (eq? (car t) ell) (pair? (cdr t))) (%sr-expand (cadr t) '() '%no-ellipsis)) 158 ((and (pair? t) (pair? (cdr t)) (eq? (cadr t) ell)) 159 (let* ((vars (filter (lambda (v) (let ((p (assq v b))) (and p (%sr-seq? (cdr p))))) (%sr-vars (car t) '() ell))) 160 (n (if (null? vars) 0 (length (cddr (assq (car vars) b)))))) 161 (let loop ((i (- n 1)) (acc (%sr-expand (cddr t) b ell))) 162 (if (< i 0) acc 163 (loop (- i 1) 164 (cons (%sr-expand (car t) (append (map (lambda (v) (cons v (list-ref (cddr (assq v b)) i))) vars) b) ell) acc)))))) 165 ((pair? t) (cons (%sr-expand (car t) b ell) (%sr-expand (cdr t) b ell))) 166 ((vector? t) (list->vector (%sr-expand (vector->list t) b ell))) 167 (else t))) 168 (define (filter ok? l) (cond ((null? l) '()) ((ok? (car l)) (cons (car l) (filter ok? (cdr l)))) (else (filter ok? (cdr l))))) 169 (define (%syntax-rules spec) 170 (let* ((ell (if (symbol? (car spec)) (car spec) '...)) 171 (spec (if (symbol? (car spec)) (cdr spec) spec)) 172 (lits (car spec)) (rules (cdr spec))) 173 (%macro (lambda (form) 174 (let loop ((rs rules)) 175 (if (null? rs) (error "no syntax-rules pattern matches" form) 176 (let ((b (%sr-match (cdar (car rs)) (cdr form) lits ell (list (cons '%ok #t))))) 177 (if b (%sr-expand (cadr (car rs)) b ell) (loop (cdr rs)))))))))) 178 179 ; dynamic-wind (escape-only continuations: unwinding runs the after thunks; there is no re-entry) 180 (define *winders* '()) 181 (define (dynamic-wind before thunk after) 182 (before) 183 (set! *winders* (cons (cons before after) *winders*)) 184 (let ((v (thunk))) (set! *winders* (cdr *winders*)) (after) v)) 185 (define (%unwind-to saved) 186 (let loop () (if (and (pair? *winders*) (not (eq? *winders* saved))) 187 (let ((w (car *winders*))) (set! *winders* (cdr *winders*)) ((cdr w)) (loop))))) 188 (define (values . xs) (if (and (pair? xs) (null? (cdr xs))) (car xs) (%make-record '%values xs))) 189 (define (%values? v) (and (%record? v) (eq? (%record-type v) '%values))) 190 (define (call-with-values producer consumer) 191 (let ((v (producer))) (if (%values? v) (apply consumer (%record-ref v 0)) (consumer v)))) 192 (define (call-with-current-continuation f) 193 (let ((saved *winders*)) 194 (%callcc (lambda (k) (f (lambda vals (%unwind-to saved) (k (apply values vals)))))))) 195 (define call/cc call-with-current-continuation) 196 197 ; exceptions 198 (define *handlers* '()) 199 (define (%make-error msg irritants) (%make-record '%error-object msg irritants)) 200 (define (error-object? x) (and (%record? x) (eq? (%record-type x) '%error-object))) 201 (define (error-object-message e) (%record-ref e 0)) 202 (define (error-object-irritants e) (%record-ref e 1)) 203 (define (read-error? x) #f) 204 (define (file-error? x) #f) 205 (define (%uncaught obj) 206 (if (error-object? obj) 207 (begin (display (error-object-message obj)) 208 (for-each (lambda (i) (display " ") (write i)) (error-object-irritants obj))) 209 (begin (display "uncaught exception: ") (write obj))) 210 (newline) (%repl-reset)) 211 (define (%with-handlers hs thunk) 212 (let ((old *handlers*)) (dynamic-wind (lambda () (set! *handlers* hs)) thunk (lambda () (set! *handlers* old))))) 213 (define (with-exception-handler h thunk) (%with-handlers (cons h *handlers*) thunk)) 214 (define (raise-continuable obj) 215 (if (null? *handlers*) (%uncaught obj) 216 (let ((h (car *handlers*))) (%with-handlers (cdr *handlers*) (lambda () (h obj)))))) 217 (define (raise obj) 218 (raise-continuable obj) 219 (%uncaught (%make-error "handler returned from raise" (list obj)))) 220 (define (error msg . irritants) (raise (%make-error msg irritants))) 221 (define (%guard handler thunk) 222 ((call/cc (lambda (k) 223 (with-exception-handler (lambda (c) (k (lambda () (handler c)))) 224 (lambda () (let ((v (thunk))) (lambda () v)))))))) 225 (define-syntax guard 226 (%macro (lambda (f) 227 (let ((var (car (cadr f))) (clauses (cdr (cadr f)))) 228 (list '%guard 229 (list 'lambda (list var) (cons 'cond (append clauses (list (list 'else (list 'raise-continuable var)))))) 230 (cons 'lambda (cons '() (cddr f)))))))) 231 232 ; promises 233 (define (%make-promise done v) (%make-record '%promise (list done v))) 234 (define (promise? x) (and (%record? x) (eq? (%record-type x) '%promise))) 235 (define (make-promise v) (if (promise? v) v (%make-promise #t v))) 236 (define (force p) 237 (if (not (promise? p)) p 238 (let ((s (%record-ref p 0))) 239 (if (car s) (cadr s) 240 (let* ((v ((cadr s))) (s2 (%record-ref p 0))) 241 (cond ((car s2) (cadr s2)) 242 ((promise? v) (%record-set! p 0 (%record-ref v 0)) (force p)) 243 (else (%record-set! p 0 (list #t v)) v))))))) 244 (define-syntax delay (%macro (lambda (f) (list '%make-promise #f (list 'lambda '() (list '%make-promise #t (cadr f))))))) 245 (define-syntax delay-force (%macro (lambda (f) (list '%make-promise #f (list 'lambda '() (cadr f)))))) 246 247 ; parameters 248 (define (make-parameter v . conv) 249 (let* ((c (if (pair? conv) (car conv) (lambda (x) x))) (cell (list (c v)))) 250 (lambda args (cond ((null? args) (car cell)) ((eq? (car args) '%set) (set-car! cell (cadr args))) (else c))))) 251 (define (%parameterize ps vs thunk) 252 (let ((new (map (lambda (p v) ((p '%conv) v)) ps vs)) (old (map (lambda (p) (p)) ps))) 253 (dynamic-wind (lambda () (for-each (lambda (p v) (p '%set v)) ps new)) thunk 254 (lambda () (for-each (lambda (p v) (p '%set v)) ps old))))) 255 (define-syntax parameterize 256 (%macro (lambda (f) (list '%parameterize (cons 'list (map car (cadr f))) (cons 'list (map cadr (cadr f))) 257 (cons 'lambda (cons '() (cddr f))))))) 258 259 ; multiple-value binding forms (let-values binds left to right, like let*-values) 260 (define (%lv bindings body) 261 (if (null? bindings) (cons 'let (cons '() body)) 262 (list 'call-with-values (list 'lambda '() (cadr (car bindings))) 263 (list 'lambda (car (car bindings)) (%lv (cdr bindings) body))))) 264 (define-syntax let-values (%macro (lambda (f) (%lv (cadr f) (cddr f))))) 265 (define-syntax let*-values (%macro (lambda (f) (%lv (cadr f) (cddr f))))) 266 (define-syntax define-values 267 (%macro (lambda (f) 268 (let ((vars (cadr f)) (tmps (map (lambda (v) (string->symbol (string-append "%t-" (symbol->string v)))) (cadr f)))) 269 (cons 'begin (append (map (lambda (v) (list 'define v #f)) vars) 270 (list (list 'call-with-values (list 'lambda '() (caddr f)) 271 (cons 'lambda (cons tmps (map (lambda (v t) (list 'set! v t)) vars tmps)))) 272 '(if #f #f)))))))) 273 (define (floor/ n d) (let ((q (floor (/ n d)))) (values q (- n (* d q))))) 274 (define (truncate/ n d) (values (quotient n d) (remainder n d))) 275 (define (floor-quotient n d) (floor (/ n d))) 276 (define (floor-remainder n d) (modulo n d)) 277 (define (truncate-quotient n d) (quotient n d)) 278 (define (truncate-remainder n d) (remainder n d)) 279 (define (exact-integer-sqrt n) (let ((s (%isqrt n))) (values s (- n (* s s))))) 280 281 ; records 282 (define-syntax define-record-type 283 (%macro (lambda (f) 284 (let* ((type (cadr f)) (ctor (caddr f)) (pred (cadddr f)) (fields (cddddr f)) (names (map car fields)) 285 (idx (lambda (n) (let loop ((l names) (i 0)) (if (eq? (car l) n) i (loop (cdr l) (+ i 1))))))) 286 (cons 'begin 287 (append (list (list 'define type (list 'quote type))) 288 (if (pair? ctor) 289 (list (list 'define (car ctor) 290 (list 'lambda (cdr ctor) 291 (cons '%make-record (cons (list 'quote type) (map (lambda (n) (if (memq n (cdr ctor)) n #f)) names)))))) 292 '()) 293 (list (list 'define pred (list 'lambda '(x) (list 'and '(%record? x) (list 'eq? '(%record-type x) (list 'quote type)))))) 294 (apply append 295 (map (lambda (fd) 296 (let ((i (idx (car fd)))) 297 (cons (list 'define (cadr fd) (list 'lambda '(r) (list '%record-ref 'r i))) 298 (if (pair? (cddr fd)) (list (list 'define (caddr fd) (list 'lambda '(r v) (list '%record-set! 'r i 'v)))) '())))) 299 fields)) 300 (list (list 'quote type)))))))) 301 302 ; case-lambda 303 (define (%arity formals) (let loop ((f formals) (n 0)) (cond ((null? f) n) ((pair? f) (loop (cdr f) (+ n 1))) (else (- -1 n))))) 304 (define (%case-lambda clauses) 305 (lambda args 306 (let ((n (length args))) 307 (let loop ((cs clauses)) 308 (cond ((null? cs) (error "no case-lambda clause matches" n)) 309 ((let ((a (caar cs))) (if (< a 0) (>= n (- -1 a)) (= n a))) (apply (cdar cs) args)) 310 (else (loop (cdr cs)))))))) 311 (define-syntax case-lambda 312 (%macro (lambda (f) (list '%case-lambda (cons 'list (map (lambda (c) (list 'cons (list 'quote (%arity (car c))) (cons 'lambda c))) (cdr f))))))) 313 314 ; ---- item 6: primitives check their argument count: (name min max), max 255 = any ---- 315 (for-each (lambda (a) (%arity! (car a) (cadr a) (caddr a))) 316 '((+ 0 255) (- 1 255) (* 0 255) (/ 1 255) (quotient 2 2) (remainder 2 2) (modulo 2 2) 317 (= 1 255) (< 1 255) (> 1 255) (<= 1 255) (>= 1 255) (eq? 2 2) (eqv? 2 2) 318 (car 1 1) (cdr 1 1) (cons 2 2) (null? 1 1) (pair? 1 1) (symbol? 1 1) (procedure? 1 1) (boolean? 1 1) 319 (exact 1 1) (inexact 1 1) (number? 1 1) (real? 1 1) (complex? 1 1) (integer? 1 1) (rational? 1 1) 320 (exact? 1 1) (inexact? 1 1) (exact-integer? 1 1) (%numerator 1 1) (%denominator 1 1) 321 (nan? 1 1) (infinite? 1 1) (%ftruncate 1 1) (%fsqrt 1 1) 322 (apply 2 255) (display 1 2) (write 1 2) (newline 0 1) 323 (string? 1 1) (vector? 1 1) (bytevector? 1 1) (char? 1 1) (char->integer 1 1) (integer->char 1 1) 324 (string-length 1 1) (vector-length 1 1) (bytevector-length 1 1) 325 (string-ref 2 2) (string-set! 3 3) (vector-ref 2 2) (vector-set! 3 3) 326 (bytevector-u8-ref 2 2) (bytevector-u8-set! 3 3) (make-string 1 2) (make-vector 1 2) (make-bytevector 1 2) 327 (%string->list 3 3) (%vector->list 3 3) (%bytevector->list 1 1) 328 (list->string 1 1) (list->vector 1 1) (list->bytevector 1 1) 329 (%substring 3 3) (%string-append2 2 2) (%string-compare 2 2) (string->symbol 1 1) (symbol->string 1 1) 330 (set-car! 2 2) (set-cdr! 2 2) (%macro 1 1) (%callcc 1 1) (%make-record 1 255) (%record? 1 1) 331 (%record-type 1 1) (%record-ref 2 2) (%record-set! 3 3) (%arity! 3 3))) 332 333 ; ---- item 9: libraries are accepted (import is ignored); ports ---- 334 (define (open-output-string) (%make-record '%oport '())) 335 (define (get-output-string p) (list->string (reverse (%record-ref p 0)))) 336 (define (open-input-string s) (%make-record '%iport s 0)) 337 (define %console-out (%make-record '%console-out)) 338 (define %console-in (%make-record '%console-in)) 339 (define (current-output-port) %console-out) 340 (define (current-error-port) %console-out) 341 (define (current-input-port) %console-in) 342 (define (output-port? p) (and (%record? p) (memq (%record-type p) '(%oport %console-out)) #t)) 343 (define (input-port? p) (and (%record? p) (memq (%record-type p) '(%iport %console-in)) #t)) 344 (define (port? p) (or (input-port? p) (output-port? p))) 345 (define (textual-port? p) (port? p)) 346 (define (binary-port? p) #f) 347 (define (input-port-open? p) (input-port? p)) 348 (define (output-port-open? p) (output-port? p)) 349 (define (close-port p) #t) 350 (define (close-input-port p) #t) 351 (define (close-output-port p) #t) 352 (define (flush-output-port . p) #t) 353 (define (write-char c . p) (apply display c p)) 354 (define (write-string s . p) (apply display s p)) 355 (define (write-shared x . p) (apply write x p)) 356 (define (write-simple x . p) (apply write x p)) 357 (define (%ip p) (if (and (pair? p) (eq? (%record-type (car p)) '%iport)) (car p) (error "only string input ports are supported"))) 358 (define (peek-char . p) 359 (let* ((ip (%ip p)) (s (%record-ref ip 0)) (i (%record-ref ip 1))) 360 (if (>= i (string-length s)) (eof-object) (string-ref s i)))) 361 (define (read-char . p) 362 (let* ((ip (%ip p)) (c (peek-char ip))) 363 (if (not (eof-object? c)) (%record-set! ip 1 (+ (%record-ref ip 1) 1))) 364 c)) 365 (define (char-ready? . p) #t) 366 (define (read-line . p) 367 (let ((ip (%ip p))) 368 (let loop ((acc '())) 369 (let ((c (read-char ip))) 370 (cond ((eof-object? c) (if (null? acc) c (list->string (reverse acc)))) 371 ((char=? c #\newline) (list->string (reverse acc))) 372 (else (loop (cons c acc)))))))) 373 (define (read-string k . p) 374 (let ((ip (%ip p))) 375 (let loop ((k k) (acc '())) 376 (if (= k 0) (list->string (reverse acc)) 377 (let ((c (read-char ip))) 378 (if (eof-object? c) (if (null? acc) c (list->string (reverse acc))) (loop (- k 1) (cons c acc)))))))) 379 (define (read . p) 380 (if (null? p) (%read-console) 381 (let ((ip (%ip p))) (dynamic-wind (lambda () #f) (lambda () (%pread ip)) (lambda () (%unsrc)))))) 382 (define (read-error? e) 383 (and (error-object? e) (member (error-object-message e) '("unexpected )" "unexpected end of input" "bad character name")) #t)) 384 (define (file-error? e) (and (error-object? e) (equal? (error-object-message e) "no file system") #t)) 385 (define (open-input-file f) (raise (%make-error "no file system" (list f)))) 386 (define (open-output-file f) (raise (%make-error "no file system" (list f)))) 387 (define (file-exists? f) #f) 388 (for-each (lambda (a) (%arity! (car a) (cadr a) (caddr a))) 389 '((%pread 1 1) (%unsrc 0 0) (%read-console 0 0) (eof-object 0 0) (eof-object? 1 1)))