diff options
| -rw-r--r-- | csc/cps.csc | 237 | ||||
| -rw-r--r-- | csc/ir1.csc | 49 | ||||
| -rw-r--r-- | csc/ir2.csc | 40 | ||||
| -rw-r--r-- | csc/match-test.csc | 16 | ||||
| -rw-r--r-- | csc/match.csc | 43 |
5 files changed, 233 insertions, 152 deletions
diff --git a/csc/cps.csc b/csc/cps.csc index cf4a26d..b6decbb 100644 --- a/csc/cps.csc +++ b/csc/cps.csc @@ -1,37 +1,28 @@ (define-library (csc cps) (export ir1->ir2) - (import (only (csc gensym) gensym) + (import (scheme base) + (only (csc gensym) gensym) (only (csc hash-map) insert make-map merge) (only (csc ir1) - call-arguments - call-procedure + %call + %define-syntax + %if + %lambda + %letrec + %lexical-set + %library-define + %sequence call? constant? - define-syntax? - if-alternate - if-consequent - if-test if? - lambda-arguments - lambda-body - lambda-rest lambda? - letrec-expression - letrec-gensyms - letrec-in-order? - letrec-names - letrec-values letrec? lexical-ref? - lexical-set-expression - lexical-set-ref lexical-set? - library-define-expression - library-define-ref library-define? library-ref? make-call @@ -40,8 +31,6 @@ make-lexical-ref make-lexical-set make-sequence - sequence-head - sequence-tail sequence?) (only (csc ir2) make-apply @@ -57,7 +46,7 @@ (only (csc loop) loop return) - (scheme base)) + (only (csc match) match)) (begin @@ -66,48 +55,52 @@ (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)))) + (match expr + ((% %letrec _ names gensyms vals _) + (loop for name in names + for gensym in gensyms + for value in vals + if (lambda? value) + collect (match value + ((% %lambda args rest body) + (define continuation (new-ref)) + (make-closure + (make-lexical-ref name gensym) + (cons continuation args) + rest + (ir1->ir2 + body + (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)) + (match expr + (_ (when (or (constant? expr) + (lexical-ref? expr) + (library-ref? expr))) (continuation expr)) - ((lexical-set? expr) + ((% %lexical-set ref arg) (ir1->ir2 - (lexical-set-expression expr) + arg (lambda (val) - (make-update (lexical-set-ref expr) val (continuation (make-constant #f)))))) - ((library-define? expr) + (make-update ref val (continuation (make-constant #f)))))) + ((% %library-define ref arg) (ir1->ir2 - (library-define-expression expr) + arg (lambda (val) - (make-update (library-define-ref expr) val (continuation (make-constant #f)))))) - ((define-syntax? expr) + (make-update ref val (continuation (make-constant #f)))))) + ((% %define-syntax _ _) ; no-op (continuation (make-constant #f))) - ((if? expr) + ((% %if test consequent alternate) (ir1->ir2 - (if-test expr) + test (lambda (val) (define continuation-ref (new-ref)) (define result-ref (new-ref)) @@ -116,81 +109,81 @@ (continuation result-ref))) (make-branch val (ir1->ir2 - (if-consequent expr) + consequent (lambda (result) (make-apply continuation-ref (list result)))) (ir1->ir2 - (if-alternate expr) + alternate (lambda (result) (make-apply continuation-ref (list result))))))))) - ((call? 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) + ((% %call proc args) + (define return-address (new-ref)) + (define result (new-ref)) + (make-fix + (list (make-closure return-address (list result) #f (continuation result))) + (ir1->ir2 + proc + (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 args)) + (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 head tail) (ir1->ir2 - (sequence-head expr) + head (lambda (x) (ir1->ir2 - (sequence-tail expr) - continuation)))) - ((lambda? expr) - (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) - (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)) - variable-values)) + tail continuation)))) - (else (error "unexpected type in ir1->ir2" expr)))))) + ((% %lambda args rest body) + (define f (new-ref)) + (define k (new-ref)) + (make-fix + (list + (make-closure f (cons k args) rest + (ir1->ir2 + body + (lambda (ret) + (make-apply k (list ret)))))) + (continuation f))) + ((% %letrec in-order? _ _ _ body) + (define-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 in-order? + (loop for name in (reverse variable-names) + for value in (reverse variable-values) + for expr = (make-call + (make-lambda + (list name) + #f + body) + (list value)) + then (make-call + (make-lambda + (list name) + #f + expr) + (list value)) + finally (return expr)) + (make-call + (make-lambda + variable-names + #f + body) + variable-values)) + continuation))) + (_ (error "unexpected type in ir1->ir2" expr)))))) diff --git a/csc/ir1.csc b/csc/ir1.csc index d82cf12..73ec703 100644 --- a/csc/ir1.csc +++ b/csc/ir1.csc @@ -1,5 +1,16 @@ (define-library (csc ir1) (export + %call + %constant + %define-syntax + %if + %lambda + %letrec + %lexical-ref + %lexical-set + %library-define + %library-ref + %sequence call-arguments call-procedure call? @@ -12,7 +23,6 @@ if-consequent if-test if? - import? ir1=? lambda-arguments lambda-body @@ -53,7 +63,9 @@ (import (scheme base) (only (csc list) all) - (only (csc loop) loop return)) + (only (csc loop) loop return) + (only (csc match) + define-match-record-type)) (begin ; This library defines the intermediate representation IR1. An expression ; in IR1 has one of the following forms (plagiarized from Guile's @@ -62,9 +74,10 @@ ; <constant> expression ; Constant is used to include literal constants in scheme code. - (define-record-type <constant> + (define-match-record-type <constant> (make-constant expression) constant? + %constant (expression constant-expression)) @@ -72,9 +85,10 @@ ; A reference to a lexically-bound variable. The name is the original name ; of the variable in the source program. gensym is a unique identifier for ; this variable. - (define-record-type <lexical-ref> + (define-match-record-type <lexical-ref> (make-lexical-ref name gensym) lexical-ref? + %lexical-ref (name lexical-ref-name) (gensym lexical-ref-gensym)) @@ -82,27 +96,30 @@ ; <library-ref> name ; A free reference to a variable in a library. If the library is 'main, ; then it is a top-level global variable. - (define-record-type <library-ref> + (define-match-record-type <library-ref> (make-library-ref name library) library-ref? + %library-ref (name library-ref-name) (library library-ref-library)) ; <lexical-set> name gensym expression ; Sets a lexically-bound variable. - (define-record-type <lexical-set> + (define-match-record-type <lexical-set> (make-lexical-set ref expression) lexical-set? + %lexical-set (ref lexical-set-ref) (expression lexical-set-expression)) ; <library-define> name expression ; Defines a new variable in the current library. - (define-record-type <library-define> + (define-match-record-type <library-define> (make-library-define ref expression) library-define? + %library-define (ref library-define-ref) (expression library-define-expression)) @@ -110,18 +127,20 @@ ; <define-syntax> name transformer ; Defines a new macro in the current environment. name is the name of the ; macro. transformer is a macro transformer. - (define-record-type <define-syntax> + (define-match-record-type <define-syntax> (make-define-syntax name transformer) define-syntax? + %define-syntax (name define-syntax-name) (transformer define-syntax-transformer)) ; <if> test consequent alternate ; A conditional. - (define-record-type <if> + (define-match-record-type <if> (make-if test consequent alternate) if? + %if (test if-test) (consequent if-consequent) (alternate if-alternate)) @@ -131,18 +150,20 @@ ; A procedure call. The procedure and arguments are evaluated in an ; unspecified order, and the resulting procedure is passed the ; resulting arguments. - (define-record-type <call> + (define-match-record-type <call> (make-call procedure arguments) call? + %call (procedure call-procedure) (arguments call-arguments)) ; <sequence> head tail ; Evaluate head, ignoring any result. Then tail is evaluated. - (define-record-type <sequence> + (define-match-record-type <sequence> (make-sequence head tail) sequence? + %sequence (head sequence-head) (tail sequence-tail)) @@ -150,9 +171,10 @@ ; <lambda> body ; 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> + (define-match-record-type <lambda> (make-lambda arguments rest body) lambda? + %lambda (arguments lambda-arguments) (rest lambda-rest) (body lambda-body)) @@ -163,9 +185,10 @@ ; names are the original binding names, gensyms are gensyms corresponding ; to the names, and values are IR1 expressions for the values. expression ; is a single IR1 expression. - (define-record-type <letrec> + (define-match-record-type <letrec> (make-letrec in-order? names gensyms values expression) letrec? + %letrec (in-order? letrec-in-order?) (names letrec-names) (gensyms letrec-gensyms) diff --git a/csc/ir2.csc b/csc/ir2.csc index 9b9397f..40109fe 100644 --- a/csc/ir2.csc +++ b/csc/ir2.csc @@ -78,7 +78,9 @@ (only (csc list) all) (only (csc loop) loop - return)) + return) + (only (csc match) + define-match-record-type)) (begin ; This library defines the intermediate representation IR2. ; It's CPS time bitch. @@ -90,6 +92,27 @@ ; - constant, ; - lexical-ref, ; - or library-ref + ; After closure conversion, lexical refs are no longer allowed. + ; Lexical refs are converted to one of the below data types. + + + ; A variable representing the address of a function in the same compilation + ; unit. This will be a constant after linking. + (define-match-record-type <label> + (make-label gensym) + label? + %label + (gensym label-gensym)) + + + ; A local variable. This can be an argument to a function or the result of + ; a primitive. + (define-match-record-type <var> + (make-var gensym) + var? + %var + (gensym var-gensym)) + ; CPS expressions: ; CPS expressions are similar to IR1 expressions, @@ -98,9 +121,10 @@ ; Modifies a library or lexically bound variable to the given atom. - (define-record-type <update> + (define-match-record-type <update> (make-update ref atom continuation) update? + %update (ref update-ref) (atom update-atom) (continuation update-continuation)) @@ -109,9 +133,10 @@ ; Branches depending on the given atom. ; If it is true, continue with continuation true. ; If false, continue with continuation false. - (define-record-type <branch> + (define-match-record-type <branch> (make-branch atom true false) branch? + %branch (atom branch-atom) (true branch-true) (false branch-false)) @@ -120,9 +145,10 @@ ; 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> + (define-match-record-type <apply> (make-apply procedure arguments) apply? + %apply (procedure apply-procedure) (arguments apply-arguments)) @@ -130,9 +156,10 @@ ; 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> + (define-match-record-type <closure> (make-closure name arguments rest body) closure? + %closure (name closure-name) (arguments closure-arguments) (rest closure-rest) @@ -141,9 +168,10 @@ ; Defines a list of mutually recursive procedures. ; Functions is a list of closures, and body is an expression. - (define-record-type <fix> + (define-match-record-type <fix> (make-fix functions body) fix? + %fix (functions fix-functions) (body fix-body)) diff --git a/csc/match-test.csc b/csc/match-test.csc index 31e7afa..c5314ce 100644 --- a/csc/match-test.csc +++ b/csc/match-test.csc @@ -85,3 +85,19 @@ (n (when (= 1 n)) 1) (n (when (= 10 n)) 2) (_ 3)))) + + +(define-match-record-type <test-record-type> + (make-test-record-type a b c) + test-record-type? + %test-record-type + (a test-record-type-a) + (b test-record-type-b) + (c test-record-type-c)) + + +(test match-record-type + (assert-equal + 2 + (match (make-test-record-type 1 2 3) + ((% %test-record-type a b c) b)))) diff --git a/csc/match.csc b/csc/match.csc index 5b85f09..ad9b56a 100644 --- a/csc/match.csc +++ b/csc/match.csc @@ -1,5 +1,7 @@ (define-library (csc match) - (export match) + (export + define-match-record-type + match) (import (scheme base)) (begin @@ -9,34 +11,53 @@ no-match?) + (define *no-match* (make-no-match)) + + + (define-syntax define-match-record-type + (syntax-rules () + ((define-match-record-type name constructor predicate matcher (field-name* field-getter*) ...) + (begin + (define-record-type name + constructor + predicate + (field-name* field-getter*) ...) + (define (matcher x) + (unless (predicate x) + (raise *no-match*)) + (list (field-getter* x) ...)))))) + + (define-syntax match-pattern - (syntax-rules (_ ! when) + (syntax-rules (_ ! when %) ((match-pattern x pattern (when condition) result result* ...) (match-pattern x pattern (if condition - (begin result result* ...) - (raise (make-no-match))))) + (let () result result* ...) + (raise *no-match*)))) ((match-pattern x _ result result* ...) - (begin result result* ...)) + (let () result result* ...)) ((match-pattern x '() result result* ...) (if (null? x) - (begin result result* ...) - (raise (make-no-match)))) + (let () result result* ...) + (raise *no-match*))) ((match-pattern x (! constant) result result* ...) (if (equal? x constant) - (begin result result* ...) - (raise (make-no-match)))) + (let () result result* ...) + (raise *no-match*))) ((match-pattern x (pattern) result result* ...) (let ((y x)) (if (= 1 (length y)) (match-pattern (car y) pattern result result* ...) - (raise (make-no-match))))) + (raise *no-match*)))) + ((match-pattern x (% record-matcher . patterns) result result* ...) + (match-pattern (record-matcher x) patterns result result* ...)) ((match-pattern x (pattern . rest) result result* ...) (let ((y x)) (if (pair? y) (match-pattern (car y) pattern (match-pattern (cdr y) rest result result* ...)) - (raise (make-no-match))))) + (raise *no-match*)))) ((match-pattern x identifier result result* ...) (let ((identifier x)) result result* ...)))) |