Compare function types with TBD types

diff --git a/curry-tests.scm b/curry-tests.scm
index 57c718270ed9a4563e79f7084ca56b29d7b9619a..b51ca0222975011a7dbc358bd27d96a2b0c8a581 100644 (file)
--- a/curry-tests.scm
+++ b/curry-tests.scm
@@ -1,5 +1,6 @@
 (define-module (vdc curry tests)
   #:use-module (vdc curry)
+  #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-64)
   #:use-module (srfi srfi-71))
 
@@ -16,6 +17,11 @@
 (define-syntax-rule (test-type given expected-bare)
   (test-assert (equal-types? given (parse expected-bare))))
 
+(define (sym-sets symtab alist)
+  (fold (lambda (x prev)
+         ((@@ (vdc curry) sym-set) prev (car x) (cdr x)))
+       symtab alist))
+
 (let ((t e (expand '() '(λc x x))))
   (test-type t '(1 . 1))
   (test-equal '(lambda (x) x) e))
@@ -25,11 +31,14 @@
 (let ((t e (expand '() '((λc x x) #t))))
   (test-type t 0)
   (test-equal #t (primitive-eval e)))
-(let ((bindings `((id  . ,(parse '(1 . 1)))
-                 (∘   . ,(parse '((2 . 3) . ((1 . 2) . (1 . 3)))))
-                 (⊙   . ,(parse '((1 . 2) . ((2 . 3) . (1 . 3)))))
-                 (map . ,(parse '((0 . 0) . (0 . 0))))
-                 (+   . ,(parse '(0 . (0 . 0)))))))
+(let ((bindings
+       (sym-sets
+       '()
+       `((id  . ,(parse '(1 . 1)))
+         (∘   . ,(parse '((2 . 3) . ((1 . 2) . (1 . 3)))))
+         (⊙   . ,(parse '((1 . 2) . ((2 . 3) . (1 . 3)))))
+         (map . ,(parse '((0 . 0) . (0 . 0))))
+         (+   . ,(parse '(0 . (0 . 0))))))))
   (let ((t e (expand bindings '(∘ id id))))
     (test-type t '(7 . 7))
     (test-equal e '((∘ id) id)))
@@ -39,6 +48,8 @@
   (let ((t e (expand bindings '(∘ id id #t))))
     (test-type t 0)
     (test-equal e '(((∘ id) id) #t)))
+  (let ((t e (expand bindings '(λc f (∘ f)))))
+    (test-type t '((2 . 3) . ((1 . 2) . (1 . 3)))))
   (let ((t e (expand bindings '(map (+ 1) '(1 2 3)))))
     (test-type t 0)
     (test-equal e '((map (+ 1)) '(1 2 3))))
@@ -68,7 +79,10 @@
   (test-type t #f)
   (test-equal e '(+ 1 2 3)))
 
-(let ((bindings `((* . ,(parse '(0 . (0 . 0)))))))
+(let ((bindings
+       (sym-sets
+       '()
+       `((* . ,(parse '(0 . (0 . 0))))))))
   ;; Typed Scheme can be used by untyped Scheme...
   (let ((t e (expand bindings '(+ 1 (* 2 3) 4))))
     (test-type t #f)

diff --git a/curry.scm b/curry.scm
index d2bea84ab0109e5baef83f079d6c75a45fabadcb..aec314c31fd9e8582a8c25592622834f743b8b9a 100644 (file)
--- a/curry.scm
+++ b/curry.scm
@@ -154,7 +154,8 @@
           (set-node-content! ny z)
           (massoc m x z)))
        ((and (pair? x) (not y))
-        (type-error 0 nx ny))
+        (set-node-content! ny x)
+        m)
        ((and (pair? y) (not x))
         (type-error 0 nx ny))
        ;; cases with TVs