Re: [Chicken-hackers] [PATCH] Fix arguments to scrutiny reporting procedure for `append'

[megane]

Evan Hanson <address@hidden> writes:

> On 2019-03-25 14:23, megane wrote:
>> The last patchset contained a more comprehensive message format test
>> suite. I guess I just forgot to mention that, sorry :P
>>
>> Here's a patch that applies on top of this fix.
>
> Thanks megane, here's a signed-off copy.
>
> I changed the new TVs ('foo et al.) to 'a, 'b, and 'c so the gensym
> redaction script would pick them up, and reenabled the commented-out
> `zero-values-for-conditional' tests. If there's a reason those really
> should be disabled, just shout.

Hi,

Yeah those conditional tests shouldn't be commented, my bad.

I don't think the format-clashing-typevars is a good test either. It was
supposed to test that identically named type variables coming from
different sources should be printed with different names (but still not
with the internally renamed names used by scrutinizer).

Currently they are printed with identical names. How this case should be
printed needs some thinking. Let's just drop this test for now.

Attached is a new version. I tweaked the formatting a bit and added some
comments, too.

>From c0e84a6410d522c71df2363f2ec0b4a1eb7c7ba2 Mon Sep 17 00:00:00 2001
From: megane <address@hidden>
Date: Sat, 30 Mar 2019 09:26:59 +0200
Subject: [PATCH] Make scrutinizer message format test suite more comprehensive

---
 tests/scrutinizer-message-format.expected | 349 ++++++++++++++++--------------
 tests/test-scrutinizer-message-format.scm |  34 ++-
 2 files changed, 211 insertions(+), 172 deletions(-)

diff --git a/tests/scrutinizer-message-format.expected 
b/tests/scrutinizer-message-format.expected
index f6f3b25..13e0361 100644
--- a/tests/scrutinizer-message-format.expected
+++ b/tests/scrutinizer-message-format.expected
@@ -306,110 +306,37 @@ Warning: List index out of range
 
   Procedure `list-ref' from module `scheme' is called with index `1' for a 
list of length `0'.
 
-Warning: Negative vector index
+Warning: Invalid argument
   In file `test-scrutinizer-message-format.scm:XXX',
-  In procedure `vector-ref-out-of-range',
+  In procedure `append-invalid-arg',
   In procedure call:
 
-    (scheme#vector-ref (scheme#vector) -1)
-
-  Procedure `vector-ref' from module `scheme' is called with a negative index 
-1.
+    (scheme#append 1 (scheme#list 1))
 
-Warning: Let binding to `a' has zero values
-  In file `test-scrutinizer-message-format.scm:XXX',
-  In procedure `zero-values-for-let',
-  In let expression:
+  Argument #1 to procedure `append' has an invalid type:
 
-    (let ((a (scheme#values))) a)
-
-  Variable `a' is bound to an expression that returns 0 values.
-
-  It is a call to `values' from module `scheme' which has this type:
-
-    (procedure (#!rest values) . *)
-
-  This is the expression:
-
-    (scheme#values)
-
-Warning: Let binding to `a' has 2 values
-  In file `test-scrutinizer-message-format.scm:XXX',
-  In procedure `multiple-values-for-let',
-  In let expression:
-
-    (let ((a (scheme#values 1 2))) a)
-
-  Variable `a' is bound to an expression that returns 2 values.
-
-  It is a call to `values' from module `scheme' which has this type:
-
-    (procedure (#!rest values) . *)
-
-  This is the expression:
-
-    (scheme#values 1 2)
-
-Warning: Zero values for conditional
-  In file `test-scrutinizer-message-format.scm:XXX',
-  In procedure `zero-values-for-conditional',
-  In conditional:
-
-    (if (scheme#values) 1 (##core#undefined))
-
-  The test expression returns 0 values.
-
-  It is a call to `values' from module `scheme' which has this type:
-
-    (procedure (#!rest values) . *)
-
-  This is the expression:
-
-    (scheme#values)
-
-Warning: Too many values for conditional
-  In file `test-scrutinizer-message-format.scm:XXX',
-  In procedure `multiple-values-for-conditional',
-  In conditional:
-
-    (if (scheme#values 1 2) 1 (##core#undefined))
-
-  The test expression returns 2 values.
+    fixnum
 
-  It is a call to `values' from module `scheme' which has this type:
+  The expected type is:
 
-    (procedure (#!rest values) . *)
+    list
 
   This is the expression:
 
-    (scheme#values 1 2)
-
-Note: Test is always true
-  In file `test-scrutinizer-message-format.scm:XXX',
-  In procedure `multiple-values-for-conditional',
-  In conditional expression:
+    1
 
-    (if (scheme#values 1 2) 1 (##core#undefined))
+  Procedure `append' from module `scheme' has this type:
 
-  Test condition has always true value of type:
+    (#!rest * -> *)
 
-    fixnum
-
-Warning: Let binding to `gXXX' has 2 values
+Warning: Negative vector index
   In file `test-scrutinizer-message-format.scm:XXX',
-  In procedure `multiple-values-for-conditional',
-  In let expression:
-
-    (if (scheme#values 1 2) 1 (##core#undefined))
-
-  Variable `gXXX' is bound to an expression that returns 2 values.
-
-  It is a call to `values' from module `scheme' which has this type:
-
-    (procedure (#!rest values) . *)
+  In procedure `vector-ref-out-of-range',
+  In procedure call:
 
-  This is the expression:
+    (scheme#vector-ref (scheme#vector) -1)
 
-    (scheme#values 1 2)
+  Procedure `vector-ref' from module `scheme' is called with a negative index 
-1.
 
 Warning: Wrong number of arguments
   In file `test-scrutinizer-message-format.scm:XXX',
@@ -493,26 +420,6 @@ Warning: Not enough argument values
 
     (scheme#values)
 
-Warning: Let binding to `gXXX' has zero values
-  In file `test-scrutinizer-message-format.scm:XXX',
-  In module `m',
-  In procedure `toplevel-foo',
-  In procedure `local-bar',
-  In procedure `r-proc-call-argument-value-count',
-  In let expression:
-
-    (let ((gXXX (scheme#values))) (gXXX))
-
-  Variable `gXXX' is bound to an expression that returns 0 values.
-
-  It is a call to `values' from module `scheme' which has this type:
-
-    (procedure (#!rest values) . *)
-
-  This is the expression:
-
-    (scheme#values)
-
 Warning: Branch values mismatch
   In file `test-scrutinizer-message-format.scm:XXX',
   In module `m',
@@ -534,10 +441,28 @@ Warning: Branch values mismatch
     (chicken.time#cpu-time)
 
 Warning: Invalid procedure
+  In file `test-scrutinizer-message-format.scm:XXX',
+  In module `m',
+  In procedure `toplevel-foo',
+  In procedure `local-bar',
+  In procedure `r-invalid-called-procedure-type',
+  In procedure `variable',
+  In procedure call:
+
+    (m#foo2 2)
+
+  Variable `foo2' from module `m' is not a procedure.
+
+  It has this type:
+
+    boolean
+
+Warning: Invalid procedure
   In module `m',
   In procedure `toplevel-foo',
   In procedure `local-bar',
   In procedure `r-invalid-called-procedure-type',
+  In procedure `non-variable',
   In procedure call:
 
     (1 2)
@@ -733,47 +658,12 @@ Warning: Deprecated identifier `deprecated-foo2'
 
   The suggested alternative is `foo'.
 
-Warning: Negative list index
-  In file `test-scrutinizer-message-format.scm:XXX',
-  In module `m',
-  In procedure `toplevel-foo',
-  In procedure `local-bar',
-  In procedure `list-ref-negative-index',
-  In procedure call:
-
-    (scheme#list-ref '() -1)
-
-  Procedure `list-ref' from module `scheme' is called with a negative index -1.
-
-Warning: List index out of range
-  In file `test-scrutinizer-message-format.scm:XXX',
-  In module `m',
-  In procedure `toplevel-foo',
-  In procedure `local-bar',
-  In procedure `list-ref-out-of-range',
-  In procedure call:
-
-    (scheme#list-ref '() 1)
-
-  Procedure `list-ref' from module `scheme' is called with index `1' for a 
list of length `0'.
-
-Warning: Negative vector index
-  In file `test-scrutinizer-message-format.scm:XXX',
-  In module `m',
-  In procedure `toplevel-foo',
-  In procedure `local-bar',
-  In procedure `vector-ref-out-of-range',
-  In procedure call:
-
-    (scheme#vector-ref (scheme#vector) -1)
-
-  Procedure `vector-ref' from module `scheme' is called with a negative index 
-1.
-
 Warning: Let binding to `a' has zero values
   In file `test-scrutinizer-message-format.scm:XXX',
   In module `m',
   In procedure `toplevel-foo',
   In procedure `local-bar',
+  In procedure `r-let-value-count-invalid',
   In procedure `zero-values-for-let',
   In let expression:
 
@@ -794,7 +684,8 @@ Warning: Let binding to `a' has 2 values
   In module `m',
   In procedure `toplevel-foo',
   In procedure `local-bar',
-  In procedure `multiple-values-for-let',
+  In procedure `r-let-value-count-invalid',
+  In procedure `too-many-values-for-let',
   In let expression:
 
     (let ((a (scheme#values 1 2))) a)
@@ -814,6 +705,7 @@ Warning: Zero values for conditional
   In module `m',
   In procedure `toplevel-foo',
   In procedure `local-bar',
+  In procedure `r-conditional-value-count-invalid',
   In procedure `zero-values-for-conditional',
   In conditional:
 
@@ -834,10 +726,11 @@ Warning: Too many values for conditional
   In module `m',
   In procedure `toplevel-foo',
   In procedure `local-bar',
-  In procedure `multiple-values-for-conditional',
+  In procedure `r-conditional-value-count-invalid',
+  In procedure `too-many-values-for-conditional',
   In conditional:
 
-    (if (scheme#values 1 2) 1 (##core#undefined))
+    (if (scheme#values (the * 1) 2) 1 (##core#undefined))
 
   The test expression returns 2 values.
 
@@ -847,33 +740,41 @@ Warning: Too many values for conditional
 
   This is the expression:
 
-    (scheme#values 1 2)
+    (scheme#values (the * 1) 2)
 
-Note: Test is always true
+Warning: Assignment to `foo' has zero values
   In file `test-scrutinizer-message-format.scm:XXX',
   In module `m',
   In procedure `toplevel-foo',
   In procedure `local-bar',
-  In procedure `multiple-values-for-conditional',
-  In conditional expression:
+  In procedure `r-assignment-value-count-invalid',
+  In procedure `zero-values-for-assignment',
+  In assignment:
 
-    (if (scheme#values 1 2) 1 (##core#undefined))
+    (set! m#foo (scheme#values))
 
-  Test condition has always true value of type:
+  Variable `foo' is assigned from expression that returns 0 values.
 
-    fixnum
+  It is a call to `values' from module `scheme' which has this type:
 
-Warning: Let binding to `gXXX' has 2 values
+    (procedure (#!rest values) . *)
+
+  This is the expression:
+
+    (scheme#values)
+
+Warning: Assignment to `foo' has 2 values
   In file `test-scrutinizer-message-format.scm:XXX',
   In module `m',
   In procedure `toplevel-foo',
   In procedure `local-bar',
-  In procedure `multiple-values-for-conditional',
-  In let expression:
+  In procedure `r-assignment-value-count-invalid',
+  In procedure `too-many-values-for-assignment',
+  In assignment:
 
-    (if (scheme#values 1 2) 1 (##core#undefined))
+    (set! m#foo (scheme#values #t 2))
 
-  Variable `gXXX' is bound to an expression that returns 2 values.
+  Variable `foo' is assigned from expression that returns 2 values.
 
   It is a call to `values' from module `scheme' which has this type:
 
@@ -881,7 +782,135 @@ Warning: Let binding to `gXXX' has 2 values
 
   This is the expression:
 
-    (scheme#values 1 2)
+    (scheme#values #t 2)
+
+Warning: Negative list index
+  In file `test-scrutinizer-message-format.scm:XXX',
+  In module `m',
+  In procedure `toplevel-foo',
+  In procedure `local-bar',
+  In procedure `list-ref-negative-index',
+  In procedure call:
+
+    (scheme#list-ref '() -1)
+
+  Procedure `list-ref' from module `scheme' is called with a negative index -1.
+
+Warning: List index out of range
+  In file `test-scrutinizer-message-format.scm:XXX',
+  In module `m',
+  In procedure `toplevel-foo',
+  In procedure `local-bar',
+  In procedure `list-ref-out-of-range',
+  In procedure call:
+
+    (scheme#list-ref '() 1)
+
+  Procedure `list-ref' from module `scheme' is called with index `1' for a 
list of length `0'.
+
+Warning: Invalid argument
+  In file `test-scrutinizer-message-format.scm:XXX',
+  In module `m',
+  In procedure `toplevel-foo',
+  In procedure `local-bar',
+  In procedure `append-invalid-arg',
+  In procedure call:
+
+    (scheme#append 1 (scheme#list 1))
+
+  Argument #1 to procedure `append' has an invalid type:
+
+    fixnum
+
+  The expected type is:
+
+    list
+
+  This is the expression:
+
+    1
+
+  Procedure `append' from module `scheme' has this type:
+
+    (#!rest * -> *)
+
+Warning: Negative vector index
+  In file `test-scrutinizer-message-format.scm:XXX',
+  In module `m',
+  In procedure `toplevel-foo',
+  In procedure `local-bar',
+  In procedure `vector-ref-out-of-range',
+  In procedure call:
+
+    (scheme#vector-ref (scheme#vector) -1)
+
+  Procedure `vector-ref' from module `scheme' is called with a negative index 
-1.
+
+Note: Predicate is always true
+  In file `test-scrutinizer-message-format.scm:XXX',
+  In module `m',
+  In procedure `toplevel-foo',
+  In procedure `local-bar',
+  In procedure `r-cond-test-always-true-with-pred',
+  In procedure call:
+
+    (scheme#symbol? 'symbol)
+
+  The predicate will always return true.
+
+  Procedure `symbol?' from module `scheme' is a predicate for:
+
+    symbol
+
+  The given argument has this type:
+
+    symbol
+
+Note: Test is always true
+  In file `test-scrutinizer-message-format.scm:XXX',
+  In module `m',
+  In procedure `toplevel-foo',
+  In procedure `local-bar',
+  In procedure `r-cond-test-always-true-with-pred',
+  In conditional expression:
+
+    (if (scheme#symbol? 'symbol) 1 (##core#undefined))
+
+  Test condition has always true value of type:
+
+    true
+
+Note: Predicate is always false
+  In file `test-scrutinizer-message-format.scm:XXX',
+  In module `m',
+  In procedure `toplevel-foo',
+  In procedure `local-bar',
+  In procedure `r-cond-test-always-false-with-pred',
+  In procedure call:
+
+    (scheme#symbol? 1)
+
+  The predicate will always return false.
+
+  Procedure `symbol?' from module `scheme' is a predicate for:
+
+    symbol
+
+  The given argument has this type:
+
+    fixnum
+
+Note: Test is always false
+  In file `test-scrutinizer-message-format.scm:XXX',
+  In module `m',
+  In procedure `toplevel-foo',
+  In procedure `local-bar',
+  In procedure `r-cond-test-always-false-with-pred',
+  In conditional expression:
+
+    (if (scheme#symbol? 1) 1 (##core#undefined))
+
+  Test condition is always false.
 
 Error: No typecase match
   In file `test-scrutinizer-message-format.scm:XXX',
diff --git a/tests/test-scrutinizer-message-format.scm 
b/tests/test-scrutinizer-message-format.scm
index d792cf3..7c67a0b 100644
--- a/tests/test-scrutinizer-message-format.scm
+++ b/tests/test-scrutinizer-message-format.scm
@@ -23,15 +23,13 @@
 
 (set! foo 1)
 
+;; These have special cases
 (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 (append-invalid-arg) (append 1 (list 1)))
 (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))
 
+;; This is disabled because fail-compiler-typecase is a fatal warning
 ;; (define (fail-compiler-typecase) (compiler-typecase 1 (symbol 1) (list 2)))
 
 (module
@@ -51,9 +49,11 @@
    (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-proc-call-argument-value-count) (list (cpu-time)) (vector 
(values)))
      (define (r-cond-branch-value-count-mismatch) (if (the * 1) 1 (cpu-time)))
-     (define (r-invalid-called-procedure-type) (1 2))
+     (define (r-invalid-called-procedure-type)
+       (define (variable) (foo2 2))
+       (define (non-variable) (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))
@@ -64,14 +64,24 @@
      (define (r-toplevel-var-assignment-type-mismatch) (set! foo2 1))
      (define (r-deprecated-identifier) (list deprecated-foo) (vector 
deprecated-foo2))
 
+     (define (r-let-value-count-invalid)
+       (define (zero-values-for-let) (let ((a (values))) a))
+       (define (too-many-values-for-let) (let ((a (values 1 2))) a)))
+     (define (r-conditional-value-count-invalid)
+       (define (zero-values-for-conditional) (if (values) 1))
+       (define (too-many-values-for-conditional) (if (values (the * 1) 2) 1)))
+     (define (r-assignment-value-count-invalid)
+       (define (zero-values-for-assignment) (set! foo (values)))
+       (define (too-many-values-for-assignment) (set! foo (values #t 2))))
+
+     ;; These have special cases
      (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 (append-invalid-arg) (append 1 (list 1)))
      (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 (r-cond-test-always-true-with-pred) (if (symbol? 'symbol) 1))
+     (define (r-cond-test-always-false-with-pred) (if (symbol? 1) 1))
 
      (define (fail-compiler-typecase) (compiler-typecase 1 (symbol 1) (list 
2)))
      )))
-- 
2.7.4


>
> Cheers,
>
> Evan