Play nicer with regular Scheme

diff --git a/curry-tests.scm b/curry-tests.scm
index b39c87921183c11ee05978c131aadcaaa58a2ead..16ece85ebc2c8c18f1abd1f8d159d72c1489b352 100644 (file)
--- 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 edb45503aa2cf7adb877d02ec2a9e9af4f336fe4..af7c14d8ca87f567087896b2425d3ed538282394 100644 (file)
--- 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)))