~ chicken-core (chicken-5) 8b95e6e18ba435b6dfa7d195f3bd55ee354b795d
commit 8b95e6e18ba435b6dfa7d195f3bd55ee354b795d
Author: felix <felix@call-with-current-continuation.org>
AuthorDate: Mon Feb 27 10:24:22 2012 +0100
Commit: Peter Bex <peter.bex@xs4all.nl>
CommitDate: Sat Mar 3 15:09:31 2012 +0100
Line-number tracking enhancements.
Squashed commit of the following:
commit 5bab46186c52d3983d97eeebb804f69015d0a4ff
Author: felix <felix@call-with-current-continuation.org>
Date: Fri Jan 27 09:13:03 2012 +0100
use line-number info in debug-messages for inlining
commit 99f7cc9b482d9130824ecb1b6b5b32a5fb96e366
Author: felix <felix@call-with-current-continuation.org>
Date: Tue Jan 24 12:13:35 2012 +0100
use line-number info of outer-expression if no other is available; updated expected scrutinizer output
commit bf40b1fb70acc2c4d7893209ea2711689773fb34
Author: felix <felix@call-with-current-continuation.org>
Date: Tue Jan 24 12:12:59 2012 +0100
use the same output-format for line-numbers in scrutinizer-messages as used in other places
commit e0e3409a889ea40e775044fa77f6b21e20699dda
Author: felix <felix@call-with-current-continuation.org>
Date: Tue Jan 24 11:57:40 2012 +0100
update ln-db for intermediate calls to ##sys#expand in canonicalization pass of compiler; use available ln-information when canonicalizing ##core#typecase
commit 34ced5125133b074dc5b5bc2ba57802a964a436c
Author: felix <felix@call-with-current-continuation.org>
Date: Tue Jan 24 08:26:56 2012 +0100
failure-message for compiler-typecase shows line-number if available
Signed-off-by: Peter Bex <peter.bex@xs4all.nl>
diff --git a/chicken-syntax.scm b/chicken-syntax.scm
index 7c4ab185..bed542ec 100644
--- a/chicken-syntax.scm
+++ b/chicken-syntax.scm
@@ -1274,9 +1274,11 @@
(##sys#er-transformer
(lambda (x r c)
(##sys#check-syntax 'compiler-typecase x '(_ _ . #((_ . #(_ 1)) 1)))
- (let ((var (gensym)))
+ (let ((var (gensym))
+ (ln (get-line-number x)))
`(##core#let ((,var ,(cadr x)))
(##core#typecase
+ ,ln
,var ; must be variable (see: CPS transform)
,@(map (lambda (clause)
(list (car clause) `(##core#begin ,@(cdr clause))))
diff --git a/compiler-namespace.scm b/compiler-namespace.scm
index 89c7e7ea..7351f815 100644
--- a/compiler-namespace.scm
+++ b/compiler-namespace.scm
@@ -42,6 +42,7 @@
build-node-graph
c-ify-string
callback-names
+ call-info
canonicalize-list-of-type
canonicalize-begin-body
canonicalize-expression
diff --git a/compiler.scm b/compiler.scm
index 3df1865c..0917cece 100644
--- a/compiler.scm
+++ b/compiler.scm
@@ -147,7 +147,7 @@
; (##core#module <symbol> #t | (<name> | (<name> ...) ...) <body>)
; (##core#let-module-alias ((<alias> <name>) ...) <body>)
; (##core#the <type> <strict?> <exp>)
-; (##core#typecase <exp> (<type> <body>) ... [(else <body>)])
+; (##core#typecase <info> <exp> (<type> <body>) ... [(else <body>)])
; (<exp> {<exp>})
; - Core language:
@@ -175,7 +175,7 @@
; [##core#direct_call {<safe-flag> <debug-info> <call-id> <words>} <exp-f> <exp>...]
; [##core#direct_lambda {<id> <mode> (<variable>... [. <variable>]) <size>} <exp>]
; [##core#the {<type> <strict>} <exp>]
-; [##core#typecase {(<type> ...)} <exp> <body1> ... [<elsebody>]]
+; [##core#typecase {<info> (<type> ...)} <exp> <body1> ... [<elsebody>]]
; - Closure converted/prepared language:
;
@@ -436,9 +436,9 @@
(d `(RESOLVE-VARIABLE: ,x0 ,x ,(map (lambda (x) (car x)) se)))
(cond ((not (symbol? x)) x0) ; syntax?
[(and constants-used (##sys#hash-table-ref constant-table x))
- => (lambda (val) (walk (car val) e se dest ldest h)) ]
+ => (lambda (val) (walk (car val) e se dest ldest h #f)) ]
[(and inline-table-used (##sys#hash-table-ref inline-table x))
- => (lambda (val) (walk val e se dest ldest h)) ]
+ => (lambda (val) (walk val e se dest ldest h #f)) ]
[(assq x foreign-variables)
=> (lambda (fv)
(let* ([t (second fv)]
@@ -448,7 +448,7 @@
(foreign-type-convert-result
(finish-foreign-result ft body)
t)
- e se dest ldest h)))]
+ e se dest ldest h #f)))]
[(assq x location-pointer-map)
=> (lambda (a)
(let* ([t (third a)]
@@ -458,7 +458,7 @@
(foreign-type-convert-result
(finish-foreign-result ft body)
t)
- e se dest ldest h))) ]
+ e se dest ldest h #f))) ]
((##sys#get x '##core#primitive))
((not (memq x e)) (##sys#alias-global-hook x #f h)) ; only if global
(else x))))
@@ -486,7 +486,7 @@
(for-each pretty-print imps)
(print "\n;; END OF FILE"))))) ) )
- (define (walk x e se dest ldest h)
+ (define (walk x e se dest ldest h outer-ln)
(cond ((symbol? x)
(cond ((keyword? x) `(quote ,x))
((memq x unlikely-variables)
@@ -498,7 +498,7 @@
`(quote ,x)
(##sys#syntax-error/context "illegal atomic form" x)))
((symbol? (car x))
- (let ([ln (get-line x)])
+ (let ((ln (or (get-line x) outer-ln)))
(emit-syntax-trace-info x #f)
(unless (proper-list? x)
(if ln
@@ -508,24 +508,24 @@
(let* ((name0 (lookup (car x) se))
(name (or (and (symbol? name0) (##sys#get name0 '##core#primitive)) name0))
(xexpanded (##sys#expand x se compiler-syntax-enabled)))
+ (when ln (update-line-number-database! xexpanded ln))
(cond ((not (eq? x xexpanded))
- (walk xexpanded e se dest ldest h))
+ (walk xexpanded e se dest ldest h ln))
[(and inline-table-used (##sys#hash-table-ref inline-table name))
=> (lambda (val)
- (walk (cons val (cdr x)) e se dest ldest h)) ]
+ (walk (cons val (cdr x)) e se dest ldest h ln)) ]
[else
- (when ln (update-line-number-database! xexpanded ln))
(case name
((##core#if)
`(if
- ,(walk (cadr x) e se #f #f h)
- ,(walk (caddr x) e se #f #f h)
+ ,(walk (cadr x) e se #f #f h ln)
+ ,(walk (caddr x) e se #f #f h ln)
,(if (null? (cdddr x))
'(##core#undefined)
- (walk (cadddr x) e se #f #f h) ) ) )
+ (walk (cadddr x) e se #f #f h ln) ) ) )
((##core#syntax ##core#quote)
`(quote ,(##sys#strip-syntax (cadr x))))
@@ -533,21 +533,22 @@
((##core#check)
(if unsafe
''#t
- (walk (cadr x) e se dest ldest h) ) )
+ (walk (cadr x) e se dest ldest h ln) ) )
((##core#the)
`(##core#the
,(##sys#strip-syntax (cadr x))
,(caddr x)
- ,(walk (cadddr x) e se dest ldest h)))
+ ,(walk (cadddr x) e se dest ldest h ln)))
((##core#typecase)
`(##core#typecase
- ,(walk (cadr x) e se #f #f h)
+ ,(or ln (cadr x))
+ ,(walk (caddr x) e se #f #f h ln)
,@(map (lambda (cl)
(list (##sys#strip-syntax (car cl))
- (walk (cadr cl) e se dest ldest h)))
- (cddr x))))
+ (walk (cadr cl) e se dest ldest h ln)))
+ (cdddr x))))
((##core#immutable)
(let ((c (cadadr x)))
@@ -568,7 +569,7 @@
((##core#inline_loc_ref)
`(##core#inline_loc_ref
,(##sys#strip-syntax (cadr x))
- ,(walk (caddr x) e se dest ldest h)))
+ ,(walk (caddr x) e se dest ldest h ln)))
((##core#require-for-syntax)
(let ([ids (map eval (cdr x))])
@@ -598,7 +599,7 @@
(warning
(sprintf "extension `~A' is currently not installed" realid)))
`(##core#begin ,exp ,(loop (cdr ids))) ) ) ) )
- e se dest ldest h) ) )
+ e se dest ldest h ln) ) )
((##core#let)
(let* ((bindings (cadr x))
@@ -608,12 +609,12 @@
(set-real-names! aliases vars)
`(let
,(map (lambda (alias b)
- (list alias (walk (cadr b) e se (car b) #t h)) )
+ (list alias (walk (cadr b) e se (car b) #t h ln)) )
aliases bindings)
,(walk (##sys#canonicalize-body
(cddr x) se2 compiler-syntax-enabled)
(append aliases e)
- se2 dest ldest h) ) ) )
+ se2 dest ldest h ln) ) ) )
((##core#letrec)
(let ((bindings (cadr x))
@@ -627,7 +628,7 @@
`(##core#set! ,(car b) ,(cadr b)))
bindings)
(##core#let () ,@body) )
- e se dest ldest h)))
+ e se dest ldest h ln)))
((##core#lambda)
(let ((llist (cadr x))
@@ -644,7 +645,7 @@
(se2 (##sys#extend-se se vars aliases))
(body0 (##sys#canonicalize-body
obody se2 compiler-syntax-enabled))
- (body (walk body0 (append aliases e) se2 #f #f dest))
+ (body (walk body0 (append aliases e) se2 #f #f dest ln))
(llist2
(build-lambda-list
aliases argc
@@ -681,7 +682,7 @@
(walk
(##sys#canonicalize-body (cddr x) se2 compiler-syntax-enabled)
e se2
- dest ldest h) ) )
+ dest ldest h ln) ) )
((##core#letrec-syntax)
(let* ((ms (map (lambda (b)
@@ -699,7 +700,7 @@
ms)
(walk
(##sys#canonicalize-body (cddr x) se2 compiler-syntax-enabled)
- e se2 dest ldest h)))
+ e se2 dest ldest h ln)))
((##core#define-syntax)
(##sys#check-syntax
@@ -724,7 +725,7 @@
',var
(##sys#current-environment) ,body) ;XXX possibly wrong se?
'(##core#undefined) )
- e se dest ldest h)) )
+ e se dest ldest h ln)) )
((##core#define-compiler-syntax)
(let* ((var (cadr x))
@@ -756,7 +757,7 @@
',var)
(##sys#current-environment))))
'(##core#undefined) )
- e se dest ldest h)))
+ e se dest ldest h ln)))
((##core#let-compiler-syntax)
(let ((bs (map
@@ -783,7 +784,7 @@
(walk
(##sys#canonicalize-body
(cddr x) se compiler-syntax-enabled)
- e se dest ldest h) )
+ e se dest ldest h ln) )
(lambda ()
(for-each
(lambda (b)
@@ -797,7 +798,7 @@
`(##core#begin
,@(fluid-let ((##sys#default-read-info-hook read-info-hook))
(##sys#include-forms-from-file (cadr x))))
- e se dest ldest h))
+ e se dest ldest h ln))
((##core#let-module-alias)
(##sys#with-module-aliases
@@ -806,7 +807,7 @@
(##sys#strip-syntax b))
(cadr x))
(lambda ()
- (walk `(##core#begin ,@(cddr x)) e se dest ldest h))))
+ (walk `(##core#begin ,@(cddr x)) e se dest ldest h ln))))
((##core#module)
(let* ((x (##sys#strip-syntax x))
@@ -875,7 +876,7 @@
(car body)
e ;?
(##sys#current-environment)
- #f #f h)
+ #f #f h ln)
xs))))))))))
(let ((body
(canonicalize-begin-body
@@ -888,7 +889,7 @@
(walk
x
e ;?
- (##sys#current-meta-environment) #f #f h) )
+ (##sys#current-meta-environment) #f #f h ln) )
mreg))
body))))
(do ((cs compiler-syntax (cdr cs)))
@@ -906,7 +907,7 @@
(walk
(##sys#canonicalize-body obody se2 compiler-syntax-enabled)
(append aliases e)
- se2 #f #f dest) ] )
+ se2 #f #f dest ln) ] )
(set-real-names! aliases vars)
`(##core#lambda ,aliases ,body) ) )
@@ -928,7 +929,7 @@
(##core#inline_update
(,(third fv) ,type)
,(foreign-type-check tmp type) ) )
- e se #f #f h))))
+ e se #f #f h ln))))
((assq var location-pointer-map)
=> (lambda (a)
(let* ([type (third a)]
@@ -939,7 +940,7 @@
(,type)
,(second a)
,(foreign-type-check tmp type) ) )
- e se #f #f h))))
+ e se #f #f h ln))))
(else
(unless (memq var e) ; global?
(set! var (or (##sys#get var '##core#primitive)
@@ -958,29 +959,30 @@
(##sys#notice "assignment to imported value binding" var)))
(when (keyword? var)
(warning (sprintf "assignment to keyword `~S'" var) ))
- `(set! ,var ,(walk val e se var0 (memq var e) h))))))
+ `(set! ,var ,(walk val e se var0 (memq var e) h ln))))))
((##core#inline)
- `(##core#inline ,(unquotify (cadr x) se) ,@(mapwalk (cddr x) e se h)))
+ `(##core#inline
+ ,(unquotify (cadr x) se) ,@(mapwalk (cddr x) e se h ln)))
((##core#inline_allocate)
`(##core#inline_allocate
,(map (cut unquotify <> se) (second x))
- ,@(mapwalk (cddr x) e se h)))
+ ,@(mapwalk (cddr x) e se h ln)))
((##core#inline_update)
- `(##core#inline_update ,(cadr x) ,(walk (caddr x) e se #f #f h)) )
+ `(##core#inline_update ,(cadr x) ,(walk (caddr x) e se #f #f h ln)) )
((##core#inline_loc_update)
`(##core#inline_loc_update
,(cadr x)
- ,(walk (caddr x) e se #f #f h)
- ,(walk (cadddr x) e se #f #f h)) )
+ ,(walk (caddr x) e se #f #f h ln)
+ ,(walk (cadddr x) e se #f #f h ln)) )
((##core#compiletimetoo ##core#elaborationtimetoo)
(let ((exp (cadr x)))
(##sys#eval/meta exp)
- (walk exp e se dest #f h) ) )
+ (walk exp e se dest #f h ln) ) )
((##core#compiletimeonly ##core#elaborationtimeonly)
(##sys#eval/meta (cadr x))
@@ -993,24 +995,24 @@
(let ([x (car xs)]
[r (cdr xs)] )
(if (null? r)
- (list (walk x e se dest ldest h))
- (cons (walk x e se #f #f h) (fold r)) ) ) ) )
+ (list (walk x e se dest ldest h ln))
+ (cons (walk x e se #f #f h ln) (fold r)) ) ) ) )
'(##core#undefined) ) )
((##core#foreign-lambda)
- (walk (expand-foreign-lambda x #f) e se dest ldest h) )
+ (walk (expand-foreign-lambda x #f) e se dest ldest h ln) )
((##core#foreign-safe-lambda)
- (walk (expand-foreign-lambda x #t) e se dest ldest h) )
+ (walk (expand-foreign-lambda x #t) e se dest ldest h ln) )
((##core#foreign-lambda*)
- (walk (expand-foreign-lambda* x #f) e se dest ldest h) )
+ (walk (expand-foreign-lambda* x #f) e se dest ldest h ln) )
((##core#foreign-safe-lambda*)
- (walk (expand-foreign-lambda* x #t) e se dest ldest h) )
+ (walk (expand-foreign-lambda* x #t) e se dest ldest h ln) )
((##core#foreign-primitive)
- (walk (expand-foreign-primitive x) e se dest ldest h) )
+ (walk (expand-foreign-primitive x) e se dest ldest h ln) )
((##core#define-foreign-variable)
(let* ([var (##sys#strip-syntax (second x))]
@@ -1044,7 +1046,7 @@
(define
,ret
,(if (pair? (cdr conv)) (second conv) '##sys#values)) )
- e se dest ldest h) ) ]
+ e se dest ldest h ln) ) ]
[else
(##sys#hash-table-set! foreign-type-table name type)
'(##core#undefined) ] ) ) )
@@ -1087,7 +1089,7 @@
'() )
,(if init (fifth x) (fourth x)) ) )
e (alist-cons var alias se)
- dest ldest h) ) )
+ dest ldest h ln) ) )
((##core#define-inline)
(let* ((name (second x))
@@ -1121,7 +1123,7 @@
(hide-variable var)
(mark-variable var '##compiler#constant)
(mark-variable var '##compiler#always-bound)
- (walk `(define ,var ',val) e se #f #f h) ) )
+ (walk `(define ,var ',val) e se #f #f h ln) ) )
(else
(quit "invalid compile-time value for named constant `~S'"
name)))))
@@ -1135,7 +1137,7 @@
(lambda (id)
(memq (lookup id se) e))))
(cdr x) ) )
- e '() #f #f h) )
+ e '() #f #f h ln) )
((##core#foreign-callback-wrapper)
(let-values ([(args lam) (split-at (cdr x) 4)])
@@ -1157,7 +1159,7 @@
"non-matching or invalid argument list to foreign callback-wrapper"
vars atypes) )
`(##core#foreign-callback-wrapper
- ,@(mapwalk args e se h)
+ ,@(mapwalk args e se h ln)
,(walk `(##core#lambda
,vars
(##core#let
@@ -1214,7 +1216,7 @@
(##sys#make-c-string r ',name)) ) ) )
(else (cddr lam)) ) )
rtype) ) )
- e se #f #f h) ) ) ) )
+ e se #f #f h ln) ) ) ) )
((##core#location)
(let ([sym (cadr x)])
@@ -1223,23 +1225,23 @@
=> (lambda (a)
(walk
`(##sys#make-locative ,(second a) 0 #f 'location)
- e se #f #f h) ) ]
+ e se #f #f h ln) ) ]
[(assq sym external-to-pointer)
- => (lambda (a) (walk (cdr a) e se #f #f h)) ]
+ => (lambda (a) (walk (cdr a) e se #f #f h ln)) ]
[(assq sym callback-names)
`(##core#inline_ref (,(symbol->string sym) c-pointer)) ]
[else
(walk
`(##sys#make-locative ,sym 0 #f 'location)
- e se #f #f h) ] )
+ e se #f #f h ln) ] )
(walk
`(##sys#make-locative ,sym 0 #f 'location)
- e se #f #f h) ) ) )
+ e se #f #f h ln) ) ) )
(else
(let* ((x2 (fluid-let ((##sys#syntax-context
(cons name ##sys#syntax-context)))
- (mapwalk x e se h)))
+ (mapwalk x e se h ln)))
(head2 (car x2))
(old (##sys#hash-table-ref line-number-database-2 head2)) )
(when ln
@@ -1255,7 +1257,7 @@
((constant? (car x))
(emit-syntax-trace-info x #f)
(warning "literal in operator position" x)
- (mapwalk x e se h) )
+ (mapwalk x e se h outer-ln) )
(else
(emit-syntax-trace-info x #f)
@@ -1264,10 +1266,10 @@
`(##core#let
((,tmp ,(car x)))
(,tmp ,@(cdr x)))
- e se dest ldest h)))))
+ e se dest ldest h outer-ln)))))
- (define (mapwalk xs e se h)
- (map (lambda (x) (walk x e se #f #f h)) xs) )
+ (define (mapwalk xs e se h ln)
+ (map (lambda (x) (walk x e se #f #f h ln)) xs) )
(when (memq 'c debugging-chicken) (newline) (pretty-print exp))
(##sys#clear-trace-buffer)
@@ -1280,7 +1282,7 @@
,(begin
(set! extended-bindings (append internal-bindings extended-bindings))
exp) )
- '() (##sys#current-environment) #f #f #f) ) )
+ '() (##sys#current-environment) #f #f #f #f) ) )
(define (process-declaration spec se local?)
@@ -1635,17 +1637,16 @@
(define (update-line-number-database! exp ln)
(define (mapupdate xs)
(let loop ((xs xs))
- (if (pair? xs)
- (begin
- (walk (car xs))
- (loop (cdr xs)) ) ) ) )
+ (when (pair? xs)
+ (walk (car xs))
+ (loop (cdr xs)) ) ) )
(define (walk x)
(cond ((not-pair? x))
((symbol? (car x))
(let* ((name (car x))
(old (or (##sys#hash-table-ref ##sys#line-number-database name) '())) )
- (if (not (assq x old))
- (##sys#hash-table-set! ##sys#line-number-database name (alist-cons x ln old)) )
+ (unless (assq x old)
+ (##sys#hash-table-set! ##sys#line-number-database name (alist-cons x ln old)) )
(mapupdate (cdr x)) ) )
(else (mapupdate x)) ) )
(walk exp) )
diff --git a/eval.scm b/eval.scm
index a2fdb5cb..779c2306 100644
--- a/eval.scm
+++ b/eval.scm
@@ -715,7 +715,7 @@
((##core#typecase)
;; drops exp and requires "else" clause
- (cond ((assq 'else (##sys#strip-syntax (cddr x))) =>
+ (cond ((assq 'else (##sys#strip-syntax (cdddr x))) =>
(lambda (cl)
(compile (cadr cl) e h tf cntr se)))
(else
diff --git a/optimizer.scm b/optimizer.scm
index b4701980..b4c39f75 100644
--- a/optimizer.scm
+++ b/optimizer.scm
@@ -301,22 +301,23 @@
(walk-generic n class params subs fids '() #f))
((##core#call)
- (let* ([fun (car subs)]
- [funclass (node-class fun)] )
+ (let* ((fun (car subs))
+ (funclass (node-class fun)))
(case funclass
[(##core#variable)
;; Call to named procedure:
- (let* ([var (first (node-parameters fun))]
- [lval (and (not (test var 'unknown))
+ (let* ((var (first (node-parameters fun)))
+ (info (call-info params var))
+ (lval (and (not (test var 'unknown))
(or (test var 'value)
- (test var 'local-value)))]
- [args (cdr subs)] )
+ (test var 'local-value))))
+ (args (cdr subs)) )
(cond ((test var 'contractable)
;; only called once
(let* ([lparams (node-parameters lval)]
[llist (third lparams)] )
(check-signature var args llist)
- (debugging 'o "contracted procedure" var)
+ (debugging 'o "contracted procedure" info)
(touch)
(for-each (cut put! db <> 'inline-target #t) fids)
(walk
@@ -338,11 +339,10 @@
(not (test (car llist) 'assigned)))))
((not (any (cut expression-has-side-effects? <> db)
(cdr args) ))))
- (let ((info (and (pair? (cdr params)) (second params))))
- (debugging
- 'o
- "removed call to pure procedure with unused result"
- (or (source-info->string info) var)))
+ (debugging
+ 'o
+ "removed call to pure procedure with unused result"
+ info)
(make-node
'##core#call (list #t)
(list k (make-node '##core#undefined '() '())) ) )
@@ -371,17 +371,17 @@
(if external
"global inlining"
"inlining")
- var ifid (fourth lparams))
+ info ifid (fourth lparams))
(for-each (cut put! db <> 'inline-target #t) fids)
(check-signature var args llist)
- (debugging 'o "inlining procedure" var)
+ (debugging 'o "inlining procedure" info)
(call/cc
(lambda (return)
(define (cfk cvar)
(debugging
'i
"not inlining procedure because it refers to contractable"
- var cvar)
+ info cvar)
(return
(walk-generic n class params subs fids gae #t)))
(let ((n2 (inline-lambda-bindings
@@ -406,7 +406,7 @@
(touch)
(debugging
'o "removed unused parameter to known procedure"
- (car vars) var)
+ (car vars) info)
(if (expression-has-side-effects? (car args) db)
(make-node
'let
@@ -424,7 +424,7 @@
(if (< (length args) n)
(walk-generic n class params subs fids gae #t)
(begin
- (debugging 'o "consed rest parameter at call site" var n)
+ (debugging 'o "consed rest parameter at call site" info n)
(let-values ([(args rargs) (split-at args n)])
(let ([n2 (make-node
'##core#call
@@ -449,7 +449,7 @@
(intrinsic? (first (node-parameters lval))))
;; callee is intrinsic
(debugging 'i "inlining call to intrinsic alias"
- var (first (node-parameters lval)))
+ info (first (node-parameters lval)))
(walk
(make-node
'##core#call
diff --git a/scrutinizer.scm b/scrutinizer.scm
index dd2d0a00..332ed2e7 100755
--- a/scrutinizer.scm
+++ b/scrutinizer.scm
@@ -295,7 +295,7 @@
(pair? (cadr params))) ; sourceinfo has line-number information?
(let ((n (source-info->line (cadr params))))
(if n
- (sprintf "~a: " n)
+ (sprintf "(~a) " n)
""))
"")
(fragment (first (node-subexpressions node)))))
@@ -781,13 +781,17 @@
(trail0 trail)
(typeenv (type-typeenv (car ts))))
;; first exp is always a variable so ts must be of length 1
- (let loop ((types params) (subs (cdr subs)))
+ (let loop ((types (cdr params)) (subs (cdr subs)))
(cond ((null? types)
- (quit "~ano clause applies in `compiler-typecase' for expression of type `~s':~a"
- (location-name loc) (car ts)
+ (quit "~a~ano clause applies in `compiler-typecase' for expression of type `~s':~a"
+ (location-name loc)
+ (if (first params)
+ (sprintf "(~a) " (first params))
+ "")
+ (car ts)
(string-concatenate
(map (lambda (t) (sprintf "\n ~a" t))
- params))))
+ (cdr params)))))
((match-types (car types) (car ts)
(append (type-typeenv (car types)) typeenv)
#t)
diff --git a/support.scm b/support.scm
index 4c0a1e09..c8cda93e 100644
--- a/support.scm
+++ b/support.scm
@@ -560,17 +560,17 @@
(list (walk (fourth x)))))
((##core#typecase)
;; clause-head is already stripped
- (let loop ((cls (cddr x)) (types '()) (exps (list (walk (cadr x)))))
+ (let loop ((cls (cdddr x)) (types '()) (exps (list (walk (caddr x)))))
(cond ((null? cls) ; no "else" clause given
(make-node
'##core#typecase
- (reverse types)
+ (cons (cadr x) (reverse types))
(reverse
(cons (make-node '##core#undefined '() '()) exps))))
((eq? 'else (caar cls))
(make-node
'##core#typecase
- (reverse (cons '* types))
+ (cons (cadr x) (reverse (cons '* types)))
(reverse (cons (walk (cadar cls)) exps))))
(else (loop (cdr cls)
(cons (caar cls) types)
@@ -649,7 +649,7 @@
((##core#typecase)
`(compiler-typecase
,(walk (first subs))
- ,@(let loop ((types params) (bodies (cdr subs)))
+ ,@(let loop ((types (cdr params)) (bodies (cdr subs)))
(if (null? types)
(if (null? bodies)
'()
@@ -1456,6 +1456,14 @@
(car info)
(and info (->string info))))
+(define (call-info params var)
+ (or (and-let* ((info (and (pair? (cdr params)) (second params))))
+ (and (list? info)
+ (let ((ln (car info))
+ (name (cadr info)))
+ (conc "(" ln ") " var))))
+ var))
+
;;; constant folding support:
diff --git a/tests/scrutiny-2.expected b/tests/scrutiny-2.expected
index 09462606..4bea4dfe 100644
--- a/tests/scrutiny-2.expected
+++ b/tests/scrutiny-2.expected
@@ -1,100 +1,100 @@
Note: at toplevel:
- in procedure call to `pair?', the predicate is called with an argument of type
+ (scrutiny-tests-2.scm:14) in procedure call to `pair?', the predicate is called with an argument of type
`(pair fixnum fixnum)' and will always return true
Note: at toplevel:
- in procedure call to `pair?', the predicate is called with an argument of type
+ (scrutiny-tests-2.scm:14) in procedure call to `pair?', the predicate is called with an argument of type
`null' and will always return false
Note: at toplevel:
- in procedure call to `pair?', the predicate is called with an argument of type
+ (scrutiny-tests-2.scm:14) in procedure call to `pair?', the predicate is called with an argument of type
`null' and will always return false
Note: at toplevel:
- in procedure call to `pair?', the predicate is called with an argument of type
+ (scrutiny-tests-2.scm:14) in procedure call to `pair?', the predicate is called with an argument of type
`fixnum' and will always return false
Note: at toplevel:
- in procedure call to `pair?', the predicate is called with an argument of type
+ (scrutiny-tests-2.scm:14) in procedure call to `pair?', the predicate is called with an argument of type
`float' and will always return false
Note: at toplevel:
- in procedure call to `list?', the predicate is called with an argument of type
+ (scrutiny-tests-2.scm:21) in procedure call to `list?', the predicate is called with an argument of type
`null' and will always return true
Note: at toplevel:
- in procedure call to `list?', the predicate is called with an argument of type
+ (scrutiny-tests-2.scm:21) in procedure call to `list?', the predicate is called with an argument of type
`null' and will always return true
Note: at toplevel:
- in procedure call to `list?', the predicate is called with an argument of type
+ (scrutiny-tests-2.scm:21) in procedure call to `list?', the predicate is called with an argument of type
`fixnum' and will always return false
Note: at toplevel:
- in procedure call to `list?', the predicate is called with an argument of type
+ (scrutiny-tests-2.scm:21) in procedure call to `list?', the predicate is called with an argument of type
`float' and will always return false
Note: at toplevel:
- in procedure call to `null?', the predicate is called with an argument of type
+ (scrutiny-tests-2.scm:22) in procedure call to `null?', the predicate is called with an argument of type
`null' and will always return true
Note: at toplevel:
- in procedure call to `null?', the predicate is called with an argument of type
+ (scrutiny-tests-2.scm:22) in procedure call to `null?', the predicate is called with an argument of type
`null' and will always return true
Note: at toplevel:
- in procedure call to `null?', the predicate is called with an argument of type
+ (scrutiny-tests-2.scm:22) in procedure call to `null?', the predicate is called with an argument of type
`fixnum' and will always return false
Note: at toplevel:
- in procedure call to `null?', the predicate is called with an argument of type
+ (scrutiny-tests-2.scm:22) in procedure call to `null?', the predicate is called with an argument of type
`float' and will always return false
Note: at toplevel:
- in procedure call to `fixnum?', the predicate is called with an argument of type
+ (scrutiny-tests-2.scm:23) in procedure call to `fixnum?', the predicate is called with an argument of type
`fixnum' and will always return true
Note: at toplevel:
- in procedure call to `fixnum?', the predicate is called with an argument of type
+ (scrutiny-tests-2.scm:23) in procedure call to `fixnum?', the predicate is called with an argument of type
`float' and will always return false
Note: at toplevel:
- in procedure call to `exact?', the predicate is called with an argument of type
+ (scrutiny-tests-2.scm:24) in procedure call to `exact?', the predicate is called with an argument of type
`fixnum' and will always return true
Note: at toplevel:
- in procedure call to `exact?', the predicate is called with an argument of type
+ (scrutiny-tests-2.scm:24) in procedure call to `exact?', the predicate is called with an argument of type
`float' and will always return false
Note: at toplevel:
- in procedure call to `flonum?', the predicate is called with an argument of type
+ (scrutiny-tests-2.scm:25) in procedure call to `flonum?', the predicate is called with an argument of type
`float' and will always return true
Note: at toplevel:
- in procedure call to `flonum?', the predicate is called with an argument of type
+ (scrutiny-tests-2.scm:25) in procedure call to `flonum?', the predicate is called with an argument of type
`fixnum' and will always return false
Note: at toplevel:
- in procedure call to `inexact?', the predicate is called with an argument of type
+ (scrutiny-tests-2.scm:26) in procedure call to `inexact?', the predicate is called with an argument of type
`float' and will always return true
Note: at toplevel:
- in procedure call to `inexact?', the predicate is called with an argument of type
+ (scrutiny-tests-2.scm:26) in procedure call to `inexact?', the predicate is called with an argument of type
`fixnum' and will always return false
Note: at toplevel:
- in procedure call to `number?', the predicate is called with an argument of type
+ (scrutiny-tests-2.scm:27) in procedure call to `number?', the predicate is called with an argument of type
`fixnum' and will always return true
Note: at toplevel:
- in procedure call to `number?', the predicate is called with an argument of type
+ (scrutiny-tests-2.scm:27) in procedure call to `number?', the predicate is called with an argument of type
`float' and will always return true
Note: at toplevel:
- in procedure call to `number?', the predicate is called with an argument of type
+ (scrutiny-tests-2.scm:27) in procedure call to `number?', the predicate is called with an argument of type
`number' and will always return true
Note: at toplevel:
- in procedure call to `number?', the predicate is called with an argument of type
+ (scrutiny-tests-2.scm:27) in procedure call to `number?', the predicate is called with an argument of type
`null' and will always return false
diff --git a/tests/scrutiny.expected b/tests/scrutiny.expected
index bca7f13e..31eeb2b8 100644
--- a/tests/scrutiny.expected
+++ b/tests/scrutiny.expected
@@ -16,10 +16,10 @@ Warning: in toplevel procedure `foo':
(if x5 (values 1 2) (values 1 2 (+ (+ ...))))
Warning: at toplevel:
- scrutiny-tests.scm:18: in procedure call to `bar6', expected argument #2 of type `number', but was given an argument of type `symbol'
+ (scrutiny-tests.scm:18) in procedure call to `bar6', expected argument #2 of type `number', but was given an argument of type `symbol'
Warning: at toplevel:
- scrutiny-tests.scm:20: in procedure call to `pp', expected 1 argument, but was given 0 arguments
+ (scrutiny-tests.scm:20) in procedure call to `pp', expected 1 argument, but was given 0 arguments
Warning: at toplevel:
expected in argument #1 of procedure call `(print (cpu-time))' a single result, but were given 2 results
@@ -28,13 +28,13 @@ Warning: at toplevel:
expected in argument #1 of procedure call `(print (values))' a single result, but were given zero results
Warning: at toplevel:
- scrutiny-tests.scm:26: in procedure call to `x7', expected a value of type `(procedure () *)', but was given a value of type `fixnum'
+ (scrutiny-tests.scm:26) in procedure call to `x7', expected a value of type `(procedure () *)', but was given a value of type `fixnum'
Warning: at toplevel:
- scrutiny-tests.scm:28: in procedure call to `+', expected argument #1 of type `number', but was given an argument of type `symbol'
+ (scrutiny-tests.scm:28) in procedure call to `+', expected argument #1 of type `number', but was given an argument of type `symbol'
Warning: at toplevel:
- scrutiny-tests.scm:28: in procedure call to `+', expected argument #2 of type `number', but was given an argument of type `symbol'
+ (scrutiny-tests.scm:28) in procedure call to `+', expected argument #2 of type `number', but was given an argument of type `symbol'
Warning: at toplevel:
assignment of value of type `fixnum' to toplevel variable `car' does not match declared type `(forall (a123) (procedure car ((pair a123 *)) a123))'
@@ -52,34 +52,34 @@ Note: in toplevel procedure `foo':
(if bar29 3 (##core#undefined))
Warning: in toplevel procedure `foo2':
- scrutiny-tests.scm:57: in procedure call to `string-append', expected argument #1 of type `string', but was given an argument of type `number'
+ (scrutiny-tests.scm:57) in procedure call to `string-append', expected argument #1 of type `string', but was given an argument of type `number'
Warning: at toplevel:
- scrutiny-tests.scm:65: in procedure call to `foo3', expected argument #1 of type `string', but was given an argument of type `fixnum'
+ (scrutiny-tests.scm:65) in procedure call to `foo3', expected argument #1 of type `string', but was given an argument of type `fixnum'
Warning: in toplevel procedure `foo4':
- scrutiny-tests.scm:70: in procedure call to `+', expected argument #1 of type `number', but was given an argument of type `string'
+ (scrutiny-tests.scm:70) in procedure call to `+', expected argument #1 of type `number', but was given an argument of type `string'
Warning: in toplevel procedure `foo5':
- scrutiny-tests.scm:76: in procedure call to `+', expected argument #1 of type `number', but was given an argument of type `string'
+ (scrutiny-tests.scm:76) in procedure call to `+', expected argument #1 of type `number', but was given an argument of type `string'
Warning: in toplevel procedure `foo6':
- scrutiny-tests.scm:82: in procedure call to `+', expected argument #1 of type `number', but was given an argument of type `string'
+ (scrutiny-tests.scm:82) in procedure call to `+', expected argument #1 of type `number', but was given an argument of type `string'
Warning: at toplevel:
- scrutiny-tests.scm:89: in procedure call to `+', expected argument #1 of type `number', but was given an argument of type `string'
+ (scrutiny-tests.scm:89) in procedure call to `+', expected argument #1 of type `number', but was given an argument of type `string'
Warning: in toplevel procedure `foo10':
- scrutiny-tests.scm:103: in procedure call to `foo9', expected argument #1 of type `string', but was given an argument of type `number'
+ (scrutiny-tests.scm:103) in procedure call to `foo9', expected argument #1 of type `string', but was given an argument of type `number'
Warning: in toplevel procedure `foo10':
- scrutiny-tests.scm:104: in procedure call to `+', expected argument #1 of type `number', but was given an argument of type `string'
+ (scrutiny-tests.scm:104) in procedure call to `+', expected argument #1 of type `number', but was given an argument of type `string'
Note: in toplevel procedure `foo10':
expression returns a result of type `string', but is declared to return `pair', which is not a subtype
Warning: in toplevel procedure `foo10':
- scrutiny-tests.scm:108: in procedure call to `string-append', expected argument #1 of type `string', but was given an argument of type `pair'
+ (scrutiny-tests.scm:108) in procedure call to `string-append', expected argument #1 of type `string', but was given an argument of type `pair'
Warning: in toplevel procedure `foo10':
expression returns 2 values but is declared to have a single result
@@ -91,6 +91,6 @@ Warning: in toplevel procedure `foo10':
expression returns zero values but is declared to have a single result of type `*'
Warning: in toplevel procedure `foo10':
- scrutiny-tests.scm:111: in procedure call to `*', expected argument #1 of type `number', but was given an argument of type `string'
+ (scrutiny-tests.scm:111) in procedure call to `*', expected argument #1 of type `number', but was given an argument of type `string'
Warning: redefinition of standard binding: car
Trap