Rewrite the macro expander to use set of scopes.HEADmain

I no longer have confidence that the timestamp approach will work for
all of the different cases that aren't discussed in the original paper.
The original paper was only about expanding a fixed set of syntax
transformers, and didn't consider defining new transformers.

Set of scopes is an extremely intuitive system, and hopefully that will
mean it's easier to implement without bugs. I think I finally understand
how it works after watching this video: https://youtu.be/Or_yKiI3Ha4

1 files changed, 51 insertions, 21 deletions

diff --git a/lib/csc/map.scheme b/lib/csc/map.scheme
index be27758..27eb0c2 100644
--- a/lib/csc/map.scheme
+++ b/lib/csc/map.scheme
@@ -13,7 +13,10 @@
     map?
     not-found-error?
     singleton
-    union)
+    size
+    subset?
+    union
+    union-with)
   (import (scheme base)
           (only (scheme case-lambda) case-lambda))
   (begin
@@ -67,12 +70,16 @@
       (make-map cmp (singleton-node key val)))
 
 
-    (define (size n)
+    (define (sz n)
       (if n
         (node-size n)
         0))
 
 
+    (define (size m)
+      (sz (map-root m)))
+
+
     (define-record-type <not-found-error>
       (make-not-found-error)
       not-found-error?)
@@ -99,7 +106,7 @@
 
     ; The bin constructor maintains the size of the tree.
     (define (bin k x l r)
-      (make-node (+ (size l) (size r) 1) k x l r))
+      (make-node (+ (sz l) (sz r) 1) k x l r))
 
 
     ; https://hackage.haskell.org/package/containers-0.4.0.0/docs/src/Data-Map.html#delta
@@ -131,20 +138,20 @@
 
 
     (define (rotate-l k x l r)
-      (if (< (size (node-left r)) (* ratio (size (node-right r))))
+      (if (< (sz (node-left r)) (* ratio (sz (node-right r))))
         (single-l k x l r)
         (double-l k x l r)))
 
 
     (define (rotate-r k x l r)
-      (if (< (size (node-right l)) (* ratio (size (node-left l))))
+      (if (< (sz (node-right l)) (* ratio (sz (node-left l))))
         (single-r k x l r)
         (double-r k x l r)))
 
 
     (define (balance k x l r)
-      (define size-l (size l))
-      (define size-r (size r))
+      (define size-l (sz l))
+      (define size-r (sz r))
       (cond
         ((<= (+ size-l size-r) 1) (bin k x l r))
         ((> size-r (* delta size-l)) (rotate-l k x l r))
@@ -186,11 +193,11 @@
 
     (define (split cmp t k)
       (match t
-        (tip (values #f #f #f))
+        (tip (values #f *not-found-error* #f))
         ((node km m l r)
           (define ord (cmp k km))
           (cond
-            ((zero? ord) (values l #t r))
+            ((zero? ord) (values l m r))
             ((negative? ord)
               (let-values (((ll b lr) (split cmp l k)))
                 (values ll b (join km m lr r))))
@@ -232,28 +239,36 @@
         (foldl f (f acc (car l)) (cdr l))))
 
 
-    (define (union-node cmp t1 t2)
+    (define (union-node cmp f t1 t2)
       (cond
-        ((not t1) t2)
         ((not t2) t1)
+        ((not t1) t2)
         (else
-          (match t2 ((node k2 x2 l2 r2)
-            (define-values (l1 b r1) (split cmp t1 k2))
-            (define tl (union-node cmp l1 l2))
-            (define tr (union-node cmp r1 r2))
-            (join k2 x2 tl tr))))))
+          (match t1 ((node k1 x1 l1 r1)
+            (define-values (l2 x2 r2) (split cmp t2 k1))
+            (define tl (union-node cmp f l1 l2))
+            (define tr (union-node cmp f r1 r2))
+            (define x
+              (if (eq? x2 *not-found-error*)
+                x1
+                (f x1 x2)))
+            (join k1 x tl tr))))))
 
 
-    (define (union m . ms)
+    (define (union-with f m . ms)
       (define cmp (map-cmp m))
       (make-map cmp
         (foldl
           (lambda (acc x)
-            (union-node cmp acc (map-root x)))
+            (union-node cmp f acc (map-root x)))
           (map-root m)
           ms)))
 
 
+    (define (union m . ms)
+      (apply union-with (lambda (l r) r) m ms))
+
+
     (define (intersect-node cmp t1 t2)
       (cond
         ((not (and t1 t2)) #f)
@@ -262,9 +277,9 @@
             (define-values (l1 b r1) (split cmp t1 k2))
             (define tl (intersect-node cmp l1 l2))
             (define tr (intersect-node cmp r1 r2))
-            (if b
-              (join k2 x2 tl tr)
-              (join2 tl tr)))))))
+            (if (eq? b *not-found-error*)
+              (join2 tl tr)
+              (join k2 x2 tl tr)))))))
 
 
     (define (intersect m . ms)
@@ -298,6 +313,21 @@
           ms)))
 
 
+    (define (subset-node cmp a b)
+      (match a
+        (tip #t)
+        ((node k x al ar)
+          (define-values (bl found? br) (split cmp b k))
+          (and (not (eq? found? *not-found-error*))
+               (subset-node cmp al bl)
+               (subset-node cmp ar br)))))
+
+
+    (define (subset? a b)
+      (define cmp (map-cmp a))
+      (make-map cmp (subset-node cmp (map-root a) (map-root b))))
+
+
     (define (list->map cmp l)
       (foldl
         (lambda (acc x)