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))))