expand untyped lambda calculus prelude, fix custom ellipses in syntax-rulesHEAD master

The evaluator is currently very slow because it is substituting all free variables at define-time. Should change to a custom weak-normal-form evaluator.
author: Peter McGoron 2025-07-10 17:42:37 -0400
committer: Peter McGoron 2025-07-10 17:42:37 -0400
commit: 8b77b52b3ed30e2849a5fb6c0758df4880e60897 (patch)
tree: 02e41998803fe569a61920be1bb2ab5be43ead43 /multisyntax/examples
parent: add display-no-eval for debugging (diff)
2 files changed, 185 insertions, 32 deletions
diff --git a/multisyntax/examples/untyped-lambda-calculus-prelude.scm b/multisyntax/examples/untyped-lambda-calculus-prelude.scm
index b32dc39..f37ab53 100644
--- a/multisyntax/examples/untyped-lambda-calculus-prelude.scm
+++ b/multisyntax/examples/untyped-lambda-calculus-prelude.scm
@@ -85,7 +85,7 @@
   (define-syntax define
     (syntax-rules ()
       ((define (name . args) body ...)
-       (define name (rec (name . args) body ...)))
+       (%define name (rec (name . args) body ...)))
       ((define name body)
        (%define name (Y (λ (name) body)))))))
 
@@ -93,9 +93,163 @@
 
 (define %true (λ (x y) x))
 (define %false (λ (x y) y))
+(define (%and x y) (x y x))
+(define (%or x y) (x x y))
 
 (define (%cons car cdr) (λ selector (selector car cdr)))
 (define (%car value) (value %true))
 (define (%cdr value) (value %false))
 
-(define %zero (%cons %true %zero))
+(define %zero (%cons %true I))
+(define (%succ n) (%cons %false n))
+(define %zero? %car)
+(define (%pred n)
+  ((%zero? n) %zero (%cdr n)))
+
+(define (%= n m)
+  ((%and (%zero? n) (%zero? m))
+   %true
+   ((%or (%zero? n) (%zero? m))
+    %false
+    (%= (%pred n) (%pred m)))))
+
+;;; Typed objects
+
+(define (error payload) (%cons %zero payload))
+
+(define boolean-tag (%succ %zero))
+(define true (%cons boolean-tag %true))
+(define false (%cons boolean-tag %false))
+
+(define (if precondition on-true on-false)
+  (let ((tag-of-precondition (%car precondition)))
+    ((%= tag-of-precondition boolean-tag)
+     ((%cdr precondition) on-true on-false)
+     (error boolean-tag))))
+
+(define (predicate-for-tag tag)
+  (λ (value) (%cons boolean-tag (%= (%car value) tag))))
+
+(define boolean? (predicate-for-tag boolean-tag))
+(define error-object? (predicate-for-tag %zero))
+
+(define-syntax define-record-type
+  (syntax-rules ()
+    ((_ tag constructor predicate (name accessor) ...)
+     (splicing-begin
+      (define predicate (predicate-for-tag tag))
+      (define (constructor name ...)
+        (%cons tag (λ selector (selector name ...))))
+      (define (accessor value)
+        (if (predicate value)
+            ((%cdr value) (λ (name ...) name))
+            (error tag)))
+      ...))))
+
+(define pair-tag (%succ (%succ %zero)))
+(define-record-type pair-tag
+  cons
+  pair?
+  (car car) (cdr cdr))
+
+(define null-tag (%succ (%succ (%succ %zero))))
+(define null (%cons null-tag I))
+(define null? (predicate-for-tag null-tag))
+
+;;; Boolean operations
+
+(define (truthy? x)
+  (if (boolean? x)
+      x
+      true))
+
+(define (or2 x y)
+  (if (truthy? x)
+      x
+      (if (truthy? y)
+          y
+          false)))
+
+(define (and2 x y)
+  (if (truthy? x)
+      (if (truthy? y)
+          y
+          false)
+      false))
+
+(define-syntax binary-to-arbitrary
+  (syntax-rules ()
+    ((_ name base-case binary)
+     (define-syntax name
+       (syntax-rules ...* ()
+         ((_) base-case)
+         ((_ x y ...*) (binary x (name y ...*))))))))
+
+(binary-to-arbitrary or false or2)
+(binary-to-arbitrary and true and2)
+
+(define (not x)
+  (if (truthy? x)
+      false
+      true))
+
+(define-syntax when
+  (syntax-rules ()
+    ((_ predicate body)
+     (if predicate
+         body
+         (error boolean-tag)))))
+
+(define-syntax cond
+  (syntax-rules (else)
+    ((_ (else body)) body)
+    ((_ (predicate) rest ...)
+     (or predicate (cond rest ...)))
+    ((_ (predicate body) rest ...)
+     (if predicate body (cond rest ...)))))
+
+;;; Numbers
+
+(define natural-tag (%succ (%succ (%succ (%succ %zero)))))
+(define-record-type natural-tag
+  %natural
+  natural?
+  (repr natural->repr))
+
+(define zero (%natural null))
+(define (zero? n)
+  (when (natural? n)
+    (null? (natural->repr n))))
+
+(define (succ n)
+  (when (natural? n)
+    (%natural (cons null (natural->repr n)))))
+
+(define (pred n)
+  (when (natural? n)
+    (let ((value (natural->repr n)))
+      (if (null? n)
+          (%natural n)
+          (%natural (cdr n))))))
+
+(define (+bin x y)
+  (when (and (natural? x) (natural? y))
+    (if (zero? y)
+        x
+        (+bin (succ x) (pred y)))))
+(binary-to-arbitrary + zero +bin)
+
+(define (-bin x y)
+  (when (and (natural? x) (natural? y))
+    (if (zero? y)
+        x
+        (-bin (pred x) (pred y)))))
+(binary-to-arbitrary - zero -bin)
+
+(define (*bin x y)
+  (when (and (natural? x) (natural? y))
+    (if (zero? y)
+        zero
+        (+bin x (*bin x (pred y))))))
+(binary-to-arbitrary * (succ zero) *bin)
+
diff --git a/multisyntax/examples/untyped-lambda-calculus.scm b/multisyntax/examples/untyped-lambda-calculus.scm
index 07f09ff..8e2d24d 100644
--- a/multisyntax/examples/untyped-lambda-calculus.scm
+++ b/multisyntax/examples/untyped-lambda-calculus.scm
@@ -128,18 +128,16 @@
   ;; 3. `value ...`.
   ;; 4. `body ...`
   ;; 
-  (let* ((stx (unwrap-list stx))
-         (binders (unwrap-list (syntax-cxr '(d a) stx)))
-         (old-names (map syntax-car binders))
+  (let* ((binders (syntax-list-ref stx 1))
+         (old-names (syntax-list-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))))
+            (syntax-list-map (lambda (old-name ll)
+                               (add-substitution old-name old-name ll))
+                             old-names
+                             new-lls)
+            (syntax-list-map (lambda (form) (syntax-list-ref form 1)) binders)
+            (syntax-list-tail stx 2))))
 
 (define (set-names-to-transformers! new-names tfmrs)
   ;; Set the lexical location values of `new-names` to each transformer
@@ -178,7 +176,7 @@
   ;; producer on the matched data.
   (let loop ((tfmr (unwrap-syntax-rules tfmr)))
     (if (null? tfmr)
-        (error "no matched pattern" name stx tfmr)
+        (error "no matched pattern" name stx (syntax->datum stx) tfmr)
         (let ((matcher (caar tfmr))
               (producer (cdar tfmr)))
           (cond
@@ -247,11 +245,10 @@
   ;; Expand a `syntax-rules` transformer and wrap it as a `syntax-rules`
   ;; object.
   (define (operate clause)
-    (let*-values (((clause) (unwrap-list clause))
-                  ((literals) (unwrap-list literals))
+    (let*-values (((literals) (unwrap-list literals))
                   ((matcher bindings _)
                    (compile-pattern literals
-                                    (list-ref clause 0)
+                                    (syntax-list-ref clause 0)
                                     ellipsis))
                   ((bindings)
                    (hashmap-map (lambda (key value)
@@ -259,11 +256,10 @@
                                 bound-identifier-comparator
                                 bindings)))
       (cons matcher (compile-producer literals
-                                      (list-ref clause 1)
+                                      (syntax-list-ref clause 1)
                                       bindings
                                       ellipsis))))
-  (let ((clauses (unwrap-list clauses)))
-    (wrap-syntax-rules (map operate clauses))))
+  (wrap-syntax-rules (syntax-list-map operate clauses)))
 
 (define (expand-transformer env stx)
   ;; Expand a transformer.
@@ -286,13 +282,13 @@
                                    (cut expand-transformer <> stx))))
       ((is? env stx 'syntax-rules)
        (let ((stx (unwrap-list stx)))
-         (if (identifier? (syntax-cxr '(d a) stx))
-             (expand-syntax-rules (syntax-cxr '(d a) stx)
-                                  (syntax-cxr '(d d a) stx)
-                                  (syntax-cxr '(d d d) stx))
+         (if (identifier? (syntax-list-ref stx 1))
+             (expand-syntax-rules (syntax-list-ref stx 1)
+                                  (syntax-list-ref stx 2)
+                                  (syntax-list-tail stx 3))
              (expand-syntax-rules #f
-                                  (syntax-cxr '(d a) stx)
-                                  (syntax-cxr '(d d) stx)))))
+                                  (syntax-list-ref stx 1)
+                                  (syntax-list-tail stx 2)))))
       ;; Although one could use splicing-let-syntax and splicing-letrec-syntax
       ;; to achieve similar behavior, the splicing variants would not have the
       ;; name bound during their expansion.
@@ -340,8 +336,8 @@
        (error "macro syntax error" (syntax->datum (syntax-list-tail stx 1))))
       ((is? env stx 'define-syntax)
        (let* ((stx (unwrap-list stx))
-              (name (syntax-cxr '(d a) stx))
-              (tfmr (expand-transformer env (syntax-cxr '(d d a) stx))))
+              (name (syntax-list-ref stx 1))
+              (tfmr (expand-transformer env (syntax-list-ref stx 2))))
          (values (hashmap-set env name tfmr) '())))
       ((is? env stx 'splicing-let-syntax)
        (let-syntax-expander
@@ -553,15 +549,18 @@
     ((is? env expr 'define)
      ;; Use weak-head normal form instead of normal order to allow for
      ;; definitions of useful combinators without normal forms (like `Y`).
-     (values #f (hashmap-set env
-                             (syntax-list-ref expr 1)
-                             (eval-to-weak-head-normal-form
-                              (syntax-list-ref expr 2)
-                              env))))
+     (let ((evalto (eval-to-weak-head-normal-form
+                    (syntax-list-ref expr 2)
+                    env)))
+       (pretty (list 'define (syntax->datum (syntax-list-ref expr 1))
+                     (syntax->datum evalto)))
+       (values #f (hashmap-set env (syntax-list-ref expr 1) evalto))))
     (else (values (eval-expr expr env) env))))
 
 (define (lceval exprs env)
   (let-values (((env exprs) (expand env exprs)))
+    (display "evaluating: ")
+    (pretty (syntax->datum exprs))
     (let loop ((exprs exprs)
                (env env)
                (acc '()))
author	Peter McGoron	2025-07-10 17:42:37 -0400
committer	Peter McGoron	2025-07-10 17:42:37 -0400
commit	8b77b52b3ed30e2849a5fb6c0758df4880e60897 (patch)
tree	02e41998803fe569a61920be1bb2ab5be43ead43 /multisyntax/examples
parent	add display-no-eval for debugging (diff)