;;; -*- Lisp -*-
;;;
;;; **********************************************************************
;;; This code was written as part of the Spice Lisp project at
;;; Carnegie-Mellon University, and has been placed in the public domain.
;;; Spice Lisp is currently incomplete and under active development.
;;; If you want to use this code or any part of Spice Lisp, please contact
;;; Scott Fahlman (FAHLMAN@CMUC).
;;; **********************************************************************
;;;
;;; Functions to implement arrays for Spice Lisp
;;; Written by Skef Wholey.
;;;
(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.")
(defun make-array (dimensions &key
(element-type t)
(initial-element nil initial-element-p)
initial-contents adjustable fill-pointer
displaced-to displaced-index-offset)
"Creates an array of the specified Dimensions. See manual for details."
(if (not (listp dimensions)) (setq dimensions (list dimensions)))
(if (eq fill-pointer t) (setq fill-pointer (car dimensions)))
(let ((array-rank (length (the list dimensions))))
(cond (displaced-to
;; If the array is displaced, make a header and fill it up.
(unless (subtypep element-type (array-element-type displaced-to))
(error "One can't displace an array of type ~S into another of ~
type ~S." element-type (array-element-type displaced-to)))
(let* ((array-size (array-linear-length dimensions))
(array (%primitive alloc-array array-rank)))
(%primitive header-set array %array-data-slot displaced-to)
(%primitive header-set array %array-length-slot array-size)
(%primitive header-set array %array-fill-pointer-slot
(or fill-pointer array-size))
(%primitive header-set array %array-displacement-slot
displaced-index-offset)
(do ((index %array-first-dim-slot (1+ index))
(dims dimensions (cdr dims)))
((null dims))
(%primitive header-set array index (car dims)))
array))
((and (not adjustable) (= array-rank 1) (not fill-pointer))
;; If the array can be represented as a simple thing, do that.
(data-vector-from-inits (car dimensions) array-rank
element-type initial-contents
initial-element initial-element-p))
(t
;; Otherwise, build a complex array.
(let* ((array-size (array-linear-length dimensions))
(array (%primitive alloc-array array-rank)))
(%primitive header-set array %array-data-slot
(data-vector-from-inits array-size array-rank
element-type initial-contents
initial-element initial-element-p))
(%primitive header-set array %array-length-slot array-size)
(%primitive header-set array %array-fill-pointer-slot
(or fill-pointer array-size))
(%primitive header-set array %array-displacement-slot 0)
(do ((index %array-first-dim-slot (1+ index))
(dims dimensions (cdr dims)))
((null dims))
(%primitive header-set array index (car dims)))
array)))))
;;; Some people out there are still calling Make-Vector:
(setf (symbol-function 'make-vector) #'make-array)
(defun vector (&rest objects)
"Constructs a Simple-Vector from the given objects."
(coerce (the list objects) 'simple-vector))
;;; Data-Vector-From-Inits returns a simple vector that has the specified array
;;; characteristics.
(defun data-vector-from-inits (size rank element-type initial-contents
initial-element initial-element-p)
(let ((data (cond ((subtypep element-type 'string-char)
(%primitive alloc-string size))
((subtypep element-type '(mod 65536))
(%primitive alloc-i-vector size
(element-type-to-access-code element-type)))
(t
(%primitive alloc-g-vector size initial-element)))))
(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
(copy-contents-aux initial-contents element-type rank 0 data)))
data))
;;; Element-Type-To-Access-Code returns the Spice Lisp I-Vector access code
;;; to be used for the data vector of an array with the given access code.
(defun element-type-to-access-code (type)
(cond ((eq type 'bit)
0)
((atom type)
(error "I can't hack the element-type ~S!" type))
((eq (car type) 'mod)
(integer-length (1- (integer-length (1- (cadr type))))))
((eq (car type) 'unsigned-byte)
(integer-length (1- (cadr type))))))
;;; Copy-Contents-Aux spins down into the Data vector and the Initial-Contents
;;; filling the former from the latter.
(defun copy-contents-aux (initial-contents element-type depth index data)
(cond ((= depth 0)
(unless (typep initial-contents element-type)
(error "~S cannot be used to initialize an array of element-type ~S."))
(setf (aref data index) initial-contents)
(1+ index))
((listp initial-contents)
(do ((initial-contents initial-contents (cdr initial-contents)))
((null initial-contents) index)
(setq index (copy-contents-aux
(car initial-contents) element-type (1- depth)
index data))))
((vectorp initial-contents)
(do ((i-index 0 (1+ i-index))
(i-end (length initial-contents)))
((= i-index i-end) index)
(setq index (copy-contents-aux
(aref initial-contents index) element-type (1- depth)
index data))))
(t
(error "~S is not a sequence, and cannot be used to initialize~%~
the contents of an array." initial-contents))))
;;; Array-Linear-Length returns the number of elements an array with the
;;; specified Dimensions would have.
(defun array-linear-length (dimensions)
(do ((dimensions dimensions (cdr dimensions))
(length 1))
((null dimensions) length)
(setq length (* length (car dimensions)))))
(defun aref (array &rest subscripts)
"Returns the element of the Array specified by the Subscripts."
(if (and subscripts (null (cdr subscripts)))
(aref array (car subscripts))
(do ((subscripts (nreverse (the list subscripts)) (cdr subscripts))
(dim-index (1- (%primitive header-length array)) (1- dim-index))
(chunk-size 1)
(result 0)
(axis))
((= dim-index %array-dim-base)
(if (atom subscripts)
(aref (%primitive header-ref array %array-data-slot)
(+ (%primitive header-ref array %array-displacement-slot)
result))
(error "Too many subscripts for array reference.")))
(setq axis (%primitive header-ref array dim-index))
(cond ((atom subscripts)
(error "Too few subscripts for array reference."))
((not (< -1 (car subscripts) axis))
(error "Subscript ~S is out of bounds." (car subscripts)))
(t
(setq result (+ result (* (car subscripts) chunk-size)))
(setq chunk-size (* chunk-size axis)))))))
(defun %aset (array &rest stuff)
(if (and (cdr stuff) (null (cddr stuff)))
(setf (aref array (car stuff)) (cadr stuff))
(let ((rstuff (nreverse (the list stuff))))
(do ((subscripts (cdr rstuff) (cdr subscripts))
(dim-index (1- (%primitive header-length array)) (1- dim-index))
(chunk-size 1)
(result 0)
(axis))
((= dim-index %array-dim-base)
(if (atom subscripts)
(setf (aref (%primitive header-ref array %array-data-slot)
(+ (%primitive header-ref array
%array-displacement-slot)
result))
(car rstuff))
(error "Too many subscripts for array reference.")))
(setq axis (%primitive header-ref array dim-index))
(cond ((atom subscripts)
(error "Too few subscripts for array reference."))
((not (< -1 (the fixnum (car subscripts)) axis))
(error "Subscript ~S is out of bounds."
(car subscripts)))
(t
(setq result (+ result (* (car subscripts) chunk-size)))
(setq chunk-size (* chunk-size axis))))))))
(defun array-element-type (array)
"Returns the type of the elements of the array"
(cond ((bit-vector-p array)
'(mod 2))
((stringp array)
'string-char)
((simple-vector-p array)
t)
((slisp-array-p array)
(array-element-type (%primitive header-ref array %array-data-slot)))
((vectorp array)
(case (%primitive get-vector-access-code array)
(0 '(mod 2))
(1 '(mod 4))
(2 '(mod 16))
(3 '(mod 256))
(4 '(mod 65536))))
(t (error "~S is not an array." array))))
(defun array-rank (array)
"Returns the number of dimensions of the Array."
(if (slisp-array-p array)
(- (%primitive header-length array) %array-first-dim-slot)
1))
(defun array-dimension (array axis-number)
"Returns length of dimension Axis-Number of the Array."
(if (slisp-array-p array)
(if (and (>= axis-number 0) (< axis-number (array-rank array)))
(%primitive header-ref array (+ %array-first-dim-slot axis-number))
(error "~S is an illegal axis number." axis-number))
(if (= axis-number 0)
(%primitive vector-length array)
(error "~S is an illegal axis number." axis-number))))
(defun array-dimensions (array)
"Returns a list whose elements are the dimensions of the array"
(if (slisp-array-p array)
(do ((index %array-first-dim-slot (1+ index))
(end (%primitive header-length array))
(result ()))
((= index end) (nreverse result))
(push (%primitive header-ref array index) result))
(list (%primitive vector-length array))))
(defun array-total-size (array)
"Returns the total number of elements in the Array."
(if (slisp-array-p array)
(%primitive header-ref array %array-length-slot)
(%primitive vector-length array)))
(defun array-in-bounds-p (array &rest subscripts)
"Returns T if the Subscipts are in bounds for the Array, Nil otherwise."
(if (slisp-array-p array)
(do ((dim-index %array-first-dim-slot (1+ dim-index))
(dim-index-limit (+ %array-first-dim-slot (array-rank array)))
(subs subscripts (cdr subs)))
((= dim-index dim-index-limit)
(atom subs))
(if (atom subs)
(return nil)
(if (not (< -1 (car subs) (%primitive header-ref array dim-index)))
(return nil))))
(and (null (cdr subscripts))
(< -1 (car subscripts) (%primitive vector-length array)))))
(defun array-row-major-index (array &rest subscripts)
"Returns the index into the Array's data vector for the given subscripts."
(do ((subscripts (nreverse (the list subscripts)) (cdr subscripts))
(dim-index (1- (%primitive header-length array)) (1- dim-index))
(chunk-size 1)
(result 0)
(axis))
((= dim-index %array-dim-base)
(if (atom subscripts)
result
(error "Too many subscripts for array reference.")))
(setq axis (%primitive header-ref array dim-index))
(cond ((atom subscripts)
(error "Too few subscripts for array reference."))
((not (< -1 (car subscripts) axis))
(error "Subscript ~S is out of bounds." (car subscripts)))
(t
(setq result (+ result (* (car subscripts) chunk-size)))
(setq chunk-size (* chunk-size axis))))))
(defun adjustable-array-p (array)
"Returns T if the given Array is adjustable, or Nil otherwise."
(slisp-array-p array))
(defun svref (simple-vector index)
"Returns the Index'th element of the given Simple-Vector."
(svref simple-vector index))
(defun %svset (simple-vector index new)
(setf (svref simple-vector index) new))
(defun array-has-fill-pointer-p (array)
"Returns T if the given Array has a fill pointer, or Nil otherwise."
(and (vectorp array) (slisp-array-p array)))
(defun fill-pointer (vector)
"Returns the Fill-Pointer of the given Vector."
(if (and (vectorp vector) (slisp-array-p vector))
(%primitive header-ref vector %array-fill-pointer-slot)
(error "~S is not an array with a fill-pointer." vector)))
(defun %set-fill-pointer (vector new)
(if (and (vectorp vector) (slisp-array-p vector))
(if (> new (%primitive header-ref vector %array-length-slot))
(error "New fill pointer, ~S, is larger than the length of the vector."
new)
(%primitive header-set vector %array-fill-pointer-slot new))
(error "~S is not an array with a fill-pointer." 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 new fill pointer value is
returned."
(if (slisp-array-p array)
(let ((fill-pointer (%primitive header-ref array %array-fill-pointer-slot)))
(cond ((= fill-pointer (%primitive header-ref array %array-length-slot))
nil)
(t (%primitive header-set array %array-fill-pointer-slot
(1+ fill-pointer))
(setf (aref (%primitive header-ref array %array-data-slot)
(+ fill-pointer (%primitive header-ref array
%array-displacement-slot)))
new-el)
(1+ fill-pointer))))
(error "~S: Object has no fill pointer." array)))
(defun vector-push-extend (new-el array &optional (extension (length array)))
"Like Vector-Push except that if the fill pointer gets too large, the
Array is extended rather than Nil being returned."
(if (slisp-array-p array)
(let ((length (%primitive header-ref array %array-length-slot))
(fill-pointer (%primitive header-ref array %array-fill-pointer-slot))
(data (%primitive header-ref array %array-data-slot)))
(if (= fill-pointer length)
(do* ((new-index 0 (1+ new-index))
(new-length (+ length extension))
(old-index (%primitive header-ref array %array-displacement-slot)
(1+ old-index))
(new-data (make-array new-length
:element-type (array-element-type array))))
((= new-index length)
(%primitive header-set array %array-data-slot new-data)
(setq data new-data)
(%primitive header-set array %array-length-slot new-length)
(%primitive header-set array %array-first-dim-slot new-length))
(setf (aref new-data new-index) (aref data old-index))))
(%primitive header-set array %array-fill-pointer-slot (1+ fill-pointer))
(setf (aref data
(+ fill-pointer
(%primitive header-ref array %array-displacement-slot)))
new-el)
(1+ fill-pointer))
(error "~S has no fill pointer." array)))
(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 new value of the fill
pointer is 0, an error occurs."
(if (slisp-array-p array)
(let ((fill-pointer (%primitive header-ref array %array-fill-pointer-slot)))
(cond ((< fill-pointer 1)
(error "Fill-pointer reached 0."))
(t
(%primitive header-set array %array-fill-pointer-slot
(1- fill-pointer))
(aref (%primitive header-ref array %array-data-slot)
(+ (1- fill-pointer)
(%primitive header-ref array
%array-displacement-slot))))))
(error "~S: Object has no fill pointer." array)))
(defun adjust-array (array dimensions &rest options &key
(element-type t)
(initial-element nil initial-element-p)
initial-contents adjustable fill-pointer
displaced-to displaced-index-offset)
"Adjusts the Array's dimensions to the given Dimensions and stuff."
(if (atom dimensions) (setq dimensions (list dimensions)))
(if (not (slisp-array-p array))
(error "~S is not an adjustable array." array))
(if (not (= (length (the list dimensions)) (array-rank array)))
(error "Number of dimensions not equal to rank of array."))
(unless (subtypep element-type (array-element-type array))
(error "New element type, ~S, is incompatible with old." element-type))
(cond ((or initial-contents displaced-to)
displaced-index-offset adjustable
(setq array (apply #'make-array dimensions options)))
((null (cdr dimensions))
(if (eq fill-pointer t) (setq fill-pointer (car dimensions)))
(if fill-pointer
(%primitive header-set array %array-fill-pointer-slot fill-pointer))
(let ((old-length (%primitive header-ref array %array-length-slot))
(new-length (car dimensions))
(old-data (%primitive header-ref array %array-data-slot)))
(%primitive header-set array %array-length-slot new-length)
(cond ((>= old-length new-length)
(%primitive shrink-vector old-data new-length))
(t
(let ((data
(data-vector-from-inits
new-length 1 element-type initial-contents
initial-element initial-element-p)))
(replace data old-data)
(%primitive header-set array %array-data-slot data))))
(%primitive header-set array %array-first-dim-slot new-length)))
(t
(if fill-pointer
(error "Multidimensional arrays can't have fill pointers."))
(let* ((old-length (%primitive header-ref array %array-length-slot))
(new-length (array-linear-length dimensions))
(old-data (%primitive header-ref array %array-data-slot))
(new-data (if (> new-length old-length)
(data-vector-from-inits
new-length (length (the list dimensions))
element-type ()
initial-element initial-element-p)
old-data)))
(%primitive header-set array %array-length-slot new-length)
(%primitive header-set array %array-data-slot new-data)
(zap-array-data old-data (array-dimensions array)
new-data dimensions)
(do ((new-dims dimensions (cdr new-dims))
(dim-slot %array-first-dim-slot (1+ dim-slot)))
((null new-dims))
(%primitive header-set array dim-slot (car new-dims))))))
array)
(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."
(cond ((slisp-array-p vector)
(%primitive shrink-vector
(%primitive header-ref vector %array-data-slot)
new-size)
(%primitive header-set vector %array-length-slot new-size))
(t
(%primitive shrink-vector vector new-size))))
;;; Zap-Array-Data does the grinding work for Adjust-Array. The data is zapped
;;; from the Old-Data in an arrangement specified by the Old-Dims to the
;;; New-Data in an arrangement specified by the New-Dims.
;;; Bump-Index-List helps us out:
(eval-when (compile eval)
(defmacro bump-index-list (index limits)
`(do ((subscripts ,index (cdr subscripts))
(limits ,limits (cdr limits)))
((null subscripts) nil)
(cond ((< (car subscripts) (car limits))
(rplaca subscripts (1+ (car subscripts)))
(return ,index))
(t
(rplaca subscripts 0)))))
)
(defun row-major-index-from-dims (subscripts dim-list)
(do ((subscripts subscripts (cdr subscripts))
(dim-list dim-list (cdr dim-list))
(chunk-size 1)
(result 0))
((null dim-list) result)
(setq result (+ result (* (car subscripts) chunk-size)))
(setq chunk-size (* chunk-size (car dim-list)))))
(defun zap-array-data (old-data old-dims new-data new-dims)
(declare (list old-dims new-dims))
(setq old-dims (nreverse old-dims))
(setq new-dims (reverse new-dims))
(let ((limits (mapcar #'(lambda (x y)
(1- (min x y)))
old-dims new-dims)))
(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 (row-major-index-from-dims index old-dims))))))
(defun bit (bit-array &rest subscripts)
"Returns the bit from the Bit-Array at the specified Subscripts."
(apply #'aref bit-array subscripts))
(defun %bitset (bit-array &rest stuff)
(apply #'%aset bit-array stuff))
(defun sbit (simple-bit-array &rest subscripts)
"Returns the bit from the Simple-Bit-Array at the specified Subscripts."
(apply #'aref simple-bit-array subscripts))
(defun %sbitset (bit-array &rest stuff)
(apply #'%aset bit-array stuff))
(defun bit-array-same-dimensions-p (array1 array2)
(and (= (%primitive header-length array1)
(%primitive header-length array2))
(do ((index %array-first-dim-slot (1+ index))
(length (- (%primitive header-length array1) %array-dim-base)))
((= index length) t)
(if (/= (%primitive header-ref array1 index)
(%primitive header-ref array2 index))
(return nil)))))
(defun bit-array-boole (array1 array2 op result-array)
(cond ((simple-bit-vector-p array1)
(let ((length (%primitive vector-length array1)))
(unless (and (simple-bit-vector-p array2)
(= (%primitive vector-length array2) length))
(error "~S and ~S do not have the same dimensions." array1 array2))
(if result-array
(unless (and (simple-bit-vector-p result-array)
(= (%primitive vector-length result-array) length))
(error "~S and ~S do not have the same dimensions."
array1 result-array))
(setq result-array (%primitive alloc-bit-vector length)))
(%primitive bit-bash array1 array2 result-array op)))
(t
(unless (bit-array-same-dimensions-p array1 array2)
(error "~S and ~S do not have the same dimensions." array1 array2))
(if result-array
(unless (bit-array-same-dimensions-p array1 result-array)
(error "~S and ~S do not have the same dimensions."
array1 result-array))
(setq result-array (make-array (array-dimensions array1)
:element-type '(mod 2))))
(let ((data1 (%primitive header-ref array1 %array-data-slot))
(data2 (%primitive header-ref array2 %array-data-slot))
(data3 (%primitive header-ref result-array %array-data-slot))
(start1 (%primitive header-ref array1 %array-displacement-slot))
(start2 (%primitive header-ref array2 %array-displacement-slot))
(start3 (%primitive header-ref result-array %array-displacement-slot))
(length (%primitive header-ref array1 %array-length-slot)))
(do ((index 0 (1+ index))
(index1 start1 (1+ index1))
(index2 start2 (1+ index2))
(index3 start3 (1+ index3)))
((= index length) result-array)
(setf (sbit data3 index3)
(boole op (sbit data1 index1) (sbit data2 index2))))))))
(defun bit-and (bit-array1 bit-array2 &optional result-bit-array)
"Performs a bit-wise logical AND on the elements of Bit-Array1 and Bit-Array2
putting the results in the Result-Bit-Array."
(bit-array-boole bit-array1 bit-array2 boole-and result-bit-array))
(defun bit-ior (bit-array1 bit-array2 &optional result-bit-array)
"Performs a bit-wise logical IOR on the elements of Bit-Array1 and Bit-Array2
putting the results in the Result-Bit-Array."
(bit-array-boole bit-array1 bit-array2 boole-ior result-bit-array))
(defun bit-xor (bit-array1 bit-array2 &optional result-bit-array)
"Performs a bit-wise logical XOR on the elements of Bit-Array1 and Bit-Array2
putting the results in the Result-Bit-Array."
(bit-array-boole bit-array1 bit-array2 boole-xor result-bit-array))
(defun bit-eqv (bit-array1 bit-array2 &optional result-bit-array)
"Performs a bit-wise logical EQV on the elements of Bit-Array1 and Bit-Array2
putting the results in the Result-Bit-Array."
(bit-array-boole bit-array1 bit-array2 boole-eqv result-bit-array))
(defun bit-nand (bit-array1 bit-array2 &optional result-bit-array)
"Performs a bit-wise logical NAND on the elements of Bit-Array1 and Bit-Array2
putting the results in the Result-Bit-Array."
(bit-array-boole bit-array1 bit-array2 boole-nand result-bit-array))
(defun bit-nor (bit-array1 bit-array2 &optional result-bit-array)
"Performs a bit-wise logical NOR on the elements of Bit-Array1 and Bit-Array2
putting the results in the Result-Bit-Array."
(bit-array-boole bit-array1 bit-array2 boole-nor result-bit-array))
(defun bit-andc1 (bit-array1 bit-array2 &optional result-bit-array)
"Performs a bit-wise logical ANDC1 on the elements of Bit-Array1 and Bit-Array2
putting the results in the Result-Bit-Array."
(bit-array-boole bit-array1 bit-array2 boole-andc1 result-bit-array))
(defun bit-andc2 (bit-array1 bit-array2 &optional result-bit-array)
"Performs a bit-wise logical ANDC2 on the elements of Bit-Array1 and Bit-Array2
putting the results in the Result-Bit-Array."
(bit-array-boole bit-array1 bit-array2 boole-andc2 result-bit-array))
(defun bit-orc1 (bit-array1 bit-array2 &optional result-bit-array)
"Performs a bit-wise logical ORC1 on the elements of Bit-Array1 and Bit-Array2
putting the results in the Result-Bit-Array."
(bit-array-boole bit-array1 bit-array2 boole-orc1 result-bit-array))
(defun bit-orc2 (bit-array1 bit-array2 &optional result-bit-array)
"Performs a bit-wise logical ORC2 on the elements of Bit-Array1 and Bit-Array2
putting the results in the Result-Bit-Array."
(bit-array-boole bit-array1 bit-array2 boole-orc2 result-bit-array))
(defun bit-not (bit-array &optional result-bit-array)
"Performs a bit-wise logical NOT in the elements of the Bit-Array putting
the results into the Result-Bit-Array."
(bit-array-boole bit-array bit-array boole-nor result-bit-array))