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

2 files changed, 327 insertions, 158 deletions

diff --git a/lib/csc/macros.scheme b/lib/csc/macros.scheme
index 2d6b790..a360ebe 100644
--- a/lib/csc/macros.scheme
+++ b/lib/csc/macros.scheme
@@ -37,16 +37,19 @@
       (body toplevel-define-body))
 
 
-    (define-record-type <tsvar>
-      (make-tsvar var timestamp)
-      tsvar?
-      (var tsvar-var)
-      (timestamp tsvar-ts))
+    (define-record-type <syntax>
+      (syntax e scopes)
+      syntax?
+      (e syntax-e)
+      (scopes syntax-scopes))
 
 
-    (define (stamper ts)
-      (lambda (var)
-        (make-tsvar var ts)))
+    (define *next-scope* 0)
+
+
+    (define (scope)
+      (set! *next-scope* (+ 1 *next-scope*))
+      *next-scope*)
 
 
     (define (constant? x)
@@ -58,52 +61,131 @@
           (vector? x)))
 
 
-    ; timestamp stamps all unstamped symbols.
-    (define (timestamp tree stamp)
+    (define (set . l)
+      (list.foldl
+        (lambda (acc x)
+          (map.insert acc x #t))
+        (map.empty -)
+        l))
+
+
+    (define *core-scopes* (set (scope)))
+
+
+    ; stamp turns an stree into a syntax expression by stamping all of the
+    ; libvars with the core scope.
+    (define (stamp tree)
+      (let loop ((tree tree))
+        (cond
+          ((ir.libvar? tree)
+            (syntax tree *core-scopes*))
+          ((list? tree)
+            (map loop tree))
+          ((constant? tree) tree)
+          (else (error "unexpected form in stamp" tree)))))
+
+
+    (define (add-scope tree . scopes)
       (cond
-        ((ir.libvar? tree)
-          (stamp tree))
+        ((syntax? tree)
+          (syntax (syntax-e tree) (map.union (syntax-scopes tree) (apply set scopes))))
         ((list? tree)
-          (map (lambda (x) (timestamp x stamp)) tree))
+          (map (lambda (x) (apply add-scope x scopes)) tree))
         ((constant? tree) tree)
-        (else (error "unexpected form in timestamp" tree))))
+        (else (error "unexpected form in add-scope"))))
+
+
+    (define (cmp-strings s1 s2)
+      (cond
+        ((string=? s1 s2)
+          0)
+        ((string<? s1 s2)
+          -1)
+        (else 1)))
+
+
+    (define (cmp-libvar x y)
+      (define d (cmp-strings (ir.libvar-lib x)
+                             (ir.libvar-lib y)))
+      (if (zero? d)
+        (cmp-strings (ir.libvar-var x) (ir.libvar-var y))
+        d))
+
+
+    (define *empty-libvar-map* (map.empty cmp-libvar))
+
+
+    ; *environment* holds the mappings for expansion.
+    ; The type of *environment* is a bit complicated, so it deserves
+    ; documentation. It is a map keyed by library variables. The values are
+    ; association lists, keyed by scope sets. The value of the inner
+    ; association list can be either a macro transformer, represented as a
+    ; procedure, or a gensym for a variable. Variables are not resolved yet,
+    ; but we put them in the environment so that we can track accurately
+    ; whether a symbol resolves to a macro or a variable.
+    (define *environment* *empty-libvar-map*)
+
+
+    (define (best-mapping scopes candidate-mappings)
+      (cdr
+        (list.foldl
+          (lambda (best x)
+            (define key (car x))
+            (if (and (map.subset? key scopes)
+                     (> (map.size key) (map.size (car best))))
+              x
+              best))
+          (cons (set) #f)
+          candidate-mappings)))
+
+
+    (define (lookup stx)
+      (define candidate-mappings (map.lookup *environment* (syntax-e stx) #f))
+      (and candidate-mappings
+           (best-mapping (syntax-scopes stx) candidate-mappings)))
+
+
+    (define (lookup-macro stx)
+      (define mapping (lookup stx))
+      (and (not (gensym.gensym? mapping))
+           mapping))
 
 
-    (define (lookup-macro env var)
-      (define binding1 (map.lookup env var #f))
-      (if (procedure? binding1)
-        binding1
-        ; Check for var in the global namespace.
-        (let ((binding2 (map.lookup env (make-tsvar (tsvar-var var) 0) #f)))
-          (and (procedure? binding2)
-               binding2))))
+    (define (insert stx val)
+      (define name (syntax-e stx))
+      (set! *environment*
+        (map.insert *environment* name
+          (cons (cons (syntax-scopes stx) val)
+                (map.lookup *environment* name '())))))
 
 
-    ; expand expands all macros in a timestamped stree.
-    (define (expand tree env time)
+    ; expand expands all macros in a syntax expression.
+    (define (expand tree)
       (cond
         ((and (pair? tree)
-              (tsvar? (car tree))
-              (lookup-macro env (car tree))) =>
-          (lambda (transformer)
-            (transformer tree env time)))
+              (syntax? (car tree))
+              (lookup-macro (car tree))) => (lambda (transformer)
+          (transformer tree)))
         ((null? tree)
           (error "nil by itself is an error"))
         ((list? tree)
           (ir.make-apply
-            (expand (car tree) env time)
+            (expand (car tree))
             (list
               (list.foldr
                 (lambda (x acc)
                   (ir.make-call-builtin 'cons
-                    (list
-                      (expand x env time)
-                      acc)))
+                     (list (expand x) acc)))
                 (ir.make-const '())
                 (cdr tree)))))
-        ((tsvar? tree)
-          (or (map.lookup env tree #f)
-              tree))  ; Global variables are still unresolved.
+        ((syntax? tree)
+          (when (lookup-macro tree)
+            (error "macro in wrong context" tree))
+          ; Variables are unresolved for now. In order to support
+          ; mutually-recursive procedures, or even procedures defined out of
+          ; order, we need to wait until all the macros are expanded to
+          ; resolve variables.
+          tree)
         ((constant? tree)
           (ir.make-const tree))
         (else (error "unexpected form in expand" tree))))
@@ -125,8 +207,8 @@
           (ir.make-set (f (ir.set-var expr)) (f (ir.set-body expr))))
         ((ir.call-builtin? expr)
           (ir.make-call-builtin (ir.call-builtin-name expr) (map f (ir.call-builtin-args expr))))
-        ((or (tsvar? expr)
-             (gensym.gensym? expr)
+        ((or (gensym.gensym? expr)
+             (syntax? expr)
              (ir.const? expr))
           expr)
         ((ir.void? expr) ir.*void*)
@@ -149,7 +231,7 @@
           (f (f acc (ir.set-var expr)) (ir.set-body expr)))
         ((ir.call-builtin? expr)
           (list.foldl f acc (ir.call-builtin-args expr)))
-        ((or (tsvar? expr)
+        ((or (syntax? expr)
              (gensym.gensym? expr)
              (ir.const? expr)
              (ir.void? expr))
@@ -157,52 +239,14 @@
         (else (error "unexpected form in fold-ir1" expr))))
 
 
-    (define (cmp-strings s1 s2)
+    ; unstamp resolves the variables.
+    (define (unstamp stx)
       (cond
-        ((string=? s1 s2)
-          0)
-        ((string<? s1 s2)
-          -1)
-        (else 1)))
-
-
-    (define (cmp-libvar x y)
-      (define d (cmp-strings (ir.libvar-lib x)
-                             (ir.libvar-lib y)))
-      (if (zero? d)
-        (cmp-strings (ir.libvar-var x) (ir.libvar-var y))
-        d))
-
-
-    (define *empty-libvar-map* (map.empty cmp-libvar))
-
-
-    (define (cmp-tsvar v1 v2)
-      (define d (- (tsvar-ts v1) (tsvar-ts v2)))
-      (if (zero? d)
-        (cmp-libvar (tsvar-var v1) (tsvar-var v2))
-        d))
-
-
-    (define *empty-tsvar-map* (map.empty cmp-tsvar))
-
-
-    (define (expand-body prog env time)
-      (let loop ((prog prog)
-                 (env env)
-                 (time time))
-        (if (null? prog)
-          '()
-          (let ((expanded (expand (car prog) env time)))
-            (cond
-              ((and (toplevel-define? expanded)
-                    (procedure? (toplevel-define-body expanded)))
-                (loop (cdr prog)
-                  (map.insert env (toplevel-define-var expanded) (toplevel-define-body expanded))
-                  (+ 1 time)))
-              (else
-                (cons expanded
-                  (loop (cdr prog) env (+ 1 time)))))))))
+        ((syntax? stx)
+          (or (lookup stx)
+              (error "unbound variable" stx)))
+        (else
+          (map-ir1 unstamp stx))))
 
 
     (define (remaining-defines? expr)
@@ -245,52 +289,27 @@
       new-body)
 
 
-    ; remaining-symbols returns the timestamped symbols in tree.
-    (define (remaining-symbols tree)
-      (cond
-        ((tsvar? tree)
-          ; These free variables should be unstamped, since they refer to
-          ; toplevel bindings.
-          (map.singleton cmp-strings (tsvar-var tree) (gensym.gen)))
-        (else
-          (fold-ir1
-            (lambda (acc x)
-              (map.union acc (remaining-symbols x)))
-            *empty-libvar-map*
-            tree))))
-
-
-    (define (unstamp-tree tree symbols)
-      (cond
-        ((tsvar? tree)
-          (map.lookup symbols (tsvar-var tree)))
-        (else (map-ir1 (lambda (x) (unstamp-tree x symbols)) tree))))
-
-
-    ; unstamp changes the timestamped symbols in expr into gensyms.
-    (define (unstamp expr)
-      (unstamp-tree expr (remaining-symbols expr)))
-
-
-    (define (builtin-define expr env time)
+    (define (builtin-define expr)
       (unless (and (list? expr)
                    (= (length expr) 3)
-                   (tsvar? (cadr expr)))
+                   (syntax? (cadr expr)))
         (error "invalid form in builtin-define"))
       (let-values (((var body) (apply values (cdr expr))))
-        (make-toplevel-define var (expand body env (+ 1 time)))))
+        (insert var (gensym.gen))
+        (make-toplevel-define var (expand body))))
 
 
-    (define (builtin-lambda expr env time)
+    (define (builtin-lambda expr)
       (unless (and (list? expr)
                    (>= (length expr) 3)
-                   (tsvar? (cadr expr)))
+                   (syntax? (cadr expr)))
         (error "invalid form in builtin-lambda"))
       (let ((var (cadr expr))
             (body (cddr expr))
-            (new-var (gensym.gen)))
-        (define env* (map.insert env var new-var))
-        (define expanded-body (expand-body body env* (+ 1 time)))
+            (var-scope (scope))
+            (body-scope (scope)))
+        (define new-var (add-scope var var-scope))
+        (define expanded-body (map expand (add-scope body var-scope body-scope)))
         (define exprs
           (let loop ((body expanded-body))
             (if (or (null? body)
@@ -299,48 +318,168 @@
               (loop (cdr body)))))
         (when (list.any remaining-defines? exprs)
           (error "out of order define"))
+        (insert new-var (gensym.gen))
         (ir.make-lambda (list new-var) (rewrite-body expanded-body))))
 
 
-    (define (builtin-call-builtin expr env time)
+
+    (define (builtin-call-builtin expr)
       (unless (and (list? expr)
                    (>= (length expr) 2)
-                   (tsvar? (cadr expr)))
+                   (syntax? (cadr expr)))
         (error "invalid form in builtin-call-builtin"))
-      (let ((builtin-name (tsvar-var (cadr expr)))
+      (let ((builtin-name (ir.libvar-var (syntax-e (cadr expr))))
             (args (cddr expr)))
-        (ir.make-call-builtin (string->symbol (ir.libvar-var builtin-name))
+        (ir.make-call-builtin (string->symbol builtin-name)
           (map
             (lambda (arg)
-              (expand arg env (+ 1 time)))
+              (expand arg))
             args))))
 
 
+    (define (gensym=? x y)
+      (and (gensym.gensym? x)
+           (gensym.gensym? y)
+           (= (gensym.gensym->int x) (gensym.gensym->int y))))
+
+
+    (define (free-identifier=? a b)
+      (and (syntax? a)
+           (syntax? b)
+           (let ((binding-a (lookup a))
+                 (binding-b (lookup b)))
+             (or (and binding-a
+                      binding-b
+                      (or (gensym=? binding-a binding-b)
+                          ; If not a gensym, then a procedure.
+                          (eq? binding-a binding-b)))
+                 (and (not binding-a)
+                      (not binding-b)
+                      (string=? (ir.libvar-var (syntax-e a)) (ir.libvar-var (syntax-e b))))))))
+
+
+    (define (identifier=? a b)
+      (and (syntax? a)
+           (syntax? b)
+           (string=? (ir.libvar-var (syntax-e a)) (ir.libvar-var (syntax-e b)))))
+
+
+    (define *empty-string-map* (map.empty cmp-strings))
+
+
+    ; TODO: handle ellipsis
+    (define (pattern-bindings ellipsis literals pattern object)
+      (cond
+        ((list.any (lambda (lit) (identifier=? pattern lit)) literals)
+          (and (free-identifier=? object pattern)
+               *empty-string-map*))
+        ((and (syntax? pattern)
+              (string=? "_" (ir.libvar-var (syntax-e pattern))))
+          *empty-string-map*)
+        ((syntax? pattern)
+          (map.singleton cmp-strings (ir.libvar-var (syntax-e pattern)) object))
+        ((null? pattern)
+          (and (null? object)
+               *empty-string-map*))
+        ((pair? pattern)
+          (and (pair? object)
+            (let ((pbindings (pattern-bindings ellipsis literals (car pattern) (car object)))
+                  (p*bindings (pattern-bindings ellipsis literals (cdr pattern) (cdr object))))
+              (and pbindings
+                   p*bindings
+                   (map.union pbindings p*bindings)))))
+        ((constant? pattern)
+          (and (equal? object pattern)
+               *empty-string-map*))
+        (else (error "unexpected form in pattern-bindings" pattern))))
+
+
+    (define (expand-template ellipsis ellipsis-nesting bindings template)
+      (cond
+        ((null? template)
+          '())
+        ((pair? template)
+          (cons (expand-template ellipsis ellipsis-nesting bindings (car template))
+                (expand-template ellipsis ellipsis-nesting bindings (cdr template))))
+        ((and (syntax? template)
+              (map.lookup bindings (ir.libvar-var (syntax-e template)) #f)) => (lambda (x) x))
+        (else template)))
+
+
+    (define (builtin-syntax-rules expr)
+      (error "syntax-rules in wrong context"))
+
+
+    (define (real-syntax-rules expr)
+      (define-values (ellipsis literals rules)
+        (cond
+          ((and (list? expr)
+                (>= (length expr) 3)
+                (syntax? (cadr expr))
+                (list? (list-ref expr 2))
+                (list.all syntax? (list-ref expr 2)))
+            (values (ir.libvar-var (syntax-e (cadr expr))) (list-ref expr 2) (list-tail expr 3)))
+          ((and (list? expr)
+                (>= (length expr) 2)
+                (list? (cadr expr))
+                (list.all syntax? (cadr expr)))
+            (values "..." (cadr expr) (cddr expr)))
+          (else (error "invalid form in builtin-syntax-rules"))))
+      (unless (list.all (lambda (rule) (and (list? rule)
+                                            (= 2 (length rule))))
+                        rules)
+        (error "invalid form in builtin-syntax-rules"))
+      (lambda (arg)
+        (call/cc (lambda (return)
+          (for-each
+            (lambda (rule)
+              (define bindings (pattern-bindings ellipsis literals (car rule) arg))
+              (when bindings
+                (return (expand (expand-template ellipsis (vector) bindings (add-scope (cadr rule) (scope)))))))
+            rules)
+          (error "builtin-syntax-rules: no match")))))
+
+
+    (define (builtin-define-syntax expr)
+      (unless (and (list? expr)
+                   (= (length expr) 3)
+                   (syntax? (cadr expr))
+                   (pair? (list-ref expr 2))
+                   (syntax? (car (list-ref expr 2)))
+                   (eq? builtin-syntax-rules (lookup-macro (car (list-ref expr 2)))))
+        (error "invalid form in builtin-define"))
+      (let-values (((var transformer-spec) (apply values (cdr expr))))
+        (define transformer (real-syntax-rules transformer-spec))
+        (insert var transformer)
+        ir.*void*))
+
+
     (define *builtins-environment*
       (list.foldl
         (lambda (acc x)
-          (map.insert acc (make-tsvar (ir.make-libvar "(csc builtins)" (car x)) 0) (cdr x)))
-        *empty-tsvar-map*
+          (map.insert acc (ir.make-libvar "(csc builtins)" (car x)) (list (cons *core-scopes* (cdr x)))))
+        *empty-libvar-map*
         (list (cons "define" builtin-define)
+              (cons "define-syntax" builtin-define-syntax)
               (cons "lambda" builtin-lambda)
+              (cons "syntax-rules" builtin-syntax-rules)
               (cons "call-builtin" builtin-call-builtin))))
-    ; Damn I can't believe we didn't actually implement syntax-rules.
 
 
     (define (list-builtins)
-      (map
-        (lambda (x)
-          (string->symbol (ir.libvar-var (tsvar-var (car x)))))
-        (map.map->list *builtins-environment*)))
+      (append
+        (map
+          (lambda (bindings)
+            (map (lambda (x) (string->symbol (ir.libvar-var (syntax-e (cdr x)))))
+              (cdr bindings)))
+          (map.map->list *builtins-environment*))))
 
 
     (define (expand-program prog)
+      (set! *environment* *builtins-environment*)
       (unstamp
         (rewrite-body
-          (expand-body
-            (map
-              (lambda (x)
-                (timestamp x (stamper 0)))
-              prog)
-            *builtins-environment*
-            1))))))
+          (map
+            (lambda (x)
+              (expand (stamp x)))
+            prog))))))
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)