`(sequence-of-checked-length-given-type ,bare
result-type-arg))
(t
- (let ((result-ctype (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)))
(subtypep result-type-value 'vector)
`(coerce (apply #'%map-to-simple-vector-arity-1 fun seqs)
',result-type-value))
- (t (give-up-ir1-transform
- "internal error: unexpected sequence type"))))
+ (t (bug "impossible (?) sequence type"))))
(t
(let* ((seq-args (make-gensym-list (length seqs)))
(index-bindingoids
(declare (ignorable dacc))
,push-dacc))))))))))
\f
-(deftransform elt ((s i) ((simple-array * (*)) *) * :when :both)
+(deftransform elt ((s i) ((simple-array * (*)) *) *)
'(aref s i))
-(deftransform elt ((s i) (list *) * :when :both)
+(deftransform elt ((s i) (list *) *)
'(nth i s))
-(deftransform %setelt ((s i v) ((simple-array * (*)) * *) * :when :both)
+(deftransform %setelt ((s i v) ((simple-array * (*)) * *) *)
'(%aset s i v))
(deftransform %setelt ((s i v) (list * *))
'(setf (car (nthcdr i s)) v))
-;;; FIXME: The MACROLET ... DEF-FROB ... DEFTRANSFORM idioms in this
-;;; file are literal translations of old CMU CL DOLIST ... DEFTRANSFORM,
-;;; and so use :EVAL-NAME for historical reasons. It'd be tidier to
-;;; just let macroexpansion substitution take care of everything,
-;;; and remove both :EVAL-NAME and the extra layer of quotes.
-
-(macrolet ((def-frob (name)
- `(deftransform ',name ((e l &key (test #'eql)) '* '* :node node :when :both
- :eval-name t)
+(macrolet ((def (name)
+ `(deftransform ,name ((e l &key (test #'eql)) * *
+ :node node)
(unless (constant-continuation-p l)
(give-up-ir1-transform))
,(frob (cdr els)))
nil)))
(frob val))))))
- (def-frob member)
- (def-frob memq))
+ (def member)
+ (def memq))
;;; FIXME: We have rewritten the original code that used DOLIST to this
;;; more natural MACROLET. However, the original code suggested that when
;;; this was done, a few bytes could be saved by a call to a shared
;;; function. This remains to be done.
-(macrolet ((def-frob (fun eq-fun)
- `(deftransform ',fun ((item list &key test) '(t list &rest t) '*
- :eval-name t)
+(macrolet ((def (fun eq-fun)
+ `(deftransform ,fun ((item list &key test) (t list &rest t) *)
"convert to EQ test"
;; FIXME: The scope of this transformation could be
;; widened somewhat, letting it work whenever the test is
;; if ITEM is not a NUMBER or is a FIXNUM, apply
;; transform, else give up on transform.
(cond (test
- (unless (continuation-function-is test '(eq))
+ (unless (continuation-fun-is test '(eq))
(give-up-ir1-transform)))
((types-equal-or-intersect (continuation-type item)
(specifier-type 'number))
(give-up-ir1-transform "Item might be a number.")))
`(,',eq-fun item list))))
- (def-frob delete delq)
- (def-frob assoc assq)
- (def-frob member memq))
+ (def delete delq)
+ (def assoc assq)
+ (def member memq))
(deftransform delete-if ((pred list) (t list))
"open code"
:policy (> speed space))
"open code"
(let ((element-type (upgraded-element-type-specifier-or-give-up seq)))
- `(with-array-data ((data seq)
- (start start)
- (end end))
+ (values
+ `(with-array-data ((data seq)
+ (start start)
+ (end end))
(declare (type (simple-array ,element-type 1) data))
+ (declare (type fixnum start end))
(do ((i start (1+ i)))
((= i end) seq)
(declare (type index i))
;; WITH-ARRAY-DATA did our range checks once and for all, so
- ;; it'd be wasteful to check again on every AREF.
+ ;; it'd be wasteful to check again on every AREF...
(declare (optimize (safety 0)))
- (setf (aref data i) item)))))
+ (setf (aref data i) item)))
+ ;; ... though we still need to check that the new element can fit
+ ;; into the vector in safe code. -- CSR, 2002-07-05
+ `((declare (type ,element-type item))))))
\f
;;;; utilities
-;;; Return true if CONT's only use is a non-notinline reference to a
+;;; Return true if CONT's only use is a non-NOTINLINE reference to a
;;; global function with one of the specified NAMES.
-(defun continuation-function-is (cont names)
+(defun continuation-fun-is (cont names)
(declare (type continuation cont) (list names))
(let ((use (continuation-use cont)))
(and (ref-p use)
(t
(give-up-ir1-transform))))
+;;; FIXME: Why is this code commented out? (Why *was* it commented
+;;; out? We inherited this situation from cmucl-2.4.8, with no
+;;; explanation.) Should we just delete this code?
#|
;;; This is a frob whose job it is to make it easier to pass around
;;; the arguments to IR1 transforms. It bundles together the name of
;; A form that returns the current value. This may be set with SETF to set
;; the current value.
(current (error "Must specify CURRENT."))
- ;; In a :Normal iterator, a form that tests whether there is a current value.
+ ;; In a :NORMAL iterator, a form that tests whether there is a current value.
(done nil)
- ;; In a :Result iterator, a form that truncates the result at the current
+ ;; In a :RESULT iterator, a form that truncates the result at the current
;; position and returns it.
(result nil)
;; A form that returns the initial total number of values. The result is
(defun make-result-sequence-iterator (name type length)
(declare (symbol name) (type ctype type))
-;;; Defines each Name as a local macro that will call the value of the
-;;; Fun-Arg with the given arguments. If the argument isn't known to be a
+;;; Define each NAME as a local macro that will call the value of the
+;;; function arg with the given arguments. If the argument isn't known to be a
;;; function, give them an efficiency note and reference a coerced version.
-(defmacro coerce-functions (specs &body body)
+(defmacro coerce-funs (specs &body body)
#!+sb-doc
"COERCE-FUNCTIONS ({(Name Fun-Arg Default)}*) Form*"
(collect ((binds)
(abort-ir1-transform "Both ~S and ~S were supplied."
(arg-name ,test)
(arg-name ,test-not)))
- (coerce-functions ((,name (if not-p ,test-not ,test) eql))
+ (coerce-funs ((,name (if not-p ,test-not ,test) eql))
,@body)))
|#
\f
;;; We transform the case-sensitive string predicates into a non-keyword
;;; version. This is an IR1 transform so that we don't have to worry about
;;; changing the order of evaluation.
-(macrolet ((def-frob (fun pred*)
- `(deftransform ',fun ((string1 string2 &key (start1 0) end1
+(macrolet ((def (fun pred*)
+ `(deftransform ,fun ((string1 string2 &key (start1 0) end1
(start2 0) end2)
- '* '* :eval-name t)
+ * *)
`(,',pred* string1 string2 start1 end1 start2 end2))))
- (def-frob string< string<*)
- (def-frob string> string>*)
- (def-frob string<= string<=*)
- (def-frob string>= string>=*)
- (def-frob string= string=*)
- (def-frob string/= string/=*))
+ (def string< string<*)
+ (def string> string>*)
+ (def string<= string<=*)
+ (def string>= string>=*)
+ (def string= string=*)
+ (def string/= string/=*))
;;; Return a form that tests the free variables STRING1 and STRING2
;;; for the ordering relationship specified by LESSP and EQUALP. The
;;; start and end are also gotten from the environment. Both strings
;;; must be SIMPLE-STRINGs.
-(macrolet ((def-frob (name lessp equalp)
- `(deftransform ',name ((string1 string2 start1 end1 start2 end2)
- '(simple-string simple-string t t t t) '*
- :eval-name t)
+(macrolet ((def (name lessp equalp)
+ `(deftransform ,name ((string1 string2 start1 end1 start2 end2)
+ (simple-string simple-string t t t t) *)
`(let* ((end1 (if (not end1) (length string1) end1))
(end2 (if (not end2) (length string2) end2))
(index (sb!impl::%sp-string-compare
(truly-the index
(+ index
(truly-the fixnum
- (- start2 start1))))))
+ (- start2
+ start1))))))
index)
(t nil))
,(if ',equalp 'end1 nil))))))
- (def-frob string<* t nil)
- (def-frob string<=* t t)
- (def-frob string>* nil nil)
- (def-frob string>=* nil t))
-
-(macrolet ((def-frob (name result-fun)
- `(deftransform ',name ((string1 string2 start1 end1 start2 end2)
- '(simple-string simple-string t t t t) '*
- :eval-name t)
+ (def string<* t nil)
+ (def string<=* t t)
+ (def string>* nil nil)
+ (def string>=* nil t))
+
+(macrolet ((def (name result-fun)
+ `(deftransform ,name ((string1 string2 start1 end1 start2 end2)
+ (simple-string simple-string t t t t) *)
`(,',result-fun
(sb!impl::%sp-string-compare
string1 start1 (or end1 (length string1))
string2 start2 (or end2 (length string2)))))))
- (def-frob string=* not)
- (def-frob string/=* identity))
+ (def string=* not)
+ (def string/=* identity))
\f
;;;; string-only transforms for sequence functions
;;;; calls when all arguments are vectors with the same element type,
;;;; rather than restricting them to STRINGs only.
+;;; 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?
;;; %CONCATENATE (with a DEFTRANSFORM to translate constant RTYPE to
;;; CTYPE before calling %CONCATENATE) which is comparably efficient,
;;; at least once DYNAMIC-EXTENT works.
+#+nil ; FIXME: currently commented out because of bug 188
(deftransform concatenate ((rtype &rest sequences)
(t &rest simple-string)
simple-string)
(all-lengths)
(args))
(dolist (seq sequences)
- (declare (ignore seq))
+ (declare (ignorable seq))
(let ((n-seq (gensym))
(n-length (gensym)))
(args n-seq)
(give-up-ir1-transform
"sequence type not known at compile time")))))
-;;; %FIND-POSITION-IF for LIST data
-(deftransform %find-position-if ((predicate sequence from-end start end key)
- (function list t t t function)
- *
- :policy (> speed space)
- :important t)
- "expand inline"
- '(let ((index 0)
- (find nil)
- (position nil))
- (declare (type index index))
- (dolist (i sequence (values find position))
- (let ((key-i (funcall key i)))
- (when (and end (>= index end))
- (return (values find position)))
- (when (>= index start)
- (when (funcall predicate key-i)
- ;; This hack of dealing with non-NIL FROM-END for list
- ;; data by iterating forward through the list and keeping
- ;; track of the last time we found a match might be more
- ;; screwy than what the user expects, but it seems to be
- ;; allowed by the ANSI standard. (And if the user is
- ;; screwy enough to ask for FROM-END behavior on list
- ;; data, turnabout is fair play.)
- ;;
- ;; It's also not enormously efficient, calling PREDICATE
- ;; and KEY more often than necessary; but all the
- ;; alternatives seem to have their own efficiency
- ;; problems.
- (if from-end
- (setf find i
- position index)
- (return (values i index))))))
- (incf index))))
-
+;;; %FIND-POSITION-IF and %FIND-POSITION-IF-NOT for LIST data
+(macrolet ((def (name condition)
+ `(deftransform ,name ((predicate sequence from-end start end key)
+ (function list t t t function)
+ *
+ :policy (> speed space)
+ :important t)
+ "expand inline"
+ `(let ((index 0)
+ (find nil)
+ (position nil))
+ (declare (type index index))
+ (dolist (i sequence (values find position))
+ (let ((key-i (funcall key i)))
+ (when (and end (>= index end))
+ (return (values find position)))
+ (when (>= index start)
+ (,',condition (funcall predicate key-i)
+ ;; This hack of dealing with non-NIL
+ ;; FROM-END for list data by iterating
+ ;; forward through the list and keeping
+ ;; track of the last time we found a match
+ ;; might be more screwy than what the user
+ ;; expects, but it seems to be allowed by
+ ;; the ANSI standard. (And if the user is
+ ;; screwy enough to ask for FROM-END
+ ;; behavior on list data, turnabout is
+ ;; fair play.)
+ ;;
+ ;; It's also not enormously efficient,
+ ;; calling PREDICATE and KEY more often
+ ;; than necessary; but all the
+ ;; alternatives seem to have their own
+ ;; efficiency problems.
+ (if from-end
+ (setf find i
+ position index)
+ (return (values i index))))))
+ (incf index))))))
+ (def %find-position-if when)
+ (def %find-position-if-not unless))
+
;;; %FIND-POSITION for LIST data can be expanded into %FIND-POSITION-IF
;;; without loss of efficiency. (I.e., the optimizer should be able
;;; to straighten everything out.)
element
`(funcall ,predicate (funcall ,key ,element)))))
-;;; %FIND-POSITION and %FIND-POSITION-IF for VECTOR data
+(def!macro %find-position-if-not-vector-macro (predicate sequence
+ from-end start end key)
+ (let ((element (gensym "ELEMENT")))
+ (%find-position-or-find-position-if-vector-expansion
+ sequence
+ from-end
+ start
+ end
+ element
+ `(not (funcall ,predicate (funcall ,key ,element))))))
+
+;;; %FIND-POSITION, %FIND-POSITION-IF and %FIND-POSITION-IF-NOT for
+;;; VECTOR data
(deftransform %find-position-if ((predicate sequence from-end start end key)
(function vector t t t function)
*
(check-inlineability-of-find-position-if sequence from-end)
'(%find-position-if-vector-macro predicate sequence
from-end start end key))
+
+(deftransform %find-position-if-not ((predicate sequence from-end start end key)
+ (function vector t t t function)
+ *
+ :policy (> speed space)
+ :important t)
+ "expand inline"
+ (check-inlineability-of-find-position-if sequence from-end)
+ '(%find-position-if-not-vector-macro predicate sequence
+ from-end start end key))
+
(deftransform %find-position ((item sequence from-end start end key test)
(t vector t t t function function)
*
projects / sbcl.git / blobdiff