Improvements in macros and IR1.

We're omitting libraries for now, and I'll add them in later.

1 files changed, 72 insertions, 76 deletions

diff --git a/csc/macros.csc b/csc/macros.csc
index e59973b..08c5fd2 100644
--- a/csc/macros.csc
+++ b/csc/macros.csc
@@ -1,6 +1,7 @@
 (define-library (csc macros)
   (export
     expand
+    program->ir1
     macro-syntax-error?
     builtins-environment)
   (import (scheme base)
@@ -20,14 +21,13 @@
           (only (csc ir1)
             lexical-ref-gensym
             lexical-ref?
-            library-ref-library
-            library-ref-name
-            library-ref?
             make-call
             make-constant
             make-lambda
             make-lambda-case
-            make-library-ref
+            make-letrec
+            make-sequence
+            make-toplevel-ref
             make-void
             sequence-head
             sequence-tail
@@ -35,6 +35,8 @@
             toplevel-define-expression
             toplevel-define-name
             toplevel-define?
+            toplevel-ref-name
+            toplevel-ref?
             void?)
           (only (csc list)
             revappend
@@ -71,20 +73,15 @@
 
     ; symbols is a map with identifiers as keys, and the values can be one of:
     ; - <lexical-ref>,
-    ; - <library-ref>,
+    ; - <toplevel-ref>,
     ; - or <macro-transformer>.
     ; The first two correspond to variables bound lexically or from a module,
     ; and the third represents a macro transformer bound in the
     ; current context.
-    ;
-    ; 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)
+      (make-environment symbols)
       environment?
-      (symbols environment-substitutions)
-      (library environment-library))
+      (symbols environment-substitutions))
 
 
     (define-record-type <syntax-object>
@@ -117,7 +114,7 @@
       (let ((environment (syntax-object-environment syntax)))
         (make-syntax-object
           (syntax->expression syntax)
-          (make-environment (insert (environment-substitutions environment) identifier binding) (environment-library environment))
+          (make-environment (insert (environment-substitutions environment) identifier binding))
           (marks syntax))))
 
 
@@ -152,10 +149,9 @@
       (or (and (lexical-ref? b1)
                (lexical-ref? b2)
                (gensym=? (lexical-ref-gensym b1) (lexical-ref-gensym b2)))
-          (and (library-ref? b1)
-               (library-ref? b2)
-               (equal? (library-ref-library b1) (library-ref-library b2))
-               (symbol=? (library-ref-name b1) (library-ref-name b2)))
+          (and (toplevel-ref? b1)
+               (toplevel-ref? b2)
+               (symbol=? (toplevel-ref-name b1) (toplevel-ref-name b2)))
           (and (macro-transformer? b1)
                (macro-transformer? b2)
                (eq? (transformer-function b1) (transformer-function b2)))))
@@ -266,18 +262,18 @@
 
 
     (define (expand-procedure-call procedure arguments)
-      (let-values (((expanded-procedure environment) (expand-syntax-object procedure))
-                   ((expanded-arguments)
-                     (let loop ((arguments arguments)
-                                (expanded-arguments '()))
-                       (syntax-case arguments
-                         ('() (reverse expanded-arguments))
-                         ((argument . rest)
-                           (let-values (((expanded-argument environment) (expand-syntax-object argument)))
-                             (loop
-                               rest
-                               (cons expanded-argument expanded-arguments))))
-                         (_ (raise-syntax-error "arguments to a procedure call must be a list" procedure arguments))))))
+      (let ((expanded-procedure (expand-syntax-object procedure))
+            (expanded-arguments
+              (let loop ((arguments arguments)
+                         (expanded-arguments '()))
+                (syntax-case arguments
+                  ('() (reverse expanded-arguments))
+                  ((argument . rest)
+                    (let ((expanded-argument (expand-syntax-object argument)))
+                      (loop
+                        rest
+                        (cons expanded-argument expanded-arguments))))
+                  (_ (raise-syntax-error "arguments to a procedure call must be a list" procedure arguments))))))
         (make-call expanded-procedure expanded-arguments)))
 
 
@@ -299,23 +295,23 @@
           (let ((macro-body (resolve-identifier macro-name)))
             (if (macro-transformer? macro-body)
               ((transformer-function macro-body) syntax)
-              (values (expand-procedure-call macro-name tail) (syntax-object-environment syntax)))))
+              (expand-procedure-call macro-name tail))))
         ((procedure . arguments)
-          (values (expand-procedure-call procedure arguments) (syntax-object-environment syntax)))
+          (expand-procedure-call procedure arguments))
         (_ (when (identifier? syntax))
           (let ((binding
                   (guard (e ((key-not-found-error? e) (raise-syntax-error "undefined symbol" syntax)))
                     (lookup (environment-substitutions (syntax-object-environment syntax)) syntax))))
             (if (macro-transformer? binding)
               (raise-syntax-error "macro is not allowed in this context" syntax)
-              (values binding (syntax-object-environment syntax)))))
+              binding)))
         (_ (when (let ((expr (syntax->expression syntax)))
                    (or (boolean? expr)
                        (char? expr)
                        (number? expr)
                        (string? expr)
                        (vector? expr))))
-          (values (make-constant (syntax->expression syntax)) (syntax-object-environment syntax)))
+          (make-constant (syntax->expression syntax)))
         (_ (raise-syntax-error "unexpected expression type" (clean-syntax syntax)))))
 
 
@@ -337,7 +333,7 @@
       (make-macro-transformer
         (lambda (syntax)
           (syntax-case syntax
-            ((_ datum) (values (make-constant (clean-syntax datum)) (syntax-object-environment syntax)))
+            ((_ datum) (make-constant (clean-syntax datum)))
             (_ (raise-syntax-error "invalid form for quote" (clean-syntax syntax)))))))
 
 
@@ -387,8 +383,7 @@
             '_
             (make-environment
               (alist->substitutions
-                (list (cons '_ (make-library-ref '(csc builtins) '_ #t))))
-              '())))))
+                (list (cons '_ (make-toplevel-ref '_)))))))))
 
 
     (define (syntax-improper-list-length l)
@@ -604,23 +599,20 @@
         (make-environment
           (alist->substitutions
             (list (cons '_
-                        (make-library-ref '(csc builtins) '_ #t))))
-          '())))
+                        (make-toplevel-ref '_)))))))
 
 
     (define builtin-syntax-rules
       (make-macro-transformer
         (lambda (syntax-rules-form)
-          (values
-            (make-macro-transformer
-              (lambda (input-form)
-                (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)))))
-            (syntax-object-environment syntax-rules-form)))))
+          (make-macro-transformer
+            (lambda (input-form)
+              (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))))))))
 
 
     (define builtin-let-syntax
@@ -628,11 +620,9 @@
         (lambda (x)
           (syntax-case x
             ((_ (ident transformer-form) body-form) (when (identifier? ident))
-              (let*-values (((transformer environment) (expand-syntax-object transformer-form))
-                            ((body environment) (expand-syntax-object (with-binding ident transformer body-form))))
-                (values
-                  body
-                  (syntax-object-environment x))))
+              (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"))))))
 
 
@@ -648,17 +638,9 @@
         (_ (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)
+        ((toplevel-define? body)
           (values
             (cons body acc)
             (make-void)))
@@ -678,9 +660,9 @@
     (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
+                                                collect (toplevel-define-name def) into names
+                                                collect (gensym) into gensyms
+                                                collect (toplevel-define-expression def) into vals
                                                 finally (return (values names gensyms vals))))
       (make-letrec
         #t
@@ -690,13 +672,6 @@
         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
         ('() '())
@@ -710,7 +685,7 @@
                 (if rest
                   (cons rest args)
                   args))
-              (fix-lambda-body (expand-syntax-object (with-library 'lambda body)))
+              (fix-lambda-body (expand-syntax-object body))
               (case-lambda-helper clauses))))
         (_ (raise-syntax-error "unexpected form in case-lambda" form))))
 
@@ -728,7 +703,28 @@
       (make-environment
         (alist->substitutions
           (list (cons 'syntax-rules builtin-syntax-rules)
-                (cons '_ (make-library-ref '(csc builtins) '_ #t))
+                (cons '_ (make-toplevel-ref '_))
                 (cons 'quote builtin-quote)
-                (cons 'builtin-let-syntax builtin-let-syntax)))
-        '()))))
+                (cons 'case-lambda builtin-case-lambda)
+                (cons 'builtin-let-syntax builtin-let-syntax)))))
+
+
+    (define (expand-body environment body)
+      (loop for expr in body
+            for expanded-expr = (expand expr environment)
+            for res = expanded-expr then (make-sequence res expanded-expr)
+            finally (return res)
+            if (toplevel-define? expanded-expr)
+              do (set! environment (insert environment (toplevel-define-name expanded-expr) (toplevel-define-expression expanded-expr)))))
+
+
+    ; A Scheme program consists of one or more import declarations
+    ; followed by a sequence of expressions and definitions.
+    ;   -- R7RS
+    (define (program->ir1 program)
+      (loop for expr in program
+            for body on program
+            do (match expr
+                 ; Add this line to make yourself feel better.
+                 ((! ('import ('csc 'builtins))) '())
+                 (_ (return (expand-body builtins-environment body))))))))