Arrays are also Sequences.
XLISP already has the
Here is a function to create
(defun make-array* (&rest dimensions-list)
(cond ((null dimensions-list)
(error "too few arguments"))
((and (null (rest dimensions-list))
(eql 0 (first dimensions-list)))
(make-array 0))
(t (labels ((multi-vector (dimensions-list)
(let ((count (first dimensions-list)))
(if (not (and (integerp count) (plusp count)))
(error "not a positive integer" count)
(let ((rest (rest dimensions-list))
(elements-list nil))
(dotimes (i count)
(push (when rest
(multi-vector rest))
elements-list))
(apply #'vector (reverse elements-list)))))))
(multi-vector dimensions-list)))))
Examples:
(make-array* 2 3) => #(#(NIL NIL NIL) #(NIL NIL NIL))) (make-array* 2 2 1) => #(#(#(NIL) #(NIL)) #(#(NIL) #(NIL)))
Like
(make-array* 0) => #() (make-array 0) => #()
But it is not allowed to create
(make-array* 1 0 1) => error: not a positive integer - 0
Rationale: Multi-dimensional arrays are implemented as nested
vectors and a
More practical examples see 'aref*' below.
XLISP already has the aref function to access elements in one-dimensional arrays:
Here is a macro for accessing elements in
(defmacro aref* (array &rest index-list)
(labels ((multi-aref (array-name index-list)
(let ((index (first index-list)))
(if (not (integerp index))
(error "not an integer" index)
(let ((rest (rest index-list))
(expansion-list (list 'aref)))
(push (if rest
(multi-aref array-name rest)
array-name)
expansion-list)
(push index expansion-list)
(reverse expansion-list))))))
(multi-aref `,array (reverse `,index-list))))
The symbols inside the labels form
do not leak into the expansion, so 'aref*' also works with array names like
'array', '
(macroexpand-1 '(aref* a 1 2 3)) => (aref (aref (aref a 1) 2) 3)
Examples:
> (setq a (make-array* 2 3)) #(#(NIL NIL NIL) #(NIL NIL NIL))) > (setf (aref* a 0 1) "hello") "hello" > a #(#(NIL "hello" NIL) #(NIL NIL NIL)) > (aref* a 0 1) "hello"
'aref*' with only one 'dimension' argument behaves
(aref* a 0) => #(NIL "hello" NIL) (aref a 0) => #(NIL "hello" NIL) (aref* (aref* a 0) 1) => "hello" (aref (aref a 0) 1) => "hello" (aref* a 0 1) => "hello" (aref a 0 1) => error: too many arguments
'aref*' like aref also works
(setf (aref* (aref* a 0) 1) "1") => "1" ; a => #(#(NIL "1" NIL) #(NIL NIL NIL))) (setf (aref (aref a 0) 1) "2") => "2" ; a => #(#(NIL "2" NIL) #(NIL NIL NIL))) (setf (aref* 0 1) "3") => "3" ; a => #(#(NIL "3" NIL) #(NIL NIL NIL))) (setf (aref 0 1) "4") => error: too many arguments
(defun vector* (&rest items)
(if (null items)
(make-array 0)
(let* ((end (length items))
(result (make-array end)))
(if (> end 1)
(dotimes (index end) ; more than one item
(setf (aref result index)
(if (eq (nth index items) '*unbound*)
'*unbound*
(nth index items))))
(if (eq (first items) '*unbound*) ; one item only
(setf (aref result 0) '*unbound*)
(let ((item (first items)))
(case (type-of item)
(cons (let ((end (length item)))
(setq result (make-array end))
(dotimes (index end)
(setf (aref result index)
(if (eq (nth index item) '*unbound*)
'*unbound*
(nth index item))))))
(array (let ((end (length item)))
(setq result (make-array end))
(dotimes (index end)
(setf (aref result index)
(if (eq (aref item index) '*unbound*)
'*unbound*
(aref item index))))))
(string (let ((end (length item)))
(setq result (make-array end))
(dotimes (index end)
(setf (aref result index)
(char item index)))))
(t (setf (aref result 0) item))))))
result)))
(defun list* (&rest items)
(if (null items)
nil
(let* ((end (length items))
(result nil))
(labels ((push-element (element)
(if (member (type-of element) '(array cons string))
(setq result (append (reverse (list* element)) result))
(push element result))))
(dotimes (index end)
(if (eq (nth index items) '*unbound*)
(push '*unbound* result)
(let ((item (nth index items)))
(case (type-of item)
(nil (push item result))
(cons (let ((end (length item)))
(when (not (consp (last item))) (incf end))
(dotimes (index end)
(if (eq (nth index item) '*unbound*)
(push '*unbound* result)
(push-element (nth index item))))))
(array (let ((end (length item)))
(dotimes (index end)
(if (eq (aref item index) '*unbound*)
(push '*unbound* result)
(push-element (aref item index))))))
(string (let ((end (length item)))
(dotimes (index end)
(push (char item index) result))))
(t (push item result))))))
(reverse result)))))
(defun tree* (&rest items)
(if (null items)
nil
(let* ((end (length items))
(result nil))
(labels ((push-element (element)
(if (member (type-of element) '(array cons string))
(push (reverse (list* element)) result)
(push element result))))
(dotimes (index end)
(if (eq (nth index items) '*unbound*)
(push '*unbound* result)
(let ((item (nth index items)))
(case (type-of item)
(nil (push item result))
(cons (let ((end (length item)))
(when (not (consp (last item))) (incf end))
(dotimes (index end)
(if (eq (nth index item) '*unbound*)
(push '*unbound* result)
(push-element (nth index item))))))
(array (let ((end (length item)))
(dotimes (index end)
(if (eq (aref item index) '*unbound*)
(push '*unbound* result)
(push-element (aref item index))))))
(string (let ((end (length item)))
(dotimes (index end)
(push (char item index) result))))
(t (push item result))))))
(reverse result)))))
(defun array* (&rest items)
(if (null items)
(make-array 0)
(let* ((end (length items))
(result (make-array end)))
(labels ((vector-element (element index)
(setf (aref result index)
(if (member (type-of element) '(cons string array))
(array* element)
element))))
(dotimes (index end)
(if (eq (nth index items) '*unbound*)
(setf (aref result index) '*unbound*)
(let ((item (nth index items)))
(case (type-of item)
(cons (let ((end (length item)))
(dotimes (index end)
(if (eq (nth index item) '*unbound*)
(strcat-element "*UNBOUND*")
(strcat-element (nth index item))))))
(array (let ((end (length item)))
(dotimes (index end)
(if (eq (aref item index) '*unbound*)
(strcat-element "*UNBOUND*")
(strcat-element (aref item index))))))
(t (strcat-element item))))))
result))))