:ELEMENT-TYPE, but in sbcl-0.6.9 this is not defined for
WITH-OUTPUT-TO-STRING.
+77:
+ As reported by Martin Atzmueller on sbcl-devel 2000-01-09,
+ DEF-ALIEN-VARIABLE doesn't work. With either the example in the
+ old CMU CL docs,
+ (def-alien-variable "errno" integer)
+ or another test avoiding any peculiarities of modern errno-as-macro
+ implementations,
+ (def-alien-variable "from_space" integer)
+ in sbcl-0.6.9 the operation fails with
+ TYPE-ERROR in SB-KERNEL::OBJECT-NOT-TYPE-ERROR-HANDLER:
+ NIL is not of type SB-KERNEL:LEXENV.
KNOWN BUGS RELATED TO THE IR1 INTERPRETER
--- /dev/null
+;;;; (See the comments at the head of the file compiler-extras.lisp.)
+
+(in-package "SB-IMPL")
+
+(declaim (optimize (speed 3) (space 1)))
+
+(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
+;;; _Introduction to Algorithms_ by Corman, Rivest, and Shamir.
+(macrolet ((%index (x) `(truly-the index ,x))
+ (%parent (i) `(ash ,i -1))
+ (%left (i) `(%index (ash ,i 1)))
+ (%right (i) `(%index (1+ (ash ,i 1))))
+ (%heapify (i)
+ `(do* ((i ,i)
+ (left (%left i) (%left i)))
+ ((> left current-heap-size))
+ (declare (type index i left))
+ (let* ((i-elt (%elt i))
+ (i-key (funcall keyfun i-elt))
+ (left-elt (%elt left))
+ (left-key (funcall keyfun left-elt)))
+ (multiple-value-bind (large large-elt large-key)
+ (if (funcall predicate i-key left-key)
+ (values left left-elt left-key)
+ (values i i-elt i-key))
+ (let ((right (%right i)))
+ (multiple-value-bind (largest largest-elt)
+ (if (> right current-heap-size)
+ (values large large-elt)
+ (let* ((right-elt (%elt right))
+ (right-key (funcall keyfun right-elt)))
+ (if (funcall predicate large-key right-key)
+ (values right right-elt)
+ (values large large-elt))))
+ (cond ((= largest i)
+ (return))
+ (t
+ (setf (%elt i) largest-elt
+ (%elt largest) i-elt
+ i largest)))))))))
+ (%srt-vector (keyfun &optional (vtype 'vector))
+ `(macrolet (;; In SBCL ca. 0.6.10, I had trouble getting
+ ;; type inference to propagate all the way
+ ;; through this tangled mess of inlining. The
+ ;; TRULY-THE here works around that. -- WHN
+ (%elt (i)
+ `(aref (truly-the ,',vtype vector)
+ (%index (+ (%index ,i) start-1)))))
+ (let ((start-1 (1- start)) ; Heaps prefer 1-based addressing.
+ (current-heap-size (- end start))
+ (keyfun ,keyfun))
+ (declare (type (integer -1 #.(1- most-positive-fixnum))
+ start-1))
+ (declare (type index current-heap-size))
+ (declare (type function keyfun))
+ (/noshow "doing SRT-VECTOR" keyfun)
+ (loop for i of-type index
+ from (ash current-heap-size -1) downto 1 do
+ (/noshow vector "about to %HEAPIFY" i)
+ (%heapify i))
+ (loop
+ (/noshow current-heap-size vector)
+ (when (< current-heap-size 2)
+ (/noshow "returning")
+ (return))
+ (/noshow "setting" current-heap-size "element to" (%elt 1))
+ (rotatef (%elt 1) (%elt current-heap-size))
+ (decf current-heap-size)
+ (%heapify 1))
+ (/noshow "falling out of %SRT-VECTOR")))))
+
+ (declaim (inline srt-vector))
+ (defun srt-vector (vector start end predicate key)
+ (declare (type vector vector))
+ (declare (type index start end))
+ (declare (type function predicate))
+ (declare (type (or function null) key))
+ (declare (optimize (speed 3) (safety 3) (debug 1) (space 1)))
+ (if (typep vector 'simple-vector)
+ ;; (VECTOR T) is worth optimizing for, and SIMPLE-VECTOR is
+ ;; what we get from (VECTOR T) inside WITH-ARRAY-DATA.
+ (if (null key)
+ ;; Special-casing the KEY=NIL case lets us avoid some
+ ;; function calls.
+ (%srt-vector #'identity simple-vector)
+ (%srt-vector key simple-vector))
+ ;; It's hard to imagine many important applications for
+ ;; sorting vector types other than (VECTOR T), so we just lump
+ ;; them all together in one slow dynamically typed mess.
+ (locally
+ (declare (optimize (speed 2) (space 2) (inhibit-warnings 3)))
+ (error "stub: suppressed to hide notes")
+ #+nil (%srt-vector (or key #'identity))))))
+
+(declaim (maybe-inline sort))
+(defun sort (sequence predicate &key key)
+ (let ((predicate-function (%coerce-callable-to-function predicate))
+ (key-function (and key (%coerce-callable-to-function key))))
+ (typecase sequence
+ (list (sort-list sequence predicate-function key-function))
+ (vector
+ (with-array-data ((vector (the vector sequence))
+ (start 0)
+ (end (length sequence)))
+ (srt-vector vector start end predicate-function key-function))
+ (/noshow "back from SRT-VECTOR" sequence)
+ sequence)
+ (t
+ (error 'simple-type-error
+ :datum sequence
+ :expected-type 'sequence
+ :format-control "~S is not a sequence."
+ :format-arguments (list sequence))))))
+
+(defun vector-push-extend (new-element
+ vector
+ &optional
+ (extension (1+ (length vector))))
+ (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)))
+ (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))
+ (declare (ignore end) (optimize (safety 0)))
+ (if (simple-vector-p v) ; if common special case
+ (setf (aref v i) new-element)
+ (setf (aref v i) new-element)))
+ old-fill-pointer))
+
+;;; FIXME: should DEFUN REPLACE in terms of same expansion as
+;;; DEFTRANSFORM
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;; POSITION/FIND stuff
+
+#+sb-xc-host
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ ;; FIXME: Report seq.impure.lisp test failures to cmucl-imp@cons.org.
+ ;; FIXME: Add BUGS entry for the way that inline expansions offunctions
+ ;; like FIND cause compiler warnings when the system can't prove that
+ ;; 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)
+ (cond ((and test test-not)
+ (error "can't specify both :TEST and :TEST-NOT"))
+ (test (%coerce-callable-to-function 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-function test-not)))
+ (t #'eql)))
+
+;;; 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.
+
+(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
+ (frobs ()
+ `(etypecase sequence-arg
+ (list (frob sequence-arg from-end))
+ (vector
+ (with-array-data ((sequence sequence-arg :offset-var offset)
+ (start start)
+ (end (or end (length sequence-arg))))
+ (multiple-value-bind (f p)
+ (macrolet ((frob2 () '(if from-end
+ (frob sequence t)
+ (frob sequence nil))))
+ (typecase sequence
+ (simple-vector (frob2))
+ (simple-string (frob2))
+ (t (vector*-frob sequence))))
+ (declare (type (or index null) p))
+ (values f (and p (the index (+ p offset))))))))))
+ (defun %find-position (item sequence-arg from-end start end key test)
+ (macrolet ((frob (sequence from-end)
+ `(%find-position item ,sequence
+ ,from-end start end key test))
+ (vector*-frob (sequence)
+ `(%find-position-vector-macro item ,sequence
+ from-end start end key test)))
+ (frobs)))
+ (defun %find-position-if (predicate sequence-arg from-end start end key)
+ (macrolet ((frob (sequence from-end)
+ `(%find-position-if predicate ,sequence
+ ,from-end start end key))
+ (vector*-frob (sequence)
+ `(%find-position-if-vector-macro predicate ,sequence
+ from-end start end key)))
+ (frobs))))
--- /dev/null
+;;;; The files
+;;;; compiler-extras.lisp
+;;;; code-extras.lisp
+;;;; hold things that I (WHN) am working on which are sufficiently
+;;;; closely tied to the system that they want to be under the same
+;;;; revision control, but which aren't yet ready for prime time.
+;;;;
+;;;; As of around sbcl-0.6.10, these are mostly performance fixes.
+;;;; Fixes for logical bugs tend to go straight into the system, but
+;;;; fixes for performance problems can easily introduce logical bugs,
+;;;; and no one's going to thank me for replacing old slow correct
+;;;; code with new fast wrong code.
+;;;;
+;;;; Unless you want to live *very* dangerously, you don't want to be
+;;;; running these. There might be some small value to looking at
+;;;; these files to see whether I'm working on optimizing something
+;;;; whose performance you care about, so that you can patch it, or
+;;;; write test cases for it, or pester me to release it, or whatever.
+
+(in-package "SB-KERNEL")
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (export '(%with-array-data-macro
+ index-or-minus-1
+ %find-position %find-position-vector-macro
+ %find-position-if %find-position-if-vector-macro)))
+
+(in-package "SB-C")
+
+(deftype index-or-minus-1 () `(integer -1 ,(1- most-positive-fixnum)))
+
+(declaim (optimize (speed 1) (space 2)))
+
+;;; This is the fundamental definition of %WITH-ARRAY-DATA, for use in
+;;; DEFTRANSFORMs and DEFUNs.
+(defmacro %with-array-data-macro (array
+ start
+ end
+ &key
+ (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-")))
+ `(let* ((,size (array-total-size ,array))
+ (,end (cond (,end
+ (unless (or ,unsafe? (<= ,end ,size))
+ ,(if fail-inline?
+ `(error "End ~D is greater than total size ~D."
+ ,end ,size)
+ `(failed-%with-array-data ,array ,start ,end)))
+ ,end)
+ (t ,size))))
+ (unless (or ,unsafe? (<= ,start ,end))
+ ,(if fail-inline?
+ `(error "Start ~D is greater than end ~D." ,start ,end)
+ `(failed-%with-array-data ,array ,start ,end)))
+ (do ((,data ,array (%array-data-vector ,data))
+ (,cumulative-offset 0
+ (+ ,cumulative-offset
+ (%array-displacement ,data))))
+ ((not (array-header-p ,data))
+ (values (the (simple-array ,element-type 1) ,data)
+ (the index (+ ,cumulative-offset ,start))
+ (the index (+ ,cumulative-offset ,end))
+ (the index ,cumulative-offset)))
+ (declare (type index ,cumulative-offset))))))
+
+(defun upgraded-element-type-specifier-or-give-up (continuation)
+ (let* ((element-ctype (extract-upgraded-element-type continuation))
+ (element-type-specifier (type-specifier element-ctype)))
+ (if (eq element-type-specifier '*)
+ (give-up-ir1-transform
+ "upgraded array element type not known at compile time")
+ element-type-specifier)))
+
+(deftransform %with-array-data ((array start end)
+ ;; Note: This transform is limited to
+ ;; VECTOR only because I happened to
+ ;; create it in order to get sequence
+ ;; function operations to be more
+ ;; efficient. It might very well be
+ ;; reasonable to allow general ARRAY
+ ;; here, I just haven't tried to
+ ;; understand the performance issues
+ ;; involved. -- WHN
+ (vector index (or index null))
+ *
+ :important t
+ :node node
+ :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)))
+
+;;; It'd waste space to expand copies of error handling in every
+;;; inline %WITH-ARRAY-DATA, so we have them call this function
+;;; instead. This is just a wrapper which is known never to return.
+(defknown failed-%with-array-data (t t t) nil)
+(defun failed-%with-array-data (array start end)
+ (declare (notinline %with-array-data))
+ (%with-array-data array start end)
+ (error "internal error: shouldn't be here with valid parameters"))
+
+(deftransform fill ((seq item &key (start 0) (end (length seq)))
+ (vector t &key (:start t) (:end index))
+ *
+ :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))
+ (declare (type (simple-array ,element-type 1) data))
+ (do ((i start (1+ i)))
+ ((= i end) seq)
+ (declare (type index i))
+ ;; WITH-ARRAY-DATA does our range checks once and for all, so
+ ;; it'd be wasteful to check again on every AREF.
+ (declare (optimize (safety 0)))
+ (setf (aref data i) item)))))
+;;; TO DO for DEFTRANSFORM FILL:
+;;; ?? This DEFTRANSFORM, and the old DEFTRANSFORMs, should only
+;;; apply when SPEED > SPACE.
+;;; ?? Add test cases.
+
+#+nil ; not tested yet..
+(deftransform replace ((seq1 seq2 &key (start1 0) end1 (start2 0) end2)
+ (vector vector &key
+ (:start1 index) (:end1 (or index null))
+ (:start2 index) (:end2 (or index null)))
+ *
+ ;; This is potentially an awfully big transform
+ ;; (if things like (EQ SEQ1 SEQ2) aren't known
+ ;; at runtime). We need to make it available
+ ;; inline, since otherwise there's no way to do
+ ;; it efficiently on all array types, but it
+ ;; probably doesn't belong inline all the time.
+ :policy (> speed (1+ space)))
+ "open code"
+ (let ((et1 (upgraded-element-type-specifier-or-give-up seq1))
+ (et2 (upgraded-element-type-specifier-or-give-up seq2)))
+ `(let* ((n-copied (min (- end1 start1) (- end2 start2)))
+ (effective-end1 (+ start1 n-copied)))
+ (if (eq seq1 seq2)
+ (with-array-data ((seq seq1)
+ (start (min start1 start2))
+ (end (max end1 end2)))
+ (declare (type (simple-array ,et1 1) seq))
+ (if (<= start1 start2)
+ (let ((index2 start2))
+ (declare (type index index2))
+ (loop for index1 of-type index
+ from start1 below effective-end1 do
+ (setf (aref seq index1)
+ (aref seq index2))
+ (incf index2)))
+ (let ((index2 (1- end2)))
+ (declare (type (integer -2 #.most-positive-fixnum) index2))
+ (loop for index1 of-type index-or-minus-1
+ from (1- effective-end1) downto start1 do
+ (setf (aref seq index1)
+ (aref seq index2))
+ (decf index2)))))
+ (with-array-data ((seq1 seq1) (start1 start1) (end1 end1))
+ (declare (type (simple-array ,et1 1) seq1))
+ (with-array-data ((seq2 seq2) (start2 start2) (end2 end2))
+ (declare (type (simple-array ,et2 1) seq2))
+ (let ((index2 start2))
+ (declare (type index index2))
+ (loop for index1 of-type index
+ from start1 below effective-end1 do
+ (setf (aref seq index1)
+ (aref seq index2))
+ (incf index2))))))
+ seq1)))
+
+(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))))
+ (if (csubtypep (continuation-type x) tspec)
+ 'x
+ ;; Note: The THE here makes sure that specifiers like
+ ;; (SINGLE-FLOAT 0.0 1.0) can raise a TYPE-ERROR.
+ `(the ,(continuation-value type)
+ ,(cond
+ ((csubtypep tspec (specifier-type 'double-float))
+ '(%double-float x))
+ ;; FIXME: #!+long-float (t ,(error "LONG-FLOAT case needed"))
+ ((csubtypep tspec (specifier-type 'float))
+ '(%single-float x))
+ ((csubtypep tspec (specifier-type 'simple-vector))
+ '(coerce-to-simple-vector x)) ; FIXME: needs DEFKNOWN return type
+ (t
+ (give-up-ir1-transform)))))))
+(defun coerce-to-simple-vector (x)
+ (if (simple-vector-p x)
+ x
+ (replace (make-array (length x)) x)))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;; setting up for POSITION/FIND stuff
+
+(defknown %find-position
+ (t sequence t index sequence-end function function)
+ (values t (or index null))
+ (flushable call))
+(defknown %find-position-if
+ (function sequence t index sequence-end function)
+ (values t (or index null))
+ (call))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;; POSITION, POSITION-IF, FIND, and FIND-IF proper
+
+;;; FIXME: Blow away old CMU CL implementation:
+;;; * the section of seq.lisp with VECTOR-LOCATER-MACRO and LOCATER-TEST-NOT
+;;; * matches to 'find' and 'position' in seq.lisp
+
+;;; We want to make sure that %FIND-POSITION is inline-expanded into
+;;; %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)))
+ (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)
+ (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")))))
+
+;;; %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 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.)
+(deftransform %find-position ((item sequence from-end start end key test)
+ (t list t t t t t)
+ *
+ :policy (> speed space)
+ :important t)
+ "expand inline"
+ '(%find-position-if (let ((test-fun (%coerce-callable-to-function test)))
+ (lambda (i)
+ (funcall test-fun i item)))
+ sequence
+ from-end
+ start
+ end
+ (%coerce-callable-to-function key)))
+
+;;; The inline expansions for the VECTOR case are saved as macros so
+;;; that we can share them between the DEFTRANSFORMs and the default
+;;; cases in the DEFUNs. (This isn't needed for the LIST case, because
+;;; the DEFTRANSFORMs for LIST are less choosy about when to expand.)
+(defun %find-position-or-find-position-if-vector-expansion (sequence-arg
+ from-end
+ start
+ 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-")))
+ `(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)))
+ (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))))))
+(defmacro %find-position-vector-macro (item sequence
+ from-end start end key test)
+ (let ((element (gensym "ELEMENT")))
+ (%find-position-or-find-position-if-vector-expansion
+ sequence
+ from-end
+ start
+ end
+ element
+ `(funcall ,test ,item (funcall ,key ,element)))))
+(defmacro %find-position-if-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
+ `(funcall ,predicate (funcall ,key ,element)))))
+
+;;; %FIND-POSITION and %FIND-POSITION-IF for VECTOR data
+(deftransform %find-position-if ((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-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)
+ *
+ :policy (> speed space)
+ :important t)
+ "expand inline"
+ (check-inlineability-of-find-position-if sequence from-end)
+ '(%find-position-vector-macro item sequence
+ from-end start end key test))
;;; ONCE-ONLY is a utility useful in writing source transforms and
;;; macros. It provides a concise way to wrap a LET around some code
;;; to ensure that some forms are only evaluated once.
+;;;
+;;; Create a LET* which evaluates each value expression, binding a
+;;; temporary variable to the result, and wrapping the LET* around the
+;;; result of the evaluation of BODY. Within the body, each VAR is
+;;; bound to the corresponding temporary variable.
(defmacro once-only (specs &body body)
- #!+sb-doc
- "Once-Only ({(Var Value-Expression)}*) Form*
- Create a Let* which evaluates each Value-Expression, binding a temporary
- variable to the result, and wrapping the Let* around the result of the
- evaluation of Body. Within the body, each Var is bound to the corresponding
- temporary variable."
(iterate frob
((specs specs)
(body body))
(let* ((name (first spec))
(exp-temp (gensym (symbol-name name))))
`(let ((,exp-temp ,(second spec))
- (,name (gensym "OO-")))
+ (,name (gensym "ONCE-ONLY-")))
`(let ((,,name ,,exp-temp))
,,(frob (rest specs) body))))))))
\f
;;; we no longer need to make a distinction between this and
;;; %PARSE-ALIEN-TYPE.
(defun parse-alien-type (type env)
- (declare (type sb!kernel:lexenv env))
+ (declare (type (or sb!kernel:lexenv null) env))
#!+sb-doc
"Parse the list structure TYPE as an alien type specifier and return
the resultant ALIEN-TYPE structure."
(%parse-alien-type type env))
(defun %parse-alien-type (type env)
- (declare (type sb!kernel:lexenv env))
+ (declare (type (or sb!kernel:lexenv null) env))
(if (consp type)
(let ((translator (info :alien-type :translator (car type))))
(unless translator
(error "unknown alien type: ~S" type)))))
(defun auxiliary-alien-type (kind name env)
- (declare (type sb!kernel:lexenv env))
+ (declare (type (or sb!kernel:lexenv null) env))
(flet ((aux-defn-matches (x)
(and (eq (first x) kind) (eq (second x) name))))
(let ((in-auxiliaries
(info :alien-type :enum name)))))))
(defun (setf auxiliary-alien-type) (new-value kind name env)
- (declare (type sb!kernel:lexenv env))
+ (declare (type (or sb!kernel:lexenv null) env))
(flet ((aux-defn-matches (x)
(and (eq (first x) kind) (eq (second x) name))))
(when (find-if #'aux-defn-matches *new-auxiliary-types*)
(parse-alien-record-type :union name fields env))
(defun parse-alien-record-type (kind name fields env)
- (declare (type sb!kernel:lexenv env))
+ (declare (type (or sb!kernel:lexenv null) env))
(cond (fields
(let* ((old (and name (auxiliary-alien-type kind name env)))
(old-fields (and old (alien-record-type-fields old))))
(error 'simple-error
:function-name name
:format-control
- "invalid array index, ~D for ~S (should have been less than ~D)"
+ "invalid array index ~D for ~S (should be nonnegative and <~D)"
:format-arguments (list index array bound)))
(deferr object-not-simple-array-error (object)
"Returns the root of the nearest integer less than n which is a perfect
square."
(declare (type unsigned-byte n) (values unsigned-byte))
- ;; theoretically (> n 7), i.e., n-len-quarter > 0
+ ;; Theoretically (> n 7), i.e., n-len-quarter > 0.
(if (and (fixnump n) (<= n 24))
(cond ((> n 15) 4)
((> n 8) 3)
,num-descriptors ,read-fds ,write-fds ,exception-fds
(if timeout-secs (alien-sap (addr tv)) (int-sap 0))))))
-;;; Unix-select accepts sets of file descriptors and waits for an event
+;;; UNIX-SELECT accepts sets of file descriptors and waits for an event
;;; to happen on one of them or to time out.
-
(defmacro num-to-fd-set (fdset num)
`(if (fixnump ,num)
(progn
(defoptimizer (%unwind-protect ltn-annotate) ((escape cleanup)
node
ltn-policy)
- (declare (ignore ltn-policy))
+ ltn-policy ; a hack to effectively (DECLARE (IGNORE LTN-POLICY))
(setf (basic-combination-info node) :funny)
(setf (node-tail-p node) nil))
recursive)))))
(let ((*compiler-error-context* call))
(compiler-warning "recursion in known function definition~2I ~
- ~_arg types=~S"
+ ~_policy=~S ~_arg types=~S"
+ (lexenv-policy (node-lexenv call))
(mapcar (lambda (arg)
(type-specifier (continuation-type
arg)))
(vector
(destructuring-bind (eltype) type-rest
(if (entirely eltype)
- (replace (make-array (length base-seq)
- :element-type eltype
- :adjustable t)
- base-seq)
+ (let ((initial-element
+ (cond ((subtypep eltype 'character)
+ #\!)
+ ((subtypep eltype 'number)
+ 0)
+ (t #'error))))
+ (replace (make-array
+ (+ (length base-seq)
+ (random 3))
+ :element-type eltype
+ :fill-pointer
+ (length base-seq)
+ :initial-element
+ initial-element)
+ base-seq))
(return))))))))
(lambda-expr `(lambda (seq)
,@(when declaredness
`((declare (type ,seq-type seq))))
(declare (optimize ,@optimization))
,snippet)))
+ (format t "~&~S~%" lambda-expr)
(multiple-value-bind (fun warnings-p failure-p)
(compile nil lambda-expr)
(when (or warnings-p failure-p)
- (error "~@<failed compilation:~2I ~_WARNINGS-P=~S ~_FAILURE-P=~S ~_LAMBDA-EXPR=~S~:@>" lambda-expr))
+ (error "~@<failed compilation:~2I ~_LAMBDA-EXPR=~S ~_WARNINGS-P=~S ~_FAILURE-P=~S~:@>"
+ lambda-expr warnings-p failure-p))
+ (format t "~&~S ~S ~S ~S ~S~%"
+ base-seq snippet seq-type declaredness optimization)
+ (format t "~&(TYPEP SEQ 'SIMPLE-ARRAY)=~S~%"
+ (typep seq 'simple-array))
(unless (funcall fun seq)
(error "~@<failed test:~2I ~_BASE-SEQ=~S ~_SNIPPET=~S ~_SEQ-TYPE=~S ~_DECLAREDNESS=~S ~_OPTIMIZATION=~S~:@>"
base-seq
(defun for-every-seq (base-seq snippets)
(dolist (snippet snippets)
(for-every-seq-1 base-seq snippet)))
-
+
+;;; a wrapper to hide declared type information from the compiler, so
+;;; we don't get stopped by compiler warnings about e.g. compiling
+;;; (POSITION 1 #() :KEY #'ABS) when #() has been coerced to a string.
+(defun indiscriminate (fun)
+ (lambda (&rest rest) (apply fun rest)))
+
;;; tests of FIND, POSITION, FIND-IF, and POSITION-IF (and a few for
;;; deprecated FIND-IF-NOT and POSITION-IF-NOT too)
(for-every-seq #()
'((null (find 1 seq))
(null (find 1 seq :from-end t))
- (null (position 1 seq :key #'abs))
+ (null (position 1 seq :key (indiscriminate #'abs)))
(null (position nil seq :test (constantly t)))
(null (position nil seq :test nil))
(null (position nil seq :test-not nil))
- (null (find-if #'1+ seq :key #'log))
+ (null (find-if #'1+ seq :key (indiscriminate #'log)))
(null (position-if #'identity seq :from-end t))
(null (find-if-not #'packagep seq))
(null (position-if-not #'packagep seq :key nil))))
'((null (find 2 seq))
(find 2 seq :key #'1+)
(find 1 seq :from-end t)
+ (null (find 1 seq :from-end t :start 1))
(null (find 0 seq :from-end t))
(eql 0 (position 1 seq :key #'abs))
(null (position nil seq :test 'equal))
(eql 2 (position 4 seq :key '1+))
(eql 2 (position 4 seq :key '1+ :from-end t))
(eql 1 (position 2 seq))
+ (eql 1 (position 2 seq :start 1))
+ (null (find 2 seq :start 1 :end 1))
+ (eql 3 (position 2 seq :start 2))
(eql 3 (position 2 seq :key nil :from-end t))
(eql 2 (position 3 seq :test '=))
(eql 0 (position 3 seq :test-not 'equalp))
(eql 3 (position-if #'plusp seq :key #'1- :from-end t))
(eql 1 (position-if #'evenp seq))
(eql 3 (position-if #'evenp seq :from-end t))
+ (eql 2 (position-if #'plusp seq :from-end nil :key '1- :start 2))
+ (eql 3 (position-if #'plusp seq :from-end t :key '1- :start 2))
+ (null (position-if #'plusp seq :from-end t :key '1- :start 2 :end 2))
(null (find-if-not #'plusp seq))
(eql 0 (position-if-not #'evenp seq))))
(for-every-seq "string test"
(find-if #'characterp seq)
(find-if #'(lambda (c) (typep c 'base-char)) seq :from-end t)
(null (find-if 'upper-case-p seq))))
-
+
;;; success
(quit :unix-status 104)
;;; versions, and a string like "0.6.5.12" is used for versions which
;;; aren't released but correspond only to CVS tags or snapshots.
-"0.6.9.21"
+"0.6.9.22"
projects / sbcl.git / commitdiff