From 68986fe0410584c6934c835bb0ee784655f5f8c5 Mon Sep 17 00:00:00 2001 From: Rose Hogenson Date: Tue, 11 Jan 2022 22:01:23 -0800 Subject: Move scheme compiler into a separate directory. --- Makefile | 5 - csc/Makefile | 5 + csc/encoding-test.csc | 117 ++++++++++++++++++++ csc/encoding.csc | 53 +++++++++ csc/format-test.csc | 24 ++++ csc/format.csc | 49 +++++++++ csc/gensym.csc | 25 +++++ csc/guile-compat/compat.scm | 3 + csc/guile-compat/csc.fish | 2 + csc/guile-compat/lib/csc | 1 + csc/hash-map-test.csc | 78 +++++++++++++ csc/hash-map.csc | 259 ++++++++++++++++++++++++++++++++++++++++++++ csc/ir1.csc | 213 ++++++++++++++++++++++++++++++++++++ csc/linker-test.csc | 24 ++++ csc/linker.csc | 67 ++++++++++++ csc/list-test.csc | 95 ++++++++++++++++ csc/list.csc | 64 +++++++++++ csc/macros.csc | 184 +++++++++++++++++++++++++++++++ csc/match-test.csc | 87 +++++++++++++++ csc/match.csc | 60 ++++++++++ csc/sort-test.csc | 35 ++++++ csc/sort.csc | 24 ++++ csc/strings-test.csc | 60 ++++++++++ csc/strings.csc | 46 ++++++++ csc/test-main.csc | 6 + csc/testing.csc | 81 ++++++++++++++ csc/vec-test.csc | 33 ++++++ csc/vec.csc | 54 +++++++++ encoding-test.csc | 117 -------------------- encoding.csc | 53 --------- format-test.csc | 24 ---- format.csc | 49 --------- gensym.csc | 25 ----- guile-compat/compat.scm | 3 - guile-compat/csc.fish | 2 - guile-compat/lib/csc | 1 - hash-map-test.csc | 78 ------------- hash-map.csc | 259 -------------------------------------------- ir1.csc | 213 ------------------------------------ linker-test.csc | 24 ---- linker.csc | 67 ------------ list-test.csc | 95 ---------------- list.csc | 64 ----------- macros.csc | 184 ------------------------------- match-test.csc | 87 --------------- match.csc | 60 ---------- sort-test.csc | 35 ------ sort.csc | 24 ---- strings-test.csc | 60 ---------- strings.csc | 46 -------- test-main.csc | 6 - testing.csc | 81 -------------- vec-test.csc | 33 ------ vec.csc | 54 --------- 54 files changed, 1749 insertions(+), 1749 deletions(-) delete mode 100644 Makefile create mode 100644 csc/Makefile create mode 100644 csc/encoding-test.csc create mode 100644 csc/encoding.csc create mode 100644 csc/format-test.csc create mode 100644 csc/format.csc create mode 100644 csc/gensym.csc create mode 100644 csc/guile-compat/compat.scm create mode 100755 csc/guile-compat/csc.fish create mode 120000 csc/guile-compat/lib/csc create mode 100644 csc/hash-map-test.csc create mode 100644 csc/hash-map.csc create mode 100644 csc/ir1.csc create mode 100644 csc/linker-test.csc create mode 100644 csc/linker.csc create mode 100644 csc/list-test.csc create mode 100644 csc/list.csc create mode 100644 csc/macros.csc create mode 100644 csc/match-test.csc create mode 100644 csc/match.csc create mode 100644 csc/sort-test.csc create mode 100644 csc/sort.csc create mode 100644 csc/strings-test.csc create mode 100644 csc/strings.csc create mode 100644 csc/test-main.csc create mode 100644 csc/testing.csc create mode 100644 csc/vec-test.csc create mode 100644 csc/vec.csc delete mode 100644 encoding-test.csc delete mode 100644 encoding.csc delete mode 100644 format-test.csc delete mode 100644 format.csc delete mode 100644 gensym.csc delete mode 100644 guile-compat/compat.scm delete mode 100755 guile-compat/csc.fish delete mode 120000 guile-compat/lib/csc delete mode 100644 hash-map-test.csc delete mode 100644 hash-map.csc delete mode 100644 ir1.csc delete mode 100644 linker-test.csc delete mode 100644 linker.csc delete mode 100644 list-test.csc delete mode 100644 list.csc delete mode 100644 macros.csc delete mode 100644 match-test.csc delete mode 100644 match.csc delete mode 100644 sort-test.csc delete mode 100644 sort.csc delete mode 100644 strings-test.csc delete mode 100644 strings.csc delete mode 100644 test-main.csc delete mode 100644 testing.csc delete mode 100644 vec-test.csc delete mode 100644 vec.csc diff --git a/Makefile b/Makefile deleted file mode 100644 index 4c2be61..0000000 --- a/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/Makefile b/csc/Makefile new file mode 100644 index 0000000..4c2be61 --- /dev/null +++ b/csc/Makefile @@ -0,0 +1,5 @@ +CSC = guile-compat/csc.fish + +.PHONY: test +test: *.csc + $(CSC) test-main.csc *-test.csc diff --git a/csc/encoding-test.csc b/csc/encoding-test.csc new file mode 100644 index 0000000..a7f4ace --- /dev/null +++ b/csc/encoding-test.csc @@ -0,0 +1,117 @@ +(import (scheme base) + (only (csc testing) test assert-equal) + (csc encoding)) + + +(test encode-const + (assert-equal + '(#xf2 #x3 0 0 0 0 0 0 #xf6 #xff #xff #xff #xff #xff #xff #xff) + (encode '((const -10))))) + + +(test encode-add + (assert-equal + '(#xfc #x3 0 0 0 0 0 0) + (encode '(add)))) + + +(test encode-sub + (assert-equal + '(#x6 #x4 0 0 0 0 0 0) + (encode '(sub)))) + + +(test encode-mul + (assert-equal + '(#x10 #x4 0 0 0 0 0 0) + (encode '(mul)))) + + +(test encode-div + (assert-equal + '(#x1a #x4 0 0 0 0 0 0) + (encode '(div)))) + + +(test encode-mod + (assert-equal + '(#x24 #x4 0 0 0 0 0 0) + (encode '(mod)))) + + +(test encode-alloc + (assert-equal + '(#xda #x7 0 0 0 0 0 0) + (encode '(alloc)))) + + +(test encode-peek + (assert-equal + '(#xe4 #x7 0 0 0 0 0 0 #xa) + (encode '((peek 10))))) + + +(test encode-poke + (assert-equal + '(#xee #x7 0 0 0 0 0 0 #xa) + (encode '((poke 10))))) + + +(test encode-peekbyte + (assert-equal + '(#xf8 #x7 0 0 0 0 0 0) + (encode '(peekbyte)))) + + +(test encode-pokebyte + (assert-equal + '(#x2 #x8 0 0 0 0 0 0) + (encode '(pokebyte)))) + + +(test encode-pop + (assert-equal + '(#xc2 #xb 0 0 0 0 0 0) + (encode '(pop)))) + + +(test encode-local + (assert-equal + '(#xcc #xb 0 0 0 0 0 0 #xa) + (encode '((local 10))))) + + +(test encode-if + (assert-equal + '(#xaa #xf 0 0 0 0 0 0 #xf6 #xff #xff #xff #xff #xff #xff #xff) + (encode '((if -10))))) + + +(test encode-call + (assert-equal + '(#xb4 #xf 0 0 0 0 0 0 #xa) + (encode '((call 10))))) + + +(test encode-ret + (assert-equal + '(#xbe #xf 0 0 0 0 0 0) + (encode '(ret)))) + + +(test encode-exit + (assert-equal + '(#xc8 #xf 0 0 0 0 0 0) + (encode '(exit)))) + + +(test encode-putc + (assert-equal + '(#x92 #x13 0 0 0 0 0 0) + (encode '(putc)))) + + +(test encode-getc + (assert-equal + '(#x9c #x13 0 0 0 0 0 0) + (encode '(getc)))) diff --git a/csc/encoding.csc b/csc/encoding.csc new file mode 100644 index 0000000..21ee88f --- /dev/null +++ b/csc/encoding.csc @@ -0,0 +1,53 @@ +(define-library (csc encoding) + (export encode) + (import (scheme base) + (only (csc match) match)) + (begin + + + (define (right-shift n1 n2) + (floor-quotient n1 (expt 2 n2))) ; Yikes. + + + (define (low-byte n) + (modulo n #x100)) + + + (define (64->le-bytes n) + (list + (low-byte n) + (low-byte (right-shift n 8)) + (low-byte (right-shift n 16)) + (low-byte (right-shift n 24)) + (low-byte (right-shift n 32)) + (low-byte (right-shift n 40)) + (low-byte (right-shift n 48)) + (low-byte (right-shift n 56)))) + + + (define (opcode-switch opcode) + (match opcode + (((! 'const) n) (append (64->le-bytes 1010) (64->le-bytes n))) + ((! 'add) (64->le-bytes 1020)) + ((! 'sub) (64->le-bytes 1030)) + ((! 'mul) (64->le-bytes 1040)) + ((! 'div) (64->le-bytes 1050)) + ((! 'mod) (64->le-bytes 1060)) + ((! 'alloc) (64->le-bytes 2010)) + (((! 'peek) n) (append (64->le-bytes 2020) (list n))) + (((! 'poke) n) (append (64->le-bytes 2030) (list n))) + ((! 'peekbyte) (64->le-bytes 2040)) + ((! 'pokebyte) (64->le-bytes 2050)) + ((! 'pop) (64->le-bytes 3010)) + (((! 'local) n) (append (64->le-bytes 3020) (list n))) + (((! 'if) n) (append (64->le-bytes 4010) (64->le-bytes n))) + (((! 'call) n) (append (64->le-bytes 4020) (list n))) + ((! 'ret) (64->le-bytes 4030)) + ((! 'exit) (64->le-bytes 4040)) + ((! 'putc) (64->le-bytes 5010)) + ((! 'getc) (64->le-bytes 5020)) + (_ (error "invalid opcode" opcode)))) + + + (define (encode program) + (apply append (map opcode-switch program))))) diff --git a/csc/format-test.csc b/csc/format-test.csc new file mode 100644 index 0000000..6efaa87 --- /dev/null +++ b/csc/format-test.csc @@ -0,0 +1,24 @@ +(import (scheme base) + (only (csc strings) str-quote) + (only (csc testing) assert-equal test) + (csc format)) + + +(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 new file mode 100644 index 0000000..0469812 --- /dev/null +++ b/csc/format.csc @@ -0,0 +1,49 @@ +(define-library (csc format) + (export + fprintf + printf + sprintf) + (import (scheme base) + (only (scheme write) display) + (only (csc strings) + find + not-found-error? + prefix?)) + (begin + + + (define (fprintf port format-string . format-args) + (let loop ((start 0) + (args format-args)) + (cond ((>= start (string-length format-string))) + ((prefix? "{{" format-string start) + (write-string "{" port) + (loop (+ 2 start) args)) + ((prefix? "}}" format-string start) + (write-string "}" port) + (loop (+ 2 start) args)) + ((prefix? "{}" format-string start) + (display (car args) port) + (loop (+ 2 start) (cdr args))) + ((prefix? "{" format-string start) + (raise (error "invalid format string" format-string))) + (else + (let* ((open-brace-pos (guard (e + ((not-found-error? e) (string-length format-string))) + (find "{" format-string start))) + (close-brace-pos (guard (e + ((not-found-error? e) (string-length format-string))) + (find "}" format-string start))) + (format-pos (min open-brace-pos close-brace-pos))) + (write-string format-string port start format-pos) + (loop format-pos args)))))) + + + (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 new file mode 100644 index 0000000..a7c30c5 --- /dev/null +++ b/csc/gensym.csc @@ -0,0 +1,25 @@ +(define-library (csc gensym) + (export + gensym + gensym=?) + (import (scheme base)) + (begin + + + (define-record-type + (make-gensym id) + gensym? + (id gensym-id)) + + + (define (gensym=? s1 s2) + (= (gensym-id s1) (gensym-id 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 new file mode 100644 index 0000000..5997267 --- /dev/null +++ b/csc/guile-compat/compat.scm @@ -0,0 +1,3 @@ +(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 new file mode 100755 index 0000000..ffda4d2 --- /dev/null +++ b/csc/guile-compat/csc.fish @@ -0,0 +1,2 @@ +#!/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 new file mode 120000 index 0000000..c25bddb --- /dev/null +++ b/csc/guile-compat/lib/csc @@ -0,0 +1 @@ +../.. \ No newline at end of file diff --git a/csc/hash-map-test.csc b/csc/hash-map-test.csc new file mode 100644 index 0000000..353e6b4 --- /dev/null +++ b/csc/hash-map-test.csc @@ -0,0 +1,78 @@ +(import (scheme base) + (only (csc sort) sort) + (only (csc testing) + assert-equal + assert-raises + test) + (csc hash-map)) + + +(define (hash-symbol s) + (hash-bytevector (string->utf8 (symbol->string s)))) + + +(define (symbolstring s1) (symbol->string s2))) + + +(define (alist->map->alist l) + (map->alist (alist->map hash-symbol symbolalist-singleton + (assert-equal (sort-alist '((a . 1))) (sort-alist (alist->map->alist '((a . 1)))))) + + +(test map->alist-two + (assert-equal (sort-alist '((a . 1) (b . 2))) (sort-alist (alist->map->alist '((a . 1) (b . 2)))))) + + +(test map->alist-longer + (assert-equal + (sort-alist '((a . 1) (b . 2) (c . 3) (d . 4) (e . 5) (f . 6))) + (sort-alist (alist->map->alist '((a . 1) (b . 2) (c . 3) (d . 4) (e . 5) (f . 6)))))) + + +(test map->alist-larger + (assert-equal + (sort-alist '((f . 5) (m . 1) (n . 7) (q . 3) (x . 8))) + (sort-alist (alist->map->alist '((m . 1) (n . 2) (q . 3) (f . 5) (n . 7) (x . 8)))))) + + +(test map->alist-in-order + (assert-equal + (sort-alist '((a . ()) (b . ()) (c . ()) (d . ()) (e . ()) (f . ()) (g . ()) (h . ()))) + (sort-alist (alist->map->alist '((a . ()) (b . ()) (c . ()) (d . ()) (e . ()) (f . ()) (g . ()) (h . ())))))) + + +(test map->alist-reversed + (assert-equal + (sort-alist '((h . ()) (g . ()) (f . ()) (e . ()) (d . ()) (c . ()) (b . ()) (a . ()))) + (sort-alist (alist->map->alist '((a . ()) (b . ()) (c . ()) (d . ()) (e . ()) (f . ()) (g . ()) (h . ())))))) + + +(test map->alist-overwrite + (assert-equal + (sort-alist '((a . 2))) + (sort-alist (alist->map->alist '((a . 1) (a . 2)))))) + + +(test map->alist-alternating + (assert-equal + (sort-alist '((h . ()) (g . ()) (i . ()) (f . ()) (j . ()) (e . ()) (k . ()) (d . ()) (l . ()) (c . ()))) + (sort-alist (alist->map->alist '((c . ()) (d . ()) (e . ()) (f . ()) (g . ()) (h . ()) (i . ()) (j . ()) (k . ()) (l . ())))))) + + +(test lookup + (assert-equal + 2 + (lookup (alist->map hash-symbol symbolmap hash-symbol symbolmap + hash-bytevector + map->alist + for-each + insert + lookup + map? + key-not-found-error? + make-map) + (import (scheme base) + (only (csc format) sprintf)) + (begin + + + (define-record-type + (make-key-hash k hash) + key-hash? + (k key-hash-value) + (hash key-hash-hash)) + + + (define (key-hash (key-hash-hash k1) (key-hash-hash k2)) #f) + ((key + (make-node color key-hash val left right) + node? + (color node-color) + (key-hash node-key) + (val node-value) + (left node-left) + (right node-right)) + + + (define (red? n) + (if (null? n) + #f + (eq? 'red (node-color n)))) + + + (define (black? n) + (if (null? n) + #t + (eq? 'black (node-color n)))) + + + (define (rebalance-left m) + (let ((p (node-left m)) + (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 + (make-node 'red (node-key m) (node-value m) + (make-node 'black (node-key p) (node-value p) (node-left p) (node-right p)) + (make-node 'black (node-key u) (node-value 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) + (let ((u (node-left m)) + (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 m k v key + (construct-hash-map hash key + (make-key-not-found-error) + key-not-found-error?) + + + (define (lookup m k) + (letrec ((k* (make-key-hash k ((hash-map-hash m) k))) + (lookup + (lambda (n) + (cond ((null? n) (raise (make-key-not-found-error))) + ((key-hashalist m) + (let ((alist '())) + (for-each + (lambda (k v) + (set! alist (cons (cons k v) alist))) + m) + alist)) + + + (define (alist->map hash key= i (bytevector-length b)) + hash + (loop (+ 1 i) (+ (* hash #x100) (bytevector-u8-ref b i)))))))) diff --git a/csc/ir1.csc b/csc/ir1.csc new file mode 100644 index 0000000..53dacc1 --- /dev/null +++ b/csc/ir1.csc @@ -0,0 +1,213 @@ +(define-library (csc ir1) + (export + call-arguments + call-procedure + call? + constant-expression + constant? + if-alternate + if-consequent + if-test + if? + lambda-body + lambda-case-alternate + lambda-case-arguments + lambda-case-body + lambda-case-gensyms + lambda-case-rest + lambda-case? + 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-gensym + lexical-set-name + lexical-set? + library-ref-library + library-ref-name + library-ref-public? + library-ref? + library-set-expression + library-set-library + library-set-name + library-set-public? + library-set? + make-call + make-constant + make-if + make-lambda + make-lambda-case + make-letrec + make-lexical-ref + make-lexical-set + make-library-ref + make-library-set + make-sequence + make-toplevel-define + make-void + sequence-head + sequence-tail + sequence? + toplevel-define-expression + toplevel-define-name + toplevel-define? + void?) + (import (scheme base)) + (begin + ; This library defines the intermediate representation IR1. An expression + ; in IR1 has one of the following forms (plagiarized from Guile's + ; Tree-IL). + + + ; + ; An empty expression. In practice, equivalent to Scheme's (if #f #f). + (define-record-type + (make-void) + void?) + + + ; expression + ; Constant is used to include literal constants in scheme code. + (define-record-type + (make-constant expression) + 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-record-type + (make-lexical-ref name gensym) + lexical-ref? + (name lexical-ref-name) + (gensym lexical-ref-gensym)) + + + ; name gensym expression + ; Sets a lexically-bound variable. + (define-record-type + (make-lexical-set name gensym expression) + lexical-set? + (name lexical-set-name) + (gensym lexical-set-gensym) + (expression lexical-set-expression)) + + + ; library name public? + ; A reference to a variable in a specific library. library should be the name + ; of the library, e.g. (scheme base). + ; + ; If public? is true, name will be looked up in library's public interface, + ; otherwise it will be looked up among the library's private bindings. + (define-record-type + (make-library-ref library name public?) + library-ref? + (library library-ref-library) + (name library-ref-name) + (public? library-ref-public?)) + + + ; library name public? expression + ; Sets a variable in a specific library. + (define-record-type + (make-library-set library name public? expression) + library-set? + (library library-set-library) + (name library-set-name) + (public? library-set-public?) + (expression library-set-expression)) + + + ; name expression + ; Defines a new variable in the current library. + (define-record-type + (make-toplevel-define name expression) + toplevel-define? + (name toplevel-define-name) + (expression toplevel-define-expression)) + + + ; test consequent alternate + ; A conditional. + (define-record-type + (make-if test consequent alternate) + 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-record-type + (make-call procedure arguments) + call? + (procedure call-procedure) + (arguments call-arguments)) + + + ; head tail + ; Evaluate head, ignoring any result. Then tail is evaluated. + (define-record-type + (make-sequence head tail) + sequence? + (head sequence-head) + (tail sequence-tail)) + + + ; body + ; A closure. body is an expression of type . + (define-record-type + (make-lambda body) + lambda? + (body lambda-body)) + + + ; arguments rest gensyms body alternate + ; One clause of a case-lambda. A lambda expression in Scheme is treated as + ; a case-lambda with one clause. + ; + ; arguments is a list of the procedures arguments, as symbols. rest is the + ; name of the rest argument, or #f. gensyms is a list of gensyms + ; corresponding to all arguments: first all of the normal arguments, then + ; the rest argument if any. + ; + ; body is the name of the clause. If the procedure is called with an + ; appropriate number of arguments, body is evaluated in tail position. + ; Otherwise if there is an alternate, it should be a + ; expression, representing the next clause to try. If there is no + ; alternate, an error is signaled. + (define-record-type + (make-lambda-case arguments rest gensyms body alternate) + lambda-case? + (arguments lambda-case-arguments) + (rest lambda-case-rest) + (gensyms lambda-case-gensyms) + (body lambda-case-body) + (alternate lambda-case-alternate)) + + + ; 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-record-type + (make-letrec in-order? names gensyms values expression) + letrec? + (in-order? letrec-in-order?) + (names letrec-names) + (gensyms letrec-gensyms) + (values letrec-values) + (expression letrec-expression)))) diff --git a/csc/linker-test.csc b/csc/linker-test.csc new file mode 100644 index 0000000..084e9ae --- /dev/null +++ b/csc/linker-test.csc @@ -0,0 +1,24 @@ +(import (scheme base) + (only (csc encoding) encode) + (only (csc testing) + assert-equal + test) + (csc linker)) + + +(test link-if + (assert-equal + (encode '((const 5) (const 1) (if 2) (const 5) add exit)) + (link '((const 5) (const 1) (if "label1") (const 5) add (label "label1") exit)))) + + +(test link-backwards-if + (assert-equal + (encode '((const 10) (const 5) add (if -3))) + (link '((const 10) (label "label1") (const 5) add (if "label1"))))) + + +(test link-call + (assert-equal + (encode '((call 3) (const 10) exit (const 5) exit)) + (link '((call "label1") (const 10) (label "label0") exit (label "label1") (const 5) exit)))) diff --git a/csc/linker.csc b/csc/linker.csc new file mode 100644 index 0000000..852ee13 --- /dev/null +++ b/csc/linker.csc @@ -0,0 +1,67 @@ +(define-library (csc linker) + (export link remove-labels make-label-map translate-labels) + (import (scheme base) + (only (csc encoding) encode) + (only (csc format) sprintf) + (only (csc hash-map) + hash-bytevector + insert + lookup + make-map) + (only (csc list) + enumerate + filter) + (only (csc match) match)) + (begin + ; A CSC bytecode program is a list of opcodes. An opcode is a symbol, or a 2 + ; item list of a symbol and an argument. The full list of opcodes can be + ; found in encoding.csc. + + + (define (translate-labels program label-map) + (map + (lambda (x) + (match x + ((i . ((! 'if) label)) + ; Compute offset from the current position. Subtract 1 + ; because the instruction pointer is incremented each + ; time already. + (list 'if (- (lookup label-map label) i 1))) + ((_ . ((! 'call) label)) + (list 'call (lookup label-map label))) + ((_ . opcode) opcode))) + (enumerate program))) + (lambda (i . opcode) + (match opcode + (((! 'if) label) #t) + (_ #f))) + + + (define (hash-string s) + (hash-bytevector (string->utf8 s))) + + + (define (make-label-map program) + (let loop ((m (make-map hash-string stringmap + hash-bytevector + insert + key-not-found-error? + lookup) + (only (csc ir1) + make-call + make-constant + make-lambda + make-lambda-case) + (only (csc list) revappend) + (only (csc match) match)) + (begin + + + (define-record-type + (make-macro-transformer transformer) + macro-transformer? + (transformer transformer-function)) + + + (define-record-type + (make-macro-syntax-error message irritants) + macro-syntax-error? + (message syntax-error-object-message) + (irritants syntax-error-object-irritants)) + + + (define (raise-syntax-error message . irritants) + (raise (make-macro-syntax-error message irritants))) + + + ; symbols is a map with symbols as keys, and the values can be one of: + ; - , + ; - , + ; - or . + ; The first two correspond to variables bound lexically or from a module, + ; and the third represents a macro transformer bound in the + ; current context. + ; + ; library is the current library name being compiled. A nil library + ; corresponds to top level expressions. + (define-record-type + (make-environment symbols library) + environment? + (symbols environment-symbols) + (library environment-library)) + + + (define (with-binding environment symbol binding) + (make-environment (insert (environment-symbols environment) symbol binding) (environment-library environment))) + + + (define (expand-procedure-call procedure arguments environment) + (let*-values (((expanded-procedure environment) (expand procedure environment)) + ((expanded-arguments environment) + (let loop ((arguments arguments) + (environment environment) + (expanded-arguments '())) + (match arguments + ('() (values (reverse expanded-arguments) environment)) + ((argument . rest) + (let-values (((expanded-argument environment) (expand argument environment))) + (loop + rest + environment + (cons expanded-argument expanded-arguments)))) + (_ (raise-syntax-error "arguments to a procedure call must be a list" procedure arguments)))))) + (make-call expanded-procedure expanded-arguments))) + + + ; expand can be thought of as a compiler from Scheme to IR1. Macros + ; included in the environment can be used to extend the syntax. Returns an + ; IR1 expression and an environment which has been modified with any new + ; bindings introduced by the expression. + (define (expand expression environment) + (cond + ((null? expression) (raise-syntax-error "nil by itself is an error (did you mean to use quote?)" expression)) + ((and (pair? expression) + (symbol? (car expression))) + (let* ((macro-name (car expression)) + (macro-body + (guard (e ((key-not-found-error? e) (raise-syntax-error "undefined symbol" macro-name))) + (lookup (environment-symbols environment) macro-name)))) + (if (macro-transformer? macro-body) + ((transformer-function macro-body) expression environment) + (expand-procedure-call macro-name (cdr expression) environment)))) + ((pair? expression) + (let ((procedure (car expression)) + (arguments (cdr expression))) + (expand-procedure-call procedure arguments environment))) + ((symbol? expression) + (let ((binding + (guard (e ((key-not-found-error? e) (raise-syntax-error "undefined symbol" expression))) + (lookup (environment-symbols environment) expression)))) + (if (macro-transformer? binding) + (raise-syntax-error "macro is not allowed in this context" expression) + (values binding environment)))) + ((or (boolean? expression) + (bytevector? expression) + (char? expression) + (number? expression) + (string? expression) + (vector? expression)) + (values (make-constant expression) environment)) + (else (raise-syntax-error "unexpected expression type" expression)))) + + + (define builtin-quote + (make-macro-transformer + (lambda (expression environment) + (match expression + ((_ datum) (values (make-constant datum) environment)) + (_ (raise-syntax-error "invalid form for quote" expression)))))) + + + (define builtin-lambda + (make-macro-transformer + (lambda (expression environment) + (match expression + ((_ formals body) + (let loop ((formals formals) + (environment environment) + (argument-names '()) + (gensyms '())) + (match formals + ('() + (make-lambda + (make-lambda-case + (reverse argument-names) + #f + (reverse gensyms) + (expand body environment) + #f))) + ((variable . variables) (when (symbol? variable)) + (let ((sym (gensym))) + (loop + variables + (with-binding environment variable sym) + (cons variable argument-names) + (cons sym gensyms)))) + (variable (when (symbol? variable)) + (let ((sym (gensym))) + (make-lambda + (make-lambda-case + (reverse argument-names) + variable + (revappend gensyms (list sym)) + (expand body (with-binding environment variable sym)) + #f)))) + (_ (raise-syntax-error "invalid form for lambda arguments" expression))))) + (_ (raise-syntax-error "invalid form for lambda" expression)))))) + + + #;(define builtin-syntax-rules + (make-macro-transformer + (lambda (expression environment) + (match expression)))) + + + (define (hash-symbol s) + (hash-bytevector (string->utf8 (symbol->string s)))) + + + (define (symbolstring s1) (symbol->string s2))) + + + (define test-environment + (make-environment + (alist->map + hash-symbol + symbol + (make-not-found-error) + not-found-error?) + + + (define find + (case-lambda + ((match str) (find match str 0 (string-length str))) + ((match str start) (find match str start (string-length str))) + ((match str start end) + (let loop ((i start)) + (cond ((>= i end) (raise (make-not-found-error))) + ((prefix? match str i) i) + (else (loop (+ 1 i)))))))) + + + (define (join sep . strings) + (apply string-append (intercalate sep strings))))) diff --git a/csc/test-main.csc b/csc/test-main.csc new file mode 100644 index 0000000..7b45883 --- /dev/null +++ b/csc/test-main.csc @@ -0,0 +1,6 @@ +(import (scheme base) + (only (csc testing) test-main)) + + +(for-each load (cdr (command-line))) +(test-main) diff --git a/csc/testing.csc b/csc/testing.csc new file mode 100644 index 0000000..a0180e6 --- /dev/null +++ b/csc/testing.csc @@ -0,0 +1,81 @@ +(define-library (csc testing) + (export + assert + assert-equal + assert-raises + test + test-main) + (import (scheme base) + (only (csc format) + printf + sprintf)) + (begin + + + (define *all-tests-succeeded* #t) + + + (define (set-all-succeeded! val) (set! *all-tests-succeeded* val)) + + + (define-record-type + (make-test-handle test-name) + test-handle? + (test-name test-name set-name!)) + + + (define-record-type + (make-test-error) + test-error?) + + + (define *test-handle* (make-test-handle "global")) + + + (define-syntax test + (syntax-rules () + ((test name body body* ...) + (begin + (set-name! *test-handle* (symbol->string 'name)) + (printf "=== RUN {}\n" 'name) + (guard (e ((test-error? e) + (printf "--- FAIL: {}\n" 'name) + (set-all-succeeded! #f))) + body body* ... + (printf "--- PASS: {}\n" 'name)))))) + + + (define (fatalf format-string . format-args) + (printf "{}: {}\n" (test-name *test-handle*) (apply sprintf format-string format-args)) + (raise (make-test-error))) + + + (define-syntax assert + (syntax-rules () + ((assert expr) + (unless expr + (fatalf "(assert {}) failed." 'expr))))) + + + (define-syntax assert-equal + (syntax-rules () + ((assert-equal left right) + (let ((x left) + (y right)) + (unless (equal? x y) + (fatalf "Fatal: {} is not equal to {}.\nleft is {}\nright is {}" 'left 'right x y)))))) + + + (define-syntax assert-raises + (syntax-rules () + ((assert-raises predicate body body* ...) + (assert + (guard (e ((predicate e) #t)) + body body* ... + #f))))) + + + (define (test-main) + (if *all-tests-succeeded* + (printf "PASS\n") + (printf "FAIL\n"))))) diff --git a/csc/vec-test.csc b/csc/vec-test.csc new file mode 100644 index 0000000..8a19b3e --- /dev/null +++ b/csc/vec-test.csc @@ -0,0 +1,33 @@ +(import (scheme base) + (only (csc testing) + assert-equal + test) + (csc vec)) + + +(test vec-empty + (assert-equal '() (vec->list (vec)))) + + +(test vec-singleton + (assert-equal '(1) (vec->list (vec 1)))) + + +(test vec-append-to-empty + (assert-equal '(1) (vec->list (vec-append (vec) 1)))) + + +(test vec-append-to-singleton + (assert-equal '(1 2) (vec->list (vec-append (vec 1) 2)))) + + +(test vec-append-to-2-elem + (assert-equal '(1 2 3) (vec->list (vec-append (vec 1 2) 3)))) + + +(test vec-ref-1 + (assert-equal 2 (vec-ref (vec 1 2) 1))) + + +(test vec-ref-singleton + (assert-equal 1 (vec-ref (vec 1) 0))) diff --git a/csc/vec.csc b/csc/vec.csc new file mode 100644 index 0000000..03f2b0f --- /dev/null +++ b/csc/vec.csc @@ -0,0 +1,54 @@ +(define-library (csc vec) + (export + list->vec + vec + vec->list + vec-append + vec-length + vec-ref + vec?) + (import (scheme base)) + (begin + + + (define-record-type + (make-vec len arr) + vec? + (len vec-length) + (arr vec-arr)) + + + (define (list->vec l) + (let ((arr (list->vector l))) + (make-vec (vector-length arr) arr))) + + + (define (vec->list v) + (vector->list (vec-arr v) 0 (vec-length v))) + + + (define (vec . xs) + (list->vec xs)) + + + (define (vec-append v . xs) + (let ((append-one + (lambda (v x) + (let ((new-v (if (> (vector-length (vec-arr v)) (vec-length v)) + v + (let ((new-arr (make-vector (max 1 (* 2 (vec-length v)))))) + (vector-copy! new-arr 0 (vec-arr v)) + (make-vec (vec-length v) new-arr))))) + (vector-set! (vec-arr new-v) (vec-length new-v) x) + (make-vec (+ 1 (vec-length new-v)) (vec-arr new-v)))))) + (let loop ((v v) + (xs xs)) + (if (null? xs) + v + (loop (append-one v (car xs)) (cdr xs)))))) + + + (define (vec-ref v k) + (if (>= k (vec-length v)) + (error "index out of bounds" k) + (vector-ref (vec-arr v) k))))) diff --git a/encoding-test.csc b/encoding-test.csc deleted file mode 100644 index a7f4ace..0000000 --- a/encoding-test.csc +++ /dev/null @@ -1,117 +0,0 @@ -(import (scheme base) - (only (csc testing) test assert-equal) - (csc encoding)) - - -(test encode-const - (assert-equal - '(#xf2 #x3 0 0 0 0 0 0 #xf6 #xff #xff #xff #xff #xff #xff #xff) - (encode '((const -10))))) - - -(test encode-add - (assert-equal - '(#xfc #x3 0 0 0 0 0 0) - (encode '(add)))) - - -(test encode-sub - (assert-equal - '(#x6 #x4 0 0 0 0 0 0) - (encode '(sub)))) - - -(test encode-mul - (assert-equal - '(#x10 #x4 0 0 0 0 0 0) - (encode '(mul)))) - - -(test encode-div - (assert-equal - '(#x1a #x4 0 0 0 0 0 0) - (encode '(div)))) - - -(test encode-mod - (assert-equal - '(#x24 #x4 0 0 0 0 0 0) - (encode '(mod)))) - - -(test encode-alloc - (assert-equal - '(#xda #x7 0 0 0 0 0 0) - (encode '(alloc)))) - - -(test encode-peek - (assert-equal - '(#xe4 #x7 0 0 0 0 0 0 #xa) - (encode '((peek 10))))) - - -(test encode-poke - (assert-equal - '(#xee #x7 0 0 0 0 0 0 #xa) - (encode '((poke 10))))) - - -(test encode-peekbyte - (assert-equal - '(#xf8 #x7 0 0 0 0 0 0) - (encode '(peekbyte)))) - - -(test encode-pokebyte - (assert-equal - '(#x2 #x8 0 0 0 0 0 0) - (encode '(pokebyte)))) - - -(test encode-pop - (assert-equal - '(#xc2 #xb 0 0 0 0 0 0) - (encode '(pop)))) - - -(test encode-local - (assert-equal - '(#xcc #xb 0 0 0 0 0 0 #xa) - (encode '((local 10))))) - - -(test encode-if - (assert-equal - '(#xaa #xf 0 0 0 0 0 0 #xf6 #xff #xff #xff #xff #xff #xff #xff) - (encode '((if -10))))) - - -(test encode-call - (assert-equal - '(#xb4 #xf 0 0 0 0 0 0 #xa) - (encode '((call 10))))) - - -(test encode-ret - (assert-equal - '(#xbe #xf 0 0 0 0 0 0) - (encode '(ret)))) - - -(test encode-exit - (assert-equal - '(#xc8 #xf 0 0 0 0 0 0) - (encode '(exit)))) - - -(test encode-putc - (assert-equal - '(#x92 #x13 0 0 0 0 0 0) - (encode '(putc)))) - - -(test encode-getc - (assert-equal - '(#x9c #x13 0 0 0 0 0 0) - (encode '(getc)))) diff --git a/encoding.csc b/encoding.csc deleted file mode 100644 index 21ee88f..0000000 --- a/encoding.csc +++ /dev/null @@ -1,53 +0,0 @@ -(define-library (csc encoding) - (export encode) - (import (scheme base) - (only (csc match) match)) - (begin - - - (define (right-shift n1 n2) - (floor-quotient n1 (expt 2 n2))) ; Yikes. - - - (define (low-byte n) - (modulo n #x100)) - - - (define (64->le-bytes n) - (list - (low-byte n) - (low-byte (right-shift n 8)) - (low-byte (right-shift n 16)) - (low-byte (right-shift n 24)) - (low-byte (right-shift n 32)) - (low-byte (right-shift n 40)) - (low-byte (right-shift n 48)) - (low-byte (right-shift n 56)))) - - - (define (opcode-switch opcode) - (match opcode - (((! 'const) n) (append (64->le-bytes 1010) (64->le-bytes n))) - ((! 'add) (64->le-bytes 1020)) - ((! 'sub) (64->le-bytes 1030)) - ((! 'mul) (64->le-bytes 1040)) - ((! 'div) (64->le-bytes 1050)) - ((! 'mod) (64->le-bytes 1060)) - ((! 'alloc) (64->le-bytes 2010)) - (((! 'peek) n) (append (64->le-bytes 2020) (list n))) - (((! 'poke) n) (append (64->le-bytes 2030) (list n))) - ((! 'peekbyte) (64->le-bytes 2040)) - ((! 'pokebyte) (64->le-bytes 2050)) - ((! 'pop) (64->le-bytes 3010)) - (((! 'local) n) (append (64->le-bytes 3020) (list n))) - (((! 'if) n) (append (64->le-bytes 4010) (64->le-bytes n))) - (((! 'call) n) (append (64->le-bytes 4020) (list n))) - ((! 'ret) (64->le-bytes 4030)) - ((! 'exit) (64->le-bytes 4040)) - ((! 'putc) (64->le-bytes 5010)) - ((! 'getc) (64->le-bytes 5020)) - (_ (error "invalid opcode" opcode)))) - - - (define (encode program) - (apply append (map opcode-switch program))))) diff --git a/format-test.csc b/format-test.csc deleted file mode 100644 index 6efaa87..0000000 --- a/format-test.csc +++ /dev/null @@ -1,24 +0,0 @@ -(import (scheme base) - (only (csc strings) str-quote) - (only (csc testing) assert-equal test) - (csc format)) - - -(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/format.csc b/format.csc deleted file mode 100644 index 0469812..0000000 --- a/format.csc +++ /dev/null @@ -1,49 +0,0 @@ -(define-library (csc format) - (export - fprintf - printf - sprintf) - (import (scheme base) - (only (scheme write) display) - (only (csc strings) - find - not-found-error? - prefix?)) - (begin - - - (define (fprintf port format-string . format-args) - (let loop ((start 0) - (args format-args)) - (cond ((>= start (string-length format-string))) - ((prefix? "{{" format-string start) - (write-string "{" port) - (loop (+ 2 start) args)) - ((prefix? "}}" format-string start) - (write-string "}" port) - (loop (+ 2 start) args)) - ((prefix? "{}" format-string start) - (display (car args) port) - (loop (+ 2 start) (cdr args))) - ((prefix? "{" format-string start) - (raise (error "invalid format string" format-string))) - (else - (let* ((open-brace-pos (guard (e - ((not-found-error? e) (string-length format-string))) - (find "{" format-string start))) - (close-brace-pos (guard (e - ((not-found-error? e) (string-length format-string))) - (find "}" format-string start))) - (format-pos (min open-brace-pos close-brace-pos))) - (write-string format-string port start format-pos) - (loop format-pos args)))))) - - - (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/gensym.csc b/gensym.csc deleted file mode 100644 index a7c30c5..0000000 --- a/gensym.csc +++ /dev/null @@ -1,25 +0,0 @@ -(define-library (csc gensym) - (export - gensym - gensym=?) - (import (scheme base)) - (begin - - - (define-record-type - (make-gensym id) - gensym? - (id gensym-id)) - - - (define (gensym=? s1 s2) - (= (gensym-id s1) (gensym-id s2))) - - - (define *next-id* 0) - - - (define (gensym) - (let ((sym (make-gensym *next-id*))) - (set! *next-id* (+ 1 *next-id*)) - sym)))) diff --git a/guile-compat/compat.scm b/guile-compat/compat.scm deleted file mode 100644 index 5997267..0000000 --- a/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/guile-compat/csc.fish b/guile-compat/csc.fish deleted file mode 100755 index ffda4d2..0000000 --- a/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/guile-compat/lib/csc b/guile-compat/lib/csc deleted file mode 120000 index c25bddb..0000000 --- a/guile-compat/lib/csc +++ /dev/null @@ -1 +0,0 @@ -../.. \ No newline at end of file diff --git a/hash-map-test.csc b/hash-map-test.csc deleted file mode 100644 index 353e6b4..0000000 --- a/hash-map-test.csc +++ /dev/null @@ -1,78 +0,0 @@ -(import (scheme base) - (only (csc sort) sort) - (only (csc testing) - assert-equal - assert-raises - test) - (csc hash-map)) - - -(define (hash-symbol s) - (hash-bytevector (string->utf8 (symbol->string s)))) - - -(define (symbolstring s1) (symbol->string s2))) - - -(define (alist->map->alist l) - (map->alist (alist->map hash-symbol symbolalist-singleton - (assert-equal (sort-alist '((a . 1))) (sort-alist (alist->map->alist '((a . 1)))))) - - -(test map->alist-two - (assert-equal (sort-alist '((a . 1) (b . 2))) (sort-alist (alist->map->alist '((a . 1) (b . 2)))))) - - -(test map->alist-longer - (assert-equal - (sort-alist '((a . 1) (b . 2) (c . 3) (d . 4) (e . 5) (f . 6))) - (sort-alist (alist->map->alist '((a . 1) (b . 2) (c . 3) (d . 4) (e . 5) (f . 6)))))) - - -(test map->alist-larger - (assert-equal - (sort-alist '((f . 5) (m . 1) (n . 7) (q . 3) (x . 8))) - (sort-alist (alist->map->alist '((m . 1) (n . 2) (q . 3) (f . 5) (n . 7) (x . 8)))))) - - -(test map->alist-in-order - (assert-equal - (sort-alist '((a . ()) (b . ()) (c . ()) (d . ()) (e . ()) (f . ()) (g . ()) (h . ()))) - (sort-alist (alist->map->alist '((a . ()) (b . ()) (c . ()) (d . ()) (e . ()) (f . ()) (g . ()) (h . ())))))) - - -(test map->alist-reversed - (assert-equal - (sort-alist '((h . ()) (g . ()) (f . ()) (e . ()) (d . ()) (c . ()) (b . ()) (a . ()))) - (sort-alist (alist->map->alist '((a . ()) (b . ()) (c . ()) (d . ()) (e . ()) (f . ()) (g . ()) (h . ())))))) - - -(test map->alist-overwrite - (assert-equal - (sort-alist '((a . 2))) - (sort-alist (alist->map->alist '((a . 1) (a . 2)))))) - - -(test map->alist-alternating - (assert-equal - (sort-alist '((h . ()) (g . ()) (i . ()) (f . ()) (j . ()) (e . ()) (k . ()) (d . ()) (l . ()) (c . ()))) - (sort-alist (alist->map->alist '((c . ()) (d . ()) (e . ()) (f . ()) (g . ()) (h . ()) (i . ()) (j . ()) (k . ()) (l . ())))))) - - -(test lookup - (assert-equal - 2 - (lookup (alist->map hash-symbol symbolmap hash-symbol symbolmap - hash-bytevector - map->alist - for-each - insert - lookup - map? - key-not-found-error? - make-map) - (import (scheme base) - (only (csc format) sprintf)) - (begin - - - (define-record-type - (make-key-hash k hash) - key-hash? - (k key-hash-value) - (hash key-hash-hash)) - - - (define (key-hash (key-hash-hash k1) (key-hash-hash k2)) #f) - ((key - (make-node color key-hash val left right) - node? - (color node-color) - (key-hash node-key) - (val node-value) - (left node-left) - (right node-right)) - - - (define (red? n) - (if (null? n) - #f - (eq? 'red (node-color n)))) - - - (define (black? n) - (if (null? n) - #t - (eq? 'black (node-color n)))) - - - (define (rebalance-left m) - (let ((p (node-left m)) - (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 - (make-node 'red (node-key m) (node-value m) - (make-node 'black (node-key p) (node-value p) (node-left p) (node-right p)) - (make-node 'black (node-key u) (node-value 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) - (let ((u (node-left m)) - (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 m k v key - (construct-hash-map hash key - (make-key-not-found-error) - key-not-found-error?) - - - (define (lookup m k) - (letrec ((k* (make-key-hash k ((hash-map-hash m) k))) - (lookup - (lambda (n) - (cond ((null? n) (raise (make-key-not-found-error))) - ((key-hashalist m) - (let ((alist '())) - (for-each - (lambda (k v) - (set! alist (cons (cons k v) alist))) - m) - alist)) - - - (define (alist->map hash key= i (bytevector-length b)) - hash - (loop (+ 1 i) (+ (* hash #x100) (bytevector-u8-ref b i)))))))) diff --git a/ir1.csc b/ir1.csc deleted file mode 100644 index 53dacc1..0000000 --- a/ir1.csc +++ /dev/null @@ -1,213 +0,0 @@ -(define-library (csc ir1) - (export - call-arguments - call-procedure - call? - constant-expression - constant? - if-alternate - if-consequent - if-test - if? - lambda-body - lambda-case-alternate - lambda-case-arguments - lambda-case-body - lambda-case-gensyms - lambda-case-rest - lambda-case? - 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-gensym - lexical-set-name - lexical-set? - library-ref-library - library-ref-name - library-ref-public? - library-ref? - library-set-expression - library-set-library - library-set-name - library-set-public? - library-set? - make-call - make-constant - make-if - make-lambda - make-lambda-case - make-letrec - make-lexical-ref - make-lexical-set - make-library-ref - make-library-set - make-sequence - make-toplevel-define - make-void - sequence-head - sequence-tail - sequence? - toplevel-define-expression - toplevel-define-name - toplevel-define? - void?) - (import (scheme base)) - (begin - ; This library defines the intermediate representation IR1. An expression - ; in IR1 has one of the following forms (plagiarized from Guile's - ; Tree-IL). - - - ; - ; An empty expression. In practice, equivalent to Scheme's (if #f #f). - (define-record-type - (make-void) - void?) - - - ; expression - ; Constant is used to include literal constants in scheme code. - (define-record-type - (make-constant expression) - 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-record-type - (make-lexical-ref name gensym) - lexical-ref? - (name lexical-ref-name) - (gensym lexical-ref-gensym)) - - - ; name gensym expression - ; Sets a lexically-bound variable. - (define-record-type - (make-lexical-set name gensym expression) - lexical-set? - (name lexical-set-name) - (gensym lexical-set-gensym) - (expression lexical-set-expression)) - - - ; library name public? - ; A reference to a variable in a specific library. library should be the name - ; of the library, e.g. (scheme base). - ; - ; If public? is true, name will be looked up in library's public interface, - ; otherwise it will be looked up among the library's private bindings. - (define-record-type - (make-library-ref library name public?) - library-ref? - (library library-ref-library) - (name library-ref-name) - (public? library-ref-public?)) - - - ; library name public? expression - ; Sets a variable in a specific library. - (define-record-type - (make-library-set library name public? expression) - library-set? - (library library-set-library) - (name library-set-name) - (public? library-set-public?) - (expression library-set-expression)) - - - ; name expression - ; Defines a new variable in the current library. - (define-record-type - (make-toplevel-define name expression) - toplevel-define? - (name toplevel-define-name) - (expression toplevel-define-expression)) - - - ; test consequent alternate - ; A conditional. - (define-record-type - (make-if test consequent alternate) - 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-record-type - (make-call procedure arguments) - call? - (procedure call-procedure) - (arguments call-arguments)) - - - ; head tail - ; Evaluate head, ignoring any result. Then tail is evaluated. - (define-record-type - (make-sequence head tail) - sequence? - (head sequence-head) - (tail sequence-tail)) - - - ; body - ; A closure. body is an expression of type . - (define-record-type - (make-lambda body) - lambda? - (body lambda-body)) - - - ; arguments rest gensyms body alternate - ; One clause of a case-lambda. A lambda expression in Scheme is treated as - ; a case-lambda with one clause. - ; - ; arguments is a list of the procedures arguments, as symbols. rest is the - ; name of the rest argument, or #f. gensyms is a list of gensyms - ; corresponding to all arguments: first all of the normal arguments, then - ; the rest argument if any. - ; - ; body is the name of the clause. If the procedure is called with an - ; appropriate number of arguments, body is evaluated in tail position. - ; Otherwise if there is an alternate, it should be a - ; expression, representing the next clause to try. If there is no - ; alternate, an error is signaled. - (define-record-type - (make-lambda-case arguments rest gensyms body alternate) - lambda-case? - (arguments lambda-case-arguments) - (rest lambda-case-rest) - (gensyms lambda-case-gensyms) - (body lambda-case-body) - (alternate lambda-case-alternate)) - - - ; 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-record-type - (make-letrec in-order? names gensyms values expression) - letrec? - (in-order? letrec-in-order?) - (names letrec-names) - (gensyms letrec-gensyms) - (values letrec-values) - (expression letrec-expression)))) diff --git a/linker-test.csc b/linker-test.csc deleted file mode 100644 index 084e9ae..0000000 --- a/linker-test.csc +++ /dev/null @@ -1,24 +0,0 @@ -(import (scheme base) - (only (csc encoding) encode) - (only (csc testing) - assert-equal - test) - (csc linker)) - - -(test link-if - (assert-equal - (encode '((const 5) (const 1) (if 2) (const 5) add exit)) - (link '((const 5) (const 1) (if "label1") (const 5) add (label "label1") exit)))) - - -(test link-backwards-if - (assert-equal - (encode '((const 10) (const 5) add (if -3))) - (link '((const 10) (label "label1") (const 5) add (if "label1"))))) - - -(test link-call - (assert-equal - (encode '((call 3) (const 10) exit (const 5) exit)) - (link '((call "label1") (const 10) (label "label0") exit (label "label1") (const 5) exit)))) diff --git a/linker.csc b/linker.csc deleted file mode 100644 index 852ee13..0000000 --- a/linker.csc +++ /dev/null @@ -1,67 +0,0 @@ -(define-library (csc linker) - (export link remove-labels make-label-map translate-labels) - (import (scheme base) - (only (csc encoding) encode) - (only (csc format) sprintf) - (only (csc hash-map) - hash-bytevector - insert - lookup - make-map) - (only (csc list) - enumerate - filter) - (only (csc match) match)) - (begin - ; A CSC bytecode program is a list of opcodes. An opcode is a symbol, or a 2 - ; item list of a symbol and an argument. The full list of opcodes can be - ; found in encoding.csc. - - - (define (translate-labels program label-map) - (map - (lambda (x) - (match x - ((i . ((! 'if) label)) - ; Compute offset from the current position. Subtract 1 - ; because the instruction pointer is incremented each - ; time already. - (list 'if (- (lookup label-map label) i 1))) - ((_ . ((! 'call) label)) - (list 'call (lookup label-map label))) - ((_ . opcode) opcode))) - (enumerate program))) - (lambda (i . opcode) - (match opcode - (((! 'if) label) #t) - (_ #f))) - - - (define (hash-string s) - (hash-bytevector (string->utf8 s))) - - - (define (make-label-map program) - (let loop ((m (make-map hash-string stringmap - hash-bytevector - insert - key-not-found-error? - lookup) - (only (csc ir1) - make-call - make-constant - make-lambda - make-lambda-case) - (only (csc list) revappend) - (only (csc match) match)) - (begin - - - (define-record-type - (make-macro-transformer transformer) - macro-transformer? - (transformer transformer-function)) - - - (define-record-type - (make-macro-syntax-error message irritants) - macro-syntax-error? - (message syntax-error-object-message) - (irritants syntax-error-object-irritants)) - - - (define (raise-syntax-error message . irritants) - (raise (make-macro-syntax-error message irritants))) - - - ; symbols is a map with symbols as keys, and the values can be one of: - ; - , - ; - , - ; - or . - ; The first two correspond to variables bound lexically or from a module, - ; and the third represents a macro transformer bound in the - ; current context. - ; - ; library is the current library name being compiled. A nil library - ; corresponds to top level expressions. - (define-record-type - (make-environment symbols library) - environment? - (symbols environment-symbols) - (library environment-library)) - - - (define (with-binding environment symbol binding) - (make-environment (insert (environment-symbols environment) symbol binding) (environment-library environment))) - - - (define (expand-procedure-call procedure arguments environment) - (let*-values (((expanded-procedure environment) (expand procedure environment)) - ((expanded-arguments environment) - (let loop ((arguments arguments) - (environment environment) - (expanded-arguments '())) - (match arguments - ('() (values (reverse expanded-arguments) environment)) - ((argument . rest) - (let-values (((expanded-argument environment) (expand argument environment))) - (loop - rest - environment - (cons expanded-argument expanded-arguments)))) - (_ (raise-syntax-error "arguments to a procedure call must be a list" procedure arguments)))))) - (make-call expanded-procedure expanded-arguments))) - - - ; expand can be thought of as a compiler from Scheme to IR1. Macros - ; included in the environment can be used to extend the syntax. Returns an - ; IR1 expression and an environment which has been modified with any new - ; bindings introduced by the expression. - (define (expand expression environment) - (cond - ((null? expression) (raise-syntax-error "nil by itself is an error (did you mean to use quote?)" expression)) - ((and (pair? expression) - (symbol? (car expression))) - (let* ((macro-name (car expression)) - (macro-body - (guard (e ((key-not-found-error? e) (raise-syntax-error "undefined symbol" macro-name))) - (lookup (environment-symbols environment) macro-name)))) - (if (macro-transformer? macro-body) - ((transformer-function macro-body) expression environment) - (expand-procedure-call macro-name (cdr expression) environment)))) - ((pair? expression) - (let ((procedure (car expression)) - (arguments (cdr expression))) - (expand-procedure-call procedure arguments environment))) - ((symbol? expression) - (let ((binding - (guard (e ((key-not-found-error? e) (raise-syntax-error "undefined symbol" expression))) - (lookup (environment-symbols environment) expression)))) - (if (macro-transformer? binding) - (raise-syntax-error "macro is not allowed in this context" expression) - (values binding environment)))) - ((or (boolean? expression) - (bytevector? expression) - (char? expression) - (number? expression) - (string? expression) - (vector? expression)) - (values (make-constant expression) environment)) - (else (raise-syntax-error "unexpected expression type" expression)))) - - - (define builtin-quote - (make-macro-transformer - (lambda (expression environment) - (match expression - ((_ datum) (values (make-constant datum) environment)) - (_ (raise-syntax-error "invalid form for quote" expression)))))) - - - (define builtin-lambda - (make-macro-transformer - (lambda (expression environment) - (match expression - ((_ formals body) - (let loop ((formals formals) - (environment environment) - (argument-names '()) - (gensyms '())) - (match formals - ('() - (make-lambda - (make-lambda-case - (reverse argument-names) - #f - (reverse gensyms) - (expand body environment) - #f))) - ((variable . variables) (when (symbol? variable)) - (let ((sym (gensym))) - (loop - variables - (with-binding environment variable sym) - (cons variable argument-names) - (cons sym gensyms)))) - (variable (when (symbol? variable)) - (let ((sym (gensym))) - (make-lambda - (make-lambda-case - (reverse argument-names) - variable - (revappend gensyms (list sym)) - (expand body (with-binding environment variable sym)) - #f)))) - (_ (raise-syntax-error "invalid form for lambda arguments" expression))))) - (_ (raise-syntax-error "invalid form for lambda" expression)))))) - - - #;(define builtin-syntax-rules - (make-macro-transformer - (lambda (expression environment) - (match expression)))) - - - (define (hash-symbol s) - (hash-bytevector (string->utf8 (symbol->string s)))) - - - (define (symbolstring s1) (symbol->string s2))) - - - (define test-environment - (make-environment - (alist->map - hash-symbol - symbol - (make-not-found-error) - not-found-error?) - - - (define find - (case-lambda - ((match str) (find match str 0 (string-length str))) - ((match str start) (find match str start (string-length str))) - ((match str start end) - (let loop ((i start)) - (cond ((>= i end) (raise (make-not-found-error))) - ((prefix? match str i) i) - (else (loop (+ 1 i)))))))) - - - (define (join sep . strings) - (apply string-append (intercalate sep strings))))) diff --git a/test-main.csc b/test-main.csc deleted file mode 100644 index 7b45883..0000000 --- a/test-main.csc +++ /dev/null @@ -1,6 +0,0 @@ -(import (scheme base) - (only (csc testing) test-main)) - - -(for-each load (cdr (command-line))) -(test-main) diff --git a/testing.csc b/testing.csc deleted file mode 100644 index a0180e6..0000000 --- a/testing.csc +++ /dev/null @@ -1,81 +0,0 @@ -(define-library (csc testing) - (export - assert - assert-equal - assert-raises - test - test-main) - (import (scheme base) - (only (csc format) - printf - sprintf)) - (begin - - - (define *all-tests-succeeded* #t) - - - (define (set-all-succeeded! val) (set! *all-tests-succeeded* val)) - - - (define-record-type - (make-test-handle test-name) - test-handle? - (test-name test-name set-name!)) - - - (define-record-type - (make-test-error) - test-error?) - - - (define *test-handle* (make-test-handle "global")) - - - (define-syntax test - (syntax-rules () - ((test name body body* ...) - (begin - (set-name! *test-handle* (symbol->string 'name)) - (printf "=== RUN {}\n" 'name) - (guard (e ((test-error? e) - (printf "--- FAIL: {}\n" 'name) - (set-all-succeeded! #f))) - body body* ... - (printf "--- PASS: {}\n" 'name)))))) - - - (define (fatalf format-string . format-args) - (printf "{}: {}\n" (test-name *test-handle*) (apply sprintf format-string format-args)) - (raise (make-test-error))) - - - (define-syntax assert - (syntax-rules () - ((assert expr) - (unless expr - (fatalf "(assert {}) failed." 'expr))))) - - - (define-syntax assert-equal - (syntax-rules () - ((assert-equal left right) - (let ((x left) - (y right)) - (unless (equal? x y) - (fatalf "Fatal: {} is not equal to {}.\nleft is {}\nright is {}" 'left 'right x y)))))) - - - (define-syntax assert-raises - (syntax-rules () - ((assert-raises predicate body body* ...) - (assert - (guard (e ((predicate e) #t)) - body body* ... - #f))))) - - - (define (test-main) - (if *all-tests-succeeded* - (printf "PASS\n") - (printf "FAIL\n"))))) diff --git a/vec-test.csc b/vec-test.csc deleted file mode 100644 index 8a19b3e..0000000 --- a/vec-test.csc +++ /dev/null @@ -1,33 +0,0 @@ -(import (scheme base) - (only (csc testing) - assert-equal - test) - (csc vec)) - - -(test vec-empty - (assert-equal '() (vec->list (vec)))) - - -(test vec-singleton - (assert-equal '(1) (vec->list (vec 1)))) - - -(test vec-append-to-empty - (assert-equal '(1) (vec->list (vec-append (vec) 1)))) - - -(test vec-append-to-singleton - (assert-equal '(1 2) (vec->list (vec-append (vec 1) 2)))) - - -(test vec-append-to-2-elem - (assert-equal '(1 2 3) (vec->list (vec-append (vec 1 2) 3)))) - - -(test vec-ref-1 - (assert-equal 2 (vec-ref (vec 1 2) 1))) - - -(test vec-ref-singleton - (assert-equal 1 (vec-ref (vec 1) 0))) diff --git a/vec.csc b/vec.csc deleted file mode 100644 index 03f2b0f..0000000 --- a/vec.csc +++ /dev/null @@ -1,54 +0,0 @@ -(define-library (csc vec) - (export - list->vec - vec - vec->list - vec-append - vec-length - vec-ref - vec?) - (import (scheme base)) - (begin - - - (define-record-type - (make-vec len arr) - vec? - (len vec-length) - (arr vec-arr)) - - - (define (list->vec l) - (let ((arr (list->vector l))) - (make-vec (vector-length arr) arr))) - - - (define (vec->list v) - (vector->list (vec-arr v) 0 (vec-length v))) - - - (define (vec . xs) - (list->vec xs)) - - - (define (vec-append v . xs) - (let ((append-one - (lambda (v x) - (let ((new-v (if (> (vector-length (vec-arr v)) (vec-length v)) - v - (let ((new-arr (make-vector (max 1 (* 2 (vec-length v)))))) - (vector-copy! new-arr 0 (vec-arr v)) - (make-vec (vec-length v) new-arr))))) - (vector-set! (vec-arr new-v) (vec-length new-v) x) - (make-vec (+ 1 (vec-length new-v)) (vec-arr new-v)))))) - (let loop ((v v) - (xs xs)) - (if (null? xs) - v - (loop (append-one v (car xs)) (cdr xs)))))) - - - (define (vec-ref v k) - (if (>= k (vec-length v)) - (error "index out of bounds" k) - (vector-ref (vec-arr v) k))))) -- cgit v1.3.1