X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fseqtran.lisp;h=58b0327c8c445b7ae205fb7508ca623076d9e17d;hb=57e21c4b62e8c1a1ee7ef59ed2abb0c864fb06bc;hp=d2de8d2fd25cbcb33ea36dab4a6b097c85594233;hpb=0c7ffa8fb85a94482814835c9f28abfd0400ab99;p=sbcl.git diff --git a/src/compiler/seqtran.lisp b/src/compiler/seqtran.lisp index d2de8d2..58b0327 100644 --- a/src/compiler/seqtran.lisp +++ b/src/compiler/seqtran.lisp @@ -26,27 +26,32 @@ (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)) + (,endtest (truly-the list (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)))))))) + (,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)) @@ -71,38 +76,99 @@ ;;; 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)) + (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 - (continuation-value result-type-arg))) + (lvar-value result-type-arg))) (if (null result-type-arg-value) 'null 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 (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)))))))) +;;; Return a DO loop, mapping a function FUN to elements of +;;; sequences. SEQS is a list of continuations, SEQ-NAMES - list of +;;; variables, bound to sequences, INTO - a variable, which is used in +;;; MAP-INTO. RESULT and BODY are forms, which can use variables +;;; FUNCALL-RESULT, containing the result of application of FUN, and +;;; INDEX, containing the current position in sequences. +(defun build-sequence-iterator (seqs seq-names &key result into body) + (declare (type list seqs seq-names) + (type symbol into)) + (collect ((bindings) + (declarations) + (vector-lengths) + (tests) + (places)) + (let ((found-vector-p nil)) + (flet ((process-vector (length) + (unless found-vector-p + (setq found-vector-p t) + (bindings `(index 0 (1+ index))) + (declarations `(type index index))) + (vector-lengths length))) + (loop for seq of-type lvar in seqs + for seq-name in seq-names + for type = (lvar-type seq) + do (cond ((csubtypep type (specifier-type 'list)) + (with-unique-names (index) + (bindings `(,index ,seq-name (cdr ,index))) + (declarations `(type list ,index)) + (places `(car ,index)) + (tests `(endp ,index)))) + ((csubtypep type (specifier-type 'vector)) + (process-vector `(length ,seq-name)) + (places `(aref ,seq-name index))) + (t + (give-up-ir1-transform + "can't determine sequence argument type")))) + (when into + (process-vector `(array-dimension ,into 0)))) + (when found-vector-p + (bindings `(length (min ,@(vector-lengths)))) + (tests `(= index length))) + `(do (,@(bindings)) + ((or ,@(tests)) ,result) + (declare ,@(declarations)) + (let ((funcall-result (funcall fun ,@(places)))) + (declare (ignorable funcall-result)) + ,body))))) + ;;; Try to compile %MAP efficiently when we can determine sequence ;;; argument types at compile time. ;;; @@ -115,28 +181,20 @@ ;;; 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) + (unless (constant-lvar-p result-type) (give-up-ir1-transform "RESULT-TYPE argument not constant")) - (labels (;; 1-valued SUBTYPEP, fails unless second value of SUBTYPEP is true + (labels ( ;; 1-valued SUBTYPEP, fails unless second value of SUBTYPEP is true (fn-1subtypep (fn x y) (multiple-value-bind (subtype-p valid-p) (funcall fn x y) (if valid-p subtype-p (give-up-ir1-transform "can't analyze sequence type relationship")))) - (1subtypep (x y) (fn-1subtypep #'sb!xc:subtypep x y)) - (1csubtypep (x y) (fn-1subtypep #'csubtypep x y)) - (seq-supertype (seq) - (let ((ctype (continuation-type seq))) - (cond ((1csubtypep ctype (specifier-type 'vector)) 'vector) - ((1csubtypep ctype (specifier-type 'list)) 'list) - (t - (give-up-ir1-transform - "can't determine sequence argument type")))))) - (let* ((result-type-value (continuation-value result-type)) + (1subtypep (x y) (fn-1subtypep #'sb!xc:subtypep x y))) + (let* ((result-type-value (lvar-value result-type)) (result-supertype (cond ((null result-type-value) 'null) ((1subtypep result-type-value 'vector) 'vector) @@ -144,56 +202,32 @@ 'list) (t (give-up-ir1-transform - "can't determine result type")))) - (seq-supertypes (mapcar #'seq-supertype seqs))) - (cond ((and result-type-value (= 1 (length seqs))) + "can't determine result type"))))) + (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)) - (;; (This one can be inefficient due to COERCE, but + (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 (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 - (mapcar (lambda (seq-arg seq-supertype) - (let ((i (gensym "I"))) - (ecase seq-supertype - (vector `(,i 0 (1+ ,i))) - (list `(,i ,seq-arg (rest ,i)))))) - seq-args seq-supertypes)) - (indices (mapcar #'first index-bindingoids)) - (index-decls (mapcar (lambda (index seq-supertype) - `(type ,(ecase seq-supertype - (vector 'index) - (list 'list)) - ,index)) - indices seq-supertypes)) - (tests (mapcar (lambda (seq-arg seq-supertype index) - (ecase seq-supertype - (vector `(>= ,index (length ,seq-arg))) - (list `(endp ,index)))) - seq-args seq-supertypes indices)) - (values (mapcar (lambda (seq-arg seq-supertype index) - (ecase seq-supertype - (vector `(aref ,seq-arg ,index)) - (list `(first ,index)))) - seq-args seq-supertypes indices))) - (multiple-value-bind (push-dacc final-result) + (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 dacc acc) `(nreverse acc))) - (vector (values `(push dacc acc) + (list (values `(push funcall-result acc) + `(nreverse acc))) + (vector (values `(push funcall-result acc) `(coerce (nreverse acc) ',result-type-value)))) ;; (We use the same idiom, of returning a LAMBDA from @@ -203,37 +237,66 @@ ;; of the &REST vars.) `(lambda (result-type fun ,@seq-args) (declare (ignore result-type)) - (do ((really-fun (%coerce-callable-to-fun fun)) - ,@index-bindingoids - (acc nil)) - ((or ,@tests) - ,final-result) - (declare ,@index-decls) - (declare (type list acc)) - (declare (ignorable acc)) - (let ((dacc (funcall really-fun ,@values))) - (declare (ignorable dacc)) - ,push-dacc)))))))))) + (let ((fun (%coerce-callable-to-fun fun)) + (acc nil)) + (declare (type list acc)) + (declare (ignorable acc)) + ,(build-sequence-iterator + seqs seq-args + :result result + :body push-dacc)))))))))) + +;;; MAP-INTO +(deftransform map-into ((result fun &rest seqs) + (vector * &rest *) + *) + "open code" + (let ((seqs-names (mapcar (lambda (x) + (declare (ignore x)) + (gensym)) + seqs))) + `(lambda (result fun ,@seqs-names) + ,(build-sequence-iterator + seqs seqs-names + :result '(when (array-has-fill-pointer-p result) + (setf (fill-pointer result) index)) + :into 'result + :body '(setf (aref result index) funcall-result)) + result))) + -(deftransform elt ((s i) ((simple-array * (*)) *) * :when :both) +;;; 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 *) * :when :both) +(deftransform elt ((s i) (list *) * :policy (< safety 3)) '(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 * *)) +(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 :when :both) - (unless (constant-continuation-p l) + :node node) + (unless (constant-lvar-p l) (give-up-ir1-transform)) - (let ((val (continuation-value l))) + (let ((val (lvar-value l))) (unless (policy node (or (= speed 3) (and (>= speed space) @@ -267,9 +330,9 @@ ;; if ITEM is not a NUMBER or is a FIXNUM, apply ;; transform, else give up on transform. (cond (test - (unless (continuation-fun-is test '(eq)) + (unless (lvar-fun-is test '(eq)) (give-up-ir1-transform))) - ((types-equal-or-intersect (continuation-type item) + ((types-equal-or-intersect (lvar-type item) (specifier-type 'number)) (give-up-ir1-transform "Item might be a number."))) `(,',eq-fun item list)))) @@ -294,25 +357,30 @@ :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)))))) ;;;; utilities ;;; Return true if CONT's only use is a non-NOTINLINE reference to a ;;; global function with one of the specified NAMES. -(defun continuation-fun-is (cont names) - (declare (type continuation cont) (list names)) - (let ((use (continuation-use cont))) +(defun lvar-fun-is (lvar names) + (declare (type lvar lvar) (list names)) + (let ((use (lvar-uses lvar))) (and (ref-p use) (let ((leaf (ref-leaf use))) (and (global-var-p leaf) @@ -325,11 +393,11 @@ ;;; IR1 transform. ;;; ;;; ### Probably should take an ARG and flame using the NAME. -(defun constant-value-or-lose (cont &optional default) - (declare (type (or continuation null) cont)) - (cond ((not cont) default) - ((constant-continuation-p cont) - (continuation-value cont)) +(defun constant-value-or-lose (lvar &optional default) + (declare (type (or lvar null) lvar)) + (cond ((not lvar) default) + ((constant-lvar-p lvar) + (lvar-value lvar)) (t (give-up-ir1-transform)))) @@ -389,9 +457,9 @@ ;; 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 @@ -501,7 +569,7 @@ (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) @@ -553,10 +621,10 @@ ;;; 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 @@ -582,7 +650,7 @@ (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)) @@ -606,17 +674,26 @@ ;;;; calls when all arguments are vectors with the same element type, ;;;; rather than restricting them to STRINGs only. -;;; 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.) +;;; Moved here from generic/vm-tran.lisp to satisfy clisp ;;; -;;; FIXME: Also, the transform should probably be dependent on -;;; SPEED>SPACE. +;;; 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)) + (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 + ;; 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 @@ -639,38 +716,46 @@ ;;; %CONCATENATE (with a DEFTRANSFORM to translate constant RTYPE to ;;; CTYPE before calling %CONCATENATE) which is comparably efficient, ;;; at least once DYNAMIC-EXTENT works. +;;; +;;; FIXME: currently KLUDGEed because of bug 188 (deftransform concatenate ((rtype &rest sequences) - (t &rest simple-string) - simple-string) - (collect ((lets) - (forms) - (all-lengths) - (args)) - (dolist (seq sequences) - (declare (ignore 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 (+ start ,n-length))))) - `(lambda (rtype ,@(args)) - (declare (ignore rtype)) - (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)))) + (t &rest (or simple-base-string + (simple-array nil (*)))) + simple-base-string + :policy (< safety 3)) + (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 `(if (and (typep ,n-seq '(simple-array nil (*))) + (> ,n-length 0)) + (error 'nil-array-accessed-error) + (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))))) ;;;; CONS accessor DERIVE-TYPE optimizers (defoptimizer (car derive-type) ((cons)) - (let ((type (continuation-type cons)) + (let ((type (lvar-type cons)) (null-type (specifier-type 'null))) (cond ((eq type null-type) null-type) @@ -678,7 +763,7 @@ (cons-type-car-type type))))) (defoptimizer (cdr derive-type) ((cons)) - (let ((type (continuation-type cons)) + (let ((type (lvar-type cons)) (null-type (specifier-type 'null))) (cond ((eq type null-type) null-type) @@ -691,12 +776,12 @@ ;;; %FIND-POSITION-IF only when %FIND-POSITION-IF has an inline ;;; expansion, so we factor out the condition into this function. (defun check-inlineability-of-find-position-if (sequence from-end) - (let ((ctype (continuation-type sequence))) + (let ((ctype (lvar-type sequence))) (cond ((csubtypep ctype (specifier-type 'vector)) ;; 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-continuation-p from-end) + (unless (constant-lvar-p from-end) (give-up-ir1-transform "FROM-END argument value not known at compile time"))) ((csubtypep ctype (specifier-type 'list)) @@ -718,7 +803,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))) @@ -747,7 +836,7 @@ (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.) @@ -758,26 +847,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 @@ -796,18 +869,13 @@ 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) (,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))) @@ -830,7 +898,7 @@ (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 @@ -844,7 +912,7 @@ (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 @@ -855,7 +923,7 @@ (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 @@ -895,3 +963,84 @@ (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) + (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) + (once-only ((key key)) + `(if ,key + (%coerce-callable-to-fun ,key) + #'identity))) + +(macrolet ((define-find-position (fun-name values-index) + `(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) + `(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)) + +;;; 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) + `(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))