~ chicken-core (chicken-5) 504ec7a30debc416d300157ffb542e660231f08b
commit 504ec7a30debc416d300157ffb542e660231f08b
Author: Evan Hanson <evhan@foldling.org>
AuthorDate: Sun Dec 29 14:47:32 2013 +1300
Commit: Peter Bex <peter.bex@xs4all.nl>
CommitDate: Thu Jan 9 22:07:12 2014 +0100
Improve scrutiny for pair types
This avoids lossy canonicalization of pair types in the scrutinizer, and
makes type matching slightly more accurate when matching (pair ...)
forms against list/list-of types. This allows type variables in pairs to
be unified from the type environment during pair <-> list-of
comparisons. Fixes #1039.
Signed-off-by: Peter Bex <peter.bex@xs4all.nl>
diff --git a/scrutinizer.scm b/scrutinizer.scm
index d7b7dfa7..9fe3bf88 100644
--- a/scrutinizer.scm
+++ b/scrutinizer.scm
@@ -1147,14 +1147,13 @@
(every match1 (cdr t1) (cdr t2))))
(else #f) ) )
((and (pair? t1) (eq? 'pair (car t1)))
- (and (not exact) (not all)
- (pair? t2)
+ (and (pair? t2)
(case (car t2)
((list-of)
- (let ((ct1 (canonicalize-list-type t1)))
- (if ct1
- (match1 ct1 t2)
- #t))) ; inexact match
+ (and (not exact)
+ (not all)
+ (match1 (second t1) (second t2))
+ (match1 (third t1) t2)))
((list)
(and (pair? (cdr t2))
(match1 (second t1) (second t2))
@@ -1167,10 +1166,9 @@
(and (pair? t1)
(case (car t1)
((list-of)
- (let ((ct2 (canonicalize-list-type t2)))
- (if ct2
- (match1 t1 ct2)
- (and (not exact) (not all))))) ; inexact mode: ok
+ (and (not exact)
+ (match1 (second t1) (second t2))
+ (match1 t1 (third t2))))
((list)
(and (pair? (cdr t1))
(match1 (second t1) (second t2))
@@ -1348,9 +1346,8 @@
(tcdr (simplify (third t))))
(if (and (eq? '* tcar) (eq? '* tcdr))
'pair
- (let ((t `(pair ,tcar ,tcdr)))
- (or (canonicalize-list-type t)
- t)))))
+ (canonicalize-list-type
+ `(pair ,tcar ,tcdr)))))
((vector-of)
(let ((t2 (simplify (second t))))
(if (eq? t2 '*)
@@ -2172,16 +2169,11 @@
(let rec ((tr tcdr) (ts (list tcar)))
(cond ((eq? 'null tr)
`(list ,@(reverse 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 ,@(reverse ts) ,@(cdr tr)))
- ((and (pair? tr) (eq? 'list-of (first tr)))
- `(list-of
- ,(simplify-type
- `(or ,@(reverse ts) ,@(cdr tr)))))
- (else #f)))))
+ (else t)))))
(else t)))
diff --git a/tests/typematch-tests.scm b/tests/typematch-tests.scm
index 6ea5b49d..b5d9d943 100644
--- a/tests/typematch-tests.scm
+++ b/tests/typematch-tests.scm
@@ -170,6 +170,10 @@
(checkp pointer-vector? (make-pointer-vector 1) pointer-vector)
(checkp pointer? (address->pointer 1) pointer)
+(mn list null)
+(mn pair null)
+(mn pair list)
+
(mn (procedure (*) *) (procedure () *))
(m (procedure (#!rest) . *) (procedure (*) . *))
(mn (procedure () *) (procedure () * *))
@@ -177,6 +181,58 @@
(mx (forall (a) (procedure (#!rest a) a)) +)
(mx (list fixnum) '(1))
+;;; pairs
+
+(: car-alike (forall (a) ((pair a *) -> a)))
+(: cadr-alike (forall (a) ((pair * (pair a *)) -> a)))
+(: cddr-alike (forall (a) ((pair * (pair * a)) -> a)))
+
+(define car-alike car)
+(define cadr-alike cadr)
+(define cddr-alike cddr)
+
+(: l (list-of fixnum))
+(: p (pair fixnum (pair fixnum fixnum)))
+
+(define l '(1 2 3))
+(define p '(1 2 . 3))
+
+(mx fixnum (car-alike l))
+(mx fixnum (car-alike p))
+(mx fixnum (cadr-alike l))
+(mx fixnum (cadr-alike p))
+(mx list (cddr-alike l))
+(mx fixnum (cddr-alike p))
+
+(ms '(1 2) '() pair)
+(ms '() '(1 2) (not pair))
+(ms '() '(1 . 2) (not pair))
+(ms '(1 2) '(1 . 2) (pair * pair))
+(ms '(1 2) '(1 . 2) (pair * list))
+(ms '(1 2) '(1 2 3) (pair * (pair * null)))
+(ms '(1 2) '(1 2 3) (pair * (pair * (not pair))))
+(ms '(1 2 3) '(1 2) (pair * (pair * (not null))))
+(ms '(1 2 . 3) '(1 2 3) (pair * (pair * fixnum)))
+
+(m (pair * null) (list *))
+(m (pair * (list *)) (list * *))
+(m (pair * (list fixnum)) (list * fixnum))
+(m (pair fixnum (list *)) (list fixnum *))
+(m (pair fixnum (pair * null)) (list fixnum *))
+(m (pair fixnum (pair fixnum null)) (list fixnum fixnum))
+(m (pair char (list fixnum)) (list char fixnum))
+(m (pair fixnum (list char)) (list fixnum char))
+(m (pair fixnum (list fixnum)) (list fixnum fixnum))
+
+(mn (pair * *) list)
+(mn (pair * list) list)
+(mn (pair fixnum *) (list-of *))
+(mn (pair fixnum *) (list-of fixnum))
+(mn (pair fixnum (list-of *)) (list-of fixnum))
+(mn (pair fixnum (list-of fixnum)) (list-of fixnum))
+(mn (pair char (list-of fixnum)) (list-of fixnum))
+(mn (pair fixnum (list-of char)) (list-of fixnum))
+(mn (pair fixnum (list-of fixnum)) (list-of fixnum))
;;; special cases
Trap