(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "XCL" BASE 10)

(FILECREATED "18-Oct-93 10:11:11" "{Pele:mv:envos}<LispCore>Sources>CLTL2>CMLARRAY.;2"
 114839 

      |previous| |date:| "12-Oct-93 16:35:09" "{Pele:mv:envos}<LispCore>Sources>CLTL2>CMLARRAY.;1")


; Copyright (c) 1986, 1987, 1988, 1990, 1991, 1992, 1993 by Venue & Xerox Corporation.  All rights reserved.

(PRETTYCOMPRINT CMLARRAYCOMS)

(RPAQQ CMLARRAYCOMS

       (
        (* |;;| "Contains table driven macros")


        (DECLARE\: DONTCOPY EVAL@COMPILE (EXPORT (FILES (SYSLOAD FROM VALUEOF DIRECTORIES)
                                                        CMLARRAY-SUPPORT)))
        
        (* |;;| "User entry points")


        (FUNCTIONS LISP:ADJUST-ARRAY LISP:ADJUSTABLE-ARRAY-P LISP:ARRAY-DIMENSION 
               LISP:ARRAY-DIMENSIONS LISP:ARRAY-ELEMENT-TYPE LISP:ARRAY-HAS-FILL-POINTER-P 
               ARRAY-NEEDS-INDIRECTION-P LISP:ARRAY-RANK LISP:ARRAY-TOTAL-SIZE BIT LISP:BIT-AND 
               LISP:BIT-ANDC1 LISP:BIT-ANDC2 BIT-ARRAY-P LISP:BIT-EQV LISP:BIT-IOR LISP:BIT-NAND 
               LISP:BIT-NOR LISP:BIT-NOT LISP:BIT-ORC1 LISP:BIT-ORC2 LISP:BIT-VECTOR-P LISP:BIT-XOR 
               LISP:CHAR LISP:ARRAYP LISP:STRINGP COPY-ARRAY COPY-VECTOR DISPLACED-ARRAY-P 
               EQUAL-DIMENSIONS-P EXTENDABLE-ARRAY-P FILL-ARRAY LISP:FILL-POINTER FILL-VECTOR 
               LISP:MAKE-ARRAY MAKE-VECTOR READ-ONLY-ARRAY-P LISP:SBIT LISP:SCHAR SET-FILL-POINTER 
               SIMPLE-ARRAY-P LISP:SIMPLE-BIT-VECTOR-P LISP:SIMPLE-STRING-P LISP:SIMPLE-VECTOR-P 
               STRING-ARRAY-P LISP:SVREF LISP::UPGRADED-ARRAY-ELEMENT-TYPE VECTOR-LENGTH 
               LISP:VECTOR-POP LISP:VECTOR-PUSH LISP:VECTOR-PUSH-EXTEND LISP:VECTORP)
        (FNS LISP:AREF LISP:ARRAY-IN-BOUNDS-P LISP:ARRAY-ROW-MAJOR-INDEX ASET LISP:VECTOR)
        
        (* |;;| "New CLtL array functions")


        (COMS (FNS LISP::ROW-MAJOR-AREF LISP::ROW-MAJOR-ASET)
              (SETFS LISP::ROW-MAJOR-AREF))
        
        (* |;;| "Setfs")


        (SETFS LISP:AREF BIT LISP:CHAR LISP:FILL-POINTER LISP:SBIT LISP:SCHAR LISP:SVREF)
        
        (* |;;| "Optimizers")


        (FUNCTIONS %AREF-EXPANDER %ASET-EXPANDER)
        (OPTIMIZERS LISP:AREF ASET BIT LISP:CHAR LISP:SBIT LISP:SCHAR LISP:SVREF)
        
        (* |;;| "Vars etc")


                                                             (* \; 

                                                           "*PRINT-ARRAY* is defined in APRINT")

        (VARIABLES LISP:ARRAY-RANK-LIMIT LISP:ARRAY-TOTAL-SIZE-LIMIT LISP:ARRAY-DIMENSION-LIMIT 
               *DEFAULT-PUSH-EXTENSION-SIZE*)
        
        (* |;;| "Run-time support")


        (FNS %ALTER-AS-DISPLACED-ARRAY %ALTER-AS-DISPLACED-TO-BASE-ARRAY %AREF0 %AREF1 %AREF2 
             %ARRAY-BASE %ARRAY-CONTENT-INITIALIZE %ARRAY-ELEMENT-INITIALIZE %ARRAY-OFFSET 
             %ARRAY-TYPE-NUMBER %ASET0 %ASET1 %ASET2 %CHECK-SEQUENCE-DIMENSIONS %COPY-TO-NEW-ARRAY 
             %DO-LOGICAL-OP %EXTEND-ARRAY %FAST-COPY-BASE %FAT-STRING-ARRAY-P 
             %FILL-ARRAY-FROM-SEQUENCE %FLATTEN-ARRAY %MAKE-ARRAY-WRITEABLE %MAKE-DISPLACED-ARRAY 
             %MAKE-GENERAL-ARRAY %MAKE-ONED-ARRAY %MAKE-STRING-ARRAY-FAT %MAKE-TWOD-ARRAY %TOTAL-SIZE
             SHRINK-VECTOR)
                                                             (* \; "For Interlisp string hack")

        (FNS %SET-ARRAY-OFFSET %SET-ARRAY-TYPE-NUMBER)
                                                             (* \; "Low level predicates")

        (FNS %ONED-ARRAY-P %TWOD-ARRAY-P %GENERAL-ARRAY-P %THIN-STRING-ARRAY-P)
        (OPTIMIZERS %ONED-ARRAY-P %TWOD-ARRAY-P %GENERAL-ARRAY-P)
                                                             (* \; 

                                                           "Real record def's on cmlarray-support")

        (INITRECORDS GENERAL-ARRAY ONED-ARRAY TWOD-ARRAY)
        (SYSRECORDS GENERAL-ARRAY ONED-ARRAY TWOD-ARRAY)
        (PROP DOPVAL %AREF1 %AREF2 %ASET1 %ASET2)
        
        (* |;;| "I/O")


        (FNS %DEFPRINT-ARRAY %DEFPRINT-BITVECTOR %DEFPRINT-GENERIC-ARRAY %DEFPRINT-VECTOR 
             %DEFPRINT-STRING %PRINT-ARRAY-CONTENTS)
        (P (DEFPRINT 'ONED-ARRAY '%DEFPRINT-VECTOR)
           (DEFPRINT 'TWOD-ARRAY '%DEFPRINT-ARRAY)
           (DEFPRINT 'GENERAL-ARRAY '%DEFPRINT-ARRAY))
        
        (* |;;| "Needed at run time. low level functions for accessing, setting, and allocating raw storage. also includes cml type to typenumber converters")


        (FNS %ARRAY-READ %ARRAY-WRITE %CML-TYPE-TO-TYPENUMBER %GET-CANONICAL-CML-TYPE 
             %GET-ENCLOSING-SIGNED-BYTE %GET-ENCLOSING-UNSIGNED-BYTE %MAKE-ARRAY-STORAGE 
             %REDUCE-INTEGER %REDUCE-MOD %SLOW-ARRAY-READ %SLOW-ARRAY-WRITE)
        (OPTIMIZERS %ARRAY-READ %ARRAY-WRITE)
        
        (* |;;| "Compiler options")


        (DECLARE\: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY (LOCALVARS . T))
        (PROP FILETYPE CMLARRAY)
        (DECLARE\: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
               (ADDVARS (NLAMA)
                      (NLAML)
                      (LAMA LISP:VECTOR ASET LISP:ARRAY-ROW-MAJOR-INDEX LISP:ARRAY-IN-BOUNDS-P 
                            LISP:AREF)))))



(* |;;| "Contains table driven macros")


(DECLARE\: DONTCOPY EVAL@COMPILE 
(* "FOLLOWING DEFINITIONS EXPORTED")
(FILESLOAD (SYSLOAD FROM VALUEOF DIRECTORIES)
       CMLARRAY-SUPPORT)

(* "END EXPORTED DEFINITIONS")

)



(* |;;| "User entry points")



(LISP:DEFUN LISP:ADJUST-ARRAY
 (ADJUSTABLE-ARRAY DIMENSIONS &KEY (ELEMENT-TYPE NIL 
                                                                           ELEMENT-TYPE-P)
                                         (INITIAL-ELEMENT NIL INITIAL-ELEMENT-P)
                                         (INITIAL-CONTENTS NIL INITIAL-CONTENTS-P)
                                         (DISPLACED-TO NIL DISPLACED-TO-P)
                                         (DISPLACED-TO-BASE NIL DISPLACED-TO-BASE-P)
                                         (DISPLACED-INDEX-OFFSET 0 DISPLACED-INDEX-OFFSET-P)
                                         (FILL-POINTER NIL FILL-POINTER-P)
                                         FATP)

   (* |;;| "Do something wonderfull")


   (LISP:IF (NOT (EXTENDABLE-ARRAY-P
 ADJUSTABLE-ARRAY))
          (LISP:ERROR "Not an adjustable or extendable array: ~S" ADJUSTABLE-ARRAY))
   (LISP:IF (NOT (LISP:LISTP DIMENSIONS))
       (SETQ DIMENSIONS (LIST DIMENSIONS)))
   (LISP:IF (LISP:DOLIST (DIM DIMENSIONS NIL)
                (LISP:IF (OR (< DIM 0)
                             (>= DIM LISP:ARRAY-DIMENSION-LIMIT))
                       (RETURN T)))
          (LISP:ERROR "Dimensions out of bounds ~S" DIMENSIONS))
   (LET ((ADJUSTABLE-ARRAY-ELEMENT-TYPE (LISP:ARRAY-ELEMENT-TYPE
 ADJUSTABLE-ARRAY))
         (NELTS (%TOTAL-SIZE
 DIMENSIONS))
         (RANK (LENGTH DIMENSIONS))
         (EXTENDABLE-P (NOT (LISP:ADJUSTABLE-ARRAY-P
 ADJUSTABLE-ARRAY))))

        (* |;;| "Consistency checks")


        (LISP:IF (>= RANK LISP:ARRAY-RANK-LIMIT)
               (LISP:ERROR "Too many dimensions: ~A" RANK))
        (LISP:IF (>= NELTS LISP:ARRAY-TOTAL-SIZE-LIMIT)
               (LISP:ERROR "Too many elements: ~A" NELTS))
        (LISP:IF (NOT (EQ RANK (LISP:ARRAY-RANK
 ADJUSTABLE-ARRAY)))
               (LISP:ERROR "Rank mismatch: ~S" DIMENSIONS))
        (LISP:IF ELEMENT-TYPE-P
            (LISP:IF (NOT (EQUAL ELEMENT-TYPE ADJUSTABLE-ARRAY-ELEMENT-TYPE))
                   (LISP:ERROR "ADJUSTABLE-ARRAY not of specified element-type: ~A" ELEMENT-TYPE))
            (SETQ ELEMENT-TYPE ADJUSTABLE-ARRAY-ELEMENT-TYPE))
        (LISP:IF (AND FILL-POINTER-P (NULL FILL-POINTER)
                      (LISP:ARRAY-HAS-FILL-POINTER-P
 ADJUSTABLE-ARRAY))
               (LISP:ERROR "ADJUSTABLE-ARRAY has fill pointer"))
        (LISP:IF (OR (AND DISPLACED-TO-P (OR INITIAL-ELEMENT-P INITIAL-CONTENTS-P DISPLACED-TO-BASE-P
                                             ))
                     (AND DISPLACED-TO-BASE-P (OR INITIAL-ELEMENT-P INITIAL-CONTENTS-P DISPLACED-TO-P
                                                  ))
                     (AND FILL-POINTER-P FILL-POINTER (NOT (LISP:ARRAY-HAS-FILL-POINTER-P
 
                                                                  ADJUSTABLE-ARRAY)))
                     (AND DISPLACED-INDEX-OFFSET-P (NOT (OR DISPLACED-TO-P DISPLACED-TO-BASE-P)))
                     (AND INITIAL-ELEMENT-P INITIAL-CONTENTS-P))
               (LISP:ERROR "Inconsistent options to adjust-array"))
        (LISP:IF DISPLACED-TO-P
            (COND
               ((NOT (%ARRAYP DISPLACED-TO))
                (LISP:ERROR "Not displaced to an array: ~S" DISPLACED-TO))
               ((NOT (EQUAL ADJUSTABLE-ARRAY-ELEMENT-TYPE (LISP:ARRAY-ELEMENT-TYPE
 DISPLACED-TO))
                     )
                (LISP:ERROR "Not displaced to an array of the same element-type:"))
               ((> (+ DISPLACED-INDEX-OFFSET NELTS)
                   (LISP:ARRAY-TOTAL-SIZE
 DISPLACED-TO))
                (LISP:ERROR "More elements than displaced-to array"))))
        (LISP:IF FILL-POINTER
            (COND
               ((EQ FILL-POINTER T)
                (SETQ FILL-POINTER NELTS))
               ((NOT (<= 0 FILL-POINTER NELTS))
                (LISP:ERROR "Fill pointer out of bounds: ~A" FILL-POINTER)))
            (LISP:IF (LISP:ARRAY-HAS-FILL-POINTER-P
 ADJUSTABLE-ARRAY)
                (SETQ FILL-POINTER (MIN (LISP:FILL-POINTER
 ADJUSTABLE-ARRAY)
                                        NELTS))))
        (LISP:IF EXTENDABLE-P
            (COND
               ((OR DISPLACED-TO-P DISPLACED-TO-BASE-P)
                (LISP:ERROR "Cannot adjust an extendable array to be displaced"))
               ((< NELTS (LISP:ARRAY-TOTAL-SIZE
 ADJUSTABLE-ARRAY))
                (LISP:ERROR "Cannot extend an extendable array to have fewer elements"))))

        (* |;;| "Specs ready, do the surgury")


        (COND
           (DISPLACED-TO-P (%ALTER-AS-DISPLACED-ARRAY
 ADJUSTABLE-ARRAY DIMENSIONS DISPLACED-TO 
                                  DISPLACED-INDEX-OFFSET FILL-POINTER))
           (DISPLACED-TO-BASE-P (%ALTER-AS-DISPLACED-TO-BASE-ARRAY
 ADJUSTABLE-ARRAY DIMENSIONS 
                                       ELEMENT-TYPE DISPLACED-TO-BASE DISPLACED-INDEX-OFFSET 
                                       FILL-POINTER FATP))
           (T (LISP:IF (EQUAL (LISP:ARRAY-DIMENSIONS
 ADJUSTABLE-ARRAY)
                              DIMENSIONS)
                  (LISP:IF FILL-POINTER (SET-FILL-POINTER
 ADJUSTABLE-ARRAY FILL-POINTER))
                  (LET ((NEW-ARRAY (LISP:MAKE-ARRAY
 DIMENSIONS :ELEMENT-TYPE ELEMENT-TYPE :FATP
                                          (%FAT-STRING-ARRAY-P
 ADJUSTABLE-ARRAY))))
                       (COND
                          (INITIAL-CONTENTS-P (%ARRAY-CONTENT-INITIALIZE
 NEW-ARRAY 
                                                     INITIAL-CONTENTS))
                          (T (LISP:IF INITIAL-ELEMENT-P (%ARRAY-ELEMENT-INITIALIZE
 NEW-ARRAY 
                                                               INITIAL-ELEMENT))
                             (%COPY-TO-NEW-ARRAY
 (LISP:ARRAY-DIMENSIONS
 ADJUSTABLE-ARRAY)
                                    (%FLATTEN-ARRAY
 ADJUSTABLE-ARRAY)
                                    0 DIMENSIONS (%FLATTEN-ARRAY
 NEW-ARRAY)
                                    0)))
                       (%EXTEND-ARRAY
 ADJUSTABLE-ARRAY NEW-ARRAY DIMENSIONS FILL-POINTER)))))

        (* |;;| "Return the adjusted array")


        ADJUSTABLE-ARRAY))

(LISP:DEFUN LISP:ADJUSTABLE-ARRAY-P
 (ARRAY)
   (LISP:IF (%ARRAYP ARRAY)
       (|fetch|
 (ARRAY-HEADER ADJUSTABLE-P) |of|
 ARRAY)
       (LISP:ERROR "Not an array: ~S" ARRAY)))

(LISP:DEFUN LISP:ARRAY-DIMENSION
 (ARRAY DIMENSION)
   (COND
      ((%ONED-ARRAY-P
 ARRAY)
       (LISP:IF (EQ 0 DIMENSION)
           (|fetch|
 (ARRAY-HEADER TOTAL-SIZE) |of|
 ARRAY)
           (LISP:ERROR "Dimension out of bounds: ~A" DIMENSION)))
      ((%TWOD-ARRAY-P
 ARRAY)
       (CASE DIMENSION
           (0 (|ffetch|
 (TWOD-ARRAY BOUND0) |of|
 ARRAY))
           (1 (|ffetch|
 (TWOD-ARRAY BOUND1) |of|
 ARRAY))
           (T (LISP:ERROR "Dimension out of bounds: ~A" DIMENSION))))
      ((%GENERAL-ARRAY-P
 ARRAY)
       (LET* ((DIMS (|ffetch|
 (GENERAL-ARRAY DIMS) |of|
 ARRAY))
              (RANK (LENGTH DIMS)))
             (LISP:IF (NOT (< -1 DIMENSION RANK))
                    (LISP:ERROR "Dimension out of bounds: ~A" DIMENSION))
             (LISP:IF (EQ RANK 1)
                 (|fetch|
 (ARRAY-HEADER TOTAL-SIZE) |of|
 ARRAY)
                 (LISP:NTH DIMENSION DIMS))))
      (T (LISP:ERROR "Not an array: ~S" ARRAY))))

(LISP:DEFUN LISP:ARRAY-DIMENSIONS
 (ARRAY)
   (COND
      ((%ONED-ARRAY-P
 ARRAY)
       (LIST (|ffetch|
 (ONED-ARRAY TOTAL-SIZE) |of|
 ARRAY)))
      ((%TWOD-ARRAY-P
 ARRAY)
       (LIST (|ffetch|
 (TWOD-ARRAY BOUND0) |of|
 ARRAY)
             (|ffetch|
 (TWOD-ARRAY BOUND1) |of|
 ARRAY)))
      ((%GENERAL-ARRAY-P
 ARRAY)
       (|ffetch|
 (GENERAL-ARRAY DIMS) |of|
 ARRAY))
      (T (LISP:ERROR "Not an array: ~S" ARRAY))))

(LISP:DEFUN LISP:ARRAY-ELEMENT-TYPE
 (ARRAY)
   (LISP:IF (%ARRAYP ARRAY)
       (%TYPENUMBER-TO-CML-TYPE (%ARRAY-TYPE-NUMBER
 ARRAY))
       (LISP:ERROR "Not an array: ~S" ARRAY)))

(LISP:DEFUN LISP:ARRAY-HAS-FILL-POINTER-P
 (ARRAY)
   (LISP:IF (%ARRAYP ARRAY)
       (|fetch|
 (ARRAY-HEADER FILL-POINTER-P) |of|
 ARRAY)
       (LISP:ERROR "Not an array: ~S" ARRAY)))

(LISP:DEFUN ARRAY-NEEDS-INDIRECTION-P
 (ARRAY)
   (COND
      ((OR (%ONED-ARRAY-P
 ARRAY)
           (%TWOD-ARRAY-P
 ARRAY))
       NIL)
      ((%GENERAL-ARRAY-P
 ARRAY)
       (|fetch|
 (ARRAY-HEADER INDIRECT-P) |of|
 ARRAY))
      (T (LISP:ERROR "Not an array: ~S" ARRAY))))

(LISP:DEFUN LISP:ARRAY-RANK
 (ARRAY)
   (COND
      ((%ONED-ARRAY-P
 ARRAY)
       1)
      ((%TWOD-ARRAY-P
 ARRAY)
       2)
      ((%GENERAL-ARRAY-P
 ARRAY)
       (LENGTH (|ffetch|
 (GENERAL-ARRAY DIMS) |of|
 ARRAY)))
      (T (LISP:ERROR "Not an array: ~S" ARRAY))))

(LISP:DEFUN LISP:ARRAY-TOTAL-SIZE
 (ARRAY)
   (LISP:IF (%ARRAYP ARRAY)
       (|fetch|
 (ARRAY-HEADER TOTAL-SIZE) |of|
 ARRAY)
       (LISP:ERROR "Not an array: ~S" ARRAY)))

(LISP:DEFUN BIT
 (BIT-ARRAY &REST INDICES)
   (LISP:ASSERT (TYPEP BIT-ARRAY '(LISP:ARRAY BIT))
          (BIT-ARRAY)
          "Not a bit-array: ~S" BIT-ARRAY)
   (LISP:APPLY #'LISP:AREF BIT-ARRAY INDICES))

(LISP:DEFUN LISP:BIT-AND
 (BIT-ARRAY1 BIT-ARRAY2 &OPTIONAL BIT-RESULT)
   (%EXPAND-BIT-OP AND BIT-ARRAY1 BIT-ARRAY2 BIT-RESULT))

(LISP:DEFUN LISP:BIT-ANDC1
 (BIT-ARRAY1 BIT-ARRAY2 &OPTIONAL BIT-RESULT)
   (%EXPAND-BIT-OP ANDC1 BIT-ARRAY1 BIT-ARRAY2 BIT-RESULT))

(LISP:DEFUN LISP:BIT-ANDC2
 (BIT-ARRAY1 BIT-ARRAY2 &OPTIONAL BIT-RESULT)
   (%EXPAND-BIT-OP ANDC2 BIT-ARRAY1 BIT-ARRAY2 BIT-RESULT))

(LISP:DEFUN BIT-ARRAY-P
 (ARRAY)
   (AND (%ARRAYP ARRAY)
        (|fetch|
 (ARRAY-HEADER BIT-P) |of|
 ARRAY)))

(LISP:DEFUN LISP:BIT-EQV
 (BIT-ARRAY1 BIT-ARRAY2 &OPTIONAL BIT-RESULT)
   (%EXPAND-BIT-OP EQV BIT-ARRAY1 BIT-ARRAY2 BIT-RESULT))

(LISP:DEFUN LISP:BIT-IOR
 (BIT-ARRAY1 BIT-ARRAY2 &OPTIONAL BIT-RESULT)
   (%EXPAND-BIT-OP IOR BIT-ARRAY1 BIT-ARRAY2 BIT-RESULT))

(LISP:DEFUN LISP:BIT-NAND
 (BIT-ARRAY1 BIT-ARRAY2 &OPTIONAL BIT-RESULT)
   (%EXPAND-BIT-OP NAND BIT-ARRAY1 BIT-ARRAY2 BIT-RESULT))

(LISP:DEFUN LISP:BIT-NOR
 (BIT-ARRAY1 BIT-ARRAY2 &OPTIONAL BIT-RESULT)
   (%EXPAND-BIT-OP NOR
 BIT-ARRAY1 BIT-ARRAY2 BIT-RESULT))

(LISP:DEFUN LISP:BIT-NOT
 (BIT-ARRAY &OPTIONAL RESULT-BIT-ARRAY)
   (LISP:IF (NOT (BIT-ARRAY-P
 BIT-ARRAY))
          (LISP:ERROR "BIT-ARRAY not a bit array"))
   (COND
      ((NULL RESULT-BIT-ARRAY)
       (SETQ RESULT-BIT-ARRAY (LISP:MAKE-ARRAY
 (LISP:ARRAY-DIMENSIONS
 BIT-ARRAY)
                                     :ELEMENT-TYPE
                                     'BIT)))
      ((EQ RESULT-BIT-ARRAY T)
       (SETQ RESULT-BIT-ARRAY BIT-ARRAY))
      ((NOT (AND (BIT-ARRAY-P
 RESULT-BIT-ARRAY)
                 (EQUAL-DIMENSIONS-P
 BIT-ARRAY RESULT-BIT-ARRAY)))
       (LISP:ERROR "Illegal result array")))
   (%DO-LOGICAL-OP
 'NOT BIT-ARRAY RESULT-BIT-ARRAY)
   RESULT-BIT-ARRAY)

(LISP:DEFUN LISP:BIT-ORC1
 (BIT-ARRAY1 BIT-ARRAY2 &OPTIONAL BIT-RESULT)
   (%EXPAND-BIT-OP ORC1 BIT-ARRAY1 BIT-ARRAY2 BIT-RESULT))

(LISP:DEFUN LISP:BIT-ORC2
 (BIT-ARRAY1 BIT-ARRAY2 &OPTIONAL BIT-RESULT)
   (%EXPAND-BIT-OP ORC2 BIT-ARRAY1 BIT-ARRAY2 BIT-RESULT))

(LISP:DEFUN LISP:BIT-VECTOR-P
 (VECTOR)
   (AND (%VECTORP VECTOR)
        (|fetch|
 (ARRAY-HEADER BIT-P) |of|
 VECTOR)))

(LISP:DEFUN LISP:BIT-XOR
 (BIT-ARRAY1 BIT-ARRAY2 &OPTIONAL BIT-RESULT)
   (%EXPAND-BIT-OP XOR BIT-ARRAY1 BIT-ARRAY2 BIT-RESULT))

(LISP:DEFUN LISP:CHAR
 (STRING INDEX)
   (LISP:ASSERT (TYPEP STRING 'STRING)
          (STRING)
          "Not a string: ~S" STRING)
   (LISP:AREF
 STRING INDEX))

(LISP:DEFUN LISP:ARRAYP
 (ARRAY)
   (%ARRAYP ARRAY))

(LISP:DEFUN LISP:STRINGP
 (STRING)
   (%STRINGP STRING))

(LISP:DEFUN COPY-ARRAY
 (FROM-ARRAY &OPTIONAL TO-ARRAY)
   (LISP:IF (NOT (%ARRAYP FROM-ARRAY))
          (LISP:ERROR "Not an array: ~S" FROM-ARRAY))
   (COND
      ((NULL TO-ARRAY)
       (SETQ TO-ARRAY (LISP:MAKE-ARRAY
 (LISP:ARRAY-DIMENSIONS
 FROM-ARRAY)
                             :ELEMENT-TYPE
                             (LISP:ARRAY-ELEMENT-TYPE
 FROM-ARRAY)
                             :FATP
                             (%FAT-STRING-ARRAY-P
 FROM-ARRAY))))
      ((NOT (EQUAL-DIMENSIONS-P
 FROM-ARRAY TO-ARRAY))
       (LISP:ERROR "Dimensionality mismatch")))
   (LISP:IF (|fetch|
 (ARRAY-HEADER READ-ONLY-P) |of|
 TO-ARRAY)
          (%MAKE-ARRAY-WRITEABLE
 TO-ARRAY))
   (LET ((FROM-TYPE-NUMBER (%ARRAY-TYPE-NUMBER
 FROM-ARRAY))
         (TO-TYPE-NUMBER (%ARRAY-TYPE-NUMBER
 TO-ARRAY)))
        (LISP:WHEN (AND (%FAT-CHAR-TYPE-P FROM-TYPE-NUMBER)
                        (%THIN-CHAR-TYPE-P TO-TYPE-NUMBER))
            (%MAKE-STRING-ARRAY-FAT
 TO-ARRAY)
            (SETQ TO-TYPE-NUMBER (%ARRAY-TYPE-NUMBER
 TO-ARRAY)))
        (%FAST-COPY-BASE
 (%ARRAY-BASE
 FROM-ARRAY)
               (%ARRAY-OFFSET
 FROM-ARRAY)
               FROM-TYPE-NUMBER
               (%ARRAY-BASE
 TO-ARRAY)
               (%ARRAY-OFFSET
 TO-ARRAY)
               TO-TYPE-NUMBER
               (|fetch|
 (ARRAY-HEADER TOTAL-SIZE) |of|
 FROM-ARRAY))
        TO-ARRAY))

(LISP:DEFUN COPY-VECTOR
 (FROM-VECTOR TO-VECTOR &KEY (START1 0)
                                   END1
                                   (START2 0)
                                   END2)
   (LET ((FROM-LENGTH (VECTOR-LENGTH
 FROM-VECTOR))
         (TO-LENGTH (VECTOR-LENGTH
 TO-VECTOR)))
        (LISP:IF (NULL END1)
               (SETQ END1 FROM-LENGTH))
        (LISP:IF (NULL END2)
               (SETQ END2 TO-LENGTH))
        (LISP:IF (NOT (<= 0 START1 END1 FROM-LENGTH))
               (LISP:ERROR "Bad subsequence for FROM-VECTOR"))
        (LISP:IF (NOT (<= 0 START2 END2 TO-LENGTH))
               (LISP:ERROR "Bad subsequence for TO-VECTOR"))
        (LISP:IF (|fetch|
 (ARRAY-HEADER READ-ONLY-P) |of|
 TO-VECTOR)
               (%MAKE-ARRAY-WRITEABLE
 TO-VECTOR))
        (LET ((SUBLEN1 (- END1 START1))
              (SUBLEN2 (- END2 START2))
              (FROM-TYPE-NUMBER (%ARRAY-TYPE-NUMBER
 FROM-VECTOR))
              (TO-TYPE-NUMBER (%ARRAY-TYPE-NUMBER
 TO-VECTOR)))
             (LISP:WHEN (AND (%FAT-CHAR-TYPE-P FROM-TYPE-NUMBER)
                             (%THIN-CHAR-TYPE-P TO-TYPE-NUMBER))
                 (%MAKE-STRING-ARRAY-FAT
 TO-VECTOR)
                 (SETQ TO-TYPE-NUMBER (%ARRAY-TYPE-NUMBER
 TO-VECTOR)))
             (%FAST-COPY-BASE
 (%ARRAY-BASE
 FROM-VECTOR)
                    (+ START1 (%ARRAY-OFFSET
 FROM-VECTOR))
                    FROM-TYPE-NUMBER
                    (%ARRAY-BASE
 TO-VECTOR)
                    (+ START2 (%ARRAY-OFFSET
 TO-VECTOR))
                    TO-TYPE-NUMBER
                    (MIN SUBLEN1 SUBLEN2))
             TO-VECTOR)))

(LISP:DEFUN DISPLACED-ARRAY-P
 (ARRAY)
   (LISP:IF (%ARRAYP ARRAY)
       (|fetch|
 (ARRAY-HEADER DISPLACED-P) |of|
 ARRAY)
       (LISP:ERROR "Not an array: ~S" ARRAY)))

(LISP:DEFUN EQUAL-DIMENSIONS-P
 (ARRAY-1 ARRAY-2)
   (COND
      ((%ONED-ARRAY-P
 ARRAY-1)
       (COND
          ((%ONED-ARRAY-P
 ARRAY-2)
           (EQ (|fetch|
 (ARRAY-HEADER TOTAL-SIZE) |of|
 ARRAY-1)
               (|fetch|
 (ARRAY-HEADER TOTAL-SIZE) |of|
 ARRAY-2)))
          ((%TWOD-ARRAY-P
 ARRAY-2)
           NIL)
          ((%GENERAL-ARRAY-P
 ARRAY-2)
           (AND (EQ 1 (LENGTH (|ffetch|
 (GENERAL-ARRAY DIMS) |of|
 ARRAY-2)))
                (EQ (|fetch|
 (ARRAY-HEADER TOTAL-SIZE) |of|
 ARRAY-1)
                    (|fetch|
 (ARRAY-HEADER TOTAL-SIZE) |of|
 ARRAY-2))))
          (T NIL)))
      ((%TWOD-ARRAY-P
 ARRAY-1)
       (COND
          ((%ONED-ARRAY-P
 ARRAY-2)
           NIL)
          ((%TWOD-ARRAY-P
 ARRAY-2)
           (AND (EQ (|ffetch|
 (TWOD-ARRAY BOUND0) |of|
 ARRAY-1)
                    (|ffetch|
 (TWOD-ARRAY BOUND0) |of|
 ARRAY-2))
                (EQ (|ffetch|
 (TWOD-ARRAY BOUND1) |of|
 ARRAY-1)
                    (|ffetch|
 (TWOD-ARRAY BOUND1) |of|
 ARRAY-2))))
          ((%GENERAL-ARRAY-P
 ARRAY-2)
           (LET ((DIMS (|ffetch|
 (GENERAL-ARRAY DIMS) |of|
 ARRAY-2)))
                (AND (EQ 2 (LENGTH DIMS))
                     (AND (EQ (|ffetch|
 (TWOD-ARRAY BOUND0) |of|
 ARRAY-1)
                              (CAR DIMS))
                          (EQ (|ffetch|
 (TWOD-ARRAY BOUND1) |of|
 ARRAY-1)
                              (CADR DIMS))))))
          (T NIL)))
      ((%GENERAL-ARRAY-P
 ARRAY-1)
       (LET ((DIMS (|ffetch|
 (GENERAL-ARRAY DIMS) |of|
 ARRAY-1)))
            (COND
               ((%ONED-ARRAY-P
 ARRAY-2)
                (AND (EQ 1 (LENGTH DIMS))
                     (EQ (|fetch|
 (ARRAY-HEADER TOTAL-SIZE) |of|
 ARRAY-1)
                         (|fetch|
 (ARRAY-HEADER TOTAL-SIZE) |of|
 ARRAY-2))))
               ((%TWOD-ARRAY-P
 ARRAY-2)
                (AND (EQ 2 (LENGTH DIMS))
                     (AND (EQ (CAR DIMS)
                              (|ffetch|
 (TWOD-ARRAY BOUND0) |of|
 ARRAY-2))
                          (EQ (CADR DIMS)
                              (|ffetch|
 (TWOD-ARRAY BOUND1) |of|
 ARRAY-2)))))
               ((%GENERAL-ARRAY-P
 ARRAY-2)
                (EQUAL DIMS (|ffetch|
 (GENERAL-ARRAY DIMS) |of|
 ARRAY-2)))
               (T NIL))))
      (T NIL)))

(LISP:DEFUN EXTENDABLE-ARRAY-P
 (ARRAY)
   
         (* *)


   (COND
      ((%ARRAYP ARRAY)
       (|fetch|
 (ARRAY-HEADER EXTENDABLE-P) |of|
 ARRAY))
      ((STRINGP ARRAY)
       NIL)
      (T (LISP:ERROR "Not an array ~S" ARRAY))))

(LISP:DEFUN FILL-ARRAY
 (ARRAY VALUE)
   (LISP:IF (NOT (%ARRAYP ARRAY))
          (LISP:ERROR "Not an array: ~S" ARRAY))
   (LET ((TOTAL-SIZE (|fetch|
 (ARRAY-HEADER TOTAL-SIZE) |of|
 ARRAY))
         (TYPE-NUMBER (%ARRAY-TYPE-NUMBER
 ARRAY)))
        (LISP:IF (|fetch|
 (ARRAY-HEADER READ-ONLY-P) |of|
 ARRAY)
               (%MAKE-ARRAY-WRITEABLE
 ARRAY))
        (LISP:WHEN (> TOTAL-SIZE 0)
            (LISP:WHEN (AND (%THIN-CHAR-TYPE-P TYPE-NUMBER)
                            (%FAT-STRING-CHAR-P VALUE))
                (%MAKE-STRING-ARRAY-FAT
 ARRAY)
                (SETQ TYPE-NUMBER (%ARRAY-TYPE-NUMBER
 ARRAY)))
            (LISP:IF (NOT (%LLARRAY-TYPEP TYPE-NUMBER VALUE))
                   (LISP:ERROR "Value of incorrect type for this array: ~S" VALUE))
            (LET ((BASE (%ARRAY-BASE
 ARRAY))
                  (OFFSET (%ARRAY-OFFSET
 ARRAY)))        (* \; "Start things off")

                 (%ARRAY-WRITE
 VALUE BASE TYPE-NUMBER OFFSET)
                                                             (* \; "An overlapping blt")

                 (%FAST-COPY-BASE
 BASE OFFSET TYPE-NUMBER BASE (LISP:1+ OFFSET)
                        TYPE-NUMBER
                        (LISP:1- TOTAL-SIZE))))
        ARRAY))

(LISP:DEFUN LISP:FILL-POINTER
 (VECTOR)
   (COND
      ((AND (OR (%ONED-ARRAY-P
 VECTOR)
                (%GENERAL-ARRAY-P
 VECTOR))
            (|fetch|
 (ARRAY-HEADER FILL-POINTER-P) |of|
 VECTOR))
       (|fetch|
 (ARRAY-HEADER FILL-POINTER) |of|
 VECTOR))
      ((%VECTORP VECTOR)
       (LISP:ERROR "vector has no fill pointer"))
      (T (LISP:ERROR "Not a vector: ~S" VECTOR))))

(LISP:DEFUN FILL-VECTOR
 (VECTOR VALUE &KEY (START 0)
                                   END)
   (LISP:IF (NOT (%VECTORP VECTOR))
          (LISP:ERROR "Not a vector: ~S" VECTOR))
   (LET ((TOTAL-SIZE (|fetch|
 (ARRAY-HEADER TOTAL-SIZE) |of|
 VECTOR)))
        (LISP:IF (NULL END)
               (SETQ END TOTAL-SIZE))
        (LISP:IF (NOT (<= START END TOTAL-SIZE))
               (LISP:ERROR "Invalid subsequence" END))
        (LET ((CNT (- END START))
              (TYPE-NUMBER (%ARRAY-TYPE-NUMBER
 VECTOR)))
             (LISP:IF (|fetch|
 (ARRAY-HEADER READ-ONLY-P) |of|
 VECTOR)
                    (%MAKE-ARRAY-WRITEABLE
 VECTOR))
             (LISP:WHEN (> CNT 0)
                 (LISP:WHEN (AND (%THIN-CHAR-TYPE-P TYPE-NUMBER)
                                 (%FAT-STRING-CHAR-P VALUE))
                     (%MAKE-STRING-ARRAY-FAT
 VECTOR)
                     (SETQ TYPE-NUMBER (%ARRAY-TYPE-NUMBER
 VECTOR)))
                 (LISP:IF (NOT (%LLARRAY-TYPEP TYPE-NUMBER VALUE))
                        (LISP:ERROR "Value of incorrect type for this array: ~S" VALUE))
                 (LET ((BASE (%ARRAY-BASE
 VECTOR))
                       (OFFSET (+ START (%ARRAY-OFFSET
 VECTOR))))
                                                             (* \; "Start things off")

                      (%ARRAY-WRITE
 VALUE BASE TYPE-NUMBER OFFSET)
                                                             (* \; "An overlapping blt")

                      (%FAST-COPY-BASE
 BASE OFFSET TYPE-NUMBER BASE (LISP:1+ OFFSET)
                             TYPE-NUMBER
                             (LISP:1- CNT))))
             VECTOR)))

(LISP:DEFUN LISP:MAKE-ARRAY
 (DIMENSIONS &KEY (ELEMENT-TYPE T)
                                       (INITIAL-ELEMENT NIL INITIAL-ELEMENT-P)
                                       (INITIAL-CONTENTS NIL INITIAL-CONTENTS-P)
                                       (DISPLACED-TO NIL DISPLACED-TO-P)
                                       (DISPLACED-TO-BASE NIL DISPLACED-TO-BASE-P)
                                       (DISPLACED-INDEX-OFFSET 0 DISPLACED-INDEX-OFFSET-P)
                                       FILL-POINTER ADJUSTABLE EXTENDABLE FATP READ-ONLY-P)

   (* |;;| "String are by default thin unless FATP is T. DISPLACED-TO-BASE indicates displacement to a raw storage block. READ-ONLY-P indicates a read only array")


   (LISP:IF (NOT (LISP:LISTP DIMENSIONS))
       (SETQ DIMENSIONS (LIST DIMENSIONS)))
   (LISP:IF (LISP:DOLIST (DIM DIMENSIONS NIL)
                (LISP:IF (OR (< DIM 0)
                             (>= DIM LISP:ARRAY-DIMENSION-LIMIT))
                       (RETURN T)))
          (LISP:ERROR "Dimensions out of bounds: ~S" DIMENSIONS))
   (LET ((RANK (LENGTH DIMENSIONS))
         (NELTS (%TOTAL-SIZE
 DIMENSIONS))
         ARRAY)

        (* |;;| "Consistency checks")


        (LISP:IF (>= RANK LISP:ARRAY-RANK-LIMIT)
               (LISP:ERROR "Too many dimensions: ~A" RANK))
        (LISP:IF (>= NELTS LISP:ARRAY-TOTAL-SIZE-LIMIT)
               (LISP:ERROR "Too many elements: ~A" NELTS))
        (LISP:IF (OR (AND DISPLACED-TO-P (OR INITIAL-ELEMENT-P INITIAL-CONTENTS-P DISPLACED-TO-BASE-P
                                             ))
                     (AND DISPLACED-TO-BASE-P (OR INITIAL-ELEMENT-P INITIAL-CONTENTS-P DISPLACED-TO-P
                                                  ))
                     (AND FILL-POINTER (NOT (EQ RANK 1)))
                     (AND DISPLACED-INDEX-OFFSET-P (NOT (OR DISPLACED-TO-P DISPLACED-TO-BASE-P)))
                     (AND INITIAL-ELEMENT-P INITIAL-CONTENTS-P)
                     (AND ADJUSTABLE EXTENDABLE)
                     (AND READ-ONLY-P (OR EXTENDABLE ADJUSTABLE)))
               (LISP:ERROR "Inconsistent options to make-array"))
        (LISP:IF DISPLACED-TO-P
            (COND
               ((NOT (%ARRAYP DISPLACED-TO))
                (LISP:ERROR "Not displaced to an array: ~s" DISPLACED-TO))
               ((NOT (EQUAL (%GET-CANONICAL-CML-TYPE
 ELEMENT-TYPE)
                            (LISP:ARRAY-ELEMENT-TYPE
 DISPLACED-TO)))
                (LISP:ERROR "Not displaced to an array of the same element-type"))
               ((> (+ DISPLACED-INDEX-OFFSET NELTS)
                   (LISP:ARRAY-TOTAL-SIZE
 DISPLACED-TO))
                (LISP:ERROR "Displaced array out of bounds"))))
        (LISP:IF FILL-POINTER
            (COND
               ((EQ FILL-POINTER T)
                (SETQ FILL-POINTER NELTS))
               ((NOT (AND (>= FILL-POINTER 0)
                          (<= FILL-POINTER NELTS)))
                (LISP:ERROR "Fill pointer out of bounds ~A" FILL-POINTER))))

        (* |;;| "Specs ready, make the array by case")


        (SETQ ARRAY (COND
                       (DISPLACED-TO-P (%MAKE-DISPLACED-ARRAY
 NELTS DIMENSIONS ELEMENT-TYPE 
                                              DISPLACED-TO DISPLACED-INDEX-OFFSET FILL-POINTER 
                                              READ-ONLY-P ADJUSTABLE EXTENDABLE))
                       (DISPLACED-TO-BASE (LISP:IF (OR (> RANK 1)
                                                       ADJUSTABLE)
                                              (%MAKE-GENERAL-ARRAY
 NELTS DIMENSIONS ELEMENT-TYPE
                                                     FILL-POINTER FATP READ-ONLY-P ADJUSTABLE 
                                                     EXTENDABLE DISPLACED-TO-BASE 
                                                     DISPLACED-INDEX-OFFSET)
                                              (%MAKE-ONED-ARRAY
 NELTS ELEMENT-TYPE FILL-POINTER 
                                                     FATP READ-ONLY-P EXTENDABLE DISPLACED-TO-BASE 
                                                     DISPLACED-INDEX-OFFSET)))
                       ((AND (EQ RANK 1)
                             (NOT ADJUSTABLE))
                        (%MAKE-ONED-ARRAY
 NELTS ELEMENT-TYPE FILL-POINTER FATP READ-ONLY-P 
                               EXTENDABLE))
                       ((AND (EQ RANK 2)
                             (NOT ADJUSTABLE))
                        (%MAKE-TWOD-ARRAY
 NELTS DIMENSIONS ELEMENT-TYPE FATP READ-ONLY-P 
                               EXTENDABLE))
                       (T (%MAKE-GENERAL-ARRAY
 NELTS DIMENSIONS ELEMENT-TYPE FILL-POINTER FATP 
                                 READ-ONLY-P ADJUSTABLE EXTENDABLE))))

        (* |;;| "Initialize the storage")


        (COND
           (INITIAL-CONTENTS-P (%ARRAY-CONTENT-INITIALIZE
 ARRAY INITIAL-CONTENTS))
           (INITIAL-ELEMENT-P (%ARRAY-ELEMENT-INITIALIZE
 ARRAY INITIAL-ELEMENT)))

        (* |;;| "Return the array")


        ARRAY))

(LISP:DEFUN MAKE-VECTOR
 (SIZE &KEY (ELEMENT-TYPE T)
                                  (INITIAL-ELEMENT NIL INITIAL-ELEMENT-P)
                                  FATP)
   (LISP:IF (OR (< SIZE 0)
                (>= SIZE LISP:ARRAY-TOTAL-SIZE-LIMIT))
          (LISP:ERROR "Size out of bounds: ~s" SIZE))
   (LET ((VECTOR (%MAKE-ONED-ARRAY
 SIZE ELEMENT-TYPE NIL FATP)))
        (LISP:IF INITIAL-ELEMENT-P (FILL-ARRAY
 VECTOR INITIAL-ELEMENT))
        VECTOR))

(LISP:DEFUN READ-ONLY-ARRAY-P
 (ARRAY)
   (LISP:IF (%ARRAYP ARRAY)
       (|fetch|
 (ARRAY-HEADER READ-ONLY-P) |of|
 ARRAY)
       (LISP:ERROR "Not an array: ~S" ARRAY)))

(LISP:DEFUN LISP:SBIT
 (SIMPLE-BIT-ARRAY &REST INDICES)
   (LISP:ASSERT (TYPEP SIMPLE-BIT-ARRAY '(LISP:SIMPLE-ARRAY BIT))
          (SIMPLE-BIT-ARRAY)
          "Not a bit-array: ~S" SIMPLE-BIT-ARRAY)
   (LISP:APPLY #'LISP:AREF SIMPLE-BIT-ARRAY INDICES))

(LISP:DEFUN LISP:SCHAR
 (SIMPLE-STRING INDEX)
   (LISP:ASSERT (TYPEP SIMPLE-STRING 'LISP:SIMPLE-STRING)
          (SIMPLE-STRING)
          "Not a simple-string: ~S" SIMPLE-STRING)
   (LISP:AREF
 SIMPLE-STRING INDEX))

(LISP:DEFUN SET-FILL-POINTER
 (VECTOR NEWVALUE)
   (COND
      ((AND (OR (%ONED-ARRAY-P
 VECTOR)
                (%GENERAL-ARRAY-P
 VECTOR))
            (|fetch|
 (ARRAY-HEADER FILL-POINTER-P) |of|
 VECTOR))
       (LISP:IF (NOT (<= 0 NEWVALUE (|fetch|
 (ARRAY-HEADER TOTAL-SIZE) |of|
 VECTOR)))
              (LISP:ERROR "Fill pointer out of bounds: ~S" NEWVALUE))
       (|replace|
 (ARRAY-HEADER FILL-POINTER) |of|
 VECTOR |with|
 NEWVALUE)
       NEWVALUE)
      ((%VECTORP VECTOR)
       (LISP:ERROR "Vector has no fill pointer"))
      (T (LISP:ERROR "Not a vector: ~S" VECTOR))))

(LISP:DEFUN SIMPLE-ARRAY-P
 (ARRAY)
   (%SIMPLE-ARRAY-P ARRAY))

(LISP:DEFUN LISP:SIMPLE-BIT-VECTOR-P
 (VECTOR)
   (AND (%ONED-ARRAY-P
 VECTOR)
        (|fetch|
 (ARRAY-HEADER SIMPLE-P) |of|
 VECTOR)
        (|fetch|
 (ARRAY-HEADER BIT-P) |of|
 VECTOR)))

(LISP:DEFUN LISP:SIMPLE-STRING-P
 (STRING)
   (%SIMPLE-STRING-P STRING))

(LISP:DEFUN LISP:SIMPLE-VECTOR-P
 (VECTOR)
   (AND (%ONED-ARRAY-P
 VECTOR)
        (|fetch|
 (ARRAY-HEADER SIMPLE-P) |of|
 VECTOR)
        (EQ (LISP:ARRAY-ELEMENT-TYPE
 VECTOR)
            T)))

(LISP:DEFUN STRING-ARRAY-P
 (ARRAY)
   (%CHAR-TYPE-P (%ARRAY-TYPE-NUMBER
 ARRAY)))

(LISP:DEFUN LISP:SVREF
 (LISP:SIMPLE-VECTOR INDEX)
   (LISP:ASSERT (TYPEP LISP:SIMPLE-VECTOR 'LISP:SIMPLE-VECTOR)
          (LISP:SIMPLE-VECTOR)
          "Not a simple-vector: ~S" LISP:SIMPLE-VECTOR)
   (LISP:AREF
 LISP:SIMPLE-VECTOR INDEX))

(LISP:DEFUN LISP::UPGRADED-ARRAY-ELEMENT-TYPE
 (TYPE)
   (%GET-CANONICAL-CML-TYPE
 TYPE))

(LISP:DEFUN VECTOR-LENGTH
 (VECTOR)
   (LISP:IF (%VECTORP VECTOR)
       (|fetch|
 (ARRAY-HEADER FILL-POINTER) |of|
 VECTOR)
       (LISP:ERROR "Not a vector: ~s" VECTOR)))

(LISP:DEFUN LISP:VECTOR-POP
 (VECTOR)
   (COND
      ((AND (OR (%ONED-ARRAY-P
 VECTOR)
                (%GENERAL-ARRAY-P
 VECTOR))
            (|fetch|
 (ARRAY-HEADER FILL-POINTER-P) |of|
 VECTOR))
       (LET ((FILL-POINTER (|fetch|
 (ARRAY-HEADER FILL-POINTER) |of|
 VECTOR)))
            (LISP:IF (<= FILL-POINTER 0)
                   (LISP:ERROR "Can't pop from zero fill pointer"))
            (SETQ FILL-POINTER (LISP:1- FILL-POINTER))
            (|replace|
 (ARRAY-HEADER FILL-POINTER) |of|
 VECTOR |with|
 FILL-POINTER)
            (LISP:AREF
 VECTOR FILL-POINTER)))
      ((%VECTORP VECTOR)
       (LISP:ERROR "Vector has no fill pointer"))
      (T (LISP:ERROR "Not a vector: ~S" VECTOR))))

(LISP:DEFUN LISP:VECTOR-PUSH
 (NEW-ELEMENT VECTOR)
   (COND
      ((AND (OR (%ONED-ARRAY-P
 VECTOR)
                (%GENERAL-ARRAY-P
 VECTOR))
            (|fetch|
 (ARRAY-HEADER FILL-POINTER-P) |of|
 VECTOR))
       (LET ((FILL-POINTER (|fetch|
 (ARRAY-HEADER FILL-POINTER) |of|
 VECTOR)))
            (LISP:WHEN (< FILL-POINTER (|fetch|
 (ARRAY-HEADER TOTAL-SIZE) |of|
 VECTOR))
                (ASET
 NEW-ELEMENT VECTOR FILL-POINTER)
                (|replace|
 (ARRAY-HEADER FILL-POINTER) |of|
 VECTOR |with|
 (LISP:1+ 
                                                                                         FILL-POINTER
                                                                                             ))
                FILL-POINTER)))
      ((%VECTORP VECTOR)
       (LISP:ERROR "Vector has no fill pointer"))
      (T (LISP:ERROR "Not a vector: ~S" VECTOR))))

(LISP:DEFUN LISP:VECTOR-PUSH-EXTEND
 (NEW-ELEMENT VECTOR &OPTIONAL (EXTENSION-SIZE 
                                                                        *DEFAULT-PUSH-EXTENSION-SIZE*
                                                                             ))

   (* |;;| "Like VECTOR-PUSH except if VECTOR is adjustable -- in which case a push beyond (array-total-size VECTOR ) will call adjust-array")


   (LET ((NEW-INDEX (LISP:VECTOR-PUSH
 NEW-ELEMENT VECTOR)))
        (LISP:IF (NULL NEW-INDEX)
            (COND
               ((> EXTENSION-SIZE 0)
                (LISP:ADJUST-ARRAY
 VECTOR (+ (LISP:ARRAY-TOTAL-SIZE
 VECTOR)
                                                 EXTENSION-SIZE))
                (LISP:VECTOR-PUSH
 NEW-ELEMENT VECTOR))
               (T (LISP:ERROR "Extension-size not greater than zero")))
            NEW-INDEX)))

(LISP:DEFUN LISP:VECTORP
 (VECTOR)
   (%VECTORP VECTOR))
(DEFINEQ

(LISP:AREF

  (LAMBDA ARGS                                               (* \; "Edited 11-Dec-87 15:32 by jop")

    (LISP:IF (< ARGS 1)
           (LISP:ERROR "Aref takes at least one arg"))
    (LET ((ARRAY (ARG ARGS 1)))
         (CASE ARGS
             (1 (%AREF0
 ARRAY))
             (2 (%AREF1
 ARRAY (ARG ARGS 2)))
             (3 (%AREF2
 ARRAY (ARG ARGS 2)
                       (ARG ARGS 3)))
             (T (COND
                   ((NOT (EQ (LISP:ARRAY-RANK
 ARRAY)
                             (LISP:1- ARGS)))
                    (LISP:ERROR "Rank mismatch"))
                   (T 
                      (* |;;| "If we've gotten this far ARRAY must be a general array")

                                                             (* \; "Check indices in bounds")

                      (LISP:DO ((I 2 (LISP:1+ I))
                                (DIMLIST (|ffetch|
 (GENERAL-ARRAY DIMS) |of|
 ARRAY)
                                       (CDR DIMLIST))
                                INDEX)
                               ((> I ARGS))
                          (SETQ INDEX (ARG ARGS I))
                          (LISP:IF (NOT (< -1 INDEX (CAR DIMLIST)))
                                 (LISP:ERROR "Index out of bounds: ~s" INDEX)))
                                                             (* \; 

                                                           "Now proceed to extract the element")

                      (LET ((ROW-MAJOR-INDEX (LISP:DO ((I 2 (LISP:1+ I))
                                                       (DIMLIST (CDR (|ffetch|
 (GENERAL-ARRAY
                                                                                    DIMS)
                                                                        |of|
 ARRAY))
                                                              (CDR DIMLIST))
                                                       (TOTAL 0))
                                                      ((EQ I ARGS)
                                                       (+ TOTAL (ARG ARGS ARGS)))
                                                 (SETQ TOTAL (LISP:* (CAR DIMLIST)
                                                                    (+ TOTAL (ARG ARGS I))))))
                            (BASE-ARRAY ARRAY))
                           (%GENERAL-ARRAY-ADJUST-BASE BASE-ARRAY ROW-MAJOR-INDEX)
                           (%ARRAY-READ
 (|fetch|
 (ARRAY-HEADER BASE) |of|
 BASE-ARRAY)
                                  (|fetch|
 (ARRAY-HEADER TYPE-NUMBER) |of|
 BASE-ARRAY)
                                  (+ (%GET-ARRAY-OFFSET BASE-ARRAY)
                                     ROW-MAJOR-INDEX))))))))))

(LISP:ARRAY-IN-BOUNDS-P

  (LAMBDA ARGS                                               (* \; "Edited 11-Dec-87 15:32 by jop")

    (LISP:IF (< ARGS 1)
           (LISP:ERROR "Array-in-bounds-p takes at least one arg"))
    (LET ((ARRAY (ARG ARGS 1)))
         (LISP:IF (EQ (LISP:ARRAY-RANK
 ARRAY)
                      (LISP:1- ARGS))
             (%CHECK-INDICES ARRAY 2 ARGS)
             (LISP:ERROR "Rank mismatch")))))

(LISP:ARRAY-ROW-MAJOR-INDEX

  (LAMBDA ARGS                                               (* \; "Edited 11-Dec-87 15:32 by jop")

    (LISP:IF (< ARGS 1)
           (LISP:ERROR "Array-row-major-index takes at least one arg"))
    (LET ((ARRAY (ARG ARGS 1)))
         (COND
            ((NOT (EQ (LISP:ARRAY-RANK
 ARRAY)
                      (LISP:1- ARGS)))
             (LISP:ERROR "Rank mismatch"))
            ((NOT (%CHECK-INDICES ARRAY 2 ARGS))
             (LISP:ERROR "Index out of bounds"))
            (T (LISP:DO ((I 2 (LISP:1+ I))
                         (TOTAL 0))
                        ((EQ I ARGS)
                         (+ TOTAL (ARG ARGS ARGS)))
                   (SETQ TOTAL (LISP:* (LISP:ARRAY-DIMENSION
 ARRAY (LISP:1- I))
                                      (+ TOTAL (ARG ARGS I))))))))))

(ASET

  (LAMBDA ARGS                                               (* \; "Edited 11-Dec-87 15:33 by jop")

    (LISP:IF (< ARGS 2)
           (LISP:ERROR "Aset takes at least two args"))
    (LET ((NEWVALUE (ARG ARGS 1))
          (ARRAY (ARG ARGS 2)))
         (CASE ARGS
             (2 (%ASET0
 NEWVALUE ARRAY))
             (3 (%ASET1
 NEWVALUE ARRAY (ARG ARGS 3)))
             (4 (%ASET2
 NEWVALUE ARRAY (ARG ARGS 3)
                       (ARG ARGS 4)))
             (T (COND
                   ((NOT (EQ (LISP:ARRAY-RANK
 ARRAY)
                             (- ARGS 2)))
                    (LISP:ERROR "Rank mismatch"))
                   (T                                        (* \; 

                                           "If we've gotten this far array must be a general array")


                      (* |;;| "Check indices")


                      (LISP:DO ((I 3 (LISP:1+ I))
                                (DIMLIST (|ffetch|
 (GENERAL-ARRAY DIMS) |of|
 ARRAY)
                                       (CDR DIMLIST))
                                INDEX)
                               ((> I ARGS))
                          (SETQ INDEX (ARG ARGS I))
                          (LISP:IF (NOT (< -1 INDEX (CAR DIMLIST)))
                                 (LISP:ERROR "Index out of bounds: ~s" INDEX)))

                      (* |;;| "Now proceed to extract the element")


                      (LET ((ROW-MAJOR-INDEX (LISP:DO ((I 3 (LISP:1+ I))
                                                       (DIMLIST (CDR (|ffetch|
 (GENERAL-ARRAY
                                                                                    DIMS)
                                                                        |of|
 ARRAY))
                                                              (CDR DIMLIST))
                                                       (TOTAL 0))
                                                      ((EQ I ARGS)
                                                       (+ TOTAL (ARG ARGS ARGS)))
                                                 (SETQ TOTAL (LISP:* (CAR DIMLIST)
                                                                    (+ TOTAL (ARG ARGS I))))))
                            (BASE-ARRAY ARRAY))
                           (%GENERAL-ARRAY-ADJUST-BASE BASE-ARRAY ROW-MAJOR-INDEX)
                           (LET ((TYPE-NUMBER (|fetch|
 (ARRAY-HEADER TYPE-NUMBER) |of|
 
                                                                                           BASE-ARRAY
                                                     )))
                                (LISP:IF (%CHECK-NOT-WRITEABLE ARRAY TYPE-NUMBER NEWVALUE)
                                    (LISP:APPLY 'ASET NEWVALUE ARRAY (LISP:DO ((I ARGS (LISP:1-
                                                                                        I))
                                                                               LST)
                                                                              ((< I 1)
                                                                               LST)
                                                                         (SETQ LST
                                                                          (CONS (ARG ARGS I)
                                                                                LST))))
                                    (%ARRAY-WRITE
 NEWVALUE (|fetch|
 (ARRAY-HEADER BASE)
                                                                  |of|
 BASE-ARRAY)
                                           TYPE-NUMBER
                                           (+ (%GET-ARRAY-OFFSET BASE-ARRAY)
                                              ROW-MAJOR-INDEX))))))))))))

(LISP:VECTOR

  (LAMBDA ARGS                                               (* \; "Edited 18-Dec-86 18:09 by jop")

    (LET ((VECTOR (%MAKE-ONED-ARRAY
 ARGS T)))
         (LISP:DOTIMES (I ARGS)
             (ASET
 (ARG ARGS (LISP:1+ I))
                    VECTOR I))
         VECTOR)))
)



(* |;;| "New CLtL array functions")


(DEFINEQ


(LISP::ROW-MAJOR-ASET

  (LAMBDA (ARRAY INDEX NEWVALUE)                             (* \; "Edited 11-Dec-87 15:54 by jop")

    (LISP:IF (NOT (AND (>= INDEX 0)
                       (< INDEX (|fetch|
 (ARRAY-HEADER TOTAL-SIZE) |of|
 ARRAY))))
        (LISP:ERROR "Index out of bounds: ~s" INDEX)
        (LET ((ROW-MAJOR-INDEX INDEX)
              (BASE-ARRAY ARRAY))

             (* |;;| "Now proceed to extract the element")


             (%GENERAL-ARRAY-ADJUST-BASE BASE-ARRAY ROW-MAJOR-INDEX)
             (LET ((TYPE-NUMBER (|fetch|
 (ARRAY-HEADER TYPE-NUMBER) |of|
 BASE-ARRAY)))
                  (LISP:IF (%CHECK-NOT-WRITEABLE ARRAY TYPE-NUMBER NEWVALUE)
                      (LISP::ROW-MAJOR-ASET
 ARRAY INDEX NEWVALUE)
                      (%ARRAY-WRITE
 NEWVALUE (|fetch|
 (ARRAY-HEADER BASE) |of|
 BASE-ARRAY
                                                        )
                             TYPE-NUMBER
                             (+ (%GET-ARRAY-OFFSET BASE-ARRAY)
                                ROW-MAJOR-INDEX))))))))
)

(LISP:DEFSETF LISP::ROW-MAJOR-AREF
 LISP::ROW-MAJOR-ASET)



(* |;;| "Setfs")



(LISP:DEFSETF LISP:AREF
 (ARRAY &REST INDICES) (NEWVALUE)
   `(ASET
 ,NEWVALUE ,ARRAY ,@INDICES))

(LISP:DEFSETF BIT
 (ARRAY &REST INDICES) (NEWVALUE)
   `(ASET
 ,NEWVALUE ,ARRAY ,@INDICES))

(LISP:DEFSETF LISP:CHAR
 (ARRAY INDEX) (NEWVALUE)
   `(ASET
 ,NEWVALUE ,ARRAY ,INDEX))

(LISP:DEFSETF LISP:FILL-POINTER
 SET-FILL-POINTER)

(LISP:DEFSETF LISP:SBIT
 (ARRAY &REST INDICES) (NEWVALUE)
   `(ASET
 ,NEWVALUE ,ARRAY ,@INDICES))

(LISP:DEFSETF LISP:SCHAR
 (ARRAY INDEX) (NEWVALUE)
   `(ASET
 ,NEWVALUE ,ARRAY ,INDEX))

(LISP:DEFSETF LISP:SVREF
 (ARRAY INDEX) (NEWVALUE)
   `(ASET
 ,NEWVALUE ,ARRAY ,INDEX))



(* |;;| "Optimizers")



(LISP:DEFUN %AREF-EXPANDER
 (ARRAY INDICES)
   (CASE (LENGTH INDICES)
       (1 `(%AREF1
 ,ARRAY ,@INDICES))
       (2 `(%AREF2
 ,ARRAY ,@INDICES))
       (T 'COMPILER:PASS)))

(LISP:DEFUN %ASET-EXPANDER
 (NEWVALUE ARRAY INDICES)
   (CASE (LENGTH INDICES)
       (1 `(%ASET1
 ,NEWVALUE ,ARRAY ,@INDICES))
       (2 `(%ASET2
 ,NEWVALUE ,ARRAY ,@INDICES))
       (T 'COMPILER:PASS)))

(DEFOPTIMIZER LISP:AREF
 (ARRAY &REST INDICES)
                            (%AREF-EXPANDER
 ARRAY INDICES))

(DEFOPTIMIZER ASET
 (NEWVALUE ARRAY &REST INDICES)
                       (%ASET-EXPANDER
 NEWVALUE ARRAY INDICES))

(DEFOPTIMIZER BIT
 (ARRAY &REST INDICES)
                      (%AREF-EXPANDER
 ARRAY INDICES))

(DEFOPTIMIZER LISP:CHAR
 (STRING INDEX)
                            `(%AREF1
 ,STRING ,INDEX))

(DEFOPTIMIZER LISP:SBIT
 (ARRAY &REST INDICES)
                            (%AREF-EXPANDER
 ARRAY INDICES))

(DEFOPTIMIZER LISP:SCHAR
 (STRING INDEX)
                             `(%AREF1
 ,STRING ,INDEX))

(DEFOPTIMIZER LISP:SVREF
 (LISP:SIMPLE-VECTOR INDEX)
                             `(%AREF1
 ,LISP:SIMPLE-VECTOR ,INDEX))



(* |;;| "Vars etc")





(* \; "*PRINT-ARRAY* is defined in APRINT")



(LISP:DEFCONSTANT LISP:ARRAY-RANK-LIMIT
 (EXPT 2 7))

(LISP:DEFCONSTANT LISP:ARRAY-TOTAL-SIZE-LIMIT
 65534)

(LISP:DEFCONSTANT LISP:ARRAY-DIMENSION-LIMIT
 LISP:ARRAY-TOTAL-SIZE-LIMIT)

(LISP:DEFPARAMETER *DEFAULT-PUSH-EXTENSION-SIZE*
 20)



(* |;;| "Run-time support")


(DEFINEQ

(%ALTER-AS-DISPLACED-ARRAY

  (LAMBDA (ADJUSTABLE-ARRAY DIMENSIONS DISPLACED-TO DISPLACED-INDEX-OFFSET FILL-POINTER)
                                                             (* \; "Edited 18-Dec-86 17:11 by jop")


    (* |;;| 

 "Alter ADJUSTABLE-ARRAY to be displaced to displaced-to. ADJUSTABLE-ARRAY must be a general array")


    (LISP:IF (NULL DISPLACED-INDEX-OFFSET)
           (SETQ DISPLACED-INDEX-OFFSET 0))
    (LET ((DISPLACED-TO-READ-ONLY-P (|fetch|
 (ARRAY-HEADER READ-ONLY-P) |of|
 DISPLACED-TO))
          (TOTAL-SIZE (%TOTAL-SIZE
 DIMENSIONS))
          (OFFSET (OR DISPLACED-INDEX-OFFSET 0))
          BASE NEED-INDIRECTION-P)
         (COND
            ((OR (%THIN-CHAR-TYPE-P (|fetch|
 (ARRAY-HEADER TYPE-NUMBER) |of|
 DISPLACED-TO))
                 (|fetch|
 (ARRAY-HEADER EXTENDABLE-P) |of|
 DISPLACED-TO)
                 (|fetch|
 (ARRAY-HEADER ADJUSTABLE-P) |of|
 DISPLACED-TO)
                 (AND DISPLACED-TO-READ-ONLY-P (NOT (|fetch|
 (ARRAY-HEADER INDIRECT-P)
                                                       |of|
 DISPLACED-TO))))
                                                             (* \; "Provide for indirection")

             (SETQ BASE DISPLACED-TO)
             (SETQ NEED-INDIRECTION-P T))
            (T                                               (* \; 

                                                  "Fold double displacement to single displacement")

               (SETQ BASE (|fetch|
 (ARRAY-HEADER BASE) |of|
 DISPLACED-TO))
               (SETQ OFFSET (+ OFFSET (%GET-ARRAY-OFFSET DISPLACED-TO)))
               (LISP:IF (|fetch|
 (ARRAY-HEADER INDIRECT-P) |of|
 DISPLACED-TO)
                      (SETQ NEED-INDIRECTION-P T))))         (* \; 

                                        "Don't need to touch the type-number since it can't change")

         (UNINTERRUPTABLY
             (|freplace|
 (GENERAL-ARRAY STORAGE) |of|
 ADJUSTABLE-ARRAY |with|
 BASE)
             (|freplace|
 (GENERAL-ARRAY READ-ONLY-P) |of|
 ADJUSTABLE-ARRAY |with|
 
                                                                             DISPLACED-TO-READ-ONLY-P
                    )
             (|freplace|
 (GENERAL-ARRAY INDIRECT-P) |of|
 ADJUSTABLE-ARRAY |with|
 
                                                                                   NEED-INDIRECTION-P
                    )
             (|freplace|
 (GENERAL-ARRAY DISPLACED-P) |of|
 ADJUSTABLE-ARRAY |with|
 T)
             (|freplace|
 (GENERAL-ARRAY FILL-POINTER-P) |of|
 ADJUSTABLE-ARRAY |with|

                                                                                      FILL-POINTER)
             (|freplace|
 (GENERAL-ARRAY OFFSET) |of|
 ADJUSTABLE-ARRAY |with|
 OFFSET)
             (|freplace|
 (GENERAL-ARRAY FILL-POINTER) |of|
 ADJUSTABLE-ARRAY
                |with|
 (OR FILL-POINTER TOTAL-SIZE))
             (|freplace|
 (GENERAL-ARRAY TOTAL-SIZE) |of|
 ADJUSTABLE-ARRAY |with|
 
                                                                                        TOTAL-SIZE)
             (|freplace|
 (GENERAL-ARRAY DIMS) |of|
 ADJUSTABLE-ARRAY |with|
 DIMENSIONS))
         ADJUSTABLE-ARRAY)))

(%ALTER-AS-DISPLACED-TO-BASE-ARRAY

  (LAMBDA (ADJUSTABLE-ARRAY DIMENSIONS ELEMENT-TYPE DISPLACED-TO-BASE DISPLACED-INDEX-OFFSET 
                 FILL-POINTER FATP)                          (* \; "Edited 18-Dec-86 17:12 by jop")


    (* |;;| "Alter adjustable-array to be displaced to displaced-to-base ")


    (LET ((TOTAL-SIZE (%TOTAL-SIZE
 DIMENSIONS))
          (TYPE-NUMBER (%CML-TYPE-TO-TYPENUMBER
 ELEMENT-TYPE FATP)))
         (UNINTERRUPTABLY
             (|freplace|
 (GENERAL-ARRAY STORAGE) |of|
 ADJUSTABLE-ARRAY |with|
 
                                                                                    DISPLACED-TO-BASE
                    )
             (|freplace|
 (GENERAL-ARRAY INDIRECT-P) |of|
 ADJUSTABLE-ARRAY |with|
 NIL)
             (|freplace|
 (GENERAL-ARRAY DISPLACED-P) |of|
 ADJUSTABLE-ARRAY |with|
 T)
             (|freplace|
 (GENERAL-ARRAY FILL-POINTER-P) |of|
 ADJUSTABLE-ARRAY |with|

                                                                                      FILL-POINTER)
             (|freplace|
 (GENERAL-ARRAY TYPE-NUMBER) |of|
 ADJUSTABLE-ARRAY |with|
 
                                                                                         TYPE-NUMBER)
             (|freplace|
 (GENERAL-ARRAY OFFSET) |of|
 ADJUSTABLE-ARRAY |with|
 (OR 
                                                                               DISPLACED-INDEX-OFFSET
                                                                                             0))
             (|freplace|
 (GENERAL-ARRAY FILL-POINTER) |of|
 ADJUSTABLE-ARRAY
                |with|
 (OR FILL-POINTER TOTAL-SIZE))
             (|freplace|
 (GENERAL-ARRAY TOTAL-SIZE) |of|
 ADJUSTABLE-ARRAY |with|
 
                                                                                        TOTAL-SIZE)
             (|freplace|
 (GENERAL-ARRAY DIMS) |of|
 ADJUSTABLE-ARRAY |with|
 DIMENSIONS))
         ADJUSTABLE-ARRAY)))

(%AREF0

  (LAMBDA (ARRAY)                                            (* \; "Edited 11-Dec-87 15:33 by jop")


    (* |;;| "Special aref for the zero dimensional case")


    (LISP:IF (EQ (LISP:ARRAY-RANK
 ARRAY)
                 0)
        (LET ((INDEX 0)
              (BASE-ARRAY ARRAY))

             (* |;;| "Must be a general array")


             (%GENERAL-ARRAY-ADJUST-BASE BASE-ARRAY INDEX)
             (%ARRAY-READ
 (|fetch|
 (ARRAY-HEADER BASE) |of|
 BASE-ARRAY)
                    (|fetch|
 (ARRAY-HEADER TYPE-NUMBER) |of|
 BASE-ARRAY)
                    (+ (%GET-ARRAY-OFFSET BASE-ARRAY)
                       INDEX)))
        (LISP:ERROR "Rank mismatch"))))

(%AREF1

  (LAMBDA (ARRAY INDEX)                                      (* \; "Edited 11-Dec-87 15:50 by jop")


    (* |;;| "specialized aref for the one-d case. Also the punt function for the aref1 opcode.")


    (COND
       ((NOT (EQ (LISP:ARRAY-RANK
 ARRAY)
                 1))
        (LISP:ERROR "Rank mismatch"))
       ((NOT (AND (>= INDEX 0)
                  (< INDEX (|fetch|
 (ARRAY-HEADER TOTAL-SIZE) |of|
 ARRAY))))
        (LISP:ERROR "Index out of bounds: ~A" INDEX))
       (T 
          (* |;;| "Now proceed to extract the element")


          (LET ((BASE-ARRAY ARRAY))
               (%GENERAL-ARRAY-ADJUST-BASE BASE-ARRAY INDEX)
               (%ARRAY-READ
 (|fetch|
 (ARRAY-HEADER BASE) |of|
 BASE-ARRAY)
                      (|fetch|
 (ARRAY-HEADER TYPE-NUMBER) |of|
 BASE-ARRAY)
                      (+ (%GET-ARRAY-OFFSET BASE-ARRAY)
                         INDEX)))))))

(%AREF2

  (LAMBDA (ARRAY I J)                                        (* \; "Edited 11-Dec-87 15:33 by jop")


    (* |;;| "Specialized aref for the two-d case. Also the punt function for the aref 2 opcode.")


    (LISP:IF (EQ (LISP:ARRAY-RANK
 ARRAY)
                 2)
        (LET (BOUND0 BOUND1 OFFSET)                          (* \; 

                                                           " ARRAY must be two-d or general")


             (* |;;| "Get bounds and offset")


             (COND
                ((%TWOD-ARRAY-P
 ARRAY)                   (* \; "Twod array case")

                 (SETQ BOUND0 (|ffetch|
 (TWOD-ARRAY BOUND0) |of|
 ARRAY))
                 (SETQ BOUND1 (|ffetch|
 (TWOD-ARRAY BOUND1) |of|
 ARRAY))
                 (SETQ OFFSET 0))
                (T                                           (* \; "General array case")

                   (SETQ BOUND0 (CAR (|ffetch|
 (GENERAL-ARRAY DIMS) |of|
 ARRAY)))
                   (SETQ BOUND1 (CADR (|ffetch|
 (GENERAL-ARRAY DIMS) |of|
 ARRAY)))
                   (SETQ OFFSET (|ffetch|
 (GENERAL-ARRAY OFFSET) |of|
 ARRAY))))
                                                             (* \; "Check indices")

             (COND
                ((NOT (< -1 I BOUND0))
                 (LISP:ERROR "Index out of bounds: ~A" I))
                ((NOT (< -1 J BOUND1))
                 (LISP:ERROR "Index out of bounds: ~A" J)))  (* \; "Extract the element")

             (LET ((ROW-MAJOR-INDEX (+ J (LISP:* BOUND1 I)))
                   (BASE-ARRAY ARRAY))
                  (%GENERAL-ARRAY-ADJUST-BASE BASE-ARRAY ROW-MAJOR-INDEX)
                  (%ARRAY-READ
 (|fetch|
 (ARRAY-HEADER BASE) |of|
 BASE-ARRAY)
                         (|fetch|
 (ARRAY-HEADER TYPE-NUMBER) |of|
 BASE-ARRAY)
                         (+ (%GET-ARRAY-OFFSET BASE-ARRAY)
                            ROW-MAJOR-INDEX))))
        (LISP:ERROR "Rank mismatch"))))

(%ARRAY-BASE

  (LAMBDA (ARRAY)                                            (* \; "Edited 18-Dec-86 17:20 by jop")

    (COND
       ((OR (%ONED-ARRAY-P
 ARRAY)
            (%TWOD-ARRAY-P
 ARRAY))
        (|fetch|
 (ARRAY-HEADER BASE) |of|
 ARRAY))
       ((%GENERAL-ARRAY-P
 ARRAY)
        (|fetch|
 (ARRAY-HEADER BASE) |of|
 (LISP:LOOP (LISP:IF (NOT (|fetch|
 (ARRAY-HEADER
                                                                                         INDIRECT-P)
                                                                              |of|
 ARRAY))
                                                                    (RETURN ARRAY))
                                                         (SETQ ARRAY (|fetch|
 (ARRAY-HEADER
                                                                                   BASE) |of|

                                                                                         ARRAY)))))
       (T (LISP:ERROR "Not an array: ~S" ARRAY)))))

(%ARRAY-CONTENT-INITIALIZE

  (LAMBDA (ARRAY INITIAL-CONTENTS)                           (* \; "Edited 11-Dec-87 15:33 by jop")

    (LISP:IF (EQ 0 (LISP:ARRAY-RANK
 ARRAY))
        (%ARRAY-ELEMENT-INITIALIZE
 ARRAY INITIAL-CONTENTS)
        (LET ((DIMS (LISP:ARRAY-DIMENSIONS
 ARRAY)))
             (LISP:IF (%CHECK-SEQUENCE-DIMENSIONS
 DIMS INITIAL-CONTENTS)
                 (%FILL-ARRAY-FROM-SEQUENCE
 DIMS INITIAL-CONTENTS (%FLATTEN-ARRAY
 ARRAY)
                        0)
                 (LISP:ERROR "Dimensionality mismatch for Initial-contents"))))))

(%ARRAY-ELEMENT-INITIALIZE

  (LAMBDA (ARRAY INITIAL-ELEMENT)                            (* \; "Edited 11-Dec-87 15:33 by jop")


    (* |;;| "Initialize an array with a value")


    (LISP:UNLESS (EQ INITIAL-ELEMENT (%TYPENUMBER-TO-DEFAULT-VALUE (%ARRAY-TYPE-NUMBER
 ARRAY)))
           (FILL-ARRAY
 ARRAY INITIAL-ELEMENT))))

(%ARRAY-OFFSET

  (LAMBDA (ARRAY)                                            (* \; "Edited 18-Dec-86 17:22 by jop")


    (* |;;| "Get the true offset for ARRAY")


    (COND
       ((%ONED-ARRAY-P
 ARRAY)
        (|fetch|
 (ARRAY-HEADER OFFSET) |of|
 ARRAY))
       ((%TWOD-ARRAY-P
 ARRAY)
        0)
       ((%GENERAL-ARRAY-P
 ARRAY)
        (LISP:DO ((OFFSET (|fetch|
 (ARRAY-HEADER OFFSET) |of|
 ARRAY)
                         (+ OFFSET (%GET-ARRAY-OFFSET ARRAY))))
                 ((NOT (|fetch|
 (ARRAY-HEADER INDIRECT-P) |of|
 ARRAY))
                  OFFSET)
            (SETQ ARRAY (|fetch|
 (ARRAY-HEADER BASE) |of|
 ARRAY))))
       (T (LISP:ERROR "Not an array: ~S" ARRAY)))))

(%ARRAY-TYPE-NUMBER

  (LAMBDA (ARRAY)                                            (* \; "Edited 18-Dec-86 17:23 by jop")


    (* |;;| "Get the true array-typenumber for ARRAY")


    (COND
       ((OR (%ONED-ARRAY-P
 ARRAY)
            (%TWOD-ARRAY-P
 ARRAY))
        (|fetch|
 (ARRAY-HEADER TYPE-NUMBER) |of|
 ARRAY))
       ((%GENERAL-ARRAY-P
 ARRAY)
        (|fetch|
 (ARRAY-HEADER TYPE-NUMBER) |of|
 (LISP:LOOP (LISP:IF
                                                                     (NOT (|fetch|
 (ARRAY-HEADER
                                                                                        INDIRECT-P)
                                                                             |of|
 ARRAY))
                                                                     (RETURN ARRAY))
                                                                (SETQ ARRAY (|fetch|
 (
                                                                                         ARRAY-HEADER
                                                                                          BASE)
                                                                               |of|
 ARRAY)))))
       (T (LISP:ERROR "Not an array: ~S" ARRAY)))))

(%ASET0

  (LAMBDA (NEWVALUE ARRAY)                                   (* \; "Edited 11-Dec-87 15:33 by jop")


    (* |;;| "Specialized aset for the zero-d case.")


    (LISP:IF (EQ (LISP:ARRAY-RANK
 ARRAY)
                 0)
        (LET ((INDEX 0)
              (BASE-ARRAY ARRAY))

             (* |;;| "Must be a general array")


             (%GENERAL-ARRAY-ADJUST-BASE BASE-ARRAY INDEX)
             (LET ((TYPE-NUMBER (|fetch|
 (ARRAY-HEADER TYPE-NUMBER) |of|
 BASE-ARRAY)))
                  (LISP:IF (%CHECK-NOT-WRITEABLE ARRAY TYPE-NUMBER NEWVALUE)
                      (%ASET0
 NEWVALUE ARRAY)
                      (%ARRAY-WRITE
 NEWVALUE (|fetch|
 (ARRAY-HEADER BASE) |of|
 BASE-ARRAY
                                                        )
                             TYPE-NUMBER
                             (+ (%GET-ARRAY-OFFSET BASE-ARRAY)
                                INDEX)))))
        (LISP:ERROR "Rank mismatch"))))

(%ASET1

  (LAMBDA (NEWVALUE ARRAY INDEX)                             (* \; "Edited 11-Dec-87 15:34 by jop")


    (* |;;| "Specialized aset for the one-d case. Also the punt for the aset1 opcode.")


    (COND
       ((NOT (EQ (LISP:ARRAY-RANK
 ARRAY)
                 1))
        (LISP:ERROR "Rank mismatch"))
       ((NOT (AND (>= INDEX 0)
                  (< INDEX (|fetch|
 (ARRAY-HEADER TOTAL-SIZE) |of|
 ARRAY))))
        (LISP:ERROR "Index out of bounds: ~s" INDEX))
       (T 
          (* |;;| "Now proceed to extract the element")


          (LET ((ROW-MAJOR-INDEX INDEX)
                (BASE-ARRAY ARRAY))
               (%GENERAL-ARRAY-ADJUST-BASE BASE-ARRAY ROW-MAJOR-INDEX)
               (LET ((TYPE-NUMBER (|fetch|
 (ARRAY-HEADER TYPE-NUMBER) |of|
 BASE-ARRAY)))
                    (LISP:IF (%CHECK-NOT-WRITEABLE ARRAY TYPE-NUMBER NEWVALUE)
                        (%ASET1
 NEWVALUE ARRAY INDEX)
                        (%ARRAY-WRITE
 NEWVALUE (|fetch|
 (ARRAY-HEADER BASE) |of|
 
                                                                                          BASE-ARRAY)
                               TYPE-NUMBER
                               (+ (%GET-ARRAY-OFFSET BASE-ARRAY)
                                  ROW-MAJOR-INDEX)))))))))

(%ASET2

  (LAMBDA (NEWVALUE ARRAY I J)                               (* \; "Edited 11-Dec-87 15:34 by jop")


    (* |;;| "Specialized aset for the two-d case. Also the punt function for the aset2 opcode.")


    (LISP:IF (EQ (LISP:ARRAY-RANK
 ARRAY)
                 2)
        (LET (BOUND0 BOUND1 OFFSET)

             (* |;;| "Get bounds and offset")


             (COND
                ((%TWOD-ARRAY-P
 ARRAY)                   (* \; "Twod case")

                 (SETQ BOUND0 (|ffetch|
 (TWOD-ARRAY BOUND0) |of|
 ARRAY))
                 (SETQ BOUND1 (|ffetch|
 (TWOD-ARRAY BOUND1) |of|
 ARRAY))
                 (SETQ OFFSET 0))
                (T                                           (* \; "General Case")

                   (SETQ BOUND0 (CAR (|ffetch|
 (GENERAL-ARRAY DIMS) |of|
 ARRAY)))
                   (SETQ BOUND1 (CADR (|ffetch|
 (GENERAL-ARRAY DIMS) |of|
 ARRAY)))
                   (SETQ OFFSET (|ffetch|
 (GENERAL-ARRAY OFFSET) |of|
 ARRAY))))

             (* |;;| "Check indices")


             (COND
                ((NOT (< -1 I BOUND0))
                 (LISP:ERROR "Index out of bounds ~s" I))
                ((NOT (< -1 J BOUND1))
                 (LISP:ERROR "Index out of bounds ~s" J)))

             (* |;;| "Set element")


             (LET ((ROW-MAJOR-INDEX (+ J (LISP:* BOUND1 I)))
                   (BASE-ARRAY ARRAY))
                  (%GENERAL-ARRAY-ADJUST-BASE BASE-ARRAY ROW-MAJOR-INDEX)
                  (LET ((TYPE-NUMBER (|fetch|
 (ARRAY-HEADER TYPE-NUMBER) |of|
 BASE-ARRAY)))
                       (LISP:IF (%CHECK-NOT-WRITEABLE ARRAY TYPE-NUMBER NEWVALUE)
                           (%ASET2
 NEWVALUE ARRAY I J)
                           (%ARRAY-WRITE
 NEWVALUE (|fetch|
 (ARRAY-HEADER BASE) |of|

                                                                                       BASE-ARRAY)
                                  TYPE-NUMBER
                                  (+ (%GET-ARRAY-OFFSET BASE-ARRAY)
                                     ROW-MAJOR-INDEX))))))
        (LISP:ERROR "Rank mismatch"))))

(%CHECK-SEQUENCE-DIMENSIONS

  (LAMBDA (DIM-LST SEQUENCE)                                 (* \; "Edited 11-Dec-87 15:34 by jop")


    (* |;;| "Returns NIL if there is a mismatch")


    (LISP:IF (EQ (CAR DIM-LST)
                 (LISP:LENGTH SEQUENCE))
        (OR (NULL (CDR DIM-LST))
            (LISP:DOTIMES (I (CAR DIM-LST)
                             T)
                (LISP:IF (NOT (%CHECK-SEQUENCE-DIMENSIONS
 (CDR DIM-LST)
                                     (LISP:ELT SEQUENCE I)))
                       (RETURN NIL)))))))

(%COPY-TO-NEW-ARRAY

  (LAMBDA (OLD-DIMS OLD-ARRAY OLD-OFFSET NEW-DIMS NEW-ARRAY NEW-OFFSET)
                                                             (* \; "Edited 13-Feb-87 15:52 by jop")


    (* |;;| "It is assumed that OLD-ARRAY and NEW-ARRAY are of the same rank")


    (LET ((SIZE (MIN (CAR OLD-DIMS)
                     (CAR NEW-DIMS))))
         (LISP:IF (CDR OLD-DIMS)
             (LISP:DOTIMES (I SIZE)
                 (%COPY-TO-NEW-ARRAY
 (CDR OLD-DIMS)
                        OLD-ARRAY
                        (LISP:* (CADR OLD-DIMS)
                               (+ OLD-OFFSET I))
                        (CDR NEW-DIMS)
                        NEW-ARRAY
                        (LISP:* (CADR NEW-DIMS)
                               (+ NEW-OFFSET I))))
             (%FAST-COPY-BASE
 (%ARRAY-BASE
 OLD-ARRAY)
                    (+ (%ARRAY-OFFSET
 OLD-ARRAY)
                       OLD-OFFSET)
                    (%ARRAY-TYPE-NUMBER
 OLD-ARRAY)
                    (%ARRAY-BASE
 NEW-ARRAY)
                    (+ (%ARRAY-OFFSET
 NEW-ARRAY)
                       NEW-OFFSET)
                    (%ARRAY-TYPE-NUMBER
 NEW-ARRAY)
                    SIZE)))))

(%DO-LOGICAL-OP

  (LAMBDA (OP SOURCE DEST)                                   (* \; "Edited 18-Dec-86 17:43 by jop")

    (LET ((SOURCE-BASE (%ARRAY-BASE
 SOURCE))
          (SOURCE-OFFSET (%ARRAY-OFFSET
 SOURCE))
          (SOURCE-SIZE (LISP:ARRAY-TOTAL-SIZE
 SOURCE))
          (DEST-BASE (%ARRAY-BASE
 DEST))
          (DEST-OFFSET (%ARRAY-OFFSET
 DEST))
          (GBBT (DEFERREDCONSTANT (|create|
 PILOTBBT
                                         PBTHEIGHT _ 1
                                         PBTDISJOINT _ T)))
          SOURCE-OP LOG-OP)
         (UNINTERRUPTABLY
             (|replace|
 (PILOTBBT PBTSOURCE) |of|
 GBBT |with|
 SOURCE-BASE)
             (|replace|
 (PILOTBBT PBTSOURCEBIT) |of|
 GBBT |with|
 SOURCE-OFFSET)
             (|replace|
 (PILOTBBT PBTDEST) |of|
 GBBT |with|
 DEST-BASE)
             (|replace|
 (PILOTBBT PBTDESTBIT) |of|
 GBBT |with|
 DEST-OFFSET)
             (|replace|
 (PILOTBBT PBTDESTBPL) |of|
 GBBT |with|
 SOURCE-SIZE)
             (|replace|
 (PILOTBBT PBTSOURCEBPL) |of|
 GBBT |with|
 SOURCE-SIZE)
             (|replace|
 (PILOTBBT PBTWIDTH) |of|
 GBBT |with|
 SOURCE-SIZE)
             (CASE OP
                 (COPY 
                    (SETQ SOURCE-OP 0)
                    (SETQ LOG-OP 0))
                 (NOT 
                    (SETQ SOURCE-OP 1)
                    (SETQ LOG-OP 0))
                 (AND 
                    (SETQ SOURCE-OP 0)
                    (SETQ LOG-OP 1))
                 (CAND 
                    (SETQ SOURCE-OP 1)
                    (SETQ LOG-OP 1))
                 (OR 
                    (SETQ SOURCE-OP 0)
                    (SETQ LOG-OP 2))
                 (COR 
                    (SETQ SOURCE-OP 1)
                    (SETQ LOG-OP 2))
                 (XOR 
                    (SETQ SOURCE-OP 0)
                    (SETQ LOG-OP 3))
                 (CXOR 
                    (SETQ SOURCE-OP 1)
                    (SETQ LOG-OP 3)))
             (|replace|
 (PILOTBBT PBTSOURCETYPE) |of|
 GBBT |with|
 SOURCE-OP)
             (|replace|
 (PILOTBBT PBTOPERATION) |of|
 GBBT |with|
 LOG-OP)
                                                             (* \; "Execute the BLT")

             (\\PILOTBITBLT GBBT 0)
             DEST))))

(%EXTEND-ARRAY

  (LAMBDA (EXTENDABLE-ARRAY NEW-ARRAY DIMENSIONS FILL-POINTER)
                                                             (* \; "Edited 18-Dec-86 17:43 by jop")


    (* |;;| "Extend ADJUSTABLE-ARRAY, using the base provided by NEW-ARRAY ")


    (LET ((TYPE-NUMBER (|fetch|
 (ARRAY-HEADER TYPE-NUMBER) |of|
 NEW-ARRAY))
          (TOTAL-SIZE (%TOTAL-SIZE
 DIMENSIONS))
          (BASE (|fetch|
 (ARRAY-HEADER BASE) |of|
 NEW-ARRAY)))
         (UNINTERRUPTABLY
             (|replace|
 (ARRAY-HEADER BASE) |of|
 EXTENDABLE-ARRAY |with|
 BASE)
             (|replace|
 (ARRAY-HEADER READ-ONLY-P) |of|
 EXTENDABLE-ARRAY |with|
 NIL)
             (|replace|
 (ARRAY-HEADER TYPE-NUMBER) |of|
 EXTENDABLE-ARRAY |with|
 
                                                                                       TYPE-NUMBER)
             (|replace|
 (ARRAY-HEADER TOTAL-SIZE) |of|
 EXTENDABLE-ARRAY |with|
 TOTAL-SIZE
                    )
             (COND
                ((%TWOD-ARRAY-P
 EXTENDABLE-ARRAY)
                 (|freplace|
 (TWOD-ARRAY BOUND0) |of|
 EXTENDABLE-ARRAY |with|

                                                                               (CAR DIMENSIONS))
                 (|freplace|
 (TWOD-ARRAY BOUND1) |of|
 EXTENDABLE-ARRAY |with|

                                                                               (CADR DIMENSIONS)))
                (T                                           (* \; "must be oned or general")

                   (|replace|
 (ARRAY-HEADER DISPLACED-P) |of|
 EXTENDABLE-ARRAY |with|

                                                                                       NIL)
                   (|replace|
 (ARRAY-HEADER FILL-POINTER-P) |of|
 EXTENDABLE-ARRAY
                      |with|
 FILL-POINTER)
                   (|replace|
 (ARRAY-HEADER OFFSET) |of|
 EXTENDABLE-ARRAY |with|
 0)
                   (|replace|
 (ARRAY-HEADER FILL-POINTER) |of|
 EXTENDABLE-ARRAY
                      |with|
 (OR FILL-POINTER TOTAL-SIZE))
                   (LISP:WHEN (%GENERAL-ARRAY-P
 EXTENDABLE-ARRAY)
                       (|freplace|
 (GENERAL-ARRAY INDIRECT-P) |of|
 EXTENDABLE-ARRAY
                          |with|
 NIL)
                       (|freplace|
 (GENERAL-ARRAY DIMS) |of|
 EXTENDABLE-ARRAY |with|

                                                                                      DIMENSIONS)))))
         EXTENDABLE-ARRAY)))

(%FAST-COPY-BASE

  (LAMBDA (FROM-BASE FROM-OFFSET FROM-TYPENUMBER TO-BASE TO-OFFSET TO-TYPENUMBER CNT)
                                                             (* \; "Edited 11-Dec-87 15:34 by jop")


    (* |;;| "Blts one array into another of the same element-type")


    (LISP:IF (OR (NOT (EQ FROM-TYPENUMBER TO-TYPENUMBER))
                 (EQ (%TYPENUMBER-TO-GC-TYPE TO-TYPENUMBER)
                     PTRBLOCK.GCT))
        (LISP:DO ((I FROM-OFFSET (LISP:1+ I))
                  (LIMIT (+ FROM-OFFSET CNT))
                  (J TO-OFFSET (LISP:1+ J)))
                 ((EQ I LIMIT))
            (%ARRAY-WRITE
 (%ARRAY-READ
 FROM-BASE FROM-TYPENUMBER I)
                   TO-BASE TO-TYPENUMBER J))
        (LET ((BITS-PER-ELEMENT (%TYPENUMBER-TO-BITS-PER-ELEMENT TO-TYPENUMBER))
              (PBBT (DEFERREDCONSTANT (|create|
 PILOTBBT
                                             PBTDISJOINT _ T
                                             PBTSOURCETYPE _ 0
                                             PBTOPERATION _ 0))))

             (* |;;| "Uses \\PILOTBITBLT instead of \\BLT because offsets might not be word aligned, and BITS-PER-ELEMENT may be greater than BITSPERWORD (16). ")


             (UNINTERRUPTABLY
                 (|freplace|
 (PILOTBBT PBTSOURCE) |of|
 PBBT |with|
 FROM-BASE)
                 (|freplace|
 (PILOTBBT PBTSOURCEBIT) |of|
 PBBT |with|
 (LISP:* 
                                                                                     BITS-PER-ELEMENT
                                                                                         FROM-OFFSET)
                        )
                 (|freplace|
 (PILOTBBT PBTDEST) |of|
 PBBT |with|
 TO-BASE)
                 (|freplace|
 (PILOTBBT PBTDESTBIT) |of|
 PBBT |with|
 (LISP:* 
                                                                                     BITS-PER-ELEMENT
                                                                                       TO-OFFSET))
                 (|freplace|
 (PILOTBBT PBTDESTBPL) |of|
 PBBT |with|
 BITS-PER-ELEMENT)
                 (|freplace|
 (PILOTBBT PBTSOURCEBPL) |of|
 PBBT |with|
 BITS-PER-ELEMENT)
                 (|freplace|
 (PILOTBBT PBTWIDTH) |of|
 PBBT |with|
 BITS-PER-ELEMENT)
                 (|freplace|
 (PILOTBBT PBTHEIGHT) |of|
 PBBT |with|
 CNT)
                 (\\PILOTBITBLT PBBT 0))
             NIL))))

(%FAT-STRING-ARRAY-P

  (LAMBDA (ARRAY)                                            (* \; "Edited 18-Dec-86 17:44 by jop")

    (%FAT-CHAR-TYPE-P (%ARRAY-TYPE-NUMBER
 ARRAY))))

(%FILL-ARRAY-FROM-SEQUENCE

  (LAMBDA (DIMS SEQUENCE FLATTENED-ARRAY OFFSET)             (* \; "Edited 11-Dec-87 15:34 by jop")

    (LISP:IF (CDR DIMS)
        (LISP:DOTIMES (I (CAR DIMS))
            (%FILL-ARRAY-FROM-SEQUENCE
 (CDR DIMS)
                   (LISP:ELT SEQUENCE I)
                   FLATTENED-ARRAY
                   (LISP:* (CADR DIMS)
                          (+ OFFSET I))))
        (LISP:DO ((I 0 (LISP:1+ I))
                  (J OFFSET (LISP:1+ J))
                  (LIMIT (CAR DIMS)))
                 ((EQ I LIMIT))
            (ASET
 (LISP:ELT SEQUENCE I)
                   FLATTENED-ARRAY J)))))

(%FLATTEN-ARRAY

  (LAMBDA (ARRAY)                                            (* \; "Edited 11-Dec-87 15:34 by jop")


    (* |;;| 

  "Make a oned-array that shares storage with array.  If array is already oned then return array")


    (LISP:IF (EQ 1 (LISP:ARRAY-RANK
 ARRAY))
        ARRAY
        (LISP:MAKE-ARRAY
 (LISP:ARRAY-TOTAL-SIZE
 ARRAY)
               :ELEMENT-TYPE
               (LISP:ARRAY-ELEMENT-TYPE
 ARRAY)
               :DISPLACED-TO ARRAY))))

(%MAKE-ARRAY-WRITEABLE

  (LAMBDA (ARRAY)                                            (* \; "Edited 18-Dec-86 18:40 by jop")

    (LISP:IF (NOT (%ARRAYP ARRAY))
           (LISP:ERROR "Not an array: ~S" ARRAY))
    (LET ((BASE-ARRAY ARRAY)
          NEW-BASE OFFSET TOTAL-SIZE TYPE-NUMBER)

         (* |;;| "Find the base array")


         (LISP:IF (|fetch|
 (ARRAY-HEADER INDIRECT-P) |of|
 ARRAY)
             (LISP:LOOP (LISP:IF (|fetch|
 (ARRAY-HEADER INDIRECT-P) |of|
 BASE-ARRAY)
                            (SETQ BASE-ARRAY (|fetch|
 (ARRAY-HEADER BASE) |of|
 BASE-ARRAY))
                            (RETURN NIL))))
         (LISP:WHEN (|fetch|
 (ARRAY-HEADER READ-ONLY-P) |of|
 BASE-ARRAY)

             (* |;;| "Allocate the new storage")

                                                             (* \; "Be careful about offsets")

             (SETQ TOTAL-SIZE (|fetch|
 (ARRAY-HEADER TOTAL-SIZE) |of|
 BASE-ARRAY))
             (SETQ OFFSET (%GET-ARRAY-OFFSET BASE-ARRAY))
             (SETQ TYPE-NUMBER (|fetch|
 (ARRAY-HEADER TYPE-NUMBER) |of|
 BASE-ARRAY))
             (SETQ NEW-BASE (%MAKE-ARRAY-STORAGE
 (+ TOTAL-SIZE OFFSET)
                                   TYPE-NUMBER))

             (* |;;| "Initialize it")


             (%FAST-COPY-BASE
 (|fetch|
 (ARRAY-HEADER BASE) |of|
 BASE-ARRAY)
                    OFFSET TYPE-NUMBER NEW-BASE OFFSET TYPE-NUMBER TOTAL-SIZE)

             (* |;;| "Smash the new base into the array-header")


             (UNINTERRUPTABLY
                 (|replace|
 (ARRAY-HEADER BASE) |of|
 BASE-ARRAY |with|
 NEW-BASE)
                 (|replace|
 (ARRAY-HEADER READ-ONLY-P) |of|
 BASE-ARRAY |with|
 NIL)))

         (* |;;| "Declare the array (and all arrays on its access chain) readable")


         (UNINTERRUPTABLY
             (LISP:DO ((NEXT-ARRAY ARRAY (|fetch|
 (ARRAY-HEADER BASE) |of|
 NEXT-ARRAY)))
                      ((NOT (|fetch|
 (ARRAY-HEADER INDIRECT-P) |of|
 NEXT-ARRAY)))
                 (|replace|
 (ARRAY-HEADER READ-ONLY-P) |of|
 NEXT-ARRAY |with|
 NIL)))

         (* |;;| "return the original array")


         ARRAY)))

(%MAKE-DISPLACED-ARRAY

  (LAMBDA (TOTALSIZE DIMENSIONS ELEMENT-TYPE DISPLACED-TO DISPLACED-INDEX-OFFSET FILL-POINTER 
                 READ-ONLY-P ADJUSTABLE EXTENDABLE)          (* \; "Edited 18-Dec-86 17:48 by jop")


    (* |;;| "Make a displaced array")


    (LET ((DISPLACED-TO-TYPENUMBER (|fetch|
 (ARRAY-HEADER TYPE-NUMBER) |of|
 DISPLACED-TO))
          (DISPLACE-TO-READ-ONLY-P (|fetch|
 (ARRAY-HEADER READ-ONLY-P) |of|
 DISPLACED-TO))
          (OFFSET (OR DISPLACED-INDEX-OFFSET 0))
          BASE NEED-INDIRECTION-P)
         (COND
            ((OR (%THIN-CHAR-TYPE-P DISPLACED-TO-TYPENUMBER)
                 (|fetch|
 (ARRAY-HEADER EXTENDABLE-P) |of|
 DISPLACED-TO)
                 (|fetch|
 (ARRAY-HEADER ADJUSTABLE-P) |of|
 DISPLACED-TO)
                 (AND DISPLACE-TO-READ-ONLY-P (NOT (|fetch|
 (ARRAY-HEADER INDIRECT-P)
                                                      |of|
 DISPLACED-TO))))
                                                             (* \; "Provide for indirection")

             (SETQ BASE DISPLACED-TO)
             (SETQ NEED-INDIRECTION-P T))
            (T                                               (* \; 

                                                  "Fold double displacement to single displacement")

               (SETQ BASE (|fetch|
 (ARRAY-HEADER BASE) |of|
 DISPLACED-TO))
               (SETQ OFFSET (+ OFFSET (%GET-ARRAY-OFFSET DISPLACED-TO)))
               (LISP:IF (|fetch|
 (ARRAY-HEADER INDIRECT-P) |of|
 DISPLACED-TO)
                      (SETQ NEED-INDIRECTION-P T))))
         (COND
            ((OR NEED-INDIRECTION-P ADJUSTABLE (> (LENGTH DIMENSIONS)
                                                  1))        (* \; 

                                                "Indirect strings always have %FAT-CHAR-TYPENUMBER")

             (%MAKE-GENERAL-ARRAY
 TOTALSIZE DIMENSIONS ELEMENT-TYPE FILL-POINTER (%CHAR-TYPE-P
                                                                                      
                                                                              DISPLACED-TO-TYPENUMBER
                                                                                      )
                    (OR READ-ONLY-P DISPLACE-TO-READ-ONLY-P)
                    ADJUSTABLE EXTENDABLE BASE OFFSET))
            (T (%MAKE-ONED-ARRAY
 TOTALSIZE ELEMENT-TYPE FILL-POINTER (%FAT-CHAR-TYPE-P 
                                                                              DISPLACED-TO-TYPENUMBER
                                                                                )
                      (OR READ-ONLY-P DISPLACE-TO-READ-ONLY-P)
                      EXTENDABLE BASE OFFSET))))))

(%MAKE-GENERAL-ARRAY

  (LAMBDA (TOTAL-SIZE DIMENSIONS ELEMENT-TYPE FILL-POINTER FATP READ-ONLY-P ADJUSTABLE-P EXTENDABLE-P
                 DISPLACED-TO DISPLACED-INDEX-OFFSET)        (* \; "Edited 11-Dec-87 15:35 by jop")


    (* |;;| "General arrays cover all make-array cases, including those requiring indirection.")


    (LET ((TYPE-NUMBER (%CML-TYPE-TO-TYPENUMBER
 ELEMENT-TYPE FATP)))
         (|create|
 GENERAL-ARRAY
                STORAGE _ (OR DISPLACED-TO (%MAKE-ARRAY-STORAGE
 TOTAL-SIZE TYPE-NUMBER))
                READ-ONLY-P _ READ-ONLY-P
                INDIRECT-P _ (%ARRAYP DISPLACED-TO)
                BIT-P _ (%BIT-TYPE-P TYPE-NUMBER)
                STRING-P _ (AND (%CHAR-TYPE-P TYPE-NUMBER)
                                (EQ 1 (LENGTH DIMENSIONS)))
                ADJUSTABLE-P _ ADJUSTABLE-P
                DISPLACED-P _ DISPLACED-TO
                FILL-POINTER-P _ FILL-POINTER
                EXTENDABLE-P _ (OR EXTENDABLE-P ADJUSTABLE-P)
                TYPE-NUMBER _ TYPE-NUMBER
                OFFSET _ (OR DISPLACED-INDEX-OFFSET 0)
                FILL-POINTER _ (OR FILL-POINTER TOTAL-SIZE)
                TOTAL-SIZE _ TOTAL-SIZE
                DIMS _ DIMENSIONS))))

(%MAKE-ONED-ARRAY

  (LAMBDA (TOTAL-SIZE ELEMENT-TYPE FILL-POINTER FATP READ-ONLY-P EXTENDABLE-P DISPLACED-TO 
                 DISPLACED-INDEX-OFFSET)                     (* \; "Edited 18-Dec-86 17:48 by jop")


    (* |;;| "Oned-arrays cover all one dimensional cases, except adjustable and displaced-to when indirection is necessary")


    (LET ((TYPE-NUMBER (%CML-TYPE-TO-TYPENUMBER
 ELEMENT-TYPE FATP)))
         (|create|
 ONED-ARRAY
                BASE _ (OR DISPLACED-TO (%MAKE-ARRAY-STORAGE
 TOTAL-SIZE TYPE-NUMBER))
                READ-ONLY-P _ READ-ONLY-P
                BIT-P _ (%BIT-TYPE-P TYPE-NUMBER)
                STRING-P _ (%CHAR-TYPE-P TYPE-NUMBER)
                DISPLACED-P _ DISPLACED-TO
                FILL-POINTER-P _ FILL-POINTER
                EXTENDABLE-P _ EXTENDABLE-P
                TYPE-NUMBER _ TYPE-NUMBER
                OFFSET _ (OR DISPLACED-INDEX-OFFSET 0)
                FILL-POINTER _ (OR FILL-POINTER TOTAL-SIZE)
                TOTAL-SIZE _ TOTAL-SIZE))))

(%MAKE-STRING-ARRAY-FAT

  (LAMBDA (ARRAY)                                            (* \; "Edited 11-Dec-87 15:35 by jop")


    (* |;;| "Like Adjust-array for the special case of Thin-string arrays")


    (LISP:IF (NOT (%ARRAYP ARRAY))
           (LISP:ERROR "Not an array" ARRAY))
    (LET ((BASE-ARRAY ARRAY)
          NEW-BASE OFFSET LIMIT)

         (* |;;| "Find the base array")


         (LISP:IF (|fetch|
 (ARRAY-HEADER INDIRECT-P) |of|
 ARRAY)
             (LISP:LOOP (LISP:IF (|fetch|
 (ARRAY-HEADER INDIRECT-P) |of|
 BASE-ARRAY)
                            (SETQ BASE-ARRAY (|fetch|
 (ARRAY-HEADER BASE) |of|
 BASE-ARRAY))
                            (RETURN NIL))))

         (* |;;| "Consistency check")


         (LISP:IF (NOT (%THIN-CHAR-TYPE-P (|fetch|
 (ARRAY-HEADER TYPE-NUMBER) |of|
 BASE-ARRAY
                                                 )))
                (LISP:ERROR "Not a thin string-char array: ~S" BASE-ARRAY))

         (* |;;| "Allocate the new storage")

                                                             (* \; "Be careful about offsets")

         (SETQ OFFSET (%GET-ARRAY-OFFSET BASE-ARRAY))
         (SETQ LIMIT (+ (|fetch|
 (ARRAY-HEADER TOTAL-SIZE) |of|
 BASE-ARRAY)
                        OFFSET))
         (SETQ NEW-BASE (%MAKE-ARRAY-STORAGE
 LIMIT %FAT-CHAR-TYPENUMBER))

         (* |;;| "Initialize it")

                                                             (* \; 

                                  "Can't use %fast-copy-base because of the differing type numbers")

         (LISP:DO ((I OFFSET (LISP:1+ I))
                   (BASE-ARRAY-BASE (|fetch|
 (ARRAY-HEADER BASE) |of|
 BASE-ARRAY)))
                  ((EQ I LIMIT))
             (%ARRAY-WRITE
 (%ARRAY-READ
 BASE-ARRAY-BASE %THIN-CHAR-TYPENUMBER I)
                    NEW-BASE %FAT-CHAR-TYPENUMBER I))

         (* |;;| "Smash the new base into the array-header")


         (UNINTERRUPTABLY
             (|replace|
 (ARRAY-HEADER BASE) |of|
 BASE-ARRAY |with|
 NEW-BASE)
             (|replace|
 (ARRAY-HEADER TYPE-NUMBER) |of|
 BASE-ARRAY |with|
 
                                                                                 %FAT-CHAR-TYPENUMBER
                    ))

         (* |;;| "return the original array")


         ARRAY)))

(%MAKE-TWOD-ARRAY

  (LAMBDA (TOTAL-SIZE DIMENSIONS ELEMENT-TYPE FATP READ-ONLY-P EXTENDABLE-P)
                                                             (* \; "Edited 18-Dec-86 17:49 by jop")


    (* |;;| "Two-d arrays are only simple or extendable twod-arrays")


    (LET ((BOUND0 (CAR DIMENSIONS))
          (BOUND1 (CADR DIMENSIONS))
          (TYPE-NUMBER (%CML-TYPE-TO-TYPENUMBER
 ELEMENT-TYPE FATP)))
         (|create|
 TWOD-ARRAY
                BASE _ (%MAKE-ARRAY-STORAGE
 TOTAL-SIZE TYPE-NUMBER)
                READ-ONLY-P _ READ-ONLY-P
                BIT-P _ (%BIT-TYPE-P TYPE-NUMBER)
                EXTENDABLE-P _ EXTENDABLE-P
                TYPE-NUMBER _ TYPE-NUMBER
                BOUND0 _ BOUND0
                BOUND1 _ BOUND1
                TOTAL-SIZE _ TOTAL-SIZE))))

(%TOTAL-SIZE

  (LAMBDA (DIMS)                                             (* \; "Edited 18-Dec-86 17:53 by jop")

    (LISP:DO ((DIM DIMS (CDR DIM))
              (PROD 1))
             ((NULL DIM)
              PROD)
        (SETQ PROD (LISP:* (CAR DIM)
                          PROD)))))

(SHRINK-VECTOR

  (LAMBDA (VECTOR NEW-SIZE)                                  (* \; "Edited 18-Dec-86 18:08 by jop")

    (COND
       ((%VECTORP VECTOR)
        (LISP:IF (OR (< NEW-SIZE 0)
                     (> NEW-SIZE (|fetch|
 (ARRAY-HEADER TOTAL-SIZE) |of|
 VECTOR)))
               (LISP:ERROR "Trying to shrink array ~s to bad size ~s" VECTOR NEW-SIZE))
        (|replace|
 (ARRAY-HEADER FILL-POINTER-P) |of|
 VECTOR |with|
 T)
        (|replace|
 (ARRAY-HEADER FILL-POINTER) |of|
 VECTOR |with|
 NEW-SIZE)
        VECTOR)
       (T (LISP:ERROR "Not a vector: ~S" VECTOR)))))
)



(* \; "For Interlisp string hack")


(DEFINEQ

(%SET-ARRAY-OFFSET

  (LAMBDA (ARRAY NEWVALUE)                                   (* \; "Edited 18-Dec-86 17:51 by jop")


    (* |;;| "Set the true offset for ARRAY")


    (COND
       ((%ONED-ARRAY-P
 ARRAY)
        (|replace|
 (ARRAY-HEADER OFFSET) |of|
 ARRAY |with|
 NEWVALUE))
       ((%TWOD-ARRAY-P
 ARRAY)
        (LISP:ERROR "Twod-arrays have no offset"))
       ((%GENERAL-ARRAY-P
 ARRAY)
        (|replace|
 (ARRAY-HEADER OFFSET) |of|
 ARRAY
           |with|
 (- NEWVALUE (LISP:DO* ((BASE-ARRAY ARRAY (|fetch|
 (ARRAY-HEADER BASE)
                                                                  |of|
 BASE-ARRAY))
                                             (OFFSET 0 (+ OFFSET (%GET-ARRAY-OFFSET BASE-ARRAY))))
                                            ((NOT (|fetch|
 (ARRAY-HEADER INDIRECT-P) |of|

                                                                                         BASE-ARRAY))
                                             OFFSET)))))
       (T (LISP:ERROR "Not an array: ~S" ARRAY)))
    NEWVALUE))

(%SET-ARRAY-TYPE-NUMBER

  (LAMBDA (ARRAY NEWVALUE)                                   (* \; "Edited 18-Dec-86 17:52 by jop")


    (* |;;| "Set the true type-number for array")


    (COND
       ((OR (%ONED-ARRAY-P
 ARRAY)
            (%TWOD-ARRAY-P
 ARRAY))
        (|replace|
 (ARRAY-HEADER TYPE-NUMBER) |of|
 ARRAY |with|
 NEWVALUE))
       ((%GENERAL-ARRAY-P
 ARRAY)
        (LISP:DO ((BASE-ARRAY ARRAY (|fetch|
 (ARRAY-HEADER BASE) |of|
 BASE-ARRAY)))
                 ((NOT (|fetch|
 (ARRAY-HEADER INDIRECT-P) |of|
 BASE-ARRAY))
                  (|replace|
 (ARRAY-HEADER TYPE-NUMBER) |of|
 BASE-ARRAY |with|
 NEWVALUE)))
        )
       (T (LISP:ERROR "Not an array ~S" ARRAY)))
    NEWVALUE))
)



(* \; "Low level predicates")


(DEFINEQ

(%ONED-ARRAY-P

  (LAMBDA (ARRAY)                                            (* \; "Edited 18-Dec-86 17:49 by jop")

    (EQ (NTYPX ARRAY)
        %ONED-ARRAY)))

(%TWOD-ARRAY-P

  (LAMBDA (ARRAY)                                            (* \; "Edited 18-Dec-86 17:53 by jop")

    (EQ (NTYPX ARRAY)
        %TWOD-ARRAY)))

(%GENERAL-ARRAY-P

  (LAMBDA (ARRAY)                                            (* \; "Edited 18-Dec-86 17:44 by jop")

    (EQ (NTYPX ARRAY)
        %GENERAL-ARRAY)))

(%THIN-STRING-ARRAY-P

  (LAMBDA (ARRAY)                                            (* \; "Edited 18-Dec-86 17:53 by jop")

    (%THIN-CHAR-TYPE-P (%ARRAY-TYPE-NUMBER
 ARRAY))))
)

(DEFOPTIMIZER %ONED-ARRAY-P
 (ARRAY)
                                `(AND ((OPCODES TYPEP 14)
                                       ,ARRAY)
                                      T))

(DEFOPTIMIZER %TWOD-ARRAY-P
 (ARRAY)
                                `(AND ((OPCODES TYPEP 15)
                                       ,ARRAY)
                                      T))

(DEFOPTIMIZER %GENERAL-ARRAY-P
 (ARRAY)
                                   `(AND ((OPCODES TYPEP 16)
                                          ,ARRAY)
                                         T))



(* \; "Real record def's on cmlarray-support")



(/DECLAREDATATYPE 'GENERAL-ARRAY '((BITS 8)
                                   POINTER FLAG FLAG FLAG FLAG FLAG FLAG FLAG FLAG (BITS 8)
                                   WORD WORD WORD POINTER)
       '((GENERAL-ARRAY 0 (BITS . 7))
         (GENERAL-ARRAY 0 POINTER)
         (GENERAL-ARRAY 2 (FLAGBITS . 0))
         (GENERAL-ARRAY 2 (FLAGBITS . 16))
         (GENERAL-ARRAY 2 (FLAGBITS . 32))
         (GENERAL-ARRAY 2 (FLAGBITS . 48))
         (GENERAL-ARRAY 2 (FLAGBITS . 64))
         (GENERAL-ARRAY 2 (FLAGBITS . 80))
         (GENERAL-ARRAY 2 (FLAGBITS . 96))
         (GENERAL-ARRAY 2 (FLAGBITS . 112))
         (GENERAL-ARRAY 2 (BITS . 135))
         (GENERAL-ARRAY 3 (BITS . 15))
         (GENERAL-ARRAY 4 (BITS . 15))
         (GENERAL-ARRAY 5 (BITS . 15))
         (GENERAL-ARRAY 6 POINTER))
       '8)

(/DECLAREDATATYPE 'ONED-ARRAY '((BITS 8)
                                POINTER FLAG (BITS 1)
                                FLAG FLAG (BITS 1)
                                FLAG FLAG FLAG (BITS 8)
                                WORD WORD WORD)
       '((ONED-ARRAY 0 (BITS . 7))
         (ONED-ARRAY 0 POINTER)
         (ONED-ARRAY 2 (FLAGBITS . 0))
         (ONED-ARRAY 2 (BITS . 16))
         (ONED-ARRAY 2 (FLAGBITS . 32))
         (ONED-ARRAY 2 (FLAGBITS . 48))
         (ONED-ARRAY 2 (BITS . 64))
         (ONED-ARRAY 2 (FLAGBITS . 80))
         (ONED-ARRAY 2 (FLAGBITS . 96))
         (ONED-ARRAY 2 (FLAGBITS . 112))
         (ONED-ARRAY 2 (BITS . 135))
         (ONED-ARRAY 3 (BITS . 15))
         (ONED-ARRAY 4 (BITS . 15))
         (ONED-ARRAY 5 (BITS . 15)))
       '6)

(/DECLAREDATATYPE 'TWOD-ARRAY '((BITS 8)
                                POINTER FLAG (BITS 1)
                                FLAG
                                (BITS 4)
                                FLAG
                                (BITS 8)
                                WORD WORD WORD)
       '((TWOD-ARRAY 0 (BITS . 7))
         (TWOD-ARRAY 0 POINTER)
         (TWOD-ARRAY 2 (FLAGBITS . 0))
         (TWOD-ARRAY 2 (BITS . 16))
         (TWOD-ARRAY 2 (FLAGBITS . 32))
         (TWOD-ARRAY 2 (BITS . 51))
         (TWOD-ARRAY 2 (FLAGBITS . 112))
         (TWOD-ARRAY 2 (BITS . 135))
         (TWOD-ARRAY 3 (BITS . 15))
         (TWOD-ARRAY 4 (BITS . 15))
         (TWOD-ARRAY 5 (BITS . 15)))
       '6)
(ADDTOVAR SYSTEMRECLST

(DATATYPE GENERAL-ARRAY
 ((NIL BITS 8)
                             (STORAGE POINTER)
                             (READ-ONLY-P FLAG)
                             (INDIRECT-P FLAG)
                             (BIT-P FLAG)
                             (STRING-P FLAG)
                             (ADJUSTABLE-P FLAG)
                             (DISPLACED-P FLAG)
                             (FILL-POINTER-P FLAG)
                             (EXTENDABLE-P FLAG)
                             (TYPE-NUMBER BITS 8)
                             (OFFSET WORD)
                             (FILL-POINTER WORD)
                             (TOTAL-SIZE WORD)
                             (DIMS POINTER)))

(DATATYPE ONED-ARRAY
 ((NIL BITS 8)
                          (BASE POINTER)
                          (READ-ONLY-P FLAG)
                          (NIL BITS 1)
                          (BIT-P FLAG)
                          (STRING-P FLAG)
                          (NIL BITS 1)
                          (DISPLACED-P FLAG)
                          (FILL-POINTER-P FLAG)
                          (EXTENDABLE-P FLAG)
                          (TYPE-NUMBER BITS 8)
                          (OFFSET WORD)
                          (FILL-POINTER WORD)
                          (TOTAL-SIZE WORD)))

(DATATYPE TWOD-ARRAY
 ((NIL BITS 8)
                          (BASE POINTER)
                          (READ-ONLY-P FLAG)
                          (NIL BITS 1)
                          (BIT-P FLAG)
                          (NIL BITS 4)
                          (EXTENDABLE-P FLAG)
                          (TYPE-NUMBER BITS 8)
                          (BOUND0 WORD)
                          (BOUND1 WORD)
                          (TOTAL-SIZE WORD)))
)

(PUTPROPS %AREF1
 DOPVAL
 (2 AREF1))

(PUTPROPS %AREF2
 DOPVAL
 (3 AREF2))

(PUTPROPS %ASET1
 DOPVAL
 (3 ASET1))

(PUTPROPS %ASET2
 DOPVAL
 (4 ASET2))



(* |;;| "I/O")


(DEFINEQ

(%DEFPRINT-ARRAY

  (LAMBDA (ARRAY STREAM)                                     (* \; "Edited  5-Feb-88 10:10 by jop")


    (* |;;| "This is the defprint for the array type")


    (COND
       ((%VECTORP ARRAY)
        (%DEFPRINT-VECTOR
 ARRAY STREAM))
       ((NOT *PRINT-ARRAY*)
        (%DEFPRINT-GENERIC-ARRAY
 ARRAY STREAM))
       ((AND *PRINT-LEVEL* (<= *PRINT-LEVEL* 0))
        (\\ELIDE.PRINT.ELEMENT STREAM)
        T)
       (T (LET ((HASH (LISP:CODE-CHAR (|fetch|
 (READTABLEP HASHMACROCHAR) |of|
 *READTABLE*)))
                (RANK (LISP:ARRAY-RANK
 ARRAY))
                RANKSTR)
               (%CHECK-CIRCLE-PRINT ARRAY STREAM (SETQ RANKSTR (LISP:PRINC-TO-STRING RANK))
                                                             (* \; "Make sure we have room for #na")

                      (.SPACECHECK. STREAM (+ (VECTOR-LENGTH
 RANKSTR)
                                              2))
                      (LISP:WRITE-CHAR HASH STREAM)
                      (LISP:WRITE-STRING RANKSTR STREAM)
                      (LISP:WRITE-CHAR (CONSTANT #\A)
                             STREAM)
                      (LISP:IF (EQ RANK 0)
                          (\\PRINDATUM (LISP:AREF
 ARRAY)
                                 STREAM 0)
                          (%PRINT-ARRAY-CONTENTS
 (%FLATTEN-ARRAY
 ARRAY)
                                 0
                                 (LISP:ARRAY-DIMENSIONS
 ARRAY)
                                 STREAM)))
               T)))))

(%DEFPRINT-BITVECTOR

  (LAMBDA (LISP:BIT-VECTOR STREAM)                           (* \; "Edited 11-Dec-87 15:35 by jop")


    (* |;;| "*Print-level* is handled in %defprint-vector")


    (LET ((HASH (LISP:CODE-CHAR (|fetch|
 (READTABLEP HASHMACROCHAR) |of|
 *READTABLE*)))
          (SIZE (VECTOR-LENGTH
 LISP:BIT-VECTOR))
          END.INDEX FINAL.INDEX ELIDED SIZESTR)
         (SETQ END.INDEX (LISP:1- SIZE))
         (%CHECK-CIRCLE-PRINT LISP:BIT-VECTOR STREAM
                (LISP:UNLESS (EQ SIZE 0)
                    (LISP:DO ((I (LISP:1- END.INDEX)
                                 (LISP:1- I))
                              (LAST.VALUE (LISP:AREF
 LISP:BIT-VECTOR END.INDEX)))
                             ((OR (< I 0)
                                  (NOT (EQL (LISP:AREF
 LISP:BIT-VECTOR I)
                                            LAST.VALUE))))
                        (SETQ END.INDEX I)))
                (SETQ FINAL.INDEX (COND
                                     ((AND *PRINT-LENGTH* (>= END.INDEX *PRINT-LENGTH*))
                                      (SETQ ELIDED T)
                                      (LISP:1- *PRINT-LENGTH*))
                                     (T END.INDEX)))
                (LISP:IF (NOT (EQ (LISP:1- SIZE)
                                  END.INDEX))
                    (SETQ SIZESTR (LISP:PRINC-TO-STRING SIZE)))
                (.SPACECHECK. STREAM (+ (PROGN               (* \; 

                                  "#* Plus 1 for final.index being 1 less than number bits printed")

                                               3)
                                        (LISP:IF SIZESTR
                                            (VECTOR-LENGTH
 SIZESTR)
                                            0)
                                        FINAL.INDEX
                                        (LISP:IF ELIDED
                                            (PROGN           (* \; "Space for ...")

                                                   3)
                                            0)))
                (LISP:WRITE-CHAR HASH STREAM)
                (LISP:IF SIZESTR (LISP:WRITE-STRING SIZESTR STREAM))
                (LISP:WRITE-CHAR (CONSTANT #\*)
                       STREAM)
                (LISP:DO ((I 0 (LISP:1+ I)))
                         ((> I FINAL.INDEX))
                    (\\OUTCHAR STREAM (+ (BIT
 LISP:BIT-VECTOR I)
                                         (CONSTANT (LISP:CHAR-CODE #\0)))))
                (LISP:IF ELIDED (\\ELIDE.PRINT.TAIL STREAM)))
         T)))

(%DEFPRINT-GENERIC-ARRAY

  (LAMBDA (ARRAY STREAM)                                     (* \; "Edited 18-Dec-86 17:40 by jop")


    (* |;;| "Invoked when *PRINT-ARRAY* is NIL")


    (LET ((HASH (LISP:CODE-CHAR (|fetch|
 (READTABLEP HASHMACROCHAR) |of|
 *READTABLE*))))
         (%CHECK-CIRCLE-PRINT ARRAY STREAM                   (* \; "Make sure we have room for #<")

                (.SPACECHECK. STREAM 2)
                (LISP:WRITE-CHAR HASH STREAM)
                (LISP:WRITE-CHAR (CONSTANT #\<)
                       STREAM)
                (LISP:WRITE-STRING (LISP:PRINC-TO-STRING 'LISP:ARRAY)
                       STREAM)
                (LISP:WRITE-CHAR (CONSTANT #\Space)
                       STREAM)
                (LISP:WRITE-STRING (LISP:PRINC-TO-STRING (LISP:ARRAY-ELEMENT-TYPE
 ARRAY))
                       STREAM)
                (LISP:WRITE-CHAR (CONSTANT #\Space)
                       STREAM)
                (LISP:WRITE-STRING (LISP:PRINC-TO-STRING (LISP:ARRAY-DIMENSIONS
 ARRAY))
                       STREAM)
                (LISP:WRITE-CHAR (CONSTANT #\Space)
                       STREAM)
                (LISP:WRITE-CHAR (CONSTANT #\@)
                       STREAM)
                (LISP:WRITE-CHAR (CONSTANT #\Space)
                       STREAM)
                (\\PRINTADDR ARRAY STREAM)
                (LISP:WRITE-CHAR (CONSTANT #\>)
                       STREAM))
         T)))

(%DEFPRINT-VECTOR

  (LAMBDA (VECTOR STREAM)                                    (* \; "Edited  5-Feb-88 10:11 by jop")


    (* |;;| "Defprint for the oned-array type")


    (COND
       ((LISP:STRINGP
 VECTOR)
        (%DEFPRINT-STRING
 VECTOR STREAM))
       ((NOT *PRINT-ARRAY*)
        (%DEFPRINT-GENERIC-ARRAY
 VECTOR STREAM))
       ((AND *PRINT-LEVEL* (<= *PRINT-LEVEL* 0))
        (\\ELIDE.PRINT.ELEMENT STREAM)
        T)
       ((LISP:BIT-VECTOR-P
 VECTOR)
        (%DEFPRINT-BITVECTOR
 VECTOR STREAM))
       (T (LET ((HASH (LISP:CODE-CHAR (|fetch|
 (READTABLEP HASHMACROCHAR) |of|
 *READTABLE*)))
                (SIZE (VECTOR-LENGTH
 VECTOR))
                END.INDEX FINAL.INDEX ELIDED SIZESTR)
               (SETQ END.INDEX (LISP:1- SIZE))
               (%CHECK-CIRCLE-PRINT VECTOR STREAM
                      (LISP:UNLESS (EQ SIZE 0)
                          (LISP:DO ((I (LISP:1- END.INDEX)
                                       (LISP:1- I))
                                    (LAST.VALUE (LISP:AREF
 VECTOR END.INDEX)))
                                   ((OR (< I 0)
                                        (NOT (EQL (LISP:AREF
 VECTOR I)
                                                  LAST.VALUE))))
                              (SETQ END.INDEX I)))
                      (SETQ FINAL.INDEX (COND
                                           ((AND *PRINT-LENGTH* (>= END.INDEX *PRINT-LENGTH*))
                                            (SETQ ELIDED T)
                                            (LISP:1- *PRINT-LENGTH*))
                                           (T END.INDEX)))
                      (LISP:IF (NOT (EQ (LISP:1- SIZE)
                                        END.INDEX))
                          (SETQ SIZESTR (LISP:PRINC-TO-STRING SIZE)))
                      (.SPACECHECK. STREAM (+ (LISP:IF SIZESTR
                                                  (VECTOR-LENGTH
 SIZESTR)
                                                  0)
                                              2))
                      (LISP:WRITE-CHAR HASH STREAM)
                      (LISP:IF SIZESTR (LISP:WRITE-STRING SIZESTR STREAM))
                      (LISP:WRITE-CHAR (CONSTANT #\()
                             STREAM)
                      (LET ((*PRINT-LEVEL* (AND *PRINT-LEVEL* (LISP:1- *PRINT-LEVEL*))))
                           (LISP:DO ((I 0 (LISP:1+ I)))
                                    ((> I FINAL.INDEX))
                               (LISP:IF (> I 0)
                                   (LISP:WRITE-CHAR (CONSTANT #\Space)
                                          STREAM))
                               (\\PRINDATUM (LISP:AREF
 VECTOR I)
                                      STREAM 0)))
                      (LISP:IF ELIDED (\\ELIDE.PRINT.TAIL STREAM))
                      (LISP:WRITE-CHAR (CONSTANT #\))
                             STREAM))
               T)))))

(%DEFPRINT-STRING

  (LAMBDA (STRING STREAM)                                    (* \; "Edited 11-Dec-87 15:36 by jop")


    (* |;;| "May never get called since (IL:typename (make-string 10)) returns IL:stringp")


    (LET ((ESCAPECHAR (|fetch|
 (READTABLEP ESCAPECHAR) |of|
 *READTABLE*))
          (CLP (|fetch|
 (READTABLEP COMMONLISP) |of|
 *READTABLE*))
          (SIZE (VECTOR-LENGTH
 STRING)))
         (%CHECK-CIRCLE-PRINT STRING STREAM (.SPACECHECK. STREAM (LISP:IF CLP
                                                                     2
                                                                     (+ 2 SIZE)))
                (LISP:WHEN *PRINT-ESCAPE*
                    (\\OUTCHAR STREAM (CONSTANT (LISP:CHAR-CODE #\"))))
                (LISP:DO ((I 0 (LISP:1+ I))
                          CH)
                         ((EQ I SIZE))
                    (SETQ CH (LISP:CHAR-CODE (LISP:CHAR
 STRING I)))
                    (LISP:WHEN (AND *PRINT-ESCAPE* (OR (EQ CH (CONSTANT (LISP:CHAR-CODE #\")))
                                                       (EQ CH ESCAPECHAR)))
                           (\\OUTCHAR STREAM ESCAPECHAR))
                    (\\OUTCHAR STREAM CH))
                (LISP:WHEN *PRINT-ESCAPE*
                    (\\OUTCHAR STREAM (CONSTANT (LISP:CHAR-CODE #\")))))
         T)))

(%PRINT-ARRAY-CONTENTS

  (LAMBDA (FLAT-ARRAY OFFSET DIMENSIONS STREAM)              (* \; "Edited  5-Feb-88 10:11 by jop")

    (LET ((NELTS (CAR DIMENSIONS))
          FINAL.INDEX ELIDED)
         (COND
            ((AND *PRINT-LENGTH* (> NELTS *PRINT-LENGTH*))
             (SETQ ELIDED T)
             (SETQ FINAL.INDEX (LISP:1- *PRINT-LENGTH*)))
            (T (SETQ FINAL.INDEX (LISP:1- NELTS))))
         (LISP:WRITE-CHAR (CONSTANT #\()
                STREAM)
         (COND
            ((NULL (CDR DIMENSIONS))                         (* \; 

                                                         "Down to bottom level, print the elements")

             (LISP:DO ((I OFFSET (LISP:1+ I))
                       (END-INDEX (+ OFFSET FINAL.INDEX)))
                      ((> I END-INDEX))
                 (LISP:IF (> I OFFSET)
                     (LISP:WRITE-CHAR (CONSTANT #\Space)
                            STREAM))
                 (\\PRINDATUM (LISP:AREF
 FLAT-ARRAY I)
                        STREAM 0)))
            ((EQ *PRINT-LEVEL* 1)                            (* \; "Elide at this level")

             (LISP:DO ((I 0 (LISP:1+ I)))
                      ((> I FINAL.INDEX))
                 (LISP:IF (> I OFFSET)
                     (LISP:WRITE-CHAR (CONSTANT #\Space)
                            STREAM))
                 (\\ELIDE.PRINT.ELEMENT STREAM)))
            (T (LET ((*PRINT-LEVEL* (AND *PRINT-LEVEL* (LISP:1- *PRINT-LEVEL*))))
                    (LISP:DO ((I 0 (LISP:1+ I)))
                             ((> I FINAL.INDEX))
                        (LISP:IF (> I 0)
                            (LISP:WRITE-CHAR (CONSTANT #\Space)
                                   STREAM))
                        (%PRINT-ARRAY-CONTENTS
 FLAT-ARRAY (LISP:* (CADR DIMENSIONS)
                                                                     (+ OFFSET I))
                               (CDR DIMENSIONS)
                               STREAM)))))
         (LISP:IF ELIDED (\\ELIDE.PRINT.TAIL STREAM))
         (LISP:WRITE-CHAR (CONSTANT #\))
                STREAM))))
)

(DEFPRINT 'ONED-ARRAY '%DEFPRINT-VECTOR)

(DEFPRINT 'TWOD-ARRAY '%DEFPRINT-ARRAY)

(DEFPRINT 'GENERAL-ARRAY '%DEFPRINT-ARRAY)



(* |;;| 
"Needed at run time. low level functions for accessing, setting, and allocating raw storage. also includes cml type to typenumber converters"
)


(DEFINEQ

(%ARRAY-READ

  (LAMBDA (BASE TYPE-NUMBER INDEX)
    (%SLOW-ARRAY-READ
 BASE TYPE-NUMBER INDEX)))

(%ARRAY-WRITE

  (LAMBDA (NEWVALUE BASE TYPE-NUMBER INDEX)                  (* \; "Edited 18-Dec-86 17:23 by jop")

    (%SLOW-ARRAY-WRITE
 NEWVALUE BASE TYPE-NUMBER INDEX)))

(%CML-TYPE-TO-TYPENUMBER

  (LAMBDA (ELEMENT-TYPE FATP)                                (* \; "Edited 18-Dec-86 17:30 by jop")

    (LET ((CANONICAL-TYPE (%GET-CANONICAL-CML-TYPE
 ELEMENT-TYPE)))
         (LISP:IF (AND FATP (EQ CANONICAL-TYPE 'LISP:BASE-CHARACTER))
             %FAT-CHAR-TYPENUMBER
             (%CML-TYPE-TO-TYPENUMBER-EXPANDER CANONICAL-TYPE)))))

(%GET-CANONICAL-CML-TYPE

  (LAMBDA (ELEMENT-TYPE)                                     (* \; "Edited 18-Dec-86 17:46 by jop")


    (* |;;| "Returns the enclosing specialized array type")


    (LISP:IF (LISP:CONSP ELEMENT-TYPE)
        (CASE (CAR ELEMENT-TYPE)
            (LISP:UNSIGNED-BYTE (%GET-ENCLOSING-UNSIGNED-BYTE
 ELEMENT-TYPE))
            (LISP:SIGNED-BYTE (%GET-ENCLOSING-SIGNED-BYTE
 ELEMENT-TYPE))
            (LISP:MOD (%REDUCE-MOD
 ELEMENT-TYPE))
            (INTEGER (%REDUCE-INTEGER
 ELEMENT-TYPE))
            (T (LET ((EXPANDER (TYPE-EXPANDER (CAR ELEMENT-TYPE))))
                    (LISP:IF EXPANDER
                        (%GET-CANONICAL-CML-TYPE
 (TYPE-EXPAND ELEMENT-TYPE EXPANDER))
                        T))))
        (CASE ELEMENT-TYPE
            ((T XPOINTER LISP:SINGLE-FLOAT LISP:BASE-CHARACTER LISP:EXTENDED-CHARACTER) ELEMENT-TYPE)
            (POINTER T)
            (FLOAT 'LISP:SINGLE-FLOAT)
            (LISP:FIXNUM '(LISP:SIGNED-BYTE 32))
            ((LISP:STRING-CHAR LISP:CHARACTER LISP:STANDARD-CHAR) 'LISP:BASE-CHARACTER)
            (BIT '(LISP:UNSIGNED-BYTE 1))
            (T (LET ((EXPANDER (TYPE-EXPANDER ELEMENT-TYPE)))
                    (LISP:IF EXPANDER
                        (%GET-CANONICAL-CML-TYPE
 (TYPE-EXPAND ELEMENT-TYPE EXPANDER))
                        T)))))))

(%GET-ENCLOSING-SIGNED-BYTE

  (LAMBDA (ELEMENT-TYPE)                                     (* \; "Edited  8-May-88 15:21 by jop")

    (LET ((NBITS (CADR ELEMENT-TYPE)))
         (LISP:IF (LISP:INTEGERP NBITS)
             (COND
                ((<= NBITS 16)
                 '(LISP:SIGNED-BYTE 16))
                ((<= NBITS 32)
                 '(LISP:SIGNED-BYTE 32))
                (T T))
             T))))

(%GET-ENCLOSING-UNSIGNED-BYTE

  (LAMBDA (ELEMENT-TYPE)                                     (* \; "Edited  8-May-88 15:21 by jop")

    (LET ((NBITS (CADR ELEMENT-TYPE)))
         (LISP:IF (LISP:INTEGERP NBITS)
             (COND
                ((<= NBITS 1)
                 '(LISP:UNSIGNED-BYTE 1))
                ((<= NBITS 8)
                 '(LISP:UNSIGNED-BYTE 8))
                ((<= NBITS 16)
                 '(LISP:UNSIGNED-BYTE 16))
                (T T))
             T))))

(%MAKE-ARRAY-STORAGE

  (LAMBDA (NELTS TYPENUMBER INIT-ON-PAGE ALIGNMENT)          (* \; "Edited 18-Dec-86 17:47 by jop")


    (* |;;| "Allocates a raw storage block for an array of NELTS elements, of type TYPENUMBER")


    (LET ((BITS-PER-ELEMENT (%TYPENUMBER-TO-BITS-PER-ELEMENT TYPENUMBER))
          (GC-TYPE (%TYPENUMBER-TO-GC-TYPE TYPENUMBER)))
         (\\ALLOCBLOCK (FOLDHI (LISP:* NELTS BITS-PER-ELEMENT)
                              BITSPERCELL)
                GC-TYPE INIT-ON-PAGE ALIGNMENT))))

(%REDUCE-INTEGER

  (LAMBDA (ELEMENT-TYPE)                                     (* \; "Edited  8-May-88 15:27 by jop")

    (LET ((LOW (CADR ELEMENT-TYPE))
          (HIGH (CADDR ELEMENT-TYPE)))
         (LISP:IF (LISP:CONSP LOW)
             (SETQ LOW (LISP:1+ (CAR LOW))))
         (LISP:IF (LISP:CONSP HIGH)
             (SETQ HIGH (LISP:1- (CAR HIGH))))
         (LISP:IF (AND (LISP:INTEGERP LOW)
                       (LISP:INTEGERP HIGH))
             (LISP:IF (>= LOW 0)
                 (COND
                    ((< HIGH 2)
                     '(LISP:UNSIGNED-BYTE 1))
                    ((< HIGH 256)
                     '(LISP:UNSIGNED-BYTE 8))
                    ((< HIGH 65536)
                     '(LISP:UNSIGNED-BYTE 16))
                    (T T))
                 (LET ((BOUND (MAX (- LOW)
                                   HIGH)))
                      (COND
                         ((< BOUND 32768)
                          '(LISP:SIGNED-BYTE 16))
                         ((<= BOUND MAX.FIXP)
                          '(LISP:SIGNED-BYTE 32))
                         (T T))))
             T))))

(%REDUCE-MOD

  (LAMBDA (ELEMENT-TYPE)                                     (* \; "Edited  8-May-88 15:22 by jop")

    (LET ((MODNUM (CADR ELEMENT-TYPE)))
         (LISP:IF (LISP:INTEGERP MODNUM)
             (COND
                ((<= MODNUM 2)
                 '(LISP:UNSIGNED-BYTE 1))
                ((<= MODNUM 256)
                 '(LISP:UNSIGNED-BYTE 8))
                ((<= MODNUM 65536)
                 '(LISP:UNSIGNED-BYTE 16))
                (T T))
             T))))

(%SLOW-ARRAY-READ

  (LAMBDA (BASE TYPENUMBER ROW-MAJOR-INDEX)                  (* \; "Edited 18-Dec-86 17:52 by jop")


    (* |;;| "Punt function for opcode arrayread")


    (%LLARRAY-TYPED-GET BASE TYPENUMBER ROW-MAJOR-INDEX)))

(%SLOW-ARRAY-WRITE

  (LAMBDA (NEWVALUE BASE TYPENUMBER ROW-MAJOR-INDEX)         (* \; "Edited 18-Dec-86 17:53 by jop")


    (* |;;| "Punt function for opcode arraywrite")


    (LISP:IF (NOT (%LLARRAY-TYPEP TYPENUMBER NEWVALUE))
        (LISP:ERROR "Illegal value: ~S" NEWVALUE)
        (%LLARRAY-TYPED-PUT BASE TYPENUMBER ROW-MAJOR-INDEX NEWVALUE))
    NEWVALUE))
)

(DEFOPTIMIZER %ARRAY-READ
 (BASE TYPENUMBER INDEX)
                              `((OPCODES MISC3 9)
                                ,BASE
                                ,TYPENUMBER
                                ,INDEX))

(DEFOPTIMIZER %ARRAY-WRITE
 (NEWVALUE BASE TYPENUMBER INDEX)
                               `((OPCODES MISC4 7)
                                 ,NEWVALUE
                                 ,BASE
                                 ,TYPENUMBER
                                 ,INDEX))



(* |;;| "Compiler options")


(DECLARE\: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY 
(DECLARE\: DOEVAL@COMPILE DONTCOPY

(LOCALVARS . T)
)
)

(PUTPROPS CMLARRAY
 FILETYPE
 LISP:COMPILE-FILE)
(DECLARE\: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS 

(ADDTOVAR NLAMA
 )

(ADDTOVAR NLAML
 )

(ADDTOVAR LAMA
 LISP:VECTOR ASET LISP:ARRAY-ROW-MAJOR-INDEX LISP:ARRAY-IN-BOUNDS-P LISP:AREF)
)
(PUTPROPS CMLARRAY COPYRIGHT ("Venue & Xerox Corporation" 1986 1987 1988 1990 1991 1992 1993))
(DECLARE\: DONTCOPY
  (FILEMAP (NIL (37276 45412 (LISP:AREF 37286 . 40020) (LISP:ARRAY-IN-BOUNDS-P 40022 . 40454) (
LISP:ARRAY-ROW-MAJOR-INDEX 40456 . 41285) (ASET 41287 . 45110) (LISP:VECTOR 45112 . 45410)) (45457 
46546 (LISP::ROW-MAJOR-ASET 45468 . 46544)) (48871 88151 (%ALTER-AS-DISPLACED-ARRAY 48881 . 52188) (
%ALTER-AS-DISPLACED-TO-BASE-ARRAY 52190 . 54222) (%AREF0 54224 . 54930) (%AREF1 54932 . 55866) (%AREF2
 55868 . 57875) (%ARRAY-BASE 57877 . 58907) (%ARRAY-CONTENT-INITIALIZE 58909 . 59493) (
%ARRAY-ELEMENT-INITIALIZE 59495 . 59836) (%ARRAY-OFFSET 59838 . 60571) (%ARRAY-TYPE-NUMBER 60573 . 
61847) (%ASET0 61849 . 62828) (%ASET1 62830 . 64139) (%ASET2 64141 . 66290) (
%CHECK-SEQUENCE-DIMENSIONS 66292 . 66844) (%COPY-TO-NEW-ARRAY 66846 . 68059) (%DO-LOGICAL-OP 68061 . 
70418) (%EXTEND-ARRAY 70420 . 72986) (%FAST-COPY-BASE 72988 . 75476) (%FAT-STRING-ARRAY-P 75478 . 
75662) (%FILL-ARRAY-FROM-SEQUENCE 75664 . 76303) (%FLATTEN-ARRAY 76305 . 76794) (%MAKE-ARRAY-WRITEABLE
 76796 . 79024) (%MAKE-DISPLACED-ARRAY 79026 . 81780) (%MAKE-GENERAL-ARRAY 81782 . 83011) (
%MAKE-ONED-ARRAY 83013 . 84038) (%MAKE-STRING-ARRAY-FAT 84040 . 86417) (%MAKE-TWOD-ARRAY 86419 . 87235
) (%TOTAL-SIZE 87237 . 87534) (SHRINK-VECTOR 87536 . 88149)) (88195 90050 (%SET-ARRAY-OFFSET 88205 . 
89295) (%SET-ARRAY-TYPE-NUMBER 89297 . 90048)) (90089 90800 (%ONED-ARRAY-P 90099 . 90266) (
%TWOD-ARRAY-P 90268 . 90435) (%GENERAL-ARRAY-P 90437 . 90610) (%THIN-STRING-ARRAY-P 90612 . 90798)) (
95759 107797 (%DEFPRINT-ARRAY 95769 . 97306) (%DEFPRINT-BITVECTOR 97308 . 99909) (
%DEFPRINT-GENERIC-ARRAY 99911 . 101361) (%DEFPRINT-VECTOR 101363 . 104323) (%DEFPRINT-STRING 104325 . 
105681) (%PRINT-ARRAY-CONTENTS 105683 . 107795)) (108086 113801 (%ARRAY-READ 108096 . 108199) (
%ARRAY-WRITE 108201 . 108384) (%CML-TYPE-TO-TYPENUMBER 108386 . 108760) (%GET-CANONICAL-CML-TYPE 
108762 . 110121) (%GET-ENCLOSING-SIGNED-BYTE 110123 . 110542) (%GET-ENCLOSING-UNSIGNED-BYTE 110544 . 
111039) (%MAKE-ARRAY-STORAGE 111041 . 111559) (%REDUCE-INTEGER 111561 . 112690) (%REDUCE-MOD 112692 . 
113180) (%SLOW-ARRAY-READ 113182 . 113422) (%SLOW-ARRAY-WRITE 113424 . 113799)))))
STOP