calls of the form (TYPEP 1 'INTEGER NIL), even though this is
just as optimizeable as (TYPEP 1 'INTEGER).
+238: "REPL compiler overenthusiasm for CLOS code"
+ From the REPL,
+ * (defclass foo () ())
+ * (defmethod bar ((x foo) (foo foo)) (call-next-method))
+ causes approximately 100 lines of code deletion notes. Some
+ discussion on this issue happened under the title 'Three "interesting"
+ bugs in PCL', resulting in a fix for this oververbosity from the
+ compiler proper; however, the problem persists in the interactor
+ because the notion of original source is not preserved: for the
+ compiler, the original source of the above expression is (DEFMETHOD
+ BAR ((X FOO) (FOO FOO)) (CALL-NEXT-METHOD)), while by the time the
+ compiler gets its hands on the code needing compilation from the REPL,
+ it has been macroexpanded several times.
+
DEFUNCT CATEGORIES OF BUGS
IR1-#:
These labels were used for bugs related to the old IR1 interpreter.
unprintable packages can now be defined.
* fixed a bug in RESTART-BIND: The :TEST-FUNCTION option had been
carelessly renamed to :TEST-FUN. (thanks to Robert E. Brown)
+ * fixed compiler failure related to checking types of functions.
+ (reported by Robert E. Brown)
+ * the compiler is now much more consistent in its error-checking
+ treatment of bounding index arguments to sequence functions: in
+ (SAFETY 3) code, errors will be signalled in almost all cases if
+ invalid sequence bounding indices are passed to functions defined
+ by ANSI to operate on sequences.
* fixed some bugs revealed by Paul Dietz' test suite:
** ARRAY-IN-BOUNDS-P now allows arbitrary integers as arguments,
not just nonnegative fixnums;
** the logical bit-array operators such as BIT-AND now accept an
explicit NIL for their "opt-arg" argument (to indicate a
freshly-consed result bit-array);
- * fixed compiler failure related to checking types of functions
- (reported by Robert E. Brown);
planned incompatible changes in 0.7.x:
* (not done yet, but planned:) When the profiling interface settles
"%ARRAY-FILL-POINTER-P"
"%ASIN" "%ASINH"
"%ATAN" "%ATAN2" "%ATANH"
- "%CALLER-FRAME-AND-PC" "%CHECK-BOUND" "%CLOSURE-FUN"
+ "%CALLER-FRAME-AND-PC" "%CHECK-BOUND"
+ "%CHECK-VECTOR-SEQUENCE-BOUNDS" "%CLOSURE-FUN"
"%CLOSURE-INDEX-REF" "%COS" "%COS-QUICK"
"%COSH" "%DATA-VECTOR-AND-INDEX"
"%DEPOSIT-FIELD"
"BINDING-STACK-POINTER-SAP" "BIT-BASH-COPY"
"BIT-INDEX" "BOGUS-ARG-TO-VALUES-LIST-ERROR"
"BOOLE-CODE"
+ "BOUNDING-INDICES-BAD-ERROR"
"BYTE-SPECIFIER"
"%BYTE-BLT"
"CALLABLE" "CASE-BODY-ERROR"
"FLOAT-WAIT"
"DYNAMIC-SPACE-FREE-POINTER" "DYNAMIC-USAGE"
"EFFECTIVE-FIND-POSITION-TEST" "EFFECTIVE-FIND-POSITION-KEY"
- "END-TOO-LARGE-ERROR"
"ERROR-NUMBER-OR-LOSE"
"FAILED-%WITH-ARRAY-DATA"
"FDEFINITION-OBJECT"
"The index ~S is too large."
(type-error-datum condition)))))
-;;; Out-of-range &KEY END arguments are similar to, but off by one
-;;; from out-of-range indices into the sequence.
-;;;
-;;; FIXME: Uh, but it isn't used for &KEY END things -- in fact, this
-;;; is only used in one place, in SUBSEQ. Is it really necessary? Is
-;;; it here so that we can actually go round seq.lisp decorating all
-;;; the sequence functions with extra checks? -- CSR, 2002-11-01
-(define-condition end-too-large-error (type-error)
- ()
+(define-condition bounding-indices-bad-error (type-error)
+ ((object :reader bounding-indices-bad-object :initarg :object))
(:report
(lambda (condition stream)
- (format stream
- "The end-of-sequence specifier ~S is too large."
- (type-error-datum condition)))))
+ (let* ((datum (type-error-datum condition))
+ (start (car datum))
+ (end (cdr datum))
+ (object (bounding-indices-bad-object condition)))
+ (etypecase object
+ (sequence
+ (format stream
+ "The bounding indices ~S and ~S are bad for a sequence of length ~S."
+ start end (length object)))
+ (array
+ ;; from WITH-ARRAY-DATA
+ (format stream
+ "The START and END parameters ~S and ~S are bad for an array of total size ~S."
+ start end (array-total-size object))))))))
(define-condition io-timeout (stream-error)
((direction :reader io-timeout-direction :initarg :direction))
and the lisp object built by the reader is returned. Macro chars
will take effect."
(declare (string string))
+
(with-array-data ((string string)
(start start)
- (end (or end (length string))))
+ (end (%check-vector-sequence-bounds string start end)))
(unless *read-from-string-spares*
(push (internal-make-string-input-stream "" 0 0)
*read-from-string-spares*))
:format-arguments (list string))))
(with-array-data ((string string)
(start start)
- (end (or end (length string))))
+ (end (%check-vector-sequence-bounds string start end)))
(let ((index (do ((i start (1+ i)))
((= i end)
(if junk-allowed
(eval-when (:compile-toplevel)
-(defvar *sequence-keyword-info*
+(defparameter *sequence-keyword-info*
;; (name default supplied-p adjustment new-type)
- '((count nil
+ `((count nil
nil
(etypecase count
(null (1- most-positive-fixnum))
(integer (if (minusp count)
0
(1- most-positive-fixnum))))
- (mod #.sb!xc:most-positive-fixnum))))
+ (mod #.sb!xc:most-positive-fixnum))
+ ,@(mapcan (lambda (names)
+ (destructuring-bind (start end length sequence) names
+ (list
+ `(,start
+ 0
+ nil
+ (if (<= 0 ,start ,length)
+ ,start
+ (signal-bounding-indices-bad-error ,sequence
+ ,start ,end))
+ index)
+ `(,end
+ nil
+ nil
+ (if (or (null ,end) (<= ,start ,end ,length))
+ ;; Defaulting of NIL is done inside the
+ ;; bodies, for ease of sharing with compiler
+ ;; transforms.
+ ;;
+ ;; FIXME: defend against non-number non-NIL
+ ;; stuff?
+ ,end
+ (signal-bounding-indices-bad-error ,sequence
+ ,start ,end))
+ (or null index)))))
+ '((start end length sequence)
+ (start1 end1 length1 sequence1)
+ (start2 end2 length2 sequence2)))
+ ))
(sb!xc:defmacro define-sequence-traverser (name args &body body)
(multiple-value-bind (body declarations docstring)
(parse-body body t)
(collect ((new-args) (new-declarations) (adjustments))
(dolist (arg args)
- (let ((info (cdr (assoc arg *sequence-keyword-info*))))
- (cond (info
- (destructuring-bind (default supplied-p adjuster type) info
- (new-args `(,arg ,default ,@(when supplied-p (list supplied-p))))
- (adjustments `(,arg ,adjuster))
- (new-declarations `(type ,type ,arg))))
- (t (new-args arg)))))
+ (case arg
+ ;; FIXME: make this robust. And clean.
+ ((sequence)
+ (new-args arg)
+ (adjustments '(length (etypecase sequence
+ (list (length sequence))
+ (vector (length sequence)))))
+ (new-declarations '(type index length)))
+ ((sequence1)
+ (new-args arg)
+ (adjustments '(length1 (etypecase sequence1
+ (list (length sequence1))
+ (vector (length sequence1)))))
+ (new-declarations '(type index length1)))
+ ((sequence2)
+ (new-args arg)
+ (adjustments '(length2 (etypecase sequence2
+ (list (length sequence2))
+ (vector (length sequence2)))))
+ (new-declarations '(type index length2)))
+ (t (let ((info (cdr (assoc arg *sequence-keyword-info*))))
+ (cond (info
+ (destructuring-bind (default supplied-p adjuster type) info
+ (new-args `(,arg ,default ,@(when supplied-p (list supplied-p))))
+ (adjustments `(,arg ,adjuster))
+ (new-declarations `(type ,type ,arg))))
+ (t (new-args arg)))))))
`(defun ,name ,(new-args)
- ,docstring
+ ,@(when docstring (list docstring))
,@declarations
- (let (,@(adjustments))
+ (let* (,@(adjustments))
(declare ,@(new-declarations))
,@body)))))
(vector-of-checked-length-given-length sequence
declared-length))))))
+(declaim (ftype (function (sequence index) nil) signal-index-too-large-error))
(defun signal-index-too-large-error (sequence index)
(let* ((length (length sequence))
(max-index (and (plusp length)
;; This seems silly, is there something better?
'(integer 0 (0))))))
-(defun signal-end-too-large-error (sequence end)
- (let* ((length (length sequence))
- (max-end length))
- (error 'end-too-large-error
- :datum end
- :expected-type `(integer 0 ,max-end))))
-
+(declaim (ftype (function (sequence index index) nil)
+ signal-bounding-indices-bad-error))
+(defun signal-bounding-indices-bad-error (sequence start end)
+ (let ((length (length sequence)))
+ (error 'bounding-indices-bad-error
+ :datum (cons start end)
+ :expected-type `(cons (integer 0 ,length)
+ (or null (integer ,start ,length)))
+ :object sequence)))
\f
(defun elt (sequence index)
#!+sb-doc "Return the element of SEQUENCE specified by INDEX."
(vector (length (truly-the vector sequence)))
(list (length (truly-the list sequence)))))
-(defun make-sequence (type length &key (initial-element NIL iep))
+(defun make-sequence (type length &key (initial-element nil iep))
#!+sb-doc
"Return a sequence of the given TYPE and LENGTH, with elements initialized
to :INITIAL-ELEMENT."
(defun vector-subseq* (sequence start &optional end)
(declare (type vector sequence))
- (declare (type fixnum start))
- (declare (type (or null fixnum) end))
- (if (null end)
- (setf end (length sequence))
- (unless (<= end (length sequence))
- (signal-end-too-large-error sequence end)))
+ (declare (type index start))
+ (declare (type (or null index) end))
+ (when (null end)
+ (setf end (length sequence)))
+ (unless (<= 0 start end (length sequence))
+ (signal-bounding-indices-bad-error sequence start end))
(do ((old-index start (1+ old-index))
(new-index 0 (1+ new-index))
(copy (make-sequence-like sequence (- end start))))
(defun list-subseq* (sequence start &optional end)
(declare (type list sequence))
- (declare (type fixnum start))
- (declare (type (or null fixnum) end))
- (if (and end (>= start (the fixnum end)))
- ()
- (let* ((groveled (nthcdr start sequence))
- (result (list (car groveled))))
- (if groveled
- (do ((list (cdr groveled) (cdr list))
- (splice result (cdr (rplacd splice (list (car list)))))
- (index (1+ start) (1+ index)))
- ((or (atom list) (and end (= index (the fixnum end))))
- result)
- (declare (fixnum index)))
- ()))))
-
-;;; SUBSEQ cannot default END to the length of sequence since it is
-;;; not an error to supply NIL for its value. We must test for END
-;;; being NIL in the body of the function, and this is actually done
-;;; in the support routines for other reasons. (See above.)
+ ;; the INDEX declaration isn't actually mandatory, but it's true for
+ ;; all practical purposes.
+ (declare (type index start))
+ (declare (type (or null index) end))
+ (do ((list sequence (cdr list))
+ (index 0 (1+ index))
+ (result nil))
+ (nil)
+ (cond
+ ((null list) (if (or (and end (> end index))
+ (< index start))
+ (signal-bounding-indices-bad-error sequence start end)
+ (return (nreverse result))))
+ ((< index start) nil)
+ ((and end (= index end)) (return (nreverse result)))
+ (t (push (car list) result)))))
+
(defun subseq (sequence start &optional end)
#!+sb-doc
"Return a copy of a subsequence of SEQUENCE starting with element number
(when (null end) (setq end (length sequence)))
(vector-fill sequence item start end))
-;;; FILL cannot default end to the length of sequence since it is not
-;;; an error to supply nil for its value. We must test for end being nil
-;;; in the body of the function, and this is actually done in the support
-;;; routines for other reasons (see above).
-(defun fill (sequence item &key (start 0) end)
+(define-sequence-traverser fill (sequence item &key start end)
#!+sb-doc "Replace the specified elements of SEQUENCE with ITEM."
(seq-dispatch sequence
(list-fill* sequence item start end)
(when (null source-end) (setq source-end (length source-sequence)))
(mumble-replace-from-mumble))
-;;; REPLACE cannot default END arguments to the length of SEQUENCE since it
-;;; is not an error to supply NIL for their values. We must test for ENDs
-;;; being NIL in the body of the function.
-(defun replace (target-sequence source-sequence &key
- ((:start1 target-start) 0)
- ((:end1 target-end))
- ((:start2 source-start) 0)
- ((:end2 source-end)))
+(define-sequence-traverser replace
+ (sequence1 sequence2 &key start1 end1 start2 end2)
#!+sb-doc
"The target sequence is destructively modified by copying successive
elements into it from the source sequence."
- (let ((target-end (or target-end (length target-sequence)))
- (source-end (or source-end (length source-sequence))))
+ (let* (;; KLUDGE: absent either rewriting FOO-REPLACE-FROM-BAR, or
+ ;; excessively polluting DEFINE-SEQUENCE-TRAVERSER, we rebind
+ ;; these things here so that legacy code gets the names it's
+ ;; expecting. We could use &AUX instead :-/.
+ (target-sequence sequence1)
+ (source-sequence sequence2)
+ (target-start start1)
+ (source-start start2)
+ (target-end (or end1 length1))
+ (source-end (or end2 length2)))
(seq-dispatch target-sequence
(seq-dispatch source-sequence
(list-replace-from-list)
) ; EVAL-WHEN
-(defun reduce (function sequence &key key from-end (start 0)
- end (initial-value nil ivp))
+(define-sequence-traverser reduce
+ (function sequence &key key from-end start end (initial-value nil ivp))
(declare (type index start))
(let ((start start)
- (end (or end (length sequence))))
+ (end (or end length)))
(declare (type index start end))
(cond ((= end start)
(if ivp initial-value (funcall function)))
) ; EVAL-WHEN
(define-sequence-traverser delete
- (item sequence &key from-end (test #'eql) test-not (start 0)
+ (item sequence &key from-end (test #'eql) test-not start
end count key)
#!+sb-doc
"Return a sequence formed by destructively removing the specified ITEM from
the given SEQUENCE."
(declare (fixnum start))
- (let* ((length (length sequence))
- (end (or end length)))
- (declare (type index length end))
+ (let ((end (or end length)))
+ (declare (type index end))
(seq-dispatch sequence
(if from-end
(normal-list-delete-from-end)
) ; EVAL-WHEN
(define-sequence-traverser delete-if
- (predicate sequence &key from-end (start 0) key end count)
+ (predicate sequence &key from-end start key end count)
#!+sb-doc
"Return a sequence formed by destructively removing the elements satisfying
the specified PREDICATE from the given SEQUENCE."
(declare (fixnum start))
- (let* ((length (length sequence))
- (end (or end length)))
- (declare (type index length end))
+ (let ((end (or end length)))
+ (declare (type index end))
(seq-dispatch sequence
(if from-end
(if-list-delete-from-end)
) ; EVAL-WHEN
(define-sequence-traverser delete-if-not
- (predicate sequence &key from-end (start 0) end key count)
+ (predicate sequence &key from-end start end key count)
#!+sb-doc
"Return a sequence formed by destructively removing the elements not
satisfying the specified PREDICATE from the given SEQUENCE."
(declare (fixnum start))
- (let* ((length (length sequence))
- (end (or end length)))
- (declare (type index length end))
+ (let ((end (or end length)))
+ (declare (type index end))
(seq-dispatch sequence
(if from-end
(if-not-list-delete-from-end)
) ; EVAL-WHEN
(define-sequence-traverser remove
- (item sequence &key from-end (test #'eql) test-not (start 0)
+ (item sequence &key from-end (test #'eql) test-not start
end count key)
#!+sb-doc
"Return a copy of SEQUENCE with elements satisfying the test (default is
EQL) with ITEM removed."
(declare (fixnum start))
- (let* ((length (length sequence))
- (end (or end length)))
- (declare (type index length end))
+ (let ((end (or end length)))
+ (declare (type index end))
(seq-dispatch sequence
(if from-end
(normal-list-remove-from-end)
(normal-mumble-remove)))))
(define-sequence-traverser remove-if
- (predicate sequence &key from-end (start 0) end count key)
+ (predicate sequence &key from-end start end count key)
#!+sb-doc
"Return a copy of sequence with elements such that predicate(element)
is non-null removed"
(declare (fixnum start))
- (let* ((length (length sequence))
- (end (or end length)))
- (declare (type index length end))
+ (let ((end (or end length)))
+ (declare (type index end))
(seq-dispatch sequence
(if from-end
(if-list-remove-from-end)
(if-mumble-remove)))))
(define-sequence-traverser remove-if-not
- (predicate sequence &key from-end (start 0) end count key)
+ (predicate sequence &key from-end start end count key)
#!+sb-doc
"Return a copy of sequence with elements such that predicate(element)
is null removed"
(declare (fixnum start))
- (let* ((length (length sequence))
- (end (or end length)))
- (declare (type index length end))
+ (let ((end (or end length)))
+ (declare (type index end))
(seq-dispatch sequence
(if from-end
(if-not-list-remove-from-end)
(setq jndex (1+ jndex)))
(shrink-vector result jndex)))
-(defun remove-duplicates
- (sequence &key (test #'eql) test-not (start 0) from-end end key)
+(define-sequence-traverser remove-duplicates
+ (sequence &key (test #'eql) test-not (start 0) end from-end key)
#!+sb-doc
"The elements of Sequence are compared pairwise, and if any two match,
the one occurring earlier is discarded, unless FROM-END is true, in
:end (if from-end jndex end) :test-not test-not)
(setq jndex (1+ jndex)))))
-(defun delete-duplicates
- (sequence &key (test #'eql) test-not (start 0) from-end end key)
+(define-sequence-traverser delete-duplicates
+ (sequence &key (test #'eql) test-not (start 0) end from-end key)
#!+sb-doc
"The elements of SEQUENCE are examined, and if any two match, one is
discarded. The resulting sequence, which may be formed by destroying the
(define-sequence-traverser substitute
(new old sequence &key from-end (test #'eql) test-not
- (start 0) count end key)
+ start count end key)
#!+sb-doc
"Return a sequence of the same kind as SEQUENCE with the same elements,
except that all elements equal to OLD are replaced with NEW. See manual
for details."
(declare (fixnum start))
- (let* ((length (length sequence))
- (end (or end length)))
- (declare (type index length end))
+ (let ((end (or end length)))
+ (declare (type index end))
(subst-dispatch 'normal)))
\f
;;;; SUBSTITUTE-IF, SUBSTITUTE-IF-NOT
(define-sequence-traverser substitute-if
- (new test sequence &key from-end (start 0) end count key)
+ (new test sequence &key from-end start end count key)
#!+sb-doc
"Return a sequence of the same kind as SEQUENCE with the same elements
except that all elements satisfying the TEST are replaced with NEW. See
manual for details."
(declare (fixnum start))
- (let* ((length (length sequence))
- (end (or end length))
- test-not
- old)
+ (let ((end (or end length))
+ test-not
+ old)
(declare (type index length end))
(subst-dispatch 'if)))
(define-sequence-traverser substitute-if-not
- (new test sequence &key from-end (start 0) end count key)
+ (new test sequence &key from-end start end count key)
#!+sb-doc
"Return a sequence of the same kind as SEQUENCE with the same elements
except that all elements not satisfying the TEST are replaced with NEW.
See manual for details."
(declare (fixnum start))
- (let* ((length (length sequence))
- (end (or end length))
- test-not
- old)
+ (let ((end (or end length))
+ test-not
+ old)
(declare (type index length end))
(subst-dispatch 'if-not)))
\f
(define-sequence-traverser nsubstitute
(new old sequence &key from-end (test #'eql) test-not
- end count key (start 0))
+ end count key start)
#!+sb-doc
"Return a sequence of the same kind as SEQUENCE with the same elements
except that all elements equal to OLD are replaced with NEW. The SEQUENCE
may be destructively modified. See manual for details."
(declare (fixnum start))
- (let ((end (or end (length sequence))))
+ (let ((end (or end length)))
(if (listp sequence)
(if from-end
(let ((length (length sequence)))
;;;; NSUBSTITUTE-IF, NSUBSTITUTE-IF-NOT
(define-sequence-traverser nsubstitute-if
- (new test sequence &key from-end (start 0) end count key)
+ (new test sequence &key from-end start end count key)
#!+sb-doc
"Return a sequence of the same kind as SEQUENCE with the same elements
except that all elements satisfying the TEST are replaced with NEW.
SEQUENCE may be destructively modified. See manual for details."
(declare (fixnum start))
- (let ((end (or end (length sequence))))
+ (let ((end (or end length)))
(declare (fixnum end))
(if (listp sequence)
(if from-end
(setq count (1- count)))))
(define-sequence-traverser nsubstitute-if-not
- (new test sequence &key from-end (start 0) end count key)
+ (new test sequence &key from-end start end count key)
#!+sb-doc
"Return a sequence of the same kind as SEQUENCE with the same elements
except that all elements not satisfying the TEST are replaced with NEW.
SEQUENCE may be destructively modified. See manual for details."
(declare (fixnum start))
- (let ((end (or end (length sequence))))
+ (let ((end (or end length)))
(declare (fixnum end))
(if (listp sequence)
(if from-end
(vector
(with-array-data ((sequence sequence-arg :offset-var offset)
(start start)
- (end (or end (length sequence-arg))))
+ (end (%check-vector-sequence-bounds
+ sequence-arg start end)))
(multiple-value-bind (f p)
(macrolet ((frob2 () '(if from-end
(frob sequence t)
) ; EVAL-WHEN
-(defun count-if (test sequence &key from-end (start 0) end key)
+(define-sequence-traverser count-if (test sequence &key from-end start end key)
#!+sb-doc
"Return the number of elements in SEQUENCE satisfying TEST(el)."
(declare (fixnum start))
- (let* ((length (length sequence))
- (end (or end length)))
+ (let ((end (or end length)))
(declare (type index end))
(seq-dispatch sequence
(if from-end
(vector-count-if nil t test sequence)
(vector-count-if nil nil test sequence)))))
-(defun count-if-not (test sequence &key from-end (start 0) end key)
+(define-sequence-traverser count-if-not
+ (test sequence &key from-end start end key)
#!+sb-doc
"Return the number of elements in SEQUENCE not satisfying TEST(el)."
(declare (fixnum start))
- (let* ((length (length sequence))
- (end (or end length)))
+ (let ((end (or end length)))
(declare (type index end))
(seq-dispatch sequence
(if from-end
(vector-count-if t t test sequence)
(vector-count-if t nil test sequence)))))
-(defun count (item sequence &key from-end (start 0) end
- key (test #'eql test-p) (test-not nil test-not-p))
+(define-sequence-traverser count
+ (item sequence &key from-end start end
+ key (test #'eql test-p) (test-not nil test-not-p))
#!+sb-doc
"Return the number of elements in SEQUENCE satisfying a test with ITEM,
which defaults to EQL."
;; ANSI Common Lisp has left the behavior in this situation unspecified.
;; (CLHS 17.2.1)
(error ":TEST and :TEST-NOT are both present."))
- (let* ((length (length sequence))
- (end (or end length)))
+ (let ((end (or end length)))
(declare (type index end))
(let ((%test (if test-not-p
(lambda (x)
) ; EVAL-WHEN
-(defun mismatch (sequence1 sequence2 &key from-end (test #'eql) test-not
- (start1 0) end1 (start2 0) end2 key)
+(define-sequence-traverser mismatch
+ (sequence1 sequence2
+ &key from-end (test #'eql) test-not
+ start1 end1 start2 end2 key)
#!+sb-doc
"The specified subsequences of SEQUENCE1 and SEQUENCE2 are compared
element-wise. If they are of equal length and match in every element, the
:FROM-END argument is given, then one plus the index of the rightmost
position in which the sequences differ is returned."
(declare (fixnum start1 start2))
- (let* ((length1 (length sequence1))
- (end1 (or end1 length1))
- (length2 (length sequence2))
+ (let* ((end1 (or end1 length1))
(end2 (or end2 length2)))
- (declare (type index length1 end1 length2 end2))
+ (declare (type index end1 end2))
(match-vars
(seq-dispatch sequence1
(matchify-list (sequence1 start1 length1 end1)
) ; EVAL-WHEN
-(defun search (sequence1 sequence2 &key from-end (test #'eql) test-not
- (start1 0) end1 (start2 0) end2 key)
+(define-sequence-traverser search
+ (sequence1 sequence2
+ &key from-end (test #'eql) test-not
+ start1 end1 start2 end2 key)
(declare (fixnum start1 start2))
- (let ((end1 (or end1 (length sequence1)))
- (end2 (or end2 (length sequence2))))
+ (let ((end1 (or end1 length1))
+ (end2 (or end2 length2)))
(seq-dispatch sequence2
(list-search sequence2 sequence1)
(vector-search sequence2 sequence1))))
(stream-fresh-line stream))))
(defun write-string (string &optional (stream *standard-output*)
- &key (start 0) (end nil))
- (%write-string string stream start (or end (length string)))
- string)
-
-(defun %write-string (string stream start end)
+ &key (start 0) end)
(declare (type string string))
- (declare (type streamlike stream))
- (declare (type index start end))
-
;; Note that even though you might expect, based on the behavior of
;; things like AREF, that the correct upper bound here is
;; (ARRAY-DIMENSION STRING 0), the ANSI glossary definitions for
;; "bounding index" and "length" indicate that in this case (i.e.
- ;; for the ANSI-specified functions WRITE-STRING and WRITE-LINE
- ;; which are implemented in terms of this function), (LENGTH STRING)
- ;; is the required upper bound. A foolish consistency is the
- ;; hobgoblin of lesser languages..
- (unless (<= 0 start end (length string))
- (error "~@<bad bounding indices START=~W END=~W for ~2I~_~S~:>"
- start
- end
- string))
+ ;; for the ANSI-specified functions WRITE-STRING [and WRITE-LINE]),
+ ;; (LENGTH STRING) is the required upper bound. A foolish
+ ;; consistency is the hobgoblin of lesser languages..
+ (%write-string string stream start (%check-vector-sequence-bounds
+ string start end))
+ string)
+(defun %write-string (string stream start end)
+ (declare (type string string))
+ (declare (type streamlike stream))
+ (declare (type index start end))
(let ((stream (out-synonym-of stream)))
(cond ((ansi-stream-p stream)
(if (array-header-p string)
(stream-write-string stream string start end)))))
(defun write-line (string &optional (stream *standard-output*)
- &key (start 0) (end nil))
- (let ((defaulted-stream (out-synonym-of stream))
- (defaulted-end (or end (length string))))
- (%write-string string defaulted-stream start defaulted-end)
+ &key (start 0) end)
+ (declare (type string string))
+ ;; FIXME: Why is there this difference between the treatments of the
+ ;; STREAM argument in WRITE-STRING and WRITE-LINE?
+ (let ((defaulted-stream (out-synonym-of stream)))
+ (%write-string string defaulted-stream start (%check-vector-sequence-bounds
+ string start end))
(write-char #\newline defaulted-stream))
string)
(:element-type 'base-char)))
(defun make-string-input-stream (string &optional
- (start 0) (end (length string)))
+ (start 0) end)
#!+sb-doc
"Return an input stream which will supply the characters of STRING between
START and END in order."
(declare (type string string)
(type index start)
(type (or index null) end))
-
- #!+high-security
- (when (> end (length string))
- (cerror "Continue with end changed from ~S to ~S"
- "Write-string: end (~S) is larger then the length of the string (~S)"
- end (1- (length string))))
-
- (internal-make-string-input-stream (coerce string 'simple-string)
- start end))
+
+ (internal-make-string-input-stream
+ (coerce string 'simple-string)
+ start
+ (%check-vector-sequence-bounds string start end)))
\f
;;;; STRING-OUTPUT-STREAM stuff
\f
;;;; READ-SEQUENCE
-(defun read-sequence (seq stream &key (start 0) (end nil))
+(defun read-sequence (seq stream &key (start 0) end)
#!+sb-doc
"Destructively modify SEQ by reading elements from STREAM.
That part of SEQ bounded by START and END is destructively modified by
:format-control "~S cannot be coerced to a string."
:format-arguments (list x)))))
+;;; %CHECK-VECTOR-SEQUENCE-BOUNDS is used to verify that the START and
+;;; END arguments are valid bounding indices.
+;;;
+;;; FIXME: This causes a certain amount of double checking that could
+;;; be avoided, as if the string passes this (more stringent) test it
+;;; will automatically pass the tests in WITH-ARRAY-DATA. Fixing this
+;;; would necessitate rearranging the transforms (maybe converting to
+;;; strings in the unasterisked versions and using this in the
+;;; transforms conditional on SAFETY>SPEED,SPACE).
+(defun %check-vector-sequence-bounds (vector start end)
+ (declare (type vector vector)
+ (type index start)
+ (type (or index null) end))
+ (let ((length (length vector)))
+ (if (<= 0 start (or end length) length)
+ (or end length)
+ (signal-bounding-indices-bad-error string start end))))
+
(eval-when (:compile-toplevel)
;;; WITH-ONE-STRING is used to set up some string hacking things. The
;;; keywords are parsed, and the string is hacked into a
;;; simple-string.
(sb!xc:defmacro with-one-string ((string start end) &body forms)
- `(let ((,string (if (stringp ,string) ,string (string ,string))))
+ `(let* ((,string (if (stringp ,string) ,string (string ,string))))
(with-array-data ((,string ,string)
- (,start ,start)
- (,end (or ,end (length (the vector ,string)))))
+ (,start ,start)
+ (,end
+ (%check-vector-sequence-bounds ,string ,start ,end)))
,@forms)))
;;; WITH-STRING is like WITH-ONE-STRING, but doesn't parse keywords.
(sb!xc:defmacro with-string (string &rest forms)
(,string2 (if (stringp ,string2) ,string2 (string ,string2))))
(with-array-data ((,string1 ,string1 :offset-var ,cum-offset-1)
(,start1 ,start1)
- (,end1 (or ,end1 (length (the vector ,string1)))))
+ (,end1 (%check-vector-sequence-bounds
+ ,string1 ,start1 ,end1)))
(with-array-data ((,string2 ,string2)
(,start2 ,start2)
- (,end2 (or ,end2 (length (the vector ,string2)))))
+ (,end2 (%check-vector-sequence-bounds
+ ,string2 ,start2 ,end2)))
,@forms))))
) ; EVAL-WHEN
(let ((slen1 (- (the fixnum end1) start1))
(slen2 (- (the fixnum end2) start2)))
(declare (fixnum slen1 slen2))
- (if (or (minusp slen1) (minusp slen2))
- ;;prevent endless looping later.
- (error "Improper bounds for string comparison."))
(if (= slen1 slen2)
;;return () immediately if lengths aren't equal.
(string-not-equal-loop 1 t nil)))))
(let ((slen1 (- end1 start1))
(slen2 (- end2 start2)))
(declare (fixnum slen1 slen2))
- (if (or (minusp slen1) (minusp slen2))
- ;; Prevent endless looping later.
- (error "Improper bounds for string comparison."))
- (cond ((or (minusp slen1) (or (minusp slen2)))
- (error "Improper substring for comparison."))
- ((= slen1 slen2)
+ (cond ((= slen1 slen2)
(string-not-equal-loop 1 nil (- index1 offset1)))
((< slen1 slen2)
(string-not-equal-loop 1 (- index1 offset1)))
(let ((slen1 (- (the fixnum end1) start1))
(slen2 (- (the fixnum end2) start2)))
(declare (fixnum slen1 slen2))
- (if (or (minusp slen1) (minusp slen2))
- ;;prevent endless looping later.
- (error "Improper bounds for string comparison."))
(do ((index1 start1 (1+ index1))
(index2 start2 (1+ index2))
(char1)
(type string namestr)
(type index start)
(type (or index null) end))
- (if junk-allowed
- (handler-case
- (%parse-namestring namestr host defaults start end nil)
- (namestring-parse-error (condition)
- (values nil (namestring-parse-error-offset condition))))
- (let* ((end (or end (length namestr))))
- (multiple-value-bind (new-host device directory file type version)
- ;; Comments below are quotes from the HyperSpec
- ;; PARSE-NAMESTRING entry, reproduced here to demonstrate
- ;; that we actually have to do things this way rather than
- ;; some possibly more logical way. - CSR, 2002-04-18
- (cond
- ;; "If host is a logical host then thing is parsed as a
- ;; logical pathname namestring on the host."
- (host (funcall (host-parse host) namestr start end))
- ;; "If host is nil and thing is a syntactically valid
- ;; logical pathname namestring containing an explicit
- ;; host, then it is parsed as a logical pathname
- ;; namestring."
- ((parseable-logical-namestring-p namestr start end)
- (parse-logical-namestring namestr start end))
- ;; "If host is nil, default-pathname is a logical
- ;; pathname, and thing is a syntactically valid logical
- ;; pathname namestring without an explicit host, then it
- ;; is parsed as a logical pathname namestring on the
- ;; host that is the host component of default-pathname."
- ;;
- ;; "Otherwise, the parsing of thing is
- ;; implementation-defined."
- ;;
- ;; Both clauses are handled here, as the default
- ;; *DEFAULT-PATHNAME-DEFAULTS has a SB-IMPL::UNIX-HOST
- ;; for a host.
- ((pathname-host defaults)
- (funcall (host-parse (pathname-host defaults))
- namestr
- start
- end))
- ;; I don't think we should ever get here, as the default
- ;; host will always have a non-null HOST, given that we
- ;; can't create a new pathname without going through
- ;; *DEFAULT-PATHNAME-DEFAULTS*, which has a non-null
- ;; host...
- (t (bug "Fallen through COND in %PARSE-NAMESTRING")))
- (when (and host new-host (not (eq new-host host)))
- (error 'simple-type-error
- :datum new-host
- ;; Note: ANSI requires that this be a TYPE-ERROR,
- ;; but there seems to be no completely correct
- ;; value to use for TYPE-ERROR-EXPECTED-TYPE.
- ;; Instead, we return a sort of "type error allowed
- ;; type", trying to say "it would be OK if you
- ;; passed NIL as the host value" but not mentioning
- ;; that a matching string would be OK too.
- :expected-type 'null
- :format-control
- "The host in the namestring, ~S,~@
+ (cond
+ (junk-allowed
+ (handler-case
+ (%parse-namestring namestr host defaults start end nil)
+ (namestring-parse-error (condition)
+ (values nil (namestring-parse-error-offset condition)))))
+ (t
+ (let* ((end (%check-vector-sequence-bounds namestr start end)))
+ (multiple-value-bind (new-host device directory file type version)
+ ;; Comments below are quotes from the HyperSpec
+ ;; PARSE-NAMESTRING entry, reproduced here to demonstrate
+ ;; that we actually have to do things this way rather than
+ ;; some possibly more logical way. - CSR, 2002-04-18
+ (cond
+ ;; "If host is a logical host then thing is parsed as a
+ ;; logical pathname namestring on the host."
+ (host (funcall (host-parse host) namestr start end))
+ ;; "If host is nil and thing is a syntactically valid
+ ;; logical pathname namestring containing an explicit
+ ;; host, then it is parsed as a logical pathname
+ ;; namestring."
+ ((parseable-logical-namestring-p namestr start end)
+ (parse-logical-namestring namestr start end))
+ ;; "If host is nil, default-pathname is a logical
+ ;; pathname, and thing is a syntactically valid logical
+ ;; pathname namestring without an explicit host, then it
+ ;; is parsed as a logical pathname namestring on the
+ ;; host that is the host component of default-pathname."
+ ;;
+ ;; "Otherwise, the parsing of thing is
+ ;; implementation-defined."
+ ;;
+ ;; Both clauses are handled here, as the default
+ ;; *DEFAULT-PATHNAME-DEFAULTS has a SB-IMPL::UNIX-HOST
+ ;; for a host.
+ ((pathname-host defaults)
+ (funcall (host-parse (pathname-host defaults))
+ namestr
+ start
+ end))
+ ;; I don't think we should ever get here, as the default
+ ;; host will always have a non-null HOST, given that we
+ ;; can't create a new pathname without going through
+ ;; *DEFAULT-PATHNAME-DEFAULTS*, which has a non-null
+ ;; host...
+ (t (bug "Fallen through COND in %PARSE-NAMESTRING")))
+ (when (and host new-host (not (eq new-host host)))
+ (error 'simple-type-error
+ :datum new-host
+ ;; Note: ANSI requires that this be a TYPE-ERROR,
+ ;; but there seems to be no completely correct
+ ;; value to use for TYPE-ERROR-EXPECTED-TYPE.
+ ;; Instead, we return a sort of "type error allowed
+ ;; type", trying to say "it would be OK if you
+ ;; passed NIL as the host value" but not mentioning
+ ;; that a matching string would be OK too.
+ :expected-type 'null
+ :format-control
+ "The host in the namestring, ~S,~@
does not match the explicit HOST argument, ~S."
- :format-arguments (list new-host host)))
- (let ((pn-host (or new-host host (pathname-host defaults))))
- (values (%make-maybe-logical-pathname
- pn-host device directory file type version)
- end))))))
+ :format-arguments (list new-host host)))
+ (let ((pn-host (or new-host host (pathname-host defaults))))
+ (values (%make-maybe-logical-pathname
+ pn-host device directory file type version)
+ end)))))))
;;; If NAMESTR begins with a colon-terminated, defined, logical host,
;;; then return that host, otherwise return NIL.
(cond (,end
(unless (or ,unsafe? (<= ,end ,size))
,(if fail-inline?
- `(error "End ~W is greater than total size ~W."
- ,end ,size)
+ `(error 'bounding-indices-bad-error
+ :datum (cons ,start ,end)
+ :expected-type `(cons (integer 0 ,',size)
+ (integer ,',start ,',size))
+ :object ,array)
`(failed-%with-array-data ,array ,start ,end)))
,end)
(t ,size))))
(unless (or ,unsafe? (<= ,start ,defaulted-end))
,(if fail-inline?
- `(error "Start ~W is greater than end ~W." ,start ,defaulted-end)
+ `(error 'bounding-indices-bad-error
+ :datum (cons ,start ,end)
+ :expected-type `(cons (integer 0 ,',size)
+ (integer ,',start ,',size))
+ :object ,array)
`(failed-%with-array-data ,array ,start ,end)))
(do ((,data ,array (%array-data-vector ,data))
(,cumulative-offset 0
function
(flushable foldable))
+(defknown %check-vector-sequence-bounds (vector index sequence-end)
+ index
+ (unwind))
+;;; FIXME: including this information here is probably necessary to
+;;; get efficient compilation of the inline expansion of
+;;; %FIND-POSITION-IF, so it should maybe be in a more
+;;; compiler-friendly package (SB-INT?)
+(defknown sb!impl::signal-bounding-indices-bad-error (sequence index index)
+ nil) ; never returns
+
(defknown arg-count-error (t t t t t t) nil (unsafe))
\f
(declare (ignorable dacc))
,push-dacc))))))))))
\f
+;;; FIXME: once the confusion over doing transforms with known-complex
+;;; arrays is over, we should also transform the calls to (AND (ARRAY
+;;; * (*)) (NOT (SIMPLE-ARRAY * (*)))) objects.
(deftransform elt ((s i) ((simple-array * (*)) *) *)
'(aref s i))
-(deftransform elt ((s i) (list *) *)
+(deftransform elt ((s i) (list *) * :policy (< safety 3))
'(nth i s))
(deftransform %setelt ((s i v) ((simple-array * (*)) * *) *)
'(%aset s i v))
-(deftransform %setelt ((s i v) (list * *))
+(deftransform %setelt ((s i v) (list * *) * :policy (< safety 3))
'(setf (car (nthcdr i s)) v))
+(deftransform %check-vector-sequence-bounds ((vector start end)
+ (vector * *) *
+ :node node)
+ (if (policy node (< safety speed))
+ '(or end (length vector))
+ '(let ((length (length vector)))
+ (if (<= 0 start (or end length) length)
+ (or end length)
+ (sb!impl::signal-bounding-indices-bad-error vector start end)))))
+
(macrolet ((def (name)
`(deftransform ,name ((e l &key (test #'eql)) * *
:node node)
;;; Moved here from generic/vm-tran.lisp to satisfy clisp
;;;
-;;; FIXME: It would be good to implement SB!XC:DEFCONSTANT, and use
-;;; use that here, so that the compiler is born knowing this value.
;;; FIXME: Add a comment telling whether this holds for all vectors
;;; or only for vectors based on simple arrays (non-adjustable, etc.).
(def!constant vector-data-bit-offset
(* sb!vm:vector-data-offset sb!vm:n-word-bits))
-;;; FIXME: Shouldn't we be testing for legality of
-;;; * START1, START2, END1, and END2 indices?
-;;; * size of copied string relative to destination string?
-;;; (Either there should be tests conditional on SAFETY>=SPEED, or
-;;; the transform should be conditional on SPEED>SAFETY.)
-;;;
-;;; FIXME: Also, the transform should probably be dependent on
-;;; SPEED>SPACE.
(deftransform replace ((string1 string2 &key (start1 0) (start2 0)
end1 end2)
- (simple-string simple-string &rest t))
+ (simple-string simple-string &rest t)
+ *
+ ;; FIXME: consider replacing this policy test
+ ;; with some tests for the STARTx and ENDx
+ ;; indices being valid, conditional on high
+ ;; SAFETY code.
+ ;;
+ ;; FIXME: It turns out that this transform is
+ ;; critical for the performance of string
+ ;; streams. Make this more explicit.
+ :policy (< (max safety space) 3))
`(locally
(declare (optimize (safety 0)))
(bit-bash-copy string2
(find nil)
(position nil))
(declare (type index index))
- (dolist (i sequence (values find position))
+ (dolist (i sequence
+ (if (and end (> end index))
+ (sb!impl::signal-bounding-indices-bad-error
+ sequence start end)
+ (values find position)))
(let ((key-i (funcall key i)))
(when (and end (>= index end))
(return (values find position)))
(,n-end ,end-arg))
(with-array-data ((,sequence ,n-sequence :offset-var ,offset)
(,start ,start)
- (,end (or ,n-end (length ,n-sequence))))
+ (,end (%check-vector-sequence-bounds
+ ,n-sequence ,start ,n-end)))
(block ,block
(macrolet ((maybe-return ()
'(let ((,element (aref ,sequence ,index)))
(in-package :cl-user)
+(load "assertoid.lisp")
+(use-package "ASSERTOID")
+
;;; helper functions for exercising SEQUENCE code on data of many
;;; specialized types, and in many different optimization scenarios
(defun for-every-seq-1 (base-seq snippet)
;;; argument isn't a valid sequence index for sequence:
(defun test-elt-signal (x)
(elt x 3))
-(multiple-value-bind (result error)
- (ignore-errors (test-elt-signal "foo"))
- (assert (null result))
- (assert (typep error 'type-error)))
+(assert (raises-error? (test-elt-signal "foo") type-error))
(assert (eql (test-elt-signal "foob") #\b))
+(locally
+ (declare (optimize (safety 3)))
+ (assert (raises-error? (elt (list 1 2 3) 3) type-error)))
+\f
+;;; checks for uniform bounding index handling under SAFETY 3 code.
+;;;
+;;; KLUDGE: not all in one big form because that causes SBCL to spend
+;;; an absolute age trying to compile it.
+(defmacro sequence-bounding-indices-test (&body body)
+ `(locally
+ ;; See Issues 332 [and 333(!)] in the CLHS
+ (declare (optimize (safety 3)))
+ (let ((string (make-array 10
+ :fill-pointer 5
+ :initial-element #\a
+ :element-type 'base-char)))
+ (flet ((reset ()
+ (setf (fill-pointer string) 10)
+ (fill string #\a)
+ (setf (fill-pointer string) 5)))
+ (declare (ignorable #'reset))
+ ,@body))))
+
+;;; Accessor SUBSEQ
+(sequence-bounding-indices-test
+ (format t "~&/Accessor SUBSEQ~%")
+ (assert (string= (subseq string 0 5) "aaaaa"))
+ (assert (raises-error? (subseq string 0 6)))
+ (assert (raises-error? (subseq string -1 5)))
+ (assert (raises-error? (subseq string 4 2)))
+ (assert (raises-error? (subseq string 6)))
+ (assert (string= (setf (subseq string 0 5) "abcde") "abcde"))
+ (assert (string= (subseq string 0 5) "abcde"))
+ (reset)
+ (assert (raises-error? (setf (subseq string 0 6) "abcdef")))
+ (assert (raises-error? (setf (subseq string -1 5) "abcdef")))
+ (assert (raises-error? (setf (subseq string 4 2) "")))
+ (assert (raises-error? (setf (subseq string 6) "ghij"))))
+
+;;; Function COUNT, COUNT-IF, COUNT-IF-NOT
+(sequence-bounding-indices-test
+ (format t "~&/Function COUNT, COUNT-IF, COUNT-IF-NOT")
+ (assert (= (count #\a string :start 0 :end nil) 5))
+ (assert (= (count #\a string :start 0 :end 5) 5))
+ (assert (raises-error? (count #\a string :start 0 :end 6)))
+ (assert (raises-error? (count #\a string :start -1 :end 5)))
+ (assert (raises-error? (count #\a string :start 4 :end 2)))
+ (assert (raises-error? (count #\a string :start 6 :end 9)))
+ (assert (= (count-if #'alpha-char-p string :start 0 :end nil) 5))
+ (assert (= (count-if #'alpha-char-p string :start 0 :end 5) 5))
+ (assert (raises-error?
+ (count-if #'alpha-char-p string :start 0 :end 6)))
+ (assert (raises-error?
+ (count-if #'alpha-char-p string :start -1 :end 5)))
+ (assert (raises-error?
+ (count-if #'alpha-char-p string :start 4 :end 2)))
+ (assert (raises-error?
+ (count-if #'alpha-char-p string :start 6 :end 9)))
+ (assert (= (count-if-not #'alpha-char-p string :start 0 :end nil) 0))
+ (assert (= (count-if-not #'alpha-char-p string :start 0 :end 5) 0))
+ (assert (raises-error?
+ (count-if-not #'alpha-char-p string :start 0 :end 6)))
+ (assert (raises-error?
+ (count-if-not #'alpha-char-p string :start -1 :end 5)))
+ (assert (raises-error?
+ (count-if-not #'alpha-char-p string :start 4 :end 2)))
+ (assert (raises-error?
+ (count-if-not #'alpha-char-p string :start 6 :end 9))))
+
+;;; Function FILL
+(sequence-bounding-indices-test
+ (format t "~&/Function FILL~%")
+ (assert (string= (fill string #\b :start 0 :end 5) "bbbbb"))
+ (assert (string= (fill string #\c :start 0 :end nil) "ccccc"))
+ (assert (raises-error? (fill string #\d :start 0 :end 6)))
+ (assert (raises-error? (fill string #\d :start -1 :end 5)))
+ (assert (raises-error? (fill string #\d :start 4 :end 2)))
+ (assert (raises-error? (fill string #\d :start 6 :end 9))))
+
+;;; Function FIND, FIND-IF, FIND-IF-NOT
+(sequence-bounding-indices-test
+ (format t "~&/Function FIND, FIND-IF, FIND-IF-NOT~%")
+ (assert (char= (find #\a string :start 0 :end nil) #\a))
+ (assert (char= (find #\a string :start 0 :end 5) #\a))
+ (assert (raises-error? (find #\a string :start 0 :end 6)))
+ (assert (raises-error? (find #\a string :start -1 :end 5)))
+ (assert (raises-error? (find #\a string :start 4 :end 2)))
+ (assert (raises-error? (find #\a string :start 6 :end 9)))
+ (assert (char= (find-if #'alpha-char-p string :start 0 :end nil) #\a))
+ (assert (char= (find-if #'alpha-char-p string :start 0 :end 5) #\a))
+ (assert (raises-error?
+ (find-if #'alpha-char-p string :start 0 :end 6)))
+ (assert (raises-error?
+ (find-if #'alpha-char-p string :start -1 :end 5)))
+ (assert (raises-error?
+ (find-if #'alpha-char-p string :start 4 :end 2)))
+ (assert (raises-error?
+ (find-if #'alpha-char-p string :start 6 :end 9)))
+ (assert (eq (find-if-not #'alpha-char-p string :start 0 :end nil) nil))
+ (assert (eq (find-if-not #'alpha-char-p string :start 0 :end 5) nil))
+ (assert (raises-error?
+ (find-if-not #'alpha-char-p string :start 0 :end 6)))
+ (assert (raises-error?
+ (find-if-not #'alpha-char-p string :start -1 :end 5)))
+ (assert (raises-error?
+ (find-if-not #'alpha-char-p string :start 4 :end 2)))
+ (assert (raises-error?
+ (find-if-not #'alpha-char-p string :start 6 :end 9))))
+
+;;; Function MISMATCH
+(sequence-bounding-indices-test
+ (format t "~&/Function MISMATCH~%")
+ (assert (null (mismatch string "aaaaa" :start1 0 :end1 nil)))
+ (assert (= (mismatch "aaab" string :start2 0 :end2 4) 3))
+ (assert (raises-error? (mismatch "aaaaaa" string :start2 0 :end2 6)))
+ (assert (raises-error? (mismatch string "aaaaaa" :start1 -1 :end1 5)))
+ (assert (raises-error? (mismatch string "" :start1 4 :end1 2)))
+ (assert (raises-error? (mismatch "aaaa" string :start2 6 :end2 9))))
+
+;;; Function PARSE-INTEGER
+(sequence-bounding-indices-test
+ (format t "~&/Function PARSE-INTEGER~%")
+ (setf (fill-pointer string) 10)
+ (setf (subseq string 0 10) "1234567890")
+ (setf (fill-pointer string) 5)
+ (assert (= (parse-integer string :start 0 :end 5) 12345))
+ (assert (= (parse-integer string :start 0 :end nil) 12345))
+ (assert (raises-error? (parse-integer string :start 0 :end 6)))
+ (assert (raises-error? (parse-integer string :start -1 :end 5)))
+ (assert (raises-error? (parse-integer string :start 4 :end 2)))
+ (assert (raises-error? (parse-integer string :start 6 :end 9))))
+
+;;; Function PARSE-NAMESTRING
+(sequence-bounding-indices-test
+ (format t "~&/Function PARSE-NAMESTRING~%")
+ (setf (fill-pointer string) 10)
+ (setf (subseq string 0 10) "/dev/ /tmp")
+ (setf (fill-pointer string) 5)
+ (assert (truename (parse-namestring string nil *default-pathname-defaults*
+ :start 0 :end 5)))
+ (assert (truename (parse-namestring string nil *default-pathname-defaults*
+ :start 0 :end nil)))
+ (assert (raises-error? (parse-namestring string nil
+ *default-pathname-defaults*
+ :start 0 :end 6)))
+ (assert (raises-error? (parse-namestring string nil
+ *default-pathname-defaults*
+ :start -1 :end 5)))
+ (assert (raises-error? (parse-namestring string nil
+ *default-pathname-defaults*
+ :start 4 :end 2)))
+ (assert (raises-error? (parse-namestring string nil
+ *default-pathname-defaults*
+ :start 6 :end 9))))
+
+;;; Function POSITION, POSITION-IF, POSITION-IF-NOT
+(sequence-bounding-indices-test
+ (format t "~&/Function POSITION, POSITION-IF, POSITION-IF-NOT~%")
+ (assert (= (position #\a string :start 0 :end nil) 0))
+ (assert (= (position #\a string :start 0 :end 5) 0))
+ (assert (raises-error? (position #\a string :start 0 :end 6)))
+ (assert (raises-error? (position #\a string :start -1 :end 5)))
+ (assert (raises-error? (position #\a string :start 4 :end 2)))
+ (assert (raises-error? (position #\a string :start 6 :end 9)))
+ (assert (= (position-if #'alpha-char-p string :start 0 :end nil) 0))
+ (assert (= (position-if #'alpha-char-p string :start 0 :end 5) 0))
+ (assert (raises-error?
+ (position-if #'alpha-char-p string :start 0 :end 6)))
+ (assert (raises-error?
+ (position-if #'alpha-char-p string :start -1 :end 5)))
+ (assert (raises-error?
+ (position-if #'alpha-char-p string :start 4 :end 2)))
+ (assert (raises-error?
+ (position-if #'alpha-char-p string :start 6 :end 9)))
+ (assert (eq (position-if-not #'alpha-char-p string :start 0 :end nil) nil))
+ (assert (eq (position-if-not #'alpha-char-p string :start 0 :end 5) nil))
+ (assert (raises-error?
+ (position-if-not #'alpha-char-p string :start 0 :end 6)))
+ (assert (raises-error?
+ (position-if-not #'alpha-char-p string :start -1 :end 5)))
+ (assert (raises-error?
+ (position-if-not #'alpha-char-p string :start 4 :end 2)))
+ (assert (raises-error?
+ (position-if-not #'alpha-char-p string :start 6 :end 9))))
+
+;;; Function READ-FROM-STRING
+(sequence-bounding-indices-test
+ (format t "~&/Function READ-FROM-STRING~%")
+ (setf (subseq string 0 5) "(a b)")
+ (assert (equal (read-from-string string nil nil :start 0 :end 5) '(a b)))
+ (assert (equal (read-from-string string nil nil :start 0 :end nil) '(a b)))
+ (assert (raises-error? (read-from-string string nil nil :start 0 :end 6)))
+ (assert (raises-error? (read-from-string string nil nil :start -1 :end 5)))
+ (assert (raises-error? (read-from-string string nil nil :start 4 :end 2)))
+ (assert (raises-error? (read-from-string string nil nil :start 6 :end 9))))
+
+;;; Function REDUCE
+(sequence-bounding-indices-test
+ (format t "~&/Function REDUCE~%")
+ (setf (subseq string 0 5) "abcde")
+ (assert (equal (reduce #'list* string :from-end t :start 0 :end nil)
+ '(#\a #\b #\c #\d . #\e)))
+ (assert (equal (reduce #'list* string :from-end t :start 0 :end 5)
+ '(#\a #\b #\c #\d . #\e)))
+ (assert (raises-error? (reduce #'list* string :start 0 :end 6)))
+ (assert (raises-error? (reduce #'list* string :start -1 :end 5)))
+ (assert (raises-error? (reduce #'list* string :start 4 :end 2)))
+ (assert (raises-error? (reduce #'list* string :start 6 :end 9))))
+
+;;; Function REMOVE, REMOVE-IF, REMOVE-IF-NOT, DELETE, DELETE-IF,
+;;; DELETE-IF-NOT
+(sequence-bounding-indices-test
+ (format t "~&/Function REMOVE, REMOVE-IF, REMOVE-IF-NOT, ...~%")
+ (assert (equal (remove #\a string :start 0 :end nil) ""))
+ (assert (equal (remove #\a string :start 0 :end 5) ""))
+ (assert (raises-error? (remove #\a string :start 0 :end 6)))
+ (assert (raises-error? (remove #\a string :start -1 :end 5)))
+ (assert (raises-error? (remove #\a string :start 4 :end 2)))
+ (assert (raises-error? (remove #\a string :start 6 :end 9)))
+ (assert (equal (remove-if #'alpha-char-p string :start 0 :end nil) ""))
+ (assert (equal (remove-if #'alpha-char-p string :start 0 :end 5) ""))
+ (assert (raises-error?
+ (remove-if #'alpha-char-p string :start 0 :end 6)))
+ (assert (raises-error?
+ (remove-if #'alpha-char-p string :start -1 :end 5)))
+ (assert (raises-error?
+ (remove-if #'alpha-char-p string :start 4 :end 2)))
+ (assert (raises-error?
+ (remove-if #'alpha-char-p string :start 6 :end 9)))
+ (assert (equal (remove-if-not #'alpha-char-p string :start 0 :end nil)
+ "aaaaa"))
+ (assert (equal (remove-if-not #'alpha-char-p string :start 0 :end 5)
+ "aaaaa"))
+ (assert (raises-error?
+ (remove-if-not #'alpha-char-p string :start 0 :end 6)))
+ (assert (raises-error?
+ (remove-if-not #'alpha-char-p string :start -1 :end 5)))
+ (assert (raises-error?
+ (remove-if-not #'alpha-char-p string :start 4 :end 2)))
+ (assert (raises-error?
+ (remove-if-not #'alpha-char-p string :start 6 :end 9)))
+ (format t "~&/... DELETE, DELETE-IF, DELETE-IF-NOT")
+ (assert (equal (delete #\a string :start 0 :end nil) ""))
+ (reset)
+ (assert (equal (delete #\a string :start 0 :end 5) ""))
+ (reset)
+ (assert (raises-error? (delete #\a string :start 0 :end 6)))
+ (reset)
+ (assert (raises-error? (delete #\a string :start -1 :end 5)))
+ (reset)
+ (assert (raises-error? (delete #\a string :start 4 :end 2)))
+ (reset)
+ (assert (raises-error? (delete #\a string :start 6 :end 9)))
+ (reset)
+ (assert (equal (delete-if #'alpha-char-p string :start 0 :end nil) ""))
+ (reset)
+ (assert (equal (delete-if #'alpha-char-p string :start 0 :end 5) ""))
+ (reset)
+ (assert (raises-error?
+ (delete-if #'alpha-char-p string :start 0 :end 6)))
+ (reset)
+ (assert (raises-error?
+ (delete-if #'alpha-char-p string :start -1 :end 5)))
+ (reset)
+ (assert (raises-error?
+ (delete-if #'alpha-char-p string :start 4 :end 2)))
+ (reset)
+ (assert (raises-error?
+ (delete-if #'alpha-char-p string :start 6 :end 9)))
+ (reset)
+ (assert (equal (delete-if-not #'alpha-char-p string :start 0 :end nil)
+ "aaaaa"))
+ (reset)
+ (assert (equal (delete-if-not #'alpha-char-p string :start 0 :end 5)
+ "aaaaa"))
+ (reset)
+ (assert (raises-error?
+ (delete-if-not #'alpha-char-p string :start 0 :end 6)))
+ (reset)
+ (assert (raises-error?
+ (delete-if-not #'alpha-char-p string :start -1 :end 5)))
+ (reset)
+ (assert (raises-error?
+ (delete-if-not #'alpha-char-p string :start 4 :end 2)))
+ (reset)
+ (assert (raises-error?
+ (delete-if-not #'alpha-char-p string :start 6 :end 9))))
+
+;;; Function REMOVE-DUPLICATES, DELETE-DUPLICATES
+(sequence-bounding-indices-test
+ (format t "~&/Function REMOVE-DUPLICATES, DELETE-DUPLICATES~%")
+ (assert (string= (remove-duplicates string :start 0 :end 5) "a"))
+ (assert (string= (remove-duplicates string :start 0 :end nil) "a"))
+ (assert (raises-error? (remove-duplicates string :start 0 :end 6)))
+ (assert (raises-error? (remove-duplicates string :start -1 :end 5)))
+ (assert (raises-error? (remove-duplicates string :start 4 :end 2)))
+ (assert (raises-error? (remove-duplicates string :start 6 :end 9)))
+ (assert (string= (delete-duplicates string :start 0 :end 5) "a"))
+ (reset)
+ (assert (string= (delete-duplicates string :start 0 :end nil) "a"))
+ (reset)
+ (assert (raises-error? (delete-duplicates string :start 0 :end 6)))
+ (reset)
+ (assert (raises-error? (delete-duplicates string :start -1 :end 5)))
+ (reset)
+ (assert (raises-error? (delete-duplicates string :start 4 :end 2)))
+ (reset)
+ (assert (raises-error? (delete-duplicates string :start 6 :end 9))))
+
+;;; Function REPLACE
+(sequence-bounding-indices-test
+ (format t "~&/Function REPLACE~%")
+ (assert (string= (replace string "bbbbb" :start1 0 :end1 5) "bbbbb"))
+ (assert (string= (replace (copy-seq "ccccc")
+ string
+ :start2 0 :end2 nil) "bbbbb"))
+ (assert (raises-error? (replace string "ccccc" :start1 0 :end1 6)))
+ (assert (raises-error? (replace string "ccccc" :start2 -1 :end2 5)))
+ (assert (raises-error? (replace string "ccccc" :start1 4 :end1 2)))
+ (assert (raises-error? (replace string "ccccc" :start1 6 :end1 9))))
+
+;;; Function SEARCH
+(sequence-bounding-indices-test
+ (format t "~&/Function SEARCH~%")
+ (assert (= (search "aa" string :start2 0 :end2 5) 0))
+ (assert (null (search string "aa" :start1 0 :end2 nil)))
+ (assert (raises-error? (search "aa" string :start2 0 :end2 6)))
+ (assert (raises-error? (search "aa" string :start2 -1 :end2 5)))
+ (assert (raises-error? (search "aa" string :start2 4 :end2 2)))
+ (assert (raises-error? (search "aa" string :start2 6 :end2 9))))
+
+;;; Function STRING-UPCASE, STRING-DOWNCASE, STRING-CAPITALIZE,
+;;; NSTRING-UPCASE, NSTRING-DOWNCASE, NSTRING-CAPITALIZE
+(sequence-bounding-indices-test
+ (macrolet ((frob (fn)
+ `(progn
+ (assert (raises-error? (,fn string :start 0 :end 6)))
+ (assert (raises-error? (,fn string :start -1 :end 5)))
+ (assert (raises-error? (,fn string :start 4 :end 2)))
+ (assert (raises-error? (,fn string :start 6 :end 9))))))
+ (format t "~&/Function STRING-UPCASE, STRING-DOWNCASE, STRING-CAPITALIZE, ...~%")
+ (frob string-upcase)
+ (frob string-downcase)
+ (frob string-capitalize)
+ (format t "~&/... NSTRING-UPCASE, NSTRING-DOWNCASE, NSTRING-CAPITALIZE~%")
+ (frob nstring-upcase)
+ (frob nstring-downcase)
+ (frob nstring-capitalize)))
+
+;;; Function STRING=, STRING/=, STRING<, STRING>, STRING<=, STRING>=,
+;;; STRING-EQUAL, STRING-NOT-EQUAL, STRING-LESSP, STRING-GREATERP,
+;;; STRING-NOT-GREATERP, STRING-NOT-LESSP
+(sequence-bounding-indices-test
+ (macrolet ((frob (fn)
+ `(progn
+ (,fn string "abcde" :start1 0 :end1 5)
+ (,fn "fghij" string :start2 0 :end2 nil)
+ (assert (raises-error? (,fn string "klmno"
+ :start1 0 :end1 6)))
+ (assert (raises-error? (,fn "pqrst" string
+ :start2 -1 :end2 5)))
+ (assert (raises-error? (,fn "uvwxy" string
+ :start1 4 :end1 2)))
+ (assert (raises-error? (,fn string "z" :start2 6 :end2 9))))))
+ (format t "~&/Function STRING=, STRING/=, STRING<, STRING>, STRING<=, STRING>=, ...")
+ (frob string=)
+ (frob string/=)
+ (frob string<)
+ (frob string>)
+ (frob string<=)
+ (frob string>=)
+ (format t "~&/... STRING-EQUAL, STRING-NOT-EQUAL, STRING-LESSP, ...~%")
+ (frob string-equal)
+ (frob string-not-equal)
+ (frob string-lessp)
+ (format t "~&/... STRING-GREATERP, STRING-NOT-GREATERP, STRING-NOT-LESSP~%")
+ (frob string-greaterp)
+ (frob string-not-greaterp)
+ (frob string-not-lessp)))
+
+;;; Function SUBSTITUTE, SUBSTITUTE-IF, SUBSTITUTE-IF-NOT,
+;;; NSUBSTITUTE, NSUBSTITUTE-IF, NSUBSTITUTE-IF-NOT
+(sequence-bounding-indices-test
+ (format t "~&/Function SUBSTITUTE, SUBSTITUTE-IF, SUBSTITUTE-IF-NOT, ...~%")
+ (assert (string= (substitute #\b #\a string :start 0 :end 5) "bbbbb"))
+ (assert (string= (substitute #\c #\a string :start 0 :end nil)
+ "ccccc"))
+ (assert (raises-error? (substitute #\b #\a string :start 0 :end 6)))
+ (assert (raises-error? (substitute #\b #\a string :start -1 :end 5)))
+ (assert (raises-error? (substitute #\b #\a string :start 4 :end 2)))
+ (assert (raises-error? (substitute #\b #\a string :start 6 :end 9)))
+ (assert (string= (substitute-if #\b #'alpha-char-p string
+ :start 0 :end 5)
+ "bbbbb"))
+ (assert (string= (substitute-if #\c #'alpha-char-p string
+ :start 0 :end nil)
+ "ccccc"))
+ (assert (raises-error? (substitute-if #\b #'alpha-char-p string
+ :start 0 :end 6)))
+ (assert (raises-error? (substitute-if #\b #'alpha-char-p string
+ :start -1 :end 5)))
+ (assert (raises-error? (substitute-if #\b #'alpha-char-p string
+ :start 4 :end 2)))
+ (assert (raises-error? (substitute-if #\b #'alpha-char-p string
+ :start 6 :end 9)))
+ (assert (string= (substitute-if-not #\b #'alpha-char-p string
+ :start 0 :end 5)
+ "aaaaa"))
+ (assert (string= (substitute-if-not #\c #'alpha-char-p string
+ :start 0 :end nil)
+ "aaaaa"))
+ (assert (raises-error? (substitute-if-not #\b #'alpha-char-p string
+ :start 0 :end 6)))
+ (assert (raises-error? (substitute-if-not #\b #'alpha-char-p string
+ :start -1 :end 5)))
+ (assert (raises-error? (substitute-if-not #\b #'alpha-char-p string
+ :start 4 :end 2)))
+ (assert (raises-error? (substitute-if-not #\b #'alpha-char-p string
+ :start 6 :end 9)))
+ (format t "~&/... NSUBSTITUTE, NSUBSTITUTE-IF, NSUBSTITUTE-IF-NOT~%")
+ (assert (string= (nsubstitute #\b #\a string :start 0 :end 5) "bbbbb"))
+ (reset)
+ (assert (string= (nsubstitute #\c #\a string :start 0 :end nil)
+ "ccccc"))
+ (reset)
+ (assert (raises-error? (nsubstitute #\b #\a string :start 0 :end 6)))
+ (reset)
+ (assert (raises-error? (nsubstitute #\b #\a string :start -1 :end 5)))
+ (reset)
+ (assert (raises-error? (nsubstitute #\b #\a string :start 4 :end 2)))
+ (reset)
+ (assert (raises-error? (nsubstitute #\b #\a string :start 6 :end 9)))
+ (reset)
+ (assert (string= (nsubstitute-if #\b #'alpha-char-p string
+ :start 0 :end 5)
+ "bbbbb"))
+ (reset)
+ (assert (string= (nsubstitute-if #\c #'alpha-char-p string
+ :start 0 :end nil)
+ "ccccc"))
+ (reset)
+ (assert (raises-error? (nsubstitute-if #\b #'alpha-char-p string
+ :start 0 :end 6)))
+ (reset)
+ (assert (raises-error? (nsubstitute-if #\b #'alpha-char-p string
+ :start -1 :end 5)))
+ (reset)
+ (assert (raises-error? (nsubstitute-if #\b #'alpha-char-p string
+ :start 4 :end 2)))
+ (reset)
+ (assert (raises-error? (nsubstitute-if #\b #'alpha-char-p string
+ :start 6 :end 9)))
+ (reset)
+ (assert (string= (nsubstitute-if-not #\b #'alpha-char-p string
+ :start 0 :end 5)
+ "aaaaa"))
+ (reset)
+ (assert (string= (nsubstitute-if-not #\c #'alpha-char-p string
+ :start 0 :end nil)
+ "aaaaa"))
+ (reset)
+ (assert (raises-error? (nsubstitute-if-not #\b #'alpha-char-p string
+ :start 0 :end 6)))
+ (reset)
+ (assert (raises-error? (nsubstitute-if-not #\b #'alpha-char-p string
+ :start -1 :end 5)))
+ (reset)
+ (assert (raises-error? (nsubstitute-if-not #\b #'alpha-char-p string
+ :start 4 :end 2)))
+ (reset)
+ (assert (raises-error? (nsubstitute-if-not #\b #'alpha-char-p string
+ :start 6 :end 9))))
+;;; Function WRITE-STRING, WRITE-LINE
+(sequence-bounding-indices-test
+ (format t "~&/Function WRITE-STRING, WRITE-LINE~%")
+ (write-string string *standard-output* :start 0 :end 5)
+ (write-string string *standard-output* :start 0 :end nil)
+ (assert (raises-error? (write-string string *standard-output*
+ :start 0 :end 6)))
+ (assert (raises-error? (write-string string *standard-output*
+ :start -1 :end 5)))
+ (assert (raises-error? (write-string string *standard-output*
+ :start 4 :end 2)))
+ (assert (raises-error? (write-string string *standard-output*
+ :start 6 :end 9)))
+ (write-line string *standard-output* :start 0 :end 5)
+ (write-line string *standard-output* :start 0 :end nil)
+ (assert (raises-error? (write-line string *standard-output*
+ :start 0 :end 6)))
+ (assert (raises-error? (write-line string *standard-output*
+ :start -1 :end 5)))
+ (assert (raises-error? (write-line string *standard-output*
+ :start 4 :end 2)))
+ (assert (raises-error? (write-line string *standard-output*
+ :start 6 :end 9))))
+
+;;; Macro WITH-INPUT-FROM-STRING
+(sequence-bounding-indices-test
+ (format t "~&/Macro WITH-INPUT-FROM-STRING~%")
+ (with-input-from-string (s string :start 0 :end 5)
+ (assert (char= (read-char s) #\a)))
+ (with-input-from-string (s string :start 0 :end nil)
+ (assert (char= (read-char s) #\a)))
+ (assert (raises-error?
+ (with-input-from-string (s string :start 0 :end 6)
+ (read-char s))))
+ (assert (raises-error?
+ (with-input-from-string (s string :start -1 :end 5)
+ (read-char s))))
+ (assert (raises-error?
+ (with-input-from-string (s string :start 4 :end 2)
+ (read-char s))))
+ (assert (raises-error?
+ (with-input-from-string (s string :start 6 :end 9)
+ (read-char s)))))
\f
;;; success
(quit :unix-status 104)
'(1 2 3 10 12 13)))
(assert (equal (stable-sort (list 1 2 3 -3 -2 -1) '< :key 'abs)
'(1 -1 2 -2 3 -3)))
+
;;; versions, especially for internal versions off the main CVS
;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
-"0.7.12.16"
+"0.7.12.17"
projects / sbcl.git / commitdiff