- (call `(funcall ,fn-sym . ,(args-to-fn)))
- (endtest `(or ,@(tests))))
- (ecase accumulate
- (:nconc
- (let ((temp (gensym))
- (map-result (gensym)))
- `(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 ((,fn-sym ,fn)
- (,map-result (list nil)))
- (do-anonymous ((,temp ,map-result) . ,(do-clauses))
- (,endtest (truly-the list (cdr ,map-result)))
- (rplacd ,temp (setq ,temp (list ,call)))))))
- ((nil)
- `(let ((,fn-sym ,fn)
- (,n-first ,(first arglists)))
- (do-anonymous ,(do-clauses)
- (,endtest (truly-the list ,n-first))
+ (call `(funcall ,fn-sym . ,(args-to-fn)))
+ (endtest `(or ,@(tests))))
+ (ecase accumulate
+ (:nconc
+ (let ((temp (gensym))
+ (map-result (gensym)))
+ `(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 ((,fn-sym ,fn)
+ (,map-result (list nil)))
+ (do-anonymous ((,temp ,map-result) . ,(do-clauses))
+ (,endtest (truly-the list (cdr ,map-result)))
+ (rplacd ,temp (setq ,temp (list ,call)))))))
+ ((nil)
+ `(let ((,fn-sym ,fn)
+ (,n-first ,(first arglists)))
+ (do-anonymous ,(do-clauses)
+ (,endtest (truly-the list ,n-first))
- (bare `(%map result-type-arg fun ,@seq-names))
- (constant-result-type-arg-p (constant-lvar-p result-type-arg))
- ;; what we know about the type of the result. (Note that the
- ;; "result type" argument is not necessarily the type of the
- ;; result, since NIL means the result has NULL type.)
- (result-type (if (not constant-result-type-arg-p)
- 'consed-sequence
- (let ((result-type-arg-value
- (lvar-value result-type-arg)))
- (if (null result-type-arg-value)
- 'null
- result-type-arg-value)))))
+ (bare `(%map result-type-arg fun ,@seq-names))
+ (constant-result-type-arg-p (constant-lvar-p result-type-arg))
+ ;; what we know about the type of the result. (Note that the
+ ;; "result type" argument is not necessarily the type of the
+ ;; result, since NIL means the result has NULL type.)
+ (result-type (if (not constant-result-type-arg-p)
+ 'consed-sequence
+ (let ((result-type-arg-value
+ (lvar-value result-type-arg)))
+ (if (null result-type-arg-value)
+ 'null
+ result-type-arg-value)))))
- ,(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)))
- (if (array-type-p result-ctype)
- (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))))))))
+ ,(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)))
+ (if (array-type-p result-ctype)
+ (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))))))))
- ;; The consing arity-1 cases can be implemented
- ;; reasonably efficiently as function calls, and the cost
- ;; of consing should be significantly larger than
- ;; function call overhead, so we always compile these
- ;; cases as full calls regardless of speed-versus-space
- ;; optimization policy.
- (cond ((subtypep result-type-value 'list)
- '(%map-to-list-arity-1 fun seq))
- ( ;; (This one can be inefficient due to COERCE, but
- ;; the current open-coded implementation has the
- ;; same problem.)
- (subtypep result-type-value 'vector)
- `(coerce (%map-to-simple-vector-arity-1 fun seq)
- ',result-type-value))
- (t (bug "impossible (?) sequence type"))))
- (t
- (let* ((seqs (cons seq seqs))
- (seq-args (make-gensym-list (length seqs))))
- (multiple-value-bind (push-dacc result)
- (ecase result-supertype
- (null (values nil nil))
- (list (values `(push funcall-result acc)
+ ;; The consing arity-1 cases can be implemented
+ ;; reasonably efficiently as function calls, and the cost
+ ;; of consing should be significantly larger than
+ ;; function call overhead, so we always compile these
+ ;; cases as full calls regardless of speed-versus-space
+ ;; optimization policy.
+ (cond ((subtypep result-type-value 'list)
+ '(%map-to-list-arity-1 fun seq))
+ ( ;; (This one can be inefficient due to COERCE, but
+ ;; the current open-coded implementation has the
+ ;; same problem.)
+ (subtypep result-type-value 'vector)
+ `(coerce (%map-to-simple-vector-arity-1 fun seq)
+ ',result-type-value))
+ (t (bug "impossible (?) sequence type"))))
+ (t
+ (let* ((seqs (cons seq seqs))
+ (seq-args (make-gensym-list (length seqs))))
+ (multiple-value-bind (push-dacc result)
+ (ecase result-supertype
+ (null (values nil nil))
+ (list (values `(push funcall-result acc)
- (vector (values `(push funcall-result acc)
- `(coerce (nreverse acc)
- ',result-type-value))))
- ;; (We use the same idiom, of returning a LAMBDA from
- ;; DEFTRANSFORM, as is used in the DEFTRANSFORMs for
- ;; FUNCALL and ALIEN-FUNCALL, and for the same
- ;; reason: we need to get the runtime values of each
- ;; of the &REST vars.)
- `(lambda (result-type fun ,@seq-args)
- (declare (ignore result-type))
+ (vector (values `(push funcall-result acc)
+ `(coerce (nreverse acc)
+ ',result-type-value))))
+ ;; (We use the same idiom, of returning a LAMBDA from
+ ;; DEFTRANSFORM, as is used in the DEFTRANSFORMs for
+ ;; FUNCALL and ALIEN-FUNCALL, and for the same
+ ;; reason: we need to get the runtime values of each
+ ;; of the &REST vars.)
+ `(lambda (result-type fun ,@seq-args)
+ (declare (ignore result-type))
- (let* ((n-stop (gensym))
- (n-idx (or index (gensym)))
- (start (default-arg 0 start))
- (end (default-arg `(length ,sequence) end)))
- (make-iterator
- :kind :normal
- :binds `((,n-idx ,(if from-end `(1- ,end) ,start))
- (,n-stop ,(if from-end `(1- ,start) ,end)))
- :decls `((type neg-index ,n-idx ,n-stop))
- :current `(aref ,sequence ,n-idx)
- :done `(,(if from-end '<= '>=) ,n-idx ,n-stop)
- :next `(setq ,n-idx
- ,(if from-end `(1- ,n-idx) `(1+ ,n-idx)))
- :length (if from-end
- `(- ,n-idx ,n-stop)
- `(- ,n-stop ,n-idx)))))
- ((csubtypep type (specifier-type 'list))
- (let* ((n-stop (if (and end (not from-end)) (gensym) nil))
- (n-current (gensym))
- (start-p (not (arg-eql start 0 0)))
- (end-p (not (arg-eql end nil nil)))
- (start (default-arg start 0))
- (end (default-arg end nil)))
- (make-iterator
- :binds `((,n-current
- ,(if from-end
- (if (or start-p end-p)
- `(nreverse (subseq ,sequence ,start
- ,@(when end `(,end))))
- `(reverse ,sequence))
- (if start-p
- `(nthcdr ,start ,sequence)
- sequence)))
- ,@(when n-stop
- `((,n-stop (nthcdr (the index
- (- ,end ,start))
- ,n-current))))
- ,@(when index
- `((,index ,(if from-end `(1- ,end) start)))))
- :kind :normal
- :decls `((list ,n-current ,n-end)
- ,@(when index `((type neg-index ,index))))
- :current `(car ,n-current)
- :done `(eq ,n-current ,n-stop)
- :length `(- ,(or end `(length ,sequence)) ,start)
- :next `(progn
- (setq ,n-current (cdr ,n-current))
- ,@(when index
- `((setq ,n-idx
- ,(if from-end
- `(1- ,index)
- `(1+ ,index)))))))))
- (t
- (give-up-ir1-transform
- "can't tell whether sequence is a list or a vector")))))
+ (let* ((n-stop (gensym))
+ (n-idx (or index (gensym)))
+ (start (default-arg 0 start))
+ (end (default-arg `(length ,sequence) end)))
+ (make-iterator
+ :kind :normal
+ :binds `((,n-idx ,(if from-end `(1- ,end) ,start))
+ (,n-stop ,(if from-end `(1- ,start) ,end)))
+ :decls `((type neg-index ,n-idx ,n-stop))
+ :current `(aref ,sequence ,n-idx)
+ :done `(,(if from-end '<= '>=) ,n-idx ,n-stop)
+ :next `(setq ,n-idx
+ ,(if from-end `(1- ,n-idx) `(1+ ,n-idx)))
+ :length (if from-end
+ `(- ,n-idx ,n-stop)
+ `(- ,n-stop ,n-idx)))))
+ ((csubtypep type (specifier-type 'list))
+ (let* ((n-stop (if (and end (not from-end)) (gensym) nil))
+ (n-current (gensym))
+ (start-p (not (arg-eql start 0 0)))
+ (end-p (not (arg-eql end nil nil)))
+ (start (default-arg start 0))
+ (end (default-arg end nil)))
+ (make-iterator
+ :binds `((,n-current
+ ,(if from-end
+ (if (or start-p end-p)
+ `(nreverse (subseq ,sequence ,start
+ ,@(when end `(,end))))
+ `(reverse ,sequence))
+ (if start-p
+ `(nthcdr ,start ,sequence)
+ sequence)))
+ ,@(when n-stop
+ `((,n-stop (nthcdr (the index
+ (- ,end ,start))
+ ,n-current))))
+ ,@(when index
+ `((,index ,(if from-end `(1- ,end) start)))))
+ :kind :normal
+ :decls `((list ,n-current ,n-end)
+ ,@(when index `((type neg-index ,index))))
+ :current `(car ,n-current)
+ :done `(eq ,n-current ,n-stop)
+ :length `(- ,(or end `(length ,sequence)) ,start)
+ :next `(progn
+ (setq ,n-current (cdr ,n-current))
+ ,@(when index
+ `((setq ,n-idx
+ ,(if from-end
+ `(1- ,index)
+ `(1+ ,index)))))))))
+ (t
+ (give-up-ir1-transform
+ "can't tell whether sequence is a list or a vector")))))
- (n-fun (arg-name ,(second spec)))
- (fun-cont (arg-cont ,(second spec))))
- (cond ((not fun-cont)
- `(macrolet ((,',(first spec) (&rest args)
- `(,',',(third spec) ,@args)))
- ,body))
- ((not (csubtypep (continuation-type fun-cont)
- (specifier-type 'function)))
- (when (policy *compiler-error-context*
- (> speed inhibit-warnings))
- (compiler-notify
- "~S may not be a function, so must coerce at run-time."
- n-fun))
- (once-only ((n-fun `(if (functionp ,n-fun)
- ,n-fun
- (symbol-function ,n-fun))))
- `(macrolet ((,',(first spec) (&rest args)
- `(funcall ,',n-fun ,@args)))
- ,body)))
- (t
- `(macrolet ((,',(first spec) (&rest args)
- `(funcall ,',n-fun ,@args)))
- ,body)))))))
+ (n-fun (arg-name ,(second spec)))
+ (fun-cont (arg-cont ,(second spec))))
+ (cond ((not fun-cont)
+ `(macrolet ((,',(first spec) (&rest args)
+ `(,',',(third spec) ,@args)))
+ ,body))
+ ((not (csubtypep (continuation-type fun-cont)
+ (specifier-type 'function)))
+ (when (policy *compiler-error-context*
+ (> speed inhibit-warnings))
+ (compiler-notify
+ "~S may not be a function, so must coerce at run-time."
+ n-fun))
+ (once-only ((n-fun `(if (functionp ,n-fun)
+ ,n-fun
+ (symbol-function ,n-fun))))
+ `(macrolet ((,',(first spec) (&rest args)
+ `(funcall ,',n-fun ,@args)))
+ ,body)))
+ (t
+ `(macrolet ((,',(first spec) (&rest args)
+ `(funcall ,',n-fun ,@args)))
+ ,body)))))))
- ;; It's not worth trying to inline vector code unless we
- ;; know a fair amount about it at compile time.
- (upgraded-element-type-specifier-or-give-up sequence)
- (unless (constant-lvar-p from-end)
- (give-up-ir1-transform
- "FROM-END argument value not known at compile time")))
- ((csubtypep ctype (specifier-type 'list))
- ;; Inlining on lists is generally worthwhile.
- )
- (t
- (give-up-ir1-transform
- "sequence type not known at compile time")))))
+ ;; It's not worth trying to inline vector code unless we
+ ;; know a fair amount about it at compile time.
+ (upgraded-element-type-specifier-or-give-up sequence)
+ (unless (constant-lvar-p from-end)
+ (give-up-ir1-transform
+ "FROM-END argument value not known at compile time")))
+ ((csubtypep ctype (specifier-type 'list))
+ ;; Inlining on lists is generally worthwhile.
+ )
+ (t
+ (give-up-ir1-transform
+ "sequence type not known at compile time")))))
- `(deftransform ,name ((predicate sequence from-end start end key)
- (function list t t t function)
- *
- :policy (> speed space))
- "expand inline"
- `(let ((index 0)
- (find nil)
- (position nil))
- (declare (type index index))
- (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)))
- (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))))))
+ `(deftransform ,name ((predicate sequence from-end start end key)
+ (function list t t t function)
+ *
+ :policy (> speed space))
+ "expand inline"
+ `(let ((index 0)
+ (find nil)
+ (position nil))
+ (declare (type index index))
+ (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)))
+ (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))))))
- (macrolet ((maybe-return ()
- '(let ((,element (aref ,sequence ,index)))
- (when ,done-p-expr
- (return-from ,block
- (values ,element
- (- ,index ,offset)))))))
- (if ,from-end
- (loop for ,index
- ;; (If we aren't fastidious about declaring that
- ;; INDEX might be -1, then (FIND 1 #() :FROM-END T)
- ;; can send us off into never-never land, since
- ;; INDEX is initialized to -1.)
- of-type index-or-minus-1
- from (1- ,end) downto ,start do
- (maybe-return))
- (loop for ,index of-type index from ,start below ,end do
- (maybe-return))))
- (values nil nil))))))
+ (macrolet ((maybe-return ()
+ '(let ((,element (aref ,sequence ,index)))
+ (when ,done-p-expr
+ (return-from ,block
+ (values ,element
+ (- ,index ,offset)))))))
+ (if ,from-end
+ (loop for ,index
+ ;; (If we aren't fastidious about declaring that
+ ;; INDEX might be -1, then (FIND 1 #() :FROM-END T)
+ ;; can send us off into never-never land, since
+ ;; INDEX is initialized to -1.)
+ of-type index-or-minus-1
+ from (1- ,end) downto ,start do
+ (maybe-return))
+ (loop for ,index of-type index from ,start below ,end do
+ (maybe-return))))
+ (values nil nil))))))