0.6.9.23:sbcl_0_6_10

	fixes in code-extra and compiler-extra
	Don't use deprecated POSITION-IF-NOT.

4 files changed, 144 insertions, 93 deletions

diff --git a/contrib/code-extras.lisp b/contrib/code-extras.lisp
index 41e395431..6df26a157 100644
--- a/contrib/code-extras.lisp
+++ b/contrib/code-extras.lisp
@@ -7,8 +7,6 @@
 (defun %with-array-data (array start end)
   (%with-array-data-macro array start end :fail-inline? t))
 
-;;; FIXME: vector-push-extend patch
-
 ;;; Like CMU CL, we use HEAPSORT. However, instead of trying to
 ;;; generalize the CMU CL code to allow START and END values, this
 ;;; code has been written from scratch following Chapter 7 of
@@ -122,18 +120,22 @@
 (defun vector-push-extend (new-element
 			   vector
 			   &optional
-			   (extension (1+ (length vector))))
+			   (extension nil extension-p))
   (declare (type vector vector))
-  (declare (type (integer 1 #.most-positive-fixnum) extension))
   (let ((old-fill-pointer (fill-pointer vector)))
     (declare (type index old-fill-pointer))
     (when (= old-fill-pointer (%array-available-elements vector))
-      (adjust-array vector (+ old-fill-pointer extension)))
+      (adjust-array vector (+ old-fill-pointer
+			      (if extension-p
+				  (the (integer 1 #.most-positive-fixnum)
+				    extension)
+				  (1+ old-fill-pointer)))))
     (setf (%array-fill-pointer vector)
 	  (1+ old-fill-pointer))
     ;; Wrapping the type test and the AREF in the same WITH-ARRAY-DATA
     ;; saves some time.
-    (with-array-data ((v vector) (i old-fill-pointer) (end))
+    (with-array-data ((v vector) (i old-fill-pointer) (end)
+		      :force-inline t)
       (declare (ignore end) (optimize (safety 0)))
       (if (simple-vector-p v) ; if common special case
           (setf (aref v i) new-element)
@@ -142,6 +144,16 @@
 
 ;;; FIXME: should DEFUN REPLACE in terms of same expansion as
 ;;; DEFTRANSFORM
+#+nil
+(defun replace (..)
+  (cond ((and (typep seq1 'simple-vector)
+	      (typep seq2 'simple-vector))
+	 (%replace-vector-vector ..))
+	((and (typep seq1 'simple-string)
+	      (typep seq2 'simple-string))
+	 (%replace-vector-vector ..))
+	(t
+	 ..)))
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;;;; POSITION/FIND stuff
@@ -154,9 +166,10 @@
   ;; NIL is never returned; and give (NEED (FIND ..)) workaround.
   (error "need to fix FIXMEs"))
   
-;;; logic to unravel :TEST and :TEST-NOT options in FIND/POSITION/etc.
-(declaim (inline %effective-test))
-(defun %effective-find-position-test (test test-not)
+;;; logic to unravel :TEST, :TEST-NOT, and :KEY options in FIND,
+;;; POSITION-IF, etc.
+(declaim (inline effective-find-position-test effective-find-position-key))
+(defun effective-find-position-test (test test-not)
   (cond ((and test test-not)
 	 (error "can't specify both :TEST and :TEST-NOT"))
 	(test (%coerce-callable-to-function test))
@@ -166,79 +179,12 @@
 	 ;; anyway, we don't care.)
 	 (complement (%coerce-callable-to-function test-not)))
 	(t #'eql)))
+(defun effective-find-position-key (key)
+  (if key
+      (%coerce-callable-to-function key)
+      #'identity))
 
-;;; the user interface to FIND and POSITION: Get all our ducks in a row,
-;;; then call %FIND-POSITION
-;;;
-;;; FIXME: These should probably be (MACROLET (..) (DEF-SOURCE-TRANSFORM ..))
-;;; instead of this DEFCONSTANT silliness.
-(eval-when (:compile-toplevel :execute)
-  (defconstant +find-fun-args+
-    '(item
-      sequence
-      &key
-      from-end
-      (start 0)
-      end
-      key
-      test
-      test-not))
-  (defconstant +find-fun-frob+
-    '(%find-position item
-		     sequence
-		     from-end
-		     start
-		     end
-		     (if key (%coerce-callable-to-function key) #'identity)
-		     (%effective-find-position-test test test-not))))
-(declaim (inline find position))
-(defun find     #.+find-fun-args+
-  (nth-value 0  #.+find-fun-frob+))
-(defun position #.+find-fun-args+
-  (nth-value 1  #.+find-fun-frob+))
-
-;;; the user interface to FIND-IF and POSITION-IF, entirely analogous
-;;; to the interface to FIND and POSITION
-(eval-when (:compile-toplevel :execute)
-  (defconstant +find-if-fun-args+
-    '(predicate
-      sequence
-      &key
-      from-end
-      (start 0)
-      end
-      (key #'identity)))
-  (defconstant +find-if-fun-frob+
-    '(%find-position-if (%coerce-callable-to-function predicate)
-			sequence
-			from-end
-			start
-			end
-			(%coerce-callable-to-function key))))
-;;; FIXME: A running SBCL doesn't like to have its FIND-IF and
-;;; POSITION-IF DEFUNed, dunno why yet..
-#|
-;;(declaim (maybe-inline find-if cl-user::%position-if))
-(defun find-if     #.+find-if-fun-args+
-  (nth-value 0     #.+find-if-fun-frob+))
-(defun cl-user::%position-if #.+find-if-fun-args+
-  (nth-value 1     #.+find-if-fun-frob+))
-(setf (symbol-function 'position-if)
-      #'cl-user::%position-if)
-;;(declaim (inline find-if cl-user::%position-if))
-|#
-
-;;; the deprecated functions FIND-IF-NOT and POSITION-IF-NOT
-(defun find-if-not     (predicate sequence &key from-end (start 0) end key)
-  (nth-value 0 (%find-position-if (complement (%coerce-callable-to-function
-					       predicate))
-				  sequence from-end start end key)))
-(defun position-if-not (predicate sequence &key from-end (start 0) end key)
-  (nth-value 1 (%find-position-if (complement (%coerce-callable-to-function
-					       predicate))
-				  sequence from-end start end key)))
-;;; FIXME: Remove uses of these deprecated functions, and of :TEST-NOT too.
-
+;;; shared guts of out-of-line FIND, POSITION, FIND-IF, and POSITION-IF
 (macrolet (;; shared logic for defining %FIND-POSITION and
 	   ;; %FIND-POSITION-IF in terms of various inlineable cases
 	   ;; of the expression defined in FROB and VECTOR*-FROB
@@ -275,3 +221,65 @@
 		 `(%find-position-if-vector-macro predicate ,sequence
 						  from-end start end key)))
       (frobs))))
+
+;;; the user interface to FIND and POSITION: Get all our ducks in a row,
+;;; then call %FIND-POSITION
+(declaim (inline find position))
+(macrolet ((def-find-position (fun-name values-index)
+	     `(defun ,fun-name (item
+				sequence
+				&key
+				from-end
+				(start 0)
+				end
+				key
+				test
+				test-not)
+		(nth-value
+		 ,values-index
+		 (%find-position item
+				 sequence
+				 from-end
+				 start
+				 end
+				 (effective-find-position-key key)
+				 (effective-find-position-test test
+							       test-not))))))
+  (def-find-position find 0)
+  (def-find-position position 1))
+
+;;; the user interface to FIND-IF and POSITION-IF, entirely analogous
+;;; to the interface to FIND and POSITION
+(declaim (inline find-if position-if))
+(macrolet ((def-find-position-if (fun-name values-index)
+	     `(defun ,fun-name (predicate sequence
+				&key from-end (start 0) end key)
+		(nth-value
+		 ,values-index
+		 (%find-position-if (%coerce-callable-to-function predicate)
+				    sequence
+				    from-end
+				    start
+				    end
+				    (effective-find-position-key key))))))
+  
+  (def-find-position-if find-if 0)
+  (def-find-position-if position-if 1))
+
+;;; the deprecated functions FIND-IF-NOT and POSITION-IF-NOT
+(macrolet ((def-find-position-if-not (fun-name values-index)
+	     `(defun ,fun-name (predicate sequence
+				&key from-end (start 0) end key)
+		(nth-value
+		 ,values-index
+		 (%find-position-if (complement (%coerce-callable-to-function
+						 predicate))
+				    sequence
+				    from-end
+				    start
+				    end
+				    (effective-find-position-key key))))))
+  (def-find-position-if-not find-if-not 0)
+  (def-find-position-if-not position-if-not 1))
+;;; FIXME: Remove uses of these deprecated functions, and of :TEST-NOT too.
+
diff --git a/contrib/compiler-extras.lisp b/contrib/compiler-extras.lisp
index 14c9c6541..d04a308ab 100644
--- a/contrib/compiler-extras.lisp
+++ b/contrib/compiler-extras.lisp
@@ -30,6 +30,58 @@
 
 (declaim (optimize (speed 1) (space 2)))
 
+;;; 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
+;;; may be further optimized.
+;;;
+;;; Given any ARRAY, bind DATA-VAR to the array's data vector and
+;;; START-VAR and END-VAR to the start and end of the designated
+;;; portion of the data vector. SVALUE and EVALUE are any start and
+;;; end specified to the original operation, and are factored into the
+;;; bindings of START-VAR and END-VAR. OFFSET-VAR is the cumulative
+;;; offset of all displacements encountered, and does not include
+;;; SVALUE.
+;;;
+;;; When FORCE-INLINE is set, the underlying %WITH-ARRAY-DATA form is
+;;; forced to be inline, overriding the ordinary judgment of the
+;;; %WITH-ARRAY-DATA DEFTRANSFORMs. Ordinarily the DEFTRANSFORMs are
+;;; fairly picky about their arguments, figuring that if you haven't
+;;; bothered to get all your ducks in a row, you probably don't care
+;;; that much about speed anyway! But in some cases it makes sense to
+;;; do type testing inside %WITH-ARRAY-DATA instead of outside, and
+;;; the DEFTRANSFORM can't tell that that's going on, so it can make
+;;; sense to use FORCE-INLINE option in that case.
+(defmacro with-array-data (((data-var array &key offset-var)
+			    (start-var &optional (svalue 0))
+			    (end-var &optional (evalue nil))
+			    &key force-inline)
+			   &body forms)
+  (once-only ((n-array array)
+	      (n-svalue `(the index ,svalue))
+	      (n-evalue `(the (or index null) ,evalue)))
+    `(multiple-value-bind (,data-var
+			   ,start-var
+			   ,end-var
+			   ,@(when offset-var `(,offset-var)))
+	 (if (not (array-header-p ,n-array))
+	     (let ((,n-array ,n-array))
+	       (declare (type (simple-array * (*)) ,n-array))
+	       ,(once-only ((n-len `(length ,n-array))
+			    (n-end `(or ,n-evalue ,n-len)))
+		  `(if (<= ,n-svalue ,n-end ,n-len)
+		       ;; success
+		       (values ,n-array ,n-svalue ,n-end 0)
+		       ;; failure: Make a NOTINLINE call to
+		       ;; %WITH-ARRAY-DATA with our bad data
+		       ;; to cause the error to be signalled.
+		       (locally
+			 (declare (notinline %with-array-data))
+			 (%with-array-data ,n-array ,n-svalue ,n-evalue)))))
+	     (,(if force-inline '%with-array-data-macro '%with-array-data)
+	      ,n-array ,n-svalue ,n-evalue))
+       ,@forms)))
+
 ;;; This is the fundamental definition of %WITH-ARRAY-DATA, for use in
 ;;; DEFTRANSFORMs and DEFUNs.
 (defmacro %with-array-data-macro (array
@@ -39,7 +91,6 @@
 				  (element-type '*)
 				  unsafe?
 				  fail-inline?)
-  (format t "~&/in %WITH-ARRAY-DATA-MACRO, ELEMENT-TYPE=~S~%" element-type)
   (let ((size (gensym "SIZE-"))
 	(data (gensym "DATA-"))
 	(cumulative-offset (gensym "CUMULATIVE-OFFSET-")))
@@ -92,8 +143,6 @@
 				:policy (> speed space))
   "inline non-SIMPLE-vector-handling logic"
   (let ((element-type (upgraded-element-type-specifier-or-give-up array)))
-    (format t "~&/in DEFTRANSFORM %WITH-ARRAY-DATA, ELEMENT-TYPE=~S~%"
-	    element-type)
     `(%with-array-data-macro array start end
 			     :unsafe? ,(policy node (= safety 0))
 			     :element-type ,element-type)))
@@ -182,7 +231,6 @@
 
 (setf (function-info-transforms (info :function :info 'coerce)) nil)
 (deftransform coerce ((x type) (* *) * :when :both)
-  (format t "~&/looking at DEFTRANSFORM COERCE~%")
   (unless (constant-continuation-p type)
     (give-up-ir1-transform))
   (let ((tspec (specifier-type (continuation-value type))))
@@ -314,14 +362,9 @@
 	(end (gensym "END-")))
     `(let ((,n-sequence ,sequence-arg)
 	   (,n-end ,end-arg))
-       ;;(format t "~&/n-sequence=~S~%" ,n-sequence)
-       ;;(format t "~&/simplicity=~S~%" (typep ,n-sequence 'simple-array))
-       ;;(describe ,n-sequence)
        (with-array-data ((,sequence ,n-sequence :offset-var ,offset)
 			 (,start ,start)
 			 (,end (or ,n-end (length ,n-sequence))))
-         ;;(format t "~&sequence=~S~%start=~S~%end=~S~%" ,sequence ,start ,end)
-	 ;;(format t "~&/n-sequence=~S~%" ,n-sequence)
          (block ,block
 	   (macrolet ((maybe-return ()
 			'(let ((,element (aref ,sequence ,index)))
diff --git a/src/compiler/ir1tran.lisp b/src/compiler/ir1tran.lisp
index c15321e1e..70d4cecc0 100644
--- a/src/compiler/ir1tran.lisp
+++ b/src/compiler/ir1tran.lisp
@@ -1927,7 +1927,7 @@
     (prev-link exit value-cont)
     (use-continuation exit (second found))))
 
-;;; Return a list of the segments of a tagbody. Each segment looks
+;;; Return a list of the segments of a TAGBODY. Each segment looks
 ;;; like (<tag> <form>* (go <next tag>)). That is, we break up the
 ;;; tagbody into segments of non-tag statements, and explicitly
 ;;; represent the drop-through with a GO. The first segment has a
@@ -1939,7 +1939,7 @@
   (collect ((segments))
     (let ((current (cons nil body)))
       (loop
-	(let ((tag-pos (position-if-not #'listp current :start 1)))
+	(let ((tag-pos (position-if (complement #'listp) current :start 1)))
 	  (unless tag-pos
 	    (segments `(,@current nil))
 	    (return))
diff --git a/version.lisp-expr b/version.lisp-expr
index fbc5ba256..539075792 100644
--- a/version.lisp-expr
+++ b/version.lisp-expr
@@ -15,4 +15,4 @@
 ;;; versions, and a string like "0.6.5.12" is used for versions which
 ;;; aren't released but correspond only to CVS tags or snapshots.
 
-"0.6.9.22"
+"0.6.9.23"