~ chicken-core (chicken-5) 2c85c5031709878ae12c31b88bbd126f9ff383ed
commit 2c85c5031709878ae12c31b88bbd126f9ff383ed
Author: felix <felix@call-with-current-continuation.org>
AuthorDate: Thu Jan 20 05:58:08 2011 -0500
Commit: felix <felix@call-with-current-continuation.org>
CommitDate: Thu Jan 20 05:58:08 2011 -0500
specialization fixes; template subst currently broken
diff --git a/batch-driver.scm b/batch-driver.scm
index 87acb498..81a74e1e 100644
--- a/batch-driver.scm
+++ b/batch-driver.scm
@@ -91,8 +91,8 @@
(a-only (memq 'analyze-only options))
(dynamic (memq 'dynamic options))
(unbox (memq 'unboxing options))
- (do-scrutinize (when (memq 'scrutinize options))
- (do-specialize (when (memq 'specialize options))
+ (do-scrutinize (memq 'scrutinize options))
+ (do-specialize (memq 'specialize options))
(dumpnodes #f)
(start-time #f)
(upap #f)
diff --git a/compiler.scm b/compiler.scm
index 41d6736c..9bc6e7b8 100644
--- a/compiler.scm
+++ b/compiler.scm
@@ -1463,13 +1463,13 @@
((type)
(for-each
(lambda (spec)
- (cond ((and (list? spec) (symbol? (car spec)) (>= 2 (length spec)))
+ (cond ((and (list? spec) (symbol? (car spec)) (>= (length spec) 2))
(##sys#put! (car spec) '##core#type (cadr spec))
(##sys#put! (car spec) '##core#declared-type #t)
(when (pair? (cddr spec))
(##sys#put! (car spec) '##core#specializations (cddr spec))))
(else
- (warning "illegal `type' declaration item" spec))))
+ (warning "illegal type declaration item" spec))))
(globalize-all (cdr spec))))
((unsafe-specialized-arithmetic)
(set! unchecked-specialized-arithmetic #t))
diff --git a/scrutinizer.scm b/scrutinizer.scm
index 87baa8f2..ffd62613 100755
--- a/scrutinizer.scm
+++ b/scrutinizer.scm
@@ -80,7 +80,11 @@
((symbol? lit) 'symbol)
((fixnum? lit) 'fixnum)
((flonum? lit) 'float)
- ((number? lit) 'number) ; in case...
+ ((number? lit)
+ (case number-type
+ ((fixnum) 'fixnum)
+ ((flonum) 'flonum)
+ (else 'number))) ; in case...
((boolean? lit) 'boolean)
((list? lit) 'list)
((pair? lit) 'pair)
@@ -487,6 +491,7 @@
(for-each
(lambda (spec)
(when (match-specialization (car spec) (cdr args) match)
+ (debugging 'x "specializing call" (cons pn (car spec)))
(specialize-node! node (cadr spec))))
specs)))
r))))
@@ -499,8 +504,10 @@
(define (procedure-name t)
(and (pair? t)
(eq? 'procedure (car t))
- (or (string? (cadr t)) (symbol? (cadr t)))
- (->string (cadr t))))
+ (let ((n (cadr t)))
+ (cond ((string? n) (string->symbol n))
+ ((symbol? n) n)
+ (else #f)))))
(define (procedure-argument-types t n)
(cond ((or (memq t '(* procedure))
(not-pair? t)
@@ -688,8 +695,5 @@
(define (specialize-node! node template)
(let ((args (cdr (node-subexpressions node))))
(define (subst x)
- (cond ((fixnum? x) (list-ref args x))
- ((not (pair? x)) x)
- ((eq? 'quote (car x)) x)
- (else (cons (subst (car x)) (subst (cdr x))))))
- (copy-node! (build-node-graph (subst template)) node)))
+ ...) ;XXX
+ (copy-node! (subst (build-node-graph template)) node)))
Trap