Add libraries.

Gone is toplevel. Now everyone lives in a library.

1 files changed, 122 insertions, 99 deletions

diff --git a/csc/macros.csc b/csc/macros.csc
index da2e7b7..0b59b84 100644
--- a/csc/macros.csc
+++ b/csc/macros.csc
@@ -1,9 +1,10 @@
 (define-library (csc macros)
   (export
+    builtins-environment
     expand
-    program->ir1
+    expand-body
     macro-syntax-error?
-    builtins-environment)
+    make-environment)
   (import (scheme base)
           (only (csc assert) assert)
           (only (csc format) sprintf)
@@ -12,32 +13,37 @@
             gensym=?)
           (only (csc hash-map)
             alist->map
-            map-for-each
             hash-bytevector
             insert
             key-not-found-error?
             lookup
+            make-map
+            map-for-each
             merge)
           (only (csc ir1)
+            define-syntax-name
+            define-syntax-transformer
+            define-syntax?
             lexical-ref-gensym
             lexical-ref?
+            library-define-expression
+            library-define-name
+            library-define?
+            library-ref-name
+            library-ref?
             make-call
             make-constant
             make-lambda
             make-lambda-case
             make-letrec
+            make-lexical-ref
+            make-library-define
+            make-library-ref
             make-sequence
-            make-toplevel-define
-            make-toplevel-ref
             make-void
             sequence-head
             sequence-tail
             sequence?
-            toplevel-define-expression
-            toplevel-define-name
-            toplevel-define?
-            toplevel-ref-name
-            toplevel-ref?
             void?)
           (only (csc list)
             revappend
@@ -74,15 +80,16 @@
 
     ; symbols is a map with identifiers as keys, and the values can be one of:
     ; - <lexical-ref>,
-    ; - <toplevel-ref>,
+    ; - <library-ref>,
     ; - or <macro-transformer>.
-    ; The first two correspond to variables bound lexically or from a module,
+    ; The first two correspond to variables bound lexically or from a library,
     ; and the third represents a macro transformer bound in the
     ; current context.
     (define-record-type <environment>
-      (make-environment symbols)
+      (make-environment symbols library)
       environment?
-      (symbols environment-substitutions))
+      (symbols environment-substitutions)
+      (library environment-library))
 
 
     (define-record-type <syntax-object>
@@ -111,12 +118,17 @@
         '()))
 
 
+    (define (add-binding identifier binding environment)
+      (make-environment
+        (insert (environment-substitutions environment) identifier binding)
+        (environment-library environment)))
+
+
     (define (with-binding identifier binding syntax)
-      (let ((environment (syntax-object-environment syntax)))
-        (make-syntax-object
-          (syntax->expression syntax)
-          (make-environment (insert (environment-substitutions environment) identifier binding))
-          (marks syntax))))
+      (make-syntax-object
+        (syntax->expression syntax)
+        (add-binding identifier binding (syntax-object-environment syntax))
+        (marks syntax)))
 
 
     (define (identifier? s)
@@ -150,9 +162,9 @@
       (or (and (lexical-ref? b1)
                (lexical-ref? b2)
                (gensym=? (lexical-ref-gensym b1) (lexical-ref-gensym b2)))
-          (and (toplevel-ref? b1)
-               (toplevel-ref? b2)
-               (symbol=? (toplevel-ref-name b1) (toplevel-ref-name b2)))
+          (and (library-ref? b1)
+               (library-ref? b2)
+               (symbol=? (library-ref-name b1) (library-ref-name b2)))
           (and (macro-transformer? b1)
                (macro-transformer? b2)
                (eq? (transformer-function b1) (transformer-function b2)))))
@@ -279,14 +291,17 @@
 
 
     (define (resolve-identifier ident)
-      (let ((substitutions (environment-substitutions (syntax-object-environment ident))))
+      (let* ((environment (syntax-object-environment ident))
+             (substitutions (environment-substitutions environment)))
         (or
           ; Check whether the variable is lexically bound to a marked identifier.
           (guard (e ((key-not-found-error? e) #f))
             (lookup substitutions ident))
           ; Check whether the variable is bound to an unmarked identifier.
-          (guard (e ((key-not-found-error? e) (raise-syntax-error "undefined symbol" ident)))
-            (lookup substitutions (identifier-name ident))))))
+          (guard (e ((key-not-found-error? e) #f))
+            (lookup substitutions (identifier-name ident)))
+          ; Otherwise insert a library-ref
+          (make-library-ref (identifier-name ident) (environment-library environment)))))
 
 
     (define (expand-syntax-object syntax)
@@ -300,9 +315,7 @@
         ((procedure . arguments)
           (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))))
+          (let ((binding (resolve-identifier syntax)))
             (if (macro-transformer? binding)
               (raise-syntax-error "macro is not allowed in this context" syntax)
               binding)))
@@ -384,7 +397,8 @@
             '_
             (make-environment
               (alist->substitutions
-                (list (cons '_ (make-toplevel-ref '_)))))))))
+                (list (cons '_ (make-library-ref '_ '(scheme base)))))
+              '(scheme base))))))
 
 
     (define (syntax-improper-list-length l)
@@ -468,9 +482,8 @@
                            (+ 1 i)
                            (syntax-map cdr object)
                            (ellipsis-substitutions-merge bindings (map-ellipsis-binding binding)))))
-                  (merge
-                    bindings
-                    (pattern-bindings ellipsis literals p* object))))
+                  (let ((bindings* (pattern-bindings ellipsis literals p* object)))
+                    (and bindings* (merge bindings bindings*)))))
               #f)))
         (underscore (when (is-underscore underscore))
           (alist->substitutions '()))
@@ -488,8 +501,9 @@
         ((p . p*)
           (syntax-case object
             ((e . e*)
-              (merge (pattern-bindings ellipsis literals p e)
-                     (pattern-bindings ellipsis literals p* e*)))
+              (define pbindings (pattern-bindings ellipsis literals p e))
+              (define p*bindings (pattern-bindings ellipsis literals p* e*))
+              (and pbindings p*bindings (merge pbindings p*bindings)))
             (_ #f)))
         (constant
           (if (equal? (syntax->expression constant) (syntax->expression object))
@@ -581,16 +595,16 @@
         (syntax-case rules
           ('() (raise-syntax-error "form did not match any patterns in syntax-rules" object all-rules))
           ((((_ . pattern) template) . tail)
-            (let ((bindings (pattern-bindings ellipsis literals pattern (syntax-map cdr object))))
-              (if bindings
-                ; We call expand-syntax-object immediately, since macros are
-                ; allowed to be recursive.
-                (expand-syntax-object
-                  ; Each time the expander encounters a macro use, it applies an
-                  ; antimark to the input form, invokes the associated
-                  ; transformer, then applies a fresh mark to the output.
-                  (add-mark (new-mark) (expand-template ellipsis (vec) bindings template)))
-                (loop tail))))
+            (define bindings (pattern-bindings ellipsis literals pattern (syntax-map cdr object)))
+            (if bindings
+              ; We call expand-syntax-object immediately, since macros are
+              ; allowed to be recursive.
+              (expand-syntax-object
+                ; Each time the expander encounters a macro use, it applies an
+                ; antimark to the input form, invokes the associated
+                ; transformer, then applies a fresh mark to the output.
+                (add-mark (new-mark) (expand-template ellipsis (vec) bindings template)))
+              (loop tail)))
           (_ (raise-syntax-error "unexpected form in syntax-rules" all-rules)))))
 
 
@@ -599,8 +613,9 @@
         '...
         (make-environment
           (alist->substitutions
-            (list (cons '_
-                        (make-toplevel-ref '_)))))))
+            (list (cons '...
+                        (make-library-ref '... '(scheme base)))))
+          '(scheme base))))
 
 
     (define builtin-syntax-rules
@@ -639,46 +654,56 @@
         (_ (raise-syntax-error "unexpected form in split-args-rest" formals))))
 
 
-    (define (collect-defines acc body)
-      (cond
-        ((toplevel-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 (expand-lambda-body-rest body)
+      (let loop ((body body)
+                 (expanded-body (make-void)))
+        (syntax-case body
+          ('()
+            expanded-body)
+          ((expr . expr*)
+            (define expanded-expr (expand-syntax-object expr))
+            (when (or (library-define? expanded-expr)
+                      (define-syntax? expanded-expr))
+              (raise-syntax-error "define not allowed here" body))
+            (loop (syntax-map cdr body)
+                  (make-sequence expanded-body expanded-expr))))))
 
 
-    (define (fix-lambda-body body)
-      (define-values (defines rest) (collect-defines '() body))
-      (define-values (names gensyms vals) (loop for def in defines
-                                                collect (toplevel-define-name def) into names
-                                                collect (gensym) into gensyms
-                                                collect (toplevel-define-expression def) into vals
-                                                finally (return (values names gensyms vals))))
-      (if (null? names)
-        rest
-        (make-letrec
-          #t
-          names
-          gensyms
-          vals
-          rest)))
+    (define (expand-lambda-body body)
+      (let loop ((body body)
+                 (names '())
+                 (gensyms '())
+                 (expressions '()))
+        (syntax-case body
+          ('()
+            (if (null? names)
+              (make-void)
+              (make-letrec #t names gensyms expressions (make-void))))
+          ((expr . expr*)
+            (define expanded-expr (expand-syntax-object expr))
+            (cond
+              ((library-define? expanded-expr)
+                (let ((name (library-define-name expanded-expr))
+                      (g (gensym)))
+                  (loop (with-binding name (make-lexical-ref name g) (syntax-map cdr body))
+                        (cons name names)
+                        (cons g gensyms)
+                        (cons (library-define-expression expanded-expr) expressions))))
+              ((define-syntax? expanded-expr)
+                (loop (with-binding (define-syntax-name expanded-expr) (define-syntax-transformer expanded-expr) (syntax-map cdr body))
+                      names
+                      gensyms
+                      expressions))
+              (else
+                (if (null? names)
+                  (expand-lambda-body-rest body)
+                  (make-letrec #t names gensyms expressions (expand-lambda-body-rest body)))))))))
 
 
     (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
@@ -688,7 +713,7 @@
                 (if rest
                   (cons rest args)
                   args))
-              (fix-lambda-body (expand-syntax-object body))
+              (expand-lambda-body body)
               (case-lambda-helper clauses))))
         (_ (raise-syntax-error "unexpected form in case-lambda-helper" form))))
 
@@ -707,7 +732,10 @@
         (lambda (x)
           (syntax-case x
             ((_ symbol expression)
-              (make-toplevel-define (identifier-name symbol) (expand-syntax-object expression)))
+              (make-library-define
+                (identifier-name symbol)
+                (expand-syntax-object expression)
+                (environment-library (syntax-object-environment x))))
             (_ (raise-syntax-error "unexpected form in builtin-define" x))))))
 
 
@@ -715,29 +743,24 @@
       (make-environment
         (alist->substitutions
           (list (cons 'syntax-rules builtin-syntax-rules)
-                (cons '_ (make-toplevel-ref '_))
+                (cons '_ (make-library-ref '_ '(scheme base)))
+                (cons '... (make-library-ref '... '(scheme base)))
                 (cons 'builtin-let-syntax builtin-let-syntax)
                 (cons 'quote builtin-quote)
                 (cons 'case-lambda builtin-case-lambda)
-                (cons 'builtin-define builtin-define)))))
+                (cons 'builtin-define builtin-define)))
+        'main))
 
 
-    (define (expand-body environment body)
-      (loop for expr in body
+    (define (expand-body body)
+      (loop with environment = (syntax-object-environment body)
+            for expr in (syntax->expression 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))))))))
+            if (define-syntax? expanded-expr)
+              do (set! environment
+                   (add-binding
+                     (define-syntax-name expanded-expr)
+                     (define-syntax-transformer expanded-expr)
+                     environment))))))