;;; -*- Mode:Lisp; Readtable:ZL; Package:USER; Base:8; Patch-File:T -*-
;;; Patch file for System version 124.96
;;; Reason:
;;;  Common Lisp compatible error checks in ADJUST-ARRAY:
;;;    - you can't displace an array to itself
;;;    - you can't displace an array to an array which is indirected (to any level)
;;;      to the first array.
;;;    - you can't displace an array to another array of different type.  Note
;;;      that you can still (make-array) displaced across array types, and, in
;;;      fact, this works for various kinds of number arrays.  Fails badly,
;;;      however, if you try to displace an art-q to an art-string.
;;; Written 23-Jun-88 19:09:03 by pld (Peter L. DeWolf) at site Gigamos Cambridge
;;; while running on Cthulhu from band 1
;;; with Experimental System 124.95, Experimental Local-File 74.3, Experimental File-Server 23.1, Experimental Unix-Interface 12.0, Experimental ZMail 72.1, 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#501 at 23-Jun-88 19:18:08
#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
      (cond ((do ((x displaced-to (array-indirect-to x)))
		 ((null x) nil)
	       (when (eq x array)
		 (ferror "You can't ~:[indirectly~;directly~] displace array ~S to itself" (eq x displaced-to) array))))
	    ((neq (array-type array) (array-type displaced-to))
	     (ferror "~S has element type ~S, and can't be displaced to ~S with element type ~S"
		     array (array-type array) displaced-to (array-type displaced-to)))
	    ((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))
	    (t
	     (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)

))