[Chicken-hackers] [PATCH] fix special cases for vector/list-ref in scrutinizer when argument count is wrong

[Felix]

The attached patch fixes the bug in the scrutinizer when list-ref/vector-ref 
are called with a wrong number of arguments.


cheers,
felix

>From f447e2d80c78e720c3c014d328b837c9c3040e15 Mon Sep 17 00:00:00 2001
From: felix <address@hidden>
Date: Fri, 10 Feb 2012 13:45:15 +0100
Subject: [PATCH] fixed bug in handling of scrutinizer special cases for 
vector-ref/list-ref/list-tail when too few arguments where given

---
 scrutinizer.scm |   74 +++++++++++++++++++++++++++---------------------------
 1 files changed, 37 insertions(+), 37 deletions(-)

diff --git a/scrutinizer.scm b/scrutinizer.scm
index dd2d0a0..8e92f4a 100755
--- a/scrutinizer.scm
+++ b/scrutinizer.scm
@@ -2153,55 +2153,55 @@
 
 (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 (let ((subs (node-subexpressions node)))
+         (and (= (length subs) 3)
+              (let ((arg1 (second args)))
+                (and (pair? arg1)
+                     (eq? 'vector (car arg1))
+                     (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))))))))))
        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 (let ((subs (node-subexpressions node)))
+         (and (= (length subs) 3)
+              (let ((arg1 (second args)))
+                (and (pair? arg1)
+                     (eq? 'list (car arg1))
+                     (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))))))))))
        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 (let ((subs (node-subexpressions node)))
+         (and (= (length subs) 3)
+              (let ((arg1 (second args)))
+                (and (pair? arg1)
+                     (eq? 'list (car arg1))
+                     (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))))))))))))
        rtypes)))
 
 (define-special-case list
-- 
1.6.0.4