result-type-arg-value)))))
`(lambda (result-type-arg fun ,@seq-names)
(truly-the ,result-type
- ,(cond ((policy node (> speed safety))
+ ,(cond ((policy node (< safety 3))
+ ;; ANSI requires the length-related type check only
+ ;; when the SAFETY quality is 3... in other cases, we
+ ;; skip it, because it could be expensive.
bare)
((not constant-result-type-arg-p)
`(sequence-of-checked-length-given-type ,bare
result-type-arg))
(t
- (let ((result-ctype (ir1-transform-specifier-type result-type)))
+ (let ((result-ctype (ir1-transform-specifier-type
+ result-type)))
(if (array-type-p result-ctype)
- (let* ((dims (array-type-dimensions result-ctype))
- (dim (first dims)))
- (if (eq dim '*)
- bare
- `(vector-of-checked-length-given-length ,bare
- ,dim)))
+ (let ((dims (array-type-dimensions result-ctype)))
+ (unless (and (listp dims) (= (length dims) 1))
+ (give-up-ir1-transform "invalid sequence type"))
+ (let ((dim (first dims)))
+ (if (eq dim '*)
+ bare
+ `(vector-of-checked-length-given-length ,bare
+ ,dim))))
+ ;; FIXME: this is wrong, as not all subtypes of
+ ;; VECTOR are ARRAY-TYPEs [consider, for
+ ;; example, (OR (VECTOR T 3) (VECTOR T
+ ;; 4))]. However, it's difficult to see what we
+ ;; should put here... maybe we should
+ ;; GIVE-UP-IR1-TRANSFORM if the type is a
+ ;; subtype of VECTOR but not an ARRAY-TYPE?
bare))))))))
;;; Try to compile %MAP efficiently when we can determine sequence
(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)))
(check-inlineability-of-find-position-if sequence from-end)
'(%find-position-vector-macro item sequence
from-end start end key test))
+
+;;; 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)))
+(define-source-transform effective-find-position-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))))))
+ (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))))))
+ (define-find-position-if find-if 0)
+ (define-find-position-if position-if 1))
+
+;;; the deprecated functions FIND-IF-NOT and POSITION-IF-NOT. We
+;;; didn't bother to worry about optimizing them, except note that on
+;;; Sat, Oct 06, 2001 at 04:22:38PM +0100, Christophe Rhodes wrote on
+;;; sbcl-devel
+;;;
+;;; My understanding is that while the :test-not argument is
+;;; deprecated in favour of :test (complement #'foo) because of
+;;; semantic difficulties (what happens if both :test and :test-not
+;;; are supplied, etc) the -if-not variants, while officially
+;;; deprecated, would be undeprecated were X3J13 actually to produce
+;;; a revised standard, as there are perfectly legitimate idiomatic
+;;; reasons for allowing the -if-not versions equal status,
+;;; particularly remove-if-not (== filter).
+;;;
+;;; This is only an informal understanding, I grant you, but
+;;; perhaps it's worth optimizing the -if-not versions in the same
+;;; way as the others?
+;;;
+;;; 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))))))
+ (define-find-position-if-not find-if-not 0)
+ (define-find-position-if-not position-if-not 1))
projects / sbcl.git / blobdiff