~ chicken-core (chicken-5) 94ec8c893a9ededc66ece7f48175856111e55823
commit 94ec8c893a9ededc66ece7f48175856111e55823
Author: felix <felix@call-with-current-continuation.org>
AuthorDate: Tue Aug 23 11:19:15 2011 +0200
Commit: felix <felix@call-with-current-continuation.org>
CommitDate: Tue Aug 23 11:19:15 2011 +0200
assignment bugfix by sh (also in master); blist/env smashing on call to impure procedure; purity-declaration still has to be figured out
diff --git a/scrutinizer.scm b/scrutinizer.scm
index 6cbcbe0d..f3fed28b 100755
--- a/scrutinizer.scm
+++ b/scrutinizer.scm
@@ -31,6 +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!
compatible-types? type<=? match-types resolve match-argument-types))
@@ -108,7 +109,7 @@
(define (scrutinize node db complain specialize)
- (let ((blist '())
+ (let ((blist '()) ; (((VAR . FLOW) TYPE) ...)
(aliased '())
(noreturn #f)
(dropped-branches 0)
@@ -628,9 +629,11 @@
"variable `~a' of type `~a' was modified to a value of type `~a'"
var ot rt)
#t)))))
- (when strict-variable-types
- ;; don't use "add-to-blist" since this does not affect aliases
- (set! blist (alist-cons (cons var (car flow)) rt blist))))
+ ;; don't use "add-to-blist" since the current operation does not affect aliases
+ (set! blist
+ (alist-cons (cons var (car flow))
+ (if strict-variable-types rt '*)
+ blist)))
'(undefined)))
((##core#primitive ##core#inline_ref) '*)
((##core#call)
@@ -655,8 +658,15 @@
(pt (and pn (variable-mark pn '##compiler#predicate))))
(let-values (((r specialized?)
(call-result n args e loc params typeenv)))
+ (define (smash)
+ (when (and (not strict-variable-types)
+ (or (not pn)
+ (not (variable-mark pn '##compiler#pure))))
+ (smash-component-types! e "env")
+ (smash-component-types! blist "blist")))
(cond (specialized?
(walk n e loc dest tail flow ctags)
+ (smash)
;; keep type, as the specialization may contain icky stuff
;; like "##core#inline", etc.
(if (eq? '* r)
@@ -714,7 +724,10 @@
(nth-value
0
(procedure-argument-types fn (sub1 len) typeenv))))
- r)))))
+ (smash)
+ (if (eq? '* r)
+ r
+ (map (cut resolve <> typeenv) r)))))))
((##core#the)
(let-values (((t _) (validate-type (first params) #f)))
(let ((rt (walk (first subs) e loc dest tail flow ctags)))
@@ -749,10 +762,11 @@
(quit "~ano clause applies in `compiler-typecase' for expression of type `~s':~a"
(location-name loc) (car ts)
(string-concatenate
- (map (lambda (t) (string-sprintf "\n ~a" t))
+ (map (lambda (t) (sprintf "\n ~a" t))
params))))
((match-types (car types) (car ts)
- (append (type-typeenv (car types)) typeenv))
+ (append (type-typeenv (car types)) typeenv)
+ #t)
;; drops exp
(copy-node! (car subs) n)
(walk n e loc dest tail flow ctags))
@@ -782,6 +796,24 @@
rn)))
+;;; replace pair/vector types with components to component-less variants in env or blist
+
+(define (smash-component-types! lst where)
+ (do ((lst lst (cdr lst)))
+ ((null? lst))
+ (let loop ((t (cdar lst))
+ (change! (cute set-cdr! (car lst) <>)))
+ (when (pair? t)
+ (case (car t)
+ ((pair vector)
+ (dd " smashing `~s' in ~a" (caar lst) where)
+ (change! (car t))
+ (car t))
+ ((forall)
+ (loop (third t)
+ (cute set-car! (cddr t) <>))))))))
+
+
;;; Converting type into string
(define (typename t)
@@ -1008,6 +1040,8 @@
(match1 (second t1) (second t2))
(match1 t1 (third t2))))
((and (pair? t1) (eq? 'list (car t1)))
+ ;;XXX (list T) == (pair T (pair T ... (pair T null)))
+ ; should also work in exact mode
(and (not exact) (not all)
(or (eq? 'null t2)
(and (pair? t2)
@@ -1506,20 +1540,44 @@
(new
(let adjust ((new (cadr e)))
(if (pair? new)
- (case (car new)
- ((procedure!)
- (mark-variable name '##compiler#enforce #t)
- `(procedure ,@(cdr new)))
- ((procedure!? procedure?!)
- (mark-variable name '##compiler#enforce #t)
- (mark-variable name '##compiler#predicate (cadr new))
- `(procedure ,@(cddr new)))
- ((procedure?)
- (mark-variable name '##compiler#predicate (cadr new))
- `(procedure ,@(cddr new)))
- ((forall)
- `(forall ,(cadr new) ,(adjust (caddr new))))
- (else new))
+ (cond ((and (list? (car new))
+ (eq? 'procedure (caar new)))
+ ;;XXX this format is not used yet:
+ (let loop ((props (cdar new)))
+ (unless (null? props)
+ (case (car props)
+ ((pure)
+ ;;XXX this overwrites a possibly existing 'standard/
+ ;; 'extended mark - I don't know if this is
+ ;; a problem
+ (mark-variable name '##compiler#pure #t)
+ (loop (cdr props)))
+ ((enforce)
+ (mark-variable name '##compiler#enforce #t)
+ (loop (cdr props)))
+ ((predicate)
+ (mark-variable name '##compiler#predicate (cadr props))
+ (loop (cddr props)))
+ (else
+ (bomb
+ "load-type-database: invalid procedure-type property"
+ (car props))))))
+ `(procedure ,@(cdr new)))
+ (else ;XXX old style, remove at some stage
+ (case (car new)
+ ((procedure!)
+ (mark-variable name '##compiler#enforce #t)
+ `(procedure ,@(cdr new)))
+ ((procedure!? procedure?!)
+ (mark-variable name '##compiler#enforce #t)
+ (mark-variable name '##compiler#predicate (cadr new))
+ `(procedure ,@(cddr new)))
+ ((procedure?)
+ (mark-variable name '##compiler#predicate (cadr new))
+ `(procedure ,@(cddr new)))
+ ((forall)
+ `(forall ,(cadr new) ,(adjust (caddr new))))
+ (else new))))
new))))
;; validation is needed, even though .types-files can be considered
;; correct, because type variables have to be renamed:
@@ -1649,6 +1707,8 @@
continuation lock mmap condition hash-table
tcp-listener))
`(struct ,t))
+ ((eq? t 'immediate) ;XXX undocumented
+ '(or eof null fixnum char boolean))
((not (pair? t))
(cond ((memq t typevars)
(set! usedvars (cons t usedvars))
diff --git a/tests/scrutiny-2.expected b/tests/scrutiny-2.expected
index 5a7cc085..4e2fa56a 100644
--- a/tests/scrutiny-2.expected
+++ b/tests/scrutiny-2.expected
@@ -19,10 +19,6 @@ Note: at toplevel:
in procedure call to `list?', the predicate is called with an argument of type
`list' and will always return true
-Note: at toplevel:
- in procedure call to `list?', the predicate is called with an argument of type
- `(pair fixnum fixnum)' and will always return false
-
Note: at toplevel:
in procedure call to `list?', the predicate is called with an argument of type
`null' and will always return true
@@ -41,7 +37,7 @@ Note: at toplevel:
Note: at toplevel:
in procedure call to `null?', the predicate is called with an argument of type
- `(pair fixnum fixnum)' and will always return false
+ `pair' and will always return false
Note: at toplevel:
in procedure call to `null?', the predicate is called with an argument of type
diff --git a/tests/typematch-tests.scm b/tests/typematch-tests.scm
index 1b5ce750..61622704 100644
--- a/tests/typematch-tests.scm
+++ b/tests/typematch-tests.scm
@@ -104,17 +104,15 @@
(check 'abc 1.2 symbol)
(check #\x 1.2 char)
(check #t 1.2 boolean)
-(check 123 'a number)
-(check 12.3 'a number)
-(check '(1) 1.2 list)
-(check '(a) 1.2 list)
+(check (+ 1 2) 'a number)
+(check '(1) 1.2 (pair fixnum null))
+(check '(a) 1.2 (pair symbol null))
+(check (list 1) '(1 . 2) list)
(check '(1) 1.2 pair)
(check '(1 . 2) '() pair)
(check + 1.2 procedure)
(check '#(1) 1.2 vector)
(check '() 1 null)
-(check '() 1.2 list)
-(check (void) 1.2 undefined)
(check (current-input-port) 1.2 port)
(check (make-blob 10) 1.2 blob)
(check (address->pointer 0) 1.2 pointer)
@@ -123,7 +121,7 @@
(check (##sys#make-structure 'promise) 1 (struct promise))
(check '(1 . 2.3) '(a) (pair fixnum float))
(check '#(a) 1 (vector symbol))
-(check '("ok") 1 (list string))
+(check '("ok") 1 (pair string null))
(ms 123 1.2 fixnum)
(ms "abc" 1.2 string)
@@ -145,20 +143,22 @@
(ms '(1 . 2.3) '(a) (pair fixnum float))
(ms '#(a) 1 (vector symbol))
(ms '(1) "a" (or pair symbol))
-(ms (list) 'a list)
+(ms (list 1) 'a list)
(ms '() 'a (or null pair))
+(define n 1)
+
(checkp boolean? #t boolean)
(checkp boolean? #f boolean)
(checkp pair? '(1 . 2) pair)
(checkp null? '() null)
(checkp list? '(1) list)
(checkp symbol? 'a symbol)
-(checkp number? '1 number)
-(checkp number? '1.2 number)
+(checkp number? (+ n) number)
+(checkp number? (+ n) number)
(checkp exact? '1 fixnum)
-(checkp real? '1 number)
-(checkp complex? '1 number)
+(checkp real? (+ n) number)
+(checkp complex? (+ n) number)
(checkp inexact? '1.2 float)
(checkp char? #\a char)
(checkp string? "a" string)
@@ -172,15 +172,9 @@
(checkp pointer-vector? (make-pointer-vector 1) pointer-vector)
(checkp pointer? (address->pointer 1) pointer)
-(m number fixnum)
-(m number float)
-(m list null)
-(m pair (pair number string))
-(m procedure (procedure () *))
(mn (procedure (*) *) (procedure () *))
(m (procedure (#!rest) . *) (procedure (*) . *))
(mn (procedure () *) (procedure () * *))
(mx (forall (a) (procedure (#!rest a) a)) +)
(mx (or pair null) '(1))
-(mx (or pair null) (list))
Trap