~ chicken-core (chicken-5) 89ca56364924e653fc08bf32e61a12ba74af70ef

commit 89ca56364924e653fc08bf32e61a12ba74af70ef
Author:     felix <address@hidden>
AuthorDate: Fri Feb 10 13:45:15 2012 +0100
Commit:     felix <felix@call-with-current-continuation.org>
CommitDate: Fri Mar 16 08:24:21 2012 +0100

    fixed bug in handling of scrutinizer special cases for vector-ref/list-ref/list-tail when too few arguments where given
    
    Signed-off-by: Peter Bex <address@hidden>
    Signed-off-by: felix <felix@call-with-current-continuation.org>

diff --git a/scrutinizer.scm b/scrutinizer.scm
old mode 100644
new mode 100755
index 94f4ec35..8d733f5f
--- a/scrutinizer.scm
+++ b/scrutinizer.scm
@@ -2157,55 +2157,57 @@
 
 (let ()
   (define (vector-ref-result-type node args rtypes)
-    (or (let ((subs (node-subexpressions node))
-	      (arg1 (second args)))
-	  (and (pair? arg1)
-	       (eq? 'vector (car arg1))
-	       (= (length subs) 3)
-	       (let ((index (third subs)))
-		 (and (eq? 'quote (node-class index))
-		      (let ((val (first (node-parameters index))))
-			(and (fixnum? val)
-			     (>= val 0) (< val (length (cdr arg1))) ;XXX could warn on failure (but needs location)
-			     (list (list-ref (cdr arg1) val))))))))
+    (or (and-let* ((subs (node-subexpressions node))
+                   ((= (length subs) 3))
+                   (arg1 (second args))
+                   ((pair? arg1))
+                   ((eq? 'vector (car arg1)))
+                   (index (third subs))
+                   ((eq? 'quote (node-class index)))
+                   (val (first (node-parameters index)))
+                   ((fixnum? val))
+                   ((>= val 0))
+                   ((< val (length (cdr arg1))))) ;XXX could warn on failure (but needs location)
+          (list (list-ref (cdr arg1) val)))
 	rtypes))
   (define-special-case vector-ref vector-ref-result-type)
   (define-special-case ##sys#vector-ref vector-ref-result-type))
 
 (let ()
   (define (list-ref-result-type node args rtypes)
-    (or (let ((subs (node-subexpressions node))
-	      (arg1 (second args)))
-	  (and (pair? arg1)
-	       (eq? 'list (car arg1))
-	       (= (length subs) 3)
-	       (let ((index (third subs)))
-		 (and (eq? 'quote (node-class index))
-		      (let ((val (first (node-parameters index))))
-			(and (fixnum? val)
-			     (>= val 0) (< val (length (cdr arg1))) ;XXX could warn on failure (but needs location)
-			     (list (list-ref (cdr arg1) val))))))))
+    (or (and-let* ((subs (node-subexpressions node))
+                   ((= (length subs) 3))
+                   (arg1 (second args))
+                   ((pair? arg1))
+                   ((eq? 'list (car arg1)))
+                   (index (third subs))
+                   ((eq? 'quote (node-class index)))
+                   (val (first (node-parameters index)))
+                   ((fixnum? val))
+                   ((>= val 0))  ;XXX could warn on failure (but needs location)
+                   ((< val (length (cdr arg1)))))
+          (list (list-ref (cdr arg1) val)))
 	rtypes))
   (define-special-case list-ref list-ref-result-type)
   (define-special-case ##sys#list-ref list-ref-result-type))
 
 (define-special-case list-tail
   (lambda (node args rtypes)
-    (or (let ((subs (node-subexpressions node))
-	      (arg1 (second args)))
-	  (and (pair? arg1)
-	       (eq? 'list (car arg1))
-	       (= (length subs) 3)
-	       (let ((index (third subs)))
-		 (and (eq? 'quote (node-class index))
-		      (let ((val (first (node-parameters index))))
-			(and (fixnum? val)
-			     (>= val 0) (< val (length (cdr arg1))) ;XXX could warn on failure (but needs location)
-			     (let ((rest (list-tail (cdr arg1) val)))
-			       (list
-				(if (null? rest)
-				    'null
-				    `(list ,@rest))))))))))
+    (or (and-let* ((subs (node-subexpressions node))
+                   ((= (length subs) 3))
+                   (arg1 (second args))
+                   ((pair? arg1))
+                   ((eq? 'list (car arg1)))
+                   (index (third subs))
+                   ((eq? 'quote (node-class index)))
+                   (val (first (node-parameters index)))
+                   ((fixnum? val))
+                   ((>= val 0))
+                   ((< val (length (cdr arg1)))))   ;XXX could warn on failure (but needs location)
+          (let ((rest (list-tail (cdr arg1) val)))
+            (list (if (null? rest)
+                      'null
+                      `(list ,@rest)))))
 	rtypes)))
 
 (define-special-case list