~ chicken-core (chicken-5) 9e1d722f7b88dffda06dc594ded8d776dba06526
commit 9e1d722f7b88dffda06dc594ded8d776dba06526
Author: felix <felix@call-with-current-continuation.org>
AuthorDate: Tue Aug 16 15:44:58 2011 +0200
Commit: felix <felix@call-with-current-continuation.org>
CommitDate: Tue Aug 16 15:44:58 2011 +0200
restore typevars after every specialization match; documented forall types
diff --git a/manual/Types b/manual/Types
index d663d057..d8b4bcd3 100644
--- a/manual/Types
+++ b/manual/Types
@@ -94,6 +94,7 @@ or {{:}} should follow the syntax given below:
<tr><td>{{(procedure [NAME] (VALUETYPE ... [#!optional VALUETYPE ...] [#!rest [VALUETYPE]]) . RESULTS)}}</td><td>procedure type, optionally with name</td></tr>
<tr><td>{{(VALUETYPE ... [#!optional VALUETYPE ...] [#!rest [VALUETYPE]] -> . RESULTS)}}</td><td>alternative procedure type syntax</td></tr>
<tr><td>{{(VALUETYPE -> VALUETYPE : VALUETYPE)}}</td><td>predicate procedure type</td></tr>
+<tr><td>{{(forall (TYPEVAR ...) VALUETYPE)}}</td><td>polymorphic type</td></tr>
<tr><td>COMPLEXTYPE</td><td></td></tr>
<tr><td>BASICTYPE</td><td></td></tr>
</table>
diff --git a/scrutinizer.scm b/scrutinizer.scm
index 0bb6dd24..573de2e7 100755
--- a/scrutinizer.scm
+++ b/scrutinizer.scm
@@ -29,7 +29,7 @@
(hide match-specialization specialize-node! specialization-statistics
procedure-type? named? procedure-result-types procedure-argument-types
noreturn-type? rest-type procedure-name d-depth
- noreturn-procedure-type?
+ noreturn-procedure-type? trail trail-restore
compatible-types? type<=? initial-argument-types))
@@ -98,6 +98,7 @@
(define specialization-statistics '())
+(define trail '())
(define (scrutinize node db complain specialize)
@@ -271,7 +272,8 @@
(if (cdr e)
(match1 (cdr e) t2)
(begin
- (d " unify ~a = ~a" t1 t2)
+ (dd " unify ~a = ~a" t1 t2)
+ (set! trail (cons t1 trail))
(set-cdr! e t2)
#t))))
((and (symbol? t2) (assq t2 typeenv)) =>
@@ -279,7 +281,8 @@
(if (cdr e)
(match1 t1 (cdr e))
(begin
- (d " unify ~a = ~a" t2 t1)
+ (dd " unify ~a = ~a" t2 t1)
+ (set! trail (cons t2 trail))
(set-cdr! e t1)
#t))))
((eq? t1 '*))
@@ -546,17 +549,23 @@
(set! op (list pt `(not ,pt))))))))
((and specialize (get-specializations pn)) =>
(lambda (specs)
- (let loop ((specs specs))
- (cond ((null? specs))
- ((match-specialization
- (first (car specs)) (cdr args) typeenv #f)
- (let ((spec (car specs)))
- (set! op (cons pn (car spec)))
- (let* ((r2 (and (pair? (cddr spec)) (second spec)))
- (rewrite (if r2 (third spec) (second spec))))
- (specialize-node! node rewrite)
- (when r2 (set! r r2)))))
- (else (loop (cdr specs))))))))
+ (let ((trail0 trail))
+ (let loop ((specs specs))
+ (cond ((null? specs))
+ ((match-specialization
+ (first (car specs)) (cdr args) typeenv #f)
+ (let ((spec (car specs)))
+ (set! op (cons pn (car spec)))
+ (let* ((r2 (and (pair? (cddr spec))
+ (second spec)))
+ (rewrite (if r2
+ (third spec)
+ (second spec))))
+ (specialize-node! node rewrite)
+ (when r2 (set! r r2)))))
+ (else
+ (trail-restore trail0 typeenv)
+ (loop (cdr specs)))))))))
(when op
(d " specialized: `~s'" op)
(cond ((assoc op specialization-statistics) =>
@@ -1281,6 +1290,12 @@
(for-each loop (cdr t))))))
(map (cut cons <> #f) te)))
+(define (trail-restore tr typeenv)
+ (do ((tr2 trail (cdr tr2)))
+ ((eq? tr2 tr))
+ (let ((a (assq (car tr2) typeenv)))
+ (set-cdr! a #f))))
+
;;; type-db processing
Trap