diff options
Diffstat (limited to 'lib/csc/cps-test.csc')
| -rw-r--r-- | lib/csc/cps-test.csc | 379 |
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)))) |