move common procedures for matcher and producer to internal

8 files changed, 183 insertions, 88 deletions

diff --git a/README.md b/README.md
index b69328b..677ed20 100644
--- a/README.md
+++ b/README.md
@@ -1,5 +1,12 @@
 # Multisyntax
 
-An implementation of `syntax-rules` using marks and substitutions
-as in `syntax-case`. This library can be thought of as "first-order
-`syntax-case`".
+Implementation of a fragment of the Macrological Fascicle using the
+[Hieb, Dybvig, and Bruggeman][1] algorithm.
+
+The goal of this library is to provide a portable core for
+
+* Future implementations of Scheme with full `syntax-case`
+* Hosted languages inside of Scheme whose macros are written in Scheme
+  (outside of the hosted language)
+
+[1]: https://legacy.cs.indiana.edu/~dyb/pubs/LaSC-5-4-pp295-326.pdf
diff --git a/multisyntax/pattern/internal.scm b/multisyntax/pattern/internal.scm
new file mode 100644
index 0000000..2753459
--- /dev/null
+++ b/multisyntax/pattern/internal.scm
@@ -0,0 +1,120 @@
+ #| 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.
+ |-----------------------------------------------
+ | Procedures shared by matcher and producer.
+ |#
+
+;;; ;;;;;;;;
+;;; Ellipsis and literals
+;;; ;;;;;;;;
+
+(define ... (empty-wrap '...))
+
+(define (contains-as-free-identifier set key)
+  ;; Returns an identifier if `key` is `free-identifier=?` to any
+  ;; identifier in `set`. Otherwise return `#f`.
+  (cond
+    ((member key (set->list set) free-identifier=?) => car)
+    (else #f)))
+
+(define (generate-ellipsis-procedure ellipsis literals)
+  ;; Generates a procedure of one argument that returns `#t` if the
+  ;; argument is an ellipsis for the purposes of the current matcher.
+  ;; 
+  ;; If `ellipsis` is `#f`, then the `ellipsis` is the auxillary global
+  ;; `...`, and matching is done with `free-identifier=?`.
+  ;; 
+  ;; If `ellipsis` is some identifier, then matching is done against it
+  ;; with `bound-identifier=?`.
+  ;; 
+  ;; If either ellipsis is in the literals, then there is no repeating
+  ;; patterns and the returned procedure returns `#f`.
+  ;; 
+  ;; This procedure is only runs inside of a parameterization, so
+  ;; `literals` must be passed explicitly and `literal?` cannot be used.
+  (define always-false-case
+    (lambda (identifier) #f))
+  (define matches-free-identifier
+    (lambda (identifier)
+      (and (identifier? identifier)
+           (free-identifier=? identifier ...))))
+  (define matches-passed-ellipsis
+    (lambda (identifier)
+      (and (identifier? identifier)
+           (bound-identifier=? identifier ...))))
+  (cond
+    ((and (not ellipsis)
+          (contains-as-free-identifier literals ...))
+     always-false-case)
+    ((not ellipsis) matches-free-identifier)
+    ((set-contains? literals ellipsis) always-false-case)
+    (else matches-passed-ellipsis)))
+
+(define (convert-to-literals-set literals)
+  ;; Convert some arguments into a set of literals.
+  (cond
+    ((set? literals) literals)
+    ((null? literals) (set bound-identifier-comparator))
+    ((pair? literals)
+     (list->set bound-identifier-comparator literals))
+    (else (error "invalid literals" literals))))
+
+(define matcher-input
+  ;; Parameter for the inputs to the pattern matcher.
+  ;; 
+  ;; The inputs are a vector of #(ellipsis literals), where `ellipsis`
+  ;; is either #f or an identifier which binds the ellipsis, and
+  ;; `literals` is a list or set of identifiers which are the literals
+  ;; for the pattern matcher.
+  ;; 
+  ;; The values of the parameter is a vector #(ellipsis-procedure literals),
+  ;; where `ellipsis-procedure` is a procedure of one argument that returns
+  ;; true if the passed argument is a real ellipsis and 0 otherwise. The
+  ;; value `literals` is a set of literals, disambiguated by `bound-identifier=?`.
+  (make-parameter #f
+                  (lambda (inputs)
+                    (if inputs
+                        (let ((literals-set
+                               (convert-to-literals-set
+                                (vector-ref inputs 1))))
+                          (vector (generate-ellipsis-procedure
+                                   (cond
+                                     ((vector-ref inputs 0) => values)
+                                     (else ...))
+                                   literals-set)
+                                  literals-set))
+                        #f))))
+
+(define (ellipsis-procedure)
+  (vector-ref (matcher-input) 0))
+
+(define (literals) (vector-ref (matcher-input) 1))
+
+(define (actual-ellipsis? identifier)
+  ;; Returns `#t` if `id` is an ellipsis, and `#f` otherwise.
+  ((ellipsis-procedure) identifier))
+
+(define (is-ellipsis-list patcdr)
+  ;; Returns (values has-ellipsis? next). `has-ellipsis?` is true if the
+  ;; pair is an ellipsis pattern, and false otherwise. `next` is the next
+  ;; pattern that will be matched.
+  (if (null? patcdr)
+      (values #f patcdr)
+      (let ((patcadr (unwrap-syntax (car patcdr))))
+        (if (actual-ellipsis? patcadr)
+            (values #t (cdr patcdr))
+            (values #f patcdr)))))
+
+(define (literal? identifier)
+  (set-contains? (literals) identifier))
diff --git a/multisyntax/pattern/internal.sld b/multisyntax/pattern/internal.sld
new file mode 100644
index 0000000..0199ced
--- /dev/null
+++ b/multisyntax/pattern/internal.sld
@@ -0,0 +1,22 @@
+#| 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.
+ |-----------------------------------------------
+ | Procedures shared by matcher and producer.
+ |#
+
+(define-library (multisyntax pattern internal)
+  (import (scheme base) (srfi 113) (multisyntax syntax-object))
+  (export matcher-input
+          is-ellipsis-list actual-ellipsis? literal?)
+  (include "internal.scm"))
diff --git a/multisyntax/pattern/matcher.scm b/multisyntax/pattern/matcher.scm
index ea9cde3..6c8d92c 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.
@@ -85,7 +85,6 @@
 ;;; syntax keywords (identifiers without timestamps and without an
 ;;; environment).
 
-(define ... (empty-wrap '...))
 (define _ (empty-wrap '_))
 
 ;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;
@@ -100,15 +99,6 @@
   ;; Current ellipsis nesting level.
   (make-parameter 0))
 
-(define actual-ellipsis-procedure
-  ;; Parameter object that contains a procedure to determine if an
-  ;; identifier acts as the ellipsis.
-  (make-parameter #f))
-
-(define literals-parameter
-  ;; Parameter object that contains the literals.
-  (make-parameter #f))
-
 (define bindings
   ;; Parameter object that contains a box that contains a mapping from
   ;; identifiers to their nesting level.
@@ -167,10 +157,6 @@
       (let ((returned (apply procedure args)))
         (values returned (unbox (bound-here)))))))
 
-(define (actual-ellipsis? identifier)
-  ;; Returns `#t` if `id` is an ellipsis, and `#f` otherwise.
-  ((actual-ellipsis-procedure) identifier))
-
 (define (add-name! identifier)
   ;; Add `identifier` to the name map with the current ellipsis nesting
   ;; level. If the identifier is added inside of an ellipses nesting level,
@@ -189,43 +175,6 @@
                    identifier
                    (cons (nesting-level) (ellipsis-group))))))
 
-(define (contains-as-free-identifier set key)
-  ;; Returns an identifier if `key` is `free-identifier=?` to any
-  ;; identifier in `set`. Otherwise return `#f`.
-  (cond
-    ((member key (set->list set) free-identifier=?) => car)
-    (else #f)))
-
-(define (generate-ellipsis-procedure literals ellipsis)
-  ;; Generates a procedure of one argument that returns `#t` if the
-  ;; argument is an ellipsis for the purposes of the current matcher.
-  ;; 
-  ;; If `ellipsis` is `#f`, then the `ellipsis` is the auxillary global
-  ;; `...`, and matching is done with `free-identifier=?`.
-  ;; 
-  ;; If `ellipsis` is some identifier, then matching is done against it
-  ;; with `bound-identifier=?`.
-  ;; 
-  ;; If either ellipsis is in the literals, then there is no repeating
-  ;; patterns and the returned procedure returns `#f`.
-  (define always-false-case
-    (lambda (identifier) #f))
-  (define matches-free-identifier
-    (lambda (identifier)
-      (and (identifier? identifier)
-           (free-identifier=? identifier ...))))
-  (define matches-passed-ellipsis
-    (lambda (identifier)
-      (and (identifier? identifier)
-           (bound-identifier=? identifier ...))))
-  (cond
-    ((and (not ellipsis)
-          (contains-as-free-identifier literals ...))
-     always-false-case)
-    ((not ellipsis) matches-free-identifier)
-    ((set-contains? literals ellipsis) always-false-case)
-    (else matches-passed-ellipsis)))
-
 (define compile-pattern
   ;; Compile `stx` into a pattern matcher with `ellipsis` as the ellipsis
   ;; identifier and the set of `literals`.
@@ -235,23 +184,14 @@
   (case-lambda
     ((literals stx) (compile-pattern literals stx #f))
     ((literals stx ellipsis)
-     (let ((literals
-            (cond
-              ((set? literals) literals)
-              ((null? literals) (set bound-identifier-comparator))
-              ((pair? literals)
-               (list->set bound-identifier-comparator literals))
-              (else (error "invalid literals" literals)))))
-       (parameterize ((nesting-level 0)
-                      (actual-ellipsis-procedure
-                       (generate-ellipsis-procedure literals ellipsis))
-                      (literals-parameter literals)
-                      (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))
-                   (unbox (ellipsis-group-map)))))))))
+     (parameterize ((nesting-level 0)
+                    (matcher-input (vector ellipsis literals))
+                    (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))
+                 (unbox (ellipsis-group-map))))))))
 
 ;;; ;;;;;;;;;;;;;;;;;;;;
 ;;; Helper functions
@@ -260,9 +200,6 @@
 (define (empty-map)
   (hashmap bound-identifier-comparator))
 
-(define (literal? identifier)
-  (set-contains? (literals-parameter) identifier))
-
 (define (merge-names oldnames newnames)
   ;; newnames is the patterns matched in an ellipsis expression. Append
   ;; each to the lists in `oldnames` associated with each name and return
@@ -325,17 +262,6 @@
             (compile-ellipsis patcar pat-next)
             (compile-actual-pair patcar pat-next)))))
 
-(define (is-ellipsis-list patcdr)
-  ;; Returns (values has-ellipsis? next). `has-ellipsis?` is true if the
-  ;; pair is an ellipsis pattern, and false otherwise. `next` is the next
-  ;; pattern that will be matched.
-  (if (null? patcdr)
-      (values #f patcdr)
-      (let ((patcadr (unwrap-syntax (car patcdr))))
-        (if (actual-ellipsis? patcadr)
-            (values #t (cdr patcdr))
-            (values #f patcdr)))))
-
 (define (compile-ellipsis patcar patcddr)
   ;; Compile an ellipsis pattern that matches `patcar` zero or more times
   ;; and then must match `patcddr`.
diff --git a/multisyntax/pattern/matcher.sld b/multisyntax/pattern/matcher.sld
index 3eef7b6..7a03dad 100644
--- a/multisyntax/pattern/matcher.sld
+++ b/multisyntax/pattern/matcher.sld
@@ -16,7 +16,7 @@
 (define-library (multisyntax pattern matcher)
   (import (scheme base) (scheme write) (scheme case-lambda)
           (srfi 26) (srfi 111) (srfi 113) (srfi 146 hash) (srfi 197)
-          (multisyntax utils)
+          (multisyntax utils) (multisyntax pattern internal)
           (only (multisyntax syntax-object)
                 identifier? bound-identifier=? free-identifier=?
                 unwrap-syntax
diff --git a/multisyntax/syntax-object.scm b/multisyntax/syntax-object.scm
index d321873..d3058b5 100644
--- a/multisyntax/syntax-object.scm
+++ b/multisyntax/syntax-object.scm
@@ -13,6 +13,23 @@
  | limitations under the License.
  |------------------------------------------------------------------------
  | Hygenic syntax transformer based on Dybvig, Hieb, and Bruggeman 1992.
+ | "Syntax objects" are Scheme data that contain a set of "marks" and
+ | "substitutions," also called "timestamps" and a "lexical environment."
+ |
+ | Marks are used to color data that is returned by syntax transformers
+ | that was not part of the input of the transformer. Substitutions are
+ | used to lazy convert bound identifiers into new bound identifiers.
+ |
+ | This library implements Chapter 3 of the Macrological Fascicle.
+ | Whats missing?
+ |
+ | * A full implementation of `identifier-defined?`, `define-property`, and
+ |   `identifier-properties`, because global scope is not stored inside of
+ |   the syntax object address store.
+ |   For hosted systems, use a hashmap with `bound-identifier-comparator`.
+ |   A hashmap has better garbage collection properties.
+ | * Macros like `quote-syntax`, because they would be difficult to write
+ |   purely in `syntax-rules`.
  |#
 
 ;;; ;;;;;;;;;;
@@ -46,7 +63,8 @@
    (lambda (x) (number-hash (lexical-location->unique-id x)))))
 
 (define (generate-lexical-location symbol)
-  (raw-lexical-location symbol (generate-unique-integer)))
+  (raw-lexical-location symbol
+                        (generate-unique-integer)))
 
 (define (lexical-location->string ll)
   (string-append (symbol->string (lexical-location->symbol ll))
diff --git a/multisyntax/syntax-object.sld b/multisyntax/syntax-object.sld
index e3df648..f013885 100644
--- a/multisyntax/syntax-object.sld
+++ b/multisyntax/syntax-object.sld
@@ -30,6 +30,7 @@
           ;; Operations on wraps
           generate-timestamp empty-wrap add-timestamp add-substitution
           wrap->timestamps resolve
+          identifier-lexically-bound?
           ;; Standard operations
           symbolic-identifier=? free-identifier=? bound-identifier=?
           identifier?
diff --git a/test/run.scm b/test/run.scm
index 39e4c70..0b0e9d9 100644
--- a/test/run.scm
+++ b/test/run.scm
@@ -16,6 +16,7 @@
 
 (test-syntax-object)
 
+(load "../multisyntax/pattern/internal.sld")
 (load "../multisyntax/pattern/matcher.sld")
 (load "pattern/matcher.sld")
 (import (multisyntax pattern matcher test))