Projects : gscm : gscm_usrbin
| 1 | ;;; Gales Scheme standard library and toplevel |
| 2 | ;;; Includes program loader and READ-EVAL-PRINT loop. |
| 3 | ;;; J. Welsh, 2017-2018 |
| 4 | |
| 5 | (begin |
| 6 | |
| 7 | ;;; Syntax library (R5RS: 4.2. Derived expression types) |
| 8 | |
| 9 | (define-syntax and |
| 10 | (syntax-rules () |
| 11 | ((and) #t) |
| 12 | ((and a) a) |
| 13 | ((and a . b) (if a (and . b) #f)))) |
| 14 | |
| 15 | (define-syntax or |
| 16 | (syntax-rules () |
| 17 | ((or) #f) |
| 18 | ((or a) a) |
| 19 | ((or (a . b) . c) (let ((tmp5f920465446f5c2d (a . b))) |
| 20 | (if tmp5f920465446f5c2d tmp5f920465446f5c2d |
| 21 | (or . c)))) |
| 22 | ;; ^ The macro machinery ought to rename temporaries automatically, but an "official random number" is adequate because we only need to avoid shadowing free references within C. Further bindings to the same "gensym" within A, B or C do not conflict with the outer one. |
| 23 | ((or a . b) (if a a (or . b))))) |
| 24 | |
| 25 | (define-syntax let* |
| 26 | (syntax-rules () |
| 27 | ((let* () body . a) (let () body . a)) |
| 28 | ((let* ((n v)) body . a) (let ((n v)) body . a)) |
| 29 | ((let* ((n v) . b) body . a) (let ((n v)) (let* b body . a))))) |
| 30 | |
| 31 | (define-syntax quasiquote |
| 32 | (syntax-rules (unquote unquote-splicing) |
| 33 | ((quasiquote (unquote a)) a) |
| 34 | ((quasiquote ((unquote-splicing a) . b)) (append a (quasiquote b))) |
| 35 | ((quasiquote (a . b)) (cons (quasiquote a) (quasiquote b))) |
| 36 | ;((quasiquote #(a ...)) (vector (quasiquote a) ...)) |
| 37 | ((quasiquote a) (quote a)))) |
| 38 | |
| 39 | (define-syntax cond |
| 40 | (syntax-rules (else =>) |
| 41 | ((cond (else a . b)) (begin a . b)) |
| 42 | ((cond (t => r)) (let ((tmp5f920465446f5c2d t)) |
| 43 | (if tmp5f920465446f5c2d (r tmp5f920465446f5c2d)))) |
| 44 | ((cond (t => r) . c) (let ((tmp5f920465446f5c2d t)) |
| 45 | (if tmp5f920465446f5c2d (r tmp5f920465446f5c2d) |
| 46 | (cond . c)))) |
| 47 | ;; return unspecified when no tests pass |
| 48 | ((cond (t)) (or t '())) |
| 49 | ((cond (t) . c) (or t (cond . c))) |
| 50 | ((cond (t a . b)) (if t (begin a . b))) |
| 51 | ((cond (t a . b) . c) (if t (begin a . b) (cond . c))))) |
| 52 | |
| 53 | (define-syntax case |
| 54 | (syntax-rules (else) |
| 55 | ((case (a . b) c . d) (let ((tmp5f920465446f5c2d (a . b))) |
| 56 | (case tmp5f920465446f5c2d c . d))) |
| 57 | ((case k (else a . b)) (begin a . b)) |
| 58 | ;; return unspecified when no tests pass |
| 59 | ((case k (() a . b)) '()) |
| 60 | ((case k (() a . b) c . d) (case k c . d)) |
| 61 | ((case k ((s) a . b)) (if (eqv? k 's) (begin a . b))) |
| 62 | ((case k ((s) a . b) c . d) (if (eqv? k 's) (begin a . b) |
| 63 | (case k c . d))) |
| 64 | ((case k ((s . t) a . b)) (if (memv k '(s . t)) (begin a . b))) |
| 65 | ((case k ((s . t) a . b) c . d) (if (memv k '(s . t)) (begin a . b) |
| 66 | (case k c . d))))) |
| 67 | |
| 68 | ;; SRFI 8 |
| 69 | (define-syntax receive |
| 70 | (syntax-rules () |
| 71 | ((receive names expr body . a) |
| 72 | (call-with-values (lambda () expr) (lambda names body . a))))) |
| 73 | |
| 74 | ;;; Toplevel |
| 75 | |
| 76 | (let ((prompt "GSCM> ") |
| 77 | (result-prefix " => ") |
| 78 | (*args* (eval '*args* (interaction-environment))) |
| 79 | (intr-env (interaction-environment)) |
| 80 | (error-cont #f) |
| 81 | (exit-cont #f) |
| 82 | (repl-cont #f) |
| 83 | (error-handler #f) |
| 84 | (trace-ring-length 8)) |
| 85 | |
| 86 | ;;; Various constants |
| 87 | ;; Inexact number and named char literals unsupported in bootstrap reader |
| 88 | (define flo-1 (flonum/unchecked -1)) |
| 89 | (define flo0 (flonum/unchecked 0)) |
| 90 | (define flo1 (flonum/unchecked 1)) |
| 91 | (define flo2 (flonum/unchecked 2)) |
| 92 | (define flo10 (flonum/unchecked 10)) |
| 93 | (define flo1/10 (flodiv/unchecked (flonum/unchecked 1) |
| 94 | (flonum/unchecked 10))) |
| 95 | (define flo-log-10 (log/unchecked (flonum/unchecked 10))) |
| 96 | (define nl (integer->char 10)) |
| 97 | (define sp (integer->char 32)) |
| 98 | |
| 99 | (define *fixnum-width*-1 (fx-/unchecked *fixnum-width* 1)) |
| 100 | |
| 101 | ;;; Tracing |
| 102 | ;; When a library procedure is called externally, its name is recorded in a circular log structure. On error, this is copied to a proper list and passed to the handler. Crude, perhaps, but fairly effective. (Errors signalled by builtins already include the builtin name in the message.) |
| 103 | (define trace-ring |
| 104 | (let ((head (cons #f '()))) |
| 105 | (do ((p head (cons #f p)) |
| 106 | (k 1 (fx+/wrap k 1))) |
| 107 | ((fx= k trace-ring-length) (set-cdr! head p) head)))) |
| 108 | |
| 109 | (define (clear-trace-ring) |
| 110 | (do ((p trace-ring (cdr p)) |
| 111 | (k 0 (fx+/wrap k 1))) |
| 112 | ((fx= k trace-ring-length)) |
| 113 | (set-car! p #f))) |
| 114 | |
| 115 | (define (get-trace-log) |
| 116 | (do ((p trace-ring (cdr p)) |
| 117 | (acc '() (if (car p) (cons (car p) acc) acc)) |
| 118 | (k 0 (fx+/wrap k 1))) |
| 119 | ((fx= k trace-ring-length) (reverse acc)))) |
| 120 | |
| 121 | (define (trace . args) |
| 122 | (set-car/unchecked! trace-ring args) |
| 123 | (set! trace-ring (cdr/unchecked trace-ring))) |
| 124 | |
| 125 | (define (traced-procedure name proc) |
| 126 | (lambda args (trace name) (apply/unchecked proc args))) |
| 127 | |
| 128 | (define (define-traced injector name proc) |
| 129 | (injector name (traced-procedure name proc))) |
| 130 | |
| 131 | (define (write-line val) (write val) (newline)) |
| 132 | |
| 133 | (define (print-error message args trace-log) |
| 134 | (display "ERROR: ") |
| 135 | (display message) |
| 136 | (for-each (lambda (arg) (write-char sp) (write arg)) args) |
| 137 | (newline) |
| 138 | (display "Trace log: ") |
| 139 | (write-line trace-log)) |
| 140 | |
| 141 | (define (repl) |
| 142 | (clear-trace-ring) |
| 143 | (display prompt) |
| 144 | (flush-output-port) |
| 145 | (let ((expr (read))) |
| 146 | (if (eof-object? expr) (newline) |
| 147 | (receive vals (eval expr intr-env) |
| 148 | (for-each (lambda (val) |
| 149 | (display result-prefix) |
| 150 | (write-line val)) vals) |
| 151 | (flush-output-port) |
| 152 | (repl))))) |
| 153 | |
| 154 | (define (repl-error message args trace-log) |
| 155 | (print-error message args trace-log) |
| 156 | (repl-cont '())) |
| 157 | |
| 158 | (define (exec-from-port p) |
| 159 | (do ((expr (read p) (read p)) |
| 160 | (acc '() (cons expr acc))) |
| 161 | ((eof-object? expr) |
| 162 | (close-input-port p) |
| 163 | (for-each (lambda (expr) (eval expr intr-env)) |
| 164 | (reverse acc))))) |
| 165 | |
| 166 | (define (not-integer x) (error "not an integer:" x)) |
| 167 | (define (not-list) (error "not a list")) |
| 168 | (define (not-number x) (error "not a number:" x)) |
| 169 | (define (not-exact-int x) (error "not an exact integer:" x)) |
| 170 | (define (not-output-port x) (error "not an output port:" x)) |
| 171 | (define (not-procedure x) (error "not a procedure:" x)) |
| 172 | |
| 173 | (define (too-many-args) (error "too many arguments")) |
| 174 | (define (zero-divisor) (error "zero divisor")) |
| 175 | (define (bad-radix x) (error "invalid radix:" x)) |
| 176 | (define (uneven-lists) (error "uneven lists")) |
| 177 | |
| 178 | (define (require-integer n) (if (integer? n) n (not-integer n))) |
| 179 | (define (require-procedure p) (if (procedure? p) p (not-procedure p))) |
| 180 | |
| 181 | (define (check-exact-non-negative-int k) |
| 182 | (if (cond ((fixnum? k) (fxnegative/unchecked? k)) |
| 183 | ((bignum? k) (bignum-negative? k)) |
| 184 | (else #t)) |
| 185 | (error "not an exact non-negative integer:" k))) |
| 186 | |
| 187 | (define (foldl f) |
| 188 | ;; type-safe but doesn't detect improper or cyclic list |
| 189 | (define (loop accum l) |
| 190 | (if (pair? l) (loop (f accum (car/unchecked l)) |
| 191 | (cdr/unchecked l)) |
| 192 | accum)) |
| 193 | loop) |
| 194 | |
| 195 | (define (all pred) |
| 196 | ;; type-safe but doesn't detect improper or cyclic list |
| 197 | (define (loop l) |
| 198 | (if (pair? l) (and (pred (car/unchecked l)) |
| 199 | (loop (cdr/unchecked l))) |
| 200 | #t)) |
| 201 | loop) |
| 202 | |
| 203 | (define (all-pairwise pred) |
| 204 | ;; type-safe but doesn't detect improper or cyclic list |
| 205 | (define (loop a b l) |
| 206 | (and (pred a b) |
| 207 | (if (pair? l) (loop b (car/unchecked l) (cdr/unchecked l)) |
| 208 | #t))) |
| 209 | loop) |
| 210 | |
| 211 | ;; not tail recursive |
| 212 | (define (map1 proc) |
| 213 | ;; type-safe but doesn't detect improper or cyclic list |
| 214 | (define (loop l) |
| 215 | (if (pair? l) |
| 216 | (cons (proc (car/unchecked l)) |
| 217 | (loop (cdr/unchecked l))) |
| 218 | l)) |
| 219 | loop) |
| 220 | |
| 221 | (define (copy-list l) |
| 222 | (define r (list '())) |
| 223 | (define (loop tail l) |
| 224 | (cond ((pair? l) (set-cdr/unchecked! tail (cons (car/unchecked l) '())) |
| 225 | (loop (cdr/unchecked tail) (cdr/unchecked l))) |
| 226 | ((null? l) (cdr/unchecked r)) |
| 227 | (else (not-list)))) |
| 228 | (loop r l)) |
| 229 | |
| 230 | (define (append2 x y) |
| 231 | (define r (list '())) |
| 232 | (define (loop tail x) |
| 233 | (cond ((pair? x) (set-cdr/unchecked! tail (cons (car/unchecked x) '())) |
| 234 | (loop (cdr/unchecked tail) (cdr/unchecked x))) |
| 235 | ((null? x) (set-cdr/unchecked! tail y) |
| 236 | (cdr/unchecked r)) |
| 237 | (else (not-list)))) |
| 238 | (loop r x)) |
| 239 | |
| 240 | (define (saving-values thunk after) |
| 241 | (call-with-values thunk |
| 242 | (lambda results |
| 243 | (after) |
| 244 | (apply/unchecked values results)))) |
| 245 | |
| 246 | (define (opt-args args . defaults) |
| 247 | (let loop ((acc '()) (args args) (defaults defaults)) |
| 248 | (if (pair? defaults) |
| 249 | (if (pair? args) |
| 250 | (loop (cons (car/unchecked args) acc) |
| 251 | (cdr/unchecked args) (cdr/unchecked defaults)) |
| 252 | (loop (cons (car/unchecked defaults) acc) |
| 253 | '() (cdr/unchecked defaults))) |
| 254 | (if (pair? args) (too-many-args) |
| 255 | (apply/unchecked values (reverse acc)))))) |
| 256 | |
| 257 | (define (first a . args) a) |
| 258 | (define (second a b . args) b) |
| 259 | |
| 260 | (define (fxquotient/unsigned/unchecked a b) |
| 261 | (call-with-values (lambda () (fxdiv/unsigned/unchecked a b)) first)) |
| 262 | |
| 263 | (define (fxremainder/unsigned/unchecked a b) |
| 264 | (call-with-values (lambda () (fxdiv/unsigned/unchecked a b)) second)) |
| 265 | |
| 266 | (define (fxquotient/ext/unsigned/unchecked al ah b) |
| 267 | (call-with-values |
| 268 | (lambda () (fxdiv/ext/unsigned/unchecked al ah b)) first)) |
| 269 | |
| 270 | ;;; Bignums |
| 271 | ;; |
| 272 | ;; Bignums are represented in a tagged sign-magnitude form. (I first tried two's complement but got stuck on efficient multiplication.) The magnitude is a vector of one or more fixnum words, least significant first. Bignums are normalized to drop trailing zeros or demoted to fixnum when possible. Words are considered unsigned, thus may appear negative to ordinary (signed) fixnum operations. |
| 273 | ;; |
| 274 | ;; Privileged primitives are as follows. Unless specified, all might omit type checks, and most internal bignum procedures inherit this! |
| 275 | ;; |
| 276 | ;; (MAKE-BIGNUM K) => bignum of K words |
| 277 | ;; Fixnum K is checked against the largest possible size, if any. The words may be uninitialized. |
| 278 | ;; (BIGNUM? OBJ) => boolean |
| 279 | ;; (BIGNUM-NEGATIVE? BN) => boolean |
| 280 | ;; (BIGNUM-SET-NEGATIVE! BN) => BN |
| 281 | ;; (BIGNUM-REF BN K) => word K of BN |
| 282 | ;; (BIGNUM-SET! BN K V) => unspecified, updating word K of BN to fixnum V |
| 283 | ;; (BIGNUM-LENGTH BN) => fixnum |
| 284 | ;; (BIGNUM N) => bignum of one word (not demoting) |
| 285 | ;; Constructs bignum with the value of N (signed). |
| 286 | ;; (BIGNUM/UNSIGNED N) => bignum of one word (not demoting) |
| 287 | ;; Constructs bignum with single word N |
| 288 | ;; (BIGNUM2 LO HI) => fixnum or bignum of one or two words |
| 289 | ;; Constructs bignum, demoting, from double-width signed value represented in two's complement by fixnums LO and HI. |
| 290 | ;; (BIGNUM-TRUNCATE! BN K) => bignum (not demoting) |
| 291 | ;; Returns truncation of BN to K words, possibly in-place. |
| 292 | |
| 293 | (define (fx+/promote a b) |
| 294 | (call-with-values (lambda () (fx+/carry a b)) bignum2)) |
| 295 | |
| 296 | (define (fx*/promote a b) |
| 297 | (call-with-values (lambda () (fx*/carry a b)) bignum2)) |
| 298 | |
| 299 | (define (fxneg/promote n) |
| 300 | (if (fx=/unchecked n *least-fixnum*) (bignum/unsigned n) |
| 301 | (fxneg/unchecked n))) |
| 302 | |
| 303 | (define (fxquotient/promote/unchecked a b) |
| 304 | (if (fxnegative/unchecked? b) |
| 305 | (if (fxnegative/unchecked? a) |
| 306 | (let ((q (fxquotient/unsigned/unchecked (fxneg/unchecked a) |
| 307 | (fxneg/unchecked b)))) |
| 308 | (if (fx=/unchecked q *least-fixnum*) (bignum/unsigned q) q)) |
| 309 | (fxneg/unchecked (fxquotient/unsigned/unchecked |
| 310 | a (fxneg/unchecked b)))) |
| 311 | (if (fxnegative/unchecked? a) |
| 312 | (fxneg/unchecked (fxquotient/unsigned/unchecked |
| 313 | (fxneg/unchecked a) b)) |
| 314 | (fxquotient/unsigned/unchecked a b)))) |
| 315 | |
| 316 | (define (fxremainder/unchecked a b) |
| 317 | (if (fxnegative/unchecked? b) |
| 318 | (if (fxnegative/unchecked? a) |
| 319 | (fxneg/unchecked (fxremainder/unsigned/unchecked |
| 320 | (fxneg/unchecked a) (fxneg/unchecked b))) |
| 321 | (fxremainder/unsigned/unchecked a (fxneg/unchecked b))) |
| 322 | (if (fxnegative/unchecked? a) |
| 323 | (fxneg/unchecked (fxremainder/unsigned/unchecked |
| 324 | (fxneg/unchecked a) b)) |
| 325 | (fxremainder/unsigned/unchecked a b)))) |
| 326 | |
| 327 | (define (bnneg n) |
| 328 | (let ((len (bignum-length n))) |
| 329 | (define r (make-bignum len)) |
| 330 | (define (copy k) |
| 331 | (bignum-set! r k (bignum-ref n k)) |
| 332 | (if (fx=/unchecked k 0) r (copy (fx-/unchecked k 1)))) |
| 333 | (if (bignum-negative? n) (copy (fx-/unchecked len 1)) |
| 334 | (if (and (fx=/unchecked len 1) |
| 335 | (fx=/unchecked (bignum-ref n 0) *least-fixnum*)) |
| 336 | *least-fixnum* |
| 337 | (bignum-set-negative! (copy (fx-/unchecked len 1))))))) |
| 338 | |
| 339 | (define (bignum-normalize! n) |
| 340 | (let loop ((k (fx-/unchecked (bignum-length n) 1))) |
| 341 | (cond ((fx=/unchecked k 0) |
| 342 | (let ((lo (bignum-ref n 0))) |
| 343 | (if (fxnegative/unchecked? lo) |
| 344 | ;; high bit set: fits in signed fixnum in singular case |
| 345 | (if (and (bignum-negative? n) |
| 346 | (fx=/unchecked lo *least-fixnum*)) lo |
| 347 | (bignum-truncate! n 1)) |
| 348 | ;; high bit clear: always fits in signed fixnum |
| 349 | (if (bignum-negative? n) (fxneg/unchecked lo) lo)))) |
| 350 | ((fx=/unchecked (bignum-ref n k) 0) (loop (fx-/unchecked k 1))) |
| 351 | (else (bignum-truncate! n (fx+/unchecked k 1)))))) |
| 352 | |
| 353 | (define (bignum-bit-stream n) |
| 354 | (define nwords (bignum-length n)) |
| 355 | (define (loop word seen-words bits-left) |
| 356 | (if (fx=/unchecked bits-left 0) |
| 357 | (if (fx=/unchecked seen-words nwords) '() |
| 358 | (loop (bignum-ref n seen-words) (fx+/unchecked seen-words 1) |
| 359 | *fixnum-width*)) |
| 360 | (cons (fxand word 1) |
| 361 | (delay (loop (fxshift word -1) seen-words |
| 362 | (fx-/unchecked bits-left 1)))))) |
| 363 | (loop (bignum-ref n 0) 1 *fixnum-width*)) |
| 364 | |
| 365 | (define stream-head car) |
| 366 | (define (stream-tail s) (force (cdr s))) |
| 367 | |
| 368 | (define (bn< a b) |
| 369 | (if (bignum-negative? a) |
| 370 | (if (bignum-negative? b) |
| 371 | (fxnegative/unchecked? (bncompare/unsigned b a)) |
| 372 | #t) |
| 373 | (if (bignum-negative? b) |
| 374 | #f |
| 375 | (fxnegative/unchecked? (bncompare/unsigned a b))))) |
| 376 | |
| 377 | (define (bncompare/unsigned a b) |
| 378 | (let ((alen (bignum-length a)) |
| 379 | (blen (bignum-length b))) |
| 380 | (cond ((fx=/unchecked alen blen) |
| 381 | (let loop ((k (fx-/unchecked alen 1))) |
| 382 | (if (fx=/unchecked k -1) 0 |
| 383 | (let ((ak (bignum-ref a k)) |
| 384 | (bk (bignum-ref b k))) |
| 385 | (cond ((fx=/unchecked ak bk) (loop (fx-/unchecked k 1))) |
| 386 | ((fx</unsigned ak bk) -1) |
| 387 | (else 1)))))) |
| 388 | ((fx</unsigned alen blen) -1) |
| 389 | (else 1)))) |
| 390 | |
| 391 | (define (bn= a b) |
| 392 | (and (eq? (bignum-negative? a) (bignum-negative? b)) |
| 393 | (let ((len (bignum-length a))) |
| 394 | (and (fx=/unchecked len (bignum-length b)) |
| 395 | (let loop ((k (fx-/unchecked len 1))) |
| 396 | (if (fx=/unchecked k -1) #t |
| 397 | (and (fx=/unchecked (bignum-ref a k) (bignum-ref b k)) |
| 398 | (loop (fx-/unchecked k 1))))))))) |
| 399 | |
| 400 | (define (bn+ a b) |
| 401 | (bignum-normalize! |
| 402 | (if (bignum-negative? a) |
| 403 | (if (bignum-negative? b) |
| 404 | (bignum-set-negative! (bn+/unsigned a b)) |
| 405 | (bn-/unsigned b a)) |
| 406 | (if (bignum-negative? b) |
| 407 | (bn-/unsigned a b) |
| 408 | (bn+/unsigned a b))))) |
| 409 | |
| 410 | (define (bn+/unsigned a b) |
| 411 | (if (fx</unsigned (bignum-length a) (bignum-length b)) |
| 412 | (bn+/ordered b a) |
| 413 | (bn+/ordered a b))) |
| 414 | |
| 415 | (define (bn+/ordered long short) |
| 416 | (let ((llen (bignum-length long)) |
| 417 | (slen (bignum-length short)) |
| 418 | (r (make-bignum (fx+/unchecked (bignum-length long) 1))) |
| 419 | (carry-in 0)) |
| 420 | (do ((k 0 (fx+/unchecked k 1))) ((fx=/unchecked k slen)) |
| 421 | (receive (sum carry-out) (fx+/carry-unsigned (bignum-ref long k) |
| 422 | (bignum-ref short k) |
| 423 | carry-in) |
| 424 | (bignum-set! r k sum) |
| 425 | (set! carry-in carry-out))) |
| 426 | (do ((k slen (fx+/unchecked k 1))) ((fx=/unchecked k llen)) |
| 427 | (receive (sum carry-out) (fx+/carry-unsigned (bignum-ref long k) |
| 428 | carry-in) |
| 429 | (bignum-set! r k sum) |
| 430 | (set! carry-in carry-out))) |
| 431 | (bignum-set! r llen carry-in) |
| 432 | r)) |
| 433 | |
| 434 | (define (bn- a b) |
| 435 | (bignum-normalize! |
| 436 | (if (bignum-negative? a) |
| 437 | (if (bignum-negative? b) |
| 438 | (bn-/unsigned b a) |
| 439 | (bignum-set-negative! (bn+/unsigned a b))) |
| 440 | (if (bignum-negative? b) |
| 441 | (bn+/unsigned a b) |
| 442 | (bn-/unsigned a b))))) |
| 443 | |
| 444 | (define (bn-/unsigned a b) |
| 445 | (let ((d (bncompare/unsigned a b))) |
| 446 | (cond ((fxnegative/unchecked? d) |
| 447 | (bignum-set-negative! (bn-/ordered b a))) |
| 448 | ((fx=/unchecked d 0) (bignum/unsigned 0)) |
| 449 | (else (bn-/ordered a b))))) |
| 450 | |
| 451 | (define (bn-/ordered large small) |
| 452 | (let ((llen (bignum-length large)) |
| 453 | (slen (bignum-length small)) |
| 454 | (r (make-bignum (bignum-length large))) |
| 455 | (borrow-in 0)) |
| 456 | (do ((k 0 (fx+/unchecked k 1))) ((fx=/unchecked k slen)) |
| 457 | (receive (diff borrow-out) (fx-/borrow-unsigned (bignum-ref large k) |
| 458 | (bignum-ref small k) |
| 459 | borrow-in) |
| 460 | (bignum-set! r k diff) |
| 461 | (set! borrow-in borrow-out))) |
| 462 | (do ((k slen (fx+/unchecked k 1))) ((fx=/unchecked k llen)) |
| 463 | (receive (diff borrow-out) (fx-/borrow-unsigned (bignum-ref large k) |
| 464 | borrow-in) |
| 465 | (bignum-set! r k diff) |
| 466 | (set! borrow-in borrow-out))) |
| 467 | r)) |
| 468 | |
| 469 | (define (bn* a b) |
| 470 | (bignum-normalize! |
| 471 | (if (eq? (bignum-negative? a) (bignum-negative? b)) |
| 472 | (bn*/unsigned a b) |
| 473 | (bignum-set-negative! (bn*/unsigned a b))))) |
| 474 | |
| 475 | (define (bn*/unsigned a b) |
| 476 | (if (fx</unsigned (bignum-length a) (bignum-length b)) |
| 477 | (bn*/comba b a) |
| 478 | (bn*/comba a b))) |
| 479 | |
| 480 | ;; Comba's algorithm: base case (quadratic) multiply that avoids excess carrying and temporary allocation by proceeding column-wise. http://www.loper-os.org/?p=2186 |
| 481 | (define (bn*/comba long short) |
| 482 | (define llen (bignum-length long)) |
| 483 | (define slen (bignum-length short)) |
| 484 | (define rlen #f) |
| 485 | (define r #f) |
| 486 | ;; Intra-column accumulator / inter-column carry. Three words are enough as at most SLEN two-word terms are summed, and SLEN fits in a word. |
| 487 | (define acc0 0) |
| 488 | (define acc1 0) |
| 489 | (define acc2 0) |
| 490 | (define (column col start stop) |
| 491 | (do ((k start (fx+/unchecked k 1))) ((fx=/unchecked k stop)) |
| 492 | (receive (lo hi) (fx*/carry-unsigned |
| 493 | (bignum-ref long (fx-/unchecked col k)) |
| 494 | (bignum-ref short k)) |
| 495 | (receive (sum c) (fx+/carry-unsigned acc0 lo) |
| 496 | (set! acc0 sum) |
| 497 | (receive (sum c) (fx+/carry-unsigned acc1 hi c) |
| 498 | (set! acc1 sum) |
| 499 | (set! acc2 (fx+/unchecked acc2 c)))))) |
| 500 | (bignum-set! r col acc0) |
| 501 | ;; down-shift for carry-in to the next column |
| 502 | (set! acc0 acc1) |
| 503 | (set! acc1 acc2) |
| 504 | (set! acc2 0)) |
| 505 | (define (loop-lo col) |
| 506 | (if (fx=/unchecked col slen) (loop-mid col) |
| 507 | (let ((col+1 (fx+/unchecked col 1))) |
| 508 | (column col 0 col+1) |
| 509 | (loop-lo col+1)))) |
| 510 | (define (loop-mid col) ;; for when lengths differ |
| 511 | (if (fx=/unchecked col llen) (loop-hi col) |
| 512 | (begin (column col 0 slen) |
| 513 | (loop-mid (fx+/unchecked col 1))))) |
| 514 | (define (loop-hi col) |
| 515 | (if (fx=/unchecked col rlen) r |
| 516 | (let ((col+1 (fx+/unchecked col 1))) |
| 517 | (column col (fx-/unchecked col+1 llen) slen) |
| 518 | (loop-hi col+1)))) |
| 519 | (set! rlen (fx+/unchecked llen slen)) |
| 520 | (set! r (make-bignum rlen)) |
| 521 | (loop-lo 0)) |
| 522 | |
| 523 | ;; High-radix restoring division: Algorithm 1.6 BasecaseDivRem from Richard P. Brent and Paul Zimmerman, "Modern Computer Arithmetic", 2010. |
| 524 | (define (bndiv A B) |
| 525 | (define n (bignum-length B)) ;; divisor length |
| 526 | (define m #f) ;; dividend-divisor length difference |
| 527 | (define Bn-1 #f) ;; high word of divisor |
| 528 | (define norm-shift #f) ;; bit shift for normalization step |
| 529 | (define Q #f) ;; quotient of m+1 words |
| 530 | (define j #f) ;; index of quotient word being computed |
| 531 | (define Qj #f) ;; guessed quotient word |
| 532 | (define n+j #f) ;; index of high word of reduced divisor |
| 533 | (define QjB #f) ;; product of divisor by guessed quotient word |
| 534 | |
| 535 | ;; Specialized scalar multiply, shifted comparison, shifted subtract-in-place, and sub-word shift operations for performance. |
| 536 | (define (mul-Qj k carry) |
| 537 | (if (fx=/unchecked k n) (bignum-set! QjB k carry) |
| 538 | (receive (prod-lo prod-hi) (fx*/carry-unsigned (bignum-ref B k) Qj) |
| 539 | (receive (sum carry) (fx+/carry-unsigned prod-lo carry) |
| 540 | (bignum-set! QjB k sum) |
| 541 | (mul-Qj (fx+/unchecked k 1) |
| 542 | (fx+/unchecked prod-hi carry)))))) |
| 543 | (define (A< X shift) |
| 544 | (let loop ((k (fx-/unchecked (bignum-length X) 1))) |
| 545 | (if (fx=/unchecked k -1) #f |
| 546 | (let ((Ak+shift (bignum-ref A (fx+/unchecked k shift))) |
| 547 | (Xk (bignum-ref X k))) |
| 548 | (cond ((fx</unsigned Ak+shift Xk) #t) |
| 549 | ((fx=/unchecked Ak+shift Xk) (loop (fx-/unchecked k 1))) |
| 550 | (else #f)))))) |
| 551 | (define (sub-in-place X Y shift) |
| 552 | (define len (bignum-length Y)) |
| 553 | (define k 0) |
| 554 | (define k+shift shift) |
| 555 | (define (loop borrow) |
| 556 | (if (fx=/unchecked k len) |
| 557 | (if (fx=/unchecked borrow 1) |
| 558 | (let ((Xk+shift (bignum-ref X k+shift))) |
| 559 | (if (fx=/unchecked Xk+shift 0) |
| 560 | (error "BUG: sub-in-place underflow")) |
| 561 | (bignum-set! X k+shift (fx-/unchecked Xk+shift 1)))) |
| 562 | (receive (diff borrow) (fx-/borrow-unsigned |
| 563 | (bignum-ref X k+shift) |
| 564 | (bignum-ref Y k) |
| 565 | borrow) |
| 566 | (bignum-set! X k+shift diff) |
| 567 | (set! k (fx+/unchecked k 1)) |
| 568 | (set! k+shift (fx+/unchecked k+shift 1)) |
| 569 | (loop borrow)))) |
| 570 | (loop 0)) |
| 571 | (define (shift-up X) |
| 572 | (define r (make-bignum (fx+/unchecked (bignum-length X) 1))) |
| 573 | (define len (bignum-length X)) |
| 574 | (define complement (fx-/unchecked norm-shift *fixnum-width*)) |
| 575 | (define k 0) |
| 576 | (define carry 0) |
| 577 | (define (loop) |
| 578 | (if (fx=/unchecked k len) |
| 579 | (if (fx=/unchecked carry 0) (bignum-truncate! r len) |
| 580 | (begin (bignum-set! r k carry) r)) |
| 581 | (let ((word (bignum-ref X k))) |
| 582 | (bignum-set! r k (fxior carry (fxshift/unsigned word |
| 583 | norm-shift))) |
| 584 | (set! carry (fxshift/unsigned word complement)) |
| 585 | (set! k (fx+/unchecked k 1)) |
| 586 | (loop)))) |
| 587 | (loop)) |
| 588 | (define (shift-down-in-place X) |
| 589 | (define neg-bits (fxneg/unchecked norm-shift)) |
| 590 | (define complement (fx-/unchecked *fixnum-width* norm-shift)) |
| 591 | (define k (fx-/unchecked (bignum-length X) 1)) |
| 592 | (define carry 0) |
| 593 | (define (loop) |
| 594 | (if (fx=/unchecked k -1) '() |
| 595 | (let ((word (bignum-ref X k))) |
| 596 | (bignum-set! X k (fxior carry (fxshift/unsigned word |
| 597 | neg-bits))) |
| 598 | (set! carry (fxshift/unsigned word complement)) |
| 599 | (set! k (fx-/unchecked k 1)) |
| 600 | (loop)))) |
| 601 | (loop)) |
| 602 | |
| 603 | ;; Long division proper |
| 604 | (define (loop-j) |
| 605 | (if (fxnegative/unchecked? j) '() |
| 606 | (begin (set! n+j (fx+/unchecked n j)) |
| 607 | (set! Qj (if (fx<=/unsigned Bn-1 (bignum-ref A n+j)) -1 |
| 608 | ;; ^ I think the < case is impossible |
| 609 | (fxquotient/ext/unsigned/unchecked |
| 610 | (bignum-ref A (fx+/unchecked n+j -1)) |
| 611 | (bignum-ref A n+j) |
| 612 | Bn-1))) |
| 613 | (mul-Qj 0 0) |
| 614 | (check-Qj)))) |
| 615 | (define (check-Qj) |
| 616 | (if (A< QjB j) |
| 617 | (begin (set! Qj (fx-/unchecked Qj 1)) |
| 618 | (sub-in-place QjB B 0) |
| 619 | (check-Qj)) |
| 620 | (begin (bignum-set! Q j Qj) |
| 621 | (sub-in-place A QjB j) |
| 622 | (if (not (fx=/unchecked (bignum-ref A n+j) 0)) |
| 623 | (error "BUG: remainder not reduced")) |
| 624 | (set! j (fx-/unchecked j 1)) |
| 625 | (loop-j)))) |
| 626 | |
| 627 | ;; Normalize: scale inputs so high bit of divisor is 1 |
| 628 | (set! norm-shift (fx-/unchecked *fixnum-width* |
| 629 | (fxlength/unsigned |
| 630 | (bignum-ref B (fx-/unchecked n 1))))) |
| 631 | (if (fx=/unchecked norm-shift *fixnum-width*) (zero-divisor)) |
| 632 | (set! A (shift-up A)) ;; copying A enables mutation |
| 633 | (set! B (shift-up B)) |
| 634 | (set! Bn-1 (bignum-ref B (fx-/unchecked n 1))) |
| 635 | |
| 636 | (set! m (fx-/unchecked (bignum-length A) n)) |
| 637 | (if (fxnegative/unchecked? m) (set! Q (bignum/unsigned 0)) |
| 638 | (begin (set! Q (make-bignum (fx+/unchecked m 1))) |
| 639 | (if (not (eq? (bignum-negative? A) (bignum-negative? B))) |
| 640 | (bignum-set-negative! Q)) |
| 641 | (if (A< B m) (bignum-set! Q m 0) |
| 642 | (begin (bignum-set! Q m 1) |
| 643 | (sub-in-place A B m))) |
| 644 | (set! QjB (make-bignum (fx+/unchecked n 1))) |
| 645 | (set! j (fx-/unchecked m 1)) |
| 646 | (loop-j) |
| 647 | ;; save looping over leading zeros, assuming truncate-in-place |
| 648 | (bignum-truncate! A n))) |
| 649 | (shift-down-in-place A) |
| 650 | (values (bignum-normalize! Q) (bignum-normalize! A))) |
| 651 | |
| 652 | (define (bnquotient a b) |
| 653 | (call-with-values (lambda () (bndiv a b)) first)) |
| 654 | |
| 655 | (define (bnremainder a b) |
| 656 | (call-with-values (lambda () (bndiv a b)) second)) |
| 657 | |
| 658 | (define flo-bn-radix (delay (flo*/unchecked flo2 (flonum/unsigned/unchecked |
| 659 | *least-fixnum*)))) |
| 660 | (define flo-log-bn-radix (delay (log/unchecked flo-bn-radix))) |
| 661 | |
| 662 | (define (bignum->flonum n) |
| 663 | (define len (bignum-length n)) |
| 664 | (define (loop k acc bits) |
| 665 | (cond ((fx=/unchecked k -1) acc) |
| 666 | ((fx<=/unchecked 53 bits) ;; significant bits in IEEE 754 double |
| 667 | ;; TODO use LOAD-EXPONENT/UNCHECKED, but beware of fixnum overflow in computing exponent |
| 668 | (flo*/unchecked |
| 669 | acc (exp/unchecked (flo*/unchecked |
| 670 | (flonum/unchecked (fx+/unchecked k 1)) |
| 671 | flo-log-bn-radix)))) |
| 672 | (else (loop (fx-/unchecked k 1) |
| 673 | (flo+/unchecked (flo*/unchecked acc flo-bn-radix) |
| 674 | (flonum/unsigned/unchecked |
| 675 | (bignum-ref n k))) |
| 676 | (fx+/unchecked bits *fixnum-width*))))) |
| 677 | (let ((r (loop (fx-/unchecked len 2) |
| 678 | (flonum/unsigned/unchecked |
| 679 | (bignum-ref n (fx-/unchecked len 1))) |
| 680 | 1))) ;; high word might only have one significant bit |
| 681 | (if (bignum-negative? n) (floneg/unchecked r) r))) |
| 682 | |
| 683 | ;; Convert nonzero bignum to minimal list of digits in a smaller power-of-two radix, least significant first, "reflowing" in linear time. |
| 684 | (define (bignum->digits n bits) |
| 685 | (define len (bignum-length n)) |
| 686 | (define mask (fx-/unchecked (fxshift 1 bits) 1)) |
| 687 | (define acc '()) |
| 688 | (define (push! digit) |
| 689 | (set! acc (cons (fxand mask digit) acc))) |
| 690 | (define (loop word bit) |
| 691 | (if (fx</unchecked word len) |
| 692 | (let ((low-bits (fxshift/unsigned (bignum-ref n word) |
| 693 | (fxneg/unchecked bit))) |
| 694 | (next-bit (fx+/unchecked bit bits)) |
| 695 | (next-word (fx+/unchecked word 1))) |
| 696 | (if (fx</unchecked *fixnum-width* next-bit) |
| 697 | ;; Join slices from adjacent words... |
| 698 | (if (fx</unchecked next-word len) |
| 699 | (begin (push! (fxior low-bits |
| 700 | (fxshift (bignum-ref n next-word) |
| 701 | (fx-/unchecked |
| 702 | *fixnum-width* bit)))) |
| 703 | (loop next-word (fx-/unchecked |
| 704 | next-bit *fixnum-width*))) |
| 705 | ;; unless this is the last word... |
| 706 | (push! low-bits)) |
| 707 | ;; or digit is entirely in the current word. |
| 708 | (begin (push! low-bits) |
| 709 | (if (fx=/unchecked next-bit *fixnum-width*) |
| 710 | (loop next-word 0) |
| 711 | (loop word next-bit))))))) |
| 712 | (loop 0 0) |
| 713 | ;; Strip leading zeros |
| 714 | (do ((acc acc (cdr/unchecked acc))) |
| 715 | ((fx</unsigned 0 (car/unchecked acc)) (reverse acc)))) |
| 716 | |
| 717 | (define (extend-padded acc chunk width) |
| 718 | (cons (make-string (fx-/unchecked width (string-length chunk)) #\0) |
| 719 | (cons chunk acc))) |
| 720 | |
| 721 | (define (press-num-string neg chunks) |
| 722 | (apply/unchecked string-append (if neg (cons "-" chunks) chunks))) |
| 723 | |
| 724 | (define dec-chunk-digits (delay (quotient (* *fixnum-width*-1 3) 10))) |
| 725 | (define dec-chunk-radix (delay (bignum (expt 10 dec-chunk-digits)))) |
| 726 | |
| 727 | (define (bignum->dec n) |
| 728 | ;; Quadratic (repeated division by fixnum constant) |
| 729 | (define (loop acc n) |
| 730 | (cond ((bignum? n) |
| 731 | (receive (q r) (bndiv n dec-chunk-radix) |
| 732 | (loop (extend-padded acc (fixnum->dec/unchecked r) |
| 733 | dec-chunk-digits) |
| 734 | q))) |
| 735 | ((fx=/unchecked n 0) acc) |
| 736 | (else (cons (fixnum->dec/unchecked n) acc)))) |
| 737 | (let ((neg (bignum-negative? n))) |
| 738 | (press-num-string neg (loop '() (if neg (bnneg n) n))))) |
| 739 | |
| 740 | (define hex-chunk-digits (delay (quotient *fixnum-width*-1 4))) |
| 741 | (define hex-chunk-bits (delay (* hex-chunk-digits 4))) |
| 742 | |
| 743 | (define (bignum->hex n) |
| 744 | (do ((digits (bignum->digits n hex-chunk-bits) (cdr/unchecked digits)) |
| 745 | (acc '() (extend-padded |
| 746 | acc (fixnum->hex/unchecked (car/unchecked digits)) |
| 747 | hex-chunk-digits))) |
| 748 | ((null? (cdr/unchecked digits)) |
| 749 | (press-num-string |
| 750 | (bignum-negative? n) |
| 751 | (cons (fixnum->hex/unchecked (car/unchecked digits)) acc))))) |
| 752 | |
| 753 | (define oct-chunk-digits (delay (quotient *fixnum-width*-1 3))) |
| 754 | (define oct-chunk-bits (delay (fx*/wrap 3 oct-chunk-digits))) |
| 755 | |
| 756 | (define (bignum->oct n) |
| 757 | (do ((digits (bignum->digits n oct-chunk-bits) (cdr/unchecked digits)) |
| 758 | (acc '() (extend-padded |
| 759 | acc (fixnum->oct/unchecked (car/unchecked digits)) |
| 760 | oct-chunk-digits))) |
| 761 | ((null? (cdr/unchecked digits)) |
| 762 | (press-num-string |
| 763 | (bignum-negative? n) |
| 764 | (cons (fixnum->oct/unchecked (car/unchecked digits)) acc))))) |
| 765 | |
| 766 | (define (bignum->bin n) |
| 767 | (define len-1 (fx-/unchecked (bignum-length n) 1)) |
| 768 | (define (loop k acc) |
| 769 | (if (fx=/unchecked k len-1) |
| 770 | (cons (fixnum->bin/unsigned/unchecked (bignum-ref n k)) acc) |
| 771 | (loop (fx+/unchecked k 1) |
| 772 | (extend-padded acc (fixnum->bin/unsigned/unchecked |
| 773 | (bignum-ref n k)) |
| 774 | *fixnum-width*)))) |
| 775 | (press-num-string (bignum-negative? n) (loop 0 '()))) |
| 776 | |
| 777 | ;;; Procedure library |
| 778 | |
| 779 | ;;; 6.1 Equivalence predicates |
| 780 | |
| 781 | (define (eqv? a b) |
| 782 | (cond ((eq? a b) #t) |
| 783 | ;; char and fixnum covered by EQ? (implementation dependent) |
| 784 | ((bignum? a) (and (bignum? b) (bn= a b))) |
| 785 | ;; exactness must match |
| 786 | ((flonum? a) (and (flonum? b) (flo=/unchecked a b))) |
| 787 | (else #f))) |
| 788 | |
| 789 | (define (vector=? a b) |
| 790 | (define len (vector-length a)) |
| 791 | (define (loop k) |
| 792 | (if (fx=/unchecked k len) #t |
| 793 | (and (equal? (vector-ref/unchecked a k) (vector-ref/unchecked b k)) |
| 794 | (loop (fx+/unchecked k 1))))) |
| 795 | (and (fx=/unchecked len (vector-length b)) |
| 796 | (loop 0))) |
| 797 | |
| 798 | (define (equal? a b) |
| 799 | (cond ((eqv? a b) #t) |
| 800 | ((pair? a) (and (pair? b) |
| 801 | (equal? (car/unchecked a) (car/unchecked b)) |
| 802 | (equal? (cdr/unchecked a) (cdr/unchecked b)))) |
| 803 | ((vector? a) (and (vector? b) (vector=? a b))) |
| 804 | ((string? a) (and (string? b) (string=? a b))) |
| 805 | (else #f))) |
| 806 | |
| 807 | ;;; 6.2.5 Numerical operations |
| 808 | |
| 809 | (define (exp10/flonum x) |
| 810 | (exp/unchecked (flo*/unchecked flo-log-10 x))) |
| 811 | |
| 812 | ;; For comparisons of mixed exactness to be transitive, arguments must not be converted inexactly (e.g. "promoting" to flonum) if this could cause the result to differ from a true comparison of the represented values. |
| 813 | |
| 814 | (define (=/mixed flonum exact-int) |
| 815 | (and (integer? flonum) |
| 816 | (not (inf/unchecked? flonum)) |
| 817 | (=/generic (inexact->exact flonum) exact-int))) |
| 818 | |
| 819 | (define (</mixed flonum exact-int) |
| 820 | (if (inf/unchecked? flonum) (flonegative/unchecked? flonum) |
| 821 | (</generic (inexact->exact (floor/unchecked flonum)) exact-int))) |
| 822 | |
| 823 | (define (>/mixed flonum exact-int) |
| 824 | (if (inf/unchecked? flonum) (not (flonegative/unchecked? flonum)) |
| 825 | (>/generic (inexact->exact (ceiling/unchecked flonum)) exact-int))) |
| 826 | |
| 827 | (define (<=/mixed flonum exact-int) |
| 828 | (if (inf/unchecked? flonum) (flonegative/unchecked? flonum) |
| 829 | (<=/generic (inexact->exact (ceiling/unchecked flonum)) exact-int))) |
| 830 | |
| 831 | (define (>=/mixed flonum exact-int) |
| 832 | (if (inf/unchecked? flonum) (not (flonegative/unchecked? flonum)) |
| 833 | (>=/generic (inexact->exact (floor/unchecked flonum)) exact-int))) |
| 834 | |
| 835 | ;; The convention for 2-arg generics is to dispatch on the type of the second argument first, as some operations (subtraction, division) do special things based on it but not the first. |
| 836 | |
| 837 | (define (=/fixnum z fx) |
| 838 | (cond ((fixnum? z) (fx=/unchecked z fx)) |
| 839 | ((bignum? z) #f) ;; assuming demotion |
| 840 | ((flonum? z) (=/mixed z fx)) |
| 841 | (else (not-number z)))) |
| 842 | |
| 843 | (define (</fixnum x fx) |
| 844 | (cond ((fixnum? x) (fx</unchecked x fx)) |
| 845 | ((bignum? x) (bignum-negative? x)) ;; assuming demotion |
| 846 | ((flonum? x) (</mixed x fx)) |
| 847 | (else (not-number x)))) |
| 848 | |
| 849 | (define (<=/fixnum x fx) |
| 850 | (cond ((fixnum? x) (fx<=/unchecked x fx)) |
| 851 | ((bignum? x) (bignum-negative? x)) ;; assuming demotion |
| 852 | ((flonum? x) (<=/mixed x fx)) |
| 853 | (else (not-number x)))) |
| 854 | |
| 855 | (define (=/bignum z bn) |
| 856 | (cond ((fixnum? z) #f) ;; assuming demotion |
| 857 | ((bignum? z) (bn= z bn)) |
| 858 | ((flonum? z) (=/mixed z bn)) |
| 859 | (else (not-number z)))) |
| 860 | |
| 861 | (define (</bignum x bn) |
| 862 | (cond ((fixnum? x) (not (bignum-negative? bn))) ;; assuming demotion |
| 863 | ((bignum? x) (bn< x bn)) |
| 864 | ((flonum? x) (</mixed x bn)) |
| 865 | (else (not-number x)))) |
| 866 | |
| 867 | (define (<=/bignum x bn) |
| 868 | (cond ((fixnum? x) (not (bignum-negative? bn))) ;; assuming demotion |
| 869 | ((bignum? x) (not (bn< bn x))) ;; reversing |
| 870 | ((flonum? x) (<=/mixed x bn)) |
| 871 | (else (not-number x)))) |
| 872 | |
| 873 | (define (=/flonum z fl) |
| 874 | (cond ((flonum? z) (flo=/unchecked z fl)) |
| 875 | ((integer? z) (=/mixed fl z)) ;; reversing |
| 876 | (else (not-number z)))) |
| 877 | |
| 878 | (define (</flonum x fl) |
| 879 | (cond ((flonum? x) (flo</unchecked x fl)) |
| 880 | ((integer? x) (>/mixed fl x)) ;; reversing |
| 881 | (else (not-number x)))) |
| 882 | |
| 883 | (define (<=/flonum x fl) |
| 884 | (cond ((flonum? x) (flo<=/unchecked x fl)) |
| 885 | ((integer? x) (>=/mixed fl x)) ;; reversing |
| 886 | (else (not-number x)))) |
| 887 | |
| 888 | (define (=/generic z1 z2) |
| 889 | (cond ((fixnum? z2) (=/fixnum z1 z2)) |
| 890 | ((bignum? z2) (=/bignum z1 z2)) |
| 891 | ((flonum? z2) (=/flonum z1 z2)) |
| 892 | (else (not-number z2)))) |
| 893 | |
| 894 | (define (</generic x1 x2) |
| 895 | (cond ((fixnum? x2) (</fixnum x1 x2)) |
| 896 | ((bignum? x2) (</bignum x1 x2)) |
| 897 | ((flonum? x2) (</flonum x1 x2)) |
| 898 | (else (not-number x2)))) |
| 899 | |
| 900 | (define (>/generic x1 x2) ;; reversing dispatch order |
| 901 | (cond ((fixnum? x1) (</fixnum x2 x1)) |
| 902 | ((bignum? x1) (</bignum x2 x1)) |
| 903 | ((flonum? x1) (</flonum x2 x1)) |
| 904 | (else (not-number x1)))) |
| 905 | |
| 906 | (define (<=/generic x1 x2) |
| 907 | (cond ((fixnum? x2) (<=/fixnum x1 x2)) |
| 908 | ((bignum? x2) (<=/bignum x1 x2)) |
| 909 | ((flonum? x2) (<=/flonum x1 x2)) |
| 910 | (else (not-number x2)))) |
| 911 | |
| 912 | (define (>=/generic x1 x2) ;; reversing dispatch order |
| 913 | (cond ((fixnum? x1) (<=/fixnum x2 x1)) |
| 914 | ((bignum? x1) (<=/bignum x2 x1)) |
| 915 | ((flonum? x1) (<=/flonum x2 x1)) |
| 916 | (else (not-number x1)))) |
| 917 | |
| 918 | (define =* (delay (all-pairwise =/generic))) |
| 919 | (define <* (delay (all-pairwise </generic))) |
| 920 | (define >* (delay (all-pairwise >/generic))) |
| 921 | (define <=* (delay (all-pairwise <=/generic))) |
| 922 | (define >=* (delay (all-pairwise >=/generic))) |
| 923 | |
| 924 | (define (= z1 z2 . zs) (=* z1 z2 zs)) |
| 925 | (define (< x1 x2 . xs) (<* x1 x2 xs)) |
| 926 | (define (> x1 x2 . xs) (>* x1 x2 xs)) |
| 927 | (define (<= x1 x2 . xs) (<=* x1 x2 xs)) |
| 928 | (define (>= x1 x2 . xs) (>=* x1 x2 xs)) |
| 929 | |
| 930 | (define (zero? z) |
| 931 | (cond ((fixnum? z) (fx=/unchecked z 0)) |
| 932 | ((bignum? z) #f) |
| 933 | ((flonum? z) (flo=/unchecked z flo0)) |
| 934 | (else (not-number z)))) |
| 935 | |
| 936 | (define (positive? x) |
| 937 | (cond ((fixnum? x) (fx</unchecked 0 x)) |
| 938 | ((bignum? x) (not (bignum-negative? x))) |
| 939 | ((flonum? x) (flo</unchecked flo0 x)) |
| 940 | (else (not-number x)))) |
| 941 | |
| 942 | (define (negative? x) |
| 943 | (cond ((fixnum? x) (fxnegative/unchecked? x)) |
| 944 | ((bignum? x) (bignum-negative? x)) |
| 945 | ((flonum? x) (flonegative/unchecked? x)) |
| 946 | (else (not-number x)))) |
| 947 | |
| 948 | (define (odd? n) |
| 949 | (cond ((fixnum? n) (fx=/unchecked (fxand n 1) 1)) |
| 950 | ((bignum? n) (fx=/unchecked (fxand (bignum-ref n 0) 1) 1)) |
| 951 | ((flonum? n) (flo=/unchecked (floremainder/unchecked |
| 952 | (if (flonegative/unchecked? n) |
| 953 | (floneg/unchecked n) n) flo2) |
| 954 | flo1)) |
| 955 | (else (not-number n)))) |
| 956 | |
| 957 | (define (even? n) |
| 958 | (cond ((fixnum? n) (fx=/unchecked (fxand n 1) 0)) |
| 959 | ((bignum? n) (fx=/unchecked (fxand (bignum-ref n 0) 1) 0)) |
| 960 | ((flonum? n) (flo=/unchecked (floremainder/unchecked n flo2) flo0)) |
| 961 | (else (not-number n)))) |
| 962 | |
| 963 | (define (flonum/generic x) |
| 964 | (cond ((fixnum? x) (flonum/unchecked x)) |
| 965 | ((bignum? x) (bignum->flonum x)) |
| 966 | ((flonum? x) x) |
| 967 | (else (not-number x)))) |
| 968 | |
| 969 | (define (max2 x1 x2) |
| 970 | (cond ((flonum? x1) (flonum/generic (if (</flonum x2 x1) x1 x2))) |
| 971 | ((flonum? x2) (flonum/generic (if (</flonum x1 x2) x2 x1))) |
| 972 | (else (if (</generic x1 x2) x2 x1)))) |
| 973 | |
| 974 | (define (min2 x1 x2) |
| 975 | (cond ((flonum? x1) (flonum/generic (if (</flonum x2 x1) x2 x1))) |
| 976 | ((flonum? x2) (flonum/generic (if (</flonum x1 x2) x1 x2))) |
| 977 | (else (if (</generic x1 x2) x1 x2)))) |
| 978 | |
| 979 | (define max* (delay (foldl max2))) |
| 980 | (define min* (delay (foldl min2))) |
| 981 | |
| 982 | (define (max x1 . xs) (max* x1 xs)) |
| 983 | (define (min x1 . xs) (min* x1 xs)) |
| 984 | |
| 985 | ;; Common dispatch patterns based on type promotion |
| 986 | |
| 987 | (define (dispatch-fixnum fx-op bn-op flo-op) |
| 988 | (lambda (z fx) |
| 989 | (cond ((fixnum? z) (fx-op z fx)) |
| 990 | ((bignum? z) (bn-op z (bignum fx))) |
| 991 | ((flonum? z) (flo-op z (flonum/unchecked fx))) |
| 992 | (else (not-number z))))) |
| 993 | |
| 994 | (define (dispatch-bignum bn-op flo-op) |
| 995 | (lambda (z bn) |
| 996 | (cond ((fixnum? z) (bn-op (bignum z) bn)) |
| 997 | ((bignum? z) (bn-op z bn)) |
| 998 | ((flonum? z) (flo-op z (bignum->flonum bn))) |
| 999 | (else (not-number z))))) |
| 1000 | |
| 1001 | (define (dispatch-num2 fx-op bn-op flo-op) |
| 1002 | (let ((dfx (dispatch-fixnum fx-op bn-op flo-op)) |
| 1003 | (dbn (dispatch-bignum bn-op flo-op))) |
| 1004 | (lambda (z1 z2) |
| 1005 | (cond ((fixnum? z2) (dfx z1 z2)) |
| 1006 | ((bignum? z2) (dbn z1 z2)) |
| 1007 | ((flonum? z2) (flo-op (flonum/generic z1) z2)) |
| 1008 | (else (not-number z2)))))) |
| 1009 | |
| 1010 | (define add2 (delay (dispatch-num2 fx+/promote bn+ flo+/unchecked))) |
| 1011 | (define mul2 (delay (dispatch-num2 fx*/promote bn* flo*/unchecked))) |
| 1012 | |
| 1013 | (define sub/bignum (delay (dispatch-bignum bn- flo-/unchecked))) |
| 1014 | |
| 1015 | (define (sub2 z1 z2) |
| 1016 | (cond ((fixnum? z2) (add2 z1 (fxneg/promote z2))) |
| 1017 | ((bignum? z2) (sub/bignum z1 z2)) |
| 1018 | ((flonum? z2) (flo-/unchecked (flonum/generic z1) z2)) |
| 1019 | (else (not-number z2)))) |
| 1020 | |
| 1021 | (define (div2 z1 z2) |
| 1022 | (flodiv/unchecked |
| 1023 | (flonum/generic z1) |
| 1024 | (cond ((fixnum? z2) (if (fx=/unchecked z2 0) (zero-divisor) |
| 1025 | (flonum/unchecked z2))) |
| 1026 | ((bignum? z2) (bignum->flonum z2)) |
| 1027 | ((flonum? z2) (if (flo=/unchecked z2 flo0) (zero-divisor) z2)) |
| 1028 | (else (not-number z2))))) |
| 1029 | |
| 1030 | (define add* (delay (foldl add2))) |
| 1031 | (define mul* (delay (foldl mul2))) |
| 1032 | (define sub* (delay (foldl sub2))) |
| 1033 | (define div* (delay (foldl div2))) |
| 1034 | |
| 1035 | (define (+ . zs) |
| 1036 | (if (pair? zs) (add* (car/unchecked zs) (cdr/unchecked zs)) 0)) |
| 1037 | |
| 1038 | (define (* . zs) |
| 1039 | (if (pair? zs) (mul* (car/unchecked zs) (cdr/unchecked zs)) 1)) |
| 1040 | |
| 1041 | (define (- z . zs) |
| 1042 | (cond ((pair? zs) (sub* (sub2 z (car/unchecked zs)) |
| 1043 | (cdr/unchecked zs))) |
| 1044 | ((fixnum? z) (fxneg/promote z)) |
| 1045 | ((bignum? z) (bnneg z)) |
| 1046 | ((flonum? z) (floneg/unchecked z)) |
| 1047 | (else (not-number z)))) |
| 1048 | |
| 1049 | (define (/ z . zs) |
| 1050 | (if (pair? zs) (div* (div2 z (car/unchecked zs)) |
| 1051 | (cdr/unchecked zs)) |
| 1052 | (div2 flo1 z))) |
| 1053 | |
| 1054 | (define (abs x) |
| 1055 | (cond ((fixnum? x) (if (fxnegative/unchecked? x) (fxneg/promote x) x)) |
| 1056 | ((bignum? x) (if (bignum-negative? x) (bnneg x) x)) |
| 1057 | ((flonum? x) (if (flonegative/unchecked? x) (floneg/unchecked x) |
| 1058 | x)) |
| 1059 | (else (not-number x)))) |
| 1060 | |
| 1061 | (define (floquotient/int/unchecked n1 n2) |
| 1062 | (floquotient/unchecked (require-integer n1) (require-integer n2))) |
| 1063 | |
| 1064 | (define (floremainder/int/unchecked n1 n2) |
| 1065 | (floremainder/unchecked (require-integer n1) (require-integer n2))) |
| 1066 | |
| 1067 | (define quotient/fixnum |
| 1068 | (delay (dispatch-fixnum fxquotient/promote/unchecked bnquotient |
| 1069 | floquotient/int/unchecked))) |
| 1070 | |
| 1071 | (define quotient/bignum |
| 1072 | (delay (dispatch-bignum bnquotient floquotient/int/unchecked))) |
| 1073 | |
| 1074 | (define remainder/fixnum |
| 1075 | (delay (dispatch-fixnum fxremainder/unchecked bnremainder |
| 1076 | floremainder/int/unchecked))) |
| 1077 | |
| 1078 | (define remainder/bignum |
| 1079 | (delay (dispatch-bignum bnremainder floremainder/int/unchecked))) |
| 1080 | |
| 1081 | (define (quotient n1 n2) |
| 1082 | (cond ((fixnum? n2) |
| 1083 | (if (fx=/unchecked n2 0) (zero-divisor) (quotient/fixnum n1 n2))) |
| 1084 | ((bignum? n2) (quotient/bignum n1 n2)) |
| 1085 | ((flonum? n2) |
| 1086 | (if (flo=/unchecked n2 flo0) (zero-divisor) |
| 1087 | (floquotient/int/unchecked (flonum/generic n1) n2))) |
| 1088 | (else (not-integer n2)))) |
| 1089 | |
| 1090 | (define (remainder n1 n2) |
| 1091 | (cond ((fixnum? n2) |
| 1092 | (if (fx=/unchecked n2 0) (zero-divisor) (remainder/fixnum n1 n2))) |
| 1093 | ((bignum? n2) (remainder/bignum n1 n2)) |
| 1094 | ((flonum? n2) |
| 1095 | (if (flo=/unchecked n2 flo0) (zero-divisor) |
| 1096 | (floremainder/int/unchecked (flonum/generic n1) n2))) |
| 1097 | (else (not-integer n2)))) |
| 1098 | |
| 1099 | (define (modulo n1 n2) |
| 1100 | (let ((r (remainder n1 n2))) |
| 1101 | (if (eq? (negative? r) (negative? n2)) r |
| 1102 | (add2 r n2)))) |
| 1103 | |
| 1104 | (define (gcd2 n1 n2) |
| 1105 | (if (= n2 0) n1 |
| 1106 | (gcd2 n2 (remainder n1 n2)))) |
| 1107 | |
| 1108 | (define gcd* (delay (foldl gcd2))) |
| 1109 | |
| 1110 | (define (gcd . ns) |
| 1111 | (if (pair? ns) (gcd* (car/unchecked ns) (cdr/unchecked ns)) 0)) |
| 1112 | |
| 1113 | (define (lcm . ns) |
| 1114 | (if (pair? ns) |
| 1115 | (quotient (mul* (car/unchecked ns) (cdr/unchecked ns)) |
| 1116 | (gcd* (car/unchecked ns) (cdr/unchecked ns))) |
| 1117 | 1)) |
| 1118 | |
| 1119 | ; numerator |
| 1120 | ; denominator |
| 1121 | |
| 1122 | (define (floor x) |
| 1123 | (cond ((flonum? x) (floor/unchecked x)) |
| 1124 | ((exact? x) x) |
| 1125 | (else (not-number x)))) |
| 1126 | |
| 1127 | (define (ceiling x) |
| 1128 | (cond ((flonum? x) (ceiling/unchecked x)) |
| 1129 | ((exact? x) x) |
| 1130 | (else (not-number x)))) |
| 1131 | |
| 1132 | (define (truncate x) |
| 1133 | (cond ((flonum? x) (truncate/unchecked x)) |
| 1134 | ((exact? x) x) |
| 1135 | (else (not-number x)))) |
| 1136 | |
| 1137 | (define (round x) |
| 1138 | (cond ((flonum? x) (round/unchecked x)) |
| 1139 | ((exact? x) x) |
| 1140 | (else (not-number x)))) |
| 1141 | |
| 1142 | ; rationalize |
| 1143 | |
| 1144 | (define (irrational flo-op special-fx-arg special-result) |
| 1145 | (lambda (z) |
| 1146 | (cond ((flonum? z) (flo-op z)) |
| 1147 | ((fixnum? z) (if (fx=/unchecked z special-fx-arg) special-result |
| 1148 | (flo-op (flonum/unchecked z)))) |
| 1149 | ((bignum? z) (flo-op (bignum->flonum z))) |
| 1150 | (else (not-number z))))) |
| 1151 | |
| 1152 | (define atan1 (delay (irrational atan/unchecked 0 0))) |
| 1153 | |
| 1154 | (define (atan2 y x) |
| 1155 | (cond ((flonum? y) (atan2/unchecked y (flonum/generic x))) |
| 1156 | ((fixnum? y) (if (and (fx=/unchecked y 0) (positive? x)) 0 |
| 1157 | (atan2/unchecked (flonum/unchecked y) |
| 1158 | (flonum/generic x)))) |
| 1159 | ((bignum? y) (atan2/unchecked (bignum->flonum y) |
| 1160 | (flonum/generic x))) |
| 1161 | (else (not-number y)))) |
| 1162 | |
| 1163 | (define (atan z . zs) |
| 1164 | (cond ((null? zs) (atan1 z)) |
| 1165 | ((null? (cdr/unchecked zs)) (atan2 z (car/unchecked zs))) |
| 1166 | (else (too-many-args)))) |
| 1167 | |
| 1168 | ;; For exact base and non-negative fixnum power |
| 1169 | (define (expt/exact/fixnum base power) |
| 1170 | (do ((base base (* base base)) |
| 1171 | (power power (fxshift power -1)) |
| 1172 | (acc 1 (if (fx=/unchecked (fxand power 1) 1) (* acc base) acc))) |
| 1173 | ((fx=/unchecked power 0) acc))) |
| 1174 | |
| 1175 | ;; For exact base and sign-ignored bignum power. XXX this seems a bit ridiculous to compute, but who am I to stop you from trying? |
| 1176 | (define (expt/exact/bignum base power) |
| 1177 | (do ((base base (* base base)) |
| 1178 | (power (bignum-bit-stream power) (stream-tail power)) |
| 1179 | (acc 1 (if (fx=/unchecked (stream-head power) 1) (* acc base) acc))) |
| 1180 | ((null? power) acc))) |
| 1181 | |
| 1182 | ;; For positive flonum base, flonum power and result |
| 1183 | (define (expt/inexact/+base base power) |
| 1184 | (exp/unchecked (flo*/unchecked (log/unchecked base) power))) |
| 1185 | |
| 1186 | ;; For nonzero flonum base, flonum power and result |
| 1187 | (define (expt/inexact base power) |
| 1188 | (if (and (flonegative/unchecked? base) (integer? power)) |
| 1189 | (if (odd? power) |
| 1190 | (floneg/unchecked |
| 1191 | (expt/inexact/+base (floneg/unchecked base) power)) |
| 1192 | (expt/inexact/+base (floneg/unchecked base) power)) |
| 1193 | ;; For non-integer power of negative base, proceed anyway to get NaN (unspecified, but consistent with sqrt) |
| 1194 | (expt/inexact/+base base power))) |
| 1195 | |
| 1196 | ;; For fixnum power |
| 1197 | (define (expt/fixnum base power) |
| 1198 | (cond ((or (fixnum? base) (bignum? base)) |
| 1199 | (if (fxnegative/unchecked? power) |
| 1200 | (/ (expt/exact/fixnum base (fxneg/promote power))) |
| 1201 | (expt/exact/fixnum base power))) |
| 1202 | ((flonum? base) |
| 1203 | (cond ((fx=/unchecked power 0) 1) |
| 1204 | ((flo=/unchecked base flo0) flo0) |
| 1205 | ((flonegative/unchecked? base) |
| 1206 | (if (odd? power) |
| 1207 | (floneg/unchecked |
| 1208 | (expt/inexact/+base (floneg/unchecked base) |
| 1209 | (flonum/unchecked power))) |
| 1210 | (expt/inexact/+base (floneg/unchecked base) |
| 1211 | (flonum/unchecked power)))) |
| 1212 | (else (expt/inexact/+base base (flonum/unchecked power))))) |
| 1213 | (else (not-number base)))) |
| 1214 | |
| 1215 | ;; For bignum power |
| 1216 | (define (expt/bignum base power) |
| 1217 | (cond ((fixnum? base) |
| 1218 | (cond ((fx=/unchecked base 0) 0) |
| 1219 | ((fx=/unchecked base 1) 1) |
| 1220 | ((fx=/unchecked base -1) (if (odd? power) -1 1)) |
| 1221 | ((bignum-negative? power) |
| 1222 | (/ (expt/exact/bignum base power))) |
| 1223 | (else (expt/exact/bignum base power)))) |
| 1224 | ((bignum? base) |
| 1225 | (cond ((bignum-negative? power) |
| 1226 | (/ (expt/exact/bignum base power))) |
| 1227 | (else (expt/exact/bignum base power)))) |
| 1228 | ((flonum? base) |
| 1229 | (cond ((flo=/unchecked base flo0) flo0) |
| 1230 | ((flo=/unchecked base flo1) flo1) |
| 1231 | ((flo=/unchecked base flo-1) (if (odd? power) flo-1 flo1)) |
| 1232 | ((flonegative/unchecked? base) |
| 1233 | (if (odd? power) |
| 1234 | (floneg/unchecked |
| 1235 | (expt/inexact/+base (floneg/unchecked base) |
| 1236 | (bignum->flonum power))) |
| 1237 | (expt/inexact/+base (floneg/unchecked base) |
| 1238 | (bignum->flonum power)))) |
| 1239 | (else (expt/inexact/+base base (bignum->flonum power))))) |
| 1240 | (else (not-number base)))) |
| 1241 | |
| 1242 | ;; For flonum power (result could still be exact) |
| 1243 | (define (expt/flonum base power) |
| 1244 | (cond ((fixnum? base) |
| 1245 | (cond ((flo=/unchecked power flo0) flo1) |
| 1246 | ((fx=/unchecked base 0) flo0) |
| 1247 | ;; ^ inexact due to the 0^0 case (a low-valued inexact power could be a zero with error) |
| 1248 | ((fx=/unchecked base 1) 1) |
| 1249 | (else (expt/inexact (flonum/unchecked base) power)))) |
| 1250 | ((bignum? base) |
| 1251 | (cond ((flo=/unchecked power flo0) flo1) |
| 1252 | (else (expt/inexact (bignum->flonum base) power)))) |
| 1253 | ((flonum? base) |
| 1254 | (cond ((flo=/unchecked power flo0) flo1) |
| 1255 | ((flo=/unchecked base flo0) flo0) |
| 1256 | (else (expt/inexact base power)))) |
| 1257 | (else (not-number base)))) |
| 1258 | |
| 1259 | (define (expt z1 z2) |
| 1260 | (cond ((fixnum? z2) (expt/fixnum z1 z2)) |
| 1261 | ((bignum? z2) (expt/bignum z1 z2)) |
| 1262 | ((flonum? z2) (expt/flonum z1 z2)) |
| 1263 | (else (not-number z2)))) |
| 1264 | |
| 1265 | ; make-rectangular |
| 1266 | ; make-polar |
| 1267 | ; real-part |
| 1268 | ; imag-part |
| 1269 | ; magnitude |
| 1270 | ; angle |
| 1271 | |
| 1272 | (define (flonum->exact-int fraction exponent) |
| 1273 | (let ((n (load-exponent/unchecked fraction *fixnum-width*-1)) |
| 1274 | (exponent (fx-/unchecked exponent *fixnum-width*-1))) |
| 1275 | (let ((word (flonum->fixnum/unchecked n))) |
| 1276 | (if (fxnegative/unchecked? exponent) |
| 1277 | (fxshift word exponent) |
| 1278 | (let ((fraction (flo-/unchecked n (flonum/unchecked word)))) |
| 1279 | (if (flo=/unchecked fraction flo0) |
| 1280 | (* word (expt/exact/fixnum 2 exponent)) |
| 1281 | (+ (* word (expt/exact/fixnum 2 exponent)) |
| 1282 | (flonum->exact-int fraction exponent)))))))) |
| 1283 | |
| 1284 | (define (inexact->exact z) |
| 1285 | (cond ((flonum? z) |
| 1286 | (cond ((flo=/unchecked z flo0) 0) |
| 1287 | ((inf/unchecked? z) (error "infinite flonum")) |
| 1288 | ((integer? z) (call-with-values |
| 1289 | (lambda () (fraction/exponent/unchecked z)) |
| 1290 | flonum->exact-int)) |
| 1291 | (else (error "non-integer flonum:" z)))) ;; includes NaN |
| 1292 | ((exact? z) z) |
| 1293 | (else (not-number z)))) |
| 1294 | |
| 1295 | ;;; 6.2.6 Numerical I/O |
| 1296 | |
| 1297 | (define (number->string z . args) |
| 1298 | (define radix 10) |
| 1299 | (if (pair? args) |
| 1300 | (begin (if (pair? (cdr args)) (too-many-args)) |
| 1301 | (set! radix (car args)) |
| 1302 | (if (not (fixnum? radix)) |
| 1303 | (if (inexact? radix) (not-exact-int radix) |
| 1304 | (bad-radix radix))))) |
| 1305 | (cond ((fixnum? z) |
| 1306 | ((cond ((fx=/unchecked radix 10) fixnum->dec/unchecked) |
| 1307 | ((fx=/unchecked radix 16) fixnum->hex/unchecked) |
| 1308 | ((fx=/unchecked radix 8) fixnum->oct/unchecked) |
| 1309 | ((fx=/unchecked radix 2) fixnum->bin/unchecked) |
| 1310 | (else (bad-radix radix))) z)) |
| 1311 | ((bignum? z) |
| 1312 | ((cond ((fx=/unchecked radix 10) bignum->dec) |
| 1313 | ((fx=/unchecked radix 16) bignum->hex) |
| 1314 | ((fx=/unchecked radix 8) bignum->oct) |
| 1315 | ((fx=/unchecked radix 2) bignum->bin) |
| 1316 | (else (bad-radix radix))) z)) |
| 1317 | ((flonum? z) |
| 1318 | (cond ((fx=/unchecked radix 10) (flonum->dec/unchecked z)) |
| 1319 | ((memv radix '(16 8 2)) |
| 1320 | ;; XXX the spec is confusing here: seems to be allowed, but point and exponent notation are only allowed in decimal radix. So inexact integers could pass the round-trip test e.g. "#iabcdef000000000", but ew. |
| 1321 | (error "non-decimal radix for inexact number")) |
| 1322 | (else (bad-radix radix)))) |
| 1323 | (else (not-number z)))) |
| 1324 | |
| 1325 | (define (string->number s . args) |
| 1326 | ;; XXX what to do if both #e prefix and point/exponent/#? |
| 1327 | (define fail #f) |
| 1328 | (define acc #f) |
| 1329 | |
| 1330 | (define radix 10) |
| 1331 | (define exact #t) |
| 1332 | (define got-radix #f) |
| 1333 | (define got-exact #f) |
| 1334 | (define (set-radix! r) |
| 1335 | (if got-radix (fail)) (set! got-radix #t) (set! radix r)) |
| 1336 | (define (set-exact! e) |
| 1337 | (if got-exact (fail)) (set! got-exact #t) (set! exact e)) |
| 1338 | |
| 1339 | (define pos 0) |
| 1340 | (define len #f) |
| 1341 | (define (peek) (string-ref s pos)) |
| 1342 | (define (next!) |
| 1343 | (let ((c (string-ref s pos))) |
| 1344 | (set! pos (fx+/unchecked pos 1)) c)) |
| 1345 | (define (end?) (fx=/unchecked pos len)) |
| 1346 | |
| 1347 | (define (char->digit c) |
| 1348 | ;; Simultaneous ASCII digit conversion and range checking with memoized radix specialization. |
| 1349 | (set! char->digit |
| 1350 | (cond ((fx=/unchecked radix 2) |
| 1351 | (lambda (c) |
| 1352 | (cond ((char<? c #\0) #f) |
| 1353 | ;; (char->integer #\0) -> 48 |
| 1354 | ((char<=? c #\1) (fx-/unchecked (char->integer c) 48)) |
| 1355 | (else #f)))) |
| 1356 | ((fx=/unchecked radix 8) |
| 1357 | (lambda (c) |
| 1358 | (cond ((char<? c #\0) #f) |
| 1359 | ((char<=? c #\7) (fx-/unchecked (char->integer c) 48)) |
| 1360 | (else #f)))) |
| 1361 | ((fx=/unchecked radix 10) |
| 1362 | (lambda (c) |
| 1363 | (cond ((char<? c #\0) #f) |
| 1364 | ((char<=? c #\9) (fx-/unchecked (char->integer c) 48)) |
| 1365 | (else #f)))) |
| 1366 | ((fx=/unchecked radix 16) |
| 1367 | (lambda (c) |
| 1368 | (set! c (char->integer (char-upcase c))) |
| 1369 | ;; (- (char->integer #\A) 10) -> 55 |
| 1370 | (set! c (fx-/unchecked c (if (fx</unsigned c 58) 48 55))) |
| 1371 | (and (fx</unsigned c 16) c))))) ;; wrap negatives |
| 1372 | (char->digit c)) |
| 1373 | |
| 1374 | (define (<prefix>) |
| 1375 | (cond ((end?) (fail)) |
| 1376 | ((char=? (peek) #\#) |
| 1377 | (next!) |
| 1378 | (if (end?) (fail)) |
| 1379 | (case (char-downcase (next!)) |
| 1380 | ((#\e) (set-exact! #t)) |
| 1381 | ((#\i) (set-exact! #f)) |
| 1382 | ((#\b) (set-radix! 2)) |
| 1383 | ((#\o) (set-radix! 8)) |
| 1384 | ((#\d) (set-radix! 10)) |
| 1385 | ((#\x) (set-radix! 16)) |
| 1386 | (else (fail))) |
| 1387 | (<prefix>)) |
| 1388 | (else (<complex>)))) |
| 1389 | |
| 1390 | (define (<complex>) |
| 1391 | (let ((r (<real>))) |
| 1392 | (if (end?) r (fail)))) ;; stub |
| 1393 | |
| 1394 | (define (<real>) |
| 1395 | (let ((proc (if (fx=/unchecked radix 10) <ureal-10> <ureal-pow2>))) |
| 1396 | (cond ((end?) (fail)) |
| 1397 | ((char=? (peek) #\+) (next!) (proc)) |
| 1398 | ((char=? (peek) #\-) (next!) (- (proc))) |
| 1399 | (else (proc))))) |
| 1400 | |
| 1401 | (define (<ureal-pow2>) |
| 1402 | (if (end?) (fail)) |
| 1403 | (let ((d (char->digit (next!)))) |
| 1404 | (cond (d (set! acc (if exact d (flonum/unchecked d))) |
| 1405 | (ureal-pow2-loop)) |
| 1406 | (else (fail))))) |
| 1407 | (define (ureal-pow2-loop) |
| 1408 | (if (end?) acc |
| 1409 | (let* ((c (peek)) (d (char->digit c))) |
| 1410 | ;; XXX naive algorithm |
| 1411 | (cond (d (next!) |
| 1412 | (set! acc (+ (* acc radix) d)) |
| 1413 | (ureal-pow2-loop)) |
| 1414 | ((char=? c #\#) (set! acc (flonum/generic acc)) |
| 1415 | (sharp-loop)) |
| 1416 | ((char=? c #\/) (next!) |
| 1417 | (fraction)) |
| 1418 | (else acc))))) |
| 1419 | |
| 1420 | (define (<ureal-10>) |
| 1421 | (if (end?) (fail)) |
| 1422 | (let* ((c (next!)) (d (char->digit c))) |
| 1423 | (cond (d (set! acc (if exact d (flonum/unchecked d))) |
| 1424 | (ureal-10-loop)) |
| 1425 | ((char=? c #\.) (initial-point)) |
| 1426 | (else (fail))))) |
| 1427 | (define (ureal-10-loop) |
| 1428 | (if (end?) acc |
| 1429 | (let* ((c (peek)) (d (char->digit c))) |
| 1430 | ;; XXX naive algorithm |
| 1431 | (cond (d (next!) |
| 1432 | (set! acc (+ (* acc 10) d)) |
| 1433 | (ureal-10-loop)) |
| 1434 | ((char=? c #\.) (next!) |
| 1435 | (set! acc (flonum/generic acc)) |
| 1436 | (point-loop flo1/10)) |
| 1437 | ((char=? c #\#) (set! acc (flonum/generic acc)) |
| 1438 | (sharp-loop)) |
| 1439 | ((char=? c #\/) (next!) (fraction)) |
| 1440 | (else (<suffix>)))))) |
| 1441 | |
| 1442 | (define (sharp-loop) |
| 1443 | (cond ((end?) acc) |
| 1444 | ((char=? (peek) #\#) (next!) |
| 1445 | (set! acc (* radix acc)) |
| 1446 | (sharp-loop)) |
| 1447 | ((char=? (peek) #\.) (next!) |
| 1448 | (if (fx=/unchecked radix 10) |
| 1449 | (point-sharp-loop) (fail))) |
| 1450 | ((char=? (peek) #\/) (next!) |
| 1451 | (fraction)) |
| 1452 | (else acc))) |
| 1453 | |
| 1454 | (define (initial-point) |
| 1455 | (if (end?) (fail)) |
| 1456 | (let ((d (char->digit (next!)))) |
| 1457 | (cond (d (set! acc (flo*/unchecked (flonum/unchecked d) flo1/10)) |
| 1458 | (point-loop (flo*/unchecked flo1/10 flo1/10))) |
| 1459 | (else (fail))))) |
| 1460 | (define (point-loop place-val) |
| 1461 | (if (end?) acc |
| 1462 | (let ((d (char->digit (peek)))) |
| 1463 | ;; XXX naive algorithm |
| 1464 | (cond (d (next!) |
| 1465 | (set! acc (flo+/unchecked |
| 1466 | acc (flo*/unchecked place-val |
| 1467 | (flonum/unchecked d)))) |
| 1468 | (point-loop (flo*/unchecked place-val flo1/10))) |
| 1469 | (else (point-sharp-loop)))))) |
| 1470 | (define (point-sharp-loop) |
| 1471 | (cond ((end?) acc) |
| 1472 | ((char=? (peek) #\#) (next!) (point-sharp-loop)) |
| 1473 | (else (<suffix>)))) |
| 1474 | |
| 1475 | (define (<suffix>) |
| 1476 | (cond ((end?) acc) |
| 1477 | ((memv (char-downcase (peek)) '(#\e #\s #\f #\d #\l)) |
| 1478 | ;; all markers equivalent as we only have one float precision |
| 1479 | (next!) (exponent-sign)) |
| 1480 | (else acc))) |
| 1481 | |
| 1482 | (define (fraction) |
| 1483 | (fail)) ;; stub |
| 1484 | |
| 1485 | (define (exponent-sign) |
| 1486 | (define (exponent negative) |
| 1487 | (if (end?) (fail) |
| 1488 | (let ((d (char->digit (next!)))) |
| 1489 | (if d (let ((e (loop (flonum/unchecked d)))) |
| 1490 | (flo*/unchecked |
| 1491 | (flonum/generic acc) |
| 1492 | (exp10/flonum (if negative (floneg/unchecked e) e)))) |
| 1493 | (fail))))) |
| 1494 | (define (loop e) |
| 1495 | (if (end?) e |
| 1496 | (let ((d (char->digit (peek)))) |
| 1497 | (if d (begin (next!) (loop (flo+/unchecked |
| 1498 | (flo*/unchecked e flo10) |
| 1499 | (flonum/unchecked d)))) |
| 1500 | e)))) |
| 1501 | (cond ((end?) (fail)) |
| 1502 | ((char=? (peek) #\+) (next!) (exponent #f)) |
| 1503 | ((char=? (peek) #\-) (next!) (exponent #t)) |
| 1504 | (else (exponent #f)))) |
| 1505 | |
| 1506 | (set! len (string-length s)) |
| 1507 | (if (pair? args) |
| 1508 | (if (pair? (cdr args)) (too-many-args) |
| 1509 | (begin (set! radix (car args)) |
| 1510 | (if (memv radix '(2 8 10 16)) |
| 1511 | (if (not (fixnum? radix)) (not-exact-int radix)) |
| 1512 | (bad-radix radix))))) |
| 1513 | (call/cc (lambda (return) (set! fail (lambda () (return #f))) |
| 1514 | (<prefix>)))) |
| 1515 | ;; end of string->number (whew!) |
| 1516 | |
| 1517 | ;;; 6.3.2 Pairs and lists |
| 1518 | |
| 1519 | (define (list . args) args) |
| 1520 | |
| 1521 | ;; not tail recursive |
| 1522 | (define (append . args) |
| 1523 | (if (pair? args) |
| 1524 | (let loop ((lists args)) |
| 1525 | (let ((next (cdr/unchecked lists))) |
| 1526 | (if (pair? next) |
| 1527 | (append2 (car/unchecked lists) (loop next)) |
| 1528 | (car/unchecked lists)))) |
| 1529 | '())) |
| 1530 | |
| 1531 | (define (reverse l) |
| 1532 | (let loop ((accum '()) (l l)) |
| 1533 | (cond ((pair? l) (loop (cons (car/unchecked l) accum) |
| 1534 | (cdr/unchecked l))) |
| 1535 | ((null? l) accum) |
| 1536 | (else (not-list))))) |
| 1537 | |
| 1538 | (define (list-tail l k) |
| 1539 | (check-exact-non-negative-int k) |
| 1540 | (do ((k k (- k 1)) (l l (cdr l))) ((zero? k) l))) |
| 1541 | |
| 1542 | (define (list-ref l k) (car (list-tail l k))) |
| 1543 | |
| 1544 | (define (memq x l) |
| 1545 | (cond ((pair? l) (if (eq? x (car/unchecked l)) l |
| 1546 | (memq x (cdr/unchecked l)))) |
| 1547 | ((null? l) #f) |
| 1548 | (else (not-list)))) |
| 1549 | |
| 1550 | (define (memv x l) |
| 1551 | (cond ((pair? l) (if (eqv? x (car/unchecked l)) l |
| 1552 | (memv x (cdr/unchecked l)))) |
| 1553 | ((null? l) #f) |
| 1554 | (else (not-list)))) |
| 1555 | |
| 1556 | (define (member x l) |
| 1557 | (cond ((pair? l) (if (equal? x (car/unchecked l)) l |
| 1558 | (member x (cdr/unchecked l)))) |
| 1559 | ((null? l) #f) |
| 1560 | (else (not-list)))) |
| 1561 | |
| 1562 | (define (assq x l) |
| 1563 | (cond ((pair? l) (if (eq? x (caar l)) (car/unchecked l) |
| 1564 | (assq x (cdr/unchecked l)))) |
| 1565 | ((null? l) #f) |
| 1566 | (else (not-list)))) |
| 1567 | |
| 1568 | (define (assv x l) |
| 1569 | (cond ((pair? l) (if (eqv? x (caar l)) (car/unchecked l) |
| 1570 | (assv x (cdr/unchecked l)))) |
| 1571 | ((null? l) #f) |
| 1572 | (else (not-list)))) |
| 1573 | |
| 1574 | (define (assoc x l) |
| 1575 | (cond ((pair? l) (if (equal? x (caar l)) (car/unchecked l) |
| 1576 | (assoc x (cdr/unchecked l)))) |
| 1577 | ((null? l) #f) |
| 1578 | (else (not-list)))) |
| 1579 | |
| 1580 | ;;; 6.3.5 Strings |
| 1581 | |
| 1582 | (define (string . args) (list->string args)) |
| 1583 | |
| 1584 | (define (string->list s) |
| 1585 | (do ((k (fx+/unchecked (string-length s) -1) (fx+/unchecked k -1)) |
| 1586 | (accum '() (cons (string-ref/unchecked s k) accum))) |
| 1587 | ((fx=/unchecked k -1) accum))) |
| 1588 | |
| 1589 | ;;; 6.3.6 Vectors |
| 1590 | |
| 1591 | (define (vector . args) (list->vector args)) |
| 1592 | |
| 1593 | (define (vector->list v) |
| 1594 | (do ((k (fx-/unchecked (vector-length v) 1) (fx-/unchecked k 1)) |
| 1595 | (accum '() (cons (vector-ref/unchecked v k) accum))) |
| 1596 | ((fx=/unchecked k -1) accum))) |
| 1597 | |
| 1598 | ;;; 6.4 Control Features |
| 1599 | |
| 1600 | (define (apply proc . args) |
| 1601 | (if (pair? args) |
| 1602 | (let ((p2 (cdr/unchecked args))) |
| 1603 | (if (pair? p2) |
| 1604 | (do ((p1 args p2) |
| 1605 | (p2 p2 p3) |
| 1606 | (p3 (cdr/unchecked p2) (cdr/unchecked p3))) |
| 1607 | ((null? p3) |
| 1608 | (set-cdr/unchecked! p1 (copy-list (car/unchecked p2))))) |
| 1609 | (set! args (copy-list (car/unchecked args))))) |
| 1610 | (error "missing argument list")) |
| 1611 | (apply/unchecked proc args)) |
| 1612 | |
| 1613 | (define all-null? (delay (all null?))) |
| 1614 | (define all-pair? (delay (all pair?))) |
| 1615 | (define car*unchecked (delay (map1 car/unchecked))) |
| 1616 | (define cdr*unchecked (delay (map1 cdr/unchecked))) |
| 1617 | |
| 1618 | ;; not tail recursive |
| 1619 | (define (map proc list1 . lists) |
| 1620 | (define (loop lists) |
| 1621 | (cond ((pair? (car/unchecked lists)) |
| 1622 | (if (all-pair? (cdr/unchecked lists)) |
| 1623 | (cons (apply/unchecked proc (car*unchecked lists)) |
| 1624 | (loop (cdr*unchecked lists))) |
| 1625 | (uneven-lists))) |
| 1626 | ((null? (car/unchecked lists)) |
| 1627 | (if (all-null? (cdr/unchecked lists)) '() (uneven-lists))) |
| 1628 | (else (not-list)))) |
| 1629 | (loop (cons list1 lists))) |
| 1630 | |
| 1631 | (define (for-each proc list1 . lists) |
| 1632 | (define (loop lists) |
| 1633 | (cond ((pair? (car/unchecked lists)) |
| 1634 | (if (not (all-pair? (cdr/unchecked lists))) (uneven-lists)) |
| 1635 | (apply/unchecked proc (car*unchecked lists)) |
| 1636 | (loop (cdr*unchecked lists))) |
| 1637 | ((null? (car/unchecked lists)) |
| 1638 | (if (all-null? (cdr/unchecked lists)) '() |
| 1639 | (uneven-lists))) |
| 1640 | (else (not-list)))) |
| 1641 | (loop (cons list1 lists))) |
| 1642 | |
| 1643 | (define (dynamic-wind before thunk after) |
| 1644 | (call/cc (lambda (return) |
| 1645 | (push-winding! before after) |
| 1646 | (before) |
| 1647 | (call-with-values thunk return)))) |
| 1648 | |
| 1649 | ;;; 6.6.1 Ports |
| 1650 | |
| 1651 | (define (call-with-input-file filename proc) |
| 1652 | (let ((port (open-input-file filename))) |
| 1653 | (saving-values (lambda () (proc port)) |
| 1654 | (lambda () (close-input-port port))))) |
| 1655 | |
| 1656 | (define (call-with-output-file filename proc . options) |
| 1657 | (let ((port (apply open-output-file filename options))) |
| 1658 | (saving-values (lambda () (proc port)) |
| 1659 | (lambda () (close-output-port port))))) |
| 1660 | |
| 1661 | (define (with-input-from-file filename proc) |
| 1662 | (let ((saved (current-input-port)) |
| 1663 | (port (open-input-file filename))) |
| 1664 | (saving-values |
| 1665 | (lambda () (dynamic-wind (lambda () (set-input-port! port)) |
| 1666 | proc |
| 1667 | (lambda () (set-input-port! saved)))) |
| 1668 | (lambda () (close-input-port port))))) |
| 1669 | |
| 1670 | (define (with-output-to-file filename proc . options) |
| 1671 | (let ((saved (current-output-port)) |
| 1672 | (port (apply open-output-file filename options))) |
| 1673 | (saving-values |
| 1674 | (lambda () (dynamic-wind (lambda () (set-output-port! port)) |
| 1675 | proc |
| 1676 | (lambda () (set-output-port! saved)))) |
| 1677 | (lambda () (close-output-port port))))) |
| 1678 | |
| 1679 | ;;; 6.6.2 Input |
| 1680 | |
| 1681 | ;; Reader sentinels: newly allocated so not EQ? to any readable object (not sure if this would be guaranteed with a quoted pair...) |
| 1682 | (define rd-close-paren (cons 'special 'close-paren)) |
| 1683 | (define rd-dot (cons 'special 'dot)) |
| 1684 | |
| 1685 | (define (read . port) |
| 1686 | (define (eof-list) (error "unexpected end-of-file in list")) |
| 1687 | (define (read-datum) |
| 1688 | (let ((t (apply/unchecked read-token port))) |
| 1689 | (if (eof-object? t) t |
| 1690 | (case (car t) |
| 1691 | ((identifier) (string->symbol (cdr t))) |
| 1692 | ((open-paren) (build-list (read-datum))) |
| 1693 | ((close-paren) rd-close-paren) |
| 1694 | ((literal) (cdr t)) |
| 1695 | ((number) (or (string->number (cdr t)) |
| 1696 | (error "bad number token:" (cdr t)))) |
| 1697 | ((abbrev) (abbrev (cdr t) (read-datum))) |
| 1698 | ((dot) rd-dot) |
| 1699 | ((open-vector) (build-vector '() (read-datum))) |
| 1700 | ((named-char) (named-char (cdr t))) |
| 1701 | (else (error "BUG: unmatched token type")))))) |
| 1702 | (define (build-list d) |
| 1703 | (cond ((eq? d rd-close-paren) '()) |
| 1704 | ((eq? d rd-dot) (error "dotted list without first item")) |
| 1705 | ((eof-object? d) (eof-list)) |
| 1706 | (else (extend-list (list d))))) |
| 1707 | (define (extend-list head) |
| 1708 | (define tail head) |
| 1709 | (define (loop d) |
| 1710 | (cond ((eq? d rd-close-paren) head) |
| 1711 | ((eq? d rd-dot) (improper (read-datum))) |
| 1712 | ((eof-object? d) (eof-list)) |
| 1713 | (else (set-cdr! tail (list d)) |
| 1714 | (set! tail (cdr tail)) |
| 1715 | (loop (read-datum))))) |
| 1716 | (define (improper d) |
| 1717 | (cond ((eof-object? d) (eof-list)) |
| 1718 | ((eq? d rd-close-paren) |
| 1719 | (error "dotted list without last item")) |
| 1720 | ((eq? d rd-dot) (error "extra dot in dotted list"))) |
| 1721 | (let ((t (apply/unchecked read-token port))) |
| 1722 | (cond ((eof-object? t) (eof-list)) |
| 1723 | ((eq? (car t) 'close-paren) (set-cdr! tail d) head) |
| 1724 | (else (error "excess item in tail of dotted list"))))) |
| 1725 | (loop (read-datum))) |
| 1726 | (define (abbrev sym d) |
| 1727 | (cond ((eof-object? d) |
| 1728 | (error "unexpected end-of-file in abbreviation")) |
| 1729 | ((eq? d rd-close-paren) |
| 1730 | (error "unexpected close-paren in abbreviation")) |
| 1731 | ((eq? d rd-dot) |
| 1732 | (error "unexpected dot in abbreviation"))) |
| 1733 | (list sym d)) |
| 1734 | (define (build-vector acc d) |
| 1735 | (cond ((eof-object? d) (error "unexpected end-of-file in vector")) |
| 1736 | ((eq? d rd-close-paren) (reverse-list->vector/unchecked acc)) |
| 1737 | ((eq? d rd-dot) (error "unexpected dot in vector")) |
| 1738 | (else (build-vector (cons d acc) (read-datum))))) |
| 1739 | (define (named-char n) |
| 1740 | (integer->char |
| 1741 | (cond ((string=? n "space") 32) |
| 1742 | ((string=? n "newline") 10) |
| 1743 | (else (error "bad character name:" n))))) |
| 1744 | (let ((d (read-datum))) |
| 1745 | (cond ((eq? d rd-close-paren) (error "unexpected close-paren")) |
| 1746 | ((eq? d rd-dot) (error "unexpected dot")) |
| 1747 | (else d)))) |
| 1748 | |
| 1749 | ;;; 6.6.3 Output |
| 1750 | |
| 1751 | (define char-printer #f) |
| 1752 | (define string-printer #f) |
| 1753 | |
| 1754 | (define environment-specs |
| 1755 | `((,(null-environment 5) "NULL") |
| 1756 | (,(scheme-report-environment 5) "SCHEME-REPORT") |
| 1757 | (,(gales-scheme-environment) "GALES-SCHEME") |
| 1758 | (,(interaction-environment) "INTERACTION") |
| 1759 | (,(toplevel-environment) "TOPLEVEL"))) |
| 1760 | |
| 1761 | (define (write-char/quoted c) |
| 1762 | (write-string "#\\") |
| 1763 | (case (char->integer c) |
| 1764 | ((32) (write-string "space")) |
| 1765 | ((10) (write-string "newline")) |
| 1766 | (else (write-char c)))) |
| 1767 | |
| 1768 | (define (print obj) |
| 1769 | (cond ((pair? obj) |
| 1770 | (let ((head (car/unchecked obj)) |
| 1771 | (tail (cdr/unchecked obj))) |
| 1772 | (cond ((and (symbol? head) |
| 1773 | (pair? tail) |
| 1774 | (null? (cdr/unchecked tail)) |
| 1775 | (assq head '((quote "'") |
| 1776 | (quasiquote "`") |
| 1777 | (unquote ",") |
| 1778 | (unquote-splicing ",@")))) |
| 1779 | => (lambda (r) |
| 1780 | (write-string (cadr r)) |
| 1781 | (print (car/unchecked tail)))) |
| 1782 | (else (write-char #\() |
| 1783 | (let loop ((head head) (tail tail)) |
| 1784 | (print head) |
| 1785 | (cond ((pair? tail) |
| 1786 | (write-char sp) |
| 1787 | (loop (car/unchecked tail) |
| 1788 | (cdr/unchecked tail))) |
| 1789 | ((null? tail)) |
| 1790 | (else (write-string " . ") |
| 1791 | (print tail)))) |
| 1792 | (write-char #\)))))) |
| 1793 | ((null? obj) (write-string "()")) |
| 1794 | ((eq? obj #t) (write-string "#t")) |
| 1795 | ((eq? obj #f) (write-string "#f")) |
| 1796 | ((char? obj) (char-printer obj)) |
| 1797 | ((number? obj) (write-string (number->string obj))) |
| 1798 | ((string? obj) (string-printer obj)) |
| 1799 | ((symbol? obj) (write-string obj)) |
| 1800 | ((vector? obj) (write-string "#(") |
| 1801 | (let ((len (vector-length obj))) |
| 1802 | (if (> len 0) |
| 1803 | (begin |
| 1804 | (print (vector-ref obj 0)) |
| 1805 | (let loop ((k 1)) |
| 1806 | (if (< k len) |
| 1807 | (begin (write-char sp) |
| 1808 | (print (vector-ref obj k)) |
| 1809 | (loop (+ k 1)))))))) |
| 1810 | (write-char #\))) |
| 1811 | ((builtin? obj) (write-string "#BUILTIN:") |
| 1812 | (write-string (builtin-name obj))) |
| 1813 | ((continuation? obj) (write-string "#CONTINUATION")) |
| 1814 | ((procedure? obj) (write-string "#PROCEDURE")) |
| 1815 | ((promise? obj) (write-string "#PROMISE")) |
| 1816 | ((input-port? obj) (write-string "#INPUT-PORT")) |
| 1817 | ((output-port? obj) (write-string "#OUTPUT-PORT")) |
| 1818 | ((eof-object? obj) (write-string "#EOF")) |
| 1819 | ((assq obj environment-specs) |
| 1820 | => (lambda (r) |
| 1821 | (write-string "#ENVSPEC:") (write-string (cadr r)))) |
| 1822 | (else (error "BUG: unmatched type")))) |
| 1823 | |
| 1824 | (define (with-output-port-option thunk args) |
| 1825 | (if (pair? args) |
| 1826 | (if (null? (cdr/unchecked args)) |
| 1827 | (let ((port (car/unchecked args)) |
| 1828 | (saved (current-output-port))) |
| 1829 | (if (output-port? port) |
| 1830 | (dynamic-wind (lambda () (set-output-port! port)) thunk |
| 1831 | (lambda () (set-output-port! saved))) |
| 1832 | (not-output-port port))) |
| 1833 | (too-many-args)) |
| 1834 | (thunk))) |
| 1835 | |
| 1836 | (define (write obj . args) |
| 1837 | (set! char-printer write-char/quoted) |
| 1838 | (set! string-printer write-string/quoted) |
| 1839 | (with-output-port-option (lambda () (print obj)) args)) |
| 1840 | |
| 1841 | (define (display obj . args) |
| 1842 | (set! char-printer write-char) |
| 1843 | (set! string-printer write-string) |
| 1844 | (with-output-port-option (lambda () (print obj)) args)) |
| 1845 | |
| 1846 | (define (newline . args) |
| 1847 | (apply/unchecked write-char (cons nl args))) |
| 1848 | |
| 1849 | ;;; 6.6.4 System Interface |
| 1850 | |
| 1851 | (define (load filename) (call-with-input-file filename exec-from-port)) |
| 1852 | |
| 1853 | ;;; Extensions |
| 1854 | |
| 1855 | (define (set-error-handler! p) |
| 1856 | (set! error-handler (require-procedure p)) |
| 1857 | ;; (re)register hook for internal errors |
| 1858 | (set-error-continuation! error-cont)) |
| 1859 | |
| 1860 | (define (exit . args) |
| 1861 | (let ((status (opt-args args 0))) |
| 1862 | (if (and (exact? status) (integer? status)) |
| 1863 | (exit-cont (modulo status 256)) |
| 1864 | ;; ^ ensures fixnum, and seems to be what unix does anyway |
| 1865 | (not-exact-int status)))) |
| 1866 | |
| 1867 | ;;; Lispy socket interface based on internal Unixy one. |
| 1868 | ;; |
| 1869 | ;; A socket object is a dispatch a-list of methods and constants. This object-oriented design avoids exposing bare file descriptors while allowing for more esoteric methods to be added in the future if needed. Unnecessary mutators are avoided, and stream sockets are not conflated with listeners. |
| 1870 | ;; |
| 1871 | ;; Explicitly closing one of the directional ports of a stream socket is interpreted as a promise that no further data will be read/written, including through other aliases of the underlying socket. Thus it is a half-shutdown visible to the peer as well as any external processes sharing the socket (e.g. if a fork extension is implemented). When closing listeners or datagram sockets shared by external processes, the usual Unix reference counting semantics apply. |
| 1872 | ;; |
| 1873 | ;; Host and service lookup is intended to be implemented in Scheme, at a higher layer. (That is, open-* won't do implicit lookups when the address looks like a name.) |
| 1874 | |
| 1875 | ;;; Internal constructors for general socket types |
| 1876 | |
| 1877 | (define (make-socket fd) |
| 1878 | `((type socket) |
| 1879 | (address ,(getsockname fd)))) ;; immutable |
| 1880 | |
| 1881 | (define (make-stream-socket fd) |
| 1882 | (receive (i o) (socket-ports fd) |
| 1883 | `((type stream-socket) |
| 1884 | (input-port ,i) |
| 1885 | (output-port ,o) |
| 1886 | (peer-address ,(getpeername fd)) ;; immutable |
| 1887 | . ,(make-socket fd)))) |
| 1888 | |
| 1889 | (define (make-listener fd) |
| 1890 | `((type listener) |
| 1891 | (accept ,(lambda () (make-stream-socket (accept fd)))) |
| 1892 | (close ,(lambda () (close fd))) |
| 1893 | . ,(make-socket fd))) |
| 1894 | |
| 1895 | (define (make-dgram-socket fd) |
| 1896 | `((type datagram-socket) |
| 1897 | (send ,(lambda (address msg) (sendto fd address msg))) |
| 1898 | (receive ,(lambda () (recvfrom fd))) |
| 1899 | (close ,(lambda () (close fd))) |
| 1900 | . ,(make-socket fd))) |
| 1901 | |
| 1902 | ;;; Specific constructors |
| 1903 | |
| 1904 | (define (open-tcp-connection address . args) |
| 1905 | (let* ((bind-address (opt-args args #f)) |
| 1906 | (fd (if bind-address (inet-stream-socket bind-address) |
| 1907 | (inet-stream-socket)))) |
| 1908 | (connect-inet fd address) |
| 1909 | (make-stream-socket fd))) |
| 1910 | |
| 1911 | (define (open-tcp-listener backlog . args) |
| 1912 | (let* ((address (opt-args args #f)) |
| 1913 | (fd (if address (inet-stream-socket address) |
| 1914 | (inet-stream-socket)))) |
| 1915 | (listen fd backlog) |
| 1916 | (make-listener fd))) |
| 1917 | |
| 1918 | (define (open-udp-socket . args) |
| 1919 | (let* ((address (opt-args args #f)) |
| 1920 | (fd (if address (inet-dgram-socket address) |
| 1921 | (inet-dgram-socket)))) |
| 1922 | (make-dgram-socket fd))) |
| 1923 | |
| 1924 | (define (open-unix-connection address . args) |
| 1925 | (let* ((bind-address (opt-args args #f)) |
| 1926 | (fd (if bind-address (unix-stream-socket bind-address) |
| 1927 | (unix-stream-socket)))) |
| 1928 | (connect-unix fd address) |
| 1929 | (make-stream-socket fd))) |
| 1930 | |
| 1931 | (define (open-unix-listener backlog address) |
| 1932 | ;; address required as Unix listeners can't bind to an automatic path |
| 1933 | (let ((fd (unix-stream-socket address))) |
| 1934 | (listen fd backlog) |
| 1935 | (make-listener fd))) |
| 1936 | |
| 1937 | (define (open-unix-datagram-socket . args) |
| 1938 | (let* ((address (opt-args args #f)) |
| 1939 | (fd (if address (unix-dgram-socket address) |
| 1940 | (unix-dgram-socket)))) |
| 1941 | (make-dgram-socket fd))) |
| 1942 | |
| 1943 | ;;; Higher-level wrappers |
| 1944 | |
| 1945 | (define (: object field) (cadr (assq field object))) |
| 1946 | |
| 1947 | (define (close-io i o) (close-input-port i) (close-output-port o)) |
| 1948 | |
| 1949 | (define (call-with-connection sock proc) |
| 1950 | (let ((i (: sock 'input-port)) |
| 1951 | (o (: sock 'output-port))) |
| 1952 | (saving-values (lambda () (proc i o)) |
| 1953 | (lambda () (close-io i o))))) |
| 1954 | |
| 1955 | (define (sequential-server listener handler) |
| 1956 | (let ((accept (: listener 'accept))) |
| 1957 | (let loop () |
| 1958 | (let ((sock (accept))) |
| 1959 | (let ((i (: sock 'input-port)) |
| 1960 | (o (: sock 'output-port))) |
| 1961 | (let ((r (handler i o (: sock 'peer-address)))) |
| 1962 | (close-io i o) |
| 1963 | (if r (loop) ((: listener 'close))))))))) |
| 1964 | |
| 1965 | (define (call-with-tcp-connection address proc) |
| 1966 | ;; parse IP / resolve name here... |
| 1967 | (call-with-connection (open-tcp-connection address) proc)) |
| 1968 | |
| 1969 | (define (call-with-unix-connection address proc) |
| 1970 | (call-with-connection (open-unix-connection address) proc)) |
| 1971 | |
| 1972 | (define (sequential-tcp-server backlog address handler) |
| 1973 | (sequential-server (open-tcp-listener backlog address) handler)) |
| 1974 | |
| 1975 | (define (sequential-unix-server backlog address handler) |
| 1976 | (sequential-server (open-unix-listener backlog address) handler)) |
| 1977 | |
| 1978 | ;;; End of internal definitions; apply deferred initializations (implicit forcing or R6's letrec* semantics could avoid this) |
| 1979 | |
| 1980 | (set! flo-bn-radix (force flo-bn-radix)) |
| 1981 | (set! flo-log-bn-radix (force flo-log-bn-radix)) |
| 1982 | (set! =* (force =*)) |
| 1983 | (set! <* (force <*)) |
| 1984 | (set! >* (force >*)) |
| 1985 | (set! <=* (force <=*)) |
| 1986 | (set! >=* (force >=*)) |
| 1987 | (set! max* (force max*)) |
| 1988 | (set! min* (force min*)) |
| 1989 | (set! add2 (force add2)) |
| 1990 | (set! mul2 (force mul2)) |
| 1991 | (set! sub/bignum (force sub/bignum)) |
| 1992 | (set! add* (force add*)) |
| 1993 | (set! mul* (force mul*)) |
| 1994 | (set! sub* (force sub*)) |
| 1995 | (set! div* (force div*)) |
| 1996 | (set! quotient/fixnum (force quotient/fixnum)) |
| 1997 | (set! quotient/bignum (force quotient/bignum)) |
| 1998 | (set! remainder/fixnum (force remainder/fixnum)) |
| 1999 | (set! remainder/bignum (force remainder/bignum)) |
| 2000 | (set! gcd* (force gcd*)) |
| 2001 | (set! atan1 (force atan1)) |
| 2002 | (set! all-null? (force all-null?)) |
| 2003 | (set! all-pair? (force all-pair?)) |
| 2004 | (set! car*unchecked (force car*unchecked)) |
| 2005 | (set! cdr*unchecked (force cdr*unchecked)) |
| 2006 | (set! dec-chunk-digits (force dec-chunk-digits)) |
| 2007 | (set! dec-chunk-radix (force dec-chunk-radix)) |
| 2008 | (set! hex-chunk-digits (force hex-chunk-digits)) |
| 2009 | (set! oct-chunk-digits (force oct-chunk-digits)) |
| 2010 | (set! hex-chunk-bits (force hex-chunk-bits)) |
| 2011 | (set! oct-chunk-bits (force oct-chunk-bits)) |
| 2012 | |
| 2013 | (for-each |
| 2014 | (lambda (rec) (define-traced define-r5rs (car rec) (cadr rec))) |
| 2015 | `((eqv? ,eqv?) |
| 2016 | (equal? ,equal?) |
| 2017 | (= ,=) |
| 2018 | (< ,<) |
| 2019 | (> ,>) |
| 2020 | (<= ,<=) |
| 2021 | (>= ,>=) |
| 2022 | (zero? ,zero?) |
| 2023 | (positive? ,positive?) |
| 2024 | (negative? ,negative?) |
| 2025 | (odd? ,odd?) |
| 2026 | (even? ,even?) |
| 2027 | (max ,max) |
| 2028 | (min ,min) |
| 2029 | (+ ,+) |
| 2030 | (* ,*) |
| 2031 | (- ,-) |
| 2032 | (/ ,/) |
| 2033 | (abs ,abs) |
| 2034 | (quotient ,quotient) |
| 2035 | (remainder ,remainder) |
| 2036 | (modulo ,modulo) |
| 2037 | (gcd ,gcd) |
| 2038 | (lcm ,lcm) |
| 2039 | (floor ,floor) |
| 2040 | (ceiling ,ceiling) |
| 2041 | (truncate ,truncate) |
| 2042 | (round ,round) |
| 2043 | (exp ,(irrational exp/unchecked 0 1)) |
| 2044 | (log ,(irrational log/unchecked 1 0)) |
| 2045 | (sin ,(irrational sin/unchecked 0 0)) |
| 2046 | (cos ,(irrational cos/unchecked 0 1)) |
| 2047 | (tan ,(irrational tan/unchecked 0 0)) |
| 2048 | (asin ,(irrational asin/unchecked 0 0)) |
| 2049 | (acos ,(irrational acos/unchecked 1 0)) |
| 2050 | (atan ,atan) |
| 2051 | (sqrt ,(irrational sqrt/unchecked 0 0)) |
| 2052 | ;; ^ could be refined to handle exact perfect squares, or bignums with greater precision and range |
| 2053 | (expt ,expt) |
| 2054 | (exact->inexact ,flonum/generic) |
| 2055 | (inexact->exact ,inexact->exact) |
| 2056 | (number->string ,number->string) |
| 2057 | (string->number ,string->number) |
| 2058 | (list ,list) |
| 2059 | (append ,append) |
| 2060 | (reverse ,reverse) |
| 2061 | (list-tail ,list-tail) |
| 2062 | (list-ref ,list-ref) |
| 2063 | (memq ,memq) |
| 2064 | (memv ,memv) |
| 2065 | (member ,member) |
| 2066 | (assq ,assq) |
| 2067 | (assv ,assv) |
| 2068 | (assoc ,assoc) |
| 2069 | (string ,string) |
| 2070 | (string->list ,string->list) |
| 2071 | (vector ,vector) |
| 2072 | (vector->list ,vector->list) |
| 2073 | (apply ,apply) |
| 2074 | (map ,map) |
| 2075 | (for-each ,for-each) |
| 2076 | (dynamic-wind ,dynamic-wind) |
| 2077 | (call-with-input-file ,call-with-input-file) |
| 2078 | (call-with-output-file ,call-with-output-file) |
| 2079 | (with-input-from-file ,with-input-from-file) |
| 2080 | (with-output-to-file ,with-output-to-file) |
| 2081 | (read ,read) |
| 2082 | (write ,write) |
| 2083 | (display ,display) |
| 2084 | (newline ,newline) |
| 2085 | (load ,load))) |
| 2086 | |
| 2087 | (for-each |
| 2088 | (lambda (rec) (define-traced define-gscm (car rec) (cadr rec))) |
| 2089 | `((set-error-handler! ,set-error-handler!) |
| 2090 | (exit ,exit) |
| 2091 | (open-tcp-connection ,open-tcp-connection) |
| 2092 | (open-tcp-listener ,open-tcp-listener) |
| 2093 | (open-udp-socket ,open-udp-socket) |
| 2094 | (open-unix-connection ,open-unix-connection) |
| 2095 | (open-unix-listener ,open-unix-listener) |
| 2096 | (open-unix-datagram-socket ,open-unix-datagram-socket) |
| 2097 | (call-with-tcp-connection ,call-with-tcp-connection) |
| 2098 | (call-with-unix-connection ,call-with-unix-connection) |
| 2099 | (sequential-tcp-server ,sequential-tcp-server) |
| 2100 | (sequential-unix-server ,sequential-unix-server))) |
| 2101 | |
| 2102 | (cond ((call/cc (lambda (c) (set! error-cont c) #f)) |
| 2103 | => (lambda (args) |
| 2104 | (let ((h error-handler) |
| 2105 | (msg (car args)) |
| 2106 | (args (cdr args))) |
| 2107 | (set! error-handler print-error) |
| 2108 | (h msg args (get-trace-log))) |
| 2109 | 1)) |
| 2110 | ((call/cc (lambda (c) (set! exit-cont c) #f))) |
| 2111 | (else (set-error-handler! print-error) |
| 2112 | (define-traced |
| 2113 | define-gscm 'error |
| 2114 | (lambda (msg . args) |
| 2115 | (if (string? msg) (error-cont (cons msg args)) |
| 2116 | (error "not a string:" msg)))) |
| 2117 | (cond ((member *args* '(() ("--"))) |
| 2118 | (call/cc (lambda (c) (set! repl-cont c))) |
| 2119 | (set-error-handler! repl-error) |
| 2120 | (repl)) |
| 2121 | ((string=? (car *args*) "-") |
| 2122 | (exec-from-port (current-input-port))) |
| 2123 | ((string=? (car *args*) "--") |
| 2124 | (set! *args* (cdr *args*)) |
| 2125 | (eval `(set! *args* ',*args*) intr-env) |
| 2126 | (load (car *args*))) |
| 2127 | (else (load (car *args*)))) |
| 2128 | 0)))) |