(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
"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"
;; 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
(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
: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)))))
+
\f
(defun elt (sequence index)
#!+sb-doc "Return the element of SEQUENCE specified by INDEX."
*
: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))
;;;; 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.
(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)))))))
;;; 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"
projects / sbcl.git / commitdiff