Write a test for case-lambda.

I'm realizing that I should have started with builtin-exit and
implemented the hard stuff later.

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)