From c5691539d01b47625dfbb278bc4372dee03cc1b5 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 b143b0c..51bf9ad 100644
--- a/scrutinizer.scm
+++ b/scrutinizer.scm
@@ -2332,6 +2332,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 type-name 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 a9f1942..546c523 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 7d02af3..ef9befd 100644
--- a/tests/scrutiny.expected
+++ b/tests/scrutiny.expected
@@ -206,4 +206,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 c22d981..c9640d9 100644
--- a/types.db
+++ b/types.db
@@ -174,6 +174,7 @@
 (list-tail (forall (a) (#(procedure #:clean #:enforce #:foldable) list-tail ((list-of a) fixnum) (list-of a))))
 (list-ref (forall (a) (#(procedure #:clean #:enforce #:foldable) 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