From 77583a881b03ce38c8065c40641489fe88b61eb2 Mon Sep 17 00:00:00 2001
From: Rose Hogenson <rhogenson@posteo.net>
Date: Sun, 9 Jan 2022 22:55:59 -0800
Subject: Write the linker.

---
 encoding-test.csc | 117 ++++++++++++++++++++++++++++++++++++++++++++++++++++++
 encoding.csc      |  53 +++++++++++++++++++++++++
 hash-map-test.csc |  48 +++++++++++++---------
 hash-map.csc      |  74 +++++++++++++++++++---------------
 linker-test.csc   |  24 +++++++++++
 linker.csc        |  67 +++++++++++++++++++++++++++++++
 list-test.csc     |  20 ++++++++++
 list.csc          |  23 ++++++++++-
 match-test.csc    |  33 +++++++++------
 match.csc         |  51 +++++++++---------------
 strings-test.csc  |  18 ++++++++-
 strings.csc       |  12 ++++--
 testing.csc       |  12 +++++-
 13 files changed, 450 insertions(+), 102 deletions(-)
 create mode 100644 encoding-test.csc
 create mode 100644 encoding.csc
 create mode 100644 linker-test.csc
 create mode 100644 linker.csc

diff --git a/encoding-test.csc b/encoding-test.csc
new file mode 100644
index 0000000..a7f4ace
--- /dev/null
+++ b/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/encoding.csc b/encoding.csc
new file mode 100644
index 0000000..21ee88f
--- /dev/null
+++ b/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/hash-map-test.csc b/hash-map-test.csc
index b1b98bd..353e6b4 100644
--- a/hash-map-test.csc
+++ b/hash-map-test.csc
@@ -2,6 +2,7 @@
         (only (csc sort) sort)
         (only (csc testing)
               assert-equal
+              assert-raises
               test)
         (csc hash-map))
 
@@ -14,53 +15,64 @@
   (string<? (symbol->string s1) (symbol->string s2)))
 
 
-(define (alist->hash-map->alist l)
-  (hash-map->alist (alist->hash-map hash-symbol symbol<? l)))
+(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 hash-map->alist-singleton
-  (assert-equal (sort-alist '((a . 1))) (sort-alist (alist->hash-map->alist '((a . 1))))))
+(test map->alist-singleton
+  (assert-equal (sort-alist '((a . 1))) (sort-alist (alist->map->alist '((a . 1))))))
 
 
-(test hash-map->alist-two
-  (assert-equal (sort-alist '((a . 1) (b . 2))) (sort-alist (alist->hash-map->alist '((a . 1) (b . 2))))))
+(test map->alist-two
+  (assert-equal (sort-alist '((a . 1) (b . 2))) (sort-alist (alist->map->alist '((a . 1) (b . 2))))))
 
 
-(test hash-map->alist-longer
+(test map->alist-longer
   (assert-equal
     (sort-alist '((a . 1) (b . 2) (c . 3) (d . 4) (e . 5) (f . 6)))
-    (sort-alist (alist->hash-map->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 hash-map->alist-larger
+(test map->alist-larger
   (assert-equal
     (sort-alist '((f . 5) (m . 1) (n . 7) (q . 3) (x . 8)))
-    (sort-alist (alist->hash-map->alist '((m . 1) (n . 2) (q . 3) (f . 5) (n . 7) (x . 8))))))
+    (sort-alist (alist->map->alist '((m . 1) (n . 2) (q . 3) (f . 5) (n . 7) (x . 8))))))
 
 
-(test hash-map->alist-in-order
+(test map->alist-in-order
   (assert-equal
     (sort-alist '((a . ()) (b . ()) (c . ()) (d . ()) (e . ()) (f . ()) (g . ()) (h . ())))
-    (sort-alist (alist->hash-map->alist '((a . ()) (b . ()) (c . ()) (d . ()) (e . ()) (f . ()) (g . ()) (h . ()))))))
+    (sort-alist (alist->map->alist '((a . ()) (b . ()) (c . ()) (d . ()) (e . ()) (f . ()) (g . ()) (h . ()))))))
 
 
-(test hash-map->alist-reversed
+(test map->alist-reversed
   (assert-equal
     (sort-alist '((h . ()) (g . ()) (f . ()) (e . ()) (d . ()) (c . ()) (b . ()) (a . ())))
-    (sort-alist (alist->hash-map->alist '((a . ()) (b . ()) (c . ()) (d . ()) (e . ()) (f . ()) (g . ()) (h . ()))))))
+    (sort-alist (alist->map->alist '((a . ()) (b . ()) (c . ()) (d . ()) (e . ()) (f . ()) (g . ()) (h . ()))))))
 
 
-(test hash-map->alist-overwrite
+(test map->alist-overwrite
   (assert-equal
     (sort-alist '((a . 2)))
-    (sort-alist (alist->hash-map->alist '((a . 1) (a . 2))))))
+    (sort-alist (alist->map->alist '((a . 1) (a . 2))))))
 
 
-(test hash-map->alist-alternating
+(test map->alist-alternating
   (assert-equal
     (sort-alist '((h . ()) (g . ()) (i . ()) (f . ()) (j . ()) (e . ()) (k . ()) (d . ()) (l . ()) (c . ())))
-    (sort-alist (alist->hash-map->alist '((c . ()) (d . ()) (e . ()) (f . ()) (g . ()) (h . ()) (i . ()) (j . ()) (k . ()) (l . ()))))))
+    (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/hash-map.csc b/hash-map.csc
index 2c95b36..01d4158 100644
--- a/hash-map.csc
+++ b/hash-map.csc
@@ -1,23 +1,24 @@
 (define-library (csc hash-map)
   (export
-    alist->hash-map
+    alist->map
     hash-bytevector
-    hash-map->alist
-    hash-map-foreach
-    hash-map-insert
-    hash-map-lookup
-    hash-map?
-    make-hash-map)
+    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 hash k)
+      (make-key-hash k hash)
       key-hash?
-      (hash key-hash-hash)
-      (k key-hash-value))
+      (k key-hash-value)
+      (hash key-hash-hash))
 
 
     (define (key-hash<? k1 k2 key<?)
@@ -161,42 +162,48 @@
               (else m))))
 
 
-    (define (insert m k v key<?)
+    (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-left m) k v key<?)
+                          (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-right m) k v key<?))))))
+                           (insert-node (node-right m) k v key<?))))))
 
 
     (define-record-type <hash-map>
       (construct-hash-map hash key<? root)
       hash-map?
-      (hash hash-map-hash)
+      (hash hash-map-raw-hash)
       (key<? hash-map-key<?)
       (root hash-map-root))
 
 
-    (define (make-hash-map hash key<?)
+    (define (make-map hash key<?)
       (construct-hash-map hash key<? '()))
 
 
-    (define (hash-map-insert m k v)
-      (let* ((shuffle
-               (lambda (hash)
-                 (truncate-remainder
-                   (* #x9e3779b97f4a7c55 hash)
-                   #x10000000000000000)))
-             (res (insert (hash-map-root m) (make-key-hash (shuffle ((hash-map-hash m) k)) k) v (hash-map-key<? m))))
+    (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-hash m)
+          (hash-map-raw-hash m)
           (hash-map-key<? m)
           (make-node 'black (node-key res) (node-value res) (node-left res) (node-right res)))))
 
@@ -206,17 +213,18 @@
       key-not-found-error?)
 
 
-    (define (hash-map-lookup m k)
-      (letrec ((lookup
+    (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))
+                         ((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 (hash-map-foreach f m)
+    (define (for-each f m)
       (letrec ((node-foreach
                  (lambda (n)
                    (unless (null? n)
@@ -226,21 +234,21 @@
               (node-foreach (hash-map-root m))))
 
 
-    (define (hash-map->alist m)
+    (define (map->alist m)
       (let ((alist '()))
-        (hash-map-foreach
+        (for-each
           (lambda (k v)
             (set! alist (cons (cons k v) alist)))
           m)
         alist))
 
 
-    (define (alist->hash-map hash key<? alist)
+    (define (alist->map hash key<? alist)
       (let loop ((alist alist)
-                 (m (make-hash-map hash key<?)))
+                 (m (make-map hash key<?)))
         (if (null? alist)
             m
-          (loop (cdr alist) (hash-map-insert m (caar alist) (cdar alist))))))
+          (loop (cdr alist) (insert m (caar alist) (cdar alist))))))
 
 
     (define (hash-bytevector b)
diff --git a/linker-test.csc b/linker-test.csc
new file mode 100644
index 0000000..084e9ae
--- /dev/null
+++ b/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/linker.csc b/linker.csc
new file mode 100644
index 0000000..852ee13
--- /dev/null
+++ b/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/list-test.csc b/list-test.csc
index d4ea504..6e910c0 100644
--- a/list-test.csc
+++ b/list-test.csc
@@ -73,3 +73,23 @@
 
 (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/list.csc b/list.csc
index 799b070..f425146 100644
--- a/list.csc
+++ b/list.csc
@@ -1,5 +1,7 @@
 (define-library (csc list)
   (export
+    enumerate
+    filter
     intercalate
     revappend
     split-at
@@ -40,4 +42,23 @@
       (match l
         ('() '())
         ((_) l)
-        ((head . tail) (cons head (cons x (intercalate x tail))))))))
+        ((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/match-test.csc b/match-test.csc
index 84b488d..73daa58 100644
--- a/match-test.csc
+++ b/match-test.csc
@@ -7,10 +7,10 @@
   (assert-equal
     3
     (match 3
-      (0 0)
-      (1 1)
-      (2 2)
-      (3 3)
+      ((! 0) 0)
+      ((! 1) 1)
+      ((! 2) 2)
+      ((! 3) 3)
       (_ 4))))
 
 
@@ -19,9 +19,9 @@
     2
     (match '(1 2 3)
       ('() 0)
-      ((1 2) 1)
-      ((1 2 3) 2)
-      ((1 2 3 4) 3)
+      (((! 1) (! 2)) 1)
+      (((! 1) (! 2) (! 3)) 2)
+      (((! 1) (! 2) (! 3) (! 4)) 3)
       (_ 4))))
 
 
@@ -29,7 +29,7 @@
   (assert-equal
     2
     (match '(1 2 3)
-      ((1 x 3) x))))
+      (((! 1) x (! 3)) x))))
 
 
 (test match-destructuring
@@ -45,8 +45,8 @@
     2
     (match '(1 2 3)
       ((_ _ _ _) 0)
-      ((2 _ _) 1)
-      ((1 _ _) 2)
+      (((! 2) _ _) 1)
+      (((! 1) _ _) 2)
       (_ 3))))
 
 
@@ -54,6 +54,15 @@
   (assert-equal
     2
     (match '(1 2 3)
-      ((2 . _) 1)
-      ((1 . x) (car x))
+      (((! 2) . _) 1)
+      (((! 1) . x) (car x))
+      (_ 3))))
+
+
+(test match-symbol
+  (assert-equal
+    2
+    (match 'b
+      ((! 'a) 1)
+      ((! 'b) 2)
       (_ 3))))
diff --git a/match.csc b/match.csc
index e5ee6ec..07ca98c 100644
--- a/match.csc
+++ b/match.csc
@@ -4,25 +4,13 @@
   (begin
 
 
-    ; From https://cookbook.scheme.org/check-for-symbol-in-syntax-rules/
-    (define-syntax symbol??
-      (syntax-rules ()
-        ((symbol?? (_ . _) _ kf) kf)  ; It's a pair, not a symbol.
-        ((symbol?? #(_ ...) _ kf) kf)  ; It's a vector, not a symbol.
-        ((symbol?? maybe-symbol kt kf)
-         (let-syntax
-           ((test
-              (syntax-rules ()
-                ((test maybe-symbol t _) t)
-                ((test _ _ f) f))))
-           (test abracadabra kt kf)))))
-
-
     (define-syntax matches?
-      (syntax-rules (_)
+      (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)))
@@ -30,28 +18,25 @@
          (and (pair? x)
               (matches? (car x) pattern1)
               (matches? (cdr x) pattern2)))
-        ((matches? x lit)
-         (symbol?? lit
-           #t
-           (equal? x lit)))))
+        ((matches? x identifier) #t)))
 
 
     (define-syntax bind-pattern
-      (syntax-rules (_)
-        ((bind-pattern x _ result1 result2 ...)
-         (begin result1 result2 ...))
-        ((bind-pattern x '() result1 result2 ...)
-         (begin result1 result2 ...))
-        ((bind-pattern x (pattern) result1 result2 ...)
-         (bind-pattern (car x) pattern result1 result2 ...))
-        ((bind-pattern x (pattern1 . pattern2) result1 result2 ...)
+      (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 result1 result2 ...)))
-        ((bind-pattern x lit result1 result2 ...)
-         (symbol?? lit
-           (let ((lit x))
-             result1 result2 ...)
-           (begin result1 result2 ...)))))
+           (bind-pattern (cdr x) pattern2 result result* ...)))
+        ((bind-pattern x identifier result result* ...)
+         (let ((identifier x))
+           result result* ...))))
 
 
     (define-syntax match
diff --git a/strings-test.csc b/strings-test.csc
index 3fededb..2e6d240 100644
--- a/strings-test.csc
+++ b/strings-test.csc
@@ -34,7 +34,7 @@
   (assert-equal 8 (find "a" "sdfdfdfsasdfe")))
 
 
-(test test-str-find-notfound
+(test find-notfound
   (let* ((match "a")
          (str "def")
          (got-exception '()))
@@ -42,3 +42,19 @@
              ((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/strings.csc b/strings.csc
index 0828363..737c91b 100644
--- a/strings.csc
+++ b/strings.csc
@@ -1,12 +1,14 @@
 (define-library (csc strings)
   (export
     find
+    join
     not-found-error?
     prefix?
     str-quote)
   (import (scheme base)
-          (scheme case-lambda)
-          (only (scheme write) write))
+          (only (scheme case-lambda) case-lambda)
+          (only (scheme write) write)
+          (only (csc list) intercalate))
   (begin
 
 
@@ -37,4 +39,8 @@
          (let loop ((i start))
            (cond ((>= i end) (raise (make-not-found-error)))
                  ((prefix? match str i) i)
-                 (else (loop (+ 1 i))))))))))
+                 (else (loop (+ 1 i))))))))
+
+
+    (define (join sep . strings)
+      (apply string-append (intercalate sep strings)))))
diff --git a/testing.csc b/testing.csc
index aebc574..a0180e6 100644
--- a/testing.csc
+++ b/testing.csc
@@ -2,6 +2,7 @@
   (export
     assert
     assert-equal
+    assert-raises
     test
     test-main)
   (import (scheme base)
@@ -53,7 +54,7 @@
       (syntax-rules ()
         ((assert expr)
          (unless expr
-           (fatalf "Assertion {} failed." 'expr)))))
+           (fatalf "(assert {}) failed." 'expr)))))
 
 
     (define-syntax assert-equal
@@ -65,6 +66,15 @@
              (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")
-- 
cgit v1.3.1