[Chicken-hackers] [PATCH] two scrutinizer fixes

[Felix]

a) when matching "list-of"/"vector-of" with "list"/"vector", each
   element of the latter must match the element-type of the former
   (reported by megane, fixes #948). Previously the "list"/vector"
   type was matched as "(list-of (or ...))" instead, which makes
   the match less precise.

b) when matching result-types, allow "undefined" to match "noreturn"
   as the "noreturn" property can not be inferred for foreign procedures
   (for example) in general

Additionally, when converting the internal node tree in the compiler
to expressions, internal type-declaration forms are not shown to
reduce clutter in the output (this is just a cosmetic change).


cheers,
felix

>From 42648a232f0519cf8141f0f8cef0c67ef9ef8b40 Mon Sep 17 00:00:00 2001
From: felix <address@hidden>
Date: Sun, 4 Nov 2012 17:58:12 +0100
Subject: [PATCH] Scrutinizer fixes.

a) when matching "list-of"/"vector-of" with "list"/"vector", each
   element of the latter must match the element-type of the former
   (reported by megane, fixes #948)

b) when matching result-types, allow "undefined" to match "noreturn"
   as the "noreturn" property can not be inferred for foreign procedures
   (for example) in general
---
 scrutinizer.scm          |   59 ++++++++++++++++++++++++++++++++-------------
 support.scm              |    2 +
 tests/runtests.sh        |    1 +
 tests/scrutiny-tests.scm |    9 +++++++
 tests/scrutiny.expected  |    5 +++-
 5 files changed, 58 insertions(+), 18 deletions(-)

diff --git a/scrutinizer.scm b/scrutinizer.scm
index 3cfbe93..73a1166 100755
--- a/scrutinizer.scm
+++ b/scrutinizer.scm
@@ -47,9 +47,11 @@
     (printf "[debug|~a] ~a~?~%" d-depth (make-string d-depth #\space) fstr 
args)) )
 
 (define dd d)
+(define ddd d)
 
 (define-syntax d (syntax-rules () ((_ . _) (void))))
 (define-syntax dd (syntax-rules () ((_ . _) (void))))
+(define-syntax ddd (syntax-rules () ((_ . _) (void))))
 
 
 ;;; Walk node tree, keeping type and binding information
@@ -1010,6 +1012,8 @@
          ((eq? '* results1))
          ((eq? '* results2) (not exact))
          ((null? results2) #f)
+         ((and (memq (car results1) '(undefined noreturn))
+               (memq (car results2) '(undefined noreturn))))
          ((match1 (car results1) (car results2)) 
           (match-results (cdr results1) (cdr results2)))
          (else #f)))
@@ -1175,9 +1179,18 @@
          ((and (pair? t1) (eq? 'list-of (car t1)))
           (or (eq? 'null t2)
               (and (pair? t2)
-                   (memq (car t2) '(pair list))
-                   (let ((ct2 (canonicalize-list-of-type t2)))
-                     (and ct2 (match1 t1 ct2))))))
+                   (case (car t2)
+                     ((list)
+                      (let ((t1 (second t1)))
+                        (over-all-instantiations
+                         (cdr t2)
+                         typeenv
+                         #t
+                         (lambda (t) (match1 t1 t)))))
+                     ((pair)
+                      (let ((ct2 (canonicalize-list-of-type t2)))
+                        (and ct2 (match1 t1 ct2))))
+                     (else #f)))))
          ((and (pair? t1) (eq? 'list (car t1)))
           (and (pair? t2)
                (case (car t2)
@@ -1186,15 +1199,20 @@
                        (match1 (second t1) (second t2))
                        (match1 t1 (third t2))))
                  ((list-of)
-                  (and (not exact) (not all)                   
-                       (let ((ct2 (canonicalize-list-of-type t2)))
-                         (and ct2 (match1 t1 ct2)))))
+                  (and (not exact) 
+                       (not all)
+                       (let ((t2 (second t2)))
+                         (over-all-instantiations
+                          (cdr t1)
+                          typeenv 
+                          #t
+                          (lambda (t) (match1 t t2))))))
                  (else #f))))
          ((and (pair? t2) (eq? 'list-of (car t2)))
           (and (not exact)             ;XXX also check "all"?
                (or (eq? 'null t1)
                    (and (pair? t1)
-                        (memq (car t1) '(pair list))
+                        (eq? 'pair (car t1)) ; list-of already handled above
                         (let ((ct1 (canonicalize-list-of-type t1)))
                           (and ct1 (match1 ct1 t2)))))))
          ((and (pair? t2) (eq? 'list (car t2)))
@@ -1204,20 +1222,27 @@
                   (and (pair? (cdr t2))
                        (match1 (second t1) (second t2))
                        (match1 (third t1) t2)))
-                 ((list-of)
-                  (and (not exact) (not all)
-                       (let ((ct1 (canonicalize-list-of-type t1)))
-                         (and ct1 (match1 ct1 t2)))))
+                 ;; t1 = list-of already handled above
                  (else #f))))
          ((and (pair? t1) (eq? 'vector (car t1)))
           (and (not exact) (not all)
                (pair? t2)
                (eq? 'vector-of (car t2))
-               (match1 (simplify-type `(or ,@(cdr t1))) (second t2))))
+               (let ((t2 (second t2)))
+                 (over-all-instantiations
+                  (cdr t1)
+                  typeenv
+                  #t
+                  (lambda (t) (match1 t t2))))))
          ((and (pair? t2) (eq? 'vector (car t2)))
           (and (pair? t1)
                (eq? 'vector-of (car t1))
-               (match1 (second t1) (simplify-type `(or ,@(cdr t2))))))
+               (let ((t1 (second t1)))
+                 (over-all-instantiations
+                  (cdr t2)
+                  typeenv 
+                  #t
+                  (lambda (t) (match1 t1 t))))))
          (else #f)))
 
   (let ((m (match1 t1 t2)))
@@ -2285,7 +2310,7 @@
 
     ;; restore trail and collect instantiations
     (define (restore)
-      ;;(dd "restoring, trail: ~s, te: ~s" trail typeenv) ;XXX remove
+      (ddd "restoring, trail: ~s, te: ~s" trail typeenv)
       (let ((is '()))
        (do ((tr trail (cdr tr)))
            ((eq? tr trail0)
@@ -2296,7 +2321,7 @@
                    (car tr)
                    (resolve (car tr) typeenv)
                    is))
-         ;; (dd "  restoring ~a, insts: ~s" (car tr) insts) ;XXX remove
+         (ddd "  restoring ~a, insts: ~s" (car tr) insts)
          (let ((a (assq (car tr) typeenv)))
            (set-car! (cdr a) #f)))))
 
@@ -2314,10 +2339,10 @@
                                   (else #f)))
                           insts)))
                       vars)))
-       ;;(dd "  collected: ~s" all)    ;XXX remove
+       (ddd "  collected: ~s" all)
        all))
 
-    ;;(dd " over-all-instantiations: ~s exact=~a" tlist exact) ;XXX remove
+    (ddd " over-all-instantiations: ~s exact=~a" tlist exact)
     ;; process all tlist elements
     (let loop ((ts tlist) (ok #f))
       (cond ((null? ts)
diff --git a/support.scm b/support.scm
index c0ff51f..08f6d66 100644
--- a/support.scm
+++ b/support.scm
@@ -640,6 +640,8 @@
               (walk (car subs)) ) )
        ((##core#the)
         `(the ,(first params) ,(walk (first subs))))
+       ((##core#the/result)
+        (walk (first subs)))
        ((##core#typecase)
         `(compiler-typecase
           ,(walk (first subs))
diff --git a/tests/runtests.sh b/tests/runtests.sh
index 3009346..7a0626b 100755
--- a/tests/runtests.sh
+++ b/tests/runtests.sh
@@ -363,6 +363,7 @@ $compile symbolgc-tests.scm
 echo "======================================== finalizer tests ..."
 $interpret -s test-finalizers.scm
 $compile finalizer-error-test.scm
+echo "expect an error message here:"
 ./a.out -:hg101
 $compile test-finalizers-2.scm
 ./a.out
diff --git a/tests/scrutiny-tests.scm b/tests/scrutiny-tests.scm
index 49a0673..9c2e867 100644
--- a/tests/scrutiny-tests.scm
+++ b/tests/scrutiny-tests.scm
@@ -147,3 +147,12 @@
 (: another-deprecated-procedure (deprecated replacement-procedure))
 (define (another-deprecated-procedure x) (+ x x))
 (another-deprecated-procedure 2)
+
+;; Needed to use "over-all-instantiations" or matching "vector"/"list" type
+;; with "vector-of"/"list-of" type (reported by megane)
+(: apply1 (forall (a b) (procedure ((procedure (#!rest a) b) (list-of a)) b)))
+
+(define (apply1 f args)
+  (apply f args))
+
+(apply1 + (list 'a 2 3)) ; <- no type warning
diff --git a/tests/scrutiny.expected b/tests/scrutiny.expected
index a8c7c6d..5612202 100644
--- a/tests/scrutiny.expected
+++ b/tests/scrutiny.expected
@@ -34,7 +34,7 @@ Warning: at toplevel:
   (scrutiny-tests.scm:25) in procedure call to `+', expected argument #2 of 
type `number', but was given an argument of type `symbol'
 
 Warning: at toplevel:
-  assignment of value of type `fixnum' to toplevel variable `car' does not 
match declared type `(forall (a148) (procedure car ((pair a148 *)) a148))'
+  assignment of value of type `fixnum' to toplevel variable `car' does not 
match declared type `(forall (a157) (procedure car ((pair a157 *)) a157))'
 
 Warning: at toplevel:
   expected in `let' binding of `g8' a single result, but were given 2 results
@@ -99,4 +99,7 @@ Warning: at toplevel:
 Warning: at toplevel:
   use of deprecated library procedure `another-deprecated-procedure' - 
consider using `replacement-procedure' instead
 
+Warning: at toplevel:
+  (scrutiny-tests.scm:158) 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: redefinition of standard binding: car
-- 
1.7.0.4