;;; -*- Mode:Lisp; Readtable:ZL; Package:USER; Base:8; Patch-File:T -*- ;;; Patch file for System version 124.90 ;;; Reason: ;;; Fixes to (make-array): ;;; - In error messages, print number of dimensions, array-rank-limit, ;;; and dimension lists in decimal. ;;; - Code that purported to restrict arrays with named-structure-symbol ;;; to being one-dimensional could never work. ;;; Written 22-Jun-88 18:37:27 by pld (Peter L. DeWolf) at site Gigamos Cambridge ;;; while running on Cthulhu from band 1 ;;; with Experimental System 124.89, Experimental Local-File 74.2, Experimental File-Server 23.1, Experimental Unix-Interface 12.0, Experimental ZMail 72.1, Experimental Tape 23.6, Experimental Lambda-Diag 16.2, microcode 1760, SDU Boot Tape 3.14, SDU ROM 8, the old ones. ; From modified file DJ: L.SYS; QRAND.LISP#499 at 22-Jun-88 18:48:11 #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 (SETQ LEADER-LENGTH (MAX LEADER-LENGTH 2)) (UNLESS (= N-DIMENSIONS 1) (FERROR "Named-structure arrays 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))) ))