diff options
| author | Rose Hogenson <rhogenson@posteo.net> | 2022-08-01 19:35:19 -0700 |
|---|---|---|
| committer | Rose Hogenson <rhogenson@posteo.net> | 2022-08-01 19:35:19 -0700 |
| commit | acc561366f3fe6ec0377103f52ef0f7e923711c9 (patch) | |
| tree | d7a19cfbad78a69ebea71b27302e708c0655863d /lib | |
| parent | 99ce19a8053a93457885f32ec54c1c5b7c1961c1 (diff) | |
| download | chromatopelma-acc561366f3fe6ec0377103f52ef0f7e923711c9.tar.zst | |
Modify the project structure.
Now the lib directory contains what will eventually end up on the
user's /usr/lib/csc. When I write make install, it will copy all of
the .csc files from lib into the destination lib directory. This means I
can start working on the standard library in lib/scheme.
Diffstat (limited to 'lib')
37 files changed, 6441 insertions, 0 deletions
diff --git a/lib/csc/assert-test.csc b/lib/csc/assert-test.csc new file mode 100644 index 0000000..4e8d2d3 --- /dev/null +++ b/lib/csc/assert-test.csc @@ -0,0 +1,14 @@ +(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/lib/csc/assert.csc b/lib/csc/assert.csc new file mode 100644 index 0000000..84d2096 --- /dev/null +++ b/lib/csc/assert.csc @@ -0,0 +1,11 @@ +(define-library (csc assert) + (export assert) + (import (scheme base)) + (begin + + + (define-syntax assert + (syntax-rules () + ((assert condition) + (unless condition + (error "assertion failed" 'condition))))))) diff --git a/lib/csc/codegen-test.csc b/lib/csc/codegen-test.csc new file mode 100644 index 0000000..29d1da5 --- /dev/null +++ b/lib/csc/codegen-test.csc @@ -0,0 +1,132 @@ +(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-label) + (make-label (gensym))) + + + (test codegen-apply + (define p (test-var)) + (assert-equal + '((peek (local 1) (local 0) (const 5)) + (mov (local 2) (local 1)) + (mov (local 1) (const 10)) + (jmp (local 2)) + (label 0)) + (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 + '((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)) + (label 0)) + (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 + '((mov (local 1) (label 1)) + (jmp (label 1)) + (label 1) + (mov (local 2) (local 1)) + (jmp (local 2)) + (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 + '((mov (local 1) (const 0)) + (mov (local 2) (const 1)) + (jmp (label 1)) + (label 1) + (mov (local 127) (local 1)) + (mov (local 1) (local 2)) + (mov (local 2) (local 127)) + (mov (local 3) (const 0)) + (jmp (label 2)) + (label 2) + (mov (local 2) (local 1)) + (mov (local 1) (local 3)) + (jmp (label 1)) + (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 + '((peek (local 1) (local 0) (const 1)) + (jmpif (const #t) (label 1)) + (mov (local 2) (local 1)) + (mov (local 1) (const 10)) + (jmp (local 2)) + (label 1) + (mov (local 2) (local 1)) + (mov (local 1) (const 5)) + (jmp (local 2)) + (label 0)) + (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/lib/csc/codegen.csc b/lib/csc/codegen.csc new file mode 100644 index 0000000..ac5b313 --- /dev/null +++ b/lib/csc/codegen.csc @@ -0,0 +1,260 @@ +(define-library (csc codegen) + (export + ir2->ir3) + (import (scheme base) + (only (csc format) + sprintf) + (only (csc gensym) + gensym + gensym->int) + (only (csc hash-map) + compare-numbers + delete + hash-bytevector + insert + lookup + make-comparer + make-map + map-for-each) + (only (csc ir2) + %apply + %branch + %constant + %globals + %label + %library-ref + %primitive + %tail + %variable + closure-arguments + closure-body + closure-name + constant-expression + constant? + fix-body + fix-functions + globals? + label-gensym + label? + library-ref-library + library-ref-name + library-ref? + make-apply + make-constant + make-label + make-primitive + variable-gensym + variable?) + (only (csc loop) + loop) + (only (csc match) + match)) + (begin + + + (define (atom->bytecode atom translate-local) + (match atom + ((% %constant x) + (cond + ((and (integer? x) + (> x (- (expt 2 30) 1))) ; out of range for a small int + (error "I don't support big ints yet")) + ((or (integer? x) + (boolean? x)) + (list 'const x)) + (else (error "Only small ints and bool constants are supported for now")))) + ((% %library-ref x lib) + (list 'global x lib)) + ((% %variable sym) + (list 'local (translate-local atom))) + ((% %globals) + ; The globals array is stored in register 0. + (list 'local 0)) + ((% %label sym) + (list 'label (translate-local atom))) + (_ (error "Unexpected form in atom->bytecode" atom)))) + + + (define-record-type <not-empty> + (make-not-empty) + not-empty?) + + + (define *not-empty* (make-not-empty)) + + + (define (empty? m) + (guard (e ((not-empty? e) #f)) + (map-for-each (lambda (k v) + (raise *not-empty*)) + m) + #t)) + + + (define *temp-reg* 127) + + + (define (get-satisfying m pred) + (define elem #f) + (guard (e ((not-empty? e) elem)) + (map-for-each (lambda (k v) + (when (pred k) + (set! elem k) + (raise *not-empty*))) + m) + #f)) + + + (define (get-least m) + (define least #f) + (map-for-each (lambda (k v) + (when (or (not least) + (< k least)) + (set! least k))) + m) + least) + + + (define (chains in->out) + (define out->in (make-map compare-numbers)) + (map-for-each (lambda (k v) + (set! out->in (insert out->in v k))) + in->out) + (define currently-in-temp #f) + (loop with results = out->in + with save-regs = in->out + for easy-result = (get-satisfying results (lambda (x) (not (lookup save-regs x #f)))) + until (empty? results) + if easy-result + collect (let ((in (lookup out->in easy-result))) + (set! results (delete results easy-result)) + (set! save-regs (delete save-regs in)) + (list 'mov (list 'local easy-result) (list 'local (lookup out->in easy-result)))) + else if currently-in-temp + collect (let ((target (lookup in->out currently-in-temp))) + (set! results (delete results target)) + (list 'mov (list 'local target) (list 'local *temp-reg*))) + and do (set! currently-in-temp #f) + else + append (let* ((any-result (get-least results)) + (in (lookup out->in any-result))) + (set! currently-in-temp any-result) + (set! results (delete results any-result)) + (set! save-regs (delete save-regs any-result)) + (list + (list 'mov (list 'local *temp-reg*) (list 'local any-result)) + (list 'mov (list 'local any-result) (list 'local in)))))) + + + (define (hash-symbol s) + (hash-bytevector (string->utf8 (symbol->string s)))) + + + (define (cmp-symbols s1 s2) + (cond + ((symbol=? s1 s2) 0) + ((string<? (symbol->string s1) (symbol->string s2)) -1) + (else 1))) + + + (define (ir2->bytecode expr translate-local) + (define (a->b atom) + (atom->bytecode atom translate-local)) + (match expr + ((% %primitive op args res cont) + (cons + (append (list op) (map a->b res) (map a->b args)) + (ir2->bytecode cont translate-local))) + ((% %branch atom true false) + (define temp (translate-local (make-label (gensym)))) + (append + (list + (list 'jmpif (a->b atom) (list 'label temp))) + (ir2->bytecode false translate-local) + (list + (list 'label temp)) + (ir2->bytecode true translate-local))) + ((% %apply proc args) + (define in->out (make-map compare-numbers)) + (define constants + (loop for arg in args + for i from 1 + if (variable? arg) + unless (= (translate-local arg) i) + do (set! in->out (insert in->out (translate-local arg) i)) + end + else if (globals? arg) + do (set! in->out (insert in->out 0 i)) + else if (constant? arg) + collect (list 'mov (list 'local i) (list 'const (constant-expression arg))) + else if (label? arg) + collect (list 'mov (list 'local i) (list 'label (translate-local arg))) + else if (library-ref? arg) + collect (list 'mov (list 'local i) (list 'global + (library-ref-name arg) + (library-ref-library arg))) + else + do (error "Unexpected form in arguments list" arg))) + (define proc-temp (translate-local proc)) + (when (and (variable? proc) + (<= proc-temp (length args))) + (let ((available-reg (+ 1 (length args)))) + (set! in->out (insert in->out proc-temp available-reg)) + (set! proc-temp available-reg))) + (append + (chains in->out) + constants + (list + (if (label? proc) + (list 'jmp (list 'label proc-temp)) + (list 'jmp (list 'local proc-temp)))))) + ((% %tail) + (list + (list 'jmp (list 'label 0)))) + (_ (error "Unexpected form in ir2->bytecode expr")))) + + + (define compare-labels + (make-comparer + (lambda (x) (gensym->int (label-gensym x))) + (lambda (x y) (- (gensym->int (label-gensym y)) (gensym->int (label-gensym x)))))) + + + (define compare-variables + (make-comparer + (lambda (x) (gensym->int (variable-gensym x))) + (lambda (x y) (- (gensym->int (variable-gensym y)) (gensym->int (variable-gensym x)))))) + + + ; Converts an IR2 program into bytecode. + (define (ir2->ir3 expr) + (define label-map (make-map compare-labels)) + (define next-label-id 1) ; start at 1 because label 0 is used for tail. + (define (translate-label x) + (or (lookup label-map x #f) + (let ((id next-label-id)) + (set! next-label-id (+ 1 next-label-id)) + (set! label-map (insert label-map x id)) + id))) + (define (make-locals-map args) + (define locals-map (make-map compare-variables)) + (loop for arg in args + for i from 1 + do (set! locals-map (insert locals-map arg i))) + (define local-count (length args)) + (lambda (x) + (if (label? x) + (translate-label x) + (or (lookup locals-map x #f) + (begin + (set! local-count (+ 1 local-count)) + ; start at 1, because register 0 holds the globals array + (set! locals-map (insert locals-map x local-count)) + local-count))))) + (append + (ir2->bytecode (fix-body expr) (make-locals-map '())) + (loop for func in (fix-functions expr) + collect (list 'label (translate-label (closure-name func))) + append (ir2->bytecode (closure-body func) (make-locals-map (closure-arguments func)))) + (list + (list 'label 0)))))) diff --git a/lib/csc/compare-test.csc b/lib/csc/compare-test.csc new file mode 100644 index 0000000..b710115 --- /dev/null +++ b/lib/csc/compare-test.csc @@ -0,0 +1,98 @@ +(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=? + " ( + 1 + - 2 + 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)) + + + (test diff-record + (assert + (string=? + " ( + (!type . + <test-type> + ) + (a . + 5 + ) + (b . + - 5 + + 6 + ) + ) +" + (diff (make-test-type 5 5) (make-test-type 5 6) (cons test-type? %test-type))))) + + + (test diff-multiline-string + (assert + (string=? + " ( + (!type . + string + ) + (value . + ( + line-one + - line-two + line-three + ) + ) + ) +" + (diff "line-one\nline-two\nline-three" "line-one\nline-three")))) + + + (test diff-vector + (assert + (string=? + " ( + (!type . + vector + ) + (value . + ( + 1 + - 2 + 3 + ) + ) + ) +" + (diff #(1 2 3) #(1 3))))) + + + (test diff-symbol-list + (assert + (string=? + "- symbol ++ ( ++ ) +" + (diff 'symbol '())))))) diff --git a/lib/csc/compare.csc b/lib/csc/compare.csc new file mode 100644 index 0000000..e8e68d3 --- /dev/null +++ b/lib/csc/compare.csc @@ -0,0 +1,248 @@ +(define-library (csc compare) + (export diff apply-transformer) + (import (scheme base) + (only (scheme write) + display + write) + (only (csc strings) + contains? + split)) + (begin + ; compare is inspired by Go's cmp.Diff. + + + (define (print w . xs) + (unless (null? xs) + (let ((x (car xs))) + (if (or (string? x) + (symbol? x)) + (display x w) + (write x w))) + (apply print w (cdr xs)))) + + + (define (apply-transformer t x) + (if (list? t) + (let loop ((transformers t) + (x x)) + (if (null? transformers) + x + (loop (cdr transformers) + (apply-transformer (car transformers) x)))) + (if ((car t) x) + ((cdr t) x) + x))) + + + (define (alist? l) + (and (list? l) + (let loop ((l l)) + (cond + ((null? l) #t) + ((not (and (pair? (car l)) + (symbol? (caar l)))) + #f) + (else (loop (cdr l))))))) + + + (define (transform x transformers) + (define x* (apply-transformer transformers x)) + (cond + ((alist? x*) + (map (lambda (elem) + (define elem* (apply-transformer transformers elem)) + (if (pair? elem*) + (cons (car elem) (transform (cdr elem) transformers)) + elem*)) + x*)) + ((list? x*) + (map (lambda (elem) (transform elem transformers)) + x*)) + (else x*))) + + + ; As always, I copied the algorithm from Wikipedia + (define (lcs x y cmp) + (define x-vals (list->vector x)) + (define y-vals (list->vector y)) + (define table (make-vector (* (+ 1 (vector-length x-vals)) (+ 1 (vector-length y-vals))) 0)) + (define (index i j) + (+ j (* i (+ 1 (vector-length y-vals))))) + (let loop-i ((i 1)) + (when (<= i (vector-length x-vals)) + (let loop-j ((j 1)) + (when (<= j (vector-length y-vals)) + (if (cmp (vector-ref x-vals (- i 1)) (vector-ref y-vals (- j 1))) + (vector-set! table (index i j) (+ 1 (vector-ref table (index (- i 1) (- j 1))))) + (vector-set! table (index i j) (max (vector-ref table (index (- i 1) j)) + (vector-ref table (index i (- j 1)))))) + (loop-j (+ 1 j)))) + (loop-i (+ 1 i)))) + (let loop ((i (vector-length x-vals)) + (j (vector-length y-vals)) + (lcs '())) + (cond + ((or (= 0 i) (= 0 j)) lcs) + ((cmp (vector-ref x-vals (- i 1)) (vector-ref y-vals (- j 1))) + (loop (- i 1) (- j 1) (cons (vector-ref x-vals (- i 1)) lcs))) + ((> (vector-ref table (index i (- j 1))) (vector-ref table (index (- i 1) j))) + (loop i (- j 1) lcs)) + (else (loop (- i 1) j lcs))))) + + + (define (pretty w x indent) + (cond + ((list? x) + (print w indent " (\n") + (let ((new-indent (string-append indent " "))) + (for-each (lambda (v) + (pretty w v new-indent)) + x)) + (print w indent " )\n")) + ((and (pair? x) + (symbol? (car x))) + (print w indent " (" (car x) " .\n") + (pretty w (cdr x) (string-append indent " ")) + (print w indent " )\n")) + (else (print w indent " " x "\n")))) + + + (define (diff* w x y indent) + (cond + ((or (and (boolean? x) (boolean? y)) + (and (char? x) (char? y)) + (and (symbol? x) (symbol? y)) + (and (number? x) (number? y)) + (and (string? x) (string? y))) + (if (equal? x y) + (begin + (print w indent " " x "\n") + #t) + (begin + (print w indent "- " x "\n" indent "+ " y "\n") + #f))) + ((and (alist? x) (alist? y)) + (print w indent " (\n") + (let ((key-lcs (lcs (map car x) (map car y) symbol=?)) + (indent* (string-append indent " ")) + (equal #t)) + (let loop () + (unless (and (null? key-lcs) + (null? x) + (null? y)) + (cond + ((and (null? key-lcs) + (null? x)) + (pretty w (car y) (string-append indent* "+")) + (set! y (cdr y)) + (set! equal #f)) + ((null? key-lcs) + (pretty w (car x) (string-append indent* "-")) + (set! x (cdr x)) + (set! equal #f)) + ((symbol=? (caar x) (caar y) (car key-lcs)) + (print w indent* " (" (car key-lcs) " .\n") + (set! equal (and (diff* w (cdar x) (cdar y) (string-append indent* " ")) + equal)) + (print w indent* " )\n") + (set! x (cdr x)) + (set! y (cdr y)) + (set! key-lcs (cdr key-lcs))) + ((symbol=? (caar x) (car key-lcs)) + (pretty w (car y) (string-append indent* "+")) + (set! y (cdr y)) + (set! equal #f)) + (else + (pretty w (car x) (string-append indent* "-")) + (set! x (cdr x)) + (set! equal #f))) + (loop))) + (print w indent " )\n") + equal)) + ((and (list? x) (list? y)) + (print w indent " (\n") + (let* ((common (lcs x y equal?)) + (indent* (string-append indent " ")) + (equal #t)) + (let loop () + (unless (and (null? common) + (null? x) + (null? y)) + (cond + ((and (null? common) + (null? x)) + (pretty w (car y) (string-append indent* "+")) + (set! y (cdr y)) + (set! equal #f)) + ((and (null? common) + (null? y)) + (pretty w (car x) (string-append indent* "-")) + (set! x (cdr x)) + (set! equal #f)) + ((null? common) + (diff* w (car x) (car y) indent*) + (set! x (cdr x)) + (set! y (cdr y)) + (set! equal #f)) + ((equal? (car x) (car y)) + (pretty w (car x) (string-append indent* " ")) + (set! x (cdr x)) + (set! y (cdr y)) + (set! common (cdr common))) + ((equal? (car x) (car common)) + (pretty w (car y) (string-append indent* "+")) + (set! y (cdr y)) + (set! equal #f)) + ((equal? (car y) (car common)) + (pretty w (car x) (string-append indent* "-")) + (set! x (cdr x)) + (set! equal #f)) + (else + (diff* w (car x) (car y) indent*) + (set! x (cdr x)) + (set! y (cdr y)) + (set! equal #f))) + (loop))) + (print w indent " )\n") + equal)) + (else + (pretty w x (string-append indent "-")) + (pretty w y (string-append indent "+")) + #f))) + + + (define default-transformers + (list + (cons (lambda (s) + (and (string? s) + (contains? s "\n"))) + (lambda (s) + (list (cons '!type 'string) + (cons 'value (split s "\n"))))) + (cons vector? (lambda (v) + (list (cons '!type 'vector) + (cons 'value (vector->list v))))) + (cons bytevector? (lambda (b) + (list (cons '!type 'bytevector) + (cons 'value (let loop ((i 0) + (acc '())) + (when (< i (bytevector-length b)) + (loop (+ 1 i) + (cons (string-append "0x" (number->string + (bytevector-u8-ref b i) + 16)) + acc))) + (reverse acc)))))))) + + + ; Returns a string diff between x and y. Diff knows how to compare lists, + ; alists and other primitive types. Any user-defined type needs a + ; transformer. Each transformer is a pair of type predicate that the + ; transformer matches on, and a function that transforms a value of that + ; type into an alist. + (define (diff x y . transformers) + (define d (open-output-string)) + (define t* (cons default-transformers transformers)) + (if (diff* d (transform x t*) (transform y t*) "") + "" + (get-output-string d))))) diff --git a/lib/csc/compiler.csc b/lib/csc/compiler.csc new file mode 100644 index 0000000..20d5d37 --- /dev/null +++ b/lib/csc/compiler.csc @@ -0,0 +1,164 @@ +(define-library (csc compiler) + (export + *library-search-dirs* + compile) + (import (scheme base) + (only (scheme file) + call-with-input-file + file-exists?) + (only (scheme read) + read) + (only (csc codegen) + ir2->ir3) + (only (csc config) + *standard-library-dir*) + (only (csc cps) + closure-convert + ir1->ir2) + (only (csc encoding) + encode) + (only (csc format) + sprintf) + (only (csc hash-map) + compare-symbols + hash-bytevector + insert + key-not-found-error? + lookup + make-comparer + make-map + merge) + (only (csc ir1) + %define-syntax + %library-define + %library-ref + %sequence) + (only (csc ir2) + *tail*) + (only (csc linker) + link) + (only (csc list) + revappend) + (only (csc loop) + loop + return) + (only (csc macros) + builtins-environment + expand-body) + (only (csc match) + match) + (only (csc strings) + join)) + (begin + + + (define (normalize-library lib) + (match lib + (('define-library name . declarations) + (loop for decl in declarations + if (match decl (('export . _) #t) + (_ #f)) + collect (cdr decl) into exports + else if (match decl (('import . _) #t) + (_ #f)) + collect (cdr decl) into imports + else if (match decl (('begin . _) #t) + (_ #f)) + collect (cdr decl) into body + else + do (error "unexpected form in normalize-library" decl) + finally (return (list 'define-library name + (cons 'export exports) + (cons 'import imports) + (cons 'begin body))))) + (_ (error "unexpected form in normalize-library" lib)))) + + + (define compare-library-names + (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 *library-search-dirs* '()) + + + (define (find-library name) + (define library-roots (cons *standard-library-dir* *library-search-dirs*)) + (loop for dir in library-roots + for file-path = (loop for part in name + collect (symbol->string part) into path + finally (return (sprintf "{}/{}.csc" dir (join "/" path)))) + if (file-exists? file-path) + return file-path + else + collect file-path into bad-paths + finally (error "unable to find library" name bad-paths))) + + + (define (ir1->bytecode expr) + (ir2->ir3 (closure-convert (ir1->ir2 expr (lambda (x) *tail*))))) + + + ; compile turns scheme code into bytecode. + (define (compile program) + (define library-symbols (make-map compare-library-names)) + (define (make-import-map imports) + (define env (make-map compare-symbols)) + (loop for import in imports + do (set! env + (merge env (load-library import))) + finally (return env))) + (define library-code '()) + (define (compile-library lib) + (match (normalize-library lib) + (('define-library library-name + ('export . exports) + ('import . imports) + ('begin . body)) + + (define expanded-body (expand-body library-name body env)) + + (define env (make-import-map imports)) + (let loop ((expr expanded-body)) + (match expr + ((% %library-define (% %library-ref name _) val) + (set! env (insert env name val))) + ((% %define-syntax name val) + (set! env (insert env name val))) + ((% %sequence head tail) + (loop head) + (loop tail)))) + + (define exported-symbols (make-map compare-symbols)) + (loop for sym in exports + do (set! exported-symbols + (insert exported-symbols sym + (guard (e ((key-not-found-error? e) (error "exported symbol was not defined in the library" sym))) + (lookup env sym))))) + + (set! library-symbols (insert library-symbols library-name exported-symbols)) + (set! library-code (cons (ir1->bytecode expanded-body) library-code)) + exported-symbols) + (_ (error "unexpected form in compile-library" lib)))) + (define (load-library lib) + (match lib + ('(csc builtins) + builtins-environment) + (_ (or (lookup library-symbols lib #f) + (call-with-input-file (find-library lib) + (lambda (f) + (compile-library (read f)))))))) + + (match program + ((('import . imports1) ('import . imports2) . rest) + (compile (cons (list 'import (append imports1 imports2)) rest))) + ((('import . imports) . body) + (define compiled-body (ir1->bytecode (expand-body 'main body (make-import-map imports)))) + (encode (link (revappend library-code (list compiled-body (list (list 'exit (list 'const 0)))))))) + (_ (error "unexpected form in compile" program)))))) diff --git a/lib/csc/config.csc b/lib/csc/config.csc new file mode 100644 index 0000000..d2618a7 --- /dev/null +++ b/lib/csc/config.csc @@ -0,0 +1,7 @@ +(define-library (csc config) + (export *standard-library-dir*) + (import (scheme base)) + (begin + + + (define *standard-library-dir* "/usr/lib/csc"))) diff --git a/lib/csc/cps-test.csc b/lib/csc/cps-test.csc new file mode 100644 index 0000000..156ba60 --- /dev/null +++ b/lib/csc/cps-test.csc @@ -0,0 +1,499 @@ +(define-library (csc cps-test) + (import (scheme base) + (only (csc gensym) + gensym + gensym?) + (only (csc ir1) + %constant + %lexical-ref + %library-ref + constant? + lexical-ref? + library-ref? + make-call + make-call-builtin + make-constant + make-define-syntax + make-if + make-lambda + make-letrec + make-lexical-ref + make-lexical-set + make-library-ref + make-sequence) + (only (csc ir2) + %apply + %branch + %closure + %fix + %globals + %label + %primitive + %variable + *globals* + apply? + branch? + closure? + fix? + globals? + label? + make-apply + make-branch + make-call-closure + make-closure + make-fix + make-label + make-primitive + make-variable + primitive? + variable?) + (only (csc testing) + assert-equal + test) + (csc cps)) + (begin + + + (define transform-ir2 + (list + (cons constant? %constant) + (cons lexical-ref? %lexical-ref) + (cons library-ref? %library-ref) + (cons variable? %variable) + (cons globals? %globals) + (cons label? %label) + (cons primitive? %primitive) + (cons branch? %branch) + (cons apply? %apply) + (cons closure? %closure) + (cons fix? %fix) + (cons gensym? (lambda (x) 'gensym)))) + + + (define (test-ref name) + (make-lexical-ref name (gensym))) + + + (define (tail x) + (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-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 lexical-set + (assert-equal + (make-primitive 'poke (list (make-constant 5) (test-ref 'var) (make-constant 0)) '() + (make-apply (test-ref 'tail) (list (make-constant #f)))) + (ir1->ir2 (make-lexical-set (test-ref 'var) (make-constant 5)) + tail) + transform-ir2)) + + + (test no-op-define-syntax + (assert-equal + (make-apply (test-ref 'tail) (list (make-constant #f))) + (ir1->ir2 (make-define-syntax 'name '(transformer)) + tail) + transform-ir2)) + + + (test branch + (assert-equal + (make-fix + (list + (make-closure (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-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-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)) + + + ; 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))))) + (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-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))))) + (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)) + (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-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-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)))))) + (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))) + (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))) + + + (test closure-convert-primitive + (define a-sym (gensym)) + (define f-sym (gensym)) + (define ret-sym (gensym)) + (define x-sym (gensym)) + (assert-equal + (make-fix + (list (make-closure (make-label (gensym)) (list (test-var) (test-var) (test-var)) + (make-primitive 'peek (list (test-var) (make-constant 0)) (list (test-var)) + (make-primitive 'poke (list (test-var) (test-var) (make-constant 0)) '() + (make-primitive 'peek (list (test-var) (make-constant 0)) (list (test-var)) + (make-apply (test-var) (list (test-var) (make-constant #f)))))))) + (make-primitive 'alloc (list (make-constant 1)) (list (test-var)) + (make-primitive 'alloc (list (make-constant 2)) (list (test-var)) + (make-primitive 'poke (list (make-label (gensym)) (test-var) (make-constant 0)) '() + (make-primitive 'poke (list (test-var) (test-var) (make-constant 1)) '() + (make-primitive 'peek (list (test-var) (make-constant 0)) (list (test-var)) + (make-apply (test-var) (list (test-var) (make-library-ref 'tail '(csc builtins)) (make-constant 10))))))))) + (closure-convert (make-primitive 'alloc (list (make-constant 1)) (list (make-lexical-ref 'a a-sym)) + (make-fix + (list + (make-closure (make-lexical-ref 'f f-sym) (list (make-lexical-ref 'ret ret-sym) (make-lexical-ref 'x x-sym)) + (make-primitive 'poke (list (make-lexical-ref 'x x-sym) (make-lexical-ref 'a a-sym) (make-constant 0)) '() + (make-apply (make-lexical-ref 'ret ret-sym) (list (make-constant #f)))))) + (make-apply (make-lexical-ref 'f f-sym) (list (make-library-ref 'tail '(csc builtins)) (make-constant 10)))))) + transform-ir2)))) diff --git a/lib/csc/cps.csc b/lib/csc/cps.csc new file mode 100644 index 0000000..f2a9c90 --- /dev/null +++ b/lib/csc/cps.csc @@ -0,0 +1,602 @@ +(define-library (csc cps) + (export + closure-convert + ir1->ir2) + (import (scheme base) + (only (csc gensym) + gensym + gensym->int) + (only (csc hash-map) + insert + key-not-found-error? + lookup + make-comparer + make-map + map->alist + merge) + (only (csc ir1) + %call + %call-builtin + %define-syntax + %if + %lambda + %letrec + %lexical-ref + %lexical-set + %library-define + %library-ref + %sequence + call? + constant? + if? + lambda? + letrec-gensyms + letrec-names + letrec-values + letrec? + lexical-ref-gensym + lexical-ref? + lexical-set? + library-define? + library-ref? + make-call + make-call-builtin + make-constant + make-if + make-lambda + make-letrec + make-lexical-ref + make-lexical-set + make-library-define + make-library-ref + make-sequence + sequence?) + (only (csc ir2) + %apply + %branch + %fix + %primitive + %tail + *globals* + *tail* + branch-atom + closure-arguments + closure-body + closure-name + make-apply + make-branch + make-call-closure + make-closure + make-fix + make-label + make-label + make-primitive + make-variable + tail?) + (only (csc loop) + loop + return) + (only (csc match) + define-match-record-type + match)) + (begin + + + (define (new-ref) + (make-lexical-ref 'generated-symbol (gensym))) + + + ; Converts an IR1 expression to an equivalent expression where every + ; procedure takes exactly one argument. + (define (argument-conversion expr) + (match expr + (_ when (or (constant? expr) + (lexical-ref? expr) + (library-ref? expr)) + expr) + ((% %lexical-set ref arg) + (make-lexical-set ref (argument-conversion arg))) + ((% %library-define ref arg) + (make-library-define ref (argument-conversion arg))) + ((% %define-syntax _ _) expr) + ((% %if test consequent alternate) + (make-if + (argument-conversion test) + (argument-conversion consequent) + (argument-conversion alternate))) + ((% %call proc args) + (define argvec (new-ref)) + (define nargs (length args)) + (make-call + (make-lambda (list argvec) #f + (make-sequence + (loop for arg in args + for i from 2 + with expr = (make-sequence + (make-call-builtin 'poke (list (make-constant 0) argvec (make-constant 0))) + (make-call-builtin 'poke (list (make-constant nargs) argvec (make-constant 1)))) + do (set! expr (make-sequence + expr + (make-call-builtin 'poke (list (argument-conversion arg) argvec (make-constant i))))) + finally (return expr)) + (make-call (argument-conversion proc) (list argvec)))) + (list (make-call-builtin 'alloc (list (make-constant (+ 2 nargs))))))) + ((% %call-builtin op args) + (make-call-builtin op (map argument-conversion args))) + ((% %sequence head tail) + (make-sequence + (argument-conversion head) + (argument-conversion tail))) + ((% %lambda args rest body) when rest + (define argvec (new-ref)) + (define nargs (length args)) + (make-lambda (list argvec) #f + (make-if (make-call-builtin 'int<? (list (make-call-builtin 'peek (list argvec (make-constant 1))) + (make-constant nargs))) + (make-call (make-library-ref 'wrong-number-of-arguments '(csc based)) (list argvec)) + (loop for arg in (reverse args) + for i downfrom (+ 1 nargs) + with expr = (make-call (make-lambda (list rest) #f + (argument-conversion body)) + (list + (argument-conversion + (make-call (make-library-ref 'vector->list '(csc based)) + (list argvec (make-constant nargs)))))) + ; I'm relying on beta reduction here. + do (set! expr (make-call (make-lambda (list arg) #f + expr) + (list (make-call-builtin 'peek (list argvec (make-constant i)))))) + finally (return expr))))) + ((% %lambda args _ body) + (define argvec (new-ref)) + (define nargs (length args)) + (make-lambda (list argvec) #f + (make-if (make-call-builtin 'int=? (list (make-call-builtin 'peek (list argvec (make-constant 1))) + (make-constant nargs))) + (loop for arg in (reverse args) + for i downfrom (+ 1 nargs) + with expr = (argument-conversion body) + do (set! expr (make-call (make-lambda (list arg) #f + expr) + (list + (make-call-builtin 'peek (list argvec (make-constant i)))))) + finally (return expr)) + (make-call (make-library-ref 'wrong-number-of-arguments '(csc based)) (list argvec))))) + ((% %letrec in-order? names gensyms exprs body) + (make-letrec in-order? names gensyms (map argument-conversion exprs) (argument-conversion body))) + (_ (error "Unexpected form in argument-conversion" expr)))) + + + ; Update is a CPS expression that is used internally as part of + ; CPS conversion. + ; Update expressions are then removed by box-conversion. + (define-match-record-type <update> + (make-update ref atom continuation) + update? + %update + (ref update-ref) + (atom update-atom) + (continuation update-continuation)) + + + (define (collect-functions-and-variables expr) + (let ((names (letrec-names expr)) + (gensyms (letrec-gensyms expr)) + (vals (letrec-values expr))) + (loop for name in names + for gensym in gensyms + for value in vals + if (lambda? value) + collect (match value + ((% %lambda args _ body) + (define continuation (new-ref)) + (make-closure + (make-lexical-ref name gensym) + (cons continuation args) + (to-cps + body + (lambda (z) + (make-apply continuation (list z))))))) + into functions + else + collect (make-lexical-ref name gensym) into variable-names + and collect value into variable-values + finally (return (values functions variable-names variable-values))))) + + + ; Converts the given IR1 expression that has undergone argument conversion + ; into an IR2 expression in continuation passing style. + ; The resulting expression will include <update> forms. + (define (to-cps expr continuation) + (match expr + (_ when (or (constant? expr) + (lexical-ref? expr)) + (continuation expr)) + ((% %library-ref . _) + (unless (library-ref? expr) + (error "wtf")) + (define temp (new-ref)) + (make-primitive 'peek (list *globals* expr) (list temp) + (continuation temp))) + ((% %lexical-set ref arg) + (to-cps + arg + (lambda (val) + (make-update ref val (continuation (make-constant #f)))))) + ((% %library-define ref arg) + (to-cps + arg + (lambda (val) + (make-update ref val (continuation (make-constant #f)))))) + ((% %define-syntax _ _) + ; no-op + (continuation (make-constant #f))) + ((% %if test consequent alternate) + (to-cps + test + (lambda (val) + (define continuation-ref (new-ref)) + (define result-ref (new-ref)) + (make-fix + (list (make-closure continuation-ref (list result-ref) + (continuation result-ref))) + (make-branch val + (to-cps + consequent + (lambda (result) + (make-apply continuation-ref (list result)))) + (to-cps + alternate + (lambda (result) + (make-apply continuation-ref (list result))))))))) + ((% %call proc (arg)) + (define return-address (new-ref)) + (define result (new-ref)) + (make-fix + (list (make-closure return-address (list result) (continuation result))) + (to-cps + proc + (lambda (f) + (to-cps + arg + (lambda (v) + (make-apply f (list return-address v)))))))) + ((% %call-builtin op args) + (define returns-value? (not (memq op '(poke exit)))) + (loop for arg in (reverse args) + with expr = (lambda (vals) + (if returns-value? + (let ((result (new-ref))) + (make-primitive op (reverse vals) (list result) + (continuation result))) + (make-primitive op (reverse vals) '() + (continuation (make-constant #f))))) + do (set! expr (let ((e* expr) ; make copies to avoid modifying the expr in the closure. + (arg* arg)) + (lambda (vals) + (to-cps arg* + (lambda (val) + (e* (cons val vals))))))) + finally (return (expr '())))) + ((% %sequence head tail) + (to-cps + head + (lambda (x) + (to-cps + tail + continuation)))) + ((% %lambda (arg) _ body) + (define f (new-ref)) + (define k (new-ref)) + (make-fix + (list + (make-closure f (list k arg) + (to-cps + body + (lambda (ret) + (make-apply k (list ret)))))) + (continuation f))) + ((% %letrec _ _ _ _ body) + (define-values (functions variable-names variable-values) (collect-functions-and-variables expr)) + (if (null? variable-names) + (make-fix functions + (to-cps body continuation)) + (let ((new-expr (loop for var in (reverse variable-names) + for val in (reverse variable-values) + with new-body = (to-cps body continuation) + do (set! new-body (to-cps val (lambda (x) + (make-update var x + new-body)))) + finally (return new-body)))) + (unless (null? functions) + (set! new-expr (make-fix functions new-expr))) + (loop for var in variable-names + do (set! new-expr (make-primitive 'alloc (list (make-constant 1)) (list var) + new-expr)) + finally (return new-expr))))) + (_ (error "unexpected type in to-cps" expr)))) + + + (define compare-refs + (make-comparer + (lambda (ref) + (gensym->int (lexical-ref-gensym ref))) + (lambda (x y) + (- (gensym->int (lexical-ref-gensym y)) (gensym->int (lexical-ref-gensym x)))))) + + + (define (make-ref-map) + (make-map compare-refs)) + + + (define (get-boxed expr) + (match expr + ((% %update ref _ continuation) + (define m (get-boxed continuation)) + (when (lexical-ref? ref) + (set! m (insert m ref #t))) + m) + ((% %primitive _ _ _ continuation) + (get-boxed continuation)) + ((% %branch _ true false) + (merge + (get-boxed true) + (get-boxed false))) + ((% %apply proc args) + (make-ref-map)) + ((% %tail) + (make-ref-map)) + ((% %fix funs body) + (loop with m = (get-boxed body) + for fun in funs + do (set! m (merge m (get-boxed (closure-body fun)))) + finally (return m))) + (_ (error "Unexpected form in get-boxed" expr)))) + + + ; Rewrites the given expression to have no more <update> forms. + (define (box-conversion expr) + (define boxed-refs (get-boxed expr)) + (define (boxed? ref) + (and (lexical-ref? ref) + (guard (e ((key-not-found-error? e) #f)) + (lookup boxed-refs ref)))) + (define (convert-arg-list args) + (define boxed-args (loop for arg in args + if (boxed? arg) + collect arg)) + (define vars (loop for x in boxed-args + collect (new-ref))) + (define new-args (loop with v* = vars + for arg in args + collect (if (boxed? arg) + (car v*) + arg) + if (boxed? arg) + do (set! v* (cdr v*)))) + (values new-args boxed-args vars)) + (let convert ((expr expr)) + (match expr + ((% %update ref atom continuation) when (library-ref? ref) + (make-primitive 'poke (list atom *globals* ref) '() + (convert continuation))) + ((% %update ref atom continuation) when (lexical-ref? ref) + (make-primitive 'poke (list atom ref (make-constant 0)) '() (convert continuation))) + ((% %primitive op args res continuation) + ; Note that no reference in res can be boxed. + (define-values (new-args boxed-args vars) (convert-arg-list args)) + (define new-expr (make-primitive op new-args res (convert continuation))) + (loop for arg in boxed-args + for var in vars + do (set! new-expr (make-primitive 'peek (list arg (make-constant 0)) (list var) + new-expr)) + finally (return new-expr))) + ((% %branch atom true false) when (boxed? atom) + (define temp (new-ref)) + (make-primitive 'peek (list atom (make-constant 0)) (list temp) + (make-branch temp + (convert true) + (convert false)))) + ((% %branch atom true false) + (make-branch atom + (convert true) + (convert false))) + ((% %apply proc args) + (define-values (new-params boxed-params vars) (convert-arg-list (cons proc args))) + (define new-expr (make-apply (car new-params) (cdr new-params))) + (loop for p in boxed-params + for var in vars + do (set! new-expr (make-primitive 'peek (list p (make-constant 0)) (list var) + new-expr)) + finally (return new-expr))) + ((% %tail) + *tail*) + ((% %fix funs body) + (define-values (new-names boxed-names temp-names) (convert-arg-list (loop for fun in funs + collect (closure-name fun)))) + (define new-funs (loop for fun in funs + for new-name in new-names + collect (let-values (((new-args boxed-args temp-args) (convert-arg-list (closure-arguments fun)))) + (make-closure + new-name + new-args + (let ((new-expr (convert (closure-body fun)))) + (loop for arg in boxed-args + for var in temp-args + do (set! new-expr (make-primitive 'alloc (list (make-constant 1)) (list arg) + (make-primitive 'poke (list var arg (make-constant 0)) '() + new-expr))) + finally (return new-expr))))))) + (define new-body (convert body)) + (loop for name in boxed-names + for var in temp-names + do (set! new-body (make-primitive 'poke (list var name (make-constant 0)) '() + new-body))) + (define new-expr (make-fix new-funs new-body)) + (loop for name in boxed-names + do (set! new-expr (make-primitive 'alloc (list (make-constant 1)) (list name) + new-expr)) + finally (return new-expr))) + (_ (error "Unexpected form in box-conversion" expr))))) + + + (define (ir1->ir2 expr continuation) + (box-conversion + (to-cps + (argument-conversion expr) + continuation))) + + + (define (hoist expr) + (define functions '()) + (define body + (let hoist ((expr expr)) + (match expr + ((% %primitive op args res cont) + (make-primitive op args res (hoist cont))) + ((% %branch atom true false) + (make-branch atom (hoist true) (hoist false))) + ((% %apply . _) expr) + ((% %tail) expr) + ((% %fix funs body) + (set! functions (append funs functions)) + (hoist body)) + (_ (error "Unexpected form in hoist" expr))))) + (make-fix functions body)) + + + (define (free-vars-expr expr bound-vars) + (define (free? ref) + (and (lexical-ref? ref) + (not (guard (e ((key-not-found-error? e) #f)) + (lookup bound-vars ref))))) + (match expr + ((% %primitive _ args res continuation) + (loop for r in res + if (lexical-ref? r) + do (set! bound-vars (insert bound-vars r #t))) + (loop with m = (free-vars-expr continuation bound-vars) + for arg in args + if (free? arg) + do (set! m (insert m arg #t)) + finally (return m))) + ((% %branch atom true false) + (define m (merge (free-vars-expr true bound-vars) (free-vars-expr false bound-vars))) + (if (free? atom) + (set! m (insert m atom #t))) + m) + ((% %apply proc args) + (define m (make-ref-map)) + (if (free? proc) + (set! m (insert m proc #t))) + (loop for arg in args + if (free? arg) + do (set! m (insert m arg #t)) + finally (return m))) + ((% %tail) + (make-ref-map)) + ((% %fix funs body) + (loop for fun in funs + for name = (closure-name fun) + if (lexical-ref? name) + do (set! bound-vars (insert bound-vars name #t))) + (define m (free-vars-expr body bound-vars)) + (loop for fun in funs + do (set! m (merge m (free-vars-closure fun bound-vars))) + finally (return m))) + (_ (error "Unexpected form in free-vars-expr" expr)))) + + + (define (free-vars-closure fun bound-vars) + (define name (closure-name fun)) + (when (lexical-ref? name) + (set! bound-vars (insert bound-vars name #t))) + (loop for arg in (closure-arguments fun) + do (set! bound-vars (insert bound-vars arg #t))) + (free-vars-expr (closure-body fun) bound-vars)) + + + ; Returns a list of the free variables in a closure. + (define (free-vars expr) + (define m (free-vars-closure expr (make-ref-map))) + (map car (map->alist m))) + + + (define (translate-ref ref env) + (if (lexical-ref? ref) + (guard (e ((key-not-found-error? e) (error "Undefined symbol in closure-convert" ref))) + (lookup env ref)) + ref)) + + + ; converts a CPS expression into an equivalent expression with no + ; free variables. + (define (closure-convert expr) + (hoist + (let convert ((expr expr) + (env (make-ref-map))) + (define (translate ref) + (translate-ref ref env)) + (match expr + ((% %primitive op args res continuation) + (loop for r in res + do (set! env (insert env r (make-variable (gensym))))) + (make-primitive op (map translate args) (map translate res) (convert continuation env))) + ((% %branch atom true false) + (make-branch (translate atom) (convert true env) (convert false env))) + ((% %apply proc args) + (let ((p (translate proc)) + (fn (make-variable (gensym)))) + (make-primitive 'peek (list p (make-constant 0)) (list fn) + (make-apply fn (cons p (map translate args)))))) + ((% %tail) + *tail*) + ((% %fix functions body) + (define frees (map free-vars functions)) + (define fn-ptrs (loop for fun in functions + collect (make-label (gensym)))) + (define converted-functions (loop for fun in functions + for fn-ptr in fn-ptrs + for free-list in frees + for env* = env + for name = (closure-name fun) + for closure = (make-variable (gensym)) + if (lexical-ref? name) + do (set! env* (insert env* name closure)) + do (loop for arg in (closure-arguments fun) + do (set! env* (insert env* arg (make-variable (gensym))))) + (loop for var in free-list + do (set! env* (insert env* var (make-variable (gensym))))) + collect (let ((new-body (convert (closure-body fun) env*))) + (loop for var in free-list + for i from 0 + do (set! new-body (make-primitive 'peek (list closure (make-constant i)) (list (translate-ref var env*)) + new-body))) + (make-closure + fn-ptr + (cons closure (map (lambda (x) (translate-ref x env*)) (closure-arguments fun))) + new-body)))) + (loop for fun in functions + for name = (closure-name fun) + if (lexical-ref? name) + do (set! env (insert env name (make-variable (gensym))))) + (let ((new-body (convert body env))) + ; Build the closures. + (loop for fun in functions + for free-list in frees + for ptr in fn-ptrs + for closure = (translate (closure-name fun)) + do (loop for var in free-list + for i from 1 + do (set! new-body (make-primitive 'poke (list (translate var) closure (make-constant i)) '() + new-body))) + (set! new-body (make-primitive 'poke (list ptr closure (make-constant 0)) '() + new-body))) + ; Allocate the closures. + (loop for fun in functions + for free-list in frees + for closure = (translate (closure-name fun)) + do (set! new-body (make-primitive 'alloc (list (make-constant (+ 1 (length free-list)))) (list closure) + new-body))) + (make-fix converted-functions new-body))) + (_ (error "Unexpected form in closure-convert" expr)))))))) diff --git a/lib/csc/encoding-test.csc b/lib/csc/encoding-test.csc new file mode 100644 index 0000000..6b28d8e --- /dev/null +++ b/lib/csc/encoding-test.csc @@ -0,0 +1,121 @@ +(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-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-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-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-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-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-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-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-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-pokebyte + (assert-equal + #u8(48 1 2 3) + (encode '((pokebyte (local 1) (local 2) (local 3)))))) + + + (test encode-exit + (assert-equal + #u8(#x36 #x1 0 0 0 0 0 0 0) + (encode '((exit (const 0)))))))) diff --git a/lib/csc/encoding.csc b/lib/csc/encoding.csc new file mode 100644 index 0000000..9afa40f --- /dev/null +++ b/lib/csc/encoding.csc @@ -0,0 +1,184 @@ +(define-library (csc encoding) + (export encode) + (import (scheme base) + (only (csc loop) + loop + return) + (only (csc match) match)) + (begin + ; I'm only going to say this once, so pay attention. + ; The format of unboxed constants is described in bytecocde/src/data.rs. + ; Boxed values are represented by a pointer to an array on the heap. The + ; first position in the array is an integer code indicating what type the + ; object is. Vectors have code 0, codes for other types are not stable. + ; Vectors are represented as an array, the first element of which is the + ; integer 0 (the type code), the second element is the vector length, and + ; the remaining slots hold the array values. + + + (define (low-byte w n) + (write-u8 (remainder n #x100) w)) + + + (define (64->le-bytes w n) + (low-byte w n) + (low-byte w (quotient n #x100)) + (low-byte w (quotient n #x10000)) + (low-byte w (quotient n #x1000000)) + (low-byte w (quotient n #x100000000)) + (low-byte w (quotient n #x10000000000)) + (low-byte w (quotient n #x1000000000000)) + (low-byte w (quotient n #x100000000000000))) + + + ; Bitwise-negates a 63-bit unsigned integer. + (define (bitwise-not n) + (loop with n* = 0 + for i from 1 to 63 + for n = n then (quotient n 2) + for digit = 1 then (* 2 digit) + if (even? n) + do (set! n* (+ n* digit)) + finally (return n*))) + + + (define (int->le-bytes w n) + (when (or (>= n #x4000000000000000) + (< n #x-4000000000000000)) + (error "int constant too large" n)) + (when (negative? n) + (set! n (remainder + (+ 1 (bitwise-not (- n))) + #x8000000000000000))) + (64->le-bytes w (+ 1 (* 2 n)))) + + + (define (bool->le-bytes w b) + (if b + (64->le-bytes w #xa) + (64->le-bytes w #x2))) + + + (define (const->le-bytes w x) + (cond + ((integer? x) + (int->le-bytes w x)) + ((boolean? x) + (bool->le-bytes w x)) + ((null? x) + (64->le-bytes w #x12)) + (else (error "unexpected type in const->le-bytes" x)))) + + + (define (make-opcode w code arg1-const arg2-const) + (when (>= code #x40) + (error "code is more than 6 bits" code)) + (define arg1-bit (if arg1-const + 2 + 0)) + (define arg2-bit (if arg2-const + 1 + 0)) + (write-u8 (+ (* 4 code) arg1-bit arg2-bit) w)) + + + (define (arg->le-bytes w atom) + (match atom + (('const val) (const->le-bytes w val)) + (('local i) + (when (>= i #x100) + (error "local index is out of range" i)) + (write-u8 i w)) + (_ (error "unexpected form in arg->le-bytes" atom)))) + + + (define (is-const? atom) + (match atom + (('const _) #t) + (_ #f))) + + + (define (opcode-switch w opcode) + (match opcode + (('mov dest src) + (make-opcode w 0 (is-const? src) #f) + (arg->le-bytes w dest) + (arg->le-bytes w src)) + (('jmpif test dest) + (make-opcode w 1 (is-const? test) (is-const? dest)) + (arg->le-bytes w test) + (arg->le-bytes w dest)) + (('jmp dest) + (make-opcode w 2 (is-const? dest) #f) + (arg->le-bytes w dest)) + (('alloc dest size) + (make-opcode w 3 (is-const? size) #f) + (arg->le-bytes w dest) + (arg->le-bytes w size)) + (('peek dest ptr offset) + (make-opcode w 4 (is-const? ptr) (is-const? offset)) ; ptr will likely never be constant. + (arg->le-bytes w dest) + (arg->le-bytes w ptr) + (arg->le-bytes w offset)) + (('poke word ('local ptr) offset) + ; We only have 2 bits to store whether the arguments are const, but + ; it's actually true that a pointer can never be a constant. So we + ; only track whether the word and offset arguments are constant, and + ; assume ptr will always be a one-byte register name. + (make-opcode w 5 (is-const? word) (is-const? offset)) + (arg->le-bytes w word) + (arg->le-bytes w (list 'local ptr)) + (arg->le-bytes w offset)) + (('add dest x y) + (make-opcode w 6 (is-const? x) (is-const? y)) + (arg->le-bytes w dest) + (arg->le-bytes w x) + (arg->le-bytes w y)) + (('sub dest x y) + (make-opcode w 7 (is-const? x) (is-const? y)) + (arg->le-bytes w dest) + (arg->le-bytes w x) + (arg->le-bytes w y)) + (('mul dest x y) + (make-opcode w 8 (is-const? x) (is-const? y)) + (arg->le-bytes w dest) + (arg->le-bytes w x) + (arg->le-bytes w y)) + (('div dest x y) + (make-opcode w 9 (is-const? x) (is-const? y)) + (arg->le-bytes w dest) + (arg->le-bytes w x) + (arg->le-bytes w y)) + (('mod dest x y) + (make-opcode w 10 (is-const? x) (is-const? y)) + (arg->le-bytes w dest) + (arg->le-bytes w x) + (arg->le-bytes w y)) + (('peekbyte dest ptr offset) + (make-opcode w 11 (is-const? ptr) (is-const? offset)) + (arg->le-bytes w dest) + (arg->le-bytes w ptr) + (arg->le-bytes w offset)) + (('pokebyte word ('local ptr) offset) + (make-opcode w 12 (is-const? word) (is-const? offset)) + (arg->le-bytes w word) + (arg->le-bytes w (list 'local ptr)) + (arg->le-bytes w offset)) + (('exit code) + (make-opcode w 13 (is-const? code) #f) + (arg->le-bytes w code)) + (('alloc-bytevector dest size) + (make-opcode w 14 (is-const? size) #f) + (arg->le-bytes w dest) + (arg->le-bytes w size)) + (('typeof dest x) + (make-opcode w 15 (is-const? x) #f) + (arg->le-bytes w dest) + (arg->le-bytes w x)) + (_ (error "invalid opcode" opcode)))) + + + (define (encode program) + (define out (open-output-bytevector)) + (map (lambda (op) (opcode-switch out op)) program) + (get-output-bytevector out)))) diff --git a/lib/csc/flag.csc b/lib/csc/flag.csc new file mode 100644 index 0000000..c0a28a8 --- /dev/null +++ b/lib/csc/flag.csc @@ -0,0 +1,119 @@ +(define-library (csc flag) + (export + *args* + bool-flag + define-bool-flag + define-flag + parse-error-flag + parse-error-msg + parse-error? + parse-flags) + (import (scheme base) + (only (scheme process-context) + command-line) + (only (csc hash-map) + compare-strings + insert + key-not-found-error? + lookup + make-map) + (only (csc loop) + loop) + (only (csc match) + match) + (only (csc strings) + contains? + has-prefix? + split)) + (begin + + + (define (bool-flag s) + (cond + ((member s '("1" "t" "T" "true" "TRUE" "True")) + #t) + ((member s '("0" "f" "F" "false" "FALSE" "False")) + #f) + (else (error "Argument could not be parsed as a boolean" s)))) + + + (define *parsers* (make-map compare-strings)) + ; I'm working around a Guile bug, which wrongly concludes + ; that *parsers* is immutable. + (set! *parsers* *parsers*) + + + (define-record-type <flag> + (make-flag bool? setter) + flag? + (bool? flag-bool?) + (setter flag-setter)) + + + (define-syntax define-flag + (syntax-rules () + ((define-flag name flag type default) + (begin + (define name default) + (set! *parsers* (insert *parsers* flag + (make-flag (eq? type bool-flag) + (lambda (x) (set! name (type x)))))))))) + + + (define *args* '()) + + + (define-record-type <parse-error> + (make-parse-error msg flag) + parse-error? + (msg parse-error-msg) + (flag parse-error-flag)) + + + (define (parse-flags) + (define args (cdr (command-line))) + ; Is this legal? + (define (parse-one) + (match args + ('() #f) + ((s . _) when (or (not (has-prefix? s "-")) + (string=? "-" s)) + #f) + ((s . rest) when (string=? "--" s) + (set! args rest) + #f) + ((s . rest) + (define name (if (has-prefix? s "--") + (string-copy s 2) + (string-copy s 1))) + (when (or (string=? "" name) + (has-prefix? name "-") + (has-prefix? name "=")) + (raise (make-parse-error "bad flag syntax" s))) + ; It's a flag. Does it have an argument? + (set! args rest) + (define value (match (split name "=" 2) + ((a b) + (set! name a) + b) + (_ #f))) + (define flag (guard (e ((key-not-found-error? e) + (raise (make-parse-error "flag provided but not defined" s)))) + (lookup *parsers* name))) + (if (flag-bool? flag) ; Special case: doesn't need an arg. + (if value + ((flag-setter flag) value) + ((flag-setter flag) "true")) + (begin + ; It must have a value, which might be the next argument. + (when (and (not value) + (not (null? args))) + ; value is the next arg + (set! value (car args)) + (set! args (cdr args))) + (unless value + (raise (make-parse-error "flag needs an argument" s))) + ((flag-setter flag) value))) + #t))) + (loop while (parse-one)) + (set! *args* args)))) diff --git a/lib/csc/format-test.csc b/lib/csc/format-test.csc new file mode 100644 index 0000000..1906af6 --- /dev/null +++ b/lib/csc/format-test.csc @@ -0,0 +1,26 @@ +(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-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-escape-open + (assert-equal "{" (sprintf "{{"))) + + + (test sprintf-escape-close + (assert-equal "}" (sprintf "}}"))))) diff --git a/lib/csc/format.csc b/lib/csc/format.csc new file mode 100644 index 0000000..6ffd736 --- /dev/null +++ b/lib/csc/format.csc @@ -0,0 +1,50 @@ +(define-library (csc format) + (export + fprintf + printf + sprintf) + (import (scheme base) + (only (scheme write) + display) + (only (csc loop) + loop) + (only (csc strings) + index + has-prefix?)) + (begin + + + (define (fprintf port format-string . args) + (loop with s = format-string + until (string=? "" s) + if (has-prefix? s "{{") + do (write-string "{" port) + (set! s (string-copy s 2)) + else if (has-prefix? s "}}") + do (write-string "}" port) + (set! s (string-copy s 2)) + else if (has-prefix? s "{}") + do (display (car args) port) + (set! args (cdr args)) + (set! s (string-copy s 2)) + else if (or (has-prefix? s "{") + (has-prefix? s "}")) + do (error "invalid format string" format-string) + else + do (let* ((open-brace-pos (index s "{")) + (close-brace-pos (index s "}")) + (format-pos (min open-brace-pos close-brace-pos))) + (when (negative? format-pos) + (set! format-pos (string-length s))) + (write-string s port 0 format-pos) + (set! s (string-copy s format-pos))))) + + + (define (printf format-string . format-args) + (apply fprintf (current-output-port) format-string format-args)) + + + (define (sprintf format-string . format-args) + (let ((string-builder (open-output-string))) + (apply fprintf string-builder format-string format-args) + (get-output-string string-builder))))) diff --git a/lib/csc/gensym.csc b/lib/csc/gensym.csc new file mode 100644 index 0000000..480cbc2 --- /dev/null +++ b/lib/csc/gensym.csc @@ -0,0 +1,27 @@ +(define-library (csc gensym) + (export + gensym + gensym->int + gensym=? + gensym?) + (import (scheme base)) + (begin + + + (define-record-type <gensym> + (make-gensym id) + gensym? + (id gensym->int)) + + + (define (gensym=? s1 s2) + (= (gensym->int s1) (gensym->int s2))) + + + (define *next-id* 0) + + + (define (gensym) + (let ((sym (make-gensym *next-id*))) + (set! *next-id* (+ 1 *next-id*)) + sym)))) diff --git a/lib/csc/hash-map-test.csc b/lib/csc/hash-map-test.csc new file mode 100644 index 0000000..6f83c30 --- /dev/null +++ b/lib/csc/hash-map-test.csc @@ -0,0 +1,155 @@ +(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))))) + + + (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-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-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-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)) + + + (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-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 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-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-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)))) diff --git a/lib/csc/hash-map.csc b/lib/csc/hash-map.csc new file mode 100644 index 0000000..682fa30 --- /dev/null +++ b/lib/csc/hash-map.csc @@ -0,0 +1,492 @@ +(define-library (csc hash-map) + (export + alist->map + compare-numbers + compare-strings + compare-symbols + delete + hash-bytevector + insert + key-not-found-error? + lookup + make-comparer + make-map + map->alist + map-for-each + map? + merge) + (import (scheme base) + (only (csc loop) + loop + return) + (only (csc match) + define-match-record-type + match) + (only (scheme case-lambda) + case-lambda)) + (begin + + + (define-record-type <key-hash> + (make-key-hash k hash) + key-hash? + (k key-hash-value) + (hash key-hash-hash)) + + + (define (cmp-key-hash k1 k2 cmp) + (define d (- (key-hash-hash k2) (key-hash-hash k1))) + (if (zero? d) + (cmp (key-hash-value k1) (key-hash-value k2)) + d)) + + + (define-match-record-type <node> + (make-node color key-hash val left right) + node? + %node + (color node-color) + (key-hash node-key) + (val node-value) + (left node-left) + (right node-right)) + + + (define (red? n) + (and (not (null? n)) + (eq? 'red (node-color n)))) + + + (define (black? n) + (or (null? n) + (eq? 'black (node-color n)))) + + + (define (node-kv n) + (cons (node-key n) (node-value n))) + + + (define (node-colored color kv left right) + (make-node color (car kv) (cdr kv) left right)) + + + (define (red-node kv left right) + (node-colored 'red kv left right)) + + (define (black-node kv left right) + (node-colored 'black kv left right)) + + + (define (rebalance-left m) + (define p (node-left m)) + (define u (node-right m)) + (cond + ((or (and (red? p) + (red? (node-left p)) + (red? u)) + (and (red? p) + (red? (node-right p)) + (red? u))) + ; b r + ; / \ / \ + ; r r => b b + ; / / + ; r r + + ; b r + ; / \ / \ + ; r r => b b + ; \ \ + ; r r + (red-node (node-kv m) + (black-node (node-kv p) (node-left p) (node-right p)) + (black-node (node-kv u) (node-left u) (node-right u)))) + ((and (red? p) + (red? (node-right p)) + (black? u)) + ; b b + ; / \ / \ + ; r b => r r + ; \ \ + ; r b + (let ((n (node-right p))) + (make-node 'black (node-key n) (node-value n) + (make-node 'red (node-key p) (node-value p) (node-left p) (node-left n)) + (make-node 'red (node-key m) (node-value m) (node-right n) u)))) + ((and (red? p) + (red? (node-left p)) + (black? u)) + ; b b + ; / \ / \ + ; r b => r r + ; / \ + ; r b + (make-node 'black (node-key p) (node-value p) + (node-left p) + (make-node 'red (node-key m) (node-value m) (node-right p) u))) + (else m))) + + + (define (rebalance-right m) + (define u (node-left m)) + (define p (node-right m)) + (cond + ((or (and (red? u) + (red? p) + (red? (node-left p))) + (and (red? u) + (red? p) + (red? (node-right p)))) + ; b r + ; / \ / \ + ; r r => b b + ; \ \ + ; r r + + ; b r + ; / \ / \ + ; r r => b b + ; / / + ; r r + (make-node 'red (node-key m) (node-value m) + (make-node 'black (node-key u) (node-value u) (node-left u) (node-right u)) + (make-node 'black (node-key p) (node-value p) (node-left p) (node-right p)))) + ((and (black? u) + (red? p) + (red? (node-left p))) + ; b b + ; / \ / \ + ; b r => r r + ; / / + ; r b + (let ((n (node-left p))) + (make-node 'black (node-key n) (node-value n) + (make-node 'red (node-key m) (node-value m) u (node-left n)) + (make-node 'red (node-key p) (node-value p) (node-right n) (node-right p))))) + ((and (black? u) + (red? p) + (red? (node-right p))) + ; b b + ; / \ / \ + ; b r => r r + ; \ / + ; r b + (make-node 'black (node-key p) (node-value p) + (make-node 'red (node-key m) (node-value m) u (node-left p)) + (node-right p))) + (else m))) + + + (define (insert-node n k v cmp) + (match n + ('() (make-node 'red k v '() '())) + ((% %node color node-key node-val left right) + (define ord (cmp-key-hash k node-key cmp)) + (cond + ((negative? ord) + (rebalance-left + (make-node color node-key node-val + (insert-node left k v cmp) + right))) + ((zero? ord) + (make-node color k v left right)) + (else + (rebalance-right + (make-node color node-key node-val + left + (insert-node right k v cmp)))))))) + + + (define-record-type <map> + (construct-map hash cmp root) + map? + (hash map-raw-hash) + (cmp map-cmp) + (root map-root)) + + + (define-record-type <comparer> + (make-comparer hash cmp) + comparer? + (hash comparer-hash) + (cmp comparer-cmp)) + + + (define (make-map comparer) + (construct-map (comparer-hash comparer) (comparer-cmp comparer) '())) + + + (define (shuffle n) + (remainder + (* #x9e3779b97f4a7c55 n) + #x10000000000000000)) + + + (define (map-hash m) + (lambda (k) + (shuffle ((map-raw-hash m) k)))) + + + (define (insert m k v) + (define res (insert-node (map-root m) (make-key-hash k ((map-hash m) k)) v (map-cmp m))) + (construct-map + (map-raw-hash m) + (map-cmp m) + (make-node 'black (node-key res) (node-value res) (node-left res) (node-right res)))) + + + (define-record-type <key-not-found-error> + (make-key-not-found-error) + key-not-found-error?) + + + (define *key-not-found-error* (make-key-not-found-error)) + + + (define lookup + (case-lambda + ((m k) + (define cmp (map-cmp m)) + (define k* (make-key-hash k ((map-hash m) k))) + (let loop ((n (map-root m))) + (match n + ('() (raise *key-not-found-error*)) + ((% %node _ node-key node-val left right) + (define ord (cmp-key-hash k* node-key cmp)) + (cond + ((negative? ord) + (loop left)) + ((zero? ord) + node-val) + (else + (loop right))))))) + ((m k def) + (guard (e ((key-not-found-error? e) def)) + (lookup m k))))) + + + (define (map-for-each f m) + (let loop ((n (map-root m))) + (match n + ((% %node _ node-key node-val left right) + (loop left) + (f (key-hash-value node-key) node-val) + (loop right))))) + + + (define (map->alist m) + (let ((alist '())) + (map-for-each + (lambda (k v) + (set! alist (cons (cons k v) alist))) + m) + alist)) + + + (define (alist->map comparer alist) + (loop with m = (make-map comparer) + for elem in alist + do (set! m (insert m (car elem) (cdr elem))) + finally (return m))) + + + (define (hash-bytevector b) + (loop for i from 0 below (bytevector-length b) + with hash = 0 + do (set! hash (remainder + (+ (* hash #x100) (bytevector-u8-ref b i)) + #x10000000000000000)) + finally (return hash))) + + + (define compare-symbols + (make-comparer + (lambda (s) (hash-bytevector (string->utf8 (symbol->string s)))) + (lambda (s1 s2) + (cond + ((symbol=? s1 s2) 0) + ((string<? (symbol->string s1) (symbol->string s2)) -1) + (else 1))))) + + + (define compare-numbers + (make-comparer + (lambda (x) x) + (lambda (y x) (- y x)))) + + + (define compare-strings + (make-comparer + (lambda (s) (hash-bytevector (string->utf8 s))) + (lambda (s1 s2) + (cond + ((string=? s1 s2) 0) + ((string<? (symbol->string s1) (symbol->string s2)) -1) + (else 1))))) + + + (define (merge2 m1 m2) + (let ((m1 m1)) + (map-for-each + (lambda (k v) + (set! m1 (insert m1 k v))) + m2) + m1)) + + + (define (merge m . m*) + (let loop ((m* m*) + (m m)) + (match m* + ('() m) + ((head . tail) (loop tail (merge2 m head)))))) + + + ; Jinkies! + (define (delete m k) + (define cmp (map-cmp m)) + (define k* (make-key-hash k ((map-hash m) k))) + ; local variables + (define need-fix #f) + (define replacement-node #f) + + (define (fix-black-height-left p) + ; n.b.: s must not be nil, because we deleted a black node and so + ; there must be at least one node in s to balance out the + ; black height. + (define s (node-right p)) + (define n (node-left p)) + (define c (node-left s)) + (define d (node-right s)) + (set! need-fix #f) + (cond + ((red? s) + ; p s + ; / \ / \ + ; n s => p d + ; / \ / \ + ; c d n c + (black-node (node-kv s) + (fix-black-height-left + (red-node (node-kv p) n c)) + d)) + ((red? d) + (node-colored (node-color p) (node-kv s) + (black-node (node-kv p) n c) + (black-node (node-kv d) (node-left d) (node-right d)))) + ((red? c) + (fix-black-height-left + (node-colored (node-color p) (node-kv p) + n + (black-node (node-kv c) + (node-left c) + (red-node (node-kv s) + (node-right c) + d))))) + ((red? p) + (black-node (node-kv p) + n + (red-node (node-kv s) c d))) + (else + (set! need-fix #t) ; This is the only recursive case. + (black-node (node-kv p) + n + (red-node (node-kv s) c d))))) + (define (fix-black-height-right p) + (define s (node-left p)) + (define n (node-right p)) + (define c (node-right s)) + (define d (node-left s)) + (set! need-fix #f) + (cond + ((red? s) + (black-node (node-kv s) + d + (fix-black-height-right + (red-node (node-kv p) c n)))) + ((red? d) + (node-colored (node-color p) (node-kv s) + (black-node (node-kv d) (node-left d) (node-right d)) + (black-node (node-kv p) c n))) + ((red? c) + ; p p + ; / \ / \ + ; s n => c n + ; / \ / + ; d c s + ; / + ; d + (fix-black-height-right + (node-colored (node-color p) (node-kv p) + (black-node (node-kv c) + (red-node (node-kv s) + d + (node-left c)) + (node-right c)) + n))) + ((red? p) + (black-node (node-kv p) + (red-node (node-kv s) d c) + n)) + (else + (set! need-fix #t) + (black-node (node-kv p) + (red-node (node-kv s) d c) + n)))) + (construct-map (map-raw-hash m) cmp + (let loop ((n (map-root m))) + (match n + ('() '()) + ((% %node color nk nv left right) + (define ord (cmp-key-hash k* nk cmp)) + (cond + ((negative? ord) + (let* ((left* (loop left)) + (n* (make-node color nk nv left* right))) + (if need-fix + (fix-black-height-left n*) + n*))) + ((positive? ord) + (let* ((right* (loop right)) + (n* (make-node color nk nv left right*))) + (if need-fix + (fix-black-height-right n*) + n*))) + ((and (not (null? left)) + (not (null? right))) + (let* ((left* (let find-max ((r left)) + (match r + ((% %node _ _ _ r-left '()) + (set! replacement-node r) + (cond + ((red? r) '()) + ((null? r-left) + (set! need-fix #t) + '()) + (else + (black-node (node-kv r-left) + (node-left r-left) + (node-right r-left))))) + ((% %node r-color r-k r-v r-left r-right) + (define n* (make-node r-color r-k r-v + r-left + (find-max r-right))) + (if need-fix + (fix-black-height-right n*) + n*))))) + (n* (node-colored color (node-kv replacement-node) left* right))) + (if need-fix + (fix-black-height-left n*) + n*))) + ((red? n) '()) + ((and (null? left) + (null? right)) + (set! need-fix #t) + '()) + (else + (let ((child (if (null? left) + right + left))) + (black-node (node-kv child) + (node-left child) + (node-right child)))))))))))) diff --git a/lib/csc/ir1.csc b/lib/csc/ir1.csc new file mode 100644 index 0000000..b91e8ab --- /dev/null +++ b/lib/csc/ir1.csc @@ -0,0 +1,215 @@ +(define-library (csc ir1) + (export + %call + %call-builtin + %constant + %define-syntax + %if + %lambda + %letrec + %lexical-ref + %lexical-set + %library-define + %library-ref + %sequence + call-arguments + call-builtin-arguments + call-builtin-operation + call-builtin? + call-procedure + call? + constant-expression + constant? + define-syntax-name + define-syntax-transformer + define-syntax? + if-alternate + if-consequent + if-test + if? + lambda-arguments + lambda-body + lambda-rest + lambda? + letrec-expression + letrec-gensyms + letrec-in-order? + letrec-names + letrec-values + letrec? + lexical-ref-gensym + lexical-ref-name + lexical-ref? + lexical-set-expression + lexical-set-ref + lexical-set? + library-define-expression + library-define-ref + library-define? + library-ref-library + library-ref-name + 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-define + make-library-ref + make-sequence + sequence-head + sequence-tail + sequence?) + (import (scheme base) + (only (csc list) + all) + (only (csc loop) loop return) + (only (csc match) + define-match-record-type)) + (begin + ; This library defines the intermediate representation IR1. An expression + ; in IR1 has one of the following forms (plagiarized from Guile's + ; Tree-IL). + + + ; <constant> expression + ; Constant is used to include literal constants in scheme code. + (define-match-record-type <constant> + (make-constant expression) + constant? + %constant + (expression constant-expression)) + + + ; <lexical-ref> name gensym + ; A reference to a lexically-bound variable. The name is the original name + ; of the variable in the source program. gensym is a unique identifier for + ; this variable. + (define-match-record-type <lexical-ref> + (make-lexical-ref name gensym) + lexical-ref? + %lexical-ref + (name lexical-ref-name) + (gensym lexical-ref-gensym)) + + + ; <library-ref> name + ; A free reference to a variable in a library. If the library is 'main, + ; then it is a top-level global variable. + (define-match-record-type <library-ref> + (make-library-ref name library) + library-ref? + %library-ref + (name library-ref-name) + (library library-ref-library)) + + + ; <lexical-set> name gensym expression + ; Sets a lexically-bound variable. + (define-match-record-type <lexical-set> + (make-lexical-set ref expression) + lexical-set? + %lexical-set + (ref lexical-set-ref) + (expression lexical-set-expression)) + + + ; <library-define> name expression + ; Defines a new variable in the current library. + (define-match-record-type <library-define> + (make-library-define ref expression) + library-define? + %library-define + (ref library-define-ref) + (expression library-define-expression)) + + + ; <define-syntax> name transformer + ; Defines a new macro in the current environment. name is the name of the + ; macro. transformer is a macro transformer. + (define-match-record-type <define-syntax> + (make-define-syntax name transformer) + define-syntax? + %define-syntax + (name define-syntax-name) + (transformer define-syntax-transformer)) + + + ; <if> test consequent alternate + ; A conditional. + (define-match-record-type <if> + (make-if test consequent alternate) + if? + %if + (test if-test) + (consequent if-consequent) + (alternate if-alternate)) + + + ; <call> procedure arguments + ; A procedure call. The procedure and arguments are evaluated in an + ; unspecified order, and the resulting procedure is passed the + ; resulting arguments. + (define-match-record-type <call> + (make-call procedure arguments) + call? + %call + (procedure call-procedure) + (arguments call-arguments)) + + + ; <call-builtin> operation arguments + ; Executes the given builtin operation on the arguments. The known builtin + ; operations are listed below. Each operation can return a value, or not. + ; - alloc: size -> result + ; - peek: pointer * offset -> result + ; - poke: word * pointer * offset -> () + ; - int<?: int * int -> bool + (define-match-record-type <call-builtin> + (make-call-builtin operation arguments) + call-builtin? + %call-builtin + (operation call-builtin-operation) + (arguments call-builtin-arguments)) + + + ; <sequence> head tail + ; Evaluate head, ignoring any result. Then tail is evaluated. + (define-match-record-type <sequence> + (make-sequence head tail) + sequence? + %sequence + (head sequence-head) + (tail sequence-tail)) + + + ; <lambda> body + ; A closure. Arguments is a list of lexical-refs. + ; Rest is a lexical ref or #f if the lambda doesn't take a rest parameter. + (define-match-record-type <lambda> + (make-lambda arguments rest body) + lambda? + %lambda + (arguments lambda-arguments) + (rest lambda-rest) + (body lambda-body)) + + + ; <letrec> in-order? names gensyms values expression + ; Lexical binding, like Scheme's letrec, or letrec* if in-order? is true. + ; names are the original binding names, gensyms are gensyms corresponding + ; to the names, and values are IR1 expressions for the values. expression + ; is a single IR1 expression. + (define-match-record-type <letrec> + (make-letrec in-order? names gensyms values expression) + letrec? + %letrec + (in-order? letrec-in-order?) + (names letrec-names) + (gensyms letrec-gensyms) + (values letrec-values) + (expression letrec-expression)))) diff --git a/lib/csc/ir2.csc b/lib/csc/ir2.csc new file mode 100644 index 0000000..888437f --- /dev/null +++ b/lib/csc/ir2.csc @@ -0,0 +1,217 @@ +(define-library (csc ir2) + (export + %apply + %branch + %closure + %fix + %globals + %label + %primitive + %tail + %variable + *globals* + *tail* + apply-arguments + apply-procedure + apply? + branch-atom + branch-false + branch-true + branch? + call-closure-args + call-closure-closure + call-closure? + closure-arguments + closure-body + closure-name + closure-rest + closure? + fix-body + fix-functions + fix? + globals? + label-gensym + label? + make-apply + make-branch + make-call-closure + make-closure + make-fix + make-label + make-primitive + make-variable + primitive-arguments + primitive-continuation + primitive-operation + primitive-results + primitive? + tail? + variable-gensym + variable? + + ; Re-exports from IR1. + %constant + %library-ref + constant-expression + constant? + lexical-ref-gensym + lexical-ref-name + lexical-ref? + lexical-set-expression + lexical-set-ref + lexical-set? + library-ref-library + library-ref-name + library-ref? + make-constant + make-lexical-ref + make-lexical-set + make-library-ref) + (import (scheme base) + (only (csc ir1) + %constant + %library-ref + constant-expression + constant? + lexical-ref-gensym + lexical-ref-name + lexical-ref? + lexical-set-expression + lexical-set-ref + lexical-set? + library-ref-library + library-ref-name + library-ref? + make-constant + make-lexical-ref + make-lexical-set + make-library-ref) + (only (csc list) all) + (only (csc loop) + loop + return) + (only (csc match) + define-match-record-type + match)) + (begin + ; This library defines the intermediate representation IR2. + ; It's CPS time bitch. + + ; CPS atom: + ; An atom is a value that can be computed immediately without + ; any subexpressions. + ; Atoms consist of + ; - constant, + ; - lexical-ref, + ; - library-ref, + ; - or globals. + ; After closure conversion, there are no more lexical refs. + ; Each lexical ref will be converted to a <variable>. + + + ; A function argument or local variable. + (define-match-record-type <variable> + (make-variable gensym) + variable? + %variable + (gensym variable-gensym)) + + + ; The globals array. This will eventually be stored in register 0. + (define-match-record-type <globals> + (make-globals) + globals? + %globals) + + + ; A global instance of <globals>. + ; Considered equal to calling (make-globals). + (define *globals* (make-globals)) + + + ; A label, used for function names and will compile to a constant. + (define-match-record-type <label> + (make-label gensym) + label? + %label + (gensym label-gensym)) + + + ; CPS expressions: + ; CPS expressions are similar to IR1 expressions, + ; but constrained not to have any subexpressions except atoms. + ; And they take a continuation. + + + ; A primitive encodes one of a number of primitive operations. + ; Each operation takes a number of arguments, + ; and binds some number of result variables. + ; The known primitives are listed below, along with their arity. + ; - alloc: size -> result + ; - peek: pointer * offset -> result + ; - poke: word * pointer * offset -> () + ; - exit: code -> () + (define-match-record-type <primitive> + (make-primitive operation arguments results continuation) + primitive? + %primitive + (operation primitive-operation) + (arguments primitive-arguments) + (results primitive-results) + (continuation primitive-continuation)) + + + ; Branches depending on the given atom. + ; If it is true, continue with continuation true. + ; If false, continue with continuation false. + (define-match-record-type <branch> + (make-branch atom true false) + branch? + %branch + (atom branch-atom) + (true branch-true) + (false branch-false)) + + + ; Applies a procedure to a list of arguments. Apply does not take a + ; continuation. Instead the continuation will be passed as the first + ; argument to the function. + (define-match-record-type <apply> + (make-apply procedure arguments) + apply? + %apply + (procedure apply-procedure) + (arguments apply-arguments)) + + + ; The tail continuation. Used for the exit point of library init functions, + ; and the end of a program. + (define-match-record-type <tail> + (make-tail) + tail? + %tail) + + + (define *tail* (make-tail)) + + + ; A procedure. All closures are allocated in a fix expression. A closure + ; does not take a continuation. Instead, the procedure will accept the + ; continuation as an argument. + (define-match-record-type <closure> + (make-closure name arguments body) + closure? + %closure + (name closure-name) + (arguments closure-arguments) + (body closure-body)) + + + ; Defines a list of mutually recursive procedures. + ; Functions is a list of closures, and body is an expression. + (define-match-record-type <fix> + (make-fix functions body) + fix? + %fix + (functions fix-functions) + (body fix-body)))) diff --git a/lib/csc/linker-test.csc b/lib/csc/linker-test.csc new file mode 100644 index 0000000..adbcf91 --- /dev/null +++ b/lib/csc/linker-test.csc @@ -0,0 +1,49 @@ +(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 + + + (test link-labels + (assert-equal + '((alloc (local 0) (const 0)) + (jmp (const 2)) + (jmp (const 1))) + (link + '(((label 0) + (jmp (label 1)) + (label 1) + (jmp (label 0))))))) + + + (test link-labels-are-unique-per-program + (assert-equal + '((alloc (local 0) (const 0)) + (jmp (const 1)) + (jmp (const 2))) + (link + '(((label 0) + (jmp (label 0))) + ((label 0) + (jmp (label 0))))))) + + + (test link-globals + (assert-equal + '((alloc (local 0) (const 11)) + (peek (local 1) (local 0) (const 10))) + (link + '(((peek (local 1) (local 0) (global cons (csc based))))) + (alist->map compare-globals '(((global cons (csc based)) . 10)))))))) diff --git a/lib/csc/linker.csc b/lib/csc/linker.csc new file mode 100644 index 0000000..5e4e678 --- /dev/null +++ b/lib/csc/linker.csc @@ -0,0 +1,119 @@ +(define-library (csc linker) + (export + add-to-environment + compare-globals + link) + (import (scheme base) + (only (csc format) + sprintf) + (only (csc hash-map) + compare-numbers + hash-bytevector + insert + lookup + make-comparer + make-map + map-for-each) + (only (csc loop) + loop + return) + (only (csc match) match) + (only (scheme case-lambda) + case-lambda)) + (begin + ; A CSC bytecode program is a list of opcodes and labels. An opcode is a + ; list of an opcode and arguments. Arguments can be any of: + ; - (local x), + ; - (global x lib), + ; - (const x), + ; - or (label x). + ; The full list of opcodes can be found in encoding.csc. + + + ; Rewrites each (label x) form into a integer constant. + (define (translate-labels program label-map) + (loop for opcode in program + for op = (car opcode) + for args = (cdr opcode) + unless (symbol=? op 'label) + collect (cons op (loop for arg in args + collect (match arg + (('label x) + (list 'const (lookup label-map x))) + (_ arg)))))) + + + (define (make-label-map offset program) + (loop for op in program + for i from offset + with m = (make-map compare-numbers) + do (match op + (('label id) + (set! m (insert m id i)) + (set! i (- i 1)))) ; Labels will be removed later. + finally (return m))) + + + (define (add-to-environment environment programs) + (define next-global-id 0) + (map-for-each (lambda (k v) + (when (>= v next-global-id) + (set! next-global-id (+ 1 v)))) + environment) + (loop for opcode in (apply append programs) + do (loop for arg in (cdr opcode) + do (match arg + (('global name lib) + (define id next-global-id) + (set! next-global-id (+ 1 next-global-id)) + (set! environment (insert environment arg id)))))) + environment) + + + (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 (translate-globals program environment) + (loop for opcode in program + for op = (car opcode) + for args = (cdr opcode) + collect (cons op (loop for arg in args + collect (match arg + (('global x lib) + (list 'const (lookup environment arg))) + (_ arg)))))) + + + (define (num-globals environment) + (define n 0) + (map-for-each (lambda (k v) + (when (<= n v) + (set! n (+ 1 v)))) + environment) + n) + + + (define link + (case-lambda + ((programs environment) + (append + (list + (list 'alloc (list 'local 0) (list 'const (num-globals environment)))) + (translate-globals + (loop for prog in programs + for off = 1 then (+ off (length converted-prog)) + for converted-prog = (translate-labels + prog + (make-label-map off prog)) + append converted-prog) + environment))) + ((programs) + (link programs (add-to-environment (make-map compare-globals) programs))))))) diff --git a/lib/csc/list-test.csc b/lib/csc/list-test.csc new file mode 100644 index 0000000..dd5d640 --- /dev/null +++ b/lib/csc/list-test.csc @@ -0,0 +1,123 @@ +(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-negative + (assert-equal '() (take -5 '(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-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)))))) + + + (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-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-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-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 intercalate-simple + (assert-equal '("a" "," "b" "," "c") (intercalate "," '("a" "b" "c")))) + + + (test intercalate-empty + (assert-equal '() (intercalate "," '()))) + + + (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-nil + (assert-equal '() (enumerate '()))) + + + (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-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-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 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)))))) diff --git a/lib/csc/list.csc b/lib/csc/list.csc new file mode 100644 index 0000000..b1c2298 --- /dev/null +++ b/lib/csc/list.csc @@ -0,0 +1,85 @@ +(define-library (csc list) + (export + all + enumerate + filter + intercalate + revappend + split-at + take + unzip) + (import (scheme base) + (only (csc loop) + loop + return) + (only (csc match) + match)) + (begin + + + (define (take n xs) + (loop for x in xs + for i from 1 to n + collect x)) + + + (define (split-at n xs) + (if (<= n 0) + (values '() xs) + (loop for i from 1 to n + for x in xs + for second-half = (cdr xs) then (cdr second-half) + collect x into first-half + finally (return (values first-half second-half))))) + + + (define (revappend a b) + (let loop ((xs a) + (acc b)) + (if (null? xs) + acc + (loop (cdr xs) (cons (car xs) acc))))) + + + (define (intercalate x l) + (match l + ('() '()) + ((_) l) + ((head . tail) (cons head (cons x (intercalate x tail)))))) + + + (define (enumerate l) + (let loop ((i 0) + (l l)) + (match l + ('() '()) + ((head . tail) (cons (cons i head) (loop (+ 1 i) tail)))))) + + + (define (filter p l) + (let loop ((l l) + (acc '())) + (match l + ('() (reverse acc)) + ((x . xs) + (if (p x) + (loop xs (cons x acc)) + (loop xs acc)))))) + + + (define (unzip l) + (loop for x in l + collect (car x) into xs + collect (cdr x) into ys + finally (return (values xs ys)))) + + + (define (all pred . ls) + (loop for ls = ls then (map cdr ls) + while (loop for l in ls + if (null? l) + return #f + finally (return #t)) + unless (apply pred (map car ls)) + return #f + finally (return #t))))) diff --git a/lib/csc/loop-test.csc b/lib/csc/loop-test.csc new file mode 100644 index 0000000..50090e0 --- /dev/null +++ b/lib/csc/loop-test.csc @@ -0,0 +1,294 @@ +(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-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-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-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-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-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-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-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 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-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-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-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-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-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-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-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-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-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-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-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/lib/csc/loop.csc b/lib/csc/loop.csc new file mode 100644 index 0000000..f07deae --- /dev/null +++ b/lib/csc/loop.csc @@ -0,0 +1,419 @@ +(define-library (csc loop) + (export loop return) + (import (scheme base)) + (begin + + + ; Once more, from the top! + + + (define-record-type <return-exception> + (make-return-exception thunk) + return-exception? + (thunk return-exception-values)) + + + (define-syntax return + (syntax-rules () + ((return expr) + (raise (make-return-exception (lambda () expr)))) + ((return) + (return #f)))) + + + (define-record-type <loop-termination> + (make-loop-termination) + loop-termination?) + + + (define *loop-termination* (make-loop-termination)) + + + ; loop is a general purpose looping construct cribbed from CL. + (define-syntax loop + (syntax-rules () + ((loop loop-clauses* ...) + (let ((list-acc '()) + (number-acc 0) + (acc-last #f) + (first #t)) + (letrec-syntax + ((loop-aux + (... (syntax-rules (= above across and append below by collect count do downfrom downto else end finally for from if in into maximize minimize on return sum then to unless until when while with) + ((loop-aux "variable-clause-collector" args with x = expr and clause* ...) + (loop-aux "and-collector" args ((x expr)) and clause* ...)) + ((loop-aux "variable-clause-collector" args with x = expr clause* ...) + (let ((x expr)) + (loop-aux "variable-clause-collector" args clause* ...))) + ((loop-aux "variable-clause-collector" (body (fin ...)) finally (form1 form1* ...) (form2 form2* ...) clause* ...) + (loop-aux "variable-clause-collector" (body (fin ... (form1 form1* ...))) finally (form2 form2* ...) clause* ...)) + ((loop-aux "variable-clause-collector" (body (fin ...)) finally (form form* ...) clause* ...) + (loop-aux "variable-clause-collector" (body (fin ... (form form* ...))) clause* ...)) + ((loop-aux "variable-clause-collector" ((body ...) fin) for x in l clause* ...) + (let ((temp l) + (x #f)) + (loop-aux "variable-clause-collector" + ((body ... (when (null? temp) + (raise *loop-termination*)) + (set! x (car temp)) + (set! temp (cdr temp))) + fin) + clause* ...))) + ((loop-aux "variable-clause-collector" ((body ...) fin) for x on l clause* ...) + (let* ((x l)) + (loop-aux "variable-clause-collector" + ((body ... (unless first + (set! x (cdr x))) + (unless (pair? x) + (raise *loop-termination*))) + fin) + clause* ...))) + ((loop-aux "variable-clause-collector" ((body ...) fin) for x = init then subseq clause* ...) + (let ((init-value (lambda () init)) ; put the body of init outside the scope of x. + (x #f)) + (loop-aux "variable-clause-collector" + ((body ... (if first + (set! x (init-value)) + (set! x subseq))) + fin) + clause* ...))) + ((loop-aux "variable-clause-collector" ((body ...) fin) for x = init clause* ...) + (let ((x #f)) + (loop-aux "variable-clause-collector" + ((body ... (set! x init)) + fin) + clause* ...))) + ((loop-aux "variable-clause-collector" ((body ...) fin) for x across v clause* ...) + (let ((temp v) + (i 0) + (x #f)) + (loop-aux "variable-clause-collector" + ((body ... (unless (< i (vector-length temp)) + (raise *loop-termination*)) + (set! x (vector-ref temp i)) + (set! i (+ 1 i))) + fin) + clause* ...))) + ((loop-aux "variable-clause-collector" ((body ...) fin) for x from start to last by inc clause* ...) + (let* ((last* last) + (inc* inc) + (x start)) + (loop-aux "variable-clause-collector" + ((body ... (unless first + (set! x (+ x inc*))) + (unless (<= x last*) + (raise *loop-termination*))) + fin) + clause* ...))) + ((loop-aux "variable-clause-collector" ((body ...) fin) for x from start downto last by inc clause* ...) + (let* ((last* last) + (inc* inc) + (x start)) + (loop-aux "variable-clause-collector" + ((body ... (unless first + (set! x (+ x inc*))) + (unless (>= x last*) + (raise *loop-termination*))) + fin) + clause* ...))) + ((loop-aux "variable-clause-collector" ((body ...) fin) for x from start below last by inc clause* ...) + (let* ((last* last) + (inc* inc) + (x start)) + (loop-aux "variable-clause-collector" + ((body ... (unless first + (set! x (+ x inc*))) + (unless (< x last*) + (raise *loop-termination*))) + fin) + clause* ...))) + ((loop-aux "variable-clause-collector" ((body ...) fin) for x from start above last by inc clause* ...) + (let* ((last* last) + (inc* inc) + (x start)) + (loop-aux "variable-clause-collector" + ((body ... (unless first + (set! x (+ x inc))) + (unless (> x last*) + (raise *loop-termination*))) + fin) + clause* ...))) + ((loop-aux "variable-clause-collector" args for x clause* ...) + (loop-aux "for-reordering" args for x #f #f #f #f clause* ...)) + ((loop-aux "variable-clause-collector" args clause* ...) + (loop-aux "main-clause-collector" args clause* ...)) + ((loop-aux "and-collector" args (and-vars ...) and x = expr and clause* ...) + (loop-aux "and-collector" args (and-vars ... (x expr)) and clause* ...)) + ((loop-aux "and-collector" args (and-vars ...) and x = expr clause* ...) + (let (and-vars ... (x expr)) + (loop-aux "variable-clause-collector" args clause* ...))) + ((loop-aux "for-reordering" args for x #f to-clause by-clause stepping from start clause* ...) + (let ((start* start)) + (loop-aux "for-reordering" args for x start* to-clause by-clause stepping clause* ...))) + ((loop-aux "for-reordering" args for x #f to-clause by-clause 1 downfrom start clause* ...) + (syntax-error "inconsistent stepping")) + ((loop-aux "for-reordering" args for x #f to-clause by-clause _ downfrom start clause* ...) + (let ((start* start)) + (loop-aux "for-reordering" args for x start* to-clause by-clause -1 clause* ...))) + ((loop-aux "for-reordering" args for x from-clause #f by-clause stepping to last clause* ...) + (let ((last* last)) + (loop-aux "for-reordering" args for x from-clause (to last*) by-clause stepping clause* ...))) + ((loop-aux "for-reordering" args for x from-clause #f by-clause 1 downto last clause* ...) + (syntax-error "inconsistent stepping")) + ((loop-aux "for-reordering" args for x from-clause #f by-clause _ downto last clause* ...) + (let ((last* last)) + (loop-aux "for-reordering" args for x from-clause (downto last*) by-clause -1 clause* ...))) + ((loop-aux "for-reordering" args for x from-clause #f by-clause -1 below last clause* ...) + (syntax-error "inconsistent stepping")) + ((loop-aux "for-reordering" args for x from-clause #f by-clause _ below last clause* ...) + (let ((last* last)) + (loop-aux "for-reordering" args for x from-clause (below last*) by-clause 1 clause* ...))) + ((loop-aux "for-reordering" args for x from-clause #f by-clause 1 above last clause* ...) + (syntax-error "inconsistent stepping")) + ((loop-aux "for-reordering" args for x from-clause #f by-clause _ above last clause* ...) + (let ((last* last)) + (loop-aux "for-reordering" args for x from-clause (above last*) by-clause -1 clause* ...))) + ((loop-aux "for-reordering" args for x from-clause to-clause #f stepping by inc clause* ...) + (let ((inc* inc)) + (loop-aux "for-reordering" args for x from-clause to-clause inc* stepping clause* ...))) + ((loop-aux "for-reordering" args for x #f #f #f _ clause* ...) + (syntax-error "need at least one for subclause")) + ((loop-aux "for-reordering" args for x from-clause to-clause inc #f clause* ...) + (loop-aux "for-reordering" args for x from-clause to-clause inc 1 clause* ...)) + ((loop-aux "for-reordering" args for x #f to-clause inc 1 clause* ...) + (loop-aux "for-reordering" args for x 0 to-clause inc 1 clause* ...)) + ((loop-aux "for-reordering" args for x from-clause to-clause #f stepping clause* ...) + (loop-aux "for-reordering" args for x from-clause to-clause 1 stepping clause* ...)) + ((loop-aux "for-reordering" ((body ...) fin) for x start #f inc stepping clause* ...) + (let* ((inc* inc) + (x start)) + (loop-aux "variable-clause-collector" + ((body ... (unless first + (set! x (+ x inc*)))) + fin) + clause* ...))) + ; The word `to' is ambiguous as to which stepping, so replace to with downto if stepping is -1. + ((loop-aux "for-reordering" args for x start (to last) inc -1 clause* ...) + (loop-aux "for-reordering" args for x start (downto last) inc -1 clause* ...)) + ; Put the reordered form back into variable-clause-collector. + ((loop-aux "for-reordering" args for x start (to-clause ...) inc stepping clause* ...) + (loop-aux "variable-clause-collector" args for x from start to-clause ... by (* stepping inc) clause* ...)) + ((loop-aux "main-clause-collector" args do clause* ...) + (loop-aux "unconditional" ("unconditional-main-continuation" args) () do clause* ...)) + ((loop-aux "main-clause-collector" args return clause* ...) + (loop-aux "unconditional" ("unconditional-main-continuation" args) () return clause* ...)) + ((loop-aux "main-clause-collector" args collect clause* ...) + (loop-aux "accumulation" ("accumulation-main-continuation" args) () collect clause* ...)) + ((loop-aux "main-clause-collector" args append clause* ...) + (loop-aux "accumulation" ("accumulation-main-continuation" args) () append clause* ...)) + ((loop-aux "main-clause-collector" args count clause* ...) + (loop-aux "accumulation" ("accumulation-main-continuation" args) () count clause* ...)) + ((loop-aux "main-clause-collector" args sum clause* ...) + (loop-aux "accumulation" ("accumulation-main-continuation" args) () sum clause* ...)) + ((loop-aux "main-clause-collector" args maximize clause* ...) + (loop-aux "accumulation" ("accumulation-main-continuation" args) () maximize clause* ...)) + ((loop-aux "main-clause-collector" args minimize clause* ...) + (loop-aux "accumulation" ("accumulation-main-continuation" args) () minimize clause* ...)) + ((loop-aux "main-clause-collector" args if clause* ...) + (loop-aux "conditional" ("conditional-main-continuation" args) () if clause* ...)) + ((loop-aux "main-clause-collector" args when clause* ...) + (loop-aux "conditional" ("conditional-main-continuation" args) () if clause* ...)) + ((loop-aux "main-clause-collector" args unless clause* ...) + (loop-aux "conditional" ("conditional-main-continuation" args) () unless clause* ...)) + ((loop-aux "main-clause-collector" ((body ...) fin) while expr clause* ...) + (loop-aux "main-clause-collector" + ((body ... (unless expr + (raise *loop-termination*))) + fin) + clause* ...)) + ((loop-aux "main-clause-collector" args until expr clause* ...) + (loop-aux "main-clause-collector" args while (not expr) clause* ...)) + ((loop-aux "main-clause-collector" (body (fin ...)) finally (form1 form1* ...) (form2 form2* ...) clause* ...) + (loop-aux "main-clause-collector" (body (fin ... (form1 form1* ...))) finally (form2 form2* ...) clause* ...)) + ((loop-aux "main-clause-collector" (body (fin ...)) finally (form form* ...) clause* ...) + (loop-aux "main-clause-collector" (body (fin ... (form form* ...))) clause* ...)) + ((loop-aux "main-clause-collector" ((body ...) (fin ...))) + (let loop-name () + (guard (e ((loop-termination? e) fin ...)) + body ... + (set! first #f) + (loop-name)))) + ((loop-aux "unconditional" continuation (compound ...) do (form1 form1* ...) (form2 form2* ...) clause* ...) + (loop-aux "unconditional" continuation (compound ... (form1 form1* ...)) do (form2 form2* ...) clause* ...)) + ((loop-aux "unconditional" (continuation ...) (compound ...) do (form form* ...) clause* ...) + (loop-aux continuation ... (compound ... (form form* ...)) clause* ...)) + ((loop-aux "unconditional" continuation compound return expr (form ...) clause* ...) + (syntax-error "unexpected form after return" (form ...))) + ((loop-aux "unconditional" continuation compound return expr clause* ...) + (loop-aux "unconditional" continuation compound do (return expr) clause* ...)) + ((loop-aux "unconditional-main-continuation" ((body ...) fin) (compound ...) clause* ...) + (loop-aux "main-clause-collector" ((body ... compound ...) fin) clause* ...)) + ((loop-aux "accumulation" (continuation ...) (compound ...) collect x into l clause* ...) + (let ((l '()) + (last #f)) + (loop-aux continuation ... + (compound ... (let ((p (list x))) + (if last + (set-cdr! last p) + (set! l p)) + (set! last p))) + clause* ...))) + ((loop-aux "accumulation" continuation compound collect x (form ...) clause* ...) + (syntax-error "unexpected form after collect" (form ...))) + ((loop-aux "accumulation" (continuation ...) (compound ...) collect x clause* ...) + (loop-aux continuation ... + (compound ... (let ((p (list x))) + (if acc-last + (set-cdr! acc-last p) + (set! list-acc p)) + (set! acc-last p))) + clause* ... finally (return list-acc))) + ((loop-aux "accumulation" (continuation ...) (compound ...) append x into l clause* ...) + (let ((l '()) + (last #f)) + (loop-aux continuation ... + (compound ... (loop for elem in x + for p = (list elem) + do (if last + (set-cdr! last p) + (set! l p)) + (set! last p))) + clause* ...))) + ((loop-aux "accumulation" (continuation ...) (compound ...) append x clause* ...) + (loop-aux continuation ... + (compound ... (loop for elem in x + for p = (list elem) + do (if acc-last + (set-cdr! acc-last p) + (set! list-acc p)) + (set! acc-last p))) + clause* ... finally (return list-acc))) + ((loop-aux "accumulation" (continuation ...) (compound ...) count x into n clause* ...) + (let ((n 0)) + (loop-aux continuation ... + (compound ... (when x + (set! n (+ 1 n)))) + clause* ...))) + ((loop-aux "accumulation" (continuation ...) (compound ...) count x clause* ...) + (loop-aux continuation ... + (compound ... (when x + (set! number-acc (+ 1 number-acc)))) + clause* ... finally (return number-acc))) + ((loop-aux "accumulation" (continuation ...) (compound ...) sum x into n clause* ...) + (let ((n 0)) + (loop-aux continuation ... + (compound ... (set! n (+ x n))) + clause* ...))) + ((loop-aux "accumulation" (continuation ...) (compound ...) sum x clause* ...) + (loop-aux continuation ... + (compound ... (set! number-acc (+ x number-acc))) + clause* ... finally (return number-acc))) + ((loop-aux "accumulation" (continuation ...) (compound ...) maximize x into n clause* ...) + (let ((n 0) + (set #f)) + (loop-aux continuation ... + (compound ... (let ((temp x)) + (if set + (set! n (max temp n)) + (begin + (set! set #t) + (set! n temp))))) + clause* ...))) + ((loop-aux "accumulation" (continuation ...) (compound ...) maximize x clause* ...) + (loop-aux continuation ... + (compound ... (let ((temp x)) + (if acc-last + (set! number-acc (max temp number-acc)) + (begin + (set! acc-last #t) + (set! number-acc temp))))) + clause* ... finally (return number-acc))) + ((loop-aux "accumulation" (continuation ...) (compound ...) minimize x into n clause* ...) + (let ((n 0) + (set #f)) + (loop-aux continuation ... + (compound ... (let ((temp x)) + (if set + (set! n (min temp n)) + (begin + (set! set #t) + (set! n temp))))) + clause* ...))) + ((loop-aux "accumulation" (continuation ...) (compound ...) minimize x clause* ...) + (loop-aux continuation ... + (compound ... (let ((temp x)) + (if acc-last + (set! number-acc (min temp number-acc)) + (begin + (set! acc-last #t) + (set! number-acc temp))))) + clause* ... finally (return number-acc))) + ((loop-aux "accumulation-main-continuation" ((body ...) fin) (compound ...) clause* ...) + (loop-aux "main-clause-collector" ((body ... compound ...) fin) clause* ...)) + ((loop-aux "conditional" continuation compound if condition clause* ...) + (loop-aux "selectable-clause" ("selectable-clause-if-continuation" continuation compound condition) () clause* ...)) + ((loop-aux "conditional" continuation compound unless condition clause* ...) + (loop-aux "selectable-clause" ("selectable-clause-if-continuation" continuation compound (not condition)) () clause* ...)) + ((loop-aux "conditional-main-continuation" ((body ...) fin) (compound ...) clause* ...) + (loop-aux "main-clause-collector" ((body ... compound ...) fin) clause* ...)) + ((loop-aux "selectable-clause" continuation compound do clause* ...) + (loop-aux "unconditional" continuation compound do clause* ...)) + ((loop-aux "selectable-clause" continuation compound return clause* ...) + (loop-aux "unconditional" continuation compound return clause* ...)) + ((loop-aux "selectable-clause" continuation compound collect clause* ...) + (loop-aux "accumulation" continuation compound collect clause* ...)) + ((loop-aux "selectable-clause" continuation compound append clause* ...) + (loop-aux "accumulation" continuation compound append clause* ...)) + ((loop-aux "selectable-clause" continuation compound count clause* ...) + (loop-aux "accumulation" continuation compound count clause* ...)) + ((loop-aux "selectable-clause" continuation compound sum clause* ...) + (loop-aux "accumulation" continuation compound sum clause* ...)) + ((loop-aux "selectable-clause" continuation compound maximize clause* ...) + (loop-aux "accumulation" continuation compound maximize clause* ...)) + ((loop-aux "selectable-clause" continuation compound minimize clause* ...) + (loop-aux "accumulation" continuation compound minimize clause* ...)) + ((loop-aux "selectable-clause" continuation compound if clause* ...) + (loop-aux "conditional" continuation compound if clause* ...)) + ((loop-aux "selectable-clause" continuation compound when clause* ...) + (loop-aux "conditional" continuation compound if clause* ...)) + ((loop-aux "selectable-clause" continuation compound unless clause* ...) + (loop-aux "conditional" continuation compound unless clause* ...)) + ((loop-aux "selectable-clause-if-continuation" continuation compound condition body and clause* ...) + (loop-aux "selectable-clause" + ("selectable-clause-if-continuation" continuation compound condition) + body + clause* ...)) + ((loop-aux "selectable-clause-if-continuation" continuation compound condition body else clause* ...) + (loop-aux "selectable-clause" + ("selectable-clause-else-continuation" continuation compound condition body) + () + clause* ...)) + ((loop-aux "selectable-clause-if-continuation" (continuation ...) (compound ...) condition (body ...) end clause* ...) + (loop-aux continuation ... + (compound ... (when condition + body ...)) + clause* ...)) + ((loop-aux "selectable-clause-if-continuation" (continuation ...) (compound ...) condition (body ...) clause* ...) + (loop-aux continuation ... + (compound ... (when condition + body ...)) + clause* ...)) + ((loop-aux "selectable-clause-else-continuation" continuation compound condition body1 body2 and clause* ...) + (loop-aux "selectable-clause" + ("selectable-clause-else-continuation" continuation compound condition body1) + body2 + clause* ...)) + ((loop-aux "selectable-clause-else-continuation" (continuation ...) (compound ...) condition (body1 ...) (body2 ...) end clause* ...) + (loop-aux continuation ... + (compound ... (if condition + (begin body1 ...) + (begin body2 ...))) + clause* ...)) + ((loop-aux "selectable-clause-else-continuation" (continuation ...) (compound ...) condition (body1 ...) (body2 ...) clause* ...) + (loop-aux continuation ... + (compound ... (if condition + (begin body1 ...) + (begin body2 ...))) + clause* ...)))))) + (guard (e ((return-exception? e) ((return-exception-values e)))) + (loop-aux "variable-clause-collector" (() ()) loop-clauses* ...))))))))) diff --git a/lib/csc/macros-test.csc b/lib/csc/macros-test.csc new file mode 100644 index 0000000..531e3e2 --- /dev/null +++ b/lib/csc/macros-test.csc @@ -0,0 +1,294 @@ +(define-library (csc macros-test) + (import (scheme base) + (only (csc gensym) + gensym + gensym?) + (only (csc ir1) + %call + %call-builtin + %constant + %define-syntax + %if + %lambda + %letrec + %lexical-ref + %lexical-set + %library-define + %library-ref + %sequence + call-builtin? + call? + constant? + define-syntax? + if? + lambda? + letrec? + lexical-ref-name + lexical-ref? + lexical-set-expression + lexical-set? + library-define? + library-ref? + make-call-builtin + make-constant + make-define-syntax + 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 call-builtin? %call-builtin) + (cons sequence? %sequence) + (cons lambda? %lambda) + (cons letrec? %letrec) + (cons gensym? (lambda (x) 'gensym)) + (cons macro-transformer? (lambda (x) 'transformer)))) + + + (test builtin-quote + (assert-equal + (make-constant '(test 1 2 3)) + (expand-body 'main + '((quote (test 1 2 3))) + builtins-environment) + transform-ir1)) + + + (test builtin-syntax-rules-literal + (assert-equal + (make-constant 1) + (expand-body 'main + '((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-body 'main + '((let-syntax + (foo + (syntax-rules () + ((foo _) 0))) + (foo ignored))) + builtins-environment) + transform-ir1)) + + + (test builtin-syntax-rules-substitution + (assert-equal + (make-constant 5) + (expand-body 'main + '((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-body 'main + '((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-body 'main + '((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-body 'main + '((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-body 'main + '((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-body 'main + '((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-body 'main + '((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-body 'main + '((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-body 'main + '((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-body 'main + '((let-syntax + (foo + (syntax-rules ::: () + ((foo x :::) (x :::)))) + (foo quote 5))) + builtins-environment) + transform-ir1)) + + + (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-body 'main + '((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-body 'main + '((lambda (x) + (builtin-define a (quote 6)) + (builtin-define b a) + (quote 7))) + builtins-environment) + transform-ir1)) + + + (test builtin-define-syntax + (assert-equal + (make-sequence + (make-define-syntax 'five 'transformer) + (make-constant 5)) + (expand-body 'main + '((define-syntax five + (syntax-rules () + ((five _) 5))) + (five 6)) + builtins-environment) + transform-ir1)) + + + (test builtin-call-builtin + (assert-equal + (make-call-builtin 'bbb (list (make-constant 5))) + (expand-body 'main + '((call-builtin bbb 5)) + builtins-environment) + transform-ir1)))) diff --git a/lib/csc/macros.csc b/lib/csc/macros.csc new file mode 100644 index 0000000..4559991 --- /dev/null +++ b/lib/csc/macros.csc @@ -0,0 +1,801 @@ +(define-library (csc macros) + (export + builtins-environment + expand-body + macro-syntax-error? + macro-transformer?) + (import (scheme base) + (only (csc assert) assert) + (only (csc format) sprintf) + (only (csc gensym) + gensym + gensym=?) + (only (csc hash-map) + alist->map + hash-bytevector + insert + key-not-found-error? + lookup + make-comparer + make-map + map-for-each + merge) + (only (csc ir1) + define-syntax-name + define-syntax-transformer + define-syntax? + lexical-ref-gensym + lexical-ref? + library-define-expression + library-define-ref + library-define? + library-ref-name + library-ref? + make-call + make-call-builtin + make-constant + make-define-syntax + make-lambda + make-letrec + make-lexical-ref + make-library-define + make-library-ref + make-sequence + sequence-head + sequence-tail + sequence?) + (only (csc list) + revappend + unzip) + (only (csc loop) + loop + return) + (only (csc match) match) + (only (csc vec) + vec + vec-append + vec-length + vec-ref)) + (begin + + + (define-record-type <macro-transformer> + (make-macro-transformer transformer) + macro-transformer? + (transformer transformer-function)) + + + (define-record-type <macro-syntax-error> + (make-macro-syntax-error message irritants) + macro-syntax-error? + (message syntax-error-object-message) + (irritants syntax-error-object-irritants)) + + + (define (raise-syntax-error message . irritants) + (raise (make-macro-syntax-error message irritants))) + + + ; symbols is a map with identifiers as keys, and the values can be one of: + ; - <lexical-ref>, + ; - <library-ref>, + ; - or <macro-transformer>. + ; The first two correspond to variables bound lexically or from a library, + ; and the third represents a macro transformer bound in the + ; current context. + (define-record-type <environment> + (make-environment symbols library) + environment? + (symbols environment-substitutions) + (library environment-library)) + + + (define-record-type <syntax-object> + (make-syntax-object expression environment marks) + syntax-object? + (expression syntax-object-expression) + (environment syntax-object-environment) + (marks syntax-object-marks)) + + + (define (wrap-syntax expression environment) + (if (syntax-object? expression) + expression + (make-syntax-object expression environment '()))) + + + (define (syntax->expression s) + (if (syntax-object? s) + (syntax-object-expression s) + s)) + + + (define (marks s) + (if (syntax-object? s) + (syntax-object-marks s) + '())) + + + (define (add-binding identifier binding environment) + (make-environment + (insert (environment-substitutions environment) identifier binding) + (environment-library environment))) + + + (define (with-binding identifier binding syntax) + (make-syntax-object + (syntax->expression syntax) + (add-binding identifier binding (syntax-object-environment syntax)) + (marks syntax))) + + + (define (identifier? s) + (or (symbol? s) + (and (syntax-object? s) + (symbol? (syntax-object-expression s))))) + + + (define (marks=? m1 m2) + (and + (= (length m1) (length m2)) + (let loop ((m1 m1) + (m2 m2)) + (if (null? m1) + #t + (and (= (car m1) (car m2)) (loop (cdr m1) (cdr m2))))))) + + + (define (identifier-name s) + (if (syntax-object? s) + (syntax-object-expression s) + s)) + + + (define (bound-identifier=? s1 s2) + (and (symbol=? (identifier-name s1) (identifier-name s2)) + (marks=? (marks s1) (marks s2)))) + + + (define (binding=? b1 b2) + (or (and (lexical-ref? b1) + (lexical-ref? b2) + (gensym=? (lexical-ref-gensym b1) (lexical-ref-gensym b2))) + (and (library-ref? b1) + (library-ref? b2) + (symbol=? (library-ref-name b1) (library-ref-name b2))) + (and (macro-transformer? b1) + (macro-transformer? b2) + (eq? (transformer-function b1) (transformer-function b2))))) + + + ; free-identifier=? only works on wrapped syntax objects. + (define (free-identifier=? s1 s2) + (let ((s1-binding (guard (e ((key-not-found-error? e) #f)) + (lookup (environment-substitutions (syntax-object-environment s1)) s1))) + (s2-binding (guard (e ((key-not-found-error? e) #f)) + (lookup (environment-substitutions (syntax-object-environment s2)) s2)))) + (or (and (not s1-binding) + (not s2-binding) + (symbol=? (identifier-name s1) (identifier-name s2))) + (binding=? s1-binding s2-binding)))) + + + (define *next-mark* 0) + + + (define (new-mark) + (let ((m *next-mark*)) + (set! *next-mark* (+ 1 *next-mark*)) + m)) + + + (define (add-mark mark expression) + (make-syntax-object + (syntax-object-expression expression) + (syntax-object-environment expression) + (if (and (pair? (syntax-object-marks expression)) + (not (car (syntax-object-marks expression)))) ; Anti-mark. + (cdr (syntax-object-marks expression)) + (cons mark (syntax-object-marks expression))))) + + + (define (add-marks marks expression) + (let loop ((marks marks) + (expression expression)) + (match marks + ('() expression) + ((mark . marks) + (loop marks (add-mark mark expression)))))) + + + (define (anti-mark expression) + (add-mark #f expression)) + + + (define (decorate marks expression environment) + (add-marks marks (wrap-syntax expression environment))) + + + (define (with-wrap expression parent) + (decorate (marks parent) expression (syntax-object-environment parent))) + + + (define (syntax-map f expr) + (with-wrap (f (syntax->expression expr)) expr)) + + + (define-record-type <syntax-case-no-match> + (make-syntax-case-no-match) + syntax-case-no-match?) + + + (define-syntax syntax-case-match-pattern + (syntax-rules (_ when) + ((syntax-case-match-pattern x pattern when condition result result* ...) + (syntax-case-match-pattern x pattern + (if condition + (let () result result* ...) + (raise (make-syntax-case-no-match))))) + ((syntax-case-match-pattern x _ result result* ...) + (let () result result* ...)) + ((syntax-case-match-pattern x '() result result* ...) + (if (null? (syntax->expression x)) + (let () result result* ...) + (raise (make-syntax-case-no-match)))) + ((syntax-case-match-pattern x (pattern) result result* ...) + (let ((y x)) + (if (pair? (syntax->expression y)) + (syntax-case-match-pattern (syntax-map car y) pattern + (syntax-case-match-pattern (syntax-map cdr y) '() result result* ...)) + (raise (make-syntax-case-no-match))))) + ((syntax-case-match-pattern x (pattern . rest) result result* ...) + (let ((y x)) + (if (pair? (syntax->expression y)) + (syntax-case-match-pattern (syntax-map car y) pattern + (syntax-case-match-pattern (syntax-map cdr y) rest result result* ...)) + (raise (make-syntax-case-no-match))))) + ((syntax-case-match-pattern x ident result result* ...) + (let ((ident x)) result result* ...)))) + + + ; Yes, I just defined syntax-case in terms of syntax-rules. + ; Are we sure this won't create a black hole? + (define-syntax syntax-case + (syntax-rules () + ((syntax-case x (arm ...)) + (guard (e ((syntax-case-no-match? e) (error "no match in syntax case"))) + (syntax-case-match-pattern x arm ...))) + ((syntax-case x (arm ...) clause clause* ...) + (let ((y x)) + (guard (e ((syntax-case-no-match? e) + (syntax-case y clause clause* ...))) + (syntax-case-match-pattern y arm ...)))))) + + + (define (expand-procedure-call procedure arguments) + (let ((expanded-procedure (expand-syntax-object procedure)) + (expanded-arguments + (let loop ((arguments arguments) + (expanded-arguments '())) + (syntax-case arguments + ('() (reverse expanded-arguments)) + ((argument . rest) + (let ((expanded-argument (expand-syntax-object argument))) + (loop + rest + (cons expanded-argument expanded-arguments)))) + (_ (raise-syntax-error "arguments to a procedure call must be a list" procedure arguments)))))) + (make-call expanded-procedure expanded-arguments))) + + + (define (resolve-identifier ident) + (let* ((environment (syntax-object-environment ident)) + (substitutions (environment-substitutions environment))) + (or + ; Check whether the variable is lexically bound to a marked identifier. + (guard (e ((key-not-found-error? e) #f)) + (lookup substitutions ident)) + ; Check whether the variable is bound to an unmarked identifier. + (guard (e ((key-not-found-error? e) #f)) + (lookup substitutions (identifier-name ident))) + ; Otherwise insert a library-ref + (make-library-ref (identifier-name ident) (environment-library environment))))) + + + (define (expand-syntax-object syntax) + (syntax-case syntax + ('() (raise-syntax-error "nil by itself is an error (did you mean to use quote?)" syntax)) + ((macro-name . tail) when (identifier? macro-name) + (let ((macro-body (resolve-identifier macro-name))) + (if (macro-transformer? macro-body) + ((transformer-function macro-body) syntax) + (expand-procedure-call macro-name tail)))) + ((procedure . arguments) + (expand-procedure-call procedure arguments)) + (_ when (identifier? syntax) + (let ((binding (resolve-identifier syntax))) + (if (macro-transformer? binding) + (raise-syntax-error "macro is not allowed in this context" syntax) + binding))) + (_ when (let ((expr (syntax->expression syntax))) + (or (boolean? expr) + (char? expr) + (number? expr) + (string? expr) + (vector? expr))) + (make-constant (syntax->expression syntax))) + (_ (raise-syntax-error "unexpected expression type" (clean-syntax syntax))))) + + + (define (expand expression environment) + (expand-syntax-object (wrap-syntax expression environment))) + + + (define (clean-syntax s) + (cond + ((pair? s) (cons (clean-syntax (car s)) (clean-syntax (cdr s)))) + ((syntax-object? s) (clean-syntax (syntax->expression s))) + (else s))) + + + (define builtin-quote + (make-macro-transformer + (lambda (syntax) + (syntax-case syntax + ((_ datum) (make-constant (clean-syntax datum))) + (_ (raise-syntax-error "invalid form for quote" (clean-syntax syntax))))))) + + + (define (matches-literals literals object) + (unless (list? (syntax->expression literals)) + (raise-syntax-error "invalid form in literals, expecting list" literals)) + (if (not (identifier? object)) + #f + (let ((literal-identifiers + (map + (lambda (lit) (with-wrap lit literals)) + (syntax->expression literals)))) + (let loop ((literal-identifiers literal-identifiers)) + (match literal-identifiers + ('() #f) + ((lit . literals) + (or (free-identifier=? lit object) + (loop literals)))))))) + + + (define (identifier-uuid i) + (sprintf "{}" (list (identifier-name i) (marks i)))) + + + (define (hash-identifier i) + (hash-bytevector (string->utf8 (identifier-uuid i)))) + + + (define (marks<? m1 m2) + (loop for m1* in m1 + for m2* in m2 + if (< m1* m2*) + return #t + else if (> m1* m2*) + return #f + finally (return (< (length m1) (length m2))))) + + + (define compare-identifiers + (make-comparer + hash-identifier + (lambda (i1 i2) + (cond + ((bound-identifier=? i1 i2) 0) + ((or (string<? (symbol->string (identifier-name i1)) (symbol->string (identifier-name i2))) + (marks<? (marks i1) (marks i2))) + -1) + (else 1))))) + + + (define (alist->substitutions l) + (alist->map compare-identifiers l)) + + + (define (is-underscore expression) + (and + (identifier? expression) + (free-identifier=? + expression + (wrap-syntax + '_ + (make-environment + (alist->substitutions + (list (cons '_ (make-library-ref '_ '(scheme base))))) + '(scheme base)))))) + + + (define (syntax-improper-list-length l) + (let loop ((l l) + (n 0)) + (syntax-case l + ('() n) + ((_ . rest) (loop rest (+ 1 n))) + (_ (+ 1 n))))) + + + ; objects is an n-dimensional vec, where n is nesting-level. + (define-record-type <ellipsis-binding> + (make-ellipsis-binding objects nesting-level) + ellipsis-binding? + (objects ellipsis-binding-objects) + (nesting-level ellipsis-binding-nesting-level)) + + + (define (merge-bindings x y) + (assert (= (ellipsis-binding-nesting-level x) (ellipsis-binding-nesting-level y))) + (make-ellipsis-binding + (vec-append (ellipsis-binding-objects x) (ellipsis-binding-objects y)) + (ellipsis-binding-nesting-level x))) + + + (define (ellipsis-substitutions-merge s1 s2) + (map-for-each + (lambda (k v) + (let-values (((s1-binding ok) + (guard (e ((key-not-found-error? e) (values #f #f))) + (values (lookup s1 k) #t)))) + (if ok + (set! s1 (insert s1 k (merge-bindings s1-binding v))) + (set! s1 (insert s1 k v))))) + s2) + s1) + + + (define (map-ellipsis-binding substitutions) + (let ((res (alist->substitutions '()))) + (map-for-each + (lambda (k v) + (if (ellipsis-binding? v) + (set! res + (insert + res + k + (make-ellipsis-binding + (vec (ellipsis-binding-objects v)) + (+ 1 (ellipsis-binding-nesting-level v))))) + (set! res + (insert + res + k + (make-ellipsis-binding + (vec v) + 1))))) + substitutions) + res)) + + + (define (pattern-bindings ellipsis literals pattern object) + (syntax-case pattern + (lit when (matches-literals literals lit) + (if (and (identifier? object) (free-identifier=? object lit)) + (alist->substitutions '()) + #f)) + ((p ellip . p*) when (and (identifier? ellip) (not (matches-literals literals ellip)) (free-identifier=? ellipsis ellip)) + (let* ((n (syntax-improper-list-length object)) + (m (syntax-improper-list-length p*)) + (n-m (- n m))) + (if (>= n m) + (let loop ((i 0) + (object object) + (bindings (alist->substitutions '()))) + (if (< i n-m) + (let ((binding (pattern-bindings ellipsis literals p (syntax-map car object)))) + (and binding + (loop + (+ 1 i) + (syntax-map cdr object) + (ellipsis-substitutions-merge bindings (map-ellipsis-binding binding))))) + (let ((bindings* (pattern-bindings ellipsis literals p* object))) + (and bindings* (merge bindings bindings*))))) + #f))) + (underscore when (is-underscore underscore) + (alist->substitutions '())) + (ident when (identifier? ident) + ; Each time the expander encounters a macro use, it applies an + ; antimark to the input form. + ; + ; We would apply it earlier, but the antimark breaks + ; free-identifier=? to check for literals. -- rose + (alist->substitutions (list (cons ident (anti-mark object))))) + ('() + (syntax-case object + ('() (alist->substitutions '())) + (_ #f))) + ((p . p*) + (syntax-case object + ((e . e*) + (define pbindings (pattern-bindings ellipsis literals p e)) + (define p*bindings (pattern-bindings ellipsis literals p* e*)) + (and pbindings p*bindings (merge pbindings p*bindings))) + (_ #f))) + (constant + (if (equal? (syntax->expression constant) (syntax->expression object)) + (alist->substitutions '()) + #f)))) + + + (define-record-type <ellipsis-out-of-bounds> + (make-ellipsis-out-of-bounds) + ellipsis-out-of-bounds?) + + + (define (ellipsis-ref v i) + (if (< i (vec-length v)) + (vec-ref v i) + (raise (make-ellipsis-out-of-bounds)))) + + + ; Can raise key-not-found-error? or ellipsis-out-of-bounds?. + (define (ellipsis-lookup substitutions ellipsis-nesting key) + (let ((n-d-vector (lookup substitutions key))) + (if (ellipsis-binding? n-d-vector) + (if (= (ellipsis-binding-nesting-level n-d-vector) (vec-length ellipsis-nesting)) + (let loop ((i 0) + (value (ellipsis-binding-objects n-d-vector))) + (if (< i (vec-length ellipsis-nesting)) + (loop + (+ 1 i) + (ellipsis-ref value (vec-ref ellipsis-nesting i))) + value)) + (raise-syntax-error "reference to pattern variable at incorrect ellipsis nesting level" (clean-syntax key) (vec-length ellipsis-nesting))) + n-d-vector))) + + + (define (syntax-append s1 s2) + (syntax-case s1 + ('() (with-wrap s2 s1)) + ((head . tail) + (with-wrap + (cons head + (syntax-append tail s2)) + s1)))) + + + (define (expand-template ellipsis ellipsis-nesting substitutions template) + (syntax-case template + ('() (with-wrap '() template)) + ((head ellip . tail) when (and (identifier? ellip) (free-identifier=? ellip ellipsis)) + (let-values (((extra-ellipses tail) + (let loop ((tail tail) + (extra-ellipses '())) + (syntax-case tail + ((ellip . tail) when (and (identifier? ellip) (free-identifier=? ellip ellipsis)) + (loop tail (cons ellip extra-ellipses))) + (_ (values extra-ellipses tail)))))) + (let loop ((i 0) + (expansion (with-wrap '() template))) + (guard (e ((ellipsis-out-of-bounds? e) + (if (= 0 i) + ; Failure was at a higher level. + (raise e) + (syntax-append expansion (expand-template ellipsis ellipsis-nesting substitutions tail))))) + (loop + (+ 1 i) + (syntax-append + expansion + (expand-template + ellipsis + (vec-append ellipsis-nesting i) + substitutions + (with-wrap + (cons + head + extra-ellipses) + template)))))))) + ((head . tail) + (with-wrap + (cons (expand-template ellipsis ellipsis-nesting substitutions head) + (expand-template ellipsis ellipsis-nesting substitutions tail)) + template)) + (ident when (identifier? ident) + (guard (e ((key-not-found-error? e) template)) + (ellipsis-lookup substitutions ellipsis-nesting template))) + (_ template))) + + + (define (syntax-match ellipsis literals all-rules object) + (let loop ((rules all-rules)) + (syntax-case rules + ('() (raise-syntax-error "form did not match any patterns in syntax-rules" object all-rules)) + ((((_ . pattern) template) . tail) + (define bindings (pattern-bindings ellipsis literals pattern (syntax-map cdr object))) + (if bindings + ; We call expand-syntax-object immediately, since macros are + ; allowed to be recursive. + (expand-syntax-object + ; Each time the expander encounters a macro use, it applies an + ; antimark to the input form, invokes the associated + ; transformer, then applies a fresh mark to the output. + (add-mark (new-mark) (expand-template ellipsis (vec) bindings template))) + (loop tail))) + (_ (raise-syntax-error "unexpected form in syntax-rules" all-rules))))) + + + (define default-ellipsis + (wrap-syntax + '... + (make-environment + (alist->substitutions + (list (cons '... + (make-library-ref '... '(scheme base))))) + '(scheme base)))) + + + (define builtin-syntax-rules + (make-macro-transformer + (lambda (syntax-rules-form) + (make-macro-transformer + (lambda (input-form) + (syntax-case syntax-rules-form + ((_ ellipsis literals . rules) when (identifier? ellipsis) + (syntax-match ellipsis literals rules input-form)) + ((_ literals . rules) + (syntax-match default-ellipsis literals rules input-form)) + (_ (raise-syntax-error "unexpected form in syntax-rules" syntax-rules-form)))))))) + + + (define builtin-let-syntax + (make-macro-transformer + (lambda (x) + (syntax-case x + ((_ (ident transformer-form) body-form) when (identifier? ident) + (let* ((transformer (expand-syntax-object transformer-form)) + (body (expand-syntax-object (with-binding ident transformer body-form)))) + body)) + (_ (raise-syntax-error "unexpected form in let-syntax")))))) + + + (define (split-args-rest formals) + (syntax-case formals + ('() + (values '() #f)) + ((var . vars) when (identifier? var) + (let-values (((args rest) (split-args-rest vars))) + (values (cons (identifier-name var) args) rest))) + (var when (identifier? var) + (values '() (identifier-name var))) + (_ (raise-syntax-error "unexpected form in split-args-rest" formals)))) + + + (define (expand-lambda-body-rest body) + (let loop ((body body) + (expanded-body (make-constant #f))) + (syntax-case body + ('() + expanded-body) + ((expr . expr*) + (define expanded-expr (expand-syntax-object expr)) + (when (or (library-define? expanded-expr) + (define-syntax? expanded-expr)) + (raise-syntax-error "define not allowed here" body)) + (loop (syntax-map cdr body) + (make-sequence expanded-body expanded-expr)))))) + + + (define (expand-lambda-body body) + (let loop ((body body) + (names '()) + (gensyms '()) + (expressions '())) + (syntax-case body + ('() + (if (null? names) + (make-constant #f) + (make-letrec #t (reverse names) (reverse gensyms) (reverse expressions) (make-constant #f)))) + ((expr . expr*) + (define expanded-expr (expand-syntax-object expr)) + (cond + ((library-define? expanded-expr) + (let ((name (library-ref-name (library-define-ref expanded-expr))) + (g (gensym))) + (loop (with-binding name (make-lexical-ref name g) (syntax-map cdr body)) + (cons name names) + (cons g gensyms) + (cons (library-define-expression expanded-expr) expressions)))) + ((define-syntax? expanded-expr) + (loop (with-binding (define-syntax-name expanded-expr) (define-syntax-transformer expanded-expr) (syntax-map cdr body)) + names + gensyms + expressions)) + (else + (if (null? names) + (expand-lambda-body-rest body) + (make-letrec #t (reverse names) (reverse gensyms) (reverse expressions) (expand-lambda-body-rest body))))))))) + + + (define builtin-lambda + (make-macro-transformer + (lambda (x) + (syntax-case x + ((_ formals . body) + (let-values (((args rest) (split-args-rest formals))) + (make-lambda + (map (lambda (name) + (make-lexical-ref name (gensym))) + args) + (if rest + (make-lexical-ref rest (gensym)) + #f) + (expand-lambda-body body)))) + (_ (raise-syntax-error "unexpected form in lambda" x)))))) + + + (define builtin-define + (make-macro-transformer + (lambda (x) + (syntax-case x + ((_ symbol expression) + (make-library-define + (make-library-ref + (identifier-name symbol) + (environment-library (syntax-object-environment x))) + (expand-syntax-object expression))) + (_ (raise-syntax-error "unexpected form in builtin-define" x)))))) + + + (define builtin-define-syntax + (make-macro-transformer + (lambda (x) + (syntax-case x + ((_ ident transformer-form) when (identifier? ident) + (make-define-syntax (identifier-name ident) + (expand-syntax-object transformer-form))) + (_ (raise-syntax-error "unexpected form in builtin-define-syntax" x)))))) + + + (define builtin-call-builtin + (make-macro-transformer + (lambda (x) + (syntax-case x + ((_ op . args) when (identifier? op) + (make-call-builtin (identifier-name op) + (let loop ((args args) + (expanded-args '())) + (syntax-case args + ('() (reverse expanded-args)) + ((head . tail) + (loop tail + (cons (expand-syntax-object head) + expanded-args))) + (_ (raise-syntax-error "unexpected form in call-builtin")))))) + (_ (raise-syntax-error "unexpected form in call-builtin" x)))))) + + + (define builtins-environment + (alist->substitutions + (list (cons 'syntax-rules builtin-syntax-rules) + (cons '_ (make-library-ref '_ '(scheme base))) + (cons '... (make-library-ref '... '(scheme base))) + (cons 'let-syntax builtin-let-syntax) + (cons 'quote builtin-quote) + (cons 'lambda builtin-lambda) + (cons 'builtin-define builtin-define) + (cons 'define-syntax builtin-define-syntax) + (cons 'call-builtin builtin-call-builtin)))) + + + ; Expands the body of a library, or top level. expand-body can be thought + ; of as a compiler from Scheme to IR1. Macros included in the environment + ; can be used to extend the syntax. Returns an IR1 expression. + (define (expand-body name body env) + (define ident-map (make-map compare-identifiers)) + (map-for-each (lambda (k v) + (set! ident-map (insert ident-map k v))) + env) + (define environment (make-environment ident-map name)) + (loop for expr in body + for expanded-expr = (expand expr environment) + for res = expanded-expr then (make-sequence res expanded-expr) + finally (return res) + if (define-syntax? expanded-expr) + do (set! environment + (add-binding + (define-syntax-name expanded-expr) + (define-syntax-transformer expanded-expr) + environment)))))) diff --git a/lib/csc/match-test.csc b/lib/csc/match-test.csc new file mode 100644 index 0000000..c5923e4 --- /dev/null +++ b/lib/csc/match-test.csc @@ -0,0 +1,113 @@ +(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-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-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-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-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)))) + + + (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-any + (assert-equal + 2 + (match '(1 2 3) + ((% %test-record-type . _) 1) + ('(1 2 3) 2)))))) diff --git a/lib/csc/match.csc b/lib/csc/match.csc new file mode 100644 index 0000000..4db0d07 --- /dev/null +++ b/lib/csc/match.csc @@ -0,0 +1,80 @@ +(define-library (csc match) + (export + define-match-record-type + match) + (import (scheme base)) + (begin + + + (define-record-type <no-match> + (make-no-match) + no-match?) + + + (define *no-match* (make-no-match)) + + + (define-syntax define-match-record-type + (syntax-rules () + ((define-match-record-type name constructor predicate matcher (field-name* field-getter*) ...) + (begin + (define-record-type name + constructor + predicate + (field-name* field-getter*) ...) + (define (matcher x) + (unless (predicate x) + (raise *no-match*)) + (list (cons '!type 'name) (cons 'field-name* (field-getter* x)) ...)))))) + + + (define-syntax match-pattern + (syntax-rules (% _ quote when) + ((match-pattern x pattern when condition result result* ...) + (match-pattern x pattern + (unless condition + (raise *no-match*)) + result result* ...)) + ((match-pattern x _ result result* ...) + (let () result result* ...)) + ((match-pattern x (quote constant) result result* ...) + (let () + (unless (equal? x (quote constant)) + (raise *no-match*)) + result result* ...)) + ((match-pattern x (% record-matcher) result result* ...) + (let () + (record-matcher x) + result result* ...)) + ((match-pattern x (% record-matcher . patterns) result result* ...) + (let ((x* (record-matcher x))) + (match-pattern (map cdr (cdr x*)) patterns result result* ...))) + ((match-pattern x () result* ...) + (syntax-error "Unexpected pattern (). Use '() to match nil.")) + ((match-pattern x (pattern) result result* ...) + (let ((y x)) + (unless (and (pair? y) + (null? (cdr y))) + (raise *no-match*)) + (match-pattern (car y) pattern result result* ...))) + ((match-pattern x (pattern . rest) result result* ...) + (let ((y x)) + (unless (pair? y) + (raise *no-match*)) + (match-pattern (car y) pattern + (match-pattern (cdr y) rest result result* ...)))) + ((match-pattern x identifier result result* ...) + (let ((identifier x)) + result result* ...)))) + + + (define-syntax match + (syntax-rules () + ((match x (arm ...)) + (guard (e ((no-match? e) (if #f #f))) + (match-pattern x arm ...))) + ((match x (arm ...) clause clause* ...) + (let ((y x)) + (guard (e ((no-match? e) + (match y clause clause* ...))) + (match-pattern y arm ...)))))))) diff --git a/lib/csc/sort-test.csc b/lib/csc/sort-test.csc new file mode 100644 index 0000000..9c91d4a --- /dev/null +++ b/lib/csc/sort-test.csc @@ -0,0 +1,37 @@ +(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-empty + (assert-equal '() (sort < '()))) + + + (test sort-singleton + (assert-equal '(1) (sort < '(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-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/lib/csc/sort.csc b/lib/csc/sort.csc new file mode 100644 index 0000000..6be1e16 --- /dev/null +++ b/lib/csc/sort.csc @@ -0,0 +1,28 @@ +(define-library (csc sort) + (export sort) + (import (scheme base) + (only (csc list) + revappend + split-at)) + (begin + + + (define (sort-len cmp xs len) + (if (<= len 1) + xs + (let ((n/2 (truncate-quotient len 2))) + (let-values (((half-a half-b) (split-at n/2 xs))) + (let ((sorted-half-a (sort-len cmp half-a n/2)) + (sorted-half-b (sort-len cmp half-b (- len n/2)))) + (let loop ((a sorted-half-a) + (b sorted-half-b) + (acc '())) + (cond ((null? a) (revappend acc b)) + ((null? b) (revappend acc a)) + ((cmp (car b) (car a)) + (loop a (cdr b) (cons (car b) acc))) + (else (loop (cdr a) b (cons (car a) acc)))))))))) + + + (define (sort cmp xs) + (sort-len cmp xs (length xs))))) diff --git a/lib/csc/strings-test.csc b/lib/csc/strings-test.csc new file mode 100644 index 0000000..1f981ad --- /dev/null +++ b/lib/csc/strings-test.csc @@ -0,0 +1,103 @@ +(define-library (csc strings-test) + (import (scheme base) + (only (csc testing) + assert + assert-equal + test) + (csc strings)) + (begin + + + (test has-prefix?-good + (assert-equal #t (has-prefix? "asdfjkl;" "asdf"))) + + + (test has-prefix?-bad + (assert-equal #f (has-prefix? "asdbjkl;" "asdf"))) + + + (test has-prefix?-too-long + (assert-equal #f (has-prefix? "as" "asdf"))) + + + (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 index-ok + (assert-equal 8 (index "dabsadfdabcdfdfd" "abc"))) + + + (test index-one-letter + (assert-equal 8 (index "sdfdfdfsasdfe" "a"))) + + + (test index-notfound + (assert-equal + -1 + (index "def" "a"))) + + + (test contains + (assert-equal + #t + (contains? "abc" "b"))) + + + (test doesnt-contain + (assert-equal + #f + (contains? "abc" "d"))) + + + (test contains-empty + (assert-equal + #t + (contains? "" ""))) + + + (test empty-contains + (assert-equal + #f + (contains? "" "a"))) + + + (test join-, + (assert-equal "a,b,c" (join "," '("a" "b" "c")))) + + + (test join-none + (assert-equal "" (join "," '()))) + + + (test join-singleton + (assert-equal "x" (join "," '("x")))) + + + (test join-empty + (assert-equal "abc" (join "" '("a" "b" "c")))) + + + (test split-empty + (assert-equal '("") (split "" " "))) + + (test split + (assert-equal '("a" "b") (split "a b" " "))) + + + (test split-trailing-empty + (assert-equal '("a" "") (split "a " " "))) + + + (test split-n + (assert-equal '("a" "b" "c d e") (split "a b c d e" " " 3))) + + + (test split-none + (assert-equal + '() + (split "a b c d e" " " 0))))) diff --git a/lib/csc/strings.csc b/lib/csc/strings.csc new file mode 100644 index 0000000..255a2fd --- /dev/null +++ b/lib/csc/strings.csc @@ -0,0 +1,64 @@ +(define-library (csc strings) + (export + contains? + has-prefix? + index + join + split + str-quote) + (import (scheme base) + (only (scheme case-lambda) case-lambda) + (only (scheme write) write) + (only (csc list) intercalate) + (only (csc loop) + loop + return)) + (begin + + + (define (has-prefix? str prefix) + (and (<= (string-length prefix) (string-length str)) + (string=? prefix (substring str 0 (string-length prefix))))) + + + (define (str-quote s) + (let ((out (open-output-string))) + (write s out) + (get-output-string out))) + + + (define (index s substr) + (loop for i from 0 + for s = s then (string-copy s 1) + until (string=? "" s) + if (has-prefix? s substr) + return i + finally (return -1))) + + + (define (contains? s substr) + (if (string=? "" substr) + #t + (not (negative? (index s substr))))) + + + (define (join sep strings) + (apply string-append (intercalate sep strings))) + + + (define split + (case-lambda + ((s sep n) + (if (= 0 n) + '() + (loop for n = n then (- n 1) + for s = s then (string-copy s (+ i (string-length sep))) + for i = (let ((i (index s sep))) + (if (or (negative? i) + (= 1 n)) + (string-length s) + i)) + collect (substring s 0 i) + while (< i (string-length s))))) + ((s sep) + (split s sep -1)))))) diff --git a/lib/csc/testing.csc b/lib/csc/testing.csc new file mode 100644 index 0000000..68678ca --- /dev/null +++ b/lib/csc/testing.csc @@ -0,0 +1,91 @@ +(define-library (csc testing) + (export + assert + assert-equal + assert-raises + test + test-main) + (import (scheme base) + (only (scheme write) + display + write) + (only (csc compare) diff)) + (begin + + + (define *all-tests-succeeded* #t) + + + (define (set-all-succeeded! val) (set! *all-tests-succeeded* val)) + + + (define-record-type <test-handle> + (make-test-handle test-name) + test-handle? + (test-name test-name set-name!)) + + + (define-record-type <test-error> + (make-test-error) + test-error?) + + + (define *test-error* (make-test-error)) + + + (define *test-handle* (make-test-handle "global")) + + + (define (print . xs) + (unless (null? xs) + (let ((x (car xs))) + (if (or (string? x) + (symbol? x)) + (display x) + (write x))) + (apply print (cdr xs)))) + + + (define-syntax test + (syntax-rules () + ((test name body body* ...) + (begin + (set-name! *test-handle* (symbol->string 'name)) + (print "=== RUN " 'name "\n") + (guard (e ((test-error? e) + (print "--- FAIL: " 'name "\n") + (set-all-succeeded! #f))) + body body* ... + (print "--- PASS: " 'name "\n")))))) + + + (define-syntax assert + (syntax-rules () + ((assert expr) + (unless expr + (print (test-name *test-handle*) ": (assert " 'expr ") failed.\n") + (raise *test-error*))))) + + + (define-syntax assert-equal + (syntax-rules () + ((assert-equal left right transformers ...) + (let ((d (diff left right transformers ...))) + (unless (string=? "" d) + (print "Fatal:\n " 'left "\nis not equal to\n " 'right "\ndiff (-left +right):\n" d "\n") + (raise *test-error*)))))) + + + (define-syntax assert-raises + (syntax-rules () + ((assert-raises predicate body body* ...) + (assert + (guard (e ((predicate e) #t)) + body body* ... + #f))))) + + + (define (test-main) + (if *all-tests-succeeded* + (print "PASS\n") + (print "FAIL\n"))))) diff --git a/lib/csc/vec-test.csc b/lib/csc/vec-test.csc new file mode 100644 index 0000000..761b259 --- /dev/null +++ b/lib/csc/vec-test.csc @@ -0,0 +1,35 @@ +(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-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-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-ref-1 + (assert-equal 2 (vec-ref (vec 1 2) 1))) + + + (test vec-ref-singleton + (assert-equal 1 (vec-ref (vec 1) 0))))) diff --git a/lib/csc/vec.csc b/lib/csc/vec.csc new file mode 100644 index 0000000..2730c39 --- /dev/null +++ b/lib/csc/vec.csc @@ -0,0 +1,65 @@ +(define-library (csc vec) + (export + list->vec + vec + vec->list + vec-append + vec-length + vec-ref + vec?) + (import (scheme base)) + (begin + + + (define-record-type <vec> + (make-vec len arr) + vec? + (len vec-length) + (arr vec-arr)) + + + (define (list->vec l) + (let ((arr (list->vector l))) + (make-vec (vector-length arr) arr))) + + + (define (vec->list v) + (vector->list (vec-arr v) 0 (vec-length v))) + + + (define (vec . xs) + (list->vec xs)) + + + (define (vec-ref v k) + (if (>= k (vec-length v)) + (error "index out of bounds" k) + (vector-ref (vec-arr v) k))) + + + (define (append-one v x) + (let ((new-v (if (> (vector-length (vec-arr v)) (vec-length v)) + v + (let ((new-arr (make-vector (max 1 (* 2 (vec-length v)))))) + (vector-copy! new-arr 0 (vec-arr v)) + (make-vec (vec-length v) new-arr))))) + (vector-set! (vec-arr new-v) (vec-length new-v) x) + (make-vec (+ 1 (vec-length new-v)) (vec-arr new-v)))) + + + (define (append2 v1 v2) + (if (vec? v2) + (let loop ((i 0) + (v v1)) + (if (< i (vec-length v2)) + (loop (+ 1 i) (append-one v (vec-ref v2 i))) + v)) + (append-one v1 v2))) + + + (define (vec-append v . xs) + (let loop ((xs xs) + (v v)) + (if (null? xs) + v + (loop (cdr xs) (append2 v (car xs)))))))) |