;;; -*- Mode:Lisp; Readtable:CL; Package:USER; Base:10; Patch-File:T -*-
;;; Patch file for System version 124.100
;;; Reason:
;;;  Is this the last change to (adjust-array)?  No more bugs from test suite...
;;;  Argument checking:
;;;     - If you specify :displaced-index-offset without :displaced-to,
;;;       default the latter to the current indirect array.  Error if none.
;;;     - Generate error if more than one of (:initial-element, :initial-contents,
;;;       :displaced-to) is given.
;;; Written 24-Jun-88 11:29:36 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#503 at 24-Jun-88 14:29:35
#8R SYSTEM-INTERNALS#: #!:ZL
(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 (and displaced-index-offset (null displaced-to))
    (cond ((array-displaced-p array)
	   (setq displaced-to (array-indirect-to array))
	   (setq keyargs (append keyargs `(:displaced-to ,displaced-to))))
	  (t
	   (ferror ":DISPLACED-INDEX-OFFSET but no :DISPLACED-TO"))))
  (when (or (and initial-element-p initial-contents-p)
	    (and initial-element-p displaced-to)
	    (and initial-contents-p displaced-to))
    (ferror "Only one of :INITIAL-ELEMENT, :INITIAL-CONTENTS, and :DISPLACED-TO may be specified"))
  (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
		     (car (rassq (array-type array) array-element-type-alist))
		     displaced-to
		     (car (rassq (array-type displaced-to) array-element-type-alist))))
	    ((and displaced-index-offset
		  (or (not (fixnump displaced-index-offset))
		      (minusp displaced-index-offset)))
	     (ferror "displaced-index-offset must be a non-negative fixnum"))
	    ((> (+ (or displaced-index-offset 0)
		   (apply #'* new-dimensions))
		(array-length displaced-to))
	     (ferror "~s would be displaced past the end of ~S" array 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) (ARRAY-LENGTH ARRAY) FILL-POINTER)))
  (INVALIDATE-ARRAY-CACHE)
  ARRAY)

))