[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
Re: [Chicken-hackers] [PATCH] Use vertical space more liberally in some
From: |
megane |
Subject: |
Re: [Chicken-hackers] [PATCH] Use vertical space more liberally in some scrutinizer messages |
Date: |
Mon, 19 Nov 2018 18:55:21 +0200 |
User-agent: |
mu4e 1.0; emacs 25.1.1 |
Hi,
Here's a reworked patch set. It's not exactly small, but I tried to make
it pretty easy to follow. Except maybe for the last patch, which
digs for some extra info from the nodes.
There's small bit of back-and-forth in the patches:
- errors? is taken out of let and put back
- report-notice lingers unused before getting deleted
There were some whitespace warnings when I applied this, but everything
seemed to work fine.
>From 00f220b2d530539baca6f3c6d6f57605d447dd16 Mon Sep 17 00:00:00 2001
From: megane <address@hidden>
Date: Fri, 16 Nov 2018 16:55:27 +0200
Subject: [PATCH 1/9] * scrutinizer.scm: Remove trailing whitespace + use ';;'
for comments starting at column 0
---
scrutinizer.scm | 322 ++++++++++++++++++++++++++++----------------------------
1 file changed, 161 insertions(+), 161 deletions(-)
diff --git a/scrutinizer.scm b/scrutinizer.scm
index bbc3b5a..216da8b 100644
--- a/scrutinizer.scm
+++ b/scrutinizer.scm
@@ -1,27 +1,27 @@
;;;; scrutinizer.scm - The CHICKEN Scheme compiler (local flow analysis)
-;
-; Copyright (c) 2009-2018, The CHICKEN Team
-; All rights reserved.
-;
-; Redistribution and use in source and binary forms, with or without
modification, are permitted provided that the following
-; conditions are met:
-;
-; Redistributions of source code must retain the above copyright notice,
this list of conditions and the following
-; disclaimer.
-; Redistributions in binary form must reproduce the above copyright notice,
this list of conditions and the following
-; disclaimer in the documentation and/or other materials provided with the
distribution.
-; Neither the name of the author nor the names of its contributors may be
used to endorse or promote
-; products derived from this software without specific prior written
permission.
-;
-; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
AND ANY EXPRESS
-; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES
OF MERCHANTABILITY
-; AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
COPYRIGHT HOLDERS OR
-; CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,
EXEMPLARY, OR
-; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
SUBSTITUTE GOODS OR
-; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
CAUSED AND ON ANY
-; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
(INCLUDING NEGLIGENCE OR
-; OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
ADVISED OF THE
-; POSSIBILITY OF SUCH DAMAGE.
+;;
+;; Copyright (c) 2009-2018, The CHICKEN Team
+;; All rights reserved.
+;;
+;; Redistribution and use in source and binary forms, with or without
modification, are permitted provided that the following
+;; conditions are met:
+;;
+;; Redistributions of source code must retain the above copyright notice,
this list of conditions and the following
+;; disclaimer.
+;; Redistributions in binary form must reproduce the above copyright notice,
this list of conditions and the following
+;; disclaimer in the documentation and/or other materials provided with
the distribution.
+;; Neither the name of the author nor the names of its contributors may be
used to endorse or promote
+;; products derived from this software without specific prior written
permission.
+;;
+;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
AND ANY EXPRESS
+;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
WARRANTIES OF MERCHANTABILITY
+;; AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
COPYRIGHT HOLDERS OR
+;; CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,
EXEMPLARY, OR
+;; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
SUBSTITUTE GOODS OR
+;; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
CAUSED AND ON ANY
+;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
(INCLUDING NEGLIGENCE OR
+;; OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
ADVISED OF THE
+;; POSSIBILITY OF SUCH DAMAGE.
(declare
@@ -67,58 +67,58 @@
;;; Walk node tree, keeping type and binding information
-;
-; result specifiers:
-;
-; SPEC = * | (TYPE1 ...)
-; TYPE = (or TYPE1 ...)
-; | (not TYPE)
-; | (struct NAME)
-; | (procedure [NAME] (TYPE1 ... [#!optional TYPE1 ...] [#!rest [TYPE |
values]]) . RESULTS)
-; | VALUE
-; | BASIC
-; | COMPLEX
-; | (forall (TVAR1 ...) TYPE)
-; | (refine (SYMBOL ...) VALUE)
-; | deprecated
-; | (deprecated NAME)
-; VALUE = string | symbol | char | number | boolean | true | false |
-; null | eof | blob | pointer | port | locative | fixnum |
-; float | bignum | ratnum | cplxnum | integer | pointer-vector
-; BASIC = * | list | pair | procedure | vector | undefined | noreturn |
values
-; COMPLEX = (pair TYPE TYPE)
-; | (vector-of TYPE)
-; | (list-of TYPE)
-; | (vector TYPE1 ...)
-; | (list TYPE1 ...)
-; RESULTS = *
-; | (TYPE1 ...)
-; TVAR = (VAR TYPE) | VAR
-;
-; global symbol properties:
-;
-; ##compiler#type -> TYPESPEC
-; ##compiler#type-source -> 'db | 'local | 'inference
-; ##compiler#predicate -> TYPESPEC
-; ##compiler#specializations -> (SPECIALIZATION ...)
-; ##compiler#local-specializations -> (SPECIALIZATION ...)
-; ##compiler#enforce -> BOOL
-; ##compiler#special-result-type -> PROCEDURE
-; ##compiler#escape -> #f | 'yes | 'no
-; ##compiler#type-abbreviation -> TYPESPEC
-;
-; specialization specifiers:
-;
-; SPECIALIZATION = ((TYPE ... [#!rest TYPE]) [RESULTS] TEMPLATE)
-; TEMPLATE = #(INDEX)
-; | #(INDEX ...)
-; | #(SYMBOL)
-; | INTEGER | SYMBOL | STRING
-; | (quote CONSTANT)
-; | (TEMPLATE . TEMPLATE)
-;
-; As an alternative to the "#!rest" and "#!optional" keywords, "&rest" or
"&optional"
-; may be used.
+;;
+;; result specifiers:
+;;
+;; SPEC = * | (TYPE1 ...)
+;; TYPE = (or TYPE1 ...)
+;; | (not TYPE)
+;; | (struct NAME)
+;; | (procedure [NAME] (TYPE1 ... [#!optional TYPE1 ...] [#!rest [TYPE
| values]]) . RESULTS)
+;; | VALUE
+;; | BASIC
+;; | COMPLEX
+;; | (forall (TVAR1 ...) TYPE)
+;; | (refine (SYMBOL ...) VALUE)
+;; | deprecated
+;; | (deprecated NAME)
+;; VALUE = string | symbol | char | number | boolean | true | false |
+;; null | eof | blob | pointer | port | locative | fixnum |
+;; float | bignum | ratnum | cplxnum | integer | pointer-vector
+;; BASIC = * | list | pair | procedure | vector | undefined | noreturn |
values
+;; COMPLEX = (pair TYPE TYPE)
+;; | (vector-of TYPE)
+;; | (list-of TYPE)
+;; | (vector TYPE1 ...)
+;; | (list TYPE1 ...)
+;; RESULTS = *
+;; | (TYPE1 ...)
+;; TVAR = (VAR TYPE) | VAR
+;;
+;; global symbol properties:
+;;
+;; ##compiler#type -> TYPESPEC
+;; ##compiler#type-source -> 'db | 'local | 'inference
+;; ##compiler#predicate -> TYPESPEC
+;; ##compiler#specializations -> (SPECIALIZATION ...)
+;; ##compiler#local-specializations -> (SPECIALIZATION ...)
+;; ##compiler#enforce -> BOOL
+;; ##compiler#special-result-type -> PROCEDURE
+;; ##compiler#escape -> #f | 'yes | 'no
+;; ##compiler#type-abbreviation -> TYPESPEC
+;;
+;; specialization specifiers:
+;;
+;; SPECIALIZATION = ((TYPE ... [#!rest TYPE]) [RESULTS] TEMPLATE)
+;; TEMPLATE = #(INDEX)
+;; | #(INDEX ...)
+;; | #(SYMBOL)
+;; | INTEGER | SYMBOL | STRING
+;; | (quote CONSTANT)
+;; | (TEMPLATE . TEMPLATE)
+;;
+;; As an alternative to the "#!rest" and "#!optional" keywords, "&rest" or
"&optional"
+;; may be used.
(define-constant +fragment-max-length+ 6)
@@ -217,13 +217,13 @@
((boolean? lit)
(if lit 'true 'false))
((null? lit) 'null)
- ((list? lit)
+ ((list? lit)
`(list ,@(map constant-result lit)))
((pair? lit)
(simplify-type
`(pair ,(constant-result (car lit)) ,(constant-result (cdr
lit)))))
((eof-object? lit) 'eof)
- ((vector? lit)
+ ((vector? lit)
(simplify-type
`(vector ,@(map constant-result (vector->list lit)))))
((and (not (##sys#immediate? lit)) (##sys#generic-structure? lit))
@@ -248,7 +248,7 @@
(else '(*))))
(define (blist-type id flow)
- (cond ((find (lambda (b)
+ (cond ((find (lambda (b)
(and (eq? id (caar b))
(memq (cdar b) flow)) )
blist)
@@ -258,7 +258,7 @@
(define (variable-result id e loc flow)
(cond ((blist-type id flow) => list)
((and (not strict)
- (db-get db id 'assigned)
+ (db-get db id 'assigned)
(not (variable-mark id '##compiler#type-source)))
'(*))
((assq id e) =>
@@ -398,7 +398,7 @@
(atypes atypes (cdr atypes))
(i 1 (add1 i)))
((or (null? actualtypes) (null? atypes)))
- (unless (match-types
+ (unless (match-types
(car atypes)
(car actualtypes)
typeenv)
@@ -415,7 +415,7 @@
(let* ((pn (procedure-name ptype))
(trail0 trail))
(when pn
- (cond ((and (fx= 1 nargs)
+ (cond ((and (fx= 1 nargs)
(variable-mark pn '##compiler#predicate)) =>
(lambda (pt)
(cond ((match-argument-types (list pt)
(cdr actualtypes) typeenv)
@@ -473,7 +473,7 @@
(lambda (a) (set-cdr! a (add1 (cdr a)))))
(else
(set! specialization-statistics
- (cons (cons op 1)
+ (cons (cons op 1)
specialization-statistics))))))
(when (and specialize (not op) (procedure-type? ptype))
(set-car! (node-parameters node) #t)
@@ -484,7 +484,7 @@
(define tag
(let ((n 0))
- (lambda ()
+ (lambda ()
(set! n (add1 n))
n)))
@@ -509,7 +509,7 @@
(define (walk n e loc dest tail flow ctags) ; returns result specifier
(let ((subs (node-subexpressions n))
- (params (node-parameters n))
+ (params (node-parameters n))
(class (node-class n)) )
(dd "walk: ~a ~s (loc: ~a, dest: ~a, tail: ~a, flow: ~a)"
class params loc dest tail flow)
@@ -591,7 +591,7 @@
(t (single
n
(sprintf "in `let' binding of `~a'"
(real-name var))
- (walk val e loc var #f flow #f)
+ (walk val e loc var #f flow #f)
loc)))
(when (and (eq? (node-class val) '##core#variable)
(not (db-get db var 'assigned)))
@@ -610,7 +610,7 @@
(if rest (butlast vars) vars)
inits)
e)))
- (when dest
+ (when dest
(d "~a: initial-argument types: ~a" dest inits))
(fluid-let ((blist '())
(noreturn #f)
@@ -625,14 +625,14 @@
(variable-mark dest
'##compiler#type-source)
(not unsafe))
(debugging 'x "checks argument-types" dest) ;XXX
- ;; [1] this is subtle: we don't want
argtype-checks to be
- ;; generated for toplevel defs other than
user-declared ones.
+ ;; [1] this is subtle: we don't want
argtype-checks to be
+ ;; generated for toplevel defs other than
user-declared ones.
;; But since the ##compiler#type-source mark is
set AFTER
;; the lambda has been walked (see below, [2]),
nothing is added.
(generate-type-checks! n dest vars inits))
(list
(append
- '(procedure)
+ '(procedure)
namelst
(list
(let loop ((argc argc) (vars vars) (args args))
@@ -648,8 +648,8 @@
(car vars) (cdr a))
(cdr a) ))
(loop (sub1 argc) (cdr vars) (cdr
args)))))
- (else
- (cons
+ (else
+ (cons
(car args)
(loop (sub1 argc) (cdr vars) (cdr
args)))))))
r))))))))
@@ -661,7 +661,7 @@
(sprintf "in assignment to `~a'" var)
(walk (first subs) e loc var #f flow #f)
loc))
- (typeenv (append
+ (typeenv (append
(if type (type-typeenv type) '())
(type-typeenv rt)))
(b (assq var e)) )
@@ -683,7 +683,7 @@
(db-get db var 'local-value))))
(when (and (eq? val (first subs))
(or (not (variable-visible? var
block-compilation))
- (not (eq? (variable-mark var
'##compiler#inline)
+ (not (eq? (variable-mark var
'##compiler#inline)
'no))))
(let ((rtlst (list (cons #f (tree-copy rt)))))
(smash-component-types! rtlst "global")
@@ -708,7 +708,7 @@
var ot rt)))))
;; don't use "add-to-blist" since the current operation
does not affect aliases
(let ((t (if (or strict (not (db-get db var 'captured)))
- rt
+ rt
'*))
(fl (car flow)))
(let loop ((bl blist) (f #f))
@@ -738,16 +738,16 @@
(list
(single
n
- (sprintf
+ (sprintf
"in ~a of procedure call `~s'"
(if (zero? i)
"operator position"
(sprintf "argument #~a" i))
f)
- (walk n e loc #f #f flow #f)
+ (walk n e loc #f #f flow #f)
loc))
(list n)))
- subs
+ subs
(iota len)))
(fn (walked-result (car args)))
(pn (procedure-name fn))
@@ -756,7 +756,7 @@
(enforces
(and pn (variable-mark pn '##compiler#enforce)))
(pt (and pn (variable-mark pn '##compiler#predicate))))
- (let-values (((r specialized?)
+ (let-values (((r specialized?)
(call-result n args e loc params typeenv)))
(define (smash)
(when (and (not strict)
@@ -784,7 +784,7 @@
(oparg? (eq? arg (first subs)))
(pred (and pt
ctags
- (not (db-get db var
'assigned))
+ (not (db-get db var
'assigned))
(not oparg?))))
(cond (pred
;;XXX is this needed? "typeenv" is
the te of "args",
@@ -810,24 +810,24 @@
(let ((ar (if (db-get db var
'assigned)
'* ; XXX necessary?
(refine-types a
argr))))
- (d " assuming: ~a -> ~a (flow:
~a)"
+ (d " assuming: ~a -> ~a (flow:
~a)"
var ar (car flow))
(add-to-blist var (car flow) ar)
(when ctags
(add-to-blist var (car ctags)
ar)
(add-to-blist var (cdr ctags)
ar)))))
((and oparg?
- (variable-mark
+ (variable-mark
var
'##compiler#special-result-type))
=> (lambda (srt)
(dd " hardcoded special
result-type: ~a" var)
(set! r (srt n args loc
r))))))))
subs
- (cons
+ (cons
fn
- (nth-value
- 0
+ (nth-value
+ 0
(procedure-argument-types fn (sub1 len)
typeenv))))
(smash)
(if (eq? '* r)
@@ -894,7 +894,7 @@
'(o e)
(lambda ()
(print "specializations:")
- (for-each
+ (for-each
(lambda (ss)
(printf " ~a ~s~%" (cdr ss) (car ss)))
specialization-statistics))))
@@ -907,7 +907,7 @@
(when errors
(quit-compiling "some variable types do not satisfy strictness"))
rn)))
-
+
;;; replace pair/vector types with components to variants with undetermined
;; component types (used for env or blist); also convert "list[-of]" types
@@ -944,19 +944,19 @@
;;; Type-matching
-;
-; - "all" means: all elements in `or'-types in second argument must match
+;;
+;; - "all" means: all elements in `or'-types in second argument must match
(define (match-types t1 t2 #!optional (typeenv (type-typeenv `(or ,t1 ,t2)))
all)
(define (match-args args1 args2)
(d "match args: ~s <-> ~s" args1 args2)
(let loop ((args1 args1) (args2 args2) (opt1 #f) (opt2 #f))
- (cond ((null? args1)
+ (cond ((null? args1)
(or opt2
(null? args2)
(optargs? (car args2))))
- ((null? args2)
+ ((null? args2)
(or opt1
(optargs? (car args1))))
((eq? '#!optional (car args1))
@@ -973,7 +973,7 @@
(define (match-rest rtype args opt) ;XXX currently ignores `opt'
(let-values (((head tail) (span (lambda (x) (not (eq? '#!rest x))) args)))
- (and (every
+ (and (every
(lambda (t)
(or (eq? '#!optional t)
(match1 rtype t)))
@@ -990,7 +990,7 @@
((null? results2) #f)
((and (memq (car results1) '(undefined noreturn))
(memq (car results2) '(undefined noreturn))))
- ((match1 (car results1) (car results2))
+ ((match1 (car results1) (car results2))
(match-results (cdr results1) (cdr results2)))
(else #f)))
@@ -1009,8 +1009,8 @@
(dd " match1: ~s <-> ~s" t1 t2)
(cond ((eq? t1 t2))
;;XXX do we have to handle circularities?
- ((and (symbol? t1) (assq t1 typeenv)) =>
- (lambda (e)
+ ((and (symbol? t1) (assq t1 typeenv)) =>
+ (lambda (e)
(cond ((second e)
(and (match1 (second e) t2)
(or (not (third e)) ; constraint
@@ -1032,8 +1032,8 @@
(set-car! (cdr e) t2)
#t)
(else #f))))
- ((and (symbol? t2) (assq t2 typeenv)) =>
- (lambda (e)
+ ((and (symbol? t2) (assq t2 typeenv)) =>
+ (lambda (e)
(cond ((second e)
(and (match1 t1 (second e))
(or (not (third e)) ; constraint
@@ -1075,7 +1075,7 @@
all
(lambda (t) (match1 t1 t))))
;; s.a.
- ((and (pair? t1) (eq? 'or (car t1)))
+ ((and (pair? t1) (eq? 'or (car t1)))
(over-all-instantiations
(cdr t1)
typeenv
@@ -1195,7 +1195,7 @@
((null? atypes) #f)
((equal? '(#!rest) tl))
((eq? (car tl) '#!rest)
- (every
+ (every
(lambda (at)
(match-types (cadr tl) at typeenv #t))
atypes))
@@ -1205,9 +1205,9 @@
;;; Simplify type specifier
-;
-; - coalesces "forall" and renames type-variables
-; - also removes unused typevars
+;;
+;; - coalesces "forall" and renames type-variables
+;; - also removes unused typevars
(define (simplify-type t)
(let ((typeenv '()) ; ((VAR1 . NEWVAR1) ...)
@@ -1222,7 +1222,7 @@
(else x)))
(define (simplify t)
;;(dd "simplify/rec: ~s" t)
- (call/cc
+ (call/cc
(lambda (return)
(cond ((pair? t)
(case (car t)
@@ -1236,8 +1236,8 @@
(cons v v*))))
typevars)
typeenv))
- (set! constraints
- (append (filter-map
+ (set! constraints
+ (append (filter-map
(lambda (v)
(and (pair? v) v))
typevars)
@@ -1341,7 +1341,7 @@
(else t)))))
(let ((t2 (simplify t)))
(when (pair? used)
- (set! t2
+ (set! t2
`(forall ,(filter-map
(lambda (e)
(and (memq (car e) used)
@@ -1361,10 +1361,10 @@
;;; Merging types
-(define (merge-argument-types ts1 ts2)
+(define (merge-argument-types ts1 ts2)
;; this could be more elegantly done by combining non-matching
arguments/llists
;; into "(or (procedure ...) (procedure ...))" and then simplifying
- (cond ((null? ts1)
+ (cond ((null? ts1)
(cond ((null? ts2) '())
((memq (car ts2) '(#!rest #!optional)) ts2)
(else '(#!rest))))
@@ -1378,7 +1378,7 @@
(else '(#!rest)))) ;XXX giving up
((eq? '#!optional (car ts1))
(cond ((and (pair? ts2) (eq? '#!optional (car ts2)))
- `(#!optional
+ `(#!optional
,(simplify-type `(or ,(cadr ts1) ,(cadr ts2)))
,@(merge-argument-types (cddr ts1) (cddr ts2))))
(else '(#!rest)))) ;XXX
@@ -1459,7 +1459,7 @@
(define (procedure-type? t)
(or (eq? 'procedure t)
- (and (pair? t)
+ (and (pair? t)
(case (car t)
((forall) (procedure-type? (third t)))
((procedure) #t)
@@ -1560,7 +1560,7 @@
(loop1 t))
(define (named? t)
- (and (pair? t)
+ (and (pair? t)
(case (car t)
((procedure)
(not (or (null? (cadr t)) (pair? (cadr t)))))
@@ -1621,7 +1621,7 @@
(when (pair? (cddr t))
(for-each loop (cddr t))))))
((forall)
- (set! te (append (map (lambda (tv)
+ (set! te (append (map (lambda (tv)
(if (symbol? tv)
(list tv #f #f)
(list (first tv) #f (second tv))))
@@ -1647,7 +1647,7 @@
(define (resolve t typeenv)
(simplify-type ;XXX do only when necessary
(let resolve ((t t) (done '()))
- (cond ((assq t typeenv) =>
+ (cond ((assq t typeenv) =>
(lambda (a)
(let ((t2 (second a)))
(if (or (not t2)
@@ -1656,11 +1656,11 @@
(resolve (third a) (cons t done))
'*)
(resolve t2 (cons t done))))))
- ((not (pair? t))
+ ((not (pair? t))
(if (or (memq t value-types) (memq t basic-types))
t
(bomb "resolve: can't resolve unknown type-variable" t)))
- (else
+ (else
(case (car t)
((or) `(or ,@(map (cut resolve <> done) (cdr t))))
((not) `(not ,(resolve (second t) done)))
@@ -1880,7 +1880,7 @@
;; - handles some type aliases
;; - drops "#!key ..." args by converting to #!rest
;; - replaces uses of "&rest"/"&optional" with "#!rest"/"#!optional"
- ;; - handles "(T1 -> T2 : T3)" (predicate)
+ ;; - handles "(T1 -> T2 : T3)" (predicate)
;; - handles "(T1 --> T2 [: T3])" (clean)
;; - simplifies result
;; - coalesces all "forall" forms into one (remove "forall" if typevar-set
is empty)
@@ -1929,7 +1929,7 @@
((eq? t 'input-port) '(refine (input) port))
((eq? t 'output-port) '(refine (output) port))
((and (symbol? t) (##sys#get t '##compiler#type-abbreviation)))
- ((not (pair? t))
+ ((not (pair? t))
(cond ((memq t typevars) t)
(else #f)))
((eq? 'not (car t))
@@ -1970,7 +1970,7 @@
(unless (memq v typevars)
(set! typevars (cons v typevars)))
v))
- ((eq? 'or (car t))
+ ((eq? 'or (car t))
(and (list? t)
(let ((ts (map validate (cdr t))))
(and (every identity ts)
@@ -2015,7 +2015,7 @@
(and (list? t)
(let loop ((ts (cdr t)) (ts2 '()))
(cond ((null? ts) `(,(car t) ,@(reverse ts2)))
- ((validate (car ts)) =>
+ ((validate (car ts)) =>
(lambda (t2) (loop (cdr ts) (cons t2 ts2))))
(else #f)))))
((eq? 'pair (car t))
@@ -2034,14 +2034,14 @@
(and ts
(every identity ts)
(let* ((rt2 (cdr t2))
- (rt (if (eq? '* rt2)
+ (rt (if (eq? '* rt2)
rt2
(and (list? rt2)
(let ((rts (map validate
rt2)))
(and (every identity rts)
rts))))))
(and rt
- `(procedure
+ `(procedure
,@(if (and name (not rec)) (list name)
'())
,ts
,@rt)))))))))
@@ -2057,7 +2057,7 @@
(delete-duplicates typevars eq?))
,type)))
(let ((type2 (simplify-type type)))
- (values
+ (values
type2
(and ptype (eq? (car ptype) type) (cdr ptype))
clean))))
@@ -2065,13 +2065,13 @@
(define (check-and-validate-type type loc #!optional name)
(let-values (((t pred pure) (validate-type (strip-syntax type) name)))
- (or t
+ (or t
(error loc "invalid type specifier" type))))
(define (install-specializations name specs)
(define (fail spec)
(error "invalid specialization format" spec name))
- (mark-variable
+ (mark-variable
name '##compiler#specializations
;;XXX it would be great if result types could refer to typevars
;; bound in the argument types, like this:
@@ -2086,10 +2086,10 @@
(map (lambda (spec)
(if (and (list? spec) (list? (first spec)))
(let* ((args
- (map (lambda (t)
+ (map (lambda (t)
(let-values (((t2 pred pure) (validate-type t #f)))
(or t2
- (error "invalid argument type in
specialization"
+ (error "invalid argument type in
specialization"
t spec name))))
(first spec)))
(typevars (unzip1 (append-map type-typeenv args))))
@@ -2097,13 +2097,13 @@
args
(case (length spec)
((2) (cdr spec))
- ((3)
+ ((3)
(cond ((list? (second spec))
(cons
(map (lambda (t)
(let-values (((t2 pred pure) (validate-type
t #f)))
(or t2
- (error "invalid result type in
specialization"
+ (error "invalid result type in
specialization"
t spec name))))
(second spec))
(cddr spec)))
@@ -2115,9 +2115,9 @@
;;; Canonicalize complex pair/list type for matching with "list-of"
-;
-; Returns an equivalent (list ...) form, or the original argument if no
-; canonicalization could be done.
+;;
+;; Returns an equivalent (list ...) form, or the original argument if no
+;; canonicalization could be done.
(define (canonicalize-list-type t)
(cond ((not (pair? t)) t)
@@ -2233,10 +2233,10 @@
;;; List-related special cases
-;
-; Preserve known element types for:
-;
-; list-ref, list-tail
+;;
+;; Preserve known element types for:
+;;
+;; list-ref, list-tail
(let ()
;; See comment in vector (let) just above this
@@ -2403,8 +2403,8 @@
(define-special-case ##sys#append append-special-case))
;;; Special cases for make-list/make-vector with a known size
-;
-; e.g. (make-list 3 #\a) => (list char char char)
+;;
+;; e.g. (make-list 3 #\a) => (list char char char)
(let ()
@@ -2428,8 +2428,8 @@
;;; perform check over all typevar instantiations
-;
-; If "all" is #t all types in tlist must match, if #f then one or more.
+;;
+;; If "all" is #t all types in tlist must match, if #f then one or more.
(define (over-all-instantiations tlist typeenv all process)
(let ((insts '())
@@ -2445,7 +2445,7 @@
(set! trail tr)
(when (pair? is) (set! anyinst #t))
(set! insts (cons is insts)))
- (set! is (alist-cons
+ (set! is (alist-cons
(car tr)
(resolve (car tr) typeenv)
is))
@@ -2476,7 +2476,7 @@
(ok #f))
(cond ((null? ts)
(cond ((or ok (null? tlist))
- (for-each
+ (for-each
(lambda (i)
(set! trail (cons (car i) trail))
(set-car! (cdr (assq (car i) typeenv))
@@ -2490,7 +2490,7 @@
(all
(restore)
#f)
- (else
+ (else
(restore)
(loop (cdr ts) ok))))))
)
--
2.7.4
>From f0751dc5cb72f5b534ec733e57f5786fa645b43a Mon Sep 17 00:00:00 2001
From: megane <address@hidden>
Date: Mon, 19 Nov 2018 10:01:33 +0200
Subject: [PATCH 2/9] Add new test test-scrutinizer-message-format.scm
* test-scrutinizer-message-format.scm: Covers most, but not all scrutinizer
messages.
* tests/runtests.sh: Move scrutiny-tests-2.scm up so all output is generated
before diffing anything
---
tests/runtests.sh | 6 +-
tests/scrutinizer-message-format.expected | 238 ++++++++++++++++++++++++++++++
tests/test-scrutinizer-message-format.scm | 77 ++++++++++
3 files changed, 319 insertions(+), 2 deletions(-)
create mode 100644 tests/scrutinizer-message-format.expected
create mode 100644 tests/test-scrutinizer-message-format.scm
diff --git a/tests/runtests.sh b/tests/runtests.sh
index 6675bb0..2f368a7 100755
--- a/tests/runtests.sh
+++ b/tests/runtests.sh
@@ -123,11 +123,13 @@ if test \! -f specialization.expected; then
cp specialization.expected specialization.out
fi
+$compile scrutiny-tests-2.scm -A -verbose 2>scrutiny-2.out
+$compile test-scrutinizer-message-format.scm -A -verbose
2>scrutinizer-message-format.out || true
+
+diff $DIFF_OPTS scrutinizer-message-format.expected
scrutinizer-message-format.out
diff $DIFF_OPTS scrutiny.expected scrutiny.out
diff $DIFF_OPTS specialization.expected specialization.out
-$compile scrutiny-tests-2.scm -A 2>scrutiny-2.out -verbose
-
# this is sensitive to gensym-names, so make it optional
if test \! -f scrutiny-2.expected; then
cp scrutiny-2.expected scrutiny-2.out
diff --git a/tests/scrutinizer-message-format.expected
b/tests/scrutinizer-message-format.expected
new file mode 100644
index 0000000..9c7299f
--- /dev/null
+++ b/tests/scrutinizer-message-format.expected
@@ -0,0 +1,238 @@
+
+Warning: literal in operator position: (1 2)
+
+Warning: literal in operator position: (1 2)
+
+Warning: in toplevel procedure `r-proc-call-argument-count-mismatch':
+ (test-scrutinizer-message-format.scm:9) in procedure call to `scheme#cons',
expected 2 arguments but was given 1 argument
+
+Warning: in toplevel procedure `r-proc-call-argument-type-mismatch':
+ (test-scrutinizer-message-format.scm:10) in procedure call to
`scheme#length', expected argument #1 of type `list' but was given an argument
of type `symbol'
+
+Warning: in toplevel procedure `r-proc-call-argument-value-count':
+ (test-scrutinizer-message-format.scm:11) expected a single result in
argument #1 of procedure call `(scheme#list (chicken.time#cpu-time))', but
received 2 results
+
+Warning: in toplevel procedure `r-proc-call-argument-value-count':
+ (test-scrutinizer-message-format.scm:11) expected a single result in
argument #1 of procedure call `(scheme#vector (scheme#values))', but received
zero results
+
+Warning: in toplevel procedure `r-proc-call-argument-value-count':
+ expected a single result in `let' binding of `g28', but received zero results
+
+Warning: in toplevel procedure `r-cond-branch-value-count-mismatch':
+ branches in conditional expression differ in the number of results:
+
+(if (the * 1) 1 (scheme#values 1 2))
+
+Warning: in toplevel procedure `r-invalid-called-procedure-type':
+ in procedure call to `1', expected a value of type `(procedure (*) *)' but
was given a value of type `fixnum'
+
+Note: in toplevel procedure `r-pred-call-always-true':
+ (test-scrutinizer-message-format.scm:14) in procedure call to
`scheme#list?', the predicate is called with an argument of type `null' and
will always return true
+
+Note: in toplevel procedure `r-pred-call-always-false':
+ (test-scrutinizer-message-format.scm:15) in procedure call to
`scheme#symbol?', the predicate is called with an argument of type `fixnum' and
will always return false
+
+Note: in toplevel procedure `r-cond-test-always-true':
+ expected a value of type boolean in conditional, but was given a value of
type `symbol' which is always true:
+
+(if 'symbol 1 (##core#undefined))
+
+Note: in toplevel procedure `r-cond-test-always-false':
+ in conditional, test expression will always return false:
+
+(if #f 1 (##core#undefined))
+
+Note: in toplevel procedure `r-type-mismatch-in-the':
+ expression returns a result of type `fixnum' but is declared to return
`symbol', which is not compatible
+
+Warning: in toplevel procedure `r-zero-values-for-the':
+ expression returns zero values but is declared to have a single result of
type `symbol'
+
+Warning: in toplevel procedure `r-too-many-values-for-the':
+ expression returns 2 values but is declared to have a single result
+
+Note: in toplevel procedure `r-too-many-values-for-the':
+ expression returns a result of type `fixnum' but is declared to return
`symbol', which is not compatible
+
+Warning: in toplevel procedure `r-toplevel-var-assignment-type-mismatch':
+ assignment of value of type `fixnum' to toplevel variable `foo' does not
match declared type `boolean'
+
+Warning: in toplevel procedure `r-deprecated-identifier':
+ use of deprecated `deprecated-foo'
+
+Warning: in toplevel procedure `r-deprecated-identifier':
+ use of deprecated `deprecated-foo2' - consider `foo'
+
+Warning: at toplevel:
+ assignment of value of type `fixnum' to toplevel variable `foo' does not
match declared type `boolean'
+
+Warning: in toplevel procedure `list-ref-negative-index':
+ (test-scrutinizer-message-format.scm:26) in procedure call to
`scheme#list-ref', index -1 is negative, which is never valid
+
+Warning: in toplevel procedure `list-ref-out-of-range':
+ (test-scrutinizer-message-format.scm:27) in procedure call to
`scheme#list-ref', index 1 out of range for proper list of length 0
+
+Warning: in toplevel procedure `vector-ref-out-of-range':
+ (test-scrutinizer-message-format.scm:29) in procedure call to
`scheme#vector-ref', index -1 out of range for vector of length 0
+
+Warning: in toplevel procedure `zero-values-for-let':
+ expected a single result in `let' binding of `a', but received zero results
+
+Warning: in toplevel procedure `multiple-values-for-let':
+ expected a single result in `let' binding of `a', but received 2 results
+
+Warning: in toplevel procedure `zero-values-for-conditional':
+ expected a single result in conditional, but received zero results
+
+Warning: in toplevel procedure `multiple-values-for-conditional':
+ expected a single result in conditional, but received 2 results
+
+Note: in toplevel procedure `multiple-values-for-conditional':
+ (test-scrutinizer-message-format.scm:33) expected a value of type boolean in
conditional, but was given a value of type `fixnum' which is always true:
+
+(if (scheme#values 1 2) 1 (##core#undefined))
+
+Warning: in local procedure `r-proc-call-argument-count-mismatch',
+ in local procedure `local-bar',
+ in toplevel procedure `m#toplevel-foo':
+ (test-scrutinizer-message-format.scm:52) in procedure call to `scheme#cons',
expected 2 arguments but was given 1 argument
+
+Warning: in local procedure `r-proc-call-argument-type-mismatch',
+ in local procedure `local-bar',
+ in toplevel procedure `m#toplevel-foo':
+ (test-scrutinizer-message-format.scm:53) in procedure call to
`scheme#length', expected argument #1 of type `list' but was given an argument
of type `symbol'
+
+Warning: in local procedure `r-proc-call-argument-value-count',
+ in local procedure `local-bar',
+ in toplevel procedure `m#toplevel-foo':
+ (test-scrutinizer-message-format.scm:54) expected a single result in
argument #1 of procedure call `(scheme#list (chicken.time#cpu-time))', but
received 2 results
+
+Warning: in local procedure `r-proc-call-argument-value-count',
+ in local procedure `local-bar',
+ in toplevel procedure `m#toplevel-foo':
+ (test-scrutinizer-message-format.scm:54) expected a single result in
argument #1 of procedure call `(scheme#vector (scheme#values))', but received
zero results
+
+Warning: in local procedure `r-proc-call-argument-value-count',
+ in local procedure `local-bar',
+ in toplevel procedure `m#toplevel-foo':
+ expected a single result in `let' binding of `g90', but received zero results
+
+Warning: in local procedure `r-cond-branch-value-count-mismatch',
+ in local procedure `local-bar',
+ in toplevel procedure `m#toplevel-foo':
+ branches in conditional expression differ in the number of results:
+
+(if (the * 1) 1 (chicken.time#cpu-time))
+
+Warning: in local procedure `r-invalid-called-procedure-type',
+ in local procedure `local-bar',
+ in toplevel procedure `m#toplevel-foo':
+ in procedure call to `1', expected a value of type `(procedure (*) *)' but
was given a value of type `fixnum'
+
+Note: in local procedure `r-pred-call-always-true',
+ in local procedure `local-bar',
+ in toplevel procedure `m#toplevel-foo':
+ (test-scrutinizer-message-format.scm:57) in procedure call to
`scheme#list?', the predicate is called with an argument of type `null' and
will always return true
+
+Note: in local procedure `r-pred-call-always-false',
+ in local procedure `local-bar',
+ in toplevel procedure `m#toplevel-foo':
+ (test-scrutinizer-message-format.scm:58) in procedure call to
`scheme#symbol?', the predicate is called with an argument of type `fixnum' and
will always return false
+
+Note: in local procedure `r-cond-test-always-true',
+ in local procedure `local-bar',
+ in toplevel procedure `m#toplevel-foo':
+ (test-scrutinizer-message-format.scm:59) expected a value of type boolean in
conditional, but was given a value of type `fixnum' which is always true:
+
+(if (scheme#length '()) 1 (##core#undefined))
+
+Note: in local procedure `r-cond-test-always-false',
+ in local procedure `local-bar',
+ in toplevel procedure `m#toplevel-foo':
+ in conditional, test expression will always return false:
+
+(if #f 1 (##core#undefined))
+
+Note: in local procedure `r-type-mismatch-in-the',
+ in local procedure `local-bar',
+ in toplevel procedure `m#toplevel-foo':
+ expression returns a result of type `fixnum' but is declared to return
`symbol', which is not compatible
+
+Warning: in local procedure `r-zero-values-for-the',
+ in local procedure `local-bar',
+ in toplevel procedure `m#toplevel-foo':
+ expression returns zero values but is declared to have a single result of
type `symbol'
+
+Warning: in local procedure `r-too-many-values-for-the',
+ in local procedure `local-bar',
+ in toplevel procedure `m#toplevel-foo':
+ expression returns 2 values but is declared to have a single result
+
+Note: in local procedure `r-too-many-values-for-the',
+ in local procedure `local-bar',
+ in toplevel procedure `m#toplevel-foo':
+ expression returns a result of type `fixnum' but is declared to return
`symbol', which is not compatible
+
+Warning: in local procedure `r-toplevel-var-assignment-type-mismatch',
+ in local procedure `local-bar',
+ in toplevel procedure `m#toplevel-foo':
+ assignment of value of type `fixnum' to toplevel variable `m#foo2' does not
match declared type `boolean'
+
+Warning: in local procedure `r-deprecated-identifier',
+ in local procedure `local-bar',
+ in toplevel procedure `m#toplevel-foo':
+ use of deprecated `m#deprecated-foo'
+
+Warning: in local procedure `r-deprecated-identifier',
+ in local procedure `local-bar',
+ in toplevel procedure `m#toplevel-foo':
+ use of deprecated `m#deprecated-foo2' - consider `foo'
+
+Warning: in local procedure `list-ref-negative-index',
+ in local procedure `local-bar',
+ in toplevel procedure `m#toplevel-foo':
+ (test-scrutinizer-message-format.scm:67) in procedure call to
`scheme#list-ref', index -1 is negative, which is never valid
+
+Warning: in local procedure `list-ref-out-of-range',
+ in local procedure `local-bar',
+ in toplevel procedure `m#toplevel-foo':
+ (test-scrutinizer-message-format.scm:68) in procedure call to
`scheme#list-ref', index 1 out of range for proper list of length 0
+
+Warning: in local procedure `vector-ref-out-of-range',
+ in local procedure `local-bar',
+ in toplevel procedure `m#toplevel-foo':
+ (test-scrutinizer-message-format.scm:70) in procedure call to
`scheme#vector-ref', index -1 out of range for vector of length 0
+
+Warning: in local procedure `zero-values-for-let',
+ in local procedure `local-bar',
+ in toplevel procedure `m#toplevel-foo':
+ expected a single result in `let' binding of `a', but received zero results
+
+Warning: in local procedure `multiple-values-for-let',
+ in local procedure `local-bar',
+ in toplevel procedure `m#toplevel-foo':
+ expected a single result in `let' binding of `a', but received 2 results
+
+Warning: in local procedure `zero-values-for-conditional',
+ in local procedure `local-bar',
+ in toplevel procedure `m#toplevel-foo':
+ expected a single result in conditional, but received zero results
+
+Warning: in local procedure `multiple-values-for-conditional',
+ in local procedure `local-bar',
+ in toplevel procedure `m#toplevel-foo':
+ expected a single result in conditional, but received 2 results
+
+Note: in local procedure `multiple-values-for-conditional',
+ in local procedure `local-bar',
+ in toplevel procedure `m#toplevel-foo':
+ (test-scrutinizer-message-format.scm:74) expected a value of type boolean in
conditional, but was given a value of type `fixnum' which is always true:
+
+(if (scheme#values 1 2) 1 (##core#undefined))
+
+Error: in local procedure `fail-compiler-typecase',
+ in local procedure `local-bar',
+ in toplevel procedure `m#toplevel-foo':
+ (test-scrutinizer-message-format.scm:76) no clause applies in
`compiler-typecase' for expression of type `fixnum':
+ symbol
+ list
diff --git a/tests/test-scrutinizer-message-format.scm
b/tests/test-scrutinizer-message-format.scm
new file mode 100644
index 0000000..d792cf3
--- /dev/null
+++ b/tests/test-scrutinizer-message-format.scm
@@ -0,0 +1,77 @@
+(import (chicken time))
+(: deprecated-foo deprecated)
+(define deprecated-foo 1)
+(: deprecated-foo2 (deprecated foo))
+(define deprecated-foo2 2)
+(: foo boolean)
+(define foo #t)
+
+(define (r-proc-call-argument-count-mismatch) (cons '()))
+(define (r-proc-call-argument-type-mismatch) (length 'symbol))
+(define (r-proc-call-argument-value-count) (list (cpu-time)) (vector (values))
((values)))
+(define (r-cond-branch-value-count-mismatch) (if (the * 1) 1 (values 1 2)))
+(define (r-invalid-called-procedure-type) (1 2))
+(define (r-pred-call-always-true) (list? '()))
+(define (r-pred-call-always-false) (symbol? 1))
+(define (r-cond-test-always-true) (if 'symbol 1))
+(define (r-cond-test-always-false) (if #f 1))
+(define (r-type-mismatch-in-the) (the symbol 1))
+(define (r-zero-values-for-the) (the symbol (values)))
+(define (r-too-many-values-for-the) (the symbol (values 1 2)))
+(define (r-toplevel-var-assignment-type-mismatch) (set! foo 1))
+(define (r-deprecated-identifier) (list deprecated-foo) (vector
deprecated-foo2))
+
+(set! foo 1)
+
+(define (list-ref-negative-index) (list-ref '() -1))
+(define (list-ref-out-of-range) (list-ref '() 1))
+(define (append-invalid-last-arg) (scheme#append (list 1) 1)) ;; TODO: doesn't
work
+(define (vector-ref-out-of-range) (vector-ref (vector) -1))
+(define (zero-values-for-let) (let ((a (values))) a))
+(define (multiple-values-for-let) (let ((a (values 1 2))) a))
+(define (zero-values-for-conditional) (if (values) 1))
+(define (multiple-values-for-conditional) (if (values 1 2) 1))
+
+;; (define (fail-compiler-typecase) (compiler-typecase 1 (symbol 1) (list 2)))
+
+(module
+ m
+ ()
+ (import scheme)
+ (import (chicken base) (chicken type) (chicken time))
+
+ (: foo2 boolean)
+ (define foo2 #t)
+ (: deprecated-foo deprecated)
+ (define deprecated-foo 1)
+ (: deprecated-foo2 (deprecated foo))
+ (define deprecated-foo2 2)
+
+ (define (toplevel-foo)
+ (define (local-bar)
+ (define (r-proc-call-argument-count-mismatch) (cons '()))
+ (define (r-proc-call-argument-type-mismatch) (length 'symbol))
+ (define (r-proc-call-argument-value-count) (list (cpu-time)) (vector
(values)) ((values)))
+ (define (r-cond-branch-value-count-mismatch) (if (the * 1) 1 (cpu-time)))
+ (define (r-invalid-called-procedure-type) (1 2))
+ (define (r-pred-call-always-true) (list? '()))
+ (define (r-pred-call-always-false) (symbol? 1))
+ (define (r-cond-test-always-true) (if (length '()) 1))
+ (define (r-cond-test-always-false) (if #f 1))
+ (define (r-type-mismatch-in-the) (the symbol 1))
+ (define (r-zero-values-for-the) (the symbol (values)))
+ (define (r-too-many-values-for-the) (the symbol (values 1 2)))
+ (define (r-toplevel-var-assignment-type-mismatch) (set! foo2 1))
+ (define (r-deprecated-identifier) (list deprecated-foo) (vector
deprecated-foo2))
+
+ (define (list-ref-negative-index) (list-ref '() -1))
+ (define (list-ref-out-of-range) (list-ref '() 1))
+ (define (append-invalid-last-arg) (scheme#append (list 1) 1)) ;; TODO:
doesn't work
+ (define (vector-ref-out-of-range) (vector-ref (vector) -1))
+ (define (zero-values-for-let) (let ((a (values))) a))
+ (define (multiple-values-for-let) (let ((a (values 1 2))) a))
+ (define (zero-values-for-conditional) (if (values) 1))
+ (define (multiple-values-for-conditional) (if (values 1 2) 1))
+
+ (define (fail-compiler-typecase) (compiler-typecase 1 (symbol 1) (list
2)))
+ )))
--
2.7.4
>From 328665ee1a9635a1ff7e95267fbaa096ac47cf2a Mon Sep 17 00:00:00 2001
From: megane <address@hidden>
Date: Fri, 16 Nov 2018 18:07:23 +0200
Subject: [PATCH 3/9] * scrutinizer.scm: Extract most scrutinizer messages into
separate functions
* scrutinizer.scm (scrutinize): Shuffle around report-notice, report,
report-error, fragment, pp-fragment so the reporting functions can
be as much to the left as possible
---
scrutinizer.scm | 242 ++++++++++++++++++++++++++++++++------------------------
1 file changed, 140 insertions(+), 102 deletions(-)
diff --git a/scrutinizer.scm b/scrutinizer.scm
index 216da8b..bfa1a17 100644
--- a/scrutinizer.scm
+++ b/scrutinizer.scm
@@ -196,12 +196,135 @@
(sprintf "in local ~a,\n ~a" (lname (car loc)) (rec (cdr
loc))))))))
(define (scrutinize node db complain specialize strict block-compilation)
+ (define errors? #f)
+ (define (report-notice loc msg . args)
+ (when complain
+ (##sys#notice
+ (conc (location-name loc)
+ (sprintf "~?" msg (map type-name args))))))
+
+ (define (report loc msg . args)
+ (when complain
+ (warning
+ (conc (location-name loc)
+ (sprintf "~?" msg (map type-name args))))))
+
+ (define (report-error loc msg . args)
+ (set! errors? #t)
+ (apply report loc msg args))
+
+ (define (r-invalid-called-procedure-type loc pname xptype ptype)
+ (report
+ loc
+ "~aexpected a value of type `~a' but was given a value of type `~a'"
+ pname xptype ptype))
+
+ (define (r-proc-call-argument-count-mismatch loc pname exp-count argc)
+ (report
+ loc
+ "~aexpected ~a argument~a but was given ~a argument~a"
+ pname
+ exp-count (multiples exp-count)
+ argc (multiples argc)))
+
+ (define (r-proc-call-argument-type-mismatch loc pname i xptype atype)
+ (report
+ loc
+ "~aexpected argument #~a of type `~a' but was given an argument of type
`~a'"
+ pname i xptype atype))
+
+ (define (r-pred-call-always-true loc pname atype)
+ (report-notice
+ loc
+ "~athe predicate is called with an argument of type `~a' \
+ and will always return true"
+ pname atype))
+
+ (define (r-pred-call-always-false loc pname atype)
+ (report-notice
+ loc
+ "~athe predicate is called with an argument of type `~a' \
+ and will always return false"
+ pname atype))
+
+ (define (r-cond-test-always-true loc test-node t if-node)
+ (report-notice
+ loc "~aexpected a value of type boolean in conditional, but \
+ was given a value of type `~a' which is always true:~%~%~a"
+ (node-source-prefix test-node) t (pp-fragment if-node)))
+
+ (define (r-cond-test-always-false loc test-node if-node)
+ (report-notice
+ loc "~ain conditional, test expression will always return false:~%~%~a"
+ (node-source-prefix test-node) (pp-fragment if-node)))
+
+ (define (r-zero-values-for-the loc the-type)
+ ;; (the t r) expects r returns exactly 1 value
+ (report
+ loc
+ "expression returns zero values but is declared to have \
+ a single result of type `~a'"
+ the-type))
+
+ (define (r-too-many-values-for-the loc rtypes)
+ (report
+ loc
+ "expression returns ~a values but is declared to have \
+ a single result" (length rtypes)))
+
+ (define (r-type-mismatch-in-the loc first-rtype the-type)
+ ((if strict report-error report-notice)
+ loc
+ "expression returns a result of type `~a' but is \
+ declared to return `~a', which is not compatible"
+ first-rtype the-type))
+
+ (define (fail-compiler-typecase loc node atype ct-types)
+ (quit-compiling
+ "~a~ano clause applies in `compiler-typecase' for expression of type
`~a':~a"
+ (location-name loc)
+ (node-source-prefix node)
+ (type-name atype)
+ (string-intersperse (map (lambda (t) (sprintf "\n ~a" (type-name t)))
ct-types)
+ "")))
+
+ (define (fragment x)
+ (let ((x (build-expression-tree (source-node-tree x))))
+ (let walk ((x x) (d 0))
+ (cond ((atom? x) (strip-syntax x))
+ ((>= d +fragment-max-depth+) '...)
+ ((list? x)
+ (let* ((len (length x))
+ (xs (if (< +fragment-max-length+ len)
+ (append (take x +fragment-max-length+) '(...))
+ x)))
+ (map (cute walk <> (add1 d)) xs)))
+ (else (strip-syntax x))))))
+
+ (define (pp-fragment x)
+ (string-chomp
+ (with-output-to-string
+ (lambda ()
+ (pp (fragment x))))))
+
+ (define (r-cond-branch-value-count-mismatch loc node)
+ (report
+ loc
+ "branches in conditional expression differ in the number of
results:~%~%~a"
+ (pp-fragment node)))
+
+ (define (r-toplevel-var-assignment-type-mismatch loc atype var xptype)
+ ((if strict report-error report)
+ loc
+ "assignment of value of type `~a' to toplevel variable `~a' \
+ does not match declared type `~a'"
+ atype var xptype))
+
(let ((blist '()) ; (((VAR . FLOW) TYPE) ...)
(aliased '())
(noreturn #f)
(dropped-branches 0)
(assigned-immediates 0)
- (errors #f)
(safe-calls 0))
(define (constant-result lit)
@@ -284,17 +407,12 @@
(define (always-true if-node test-node t loc)
(and-let* ((_ (always-true1 t)))
- (report-notice
- loc "~aexpected a value of type boolean in conditional, but \
- was given a value of type `~a' which is always true:~%~%~a"
- (node-source-prefix test-node) t (pp-fragment if-node))
+ (r-cond-test-always-true loc test-node t if-node)
#t))
(define (always-false if-node test-node t loc)
(and-let* ((_ (eq? t 'false)))
- (report-notice
- loc "~ain conditional, test expression will always return false:~%~%~a"
- (node-source-prefix test-node) (pp-fragment if-node))
+ (r-cond-test-always-false loc test-node if-node)
#t))
(define (always-immediate var t loc)
@@ -320,43 +438,8 @@
(node-source-prefix node) what n (multiples n))
(first tv))))))
- (define (report-notice loc msg . args)
- (when complain
- (##sys#notice
- (conc (location-name loc)
- (sprintf "~?" msg (map type-name args))))))
-
- (define (report loc msg . args)
- (when complain
- (warning
- (conc (location-name loc)
- (sprintf "~?" msg (map type-name args))))))
-
- (define (report-error loc msg . args)
- (set! errors #t)
- (apply report loc msg args))
-
(define add-loc cons)
- (define (fragment x)
- (let ((x (build-expression-tree (source-node-tree x))))
- (let walk ((x x) (d 0))
- (cond ((atom? x) (strip-syntax x))
- ((>= d +fragment-max-depth+) '...)
- ((list? x)
- (let* ((len (length x))
- (xs (if (< +fragment-max-length+ len)
- (append (take x +fragment-max-length+) '(...))
- x)))
- (map (cute walk <> (add1 d)) xs)))
- (else (strip-syntax x))))))
-
- (define (pp-fragment x)
- (string-chomp
- (with-output-to-string
- (lambda ()
- (pp (fragment x))))))
-
(define (get-specializations name)
(let* ((a (variable-mark name '##compiler#local-specializations))
(b (variable-mark name '##compiler#specializations))
@@ -377,23 +460,14 @@
(op #f))
(d " call: ~a, te: ~a" actualtypes typeenv)
(cond ((and (not pptype?) (not (match-types xptype ptype typeenv)))
- (report
- loc
- "~aexpected a value of type `~a' but was given a value of type
`~a'"
- (pname)
- (resolve xptype typeenv)
- (resolve ptype typeenv))
+ (r-invalid-called-procedure-type
+ loc (pname) (resolve xptype typeenv) (resolve ptype typeenv))
(values '* #f))
(else
(let-values (((atypes values-rest ok alen)
(procedure-argument-types ptype nargs typeenv)))
(unless ok
- (report
- loc
- "~aexpected ~a argument~a but was given ~a argument~a"
- (pname)
- alen (multiples alen)
- nargs (multiples nargs)))
+ (r-proc-call-argument-count-mismatch loc (pname) alen nargs))
(do ((actualtypes (cdr actualtypes) (cdr actualtypes))
(atypes atypes (cdr atypes))
(i 1 (add1 i)))
@@ -402,11 +476,8 @@
(car atypes)
(car actualtypes)
typeenv)
- (report
- loc
- "~aexpected argument #~a of type `~a' but was given an
argument of type `~a'"
- (pname)
- i
+ (r-proc-call-argument-type-mismatch
+ loc (pname) i
(resolve (car atypes) typeenv)
(resolve (car actualtypes) typeenv))))
(when (noreturn-procedure-type? ptype)
@@ -419,11 +490,7 @@
(variable-mark pn '##compiler#predicate)) =>
(lambda (pt)
(cond ((match-argument-types (list pt)
(cdr actualtypes) typeenv)
- (report-notice
- loc
- "~athe predicate is called with an
argument of type `~a' \
- and will always return true"
- (pname) (cadr actualtypes))
+ (r-pred-call-always-true loc
(pname) (cadr actualtypes))
(when specialize
(specialize-node!
node (cdr args)
@@ -433,11 +500,7 @@
((begin
(trail-restore trail0 typeenv)
(match-argument-types (list `(not
,pt)) (cdr actualtypes) typeenv))
- (report-notice
- loc
- "~athe predicate is called with an
argument of type `~a' \
- and will always return false"
- (pname) (cadr actualtypes))
+ (r-pred-call-always-false loc
(pname) (cadr actualtypes))
(when specialize
(specialize-node!
node (cdr args)
@@ -568,10 +631,7 @@
;;(dd " branches: ~s:~s / ~s:~s" nor1 r1
nor2 r2)
(cond ((and (not nor1) (not nor2)
(not (= (length r1) (length
r2))))
- (report
- loc
- "branches in conditional expression
differ in the number of results:~%~%~a"
- (pp-fragment n))
+ (r-cond-branch-value-count-mismatch
loc n)
'*)
(nor1 r2)
(nor2 r1)
@@ -670,11 +730,7 @@
(and (pair? type)
(eq? (car type) 'deprecated))))
(not (match-types type rt typeenv)))
- ((if strict report-error report)
- loc
- "assignment of value of type `~a' to toplevel variable
`~a' \
- does not match declared type `~a'"
- rt var type))
+ (r-toplevel-var-assignment-type-mismatch loc rt var type))
(when (and (not type) ;XXX global declaration could allow
this
(not b)
(not (eq? '* rt))
@@ -837,24 +893,13 @@
(let ((t (first params))
(rt (walk (first subs) e loc dest tail flow ctags)))
(cond ((eq? rt '*))
- ((null? rt)
- (report
- loc
- "expression returns zero values but is declared to
have \
- a single result of type `~a'" t))
+ ((null? rt) (r-zero-values-for-the loc t))
(else
(when (> (length rt) 1)
- (report
- loc
- "expression returns ~a values but is declared to
have \
- a single result" (length rt)))
+ (r-too-many-values-for-the loc rt))
(when (and (second params)
(not (compatible-types? t (first rt))))
- ((if strict report-error report-notice)
- loc
- "expression returns a result of type `~a' but is \
- declared to return `~a', which is not compatible"
- (first rt) t))))
+ (r-type-mismatch-in-the loc (first rt) t))))
(list t)))
((##core#typecase)
(let* ((ts (walk (first subs) e loc #f #f flow ctags))
@@ -863,14 +908,7 @@
;; first exp is always a variable so ts must be of length 1
(let loop ((types (cdr params)) (subs (cdr subs)))
(if (null? types)
- (quit-compiling
- "~a~ano clause applies in `compiler-typecase' for
expression of type `~a':~a"
- (location-name loc)
- (node-source-prefix n)
- (type-name (car ts))
- (string-intersperse
- (map (lambda (t) (sprintf "\n ~a" (type-name t)))
- (cdr params)) ""))
+ (fail-compiler-typecase loc n (car ts) (cdr params))
(let ((typeenv (append (type-typeenv (car types))
typeenv0)))
(if (match-types (car types) (car ts) typeenv #t)
(begin ; drops exp
@@ -904,7 +942,7 @@
(debugging '(o e) "dropped branches" dropped-branches))
(when (positive? assigned-immediates)
(debugging '(o e) "assignments to immediate values"
assigned-immediates))
- (when errors
+ (when errors?
(quit-compiling "some variable types do not satisfy strictness"))
rn)))
--
2.7.4
>From c4c4659b9828a0ec7a825206a45569548b26a0ea Mon Sep 17 00:00:00 2001
From: megane <address@hidden>
Date: Sun, 18 Nov 2018 19:06:44 +0200
Subject: [PATCH 4/9] * scrutinizer.scm (scrutinize): Move the report functions
to toplevel
* scrutinizer.scm (scrutinize): Copy report, report-notice outside as report2,
report-notice2
* scrutinizer.scm: Add global *complain?*, needed by report2, report-notice2
* scrutinizer.scm (scrutinize): Remove report-error so 'errors?' variable
doesn't need to be made global
- As a side effect (the symbol 1) now always gives a warning, which I think
is for the best
* scrutinizer.scm: Move multiples, node-source-prefix, location-name, fragment,
pp-fragment under comment "Report helpers"
---
scrutinizer.scm | 282 ++++++++++++++++--------------
tests/scrutinizer-message-format.expected | 8 +-
tests/scrutiny.expected | 2 +-
3 files changed, 154 insertions(+), 138 deletions(-)
diff --git a/scrutinizer.scm b/scrutinizer.scm
index bfa1a17..bc9d1b8 100644
--- a/scrutinizer.scm
+++ b/scrutinizer.scm
@@ -53,6 +53,7 @@
(define d-depth 0)
(define scrutiny-debug #t)
+(define *complain?* #f)
(define (d fstr . args)
(when (and scrutiny-debug (##sys#debug-mode?))
@@ -162,9 +163,6 @@
(define specialization-statistics '())
(define trail '())
-(define (multiples n)
- (if (= n 1) "" "s"))
-
(define (walked-result n)
(first (node-parameters n))) ; assumes ##core#the/result node
@@ -177,26 +175,8 @@
((memq t '(eof null fixnum char boolean undefined)) #t)
(else #f)))
-(define (node-source-prefix n)
- (let ((line (node-line-number n)))
- (if (not line) "" (sprintf "(~a) " line))))
-
-(define (location-name loc)
- (define (lname loc1)
- (if loc1
- (sprintf "procedure `~a'" (real-name loc1))
- "unknown procedure"))
- (cond ((null? loc) "at toplevel:\n ")
- ((null? (cdr loc))
- (sprintf "in toplevel ~a:\n " (lname (car loc))))
- (else
- (let rec ((loc loc))
- (if (null? (cdr loc))
- (location-name loc)
- (sprintf "in local ~a,\n ~a" (lname (car loc)) (rec (cdr
loc))))))))
-
(define (scrutinize node db complain specialize strict block-compilation)
- (define errors? #f)
+ (set! *complain?* complain)
(define (report-notice loc msg . args)
(when complain
(##sys#notice
@@ -209,120 +189,10 @@
(conc (location-name loc)
(sprintf "~?" msg (map type-name args))))))
- (define (report-error loc msg . args)
- (set! errors? #t)
- (apply report loc msg args))
-
- (define (r-invalid-called-procedure-type loc pname xptype ptype)
- (report
- loc
- "~aexpected a value of type `~a' but was given a value of type `~a'"
- pname xptype ptype))
-
- (define (r-proc-call-argument-count-mismatch loc pname exp-count argc)
- (report
- loc
- "~aexpected ~a argument~a but was given ~a argument~a"
- pname
- exp-count (multiples exp-count)
- argc (multiples argc)))
-
- (define (r-proc-call-argument-type-mismatch loc pname i xptype atype)
- (report
- loc
- "~aexpected argument #~a of type `~a' but was given an argument of type
`~a'"
- pname i xptype atype))
-
- (define (r-pred-call-always-true loc pname atype)
- (report-notice
- loc
- "~athe predicate is called with an argument of type `~a' \
- and will always return true"
- pname atype))
-
- (define (r-pred-call-always-false loc pname atype)
- (report-notice
- loc
- "~athe predicate is called with an argument of type `~a' \
- and will always return false"
- pname atype))
-
- (define (r-cond-test-always-true loc test-node t if-node)
- (report-notice
- loc "~aexpected a value of type boolean in conditional, but \
- was given a value of type `~a' which is always true:~%~%~a"
- (node-source-prefix test-node) t (pp-fragment if-node)))
-
- (define (r-cond-test-always-false loc test-node if-node)
- (report-notice
- loc "~ain conditional, test expression will always return false:~%~%~a"
- (node-source-prefix test-node) (pp-fragment if-node)))
-
- (define (r-zero-values-for-the loc the-type)
- ;; (the t r) expects r returns exactly 1 value
- (report
- loc
- "expression returns zero values but is declared to have \
- a single result of type `~a'"
- the-type))
-
- (define (r-too-many-values-for-the loc rtypes)
- (report
- loc
- "expression returns ~a values but is declared to have \
- a single result" (length rtypes)))
-
- (define (r-type-mismatch-in-the loc first-rtype the-type)
- ((if strict report-error report-notice)
- loc
- "expression returns a result of type `~a' but is \
- declared to return `~a', which is not compatible"
- first-rtype the-type))
-
- (define (fail-compiler-typecase loc node atype ct-types)
- (quit-compiling
- "~a~ano clause applies in `compiler-typecase' for expression of type
`~a':~a"
- (location-name loc)
- (node-source-prefix node)
- (type-name atype)
- (string-intersperse (map (lambda (t) (sprintf "\n ~a" (type-name t)))
ct-types)
- "")))
-
- (define (fragment x)
- (let ((x (build-expression-tree (source-node-tree x))))
- (let walk ((x x) (d 0))
- (cond ((atom? x) (strip-syntax x))
- ((>= d +fragment-max-depth+) '...)
- ((list? x)
- (let* ((len (length x))
- (xs (if (< +fragment-max-length+ len)
- (append (take x +fragment-max-length+) '(...))
- x)))
- (map (cute walk <> (add1 d)) xs)))
- (else (strip-syntax x))))))
-
- (define (pp-fragment x)
- (string-chomp
- (with-output-to-string
- (lambda ()
- (pp (fragment x))))))
-
- (define (r-cond-branch-value-count-mismatch loc node)
- (report
- loc
- "branches in conditional expression differ in the number of
results:~%~%~a"
- (pp-fragment node)))
-
- (define (r-toplevel-var-assignment-type-mismatch loc atype var xptype)
- ((if strict report-error report)
- loc
- "assignment of value of type `~a' to toplevel variable `~a' \
- does not match declared type `~a'"
- atype var xptype))
-
(let ((blist '()) ; (((VAR . FLOW) TYPE) ...)
(aliased '())
(noreturn #f)
+ (errors? #f)
(dropped-branches 0)
(assigned-immediates 0)
(safe-calls 0))
@@ -730,6 +600,7 @@
(and (pair? type)
(eq? (car type) 'deprecated))))
(not (match-types type rt typeenv)))
+ (when strict (set! errors? #t))
(r-toplevel-var-assignment-type-mismatch loc rt var type))
(when (and (not type) ;XXX global declaration could allow
this
(not b)
@@ -899,6 +770,7 @@
(r-too-many-values-for-the loc rt))
(when (and (second params)
(not (compatible-types? t (first rt))))
+ (when strict (set! errors? #t))
(r-type-mismatch-in-the loc (first rt) t))))
(list t)))
((##core#typecase)
@@ -2531,4 +2403,148 @@
(else
(restore)
(loop (cdr ts) ok))))))
+
+;;; Report helpers
+(define (multiples n)
+ (if (= n 1) "" "s"))
+
+(define (fragment x)
+ (let ((x (build-expression-tree (source-node-tree x))))
+ (let walk ((x x) (d 0))
+ (cond ((atom? x) (strip-syntax x))
+ ((>= d +fragment-max-depth+) '...)
+ ((list? x)
+ (let* ((len (length x))
+ (xs (if (< +fragment-max-length+ len)
+ (append (take x +fragment-max-length+) '(...))
+ x)))
+ (map (cute walk <> (add1 d)) xs)))
+ (else (strip-syntax x))))))
+
+(define (pp-fragment x)
+ (string-chomp
+ (with-output-to-string
+ (lambda ()
+ (pp (fragment x))))))
+
+(define (node-source-prefix n)
+ (let ((line (node-line-number n)))
+ (if (not line) "" (sprintf "(~a) " line))))
+
+(define (location-name loc)
+ (define (lname loc1)
+ (if loc1
+ (sprintf "procedure `~a'" (real-name loc1))
+ "unknown procedure"))
+ (cond ((null? loc) "at toplevel:\n ")
+ ((null? (cdr loc))
+ (sprintf "in toplevel ~a:\n " (lname (car loc))))
+ (else
+ (let rec ((loc loc))
+ (if (null? (cdr loc))
+ (location-name loc)
+ (sprintf "in local ~a,\n ~a" (lname (car loc)) (rec (cdr
loc))))))))
+
+(define (report2 loc msg . args)
+ (when *complain?*
+ (warning
+ (conc (location-name loc)
+ (sprintf "~?" msg (map type-name args))))))
+
+(define (report-notice2 loc msg . args)
+ (when *complain?*
+ (##sys#notice
+ (conc (location-name loc)
+ (sprintf "~?" msg (map type-name args))))))
+
+;;; Reports
+
+(define (r-invalid-called-procedure-type loc pname xptype ptype)
+ (report2
+ loc
+ "~aexpected a value of type `~a' but was given a value of type `~a'"
+ pname xptype ptype))
+
+(define (r-proc-call-argument-count-mismatch loc pname exp-count argc)
+ (report2
+ loc
+ "~aexpected ~a argument~a but was given ~a argument~a"
+ pname
+ exp-count (multiples exp-count)
+ argc (multiples argc)))
+
+(define (r-proc-call-argument-type-mismatch loc pname i xptype atype)
+ (report2
+ loc
+ "~aexpected argument #~a of type `~a' but was given an argument of type
`~a'"
+ pname i xptype atype))
+
+(define (r-pred-call-always-true loc pname atype)
+ (report-notice2
+ loc
+ "~athe predicate is called with an argument of type `~a' \
+ and will always return true"
+ pname atype))
+
+(define (r-pred-call-always-false loc pname atype)
+ (report-notice2
+ loc
+ "~athe predicate is called with an argument of type `~a' \
+ and will always return false"
+ pname atype))
+
+(define (r-cond-test-always-true loc test-node t if-node)
+ (report-notice2
+ loc "~aexpected a value of type boolean in conditional, but \
+ was given a value of type `~a' which is always true:~%~%~a"
+ (node-source-prefix test-node) t (pp-fragment if-node)))
+
+(define (r-cond-test-always-false loc test-node if-node)
+ (report-notice2
+ loc "~ain conditional, test expression will always return false:~%~%~a"
+ (node-source-prefix test-node) (pp-fragment if-node)))
+
+(define (r-zero-values-for-the loc the-type)
+ ;; (the t r) expects r returns exactly 1 value
+ (report2
+ loc
+ "expression returns zero values but is declared to have \
+ a single result of type `~a'"
+ the-type))
+
+(define (r-too-many-values-for-the loc rtypes)
+ (report2
+ loc
+ "expression returns ~a values but is declared to have \
+ a single result" (length rtypes)))
+
+(define (r-type-mismatch-in-the loc first-rtype the-type)
+ ;; NOTE: Now always reports
+ (report2
+ loc
+ "expression returns a result of type `~a' but is \
+ declared to return `~a', which is not compatible"
+ first-rtype the-type))
+
+(define (fail-compiler-typecase loc node atype ct-types)
+ (quit-compiling
+ "~a~ano clause applies in `compiler-typecase' for expression of type
`~a':~a"
+ (location-name loc)
+ (node-source-prefix node)
+ (type-name atype)
+ (string-intersperse (map (lambda (t) (sprintf "\n ~a" (type-name t)))
ct-types)
+ "")))
+
+(define (r-cond-branch-value-count-mismatch loc node)
+ (report2
+ loc
+ "branches in conditional expression differ in the number of results:~%~%~a"
+ (pp-fragment node)))
+
+(define (r-toplevel-var-assignment-type-mismatch loc atype var xptype)
+ (report2
+ loc
+ "assignment of value of type `~a' to toplevel variable `~a' \
+ does not match declared type `~a'"
+ atype var xptype))
)
diff --git a/tests/scrutinizer-message-format.expected
b/tests/scrutinizer-message-format.expected
index 9c7299f..b88c938 100644
--- a/tests/scrutinizer-message-format.expected
+++ b/tests/scrutinizer-message-format.expected
@@ -42,7 +42,7 @@ Note: in toplevel procedure `r-cond-test-always-false':
(if #f 1 (##core#undefined))
-Note: in toplevel procedure `r-type-mismatch-in-the':
+Warning: in toplevel procedure `r-type-mismatch-in-the':
expression returns a result of type `fixnum' but is declared to return
`symbol', which is not compatible
Warning: in toplevel procedure `r-zero-values-for-the':
@@ -51,7 +51,7 @@ Warning: in toplevel procedure `r-zero-values-for-the':
Warning: in toplevel procedure `r-too-many-values-for-the':
expression returns 2 values but is declared to have a single result
-Note: in toplevel procedure `r-too-many-values-for-the':
+Warning: in toplevel procedure `r-too-many-values-for-the':
expression returns a result of type `fixnum' but is declared to return
`symbol', which is not compatible
Warning: in toplevel procedure `r-toplevel-var-assignment-type-mismatch':
@@ -153,7 +153,7 @@ Note: in local procedure `r-cond-test-always-false',
(if #f 1 (##core#undefined))
-Note: in local procedure `r-type-mismatch-in-the',
+Warning: in local procedure `r-type-mismatch-in-the',
in local procedure `local-bar',
in toplevel procedure `m#toplevel-foo':
expression returns a result of type `fixnum' but is declared to return
`symbol', which is not compatible
@@ -168,7 +168,7 @@ Warning: in local procedure `r-too-many-values-for-the',
in toplevel procedure `m#toplevel-foo':
expression returns 2 values but is declared to have a single result
-Note: in local procedure `r-too-many-values-for-the',
+Warning: in local procedure `r-too-many-values-for-the',
in local procedure `local-bar',
in toplevel procedure `m#toplevel-foo':
expression returns a result of type `fixnum' but is declared to return
`symbol', which is not compatible
diff --git a/tests/scrutiny.expected b/tests/scrutiny.expected
index 665d700..cd5fe04 100644
--- a/tests/scrutiny.expected
+++ b/tests/scrutiny.expected
@@ -77,7 +77,7 @@ Warning: in toplevel procedure `foo10':
Warning: in toplevel procedure `foo10':
(scrutiny-tests.scm:105) in procedure call to `scheme#+', expected argument
#1 of type `number' but was given an argument of type `string'
-Note: in toplevel procedure `foo10':
+Warning: in toplevel procedure `foo10':
expression returns a result of type `string' but is declared to return
`pair', which is not compatible
Warning: in toplevel procedure `foo10':
--
2.7.4
>From 3e7f9ed749bf482c6e9b97169b0af715aa975119 Mon Sep 17 00:00:00 2001
From: megane <address@hidden>
Date: Mon, 19 Nov 2018 11:18:51 +0200
Subject: [PATCH 5/9] Tweak scrutinizer messages (pretty print types)
* scrutinizer.scm: Remove type-name
- functionality is moved to type->pp-string
* scrutinizer.scm (string-add-indent) : New function
* scrutinizer.scm (type->pp-string) : New function
* scrutinizer.scm (pp-fragment): do indenting
* scrutinizer.scm (location-name): Print locations from toplevel to most local
level order
+ update *.expected files
---
scrutinizer.scm | 463 ++++++++++----
tests/scrutinizer-message-format.expected | 646 +++++++++++++++-----
tests/scrutiny-2.expected | 396 ++++++++++--
tests/scrutiny.expected | 973 ++++++++++++++++++++++++++----
tests/specialization.expected | 118 +++-
5 files changed, 2130 insertions(+), 466 deletions(-)
diff --git a/scrutinizer.scm b/scrutinizer.scm
index bc9d1b8..43a37a8 100644
--- a/scrutinizer.scm
+++ b/scrutinizer.scm
@@ -154,12 +154,6 @@
(define-inline (value-type? t)
(or (struct-type? t) (memq t value-types)))
-(define (type-name x)
- (let ((t (strip-syntax x)))
- (if (refinement-type? t)
- (sprintf "~a-~a" (string-intersperse (map conc (second t)) "/") (third
t))
- (sprintf "~a" t))))
-
(define specialization-statistics '())
(define trail '())
@@ -176,18 +170,19 @@
(else #f)))
(define (scrutinize node db complain specialize strict block-compilation)
+ (d "################################## SCRUTINIZE
##################################")
(set! *complain?* complain)
(define (report-notice loc msg . args)
(when complain
(##sys#notice
(conc (location-name loc)
- (sprintf "~?" msg (map type-name args))))))
+ (sprintf "~?" msg args)))))
(define (report loc msg . args)
(when complain
(warning
(conc (location-name loc)
- (sprintf "~?" msg (map type-name args))))))
+ (sprintf "~?" msg args)))))
(let ((blist '()) ; (((VAR . FLOW) TYPE) ...)
(aliased '())
@@ -277,12 +272,12 @@
(define (always-true if-node test-node t loc)
(and-let* ((_ (always-true1 t)))
- (r-cond-test-always-true loc test-node t if-node)
+ (r-cond-test-always-true loc if-node test-node t)
#t))
(define (always-false if-node test-node t loc)
(and-let* ((_ (eq? t 'false)))
- (r-cond-test-always-false loc test-node if-node)
+ (r-cond-test-always-false loc if-node test-node)
#t))
(define (always-immediate var t loc)
@@ -318,9 +313,7 @@
(define (call-result node args e loc params typeenv)
(define (pname)
- (sprintf "~ain procedure call to `~s', "
- (node-source-prefix node)
- (fragment (first (node-subexpressions node)))))
+ (fragment (first (node-subexpressions node))))
(let* ((actualtypes (map walked-result args))
(ptype (car actualtypes))
(pptype? (procedure-type? ptype))
@@ -331,13 +324,13 @@
(d " call: ~a, te: ~a" actualtypes typeenv)
(cond ((and (not pptype?) (not (match-types xptype ptype typeenv)))
(r-invalid-called-procedure-type
- loc (pname) (resolve xptype typeenv) (resolve ptype typeenv))
+ loc node (resolve xptype typeenv) (resolve ptype typeenv))
(values '* #f))
(else
(let-values (((atypes values-rest ok alen)
(procedure-argument-types ptype nargs typeenv)))
(unless ok
- (r-proc-call-argument-count-mismatch loc (pname) alen nargs))
+ (r-proc-call-argument-count-mismatch loc node (pname) alen
nargs ptype))
(do ((actualtypes (cdr actualtypes) (cdr actualtypes))
(atypes atypes (cdr atypes))
(i 1 (add1 i)))
@@ -347,9 +340,10 @@
(car actualtypes)
typeenv)
(r-proc-call-argument-type-mismatch
- loc (pname) i
+ loc node (pname) i
(resolve (car atypes) typeenv)
- (resolve (car actualtypes) typeenv))))
+ (resolve (car actualtypes) typeenv)
+ ptype)))
(when (noreturn-procedure-type? ptype)
(set! noreturn #t))
(let ((r (procedure-result-types ptype values-rest (cdr
actualtypes) typeenv)))
@@ -360,7 +354,8 @@
(variable-mark pn '##compiler#predicate)) =>
(lambda (pt)
(cond ((match-argument-types (list pt)
(cdr actualtypes) typeenv)
- (r-pred-call-always-true loc
(pname) (cadr actualtypes))
+ (r-pred-call-always-true
+ loc node (pname) pt (cadr
actualtypes))
(when specialize
(specialize-node!
node (cdr args)
@@ -370,7 +365,8 @@
((begin
(trail-restore trail0 typeenv)
(match-argument-types (list `(not
,pt)) (cdr actualtypes) typeenv))
- (r-pred-call-always-false loc
(pname) (cadr actualtypes))
+ (r-pred-call-always-false
+ loc node (pname) pt (cadr
actualtypes))
(when specialize
(specialize-node!
node (cdr args)
@@ -501,7 +497,7 @@
;;(dd " branches: ~s:~s / ~s:~s" nor1 r1
nor2 r2)
(cond ((and (not nor1) (not nor2)
(not (= (length r1) (length
r2))))
- (r-cond-branch-value-count-mismatch
loc n)
+ (r-cond-branch-value-count-mismatch
loc n c a r1 r2)
'*)
(nor1 r2)
(nor2 r1)
@@ -601,7 +597,7 @@
(eq? (car type) 'deprecated))))
(not (match-types type rt typeenv)))
(when strict (set! errors? #t))
- (r-toplevel-var-assignment-type-mismatch loc rt var type))
+ (r-toplevel-var-assignment-type-mismatch loc n rt var
type (first subs)))
(when (and (not type) ;XXX global declaration could allow
this
(not b)
(not (eq? '* rt))
@@ -764,14 +760,14 @@
(let ((t (first params))
(rt (walk (first subs) e loc dest tail flow ctags)))
(cond ((eq? rt '*))
- ((null? rt) (r-zero-values-for-the loc t))
+ ((null? rt) (r-zero-values-for-the loc (first subs)
t))
(else
(when (> (length rt) 1)
- (r-too-many-values-for-the loc rt))
+ (r-too-many-values-for-the loc (first subs) t rt))
(when (and (second params)
(not (compatible-types? t (first rt))))
(when strict (set! errors? #t))
- (r-type-mismatch-in-the loc (first rt) t))))
+ (r-type-mismatch-in-the loc (first subs) (first
rt) t))))
(list t)))
((##core#typecase)
(let* ((ts (walk (first subs) e loc #f #f flow ctags))
@@ -1654,17 +1650,20 @@
(let-values (((t pred pure) (validate-type new name)))
(unless t
(warning
- (sprintf "invalid type specification for `~a': ~a"
+ (sprintf "Invalid type specification for `~a':~%~%~a"
name
- (type-name new))))
+ (type->pp-string new))))
(when (and old (not (compatible-types? old t)))
(warning
(sprintf
- "type definition for toplevel binding `~a' \
- conflicts with previously loaded type:\
- ~n New type: ~a\
- ~n Original type: ~a"
- name (type-name old) (type-name new))))
+ (string-append
+ "Declared type for toplevel binding `~a'"
+ "~%~%~a~%~%"
+ " conflicts with previously loaded type:"
+ "~%~%~a")
+ name
+ (type->pp-string new)
+ (type->pp-string old))))
(mark-variable name '##compiler#type t)
(mark-variable name '##compiler#type-source 'db)
(when specs
@@ -2088,7 +2087,7 @@
(define (report loc msg . args)
(warning
(conc (location-name loc)
- (sprintf "~?" msg (map type-name args)))))
+ (sprintf "~?" msg args))))
(define (known-length-vector-index node args loc expected-argcount)
(and-let* ((subs (node-subexpressions node))
@@ -2153,7 +2152,7 @@
(define (report loc msg . args)
(warning
(conc (location-name loc)
- (sprintf "~?" msg (map type-name args)))))
+ (sprintf "~?" msg args))))
(define (list-or-null a)
(if (null? a) 'null `(list ,@a)))
@@ -2265,7 +2264,7 @@
(define (report loc msg . args)
(warning
(conc (location-name loc)
- (sprintf "~?" msg (map type-name args)))))
+ (sprintf "~?" msg args))))
(define (append-special-case node args loc rtypes)
(define (potentially-proper-list? l) (match-types l 'list '()))
@@ -2299,12 +2298,16 @@
(unless (or (null? (cdr arg-types))
(potentially-proper-list? arg1))
(report
- loc "~ain procedure call to `~a', argument #~a is \
- of type ~a but expected a proper list"
+ loc
+ (string-append
+ "~ain procedure call to `~a', argument #~a is of type"
+ "~%~%~a~%~%"
+ " but expected a proper list.")
(node-source-prefix node)
(first (node-parameters
(first (node-subexpressions node))))
- index arg1))
+ index
+ (type->pp-string arg1)))
#f))))))
(cond ((derive-result-type) => list)
(else rtypes)))
@@ -2408,6 +2411,28 @@
(define (multiples n)
(if (= n 1) "" "s"))
+(define (string-add-indent str #!optional (ind " "))
+ (let* ((ls (string-split str "\n" #t))
+ (s (string-intersperse
+ (map (lambda (l) (if (string=? "" l) l
+ (string-append ind l)))
+ ls)
+ "\n")))
+ (if (eq? #\newline (string-ref str (sub1 (string-length str))))
+ (string-append s "\n")
+ s)))
+
+(define (type->pp-string t)
+ (string-add-indent
+ (string-chomp
+ (with-output-to-string
+ (lambda ()
+ (let ((t (strip-syntax t)))
+ (if (refinement-type? t)
+ (printf "~a-~a" (string-intersperse (map conc (second t)) "/")
(third t))
+ (pp t))))))
+ " "))
+
(define (fragment x)
(let ((x (build-expression-tree (source-node-tree x))))
(let walk ((x x) (d 0))
@@ -2421,130 +2446,332 @@
(map (cute walk <> (add1 d)) xs)))
(else (strip-syntax x))))))
-(define (pp-fragment x)
- (string-chomp
- (with-output-to-string
- (lambda ()
- (pp (fragment x))))))
+(define (pp-fragment x #!optional (ind " "))
+ (string-add-indent
+ (string-chomp
+ (with-output-to-string
+ (lambda ()
+ (pp (fragment x)))))
+ ind))
(define (node-source-prefix n)
(let ((line (node-line-number n)))
(if (not line) "" (sprintf "(~a) " line))))
-(define (location-name loc)
+(define (location-name loc #!optional (ind " "))
(define (lname loc1)
(if loc1
- (sprintf "procedure `~a'" (real-name loc1))
- "unknown procedure"))
- (cond ((null? loc) "at toplevel:\n ")
- ((null? (cdr loc))
- (sprintf "in toplevel ~a:\n " (lname (car loc))))
+ (real-name loc1)
+ "(unknown procedure)"))
+ (cond ((null? loc) (sprintf "At toplevel:\n~a" ind))
(else
- (let rec ((loc loc))
+ (let rec ((loc loc)
+ (msgs (list "")))
(if (null? (cdr loc))
- (location-name loc)
- (sprintf "in local ~a,\n ~a" (lname (car loc)) (rec (cdr
loc))))))))
-
-(define (report2 loc msg . args)
- (when *complain?*
- (warning
- (conc (location-name loc)
- (sprintf "~?" msg (map type-name args))))))
-
-(define (report-notice2 loc msg . args)
+ (string-intersperse
+ (cons (sprintf "In `~a', a toplevel procedure" (lname (car
loc))) msgs)
+ (sprintf "\n~a" ind))
+ (rec (cdr loc)
+ (cons (sprintf "In `~a', a local procedure" (lname (car
loc))) msgs)))))))
+
+(define (report2 report-f location-node-candidates loc msg . args)
+ (define (file-location)
+ (any (lambda (n) (and (not (string=? "" (node-source-prefix n)))
+ (node-source-prefix n)))
+ location-node-candidates))
(when *complain?*
- (##sys#notice
- (conc (location-name loc)
- (sprintf "~?" msg (map type-name args))))))
+ (report-f
+ (conc
+ "Type mismatch.\n "
+ (string-add-indent
+ (conc (let ((l (file-location))) (if l (conc l "\n ") ""))
+ (location-name loc " ")
+ (sprintf "~?" msg args))
+ " ")))))
+
+(define (report-notice2 location-node-candidates loc msg . args)
+ (apply report2 ##sys#notice location-node-candidates loc msg args))
;;; Reports
-(define (r-invalid-called-procedure-type loc pname xptype ptype)
+(define (r-invalid-called-procedure-type loc node xptype ptype)
(report2
+ warning
+ (list node)
loc
- "~aexpected a value of type `~a' but was given a value of type `~a'"
- pname xptype ptype))
-
-(define (r-proc-call-argument-count-mismatch loc pname exp-count argc)
+ (string-append
+ "In procedure call"
+ "~%~%"
+ "~a"
+ "~%~%"
+ "Procedure in a procedure call has invalid type"
+ "~%~%"
+ "~a"
+ "~%~%"
+ "The expected type is"
+ "~%~%"
+ "~a")
+ (pp-fragment node " ")
+ (type->pp-string ptype)
+ (type->pp-string xptype)))
+
+(define (r-proc-call-argument-count-mismatch loc node pname exp-count argc
ptype)
(report2
+ warning
+ (list node)
loc
- "~aexpected ~a argument~a but was given ~a argument~a"
+ (string-append
+ "In procedure call"
+ "~%~%"
+ "~a"
+ "~%~%"
+ "Procedure `~a' is called with ~a argument~a but ~a argument~a is
expected."
+ "~%~%"
+ "The procedure's type is"
+ "~%~%"
+ "~a")
+ (pp-fragment node " ")
pname
+ argc (multiples argc)
exp-count (multiples exp-count)
- argc (multiples argc)))
+ (type->pp-string ptype)))
-(define (r-proc-call-argument-type-mismatch loc pname i xptype atype)
+(define (r-proc-call-argument-type-mismatch loc node pname i xptype atype
ptype)
(report2
+ warning
+ (list node)
loc
- "~aexpected argument #~a of type `~a' but was given an argument of type
`~a'"
- pname i xptype atype))
+ (string-append
+ "In procedure call"
+ "~%~%"
+ "~a"
+ "~%~%"
+ "Argument #~a to procedure `~a' has invalid type"
+ "~%~%"
+ "~a"
+ "~%~%"
+ "The expected type is"
+ "~%~%"
+ "~a"
+ "~%~%"
+ "The procedure's type is"
+ "~%~%"
+ "~a")
+ (pp-fragment node " ")
+ i
+ pname
+ (type->pp-string atype)
+ (type->pp-string xptype)
+ (type->pp-string ptype)))
-(define (r-pred-call-always-true loc pname atype)
+(define (r-pred-call-always-true loc node pname pred-type atype)
+ ;; pname is "... proc call to predicate `foo' "
(report-notice2
+ (list node)
loc
- "~athe predicate is called with an argument of type `~a' \
- and will always return true"
- pname atype))
+ (string-append
+ "In predicate call"
+ "~%~%"
+ "~a"
+ "~%~%"
+ "Predicate call will always return true."
+ "~%~%"
+ "Procedure `~a' is a predicate for"
+ "~%~%"
+ "~a"
+ "~%~%"
+ "The given argument has type"
+ "~%~%"
+ "~a")
+ (pp-fragment node " ")
+ pname
+ (type->pp-string pred-type)
+ (type->pp-string atype)))
-(define (r-pred-call-always-false loc pname atype)
+(define (r-pred-call-always-false loc node pname pred-type atype)
(report-notice2
+ (list node)
loc
- "~athe predicate is called with an argument of type `~a' \
- and will always return false"
- pname atype))
+ (string-append
+ "In predicate call"
+ "~%~%"
+ "~a"
+ "~%~%"
+ "Predicate call will always return false."
+ "~%~%"
+ "Procedure `~a' is a predicate for"
+ "~%~%"
+ "~a"
+ "~%~%"
+ "The given argument has type"
+ "~%~%"
+ "~a")
+ (pp-fragment node " ")
+ pname
+ (type->pp-string pred-type)
+ (type->pp-string atype)))
-(define (r-cond-test-always-true loc test-node t if-node)
+(define (r-cond-test-always-true loc if-node test-node t)
(report-notice2
- loc "~aexpected a value of type boolean in conditional, but \
- was given a value of type `~a' which is always true:~%~%~a"
- (node-source-prefix test-node) t (pp-fragment if-node)))
-
-(define (r-cond-test-always-false loc test-node if-node)
+ (list test-node if-node)
+ loc
+ (string-append
+ "In conditional expression"
+ "~%~%"
+ "~a"
+ "~%~%"
+ "Test condition has always true value of type"
+ "~%~%"
+ "~a")
+ (pp-fragment if-node " ")
+ (type->pp-string t)))
+
+(define (r-cond-test-always-false loc if-node test-node)
(report-notice2
- loc "~ain conditional, test expression will always return false:~%~%~a"
- (node-source-prefix test-node) (pp-fragment if-node)))
-
-(define (r-zero-values-for-the loc the-type)
+ (list test-node if-node)
+ loc
+ (string-append
+ "In conditional expression"
+ "~%~%"
+ "~a"
+ "~%~%"
+ "Test condition is always false.")
+ (pp-fragment if-node " ")))
+
+(define (r-zero-values-for-the loc node the-type)
;; (the t r) expects r returns exactly 1 value
(report2
+ warning
+ (list node)
loc
- "expression returns zero values but is declared to have \
- a single result of type `~a'"
- the-type))
-
-(define (r-too-many-values-for-the loc rtypes)
+ (string-append
+ "In expression"
+ "~%~%"
+ "~a"
+ "~%~%"
+ "Expression returns 0 values but is declared to return"
+ "~%~%"
+ "~a")
+ (pp-fragment node " ")
+ (type->pp-string the-type)))
+
+(define (r-too-many-values-for-the loc node the-type rtypes)
(report2
+ warning
+ (list node)
loc
- "expression returns ~a values but is declared to have \
- a single result" (length rtypes)))
-
-(define (r-type-mismatch-in-the loc first-rtype the-type)
- ;; NOTE: Now always reports
+ (string-append
+ "In expression"
+ "~%~%"
+ "~a"
+ "~%~%"
+ "Expression returns too many values."
+ "~%~%"
+ "The expression returns ~a values but is declared to return"
+ "~%~%"
+ "~a")
+ (pp-fragment node " ")
+ (length rtypes)
+ (type->pp-string the-type)))
+
+(define (r-type-mismatch-in-the loc node first-rtype the-type)
(report2
+ warning
+ (list node)
loc
- "expression returns a result of type `~a' but is \
- declared to return `~a', which is not compatible"
- first-rtype the-type))
+ (string-append
+ "In expression"
+ "~%~%"
+ "~a"
+ "~%~%"
+ "Expression's declared and actual types do not match."
+ "~%~%"
+ "The actual type is"
+ "~%~%"
+ "~a"
+ "~%~%"
+ "The expression's declared type is"
+ "~%~%"
+ "~a")
+ (pp-fragment node " ")
+ (type->pp-string first-rtype)
+ (type->pp-string the-type)))
(define (fail-compiler-typecase loc node atype ct-types)
+ (define (ppt t) (string-add-indent (type->pp-string t) " "))
(quit-compiling
- "~a~ano clause applies in `compiler-typecase' for expression of type
`~a':~a"
- (location-name loc)
- (node-source-prefix node)
- (type-name atype)
- (string-intersperse (map (lambda (t) (sprintf "\n ~a" (type-name t)))
ct-types)
- "")))
-
-(define (r-cond-branch-value-count-mismatch loc node)
+ (string-append
+ "Type mismatch.~%"
+ "~a"
+ " ~a"
+ "In `compiler-typecase' expression"
+ "~%~%"
+ "~a"
+ "~%~%"
+ " Tested expression in `compiler-typecase' does not match any case."
+ "~%~%"
+ " The expression has this type"
+ "~%~%"
+ "~a"
+ "~%~%"
+ " The specified type cases are these"
+ "~%~%"
+ "~a")
+ (if (string=? "" (node-source-prefix node))
+ ""
+ (conc " " (node-source-prefix node) "\n"))
+ (location-name loc " ")
+ (pp-fragment node " ")
+ (ppt atype)
+ (string-intersperse (map ppt ct-types) "\n\n")))
+
+(define (r-cond-branch-value-count-mismatch loc node c-node a-node c-types
a-types)
(report2
+ warning
+ (list a-node node)
loc
- "branches in conditional expression differ in the number of results:~%~%~a"
- (pp-fragment node)))
-
-(define (r-toplevel-var-assignment-type-mismatch loc atype var xptype)
+ (string-append
+ "In conditional expression"
+ "~%~%"
+ "~a"
+ "~%~%"
+ "The branches have different number of returned values."
+ "~%~%"
+ "The true branch returns ~a value~a"
+ "~%~%"
+ "~a"
+ "~%~%"
+ "The false branch returns ~a value~a"
+ "~%~%"
+ "~a")
+ (pp-fragment node " ")
+ (length c-types) (multiples (length c-types))
+ (pp-fragment c-node " ")
+ (length a-types) (multiples (length a-types))
+ (pp-fragment a-node " ")))
+
+(define (r-toplevel-var-assignment-type-mismatch loc node atype var xptype
value-node)
(report2
+ warning
+ (list node value-node)
loc
- "assignment of value of type `~a' to toplevel variable `~a' \
- does not match declared type `~a'"
- atype var xptype))
+ (string-append
+ "In assignment"
+ "~%~%"
+ "~a"
+ "~%~%"
+ "Variable `~a' is assigned invalid value."
+ "~%~%"
+ "The assigned value has type"
+ "~%~%"
+ "~a"
+ "~%~%"
+ "The declared type of `~a' is"
+ "~%~%"
+ "~a")
+ (pp-fragment node " ")
+ var
+ (type->pp-string atype)
+ var
+ (type->pp-string xptype)))
)
diff --git a/tests/scrutinizer-message-format.expected
b/tests/scrutinizer-message-format.expected
index b88c938..6b00490 100644
--- a/tests/scrutinizer-message-format.expected
+++ b/tests/scrutinizer-message-format.expected
@@ -3,236 +3,562 @@ Warning: literal in operator position: (1 2)
Warning: literal in operator position: (1 2)
-Warning: in toplevel procedure `r-proc-call-argument-count-mismatch':
- (test-scrutinizer-message-format.scm:9) in procedure call to `scheme#cons',
expected 2 arguments but was given 1 argument
+Warning: Type mismatch.
+ (test-scrutinizer-message-format.scm:9)
+ In `r-proc-call-argument-count-mismatch', a toplevel procedure
+ In procedure call
-Warning: in toplevel procedure `r-proc-call-argument-type-mismatch':
- (test-scrutinizer-message-format.scm:10) in procedure call to
`scheme#length', expected argument #1 of type `list' but was given an argument
of type `symbol'
+ (scheme#cons '())
-Warning: in toplevel procedure `r-proc-call-argument-value-count':
+ Procedure `scheme#cons' is called with 1 argument but 2 arguments is
expected.
+
+ The procedure's type is
+
+ (forall (a b) (procedure scheme#cons (a b) (pair a b)))
+
+Warning: Type mismatch.
+ (test-scrutinizer-message-format.scm:10)
+ In `r-proc-call-argument-type-mismatch', a toplevel procedure
+ In procedure call
+
+ (scheme#length 'symbol)
+
+ Argument #1 to procedure `scheme#length' has invalid type
+
+ symbol
+
+ The expected type is
+
+ list
+
+ The procedure's type is
+
+ (procedure scheme#length (list) fixnum)
+
+Warning: In `r-proc-call-argument-value-count', a toplevel procedure
(test-scrutinizer-message-format.scm:11) expected a single result in
argument #1 of procedure call `(scheme#list (chicken.time#cpu-time))', but
received 2 results
-Warning: in toplevel procedure `r-proc-call-argument-value-count':
+Warning: In `r-proc-call-argument-value-count', a toplevel procedure
(test-scrutinizer-message-format.scm:11) expected a single result in
argument #1 of procedure call `(scheme#vector (scheme#values))', but received
zero results
-Warning: in toplevel procedure `r-proc-call-argument-value-count':
+Warning: In `r-proc-call-argument-value-count', a toplevel procedure
expected a single result in `let' binding of `g28', but received zero results
-Warning: in toplevel procedure `r-cond-branch-value-count-mismatch':
- branches in conditional expression differ in the number of results:
+Warning: Type mismatch.
+ (test-scrutinizer-message-format.scm:12)
+ In `r-cond-branch-value-count-mismatch', a toplevel procedure
+ In conditional expression
+
+ (if (the * 1) 1 (scheme#values 1 2))
+
+ The branches have different number of returned values.
+
+ The true branch returns 1 value
+
+ 1
-(if (the * 1) 1 (scheme#values 1 2))
+ The false branch returns 2 values
-Warning: in toplevel procedure `r-invalid-called-procedure-type':
- in procedure call to `1', expected a value of type `(procedure (*) *)' but
was given a value of type `fixnum'
+ (scheme#values 1 2)
-Note: in toplevel procedure `r-pred-call-always-true':
- (test-scrutinizer-message-format.scm:14) in procedure call to
`scheme#list?', the predicate is called with an argument of type `null' and
will always return true
+Warning: Type mismatch.
+ In `r-invalid-called-procedure-type', a toplevel procedure
+ In procedure call
-Note: in toplevel procedure `r-pred-call-always-false':
- (test-scrutinizer-message-format.scm:15) in procedure call to
`scheme#symbol?', the predicate is called with an argument of type `fixnum' and
will always return false
+ (1 2)
-Note: in toplevel procedure `r-cond-test-always-true':
- expected a value of type boolean in conditional, but was given a value of
type `symbol' which is always true:
+ Procedure in a procedure call has invalid type
-(if 'symbol 1 (##core#undefined))
+ fixnum
-Note: in toplevel procedure `r-cond-test-always-false':
- in conditional, test expression will always return false:
+ The expected type is
-(if #f 1 (##core#undefined))
+ (procedure (*) *)
-Warning: in toplevel procedure `r-type-mismatch-in-the':
- expression returns a result of type `fixnum' but is declared to return
`symbol', which is not compatible
+Note: Type mismatch.
+ (test-scrutinizer-message-format.scm:14)
+ In `r-pred-call-always-true', a toplevel procedure
+ In predicate call
+
+ (scheme#list? '())
+
+ Predicate call will always return true.
+
+ Procedure `scheme#list?' is a predicate for
+
+ list
-Warning: in toplevel procedure `r-zero-values-for-the':
- expression returns zero values but is declared to have a single result of
type `symbol'
+ The given argument has type
-Warning: in toplevel procedure `r-too-many-values-for-the':
- expression returns 2 values but is declared to have a single result
+ null
-Warning: in toplevel procedure `r-too-many-values-for-the':
- expression returns a result of type `fixnum' but is declared to return
`symbol', which is not compatible
+Note: Type mismatch.
+ (test-scrutinizer-message-format.scm:15)
+ In `r-pred-call-always-false', a toplevel procedure
+ In predicate call
-Warning: in toplevel procedure `r-toplevel-var-assignment-type-mismatch':
- assignment of value of type `fixnum' to toplevel variable `foo' does not
match declared type `boolean'
+ (scheme#symbol? 1)
-Warning: in toplevel procedure `r-deprecated-identifier':
+ Predicate call will always return false.
+
+ Procedure `scheme#symbol?' is a predicate for
+
+ symbol
+
+ The given argument has type
+
+ fixnum
+
+Note: Type mismatch.
+ In `r-cond-test-always-true', a toplevel procedure
+ In conditional expression
+
+ (if 'symbol 1 (##core#undefined))
+
+ Test condition has always true value of type
+
+ symbol
+
+Note: Type mismatch.
+ In `r-cond-test-always-false', a toplevel procedure
+ In conditional expression
+
+ (if #f 1 (##core#undefined))
+
+ Test condition is always false.
+
+Warning: Type mismatch.
+ In `r-type-mismatch-in-the', a toplevel procedure
+ In expression
+
+ 1
+
+ Expression's declared and actual types do not match.
+
+ The actual type is
+
+ fixnum
+
+ The expression's declared type is
+
+ symbol
+
+Warning: Type mismatch.
+ (test-scrutinizer-message-format.scm:19)
+ In `r-zero-values-for-the', a toplevel procedure
+ In expression
+
+ (scheme#values)
+
+ Expression returns 0 values but is declared to return
+
+ symbol
+
+Warning: Type mismatch.
+ (test-scrutinizer-message-format.scm:20)
+ In `r-too-many-values-for-the', a toplevel procedure
+ In expression
+
+ (scheme#values 1 2)
+
+ Expression returns too many values.
+
+ The expression returns 2 values but is declared to return
+
+ symbol
+
+Warning: Type mismatch.
+ (test-scrutinizer-message-format.scm:20)
+ In `r-too-many-values-for-the', a toplevel procedure
+ In expression
+
+ (scheme#values 1 2)
+
+ Expression's declared and actual types do not match.
+
+ The actual type is
+
+ fixnum
+
+ The expression's declared type is
+
+ symbol
+
+Warning: Type mismatch.
+ In `r-toplevel-var-assignment-type-mismatch', a toplevel procedure
+ In assignment
+
+ (set! foo 1)
+
+ Variable `foo' is assigned invalid value.
+
+ The assigned value has type
+
+ fixnum
+
+ The declared type of `foo' is
+
+ boolean
+
+Warning: In `r-deprecated-identifier', a toplevel procedure
use of deprecated `deprecated-foo'
-Warning: in toplevel procedure `r-deprecated-identifier':
+Warning: In `r-deprecated-identifier', a toplevel procedure
use of deprecated `deprecated-foo2' - consider `foo'
-Warning: at toplevel:
- assignment of value of type `fixnum' to toplevel variable `foo' does not
match declared type `boolean'
+Warning: Type mismatch.
+ At toplevel:
+ In assignment
+
+ (set! foo 1)
+
+ Variable `foo' is assigned invalid value.
+
+ The assigned value has type
+
+ fixnum
+
+ The declared type of `foo' is
-Warning: in toplevel procedure `list-ref-negative-index':
+ boolean
+
+Warning: In `list-ref-negative-index', a toplevel procedure
(test-scrutinizer-message-format.scm:26) in procedure call to
`scheme#list-ref', index -1 is negative, which is never valid
-Warning: in toplevel procedure `list-ref-out-of-range':
+Warning: In `list-ref-out-of-range', a toplevel procedure
(test-scrutinizer-message-format.scm:27) in procedure call to
`scheme#list-ref', index 1 out of range for proper list of length 0
-Warning: in toplevel procedure `vector-ref-out-of-range':
+Warning: In `vector-ref-out-of-range', a toplevel procedure
(test-scrutinizer-message-format.scm:29) in procedure call to
`scheme#vector-ref', index -1 out of range for vector of length 0
-Warning: in toplevel procedure `zero-values-for-let':
+Warning: In `zero-values-for-let', a toplevel procedure
expected a single result in `let' binding of `a', but received zero results
-Warning: in toplevel procedure `multiple-values-for-let':
+Warning: In `multiple-values-for-let', a toplevel procedure
expected a single result in `let' binding of `a', but received 2 results
-Warning: in toplevel procedure `zero-values-for-conditional':
+Warning: In `zero-values-for-conditional', a toplevel procedure
expected a single result in conditional, but received zero results
-Warning: in toplevel procedure `multiple-values-for-conditional':
+Warning: In `multiple-values-for-conditional', a toplevel procedure
expected a single result in conditional, but received 2 results
-Note: in toplevel procedure `multiple-values-for-conditional':
- (test-scrutinizer-message-format.scm:33) expected a value of type boolean in
conditional, but was given a value of type `fixnum' which is always true:
+Note: Type mismatch.
+ (test-scrutinizer-message-format.scm:33)
+ In `multiple-values-for-conditional', a toplevel procedure
+ In conditional expression
+
+ (if (scheme#values 1 2) 1 (##core#undefined))
+
+ Test condition has always true value of type
+
+ fixnum
+
+Warning: Type mismatch.
+ (test-scrutinizer-message-format.scm:52)
+ In `m#toplevel-foo', a toplevel procedure
+ In `local-bar', a local procedure
+ In `r-proc-call-argument-count-mismatch', a local procedure
+ In procedure call
+
+ (scheme#cons '())
+
+ Procedure `scheme#cons' is called with 1 argument but 2 arguments is
expected.
+
+ The procedure's type is
+
+ (forall (a b) (procedure scheme#cons (a b) (pair a b)))
+
+Warning: Type mismatch.
+ (test-scrutinizer-message-format.scm:53)
+ In `m#toplevel-foo', a toplevel procedure
+ In `local-bar', a local procedure
+ In `r-proc-call-argument-type-mismatch', a local procedure
+ In procedure call
-(if (scheme#values 1 2) 1 (##core#undefined))
+ (scheme#length 'symbol)
-Warning: in local procedure `r-proc-call-argument-count-mismatch',
- in local procedure `local-bar',
- in toplevel procedure `m#toplevel-foo':
- (test-scrutinizer-message-format.scm:52) in procedure call to `scheme#cons',
expected 2 arguments but was given 1 argument
+ Argument #1 to procedure `scheme#length' has invalid type
-Warning: in local procedure `r-proc-call-argument-type-mismatch',
- in local procedure `local-bar',
- in toplevel procedure `m#toplevel-foo':
- (test-scrutinizer-message-format.scm:53) in procedure call to
`scheme#length', expected argument #1 of type `list' but was given an argument
of type `symbol'
+ symbol
+
+ The expected type is
+
+ list
+
+ The procedure's type is
+
+ (procedure scheme#length (list) fixnum)
-Warning: in local procedure `r-proc-call-argument-value-count',
- in local procedure `local-bar',
- in toplevel procedure `m#toplevel-foo':
+Warning: In `m#toplevel-foo', a toplevel procedure
+ In `local-bar', a local procedure
+ In `r-proc-call-argument-value-count', a local procedure
(test-scrutinizer-message-format.scm:54) expected a single result in
argument #1 of procedure call `(scheme#list (chicken.time#cpu-time))', but
received 2 results
-Warning: in local procedure `r-proc-call-argument-value-count',
- in local procedure `local-bar',
- in toplevel procedure `m#toplevel-foo':
+Warning: In `m#toplevel-foo', a toplevel procedure
+ In `local-bar', a local procedure
+ In `r-proc-call-argument-value-count', a local procedure
(test-scrutinizer-message-format.scm:54) expected a single result in
argument #1 of procedure call `(scheme#vector (scheme#values))', but received
zero results
-Warning: in local procedure `r-proc-call-argument-value-count',
- in local procedure `local-bar',
- in toplevel procedure `m#toplevel-foo':
+Warning: In `m#toplevel-foo', a toplevel procedure
+ In `local-bar', a local procedure
+ In `r-proc-call-argument-value-count', a local procedure
expected a single result in `let' binding of `g90', but received zero results
-Warning: in local procedure `r-cond-branch-value-count-mismatch',
- in local procedure `local-bar',
- in toplevel procedure `m#toplevel-foo':
- branches in conditional expression differ in the number of results:
-
-(if (the * 1) 1 (chicken.time#cpu-time))
-
-Warning: in local procedure `r-invalid-called-procedure-type',
- in local procedure `local-bar',
- in toplevel procedure `m#toplevel-foo':
- in procedure call to `1', expected a value of type `(procedure (*) *)' but
was given a value of type `fixnum'
-
-Note: in local procedure `r-pred-call-always-true',
- in local procedure `local-bar',
- in toplevel procedure `m#toplevel-foo':
- (test-scrutinizer-message-format.scm:57) in procedure call to
`scheme#list?', the predicate is called with an argument of type `null' and
will always return true
-
-Note: in local procedure `r-pred-call-always-false',
- in local procedure `local-bar',
- in toplevel procedure `m#toplevel-foo':
- (test-scrutinizer-message-format.scm:58) in procedure call to
`scheme#symbol?', the predicate is called with an argument of type `fixnum' and
will always return false
-
-Note: in local procedure `r-cond-test-always-true',
- in local procedure `local-bar',
- in toplevel procedure `m#toplevel-foo':
- (test-scrutinizer-message-format.scm:59) expected a value of type boolean in
conditional, but was given a value of type `fixnum' which is always true:
-
-(if (scheme#length '()) 1 (##core#undefined))
-
-Note: in local procedure `r-cond-test-always-false',
- in local procedure `local-bar',
- in toplevel procedure `m#toplevel-foo':
- in conditional, test expression will always return false:
-
-(if #f 1 (##core#undefined))
-
-Warning: in local procedure `r-type-mismatch-in-the',
- in local procedure `local-bar',
- in toplevel procedure `m#toplevel-foo':
- expression returns a result of type `fixnum' but is declared to return
`symbol', which is not compatible
-
-Warning: in local procedure `r-zero-values-for-the',
- in local procedure `local-bar',
- in toplevel procedure `m#toplevel-foo':
- expression returns zero values but is declared to have a single result of
type `symbol'
-
-Warning: in local procedure `r-too-many-values-for-the',
- in local procedure `local-bar',
- in toplevel procedure `m#toplevel-foo':
- expression returns 2 values but is declared to have a single result
-
-Warning: in local procedure `r-too-many-values-for-the',
- in local procedure `local-bar',
- in toplevel procedure `m#toplevel-foo':
- expression returns a result of type `fixnum' but is declared to return
`symbol', which is not compatible
-
-Warning: in local procedure `r-toplevel-var-assignment-type-mismatch',
- in local procedure `local-bar',
- in toplevel procedure `m#toplevel-foo':
- assignment of value of type `fixnum' to toplevel variable `m#foo2' does not
match declared type `boolean'
-
-Warning: in local procedure `r-deprecated-identifier',
- in local procedure `local-bar',
- in toplevel procedure `m#toplevel-foo':
+Warning: Type mismatch.
+ (test-scrutinizer-message-format.scm:55)
+ In `m#toplevel-foo', a toplevel procedure
+ In `local-bar', a local procedure
+ In `r-cond-branch-value-count-mismatch', a local procedure
+ In conditional expression
+
+ (if (the * 1) 1 (chicken.time#cpu-time))
+
+ The branches have different number of returned values.
+
+ The true branch returns 1 value
+
+ 1
+
+ The false branch returns 2 values
+
+ (chicken.time#cpu-time)
+
+Warning: Type mismatch.
+ In `m#toplevel-foo', a toplevel procedure
+ In `local-bar', a local procedure
+ In `r-invalid-called-procedure-type', a local procedure
+ In procedure call
+
+ (1 2)
+
+ Procedure in a procedure call has invalid type
+
+ fixnum
+
+ The expected type is
+
+ (procedure (*) *)
+
+Note: Type mismatch.
+ (test-scrutinizer-message-format.scm:57)
+ In `m#toplevel-foo', a toplevel procedure
+ In `local-bar', a local procedure
+ In `r-pred-call-always-true', a local procedure
+ In predicate call
+
+ (scheme#list? '())
+
+ Predicate call will always return true.
+
+ Procedure `scheme#list?' is a predicate for
+
+ list
+
+ The given argument has type
+
+ null
+
+Note: Type mismatch.
+ (test-scrutinizer-message-format.scm:58)
+ In `m#toplevel-foo', a toplevel procedure
+ In `local-bar', a local procedure
+ In `r-pred-call-always-false', a local procedure
+ In predicate call
+
+ (scheme#symbol? 1)
+
+ Predicate call will always return false.
+
+ Procedure `scheme#symbol?' is a predicate for
+
+ symbol
+
+ The given argument has type
+
+ fixnum
+
+Note: Type mismatch.
+ (test-scrutinizer-message-format.scm:59)
+ In `m#toplevel-foo', a toplevel procedure
+ In `local-bar', a local procedure
+ In `r-cond-test-always-true', a local procedure
+ In conditional expression
+
+ (if (scheme#length '()) 1 (##core#undefined))
+
+ Test condition has always true value of type
+
+ fixnum
+
+Note: Type mismatch.
+ In `m#toplevel-foo', a toplevel procedure
+ In `local-bar', a local procedure
+ In `r-cond-test-always-false', a local procedure
+ In conditional expression
+
+ (if #f 1 (##core#undefined))
+
+ Test condition is always false.
+
+Warning: Type mismatch.
+ In `m#toplevel-foo', a toplevel procedure
+ In `local-bar', a local procedure
+ In `r-type-mismatch-in-the', a local procedure
+ In expression
+
+ 1
+
+ Expression's declared and actual types do not match.
+
+ The actual type is
+
+ fixnum
+
+ The expression's declared type is
+
+ symbol
+
+Warning: Type mismatch.
+ (test-scrutinizer-message-format.scm:62)
+ In `m#toplevel-foo', a toplevel procedure
+ In `local-bar', a local procedure
+ In `r-zero-values-for-the', a local procedure
+ In expression
+
+ (scheme#values)
+
+ Expression returns 0 values but is declared to return
+
+ symbol
+
+Warning: Type mismatch.
+ (test-scrutinizer-message-format.scm:63)
+ In `m#toplevel-foo', a toplevel procedure
+ In `local-bar', a local procedure
+ In `r-too-many-values-for-the', a local procedure
+ In expression
+
+ (scheme#values 1 2)
+
+ Expression returns too many values.
+
+ The expression returns 2 values but is declared to return
+
+ symbol
+
+Warning: Type mismatch.
+ (test-scrutinizer-message-format.scm:63)
+ In `m#toplevel-foo', a toplevel procedure
+ In `local-bar', a local procedure
+ In `r-too-many-values-for-the', a local procedure
+ In expression
+
+ (scheme#values 1 2)
+
+ Expression's declared and actual types do not match.
+
+ The actual type is
+
+ fixnum
+
+ The expression's declared type is
+
+ symbol
+
+Warning: Type mismatch.
+ In `m#toplevel-foo', a toplevel procedure
+ In `local-bar', a local procedure
+ In `r-toplevel-var-assignment-type-mismatch', a local procedure
+ In assignment
+
+ (set! m#foo2 1)
+
+ Variable `m#foo2' is assigned invalid value.
+
+ The assigned value has type
+
+ fixnum
+
+ The declared type of `m#foo2' is
+
+ boolean
+
+Warning: In `m#toplevel-foo', a toplevel procedure
+ In `local-bar', a local procedure
+ In `r-deprecated-identifier', a local procedure
use of deprecated `m#deprecated-foo'
-Warning: in local procedure `r-deprecated-identifier',
- in local procedure `local-bar',
- in toplevel procedure `m#toplevel-foo':
+Warning: In `m#toplevel-foo', a toplevel procedure
+ In `local-bar', a local procedure
+ In `r-deprecated-identifier', a local procedure
use of deprecated `m#deprecated-foo2' - consider `foo'
-Warning: in local procedure `list-ref-negative-index',
- in local procedure `local-bar',
- in toplevel procedure `m#toplevel-foo':
+Warning: In `m#toplevel-foo', a toplevel procedure
+ In `local-bar', a local procedure
+ In `list-ref-negative-index', a local procedure
(test-scrutinizer-message-format.scm:67) in procedure call to
`scheme#list-ref', index -1 is negative, which is never valid
-Warning: in local procedure `list-ref-out-of-range',
- in local procedure `local-bar',
- in toplevel procedure `m#toplevel-foo':
+Warning: In `m#toplevel-foo', a toplevel procedure
+ In `local-bar', a local procedure
+ In `list-ref-out-of-range', a local procedure
(test-scrutinizer-message-format.scm:68) in procedure call to
`scheme#list-ref', index 1 out of range for proper list of length 0
-Warning: in local procedure `vector-ref-out-of-range',
- in local procedure `local-bar',
- in toplevel procedure `m#toplevel-foo':
+Warning: In `m#toplevel-foo', a toplevel procedure
+ In `local-bar', a local procedure
+ In `vector-ref-out-of-range', a local procedure
(test-scrutinizer-message-format.scm:70) in procedure call to
`scheme#vector-ref', index -1 out of range for vector of length 0
-Warning: in local procedure `zero-values-for-let',
- in local procedure `local-bar',
- in toplevel procedure `m#toplevel-foo':
+Warning: In `m#toplevel-foo', a toplevel procedure
+ In `local-bar', a local procedure
+ In `zero-values-for-let', a local procedure
expected a single result in `let' binding of `a', but received zero results
-Warning: in local procedure `multiple-values-for-let',
- in local procedure `local-bar',
- in toplevel procedure `m#toplevel-foo':
+Warning: In `m#toplevel-foo', a toplevel procedure
+ In `local-bar', a local procedure
+ In `multiple-values-for-let', a local procedure
expected a single result in `let' binding of `a', but received 2 results
-Warning: in local procedure `zero-values-for-conditional',
- in local procedure `local-bar',
- in toplevel procedure `m#toplevel-foo':
+Warning: In `m#toplevel-foo', a toplevel procedure
+ In `local-bar', a local procedure
+ In `zero-values-for-conditional', a local procedure
expected a single result in conditional, but received zero results
-Warning: in local procedure `multiple-values-for-conditional',
- in local procedure `local-bar',
- in toplevel procedure `m#toplevel-foo':
+Warning: In `m#toplevel-foo', a toplevel procedure
+ In `local-bar', a local procedure
+ In `multiple-values-for-conditional', a local procedure
expected a single result in conditional, but received 2 results
-Note: in local procedure `multiple-values-for-conditional',
- in local procedure `local-bar',
- in toplevel procedure `m#toplevel-foo':
- (test-scrutinizer-message-format.scm:74) expected a value of type boolean in
conditional, but was given a value of type `fixnum' which is always true:
+Note: Type mismatch.
+ (test-scrutinizer-message-format.scm:74)
+ In `m#toplevel-foo', a toplevel procedure
+ In `local-bar', a local procedure
+ In `multiple-values-for-conditional', a local procedure
+ In conditional expression
+
+ (if (scheme#values 1 2) 1 (##core#undefined))
+
+ Test condition has always true value of type
+
+ fixnum
+
+Error: Type mismatch.
+ (test-scrutinizer-message-format.scm:76)
+ In `m#toplevel-foo', a toplevel procedure
+ In `local-bar', a local procedure
+ In `fail-compiler-typecase', a local procedure
+ In `compiler-typecase' expression
-(if (scheme#values 1 2) 1 (##core#undefined))
+ (compiler-typecase g97 (symbol 1) (list 2) (else (##core#undefined)))
+
+ Tested expression in `compiler-typecase' does not match any case.
+
+ The expression has this type
+
+ fixnum
+
+ The specified type cases are these
-Error: in local procedure `fail-compiler-typecase',
- in local procedure `local-bar',
- in toplevel procedure `m#toplevel-foo':
- (test-scrutinizer-message-format.scm:76) no clause applies in
`compiler-typecase' for expression of type `fixnum':
symbol
+
list
diff --git a/tests/scrutiny-2.expected b/tests/scrutiny-2.expected
index 9058276..9d5e7fd 100644
--- a/tests/scrutiny-2.expected
+++ b/tests/scrutiny-2.expected
@@ -1,66 +1,374 @@
-Note: at toplevel:
- (scrutiny-tests-2.scm:20) in procedure call to `scheme#pair?', the predicate
is called with an argument of type `pair' and will always return true
+Note: Type mismatch.
+ (scrutiny-tests-2.scm:20)
+ At toplevel:
+ In predicate call
-Note: at toplevel:
- (scrutiny-tests-2.scm:20) in procedure call to `scheme#pair?', the predicate
is called with an argument of type `null' and will always return false
+ (scheme#pair? p)
-Note: at toplevel:
- (scrutiny-tests-2.scm:20) in procedure call to `scheme#pair?', the predicate
is called with an argument of type `null' and will always return false
+ Predicate call will always return true.
-Note: at toplevel:
- (scrutiny-tests-2.scm:20) in procedure call to `scheme#pair?', the predicate
is called with an argument of type `fixnum' and will always return false
+ Procedure `scheme#pair?' is a predicate for
-Note: at toplevel:
- (scrutiny-tests-2.scm:20) in procedure call to `scheme#pair?', the predicate
is called with an argument of type `float' and will always return false
+ pair
-Note: at toplevel:
- (scrutiny-tests-2.scm:21) in procedure call to `scheme#list?', the predicate
is called with an argument of type `null' and will always return true
+ The given argument has type
-Note: at toplevel:
- (scrutiny-tests-2.scm:21) in procedure call to `scheme#list?', the predicate
is called with an argument of type `null' and will always return true
+ pair
-Note: at toplevel:
- (scrutiny-tests-2.scm:21) in procedure call to `scheme#list?', the predicate
is called with an argument of type `fixnum' and will always return false
+Note: Type mismatch.
+ (scrutiny-tests-2.scm:20)
+ At toplevel:
+ In predicate call
-Note: at toplevel:
- (scrutiny-tests-2.scm:21) in procedure call to `scheme#list?', the predicate
is called with an argument of type `float' and will always return false
+ (scheme#pair? l)
-Note: at toplevel:
- (scrutiny-tests-2.scm:22) in procedure call to `scheme#null?', the predicate
is called with an argument of type `null' and will always return true
+ Predicate call will always return false.
-Note: at toplevel:
- (scrutiny-tests-2.scm:22) in procedure call to `scheme#null?', the predicate
is called with an argument of type `null' and will always return true
+ Procedure `scheme#pair?' is a predicate for
-Note: at toplevel:
- (scrutiny-tests-2.scm:22) in procedure call to `scheme#null?', the predicate
is called with an argument of type `pair' and will always return false
+ pair
-Note: at toplevel:
- (scrutiny-tests-2.scm:22) in procedure call to `scheme#null?', the predicate
is called with an argument of type `fixnum' and will always return false
+ The given argument has type
-Note: at toplevel:
- (scrutiny-tests-2.scm:22) in procedure call to `scheme#null?', the predicate
is called with an argument of type `float' and will always return false
+ null
-Note: at toplevel:
- (scrutiny-tests-2.scm:23) in procedure call to `chicken.base#fixnum?', the
predicate is called with an argument of type `fixnum' and will always return
true
+Note: Type mismatch.
+ (scrutiny-tests-2.scm:20)
+ At toplevel:
+ In predicate call
-Note: at toplevel:
- (scrutiny-tests-2.scm:23) in procedure call to `chicken.base#fixnum?', the
predicate is called with an argument of type `float' and will always return
false
+ (scheme#pair? n)
-Note: at toplevel:
- (scrutiny-tests-2.scm:25) in procedure call to `chicken.base#flonum?', the
predicate is called with an argument of type `float' and will always return true
+ Predicate call will always return false.
-Note: at toplevel:
- (scrutiny-tests-2.scm:25) in procedure call to `chicken.base#flonum?', the
predicate is called with an argument of type `fixnum' and will always return
false
+ Procedure `scheme#pair?' is a predicate for
-Note: at toplevel:
- (scrutiny-tests-2.scm:27) in procedure call to `scheme#number?', the
predicate is called with an argument of type `fixnum' and will always return
true
+ pair
-Note: at toplevel:
- (scrutiny-tests-2.scm:27) in procedure call to `scheme#number?', the
predicate is called with an argument of type `float' and will always return true
+ The given argument has type
-Note: at toplevel:
- (scrutiny-tests-2.scm:27) in procedure call to `scheme#number?', the
predicate is called with an argument of type `number' and will always return
true
+ null
-Note: at toplevel:
- (scrutiny-tests-2.scm:27) in procedure call to `scheme#number?', the
predicate is called with an argument of type `null' and will always return false
+Note: Type mismatch.
+ (scrutiny-tests-2.scm:20)
+ At toplevel:
+ In predicate call
+
+ (scheme#pair? i)
+
+ Predicate call will always return false.
+
+ Procedure `scheme#pair?' is a predicate for
+
+ pair
+
+ The given argument has type
+
+ fixnum
+
+Note: Type mismatch.
+ (scrutiny-tests-2.scm:20)
+ At toplevel:
+ In predicate call
+
+ (scheme#pair? f)
+
+ Predicate call will always return false.
+
+ Procedure `scheme#pair?' is a predicate for
+
+ pair
+
+ The given argument has type
+
+ float
+
+Note: Type mismatch.
+ (scrutiny-tests-2.scm:21)
+ At toplevel:
+ In predicate call
+
+ (scheme#list? l)
+
+ Predicate call will always return true.
+
+ Procedure `scheme#list?' is a predicate for
+
+ list
+
+ The given argument has type
+
+ null
+
+Note: Type mismatch.
+ (scrutiny-tests-2.scm:21)
+ At toplevel:
+ In predicate call
+
+ (scheme#list? n)
+
+ Predicate call will always return true.
+
+ Procedure `scheme#list?' is a predicate for
+
+ list
+
+ The given argument has type
+
+ null
+
+Note: Type mismatch.
+ (scrutiny-tests-2.scm:21)
+ At toplevel:
+ In predicate call
+
+ (scheme#list? i)
+
+ Predicate call will always return false.
+
+ Procedure `scheme#list?' is a predicate for
+
+ list
+
+ The given argument has type
+
+ fixnum
+
+Note: Type mismatch.
+ (scrutiny-tests-2.scm:21)
+ At toplevel:
+ In predicate call
+
+ (scheme#list? f)
+
+ Predicate call will always return false.
+
+ Procedure `scheme#list?' is a predicate for
+
+ list
+
+ The given argument has type
+
+ float
+
+Note: Type mismatch.
+ (scrutiny-tests-2.scm:22)
+ At toplevel:
+ In predicate call
+
+ (scheme#null? n)
+
+ Predicate call will always return true.
+
+ Procedure `scheme#null?' is a predicate for
+
+ null
+
+ The given argument has type
+
+ null
+
+Note: Type mismatch.
+ (scrutiny-tests-2.scm:22)
+ At toplevel:
+ In predicate call
+
+ (scheme#null? l)
+
+ Predicate call will always return true.
+
+ Procedure `scheme#null?' is a predicate for
+
+ null
+
+ The given argument has type
+
+ null
+
+Note: Type mismatch.
+ (scrutiny-tests-2.scm:22)
+ At toplevel:
+ In predicate call
+
+ (scheme#null? p)
+
+ Predicate call will always return false.
+
+ Procedure `scheme#null?' is a predicate for
+
+ null
+
+ The given argument has type
+
+ pair
+
+Note: Type mismatch.
+ (scrutiny-tests-2.scm:22)
+ At toplevel:
+ In predicate call
+
+ (scheme#null? i)
+
+ Predicate call will always return false.
+
+ Procedure `scheme#null?' is a predicate for
+
+ null
+
+ The given argument has type
+
+ fixnum
+
+Note: Type mismatch.
+ (scrutiny-tests-2.scm:22)
+ At toplevel:
+ In predicate call
+
+ (scheme#null? f)
+
+ Predicate call will always return false.
+
+ Procedure `scheme#null?' is a predicate for
+
+ null
+
+ The given argument has type
+
+ float
+
+Note: Type mismatch.
+ (scrutiny-tests-2.scm:23)
+ At toplevel:
+ In predicate call
+
+ (chicken.base#fixnum? i)
+
+ Predicate call will always return true.
+
+ Procedure `chicken.base#fixnum?' is a predicate for
+
+ fixnum
+
+ The given argument has type
+
+ fixnum
+
+Note: Type mismatch.
+ (scrutiny-tests-2.scm:23)
+ At toplevel:
+ In predicate call
+
+ (chicken.base#fixnum? f)
+
+ Predicate call will always return false.
+
+ Procedure `chicken.base#fixnum?' is a predicate for
+
+ fixnum
+
+ The given argument has type
+
+ float
+
+Note: Type mismatch.
+ (scrutiny-tests-2.scm:25)
+ At toplevel:
+ In predicate call
+
+ (chicken.base#flonum? f)
+
+ Predicate call will always return true.
+
+ Procedure `chicken.base#flonum?' is a predicate for
+
+ float
+
+ The given argument has type
+
+ float
+
+Note: Type mismatch.
+ (scrutiny-tests-2.scm:25)
+ At toplevel:
+ In predicate call
+
+ (chicken.base#flonum? i)
+
+ Predicate call will always return false.
+
+ Procedure `chicken.base#flonum?' is a predicate for
+
+ float
+
+ The given argument has type
+
+ fixnum
+
+Note: Type mismatch.
+ (scrutiny-tests-2.scm:27)
+ At toplevel:
+ In predicate call
+
+ (scheme#number? i)
+
+ Predicate call will always return true.
+
+ Procedure `scheme#number?' is a predicate for
+
+ number
+
+ The given argument has type
+
+ fixnum
+
+Note: Type mismatch.
+ (scrutiny-tests-2.scm:27)
+ At toplevel:
+ In predicate call
+
+ (scheme#number? f)
+
+ Predicate call will always return true.
+
+ Procedure `scheme#number?' is a predicate for
+
+ number
+
+ The given argument has type
+
+ float
+
+Note: Type mismatch.
+ (scrutiny-tests-2.scm:27)
+ At toplevel:
+ In predicate call
+
+ (scheme#number? u)
+
+ Predicate call will always return true.
+
+ Procedure `scheme#number?' is a predicate for
+
+ number
+
+ The given argument has type
+
+ number
+
+Note: Type mismatch.
+ (scrutiny-tests-2.scm:27)
+ At toplevel:
+ In predicate call
+
+ (scheme#number? n)
+
+ Predicate call will always return false.
+
+ Procedure `scheme#number?' is a predicate for
+
+ number
+
+ The given argument has type
+
+ null
diff --git a/tests/scrutiny.expected b/tests/scrutiny.expected
index cd5fe04..4cf59e6 100644
--- a/tests/scrutiny.expected
+++ b/tests/scrutiny.expected
@@ -1,215 +1,940 @@
Warning: (scrutiny-tests.scm:31) - assignment to imported value binding `car'
-Note: in local procedure `c',
- in local procedure `b',
- in toplevel procedure `a':
- expected a value of type boolean in conditional, but was given a value of
type `number' which is always true:
+Note: Type mismatch.
+ In `a', a toplevel procedure
+ In `b', a local procedure
+ In `c', a local procedure
+ In conditional expression
-(if x 1 2)
+ (if x 1 2)
-Note: in toplevel procedure `b':
- expected a value of type boolean in conditional, but was given a value of
type `true' which is always true:
+ Test condition has always true value of type
-(if x 1 2)
+ number
-Warning: in toplevel procedure `foo':
- branches in conditional expression differ in the number of results:
+Note: Type mismatch.
+ In `b', a toplevel procedure
+ In conditional expression
-(if x (scheme#values 1 2) (scheme#values 1 2 (scheme#+ (scheme#+ ...))))
+ (if x 1 2)
-Warning: at toplevel:
- (scrutiny-tests.scm:19) in procedure call to `bar', expected argument #2 of
type `number' but was given an argument of type `symbol'
+ Test condition has always true value of type
-Warning: at toplevel:
- (scrutiny-tests.scm:21) in procedure call to `scheme#string?', expected 1
argument but was given 0 arguments
+ true
-Warning: at toplevel:
+Warning: Type mismatch.
+ (scrutiny-tests.scm:16)
+ In `foo', a toplevel procedure
+ In conditional expression
+
+ (if x (scheme#values 1 2) (scheme#values 1 2 (scheme#+ (scheme#+ ...))))
+
+ The branches have different number of returned values.
+
+ The true branch returns 2 values
+
+ (scheme#values 1 2)
+
+ The false branch returns 3 values
+
+ (scheme#values 1 2 (scheme#+ (scheme#+ (scheme#+ ...))))
+
+Warning: Type mismatch.
+ (scrutiny-tests.scm:19)
+ At toplevel:
+ In procedure call
+
+ (bar 3 'a)
+
+ Argument #2 to procedure `bar' has invalid type
+
+ symbol
+
+ The expected type is
+
+ number
+
+ The procedure's type is
+
+ (procedure scheme#+ (#!rest number) number)
+
+Warning: Type mismatch.
+ (scrutiny-tests.scm:21)
+ At toplevel:
+ In procedure call
+
+ (scheme#string?)
+
+ Procedure `scheme#string?' is called with 0 arguments but 1 argument is
expected.
+
+ The procedure's type is
+
+ (procedure scheme#string? (*) boolean)
+
+Warning: At toplevel:
(scrutiny-tests.scm:23) expected a single result in argument #1 of procedure
call `(chicken.base#print (scheme#values 1 2))', but received 2 results
-Warning: at toplevel:
+Warning: At toplevel:
(scrutiny-tests.scm:24) expected a single result in argument #1 of procedure
call `(chicken.base#print (scheme#values))', but received zero results
-Warning: at toplevel:
- (scrutiny-tests.scm:27) in procedure call to `x', expected a value of type
`(procedure () *)' but was given a value of type `fixnum'
+Warning: Type mismatch.
+ (scrutiny-tests.scm:27)
+ At toplevel:
+ In procedure call
+
+ (x)
+
+ Procedure in a procedure call has invalid type
+
+ fixnum
+
+ The expected type is
+
+ (procedure () *)
+
+Warning: Type mismatch.
+ (scrutiny-tests.scm:29)
+ At toplevel:
+ In procedure call
+
+ (scheme#+ 'a 'b)
+
+ Argument #1 to procedure `scheme#+' has invalid type
+
+ symbol
+
+ The expected type is
+
+ number
+
+ The procedure's type is
+
+ (procedure scheme#+ (#!rest number) number)
+
+Warning: Type mismatch.
+ (scrutiny-tests.scm:29)
+ At toplevel:
+ In procedure call
+
+ (scheme#+ 'a 'b)
+
+ Argument #2 to procedure `scheme#+' has invalid type
+
+ symbol
+
+ The expected type is
+
+ number
+
+ The procedure's type is
-Warning: at toplevel:
- (scrutiny-tests.scm:29) in procedure call to `scheme#+', expected argument
#1 of type `number' but was given an argument of type `symbol'
+ (procedure scheme#+ (#!rest number) number)
-Warning: at toplevel:
- (scrutiny-tests.scm:29) in procedure call to `scheme#+', expected argument
#2 of type `number' but was given an argument of type `symbol'
+Warning: Type mismatch.
+ At toplevel:
+ In assignment
-Warning: at toplevel:
- assignment of value of type `fixnum' to toplevel variable `scheme#car' does
not match declared type `(forall (a) (procedure scheme#car ((pair a *)) a))'
+ (set! scheme#car 33)
-Warning: at toplevel:
+ Variable `scheme#car' is assigned invalid value.
+
+ The assigned value has type
+
+ fixnum
+
+ The declared type of `scheme#car' is
+
+ (forall (a) (procedure scheme#car ((pair a *)) a))
+
+Warning: At toplevel:
expected a single result in `let' binding of `g19', but received 2 results
-Warning: at toplevel:
- in procedure call to `g19', expected a value of type `(procedure () *)' but
was given a value of type `fixnum'
+Warning: Type mismatch.
+ At toplevel:
+ In procedure call
+
+ (g19)
+
+ Procedure in a procedure call has invalid type
+
+ fixnum
+
+ The expected type is
+
+ (procedure () *)
+
+Note: Type mismatch.
+ In `foo', a toplevel procedure
+ In conditional expression
+
+ (if bar 3 (##core#undefined))
+
+ Test condition has always true value of type
+
+ (procedure bar () *)
+
+Warning: Type mismatch.
+ (scrutiny-tests.scm:58)
+ In `foo2', a toplevel procedure
+ In procedure call
+
+ (scheme#string-append x "abc")
+
+ Argument #1 to procedure `scheme#string-append' has invalid type
+
+ number
+
+ The expected type is
+
+ string
+
+ The procedure's type is
+
+ (procedure scheme#string-append (#!rest string) string)
+
+Warning: Type mismatch.
+ (scrutiny-tests.scm:66)
+ At toplevel:
+ In procedure call
+
+ (foo3 99)
+
+ Argument #1 to procedure `foo3' has invalid type
+
+ fixnum
+
+ The expected type is
+
+ string
+
+ The procedure's type is
+
+ (procedure foo3 (string) string)
+
+Warning: Type mismatch.
+ (scrutiny-tests.scm:71)
+ In `foo4', a toplevel procedure
+ In procedure call
+
+ (scheme#+ x 1)
+
+ Argument #1 to procedure `scheme#+' has invalid type
+
+ string
+
+ The expected type is
+
+ number
+
+ The procedure's type is
+
+ (procedure scheme#+ (#!rest number) number)
+
+Warning: Type mismatch.
+ (scrutiny-tests.scm:77)
+ In `foo5', a toplevel procedure
+ In procedure call
-Note: in toplevel procedure `foo':
- expected a value of type boolean in conditional, but was given a value of
type `(procedure bar () *)' which is always true:
+ (scheme#+ x 3)
-(if bar 3 (##core#undefined))
+ Argument #1 to procedure `scheme#+' has invalid type
-Warning: in toplevel procedure `foo2':
- (scrutiny-tests.scm:58) in procedure call to `scheme#string-append',
expected argument #1 of type `string' but was given an argument of type `number'
+ string
-Warning: at toplevel:
- (scrutiny-tests.scm:66) in procedure call to `foo3', expected argument #1 of
type `string' but was given an argument of type `fixnum'
+ The expected type is
-Warning: in toplevel procedure `foo4':
- (scrutiny-tests.scm:71) in procedure call to `scheme#+', expected argument
#1 of type `number' but was given an argument of type `string'
+ number
-Warning: in toplevel procedure `foo5':
- (scrutiny-tests.scm:77) in procedure call to `scheme#+', expected argument
#1 of type `number' but was given an argument of type `string'
+ The procedure's type is
-Warning: in toplevel procedure `foo6':
- (scrutiny-tests.scm:83) in procedure call to `scheme#+', expected argument
#1 of type `number' but was given an argument of type `string'
+ (procedure scheme#+ (#!rest number) number)
-Warning: at toplevel:
- (scrutiny-tests.scm:90) in procedure call to `scheme#+', expected argument
#1 of type `number' but was given an argument of type `string'
+Warning: Type mismatch.
+ (scrutiny-tests.scm:83)
+ In `foo6', a toplevel procedure
+ In procedure call
-Warning: in toplevel procedure `foo10':
- (scrutiny-tests.scm:104) in procedure call to `foo9', expected argument #1
of type `string' but was given an argument of type `number'
+ (scheme#+ x 3)
-Warning: in toplevel procedure `foo10':
- (scrutiny-tests.scm:105) in procedure call to `scheme#+', expected argument
#1 of type `number' but was given an argument of type `string'
+ Argument #1 to procedure `scheme#+' has invalid type
-Warning: in toplevel procedure `foo10':
- expression returns a result of type `string' but is declared to return
`pair', which is not compatible
+ string
-Warning: in toplevel procedure `foo10':
- (scrutiny-tests.scm:109) in procedure call to `scheme#string-append',
expected argument #1 of type `string' but was given an argument of type `pair'
+ The expected type is
-Warning: in toplevel procedure `foo10':
- expression returns 2 values but is declared to have a single result
+ number
-Warning: in toplevel procedure `foo10':
- expression returns zero values but is declared to have a single result of
type `*'
+ The procedure's type is
-Warning: in toplevel procedure `foo10':
- (scrutiny-tests.scm:112) in procedure call to `scheme#*', expected argument
#1 of type `number' but was given an argument of type `string'
+ (procedure scheme#+ (#!rest number) number)
-Warning: in toplevel procedure `foo#blabla':
- (scrutiny-tests.scm:137) in procedure call to `scheme#+', expected argument
#2 of type `number' but was given an argument of type `symbol'
+Warning: Type mismatch.
+ (scrutiny-tests.scm:90)
+ At toplevel:
+ In procedure call
-Warning: at toplevel:
+ (scheme#+ x 1)
+
+ Argument #1 to procedure `scheme#+' has invalid type
+
+ string
+
+ The expected type is
+
+ number
+
+ The procedure's type is
+
+ (procedure scheme#+ (#!rest number) number)
+
+Warning: Type mismatch.
+ (scrutiny-tests.scm:104)
+ In `foo10', a toplevel procedure
+ In procedure call
+
+ (foo9 x)
+
+ Argument #1 to procedure `foo9' has invalid type
+
+ number
+
+ The expected type is
+
+ string
+
+ The procedure's type is
+
+ (procedure foo9 (string) symbol)
+
+Warning: Type mismatch.
+ (scrutiny-tests.scm:105)
+ In `foo10', a toplevel procedure
+ In procedure call
+
+ (scheme#+ x 1)
+
+ Argument #1 to procedure `scheme#+' has invalid type
+
+ string
+
+ The expected type is
+
+ number
+
+ The procedure's type is
+
+ (procedure scheme#+ (#!rest number) number)
+
+Warning: Type mismatch.
+ (scrutiny-tests.scm:109)
+ In `foo10', a toplevel procedure
+ In expression
+
+ (scheme#substring x 0 10)
+
+ Expression's declared and actual types do not match.
+
+ The actual type is
+
+ string
+
+ The expression's declared type is
+
+ pair
+
+Warning: Type mismatch.
+ (scrutiny-tests.scm:109)
+ In `foo10', a toplevel procedure
+ In procedure call
+
+ (scheme#string-append (the pair (scheme#substring x 0 10)))
+
+ Argument #1 to procedure `scheme#string-append' has invalid type
+
+ pair
+
+ The expected type is
+
+ string
+
+ The procedure's type is
+
+ (procedure scheme#string-append (#!rest string) string)
+
+Warning: Type mismatch.
+ (scrutiny-tests.scm:110)
+ In `foo10', a toplevel procedure
+ In expression
+
+ (scheme#values 1 2)
+
+ Expression returns too many values.
+
+ The expression returns 2 values but is declared to return
+
+ *
+
+Warning: Type mismatch.
+ (scrutiny-tests.scm:111)
+ In `foo10', a toplevel procedure
+ In expression
+
+ (scheme#values)
+
+ Expression returns 0 values but is declared to return
+
+ *
+
+Warning: Type mismatch.
+ (scrutiny-tests.scm:112)
+ In `foo10', a toplevel procedure
+ In procedure call
+
+ (scheme#* x y)
+
+ Argument #1 to procedure `scheme#*' has invalid type
+
+ string
+
+ The expected type is
+
+ number
+
+ The procedure's type is
+
+ (procedure scheme#* (#!rest number) number)
+
+Warning: Type mismatch.
+ (scrutiny-tests.scm:137)
+ In `foo#blabla', a toplevel procedure
+ In procedure call
+
+ (scheme#+ 1 'x)
+
+ Argument #2 to procedure `scheme#+' has invalid type
+
+ symbol
+
+ The expected type is
+
+ number
+
+ The procedure's type is
+
+ (procedure scheme#+ (#!rest number) number)
+
+Warning: At toplevel:
use of deprecated `deprecated-procedure'
-Warning: at toplevel:
+Warning: At toplevel:
use of deprecated `another-deprecated-procedure' - consider
`replacement-procedure'
-Warning: at toplevel:
- (scrutiny-tests.scm:168) in procedure call to `apply1', expected argument #2
of type `(list-of number)' but was given an argument of type `(list symbol
fixnum fixnum)'
+Warning: Type mismatch.
+ (scrutiny-tests.scm:168)
+ At toplevel:
+ In procedure call
+
+ (apply1 scheme#+ (scheme#list 'a 2 3))
+
+ Argument #2 to procedure `apply1' has invalid type
+
+ (list symbol fixnum fixnum)
+
+ The expected type is
+
+ (list-of number)
+
+ The procedure's type is
+
+ (forall (a b) (procedure apply1 ((procedure (#!rest a) b) (list-of a)) b))
+
+Warning: Type mismatch.
+ (scrutiny-tests.scm:169)
+ At toplevel:
+ In procedure call
+
+ (apply1 scheme#+ (scheme#cons 'a (scheme#cons 2 (scheme#cons 3 ...))))
+
+ Argument #2 to procedure `apply1' has invalid type
+
+ (list symbol fixnum fixnum)
+
+ The expected type is
+
+ (list-of number)
+
+ The procedure's type is
+
+ (forall (a b) (procedure apply1 ((procedure (#!rest a) b) (list-of a)) b))
-Warning: at toplevel:
- (scrutiny-tests.scm:169) in procedure call to `apply1', expected argument #2
of type `(list-of number)' but was given an argument of type `(list symbol
fixnum fixnum)'
+Note: Type mismatch.
+ (scrutiny-tests.scm:182)
+ At toplevel:
+ In predicate call
-Note: at toplevel:
- (scrutiny-tests.scm:182) in procedure call to `chicken.base#fixnum?', the
predicate is called with an argument of type `fixnum' and will always return
true
+ (chicken.base#fixnum? x)
-Note: at toplevel:
- (scrutiny-tests.scm:190) in procedure call to `scheme#symbol?', the
predicate is called with an argument of type `(or char string)' and will always
return false
+ Predicate call will always return true.
-Note: at toplevel:
- (scrutiny-tests.scm:191) in procedure call to `scheme#string?', the
predicate is called with an argument of type `(not (or char string))' and will
always return false
+ Procedure `chicken.base#fixnum?' is a predicate for
-Note: at toplevel:
- (scrutiny-tests.scm:194) in procedure call to `char-or-string?', the
predicate is called with an argument of type `fixnum' and will always return
false
+ fixnum
-Note: at toplevel:
- (scrutiny-tests.scm:195) in procedure call to `scheme#symbol?', the
predicate is called with an argument of type `(or char string)' and will always
return false
+ The given argument has type
-Note: at toplevel:
- (scrutiny-tests.scm:196) in procedure call to `scheme#string?', the
predicate is called with an argument of type `fixnum' and will always return
false
+ fixnum
-Note: at toplevel:
- (scrutiny-tests.scm:200) in procedure call to `scheme#symbol?', the
predicate is called with an argument of type `char' and will always return false
+Note: Type mismatch.
+ (scrutiny-tests.scm:190)
+ At toplevel:
+ In predicate call
-Note: at toplevel:
- (scrutiny-tests.scm:201) in procedure call to `scheme#string?', the
predicate is called with an argument of type `symbol' and will always return
false
+ (scheme#symbol? x)
-Note: at toplevel:
- (scrutiny-tests.scm:205) in procedure call to `scheme#symbol?', the
predicate is called with an argument of type `(or char string)' and will always
return false
+ Predicate call will always return false.
-Note: at toplevel:
- (scrutiny-tests.scm:206) in procedure call to `scheme#string?', the
predicate is called with an argument of type `symbol' and will always return
false
+ Procedure `scheme#symbol?' is a predicate for
-Warning: at toplevel:
- (scrutiny-tests.scm:210) in procedure call to `f', expected argument #1 of
type `pair' but was given an argument of type `null'
+ symbol
-Warning: at toplevel:
- (scrutiny-tests.scm:212) in procedure call to `f', expected argument #1 of
type `null' but was given an argument of type `(list fixnum)'
+ The given argument has type
-Warning: at toplevel:
- (scrutiny-tests.scm:214) in procedure call to `f', expected argument #1 of
type `list' but was given an argument of type `(pair fixnum fixnum)'
+ (or char string)
-Warning: in toplevel procedure `vector-ref-warn1':
+Note: Type mismatch.
+ (scrutiny-tests.scm:191)
+ At toplevel:
+ In predicate call
+
+ (scheme#string? x)
+
+ Predicate call will always return false.
+
+ Procedure `scheme#string?' is a predicate for
+
+ string
+
+ The given argument has type
+
+ (not (or char string))
+
+Note: Type mismatch.
+ (scrutiny-tests.scm:194)
+ At toplevel:
+ In predicate call
+
+ (char-or-string? x)
+
+ Predicate call will always return false.
+
+ Procedure `char-or-string?' is a predicate for
+
+ (or char string)
+
+ The given argument has type
+
+ fixnum
+
+Note: Type mismatch.
+ (scrutiny-tests.scm:195)
+ At toplevel:
+ In predicate call
+
+ (scheme#symbol? x)
+
+ Predicate call will always return false.
+
+ Procedure `scheme#symbol?' is a predicate for
+
+ symbol
+
+ The given argument has type
+
+ (or char string)
+
+Note: Type mismatch.
+ (scrutiny-tests.scm:196)
+ At toplevel:
+ In predicate call
+
+ (scheme#string? x)
+
+ Predicate call will always return false.
+
+ Procedure `scheme#string?' is a predicate for
+
+ string
+
+ The given argument has type
+
+ fixnum
+
+Note: Type mismatch.
+ (scrutiny-tests.scm:200)
+ At toplevel:
+ In predicate call
+
+ (scheme#symbol? x)
+
+ Predicate call will always return false.
+
+ Procedure `scheme#symbol?' is a predicate for
+
+ symbol
+
+ The given argument has type
+
+ char
+
+Note: Type mismatch.
+ (scrutiny-tests.scm:201)
+ At toplevel:
+ In predicate call
+
+ (scheme#string? x)
+
+ Predicate call will always return false.
+
+ Procedure `scheme#string?' is a predicate for
+
+ string
+
+ The given argument has type
+
+ symbol
+
+Note: Type mismatch.
+ (scrutiny-tests.scm:205)
+ At toplevel:
+ In predicate call
+
+ (scheme#symbol? x)
+
+ Predicate call will always return false.
+
+ Procedure `scheme#symbol?' is a predicate for
+
+ symbol
+
+ The given argument has type
+
+ (or char string)
+
+Note: Type mismatch.
+ (scrutiny-tests.scm:206)
+ At toplevel:
+ In predicate call
+
+ (scheme#string? x)
+
+ Predicate call will always return false.
+
+ Procedure `scheme#string?' is a predicate for
+
+ string
+
+ The given argument has type
+
+ symbol
+
+Warning: Type mismatch.
+ (scrutiny-tests.scm:210)
+ At toplevel:
+ In procedure call
+
+ (f (scheme#list))
+
+ Argument #1 to procedure `f' has invalid type
+
+ null
+
+ The expected type is
+
+ pair
+
+ The procedure's type is
+
+ (procedure (pair) *)
+
+Warning: Type mismatch.
+ (scrutiny-tests.scm:212)
+ At toplevel:
+ In procedure call
+
+ (f (scheme#list 1))
+
+ Argument #1 to procedure `f' has invalid type
+
+ (list fixnum)
+
+ The expected type is
+
+ null
+
+ The procedure's type is
+
+ (procedure (null) *)
+
+Warning: Type mismatch.
+ (scrutiny-tests.scm:214)
+ At toplevel:
+ In procedure call
+
+ (f (scheme#cons 1 2))
+
+ Argument #1 to procedure `f' has invalid type
+
+ (pair fixnum fixnum)
+
+ The expected type is
+
+ list
+
+ The procedure's type is
+
+ (procedure (list) *)
+
+Warning: In `vector-ref-warn1', a toplevel procedure
(scrutiny-tests.scm:220) in procedure call to `scheme#vector-ref', index -1
out of range for vector of length 3
-Warning: in toplevel procedure `vector-ref-warn2':
+Warning: In `vector-ref-warn2', a toplevel procedure
(scrutiny-tests.scm:222) in procedure call to `scheme#vector-ref', index 3
out of range for vector of length 3
-Warning: in toplevel procedure `vector-ref-warn3':
+Warning: In `vector-ref-warn3', a toplevel procedure
(scrutiny-tests.scm:223) in procedure call to `scheme#vector-ref', index 4
out of range for vector of length 3
-Warning: in toplevel procedure `vector-ref-standard-warn1':
- (scrutiny-tests.scm:226) in procedure call to `scheme#vector-ref', expected
argument #2 of type `fixnum' but was given an argument of type `symbol'
+Warning: Type mismatch.
+ (scrutiny-tests.scm:226)
+ In `vector-ref-standard-warn1', a toplevel procedure
+ In procedure call
+
+ (scheme#vector-ref v1 'bad)
+
+ Argument #2 to procedure `scheme#vector-ref' has invalid type
+
+ symbol
+
+ The expected type is
-Warning: in toplevel procedure `vector-set!-warn1':
+ fixnum
+
+ The procedure's type is
+
+ (forall (a) (procedure scheme#vector-ref ((vector-of a) fixnum) a))
+
+Warning: In `vector-set!-warn1', a toplevel procedure
(scrutiny-tests.scm:227) in procedure call to `scheme#vector-set!', index -1
out of range for vector of length 3
-Warning: in toplevel procedure `vector-set!-warn2':
+Warning: In `vector-set!-warn2', a toplevel procedure
(scrutiny-tests.scm:228) in procedure call to `scheme#vector-set!', index 3
out of range for vector of length 3
-Warning: in toplevel procedure `vector-set!-warn3':
+Warning: In `vector-set!-warn3', a toplevel procedure
(scrutiny-tests.scm:229) in procedure call to `scheme#vector-set!', index 4
out of range for vector of length 3
-Warning: in toplevel procedure `vector-set!-standard-warn1':
- (scrutiny-tests.scm:232) in procedure call to `scheme#vector-set!', expected
argument #2 of type `fixnum' but was given an argument of type `symbol'
+Warning: Type mismatch.
+ (scrutiny-tests.scm:232)
+ In `vector-set!-standard-warn1', a toplevel procedure
+ In procedure call
+
+ (scheme#vector-set! v1 'bad 'whatever)
+
+ Argument #2 to procedure `scheme#vector-set!' has invalid type
-Warning: in toplevel procedure `list-ref-warn1':
+ symbol
+
+ The expected type is
+
+ fixnum
+
+ The procedure's type is
+
+ (procedure scheme#vector-set! (vector fixnum *) undefined)
+
+Warning: In `list-ref-warn1', a toplevel procedure
(scrutiny-tests.scm:238) in procedure call to `scheme#list-ref', index -1 is
negative, which is never valid
-Warning: in toplevel procedure `list-ref-warn2':
+Warning: In `list-ref-warn2', a toplevel procedure
(scrutiny-tests.scm:241) in procedure call to `scheme#list-ref', index -1 is
negative, which is never valid
-Warning: in toplevel procedure `list-ref-warn3':
+Warning: In `list-ref-warn3', a toplevel procedure
(scrutiny-tests.scm:244) in procedure call to `scheme#list-ref', index -1 is
negative, which is never valid
-Warning: in toplevel procedure `list-ref-warn4':
+Warning: In `list-ref-warn4', a toplevel procedure
(scrutiny-tests.scm:246) in procedure call to `scheme#list-ref', index 3 out
of range for proper list of length 3
-Warning: in toplevel procedure `list-ref-warn5':
+Warning: In `list-ref-warn5', a toplevel procedure
(scrutiny-tests.scm:252) in procedure call to `scheme#list-ref', index 4 out
of range for proper list of length 3
-Warning: in toplevel procedure `list-ref-standard-warn1':
- (scrutiny-tests.scm:281) in procedure call to `scheme#list-ref', expected
argument #2 of type `fixnum' but was given an argument of type `symbol'
+Warning: Type mismatch.
+ (scrutiny-tests.scm:281)
+ In `list-ref-standard-warn1', a toplevel procedure
+ In procedure call
+
+ (scheme#list-ref l1 'bad)
+
+ Argument #2 to procedure `scheme#list-ref' has invalid type
+
+ symbol
+
+ The expected type is
+
+ fixnum
+
+ The procedure's type is
+
+ (forall (a) (procedure scheme#list-ref ((list-of a) fixnum) a))
+
+Warning: Type mismatch.
+ (scrutiny-tests.scm:282)
+ In `list-ref-standard-warn2', a toplevel procedure
+ In procedure call
+
+ (scheme#list-ref l1 'bad)
+
+ Argument #2 to procedure `scheme#list-ref' has invalid type
+
+ symbol
+
+ The expected type is
+
+ fixnum
+
+ The procedure's type is
+
+ (forall (a) (procedure scheme#list-ref ((list-of a) fixnum) a))
+
+Warning: Type mismatch.
+ (scrutiny-tests.scm:284)
+ In `list-ref-standard-warn3', a toplevel procedure
+ In procedure call
+
+ (scheme#list-ref l2 'bad)
+
+ Argument #2 to procedure `scheme#list-ref' has invalid type
+
+ symbol
+
+ The expected type is
+
+ fixnum
+
+ The procedure's type is
+
+ (forall (a) (procedure scheme#list-ref ((list-of a) fixnum) a))
+
+Warning: Type mismatch.
+ (scrutiny-tests.scm:285)
+ In `list-ref-standard-warn4', a toplevel procedure
+ In procedure call
+
+ (scheme#list-ref l2 'bad)
+
+ Argument #2 to procedure `scheme#list-ref' has invalid type
+
+ symbol
+
+ The expected type is
+
+ fixnum
+
+ The procedure's type is
+
+ (forall (a) (procedure scheme#list-ref ((list-of a) fixnum) a))
+
+Warning: Type mismatch.
+ (scrutiny-tests.scm:289)
+ In `list-ref-type-warn1', a toplevel procedure
+ In procedure call
+
+ (chicken.base#add1 (scheme#list-ref l1 1))
+
+ Argument #1 to procedure `chicken.base#add1' has invalid type
+
+ symbol
+
+ The expected type is
+
+ number
+
+ The procedure's type is
+
+ (procedure chicken.base#add1 (number) number)
+
+Warning: Type mismatch.
+ (scrutiny-tests.scm:291)
+ In `list-ref-type-warn2', a toplevel procedure
+ In procedure call
+
+ (chicken.base#add1 (scheme#list-ref l2 1))
+
+ Argument #1 to procedure `chicken.base#add1' has invalid type
+
+ symbol
+
+ The expected type is
+
+ number
+
+ The procedure's type is
+
+ (procedure chicken.base#add1 (number) number)
+
+Warning: Type mismatch.
+ (scrutiny-tests.scm:295)
+ In `list-ref-type-warn3', a toplevel procedure
+ In procedure call
+
+ (chicken.base#add1 (scheme#list-ref l3 1))
+
+ Argument #1 to procedure `chicken.base#add1' has invalid type
+
+ symbol
+
+ The expected type is
+
+ number
+
+ The procedure's type is
+
+ (procedure chicken.base#add1 (number) number)
+
+Warning: Type mismatch.
+ (scrutiny-tests.scm:307)
+ In `append-result-type-warn1', a toplevel procedure
+ In procedure call
+
+ (chicken.base#add1 (scheme#list-ref l1 1))
+
+ Argument #1 to procedure `chicken.base#add1' has invalid type
+
+ symbol
+
+ The expected type is
+
+ number
+
+ The procedure's type is
+
+ (procedure chicken.base#add1 (number) number)
-Warning: in toplevel procedure `list-ref-standard-warn2':
- (scrutiny-tests.scm:282) in procedure call to `scheme#list-ref', expected
argument #2 of type `fixnum' but was given an argument of type `symbol'
+Warning: Type mismatch.
+ (scrutiny-tests.scm:312)
+ In `append-result-type-warn2', a toplevel procedure
+ In procedure call
-Warning: in toplevel procedure `list-ref-standard-warn3':
- (scrutiny-tests.scm:284) in procedure call to `scheme#list-ref', expected
argument #2 of type `fixnum' but was given an argument of type `symbol'
+ (chicken.base#add1 (scheme#list-ref l3 3))
-Warning: in toplevel procedure `list-ref-standard-warn4':
- (scrutiny-tests.scm:285) in procedure call to `scheme#list-ref', expected
argument #2 of type `fixnum' but was given an argument of type `symbol'
+ Argument #1 to procedure `chicken.base#add1' has invalid type
-Warning: in toplevel procedure `list-ref-type-warn1':
- (scrutiny-tests.scm:289) in procedure call to `chicken.base#add1', expected
argument #1 of type `number' but was given an argument of type `symbol'
+ symbol
-Warning: in toplevel procedure `list-ref-type-warn2':
- (scrutiny-tests.scm:291) in procedure call to `chicken.base#add1', expected
argument #1 of type `number' but was given an argument of type `symbol'
+ The expected type is
-Warning: in toplevel procedure `list-ref-type-warn3':
- (scrutiny-tests.scm:295) in procedure call to `chicken.base#add1', expected
argument #1 of type `number' but was given an argument of type `symbol'
+ number
-Warning: in toplevel procedure `append-result-type-warn1':
- (scrutiny-tests.scm:307) in procedure call to `chicken.base#add1', expected
argument #1 of type `number' but was given an argument of type `symbol'
+ The procedure's type is
-Warning: in toplevel procedure `append-result-type-warn2':
- (scrutiny-tests.scm:312) in procedure call to `chicken.base#add1', expected
argument #1 of type `number' but was given an argument of type `symbol'
+ (procedure chicken.base#add1 (number) number)
Warning: redefinition of standard binding: scheme#car
diff --git a/tests/specialization.expected b/tests/specialization.expected
index fed76b6..fcd2259 100644
--- a/tests/specialization.expected
+++ b/tests/specialization.expected
@@ -1,32 +1,110 @@
-Note: at toplevel:
- (specialization-tests.scm:3) in procedure call to `scheme#string?', the
predicate is called with an argument of type `string' and will always return
true
+Note: Type mismatch.
+ (specialization-tests.scm:3)
+ At toplevel:
+ In predicate call
-Note: at toplevel:
- (specialization-tests.scm:3) expected a value of type boolean in
conditional, but was given a value of type `true' which is always true:
+ (scheme#string? a)
-(if (scheme#string? a) 'ok 'no)
+ Predicate call will always return true.
-Note: at toplevel:
- (specialization-tests.scm:4) in procedure call to `scheme#string?', the
predicate is called with an argument of type `symbol' and will always return
false
+ Procedure `scheme#string?' is a predicate for
-Note: at toplevel:
- (specialization-tests.scm:4) in conditional, test expression will always
return false:
+ string
-(if (scheme#string? a) 'ok 'no)
+ The given argument has type
-Note: at toplevel:
- (specialization-tests.scm:10) in procedure call to `scheme#input-port?', the
predicate is called with an argument of type `input/output-port' and will
always return true
+ string
-Note: at toplevel:
- (specialization-tests.scm:10) expected a value of type boolean in
conditional, but was given a value of type `true' which is always true:
+Note: Type mismatch.
+ (specialization-tests.scm:3)
+ At toplevel:
+ In conditional expression
-(if (scheme#input-port? p) 'ok 'no)
+ (if (scheme#string? a) 'ok 'no)
-Note: at toplevel:
- (specialization-tests.scm:11) in procedure call to `scheme#output-port?',
the predicate is called with an argument of type `input/output-port' and will
always return true
+ Test condition has always true value of type
-Note: at toplevel:
- (specialization-tests.scm:11) expected a value of type boolean in
conditional, but was given a value of type `true' which is always true:
+ true
-(if (scheme#output-port? p) 'ok 'no)
+Note: Type mismatch.
+ (specialization-tests.scm:4)
+ At toplevel:
+ In predicate call
+
+ (scheme#string? a)
+
+ Predicate call will always return false.
+
+ Procedure `scheme#string?' is a predicate for
+
+ string
+
+ The given argument has type
+
+ symbol
+
+Note: Type mismatch.
+ (specialization-tests.scm:4)
+ At toplevel:
+ In conditional expression
+
+ (if (scheme#string? a) 'ok 'no)
+
+ Test condition is always false.
+
+Note: Type mismatch.
+ (specialization-tests.scm:10)
+ At toplevel:
+ In predicate call
+
+ (scheme#input-port? p)
+
+ Predicate call will always return true.
+
+ Procedure `scheme#input-port?' is a predicate for
+
+ input-port
+
+ The given argument has type
+
+ input/output-port
+
+Note: Type mismatch.
+ (specialization-tests.scm:10)
+ At toplevel:
+ In conditional expression
+
+ (if (scheme#input-port? p) 'ok 'no)
+
+ Test condition has always true value of type
+
+ true
+
+Note: Type mismatch.
+ (specialization-tests.scm:11)
+ At toplevel:
+ In predicate call
+
+ (scheme#output-port? p)
+
+ Predicate call will always return true.
+
+ Procedure `scheme#output-port?' is a predicate for
+
+ output-port
+
+ The given argument has type
+
+ input/output-port
+
+Note: Type mismatch.
+ (specialization-tests.scm:11)
+ At toplevel:
+ In conditional expression
+
+ (if (scheme#output-port? p) 'ok 'no)
+
+ Test condition has always true value of type
+
+ true
--
2.7.4
>From 19d2bc137e18f430b2d73a59380b3ddd85612019 Mon Sep 17 00:00:00 2001
From: megane <address@hidden>
Date: Mon, 19 Nov 2018 11:55:01 +0200
Subject: [PATCH 6/9] * scrutinizer.scm: Print procedure name and its module
separately in messages
* scrutinizer.scm (variable-from-module) : New function
---
scrutinizer.scm | 30 +++---
tests/scrutinizer-message-format.expected | 42 ++++-----
tests/scrutiny-2.expected | 88 +++++++++---------
tests/scrutiny.expected | 148 +++++++++++++++---------------
tests/specialization.expected | 16 ++--
tests/test-scrutinizer-message-format.scm | 2 +-
6 files changed, 167 insertions(+), 159 deletions(-)
diff --git a/scrutinizer.scm b/scrutinizer.scm
index 43a37a8..578b01e 100644
--- a/scrutinizer.scm
+++ b/scrutinizer.scm
@@ -2474,6 +2474,12 @@
(rec (cdr loc)
(cons (sprintf "In `~a', a local procedure" (lname (car
loc))) msgs)))))))
+(define (variable-from-module sym)
+ (let ((r (string-split (symbol->string sym) "#" #t)))
+ (if (= (length r) 2)
+ (sprintf "`~a', imported from `~a'," (second r) (first r))
+ (sprintf "`~a'" sym))))
+
(define (report2 report-f location-node-candidates loc msg . args)
(define (file-location)
(any (lambda (n) (and (not (string=? "" (node-source-prefix n)))
@@ -2527,13 +2533,14 @@
"~%~%"
"Procedure `~a' is called with ~a argument~a but ~a argument~a is
expected."
"~%~%"
- "The procedure's type is"
+ "Procedure ~a has this type"
"~%~%"
"~a")
(pp-fragment node " ")
- pname
+ (strip-namespace pname)
argc (multiples argc)
exp-count (multiples exp-count)
+ (variable-from-module pname)
(type->pp-string ptype)))
(define (r-proc-call-argument-type-mismatch loc node pname i xptype atype
ptype)
@@ -2554,14 +2561,15 @@
"~%~%"
"~a"
"~%~%"
- "The procedure's type is"
+ "Procedure ~a has this type"
"~%~%"
"~a")
(pp-fragment node " ")
i
- pname
+ (strip-namespace pname)
(type->pp-string atype)
(type->pp-string xptype)
+ (variable-from-module pname)
(type->pp-string ptype)))
(define (r-pred-call-always-true loc node pname pred-type atype)
@@ -2576,15 +2584,15 @@
"~%~%"
"Predicate call will always return true."
"~%~%"
- "Procedure `~a' is a predicate for"
+ "Procedure ~a is a predicate for"
"~%~%"
"~a"
"~%~%"
- "The given argument has type"
+ "The given argument has this type"
"~%~%"
"~a")
(pp-fragment node " ")
- pname
+ (variable-from-module pname)
(type->pp-string pred-type)
(type->pp-string atype)))
@@ -2599,15 +2607,15 @@
"~%~%"
"Predicate call will always return false."
"~%~%"
- "Procedure `~a' is a predicate for"
+ "Procedure ~a is a predicate for"
"~%~%"
"~a"
"~%~%"
- "The given argument has type"
+ "The given argument has this type"
"~%~%"
"~a")
(pp-fragment node " ")
- pname
+ (variable-from-module pname)
(type->pp-string pred-type)
(type->pp-string atype)))
@@ -2762,7 +2770,7 @@
"~%~%"
"Variable `~a' is assigned invalid value."
"~%~%"
- "The assigned value has type"
+ "The assigned value has this type"
"~%~%"
"~a"
"~%~%"
diff --git a/tests/scrutinizer-message-format.expected
b/tests/scrutinizer-message-format.expected
index 6b00490..e298366 100644
--- a/tests/scrutinizer-message-format.expected
+++ b/tests/scrutinizer-message-format.expected
@@ -10,9 +10,9 @@ Warning: Type mismatch.
(scheme#cons '())
- Procedure `scheme#cons' is called with 1 argument but 2 arguments is
expected.
+ Procedure `cons' is called with 1 argument but 2 arguments is expected.
- The procedure's type is
+ Procedure `cons', imported from `scheme', has this type
(forall (a b) (procedure scheme#cons (a b) (pair a b)))
@@ -23,7 +23,7 @@ Warning: Type mismatch.
(scheme#length 'symbol)
- Argument #1 to procedure `scheme#length' has invalid type
+ Argument #1 to procedure `length' has invalid type
symbol
@@ -31,7 +31,7 @@ Warning: Type mismatch.
list
- The procedure's type is
+ Procedure `length', imported from `scheme', has this type
(procedure scheme#length (list) fixnum)
@@ -49,7 +49,7 @@ Warning: Type mismatch.
In `r-cond-branch-value-count-mismatch', a toplevel procedure
In conditional expression
- (if (the * 1) 1 (scheme#values 1 2))
+ (if (the * 1) 1 (chicken.time#cpu-time))
The branches have different number of returned values.
@@ -59,7 +59,7 @@ Warning: Type mismatch.
The false branch returns 2 values
- (scheme#values 1 2)
+ (chicken.time#cpu-time)
Warning: Type mismatch.
In `r-invalid-called-procedure-type', a toplevel procedure
@@ -84,11 +84,11 @@ Note: Type mismatch.
Predicate call will always return true.
- Procedure `scheme#list?' is a predicate for
+ Procedure `list?', imported from `scheme', is a predicate for
list
- The given argument has type
+ The given argument has this type
null
@@ -101,11 +101,11 @@ Note: Type mismatch.
Predicate call will always return false.
- Procedure `scheme#symbol?' is a predicate for
+ Procedure `symbol?', imported from `scheme', is a predicate for
symbol
- The given argument has type
+ The given argument has this type
fixnum
@@ -192,7 +192,7 @@ Warning: Type mismatch.
Variable `foo' is assigned invalid value.
- The assigned value has type
+ The assigned value has this type
fixnum
@@ -214,7 +214,7 @@ Warning: Type mismatch.
Variable `foo' is assigned invalid value.
- The assigned value has type
+ The assigned value has this type
fixnum
@@ -263,9 +263,9 @@ Warning: Type mismatch.
(scheme#cons '())
- Procedure `scheme#cons' is called with 1 argument but 2 arguments is
expected.
+ Procedure `cons' is called with 1 argument but 2 arguments is expected.
- The procedure's type is
+ Procedure `cons', imported from `scheme', has this type
(forall (a b) (procedure scheme#cons (a b) (pair a b)))
@@ -278,7 +278,7 @@ Warning: Type mismatch.
(scheme#length 'symbol)
- Argument #1 to procedure `scheme#length' has invalid type
+ Argument #1 to procedure `length' has invalid type
symbol
@@ -286,7 +286,7 @@ Warning: Type mismatch.
list
- The procedure's type is
+ Procedure `length', imported from `scheme', has this type
(procedure scheme#length (list) fixnum)
@@ -351,11 +351,11 @@ Note: Type mismatch.
Predicate call will always return true.
- Procedure `scheme#list?' is a predicate for
+ Procedure `list?', imported from `scheme', is a predicate for
list
- The given argument has type
+ The given argument has this type
null
@@ -370,11 +370,11 @@ Note: Type mismatch.
Predicate call will always return false.
- Procedure `scheme#symbol?' is a predicate for
+ Procedure `symbol?', imported from `scheme', is a predicate for
symbol
- The given argument has type
+ The given argument has this type
fixnum
@@ -476,7 +476,7 @@ Warning: Type mismatch.
Variable `m#foo2' is assigned invalid value.
- The assigned value has type
+ The assigned value has this type
fixnum
diff --git a/tests/scrutiny-2.expected b/tests/scrutiny-2.expected
index 9d5e7fd..c4903cd 100644
--- a/tests/scrutiny-2.expected
+++ b/tests/scrutiny-2.expected
@@ -8,11 +8,11 @@ Note: Type mismatch.
Predicate call will always return true.
- Procedure `scheme#pair?' is a predicate for
+ Procedure `pair?', imported from `scheme', is a predicate for
pair
- The given argument has type
+ The given argument has this type
pair
@@ -25,11 +25,11 @@ Note: Type mismatch.
Predicate call will always return false.
- Procedure `scheme#pair?' is a predicate for
+ Procedure `pair?', imported from `scheme', is a predicate for
pair
- The given argument has type
+ The given argument has this type
null
@@ -42,11 +42,11 @@ Note: Type mismatch.
Predicate call will always return false.
- Procedure `scheme#pair?' is a predicate for
+ Procedure `pair?', imported from `scheme', is a predicate for
pair
- The given argument has type
+ The given argument has this type
null
@@ -59,11 +59,11 @@ Note: Type mismatch.
Predicate call will always return false.
- Procedure `scheme#pair?' is a predicate for
+ Procedure `pair?', imported from `scheme', is a predicate for
pair
- The given argument has type
+ The given argument has this type
fixnum
@@ -76,11 +76,11 @@ Note: Type mismatch.
Predicate call will always return false.
- Procedure `scheme#pair?' is a predicate for
+ Procedure `pair?', imported from `scheme', is a predicate for
pair
- The given argument has type
+ The given argument has this type
float
@@ -93,11 +93,11 @@ Note: Type mismatch.
Predicate call will always return true.
- Procedure `scheme#list?' is a predicate for
+ Procedure `list?', imported from `scheme', is a predicate for
list
- The given argument has type
+ The given argument has this type
null
@@ -110,11 +110,11 @@ Note: Type mismatch.
Predicate call will always return true.
- Procedure `scheme#list?' is a predicate for
+ Procedure `list?', imported from `scheme', is a predicate for
list
- The given argument has type
+ The given argument has this type
null
@@ -127,11 +127,11 @@ Note: Type mismatch.
Predicate call will always return false.
- Procedure `scheme#list?' is a predicate for
+ Procedure `list?', imported from `scheme', is a predicate for
list
- The given argument has type
+ The given argument has this type
fixnum
@@ -144,11 +144,11 @@ Note: Type mismatch.
Predicate call will always return false.
- Procedure `scheme#list?' is a predicate for
+ Procedure `list?', imported from `scheme', is a predicate for
list
- The given argument has type
+ The given argument has this type
float
@@ -161,11 +161,11 @@ Note: Type mismatch.
Predicate call will always return true.
- Procedure `scheme#null?' is a predicate for
+ Procedure `null?', imported from `scheme', is a predicate for
null
- The given argument has type
+ The given argument has this type
null
@@ -178,11 +178,11 @@ Note: Type mismatch.
Predicate call will always return true.
- Procedure `scheme#null?' is a predicate for
+ Procedure `null?', imported from `scheme', is a predicate for
null
- The given argument has type
+ The given argument has this type
null
@@ -195,11 +195,11 @@ Note: Type mismatch.
Predicate call will always return false.
- Procedure `scheme#null?' is a predicate for
+ Procedure `null?', imported from `scheme', is a predicate for
null
- The given argument has type
+ The given argument has this type
pair
@@ -212,11 +212,11 @@ Note: Type mismatch.
Predicate call will always return false.
- Procedure `scheme#null?' is a predicate for
+ Procedure `null?', imported from `scheme', is a predicate for
null
- The given argument has type
+ The given argument has this type
fixnum
@@ -229,11 +229,11 @@ Note: Type mismatch.
Predicate call will always return false.
- Procedure `scheme#null?' is a predicate for
+ Procedure `null?', imported from `scheme', is a predicate for
null
- The given argument has type
+ The given argument has this type
float
@@ -246,11 +246,11 @@ Note: Type mismatch.
Predicate call will always return true.
- Procedure `chicken.base#fixnum?' is a predicate for
+ Procedure `fixnum?', imported from `chicken.base', is a predicate for
fixnum
- The given argument has type
+ The given argument has this type
fixnum
@@ -263,11 +263,11 @@ Note: Type mismatch.
Predicate call will always return false.
- Procedure `chicken.base#fixnum?' is a predicate for
+ Procedure `fixnum?', imported from `chicken.base', is a predicate for
fixnum
- The given argument has type
+ The given argument has this type
float
@@ -280,11 +280,11 @@ Note: Type mismatch.
Predicate call will always return true.
- Procedure `chicken.base#flonum?' is a predicate for
+ Procedure `flonum?', imported from `chicken.base', is a predicate for
float
- The given argument has type
+ The given argument has this type
float
@@ -297,11 +297,11 @@ Note: Type mismatch.
Predicate call will always return false.
- Procedure `chicken.base#flonum?' is a predicate for
+ Procedure `flonum?', imported from `chicken.base', is a predicate for
float
- The given argument has type
+ The given argument has this type
fixnum
@@ -314,11 +314,11 @@ Note: Type mismatch.
Predicate call will always return true.
- Procedure `scheme#number?' is a predicate for
+ Procedure `number?', imported from `scheme', is a predicate for
number
- The given argument has type
+ The given argument has this type
fixnum
@@ -331,11 +331,11 @@ Note: Type mismatch.
Predicate call will always return true.
- Procedure `scheme#number?' is a predicate for
+ Procedure `number?', imported from `scheme', is a predicate for
number
- The given argument has type
+ The given argument has this type
float
@@ -348,11 +348,11 @@ Note: Type mismatch.
Predicate call will always return true.
- Procedure `scheme#number?' is a predicate for
+ Procedure `number?', imported from `scheme', is a predicate for
number
- The given argument has type
+ The given argument has this type
number
@@ -365,10 +365,10 @@ Note: Type mismatch.
Predicate call will always return false.
- Procedure `scheme#number?' is a predicate for
+ Procedure `number?', imported from `scheme', is a predicate for
number
- The given argument has type
+ The given argument has this type
null
diff --git a/tests/scrutiny.expected b/tests/scrutiny.expected
index 4cf59e6..3aa09f4 100644
--- a/tests/scrutiny.expected
+++ b/tests/scrutiny.expected
@@ -55,7 +55,7 @@ Warning: Type mismatch.
number
- The procedure's type is
+ Procedure `bar' has this type
(procedure scheme#+ (#!rest number) number)
@@ -66,9 +66,9 @@ Warning: Type mismatch.
(scheme#string?)
- Procedure `scheme#string?' is called with 0 arguments but 1 argument is
expected.
+ Procedure `string?' is called with 0 arguments but 1 argument is expected.
- The procedure's type is
+ Procedure `string?', imported from `scheme', has this type
(procedure scheme#string? (*) boolean)
@@ -100,7 +100,7 @@ Warning: Type mismatch.
(scheme#+ 'a 'b)
- Argument #1 to procedure `scheme#+' has invalid type
+ Argument #1 to procedure `+' has invalid type
symbol
@@ -108,7 +108,7 @@ Warning: Type mismatch.
number
- The procedure's type is
+ Procedure `+', imported from `scheme', has this type
(procedure scheme#+ (#!rest number) number)
@@ -119,7 +119,7 @@ Warning: Type mismatch.
(scheme#+ 'a 'b)
- Argument #2 to procedure `scheme#+' has invalid type
+ Argument #2 to procedure `+' has invalid type
symbol
@@ -127,7 +127,7 @@ Warning: Type mismatch.
number
- The procedure's type is
+ Procedure `+', imported from `scheme', has this type
(procedure scheme#+ (#!rest number) number)
@@ -139,7 +139,7 @@ Warning: Type mismatch.
Variable `scheme#car' is assigned invalid value.
- The assigned value has type
+ The assigned value has this type
fixnum
@@ -181,7 +181,7 @@ Warning: Type mismatch.
(scheme#string-append x "abc")
- Argument #1 to procedure `scheme#string-append' has invalid type
+ Argument #1 to procedure `string-append' has invalid type
number
@@ -189,7 +189,7 @@ Warning: Type mismatch.
string
- The procedure's type is
+ Procedure `string-append', imported from `scheme', has this type
(procedure scheme#string-append (#!rest string) string)
@@ -208,7 +208,7 @@ Warning: Type mismatch.
string
- The procedure's type is
+ Procedure `foo3' has this type
(procedure foo3 (string) string)
@@ -219,7 +219,7 @@ Warning: Type mismatch.
(scheme#+ x 1)
- Argument #1 to procedure `scheme#+' has invalid type
+ Argument #1 to procedure `+' has invalid type
string
@@ -227,7 +227,7 @@ Warning: Type mismatch.
number
- The procedure's type is
+ Procedure `+', imported from `scheme', has this type
(procedure scheme#+ (#!rest number) number)
@@ -238,7 +238,7 @@ Warning: Type mismatch.
(scheme#+ x 3)
- Argument #1 to procedure `scheme#+' has invalid type
+ Argument #1 to procedure `+' has invalid type
string
@@ -246,7 +246,7 @@ Warning: Type mismatch.
number
- The procedure's type is
+ Procedure `+', imported from `scheme', has this type
(procedure scheme#+ (#!rest number) number)
@@ -257,7 +257,7 @@ Warning: Type mismatch.
(scheme#+ x 3)
- Argument #1 to procedure `scheme#+' has invalid type
+ Argument #1 to procedure `+' has invalid type
string
@@ -265,7 +265,7 @@ Warning: Type mismatch.
number
- The procedure's type is
+ Procedure `+', imported from `scheme', has this type
(procedure scheme#+ (#!rest number) number)
@@ -276,7 +276,7 @@ Warning: Type mismatch.
(scheme#+ x 1)
- Argument #1 to procedure `scheme#+' has invalid type
+ Argument #1 to procedure `+' has invalid type
string
@@ -284,7 +284,7 @@ Warning: Type mismatch.
number
- The procedure's type is
+ Procedure `+', imported from `scheme', has this type
(procedure scheme#+ (#!rest number) number)
@@ -303,7 +303,7 @@ Warning: Type mismatch.
string
- The procedure's type is
+ Procedure `foo9' has this type
(procedure foo9 (string) symbol)
@@ -314,7 +314,7 @@ Warning: Type mismatch.
(scheme#+ x 1)
- Argument #1 to procedure `scheme#+' has invalid type
+ Argument #1 to procedure `+' has invalid type
string
@@ -322,7 +322,7 @@ Warning: Type mismatch.
number
- The procedure's type is
+ Procedure `+', imported from `scheme', has this type
(procedure scheme#+ (#!rest number) number)
@@ -350,7 +350,7 @@ Warning: Type mismatch.
(scheme#string-append (the pair (scheme#substring x 0 10)))
- Argument #1 to procedure `scheme#string-append' has invalid type
+ Argument #1 to procedure `string-append' has invalid type
pair
@@ -358,7 +358,7 @@ Warning: Type mismatch.
string
- The procedure's type is
+ Procedure `string-append', imported from `scheme', has this type
(procedure scheme#string-append (#!rest string) string)
@@ -393,7 +393,7 @@ Warning: Type mismatch.
(scheme#* x y)
- Argument #1 to procedure `scheme#*' has invalid type
+ Argument #1 to procedure `*' has invalid type
string
@@ -401,7 +401,7 @@ Warning: Type mismatch.
number
- The procedure's type is
+ Procedure `*', imported from `scheme', has this type
(procedure scheme#* (#!rest number) number)
@@ -412,7 +412,7 @@ Warning: Type mismatch.
(scheme#+ 1 'x)
- Argument #2 to procedure `scheme#+' has invalid type
+ Argument #2 to procedure `+' has invalid type
symbol
@@ -420,7 +420,7 @@ Warning: Type mismatch.
number
- The procedure's type is
+ Procedure `+', imported from `scheme', has this type
(procedure scheme#+ (#!rest number) number)
@@ -445,7 +445,7 @@ Warning: Type mismatch.
(list-of number)
- The procedure's type is
+ Procedure `apply1' has this type
(forall (a b) (procedure apply1 ((procedure (#!rest a) b) (list-of a)) b))
@@ -464,7 +464,7 @@ Warning: Type mismatch.
(list-of number)
- The procedure's type is
+ Procedure `apply1' has this type
(forall (a b) (procedure apply1 ((procedure (#!rest a) b) (list-of a)) b))
@@ -477,11 +477,11 @@ Note: Type mismatch.
Predicate call will always return true.
- Procedure `chicken.base#fixnum?' is a predicate for
+ Procedure `fixnum?', imported from `chicken.base', is a predicate for
fixnum
- The given argument has type
+ The given argument has this type
fixnum
@@ -494,11 +494,11 @@ Note: Type mismatch.
Predicate call will always return false.
- Procedure `scheme#symbol?' is a predicate for
+ Procedure `symbol?', imported from `scheme', is a predicate for
symbol
- The given argument has type
+ The given argument has this type
(or char string)
@@ -511,11 +511,11 @@ Note: Type mismatch.
Predicate call will always return false.
- Procedure `scheme#string?' is a predicate for
+ Procedure `string?', imported from `scheme', is a predicate for
string
- The given argument has type
+ The given argument has this type
(not (or char string))
@@ -532,7 +532,7 @@ Note: Type mismatch.
(or char string)
- The given argument has type
+ The given argument has this type
fixnum
@@ -545,11 +545,11 @@ Note: Type mismatch.
Predicate call will always return false.
- Procedure `scheme#symbol?' is a predicate for
+ Procedure `symbol?', imported from `scheme', is a predicate for
symbol
- The given argument has type
+ The given argument has this type
(or char string)
@@ -562,11 +562,11 @@ Note: Type mismatch.
Predicate call will always return false.
- Procedure `scheme#string?' is a predicate for
+ Procedure `string?', imported from `scheme', is a predicate for
string
- The given argument has type
+ The given argument has this type
fixnum
@@ -579,11 +579,11 @@ Note: Type mismatch.
Predicate call will always return false.
- Procedure `scheme#symbol?' is a predicate for
+ Procedure `symbol?', imported from `scheme', is a predicate for
symbol
- The given argument has type
+ The given argument has this type
char
@@ -596,11 +596,11 @@ Note: Type mismatch.
Predicate call will always return false.
- Procedure `scheme#string?' is a predicate for
+ Procedure `string?', imported from `scheme', is a predicate for
string
- The given argument has type
+ The given argument has this type
symbol
@@ -613,11 +613,11 @@ Note: Type mismatch.
Predicate call will always return false.
- Procedure `scheme#symbol?' is a predicate for
+ Procedure `symbol?', imported from `scheme', is a predicate for
symbol
- The given argument has type
+ The given argument has this type
(or char string)
@@ -630,11 +630,11 @@ Note: Type mismatch.
Predicate call will always return false.
- Procedure `scheme#string?' is a predicate for
+ Procedure `string?', imported from `scheme', is a predicate for
string
- The given argument has type
+ The given argument has this type
symbol
@@ -653,7 +653,7 @@ Warning: Type mismatch.
pair
- The procedure's type is
+ Procedure `f' has this type
(procedure (pair) *)
@@ -672,7 +672,7 @@ Warning: Type mismatch.
null
- The procedure's type is
+ Procedure `f' has this type
(procedure (null) *)
@@ -691,7 +691,7 @@ Warning: Type mismatch.
list
- The procedure's type is
+ Procedure `f' has this type
(procedure (list) *)
@@ -711,7 +711,7 @@ Warning: Type mismatch.
(scheme#vector-ref v1 'bad)
- Argument #2 to procedure `scheme#vector-ref' has invalid type
+ Argument #2 to procedure `vector-ref' has invalid type
symbol
@@ -719,7 +719,7 @@ Warning: Type mismatch.
fixnum
- The procedure's type is
+ Procedure `vector-ref', imported from `scheme', has this type
(forall (a) (procedure scheme#vector-ref ((vector-of a) fixnum) a))
@@ -739,7 +739,7 @@ Warning: Type mismatch.
(scheme#vector-set! v1 'bad 'whatever)
- Argument #2 to procedure `scheme#vector-set!' has invalid type
+ Argument #2 to procedure `vector-set!' has invalid type
symbol
@@ -747,7 +747,7 @@ Warning: Type mismatch.
fixnum
- The procedure's type is
+ Procedure `vector-set!', imported from `scheme', has this type
(procedure scheme#vector-set! (vector fixnum *) undefined)
@@ -773,7 +773,7 @@ Warning: Type mismatch.
(scheme#list-ref l1 'bad)
- Argument #2 to procedure `scheme#list-ref' has invalid type
+ Argument #2 to procedure `list-ref' has invalid type
symbol
@@ -781,7 +781,7 @@ Warning: Type mismatch.
fixnum
- The procedure's type is
+ Procedure `list-ref', imported from `scheme', has this type
(forall (a) (procedure scheme#list-ref ((list-of a) fixnum) a))
@@ -792,7 +792,7 @@ Warning: Type mismatch.
(scheme#list-ref l1 'bad)
- Argument #2 to procedure `scheme#list-ref' has invalid type
+ Argument #2 to procedure `list-ref' has invalid type
symbol
@@ -800,7 +800,7 @@ Warning: Type mismatch.
fixnum
- The procedure's type is
+ Procedure `list-ref', imported from `scheme', has this type
(forall (a) (procedure scheme#list-ref ((list-of a) fixnum) a))
@@ -811,7 +811,7 @@ Warning: Type mismatch.
(scheme#list-ref l2 'bad)
- Argument #2 to procedure `scheme#list-ref' has invalid type
+ Argument #2 to procedure `list-ref' has invalid type
symbol
@@ -819,7 +819,7 @@ Warning: Type mismatch.
fixnum
- The procedure's type is
+ Procedure `list-ref', imported from `scheme', has this type
(forall (a) (procedure scheme#list-ref ((list-of a) fixnum) a))
@@ -830,7 +830,7 @@ Warning: Type mismatch.
(scheme#list-ref l2 'bad)
- Argument #2 to procedure `scheme#list-ref' has invalid type
+ Argument #2 to procedure `list-ref' has invalid type
symbol
@@ -838,7 +838,7 @@ Warning: Type mismatch.
fixnum
- The procedure's type is
+ Procedure `list-ref', imported from `scheme', has this type
(forall (a) (procedure scheme#list-ref ((list-of a) fixnum) a))
@@ -849,7 +849,7 @@ Warning: Type mismatch.
(chicken.base#add1 (scheme#list-ref l1 1))
- Argument #1 to procedure `chicken.base#add1' has invalid type
+ Argument #1 to procedure `add1' has invalid type
symbol
@@ -857,7 +857,7 @@ Warning: Type mismatch.
number
- The procedure's type is
+ Procedure `add1', imported from `chicken.base', has this type
(procedure chicken.base#add1 (number) number)
@@ -868,7 +868,7 @@ Warning: Type mismatch.
(chicken.base#add1 (scheme#list-ref l2 1))
- Argument #1 to procedure `chicken.base#add1' has invalid type
+ Argument #1 to procedure `add1' has invalid type
symbol
@@ -876,7 +876,7 @@ Warning: Type mismatch.
number
- The procedure's type is
+ Procedure `add1', imported from `chicken.base', has this type
(procedure chicken.base#add1 (number) number)
@@ -887,7 +887,7 @@ Warning: Type mismatch.
(chicken.base#add1 (scheme#list-ref l3 1))
- Argument #1 to procedure `chicken.base#add1' has invalid type
+ Argument #1 to procedure `add1' has invalid type
symbol
@@ -895,7 +895,7 @@ Warning: Type mismatch.
number
- The procedure's type is
+ Procedure `add1', imported from `chicken.base', has this type
(procedure chicken.base#add1 (number) number)
@@ -906,7 +906,7 @@ Warning: Type mismatch.
(chicken.base#add1 (scheme#list-ref l1 1))
- Argument #1 to procedure `chicken.base#add1' has invalid type
+ Argument #1 to procedure `add1' has invalid type
symbol
@@ -914,7 +914,7 @@ Warning: Type mismatch.
number
- The procedure's type is
+ Procedure `add1', imported from `chicken.base', has this type
(procedure chicken.base#add1 (number) number)
@@ -925,7 +925,7 @@ Warning: Type mismatch.
(chicken.base#add1 (scheme#list-ref l3 3))
- Argument #1 to procedure `chicken.base#add1' has invalid type
+ Argument #1 to procedure `add1' has invalid type
symbol
@@ -933,7 +933,7 @@ Warning: Type mismatch.
number
- The procedure's type is
+ Procedure `add1', imported from `chicken.base', has this type
(procedure chicken.base#add1 (number) number)
diff --git a/tests/specialization.expected b/tests/specialization.expected
index fcd2259..c56611f 100644
--- a/tests/specialization.expected
+++ b/tests/specialization.expected
@@ -8,11 +8,11 @@ Note: Type mismatch.
Predicate call will always return true.
- Procedure `scheme#string?' is a predicate for
+ Procedure `string?', imported from `scheme', is a predicate for
string
- The given argument has type
+ The given argument has this type
string
@@ -36,11 +36,11 @@ Note: Type mismatch.
Predicate call will always return false.
- Procedure `scheme#string?' is a predicate for
+ Procedure `string?', imported from `scheme', is a predicate for
string
- The given argument has type
+ The given argument has this type
symbol
@@ -62,11 +62,11 @@ Note: Type mismatch.
Predicate call will always return true.
- Procedure `scheme#input-port?' is a predicate for
+ Procedure `input-port?', imported from `scheme', is a predicate for
input-port
- The given argument has type
+ The given argument has this type
input/output-port
@@ -90,11 +90,11 @@ Note: Type mismatch.
Predicate call will always return true.
- Procedure `scheme#output-port?' is a predicate for
+ Procedure `output-port?', imported from `scheme', is a predicate for
output-port
- The given argument has type
+ The given argument has this type
input/output-port
diff --git a/tests/test-scrutinizer-message-format.scm
b/tests/test-scrutinizer-message-format.scm
index d792cf3..0c45194 100644
--- a/tests/test-scrutinizer-message-format.scm
+++ b/tests/test-scrutinizer-message-format.scm
@@ -9,7 +9,7 @@
(define (r-proc-call-argument-count-mismatch) (cons '()))
(define (r-proc-call-argument-type-mismatch) (length 'symbol))
(define (r-proc-call-argument-value-count) (list (cpu-time)) (vector (values))
((values)))
-(define (r-cond-branch-value-count-mismatch) (if (the * 1) 1 (values 1 2)))
+(define (r-cond-branch-value-count-mismatch) (if (the * 1) 1 (cpu-time)))
(define (r-invalid-called-procedure-type) (1 2))
(define (r-pred-call-always-true) (list? '()))
(define (r-pred-call-always-false) (symbol? 1))
--
2.7.4
>From 5e6e363f83ce9a88cac7121d42246c87150782a6 Mon Sep 17 00:00:00 2001
From: megane <address@hidden>
Date: Mon, 19 Nov 2018 13:11:09 +0200
Subject: [PATCH 7/9] * scrutinizer.scm: Pretty print procedure types with
"->"s and "'"s
* scrutinizer.scm (type->pp-string): Do the thing
+ Update *.expected files
---
scrutinizer.scm | 62 ++++++++++++++++++++++------
tests/runtests.sh | 2 +-
tests/scrutinizer-message-format.expected | 20 ++++++---
tests/scrutiny.expected | 68 +++++++++++++++----------------
4 files changed, 99 insertions(+), 53 deletions(-)
diff --git a/scrutinizer.scm b/scrutinizer.scm
index 578b01e..496ab52 100644
--- a/scrutinizer.scm
+++ b/scrutinizer.scm
@@ -2422,16 +2422,54 @@
(string-append s "\n")
s)))
-(define (type->pp-string t)
- (string-add-indent
- (string-chomp
- (with-output-to-string
- (lambda ()
- (let ((t (strip-syntax t)))
- (if (refinement-type? t)
- (printf "~a-~a" (string-intersperse (map conc (second t)) "/")
(third t))
- (pp t))))))
- " "))
+(define (type->pp-string t #!optional (proc-name? #t) (bomb? #t))
+ (define (pr t)
+ (string-add-indent
+ (string-chomp
+ (with-output-to-string
+ (lambda ()
+ (pp t))))
+ " "))
+
+ (define (conv t #!optional (tv-replacements '()))
+ (define (R t) (conv t tv-replacements))
+ (cond
+ ((not (pair? t))
+ (or (alist-ref t tv-replacements eq?)
+ (alist-ref t '((#!rest . &rest) (#!key . &key) (#!optional .
&optional)) eq?)
+ t))
+ ((refinement-type? t)
+ (string->symbol
+ (sprintf "~a-~a" (string-intersperse (map conc (second t)) "/") (third
t))))
+ (else
+ (let ((tcar (and (pair? t) (car t))))
+ (cond
+ ((and (eq? 'forall tcar) (every symbol? (second t))) ;; no constraints
+ (let ((tvs (map (lambda (tv) (cons tv (list 'quote tv))) (second t))))
+ (conv (third t) tvs)))
+ ((eq? 'forall tcar) t) ; forall with constraints, do nothing
+ ((memq tcar '(or not list vector pair list-of vector-of))
+ `(,tcar ,@(map R (cdr t))))
+ ((eq? 'struct tcar) t)
+ ((eq? 'procedure tcar)
+ (let ((args (map R (procedure-arguments t)))
+ (res (let ((res (procedure-results t)))
+ (if (eq? '* res)
+ #f
+ (map R res)))))
+ (if (or (and proc-name? (procedure-name t))
+ ;; '. *' return type not supported by ->
+ (not res))
+ `(procedure ,@(if (procedure-name t) (list (procedure-name t))
'())
+ ,args
+ ,@(or res '*))
+ `(,@args ,(if (and-let* ((pn (procedure-name t))
+ ((variable-mark pn '##compiler#pure))))
+ '--> '->)
+ ,@res))))
+ (bomb? (bomb "type->pp-string: unhandled type" t))
+ (else t))))))
+ (pr (conv (strip-syntax t))))
(define (fragment x)
(let ((x (build-expression-tree (source-node-tree x))))
@@ -2541,7 +2579,7 @@
argc (multiples argc)
exp-count (multiples exp-count)
(variable-from-module pname)
- (type->pp-string ptype)))
+ (type->pp-string ptype #f)))
(define (r-proc-call-argument-type-mismatch loc node pname i xptype atype
ptype)
(report2
@@ -2570,7 +2608,7 @@
(type->pp-string atype)
(type->pp-string xptype)
(variable-from-module pname)
- (type->pp-string ptype)))
+ (type->pp-string ptype #f)))
(define (r-pred-call-always-true loc node pname pred-type atype)
;; pname is "... proc call to predicate `foo' "
diff --git a/tests/runtests.sh b/tests/runtests.sh
index 2f368a7..51c9632 100755
--- a/tests/runtests.sh
+++ b/tests/runtests.sh
@@ -124,7 +124,7 @@ if test \! -f specialization.expected; then
fi
$compile scrutiny-tests-2.scm -A -verbose 2>scrutiny-2.out
-$compile test-scrutinizer-message-format.scm -A -verbose
2>scrutinizer-message-format.out || true
+$compile test-scrutinizer-message-format.scm -A -specialize -verbose
2>scrutinizer-message-format.out || true
diff $DIFF_OPTS scrutinizer-message-format.expected
scrutinizer-message-format.out
diff $DIFF_OPTS scrutiny.expected scrutiny.out
diff --git a/tests/scrutinizer-message-format.expected
b/tests/scrutinizer-message-format.expected
index e298366..0c05a65 100644
--- a/tests/scrutinizer-message-format.expected
+++ b/tests/scrutinizer-message-format.expected
@@ -14,7 +14,7 @@ Warning: Type mismatch.
Procedure `cons', imported from `scheme', has this type
- (forall (a b) (procedure scheme#cons (a b) (pair a b)))
+ ('a 'b --> (pair 'a 'b))
Warning: Type mismatch.
(test-scrutinizer-message-format.scm:10)
@@ -33,7 +33,7 @@ Warning: Type mismatch.
Procedure `length', imported from `scheme', has this type
- (procedure scheme#length (list) fixnum)
+ (list -> fixnum)
Warning: In `r-proc-call-argument-value-count', a toplevel procedure
(test-scrutinizer-message-format.scm:11) expected a single result in
argument #1 of procedure call `(scheme#list (chicken.time#cpu-time))', but
received 2 results
@@ -73,7 +73,7 @@ Warning: Type mismatch.
The expected type is
- (procedure (*) *)
+ (* -> *)
Note: Type mismatch.
(test-scrutinizer-message-format.scm:14)
@@ -254,6 +254,9 @@ Note: Type mismatch.
fixnum
+Warning: In `multiple-values-for-conditional', a toplevel procedure
+ expected a single result in `let' binding of `g265', but received 2 results
+
Warning: Type mismatch.
(test-scrutinizer-message-format.scm:52)
In `m#toplevel-foo', a toplevel procedure
@@ -267,7 +270,7 @@ Warning: Type mismatch.
Procedure `cons', imported from `scheme', has this type
- (forall (a b) (procedure scheme#cons (a b) (pair a b)))
+ ('a 'b --> (pair 'a 'b))
Warning: Type mismatch.
(test-scrutinizer-message-format.scm:53)
@@ -288,7 +291,7 @@ Warning: Type mismatch.
Procedure `length', imported from `scheme', has this type
- (procedure scheme#length (list) fixnum)
+ (list -> fixnum)
Warning: In `m#toplevel-foo', a toplevel procedure
In `local-bar', a local procedure
@@ -338,7 +341,7 @@ Warning: Type mismatch.
The expected type is
- (procedure (*) *)
+ (* -> *)
Note: Type mismatch.
(test-scrutinizer-message-format.scm:57)
@@ -542,6 +545,11 @@ Note: Type mismatch.
fixnum
+Warning: In `m#toplevel-foo', a toplevel procedure
+ In `local-bar', a local procedure
+ In `multiple-values-for-conditional', a local procedure
+ expected a single result in `let' binding of `g276', but received 2 results
+
Error: Type mismatch.
(test-scrutinizer-message-format.scm:76)
In `m#toplevel-foo', a toplevel procedure
diff --git a/tests/scrutiny.expected b/tests/scrutiny.expected
index 3aa09f4..8e984ea 100644
--- a/tests/scrutiny.expected
+++ b/tests/scrutiny.expected
@@ -57,7 +57,7 @@ Warning: Type mismatch.
Procedure `bar' has this type
- (procedure scheme#+ (#!rest number) number)
+ (&rest number -> number)
Warning: Type mismatch.
(scrutiny-tests.scm:21)
@@ -70,7 +70,7 @@ Warning: Type mismatch.
Procedure `string?', imported from `scheme', has this type
- (procedure scheme#string? (*) boolean)
+ (* -> boolean)
Warning: At toplevel:
(scrutiny-tests.scm:23) expected a single result in argument #1 of procedure
call `(chicken.base#print (scheme#values 1 2))', but received 2 results
@@ -91,7 +91,7 @@ Warning: Type mismatch.
The expected type is
- (procedure () *)
+ (-> *)
Warning: Type mismatch.
(scrutiny-tests.scm:29)
@@ -110,7 +110,7 @@ Warning: Type mismatch.
Procedure `+', imported from `scheme', has this type
- (procedure scheme#+ (#!rest number) number)
+ (&rest number -> number)
Warning: Type mismatch.
(scrutiny-tests.scm:29)
@@ -129,7 +129,7 @@ Warning: Type mismatch.
Procedure `+', imported from `scheme', has this type
- (procedure scheme#+ (#!rest number) number)
+ (&rest number -> number)
Warning: Type mismatch.
At toplevel:
@@ -145,7 +145,7 @@ Warning: Type mismatch.
The declared type of `scheme#car' is
- (forall (a) (procedure scheme#car ((pair a *)) a))
+ (procedure scheme#car ((pair 'a *)) 'a)
Warning: At toplevel:
expected a single result in `let' binding of `g19', but received 2 results
@@ -162,7 +162,7 @@ Warning: Type mismatch.
The expected type is
- (procedure () *)
+ (-> *)
Note: Type mismatch.
In `foo', a toplevel procedure
@@ -191,7 +191,7 @@ Warning: Type mismatch.
Procedure `string-append', imported from `scheme', has this type
- (procedure scheme#string-append (#!rest string) string)
+ (&rest string -> string)
Warning: Type mismatch.
(scrutiny-tests.scm:66)
@@ -210,7 +210,7 @@ Warning: Type mismatch.
Procedure `foo3' has this type
- (procedure foo3 (string) string)
+ (string -> string)
Warning: Type mismatch.
(scrutiny-tests.scm:71)
@@ -229,7 +229,7 @@ Warning: Type mismatch.
Procedure `+', imported from `scheme', has this type
- (procedure scheme#+ (#!rest number) number)
+ (&rest number -> number)
Warning: Type mismatch.
(scrutiny-tests.scm:77)
@@ -248,7 +248,7 @@ Warning: Type mismatch.
Procedure `+', imported from `scheme', has this type
- (procedure scheme#+ (#!rest number) number)
+ (&rest number -> number)
Warning: Type mismatch.
(scrutiny-tests.scm:83)
@@ -267,7 +267,7 @@ Warning: Type mismatch.
Procedure `+', imported from `scheme', has this type
- (procedure scheme#+ (#!rest number) number)
+ (&rest number -> number)
Warning: Type mismatch.
(scrutiny-tests.scm:90)
@@ -286,7 +286,7 @@ Warning: Type mismatch.
Procedure `+', imported from `scheme', has this type
- (procedure scheme#+ (#!rest number) number)
+ (&rest number -> number)
Warning: Type mismatch.
(scrutiny-tests.scm:104)
@@ -305,7 +305,7 @@ Warning: Type mismatch.
Procedure `foo9' has this type
- (procedure foo9 (string) symbol)
+ (string -> symbol)
Warning: Type mismatch.
(scrutiny-tests.scm:105)
@@ -324,7 +324,7 @@ Warning: Type mismatch.
Procedure `+', imported from `scheme', has this type
- (procedure scheme#+ (#!rest number) number)
+ (&rest number -> number)
Warning: Type mismatch.
(scrutiny-tests.scm:109)
@@ -360,7 +360,7 @@ Warning: Type mismatch.
Procedure `string-append', imported from `scheme', has this type
- (procedure scheme#string-append (#!rest string) string)
+ (&rest string -> string)
Warning: Type mismatch.
(scrutiny-tests.scm:110)
@@ -403,7 +403,7 @@ Warning: Type mismatch.
Procedure `*', imported from `scheme', has this type
- (procedure scheme#* (#!rest number) number)
+ (&rest number -> number)
Warning: Type mismatch.
(scrutiny-tests.scm:137)
@@ -422,7 +422,7 @@ Warning: Type mismatch.
Procedure `+', imported from `scheme', has this type
- (procedure scheme#+ (#!rest number) number)
+ (&rest number -> number)
Warning: At toplevel:
use of deprecated `deprecated-procedure'
@@ -447,7 +447,7 @@ Warning: Type mismatch.
Procedure `apply1' has this type
- (forall (a b) (procedure apply1 ((procedure (#!rest a) b) (list-of a)) b))
+ ((&rest 'a -> 'b) (list-of 'a) -> 'b)
Warning: Type mismatch.
(scrutiny-tests.scm:169)
@@ -466,7 +466,7 @@ Warning: Type mismatch.
Procedure `apply1' has this type
- (forall (a b) (procedure apply1 ((procedure (#!rest a) b) (list-of a)) b))
+ ((&rest 'a -> 'b) (list-of 'a) -> 'b)
Note: Type mismatch.
(scrutiny-tests.scm:182)
@@ -655,7 +655,7 @@ Warning: Type mismatch.
Procedure `f' has this type
- (procedure (pair) *)
+ (pair -> *)
Warning: Type mismatch.
(scrutiny-tests.scm:212)
@@ -674,7 +674,7 @@ Warning: Type mismatch.
Procedure `f' has this type
- (procedure (null) *)
+ (null -> *)
Warning: Type mismatch.
(scrutiny-tests.scm:214)
@@ -693,7 +693,7 @@ Warning: Type mismatch.
Procedure `f' has this type
- (procedure (list) *)
+ (list -> *)
Warning: In `vector-ref-warn1', a toplevel procedure
(scrutiny-tests.scm:220) in procedure call to `scheme#vector-ref', index -1
out of range for vector of length 3
@@ -721,7 +721,7 @@ Warning: Type mismatch.
Procedure `vector-ref', imported from `scheme', has this type
- (forall (a) (procedure scheme#vector-ref ((vector-of a) fixnum) a))
+ ((vector-of 'a) fixnum -> 'a)
Warning: In `vector-set!-warn1', a toplevel procedure
(scrutiny-tests.scm:227) in procedure call to `scheme#vector-set!', index -1
out of range for vector of length 3
@@ -749,7 +749,7 @@ Warning: Type mismatch.
Procedure `vector-set!', imported from `scheme', has this type
- (procedure scheme#vector-set! (vector fixnum *) undefined)
+ (vector fixnum * -> undefined)
Warning: In `list-ref-warn1', a toplevel procedure
(scrutiny-tests.scm:238) in procedure call to `scheme#list-ref', index -1 is
negative, which is never valid
@@ -783,7 +783,7 @@ Warning: Type mismatch.
Procedure `list-ref', imported from `scheme', has this type
- (forall (a) (procedure scheme#list-ref ((list-of a) fixnum) a))
+ ((list-of 'a) fixnum -> 'a)
Warning: Type mismatch.
(scrutiny-tests.scm:282)
@@ -802,7 +802,7 @@ Warning: Type mismatch.
Procedure `list-ref', imported from `scheme', has this type
- (forall (a) (procedure scheme#list-ref ((list-of a) fixnum) a))
+ ((list-of 'a) fixnum -> 'a)
Warning: Type mismatch.
(scrutiny-tests.scm:284)
@@ -821,7 +821,7 @@ Warning: Type mismatch.
Procedure `list-ref', imported from `scheme', has this type
- (forall (a) (procedure scheme#list-ref ((list-of a) fixnum) a))
+ ((list-of 'a) fixnum -> 'a)
Warning: Type mismatch.
(scrutiny-tests.scm:285)
@@ -840,7 +840,7 @@ Warning: Type mismatch.
Procedure `list-ref', imported from `scheme', has this type
- (forall (a) (procedure scheme#list-ref ((list-of a) fixnum) a))
+ ((list-of 'a) fixnum -> 'a)
Warning: Type mismatch.
(scrutiny-tests.scm:289)
@@ -859,7 +859,7 @@ Warning: Type mismatch.
Procedure `add1', imported from `chicken.base', has this type
- (procedure chicken.base#add1 (number) number)
+ (number -> number)
Warning: Type mismatch.
(scrutiny-tests.scm:291)
@@ -878,7 +878,7 @@ Warning: Type mismatch.
Procedure `add1', imported from `chicken.base', has this type
- (procedure chicken.base#add1 (number) number)
+ (number -> number)
Warning: Type mismatch.
(scrutiny-tests.scm:295)
@@ -897,7 +897,7 @@ Warning: Type mismatch.
Procedure `add1', imported from `chicken.base', has this type
- (procedure chicken.base#add1 (number) number)
+ (number -> number)
Warning: Type mismatch.
(scrutiny-tests.scm:307)
@@ -916,7 +916,7 @@ Warning: Type mismatch.
Procedure `add1', imported from `chicken.base', has this type
- (procedure chicken.base#add1 (number) number)
+ (number -> number)
Warning: Type mismatch.
(scrutiny-tests.scm:312)
@@ -935,6 +935,6 @@ Warning: Type mismatch.
Procedure `add1', imported from `chicken.base', has this type
- (procedure chicken.base#add1 (number) number)
+ (number -> number)
Warning: redefinition of standard binding: scheme#car
--
2.7.4
>From ff860b5e9fdc49bc124e845d3012ef319db3d2b9 Mon Sep 17 00:00:00 2001
From: megane <address@hidden>
Date: Mon, 19 Nov 2018 13:45:43 +0200
Subject: [PATCH 8/9] * scrutinizer.scm: Pretty print deprecation messages
* scrutinizer.scm (r-deprecated-identifier) : New function
+ Update *.expected
---
scrutinizer.scm | 36 +++++++++----
tests/scrutinizer-message-format.expected | 64 +++++++++++++++--------
tests/scrutiny-2.expected | 44 ++++++++--------
tests/scrutiny.expected | 84 ++++++++++++++++++-------------
tests/specialization.expected | 8 +--
5 files changed, 144 insertions(+), 92 deletions(-)
diff --git a/scrutinizer.scm b/scrutinizer.scm
index 496ab52..8582a06 100644
--- a/scrutinizer.scm
+++ b/scrutinizer.scm
@@ -219,18 +219,15 @@
((char? lit) 'char)
(else '*)))
- (define (global-result id loc)
+ (define (global-result id loc node)
(cond ((variable-mark id '##compiler#type) =>
(lambda (a)
(cond
((eq? a 'deprecated)
- (report loc "use of deprecated `~a'" id)
+ (r-deprecated-identifier loc node id)
'(*))
((and (pair? a) (eq? (car a) 'deprecated))
- (report
- loc
- "use of deprecated `~a' - consider `~a'"
- id (cadr a))
+ (r-deprecated-identifier loc node id (cadr a))
'(*))
(else (list a)))))
(else '(*))))
@@ -243,7 +240,7 @@
=> cdr)
(else #f)))
- (define (variable-result id e loc flow)
+ (define (variable-result id e loc node flow)
(cond ((blist-type id flow) => list)
((and (not strict)
(db-get db id 'assigned)
@@ -258,7 +255,7 @@
(real-name id db))
'(*))
(else (list (cdr a))))))
- (else (global-result id loc))))
+ (else (global-result id loc node))))
(define (always-true1 t)
(cond ((pair? t)
@@ -451,7 +448,7 @@
((quote) (list (constant-result (first params))))
((##core#undefined) '(*))
((##core#proc) '(procedure))
- ((##core#variable) (variable-result (first params) e loc flow))
+ ((##core#variable) (variable-result (first params) e loc n
flow))
((##core#inline_ref)
(list (foreign-type->scrutiny-type (second params) 'result)))
((##core#inline_loc_ref)
@@ -2515,7 +2512,7 @@
(define (variable-from-module sym)
(let ((r (string-split (symbol->string sym) "#" #t)))
(if (= (length r) 2)
- (sprintf "`~a', imported from `~a'," (second r) (first r))
+ (sprintf "`~a' from module `~a'" (second r) (first r))
(sprintf "`~a'" sym))))
(define (report2 report-f location-node-candidates loc msg . args)
@@ -2820,4 +2817,23 @@
(type->pp-string atype)
var
(type->pp-string xptype)))
+
+(define (r-deprecated-identifier loc node id #!optional suggestion)
+ (report2
+ warning
+ (list node)
+ loc
+ (string-append
+ "In expression"
+ "~%~%"
+ "~a"
+ "~%~%"
+ "Use of deprecated ~a."
+ "~a")
+ (pp-fragment node " ") ;; TODO: parent node would be nice here
+ (variable-from-module id)
+ (if suggestion
+ (sprintf "~%~%The suggested replacement is ~a."
+ (variable-from-module suggestion))
+ "")))
)
diff --git a/tests/scrutinizer-message-format.expected
b/tests/scrutinizer-message-format.expected
index 0c05a65..4d99457 100644
--- a/tests/scrutinizer-message-format.expected
+++ b/tests/scrutinizer-message-format.expected
@@ -12,7 +12,7 @@ Warning: Type mismatch.
Procedure `cons' is called with 1 argument but 2 arguments is expected.
- Procedure `cons', imported from `scheme', has this type
+ Procedure `cons' from module `scheme' has this type
('a 'b --> (pair 'a 'b))
@@ -31,7 +31,7 @@ Warning: Type mismatch.
list
- Procedure `length', imported from `scheme', has this type
+ Procedure `length' from module `scheme' has this type
(list -> fixnum)
@@ -84,7 +84,7 @@ Note: Type mismatch.
Predicate call will always return true.
- Procedure `list?', imported from `scheme', is a predicate for
+ Procedure `list?' from module `scheme' is a predicate for
list
@@ -101,7 +101,7 @@ Note: Type mismatch.
Predicate call will always return false.
- Procedure `symbol?', imported from `scheme', is a predicate for
+ Procedure `symbol?' from module `scheme' is a predicate for
symbol
@@ -200,11 +200,23 @@ Warning: Type mismatch.
boolean
-Warning: In `r-deprecated-identifier', a toplevel procedure
- use of deprecated `deprecated-foo'
+Warning: Type mismatch.
+ In `r-deprecated-identifier', a toplevel procedure
+ In expression
-Warning: In `r-deprecated-identifier', a toplevel procedure
- use of deprecated `deprecated-foo2' - consider `foo'
+ deprecated-foo
+
+ Use of deprecated `deprecated-foo'.
+
+Warning: Type mismatch.
+ In `r-deprecated-identifier', a toplevel procedure
+ In expression
+
+ deprecated-foo2
+
+ Use of deprecated `deprecated-foo2'.
+
+ The suggested replacement is `foo'.
Warning: Type mismatch.
At toplevel:
@@ -268,7 +280,7 @@ Warning: Type mismatch.
Procedure `cons' is called with 1 argument but 2 arguments is expected.
- Procedure `cons', imported from `scheme', has this type
+ Procedure `cons' from module `scheme' has this type
('a 'b --> (pair 'a 'b))
@@ -289,7 +301,7 @@ Warning: Type mismatch.
list
- Procedure `length', imported from `scheme', has this type
+ Procedure `length' from module `scheme' has this type
(list -> fixnum)
@@ -354,7 +366,7 @@ Note: Type mismatch.
Predicate call will always return true.
- Procedure `list?', imported from `scheme', is a predicate for
+ Procedure `list?' from module `scheme' is a predicate for
list
@@ -373,7 +385,7 @@ Note: Type mismatch.
Predicate call will always return false.
- Procedure `symbol?', imported from `scheme', is a predicate for
+ Procedure `symbol?' from module `scheme' is a predicate for
symbol
@@ -487,15 +499,27 @@ Warning: Type mismatch.
boolean
-Warning: In `m#toplevel-foo', a toplevel procedure
- In `local-bar', a local procedure
- In `r-deprecated-identifier', a local procedure
- use of deprecated `m#deprecated-foo'
+Warning: Type mismatch.
+ In `m#toplevel-foo', a toplevel procedure
+ In `local-bar', a local procedure
+ In `r-deprecated-identifier', a local procedure
+ In expression
-Warning: In `m#toplevel-foo', a toplevel procedure
- In `local-bar', a local procedure
- In `r-deprecated-identifier', a local procedure
- use of deprecated `m#deprecated-foo2' - consider `foo'
+ m#deprecated-foo
+
+ Use of deprecated `deprecated-foo' from module `m'.
+
+Warning: Type mismatch.
+ In `m#toplevel-foo', a toplevel procedure
+ In `local-bar', a local procedure
+ In `r-deprecated-identifier', a local procedure
+ In expression
+
+ m#deprecated-foo2
+
+ Use of deprecated `deprecated-foo2' from module `m'.
+
+ The suggested replacement is `foo'.
Warning: In `m#toplevel-foo', a toplevel procedure
In `local-bar', a local procedure
diff --git a/tests/scrutiny-2.expected b/tests/scrutiny-2.expected
index c4903cd..b994f5e 100644
--- a/tests/scrutiny-2.expected
+++ b/tests/scrutiny-2.expected
@@ -8,7 +8,7 @@ Note: Type mismatch.
Predicate call will always return true.
- Procedure `pair?', imported from `scheme', is a predicate for
+ Procedure `pair?' from module `scheme' is a predicate for
pair
@@ -25,7 +25,7 @@ Note: Type mismatch.
Predicate call will always return false.
- Procedure `pair?', imported from `scheme', is a predicate for
+ Procedure `pair?' from module `scheme' is a predicate for
pair
@@ -42,7 +42,7 @@ Note: Type mismatch.
Predicate call will always return false.
- Procedure `pair?', imported from `scheme', is a predicate for
+ Procedure `pair?' from module `scheme' is a predicate for
pair
@@ -59,7 +59,7 @@ Note: Type mismatch.
Predicate call will always return false.
- Procedure `pair?', imported from `scheme', is a predicate for
+ Procedure `pair?' from module `scheme' is a predicate for
pair
@@ -76,7 +76,7 @@ Note: Type mismatch.
Predicate call will always return false.
- Procedure `pair?', imported from `scheme', is a predicate for
+ Procedure `pair?' from module `scheme' is a predicate for
pair
@@ -93,7 +93,7 @@ Note: Type mismatch.
Predicate call will always return true.
- Procedure `list?', imported from `scheme', is a predicate for
+ Procedure `list?' from module `scheme' is a predicate for
list
@@ -110,7 +110,7 @@ Note: Type mismatch.
Predicate call will always return true.
- Procedure `list?', imported from `scheme', is a predicate for
+ Procedure `list?' from module `scheme' is a predicate for
list
@@ -127,7 +127,7 @@ Note: Type mismatch.
Predicate call will always return false.
- Procedure `list?', imported from `scheme', is a predicate for
+ Procedure `list?' from module `scheme' is a predicate for
list
@@ -144,7 +144,7 @@ Note: Type mismatch.
Predicate call will always return false.
- Procedure `list?', imported from `scheme', is a predicate for
+ Procedure `list?' from module `scheme' is a predicate for
list
@@ -161,7 +161,7 @@ Note: Type mismatch.
Predicate call will always return true.
- Procedure `null?', imported from `scheme', is a predicate for
+ Procedure `null?' from module `scheme' is a predicate for
null
@@ -178,7 +178,7 @@ Note: Type mismatch.
Predicate call will always return true.
- Procedure `null?', imported from `scheme', is a predicate for
+ Procedure `null?' from module `scheme' is a predicate for
null
@@ -195,7 +195,7 @@ Note: Type mismatch.
Predicate call will always return false.
- Procedure `null?', imported from `scheme', is a predicate for
+ Procedure `null?' from module `scheme' is a predicate for
null
@@ -212,7 +212,7 @@ Note: Type mismatch.
Predicate call will always return false.
- Procedure `null?', imported from `scheme', is a predicate for
+ Procedure `null?' from module `scheme' is a predicate for
null
@@ -229,7 +229,7 @@ Note: Type mismatch.
Predicate call will always return false.
- Procedure `null?', imported from `scheme', is a predicate for
+ Procedure `null?' from module `scheme' is a predicate for
null
@@ -246,7 +246,7 @@ Note: Type mismatch.
Predicate call will always return true.
- Procedure `fixnum?', imported from `chicken.base', is a predicate for
+ Procedure `fixnum?' from module `chicken.base' is a predicate for
fixnum
@@ -263,7 +263,7 @@ Note: Type mismatch.
Predicate call will always return false.
- Procedure `fixnum?', imported from `chicken.base', is a predicate for
+ Procedure `fixnum?' from module `chicken.base' is a predicate for
fixnum
@@ -280,7 +280,7 @@ Note: Type mismatch.
Predicate call will always return true.
- Procedure `flonum?', imported from `chicken.base', is a predicate for
+ Procedure `flonum?' from module `chicken.base' is a predicate for
float
@@ -297,7 +297,7 @@ Note: Type mismatch.
Predicate call will always return false.
- Procedure `flonum?', imported from `chicken.base', is a predicate for
+ Procedure `flonum?' from module `chicken.base' is a predicate for
float
@@ -314,7 +314,7 @@ Note: Type mismatch.
Predicate call will always return true.
- Procedure `number?', imported from `scheme', is a predicate for
+ Procedure `number?' from module `scheme' is a predicate for
number
@@ -331,7 +331,7 @@ Note: Type mismatch.
Predicate call will always return true.
- Procedure `number?', imported from `scheme', is a predicate for
+ Procedure `number?' from module `scheme' is a predicate for
number
@@ -348,7 +348,7 @@ Note: Type mismatch.
Predicate call will always return true.
- Procedure `number?', imported from `scheme', is a predicate for
+ Procedure `number?' from module `scheme' is a predicate for
number
@@ -365,7 +365,7 @@ Note: Type mismatch.
Predicate call will always return false.
- Procedure `number?', imported from `scheme', is a predicate for
+ Procedure `number?' from module `scheme' is a predicate for
number
diff --git a/tests/scrutiny.expected b/tests/scrutiny.expected
index 8e984ea..02ea4af 100644
--- a/tests/scrutiny.expected
+++ b/tests/scrutiny.expected
@@ -68,7 +68,7 @@ Warning: Type mismatch.
Procedure `string?' is called with 0 arguments but 1 argument is expected.
- Procedure `string?', imported from `scheme', has this type
+ Procedure `string?' from module `scheme' has this type
(* -> boolean)
@@ -108,7 +108,7 @@ Warning: Type mismatch.
number
- Procedure `+', imported from `scheme', has this type
+ Procedure `+' from module `scheme' has this type
(&rest number -> number)
@@ -127,7 +127,7 @@ Warning: Type mismatch.
number
- Procedure `+', imported from `scheme', has this type
+ Procedure `+' from module `scheme' has this type
(&rest number -> number)
@@ -189,7 +189,7 @@ Warning: Type mismatch.
string
- Procedure `string-append', imported from `scheme', has this type
+ Procedure `string-append' from module `scheme' has this type
(&rest string -> string)
@@ -227,7 +227,7 @@ Warning: Type mismatch.
number
- Procedure `+', imported from `scheme', has this type
+ Procedure `+' from module `scheme' has this type
(&rest number -> number)
@@ -246,7 +246,7 @@ Warning: Type mismatch.
number
- Procedure `+', imported from `scheme', has this type
+ Procedure `+' from module `scheme' has this type
(&rest number -> number)
@@ -265,7 +265,7 @@ Warning: Type mismatch.
number
- Procedure `+', imported from `scheme', has this type
+ Procedure `+' from module `scheme' has this type
(&rest number -> number)
@@ -284,7 +284,7 @@ Warning: Type mismatch.
number
- Procedure `+', imported from `scheme', has this type
+ Procedure `+' from module `scheme' has this type
(&rest number -> number)
@@ -322,7 +322,7 @@ Warning: Type mismatch.
number
- Procedure `+', imported from `scheme', has this type
+ Procedure `+' from module `scheme' has this type
(&rest number -> number)
@@ -358,7 +358,7 @@ Warning: Type mismatch.
string
- Procedure `string-append', imported from `scheme', has this type
+ Procedure `string-append' from module `scheme' has this type
(&rest string -> string)
@@ -401,7 +401,7 @@ Warning: Type mismatch.
number
- Procedure `*', imported from `scheme', has this type
+ Procedure `*' from module `scheme' has this type
(&rest number -> number)
@@ -420,15 +420,27 @@ Warning: Type mismatch.
number
- Procedure `+', imported from `scheme', has this type
+ Procedure `+' from module `scheme' has this type
(&rest number -> number)
-Warning: At toplevel:
- use of deprecated `deprecated-procedure'
+Warning: Type mismatch.
+ At toplevel:
+ In expression
-Warning: At toplevel:
- use of deprecated `another-deprecated-procedure' - consider
`replacement-procedure'
+ deprecated-procedure
+
+ Use of deprecated `deprecated-procedure'.
+
+Warning: Type mismatch.
+ At toplevel:
+ In expression
+
+ another-deprecated-procedure
+
+ Use of deprecated `another-deprecated-procedure'.
+
+ The suggested replacement is `replacement-procedure'.
Warning: Type mismatch.
(scrutiny-tests.scm:168)
@@ -477,7 +489,7 @@ Note: Type mismatch.
Predicate call will always return true.
- Procedure `fixnum?', imported from `chicken.base', is a predicate for
+ Procedure `fixnum?' from module `chicken.base' is a predicate for
fixnum
@@ -494,7 +506,7 @@ Note: Type mismatch.
Predicate call will always return false.
- Procedure `symbol?', imported from `scheme', is a predicate for
+ Procedure `symbol?' from module `scheme' is a predicate for
symbol
@@ -511,7 +523,7 @@ Note: Type mismatch.
Predicate call will always return false.
- Procedure `string?', imported from `scheme', is a predicate for
+ Procedure `string?' from module `scheme' is a predicate for
string
@@ -545,7 +557,7 @@ Note: Type mismatch.
Predicate call will always return false.
- Procedure `symbol?', imported from `scheme', is a predicate for
+ Procedure `symbol?' from module `scheme' is a predicate for
symbol
@@ -562,7 +574,7 @@ Note: Type mismatch.
Predicate call will always return false.
- Procedure `string?', imported from `scheme', is a predicate for
+ Procedure `string?' from module `scheme' is a predicate for
string
@@ -579,7 +591,7 @@ Note: Type mismatch.
Predicate call will always return false.
- Procedure `symbol?', imported from `scheme', is a predicate for
+ Procedure `symbol?' from module `scheme' is a predicate for
symbol
@@ -596,7 +608,7 @@ Note: Type mismatch.
Predicate call will always return false.
- Procedure `string?', imported from `scheme', is a predicate for
+ Procedure `string?' from module `scheme' is a predicate for
string
@@ -613,7 +625,7 @@ Note: Type mismatch.
Predicate call will always return false.
- Procedure `symbol?', imported from `scheme', is a predicate for
+ Procedure `symbol?' from module `scheme' is a predicate for
symbol
@@ -630,7 +642,7 @@ Note: Type mismatch.
Predicate call will always return false.
- Procedure `string?', imported from `scheme', is a predicate for
+ Procedure `string?' from module `scheme' is a predicate for
string
@@ -719,7 +731,7 @@ Warning: Type mismatch.
fixnum
- Procedure `vector-ref', imported from `scheme', has this type
+ Procedure `vector-ref' from module `scheme' has this type
((vector-of 'a) fixnum -> 'a)
@@ -747,7 +759,7 @@ Warning: Type mismatch.
fixnum
- Procedure `vector-set!', imported from `scheme', has this type
+ Procedure `vector-set!' from module `scheme' has this type
(vector fixnum * -> undefined)
@@ -781,7 +793,7 @@ Warning: Type mismatch.
fixnum
- Procedure `list-ref', imported from `scheme', has this type
+ Procedure `list-ref' from module `scheme' has this type
((list-of 'a) fixnum -> 'a)
@@ -800,7 +812,7 @@ Warning: Type mismatch.
fixnum
- Procedure `list-ref', imported from `scheme', has this type
+ Procedure `list-ref' from module `scheme' has this type
((list-of 'a) fixnum -> 'a)
@@ -819,7 +831,7 @@ Warning: Type mismatch.
fixnum
- Procedure `list-ref', imported from `scheme', has this type
+ Procedure `list-ref' from module `scheme' has this type
((list-of 'a) fixnum -> 'a)
@@ -838,7 +850,7 @@ Warning: Type mismatch.
fixnum
- Procedure `list-ref', imported from `scheme', has this type
+ Procedure `list-ref' from module `scheme' has this type
((list-of 'a) fixnum -> 'a)
@@ -857,7 +869,7 @@ Warning: Type mismatch.
number
- Procedure `add1', imported from `chicken.base', has this type
+ Procedure `add1' from module `chicken.base' has this type
(number -> number)
@@ -876,7 +888,7 @@ Warning: Type mismatch.
number
- Procedure `add1', imported from `chicken.base', has this type
+ Procedure `add1' from module `chicken.base' has this type
(number -> number)
@@ -895,7 +907,7 @@ Warning: Type mismatch.
number
- Procedure `add1', imported from `chicken.base', has this type
+ Procedure `add1' from module `chicken.base' has this type
(number -> number)
@@ -914,7 +926,7 @@ Warning: Type mismatch.
number
- Procedure `add1', imported from `chicken.base', has this type
+ Procedure `add1' from module `chicken.base' has this type
(number -> number)
@@ -933,7 +945,7 @@ Warning: Type mismatch.
number
- Procedure `add1', imported from `chicken.base', has this type
+ Procedure `add1' from module `chicken.base' has this type
(number -> number)
diff --git a/tests/specialization.expected b/tests/specialization.expected
index c56611f..48afcef 100644
--- a/tests/specialization.expected
+++ b/tests/specialization.expected
@@ -8,7 +8,7 @@ Note: Type mismatch.
Predicate call will always return true.
- Procedure `string?', imported from `scheme', is a predicate for
+ Procedure `string?' from module `scheme' is a predicate for
string
@@ -36,7 +36,7 @@ Note: Type mismatch.
Predicate call will always return false.
- Procedure `string?', imported from `scheme', is a predicate for
+ Procedure `string?' from module `scheme' is a predicate for
string
@@ -62,7 +62,7 @@ Note: Type mismatch.
Predicate call will always return true.
- Procedure `input-port?', imported from `scheme', is a predicate for
+ Procedure `input-port?' from module `scheme' is a predicate for
input-port
@@ -90,7 +90,7 @@ Note: Type mismatch.
Predicate call will always return true.
- Procedure `output-port?', imported from `scheme', is a predicate for
+ Procedure `output-port?' from module `scheme' is a predicate for
output-port
--
2.7.4
>From 58e02767f9f25c46781f060ca2b6d77508e8f10f Mon Sep 17 00:00:00 2001
From: megane <address@hidden>
Date: Mon, 19 Nov 2018 15:52:22 +0200
Subject: [PATCH 9/9] * scrutinizer.scm: Pretty print "wrong number of values
for procedure argument" errors
* scrutinizer.scm: Remove report-notice (unused)
* scrutinizer.scm: Rename report-notice2 -> report-notice
* scrutinizer.scm (scrutinize -> single2): New function
I'm planning to replace all uses of 'single' with this function
* scrutinizer.scm (r-proc-call-argument-value-count) : New function
Maybe could be called "r-proc-call-argument-invalid-value-count",
but that's perhaps too long
The p-arg-expr prints additional info if the expression is function
call.
+ update *.expected
---
scrutinizer.scm | 107 ++++++++++++++++++++++++------
tests/scrutinizer-message-format.expected | 80 ++++++++++++++++++----
tests/scrutiny.expected | 36 ++++++++--
3 files changed, 185 insertions(+), 38 deletions(-)
diff --git a/scrutinizer.scm b/scrutinizer.scm
index 8582a06..6558c8d 100644
--- a/scrutinizer.scm
+++ b/scrutinizer.scm
@@ -172,11 +172,6 @@
(define (scrutinize node db complain specialize strict block-compilation)
(d "################################## SCRUTINIZE
##################################")
(set! *complain?* complain)
- (define (report-notice loc msg . args)
- (when complain
- (##sys#notice
- (conc (location-name loc)
- (sprintf "~?" msg args)))))
(define (report loc msg . args)
(when complain
@@ -300,6 +295,18 @@
(node-source-prefix node) what n (multiples n))
(first tv))))))
+ (define (single2 tv r-value-count-mismatch)
+ (if (eq? '* tv)
+ '*
+ (let ((n (length tv)))
+ (cond ((= 1 n) (car tv))
+ ((zero? n)
+ (r-value-count-mismatch tv)
+ 'undefined)
+ (else
+ (r-value-count-mismatch tv)
+ (first tv))))))
+
(define add-loc cons)
(define (get-specializations name)
@@ -652,21 +659,14 @@
((##core#call)
(let* ((f (fragment n))
(len (length subs))
- (args (map (lambda (n i)
+ (args (map (lambda (n2 i)
(make-node
'##core#the/result
(list
- (single
- n
- (sprintf
- "in ~a of procedure call `~s'"
- (if (zero? i)
- "operator position"
- (sprintf "argument #~a" i))
- f)
- (walk n e loc #f #f flow #f)
- loc))
- (list n)))
+ (single2
+ (walk n2 e loc #f #f flow #f)
+ (cut r-proc-call-argument-value-count
loc n i n2 <>)))
+ (list n2)))
subs
(iota len)))
(fn (walked-result (car args)))
@@ -2530,7 +2530,7 @@
(sprintf "~?" msg args))
" ")))))
-(define (report-notice2 location-node-candidates loc msg . args)
+(define (report-notice location-node-candidates loc msg . args)
(apply report2 ##sys#notice location-node-candidates loc msg args))
;;; Reports
@@ -2607,9 +2607,72 @@
(variable-from-module pname)
(type->pp-string ptype #f)))
+(define (r-proc-call-argument-value-count loc call-node i arg-node atype)
+ (define pn
+ (if (zero? i) ""
+ (sprintf " `~a'"
+ (strip-namespace (fragment (first (node-subexpressions
call-node)))))))
+ (define (p-arg-expr)
+ (define (p-expr)
+ (sprintf (string-append
+ "This is the expression"
+ "~%~%"
+ "~a")
+ (pp-fragment arg-node)))
+ (or (and (eq? '##core#call (node-class arg-node))
+ (let ((pnode (first (node-subexpressions arg-node))))
+ (and-let* (((eq? '##core#variable (node-class pnode)))
+ (pname (car (node-parameters pnode)))
+ (ptype (variable-mark pname '##compiler#type)))
+ (sprintf (string-append
+ "It is a call to ~a which has this type"
+ "~%~%"
+ "~a"
+ "~%~%"
+ "~a")
+ (variable-from-module pname)
+ (type->pp-string ptype #f)
+ (p-expr)))))
+ (p-expr)))
+
+ (if (zero? (length atype))
+ (report2
+ warning
+ (list arg-node call-node)
+ loc
+ (string-append
+ "In procedure call"
+ "~%~%"
+ "~a"
+ "~%~%"
+ "Argument expression #~a to procedure~a does not return any values."
+ "~%~%"
+ "~a")
+ (pp-fragment call-node " ")
+ i
+ pn
+ (p-arg-expr))
+ (report2
+ warning
+ (list arg-node call-node)
+ loc
+ (string-append
+ "In procedure call"
+ "~%~%"
+ "~a"
+ "~%~%"
+ "Argument #~a to procedure~a returns ~a values but 1 is expected."
+ "~%~%"
+ "~a")
+ (pp-fragment call-node " ")
+ i
+ pn
+ (length atype)
+ (p-arg-expr))))
+
(define (r-pred-call-always-true loc node pname pred-type atype)
;; pname is "... proc call to predicate `foo' "
- (report-notice2
+ (report-notice
(list node)
loc
(string-append
@@ -2632,7 +2695,7 @@
(type->pp-string atype)))
(define (r-pred-call-always-false loc node pname pred-type atype)
- (report-notice2
+ (report-notice
(list node)
loc
(string-append
@@ -2655,7 +2718,7 @@
(type->pp-string atype)))
(define (r-cond-test-always-true loc if-node test-node t)
- (report-notice2
+ (report-notice
(list test-node if-node)
loc
(string-append
@@ -2670,7 +2733,7 @@
(type->pp-string t)))
(define (r-cond-test-always-false loc if-node test-node)
- (report-notice2
+ (report-notice
(list test-node if-node)
loc
(string-append
diff --git a/tests/scrutinizer-message-format.expected
b/tests/scrutinizer-message-format.expected
index 4d99457..c050112 100644
--- a/tests/scrutinizer-message-format.expected
+++ b/tests/scrutinizer-message-format.expected
@@ -35,11 +35,39 @@ Warning: Type mismatch.
(list -> fixnum)
-Warning: In `r-proc-call-argument-value-count', a toplevel procedure
- (test-scrutinizer-message-format.scm:11) expected a single result in
argument #1 of procedure call `(scheme#list (chicken.time#cpu-time))', but
received 2 results
+Warning: Type mismatch.
+ (test-scrutinizer-message-format.scm:11)
+ In `r-proc-call-argument-value-count', a toplevel procedure
+ In procedure call
-Warning: In `r-proc-call-argument-value-count', a toplevel procedure
- (test-scrutinizer-message-format.scm:11) expected a single result in
argument #1 of procedure call `(scheme#vector (scheme#values))', but received
zero results
+ (scheme#list (chicken.time#cpu-time))
+
+ Argument #1 to procedure `list' returns 2 values but 1 is expected.
+
+ It is a call to `cpu-time' from module `chicken.time' which has this type
+
+ (-> fixnum fixnum)
+
+ This is the expression
+
+ (chicken.time#cpu-time)
+
+Warning: Type mismatch.
+ (test-scrutinizer-message-format.scm:11)
+ In `r-proc-call-argument-value-count', a toplevel procedure
+ In procedure call
+
+ (scheme#vector (scheme#values))
+
+ Argument expression #1 to procedure `vector' does not return any values.
+
+ It is a call to `values' from module `scheme' which has this type
+
+ (procedure scheme#values (&rest values) . *)
+
+ This is the expression
+
+ (scheme#values)
Warning: In `r-proc-call-argument-value-count', a toplevel procedure
expected a single result in `let' binding of `g28', but received zero results
@@ -305,15 +333,43 @@ Warning: Type mismatch.
(list -> fixnum)
-Warning: In `m#toplevel-foo', a toplevel procedure
- In `local-bar', a local procedure
- In `r-proc-call-argument-value-count', a local procedure
- (test-scrutinizer-message-format.scm:54) expected a single result in
argument #1 of procedure call `(scheme#list (chicken.time#cpu-time))', but
received 2 results
+Warning: Type mismatch.
+ (test-scrutinizer-message-format.scm:54)
+ In `m#toplevel-foo', a toplevel procedure
+ In `local-bar', a local procedure
+ In `r-proc-call-argument-value-count', a local procedure
+ In procedure call
-Warning: In `m#toplevel-foo', a toplevel procedure
- In `local-bar', a local procedure
- In `r-proc-call-argument-value-count', a local procedure
- (test-scrutinizer-message-format.scm:54) expected a single result in
argument #1 of procedure call `(scheme#vector (scheme#values))', but received
zero results
+ (scheme#list (chicken.time#cpu-time))
+
+ Argument #1 to procedure `list' returns 2 values but 1 is expected.
+
+ It is a call to `cpu-time' from module `chicken.time' which has this type
+
+ (-> fixnum fixnum)
+
+ This is the expression
+
+ (chicken.time#cpu-time)
+
+Warning: Type mismatch.
+ (test-scrutinizer-message-format.scm:54)
+ In `m#toplevel-foo', a toplevel procedure
+ In `local-bar', a local procedure
+ In `r-proc-call-argument-value-count', a local procedure
+ In procedure call
+
+ (scheme#vector (scheme#values))
+
+ Argument expression #1 to procedure `vector' does not return any values.
+
+ It is a call to `values' from module `scheme' which has this type
+
+ (procedure scheme#values (&rest values) . *)
+
+ This is the expression
+
+ (scheme#values)
Warning: In `m#toplevel-foo', a toplevel procedure
In `local-bar', a local procedure
diff --git a/tests/scrutiny.expected b/tests/scrutiny.expected
index 02ea4af..a40c742 100644
--- a/tests/scrutiny.expected
+++ b/tests/scrutiny.expected
@@ -72,11 +72,39 @@ Warning: Type mismatch.
(* -> boolean)
-Warning: At toplevel:
- (scrutiny-tests.scm:23) expected a single result in argument #1 of procedure
call `(chicken.base#print (scheme#values 1 2))', but received 2 results
+Warning: Type mismatch.
+ (scrutiny-tests.scm:23)
+ At toplevel:
+ In procedure call
-Warning: At toplevel:
- (scrutiny-tests.scm:24) expected a single result in argument #1 of procedure
call `(chicken.base#print (scheme#values))', but received zero results
+ (chicken.base#print (scheme#values 1 2))
+
+ Argument #1 to procedure `print' returns 2 values but 1 is expected.
+
+ It is a call to `values' from module `scheme' which has this type
+
+ (procedure scheme#values (&rest values) . *)
+
+ This is the expression
+
+ (scheme#values 1 2)
+
+Warning: Type mismatch.
+ (scrutiny-tests.scm:24)
+ At toplevel:
+ In procedure call
+
+ (chicken.base#print (scheme#values))
+
+ Argument expression #1 to procedure `print' does not return any values.
+
+ It is a call to `values' from module `scheme' which has this type
+
+ (procedure scheme#values (&rest values) . *)
+
+ This is the expression
+
+ (scheme#values)
Warning: Type mismatch.
(scrutiny-tests.scm:27)
--
2.7.4
- Re: [Chicken-hackers] [PATCH] Use vertical space more liberally in some scrutinizer messages,
megane <=
- Message not available
- Re: [Chicken-hackers] [PATCH] Use vertical space more liberally in some scrutinizer messages, felix . winkelmann, 2018/11/19
- Re: [Chicken-hackers] [PATCH] Use vertical space more liberally in some scrutinizer messages, megane, 2018/11/19
- Re: [Chicken-hackers] [PATCH] Use vertical space more liberally in some scrutinizer messages, felix . winkelmann, 2018/11/19
- Re: [Chicken-hackers] [PATCH] Use vertical space more liberally in some scrutinizer messages, Peter Bex, 2018/11/19
- Re: [Chicken-hackers] [PATCH] Use vertical space more liberally in some scrutinizer messages, megane, 2018/11/19
- Re: [Chicken-hackers] [PATCH] Use vertical space more liberally in some scrutinizer messages, felix . winkelmann, 2018/11/19