~ chicken-core (chicken-5) e61b5e9ccef5254e908a6d5b31bdf5d793d17046

commit e61b5e9ccef5254e908a6d5b31bdf5d793d17046
Author:     Peter Bex <peter@more-magic.net>
AuthorDate: Sun Jul 24 20:04:20 2016 +0200
Commit:     Evan Hanson <evhan@foldling.org>
CommitDate: Mon Jul 25 10:22:57 2016 +1200

    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.
    
    Signed-off-by: Evan Hanson <evhan@foldling.org>

diff --git a/scrutinizer.scm b/scrutinizer.scm
index b143b0cf..5f1dd8ce 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 `~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))
+		#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 a9f1942c..546c5238 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 7d02af33..ef9befd1 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 c22d9819..c9640d9b 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 *) *))