~ chicken-core (chicken-5) 108fef13b40dc150cdc6ac2f096a35c83756edaa
commit 108fef13b40dc150cdc6ac2f096a35c83756edaa
Author: felix <felix@call-with-current-continuation.org>
AuthorDate: Sun Aug 21 12:44:18 2011 +0200
Commit: felix <felix@call-with-current-continuation.org>
CommitDate: Sun Aug 21 12:44:18 2011 +0200
various scrutiny bugfixes
diff --git a/TODO b/TODO
index ee63a1e4..48e41113 100644
--- a/TODO
+++ b/TODO
@@ -2,6 +2,7 @@ TODO -*- Outline -*-
* replace "types.db" with "types.db.new"
+** rm ./xchicken
* enable specialization in "common-declarations.scm" and "tweaks.scm"
diff --git a/scrutinizer.scm b/scrutinizer.scm
index 17c2ca6a..5d997ef7 100755
--- a/scrutinizer.scm
+++ b/scrutinizer.scm
@@ -377,7 +377,6 @@
(else (trail-restore trail0 typeenv)))))
((and specialize (get-specializations pn)) =>
(lambda (specs)
- (dd " specializing: ~s" pn)
(let loop ((specs specs))
(and (pair? specs)
(let* ((spec (car specs))
@@ -514,7 +513,8 @@
(cond (nor1 r2)
(nor2 r1)
(else
- (map (lambda (t1 t2) (simplify-type `(or ,t1 ,t2)))
+ (map (lambda (t1 t2)
+ (simplify-type `(or ,t1 ,t2)))
r1 r2))))
(else '*))))))
((let)
@@ -1034,6 +1034,13 @@
(define (simplify-type t)
(let ((typeenv '())) ; ((VAR1 . NEWVAR1) ...)
+ (define (subst x)
+ (cond ((symbol? x)
+ (cond ((assq x typeenv) => cdr)
+ (else x)))
+ ((pair? x)
+ (cons (subst (car x)) (subst (cdr x))))
+ (else x)))
(define (rename v)
(cond ((assq v typeenv) => cdr)
(else
@@ -1041,6 +1048,7 @@
(set! typeenv (alist-cons v new typeenv))
new))))
(define (simplify t)
+ ;;(dd "simplify/rec: ~s" t)
(call/cc
(lambda (return)
(cond ((pair? t)
@@ -1050,49 +1058,50 @@
(append (map (lambda (v) (cons v (gensym v))) (second t)) typeenv))
(simplify (third t)))
((or)
- (cond ((= 2 (length t)) (simplify (second t)))
- ((every procedure-type? (cdr t))
- (if (any (cut eq? 'procedure <>) (cdr t))
- 'procedure
- (reduce
- (lambda (t pt)
- (let* ((name1 (and (named? t) (cadr t)))
- (atypes1 (if name1 (third t) (second t)))
- (rtypes1 (if name1 (cdddr t) (cddr t)))
- (name2 (and (named? pt) (cadr pt)))
- (atypes2 (if name2 (third pt) (second pt)))
- (rtypes2 (if name2 (cdddr pt) (cddr pt))))
- (append
- '(procedure)
- (if (and name1 name2 (eq? name1 name2)) (list name1) '())
- (list (merge-argument-types atypes1 atypes2))
- (merge-result-types rtypes1 rtypes2))))
- #f
- (cdr t))))
- ((lset= eq? '(fixnum float) (cdr t)) 'number)
- (else
- (let* ((ts (append-map
- (lambda (t)
- (let ((t (simplify t)))
- (cond ((and (pair? t) (eq? 'or (car t)))
- (cdr t))
- ((eq? t 'undefined) (return 'undefined))
- ((eq? t 'noreturn) '())
- (else (list t)))))
- (cdr t)))
- (ts2 (let loop ((ts ts) (done '()))
- (cond ((null? ts) (reverse done))
- ((eq? '* (car ts)) (return '*))
- ((any (cut type<=? (car ts) <>) (cdr ts))
- (loop (cdr ts) done))
- ((any (cut type<=? (car ts) <>) done)
- (loop (cdr ts) done))
- (else (loop (cdr ts) (cons (car ts) done)))))))
- (cond ((equal? ts2 (cdr t)) t)
- (else
- (dd " or-simplify: ~a" ts2)
- (simplify
- `(or ,@(if (any (cut eq? <> '*) ts2) '(*) ts2)))))))) )
+ (let ((ts (map simplify (cdr t))))
+ (cond ((= 1 (length ts)) (simplify (car ts)))
+ ((every procedure-type? ts)
+ (if (any (cut eq? 'procedure <>) ts)
+ 'procedure
+ (reduce
+ (lambda (t pt)
+ (let* ((name1 (procedure-name t))
+ (atypes1 (procedure-arguments t))
+ (rtypes1 (procedure-results t))
+ (name2 (procedure-name pt))
+ (atypes2 (procedure-arguments pt))
+ (rtypes2 (procedure-results pt)))
+ (append
+ '(procedure)
+ (if (and name1 name2 (eq? name1 name2)) (list name1) '())
+ (list (merge-argument-types atypes1 atypes2))
+ (merge-result-types rtypes1 rtypes2))))
+ #f
+ (cdr t))))
+ ((lset= eq? '(fixnum float) ts) 'number)
+ (else
+ (let* ((ts (append-map
+ (lambda (t)
+ (let ((t (simplify t)))
+ (cond ((and (pair? t) (eq? 'or (car t)))
+ (cdr t))
+ ((eq? t 'undefined) (return 'undefined))
+ ((eq? t 'noreturn) '())
+ (else (list t)))))
+ ts))
+ (ts2 (let loop ((ts ts) (done '()))
+ (cond ((null? ts) (reverse done))
+ ((eq? '* (car ts)) (return '*))
+ ((any (cut type<=? (car ts) <>) (cdr ts))
+ (loop (cdr ts) done))
+ ((any (cut type<=? (car ts) <>) done)
+ (loop (cdr ts) done))
+ (else (loop (cdr ts) (cons (car ts) done)))))))
+ (cond ((equal? ts2 (cdr t)) t)
+ (else
+ (dd " or-simplify: ~a" ts2)
+ (simplify
+ `(or ,@(if (any (cut eq? <> '*) ts2) '(*) ts2)))))))) ))
((pair)
(let ((tcar (simplify (second t)))
(tcdr (simplify (third t))))
@@ -1122,7 +1131,7 @@
(else t)))))
(let ((t2 (simplify t)))
(when (pair? typeenv)
- (set! t2 `(forall ,(map cdr typeenv) ,t2)))
+ (set! t2 `(forall ,(map cdr typeenv) ,(subst t2))))
(dd "simplify: ~a -> ~a" t t2)
t2)))
@@ -1299,6 +1308,28 @@
(else #f))))
(else #f))))
+(define (procedure-arguments t)
+ (and (pair? t)
+ (case (car t)
+ ((forall) (procedure-arguments (third t)))
+ ((procedure)
+ (let ((n (second t)))
+ (if (or (string? n) (symbol? n))
+ (third t)
+ (second t))))
+ (else (bomb "procedure-arguments: not a procedure type" t)))))
+
+(define (procedure-results t)
+ (and (pair? t)
+ (case (car t)
+ ((forall) (procedure-results (third t)))
+ ((procedure)
+ (let ((n (second t)))
+ (if (or (string? n) (symbol? n))
+ (cdddr t)
+ (cddr t))))
+ (else (bomb "procedure-results: not a procedure type" t)))))
+
(define (procedure-argument-types t n typeenv #!optional norest)
(let loop1 ((t t))
(cond ((and (pair? t)
Trap