chicken-hackers
[Top][All Lists]
Advanced

[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


reply via email to

[Prev in Thread] Current Thread [Next in Thread]