From 68986fe0410584c6934c835bb0ee784655f5f8c5 Mon Sep 17 00:00:00 2001
From: Rose Hogenson <rhogenson@posteo.net>
Date: Tue, 11 Jan 2022 22:01:23 -0800
Subject: Move scheme compiler into a separate directory.

---
 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 +++++++++
 27 files changed, 1749 insertions(+)
 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

(limited to '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 <gensym>
+      (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 (symbol<? s1 s2)
+  (string<? (symbol->string s1) (symbol->string s2)))
+
+
+(define (alist->map->alist l)
+  (map->alist (alist->map hash-symbol symbol<? l)))
+
+
+(define (sort-alist l)
+  (sort (lambda (x1 x2) (symbol<? (car x1) (car x2))) l))
+
+
+(test map->alist-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 symbol<? '((a . 1) (b . 2) (c . 3))) 'b)))
+
+
+(test lookup-notfound
+  (assert-raises key-not-found-error?
+    (lookup (alist->map hash-symbol symbol<? '((a . 1) (b . 2) (c . 3))) 'd)))
diff --git a/csc/hash-map.csc b/csc/hash-map.csc
new file mode 100644
index 0000000..01d4158
--- /dev/null
+++ b/csc/hash-map.csc
@@ -0,0 +1,259 @@
+(define-library (csc hash-map)
+  (export
+    alist->map
+    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 <key-hash>
+      (make-key-hash k hash)
+      key-hash?
+      (k key-hash-value)
+      (hash key-hash-hash))
+
+
+    (define (key-hash<? k1 k2 key<?)
+      (cond ((< (key-hash-hash k1) (key-hash-hash k2)) #t)
+            ((> (key-hash-hash k1) (key-hash-hash k2)) #f)
+            ((key<? (key-hash-value k1) (key-hash-value k2)) #t)
+            (else #f)))
+
+
+    (define (key-hash=? k1 k2)
+      (and (= (key-hash-hash k1) (key-hash-hash k2)) (eqv? (key-hash-value k1) (key-hash-value k2))))
+
+
+    (define-record-type <node>
+      (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<?)
+      (cond ((null? m) (make-node 'red k v '() '()))
+            ((key-hash<? k (node-key m) key<?)
+             (rebalance-left
+               (make-node (node-color m) (node-key m) (node-value m)
+                          (insert-node (node-left m) k v key<?)
+                          (node-right m))))
+            ((key-hash=? k (node-key m)) (make-node (node-color m) k v (node-left m) (node-right m)))
+            (else
+              (rebalance-right
+                (make-node (node-color m) (node-key m) (node-value m)
+                           (node-left m)
+                           (insert-node (node-right m) k v key<?))))))
+
+
+    (define-record-type <hash-map>
+      (construct-hash-map hash key<? root)
+      hash-map?
+      (hash hash-map-raw-hash)
+      (key<? hash-map-key<?)
+      (root hash-map-root))
+
+
+    (define (make-map hash key<?)
+      (construct-hash-map hash key<? '()))
+
+
+    (define (shuffle n)
+      (truncate-remainder
+        (* #x9e3779b97f4a7c55 n)
+        #x10000000000000000))
+
+
+    (define (hash-map-hash m)
+      (lambda (k)
+        (shuffle ((hash-map-raw-hash m) k))))
+
+
+    (define (insert m k v)
+      (let ((res (insert-node (hash-map-root m) (make-key-hash k ((hash-map-hash m) k)) v (hash-map-key<? m))))
+        (construct-hash-map
+          (hash-map-raw-hash m)
+          (hash-map-key<? m)
+          (make-node 'black (node-key res) (node-value res) (node-left res) (node-right res)))))
+
+
+    (define-record-type <key-not-found-error>
+      (make-key-not-found-error)
+      key-not-found-error?)
+
+
+    (define (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-hash<? k* (node-key n) (hash-map-key<? m)) (lookup (node-left n)))
+                         ((key-hash=? k* (node-key n)) (node-value n))
+                         (else (lookup (node-right n)))))))
+              (lookup (hash-map-root m))))
+
+
+    (define (for-each f m)
+      (letrec ((node-foreach
+                 (lambda (n)
+                   (unless (null? n)
+                     (node-foreach (node-left n))
+                     (f (key-hash-value (node-key n)) (node-value n))
+                     (node-foreach (node-right n))))))
+              (node-foreach (hash-map-root m))))
+
+
+    (define (map->alist m)
+      (let ((alist '()))
+        (for-each
+          (lambda (k v)
+            (set! alist (cons (cons k v) alist)))
+          m)
+        alist))
+
+
+    (define (alist->map hash key<? alist)
+      (let loop ((alist alist)
+                 (m (make-map hash key<?)))
+        (if (null? alist)
+            m
+          (loop (cdr alist) (insert m (caar alist) (cdar alist))))))
+
+
+    (define (hash-bytevector b)
+      (let loop ((i 0)
+                 (hash 0))
+        (if (>= 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).
+
+
+    ; <void>
+    ; An empty expression. In practice, equivalent to Scheme's (if #f #f).
+    (define-record-type <void>
+      (make-void)
+      void?)
+
+
+    ; <constant> expression
+    ; Constant is used to include literal constants in scheme code.
+    (define-record-type <constant>
+      (make-constant expression)
+      constant?
+      (expression constant-expression))
+
+
+    ; <lexical-ref> name gensym
+    ; A reference to a lexically-bound variable. The name is the original name
+    ; of the variable in the source program. gensym is a unique identifier for
+    ; this variable.
+    (define-record-type <lexical-ref>
+      (make-lexical-ref name gensym)
+      lexical-ref?
+      (name lexical-ref-name)
+      (gensym lexical-ref-gensym))
+
+
+    ; <lexical-set> name gensym expression
+    ; Sets a lexically-bound variable.
+    (define-record-type <lexical-set>
+      (make-lexical-set name gensym expression)
+      lexical-set?
+      (name lexical-set-name)
+      (gensym lexical-set-gensym)
+      (expression lexical-set-expression))
+
+
+    ; <library-ref> 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 <library-ref>
+      (make-library-ref library name public?)
+      library-ref?
+      (library library-ref-library)
+      (name library-ref-name)
+      (public? library-ref-public?))
+
+
+    ; <library-set> library name public? expression
+    ; Sets a variable in a specific library.
+    (define-record-type <library-set>
+      (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))
+
+
+    ; <toplevel-define> name expression
+    ; Defines a new variable in the current library.
+    (define-record-type <toplevel-define>
+      (make-toplevel-define name expression)
+      toplevel-define?
+      (name toplevel-define-name)
+      (expression toplevel-define-expression))
+
+
+    ; <if> test consequent alternate
+    ; A conditional.
+    (define-record-type <if>
+      (make-if test consequent alternate)
+      if?
+      (test if-test)
+      (consequent if-consequent)
+      (alternate if-alternate))
+
+
+    ; <call> procedure arguments
+    ; A procedure call. The procedure and arguments are evaluated in an
+    ; unspecified order, and the resulting procedure is passed the
+    ; resulting arguments.
+    (define-record-type <call>
+      (make-call procedure arguments)
+      call?
+      (procedure call-procedure)
+      (arguments call-arguments))
+
+
+    ; <sequence> head tail
+    ; Evaluate head, ignoring any result. Then tail is evaluated.
+    (define-record-type <sequence>
+      (make-sequence head tail)
+      sequence?
+      (head sequence-head)
+      (tail sequence-tail))
+
+
+    ; <lambda> body
+    ; A closure. body is an expression of type <lambda-case>.
+    (define-record-type <lambda>
+      (make-lambda body)
+      lambda?
+      (body lambda-body))
+
+
+    ; <lambda-case> 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 <lambda-case>
+    ; expression, representing the next clause to try. If there is no
+    ; alternate, an error is signaled.
+    (define-record-type <lambda-case>
+      (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))
+
+
+    ; <letrec> in-order? names gensyms values expression
+    ; Lexical binding, like Scheme's letrec, or letrec* if in-order? is true.
+    ; names are the original binding names, gensyms are gensyms corresponding
+    ; to the names, and values are IR1 expressions for the values. expression
+    ; is a single IR1 expression.
+    (define-record-type <letrec>
+      (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 string<?))
+                 (program program)
+                 (i 0))
+        (match program
+          ('() m)
+          ((((! 'label) name) . tail)
+           (loop (insert m name i) tail i))  ; N.b.: i instead of (+ 1 i) because we're going to remove the labels later.
+          ((_ . tail) (loop m tail (+ 1 i))))))
+
+
+    (define (remove-labels program)
+      (filter
+        (lambda (opcode)
+          (match opcode
+            (((! 'label) _) #f)
+            (_ #t)))
+        program))
+
+
+    (define (link . programs)
+      (let* ((program (apply append programs))
+             (label-map (make-label-map program)))
+        (encode (translate-labels (remove-labels program) label-map))))))
diff --git a/csc/list-test.csc b/csc/list-test.csc
new file mode 100644
index 0000000..6e910c0
--- /dev/null
+++ b/csc/list-test.csc
@@ -0,0 +1,95 @@
+(import (scheme base)
+        (only (csc testing) assert assert-equal test)
+        (csc list))
+
+
+(test take-simple
+  (assert-equal '(1 2 3) (take 3 '(1 2 3 4 5))))
+
+
+(test take-negative
+  (assert-equal '() (take -5 '(1 2 3))))
+
+
+(test take-zero
+  (assert-equal '() (take 0 '(1 2 3))))
+
+
+(test take-short-list
+  (assert-equal '(1 2 3) (take 5 '(1 2 3))))
+
+
+(test take-whole-list
+  (assert-equal '(1 2 3) (take 3 '(1 2 3))))
+
+
+(define-syntax values=
+  (syntax-rules ()
+    ((values= x y)
+     (let-values (((x-a x-b) x)
+                  ((y-a y-b) y))
+       (and (equal? x-a y-a) (equal? x-b y-b))))))
+
+
+(test split-at-simple
+  (assert (values= (values '(1 2) '(3 4)) (split-at 2 '(1 2 3 4)))))
+
+
+(test split-at-negative
+  (assert (values= (values '() '(1 2 3)) (split-at -5 '(1 2 3)))))
+
+
+(test split-at-zero
+  (assert (values= (values '() '(1 2 3)) (split-at 0 '(1 2 3)))))
+
+
+(test split-at-short-list
+  (assert (values= (values '(1 2 3) '()) (split-at 5 '(1 2 3)))))
+
+
+(test split-at-whole-list
+  (assert (values= (values '(1 2 3) '()) (split-at 3 '(1 2 3)))))
+
+
+(test revappend-threes
+  (assert-equal '(1 2 3 4 5 6) (revappend '(3 2 1) '(4 5 6))))
+
+
+(test revappend-empty-first-list
+  (assert-equal '(1 2 3) (revappend '() '(1 2 3))))
+
+
+(test revappend-empty-second-list
+  (assert-equal '(1 2 3) (revappend '(3 2 1) '())))
+
+
+(test intercalate-simple
+  (assert-equal '("a" "," "b" "," "c") (intercalate "," '("a" "b" "c"))))
+
+
+(test intercalate-empty
+  (assert-equal '() (intercalate "," '())))
+
+
+(test intercalate-singleton
+  (assert-equal '(1) (intercalate "," '(1))))
+
+
+(test enumerate-simple
+  (assert-equal '((0 . a) (1 . b) (2 . c) (3 . d)) (enumerate '(a b c d))))
+
+
+(test enumerate-nil
+  (assert-equal '() (enumerate '())))
+
+
+(test enumerate-singleton
+  (assert-equal '((0 . "test")) (enumerate '("test"))))
+
+
+(test filter-even
+  (assert-equal '(0 2 4 6 8) (filter even? '(0 1 2 3 4 5 6 7 8 9))))
+
+
+(test filter-odd
+  (assert-equal '(1 3 5 7 9) (filter odd? '(0 1 2 3 4 5 6 7 8 9))))
diff --git a/csc/list.csc b/csc/list.csc
new file mode 100644
index 0000000..f425146
--- /dev/null
+++ b/csc/list.csc
@@ -0,0 +1,64 @@
+(define-library (csc list)
+  (export
+    enumerate
+    filter
+    intercalate
+    revappend
+    split-at
+    take)
+  (import (scheme base)
+          (only (csc match)
+            match))
+  (begin
+
+
+    (define (take n xs)
+      (let loop ((n n)
+                 (xs xs)
+                 (acc '()))
+        (if (or (not (positive? n)) (null? xs))
+            (reverse acc)
+          (loop (- n 1) (cdr xs) (cons (car xs) acc)))))
+
+
+    (define (split-at n xs)
+      (let loop ((n n)
+                 (xs xs)
+                 (acc '()))
+        (if (or (not (positive? n)) (null? xs))
+            (values (reverse acc) xs)
+          (loop (- n 1) (cdr xs) (cons (car xs) acc)))))
+
+
+    (define (revappend a b)
+      (let loop ((xs a)
+                 (acc b))
+        (if (null? xs)
+            acc
+          (loop (cdr xs) (cons (car xs) acc)))))
+
+
+    (define (intercalate x l)
+      (match l
+        ('() '())
+        ((_) l)
+        ((head . tail) (cons head (cons x (intercalate x tail))))))
+
+
+    (define (enumerate l)
+      (let loop ((i 0)
+                 (l l))
+        (match l
+          ('() '())
+          ((head . tail) (cons (cons i head) (loop (+ 1 i) tail))))))
+
+
+    (define (filter p l)
+      (let loop ((l l)
+                 (acc '()))
+        (match l
+          ('() (reverse acc))
+          ((x . xs)
+           (if (p x)
+             (loop xs (cons x acc))
+             (loop xs acc))))))))
diff --git a/csc/macros.csc b/csc/macros.csc
new file mode 100644
index 0000000..a41a4a7
--- /dev/null
+++ b/csc/macros.csc
@@ -0,0 +1,184 @@
+(define-library (csc macros)
+  (export
+    expand
+    test-environment)
+  (import (scheme base)
+          (only (csc gensym) gensym)
+          (only (csc hash-map)
+            alist->map
+            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 <macro-transformer>
+      (make-macro-transformer transformer)
+      macro-transformer?
+      (transformer transformer-function))
+
+
+    (define-record-type <macro-syntax-error>
+      (make-macro-syntax-error message irritants)
+      macro-syntax-error?
+      (message syntax-error-object-message)
+      (irritants syntax-error-object-irritants))
+
+
+    (define (raise-syntax-error message . irritants)
+      (raise (make-macro-syntax-error message irritants)))
+
+
+    ; symbols is a map with symbols as keys, and the values can be one of:
+    ; - <lexical-ref>,
+    ; - <module-ref>,
+    ; - or <macro-transformer>.
+    ; 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 <environment>
+      (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 (symbol<? s1 s2)
+      (string<? (symbol->string s1) (symbol->string s2)))
+
+
+    (define test-environment
+      (make-environment
+        (alist->map
+          hash-symbol
+          symbol<?
+          (list
+            (cons 'quote builtin-quote)
+            (cons 'lambda builtin-lambda)))
+        '()))))
diff --git a/csc/match-test.csc b/csc/match-test.csc
new file mode 100644
index 0000000..31e7afa
--- /dev/null
+++ b/csc/match-test.csc
@@ -0,0 +1,87 @@
+(import (scheme base)
+        (only (csc testing) assert-equal test)
+        (csc match))
+
+
+(test match-cond
+  (assert-equal
+    3
+    (match 3
+      ((! 0) 0)
+      ((! 1) 1)
+      ((! 2) 2)
+      ((! 3) 3)
+      (_ 4))))
+
+
+(test match-list
+  (assert-equal
+    2
+    (match '(1 2 3)
+      ('() 0)
+      (((! 1) (! 2)) 1)
+      (((! 1) (! 2) (! 3)) 2)
+      (((! 1) (! 2) (! 3) (! 4)) 3)
+      (_ 4))))
+
+
+(test match-binding
+  (assert-equal
+    2
+    (match '(1 2 3)
+      (((! 1) x (! 3)) x))))
+
+
+(test match-destructuring
+  (assert-equal
+    1
+    (match '(1 2 3)
+      ('() 0)
+      ((head . _) head))))
+
+
+(test match-ignore
+  (assert-equal
+    2
+    (match '(1 2 3)
+      ((_ _ _ _) 0)
+      (((! 2) _ _) 1)
+      (((! 1) _ _) 2)
+      (_ 3))))
+
+
+(test match-improper-list
+  (assert-equal
+    2
+    (match '(1 2 3)
+      (((! 2) . _) 1)
+      (((! 1) . x) (car x))
+      (_ 3))))
+
+
+(test match-symbol
+  (assert-equal
+    2
+    (match 'b
+      ((! 'a) 1)
+      ((! 'b) 2)
+      (_ 3))))
+
+
+(test match-when
+  (assert-equal
+    3
+    (match 'b
+      ((! 'a) 1)
+      ((! 'b) (when #f) 2)
+      ((! 'b) (when #t) 3)
+      (_ 4))))
+
+
+(test match-when-depending-on-pattern-variable
+  (assert-equal
+    2
+    (match 10
+      (n (when (= 1 n)) 1)
+      (n (when (= 10 n)) 2)
+      (_ 3))))
diff --git a/csc/match.csc b/csc/match.csc
new file mode 100644
index 0000000..3e02937
--- /dev/null
+++ b/csc/match.csc
@@ -0,0 +1,60 @@
+(define-library (csc match)
+  (export match)
+  (import (scheme base))
+  (begin
+
+
+    (define-syntax matches?
+      (syntax-rules (_ !)
+        ((matches? x _) #t)
+        ((matches? x '())
+         (null? x))
+        ((matches? x (! constant))
+         (equal? x constant))
+        ((matches? x (pattern))
+         (and (= 1 (length x))
+              (matches? (car x) pattern)))
+        ((matches? x (pattern1 . pattern2))
+         (and (pair? x)
+              (matches? (car x) pattern1)
+              (matches? (cdr x) pattern2)))
+        ((matches? x identifier) #t)))
+
+
+    (define-syntax bind-pattern
+      (syntax-rules (_ !)
+        ((bind-pattern x _ result result* ...)
+         (begin result result* ...))
+        ((bind-pattern x '() result result* ...)
+         (begin result result* ...))
+        ((bind-pattern x (! constant) result result* ...)
+         (begin result result* ...))
+        ((bind-pattern x (pattern) result result* ...)
+         (bind-pattern (car x) pattern result result* ...))
+        ((bind-pattern x (pattern1 . pattern2) result result* ...)
+         (bind-pattern (car x) pattern1
+           (bind-pattern (cdr x) pattern2 result result* ...)))
+        ((bind-pattern x identifier result result* ...)
+         (let ((identifier x))
+           result result* ...))))
+
+
+    (define-syntax match
+      (syntax-rules (when)
+        ((match x (pattern (when condition) result result* ...))
+         (if (matches? x pattern)
+           (bind-pattern x pattern
+             (if condition
+               (begin result result* ...)))))
+        ((match x (pattern result1 result2 ...))
+         (if (matches? x pattern)
+           (bind-pattern x pattern result1 result2 ...)))
+        ((match x (pattern (when condition) result result* ...) clause clause* ...)
+         (if (and (matches? x pattern)
+                  (bind-pattern x pattern condition))
+           (bind-pattern x pattern result result* ...)
+           (match x clause clause* ...)))
+        ((match x (pattern result1 result2 ...) clause1 clause2 ...)
+         (if (matches? x pattern)
+           (bind-pattern x pattern result1 result2 ...)
+           (match x clause1 clause2 ...)))))))
diff --git a/csc/sort-test.csc b/csc/sort-test.csc
new file mode 100644
index 0000000..dec2a53
--- /dev/null
+++ b/csc/sort-test.csc
@@ -0,0 +1,35 @@
+(import (scheme base)
+        (only (csc testing)
+          assert-equal
+          test)
+        (csc sort))
+
+
+(test sort-ten-elem
+  (assert-equal
+    '(-2 0 2 3 4 4 5 6 9 100)
+    (sort < '(9 4 5 100 3 2 4 6 0 -2))))
+
+
+(test sort-empty
+  (assert-equal '() (sort < '())))
+
+
+(test sort-singleton
+  (assert-equal '(1) (sort < '(1))))
+
+
+(test sort-two
+  (assert-equal '(1 2) (sort < '(2 1))))
+
+
+(test sort-reversed
+  (assert-equal
+    '(1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20)
+    (sort < '(20 19 18 17 16 15 14 13 12 11 10 9 8 7 6 5 4 3 2 1))))
+
+
+(test sort-already-sorted
+  (assert-equal
+    '(1 2 3 4 5 6 7 8 9 10)
+    (sort < '(1 2 3 4 5 6 7 8 9 10))))
diff --git a/csc/sort.csc b/csc/sort.csc
new file mode 100644
index 0000000..62b1c9d
--- /dev/null
+++ b/csc/sort.csc
@@ -0,0 +1,24 @@
+(define-library (csc sort)
+  (export sort)
+  (import (scheme base)
+          (only (csc list)
+                revappend
+                split-at))
+  (begin
+
+
+    (define (sort cmp xs)
+      (let ((len (length xs)))
+        (if (<= len 1)
+            xs
+          (let-values (((half-a half-b) (split-at (truncate-quotient len 2) xs)))
+            (let ((sorted-half-a (sort cmp half-a))
+                  (sorted-half-b (sort cmp half-b)))
+              (let loop ((a sorted-half-a)
+                         (b sorted-half-b)
+                         (acc '()))
+                (cond ((null? a) (revappend acc b))
+                      ((null? b) (revappend acc a))
+                      ((cmp (car b) (car a))
+                       (loop a (cdr b) (cons (car b) acc)))
+                      (else (loop (cdr a) b (cons (car a) acc))))))))))))
diff --git a/csc/strings-test.csc b/csc/strings-test.csc
new file mode 100644
index 0000000..2e6d240
--- /dev/null
+++ b/csc/strings-test.csc
@@ -0,0 +1,60 @@
+(import (scheme base)
+        (only (csc testing)
+          assert
+          assert-equal
+          test)
+        (csc strings))
+
+
+(test prefix?-good
+  (assert-equal #t (prefix? "asdf" "asdfjkl;")))
+
+
+(test prefix?-bad
+  (assert-equal #f (prefix? "asdf" "asdbjkl;")))
+
+
+(test prefix?-too-long
+  (assert-equal #f (prefix? "asdf" "as")))
+
+
+(test str-quote-simple
+  (assert-equal "\"hello\"" (str-quote "hello")))
+
+
+(test str-quote-escape
+  (assert-equal "\"this string \\\" has a quote\"" (str-quote "this string \" has a quote")))
+
+
+(test find-ok
+  (assert-equal 8 (find "abc" "dabsadfdabcdfdfd")))
+
+
+(test find-one-letter
+  (assert-equal 8 (find "a" "sdfdfdfsasdfe")))
+
+
+(test find-notfound
+  (let* ((match "a")
+         (str "def")
+         (got-exception '()))
+    (guard (e
+             ((not-found-error? e) (set! got-exception e)))
+           (find match str))
+    (assert (not-found-error? got-exception))))
+
+
+(test join-,
+  (assert-equal "a,b,c" (join "," "a" "b" "c")))
+
+
+(test join-none
+  (assert-equal "" (join ",")))
+
+
+(test join-singleton
+  (assert-equal "x" (join "," "x")))
+
+
+(test join-empty
+  (assert-equal "abc" (join "" "a" "b" "c")))
diff --git a/csc/strings.csc b/csc/strings.csc
new file mode 100644
index 0000000..737c91b
--- /dev/null
+++ b/csc/strings.csc
@@ -0,0 +1,46 @@
+(define-library (csc strings)
+  (export
+    find
+    join
+    not-found-error?
+    prefix?
+    str-quote)
+  (import (scheme base)
+          (only (scheme case-lambda) case-lambda)
+          (only (scheme write) write)
+          (only (csc list) intercalate))
+  (begin
+
+
+    (define prefix?
+      (case-lambda
+        ((prefix str) (prefix? prefix str 0))
+        ((prefix str start)
+         (and (<= (string-length prefix) (- (string-length str) start))
+              (string=? prefix (substring str start (+ start (string-length prefix))))))))
+
+
+    (define (str-quote s)
+      (let ((out (open-output-string)))
+        (write s out)
+        (get-output-string out)))
+
+
+    (define-record-type <not-found-error>
+      (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 <test-handle>
+      (make-test-handle test-name)
+      test-handle?
+      (test-name test-name set-name!))
+
+
+    (define-record-type <test-error>
+      (make-test-error)
+      test-error?)
+
+
+    (define *test-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 <vec>
+      (make-vec len arr)
+      vec?
+      (len vec-length)
+      (arr vec-arr))
+
+
+    (define (list->vec l)
+      (let ((arr (list->vector l)))
+        (make-vec (vector-length arr) arr)))
+
+
+    (define (vec->list v)
+      (vector->list (vec-arr v) 0 (vec-length v)))
+
+
+    (define (vec . xs)
+      (list->vec xs))
+
+
+    (define (vec-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