Write the compiler frontend.

4 files changed, 186 insertions, 54 deletions

diff --git a/csc/compiler.csc b/csc/compiler.csc
new file mode 100644
index 0000000..5486344
--- /dev/null
+++ b/csc/compiler.csc
@@ -0,0 +1,89 @@
+(define-library (csc compiler)
+  (import (scheme base)
+          (only (csc hash-map)
+            hash-bytevector
+            insert
+            key-not-found-error?
+            lookup
+            make-map
+            map-for-each
+            merge)
+          (only (csc ir1)
+            toplevel-define?)
+          (only (csc loop)
+            loop
+            return)
+          (only (csc macros)
+            builtins-environment
+            expand)
+          (only (csc match) match))
+  (begin
+
+
+    (define (hash-symbol s)
+      (hash-bytevector (string->utf8 (symbol->string s))))
+
+
+    (define (cmp-symbol s1 s2)
+      (string<? (symbol->string s1) (symbol->string s2)))
+
+
+    (define-record-type <syntax-error>
+      (make-syntax-error msg irritants)
+      syntax-error?)
+
+
+    (define (raise-syntax-error msg . irritants)
+      (raise (make-syntax-error msg irritants)))
+
+
+    (define (parse-import-set expr)
+      (match expr
+        (((! 'only) import-set . idents)
+          (loop with bindings = (parse-import-set import-set)
+                and new-bindings = (make-map hash-symbol cmp-symbol)
+                for ident in idents
+                do (set! new-bindings
+                     (insert new-bindings
+                       ident
+                       (guard (e ((key-not-found-error? e) (raise-syntax-error "unknown symbol in `only' form" ident)))
+                         (lookup bindings ident))))
+                finally (return new-bindings)))
+        ((! '(csc builtins))
+          builtins-environment)
+        (_ (raise-syntax-error "unknown or unsupported import set form" expr))))
+          
+
+
+    (define (parse-import expr)
+      (match expr
+        (((! 'import) . import-sets)
+          (loop with bindings = (make-map hash-symbol cmp-symbol)
+                for import-set in import-sets
+                do (set! bindings
+                     (merge bindings (parse-import-set import-set)))
+                finally (return bindings)))
+        (_ (raise-syntax-error "expected import form" expr))))
+
+
+    (define-record-type <program>
+      (make-program imports body)
+      program?
+      (imports program-imports)
+      (body program-body))
+
+
+    ; A Scheme program consists of one or more import declarations
+    ; followed by a sequence of expressions and definitions.
+    ;   -- R7RS
+    (define (program->ir1 program)
+      (loop with bindings = (make-map hash-symbol cmp-symbol)
+            for body on program
+            for expr = (car body)
+            do (match expr
+                 (((! 'import) . import-sets)
+                   (set! bindings
+                     (merge bindings (parse-import expr))))
+                 (_ (loop for expr in body
+                          for expanded-expr = (expand expr bindings)
+                          if (toplevel-define? expanded-expr)
diff --git a/csc/ir1.csc b/csc/ir1.csc
index 1365891..334f870 100644
--- a/csc/ir1.csc
+++ b/csc/ir1.csc
@@ -9,6 +9,7 @@
     if-consequent
     if-test
     if?
+    import?
     lambda-body
     lambda-case-alternate
     lambda-case-arguments
@@ -30,15 +31,6 @@
     lexical-set-gensym
     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-call
     make-constant
     make-if
@@ -47,8 +39,6 @@
     make-letrec
     make-lexical-ref
     make-lexical-set
-    make-library-ref
-    make-library-set
     make-sequence
     make-toplevel-define
     make-void
@@ -102,31 +92,6 @@
       (expression lexical-set-expression))
 
 
-    ; <library-ref> library name public?
-    ; A reference to a variable in a specific library. library should be the name
-    ; of the library, e.g. (scheme base).
-    ;
-    ; If public? is true, name will be looked up in library's public interface,
-    ; otherwise it will be looked up among the library's private bindings.
-    (define-record-type <library-ref>
-      (make-library-ref library name public?)
-      library-ref?
-      (library library-ref-library)
-      (name library-ref-name)
-      (public? library-ref-public?))
-
-
-    ; <library-set> library name public? expression
-    ; Sets a variable in a specific library.
-    (define-record-type <library-set>
-      (make-library-set library name public? expression)
-      library-set?
-      (library library-set-library)
-      (name library-set-name)
-      (public? library-set-public?)
-      (expression library-set-expression))
-
-
     ; <toplevel-define> name expression
     ; Defines a new variable in the current library.
     (define-record-type <toplevel-define>
diff --git a/csc/macros-test.csc b/csc/macros-test.csc
index 4cc8efa..6529e58 100644
--- a/csc/macros-test.csc
+++ b/csc/macros-test.csc
@@ -1,15 +1,88 @@
 (import (scheme base)
-        (only (csc ir1) make-constant)
+        (only (csc ir1)
+          constant-expression
+          constant?
+          lexical-ref-name
+          lexical-ref?
+          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
+          void?)
         (only (csc testing)
           assert-equal
           test)
         (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
     (make-constant '(test 1 2 3))
-    (expand '(quote (test 1 2 3)) test-environment)))
+    (expand '(quote (test 1 2 3)) builtins-environment)))
 
 
 (test builtin-syntax-rules-literal
@@ -24,7 +97,7 @@
              ((foo b)
                1)))
          (foo b))
-      test-environment)))
+      builtins-environment)))
 
 
 (test builtin-syntax-rules-underscore
@@ -36,7 +109,7 @@
            (syntax-rules ()
              ((foo _) 0)))
          (foo ignored))
-      test-environment)))
+      builtins-environment)))
 
 
 (test builtin-syntax-rules-substitution
@@ -48,7 +121,7 @@
            (syntax-rules ()
              ((foo x) x)))
          (foo 5))
-      test-environment)))
+      builtins-environment)))
 
 
 (test builtin-syntax-rules-nil
@@ -61,7 +134,7 @@
              ((foo x) 0)
              ((foo) 1)))
          (foo))
-      test-environment)))
+      builtins-environment)))
 
 
 (test builtin-syntax-rules-improper-list
@@ -73,7 +146,7 @@
            (syntax-rules ()
              ((foo a . b) a)))
          (foo 1 2 3))
-      test-environment)))
+      builtins-environment)))
 
 
 (test builtin-syntax-rules-quoted
@@ -85,7 +158,7 @@
            (syntax-rules ()
              ((foo x) (quote x))))
          (foo a))
-      test-environment)))
+      builtins-environment)))
 
 
 (test builtin-syntax-rules-constant
@@ -99,7 +172,7 @@
              ((foo "def") 1)
              ((foo "ghi") 2)))
          (foo "ghi"))
-      test-environment)))
+      builtins-environment)))
 
 
 (test builtin-syntax-rules-ellipsis
@@ -111,7 +184,7 @@
            (syntax-rules ()
              ((foo x ...) (x ...))))
          (foo quote 5))
-      test-environment)))
+      builtins-environment)))
 
 
 (test builtin-syntax-rules-ellipsis-improper
@@ -123,7 +196,7 @@
            (syntax-rules ()
              ((foo x ... . y) (x ... y))))
          (foo quote . 5))
-      test-environment)))
+      builtins-environment)))
 
 
 (test builtin-syntax-rules-ellipsis-zip
@@ -136,7 +209,7 @@
              ((zip (x ...) (y ...))
                (quote ((x . y) ...)))))
          (zip (1 2) (3 4)))
-      test-environment)))
+      builtins-environment)))
 
 
 (test builtin-syntax-rules-ellipsis-nested
@@ -149,7 +222,7 @@
              ((append (x ...) ...)
                (quote (x ... ...)))))
          (append (1 2) (3 4) () (5)))
-      test-environment)))
+      builtins-environment)))
 
 
 (test builtin-syntax-rules-ellipsis-custom
@@ -161,4 +234,9 @@
            (syntax-rules ::: ()
              ((foo x :::) (x :::))))
          (foo quote 5))
-      test-environment)))
+      builtins-environment)))
+
+
+(test builtin-lambda-simple
+  (assert-equal
+    (make-lambda
diff --git a/csc/macros.csc b/csc/macros.csc
index df8bc73..e59973b 100644
--- a/csc/macros.csc
+++ b/csc/macros.csc
@@ -1,7 +1,8 @@
 (define-library (csc macros)
   (export
     expand
-    test-environment)
+    macro-syntax-error?
+    builtins-environment)
   (import (scheme base)
           (only (csc assert) assert)
           (only (csc format) sprintf)
@@ -320,8 +321,7 @@
 
     ; expand can be thought of as a compiler from Scheme to IR1. Macros
     ; included in the environment can be used to extend the syntax. Returns an
-    ; IR1 expression and an environment which has been modified with any new
-    ; bindings introduced by the expression.
+    ; IR1 expression.
     (define (expand expression environment)
       (expand-syntax-object (wrap-syntax expression environment)))
 
@@ -724,7 +724,7 @@
             (_ (raise-syntax-error "unexpected form in case-lambda" x))))))
 
 
-    (define test-environment
+    (define builtins-environment
       (make-environment
         (alist->substitutions
           (list (cons 'syntax-rules builtin-syntax-rules)