~ chicken-core (chicken-5) 9b47664db26526a8075020fcfb55dd69b40d9557

commit 9b47664db26526a8075020fcfb55dd69b40d9557
Author:     Evan Hanson <evhan@foldling.org>
AuthorDate: Mon Jan 27 21:48:12 2014 +1300
Commit:     Moritz Heidkamp <moritz@twoticketsplease.de>
CommitDate: Mon Jan 27 20:41:46 2014 +0100

    Fix validation for multiple-return procedure types
    
    Validation for procedure types like (a -> . b) relied on the pre-0a52536
    behavior of memq, where a failed search on an improper list would return
    false rather than raise an error. After that change, such types are
    rejected as invalid, so this adds a local memq variant to the
    scrutinizer that reproduces the old behavior, as a workaround to
    re-support this type syntax.
    
    Signed-off-by: Moritz Heidkamp <moritz@twoticketsplease.de>

diff --git a/scrutinizer.scm b/scrutinizer.scm
index e29e8477..695a7578 100644
--- a/scrutinizer.scm
+++ b/scrutinizer.scm
@@ -1948,6 +1948,11 @@
       (let loop ((lst lst))
 	(cond ((eq? lst p) '())
 	      (else (cons (car lst) (loop (cdr lst)))))))
+    (define (memq* x lst) ; memq, but allow improper list
+      (let loop ((lst lst))
+	(cond ((not (pair? lst)) #f)
+	      ((eq? (car lst) x) lst)
+	      (else (loop (cdr lst))))))
     (define (validate-llist llist)
       (cond ((null? llist) '())
 	    ((symbol? llist) '(#!rest *))
@@ -2029,12 +2034,12 @@
 		  t))
 	    ((eq? 'deprecated (car t))
 	     (and (= 2 (length t)) (symbol? (second t)) t))
-	    ((and (list? t) (or (memq '--> t) (memq '-> t))) =>
+	    ((or (memq* '--> t) (memq* '-> t)) =>
 	     (lambda (p)
 	       (let* ((cleanf (eq? '--> (car p)))
 		      (ok (or (not rec) (not cleanf))))
 		 (unless rec (set! clean cleanf))
-		 (let ((cp (memq ': (cdr p))))
+		 (let ((cp (memq* ': p)))
 		   (cond ((not cp)
 			  (and ok
 			       (validate
diff --git a/tests/scrutiny-tests.scm b/tests/scrutiny-tests.scm
index 67ce5a50..3ac754f9 100644
--- a/tests/scrutiny-tests.scm
+++ b/tests/scrutiny-tests.scm
@@ -158,3 +158,6 @@
 (apply1 + (list 'a 2 3)) ; <- no type warning (#948)
 (apply1 + (cons 'a (cons 2 (cons 3 '())))) ; <- same here (#952)
 
+;; multiple-value return syntax
+(: mv (-> . *))
+(: mv (procedure () . *))