From acc561366f3fe6ec0377103f52ef0f7e923711c9 Mon Sep 17 00:00:00 2001 From: Rose Hogenson Date: Mon, 1 Aug 2022 19:35:19 -0700 Subject: 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. --- Makefile | 8 + csc.csc | 76 +++++ csc/Makefile | 5 - csc/assert-test.csc | 14 - csc/assert.csc | 11 - csc/codegen-test.csc | 132 -------- csc/codegen.csc | 260 -------------- csc/compare-test.csc | 98 ------ csc/compare.csc | 248 -------------- csc/compiler.csc | 164 --------- csc/config.csc | 7 - csc/cps-test.csc | 499 --------------------------- csc/cps.csc | 602 --------------------------------- csc/encoding-test.csc | 121 ------- csc/encoding.csc | 184 ---------- csc/flag.csc | 119 ------- csc/format-test.csc | 26 -- csc/format.csc | 50 --- csc/gensym.csc | 27 -- csc/guile-compat/compat.scm | 3 - csc/guile-compat/csc.fish | 2 - csc/guile-compat/lib/csc | 1 - csc/hash-map-test.csc | 155 --------- csc/hash-map.csc | 492 --------------------------- csc/ir1.csc | 215 ------------ csc/ir2.csc | 217 ------------ csc/linker-test.csc | 49 --- csc/linker.csc | 119 ------- csc/list-test.csc | 123 ------- csc/list.csc | 85 ----- csc/loop-test.csc | 294 ---------------- csc/loop.csc | 419 ----------------------- csc/macros-test.csc | 294 ---------------- csc/macros.csc | 801 -------------------------------------------- csc/main.csc | 76 ----- csc/match-test.csc | 113 ------- csc/match.csc | 80 ----- csc/shell.nix | 5 - csc/sort-test.csc | 37 -- csc/sort.csc | 28 -- csc/strings-test.csc | 103 ------ csc/strings.csc | 64 ---- csc/test-main.csc | 18 - csc/testing.csc | 91 ----- csc/vec-test.csc | 35 -- csc/vec.csc | 65 ---- guile-compat/compat.scm | 3 + guile-compat/csc.fish | 2 + guile-compat/lib/csc | 1 + lib/csc/assert-test.csc | 14 + lib/csc/assert.csc | 11 + lib/csc/codegen-test.csc | 132 ++++++++ lib/csc/codegen.csc | 260 ++++++++++++++ lib/csc/compare-test.csc | 98 ++++++ lib/csc/compare.csc | 248 ++++++++++++++ lib/csc/compiler.csc | 164 +++++++++ lib/csc/config.csc | 7 + lib/csc/cps-test.csc | 499 +++++++++++++++++++++++++++ lib/csc/cps.csc | 602 +++++++++++++++++++++++++++++++++ lib/csc/encoding-test.csc | 121 +++++++ lib/csc/encoding.csc | 184 ++++++++++ lib/csc/flag.csc | 119 +++++++ lib/csc/format-test.csc | 26 ++ lib/csc/format.csc | 50 +++ lib/csc/gensym.csc | 27 ++ lib/csc/hash-map-test.csc | 155 +++++++++ lib/csc/hash-map.csc | 492 +++++++++++++++++++++++++++ lib/csc/ir1.csc | 215 ++++++++++++ lib/csc/ir2.csc | 217 ++++++++++++ lib/csc/linker-test.csc | 49 +++ lib/csc/linker.csc | 119 +++++++ lib/csc/list-test.csc | 123 +++++++ lib/csc/list.csc | 85 +++++ lib/csc/loop-test.csc | 294 ++++++++++++++++ lib/csc/loop.csc | 419 +++++++++++++++++++++++ lib/csc/macros-test.csc | 294 ++++++++++++++++ lib/csc/macros.csc | 801 ++++++++++++++++++++++++++++++++++++++++++++ lib/csc/match-test.csc | 113 +++++++ lib/csc/match.csc | 80 +++++ lib/csc/sort-test.csc | 37 ++ lib/csc/sort.csc | 28 ++ lib/csc/strings-test.csc | 103 ++++++ lib/csc/strings.csc | 64 ++++ lib/csc/testing.csc | 91 +++++ lib/csc/vec-test.csc | 35 ++ lib/csc/vec.csc | 65 ++++ shell.nix | 5 + tests/test-main.csc | 21 ++ 88 files changed, 6557 insertions(+), 6551 deletions(-) create mode 100644 Makefile create mode 100644 csc.csc delete mode 100644 csc/Makefile delete mode 100644 csc/assert-test.csc delete mode 100644 csc/assert.csc delete mode 100644 csc/codegen-test.csc delete mode 100644 csc/codegen.csc delete mode 100644 csc/compare-test.csc delete mode 100644 csc/compare.csc delete mode 100644 csc/compiler.csc delete mode 100644 csc/config.csc delete mode 100644 csc/cps-test.csc delete mode 100644 csc/cps.csc delete mode 100644 csc/encoding-test.csc delete mode 100644 csc/encoding.csc delete mode 100644 csc/flag.csc delete mode 100644 csc/format-test.csc delete mode 100644 csc/format.csc delete mode 100644 csc/gensym.csc delete mode 100644 csc/guile-compat/compat.scm delete mode 100755 csc/guile-compat/csc.fish delete mode 120000 csc/guile-compat/lib/csc delete mode 100644 csc/hash-map-test.csc delete mode 100644 csc/hash-map.csc delete mode 100644 csc/ir1.csc delete mode 100644 csc/ir2.csc delete mode 100644 csc/linker-test.csc delete mode 100644 csc/linker.csc delete mode 100644 csc/list-test.csc delete mode 100644 csc/list.csc delete mode 100644 csc/loop-test.csc delete mode 100644 csc/loop.csc delete mode 100644 csc/macros-test.csc delete mode 100644 csc/macros.csc delete mode 100644 csc/main.csc delete mode 100644 csc/match-test.csc delete mode 100644 csc/match.csc delete mode 100644 csc/shell.nix delete mode 100644 csc/sort-test.csc delete mode 100644 csc/sort.csc delete mode 100644 csc/strings-test.csc delete mode 100644 csc/strings.csc delete mode 100644 csc/test-main.csc delete mode 100644 csc/testing.csc delete mode 100644 csc/vec-test.csc delete mode 100644 csc/vec.csc create mode 100644 guile-compat/compat.scm create mode 100755 guile-compat/csc.fish create mode 120000 guile-compat/lib/csc create mode 100644 lib/csc/assert-test.csc create mode 100644 lib/csc/assert.csc create mode 100644 lib/csc/codegen-test.csc create mode 100644 lib/csc/codegen.csc create mode 100644 lib/csc/compare-test.csc create mode 100644 lib/csc/compare.csc create mode 100644 lib/csc/compiler.csc create mode 100644 lib/csc/config.csc create mode 100644 lib/csc/cps-test.csc create mode 100644 lib/csc/cps.csc create mode 100644 lib/csc/encoding-test.csc create mode 100644 lib/csc/encoding.csc create mode 100644 lib/csc/flag.csc create mode 100644 lib/csc/format-test.csc create mode 100644 lib/csc/format.csc create mode 100644 lib/csc/gensym.csc create mode 100644 lib/csc/hash-map-test.csc create mode 100644 lib/csc/hash-map.csc create mode 100644 lib/csc/ir1.csc create mode 100644 lib/csc/ir2.csc create mode 100644 lib/csc/linker-test.csc create mode 100644 lib/csc/linker.csc create mode 100644 lib/csc/list-test.csc create mode 100644 lib/csc/list.csc create mode 100644 lib/csc/loop-test.csc create mode 100644 lib/csc/loop.csc create mode 100644 lib/csc/macros-test.csc create mode 100644 lib/csc/macros.csc create mode 100644 lib/csc/match-test.csc create mode 100644 lib/csc/match.csc create mode 100644 lib/csc/sort-test.csc create mode 100644 lib/csc/sort.csc create mode 100644 lib/csc/strings-test.csc create mode 100644 lib/csc/strings.csc create mode 100644 lib/csc/testing.csc create mode 100644 lib/csc/vec-test.csc create mode 100644 lib/csc/vec.csc create mode 100644 shell.nix create mode 100644 tests/test-main.csc diff --git a/Makefile b/Makefile new file mode 100644 index 0000000..ce7b5b4 --- /dev/null +++ b/Makefile @@ -0,0 +1,8 @@ +CSC := guile-compat/csc.fish + +.PHONY: test-csc +test: *.csc + $(CSC) tests/test-main.csc lib/csc/*-test.csc + +.PHONY: test +test: test-csc diff --git a/csc.csc b/csc.csc new file mode 100644 index 0000000..9dae75f --- /dev/null +++ b/csc.csc @@ -0,0 +1,76 @@ +(import (scheme base) + (only (scheme file) + open-binary-output-file) + (only (scheme read) + read) + (only (csc compiler) + *library-search-dirs* + compile) + (only (csc flag) + *args* + bool-flag + define-flag + parse-error-flag + parse-error-msg + parse-error? + parse-flags) + (only (csc format) + printf) + (only (csc loop) + loop) + (only (csc match) + match)) + + +(define-flag *include* "include" (lambda (s) (cons s *include*)) '()) +(define-flag *output* "output" string-copy "") +(define-flag *help* "help" bool-flag #f) +(define-flag *h* "h" bool-flag #f) + + +(define *help-msg* + "Usage: csc [OPTION]... [FILE] + + --include DIRECTORY Search in the given directory for libraries. + This flag can be passed more than once. + --output FILE Write output to the given file. The default is + to immediately execute. + + --help,-h Print the usage message. +") + + +(define (read-file f) + (call-with-input-file f + (lambda (p) + (loop for expr = (read p) + until (eof-object? expr) + collect expr)))) + + +(define (write-file f bytes) + (call-with-port (open-binary-output-file f) + (lambda (p) + (write-bytevector bytes p)))) + + +(define (main) + (guard (e ((parse-error? e) + (printf "Error: could not parse flag {}: {}\n{}" (parse-error-flag e) (parse-error-msg e) *help-msg*) + (exit 2))) + (parse-flags)) + (when (or *help* *h*) + (printf "{}" *help-msg*) + (exit 0)) + (when (string=? "" *output*) + (printf "For now, the option --output is required. In the future, we will be able to execute code directly.\n") + (exit 2)) + (define input-file (match *args* + ((file) file) + (_ (printf "Error: must pass exactly one file to csc.\n{}" *help-msg*) + (exit 2)))) + (set! *library-search-dirs* *include*) + (write-file *output* (compile (read-file input-file)))) + + +(main) diff --git a/csc/Makefile b/csc/Makefile deleted file mode 100644 index d4f1ab6..0000000 --- a/csc/Makefile +++ /dev/null @@ -1,5 +0,0 @@ -CSC := guile-compat/csc.fish - -.PHONY: test -test: *.csc - $(CSC) test-main.csc *-test.csc diff --git a/csc/assert-test.csc b/csc/assert-test.csc deleted file mode 100644 index 4e8d2d3..0000000 --- a/csc/assert-test.csc +++ /dev/null @@ -1,14 +0,0 @@ -(define-library (csc assert-test) - (import (scheme base) - (only (csc testing) - assert-raises - test) - (csc assert)) - (begin - (test assert-raises - (assert-raises error-object? - (assert #f))) - - - (test assert-ok - (assert #t)))) diff --git a/csc/assert.csc b/csc/assert.csc deleted file mode 100644 index 84d2096..0000000 --- a/csc/assert.csc +++ /dev/null @@ -1,11 +0,0 @@ -(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/csc/codegen-test.csc b/csc/codegen-test.csc deleted file mode 100644 index 29d1da5..0000000 --- a/csc/codegen-test.csc +++ /dev/null @@ -1,132 +0,0 @@ -(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/csc/codegen.csc b/csc/codegen.csc deleted file mode 100644 index ac5b313..0000000 --- a/csc/codegen.csc +++ /dev/null @@ -1,260 +0,0 @@ -(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 - (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) - ((stringstring 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/csc/compare-test.csc b/csc/compare-test.csc deleted file mode 100644 index b710115..0000000 --- a/csc/compare-test.csc +++ /dev/null @@ -1,98 +0,0 @@ -(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 - (make-test-type a b) - test-type? - %test-type - (a test-type-a) - (b test-type-b)) - - - (test diff-record - (assert - (string=? - " ( - (!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/csc/compare.csc b/csc/compare.csc deleted file mode 100644 index e8e68d3..0000000 --- a/csc/compare.csc +++ /dev/null @@ -1,248 +0,0 @@ -(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/csc/compiler.csc b/csc/compiler.csc deleted file mode 100644 index 20d5d37..0000000 --- a/csc/compiler.csc +++ /dev/null @@ -1,164 +0,0 @@ -(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) - ((stringstring 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/csc/config.csc b/csc/config.csc deleted file mode 100644 index d2618a7..0000000 --- a/csc/config.csc +++ /dev/null @@ -1,7 +0,0 @@ -(define-library (csc config) - (export *standard-library-dir*) - (import (scheme base)) - (begin - - - (define *standard-library-dir* "/usr/lib/csc"))) diff --git a/csc/cps-test.csc b/csc/cps-test.csc deleted file mode 100644 index 156ba60..0000000 --- a/csc/cps-test.csc +++ /dev/null @@ -1,499 +0,0 @@ -(define-library (csc cps-test) - (import (scheme base) - (only (csc gensym) - gensym - gensym?) - (only (csc ir1) - %constant - %lexical-ref - %library-ref - constant? - lexical-ref? - library-ref? - make-call - make-call-builtin - make-constant - make-define-syntax - make-if - make-lambda - make-letrec - make-lexical-ref - make-lexical-set - make-library-ref - make-sequence) - (only (csc ir2) - %apply - %branch - %closure - %fix - %globals - %label - %primitive - %variable - *globals* - apply? - branch? - closure? - fix? - globals? - label? - make-apply - make-branch - make-call-closure - make-closure - make-fix - make-label - make-primitive - make-variable - primitive? - variable?) - (only (csc testing) - assert-equal - test) - (csc cps)) - (begin - - - (define transform-ir2 - (list - (cons constant? %constant) - (cons lexical-ref? %lexical-ref) - (cons library-ref? %library-ref) - (cons variable? %variable) - (cons globals? %globals) - (cons label? %label) - (cons primitive? %primitive) - (cons branch? %branch) - (cons apply? %apply) - (cons closure? %closure) - (cons fix? %fix) - (cons gensym? (lambda (x) 'gensym)))) - - - (define (test-ref name) - (make-lexical-ref name (gensym))) - - - (define (tail x) - (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 'intlist '(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/csc/cps.csc b/csc/cps.csc deleted file mode 100644 index f2a9c90..0000000 --- a/csc/cps.csc +++ /dev/null @@ -1,602 +0,0 @@ -(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 'intlist '(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 - (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 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 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/csc/encoding-test.csc b/csc/encoding-test.csc deleted file mode 100644 index 6b28d8e..0000000 --- a/csc/encoding-test.csc +++ /dev/null @@ -1,121 +0,0 @@ -(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/csc/encoding.csc b/csc/encoding.csc deleted file mode 100644 index 9afa40f..0000000 --- a/csc/encoding.csc +++ /dev/null @@ -1,184 +0,0 @@ -(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/csc/flag.csc b/csc/flag.csc deleted file mode 100644 index c0a28a8..0000000 --- a/csc/flag.csc +++ /dev/null @@ -1,119 +0,0 @@ -(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 - (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 - (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/csc/format-test.csc b/csc/format-test.csc deleted file mode 100644 index 1906af6..0000000 --- a/csc/format-test.csc +++ /dev/null @@ -1,26 +0,0 @@ -(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/csc/format.csc b/csc/format.csc deleted file mode 100644 index 6ffd736..0000000 --- a/csc/format.csc +++ /dev/null @@ -1,50 +0,0 @@ -(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/csc/gensym.csc b/csc/gensym.csc deleted file mode 100644 index 480cbc2..0000000 --- a/csc/gensym.csc +++ /dev/null @@ -1,27 +0,0 @@ -(define-library (csc gensym) - (export - gensym - gensym->int - gensym=? - gensym?) - (import (scheme base)) - (begin - - - (define-record-type - (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/csc/guile-compat/compat.scm b/csc/guile-compat/compat.scm deleted file mode 100644 index 5997267..0000000 --- a/csc/guile-compat/compat.scm +++ /dev/null @@ -1,3 +0,0 @@ -(install-r7rs!) -(set! %load-extensions (cons ".csc" %load-extensions)) -(add-to-load-path (string-append (dirname (current-filename)) "/lib")) diff --git a/csc/guile-compat/csc.fish b/csc/guile-compat/csc.fish deleted file mode 100755 index ffda4d2..0000000 --- a/csc/guile-compat/csc.fish +++ /dev/null @@ -1,2 +0,0 @@ -#!/usr/bin/env fish -guile -l (dirname (status --current-filename))/compat.scm $argv diff --git a/csc/guile-compat/lib/csc b/csc/guile-compat/lib/csc deleted file mode 120000 index c25bddb..0000000 --- a/csc/guile-compat/lib/csc +++ /dev/null @@ -1 +0,0 @@ -../.. \ No newline at end of file diff --git a/csc/hash-map-test.csc b/csc/hash-map-test.csc deleted file mode 100644 index 6f83c30..0000000 --- a/csc/hash-map-test.csc +++ /dev/null @@ -1,155 +0,0 @@ -(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) (stringstring (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/csc/hash-map.csc b/csc/hash-map.csc deleted file mode 100644 index 682fa30..0000000 --- a/csc/hash-map.csc +++ /dev/null @@ -1,492 +0,0 @@ -(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 - (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 - (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 - (construct-map hash cmp root) - map? - (hash map-raw-hash) - (cmp map-cmp) - (root map-root)) - - - (define-record-type - (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 - (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) - ((stringstring 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) - ((stringstring 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/csc/ir1.csc b/csc/ir1.csc deleted file mode 100644 index b91e8ab..0000000 --- a/csc/ir1.csc +++ /dev/null @@ -1,215 +0,0 @@ -(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). - - - ; expression - ; Constant is used to include literal constants in scheme code. - (define-match-record-type - (make-constant expression) - constant? - %constant - (expression constant-expression)) - - - ; 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 - (make-lexical-ref name gensym) - lexical-ref? - %lexical-ref - (name lexical-ref-name) - (gensym lexical-ref-gensym)) - - - ; 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 - (make-library-ref name library) - library-ref? - %library-ref - (name library-ref-name) - (library library-ref-library)) - - - ; name gensym expression - ; Sets a lexically-bound variable. - (define-match-record-type - (make-lexical-set ref expression) - lexical-set? - %lexical-set - (ref lexical-set-ref) - (expression lexical-set-expression)) - - - ; name expression - ; Defines a new variable in the current library. - (define-match-record-type - (make-library-define ref expression) - library-define? - %library-define - (ref library-define-ref) - (expression library-define-expression)) - - - ; 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 - (make-define-syntax name transformer) - define-syntax? - %define-syntax - (name define-syntax-name) - (transformer define-syntax-transformer)) - - - ; test consequent alternate - ; A conditional. - (define-match-record-type - (make-if test consequent alternate) - if? - %if - (test if-test) - (consequent if-consequent) - (alternate if-alternate)) - - - ; 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 - (make-call procedure arguments) - call? - %call - (procedure call-procedure) - (arguments call-arguments)) - - - ; 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 bool - (define-match-record-type - (make-call-builtin operation arguments) - call-builtin? - %call-builtin - (operation call-builtin-operation) - (arguments call-builtin-arguments)) - - - ; head tail - ; Evaluate head, ignoring any result. Then tail is evaluated. - (define-match-record-type - (make-sequence head tail) - sequence? - %sequence - (head sequence-head) - (tail sequence-tail)) - - - ; 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 - (make-lambda arguments rest body) - lambda? - %lambda - (arguments lambda-arguments) - (rest lambda-rest) - (body lambda-body)) - - - ; 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 - (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/csc/ir2.csc b/csc/ir2.csc deleted file mode 100644 index 888437f..0000000 --- a/csc/ir2.csc +++ /dev/null @@ -1,217 +0,0 @@ -(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 . - - - ; A function argument or local variable. - (define-match-record-type - (make-variable gensym) - variable? - %variable - (gensym variable-gensym)) - - - ; The globals array. This will eventually be stored in register 0. - (define-match-record-type - (make-globals) - globals? - %globals) - - - ; A global instance of . - ; 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