~ chicken-core (chicken-5) c8165a2dc0f8f6ec26afc5f0ad3bbaa0a54a662c
commit c8165a2dc0f8f6ec26afc5f0ad3bbaa0a54a662c
Author: felix <felix@call-with-current-continuation.org>
AuthorDate: Thu Aug 11 11:45:33 2011 +0200
Commit: felix <felix@call-with-current-continuation.org>
CommitDate: Thu Aug 11 11:45:33 2011 +0200
type-handling bugfixes; disable debug output during loading of type dbs
diff --git a/compiler-namespace.scm b/compiler-namespace.scm
index 6d4d6ff1..90963b00 100644
--- a/compiler-namespace.scm
+++ b/compiler-namespace.scm
@@ -255,6 +255,7 @@
scan-toplevel-assignments
scan-used-variables
scrutinize
+ scrutiny-debug
set-real-name!
sexpr->node
simple-lambda-node?
diff --git a/scrutinizer.scm b/scrutinizer.scm
index 970504f2..e5460cdd 100755
--- a/scrutinizer.scm
+++ b/scrutinizer.scm
@@ -38,9 +38,10 @@
(define d-depth 0)
+(define scrutiny-debug #t)
(define (d fstr . args)
- (when (##sys#fudge 13)
+ (when (and scrutiny-debug (##sys#fudge 13))
(printf "[debug|~a] ~a~?~%" d-depth (make-string d-depth #\space) fstr args)) )
(define dd d)
@@ -126,7 +127,7 @@
((eof-object? lit) 'eof)
((vector? lit)
(simplify-type
- `(vector (or ,@(map constant-result lit)))))
+ `(vector (or ,@(map constant-result (vector->list lit))))))
((and (not (##sys#immediate? lit)) (##sys#generic-structure? lit))
`(struct ,(##sys#slot lit 0)))
((char? lit) 'char)
@@ -876,6 +877,7 @@
(merge-result-types rtypes1 rtypes2))))
#f
(cdr t))))
+ ((lset= eq? '(fixnum float) (cdr t)) 'number)
(else
(let* ((ts (append-map
(lambda (t)
@@ -911,7 +913,7 @@
(else `(pair ,tcar ,tcdr)))))))
((vector list)
(let ((t2 (simplify (second t))))
- (if (eq? ts '*)
+ (if (eq? t2 '*)
(car t)
`(,(car t) ,t2))))
((procedure)
@@ -973,83 +975,88 @@
(cond ((eq? t1 t2))
((memq t2 '(* undefined)))
((eq? 'pair t1) (type<=? '(pair * *) t2))
- ((memq t1 '(vector list)) (type<=? `(,(car t1) *) t2))
+ ((memq t1 '(vector list)) (type<=? `(,t1 *) t2))
((and (eq? 'null t1)
(pair? t2)
- (memq (car t1) '(pair list))))
+ (memq (car t2) '(pair list))))
(else
(case t2
((procedure) (and (pair? t1) (eq? 'procedure (car t1))))
((number) (memq t1 '(fixnum float)))
- ((vector list) (type<=? t1 `(,(car t2) *)))
+ ((vector list) (type<=? t1 `(,t2 *)))
((pair) (type<=? t1 '(pair * *)))
(else
- (and (pair? t1) (pair? t2)
- (case (car t1)
- ((or) (every (cut type<=? <> t2) (cdr t1)))
- ((vector) (type<=? (second t1) (second t2)))
- ((list)
- (case (car t2)
- ((list) (type<=? (second t1) (second t2)))
- ((pair)
- (and (type<=? (second t1) (second t2))
- (type<=? t1 (third t2))))
- (else #f)))
- ((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))))))))
+ (cond ((not (pair? t1)) #f)
+ ((not (pair? t2)) #f)
+ ((eq? 'or (car t2))
+ (every (cut type<=? t1 <>) (cdr t2)))
+ ((not (eq? (car t1) (car t2))) #f)
+ (else
+ (case (car t1)
+ ((or) (every (cut type<=? <> t2) (cdr t1)))
+ ((vector) (type<=? (second t1) (second t2)))
+ ((list)
+ (case (car t2)
+ ((list) (type<=? (second t1) (second t2)))
+ ((pair)
+ (and (type<=? (second t1) (second t2))
+ (type<=? t1 (third t2))))
+ (else #f)))
+ ((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)))))))))
(define (procedure-type? t)
@@ -1132,40 +1139,41 @@
(define (load-type-database name #!optional (path (repository-path)))
(and-let* ((dbfile (file-exists? (make-pathname path name))))
(debugging 'p (sprintf "loading type database ~a ...~%" dbfile))
- (for-each
- (lambda (e)
- (let* ((name (car e))
- (old (variable-mark name '##compiler#type))
- (new (cadr e))
- (specs (and (pair? (cddr e)) (cddr e))))
- (when (pair? new)
- (case (car new)
- ((procedure!)
- (mark-variable name '##compiler#enforce #t)
- (set-car! new 'procedure))
- ((procedure!? procedure?!)
- (mark-variable name '##compiler#enforce #t)
- (mark-variable name '##compiler#predicate (cadr new))
- (set! new (cons 'procedure (cddr new))))
- ((procedure?)
- (mark-variable name '##compiler#predicate (cadr new))
- (set! new (cons 'procedure (cddr new))))))
- (cond-expand
- (debugbuild
- (let-values (((t _) (validate-type new name)))
- (unless t
- (warning "invalid type specification" name new))))
- (else))
- (when (and old (not (compatible-types? old new)))
- (warning
- (sprintf
- "type-definition `~a' for toplevel binding `~a' conflicts with previously loaded type `~a'"
- name new old)))
- (mark-variable name '##compiler#type new)
- (when specs
- ;;XXX validate types in specs
- (mark-variable name '##compiler#specializations specs))))
- (read-file dbfile))))
+ (fluid-let ((scrutiny-debug #f))
+ (for-each
+ (lambda (e)
+ (let* ((name (car e))
+ (old (variable-mark name '##compiler#type))
+ (new (cadr e))
+ (specs (and (pair? (cddr e)) (cddr e))))
+ (when (pair? new)
+ (case (car new)
+ ((procedure!)
+ (mark-variable name '##compiler#enforce #t)
+ (set-car! new 'procedure))
+ ((procedure!? procedure?!)
+ (mark-variable name '##compiler#enforce #t)
+ (mark-variable name '##compiler#predicate (cadr new))
+ (set! new (cons 'procedure (cddr new))))
+ ((procedure?)
+ (mark-variable name '##compiler#predicate (cadr new))
+ (set! new (cons 'procedure (cddr new))))))
+ (cond-expand
+ (debugbuild
+ (let-values (((t _) (validate-type new name)))
+ (unless t
+ (warning "invalid type specification" name new))))
+ (else))
+ (when (and old (not (compatible-types? old new)))
+ (warning
+ (sprintf
+ "type-definition `~a' for toplevel binding `~a' conflicts with previously loaded type `~a'"
+ name new old)))
+ (mark-variable name '##compiler#type new)
+ (when specs
+ ;;XXX validate types in specs
+ (mark-variable name '##compiler#specializations specs))))
+ (read-file dbfile)))))
(define (emit-type-file filename db)
(with-output-to-file filename
Trap