[Top][All Lists]
[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Chicken-hackers] [PATCH] various scrutinizer bugfixes
|
From: |
Felix |
|
Subject: |
[Chicken-hackers] [PATCH] various scrutinizer bugfixes |
|
Date: |
Mon, 19 Sep 2011 13:16:01 +0200 (CEST) |
This commit fixes several problems with the scrutinizer:
- instantiations of type-variables need to be done over all alternatives
in a union ("or") type
- swapped order of "or"-type matching to handle cases where
matching two union types failed where they shouldn't
- resolution of type-variables may require type-simplification
- subtype-checking uses existing typeenv machinery
- commented out unused typecheck-generation code for the time being
- adds a few testcase
Note that without this patch the current "master" version of chicken
produces incorrect and disturbing warnings when compiling itself
(specifically "irregex.scm").
This patch is also available as commit 4c574b04 in the "felix-pending"
branch.
commit 4c574b040d5ee1e67993b1c3d6aa557741a36e5f
Author: felix <address@hidden>
Date: Mon Sep 19 13:00:52 2011 +0200
This commit fixes several problems with the scrutinizer:
- instantiations of type-variables need to be done over all alternatives
in a union ("or") type
- swapped order of "or"-type matching to handle cases where
matching two union types failed where they shouldn't
- resolution of type-variables may require type-simplification
- subtype-checking uses existing typeenv machinery
- commented out unused typecheck-generation code for the time being
- adds a few testcase
Squashed commit of the following:
commit 34f451dbcc3119c0307e503a97a512eff964e5a9
Merge: 93ccf52... 60b4a6c...
Author: felix <address@hidden>
Date: Mon Sep 19 13:00:15 2011 +0200
Merge branch 'scrutiny-fixes' into tmp
commit 60b4a6c2f7aa7dd5afb0c0ad1436177a34d634ed
Merge: 5ae00b5... e8d45b2...
Author: felix <address@hidden>
Date: Mon Sep 19 12:41:27 2011 +0200
Merge branch 'felix-pending' into scrutiny-fixes
commit 5ae00b5a16ea6cf0daeed8cc85d15eb15525ee7f
Author: felix <address@hidden>
Date: Mon Sep 19 12:28:36 2011 +0200
specialization for atan/2 in mixed fixnum/flonum case
commit 60371ba7dec19f1110e1ad79c4e4e7ac83938df2
Author: felix <address@hidden>
Date: Mon Sep 19 09:19:32 2011 +0200
specializations for expt in mixed flonum/fixnum case
commit 8c2c8764362ccf540a4a01c65c71fbf5993f00ef
Author: felix <address@hidden>
Date: Mon Sep 19 08:39:54 2011 +0200
correct order of OR-type matching; slight simplification of o-a-i;
added testcase
commit 032448a84ef067d4dc786916565efe34e26c0468
Author: felix <address@hidden>
Date: Sat Sep 17 15:16:54 2011 +0200
list-of is not a subtype of pair or fixed-length list; factored out
setting up of final instantiations of vars in over-all-instantiations; fixed
bugs in the latter
commit b629144e1f3127f3ae664a07670542df95ea2a32
Author: felix <address@hidden>
Date: Fri Sep 16 23:52:16 2011 +0200
scrutiny not completely broken anymore, but still feels flaky
commit feeec2010eaab6386a4890cf13c7691a62b96073
Author: felix <address@hidden>
Date: Fri Sep 16 23:51:38 2011 +0200
tiny fix in compile-all script
commit 85dd3577a145b344db34d5037d3a841bca209304
Author: felix <address@hidden>
Date: Fri Sep 16 23:51:19 2011 +0200
removed compile-all target (slightly broken and redundant)
commit 3aa6214bf4b8ef80f228bc2b1ef0eb0d9720e2e7
Author: felix <address@hidden>
Date: Fri Sep 16 18:39:53 2011 +0200
added debugging output
commit 593bb9b84d622f79dc838d95f558ddad8cf108b2
Author: felix <address@hidden>
Date: Fri Sep 16 18:25:55 2011 +0200
combine typevar instantiations over all elements of 'or' types; type<=?
does the same and uses usual typeenv mechanisms
commit 4a06a44531806cfa8306c6076f96e33613401ebf
Author: felix <address@hidden>
Date: Fri Sep 16 14:36:05 2011 +0200
trying to reduce list-type complexity, variable unification results in
incorrect instantiation when multiple alternatives exist, i.e. (list-of a) =
(list (or X Y)) - first match insantiates a, second is ignored, but must match,
too
diff --git a/scrutinizer.scm b/scrutinizer.scm
index 895481e..61971bc 100755
--- a/scrutinizer.scm
+++ b/scrutinizer.scm
@@ -31,7 +31,7 @@
noreturn-type? rest-type procedure-name d-depth
noreturn-procedure-type? trail trail-restore
typename multiples procedure-arguments procedure-results
- smash-component-types! generate-type-checks!
+ smash-component-types! generate-type-checks! over-all-instantiations
compatible-types? type<=? match-types resolve match-argument-types))
@@ -155,14 +155,6 @@
(cond ((variable-mark id '##compiler#type) =>
(lambda (a)
(cond
- #| XXX Disabled, since this would remove specializations in
core library
- code, where these get assigned. Still, it would be safer
to
- unmark assigned vars...
- ((and (get db id 'assigned) ; remove assigned global from type
db
- (not (variable-mark id '##compiler#declared-type)))
- (mark-variable id '##compiler#type #f)
- '(*))
- |#
((eq? a 'deprecated)
(report
loc
@@ -346,7 +338,6 @@
(when (noreturn-procedure-type? ptype)
(set! noreturn #t))
(let ((r (procedure-result-types ptype values-rest (cdr args)
typeenv)))
- ;;XXX we should check whether this is a standard- or
extended binding
(let* ((pn (procedure-name ptype))
(trail0 trail))
(when pn
@@ -613,7 +604,7 @@
"assignment of value of type `~a' to toplevel
variable `~a' does not match declared type `~a'"
rt var type)
#t))
- (when (and (not type)
+ (when (and (not type) ;XXX global declaration could allow
this
(not b)
(not (eq? '* rt))
(not (get db var 'unknown)))
@@ -645,7 +636,7 @@
(alist-cons
(cons var (car flow))
(if (or strict-variable-types
- ;;XXX needs to be tested more
+ ;;XXX needs to be tested more but might be
worth it
#;(not (get db var 'captured)))
rt
'*)
@@ -705,10 +696,6 @@
(not (get db var
'assigned))
(not oparg?))))
(cond (pred
- ;;XXX we could add a blist entry for
var in the other
- ;; branch by subtracting pt from
the current type
- ;; of var, at least in the simple
case of
- ;; "(or ... <PT> ...)" -> "(or
... ...)"
(let ((pt (resolve pt typeenv)))
(d " predicate `~a' indicates
`~a' is ~a in flow ~a"
pn var pt (car ctags))
@@ -804,15 +791,15 @@
(let ((rn (walk (first (node-subexpressions node)) '() '() #f #f (list
(tag)) #f)))
(when (and (pair? specialization-statistics)
- (debugging 'x "specializations:")) ;XXX
+ (debugging 'x "specializations:")) ;XXX use 'o
(for-each
(lambda (ss)
(printf " ~a ~s~%" (cdr ss) (car ss)))
specialization-statistics))
(when (positive? safe-calls)
- (debugging 'x "safe calls" safe-calls)) ;XXX
+ (debugging 'x "safe calls" safe-calls)) ;XXX use 'o
(when (positive? dropped-branches)
- (debugging 'x "dropped branches" dropped-branches)) ;XXX
+ (debugging 'x "dropped branches" dropped-branches)) ;XXX use 'o
rn)))
@@ -963,14 +950,6 @@
(match-results (cdr results1) (cdr results2)))
(else #f)))
- (define (match1/restore t1 t2)
- (let* ((trail0 trail)
- (m (match1 t1 t2)))
- (cond (m)
- (else
- (trail-restore trail0 typeenv)
- #f))))
-
(define (rawmatch1 t1 t2)
(fluid-let ((exact #f)
(all #f))
@@ -978,12 +957,11 @@
(define (match1 t1 t2)
;; note: the order of determining the type is important
- ;;(dd " match1: ~s <-> ~s" t1 t2)
+ (dd " match1: ~s <-> ~s" t1 t2)
(cond ((eq? t1 t2))
;;XXX do we have to handle circularities?
((and (symbol? t1) (assq t1 typeenv)) =>
(lambda (e)
- ;;XXX is "raw" matching for constraints correct?
(cond ((second e)
(and (match1 (second e) t2)
(or (not (third e)) ; constraint
@@ -1032,10 +1010,25 @@
(m (match1 t1 (cadr t2))))
(trail-restore trail0 typeenv)
(not m))))
- ((and (pair? t1) (eq? 'or (car t1)))
- (any (cut match1/restore <> t2) (cdr t1)))
+ ;; this is subtle: "or" types for t2 are less restrictive,
+ ;; so we handle them before "or" types for t1
((and (pair? t2) (eq? 'or (car t2)))
- ((if (or exact all) every any) (cut match1/restore t1 <>) (cdr t2)))
+ (over-all-instantiations
+ (cdr t2)
+ typeenv
+ (lambda (t) (match1 t1 t))
+ (lambda ()
+ (if (or exact all)
+ (every
+ (cut match1 t1 <>)
+ (cdr t2))
+ #t))))
+ ;; s.a.
+ ((and (pair? t1) (eq? 'or (car t1)))
+ (over-all-instantiations
+ (cdr t1)
+ typeenv
+ (lambda (t) (match1 t t2)))) ; o-a-i ensures at least one element
matches
((and (pair? t1) (eq? 'forall (car t1)))
(match1 (third t1) t2)) ; assumes typeenv has already been extracted
((and (pair? t2) (eq? 'forall (car t2)))
@@ -1104,12 +1097,11 @@
(and (pair? t1)
(case (car t1)
((list-of)
- (and (not exact)
+ (and ;(not exact)
(match1 (second t1) (second t2))
(match1 t1 (third t2))))
((list)
(and (match1 (second t1) (second t2))
- (or (not exact) (pair? (cdr t1)))
(match1 (if (null? (cdr t1))
'null
`(list ,@(cddr t1)))
@@ -1297,8 +1289,14 @@
(if (and (eq? '* tcar) (eq? '* tcdr))
'pair
(let rec ((tr tcdr) (ts (list tcar)))
- (cond ((and (pair? tr) (eq? 'pair (first tr)))
+ (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)))))))
((vector-of)
(let ((t2 (simplify (second t))))
@@ -1395,134 +1393,137 @@
(define (type<=? t1 t2)
- (let ((typeenv '()) ; ((VAR1 . TYPE1) ...)
- (constraints '())) ; ((VAR1 TYPE1) ...)
-
- (define (extract-vars tv)
- (set! typeenv
- (append (map (lambda (v)
- (cons (if (symbol? v) v (first v)) #f))
- tv)
- typeenv))
- (set! constraints
- (append (filter-map
- (lambda (v)
- (and (pair? v) v))
- tv)
- constraints)))
-
- (cond ((eq? t1 t2))
- ;;XXX do we need to handle circularities in typevar-references?
- ((and (symbol? t1) (assq t1 typeenv)) =>
- (lambda (e)
- (if (cdr e)
- (type<=? (cdr e) t2)
- (begin
- (set-cdr! e t2)
- (cond ((assq t1 constraints) =>
- (lambda (c) (type<=? (second c) t2)))
- (else #t))))))
- ((and (symbol? t2) (assq t2 typeenv)) =>
- (lambda (e)
- (if (cdr e)
- (type<=? t1 (cdr e))
- (begin
- (set-cdr! e t1)
- (cond ((assq t2 constraints) =>
- (lambda (c) (type<=? t1 (second c))))
- (else #t))))))
- ((memq t2 '(* undefined)))
- ((eq? 'pair t1) (type<=? '(pair * *) t2))
- ((memq t1 '(vector list)) (type<=? `(,t1 *) t2))
- ((and (eq? 'null t1)
- (pair? t2)
- (eq? (car t2) 'list-of)))
- ((and (pair? t1) (eq? 'forall (car t1)))
- (extract-vars (second t1))
- (type<=? (third t1) t2))
- ((and (pair? t2) (eq? 'forall (car t2)))
- (extract-vars (second t2))
- (type<=? t1 (third t2)))
- (else
- (case t2
- ((procedure) (and (pair? t1) (eq? 'procedure (car t1))))
- ((number) (memq t1 '(fixnum float)))
- ((vector) (type<=? t1 '(vector-of *)))
- ((list) (type<=? t1 '(list-of *)))
- ((pair) (type<=? t1 '(pair * *)))
- (else
- (cond ((not (pair? t1)) #f)
- ((not (pair? t2)) #f)
- ((eq? 'or (car t2))
- (every (cut type<=? t1 <>) (cdr t2)))
- ((and (eq? 'vector (car t1)) (eq? 'vector-of (car t2)))
- (every (cute type<=? <> (second t2)) (cdr t1)))
- ((and (eq? 'vector-of (car t1)) (eq? 'vector (car t2)))
- (every (cute type<=? (second t1) <>) (cdr t2)))
- ((and (eq? 'list (car t1)) (eq? 'list-of (car t2)))
- (every (cute type<=? <> (second t2)) (cdr t1)))
- ((and (eq? 'list-of (car t1)) (eq? 'list (car t2)))
- (every (cute type<=? (second t1) <>) (cdr t2)))
- ((not (eq? (car t1) (car t2))) #f)
+ (let* ((typeenv (append-map type-typeenv (list t1 t2)))
+ (trail0 trail)
+ (r (let test ((t1 t1) (t2 t2))
+ (cond ((eq? t1 t2))
+ ((and (symbol? t1) (assq t1 typeenv)) =>
+ (lambda (e)
+ (cond ((second e) (test (second e) t2))
+ (else
+ (set-car! (cdr e) t2)
+ (or (not (third e))
+ (test (third e) t2))))))
+ ((and (symbol? t2) (assq t2 typeenv)) =>
+ (lambda (e)
+ (cond ((second e) (test t1 (second e)))
+ (else
+ (set-cdr! e t1)
+ (or (not (third e))
+ (test t1 (third e)))))))
+ ((memq t2 '(* undefined)))
+ ((eq? 'pair t1) (test '(pair * *) t2))
+ ((memq t1 '(vector list)) (test `(,t1 *) t2))
+ ((and (eq? 'null t1)
+ (pair? t2)
+ (eq? (car t2) 'list-of)))
+ ((and (pair? t1) (eq? 'forall (car t1)))
+ (test (third t1) t2))
+ ((and (pair? t2) (eq? 'forall (car t2)))
+ (test t1 (third t2)))
(else
- (case (car t1)
- ((or) (every (cut type<=? <> t2) (cdr t1)))
- ((vector-of list-of) (type<=? (second t1) (second t2)))
- ((pair) (every type<=? (cdr t1) (cdr t2)))
- ((procedure)
- (let ((args1 (if (named? t1) (caddr t1) (cadr t1)))
- (args2 (if (named? t2) (caddr t2) (cadr t2)))
- (res1 (if (named? t1) (cdddr t1) (cddr t1)))
- (res2 (if (named? t2) (cdddr t2) (cddr t2))) )
- (let loop1 ((args1 args1)
- (args2 args2)
- (rtype1 #f)
- (rtype2 #f)
- (m1 0)
- (m2 0))
- (cond ((null? args1)
- (and (cond ((null? args2)
- (if rtype1
- (if rtype2
- (type<=? rtype1 rtype2)
- #f)
- #t))
- ((eq? '#!optional (car args2))
- (not rtype1))
- ((eq? '#!rest (car args2))
- (or (null? (cdr args2))
- rtype1
- (type<=? rtype1 (cadr
args2))))
- (else (>= m2 m1)))
- (let loop2 ((res1 res1) (res2 res2))
- (cond ((eq? '* res2) #t)
- ((null? res2) (null? res1))
- ((eq? '* res1) #f)
- ((type<=? (car res1) (car res2))
- (loop2 (cdr res1) (cdr res2)))
- (else #f)))))
- ((eq? (car args1) '#!optional)
- (loop1 (cdr args1) args2 #f rtype2 1 m2))
- ((eq? (car args1) '#!rest)
- (if (null? (cdr args1))
- (loop1 '() args2 '* rtype2 2 m2)
- (loop1 '() args2 (cadr args1) rtype2 2
m2)))
- ((null? args2)
- (and rtype2
- (type<=? (car args1) rtype2)
- (loop1 (cdr args1) '() rtype1 rtype2 m1
m2)))
- ((eq? (car args2) '#!optional)
- (loop1 args1 (cdr args2) rtype1 #f m1 1))
- ((eq? (car args2) '#!rest)
- (if (null? (cdr args2))
- (loop1 args1 '() rtype1 '* m1 2)
- (loop1 args1 '() rtype1 (cadr args2) m1
2)))
- ((type<=?
- (or rtype1 (car args1))
- (or rtype2 (car args2)))
- (loop1 (cdr args1) (cdr args2) rtype1 rtype2
m1 m2))
- (else #f)))))
- (else #f))))))))))
+ (case t2
+ ((procedure) (and (pair? t1) (eq? 'procedure (car t1))))
+ ((number) (memq t1 '(fixnum float)))
+ ((vector) (test t1 '(vector-of *)))
+ ((list) (test t1 '(list-of *)))
+ ((pair) (test t1 '(pair * *)))
+ (else
+ (cond ((not (pair? t1)) #f)
+ ((not (pair? t2)) #f)
+ ((eq? 'or (car t2))
+ (over-all-instantiations
+ (cdr t2)
+ typeenv
+ (lambda (t) (test t1 t))
+ (lambda ()
+ (every (cut test t1 <>) (cdr t2)))))
+ ((and (eq? 'vector (car t1)) (eq? 'vector-of (car
t2)))
+ (every (cute test <> (second t2)) (cdr t1)))
+ ((and (eq? 'vector-of (car t1)) (eq? 'vector (car
t2)))
+ (every (cute test (second t1) <>) (cdr t2)))
+ ((and (eq? 'list (car t1)) (eq? 'list-of (car
t2)))
+ (every (cute test <> (second t2)) (cdr t1)))
+ ((and (eq? 'list (car t1)) (eq? 'pair (car t2)))
+ (and (not (null? (cdr t1)))
+ (test (second t1) (second t2))
+ (test t1 (third t2))))
+ ((and (eq? 'pair (car t1)) (eq? 'list (car t2)))
+ (and (not (null? (cdr t2)))
+ (test (second t1) (second t2))
+ (test (third t1) t2)))
+ ((and (eq? 'pair (car t1)) (eq? 'list-of (car
t2)))
+ (and (test (second t1) (second t2))
+ (test (third t1) t2)))
+ ((not (eq? (car t1) (car t2))) #f)
+ (else
+ (case (car t1)
+ ((or)
+ (over-all-instantiations
+ (cdr t1)
+ typeenv
+ (lambda (t) (test t t2))
+ (lambda ()
+ (every (cut test <> t2) (cdr t1)))))
+ ((vector-of list-of) (test (second t1) (second
t2)))
+ ((pair) (every test (cdr t1) (cdr t2)))
+ ((procedure)
+ (let ((args1 (if (named? t1) (caddr t1) (cadr
t1)))
+ (args2 (if (named? t2) (caddr t2) (cadr
t2)))
+ (res1 (if (named? t1) (cdddr t1) (cddr
t1)))
+ (res2 (if (named? t2) (cdddr t2) (cddr
t2))) )
+ (let loop1 ((args1 args1)
+ (args2 args2)
+ (rtype1 #f)
+ (rtype2 #f)
+ (m1 0)
+ (m2 0))
+ (cond ((null? args1)
+ (and (cond ((null? args2)
+ (if rtype1
+ (if rtype2
+ (test rtype1
rtype2)
+ #f)
+ #t))
+ ((eq? '#!optional (car
args2))
+ (not rtype1))
+ ((eq? '#!rest (car
args2))
+ (or (null? (cdr args2))
+ rtype1
+ (test rtype1 (cadr
args2))))
+ (else (>= m2 m1)))
+ (let loop2 ((res1 res1) (res2
res2))
+ (cond ((eq? '* res2) #t)
+ ((null? res2) (null?
res1))
+ ((eq? '* res1) #f)
+ ((test (car res1)
(car res2))
+ (loop2 (cdr res1)
(cdr res2)))
+ (else #f)))))
+ ((eq? (car args1) '#!optional)
+ (loop1 (cdr args1) args2 #f rtype2
1 m2))
+ ((eq? (car args1) '#!rest)
+ (if (null? (cdr args1))
+ (loop1 '() args2 '* rtype2 2
m2)
+ (loop1 '() args2 (cadr args1)
rtype2 2 m2)))
+ ((null? args2)
+ (and rtype2
+ (test (car args1) rtype2)
+ (loop1 (cdr args1) '() rtype1
rtype2 m1 m2)))
+ ((eq? (car args2) '#!optional)
+ (loop1 args1 (cdr args2) rtype1 #f
m1 1))
+ ((eq? (car args2) '#!rest)
+ (if (null? (cdr args2))
+ (loop1 args1 '() rtype1 '* m1
2)
+ (loop1 args1 '() rtype1 (cadr
args2) m1 2)))
+ ((test
+ (or rtype1 (car args1))
+ (or rtype2 (car args2)))
+ (loop1 (cdr args1) (cdr args2)
rtype1 rtype2 m1 m2))
+ (else #f)))))
+ (else #f)))))))))))
+ (set! trail trail0)
+ ;;(dd "type<=?: ~s <-> ~s -> ~s" t1 t2 r)
+ r))
;;; various operations on procedure types
@@ -1699,46 +1700,47 @@
(set-car! (cdr a) #f))))
(define (resolve t typeenv)
- (let resolve ((t t) (done '()))
- (cond ((assq t typeenv) =>
- (lambda (a)
- (let ((t2 (second a)))
- (if (or (not t2)
- (memq t2 done)) ; circular reference
- (if (third a)
- (resolve (third a) (cons t done))
- '*)
- (resolve t2 (cons t done))))))
- ((not (pair? t))
- (if (memq t '(* fixnum eof char string symbol float number list
vector pair
- undefined blob port pointer locative boolean
pointer-vector
- null procedure noreturn))
- t
- (bomb "resolve: can't resolve unknown type-variable" t)))
- (else
- (case (car t)
- ((or) `(or ,@(map (cut resolve <> done) (cdr t))))
- ((not) `(not ,(resolve (second t) done)))
- ((forall) `(forall ,(second t) ,(resolve (third t) done)))
- ((pair list vector vector-of list-of)
- (cons (car t) (map (cut resolve <> done) (cdr t))))
- ((procedure)
- (let* ((argtypes (procedure-arguments t))
- (rtypes (procedure-results t)))
- `(procedure
- ,(let loop ((args argtypes))
- (cond ((null? args) '())
- ((eq? '#!rest (car args))
- (if (equal? '(values) (cdr args))
- args
- (cons (car args) (loop (cdr args)))))
- ((eq? '#!optional (car args))
- (cons (car args) (loop (cdr args))))
- (else (cons (resolve (car args) done) (loop (cdr
args))))))
- ,@(if (eq? '* rtypes)
- '*
- (map (cut resolve <> done) rtypes)))))
- (else t))))))
+ (simplify-type ;XXX do only when necessary
+ (let resolve ((t t) (done '()))
+ (cond ((assq t typeenv) =>
+ (lambda (a)
+ (let ((t2 (second a)))
+ (if (or (not t2)
+ (memq t2 done)) ; circular reference
+ (if (third a)
+ (resolve (third a) (cons t done))
+ '*)
+ (resolve t2 (cons t done))))))
+ ((not (pair? t))
+ (if (memq t '(* fixnum eof char string symbol float number list
vector pair
+ undefined blob port pointer locative boolean
pointer-vector
+ null procedure noreturn))
+ t
+ (bomb "resolve: can't resolve unknown type-variable" t)))
+ (else
+ (case (car t)
+ ((or) `(or ,@(map (cut resolve <> done) (cdr t))))
+ ((not) `(not ,(resolve (second t) done)))
+ ((forall) `(forall ,(second t) ,(resolve (third t) done)))
+ ((pair list vector vector-of list-of)
+ (cons (car t) (map (cut resolve <> done) (cdr t))))
+ ((procedure)
+ (let* ((argtypes (procedure-arguments t))
+ (rtypes (procedure-results t)))
+ `(procedure
+ ,(let loop ((args argtypes))
+ (cond ((null? args) '())
+ ((eq? '#!rest (car args))
+ (if (equal? '(values) (cdr args))
+ args
+ (cons (car args) (loop (cdr args)))))
+ ((eq? '#!optional (car args))
+ (cons (car args) (loop (cdr args))))
+ (else (cons (resolve (car args) done) (loop (cdr
args))))))
+ ,@(if (eq? '* rtypes)
+ '*
+ (map (cut resolve <> done) rtypes)))))
+ (else t)))))))
;;; type-db processing
@@ -1935,26 +1937,28 @@
((eq? 'forall (car t))
(and (= 3 (length t))
(list? (second t))
- (begin
- (set! typevars
- (append (map (lambda (tv)
- (if (symbol? tv) tv (first tv)))
- (second t))
- typevars))
- (set! constraints
- (append (filter-map
- (lambda (tv)
- (and (pair? tv) tv))
- (second t))
- constraints))
- (and
- (every (lambda (tv)
- (or (symbol? tv)
- (and (list? tv)
- (= 2 (length tv))
- (symbol? (first tv))
- (validate (second tv)))))
- (second t))
+ (call/cc
+ (lambda (return)
+ (set! typevars
+ (append (map (lambda (tv)
+ (cond ((symbol? tv) tv)
+ ((and (list? tv)
+ (= 2 (length tv))
+ (symbol? (car tv)))
+ (car tv))
+ (else (return #f))))
+ (second t))
+ typevars))
+ (set! constraints
+ (append (filter-map
+ (lambda (tv)
+ (and (pair? tv)
+ (list (car tv)
+ (let ((t (validate (cadr tv))))
+ (unless t (return #f))
+ t))))
+ (second t))
+ constraints))
(validate (third t) rec)))))
((eq? 'or (car t))
(and (list? t)
@@ -2154,7 +2158,7 @@
;
;XXX not used in the moment
-(define (generate-type-checks! node loc vars inits)
+#;(define (generate-type-checks! node loc vars inits)
;; assumes type is validated
(define (test t v)
(case t
@@ -2269,3 +2273,62 @@
v t)
,v))))
b))))))))
+
+
+;;; perform check over all typevar instantiations
+
+(define (over-all-instantiations tlist typeenv process #!optional (combine
(constantly #t)))
+ (let ((insts '())
+ (anyinst #f)
+ (trail0 trail))
+
+ ;; restore trail and collect instantiations
+ (define (restore)
+ ;;(dd "restoring, trail: ~s, te: ~s" trail typeenv) ;XXX remove
+ (let ((is '()))
+ (do ((tr trail (cdr tr)))
+ ((eq? tr trail0)
+ (set! trail tr)
+ (when (pair? is) (set! anyinst #t))
+ (set! insts (cons is insts)))
+ (set! is (alist-cons
+ (car tr)
+ (resolve (car tr) typeenv)
+ is))
+ ;; (dd " restoring ~a, insts: ~s" (car tr) insts) ;XXX remove
+ (let ((a (assq (car tr) typeenv)))
+ (set-car! (cdr a) #f)))))
+
+ ;; collect candidates for each typevar
+ (define (collect)
+ (let* ((vars (delete-duplicates (concatenate (map unzip1 insts)) eq?))
+ ;;(_ (dd "vars: ~s, insts: ~s" vars insts)) ;XXX remove
+ (all (map (lambda (var)
+ (cons
+ var
+ (map (lambda (inst)
+ (cond ((assq var inst) => cdr)
+ (else '*)))
+ insts)))
+ vars)))
+ ;;(dd " collected: ~s" all) ;XXX remove
+ all))
+
+ (dd " over-all-instantiations: ~s" tlist) ;XXX remove
+ ;; process all tlist elements
+ (let loop ((ts tlist) (ok #f))
+ (cond ((null? ts)
+ (cond ((or ok (null? tlist))
+ (for-each
+ (lambda (i)
+ (set! trail (cons (car i) trail))
+ (set-car! (cdr (assq (car i) typeenv)) `(or ,@(cdr i))))
+ (collect))
+ (combine))
+ (else #f)))
+ ((process (car ts))
+ (restore)
+ (loop (cdr ts) #t))
+ (else
+ (restore)
+ (loop (cdr ts) ok))))))
diff --git a/tests/typematch-tests.scm b/tests/typematch-tests.scm
index eb437e0..bbb50cf 100644
--- a/tests/typematch-tests.scm
+++ b/tests/typematch-tests.scm
@@ -199,3 +199,16 @@
(mx fixnum (##sys#vector-ref '#(1 2 3.4) 0))
(mx (vector fixnum float) (vector 1 2.3))
(mx (list fixnum float) (list 1 2.3))
+
+(: f1 (forall (a) ((list-of a) -> a)))
+(define (f1 x) (car x))
+(mx fixnum (f1 '(1)))
+
+(: f2 (forall (a) ((list-of a) -> a)))
+(define (f2 x) (car x))
+(assert
+ (eq? 'sf
+ (compiler-typecase (f2 (list (if bar 1 'a)))
+ (symbol 's)
+ (fixnum 'f)
+ ((or fixnum symbol) 'sf))))
- [Chicken-hackers] [PATCH] various scrutinizer bugfixes,
Felix <=