~ chicken-core (chicken-5) 3e72cecc8891e43a998787144d6bcb2757e4f652
commit 3e72cecc8891e43a998787144d6bcb2757e4f652
Author: felix <felix@call-with-current-continuation.org>
AuthorDate: Sun Nov 4 17:58:12 2012 +0100
Commit: Peter Bex <peter.bex@xs4all.nl>
CommitDate: Fri Nov 9 21:24:21 2012 +0100
Scrutinizer fixes.
a) when matching "list-of"/"vector-of" with "list"/"vector", each
element of the latter must match the element-type of the former
(reported by megane, fixes #948)
b) when matching result-types, allow "undefined" to match "noreturn"
as the "noreturn" property can not be inferred for foreign procedures
(for example) in general
Signed-off-by: Peter Bex <peter.bex@xs4all.nl>
diff --git a/scrutinizer.scm b/scrutinizer.scm
index 3cfbe93c..73a1166b 100755
--- a/scrutinizer.scm
+++ b/scrutinizer.scm
@@ -47,9 +47,11 @@
(printf "[debug|~a] ~a~?~%" d-depth (make-string d-depth #\space) fstr args)) )
(define dd d)
+(define ddd d)
(define-syntax d (syntax-rules () ((_ . _) (void))))
(define-syntax dd (syntax-rules () ((_ . _) (void))))
+(define-syntax ddd (syntax-rules () ((_ . _) (void))))
;;; Walk node tree, keeping type and binding information
@@ -1010,6 +1012,8 @@
((eq? '* results1))
((eq? '* results2) (not exact))
((null? results2) #f)
+ ((and (memq (car results1) '(undefined noreturn))
+ (memq (car results2) '(undefined noreturn))))
((match1 (car results1) (car results2))
(match-results (cdr results1) (cdr results2)))
(else #f)))
@@ -1175,9 +1179,18 @@
((and (pair? t1) (eq? 'list-of (car t1)))
(or (eq? 'null t2)
(and (pair? t2)
- (memq (car t2) '(pair list))
- (let ((ct2 (canonicalize-list-of-type t2)))
- (and ct2 (match1 t1 ct2))))))
+ (case (car t2)
+ ((list)
+ (let ((t1 (second t1)))
+ (over-all-instantiations
+ (cdr t2)
+ typeenv
+ #t
+ (lambda (t) (match1 t1 t)))))
+ ((pair)
+ (let ((ct2 (canonicalize-list-of-type t2)))
+ (and ct2 (match1 t1 ct2))))
+ (else #f)))))
((and (pair? t1) (eq? 'list (car t1)))
(and (pair? t2)
(case (car t2)
@@ -1186,15 +1199,20 @@
(match1 (second t1) (second t2))
(match1 t1 (third t2))))
((list-of)
- (and (not exact) (not all)
- (let ((ct2 (canonicalize-list-of-type t2)))
- (and ct2 (match1 t1 ct2)))))
+ (and (not exact)
+ (not all)
+ (let ((t2 (second t2)))
+ (over-all-instantiations
+ (cdr t1)
+ typeenv
+ #t
+ (lambda (t) (match1 t t2))))))
(else #f))))
((and (pair? t2) (eq? 'list-of (car t2)))
(and (not exact) ;XXX also check "all"?
(or (eq? 'null t1)
(and (pair? t1)
- (memq (car t1) '(pair list))
+ (eq? 'pair (car t1)) ; list-of already handled above
(let ((ct1 (canonicalize-list-of-type t1)))
(and ct1 (match1 ct1 t2)))))))
((and (pair? t2) (eq? 'list (car t2)))
@@ -1204,20 +1222,27 @@
(and (pair? (cdr t2))
(match1 (second t1) (second t2))
(match1 (third t1) t2)))
- ((list-of)
- (and (not exact) (not all)
- (let ((ct1 (canonicalize-list-of-type t1)))
- (and ct1 (match1 ct1 t2)))))
+ ;; t1 = list-of already handled above
(else #f))))
((and (pair? t1) (eq? 'vector (car t1)))
(and (not exact) (not all)
(pair? t2)
(eq? 'vector-of (car t2))
- (match1 (simplify-type `(or ,@(cdr t1))) (second t2))))
+ (let ((t2 (second t2)))
+ (over-all-instantiations
+ (cdr t1)
+ typeenv
+ #t
+ (lambda (t) (match1 t t2))))))
((and (pair? t2) (eq? 'vector (car t2)))
(and (pair? t1)
(eq? 'vector-of (car t1))
- (match1 (second t1) (simplify-type `(or ,@(cdr t2))))))
+ (let ((t1 (second t1)))
+ (over-all-instantiations
+ (cdr t2)
+ typeenv
+ #t
+ (lambda (t) (match1 t1 t))))))
(else #f)))
(let ((m (match1 t1 t2)))
@@ -2285,7 +2310,7 @@
;; restore trail and collect instantiations
(define (restore)
- ;;(dd "restoring, trail: ~s, te: ~s" trail typeenv) ;XXX remove
+ (ddd "restoring, trail: ~s, te: ~s" trail typeenv)
(let ((is '()))
(do ((tr trail (cdr tr)))
((eq? tr trail0)
@@ -2296,7 +2321,7 @@
(car tr)
(resolve (car tr) typeenv)
is))
- ;; (dd " restoring ~a, insts: ~s" (car tr) insts) ;XXX remove
+ (ddd " restoring ~a, insts: ~s" (car tr) insts)
(let ((a (assq (car tr) typeenv)))
(set-car! (cdr a) #f)))))
@@ -2314,10 +2339,10 @@
(else #f)))
insts)))
vars)))
- ;;(dd " collected: ~s" all) ;XXX remove
+ (ddd " collected: ~s" all)
all))
- ;;(dd " over-all-instantiations: ~s exact=~a" tlist exact) ;XXX remove
+ (ddd " over-all-instantiations: ~s exact=~a" tlist exact)
;; process all tlist elements
(let loop ((ts tlist) (ok #f))
(cond ((null? ts)
diff --git a/support.scm b/support.scm
index c0ff51f4..08f6d666 100644
--- a/support.scm
+++ b/support.scm
@@ -640,6 +640,8 @@
(walk (car subs)) ) )
((##core#the)
`(the ,(first params) ,(walk (first subs))))
+ ((##core#the/result)
+ (walk (first subs)))
((##core#typecase)
`(compiler-typecase
,(walk (first subs))
diff --git a/tests/runtests.sh b/tests/runtests.sh
index 3009346f..7a0626b9 100755
--- a/tests/runtests.sh
+++ b/tests/runtests.sh
@@ -363,6 +363,7 @@ $compile symbolgc-tests.scm
echo "======================================== finalizer tests ..."
$interpret -s test-finalizers.scm
$compile finalizer-error-test.scm
+echo "expect an error message here:"
./a.out -:hg101
$compile test-finalizers-2.scm
./a.out
diff --git a/tests/scrutiny-tests.scm b/tests/scrutiny-tests.scm
index 49a0673e..9c2e867b 100644
--- a/tests/scrutiny-tests.scm
+++ b/tests/scrutiny-tests.scm
@@ -147,3 +147,12 @@
(: another-deprecated-procedure (deprecated replacement-procedure))
(define (another-deprecated-procedure x) (+ x x))
(another-deprecated-procedure 2)
+
+;; Needed to use "over-all-instantiations" or matching "vector"/"list" type
+;; with "vector-of"/"list-of" type (reported by megane)
+(: apply1 (forall (a b) (procedure ((procedure (#!rest a) b) (list-of a)) b)))
+
+(define (apply1 f args)
+ (apply f args))
+
+(apply1 + (list 'a 2 3)) ; <- no type warning
diff --git a/tests/scrutiny.expected b/tests/scrutiny.expected
index a8c7c6d9..5612202b 100644
--- a/tests/scrutiny.expected
+++ b/tests/scrutiny.expected
@@ -34,7 +34,7 @@ Warning: at toplevel:
(scrutiny-tests.scm:25) in procedure call to `+', expected argument #2 of type `number', but was given an argument of type `symbol'
Warning: at toplevel:
- assignment of value of type `fixnum' to toplevel variable `car' does not match declared type `(forall (a148) (procedure car ((pair a148 *)) a148))'
+ assignment of value of type `fixnum' to toplevel variable `car' does not match declared type `(forall (a157) (procedure car ((pair a157 *)) a157))'
Warning: at toplevel:
expected in `let' binding of `g8' a single result, but were given 2 results
@@ -99,4 +99,7 @@ Warning: at toplevel:
Warning: at toplevel:
use of deprecated library procedure `another-deprecated-procedure' - consider using `replacement-procedure' instead
+Warning: at toplevel:
+ (scrutiny-tests.scm:158) in procedure call to `apply1', expected argument #2 of type `(list-of number)', but was given an argument of type `(list symbol fixnum fixnum)'
+
Warning: redefinition of standard binding: car
Trap