~ chicken-core (chicken-5) e89f3e98e57aefb217356b623c78260ea86a874e

commit e89f3e98e57aefb217356b623c78260ea86a874e
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:23:01 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 3502106c..abdf764d 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 30c74608..5fac5bad 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 31871de4..98ac177c 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 4d0b88d6..12014e8f 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 *) *))