Forked from
cmucl / cmucl
3237 commits behind the upstream repository.
array.lisp 41.57 KiB
;;; -*- Log: code.log; Package: Lisp -*-
;;;
;;; **********************************************************************
;;; This code was written as part of the CMU Common Lisp project at
;;; Carnegie Mellon University, and has been placed in the public domain.
;;;
(ext:file-comment
"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/array.lisp,v 1.45 2009/09/09 15:51:27 rtoy Rel $")
;;;
;;; **********************************************************************
;;;
;;; Functions to implement arrays for CMU Common Lisp.
;;; Written by Skef Wholey.
;;; Worked over for the MIPS port by William Lott.
;;;
(in-package "LISP")
(export '(array-rank-limit array-dimension-limit array-total-size-limit
make-array vector aref array-element-type array-rank
array-dimension array-dimensions array-in-bounds-p
array-row-major-index array-total-size svref bit sbit
bit-and bit-ior bit-xor bit-eqv bit-nand bit-nor bit-andc1 bit-andc2
bit-orc1 bit-orc2 bit-not array-has-fill-pointer-p
fill-pointer vector-push vector-push-extend vector-pop adjust-array
adjustable-array-p row-major-aref array-displacement))
(in-package "KERNEL")
(export '(%with-array-data))
(in-package "LISP")
(declaim (inline fill-pointer array-has-fill-pointer-p adjustable-array-p
array-displacement))
(defconstant array-rank-limit 65529
"The exclusive upper bound on the rank of an array.")
(defconstant array-dimension-limit most-positive-fixnum
"The exclusive upper bound any given dimension of an array.")
(defconstant array-total-size-limit most-positive-fixnum
"The exclusive upper bound on the total number of elements in an array.")
;;;; Random accessor functions.
;;; These functions are needed by the interpreter, 'cause the compiler inlines
;;; them.
(macrolet ((frob (name)
`(progn
(defun ,name (array)
(,name array))
(defun (setf ,name) (value array)
(setf (,name array) value)))))
(frob %array-fill-pointer)
(frob %array-fill-pointer-p)
(frob %array-available-elements)
(frob %array-data-vector)
(frob %array-displacement)
(frob %array-displaced-p))
(defun %array-rank (array)
(%array-rank array))
(defun %array-dimension (array axis)
(%array-dimension array axis))
(defun %set-array-dimension (array axis value)
(%set-array-dimension array axis value))
(defun %check-bound (array bound index)
(declare (type index bound)
(fixnum index))
(%check-bound array bound index))
;;; %WITH-ARRAY-DATA -- Interface
;;;
;;; The guts of the WITH-ARRAY-DATA macro (in sysmacs). Note that this
;;; function is only called if we have an array header or an error, so it
;;; doesn't have to be too tense.
;;;
(defun %with-array-data (array start end)
(declare (array array) (type index start) (type (or index null) end)
(values (simple-array * (*)) index index index))
(let* ((size (array-total-size array))
(end (cond (end
(unless (<= end size)
(error "End ~D is greater than total size ~D."
end size))
end)
(t size))))
(when (> start end)
(error "Start ~D is greater than end ~D." start end))
(do ((data array (%array-data-vector data))
(cumulative-offset 0
(+ cumulative-offset
(%array-displacement data))))
((not (array-header-p data))
(values data
(+ cumulative-offset start)
(+ cumulative-offset end)
cumulative-offset))
(declare (type index cumulative-offset)))))
;;;; MAKE-ARRAY
(eval-when (:compile-toplevel :execute)
(defmacro pick-type (type &rest specs)
`(cond ,@(mapcar #'(lambda (spec)
`(,(if (eq (car spec) t)
t
`(subtypep ,type ',(car spec)))
,@(cdr spec)))
specs)))
); eval-when
(defun %vector-type-code (type)
(pick-type type
(base-char (values #.vm:simple-string-type #.vm:char-bits))
(bit (values #.vm:simple-bit-vector-type 1))
((unsigned-byte 2) (values #.vm:simple-array-unsigned-byte-2-type 2))
((unsigned-byte 4) (values #.vm:simple-array-unsigned-byte-4-type 4))
((unsigned-byte 8) (values #.vm:simple-array-unsigned-byte-8-type 8))
((unsigned-byte 16) (values #.vm:simple-array-unsigned-byte-16-type 16))
((unsigned-byte 32) (values #.vm:simple-array-unsigned-byte-32-type 32))
((signed-byte 8) (values #.vm:simple-array-signed-byte-8-type 8))
((signed-byte 16) (values #.vm:simple-array-signed-byte-16-type 16))
((signed-byte 30) (values #.vm:simple-array-signed-byte-30-type 32))
((signed-byte 32) (values #.vm:simple-array-signed-byte-32-type 32))
(single-float (values #.vm:simple-array-single-float-type 32))
(double-float (values #.vm:simple-array-double-float-type 64))
#+long-float
(long-float
(values #.vm:simple-array-long-float-type #+x86 96 #+sparc 128))
#+double-double
(double-double-float
(values #.vm::simple-array-double-double-float-type 128))
((complex single-float)
(values #.vm:simple-array-complex-single-float-type 64))
((complex double-float)
(values #.vm:simple-array-complex-double-float-type 128))
#+long-float
((complex long-float)
(values #.vm:simple-array-complex-long-float-type #+x86 192 #+sparc 256))
#+double-double
((complex double-double-float)
(values #.vm::simple-array-complex-double-double-float-type 256))
(t (values #.vm:simple-vector-type #.vm:word-bits))))
(defun %complex-vector-type-code (type)
(pick-type type
(base-char #.vm:complex-string-type)
(bit #.vm:complex-bit-vector-type)
(t #.vm:complex-vector-type)))
(defun make-array (dimensions &key
(element-type t)
(initial-element nil initial-element-p)
(initial-contents nil initial-contents-p)
adjustable fill-pointer
displaced-to displaced-index-offset)
"Creates an array of the specified Dimensions. See manual for details."
(let* ((dimensions (if (listp dimensions) dimensions (list dimensions)))
(array-rank (length (the list dimensions)))
(simple (and (null fill-pointer)
(not adjustable)
(null displaced-to))))
(declare (fixnum array-rank))
(when (and displaced-index-offset (null displaced-to))
(error "Can't specify :displaced-index-offset without :displaced-to"))
(if (and simple (= array-rank 1))
;; Its a (simple-array * (*))
(multiple-value-bind (type bits)
(%vector-type-code element-type)
(declare (type (unsigned-byte 8) type)
(type (integer 1 256) bits))
(let* ((length (car dimensions))
(array (allocate-vector
type
length
(ceiling (* (if (= type vm:simple-string-type)
(1+ length)
length)
bits)
vm:word-bits))))
(declare (type index length))
(when initial-element-p
(fill array initial-element))
(when initial-contents-p
(when initial-element-p
(error "Cannot specify both :initial-element and ~
:initial-contents"))
(unless (= length (length initial-contents))
(error "~D elements in the initial-contents, but the ~
vector length is ~D."
(length initial-contents)
length))
(replace array initial-contents))
array))
;; It's either a complex array or a multidimensional array.
(let* ((total-size (reduce #'* dimensions))
(data (or displaced-to
(data-vector-from-inits
dimensions total-size element-type
initial-contents initial-contents-p
initial-element initial-element-p)))
(array (make-array-header
(cond ((= array-rank 1)
(%complex-vector-type-code element-type))
(simple vm:simple-array-type)
(t vm:complex-array-type))
array-rank)))
(cond (fill-pointer
(unless (= array-rank 1)
(error "Only vectors can have fill pointers."))
(let ((length (car dimensions)))
(declare (fixnum length))
(setf (%array-fill-pointer array)
(cond ((eq fill-pointer t)
length)
(t
(unless (and (fixnump fill-pointer)
(>= fill-pointer 0)
(<= fill-pointer length))
(error "Invalid fill-pointer ~D"
fill-pointer))
fill-pointer))))
(setf (%array-fill-pointer-p array) t))
(t
(setf (%array-fill-pointer array) total-size)
(setf (%array-fill-pointer-p array) nil)))
(setf (%array-available-elements array) total-size)
(setf (%array-data-vector array) data)
(cond (displaced-to
(when (or initial-element-p initial-contents-p)
(error "Neither :initial-element nor :initial-contents ~
can be specified along with :displaced-to"))
;; The CLHS entry for MAKE-ARRAY says that if the
;; actual array element types are not type equivalent
;; (subtypes of each other), the consequences are
;; undefined. Let's signal an error here.
(unless (and (subtypep (upgraded-array-element-type element-type)
(array-element-type displaced-to))
(subtypep (array-element-type displaced-to)
(upgraded-array-element-type element-type)))
(error "One can't displace an array of type ~S into ~
another of type ~S."
element-type (array-element-type displaced-to)))
(let ((offset (or displaced-index-offset 0)))
(when (> (+ offset total-size)
(array-total-size displaced-to))
(error "~S doesn't have enough elements." displaced-to))
(setf (%array-displacement array) offset)
(setf (%array-displaced-p array) t)))
(t
(setf (%array-displaced-p array) nil)))
(let ((axis 0))
(dolist (dim dimensions)
(setf (%array-dimension array axis) dim)
(incf axis)))
array))))
;;; DATA-VECTOR-FROM-INITS returns a simple vector that has the specified array
;;; characteristics. Dimensions is only used to pass to FILL-DATA-VECTOR
;;; for error checking on the structure of initial-contents.
;;;
(defun data-vector-from-inits (dimensions total-size element-type
initial-contents initial-contents-p
initial-element initial-element-p)
(when (and initial-contents-p initial-element-p)
(error "Cannot supply both :initial-contents and :initial-element to
either make-array or adjust-array."))
(let ((data (if initial-element-p
(make-array total-size
:element-type element-type
:initial-element initial-element)
(make-array total-size
:element-type element-type))))
(cond (initial-element-p
(unless (simple-vector-p data)
(unless (typep initial-element element-type)
(error "~S cannot be used to initialize an array of type ~S."
initial-element element-type))
(fill (the vector data) initial-element)))
(initial-contents-p
(fill-data-vector data dimensions initial-contents)))
data))
(defun fill-data-vector (vector dimensions initial-contents)
(let ((index 0))
(labels ((frob (axis dims contents)
(cond ((null dims)
(setf (aref vector index) contents)
(incf index))
(t
(unless (typep contents 'sequence)
(error "Malformed :initial-contents. ~S is not a ~
sequence, but ~D more layer~:P needed."
contents
(- (length dimensions) axis)))
(unless (= (length contents) (car dims))
(error "Malformed :initial-contents. Dimension of ~
axis ~D is ~D, but ~S is ~D long."
axis (car dims) contents (length contents)))
(if (listp contents)
(dolist (content contents)
(frob (1+ axis) (cdr dims) content))
(dotimes (i (length contents))
(frob (1+ axis) (cdr dims) (aref contents i))))))))
(frob 0 dimensions initial-contents))))
(defun vector (&rest objects)
"Constructs a simple-vector from the given objects."
(coerce (the list objects) 'simple-vector))
;;;; Accessor/Setter functions.
(defun data-vector-ref (array index)
(with-array-data ((vector array) (index index) (end))
(declare (ignore end) (optimize (safety 3)))
(macrolet ((dispatch (&rest stuff)
`(etypecase vector
,@(mapcar #'(lambda (type)
(let ((atype `(simple-array ,type (*))))
`(,atype
(data-vector-ref (the ,atype vector)
index))))
stuff))))
(dispatch
t
bit
character
(unsigned-byte 2)
(unsigned-byte 4)
(unsigned-byte 8)
(unsigned-byte 16)
(unsigned-byte 32)
(signed-byte 8)
(signed-byte 16)
(signed-byte 30)
(signed-byte 32)
single-float
double-float
#+long-float long-float
#+double-double double-double-float
(complex single-float)
(complex double-float)
#+long-float (complex long-float)
#+double-double (complex double-double-float)))))
(defun data-vector-set (array index new-value)
(with-array-data ((vector array) (index index) (end))
(declare (ignore end) (optimize (safety 3)))
(macrolet ((dispatch (&rest stuff)
`(etypecase vector
,@(mapcar #'(lambda (type)
(let ((atype `(simple-array ,type (*))))
`(,atype
(data-vector-set (the ,atype vector)
index
(the ,type new-value))
new-value)))
stuff))))
(dispatch
t
bit
character
(unsigned-byte 2)
(unsigned-byte 4)
(unsigned-byte 8)
(unsigned-byte 16)
(unsigned-byte 32)
(signed-byte 8)
(signed-byte 16)
(signed-byte 30)
(signed-byte 32)
single-float
double-float
#+long-float long-float
#+double-double double-double-float
(complex single-float)
(complex double-float)
#+long-float (complex long-float)
#+double-double (complex double-double-float)))))
(defun %array-row-major-index (array subscripts
&optional (invalid-index-error-p t))
(declare (array array)
(list subscripts))
(let ((rank (array-rank array)))
(unless (= rank (length subscripts))
(simple-program-error "Wrong number of subscripts, ~D, for array of rank ~D"
(length subscripts) rank))
(if (array-header-p array)
(do ((subs (nreverse subscripts) (cdr subs))
(axis (1- (array-rank array)) (1- axis))
(chunk-size 1)
(result 0))
((null subs) result)
(declare (list subs) (fixnum axis chunk-size result))
(let ((index (car subs))
(dim (%array-dimension array axis)))
(declare (fixnum index dim))
(unless (< -1 index dim)
(if invalid-index-error-p
(error "Invalid index ~D~[~;~:; on axis ~:*~D~] in ~S"
index axis array)
(return-from %array-row-major-index nil)))
(incf result (* chunk-size index))
(setf chunk-size (* chunk-size dim))))
(let ((index (first subscripts)))
(unless (< -1 index (length (the (simple-array * (*)) array)))
(if invalid-index-error-p
(error "Invalid index ~D in ~S" index array)
(return-from %array-row-major-index nil)))
index))))
(defun array-in-bounds-p (array &rest subscripts)
"Returns T if the Subscipts are in bounds for the Array, Nil otherwise."
(if (%array-row-major-index array subscripts nil)
t))
(defun array-row-major-index (array &rest subscripts)
(%array-row-major-index array subscripts))
(defun aref (array &rest subscripts)
"Returns the element of the Array specified by the Subscripts."
(row-major-aref array (%array-row-major-index array subscripts)))
(defun %aset (array &rest stuff)
(let ((subscripts (butlast stuff))
(new-value (car (last stuff))))
(setf (row-major-aref array (%array-row-major-index array subscripts))
new-value)))
(declaim (inline (setf aref)))
(defun (setf aref) (new-value array &rest subscripts)
(declare (type array array))
(setf (row-major-aref array (%array-row-major-index array subscripts))
new-value))
(defun row-major-aref (array index)
"Returns the element of array corressponding to the row-major index. This is
SETF'able."
(declare (optimize (safety 1)))
(row-major-aref array index))
(defun %set-row-major-aref (array index new-value)
(declare (optimize (safety 1)))
(setf (row-major-aref array index) new-value))
(defun svref (simple-vector index)
"Returns the Index'th element of the given Simple-Vector."
(declare (optimize (safety 1)))
(aref simple-vector index))
(defun %svset (simple-vector index new)
(declare (optimize (safety 1)))
(setf (aref simple-vector index) new))
(defun bit (bit-array &rest subscripts)
"Returns the bit from the Bit-Array at the specified Subscripts."
(declare (type (array bit) bit-array) (optimize (safety 1)))
(row-major-aref bit-array (%array-row-major-index bit-array subscripts)))
(defun %bitset (bit-array &rest stuff)
(declare (type (array bit) bit-array) (optimize (safety 1)))
(let ((subscripts (butlast stuff))
(new-value (car (last stuff))))
(setf (row-major-aref bit-array
(%array-row-major-index bit-array subscripts))
new-value)))
(declaim (inline (setf bit)))
(defun (setf bit) (new-value bit-array &rest subscripts)
(declare (type (array bit) bit-array) (optimize (safety 1)))
(setf (row-major-aref bit-array
(%array-row-major-index bit-array subscripts))
new-value))
(defun sbit (simple-bit-array &rest subscripts)
"Returns the bit from the Simple-Bit-Array at the specified Subscripts."
(declare (type (simple-array bit) simple-bit-array) (optimize (safety 1)))
(row-major-aref simple-bit-array
(%array-row-major-index simple-bit-array subscripts)))
(defun %sbitset (simple-bit-array &rest stuff)
(declare (type (simple-array bit) simple-bit-array) (optimize (safety 1)))
(let ((subscripts (butlast stuff))
(new-value (car (last stuff))))
(setf (row-major-aref simple-bit-array
(%array-row-major-index simple-bit-array subscripts))
new-value)))
(declaim (inline (setf sbit)))
(defun (setf sbit) (new-value bit-array &rest subscripts)
(declare (type (simple-array bit) bit-array) (optimize (safety 1)))
(setf (row-major-aref bit-array
(%array-row-major-index bit-array subscripts))
new-value))
;;;; Random array properties.
(defun array-element-type (array)
"Returns the type of the elements of the array"
(let ((type (get-type array)))
(macrolet ((pick-element-type (&rest stuff)
`(cond ,@(mapcar #'(lambda (stuff)
(cons
(let ((item (car stuff)))
(cond ((eq item t)
t)
((listp item)
(cons 'or
(mapcar #'(lambda (x)
`(= type ,x))
item)))
(t
`(= type ,item))))
(cdr stuff)))
stuff))))
(pick-element-type
((vm:simple-string-type vm:complex-string-type) 'base-char)
((vm:simple-bit-vector-type vm:complex-bit-vector-type) 'bit)
(vm:simple-vector-type t)
(vm:simple-array-unsigned-byte-2-type '(unsigned-byte 2))
(vm:simple-array-unsigned-byte-4-type '(unsigned-byte 4))
(vm:simple-array-unsigned-byte-8-type '(unsigned-byte 8))
(vm:simple-array-unsigned-byte-16-type '(unsigned-byte 16))
(vm:simple-array-unsigned-byte-32-type '(unsigned-byte 32))
(vm:simple-array-signed-byte-8-type '(signed-byte 8))
(vm:simple-array-signed-byte-16-type '(signed-byte 16))
(vm:simple-array-signed-byte-30-type '(signed-byte 30))
(vm:simple-array-signed-byte-32-type '(signed-byte 32))
(vm:simple-array-single-float-type 'single-float)
(vm:simple-array-double-float-type 'double-float)
#+long-float
(vm:simple-array-long-float-type 'long-float)
#+double-double
(vm::simple-array-double-double-float-type 'double-double-float)
(vm:simple-array-complex-single-float-type '(complex single-float))
(vm:simple-array-complex-double-float-type '(complex double-float))
#+long-float
(vm:simple-array-complex-long-float-type '(complex long-float))
#+double-double
(vm::simple-array-complex-double-double-float-type '(complex double-double-float))
((vm:simple-array-type vm:complex-vector-type vm:complex-array-type)
(with-array-data ((array array) (start) (end))
(declare (ignore start end))
(array-element-type array)))
(t
(error 'type-error :datum array :expected-type 'array))))))
(defun array-rank (array)
"Returns the number of dimensions of the Array."
(if (array-header-p array)
(%array-rank array)
1))
(defun array-dimension (array axis-number)
"Returns length of dimension Axis-Number of the Array."
(declare (array array) (type index axis-number))
(cond ((not (array-header-p array))
(unless (= axis-number 0)
(simple-program-error "Vector axis is not zero: ~S" axis-number))
(length (the (simple-array * (*)) array)))
((>= axis-number (%array-rank array))
(simple-program-error "~D is too big; ~S only has ~D dimension~:P"
axis-number array (%array-rank array)))
(t
(%array-dimension array axis-number))))
(defun array-dimensions (array)
"Returns a list whose elements are the dimensions of the array"
(declare (array array))
(if (array-header-p array)
(do ((results nil (cons (array-dimension array index) results))
(index (1- (array-rank array)) (1- index)))
((minusp index) results))
(list (array-dimension array 0))))
(defun array-total-size (array)
"Returns the total number of elements in the Array."
(declare (array array))
(if (array-header-p array)
(%array-available-elements array)
(length (the vector array))))
(defun array-displacement (array)
"Returns values of :displaced-to and :displaced-index-offset options to
make-array, or the defaults nil and 0 if not a displaced array."
(declare (array array))
(if (and (array-header-p array) (%array-displaced-p array))
(values (%array-data-vector array)
(truly-the fixnum (%array-displacement array)))
(values nil 0)))
(defun adjustable-array-p (array)
"Returns T if (adjust-array array...) would return an array identical
to the argument, this happens for complex arrays."
(declare (array array))
(not (typep array 'simple-array)))
;;;; Fill pointer frobbing stuff.
(defun array-has-fill-pointer-p (array)
"Returns T if the given Array has a fill pointer, or Nil otherwise."
(declare (array array))
(and (array-header-p array) (%array-fill-pointer-p array)))
(defun fill-pointer (vector)
"Returns the Fill-Pointer of the given Vector."
(declare (vector vector))
(if (and (array-header-p vector) (%array-fill-pointer-p vector))
(%array-fill-pointer vector)
(error 'simple-type-error
:datum vector
:expected-type '(and vector (satisfies array-has-fill-pointer-p))
:format-control
"~S is not an array with a fill-pointer."
:format-arguments (list vector))))
(defun %set-fill-pointer (vector new)
(declare (vector vector) (fixnum new))
(if (and (array-header-p vector) (%array-fill-pointer-p vector))
(if (> new (%array-available-elements vector))
(simple-program-error
"New fill pointer, ~S, is larger than the length of the vector."
new)
(setf (%array-fill-pointer vector) new))
(error 'simple-type-error
:datum vector
:expected-type '(and vector (satisfies array-has-fill-pointer-p))
:format-control "~S is not an array with a fill-pointer."
:format-arguments (list vector))))
(defun vector-push (new-el array)
"Attempts to set the element of Array designated by the fill pointer
to New-El and increment fill pointer by one. If the fill pointer is
too large, Nil is returned, otherwise the index of the pushed element is
returned."
(declare (vector array))
(let ((fill-pointer (fill-pointer array)))
(declare (fixnum fill-pointer))
(cond ((= fill-pointer (%array-available-elements array))
nil)
(t
(setf (aref array fill-pointer) new-el)
(setf (%array-fill-pointer array) (1+ fill-pointer))
fill-pointer))))
(defun vector-push-extend (new-el array &optional
(extension (if (zerop (length array))
1
(length array))))
"Like Vector-Push except that if the fill pointer gets too large, the
Array is extended rather than Nil being returned."
(declare (vector array) (fixnum extension))
(let ((fill-pointer (fill-pointer array)))
(declare (fixnum fill-pointer))
(when (= fill-pointer (%array-available-elements array))
(setf array (adjust-array array (+ fill-pointer extension))))
(setf (aref array fill-pointer) new-el)
(setf (%array-fill-pointer array) (1+ fill-pointer))
fill-pointer))
(defun vector-pop (array)
"Attempts to decrease the fill-pointer by 1 and return the element
pointer to by the new fill pointer. If the original value of the fill
pointer is 0, an error occurs."
(declare (vector array))
(let ((fill-pointer (fill-pointer array)))
(declare (fixnum fill-pointer))
(if (zerop fill-pointer)
(simple-program-error "Nothing left to pop.")
(aref array
(setf (%array-fill-pointer array)
(1- fill-pointer))))))
;;;; Adjust-array
(defun adjust-array (array dimensions &key
(element-type (array-element-type array))
(initial-element nil initial-element-p)
(initial-contents nil initial-contents-p)
fill-pointer
displaced-to displaced-index-offset)
"Adjusts the Array's dimensions to the given Dimensions and stuff."
(let ((dimensions (if (listp dimensions) dimensions (list dimensions))))
(cond ((/= (the fixnum (length (the list dimensions)))
(the fixnum (array-rank array)))
(simple-program-error "Number of dimensions not equal to rank of array."))
((not (subtypep element-type (array-element-type array)))
(simple-program-error "New element type, ~S, is incompatible with old."
element-type)))
(let ((array-rank (length (the list dimensions))))
(declare (fixnum array-rank))
(when (and fill-pointer (> array-rank 1))
(simple-program-error "Multidimensional arrays can't have fill pointers."))
(cond (initial-contents-p
;; Array former contents replaced by initial-contents.
(if (or initial-element-p displaced-to)
(simple-program-error "Initial contents may not be specified with ~
the :initial-element or :displaced-to option."))
(let* ((array-size (apply #'* dimensions))
(array-data (data-vector-from-inits
dimensions array-size element-type
initial-contents initial-contents-p
initial-element initial-element-p)))
(if (adjustable-array-p array)
(set-array-header array array-data array-size
(get-new-fill-pointer array array-size
fill-pointer)
0 dimensions nil)
(if (array-header-p array)
;; Simple multidimensional or single dimensional array.
(make-array dimensions
:element-type element-type
:initial-contents initial-contents)
array-data))))
(displaced-to
;; No initial-contents supplied is already established.
(when initial-element
(simple-program-error "The :initial-element option may not be specified ~
with :displaced-to."))
(unless (subtypep element-type (array-element-type displaced-to))
(simple-program-error "One can't displace an array of type ~S into another of ~
type ~S."
element-type (array-element-type displaced-to)))
(let ((displacement (or displaced-index-offset 0))
(array-size (apply #'* dimensions)))
(declare (fixnum displacement array-size))
(if (< (the fixnum (array-total-size displaced-to))
(the fixnum (+ displacement array-size)))
(simple-program-error "The :displaced-to array is too small."))
(if (adjustable-array-p array)
;; None of the original contents appear in adjusted array.
(set-array-header array displaced-to array-size
(get-new-fill-pointer array array-size
fill-pointer)
displacement dimensions t)
;; Simple multidimensional or single dimensional array.
(make-array dimensions
:element-type element-type
:displaced-to displaced-to
:displaced-index-offset
displaced-index-offset))))
((= array-rank 1)
(let ((old-length (array-total-size array))
(new-length (car dimensions))
new-data)
(declare (fixnum old-length new-length))
(with-array-data ((old-data array) (old-start)
(old-end old-length))
(cond
((and (adjustable-array-p array)
(not (%array-displaced-p array))
(<= new-length old-length))
;; Shrink underlying vector in-place. We don't do this
;; for non-adjustable arrays, since that might confuse
;; user expectations about adjust-array consing a fresh
;; array in that case.
(setf new-data (shrink-vector old-data new-length)))
(t
(setf new-data
(data-vector-from-inits
dimensions new-length element-type
initial-contents initial-contents-p
initial-element initial-element-p))
(replace new-data old-data
:start2 old-start :end2 old-end)))
(if (adjustable-array-p array)
(set-array-header array new-data new-length
(get-new-fill-pointer array new-length
fill-pointer)
0 dimensions nil)
new-data))))
(t
(let ((old-length (%array-available-elements array))
(new-length (apply #'* dimensions)))
(declare (fixnum old-length new-length))
(cond ((null dimensions)
array)
(t
(with-array-data ((old-data array) (old-start)
(old-end old-length))
(declare (ignore old-end))
(let ((new-data (if (or (%array-displaced-p array)
(> new-length old-length))
(data-vector-from-inits
dimensions new-length
element-type () nil
initial-element initial-element-p)
old-data)))
(if (or (zerop old-length) (zerop new-length))
(when initial-element-p (fill new-data initial-element))
(zap-array-data old-data (array-dimensions array)
old-start
new-data dimensions new-length
element-type initial-element
initial-element-p))
(if (adjustable-array-p array)
(set-array-header array new-data new-length
new-length 0 dimensions nil)
(let ((new-array
(make-array-header vm:simple-array-type array-rank)))
(set-array-header new-array new-data new-length
new-length 0 dimensions nil)))))))))))))
(defun get-new-fill-pointer (old-array new-array-size fill-pointer)
(cond ((not fill-pointer)
(when (array-has-fill-pointer-p old-array)
(when (> (%array-fill-pointer old-array) new-array-size)
(simple-program-error
"Cannot adjust-array an array (~S) to a size (~S) that is ~
smaller than it's fill pointer (~S)."
old-array new-array-size (fill-pointer old-array)))
(%array-fill-pointer old-array)))
((not (array-has-fill-pointer-p old-array))
(simple-program-error
"Cannot supply a non-NIL value (~S) for :fill-pointer ~
in adjust-array unless the array (~S) was originally ~
created with a fill pointer."
fill-pointer
old-array))
((numberp fill-pointer)
(when (> fill-pointer new-array-size)
(simple-program-error
"Cannot supply a value for :fill-pointer (~S) that is larger ~
than the new length of the vector (~S)."
fill-pointer new-array-size))
fill-pointer)
((eq fill-pointer t)
new-array-size)
(t
(simple-program-error "Bogus value for :fill-pointer in adjust-array: ~S"
fill-pointer))))
(defun shrink-vector (vector new-size)
"Destructively alters the Vector, changing its length to New-Size, which
must be less than or equal to its current size."
(declare (vector vector))
(unless (array-header-p vector)
(macrolet ((frob (name &rest things)
`(etypecase ,name
,@(mapcar #'(lambda (thing)
`(,(car thing)
(fill (truly-the ,(car thing) ,name)
,(cadr thing)
:start new-size)))
things))))
(frob vector
(simple-vector 0)
(simple-base-string (code-char 0))
(simple-bit-vector 0)
((simple-array (unsigned-byte 2) (*)) 0)
((simple-array (unsigned-byte 4) (*)) 0)
((simple-array (unsigned-byte 8) (*)) 0)
((simple-array (unsigned-byte 16) (*)) 0)
((simple-array (unsigned-byte 32) (*)) 0)
((simple-array (signed-byte 8) (*)) 0)
((simple-array (signed-byte 16) (*)) 0)
((simple-array (signed-byte 30) (*)) 0)
((simple-array (signed-byte 32) (*)) 0)
((simple-array single-float (*)) (coerce 0 'single-float))
((simple-array double-float (*)) (coerce 0 'double-float))
#+long-float
((simple-array long-float (*)) (coerce 0 'long-float))
#+double-double
((simple-array double-double-float (*))
(coerce 0 'double-double-float))
((simple-array (complex single-float) (*))
(coerce 0 '(complex single-float)))
((simple-array (complex double-float) (*))
(coerce 0 '(complex double-float)))
#+long-float
((simple-array (complex long-float) (*))
(coerce 0 '(complex long-float)))
#+double-double
((simple-array (complex double-double-float) (*))
(coerce 0 '(complex double-double-float))))))
;; Only arrays have fill-pointers, but vectors have their length parameter
;; in the same place.
(setf (%array-fill-pointer vector) new-size)
vector)
(defun set-array-header (array data length fill-pointer displacement dimensions
&optional displacedp)
"Fills in array header with provided information. Returns array."
(setf (%array-data-vector array) data)
(setf (%array-available-elements array) length)
(cond (fill-pointer
(setf (%array-fill-pointer array) fill-pointer)
(setf (%array-fill-pointer-p array) t))
(t
(setf (%array-fill-pointer array) length)
(setf (%array-fill-pointer-p array) nil)))
(setf (%array-displacement array) displacement)
(if (listp dimensions)
(dotimes (axis (array-rank array))
(declare (type index axis))
(setf (%array-dimension array axis) (pop dimensions)))
(setf (%array-dimension array 0) dimensions))
(setf (%array-displaced-p array) displacedp)
array)
;;;; ZAP-ARRAY-DATA for ADJUST-ARRAY.
;;; Make a temporary to be used when old-data and new-data are EQ.
;;;
(defvar *zap-array-data-temp* (make-array 1000 :initial-element t))
(defun zap-array-data-temp (length element-type initial-element
initial-element-p)
(declare (fixnum length))
(when (> length (the fixnum (length *zap-array-data-temp*)))
(setf *zap-array-data-temp*
(make-array length :initial-element t)))
(when initial-element-p
(unless (typep initial-element element-type)
(simple-program-error "~S cannot be used to initialize an array of type ~S."
initial-element element-type))
(fill (the simple-vector *zap-array-data-temp*) initial-element
:end length))
*zap-array-data-temp*)
;;; ZAP-ARRAY-DATA -- Internal.
;;;
;;; This does the grinding work for ADJUST-ARRAY. It zaps the data from the
;;; Old-Data in an arrangement specified by the Old-Dims to the New-Data in an
;;; arrangement specified by the New-Dims. Offset is a displaced offset to be
;;; added to computed indexes of Old-Data. New-Length, Element-Type,
;;; Initial-Element, and Initial-Element-P are used when Old-Data and New-Data
;;; are EQ; in this case, a temporary must be used and filled appropriately.
;;; When Old-Data and New-Data are not EQ, New-Data has already been filled
;;; with any specified initial-element.
;;;
(defun zap-array-data (old-data old-dims offset new-data new-dims new-length
element-type initial-element initial-element-p)
(declare (list old-dims new-dims))
(setq old-dims (nreverse old-dims))
(setq new-dims (reverse new-dims))
(if (eq old-data new-data)
(let ((temp (zap-array-data-temp new-length element-type
initial-element initial-element-p)))
(zap-array-data-aux old-data old-dims offset temp new-dims)
(dotimes (i new-length) (setf (aref new-data i) (aref temp i))))
(zap-array-data-aux old-data old-dims offset new-data new-dims)))
(defun zap-array-data-aux (old-data old-dims offset new-data new-dims)
(declare (fixnum offset))
(let ((limits (mapcar #'(lambda (x y)
(declare (fixnum x y))
(1- (the fixnum (min x y))))
old-dims new-dims)))
(macrolet ((bump-index-list (index limits)
`(do ((subscripts ,index (cdr subscripts))
(limits ,limits (cdr limits)))
((null subscripts) nil)
(cond ((< (the fixnum (car subscripts))
(the fixnum (car limits)))
(rplaca subscripts
(1+ (the fixnum (car subscripts))))
(return ,index))
(t (rplaca subscripts 0))))))
(do ((index (make-list (length old-dims) :initial-element 0)
(bump-index-list index limits)))
((null index))
(setf (aref new-data (row-major-index-from-dims index new-dims))
(aref old-data
(+ (the fixnum (row-major-index-from-dims index old-dims))
offset)))))))
;;; ROW-MAJOR-INDEX-FROM-DIMS -- Internal.
;;;
;;; This figures out the row-major-order index of an array reference from a
;;; list of subscripts and a list of dimensions. This is for internal calls
;;; only, and the subscripts and dim-list variables are assumed to be reversed
;;; from what the user supplied.
;;;
(defun row-major-index-from-dims (rev-subscripts rev-dim-list)
(do ((rev-subscripts rev-subscripts (cdr rev-subscripts))
(rev-dim-list rev-dim-list (cdr rev-dim-list))
(chunk-size 1)
(result 0))
((null rev-dim-list) result)
(declare (fixnum chunk-size result))
(setq result (+ result
(the fixnum (* (the fixnum (car rev-subscripts))
chunk-size))))
(setq chunk-size (* chunk-size (the fixnum (car rev-dim-list))))))
;;;; Some bit stuff.
(defun bit-array-same-dimensions-p (array1 array2)
(declare (type (array bit) array1 array2))
(and (= (array-rank array1)
(array-rank array2))
(dotimes (index (array-rank array1) t)
(when (/= (array-dimension array1 index)
(array-dimension array2 index))
(return nil)))))
(defun pick-result-array (result-bit-array bit-array-1)
(case result-bit-array
((t) bit-array-1)
((nil) (make-array (array-dimensions bit-array-1)
:element-type 'bit
:initial-element 0))
(t
(unless (bit-array-same-dimensions-p bit-array-1
result-bit-array)
(simple-program-error "~S and ~S do not have the same dimensions."
bit-array-1 result-bit-array))
result-bit-array)))
(defmacro def-bit-array-op (name function)
`(defun ,name (bit-array-1 bit-array-2 &optional result-bit-array)
,(format nil
"Perform a bit-wise ~A on the elements of BIT-ARRAY-1 and ~
BIT-ARRAY-2,~% putting the results in RESULT-BIT-ARRAY. ~
If RESULT-BIT-ARRAY is T,~% BIT-ARRAY-1 is used. If ~
RESULT-BIT-ARRAY is NIL or omitted, a new array is~% created. ~
All the arrays must have the same rank and dimensions."
(symbol-name function))
(declare (type (array bit) bit-array-1 bit-array-2)
(type (or (array bit) (member t nil)) result-bit-array))
(unless (bit-array-same-dimensions-p bit-array-1 bit-array-2)
(simple-program-error "~S and ~S do not have the same dimensions."
bit-array-1 bit-array-2))
(let ((result-bit-array (pick-result-array result-bit-array bit-array-1)))
(if (and (simple-bit-vector-p bit-array-1)
(simple-bit-vector-p bit-array-2)
(simple-bit-vector-p result-bit-array))
(locally (declare (optimize (speed 3) (safety 0)))
(,name bit-array-1 bit-array-2 result-bit-array))
(with-array-data ((data1 bit-array-1) (start1) (end1))
(declare (ignore end1))
(with-array-data ((data2 bit-array-2) (start2) (end2))
(declare (ignore end2))
(with-array-data ((data3 result-bit-array) (start3) (end3))
(do ((index-1 start1 (1+ index-1))
(index-2 start2 (1+ index-2))
(index-3 start3 (1+ index-3)))
((>= index-3 end3) result-bit-array)
(declare (type index index-1 index-2 index-3))
(setf (sbit data3 index-3)
(logand (,function (sbit data1 index-1)
(sbit data2 index-2))
1))))))))))
(def-bit-array-op bit-and logand)
(def-bit-array-op bit-ior logior)
(def-bit-array-op bit-xor logxor)
(def-bit-array-op bit-eqv logeqv)
(def-bit-array-op bit-nand lognand)
(def-bit-array-op bit-nor lognor)
(def-bit-array-op bit-andc1 logandc1)
(def-bit-array-op bit-andc2 logandc2)
(def-bit-array-op bit-orc1 logorc1)
(def-bit-array-op bit-orc2 logorc2)
(defun bit-not (bit-array &optional result-bit-array)
"Performs a bit-wise logical NOT on the elements of BIT-ARRAY,
putting the results in RESULT-BIT-ARRAY. If RESULT-BIT-ARRAY is T,
BIT-ARRAY is used. If RESULT-BIT-ARRAY is NIL or omitted, a new array is
created. Both arrays must have the same rank and dimensions."
(declare (type (array bit) bit-array)
(type (or (array bit) (member t nil)) result-bit-array))
(let ((result-bit-array (pick-result-array result-bit-array bit-array)))
(if (and (simple-bit-vector-p bit-array)
(simple-bit-vector-p result-bit-array))
(locally (declare (optimize (speed 3) (safety 0)))
(bit-not bit-array result-bit-array))
(with-array-data ((src bit-array) (src-start) (src-end))
(declare (ignore src-end))
(with-array-data ((dst result-bit-array) (dst-start) (dst-end))
(do ((src-index src-start (1+ src-index))
(dst-index dst-start (1+ dst-index)))
((>= dst-index dst-end) result-bit-array)
(declare (type index src-index dst-index))
(setf (sbit dst dst-index)
(logxor (sbit src src-index) 1))))))))