Email Archive: sbcl-commits (read-only)
|
[Sbcl-commits] CVS: sbcl/src/code array.lisp, 1.70,
1.71 cross-misc.lisp, 1.28, 1.29 octets.lisp, 1.18,
1.19 print.lisp, 1.71, 1.72 reader.lisp, 1.50, 1.51 seq.lisp,
1.75, 1.76 sort.lisp, 1.22, 1.23 stream.lisp, 1.94,
1.95 string.lisp, 1.12, 1.13 timer.lisp, 1.11, 1.12
From: Nikodemus Siivola <demoss@us...> - 2007-11-29 17:30
|
Update of /cvsroot/sbcl/sbcl/src/code
In directory sc8-pr-cvs8.sourceforge.net:/tmp/cvs-serv5461/src/code
Modified Files:
array.lisp cross-misc.lisp octets.lisp print.lisp reader.lisp
seq.lisp sort.lisp stream.lisp string.lisp timer.lisp
Log Message:
1.0.12.5: WITH-ARRAY-DATA touchups
* Eliminate some double-bounds checks: since WITH-ARRAY-DATA does
bounds checking, there is no need to vet START and END with
%CHECK-VECTOR-SEQUENCE-BOUNDS.
* Eliminate some fill-pointer confusion: Since WITH-ARRAY-DATA is
used both in contexts where fill-pointer needs to be used, and
in contexts where we only care about the total array size, add
a :CHECK-FILL-POINTER argument to WITH-ARRAY-DATA.
* Do bounds checking in WITH-ARRAY-DATA based on
INSERT-ARRAY-BOUNDS-CHECKS policy -- not SPEED vs. SAFETY
comparison. Adjust tests to check for this.
Index: array.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/code/array.lisp,v
retrieving revision 1.70
retrieving revision 1.71
diff -u -d -r1.70 -r1.71
--- array.lisp 15 Jul 2007 22:28:13 -0000 1.70
+++ array.lisp 29 Nov 2007 17:30:18 -0000 1.71
@@ -46,8 +46,11 @@
(fixnum index))
(%check-bound array bound index))
+(defun %with-array-data/fp (array start end)
+ (%with-array-data-macro array start end :check-bounds t :check-fill-pointer t))
+
(defun %with-array-data (array start end)
- (%with-array-data-macro array start end :fail-inline? t))
+ (%with-array-data-macro array start end :check-bounds t :check-fill-pointer nil))
(defun %data-vector-and-index (array index)
(if (array-header-p array)
@@ -55,14 +58,6 @@
(%with-array-data array index nil)
(values vector index))
(values array index)))
-
-;;; It'd waste space to expand copies of error handling in every
-;;; inline %WITH-ARRAY-DATA, so we have them call this function
-;;; instead. This is just a wrapper which is known never to return.
-(defun failed-%with-array-data (array start end)
- (declare (notinline %with-array-data))
- (%with-array-data array start end)
- (bug "called FAILED-%WITH-ARRAY-DATA with valid array parameters?"))
;;;; MAKE-ARRAY
(eval-when (:compile-toplevel :execute)
Index: cross-misc.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/code/cross-misc.lisp,v
retrieving revision 1.28
retrieving revision 1.29
diff -u -d -r1.28 -r1.29
--- cross-misc.lisp 12 Nov 2007 17:14:50 -0000 1.28
+++ cross-misc.lisp 29 Nov 2007 17:30:18 -0000 1.29
@@ -150,6 +150,10 @@
(assert (typep array '(simple-array * (*))))
(values array start end 0))
+(defun sb!kernel:%with-array-data/fp (array start end)
+ (assert (typep array '(simple-array * (*))))
+ (values array start end 0))
+
(defun sb!kernel:signed-byte-32-p (number)
(typep number '(signed-byte 32)))
Index: octets.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/code/octets.lisp,v
retrieving revision 1.18
retrieving revision 1.19
diff -u -d -r1.18 -r1.19
--- octets.lisp 10 Sep 2007 13:31:45 -0000 1.18
+++ octets.lisp 29 Nov 2007 17:30:18 -0000 1.19
@@ -817,7 +817,8 @@
(declare (type (vector (unsigned-byte 8)) vector))
(with-array-data ((vector vector)
(start start)
- (end (%check-vector-sequence-bounds vector start end)))
+ (end end)
+ :check-fill-pointer t)
(declare (type (simple-array (unsigned-byte 8) (*)) vector))
(funcall (symbol-function (first (external-formats-funs external-format)))
vector start end)))
@@ -827,7 +828,8 @@
(declare (type string string))
(with-array-data ((string string)
(start start)
- (end (%check-vector-sequence-bounds string start end)))
+ (end end)
+ :check-fill-pointer t)
(declare (type simple-string string))
(funcall (symbol-function (second (external-formats-funs external-format)))
string start end (if null-terminate 1 0))))
Index: print.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/code/print.lisp,v
retrieving revision 1.71
retrieving revision 1.72
diff -u -d -r1.71 -r1.72
--- print.lisp 9 Jun 2007 18:31:38 -0000 1.71
+++ print.lisp 29 Nov 2007 17:30:18 -0000 1.72
@@ -908,7 +908,8 @@
;; this for now. [noted by anonymous long ago] -- WHN 19991130
`(or (char= ,char #\\)
(char= ,char #\"))))
- (with-array-data ((data string) (start) (end (length string)))
+ (with-array-data ((data string) (start) (end)
+ :check-fill-pointer t)
(do ((index start (1+ index)))
((>= index end))
(let ((char (schar data index)))
Index: reader.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/code/reader.lisp,v
retrieving revision 1.50
retrieving revision 1.51
diff -u -d -r1.50 -r1.51
--- reader.lisp 16 Sep 2007 12:05:17 -0000 1.50
+++ reader.lisp 29 Nov 2007 17:30:18 -0000 1.51
@@ -1521,7 +1521,8 @@
(declare (string string))
(with-array-data ((string string :offset-var offset)
(start start)
- (end (%check-vector-sequence-bounds string start end)))
+ (end end)
+ :check-fill-pointer t)
(let ((stream (make-string-input-stream string start end)))
(values (if preserve-whitespace
(read-preserving-whitespace stream eof-error-p eof-value)
@@ -1542,7 +1543,8 @@
:format-arguments (list string))))
(with-array-data ((string string :offset-var offset)
(start start)
- (end (%check-vector-sequence-bounds string start end)))
+ (end end)
+ :check-fill-pointer t)
(let ((index (do ((i start (1+ i)))
((= i end)
(if junk-allowed
Index: seq.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/code/seq.lisp,v
retrieving revision 1.75
retrieving revision 1.76
diff -u -d -r1.75 -r1.76
--- seq.lisp 20 Nov 2007 14:19:54 -0000 1.75
+++ seq.lisp 29 Nov 2007 17:30:18 -0000 1.76
@@ -2132,8 +2132,8 @@
(frob sequence-arg from-end)
(with-array-data ((sequence sequence-arg :offset-var offset)
(start start)
- (end (%check-vector-sequence-bounds
- sequence-arg start end)))
+ (end end)
+ :check-fill-pointer t)
(multiple-value-bind (f p)
(macrolet ((frob2 () '(if from-end
(frob sequence t)
Index: sort.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/code/sort.lisp,v
retrieving revision 1.22
retrieving revision 1.23
diff -u -d -r1.22 -r1.23
--- sort.lisp 13 Apr 2007 12:32:19 -0000 1.22
+++ sort.lisp 29 Nov 2007 17:30:19 -0000 1.23
@@ -31,8 +31,9 @@
(if key (%coerce-callable-to-fun key) #'identity))
(let ((key-fun-or-nil (and key (%coerce-callable-to-fun key))))
(with-array-data ((vector (the vector sequence))
- (start 0)
- (end (length sequence)))
+ (start)
+ (end)
+ :check-fill-pointer t)
(sort-vector vector start end predicate-fun key-fun-or-nil))
sequence)
(apply #'sb!sequence:sort sequence predicate args))))
Index: stream.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/code/stream.lisp,v
retrieving revision 1.94
retrieving revision 1.95
diff -u -d -r1.94 -r1.95
--- stream.lisp 10 Sep 2007 13:31:45 -0000 1.94
+++ stream.lisp 29 Nov 2007 17:30:19 -0000 1.95
@@ -572,12 +572,11 @@
(declare (type string string))
(declare (type ansi-stream stream))
(declare (type index start end))
- (if (array-header-p string)
- (with-array-data ((data string) (offset-start start)
- (offset-end end))
- (funcall (ansi-stream-sout stream)
- stream data offset-start offset-end))
- (funcall (ansi-stream-sout stream) stream string start end))
+ (with-array-data ((data string) (offset-start start)
+ (offset-end end)
+ :check-fill-pointer t)
+ (funcall (ansi-stream-sout stream)
+ stream data offset-start offset-end))
string)
(defun %write-string (string stream start end)
@@ -1181,8 +1180,8 @@
(declare (type string string)
(type index start)
(type (or index null) end))
- (let* ((string (coerce string '(simple-array character (*))))
- (end (%check-vector-sequence-bounds string start end)))
+ (let* ((string (coerce string '(simple-array character (*)))))
+ ;; FIXME: Why WITH-ARRAY-DATA, since the array is already simple?
(with-array-data ((string string) (start start) (end end))
(internal-make-string-input-stream
string ;; now simple
@@ -1969,7 +1968,8 @@
(return i))
(setf (first rem) el)))))
(vector
- (with-array-data ((data seq) (offset-start start) (offset-end end))
+ (with-array-data ((data seq) (offset-start start) (offset-end end)
+ :check-fill-pointer t)
(if (compatible-vector-and-stream-element-types-p data stream)
(let* ((numbytes (- end start))
(bytes-read (read-n-bytes stream data offset-start
@@ -2036,7 +2036,8 @@
(string
(%write-string seq stream start end))
(vector
- (with-array-data ((data seq) (offset-start start) (offset-end end))
+ (with-array-data ((data seq) (offset-start start) (offset-end end)
+ :check-fill-pointer t)
(labels
((output-seq-in-loop ()
(let ((write-function
Index: string.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/code/string.lisp,v
retrieving revision 1.12
retrieving revision 1.13
diff -u -d -r1.12 -r1.13
--- string.lisp 19 Apr 2007 12:01:32 -0000 1.12
+++ string.lisp 29 Nov 2007 17:30:20 -0000 1.13
@@ -47,15 +47,16 @@
`(let* ((,string (if (stringp ,string) ,string (string ,string))))
(with-array-data ((,string ,string)
(,start ,start)
- (,end
- (%check-vector-sequence-bounds ,string ,start ,end)))
+ (,end ,end)
+ :check-fill-pointer t)
,@forms)))
;;; WITH-STRING is like WITH-ONE-STRING, but doesn't parse keywords.
(sb!xc:defmacro with-string (string &rest forms)
`(let ((,string (if (stringp ,string) ,string (string ,string))))
(with-array-data ((,string ,string)
(start)
- (end (length (the vector ,string))))
+ (end)
+ :check-fill-pointer t)
,@forms)))
;;; WITH-TWO-STRINGS is used to set up string comparison operations. The
;;; keywords are parsed, and the strings are hacked into SIMPLE-STRINGs.
@@ -65,12 +66,12 @@
(,string2 (if (stringp ,string2) ,string2 (string ,string2))))
(with-array-data ((,string1 ,string1 :offset-var ,cum-offset-1)
(,start1 ,start1)
- (,end1 (%check-vector-sequence-bounds
- ,string1 ,start1 ,end1)))
+ (,end1 ,end1)
+ :check-fill-pointer t)
(with-array-data ((,string2 ,string2)
(,start2 ,start2)
- (,end2 (%check-vector-sequence-bounds
- ,string2 ,start2 ,end2)))
+ (,end2 ,end2)
+ :check-fill-pointer t)
,@forms))))
) ; EVAL-WHEN
Index: timer.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/code/timer.lisp,v
retrieving revision 1.11
retrieving revision 1.12
diff -u -d -r1.11 -r1.12
--- timer.lisp 8 Jun 2007 20:38:22 -0000 1.11
+++ timer.lisp 29 Nov 2007 17:30:20 -0000 1.12
@@ -65,7 +65,7 @@
(aref heap 0)))
(defun heap-extract (heap i &key (key #'identity) (test #'>=))
- (when (< (length heap) i)
+ (unless (> (length heap) i)
(error "Heap underflow"))
(prog1
(aref heap i)
|
Thread View
| Thread | Author | Date |
|---|---|---|
| [Sbcl-commits] CVS: sbcl/src/code array.lisp, 1.70, 1.71 cross-misc.lisp, 1.28, 1.29 octets.lisp, 1.18, 1.19 print.lisp, 1.71, 1.72 reader.lisp, 1.50, 1.51 seq.lisp, 1.75, 1.76 sort.lisp, 1.22, 1.23 stream.lisp, 1.94, 1.95 string.lisp, 1.12, 1.13 timer.lisp, 1.11, 1.12 | Nikodemus Siivola <demoss@us...> |