(FILECREATED "14-Oct-86 14:32:13" {ERIS}<LISPCORE>SOURCES>CMLARRAY.;7
 125111 

      changes to:  (VARS CMLARRAYCOMS)

      previous date: " 9-Oct-86 13:11:07" {ERIS}<LISPCORE>SOURCES>CMLARRAY.;6)


(* "
Copyright (c) 1986 by 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 ADJUST-ARRAY ADJUSTABLE-ARRAY-P ARRAY-DIMENSION ARRAY-DIMENSIONS 
               ARRAY-ELEMENT-TYPE ARRAY-HAS-FILL-POINTER-P ARRAY-NEEDS-INDIRECTION-P ARRAY-RANK 
               ARRAY-TOTAL-SIZE BIT BIT-AND BIT-ANDC1 BIT-ANDC2 BIT-ARRAY-P BIT-EQV BIT-IOR BIT-NAND 
               BIT-NOR BIT-NOT BIT-ORC1 BIT-ORC2 BIT-VECTOR-P BIT-XOR CHAR CL:ARRAYP CL:STRINGP 
               COPY-ARRAY DISPLACED-ARRAY-P EQUAL-DIMENSIONS-P EXTENDABLE-ARRAY-P FILL-ARRAY 
               FILL-POINTER FILL-VECTOR MAKE-ARRAY MAKE-VECTOR READ-ONLY-ARRAY-P SBIT SCHAR 
               SET-FILL-POINTER SIMPLE-ARRAY-P SIMPLE-BIT-VECTOR-P SIMPLE-STRING-P SIMPLE-VECTOR-P 
               STRING-ARRAY-P SVREF VECTOR-LENGTH VECTOR-POP VECTOR-PUSH VECTOR-PUSH-EXTEND VECTORP)
        (FNS %%COPY-TO-NEW-ARRAY AREF ARRAY-IN-BOUNDS-P ARRAY-ROW-MAJOR-INDEX ASET VECTOR)
        (* * "Obsolete but retained to avoid recompilation")
        (FNS SCHARSET)
        (* * "Vars etc")
        (* "*PRINT-ARRAY* is defined in APRINT")
        (VARIABLES ARRAY-RANK-LIMIT ARRAY-TOTAL-SIZE-LIMIT ARRAY-DIMENSION-LIMIT 
               *DEFAULT-PUSH-EXTENSION-SIZE*)
        (* * "Internal stuff")
        (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 %%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)
        (* "Faster predicates not including IL:STRINGP's")
        (FNS %%ARRAYP %%SIMPLE-ARRAY-P %%SIMPLE-STRING-P %%STRINGP %%VECTORP)
        (* "Low level predicates")
        (FNS %%GENERAL-ARRAY-P %%ONED-ARRAY-P %%THIN-STRING-ARRAY-P %%TWOD-ARRAY-P)
        (* "Record def's")
        (DECLARE: DONTCOPY DOEVAL@COMPILE (EXPORT (RECORDS ARRAY-HEADER GENERAL-ARRAY ONED-ARRAY 
                                                         TWOD-ARRAY)))
        (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 (QUOTE ONED-ARRAY)
                  (QUOTE %%DEFPRINT-VECTOR))
           (DEFPRINT (QUOTE TWOD-ARRAY)
                  (QUOTE %%DEFPRINT-ARRAY))
           (DEFPRINT (QUOTE GENERAL-ARRAY)
                  (QUOTE %%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)
        (* * "Compiler options")
        (DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY (LOCALVARS . T))
        (PROP FILETYPE CMLARRAY)
        (DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
               (ADDVARS (NLAMA)
                      (NLAML)
                      (LAMA VECTOR ASET ARRAY-ROW-MAJOR-INDEX ARRAY-IN-BOUNDS-P 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")


(DEFUN 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 wonderful"
          
          (* * "Strings are by default thin unless FATP is T")


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


        (CL:IF (>= RANK ARRAY-RANK-LIMIT)
               (CL:ERROR "Too many dimensions: ~A" RANK))
        (CL:IF (>= NELTS ARRAY-TOTAL-SIZE-LIMIT)
               (CL:ERROR "Too many elements: ~A" NELTS))
        (CL:IF (NOT (EQL RANK (ARRAY-RANK ADJUSTABLE-ARRAY)))
               (CL:ERROR "Rank mismatch ~S" DIMENSIONS))
        (CL:IF ELEMENT-TYPE-P (CL:IF (NOT (EQUAL ELEMENT-TYPE ADJUSTABLE-ARRAY-ELEMENT-TYPE))
                                     (CL:ERROR "ADJUSTABLE-ARRAY not of specified element-type: ~A" 
                                            ELEMENT-TYPE))
               (SETQ ELEMENT-TYPE ADJUSTABLE-ARRAY-ELEMENT-TYPE))
        (CL:IF (AND FILL-POINTER-P (NULL FILL-POINTER)
                    (ARRAY-HAS-FILL-POINTER-P ADJUSTABLE-ARRAY))
               (CL:ERROR "ADJUSTABLE-ARRAY has fill pointer"))
        (CL: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 (EQL RANK 1)))
                   (AND DISPLACED-INDEX-OFFSET-P (NOT (OR DISPLACED-TO-P DISPLACED-TO-BASE-P)))
                   (AND INITIAL-ELEMENT-P INITIAL-CONTENTS-P))
               (CL:ERROR "Inconsistent options to adjust-array"))
        (CL:IF DISPLACED-TO-P (COND
                                 ((NOT (%%ARRAYP DISPLACED-TO))
                                  (CL:ERROR "Cannot displace to an Interlisp array/string"))
                                 ((NOT (EQUAL ADJUSTABLE-ARRAY-ELEMENT-TYPE (ARRAY-ELEMENT-TYPE
                                                                             DISPLACED-TO)))
                                  (CL:ERROR "Not displaced to an array of the same element-type:"))
                                 ((> (+ DISPLACED-INDEX-OFFSET NELTS)
                                     (ARRAY-TOTAL-SIZE DISPLACED-TO))
                                  (CL:ERROR "More elements than displaced-to array"))))
        (CL:IF FILL-POINTER (COND
                               ((EQ FILL-POINTER T)
                                (SETQ FILL-POINTER NELTS))
                               ((NOT (AND (>= FILL-POINTER 0)
                                          (<= FILL-POINTER NELTS)))
                                (CL:ERROR "Fill pointer out of bounds ~A" FILL-POINTER)))
               (CL:IF (ARRAY-HAS-FILL-POINTER-P ADJUSTABLE-ARRAY)
                      (SETQ FILL-POINTER (MIN (FILL-POINTER ADJUSTABLE-ARRAY)
                                              NELTS))))
        (CL:IF EXTENDABLE-P (COND
                               ((OR DISPLACED-TO-P DISPLACED-TO-BASE-P)
                                (CL:ERROR "Cannot adjust an extendable array to be displaced"))
                               ((< NELTS (ARRAY-TOTAL-SIZE ADJUSTABLE-ARRAY))
                                (CL: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 (CL:IF (EQUAL (ARRAY-DIMENSIONS ADJUSTABLE-ARRAY)
                            DIMENSIONS)
                     (CL:IF FILL-POINTER (SET-FILL-POINTER ADJUSTABLE-ARRAY FILL-POINTER))
                     (LET ((NEW-ARRAY (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 (CL:IF INITIAL-ELEMENT-P (%%ARRAY-ELEMENT-INITIALIZE NEW-ARRAY 
                                                                INITIAL-ELEMENT))
                                (%%COPY-TO-NEW-ARRAY (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))

(DEFUN ADJUSTABLE-ARRAY-P
 (ARRAY) 
          
          (* *)

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

(DEFUN ARRAY-DIMENSION
 (ARRAY DIMENSION) 
          
          (* *)

 (COND
    ((%%ONED-ARRAY-P ARRAY)
     (CL:IF (EQL 0 DIMENSION)
            (fetch
 (ARRAY-HEADER TOTAL-SIZE) of
 ARRAY)
            (CL: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))
           (OTHERWISE (CL:ERROR "Dimension out of bounds: ~A" DIMENSION))))
    ((%%GENERAL-ARRAY-P ARRAY)
     (LET* ((DIMS (ffetch
 (GENERAL-ARRAY DIMS) of
 ARRAY))
            (RANK (LENGTH DIMS)))
           (CL:IF (NOT (< -1 DIMENSION RANK))
                  (CL:ERROR "Dimension out of bounds: ~A" DIMENSION))
           (CL:IF (EQL RANK 1)
                  (fetch
 (ARRAY-HEADER TOTAL-SIZE) of
 ARRAY)
                  (CL:NTH DIMENSION DIMS))))
    ((STRINGP ARRAY)                                         (* "Hack to handle IL:STRINGP's")

     (CL:IF (EQL DIMENSION 0)
            (NCHARS ARRAY)
            (CL:ERROR "Dimension out of bounds: ~A" DIMENSION)))
    (T (CL:ERROR "Not an array ~S" ARRAY))))

(DEFUN ARRAY-DIMENSIONS
 (ARRAY) 
                             (* jop: " 5-Sep-86 12:55")

          
          (* *)


   (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))
      ((STRINGP ARRAY)                                       (* "Hack to handle IL:STRINGP's")

       (LIST (NCHARS ARRAY)))
      (T (CL:ERROR "Not an array ~S" ARRAY))))

(DEFUN ARRAY-ELEMENT-TYPE
 (ARRAY) 
          
          (* *)

 (COND
    ((%%ARRAYP ARRAY)
     (%%TYPENUMBER-TO-CML-TYPE (%%ARRAY-TYPE-NUMBER ARRAY)))
    ((STRINGP ARRAY)                                         (* "Hack to handle IL:STRINGP's")

     (QUOTE STRING-CHAR))
    (T (CL:ERROR "Not an array ~S" ARRAY))))

(DEFUN ARRAY-HAS-FILL-POINTER-P
 (ARRAY) 
          
          (* *)

 (COND
    ((%%ARRAYP ARRAY)
     (fetch
 (ARRAY-HEADER FILL-POINTER-P) of
 ARRAY))
    ((STRINGP ARRAY)                                         (* "Hack to handle IL:STRINGP's")

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

(DEFUN ARRAY-NEEDS-INDIRECTION-P
 (ARRAY) 
          
          (* *)

 (COND
    ((OR (%%ONED-ARRAY-P ARRAY)
         (%%TWOD-ARRAY-P ARRAY)
         (STRINGP ARRAY))
     NIL)
    ((%%GENERAL-ARRAY-P ARRAY)
     (fetch
 (ARRAY-HEADER INDIRECT-P) of
 ARRAY))
    (T (CL:ERROR "Not an array ~S" ARRAY))))

(DEFUN 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)))
    ((STRINGP ARRAY)                                         (* "Hack to handle IL:STRINGP's")

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

(DEFUN ARRAY-TOTAL-SIZE
 (ARRAY) 
          
          (* *)

 (COND
    ((%%ARRAYP ARRAY)
     (fetch
 (ARRAY-HEADER TOTAL-SIZE) of
 ARRAY))
    ((STRINGP ARRAY)                                         (* "Hack to handle IL:STRINGP's")

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

(DEFUN BIT
 (BIT-ARRAY &REST INDICES) (CL:ASSERT (TYPEP BIT-ARRAY (QUOTE (ARRAY BIT)))
                                            (BIT-ARRAY)
                                            "Not a bit-array: ~S" BIT-ARRAY)
                                     (CL:APPLY (FUNCTION AREF)
                                            BIT-ARRAY INDICES))

(DEFUN BIT-AND
 (BIT-ARRAY1 BIT-ARRAY2 &OPTIONAL BIT-RESULT) 
          
          (* *)

 (%%EXPAND-BIT-OP AND BIT-ARRAY1 BIT-ARRAY2 BIT-RESULT))

(DEFUN BIT-ANDC1
 (BIT-ARRAY1 BIT-ARRAY2 &OPTIONAL BIT-RESULT) 
          
          (* *)

 (%%EXPAND-BIT-OP ANDC1 BIT-ARRAY1 BIT-ARRAY2 BIT-RESULT))

(DEFUN BIT-ANDC2
 (BIT-ARRAY1 BIT-ARRAY2 &OPTIONAL BIT-RESULT) 
          
          (* *)

 (%%EXPAND-BIT-OP ANDC2 BIT-ARRAY1 BIT-ARRAY2 BIT-RESULT))

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

(DEFUN BIT-EQV
 (BIT-ARRAY1 BIT-ARRAY2 &OPTIONAL BIT-RESULT) 
          
          (* *)

 (%%EXPAND-BIT-OP EQV BIT-ARRAY1 BIT-ARRAY2 BIT-RESULT))

(DEFUN BIT-IOR
 (BIT-ARRAY1 BIT-ARRAY2 &OPTIONAL BIT-RESULT) 
          
          (* *)

 (%%EXPAND-BIT-OP IOR BIT-ARRAY1 BIT-ARRAY2 BIT-RESULT))

(DEFUN BIT-NAND
 (BIT-ARRAY1 BIT-ARRAY2 &OPTIONAL BIT-RESULT) 
          
          (* *)

 (%%EXPAND-BIT-OP NAND BIT-ARRAY1 BIT-ARRAY2 BIT-RESULT))

(DEFUN BIT-NOR
 (BIT-ARRAY1 BIT-ARRAY2 &OPTIONAL BIT-RESULT) 
          
          (* *)

 (%%EXPAND-BIT-OP NOR
 BIT-ARRAY1 BIT-ARRAY2 BIT-RESULT))

(DEFUN BIT-NOT
 (BIT-ARRAY &OPTIONAL RESULT-BIT-ARRAY) 
       (* jop: " 9-Sep-86 17:05")

          
          (* *)


   (CL:IF (NOT (BIT-ARRAY-P BIT-ARRAY))
          (CL:ERROR "BIT-ARRAY not a bit array"))
   (COND
      ((NULL RESULT-BIT-ARRAY)
       (SETQ RESULT-BIT-ARRAY (MAKE-ARRAY (ARRAY-DIMENSIONS BIT-ARRAY)
                                     :ELEMENT-TYPE
                                     (QUOTE 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)))
       (CL:ERROR "Illegal result array")))
   (%%DO-LOGICAL-OP (QUOTE NOT)
          BIT-ARRAY RESULT-BIT-ARRAY)
   RESULT-BIT-ARRAY)

(DEFUN BIT-ORC1
 (BIT-ARRAY1 BIT-ARRAY2 &OPTIONAL BIT-RESULT) 
          
          (* *)

 (%%EXPAND-BIT-OP ORC1 BIT-ARRAY1 BIT-ARRAY2 BIT-RESULT))

(DEFUN BIT-ORC2
 (BIT-ARRAY1 BIT-ARRAY2 &OPTIONAL BIT-RESULT) 
          
          (* *)

 (%%EXPAND-BIT-OP ORC2 BIT-ARRAY1 BIT-ARRAY2 BIT-RESULT))

(DEFUN BIT-VECTOR-P
 (VECTOR) 
          
          (* *)

 (AND (%%VECTORP VECTOR)
      (fetch
 (ARRAY-HEADER BIT-P) of
 VECTOR)))

(DEFUN BIT-XOR
 (BIT-ARRAY1 BIT-ARRAY2 &OPTIONAL BIT-RESULT) 
          
          (* *)

 (%%EXPAND-BIT-OP XOR BIT-ARRAY1 BIT-ARRAY2 BIT-RESULT))

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

(DEFUN CL:ARRAYP
 (ARRAY) 
                                    (* jop: " 5-Sep-86 12:53")

          
          (* *)


   (AND (OR (%%ARRAYP ARRAY)
            (STRINGP ARRAY))
        T))

(DEFUN CL:STRINGP
 (STRING) (AND (OR (%%STRINGP STRING)
                                    (STRINGP STRING))
                                T))

(DEFUN COPY-ARRAY
 (FROM-ARRAY &OPTIONAL TO-ARRAY) (CL:IF (NOT (%%ARRAYP FROM-ARRAY))
                                                         (CL:ERROR "Not an array: ~S" FROM-ARRAY))
                                                  (COND
                                                     ((NULL TO-ARRAY)
                                                      (SETQ TO-ARRAY (MAKE-ARRAY (ARRAY-DIMENSIONS
                                                                                  FROM-ARRAY)
                                                                            :ELEMENT-TYPE
                                                                            (ARRAY-ELEMENT-TYPE
                                                                             FROM-ARRAY)
                                                                            :FATP
                                                                            (%%FAT-STRING-ARRAY-P
                                                                             FROM-ARRAY))))
                                                     ((NOT (EQUAL-DIMENSIONS-P FROM-ARRAY TO-ARRAY))
                                                      (CL:ERROR "Dimensionality mismatch")))
                                                  (CL: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
                                                                               )))
                                                       (CL: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)))
                                                       (CL:IF (NOT (EQ FROM-TYPE-NUMBER 
                                                                       TO-TYPE-NUMBER))
                                                              (CL:ERROR 
                                                                 "Arrays have different type numbers"
                                                                     ))
                                                       (%%FAST-COPY-BASE (%%ARRAY-BASE FROM-ARRAY)
                                                              (%%ARRAY-OFFSET FROM-ARRAY)
                                                              (%%ARRAY-BASE TO-ARRAY)
                                                              (%%ARRAY-OFFSET TO-ARRAY)
                                                              (fetch
 (ARRAY-HEADER TOTAL-SIZE)
                                                                 of
 FROM-ARRAY)
                                                              FROM-TYPE-NUMBER)
                                                       TO-ARRAY))

(DEFUN DISPLACED-ARRAY-P
 (ARRAY) 
          
          (* *)

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

(DEFUN EQUAL-DIMENSIONS-P
 (ARRAY-1 ARRAY-2) (COND
                                               ((%%ONED-ARRAY-P ARRAY-1)
                                                (COND
                                                   ((%%ONED-ARRAY-P ARRAY-2)
                                                    (EQL (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)))
                                                         (EQL (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 (EQL (ffetch
 (TWOD-ARRAY BOUND0)
                                                                 of
 ARRAY-1)
                                                              (ffetch
 (TWOD-ARRAY BOUND0)
                                                                 of
 ARRAY-2))
                                                         (EQL (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 (EQL (ffetch
 (TWOD-ARRAY BOUND0)
                                                                           of
 ARRAY-1)
                                                                        (CAR DIMS))
                                                                   (EQL (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))
                                                              (EQL (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 (EQL (CAR DIMS)
                                                                        (ffetch
 (TWOD-ARRAY BOUND0)
                                                                           of
 ARRAY-2))
                                                                   (EQL (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)))

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

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

(DEFUN FILL-ARRAY
 (ARRAY VALUE) (CL:IF (NOT (%%ARRAYP ARRAY))
                                       (CL:ERROR "Not an array: ~S" ARRAY))
                                (LET ((TOTAL-SIZE (fetch
 (ARRAY-HEADER TOTAL-SIZE) of
 ARRAY))
                                      (TYPE-NUMBER (%%ARRAY-TYPE-NUMBER ARRAY)))
                                     (CL:IF (fetch
 (ARRAY-HEADER READ-ONLY-P) of
 ARRAY)
                                            (%%MAKE-ARRAY-WRITEABLE ARRAY))
                                     (CL:WHEN (> TOTAL-SIZE 0)
                                            (CL: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)))
                                            (CL:IF (NOT (%%LLARRAY-TYPEP TYPE-NUMBER VALUE))
                                                   (CL: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 BASE (1+ OFFSET)
                                                        (1- TOTAL-SIZE)
                                                        TYPE-NUMBER)))
                                     ARRAY))

(DEFUN 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))
    ((OR (%%VECTORP VECTOR)
         (STRINGP VECTOR))
     (CL:ERROR "vector has no fill pointer"))
    (T (CL:ERROR "Not a vector ~S" VECTOR))))

(DEFUN FILL-VECTOR
 (VECTOR VALUE &KEY (START 0)
                          END) (CL:IF (NOT (%%VECTORP VECTOR))
                                      (CL:ERROR "Not a vector: ~S" VECTOR))
                               (CL:IF (< START 0)
                                      (CL:ERROR "Invalid :start arg: ~S" START))
                               (COND
                                  ((NULL END)
                                   (SETQ END (fetch
 (ARRAY-HEADER TOTAL-SIZE) of
 VECTOR)))
                                  ((NOT (<= 0 END (fetch
 (ARRAY-HEADER TOTAL-SIZE) of
 VECTOR)))
                                   (CL:ERROR "Invalid :end arg: ~S" END)))
                               (LET ((CNT (- END START))
                                     (TYPE-NUMBER (%%ARRAY-TYPE-NUMBER VECTOR)))
                                    (CL:IF (fetch
 (ARRAY-HEADER READ-ONLY-P) of
 VECTOR)
                                           (%%MAKE-ARRAY-WRITEABLE VECTOR))
                                    (CL:WHEN (> CNT 0)
                                           (CL: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)))
                                           (CL:IF (NOT (%%LLARRAY-TYPEP TYPE-NUMBER VALUE))
                                                  (CL: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 BASE (1+ OFFSET)
                                                       (1- CNT)
                                                       TYPE-NUMBER)))
                                    VECTOR))

(DEFUN 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) 
                                                         "Make an array following the key word specs"
          
          (* * "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")


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


        (CL:IF (>= RANK ARRAY-RANK-LIMIT)
               (CL:ERROR "Too many dimensions: ~A" RANK))
        (CL:IF (>= NELTS ARRAY-TOTAL-SIZE-LIMIT)
               (CL:ERROR "Too many elements: ~A" NELTS))
        (CL: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 (EQL 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)))
               (CL:ERROR "Inconsistent options to make-array"))
        (CL:IF DISPLACED-TO-P (COND
                                 ((NOT (%%ARRAYP DISPLACED-TO))
                                  (CL:ERROR "Cannot displace to an Interlisp array/string"))
                                 ((NOT (EQUAL (%%GET-CANONICAL-CML-TYPE ELEMENT-TYPE)
                                              (ARRAY-ELEMENT-TYPE DISPLACED-TO)))
                                  (CL:ERROR "Not displaced to an array of the same element-type"))
                                 ((> (+ DISPLACED-INDEX-OFFSET NELTS)
                                     (ARRAY-TOTAL-SIZE DISPLACED-TO))
                                  (CL:ERROR "displaced array out of bounds"))))
        (CL:IF FILL-POINTER (COND
                               ((EQ FILL-POINTER T)
                                (SETQ FILL-POINTER NELTS))
                               ((NOT (AND (>= FILL-POINTER 0)
                                          (<= FILL-POINTER NELTS)))
                                (CL: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 (CL: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))

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

(DEFUN READ-ONLY-ARRAY-P
 (ARRAY) 
          
          (* *)

 (COND
    ((%%ARRAYP ARRAY)
     (fetch
 (ARRAY-HEADER READ-ONLY-P) of
 ARRAY))
    ((STRINGP ARRAY)
     NIL)
    (T (CL:ERROR "Not an array ~S" ARRAY))))

(DEFUN SBIT
 (SIMPLE-BIT-ARRAY &REST INDICES) (CL:ASSERT (TYPEP SIMPLE-BIT-ARRAY (QUOTE (SIMPLE-ARRAY
                                                                                        BIT)))
                                                    (SIMPLE-BIT-ARRAY)
                                                    "Not a bit-array: ~S" SIMPLE-BIT-ARRAY)
                                             (CL:APPLY (FUNCTION AREF)
                                                    SIMPLE-BIT-ARRAY INDICES))

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

(DEFUN SET-FILL-POINTER
 (VECTOR NEWVALUE) 
                   (* jop: " 5-Sep-86 12:55")

          
          (* *)


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

(DEFUN SIMPLE-ARRAY-P
 (ARRAY) 
          
          (* *)

 (AND (OR (%%SIMPLE-ARRAY-P ARRAY)
          (STRINGP ARRAY))
      T))

(DEFUN SIMPLE-BIT-VECTOR-P
 (VECTOR) 
          
          (* *)

 (AND (%%ONED-ARRAY-P VECTOR)
      (fetch
 (ARRAY-HEADER SIMPLE-P) of
 VECTOR)
      (fetch
 (ARRAY-HEADER BIT-P) of
 VECTOR)))

(DEFUN SIMPLE-STRING-P
 (STRING) 
          
          (* *)

 (AND (OR (%%SIMPLE-STRING-P STRING)
          (STRINGP STRING))
      T))

(DEFUN SIMPLE-VECTOR-P
 (VECTOR) 
                             (* jop: " 5-Sep-86 12:54")

          
          (* *)


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

(DEFUN STRING-ARRAY-P
 (ARRAY) 
          
          (* *)

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

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

(DEFUN VECTOR-LENGTH
 (VECTOR) 
                               (* jop: " 5-Sep-86 12:55")

   (COND
      ((%%VECTORP VECTOR)
       (fetch
 (ARRAY-HEADER FILL-POINTER) of
 VECTOR))
      ((STRINGP VECTOR)
       (NCHARS VECTOR))
      (T (CL:ERROR "Not a vector: ~s" VECTOR))))

(DEFUN VECTOR-POP
 (VECTOR) 
                                  (* jop: " 5-Sep-86 12:55")

          
          (* *)


   (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)))
            (CL:IF (<= FILL-POINTER 0)
                   (CL:ERROR "Can't pop from zero fill pointer"))
            (SETQ FILL-POINTER (1- FILL-POINTER))
            (replace
 (ARRAY-HEADER FILL-POINTER) of
 VECTOR with
 FILL-POINTER)
            (AREF VECTOR FILL-POINTER)))
      ((OR (%%VECTORP VECTOR)
           (STRINGP VECTOR))
       (CL:ERROR "Vector has no fill pointer"))
      (T (CL:ERROR "Not a vector ~S" VECTOR))))

(DEFUN VECTOR-PUSH
 (NEW-ELEMENT VECTOR) 
                     (* jop: " 5-Sep-86 12:55")

          
          (* *)


   (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)))
            (CL:WHEN (< FILL-POINTER (fetch
 (ARRAY-HEADER TOTAL-SIZE) of
 VECTOR))
                   (ASET NEW-ELEMENT VECTOR FILL-POINTER)
                   (replace
 (ARRAY-HEADER FILL-POINTER) of
 VECTOR with
 (1+ FILL-POINTER))
                   FILL-POINTER)))
      ((OR (%%VECTORP VECTOR)
           (STRINGP VECTOR))
       (CL:ERROR "Vector has no fill pointer"))
      (T (CL:ERROR "Not a vector ~S" VECTOR))))

(DEFUN 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 (VECTOR-PUSH NEW-ELEMENT VECTOR)))
        (CL:IF (NULL NEW-INDEX)
               (COND
                  ((> EXTENSION-SIZE 0)
                   (ADJUST-ARRAY VECTOR (+ (ARRAY-TOTAL-SIZE VECTOR)
                                           EXTENSION-SIZE))
                   (VECTOR-PUSH NEW-ELEMENT VECTOR))
                  (T (CL:ERROR "Extension-size not greater than zero")))
               NEW-INDEX)))

(DEFUN VECTORP
 (VECTOR) 
                                     (* jop: " 5-Sep-86 12:55")

          
          (* *)


   (AND (OR (%%VECTORP VECTOR)
            (STRINGP VECTOR))
        T))

(DEFINEQ

(%%COPY-TO-NEW-ARRAY

  (LAMBDA (OLD-DIMS OLD-ARRAY OLD-OFFSET NEW-DIMS NEW-ARRAY NEW-OFFSET)

                                                             (* jop: "21-Sep-86 16:55")

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


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

                                      "Can only do a fast copy when arrays have the same type number")

                     (CL:IF (EQ OLD-TYPE-NUMBER NEW-TYPE-NUMBER)
                            (%%FAST-COPY-BASE
 (%%ARRAY-BASE
 OLD-ARRAY)
                                   OLD-OFFSET
                                   (%%ARRAY-BASE
 NEW-ARRAY)
                                   NEW-OFFSET SIZE OLD-TYPE-NUMBER)
                            (CL:ERROR "Arrays have differing type numbers")))))))

(AREF

  (LAMBDA ARGS
                                               (* jop: "21-Sep-86 15:00")

          
          (* *)


    (CL:IF (< ARGS 1)
           (CL: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)))
               (OTHERWISE (COND
                             ((NOT (%%ARRAYP
 ARRAY))
                              (CL:ERROR "Not an array ~S" ARRAY))
                             ((NOT (EQL (ARRAY-RANK ARRAY)
                                        (1- ARGS)))
                              (CL:ERROR "Rank mismatch"))
                             (T 
          
          (* * "If we've gotten this far ARRAY must be a general array")

                                                             (* "Check indices in bounds")

                                (CL:DO ((I 2 (1+ I))
                                        (DIMLIST (ffetch
 (GENERAL-ARRAY DIMS) of
 ARRAY)
                                               (CDR DIMLIST))
                                        INDEX)
                                       ((> I ARGS))
                                       (SETQ INDEX (ARG ARGS I))
                                       (CL:IF (NOT (AND (>= INDEX 0)
                                                        (< INDEX (CAR DIMLIST))))
                                              (CL:ERROR "Index out of bounds: ~A" INDEX)))
                                                             (* "Now proceed to extract the element")

                                (LET ((ROW-MAJOR-INDEX (CL:DO ((I 2 (1+ I))
                                                               (DIMLIST (CDR (ffetch
 (GENERAL-ARRAY
                                                                                      DIMS)
                                                                                of
 ARRAY))
                                                                      (CDR DIMLIST))
                                                               (TOTAL 0))
                                                              ((EQL I ARGS)
                                                               (+ TOTAL (ARG ARGS ARGS)))
                                                              (SETQ TOTAL
                                                               (CL:* (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))))))))))

(ARRAY-IN-BOUNDS-P

  (LAMBDA ARGS
                                               (* jop: " 5-Sep-86 11:22")

          
          (* *)


    (CL:IF (< ARGS 1)
           (CL:ERROR "Array-in-bounds-p takes at least one arg"))
    (LET ((ARRAY (ARG ARGS 1)))
         (COND
            ((NOT (CL:ARRAYP ARRAY))
             (CL:ERROR "Not an array ~S" ARRAY))
            ((NOT (EQL (ARRAY-RANK ARRAY)
                       (1- ARGS)))
             (CL:ERROR "Rank mismatch"))
            (T (%%CHECK-INDICES ARRAY 2 ARGS))))))

(ARRAY-ROW-MAJOR-INDEX

  (LAMBDA ARGS
                                               (* jop: " 5-Sep-86 11:23")

          
          (* *)


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

(ASET

  (LAMBDA ARGS
                                               (* jop: "21-Sep-86 18:57")

          
          (* *)


    (CL:IF (< ARGS 2)
           (CL: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)))
               (OTHERWISE (COND
                             ((NOT (%%ARRAYP
 ARRAY))
                              (CL:ERROR "Not an array ~S" ARRAY))
                             ((NOT (EQL (ARRAY-RANK ARRAY)
                                        (- ARGS 2)))
                              (CL:ERROR "Rank mismatch"))
                             (T                              (* 

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

                                                             (* "Check indices")

                                (CL:DO ((I 3 (1+ I))
                                        (DIMLIST (ffetch
 (GENERAL-ARRAY DIMS) of
 ARRAY)
                                               (CDR DIMLIST))
                                        INDEX)
                                       ((> I ARGS))
                                       (SETQ INDEX (ARG ARGS I))
                                       (CL:IF (NOT (< -1 INDEX (CAR DIMLIST)))
                                              (CL:ERROR "Index out of bounds: ~A" INDEX)))
                                                             (* "Now proceed to extract the element")

                                (LET ((ROW-MAJOR-INDEX (CL:DO ((I 3 (1+ I))
                                                               (DIMLIST (CDR (ffetch
 (GENERAL-ARRAY
                                                                                      DIMS)
                                                                                of
 ARRAY))
                                                                      (CDR DIMLIST))
                                                               (TOTAL 0))
                                                              ((EQL I ARGS)
                                                               (+ TOTAL (ARG ARGS ARGS)))
                                                              (SETQ TOTAL
                                                               (CL:* (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)))
                                          (CL:IF (%%CHECK-NOT-WRITEABLE ARRAY TYPE-NUMBER NEWVALUE)
                                                 (CL:APPLY (QUOTE ASET)
                                                        NEWVALUE ARRAY
                                                        (CL:DO ((I ARGS (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))))))))))))

(VECTOR

  (LAMBDA ARGS
                                               (* jop: " 4-Sep-86 22:59")

          
          (* *)


    (LET ((VECTOR
 (%%MAKE-ONED-ARRAY
 ARGS T)))
         (DOTIMES (I ARGS)
                (ASET
 (ARG ARGS (1+ I))
                      VECTOR I))
         VECTOR)))
)
(* * "Obsolete but retained to avoid recompilation")


(DEFINEQ

(SCHARSET

  (LAMBDA (SIMPLE-STRING INDEX VALUE)
                        (* jop: "14-Aug-86 16:21")

    (ASET
 VALUE (THE SIMPLE-STRING SIMPLE-STRING)
          INDEX)))
)
(* * "Vars etc")





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


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

(DEFCONSTANT ARRAY-TOTAL-SIZE-LIMIT
 65534)

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

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

(* * "Internal stuff")


(DEFINEQ

(%%ALTER-AS-DISPLACED-ARRAY

  (LAMBDA (ADJUSTABLE-ARRAY DIMENSIONS DISPLACED-TO DISPLACED-INDEX-OFFSET FILL-POINTER)

                                                             (* jop: "21-Sep-86 18:45")

          
          (* * 

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


    (CL: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)))
               (CL: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)
                          (* jop: "21-Sep-86 17:01")

          
          (* * "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)
                                            (* jop: "21-Sep-86 15:09")

          
          (* *)


    (COND
       ((NOT (%%ARRAYP
 ARRAY))
        (CL:ERROR "Not an array ~S" ARRAY))
       ((NOT (EQL (ARRAY-RANK ARRAY)
                  0))
        (CL:ERROR "Rank mismatch"))
       (T (* * "Must be a general array")

          (LET ((INDEX 0)
                (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)))))))

(%%AREF1

  (LAMBDA (ARRAY INDEX)
                                      (* jop: "21-Sep-86 19:26")

          
          (* *)


    (COND
       ((NOT (%%ARRAYP
 ARRAY))                               (* "Hack to handle IL:STRINGP's")

        (CL:IF (STRINGP ARRAY)
               (CODE-CHAR (NTHCHARCODE ARRAY (1+ INDEX)))
               (CL:ERROR "Not an array ~S" ARRAY)))
       ((NOT (EQL (ARRAY-RANK ARRAY)
                  1))
        (CL:ERROR "Rank mismatch"))
       ((NOT (AND (>= INDEX 0)
                  (< INDEX (fetch
 (ARRAY-HEADER TOTAL-SIZE) of
 ARRAY))))
        (CL:ERROR "Index out of bounds: ~A" INDEX))
       (T (* * "Now proceed to extract the element")

          (LET ((BASE-ARRAY ARRAY))
               (CL:IF (ffetch
 (GENERAL-ARRAY INDIRECT-P) of
 BASE-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)
                                        (* jop: "21-Sep-86 15:11")

          
          (* *)


    (COND
       ((NOT (%%ARRAYP
 ARRAY))
        (CL:ERROR "Not an array ~S" ARRAY))
       ((NOT (EQL (ARRAY-RANK ARRAY)
                  2))
        (CL:ERROR "Rank mismatch"))
       (T (* * "If we get here ARRAY must be twod or general")

          (LET (BOUND0 BOUND1 OFFSET)                        (* "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 (AND (>= I 0)
                             (< I BOUND0)))
                   (CL:ERROR "Index out of bounds: ~A" I))
                  ((NOT (AND (>= J 0)
                             (< J BOUND1)))
                   (CL:ERROR "Index out of bounds: ~A" J)))  (* "Extract the element")

               (LET ((ROW-MAJOR-INDEX (+ J (CL:* 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))))))))

(%%ARRAY-BASE

  (LAMBDA (ARRAY)
                                            (* jop: "21-Sep-86 13:13")

          
          (* * "Get the raw offset for ARRAY")


    (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
 (LOOP (CL:IF (NOT (fetch
 (ARRAY-HEADER INDIRECT-P) of
 ARRAY))
                                                   (RETURN ARRAY))
                                            (SETQ ARRAY (fetch
 (ARRAY-HEADER BASE) of
 ARRAY)))))
       (T (CL:ERROR "Not an array ~S" ARRAY)))))

(%%ARRAY-CONTENT-INITIALIZE

  (LAMBDA (ARRAY INITIAL-CONTENTS)
                           (* jop: "18-Sep-86 21:37")

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

(%%ARRAY-ELEMENT-INITIALIZE

  (LAMBDA (ARRAY INITIAL-ELEMENT)
                            (* jop: "21-Sep-86 15:40")

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


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

(%%ARRAY-OFFSET

  (LAMBDA (ARRAY)
                                            (* jop: " 5-Sep-86 12:55")

          
          (* * "Get the raw offset for ARRAY")


    (COND
       ((%%ONED-ARRAY-P
 ARRAY)
        (fetch
 (ARRAY-HEADER OFFSET) of
 ARRAY))
       ((%%TWOD-ARRAY-P
 ARRAY)
        0)
       ((%%GENERAL-ARRAY-P
 ARRAY)
        (CL: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 (CL:ERROR "Not an array ~S" ARRAY)))))

(%%ARRAY-TYPE-NUMBER

  (LAMBDA (ARRAY)
                                            (* jop: "21-Sep-86 13:13")

          
          (* * "Get the raw offset 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
 (LOOP (CL:IF (NOT (fetch
 (ARRAY-HEADER INDIRECT-P)
                                                                  of
 ARRAY))
                                                          (RETURN ARRAY))
                                                   (SETQ ARRAY (fetch
 (ARRAY-HEADER BASE)
                                                                  of
 ARRAY)))))
       (T (CL:ERROR "Not an array ~S" ARRAY)))))

(%%ASET0

  (LAMBDA (NEWVALUE ARRAY)
                                   (* jop: "21-Sep-86 18:57")

          
          (* *)


    (COND
       ((NOT (%%ARRAYP
 ARRAY))
        (CL:ERROR "Not an array ~S" ARRAY))
       ((NOT (EQL (ARRAY-RANK ARRAY)
                  0))
        (CL:ERROR "Rank mismatch"))
       (T (* * "Must be a general array")

          (LET ((INDEX 0)
                (BASE-ARRAY ARRAY))
               (%%GENERAL-ARRAY-ADJUST-BASE BASE-ARRAY INDEX)
               (LET ((TYPE-NUMBER (fetch
 (ARRAY-HEADER TYPE-NUMBER) of
 BASE-ARRAY)))
                    (CL: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)))))))))

(%%ASET1

  (LAMBDA (NEWVALUE ARRAY INDEX)
                             (* jop: "21-Sep-86 18:58")

          
          (* *)


    (COND
       ((NOT (%%ARRAYP
 ARRAY))                               (* "Hack to handle IL:STRINGP's")

        (CL:IF (STRINGP ARRAY)
               (PROGN (RPLCHARCODE ARRAY (1+ INDEX)
                             (CHAR-CODE NEWVALUE))
                      NEWVALUE)
               (CL:ERROR "Not an array" ARRAY)))
       ((NOT (EQL (ARRAY-RANK ARRAY)
                  1))
        (CL:ERROR "Rank mismatch"))
       ((NOT (AND (>= INDEX 0)
                  (< INDEX (fetch
 (ARRAY-HEADER TOTAL-SIZE) of
 ARRAY))))
        (CL:ERROR "Index out of bounds: ~A" 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)))
                    (CL: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)
                               (* jop: "21-Sep-86 18:58")

          
          (* *)


    (COND
       ((NOT (%%ARRAYP
 ARRAY))
        (CL:ERROR "Not an array ~S" ARRAY))
       ((NOT (EQL (ARRAY-RANK ARRAY)
                  2))
        (CL:ERROR "Rank mismatch"))
       (T (* * "If we get here ARRAY must be twod or general")

          (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 (AND (>= I 0)
                             (< I BOUND0)))
                   (CL:ERROR "Index out of bounds ~A" I))
                  ((NOT (AND (>= J 0)
                             (< J BOUND1)))
                   (CL:ERROR "Index out of bounds ~A" J)))
               (LET ((ROW-MAJOR-INDEX (+ J (CL:* 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)))
                         (CL: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))))))))))

(%%CHECK-SEQUENCE-DIMENSIONS

  (LAMBDA (DIM-LST SEQUENCE)
                                 (* jop: "18-Sep-86 18:07")

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


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

(%%DO-LOGICAL-OP

  (LAMBDA (OP SOURCE DEST)
                                   (* jop: " 4-Sep-86 23:09")

          
          (* *)


    (LET ((SOURCE-BASE (%%ARRAY-BASE
 SOURCE))
          (SOURCE-OFFSET (%%ARRAY-OFFSET
 SOURCE))
          (SOURCE-SIZE (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)

                                                             (* jop: "22-Sep-86 11:20")

          
          (* * "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))
                   (CL: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 TO-BASE TO-OFFSET CNT TYPE-NUMBER)

                                                             (* jop: "17-Sep-86 12:40")

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


    (LET ((BITS-PER-ELEMENT (%%TYPENUMBER-TO-BITS-PER-ELEMENT TYPE-NUMBER))
          (GC-TYPE (%%TYPENUMBER-TO-GC-TYPE TYPE-NUMBER)))
         (CL:IF (NOT (EQ GC-TYPE PTRBLOCK.GCT))
                (LET ((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
                         (replace
 (PILOTBBT PBTSOURCE) of
 PBBT with
 FROM-BASE)
                         (replace
 (PILOTBBT PBTSOURCEBIT) of
 PBBT with
 (CL:* BITS-PER-ELEMENT 
                                                                             FROM-OFFSET))
                         (replace
 (PILOTBBT PBTDEST) of
 PBBT with
 TO-BASE)
                         (replace
 (PILOTBBT PBTDESTBIT) of
 PBBT with
 (CL:* BITS-PER-ELEMENT TO-OFFSET
                                                                           ))
                         (replace
 (PILOTBBT PBTDESTBPL) of
 PBBT with
 BITS-PER-ELEMENT)
                         (replace
 (PILOTBBT PBTSOURCEBPL) of
 PBBT with
 BITS-PER-ELEMENT)
                         (replace
 (PILOTBBT PBTWIDTH) of
 PBBT with
 BITS-PER-ELEMENT)
                         (replace
 (PILOTBBT PBTHEIGHT) of
 PBBT with
 CNT)
                         (\PILOTBITBLT PBBT 0)))
                (CL:DO ((I FROM-OFFSET (1+ I))
                        (LIMIT (+ FROM-OFFSET CNT))
                        (J TO-OFFSET (1+ J)))
                       ((EQL I LIMIT))
                       (%%ARRAY-WRITE
 (%%ARRAY-READ
 FROM-BASE TYPE-NUMBER I)
                              TO-BASE TYPE-NUMBER J)))
         NIL)))

(%%FAT-STRING-ARRAY-P

  (LAMBDA (ARRAY)
                                            (* jop: "21-Sep-86 13:30")

          
          (* *)


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

(%%FILL-ARRAY-FROM-SEQUENCE

  (LAMBDA (DIMS SEQUENCE FLATTENED-ARRAY OFFSET)
             (* jop: "18-Sep-86 20:57")

          
          (* *)


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

(%%FLATTEN-ARRAY

  (LAMBDA (ARRAY)
                                            (* jop: " 4-Sep-86 22:28")

          
          (* * 

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


    (CL:IF (EQL 1 (ARRAY-RANK ARRAY))
           ARRAY
           (MAKE-ARRAY (ARRAY-TOTAL-SIZE ARRAY)
                  :ELEMENT-TYPE
                  (ARRAY-ELEMENT-TYPE ARRAY)
                  :DISPLACED-TO ARRAY))))

(%%MAKE-ARRAY-WRITEABLE

  (LAMBDA (ARRAY)
                                            (* jop: "23-Sep-86 21:10")

    (CL:IF (NOT (%%ARRAYP
 ARRAY))
           (CL:ERROR "Not an array" ARRAY))
    (LET ((BASE-ARRAY ARRAY)
          NEW-BASE OFFSET TOTAL-SIZE TYPE-NUMBER)
          
          (* * "Find the base array")


         (CL:IF (fetch
 (ARRAY-HEADER INDIRECT-P) of
 ARRAY)
                (LOOP (CL:IF (fetch
 (ARRAY-HEADER INDIRECT-P) of
 BASE-ARRAY)
                             (SETQ BASE-ARRAY (fetch
 (ARRAY-HEADER BASE) of
 BASE-ARRAY))
                             (RETURN NIL))))
         (CL: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 NEW-BASE OFFSET TOTAL-SIZE TYPE-NUMBER)
          
          (* * "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
             (CL: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)
          (* jop: "21-Sep-86 18:39")

          
          (* * "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)))
               (CL: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)
        (* jop: "19-Sep-86 16:30")

          
          (* * "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)
                                (EQL 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)
                     (* jop: " 5-Sep-86 14:15")

          
          (* * "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)
                                            (* jop: "21-Sep-86 15:28")

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


    (CL:IF (NOT (%%ARRAYP
 ARRAY))
           (CL:ERROR "Not an array" ARRAY))
    (LET ((BASE-ARRAY ARRAY)
          NEW-BASE OFFSET LIMIT)
          
          (* * "Find the base array")


         (CL:IF (fetch
 (ARRAY-HEADER INDIRECT-P) of
 ARRAY)
                (LOOP (CL:IF (fetch
 (ARRAY-HEADER INDIRECT-P) of
 BASE-ARRAY)
                             (SETQ BASE-ARRAY (fetch
 (ARRAY-HEADER BASE) of
 BASE-ARRAY))
                             (RETURN NIL))))
          
          (* * "Consistency check")


         (CL:IF (NOT (%%THIN-CHAR-TYPE-P (fetch
 (ARRAY-HEADER TYPE-NUMBER) of
 BASE-ARRAY)))
                (CL: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")

         (CL:DO ((I OFFSET (1+ I))
                 (BASE-ARRAY-BASE (fetch
 (ARRAY-HEADER BASE) of
 BASE-ARRAY)))
                ((EQL 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)

                                                             (* jop: " 5-Sep-86 14:14")

          
          (* * "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)
                                             (* jop: "27-Apr-86 17:02")

          
          (* *)


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

(SHRINK-VECTOR

  (LAMBDA (VECTOR
 NEW-SIZE)
                                  (* jop: " 5-Sep-86 12:55")

          
          (* *)


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



(* "For interlisp string hack")


(DEFINEQ

(%%SET-ARRAY-OFFSET

  (LAMBDA (ARRAY NEWVALUE)
                                   (* jop: "17-Sep-86 17:54")

          
          (* * "Set the raw offset for ARRAY")


    (COND
       ((%%ONED-ARRAY-P
 ARRAY)
        (replace
 (ARRAY-HEADER OFFSET) of
 ARRAY with
 NEWVALUE))
       ((%%TWOD-ARRAY-P
 ARRAY)
        (CL:ERROR "Twod-arrays have no offset"))
       ((%%GENERAL-ARRAY-P
 ARRAY)
        (replace
 (ARRAY-HEADER OFFSET) of
 ARRAY with
 (- NEWVALUE (CL: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 (CL:ERROR "Not an array ~S" ARRAY)))
    NEWVALUE))

(%%SET-ARRAY-TYPE-NUMBER

  (LAMBDA (ARRAY NEWVALUE)
                                   (* jop: "18-Sep-86 15:22")

          
          (* * "Set the 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)
        (CL: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 (CL:ERROR "Not an array ~S" ARRAY)))
    NEWVALUE))
)



(* "Faster predicates not including IL:STRINGP's")


(DEFINEQ

(%%ARRAYP

  (LAMBDA (ARRAY)
                                            (* jop: " 5-Sep-86 12:49")

          
          (* *)


    (OR (%%ONED-ARRAY-P
 ARRAY)
        (%%TWOD-ARRAY-P
 ARRAY)
        (%%GENERAL-ARRAY-P
 ARRAY))))

(%%SIMPLE-ARRAY-P

  (LAMBDA (ARRAY)
                                            (* jop: " 5-Sep-86 12:59")

          
          (* *)


    (AND (%%ARRAYP
 ARRAY)
         (fetch
 (ARRAY-HEADER SIMPLE-P) of
 ARRAY))))

(%%SIMPLE-STRING-P

  (LAMBDA (STRING)
                                           (* jop: " 5-Sep-86 12:54")

          
          (* *)


    (AND (%%ONED-ARRAY-P
 STRING)
         (fetch
 (ARRAY-HEADER SIMPLE-P) of
 STRING)
         (fetch
 (ARRAY-HEADER STRING-P) of
 STRING))))

(%%STRINGP

  (LAMBDA (ARRAY)
                                            (* jop: " 5-Sep-86 12:49")

          
          (* *)


    (AND (OR (%%ONED-ARRAY-P
 ARRAY)
             (%%GENERAL-ARRAY-P
 ARRAY))
         (fetch
 (ARRAY-HEADER STRING-P) of
 ARRAY))))

(%%VECTORP

  (LAMBDA (VECTOR
)
                                           (* jop: " 5-Sep-86 12:49")

          
          (* *)


    (OR (%%ONED-ARRAY-P
 VECTOR)
        (AND (%%GENERAL-ARRAY-P
 VECTOR)
             (EQL 1 (LENGTH (ffetch
 (GENERAL-ARRAY DIMS) of
 VECTOR)))))))
)



(* "Low level predicates")


(DEFINEQ

(%%GENERAL-ARRAY-P

  (LAMBDA (ARRAY)
                                            (* jop: " 5-Sep-86 13:17")

          
          (* *)


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

(%%ONED-ARRAY-P

  (LAMBDA (ARRAY)
                                            (* jop: " 5-Sep-86 13:18")

          
          (* *)


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

(%%THIN-STRING-ARRAY-P

  (LAMBDA (ARRAY)
                                            (* jop: "21-Sep-86 15:55")

          
          (* *)


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

(%%TWOD-ARRAY-P

  (LAMBDA (ARRAY)
                                            (* jop: " 5-Sep-86 13:18")

          
          (* *)


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



(* "Record def's")


(DECLARE: DONTCOPY DOEVAL@COMPILE 
(* FOLLOWING DEFINITIONS EXPORTED)


[DECLARE: EVAL@COMPILE 

(BLOCKRECORD ARRAY-HEADER
 (
          
          (* * "Describes common slots of all array headers")

                                                             (* "First 8 bits are unused")

                           (BASE POINTER)                    (* 

        "24 bits of pointer. Points at raw storage or, in the indirect case, at another array header")

                                                             (* "8 bits of flags")

                           (READ-ONLY-P FLAG)                (* 

                                                        "Used for headers pointing at symbols pnames")

                           (INDIRECT-P FLAG)                 (* 

                                          "Points at an array header rather than a raw storage block")

                           (BIT-P FLAG)                      (* "Is a bit array")

                           (STRING-P FLAG)                   (* "Is a string (implies is a vector)")

                                                             (* 

                                     "If any of the following flags are set, the array in non-simple")

                           (ADJUSTABLE-P FLAG)
                           (DISPLACED-P FLAG)
                           (FILL-POINTER-P FLAG)
                           (EXTENDABLE-P FLAG)
                           (TYPE-NUMBER BITS 8)              (* "8 bits of type + size")

                           (OFFSET WORD)                     (* "For oned and general arrays")

                           (FILL-POINTER WORD)               (* "For oned and general arrays")

                           (TOTAL-SIZE WORD))
                          (BLOCKRECORD ARRAY-HEADER ((NIL POINTER)
                                                     (FLAGS BITS 8)
                                                     (TYPE BITS 4)
                                                     (SIZE BITS 4)))
                          (ACCESSFNS (SIMPLE-P (EQ 0 (LOGAND (fetch
 (ARRAY-HEADER FLAGS) of
 DATUM)
                                                            15))))
                          (SYSTEM))

(DATATYPE GENERAL-ARRAY
 ((NIL BITS 8)                        (* "For alignment")

                         (STORAGE POINTER)                   (* "24 bits of pointer")

                         (READ-ONLY-P FLAG)                  (* "8 bits of flags")

                         (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)                (* "8 bits of typenumber")

                         (OFFSET WORD)
                         (FILL-POINTER WORD)
                         (TOTAL-SIZE WORD)
                         (DIMS POINTER)))

(DATATYPE ONED-ARRAY
 ((NIL BITS 8)                           (* "Don't use high 8 bits")

                      (BASE POINTER)                         (* "The raw storage base")

                      (READ-ONLY-P FLAG)                     (* "8 bits worth of flags")

                      (NIL BITS 1)                           (* "Oned array's cann't be indirect")

                      (BIT-P FLAG)
                      (STRING-P FLAG)
                      (NIL BITS 1)                           (* "Oned-array's cann't be adjustable")

                      (DISPLACED-P FLAG)
                      (FILL-POINTER-P FLAG)
                      (EXTENDABLE-P FLAG)
                      (TYPE-NUMBER BITS 8)                   (* "4 bits of type and 4 bits of size")

                      (OFFSET WORD)                          (* "For displaced arrays")

                      (FILL-POINTER WORD)                    (* "For filled arrays")

                      (TOTAL-SIZE WORD)                      (* "Total number of elements")

                      ))

(DATATYPE TWOD-ARRAY
 ((NIL BITS 8)                           (* "For alignmnet")

                      (BASE POINTER)                         (* "Raw storage pointer")

                      (READ-ONLY-P FLAG)                     (* "8 bits of flags")

                      (NIL BITS 1)                           (* "Twod arrays cann't be indirect")

                      (BIT-P FLAG)
                      (NIL BITS 4)                           (* 

        "Twod arrays cann't be strings, nor can they be adjustable, displaced, or have fill pointers")

                      (EXTENDABLE-P FLAG)
                      (TYPE-NUMBER BITS 8)
                      (BOUND0 WORD)                          (* "Zero dimension bound")

                      (BOUND1 WORD)                          (* "One dimension bound")

                      (TOTAL-SIZE WORD)))
]
(/DECLAREDATATYPE (QUOTE GENERAL-ARRAY)
       (QUOTE ((BITS 8)
               POINTER FLAG FLAG FLAG FLAG FLAG FLAG FLAG FLAG (BITS 8)
               WORD WORD WORD POINTER))
       (QUOTE ((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)))
       (QUOTE 8))
(/DECLAREDATATYPE (QUOTE ONED-ARRAY)
       (QUOTE ((BITS 8)
               POINTER FLAG (BITS 1)
               FLAG FLAG (BITS 1)
               FLAG FLAG FLAG (BITS 8)
               WORD WORD WORD))
       (QUOTE ((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))))
       (QUOTE 6))
(/DECLAREDATATYPE (QUOTE TWOD-ARRAY)
       (QUOTE ((BITS 8)
               POINTER FLAG (BITS 1)
               FLAG
               (BITS 4)
               FLAG
               (BITS 8)
               WORD WORD WORD))
       (QUOTE ((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))))
       (QUOTE 6))


(* END EXPORTED DEFINITIONS)

)
(/DECLAREDATATYPE (QUOTE GENERAL-ARRAY)
       (QUOTE ((BITS 8)
               POINTER FLAG FLAG FLAG FLAG FLAG FLAG FLAG FLAG (BITS 8)
               WORD WORD WORD POINTER))
       (QUOTE ((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)))
       (QUOTE 8))
(/DECLAREDATATYPE (QUOTE ONED-ARRAY)
       (QUOTE ((BITS 8)
               POINTER FLAG (BITS 1)
               FLAG FLAG (BITS 1)
               FLAG FLAG FLAG (BITS 8)
               WORD WORD WORD))
       (QUOTE ((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))))
       (QUOTE 6))
(/DECLAREDATATYPE (QUOTE TWOD-ARRAY)
       (QUOTE ((BITS 8)
               POINTER FLAG (BITS 1)
               FLAG
               (BITS 4)
               FLAG
               (BITS 8)
               WORD WORD WORD))
       (QUOTE ((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))))
       (QUOTE 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)
                                     (* jop: "10-Sep-86 12:54")

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


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

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

(%%DEFPRINT-BITVECTOR

  (LAMBDA (BIT-VECTOR STREAM)
                                (* jop: " 5-Sep-86 11:19")

          
          (* * "*Print-level* is handled in \defprint-vector")


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

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

                                               3)
                                        (CL:IF SIZESTR (VECTOR-LENGTH SIZESTR)
                                               0)
                                        FINAL.INDEX
                                        (CL:IF ELISION (PROGN 
                                                             (* "Space for ...")

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

(%%DEFPRINT-GENERIC-ARRAY

  (LAMBDA (ARRAY STREAM)
                                     (* jop: "24-Sep-86 11:09")

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


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

                (.SPACECHECK. STREAM 2)
                (WRITE-CHAR HASH STREAM)
                (WRITE-CHAR |\< STREAM)
                (WRITE-STRING "ARRAY" STREAM)
                (WRITE-CHAR |\Space STREAM)
                (WRITE-STRING (PRINC-TO-STRING (ARRAY-ELEMENT-TYPE ARRAY))
                       STREAM)
                (WRITE-CHAR |\Space STREAM)
                (WRITE-STRING (PRINC-TO-STRING (ARRAY-DIMENSIONS ARRAY))
                       STREAM)
                (WRITE-CHAR |\Space STREAM)
                (WRITE-CHAR |\@ STREAM)
                (WRITE-CHAR |\Space STREAM)
                (\PRINTADDR ARRAY STREAM)
                (WRITE-CHAR |\> STREAM))
         T)))

(%%DEFPRINT-VECTOR

  (LAMBDA (VECTOR
 STREAM)
                                    (* jop: "10-Sep-86 12:55")

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

(%%DEFPRINT-STRING

  (LAMBDA (STRING STREAM)
                                    (* jop: " 5-Sep-86 11:19")

          
          (* *)


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

(%%PRINT-ARRAY-CONTENTS

  (LAMBDA (FLAT-ARRAY OFFSET DIMENSIONS STREAM)
              (* jop: " 5-Sep-86 11:14")

          
          (* *)


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

                                                           "Down to bottom level, print the elements")

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

             (CL:DO ((I 0 (1+ I)))
                    ((> I FINAL.INDEX))
                    (CL:IF (> I OFFSET)
                           (WRITE-CHAR |\Space STREAM))
                    (\ELIDE.PRINT.ELEMENT STREAM)))
            (T (LET ((*PRINT-LEVEL* (AND *PRINT-LEVEL* (1- *PRINT-LEVEL*))))
                    (CL:DO ((I 0 (1+ I)))
                           ((> I FINAL.INDEX))
                           (CL:IF (> I 0)
                                  (WRITE-CHAR |\Space STREAM))
                           (%%PRINT-ARRAY-CONTENTS
 FLAT-ARRAY (CL:* (CADR DIMENSIONS)
                                                                    (+ OFFSET I))
                                  (CDR DIMENSIONS)
                                  STREAM)))))
         (CL:IF ELIDED (\ELIDE.PRINT.TAIL STREAM))
         (WRITE-CHAR |\) STREAM))))
)
(DEFPRINT (QUOTE ONED-ARRAY)
       (QUOTE %%DEFPRINT-VECTOR))
(DEFPRINT (QUOTE TWOD-ARRAY)
       (QUOTE %%DEFPRINT-ARRAY))
(DEFPRINT (QUOTE GENERAL-ARRAY)
       (QUOTE %%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)
                  (* jop: "17-Sep-86 12:20")

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

(%%CML-TYPE-TO-TYPENUMBER

  (LAMBDA (ELEMENT-TYPE FATP)
                                (* jop: " 5-Sep-86 14:34")

          
          (* *)


    (LET ((CANONICAL-TYPE (%%GET-CANONICAL-CML-TYPE
 ELEMENT-TYPE)))
         (CL:IF (AND FATP (EQ CANONICAL-TYPE (QUOTE STRING-CHAR)))
                %%FAT-CHAR-TYPENUMBER
                (%%CML-TYPE-TO-TYPENUMBER-EXPANDER CANONICAL-TYPE)))))

(%%GET-CANONICAL-CML-TYPE

  (LAMBDA (ELEMENT-TYPE)
                                     (* jop: " 9-Oct-86 13:09")

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

(%%GET-ENCLOSING-SIGNED-BYTE

  (LAMBDA (ELEMENT-TYPE)
                                     (* jop: " 6-Jul-86 12:50")

          
          (* *)


    (LET ((NBITS (CADR ELEMENT-TYPE)))
         (COND
            ((<= NBITS 16)
             (QUOTE (SIGNED-BYTE 16)))
            ((<= NBITS 32)
             (QUOTE (SIGNED-BYTE 32)))
            (T T)))))

(%%GET-ENCLOSING-UNSIGNED-BYTE

  (LAMBDA (ELEMENT-TYPE)
                                     (* jop: " 6-Jul-86 12:50")

          
          (* *)


    (LET ((NBITS (CADR ELEMENT-TYPE)))
         (COND
            ((<= NBITS 1)
             (QUOTE (UNSIGNED-BYTE 1)))
            ((<= NBITS 8)
             (QUOTE (UNSIGNED-BYTE 8)))
            ((<= NBITS 16)
             (QUOTE (UNSIGNED-BYTE 16)))
            (T T)))))

(%%MAKE-ARRAY-STORAGE

  (LAMBDA (NELTS TYPENUMBER INIT-ON-PAGE ALIGNMENT)
          (* jop: " 5-Sep-86 14:18")

          
          (* *)


    (LET ((BITS-PER-ELEMENT (%%TYPENUMBER-TO-BITS-PER-ELEMENT TYPENUMBER))
          (GC-TYPE (%%TYPENUMBER-TO-GC-TYPE TYPENUMBER)))    (* Initialize Strings to |\Space)

         (\ALLOCBLOCK (FOLDHI (CL:* NELTS BITS-PER-ELEMENT)
                             BITSPERCELL)
                GC-TYPE INIT-ON-PAGE ALIGNMENT))))

(%%REDUCE-INTEGER

  (LAMBDA (ELEMENT-TYPE)
    (LET ((LOW (CADR ELEMENT-TYPE))
          (HIGH (CADDR ELEMENT-TYPE)))
         (CL:IF (LISTP LOW)
                (SETQ LOW (1+ (CAR LOW))))
         (CL:IF (LISTP HIGH)
                (SETQ HIGH (1- (CAR HIGH))))
         (CL:IF (< LOW HIGH)
                (COND
                   ((>= LOW 0)                               (* (INTEGER + high) =>

                                                             (MOD (1+ HIGH)))

                    (COND
                       ((< HIGH 2)
                        (QUOTE (UNSIGNED-BYTE 1)))
                       ((< HIGH 256)
                        (QUOTE (UNSIGNED-BYTE 8)))
                       ((< HIGH 65536)
                        (QUOTE (UNSIGNED-BYTE 16)))
                       (T T)))
                   (T (LET ((BOUND (MAX (ABS LOW)
                                        HIGH)))
                           (COND
                              ((< BOUND 32768)
                               (QUOTE (SIGNED-BYTE 16)))
                              ((<= BOUND MAX.FIXP)
                               (QUOTE (SIGNED-BYTE 32)))
                              (T T)))))))))

(%%REDUCE-MOD

  (LAMBDA (ELEMENT-TYPE)
                                     (* jop: " 6-Jul-86 12:50")

          
          (* *)


    (LET ((MODNUM (CADR ELEMENT-TYPE)))
         (COND
            ((<= MODNUM 2)
             (QUOTE (UNSIGNED-BYTE 1)))
            ((<= MODNUM 256)
             (QUOTE (UNSIGNED-BYTE 8)))
            ((<= MODNUM 65536)
             (QUOTE (UNSIGNED-BYTE 16)))
            (T T)))))

(%%SLOW-ARRAY-READ

  (LAMBDA (BASE TYPENUMBER ROW-MAJOR-INDEX)
                  (* jop: " 5-Sep-86 14:16")

          
          (* *)


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

(%%SLOW-ARRAY-WRITE

  (LAMBDA (NEWVALUE BASE TYPENUMBER ROW-MAJOR-INDEX)
         (* jop: " 5-Sep-86 14:16")

          
          (* *)


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


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

(LOCALVARS . T)
)
)

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

(ADDTOVAR NLAMA
 )

(ADDTOVAR NLAML
 )

(ADDTOVAR LAMA
 VECTOR ASET ARRAY-ROW-MAJOR-INDEX ARRAY-IN-BOUNDS-P AREF)
)
(PUTPROPS CMLARRAY COPYRIGHT ("Xerox Corporation" 1986))
(DECLARE: DONTCOPY
  (FILEMAP (NIL (44122 54693 (%%COPY-TO-NEW-ARRAY 44132 . 45697) (AREF 45699 . 48847) (ARRAY-IN-BOUNDS-P
 48849 . 49389) (ARRAY-ROW-MAJOR-INDEX 49391 . 50209) (ASET 50211 . 54372) (VECTOR 54374 . 54691)) (
54753 54947 (SCHARSET 54763 . 54945)) (55262 91119 (%%ALTER-AS-DISPLACED-ARRAY 55272 . 58128) (
%%ALTER-AS-DISPLACED-TO-BASE-ARRAY 58130 . 59636) (%%AREF0 59638 . 60389) (%%AREF1 60391 . 61544) (
%%AREF2 61546 . 63576) (%%ARRAY-BASE 63578 . 64272) (%%ARRAY-CONTENT-INITIALIZE 64274 . 64859) (
%%ARRAY-ELEMENT-INITIALIZE 64861 . 65205) (%%ARRAY-OFFSET 65207 . 65925) (%%ARRAY-TYPE-NUMBER 65927 . 
66788) (%%ASET0 66790 . 67783) (%%ASET1 67785 . 69232) (%%ASET2 69234 . 71480) (
%%CHECK-SEQUENCE-DIMENSIONS 71482 . 72046) (%%DO-LOGICAL-OP 72048 . 74229) (%%EXTEND-ARRAY 74231 . 
76297) (%%FAST-COPY-BASE 76299 . 78582) (%%FAT-STRING-ARRAY-P 78584 . 78795) (
%%FILL-ARRAY-FROM-SEQUENCE 78797 . 79487) (%%FLATTEN-ARRAY 79489 . 79966) (%%MAKE-ARRAY-WRITEABLE 
79968 . 82173) (%%MAKE-DISPLACED-ARRAY 82175 . 84762) (%%MAKE-GENERAL-ARRAY 84764 . 86008) (
%%MAKE-ONED-ARRAY 86010 . 87043) (%%MAKE-STRING-ARRAY-FAT 87045 . 89279) (%%MAKE-TWOD-ARRAY 89281 . 
90104) (%%TOTAL-SIZE 90106 . 90423) (SHRINK-VECTOR 90425 . 91117)) (91160 93792 (%%SET-ARRAY-OFFSET 
91170 . 93070) (%%SET-ARRAY-TYPE-NUMBER 93072 . 93790)) (93852 95267 (%%ARRAYP 93862 . 94114) (
%%SIMPLE-ARRAY-P 94116 . 94356) (%%SIMPLE-STRING-P 94358 . 94666) (%%STRINGP 94668 . 94955) (%%VECTORP
 94957 . 95265)) (95303 96119 (%%GENERAL-ARRAY-P 95313 . 95512) (%%ONED-ARRAY-P 95514 . 95707) (
%%THIN-STRING-ARRAY-P 95709 . 95922) (%%TWOD-ARRAY-P 95924 . 96117)) (107989 118642 (%%DEFPRINT-ARRAY 
107999 . 109533) (%%DEFPRINT-BITVECTOR 109535 . 111968) (%%DEFPRINT-GENERIC-ARRAY 111970 . 113042) (
%%DEFPRINT-VECTOR 113044 . 115669) (%%DEFPRINT-STRING 115671 . 116727) (%%PRINT-ARRAY-CONTENTS 116729
 . 118640)) (118989 124662 (%%ARRAY-READ 118999 . 119104) (%%ARRAY-WRITE 119106 . 119283) (
%%CML-TYPE-TO-TYPENUMBER 119285 . 119690) (%%GET-CANONICAL-CML-TYPE 119692 . 121177) (
%%GET-ENCLOSING-SIGNED-BYTE 121179 . 121547) (%%GET-ENCLOSING-UNSIGNED-BYTE 121549 . 121987) (
%%MAKE-ARRAY-STORAGE 121989 . 122469) (%%REDUCE-INTEGER 122471 . 123667) (%%REDUCE-MOD 123669 . 124099
) (%%SLOW-ARRAY-READ 124101 . 124311) (%%SLOW-ARRAY-WRITE 124313 . 124660)))))
STOP