diff options
| author | Rose Hogenson <rhogenson@posteo.net> | 2022-07-26 19:24:10 -0700 |
|---|---|---|
| committer | Rose Hogenson <rhogenson@posteo.net> | 2022-07-26 19:24:10 -0700 |
| commit | becfaeb778a3c8ba241e2155b998d6b27dcfad0c (patch) | |
| tree | 97ca02178660fe958026a707905eac1c5ebd188d /csc | |
| parent | b8ed2e52cd7decd56b195df5363fcc0f17cc3805 (diff) | |
| download | chromatopelma-becfaeb778a3c8ba241e2155b998d6b27dcfad0c.tar.zst | |
Fix a potential R7RS issue.
I was using the load procedure to load a program, but by a strict
reading of R7RS, load can only handle expressions and definitions, not
imports. So instead I'm defining each test as a library, and using the
environment procedure to load them at runtime.
Diffstat (limited to 'csc')
| -rw-r--r-- | csc/assert-test.csc | 28 | ||||
| -rw-r--r-- | csc/codegen-test.csc | 234 | ||||
| -rw-r--r-- | csc/compare-test.csc | 76 | ||||
| -rw-r--r-- | csc/cps-test.csc | 860 | ||||
| -rw-r--r-- | csc/encoding-test.csc | 164 | ||||
| -rw-r--r-- | csc/format-test.csc | 30 | ||||
| -rw-r--r-- | csc/hash-map-test.csc | 232 | ||||
| -rw-r--r-- | csc/linker-test.csc | 128 | ||||
| -rw-r--r-- | csc/list-test.csc | 136 | ||||
| -rw-r--r-- | csc/loop-test.csc | 434 | ||||
| -rw-r--r-- | csc/macros-test.csc | 456 | ||||
| -rw-r--r-- | csc/match-test.csc | 176 | ||||
| -rw-r--r-- | csc/sort-test.csc | 48 | ||||
| -rw-r--r-- | csc/strings-test.csc | 118 | ||||
| -rw-r--r-- | csc/test-main.csc | 16 | ||||
| -rw-r--r-- | csc/vec-test.csc | 40 |
16 files changed, 1608 insertions, 1568 deletions
diff --git a/csc/assert-test.csc b/csc/assert-test.csc index 4341ac7..4e8d2d3 100644 --- a/csc/assert-test.csc +++ b/csc/assert-test.csc @@ -1,14 +1,14 @@ -(import (scheme base) - (only (csc testing) - assert-raises - test) - (csc assert)) - - -(test assert-raises - (assert-raises error-object? - (assert #f))) - - -(test assert-ok - (assert #t)) +(define-library (csc assert-test) + (import (scheme base) + (only (csc testing) + assert-raises + test) + (csc assert)) + (begin + (test assert-raises + (assert-raises error-object? + (assert #f))) + + + (test assert-ok + (assert #t)))) diff --git a/csc/codegen-test.csc b/csc/codegen-test.csc index 03f6b11..ef1c88b 100644 --- a/csc/codegen-test.csc +++ b/csc/codegen-test.csc @@ -1,130 +1,132 @@ -(import (scheme base) - (only (csc gensym) - gensym) - (only (csc ir2) - *globals* - make-apply - make-branch - make-closure - make-constant - make-fix - make-label - make-library-ref - make-primitive - make-variable) - (only (csc loop) - loop - return) - (only (csc match) - match) - (only (csc testing) - assert-equal - test) - (csc codegen)) +(define-library (csc codegen-test) + (import (scheme base) + (only (csc gensym) + gensym) + (only (csc ir2) + *globals* + make-apply + make-branch + make-closure + make-constant + make-fix + make-label + make-library-ref + make-primitive + make-variable) + (only (csc loop) + loop + return) + (only (csc match) + match) + (only (csc testing) + assert-equal + test) + (csc codegen)) + (begin -(define (test-var) - (make-variable (gensym))) + (define (test-var) + (make-variable (gensym))) -(define (test-label) - (make-label (gensym))) + (define (test-label) + (make-label (gensym))) -(test codegen-apply - (define p (test-var)) - (assert-equal - '((label init) - (peek (local 1) (local 0) (const 5)) - (mov (local 2) (local 1)) - (mov (local 1) (const 10)) - (jmp (local 2))) - (ir2->ir3 - (make-fix '() - (make-primitive 'peek (list *globals* (make-constant 5)) (list p) - (make-apply p (list (make-constant 10)))))))) + (test codegen-apply + (define p (test-var)) + (assert-equal + '((label init) + (peek (local 1) (local 0) (const 5)) + (mov (local 2) (local 1)) + (mov (local 1) (const 10)) + (jmp (local 2))) + (ir2->ir3 + (make-fix '() + (make-primitive 'peek (list *globals* (make-constant 5)) (list p) + (make-apply p (list (make-constant 10)))))))) -(test codegen-call-global - (define p (test-var)) - (assert-equal - '((label init) - (peek (local 1) (local 0) (global cons (csc based))) - (mov (local 3) (local 1)) - (mov (local 1) (const 5)) - (mov (local 2) (const ())) - (jmp (local 3))) - (ir2->ir3 - (make-fix '() - (make-primitive 'peek (list *globals* (make-library-ref 'cons '(csc based))) (list p) - (make-apply p (list (make-constant 5) (make-constant '())))))))) + (test codegen-call-global + (define p (test-var)) + (assert-equal + '((label init) + (peek (local 1) (local 0) (global cons (csc based))) + (mov (local 3) (local 1)) + (mov (local 1) (const 5)) + (mov (local 2) (const ())) + (jmp (local 3))) + (ir2->ir3 + (make-fix '() + (make-primitive 'peek (list *globals* (make-library-ref 'cons '(csc based))) (list p) + (make-apply p (list (make-constant 5) (make-constant '())))))))) -(test codegen-call-known - (define f (test-label)) - (define ret (test-var)) - (assert-equal - '((label 0) - (mov (local 2) (local 1)) - (jmp (local 2)) - (label init) - (mov (local 1) (label 0)) - (jmp (label 0))) - (ir2->ir3 - (make-fix - (list (make-closure f (list ret) - (make-apply ret (list ret)))) - (make-apply f (list f)))))) + (test codegen-call-known + (define f (test-label)) + (define ret (test-var)) + (assert-equal + '((label 0) + (mov (local 2) (local 1)) + (jmp (local 2)) + (label init) + (mov (local 1) (label 0)) + (jmp (label 0))) + (ir2->ir3 + (make-fix + (list (make-closure f (list ret) + (make-apply ret (list ret)))) + (make-apply f (list f)))))) -(test codegen-permute - (define f (test-label)) - (define g (test-label)) - (define f1 (test-var)) - (define f2 (test-var)) - (define g1 (test-var)) - (define g2 (test-var)) - (define g3 (test-var)) - (assert-equal - '((label 0) - (mov (local 127) (local 1)) - (mov (local 1) (local 2)) - (mov (local 2) (local 127)) - (mov (local 3) (const 0)) - (jmp (label 1)) - (label 1) - (mov (local 2) (local 1)) - (mov (local 1) (local 3)) - (jmp (label 0)) - (label init) - (mov (local 1) (const 0)) - (mov (local 2) (const 1)) - (jmp (label 0))) - (ir2->ir3 - (make-fix - (list (make-closure f (list f1 f2) - (make-apply g (list f2 f1 (make-constant 0)))) - (make-closure g (list g1 g2 g3) - (make-apply f (list g3 g1)))) - (make-apply f (list (make-constant 0) (make-constant 1))))))) + (test codegen-permute + (define f (test-label)) + (define g (test-label)) + (define f1 (test-var)) + (define f2 (test-var)) + (define g1 (test-var)) + (define g2 (test-var)) + (define g3 (test-var)) + (assert-equal + '((label 0) + (mov (local 127) (local 1)) + (mov (local 1) (local 2)) + (mov (local 2) (local 127)) + (mov (local 3) (const 0)) + (jmp (label 1)) + (label 1) + (mov (local 2) (local 1)) + (mov (local 1) (local 3)) + (jmp (label 0)) + (label init) + (mov (local 1) (const 0)) + (mov (local 2) (const 1)) + (jmp (label 0))) + (ir2->ir3 + (make-fix + (list (make-closure f (list f1 f2) + (make-apply g (list f2 f1 (make-constant 0)))) + (make-closure g (list g1 g2 g3) + (make-apply f (list g3 g1)))) + (make-apply f (list (make-constant 0) (make-constant 1))))))) -(test codegen-branch - (define p (test-var)) - (assert-equal - '((label init) - (peek (local 1) (local 0) (const 1)) - (jmpif (const #t) (label 0)) - (mov (local 2) (local 1)) - (mov (local 1) (const 10)) - (jmp (local 2)) - (label 0) - (mov (local 2) (local 1)) - (mov (local 1) (const 5)) - (jmp (local 2))) - (ir2->ir3 - (make-fix '() - (make-primitive 'peek (list *globals* (make-constant 1)) (list p) - (make-branch (make-constant #t) - (make-apply p (list (make-constant 5))) - (make-apply p (list (make-constant 10))))))))) + (test codegen-branch + (define p (test-var)) + (assert-equal + '((label init) + (peek (local 1) (local 0) (const 1)) + (jmpif (const #t) (label 0)) + (mov (local 2) (local 1)) + (mov (local 1) (const 10)) + (jmp (local 2)) + (label 0) + (mov (local 2) (local 1)) + (mov (local 1) (const 5)) + (jmp (local 2))) + (ir2->ir3 + (make-fix '() + (make-primitive 'peek (list *globals* (make-constant 1)) (list p) + (make-branch (make-constant #t) + (make-apply p (list (make-constant 5))) + (make-apply p (list (make-constant 10))))))))))) diff --git a/csc/compare-test.csc b/csc/compare-test.csc index 379f21b..b710115 100644 --- a/csc/compare-test.csc +++ b/csc/compare-test.csc @@ -1,16 +1,18 @@ -(import (scheme base) - (only (csc match) - define-match-record-type) - (only (csc testing) - assert - test) - (csc compare)) +(define-library (csc compare-test) + (import (scheme base) + (only (csc match) + define-match-record-type) + (only (csc testing) + assert + test) + (csc compare)) + (begin -(test diff-list - (assert - (string=? - " ( + (test diff-list + (assert + (string=? + " ( 1 - 2 3 @@ -18,21 +20,21 @@ 4 ) " - (diff '(1 2 3 4) '(1 3 3.5 4))))) + (diff '(1 2 3 4) '(1 3 3.5 4))))) -(define-match-record-type <test-type> - (make-test-type a b) - test-type? - %test-type - (a test-type-a) - (b test-type-b)) + (define-match-record-type <test-type> + (make-test-type a b) + test-type? + %test-type + (a test-type-a) + (b test-type-b)) -(test diff-record - (assert - (string=? - " ( + (test diff-record + (assert + (string=? + " ( (!type . <test-type> ) @@ -45,13 +47,13 @@ ) ) " - (diff (make-test-type 5 5) (make-test-type 5 6) (cons test-type? %test-type))))) + (diff (make-test-type 5 5) (make-test-type 5 6) (cons test-type? %test-type))))) -(test diff-multiline-string - (assert - (string=? - " ( + (test diff-multiline-string + (assert + (string=? + " ( (!type . string ) @@ -64,12 +66,12 @@ ) ) " - (diff "line-one\nline-two\nline-three" "line-one\nline-three")))) + (diff "line-one\nline-two\nline-three" "line-one\nline-three")))) -(test diff-vector - (assert - (string=? + (test diff-vector + (assert + (string=? " ( (!type . vector @@ -83,14 +85,14 @@ ) ) " - (diff #(1 2 3) #(1 3))))) + (diff #(1 2 3) #(1 3))))) -(test diff-symbol-list - (assert - (string=? - "- symbol + (test diff-symbol-list + (assert + (string=? + "- symbol + ( + ) " - (diff 'symbol '())))) + (diff 'symbol '())))))) diff --git a/csc/cps-test.csc b/csc/cps-test.csc index 98823f0..6439d78 100644 --- a/csc/cps-test.csc +++ b/csc/cps-test.csc @@ -1,498 +1,500 @@ -(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)) +(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 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 (test-ref name) + (make-lexical-ref name (gensym))) -(define (tail x) - (make-apply (test-ref 'tail) (list x))) + (define (tail x) + (make-apply (test-ref 'tail) (list x))) -(test atom-const - (assert-equal - (make-apply (test-ref 'tail) (list (make-constant 5))) - (ir1->ir2 (make-constant 5) tail) - transform-ir2)) + (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-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 (test-ref 'generated-symbol)) - (make-apply (test-ref 'tail) (list (test-ref 'generated-symbol)))) - (ir1->ir2 (make-library-ref 'var '(csc builtins)) tail) - transform-ir2)) + (test atom-library-ref + (assert-equal + (make-primitive 'peek (list *globals* (make-library-ref 'var '(csc builtins))) (list (test-ref 'generated-symbol)) + (make-apply (test-ref 'tail) (list (test-ref '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 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 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 (test-ref 'generated-symbol) (list (test-ref 'generated-symbol)) - (make-apply (test-ref 'tail) (list (test-ref 'generated-symbol))))) - (make-branch (make-constant #t) - (make-apply (test-ref 'generated-symbol) (list (make-constant 1))) - (make-apply (test-ref 'generated-symbol) (list (make-constant 2))))) - (ir1->ir2 (make-if (make-constant #t) - (make-constant 1) - (make-constant 2)) - tail) - transform-ir2)) + (test branch + (assert-equal + (make-fix + (list + (make-closure (test-ref 'generated-symbol) (list (test-ref 'generated-symbol)) + (make-apply (test-ref 'tail) (list (test-ref 'generated-symbol))))) + (make-branch (make-constant #t) + (make-apply (test-ref 'generated-symbol) (list (make-constant 1))) + (make-apply (test-ref 'generated-symbol) (list (make-constant 2))))) + (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 (test-ref 'generated-symbol) (list (test-ref 'generated-symbol)) - (make-apply (test-ref 'tail) (list (test-ref 'generated-symbol))))) - (make-fix - (list (make-closure (test-ref 'generated-symbol) (list (test-ref 'generated-symbol) (test-ref 'generated-symbol)) - (make-primitive 'poke (list (make-constant 0) (test-ref 'generated-symbol) (make-constant 0)) '() - (make-primitive 'poke (list (make-constant 2) (test-ref 'generated-symbol) (make-constant 1)) '() - (make-primitive 'poke (list (make-constant 10) (test-ref 'generated-symbol) (make-constant 2)) '() - (make-primitive 'poke (list (make-constant 20) (test-ref 'generated-symbol) (make-constant 3)) '() - (make-fix - (list (make-closure (test-ref 'generated-symbol) (list (test-ref 'generated-symbol)) - (make-apply (test-ref 'generated-symbol) (list (test-ref 'generated-symbol))))) - (make-apply (test-ref 'f) (list (test-ref 'generated-symbol) (test-ref 'generated-symbol)))))))))) - (make-primitive 'alloc (list (make-constant 4)) (list (test-ref 'generated-symbol)) - (make-apply (test-ref 'generated-symbol) (list (test-ref 'generated-symbol) (test-ref 'generated-symbol)))))) - (ir1->ir2 (make-call (test-ref 'f) (list (make-constant 10) (make-constant 20))) - tail) - transform-ir2)) + (test call-closure + (assert-equal + (make-fix + (list + (make-closure (test-ref 'generated-symbol) (list (test-ref 'generated-symbol)) + (make-apply (test-ref 'tail) (list (test-ref 'generated-symbol))))) + (make-fix + (list (make-closure (test-ref 'generated-symbol) (list (test-ref 'generated-symbol) (test-ref 'generated-symbol)) + (make-primitive 'poke (list (make-constant 0) (test-ref 'generated-symbol) (make-constant 0)) '() + (make-primitive 'poke (list (make-constant 2) (test-ref 'generated-symbol) (make-constant 1)) '() + (make-primitive 'poke (list (make-constant 10) (test-ref 'generated-symbol) (make-constant 2)) '() + (make-primitive 'poke (list (make-constant 20) (test-ref 'generated-symbol) (make-constant 3)) '() + (make-fix + (list (make-closure (test-ref 'generated-symbol) (list (test-ref 'generated-symbol)) + (make-apply (test-ref 'generated-symbol) (list (test-ref 'generated-symbol))))) + (make-apply (test-ref 'f) (list (test-ref 'generated-symbol) (test-ref 'generated-symbol)))))))))) + (make-primitive 'alloc (list (make-constant 4)) (list (test-ref 'generated-symbol)) + (make-apply (test-ref 'generated-symbol) (list (test-ref 'generated-symbol) (test-ref '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 (test-ref 'generated-symbol)) - (make-apply (test-ref 'tail) (list (test-ref 'generated-symbol)))) - (ir1->ir2 (make-call-builtin 'alloc (list (make-constant 10))) tail) - transform-ir2)) + (test call-builtin-alloc + (assert-equal + (make-primitive 'alloc (list (make-constant 10)) (list (test-ref 'generated-symbol)) + (make-apply (test-ref 'tail) (list (test-ref '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 (test-ref 'generated-symbol)) - (make-primitive 'peek (list (test-ref 'generated-symbol) (make-constant 0)) (list (test-ref 'generated-symbol)) - (make-apply (test-ref 'tail) (list (test-ref '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-peek + (assert-equal + (make-primitive 'alloc (list (make-constant 1)) (list (test-ref 'generated-symbol)) + (make-primitive 'peek (list (test-ref 'generated-symbol) (make-constant 0)) (list (test-ref 'generated-symbol)) + (make-apply (test-ref 'tail) (list (test-ref '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 (test-ref 'generated-symbol)) - (make-primitive 'poke (list (make-constant 10) (test-ref '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 call-builtin-poke + (assert-equal + (make-primitive 'alloc (list (make-constant 1)) (list (test-ref 'generated-symbol)) + (make-primitive 'poke (list (make-constant 10) (test-ref '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 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)) -; It's pretty bad -(test closure-rest - (assert-equal - (make-fix - (list (make-closure (test-ref 'generated-symbol) - (list (test-ref 'generated-symbol) (test-ref 'generated-symbol)) - (make-primitive 'peek (list (test-ref 'generated-symbol) (make-constant 1)) (list (test-ref 'generated-symbol)) - (make-primitive 'int<? (list (test-ref 'generated-symbol) (make-constant 0)) (list (test-ref 'generated-symbol)) - (make-fix (list (make-closure (test-ref 'generated-symbol) - (list (test-ref 'generated-symbol)) - (make-apply (test-ref 'generated-symbol) (list (test-ref 'generated-symbol))))) - (make-branch (test-ref 'generated-symbol) - (make-fix (list (make-closure (test-ref 'generated-symbol) - (list (test-ref 'generated-symbol)) - (make-apply (test-ref 'generated-symbol) (list (test-ref 'generated-symbol))))) - (make-primitive 'peek (list *globals* (make-library-ref 'wrong-number-of-arguments '(csc based))) (list (test-ref 'generated-symbol)) - (make-apply (test-ref 'generated-symbol) - (list (test-ref 'generated-symbol) (test-ref 'generated-symbol))))) + ; It's pretty bad + (test closure-rest + (assert-equal + (make-fix + (list (make-closure (test-ref 'generated-symbol) + (list (test-ref 'generated-symbol) (test-ref 'generated-symbol)) + (make-primitive 'peek (list (test-ref 'generated-symbol) (make-constant 1)) (list (test-ref 'generated-symbol)) + (make-primitive 'int<? (list (test-ref 'generated-symbol) (make-constant 0)) (list (test-ref 'generated-symbol)) (make-fix (list (make-closure (test-ref 'generated-symbol) (list (test-ref 'generated-symbol)) (make-apply (test-ref 'generated-symbol) (list (test-ref 'generated-symbol))))) - (make-fix - (list (make-closure (test-ref 'generated-symbol) (list (test-ref 'generated-symbol) (test-ref 'c)) - (make-apply (test-ref 'generated-symbol) (list (make-constant 5))))) - (make-fix - (list (make-closure (test-ref 'generated-symbol) (list (test-ref 'generated-symbol)) - (make-apply (test-ref 'generated-symbol) (list (test-ref 'generated-symbol) (test-ref 'generated-symbol))))) + (make-branch (test-ref 'generated-symbol) + (make-fix (list (make-closure (test-ref 'generated-symbol) + (list (test-ref 'generated-symbol)) + (make-apply (test-ref 'generated-symbol) (list (test-ref 'generated-symbol))))) + (make-primitive 'peek (list *globals* (make-library-ref 'wrong-number-of-arguments '(csc based))) (list (test-ref 'generated-symbol)) + (make-apply (test-ref 'generated-symbol) + (list (test-ref 'generated-symbol) (test-ref 'generated-symbol))))) + (make-fix (list (make-closure (test-ref 'generated-symbol) + (list (test-ref 'generated-symbol)) + (make-apply (test-ref 'generated-symbol) (list (test-ref 'generated-symbol))))) (make-fix - (list (make-closure (test-ref 'generated-symbol) (list (test-ref 'generated-symbol) (test-ref 'generated-symbol)) - (make-primitive 'poke (list (make-constant 0) (test-ref 'generated-symbol) (make-constant 0)) '() - (make-primitive 'poke (list (make-constant 2) (test-ref 'generated-symbol) (make-constant 1)) '() - (make-primitive 'poke (list (test-ref 'generated-symbol) (test-ref 'generated-symbol) (make-constant 2)) '() - (make-primitive 'poke (list (make-constant 0) (test-ref 'generated-symbol) (make-constant 3)) '() - (make-fix - (list (make-closure (test-ref 'generated-symbol) (list (test-ref 'generated-symbol)) - (make-apply (test-ref 'generated-symbol) (list (test-ref 'generated-symbol))))) - (make-primitive 'peek (list *globals* (make-library-ref 'vector->list '(csc based))) (list (test-ref 'generated-symbol)) - (make-apply (test-ref 'generated-symbol) (list (test-ref 'generated-symbol) (test-ref 'generated-symbol))))))))))) - (make-primitive 'alloc (list (make-constant 4)) (list (test-ref 'generated-symbol)) - (make-apply (test-ref 'generated-symbol) (list (test-ref 'generated-symbol) (test-ref 'generated-symbol)))))))))))))) - (make-apply (test-ref 'tail) (list (test-ref 'generated-symbol)))) - (ir1->ir2 (make-lambda - '() - (test-ref 'c) - (make-constant 5)) - tail) - transform-ir2)) + (list (make-closure (test-ref 'generated-symbol) (list (test-ref 'generated-symbol) (test-ref 'c)) + (make-apply (test-ref 'generated-symbol) (list (make-constant 5))))) + (make-fix + (list (make-closure (test-ref 'generated-symbol) (list (test-ref 'generated-symbol)) + (make-apply (test-ref 'generated-symbol) (list (test-ref 'generated-symbol) (test-ref 'generated-symbol))))) + (make-fix + (list (make-closure (test-ref 'generated-symbol) (list (test-ref 'generated-symbol) (test-ref 'generated-symbol)) + (make-primitive 'poke (list (make-constant 0) (test-ref 'generated-symbol) (make-constant 0)) '() + (make-primitive 'poke (list (make-constant 2) (test-ref 'generated-symbol) (make-constant 1)) '() + (make-primitive 'poke (list (test-ref 'generated-symbol) (test-ref 'generated-symbol) (make-constant 2)) '() + (make-primitive 'poke (list (make-constant 0) (test-ref 'generated-symbol) (make-constant 3)) '() + (make-fix + (list (make-closure (test-ref 'generated-symbol) (list (test-ref 'generated-symbol)) + (make-apply (test-ref 'generated-symbol) (list (test-ref 'generated-symbol))))) + (make-primitive 'peek (list *globals* (make-library-ref 'vector->list '(csc based))) (list (test-ref 'generated-symbol)) + (make-apply (test-ref 'generated-symbol) (list (test-ref 'generated-symbol) (test-ref 'generated-symbol))))))))))) + (make-primitive 'alloc (list (make-constant 4)) (list (test-ref 'generated-symbol)) + (make-apply (test-ref 'generated-symbol) (list (test-ref 'generated-symbol) (test-ref 'generated-symbol)))))))))))))) + (make-apply (test-ref 'tail) (list (test-ref '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 (test-ref 'generated-symbol) (test-ref 'generated-symbol)) - (make-primitive 'peek (list (test-ref 'generated-symbol) (make-constant 1)) (list (test-ref 'generated-symbol)) - (make-primitive 'int=? (list (test-ref 'generated-symbol) (make-constant 1)) (list (test-ref 'generated-symbol)) - (make-fix - (list (make-closure (test-ref 'generated-symbol) (list (test-ref 'generated-symbol)) - (make-apply (test-ref 'generated-symbol) (list (test-ref 'generated-symbol))))) - (make-branch (test-ref 'generated-symbol) - (make-fix - (list (make-closure (test-ref 'generated-symbol) (list (test-ref 'generated-symbol)) - (make-apply (test-ref 'generated-symbol) (list (test-ref 'generated-symbol))))) - (make-fix - (list (make-closure (test-ref 'generated-symbol) (list (test-ref 'generated-symbol) (test-ref 'x)) - (make-apply (test-ref 'generated-symbol) (list (test-ref 'x))))) - (make-primitive 'peek (list (test-ref 'generated-symbol) (make-constant 2)) (list (test-ref 'generated-symbol)) - (make-apply (test-ref 'generated-symbol) (list (test-ref 'generated-symbol) (test-ref 'generated-symbol)))))) - (make-fix - (list (make-closure (test-ref 'generated-symbol) (list (test-ref 'generated-symbol)) - (make-apply (test-ref 'generated-symbol) (list (test-ref 'generated-symbol))))) - (make-primitive 'peek (list *globals* (make-library-ref 'wrong-number-of-arguments '(csc based))) (list (test-ref 'generated-symbol)) - (make-apply (test-ref 'generated-symbol) (list (test-ref 'generated-symbol) (test-ref 'generated-symbol))))))))))) - (make-fix - (list - (make-closure (test-ref 'generated-symbol) (list (test-ref 'generated-symbol)) - (make-apply (test-ref 'tail) (list (test-ref 'generated-symbol))))) + (test letrec-functions + (define x (test-ref 'x)) + (define f (gensym)) + (assert-equal (make-fix - (list (make-closure (test-ref 'generated-symbol) (list (test-ref 'generated-symbol) (test-ref 'generated-symbol)) - (make-primitive 'poke (list (make-constant 0) (test-ref 'generated-symbol) (make-constant 0)) '() - (make-primitive 'poke (list (make-constant 1) (test-ref 'generated-symbol) (make-constant 1)) '() - (make-primitive 'poke (list (make-constant 10) (test-ref 'generated-symbol) (make-constant 2)) '() - (make-fix - (list (make-closure (test-ref 'generated-symbol) (list (test-ref 'generated-symbol)) - (make-apply (test-ref 'generated-symbol) (list (test-ref 'generated-symbol))))) - (make-apply (test-ref 'f) (list (test-ref 'generated-symbol) (test-ref 'generated-symbol))))))))) - (make-primitive 'alloc (list (make-constant 3)) (list (test-ref 'generated-symbol)) - (make-apply (test-ref 'generated-symbol) (list (test-ref 'generated-symbol) (test-ref 'generated-symbol))))))) - (ir1->ir2 - (make-letrec #f '(f) (list f) - (list (make-lambda (list x) #f 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 (test-ref 'generated-symbol) (test-ref 'generated-symbol)) + (list + (make-closure (test-ref 'f) (list (test-ref 'generated-symbol) (test-ref 'generated-symbol)) (make-primitive 'peek (list (test-ref 'generated-symbol) (make-constant 1)) (list (test-ref 'generated-symbol)) - (make-primitive 'int=? (list (test-ref 'generated-symbol) (make-constant 0)) (list (test-ref 'generated-symbol)) + (make-primitive 'int=? (list (test-ref 'generated-symbol) (make-constant 1)) (list (test-ref 'generated-symbol)) (make-fix (list (make-closure (test-ref 'generated-symbol) (list (test-ref 'generated-symbol)) (make-apply (test-ref 'generated-symbol) (list (test-ref 'generated-symbol))))) (make-branch (test-ref 'generated-symbol) - (make-apply (test-ref 'generated-symbol) (list (make-constant 5))) + (make-fix + (list (make-closure (test-ref 'generated-symbol) (list (test-ref 'generated-symbol)) + (make-apply (test-ref 'generated-symbol) (list (test-ref 'generated-symbol))))) + (make-fix + (list (make-closure (test-ref 'generated-symbol) (list (test-ref 'generated-symbol) (test-ref 'x)) + (make-apply (test-ref 'generated-symbol) (list (test-ref 'x))))) + (make-primitive 'peek (list (test-ref 'generated-symbol) (make-constant 2)) (list (test-ref 'generated-symbol)) + (make-apply (test-ref 'generated-symbol) (list (test-ref 'generated-symbol) (test-ref 'generated-symbol)))))) (make-fix (list (make-closure (test-ref 'generated-symbol) (list (test-ref 'generated-symbol)) (make-apply (test-ref 'generated-symbol) (list (test-ref 'generated-symbol))))) (make-primitive 'peek (list *globals* (make-library-ref 'wrong-number-of-arguments '(csc based))) (list (test-ref 'generated-symbol)) (make-apply (test-ref 'generated-symbol) (list (test-ref 'generated-symbol) (test-ref 'generated-symbol))))))))))) - (make-apply (test-ref 'tail) (list (make-constant 10)))) - (ir1->ir2 - (make-letrec #t - '(f) - (list (gensym)) - (list (make-lambda '() #f (make-constant 5))) - (make-constant 10)) - tail) - transform-ir2)) + (make-fix + (list + (make-closure (test-ref 'generated-symbol) (list (test-ref 'generated-symbol)) + (make-apply (test-ref 'tail) (list (test-ref 'generated-symbol))))) + (make-fix + (list (make-closure (test-ref 'generated-symbol) (list (test-ref 'generated-symbol) (test-ref 'generated-symbol)) + (make-primitive 'poke (list (make-constant 0) (test-ref 'generated-symbol) (make-constant 0)) '() + (make-primitive 'poke (list (make-constant 1) (test-ref 'generated-symbol) (make-constant 1)) '() + (make-primitive 'poke (list (make-constant 10) (test-ref 'generated-symbol) (make-constant 2)) '() + (make-fix + (list (make-closure (test-ref 'generated-symbol) (list (test-ref 'generated-symbol)) + (make-apply (test-ref 'generated-symbol) (list (test-ref 'generated-symbol))))) + (make-apply (test-ref 'f) (list (test-ref 'generated-symbol) (test-ref 'generated-symbol))))))))) + (make-primitive 'alloc (list (make-constant 3)) (list (test-ref 'generated-symbol)) + (make-apply (test-ref 'generated-symbol) (list (test-ref 'generated-symbol) (test-ref 'generated-symbol))))))) + (ir1->ir2 + (make-letrec #f '(f) (list f) + (list (make-lambda (list x) #f x)) + (make-call (make-lexical-ref 'f f) (list (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 (test-ref 'generated-symbol) (test-ref 'generated-symbol)) - (make-primitive 'peek (list (test-ref 'generated-symbol) (make-constant 1)) (list (test-ref 'generated-symbol)) - (make-primitive 'int=? (list (test-ref 'generated-symbol) (make-constant 0)) (list (test-ref 'generated-symbol)) - (make-fix - (list (make-closure (test-ref 'generated-symbol) (list (test-ref 'generated-symbol)) - (make-apply (test-ref 'generated-symbol) (list (test-ref 'generated-symbol))))) - (make-branch (test-ref 'generated-symbol) - (make-primitive 'peek (list (test-ref 'x) (make-constant 0)) (list (test-ref 'generated-symbol)) - (make-apply (test-ref 'generated-symbol) (list (test-ref 'generated-symbol)))) + (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 (test-ref 'generated-symbol) (test-ref 'generated-symbol)) + (make-primitive 'peek (list (test-ref 'generated-symbol) (make-constant 1)) (list (test-ref 'generated-symbol)) + (make-primitive 'int=? (list (test-ref 'generated-symbol) (make-constant 0)) (list (test-ref 'generated-symbol)) + (make-fix + (list (make-closure (test-ref 'generated-symbol) (list (test-ref 'generated-symbol)) + (make-apply (test-ref 'generated-symbol) (list (test-ref 'generated-symbol))))) + (make-branch (test-ref 'generated-symbol) + (make-apply (test-ref 'generated-symbol) (list (make-constant 5))) + (make-fix + (list (make-closure (test-ref 'generated-symbol) (list (test-ref 'generated-symbol)) + (make-apply (test-ref 'generated-symbol) (list (test-ref 'generated-symbol))))) + (make-primitive 'peek (list *globals* (make-library-ref 'wrong-number-of-arguments '(csc based))) (list (test-ref 'generated-symbol)) + (make-apply (test-ref 'generated-symbol) (list (test-ref 'generated-symbol) (test-ref 'generated-symbol))))))))))) + (make-apply (test-ref 'tail) (list (make-constant 10)))) + (ir1->ir2 + (make-letrec #t + '(f) + (list (gensym)) + (list (make-lambda '() #f (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 (test-ref 'generated-symbol) (test-ref 'generated-symbol)) + (make-primitive 'peek (list (test-ref 'generated-symbol) (make-constant 1)) (list (test-ref 'generated-symbol)) + (make-primitive 'int=? (list (test-ref 'generated-symbol) (make-constant 0)) (list (test-ref 'generated-symbol)) (make-fix (list (make-closure (test-ref 'generated-symbol) (list (test-ref 'generated-symbol)) (make-apply (test-ref 'generated-symbol) (list (test-ref 'generated-symbol))))) - (make-primitive 'peek (list *globals* (make-library-ref 'wrong-number-of-arguments '(csc based))) (list (test-ref 'generated-symbol)) - (make-apply (test-ref 'generated-symbol) (list (test-ref 'generated-symbol) (test-ref 'generated-symbol))))))))))) - (make-fix - (list - (make-closure (test-ref 'generated-symbol) (list (test-ref 'generated-symbol)) - (make-primitive 'poke (list (test-ref 'generated-symbol) (test-ref 'x) (make-constant 0)) '() - (make-primitive 'peek (list (test-ref 'x) (make-constant 0)) (list (test-ref 'generated-symbol)) - (make-apply (test-ref 'tail) (list (test-ref 'generated-symbol))))))) - (make-fix - (list (make-closure (test-ref 'generated-symbol) (list (test-ref 'generated-symbol) (test-ref 'generated-symbol)) - (make-primitive 'poke (list (make-constant 0) (test-ref 'generated-symbol) (make-constant 0)) '() - (make-primitive 'poke (list (make-constant 0) (test-ref 'generated-symbol) (make-constant 1)) '() + (make-branch (test-ref 'generated-symbol) + (make-primitive 'peek (list (test-ref 'x) (make-constant 0)) (list (test-ref 'generated-symbol)) + (make-apply (test-ref 'generated-symbol) (list (test-ref 'generated-symbol)))) (make-fix (list (make-closure (test-ref 'generated-symbol) (list (test-ref 'generated-symbol)) (make-apply (test-ref 'generated-symbol) (list (test-ref 'generated-symbol))))) - (make-apply (test-ref 'f) (list (test-ref 'generated-symbol) (test-ref 'generated-symbol)))))))) - (make-primitive 'alloc (list (make-constant 2)) (list (test-ref 'generated-symbol)) - (make-apply (test-ref 'generated-symbol) (list (test-ref 'generated-symbol) (test-ref 'generated-symbol)))))))) - (ir1->ir2 - (make-letrec #t - '(f x) - (list f x) - (list (make-lambda '() #f (make-lexical-ref 'x x)) - (make-call (make-lexical-ref 'f f) '())) - (make-lexical-ref 'x x)) - tail) - transform-ir2)) + (make-primitive 'peek (list *globals* (make-library-ref 'wrong-number-of-arguments '(csc based))) (list (test-ref 'generated-symbol)) + (make-apply (test-ref 'generated-symbol) (list (test-ref 'generated-symbol) (test-ref 'generated-symbol))))))))))) + (make-fix + (list + (make-closure (test-ref 'generated-symbol) (list (test-ref 'generated-symbol)) + (make-primitive 'poke (list (test-ref 'generated-symbol) (test-ref 'x) (make-constant 0)) '() + (make-primitive 'peek (list (test-ref 'x) (make-constant 0)) (list (test-ref 'generated-symbol)) + (make-apply (test-ref 'tail) (list (test-ref 'generated-symbol))))))) + (make-fix + (list (make-closure (test-ref 'generated-symbol) (list (test-ref 'generated-symbol) (test-ref 'generated-symbol)) + (make-primitive 'poke (list (make-constant 0) (test-ref 'generated-symbol) (make-constant 0)) '() + (make-primitive 'poke (list (make-constant 0) (test-ref 'generated-symbol) (make-constant 1)) '() + (make-fix + (list (make-closure (test-ref 'generated-symbol) (list (test-ref 'generated-symbol)) + (make-apply (test-ref 'generated-symbol) (list (test-ref 'generated-symbol))))) + (make-apply (test-ref 'f) (list (test-ref 'generated-symbol) (test-ref 'generated-symbol)))))))) + (make-primitive 'alloc (list (make-constant 2)) (list (test-ref 'generated-symbol)) + (make-apply (test-ref 'generated-symbol) (list (test-ref 'generated-symbol) (test-ref 'generated-symbol)))))))) + (ir1->ir2 + (make-letrec #t + '(f x) + (list f x) + (list (make-lambda '() #f (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 (test-ref 'generated-symbol) - (test-ref 'generated-symbol)) - (make-primitive 'peek (list (test-ref 'generated-symbol) (make-constant 1)) (list (test-ref 'generated-symbol)) - (make-primitive 'int=? (list (test-ref 'generated-symbol) (make-constant 1)) (list (test-ref 'generated-symbol)) - (make-fix - (list (make-closure (test-ref 'generated-symbol) (list (test-ref 'generated-symbol)) - (make-apply (test-ref 'generated-symbol) (list (test-ref 'generated-symbol))))) - (make-branch (test-ref 'generated-symbol) - (make-fix - (list (make-closure (test-ref 'generated-symbol) (list (test-ref 'generated-symbol)) - (make-apply (test-ref 'generated-symbol) (list (test-ref 'generated-symbol))))) - (make-fix - (list (make-closure (test-ref 'generated-symbol) (list (test-ref 'generated-symbol) (test-ref 'generated-symbol)) - (make-primitive 'alloc (list (make-constant 1)) (list (test-ref 'x)) - (make-primitive 'poke (list (test-ref 'generated-symbol) (test-ref 'x) (make-constant 0)) '() - (make-primitive 'poke (list (make-constant 10) (test-ref 'x) (make-constant 0)) '() - (make-apply (test-ref 'generated-symbol) (list (make-constant #f)))))))) - (make-primitive 'peek (list (test-ref 'generated-symbol) (make-constant 2)) (list (test-ref 'generated-symbol)) - (make-apply (test-ref 'generated-symbol) (list (test-ref 'generated-symbol) (test-ref 'generated-symbol)))))) + (test set-argument + (define test-sym (gensym)) + (assert-equal + (make-fix + (list + (make-closure (test-ref 'f) (list (test-ref 'generated-symbol) + (test-ref 'generated-symbol)) + (make-primitive 'peek (list (test-ref 'generated-symbol) (make-constant 1)) (list (test-ref 'generated-symbol)) + (make-primitive 'int=? (list (test-ref 'generated-symbol) (make-constant 1)) (list (test-ref 'generated-symbol)) (make-fix (list (make-closure (test-ref 'generated-symbol) (list (test-ref 'generated-symbol)) (make-apply (test-ref 'generated-symbol) (list (test-ref 'generated-symbol))))) - (make-primitive 'peek (list *globals* (make-library-ref 'wrong-number-of-arguments '(csc based))) (list (test-ref 'generated-symbol)) - (make-apply (test-ref 'generated-symbol) (list (test-ref 'generated-symbol) (test-ref 'generated-symbol))))))))))) - (make-apply (test-ref 'tail) (list (make-constant 5)))) - (ir1->ir2 (make-letrec - #f - '(f) - (list (gensym)) - (list (make-lambda (list (make-lexical-ref 'x test-sym)) #f - (make-lexical-set (make-lexical-ref 'x test-sym) (make-constant 10)))) - (make-constant 5)) - tail) - transform-ir2)) + (make-branch (test-ref 'generated-symbol) + (make-fix + (list (make-closure (test-ref 'generated-symbol) (list (test-ref 'generated-symbol)) + (make-apply (test-ref 'generated-symbol) (list (test-ref 'generated-symbol))))) + (make-fix + (list (make-closure (test-ref 'generated-symbol) (list (test-ref 'generated-symbol) (test-ref 'generated-symbol)) + (make-primitive 'alloc (list (make-constant 1)) (list (test-ref 'x)) + (make-primitive 'poke (list (test-ref 'generated-symbol) (test-ref 'x) (make-constant 0)) '() + (make-primitive 'poke (list (make-constant 10) (test-ref 'x) (make-constant 0)) '() + (make-apply (test-ref 'generated-symbol) (list (make-constant #f)))))))) + (make-primitive 'peek (list (test-ref 'generated-symbol) (make-constant 2)) (list (test-ref 'generated-symbol)) + (make-apply (test-ref 'generated-symbol) (list (test-ref 'generated-symbol) (test-ref 'generated-symbol)))))) + (make-fix + (list (make-closure (test-ref 'generated-symbol) (list (test-ref 'generated-symbol)) + (make-apply (test-ref 'generated-symbol) (list (test-ref 'generated-symbol))))) + (make-primitive 'peek (list *globals* (make-library-ref 'wrong-number-of-arguments '(csc based))) (list (test-ref 'generated-symbol)) + (make-apply (test-ref 'generated-symbol) (list (test-ref 'generated-symbol) (test-ref 'generated-symbol))))))))))) + (make-apply (test-ref 'tail) (list (make-constant 5)))) + (ir1->ir2 (make-letrec + #f + '(f) + (list (gensym)) + (list (make-lambda (list (make-lexical-ref 'x test-sym)) #f + (make-lexical-set (make-lexical-ref 'x 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 (test-ref 'generated-symbol) (list (test-ref 'generated-symbol) (test-ref 'generated-symbol)) - (make-primitive 'peek (list (test-ref 'generated-symbol) (make-constant 1)) (list (test-ref 'generated-symbol)) - (make-primitive 'int=? (list (test-ref 'generated-symbol) (make-constant 0)) (list (test-ref 'generated-symbol)) - (make-fix - (list (make-closure (test-ref 'generated-symbol) (list (test-ref 'generated-symbol)) - (make-apply (test-ref 'generated-symbol) (list (test-ref 'generated-symbol))))) - (make-branch (test-ref 'generated-symbol) - (make-apply (test-ref 'generated-symbol) (list (make-constant 10))) + (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 (test-ref 'generated-symbol) (list (test-ref 'generated-symbol) (test-ref 'generated-symbol)) + (make-primitive 'peek (list (test-ref 'generated-symbol) (make-constant 1)) (list (test-ref 'generated-symbol)) + (make-primitive 'int=? (list (test-ref 'generated-symbol) (make-constant 0)) (list (test-ref 'generated-symbol)) (make-fix (list (make-closure (test-ref 'generated-symbol) (list (test-ref 'generated-symbol)) (make-apply (test-ref 'generated-symbol) (list (test-ref 'generated-symbol))))) - (make-primitive 'peek (list *globals* (make-library-ref 'wrong-number-of-arguments '(csc based))) (list (test-ref 'generated-symbol)) - (make-apply (test-ref 'generated-symbol) (list (test-ref 'generated-symbol) (test-ref 'generated-symbol))))))))))) - (make-primitive 'poke (list (test-ref '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 '() #f (make-constant 10))) - (make-lexical-set (make-lexical-ref 'f test-sym) (make-constant 5))) - tail) - transform-ir2)) + (make-branch (test-ref 'generated-symbol) + (make-apply (test-ref 'generated-symbol) (list (make-constant 10))) + (make-fix + (list (make-closure (test-ref 'generated-symbol) (list (test-ref 'generated-symbol)) + (make-apply (test-ref 'generated-symbol) (list (test-ref 'generated-symbol))))) + (make-primitive 'peek (list *globals* (make-library-ref 'wrong-number-of-arguments '(csc based))) (list (test-ref 'generated-symbol)) + (make-apply (test-ref 'generated-symbol) (list (test-ref 'generated-symbol) (test-ref 'generated-symbol))))))))))) + (make-primitive 'poke (list (test-ref '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 '() #f (make-constant 10))) + (make-lexical-set (make-lexical-ref 'f test-sym) (make-constant 5))) + tail) + transform-ir2)) -(define (test-var) - (make-variable (gensym))) + (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-primitive 'alloc (list (make-constant 1)) (list (test-var)) - (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)) '() + (test closure-convert-primitive + (define a-sym (gensym)) + (define f-sym (gensym)) + (define ret-sym (gensym)) + (define x-sym (gensym)) + (assert-equal + (make-primitive 'alloc (list (make-constant 1)) (list (test-var)) + (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-apply (test-var) (list (test-var) (make-constant #f)))))))) - (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)) + (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 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)))) diff --git a/csc/encoding-test.csc b/csc/encoding-test.csc index fb9fe21..7a96c51 100644 --- a/csc/encoding-test.csc +++ b/csc/encoding-test.csc @@ -1,119 +1,121 @@ -(import (scheme base) - (only (csc testing) - assert-equal - test) - (csc encoding)) +(define-library (csc encoding-test) + (import (scheme base) + (only (csc testing) + assert-equal + test) + (csc encoding)) + (begin -(test encode-mov - (assert-equal - #u8(0 1 2) - (encode '((mov (local 1) (local 2)))))) + (test encode-mov + (assert-equal + #u8(0 1 2) + (encode '((mov (local 1) (local 2)))))) -(test encode-int - (assert-equal - #u8(2 1 #x15 0 0 0 0 0 0 0) - (encode '((mov (local 1) (const 10)))))) + (test encode-int + (assert-equal + #u8(2 1 #x15 0 0 0 0 0 0 0) + (encode '((mov (local 1) (const 10)))))) -(test encode-negative-int - (assert-equal - #u8(2 1 #xed #xff #xff #xff #xff #xff #xff #xff) - (encode '((mov (local 1) (const -10)))))) + (test encode-negative-int + (assert-equal + #u8(2 1 #xed #xff #xff #xff #xff #xff #xff #xff) + (encode '((mov (local 1) (const -10)))))) -(test encode-true - (assert-equal - #u8(2 1 #xa 0 0 0 0 0 0 0) - (encode '((mov (local 1) (const #t)))))) + (test encode-true + (assert-equal + #u8(2 1 #xa 0 0 0 0 0 0 0) + (encode '((mov (local 1) (const #t)))))) -(test encode-false - (assert-equal - #u8(2 1 #x2 0 0 0 0 0 0 0) - (encode '((mov (local 1) (const #f)))))) + (test encode-false + (assert-equal + #u8(2 1 #x2 0 0 0 0 0 0 0) + (encode '((mov (local 1) (const #f)))))) -(test encode-nil - (assert-equal - #u8(2 1 #x12 0 0 0 0 0 0 0) - (encode '((mov (local 1) (const ())))))) + (test encode-nil + (assert-equal + #u8(2 1 #x12 0 0 0 0 0 0 0) + (encode '((mov (local 1) (const ())))))) -(test encode-jmpif - (assert-equal - #u8(4 1 2) - (encode '((jmpif (local 1) (local 2)))))) + (test encode-jmpif + (assert-equal + #u8(4 1 2) + (encode '((jmpif (local 1) (local 2)))))) -(test encode-jmp - (assert-equal - #u8(8 1) - (encode '((jmp (local 1)))))) + (test encode-jmp + (assert-equal + #u8(8 1) + (encode '((jmp (local 1)))))) -(test encode-alloc - (assert-equal - #u8(12 1 2) - (encode '((alloc (local 1) (local 2)))))) + (test encode-alloc + (assert-equal + #u8(12 1 2) + (encode '((alloc (local 1) (local 2)))))) -(test encode-peek - (assert-equal - #u8(17 1 2 1 0 0 0 0 0 0 0) - (encode '((peek (local 1) (local 2) (const 0)))))) + (test encode-peek + (assert-equal + #u8(17 1 2 1 0 0 0 0 0 0 0) + (encode '((peek (local 1) (local 2) (const 0)))))) -(test encode-poke - (assert-equal - #u8(23 #x15 0 0 0 0 0 0 0 1 1 0 0 0 0 0 0 0) - (encode '((poke (const 10) (local 1) (const 0)))))) + (test encode-poke + (assert-equal + #u8(23 #x15 0 0 0 0 0 0 0 1 1 0 0 0 0 0 0 0) + (encode '((poke (const 10) (local 1) (const 0)))))) -(test encode-add - (assert-equal - #u8(24 1 2 3) - (encode '((add (local 1) (local 2) (local 3)))))) + (test encode-add + (assert-equal + #u8(24 1 2 3) + (encode '((add (local 1) (local 2) (local 3)))))) -(test encode-sub - (assert-equal - #u8(28 1 2 3) - (encode '((sub (local 1) (local 2) (local 3)))))) + (test encode-sub + (assert-equal + #u8(28 1 2 3) + (encode '((sub (local 1) (local 2) (local 3)))))) -(test encode-mul - (assert-equal - #u8(32 1 2 3) - (encode '((mul (local 1) (local 2) (local 3)))))) + (test encode-mul + (assert-equal + #u8(32 1 2 3) + (encode '((mul (local 1) (local 2) (local 3)))))) -(test encode-div - (assert-equal - #u8(36 1 2 3) - (encode '((div (local 1) (local 2) (local 3)))))) + (test encode-div + (assert-equal + #u8(36 1 2 3) + (encode '((div (local 1) (local 2) (local 3)))))) -(test encode-mod - (assert-equal - #u8(40 1 2 3) - (encode '((mod (local 1) (local 2) (local 3)))))) + (test encode-mod + (assert-equal + #u8(40 1 2 3) + (encode '((mod (local 1) (local 2) (local 3)))))) -(test encode-peekbyte - (assert-equal - #u8(44 1 2 3) - (encode '((peekbyte (local 1) (local 2) (local 3)))))) + (test encode-peekbyte + (assert-equal + #u8(44 1 2 3) + (encode '((peekbyte (local 1) (local 2) (local 3)))))) -(test encode-pokebyte - (assert-equal - #u8(48 1 2 3) - (encode '((pokebyte (local 1) (local 2) (local 3)))))) + (test encode-pokebyte + (assert-equal + #u8(48 1 2 3) + (encode '((pokebyte (local 1) (local 2) (local 3)))))) -(test encode-exit - (assert-equal - #u8(52) - (encode '((exit))))) + (test encode-exit + (assert-equal + #u8(52) + (encode '((exit))))))) diff --git a/csc/format-test.csc b/csc/format-test.csc index 6efaa87..1906af6 100644 --- a/csc/format-test.csc +++ b/csc/format-test.csc @@ -1,24 +1,26 @@ -(import (scheme base) - (only (csc strings) str-quote) - (only (csc testing) assert-equal test) - (csc format)) +(define-library (csc format-test) + (import (scheme base) + (only (csc strings) str-quote) + (only (csc testing) assert-equal test) + (csc format)) + (begin -(test sprintf-single-string - (assert-equal "test-string" (sprintf "test-string"))) + (test sprintf-single-string + (assert-equal "test-string" (sprintf "test-string"))) -(test sprintf-list - (assert-equal "(1 2 3)" (sprintf "{}" '(1 2 3)))) + (test sprintf-list + (assert-equal "(1 2 3)" (sprintf "{}" '(1 2 3)))) -(test sprintf-complex - (assert-equal "this (1 2 3) is 1 a bbb test" (sprintf "this {} is {} a {} test" '(1 2 3) 1 "bbb"))) + (test sprintf-complex + (assert-equal "this (1 2 3) is 1 a bbb test" (sprintf "this {} is {} a {} test" '(1 2 3) 1 "bbb"))) -(test sprintf-escape-open - (assert-equal "{" (sprintf "{{"))) + (test sprintf-escape-open + (assert-equal "{" (sprintf "{{"))) -(test sprintf-escape-close - (assert-equal "}" (sprintf "}}"))) + (test sprintf-escape-close + (assert-equal "}" (sprintf "}}"))))) diff --git a/csc/hash-map-test.csc b/csc/hash-map-test.csc index 10edc26..6f83c30 100644 --- a/csc/hash-map-test.csc +++ b/csc/hash-map-test.csc @@ -1,153 +1,155 @@ -(import (scheme base) - (only (csc format) - sprintf) - (only (csc loop) - loop - return) - (only (csc sort) sort) - (only (csc testing) - assert-equal - assert-raises - test) - (csc hash-map)) +(define-library (csc hash-map-test) + (import (scheme base) + (only (csc format) + sprintf) + (only (csc loop) + loop + return) + (only (csc sort) sort) + (only (csc testing) + assert-equal + assert-raises + test) + (csc hash-map)) + (begin -(define transform-map - (list - (cons map? map->alist) - (cons list? (lambda (l) (sort (lambda (x y) (string<? (symbol->string (car x)) (symbol->string (car y)))) l))))) + (define transform-map + (list + (cons map? map->alist) + (cons list? (lambda (l) (sort (lambda (x y) (string<? (symbol->string (car x)) (symbol->string (car y)))) l))))) -(test alist->map-singleton - (assert-equal - '((a . 1)) - (alist->map compare-symbols '((a . 1))) - transform-map)) + (test alist->map-singleton + (assert-equal + '((a . 1)) + (alist->map compare-symbols '((a . 1))) + transform-map)) -(test alist->map-two - (assert-equal - '((a . 1) (b . 2)) - (alist->map compare-symbols '((a . 1) (b . 2))) - transform-map)) + (test alist->map-two + (assert-equal + '((a . 1) (b . 2)) + (alist->map compare-symbols '((a . 1) (b . 2))) + transform-map)) -(test alist->map-longer - (assert-equal - '((a . 1) (b . 2) (c . 3) (d . 4) (e . 5) (f . 6)) - (alist->map compare-symbols '((a . 1) (b . 2) (c . 3) (d . 4) (e . 5) (f . 6))) - transform-map)) + (test alist->map-longer + (assert-equal + '((a . 1) (b . 2) (c . 3) (d . 4) (e . 5) (f . 6)) + (alist->map compare-symbols '((a . 1) (b . 2) (c . 3) (d . 4) (e . 5) (f . 6))) + transform-map)) -(test alist->map-larger - (assert-equal - '((f . 5) (m . 1) (n . 7) (q . 3) (x . 8)) - (alist->map compare-symbols '((m . 1) (n . 2) (q . 3) (f . 5) (n . 7) (x . 8))) - transform-map)) + (test alist->map-larger + (assert-equal + '((f . 5) (m . 1) (n . 7) (q . 3) (x . 8)) + (alist->map compare-symbols '((m . 1) (n . 2) (q . 3) (f . 5) (n . 7) (x . 8))) + transform-map)) -(test alist->map-in-order - (assert-equal - '((a . ()) (b . ()) (c . ()) (d . ()) (e . ()) (f . ()) (g . ()) (h . ())) - (alist->map compare-symbols '((a . ()) (b . ()) (c . ()) (d . ()) (e . ()) (f . ()) (g . ()) (h . ()))) - transform-map)) + (test alist->map-in-order + (assert-equal + '((a . ()) (b . ()) (c . ()) (d . ()) (e . ()) (f . ()) (g . ()) (h . ())) + (alist->map compare-symbols '((a . ()) (b . ()) (c . ()) (d . ()) (e . ()) (f . ()) (g . ()) (h . ()))) + transform-map)) -(test alist->map-reversed - (assert-equal - '((h . ()) (g . ()) (f . ()) (e . ()) (d . ()) (c . ()) (b . ()) (a . ())) - (alist->map compare-symbols '((a . ()) (b . ()) (c . ()) (d . ()) (e . ()) (f . ()) (g . ()) (h . ()))) - transform-map)) + (test alist->map-reversed + (assert-equal + '((h . ()) (g . ()) (f . ()) (e . ()) (d . ()) (c . ()) (b . ()) (a . ())) + (alist->map compare-symbols '((a . ()) (b . ()) (c . ()) (d . ()) (e . ()) (f . ()) (g . ()) (h . ()))) + transform-map)) -(test alist->map-overwrite - (assert-equal - '((a . 2)) - (alist->map compare-symbols '((a . 1) (a . 2))) - transform-map)) + (test alist->map-overwrite + (assert-equal + '((a . 2)) + (alist->map compare-symbols '((a . 1) (a . 2))) + transform-map)) -(test alist->map-alternating - (assert-equal - '((h . ()) (g . ()) (i . ()) (f . ()) (j . ()) (e . ()) (k . ()) (d . ()) (l . ()) (c . ())) - (alist->map compare-symbols '((c . ()) (d . ()) (e . ()) (f . ()) (g . ()) (h . ()) (i . ()) (j . ()) (k . ()) (l . ()))) - transform-map)) + (test alist->map-alternating + (assert-equal + '((h . ()) (g . ()) (i . ()) (f . ()) (j . ()) (e . ()) (k . ()) (d . ()) (l . ()) (c . ())) + (alist->map compare-symbols '((c . ()) (d . ()) (e . ()) (f . ()) (g . ()) (h . ()) (i . ()) (j . ()) (k . ()) (l . ()))) + transform-map)) -(define (test-map . bindings) - (alist->map compare-symbols bindings)) + (define (test-map . bindings) + (alist->map compare-symbols bindings)) -(test lookup - (assert-equal - 2 - (lookup (test-map '(a . 1) '(b . 2) '(c . 3)) 'b))) + (test lookup + (assert-equal + 2 + (lookup (test-map '(a . 1) '(b . 2) '(c . 3)) 'b))) -(test lookup-notfound - (assert-raises key-not-found-error? - (lookup (test-map '(a . 1) '(b . 2) '(c . 3)) 'd))) + (test lookup-notfound + (assert-raises key-not-found-error? + (lookup (test-map '(a . 1) '(b . 2) '(c . 3)) 'd))) -(test lookup-default - (assert-equal - #f - (lookup (test-map '(a . #t) '(b . #t)) 'c #f))) + (test lookup-default + (assert-equal + #f + (lookup (test-map '(a . #t) '(b . #t)) 'c #f))) -(test merge - (assert-equal - '((a . 1) (b . 2) (c . 3) (d . 4)) - (merge - (test-map '(a . 1) '(b . 2)) - (test-map '(c . 3) '(d . 4))) - transform-map)) + (test merge + (assert-equal + '((a . 1) (b . 2) (c . 3) (d . 4)) + (merge + (test-map '(a . 1) '(b . 2)) + (test-map '(c . 3) '(d . 4))) + transform-map)) -(test delete - (assert-equal - '((a . 1) (b . 2) (d . 4)) - (delete - (test-map '(a . 1) '(b . 2) '(c . 3) '(d . 4)) - 'c) - transform-map)) + (test delete + (assert-equal + '((a . 1) (b . 2) (d . 4)) + (delete + (test-map '(a . 1) '(b . 2) '(c . 3) '(d . 4)) + 'c) + transform-map)) -(test delete-only - (assert-equal - '() - (delete - (test-map '(a . 1)) - 'a) - transform-map)) + (test delete-only + (assert-equal + '() + (delete + (test-map '(a . 1)) + 'a) + transform-map)) -(test delete-first - (assert-equal - '((b . 2) (c . 3) (d . 4)) - (delete - (test-map '(a . 1) '(b . 2) '(c . 3) '(d . 4)) - 'a) - transform-map)) + (test delete-first + (assert-equal + '((b . 2) (c . 3) (d . 4)) + (delete + (test-map '(a . 1) '(b . 2) '(c . 3) '(d . 4)) + 'a) + transform-map)) -(test delete-last - (assert-equal - '((a . 1) (b . 2) (c . 3)) - (delete - (test-map '(a . 1) '(b . 2) '(c . 3) '(d . 4)) - 'd) - transform-map)) + (test delete-last + (assert-equal + '((a . 1) (b . 2) (c . 3)) + (delete + (test-map '(a . 1) '(b . 2) '(c . 3) '(d . 4)) + 'd) + transform-map)) -(test delete-many - (assert-equal - '() - (loop with m = (loop with m = (test-map) - for i from 1 to 100 - do (set! m (insert m (string->symbol (sprintf "key{}" i)) i)) - finally (return m)) - for i from 1 to 100 - do (set! m (delete m (string->symbol (sprintf "key{}" i)))) - finally (return m)) - transform-map)) + (test delete-many + (assert-equal + '() + (loop with m = (loop with m = (test-map) + for i from 1 to 100 + do (set! m (insert m (string->symbol (sprintf "key{}" i)) i)) + finally (return m)) + for i from 1 to 100 + do (set! m (delete m (string->symbol (sprintf "key{}" i)))) + finally (return m)) + transform-map)))) diff --git a/csc/linker-test.csc b/csc/linker-test.csc index d3481a9..70e5e31 100644 --- a/csc/linker-test.csc +++ b/csc/linker-test.csc @@ -1,71 +1,73 @@ -(import (scheme base) - (only (csc format) - sprintf) - (only (csc hash-map) - alist->map - hash-bytevector - make-comparer - make-map) - (only (csc list) - all) - (only (csc testing) - assert-equal - test) - (csc linker)) +(define-library (csc linker-test) + (import (scheme base) + (only (csc format) + sprintf) + (only (csc hash-map) + alist->map + hash-bytevector + make-comparer + make-map) + (only (csc list) + all) + (only (csc testing) + assert-equal + test) + (csc linker)) + (begin -(define compare-globals - (make-comparer - (lambda (x) - (hash-bytevector (string->utf8 (sprintf "{}" x)))) - (lambda (x y) - (cond - ((equal? x y) 0) - ((string<? (sprintf "{}" x) (sprintf "{}" y)) -1) - (else 1))))) + (define compare-globals + (make-comparer + (lambda (x) + (hash-bytevector (string->utf8 (sprintf "{}" x)))) + (lambda (x y) + (cond + ((equal? x y) 0) + ((string<? (sprintf "{}" x) (sprintf "{}" y)) -1) + (else 1))))) -(test link-labels - (assert-equal - '((jmp (const 3)) - (jmp (const 2)) - (jmp (const 1)) - (jmp (const 1))) - (link - '(((label 0) - (jmp (label 1)) - (label 1) - (jmp (label 0)) - (label init) - (jmp (label 0)))) - (make-map compare-globals)))) + (test link-labels + (assert-equal + '((jmp (const 3)) + (jmp (const 2)) + (jmp (const 1)) + (jmp (const 1))) + (link + '(((label 0) + (jmp (label 1)) + (label 1) + (jmp (label 0)) + (label init) + (jmp (label 0)))) + (make-map compare-globals)))) -(test link-labels-are-unique-per-program - (assert-equal - '((jmp (const 2)) - (jmp (const 1)) - (jmp (const 1)) - (jmp (const 5)) - (jmp (const 4)) - (jmp (const 4))) - (link - '(((label 0) - (jmp (label 0)) - (label init) - (jmp (label 0))) - ((label 0) - (jmp (label 0)) - (label init) - (jmp (label 0)))) - (make-map compare-globals)))) + (test link-labels-are-unique-per-program + (assert-equal + '((jmp (const 2)) + (jmp (const 1)) + (jmp (const 1)) + (jmp (const 5)) + (jmp (const 4)) + (jmp (const 4))) + (link + '(((label 0) + (jmp (label 0)) + (label init) + (jmp (label 0))) + ((label 0) + (jmp (label 0)) + (label init) + (jmp (label 0)))) + (make-map compare-globals)))) -(test link-globals - (assert-equal - '((jmp (const 1)) - (peek (local 0) (const 10))) - (link - '(((label init) - (peek (local 0) (global cons (csc based))))) - (alist->map compare-globals '(((global cons (csc based)) . 10)))))) + (test link-globals + (assert-equal + '((jmp (const 1)) + (peek (local 0) (const 10))) + (link + '(((label init) + (peek (local 0) (global cons (csc based))))) + (alist->map compare-globals '(((global cons (csc based)) . 10)))))))) diff --git a/csc/list-test.csc b/csc/list-test.csc index e16feee..dd5d640 100644 --- a/csc/list-test.csc +++ b/csc/list-test.csc @@ -1,121 +1,123 @@ -(import (scheme base) - (only (csc testing) assert assert-equal test) - (csc list)) +(define-library (csc list-test) + (import (scheme base) + (only (csc testing) assert assert-equal test) + (csc list)) + (begin -(test take-simple - (assert-equal '(1 2 3) (take 3 '(1 2 3 4 5)))) + (test take-simple + (assert-equal '(1 2 3) (take 3 '(1 2 3 4 5)))) -(test take-negative - (assert-equal '() (take -5 '(1 2 3)))) + (test take-negative + (assert-equal '() (take -5 '(1 2 3)))) -(test take-zero - (assert-equal '() (take 0 '(1 2 3)))) + (test take-zero + (assert-equal '() (take 0 '(1 2 3)))) -(test take-short-list - (assert-equal '(1 2 3) (take 5 '(1 2 3)))) + (test take-short-list + (assert-equal '(1 2 3) (take 5 '(1 2 3)))) -(test take-whole-list - (assert-equal '(1 2 3) (take 3 '(1 2 3)))) + (test take-whole-list + (assert-equal '(1 2 3) (take 3 '(1 2 3)))) -(define-syntax values= - (syntax-rules () - ((values= x y) - (let-values (((x-a x-b) x) - ((y-a y-b) y)) - (and (equal? x-a y-a) (equal? x-b y-b)))))) + (define-syntax values= + (syntax-rules () + ((values= x y) + (let-values (((x-a x-b) x) + ((y-a y-b) y)) + (and (equal? x-a y-a) (equal? x-b y-b)))))) -(test split-at-simple - (assert (values= (values '(1 2) '(3 4)) (split-at 2 '(1 2 3 4))))) + (test split-at-simple + (assert (values= (values '(1 2) '(3 4)) (split-at 2 '(1 2 3 4))))) -(test split-at-negative - (assert (values= (values '() '(1 2 3)) (split-at -5 '(1 2 3))))) + (test split-at-negative + (assert (values= (values '() '(1 2 3)) (split-at -5 '(1 2 3))))) -(test split-at-zero - (assert (values= (values '() '(1 2 3)) (split-at 0 '(1 2 3))))) + (test split-at-zero + (assert (values= (values '() '(1 2 3)) (split-at 0 '(1 2 3))))) -(test split-at-short-list - (assert (values= (values '(1 2 3) '()) (split-at 5 '(1 2 3))))) + (test split-at-short-list + (assert (values= (values '(1 2 3) '()) (split-at 5 '(1 2 3))))) -(test split-at-whole-list - (assert (values= (values '(1 2 3) '()) (split-at 3 '(1 2 3))))) + (test split-at-whole-list + (assert (values= (values '(1 2 3) '()) (split-at 3 '(1 2 3))))) -(test revappend-threes - (assert-equal '(1 2 3 4 5 6) (revappend '(3 2 1) '(4 5 6)))) + (test revappend-threes + (assert-equal '(1 2 3 4 5 6) (revappend '(3 2 1) '(4 5 6)))) -(test revappend-empty-first-list - (assert-equal '(1 2 3) (revappend '() '(1 2 3)))) + (test revappend-empty-first-list + (assert-equal '(1 2 3) (revappend '() '(1 2 3)))) -(test revappend-empty-second-list - (assert-equal '(1 2 3) (revappend '(3 2 1) '()))) + (test revappend-empty-second-list + (assert-equal '(1 2 3) (revappend '(3 2 1) '()))) -(test intercalate-simple - (assert-equal '("a" "," "b" "," "c") (intercalate "," '("a" "b" "c")))) + (test intercalate-simple + (assert-equal '("a" "," "b" "," "c") (intercalate "," '("a" "b" "c")))) -(test intercalate-empty - (assert-equal '() (intercalate "," '()))) + (test intercalate-empty + (assert-equal '() (intercalate "," '()))) -(test intercalate-singleton - (assert-equal '(1) (intercalate "," '(1)))) + (test intercalate-singleton + (assert-equal '(1) (intercalate "," '(1)))) -(test enumerate-simple - (assert-equal '((0 . a) (1 . b) (2 . c) (3 . d)) (enumerate '(a b c d)))) + (test enumerate-simple + (assert-equal '((0 . a) (1 . b) (2 . c) (3 . d)) (enumerate '(a b c d)))) -(test enumerate-nil - (assert-equal '() (enumerate '()))) + (test enumerate-nil + (assert-equal '() (enumerate '()))) -(test enumerate-singleton - (assert-equal '((0 . "test")) (enumerate '("test")))) + (test enumerate-singleton + (assert-equal '((0 . "test")) (enumerate '("test")))) -(test filter-even - (assert-equal '(0 2 4 6 8) (filter even? '(0 1 2 3 4 5 6 7 8 9)))) + (test filter-even + (assert-equal '(0 2 4 6 8) (filter even? '(0 1 2 3 4 5 6 7 8 9)))) -(test filter-odd - (assert-equal '(1 3 5 7 9) (filter odd? '(0 1 2 3 4 5 6 7 8 9)))) + (test filter-odd + (assert-equal '(1 3 5 7 9) (filter odd? '(0 1 2 3 4 5 6 7 8 9)))) -(test unzip-empty - (assert (values= (values '() '()) (unzip '())))) + (test unzip-empty + (assert (values= (values '() '()) (unzip '())))) -(test unzip-simple - (assert (values= (values '(1 2 3) '(4 5 6)) (unzip '((1 . 4) (2 . 5) (3 . 6)))))) + (test unzip-simple + (assert (values= (values '(1 2 3) '(4 5 6)) (unzip '((1 . 4) (2 . 5) (3 . 6)))))) -(test all-even - (assert-equal - #t - (all (lambda (x) (= 0 (remainder x 2))) '(2 12 8)))) + (test all-even + (assert-equal + #t + (all (lambda (x) (= 0 (remainder x 2))) '(2 12 8)))) -(test some-odd - (assert-equal - #f - (all (lambda (x) (= 0 (remainder x 2))) '(2 13 8)))) + (test some-odd + (assert-equal + #f + (all (lambda (x) (= 0 (remainder x 2))) '(2 13 8)))) -(test all-equal - (assert-equal - #t - (all = '(1 2 3) '(1 2 3)))) + (test all-equal + (assert-equal + #t + (all = '(1 2 3) '(1 2 3)))))) diff --git a/csc/loop-test.csc b/csc/loop-test.csc index 9a74ad4..50090e0 100644 --- a/csc/loop-test.csc +++ b/csc/loop-test.csc @@ -1,292 +1,294 @@ -(import (scheme base) - (only (csc format) printf) - (only (csc testing) - assert-equal - test) - (csc loop)) +(define-library (csc loop-test) + (import (scheme base) + (only (csc format) printf) + (only (csc testing) + assert-equal + test) + (csc loop)) + (begin -(test loop-for-collect - (assert-equal - '(1 2 3 4 5) - (loop for x in '(1 2 3 4 5) - collect x))) + (test loop-for-collect + (assert-equal + '(1 2 3 4 5) + (loop for x in '(1 2 3 4 5) + collect x))) -(test loop-for-collect-add - (assert-equal - '(2 3 4 5 6) - (loop for x in '(1 2 3 4 5) - collect (+ 1 x)))) + (test loop-for-collect-add + (assert-equal + '(2 3 4 5 6) + (loop for x in '(1 2 3 4 5) + collect (+ 1 x)))) -(test loop-collect-nothing - (assert-equal - '() - (loop for x in '() - collect x))) + (test loop-collect-nothing + (assert-equal + '() + (loop for x in '() + collect x))) -(test loop-for-arithmetic - (assert-equal - '(1 2 3 4 5) - (loop for x from 1 to 5 - collect x))) + (test loop-for-arithmetic + (assert-equal + '(1 2 3 4 5) + (loop for x from 1 to 5 + collect x))) -(test loop-for-arithmetic-step - (assert-equal - '(1 3 5 7 9) - (loop for x from 1 to 10 by 2 - collect x))) + (test loop-for-arithmetic-step + (assert-equal + '(1 3 5 7 9) + (loop for x from 1 to 10 by 2 + collect x))) -(test loop-finally-noop - (assert-equal - '(1 2 3) - (loop for x from 1 to 3 - finally (if #f #f) - collect x))) + (test loop-finally-noop + (assert-equal + '(1 2 3) + (loop for x from 1 to 3 + finally (if #f #f) + collect x))) -(test loop-collect-into - (assert-equal - '((1 2 3) (1 2 3) (1 2 3)) - (loop for x from 1 to 3 - collect x into l - collect l))) + (test loop-collect-into + (assert-equal + '((1 2 3) (1 2 3) (1 2 3)) + (loop for x from 1 to 3 + collect x into l + collect l))) -(test loop-finally-set - (assert-equal - '(1 2 3) - (let ((res #f)) - (loop for x from 1 to 3 - collect x into l - finally (set! res l)) - res))) + (test loop-finally-set + (assert-equal + '(1 2 3) + (let ((res #f)) + (loop for x from 1 to 3 + collect x into l + finally (set! res l)) + res))) -(test loop-do - (assert-equal - '(3 2 1) - (let ((res '())) - (loop for x from 1 to 3 - do (set! res (cons x res))) - res))) + (test loop-do + (assert-equal + '(3 2 1) + (let ((res '())) + (loop for x from 1 to 3 + do (set! res (cons x res))) + res))) -(test loop-return - (assert-equal - '(1 2 3) - (loop do (return '(1 2 3))))) + (test loop-return + (assert-equal + '(1 2 3) + (loop do (return '(1 2 3))))) -(test loop-finally-return - (assert-equal - '(1 2 3) - (loop for x from 1 to 3 - collect x into l - finally (return l)))) + (test loop-finally-return + (assert-equal + '(1 2 3) + (loop for x from 1 to 3 + collect x into l + finally (return l)))) -(test loop-for-as-equals-then - (assert-equal - '((1 2 3) (2 3) (3)) - (loop for i from 1 to 3 - for tail = '(1 2 3) then (cdr tail) - collect tail))) + (test loop-for-as-equals-then + (assert-equal + '((1 2 3) (2 3) (3)) + (loop for i from 1 to 3 + for tail = '(1 2 3) then (cdr tail) + collect tail))) -(test loop-for-as-equals - (assert-equal - '((1) (2) (3)) - (loop for i from 1 to 3 - for j = (list i) - collect j))) + (test loop-for-as-equals + (assert-equal + '((1) (2) (3)) + (loop for i from 1 to 3 + for j = (list i) + collect j))) -(test loop-return-multiple-values - (let-values (((x1 x2) (loop do (return (values 1 2))))) - (assert-equal - 1 - x1) - (assert-equal - 2 - x2))) + (test loop-return-multiple-values + (let-values (((x1 x2) (loop do (return (values 1 2))))) + (assert-equal + 1 + x1) + (assert-equal + 2 + x2))) -(test nested-loops - (assert-equal - '(1 2 3) - (loop do (define x (loop do (return '(1 2 3)))) - (return x)))) + (test nested-loops + (assert-equal + '(1 2 3) + (loop do (define x (loop do (return '(1 2 3)))) + (return x)))) -(test loop-with-return - (assert-equal - 5 - (loop with x = 5 - return x))) + (test loop-with-return + (assert-equal + 5 + (loop with x = 5 + return x))) -(test loop-for-x-on-l - (assert-equal - '((1 2 3) (2 3) (3)) - (loop for x on '(1 2 3) - collect x))) + (test loop-for-x-on-l + (assert-equal + '((1 2 3) (2 3) (3)) + (loop for x on '(1 2 3) + collect x))) -(test loop-for-across - (assert-equal - '(1 2 3) - (loop for x across #(1 2 3) - collect x))) + (test loop-for-across + (assert-equal + '(1 2 3) + (loop for x across #(1 2 3) + collect x))) -(test loop-for-downfrom - (assert-equal - '(3 2 1) - (loop for x to 1 downfrom 3 - collect x))) + (test loop-for-downfrom + (assert-equal + '(3 2 1) + (loop for x to 1 downfrom 3 + collect x))) -(test loop-for-to - (assert-equal - '(0 1 2 3) - (loop for x to 3 - collect x))) + (test loop-for-to + (assert-equal + '(0 1 2 3) + (loop for x to 3 + collect x))) -(test loop-for-downto - (assert-equal - '(3 2 1) - (loop for x downto 1 from 3 - collect x))) + (test loop-for-downto + (assert-equal + '(3 2 1) + (loop for x downto 1 from 3 + collect x))) -(test loop-for-below - (assert-equal - '(0 1 2) - (loop for x below 3 - collect x))) + (test loop-for-below + (assert-equal + '(0 1 2) + (loop for x below 3 + collect x))) -(test loop-for-above - (assert-equal - '(3 2 1) - (loop for x above 0 from 3 - collect x))) + (test loop-for-above + (assert-equal + '(3 2 1) + (loop for x above 0 from 3 + collect x))) -(test loop-for-by - (assert-equal - '(0 2 4) - (loop for x by 2 to 4 - collect x))) + (test loop-for-by + (assert-equal + '(0 2 4) + (loop for x by 2 to 4 + collect x))) -(test loop-append - (assert-equal - '(1 2 3 4) - (loop for x in '((1 2) (3 4)) - append x))) + (test loop-append + (assert-equal + '(1 2 3 4) + (loop for x in '((1 2) (3 4)) + append x))) -(test loop-count - (assert-equal - 50 - (loop for x from 1 to 100 - count (even? x)))) + (test loop-count + (assert-equal + 50 + (loop for x from 1 to 100 + count (even? x)))) -(test loop-sum - (assert-equal - 15 - (loop for x from 1 to 5 - sum x))) + (test loop-sum + (assert-equal + 15 + (loop for x from 1 to 5 + sum x))) -(test loop-maximize - (assert-equal - 10 - (loop for x in '(3 10 1 4) - maximize x))) + (test loop-maximize + (assert-equal + 10 + (loop for x in '(3 10 1 4) + maximize x))) -(test loop-maximize-none - (assert-equal - 0 - (loop for x in '() - maximize x))) + (test loop-maximize-none + (assert-equal + 0 + (loop for x in '() + maximize x))) -(test loop-minimize - (assert-equal - 1 - (loop for x in '(3 10 1 4) - minimize x))) + (test loop-minimize + (assert-equal + 1 + (loop for x in '(3 10 1 4) + minimize x))) -(test loop-minimize-none - (assert-equal - 0 - (loop for x in '() - minimize x))) + (test loop-minimize-none + (assert-equal + 0 + (loop for x in '() + minimize x))) -(test loop-if - (assert-equal - 5 - (loop for x from 0 - if (>= x 5) return x))) + (test loop-if + (assert-equal + 5 + (loop for x from 0 + if (>= x 5) return x))) -(test loop-when - (assert-equal - 5 - (loop for x from 0 - when (>= x 5) return x))) + (test loop-when + (assert-equal + 5 + (loop for x from 0 + when (>= x 5) return x))) -(test loop-else - (assert-equal - '((0 2 4) . (1 3 5)) - (loop for x to 5 - if (even? x) collect x into evens - else collect x into odds - finally (return (cons evens odds))))) + (test loop-else + (assert-equal + '((0 2 4) . (1 3 5)) + (loop for x to 5 + if (even? x) collect x into evens + else collect x into odds + finally (return (cons evens odds))))) -(test loop-if-compound - (assert-equal - '((0 2 4) . (1 3 5)) - (loop for x to 5 - if (even? x) collect x into list1 - and collect (+ 1 x) into list2 - finally (return (cons list1 list2))))) + (test loop-if-compound + (assert-equal + '((0 2 4) . (1 3 5)) + (loop for x to 5 + if (even? x) collect x into list1 + and collect (+ 1 x) into list2 + finally (return (cons list1 list2))))) -(test loop-if-end - (assert-equal - 5 - (loop for x from 0 - if (>= x 5) return x end))) + (test loop-if-end + (assert-equal + 5 + (loop for x from 0 + if (>= x 5) return x end))) -(test loop-if-collect-and - (assert-equal - '(1 2 3 4 5 6 7 8 9 10) - (loop for i from 1 to 10 - if (odd? i) - collect i - and collect (+ 1 i)))) + (test loop-if-collect-and + (assert-equal + '(1 2 3 4 5 6 7 8 9 10) + (loop for i from 1 to 10 + if (odd? i) + collect i + and collect (+ 1 i)))) -(test loop-collect-advanced - (assert-equal - '(fred bob ken sue alice joe kris sunshine june) - (loop for name in '(fred sue alice joe june) - for kids in '((bob ken) () () (kris sunshine) ()) - collect name - append kids))) + (test loop-collect-advanced + (assert-equal + '(fred bob ken sue alice joe kris sunshine june) + (loop for name in '(fred sue alice joe june) + for kids in '((bob ken) () () (kris sunshine) ()) + collect name + append kids))))) diff --git a/csc/macros-test.csc b/csc/macros-test.csc index b2e2f3f..e4451e7 100644 --- a/csc/macros-test.csc +++ b/csc/macros-test.csc @@ -1,261 +1,263 @@ -(import (scheme base) - (only (csc gensym) - gensym - gensym?) - (only (csc ir1) - %call - %constant - %define-syntax - %if - %lambda - %letrec - %lexical-ref - %lexical-set - %library-define - %library-ref - %sequence - call? - constant? - define-syntax? - if? - lambda? - letrec? - lexical-ref-name - lexical-ref? - lexical-set-expression - lexical-set? - library-define? - library-ref? - make-constant - make-lambda - make-letrec - make-lexical-ref - make-library-ref - make-sequence - sequence?) - (only (csc testing) - assert-equal - test) - (csc macros)) +(define-library (csc macros-test) + (import (scheme base) + (only (csc gensym) + gensym + gensym?) + (only (csc ir1) + %call + %constant + %define-syntax + %if + %lambda + %letrec + %lexical-ref + %lexical-set + %library-define + %library-ref + %sequence + call? + constant? + define-syntax? + if? + lambda? + letrec? + lexical-ref-name + lexical-ref? + lexical-set-expression + lexical-set? + library-define? + library-ref? + make-constant + make-lambda + make-letrec + make-lexical-ref + make-library-ref + make-sequence + sequence?) + (only (csc testing) + assert-equal + test) + (csc macros)) + (begin -(define transform-ir1 - (list - (cons constant? %constant) - (cons lexical-ref? %lexical-ref) - (cons library-ref? %library-ref) - (cons lexical-set? %lexical-set) - (cons library-define? %library-define) - (cons define-syntax? %define-syntax) - (cons if? %if) - (cons call? %call) - (cons sequence? %sequence) - (cons lambda? %lambda) - (cons letrec? %letrec) - (cons gensym? (lambda (x) 'gensym)))) + (define transform-ir1 + (list + (cons constant? %constant) + (cons lexical-ref? %lexical-ref) + (cons library-ref? %library-ref) + (cons lexical-set? %lexical-set) + (cons library-define? %library-define) + (cons define-syntax? %define-syntax) + (cons if? %if) + (cons call? %call) + (cons sequence? %sequence) + (cons lambda? %lambda) + (cons letrec? %letrec) + (cons gensym? (lambda (x) 'gensym)))) -(test builtin-quote - (assert-equal - (make-constant '(test 1 2 3)) - (expand '(quote (test 1 2 3)) builtins-environment) - transform-ir1)) + (test builtin-quote + (assert-equal + (make-constant '(test 1 2 3)) + (expand '(quote (test 1 2 3)) builtins-environment) + transform-ir1)) -(test builtin-syntax-rules-literal - (assert-equal - (make-constant 1) - (expand - '(builtin-let-syntax - (foo - (syntax-rules (a b) - ((foo a) - 0) - ((foo b) - 1))) - (foo b)) - builtins-environment) - transform-ir1)) + (test builtin-syntax-rules-literal + (assert-equal + (make-constant 1) + (expand + '(builtin-let-syntax + (foo + (syntax-rules (a b) + ((foo a) + 0) + ((foo b) + 1))) + (foo b)) + builtins-environment) + transform-ir1)) -(test builtin-syntax-rules-underscore - (assert-equal - (make-constant 0) - (expand - '(builtin-let-syntax - (foo - (syntax-rules () - ((foo _) 0))) - (foo ignored)) - builtins-environment) - transform-ir1)) + (test builtin-syntax-rules-underscore + (assert-equal + (make-constant 0) + (expand + '(builtin-let-syntax + (foo + (syntax-rules () + ((foo _) 0))) + (foo ignored)) + builtins-environment) + transform-ir1)) -(test builtin-syntax-rules-substitution - (assert-equal - (make-constant 5) - (expand - '(builtin-let-syntax - (foo - (syntax-rules () - ((foo x) x))) - (foo 5)) - builtins-environment) - transform-ir1)) + (test builtin-syntax-rules-substitution + (assert-equal + (make-constant 5) + (expand + '(builtin-let-syntax + (foo + (syntax-rules () + ((foo x) x))) + (foo 5)) + builtins-environment) + transform-ir1)) -(test builtin-syntax-rules-nil - (assert-equal - (make-constant 1) - (expand - '(builtin-let-syntax - (foo - (syntax-rules () - ((foo x) 0) - ((foo) 1))) - (foo)) - builtins-environment) - transform-ir1)) + (test builtin-syntax-rules-nil + (assert-equal + (make-constant 1) + (expand + '(builtin-let-syntax + (foo + (syntax-rules () + ((foo x) 0) + ((foo) 1))) + (foo)) + builtins-environment) + transform-ir1)) -(test builtin-syntax-rules-improper-list - (assert-equal - (make-constant 1) - (expand - '(builtin-let-syntax - (foo - (syntax-rules () - ((foo a . b) a))) - (foo 1 2 3)) - builtins-environment) - transform-ir1)) + (test builtin-syntax-rules-improper-list + (assert-equal + (make-constant 1) + (expand + '(builtin-let-syntax + (foo + (syntax-rules () + ((foo a . b) a))) + (foo 1 2 3)) + builtins-environment) + transform-ir1)) -(test builtin-syntax-rules-quoted - (assert-equal - (make-constant 'a) - (expand - '(builtin-let-syntax - (foo - (syntax-rules () - ((foo x) (quote x)))) - (foo a)) - builtins-environment) - transform-ir1)) + (test builtin-syntax-rules-quoted + (assert-equal + (make-constant 'a) + (expand + '(builtin-let-syntax + (foo + (syntax-rules () + ((foo x) (quote x)))) + (foo a)) + builtins-environment) + transform-ir1)) -(test builtin-syntax-rules-constant - (assert-equal - (make-constant 2) - (expand - '(builtin-let-syntax - (foo - (syntax-rules () - ((foo "abc") 0) - ((foo "def") 1) - ((foo "ghi") 2))) - (foo "ghi")) - builtins-environment) - transform-ir1)) + (test builtin-syntax-rules-constant + (assert-equal + (make-constant 2) + (expand + '(builtin-let-syntax + (foo + (syntax-rules () + ((foo "abc") 0) + ((foo "def") 1) + ((foo "ghi") 2))) + (foo "ghi")) + builtins-environment) + transform-ir1)) -(test builtin-syntax-rules-ellipsis - (assert-equal - (make-constant 5) - (expand - '(builtin-let-syntax - (foo - (syntax-rules () - ((foo x ...) (x ...)))) - (foo quote 5)) - builtins-environment) - transform-ir1)) + (test builtin-syntax-rules-ellipsis + (assert-equal + (make-constant 5) + (expand + '(builtin-let-syntax + (foo + (syntax-rules () + ((foo x ...) (x ...)))) + (foo quote 5)) + builtins-environment) + transform-ir1)) -(test builtin-syntax-rules-ellipsis-improper - (assert-equal - (make-constant 5) - (expand - '(builtin-let-syntax - (foo - (syntax-rules () - ((foo x ... . y) (x ... y)))) - (foo quote . 5)) - builtins-environment) - transform-ir1)) + (test builtin-syntax-rules-ellipsis-improper + (assert-equal + (make-constant 5) + (expand + '(builtin-let-syntax + (foo + (syntax-rules () + ((foo x ... . y) (x ... y)))) + (foo quote . 5)) + builtins-environment) + transform-ir1)) -(test builtin-syntax-rules-ellipsis-zip - (assert-equal - (make-constant '((1 . 3) (2 . 4))) - (expand - '(builtin-let-syntax - (zip - (syntax-rules () - ((zip (x ...) (y ...)) - (quote ((x . y) ...))))) - (zip (1 2) (3 4))) - builtins-environment) - transform-ir1)) + (test builtin-syntax-rules-ellipsis-zip + (assert-equal + (make-constant '((1 . 3) (2 . 4))) + (expand + '(builtin-let-syntax + (zip + (syntax-rules () + ((zip (x ...) (y ...)) + (quote ((x . y) ...))))) + (zip (1 2) (3 4))) + builtins-environment) + transform-ir1)) -(test builtin-syntax-rules-ellipsis-nested - (assert-equal - (make-constant '(1 2 3 4 5)) - (expand - '(builtin-let-syntax - (append - (syntax-rules () - ((append (x ...) ...) - (quote (x ... ...))))) - (append (1 2) (3 4) () (5))) - builtins-environment) - transform-ir1)) + (test builtin-syntax-rules-ellipsis-nested + (assert-equal + (make-constant '(1 2 3 4 5)) + (expand + '(builtin-let-syntax + (append + (syntax-rules () + ((append (x ...) ...) + (quote (x ... ...))))) + (append (1 2) (3 4) () (5))) + builtins-environment) + transform-ir1)) -(test builtin-syntax-rules-ellipsis-custom - (assert-equal - (make-constant 5) - (expand - '(builtin-let-syntax - (foo - (syntax-rules ::: () - ((foo x :::) (x :::)))) - (foo quote 5)) - builtins-environment) - transform-ir1)) + (test builtin-syntax-rules-ellipsis-custom + (assert-equal + (make-constant 5) + (expand + '(builtin-let-syntax + (foo + (syntax-rules ::: () + ((foo x :::) (x :::)))) + (foo quote 5)) + builtins-environment) + transform-ir1)) -(define (test-ref sym) - (make-lexical-ref sym (gensym))) + (define (test-ref sym) + (make-lexical-ref sym (gensym))) -(test builtin-lambda-rest - (assert-equal - (make-lambda (list - (test-ref 'a) - (test-ref 'b) - (test-ref 'c)) - (test-ref 'd) - (make-sequence (make-constant #f) (make-constant 5))) - (expand - '(lambda - (a b c . d) (quote 5)) - builtins-environment) - transform-ir1)) + (test builtin-lambda-rest + (assert-equal + (make-lambda (list + (test-ref 'a) + (test-ref 'b) + (test-ref 'c)) + (test-ref 'd) + (make-sequence (make-constant #f) (make-constant 5))) + (expand + '(lambda + (a b c . d) (quote 5)) + builtins-environment) + transform-ir1)) -(test builtin-case-lambda-defines - (assert-equal - (make-lambda (list (test-ref 'x)) #f - (make-letrec #t '(a b) (list (gensym) (gensym)) - (list (make-constant 6) - (test-ref 'a)) - (make-sequence (make-constant #f) (make-constant 7)))) - (expand - '(lambda (x) - (builtin-define a (quote 6)) - (builtin-define b a) - (quote 7)) - builtins-environment) - transform-ir1)) + (test builtin-case-lambda-defines + (assert-equal + (make-lambda (list (test-ref 'x)) #f + (make-letrec #t '(a b) (list (gensym) (gensym)) + (list (make-constant 6) + (test-ref 'a)) + (make-sequence (make-constant #f) (make-constant 7)))) + (expand + '(lambda (x) + (builtin-define a (quote 6)) + (builtin-define b a) + (quote 7)) + builtins-environment) + transform-ir1)))) diff --git a/csc/match-test.csc b/csc/match-test.csc index 8323952..c5923e4 100644 --- a/csc/match-test.csc +++ b/csc/match-test.csc @@ -1,111 +1,113 @@ -(import (scheme base) - (only (csc testing) assert-equal test) - (csc match)) +(define-library (csc match-test) + (import (scheme base) + (only (csc testing) assert-equal test) + (csc match)) + (begin -(test match-cond - (assert-equal - 3 - (match 3 - ('0 0) - ('1 1) - ('2 2) - ('3 3) - ('4 4)))) + (test match-cond + (assert-equal + 3 + (match 3 + ('0 0) + ('1 1) + ('2 2) + ('3 3) + ('4 4)))) -(test match-list - (assert-equal - 2 - (match '(1 2 3) - ('() 0) - (('1 '2) 1) - (('1 '2 '3) 2) - (('1 '2 '3 '4) 3) - (_ 4)))) + (test match-list + (assert-equal + 2 + (match '(1 2 3) + ('() 0) + (('1 '2) 1) + (('1 '2 '3) 2) + (('1 '2 '3 '4) 3) + (_ 4)))) -(test match-binding - (assert-equal - 2 - (match '(1 2 3) - (('1 x '3) x)))) + (test match-binding + (assert-equal + 2 + (match '(1 2 3) + (('1 x '3) x)))) -(test match-destructuring - (assert-equal - 1 - (match '(1 2 3) - ('() 0) - ((head . _) head)))) + (test match-destructuring + (assert-equal + 1 + (match '(1 2 3) + ('() 0) + ((head . _) head)))) -(test match-ignore - (assert-equal - 2 - (match '(1 2 3) - ((_ _ _ _) 0) - (('2 _ _) 1) - (('1 _ _) 2) - (_ 3)))) + (test match-ignore + (assert-equal + 2 + (match '(1 2 3) + ((_ _ _ _) 0) + (('2 _ _) 1) + (('1 _ _) 2) + (_ 3)))) -(test match-improper-list - (assert-equal - 2 - (match '(1 2 3) - (('2 . _) 1) - (('1 . x) (car x)) - (_ 3)))) + (test match-improper-list + (assert-equal + 2 + (match '(1 2 3) + (('2 . _) 1) + (('1 . x) (car x)) + (_ 3)))) -(test match-symbol - (assert-equal - 2 - (match 'b - ('a 1) - ('b 2) - (_ 3)))) + (test match-symbol + (assert-equal + 2 + (match 'b + ('a 1) + ('b 2) + (_ 3)))) -(test match-when - (assert-equal - 3 - (match 'b - ('a 1) - ('b when #f 2) - ('b when #t 3) - (_ 4)))) + (test match-when + (assert-equal + 3 + (match 'b + ('a 1) + ('b when #f 2) + ('b when #t 3) + (_ 4)))) -(test match-when-depending-on-pattern-variable - (assert-equal - 2 - (match 10 - (n when (= 1 n) 1) - (n when (= 10 n) 2) - (_ 3)))) + (test match-when-depending-on-pattern-variable + (assert-equal + 2 + (match 10 + (n when (= 1 n) 1) + (n when (= 10 n) 2) + (_ 3)))) -(define-match-record-type <test-record-type> - (make-test-record-type a b c) - test-record-type? - %test-record-type - (a test-record-type-a) - (b test-record-type-b) - (c test-record-type-c)) + (define-match-record-type <test-record-type> + (make-test-record-type a b c) + test-record-type? + %test-record-type + (a test-record-type-a) + (b test-record-type-b) + (c test-record-type-c)) -(test match-record-type - (assert-equal - 2 - (match (make-test-record-type 1 2 3) - ((% %test-record-type a b c) b)))) + (test match-record-type + (assert-equal + 2 + (match (make-test-record-type 1 2 3) + ((% %test-record-type a b c) b)))) -(test match-record-type-any - (assert-equal - 2 - (match '(1 2 3) - ((% %test-record-type . _) 1) - ('(1 2 3) 2)))) + (test match-record-type-any + (assert-equal + 2 + (match '(1 2 3) + ((% %test-record-type . _) 1) + ('(1 2 3) 2)))))) diff --git a/csc/sort-test.csc b/csc/sort-test.csc index dec2a53..9c91d4a 100644 --- a/csc/sort-test.csc +++ b/csc/sort-test.csc @@ -1,35 +1,37 @@ -(import (scheme base) - (only (csc testing) - assert-equal - test) - (csc sort)) +(define-library (csc sort-test) + (import (scheme base) + (only (csc testing) + assert-equal + test) + (csc sort)) + (begin -(test sort-ten-elem - (assert-equal - '(-2 0 2 3 4 4 5 6 9 100) - (sort < '(9 4 5 100 3 2 4 6 0 -2)))) + (test sort-ten-elem + (assert-equal + '(-2 0 2 3 4 4 5 6 9 100) + (sort < '(9 4 5 100 3 2 4 6 0 -2)))) -(test sort-empty - (assert-equal '() (sort < '()))) + (test sort-empty + (assert-equal '() (sort < '()))) -(test sort-singleton - (assert-equal '(1) (sort < '(1)))) + (test sort-singleton + (assert-equal '(1) (sort < '(1)))) -(test sort-two - (assert-equal '(1 2) (sort < '(2 1)))) + (test sort-two + (assert-equal '(1 2) (sort < '(2 1)))) -(test sort-reversed - (assert-equal - '(1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20) - (sort < '(20 19 18 17 16 15 14 13 12 11 10 9 8 7 6 5 4 3 2 1)))) + (test sort-reversed + (assert-equal + '(1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20) + (sort < '(20 19 18 17 16 15 14 13 12 11 10 9 8 7 6 5 4 3 2 1)))) -(test sort-already-sorted - (assert-equal - '(1 2 3 4 5 6 7 8 9 10) - (sort < '(1 2 3 4 5 6 7 8 9 10)))) + (test sort-already-sorted + (assert-equal + '(1 2 3 4 5 6 7 8 9 10) + (sort < '(1 2 3 4 5 6 7 8 9 10)))))) diff --git a/csc/strings-test.csc b/csc/strings-test.csc index 49f8d20..c3dd378 100644 --- a/csc/strings-test.csc +++ b/csc/strings-test.csc @@ -1,95 +1,97 @@ -(import (scheme base) - (only (csc testing) - assert - assert-equal - test) - (csc strings)) +(define-library (csc strings-test) + (import (scheme base) + (only (csc testing) + assert + assert-equal + test) + (csc strings)) + (begin -(test prefix?-good - (assert-equal #t (prefix? "asdf" "asdfjkl;"))) + (test prefix?-good + (assert-equal #t (prefix? "asdf" "asdfjkl;"))) -(test prefix?-bad - (assert-equal #f (prefix? "asdf" "asdbjkl;"))) + (test prefix?-bad + (assert-equal #f (prefix? "asdf" "asdbjkl;"))) -(test prefix?-too-long - (assert-equal #f (prefix? "asdf" "as"))) + (test prefix?-too-long + (assert-equal #f (prefix? "asdf" "as"))) -(test str-quote-simple - (assert-equal "\"hello\"" (str-quote "hello"))) + (test str-quote-simple + (assert-equal "\"hello\"" (str-quote "hello"))) -(test str-quote-escape - (assert-equal "\"this string \\\" has a quote\"" (str-quote "this string \" has a quote"))) + (test str-quote-escape + (assert-equal "\"this string \\\" has a quote\"" (str-quote "this string \" has a quote"))) -(test find-ok - (assert-equal 8 (find "abc" "dabsadfdabcdfdfd"))) + (test find-ok + (assert-equal 8 (find "abc" "dabsadfdabcdfdfd"))) -(test find-one-letter - (assert-equal 8 (find "a" "sdfdfdfsasdfe"))) + (test find-one-letter + (assert-equal 8 (find "a" "sdfdfdfsasdfe"))) -(test find-notfound - (let* ((match "a") - (str "def") - (got-exception '())) - (guard (e - ((not-found-error? e) (set! got-exception e))) - (find match str)) - (assert (not-found-error? got-exception)))) + (test find-notfound + (let* ((match "a") + (str "def") + (got-exception '())) + (guard (e + ((not-found-error? e) (set! got-exception e))) + (find match str)) + (assert (not-found-error? got-exception)))) -(test contains - (assert-equal - #t - (contains "abc" "b"))) + (test contains + (assert-equal + #t + (contains "abc" "b"))) -(test doesnt-contain - (assert-equal - #f - (contains "abc" "d"))) + (test doesnt-contain + (assert-equal + #f + (contains "abc" "d"))) -(test contains-empty - (assert-equal - #t - (contains "" ""))) + (test contains-empty + (assert-equal + #t + (contains "" ""))) -(test empty-contains - (assert-equal - #f - (contains "" "a"))) + (test empty-contains + (assert-equal + #f + (contains "" "a"))) -(test join-, - (assert-equal "a,b,c" (join "," "a" "b" "c"))) + (test join-, + (assert-equal "a,b,c" (join "," "a" "b" "c"))) -(test join-none - (assert-equal "" (join ","))) + (test join-none + (assert-equal "" (join ","))) -(test join-singleton - (assert-equal "x" (join "," "x"))) + (test join-singleton + (assert-equal "x" (join "," "x"))) -(test join-empty - (assert-equal "abc" (join "" "a" "b" "c"))) + (test join-empty + (assert-equal "abc" (join "" "a" "b" "c"))) -(test split-empty - (assert-equal '("") (split "" " "))) + (test split-empty + (assert-equal '("") (split "" " "))) -(test split - (assert-equal '("a" "b") (split "a b" " "))) + (test split + (assert-equal '("a" "b") (split "a b" " "))) -(test split-trailing-empty - (assert-equal '("a" "") (split "a " " "))) + (test split-trailing-empty + (assert-equal '("a" "") (split "a " " "))))) diff --git a/csc/test-main.csc b/csc/test-main.csc index 7b45883..184d069 100644 --- a/csc/test-main.csc +++ b/csc/test-main.csc @@ -1,6 +1,18 @@ (import (scheme base) - (only (csc testing) test-main)) + (only (csc testing) + test-main) + (only (scheme eval) + environment)) -(for-each load (cdr (command-line))) +(define (filename->library f) + (list 'csc (string->symbol (substring f 0 (- (string-length f) 4))))) + + +; Guile's load function allows import forms, but by a strict reading of R7RS, +; load can only handle expressions and definitions. I'm working around this by +; defining each test as a library, and using the environment procedure to load +; the libraries at runtime. Somehow this should be more portable. +(apply environment + (map filename->library (cdr (command-line)))) (test-main) diff --git a/csc/vec-test.csc b/csc/vec-test.csc index 8a19b3e..761b259 100644 --- a/csc/vec-test.csc +++ b/csc/vec-test.csc @@ -1,33 +1,35 @@ -(import (scheme base) - (only (csc testing) - assert-equal - test) - (csc vec)) +(define-library (csc vec-test) + (import (scheme base) + (only (csc testing) + assert-equal + test) + (csc vec)) + (begin -(test vec-empty - (assert-equal '() (vec->list (vec)))) + (test vec-empty + (assert-equal '() (vec->list (vec)))) -(test vec-singleton - (assert-equal '(1) (vec->list (vec 1)))) + (test vec-singleton + (assert-equal '(1) (vec->list (vec 1)))) -(test vec-append-to-empty - (assert-equal '(1) (vec->list (vec-append (vec) 1)))) + (test vec-append-to-empty + (assert-equal '(1) (vec->list (vec-append (vec) 1)))) -(test vec-append-to-singleton - (assert-equal '(1 2) (vec->list (vec-append (vec 1) 2)))) + (test vec-append-to-singleton + (assert-equal '(1 2) (vec->list (vec-append (vec 1) 2)))) -(test vec-append-to-2-elem - (assert-equal '(1 2 3) (vec->list (vec-append (vec 1 2) 3)))) + (test vec-append-to-2-elem + (assert-equal '(1 2 3) (vec->list (vec-append (vec 1 2) 3)))) -(test vec-ref-1 - (assert-equal 2 (vec-ref (vec 1 2) 1))) + (test vec-ref-1 + (assert-equal 2 (vec-ref (vec 1 2) 1))) -(test vec-ref-singleton - (assert-equal 1 (vec-ref (vec 1) 0))) + (test vec-ref-singleton + (assert-equal 1 (vec-ref (vec 1) 0))))) |