diff options
| -rw-r--r-- | csc/ir1.csc | 16 | ||||
| -rw-r--r-- | csc/macros-test.csc | 14 | ||||
| -rw-r--r-- | csc/macros.csc | 37 |
3 files changed, 49 insertions, 18 deletions
diff --git a/csc/ir1.csc b/csc/ir1.csc index 3826c34..59911ab 100644 --- a/csc/ir1.csc +++ b/csc/ir1.csc @@ -161,7 +161,7 @@ ; 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 + ; 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 @@ -191,7 +191,7 @@ (expression letrec-expression)) - (define (ir1=? x y) + (define (ir1=?-sametype x y) (cond ((and (void? x) (void? y)) #t) ((and (constant? x) (constant? y)) @@ -233,8 +233,8 @@ (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 (not (lambda-case-alternate x)) - (not (lambda-case-alternate y))) + (or (and (null? (lambda-case-alternate x)) + (null? (lambda-case-alternate y))) (ir1=? (lambda-case-alternate x) (lambda-case-alternate y))))) ((and (letrec? x) (letrec? y)) (and @@ -246,6 +246,12 @@ unless (ir1=? x-val y-val) return #f finally (return #t)) (ir1=? (letrec-expression x) (letrec-expression y)))) - ((and (ir1=? x x) (ir1=? y y)) + (else #f))) + + + (define (ir1=? x y) + (cond + ((ir1=?-sametype x y) #t) + ((and (ir1=?-sametype x x) (ir1=?-sametype y y)) #f) (else (error "One or more arguments has a type unknown to ir1=?" x y)))))) diff --git a/csc/macros-test.csc b/csc/macros-test.csc index 4bdc3f1..23a9cfc 100644 --- a/csc/macros-test.csc +++ b/csc/macros-test.csc @@ -2,13 +2,14 @@ (only (csc ir1) constant-expression constant? + ir1=? lexical-ref-name lexical-ref? lexical-set-expression lexical-set-name lexical-set? make-constant - ir1=? + make-lambda-case void?) (only (csc testing) assert-equal @@ -172,3 +173,14 @@ ((foo x :::) (x :::)))) (foo quote 5)) builtins-environment))) + + +(test builtin-case-lambda + (assert-equal ir1=? + (make-lambda-case '(x y z) #f #f (make-constant 5) + (make-lambda-case '(a b c) 'd #f (make-constant 6) '())) + (expand + '(case-lambda + ((x y z) (quote 5)) + ((a b c . d) (quote 6))) + builtins-environment))) diff --git a/csc/macros.csc b/csc/macros.csc index 08c5fd2..da2e7b7 100644 --- a/csc/macros.csc +++ b/csc/macros.csc @@ -27,6 +27,7 @@ make-lambda-case make-letrec make-sequence + make-toplevel-define make-toplevel-ref make-void sequence-head @@ -623,7 +624,7 @@ (let* ((transformer (expand-syntax-object transformer-form)) (body (expand-syntax-object (with-binding ident transformer body-form)))) body)) - (_ (raise-syntax-error "unexpected for in let-syntax")))))) + (_ (raise-syntax-error "unexpected form in let-syntax")))))) (define (split-args-rest formals) @@ -635,7 +636,7 @@ (values (cons (identifier-name var) args) rest))) (var (when identifier? var) (values '() (identifier-name var))) - (_ (raise-syntax-error "unexpected form in case-lambda" formals)))) + (_ (raise-syntax-error "unexpected form in split-args-rest" formals)))) (define (collect-defines acc body) @@ -664,18 +665,20 @@ collect (gensym) into gensyms collect (toplevel-define-expression def) into vals finally (return (values names gensyms vals)))) - (make-letrec - #t - names - gensyms - vals - rest)) + (if (null? names) + rest + (make-letrec + #t + names + gensyms + vals + rest))) (define (case-lambda-helper form) (syntax-case form ('() '()) - ((_ (formals body) . clauses) + (((formals body) . clauses) (let-values (((args rest) (split-args-rest formals))) (make-lambda-case args @@ -687,7 +690,7 @@ args)) (fix-lambda-body (expand-syntax-object body)) (case-lambda-helper clauses)))) - (_ (raise-syntax-error "unexpected form in case-lambda" form)))) + (_ (raise-syntax-error "unexpected form in case-lambda-helper" form)))) (define builtin-case-lambda @@ -695,18 +698,28 @@ (lambda (x) (syntax-case x ((_ clause . clauses) - (case-lambda-helper x)) + (case-lambda-helper (with-wrap (cons clause clauses) x))) (_ (raise-syntax-error "unexpected form in case-lambda" x)))))) + (define builtin-define + (make-macro-transformer + (lambda (x) + (syntax-case x + ((_ symbol expression) + (make-toplevel-define (identifier-name symbol) (expand-syntax-object expression))) + (_ (raise-syntax-error "unexpected form in builtin-define" x)))))) + + (define builtins-environment (make-environment (alist->substitutions (list (cons 'syntax-rules builtin-syntax-rules) (cons '_ (make-toplevel-ref '_)) + (cons 'builtin-let-syntax builtin-let-syntax) (cons 'quote builtin-quote) (cons 'case-lambda builtin-case-lambda) - (cons 'builtin-let-syntax builtin-let-syntax))))) + (cons 'builtin-define builtin-define))))) (define (expand-body environment body) |