Hello again,
this fixes #1446 I reported earlier.
The patch applies after the other patch I posted today.
Here's a simple example showing the issue:
(define-type T (or string boolean))
(: foo ((T T -> any) T -> any))
(define (foo f a) (f a "foo"))
(: bar (string string -> any))
(define (bar a b)
(string-length a))
(print (foo bar #t))
;; $ csc -O3 func-args.scm && ./func-args
;;
;; Error: (string-length) bad argument type: #t
;;
;; Call history:
;;
;; func-args.scm:9: string-length <--
Same example in Typed Racket:
#lang typed/racket
(define-type T (U String Boolean))
(: foo (-> (-> T T Any) T Any))
(define (foo f a) (f a "foo"))
(: bar (-> String String Any))
(define (bar a b)
(string-length a))
(print (foo bar #t))
;; $ racket function-args.rkt
;; function-args.rkt:9:12: Type Checker: type mismatch
;; expected: (-> T T Any)
;; given: (-> String String Any)
;; in: bar
;; context...:
;;
/usr/share/racket/pkgs/typed-racket-lib/typed-racket/typecheck/tc-toplevel.rkt:314:0:
type-check
;;
/usr/share/racket/pkgs/typed-racket-lib/typed-racket/typecheck/tc-toplevel.rkt:552:0:
tc-module
;; /usr/share/racket/pkgs/typed-racket-lib/typed-racket/tc-setup.rkt:82:0:
tc-module/full
;; /usr/share/racket/pkgs/typed-racket-lib/typed-racket/typed-racket.rkt:24:4
Cheers,
diff --git a/scrutinizer.scm b/scrutinizer.scm
index a330d4e..69b4583 100644
--- a/scrutinizer.scm
+++ b/scrutinizer.scm
@@ -389,7 +389,7 @@
(atypes atypes (cdr atypes))
(i 1 (add1 i)))
((or (null? actualtypes) (null? atypes)))
- (unless (match-types
+ (unless (match-types
(car atypes)
(car actualtypes)
typeenv)
@@ -942,13 +942,31 @@
(define (match-types t1 t2 #!optional (typeenv (type-typeenv `(or ,t1 ,t2))) all)
(define (match-args args1 args2)
+ (define (match-rest rtype args opt reverse?) ;XXX currently ignores `opt'
+ (fluid-let ((all #t))
+ (let-values (((head tail) (span (lambda (x) (not (eq? '#!rest x))) args)))
+ (let ((match1* (lambda (t r)
+ (if reverse?
+ (match1 r t)
+ (match1 t r)))))
+ (and (every
+ (lambda (t)
+ (or (eq? '#!optional t)
+ (match1* t rtype)))
+ head)
+ (let ((t (if (pair? tail) (rest-type (cdr tail)) '*)))
+ (match1* t rtype)))))))
+
+ (define (optargs? a)
+ (memq a '(#!rest #!optional)))
+
(d "match args: ~s <-> ~s" args1 args2)
(let loop ((args1 args1) (args2 args2) (opt1 #f) (opt2 #f))
- (cond ((null? args1)
+ (cond ((null? args1)
(or opt2
(null? args2)
(optargs? (car args2))))
- ((null? args2)
+ ((null? args2)
(or opt1
(optargs? (car args1))))
((eq? '#!optional (car args1))
@@ -956,25 +974,13 @@
((eq? '#!optional (car args2))
(loop args1 (cdr args2) opt1 #t))
((eq? '#!rest (car args1))
- (match-rest (rest-type (cdr args1)) args2 opt2))
+ (match-rest (rest-type (cdr args1)) args2 opt2 #f))
((eq? '#!rest (car args2))
- (match-rest (rest-type (cdr args2)) args1 opt1))
- ((match1 (car args1) (car args2))
+ (match-rest (rest-type (cdr args2)) args1 opt1 #t))
+ ((fluid-let ((all #t)) (match1 (car args2) (car args1)))
(loop (cdr args1) (cdr args2) opt1 opt2))
(else #f))))
- (define (match-rest rtype args opt) ;XXX currently ignores `opt'
- (let-values (((head tail) (span (lambda (x) (not (eq? '#!rest x))) args)))
- (and (every
- (lambda (t)
- (or (eq? '#!optional t)
- (match1 rtype t)))
- head)
- (match1 rtype (if (pair? tail) (rest-type (cdr tail)) '*)))))
-
- (define (optargs? a)
- (memq a '(#!rest #!optional)))
-
(define (match-results results1 results2)
(cond ((eq? '* results1))
((eq? '* results2) (not all))
diff --git a/tests/scrutinizer-tests.scm b/tests/scrutinizer-tests.scm
index ed313a4..8a87500 100644
--- a/tests/scrutinizer-tests.scm
+++ b/tests/scrutinizer-tests.scm
@@ -231,8 +231,8 @@
(test (>< (procedure (x)) (procedure (y))))
(test (>< (procedure () x) (procedure () y)))
-(test (? (procedure (x)) (procedure (*))))
-(test (? (procedure () x) (procedure () *)))
+(test (< (procedure (*)) (procedure (x))))
+(test (< (procedure () x) (procedure () *)))
(test (! (procedure (x)) (procedure ())))
(test (! (procedure (x)) (procedure (x y))))
diff --git a/tests/typematch-tests.scm b/tests/typematch-tests.scm
index e4123cd..67d0e48 100644
--- a/tests/typematch-tests.scm
+++ b/tests/typematch-tests.scm
@@ -392,4 +392,14 @@
;; Always a bignum
(infer-last (fixnum bignum) #x7fffffffffffffff)
+(proper-subtype (#!optional (or list vector) -> *) (#!optional list -> *))
+(proper-subtype (#!rest (or list vector) -> *) (#!rest list -> *))
+(proper-subtype (#!rest (or list vector) -> *) (vector #!rest list -> *))
+(proper-subtype ((or list vector) -> *) (list -> *))
+(proper-subtype ((or list vector) -> list) (list -> (or list vector)))
+(proper-subtype (-> list) (-> (or list vector)))
+
+(proper-subtype ((list -> *) -> *) (((or list vector) -> *) -> *))
+(proper-subtype (* -> ((or list vector) -> *)) (* -> (list -> *)))
+
(test-exit)
_______________________________________________
Chicken-hackers mailing list
Chicken-hackers@nongnu.org
https://lists.nongnu.org/mailman/listinfo/chicken-hackers
