move utils to new library, emit ellipsis dag from matcher compiler

The compiler now returns a DAG implemented as a hash table. The keys
are ellipsis group IDs and the values are lists of ellipsis group IDS.
When a producer encounters a repeated form, it uses the information in
this DAG to confirm that the production is valid.

7 files changed, 128 insertions, 54 deletions

diff --git a/multisyntax/pattern/matcher.scm b/multisyntax/pattern/matcher.scm
index 8870b54..ea9cde3 100644
--- a/multisyntax/pattern/matcher.scm
+++ b/multisyntax/pattern/matcher.scm
@@ -1,4 +1,4 @@
-#| Copyright (c) Peter McGoron 2025
+ #| Copyright (c) Peter McGoron 2025
  |
  | Licensed under the Apache License, Version 2.0 (the "License");
  | you may not use this file except in compliance with the License.
@@ -22,11 +22,13 @@
  | 2. a hashmap from identifiers to `(cons x y)`, where
  |    `x` is the "ellipsis nesting level" and `y` is the "ellipsis group".
  |    The hashmap checks identifier according to `bound-identifier=?`.
+ | 3. A hashmap from ellipsis groups to ellipsis groups. These are the
+ |    ellipsis groups that occur inside of that ellipsis group.
  |
  | The matcher is implemented as a recursive procedure that accumulates
  | the result map as it continues. When it encounters a template of the
  | form `template ...` in a vector or a list, `template` is matched with
- | an empty identifier hashmap. map. If `template` successfully matches,
+ | an empty identifier hashmap. If `template` successfully matches,
  | the returned identifiers inside of that pattern are inserted into the
  | result map as elements of a list and then P is called again. This way,
  | multiple values from an ellipsis can be collected.
@@ -126,6 +128,19 @@
   ;; Current ellipsis group.
   (make-parameter #f))
 
+(define ellipsis-group-map
+  ;; Map containing the ellipsis group tree.
+  (make-parameter #f))
+
+(define (set-parameter! parameter operation)
+  ;; Set the box stored in `parameter` to the value returned by
+  ;; `(operation value)`, where `value` is the value stored in the box.
+  ;; 
+  ;; This has no effect if `box` is falsy.
+  (let ((box (parameter)))
+    (when box
+      (set-box! box (operation (unbox box))))))
+
 (define (call/nesting-level procedure . args)
   ;; Invoke (procedure args ...) with a higher nesting level and an empty
   ;; `bound-here` map. Also creates a new ellipsis group.
@@ -135,10 +150,20 @@
   ;; 1. `return` is the returned value from `(procedure args ...)`
   ;; 2. `map` is the map of identifiers at this nesting level to their
   ;;    default values (the empty list).
-  (let ((old-bound-here-box (bound-here)))
+  (let ((old-bound-here-box (bound-here))
+        (outer-ellipsis-group (ellipsis-group)))
     (parameterize ((nesting-level (+ (nesting-level) 1))
                    (bound-here (box (empty-map)))
                    (ellipsis-group (generate-unique-integer)))
+      (when outer-ellipsis-group
+        (set-parameter! ellipsis-group-map
+                        (cute hashmap-update!/default
+                              <>
+                              outer-ellipsis-group
+                              (cute cons (ellipsis-group) <>)
+                              '())))
+      (set-parameter! ellipsis-group-map
+                      (cute hashmap-set! <> (ellipsis-group) '()))
       (let ((returned (apply procedure args)))
         (values returned (unbox (bound-here)))))))
 
@@ -150,18 +175,19 @@
   ;; Add `identifier` to the name map with the current ellipsis nesting
   ;; level. If the identifier is added inside of an ellipses nesting level,
   ;; then it is also added to the `bound-here` map.
-  (let* ((the-box (bindings))
-         (old (unbox the-box)))
-    (when (hashmap-contains? old identifier)
-      (error "identifier bound twice" identifier))
-    (when (bound-here)
-      (set-box! (bound-here) (hashmap-set! (unbox (bound-here))
-                                           identifier
-                                           '())))
-    (set-box! the-box (hashmap-set! old
-                                    identifier
-                                    (cons (nesting-level)
-                                          (ellipsis-group))))))
+  (set-parameter! bound-here
+                  (lambda (bound-here)
+                    (hashmap-set! bound-here
+                                  identifier
+                                  '())))
+  (set-parameter!
+   bindings
+   (lambda (map)
+     (when (hashmap-contains? map identifier)
+       (error "identifier bound twice" identifier))
+     (hashmap-set! map
+                   identifier
+                   (cons (nesting-level) (ellipsis-group))))))
 
 (define (contains-as-free-identifier set key)
   ;; Returns an identifier if `key` is `free-identifier=?` to any
@@ -220,22 +246,17 @@
                       (actual-ellipsis-procedure
                        (generate-ellipsis-procedure literals ellipsis))
                       (literals-parameter literals)
-                      (bindings (box (empty-map))))
+                      (bindings (box (empty-map)))
+                      (ellipsis-group-map (box (hashmap exact-integer-comparator))))
          (let ((match (compile stx)))
-           (values (lambda (stx)
-                     (match (empty-map) stx))
-                   (unbox (bindings)))))))))
+           (values (lambda (stx) (match (empty-map) stx))
+                   (unbox (bindings))
+                   (unbox (ellipsis-group-map)))))))))
 
 ;;; ;;;;;;;;;;;;;;;;;;;;
 ;;; Helper functions
 ;;; ;;;;;;;;;;;;;;;;;;;;
 
-(define generate-unique-integer
-  (let ((i 0))
-    (lambda ()
-      (set! i (+ i 1))
-      i)))
-
 (define (empty-map)
   (hashmap bound-identifier-comparator))
 
diff --git a/multisyntax/pattern/matcher.sld b/multisyntax/pattern/matcher.sld
index c842577..3eef7b6 100644
--- a/multisyntax/pattern/matcher.sld
+++ b/multisyntax/pattern/matcher.sld
@@ -15,7 +15,8 @@
 
 (define-library (multisyntax pattern matcher)
   (import (scheme base) (scheme write) (scheme case-lambda)
-          (srfi 26) (srfi 111) (srfi 113) (srfi 146 hash)
+          (srfi 26) (srfi 111) (srfi 113) (srfi 146 hash) (srfi 197)
+          (multisyntax utils)
           (only (multisyntax syntax-object)
                 identifier? bound-identifier=? free-identifier=?
                 unwrap-syntax
diff --git a/multisyntax/syntax-object.scm b/multisyntax/syntax-object.scm
index 320ee6e..d321873 100644
--- a/multisyntax/syntax-object.scm
+++ b/multisyntax/syntax-object.scm
@@ -19,19 +19,11 @@
 ;;; Timestamps
 ;;; ;;;;;;;;;;
 
-(define generate-unique-integer
-  ;; Generate a unique positive integer.
-  (let ((x 1))
-    (lambda ()
-      (set! x (+ x 1))
-      x)))
-
 (define generate-timestamp
   ;; A timestamp is an integer.
   generate-unique-integer)
 
-(define timestamp-comparator
-  (make-comparator exact-integer? = < number-hash))
+(define timestamp-comparator exact-integer-comparator)
 
 ;;; ;;;;;;;;;;;;;;;
 ;;; Locations and substitutions
@@ -61,13 +53,6 @@
                  "."
                  (number->string (lexical-location->unique-id ll))))
 
-(define symbol-comparator
-  (make-comparator
-   symbol?
-   symbol=?
-   (lambda (x y) (string<? (symbol->string x) (symbol->string y)))
-   symbol-hash))
-
 (define environment-key-comparator
   ;; Comparator for keys to the environment that stores substitutions.
   ;; 
diff --git a/multisyntax/syntax-object.sld b/multisyntax/syntax-object.sld
index 7886d38..e3df648 100644
--- a/multisyntax/syntax-object.sld
+++ b/multisyntax/syntax-object.sld
@@ -18,7 +18,8 @@
 (define-library (multisyntax syntax-object)
   (import (scheme base) (scheme case-lambda)
           (scheme write)
-          (srfi 26) (srfi 113) (srfi 128) (srfi 133) (srfi 146) (srfi 228))
+          (srfi 26) (srfi 113) (srfi 128) (srfi 133) (srfi 146) (srfi 228)
+          (multisyntax utils))
   (export generate-lexical-location
           lexical-location->string
           lexical-location-comparator
diff --git a/multisyntax/utils.sld b/multisyntax/utils.sld
new file mode 100644
index 0000000..1d422b7
--- /dev/null
+++ b/multisyntax/utils.sld
@@ -0,0 +1,34 @@
+#| Copyright (c) Peter McGoron 2025
+ |
+ | Licensed under the Apache License, Version 2.0 (the "License");
+ | you may not use this file except in compliance with the License.
+ | You may obtain a copy of the License at
+ |
+ |     http://www.apache.org/licenses/LICENSE-2.0
+ |
+ | Unless required by applicable law or agreed to in writing, software
+ | distributed under the License is distributed on an "AS IS" BASIS,
+ | WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+ | See the License for the specific language governing permissions and
+ | limitations under the License.
+ |#
+
+(define-library (multisyntax utils)
+  (import (scheme base) (srfi 128))
+  (export generate-unique-integer
+          symbol-comparator exact-integer-comparator)
+  (begin
+    (define generate-unique-integer
+      ;; Generate a unique positive integer.
+      (let ((x 1))
+        (lambda ()
+          (set! x (+ x 1))
+          x)))
+    (define symbol-comparator
+      (make-comparator
+       symbol?
+       symbol=?
+       (lambda (x y) (string<? (symbol->string x) (symbol->string y)))
+       symbol-hash))
+    (define exact-integer-comparator
+      (make-comparator exact-integer? = < number-hash))))
diff --git a/test/pattern/matcher.scm b/test/pattern/matcher.scm
index acdea63..616570f 100644
--- a/test/pattern/matcher.scm
+++ b/test/pattern/matcher.scm
@@ -21,7 +21,7 @@
 (define empty-set (set bound-identifier-comparator))
 
 (define (test-single-match)
-  (define-values (matcher names)
+  (define-values (matcher names _)
     (compile-pattern '() (empty-wrap 'x)))
   (test-equal "nesting info of identifier"
               (cons 0 #f)
@@ -40,7 +40,7 @@
                                      (empty-wrap 'y)))))
 
 (define (test-match-in-list)
-  (define-values (matcher names)
+  (define-values (matcher names _)
     (compile-pattern '() (list (empty-wrap 'x))))
   (test-equal "nesting info of identifier"
               (cons 0 #f)
@@ -54,7 +54,7 @@
                                      (empty-wrap 'y)))))
 
 (define (test-multiple-matches-in-list)
-  (define-values (matcher names)
+  (define-values (matcher names _)
     (compile-pattern '() (list (empty-wrap 'x)
                                (empty-wrap 'y))))
   (test-equal "nesting info of x"
@@ -68,11 +68,15 @@
     (test-equal "second" 2 (hashmap-ref returned (empty-wrap 'y)))))
 
 (define (test-simple-ellipsis)
-  (define-values (matcher names)
+  (define-values (matcher names levels)
     (compile-pattern '() (list (empty-wrap 'x) ellipsis)))
+  (define data-x (hashmap-ref names (empty-wrap 'x)))
   (test-equal "nesting level of x"
               1
-              (car (hashmap-ref names (empty-wrap 'x))))
+              (car data-x))
+  (test-equal "nested ellipsis groups of the group of x"
+              '()
+              (hashmap-ref levels (cdr data-x)))
   (let* ((list '(1 2 3 4 5 6 7 8))
          (returned (matcher list))
          (x-value (hashmap-ref returned (empty-wrap 'x))))
@@ -100,10 +104,12 @@
                     (empty-wrap 'x))))))
 
 (define (test-multiple-ellipsis)
-  (define-values (matcher names)
+  (define-values (matcher names levels)
     (compile-pattern '()
                      (list (list (empty-wrap 'x) ellipsis)
                            (list (empty-wrap 'y) ellipsis))))
+  (define data-x (hashmap-ref names (empty-wrap 'x)))
+  (define data-y (hashmap-ref names (empty-wrap 'y)))
   (define (test-for list x y)
     (let ((returned (matcher list)))
       (test-equal "x"
@@ -112,6 +118,16 @@
       (test-equal "y"
                   y
                   (hashmap-ref returned (empty-wrap 'y)))))
+  (test-equal "level of x" 1 (car data-x))
+  (test-equal "level of y" 1 (car data-y))
+  (test-assert "groups of x and y are different"
+               (not (= (cdr data-x) (cdr data-y))))
+  (test-equal "ellipses subgroups of x"
+              '()
+              (hashmap-ref levels (cdr data-y)))
+  (test-equal "ellipses subgroups of y"
+              '()
+              (hashmap-ref levels (cdr data-y)))
   (test-group "two lists"
     (test-for '((1 2 3 4) (5 6 7 8))
               '(4 3 2 1)
@@ -122,10 +138,12 @@
               '())))
 
 (define (test-compound-ellipsis)
-  (define-values (matcher names)
+  (define-values (matcher names levels)
     (compile-pattern '()
                      (list (list (empty-wrap 'name) (empty-wrap 'value))
                            ellipsis)))
+  (define data-x (hashmap-ref names (empty-wrap 'x)))
+  (define data-y (hashmap-ref names (empty-wrap 'y)))
   (define (test-for list x y)
     (let ((returned (matcher list)))
       (test-equal "x"
@@ -134,6 +152,10 @@
       (test-equal "y"
                   y
                   (hashmap-ref returned (empty-wrap 'y)))))
+  (test-equal "level of x" 1 (car data-x))
+  (test-equal "level of y" 1 (car data-y))
+  (test-equal "x and y are in the same group"
+              (= (cdr data-x) (cdr data-y)))
   (test-group "pairs"
     (test-for '((1 2) (3 4) (5 6))
               '(5 3 1)
@@ -142,11 +164,13 @@
     (test-for '() '() '())))
 
 (define (test-nested-ellipsis)
-  (define-values (matcher names)
+  (define-values (matcher names levels)
     (compile-pattern '()
                      (list (list (list (empty-wrap 'name) ellipsis)
                                  (empty-wrap 'value))
                            ellipsis)))
+  (define data-name (hashmap-ref names (empty-wrap 'name)))
+  (define data-value (hashmap-ref names (empty-wrap 'value)))
   (define (test-of form names values)
     (let ((returned (matcher form)))
       (test-equal "names"
@@ -155,6 +179,13 @@
       (test-equal "values"
                   values
                   (hashmap-ref returned (empty-wrap 'value)))))
+  (test-equal "level of name" 2 (car data-name))
+  (test-equal "level of value" 1 (car data-value))
+  (test-assert "name and value have different groups"
+               (not (= (cdr data-name) (cdr data-value))))
+  (test-assert "name group is a subset of value group"
+               (member (cdr data-name)
+                       (hashmap-ref levels (cdr data-value))))
   (test-group "let-values like form"
     (test-of '((("name1" "name2" "name3") "value1")
                (("name4" "name5" "name6") "value2"))
@@ -171,7 +202,7 @@
 
 (define (test-single-literal)
   (define literal-list (list (empty-wrap 'literal)))
-  (define-values (matcher names)
+  (define-values (matcher names levels)
     (compile-pattern literal-list
                      (list (empty-wrap 'literal) (empty-wrap 'x))))
   (test-assert "without literal fails"
@@ -184,7 +215,7 @@
                   (hashmap-ref returned (empty-wrap 'x))))))
 
 (define (test-ignored-pattern)
-  (define-values (matcher names)
+  (define-values (matcher names levels)
     (compile-pattern '()
                      (list (empty-wrap '_) (empty-wrap 'x))))
   (test-equal "names is length 1"
@@ -198,7 +229,7 @@
                 (hashmap-ref returned (empty-wrap 'x)))))
 
 (define (test-matching-a-vector)
-  (define-values (matcher names)
+  (define-values (matcher names levels)
     (compile-pattern (list (empty-wrap 'then))
                      (vector (empty-wrap 'x)
                              ellipsis
diff --git a/test/run.scm b/test/run.scm
index e370a9a..39e4c70 100644
--- a/test/run.scm
+++ b/test/run.scm
@@ -7,6 +7,7 @@
            (test-runner-factory mcgoron-factory)
            (test-runner-current (mcgoron-factory))))
 
+(load "../multisyntax/utils.sld")
 (load "../multisyntax/syntax-object.sld")
 (load "syntax-object.sld")