`(let ((,fn-sym ,fn)
(,map-result (list nil)))
(do-anonymous ((,temp ,map-result) . ,(do-clauses))
- (,endtest (cdr ,map-result))
+ (,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 ,n-first) ,call))))))))
+ (,endtest (truly-the list ,n-first))
+ ,call))))))))
(define-source-transform mapc (function list &rest more-lists)
(mapfoo-transform function (cons list more-lists) nil t))
;;; MAP is %MAP plus a check to make sure that any length specified in
;;; the result type matches the actual result. We also wrap it in a
;;; TRULY-THE for the most specific type we can determine.
-(deftransform map ((result-type-arg fun &rest seqs) * * :node node)
- (let* ((seq-names (make-gensym-list (length seqs)))
+(deftransform map ((result-type-arg fun seq &rest seqs) * * :node node)
+ (let* ((seq-names (make-gensym-list (1+ (length seqs))))
(bare `(%map result-type-arg fun ,@seq-names))
(constant-result-type-arg-p (constant-continuation-p result-type-arg))
;; what we know about the type of the result. (Note that the
(declare (type list seqs seq-names)
(type symbol into))
(collect ((bindings)
- (declarations)
+ (declarations)
(vector-lengths)
(tests)
(places))
for seq-name in seq-names
for type = (continuation-type seq)
do (cond ((csubtypep type (specifier-type 'list))
- (let ((index (gensym "I")))
+ (with-unique-names (index)
(bindings `(,index ,seq-name (cdr ,index)))
(declarations `(type list ,index))
(places `(car ,index))
;;; handle that case more efficiently, but it's left as an exercise to
;;; the reader, because the code is complicated enough already and I
;;; don't happen to need that functionality right now. -- WHN 20000410
-(deftransform %map ((result-type fun &rest seqs) * * :policy (>= speed space))
+(deftransform %map ((result-type fun seq &rest seqs) * *
+ :policy (>= speed space))
"open code"
- (unless seqs (abort-ir1-transform "no sequence args"))
(unless (constant-continuation-p result-type)
(give-up-ir1-transform "RESULT-TYPE argument not constant"))
(labels ( ;; 1-valued SUBTYPEP, fails unless second value of SUBTYPEP is true
(t
(give-up-ir1-transform
"can't determine result type")))))
- (cond ((and result-type-value (= 1 (length seqs)))
+ (cond ((and result-type-value (null seqs))
;; 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 'list result-type-value)
- '(apply #'%map-to-list-arity-1 fun seqs))
+ (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 (apply #'%map-to-simple-vector-arity-1 fun seqs)
+ `(coerce (%map-to-simple-vector-arity-1 fun seq)
',result-type-value))
(t (bug "impossible (?) sequence type"))))
(t
- (let* ((seq-args (make-gensym-list (length seqs))))
+ (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))
(specifier-type 'function)))
(when (policy *compiler-error-context*
(> speed inhibit-warnings))
- (compiler-note
+ (compiler-notify
"~S may not be a function, so must coerce at run-time."
n-fun))
(once-only ((n-fun `(if (functionp ,n-fun)
;;; 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.
+;;; must be SIMPLE-BASE-STRINGs.
(macrolet ((def (name lessp equalp)
`(deftransform ,name ((string1 string2 start1 end1 start2 end2)
- (simple-string simple-string t t t t) *)
+ (simple-base-string simple-base-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
(macrolet ((def (name result-fun)
`(deftransform ,name ((string1 string2 start1 end1 start2 end2)
- (simple-string simple-string t t t t) *)
+ (simple-base-string simple-base-string t t t t) *)
`(,',result-fun
(sb!impl::%sp-string-compare
string1 start1 (or end1 (length string1))
(deftransform replace ((string1 string2 &key (start1 0) (start2 0)
end1 end2)
- (simple-string simple-string &rest t)
+ (simple-base-string simple-base-string &rest t)
*
;; FIXME: consider replacing this policy test
;; with some tests for the STARTx and ENDx
;;;
;;; FIXME: currently KLUDGEed because of bug 188
(deftransform concatenate ((rtype &rest sequences)
- (t &rest simple-string)
- simple-string
+ (t &rest simple-base-string)
+ simple-base-string
:policy (< safety 3))
- (collect ((lets)
- (forms)
- (all-lengths)
- (args))
- (dolist (seq sequences)
- (declare (ignorable seq))
- (let ((n-seq (gensym))
- (n-length (gensym)))
- (args n-seq)
- (lets `(,n-length (the index (* (length ,n-seq) sb!vm:n-byte-bits))))
- (all-lengths n-length)
- (forms `(bit-bash-copy ,n-seq ,vector-data-bit-offset
- res start
- ,n-length))
- (forms `(setq start (opaque-identity (+ start ,n-length))))))
- `(lambda (rtype ,@(args))
- (declare (ignore rtype))
- ;; KLUDGE
- (flet ((opaque-identity (x) x))
- (declare (notinline opaque-identity))
- (let* (,@(lets)
- (res (make-string (truncate (the index (+ ,@(all-lengths)))
- sb!vm:n-byte-bits)))
- (start ,vector-data-bit-offset))
- (declare (type index start ,@(all-lengths)))
- ,@(forms)
- res)))))
+ (loop for rest-seqs on sequences
+ for n-seq = (gensym "N-SEQ")
+ for n-length = (gensym "N-LENGTH")
+ for start = vector-data-bit-offset then next-start
+ for next-start = (gensym "NEXT-START")
+ collect n-seq into args
+ collect `(,n-length (* (length ,n-seq) sb!vm:n-byte-bits)) into lets
+ collect n-length into all-lengths
+ collect next-start into starts
+ collect `(bit-bash-copy ,n-seq ,vector-data-bit-offset
+ res ,start ,n-length)
+ into forms
+ collect `(setq ,next-start (+ ,start ,n-length)) into forms
+ finally
+ (return
+ `(lambda (rtype ,@args)
+ (declare (ignore rtype))
+ (let* (,@lets
+ (res (make-string (truncate (the index (+ ,@all-lengths))
+ sb!vm:n-byte-bits))))
+ (declare (type index ,@all-lengths))
+ (let (,@(mapcar (lambda (name) `(,name 0)) starts))
+ (declare (type index ,@starts))
+ ,@forms)
+ res)))))
\f
;;;; CONS accessor DERIVE-TYPE optimizers
end-arg
element
done-p-expr)
- (let ((offset (gensym "OFFSET"))
- (block (gensym "BLOCK"))
- (index (gensym "INDEX"))
- (n-sequence (gensym "N-SEQUENCE-"))
- (sequence (gensym "SEQUENCE"))
- (n-end (gensym "N-END-"))
- (end (gensym "END-")))
+ (with-unique-names (offset block index n-sequence sequence n-end end)
`(let ((,n-sequence ,sequence-arg)
(,n-end ,end-arg))
(with-array-data ((,sequence ,n-sequence :offset-var ,offset)
(def!macro %find-position-vector-macro (item sequence
from-end start end key test)
- (let ((element (gensym "ELEMENT")))
+ (with-unique-names (element)
(%find-position-or-find-position-if-vector-expansion
sequence
from-end
(def!macro %find-position-if-vector-macro (predicate sequence
from-end start end key)
- (let ((element (gensym "ELEMENT")))
+ (with-unique-names (element)
(%find-position-or-find-position-if-vector-expansion
sequence
from-end
(def!macro %find-position-if-not-vector-macro (predicate sequence
from-end start end key)
- (let ((element (gensym "ELEMENT")))
+ (with-unique-names (element)
(%find-position-or-find-position-if-vector-expansion
sequence
from-end