From 738984acedf1f725a10872c6aa70eb7d2a1a81f9 Mon Sep 17 00:00:00 2001
From: admin <admin@vouivredigital.com>
Date: Thu, 21 Sep 2023 14:46:50 +0900
Subject: [PATCH] Play nicer with regular Scheme

---
 curry-tests.scm | 23 +++++++++++++++++++---
 curry.scm       | 52 +++++++++++++++++++++++++++++++------------------
 2 files changed, 53 insertions(+), 22 deletions(-)

diff --git a/curry-tests.scm b/curry-tests.scm
index b39c879..16ece85 100644
--- a/curry-tests.scm
+++ b/curry-tests.scm
@@ -12,11 +12,11 @@
 ;;       (parse '(1       . (2 . 3)))
 ;;       (parse '((1 . 2) . (1 . 1))))))
 (test-equal '(1 . 1)
-  (t '() '(lambda x x)))
+  (t '() '(λc x x)))
 (test-equal '((3 . 4) . ((2 . 3) . (2 . 4)))
-  (t '() '(lambda g (lambda f (lambda x (g (f x)))))))
+  (t '() '(λc g (λc f (λc x (g (f x)))))))
 (test-equal 0
-  (t '() '((lambda x x) #t)))
+  (t '() '((λc x x) #t)))
 (let ((bindings `((id  . ,(parse '(1 . 1)))
 		  (∘   . ,(parse '((2 . 3) . ((1 . 2) . (1 . 3)))))
 		  (⊙   . ,(parse '((1 . 2) . ((2 . 3) . (1 . 3)))))
@@ -43,4 +43,21 @@
   (test-equal 0
     (t bindings '((∘ (⊙ (+ 1)) +) 2 3)))
   )
+
+;;; interaction between typed and untyped (regular) scheme
+
+;; Untyped scheme produces untyped return.
+(test-assert (not (t '() '(+ 1 2 3))))
+
+(let ((bindings `((* . ,(parse '(0 . (0 . 0)))))))
+  ;; Typed Scheme can be used by untyped Scheme...
+  (test-assert (not (t bindings '(+ 1 (* 2 3) 4))))
+
+  ;; ... although, sometimes, with terrible runtime consequences!
+  (test-assert (not (t bindings '(+ 1 (* 2) 3))))
+
+  ;; On the other hand, typed Scheme expects typed Scheme.
+  (test-error (t bindings '(* 1 (+ 2 3))))
+  )
+
 (test-end "curry")
diff --git a/curry.scm b/curry.scm
index edb4550..af7c14d 100644
--- a/curry.scm
+++ b/curry.scm
@@ -6,8 +6,9 @@
   #:use-module (srfi srfi-64)
   #:use-module (vdc misc)
   #:replace
-  ((vdc:define . define)
-   (vdc:primitive-eval . primitive-eval))
+  (;(vdc:define . define)
+   ;(vdc:primitive-eval . primitive-eval)
+   )
   #:export
   (curry
    parse
@@ -27,7 +28,8 @@
 		  (1 . INCOMPATIBLE)
 		  (2 . BAD-INPUT)
 		  (3 . BAD-APPLICATION)
-		  (4 . UNBOUND-SYMBOL))))
+		  (4 . UNBOUND-SYMBOL)
+		  (5 . TYPE-EXPECT-TYPES))))
     (apply error "type error" (assoc-ref errors n) args)))
 
 (define (zo? x)
@@ -238,35 +240,47 @@
   (match expr
     (('quote x)
      (make-node 0))
-    (('lambda (? symbol? var) body)
+    (('λc (? symbol? var) body)
      (let ((var-node (make-node #f)))
        (let ((nbody (t% (sym-set symtab var var-node)
 			body)))
+	 (unless nbody
+	   (type-error 5 "in body of" `(λc ,var ,body)))
 	 (populate-tvs! var-node)
 	 (make-node
 	  (cons var-node nbody)))))
     (('letrecc1 ((? symbol? name) expr) body)
      (type-error 0 'letrecc1 name expr body))
     ((f)
-     (type-error 3 expr))
+     (if (t% symtab f)
+	 (type-error 3 expr)
+	 #f))
     ((f as ..1)
-     (fold
-      (lambda (a prev)
-	(apply-1 prev (t% symtab a)))
-      (t% symtab f)
-      as))
+     (if-let (ft (t% symtab f))
+	     (fold
+	      (lambda (a prev)
+		(apply-1 prev (or (t% symtab a) (type-error 5 f a))))
+	      ft as)
+	     (begin
+	       (for-each
+		(lambda (a)
+		  (t% symtab a))
+		as)
+	       #f)))
     (x
      (if (symbol? x)
-	 (or (sym-ref symtab x)
-	     (type-error 4 x))
+	 (sym-ref symtab x)
 	 (make-node 0)))))
 
-(define (bare-t node)
-  (let ((x (node-content node)))
-    (cond
-     ((pair? x)
-      (cons (bare-t (car x)) (bare-t (cdr x))))
-     (else x))))
+(define (bare-t x)
+  (and=>
+   x
+   (lambda (node)
+     (let ((x (node-content node)))
+       (cond
+	((pair? x)
+	 (cons (bare-t (car x)) (bare-t (cdr x))))
+	(else x))))))
 
 (define (pt node)
   (format
@@ -309,7 +323,7 @@
 (define (curry x)
   (match x
     (('quote x) (quote x))
-    (('lambda (? symbol? var) body)
+    (('λc (? symbol? var) body)
      `(lambda (,var) ,(curry body)))
     ;; (('letrecc1 ((? symbol? name) expr) body)
     ;;  `(letrecc1 (,name ,(curry expr)) ,(curry body)))
-- 
2.39.2