;;; -*- Mode:Lisp; Readtable:ZL; Package:USER; Base:8; Patch-File:T -*-
;;; Patch file for System version 124.67
;;; Reason:
;;;  Problems with (adjust-array):
;;;    - NEW-DIMENSIONS was required to be a list
;;;    - It didn't type check that the dimensions were fixnums
;;;    - couldn't handle 0-dimensional arrays (big deal...)
;;; Written 17-Jun-88 10:48:07 by pld (Peter L. DeWolf) at site Gigamos Cambridge
;;; while running on Azathoth from band 1
;;; with Experimental System 124.65, Experimental Local-File 74.2, Experimental File-Server 23.1, Experimental Unix-Interface 12.0, Experimental ZMail 72.0, Experimental Tape 23.6, Experimental Lambda-Diag 16.2, microcode 1761, SDU Boot Tape 3.14, SDU ROM 8, the old ones.



; From modified file DJ: L.SYS; QRAND.LISP#499 at 17-Jun-88 10:50:39
#8R SYSTEM-INTERNALS#: 
(COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "SYSTEM-INTERNALS")))
  (COMPILER::PATCH-SOURCE-FILE "SYS: SYS; QRAND  "

(DEFUN ADJUST-ARRAY (ARRAY NEW-DIMENSIONS &REST KEYARGS
		     &KEY 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."
  (CHECK-TYPE ARRAY ARRAY)
  (typecase new-dimensions
    ((fixnum 0)
     (unless (= (array-rank array) 1)
       (ferror "1 is the wrong number of dimensions for ~S" array))
     (setq new-dimensions (ncons new-dimensions)))
    (list
     (unless (= (array-rank array) (length new-dimensions))
       (ferror "~S is the wrong number of dimensions for ~S" (length new-dimensions) array))
     (dolist (dimension new-dimensions)
       (check-type dimension (fixnum 0))))
    (otherwise
     (ferror "~S is not a valid array dimension specification." new-dimensions)))
  (WHEN ELEMENT-TYPE
    (LET ((ELT (CAR (RASSQ (ARRAY-TYPE-FROM-ELEMENT-TYPE ELEMENT-TYPE)
			   ARRAY-ELEMENT-TYPE-ALIST))))
      (UNLESS (EQ ELT (CAR (RASSQ (ARRAY-TYPE ARRAY) ARRAY-ELEMENT-TYPE-ALIST)))
	(FERROR "~S is ~S~:[ (=> ~S)~;~*~], but ~S is of element-type ~S"
		'ELEMENT-TYPE ELEMENT-TYPE (EQUAL ELEMENT-TYPE ELT) ELT
		'ARRAY (CAR (RASSQ (ARRAY-TYPE ARRAY) ARRAY-ELEMENT-TYPE-ALIST))))))
  (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)))
    (case (ARRAY-RANK ARRAY)
      (0)
      (1
       (LET ((OLD-LEN (ARRAY-LENGTH ARRAY)))
	 (SETQ ARRAY (ADJUST-ARRAY-SIZE ARRAY (CAR NEW-DIMENSIONS)))
	 (WHEN INITIAL-ELEMENT-P
	   (ARRAY-INITIALIZE ARRAY INITIAL-ELEMENT OLD-LEN (CAR NEW-DIMENSIONS)))))
      (otherwise
       (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)))
  (INVALIDATE-ARRAY-CACHE)
  ARRAY)

))