~ chicken-core (chicken-5) 4ca0f7dbd29b1e38edd09dd61d94f5df40a12c70
commit 4ca0f7dbd29b1e38edd09dd61d94f5df40a12c70
Author: felix <felix@call-with-current-continuation.org>
AuthorDate: Fri Jan 20 09:20:49 2012 +0100
Commit: Peter Bex <peter.bex@xs4all.nl>
CommitDate: Sat Jan 28 14:21:45 2012 +0100
Squashed commit of the following:
commit a5c646137f73e31aa92bc576eea9dae02397550f
Author: felix <felix@call-with-current-continuation.org>
Date: Fri Jan 20 09:20:07 2012 +0100
disabled debug output for scrutinizer
commit d605271870a12f49e9e3d3e951c52388e0e44bea
Author: felix <felix@call-with-current-continuation.org>
Date: Fri Dec 30 13:01:59 2011 +0100
updated expected output for 2nd scrutiny test
commit 059738feaa75789ccbf0b172753a636ccee42178
Author: felix <felix@call-with-current-continuation.org>
Date: Wed Dec 21 23:16:50 2011 +0100
FA: invalidate blist entries only for captured variables; canonicalize pair/list types prior to matching with list-of type; pounding on matching to not make it too strict or too loose
Signed-off-by: Peter Bex <peter.bex@xs4all.nl>
diff --git a/compiler-namespace.scm b/compiler-namespace.scm
index 679f0247..6e3c85e9 100644
--- a/compiler-namespace.scm
+++ b/compiler-namespace.scm
@@ -42,6 +42,7 @@
build-node-graph
c-ify-string
callback-names
+ canonicalize-list-of-type
canonicalize-begin-body
canonicalize-expression
check-and-open-input-file
diff --git a/scrutinizer.scm b/scrutinizer.scm
index 69682a0a..50f7b546 100755
--- a/scrutinizer.scm
+++ b/scrutinizer.scm
@@ -643,8 +643,7 @@
(alist-cons
(cons var (car flow))
(if (or strict-variable-types
- ;;XXX needs to be tested more but might be worth it
- #;(not (get db var 'captured)))
+ (not (get db var 'captured)))
rt
'*)
blist)))
@@ -1095,8 +1094,10 @@
(pair? t2)
(case (car t2)
((list-of)
- (and (match1 (second t1) (second t2))
- (match1 (third t1) t2)))
+ (let ((ct1 (canonicalize-list-of-type t1)))
+ (if ct1
+ (match1 ct1 t2)
+ #t))) ; inexact match
((list)
(and (match1 (second t1) (second t2))
(match1 (third t1)
@@ -1108,9 +1109,10 @@
(and (pair? t1)
(case (car t1)
((list-of)
- (and ;(not exact)
- (match1 (second t1) (second t2))
- (match1 t1 (third t2))))
+ (let ((ct2 (canonicalize-list-of-type t2)))
+ (if ct2
+ (match1 t1 ct2)
+ (and (not exact) (not all))))) ; inexact mode: ok
((list)
(and (match1 (second t1) (second t2))
(match1 (if (null? (cdr t1))
@@ -1121,15 +1123,9 @@
((and (pair? t1) (eq? 'list-of (car t1)))
(or (eq? 'null t2)
(and (pair? t2)
- (case (car t2)
- ((pair)
- (and (match1 (second t1) (second t2))
- (match1 t1 (third t2))))
- ((list)
- (match1
- (second t1)
- (simplify-type `(or ,@(cdr t2)))))
- (else #f)))))
+ (memq (car t2) '(pair list))
+ (let ((ct2 (canonicalize-list-of-type t2)))
+ (and ct2 (match1 t1 ct2))))))
((and (pair? t1) (eq? 'list (car t1)))
(and (pair? t2)
(case (car t2)
@@ -1139,23 +1135,16 @@
(match1 t1 (third t2))))
((list-of)
(and (not exact) (not all)
- (match1
- (simplify-type `(or ,@(cdr t1)))
- (second t2))))
+ (let ((ct2 (canonicalize-list-of-type t2)))
+ (and ct2 (match1 t1 ct2)))))
(else #f))))
((and (pair? t2) (eq? 'list-of (car t2)))
- (and (not exact)
+ (and (not exact) ;XXX also check "all"?
(or (eq? 'null t1)
(and (pair? t1)
- (case (car t1)
- ((pair)
- (and (match1 (second t1) (second t2))
- (match1 (third t1) t2)))
- ((list)
- (match1
- (simplify-type `(or ,@(cdr t1)))
- (second t2)))
- (else #f))))))
+ (memq (car t1) '(pair list))
+ (let ((ct1 (canonicalize-list-of-type t1)))
+ (and ct1 (match1 ct1 t2)))))))
((and (pair? t2) (eq? 'list (car t2)))
(and (pair? t1)
(case (car t1)
@@ -1165,9 +1154,8 @@
(match1 (third t1) t2)))
((list-of)
(and (not exact) (not all)
- (match1
- (second t1)
- (simplify-type `(or ,@(cdr t2))))))
+ (let ((ct1 (canonicalize-list-of-type t1)))
+ (and ct1 (match1 ct1 t2)))))
(else #f))))
((and (pair? t1) (eq? 'vector (car t1)))
(and (not exact) (not all)
@@ -1303,16 +1291,9 @@
(tcdr (simplify (third t))))
(if (and (eq? '* tcar) (eq? '* tcdr))
'pair
- (let rec ((tr tcdr) (ts (list tcar)))
- (cond ((eq? 'null tr)
- `(list-of ,(simplify `(or ,@ts))))
- ((and (pair? tr) (eq? 'pair (first tr)))
- (rec (third tr) (cons (second tr) ts)))
- ((and (pair? tr) (eq? 'list (first tr)))
- `(list-of ,(simplify `(or ,@ts ,@(cdr tr)))))
- ((and (pair? tr) (eq? 'list-of (first tr)))
- `(list-of ,(simplify-type `(or ,@(reverse ts) ,@(cdr tr)))))
- (else `(pair ,tcar ,tcdr)))))))
+ (let ((t `(pair ,tcar ,tcdr)))
+ (or (canonicalize-list-of-type t)
+ t)))))
((vector-of)
(let ((t2 (simplify (second t))))
(if (eq? t2 '*)
@@ -2113,6 +2094,33 @@
specs)))
+;;; Canonicalize complex pair/list type for matching with "list-of"
+;
+; - returns #f if not possibly matchable with "list-of"
+
+(define (canonicalize-list-of-type t)
+ (cond ((not (pair? t)) t)
+ ((eq? 'pair (car t))
+ (let ((tcar (second t))
+ (tcdr (third t)))
+ (let rec ((tr tcdr) (ts (list tcar)))
+ (cond ((eq? 'null tr)
+ `(list-of ,(simplify-type `(or ,@ts))))
+ ((eq? 'list tr) tr)
+ ((and (pair? tr) (eq? 'pair (first tr)))
+ (rec (third tr) (cons (second tr) ts)))
+ ((and (pair? tr) (eq? 'list (first tr)))
+ `(list-of ,(simplify-type `(or ,@ts ,@(cdr tr)))))
+ ((and (pair? tr) (eq? 'list-of (first tr)))
+ `(list-of
+ ,(simplify-type
+ `(or ,@(reverse ts) ,@(cdr tr)))))
+ (else #f)))))
+ ((eq? 'list (car t))
+ `(list-of ,(simplify-type `(or ,@(cdr t)))))
+ (else t)))
+
+
;;; hardcoded result types for certain primitives
(define-syntax define-special-case
diff --git a/tests/scrutiny-2.expected b/tests/scrutiny-2.expected
index 55f66029..09462606 100644
--- a/tests/scrutiny-2.expected
+++ b/tests/scrutiny-2.expected
@@ -39,10 +39,6 @@ Note: at toplevel:
in procedure call to `null?', the predicate is called with an argument of type
`null' and will always return true
-Note: at toplevel:
- in procedure call to `null?', the predicate is called with an argument of type
- `pair' and will always return false
-
Note: at toplevel:
in procedure call to `null?', the predicate is called with an argument of type
`null' and will always return true
diff --git a/tests/scrutiny-tests-2.scm b/tests/scrutiny-tests-2.scm
index 986c303b..10dde750 100644
--- a/tests/scrutiny-tests-2.scm
+++ b/tests/scrutiny-tests-2.scm
@@ -18,8 +18,8 @@
(f 12.3)
(u (+ i f)))
(predicate pair? (p) (l n i f))
- (predicate list? (l) (p n i f))
- (predicate null? (n) (p l i f))
+ (predicate list? (l n p) (i f))
+ (predicate null? (n l) (p i f))
(predicate fixnum? (i) (f u))
(predicate exact? (i) (f u))
(predicate flonum? (f) (i u))
diff --git a/tests/scrutiny.expected b/tests/scrutiny.expected
index 2a242925..b77bedb0 100644
--- a/tests/scrutiny.expected
+++ b/tests/scrutiny.expected
@@ -45,6 +45,12 @@ Warning: at toplevel:
Warning: at toplevel:
in procedure call to `g89', expected a value of type `(procedure () *)', but was given a value of type `fixnum'
+Note: in toplevel procedure `foo':
+ expected value of type boolean in conditional but were given a value of type
+ `(procedure bar29 () *)' which is always true:
+
+(if bar29 3 (##core#undefined))
+
Warning: in toplevel procedure `foo2':
scrutiny-tests.scm:57: in procedure call to `string-append', expected argument #1 of type `string', but was given an argument of type `number'
Trap