ref: 0379b2da811c64c690aa35fb99f0a115aa7919e0
parent: c20c2ac58ef854e50225ef34f01ceda5ae511956
author: Sigrid Solveig Haflínudóttir <sigrid@ftrv.se>
date: Tue Nov 5 16:00:50 EST 2024
scheme/lisp files: tabs to spaces, remove trailing whitespace
--- a/3rd/utf/runeistypedata
+++ b/3rd/utf/runeistypedata
@@ -1108,7 +1108,6 @@
3691,3691,3691,3691,3691,3691,3691,3691,3691,3691,3691,3691,3691,3691,3691,3691,
3691,3691,3691,3691,3691,3691,3691,3691,3691,3691,3691,3691,3691,3691,3691,3691,
3691,3691,3691,3691,3691,3691,3691,3691,3691,3691,3691,3691,3691,3691,3691,3691,
-
};
#define mergedindex1(x) (((x)>>(4+6))&0x7FF)
--- a/3rd/utf/runetotypedata
+++ b/3rd/utf/runetotypedata
@@ -283,7 +283,6 @@
1467,1467,1467,1467,1467,1467,1467,1467,1467,1467,1467,1467,1467,1467,1467,1467,
1467,1467,1467,1467,1467,1467,1467,1467,1467,1467,1467,1467,1467,1467,1467,1467,
1467,1467,1467,1467,1467,1467,1467,1467,1467,1467,1467,1467,1467,1467,1467,1467,
-
};
#define upperindex1(x) (((x)>>(4+7))&0x3FF)
@@ -564,7 +563,6 @@
1396,1396,1396,1396,1396,1396,1396,1396,1396,1396,1396,1396,1396,1396,1396,1396,
1396,1396,1396,1396,1396,1396,1396,1396,1396,1396,1396,1396,1396,1396,1396,1396,
1396,1396,1396,1396,1396,1396,1396,1396,1396,1396,1396,1396,1396,1396,1396,1396,
-
};
#define lowerindex1(x) (((x)>>(4+7))&0x3FF)
@@ -792,7 +790,6 @@
508,508,508,508,536,664,724,724,724,724,724,724,724,724,724,736,
854,946,1026,1142,1156,1156,1156,1156,1156,1156,1156,1156,1156,1182,1286,1286,
1286,1286,1286,1286,1286,1286,1286,1286,1286,1286,1286,1286,1286,1396,1417,1417,
- 1417,1417,1417,1417,1417,1417,1417,1417,1417,1417,1417,1417,1417,1417,1417,1417,
1417,1417,1417,1417,1417,1417,1417,1417,1417,1417,1417,1417,1417,1417,1417,1417,
1417,1417,1417,1417,1417,1417,1417,1417,1417,1417,1417,1417,1417,1417,1417,1417,
1417,1417,1417,1417,1417,1417,1417,1417,1417,1417,1417,1417,1417,1417,1417,1417,
@@ -852,7 +849,7 @@
1417,1417,1417,1417,1417,1417,1417,1417,1417,1417,1417,1417,1417,1417,1417,1417,
1417,1417,1417,1417,1417,1417,1417,1417,1417,1417,1417,1417,1417,1417,1417,1417,
1417,1417,1417,1417,1417,1417,1417,1417,1417,1417,1417,1417,1417,1417,1417,1417,
-
+ 1417,1417,1417,1417,1417,1417,1417,1417,1417,1417,1417,1417,1417,1417,1417,1417,
};
#define titleindex1(x) (((x)>>(4+7))&0x3FF)
--- a/aliases.scm
+++ b/aliases.scm
@@ -7,10 +7,10 @@
(define (set-symbol-value! s v) (set-top-level-value! s v))
(define (eval x)
((compile-thunk (expand
- (if (and (pair? x)
- (equal? (car x) "noexpand"))
- (cadr x)
- x)))))
+ (if (and (pair? x)
+ (equal? (car x) "noexpand"))
+ (cadr x)
+ x)))))
(define (command-line) *argv*)
(define gensym
@@ -134,20 +134,20 @@
(define get-datum read)
(define (put-datum port x)
(with-bindings ((*print-readably* #t))
- (write x port)))
+ (write x port)))
(define (put-u8 port o) (io-write port (uint8 o)))
(define (put-string port s (start 0) (count #f))
(let* ((end (if count
- (+ start count)
- (string-length s))))
+ (+ start count)
+ (string-length s))))
(io-write port (string-sub s start (- end start)))))
(define (io-skipws s)
(let ((c (io-peekc s)))
(if (and (not (eof-object? c)) (char-whitespace? c))
- (begin (io-getc s)
- (io-skipws s)))))
+ (begin (io-getc s)
+ (io-skipws s)))))
(define (with-output-to-file name thunk)
(let ((f (file name :write :create :truncate)))
@@ -164,12 +164,12 @@
(define (call-with-input-file name proc)
(let ((f (open-input-file name)))
(prog1 (proc f)
- (io-close f))))
+ (io-close f))))
(define (call-with-output-file name proc)
(let ((f (open-output-file name)))
(prog1 (proc f)
- (io-close f))))
+ (io-close f))))
(define (file-exists? f) (path-exists? f))
(define (delete-file name) (void)) ; TODO
@@ -178,8 +178,8 @@
(with-output-to port (princ x))
#t)
-(define assertion-violation
- (lambda args
+(define assertion-violation
+ (lambda args
(display 'assertion-violation)
(newline)
(display args)
@@ -197,8 +197,8 @@
(define (assp pred lst)
(cond ((atom? lst) #f)
- ((pred (caar lst)) (car lst))
- (else (assp pred (cdr lst)))))
+ ((pred (caar lst)) (car lst))
+ (else (assp pred (cdr lst)))))
(define (for-all proc l . ls)
(or (null? l)
@@ -209,7 +209,7 @@
(define (exists proc l . ls)
(and (not (null? l))
(or (apply proc (car l) (map car ls))
- (apply exists proc (cdr l) (map cdr ls)))))
+ (apply exists proc (cdr l) (map cdr ls)))))
(define ormap exists)
(define cons* list*)
@@ -227,27 +227,27 @@
(define (dynamic-wind before thunk after)
(before)
(unwind-protect (thunk)
- (after)))
+ (after)))
(let ((*properties* (table)))
(set! putprop
- (lambda (sym key val)
- (let ((sp (get *properties* sym #f)))
- (if (not sp)
- (let ((t (table)))
- (put! *properties* sym t)
- (set! sp t)))
- (put! sp key val))))
+ (lambda (sym key val)
+ (let ((sp (get *properties* sym #f)))
+ (if (not sp)
+ (let ((t (table)))
+ (put! *properties* sym t)
+ (set! sp t)))
+ (put! sp key val))))
(set! getprop
- (lambda (sym key)
- (let ((sp (get *properties* sym #f)))
- (and sp (get sp key #f)))))
+ (lambda (sym key)
+ (let ((sp (get *properties* sym #f)))
+ (and sp (get sp key #f)))))
(set! remprop
- (lambda (sym key)
- (let ((sp (get *properties* sym #f)))
- (and sp (has? sp key) (del! sp key))))))
+ (lambda (sym key)
+ (let ((sp (get *properties* sym #f)))
+ (and sp (has? sp key) (del! sp key))))))
; --- gambit
@@ -260,7 +260,7 @@
(define (include f) (load f))
(define (with-exception-catcher hand thk)
(trycatch (thk)
- (lambda (e) (hand e))))
+ (lambda (e) (hand e))))
(define (current-exception-handler)
; close enough
--- a/compiler.lsp
+++ b/compiler.lsp
@@ -8,67 +8,67 @@
; get an index for a referenced value in a bytecode object
(define (bcode:indexfor b v)
(let ((const-to-idx (bcode:ctable b))
- (nconst (bcode:nconst b)))
+ (nconst (bcode:nconst b)))
(if (has? const-to-idx v)
- (get const-to-idx v)
- (begin (put! const-to-idx v nconst)
- (prog1 nconst
- (aset! b 2 (+ nconst 1)))))))
+ (get const-to-idx v)
+ (begin (put! const-to-idx v nconst)
+ (prog1 nconst
+ (aset! b 2 (+ nconst 1)))))))
(define (emit e inst . args)
(if (null? args)
(if (and (eq? inst 'car) (pair? (aref e 0))
- (eq? (car (aref e 0)) 'cdr))
- (set-car! (aref e 0) 'cadr)
- (aset! e 0 (cons inst (aref e 0))))
- (begin
- (if (memq inst '(loadv loadg setg))
- (set! args (list (bcode:indexfor e (car args)))))
- (let ((longform
- (assq inst '((loadv loadv.l) (loadg loadg.l) (setg setg.l)
- (loada loada.l) (seta seta.l)))))
- (if (and longform
- (> (car args) 255))
- (set! inst (cadr longform))))
- (let ((longform
- (assq inst '((loadc loadc.l) (setc setc.l)))))
- (if (and longform
- (or (> (car args) 255)
- (> (cadr args) 255)))
- (set! inst (cadr longform))))
- (if (eq? inst 'loada)
- (cond ((equal? args '(0))
- (set! inst 'loada0)
- (set! args ()))
- ((equal? args '(1))
- (set! inst 'loada1)
- (set! args ()))))
- (if (eq? inst 'loadc)
- (cond ((equal? args '(0 0))
- (set! inst 'loadc00)
- (set! args ()))
- ((equal? args '(0 1))
- (set! inst 'loadc01)
- (set! args ()))))
+ (eq? (car (aref e 0)) 'cdr))
+ (set-car! (aref e 0) 'cadr)
+ (aset! e 0 (cons inst (aref e 0))))
+ (begin
+ (if (memq inst '(loadv loadg setg))
+ (set! args (list (bcode:indexfor e (car args)))))
+ (let ((longform
+ (assq inst '((loadv loadv.l) (loadg loadg.l) (setg setg.l)
+ (loada loada.l) (seta seta.l)))))
+ (if (and longform
+ (> (car args) 255))
+ (set! inst (cadr longform))))
+ (let ((longform
+ (assq inst '((loadc loadc.l) (setc setc.l)))))
+ (if (and longform
+ (or (> (car args) 255)
+ (> (cadr args) 255)))
+ (set! inst (cadr longform))))
+ (if (eq? inst 'loada)
+ (cond ((equal? args '(0))
+ (set! inst 'loada0)
+ (set! args ()))
+ ((equal? args '(1))
+ (set! inst 'loada1)
+ (set! args ()))))
+ (if (eq? inst 'loadc)
+ (cond ((equal? args '(0 0))
+ (set! inst 'loadc00)
+ (set! args ()))
+ ((equal? args '(0 1))
+ (set! inst 'loadc01)
+ (set! args ()))))
- (let ((lasti (if (pair? (aref e 0))
- (car (aref e 0)) ()))
- (bc (aref e 0)))
- (cond ((and
- (eq? inst 'brf)
- (cond ((and (eq? lasti 'not)
- (eq? (cadr bc) 'null?))
- (aset! e 0 (cons (car args) (cons 'brn (cddr bc)))))
- ((eq? lasti 'not)
- (aset! e 0 (cons (car args) (cons 'brt (cdr bc)))))
- ((eq? lasti 'eq?)
- (aset! e 0 (cons (car args) (cons 'brne (cdr bc)))))
- ((eq? lasti 'null?)
- (aset! e 0 (cons (car args) (cons 'brnn (cdr bc)))))
- (else #f))))
- ((and (eq? inst 'brt) (eq? lasti 'null?))
- (aset! e 0 (cons (car args) (cons 'brn (cdr bc)))))
- (else
- (aset! e 0 (nreconc (cons inst args) bc)))))))
+ (let ((lasti (if (pair? (aref e 0))
+ (car (aref e 0)) ()))
+ (bc (aref e 0)))
+ (cond ((and
+ (eq? inst 'brf)
+ (cond ((and (eq? lasti 'not)
+ (eq? (cadr bc) 'null?))
+ (aset! e 0 (cons (car args) (cons 'brn (cddr bc)))))
+ ((eq? lasti 'not)
+ (aset! e 0 (cons (car args) (cons 'brt (cdr bc)))))
+ ((eq? lasti 'eq?)
+ (aset! e 0 (cons (car args) (cons 'brne (cdr bc)))))
+ ((eq? lasti 'null?)
+ (aset! e 0 (cons (car args) (cons 'brnn (cdr bc)))))
+ (else #f))))
+ ((and (eq? inst 'brt) (eq? lasti 'null?))
+ (aset! e 0 (cons (car args) (cons 'brn (cdr bc)))))
+ (else
+ (aset! e 0 (nreconc (cons inst args) bc)))))))
e)
(define (make-label e) (gensym))
@@ -78,83 +78,83 @@
; labels are fixed-up.
(define (encode-byte-code e)
(let* ((cl (reverse! e))
- (v (list->vector cl))
- (long? (>= (+ (length v) ; 1 byte for each entry, plus...
- ; at most half the entries in this vector can be
- ; instructions accepting 32-bit arguments
- (* 3 (div0 (length v) 2)))
- 65536)))
+ (v (list->vector cl))
+ (long? (>= (+ (length v) ; 1 byte for each entry, plus...
+ ; at most half the entries in this vector can be
+ ; instructions accepting 32-bit arguments
+ (* 3 (div0 (length v) 2)))
+ 65536)))
(let ((n (length v))
- (i 0)
- (label-to-loc (table))
- (fixup-to-label (table))
- (bcode (buffer))
- (vi #f)
- (nxt #f))
+ (i 0)
+ (label-to-loc (table))
+ (fixup-to-label (table))
+ (bcode (buffer))
+ (vi #f)
+ (nxt #f))
(io-write bcode #int32(0))
(while (< i n)
- (begin
- (set! vi (aref v i))
- (if (eq? vi 'label)
- (begin (put! label-to-loc (aref v (+ i 1)) (sizeof bcode))
- (set! i (+ i 2)))
- (begin
- (io-write bcode
- (byte
- (get Instructions
- (if long?
- (case vi
- (jmp 'jmp.l)
- (brt 'brt.l)
- (brf 'brf.l)
- (brne 'brne.l)
- (brnn 'brnn.l)
- (brn 'brn.l)
- (else vi))
- vi))))
- (set! i (+ i 1))
- (set! nxt (if (< i n) (aref v i) #f))
- (cond ((memq vi '(jmp brf brt brne brnn brn))
- (put! fixup-to-label (sizeof bcode) nxt)
- (io-write bcode ((if long? int32 int16) 0))
- (set! i (+ i 1)))
- ((eq? vi 'brbound)
- (io-write bcode (int32 nxt))
- (set! i (+ i 1)))
- ((number? nxt)
- (case vi
- ((loadv.l loadg.l setg.l loada.l seta.l
- largc lvargc call.l tcall.l)
- (io-write bcode (int32 nxt))
- (set! i (+ i 1)))
-
- ((loadc setc) ; 2 uint8 args
- (io-write bcode (uint8 nxt))
- (set! i (+ i 1))
- (io-write bcode (uint8 (aref v i)))
- (set! i (+ i 1)))
-
- ((loadc.l setc.l optargs keyargs) ; 2 int32 args
- (io-write bcode (int32 nxt))
- (set! i (+ i 1))
- (io-write bcode (int32 (aref v i)))
- (set! i (+ i 1))
- (if (eq? vi 'keyargs)
- (begin (io-write bcode (int32 (aref v i)))
- (set! i (+ i 1)))))
-
- (else
- ; other number arguments are always uint8
- (io-write bcode (uint8 nxt))
- (set! i (+ i 1)))))
- (else #f))))))
+ (begin
+ (set! vi (aref v i))
+ (if (eq? vi 'label)
+ (begin (put! label-to-loc (aref v (+ i 1)) (sizeof bcode))
+ (set! i (+ i 2)))
+ (begin
+ (io-write bcode
+ (byte
+ (get Instructions
+ (if long?
+ (case vi
+ (jmp 'jmp.l)
+ (brt 'brt.l)
+ (brf 'brf.l)
+ (brne 'brne.l)
+ (brnn 'brnn.l)
+ (brn 'brn.l)
+ (else vi))
+ vi))))
+ (set! i (+ i 1))
+ (set! nxt (if (< i n) (aref v i) #f))
+ (cond ((memq vi '(jmp brf brt brne brnn brn))
+ (put! fixup-to-label (sizeof bcode) nxt)
+ (io-write bcode ((if long? int32 int16) 0))
+ (set! i (+ i 1)))
+ ((eq? vi 'brbound)
+ (io-write bcode (int32 nxt))
+ (set! i (+ i 1)))
+ ((number? nxt)
+ (case vi
+ ((loadv.l loadg.l setg.l loada.l seta.l
+ largc lvargc call.l tcall.l)
+ (io-write bcode (int32 nxt))
+ (set! i (+ i 1)))
+ ((loadc setc) ; 2 uint8 args
+ (io-write bcode (uint8 nxt))
+ (set! i (+ i 1))
+ (io-write bcode (uint8 (aref v i)))
+ (set! i (+ i 1)))
+
+ ((loadc.l setc.l optargs keyargs) ; 2 int32 args
+ (io-write bcode (int32 nxt))
+ (set! i (+ i 1))
+ (io-write bcode (int32 (aref v i)))
+ (set! i (+ i 1))
+ (if (eq? vi 'keyargs)
+ (begin (io-write bcode (int32 (aref v i)))
+ (set! i (+ i 1)))))
+
+ (else
+ ; other number arguments are always uint8
+ (io-write bcode (uint8 nxt))
+ (set! i (+ i 1)))))
+ (else #f))))))
+
(table-foreach
(λ (addr labl)
- (begin (io-seek bcode addr)
- (io-write bcode ((if long? int32 int16)
- (- (get label-to-loc labl)
- addr)))))
+ (begin (io-seek bcode addr)
+ (io-write bcode ((if long? int32 int16)
+ (- (get label-to-loc labl)
+ addr)))))
fixup-to-label)
(iostream->string bcode))))
@@ -161,92 +161,92 @@
(define (const-to-idx-vec e)
(let ((cvec (vector-alloc (bcode:nconst e))))
(table-foreach (λ (val idx) (aset! cvec idx val))
- (bcode:ctable e))
+ (bcode:ctable e))
cvec))
(define (index-of item lst start)
(cond ((null? lst) #f)
- ((eq? item (car lst)) start)
- (else (index-of item (cdr lst) (+ start 1)))))
+ ((eq? item (car lst)) start)
+ (else (index-of item (cdr lst) (+ start 1)))))
(define (in-env? s env)
(and (pair? env)
(or (memq s (car env))
- (in-env? s (cdr env)))))
+ (in-env? s (cdr env)))))
(define (lookup-sym s env lev arg?)
(if (null? env)
'(global)
(let* ((curr (car env))
- (i (index-of s curr 0)))
- (if i
- (if arg?
- i
- (cons lev i))
- (lookup-sym s
- (cdr env)
- (if (or arg? (null? curr)) lev (+ lev 1))
- #f)))))
+ (i (index-of s curr 0)))
+ (if i
+ (if arg?
+ i
+ (cons lev i))
+ (lookup-sym s
+ (cdr env)
+ (if (or arg? (null? curr)) lev (+ lev 1))
+ #f)))))
; number of non-nulls
(define (nnn e) (count (λ (x) (not (null? x))) e))
(define (printable? x) (not (or (iostream? x)
- (eof-object? x))))
+ (eof-object? x))))
(define (compile-sym g env s Is)
(let ((loc (lookup-sym s env 0 #t)))
(cond ((number? loc) (emit g (aref Is 0) loc))
- ((number? (car loc)) (emit g (aref Is 1) (car loc) (cdr loc))
- ; update index of most distant captured frame
- (bcode:cdepth g (- (nnn (cdr env)) 1 (car loc))))
- (else
- (if (and (constant? s)
- (printable? (top-level-value s)))
- (emit g 'loadv (top-level-value s))
- (emit g (aref Is 2) s))))))
+ ((number? (car loc)) (emit g (aref Is 1) (car loc) (cdr loc))
+ ; update index of most distant captured frame
+ (bcode:cdepth g (- (nnn (cdr env)) 1 (car loc))))
+ (else
+ (if (and (constant? s)
+ (printable? (top-level-value s)))
+ (emit g 'loadv (top-level-value s))
+ (emit g (aref Is 2) s))))))
(define (compile-if g env tail? x)
(let ((elsel (make-label g))
- (endl (make-label g))
- (test (cadr x))
- (then (caddr x))
- (else (if (pair? (cdddr x))
- (cadddr x)
- (void))))
+ (endl (make-label g))
+ (test (cadr x))
+ (then (caddr x))
+ (else (if (pair? (cdddr x))
+ (cadddr x)
+ (void))))
(cond ((eq? test #t)
- (compile-in g env tail? then))
- ((eq? test #f)
- (compile-in g env tail? else))
- (else
- (compile-in g env #f test)
- (emit g 'brf elsel)
- (compile-in g env tail? then)
- (if tail?
- (emit g 'ret)
- (emit g 'jmp endl))
- (mark-label g elsel)
- (compile-in g env tail? else)
- (mark-label g endl)))))
+ (compile-in g env tail? then))
+ ((eq? test #f)
+ (compile-in g env tail? else))
+ (else
+ (compile-in g env #f test)
+ (emit g 'brf elsel)
+ (compile-in g env tail? then)
+ (if tail?
+ (emit g 'ret)
+ (emit g 'jmp endl))
+ (mark-label g elsel)
+ (compile-in g env tail? else)
+ (mark-label g endl)))))
(define (compile-begin g env tail? forms)
(cond ((atom? forms) (compile-in g env tail? (void)))
- ((atom? (cdr forms))
- (compile-in g env tail? (car forms)))
- (else
- (compile-in g env #f (car forms))
- (emit g 'pop)
- (compile-begin g env tail? (cdr forms)))))
+ ((atom? (cdr forms))
+ (compile-in g env tail? (car forms)))
+ (else
+ (compile-in g env #f (car forms))
+ (emit g 'pop)
+ (compile-begin g env tail? (cdr forms)))))
(define (compile-prog1 g env x)
(compile-in g env #f (cadr x))
(if (pair? (cddr x))
(begin (compile-begin g env #f (cddr x))
- (emit g 'pop))))
+ (emit g 'pop))))
(define (compile-while g env cond body)
(let ((top (make-label g))
- (end (make-label g)))
+ (end (make-label g)))
(compile-in g env #f (void))
(mark-label g top)
(compile-in g env #f cond)
@@ -266,22 +266,22 @@
(define (compile-for g env lo hi func)
(if (1arg-lambda? func)
(begin (compile-in g env #f lo)
- (compile-in g env #f hi)
- (compile-in g env #f func)
- (emit g 'for))
+ (compile-in g env #f hi)
+ (compile-in g env #f func)
+ (emit g 'for))
(error "for: third form must be a 1-argument lambda")))
(define (compile-short-circuit g env tail? forms default branch)
(cond ((atom? forms) (compile-in g env tail? default))
- ((atom? (cdr forms)) (compile-in g env tail? (car forms)))
- (else
- (let ((end (make-label g)))
- (compile-in g env #f (car forms))
- (emit g 'dup)
- (emit g branch end)
- (emit g 'pop)
- (compile-short-circuit g env tail? (cdr forms) default branch)
- (mark-label g end)))))
+ ((atom? (cdr forms)) (compile-in g env tail? (car forms)))
+ (else
+ (let ((end (make-label g)))
+ (compile-in g env #f (car forms))
+ (emit g 'dup)
+ (emit g branch end)
+ (emit g 'pop)
+ (compile-short-circuit g env tail? (cdr forms) default branch)
+ (mark-label g end)))))
(define (compile-and g env tail? forms)
(compile-short-circuit g env tail? forms #t 'brf))
@@ -290,30 +290,30 @@
(define (compile-arglist g env lst)
(for-each (λ (a)
- (compile-in g env #f a))
- lst)
+ (compile-in g env #f a))
+ lst)
(length lst))
(define (argc-error head count)
(error "compile error: " head " expects " count
- (if (= count 1)
- " argument."
- " arguments.")))
+ (if (= count 1)
+ " argument."
+ " arguments.")))
(define builtin->instruction
(let ((b2i (table number? 'number? cons 'cons
- fixnum? 'fixnum? equal? 'equal?
- eq? 'eq? symbol? 'symbol?
- div0 'div0 builtin? 'builtin?
- aset! 'aset! - '- boolean? 'boolean? not 'not
- apply 'apply atom? 'atom?
- set-cdr! 'set-cdr! / '/
- function? 'function? vector 'vector
- list 'list bound? 'bound?
- < '< * '* cdr 'cdr cadr 'cadr null? 'null?
- + '+ eqv? 'eqv? compare 'compare aref 'aref
- set-car! 'set-car! car 'car
- pair? 'pair? = '= vector? 'vector?)))
+ fixnum? 'fixnum? equal? 'equal?
+ eq? 'eq? symbol? 'symbol?
+ div0 'div0 builtin? 'builtin?
+ aset! 'aset! - '- boolean? 'boolean? not 'not
+ apply 'apply atom? 'atom?
+ set-cdr! 'set-cdr! / '/
+ function? 'function? vector 'vector
+ list 'list bound? 'bound?
+ < '< * '* cdr 'cdr cadr 'cadr null? 'null?
+ + '+ eqv? 'eqv? compare 'compare aref 'aref
+ set-car! 'set-car! car 'car
+ pair? 'pair? = '= vector? 'vector?)))
(λ (b)
(get b2i b #f))))
@@ -320,142 +320,142 @@
(define (compile-builtin-call g env tail? x head b nargs)
(let ((count (get arg-counts head #f)))
(if (and count
- (not (length= (cdr x) count)))
- (argc-error b count))
+ (not (length= (cdr x) count)))
+ (argc-error b count))
(case b ; handle special cases of vararg builtins
(list (if (= nargs 0) (emit g 'loadnil) (emit g b nargs)))
(+ (cond ((= nargs 0) (emit g 'load0))
- ((= nargs 2) (emit g 'add2))
- (else (emit g b nargs))))
+ ((= nargs 2) (emit g 'add2))
+ (else (emit g b nargs))))
(- (cond ((= nargs 0) (argc-error b 1))
- ((= nargs 1) (emit g 'neg))
- ((= nargs 2) (emit g 'sub2))
- (else (emit g b nargs))))
+ ((= nargs 1) (emit g 'neg))
+ ((= nargs 2) (emit g 'sub2))
+ (else (emit g b nargs))))
(* (if (= nargs 0) (emit g 'load1)
- (emit g b nargs)))
+ (emit g b nargs)))
(/ (if (= nargs 0)
- (argc-error b 1)
- (emit g b nargs)))
+ (argc-error b 1)
+ (emit g b nargs)))
(vector (if (= nargs 0)
- (emit g 'loadv #())
- (emit g b nargs)))
+ (emit g 'loadv #())
+ (emit g b nargs)))
(apply (if (< nargs 2)
- (argc-error b 2)
- (emit g (if tail? 'tapply 'apply) nargs)))
+ (argc-error b 2)
+ (emit g (if tail? 'tapply 'apply) nargs)))
(else (emit g b)))))
(define (compile-app g env tail? x)
(let ((head (car x)))
(let ((head
- (if (and (symbol? head)
- (not (in-env? head env))
- (bound? head)
- (constant? head)
- (builtin? (top-level-value head)))
- (top-level-value head)
- head)))
+ (if (and (symbol? head)
+ (not (in-env? head env))
+ (bound? head)
+ (constant? head)
+ (builtin? (top-level-value head)))
+ (top-level-value head)
+ head)))
(if (length> (cdr x) 255)
- ; more than 255 arguments, need long versions of instructions
- (begin (compile-in g env #f head)
- (let ((nargs (compile-arglist g env (cdr x))))
- (emit g (if tail? 'tcall.l 'call.l) nargs)))
- (let ((b (and (builtin? head)
- (builtin->instruction head))))
- (if (and (eq? head 'cadr)
- (not (in-env? head env))
- (equal? (top-level-value 'cadr) cadr)
- (length= x 2))
- (begin (compile-in g env #f (cadr x))
- (emit g 'cadr))
- (begin
- (if (not b)
- (compile-in g env #f head))
- (let ((nargs (compile-arglist g env (cdr x))))
- (if b
- (compile-builtin-call g env tail? x head b nargs)
- (emit g (if tail? 'tcall 'call) nargs))))))))))
+ ; more than 255 arguments, need long versions of instructions
+ (begin (compile-in g env #f head)
+ (let ((nargs (compile-arglist g env (cdr x))))
+ (emit g (if tail? 'tcall.l 'call.l) nargs)))
+ (let ((b (and (builtin? head)
+ (builtin->instruction head))))
+ (if (and (eq? head 'cadr)
+ (not (in-env? head env))
+ (equal? (top-level-value 'cadr) cadr)
+ (length= x 2))
+ (begin (compile-in g env #f (cadr x))
+ (emit g 'cadr))
+ (begin
+ (if (not b)
+ (compile-in g env #f head))
+ (let ((nargs (compile-arglist g env (cdr x))))
+ (if b
+ (compile-builtin-call g env tail? x head b nargs)
+ (emit g (if tail? 'tcall 'call) nargs))))))))))
(define (expand-define x)
(let ((form (cadr x))
- (body (if (pair? (cddr x))
- (cddr x)
- (if (symbol? (cadr x))
- `(,(void))
- (error "compile error: invalid syntax "
- (print-to-string x))))))
+ (body (if (pair? (cddr x))
+ (cddr x)
+ (if (symbol? (cadr x))
+ `(,(void))
+ (error "compile error: invalid syntax "
+ (print-to-string x))))))
(if (symbol? form)
- `(set! ,form ,(car body))
- `(set! ,(car form)
- (λ ,(cdr form) ,@body . ,(car form))))))
+ `(set! ,form ,(car body))
+ `(set! ,(car form)
+ (λ ,(cdr form) ,@body . ,(car form))))))
(define (fits-i8 x) (and (fixnum? x) (>= x -128) (<= x 127)))
(define (compile-in g env tail? x)
(cond ((symbol? x) (compile-sym g env x #(loada loadc loadg)))
- ((atom? x)
- (cond ((eq? x 0) (emit g 'load0))
- ((eq? x 1) (emit g 'load1))
- ((eq? x #t) (emit g 'loadt))
- ((eq? x #f) (emit g 'loadf))
- ((eq? x ()) (emit g 'loadnil))
- ((fits-i8 x) (emit g 'loadi8 x))
- ((eof-object? x)
- (compile-in g env tail? (list (top-level-value 'eof-object))))
- (else (emit g 'loadv x))))
- ((or (not (symbol? (car x))) (bound? (car x)) (in-env? (car x) env))
- (compile-app g env tail? x))
- (else
- (case (car x)
- (quote (if (self-evaluating? (cadr x))
- (compile-in g env tail? (cadr x))
- (emit g 'loadv (cadr x))))
- (if (compile-if g env tail? x))
- (begin (compile-begin g env tail? (cdr x)))
- (prog1 (compile-prog1 g env x))
- (λ (receive (the-f dept) (compile-f- env x)
- (begin (emit g 'loadv the-f)
- (bcode:cdepth g dept)
- (if (< dept (nnn env))
- (emit g 'closure)))))
- (and (compile-and g env tail? (cdr x)))
- (or (compile-or g env tail? (cdr x)))
- (while (compile-while g env (cadr x) (cons 'begin (cddr x))))
- (for (compile-for g env (cadr x) (caddr x) (cadddr x)))
- (return (compile-in g env #t (cadr x))
- (emit g 'ret))
- (set! (compile-in g env #f (caddr x))
- (or (symbol? (cadr x))
- (error "set!: second argument must be a symbol"))
- (compile-sym g env (cadr x) #(seta setc setg)))
- (define (compile-in g env tail?
- (expand-define x)))
- (trycatch (compile-in g env #f `(λ () ,(cadr x)))
- (unless (1arg-lambda? (caddr x))
- (error "trycatch: second form must be a 1-argument lambda"))
- (compile-in g env #f (caddr x))
- (emit g 'trycatch))
- (else (compile-app g env tail? x))))))
+ ((atom? x)
+ (cond ((eq? x 0) (emit g 'load0))
+ ((eq? x 1) (emit g 'load1))
+ ((eq? x #t) (emit g 'loadt))
+ ((eq? x #f) (emit g 'loadf))
+ ((eq? x ()) (emit g 'loadnil))
+ ((fits-i8 x) (emit g 'loadi8 x))
+ ((eof-object? x)
+ (compile-in g env tail? (list (top-level-value 'eof-object))))
+ (else (emit g 'loadv x))))
+ ((or (not (symbol? (car x))) (bound? (car x)) (in-env? (car x) env))
+ (compile-app g env tail? x))
+ (else
+ (case (car x)
+ (quote (if (self-evaluating? (cadr x))
+ (compile-in g env tail? (cadr x))
+ (emit g 'loadv (cadr x))))
+ (if (compile-if g env tail? x))
+ (begin (compile-begin g env tail? (cdr x)))
+ (prog1 (compile-prog1 g env x))
+ (λ (receive (the-f dept) (compile-f- env x)
+ (begin (emit g 'loadv the-f)
+ (bcode:cdepth g dept)
+ (if (< dept (nnn env))
+ (emit g 'closure)))))
+ (and (compile-and g env tail? (cdr x)))
+ (or (compile-or g env tail? (cdr x)))
+ (while (compile-while g env (cadr x) (cons 'begin (cddr x))))
+ (for (compile-for g env (cadr x) (caddr x) (cadddr x)))
+ (return (compile-in g env #t (cadr x))
+ (emit g 'ret))
+ (set! (compile-in g env #f (caddr x))
+ (or (symbol? (cadr x))
+ (error "set!: second argument must be a symbol"))
+ (compile-sym g env (cadr x) #(seta setc setg)))
+ (define (compile-in g env tail?
+ (expand-define x)))
+ (trycatch (compile-in g env #f `(λ () ,(cadr x)))
+ (unless (1arg-lambda? (caddr x))
+ (error "trycatch: second form must be a 1-argument lambda"))
+ (compile-in g env #f (caddr x))
+ (emit g 'trycatch))
+ (else (compile-app g env tail? x))))))
(define (compile-f env f)
(receive (ff ignore)
- (compile-f- env f)
- ff))
+ (compile-f- env f)
+ ff))
(define get-defined-vars
(letrec ((get-defined-vars-
- (λ (expr)
- (cond ((atom? expr) ())
- ((and (eq? (car expr) 'define)
- (pair? (cdr expr)))
- (or (and (symbol? (cadr expr))
- (list (cadr expr)))
- (and (pair? (cadr expr))
- (symbol? (caadr expr))
- (list (caadr expr)))
- ()))
- ((eq? (car expr) 'begin)
- (apply nconc (map get-defined-vars- (cdr expr))))
- (else ())))))
+ (λ (expr)
+ (cond ((atom? expr) ())
+ ((and (eq? (car expr) 'define)
+ (pair? (cdr expr)))
+ (or (and (symbol? (cadr expr))
+ (list (cadr expr)))
+ (and (pair? (cadr expr))
+ (symbol? (caadr expr))
+ (list (caadr expr)))
+ ()))
+ ((eq? (car expr) 'begin)
+ (apply nconc (map get-defined-vars- (cdr expr))))
+ (else ())))))
(λ (expr) (delete-duplicates (get-defined-vars- expr)))))
(define (keyword-arg? x) (and (pair? x) (keyword? (car x))))
@@ -462,40 +462,40 @@
(define (keyword->symbol k)
(if (keyword? k)
(symbol (let ((s (string k)))
- (string-sub s 0 (1- (string-length s)))))
+ (string-sub s 0 (1- (string-length s)))))
k))
(define (lambda-arg-names argl)
(map! (λ (s) (if (pair? s) (keyword->symbol (car s)) s))
- (to-proper argl)))
+ (to-proper argl)))
(define (lambda-vars l)
(define (check-formals l o opt kw)
(cond ((or (null? l) (symbol? l)) #t)
- ((and (pair? l) (symbol? (car l)))
- (if (or opt kw)
- (error "compile error: invalid argument list "
- o ". optional arguments must come after required.")
- (check-formals (cdr l) o opt kw)))
- ((and (pair? l) (pair? (car l)))
- (unless (and (length= (car l) 2)
- (symbol? (caar l)))
- (error "compile error: invalid optional argument " (car l)
- " in list " o))
- (if (keyword? (caar l))
- (check-formals (cdr l) o opt #t)
- (if kw
- (error "compile error: invalid argument list "
- o ". keyword arguments must come last.")
- (check-formals (cdr l) o #t kw))))
- ((pair? l)
- (error "compile error: invalid formal argument " (car l)
- " in list " o))
- (else
- (if (eq? l o)
- (error "compile error: invalid argument list " o)
- (error "compile error: invalid formal argument " l
- " in list " o)))))
+ ((and (pair? l) (symbol? (car l)))
+ (if (or opt kw)
+ (error "compile error: invalid argument list "
+ o ". optional arguments must come after required.")
+ (check-formals (cdr l) o opt kw)))
+ ((and (pair? l) (pair? (car l)))
+ (unless (and (length= (car l) 2)
+ (symbol? (caar l)))
+ (error "compile error: invalid optional argument " (car l)
+ " in list " o))
+ (if (keyword? (caar l))
+ (check-formals (cdr l) o opt #t)
+ (if kw
+ (error "compile error: invalid argument list "
+ o ". keyword arguments must come last.")
+ (check-formals (cdr l) o #t kw))))
+ ((pair? l)
+ (error "compile error: invalid formal argument " (car l)
+ " in list " o))
+ (else
+ (if (eq? l o)
+ (error "compile error: invalid argument list " o)
+ (error "compile error: invalid formal argument " l
+ " in list " o)))))
(check-formals l l #f #f)
(lambda-arg-names l))
@@ -503,22 +503,22 @@
; i is the lexical var index of the opt arg to process next
(if (pair? opta)
(let ((nxt (make-label g)))
- (emit g 'brbound i)
- (emit g 'brt nxt)
- (compile-in g (cons (list-head vars i) env) #f (cadar opta))
- (emit g 'seta i)
- (emit g 'pop)
- (mark-label g nxt)
- (emit-optional-arg-inits g env (cdr opta) vars (+ i 1)))))
+ (emit g 'brbound i)
+ (emit g 'brt nxt)
+ (compile-in g (cons (list-head vars i) env) #f (cadar opta))
+ (emit g 'seta i)
+ (emit g 'pop)
+ (mark-label g nxt)
+ (emit-optional-arg-inits g env (cdr opta) vars (+ i 1)))))
#;(define (free-vars e)
(cond ((symbol? e) (list e))
- ((or (atom? e) (eq? (car e) 'quote)) ())
- ((or (eq? (car e) 'λ) (eq? (car e) 'lambda))
- (diff (free-vars (cddr e))
- (nconc (get-defined-vars (cons 'begin (cddr e)))
- (lambda-arg-names (cadr e)))))
- (else (delete-duplicates (apply nconc (map free-vars (cdr e)))))))
+ ((or (atom? e) (eq? (car e) 'quote)) ())
+ ((or (eq? (car e) 'λ) (eq? (car e) 'lambda))
+ (diff (free-vars (cddr e))
+ (nconc (get-defined-vars (cons 'begin (cddr e)))
+ (lambda-arg-names (cadr e)))))
+ (else (delete-duplicates (apply nconc (map free-vars (cdr e)))))))
(define compile-f-
(let ((*defines-processed-token* (gensym)))
@@ -531,72 +531,72 @@
(λ (env f)
; convert lambda to one body expression and process internal defines
(define (lambda-body e)
- (let ((B (if (pair? (cddr e))
- (if (pair? (cdddr e))
- (cons 'begin (cddr e))
- (caddr e))
- (void))))
- (let ((V (get-defined-vars B)))
- (if (null? V)
- B
- (cons (list* 'λ V B *defines-processed-token*)
- (map (λ (x) (void)) V))))))
+ (let ((B (if (pair? (cddr e))
+ (if (pair? (cdddr e))
+ (cons 'begin (cddr e))
+ (caddr e))
+ (void))))
+ (let ((V (get-defined-vars B)))
+ (if (null? V)
+ B
+ (cons (list* 'λ V B *defines-processed-token*)
+ (map (λ (x) (void)) V))))))
(define (lam:body f)
- (if (eq? (lastcdr f) *defines-processed-token*)
- (caddr f)
- (lambda-body f)))
-
+ (if (eq? (lastcdr f) *defines-processed-token*)
+ (caddr f)
+ (lambda-body f)))
+
(let ((g (make-code-emitter))
- (args (cadr f))
- (atail (lastcdr (cadr f)))
- (vars (lambda-vars (cadr f)))
- (opta (filter pair? (cadr f)))
- (name (if (eq? (lastcdr f) *defines-processed-token*)
- 'λ
- (lastcdr f))))
- (let* ((nargs (if (atom? args) 0 (length args)))
- (nreq (- nargs (length opta)))
- (kwa (filter keyword-arg? opta)))
+ (args (cadr f))
+ (atail (lastcdr (cadr f)))
+ (vars (lambda-vars (cadr f)))
+ (opta (filter pair? (cadr f)))
+ (name (if (eq? (lastcdr f) *defines-processed-token*)
+ 'λ
+ (lastcdr f))))
+ (let* ((nargs (if (atom? args) 0 (length args)))
+ (nreq (- nargs (length opta)))
+ (kwa (filter keyword-arg? opta)))
- ; emit argument checking prologue
- (if (not (null? opta))
- (begin
- (if (null? kwa)
- (emit g 'optargs nreq
- (if (null? atail) nargs (- nargs)))
- (begin
- (bcode:indexfor g (make-perfect-hash-table
- (map cons
- (map car kwa)
- (iota (length kwa)))))
- (emit g 'keyargs nreq (length kwa)
- (if (null? atail) nargs (- nargs)))))
- (emit-optional-arg-inits g env opta vars nreq)))
+ ; emit argument checking prologue
+ (if (not (null? opta))
+ (begin
+ (if (null? kwa)
+ (emit g 'optargs nreq
+ (if (null? atail) nargs (- nargs)))
+ (begin
+ (bcode:indexfor g (make-perfect-hash-table
+ (map cons
+ (map car kwa)
+ (iota (length kwa)))))
+ (emit g 'keyargs nreq (length kwa)
+ (if (null? atail) nargs (- nargs)))))
+ (emit-optional-arg-inits g env opta vars nreq)))
- (cond ((> nargs 255) (emit g (if (null? atail)
- 'largc 'lvargc)
- nargs))
- ((not (null? atail)) (emit g 'vargc nargs))
- ((null? opta) (emit g 'argc nargs)))
+ (cond ((> nargs 255) (emit g (if (null? atail)
+ 'largc 'lvargc)
+ nargs))
+ ((not (null? atail)) (emit g 'vargc nargs))
+ ((null? opta) (emit g 'argc nargs)))
- ; compile body and return
- (compile-in g (cons vars env) #t (lam:body f))
- (emit g 'ret)
- (values (function (encode-byte-code (bcode:code g))
- (const-to-idx-vec g) name)
- (aref g 3)))))))
+ ; compile body and return
+ (compile-in g (cons vars env) #t (lam:body f))
+ (emit g 'ret)
+ (values (function (encode-byte-code (bcode:code g))
+ (const-to-idx-vec g) name)
+ (aref g 3)))))))
(define (compile f) (compile-f () f))
(define (ref-int32-LE a i)
(int32 (+ (ash (aref a (+ i 0)) 0)
- (ash (aref a (+ i 1)) 8)
- (ash (aref a (+ i 2)) 16)
- (ash (aref a (+ i 3)) 24))))
+ (ash (aref a (+ i 1)) 8)
+ (ash (aref a (+ i 2)) 16)
+ (ash (aref a (+ i 3)) 24))))
(define (ref-int16-LE a i)
(int16 (+ (ash (aref a (+ i 0)) 0)
- (ash (aref a (+ i 1)) 8))))
+ (ash (aref a (+ i 1)) 8))))
(define (hex5 n)
(string-lpad (number->string n 16) 5 #\0))
@@ -604,79 +604,79 @@
(define (disassemble f . lev?)
(if (null? lev?)
(begin (disassemble f 0)
- (newline)
- (return #t)))
+ (newline)
+ (return #t)))
(let ((lev (car lev?))
- (code (function:code f))
- (vals (function:vals f)))
+ (code (function:code f))
+ (vals (function:vals f)))
(define (print-val v)
(if (and (function? v) (not (builtin? v)))
- (begin (princ "\n")
- (disassemble v (+ lev 1)))
- (print v)))
+ (begin (princ "\n")
+ (disassemble v (+ lev 1)))
+ (print v)))
(dotimes (xx lev) (princ "\t"))
(princ "maxstack " (ref-int32-LE code 0) "\n")
(let ((i 4)
- (N (length code)))
+ (N (length code)))
(while (< i N)
- ; find key whose value matches the current byte
- (let ((inst (table-foldl (λ (k v z)
- (or z (and (eq? v (aref code i))
- k)))
- #f Instructions)))
- (if (> i 4) (newline))
- (dotimes (xx lev) (princ "\t"))
- (princ (hex5 (- i 4)) ": "
- (string inst) "\t")
- (set! i (+ i 1))
- (case inst
- ((loadv.l loadg.l setg.l)
- (print-val (aref vals (ref-int32-LE code i)))
- (set! i (+ i 4)))
-
- ((loadv loadg setg)
- (print-val (aref vals (aref code i)))
- (set! i (+ i 1)))
-
- ((loada seta call tcall list + - * / vector
- argc vargc loadi8 apply tapply)
- (princ (number->string (aref code i)))
- (set! i (+ i 1)))
-
- ((loada.l seta.l largc lvargc call.l tcall.l)
- (princ (number->string (ref-int32-LE code i)))
- (set! i (+ i 4)))
-
- ((loadc setc)
- (princ (number->string (aref code i)) " ")
- (set! i (+ i 1))
- (princ (number->string (aref code i)))
- (set! i (+ i 1)))
-
- ((loadc.l setc.l optargs keyargs)
- (princ (number->string (ref-int32-LE code i)) " ")
- (set! i (+ i 4))
- (princ (number->string (ref-int32-LE code i)))
- (set! i (+ i 4))
- (if (eq? inst 'keyargs)
- (begin
- (princ " ")
- (princ (number->string (ref-int32-LE code i)) " ")
- (set! i (+ i 4)))))
-
- ((brbound)
- (princ (number->string (ref-int32-LE code i)) " ")
- (set! i (+ i 4)))
-
- ((jmp brf brt brne brnn brn)
- (princ "@" (hex5 (+ i -4 (ref-int16-LE code i))))
- (set! i (+ i 2)))
-
- ((jmp.l brf.l brt.l brne.l brnn.l brn.l)
- (princ "@" (hex5 (+ i -4 (ref-int32-LE code i))))
- (set! i (+ i 4)))
-
- (else #f)))))))
+ ; find key whose value matches the current byte
+ (let ((inst (table-foldl (λ (k v z)
+ (or z (and (eq? v (aref code i))
+ k)))
+ #f Instructions)))
+ (if (> i 4) (newline))
+ (dotimes (xx lev) (princ "\t"))
+ (princ (hex5 (- i 4)) ": "
+ (string inst) "\t")
+ (set! i (+ i 1))
+ (case inst
+ ((loadv.l loadg.l setg.l)
+ (print-val (aref vals (ref-int32-LE code i)))
+ (set! i (+ i 4)))
+
+ ((loadv loadg setg)
+ (print-val (aref vals (aref code i)))
+ (set! i (+ i 1)))
+
+ ((loada seta call tcall list + - * / vector
+ argc vargc loadi8 apply tapply)
+ (princ (number->string (aref code i)))
+ (set! i (+ i 1)))
+
+ ((loada.l seta.l largc lvargc call.l tcall.l)
+ (princ (number->string (ref-int32-LE code i)))
+ (set! i (+ i 4)))
+
+ ((loadc setc)
+ (princ (number->string (aref code i)) " ")
+ (set! i (+ i 1))
+ (princ (number->string (aref code i)))
+ (set! i (+ i 1)))
+
+ ((loadc.l setc.l optargs keyargs)
+ (princ (number->string (ref-int32-LE code i)) " ")
+ (set! i (+ i 4))
+ (princ (number->string (ref-int32-LE code i)))
+ (set! i (+ i 4))
+ (if (eq? inst 'keyargs)
+ (begin
+ (princ " ")
+ (princ (number->string (ref-int32-LE code i)) " ")
+ (set! i (+ i 4)))))
+
+ ((brbound)
+ (princ (number->string (ref-int32-LE code i)) " ")
+ (set! i (+ i 4)))
+
+ ((jmp brf brt brne brnn brn)
+ (princ "@" (hex5 (+ i -4 (ref-int16-LE code i))))
+ (set! i (+ i 2)))
+
+ ((jmp.l brf.l brt.l brne.l brnn.l brn.l)
+ (princ "@" (hex5 (+ i -4 (ref-int32-LE code i))))
+ (set! i (+ i 4)))
+
+ (else #f)))))))
; From SRFI 89 by Marc Feeley (http://srfi.schemers.org/srfi-89/srfi-89.html)
; Copyright (C) Marc Feeley 2006. All Rights Reserved.
--- a/lib/lazy.scm
+++ b/lib/lazy.scm
@@ -34,8 +34,8 @@
(let ((content (unbox promise)))
(case (car content)
((eager) (cdr content))
- ((lazy) (let* ((promise* ((cdr content)))
- (content (unbox promise))) ; *
+ ((lazy) (let* ((promise* ((cdr content)))
+ (content (unbox promise))) ; *
(if (not (eqv? (car content) 'eager)) ; *
(begin (set-car! content (car (unbox promise*)))
(set-cdr! content (cdr (unbox promise*)))
@@ -42,6 +42,6 @@
(set-box! promise* content)))
(force promise))))))
-; (*) These two lines re-fetch and check the original promise in case
-; the first line of the let* caused it to be forced. For an example
+; (*) These two lines re-fetch and check the original promise in case
+; the first line of the let* caused it to be forced. For an example
; where this happens, see reentrancy test 3 below.
--- a/lib/psyntax.ss
+++ b/lib/psyntax.ss
@@ -48,7 +48,7 @@
;;; Guide (R. Kent Dybvig, Cadence Research Systems, 1998), which can
;;; also be found online at http://www.scheme.com/csug/. They are
;;; described briefly here as well.
-
+
;;; All are definitions and may appear where and only where other
;;; definitions may appear. modules may be named:
;;;
@@ -94,36 +94,36 @@
;;; drop-prefix, rename, and alias.
;;;
;;; (import (only m x y))
-;;;
+;;;
;;; imports x and y (and nothing else) from m.
;;;
;;; (import (except m x y))
-;;;
+;;;
;;; imports all of m's imports except for x and y.
;;;
;;; (import (add-prefix (only m x y) m:))
-;;;
+;;;
;;; imports x and y as m:x and m:y.
;;;
;;; (import (drop-prefix m foo:))
-;;;
+;;;
;;; imports all of m's imports, dropping the common foo: prefix
;;; (which must appear on all of m's exports).
-;;;
+;;;
;;; (import (rename (except m a b) (m-c c) (m-d d)))
-;;;
+;;;
;;; imports all of m's imports except for x and y, renaming c
;;; m-c and d m-d.
-;;;
+;;;
;;; (import (alias (except m a b) (m-c c) (m-d d)))
-;;;
+;;;
;;; imports all of m's imports except for x and y, with additional
;;; aliases m-c for c and m-d for d.
-;;;
+;;;
;;; multiple imports may be specified with one import form:
-;;;
+;;;
;;; (import (except m1 x) (only m2 x))
-;;;
+;;;
;;; imports all of m1's exports except for x plus x from m2.
;;; Another form, meta, may be used as a prefix for any definition and
@@ -165,7 +165,7 @@
;;; meta definitions propagate through macro expansion, so one can write,
;;; for example:
-;;;
+;;;
;;; (module (a)
;;; (meta define-structure (foo x))
;;; (define-syntax a
@@ -173,17 +173,17 @@
;;; (lambda (x)
;;; (foo-x q)))))
;;; a -> q
-;;;
+;;;
;;; where define-record is a macro that expands into a set of defines.
-;;;
+;;;
;;; It is also sometimes convenient to write
-;;;
+;;;
;;; (meta begin defn ...)
-;;;
+;;;
;;; or
-;;;
+;;;
;;; (meta module {exports} defn ...)-;;;
+;;;
;;; to create groups of meta bindings.
;;; Another form, alias, is used to create aliases from one identifier
@@ -1166,7 +1166,7 @@
(and (same-marks? marks (join-marks new-marks (wrap-marks top-wrap))) new))
((same-marks? marks (join-marks new-marks (wrap-marks (syntax-object-wrap new)))) new)
(else #f)))))))
-
+
(define store-import-binding
(lambda (id token new-marks)
(define cons-id
@@ -1186,7 +1186,7 @@
(join-marks new-marks (id-marks id))
(id-subst id))))))
(let ((sym (id-sym-name id)))
- ; no need to record bindings mapping symbol to self, since this
+ ; no need to record bindings mapping symbol to self, since this
; assumed by default.
(unless (eq? id sym)
(let ((marks (id-marks id)))
@@ -1483,7 +1483,7 @@
(lambda (i.sym i.marks j.sym j.marks)
(and (eq? i.sym j.sym)
(same-marks? i.marks j.marks))))
-
+
(define bound-id=?
(lambda (i j)
(help-bound-id=? (id-sym-name i) (id-marks i) (id-sym-name j) (id-marks j))))
@@ -1952,7 +1952,7 @@
((define-syntax-form)
(let ((sym (generate-id (id-sym-name id))))
(process-exports fexports
- (lambda ()
+ (lambda ()
(let ((local-label (get-indirect-label label)))
(set-indirect-label! label sym)
(cons
@@ -2711,7 +2711,7 @@
(unless label
(syntax-error id "exported identifier not visible"))
label)))
-
+
(define do-import!
(lambda (import-iface ribcage)
(let ((ie (interface-exports (import-interface-interface import-iface))))
@@ -3434,7 +3434,7 @@
(let ((id (if (pair? x) (car x) x)))
(make-syntax-object
(syntax-object->datum id)
- (let ((marks (join-marks new-marks (wrap-marks (syntax-object-wrap id)))))
+ (let ((marks (join-marks new-marks (wrap-marks (syntax-object-wrap id)))))
(make-wrap marks
; the anti mark should always be present at the head
; of new-marks, but we paranoically check anyway
@@ -3578,7 +3578,7 @@
(put-cte-hook 'import
(lambda (orig)
($import-help orig #f)))
-
+
(put-cte-hook 'import-only
(lambda (orig)
($import-help orig #t)))
@@ -3725,7 +3725,7 @@
; unique mark (in tmp-wrap) to distinguish from non-temporaries
tmp-wrap))
ls))))
-
+
(set! free-identifier=?
(lambda (x y)
(arg-check nonsymbol-id? x 'free-identifier=?)
--- a/system.lsp
+++ b/system.lsp
@@ -13,21 +13,21 @@
(define-macro (define-macro form . body)
`(set-syntax! ',(car form)
- (λ ,(cdr form) ,@body)))
+ (λ ,(cdr form) ,@body)))
#;(define (map1 f lst acc)
(cdr
(prog1 acc
- (while (pair? lst)
- (begin (set! acc
- (cdr (set-cdr! acc (cons (f (car lst)) ()))))
- (set! lst (cdr lst)))))))
+ (while (pair? lst)
+ (begin (set! acc
+ (cdr (set-cdr! acc (cons (f (car lst)) ()))))
+ (set! lst (cdr lst)))))))
#;(define (mapn f lsts)
(if (null? (car lsts))
()
(cons (apply f (map1 car lsts (list ())))
- (mapn f (map1 cdr lsts (list ()))))))
+ (mapn f (map1 cdr lsts (list ()))))))
#;(define (map f lst . lsts)
(if (null? lsts)
@@ -43,53 +43,53 @@
(define-macro (let binds . body)
(let ((lname #f))
(if (symbol? binds)
- (begin (set! lname binds)
- (set! binds (car body))
- (set! body (cdr body))))
+ (begin (set! lname binds)
+ (set! binds (car body))
+ (set! body (cdr body))))
(let ((thelambda
- `(λ ,(map (λ (c) (if (pair? c) (car c) c))
- binds)
- ,@body))
- (theargs
- (map (λ (c) (if (pair? c) (cadr c) (void))) binds)))
+ `(λ ,(map (λ (c) (if (pair? c) (car c) c))
+ binds)
+ ,@body))
+ (theargs
+ (map (λ (c) (if (pair? c) (cadr c) (void))) binds)))
(cons (if lname
- `(letrec ((,lname ,thelambda)) ,lname)
- thelambda)
- theargs))))
+ `(letrec ((,lname ,thelambda)) ,lname)
+ thelambda)
+ theargs))))
(define-macro (cond . clauses)
(define (cond-clauses->if lst)
(if (atom? lst)
- #f
- (let ((clause (car lst)))
- (if (or (eq? (car clause) 'else)
- (eq? (car clause) #t))
- (if (null? (cdr clause))
- (car clause)
- (cons 'begin (cdr clause)))
- (if (null? (cdr clause))
- ; test by itself
- (list 'or
- (car clause)
- (cond-clauses->if (cdr lst)))
- ; test => expression
- (if (eq? (cadr clause) '=>)
- (if (1arg-lambda? (caddr clause))
- ; test => (λ (x) ...)
- (let ((var (caadr (caddr clause))))
- `(let ((,var ,(car clause)))
- (if ,var ,(cons 'begin (cddr (caddr clause)))
- ,(cond-clauses->if (cdr lst)))))
- ; test => proc
- (let ((b (gensym)))
- `(let ((,b ,(car clause)))
- (if ,b
- (,(caddr clause) ,b)
- ,(cond-clauses->if (cdr lst))))))
- (list 'if
- (car clause)
- (cons 'begin (cdr clause))
- (cond-clauses->if (cdr lst)))))))))
+ #f
+ (let ((clause (car lst)))
+ (if (or (eq? (car clause) 'else)
+ (eq? (car clause) #t))
+ (if (null? (cdr clause))
+ (car clause)
+ (cons 'begin (cdr clause)))
+ (if (null? (cdr clause))
+ ; test by itself
+ (list 'or
+ (car clause)
+ (cond-clauses->if (cdr lst)))
+ ; test => expression
+ (if (eq? (cadr clause) '=>)
+ (if (1arg-lambda? (caddr clause))
+ ; test => (λ (x) ...)
+ (let ((var (caadr (caddr clause))))
+ `(let ((,var ,(car clause)))
+ (if ,var ,(cons 'begin (cddr (caddr clause)))
+ ,(cond-clauses->if (cdr lst)))))
+ ; test => proc
+ (let ((b (gensym)))
+ `(let ((,b ,(car clause)))
+ (if ,b
+ (,(caddr clause) ,b)
+ ,(cond-clauses->if (cdr lst))))))
+ (list 'if
+ (car clause)
+ (cons 'begin (cdr clause))
+ (cond-clauses->if (cdr lst)))))))))
(cond-clauses->if clauses))
; standard procedures ---------------------------------------------------------
@@ -105,12 +105,12 @@
(define (assoc item lst)
(cond ((atom? lst) #f)
- ((equal? (caar lst) item) (car lst))
- (#t (assoc item (cdr lst)))))
+ ((equal? (caar lst) item) (car lst))
+ (#t (assoc item (cdr lst)))))
(define (assv item lst)
(cond ((atom? lst) #f)
- ((eqv? (caar lst) item) (car lst))
- (#t (assv item (cdr lst)))))
+ ((eqv? (caar lst) item) (car lst))
+ (#t (assv item (cdr lst)))))
(define (> a b) (< b a))
(define (nan? x) (or (equal? x +nan.0) (equal? x -nan.0)))
@@ -128,10 +128,10 @@
(define (1- n) (- n 1))
(define (mod0 x y) (- x (* (div0 x y) y)))
(define (div x y) (+ (div0 x y)
- (or (and (< x 0)
- (or (and (< y 0) 1)
- -1))
- 0)))
+ (or (and (< x 0)
+ (or (and (< y 0) 1)
+ -1))
+ 0)))
(define (mod x y) (- x (* (div x y) y)))
(define (random n)
(if (integer? n)
@@ -146,8 +146,8 @@
(foldl (λ (a b) (if (< a b) a b)) x0 xs)))
(define (char? x) (eq? (typeof x) 'rune))
(define (array? x) (or (vector? x)
- (let ((t (typeof x)))
- (and (pair? t) (eq? (car t) 'array)))))
+ (let ((t (typeof x)))
+ (and (pair? t) (eq? (car t) 'array)))))
(define (closure? x) (and (function? x) (not (builtin? x))))
(define (caar x) (car (car x)))
@@ -180,16 +180,16 @@
(let ((*values* (list '*values*)))
(set! values
- (λ vs
- (if (and (pair? vs) (null? (cdr vs)))
- (car vs)
- (cons *values* vs))))
+ (λ vs
+ (if (and (pair? vs) (null? (cdr vs)))
+ (car vs)
+ (cons *values* vs))))
(set! call-with-values
- (λ (producer consumer)
- (let ((res (producer)))
- (if (and (pair? res) (eq? *values* (car res)))
- (apply consumer (cdr res))
- (consumer res))))))
+ (λ (producer consumer)
+ (let ((res (producer)))
+ (if (and (pair? res) (eq? *values* (car res)))
+ (apply consumer (cdr res))
+ (consumer res))))))
; list utilities --------------------------------------------------------------
@@ -212,7 +212,7 @@
(define (list-head lst n)
(if (<= n 0) ()
(cons (car lst)
- (list-head (cdr lst) (- n 1)))))
+ (list-head (cdr lst) (- n 1)))))
(define (list-ref lst n)
(car (list-tail lst n)))
@@ -222,15 +222,15 @@
; work and always terminates.
(define (length= lst n)
(cond ((< n 0) #f)
- ((= n 0) (atom? lst))
- ((atom? lst) (= n 0))
- (else (length= (cdr lst) (- n 1)))))
+ ((= n 0) (atom? lst))
+ ((atom? lst) (= n 0))
+ (else (length= (cdr lst) (- n 1)))))
(define (length> lst n)
(cond ((< n 0) lst)
- ((= n 0) (and (pair? lst) lst))
- ((atom? lst) (< n 0))
- (else (length> (cdr lst) (- n 1)))))
+ ((= n 0) (and (pair? lst) lst))
+ ((atom? lst) (< n 0))
+ (else (length> (cdr lst) (- n 1)))))
(define (last-pair l)
(if (atom? (cdr l))
@@ -244,14 +244,14 @@
(define (to-proper l)
(cond ((null? l) l)
- ((atom? l) (list l))
- (else (cons (car l) (to-proper (cdr l))))))
+ ((atom? l) (list l))
+ (else (cons (car l) (to-proper (cdr l))))))
(define (map! f lst)
(prog1 lst
- (while (pair? lst)
- (set-car! lst (f (car lst)))
- (set! lst (cdr lst)))))
+ (while (pair? lst)
+ (set-car! lst (f (car lst)))
+ (set! lst (cdr lst)))))
(define (filter pred lst)
(define (filter- f lst acc)
@@ -258,24 +258,24 @@
(cdr
(prog1 acc
(while (pair? lst)
- (begin (if (pred (car lst))
- (set! acc
- (cdr (set-cdr! acc (cons (car lst) ())))))
- (set! lst (cdr lst)))))))
+ (begin (if (pred (car lst))
+ (set! acc
+ (cdr (set-cdr! acc (cons (car lst) ())))))
+ (set! lst (cdr lst)))))))
(filter- pred lst (list ())))
(define (separate pred lst)
(define (separate- pred lst yes no)
(let ((vals
- (prog1
- (cons yes no)
- (while (pair? lst)
- (begin (if (pred (car lst))
- (set! yes
- (cdr (set-cdr! yes (cons (car lst) ()))))
- (set! no
- (cdr (set-cdr! no (cons (car lst) ())))))
- (set! lst (cdr lst)))))))
+ (prog1
+ (cons yes no)
+ (while (pair? lst)
+ (begin (if (pred (car lst))
+ (set! yes
+ (cdr (set-cdr! yes (cons (car lst) ()))))
+ (set! no
+ (cdr (set-cdr! no (cons (car lst) ())))))
+ (set! lst (cdr lst)))))))
(values (cdr (car vals)) (cdr (cdr vals)))))
(separate- pred lst (list ()) (list ())))
@@ -282,10 +282,10 @@
(define (count f l)
(define (count- f l n)
(if (null? l)
- n
- (count- f (cdr l) (if (f (car l))
- (+ n 1)
- n))))
+ n
+ (count- f (cdr l) (if (f (car l))
+ (+ n 1)
+ n))))
(count- f l 0))
(define (nestlist f zero n)
@@ -308,9 +308,9 @@
(define (reverse!- prev l)
(while (pair? l)
- (set! l (prog1 (cdr l)
- (set-cdr! l (prog1 prev
- (set! prev l))))))
+ (set! l (prog1 (cdr l)
+ (set-cdr! l (prog1 prev
+ (set! prev l))))))
prev)
(define (reverse! l) (reverse!- () l))
@@ -323,22 +323,22 @@
(define (delete-duplicates lst)
(if (length> lst 20)
(let ((t (table)))
- (let loop ((l lst) (acc '()))
- (if (atom? l)
- (reverse! acc)
- (if (has? t (car l))
- (loop (cdr l) acc)
- (begin
- (put! t (car l) #t)
- (loop (cdr l) (cons (car l) acc)))))))
+ (let loop ((l lst) (acc '()))
+ (if (atom? l)
+ (reverse! acc)
+ (if (has? t (car l))
+ (loop (cdr l) acc)
+ (begin
+ (put! t (car l) #t)
+ (loop (cdr l) (cons (car l) acc)))))))
(if (atom? lst)
- lst
- (let ((elt (car lst))
- (tail (cdr lst)))
- (if (member elt tail)
- (delete-duplicates tail)
- (cons elt
- (delete-duplicates tail)))))))
+ lst
+ (let ((elt (car lst))
+ (tail (cdr lst)))
+ (if (member elt tail)
+ (delete-duplicates tail)
+ (cons elt
+ (delete-duplicates tail)))))))
; backquote -------------------------------------------------------------------
@@ -349,7 +349,7 @@
(or (and (atom? x)
(not (symbol? x)))
(and (constant? x)
- (symbol? x)
+ (symbol? x)
(eq x (top-level-value x)))))
(define-macro (quasiquote x) (bq-process x 0))
@@ -356,9 +356,9 @@
(define (splice-form? x)
(or (and (pair? x) (or (eq? (car x) 'unquote-splicing)
- (eq? (car x) 'unquote-nsplicing)
- (and (eq? (car x) 'unquote)
- (length> x 2))))
+ (eq? (car x) 'unquote-nsplicing)
+ (and (eq? (car x) 'unquote)
+ (length> x 2))))
(eq? x 'unquote)))
;; bracket without splicing
@@ -365,71 +365,71 @@
(define (bq-bracket1 x d)
(if (and (pair? x) (eq? (car x) 'unquote))
(if (= d 0)
- (cadr x)
- (list cons ''unquote
- (bq-process (cdr x) (- d 1))))
+ (cadr x)
+ (list cons ''unquote
+ (bq-process (cdr x) (- d 1))))
(bq-process x d)))
(define (bq-bracket x d)
(cond ((atom? x) (list list (bq-process x d)))
- ((eq? (car x) 'unquote)
- (if (= d 0)
- (cons list (cdr x))
- (list list (list cons ''unquote
- (bq-process (cdr x) (- d 1))))))
- ((eq? (car x) 'unquote-splicing)
- (if (= d 0)
- (list 'copy-list (cadr x))
- (list list (list list ''unquote-splicing
- (bq-process (cadr x) (- d 1))))))
- ((eq? (car x) 'unquote-nsplicing)
- (if (= d 0)
- (cadr x)
- (list list (list list ''unquote-nsplicing
- (bq-process (cadr x) (- d 1))))))
- (else (list list (bq-process x d)))))
+ ((eq? (car x) 'unquote)
+ (if (= d 0)
+ (cons list (cdr x))
+ (list list (list cons ''unquote
+ (bq-process (cdr x) (- d 1))))))
+ ((eq? (car x) 'unquote-splicing)
+ (if (= d 0)
+ (list 'copy-list (cadr x))
+ (list list (list list ''unquote-splicing
+ (bq-process (cadr x) (- d 1))))))
+ ((eq? (car x) 'unquote-nsplicing)
+ (if (= d 0)
+ (cadr x)
+ (list list (list list ''unquote-nsplicing
+ (bq-process (cadr x) (- d 1))))))
+ (else (list list (bq-process x d)))))
(define (bq-process x d)
(cond ((symbol? x) (list 'quote x))
- ((vector? x)
- (let ((body (bq-process (vector->list x) d)))
- (if (eq? (car body) list)
- (cons vector (cdr body))
- (list apply vector body))))
+ ((vector? x)
+ (let ((body (bq-process (vector->list x) d)))
+ (if (eq? (car body) list)
+ (cons vector (cdr body))
+ (list apply vector body))))
((atom? x) x)
((eq? (car x) 'quasiquote)
- (list list ''quasiquote (bq-process (cadr x) (+ d 1))))
+ (list list ''quasiquote (bq-process (cadr x) (+ d 1))))
((eq? (car x) 'unquote)
- (if (and (= d 0) (length= x 2))
- (cadr x)
- (list cons ''unquote (bq-process (cdr x) (- d 1)))))
- ((not (any splice-form? x))
+ (if (and (= d 0) (length= x 2))
+ (cadr x)
+ (list cons ''unquote (bq-process (cdr x) (- d 1)))))
+ ((not (any splice-form? x))
(let ((lc (lastcdr x))
(forms (map (λ (x) (bq-bracket1 x d)) x)))
(if (null? lc)
(cons list forms)
- (if (null? (cdr forms))
- (list cons (car forms) (bq-process lc d))
- (nconc (cons list* forms) (list (bq-process lc d)))))))
- (else
- (let loop ((p x) (q ()))
- (cond ((null? p) ;; proper list
- (cons 'nconc (reverse! q)))
- ((pair? p)
- (cond ((eq? (car p) 'unquote)
- ;; (... . ,x)
- (cons 'nconc
- (nreconc q
- (if (= d 0)
- (cdr p)
- (list (list list ''unquote)
- (bq-process (cdr p)
- (- d 1)))))))
- (else
- (loop (cdr p) (cons (bq-bracket (car p) d) q)))))
- (else
- ;; (... . x)
- (cons 'nconc (reverse! (cons (bq-process p d) q)))))))))
+ (if (null? (cdr forms))
+ (list cons (car forms) (bq-process lc d))
+ (nconc (cons list* forms) (list (bq-process lc d)))))))
+ (else
+ (let loop ((p x) (q ()))
+ (cond ((null? p) ;; proper list
+ (cons 'nconc (reverse! q)))
+ ((pair? p)
+ (cond ((eq? (car p) 'unquote)
+ ;; (... . ,x)
+ (cons 'nconc
+ (nreconc q
+ (if (= d 0)
+ (cdr p)
+ (list (list list ''unquote)
+ (bq-process (cdr p)
+ (- d 1)))))))
+ (else
+ (loop (cdr p) (cons (bq-bracket (car p) d) q)))))
+ (else
+ ;; (... . x)
+ (cons 'nconc (reverse! (cons (bq-process p d) q)))))))))
; standard macros -------------------------------------------------------------
@@ -441,10 +441,10 @@
(define-macro (let* binds . body)
(if (atom? binds) `((λ () ,@body))
`((λ (,(caar binds))
- ,@(if (pair? (cdr binds))
- `((let* ,(cdr binds) ,@body))
- body))
- ,(cadar binds))))
+ ,@(if (pair? (cdr binds))
+ `((let* ,(cdr binds) ,@body))
+ body))
+ ,(cadar binds))))
(define-macro (when c . body) (list 'if c (cons 'begin body) #f))
(define-macro (unless c . body) (list 'if c #f (cons 'begin body)))
@@ -452,37 +452,37 @@
(define-macro (case key . clauses)
(define (vals->cond key v)
(cond ((eq? v 'else) 'else)
- ((null? v) #f)
- ((symbol? v) `(eq? ,key ,(quote-value v)))
+ ((null? v) #f)
+ ((symbol? v) `(eq? ,key ,(quote-value v)))
((atom? v) `(eqv? ,key ,(quote-value v)))
- ((null? (cdr v)) `(eqv? ,key ,(quote-value (car v))))
- ((every symbol? v)
- `(memq ,key ',v))
- (else `(memv ,key ',v))))
+ ((null? (cdr v)) `(eqv? ,key ,(quote-value (car v))))
+ ((every symbol? v)
+ `(memq ,key ',v))
+ (else `(memv ,key ',v))))
(let ((g (gensym)))
`(let ((,g ,key))
(cond ,.(map (λ (clause)
- (cons (vals->cond g (car clause))
- (cdr clause)))
- clauses)))))
+ (cons (vals->cond g (car clause))
+ (cdr clause)))
+ clauses)))))
(define-macro (do vars test-spec . commands)
(let ((loop (gensym))
- (test-expr (car test-spec))
- (vars (map car vars))
- (inits (map cadr vars))
- (steps (map (λ (x)
- (if (pair? (cddr x))
- (caddr x)
- (car x)))
- vars)))
+ (test-expr (car test-spec))
+ (vars (map car vars))
+ (inits (map cadr vars))
+ (steps (map (λ (x)
+ (if (pair? (cddr x))
+ (caddr x)
+ (car x)))
+ vars)))
`(letrec ((,loop (λ ,vars
- (if ,test-expr
- (begin
- ,@(cdr test-spec))
- (begin
- ,@commands
- (,loop ,.steps))))))
+ (if ,test-expr
+ (begin
+ ,@(cdr test-spec))
+ (begin
+ ,@commands
+ (,loop ,.steps))))))
(,loop ,.inits))))
; SRFI 8
@@ -513,24 +513,24 @@
(define (for-each f l . lsts)
(define (for-each-n f lsts)
(if (pair? (car lsts))
- (begin (apply f (map car lsts))
- (for-each-n f (map cdr lsts)))))
+ (begin (apply f (map car lsts))
+ (for-each-n f (map cdr lsts)))))
(if (null? lsts)
(while (pair? l)
- (begin (f (car l))
- (set! l (cdr l))))
+ (begin (f (car l))
+ (set! l (cdr l))))
(for-each-n f (cons l lsts)))
#t)
(define-macro (with-bindings binds . body)
(let ((vars (map car binds))
- (vals (map cadr binds))
- (olds (map (λ (x) (gensym)) binds)))
+ (vals (map cadr binds))
+ (olds (map (λ (x) (gensym)) binds)))
`(let ,(map list olds vars)
,@(map (λ (v val) `(set! ,v ,val)) vars vals)
(unwind-protect
- (begin ,@body)
- (begin ,@(map (λ (v old) `(set! ,v ,old)) vars olds))))))
+ (begin ,@body)
+ (begin ,@(map (λ (v old) `(set! ,v ,old)) vars olds))))))
; exceptions ------------------------------------------------------------------
@@ -544,15 +544,15 @@
(eq (car ,e) 'thrown-value)
(eq (cadr ,e) ,tag))
(caddr ,e)
- (raise ,e))))))
+ (raise ,e))))))
(define-macro (unwind-protect expr finally)
(let ((e (gensym))
- (thk (gensym)))
+ (thk (gensym)))
`(let ((,thk (λ () ,finally)))
(prog1 (trycatch ,expr
- (λ (,e) (begin (,thk) (raise ,e))))
- (,thk)))))
+ (λ (,e) (begin (,thk) (raise ,e))))
+ (,thk)))))
; debugging utilities ---------------------------------------------------------
@@ -560,37 +560,37 @@
(define traced?
(letrec ((sample-traced-lambda (λ args (begin (write (cons 'x args))
- (newline)
- (apply #.apply args)))))
+ (newline)
+ (apply #.apply args)))))
(λ (f)
(and (closure? f)
- (equal? (function:code f)
- (function:code sample-traced-lambda))))))
+ (equal? (function:code f)
+ (function:code sample-traced-lambda))))))
(define (trace sym)
(let* ((func (top-level-value sym))
- (args (gensym)))
+ (args (gensym)))
(if (not (traced? func))
- (set-top-level-value! sym
- (eval
- `(λ ,args
- (begin (write (cons ',sym ,args))
- (newline)
- (apply ',func ,args)))))))
+ (set-top-level-value! sym
+ (eval
+ `(λ ,args
+ (begin (write (cons ',sym ,args))
+ (newline)
+ (apply ',func ,args)))))))
'ok)
(define (untrace sym)
(let ((func (top-level-value sym)))
(if (traced? func)
- (set-top-level-value! sym
- (aref (function:vals func) 2)))))
+ (set-top-level-value! sym
+ (aref (function:vals func) 2)))))
(define-macro (time expr)
(let ((t0 (gensym)))
`(let ((,t0 (time-now)))
(prog1
- ,expr
- (princ "Elapsed time: " (- (time-now) ,t0) " seconds\n")))))
+ ,expr
+ (princ "Elapsed time: " (- (time-now) ,t0) " seconds\n")))))
; text I/O --------------------------------------------------------------------
@@ -597,7 +597,7 @@
(define (print . args) (for-each write args))
(define (princ . args)
(with-bindings ((*print-readably* #f))
- (for-each write args)))
+ (for-each write args)))
(define (newline (port *output-stream*))
(io-write port *linefeed*)
@@ -608,10 +608,10 @@
; call f on a stream until the stream runs out of data
(define (read-all-of f s)
(let loop ((lines ())
- (curr (f s)))
+ (curr (f s)))
(if (io-eof? s)
- (reverse! lines)
- (loop (cons curr lines) (f s)))))
+ (reverse! lines)
+ (loop (cons curr lines) (f s)))))
(define (io-readlines s) (read-all-of io-readline s))
(define (read-all s) (read-all-of read s))
@@ -621,15 +621,15 @@
(io-copy b s)
(let ((str (iostream->string b)))
(if (and (equal? str "") (io-eof? s))
- (eof-object)
- str))))
+ (eof-object)
+ str))))
(define-macro (with-output-to stream . body)
`(with-bindings ((*output-stream* ,stream))
- ,@body))
+ ,@body))
(define-macro (with-input-from stream . body)
`(with-bindings ((*input-stream* ,stream))
- ,@body))
+ ,@body))
; vector functions ------------------------------------------------------------
@@ -669,7 +669,7 @@
(define (table-invert t)
(let ((nt (table)))
(table-foldl (λ (k v z) (put! nt v k))
- () t)
+ () t)
nt))
(define (table-foreach f t)
(table-foldl (λ (k v z) (begin (f k v) #t)) () t))
@@ -681,34 +681,34 @@
(define (string-trim s at-start at-end)
(define (trim-start s chars i L)
(if (and (< i L) (string-find chars (string-char s i)))
- (trim-start s chars (1+ i) L)
- i))
+ (trim-start s chars (1+ i) L)
+ i))
(define (trim-end s chars i)
(if (and (> i 0) (string-find chars (string-char s (1- i))))
- (trim-end s chars (1- i))
- i))
+ (trim-end s chars (1- i))
+ i))
(let ((L (string-length s)))
(string-sub s
- (trim-start s at-start 0 L)
- (trim-end s at-end L))))
+ (trim-start s at-start 0 L)
+ (trim-end s at-end L))))
(define (string-map f s)
(let ((b (buffer))
- (n (string-length s)))
+ (n (string-length s)))
(let ((i 0))
(while (< i n)
- (begin (io-putc b (f (string-char s i)))
- (set! i (1+ i)))))
+ (begin (io-putc b (f (string-char s i)))
+ (set! i (1+ i)))))
(iostream->string b)))
(define (string-rep s k)
(cond ((< k 4)
- (cond ((<= k 0) "")
- ((= k 1) (string s))
- ((= k 2) (string s s))
- (else (string s s s))))
- ((odd? k) (string s (string-rep s (- k 1))))
- (else (string-rep (string s s) (/ k 2)))))
+ (cond ((<= k 0) "")
+ ((= k 1) (string s))
+ ((= k 2) (string s s))
+ (else (string s s s))))
+ ((odd? k) (string s (string-rep s (- k 1))))
+ (else (string-rep (string s s) (/ k 2)))))
(define (string-lpad s n c) (string (string-rep c (- n (string-length s))) s))
(define (string-rpad s n c) (string s (string-rep c (- n (string-length s)))))
@@ -721,150 +721,150 @@
(define (string-join strlist sep)
(if (null? strlist) ""
(let ((b (buffer)))
- (io-write b (car strlist))
- (for-each (λ (s) (begin (io-write b sep)
- (io-write b s)))
- (cdr strlist))
- (iostream->string b))))
+ (io-write b (car strlist))
+ (for-each (λ (s) (begin (io-write b sep)
+ (io-write b s)))
+ (cdr strlist))
+ (iostream->string b))))
; toplevel --------------------------------------------------------------------
(define (macrocall? e) (and (symbol? (car e))
- (symbol-syntax (car e))))
+ (symbol-syntax (car e))))
(define (macroexpand-1 e)
(if (atom? e) e
(let ((f (macrocall? e)))
- (if f (apply f (cdr e))
- e))))
+ (if f (apply f (cdr e))
+ e))))
(define (expand e)
; symbol resolves to toplevel; i.e. has no shadowing definition
(define (top? s env) (not (or (bound? s) (assq s env))))
-
+
(define (splice-begin body)
(cond ((atom? body) body)
- ((equal? body '((begin)))
- body)
- ((and (pair? (car body))
- (eq? (caar body) 'begin))
- (append (splice-begin (cdar body)) (splice-begin (cdr body))))
- (else
- (cons (car body) (splice-begin (cdr body))))))
-
+ ((equal? body '((begin)))
+ body)
+ ((and (pair? (car body))
+ (eq? (caar body) 'begin))
+ (append (splice-begin (cdar body)) (splice-begin (cdr body))))
+ (else
+ (cons (car body) (splice-begin (cdr body))))))
+
(define *expanded* (list '*expanded*))
-
+
(define (expand-body body env)
(if (atom? body) body
- (let* ((body (if (top? 'begin env)
- (splice-begin body)
- body))
- (def? (top? 'define env))
- (dvars (if def? (get-defined-vars body) ()))
- (env (nconc (map list dvars) env)))
- (if (not def?)
- (map (λ (x) (expand-in x env)) body)
- (let* ((ex-nondefs ; expand non-definitions
- (let loop ((body body))
- (cond ((atom? body) body)
- ((and (pair? (car body))
- (eq? 'define (caar body)))
- (cons (car body) (loop (cdr body))))
- (else
- (let ((form (expand-in (car body) env)))
- (set! env (nconc
- (map list (get-defined-vars form))
- env))
- (cons
- (cons *expanded* form)
- (loop (cdr body))))))))
- (body ex-nondefs))
- (while (pair? body) ; now expand deferred definitions
- (if (not (eq? *expanded* (caar body)))
- (set-car! body (expand-in (car body) env))
- (set-car! body (cdar body)))
- (set! body (cdr body)))
- ex-nondefs)))))
-
+ (let* ((body (if (top? 'begin env)
+ (splice-begin body)
+ body))
+ (def? (top? 'define env))
+ (dvars (if def? (get-defined-vars body) ()))
+ (env (nconc (map list dvars) env)))
+ (if (not def?)
+ (map (λ (x) (expand-in x env)) body)
+ (let* ((ex-nondefs ; expand non-definitions
+ (let loop ((body body))
+ (cond ((atom? body) body)
+ ((and (pair? (car body))
+ (eq? 'define (caar body)))
+ (cons (car body) (loop (cdr body))))
+ (else
+ (let ((form (expand-in (car body) env)))
+ (set! env (nconc
+ (map list (get-defined-vars form))
+ env))
+ (cons
+ (cons *expanded* form)
+ (loop (cdr body))))))))
+ (body ex-nondefs))
+ (while (pair? body) ; now expand deferred definitions
+ (if (not (eq? *expanded* (caar body)))
+ (set-car! body (expand-in (car body) env))
+ (set-car! body (cdar body)))
+ (set! body (cdr body)))
+ ex-nondefs)))))
+
(define (expand-lambda-list l env)
(if (atom? l) l
- (cons (if (and (pair? (car l)) (pair? (cdr (car l))))
- (list (caar l) (expand-in (cadar l) env))
- (car l))
- (expand-lambda-list (cdr l) env))))
-
+ (cons (if (and (pair? (car l)) (pair? (cdr (car l))))
+ (list (caar l) (expand-in (cadar l) env))
+ (car l))
+ (expand-lambda-list (cdr l) env))))
+
(define (l-vars l)
(cond ((atom? l) (list l))
- ((pair? (car l)) (cons (caar l) (l-vars (cdr l))))
- (else (cons (car l) (l-vars (cdr l))))))
-
+ ((pair? (car l)) (cons (caar l) (l-vars (cdr l))))
+ (else (cons (car l) (l-vars (cdr l))))))
+
(define (expand-lambda e env)
(let ((formals (cadr e))
- (name (lastcdr e))
- (body (cddr e))
- (vars (l-vars (cadr e))))
+ (name (lastcdr e))
+ (body (cddr e))
+ (vars (l-vars (cadr e))))
(let ((env (nconc (map list vars) env)))
- `(λ ,(expand-lambda-list formals env)
- ,.(expand-body body env)
- . ,name))))
-
+ `(λ ,(expand-lambda-list formals env)
+ ,.(expand-body body env)
+ . ,name))))
+
(define (expand-define e env)
(if (or (null? (cdr e)) (atom? (cadr e)))
- (if (null? (cddr e))
- e
- `(define ,(cadr e) ,(expand-in (caddr e) env)))
- (let ((formals (cdadr e))
- (name (caadr e))
- (body (cddr e))
- (vars (l-vars (cdadr e))))
- (let ((env (nconc (map list vars) env)))
- `(define ,(cons name (expand-lambda-list formals env))
- ,.(expand-body body env))))))
-
+ (if (null? (cddr e))
+ e
+ `(define ,(cadr e) ,(expand-in (caddr e) env)))
+ (let ((formals (cdadr e))
+ (name (caadr e))
+ (body (cddr e))
+ (vars (l-vars (cdadr e))))
+ (let ((env (nconc (map list vars) env)))
+ `(define ,(cons name (expand-lambda-list formals env))
+ ,.(expand-body body env))))))
+
(define (expand-let-syntax e env)
(let ((binds (cadr e)))
(cons 'begin
- (expand-body (cddr e)
- (nconc
- (map (λ (bind)
- (list (car bind)
- ((compile-thunk
- (expand-in (cadr bind) env)))
- env))
- binds)
- env)))))
-
+ (expand-body (cddr e)
+ (nconc
+ (map (λ (bind)
+ (list (car bind)
+ ((compile-thunk
+ (expand-in (cadr bind) env)))
+ env))
+ binds)
+ env)))))
+
; given let-syntax definition environment (menv) and environment
; at the point of the macro use (lenv), return the environment to
; expand the macro use in. TODO
(define (local-expansion-env menv lenv) menv)
-
+
(define (expand-in e env)
(if (atom? e) e
- (let* ((head (car e))
- (bnd (assq head env))
- (default (λ ()
- (let loop ((e e))
- (if (atom? e) e
- (cons (if (atom? (car e))
- (car e)
- (expand-in (car e) env))
- (loop (cdr e))))))))
- (cond ((and bnd (pair? (cdr bnd))) ; local macro
- (expand-in (apply (cadr bnd) (cdr e))
- (local-expansion-env (caddr bnd) env)))
- ((or bnd ; bound lexical or toplevel var
- (not (symbol? head))
- (bound? head))
- (default))
- ((macrocall? e) => (λ (f)
- (expand-in (apply f (cdr e)) env)))
- ((eq? head 'quote) e)
- ((eq? head 'λ) (expand-lambda e env))
- ((eq? head 'lambda) (expand-lambda e env))
- ((eq? head 'define) (expand-define e env))
- ((eq? head 'let-syntax) (expand-let-syntax e env))
- (else (default))))))
+ (let* ((head (car e))
+ (bnd (assq head env))
+ (default (λ ()
+ (let loop ((e e))
+ (if (atom? e) e
+ (cons (if (atom? (car e))
+ (car e)
+ (expand-in (car e) env))
+ (loop (cdr e))))))))
+ (cond ((and bnd (pair? (cdr bnd))) ; local macro
+ (expand-in (apply (cadr bnd) (cdr e))
+ (local-expansion-env (caddr bnd) env)))
+ ((or bnd ; bound lexical or toplevel var
+ (not (symbol? head))
+ (bound? head))
+ (default))
+ ((macrocall? e) => (λ (f)
+ (expand-in (apply f (cdr e)) env)))
+ ((eq? head 'quote) e)
+ ((eq? head 'λ) (expand-lambda e env))
+ ((eq? head 'lambda) (expand-lambda e env))
+ ((eq? head 'define) (expand-define e env))
+ ((eq? head 'let-syntax) (expand-let-syntax e env))
+ (else (default))))))
(expand-in e ()))
(define (eval x) ((compile-thunk (expand x))))
@@ -876,74 +876,74 @@
(trycatch
(let next (prev E v)
(if (not (io-eof? F))
- (next (read F)
+ (next (read F)
prev
- (load-process E))
- (begin (io-close F)
- ; evaluate last form in almost-tail position
- (load-process E))))
+ (load-process E))
+ (begin (io-close F)
+ ; evaluate last form in almost-tail position
+ (load-process E))))
(λ (e)
(begin
- (io-close F)
- (raise `(load-error ,filename ,e)))))))
+ (io-close F)
+ (raise `(load-error ,filename ,e)))))))
(define (repl)
(define (prompt)
(princ "> ") (io-flush *output-stream*)
(let ((v (trycatch (read)
- (λ (e) (begin (io-discardbuffer *input-stream*)
- (raise e))))))
+ (λ (e) (begin (io-discardbuffer *input-stream*)
+ (raise e))))))
(and (not (io-eof? *input-stream*))
- (let ((V (load-process v)))
- (print V)
- (set! that V)
- #t))))
+ (let ((V (load-process v)))
+ (print V)
+ (set! that V)
+ #t))))
(define (reploop)
(when (trycatch (and (prompt) (newline))
- (λ (e)
- (top-level-exception-handler e)
- #t))
- (begin (newline)
- (reploop))))
+ (λ (e)
+ (top-level-exception-handler e)
+ #t))
+ (begin (newline)
+ (reploop))))
(reploop)
(newline))
(define (top-level-exception-handler e)
(with-output-to *stderr*
- (print-exception e)
- (print-stack-trace (stacktrace))))
+ (print-exception e)
+ (print-stack-trace (stacktrace))))
(define (print-stack-trace st)
(define (find-in-f f tgt path)
(let ((path (cons (function:name f) path)))
(if (eq? (function:code f) (function:code tgt))
- (throw 'ffound path)
- (let ((v (function:vals f)))
- (for 0 (1- (length v))
- (λ (i) (if (closure? (aref v i))
- (find-in-f (aref v i) tgt path))))))))
+ (throw 'ffound path)
+ (let ((v (function:vals f)))
+ (for 0 (1- (length v))
+ (λ (i) (if (closure? (aref v i))
+ (find-in-f (aref v i) tgt path))))))))
(define (fn-name f e)
(let ((p (catch 'ffound
- (begin
- (for-each (λ (topfun)
- (find-in-f topfun f ()))
- e)
- #f))))
+ (begin
+ (for-each (λ (topfun)
+ (find-in-f topfun f ()))
+ e)
+ #f))))
(if p
- (symbol (string-join (map string (reverse! p)) "/"))
- 'λ)))
+ (symbol (string-join (map string (reverse! p)) "/"))
+ 'λ)))
(let ((st (reverse! (if (length> st 3)
(list-tail st (if *interactive* 5 4))
st)))
- (e (filter closure? (map (λ (s) (and (bound? s)
- (top-level-value s)))
- (environment))))
- (n 0))
+ (e (filter closure? (map (λ (s) (and (bound? s)
+ (top-level-value s)))
+ (environment))))
+ (n 0))
(for-each
(λ (f)
(princ "#" n " ")
(print (cons (fn-name (aref f 0) e)
- (cdr (vector->list f))))
+ (cdr (vector->list f))))
(newline)
(set! n (+ n 1)))
st)))
@@ -950,43 +950,43 @@
(define (print-exception e)
(cond ((and (pair? e)
- (eq? (car e) 'type-error)
- (length= e 4))
- (princ "type error: " (cadr e) ": expected " (caddr e) ", got ")
- (print (cadddr e)))
+ (eq? (car e) 'type-error)
+ (length= e 4))
+ (princ "type error: " (cadr e) ": expected " (caddr e) ", got ")
+ (print (cadddr e)))
- ((and (pair? e)
- (eq? (car e) 'bounds-error)
- (length= e 4))
- (princ (cadr e) ": index " (cadddr e) " out of bounds for ")
- (print (caddr e)))
+ ((and (pair? e)
+ (eq? (car e) 'bounds-error)
+ (length= e 4))
+ (princ (cadr e) ": index " (cadddr e) " out of bounds for ")
+ (print (caddr e)))
- ((and (pair? e)
- (eq? (car e) 'unbound-error)
- (pair? (cdr e)))
- (princ "eval: variable " (caddr e) " has no value"))
+ ((and (pair? e)
+ (eq? (car e) 'unbound-error)
+ (pair? (cdr e)))
+ (princ "eval: variable " (caddr e) " has no value"))
- ((and (pair? e)
- (eq? (car e) 'error))
- (princ "error: ")
- (apply princ (cdr e)))
+ ((and (pair? e)
+ (eq? (car e) 'error))
+ (princ "error: ")
+ (apply princ (cdr e)))
- ((and (pair? e)
- (eq? (car e) 'load-error))
- (print-exception (caddr e))
- (princ "in file " (cadr e)))
+ ((and (pair? e)
+ (eq? (car e) 'load-error))
+ (print-exception (caddr e))
+ (princ "in file " (cadr e)))
- ((and (list? e)
- (length= e 2))
- (print (car e))
- (princ ": ")
- (let ((msg (cadr e)))
- ((if (or (string? msg) (symbol? msg))
- princ print)
- msg)))
+ ((and (list? e)
+ (length= e 2))
+ (print (car e))
+ (princ ": ")
+ (let ((msg (cadr e)))
+ ((if (or (string? msg) (symbol? msg))
+ princ print)
+ msg)))
- (else (princ "*** Unhandled exception: ")
- (print e)))
+ (else (princ "*** Unhandled exception: ")
+ (print e)))
(princ *linefeed*))
@@ -993,31 +993,31 @@
(define (simple-sort l)
(if (or (null? l) (null? (cdr l))) l
(let ((piv (car l)))
- (receive (less grtr)
- (separate (λ (x) (< x piv)) (cdr l))
- (nconc (simple-sort less)
- (list piv)
- (simple-sort grtr))))))
+ (receive (less grtr)
+ (separate (λ (x) (< x piv)) (cdr l))
+ (nconc (simple-sort less)
+ (list piv)
+ (simple-sort grtr))))))
(define (make-system-image fname)
(let ((f (file fname :write :create :truncate))
- (excludes '(*linefeed* *directory-separator* *argv* that
- *print-pretty* *print-width* *print-readably*
- *print-level* *print-length* *os-name*)))
+ (excludes '(*linefeed* *directory-separator* *argv* that
+ *print-pretty* *print-width* *print-readably*
+ *print-level* *print-length* *os-name*)))
(with-bindings ((*print-pretty* #t)
- (*print-readably* #t))
+ (*print-readably* #t))
(let ((syms
- (filter (λ (s)
- (and (bound? s)
- (not (constant? s))
- (or (not (builtin? (top-level-value s)))
- (not (equal? (string s) ; alias of builtin
- (string (top-level-value s)))))
- (not (memq s excludes))
- (not (iostream? (top-level-value s)))))
- (simple-sort (environment)))))
- (write (apply nconc (map list syms (map top-level-value syms))) f)
- (io-write f *linefeed*))
+ (filter (λ (s)
+ (and (bound? s)
+ (not (constant? s))
+ (or (not (builtin? (top-level-value s)))
+ (not (equal? (string s) ; alias of builtin
+ (string (top-level-value s)))))
+ (not (memq s excludes))
+ (not (iostream? (top-level-value s)))))
+ (simple-sort (environment)))))
+ (write (apply nconc (map list syms (map top-level-value syms))) f)
+ (io-write f *linefeed*))
(io-close f))))
; initialize globals that need to be set at load time
@@ -1030,8 +1030,8 @@
(define (__script fname)
(trycatch (load fname)
- (λ (e) (begin (top-level-exception-handler e)
- (exit 1)))))
+ (λ (e) (begin (top-level-exception-handler e)
+ (exit 1)))))
(define (__rcscript)
(let ((fname (case *os-name*
@@ -1044,10 +1044,10 @@
(__init_globals)
(if (pair? (cdr argv))
(begin (set! *argv* (cdr argv))
- (set! *interactive* #f)
- (__script (cadr argv)))
+ (set! *interactive* #f)
+ (__script (cadr argv)))
(begin (set! *argv* argv)
- (set! *interactive* #t)
+ (set! *interactive* #t)
(__rcscript)
- (repl)))
+ (repl)))
(exit 0))
--- a/test/ast/match.lsp
+++ b/test/ast/match.lsp
@@ -46,10 +46,10 @@
(if capt
(and (equal? expr (cdr capt)) state)
(cons (cons p expr) state))))))
-
+
((procedure? p)
(and (p expr) state))
-
+
((pair? p)
(cond ((eq (car p) '-/) (and (equal? (cadr p) expr) state))
((eq (car p) '-^) (and (not (match- (cadr p) expr state)) state))
@@ -62,7 +62,7 @@
(and (pair? expr)
(equal? (car p) (car expr))
(match-seq (cdr p) (cdr expr) state (length (cdr expr)))))))
-
+
(#t
(and (equal? p expr) state))))
@@ -97,7 +97,7 @@
(#t
(or (match-star- p prest expr state var 0 0 L sofar)
(match-star- p prest expr state var 1 max L sofar)))))
-(define (match-star p prest expr state var min max L)
+(define (match-star p prest expr state var min max L)
(match-star- p prest expr state var min max L ()))
; match sequences of expressions
@@ -136,12 +136,12 @@
(cond ((and (symbol? p)
(not (member p metasymbols)))
(list p))
-
+
((pair? p)
(if (eq (car p) '-/)
()
(unique (apply append (map patargs- (cdr p))))))
-
+
(#t ())))
(define (patargs p)
(cons '__ (patargs- p)))
--- a/test/ast/match.scm
+++ b/test/ast/match.scm
@@ -38,10 +38,10 @@
(if capt
(and (equal? expr (cdr capt)) state)
(cons (cons p expr) state))))))
-
+
((procedure? p)
(and (p expr) state))
-
+
((pair? p)
(cond ((eq? (car p) '-/) (and (equal? (cadr p) expr) state))
((eq? (car p) '-^) (and (not (match- (cadr p) expr state)) state))
@@ -54,7 +54,7 @@
(and (pair? expr)
(equal? (car p) (car expr))
(match-seq (cdr p) (cdr expr) state (length (cdr expr)))))))
-
+
(else
(and (equal? p expr) state))))
@@ -90,7 +90,7 @@
(else
(or (match-star- p prest expr state var 0 0 L sofar)
(match-star- p prest expr state var 1 max L sofar)))))
-
+
(match-star- p prest expr state var min max L ()))
; match sequences of expressions
@@ -130,12 +130,12 @@
(cond ((and (symbol? p)
(not (member p metasymbols)))
(list p))
-
+
((pair? p)
(if (eq? (car p) '-/)
()
(delete-duplicates (apply append (map patargs- (cdr p))))))
-
+
(else ())))
(cons '__ (patargs- p)))
--- a/test/color.lsp
+++ b/test/color.lsp
@@ -52,7 +52,7 @@
(define (try-each f lst)
(if (null? lst) #f
(let ((ret (f (car lst))))
- (if ret ret (try-each f (cdr lst))))))
+ (if ret ret (try-each f (cdr lst))))))
(define (color-node g coloring colors uncolored-nodes color)
(cond
--- a/test/perf.lsp
+++ b/test/perf.lsp
@@ -19,10 +19,10 @@
(cond ((null? lsts) ())
((null? (cdr lsts)) (car lsts))
(else (letrec ((append2 (lambda (l d)
- (if (null? l) d
- (cons (car l)
- (append2 (cdr l) d))))))
- (append2 (car lsts) (apply my-append (cdr lsts)))))))
+ (if (null? l) d
+ (cons (car l)
+ (append2 (cdr l) d))))))
+ (append2 (car lsts) (apply my-append (cdr lsts)))))))
(princ "append: ")
(set! L (map-int (lambda (x) (map-int identity 20)) 20))
--- a/test/tcolor.lsp
+++ b/test/tcolor.lsp
@@ -10,7 +10,7 @@
(dotimes (n 99) (color-pairs Q '(a b c d e))))
(time (ct))
(assert (equal? C
- '((23 . a) (9 . a) (22 . b) (17 . d) (14 . d) (8 . b) (21 . e)
- (19 . b) (16 . c) (13 . c) (11 . b) (7 . e) (24 . c) (20 . d)
- (18 . e) (15 . a) (12 . a) (10 . e) (6 . d) (5 . c) (4 . e)
- (3 . d) (2 . c) (0 . b) (1 . a))))
+ '((23 . a) (9 . a) (22 . b) (17 . d) (14 . d) (8 . b) (21 . e)
+ (19 . b) (16 . c) (13 . c) (11 . b) (7 . e) (24 . c) (20 . d)
+ (18 . e) (15 . a) (12 . a) (10 . e) (6 . d) (5 . c) (4 . e)
+ (3 . d) (2 . c) (0 . b) (1 . a))))
--- a/test/test.lsp
+++ b/test/test.lsp
@@ -19,10 +19,10 @@
(cond ((null? lsts) ())
((null? (cdr lsts)) (car lsts))
(#t ((label append2 (lambda (l d)
- (if (null? l) d
- (cons (car l)
- (append2 (cdr l) d)))))
- (car lsts) (append-h (cdr lsts)))))))
+ (if (null? l) d
+ (cons (car l)
+ (append2 (cdr l) d)))))
+ (car lsts) (append-h (cdr lsts)))))))
lsts))
;(princ 'Hello '| | 'world! "\n")
@@ -49,13 +49,13 @@
(if (<= n 0)
()
(let ((first (cons (f 0) ())))
- ((label map-int-
- (lambda (acc i n)
- (if (= i n)
- first
- (begin (set-cdr! acc (cons (f i) ()))
- (map-int- (cdr acc) (+ i 1) n)))))
- first 1 n))))
+ ((label map-int-
+ (lambda (acc i n)
+ (if (= i n)
+ first
+ (begin (set-cdr! acc (cons (f i) ()))
+ (map-int- (cdr acc) (+ i 1) n)))))
+ first 1 n))))
|#
(define-macro (labl name fn)
@@ -91,7 +91,7 @@
((label mapl-
(lambda (lsts)
(if (null? (car lsts)) ()
- (begin (apply f lsts) (mapl- (map cdr lsts))))))
+ (begin (apply f lsts) (mapl- (map cdr lsts))))))
lsts))
; test to see if a symbol begins with :
@@ -102,7 +102,7 @@
(define (swapad c)
(if (atom? c) c
(set-cdr! c (K (swapad (car c))
- (set-car! c (swapad (cdr c)))))))
+ (set-car! c (swapad (cdr c)))))))
(define (without x l)
(filter (lambda (e) (not (eq e x))) l))
@@ -120,7 +120,7 @@
;[` _ ,_ |- | . _ 2
;| (/_||||_()|_|_\|)
-; |
+; |
(define-macro (while- test . forms)
`((label -loop- (lambda ()
@@ -127,7 +127,7 @@
(if ,test
(begin ,@forms
(-loop-))
- ())))))
+ ())))))
; this would be a cool use of thunking to handle 'finally' clauses, but
; this code doesn't work in the case where the user manually re-raises
@@ -183,22 +183,22 @@
(let ((acc (gensym)))
`(let ((,acc (list ())))
(cdr
- (prog1 ,acc
- (while ,cnd
- (begin (set! ,acc
- (cdr (set-cdr! ,acc (cons ,what ()))))
- ,@body)))))))
+ (prog1 ,acc
+ (while ,cnd
+ (begin (set! ,acc
+ (cdr (set-cdr! ,acc (cons ,what ()))))
+ ,@body)))))))
(define-macro (accumulate-for var lo hi what . body)
(let ((acc (gensym)))
`(let ((,acc (list ())))
(cdr
- (prog1 ,acc
- (for ,lo ,hi
- (lambda (,var)
- (begin (set! ,acc
- (cdr (set-cdr! ,acc (cons ,what ()))))
- ,@body))))))))
+ (prog1 ,acc
+ (for ,lo ,hi
+ (lambda (,var)
+ (begin (set! ,acc
+ (cdr (set-cdr! ,acc (cons ,what ()))))
+ ,@body))))))))
(define (map-indexed f lst)
(if (atom? lst) lst
@@ -209,78 +209,78 @@
(let ((*profiles* (table)))
(set! profile
- (lambda (s)
- (let ((f (top-level-value s)))
- (put! *profiles* s (cons 0 0))
- (set-top-level-value! s
- (lambda args
- (define tt (get *profiles* s))
- (define count (car tt))
- (define time (cdr tt))
- (define t0 (time-now))
- (define v (apply f args))
- (set-cdr! tt (+ time (- (time-now) t0)))
- (set-car! tt (+ count 1))
- v)))))
+ (lambda (s)
+ (let ((f (top-level-value s)))
+ (put! *profiles* s (cons 0 0))
+ (set-top-level-value! s
+ (lambda args
+ (define tt (get *profiles* s))
+ (define count (car tt))
+ (define time (cdr tt))
+ (define t0 (time-now))
+ (define v (apply f args))
+ (set-cdr! tt (+ time (- (time-now) t0)))
+ (set-car! tt (+ count 1))
+ v)))))
(set! show-profiles
- (lambda ()
- (define pr (filter (lambda (x) (> (cadr x) 0))
- (table-pairs *profiles*)))
- (define width (+ 4
- (apply max
- (map (lambda (x)
- (length (string x)))
- (cons 'Function
- (map car pr))))))
- (princ (string-rpad "Function" width #\ )
- "#Calls Time (seconds)")
- (newline)
- (princ (string-rpad "--------" width #\ )
- "------ --------------")
- (newline)
- (for-each
- (lambda (p)
- (princ (string-rpad (string (caddr p)) width #\ )
- (string-rpad (string (cadr p)) 11 #\ )
- (car p))
- (newline))
- (simple-sort (map (lambda (l) (reverse (to-proper l)))
- pr)))))
- (set! clear-profiles
- (lambda ()
- (for-each (lambda (k)
- (put! *profiles* k (cons 0 0)))
- (table-keys *profiles*)))))
+ (lambda ()
+ (define pr (filter (lambda (x) (> (cadr x) 0))
+ (table-pairs *profiles*)))
+ (define width (+ 4
+ (apply max
+ (map (lambda (x)
+ (length (string x)))
+ (cons 'Function
+ (map car pr))))))
+ (princ (string-rpad "Function" width #\ )
+ "#Calls Time (seconds)")
+ (newline)
+ (princ (string-rpad "--------" width #\ )
+ "------ --------------")
+ (newline)
+ (for-each
+ (lambda (p)
+ (princ (string-rpad (string (caddr p)) width #\ )
+ (string-rpad (string (cadr p)) 11 #\ )
+ (car p))
+ (newline))
+ (simple-sort (map (lambda (l) (reverse (to-proper l)))
+ pr)))))
+ (set! clear-profiles
+ (lambda ()
+ (for-each (lambda (k)
+ (put! *profiles* k (cons 0 0)))
+ (table-keys *profiles*)))))
#;(for-each profile
- '(emit encode-byte-code const-to-idx-vec
- index-of lookup-sym in-env? any every
- compile-sym compile-if compile-begin
- compile-arglist expand builtin->instruction
- compile-app separate nconc get-defined-vars
- compile-in compile compile-f delete-duplicates
- map length> length= count filter append
- lastcdr to-proper reverse reverse! list->vector
- taboreach list-head list-tail assq memq assoc member
- assv memv nreconc bq-process))
+ '(emit encode-byte-code const-to-idx-vec
+ index-of lookup-sym in-env? any every
+ compile-sym compile-if compile-begin
+ compile-arglist expand builtin->instruction
+ compile-app separate nconc get-defined-vars
+ compile-in compile compile-f delete-duplicates
+ map length> length= count filter append
+ lastcdr to-proper reverse reverse! list->vector
+ taboreach list-head list-tail assq memq assoc member
+ assv memv nreconc bq-process))
(define (filt1 pred lst)
(define (filt1- pred lst accum)
(if (null? lst) accum
- (if (pred (car lst))
- (filt1- pred (cdr lst) (cons (car lst) accum))
- (filt1- pred (cdr lst) accum))))
+ (if (pred (car lst))
+ (filt1- pred (cdr lst) (cons (car lst) accum))
+ (filt1- pred (cdr lst) accum))))
(filt1- pred lst ()))
(define (filto pred lst (accum ()))
(if (atom? lst) accum
(if (pred (car lst))
- (filto pred (cdr lst) (cons (car lst) accum))
- (filto pred (cdr lst) accum))))
+ (filto pred (cdr lst) (cons (car lst) accum))
+ (filto pred (cdr lst) accum))))
; (pairwise? p a b c d) == (and (p a b) (p b c) (p c d))
(define (pairwise? pred . args)
(or (null? args)
(let f ((a (car args)) (d (cdr args)))
- (or (null? d)
- (and (pred a (car d)) (f (car d) (cdr d)))))))
+ (or (null? d)
+ (and (pred a (car d)) (f (car d) (cdr d)))))))
--- a/test/unittest.lsp
+++ b/test/unittest.lsp
@@ -1,8 +1,8 @@
; -*- scheme -*-
(define-macro (assert-fail expr . what)
`(assert (trycatch (begin ,expr #f)
- (lambda (e) ,(if (null? what) #t
- `(eq? (car e) ',(car what)))))))
+ (lambda (e) ,(if (null? what) #t
+ `(eq? (car e) ',(car what)))))))
(define (every-int n)
(list (fixnum n) (int8 n) (uint8 n) (int16 n) (uint16 n) (int32 n) (uint32 n)
@@ -14,7 +14,7 @@
(define (each f l)
(if (atom? l) ()
(begin (f (car l))
- (each f (cdr l)))))
+ (each f (cdr l)))))
(define (each^2 f l m)
(each (lambda (o) (each (lambda (p) (f o p)) m)) l))
@@ -71,9 +71,9 @@
(assert (not (equal? #int64(0x8000000000000000) #uint64(0x8000000000000000))))
(assert (equal? (+ #int64(0x4000000000000000) #int64(0x4000000000000000))
- #uint64(0x8000000000000000)))
+ #uint64(0x8000000000000000)))
(assert (equal? (* 2 #int64(0x4000000000000000))
- #uint64(0x8000000000000000)))
+ #uint64(0x8000000000000000)))
(assert (equal? (uint64 (double -123)) #uint64(0xffffffffffffff85)))
@@ -169,9 +169,9 @@
(assert (= (apply + (iota 100000)) 4999950000))
(define ones (map (lambda (x) 1) (iota 80000)))
(assert (= (eval `(if (< 2 1)
- (+ ,@ones)
- (+ ,@(cdr ones))))
- 79999))
+ (+ ,@ones)
+ (+ ,@(cdr ones))))
+ 79999))
(define MAX_ARGS 255)
@@ -183,10 +183,10 @@
(define as (apply list* (map-int (lambda (x) (gensym)) (+ MAX_ARGS 100))))
(define ff (compile `(lambda ,as (set! ,(car (last-pair as)) 42)
- ,(car (last-pair as)))))
+ ,(car (last-pair as)))))
(assert (equal? (apply ff (iota (+ MAX_ARGS 100))) 42))
(define ff (compile `(lambda ,as (set! ,(car (last-pair as)) 42)
- (lambda () ,(car (last-pair as))))))
+ (lambda () ,(car (last-pair as))))))
(assert (equal? ((apply ff (iota (+ MAX_ARGS 100)))) 42))
(define as (map-int (lambda (x) (gensym)) 1000))
@@ -214,9 +214,9 @@
(assert (not (keyword? 'kw)))
(assert (not (keyword? ':)))
(assert (equal? ((lambda (x (a 2) (b: a) . r) (list x a b r)) 1 0 8 4 5)
- '(1 0 0 (8 4 5))))
+ '(1 0 0 (8 4 5))))
(assert (equal? ((lambda (x (a 2) (b: a) . r) (list x a b r)) 0 b: 3 1)
- '(0 2 3 (1))))
+ '(0 2 3 (1))))
(define (keys4 (a: 8) (b: 3) (c: 7) (d: 6)) (list a b c d))
(assert (equal? (keys4 a: 10) '(10 3 7 6)))
(assert (equal? (keys4 b: 10) '(8 10 7 6)))
@@ -255,75 +255,75 @@
(load "color.lsp")
(assert (equal? (color-pairs (generate-5x5-pairs) '(a b c d e))
- '((23 . a) (9 . a) (22 . b) (17 . d) (14 . d) (8 . b) (21 . e)
- (19 . b) (16 . c) (13 . c) (11 . b) (7 . e) (24 . c) (20 . d)
- (18 . e) (15 . a) (12 . a) (10 . e) (6 . d) (5 . c) (4 . e)
- (3 . d) (2 . c) (0 . b) (1 . a))))
+ '((23 . a) (9 . a) (22 . b) (17 . d) (14 . d) (8 . b) (21 . e)
+ (19 . b) (16 . c) (13 . c) (11 . b) (7 . e) (24 . c) (20 . d)
+ (18 . e) (15 . a) (12 . a) (10 . e) (6 . d) (5 . c) (4 . e)
+ (3 . d) (2 . c) (0 . b) (1 . a))))
; hashing strange things
(assert (equal?
- (hash '#0=(1 1 #0# . #0#))
- (hash '#1=(1 1 #1# 1 1 #1# . #1#))))
+ (hash '#0=(1 1 #0# . #0#))
+ (hash '#1=(1 1 #1# 1 1 #1# . #1#))))
(assert (not (equal?
- (hash '#0=(1 1 #0# . #0#))
- (hash '#1=(1 2 #1# 1 1 #1# . #1#)))))
+ (hash '#0=(1 1 #0# . #0#))
+ (hash '#1=(1 2 #1# 1 1 #1# . #1#)))))
(assert (equal?
- (hash '#0=((1 . #0#) . #0#))
- (hash '#1=((1 . #1#) (1 . #1#) . #1#))))
+ (hash '#0=((1 . #0#) . #0#))
+ (hash '#1=((1 . #1#) (1 . #1#) . #1#))))
(assert (not (equal?
- (hash '#0=((1 . #0#) . #0#))
- (hash '#1=((2 . #1#) (1 . #1#) . #1#)))))
+ (hash '#0=((1 . #0#) . #0#))
+ (hash '#1=((2 . #1#) (1 . #1#) . #1#)))))
(assert (not (equal?
- (hash '#0=((1 . #0#) . #0#))
- (hash '#1=((1 . #1#) (2 . #1#) . #1#)))))
+ (hash '#0=((1 . #0#) . #0#))
+ (hash '#1=((1 . #1#) (2 . #1#) . #1#)))))
(assert (equal?
- (hash '(#0=(#0#) 0))
- (hash '(#1=(((((#1#))))) 0))))
+ (hash '(#0=(#0#) 0))
+ (hash '(#1=(((((#1#))))) 0))))
(assert (not (equal?
- (hash '(#0=(#0#) 0))
- (hash '(#1=(((((#1#))))) 1)))))
+ (hash '(#0=(#0#) 0))
+ (hash '(#1=(((((#1#))))) 1)))))
(assert (equal?
- (hash #0=#(1 #(2 #(#0#)) 3))
- (hash #1=#(1 #(2 #(#(1 #(2 #(#1#)) 3))) 3))))
+ (hash #0=#(1 #(2 #(#0#)) 3))
+ (hash #1=#(1 #(2 #(#(1 #(2 #(#1#)) 3))) 3))))
(assert (not (equal?
- (hash #0=#(1 #(2 #(#0#)) 3))
- (hash #1=#(1 #(2 #(#(5 #(2 #(#1#)) 3))) 3)))))
+ (hash #0=#(1 #(2 #(#0#)) 3))
+ (hash #1=#(1 #(2 #(#(5 #(2 #(#1#)) 3))) 3)))))
(assert (equal?
- (hash #0=#(1 #0# #(2 #(#0#)) 3))
- (hash #1=#(1 #1# #(2 #(#(1 #1# #(2 #(#1#)) 3))) 3))))
+ (hash #0=#(1 #0# #(2 #(#0#)) 3))
+ (hash #1=#(1 #1# #(2 #(#(1 #1# #(2 #(#1#)) 3))) 3))))
(assert (not (equal?
- (hash #0=#(1 #0# #(2 #(#0#)) 3))
- (hash #1=#(6 #1# #(2 #(#(1 #1# #(2 #(#1#)) 3))) 3)))))
+ (hash #0=#(1 #0# #(2 #(#0#)) 3))
+ (hash #1=#(6 #1# #(2 #(#(1 #1# #(2 #(#1#)) 3))) 3)))))
(assert (equal?
- (hash #(1 #(2 #(#(1 1 #(2 #(1)) 3))) 3))
- (hash #(1 #(2 #(#(1 1 #(2 #(1)) 3))) 3))))
+ (hash #(1 #(2 #(#(1 1 #(2 #(1)) 3))) 3))
+ (hash #(1 #(2 #(#(1 1 #(2 #(1)) 3))) 3))))
(assert (not (equal?
- (hash #(6 1 #(2 #(#(3 1 #(2 #(1)) 3))) 3))
- (hash #(6 1 #(2 #(#(1 1 #(2 #(1)) 3))) 3)))))
+ (hash #(6 1 #(2 #(#(3 1 #(2 #(1)) 3))) 3))
+ (hash #(6 1 #(2 #(#(1 1 #(2 #(1)) 3))) 3)))))
(assert (equal? (hash '#0=(1 . #0#))
- (hash '#1=(1 1 . #1#))))
+ (hash '#1=(1 1 . #1#))))
(assert (not (equal? (hash '#0=(1 1 . #0#))
- (hash '#1=(1 #0# . #1#)))))
+ (hash '#1=(1 #0# . #1#)))))
(assert (not (equal? (hash (iota 10))
- (hash (iota 20)))))
+ (hash (iota 20)))))
(assert (not (equal? (hash (iota 41))
- (hash (iota 42)))))
+ (hash (iota 42)))))
(if (top-level-bound? 'string->time)
(assert (let ((ts (time->string (time-now))))
--- a/test/wt.lsp
+++ b/test/wt.lsp
@@ -14,7 +14,7 @@
(if (< i 10000000)
(begin (set! i (+ i 1))
(loop))
- ()))))
+ ()))))
(loop)))
#|
--- a/time_posix.c
+++ b/time_posix.c
@@ -46,7 +46,7 @@
res = strptime(s, fmt, &tm);
if(res != nil){- /* Not set by strptime(); tells mktime() to determine
+ /* Not set by strptime(); tells mktime() to determine
* whether daylight saving time is in effect
*/
tm.tm_isdst = -1;