embox

1
;; init-7.scm -- core library procedures for R7RS
2
;; Copyright (c) 2009-2012 Alex Shinn.  All rights reserved.
3
;; BSD-style license: http://synthcode.com/license.txt
4

5
(define (caar x) (car (car x)))
6
(define (cadr x) (car (cdr x)))
7
(define (cdar x) (cdr (car x)))
8
(define (cddr x) (cdr (cdr x)))
9

10
(define (cons-source kar kdr source)
11
  ((lambda (pair)
12
     (if (pair? source)
13
         (pair-source-set! pair (pair-source source)))
14
     pair)
15
   (cons kar kdr)))
16

17
;; basic utils
18

19
(define (procedure? x) (if (closure? x) #t (opcode? x)))
20

21
(define (length ls)
22
  (if (list? ls) (length* ls) (error "not a list" ls)))
23

24
(define (list . args) args)
25

26
(define (list-tail ls k)
27
  (if (eq? k 0)
28
      ls
29
      (list-tail (cdr ls) (- k 1))))
30

31
(define (list-ref ls k) (car (list-tail ls k)))
32

33
(define (append-helper ls res)
34
  (if (null? ls)
35
      res
36
      (append-helper (cdr ls) (append2 (car ls) res))))
37

38
(define (append . o)
39
  (if (null? o)
40
      '()
41
      ((lambda (lol)
42
         (append-helper (cdr lol) (car lol)))
43
       (reverse o))))
44

45
(define (apply proc . args)
46
  (if (null? args)
47
      (proc)
48
      ((lambda (lol)
49
         (apply1 proc (append2 (reverse (cdr lol)) (car lol))))
50
       (reverse args))))
51

52
;; map with a fast-path for single lists
53

54
(define (map proc ls . lol)
55
  (define (map1 proc ls res)
56
    (if (pair? ls)
57
        (map1 proc (cdr ls) (cons (proc (car ls)) res))
58
        (reverse res)))
59
  (define (mapn proc lol res)
60
    (if (every pair? lol)
61
        (mapn proc
62
              (map1 cdr lol '())
63
              (cons (apply proc (map1 car lol '())) res))
64
        (reverse res)))
65
  (if (null? lol)
66
      (map1 proc ls '())
67
      (mapn proc (cons ls lol) '())))
68

69
(define (for-each f ls . lol)
70
  (define (for1 f ls) (if (pair? ls) (begin (f (car ls)) (for1 f (cdr ls)))))
71
  (if (null? lol) (for1 f ls) (begin (apply map f ls lol) (if #f #f))))
72

73
(define (any pred ls . lol)
74
  (define (any1 pred ls)
75
    (if (null? (cdr ls))
76
        (pred (car ls))
77
        ((lambda (x) (if x x (any1 pred (cdr ls)))) (pred (car ls)))))
78
  (define (anyn pred lol)
79
    (if (every pair? lol)
80
        ((lambda (x) (if x x (anyn pred (map cdr lol))))
81
         (apply pred (map car lol)))
82
        #f))
83
  (if (null? lol) (if (pair? ls) (any1 pred ls) #f) (anyn pred (cons ls lol))))
84

85
(define (every pred ls . lol)
86
  (define (every1 pred ls)
87
    (if (null? (cdr ls))
88
        (pred (car ls))
89
        (if (pred (car ls)) (every1 pred (cdr ls)) #f)))
90
  (if (null? lol)
91
      (if (pair? ls) (every1 pred ls) #t)
92
      (not (apply any (lambda (x) (not (pred x))) ls lol))))
93

94
(define (error msg . args)
95
  (raise (make-exception 'user msg args #f #f)))
96

97
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
98
;; syntax
99

100
(define sc-macro-transformer
101
  (lambda (f)
102
    (lambda (expr use-env mac-env)
103
      (make-syntactic-closure mac-env '() (f expr use-env)))))
104

105
(define rsc-macro-transformer
106
  (lambda (f)
107
    (lambda (expr use-env mac-env)
108
      (f expr mac-env))))
109

110
(define er-macro-transformer
111
  (lambda (f)
112
    (lambda (expr use-env mac-env)
113
      ((lambda (rename compare) (f expr rename compare))
114
       ((lambda (renames)
115
          (lambda (identifier)
116
            ((lambda (cell)
117
               (if cell
118
                   (cdr cell)
119
                   ((lambda (name)
120
                      (set! renames (cons (cons identifier name) renames))
121
                      name)
122
                    (make-syntactic-closure mac-env '() identifier))))
123
             (assq identifier renames))))
124
        '())
125
       (lambda (x y) (identifier=? use-env x use-env y))))))
126

127
(define-syntax cond
128
  (er-macro-transformer
129
   (lambda (expr rename compare)
130
     (if (null? (cdr expr))
131
         #f
132
         ((lambda (cl)
133
            (if (compare (rename 'else) (car cl))
134
                (if (pair? (cddr expr))
135
                    (error "non-final else in cond" expr)
136
                    (cons (rename 'begin) (cdr cl)))
137
                (if (if (null? (cdr cl)) #t (compare (rename '=>) (cadr cl)))
138
                    (list (list (rename 'lambda) (list (rename 'tmp))
139
                                (list (rename 'if) (rename 'tmp)
140
                                      (if (null? (cdr cl))
141
                                          (rename 'tmp)
142
                                          (list (car (cddr cl)) (rename 'tmp)))
143
                                      (cons (rename 'cond) (cddr expr))))
144
                          (car cl))
145
                    (list (rename 'if)
146
                          (car cl)
147
                          (cons (rename 'begin) (cdr cl))
148
                          (cons (rename 'cond) (cddr expr))))))
149
          (cadr expr))))))
150

151
(define-syntax or
152
  (er-macro-transformer
153
   (lambda (expr rename compare)
154
     (cond ((null? (cdr expr)) #f)
155
           ((null? (cddr expr)) (cadr expr))
156
           (else
157
            (list (rename 'let) (list (list (rename 'tmp) (cadr expr)))
158
                  (list (rename 'if) (rename 'tmp)
159
                        (rename 'tmp)
160
                        (cons (rename 'or) (cddr expr)))))))))
161

162
(define-syntax and
163
  (er-macro-transformer
164
   (lambda (expr rename compare)
165
     (cond ((null? (cdr expr)))
166
           ((null? (cddr expr)) (cadr expr))
167
           (else (list (rename 'if) (cadr expr)
168
                       (cons (rename 'and) (cddr expr))
169
                       #f))))))
170

171
(define-syntax quasiquote
172
  (er-macro-transformer
173
   (lambda (expr rename compare)
174
     (define (qq x d)
175
       (cond
176
        ((pair? x)
177
         (cond
178
          ((compare (rename 'unquote) (car x))
179
           (if (<= d 0)
180
               (cadr x)
181
               (list (rename 'list) (list (rename 'quote) 'unquote)
182
                     (qq (cadr x) (- d 1)))))
183
          ((compare (rename 'unquote-splicing) (car x))
184
           (if (<= d 0)
185
               (list (rename 'cons) (qq (car x) d) (qq (cdr x) d))
186
               (list (rename 'list) (list (rename 'quote) 'unquote-splicing)
187
                     (qq (cadr x) (- d 1)))))
188
          ((compare (rename 'quasiquote) (car x))
189
           (list (rename 'list) (list (rename 'quote) 'quasiquote)
190
                 (qq (cadr x) (+ d 1))))
191
          ((and (<= d 0) (pair? (car x))
192
                (compare (rename 'unquote-splicing) (caar x)))
193
           (if (null? (cdr x))
194
               (cadr (car x))
195
               (list (rename 'append) (cadr (car x)) (qq (cdr x) d))))
196
          (else
197
           (list (rename 'cons) (qq (car x) d) (qq (cdr x) d)))))
198
        ((vector? x) (list (rename 'list->vector) (qq (vector->list x) d)))
199
        ((if (symbol? x) #t (null? x)) (list (rename 'quote) x))
200
        (else x)))
201
     (qq (cadr expr) 0))))
202

203
(define-syntax letrec
204
  (er-macro-transformer
205
   (lambda (expr rename compare)
206
     ((lambda (defs)
207
        `((,(rename 'lambda) () ,@defs ,@(cddr expr))))
208
      (map (lambda (x) (cons (rename 'define) x)) (cadr expr))))))
209

210
(define-syntax let
211
  (er-macro-transformer
212
   (lambda (expr rename compare)
213
     (if (null? (cdr expr)) (error "empty let" expr))
214
     (if (null? (cddr expr)) (error "no let body" expr))
215
     ((lambda (bindings)
216
        (if (list? bindings) #f (error "bad let bindings"))
217
        (if (every (lambda (x)
218
                     (if (pair? x) (if (pair? (cdr x)) (null? (cddr x)) #f) #f))
219
                   bindings)
220
            ((lambda (vars vals)
221
               (if (identifier? (cadr expr))
222
                   `((,(rename 'lambda) ,vars
223
                      (,(rename 'letrec) ((,(cadr expr)
224
                                           (,(rename 'lambda) ,vars
225
                                            ,@(cdr (cddr expr)))))
226
                       (,(cadr expr) ,@vars)))
227
                     ,@vals)
228
                   `((,(rename 'lambda) ,vars ,@(cddr expr)) ,@vals)))
229
             (map car bindings)
230
             (map cadr bindings))
231
            (error "bad let syntax" expr)))
232
      (if (identifier? (cadr expr)) (car (cddr expr)) (cadr expr))))))
233

234
(define-syntax let*
235
  (er-macro-transformer
236
   (lambda (expr rename compare)
237
     (if (null? (cdr expr)) (error "empty let*" expr))
238
     (if (null? (cddr expr)) (error "no let* body" expr))
239
     (if (null? (cadr expr))
240
         `(,(rename 'let) () ,@(cddr expr))
241
         (if (if (list? (cadr expr))
242
                 (every
243
                  (lambda (x)
244
                    (if (pair? x) (if (pair? (cdr x)) (null? (cddr x)) #f) #f))
245
                  (cadr expr))
246
                 #f)
247
             `(,(rename 'let) (,(caar (cdr expr)))
248
               (,(rename 'let*) ,(cdar (cdr expr)) ,@(cddr expr)))
249
             (error "bad let* syntax"))))))
250

251
(define-syntax case
252
  (er-macro-transformer
253
   (lambda (expr rename compare)
254
     (define (body exprs)
255
       (cond
256
        ((null? exprs)
257
         (rename 'tmp))
258
        ((compare (rename '=>) (car exprs))
259
         `(,(cadr exprs) ,(rename 'tmp)))
260
        (else
261
         `(,(rename 'begin) ,@exprs))))
262
     (define (clause ls)
263
       (cond
264
        ((null? ls) #f)
265
        ((compare (rename 'else) (caar ls))
266
         (body (cdar ls)))
267
        ((and (pair? (car (car ls))) (null? (cdr (car (car ls)))))
268
         `(,(rename 'if) (,(rename 'eqv?) ,(rename 'tmp)
269
                          (,(rename 'quote) ,(car (caar ls))))
270
           ,(body (cdar ls))
271
           ,(clause (cdr ls))))
272
        (else
273
         `(,(rename 'if) (,(rename 'memv) ,(rename 'tmp)
274
                          (,(rename 'quote) ,(caar ls)))
275
           ,(body (cdar ls))
276
           ,(clause (cdr ls))))))
277
     `(let ((,(rename 'tmp) ,(cadr expr)))
278
        ,(clause (cddr expr))))))
279

280
(define-syntax do
281
  (er-macro-transformer
282
   (lambda (expr rename compare)
283
     (let* ((body
284
             `(,(rename 'begin)
285
               ,@(cdr (cddr expr))
286
               (,(rename 'lp)
287
                ,@(map (lambda (x) (if (pair? (cddr x)) (car (cddr x)) (car x)))
288
                       (cadr expr)))))
289
            (check (car (cddr expr)))
290
            (wrap
291
             (if (null? (cdr check))
292
                 `(,(rename 'let) ((,(rename 'tmp) ,(car check)))
293
                   (,(rename 'if) ,(rename 'tmp)
294
                    ,(rename 'tmp)
295
                    ,body))
296
                 `(,(rename 'if) ,(car check)
297
                   (,(rename 'begin) ,@(cdr check))
298
                   ,body))))
299
       `(,(rename 'let) ,(rename 'lp)
300
         ,(map (lambda (x) (list (car x) (cadr x))) (cadr expr))
301
         ,wrap)))))
302

303
(define-syntax delay-force
304
  (er-macro-transformer
305
   (lambda (expr rename compare)
306
     `(,(rename 'promise) #f (,(rename 'lambda) () ,(cadr expr))))))
307

308
(define-syntax delay
309
  (er-macro-transformer
310
   (lambda (expr rename compare)
311
     `(,(rename 'delay-force) (,(rename 'promise) #t ,(cadr expr))))))
312

313
(define-syntax define-auxiliary-syntax
314
  (er-macro-transformer
315
   (lambda (expr rename compare)
316
     `(,(rename 'define-syntax) ,(cadr expr)
317
       (,(rename 'er-macro-transformer)
318
        (,(rename 'lambda) (expr rename compare)
319
         (,(rename 'error) "invalid use of auxiliary syntax" ',(cadr expr))))))))
320

321
(define-auxiliary-syntax _)
322
(define-auxiliary-syntax =>)
323
(define-auxiliary-syntax ...)
324
(define-auxiliary-syntax else)
325
(define-auxiliary-syntax unquote)
326
(define-auxiliary-syntax unquote-splicing)
327

328
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
329
;; library functions
330

331
;; booleans
332

333
(define (not x) (if x #f #t))
334
(define (boolean? x) (if (eq? x #t) #t (eq? x #f)))
335

336
;; char utils
337

338
(define (char-alphabetic? ch) (<= 65 (char->integer (char-upcase ch)) 90))
339
(define (char-numeric? ch) (<= 48 (char->integer ch) 57))
340
(define (char-whitespace? ch)
341
  (if (eq? ch #\space)
342
      #t
343
      (if (eq? ch #\tab) #t (if (eq? ch #\newline)
344
                                #t
345
                                (if (eq? ch #\xC0) #f (eq? ch #\return))))))
346
(define (char-upper-case? ch) (<= 65 (char->integer ch) 90))
347
(define (char-lower-case? ch) (<= 97 (char->integer ch) 122))
348

349
(define (char=? a b) (= (char->integer a) (char->integer b)))
350
(define (char<? a b) (< (char->integer a) (char->integer b)))
351
(define (char>? a b) (> (char->integer a) (char->integer b)))
352
(define (char<=? a b) (<= (char->integer a) (char->integer b)))
353
(define (char>=? a b) (>= (char->integer a) (char->integer b)))
354

355
(define (char-ci=? a b)
356
  (= (char->integer (char-downcase a)) (char->integer (char-downcase b))))
357
(define (char-ci<? a b)
358
  (< (char->integer (char-downcase a)) (char->integer (char-downcase b))))
359
(define (char-ci>? a b)
360
  (> (char->integer (char-downcase a)) (char->integer (char-downcase b))))
361
(define (char-ci<=? a b)
362
  (<= (char->integer (char-downcase a)) (char->integer (char-downcase b))))
363
(define (char-ci>=? a b)
364
  (>= (char->integer (char-downcase a)) (char->integer (char-downcase b))))
365

366
;; string utils
367

368
(define (digit-char n)
369
  (if (<= n 9)
370
      (integer->char (+ n (char->integer #\0)))
371
      (integer->char (+ (- n 10) (char->integer #\A)))))
372

373
(define (%number->string num)
374
  (call-with-output-string (lambda (out) (write num out))))
375

376
(define (number->string num . o)
377
  (cond
378
   ((not (number? num))
379
    (error "not a number" num))
380
   ((if (null? o) #t (eq? 10 (car o)))
381
    (%number->string num))
382
   (else
383
    (let lp ((n (abs num)) (d (car o)) (res '()))
384
      (if (> n 0)
385
          (lp (quotient n d) d (cons (digit-char (remainder n d)) res))
386
          (if (null? res)
387
              "0"
388
              (list->string (if (negative? num) (cons #\- res) res))))))))
389

390
(define (list->string ls)
391
  (call-with-output-string
392
    (lambda (out) (for-each (lambda (ch) (write-char ch out)) ls))))
393

394
(define (string->list str . o)
395
  (cond
396
   ((null? o)
397
    (let lp ((i (string-cursor-prev str (string-cursor-end str))) (res '()))
398
      (if (< i 0)
399
          res
400
          (lp (string-cursor-prev str i) (cons (string-cursor-ref str i) res)))))
401
   (else
402
    (string->list (apply substring str o)))))
403

404
(define (string-fill! str ch . o)
405
  (let ((start (if (pair? o) (car o) 0))
406
        (end (if (and (pair? o) (pair? (cdr o))) (cadr o) (string-length str))))
407
    (let lp ((i (- end 1)))
408
      (if (>= i start) (begin (string-set! str i ch) (lp (- i 1)))))))
409

410
(define (string . args) (list->string args))
411
(define (string-append . args) (string-concatenate args))
412

413
(define (string=? s1 s2) (eq? (string-cmp s1 s2 #f) 0))
414
(define (string<? s1 s2) (< (string-cmp s1 s2 #f) 0))
415
(define (string<=? s1 s2) (<= (string-cmp s1 s2 #f) 0))
416
(define (string>? s1 s2) (> (string-cmp s1 s2 #f) 0))
417
(define (string>=? s1 s2) (>= (string-cmp s1 s2 #f) 0))
418

419
(define (string-ci=? s1 s2) (eq? (string-cmp s1 s2 #t) 0))
420
(define (string-ci<? s1 s2) (< (string-cmp s1 s2 #t) 0))
421
(define (string-ci<=? s1 s2) (<= (string-cmp s1 s2 #t) 0))
422
(define (string-ci>? s1 s2) (> (string-cmp s1 s2 #t) 0))
423
(define (string-ci>=? s1 s2) (>= (string-cmp s1 s2 #t) 0))
424

425
;; list utils
426

427
(define (member obj ls . o)
428
  (let ((eq (if (pair? o) (car o) equal?)))
429
    (let lp ((ls ls))
430
      (and (pair? ls) (if (eq obj (car ls)) ls (lp (cdr ls)))))))
431

432
(define memv member)
433

434
(define (assoc obj ls . o)
435
  (let ((eq (if (pair? o) (car o) equal?)))
436
    (let assoc ((ls ls))
437
      (cond ((null? ls) #f)
438
            ((eq obj (caar ls)) (car ls))
439
            (else (assoc (cdr ls)))))))
440

441
(define assv assoc)
442

443
(define (find-tail pred ls)
444
  (and (pair? ls) (if (pred (car ls)) ls (find-tail pred (cdr ls)))))
445

446
(define (find pred ls)
447
  (cond ((find-tail pred ls) => car) (else #f)))
448

449
;; vector utils
450

451
(define (vector-copy vec . o)
452
  (let* ((start (if (pair? o) (car o) 0))
453
         (end (if (and (pair? o) (pair? (cdr o))) (cadr o) (vector-length vec)))
454
         (res (make-vector (- end start))))
455
    (do ((i 0 (+ i 1)) (j start (+ j 1))) ((>= j end) res)
456
      (vector-set! res i (vector-ref vec j)))))
457

458
(define (list->vector ls)
459
  (let ((vec (make-vector (length ls) #f)))
460
    (let lp ((ls ls) (i 0))
461
      (if (pair? ls)
462
          (begin
463
            (vector-set! vec i (car ls))
464
            (lp (cdr ls) (+ i 1)))))
465
    vec))
466

467
(define (vector->list vec . o)
468
  (let ((start (if (pair? o) (car o) 0))
469
        (end (if (and (pair? o) (pair? (cdr o))) (cadr o) (vector-length vec))))
470
    (let lp ((i (- end 1)) (res '()))
471
      (if (< i start) res (lp (- i 1) (cons (vector-ref vec i) res))))))
472

473
(define (vector-fill! vec ch . o)
474
  (let ((start (if (pair? o) (car o) 0))
475
        (end (if (and (pair? o) (pair? (cdr o))) (cadr o) (vector-length vec))))
476
    (let lp ((i (- end 1)))
477
      (if (>= i start) (begin (vector-set! vec i ch) (lp (- i 1)))))))
478

479
(define (vector . args) (list->vector args))
480

481
;; I/O utils
482

483
(define (display x . o)
484
  (let ((out (if (pair? o) (car o) (current-output-port))))
485
    (cond ((char? x) (write-char x out))
486
          ((string? x) (%write-string x #t out))
487
          (else (write x out)))))
488

489
(define (newline . o)
490
  (write-char #\newline (if (pair? o) (car o) (current-output-port))))
491

492
(define (port? x) (or (input-port? x) (output-port? x)))
493

494
(define textual-port? port?)
495

496
(define (call-with-input-string str proc)
497
  (let* ((in (open-input-string str))
498
         (res (proc in)))
499
    (close-input-port in)
500
    res))
501

502
(define (call-with-output-string proc)
503
  (let ((out (open-output-string)))
504
    (proc out)
505
    (let ((res (get-output-string out)))
506
      (close-output-port out)
507
      res)))
508

509
(define (call-with-input-file file proc)
510
  (let* ((in (open-input-file file))
511
         (res (proc in)))
512
    (close-input-port in)
513
    res))
514

515
(define (call-with-output-file file proc)
516
  (let* ((out (open-output-file file))
517
         (res (proc out)))
518
    (close-output-port out)
519
    res))
520

521
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
522
;; values
523

524
(define *values-tag* (list 'values))
525

526
(define (%values ls)
527
  (if (and (pair? ls) (null? (cdr ls)))
528
      (car ls)
529
      (cons *values-tag* ls)))
530

531
(define (values . ls) (%values ls))
532

533
(define (call-with-values producer consumer)
534
  (let ((res (producer)))
535
    (if (and (pair? res) (eq? *values-tag* (car res)))
536
        (apply consumer (cdr res))
537
        (consumer res))))
538

539
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
540
;; SRFI-0
541

542
(define-syntax cond-expand
543
  (er-macro-transformer
544
   (lambda (expr rename compare)
545
     (define (check x)
546
       (if (pair? x)
547
           (case (car x)
548
             ((and) (every check (cdr x)))
549
             ((or) (any check (cdr x)))
550
             ((not) (not (check (cadr x))))
551
             ((library) (eval `(find-module ',(cadr x)) (%meta-env)))
552
             (else (error "cond-expand: bad feature" x)))
553
           (memq (identifier->symbol x) *features*)))
554
     (let expand ((ls (cdr expr)))
555
       (cond ((null? ls))  ; (error "cond-expand: no expansions" expr)
556
             ((not (pair? (car ls))) (error "cond-expand: bad clause" (car ls)))
557
             ((eq? 'else (identifier->symbol (caar ls)))
558
              (if (pair? (cdr ls))
559
                  (error "cond-expand: else in non-final position")
560
                  `(,(rename 'begin) ,@(cdar ls))))
561
             ((check (caar ls)) `(,(rename 'begin) ,@(cdar ls)))
562
             (else (expand (cdr ls))))))))
563

564
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
565
;; dynamic-wind
566

567
(cond-expand
568
 (threads)
569
 (else
570
  (define %dk
571
    (let ((dk (list #f)))
572
      (lambda o (if (pair? o) (set! dk (car o)) dk))))))
573

574
(define (dynamic-wind before thunk after)
575
  (let ((dk (%dk)))
576
    (set-dk! (cons (cons before after) dk))
577
    (let ((res (thunk))) (set-dk! dk) res)))
578

579
;; TODO: Implement a non-mutating tree oriented stack so we don't need
580
;; to reset the stack in child threads.
581
(define (set-dk! new-dk)
582
  (if (not (eq? new-dk (%dk)))
583
      (begin
584
        (set-dk! (cdr new-dk))
585
        (let ((before (car (car new-dk)))
586
	      (old-dk (%dk)))
587
          (set-car! old-dk (cons (cdr (car new-dk)) before))
588
          (set-cdr! old-dk new-dk)
589
          (set-car! new-dk #f)
590
          (set-cdr! new-dk '())
591
          (%dk new-dk)
592
          (before)))))
593

594
(define (call-with-current-continuation proc)
595
  (let ((dk (%dk)))
596
    (%call/cc (lambda (k) (proc (lambda x (set-dk! dk) (k (%values x))))))))
597

598
(define (with-input-from-file file thunk)
599
  (let ((old-in (current-input-port))
600
        (tmp-in (open-input-file file)))
601
    (dynamic-wind
602
      (lambda () (current-input-port tmp-in))
603
      (lambda () (let ((res (thunk))) (close-input-port tmp-in) res))
604
      (lambda () (current-input-port old-in)))))
605

606
(define (with-output-to-file file thunk)
607
  (let ((old-out (current-output-port))
608
        (tmp-out (open-output-file file)))
609
    (dynamic-wind
610
      (lambda () (current-output-port tmp-out))
611
      (lambda () (let ((res (thunk))) (close-output-port tmp-out) res))
612
      (lambda () (current-output-port old-out)))))
613

614
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
615
;; syntax-rules
616

617
(define-syntax syntax-rules
618
  (er-macro-transformer
619
   (lambda (expr rename compare)
620
     (let ((ellipsis-specified? (identifier? (cadr expr)))
621
           (count 0)
622
           (_er-macro-transformer (rename 'er-macro-transformer))
623
           (_lambda (rename 'lambda))      (_let (rename 'let))
624
           (_begin (rename 'begin))        (_if (rename 'if))
625
           (_and (rename 'and))            (_or (rename 'or))
626
           (_eq? (rename 'eq?))            (_equal? (rename 'equal?))
627
           (_car (rename 'car))            (_cdr (rename 'cdr))
628
           (_cons (rename 'cons))          (_pair? (rename 'pair?))
629
           (_null? (rename 'null?))        (_expr (rename 'expr))
630
           (_rename (rename 'rename))      (_compare (rename 'compare))
631
           (_quote (rename 'syntax-quote)) (_apply (rename 'apply))
632
           (_append (rename 'append))      (_map (rename 'map))
633
           (_vector? (rename 'vector?))    (_list? (rename 'list?))
634
           (_len (rename'len))             (_length (rename 'length))
635
           (_- (rename '-))   (_>= (rename '>=))   (_error (rename 'error))
636
           (_ls (rename 'ls)) (_res (rename 'res)) (_i (rename 'i))
637
           (_reverse (rename 'reverse))
638
           (_vector->list (rename 'vector->list))
639
           (_list->vector (rename 'list->vector))
640
           (_cons3 (rename 'cons-source)))
641
       (define ellipsis (rename (if ellipsis-specified? (cadr expr) '...)))
642
       (define lits (if ellipsis-specified? (car (cddr expr)) (cadr expr)))
643
       (define forms (if ellipsis-specified? (cdr (cddr expr)) (cddr expr)))
644
       (define (next-symbol s)
645
         (set! count (+ count 1))
646
         (rename (string->symbol (string-append s (%number->string count)))))
647
       (define (expand-pattern pat tmpl)
648
         (let lp ((p (cdr pat))
649
                  (x (list _cdr _expr))
650
                  (dim 0)
651
                  (vars '())
652
                  (k (lambda (vars)
653
                       (list _cons (expand-template tmpl vars) #f))))
654
           (let ((v (next-symbol "v.")))
655
             (list
656
              _let (list (list v x))
657
              (cond
658
               ((identifier? p)
659
                (if (any (lambda (l) (compare p l)) lits)
660
                    (list _and
661
                          (list _compare v (list _rename (list _quote p)))
662
                          (k vars))
663
                    (list _let (list (list p v)) (k (cons (cons p dim) vars)))))
664
               ((ellipsis? p)
665
                (cond
666
                 ((not (null? (cdr (cdr p))))
667
                  (cond
668
                   ((any (lambda (x) (and (identifier? x) (compare x ellipsis)))
669
                         (cddr p))
670
                    (error "multiple ellipses" p))
671
                   (else
672
                    (let ((len (length* (cdr (cdr p))))
673
                          (_lp (next-symbol "lp.")))
674
                      `(,_let ((,_len (,_length ,v)))
675
                         (,_and (,_>= ,_len ,len)
676
                                (,_let ,_lp ((,_ls ,v)
677
                                             (,_i (,_- ,_len ,len))
678
                                             (,_res (,_quote ())))
679
                                  (,_if (,_>= 0 ,_i)
680
                                      ,(lp `(,(cddr p)
681
                                             (,(car p) ,(car (cdr p))))
682
                                           `(,_cons ,_ls
683
                                                    (,_cons (,_reverse ,_res)
684
                                                            (,_quote ())))
685
                                           dim
686
                                           vars
687
                                           k)
688
                                      (,_lp (,_cdr ,_ls)
689
                                            (,_- ,_i 1)
690
                                            (,_cons3 (,_car ,_ls)
691
                                                     ,_res
692
                                                     ,_ls))))))))))
693
                 ((identifier? (car p))
694
                  (list _and (list _list? v)
695
                        (list _let (list (list (car p) v))
696
                              (k (cons (cons (car p) (+ 1 dim)) vars)))))
697
                 (else
698
                  (let* ((w (next-symbol "w."))
699
                         (_lp (next-symbol "lp."))
700
                         (new-vars (all-vars (car p) (+ dim 1)))
701
                         (ls-vars (map (lambda (x)
702
                                         (next-symbol
703
                                          (string-append
704
                                           (symbol->string
705
                                            (identifier->symbol (car x)))
706
                                           "-ls")))
707
                                       new-vars))
708
                         (once
709
                          (lp (car p) (list _car w) (+ dim 1) '()
710
                              (lambda (_)
711
                                (cons
712
                                 _lp
713
                                 (cons
714
                                  (list _cdr w)
715
                                  (map (lambda (x l)
716
                                         (list _cons (car x) l))
717
                                       new-vars
718
                                       ls-vars)))))))
719
                    (list
720
                     _let
721
                     _lp (cons (list w v)
722
                               (map (lambda (x) (list x (list _quote '()))) ls-vars))
723
                     (list _if (list _null? w)
724
                           (list _let (map (lambda (x l)
725
                                             (list (car x) (list _reverse l)))
726
                                           new-vars
727
                                           ls-vars)
728
                                 (k (append new-vars vars)))
729
                           (list _and (list _pair? w) once)))))))
730
               ((pair? p)
731
                (list _and (list _pair? v)
732
                      (lp (car p)
733
                          (list _car v)
734
                          dim
735
                          vars
736
                          (lambda (vars)
737
                            (lp (cdr p) (list _cdr v) dim vars k)))))
738
               ((vector? p)
739
                (list _and
740
                      (list _vector? v)
741
                      (lp (vector->list p) (list _vector->list v) dim vars k)))
742
               ((null? p) (list _and (list _null? v) (k vars)))
743
               (else (list _and (list _equal? v p) (k vars))))))))
744
       (define (ellipsis-escape? x) (and (pair? x) (compare ellipsis (car x))))
745
       (define (ellipsis? x)
746
         (and (pair? x) (pair? (cdr x)) (compare ellipsis (cadr x))))
747
       (define (ellipsis-depth x)
748
         (if (ellipsis? x)
749
             (+ 1 (ellipsis-depth (cdr x)))
750
             0))
751
       (define (ellipsis-tail x)
752
         (if (ellipsis? x)
753
             (ellipsis-tail (cdr x))
754
             (cdr x)))
755
       (define (all-vars x dim)
756
         (let lp ((x x) (dim dim) (vars '()))
757
           (cond ((identifier? x)
758
                  (if (any (lambda (lit) (compare x lit)) lits)
759
                      vars
760
                      (cons (cons x dim) vars)))
761
                 ((ellipsis? x) (lp (car x) (+ dim 1) (lp (cddr x) dim vars)))
762
                 ((pair? x) (lp (car x) dim (lp (cdr x) dim vars)))
763
                 ((vector? x) (lp (vector->list x) dim vars))
764
                 (else vars))))
765
       (define (free-vars x vars dim)
766
         (let lp ((x x) (free '()))
767
           (cond
768
            ((identifier? x)
769
             (if (and (not (memq x free))
770
                      (cond ((assq x vars) => (lambda (cell) (>= (cdr cell) dim)))
771
                            (else #f)))
772
                 (cons x free)
773
                 free))
774
            ((pair? x) (lp (car x) (lp (cdr x) free)))
775
            ((vector? x) (lp (vector->list x) free))
776
            (else free))))
777
       (define (expand-template tmpl vars)
778
         (let lp ((t tmpl) (dim 0))
779
           (cond
780
            ((identifier? t)
781
             (cond
782
              ((find (lambda (v) (compare t (car v))) vars)
783
               => (lambda (cell)
784
                    (if (<= (cdr cell) dim)
785
                        t
786
                        (error "too few ...'s"))))
787
              (else
788
               (list _rename (list _quote t)))))
789
            ((pair? t)
790
             (cond
791
              ((ellipsis-escape? t)
792
               (list _quote
793
                     (if (pair? (cdr t))
794
                         (if (pair? (cddr t)) (cddr t) (cadr t))
795
                         (cdr t))))
796
              ((ellipsis? t)
797
               (let* ((depth (ellipsis-depth t))
798
                      (ell-dim (+ dim depth))
799
                      (ell-vars (free-vars (car t) vars ell-dim)))
800
                 (cond
801
                  ((null? ell-vars)
802
                   (error "too many ...'s"))
803
                  ((and (null? (cdr (cdr t))) (identifier? (car t)))
804
                   ;; shortcut for (var ...)
805
                   (lp (car t) depth))
806
                  (else
807
                   (let* ((once (lp (car t) ell-dim))
808
                          (nest (if (and (null? (cdr ell-vars))
809
                                         (identifier? once)
810
                                         (eq? once (car vars)))
811
                                    once ;; shortcut
812
                                    (cons _map
813
                                          (cons (list _lambda ell-vars once)
814
                                                ell-vars))))
815
                          (many (do ((d depth (- d 1))
816
                                     (many nest
817
                                           (list _apply _append many)))
818
                                    ((= d 1) many))))
819
                     (if (null? (ellipsis-tail t))
820
                         many ;; shortcut
821
                         (list _append many (lp (ellipsis-tail t) dim))))))))
822
              (else (list _cons3 (lp (car t) dim) (lp (cdr t) dim) (list _quote t)))))
823
            ((vector? t) (list _list->vector (lp (vector->list t) dim)))
824
            ((null? t) (list _quote '()))
825
            (else t))))
826
       (list
827
        _er-macro-transformer
828
        (list _lambda (list _expr _rename _compare)
829
              (list
830
               _car
831
               (cons
832
                _or
833
                (append
834
                 (map
835
                  (lambda (clause) (expand-pattern (car clause) (cadr clause)))
836
                  forms)
837
                 (list
838
                  (list _cons
839
                        (list _error "no expansion for"
840
                              (list (rename 'strip-syntactic-closures) _expr))
841
                        #f)))))))))))
842

843
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
844
;; additional syntax
845

846
(define-syntax syntax-error
847
  (er-macro-transformer
848
   (lambda (expr rename compare)
849
     (apply error (cdr expr)))))
850

851
(define-syntax letrec*
852
  (syntax-rules ()
853
    ((letrec* ((var val) ...) . body)
854
     (let () (define var val) ... . body))))
855

856
(define-syntax let-optionals*
857
  (syntax-rules ()
858
    ((let-optionals* opt-ls () . body)
859
     (begin . body))
860
    ((let-optionals* (op . args) vars . body)
861
     (let ((tmp (op . args)))
862
       (let-optionals* tmp vars . body)))
863
    ((let-optionals* tmp ((var default) . rest) . body)
864
     (let ((var (if (pair? tmp) (car tmp) default))
865
           (tmp2 (if (pair? tmp) (cdr tmp) '())))
866
       (let-optionals* tmp2 rest . body)))
867
    ((let-optionals* tmp tail . body)
868
     (let ((tail tmp)) . body))))
869

870
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
871
;; exceptions
872

873
(define *continuable* (list 'continuable))
874

875
(define (raise-continuable exn)
876
  (raise (list *continuable* exn)))
877

878
(define (%with-exception-handler handler thunk)
879
  (let* ((old (thread-parameters))
880
         (new (cons (cons current-exception-handler handler) old)))
881
    (dynamic-wind
882
      (lambda () (thread-parameters-set! new))
883
      thunk
884
      (lambda () (thread-parameters-set! old)))))
885

886
(define (with-exception-handler handler thunk)
887
  (letrec ((orig-handler (current-exception-handler))
888
           (self (lambda (exn)
889
                   (%with-exception-handler orig-handler
890
                     (lambda ()
891
                       (cond
892
                        ((and (pair? exn) (eq? *continuable* (car exn)))
893
                         (handler (cadr exn)))
894
                        (else
895
                         (handler exn)
896
                         (error "exception handler returned"))))))))
897
    (%with-exception-handler self thunk)))
898

899
(define-syntax guard
900
  (syntax-rules ()
901
    ((guard (var clause ...) e1 e2 ...)
902
     ((call-with-current-continuation
903
       (lambda (guard-k)
904
         (with-exception-handler
905
          (lambda (condition)
906
            ((call-with-current-continuation
907
              (lambda (handler-k)
908
                (guard-k
909
                 (lambda ()
910
                   (let ((var condition))
911
                     (guard-aux (handler-k (lambda ()
912
                                             (raise-continuable condition)))
913
                                clause ...))))))))
914
          (lambda ()
915
            (call-with-values (lambda () e1 e2 ...)
916
              (lambda args
917
                (guard-k (lambda () (apply values args)))))))))))))
918

919
(define-syntax guard-aux
920
  (syntax-rules (else =>)
921
    ((guard-aux reraise (else result1 result2 ...))
922
     (begin result1 result2 ...))
923
    ((guard-aux reraise (test => result))
924
     (let ((temp test))
925
       (if temp (result temp) reraise)))
926
    ((guard-aux reraise (test => result) clause1 clause2 ...)
927
     (let ((temp test))
928
       (if temp (result temp) (guard-aux reraise clause1 clause2 ...))))
929
    ((guard-aux reraise (test))
930
     (or test reraise))
931
    ((guard-aux reraise (test) clause1 clause2 ...)
932
     (or test (guard-aux reraise clause1 clause2 ...)))
933
    ((guard-aux reraise (test result1 result2 ...))
934
     (if test (begin result1 result2 ...) reraise))
935
    ((guard-aux reraise (test result1 result2 ...) clause1 clause2 ...)
936
     (if test
937
         (begin result1 result2 ...)
938
         (guard-aux reraise clause1 clause2 ...)))))
939

940
(define (eval x . o)
941
  (let ((thunk (compile x (if (pair? o) (car o) (interaction-environment)))))
942
    (if (procedure? thunk) (thunk) (raise thunk))))
943

944
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
945
;; promises
946

947
(cond-expand
948
 (auto-force
949
  )
950
 (else
951
  (define (promise done? proc)
952
    (list (cons done? proc)))
953
  (define (promise-done? x) (car (car x)))
954
  (define (promise-value x) (cdr (car x)))
955
  (define (promise-update! new old)
956
    (set-car! (car old) (promise-done? new))
957
    (set-cdr! (car old) (promise-value new))
958
    (set-car! new (car old)))
959
  (define (force promise)
960
    (if (promise-done? promise)
961
        (promise-value promise)
962
        (let ((promise* ((promise-value promise))))
963
          (if (not (promise-done? promise))
964
            (promise-update! promise* promise))
965
          (force promise))))))
966

967
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
968
;; math utils
969

970
(cond-expand
971
 (complex
972
  (define (exact-complex? x)
973
    (and (%complex? x) (exact? (complex-real x)) (exact? (complex-imag x)))))
974
 (else
975
  (define (exact-complex? x) #f)))
976

977
(cond-expand
978
 (ratios
979
  (cond-expand
980
   (complex
981
    (define (exact? x)
982
      (if (fixnum? x)
983
          #t
984
          (if (bignum? x) #t (if (ratio? x) #t (exact-complex? x))))))
985
   (else
986
    (define (exact? x) (if (fixnum? x) #t (if (bignum? x) #t (ratio? x))))))
987
  (define (numerator x)
988
    (if (ratio? x)
989
        (ratio-numerator x)
990
        (if (inexact? x) (ratio-numerator (inexact->exact x)) x)))
991
  (define (denominator x)
992
    (if (exact? x)
993
        (if (ratio? x) (ratio-denominator x) 1)
994
        (if (integer? x) 1 (ratio-denominator (inexact->exact x))))))
995
 (else
996
  (cond-expand
997
   (complex
998
    (define (exact? x)
999
      (if (fixnum? x) #t (if (bignum? x) #t (exact-complex? x)))))
1000
   (else
1001
    (define (exact? x) (if (fixnum? x) #t (bignum? x)))))
1002
  (define (numerator x)
1003
    (if (integer? x) x (numerator (* x 10))))
1004
  (define (denominator x)
1005
    (if (exact? x)
1006
        1
1007
        (let lp ((x x) (r 1.0)) (if (integer? x) r (lp (* x 10) (* r 10))))))))
1008

1009
(cond-expand
1010
 (complex
1011
  (define (inexact? x)
1012
    (if (flonum? x) #t (and (%complex? x) (not (exact-complex? x))))))
1013
 (else (define inexact? flonum?)))
1014
(define (exact-integer? x) (if (fixnum? x) #t (bignum? x)))
1015
(define (integer? x)
1016
  (if (exact-integer? x) #t (and (flonum? x) (= x (truncate x)))))
1017
(define (number? x) (if (inexact? x) #t (exact? x)))
1018
(define complex? number?)
1019
(cond-expand
1020
 (complex (define (real? x) (and (number? x) (not (%complex? x)))))
1021
 (else (define real? number?)))
1022
(define (rational? x)
1023
  (and (real? x) (= x x) (not (= x (+ x (if (positive? x) 1 -1))))))
1024

1025
(define (eqv? a b) (if (eq? a b) #t (and (number? a) (equal? a b))))
1026

1027
(define (exact-integer-sqrt x)
1028
  (let ((res (sqrt x)))
1029
    (if (exact? res)
1030
        (values res 0)
1031
        (let ((res (inexact->exact (truncate res))))
1032
          (values res (- x (* res res)))))))
1033

1034
(define (zero? x) (= x 0))
1035
(define (positive? x) (> x 0))
1036
(define (negative? x) (< x 0))
1037
(define (even? n) (= (remainder n 2) 0))
1038
(define (odd? n) (= (abs (remainder n 2)) 1))
1039

1040
(define (abs x) (if (< x 0) (- x) x))
1041

1042
(define (modulo a b)
1043
  (let ((res (remainder a b)))
1044
    (if (< b 0)
1045
        (if (<= res 0) res (+ res b))
1046
        (if (>= res 0) res (+ res b)))))
1047

1048
(define (gcd2 a b)
1049
  (if (= b 0)
1050
      (abs a)
1051
      (gcd b (remainder a b))))
1052

1053
(define (gcd . args)
1054
  (if (null? args)
1055
      0
1056
      (let lp ((x (car args)) (ls (cdr args)))
1057
        (if (null? ls) x (lp (gcd2 x (car ls)) (cdr ls))))))
1058

1059
(define (lcm2 a b)
1060
  (abs (quotient (* a b) (gcd a b))))
1061

1062
(define (lcm . args)
1063
  (if (null? args)
1064
      1
1065
      (let lp ((x (car args)) (ls (cdr args)))
1066
        (if (null? ls) x (lp (lcm2 x (car ls)) (cdr ls))))))
1067

1068
(define (max x . rest)
1069
  (let lp ((hi x) (ls rest))
1070
    (if (null? ls)
1071
        hi
1072
        (lp (if (> (car ls) hi) (car ls) hi) (cdr ls)))))
1073

1074
(define (min x . rest)
1075
  (let lp ((lo x) (ls rest))
1076
    (if (null? ls)
1077
        lo
1078
        (lp (if (< (car ls) lo) (car ls) lo) (cdr ls)))))
1079

1080
(cond-expand
1081
 (complex
1082
  (define (real-part z) (if (%complex? z) (complex-real z) z))
1083
  (define (imag-part z) (if (%complex? z) (complex-imag z) 0.0))
1084
  (define (magnitude z)
1085
    (sqrt (+ (* (real-part z) (real-part z))
1086
             (* (imag-part z) (imag-part z)))))
1087
  (define (angle z) (atan (imag-part z) (real-part z)))
1088
  (define (make-rectangular x y)
1089
    (+ x (* y (sqrt -1))))
1090
  (define (make-polar r phi)
1091
    (make-rectangular (* r (cos phi)) (* r (sin phi)))))
1092
 (else
1093
  (define (real-part z) z)
1094
  (define (imag-part z) 0.0)
1095
  (define magnitude abs)
1096
  (define (angle z) (if (< z 0) 3.141592653589793 0))))
1097

1098
(define (log x . o)
1099
  (if (pair? o) (/ (ln x) (ln (car o))) (ln x)))
1100

1101
(define (atan y . o)
1102
  (if (null? o)
1103
      (atan1 y)
1104
      (let ((x (exact->inexact (car o))))
1105
        (if (negative? x)
1106
            (if (negative? y)
1107
                (- (atan1 (/ y x)) 3.141592653589793)
1108
                (- 3.141592653589793 (atan1 (/ y (- x)))))
1109
            (atan1 (/ y x))))))
1110

1111
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1112
;; string cursors
1113

1114
(define string-cursor<? <)
1115
(define string-cursor<=? <=)
1116
(define string-cursor>? >)
1117
(define string-cursor>=? >=)
1118
(define string-cursor=? =)
1119

1120
(define (string-cursor-start s) 0)
1121

1122
(define (string-copy str . o)
1123
  (apply substring str (if (pair? o) o '(0))))
1124

1125
(cond-expand
1126
 (full-unicode
1127
  (define string-cursor-end string-size))
1128
 (else
1129
  (define (string-index->offset str i) i)
1130
  (define string-size string-length)
1131
  (define substring-cursor substring)
1132
  (define string-cursor-end string-length)
1133
  (define string-cursor-ref string-ref)
1134
  (define (string-cursor-next s i) (+ i 1))
1135
  (define (string-cursor-prev s i) (- i 1))))
1136