From fc9539bda29d06dfe6192ead249747c9d983559f Mon Sep 17 00:00:00 2001
From: Peter Bex <address@hidden>
Date: Sun, 24 Jul 2016 20:04:20 +0200
Subject: [PATCH] Add special-case scrutiny handling for "append".

Type derivation works perfectly for arguments known to be proper lists,
but for (pair ...) structures it will punt.  However, it can emit
warnings when the arguments (except for the last one) are known to be
non-lists or improper lists.
---
 scrutinizer.scm          | 52 ++++++++++++++++++++++++++++++++++++++++++++++++
 tests/scrutiny-tests.scm | 16 +++++++++++++++
 tests/scrutiny.expected  |  6 ++++++
 types.db                 |  1 +
 4 files changed, 75 insertions(+)

diff --git a/scrutinizer.scm b/scrutinizer.scm
index 3502106..8738aef 100644
--- a/scrutinizer.scm
+++ b/scrutinizer.scm
@@ -2388,6 +2388,58 @@
 	  `((list ,@(reverse (cdr arg1)))))
 	rtypes)))
 
+(let ()
+  ;; See comment in vector (let)
+  (define (report loc msg . args)
+    (warning
+     (conc (location-name loc)
+	   (sprintf "~?" msg (map unrename-type args)))))
+
+  (define (append-special-case node args loc rtypes)
+    (define (potentially-proper-list? l) (match-types l 'list '()))
+
+    (define (derive-result-type)
+      (let lp ((arg-types (cdr args))
+               (index 1))
+        (if (null? arg-types)
+            'null
+            (let ((arg1 (walked-result (car arg-types))))
+              (cond
+               ((and (pair? arg1) (eq? (car arg1) 'list))
+                (and-let* ((rest-t (lp (cdr arg-types) (add1 index))))
+                  ;; decanonicalize, then recanonicalize to make it
+                  ;; easy to append a variety of types.
+                  (canonicalize-list-type
+                   (foldl (lambda (rest t) `(pair ,t ,rest))
+                          rest-t (reverse (cdr arg1))))))
+
+               ((and (pair? arg1) (eq? (car arg1) 'list-of))
+                (and-let* ((rest-t (lp (cdr arg-types) (add1 index))))
+                  ;; list-of's length unsurety is "contagious"
+                  (simplify-type `(or ,arg1 ,rest-t))))
+
+               ;; TODO: (append (pair x (pair y z)) lst) =>
+               ;; (pair x (pair y (or z lst)))
+               ;; This is trickier than it sounds!
+
+               (else
+                ;; The final argument may be an atom or improper list
+                (unless (or (null? (cdr arg-types))
+                            (potentially-proper-list? arg1))
+                  (report
+                   loc "~ain procedure call to `~s', argument #~a is \
+                        of type ~a but expected a proper list"
+                   (node-source-prefix node)
+                   (first (node-parameters
+                           (first (node-subexpressions node))))
+                   index arg1))
+                #f))))))
+    (cond ((derive-result-type) => list)
+          (else rtypes)))
+
+  (define-special-case append append-special-case)
+  (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)
diff --git a/tests/scrutiny-tests.scm b/tests/scrutiny-tests.scm
index 30c7460..5fac5ba 100644
--- a/tests/scrutiny-tests.scm
+++ b/tests/scrutiny-tests.scm
@@ -295,3 +295,19 @@
   (define (list-ref-type-nowarn2) (add1 (list-ref l2 1))))
 (let ((l3 (the (list-of fixnum) '(1 2 3))))
   (define (list-ref-type-nowarn3) (add1 (list-ref l3 1))))
+
+;; Test type preservation of append (TODO: decouple from list-ref)
+(let ((l1 (append (list 'x 'y) (list 1 2 (eval '(list))))))
+  (define (append-result-type-warn1) (add1 (list-ref l1 1))))
+;; This currently doesn't warn because pair types aren't joined yet
+#;(let ((l2 (append (cons 'x (cons 'y (eval '(list)))) (list 'x 'y))))
+  (define (append-result-type-warn2) (add1 (list-ref l2 1))))
+(let ((l3 (append (the (list-of symbol) '(x y)) '(a b))))
+  (define (append-result-type-warn2) (add1 (list-ref l3 3))))
+
+(let ((l1 (append (list 1 2) (list 'x 'y (eval '(list))))))
+  (define (append-result-type-nowarn1) (add1 (list-ref l1 1))))
+(let ((l2 (append (cons 1 (cons 2 (eval '(list)))) (list 'x))))
+  (define (append-result-type-nowarn2) (add1 (list-ref l2 1))))
+(let ((l3 (append (the (list-of fixnum) '(1 2)) '(x y))))
+  (define (append-result-type-nowarn3) (add1 (list-ref l3 1))))
diff --git a/tests/scrutiny.expected b/tests/scrutiny.expected
index 31871de..98ac177 100644
--- a/tests/scrutiny.expected
+++ b/tests/scrutiny.expected
@@ -201,4 +201,10 @@ Warning: in toplevel procedure `list-ref-type-warn2':
 Warning: in toplevel procedure `list-ref-type-warn3':
   (scrutiny-tests.scm:289) in procedure call to `add1', expected argument #1 of type `number' but was given an argument of type `symbol'
 
+Warning: in toplevel procedure `append-result-type-warn1':
+  (scrutiny-tests.scm:301) in procedure call to `add1', expected argument #1 of type `number' but was given an argument of type `symbol'
+
+Warning: in toplevel procedure `append-result-type-warn2':
+  (scrutiny-tests.scm:306) in procedure call to `add1', expected argument #1 of type `number' but was given an argument of type `symbol'
+
 Warning: redefinition of standard binding: car
diff --git a/types.db b/types.db
index 4d0b88d..12014e8 100644
--- a/types.db
+++ b/types.db
@@ -169,6 +169,7 @@
 (list-tail (forall (a) (#(procedure #:clean #:enforce) list-tail ((list-of a) fixnum) (list-of a))))
 (list-ref (forall (a) (#(procedure #:clean #:enforce) list-ref ((list-of a) fixnum) a)))
 
+;; special cased (see scrutinizer.scm)
 (append (#(procedure #:clean) append (#!rest *) *)) ; sic
 (##sys#append (#(procedure #:clean) ##sys#append (#!rest *) *))
 
-- 
2.1.4