X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fseqtran.lisp;h=bfea7221c7e159c72fd2925fd298b614e187e7e9;hb=93c941d86b264637de20aa1b713757b704d4c1a6;hp=0e50c0fa1eed3b839392f8444fe9a97d93fecae3;hpb=09d7974601df2aaaa820ca576026b9b4f03e6ab1;p=sbcl.git

diff --git a/src/compiler/seqtran.lisp b/src/compiler/seqtran.lisp
index 0e50c0f..bfea722 100644
--- a/src/compiler/seqtran.lisp
+++ b/src/compiler/seqtran.lisp
@@ -26,25 +26,29 @@
 	  (tests `(endp ,v))
 	  (args-to-fn (if take-car `(car ,v) v))))
 
-      (let ((call `(funcall ,fn . ,(args-to-fn)))
-	    (endtest `(or ,@(tests))))
+      (let* ((fn-sym (gensym))  ; for ONCE-ONLY-ish purposes
+	     (call `(funcall ,fn-sym . ,(args-to-fn)))
+	     (endtest `(or ,@(tests))))
 	(ecase accumulate
 	  (:nconc
 	   (let ((temp (gensym))
 		 (map-result (gensym)))
-	     `(let ((,map-result (list nil)))
+	     `(let ((,fn-sym ,fn)
+		    (,map-result (list nil)))
 		(do-anonymous ((,temp ,map-result) . ,(do-clauses))
 			      (,endtest (cdr ,map-result))
 		  (setq ,temp (last (nconc ,temp ,call)))))))
 	  (:list
 	   (let ((temp (gensym))
 		 (map-result (gensym)))
-	     `(let ((,map-result (list nil)))
+	     `(let ((,fn-sym ,fn)
+		    (,map-result (list nil)))
 		(do-anonymous ((,temp ,map-result) . ,(do-clauses))
 			      (,endtest (cdr ,map-result))
 		  (rplacd ,temp (setq ,temp (list ,call)))))))
 	  ((nil)
-	   `(let ((,n-first ,(first arglists)))
+	   `(let ((,fn-sym ,fn)
+		  (,n-first ,(first arglists)))
 	      (do-anonymous ,(do-clauses)
 			    (,endtest ,n-first) ,call))))))))
 
@@ -227,18 +231,31 @@
 		      (declare (ignorable dacc))
 		      ,push-dacc))))))))))
 
+;;; 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)
@@ -625,24 +642,24 @@
 
 ;;; 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
@@ -750,7 +767,11 @@
 		       (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)))
@@ -790,26 +811,10 @@
 			      :important t)
   "expand inline"
   '(%find-position-if (let ((test-fun (%coerce-callable-to-fun test)))
-			;; I'm having difficulty believing I'm
-			;; reading it right, but as far as I can see,
-			;; the only guidance that ANSI gives for the
-			;; order of arguments to asymmetric tests is
-			;; the character-set dependent example from
-			;; the definition of FIND,
-			;;   (find #\d "here are some.." :test #'char>)
-			;;     => #\Space
-			;; (In ASCII, we have (CHAR> #\d #\SPACE)=>T.)
-			;; (Neither the POSITION definition page nor
-			;; section 17.2 ("Rules about Test Functions")
-			;; seem to consider the possibility of
-			;; asymmetry.)
-			;;
-			;; So, judging from the example, we want to
-			;; do (FUNCALL TEST-FUN ITEM I), because
-			;; (FUNCALL #'CHAR> #\d #\SPACE)=>T.
-			;;
-			;; -- WHN (whose attention was drawn to it by
-			;;         Alexey Dejneka's bug report/fix)
+			;; The order of arguments for asymmetric tests
+			;; (e.g. #'<, as opposed to order-independent
+			;; tests like #'=) is specified in the spec
+			;; section 17.2.1 -- the O/Zi stuff there.
 			(lambda (i)
 			  (funcall test-fun item i)))
 		      sequence
@@ -839,7 +844,8 @@
 	   (,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)))
@@ -931,44 +937,48 @@
 ;;; logic to unravel :TEST, :TEST-NOT, and :KEY options in FIND,
 ;;; POSITION-IF, etc.
 (define-source-transform 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-fun ,test))
-    (,test-not
-     ;; (Without DYNAMIC-EXTENT, this is potentially horribly
-     ;; inefficient, but since the TEST-NOT option is deprecated
-     ;; anyway, we don't care.)
-     (complement (%coerce-callable-to-fun ,test-not)))
-    (t #'eql)))
+  (once-only ((test test)
+	      (test-not test-not))
+    `(cond
+      ((and ,test ,test-not)
+       (error "can't specify both :TEST and :TEST-NOT"))
+      (,test (%coerce-callable-to-fun ,test))
+      (,test-not
+       ;; (Without DYNAMIC-EXTENT, this is potentially horribly
+       ;; inefficient, but since the TEST-NOT option is deprecated
+       ;; anyway, we don't care.)
+       (complement (%coerce-callable-to-fun ,test-not)))
+      (t #'eql))))
 (define-source-transform effective-find-position-key (key)
-  `(if ,key
-       (%coerce-callable-to-fun ,key)
-       #'identity))
+  (once-only ((key key))
+    `(if ,key
+	 (%coerce-callable-to-fun ,key)
+	 #'identity)))
 
 (macrolet ((define-find-position (fun-name values-index)
-	       `(define-source-transform ,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))))))
+	     `(deftransform ,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))))))
   (define-find-position find 0)
   (define-find-position position 1))
 
 (macrolet ((define-find-position-if (fun-name values-index)
-	       `(define-source-transform ,fun-name (predicate sequence &key
-						    from-end (start 0)
-						    end key)
-		 `(nth-value
-		   ,,values-index
-		   (%find-position-if (%coerce-callable-to-fun ,predicate)
-		    ,sequence ,from-end
-		    ,start ,end
-		    (effective-find-position-key ,key))))))
+	     `(deftransform ,fun-name ((predicate sequence &key
+						  from-end (start 0)
+						  end key))
+		'(nth-value
+		  ,values-index
+		  (%find-position-if (%coerce-callable-to-fun predicate)
+				     sequence from-end
+				     start end
+				     (effective-find-position-key key))))))
   (define-find-position-if find-if 0)
   (define-find-position-if position-if 1))
 
@@ -993,14 +1003,14 @@
 ;;; FIXME: Maybe remove uses of these deprecated functions (and
 ;;; definitely of :TEST-NOT) within the implementation of SBCL.
 (macrolet ((define-find-position-if-not (fun-name values-index)
-	       `(define-source-transform ,fun-name (predicate sequence &key
-						    from-end (start 0)
-						    end key)
-		 `(nth-value
-		   ,,values-index
-		   (%find-position-if-not (%coerce-callable-to-fun ,predicate)
-		    ,sequence ,from-end
-		    ,start ,end
-		    (effective-find-position-key ,key))))))
+	       `(deftransform ,fun-name ((predicate sequence &key
+					  from-end (start 0)
+					  end key))
+		 '(nth-value
+		   ,values-index
+		   (%find-position-if-not (%coerce-callable-to-fun predicate)
+		    sequence from-end
+		    start end
+		    (effective-find-position-key key))))))
   (define-find-position-if-not find-if-not 0)
   (define-find-position-if-not position-if-not 1))