diff options
Diffstat (limited to 'csc')
| -rw-r--r-- | csc/cps-test.csc | 59 | ||||
| -rw-r--r-- | csc/cps.csc | 58 | ||||
| -rw-r--r-- | csc/ir1.csc | 2 | ||||
| -rw-r--r-- | csc/ir2.csc | 52 | ||||
| -rw-r--r-- | csc/list-test.csc | 13 | ||||
| -rw-r--r-- | csc/list.csc | 10 |
6 files changed, 182 insertions, 12 deletions
diff --git a/csc/cps-test.csc b/csc/cps-test.csc index ea1d177..d51d10c 100644 --- a/csc/cps-test.csc +++ b/csc/cps-test.csc @@ -6,6 +6,9 @@ make-constant make-define-syntax make-if + make-lambda + make-lambda-case + make-letrec make-lexical-ref make-lexical-set make-library-ref @@ -15,9 +18,11 @@ make-atom make-branch make-call-closure + make-closure make-kargs make-klabel make-ktail + make-lambda-args make-update) (only (csc loop) loop @@ -130,3 +135,57 @@ (cons 2 (make-klabel (make-atom (make-constant 2) 1)))) (soup->alist (ir1->ir2 (make-sequence (make-constant 1) (make-constant 2)))))) + + +(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)))))) + + +(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 + (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)))))) diff --git a/csc/cps.csc b/csc/cps.csc index 55e7e81..0c85707 100644 --- a/csc/cps.csc +++ b/csc/cps.csc @@ -16,6 +16,18 @@ if-consequent if-test if? + lambda-body + lambda-case-alternate + lambda-case-arguments + lambda-case-body + lambda-case-gensyms + lambda-case-rest + lambda? + letrec-expression + letrec-gensyms + letrec-names + letrec-values + letrec? lexical-ref? lexical-set-expression lexical-set-ref @@ -24,8 +36,13 @@ library-define-ref library-define? library-ref? + make-call make-constant + make-lambda + make-lambda-case make-lexical-ref + make-lexical-set + make-sequence sequence-head sequence-tail sequence?) @@ -33,9 +50,11 @@ make-atom make-branch make-call-closure + make-closure make-kargs make-klabel make-ktail + make-lambda-args make-update) (only (csc loop) loop @@ -105,6 +124,45 @@ (make-klabel (to-cps (sequence-tail expr) continuation add-continuation))) add-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)) + ((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)) + (letrec-expression expr)) + #f)) + (map (lambda (x) (make-constant #f)) names)) + continuation + add-continuation))) (else (error "unexpected type in to-cps" expr)))) diff --git a/csc/ir1.csc b/csc/ir1.csc index cf745c6..26b885b 100644 --- a/csc/ir1.csc +++ b/csc/ir1.csc @@ -170,7 +170,7 @@ ; 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 nil, an + ; 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) diff --git a/csc/ir2.csc b/csc/ir2.csc index fc31ce3..1872b65 100644 --- a/csc/ir2.csc +++ b/csc/ir2.csc @@ -10,6 +10,9 @@ call-closure-args call-closure-closure call-closure? + closure-cases + closure-continuation + closure? ir2=? kargs-expression kargs-refs @@ -17,12 +20,18 @@ klabel-expression klabel? ktail? + lambda-args-kargs + lambda-args-nargs + lambda-args-rest + lambda-args? make-atom make-branch make-call-closure + make-closure make-kargs make-klabel make-ktail + make-lambda-args make-update update-atom update-continuation @@ -61,6 +70,7 @@ make-lexical-ref make-lexical-set make-library-ref) + (only (csc list) all) (only (csc loop) loop return)) @@ -128,6 +138,26 @@ (continuation call-closure-continuation)) + ; 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. + (define-record-type <closure> + (make-closure cases continuation) + closure? + (cases closure-cases) + (continuation closure-continuation)) + + ; CPS continuations. @@ -171,22 +201,24 @@ (y-args (call-closure-args y))) (and (ir1=? (call-closure-closure x) (call-closure-closure y)) (= (length x-args) (length y-args)) - (loop for x-arg in (call-closure-args x) - for y-arg in (call-closure-args y) - unless (ir1=? x-arg y-arg) - return #f - finally (return #t)) + (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)) - (loop for x-ref in x-refs - for y-ref in y-refs - unless (ir1=? x-ref y-ref) - return #f - finally (return #t)) + (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))) diff --git a/csc/list-test.csc b/csc/list-test.csc index d4c145a..faa90b6 100644 --- a/csc/list-test.csc +++ b/csc/list-test.csc @@ -98,5 +98,18 @@ (test unzip-empty (assert (values= (values '() '()) (unzip '())))) + (test unzip-simple (assert (values= (values '(1 2 3) '(4 5 6)) (unzip '((1 . 4) (2 . 5) (3 . 6)))))) + + +(test all-even + (assert-equal + #t + (all (lambda (x) (= 0 (remainder x 2))) '(2 12 8)))) + + +(test some-odd + (assert-equal + #f + (all (lambda (x) (= 0 (remainder x 2))) '(2 13 8)))) diff --git a/csc/list.csc b/csc/list.csc index 95fff04..cc64168 100644 --- a/csc/list.csc +++ b/csc/list.csc @@ -1,5 +1,6 @@ (define-library (csc list) (export + all enumerate filter intercalate @@ -70,4 +71,11 @@ (loop for x in l collect (car x) into xs collect (cdr x) into ys - finally (return (values xs ys)))))) + finally (return (values xs ys)))) + + + (define (all pred l) + (loop for x in l + unless (pred x) + return #f + finally (return #t))))) |