>From b6a170cbe9d0eee1ca882bb25ca1813ff6bcfdd5 Mon Sep 17 00:00:00 2001 From: felix Date: Fri, 10 Feb 2012 13:45:15 +0100 Subject: [PATCH 1/2] 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 --- scrutinizer.scm | 76 ++++++++++++++++++++++++++++-------------------------- 1 files changed, 39 insertions(+), 37 deletions(-) diff --git a/scrutinizer.scm b/scrutinizer.scm index 332ed2e..e9f3414 100755 --- 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 -- 1.7.9.1