diff options
| -rw-r--r-- | csc/cps-test.csc | 238 | ||||
| -rw-r--r-- | csc/cps.csc | 224 | ||||
| -rw-r--r-- | csc/ir1.csc | 80 | ||||
| -rw-r--r-- | csc/ir2.csc | 161 | ||||
| -rw-r--r-- | csc/list-test.csc | 6 | ||||
| -rw-r--r-- | csc/list.csc | 10 | ||||
| -rw-r--r-- | csc/loop.csc | 3 | ||||
| -rw-r--r-- | csc/macros-test.csc | 29 | ||||
| -rw-r--r-- | csc/macros.csc | 37 |
9 files changed, 357 insertions, 431 deletions
diff --git a/csc/cps-test.csc b/csc/cps-test.csc index d51d10c..d3cfb6d 100644 --- a/csc/cps-test.csc +++ b/csc/cps-test.csc @@ -1,13 +1,10 @@ (import (scheme base) - (only (csc hash-map) - map->alist) (only (csc ir1) make-call make-constant make-define-syntax make-if make-lambda - make-lambda-case make-letrec make-lexical-ref make-lexical-set @@ -15,6 +12,8 @@ make-sequence) (only (csc ir2) ir2=? + make-apply + make-fix make-atom make-branch make-call-closure @@ -22,170 +21,143 @@ make-kargs make-klabel make-ktail - make-lambda-args make-update) - (only (csc loop) - loop - return) - (only (csc sort) sort) (only (csc testing) assert-equal test) (csc cps)) -(define (soup->alist s) - (sort (lambda (x y) (< (car x) (car y))) (map->alist s))) - - -(define (soup=? x y) - (and (= (length x) (length y)) - (loop for x* in x - for y* in y - unless (and (= (car x*) (car y*)) - (ir2=? (cdr x*) (cdr y*))) - return #f - finally (return #t)))) +(define (tail x) + (make-apply (make-lexical-ref 'tail #f) (list x))) (test atom-const - (assert-equal soup=? - (list - (cons 0 (make-klabel - (make-atom (make-constant 5) 1))) - (cons 1 (make-ktail))) - (soup->alist (ir1->ir2 (make-constant 5))))) + (assert-equal ir2=? + (make-apply (make-lexical-ref 'tail #f) (list (make-constant 5))) + (ir1->ir2 (make-constant 5) tail))) (test atom-lexical-ref - (assert-equal soup=? - (list - (cons 0 (make-klabel - (make-atom (make-lexical-ref 'var #f) 1))) - (cons 1 (make-ktail))) - (soup->alist (ir1->ir2 (make-lexical-ref 'var #f))))) + (assert-equal ir2=? + (make-apply (make-lexical-ref 'tail #f) (list (make-lexical-ref 'var #f))) + (ir1->ir2 (make-lexical-ref 'var #f) tail))) (test atom-library-ref - (assert-equal soup=? - (list - (cons 0 (make-klabel - (make-atom (make-library-ref 'var '(csc builtins)) 1))) - (cons 1 (make-ktail))) - (soup->alist (ir1->ir2 (make-library-ref 'var '(csc builtins)))))) + (assert-equal ir2=? + (make-apply (make-lexical-ref 'tail #f) + (list (make-library-ref 'var '(csc builtins)))) + (ir1->ir2 (make-library-ref 'var '(csc builtins)) tail))) (test lexical-set - (assert-equal soup=? - (list - (cons 0 (make-klabel - (make-atom (make-constant 5) 2))) - (cons 1 (make-ktail)) - (cons 2 (make-kargs (list (make-lexical-ref 'generated-symbol #f)) - (make-update (make-lexical-ref 'var #f) - (make-lexical-ref 'generated-symbol #f) 1)))) - (soup->alist (ir1->ir2 (make-lexical-set (make-lexical-ref 'var #f) (make-constant 5)))))) + (assert-equal ir2=? + (make-update (make-lexical-ref 'var #f) (make-constant 5) + (make-apply (make-lexical-ref 'tail #f) (list (make-constant #f)))) + (ir1->ir2 (make-lexical-set (make-lexical-ref 'var #f) (make-constant 5)) + tail))) (test no-op-define-syntax - (assert-equal soup=? - (list - (cons 0 (make-klabel (make-atom (make-constant #f) 1))) - (cons 1 (make-ktail))) - (soup->alist (ir1->ir2 (make-define-syntax 'name '(transformer)))))) + (assert-equal ir2=? + (make-apply (make-lexical-ref 'tail #f) (list (make-constant #f))) + (ir1->ir2 (make-define-syntax 'name '(transformer)) + tail))) (test branch - (assert-equal soup=? - (list - (cons 0 (make-klabel (make-atom (make-constant #t) 4))) - (cons 1 (make-ktail)) - (cons 2 (make-klabel (make-atom (make-constant 1) 1))) - (cons 3 (make-klabel (make-atom (make-constant 2) 1))) - (cons 4 (make-kargs (list (make-lexical-ref 'generated-symbol #f)) - (make-branch (make-lexical-ref 'generated-symbol #f) - 2 3)))) - (soup->alist (ir1->ir2 (make-if (make-constant #t) - (make-constant 1) - (make-constant 2)))))) + (assert-equal ir2=? + (make-fix + (list + (make-closure (make-lexical-ref 'generated-symbol #f) (list (make-lexical-ref 'generated-symbol #f)) #f + (make-apply (make-lexical-ref 'tail #f) (list (make-lexical-ref 'generated-symbol #f))))) + (make-branch (make-constant #t) + (make-apply (make-lexical-ref 'generated-symbol #f) (list (make-constant 1))) + (make-apply (make-lexical-ref 'generated-symbol #f) (list (make-constant 2))))) + (ir1->ir2 (make-if (make-constant #t) + (make-constant 1) + (make-constant 2)) + tail))) (test call-closure - (assert-equal soup=? - (list - (cons 0 (make-klabel (make-atom (make-lexical-ref 'f #f) 4))) - (cons 1 (make-ktail)) - (cons 2 (make-kargs (list (make-lexical-ref 'generated-symbol #f)) - (make-call-closure (make-lexical-ref 'generated-symbol #f) - (list (make-lexical-ref 'generated-symbol #f) - (make-lexical-ref 'generated-symbol #f)) - 1))) - (cons 3 (make-kargs (list (make-lexical-ref 'generated-symbol #f)) - (make-atom (make-constant 2) 2))) - (cons 4 (make-kargs (list (make-lexical-ref 'generated-symbol #f)) - (make-atom (make-constant 1) 3)))) - (soup->alist (ir1->ir2 (make-call (make-lexical-ref 'f #f) (list (make-constant 1) (make-constant 2))))))) + (assert-equal ir2=? + (make-fix + (list + (make-closure (make-lexical-ref 'generated-symbol #f) (list (make-lexical-ref 'generated-symbol #f)) #f + (make-apply (make-lexical-ref 'tail #f) (list (make-lexical-ref 'generated-symbol #f))))) + (make-apply (make-lexical-ref 'f #f) (list (make-lexical-ref 'generated-symbol #f) + (make-constant 1) + (make-constant 2)))) + (ir1->ir2 (make-call (make-lexical-ref 'f #f) (list (make-constant 1) (make-constant 2))) + tail))) (test sequence - (assert-equal soup=? - (list - (cons 0 (make-klabel (make-atom (make-constant 1) 2))) - (cons 1 (make-ktail)) - (cons 2 (make-klabel (make-atom (make-constant 2) 1)))) - (soup->alist (ir1->ir2 (make-sequence (make-constant 1) - (make-constant 2)))))) + (assert-equal ir2=? + (make-update (make-lexical-ref 'a #f) (make-constant 5) + (make-update (make-lexical-ref 'b #f) (make-constant 6) + (make-apply (make-lexical-ref 'tail #f) (list (make-constant #f))))) + (ir1->ir2 (make-sequence (make-lexical-set (make-lexical-ref 'a #f) (make-constant 5)) + (make-lexical-set (make-lexical-ref 'b #f) (make-constant 6))) + tail))) (test closure - (assert-equal soup=? - (list - (cons 0 (make-klabel - (make-closure - (list (make-lambda-args 2 #t 3)) - 1))) - (cons 1 (make-ktail)) - (cons 2 (make-ktail)) - (cons 3 (make-kargs (list (make-lexical-ref 'a #f) - (make-lexical-ref 'b #f) - (make-lexical-ref 'c #f)) - (make-atom (make-constant 5) 2)))) - (soup->alist (ir1->ir2 (make-lambda - (make-lambda-case - '(a b) - 'c - '(#f #f #f) - (make-constant 5) - #f)))))) + (assert-equal ir2=? + (make-fix + (list + (make-closure (make-lexical-ref 'generated-symbol #f) + (list (make-lexical-ref 'generated-symbol #f) + (make-lexical-ref 'a #f) + (make-lexical-ref 'b #f)) + (make-lexical-ref 'c #f) + (make-apply (make-lexical-ref 'generated-symbol #f) (list (make-constant 5))))) + (make-apply (make-lexical-ref 'tail #f) (list (make-lexical-ref 'generated-symbol #f)))) + (ir1->ir2 (make-lambda + (list (make-lexical-ref 'a #f) (make-lexical-ref 'b #f)) + (make-lexical-ref 'c #f) + (make-constant 5)) + tail))) -(test letrec-to-lambda - (assert-equal soup=? - (list - ; God help you when it's time to debug this test. - (cons 0 (make-klabel - (make-closure +(test letrec-in-order + (assert-equal ir2=? + (make-fix + (list + (make-closure (make-lexical-ref 'f #f) (list (make-lexical-ref 'generated-symbol #f) + (make-lexical-ref 'x #f)) #f + (make-apply (make-lexical-ref 'generated-symbol #f) (list (make-constant 5))))) + (make-fix + (list + (make-closure (make-lexical-ref 'generated-symbol #f) (list (make-lexical-ref 'generated-symbol #f)) #f + (make-apply (make-lexical-ref 'tail #f) (list (make-lexical-ref 'generated-symbol #f))))) + (make-fix + (list + (make-closure (make-lexical-ref 'generated-symbol #f) (list (make-lexical-ref 'generated-symbol #f) + (make-lexical-ref 'a #f)) #f + (make-fix + (list + (make-closure (make-lexical-ref 'generated-symbol #f) (list (make-lexical-ref 'generated-symbol #f)) #f + (make-apply (make-lexical-ref 'generated-symbol #f) (list (make-lexical-ref 'generated-symbol #f))))) + (make-fix (list - (make-lambda-args 1 #f 7)) - 3))) - (cons 1 (make-ktail)) - (cons 2 (make-kargs (list (make-lexical-ref 'generated-symbol #f)) - (make-call-closure - (make-lexical-ref 'generated-symbol #f) - (list (make-lexical-ref 'generated-symbol #f)) - 1))) - (cons 3 (make-kargs (list (make-lexical-ref 'generated-symbol #f)) - (make-atom (make-constant #f) 2))) - (cons 4 (make-ktail)) - (cons 5 (make-klabel - (make-atom (make-constant 2) 4))) - (cons 6 (make-kargs (list (make-lexical-ref 'generated-symbol #f)) - (make-update (make-lexical-ref 'a #f) (make-lexical-ref 'generated-symbol #f) 5))) - (cons 7 (make-kargs (list (make-lexical-ref 'a #f)) - (make-atom (make-constant 1) 6)))) - (soup->alist (ir1->ir2 (make-letrec - #t - '(a) - '(#f) - (list (make-constant 1)) - (make-constant 2)))))) + (make-closure (make-lexical-ref 'generated-symbol #f) (list (make-lexical-ref 'generated-symbol #f) + (make-lexical-ref 'b #f)) #f + (make-apply (make-lexical-ref 'generated-symbol #f) (list (make-constant 10))))) + (make-apply (make-lexical-ref 'generated-symbol #f) + (list (make-lexical-ref 'generated-symbol #f) + (make-constant 2))))))) + (make-apply (make-lexical-ref 'generated-symbol #f) + (list (make-lexical-ref 'generated-symbol #f) + (make-constant 1)))))) + (ir1->ir2 (make-letrec + #t + '(a f b) + '(#f #f #f) + (list (make-constant 1) + (make-lambda (list (make-lexical-ref 'x #f)) #f (make-constant 5)) + (make-constant 2)) + (make-constant 10)) + tail))) diff --git a/csc/cps.csc b/csc/cps.csc index 0c85707..cf4a26d 100644 --- a/csc/cps.csc +++ b/csc/cps.csc @@ -16,15 +16,13 @@ if-consequent if-test if? + lambda-arguments lambda-body - lambda-case-alternate - lambda-case-arguments - lambda-case-body - lambda-case-gensyms - lambda-case-rest + lambda-rest lambda? letrec-expression letrec-gensyms + letrec-in-order? letrec-names letrec-values letrec? @@ -39,7 +37,6 @@ make-call make-constant make-lambda - make-lambda-case make-lexical-ref make-lexical-set make-sequence @@ -47,14 +44,15 @@ sequence-tail sequence?) (only (csc ir2) + make-apply make-atom make-branch make-call-closure make-closure + make-fix make-kargs make-klabel make-ktail - make-lambda-args make-update) (only (csc loop) loop @@ -67,116 +65,132 @@ (make-lexical-ref 'generated-symbol (gensym))) - (define (to-cps expr continuation add-continuation) + (define (collect-functions-and-variables expr) + (loop for name in (letrec-names expr) + for gensym in (letrec-gensyms expr) + for value in (letrec-values expr) + if (lambda? value) + collect (let ((continuation (new-ref))) + (make-closure + (make-lexical-ref name gensym) + (cons continuation (lambda-arguments value)) + (lambda-rest value) + (ir1->ir2 + (lambda-body value) + (lambda (z) + (make-apply continuation (list z)))))) + into functions + else + collect (make-lexical-ref name gensym) into variable-names + and collect value into variable-values + finally (return (values functions variable-names variable-values)))) + + + (define (ir1->ir2 expr continuation) (cond ((or (constant? expr) (lexical-ref? expr) (library-ref? expr)) - (make-atom expr continuation)) + (continuation expr)) ((lexical-set? expr) - (let ((ref (new-ref))) - (to-cps - (lexical-set-expression expr) - (add-continuation - (make-kargs (list ref) - (make-update (lexical-set-ref expr) ref continuation))) - add-continuation))) + (ir1->ir2 + (lexical-set-expression expr) + (lambda (val) + (make-update (lexical-set-ref expr) val (continuation (make-constant #f)))))) ((library-define? expr) - (let ((ref (new-ref))) - (to-cps - (library-define-expression expr) - (add-continuation - (make-kargs (list ref) - (make-update (library-define-ref expr) ref continuation))) - add-continuation))) + (ir1->ir2 + (library-define-expression expr) + (lambda (val) + (make-update (library-define-ref expr) val (continuation (make-constant #f)))))) ((define-syntax? expr) ; no-op - (make-atom (make-constant #f) continuation)) + (continuation (make-constant #f))) ((if? expr) - (let* ((true-id (add-continuation - (make-klabel - (to-cps (if-consequent expr) continuation add-continuation)))) - (false-id (add-continuation - (make-klabel - (to-cps (if-alternate expr) continuation add-continuation)))) - (test-ref (new-ref)) - (branch-id (add-continuation - (make-kargs (list test-ref) - (make-branch test-ref true-id false-id))))) - (to-cps (if-test expr) branch-id add-continuation))) + (ir1->ir2 + (if-test expr) + (lambda (val) + (define continuation-ref (new-ref)) + (define result-ref (new-ref)) + (make-fix + (list (make-closure continuation-ref (list result-ref) #f + (continuation result-ref))) + (make-branch val + (ir1->ir2 + (if-consequent expr) + (lambda (result) + (make-apply continuation-ref (list result)))) + (ir1->ir2 + (if-alternate expr) + (lambda (result) + (make-apply continuation-ref (list result))))))))) ((call? expr) - ; Technically the order of evaluation is unspecified. We evaluate - ; expressions left to right. - (loop with terms = (cons (call-procedure expr) (call-arguments expr)) - with temps = (map (lambda (x) (new-ref)) terms) - with expr = (make-call-closure (car temps) (cdr temps) continuation) - for term in (reverse terms) - for temp in (reverse temps) - do (set! expr (to-cps term - (add-continuation - (make-kargs (list temp) expr)) - add-continuation)) - finally (return expr))) + (let ((return-address (new-ref)) + (result (new-ref))) + (make-fix + (list (make-closure return-address (list result) #f (continuation result))) + (ir1->ir2 + (call-procedure expr) + (lambda (f) + ; Technically the order of evaluation is unspecified. + ; We evaluate expressions left to right. + ; + ; I would use the loop macro, but it mutates the loop + ; variables which plays badly with building a lambda. + (let loop ((args (reverse (call-arguments expr))) + (exprs (lambda (vals) + (make-apply f (cons return-address (reverse vals)))))) + (if (null? args) + (exprs '()) + (loop (cdr args) + (lambda (vals) + (ir1->ir2 + (car args) + (lambda (val) + (exprs (cons val vals))))))))))))) ((sequence? expr) - (to-cps + (ir1->ir2 (sequence-head expr) - (add-continuation - (make-klabel - (to-cps (sequence-tail expr) continuation add-continuation))) - add-continuation)) + (lambda (x) + (ir1->ir2 + (sequence-tail expr) + continuation)))) ((lambda? expr) - (make-closure - (loop with tail = (add-continuation (make-ktail)) - for lambda-case = (lambda-body expr) then (lambda-case-alternate lambda-case) - while lambda-case - collect (let ((args (lambda-case-arguments lambda-case)) - (rest (lambda-case-rest lambda-case))) - (make-lambda-args - (length args) - (not (not rest)) - (add-continuation - (make-kargs (map make-lexical-ref - (append args (list rest)) - (lambda-case-gensyms lambda-case)) - (to-cps (lambda-case-body lambda-case) tail add-continuation)))))) - continuation)) + (let ((f (new-ref)) + (k (new-ref))) + (make-fix + (list + (make-closure f (cons k (lambda-arguments expr)) (lambda-rest expr) + (ir1->ir2 + (lambda-body expr) + (lambda (ret) + (make-apply k (list ret)))))) + (continuation f)))) ((letrec? expr) - ; We re-write a letrec into a corresponding lambda form. - (let ((names (letrec-names expr)) - (gensyms (letrec-gensyms expr))) - (to-cps - (make-call - (make-lambda - (make-lambda-case - names - #f - gensyms - (make-sequence - (loop for name in names - for gensym in gensyms - for value in (letrec-values expr) - for set = (make-lexical-set (make-lexical-ref name gensym) value) - for body = set then (make-sequence body set) - finally (return body)) + (let-values (((functions variable-names variable-values) (collect-functions-and-variables expr))) + (make-fix functions + (ir1->ir2 + ; We re-write a letrec into a corresponding lambda form. + (if (letrec-in-order? expr) + (loop for name in (reverse variable-names) + for value in (reverse variable-values) + for expr = (make-call + (make-lambda + (list name) + #f + (letrec-expression expr)) + (list value)) + then (make-call + (make-lambda + (list name) + #f + expr) + (list value)) + finally (return expr)) + (make-call + (make-lambda + variable-names + #f (letrec-expression expr)) - #f)) - (map (lambda (x) (make-constant #f)) names)) - continuation - add-continuation))) - (else (error "unexpected type in to-cps" expr)))) - - - ; Returns a map from integers to CPS continuations. - ; By convention the continuation at key 0 is the entrypoint. - (define (ir1->ir2 program) - (define current-continuation-id 0) - (define soup (make-map (lambda (x) x) <)) - (define (add-continuation continuation) - (set! current-continuation-id (+ 1 current-continuation-id)) - (set! soup (insert soup - current-continuation-id - continuation)) - current-continuation-id) - (define ktail (add-continuation (make-ktail))) - (define entrypoint (to-cps program ktail add-continuation)) - (insert soup 0 (make-klabel entrypoint))))) + variable-values)) + continuation)))) + (else (error "unexpected type in ir1->ir2" expr)))))) diff --git a/csc/ir1.csc b/csc/ir1.csc index 26b885b..d82cf12 100644 --- a/csc/ir1.csc +++ b/csc/ir1.csc @@ -14,13 +14,9 @@ if? import? ir1=? + lambda-arguments lambda-body - lambda-case-alternate - lambda-case-arguments - lambda-case-body - lambda-case-gensyms - lambda-case-rest - lambda-case? + lambda-rest lambda? letrec-expression letrec-gensyms @@ -45,7 +41,6 @@ make-define-syntax make-if make-lambda - make-lambda-case make-letrec make-lexical-ref make-lexical-set @@ -56,6 +51,8 @@ sequence-tail sequence?) (import (scheme base) + (only (csc list) + all) (only (csc loop) loop return)) (begin ; This library defines the intermediate representation IR1. An expression @@ -151,37 +148,16 @@ ; <lambda> body - ; A closure. body is an expression of type <lambda-case>. + ; A closure. Arguments is a list of lexical-refs. + ; Rest is a lexical ref or #f if the lambda doesn't take a rest parameter. (define-record-type <lambda> - (make-lambda body) + (make-lambda arguments rest body) lambda? + (arguments lambda-arguments) + (rest lambda-rest) (body lambda-body)) - ; <lambda-case> arguments rest gensyms body alternate - ; One clause of a case-lambda. A lambda expression in Scheme is treated as - ; a case-lambda with one clause. - ; - ; arguments is a list of the procedures arguments, as symbols. rest is the - ; name of the rest argument, or #f. gensyms is a list of gensyms - ; corresponding to all arguments: first all of the normal arguments, then - ; the rest argument if any. - ; - ; body is the name of the clause (??). If the procedure is called with an - ; appropriate number of arguments, body is evaluated in tail position. - ; Otherwise if there is an alternate, it should be a <lambda-case> - ; expression, representing the next clause to try. If alternate is #f, an - ; error is signaled. - (define-record-type <lambda-case> - (make-lambda-case arguments rest gensyms body alternate) - lambda-case? - (arguments lambda-case-arguments) - (rest lambda-case-rest) - (gensyms lambda-case-gensyms) - (body lambda-case-body) - (alternate lambda-case-alternate)) - - ; <letrec> in-order? names gensyms values expression ; Lexical binding, like Scheme's letrec, or letrec* if in-order? is true. ; names are the original binding names, gensyms are gensyms corresponding @@ -233,25 +209,27 @@ (ir1=? (sequence-head x) (sequence-head y)) (ir1=? (sequence-tail x) (sequence-tail y)))) ((and (lambda? x) (lambda? y)) - (ir1=? (lambda-body x) (lambda-body y))) - ((and (lambda-case? x) (lambda-case? y)) - (and - (equal? (lambda-case-arguments x) (lambda-case-arguments y)) - (eq? (lambda-case-rest x) (lambda-case-rest y)) - (ir1=? (lambda-case-body x) (lambda-case-body y)) - (or (and (null? (lambda-case-alternate x)) - (null? (lambda-case-alternate y))) - (ir1=? (lambda-case-alternate x) (lambda-case-alternate y))))) + (let ((x-args (lambda-arguments x)) + (x-rest (lambda-rest x)) + (y-args (lambda-arguments y)) + (y-rest (lambda-rest y))) + (and (= (length x-args) (length y-args)) + (all ir1=? x-args y-args) + (or (and (not x-rest) (not y-rest)) + (ir1=? x-rest y-rest)) + (ir1=? (lambda-body x) (lambda-body y))))) ((and (letrec? x) (letrec? y)) - (and - (boolean=? (letrec-in-order? x) (letrec-in-order? y)) - (map symbol=? (letrec-names x) (letrec-names y)) - (= (length (letrec-values x)) (length (letrec-values y))) - (loop for x-val in (letrec-values x) - for y-val in (letrec-values y) - unless (ir1=? x-val y-val) return #f - finally (return #t)) - (ir1=? (letrec-expression x) (letrec-expression y)))) + (let ((x-names (letrec-names x)) + (x-values (letrec-values x)) + (y-names (letrec-names y)) + (y-values (letrec-values y))) + (and + (boolean=? (letrec-in-order? x) (letrec-in-order? y)) + (= (length x-names) (length y-names)) + (all symbol=? x-names y-names) + (= (length x-values) (length y-values)) + (all ir1=? x-values y-values) + (ir1=? (letrec-expression x) (letrec-expression y))))) (else #f))) diff --git a/csc/ir2.csc b/csc/ir2.csc index 1872b65..9b9397f 100644 --- a/csc/ir2.csc +++ b/csc/ir2.csc @@ -1,5 +1,8 @@ (define-library (csc ir2) (export + apply-arguments + apply-procedure + apply? atom-continuation atom-expression atom? @@ -10,9 +13,14 @@ call-closure-args call-closure-closure call-closure? - closure-cases - closure-continuation + closure-arguments + closure-body + closure-name + closure-rest closure? + fix-body + fix-functions + fix? ir2=? kargs-expression kargs-refs @@ -20,18 +28,15 @@ klabel-expression klabel? ktail? - lambda-args-kargs - lambda-args-nargs - lambda-args-rest - lambda-args? + make-apply make-atom make-branch make-call-closure make-closure + make-fix make-kargs make-klabel make-ktail - make-lambda-args make-update update-atom update-continuation @@ -91,23 +96,6 @@ ; but constrained not to have any subexpressions except atoms. ; And they take a continuation. - ; CPS continuations - ; There are a few continuations. - ; Continuations are identified by an integer ID into the - ; continuation map. - ; Guile calls this map the "continuation soup". - - - ; CPS expressions. - - - ; An atom consists of an atom and a continuation. - (define-record-type <atom> - (make-atom expression continuation) - atom? - (expression atom-expression) - (continuation atom-continuation)) - ; Modifies a library or lexically bound variable to the given atom. (define-record-type <update> @@ -118,7 +106,7 @@ (continuation update-continuation)) - ; Evaluates the given atom. + ; Branches depending on the given atom. ; If it is true, continue with continuation true. ; If false, continue with continuation false. (define-record-type <branch> @@ -129,99 +117,72 @@ (false branch-false)) - ; Calls the given closure. Closure is an atom, and args is a list of atoms. - (define-record-type <call-closure> - (make-call-closure closure args continuation) - call-closure? - (closure call-closure-closure) - (args call-closure-args) - (continuation call-closure-continuation)) - + ; Applies a procedure to a list of arguments. Apply does not take a + ; continuation. Instead the continuation will be passed as the first + ; argument to the function. + (define-record-type <apply> + (make-apply procedure arguments) + apply? + (procedure apply-procedure) + (arguments apply-arguments)) - ; One branch of a case-lambda. nargs encodes the number of required - ; arguments, and rest is a boolean indicating whether the function takes a - ; rest parameter. kargs is a continuation ID pointing to a - ; kargs continuation. - (define-record-type <lambda-args> - (make-lambda-args nargs rest kargs) - lambda-args? - (nargs lambda-args-nargs) - (rest lambda-args-rest) - (kargs lambda-args-kargs)) - - ; A lambda expression. + ; A procedure. All closures are allocated in a fix expression. A closure + ; does not take a continuation. Instead, the procedure will accept the + ; continuation as an argument. (define-record-type <closure> - (make-closure cases continuation) + (make-closure name arguments rest body) closure? - (cases closure-cases) - (continuation closure-continuation)) - - - ; CPS continuations. - - - ; The tail continuation. - (define-record-type <ktail> - (make-ktail) - ktail?) + (name closure-name) + (arguments closure-arguments) + (rest closure-rest) + (body closure-body)) - ; Binds the incoming values to the given lexically-bound variables - ; and then evaluates expression. - (define-record-type <kargs> - (make-kargs refs expression) - kargs? - (refs kargs-refs) - (expression kargs-expression)) + ; Defines a list of mutually recursive procedures. + ; Functions is a list of closures, and body is an expression. + (define-record-type <fix> + (make-fix functions body) + fix? + (functions fix-functions) + (body fix-body)) - ; Ignores any incoming values and evaluates the given expression. - (define-record-type <klabel> - (make-klabel expression) - klabel? - (expression klabel-expression)) + (define (closure=? x y) + (let ((x-args (closure-arguments x)) + (x-rest (closure-rest x)) + (y-args (closure-arguments y)) + (y-rest (closure-rest y))) + (and (ir1=? (closure-name x) (closure-name y)) + (= (length x-args) (length y-args)) + (all ir1=? x-args y-args) + (or (and (not x-rest) (not y-rest)) + (and x-rest y-rest (ir1=? x-rest y-rest))) + (ir2=? (closure-body x) (closure-body y))))) (define (ir2=?-sametype x y) (cond - ((and (atom? x) (atom? y)) - (and (ir1=? (atom-expression x) (atom-expression y)) - (= (atom-continuation x) (atom-continuation y)))) ((and (update? x) (update? y)) (and (ir1=? (update-ref x) (update-ref y)) (ir1=? (update-atom x) (update-atom y)) - (= (update-continuation x) (update-continuation y)))) + (ir2=? (update-continuation x) (update-continuation y)))) ((and (branch? x) (branch? y)) (and (ir1=? (branch-atom x) (branch-atom y)) - (= (branch-true x) (branch-true y)) - (= (branch-false x) (branch-false y)))) - ((and (call-closure? x) (call-closure? y)) - (let ((x-args (call-closure-args x)) - (y-args (call-closure-args y))) - (and (ir1=? (call-closure-closure x) (call-closure-closure y)) + (ir2=? (branch-true x) (branch-true y)) + (ir2=? (branch-false x) (branch-false y)))) + ((and (apply? x) (apply? y)) + (let ((x-args (apply-arguments x)) + (y-args (apply-arguments y))) + (and (ir1=? (apply-procedure x) (apply-procedure y)) (= (length x-args) (length y-args)) - (all (lambda (x) x) (map ir1=? x-args y-args)) - (= (call-closure-continuation x) (call-closure-continuation y))))) - ((and (lambda-args? x) (lambda-args? y)) - (and (= (lambda-args-nargs x) (lambda-args-nargs y)) - (boolean=? (lambda-args-rest x) (lambda-args-rest y)) - (= (lambda-args-kargs x) (lambda-args-kargs y)))) - ((and (closure? x) (closure? y)) - (let ((x-cases (closure-cases x)) - (y-cases (closure-cases y))) - (and (= (length x-cases) (length y-cases)) - (all (lambda (x) x) (map ir2=? x-cases y-cases)) - (= (closure-continuation x) (closure-continuation y))))) - ((and (ktail? x) (ktail? y)) #t) - ((and (kargs? x) (kargs? y)) - (let ((x-refs (kargs-refs x)) - (y-refs (kargs-refs y))) - (and (= (length x-refs) (length y-refs)) - (all (lambda (x) x) (map ir1=? x-refs y-refs)) - (ir2=? (kargs-expression x) (kargs-expression y))))) - ((and (klabel? x) (klabel? y)) - (ir2=? (klabel-expression x) (klabel-expression y))) + (all ir1=? x-args y-args)))) + ((and (fix? x) (fix? y)) + (let ((x-funs (fix-functions x)) + (y-funs (fix-functions y))) + (and (= (length x-funs) (length y-funs)) + (all closure=? x-funs y-funs) + (ir2=? (fix-body x) (fix-body y))))) (else #f))) diff --git a/csc/list-test.csc b/csc/list-test.csc index faa90b6..e16feee 100644 --- a/csc/list-test.csc +++ b/csc/list-test.csc @@ -113,3 +113,9 @@ (assert-equal #f (all (lambda (x) (= 0 (remainder x 2))) '(2 13 8)))) + + +(test all-equal + (assert-equal + #t + (all = '(1 2 3) '(1 2 3)))) diff --git a/csc/list.csc b/csc/list.csc index cc64168..b1c2298 100644 --- a/csc/list.csc +++ b/csc/list.csc @@ -74,8 +74,12 @@ finally (return (values xs ys)))) - (define (all pred l) - (loop for x in l - unless (pred x) + (define (all pred . ls) + (loop for ls = ls then (map cdr ls) + while (loop for l in ls + if (null? l) + return #f + finally (return #t)) + unless (apply pred (map car ls)) return #f finally (return #t))))) diff --git a/csc/loop.csc b/csc/loop.csc index a323495..dbd6200 100644 --- a/csc/loop.csc +++ b/csc/loop.csc @@ -88,12 +88,13 @@ clause* ...))) ((loop-aux "variable-clause-collector" ((body ...) fin) for x = init then subseq clause* ...) (let ((first #t) + (init-value (lambda () init)) ; put the body of init outside the scope of x. (x #f)) (loop-aux "variable-clause-collector" ((body ... (if first (begin (set! first #f) - (set! x init)) + (set! x (init-value))) (set! x subseq))) fin) clause* ...))) diff --git a/csc/macros-test.csc b/csc/macros-test.csc index fd9d1ae..db78324 100644 --- a/csc/macros-test.csc +++ b/csc/macros-test.csc @@ -8,7 +8,6 @@ lexical-set-expression lexical-set? make-constant - make-lambda-case make-letrec make-lexical-ref make-library-ref @@ -177,28 +176,30 @@ builtins-environment))) -(test builtin-case-lambda-cases +(test builtin-lambda-rest (assert-equal ir1=? - (make-lambda-case '(x y z) #f #f (make-sequence (make-constant #f) (make-constant 5)) - (make-lambda-case '(a b c) 'd #f (make-sequence (make-constant #f) (make-constant 6)) '())) + (make-lambda (list + (make-lexical-ref 'a #f) + (make-lexical-ref 'b #f) + (make-lexical-ref 'c #f)) + (make-lexical-ref 'd #f) + (make-sequence (make-constant #f) (make-constant 5))) (expand - '(case-lambda - ((x y z) (quote 5)) - ((a b c . d) (quote 6))) + '(lambda + (a b c . d) (quote 5)) builtins-environment))) (test builtin-case-lambda-defines (assert-equal ir1=? - (make-lambda-case '(x) #f #f + (make-lambda (list (make-lexical-ref 'x #f)) #f (make-letrec #t '(a b) #f (list (make-constant 6) (make-lexical-ref 'a #f)) - (make-sequence (make-constant #f) (make-constant 7))) '()) + (make-sequence (make-constant #f) (make-constant 7)))) (expand - '(case-lambda - ((x) - (builtin-define a (quote 6)) - (builtin-define b a) - (quote 7))) + '(lambda (x) + (builtin-define a (quote 6)) + (builtin-define b a) + (quote 7)) builtins-environment))) diff --git a/csc/macros.csc b/csc/macros.csc index ff5b63a..6364e19 100644 --- a/csc/macros.csc +++ b/csc/macros.csc @@ -34,7 +34,6 @@ make-call make-constant make-lambda - make-lambda-case make-letrec make-lexical-ref make-library-define @@ -698,31 +697,21 @@ (make-letrec #t (reverse names) (reverse gensyms) (reverse expressions) (expand-lambda-body-rest body))))))))) - (define (case-lambda-helper form) - (syntax-case form - ('() '()) - (((formals . body) . clauses) - (let-values (((args rest) (split-args-rest formals))) - (make-lambda-case - args - rest - (map - (lambda (x) (gensym)) - (if rest - (cons rest args) - args)) - (expand-lambda-body body) - (case-lambda-helper clauses)))) - (_ (raise-syntax-error "unexpected form in case-lambda-helper" form)))) - - - (define builtin-case-lambda + (define builtin-lambda (make-macro-transformer (lambda (x) (syntax-case x - ((_ clause . clauses) - (case-lambda-helper (with-wrap (cons clause clauses) x))) - (_ (raise-syntax-error "unexpected form in case-lambda" x)))))) + ((_ formals . body) + (let-values (((args rest) (split-args-rest formals))) + (make-lambda + (map (lambda (name) + (make-lexical-ref name (gensym))) + args) + (if rest + (make-lexical-ref rest (gensym)) + #f) + (expand-lambda-body body)))) + (_ (raise-syntax-error "unexpected form in lambda" x)))))) (define builtin-define @@ -746,7 +735,7 @@ (cons '... (make-library-ref '... '(scheme base))) (cons 'builtin-let-syntax builtin-let-syntax) (cons 'quote builtin-quote) - (cons 'case-lambda builtin-case-lambda) + (cons 'lambda builtin-lambda) (cons 'builtin-define builtin-define))) 'main)) |