Fix some compilation errors in the compiler.

7 files changed, 72 insertions, 15 deletions

diff --git a/csc/codegen.csc b/csc/codegen.csc
index 1fd7099..7712427 100644
--- a/csc/codegen.csc
+++ b/csc/codegen.csc
@@ -207,6 +207,9 @@
               (if (label? proc)
                 (list 'jmp (list 'label proc-temp))
                 (list 'jmp (list 'local proc-temp))))))
+        ((% %tail)
+          (list
+            (list 'jmp (list 'label 0))))
         (_ (error "Unexpected form in ir2->bytecode expr"))))
 
 
@@ -225,7 +228,7 @@
     ; Converts an IR2 program into bytecode.
     (define (ir2->ir3 expr)
       (define label-map (make-map compare-labels))
-      (define next-label-id 0)
+      (define next-label-id 1)  ; start at 1 because label 0 is used for tail.
       (define (translate-label x)
         (or (lookup label-map x #f)
             (let ((id next-label-id))
@@ -248,9 +251,9 @@
                   (set! locals-map (insert locals-map x local-count))
                   local-count)))))
       (append
+        (ir2->bytecode (fix-body expr) (make-locals-map '()))
         (loop for func in (fix-functions expr)
               collect (list 'label (translate-label (closure-name func)))
               append (ir2->bytecode (closure-body func) (make-locals-map (closure-arguments func))))
         (list
-          (list 'label 'init))
-        (ir2->bytecode (fix-body expr) (make-locals-map '()))))))
+          (list 'label 0))))))
diff --git a/csc/compiler.csc b/csc/compiler.csc
index 6bdf1ba..ee0b3b4 100644
--- a/csc/compiler.csc
+++ b/csc/compiler.csc
@@ -4,7 +4,10 @@
     compile)
   (import (scheme base)
           (only (scheme file)
+            call-with-input-file
             file-exists?)
+          (only (scheme read)
+            read)
           (only (csc codegen)
             ir2->ir3)
           (only (csc config)
@@ -17,16 +20,32 @@
           (only (csc format)
             sprintf)
           (only (csc hash-map)
+            compare-symbols
             hash-bytevector
+            insert
+            key-not-found-error?
+            lookup
             make-comparer
             make-map
             merge)
+          (only (csc ir1)
+            %define-syntax
+            %library-define
+            %library-ref
+            %sequence)
           (only (csc linker)
             link)
           (only (csc list)
             revappend)
+          (only (csc loop)
+            loop
+            return)
+          (only (csc macros)
+            expand-body)
           (only (csc match)
-            match))
+            match)
+          (only (csc strings)
+            join))
   (begin
 
 
@@ -80,7 +99,7 @@
 
 
     (define (ir1->bytecode expr)
-      (ir2->ir3 (closure-convert (ir1->ir2 expr))))
+      (ir2->ir3 (closure-convert (ir1->ir2 expr (lambda (x) *tail*)))))
 
 
     ; compile turns scheme code into bytecode.
@@ -104,8 +123,10 @@
             ('import . imports)
             ('begin . body))
 
+            (define expanded-body (expand-body library-name body env))
+
             (define env (make-import-map imports))
-            (let loop ((expr (expand-body library-name body env)))
+            (let loop ((expr expanded-body))
               (match expr
                 ((% %library-define (% %library-ref name _) val)
                   (set! env (insert env name val)))
diff --git a/csc/config.csc b/csc/config.csc
index 39268c0..d2618a7 100644
--- a/csc/config.csc
+++ b/csc/config.csc
@@ -1,5 +1,5 @@
 (define-library (csc config)
-  (export *library-search-dir*)
+  (export *standard-library-dir*)
   (import (scheme base))
   (begin
 
diff --git a/csc/cps.csc b/csc/cps.csc
index 9e1721c..cdd6611 100644
--- a/csc/cps.csc
+++ b/csc/cps.csc
@@ -56,7 +56,9 @@
             %branch
             %fix
             %primitive
+            %tail
             *globals*
+            *tail*
             branch-atom
             closure-arguments
             closure-body
@@ -69,7 +71,8 @@
             make-label
             make-label
             make-primitive
-            make-variable)
+            make-variable
+            tail?)
           (only (csc loop)
             loop
             return)
@@ -341,6 +344,8 @@
             (get-boxed false)))
         ((% %apply proc args)
           (make-ref-map))
+        ((% %tail)
+          (make-ref-map))
         ((% %fix funs body)
           (loop with m = (get-boxed body)
                 for fun in funs
@@ -404,6 +409,8 @@
                   do (set! new-expr (make-primitive 'peek (list p (make-constant 0)) (list var)
                                       new-expr))
                   finally (return new-expr)))
+          ((% %tail)
+            *tail*)
           ((% %fix funs body)
             (define-values (new-names boxed-names temp-names) (convert-arg-list (loop for fun in funs
                                                                                       collect (closure-name fun))))
@@ -468,6 +475,8 @@
                 if (free? arg)
                   do (set! m (insert m arg #t))
                 finally (return m)))
+        ((% %tail)
+          (make-ref-map))
         ((% %fix funs body)
           (loop for fun in funs
                 for name = (closure-name fun)
@@ -521,6 +530,8 @@
                   (fn (make-variable (gensym))))
               (make-primitive 'peek (list p (make-constant 0)) (list fn)
                 (make-apply fn (cons p (map translate args))))))
+          ((% %tail)
+            *tail*)
           ((% %fix functions body)
             (define frees (map free-vars functions))
             (define fn-ptrs (loop for fun in functions
diff --git a/csc/flag.csc b/csc/flag.csc
index ea699db..c328dcf 100644
--- a/csc/flag.csc
+++ b/csc/flag.csc
@@ -9,16 +9,22 @@
     parse-error?
     parse-flags)
   (import (scheme base)
+          (only (scheme process-context)
+            command-line)
           (only (csc hash-map)
             compare-strings
+            insert
             key-not-found-error?
             lookup
             make-map)
           (only (csc loop)
             loop)
+          (only (csc match)
+            match)
           (only (csc strings)
-            prefix?
-            contains?))
+            contains?
+            has-prefix?
+            split))
   (begin
 
 
@@ -94,7 +100,7 @@
                   (set! value (car args))
                   (set! args (cdr args)))
                 (unless value
-                  (raise (make-parse-flag "flag needs an argument" s)))
+                  (raise (make-parse-error "flag needs an argument" s)))
                 (parser value)))
             #t)))
       (loop while (parse-one))
diff --git a/csc/ir2.csc b/csc/ir2.csc
index 4e4c42e..800d3c0 100644
--- a/csc/ir2.csc
+++ b/csc/ir2.csc
@@ -7,8 +7,10 @@
     %globals
     %label
     %primitive
+    %tail
     %variable
     *globals*
+    *tail*
     apply-arguments
     apply-procedure
     apply?
@@ -43,6 +45,7 @@
     primitive-operation
     primitive-results
     primitive?
+    tail?
     variable-gensym
     variable?
 
@@ -180,6 +183,17 @@
       (arguments apply-arguments))
 
 
+    ; The tail continuation. Used for the exit point of library init functions,
+    ; and the end of a program.
+    (define-match-record-type <tail>
+      (make-tail)
+      tail?
+      %tail)
+
+
+    (define *tail* (make-tail))
+
+
     ; A procedure. All closures are allocated in a fix expression. A closure
     ; does not take a continuation. Instead, the procedure will accept the
     ; continuation as an argument.
diff --git a/csc/main.csc b/csc/main.csc
index a67a511..1e2cde1 100644
--- a/csc/main.csc
+++ b/csc/main.csc
@@ -2,8 +2,8 @@
         (only (scheme read)
           read)
         (only (csc compiler)
-          *library-search-dirs*)
-          compile
+          *library-search-dirs*
+          compile)
         (only (csc flag)
           *args*
           bool-flag
@@ -15,10 +15,12 @@
         (only (csc format)
           printf)
         (only (csc loop)
-          loop))
+          loop)
+        (only (csc match)
+          match))
 
 
-(define-flag *include* "include" (lambda (s) (cons s include)) '())
+(define-flag *include* "include" (lambda (s) (cons s *include*)) '())
 (define-flag *output* "output" string-copy "")
 (define-flag *help* "help" bool-flag #f)