Improvements in macros and IR1.

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

4 files changed, 171 insertions, 184 deletions

diff --git a/csc/ir1.csc b/csc/ir1.csc
index 334f870..3826c34 100644
--- a/csc/ir1.csc
+++ b/csc/ir1.csc
@@ -10,6 +10,7 @@
     if-test
     if?
     import?
+    ir1=?
     lambda-body
     lambda-case-alternate
     lambda-case-arguments
@@ -41,6 +42,7 @@
     make-lexical-set
     make-sequence
     make-toplevel-define
+    make-toplevel-ref
     make-void
     sequence-head
     sequence-tail
@@ -48,8 +50,11 @@
     toplevel-define-expression
     toplevel-define-name
     toplevel-define?
+    toplevel-ref-name
+    toplevel-ref?
     void?)
-  (import (scheme base))
+  (import (scheme base)
+          (only (csc loop) loop return))
   (begin
     ; This library defines the intermediate representation IR1. An expression
     ; in IR1 has one of the following forms (plagiarized from Guile's
@@ -82,6 +87,14 @@
       (gensym lexical-ref-gensym))
 
 
+    ; <toplevel-ref> name
+    ; A free reference to a top level variable.
+    (define-record-type <toplevel-ref>
+      (make-toplevel-ref name)
+      toplevel-ref?
+      (name toplevel-ref-name))
+
+
     ; <lexical-set> name gensym expression
     ; Sets a lexically-bound variable.
     (define-record-type <lexical-set>
@@ -175,4 +188,64 @@
       (names letrec-names)
       (gensyms letrec-gensyms)
       (values letrec-values)
-      (expression letrec-expression))))
+      (expression letrec-expression))
+
+
+    (define (ir1=? x y)
+      (cond
+        ((and (void? x) (void? y)) #t)
+        ((and (constant? x) (constant? y))
+          (equal? (constant-expression x) (constant-expression y)))
+        ((and (lexical-ref? x) (lexical-ref? y))
+          (symbol=? (lexical-ref-name x) (lexical-ref-name y)))
+        ((and (toplevel-ref? x) (toplevel-ref? y))
+          (symbol=? (toplevel-ref-name x) (toplevel-ref-name y)))
+        ((and (lexical-set? x) (lexical-set? y))
+          (and
+            (symbol=? (lexical-set-name x) (lexical-set-name y))
+            (ir1=? (lexical-set-expression x) (lexical-set-expression y))))
+        ((and (toplevel-define? x) (toplevel-define? y))
+          (and
+            (symbol=? (toplevel-define-name x) (toplevel-define-name y))
+            (ir1=? (toplevel-define-expression x) (toplevel-define-expression y))))
+        ((and (if? x) (if? y))
+          (and
+            (ir1=? (if-test x) (if-test y))
+            (ir1=? (if-consequent x) (if-consequent y))
+            (ir1=? (if-alternate x) (if-alternate y))))
+        ((and (call? x) (call? y))
+          (and
+            (ir1=? (call-procedure x) (call-procedure y))
+            (= (length (call-arguments x)) (length (call-arguments y)))
+            (loop for x-arg in (call-arguments x)
+                  for y-arg in (call-arguments y)
+                  unless (ir1=? x-arg y-arg)
+                    return #f
+                  finally (return #t))))
+        ((and (sequence? x) (sequence? y))
+          (and
+            (ir1=? (sequence-head x) (sequence-head y))
+            (ir1=? (sequence-tail x) (sequence-tail y))))
+        ((and (lambda? x) (lambda? y))
+          (ir1=? (lambda-body x) (lambda-body y)))
+        ((and (lambda-case? x) (lambda-case? y))
+          (and
+            (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)))
+                (ir1=? (lambda-case-alternate x) (lambda-case-alternate y)))))
+        ((and (letrec? x) (letrec? y))
+          (and
+            (boolean=? (letrec-in-order? x) (letrec-in-order? y))
+            (map symbol=? (letrec-names x) (letrec-names y))
+            (= (length (letrec-values x)) (length (letrec-values y)))
+            (loop for x-val in (letrec-values x)
+                  for y-val in (letrec-values y)
+                  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))
+          #f)
+        (else (error "One or more arguments has a type unknown to ir1=?" x y))))))
diff --git a/csc/ir2.csc b/csc/ir2.csc
index 1542f1e..0c37d6c 100644
--- a/csc/ir2.csc
+++ b/csc/ir2.csc
@@ -10,8 +10,6 @@
     make-lambda-case
 
     ; Re-exports from IR1.
-    lambda?
-    make-lambda
     call-arguments
     call-procedure
     call?
@@ -21,22 +19,14 @@
     if-consequent
     if-test
     if?
-    library-ref-library
-    library-ref-name
-    library-ref-public?
-    library-ref?
-    library-set-expression
-    library-set-library
-    library-set-name
-    library-set-public?
-    library-set?
+    lambda?
     make-call
     make-constant
     make-if
-    make-library-ref
-    make-library-set
+    make-lambda
     make-sequence
     make-toplevel-define
+    make-toplevel-ref
     make-void
     sequence-head
     sequence-tail
@@ -44,6 +34,8 @@
     toplevel-define-expression
     toplevel-define-name
     toplevel-define?
+    toplevel-ref-name
+    toplevel-ref?
     void?)
   (import (scheme base)
           (only (csc ir1)
@@ -58,21 +50,10 @@
             if?
             lambda-body
             lambda?
-            library-ref-library
-            library-ref-name
-            library-ref-public?
-            library-ref?
-            library-set-expression
-            library-set-library
-            library-set-name
-            library-set-public?
-            library-set?
             make-call
             make-constant
             make-if
             make-lambda
-            make-library-ref
-            make-library-set
             make-sequence
             make-toplevel-define
             make-void
@@ -88,6 +69,11 @@
     ; It's CPS time bitch.
 
 
+    ; <variable> 
+    (define-record-type <variable>
+      (make-variable k var
+
+
     ; <closure-ref> idx
     ; Reference to a variable by index in the closure.
     (define-record-type <closure-ref>
diff --git a/csc/macros-test.csc b/csc/macros-test.csc
index 6529e58..4bdc3f1 100644
--- a/csc/macros-test.csc
+++ b/csc/macros-test.csc
@@ -7,16 +7,8 @@
           lexical-set-expression
           lexical-set-name
           lexical-set?
-          library-ref-library
-          library-ref-name
-          library-ref-public?
-          library-ref?
-          library-set-expression
-          library-set-library
-          library-set-name
-          library-set-public?
-          library-set?
           make-constant
+          ir1=?
           void?)
         (only (csc testing)
           assert-equal
@@ -24,69 +16,14 @@
         (csc macros))
 
 
-(define (ir1= x y)
-  (cond
-    ((and (void? x) (void? y)) #t)
-    ((and (constant? x) (constant? y))
-      (equal? (constant-expression x) (constant-expression y)))
-    ((and (lexical-ref? x) (lexical-ref? y))
-      (symbol=? (lexical-ref-name x) (lexical-ref-name y)))
-    ((and (lexical-set? x) (lexical-set? y))
-      (and
-        (symbol=? (lexical-set-name x) (lexical-set-name y))
-        (ir1= (lexical-set-expression x) (lexical-set-expression y))))
-    ((and (library-ref? x) (library-ref? y))
-      (and
-        (equal? (library-ref-library x) (library-ref-library y))
-        (symbol=? (library-ref-name x) (library-ref-name y))
-        (boolean=? (library-ref-public? x) (library-ref-public? y))))
-    ((and (library-set? x) (library-set? y))
-      (and
-        (equal? (library-set-library x) (library-set-library y))
-        (symbol=? (library-set-name x) (library-set-name y))
-        (boolean=? (library-set-public? x) (library-set-public? y))
-        (ir1=? (library-set-expression x) (library-set-expression y))))
-    ((and (toplevel-define? x) (toplevel-define? y))
-      (and
-        (symbol=? (toplevel-define-name x) (toplevel-define-name y))
-        (ir1=? (toplevel-define-expression x) (toplevel-define-expression y))))
-    ((and (if? x) (if? y))
-      (and
-        (ir1=? (if-test x) (if-test y))
-        (ir1=? (if-consequent x) (if-consequent y))
-        (ir1=? (if-alternate x) (if-alternate y))))
-    ((and (call? x) (call? y))
-      (and
-        (ir1=? (call-procedure x) (call-procedure y))
-        (apply (map ir1=? (call-arguments x) (call-arguments y))))
-    ((and (sequence? x) (sequence? y))
-      (and
-        (ir1=? (sequence-head x) (sequence-head y))
-        (ir1=? (sequence-tail x) (sequence-tail y))))
-    ((and (lambda? x) (lambda? y))
-      (ir1=? (lambda-body x) (lambda-body y)))
-    ((and (lambda-case? x) (lambda-case? y))
-      (and
-        (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)))
-            (ir1= (lambda-case-alternate x) (lambda-case-alternate y)))))
-    ((and (letrec? x) (letrec? y))
-      (and
-        (boolean=? (letrec-in-order? x) (letrec-in-order? y))
-        (map symbol=? (letrec-names x) (letrec-names y))
-
-
 (test builtin-quote
-  (assert-equal
+  (assert-equal ir1=?
     (make-constant '(test 1 2 3))
     (expand '(quote (test 1 2 3)) builtins-environment)))
 
 
 (test builtin-syntax-rules-literal
-  (assert-equal
+  (assert-equal ir1=?
     (make-constant 1)
     (expand
       '(builtin-let-syntax
@@ -101,7 +38,7 @@
 
 
 (test builtin-syntax-rules-underscore
-  (assert-equal
+  (assert-equal ir1=?
     (make-constant 0)
     (expand
       '(builtin-let-syntax
@@ -113,7 +50,7 @@
 
 
 (test builtin-syntax-rules-substitution
-  (assert-equal
+  (assert-equal ir1=?
     (make-constant 5)
     (expand
       '(builtin-let-syntax
@@ -125,7 +62,7 @@
 
 
 (test builtin-syntax-rules-nil
-  (assert-equal
+  (assert-equal ir1=?
     (make-constant 1)
     (expand
       '(builtin-let-syntax
@@ -138,7 +75,7 @@
 
 
 (test builtin-syntax-rules-improper-list
-  (assert-equal
+  (assert-equal ir1=?
     (make-constant 1)
     (expand
       '(builtin-let-syntax
@@ -150,7 +87,7 @@
 
 
 (test builtin-syntax-rules-quoted
-  (assert-equal
+  (assert-equal ir1=?
     (make-constant 'a)
     (expand
       '(builtin-let-syntax
@@ -162,7 +99,7 @@
 
 
 (test builtin-syntax-rules-constant
-  (assert-equal
+  (assert-equal ir1=?
     (make-constant 2)
     (expand
       '(builtin-let-syntax
@@ -176,7 +113,7 @@
 
 
 (test builtin-syntax-rules-ellipsis
-  (assert-equal
+  (assert-equal ir1=?
     (make-constant 5)
     (expand
       '(builtin-let-syntax
@@ -188,7 +125,7 @@
 
 
 (test builtin-syntax-rules-ellipsis-improper
-  (assert-equal
+  (assert-equal ir1=?
     (make-constant 5)
     (expand
       '(builtin-let-syntax
@@ -200,7 +137,7 @@
 
 
 (test builtin-syntax-rules-ellipsis-zip
-  (assert-equal
+  (assert-equal ir1=?
     (make-constant '((1 . 3) (2 . 4)))
     (expand
       '(builtin-let-syntax
@@ -213,7 +150,7 @@
 
 
 (test builtin-syntax-rules-ellipsis-nested
-  (assert-equal
+  (assert-equal ir1=?
     (make-constant '(1 2 3 4 5))
     (expand
       '(builtin-let-syntax
@@ -226,7 +163,7 @@
 
 
 (test builtin-syntax-rules-ellipsis-custom
-  (assert-equal
+  (assert-equal ir1=?
     (make-constant 5)
     (expand
       '(builtin-let-syntax
@@ -235,8 +172,3 @@
              ((foo x :::) (x :::))))
          (foo quote 5))
       builtins-environment)))
-
-
-(test builtin-lambda-simple
-  (assert-equal
-    (make-lambda
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))))))))