first pass at a syntax expander for pure LC

6 files changed, 708 insertions, 22 deletions

diff --git a/multisyntax/examples/untyped-lambda-calculus-prelude.scm b/multisyntax/examples/untyped-lambda-calculus-prelude.scm
new file mode 100644
index 0000000..ad9d2a1
--- /dev/null
+++ b/multisyntax/examples/untyped-lambda-calculus-prelude.scm
@@ -0,0 +1,282 @@
+;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; Untyped lambda calculus using normal-order evaluation.
+;;; 
+;;; The following defines a Scheme-like pure untyped curried lambda
+;;; calculus evaluated in normal order. "Pure" means there are only
+;;; functions: numbers, pairs, booleans, etc. are Church encoded.
+;;; Numbers are expanded into Church numerals by the expander.
+
+;;; ;;;;;;;;;;;;;
+;;; Fundamentals
+
+(define-syntax splicing-begin
+  (syntax-rules ()
+    ((_ body ...) (splicing-let-syntax () body ...))))
+
+(define I (lambda x x))
+
+(splicing-let-syntax ((lambda lambda))
+  ;; This binds `lambda` in the global syntatic environment into a
+  ;; local, immutable syntatic environment.
+  (define-syntax begin
+    (syntax-rules ()
+      ((begin) I)
+      ((begin x y ...)
+       ((lambda dummy (begin y ...)) x)))))
+
+(splicing-let-syntax ((%lambda lambda))
+  ;; This binds `%lambda` because `lambda` will be overridden in the
+  ;; global syntatic environment.
+  (define-syntax lambda
+    (syntax-rules ()
+      ((_ (formal1 formal-rest ...) body ...)
+       (lambda formal1 (lambda (formal-rest ...) body ...)))
+      ((_ (formal) body ...)
+       (lambda formal body ...))
+      ((_ formal body ...)
+       (%lambda formal (begin body ...))))))
+
+(define-syntax λ lambda)
+
+(define-syntax let
+  ;; Regular `let`. Named `let` is defined later.
+  (syntax-rules ()
+    ((let () body ...)
+     ((λ (dummy) body ...) I))
+    ((let ((name value) ...) body ...)
+     ((λ (name ...) body ...) value ...))))
+
+(define-syntax let* let)
+
+(define (Y f)
+  ;; Y combinator.
+  (let ((recursor (λ (x) (f (x x)))))
+    (recursor recursor)))
+
+(define-syntax rec
+  ;; Define a recursive function.
+  (syntax-rules ()
+    ((rec (name . formals) body ...)
+     (Y (λ (name . formals) body ...)))))
+
+(define-syntax υ rec)
+
+(splicing-let-syntax ((%let let))
+  ;; Named `let`.
+  (define-syntax let
+    (syntax-rules ()
+      ((let ((name value) ...) body ...)
+       (%let ((name value) ...) body ...))
+      ((let name ((param first-binding) ...) body ...)
+       ((υ (name param ...) body ...)
+        first-binding ...)))))
+
+(define-syntax letrec
+  (syntax-rules ()
+    ((letrec ((name value) ...) body ...)
+     (let ((name (λ (name ...) value)) ...)
+       (let ((name (name name ...)) ...)
+         body ...)))))
+
+(splicing-let-syntax ((%define define))
+  (define-syntax define
+    (syntax-rules ()
+      ((define (name . args) body ...)
+       (define name (rec (name . args) body ...)))
+      ((define name body ...)
+       (%define name (letrec ((name (begin body ...))) name))))))
+
+(define-syntax binary-to-arbitrary
+  ;; Convert a binary procedure to a syntatic procedure of arbitrary
+  ;; arguments.
+  (syntax-rules ()
+    ((_ name binary)
+     (define-syntax name
+       (syntax-rules ...* ()
+         ((_ x) x)
+         ((_ x y ...*) (binary x (name y ...*))))))))
+
+(define-syntax let-lowered
+  (syntax-rules (define)
+    ((_ ((name value) ...) (define d-name d-value ...))
+     (splicing-begin
+      (define d-name (let ((name value) ...) d-value ...))
+      ...))))
+
+;;; Boolean logic. `#t` maps to this definition of true, and `#f` maps to
+;;; this definition of false.
+(define (true x y) x)
+(define (false x y) y)
+(define (not x) (x false true))
+
+(define (binary-and x y) (x y false))
+(binary-to-arbitrary and binary-and)
+
+(define (binary-or x y) (x true y))
+(binary-to-arbitrary or binary-or)
+
+(define (if predicate truthy falsy)
+  (predicate truthy falsy))
+
+(define-syntax cond
+  ;; Simplified cond.
+  (syntax-rules (else)
+    ((_ (predicate expression ...)
+        rest ...)
+     (if predicate
+         (begin expression ...)
+         (case rest ...)))
+    ((_ (else expression ...))
+     (begin expression ...))))
+
+;;; Church numeral operations
+
+(define (S n)
+  (λ (f x) (f (n f x))))
+
+(define (binary+ x y) (x S n))
+(binary-to-arbitrary + binary+)
+
+(define (binary* x y) (λ (f) (m (n f))))
+(binary-to-arbitary * binary*)
+
+(define (expt b n) (n b))
+
+;;; Pairs and lists
+
+(define (cons car cdr)
+  (lambda (f) (f car cdr)))
+(define null false)
+
+(define-syntax list
+  (syntax-rules ()
+    ((list) null)
+    ((list x y ...)
+     (cons x (list y ...)))))
+
+(define-syntax cons*
+  (syntax-rules ()
+    ((cons* x y) (cons x y))
+    ((cons* x y z ...)
+     (cons x (cons* y z ...)))))
+
+(define (car pair) (pair true))
+(define (cdr pair) (pair false))
+
+(define (null? x) (x (λ (h t d) false) true))
+
+(define (fold kons nil list)
+  ;; This is a left-fold: i.e.
+  ;; (kons (kons (... (kons (car list) nil))))
+  ;; 
+  ;; This is the fundamental list iterator that all other list functions
+  ;; are defined with.
+  (if (null? list)
+      nil
+      (fold kons (kons (car list) nil) (cdr list))))
+
+(define (reverse-append list1 list2)
+  (fold cons list2 list1))
+(define (reverse list) (reverse-append list1 null))
+
+(define (fold-right kons nil list)
+  (fold kons nil (reverse list)))
+
+(define (append list1 list2) (fold-right cons list2 list1))
+
+(define (append-n list-of-lists)
+  (fold-right (λ (list acc) (append list acc))
+              null
+              list-of-lists))
+
+(let-lowered ((mapper (λ (car cdr) (cons (f car) cdr))))
+  (define (map-reverse f list) (fold mapper null list))
+  (define (map f list) (fold-right mapper null list)))
+
+(define (any f list)
+  (fold (λ (value previous) (or previous (f value))) false list))
+(define (all f list)
+  (fold (λ (value previous) (and previous (f value))) true list))
+
+(define (length list) (fold (lambda (_ n) (+ n 1)) 0 list))
+
+(define (iota-fold kons nil count start step)
+  ;; `iota` cannot be defined in terms of `fold`s.
+  (if (<= count 0)
+      nil
+      (iota-fold kons
+                 (kons start nil)
+                 (- count 1)
+                 (+ start step)
+                 step)))
+
+(define (reverse-iota count start step)
+  (iota-fold cons null count start step))
+(define (iota count start step)
+  (reverse (reverse-iota count start step)))
+
+(define (make-list n fill)
+  (iota-fold (λ (_ cdr) (cons fill cdr)) null n 0 1))
+
+(define (list-tabulate n init-proc)
+  (iota-fold (λ (i cdr) (cons (init-proc i) cdr)) null n 0 1))
+
+(define (list-tail n list failure)
+  (let ((length (length list)))
+    (if (>= n length)
+        (failure n)
+        (iota-fold (lambda (_ list) list) n 0 1))))
+
+(define (list-ref n list failure)
+  (car (list-tail n list (lambda (n)
+                           (cons (failure n) nil)))))
+
+(define (list-drop list i)
+  (iota-fold (λ (_ cdr) cdr) list i 0 1))
+
+(define (list-take list i)
+  (reverse (list-drop (reverse list) (- (length list) i))))
+
+(define (list-take-right list i)
+  (list-drop list (- (length list) i)))
+
+(define (list-drop-right list i)
+  (list-take list (- (length list) i)))
+
+(define (last list default)
+  (fold (λ (kar knil) kar) default list))
+
+(define (transverse list-of-lists)
+  (let ((init-list (list-tabluate (length (car list-of-lists)) null))
+        (add-element
+         (λ (el state)
+           (let ((n (list-ref state 0))
+                 (acc (list-ref state 1)))
+             (list (+ n 1)
+                   (append (list-take acc n)
+                           (cons el (list-ref acc n))
+                           (list-drop acc (+ n 1))))))))
+    (fold-right (λ (l state)
+                  (fold-right add-element l (list 0 state)))
+                init-list
+                list-of-lists)))
+
+(define (foldn f init list-of-lists)
+  (fold (λ (elements init)
+          (letrec ((loop
+                    (λ (f elements init)
+                      (if (null? elements)
+                          (f init)
+                          (loop (f (car elements)) (cdr elements) init)))))
+            (loop f elements init)))
+        init
+        (transverse list-of-lists)))
+
+(define (list= = l1 l2)
+  (fold-n (λ (e1 e2 result)
+            (cond
+              ((not result) result)
+              ((= e1 e2) true)
+              (else false)))
+          (list l1 l2)))
+
diff --git a/multisyntax/examples/untyped-lambda-calculus.scm b/multisyntax/examples/untyped-lambda-calculus.scm
new file mode 100644
index 0000000..feea5f5
--- /dev/null
+++ b/multisyntax/examples/untyped-lambda-calculus.scm
@@ -0,0 +1,326 @@
+#| 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.
+ |------------------------------------------------------------------------
+ | Example implementation of macros for an untyped lambda calculus.
+ |
+ | Syntax of the core:
+ |
+ |     TERM ::= (lambda ID TERM) | (TERM TERM+) | ID
+ |
+ | where `(TERM1 TERM2 TERM3 TERM4 ...)` is interpreted as
+ | `((TERM1 TERM2) TERM3 TERM4 ...)`.
+ |
+ | Syntax with macros:
+ |
+ | TOPLEVEL ::= (define-syntax ID TFMR)
+ |            | (define ID TERM)
+ |            | (splicing-let-syntax ((ID TFMR) ...) TOPLEVEL ...)
+ |            | (splicing-letrec-syntax ((ID TFMR) ...) TOPLEVEL ...)
+ |            | EXPR
+ | EXPR ::= (let-syntax ((ID TFMR) ...) EXPR)
+ |        | (letrec-syntax ((ID TFMR) ...) EXPR)
+ |        | (lambda ID EXPR)
+ |        | (EXPR EXPR EXPR ...)
+ |        | ID
+ | TFMR ::= ID
+ |        | (let-syntax ((ID TFMR) ...) TFMR)
+ |        | (letrec-syntax ((ID TFMR) ...) TFMR)
+ |        | (syntax-rules ID? (ID ...) ((ID . pattern) PROD) ... )
+ |
+ | The lexical environment is made up of either the symbol `variable`
+ | (meaning that the identifier is some bound variable), a value
+ | satisfying `transformer?` (a syntax transformer), or a symbol for a
+ | primitive syntatic transformer (`'lambda` for `lambda`, etc).
+ |#
+
+(define-record-type <syntax-rules>
+  ;; `clauses` is a list of cons cells, the car of each cell is the matcher
+  ;; and the cdr of each cell is the producer.
+  (wrap-syntax-rules clauses)
+  transformer?
+  (clauses unwrap-syntax-rules))
+
+(define (empty-map) (hashmap bound-identifier-comparator))
+
+(define initial-environment
+  (hashmap bound-identifier-comparator
+           (empty-wrap 'lambda) 'lambda
+           (empty-wrap 'define) 'define
+           (empty-wrap 'define-syntax) 'define-syntax
+           (empty-wrap 'splicing-let-syntax) 'splicing-let-syntax
+           (empty-wrap 'splicing-letrec-syntax) 'splicing-letrec-syntax
+           (empty-wrap 'let-syntax) 'let-syntax
+           (empty-wrap 'letrec-syntax) 'letrec-syntax
+           (empty-wrap 'syntax-rules) 'syntax-rules))
+
+(define (church-numeral stx)
+  ;; Convert the exact non-negative integer `stx` into a Church numeral.
+  (let ((function (generate-identifier 'f))
+        (argument (generate-identifier 'x)))
+    (list (empty-wrap 'lambda)
+          function
+          (list (empty-wrap 'lambda)
+                argument
+                (let loop ((i stx))
+                  (if (zero? i)
+                      argument
+                      (list function
+                            (loop (- i 1)))))))))
+
+(define (on-bindings stx)
+  ;; Given (_ ((name value) ...) body ...), return 
+  ;; 
+  ;; 1. `name ...`,
+  ;; 2. `tmp ...`, the same length as `name ...`, which are the names with
+  ;;    new lexical locations.
+  ;; 3. `value ...`.
+  ;; 4. `body ...`
+  ;; 
+  (let* ((stx (unwrap-list stx))
+         (binders (unwrap-list (syntax-cxr '(d a) stx)))
+         (old-names (map syntax-car binders))
+         (new-lls (generate-lexical-locations old-names)))
+    (values old-names
+            (map (lambda (old-name ll)
+                   (add-substitution old-name old-name ll))
+                 old-names
+                 new-lls)
+            (map (lambda (form) (syntax-cxr '(d a) form))
+                 binders)
+            (syntax-cxr '(d d) stx))))
+
+(define (union-names env new-names tfmrs)
+  ;; Add `new-names` bound to `tfmrs` in `env`, overriding previous
+  ;; bindings.
+  (hashmap-union (alist->hashmap bound-identifier-comparator
+                                 (map cons new-names tfmrs))
+                 env))
+
+(define (is? env stx id)
+  ;; Return true if `stx` in `env` is `eq?` to `id`.
+  (and (identifier? (syntax-car stx))
+       (let ((resolved (hashmap-ref/default env (syntax-car stx) #f)))
+         (eq? resolved id))))
+
+(define (identifier-is-transformer env stx)
+  ;; Returns transformer if `stx` is a syntax-rules transformer in `env`.
+  (cond
+    ((not (identifier? (syntax-car stx))) #f)
+    ((hashmap-ref/default env (syntax-car stx) #f)
+     => (lambda (return)
+          (and (transformer? return) return)))
+    (else #f)))
+
+(define (let-syntax-expander env stx K)
+  ;; Continuation-passing-style expansion of `let-syntax`. Expands the
+  ;; body of the `let-syntax` form using the continuation `K`, with an
+  ;; environment binding the transformers to names as defined by the
+  ;; `let-syntax` declaration.
+  (let*-values (((old-names new-names tfmrs body) (on-bindings stx))
+                ((tfmrs) (map (lambda (stx) (expand-transformer env stx))
+                              tfmrs)))
+    (K (union-names env new-names tfmrs)
+       (add-substitution (syntax-cxr '(a) body)
+                         old-names
+                         new-names))))
+
+(define (letrec-syntax-expander env stx K)
+  ;; CPS expansion of `letrec-syntax`. See `let-syntax-expander`.
+  (let*-values (((old-names new-names tfmrs body) (on-bindings stx))
+                ((tfmrs)
+                 (map (lambda (stx)
+                        (expand-transformer env
+                                            (add-substitution
+                                             stx
+                                             old-names
+                                             new-names)))
+                      tfmrs)))
+    (K (union-names env new-names tfmrs)
+       (add-substitution (syntax-cxr '(a) stx)
+                         old-names
+                         new-names))))
+
+(define (eval-transformer tfmr stx)
+  ;; Try to match each pattern in `tfmr`, and when one matches, call the
+  ;; producer on the matched data.
+  (let loop ((tfmr (unwrap-syntax-rules tfmr)))
+    (if (null? tfmr)
+        (error "no matched pattern" stx tfmr)
+        (let ((matcher (caar tfmr))
+              (producer (cdar tfmr)))
+          (cond
+            ((matcher tfmr) => producer)
+            (else (loop (cdr tfmr))))))))
+
+(define (macro-expand-expander env stx tfmr K)
+  ;; Evaluate the transformer `tfmr` with `stx`, properly adding and
+  ;; removing macro expansion timesteps. Pass the result to `K`, which
+  ;; is a function of one argument (not two like the `let-syntax-expander`
+  ;; procedures).
+  (let ((ts (generate-timestamp)))
+    (K (add-timestamp (eval-transformer tfmr
+                                        (add-timestamp stx ts))
+                      ts))))
+
+(define (expand-expr env stx)
+  ;; TODO: fix function application
+  ;; Expander of expressions (not toplevel statements).
+  (let ((stx (unwrap-syntax stx)))
+    (cond
+      ((and (exact-integer? stx) (positive? stx))
+       (church-numeral stx))
+      ((identifier? stx) stx)
+      ((is? env stx 'lambda)
+       (let* ((bound (syntax-cxr '(d a) stx))
+              (renamed (generate-identifier (syntax->datum bound)))
+              (body (syntax-cxr '(d d a) stx)))
+         (list (empty-wrap 'lambda)
+               renamed
+               (expand-expr
+                (hashmap-adjoin env renamed 'variable)
+                (add-substitution body renamed bound)))))
+      ((is? env stx 'let-syntax)
+       (let-syntax-expander env stx expand-expr))
+      ((is? env stx 'letrec-syntax)
+       (letrec-syntax-expander env stx expand-expr))
+      ((identifier-is-transformer env stx)
+       => (lambda (tfmr)
+            (macro-expand-expander env
+                                   stx
+                                   tfmr
+                                   (lambda (stx)
+                                     (expand-expr env stx)))))
+      ((pair? stx)
+       (cons (expand-expr env (car stx)) (expand-expr env (cdr stx))))
+      (else (error "invalid syntax" stx)))))
+
+(define (expand-syntax-rules env ellipsis literals clauses)
+  ;; Expand a `syntax-rules` transformer and wrap it as a `syntax-rules`
+  ;; object.
+  (define (operate clause)
+    (let*-values (((clause) (unwrap-list clause))
+                  ((matcher bindings _)
+                   (compile-pattern literals
+                                    (list-ref clause 0)
+                                    ellipsis)))
+      (cons matcher (compile-producer literals
+                                      (list-ref clause 1)
+                                      bindings
+                                      ellipsis))))
+  (wrap-syntax-rules (map operate (unwrap-list clauses))))
+
+(define (expand-transformer env stx)
+  (let ((stx (unwrap-syntax stx)))
+    (cond
+      ((identifier? stx)
+       (hashmap-ref env stx (lambda () (error "transformer not found" stx))))
+      ((identifier-is-transformer env stx)
+       => (lambda (tfmr)
+            (macro-expand-expander env
+                                   stx
+                                   tfmr
+                                   (lambda (stx)
+                                     (expand-transformer env stx)))))
+      ((is? env stx 'syntax-rules)
+       (if (identifier? (syntax-cxr '(d a) stx))
+           (expand-syntax-rules env
+                                (syntax-cxr '(d a) stx)
+                                (syntax-cxr '(d d a) stx)
+                                (syntax-cxr '(d d d) stx))
+           (expand-syntax-rules env
+                                #f
+                                (syntax-cxr '(d a) stx)
+                                (syntax-cxr '(d d) stx))))
+      ((is? env stx 'let-syntax)
+       (let-syntax-expander env stx expand-transformer))
+      ((is? env stx 'letrec-syntax)
+       (letrec-syntax-expander env stx expand-transformer))
+      (else (error "invalid syntax for transformer" stx)))))
+
+(define (accumulate-splicing globalenv lexenv body)
+  ;; Expand each toplevel declaraion in `body` with the lexical environment
+  ;; `lexenv` with an accumulated global environment `globalenv`.
+  ;; 
+  ;; Returns `(values globalenv acc)` which is the expanded body clauses
+  ;; and the accumulated global environment.
+  (let loop ((globalenv globalenv)
+             (iter (unwrap-list body))
+             (acc '()))
+    (if (null? iter)
+        (values globalenv (reverse acc))
+        (let-values (((globalenv next)
+                      (expand-toplevel globalenv lexenv (car iter))))
+          (loop globalenv (cdr iter) (append-reverse next acc))))))
+
+(define (expand-toplevel globalenv lexenv stx)
+  ;; Expands toplevel expressions with accumulated global environment
+  ;; `globalenv`.
+  (let ((stx (unwrap-syntax stx))
+        (env (hashmap-union lexenv globalenv)))
+    (cond
+      ((is? env stx 'define-syntax)
+       (let* ((name (syntax-cxr '(d a) stx))
+              (tfmr (expand-transformer env (syntax-cxr '(d d a) stx))))
+         (values (hashmap-adjoin globalenv name tfmr) '())))
+      ((is? env stx 'splicing-let-syntax)
+       (let*-values (((old-names new-names tfmrs body)
+                      (on-bindings stx))
+                     ((tfmrs) (map (lambda (stx)
+                                     (expand-transformer env stx))
+                                   tfmrs)))
+         (accumulate-splicing globalenv
+                              (union-names lexenv new-names tfmrs)
+                              body)))
+      ((is? env stx 'splicing-letrec-syntax)
+       (let*-values (((old-names new-names tfmrs body) (on-bindings stx))
+                     ((tfmrs) (map (lambda (stx)
+                                    (expand-transformer env
+                                                        (add-substitution
+                                                         stx
+                                                         old-names
+                                                         new-names)))
+                                  tfmrs)))
+         (accumulate-splicing globalenv
+                              (union-names lexenv new-names tfmrs)
+                              body)))
+      ((is? env stx 'define)
+       (let* ((name (syntax-cxr '(d a) stx))
+              (expanded-value (expand-expr env (syntax-cxr '(d d a) stx))))
+         (values (hashmap-adjoin globalenv name 'variable)
+                 (list (list (empty-wrap 'define)
+                             name
+                             expanded-value)))))
+      ((identifier-is-transformer env stx)
+       => (lambda (tfmr)
+            (macro-expand-expander env
+                                   stx
+                                   tfmr
+                                   (lambda (stx)
+                                     (expand-toplevel globalenv lexenv stx)))))
+      (else (values globalenv
+                    (list
+                     (expand-expr (hashmap-union lexenv globalenv) stx)))))))
+
+(define (expand initenv stx)
+  ;; Expand `stx`, which is a list of syntax forms, into a list of syntax
+  ;; forms, with initial environment `initenv`. Returns the new environment
+  ;; and the list of expanded forms.
+  (define (fold globalenv stxlist acc)
+    (if (null? stxlist)
+        (values globalenv (reverse acc))
+        (let-values (((globalenv next)
+                      (expand-toplevel globalenv (empty-map) (car stxlist))))
+          (fold globalenv (cdr stxlist) (append-reverse next acc)))))
+  (fold initenv (unwrap-list stx) '()))
+
diff --git a/multisyntax/examples/untyped-lambda-calculus.sld b/multisyntax/examples/untyped-lambda-calculus.sld
new file mode 100644
index 0000000..2ace753
--- /dev/null
+++ b/multisyntax/examples/untyped-lambda-calculus.sld
@@ -0,0 +1,23 @@
+#| 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 examples untyped-lambda-calculus)
+  (import (scheme base) (scheme write)
+          (srfi 1) (srfi 146 hash)
+          (multisyntax syntax-object)
+          (multisyntax pattern matcher)
+          (multisyntax pattern producer))
+  (export expand transformer? initial-environment)
+  (include "untyped-lambda-calculus.scm"))
\ No newline at end of file
diff --git a/multisyntax/syntax-object.scm b/multisyntax/syntax-object.scm
index c55b4e1..2bd2060 100644
--- a/multisyntax/syntax-object.scm
+++ b/multisyntax/syntax-object.scm
@@ -66,6 +66,12 @@
   (raw-lexical-location symbol
                         (generate-unique-integer)))
 
+(define (generate-lexical-locations list)
+  (do ((acc (list-accumulator))
+       (list (unwrap-list list) (cdr list)))
+      ((null? list) (acc (eof-object)))
+    (acc (generate-lexical-location (syntax->datum (car list))))))
+
 (define (lexical-location->string ll)
   (string-append (symbol->string (lexical-location->symbol ll))
                  "."
@@ -209,7 +215,6 @@
       ((mapping-ref/default invenv location-from '())
        => (lambda (lst)
             (for-each (lambda (maps-to-location-from)
-                        (display "a\n")
                         (set! env (mapping-set
                                    env
                                    maps-to-location-from
@@ -234,6 +239,12 @@
   ;; 
   ;; Otherwise update `environment` and `inverse-environment` with the
   ;; new locations.
+  ;; 
+  ;; If `location-to` is a list, then `id` must be a list too. Each
+  ;; pair `(id location-to)` is added as a substitution.
+  ;; 
+  ;; If `location-to` is an identifier, the location that it resolves to
+  ;; is added as a substitution.
   (cond
     ((pair? stx) (cons (add-substitution (car stx)
                                          id
@@ -245,19 +256,25 @@
                                stx))
     ((self-syntax? stx) stx)
     (else
-     (let ((timestamps (wrap->timestamps stx)))
-       (if (not (set=? timestamps (wrap->timestamps id)))
-           stx
-           (add-timestamps/same-wrap stx id location-to))))))
+     (let operate ((id id)
+                   (location-to location-to)
+                   (stx stx))
+       (cond
+         ((pair? location-to)
+          (fold operate stx id location-to))
+         ((identifier? location-to)
+          (operate id (resolve location-to) stx))
+         ((not (set=? (wrap->timestamps stx) (wrap->timestamps id)))
+          stx)
+         (else
+          (add-timestamps/same-wrap stx id location-to)))))))
 
 (define (generate-unique-symbol)
   ;; Tries as best as possible to generate a unique symbol. Not read/write
   ;; invariant. An actual implementation of this procedure would require
   ;; implementation support.
   (string->symbol
-   (string-append "gensym."
-                  (number->string
-                   (generate-unique-integer)))))
+   (string-append "gensym." (number->string (generate-unique-integer)))))
 
 (define (identifier-lexically-bound? id)
   ;; Returns true if `id` was bound by some lexical construct. Returns
@@ -279,11 +296,12 @@
 
 (define (generate-temporaries lst)
   ;; Generate a list of identifiers from `generate-identifier`.
-  (let loop ((lst (unwrap-syntax lst))
-             (acc '()))
-    (if (null? lst)
-        '()
-        (loop (unwrap-syntax (cdr list)) (cons (generate-identifier) acc)))))
+  (do ((acc (list-accumulator))
+       (lst (unwrap-list lst) (cdr lst)))
+      ((null? lst) (acc (eof-object)))
+    (if (identifier? (car lst))
+        (acc (generate-identifier (syntax->datum (car lst))))
+        (acc (generate-identifier)))))
 
 (define (symbolic-identifier=? id1 id2)
   ;; Returns true if the underlying symbol of each identifier is the same.
@@ -415,3 +433,22 @@
     ((self-syntax? datum) datum)
     ((if-contains-wrap operate datum) => values)
     (else (push-wrap context-id datum))))
+
+(define (syntax-cxr list stx)
+  (if (null? list)
+      stx
+      (let ((stx (unwrap-syntax stx)))
+        (case (car list)
+          ((a) (syntax-cxr (cdr list) (car stx)))
+          ((d) (syntax-cxr (cdr list) (cdr stx)))
+          (else (error "invalid accessor" list stx))))))
+
+(define (syntax-car stx) (syntax-cxr '(a) stx))
+(define (syntax-cdr stx) (syntax-cxr '(d) stx))
+
+(define (unwrap-list stx)
+  (let ((stx (unwrap-syntax stx)))
+    (if (pair? stx)
+        (cons (car stx) (unwrap-syntax (cdr stx)))
+        stx)))
+
diff --git a/multisyntax/syntax-object.sld b/multisyntax/syntax-object.sld
index f013885..31060b4 100644
--- a/multisyntax/syntax-object.sld
+++ b/multisyntax/syntax-object.sld
@@ -18,19 +18,20 @@
 (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 1) (srfi 26) (srfi 113) (srfi 128) (srfi 133) (srfi 146) (srfi 158) (srfi 228)
           (multisyntax utils))
-  (export generate-lexical-location
-          lexical-location->string
-          lexical-location-comparator
-          environment-key-comparator
-          bound-identifier-comparator
+  (export generate-lexical-location generate-lexical-locations
+          lexical-location->string lexical-location-comparator
+          environment-key-comparator bound-identifier-comparator
           ;; Misc. predicates
           self-syntax? syntax?
           ;; Operations on wraps
           generate-timestamp empty-wrap add-timestamp add-substitution
           wrap->timestamps resolve
           identifier-lexically-bound?
+          ;; Non-standard procedures that can be defined in terms of
+          ;; Macrological Fascile procedures
+          syntax-cxr syntax-car syntax-cdr unwrap-list
           ;; Standard operations
           symbolic-identifier=? free-identifier=? bound-identifier=?
           identifier?
diff --git a/test/run.scm b/test/run.scm
index b0b03bc..23d3af2 100644
--- a/test/run.scm
+++ b/test/run.scm
@@ -14,15 +14,32 @@
 (import (rename (multisyntax syntax-object test)
                 (test test-syntax-object)))
 
-(test-syntax-object)
+#;(test-syntax-object)
 
 (load "../multisyntax/pattern/internal.sld")
 (load "../multisyntax/pattern/matcher.sld")
 (load "pattern/matcher.sld")
 (import (multisyntax pattern matcher test))
-(test-patterns)
+#;(test-patterns)
 
 (load "../multisyntax/pattern/producer.sld")
 (load "pattern/producer.sld")
 (import (multisyntax pattern producer test))
-(test-producers)
+#;(test-producers)
+
+(load "../multisyntax/examples/untyped-lambda-calculus.sld")
+(import (multisyntax examples untyped-lambda-calculus)
+        (multisyntax syntax-object))
+
+#;(let-values (((global-map expanded-list)
+              (expand initial-environment (list (empty-wrap '(lambda x x)))))))
+
+(define-values (global-map expanded-list)
+  (expand initial-environment
+          (list (empty-wrap '(let-syntax ((λ lambda))
+                               (λ x x))))))
+
+#;(begin
+  (load "examples/untyped-lambda-calculus.sld")
+  (import (multisyntax examples untyped-lambda-calculus test))
+  (test-untyped-lambda-calculus))