add syntax-error, only evaluate defined terms to weak head normal form

6 files changed, 67 insertions, 123 deletions

diff --git a/multisyntax/examples/untyped-lambda-calculus-prelude.scm b/multisyntax/examples/untyped-lambda-calculus-prelude.scm
index db67896..04403a3 100644
--- a/multisyntax/examples/untyped-lambda-calculus-prelude.scm
+++ b/multisyntax/examples/untyped-lambda-calculus-prelude.scm
@@ -32,26 +32,18 @@
     (syntax-rules ()
       ((∘← f ...) (R (f ...) ())))))
 
-(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 ...))))))
+      ((_ (formal) body)
+       (lambda formal body))
+      ((_ (formal1 formal-rest ...) body)
+       (lambda formal1 (lambda (formal-rest ...) body)))
+      ((_ () body) (syntax-error "functions must have at least one argument"))
+      ((_ formal body)
+       (%lambda formal body)))))
 
 (define-syntax λ lambda)
 
@@ -59,7 +51,7 @@
   ;; Regular `let`. Named `let` is defined later.
   (syntax-rules ()
     ((let () body ...)
-     ((λ (dummy) body ...) I))
+     (error "let bindings must have at least one argument"))
     ((let ((name value) ...) body ...)
      ((λ (name ...) body ...) value ...))))
 
@@ -67,15 +59,15 @@
 
 (define Y
   ;; Y combinator.
-  (lambda (f)
+  (λ (f)
     (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 ...)))))
+    ((rec (name formal1 formal-rest ...) body)
+     (Y (λ (name formal1 formal-rest ...) body)))))
 
 (define-syntax υ rec)
 
@@ -83,10 +75,10 @@
   ;; Named `let`.
   (define-syntax let
     (syntax-rules ()
-      ((let ((name value) ...) body ...)
-       (%let ((name value) ...) body ...))
-      ((let name ((param first-binding) ...) body ...)
-       ((υ (name param ...) body ...)
+      ((let ((name value) ...) body)
+       (%let ((name value) ...) body))
+      ((let name ((param first-binding) ...) body)
+       ((υ (name param ...) body)
         first-binding ...)))))
 
 (splicing-let-syntax ((%define define))
@@ -94,78 +86,6 @@
     (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 ...))
-      ...))))
-
-;;; ;;;;;;;;;;;;
-;;; untyped operations
-
-(define (%cons car cdr)
-  (λ selector (selector car cdr)))
-
-(define (%car pair)
-  (pair (λ (x y) x)))
-(define (%cdr pair)
-  (pair (λ (x y) y)))
-
-(define %true (λ (x y) x))
-(define %false (λ (x y) y))
-(define (%and x y) (x y x))
-
-(define %null (λ (f x) x))
-(define (%null? value)
-  (church-numeral (λ x %false) %true))
-
-(define (%succ n) (λ (f x) (f (n f x))))
-
-(define (%pred n)
-  (%car (n (λ p (%cons (%cdr p) (%succ (%car p))))
-           (%cons %null %null))))
-
-(define (%- x y) (y pred) x)
-(define (%<= x y) (%null? (%- x y)))
-(define (%= x y) (%and (%<= x y) (%<= y x)))
-
-;;; ;;;;;;;;;;;;;;;
-;;; Typed pairs
-
-(define (type-constructor tag)
-  (λ value (%cons tag value)))
-(define (type-predicate tag)
-  (λ value (%= (%car value) tag)))
-(define type-value %cdr)
-
-(let-lowered ((tag %null)))
-
-(let-lowered ((tag %null))
-  (define null ((type-constructor tag) null))
-  (define null? (type-predicate tag)))
-
-(let-lowered ((tag (%succ %null)))
-  (define (cons car cdr)
-    ((type-constructor tag) (%cons car cdr)))
-  (define pair? (type-predicate tag)))
-
-(define (car cell)
-  ((∘← type-value primitive-car) cell))
-
-(define (cdr cell)
-  ((∘← type-value primitive-cdr) cell))
+      ((define name body)
+       (%define name (letrec ((name body)) name))))))
 
diff --git a/multisyntax/examples/untyped-lambda-calculus.scm b/multisyntax/examples/untyped-lambda-calculus.scm
index 35cd13f..1f0ea7e 100644
--- a/multisyntax/examples/untyped-lambda-calculus.scm
+++ b/multisyntax/examples/untyped-lambda-calculus.scm
@@ -78,7 +78,8 @@
            (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))
+           (empty-wrap 'syntax-rules) 'syntax-rules
+           (empty-wrap 'syntax-error) 'syntax-error))
 
 (define (union-names env new-names tfmrs)
   ;; Add `new-names` bound to `tfmrs` in `env`, overriding previous
@@ -201,6 +202,8 @@
     (cond
       ((self-syntax? stx) stx)
       ((identifier? stx) stx)
+      ((is? env stx 'syntax-error)
+       (error "macro syntax error" (syntax->datum (syntax-list-tail stx 1))))
       ((is? env stx 'lambda)
        (let* ((bound (syntax-cxr '(d a) stx))
               (renamed (add-substitution
@@ -265,6 +268,8 @@
   ;; Expand a transformer.
   (let ((stx (unwrap-syntax stx)))
     (cond
+      ((is? env stx 'syntax-error)
+       (error "macro syntax error" (syntax->datum (syntax-list-tail stx 1))))
       ((identifier? stx)
        (let ((value (resolve stx)))
          (if (lexical-location? value)
@@ -330,6 +335,8 @@
   ;; `env`.
   (let ((stx (unwrap-syntax stx)))
     (cond
+      ((is? env stx 'syntax-error)
+       (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))
@@ -350,8 +357,8 @@
           (accumulate-splicing env
                                (add-substitution body old-names new-names)))))
       ((is? env stx 'define)
-       (let* ((name (syntax-cxr '(d a) stx))
-              (expanded-value (expand-expr env (syntax-cxr '(d d a) stx))))
+       (let* ((name (syntax-list-ref stx 1))
+              (expanded-value (expand-expr env (syntax-list-ref stx 2))))
          (values (hashmap-set env name 'variable)
                  (list (list (inject-primitive 'define)
                              name
@@ -501,10 +508,13 @@
 (define (expanded-eval1 expr env)
   (cond
     ((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-cxr '(d a) expr)
-                             (expanded-eval1 (syntax-cxr '(d d a) expr)
-                                             env))))
+                             (syntax-list-ref expr 1)
+                             (eval-to-weak-head-normal-form
+                              (syntax-list-ref expr 2)
+                              env))))
     (else (values (eval-expr expr env) env))))
 
 (define (lceval exprs env)
@@ -518,4 +528,22 @@
                         (expanded-eval1 (car exprs) env)))
             (loop (cdr exprs)
                   env
-                  (cons normal-form acc)))))))
+                  (if normal-form
+                      (cons normal-form acc)
+                      acc)))))))
+
+(define current-environment (make-parameter initial-environment box))
+
+(define (lcrepl)
+  (let ((expr (read)))
+    (unless (eof-object? expr)
+      (display (list "expanding" expr)) (newline)
+      (let-values (((exprs newmap)
+                    (lceval (list (empty-wrap expr)) (unbox (current-environment)))))
+        (set-box! (current-environment) newmap)
+        (when (not (null? exprs))
+          (display (list "result: " (syntax->datum (list-ref exprs 0))))
+          (newline))
+        (lcrepl)))))
+
+(define (lcload file) (with-input-from-file file lcrepl))
diff --git a/multisyntax/examples/untyped-lambda-calculus.sld b/multisyntax/examples/untyped-lambda-calculus.sld
index 0695168..0e57e2b 100644
--- a/multisyntax/examples/untyped-lambda-calculus.sld
+++ b/multisyntax/examples/untyped-lambda-calculus.sld
@@ -14,11 +14,11 @@
  |#
 
 (define-library (multisyntax examples untyped-lambda-calculus)
-  (import (scheme base) (scheme write) (scheme cxr)
-          (srfi 1) (srfi 26) (srfi 146 hash)
+  (import (scheme base) (scheme write) (scheme read) (scheme file) (scheme cxr)
+          (srfi 1) (srfi 26) (srfi 111) (srfi 146 hash)
           (multisyntax syntax-object)
           (multisyntax pattern matcher)
           (multisyntax pattern producer))
   (export expand transformer? initial-environment alpha
-          debruijnize lceval)
+          debruijnize lceval current-environment lcrepl lcload)
   (include "untyped-lambda-calculus.scm"))
\ No newline at end of file
diff --git a/multisyntax/syntax-object.scm b/multisyntax/syntax-object.scm
index f4cd3c5..6f6260a 100644
--- a/multisyntax/syntax-object.scm
+++ b/multisyntax/syntax-object.scm
@@ -193,7 +193,7 @@
       ((vector? stx) (vector-map loop stx))
       ((self-syntax? stx) stx)
       ((wrap? stx) (f stx))
-      (else (error "not a syntax object" %stx)))))
+      (else (error "not a syntax object" %stx stx)))))
 
 (define (add-timestamp stx ts)
   ;; Adds a timestamp to the syntax object `stx`. If the timestamp is
@@ -386,11 +386,7 @@
 
 (define (syntax->datum stx)
   ;; Remove wraps from the syntax object.
-  (wrap-map (lambda (stx)
-               (if (identifier? stx)
-                   (wrap->expr stx)
-                   (syntax->datum (wrap->expr stx))))
-             stx))
+  (wrap-map wrap->expr stx))
 
 (define (if-contains-wrap operate obj)
   ;; If `obj` does not contain a wrapped syntax object, return `#f`.
diff --git a/test/examples/untyped-lambda-calculus.scm b/test/examples/untyped-lambda-calculus.scm
index 534d6e6..42d1fea 100644
--- a/test/examples/untyped-lambda-calculus.scm
+++ b/test/examples/untyped-lambda-calculus.scm
@@ -117,29 +117,26 @@
                    ((lambda 0)))
   (test-eval-alpha "define returns nothing"
                    ((define I (lambda x x)))
-                   (#f))
+                   ())
   (test-eval-alpha "global environment lookup"
                    ((define I (lambda x x))
                     I)
-                   (#f
-                    (lambda 0)))
+                   ((lambda 0)))
   (test-eval-alpha "K combinator, 1"
                    ((define K (lambda x (lambda y x)))
                     (define I (lambda x x))
                     (K I I))
-                   (#f
-                    #f
-                    (lambda 0)))
+                   ((lambda 0)))
   (test-eval-alpha "K combinator, 2"
                    ((define K (lambda x (lambda y x)))
                     (define I (lambda x x))
                     (K I K))
-                   (#f #f (lambda 0)))
+                   ((lambda 0)))
   (test-eval-alpha "K combinator, 3"
                    ((define K (lambda x (lambda y x)))
                     (define I (lambda x x))
                     (K K I))
-                   (#f #f (lambda (lambda 1))))
+                   ((lambda (lambda 1))))
   (test-eval-alpha "define-syntax"
                    ((define-syntax λ
                       (syntax-rules ()
@@ -150,12 +147,12 @@
                     (define true (λ (x y) x))
                     (define false (λ (x y) y))
                     (false false true))
-                   (#f #f (lambda (lambda 1))))
+                   ((lambda (lambda 1))))
   (test-eval-alpha "normal order evaluation"
                    ((define ω (lambda x (x x)))
                     (define K (lambda x (lambda y x)))
                     (K K (ω ω)))
-                   (#f #f (lambda (lambda 1)))))
+                   ((lambda (lambda 1)))))
 
 (define (test-untyped-lambda-calculus)
   (test-group "untyped lambda calculus"
diff --git a/test/run.scm b/test/run.scm
index d3bd7d4..e7b9dba 100644
--- a/test/run.scm
+++ b/test/run.scm
@@ -31,3 +31,6 @@
 (load "examples/untyped-lambda-calculus.sld")
 (import (multisyntax examples untyped-lambda-calculus test))
 (test-untyped-lambda-calculus)
+
+(import (multisyntax examples untyped-lambda-calculus))
+(lcload "/home/user/Documents/code/scheme/multisyntax/multisyntax/examples/untyped-lambda-calculus-prelude.scm")