~ chicken-core (chicken-5) 225fdfc473ce834cdc76dbc184c018ff6196c45c
commit 225fdfc473ce834cdc76dbc184c018ff6196c45c
Author: felix <felix@call-with-current-continuation.org>
AuthorDate: Wed Apr 6 06:26:06 2011 -0400
Commit: felix <felix@call-with-current-continuation.org>
CommitDate: Wed Apr 6 06:26:06 2011 -0400
more specialization match tweaking
diff --git a/scrutinizer.scm b/scrutinizer.scm
index 3d9f148c..005d3419 100755
--- a/scrutinizer.scm
+++ b/scrutinizer.scm
@@ -832,28 +832,31 @@
(cond ((eq? st t))
((pair? st)
(case (car st)
- ((not)
- (cond ((and (pair? t) (eq? 'or (car t)))
- (not (any (cute match (cadr st) <>) (cdr t))))
- ((eq? '* t) #f)
- (else (not (match (cadr st) t)))))
+ ((not) (matchnot (cadr st) t))
((or) (any (cut match <> t) (cdr st)))
((and) (every (cut match <> t) (cdr st)))
+ ((procedure) (bomb "match-specialization: invalid complex procedure type" st))
(else (equal? st t))))
((eq? st '*))
- ((eq? st 'list) (match '(or null pair) t))
- ((eq? st 'number) (match '(or fixnum float) t))
- ((eq? t 'list) (match st '(or null pair)))
- ((eq? t 'number) (match st '(or fixnum float)))
- ((eq? st 'procedure)
- (or (eq? t 'procedure)
- (and (pair? t) (eq? 'procedure (car t))))) ; doesn't match argument/result types
+ ((eq? st 'list) (eq? t 'list))
+ ((eq? st 'number) (eq? t 'number))
((pair? t)
(case (car t)
- ((or) (every (cut match st <>) (cdr t))) ; must match every option
- ((and) #f) ; should not happen...
+ ((or) (any (cut match st <>) (cdr t)))
+ ((and) (every (cut match st <>) (cdr t)))
+ ((procedure) (match st 'procedure))
+ ;; (not ...) should not occur
(else (equal? st t))))
(else (equal? st t))))
+ (define (matchnot st t)
+ (cond ((eq? 'list t) (matchnot st '(or null pair)))
+ ((eq? '* t) #f)
+ ((pair? t)
+ (case (car t)
+ ((or) (every (cut matchnot st <>) (cdr t)))
+ ((and) (any (cut matchnot st <>) (cdr t)))
+ (else (not (match st t)))))
+ (else (not (match st t)))))
(let loop ((tl typelist) (atypes atypes))
(cond ((null? tl) (null? atypes))
((null? atypes) #f)
Trap