(FILECREATED " 2-Oct-86 12:20:02" {QV}<PEDERSEN>LISP>CMLARRAY.;28 125121
changes to: (FUNCTIONS FILL-VECTOR FILL-ARRAY)
(VARS CMLARRAYCOMS)
(RECORDS ARRAY-HEADER)
previous date: " 2-Oct-86 12:01:26" {QV}<PEDERSEN>LISP>CMLARRAY.;27)
(* "
Copyright (c) 1986 by Xerox Corporation. All rights reserved.
")
(PRETTYCOMPRINT CMLARRAYCOMS)
(RPAQQ CMLARRAYCOMS
((* * "Contains table driven macros")
(DECLARE: DONTCOPY EVAL@COMPILE (FILES 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
(FILESLOAD CMLARRAY-SUPPORT)
)
(* * "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: " 5-Sep-86 11:39")
(OR (COND
((LISTP 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 ((PROP (GETPROP (CAR ELEMENT-TYPE)
(QUOTE DEFTYPE))))
(AND PROP (%%GET-CANONICAL-CML-TYPE (\TYPEP.EXPAND.MACRO PROP
ELEMENT-TYPE)))))))
(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 ((PROP (GET ELEMENT-TYPE (QUOTE DEFTYPE))))
(AND PROP (%%GET-CANONICAL-CML-TYPE (\TYPEP.EXPAND.MACRO
PROP
(LIST ELEMENT-TYPE)))))))))
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 (44000 54571 (%%COPY-TO-NEW-ARRAY 44010 . 45575) (AREF 45577 . 48725) (ARRAY-IN-BOUNDS-P
48727 . 49267) (ARRAY-ROW-MAJOR-INDEX 49269 . 50087) (ASET 50089 . 54250) (VECTOR 54252 . 54569)) (
54631 54825 (SCHARSET 54641 . 54823)) (55140 90997 (%%ALTER-AS-DISPLACED-ARRAY 55150 . 58006) (
%%ALTER-AS-DISPLACED-TO-BASE-ARRAY 58008 . 59514) (%%AREF0 59516 . 60267) (%%AREF1 60269 . 61422) (
%%AREF2 61424 . 63454) (%%ARRAY-BASE 63456 . 64150) (%%ARRAY-CONTENT-INITIALIZE 64152 . 64737) (
%%ARRAY-ELEMENT-INITIALIZE 64739 . 65083) (%%ARRAY-OFFSET 65085 . 65803) (%%ARRAY-TYPE-NUMBER 65805 .
66666) (%%ASET0 66668 . 67661) (%%ASET1 67663 . 69110) (%%ASET2 69112 . 71358) (
%%CHECK-SEQUENCE-DIMENSIONS 71360 . 71924) (%%DO-LOGICAL-OP 71926 . 74107) (%%EXTEND-ARRAY 74109 .
76175) (%%FAST-COPY-BASE 76177 . 78460) (%%FAT-STRING-ARRAY-P 78462 . 78673) (
%%FILL-ARRAY-FROM-SEQUENCE 78675 . 79365) (%%FLATTEN-ARRAY 79367 . 79844) (%%MAKE-ARRAY-WRITEABLE
79846 . 82051) (%%MAKE-DISPLACED-ARRAY 82053 . 84640) (%%MAKE-GENERAL-ARRAY 84642 . 85886) (
%%MAKE-ONED-ARRAY 85888 . 86921) (%%MAKE-STRING-ARRAY-FAT 86923 . 89157) (%%MAKE-TWOD-ARRAY 89159 .
89982) (%%TOTAL-SIZE 89984 . 90301) (SHRINK-VECTOR 90303 . 90995)) (91038 93670 (%%SET-ARRAY-OFFSET
91048 . 92948) (%%SET-ARRAY-TYPE-NUMBER 92950 . 93668)) (93730 95145 (%%ARRAYP 93740 . 93992) (
%%SIMPLE-ARRAY-P 93994 . 94234) (%%SIMPLE-STRING-P 94236 . 94544) (%%STRINGP 94546 . 94833) (%%VECTORP
94835 . 95143)) (95181 95997 (%%GENERAL-ARRAY-P 95191 . 95390) (%%ONED-ARRAY-P 95392 . 95585) (
%%THIN-STRING-ARRAY-P 95587 . 95800) (%%TWOD-ARRAY-P 95802 . 95995)) (107867 118520 (%%DEFPRINT-ARRAY
107877 . 109411) (%%DEFPRINT-BITVECTOR 109413 . 111846) (%%DEFPRINT-GENERIC-ARRAY 111848 . 112920) (
%%DEFPRINT-VECTOR 112922 . 115547) (%%DEFPRINT-STRING 115549 . 116605) (%%PRINT-ARRAY-CONTENTS 116607
. 118518)) (118867 124672 (%%ARRAY-READ 118877 . 118982) (%%ARRAY-WRITE 118984 . 119161) (
%%CML-TYPE-TO-TYPENUMBER 119163 . 119568) (%%GET-CANONICAL-CML-TYPE 119570 . 121187) (
%%GET-ENCLOSING-SIGNED-BYTE 121189 . 121557) (%%GET-ENCLOSING-UNSIGNED-BYTE 121559 . 121997) (
%%MAKE-ARRAY-STORAGE 121999 . 122479) (%%REDUCE-INTEGER 122481 . 123677) (%%REDUCE-MOD 123679 . 124109
) (%%SLOW-ARRAY-READ 124111 . 124321) (%%SLOW-ARRAY-WRITE 124323 . 124670)))))
STOP