;;; -*- Mode:Lisp; Readtable:ZL; Package:USER; Base:8; Patch-File:T -*-
;;; Patch file for System version 124.123
;;; Reason:
;;;  In MAKE-ARRAY and ARRAY-SIZE-IF-MADE: Fix logic dealing with
;;;  NAMED-STRUCTURE-SYMBOL in combination with LEADER-LENGTH and
;;;  N-DIMENSIONS.  The restriction should be stated (and coded!) as:
;;;  
;;;   "Named-structure arrays without leaders must be one-dimensional."
;;;  
;;;  You now get that error if and only for something like:
;;;  
;;;    (make-array '(2 2) :named-structure-symbol 'FOO)
;;;  
;;;  ...whereas the following is acceptable (and failed before):
;;;  
;;;    (make-array '(2 2) :named-structure-symbol T)
;;; Written 1-Jul-88 13:13:42 by keith at site Gigamos Cambridge
;;; while running on Breaking Glass from band 1
;;; with Experimental System 124.122, Experimental Local-File 74.3, Experimental File-Server 23.1, Unix-Interface 12.0, Experimental ZMail 72.1, Experimental Tape 23.6, Experimental Lambda-Diag 16.2, Tiger 28.0, microcode 1761, SDU Boot Tape 3.14, SDU ROM 103, Beta 3 plus patches.



; From modified file DJ: L.SYS; QRAND.LISP#507 at 1-Jul-88 13:13:50
#8R SYSTEM-INTERNALS#: 
(COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "SYSTEM-INTERNALS")))
  (COMPILER::PATCH-SOURCE-FILE "SYS: SYS; QRAND  "


(DEFUN MAKE-ARRAY (DIMENSIONS &REST OPTIONS)
  "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 255, printed with quotes),
 ART-FAT-STRING (16 bit unsigned elements, printed with quotes),
 ART-1B (elements 0 and 1), ART-2B (elements 0 through 3), ART-4B, ART-8B, ART-16B,
 ART-32B, ART-INUM (any fixnum, low 25. bits of bignum stored),
 ART-FLOAT (elements any full-size flonum),
 ART-COMPLEX (elements any number including complex numbers),
 ART-COMPLEX-FLOAT (elements complex numbers composed of two full-size flonums),
 ART-HALF-FIX (16 bit signed fixnum elements),
 ART-FPS-FLOAT ART-COMPLEX-FPS-FLOAT (used with floating point array processor),
 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.
:ADJUSTABLE - ignored.  (for Common Lisp compatibility)."
  (DECLARE (ARGLIST DIMENSIONS &KEY ELEMENT-TYPE INITIAL-ELEMENT INITIAL-CONTENTS
		    		    FILL-POINTER DISPLACED-TO DISPLACED-INDEX-OFFSET
				    TYPE AREA LEADER-LENGTH LEADER-LIST NAMED-STRUCTURE-SYMBOL
				    ADJUSTABLE))
  (LET ((LENGTH-OF-OPTIONS (LENGTH OPTIONS))
	LEADER-LIST LEADER-LENGTH LEADER-SIZE FILL-POINTER NAMED-STRUCTURE-SYMBOL
	DISPLACED-TO DISPLACED-INDEX-OFFSET
	AREA ARRAY N-DIMENSIONS INDEX-LENGTH LONG-ARRAY?
	(TYPE ART-Q) TYPE? ELEMENT-TYPE?
	INITIAL-ELEMENT INITIAL-ELEMENT?
	INITIAL-CONTENTS INITIAL-CONTENTS?
	BOXED-SIZE TOTAL-SIZE HEADER-SIZE HEADER)
    (UNLESS (EVENP LENGTH-OF-OPTIONS)
      (FERROR "Odd-length options list: ~S" OPTIONS))
    (DO ((O OPTIONS (CDDR O)))
	((NULL O))
      (LET ((VALUE (CADR O)))
	(CASE (CAR O)
	  (:AREA (SETQ AREA VALUE))
	  (:TYPE (SETQ TYPE VALUE TYPE? T))
	  (:ELEMENT-TYPE (SETQ TYPE (ARRAY-TYPE-FROM-ELEMENT-TYPE VALUE) ELEMENT-TYPE? T))
	  (:DISPLACED-INDEX-OFFSET (SETQ DISPLACED-INDEX-OFFSET VALUE))
	  (:DISPLACED-TO (SETQ DISPLACED-TO VALUE))
	  ((:INITIAL-ELEMENT :INITIAL-VALUE) (SETQ INITIAL-ELEMENT VALUE INITIAL-ELEMENT? T))
	  (:INITIAL-CONTENTS (SETQ INITIAL-CONTENTS VALUE INITIAL-CONTENTS? T))
	  (:FILL-POINTER (SETQ FILL-POINTER VALUE))
	  (:ADJUSTABLE)
	  (:LEADER-LIST (SETQ LEADER-LIST VALUE))
	  (:LEADER-LENGTH (SETQ LEADER-LENGTH VALUE))
	  (:NAMED-STRUCTURE-SYMBOL (SETQ NAMED-STRUCTURE-SYMBOL VALUE))
	  (OTHERWISE
	   (FERROR "~S is not a known ~S keyword." (CAR O) 'MAKE-ARRAY)))))
    (IF (AND TYPE? ELEMENT-TYPE?)
	(FERROR "Both ~S and ~S specified." :TYPE :ELEMENT-TYPE))
    (IF (AND DISPLACED-INDEX-OFFSET (NOT DISPLACED-TO))
	(FERROR "The ~S option specified without ~S." :DISPLACED-INDEX-OFFSET :DISPLACED-TO))
    (IF (AND INITIAL-ELEMENT? INITIAL-CONTENTS?)
	(FERROR "Both ~S and ~S specified." :INITIAL-ELEMENT :INITIAL-CONTENTS))
    (TYPECASE TYPE
      (FIXNUM
       ;; Perfunctory test to decide whether the array-type is shifted or not.
       (UNLESS (ZEROP (%LOGLDB %%ARRAY-TYPE-FIELD TYPE))
	 (SETQ TYPE (%LOGLDB %%ARRAY-TYPE-FIELD TYPE))))
      (SYMBOL
       (COND ((MEMQ TYPE ARRAY-TYPES)
	      (SETQ TYPE (%LOGLDB %%ARRAY-TYPE-FIELD (SYMBOL-VALUE TYPE))))
	     ((MEMQ TYPE ARRAY-TYPE-KEYWORDS)
	      (SETQ TYPE (FIND-POSITION-IN-LIST TYPE ARRAY-TYPE-KEYWORDS)))
	     (T
	      (FERROR "~S is not a valid array type." TYPE))))
      (OTHERWISE
       (FERROR "~S is not a valid array type." TYPE)))
    (TYPECASE DIMENSIONS
      ((FIXNUM 0)
       (SETQ N-DIMENSIONS 1)
       (SETQ INDEX-LENGTH DIMENSIONS))
      (LIST
       (WHEN (> (SETQ N-DIMENSIONS (LENGTH DIMENSIONS)) ARRAY-RANK-LIMIT)
	 (FERROR "Arrays may have at most ~D dimensions, not ~D." ARRAY-RANK-LIMIT N-DIMENSIONS))
       (DOLIST (DIMENSION DIMENSIONS)
	 (CHECK-TYPE DIMENSION (FIXNUM 0)))
       (SETQ INDEX-LENGTH (APPLY #'* DIMENSIONS))
       (UNLESS (FIXNUMP INDEX-LENGTH)
	 (FERROR "Array too large; dimensions ~D ==> total size ~D" DIMENSIONS INDEX-LENGTH)))
      (OTHERWISE
       (FERROR "~S is not a valid array dimension specification." DIMENSIONS)))
    (CHECK-TYPE DISPLACED-TO (OR NULL FIXNUM ARRAY LOCATIVE))
    (CHECK-TYPE DISPLACED-INDEX-OFFSET (OR NULL (FIXNUM 0)))
    (TYPECASE LEADER-LENGTH
      (NULL         (SETQ LEADER-LENGTH 0))
      ((FIXNUM 0))
      (OTHERWISE    (FERROR "~S is not a valid leader-length specification." LEADER-LENGTH)))
    (TYPECASE LEADER-LIST
      (NULL)
      (CONS         (SETQ LEADER-LENGTH (MAX LEADER-LENGTH (LENGTH LEADER-LIST))))
      (OTHERWISE    (FERROR "~S is not a valid leader-list." LEADER-LIST)))
    (TYPECASE NAMED-STRUCTURE-SYMBOL
      (NULL)
      (SYMBOL
       ;;Make sure NAMED-STRUCTURE-SYMBOL gets stored and/or handled correctly later.
       (cond
	 ((eq named-structure-symbol T))		;Structure symbol doesn't get stored 
	 ((and leader-length (plusp leader-length))	;Store structure symbol in leader elt 1
	  (SETQ LEADER-LENGTH (MAX LEADER-LENGTH 2)))
	 ((= N-DIMENSIONS 1))				;Store structure symbol in array element 0
	 (t						;Can't handle structure name
	  (FERROR "Named-structure arrays without leaders must be one-dimensional."))))
      (OTHERWISE
       (FERROR "~S is not a valid named-structure symbol." NAMED-STRUCTURE-SYMBOL)))
    (TYPECASE FILL-POINTER
      (NULL)
      ((OR (FIXNUM 0) (CL:MEMBER T))
       (UNLESS (= N-DIMENSIONS 1)
	 (FERROR "Only 1-dimensional arrays may have fill-pointers."))
       (SETQ LEADER-LENGTH (MAX LEADER-LENGTH 1))
       (OR (FIXNUMP FILL-POINTER) (SETQ FILL-POINTER index-length)))
      (OTHERWISE (FERROR "~S is not a valid fill-pointer." FILL-POINTER)))
    (COND ((ZEROP LEADER-LENGTH)
	   (SETQ LEADER-SIZE 0)
	   (SETQ HEADER (%LOGDPB N-DIMENSIONS
				 %%ARRAY-NUMBER-DIMENSIONS
				 (%LOGDPB TYPE %%ARRAY-TYPE-FIELD 0))))
	  (T
	   (SETQ LEADER-SIZE (+ 2 LEADER-LENGTH))
	   (SETQ HEADER (%LOGDPB 1
				 %%ARRAY-LEADER-BIT
				 (%LOGDPB N-DIMENSIONS
					  %%ARRAY-NUMBER-DIMENSIONS
					  (%LOGDPB TYPE %%ARRAY-TYPE-FIELD 0))))))
    (COND ((NULL DISPLACED-TO)
	   (COND ((NOT (SETQ LONG-ARRAY? (> INDEX-LENGTH %ARRAY-MAX-SHORT-INDEX-LENGTH)))
		  (SETQ HEADER (+ INDEX-LENGTH HEADER))
		  (SETQ HEADER-SIZE (MAX 1 N-DIMENSIONS)))
		 (T    
		  (SETQ HEADER (%LOGDPB 1 %%ARRAY-LONG-LENGTH-FLAG HEADER))
		  (SETQ HEADER-SIZE (1+ (MAX 1 N-DIMENSIONS)))))
	   (SETQ ARRAY (%MAKE-ARRAY
			 HEADER
			 INDEX-LENGTH
			 LEADER-LENGTH
			 AREA
			 (SETQ TOTAL-SIZE (+ LEADER-SIZE
					     HEADER-SIZE
					     (ARRAY-TOTAL-DATA-SIZE TYPE INDEX-LENGTH)))
			 (SETQ BOXED-SIZE (+ LEADER-SIZE
					     HEADER-SIZE
					     (ARRAY-BOXED-DATA-SIZE TYPE INDEX-LENGTH))))))
	  (T
	   (SETQ ARRAY (%MAKE-ARRAY
			 (+ (%LOGDPB 1 %%ARRAY-DISPLACED-BIT HEADER)
			    (IF DISPLACED-INDEX-OFFSET 3 2))
			 INDEX-LENGTH
			 LEADER-LENGTH
			 AREA
			 (SETQ TOTAL-SIZE (+ LEADER-SIZE
					     (MAX 1 N-DIMENSIONS)
					     (IF DISPLACED-INDEX-OFFSET 3 2)))
			 (SETQ BOXED-SIZE TOTAL-SIZE)))
	   (%P-STORE-CONTENTS-OFFSET DISPLACED-TO ARRAY N-DIMENSIONS)
	   (%P-STORE-CONTENTS-OFFSET INDEX-LENGTH ARRAY (1+ N-DIMENSIONS))
	   (UNLESS (NULL DISPLACED-INDEX-OFFSET)
	     (%P-STORE-CONTENTS-OFFSET DISPLACED-INDEX-OFFSET ARRAY (+ N-DIMENSIONS 2)))))
    (WHEN (> N-DIMENSIONS 1)
      ;; Initialize the dimension list.  Last dimension goes last, the first is already done.
      (LOOP FOR (DIMENSION) ON (CDR DIMENSIONS)
	    FOR INDEX = (IF LONG-ARRAY? N-DIMENSIONS (1- N-DIMENSIONS)) THEN (1- INDEX)
	 DO (%P-STORE-CONTENTS-OFFSET DIMENSION ARRAY INDEX)))
    (WHEN (NOT (NULL LEADER-LIST))
      (LOOP FOR (ELEMENT) ON LEADER-LIST
	    FOR INDEX = 0 THEN (1+ INDEX)
	 DO (SETF (ARRAY-LEADER ARRAY INDEX) ELEMENT)))
    (WHEN (NOT (NULL FILL-POINTER))
      (SETF (FILL-POINTER ARRAY) 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 (NOT (NULL NAMED-STRUCTURE-SYMBOL))
      (IF (ZEROP LEADER-LENGTH)
	  ;; There is no leader; put it in element zero of the body.
	  (SETF (AREF ARRAY 0) NAMED-STRUCTURE-SYMBOL)
	;; There is a leader; use element one of the leader.
	(UNLESS (EQ NAMED-STRUCTURE-SYMBOL T)
	  (SETF (ARRAY-LEADER ARRAY 1) NAMED-STRUCTURE-SYMBOL)))
      ;; It is a named structure.  Set the flag.
      (%P-DPB-OFFSET 1 %%ARRAY-NAMED-STRUCTURE-FLAG ARRAY 0))

    ;; %MAKE-ARRAY initializes boxed qs to nil, so only initialize to non-nil values.
    (WHEN (AND INITIAL-ELEMENT (NOT DISPLACED-TO))
      (ARRAY-INITIALIZE ARRAY INITIAL-ELEMENT))
    (WHEN (NOT (NULL INITIAL-CONTENTS?))
      (FILL-ARRAY-FROM-SEQUENCES 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 (OR FILL-POINTER LEADER-LIST)
	       (= N-DIMENSIONS 1)
	       (= TYPE (LDB %%ARRAY-TYPE-FIELD ART-Q-LIST)))
      (UNLESS FILL-POINTER (SETQ FILL-POINTER (CAR LEADER-LIST)))
      (WHEN (AND (FIXNUMP FILL-POINTER)
		 (> FILL-POINTER 0)
		 (< FILL-POINTER (ARRAY-LENGTH ARRAY)))
	(%P-DPB CDR-NIL %%Q-CDR-CODE (AP-1 ARRAY (1- FILL-POINTER)))))

    (VALUES ARRAY TOTAL-SIZE BOXED-SIZE)))

))

; From modified file DJ: L.SYS; QRAND.LISP#507 at 1-Jul-88 13:13:54
#8R SYSTEM-INTERNALS#: 
(COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "SYSTEM-INTERNALS")))
  (COMPILER::PATCH-SOURCE-FILE "SYS: SYS; QRAND  "

(DEFUN ARRAY-SIZE-IF-MADE (DIMENSIONS &REST OPTIONS)
  "Args like MAKE-ARRAY, values total-size boxed-size"
  (DECLARE (ARGLIST DIMENSIONS &KEY ELEMENT-TYPE INITIAL-ELEMENT INITIAL-CONTENTS
		    		    FILL-POINTER DISPLACED-TO DISPLACED-INDEX-OFFSET
				    TYPE AREA LEADER-LENGTH LEADER-LIST NAMED-STRUCTURE-SYMBOL
				    ADJUSTABLE)
	   (VALUES TOTAL-SIZE BOXED-SIZE))
  (LET ((LENGTH-OF-OPTIONS (LENGTH OPTIONS))
	LEADER-LIST LEADER-LENGTH LEADER-SIZE FILL-POINTER NAMED-STRUCTURE-SYMBOL
	DISPLACED-TO DISPLACED-INDEX-OFFSET
	AREA N-DIMENSIONS INDEX-LENGTH LONG-ARRAY?
	(TYPE ART-Q) TYPE? ELEMENT-TYPE?
	INITIAL-ELEMENT INITIAL-ELEMENT?
	INITIAL-CONTENTS INITIAL-CONTENTS?
	BOXED-DATA-SIZE TOTAL-DATA-SIZE BOXED-SIZE TOTAL-SIZE
	HEADER-SIZE WIREABLE?)
    (UNLESS (EVENP LENGTH-OF-OPTIONS)
      (FERROR "Odd-length options list: ~S" OPTIONS))
    (DO ((O OPTIONS (CDDR O)))
	((NULL O))
      (LET ((VALUE (CADR O)))
	(CASE (CAR O)
	  (:AREA (SETQ AREA VALUE))
	  (:TYPE (SETQ TYPE VALUE TYPE? T))
	  (:ELEMENT-TYPE (SETQ TYPE (ARRAY-TYPE-FROM-ELEMENT-TYPE VALUE) ELEMENT-TYPE? T))
	  (:DISPLACED-INDEX-OFFSET (SETQ DISPLACED-INDEX-OFFSET VALUE))
	  (:DISPLACED-TO (SETQ DISPLACED-TO VALUE))
	  ((:INITIAL-ELEMENT :INITIAL-VALUE) (SETQ INITIAL-ELEMENT VALUE INITIAL-ELEMENT? T))
	  (:INITIAL-CONTENTS (SETQ INITIAL-CONTENTS VALUE INITIAL-CONTENTS? T))
	  (:FILL-POINTER (SETQ FILL-POINTER VALUE))
	  (:ADJUSTABLE)
	  (:WIREABLE (SETQ WIREABLE? VALUE))
	  (:LEADER-LIST (SETQ LEADER-LIST VALUE))
	  (:LEADER-LENGTH (SETQ LEADER-LENGTH VALUE))
	  (:NAMED-STRUCTURE-SYMBOL (SETQ NAMED-STRUCTURE-SYMBOL VALUE))
	  (OTHERWISE
	   (FERROR "~S is not a known ~S keyword." (CAR O) 'MAKE-ARRAY)))))
    (IF (AND TYPE? ELEMENT-TYPE?)
	(FERROR "Both ~S and ~S specified." :TYPE :ELEMENT-TYPE))
    (IF (AND DISPLACED-INDEX-OFFSET (NOT DISPLACED-TO))
	(FERROR "The ~S option specified without ~S." :DISPLACED-INDEX-OFFSET :DISPLACED-TO))
    (IF (AND INITIAL-ELEMENT? INITIAL-CONTENTS?)
	(FERROR "Both ~S and ~S specified." :INITIAL-ELEMENT :INITIAL-CONTENTS))
    (TYPECASE TYPE
      (FIXNUM
       ;; Perfunctory test to decide whether the array-type is shifted or not.
       (UNLESS (ZEROP (%LOGLDB %%ARRAY-TYPE-FIELD TYPE))
	 (SETQ TYPE (%LOGLDB %%ARRAY-TYPE-FIELD TYPE))))
      (SYMBOL
       (COND ((MEMQ TYPE ARRAY-TYPES)
	      (SETQ TYPE (%LOGLDB %%ARRAY-TYPE-FIELD (SYMBOL-VALUE TYPE))))
	     ((MEMQ TYPE ARRAY-TYPE-KEYWORDS)
	      (SETQ TYPE (FIND-POSITION-IN-LIST TYPE ARRAY-TYPE-KEYWORDS)))
	     (T
	      (FERROR "~S is not a valid array type." TYPE))))
      (OTHERWISE
       (FERROR "~S is not a valid array type." TYPE)))
    (TYPECASE DIMENSIONS
      ((FIXNUM 0)
       (SETQ N-DIMENSIONS 1)
       (SETQ INDEX-LENGTH DIMENSIONS))
      (LIST
       (unless (< (SETQ N-DIMENSIONS (LENGTH DIMENSIONS)) ARRAY-RANK-LIMIT)
	 (FERROR "Arrays may have at most ~S dimensions, not ~S." (- array-rank-limit 1) N-DIMENSIONS))
       (DOLIST (DIMENSION DIMENSIONS)
	 (CHECK-TYPE DIMENSION (FIXNUM 0) "a non-negative fixnum"))
       (SETQ INDEX-LENGTH (APPLY #'* DIMENSIONS))
       (UNLESS (FIXNUMP INDEX-LENGTH)
	 (FERROR "Array too large; dimensions ~S ==> total size ~S" DIMENSIONS INDEX-LENGTH)))
      (OTHERWISE
       (FERROR "~S is not a valid array dimension specification." DIMENSIONS)))
    (CHECK-TYPE DISPLACED-TO (OR NULL FIXNUM ARRAY LOCATIVE))
    (CHECK-TYPE DISPLACED-INDEX-OFFSET (OR NULL (FIXNUM 0)))
    (TYPECASE LEADER-LENGTH
      (NULL         (SETQ LEADER-LENGTH 0))
      ((FIXNUM 0))
      (OTHERWISE    (FERROR "~S is not a valid leader-length specification." LEADER-LENGTH)))
    (TYPECASE LEADER-LIST
      (NULL)
      (CONS         (SETQ LEADER-LENGTH (MAX LEADER-LENGTH (LENGTH LEADER-LIST))))
      (OTHERWISE    (FERROR "~S is not a valid leader-list." LEADER-LIST)))
    (TYPECASE NAMED-STRUCTURE-SYMBOL
      (NULL)
      (SYMBOL
       ;;Make sure NAMED-STRUCTURE-SYMBOL gets stored and/or handled correctly later.
       (cond
	 ((eq named-structure-symbol T))		;Structure symbol doesn't get stored 
	 ((and leader-length (plusp leader-length))	;Store structure symbol in leader elt 1
	  (SETQ LEADER-LENGTH (MAX LEADER-LENGTH 2)))
	 ((= N-DIMENSIONS 1))				;Store structure symbol in array element 0
	 (t						;Can't handle structure name
	  (FERROR "Named-structure arrays without leaders must be one-dimensional."))))
      (OTHERWISE
       (FERROR "~S is not a valid named-structure symbol." NAMED-STRUCTURE-SYMBOL)))
    (TYPECASE FILL-POINTER
      (NULL)
      ((FIXNUM 0)
       (UNLESS (= N-DIMENSIONS 1)
	 (FERROR "Only 1-dimensional arrays may have fill-pointers."))
       (SETQ LEADER-LENGTH (MAX LEADER-LENGTH 1)))
      (OTHERWISE
       (FERROR "~S is not a valid fill-pointer." FILL-POINTER)))
    (COND ((ZEROP LEADER-LENGTH)
	   (SETQ LEADER-SIZE 0))
	  (T
	   (SETQ LEADER-SIZE (+ 2 LEADER-LENGTH))))
    (COND ((NOT (NULL WIREABLE?))
	   (SETQ TOTAL-DATA-SIZE (ARRAY-TOTAL-DATA-SIZE TYPE INDEX-LENGTH))
	   (SETQ BOXED-DATA-SIZE (ARRAY-BOXED-DATA-SIZE TYPE INDEX-LENGTH))
	   (COND ((NOT (SETQ LONG-ARRAY? (> INDEX-LENGTH %ARRAY-MAX-SHORT-INDEX-LENGTH)))
		  (SETQ HEADER-SIZE (MAX 1 N-DIMENSIONS)))
		 (T    
		  (SETQ HEADER-SIZE (1+ (MAX 1 N-DIMENSIONS)))))
	   (SETQ BOXED-SIZE (+ LEADER-SIZE HEADER-SIZE BOXED-DATA-SIZE))
	   (SETQ TOTAL-SIZE (+ LEADER-SIZE HEADER-SIZE TOTAL-DATA-SIZE)))
	  ((NULL DISPLACED-TO)
	   (SETQ TOTAL-DATA-SIZE (ARRAY-TOTAL-DATA-SIZE TYPE INDEX-LENGTH))
	   (SETQ BOXED-DATA-SIZE (ARRAY-BOXED-DATA-SIZE TYPE INDEX-LENGTH))
	   (COND ((NOT (SETQ LONG-ARRAY? (> INDEX-LENGTH %ARRAY-MAX-SHORT-INDEX-LENGTH)))
		  (SETQ HEADER-SIZE (MAX 1 N-DIMENSIONS)))
		 (T    
		  (SETQ HEADER-SIZE (1+ (MAX 1 N-DIMENSIONS)))))
	   (SETQ BOXED-SIZE (+ LEADER-SIZE HEADER-SIZE BOXED-DATA-SIZE))
	   (SETQ TOTAL-SIZE (+ LEADER-SIZE HEADER-SIZE TOTAL-DATA-SIZE)))
	  (T
	   (SETQ BOXED-DATA-SIZE (IF DISPLACED-INDEX-OFFSET 3 2))
	   (SETQ TOTAL-SIZE (+ LEADER-SIZE (MAX 1 N-DIMENSIONS) BOXED-DATA-SIZE))
	   (SETQ BOXED-SIZE TOTAL-SIZE)))
    (VALUES TOTAL-SIZE BOXED-SIZE)))

))