LMFL#!C(:HOST "SYS" :BACKUP-DATE 2760031364. :SYSTEM-TYPE :LOGICAL :VERSION 14. :TYPE "LISP" :NAME "ARRAYS" :DIRECTORY ("REL3-SOURCE" "KERNEL") :SOURCE-PATTERN "( :DIRECTORY (\"REL3-SOURCE\") :NAME :WILD :TYPE :WILD :VERSION :NEWEST)" :VERSION-LIMIT 0. :CHARACTERS T :NOT-BACKED-UP T :CREATION-DATE 2758638433. :AUTHOR "REL3" :LENGTH-IN-BYTES 64688. :LENGTH-IN-BLOCKS 64. :BYTE-SIZE 8.)                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                              ;; -*- cold-load:t; Mode:Common-Lisp; Package:SYSTEM-INTERNALS; Base:8 -*-;;;                           RESTRICTED RIGHTS LEGEND;;;Use, duplication, or disclosure by the Government is subject to;;;restrictions as set forth in subdivision (b)(3)(ii) of the Rights in;;;Technical Data and Computer Software clause at 52.227-7013.;;;                     TEXAS INSTRUMENTS INCORPORATED.;;;                              P.O. BOX 2909;;;                           AUSTIN, TEXAS 78769;;;                                 MS 2151;;; Copyright (C) 1985,1987 Texas Instruments Incorporated. All rights reserved.;** (c) Copyright 1980 Massachusetts Institute of Technology **;;; Correction history:;;; 04-15-87 ab  Fix array-initialize for physical arrays.;;; 02/04-87 AB  Added 2 new array functions, array-data-buffer-address (like array-data-offset;;;              but works on displaced arrays), and array-element-offset (generalization of;;;              array-data-offset).;;; 11/11/86 AB  Moved COPY-OBJECT and COPY-OBJECT-TREE to MEMORY; STORAGE-INTERNALS file.;;;              Made changes required for TGC.;;; 07/10/86 DRH added type spec definitions for use in make-array & friends;;; 07/07/86 drh added internal-make-simple-vector which creates simple-arrays for Common Lisp sequence functions;;; 06/20/86 DRH changed reference to list-product to apply -- another look at make-array , array-type-from-element type;;; 05/23/86 SDK Merge with Kernel version.  Restore %P-LDB-OFFSET instead of %P-LDB.;;; 05/20/86 LGO Insert missing quote before ART-STRING in ARRAY-TYPE-FROM-ELEMENT-TYPE ;;; 05/20/86 LGO In MAKE-ARRAY, Put array total size in leader 0 On :fill-pointer T;;; 05/20/86 LGO In MAKE-ARRAY, Relax common-lisp displaced-to type restrictions.;;; 05/20/86 LGO Ignore the fill-pointer in Make-Array when setting an :initial-element.;;; 02/28/86 LGO Added PHD's patch to array-type-from-element-type fixing ART-32B and ART-4B clauses.;;; 02/25/86 LGO Modify MAKE-ARRAY to check for compatable displaced-to types.;;; 02/24/86 LGO More common-lisp compatablility changes.;;; 02/19/86 LGO Modify MAKE-ARRAY and SIMPLE-MAKE-ARRAY to make zero length arrays not simple.;;; 02/19/86 LGO Added INITIAL-VALUE keyword to MAKE-ARRAY for zetalisp compatability.;;; 01/23/86 RNB Allowed the NEW-DIMENSIONS parameter to ADJUST-ARRAY to be a fixnum.;;; 10/23/85 RNB Remove the restriction that named-arrays be one dimensionsl from MAKE-ARRAY.;;; 09/24/85 LGO Modified for simple arrays.;;; 07/11/85 DRH Original common lisp converted from old MIT code.;;; Array manipulation functions(defconstant array-index-order t);;PHD 1/2/87 Fixed the alist so we can find type-canonicalized types in it.;Ordered as per ARRAY-TYPES(DEFCONSTANT array-element-type-alist  '((nil . art-error)    (BIT . art-1b)    ((MOD 4) . art-2b)    ((MOD 20) . art-4b)    ((MOD 400) . art-8b)    ((MOD 200000) . art-16b)            ((MOD 40000000000) . art-32b)    (t . art-q)    (t . art-q-list)    (STRING-CHAR . art-string)    (t . art-stack-group-head)    (t . art-special-pdl)    ((signed-byte 20) . art-half-fix)    (t . art-reg-pdl)    (DOUBLE-FLOAT . art-double-float)    (SINGLE-FLOAT . art-single-float)    (fat-char . art-fat-string)    ((COMPLEX double-float) . art-complex-double-float)    (COMPLEX . art-complex)    ((COMPLEX single-float) . art-complex-single-float)            (fixnum . art-fix)    ((integer 0 1) . art-1b)    ((integer 0 3 ) . art-2b)    ((integer 0 15. ) . art-4b)    ((integer 0 #.(1- (expt 2 8.))) . art-8b)    ((integer 0 #.(1- (expt 2 16.))) . art-16b)            ((integer 0 #.(1- (expt 2 32.))) . art-32b)    (#.(type-canonicalize '(signed-byte 20)) . art-half-fix)    (#.(type-canonicalize 'fixnum) . art-fix)    (#.(type-canonicalize 'string-char) . art-string)));;PHD 2/13/87 New alist.(defconstant obsolete-array-types    '((art-single-float . art-float)      (art-complex-single-float . art-complex-float)))(DEFCONSTANT array-element-size-alist  '((2 . art-1b)    (4 . art-2b)    (20 . art-4b)    (400 . art-8b)    (200000 . art-16b)            (40000000000 . art-32b)))(DEFF cli:aref #'common-lisp-aref)(SETF (DOCUMENTATION 'cli:aref 'FUNCTION)  "Access an element of ARRAY specified by indices.");;PHD 1/2/87 Fixed ARRAY-TYPE-FROM-ELEMENT-TYPE  so we don't type canonicalize uselessly.;;PHD 1/2/87 Fixed  ARRAY-TYPE-FROM-ELEMENT-TYPE: added :test #'equal on the ASSOC second call (Defun ARRAY-TYPE-FROM-ELEMENT-TYPE (element-type);; given a common lisp type specified for the element type of an array, return an;; appropriate lispm-array-type.  (or (CDR (ASSOC element-type array-element-type-alist :test #'eq)) ;;eq for fast first pass.      (LET ((element-type (TYPE-CANONICALIZE element-type)))(OR (CDR (ASSOC element-type array-element-type-alist :test #'equal))    (COND ((SUBTYPEP element-type 'fixnum)   (COND ((SUBTYPEP element-type 'BIT) 'art-1b);common case ((SUBTYPEP element-type '(MOD #o20))  (IF (SUBTYPEP element-type '(MOD 4)) 'art-2b 'art-4b)) ((SUBTYPEP element-type '(MOD #o200000))  (IF (SUBTYPEP element-type '(MOD #o400)) 'art-8b 'art-16b)) ((SUBTYPEP element-type '(signed-byte #o20)) 'art-half-fix) (t 'art-q)))  ((SUBTYPEP element-type '(MOD #o40000000000 ))   'art-32b)  ((SUBTYPEP element-type 'STRING-CHAR) 'art-string)  ((SUBTYPEP element-type 'DOUBLE-FLOAT) 'art-double-float)  ((SUBTYPEP element-type 'SINGLE-FLOAT) 'art-single-float)  ((SUBTYPEP element-type 'COMPLEX)   (COND ((SUBTYPEP element-type '(COMPLEX double-float))  'art-complex-double-float) ((SUBTYPEP element-type '(COMPLEX single-float))  'art-complex-single-float) (t 'art-complex)))  (t 'art-q))))))(DEFUN array-canonicalize-type (type &aux foo)  (COND ((MEMBER type array-types :test #'EQ) type)((SETQ foo (POSITION type (THE list array-type-keywords) :test #'EQ)) (NTH foo array-types))((FIXNUMP type) (IF (NOT (ZEROP (LDB %%array-type-field type)))     (SETQ type (LDB %%array-type-field type))) (NTH type array-types))(t (SETQ type (array-type-from-element-type type)))))(DEFUN ARRAY-TYPE (ARRAY)  "Return the name of the array-type of ARRAY.The value is a symbol such as ART-Q."  (CHECK-ARG ARRAY ARRAYP "an array")  (NTH (%P-LDB-OFFSET %%ARRAY-TYPE-FIELD ARRAY 0) ARRAY-TYPES))(DEFUN array-element-type (ARRAY)  "Return a Common Lisp data type describing the objects that could be stored in array."  (OR (CAR (RASSOC (ARRAY-TYPE array) array-element-type-alist :test #'EQ))      t))(DEFVAR array-type-keywords nil  "List of keywords which have pnames matching the array type symbols.");; DEFVAR to NIL with a SETQ insures it will never be unbound.;; The SETQ now happens in installing packages.(DEFUN adjust-array (ARRAY new-dimensions &rest keyargs     &key &optional element-type     (initial-element nil initial-element-p)     (initial-contents nil initial-contents-p)     fill-pointer displaced-to displaced-index-offset)  "Alter dimensions, contents or displacedness of ARRAY.May modify ARRAY or forward it to a new array.  In either case ARRAY is returned.The dimensions are altered to be those in the list NEW-DIMENSIONS.DISPLACED-TO and DISPLACED-INDEX-OFFSET are used to make ARRAY be displaced. They mean the same as in MAKE-ARRAY.INITIAL-CONTENTS is as in MAKE-ARRAY. ARRAY's entire contents are initialized from this after its shape has been changed.  The old contents become irrelevant.If neither INITIAL-CONTENTS nor DISPLACED-TO is specified, the old contents of ARRAY are preserved.  Each element is preserved according to its subscripts.INITIAL-ELEMENT, if specified, is used to init any new elements created by the reshaping; that is, elements at subscripts which were previously out of bounds.  If this is not specified, NIL, 0 or 0.0 is used acc. to array type.ELEMENT-TYPE if non-NIL causes an error if ARRAY is not of the array type which MAKE-ARRAY would create given the same ELEMENT-TYPE.  Just an error check.FILL-POINTER, if specified, sets the fill pointer of array."  displaced-index-offset  (CHECK-ARG array arrayp "an array")  (WHEN (NUMBERP  new-dimensions)(SETQ  new-dimensions (LIST  new-dimensions)))  (UNLESS (= (LENGTH new-dimensions) (ARRAY-RANK array))    (FERROR nil "~S is the wrong number of dimensions for ~s."    new-dimensions array))  (WHEN element-type    (LET ((ARRAY-TYPE (array-type-from-element-type element-type)))      (DO () ((EQ (CAR (RASSOC array-type array-element-type-alist :test #'EQ))  (CAR (RASSOC (ARRAY-TYPE array) array-element-type-alist :test #'EQ))))(SETQ array (CERROR :new-argument nil 'wrong-type-argument    "The argument ~2G~S was ~1G~S, which is not an ~3G~A array."    `(ARRAY ,(OR (CAR (RASSOC array-type array-element-type-alist :test #'EQ)) t))    array 'ARRAY array-type)))))  (IF displaced-to      (IF (AND (ARRAY-DISPLACED-P array)       (EQ (NULL displaced-index-offset)   (NULL (array-index-offset array))))  (change-indirect-array array (ARRAY-TYPE array) new-dimensions displaced-to displaced-index-offset)  (STRUCTURE-FORWARD array     (APPLY 'MAKE-ARRAY new-dimensions    :leader-list (LIST-ARRAY-LEADER array)    :type (ARRAY-TYPE array) keyargs)))      (IF (= (ARRAY-RANK array) 1)  (LET ((old-len (ARRAY-TOTAL-SIZE array)))    (SETQ array (ZLC:ADJUST-ARRAY-SIZE array (CAR new-dimensions)))    (WHEN initial-element-p      (ARRAY-INITIALIZE array initial-element old-len (CAR new-dimensions))))  (array-grow-1 array new-dimensions initial-element-p initial-element)))  (IF initial-contents-p      (fill-array-from-sequences array initial-contents 0 0))  (IF fill-pointer      (SETF (FILL-POINTER array)    (IF (EQ fill-pointer t) (LENGTH array) fill-pointer)))  array)(DEFUN array-grow-1 (ARRAY dimensions initial-element-p initial-element     &aux (old-dims (ARRAY-DIMENSIONS array))     index new-array)  (PROG ();; Make the new array.(IF initial-element-p    (SETQ new-array (MAKE-ARRAY dimensions:area (%AREA-NUMBER array):type (ARRAY-TYPE array):initial-element initial-element:leader-length (ARRAY-LEADER-LENGTH array)))    (SETQ new-array (MAKE-ARRAY dimensions:area (%AREA-NUMBER array):type (ARRAY-TYPE array):leader-length (ARRAY-LEADER-LENGTH array))));; Copy the array leader.        (DO ((i 0 (1+ i))             (n (OR (ARRAY-LEADER-LENGTH array) 0) (1- n)))            ((ZEROP n))  (SETF (ARRAY-LEADER new-array i) (ARRAY-LEADER array i)));; Check for zero-size array, which the code below doesn't handle correctly(AND (DO ((l dimensions (CDR l)) (l1 old-dims (CDR l1))) ((NULL l) nil)       (AND (OR (ZEROP (CAR l)) (ZEROP (CAR l1)))    (RETURN t)))     (GO done));; Create a vector of fixnums to use as subscripts to step thru the arrays.(SETQ index (MAKE-LIST (LENGTH dimensions) :initial-element 0))        ;; Make the first increment of INDEX bring us to element 0 0 0 0..        (RPLACA index -1)     LOOP  ;; Boy, this is sure ugly and slow - somebody please redo this using ar-1-force;; Increment the vector of subscripts INDEX.        ;; Go to DONE if we have exhausted all elements that need copying.(DO ((i index (CDR i))     (o old-dims (CDR o))     (n dimensions (CDR n)))    ((NULL i) (GO done))  ;; Increment one index  (RPLACA i (1+ (CAR i)))  ;; and decide whether to "carry" to the next one.  (COND ((OR (>= (CAR i) (CAR o)) (>= (CAR i) (CAR n))) (RPLACA i 0))(t (RETURN nil))))(APPLY 'ZLC:ASET (APPLY 'AREF array index) new-array index)(GO loop)     done;; The contents have been copied.  Copy a few random things.(%P-DPB (%P-LDB %%array-named-structure-flag array)%%array-named-structure-flag new-array)(STRUCTURE-FORWARD array new-array)(RETURN new-array)))(DEFUN vector (&rest objects)  "Return a vector (1-dimensional array) whose elements are the objects."  (let* ((len (length objects)) (vector (if (simple-vector-size-p len)     (internal-make-simple-vector len art-q)     (make-array len))) (j 0))    (dolist (x objects  vector)      (setf (aref vector (prog1 j (incf j))) x))))(DEFUN fill-array (ARRAY size value) (ARRAY-INITIALIZE array value 0 size));Set all the elements of ARRAY to VALUE,;or all elements from START to END.;;Pat Hogan's fix 9/4/86;; 4-15-87 ab.  Fix for physical arrays and displaced-to-address arrays.(defun array-initialize (original-array value &optional (start 0) end  &aux forwarding-followed-array array (offset 0))  "Set all the elements of ARRAY to VALUE, or all elements from START to END.If END is NIL or not specified, the active length of ARRAY is used."  ;; Handle forwarded arrays.  (setq forwarding-followed-array (follow-structure-forwarding original-array))  (setq array forwarding-followed-array)  (unless end    (setq end (array-active-length array)))  (unless (<= 0 start end (array-total-size array))    (ferror () "START is ~S and END is ~S, for ~S." start end array))  (IF (< end (+ start 32.))      ;; If number of elements to be hacked is small, just do it      (do ((i start (1+ i)))  ((>= i end))(setf (ar-1-force array i) value))      (progn;; Handle indirect-to-array arrays by finding the array indirected to;; and updating the start and end indices if appropriate.(do (tem)    ((not (array-indirect-p array)))  (when (setq tem (array-index-offset array))    (incf offset tem))  (setq array (array-indirect-to array)))(if (OR (array-physical-p array)(AND (ARRAY-DISPLACED-P array)     (NOT (ARRAY-INDIRECT-P array))))    ;; If eventual target real array is physical or displaced to non-array,    ;; or if the array types of intermediate indirect arrays aren't compatible    ;; (which means the offsets could be wrong)    ;; just do original array by element.    (do ((i start (1+ i)))((>= i end))      (setf (ar-1-force forwarding-followed-array i) value))    ;; Otherwise, do it faster way...    (let* ((entries-per-q    (array-elements-per-q (%p-ldb %%array-type-field forwarding-followed-array)))  (bits-per-element    (array-bits-per-element (%p-ldb %%array-type-field forwarding-followed-array)))  (start (+ start offset))  (end (+ end offset))  (data-offset (array-data-offset array))  ;; Compute how many words are in the repeating unit that we replicate with %BLT.  ;; This is 1 word unless an element is bigger than that.  (blt-distance (if (plusp entries-per-q) 1 (- entries-per-q)))  ;; This is how many elements it takes to make BLT-DISTANCE words.  (q-boundary-elts (max 1 entries-per-q))  ;; We must deposit element by element until this element  ;; in order to make sure we have a full word of elements stored  ;; Beyond this, we can blt entire words.  (stop-element-by-element    (min end (* q-boundary-elts (1+ (ceiling start q-boundary-elts)))))  ;; We must stop our word-wise copying before this element number  ;; to avoid clobbering any following elements which are beyond END.  (end-word-wise (max start (* q-boundary-elts (floor end q-boundary-elts))))  ;; Compute index in words, wrt array data, of the first data word  ;; that we will not fill up an element at a time.  (uninitialized-data-offset    (+ data-offset (* blt-distance (ceiling stop-element-by-element q-boundary-elts))))  ;; Compute the length of the data in the array, in Qs, if caller didn't supply it.  (data-length    (if (plusp entries-per-q)(truncate end-word-wise entries-per-q)(* end-word-wise (- entries-per-q)))))     ;; Fill in any elements in an incomplete first word,     ;; plus one full word's worth.     ;; We must use the original array to store element by element,     ;; since the element size of the array indirected to may be different.     (do ((i start (1+ i))) ((= i stop-element-by-element))       (setf (ar-1-force forwarding-followed-array (- i offset)) value))     ;; Now fill in the elements in the incomplete last word.     (do ((i end-word-wise (1+ i))) ((>= i end))       (setf (ar-1-force forwarding-followed-array (- i offset)) value))     ;; Now copy the data word by word (or by two words for ART-DOUBLE-FLOAT!)     ;; There is no hope of passing %BLT pointers that are GC-safe.     (if (plusp (- data-length (- uninitialized-data-offset data-offset))) (without-interrupts   (if bits-per-element       ;; Numeric array.       (%blt (%make-pointer-offset dtp-fix array (- uninitialized-data-offset blt-distance)) (%make-pointer-offset dtp-fix array uninitialized-data-offset) (- data-length (- uninitialized-data-offset data-offset)) 1)       (progn (%blt-typed   (%make-pointer-offset dtp-fix array (- uninitialized-data-offset blt-distance))   (%make-pointer-offset dtp-fix array uninitialized-data-offset)   (- data-length (- uninitialized-data-offset data-offset)) 1) (when (eq 'art-q-list (array-type array))   (%p-store-cdr-code (aloc array (1- (array-total-size array)))      cdr-nil))))))))))  original-array)(DEFUN zlc:adjust-array-size (ARRAY new-index-length      &aux region current-data-length array-type-number       ndims entries-per-q new-data-length new-array       freed-array-locn freed-array-length      array-data-base long-array-bit current-index-length      array-data-base-relative-to-region-origin      max-short-index-length array-type)  "Make ARRAY larger or smaller.  NEW-INDEX-LENGTH is the new size.For multi-dimensional arrays, changes the last dimension (the one which varies slowest).If array displaced, adjust request refers to the displaced header, not pointed-to data.Making an array larger may forward it.  The value returned is the new array,not the old, forwarded one."  (CHECK-ARG array arrayp "an array")  (WITHOUT-INTERRUPTS;Disallow garbage collection (flipping), references; to the array, and allocation in the region.    (SETQ array (FOLLOW-STRUCTURE-FORWARDING array))    ;;By this point, ARRAY cannot be in oldspace    (IF (ZEROP (%P-LDB %%array-simple-bit array))(SETQ ndims (%P-LDB %%array-number-dimensions array)      long-array-bit (%P-LDB %%array-long-length-flag array)      current-index-length (IF (ZEROP long-array-bit)       (%P-LDB %%array-index-length-if-short array)       (%P-CONTENTS-OFFSET array 1))      max-short-index-length %array-max-short-index-length)(SETQ ndims 1      long-array-bit 0      current-index-length (%P-LDB %%array-index-length-if-simple array)      max-short-index-length %array-max-simple-index-length))    (SETQ array-data-base (+ (%MAKE-POINTER dtp-fix array);Safe since can't move now     LONG-ARRAY-BIT;Careful, this can be a negative number!     ndims)  region (%REGION-NUMBER array)  array-data-base-relative-to-region-origin  (%POINTER-DIFFERENCE array-data-base       (region-origin region))       array-type-number (%P-LDB %%array-type-field array)  entries-per-q (AREF (FUNCTION array-elements-per-q) array-type-number)  new-data-length (IF (PLUSP entries-per-q)      (CEILING new-index-length entries-per-q)      (* new-index-length (- entries-per-q)))  current-data-length (IF (PLUSP entries-per-q)  (CEILING current-index-length entries-per-q)  (* current-index-length (- entries-per-q))))    (COND ((AND (PLUSP (%P-LDB %%array-physical-bit array))(> new-index-length current-index-length))   (FERROR nil "Can't grow physical array ~s" array))  ((AND (PLUSP (%P-LDB %%array-displaced-bit array))(ZEROP (%P-LDB %%array-simple-bit array)));Displaced array   (SETQ current-index-length (%P-CONTENTS-OFFSET array-data-base 1))   (COND ((> new-index-length current-index-length)  (FERROR nil "Can't make displaced array ~S bigger" array)))   (%P-STORE-CONTENTS-OFFSET new-index-length array-data-base 1)   array)  ((AND     (<= new-data-length current-data-length);No new storage required     (NOT (AND (ZEROP long-array-bit);and length field will not overflow.       (> new-index-length max-short-index-length))))   (AND (EQ (SETQ array-type (ARRAY-TYPE array)) 'art-q-list)(%P-STORE-CDR-CODE-OFFSET   cdr-nil array-data-base (1- new-data-length)))   (COND ((= new-data-length current-data-length));No storage change;;;; No longer support "return-storage" facility with TGC.;;;; ((= (+ array-data-base-relative-to-region-origin;;current-data-length);Give back from end of region;;     (region-free-pointer region));;  (gc-reset-free-pointer region;; (+ array-data-base-relative-to-region-origin;;    new-data-length))) (T;Fill hole in region with an ART-32B array  (%gc-scav-reset region);Make scavenger forget about this region  (SETQ freed-array-locn(%MAKE-POINTER-OFFSET dtp-fix array-data-base new-data-length))  (COND ((OR (EQ ARRAY-TYPE 'ART-Q) (EQ ARRAY-TYPE 'ART-Q-LIST) (EQ ARRAY-TYPE 'ART-STACK-GROUP-HEAD))    ;;    ;; STORE NIL IN THE Q'S BEING RELEASED IF THEY ARE    ;; BOXED SO TGC CAN SEE THAT THEY ARE NOT USED.    ;;    (%P-STORE-CONTENTS FREED-ARRAY-LOCN NIL)    (%BLT-TYPED FREED-ARRAY-LOCN   (1+ FREED-ARRAY-LOCN)   FREED-ARRAY-LENGTH   1))  (T     ;; FORCE THE HEADER SLOT TO HAVE A BOXED DTP-FIX     ;; FOR THE CODE BELOW     (%P-DPB        DTP-FIX %%Q-DATA-TYPE FREED-ARRAY-LOCN)))  (COND ((<= (SETQ freed-array-length   (1- (- current-data-length new-data-length)))     %array-max-simple-index-length) (%P-STORE-TAG-AND-POINTER freed-array-locn dtp-array-header    (+ ;; not on simple array-dim-mult     art-32b     freed-array-length)) (%P-DPB 1 %%array-simple-bit freed-array-locn))(t (%P-STORE-TAG-AND-POINTER freed-array-locn dtp-array-header      (+ array-dim-mult art-32barray-long-length-flag))   (%P-STORE-CONTENTS-OFFSET (1- freed-array-length)     freed-array-locn     1)))))   (IF (ZEROP long-array-bit)       (IF (ZEROP (%P-LDB %%array-simple-bit array))   (%P-DPB new-index-length %%array-index-length-if-short array)   (%P-DPB new-index-length %%array-index-length-if-simple array))       (%P-STORE-CONTENTS-OFFSET new-index-length array 1))   array)  ;; Need increased storage.  Either make fresh copy or extend existing copy.  (t   (SETQ new-array (MAKE-ARRAY (IF (= ndims 1) new-index-length   (LET ((dims (ARRAY-DIMENSIONS array)))     (RPLACA (LAST dims) 1)     (RPLACA (LAST dims)     (TRUNCATE new-index-length       (APPLY 'TIMES dims)))     dims))       :area (%AREA-NUMBER array)       :type (AREF (FUNCTION array-types) array-type-number)       :leader-length (ARRAY-LEADER-LENGTH array)))   (COPY-ARRAY-CONTENTS-AND-LEADER array new-array)   (%P-DPB (%P-LDB %%array-named-structure-flag array)   %%array-named-structure-flag new-array)   (STRUCTURE-FORWARD array new-array)   new-array)  )))(DEFUN adjustable-array-p (ARRAY)  "A Common Lisp function which returns T if ARRAY is an adjustable array (ie may haveADJUST-ARRAY applied to it) This is true for all arrays on the Lisp machine."  (ARRAYP array));; Subroutine used by EQUALP when args are arrays (of same rank).(DEFUN equalp-array (array1 array2)  (AND (LET ((rank (ARRAY-RANK array1))) (DO ((i 1 (1+ i)))     ((= i rank) t)   (UNLESS (= (%P-CONTENTS-OFFSET array1 i) (%P-CONTENTS-OFFSET array2 i))     (RETURN nil))))       (LET ((len (LENGTH array1))) (AND (= len (LENGTH array2))      (DOTIMES (i len t)(UNLESS (EQUALP (ar-1-force array1 i) (ar-1-force array2 i))  (RETURN nil)))))))(DEFUN array-dimensions (ARRAY &aux index-length rank long-array-p dims (product 1))  "Return a list of the dimensions of array."  (WHEN (SYMBOLP array) (SETQ array (SYMBOL-FUNCTION array)))  (CHECK-ARG array arrayp "an array")  (SETQ array (FOLLOW-STRUCTURE-FORWARDING array));SHOULD CHECK FOR INVZ  (IF (PLUSP (%P-LDB %%array-simple-bit array))      (LIST (%P-LDB %%array-index-length-if-simple array))      (PROGN(SETQ rank (%P-LDB %%array-number-dimensions array)      long-array-p (%P-LDB %%array-long-length-flag array))(SETQ index-length (COND ((= 0 (%P-LDB %%array-displaced-bit array))  (COND ((= 1 long-array-p) (%P-POINTER-OFFSET array 1))(t (%P-LDB %%array-index-length-if-short array)))) ((%P-POINTER-OFFSET array (1+ (+ rank long-array-p))))))(IF (ZEROP rank)    nil    (PROGN      (DO ((n rank (1- n))   (i (1+ long-array-p) (1+ i))   dim)  ((<= n 1))(SETQ dim (%P-POINTER-OFFSET array i))(SETQ product (* product dim))(SETQ dims (CONS dim dims)))      (CONS (COND ((ZEROP product) 0)  (t (TRUNCATE index-length product)))    dims))    ))));Returns the number of bits that fit in an element of an array.(DEFUN array-element-size (ARRAY)  "Return the number of bits per element of array."  (OR (AREF #'ARRAY-BITS-PER-ELEMENT (%P-LDB-OFFSET %%array-type-field array 0))      25.));Q-type, assume going to use unsigned fixnums.(DEFUN zlc:array-push-extend (ARRAY data &optional extension  &aux (inhibit-scheduling-flag t))  "Add the new element DATA to the end of ARRAY, making ARRAY larger if needed.EXTENSION says how many elements to add; the default is a fractionof the existing size.  ARRAY must have a fill pointer."    (COND ((VECTOR-PUSH data array))  (t (ZLC:ADJUST-ARRAY-SIZE array (+ (ARRAY-TOTAL-SIZE array) ;; If amount to extend by not specified, ;; try to guess a reasonable amount (COND (extension)       ((< (%STRUCTURE-TOTAL-SIZE     (FOLLOW-STRUCTURE-FORWARDING array))   page-size)(MAX (ARRAY-TOTAL-SIZE array) 100))       (t (TRUNCATE (ARRAY-TOTAL-SIZE array) 4)))))     (VECTOR-PUSH data array))))(DEFUN vector-push-extend (data vector &optional extension)  "Add the new element DATA to the end of VECTOR, making VECTOR larger if needed.EXTENSION says how many elements to add; the default is a fractionof the existing size.  VECTOR must have a fill pointer."  (WITHOUT-INTERRUPTS    (COND ((VECTOR-PUSH data vector))  (t (ZLC:ADJUST-ARRAY-SIZE vector (+ (ARRAY-TOTAL-SIZE vector)   ;; If amount to extend by not specified,   ;; try to guess a reasonable amount   (COND (extension) ((< (%STRUCTURE-TOTAL-SIZE       (FOLLOW-STRUCTURE-FORWARDING vector))     page-size)  (MAX (ARRAY-TOTAL-SIZE vector) 100)) (t (TRUNCATE (ARRAY-TOTAL-SIZE vector) 4)))))     (VECTOR-PUSH data vector)))))(DEFUN array-physical-p (ARRAY)  "T if ARRAY is a physical array."    (PLUSP (%P-LDB-OFFSET %%array-physical-bit array 0)))(DEFUN array-displaced-p (ARRAY)  "T if ARRAY is a displaced array."  (AND (ZEROP (%P-LDB-OFFSET %%array-simple-bit array 0))       (PLUSP (%P-LDB-OFFSET %%array-displaced-bit array 0))))(DEFUN array-indirect-p (ARRAY)  "T if ARRAY is displaced to another array."  (let ((hdr (%P-LDB-OFFSET %%Q-Pointer array 0)))    (AND (PLUSP  (LDB %%array-displaced-bit hdr)) (ZEROP  (LDB %%array-simple-bit hdr)) (ZEROP  (LDB %%array-physical-bit hdr)) (ARRAYP (%P-CONTENTS-OFFSET array (LDB %%array-number-dimensions hdr))))));This is random, maybe it should be flushed.(DEFUN array-indexed-p (ARRAY)  "T if ARRAY is indexed to another array and has an index offset."  (let ((hdr (%P-LDB-OFFSET %%Q-Pointer array 0)))    (AND (PLUSP (LDB %%array-displaced-bit hdr)) (ZEROP (LDB %%array-simple-bit hdr)) (ZEROP (LDB %%array-physical-bit hdr)) (ARRAYP (%P-CONTENTS-OFFSET array (LDB %%array-number-dimensions hdr))) (= (LDB %%array-index-length-if-short hdr) 3) )))(DEFUN array-indirect-to (ARRAY  &aux (offset (%P-LDB-OFFSET %%array-number-dimensions array 0)))  "Given an indirect array, return the array it indirects to.  Otherwise nil."  (let ((hdr (%P-LDB-OFFSET %%Q-Pointer array 0)))    (AND (PLUSP (LDB %%array-displaced-bit hdr)) (ZEROP (LDB %%array-simple-bit hdr)) (ZEROP (LDB %%array-physical-bit hdr)) (ARRAYP (%P-CONTENTS-OFFSET array offset)) (%P-CONTENTS-OFFSET array offset))))(DEFUN array-index-offset (ARRAY &aux (offset (%P-LDB-OFFSET %%array-number-dimensions array 0)))  "Given an array with an index offset, return that.  Otherwise nil."  (let ((hdr (%P-LDB-OFFSET %%Q-Pointer array 0)))    (AND (PLUSP (LDB %%array-displaced-bit hdr)) (ZEROP (LDB %%array-simple-bit hdr)) (ZEROP (LDB %%array-physical-bit hdr)) (ARRAYP (%P-CONTENTS-OFFSET array offset)) (= (LDB %%array-index-length-if-short hdr) 3) (%P-CONTENTS-OFFSET array (+ 2 offset)))))(DEFUN make-array-into-named-structure (ARRAY &optional nss)  (COND ((ARRAYP array) (WHEN nss   (IF (ARRAY-HAS-LEADER-P array)       (SETF (ARRAY-LEADER array 1) nss)     (SETF (AREF array 0) nss))) (%P-DPB-OFFSET 1 %%array-named-structure-flag array 0) array)(t (FERROR nil "~S is not an array" array))));;;PHD 4/3/87 Fixed bit-... functions. Case where result-bit-array it T.(DEFUN bit-and (bit-array1 bit-array2 &optional result-bit-array)  "Returns the bitwise AND of all the two bit arrays,The result is stored into RESULT-BIT-ARRAY, or returned as a new bit arrayif RESULT-BIT-ARRAY is NIL.  If it is T, BIT-ARRAY1 is used for the result."  (UNLESS (arrayp result-bit-array)    (IF (EQ result-bit-array t)(SETQ result-bit-array bit-array1)      (SETQ result-bit-array (copy-object bit-array2))))  (bit-array-logical-op boole-and bit-array1 bit-array2 result-bit-array)  result-bit-array)(DEFUN bit-ior (bit-array1 bit-array2 &optional result-bit-array)  "Returns the bitwise OR of all the two bit arrays,The result is stored into RESULT-BIT-ARRAY, or returned as a new bit arrayif RESULT-BIT-ARRAY is NIL.  If it is T, BIT-ARRAY1 is used for the result."  (UNLESS (arrayp result-bit-array)    (IF (EQ result-bit-array t)(SETQ result-bit-array bit-array1)      (SETQ result-bit-array (copy-object bit-array2))))  (bit-array-logical-op boole-ior bit-array1 bit-array2 result-bit-array)  result-bit-array)(DEFUN bit-xor (bit-array1 bit-array2 &optional result-bit-array)  "Returns the bitwise XOR of all the two bit arrays,The result is stored into RESULT-BIT-ARRAY, or returned as a new bit arrayif RESULT-BIT-ARRAY is NIL.  If it is T, BIT-ARRAY1 is used for the result."  (UNLESS (arrayp result-bit-array)    (IF (EQ result-bit-array t)(SETQ result-bit-array bit-array1)      (SETQ result-bit-array (copy-object bit-array2))))  (bit-array-logical-op boole-xor bit-array1 bit-array2 result-bit-array)  result-bit-array)(DEFUN bit-eqv (bit-array1 bit-array2 &optional result-bit-array)  "Returns the bitwise EQV of all the two bit arrays,The result is stored into RESULT-BIT-ARRAY, or returned as a new bit arrayif RESULT-BIT-ARRAY is NIL.  If it is T, BIT-ARRAY1 is used for the result."  (UNLESS (arrayp result-bit-array)    (IF (EQ result-bit-array t)(SETQ result-bit-array bit-array1)(SETQ result-bit-array (copy-object bit-array2))))  (bit-array-logical-op boole-eqv bit-array1 bit-array2 result-bit-array)  result-bit-array)(DEFUN bit-nand (bit-array1 bit-array2 &optional result-bit-array)  "Returns the bitwise NAND of all the two bit arrays,The result is stored into RESULT-BIT-ARRAY, or returned as a new bit arrayif RESULT-BIT-ARRAY is NIL.  If it is T, BIT-ARRAY1 is used for the result."  (UNLESS (arrayp result-bit-array)    (IF (EQ result-bit-array t)(SETQ result-bit-array bit-array1)      (SETQ result-bit-array (copy-object bit-array2))))  (bit-array-logical-op boole-nand bit-array1 bit-array2 result-bit-array)  result-bit-array)(DEFUN bit-nor (bit-array1 bit-array2 &optional result-bit-array)  "Returns the bitwise NOR of all the two bit arrays,The result is stored into RESULT-BIT-ARRAY, or returned as a new bit arrayif RESULT-BIT-ARRAY is NIL.  If it is T, BIT-ARRAY1 is used for the result."  (UNLESS (arrayp result-bit-array)    (IF (EQ result-bit-array t)(SETQ result-bit-array bit-array1)      (SETQ result-bit-array (copy-object bit-array2))))  (bit-array-logical-op boole-nor bit-array1 bit-array2 result-bit-array)  result-bit-array)(DEFUN bit-andc1 (bit-array1 bit-array2 &optional result-bit-array)  "Returns the bitwise AND of BIT-ARRAY2 with the complement of BIT-ARRAY1.The result is stored into RESULT-BIT-ARRAY, or returned as a new bit arrayif RESULT-BIT-ARRAY is NIL.  If it is T, BIT-ARRAY1 is used for the result."  (UNLESS (arrayp result-bit-array)    (IF (EQ result-bit-array t)(SETQ result-bit-array bit-array1)      (SETQ result-bit-array (copy-object bit-array2))))  (bit-array-logical-op boole-andc1 bit-array1 bit-array2 result-bit-array)  result-bit-array)(DEFUN bit-andc2 (bit-array1 bit-array2 &optional result-bit-array)  "Returns the bitwise AND of BIT-ARRAY1 with the complement of BIT-ARRAY2.The result is stored into RESULT-BIT-ARRAY, or returned as a new bit arrayif RESULT-BIT-ARRAY is NIL.  If it is T, BIT-ARRAY1 is used for the result."  (UNLESS (arrayp result-bit-array)    (IF (EQ result-bit-array t)(SETQ result-bit-array bit-array1)      (SETQ result-bit-array (copy-object bit-array2))))  (bit-array-logical-op boole-andc2 bit-array1 bit-array2 result-bit-array)  result-bit-array)(DEFUN bit-orc1 (bit-array1 bit-array2 &optional result-bit-array)  "Returns the bitwise OR of BIT-ARRAY2 with the complement of BIT-ARRAY1.The result is stored into RESULT-BIT-ARRAY, or returned as a new bit arrayif RESULT-BIT-ARRAY is NIL.  If it is T, BIT-ARRAY1 is used for the result."  (UNLESS (arrayp result-bit-array)    (IF (EQ result-bit-array t)(SETQ result-bit-array bit-array1)      (SETQ result-bit-array (copy-object bit-array2))))  (bit-array-logical-op boole-orc1 bit-array1 bit-array2 result-bit-array)  result-bit-array)(DEFUN bit-orc2 (bit-array1 bit-array2 &optional result-bit-array)  "Returns the bitwise OR of BIT-ARRAY1 with the complement of BIT-ARRAY2.The result is stored into RESULT-BIT-ARRAY, or returned as a new bit arrayif RESULT-BIT-ARRAY is NIL.  If it is T, BIT-ARRAY1 is used for the result."  (UNLESS (arrayp result-bit-array)    (IF (EQ result-bit-array t)(SETQ result-bit-array bit-array1)      (SETQ result-bit-array (copy-object bit-array2))))  (bit-array-logical-op boole-orc2 bit-array1 bit-array2 result-bit-array)  result-bit-array)(DEFUN bit-array-logical-op (alu-function bv1 bv2 bv-out)  (DOTIMES (i (ARRAY-TOTAL-SIZE bv-out))    (SETF (AR-1-FORCE bv-out i)  (BOOLE alu-function (AR-1-FORCE bv1 i) (AR-1-FORCE bv2 i))))  bv-out)(DEFUN bit-not (bit-array &optional result-bit-array)  "Returns a bit array containing the complements of the elements of bit-array."  (UNLESS (arrayp result-bit-array)    (IF (EQ result-bit-array t)(SETQ result-bit-array bit-array)      (SETQ result-bit-array (copy-object bit-array))))  (DOTIMES (i (ARRAY-TOTAL-SIZE bit-array))    (SETF (AR-1-FORCE result-bit-array i) (LOGNOT (AR-1-FORCE bit-array i))))  result-bit-array)(DEFUN zlc:make-pixel-array (width height &rest options)  "Make a pixel array of WIDTH by HEIGHT.  You must specify :TYPE as in MAKE-ARRAY.This will create an array of the appropriate shape and knows whetherthe height is supposed to be the first dimension or the second.Access the resulting array with AR-2-REVERSE and AS-2-REVERSE to make surethat accessing also is independent of array dimension order."  (APPLY 'MAKE-ARRAY (LIST height width) options))(DEFUN zlc:pixel-array-width (ARRAY)  "Return the width in pixels of an array of pixels.The width is the dimension which varies more faster."  (ARRAY-DIMENSION array 1))(DEFUN zlc:pixel-array-height (ARRAY)  "Return the height in pixels of an array of pixels.The height is the dimension which varies more slowly."  (ARRAY-DIMENSION array 0 ));UNDOES (ARRAY-PUSH ARRAY <DATA>) AND RETURNS <DATA>(DEFUN vector-pop (ARRAY)  "Returns the last used element of ARRAY, and decrements the fill pointer.For an ART-Q-LIST array, the cdr codes are updated so that the overlayed listno longer contains the element removed. Signals an error if ARRAY is empty/(has fill-pointer 0)"   (WITHOUT-INTERRUPTS       (LET ((index (1- (FILL-POINTER array)));1- because fill-pointer is # active elements  (ARRAY-TYPE (AREF #'ARRAY-TYPES (%P-LDB-OFFSET %%array-type-field array 0)))  val)      (WHEN (MINUSP index)(FERROR nil "~S overpopped" array))      (SETQ val (AREF array index))      (SETF (FILL-POINTER array) index)      (WHEN (AND (EQ array-type 'art-q-list) (NOT (ZEROP index)))(%P-STORE-CDR-CODE (ALOC array (1- index)) cdr-nil))      val)))(DEFF zlc:array-pop 'VECTOR-POP);;PHD for DJ 1/30/87 Replaced (apply #'* .. by a loop.(DEFUN change-indirect-array (ARRAY type dimlist displaced-p index-offset      &aux index-length ndims indirect-length tem   old-ndims old-indirect-length)  "Change an indirect array ARRAY's type, size, or target pointed at.TYPE specifies the new array type, DIMLIST its new dimensions,DISPLACED-P the target it should point to (array, locative or fixnum),INDEX-OFFSET the new offset in the new target." ;;; phd 10/16/85 remove calls to eval1 and suppressed the reverse on dimlist  (CHECK-TYPE array array)  (OR (= (%P-LDB-OFFSET %%array-displaced-bit array 0) 1)      (FERROR nil "~S is not a displaced array." array))  (CHECK-ARG displaced-p (OR (ARRAYP displaced-p) (FIXNUMP displaced-p)     (LOCATIVEP displaced-p))     "an array or virtual address to indirect to")  (CHECK-ARG TYPE;TEM gets the numeric array type     (SETQ tem (COND ((NUMBERP type) (LDB %%array-type-field type))     ((POSITION type (THE list array-types) :test #'EQ))))     "an array type")  (CHECK-ARG index-offset (OR (NULL index-offset) (FIXNUMP index-offset)) "A fixnum or nil")  (SETQ type tem)  (IF (CONSP dimlist)      (progn(SETQ ndims 0      index-length 1)(dolist (dim dimlist)  (setf index-length (* index-length dim))  (incf ndims)))      (SETQ ndims 1 index-length dimlist))  (SETQ indirect-length (IF index-offset 3 2)old-ndims (%P-LDB-OFFSET %%array-number-dimensions array 0)old-indirect-length (%P-LDB-OFFSET %%array-index-length-if-short array 0))  (OR (= ndims old-ndims)      (FERROR nil "Attempt to change the number of dimensions from ~D to ~d."          old-ndims ndims))  (OR (= indirect-length old-indirect-length)      (FERROR nil "Attempt to add or remove index-offset."))  (%P-DPB-OFFSET type %%array-type-field array 0)  (AND (CONSP dimlist)       (SETQ dimlist (CDR dimlist))       (DO ((n ndims (1- n)))   ((< n 2)) (%P-STORE-CONTENTS-OFFSET (CAR dimlist) array (1- n)) (SETQ dimlist (CDR dimlist))))  (%P-STORE-CONTENTS-OFFSET displaced-p array ndims)  (%P-STORE-CONTENTS-OFFSET index-length array (1+ ndims))  (WHEN index-offset    (%P-STORE-CONTENTS-OFFSET index-offset array (+ ndims 2)))  array);; the following two definitions depend heavily on the length and the ordering of ARRAY-TYPES;; defined in QCOM(Deftype ARRAY-TYPES-TYPESPEC ()    ;; this is for checking the lispm-array-type for validity and expands to (INTEGER 1. (21.)).  `(integer 1 (21.)))    ;; (length array-types) = 21.(Deftype DISPLACED-ARRAY-TYPES-TYPESPEC ()    "this is for checking the lispm-array-type for validity as a DISPLACED array and expands to (INTEGER 1. 6)."  `(integer 1. 6.))      ;; 1-6 correspond to art1b,art2b,...,art32b arrays;;PHD  1/30/87 return length of 1 for null-dimension arrays.;;PHD for DJ 1/30/87 Replaced (apply #'* .. by a loop.(Defun COMPUTE-RANK-AND-TOTAL-SIZE (dimensions);; convert a non-negative fixnum or a list of fixnums to a pair corresponding to;; the rank (dimensionality) and total length of a would-be array  (multiple-value-bind (rank total-size)      (eTYPECASE dimensions((integer 0 (16777215.)) (VALUES 1 dimensions)) (null (values 0 1 ))(cons (let ((size 1)    (length 0))(dolist (dim dimensions)  (setf size (* size dim))  (incf length))  (values length size))))    (UNLESS (< rank array-rank-limit)      (ERROR T "dimension list ~s must indicate less than ~d dimensions~%" dimensions array-rank-limit))    (UNLESS (TYPEP total-size '(integer 0 (16777215.)))      (ERROR T "total size ~d is way too large; see ARRAY-TOTAL-SIZE-LIMIT~%" total-size))    (VALUES rank total-size)));;;PHD 2/13/87 Added support for obsolete types.(Defun COMPUTE-LISPM-ARRAY-TYPE (type) ;; Canonicalize <type>, some kind of Lispm array type, to a fixnum between 1 and 20 (inclusive).;; Thus (compute-lispm-array-type 'art-q) = ;;      (compute-lispm-array-type art-q) =;;      (compute-lispm-array-type 3670016) =    (NOTE: the value of the symbol ART-Q is 3670016);;      (compute-lispm-array-type :art-q) =;;      (compute-lispm-array-type 7) = 7  (declare (inline COMPUTE-LISPM-ARRAY-TYPE ))  (eTYPECASE type    (fixnum     (LET* ((type-num (LDB %%array-type-field type)) ;; extract bits in case already shifted ...    (real-type (IF (ZEROP type-num) type type-num)))        (IF (TYPEP real-type 'array-types-typespec)    real-type   (ERROR t "number ~d does not correspond to a valid array type~%" type))))    (symbol     (OR (POSITION type (The list array-types) :test #'EQ) (POSITION type (The list array-type-keywords) :test #'EQ) (POSITION (car (rassoc type obsolete-array-types :test #'eq)) (The list array-types) :test #'EQ) (ERROR T "invalid symbol ~s used as an array type~%" type)))))(Defun COMPUTE-NUMBER-OF-QS (lispm-array-type total-size);; given the lispm-array-type and the number of items to be in the (data-portion of the) array, compute;; the number of q's which are required to hold these items.;; Note <entries-per-q>  is positive if there are 1 or more entries per Q and negative;; if there are more than one Qs per entry.  (declare (inline COMPUTE-NUMBER-OF-QS))  (LET ((entries-per-q (ARRAY-ELEMENTS-PER-Q lispm-array-type)))    (IF (PLUSP entries-per-q)(CEILING total-size entries-per-q)(* total-size (- entries-per-q)))))(Defun INTERNAL-MAKE-SIMPLE-VECTOR (length lispm-array-type &OPTIONAL leader-length area);; IF possible, create a simple array of specified length, type , leader and in the;; proper area. This is called from MAKE-ARRAY and INTERNAL-MAKE-VECTOR.;; <data-length> is also returned for compatibility with MAKE-ARRAY.  (declare (inline COMPUTE-NUMBER-OF-QS COMPUTE-LISPM-ARRAY-TYPE ))  (CHECK-TYPE length (Satisfies SIMPLE-VECTOR-SIZE-P) "a suitable size for a simple vector")  (LET* ((type          (COMPUTE-LISPM-ARRAY-TYPE lispm-array-type)) (data-length   (COMPUTE-NUMBER-OF-QS type length)) (array-header    (%LOGDPB (IF leader-length 1 0) %%array-leader-bit    (%logdpb 1 %%array-number-dimensions       (%LOGDPB type %%array-type-field      (%LOGDPB 1 %%array-simple-bit length))))) (qs-in-leader (IF leader-length (+ 2 leader-length) 0)) (vector   (%ALLOCATE-AND-INITIALIZE-ARRAY      array-header     length     (OR leader-length 0)     area     (+ 1 qs-in-leader data-length))) )    (VALUES vector data-length)))(DEFUN make-array (dimensions  &key   type   element-type    initial-element   initial-value    ;; Same as initial-element - included for zetalisp compatability   initial-contents   adjustable       ;;lispm arrays are ALWAYS adjustable   fill-pointer   displaced-to   displaced-to-physical-address   displaced-index-offset   leader-length   leader-list   area   named-structure-symbol   )  "Create an array of size DIMENSIONS (a number or list of numbers).The keywords are as follows::TYPE - specify array type, controlling type of elements allowed.  Default is ART-Q. ART-Q (any elements), ART-Q-LIST (any elements, and the contents looks like a list), ART-STRING (elements 0 through 377, printed with quotes), ART-FAT-STRING (16 bit unsigned elements, printed with quotes), ART-1B (elements 0 and 1), ART-2B (elements 0 thru 3), ART-4B, ART-8B, ART-16B, ART-32B (32-bit unsigned elements), ART-SINGLE-FLOAT (elements any single precision float), ART-DOUBLE-FLOAT (elements any double precision float), ART-COMPLEX (elements any number including complex numbers), ART-COMPLEX-SINGLE-FLOAT (elements complex numbers composed of two single precision floats), ART-COMPLEX-DOUBLE-FLOAT (elements complex numbers composed of two double precision floats), ART-HALF-FIX (16 bit signed fixnum elements), ART-FIX (elements any fixnum), ART-STACK-GROUP-HEAD, ART-REGULAR-PDL, ART-SPECIAL-PDL (parts of stack groups).:ELEMENT-TYPE - specify array type by specifying Common Lisp data type of elements allowed.  For example, an :ELEMENT-TYPE of (MOD 4) would get an ART-2B array.:AREA - specify area to create the array in.:LEADER-LENGTH - specify number of elements of array leader to make.:LEADER-LIST - list whose elements are used to initialize the leader.:FILL-POINTER - specify initial fill pointer value (ARRAY-ACTIVE-LENGTH of the array). Requests a leader of length 1 and specifies the contents of the slot.:INITIAL-ELEMENT - value used to initialize all elements of the array.:DISPLACED-TO - array, locative or fixnum specifying address of data that this array should overlap.:DISPLACED-INDEX-OFFSET - if displaced to another array, this specifies which element of that array should correspond to element 0 of the new one.:NAMED-STRUCTURE-SYMBOL - if not NIL, specifies a named structure symbol to be stored in the array, which should have its named-structure bit set.:INITIAL-CONTENTS - value is a sequence of sequences of sequences... where the leaves are the values to initialize the array from. The top level of sequence corresponds to the most slowly varying subscript."  (DECLARE (IGNORE adjustable)  ;; all Lispm arrays are adjustable   (inline COMPUTE-NUMBER-OF-QS))  (LET (n-dimensions        ;; number of dimensions (<= 7)index-length        ;; n1*n2*...*nM where nJ is the upper index of each dimensionlong-length-flag    ;; set if index-length requires more than 10 bitsarray-type          ;; the type of array to be created - integer 1 through 20data-length         ;; the number of Q's in the arrayqs-in-leader        ;; number of Q's in the leaderarray-header    ;; The array headerthe-array           ;; the star of our little show(displaced-p (OR displaced-to displaced-to-physical-address)))    ;;  begin by processing those options needed to create the array - watch for conflicts arising from ,e.g.;;  using a Common Lisp keyword and a Lispm keyword with a similar function. Once the array is created,;;  perform the initializations specified by the remaining keywords    ;;  process DIMENSIONS - setting up n-dimensions and index-length        (MULTIPLE-VALUE-SETQ (n-dimensions index-length) (COMPUTE-RANK-AND-TOTAL-SIZE dimensions))        ;;  process DISPLACED-TO and DISPLACED-TO-PHYSICAL-ADDRESS - the latter can restrict the specification of array type        (WHEN displaced-p      (COND (displaced-to     (WHEN displaced-to-physical-address       (FERROR nil "specifying two types of displacement ~s and ~s for an array is illegal"       displaced-to displaced-to-physical-address))     (UNLESS (ARRAYP displaced-to)       (IF (OR type (NOT element-type)) ;; If zetalisp type is specified, or using the default type  - Patch-2-76   (UNLESS (OR (INTEGERP displaced-to) (LOCATIVEP displaced-to))     (FERROR nil "DISPLACED-TO value must be an array, an integer or a locative - ~  ~s not admissible" displaced-to))   (FERROR nil "DISPLACED-TO value must be an array - ~s not admissible" displaced-to)))     (WHEN displaced-index-offset       (UNLESS (AND (INTEGERP displaced-index-offset) (>= displaced-index-offset 0)) (FERROR nil "DISPLACED-INDEX-OFFSET value must be a non-negative integer - ~s not admissible" displaced-index-offset))))    (t  ;; displaced-to-physical-address  ;; ask paul about validation for value     (WHEN displaced-index-offset       (FERROR nil "a physical array may not have a displaced-index-offset")))))    ;;  process TYPE and ELEMENT-TYPE -setting array-type         (SETQ array-type  ;; this is a fixnum between 1 and 20 (inclusive on both ends)  (COND     ((AND type element-type) (ERROR nil "illegal to use both TYPE and ELEMENT-TYPE~%"))    (type (COMPUTE-LISPM-ARRAY-TYPE type))                                                 ;; Zetalisp    (element-type (COMPUTE-LISPM-ARRAY-TYPE (ARRAY-TYPE-FROM-ELEMENT-TYPE element-type)))  ;; Common Lisp    (t (LDB %%array-type-field art-q))  ;; else defaults to art-q (compiler can constant-fold expression)    ))        ;; test array-type for validity if displaced array desired    (WHEN displaced-to-physical-address(UNLESS (TYPEP array-type 'DISPLACED-ARRAY-TYPES-TYPESPEC)  (FERROR nil "illegal type ~s for :DISPLACED-TO-PHYSICAL-ADDRESS array" (OR type element-type))))    (WHEN (AND displaced-to (ARRAYP displaced-to)       (NOT (= array-type (%P-LDB-offset %%array-type-field displaced-to 0)))       (OR ;; don't allow a typed array to be displaced to an untyped array.      - Patch-2-76 (= array-type (LDB %%array-type-field art-q)) ;; are there any other types that need to be checked? (= array-type (LDB %%array-type-field art-q-list)))       (not (OR ;; DO allow a typed array to be displaced to a different kind of typed array      (= (%P-LDB-offset %%ARRAY-TYPE-FIELD displaced-to 0) (LDB %%array-type-field art-q-list))      (= (%P-LDB-offset %%ARRAY-TYPE-FIELD displaced-to 0) (LDB %%array-type-field art-q)))))      (FSIGNAL "illegal type specifier ~s doesn't match displaced-to type ~s~@                Its dangerous to displace a typed array to an untyped array."        ; - Patch-2-76       (OR type element-type 'art-q) (type-of displaced-to)))        ;;  process LEADER-LENGTH,LEADER-LIST, FILL-POINTER and NAMED-STRUCTURE-SYMBOL keywords to see if a ;;  leader is required and/or desired        (WHEN leader-length      (UNLESS (TYPEP leader-length '(INTEGER 1 *))(FERROR nil "illegal :LEADER-LENGTH specification ~s . It must be a positive integer." leader-length)))        (WHEN fill-pointer      (WHEN (EQ fill-pointer t)(SETQ fill-pointer index-length))      (UNLESS (TYPEP fill-pointer '(INTEGER 0 *))(FERROR nil "illegal :FILL-POINTER specification ~s" fill-pointer))      (UNLESS leader-length (SETQ leader-length 1)))        (WHEN leader-list      (UNLESS (LISTP leader-list)(FERROR nil "illegal :LEADER-LIST specification ~s. It must be a list." leader-list))      (COND ((AND leader-length (> (LENGTH leader-list) leader-length))     (FERROR nil ":LEADER-LIST ~S has length greater than :LEADER-LIST ~s" leader-list leader-length))    ((NULL leader-length) (SETQ leader-length (LENGTH leader-list))))      )        (WHEN (AND  named-structure-symbol leader-length(< leader-length 1))      (FERROR nil "Leader-length must be at least two for a named structure with leader"))        (SETQ qs-in-leader (IF leader-length (+ 2 leader-length) 0))    ;;  now create the array after initially sketching an array header word    ;;PHD fixed null-dimension arrays, they should not be simple.    (COND ((OR (/= n-dimensions 1)       displaced-p       (> index-length %array-max-simple-index-length))   ;; Not a simple array   (WHEN (AND (> index-length %array-max-short-index-length) (NOT displaced-p))     (SETQ long-length-flag t))   (SETQ array-header (%LOGDPB n-dimensions %%array-number-dimensions    (%LOGDPB array-type %%array-type-field   (IF leader-length (%LOGDPB 1 %%array-leader-bit 0) 0))))   (SETQ array-header (COND (displaced-p;; Array is displaced; turn on the bit, and the array is 2 long;; plus one for the index-offset if any.(+ (%LOGDPB 1 %%array-displaced-bit array-header)   (IF displaced-to-physical-address       (%LOGDPB 1 %%array-physical-bit 0) 0)   (IF displaced-index-offset 3 2)))          (long-length-flag (%LOGDPB 1 %%array-long-length-flag array-header))       (t(+ index-length array-header))))   (SETQ data-length (COMPUTE-NUMBER-OF-QS array-type index-length) qs-in-leader (IF leader-length (+ 2 leader-length) 0))   (SETQ the-array (%ALLOCATE-AND-INITIALIZE-ARRAY    array-header   index-length   (OR leader-length 0)   area   (+ (MAX 1 n-dimensions)       qs-in-leader      (COND (displaced-p (IF displaced-index-offset 3 2))(long-length-flag  (1+ data-length))(t data-length)))))      (WHEN (> n-dimensions 1)       ;; Fill in the "dope vector".     ;; put in all but first dimension,     ;; and the last dimensions come last.     (DO ((dimlist (CDR dimensions) (CDR dimlist))  (i (+ n-dimensions (IF long-length-flag 0 -1)) (1- i))) ((NULL dimlist))       (%P-STORE-CONTENTS-OFFSET (CAR dimlist) the-array i)))      (WHEN displaced-p     ;; It is displaced.  Put information after the dope vector, and after     ;; the "long array" word if any.     (LET ((idx (IF long-length-flag (1+ n-dimensions) n-dimensions)))       (COND (displaced-to-physical-address;;  Store 32-bit physical address.      (%P-DPB-OFFSET (LDB #o2020 displaced-to-physical-address) #o2020 the-array idx)      (%P-DPB-OFFSET (LDB #o0020 displaced-to-physical-address) #o0020 the-array idx))     ('else;;  Store a typed pointer.      (%P-STORE-CONTENTS-OFFSET displaced-to the-array idx)))       (%P-STORE-CONTENTS-OFFSET index-length the-array (1+ idx))       (COND (displaced-index-offset      ;; Index offset feature is in use.      ;; Store the index offset in the next Q.      (%P-STORE-CONTENTS-OFFSET displaced-index-offset the-array (+ idx 2)))))))    ;; A simple array  (t    (MULTIPLE-VALUE-SETQ (the-array data-length)(INTERNAL-MAKE-SIMPLE-VECTOR index-length array-type leader-length area))))        (WHEN leader-list; The leader's initial values were specified.      (DO ((i 0 (1+ i))   (leader-list leader-list (CDR leader-list)))  ((NULL leader-list))(SETF (ARRAY-LEADER the-array i) (CAR leader-list))))        (WHEN fill-pointer      (SETF (ARRAY-LEADER the-array 0) fill-pointer))        ;;; Cretinism associated with make-array, in that the leader list can overlap    ;;; with the name-structure slot, which is how fasd dumps the named-structure-symbol    ;;; So we check for the symbol being t and not smash it in that case    (WHEN named-structure-symbol      ;; It is a named structure.  Set the flag.      (%P-DPB-OFFSET 1 %%array-named-structure-flag the-array 0)      (UNLESS (EQ named-structure-symbol t)(if leader-length    (SETF (ARRAY-LEADER the-array 1) named-structure-symbol)    (setf (aref the-array 0)  named-structure-symbol))))        (WHEN (AND (OR initial-element initial-value) (NOT displaced-to))      (ARRAY-INITIALIZE the-array (OR initial-element initial-value) 0 index-length))        (WHEN (AND initial-contents (NOT displaced-to))      (fill-array-from-sequences the-array initial-contents 0 0))        ;; If there is a fill pointer on an art-q-list array, then it should control    ;; the length of the list as well.  See array-push and array-pop.    (WHEN (AND (= array-type (LDB %%array-type-field art-q-list))       (OR fill-pointer (NOT (NULL leader-list)))       (= n-dimensions 1))      (OR fill-pointer (SETQ fill-pointer (CAR leader-list)))      (COND ((AND (INTEGERP fill-pointer)  (< 0 fill-pointer (ARRAY-TOTAL-SIZE the-array)))     (%P-STORE-CDR-CODE cdr-nil (AP-1 the-array (1- fill-pointer))))))    (VALUES the-array data-length)));;; This is an internal function designed to be called by code generated;;; be a compiler optimizer of simple calls to MAKE-ARRAY.(DEFUN simple-make-array (dimensions &optional type area leader-length initial-value)  (declare (inline COMPUTE-NUMBER-OF-QS COMPUTE-LISPM-ARRAY-TYPE ))  (LET (n-dimensions        ;; number of dimensions (<= 7)index-length        ;; n1*n2*...*nM where nJ is the upper index of each dimensionarray-type          ;; the type of array to be created - integer 1 through 20data-length         ;; the number of Q's in the arraythe-array           ;; the star of our little show);;  process DIMENSIONS - setting up n-dimensions and index-length    (MULTIPLE-VALUE-SETQ (n-dimensions index-length) (COMPUTE-RANK-AND-TOTAL-SIZE dimensions))    ;;  process TYPE, setting array-type    (SETQ array-type  ;; a fixnum between 1 and 20 (inclusive on both ends)  (IF type       (COMPUTE-LISPM-ARRAY-TYPE type)       (LDB %%array-type-field art-q)))  ;; else defaults to an art-q    ;;  verify LEADER-LENGTH    (WHEN leader-length      (UNLESS (TYPEP leader-length '(INTEGER 1 *))(FERROR nil "illegal :LEADER-LENGTH specification ~s . It must be a positive integer." leader-length)))    ;;  now create the array after initially sketching an array header word    ;; JK 4/14/87 0-dimensional arrays should not be simple (fixes [SPR 4712]).     (COND ((OR (/= n-dimensions 1)   ;; if any of these conditions are met, then the array is Not simple       (> index-length %array-max-simple-index-length)       (ZEROP index-length))      (LET* ((long-length-flag  ;; does index-length requires more than 10 bits?    (> index-length %array-max-short-index-length))  (qs-in-leader    (COND ((AND leader-length long-length-flag) (+ 3 leader-length))  (leader-length (+ 2 leader-length))  (long-length-flag 1)  (t 0)))  array-header  )          (SETQ array-header   (%LOGDPB n-dimensions %%array-number-dimensions      (%LOGDPB array-type %%array-type-field     (IF leader-length (%LOGDPB 1 %%array-leader-bit 0) 0))))     (SETQ array-header   (COND (long-length-flag   (%LOGDPB 1 %%array-long-length-flag array-header)) (t (LOGIOR index-length array-header))))          (SETQ data-length (COMPUTE-NUMBER-OF-QS array-type index-length))          (SETQ the-array   (%ALLOCATE-AND-INITIALIZE-ARRAY     array-header     index-length     (OR leader-length 0)     area     (+ (MAX 1 n-dimensions) qs-in-leaderdata-length)))          (WHEN (> n-dimensions 1)         ;; Fill in the "dope vector".       ;; put in all but first dimension,       ;; and the last dimensions come last.       (DO ((dimlist (CDR dimensions) (CDR dimlist))    (i (+ n-dimensions (IF long-length-flag 0 -1)) (1- i)))   ((NULL dimlist)) (%P-STORE-CONTENTS-OFFSET (CAR dimlist) the-array i)))))    ;; A simple array  (t    (MULTIPLE-VALUE-SETQ (the-array data-length)(INTERNAL-MAKE-SIMPLE-VECTOR index-length array-type leader-length area))))    (WHEN initial-value      (ARRAY-INITIALIZE the-array initial-value))    (VALUES the-array data-length)));;; Added 8/22/86 PMH(DEFUN ARRAY-ROW-MAJOR-INDEX (ARRAY &REST SUBSCRIPTS)  "Return the combined index in ARRAY of the element identified by SUBSCRIPTS.This value could be used as the second argument of AR-1-FORCE to access that element.The calculation assumes row-major order"  (CHECK-TYPE ARRAY ARRAY)  (DO ((DIM 0 (1+ DIM))       (RANK (ARRAY-RANK ARRAY))       (RESULT 0)       (TAIL SUBSCRIPTS (CDR TAIL)))      ((= DIM RANK)       RESULT)    (LET ((SUBSCRIPT (CAR TAIL)))      (CHECK-ARG SUBSCRIPT (AND (fixnumP SUBSCRIPT)(< -1 SUBSCRIPT (ARRAY-DIMENSION ARRAY DIM))) "a number in the proper range")      (SETQ RESULT (+ (* RESULT (ARRAY-DIMENSION ARRAY DIM)) SUBSCRIPT)))))(deff row-major-aref 'ar-1-force)(defun displaced-array-p (array)  "If ARRAY is displaced, return the array displaced to and the offset.   If array is not displaced then return NIL and 0."  (declare (values array-indirect-to array-index-offset))  (if (array-indirect-p array)      (values (array-indirect-to array)      (array-index-offset array))      (values nil 0)))(DEFUN LIST-ARRAY-LEADER (ARRAY &OPTIONAL LIMIT)  "Return a list of the contents of ARRAY's leader, up to LIMIT."  (IF (AND (SYMBOLP ARRAY)   (FBOUNDP ARRAY)   (ARRAYP (SYMBOL-FUNCTION ARRAY)))      (SETQ ARRAY (SYMBOL-FUNCTION ARRAY)))  (IF (NULL LIMIT)      (SETQ LIMIT (OR (ARRAY-LEADER-LENGTH ARRAY) 0)))  (LET ((LIST (MAKE-LIST LIMIT)))    (DO ((I 0 (1+ I)) (L LIST (CDR L)))((>= I LIMIT) LIST)      (RPLACA L (ARRAY-LEADER ARRAY I)))))(DEFUN array-data-offset (ARRAY)  "Return the offset in Qs of the first array element from the array header.Not meaningful for displaced arrays."  (IF (PLUSP (%P-LDB-OFFSET %%array-simple-bit array 0))      1      (+ (ARRAY-RANK array) (%P-LDB-OFFSET %%array-long-length-flag array 0))))(DEFUN array-element-offset (element-number ary-type)  "Given an array ELEMENT-NUMBER and an array type ARY-TYPE,returns three values:  the word offset in the array data buffer ofelement ELEMENT-NUMBER, the starting bit number in that word (usefulfor bit-arrays) and a keyword :BOXED or :UNBOXED depending on whetheror not the array type ARY-TYPE is boxed or unboxed storage.  ARY-TYPE can be an array type number or an array type symbol."  (LET (symbolic-type bits-per-elem elements-per-qboxed)    (IF (SYMBOLP ary-type)(SETQ symbolic-type ary-type      ary-type (SYMBOL-VALUE ary-type)))    (LOOP FOR (sym . value) IN array-bits-per-element  DO (WHEN (= (SYMBOL-VALUE sym) ary-type)       (SETQ symbolic-type sym     bits-per-elem value)       (RETURN)))    (UNLESS symbolic-type      (FERROR nil "array type number ~a unknown" ary-type))    (SETQ elements-per-q (CDR (ASSOC symbolic-type array-elements-per-q :test #'EQ))  boxed (IF bits-per-elem nil t))        (MULTIPLE-VALUE-BIND (word-offset rem)(IF (PLUSP elements-per-q)    (FLOOR element-number elements-per-q)    (* (- elements-per-q) element-number))      (VALUESword-offset(IF (AND rem (NOT boxed))    (* rem bits-per-elem)    0)(IF boxed :BOXED :UNBOXED))))  )(DEFUN array-data-buffer-address (array)  "Given an array ARRAY, returns the address of ARRAY's databuffer.  If ARRAY is not a physical array or is not displaced-to aphysical array, the data buffer address returned will be a virtual address (as a FIXNUM).  For physical arrays, the address will bethe full NuBus address (which may be a BIGNUM), and a second value of:PHYSICAL will be returned.  For displaced arrays with index-offsets, a third value is returnedindicating the bit offset of ARRAY's element 0 in the data buffer address word."  (CHECK-type  array array)  (SETQ array (FOLLOW-STRUCTURE-FORWARDING array))  (LET ((data-offset (array-data-offset array))final-array index-offsetphys-addr-word dims long-len ary-type)    (COND            ;; Non-displaced.  Data is contiguous with array overhead.      ((NOT (ARRAY-DISPLACED-P array))       (%POINTER-PLUS array data-offset))            ;; Displaced to physical      ((array-physical-p array)       (SETQ long-len (%P-LDB %%array-long-length-flag array)     dims (ARRAY-RANK array)     phys-addr-word (%POINTER-PLUS array (+ long-len dims)))       (VALUES (DPB (%P-LDB %%Q-high-half phys-addr-word)    %%Q-High-Half    (%P-LDB %%Q-low-half phys-addr-word))       :physical))            ;; Displaced to another array      ((SETQ final-array (array-indirect-to array))       (SETQ index-offset (OR (array-index-offset array) 0)     ary-type (ARRAY-TYPE array))       (DO (tem)   ((NOT (ARRAY-INDIRECT-P final-array))) (WHEN (SETQ tem (array-index-offset final-array))   (INCF index-offset tem)) (SETQ final-array (array-indirect-to final-array)))        (MULTIPLE-VALUE-BIND (word-offset start-bit)   (array-element-offset index-offset ary-type) (MULTIPLE-VALUE-BIND (adr phys-flag st-bit)     (array-data-buffer-address final-array)   (MULTIPLE-VALUE-BIND (words bits)       (FLOOR (+ start-bit (OR st-bit 0)) 32.)     (IF (EQ phys-flag :physical) (VALUES (+ adr (* 4 (+ word-offset words))) phys-flag bits) (VALUES   (%POINTER-PLUS adr (+ word-offset words)) phys-flag bits))))))      ;; Displaced to address.      (t (SETQ long-len (%P-LDB %%array-long-length-flag array)       dims (ARRAY-RANK array)) (%P-CONTENTS-OFFSET array (+ long-len dims)))))  )*;1;; :DONT-DELETE <boolean>*;1;; :DONT-DUMP <boolean>*;1;; :DONT-REAP <boolean>*;1;; :DUMPED <boolean>*;1;; :GENERATION-RETENTION-COUNT <number>*;1;; :LENGTH-IN-BLOCKS <number>*;1;; :LENGTH-IN-BYTES <number>*;1;; :LINK-TO <string>*;1;; :OFFLINE <boolean>*;1;; :PHYSICAL-VOLUME <string>*;1;; :PROTECTION <string>*;1;; :READER <string>*;1;; :REFERENCE-DATE <universal-date>*;1;; :TEMPORARY <boolean>*;1;; A pathname of NIL is treated specially and gives properties for all*;1;; the files listed.  The indicators for this "pathname" are:*;1;; :SETTABLE-PROPERTIES <list-of-indicators, or just T>*;1;; :BLOCK-SIZE  <number>*;1;; :PHYSICAL-VOLUME-FREE-BLOCKS alist of (<string> . <number>)*;1;; :DISK-SPACE-DESCRIPTION <string>*;1;; The currently defined OPTIONS are:*;1;; :NOERROR - a