From b86daba1860b622636d9e8f655a3f96de4d86801 Mon Sep 17 00:00:00 2001 From: Nikodemus Siivola Date: Fri, 30 Nov 2007 14:18:31 +0000 Subject: [PATCH] 1.0.12.8: refactor bounding index error signalling functions * We need two variants: one that uses ARRAY-TOTAL-SIZE for the limit, other othat uses LENGTH. Call them ARRAY- and SEQUENCE-BOUNDING-INDICES-BAD-ERROR. --- package-data-list.lisp-expr | 4 ++++ src/code/fd-stream.lisp | 4 ++-- src/code/seq.lisp | 26 ++++++++++++++++---------- src/compiler/array-tran.lisp | 24 ++++-------------------- src/compiler/fndb.lisp | 4 ++-- src/compiler/seqtran.lisp | 12 ++++++------ version.lisp-expr | 2 +- 7 files changed, 35 insertions(+), 41 deletions(-) diff --git a/package-data-list.lisp-expr b/package-data-list.lisp-expr index 6b7eab4..989ae2e 100644 --- a/package-data-list.lisp-expr +++ b/package-data-list.lisp-expr @@ -837,6 +837,10 @@ possibly temporariliy, because it might be used internally." "SIMPLE-STYLE-WARNING" "TRY-RESTART" + ;; error-signalling facilities + "ARRAY-BOUNDING-INDICES-BAD-ERROR" + "SEQUENCE-BOUNDING-INDICES-BAD-ERROR" + "SPECIAL-FORM-FUNCTION" "STYLE-WARN" "SIMPLE-COMPILER-NOTE" diff --git a/src/code/fd-stream.lisp b/src/code/fd-stream.lisp index 98df2d4..9a7ce72 100644 --- a/src/code/fd-stream.lisp +++ b/src/code/fd-stream.lisp @@ -1234,7 +1234,7 @@ (declare (type index start end)) (synchronize-stream-output stream) (unless (<= 0 start end (length string)) - (signal-bounding-indices-bad-error string start end)) + (sequence-bounding-indices-bad-error string start end)) (do () ((= end start)) (let ((obuf (fd-stream-obuf stream))) @@ -1411,7 +1411,7 @@ (declare (type index start end)) (synchronize-stream-output stream) (unless (<= 0 start end (length string)) - (signal-bounding-indices-bad-error string start end)) + (sequence-bounding-indices-bad string start end)) (do () ((= end start)) (let ((obuf (fd-stream-obuf stream))) diff --git a/src/code/seq.lisp b/src/code/seq.lisp index c5c6bd8..eba8389 100644 --- a/src/code/seq.lisp +++ b/src/code/seq.lisp @@ -41,8 +41,7 @@ nil (if (<= 0 ,start ,length) ,start - (signal-bounding-indices-bad-error ,sequence - ,start ,end)) + (sequence-bounding-indices-bad-error ,sequence ,start ,end)) index) `(,end nil @@ -55,8 +54,7 @@ ;; FIXME: defend against non-number non-NIL ;; stuff? ,end - (signal-bounding-indices-bad-error ,sequence - ,start ,end)) + (sequence-bounding-indices-bad-error ,sequence ,start ,end)) (or null index))))) '((start end length sequence) (start1 end1 length1 sequence1) @@ -220,13 +218,21 @@ ;; This seems silly, is there something better? '(integer 0 (0)))))) -(defun signal-bounding-indices-bad-error (sequence start end) - (let ((length (length sequence))) +(defun sequence-bounding-indices-bad-error (sequence start end) + (let ((size (length sequence))) (error 'bounding-indices-bad-error :datum (cons start end) - :expected-type `(cons (integer 0 ,length) - (or null (integer ,start ,length))) + :expected-type `(cons (integer 0 ,size) + (integer ,start ,size)) :object sequence))) + +(defun array-bounding-indices-bad-error (array start end) + (let ((size (array-total-size array))) + (error 'bounding-indices-bad-error + :datum (cons start end) + :expected-type `(cons (integer 0 ,size) + (integer ,start ,size)) + :object array))) (defun elt (sequence index) #!+sb-doc "Return the element of SEQUENCE specified by INDEX." @@ -359,7 +365,7 @@ (when (null end) (setf end (length sequence))) (unless (<= 0 start end (length sequence)) - (signal-bounding-indices-bad-error sequence start end)) + (sequence-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)))) @@ -373,7 +379,7 @@ (type unsigned-byte start) (type (or null unsigned-byte) end)) (flet ((oops () - (signal-bounding-indices-bad-error sequence start end))) + (sequence-bounding-indices-bad-error sequence start end))) (let ((pointer sequence)) (unless (zerop start) ;; If START > 0 the list cannot be empty. So CDR down to diff --git a/src/compiler/array-tran.lisp b/src/compiler/array-tran.lisp index 2026bb2..5224134 100644 --- a/src/compiler/array-tran.lisp +++ b/src/compiler/array-tran.lisp @@ -569,22 +569,6 @@ ;;;; WITH-ARRAY-DATA -(defun bounding-index-error (array start end) - (let ((size (array-total-size array))) - (error 'bounding-indices-bad-error - :datum (cons start end) - :expected-type `(cons (integer 0 ,size) - (integer ,start ,size)) - :object array))) - -(defun bounding-index-error/fp (array start end) - (let ((size (length array))) - (error 'bounding-indices-bad-error - :datum (cons start end) - :expected-type `(cons (integer 0 ,size) - (integer ,start ,size)) - :object array))) - ;;; This checks to see whether the array is simple and the start and ;;; end are in bounds. If so, it proceeds with those values. ;;; Otherwise, it calls %WITH-ARRAY-DATA. Note that %WITH-ARRAY-DATA @@ -633,8 +617,8 @@ `(if (<= ,n-svalue ,n-end ,n-len) (values ,n-array ,n-svalue ,n-end 0) ,(if check-fill-pointer - `(bounding-index-error/fp ,n-array ,n-svalue ,n-evalue) - `(bounding-index-error ,n-array ,n-svalue ,n-evalue)))))) + `(sequence-bounding-indices-bad-error ,n-array ,n-svalue ,n-evalue) + `(array-bounding-indices-bad-error ,n-array ,n-svalue ,n-evalue)))))) ,(if force-inline `(%with-array-data-macro ,n-array ,n-svalue ,n-evalue :check-bounds ,check-bounds @@ -661,8 +645,8 @@ ,@(when check-bounds `((unless (<= ,start ,defaulted-end ,size) ,(if check-fill-pointer - `(bounding-index-error/fp ,array ,start ,end) - `(bounding-index-error ,array ,start ,end))))) + `(sequence-bounding-indices-bad-error ,array ,start ,end) + `(array-bounding-indices-bad-error ,array ,start ,end))))) (do ((,data ,array (%array-data-vector ,data)) (,cumulative-offset 0 (+ ,cumulative-offset diff --git a/src/compiler/fndb.lisp b/src/compiler/fndb.lisp index e845ec7..30fe77d 100644 --- a/src/compiler/fndb.lisp +++ b/src/compiler/fndb.lisp @@ -1459,8 +1459,8 @@ (defknown %set-symbol-package (symbol t) t (unsafe)) (defknown %coerce-name-to-fun ((or symbol cons)) function (flushable)) (defknown %coerce-callable-to-fun (callable) function (flushable)) -(defknown bounding-index-error (t t t) nil) -(defknown bounding-index-error/fp (t t t) nil) +(defknown array-bounding-indices-bad-error (t t t) nil) +(defknown sequence-bounding-indices-bad-error (t t t) nil) (defknown %find-position (t sequence t index sequence-end function function) (values t (or index null)) diff --git a/src/compiler/seqtran.lisp b/src/compiler/seqtran.lisp index eafa639..9cd3e8a 100644 --- a/src/compiler/seqtran.lisp +++ b/src/compiler/seqtran.lisp @@ -289,7 +289,7 @@ '(let ((length (length vector))) (if (<= 0 start (or end length) length) (or end length) - (sb!impl::signal-bounding-indices-bad-error vector start end))))) + (sequence-bounding-indices-bad-error vector start end))))) (defun specialized-list-seek-function-name (function-name key-functions) (or (find-symbol (with-output-to-string (s) @@ -617,9 +617,9 @@ ,(unless (policy node (= safety 0)) `(progn (unless (<= 0 start1 end1 len1) - (sb!impl::signal-bounding-indices-bad-error seq1 start1 end1)) + (sequence-bounding-indices-bad-error seq1 start1 end1)) (unless (<= 0 start2 end2 len2) - (sb!impl::signal-bounding-indices-bad-error seq2 start2 end2)))) + (sequence-bounding-indices-bad-error seq2 start2 end2)))) ,',(cond ((and saetp (valid-bit-bash-saetp-p saetp)) (let* ((n-element-bits (sb!vm:saetp-n-bits saetp)) @@ -793,7 +793,7 @@ ,(unless (policy node (= safety 0)) '(progn (unless (<= 0 start end length) - (sb!impl::signal-bounding-indices-bad-error seq start end)))) + (sequence-bounding-indices-bad-error seq start end)))) (let* ((size (- end start)) (result (make-array size :element-type ',element-type))) ,(maybe-expand-copy-loop-inline 'seq (if (constant-lvar-p start) @@ -837,7 +837,7 @@ (check-bounds-p (policy node (plusp insert-array-bounds-checks)))) `(block search (flet ((oops (vector start end) - (bounding-index-error vector start end))) + (sequence-bounding-indices-bad-error vector start end))) (let* ((len1 (length pattern)) (len2 (length text)) (end1 (or end1 len1)) @@ -997,7 +997,7 @@ (declare (type index index)) (dolist (i sequence (if (and end (> end index)) - (sb!impl::signal-bounding-indices-bad-error + (sequence-bounding-indices-bad-error sequence start end) (values find position))) (let ((key-i (funcall key i))) diff --git a/version.lisp-expr b/version.lisp-expr index cbfce67..15217fe 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.12.7" +"1.0.12.8" -- 1.7.10.4