From 1ab1dd29f2602c87d404492e588abdf5f6abfbf2 Mon Sep 17 00:00:00 2001 From: Nikodemus Siivola Date: Mon, 15 Mar 2010 09:13:59 +0000 Subject: [PATCH] 1.0.36.24: FIND/POSITION bounds checking on lists * Signal an error if the list is shorter than required, and also check for circularity. Based on patch by: Jorge Tavares Fixes launchpad bug #452008. * Also add declarations for some error signaling functions used by sequence code so that compiler knows they never return. --- NEWS | 2 ++ package-data-list.lisp-expr | 1 + src/code/seq.lisp | 12 +++++++ src/compiler/seqtran.lisp | 78 ++++++++++++++++++++++++------------------- tests/seq.pure.lisp | 37 ++++++++++++++++++++ version.lisp-expr | 2 +- 6 files changed, 97 insertions(+), 35 deletions(-) diff --git a/NEWS b/NEWS index 58a108f..bb43caf 100644 --- a/NEWS +++ b/NEWS @@ -41,6 +41,8 @@ changes relative to sbcl-1.0.36: (lp#528807) * bug fix: More consistent warnings and notes for ignored DYNAMIC-EXTENT declarations (lp#497321) + * bug fix: FIND and POSITION on lists did not check sequence bounds properly + and failed to detect circular lists (lp#452008) changes in sbcl-1.0.36 relative to sbcl-1.0.35: * new feature: SB-EXT:TYPEXPAND-1, SB-EXT:TYPEXPAND, and diff --git a/package-data-list.lisp-expr b/package-data-list.lisp-expr index 959d43e..42658c9 100644 --- a/package-data-list.lisp-expr +++ b/package-data-list.lisp-expr @@ -918,6 +918,7 @@ possibly temporariliy, because it might be used internally." "STANDARD-READTABLE-MODIFIED-ERROR" "STANDARD-PPRINT-DISPATCH-TABLE-MODIFIED-ERROR" "ARRAY-BOUNDING-INDICES-BAD-ERROR" + "CIRCULAR-LIST-ERROR" "SEQUENCE-BOUNDING-INDICES-BAD-ERROR" "SPECIAL-FORM-FUNCTION" "STYLE-WARN" "SIMPLE-COMPILER-NOTE" diff --git a/src/code/seq.lisp b/src/code/seq.lisp index f63ce3b..8c23fe3 100644 --- a/src/code/seq.lisp +++ b/src/code/seq.lisp @@ -224,6 +224,7 @@ ;; This seems silly, is there something better? '(integer 0 (0)))))) +(declaim (ftype (function (t t t) nil) sequence-bounding-indices-bad-error)) (defun sequence-bounding-indices-bad-error (sequence start end) (let ((size (length sequence))) (error 'bounding-indices-bad-error @@ -232,6 +233,7 @@ (integer ,start ,size)) :object sequence))) +(declaim (ftype (function (t t t) nil) array-bounding-indices-bad-error)) (defun array-bounding-indices-bad-error (array start end) (let ((size (array-total-size array))) (error 'bounding-indices-bad-error @@ -239,6 +241,16 @@ :expected-type `(cons (integer 0 ,size) (integer ,start ,size)) :object array))) + +(declaim (ftype (function (t) nil) circular-list-error)) +(defun circular-list-error (list) + (let ((*print-circle* t)) + (error 'simple-type-error + :format-control "List is circular:~% ~S" + :format-arguments (list list) + :datum list + :type '(and list (satisfies list-length))))) + (defun elt (sequence index) #!+sb-doc "Return the element of SEQUENCE specified by INDEX." diff --git a/src/compiler/seqtran.lisp b/src/compiler/seqtran.lisp index 0074e14..466496d 100644 --- a/src/compiler/seqtran.lisp +++ b/src/compiler/seqtran.lisp @@ -1195,41 +1195,51 @@ * :policy (> speed space)) "expand inline" - `(let ((index 0) - (find nil) + `(let ((find nil) (position nil)) - (declare (type index index)) - (dolist (i sequence - (if (and end (> end index)) - (sequence-bounding-indices-bad-error - sequence start end) - (values find position))) - (when (and end (>= index end)) - (return (values find position))) - (when (>= index start) - (let ((key-i (funcall key i))) - (,',condition (funcall predicate key-i) - ;; This hack of dealing with non-NIL - ;; FROM-END for list data by iterating - ;; forward through the list and keeping - ;; track of the last time we found a - ;; match might be more screwy than what - ;; the user expects, but it seems to be - ;; allowed by the ANSI standard. (And - ;; if the user is screwy enough to ask - ;; for FROM-END behavior on list data, - ;; turnabout is fair play.) - ;; - ;; It's also not enormously efficient, - ;; calling PREDICATE and KEY more often - ;; than necessary; but all the - ;; alternatives seem to have their own - ;; efficiency problems. - (if from-end - (setf find i - position index) - (return (values i index)))))) - (incf index)))))) + (flet ((bounds-error () + (sequence-bounding-indices-bad-error sequence start end))) + (if (and end (> start end)) + (bounds-error) + (do ((slow sequence (cdr slow)) + (fast (cdr sequence) (cddr fast)) + (index 0 (+ index 1))) + ((cond ((null slow) + (if (and end (> end index)) + (bounds-error) + (return (values find position)))) + ((and end (>= index end)) + (return (values find position))) + ((eq slow fast) + (circular-list-error sequence))) + (bug "never")) + (declare (list slow fast)) + (when (>= index start) + (let* ((element (car slow)) + (key-i (funcall key element))) + (,',condition (funcall predicate key-i) + ;; This hack of dealing with non-NIL + ;; FROM-END for list data by iterating + ;; forward through the list and keeping + ;; track of the last time we found a + ;; match might be more screwy than what + ;; the user expects, but it seems to be + ;; allowed by the ANSI standard. (And + ;; if the user is screwy enough to ask + ;; for FROM-END behavior on list data, + ;; turnabout is fair play.) + ;; + ;; It's also not enormously efficient, + ;; calling PREDICATE and KEY more often + ;; than necessary; but all the + ;; alternatives seem to have their own + ;; efficiency problems. + (if from-end + (setf find element + position index) + (unless find + (setf find element + position index))))))))))))) (def %find-position-if when) (def %find-position-if-not unless)) diff --git a/tests/seq.pure.lisp b/tests/seq.pure.lisp index fcba6c9..eb75013 100644 --- a/tests/seq.pure.lisp +++ b/tests/seq.pure.lisp @@ -11,6 +11,8 @@ ;;;; absolutely no warranty. See the COPYING and CREDITS files for ;;;; more information. +(in-package :cl-user) + ;;; As reported by Paul Dietz from his ansi-test suite for gcl, REMOVE ;;; malfunctioned when given :START, :END and :FROM-END arguments. ;;; Make sure it doesn't happen again. @@ -205,3 +207,38 @@ (b1 (make-array bsize :element-type '(unsigned-byte 8))) (b2 (make-array l :element-type '(unsigned-byte 8)))) (replace b1 b2 :start2 0 :end2 l)))))) + +(with-test (:name :bug-452008) + ;; FIND & POSITION on lists should check bounds and (in safe code) detect + ;; circular and dotted lists. + (macrolet ((test (type lambda) + `(let ((got (handler-case + (funcall (compile nil ',lambda)) + (,type () :error) + (:no-error (res) + (list :no-error res))))) + (let ((*print-circle* t)) + (format t "test: ~S~%" ',lambda)) + (unless (eq :error got) + (error "wanted an error, got ~S for~% ~S" + (second got) ',lambda))))) + (test sb-kernel:bounding-indices-bad-error + (lambda () + (find :foo '(1 2 3 :foo) :start 1 :end 5))) + (test sb-kernel:bounding-indices-bad-error + (lambda () + (position :foo '(1 2 3 :foo) :start 1 :end 5))) + (test sb-kernel:bounding-indices-bad-error + (lambda () + (find :foo '(1 2 3 :foo) :start 3 :end 0))) + (test sb-kernel:bounding-indices-bad-error + (lambda () + (position :foo '(1 2 3 :foo) :start 3 :end 0))) + (test type-error + (lambda () + (let ((list (list 1 2 3 :foo))) + (find :bar (nconc list list))))) + (test type-error + (lambda () + (let ((list (list 1 2 3 :foo))) + (position :bar (nconc list list))))))) diff --git a/version.lisp-expr b/version.lisp-expr index cfbafdf..bb03be7 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -17,4 +17,4 @@ ;;; checkins which aren't released. (And occasionally for internal ;;; versions, especially for internal versions off the main CVS ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".) -"1.0.36.23" +"1.0.36.24" -- 1.7.10.4