;;; -*- Mode:LISP; Package:TIGER; Fonts:(CPTFONT TR12I); Base:8; Readtable:T -*-

; Copyright LISP Machine, Inc. 1984
;   See filename "Copyright" for
; licensing and release information.

;1;; *STUFF-ARRAY1 is a general macro for setting up the initial contents of (one-dimensional) tables.*
;1;; Usage:  *(STUFF-ARRAY ARRAY &BODY INITIALIZATION-SPECS)
;1;;*
;1;; The *INITIALIZATION-SPECS1 specify the value of one or more elements of the array.*
;1;; Each one can take one of the following forms:*
;1;;*	1(value element [element ...])*	1Puts the value in each of the specified elements.*
;1;;*	1(value (start end)*	1)*		1Puts the value in a range of elements.  As in most such things*
;1;;*					1on the Lisp Machine, end actually specifies the first element*
;1;;*					1number not included in the range!*
;1;;*	1value*				1Puts the value in all elements of the array.*
;1;;*					1If this appears, it must be given first.*
;1;;*
;1;; Any elements not mentioned at all will not be changed.*
;1;;*
;1;; It is important to note that the macro makes no attempt to be clever about avoiding writing the*
;1;; same element of the array twice.  The last value given (in any way) will override any given before it.*
;1;; Usually the right thing to do is to give the default value first (if used, it must be first), then any range*
;1;; initializations, then finally any initializations specifying specific elements (perhaps changing a few*
;1;; elements inside the range specifications).*
;1;;*
;1;; The default and range initializations are very fast, since they use *ARRAY-INITIALIZE1, which is done*
;1; in microcode.  Specific element initializations use ordinary *ASET1.*

(defmacro stuff-array (array &body initialization-specs)
  `(progn 'compile
     ,@(loop with not-first-p = nil
	     for spec in initialization-specs
	     collect (cond ((atom spec)
			    (when not-first-p
			      (ferror nil "Default value not first in STUFF-ARRAY."))
			    `(array-initialize ,array ,spec))
			   ((atom (cadr spec))
			    `(progn ,@(loop with value = (car spec)
					    for element in (cdr spec)
					    collect `(aset ,value ,array ,element))))
			   (t `(array-initialize ,array
						 ,(car spec)		;1value*
						 ,(caadr spec)		;1start*
						 ,(cadadr spec))))	;1end*
	     do (setq not-first-p t))))