(defun %with-array-data (array start end)
(%with-array-data-macro array start end :fail-inline? t))
-;;; FIXME: vector-push-extend patch
-
;;; Like CMU CL, we use HEAPSORT. However, instead of trying to
;;; generalize the CMU CL code to allow START and END values, this
;;; code has been written from scratch following Chapter 7 of
(defun vector-push-extend (new-element
vector
&optional
- (extension (1+ (length vector))))
+ (extension nil extension-p))
(declare (type vector vector))
- (declare (type (integer 1 #.most-positive-fixnum) extension))
(let ((old-fill-pointer (fill-pointer vector)))
(declare (type index old-fill-pointer))
(when (= old-fill-pointer (%array-available-elements vector))
- (adjust-array vector (+ old-fill-pointer extension)))
+ (adjust-array vector (+ old-fill-pointer
+ (if extension-p
+ (the (integer 1 #.most-positive-fixnum)
+ extension)
+ (1+ old-fill-pointer)))))
(setf (%array-fill-pointer vector)
(1+ old-fill-pointer))
;; Wrapping the type test and the AREF in the same WITH-ARRAY-DATA
;; saves some time.
- (with-array-data ((v vector) (i old-fill-pointer) (end))
+ (with-array-data ((v vector) (i old-fill-pointer) (end)
+ :force-inline t)
(declare (ignore end) (optimize (safety 0)))
(if (simple-vector-p v) ; if common special case
(setf (aref v i) new-element)
;;; FIXME: should DEFUN REPLACE in terms of same expansion as
;;; DEFTRANSFORM
+#+nil
+(defun replace (..)
+ (cond ((and (typep seq1 'simple-vector)
+ (typep seq2 'simple-vector))
+ (%replace-vector-vector ..))
+ ((and (typep seq1 'simple-string)
+ (typep seq2 'simple-string))
+ (%replace-vector-vector ..))
+ (t
+ ..)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; POSITION/FIND stuff
;; NIL is never returned; and give (NEED (FIND ..)) workaround.
(error "need to fix FIXMEs"))
-;;; logic to unravel :TEST and :TEST-NOT options in FIND/POSITION/etc.
-(declaim (inline %effective-test))
-(defun %effective-find-position-test (test test-not)
+;;; logic to unravel :TEST, :TEST-NOT, and :KEY options in FIND,
+;;; POSITION-IF, etc.
+(declaim (inline effective-find-position-test effective-find-position-key))
+(defun 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-function test))
;; anyway, we don't care.)
(complement (%coerce-callable-to-function test-not)))
(t #'eql)))
+(defun effective-find-position-key (key)
+ (if key
+ (%coerce-callable-to-function key)
+ #'identity))
-;;; the user interface to FIND and POSITION: Get all our ducks in a row,
-;;; then call %FIND-POSITION
-;;;
-;;; FIXME: These should probably be (MACROLET (..) (DEF-SOURCE-TRANSFORM ..))
-;;; instead of this DEFCONSTANT silliness.
-(eval-when (:compile-toplevel :execute)
- (defconstant +find-fun-args+
- '(item
- sequence
- &key
- from-end
- (start 0)
- end
- key
- test
- test-not))
- (defconstant +find-fun-frob+
- '(%find-position item
- sequence
- from-end
- start
- end
- (if key (%coerce-callable-to-function key) #'identity)
- (%effective-find-position-test test test-not))))
-(declaim (inline find position))
-(defun find #.+find-fun-args+
- (nth-value 0 #.+find-fun-frob+))
-(defun position #.+find-fun-args+
- (nth-value 1 #.+find-fun-frob+))
-
-;;; the user interface to FIND-IF and POSITION-IF, entirely analogous
-;;; to the interface to FIND and POSITION
-(eval-when (:compile-toplevel :execute)
- (defconstant +find-if-fun-args+
- '(predicate
- sequence
- &key
- from-end
- (start 0)
- end
- (key #'identity)))
- (defconstant +find-if-fun-frob+
- '(%find-position-if (%coerce-callable-to-function predicate)
- sequence
- from-end
- start
- end
- (%coerce-callable-to-function key))))
-;;; FIXME: A running SBCL doesn't like to have its FIND-IF and
-;;; POSITION-IF DEFUNed, dunno why yet..
-#|
-;;(declaim (maybe-inline find-if cl-user::%position-if))
-(defun find-if #.+find-if-fun-args+
- (nth-value 0 #.+find-if-fun-frob+))
-(defun cl-user::%position-if #.+find-if-fun-args+
- (nth-value 1 #.+find-if-fun-frob+))
-(setf (symbol-function 'position-if)
- #'cl-user::%position-if)
-;;(declaim (inline find-if cl-user::%position-if))
-|#
-
-;;; the deprecated functions FIND-IF-NOT and POSITION-IF-NOT
-(defun find-if-not (predicate sequence &key from-end (start 0) end key)
- (nth-value 0 (%find-position-if (complement (%coerce-callable-to-function
- predicate))
- sequence from-end start end key)))
-(defun position-if-not (predicate sequence &key from-end (start 0) end key)
- (nth-value 1 (%find-position-if (complement (%coerce-callable-to-function
- predicate))
- sequence from-end start end key)))
-;;; FIXME: Remove uses of these deprecated functions, and of :TEST-NOT too.
-
+;;; shared guts of out-of-line FIND, POSITION, FIND-IF, and POSITION-IF
(macrolet (;; shared logic for defining %FIND-POSITION and
;; %FIND-POSITION-IF in terms of various inlineable cases
;; of the expression defined in FROB and VECTOR*-FROB
`(%find-position-if-vector-macro predicate ,sequence
from-end start end key)))
(frobs))))
+
+;;; the user interface to FIND and POSITION: Get all our ducks in a row,
+;;; then call %FIND-POSITION
+(declaim (inline find position))
+(macrolet ((def-find-position (fun-name values-index)
+ `(defun ,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))))))
+ (def-find-position find 0)
+ (def-find-position position 1))
+
+;;; the user interface to FIND-IF and POSITION-IF, entirely analogous
+;;; to the interface to FIND and POSITION
+(declaim (inline find-if position-if))
+(macrolet ((def-find-position-if (fun-name values-index)
+ `(defun ,fun-name (predicate sequence
+ &key from-end (start 0) end key)
+ (nth-value
+ ,values-index
+ (%find-position-if (%coerce-callable-to-function predicate)
+ sequence
+ from-end
+ start
+ end
+ (effective-find-position-key key))))))
+
+ (def-find-position-if find-if 0)
+ (def-find-position-if position-if 1))
+
+;;; the deprecated functions FIND-IF-NOT and POSITION-IF-NOT
+(macrolet ((def-find-position-if-not (fun-name values-index)
+ `(defun ,fun-name (predicate sequence
+ &key from-end (start 0) end key)
+ (nth-value
+ ,values-index
+ (%find-position-if (complement (%coerce-callable-to-function
+ predicate))
+ sequence
+ from-end
+ start
+ end
+ (effective-find-position-key key))))))
+ (def-find-position-if-not find-if-not 0)
+ (def-find-position-if-not position-if-not 1))
+;;; FIXME: Remove uses of these deprecated functions, and of :TEST-NOT too.
+
(declaim (optimize (speed 1) (space 2)))
+;;; This checks to see whether the array is simple and the start and
+;;; end are in bounds. If so, it proceeds with those values.
+;;; Otherwise, it calls %WITH-ARRAY-DATA. Note that %WITH-ARRAY-DATA
+;;; may be further optimized.
+;;;
+;;; Given any ARRAY, bind DATA-VAR to the array's data vector and
+;;; START-VAR and END-VAR to the start and end of the designated
+;;; portion of the data vector. SVALUE and EVALUE are any start and
+;;; end specified to the original operation, and are factored into the
+;;; bindings of START-VAR and END-VAR. OFFSET-VAR is the cumulative
+;;; offset of all displacements encountered, and does not include
+;;; SVALUE.
+;;;
+;;; When FORCE-INLINE is set, the underlying %WITH-ARRAY-DATA form is
+;;; forced to be inline, overriding the ordinary judgment of the
+;;; %WITH-ARRAY-DATA DEFTRANSFORMs. Ordinarily the DEFTRANSFORMs are
+;;; fairly picky about their arguments, figuring that if you haven't
+;;; bothered to get all your ducks in a row, you probably don't care
+;;; that much about speed anyway! But in some cases it makes sense to
+;;; do type testing inside %WITH-ARRAY-DATA instead of outside, and
+;;; the DEFTRANSFORM can't tell that that's going on, so it can make
+;;; sense to use FORCE-INLINE option in that case.
+(defmacro with-array-data (((data-var array &key offset-var)
+ (start-var &optional (svalue 0))
+ (end-var &optional (evalue nil))
+ &key force-inline)
+ &body forms)
+ (once-only ((n-array array)
+ (n-svalue `(the index ,svalue))
+ (n-evalue `(the (or index null) ,evalue)))
+ `(multiple-value-bind (,data-var
+ ,start-var
+ ,end-var
+ ,@(when offset-var `(,offset-var)))
+ (if (not (array-header-p ,n-array))
+ (let ((,n-array ,n-array))
+ (declare (type (simple-array * (*)) ,n-array))
+ ,(once-only ((n-len `(length ,n-array))
+ (n-end `(or ,n-evalue ,n-len)))
+ `(if (<= ,n-svalue ,n-end ,n-len)
+ ;; success
+ (values ,n-array ,n-svalue ,n-end 0)
+ ;; failure: Make a NOTINLINE call to
+ ;; %WITH-ARRAY-DATA with our bad data
+ ;; to cause the error to be signalled.
+ (locally
+ (declare (notinline %with-array-data))
+ (%with-array-data ,n-array ,n-svalue ,n-evalue)))))
+ (,(if force-inline '%with-array-data-macro '%with-array-data)
+ ,n-array ,n-svalue ,n-evalue))
+ ,@forms)))
+
;;; This is the fundamental definition of %WITH-ARRAY-DATA, for use in
;;; DEFTRANSFORMs and DEFUNs.
(defmacro %with-array-data-macro (array
(element-type '*)
unsafe?
fail-inline?)
- (format t "~&/in %WITH-ARRAY-DATA-MACRO, ELEMENT-TYPE=~S~%" element-type)
(let ((size (gensym "SIZE-"))
(data (gensym "DATA-"))
(cumulative-offset (gensym "CUMULATIVE-OFFSET-")))
:policy (> speed space))
"inline non-SIMPLE-vector-handling logic"
(let ((element-type (upgraded-element-type-specifier-or-give-up array)))
- (format t "~&/in DEFTRANSFORM %WITH-ARRAY-DATA, ELEMENT-TYPE=~S~%"
- element-type)
`(%with-array-data-macro array start end
:unsafe? ,(policy node (= safety 0))
:element-type ,element-type)))
(setf (function-info-transforms (info :function :info 'coerce)) nil)
(deftransform coerce ((x type) (* *) * :when :both)
- (format t "~&/looking at DEFTRANSFORM COERCE~%")
(unless (constant-continuation-p type)
(give-up-ir1-transform))
(let ((tspec (specifier-type (continuation-value type))))
(end (gensym "END-")))
`(let ((,n-sequence ,sequence-arg)
(,n-end ,end-arg))
- ;;(format t "~&/n-sequence=~S~%" ,n-sequence)
- ;;(format t "~&/simplicity=~S~%" (typep ,n-sequence 'simple-array))
- ;;(describe ,n-sequence)
(with-array-data ((,sequence ,n-sequence :offset-var ,offset)
(,start ,start)
(,end (or ,n-end (length ,n-sequence))))
- ;;(format t "~&sequence=~S~%start=~S~%end=~S~%" ,sequence ,start ,end)
- ;;(format t "~&/n-sequence=~S~%" ,n-sequence)
(block ,block
(macrolet ((maybe-return ()
'(let ((,element (aref ,sequence ,index)))
projects / sbcl.git / commitdiff