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)