move tests to their own file; use debruijn form to test alpha equivalence

5 files changed, 121 insertions, 47 deletions

diff --git a/multisyntax/examples/untyped-lambda-calculus.scm b/multisyntax/examples/untyped-lambda-calculus.scm
index 9d87d3b..fc79867 100644
--- a/multisyntax/examples/untyped-lambda-calculus.scm
+++ b/multisyntax/examples/untyped-lambda-calculus.scm
@@ -363,3 +363,25 @@
              loc
              (lexical-location->string loc))))
       (else stx))))
+
+(define (debruijnize env stx free-variables)
+  (let ((stx (unwrap-syntax stx)))
+    (cond
+      ((is? env stx 'lambda)
+       (list 'lambda
+             (debruijnize env
+                          (syntax-cxr '(d d a) stx)
+                          (cons (cons (syntax-cxr '(d a) stx)
+                                      0)
+                                (map (lambda (pair)
+                                       (cons (car pair)
+                                             (+ 1 (cdr pair))))
+                                     free-variables)))))
+      ((and (identifier? stx)
+            (assoc stx free-variables bound-identifier=?))
+       => cdr)
+      ((identifier? stx) (syntax->datum stx))
+      ((pair? stx)
+       (cons (debruijnize env (car stx) free-variables)
+             (debruijnize env (cdr stx) free-variables)))
+      (else stx))))
diff --git a/multisyntax/examples/untyped-lambda-calculus.sld b/multisyntax/examples/untyped-lambda-calculus.sld
index 1076111..b2c03f2 100644
--- a/multisyntax/examples/untyped-lambda-calculus.sld
+++ b/multisyntax/examples/untyped-lambda-calculus.sld
@@ -19,5 +19,5 @@
           (multisyntax syntax-object)
           (multisyntax pattern matcher)
           (multisyntax pattern producer))
-  (export expand transformer? initial-environment alpha)
+  (export expand transformer? initial-environment alpha debruijnize)
   (include "untyped-lambda-calculus.scm"))
\ No newline at end of file
diff --git a/test/examples/untyped-lambda-calculus.scm b/test/examples/untyped-lambda-calculus.scm
new file mode 100644
index 0000000..46f3f60
--- /dev/null
+++ b/test/examples/untyped-lambda-calculus.scm
@@ -0,0 +1,71 @@
+#| 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-syntax test-alpha
+  (syntax-rules ()
+    ((test-alpha name (inputs ...) output)
+
+     (let-values (((global-map expanded-list)
+                   (expand initial-environment
+                           (list (empty-wrap (quote inputs)) ...))))
+       (test-equal name
+                   (map (lambda (term)
+                          (debruijnize global-map term '()))
+                        expanded-list)
+                   (quote output))))))
+
+(define (test-expander)
+  (test-alpha "identity"
+              ((lambda x x))
+              ((lambda 0)))
+  (test-alpha "let-syntax of identifier"
+              ((let-syntax ((λ lambda))
+                 (λ x x)))
+              ((lambda 0)))
+  (test-alpha "lexical renaming of keywords"
+              ((lambda lambda (lambda lambda)))
+              ((lambda (0 0))))
+  (test-alpha "simple define-syntax"
+              ((define-syntax let
+                 (syntax-rules ()
+                   ((let ((name value)) body)
+                    ((lambda name body) value))))
+               (let ((x (f y))) (f x)))
+              (((lambda (f 0)) (f y))))
+  (test-alpha "define-syntax with ellipsis"
+              ((define-syntax let
+                 (syntax-rules ()
+                   ((let ((name value)) body)
+                    ((lambda name body) value))))
+               (define-syntax or
+                 (syntax-rules ()
+                   ((or) false)
+                   ((or x y ...)
+                    (let ((tmp x))
+                      (if tmp tmp (or y ...))))))
+               (or a tmp b))
+              (((lambda (if 0
+                            0
+                            ((lambda (if 0
+                                         0
+                                         ((lambda (if 0
+                                                     0
+                                                     false))
+                                          b))) tmp))) a))))
+
+(define (test-untyped-lambda-calculus)
+  (test-group "untyped lambda calculus"
+    (test-expander)))
+
diff --git a/test/examples/untyped-lambda-calculus.sld b/test/examples/untyped-lambda-calculus.sld
new file mode 100644
index 0000000..6d85eed
--- /dev/null
+++ b/test/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 test)
+  (import (scheme base) (srfi 64)
+          (multisyntax syntax-object) (multisyntax examples untyped-lambda-calculus))
+  (cond-expand
+    (chicken (import (chicken condition)))
+    (else))
+  (export test-untyped-lambda-calculus)
+  (include "untyped-lambda-calculus.scm"))
\ No newline at end of file
diff --git a/test/run.scm b/test/run.scm
index dfcaf97..e6055c0 100644
--- a/test/run.scm
+++ b/test/run.scm
@@ -28,58 +28,16 @@
 #;(test-producers)
 
 (load "../multisyntax/examples/untyped-lambda-calculus.sld")
-(import (multisyntax examples untyped-lambda-calculus)
-        (multisyntax syntax-object))
+(load "examples/untyped-lambda-calculus.sld")
+(import (multisyntax examples untyped-lambda-calculus test))
+(test-untyped-lambda-calculus)
 
-(let-values (((global-map expanded-list)
-              (expand initial-environment (list (empty-wrap '(lambda x x))))))
-  (display (alpha expanded-list)) (newline))
-
-(let-values (((global-map expanded-list)
-              (expand initial-environment
-                      (list (empty-wrap '(let-syntax ((λ lambda))
-                                           (λ x x)))))))
-  (display (alpha expanded-list)) (newline))
-
-(let-values (((global-map expanded-list)
-              (expand initial-environment
-                      (list (empty-wrap '(lambda lambda (lambda lambda)))))))
-  (display (alpha expanded-list)) (newline))
-
-(let-values (((global-map expanded-list)
+#;(let-values (((global-map expanded-list)
               (expand initial-environment
                       (list (empty-wrap '(define I (lambda x x)))
                             (empty-wrap '(I (lambda I I)))))))
   (display (alpha expanded-list)) (newline))
 
-(let-values (((global-map expanded-list)
-              (expand initial-environment
-                      (list (empty-wrap
-                             '(define-syntax let
-                                (syntax-rules ()
-                                  ((let (name value) body)
-                                   ((lambda name body) value)))))
-                            (empty-wrap '(let (x (lambda x x)) (x x)))))))
-  (display (alpha expanded-list)) (newline))
-
-(let-values (((global-map expanded-list)
-              (expand initial-environment
-                      (list (empty-wrap
-                             '(define-syntax let
-                                (syntax-rules ()
-                                  ((let ((name value)) body)
-                                   ((lambda name body) value)))))
-                            (empty-wrap
-                             '(define-syntax or
-                                (syntax-rules ()
-                                  ((or) false)
-                                  ((or x y ...)
-                                   (let ((tmp x))
-                                     (if tmp x (or y ...)))))))
-                            (empty-wrap
-                             '(or a b tmp c d e))))))
-  (display (alpha expanded-list)) (newline))
-
 #;(begin
   (load "examples/untyped-lambda-calculus.sld")
   (import (multisyntax examples untyped-lambda-calculus test))