Rewrite most of the compiler.

This represents a major step back in terms of functionality, and amount
of code. The latter I think constitutes a major win. Next steps are to
reimplement syntax-rules, call/cc, and call-with-values.

1 files changed, 0 insertions, 379 deletions

diff --git a/lib/csc/cps-test.csc b/lib/csc/cps-test.csc
deleted file mode 100644
index 256e9e3..0000000
--- a/lib/csc/cps-test.csc
+++ /dev/null
@@ -1,379 +0,0 @@
-(define-library (csc cps-test)
-  (import (scheme base)
-          (only (csc gensym)
-            gensym
-            gensym?)
-          (only (csc ir1)
-            %constant
-            %lexical-ref
-            %library-ref
-            constant?
-            lexical-ref?
-            library-ref?
-            make-call
-            make-call-builtin
-            make-constant
-            make-define-syntax
-            make-if
-            make-lambda
-            make-letrec
-            make-lexical-ref
-            make-lexical-set
-            make-library-ref
-            make-sequence)
-          (only (csc ir2)
-            %apply
-            %branch
-            %closure
-            %fix
-            %globals
-            %label
-            %primitive
-            %variable
-            *globals*
-            apply?
-            branch?
-            closure?
-            fix?
-            globals?
-            label?
-            make-apply
-            make-branch
-            make-call-closure
-            make-closure
-            make-fix
-            make-label
-            make-primitive
-            make-variable
-            primitive?
-            variable?)
-          (only (csc testing)
-            assert-equal
-            test)
-          (csc cps))
-  (begin
-
-
-    (define transform-ir2
-      (list
-        (cons constant? %constant)
-        (cons lexical-ref? %lexical-ref)
-        (cons library-ref? %library-ref)
-        (cons variable? %variable)
-        (cons globals? %globals)
-        (cons label? %label)
-        (cons primitive? %primitive)
-        (cons branch? %branch)
-        (cons apply? %apply)
-        (cons closure? %closure)
-        (cons fix? %fix)
-        (cons gensym? (lambda (x) 'gensym))))
-
-
-    (define (test-ref name)
-      (make-lexical-ref name (gensym)))
-
-
-    (define (tail x multi)
-      (make-apply (test-ref 'tail) (list x)))
-
-
-    (define generated-symbol (test-ref 'generated-symbol))
-
-
-    (test atom-const
-      (assert-equal
-        (make-apply (test-ref 'tail) (list (make-constant 5)))
-        (ir1->ir2 (make-constant 5) tail)
-        transform-ir2))
-
-
-    (test atom-lexical-ref
-      (assert-equal
-        (make-apply (test-ref 'tail) (list (test-ref 'var)))
-        (ir1->ir2 (test-ref 'var) tail)
-        transform-ir2))
-
-
-    (test atom-library-ref
-      (assert-equal
-        (make-primitive 'peek (list *globals* (make-library-ref 'var '(csc builtins))) (list generated-symbol)
-          (make-apply (test-ref 'tail) (list generated-symbol)))
-        (ir1->ir2 (make-library-ref 'var '(csc builtins)) tail)
-        transform-ir2))
-
-
-    (test lexical-set
-      (assert-equal
-        (make-primitive 'poke (list (make-constant 5) (test-ref 'var) (make-constant 0)) '()
-          (make-apply (test-ref 'tail) (list (make-constant #f))))
-        (ir1->ir2 (make-lexical-set (test-ref 'var) (make-constant 5))
-                  tail)
-        transform-ir2))
-
-
-    (test no-op-define-syntax
-      (assert-equal
-        (make-apply (test-ref 'tail) (list (make-constant #f)))
-        (ir1->ir2 (make-define-syntax 'name '(transformer))
-                  tail)
-        transform-ir2))
-
-
-    (test branch
-      (assert-equal
-        (make-fix
-          (list
-            (make-closure generated-symbol (list generated-symbol)
-              (make-apply (test-ref 'tail) (list generated-symbol))))
-          (make-branch (make-constant #t)
-            (make-primitive 'cons (list (make-constant 1) (make-constant '())) (list generated-symbol)
-              (make-apply generated-symbol (list generated-symbol)))
-            (make-primitive 'cons (list (make-constant 2) (make-constant '())) (list generated-symbol)
-              (make-apply generated-symbol (list generated-symbol)))))
-        (ir1->ir2 (make-if (make-constant #t)
-                    (make-constant 1)
-                    (make-constant 2))
-                  tail)
-        transform-ir2))
-
-
-    (test call-closure
-      (assert-equal
-        (make-fix
-          (list
-            (make-closure generated-symbol (list generated-symbol)
-              (make-apply (test-ref 'tail) (list generated-symbol))))
-          (make-primitive 'cons (list (make-constant 20) (make-constant '())) (list generated-symbol)
-            (make-primitive 'cons (list (make-constant 10) generated-symbol) (list generated-symbol)
-              (make-apply (test-ref 'f) (list generated-symbol generated-symbol)))))
-        (ir1->ir2 (make-call (test-ref 'f) (list (make-constant 10) (make-constant 20)))
-                  tail)
-        transform-ir2))
-
-
-    (test call-builtin-alloc
-      (assert-equal
-        (make-primitive 'alloc (list (make-constant 10)) (list generated-symbol)
-          (make-apply (test-ref 'tail) (list generated-symbol)))
-        (ir1->ir2 (make-call-builtin 'alloc (list (make-constant 10))) tail)
-        transform-ir2))
-
-
-    (test call-builtin-peek
-      (assert-equal
-        (make-primitive 'alloc (list (make-constant 1)) (list generated-symbol)
-          (make-primitive 'peek (list generated-symbol (make-constant 0)) (list generated-symbol)
-            (make-apply (test-ref 'tail) (list generated-symbol))))
-        (ir1->ir2
-          (make-call-builtin 'peek (list (make-call-builtin 'alloc (list (make-constant 1))) (make-constant 0)))
-          tail)
-        transform-ir2))
-
-
-    (test call-builtin-poke
-      (assert-equal
-        (make-primitive 'alloc (list (make-constant 1)) (list generated-symbol)
-          (make-primitive 'poke (list (make-constant 10) generated-symbol (make-constant 0)) '()
-            (make-apply (test-ref 'tail) (list (make-constant #f)))))
-        (ir1->ir2
-          (make-call-builtin 'poke (list (make-constant 10)
-                                         (make-call-builtin 'alloc (list (make-constant 1)))
-                                         (make-constant 0)))
-          tail)
-        transform-ir2))
-
-
-    (test sequence
-      (assert-equal
-        (make-primitive 'poke (list (make-constant 5) (test-ref 'a) (make-constant 0)) '()
-          (make-primitive 'poke (list (make-constant 6) (test-ref 'b) (make-constant 0)) '()
-            (make-apply (test-ref 'tail) (list (make-constant #f)))))
-        (ir1->ir2 (make-sequence (make-lexical-set (test-ref 'a) (make-constant 5))
-                                 (make-lexical-set (test-ref 'b) (make-constant 6)))
-                  tail)
-        transform-ir2))
-
-
-    (test closure
-      (assert-equal
-        (make-fix
-          (list (make-closure generated-symbol (list generated-symbol (test-ref 'c))
-                  (make-primitive 'cons (list (make-constant 5) (make-constant '())) (list generated-symbol)
-                    (make-apply generated-symbol (list generated-symbol)))))
-          (make-apply (test-ref 'tail) (list generated-symbol)))
-        (ir1->ir2 (make-lambda
-                    (test-ref 'c)
-                    (make-constant 5))
-                  tail)
-        transform-ir2))
-
-
-    (test letrec-functions
-      (define x (test-ref 'x))
-      (define f (gensym))
-      (assert-equal
-        (make-fix
-          (list
-            (make-closure (test-ref 'f) (list generated-symbol (test-ref 'x))
-              (make-primitive 'cons (list (test-ref 'x) (make-constant '())) (list generated-symbol)
-                (make-apply generated-symbol (list generated-symbol)))))
-          (make-fix
-            (list
-              (make-closure generated-symbol (list generated-symbol)
-                (make-apply (test-ref 'tail) (list generated-symbol))))
-            (make-primitive 'cons (list (make-constant 10) (make-constant '())) (list generated-symbol)
-              (make-apply (test-ref 'f) (list generated-symbol generated-symbol)))))
-        (ir1->ir2
-          (make-letrec #f '(f) (list f)
-                       (list (make-lambda x x))
-            (make-call (make-lexical-ref 'f f) (list (make-constant 10))))
-          tail)
-        transform-ir2))
-
-
-    (test letrec-in-order
-      (define a (gensym))
-      (define b (gensym))
-      (assert-equal
-        (make-primitive 'alloc (list (make-constant 1)) (list (test-ref 'b))
-          (make-primitive 'alloc (list (make-constant 1)) (list (test-ref 'a))
-            (make-primitive 'poke (list (make-constant 1) (test-ref 'a) (make-constant 0)) '()
-              (make-primitive 'poke (list (test-ref 'a) (test-ref 'b) (make-constant 0)) '()
-                (make-apply (test-ref 'tail) (list (test-ref 'b)))))))
-        (ir1->ir2
-          (make-letrec #t
-            '(a b)
-            (list a (gensym))
-            (list (make-constant 1)
-                  (make-lexical-ref 'a a))
-            (make-lexical-ref 'b b))
-          tail)
-        transform-ir2))
-
-
-    (test letrec-in-order-function
-      (assert-equal
-        (make-fix
-          (list
-            (make-closure (test-ref 'f) (list generated-symbol (test-ref 'args))
-              (make-primitive 'cons (list (make-constant 5) (make-constant '())) (list generated-symbol)
-                (make-apply generated-symbol (list generated-symbol)))))
-          (make-apply (test-ref 'tail) (list (make-constant 10))))
-        (ir1->ir2
-          (make-letrec #t
-            '(f)
-            (list (gensym))
-            (list (make-lambda (test-ref 'args) (make-constant 5)))
-            (make-constant 10))
-          tail)
-        transform-ir2))
-
-
-    ; What does the following letrec return?
-    ; (letrec* ((f (lambda () x))
-    ;           (x (f)))
-    ;   x)
-    (test letrec-very-cool
-      (define f (gensym))
-      (define x (gensym))
-      (assert-equal
-        (make-primitive 'alloc (list (make-constant 1)) (list (test-ref 'x))
-          (make-fix
-            (list
-              (make-closure (test-ref 'f) (list generated-symbol (test-ref 'args))
-                (make-primitive 'peek (list (test-ref 'x) (make-constant 0)) (list generated-symbol)
-                  (make-primitive 'cons (list generated-symbol (make-constant '())) (list generated-symbol)
-                    (make-apply generated-symbol (list generated-symbol))))))
-            (make-fix
-              (list
-                (make-closure generated-symbol (list generated-symbol)
-                  (make-primitive 'assert-singleton (list generated-symbol) (list generated-symbol)
-                    (make-primitive 'poke (list generated-symbol (test-ref 'x) (make-constant 0)) '()
-                      (make-primitive 'peek (list (test-ref 'x) (make-constant 0)) (list generated-symbol)
-                        (make-apply (test-ref 'tail) (list generated-symbol)))))))
-              (make-apply (test-ref 'f) (list generated-symbol (make-constant '()))))))
-        (ir1->ir2
-          (make-letrec #t
-            '(f x)
-            (list f x)
-            (list (make-lambda (test-ref 'args) (make-lexical-ref 'x x))
-                  (make-call (make-lexical-ref 'f f) '()))
-            (make-lexical-ref 'x x))
-          tail)
-        transform-ir2))
-
-
-    (test set-argument
-      (define test-sym (gensym))
-      (assert-equal
-        (make-fix
-          (list
-            (make-closure (test-ref 'f) (list generated-symbol generated-symbol)
-              (make-primitive 'alloc (list (make-constant 1)) (list (test-ref 'args))
-                (make-primitive 'poke (list generated-symbol (test-ref 'args) (make-constant 0)) '()
-                  (make-primitive 'poke (list (make-constant 10) (test-ref 'args) (make-constant 0)) '()
-                    (make-primitive 'cons (list (make-constant #f) (make-constant '())) (list generated-symbol)
-                      (make-apply generated-symbol (list generated-symbol))))))))
-          (make-apply (test-ref 'tail) (list (make-constant 5))))
-        (ir1->ir2 (make-letrec
-                    #f
-                    '(f)
-                    (list (gensym))
-                    (list (make-lambda (make-lexical-ref 'args test-sym)
-                            (make-lexical-set (make-lexical-ref 'args test-sym) (make-constant 10))))
-                    (make-constant 5))
-                  tail)
-        transform-ir2))
-
-    (test set-function
-      (define test-sym (gensym))
-      (assert-equal
-        (make-primitive 'alloc (list (make-constant 1)) (list (test-ref 'f))
-          (make-fix
-            (list (make-closure generated-symbol (list generated-symbol (test-ref 'args))
-                    (make-primitive 'cons (list (make-constant 10) (make-constant '())) (list generated-symbol)
-                      (make-apply generated-symbol (list generated-symbol)))))
-            (make-primitive 'poke (list generated-symbol (test-ref 'f) (make-constant 0)) '()
-              (make-primitive 'poke (list (make-constant 5) (test-ref 'f) (make-constant 0)) '()
-                (make-apply (test-ref 'tail) (list (make-constant #f)))))))
-        (ir1->ir2 (make-letrec
-                    #f
-                    '(f)
-                    (list test-sym)
-                    (list (make-lambda (test-ref 'args) (make-constant 10)))
-                    (make-lexical-set (make-lexical-ref 'f test-sym) (make-constant 5)))
-                  tail)
-        transform-ir2))
-
-
-    (define (test-var)
-      (make-variable (gensym)))
-
-
-    (test closure-convert-primitive
-      (define a-sym (gensym))
-      (define f-sym (gensym))
-      (define ret-sym (gensym))
-      (define x-sym (gensym))
-      (assert-equal
-        (make-fix
-          (list (make-closure (make-label (gensym)) (list (test-var) (test-var) (test-var))
-                  (make-primitive 'peek (list (test-var) (make-constant 0)) (list (test-var))
-                    (make-primitive 'poke (list (test-var) (test-var) (make-constant 0)) '()
-                      (make-primitive 'peek (list (test-var) (make-constant 0)) (list (test-var))
-                        (make-apply (test-var) (list (test-var) (make-constant #f))))))))
-          (make-primitive 'alloc (list (make-constant 1)) (list (test-var))
-            (make-primitive 'alloc (list (make-constant 2)) (list (test-var))
-              (make-primitive 'poke (list (make-label (gensym)) (test-var) (make-constant 0)) '()
-                (make-primitive 'poke (list (test-var) (test-var) (make-constant 1)) '()
-                  (make-primitive 'peek (list (test-var) (make-constant 0)) (list (test-var))
-                    (make-apply (test-var) (list (test-var) (make-library-ref 'tail '(csc builtins)) (make-constant 10)))))))))
-        (closure-convert (make-primitive 'alloc (list (make-constant 1)) (list (make-lexical-ref 'a a-sym))
-                           (make-fix
-                             (list
-                               (make-closure (make-lexical-ref 'f f-sym) (list (make-lexical-ref 'ret ret-sym) (make-lexical-ref 'x x-sym))
-                                 (make-primitive 'poke (list (make-lexical-ref 'x x-sym) (make-lexical-ref 'a a-sym) (make-constant 0)) '()
-                                   (make-apply (make-lexical-ref 'ret ret-sym) (list (make-constant #f))))))
-                             (make-apply (make-lexical-ref 'f f-sym) (list (make-library-ref 'tail '(csc builtins)) (make-constant 10))))))
-        transform-ir2))))