Implement lambda?

1 files changed, 110 insertions, 12 deletions

diff --git a/csc/macros.csc b/csc/macros.csc
index b4bb66e..df8bc73 100644
--- a/csc/macros.csc
+++ b/csc/macros.csc
@@ -26,8 +26,21 @@
             make-constant
             make-lambda
             make-lambda-case
-            make-library-ref)
-          (only (csc list) revappend)
+            make-library-ref
+            make-void
+            sequence-head
+            sequence-tail
+            sequence?
+            toplevel-define-expression
+            toplevel-define-name
+            toplevel-define?
+            void?)
+          (only (csc list)
+            revappend
+            unzip)
+          (only (csc loop)
+            loop
+            return)
           (only (csc match) match)
           (only (csc strings) join)
           (only (csc vec)
@@ -63,8 +76,9 @@
     ; and the third represents a macro transformer bound in the
     ; current context.
     ;
-    ; library is the current library name being compiled. A nil library
-    ; corresponds to top level expressions.
+    ; library holds information about what library toplevel defines will define
+    ; into. A value of nil means the main program. The special value 'lambda
+    ; means define should emit a <lambda-define> object.
     (define-record-type <environment>
       (make-environment symbols library)
       environment?
@@ -212,13 +226,13 @@
         ((syntax-case-match-pattern x pattern (when condition) result result* ...)
           (syntax-case-match-pattern x pattern
             (if condition
-              (begin result result* ...)
+              (let () result result* ...)
               (raise (make-syntax-case-no-match)))))
         ((syntax-case-match-pattern x _ result result* ...)
-          (begin result result* ...))
+          (let () result result* ...))
         ((syntax-case-match-pattern x '() result result* ...)
           (if (null? (syntax->expression x))
-            (begin result result* ...)
+            (let () result result* ...)
             (raise (make-syntax-case-no-match))))
         ((syntax-case-match-pattern x (pattern) result result* ...)
           (let ((y x))
@@ -600,21 +614,18 @@
           (values
             (make-macro-transformer
               (lambda (input-form)
-                (let-values (((x y)
                 (syntax-case syntax-rules-form
                   ((_ ellipsis literals . rules) (when (identifier? ellipsis))
                     (syntax-match ellipsis literals rules input-form))
                   ((_ literals . rules)
                     (syntax-match default-ellipsis literals rules input-form))
                   (_ (raise-syntax-error "unexpected form in syntax-rules" syntax-rules-form)))))
-                  (values x y))))
             (syntax-object-environment syntax-rules-form)))))
 
 
     (define builtin-let-syntax
       (make-macro-transformer
         (lambda (x)
-          (let-values (((x y)
           (syntax-case x
             ((_ (ident transformer-form) body-form) (when (identifier? ident))
               (let*-values (((transformer environment) (expand-syntax-object transformer-form))
@@ -622,8 +633,95 @@
                 (values
                   body
                   (syntax-object-environment x))))
-            (_ (raise-syntax-error "unexpected for in let-syntax")))))
-            (values x y)))))
+            (_ (raise-syntax-error "unexpected for in let-syntax"))))))
+
+
+    (define (split-args-rest formals)
+      (syntax-case formals
+        ('()
+          (values '() #f))
+        ((var . vars) (when (identifier? var))
+          (let-values (((args rest) (split-args-rest vars)))
+            (values (cons (identifier-name var) args) rest)))
+        (var (when identifier? var)
+          (values '() (identifier-name var)))
+        (_ (raise-syntax-error "unexpected form in case-lambda" formals))))
+
+
+    (define-record-type <lambda-define>
+      (make-lambda-define name gensym expression)
+      lambda-define?
+      (name lambda-define-name)
+      (gensym lambda-define-gensym)
+      (expression lambda-define-expression))
+
+
+    (define (collect-defines acc body)
+      (cond
+        ((lambda-define? body)
+          (values
+            (cons body acc)
+            (make-void)))
+        ((sequence? body)
+          (let-values (((acc rest) (collect-defines acc (sequence-head body))))
+            (if (void? rest)
+              (collect-defines acc (sequence-tail body))
+              (values
+                acc
+                (make-sequence rest (sequence-tail body))))))
+        ((void? body)
+          (values acc body))
+        (else
+          (values (reverse acc) body))))
+
+
+    (define (fix-lambda-body body)
+      (define-values (defines rest) (collect-defines '() body))
+      (define-values (names gensyms vals) (loop for def in defines
+                                                collect (lambda-define-name def) into names
+                                                collect (lambda-define-gensym def) into gensyms
+                                                collect (lambda-define-expression def) into vals
+                                                finally (return (values names gensyms vals))))
+      (make-letrec
+        #t
+        names
+        gensyms
+        vals
+        rest))
+
+
+    (define (with-library lib expr)
+      (make-syntax-object
+        (syntax->expression expr)
+        (make-environment (environment-symbols (syntax-object-environment expr)) lib)
+        (marks expr)))
+
+
+    (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))
+              (fix-lambda-body (expand-syntax-object (with-library 'lambda body)))
+              (case-lambda-helper clauses))))
+        (_ (raise-syntax-error "unexpected form in case-lambda" form))))
+
+
+    (define builtin-case-lambda
+      (make-macro-transformer
+        (lambda (x)
+          (syntax-case x
+            ((_ clause . clauses)
+              (case-lambda-helper x))
+            (_ (raise-syntax-error "unexpected form in case-lambda" x))))))
 
 
     (define test-environment