(FILECREATED "29-Jul-86 04:04:40" {ERIS}<LISPCORE>LIBRARY>CMLARRAY.;94 131355
changes to: (FNS \GET-CANONICAL-CML-TYPE \REDUCE-INTEGER)
(FUNCTIONS MAKE-ARRAY)
previous date: "25-Jul-86 00:17:37" {ERIS}<LISPCORE>LIBRARY>CMLARRAY.;93)
(* Copyright (c) 1986 by Xerox Corporation. All rights reserved.)
(PRETTYCOMPRINT CMLARRAYCOMS)
(RPAQQ CMLARRAYCOMS
[(* * User entry points)
(FUNCTIONS ADJUST-ARRAY MAKE-ARRAY VECTOR-PUSH-EXTEND)
(FNS ADJUSTABLE-ARRAY-P AREF ARRAY-DIMENSION ARRAY-DIMENSIONS ARRAY-DISPLACED-P
ARRAY-ELEMENT-TYPE ARRAY-HAS-FILL-POINTER-P ARRAY-IN-BOUNDS-P ARRAY-RANK
ARRAY-ROW-MAJOR-INDEX ARRAY-TOTAL-SIZE ASET BIT-AND BIT-ANDC1 BIT-ANDC2 BIT-EQV BIT-IOR
BIT-NAND BIT-NOR BIT-NOT BIT-ORC1 BIT-ORC2 BIT-VECTOR-P BIT-XOR CL:ARRAYP CL:STRINGP
FILL-POINTER SCHAR CHAR SCHARSET SET-FILL-POINTER SIMPLE-ARRAY-P SIMPLE-BIT-VECTOR-P
SIMPLE-STRING-P SIMPLE-VECTOR-P VECTOR VECTOR-POP VECTOR-PUSH VECTORP)
(SETFS AREF BIT FILL-POINTER SBIT SCHAR SVREF CHAR)
(* These need to be functions)
[DECLARE: DONTEVAL@LOAD DOCOPY (P (MOVD (FUNCTION AREF)
(FUNCTION BIT))
(MOVD (FUNCTION AREF)
(FUNCTION SBIT))
(MOVD (FUNCTION AREF)
(FUNCTION SVREF]
(* * Vars, etc.)
(VARIABLES ARRAY-RANK-LIMIT ARRAY-TOTAL-SIZE-LIMIT ARRAY-DIMENSION-LIMIT
*DEFAULT-PUSH-EXTENSION-SIZE* *PRINT-ARRAY*)
(* * Internal stuff)
(FNS SHRINK-VECTOR \ALTER-AS-DISPLACED-ARRAY \ALTER-AS-DISPLACED-TO-BASE-ARRAY \AREF0 \AREF1
\AREF2 \ARRAY-BASE \ARRAY-CONTENT-INITIALIZE \ARRAY-ELEMENT-INITIALIZE \ARRAY-OFFSET
\ASET0 \ASET1 \ASET2 \COPY-ARRAY-TO-ARRAY \COPY-LIST-TO-ARRAY \DO-LOGICAL-OP
\EQUAL-LIST-DIMENSIONS \FAT-STRING-ARRAY-P \FILL-NEW-ARRAY \FLATTEN-ARRAY
\GET-ARRAY-OFFSET \MAKE-DISPLACED-ARRAY \MAKE-DISPLACED-TO-BASE-ARRAY
\MAKE-GENERAL-ARRAY \MAKE-NON-SIMPLE-ARRAY \MAKE-ONED-ARRAY \MAKE-SIMPLE-ARRAY
\MAKE-STRING-FAT \MAKE-TWOD-ARRAY \TOTAL-SIZE)
(FUNCTIONS ASET-MACRO)
(* Faster predicates not including IL:STRINGP's)
(FNS \ARRAYP \SIMPLE-ARRAY-P \SIMPLE-STRING-P \SIMPLE-VECTOR-P \STRING-ARRAY-P \STRINGP
\VECTORP)
(* Low level predicates)
(FNS \GENERAL-ARRAY-P \ONED-ARRAY-P \THIN-STRING-ARRAY-P \TWOD-ARRAY-P)
(* Record def's)
(INITRECORDS GENERAL-ARRAY ONED-ARRAY TWOD-ARRAY)
(* * Don't need this stuff at run time)
(DECLARE: DONTCOPY EVAL@COMPILE (RECORDS ARRAY-HEADER GENERAL-ARRAY ONED-ARRAY TWOD-ARRAY)
(FUNCTIONS \CHECK-INDICES \GENERAL-ARRAY-ADJUST-BASE \EXPAND-BIT-OP)
(CONSTANTS \GENERAL-ARRAY \ONED-ARRAY \TWOD-ARRAY))
(* * Optimizers)
(FNS \AREF-EXPANDER \ASET-EXPANDER)
(MACROS AREF ASET BIT SBIT SCHAR SVREF \ARRAYP)
(PROP DOPVAL \AREF1 \AREF2 \ASET1 \ASET2 \GENERAL-ARRAY-P \ONED-ARRAY-P \TWOD-ARRAY-P)
(* * I/O)
(FNS \DEFPRINT-ARRAY \DEFPRINT-BITVECTOR \DEFPRINT-VECTOR \DEFPRINT-STRING
\PRINT-ARRAY-CONTENTS)
(P (DEFPRINT (QUOTE ONED-ARRAY)
(FUNCTION \DEFPRINT-VECTOR))
(DEFPRINT (QUOTE TWOD-ARRAY)
(FUNCTION \DEFPRINT-ARRAY))
(DEFPRINT (QUOTE GENERAL-ARRAY)
(FUNCTION \DEFPRINT-ARRAY)))
(* * Aux files)
(COMS * LOWCMLARRAYCOMS)
(* * Compiler options)
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY (LOCALVARS . T))
(PROP FILETYPE CMLARRAY)
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
(ADDVARS (NLAMA)
(NLAML)
(LAMA SHRINK-VECTOR VECTOR ASET ARRAY-ROW-MAJOR-INDEX ARRAY-IN-BOUNDS-P AREF])
(* * 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) (* jop: " 7-Jul-86 16:37")
(* *)
(SETQ DIMENSIONS (MKLIST DIMENSIONS))
(if (NOT (for DIM in DIMENSIONS always (AND (FIXP DIM)
(IGEQ DIM 0))))
then (ERROR "Illegal dimensions" DIMENSIONS))
(if (NOT (ADJUSTABLE-ARRAY-P ADJUSTABLE-ARRAY))
then (ERROR "Not an adjustable array" ADJUSTABLE-ARRAY))
(LET ((ADJUSTABLE-ARRAY-DIMENSIONS (ARRAY-DIMENSIONS ADJUSTABLE-ARRAY))
(ADJUSTABLE-ARRAY-RANK (ARRAY-RANK ADJUSTABLE-ARRAY))
(NELTS (\TOTAL-SIZE DIMENSIONS))
(RANK (LENGTH DIMENSIONS)))
(* * Consistency checks)
(for DIM in DIMENSIONS do (if (IGREATERP DIM ARRAY-DIMENSION-LIMIT)
then (ERROR "Too many levels" DIM)))
(if (IGREATERP NELTS ARRAY-TOTAL-SIZE-LIMIT)
then (ERROR "Too many elements" NELTS))
(if (IGREATERP RANK ARRAY-RANK-LIMIT)
then (ERROR "Too many dimensions" RANK))
(if (NOT (EQL RANK ADJUSTABLE-ARRAY-RANK))
then (ERROR "Rank mismatch" ADJUSTABLE-ARRAY))
(if (AND ELEMENT-TYPE-P (NOT (EQUAL ELEMENT-TYPE (ARRAY-ELEMENT-TYPE ADJUSTABLE-ARRAY))))
then (ERROR "ADJUSTABLE-ARRAY not of specified element-type" ELEMENT-TYPE)
else (SETQ ELEMENT-TYPE (ARRAY-ELEMENT-TYPE ADJUSTABLE-ARRAY)))
(if (AND FILL-POINTER-P (NULL FILL-POINTER)
(ARRAY-HAS-FILL-POINTER-P ADJUSTABLE-ARRAY))
then (ERROR "ADJUSTABLE-ARRAY has fill pointer" ADJUSTABLE-ARRAY))
(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 (NEQ RANK 1))
(AND DISPLACED-INDEX-OFFSET-P (NOT (OR DISPLACED-TO-P DISPLACED-TO-BASE-P)))
(AND INITIAL-ELEMENT-P INITIAL-CONTENTS-P))
then (ERROR "Inconsistent options to ADJUST-ARRAY"))
(if DISPLACED-TO-P
then (if (NOT (\ARRAYP DISPLACED-TO))
then (ERROR "Not displaced to a cmlarray" DISPLACED-TO))
(if (NOT (EQUAL (ARRAY-ELEMENT-TYPE ADJUSTABLE-ARRAY)
(ARRAY-ELEMENT-TYPE DISPLACED-TO)))
then (ERROR "Not displaced to an array of the same element-type" DISPLACED-TO))
(if (IGREATERP (IPLUS DISPLACED-INDEX-OFFSET NELTS)
(ARRAY-TOTAL-SIZE DISPLACED-TO))
then (ERROR "More elements than displaced-to array" DISPLACED-TO)))
(if FILL-POINTER-P
then (if (EQ FILL-POINTER T)
then (SETQ FILL-POINTER (FILL-POINTER ADJUSTABLE-ARRAY))
elseif (NOT (AND (FIXP FILL-POINTER)
(IGEQ FILL-POINTER 0)
(ILEQ FILL-POINTER NELTS)))
then (ERROR "Fill pointer out of bounds" FILL-POINTER))
else (if (ARRAY-HAS-FILL-POINTER-P ADJUSTABLE-ARRAY)
then (SETQ FILL-POINTER (FILL-POINTER ADJUSTABLE-ARRAY))))
(* * Specs ready, do the surgury)
(if DISPLACED-TO-P
then (\ALTER-AS-DISPLACED-ARRAY ADJUSTABLE-ARRAY DIMENSIONS ELEMENT-TYPE DISPLACED-TO
DISPLACED-INDEX-OFFSET FILL-POINTER)
elseif DISPLACED-TO-BASE-P
then (\ALTER-AS-DISPLACED-TO-BASE-ARRAY ADJUSTABLE-ARRAY DIMENSIONS ELEMENT-TYPE
DISPLACED-TO-BASE DISPLACED-INDEX-OFFSET FILL-POINTER FATP)
else (if (EQUAL ADJUSTABLE-ARRAY-DIMENSIONS DIMENSIONS)
then (if FILL-POINTER
then (SET-FILL-POINTER ADJUSTABLE-ARRAY FILL-POINTER))
else (LET ((NEW-ARRAY (MAKE-ARRAY DIMENSIONS (QUOTE :ELEMENT-TYPE)
ELEMENT-TYPE
(QUOTE :FATP)
(OR FATP (\FAT-STRING-ARRAY-P ADJUSTABLE-ARRAY)))))
(if INITIAL-CONTENTS-P
then (\ARRAY-CONTENT-INITIALIZE NEW-ARRAY INITIAL-CONTENTS)
else (if INITIAL-ELEMENT-P
then (\ARRAY-ELEMENT-INITIALIZE NEW-ARRAY INITIAL-ELEMENT))
(\FILL-NEW-ARRAY ADJUSTABLE-ARRAY NEW-ARRAY))
(\ALTER-AS-DISPLACED-ARRAY ADJUSTABLE-ARRAY DIMENSIONS ELEMENT-TYPE
NEW-ARRAY 0 FILL-POINTER))))
ADJUSTABLE-ARRAY))
(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 FATP &AUX NELTS RANK)
(ETYPECASE DIMENSIONS ((INTEGER 0)
(SETQ DIMENSIONS (LIST DIMENSIONS)))
((LIST (INTEGER 0 (ARRAY-DIMENSION-LIMIT)))))
(CL:ASSERT (AND (< (SETQ NELTS (\TOTAL-SIZE DIMENSIONS))
ARRAY-TOTAL-SIZE-LIMIT)
(< (SETQ RANK (LENGTH DIMENSIONS))
ARRAY-RANK-LIMIT))
(DIMENSIONS)
"~A not valid dimensions for MAKE-ARRAY" DIMENSIONS)
(LET ((SIMPLE-P (NOT (OR ADJUSTABLE FILL-POINTER DISPLACED-TO-P DISPLACED-TO-BASE-P)))
ARRAY)
(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 (NEQ RANK 1))
(AND DISPLACED-INDEX-OFFSET-P (NOT (OR DISPLACED-TO-P DISPLACED-TO-BASE-P)))
(AND INITIAL-ELEMENT-P INITIAL-CONTENTS-P))
then (CL:ERROR "Inconsistent options to MAKE-ARRAY"))
(if DISPLACED-TO-P
then (if (NOT (\ARRAYP DISPLACED-TO))
then (CL:ERROR "Cannot currenlty displace to an Interlisp array/string"))
(if (NOT (EQUAL (\GET-CANONICAL-CML-TYPE ELEMENT-TYPE)
(ARRAY-ELEMENT-TYPE DISPLACED-TO)))
then (CL:ERROR "Not displaced to an array of the same element-type"))
(if (IGREATERP (IPLUS DISPLACED-INDEX-OFFSET NELTS)
(ARRAY-TOTAL-SIZE DISPLACED-TO))
then (CL:ERROR "displaced array out of bounds")))
(if FILL-POINTER
then (if (EQ FILL-POINTER T)
then (SETQ FILL-POINTER NELTS)
elseif (NOT (AND (FIXP FILL-POINTER)
(IGEQ FILL-POINTER 0)
(ILEQ FILL-POINTER NELTS)))
then (CL:ERROR "Fill pointer out of bounds")))
(* * Specs ready, cases separated by type of the data structure it is
implemented by.)
(SETQ ARRAY (if SIMPLE-P
then (\MAKE-SIMPLE-ARRAY NELTS DIMENSIONS ELEMENT-TYPE FATP)
elseif DISPLACED-TO-P
then (\MAKE-DISPLACED-ARRAY NELTS DIMENSIONS ELEMENT-TYPE DISPLACED-TO
DISPLACED-INDEX-OFFSET FILL-POINTER ADJUSTABLE)
elseif DISPLACED-TO-BASE
then (\MAKE-DISPLACED-TO-BASE-ARRAY NELTS DIMENSIONS ELEMENT-TYPE
DISPLACED-TO-BASE DISPLACED-INDEX-OFFSET FILL-POINTER ADJUSTABLE
FATP)
else (\MAKE-NON-SIMPLE-ARRAY NELTS DIMENSIONS ELEMENT-TYPE FILL-POINTER
ADJUSTABLE FATP)))
(* * Initialize the storage)
(if INITIAL-CONTENTS-P
then (\ARRAY-CONTENT-INITIALIZE ARRAY INITIAL-CONTENTS)
elseif INITIAL-ELEMENT-P
then (\ARRAY-ELEMENT-INITIALIZE ARRAY INITIAL-ELEMENT))
ARRAY))
(DEFUN VECTOR-PUSH-EXTEND (NEW-ELEMENT VECTOR &OPTIONAL (EXTENSION-SIZE *DEFAULT-PUSH-EXTENSION-SIZE*
))
(* jop: "30-Apr-86 14:06")
(* *)
(LET ((NEW-INDEX (VECTOR-PUSH NEW-ELEMENT VECTOR)))
(if (NULL NEW-INDEX)
then (if (ADJUSTABLE-ARRAY-P VECTOR)
then (if (SMALLPOSP EXTENSION-SIZE)
then (ADJUST-ARRAY VECTOR (IPLUS (ARRAY-TOTAL-SIZE VECTOR)
EXTENSION-SIZE))
else (ERROR "EXTENSION-SIZE not a small positive integer" EXTENSION-SIZE)
)
else (ERROR "Vector not adjustable" VECTOR))
(VECTOR-PUSH NEW-ELEMENT VECTOR)
else NEW-INDEX)))
(DEFINEQ
(ADJUSTABLE-ARRAY-P
(LAMBDA (ARRAY) (* jop: "13-Jul-86 14:15")
(* *)
(if (\ARRAYP ARRAY)
then (fetch (ARRAY-HEADER ADJUSTABLE-P) of ARRAY)
else (* Hack to handle IL:STRINGP's)
(if (STRINGP ARRAY)
then NIL
else (ERROR "Not an array" ARRAY)))))
(AREF
(LAMBDA ARGS (* jop: "15-Jul-86 20:49")
(* *)
(if (ILESSP ARGS 1)
then (ERROR "Aref takes at least one arg"))
(SELECTQ ARGS
(1 (\AREF0 (ARG ARGS 1)))
(2 (\AREF1 (ARG ARGS 1)
(ARG ARGS 2)))
(3 (\AREF2 (ARG ARGS 1)
(ARG ARGS 2)
(ARG ARGS 3)))
(LET ((ARRAY (ARG ARGS 1)))
(if (NOT (\ARRAYP ARRAY))
then (ERROR "Not a cmlarray" ARRAY)
elseif (NOT (EQL (ARRAY-RANK ARRAY)
(SUB1 ARGS)))
then (ERROR "Rank mismatch")
else (* If we've gotten this far ARRAY must
be a general array)
(bind INDEX for I from 2 to ARGS as DIM in (ffetch (GENERAL-ARRAY DIMS)
of ARRAY)
do (SETQ INDEX (ARG ARGS I))
(if (NOT (AND (SMALLPOSP INDEX)
(ILESSP INDEX DIM)))
then (ERROR "Index out of bounds" INDEX)))
(* * Now proceed to extract the element)
(LET ((BASE (ffetch (GENERAL-ARRAY STORAGE) of ARRAY))
(ROW-MAJOR-INDEX (bind (OFFSET ← (ffetch (GENERAL-ARRAY OFFSET)
of ARRAY))
(TOTAL ← 0) for I from 2 to (SUB1 ARGS) as DIM
in (CDR (ffetch (GENERAL-ARRAY DIMS) of ARRAY))
do (SETQ TOTAL (ITIMES DIM (IPLUS TOTAL
(ARG ARGS I))))
finally (RETURN (IPLUS OFFSET TOTAL (ARG ARGS ARGS)))))
(TYPENUMBER (ffetch (GENERAL-ARRAY TYPENUMBER) of ARRAY)))
(if (\ARRAYP BASE)
then (\GENERAL-ARRAY-ADJUST-BASE BASE ROW-MAJOR-INDEX TYPENUMBER))
(\LLARRAY-READ BASE TYPENUMBER ROW-MAJOR-INDEX)))))))
(ARRAY-DIMENSION
(LAMBDA (ARRAY DIMENSION) (* jop: "13-Jul-86 14:17")
(* *)
(if (\ARRAYP ARRAY)
then (LET ((RANK (ARRAY-RANK ARRAY)))
(if (NOT (AND (IGEQ DIMENSION 0)
(ILESSP DIMENSION RANK)))
then (ERROR "Dimension out of bounds" DIMENSION)
else (* Don't always use the default case
to avoid consing for ONED and TWOD
arrays)
(if (EQL RANK 1)
then (* Includes the oned case)
(fetch (ARRAY-HEADER TOTALSIZE) of ARRAY)
elseif (\TWOD-ARRAY-P ARRAY)
then (SELECTQ DIMENSION
(0 (ffetch (TWOD-ARRAY BOUND0) of ARRAY))
(1 (ffetch (TWOD-ARRAY BOUND1) of ARRAY))
(SHOULDNT))
else (* Must be a general array)
(CAR (FNTH (ffetch (GENERAL-ARRAY DIMS) of ARRAY)
(ADD1 DIMENSION))))))
else (* Hack to handle IL:STRINGP's)
(if (STRINGP ARRAY)
then (if (EQL DIMENSION 0)
then (NCHARS ARRAY)
else (ERROR "Dimension out of bounds" DIMENSION))
else (ERROR "Not an array" ARRAY)))))
(ARRAY-DIMENSIONS
(LAMBDA (ARRAY) (* jop: "13-Jul-86 12:34")
(* *)
(if (\ONED-ARRAY-P ARRAY)
then (LIST (ffetch (ONED-ARRAY TOTALSIZE) of ARRAY))
elseif (\TWOD-ARRAY-P ARRAY)
then (LIST (ffetch (TWOD-ARRAY BOUND0) of ARRAY)
(ffetch (TWOD-ARRAY BOUND1) of ARRAY))
elseif (\GENERAL-ARRAY-P ARRAY)
then (ffetch (GENERAL-ARRAY DIMS) of ARRAY)
else (* Hack to handle IL:STRINGP's)
(if (STRINGP ARRAY)
then (LIST (NCHARS ARRAY))
else (ERROR "Not an array" ARRAY)))))
(ARRAY-DISPLACED-P
(LAMBDA (ARRAY) (* jop: "13-Jul-86 14:17")
(* *)
(if (\ARRAYP ARRAY)
then (fetch (ARRAY-HEADER DISPLACED-P) of ARRAY)
else (* Hack to handle IL:STRINGP's)
(if (STRINGP ARRAY)
then NIL
else (ERROR "Not an array" ARRAY)))))
(ARRAY-ELEMENT-TYPE
(LAMBDA (ARRAY) (* jop: "13-Jul-86 14:17")
(* *)
(if (\ARRAYP ARRAY)
then (\TYPENUMBER-TO-CML-TYPE (fetch (ARRAY-HEADER TYPENUMBER) of ARRAY))
else (* Hack to handle IL:STRINGP's)
(if (STRINGP ARRAY)
then (QUOTE STRING-CHAR)
else (ERROR "Not an array" ARRAY)))))
(ARRAY-HAS-FILL-POINTER-P
(LAMBDA (ARRAY) (* jop: "13-Jul-86 14:18")
(* *)
(if (\ARRAYP ARRAY)
then (fetch (ARRAY-HEADER FILLPOINTER-P) of ARRAY)
else (* Hack to handle IL:STRINGP's)
(if (STRINGP ARRAY)
then NIL
else (ERROR "Not an array" ARRAY)))))
(ARRAY-IN-BOUNDS-P
(LAMBDA ARGS (* jop: "13-Jul-86 14:20")
(* *)
(if (ILESSP ARGS 1)
then (ERROR "Array-in-bounds-p takes at least one arg"))
(LET ((ARRAY (ARG ARGS 1)))
(if (NOT (CL:ARRAYP ARRAY))
then (ERROR "Not an array" ARRAY)
elseif (NOT (EQL (ARRAY-RANK ARRAY)
(SUB1 ARGS)))
then (ERROR "Rank mismatch" (for I from 2 to ARGS collect (ARG ARGS I)))
else (\CHECK-INDICES ARRAY 2 ARGS)))))
(ARRAY-RANK
(LAMBDA (ARRAY) (* jop: "13-Jul-86 12:37")
(* *)
(if (\ONED-ARRAY-P ARRAY)
then 1
elseif (\TWOD-ARRAY-P ARRAY)
then 2
elseif (\GENERAL-ARRAY-P ARRAY)
then (LENGTH (ffetch (GENERAL-ARRAY DIMS) of ARRAY))
else (* Hack to handle IL:STRINGP's)
(if (STRINGP ARRAY)
then 1
else (ERROR "Not an array" ARRAY)))))
(ARRAY-ROW-MAJOR-INDEX
(LAMBDA ARGS (* jop: "13-Jul-86 13:13")
(* *)
(if (LESSP ARGS 1)
then (ERROR "Array-row-major-index takes at least one arg"))
(LET* ((ARRAY (ARG ARGS 1))
(RANK (ARRAY-RANK ARRAY)))
(if (NOT (EQL RANK (SUB1 ARGS)))
then (ERROR "Rank mismatch")
elseif (NOT (\CHECK-INDICES ARRAY 2 ARGS))
then (ERROR "Index out of bounds")
else (bind (ROWMAJORINDEX ← 0) for I from 2 to (SUB1 ARGS) as DIM from 1
do (SETQ ROWMAJORINDEX (ITIMES (ARRAY-DIMENSION ARRAY DIM)
(IPLUS ROWMAJORINDEX (ARG ARGS I))))
finally (RETURN (IPLUS ROWMAJORINDEX (ARG ARGS ARGS))))))))
(ARRAY-TOTAL-SIZE
(LAMBDA (ARRAY) (* jop: "13-Jul-86 14:20")
(* *)
(if (\ARRAYP ARRAY)
then (fetch (ARRAY-HEADER TOTALSIZE) of ARRAY)
else (* Hack to handle IL:STRINGP's)
(if (STRINGP ARRAY)
then (NCHARS ARRAY)
else (ERROR "Not an array" ARRAY)))))
(ASET
(LAMBDA ARGS (* jop: "15-Jul-86 20:52")
(* *)
(if (ILESSP ARGS 2)
then (ERROR "Aset takes at least two args"))
(SELECTQ ARGS
(2 (\ASET0 (ARG ARGS 1)
(ARG ARGS 2)))
(3 (\ASET1 (ARG ARGS 1)
(ARG ARGS 2)
(ARG ARGS 3)))
(4 (\ASET2 (ARG ARGS 1)
(ARG ARGS 2)
(ARG ARGS 3)
(ARG ARGS 4)))
(LET ((NEWVALUE (ARG ARGS 1))
(ARRAY (ARG ARGS 2)))
(if (NOT (\ARRAYP ARRAY))
then (ERROR "Not a cmlarray" ARRAY)
elseif (NOT (EQL (ARRAY-RANK ARRAY)
(IDIFFERENCE ARGS 2)))
then (ERROR "Rank mismatch")
else (* If we've gotten this far ARRAY must
be a general array)
(bind INDEX for I from 3 to ARGS as DIM in (ffetch (GENERAL-ARRAY DIMS)
of ARRAY)
do (SETQ INDEX (ARG ARGS I))
(if (NOT (AND (SMALLPOSP INDEX)
(ILESSP INDEX DIM)))
then (ERROR "Index out of bounds" INDEX)))
(* * Now proceed to set the element)
(LET ((BASE (ffetch (GENERAL-ARRAY STORAGE) of ARRAY))
(ROW-MAJOR-INDEX (bind (OFFSET ← (ffetch (GENERAL-ARRAY OFFSET)
of ARRAY))
(TOTAL ← 0) for I from 3 to (SUB1 ARGS) as DIM
in (CDR (ffetch (GENERAL-ARRAY DIMS) of ARRAY))
do (SETQ TOTAL (ITIMES DIM (IPLUS TOTAL
(ARG ARGS I))))
finally (RETURN (IPLUS OFFSET TOTAL (ARG ARGS ARGS)))))
(TYPENUMBER (ffetch (GENERAL-ARRAY TYPENUMBER) of ARRAY)))
(if (\ARRAYP BASE)
then (\GENERAL-ARRAY-ADJUST-BASE BASE ROW-MAJOR-INDEX TYPENUMBER))
(if (AND (\THIN-CHAR-TYPE-P TYPENUMBER)
(\FAT-STRING-CHAR-P NEWVALUE))
then (\MAKE-STRING-FAT ARRAY)
(CL:APPLY (FUNCTION ASET)
NEWVALUE ARRAY (for I from 3 to ARGS
collect (ARG ARGS I)))
else (\LLARRAY-WRITE NEWVALUE BASE TYPENUMBER ROW-MAJOR-INDEX))))))))
(BIT-AND
(LAMBDA (BIT-ARRAY1 BIT-ARRAY2 BIT-RESULT) (* jop: "15-Jul-86 23:17")
(* *)
(\EXPAND-BIT-OP AND BIT-ARRAY1 BIT-ARRAY2 BIT-RESULT)))
(BIT-ANDC1
(LAMBDA (BIT-ARRAY1 BIT-ARRAY2 BIT-RESULT) (* jop: "15-Jul-86 23:17")
(* *)
(\EXPAND-BIT-OP ANDC1 BIT-ARRAY1 BIT-ARRAY2 BIT-RESULT)))
(BIT-ANDC2
(LAMBDA (BIT-ARRAY1 BIT-ARRAY2 BIT-RESULT) (* jop: "15-Jul-86 23:17")
(* *)
(\EXPAND-BIT-OP ANDC2 BIT-ARRAY1 BIT-ARRAY2 BIT-RESULT)))
(BIT-EQV
(LAMBDA (BIT-ARRAY1 BIT-ARRAY2 BIT-RESULT) (* jop: "15-Jul-86 23:18")
(* *)
(\EXPAND-BIT-OP EQV BIT-ARRAY1 BIT-ARRAY2 BIT-RESULT)))
(BIT-IOR
(LAMBDA (BIT-ARRAY1 BIT-ARRAY2 BIT-RESULT) (* jop: "15-Jul-86 23:18")
(* *)
(\EXPAND-BIT-OP IOR BIT-ARRAY1 BIT-ARRAY2 BIT-RESULT)))
(BIT-NAND
(LAMBDA (BIT-ARRAY1 BIT-ARRAY2 BIT-RESULT) (* jop: "15-Jul-86 23:18")
(* *)
(\EXPAND-BIT-OP NAND BIT-ARRAY1 BIT-ARRAY2 BIT-RESULT)))
(BIT-NOR
(LAMBDA (BIT-ARRAY1 BIT-ARRAY2 BIT-RESULT) (* jop: "15-Jul-86 23:19")
(* *)
(\EXPAND-BIT-OP NOR BIT-ARRAY1 BIT-ARRAY2 BIT-RESULT)))
(BIT-NOT
(LAMBDA (BIT-ARRAY RESULT-BIT-ARRAY) (* jop: "15-Jul-86 14:58")
(* *)
(if (NOT (EQUAL (ARRAY-ELEMENT-TYPE BIT-ARRAY)
(QUOTE (UNSIGNED-BYTE 1))))
then (ERROR "Not a bit array" BIT-ARRAY))
(LET ((DIMS (ARRAY-DIMENSIONS BIT-ARRAY)))
(if (NULL RESULT-BIT-ARRAY)
then (SETQ RESULT-BIT-ARRAY (MAKE-ARRAY DIMS :ELEMENT-TYPE (QUOTE (UNSIGNED-BYTE 1))))
elseif (EQ RESULT-BIT-ARRAY T)
then (SETQ RESULT-BIT-ARRAY BIT-ARRAY)
elseif (NOT (AND (EQUAL (ARRAY-ELEMENT-TYPE RESULT-BIT-ARRAY)
(QUOTE (UNSIGNED-BYTE 1)))
(EQUAL (ARRAY-DIMENSIONS RESULT-BIT-ARRAY)
DIMS)))
then (ERROR "Illegal result array" RESULT-BIT-ARRAY))
(\DO-LOGICAL-OP (QUOTE NOT)
BIT-ARRAY RESULT-BIT-ARRAY)
RESULT-BIT-ARRAY)))
(BIT-ORC1
(LAMBDA (BIT-ARRAY1 BIT-ARRAY2 BIT-RESULT) (* jop: "15-Jul-86 23:20")
(* *)
(\EXPAND-BIT-OP ORC1 BIT-ARRAY1 BIT-ARRAY2 BIT-RESULT)))
(BIT-ORC2
(LAMBDA (BIT-ARRAY1 BIT-ARRAY2 BIT-RESULT) (* jop: "15-Jul-86 23:20")
(* *)
(\EXPAND-BIT-OP ORC2 BIT-ARRAY1 BIT-ARRAY2 BIT-RESULT)))
(BIT-VECTOR-P
(LAMBDA (VECTOR) (* jop: "14-Jul-86 17:57")
(* *)
(AND (\VECTORP VECTOR)
(EQUAL (ARRAY-ELEMENT-TYPE VECTOR)
(QUOTE (UNSIGNED-BYTE 1))))))
(BIT-XOR
(LAMBDA (BIT-ARRAY1 BIT-ARRAY2 BIT-RESULT) (* jop: "16-Jul-86 00:20")
(* *)
(\EXPAND-BIT-OP XOR BIT-ARRAY1 BIT-ARRAY2 BIT-RESULT)))
(CL:ARRAYP
(LAMBDA (ARRAY) (* jop: "14-Jul-86 17:53")
(* *)
(AND (OR (\ARRAYP ARRAY)
(STRINGP ARRAY))
T)))
(CL:STRINGP
(LAMBDA (STRING) (* jop: "14-Jul-86 17:53")
(* *)
(AND (OR (\STRINGP STRING)
(STRINGP STRING))
T)))
(FILL-POINTER
(LAMBDA (ARRAY) (* jop: "13-Jul-86 14:22")
(* *)
(if (\ARRAYP ARRAY)
then (if (fetch (ARRAY-HEADER FILLPOINTER-P) of ARRAY)
then (fetch (ARRAY-HEADER FILLPOINTER) of ARRAY)
else (ERROR "Array has no fill pointer" ARRAY))
else (ERROR "Not a cmlarray" ARRAY))))
(SCHAR
(LAMBDA (SIMPLE-STRING INDEX) (* lmm "17-Jul-86 01:53")
(AREF (THE SIMPLE-STRING SIMPLE-STRING)
INDEX)))
(CHAR
(LAMBDA (STRING INDEX) (* lmm "17-Jul-86 01:55")
(AREF (THE STRING STRING)
INDEX)))
(SCHARSET
(LAMBDA (SIMPLE-STRING INDEX VALUE) (* jop: "16-Jul-86 12:11")
(ASET VALUE SIMPLE-STRING INDEX)))
(SET-FILL-POINTER
(LAMBDA (ARRAY NEWVALUE) (* jop: "13-Jul-86 14:23")
(* *)
(if (\ARRAYP ARRAY)
then (if (fetch (ARRAY-HEADER FILLPOINTER-P) of ARRAY)
then (if (AND (IGEQ NEWVALUE 0)
(ILEQ NEWVALUE (fetch (ARRAY-HEADER TOTALSIZE) of ARRAY)))
then (replace (ARRAY-HEADER FILLPOINTER) of ARRAY with NEWVALUE)
else (ERROR "Fill pointer out of bounds" NEWVALUE))
NEWVALUE
else (ERROR "Array has no fill pointer" ARRAY))
else (ERROR "Not a cmlarray" ARRAY))))
(SIMPLE-ARRAY-P
(LAMBDA (ARRAY) (* jop: "14-Jul-86 17:55")
(* *)
(AND (OR (\SIMPLE-ARRAY-P ARRAY)
(STRINGP ARRAY))
T)))
(SIMPLE-BIT-VECTOR-P
(LAMBDA (VECTOR) (* jop: "13-Jul-86 14:45")
(* *)
(AND (\SIMPLE-VECTOR-P VECTOR)
(EQUAL (ARRAY-ELEMENT-TYPE VECTOR)
(QUOTE (UNSIGNED-BYTE 1))))))
(SIMPLE-STRING-P
(LAMBDA (STRING) (* jop: "16-Jul-86 13:36")
(* *)
(AND (OR (\SIMPLE-STRING-P STRING)
(STRINGP STRING))
T)))
(SIMPLE-VECTOR-P
(LAMBDA (VECTOR) (* jop: "14-Jul-86 17:55")
(* *)
(AND (OR (\SIMPLE-VECTOR-P VECTOR)
(STRINGP VECTOR))
T)))
(VECTOR
(LAMBDA ARGS (* jop: "11-Jul-86 17:27")
(LET ((ARRAY (MAKE-ARRAY ARGS)))
(for I from 1 to ARGS do (ASET (ARG ARGS I)
ARRAY
(SUB1 I)))
ARRAY)))
(VECTOR-POP
(LAMBDA (VECTOR) (* jop: "13-Jul-86 14:25")
(* *)
(if (\ARRAYP VECTOR)
then (if (fetch (ARRAY-HEADER FILLPOINTER-P) of VECTOR)
then (LET ((FILL-POINTER (fetch (ARRAY-HEADER FILLPOINTER) of VECTOR)))
(if (IGREATERP FILL-POINTER 0)
then (SETQ FILL-POINTER (SUB1 FILL-POINTER))
(replace (ARRAY-HEADER FILLPOINTER) of VECTOR with FILL-POINTER)
(AREF VECTOR FILL-POINTER)
else (ERROR "Can't pop from zero fill pointer" FILL-POINTER)))
else (ERROR "Vector has no fill pointer" VECTOR))
else (ERROR "Not a cmlarray" VECTOR))))
(VECTOR-PUSH
(LAMBDA (NEW-ELEMENT VECTOR) (* jop: "13-Jul-86 14:25")
(* *)
(if (\ARRAYP VECTOR)
then (if (fetch (ARRAY-HEADER FILLPOINTER-P) of VECTOR)
then (LET ((FILL-POINTER (fetch (ARRAY-HEADER FILLPOINTER) of VECTOR)))
(if (ILESSP FILL-POINTER (fetch (ARRAY-HEADER TOTALSIZE) of VECTOR))
then (ASET NEW-ELEMENT VECTOR FILL-POINTER)
(replace (ARRAY-HEADER FILLPOINTER) of VECTOR with (ADD1
FILL-POINTER
))
FILL-POINTER
else NIL))
else (ERROR "Vector has no fill pointer" VECTOR))
else (ERROR "Not a cmlarray" VECTOR))))
(VECTORP
(LAMBDA (VECTOR) (* jop: "14-Jul-86 17:54")
(* *)
(AND (OR (\VECTORP VECTOR)
(STRINGP VECTOR))
T)))
)
(DEFSETF AREF (ARRAY &REST INDICES) (NEWVALUE)
(BQUOTE (ASET (\, NEWVALUE)
(\, ARRAY)
(\,@ INDICES))))
(DEFSETF BIT (ARRAY &REST INDICES) (NEWVALUE)
(BQUOTE (ASET (\, NEWVALUE)
(THE (ARRAY BIT)
(\, ARRAY))
(\,@ INDICES))))
(DEFSETF FILL-POINTER SET-FILL-POINTER)
(DEFSETF SBIT (ARRAY &REST INDICES) (NEWVALUE)
(BQUOTE (ASET (\, NEWVALUE)
(\, ARRAY)
(\,@ INDICES))))
(DEFSETF SCHAR (ARRAY &REST INDICES) (NEWVALUE)
(BQUOTE (ASET (\, NEWVALUE)
(\, ARRAY)
(\,@ INDICES))))
(DEFSETF SVREF (ARRAY &REST INDICES) (NEWVALUE)
(BQUOTE (ASET (\, NEWVALUE)
(\, ARRAY)
(\,@ INDICES))))
(DEFSETF CHAR SCHARSET)
(* These need to be functions)
(DECLARE: DONTEVAL@LOAD DOCOPY
(MOVD (FUNCTION AREF)
(FUNCTION BIT))
(MOVD (FUNCTION AREF)
(FUNCTION SBIT))
(MOVD (FUNCTION AREF)
(FUNCTION SVREF))
)
(* * Vars, etc.)
(DEFCONSTANT ARRAY-RANK-LIMIT (EXPT 2 7) )
(DEFCONSTANT ARRAY-TOTAL-SIZE-LIMIT 65533)
(DEFCONSTANT ARRAY-DIMENSION-LIMIT ARRAY-TOTAL-SIZE-LIMIT)
(DEFPARAMETER *DEFAULT-PUSH-EXTENSION-SIZE* 20)
(DEFVAR *PRINT-ARRAY* T "True if arrays print out with their entire contents")
(* * Internal stuff)
(DEFINEQ
(SHRINK-VECTOR
(CL:LAMBDA (VECTOR NEW-SIZE) (* lmm "21-Jul-86 23:27")
(COND
((OR (\ONED-ARRAY-P VECTOR)
(AND (\GENERAL-ARRAY-P VECTOR)
(EQL (ARRAY-RANK VECTOR)
1)))
(CL:ASSERT (<= 0 NEW-SIZE (fetch (ARRAY-HEADER TOTALSIZE) of VECTOR))
NIL "Trying to shrink array ~A to bad size ~A" VECTOR NEW-SIZE)
(OR (fetch (ARRAY-HEADER FILLPOINTER-P) of VECTOR)
(SETF (fetch (ARRAY-HEADER FILLPOINTER-P) of VECTOR)
T))
(replace (ARRAY-HEADER FILLPOINTER) of VECTOR with NEW-SIZE)
VECTOR)
((STRINGP VECTOR)
(SUBSTRING VECTOR 1 (1- NEW-SIZE)
VECTOR))
(T (ERROR "not a vector" VECTOR)))))
(\ALTER-AS-DISPLACED-ARRAY
(LAMBDA (ADJUSTABLE-ARRAY DIMENSIONS ELEMENT-TYPE DISPLACED-TO DISPLACED-INDEX-OFFSET FILL-POINTER)
(* jop: "13-Jul-86 13:24")
(* * Alter ADJUSTABLE-ARRAY to be displaced-to DISPLACED-TO)
(if (NULL DISPLACED-INDEX-OFFSET)
then (SETQ DISPLACED-INDEX-OFFSET 0))
(LET ((DISPLACE-TO-TYPENUMBER (fetch (ARRAY-HEADER TYPENUMBER) of DISPLACED-TO))
BASE)
(if (OR (ADJUSTABLE-ARRAY-P DISPLACED-TO)
(\THIN-CHAR-TYPE-P DISPLACE-TO-TYPENUMBER))
then (* Provide for indirection)
(SETQ BASE DISPLACED-TO) (* Indirect strings are always FAT)
(if (\THIN-CHAR-TYPE-P DISPLACE-TO-TYPENUMBER)
then (SETQ DISPLACE-TO-TYPENUMBER \FAT-CHAR-TYPENUMBER))
else (* Fold double displacement to single
displacement)
(SETQ BASE (fetch (ARRAY-HEADER BASE) of DISPLACED-TO))
(SETQ DISPLACED-INDEX-OFFSET (IPLUS DISPLACED-INDEX-OFFSET (\GET-ARRAY-OFFSET
DISPLACED-TO))))
(UNINTERRUPTABLY
(with GENERAL-ARRAY ADJUSTABLE-ARRAY (SETQ STORAGE BASE)
(SETQ DISPLACED-P T)
(SETQ FILLPOINTER-P FILL-POINTER)
(SETQ STRING-P (AND (EQLENGTH DIMENSIONS 1)
(\CHAR-TYPE-P DISPLACE-TO-TYPENUMBER)))
(SETQ TYPENUMBER DISPLACE-TO-TYPENUMBER)
(SETQ OFFSET DISPLACED-INDEX-OFFSET)
(SETQ FILLPOINTER (OR FILL-POINTER 0))
(SETQ TOTALSIZE (\TOTAL-SIZE DIMENSIONS))
(SETQ DIMS 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: "13-Jul-86 13:24")
(* * Alter ADJUSTABLE-ARRAY to be displaced-to DISPLACED-TO-BASE)
(LET ((TYPEN (\CML-TYPE-TO-TYPENUMBER ELEMENT-TYPE FATP)))
(UNINTERRUPTABLY
(with GENERAL-ARRAY ADJUSTABLE-ARRAY (SETQ STORAGE DISPLACED-TO-BASE)
(SETQ DISPLACED-P T)
(SETQ FILLPOINTER-P FILL-POINTER)
(SETQ STRING-P (AND (EQLENGTH DIMENSIONS 1)
(\CHAR-TYPE-P TYPEN)))
(SETQ TYPENUMBER TYPEN)
(SETQ OFFSET (OR DISPLACED-INDEX-OFFSET 0))
(SETQ FILLPOINTER (OR FILL-POINTER 0))
(SETQ TOTALSIZE (\TOTAL-SIZE DIMENSIONS))
(SETQ DIMS DIMENSIONS)))
ADJUSTABLE-ARRAY)))
(\AREF0
(LAMBDA (ARRAY) (* jop: "15-Jul-86 20:47")
(* *)
(if (NOT (\ARRAYP ARRAY))
then (ERROR "Not an array" ARRAY)
elseif (NOT (EQL (ARRAY-RANK ARRAY)
0))
then (ERROR "Rank mismatch")
else
(* * Must be a general array)
(LET ((BASE (ffetch (GENERAL-ARRAY STORAGE) of ARRAY))
(TYPENUMBER (ffetch (GENERAL-ARRAY TYPENUMBER) of ARRAY))
(ROW-MAJOR-INDEX (ffetch (GENERAL-ARRAY OFFSET) of ARRAY)))
(if (\ARRAYP BASE)
then (\GENERAL-ARRAY-ADJUST-BASE BASE ROW-MAJOR-INDEX TYPENUMBER))
(\LLARRAY-READ BASE TYPENUMBER ROW-MAJOR-INDEX)))))
(\AREF1
(LAMBDA (ARRAY INDEX) (* jop: "16-Jul-86 12:09")
(* *)
(if (NOT (\ARRAYP ARRAY))
then (* Hack to handle IL:STRINGP's)
(if (STRINGP ARRAY)
then (INT-CHAR (NTHCHARCODE ARRAY (ADD1 INDEX)))
else (ERROR "Not an array" ARRAY))
elseif (NOT (EQL (ARRAY-RANK ARRAY)
1))
then (ERROR "Rank mismatch")
elseif (NOT (AND (SMALLPOSP INDEX)
(ILESSP INDEX (fetch (ARRAY-HEADER TOTALSIZE) of ARRAY))))
then (ERROR "Index out of bounds" INDEX)
else
(* * Now proceed to extract the element)
(LET ((BASE (fetch (ARRAY-HEADER BASE) of ARRAY))
(TYPENUMBER (fetch (ARRAY-HEADER TYPENUMBER) of ARRAY))
(ROW-MAJOR-INDEX (IPLUS INDEX (fetch (ARRAY-HEADER OFFSET) of ARRAY))))
(if (\ARRAYP BASE)
then (\GENERAL-ARRAY-ADJUST-BASE BASE ROW-MAJOR-INDEX TYPENUMBER))
(\LLARRAY-READ BASE TYPENUMBER ROW-MAJOR-INDEX)))))
(\AREF2
(LAMBDA (ARRAY I J) (* jop: "13-Jul-86 14:27")
(* *)
(if (NOT (\ARRAYP ARRAY))
then (ERROR "Not a cmlarray" ARRAY)
elseif (NOT (EQL (ARRAY-RANK ARRAY)
2))
then (ERROR "Rank mismatch")
else (* If we get here ARRAY must be twod
or general)
(LET (BOUND0 BOUND1 OFFSET)
(if (\TWOD-ARRAY-P ARRAY)
then (SETQ BOUND0 (ffetch (TWOD-ARRAY BOUND0) of ARRAY))
(SETQ BOUND1 (ffetch (TWOD-ARRAY BOUND1) of ARRAY))
(SETQ OFFSET 0)
else (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)))
(if (NOT (AND (SMALLPOSP I)
(ILESSP I BOUND0)))
then (ERROR "Index I out of bounds" I)
elseif (NOT (AND (SMALLPOSP J)
(ILESSP J BOUND1)))
then (ERROR "Index J out of bounds" J)
else (LET ((BASE (fetch (ARRAY-HEADER BASE) of ARRAY))
(TYPENUMBER (fetch (ARRAY-HEADER TYPENUMBER) of ARRAY))
(ROW-MAJOR-INDEX (IPLUS OFFSET J (ITIMES BOUND1 I))))
(if (\ARRAYP BASE)
then (\GENERAL-ARRAY-ADJUST-BASE BASE ROW-MAJOR-INDEX TYPENUMBER))
(\LLARRAY-READ BASE TYPENUMBER ROW-MAJOR-INDEX)))))))
(\ARRAY-BASE
(LAMBDA (ARRAY) (* jop: "13-Jul-86 14:28")
(* * Get the raw offset for ARRAY)
(if (NOT (\ARRAYP ARRAY))
then (ERROR "Not a cmlarray" ARRAY))
(bind ARRAY-BASE while (\ARRAYP (SETQ ARRAY-BASE (fetch (ARRAY-HEADER BASE) of ARRAY)))
do (SETQ ARRAY ARRAY-BASE) finally (RETURN ARRAY-BASE))))
(\ARRAY-CONTENT-INITIALIZE
[LAMBDA (ARRAY INITIAL-CONTENTS) (* lmm "25-Jul-86 00:10")
(CL:IF (EQL 0 (ARRAY-RANK ARRAY))
(\ARRAY-ELEMENT-INITIALIZE ARRAY INITIAL-CONTENTS)
(ETYPECASE INITIAL-CONTENTS (LIST (\COPY-LIST-TO-ARRAY INITIAL-CONTENTS ARRAY))
(ARRAY (\COPY-ARRAY-TO-ARRAY INITIAL-CONTENTS ARRAY])
(\ARRAY-ELEMENT-INITIALIZE
(LAMBDA (ARRAY INITIAL-ELEMENT) (* jop: "15-Jul-86 14:16")
(* * Initialize an array with a value)
(LET* ((TOTAL-SIZE (ARRAY-TOTAL-SIZE ARRAY))
(VECTOR-ARRAY (\FLATTEN-ARRAY ARRAY)))
(for I from 0 to (SUB1 TOTAL-SIZE) do (ASET INITIAL-ELEMENT VECTOR-ARRAY I)))))
(\ARRAY-OFFSET
(LAMBDA (ARRAY) (* jop: "13-Jul-86 14:29")
(* * Get the raw offset for ARRAY)
(if (NOT (\ARRAYP ARRAY))
then (ERROR "Not a cmlarray" ARRAY))
(bind (OFFSET ← (\GET-ARRAY-OFFSET ARRAY))
ARRAY-BASE while (\ARRAYP (SETQ ARRAY-BASE (fetch (ARRAY-HEADER BASE) of ARRAY)))
do (SETQ ARRAY ARRAY-BASE)
(SETQ OFFSET (IPLUS OFFSET (\GET-ARRAY-OFFSET ARRAY))) finally (RETURN OFFSET))))
(\ASET0
(LAMBDA (NEWVALUE ARRAY) (* jop: "15-Jul-86 20:55")
(* *)
(if (NOT (\ARRAYP ARRAY))
then (ERROR "Not an array" ARRAY)
elseif (NOT (EQL (ARRAY-RANK ARRAY)
0))
then (ERROR "Rank mismatch")
else
(* * Must be a general array)
(LET ((BASE (ffetch (GENERAL-ARRAY STORAGE) of ARRAY))
(TYPENUMBER (ffetch (GENERAL-ARRAY TYPENUMBER) of ARRAY))
(ROW-MAJOR-INDEX (ffetch (GENERAL-ARRAY OFFSET) of ARRAY)))
(if (\ARRAYP BASE)
then (\GENERAL-ARRAY-ADJUST-BASE BASE ROW-MAJOR-INDEX TYPENUMBER))
(\LLARRAY-WRITE NEWVALUE BASE TYPENUMBER ROW-MAJOR-INDEX)))))
(\ASET1
(LAMBDA (NEWVALUE ARRAY INDEX) (* jop: "16-Jul-86 12:10")
(* *)
(if (NOT (\ARRAYP ARRAY))
then (* Hack to handle IL:STRINGP's)
(if (STRINGP ARRAY)
then (RPLCHARCODE ARRAY (ADD1 INDEX)
(CHAR-INT NEWVALUE))
NEWVALUE
else (ERROR "Not an array" ARRAY))
elseif (NOT (EQL (ARRAY-RANK ARRAY)
1))
then (ERROR "Rank mismatch")
elseif (NOT (AND (SMALLPOSP INDEX)
(ILESSP INDEX (fetch (ARRAY-HEADER TOTALSIZE) of ARRAY))))
then (ERROR "Index out of bounds" INDEX)
else
(* * Now proceed to extract the element)
(LET ((BASE (fetch (ARRAY-HEADER BASE) of ARRAY))
(TYPENUMBER (fetch (ARRAY-HEADER TYPENUMBER) of ARRAY))
(ROW-MAJOR-INDEX (IPLUS INDEX (fetch (ARRAY-HEADER OFFSET) of ARRAY))))
(if (\ARRAYP BASE)
then (\GENERAL-ARRAY-ADJUST-BASE BASE ROW-MAJOR-INDEX TYPENUMBER))
(if (AND (\THIN-CHAR-TYPE-P TYPENUMBER)
(\FAT-STRING-CHAR-P NEWVALUE))
then (\MAKE-STRING-FAT ARRAY)
(\ASET1 NEWVALUE ARRAY INDEX)
else (\LLARRAY-WRITE NEWVALUE BASE TYPENUMBER ROW-MAJOR-INDEX))))))
(\ASET2
(LAMBDA (NEWVALUE ARRAY I J) (* jop: "13-Jul-86 14:30")
(* *)
(if (NOT (\ARRAYP ARRAY))
then (ERROR "Not a cmlarray" ARRAY)
elseif (NOT (EQL (ARRAY-RANK ARRAY)
2))
then (ERROR "Rank mismatch")
else (* If we get here ARRAY must be twod
or general)
(LET (BOUND0 BOUND1 OFFSET)
(if (\TWOD-ARRAY-P ARRAY)
then (SETQ BOUND0 (ffetch (TWOD-ARRAY BOUND0) of ARRAY))
(SETQ BOUND1 (ffetch (TWOD-ARRAY BOUND1) of ARRAY))
(SETQ OFFSET 0)
else (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)))
(if (NOT (AND (SMALLPOSP I)
(ILESSP I BOUND0)))
then (ERROR "Index out of bounds" I)
elseif (NOT (AND (SMALLPOSP J)
(ILESSP J BOUND1)))
then (ERROR "Index out of bounds" J)
else (LET ((BASE (fetch (ARRAY-HEADER BASE) of ARRAY))
(TYPENUMBER (fetch (ARRAY-HEADER TYPENUMBER) of ARRAY))
(ROW-MAJOR-INDEX (IPLUS OFFSET J (ITIMES BOUND1 I))))
(if (\ARRAYP BASE)
then (\GENERAL-ARRAY-ADJUST-BASE BASE ROW-MAJOR-INDEX TYPENUMBER))
(if (AND (\THIN-CHAR-TYPE-P TYPENUMBER)
(\FAT-STRING-CHAR-P NEWVALUE))
then (\MAKE-STRING-FAT ARRAY)
(\ASET2 NEWVALUE ARRAY I J)
else (\LLARRAY-WRITE NEWVALUE BASE TYPENUMBER ROW-MAJOR-INDEX))))))))
(\COPY-ARRAY-TO-ARRAY
(LAMBDA (INITIAL-CONTENTS ARRAY) (* jop: "15-Jul-86 14:17")
(* *)
(if (EQUAL (ARRAY-DIMENSIONS ARRAY)
(ARRAY-DIMENSIONS INITIAL-CONTENTS))
then (LET* ((TOTALSIZE (ARRAY-TOTAL-SIZE ARRAY))
(VECTOR-ARRAY (\FLATTEN-ARRAY ARRAY))
(VECTOR-INITIAL-CONTENTS (\FLATTEN-ARRAY INITIAL-CONTENTS)))
(for I from 0 to (SUB1 TOTALSIZE) do (ASET (AREF VECTOR-INITIAL-CONTENTS I)
VECTOR-ARRAY I)))
else (ERROR "Dimensionality mismatch for INITIAL-CONTENTS" INITIAL-CONTENTS))))
(\COPY-LIST-TO-ARRAY
(LAMBDA (INITIAL-CONTENTS ARRAY) (* jop: "15-Jul-86 14:17")
(* *)
(if (\EQUAL-LIST-DIMENSIONS (ARRAY-DIMENSIONS ARRAY)
INITIAL-CONTENTS)
then (FRPTQ (SUB1 (ARRAY-RANK ARRAY))
(SETQ INITIAL-CONTENTS (APPLY (FUNCTION APPEND)
INITIAL-CONTENTS)))
(LET* ((TOTAL-SIZE (ARRAY-TOTAL-SIZE ARRAY))
(VECTOR-ARRAY (\FLATTEN-ARRAY ARRAY)))
(for L in INITIAL-CONTENTS as I from 0 to (SUB1 TOTAL-SIZE)
do (ASET L VECTOR-ARRAY I)))
else (ERROR "Dimensionality mismatch for INITIAL-CONTENTS" INITIAL-CONTENTS))))
(\DO-LOGICAL-OP
(LAMBDA (OP SOURCE DEST) (* jop: "14-Jul-86 17:56")
(* *)
(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)
(SELECTQ 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))
NIL)
(replace (PILOTBBT PBTSOURCETYPE) of GBBT with SOURCE-OP)
(replace (PILOTBBT PBTOPERATION) of GBBT with LOG-OP)
(* Execute the BLT)
(\PILOTBITBLT GBBT 0)
DEST))))
(\EQUAL-LIST-DIMENSIONS
(LAMBDA (DIM-LST LST) (* jop: "30-Apr-86 12:35")
(* * Returns NIL if there is a mismatch)
(if (NEQ (CAR DIM-LST)
(LENGTH LST))
then NIL
else (OR (NULL (CDR DIM-LST))
(for LL in LST always (\EQUAL-LIST-DIMENSIONS (CDR DIM-LST)
LL))))))
(\FAT-STRING-ARRAY-P
(LAMBDA (ARRAY) (* jop: "13-Jul-86 14:30")
(* *)
(AND (\ARRAYP ARRAY)
(\FAT-CHAR-TYPE-P (fetch (ARRAY-HEADER TYPENUMBER) of ARRAY)))))
(\FILL-NEW-ARRAY
(LAMBDA (OLD-ARRAY NEW-ARRAY) (* jop: "11-Jul-86 17:12")
(* * It is assumed that OLD-ARRAY and NEW-ARRAY are of the same rank)
(LET* ((OLD-RANK (ARRAY-RANK OLD-ARRAY))
(INDICES (for I from 1 to OLD-RANK collect 0))
(LIMITS (for OLD-DIM in (ARRAY-DIMENSIONS OLD-ARRAY) as NEW-DIM in (ARRAY-DIMENSIONS
NEW-ARRAY)
collect (IMIN OLD-DIM NEW-DIM)))
ENDITERATION)
(if (NOT (EQL OLD-RANK (ARRAY-RANK NEW-ARRAY)))
then (ERROR "Arrays not of equal rank"))
(while (NOT ENDITERATION)
do (CL:APPLY (FUNCTION ASET)
(CL:APPLY (FUNCTION AREF)
OLD-ARRAY INDICES)
NEW-ARRAY INDICES)
(* * Update indices)
(bind INDEX LIMIT (I ← OLD-RANK)
while (AND (IGREATERP I 0)
(EQL (ADD1 (CAR (SETQ INDEX (FNTH INDICES I))))
(SETQ LIMIT (CAR (FNTH LIMITS I))))) do (RPLACA INDEX 0)
(SETQ I (SUB1 I))
finally (if (EQL I 0)
then (SETQ ENDITERATION T)
else (RPLACA INDEX (ADD1 (CAR INDEX)))))))))
(\FLATTEN-ARRAY
(LAMBDA (ARRAY) (* jop: "15-Jul-86 14:13")
(* * Make a oned-array that shares storage with array.
If array is already oned then return array)
(if (EQL 1 (ARRAY-RANK ARRAY))
then ARRAY
else (MAKE-ARRAY (ARRAY-TOTAL-SIZE ARRAY)
(QUOTE :ELEMENT-TYPE)
(ARRAY-ELEMENT-TYPE ARRAY)
(QUOTE :DISPLACED-TO)
ARRAY))))
(\GET-ARRAY-OFFSET
(LAMBDA (ARRAY) (* jop: "13-Jul-86 14:32")
(* *)
(if (OR (\ONED-ARRAY-P ARRAY)
(\GENERAL-ARRAY-P ARRAY))
then (fetch (ARRAY-HEADER OFFSET) of ARRAY)
elseif (\TWOD-ARRAY-P ARRAY)
then 0
else (ERROR "Not a cmlarray" ARRAY))))
(\MAKE-DISPLACED-ARRAY
(LAMBDA (TOTALSIZE DIMENSIONS ELEMENTTYPE DISPLACED-TO DISPLACED-INDEX-OFFSET FILL-POINTER
ADJUSTABLE) (* jop: "13-Jul-86 14:32")
(* * Make a displaced array)
(LET ((RANK (LENGTH DIMENSIONS))
(DISPLACED-TO-TYPENUMBER (fetch (ARRAY-HEADER TYPENUMBER) of DISPLACED-TO))
BASE OFFSET NEED-INDIRECTION-P)
(if (OR (ADJUSTABLE-ARRAY-P DISPLACED-TO)
(\THIN-CHAR-TYPE-P DISPLACED-TO-TYPENUMBER))
then (* Provide for indirection)
(SETQ BASE DISPLACED-TO)
(SETQ OFFSET DISPLACED-INDEX-OFFSET)
(SETQ NEED-INDIRECTION-P T)
else (SETQ BASE (fetch (ARRAY-HEADER BASE) of DISPLACED-TO))
(* Fold double displacement to single
displacement)
(SETQ OFFSET (IPLUS DISPLACED-INDEX-OFFSET (\GET-ARRAY-OFFSET DISPLACED-TO)))
(if (\ARRAYP BASE)
then (SETQ NEED-INDIRECTION-P T)))
(if (OR (IGREATERP RANK 1)
ADJUSTABLE NEED-INDIRECTION-P)
then (* Indirect strings always have
\FAT-CHAR-TYPENUMBER)
(\MAKE-GENERAL-ARRAY TOTALSIZE DIMENSIONS ELEMENTTYPE FILL-POINTER ADJUSTABLE BASE
OFFSET (\CHAR-TYPE-P DISPLACED-TO-TYPENUMBER))
else (\MAKE-ONED-ARRAY TOTALSIZE ELEMENTTYPE FILL-POINTER BASE OFFSET (\FAT-CHAR-TYPE-P
DISPLACED-TO-TYPENUMBER
))))))
(\MAKE-DISPLACED-TO-BASE-ARRAY
(LAMBDA (TOTALSIZE DIMENSIONS ELEMENTTYPE DISPLACED-TO-BASE DISPLACED-INDEX-OFFSET FILL-POINTER
ADJUSTABLE FATP) (* jop: " 7-Jul-86 16:15")
(* * Make a displaced array)
(if (OR (IGREATERP (LENGTH DIMENSIONS)
1)
ADJUSTABLE)
then (\MAKE-GENERAL-ARRAY TOTALSIZE DIMENSIONS ELEMENTTYPE FILL-POINTER ADJUSTABLE
DISPLACED-TO-BASE DISPLACED-INDEX-OFFSET FATP)
else (\MAKE-ONED-ARRAY TOTALSIZE ELEMENTTYPE FILL-POINTER DISPLACED-TO-BASE
DISPLACED-INDEX-OFFSET FATP))))
(\MAKE-GENERAL-ARRAY
(LAMBDA (TOTALSIZE DIMENSIONS ELEMENT-TYPE FILLPOINTER ADJUSTABLE-P DISPLACED-TO
DISPLACED-INDEX-OFFSET FATP) (* jop: "13-Jul-86 13:23")
(* *)
(LET ((TYPENUMBER (\CML-TYPE-TO-TYPENUMBER ELEMENT-TYPE FATP)))
(create GENERAL-ARRAY
STORAGE ← (OR DISPLACED-TO (\LLARRAY-MAKE-STORAGE TOTALSIZE TYPENUMBER))
ADJUSTABLE-P ← ADJUSTABLE-P
DISPLACED-P ← DISPLACED-TO
FILLPOINTER-P ← FILLPOINTER
STRING-P ← (AND (EQLENGTH DIMENSIONS 1)
(\CHAR-TYPE-P TYPENUMBER))
TYPENUMBER ← TYPENUMBER
OFFSET ← (OR DISPLACED-INDEX-OFFSET 0)
FILLPOINTER ← (OR FILLPOINTER 0)
TOTALSIZE ← TOTALSIZE
DIMS ← DIMENSIONS))))
(\MAKE-NON-SIMPLE-ARRAY
(LAMBDA (TOTALSIZE DIMENSIONS ELEMENT-TYPE FILL-POINTER ADJUSTABLE FATP)
(* jop: " 7-Jul-86 15:44")
(* *)
(if (OR (IGREATERP (LENGTH DIMENSIONS)
1)
ADJUSTABLE)
then (\MAKE-GENERAL-ARRAY TOTALSIZE DIMENSIONS ELEMENT-TYPE FILL-POINTER ADJUSTABLE NIL NIL
FATP)
else (\MAKE-ONED-ARRAY TOTALSIZE ELEMENT-TYPE FILL-POINTER NIL NIL FATP))))
(\MAKE-ONED-ARRAY
(LAMBDA (TOTALSIZE ELEMENT-TYPE FILLPOINTER DISPLACED-TO DISPLACED-INDEX-OFFSET FATP)
(* jop: " 8-Jul-86 13:12")
(* *)
(LET ((TYPENUMBER (\CML-TYPE-TO-TYPENUMBER ELEMENT-TYPE FATP)))
(create ONED-ARRAY
BASE ← (OR DISPLACED-TO (\LLARRAY-MAKE-STORAGE TOTALSIZE TYPENUMBER))
DISPLACED-P ← DISPLACED-TO
FILLPOINTER-P ← FILLPOINTER
STRING-P ← (\CHAR-TYPE-P TYPENUMBER)
TYPENUMBER ← TYPENUMBER
OFFSET ← (OR DISPLACED-INDEX-OFFSET 0)
FILLPOINTER ← (OR FILLPOINTER 0)
TOTALSIZE ← TOTALSIZE))))
(\MAKE-SIMPLE-ARRAY
(LAMBDA (TOTALSIZE DIMENSIONS ELEMENT-TYPE FATP) (* jop: " 7-Jul-86 22:38")
(* * Make a simple array)
(SELECTQ (LENGTH DIMENSIONS)
(1 (\MAKE-ONED-ARRAY TOTALSIZE ELEMENT-TYPE NIL NIL NIL FATP))
(2 (\MAKE-TWOD-ARRAY TOTALSIZE DIMENSIONS ELEMENT-TYPE FATP))
(\MAKE-GENERAL-ARRAY TOTALSIZE DIMENSIONS ELEMENT-TYPE NIL NIL NIL NIL FATP))))
(\MAKE-STRING-FAT
(LAMBDA (ARRAY) (* jop: "13-Jul-86 14:33")
(* * Like Adjust-array for the special case of Thin-string arrays)
(if (NOT (\ARRAYP ARRAY))
then (ERROR "Not a cmlarray" ARRAY))
(LET ((BASE-ARRAY ARRAY)
(BASE-ARRAY-BASE (fetch (ARRAY-HEADER BASE) of ARRAY))
NEW-BASE)
(* * find the base array)
(while (\ARRAYP BASE-ARRAY-BASE) do (SETQ BASE-ARRAY BASE-ARRAY-BASE)
(SETQ BASE-ARRAY-BASE (fetch (ARRAY-HEADER BASE)
of BASE-ARRAY)))
(* * Consistency check)
(if (NOT (\THIN-CHAR-TYPE-P (fetch (ARRAY-HEADER TYPENUMBER) of BASE-ARRAY)))
then (ERROR "Not a thin string-char array" BASE-ARRAY)
else
(* * Allocate the new storage)
(SETQ NEW-BASE (\LLARRAY-MAKE-STORAGE (ARRAY-TOTAL-SIZE BASE-ARRAY)
\FAT-CHAR-TYPENUMBER))
(* * Initialize it)
(for I from 0 to (SUB1 (ARRAY-TOTAL-SIZE BASE-ARRAY))
do (\LLARRAY-WRITE (\LLARRAY-READ BASE-ARRAY-BASE \THIN-CHAR-TYPENUMBER I)
NEW-BASE \FAT-CHAR-TYPENUMBER I))
(UNINTERRUPTABLY
(* * Smash the new base into the array-header)
(replace (ARRAY-HEADER BASE) of BASE-ARRAY with NEW-BASE)
(* * Change the typenumber)
(replace (ARRAY-HEADER TYPENUMBER) of BASE-ARRAY with \FAT-CHAR-TYPENUMBER))
(* * return the original array)
ARRAY))))
(\MAKE-TWOD-ARRAY
(LAMBDA (TOTALSIZE DIMENSIONS ELEMENT-TYPE FATP) (* jop: " 7-Jul-86 22:35")
(* *)
(LET ((BOUND0 (CAR DIMENSIONS))
(BOUND1 (CADR DIMENSIONS))
(TYPENUMBER (\CML-TYPE-TO-TYPENUMBER ELEMENT-TYPE FATP)))
(create TWOD-ARRAY
BASE ← (\LLARRAY-MAKE-STORAGE TOTALSIZE TYPENUMBER)
TYPENUMBER ← TYPENUMBER
BOUND0 ← BOUND0
BOUND1 ← BOUND1
TOTALSIZE ← TOTALSIZE))))
(\TOTAL-SIZE
(LAMBDA (DIMS) (* jop: "27-Apr-86 17:02")
(* *)
(bind (PROD ← 1) for DIM in DIMS do (SETQ PROD (ITIMES PROD DIM)) finally (RETURN PROD))))
)
(DEFMACRO ASET-MACRO (ARRAY &REST ARGS)
(* *)
(LET ((LAST-ARG (LAST ARGS)))
(BQUOTE (ASET %, (CAR LAST-ARG)
%, ARRAY %,@ (LDIFF ARGS LAST-ARG)))))
(* Faster predicates not including IL:STRINGP's)
(DEFINEQ
(\ARRAYP
(LAMBDA (ARRAY) (* jop: "19-Jun-86 17:15")
(* *)
(OR (\ONED-ARRAY-P ARRAY)
(\TWOD-ARRAY-P ARRAY)
(\GENERAL-ARRAY-P ARRAY))))
(\SIMPLE-ARRAY-P
(LAMBDA (ARRAY) (* jop: "13-Jul-86 14:43")
(* *)
(AND (\ARRAYP ARRAY)
(NOT (fetch (ARRAY-HEADER DISPLACED-P) of ARRAY))
(NOT (fetch (ARRAY-HEADER ADJUSTABLE-P) of ARRAY))
(NOT (fetch (ARRAY-HEADER FILLPOINTER-P) of ARRAY)))))
(\SIMPLE-STRING-P
(LAMBDA (VECTOR) (* jop: "13-Jul-86 15:37")
(* *)
(AND (\SIMPLE-VECTOR-P VECTOR)
(fetch (ARRAY-HEADER STRING-P) of VECTOR))))
(\SIMPLE-VECTOR-P
(LAMBDA (VECTOR) (* jop: "13-Jul-86 14:51")
(* *)
(AND (\ONED-ARRAY-P VECTOR)
(NOT (fetch (ARRAY-HEADER DISPLACED-P) of VECTOR))
(NOT (fetch (ARRAY-HEADER FILLPOINTER-P) of VECTOR)))))
(\STRING-ARRAY-P
(LAMBDA (ARRAY) (* jop: "13-Jul-86 14:33")
(* *)
(AND (\ARRAYP ARRAY)
(\CHAR-TYPE-P (fetch (ARRAY-HEADER TYPENUMBER) of ARRAY)))))
(\STRINGP
(LAMBDA (ARRAY) (* jop: "13-Jul-86 14:34")
(* *)
(AND (\ARRAYP ARRAY)
(fetch (ARRAY-HEADER STRING-P) of ARRAY))))
(\VECTORP
(LAMBDA (VECTOR) (* jop: "13-Jul-86 14:45")
(* *)
(AND (\ARRAYP VECTOR)
(EQL 1 (ARRAY-RANK VECTOR)))))
)
(* Low level predicates)
(DEFINEQ
(\GENERAL-ARRAY-P
(LAMBDA (ARRAY) (* jop: " 7-Jul-86 14:47")
(* *)
(SELECTC (NTYPX ARRAY)
(\GENERAL-ARRAY
ARRAY)
NIL)))
(\ONED-ARRAY-P
(LAMBDA (ARRAY) (* jop: " 7-Jul-86 14:45")
(* *)
(SELECTC (NTYPX ARRAY)
(\ONED-ARRAY ARRAY)
NIL)))
(\THIN-STRING-ARRAY-P
(LAMBDA (ARRAY) (* jop: "13-Jul-86 14:34")
(* *)
(AND (\ARRAYP ARRAY)
(\THIN-CHAR-TYPE-P (fetch (ARRAY-HEADER TYPENUMBER) of ARRAY)))))
(\TWOD-ARRAY-P
(LAMBDA (ARRAY) (* jop: " 7-Jul-86 14:47")
(* *)
(SELECTC (NTYPX ARRAY)
(\TWOD-ARRAY ARRAY)
NIL)))
)
(* Record def's)
(/DECLAREDATATYPE (QUOTE GENERAL-ARRAY)
(QUOTE ((BITS 8)
POINTER
(BITS 4)
FLAG FLAG FLAG FLAG (BITS 8)
WORD WORD WORD POINTER))
(QUOTE ((GENERAL-ARRAY 0 (BITS . 7))
(GENERAL-ARRAY 0 POINTER)
(GENERAL-ARRAY 2 (BITS . 3))
(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
(BITS 5)
FLAG FLAG FLAG (BITS 8)
WORD WORD WORD))
[QUOTE ((ONED-ARRAY 0 (BITS . 7))
(ONED-ARRAY 0 POINTER)
(ONED-ARRAY 2 (BITS . 4))
(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
(BITS 8)
(BITS 8)
WORD WORD WORD))
[QUOTE ((TWOD-ARRAY 0 (BITS . 7))
(TWOD-ARRAY 0 POINTER)
(TWOD-ARRAY 2 (BITS . 7))
(TWOD-ARRAY 2 (BITS . 135))
(TWOD-ARRAY 3 (BITS . 15))
(TWOD-ARRAY 4 (BITS . 15))
(TWOD-ARRAY 5 (BITS . 15]
(QUOTE 6))
(* * Don't need this stuff at run time)
(DECLARE: DONTCOPY EVAL@COMPILE
[DECLARE: EVAL@COMPILE
(BLOCKRECORD ARRAY-HEADER (
(* * Describes common slots of all arrays)
(BASE POINTER) (* Storage pointer)
(NIL BITS 4) (* 8 bits of flags in a 16 bit field)
(ADJUSTABLE-P FLAG)
(DISPLACED-P FLAG)
(FILLPOINTER-P FLAG)
(STRING-P FLAG)
(TYPENUMBER BITS 8) (* 8 bits of type + size in 16 bit
field)
(* for oned and general arrays)
(OFFSET WORD) (* for oned and general arrays)
(FILLPOINTER WORD)
(TOTALSIZE WORD)))
(DATATYPE GENERAL-ARRAY ((NIL BITS 8) (* For alignment)
(STORAGE POINTER) (* 24 bits of pointer)
(NIL BITS 4) (* 8 bits of flags in 16 bit field)
(ADJUSTABLE-P FLAG)
(DISPLACED-P FLAG)
(FILLPOINTER-P FLAG)
(STRING-P FLAG)
(TYPENUMBER BITS 8) (* 8 bits of typenumber in 16 bit
field)
(OFFSET WORD)
(FILLPOINTER WORD)
(TOTALSIZE WORD)
(DIMS POINTER)))
(DATATYPE ONED-ARRAY ((NIL BITS 8) (* Don't use high 8 bits of pointer)
(BASE POINTER) (* The Storage Base)
(NIL BITS 5) (* 8 bits worth of flags)
(DISPLACED-P FLAG)
(FILLPOINTER-P FLAG)
(STRING-P FLAG)
(TYPENUMBER BITS 8) (* 4 bits of type and 4 bits of size)
(OFFSET WORD) (* For Displaced Arrays)
(FILLPOINTER WORD) (* For Filled Arrays)
(TOTALSIZE WORD) (* Total Number Of Elements)
))
(DATATYPE TWOD-ARRAY ((NIL BITS 8) (* for alignment)
(BASE POINTER) (* storage pointer)
(NIL BITS 8) (* Flag fields -- must all be NIL)
(TYPENUMBER BITS 8) (* left 4 are type, right 4 are size)
(BOUND0 WORD) (* Zero dimension bound)
(BOUND1 WORD) (* One dimension bound)
(TOTALSIZE WORD)))
]
(/DECLAREDATATYPE (QUOTE GENERAL-ARRAY)
(QUOTE ((BITS 8)
POINTER
(BITS 4)
FLAG FLAG FLAG FLAG (BITS 8)
WORD WORD WORD POINTER))
(QUOTE ((GENERAL-ARRAY 0 (BITS . 7))
(GENERAL-ARRAY 0 POINTER)
(GENERAL-ARRAY 2 (BITS . 3))
(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
(BITS 5)
FLAG FLAG FLAG (BITS 8)
WORD WORD WORD))
[QUOTE ((ONED-ARRAY 0 (BITS . 7))
(ONED-ARRAY 0 POINTER)
(ONED-ARRAY 2 (BITS . 4))
(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
(BITS 8)
(BITS 8)
WORD WORD WORD))
[QUOTE ((TWOD-ARRAY 0 (BITS . 7))
(TWOD-ARRAY 0 POINTER)
(TWOD-ARRAY 2 (BITS . 7))
(TWOD-ARRAY 2 (BITS . 135))
(TWOD-ARRAY 3 (BITS . 15))
(TWOD-ARRAY 4 (BITS . 15))
(TWOD-ARRAY 5 (BITS . 15]
(QUOTE 6))
(DEFMACRO \CHECK-INDICES (ARRAY START-ARG ARGS)
(* *)
(BQUOTE (bind INDEX for I from %, START-ARG to %, ARGS as DIM from 0
always (SETQ INDEX (ARG %, ARGS I))
(AND (SMALLPOSP INDEX)
(ILESSP INDEX (ARRAY-DIMENSION %, ARRAY DIM))))))
(DEFMACRO \GENERAL-ARRAY-ADJUST-BASE (ARRAY ROW-MAJOR-INDEX TYPENUMBER)
(* *)
(BQUOTE (while (\ARRAYP (fetch (ARRAY-HEADER BASE) of %, ARRAY))
do (SETQ %, ROW-MAJOR-INDEX (IPLUS %, ROW-MAJOR-INDEX (\GET-ARRAY-OFFSET %, ARRAY)))
(SETQ %, ARRAY (fetch (ARRAY-HEADER BASE) of %, ARRAY))
finally (if (NOT (ILESSP %, ROW-MAJOR-INDEX (fetch (ARRAY-HEADER TOTALSIZE)
of %, ARRAY)))
then (ERROR "Row-major-index out of bounds (displaced to adjustable?)")
else (SETQ %, ROW-MAJOR-INDEX (IPLUS %, ROW-MAJOR-INDEX (\GET-ARRAY-OFFSET
%, ARRAY)))
(SETQ TYPENUMBER (fetch (ARRAY-HEADER TYPENUMBER) of %, ARRAY))
(SETQ %, ARRAY (fetch (ARRAY-HEADER BASE) of %, ARRAY))))))
(DEFMACRO \EXPAND-BIT-OP (OP BIT-ARRAY1 BIT-ARRAY2 RESULT-BIT-ARRAY)
(* *)
(BQUOTE (LET ((COMMON-DIMS (ARRAY-DIMENSIONS (\, BIT-ARRAY1))))
(if (NOT (EQUAL (ARRAY-ELEMENT-TYPE (\, BIT-ARRAY1))
(QUOTE (UNSIGNED-BYTE 1))))
then (ERROR "Not a bit array" (\, BIT-ARRAY1)))
(if (NOT (EQUAL (ARRAY-ELEMENT-TYPE (\, BIT-ARRAY2))
(QUOTE (UNSIGNED-BYTE 1))))
then (ERROR "Not a bit array" (\, BIT-ARRAY2)))
(if (NOT (EQUAL COMMON-DIMS (ARRAY-DIMENSIONS (\, BIT-ARRAY2))))
then (ERROR "Bit-arrays not of same dimensions"))
(if (NULL (\, RESULT-BIT-ARRAY))
then (SETQ (\, RESULT-BIT-ARRAY)
(MAKE-ARRAY COMMON-DIMS :ELEMENT-TYPE (QUOTE (UNSIGNED-BYTE 1))))
elseif (EQ (\, RESULT-BIT-ARRAY)
T)
then (SETQ (\, RESULT-BIT-ARRAY)
(\, BIT-ARRAY1))
elseif (NOT (AND (EQUAL (ARRAY-ELEMENT-TYPE (\, RESULT-BIT-ARRAY))
(QUOTE (UNSIGNED-BYTE 1)))
(EQUAL (ARRAY-DIMENSIONS (\, RESULT-BIT-ARRAY))
COMMON-DIMS)))
then (ERROR "Illegal result array" (\, RESULT-BIT-ARRAY)))
(\, (SELECTQ OP
((AND IOR XOR ANDC2 ORC2)
(BQUOTE (OR (EQ (\, BIT-ARRAY1)
(\, RESULT-BIT-ARRAY))
(\DO-LOGICAL-OP (QUOTE COPY)
(\, BIT-ARRAY1)
(\, RESULT-BIT-ARRAY)))))
((EQV NAND NOR ANDC1 ORC1)
(BQUOTE (\DO-LOGICAL-OP (QUOTE NOT)
(\, BIT-ARRAY1)
(\, RESULT-BIT-ARRAY))))
(SHOULDNT "No such op" OP)))
(\, (SELECTQ OP
(AND (BQUOTE (\DO-LOGICAL-OP (QUOTE AND)
(\, BIT-ARRAY2)
(\, RESULT-BIT-ARRAY))))
(IOR (BQUOTE (\DO-LOGICAL-OP (QUOTE OR)
(\, BIT-ARRAY2)
(\, RESULT-BIT-ARRAY))))
(XOR (BQUOTE (\DO-LOGICAL-OP (QUOTE XOR)
(\, BIT-ARRAY2)
(\, RESULT-BIT-ARRAY))))
(EQV (BQUOTE (\DO-LOGICAL-OP (QUOTE XOR)
(\, BIT-ARRAY2)
(\, RESULT-BIT-ARRAY))))
(NAND (BQUOTE (\DO-LOGICAL-OP (QUOTE COR)
(\, BIT-ARRAY2)
(\, RESULT-BIT-ARRAY))))
(NOR (BQUOTE (\DO-LOGICAL-OP (QUOTE CAND)
(\, BIT-ARRAY2)
(\, RESULT-BIT-ARRAY))))
(ANDC1 (BQUOTE (\DO-LOGICAL-OP (QUOTE AND)
(\, BIT-ARRAY2)
(\, RESULT-BIT-ARRAY))))
(ANDC2 (BQUOTE (\DO-LOGICAL-OP (QUOTE CAND)
(\, BIT-ARRAY2)
(\, RESULT-BIT-ARRAY))))
(ORC1 (BQUOTE (\DO-LOGICAL-OP (QUOTE OR)
(\, BIT-ARRAY2)
(\, RESULT-BIT-ARRAY))))
(ORC2 (BQUOTE (\DO-LOGICAL-OP (QUOTE COR)
(\, BIT-ARRAY2)
(\, RESULT-BIT-ARRAY))))
(SHOULDNT "No such op" OP)))
(\, RESULT-BIT-ARRAY))))
(DECLARE: EVAL@COMPILE
(RPAQQ \GENERAL-ARRAY 16)
(RPAQQ \ONED-ARRAY 14)
(RPAQQ \TWOD-ARRAY 15)
(CONSTANTS \GENERAL-ARRAY \ONED-ARRAY \TWOD-ARRAY)
)
)
(* * Optimizers)
(DEFINEQ
(\AREF-EXPANDER
(LAMBDA (FORM) (* jop: "13-Jul-86 17:01")
(* *)
(SELECTQ (LENGTH FORM)
(2 (BQUOTE (\AREF1 (\,@ FORM))))
(3 (BQUOTE (\AREF2 (\,@ FORM))))
(QUOTE IGNOREMACRO))))
(\ASET-EXPANDER
(LAMBDA (FORM) (* jop: "13-Jul-86 17:02")
(* *)
(SELECTQ (LENGTH FORM)
(3 (BQUOTE (\ASET1 (\,@ FORM))))
(4 (BQUOTE (\ASET2 (\,@ FORM))))
(QUOTE IGNOREMACRO))))
)
(DECLARE: EVAL@COMPILE
(PUTPROPS AREF DMACRO (ARGS (\AREF-EXPANDER ARGS)))
(PUTPROPS ASET DMACRO (ARGS (\ASET-EXPANDER ARGS)))
(PUTPROPS BIT DMACRO (ARGS (\AREF-EXPANDER ARGS)))
(PUTPROPS SBIT DMACRO (ARGS (\AREF-EXPANDER ARGS)))
(PUTPROPS SCHAR DMACRO (ARGS (\AREF-EXPANDER ARGS)))
(PUTPROPS SVREF DMACRO (ARGS (\AREF-EXPANDER ARGS)))
[PUTPROPS \ARRAYP DMACRO (OPENLAMBDA (ARRAY)
(OR (\ONED-ARRAY-P ARRAY)
(\TWOD-ARRAY-P ARRAY)
(\GENERAL-ARRAY-P ARRAY]
)
(PUTPROPS \AREF1 DOPVAL (2 AREF1))
(PUTPROPS \AREF2 DOPVAL (3 AREF2))
(PUTPROPS \ASET1 DOPVAL (3 ASET1))
(PUTPROPS \ASET2 DOPVAL (4 ASET2))
(PUTPROPS \GENERAL-ARRAY-P DOPVAL (1 TYPEP 16))
(PUTPROPS \ONED-ARRAY-P DOPVAL (1 TYPEP 14))
(PUTPROPS \TWOD-ARRAY-P DOPVAL (1 TYPEP 15))
(* * I/O)
(DEFINEQ
(\DEFPRINT-ARRAY
(LAMBDA (ARRAY STREAM) (* lmm "21-Jul-86 20:33")
(* * This is the DEFPRINT function for the ARRAY type)
(COND
((CL:STRINGP ARRAY)
(\DEFPRINT-STRING ARRAY STREAM))
((NOT *PRINT-ARRAY*)
NIL)
((AND *PRINT-LEVEL* (ILEQ *PRINT-LEVEL* 0)) (* Elide it all)
(\ELIDE.PRINT.ELEMENT STREAM)
T)
(T (LET ((RANK (ARRAY-RANK ARRAY))
CIRCLELABEL FIRSTTIME)
(* * "If A has a circle label, print it. If it's not the first time or it has no label, print the contents")
(if (EQ RANK 1)
then (\DEFPRINT-VECTOR ARRAY STREAM)
else (AND *PRINT-CIRCLE-HASHTABLE* (MULTIPLE-VALUE-SETQ (CIRCLELABEL FIRSTTIME)
(PRINT-CIRCLE-LOOKUP ARRAY)))
(if CIRCLELABEL
then (\CKPOSSOUT STREAM CIRCLELABEL)
(if FIRSTTIME
then (\CKPOSBOUT STREAM (CHARCODE SPACE))))
(if (OR (NOT CIRCLELABEL)
FIRSTTIME)
then (LET ((RANKSTR (MKSTRING RANK)))
(.SPACECHECK. STREAM (IPLUS (NCHARS RANKSTR)
2))
(* Make sure we have space for "#nA")
(\OUTCHAR STREAM (fetch (READTABLEP HASHMACROCHAR) of *READTABLE*
))
(\SOUT RANKSTR STREAM)
(\OUTCHAR STREAM (CHARCODE "A"))
(COND
((EQ RANK 0)
(\PRINDATUM (AREF ARRAY)
STREAM))
(T (\PRINT-ARRAY-CONTENTS (\FLATTEN-ARRAY ARRAY)
0
(ARRAY-DIMENSIONS ARRAY)
STREAM)))))
T))))))
(\DEFPRINT-BITVECTOR
(LAMBDA (BIT-VECTOR STREAM) (* jop: "11-Jul-86 17:30")
(* * *PRINT-LEVEL* is handled in DEFPRINT.VECTOR, which defers here if its a
bitvector -
The bitvector representation is generated in a string.
Simplicity is denied becuase of *PRINT-LENGTH*.)
(LET* ((SIZE (ARRAY-TOTAL-SIZE BIT-VECTOR))
(END.INDEX (SUB1 SIZE))
LENSTR LENLENSTR FINAL.INDEX ELISION)
(* * Remove EQ tail elements)
(bind (LAST.VALUE ← (BIT BIT-VECTOR END.INDEX)) for J from (SUB1 END.INDEX) to 0
by -1 while (EQ (BIT BIT-VECTOR J)
LAST.VALUE) do (SETQ END.INDEX J))
(* * Limit by *PRINT-LENGTH*)
(SETQ FINAL.INDEX (COND
((AND *PRINT-LENGTH* (IGEQ END.INDEX *PRINT-LENGTH*))
(SETQ ELISION T)
(SUB1 *PRINT-LENGTH*))
(T END.INDEX)))
(SETQ LENLENSTR (COND
((NOT (EQ FINAL.INDEX (SUB1 SIZE)))
(* Eliding final chars, so have to say
how long it is)
(NCHARS (SETQ LENSTR (MKSTRING SIZE))))
(T 0)))
(.SPACECHECK. STREAM (IPLUS (PROGN (* "#*" plus 1 for FINAL.INDEX being 1
less than number bits printed)
3)
LENLENSTR FINAL.INDEX (COND
(ELISION
(* Space for "...")
3)
(T 0))))
(\OUTCHAR STREAM (fetch (READTABLEP HASHMACROCHAR) of *READTABLE*))
(COND
((NEQ LENLENSTR 0)
(\SOUT LENSTR STREAM)))
(\OUTCHAR STREAM (CHARCODE "*"))
(for J from 0 to FINAL.INDEX do (\OUTCHAR STREAM (IPLUS (BIT BIT-VECTOR J)
(CONSTANT (CHARCODE 0)))))
(COND
(ELISION (\SOUT "..." STREAM))) (* Return T to say we did it)
T)))
(\DEFPRINT-VECTOR
(LAMBDA (VECTOR STREAM) (* amd "21-Jul-86 14:47")
(COND
((CL:STRINGP VECTOR)
(\DEFPRINT-STRING VECTOR STREAM))
((NOT *PRINT-ARRAY*)
NIL)
((AND *PRINT-LEVEL* (ILEQ *PRINT-LEVEL* 0))
(\OUTCHAR STREAM (\ELIDE.ELEMENT.CHAR))
T)
((EQUAL (ARRAY-ELEMENT-TYPE VECTOR)
(QUOTE (UNSIGNED-BYTE 1)))
(\DEFPRINT-BITVECTOR VECTOR STREAM))
(T (LET ((HASH (fetch (READTABLEP HASHMACROCHAR) of *READTABLE*))
(SIZE (ARRAY-TOTAL-SIZE VECTOR))
(END.INDEX -1)
FINAL.INDEX ELIDED SIZESTR CIRCLELABEL FIRSTTIME)
(* * "If A has a circle label, print it. If it's not the first time or it has no label, print the contents")
(AND *PRINT-CIRCLE-HASHTABLE* (MULTIPLE-VALUE-SETQ (CIRCLELABEL FIRSTTIME)
(PRINT-CIRCLE-LOOKUP VECTOR)))
(if CIRCLELABEL
then (\CKPOSSOUT STREAM CIRCLELABEL)
(if FIRSTTIME
then (\CKPOSBOUT STREAM (CHARCODE SPACE))))
(if (OR (NOT CIRCLELABEL)
FIRSTTIME)
then (CL:UNLESS (ZEROP SIZE)
(bind (LAST.VALUE ← (AREF VECTOR (SETQ END.INDEX (SUB1 SIZE))))
for J from (SUB1 SIZE) to 0 by -1
while (EQ (AREF VECTOR J)
LAST.VALUE) do (SETQ END.INDEX J)))
(* "END.INDEX is the index of the last array element worth printing -- all subsequent elements are the same")
(SETQ FINAL.INDEX (COND
((AND *PRINT-LENGTH* (IGEQ END.INDEX *PRINT-LENGTH*))
(SETQ ELIDED T)
*PRINT-LENGTH*)
(T END.INDEX)))
(COND
((NOT (EQ (SUB1 SIZE)
END.INDEX)) (*
"Not printing everything, so have to indicate the size")
(SETQ SIZESTR (MKSTRING SIZE))))
(.SPACECHECK. STREAM (IPLUS (COND
(SIZESTR (NCHARS SIZESTR))
(T 0))
(COND
((EQ HASH (CHARCODE "|"))
3)
(T 2))))
(* "Make sure we have space for #n(")
(\OUTCHAR STREAM HASH)
(COND
((EQ HASH (CHARCODE "|")) (*
"Yuck, Interlisp's | does not handle |( a la Common Lisp, need |#(")
(\OUTCHAR STREAM (CHARCODE "#"))))
(COND
(SIZESTR (\SOUT SIZESTR STREAM)))
(LET ((*PRINT-LEVEL* (AND *PRINT-LEVEL* (SUB1 *PRINT-LEVEL*))))
(\OUTCHAR STREAM (CHARCODE "("))
(for I from 0 to FINAL.INDEX do (CL:UNLESS (EQ I 0)
(\OUTCHAR STREAM (CHARCODE SPACE)
))
(\PRINDATUM (AREF VECTOR I)
STREAM)))
(COND
(ELIDED (\ELIDE.PRINT.TAIL STREAM)))
(\OUTCHAR STREAM (CHARCODE ")")))
T)))))
(\DEFPRINT-STRING
(LAMBDA (STRING STREAM) (* amd "22-Jul-86 14:35")
(LET ((ESCAPECHAR (fetch (READTABLEP ESCAPECHAR) of *READTABLE*))
(CLP (fetch (READTABLEP COMMONLISP) of *READTABLE*))
(SIZE (ARRAY-TOTAL-SIZE STRING))
CIRCLELABEL FIRSTTIME)
(* * "If A has a circle label, print it. If it's not the first time or it has no label, print the contents")
(AND *PRINT-CIRCLE-HASHTABLE* (MULTIPLE-VALUE-SETQ (CIRCLELABEL FIRSTTIME)
(PRINT-CIRCLE-LOOKUP STRING)))
(if CIRCLELABEL
then (\CKPOSSOUT STREAM CIRCLELABEL)
(if FIRSTTIME
then (\CKPOSBOUT STREAM (CHARCODE SPACE))))
(CL:WHEN (ARRAY-HAS-FILL-POINTER-P STRING)
(SETQ SIZE (MIN SIZE (FILL-POINTER STRING))))
(if (OR (NOT CIRCLELABEL)
FIRSTTIME)
then (.SPACECHECK. STREAM (if CLP
then 2
else (+ 2 SIZE)))
(CL:WHEN *PRINT-ESCAPE* (\OUTCHAR STREAM (CHARCODE "%"")))
(DOTIMES (I SIZE)
(LET ((CH (CHAR-INT (SCHAR STRING I))))
(CL:WHEN (AND *PRINT-ESCAPE* (OR (EQL CH (CHARCODE "%""))
(EQL CH ESCAPECHAR)))
(\OUTCHAR STREAM ESCAPECHAR))
(\OUTCHAR STREAM CH)))
(CL:WHEN *PRINT-ESCAPE* (\OUTCHAR STREAM (CHARCODE "%""))))
T)))
(\PRINT-ARRAY-CONTENTS
(LAMBDA (FLAT-ARRAY OFFSET DIMENSIONS STREAM) (* jop: "15-Jul-86 20:35")
(LET* ((ELIDED NIL)
(FINAL.INDEX (SUB1 (LET ((NELTS (CAR DIMENSIONS)))
(COND
((AND *PRINT-LENGTH* (IGREATERP NELTS *PRINT-LENGTH*))
(SETQ ELIDED T)
*PRINT-LENGTH*)
(T NELTS))))))
(\OUTCHAR STREAM (CHARCODE "("))
(COND
((NULL (CDR DIMENSIONS)) (* Down to bottom level, print the
elements)
(for I from OFFSET to (IPLUS OFFSET FINAL.INDEX)
do (CL:UNLESS (EQ I 0)
(\OUTCHAR STREAM (CHARCODE SPACE)))
(\PRINDATUM (AREF FLAT-ARRAY I)
STREAM)))
((EQ *PRINT-LEVEL* 1) (* Elide at this level)
(for I from 0 to FINAL.INDEX do (CL:UNLESS (EQ I 0)
(\OUTCHAR STREAM (CHARCODE SPACE)))
(\ELIDE.PRINT.ELEMENT STREAM)))
(T (LET ((*PRINT-LEVEL* (AND *PRINT-LEVEL* (SUB1 *PRINT-LEVEL*))))
(for I from 0 to FINAL.INDEX do (CL:UNLESS (EQ I 0)
(\OUTCHAR STREAM (CHARCODE SPACE)))
(\PRINT-ARRAY-CONTENTS FLAT-ARRAY
(ITIMES (CADR DIMENSIONS)
(IPLUS OFFSET I))
(CDR DIMENSIONS)
STREAM)))))
(COND
(ELIDED (\ELIDE.PRINT.TAIL STREAM)))
(\OUTCHAR STREAM (CHARCODE ")")))))
)
(DEFPRINT (QUOTE ONED-ARRAY)
(FUNCTION \DEFPRINT-VECTOR))
(DEFPRINT (QUOTE TWOD-ARRAY)
(FUNCTION \DEFPRINT-ARRAY))
(DEFPRINT (QUOTE GENERAL-ARRAY)
(FUNCTION \DEFPRINT-ARRAY))
(* * Aux files)
(RPAQQ LOWCMLARRAYCOMS
((* * Needed ar run time. Lowel level functions for accessing, setting, and allocating raw
storage. Also includes CML type to TYPENUMBER converters)
(FNS \CML-TYPE-TO-TYPENUMBER \GET-CANONICAL-CML-TYPE \GET-ENCLOSING-SIGNED-BYTE
\GET-ENCLOSING-UNSIGNED-BYTE \LLARRAY-READ \LLARRAY-WRITE \REDUCE-INTEGER \REDUCE-MOD
\LLARRAY-MAKE-STORAGE \SMALLFIXP-SMALLPOSP \SMALLPOSP-SMALLFIXP)
(* * Optimizers, not yet used, since not backed by micro-code)
(MACROS \ARRAY-READ \ARRAY-WRITE)
(* * Support Fns)
(FNS \GET-TYPE-TABLE-ENTRY \GET-TYPE-TABLE-ENTRY-FIELD \LIT-SIZE-TO-SIZE \LIT-TYPE-TO-TYPE
\LLARRAY-MAKE-ACCESSOR-EXPR \LLARRAY-MAKE-SETTOR-EXPR \MAKE-ARRAY-TYPE-TABLE
\MAKE-CML-TYPE-TABLE \TYPE-SIZE-TO-TYPENUMBER)
(* * These aren't needed at run-time)
(DECLARE: DONTCOPY EVAL@COMPILE (* *)
(FUNCTIONS \CML-TYPE-TO-TYPENUMBER-EXPANDER \CHAR-TYPE-P \FAT-CHAR-TYPE-P
\FAT-STRING-CHAR-P \GETBASESMALL-FIXP \GETBASESTRING-CHAR
\GETBASETHINSTRING-CHAR \LLARRAY-TYPED-GET \LLARRAY-TYPED-PUT \LLARRAY-TYPEP
\PACK-TYPENUMBER \PUTBASESMALL-FIXP \PUTBASESTRING-CHAR \PUTBASETHINSTRING-CHAR
\THIN-CHAR-TYPE-P \THIN-STRING-CHAR-P \TYPENUMBER-TO-BITS-PER-ELEMENT
\TYPENUMBER-TO-CML-TYPE \TYPENUMBER-TO-DEFAULT-VALUE \TYPENUMBER-TO-GC-TYPE
\TYPENUMBER-TO-NEEDS-INIT-P \TYPENUMBER-TO-SIZE \TYPENUMBER-TO-TYPE)
(* * These vars contain all the necessary information for typed arrays)
(VARS \LIT-ARRAY-SIZES \LIT-ARRAY-TABLE \LIT-ARRAY-TYPES)
(* * These are generated below)
(GLOBALVARS \ARRAY-TYPE-TABLE \CANONICAL-CML-TYPES)
(* * Describes each entry of \ARRAY-TYPE-TABLE)
(RECORDS ARRAY-TYPE-TABLE-ENTRY)
(* * Make table that drives various macros)
(P (SETQ \ARRAY-TYPE-TABLE (\MAKE-ARRAY-TYPE-TABLE \LIT-ARRAY-TABLE \LIT-ARRAY-TYPES
\LIT-ARRAY-SIZES))
(SETQ \CANONICAL-CML-TYPES (\MAKE-CML-TYPE-TABLE \ARRAY-TYPE-TABLE)))
(* * Constants for (SIGNED-BYTE 16))
(CONSTANTS MAX.SMALLFIXP MIN.SMALLFIXP)
(* * Constants for STRING-CHARS)
(CONSTANTS (\CHAR-TYPE (\LIT-TYPE-TO-TYPE (QUOTE STRING-CHAR)))
(\THIN-CHAR-TYPENUMBER (\TYPE-SIZE-TO-TYPENUMBER (QUOTE STRING-CHAR)
(QUOTE 8BIT)))
(\FAT-CHAR-TYPENUMBER (\TYPE-SIZE-TO-TYPENUMBER (QUOTE STRING-CHAR)
(QUOTE 16BIT)))
\MAXTHINCHAR))
(* * Compiler options)
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY (LOCALVARS . T))))
(* * Needed ar run time. Lowel level functions for accessing, setting, and allocating raw
storage. Also includes CML type to TYPENUMBER converters)
(DEFINEQ
(\CML-TYPE-TO-TYPENUMBER
(LAMBDA (ELEMENT-TYPE FATP) (* jop: " 9-Jul-86 13:35")
(* *)
(LET ((CANONICAL-TYPE (\GET-CANONICAL-CML-TYPE ELEMENT-TYPE)))
(if (AND FATP (EQ CANONICAL-TYPE (QUOTE STRING-CHAR)))
then \FAT-CHAR-TYPENUMBER
else (\CML-TYPE-TO-TYPENUMBER-EXPANDER CANONICAL-TYPE)))))
(\GET-CANONICAL-CML-TYPE
[LAMBDA (ELEMENT-TYPE) (* lmm "29-Jul-86 04:03")
(OR [COND
[(LISTP ELEMENT-TYPE)
(CASE (CAR ELEMENT-TYPE)
(UNSIGNED-BYTE (if (AND (EQLENGTH ELEMENT-TYPE 2)
(SMALLPOSP (CADR ELEMENT-TYPE)))
then (\GET-ENCLOSING-UNSIGNED-BYTE ELEMENT-TYPE)))
(SIGNED-BYTE (if (AND (EQLENGTH ELEMENT-TYPE 2)
(SMALLPOSP (CADR ELEMENT-TYPE)))
then (\GET-ENCLOSING-SIGNED-BYTE ELEMENT-TYPE)))
((MOD CL:MOD)
(if (AND (EQLENGTH ELEMENT-TYPE 2)
(SMALLPOSP (CADR ELEMENT-TYPE)))
then (\REDUCE-MOD ELEMENT-TYPE)))
[INTEGER (DESTRUCTURING-BIND
(LOW HIGH)
(CDR ELEMENT-TYPE)
(COND
((AND (EQLENGTH ELEMENT-TYPE 3)
(INTEGERP LOW)
[OR (INTEGERP HIGH)
(AND (CONSP HIGH)
(INTEGERP (SETQ HIGH (CAR HIGH)))
(SETQ HIGH (SUB1 HIGH]
(<= LOW HIGH))
(if (>= LOW 0)
then (* (INTEGER + high) =>
(MOD (ADD1 HIGH)))
(\REDUCE-MOD (LIST (QUOTE MOD)
(ADD1 HIGH)))
else (LET [(BOUND (MAX (- -1 LOW)
(IABS HIGH]
(if (< BOUND 32768)
then (QUOTE (SIGNED-BYTE 16))
elseif (<= BOUND MAX.FIXP)
then (QUOTE (SIGNED-BYTE 32))
else T]
(AND (* "if (AND A B), use A")
(\GET-CANONICAL-CML-TYPE (CADR ELEMENT-TYPE)))
(T (LET [(PROP (GETPROP (CAR ELEMENT-TYPE)
(QUOTE DEFTYPE]
(AND PROP (\GET-CANONICAL-CML-TYPE (\TYPEP.EXPAND.MACRO PROP ELEMENT-TYPE]
(T (SELECTQ 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)))
(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)))
(if (ILEQ NBITS 16)
then (QUOTE (SIGNED-BYTE 16))
elseif (ILEQ NBITS 32)
then (QUOTE (SIGNED-BYTE 32))
else T))))
(\GET-ENCLOSING-UNSIGNED-BYTE
(LAMBDA (ELEMENT-TYPE) (* jop: " 6-Jul-86 12:50")
(* *)
(LET ((NBITS (CADR ELEMENT-TYPE)))
(if (ILEQ NBITS 1)
then (QUOTE (UNSIGNED-BYTE 1))
elseif (ILEQ NBITS 8)
then (QUOTE (UNSIGNED-BYTE 8))
elseif (ILEQ NBITS 16)
then (QUOTE (UNSIGNED-BYTE 16))
else T))))
(\LLARRAY-READ
(LAMBDA (BASE TYPENUMBER ROW-MAJOR-INDEX) (* jop: " 7-Jul-86 14:15")
(* *)
(\LLARRAY-TYPED-GET BASE TYPENUMBER ROW-MAJOR-INDEX)))
(\LLARRAY-WRITE
(LAMBDA (NEWVALUE BASE TYPENUMBER ROW-MAJOR-INDEX) (* jop: " 7-Jul-86 14:16")
(* *)
(if (NOT (\LLARRAY-TYPEP TYPENUMBER NEWVALUE))
then (ERROR "Illegal value" NEWVALUE)
else (\LLARRAY-TYPED-PUT BASE TYPENUMBER ROW-MAJOR-INDEX NEWVALUE))
NEWVALUE))
(\REDUCE-INTEGER
[LAMBDA (ELEMENTTYPE) (* lmm "29-Jul-86 03:09")
(* *)
(LET ((LOW (CADR ELEMENTTYPE))
(HIGH (CADDR ELEMENTTYPE)))
(if (>= LOW 0)
then (* (INTEGER + high) =>
(MOD (ADD1 HIGH)))
(\REDUCE-MOD (LIST (QUOTE MOD)
(ADD1 HIGH)))
else (LET [(BOUND (MAX (- -1 LOW)
(IABS HIGH]
(if (< BOUND 32768)
then (QUOTE (SIGNED-BYTE 16))
elseif (<= BOUND MAX.FIXP)
then (QUOTE (SIGNED-BYTE 32))
else T])
(\REDUCE-MOD
(LAMBDA (ELEMENT-TYPE) (* jop: " 6-Jul-86 12:50")
(* *)
(LET ((MODNUM (CADR ELEMENT-TYPE)))
(if (ILESSP MODNUM 2)
then (QUOTE (UNSIGNED-BYTE 1))
elseif (ILESSP MODNUM 256)
then (QUOTE (UNSIGNED-BYTE 8))
elseif (ILESSP MODNUM 65536)
then (QUOTE (UNSIGNED-BYTE 16))
else T))))
(\LLARRAY-MAKE-STORAGE
(LAMBDA (NELTS TYPENUMBER INIT-ON-PAGE ALIGNMENT) (* jop: " 7-Jul-86 14:14")
(* *)
(LET* ((BITS-PER-ELEMENT (\TYPENUMBER-TO-BITS-PER-ELEMENT TYPENUMBER))
(GC-TYPE (\TYPENUMBER-TO-GC-TYPE TYPENUMBER))
(NEEDS-INIT-P (\TYPENUMBER-TO-NEEDS-INIT-P TYPENUMBER))
(BASE (\ALLOCBLOCK (FOLDHI (ITIMES NELTS BITS-PER-ELEMENT)
BITSPERCELL)
GC-TYPE INIT-ON-PAGE ALIGNMENT))) (* Initialize Strings to |\Space)
(if NEEDS-INIT-P
then (bind (DEFAULT-VALUE ← (\TYPENUMBER-TO-DEFAULT-VALUE TYPENUMBER)) for I
from 0 to (SUB1 NELTS) do (\LLARRAY-WRITE DEFAULT-VALUE BASE TYPENUMBER I)))
BASE)))
(\SMALLFIXP-SMALLPOSP
(LAMBDA (NUM) (* jop: "21-Apr-86 21:26")
(* *)
(if (SMALLP NUM)
then (if (ILESSP NUM 0)
then (\LOLOC NUM)
else NUM)
else (ERROR "Not a smallp" NUM))))
(\SMALLPOSP-SMALLFIXP
(LAMBDA (NUM) (* jop: " 6-Jul-86 19:26")
(* *)
(if (SMALLPOSP NUM)
then (* as in \MAKENUMBER)
(if (IGREATERP NUM MAX.SMALLFIXP)
then (\VAG2 \SmallNegHi NUM)
else NUM)
else (ERROR "Not a smallposp" NUM))))
)
(* * Optimizers, not yet used, since not backed by micro-code)
(DECLARE: EVAL@COMPILE
(PUTPROPS \ARRAY-READ DMACRO ((BASE TYPENUMBER INDEX)
((OPCODES MISC3 9)
BASE TYPENUMBER INDEX)))
(PUTPROPS \ARRAY-WRITE DMACRO ((NEWVALUE BASE TYPENUMBER INDEX)
((OPCODES MISC4 7)
NEWVALUE BASE TYPENUMBER INDEX)))
)
(* * Support Fns)
(DEFINEQ
(\GET-TYPE-TABLE-ENTRY
(LAMBDA (TYPENUMBER) (* jop: " 6-Jul-86 16:54")
(* *)
(DECLARE (GLOBALVARS \ARRAY-TYPE-TABLE))
(CADR (FASSOC TYPENUMBER \ARRAY-TYPE-TABLE))))
(\GET-TYPE-TABLE-ENTRY-FIELD
(LAMBDA (TYPENUMBER FIELDNAME) (* jop: " 6-Jul-86 18:18")
(* *)
(LET ((ENTRY (\GET-TYPE-TABLE-ENTRY TYPENUMBER)))
(if ENTRY
then (SELECTQ FIELDNAME
(CML-TYPE (fetch (ARRAY-TYPE-TABLE-ENTRY CML-TYPE) of ENTRY))
(ACCESSOR (fetch (ARRAY-TYPE-TABLE-ENTRY ACCESSOR) of ENTRY))
(SETTOR (fetch (ARRAY-TYPE-TABLE-ENTRY SETTOR) of ENTRY))
(BITS-PER-ELEMENT
(fetch (ARRAY-TYPE-TABLE-ENTRY BITS-PER-ELEMENT) of ENTRY))
(GC-TYPE (fetch (ARRAY-TYPE-TABLE-ENTRY GC-TYPE) of ENTRY))
(DEFAULT-VALUE (fetch (ARRAY-TYPE-TABLE-ENTRY DEFAULT-VALUE) of ENTRY))
(NEEDS-SHIFT-P (fetch (ARRAY-TYPE-TABLE-ENTRY NEEDS-SHIFT-P) of ENTRY))
(NEEDS-INIT-P (fetch (ARRAY-TYPE-TABLE-ENTRY NEEDS-INIT-P) of ENTRY))
(TYPE-TEST (fetch (ARRAY-TYPE-TABLE-ENTRY TYPE-TEST) of ENTRY))
(ERROR "No such field" FIELDNAME))
else (ERROR "Illegal type" TYPENUMBER)))))
(\LIT-SIZE-TO-SIZE
(LAMBDA (LIT-SIZE) (* jop: " 6-Jul-86 18:23")
(* *)
(DECLARE (GLOBALVARS \LIT-ARRAY-SIZES))
(CADR (FASSOC LIT-SIZE \LIT-ARRAY-SIZES))))
(\LIT-TYPE-TO-TYPE
(LAMBDA (LIT-TYPE) (* jop: " 6-Jul-86 18:22")
(* *)
(DECLARE (GLOBALVARS \LIT-ARRAY-TYPES))
(CADR (FASSOC LIT-TYPE \LIT-ARRAY-TYPES))))
(\LLARRAY-MAKE-ACCESSOR-EXPR
(LAMBDA (TYPENUMBER BASE OFFSET) (* jop: " 7-Jul-86 14:15")
(* *)
(LET* ((ENTRY (\GET-TYPE-TABLE-ENTRY TYPENUMBER))
(ACCESSOR (fetch (ARRAY-TYPE-TABLE-ENTRY ACCESSOR) of ENTRY))
(BITS-PER-ELEMENT (fetch (ARRAY-TYPE-TABLE-ENTRY BITS-PER-ELEMENT) of ENTRY))
(NEEDS-SHIFT-P (fetch (ARRAY-TYPE-TABLE-ENTRY NEEDS-SHIFT-P) of ENTRY)))
(BQUOTE (%, ACCESSOR %, BASE %, (if NEEDS-SHIFT-P
then (BQUOTE (LLSH %, OFFSET %, NEEDS-SHIFT-P))
else OFFSET))))))
(\LLARRAY-MAKE-SETTOR-EXPR
(LAMBDA (TYPENUMBER BASE OFFSET NEWVALUE) (* jop: " 7-Jul-86 14:14")
(* *)
(LET* ((ENTRY (\GET-TYPE-TABLE-ENTRY TYPENUMBER))
(SETTOR (fetch (ARRAY-TYPE-TABLE-ENTRY SETTOR) of ENTRY))
(BITS-PER-ELEMENT (fetch (ARRAY-TYPE-TABLE-ENTRY BITS-PER-ELEMENT) of ENTRY))
(NEEDS-SHIFT-P (fetch (ARRAY-TYPE-TABLE-ENTRY NEEDS-SHIFT-P) of ENTRY)))
(BQUOTE (%, SETTOR %, BASE %, (if NEEDS-SHIFT-P
then (BQUOTE (LLSH %, OFFSET %, NEEDS-SHIFT-P))
else OFFSET)
%, NEWVALUE)))))
(\MAKE-ARRAY-TYPE-TABLE
(LAMBDA (LIT-TABLE TYPES SIZES) (* jop: " 6-Jul-86 18:35")
(* *)
(for TYPE-ENTRY in LIT-TABLE join (for SIZE-ENTRY in (CADR TYPE-ENTRY)
collect (LIST (\TYPE-SIZE-TO-TYPENUMBER (CAR TYPE-ENTRY)
(CAR SIZE-ENTRY))
(CADR SIZE-ENTRY))))))
(\MAKE-CML-TYPE-TABLE
(LAMBDA (ARRAY-TABLE) (* jop: " 7-Jul-86 13:18")
(* *)
(bind CMLTYPE CMLTYPES for TYPE-ENTRY in ARRAY-TABLE
when (NOT (MEMBER (SETQ CMLTYPE (fetch (ARRAY-TYPE-TABLE-ENTRY CML-TYPE) of (CADR TYPE-ENTRY))
)
CMLTYPES)) collect (push CMLTYPES CMLTYPE)
(LIST CMLTYPE (CAR TYPE-ENTRY)))))
(\TYPE-SIZE-TO-TYPENUMBER
(LAMBDA (LIT-TYPE LIT-SIZE) (* jop: " 6-Jul-86 14:45")
(* *)
(DECLARE (GLOBALVARS \LIT-ARRAY-TYPES \LIT-ARRAY-SIZES))
(LET ((TYPE (CADR (FASSOC LIT-TYPE \LIT-ARRAY-TYPES)))
(SIZE (CADR (FASSOC LIT-SIZE \LIT-ARRAY-SIZES))))
(\PACK-TYPENUMBER TYPE SIZE))))
)
(* * These aren't needed at run-time)
(DECLARE: DONTCOPY EVAL@COMPILE
(DEFMACRO \CML-TYPE-TO-TYPENUMBER-EXPANDER (CML-TYPE)
(* *)
(DECLARE (GLOBALVARS \CANONICAL-CML-TYPES))
(LET
((SIMPLE-TYPES (for ENTRY in \CANONICAL-CML-TYPES when (NOT (LISTP (CAR ENTRY)))
collect (CAR ENTRY)))
(COMPOUND-TYPES (bind MAJOR-TYPES for ENTRY in \CANONICAL-CML-TYPES
when (AND (LISTP (CAR ENTRY))
(NOT (MEMB (CAAR ENTRY)
MAJOR-TYPES))) do (push MAJOR-TYPES (CAAR ENTRY))
finally (RETURN (DREVERSE MAJOR-TYPES)))))
(BQUOTE (if (LISTP %, CML-TYPE)
then (SELECTQ (CAR %, CML-TYPE)
%,@
(for TYPE in COMPOUND-TYPES collect
(BQUOTE ((\, TYPE)
(SELECTQ (CADR (\, CML-TYPE))
%,@
(for ENTRY in \CANONICAL-CML-TYPES when
(AND (LISTP (CAR ENTRY))
(EQ (CAAR ENTRY)
TYPE))
collect
(LIST (CADAR ENTRY)
(CADR ENTRY)))
(SHOULDNT)))))
(SHOULDNT))
else (SELECTQ %,
CML-TYPE
%,@
(for TYPE in SIMPLE-TYPES collect (FASSOC TYPE \CANONICAL-CML-TYPES))
(SHOULDNT))))))
(DEFMACRO \CHAR-TYPE-P (TYPENUMBER)
(* *)
(BQUOTE (EQ (\TYPENUMBER-TO-TYPE (\, TYPENUMBER))
\CHAR-TYPE)))
(DEFMACRO \FAT-CHAR-TYPE-P (TYPENUMBER)
(* *)
(BQUOTE (EQ (\, TYPENUMBER)
\FAT-CHAR-TYPENUMBER)))
(DEFMACRO \FAT-STRING-CHAR-P (OBJECT)
(* *)
(BQUOTE (AND (STRING-CHAR-P (\, OBJECT))
(IGREATERP (CHAR-INT (\, OBJECT))
\MAXTHINCHAR))))
(DEFMACRO \GETBASESMALL-FIXP (BASE OFFSET)
(* *)
(BQUOTE (\SMALLPOSP-SMALLFIXP (\GETBASE %, BASE %, OFFSET))))
(DEFMACRO \GETBASESTRING-CHAR (PTR DISP)
(* *)
(BQUOTE (INT-CHAR (\GETBASE (\, PTR)
(\, DISP)))))
(DEFMACRO \GETBASETHINSTRING-CHAR (PTR DISP)
(* *)
(BQUOTE (INT-CHAR (\GETBASEBYTE (\, PTR)
(\, DISP)))))
(DEFMACRO \LLARRAY-TYPED-GET (BASE TYPENUMBER OFFSET)
(DECLARE (GLOBALVARS \ARRAY-TYPE-TABLE))
(BQUOTE (SELECTQ %,
TYPENUMBER
%,.
(APPEND (for TYPEENTRY in \ARRAY-TYPE-TABLE
collect (BQUOTE (%, (CAR TYPEENTRY)
%,
(\LLARRAY-MAKE-ACCESSOR-EXPR (CAR TYPEENTRY)
BASE OFFSET))))
(BQUOTE ((SHOULDNT)))))))
(DEFMACRO \LLARRAY-TYPED-PUT (BASE TYPENUMBER OFFSET NEWVALUE)
(DECLARE (GLOBALVARS \ARRAY-TYPE-TABLE))
(BQUOTE (SELECTQ %,
TYPENUMBER
%,.
(APPEND (for TYPEENTRY in \ARRAY-TYPE-TABLE
collect (BQUOTE (%, (CAR TYPEENTRY)
%,
(\LLARRAY-MAKE-SETTOR-EXPR (CAR TYPEENTRY)
BASE OFFSET NEWVALUE))))
(BQUOTE ((SHOULDNT)))))))
(DEFMACRO \LLARRAY-TYPEP (TYPENUMBER VALUE)
(BQUOTE (SELECTQ %,
TYPENUMBER
%,.
(APPEND (for TYPEENTRY in \ARRAY-TYPE-TABLE
collect (BQUOTE (%, (CAR TYPEENTRY)
(%, (fetch (ARRAY-TYPE-TABLE-ENTRY TYPE-TEST)
of (CADR TYPEENTRY))
%, VALUE))))
(BQUOTE ((SHOULDNT)))))))
(DEFMACRO \PACK-TYPENUMBER (ELTTYPE ELTSIZE) (BQUOTE (\ADDBASE (LLSH %, ELTTYPE 4)
%, ELTSIZE)))
(DEFMACRO \PUTBASESMALL-FIXP (BASE OFFSET VALUE)
(* *)
(BQUOTE (\PUTBASE %, BASE %, OFFSET (\SMALLFIXP-SMALLPOSP %, VALUE))))
(DEFMACRO \PUTBASESTRING-CHAR (PTR DISP CHAR)
(* *)
(BQUOTE (\PUTBASE (\, PTR)
(\, DISP)
(CHAR-INT (\, CHAR)))))
(DEFMACRO \PUTBASETHINSTRING-CHAR (PTR DISP CHAR)
(* *)
(BQUOTE (\PUTBASEBYTE (\, PTR)
(\, DISP)
(CHAR-INT (\, CHAR)))))
(DEFMACRO \THIN-CHAR-TYPE-P (TYPENUMBER)
(* *)
(BQUOTE (EQ (\, TYPENUMBER)
\THIN-CHAR-TYPENUMBER)))
(DEFMACRO \THIN-STRING-CHAR-P (OBJECT)
(* *)
(BQUOTE (AND (STRING-CHAR-P (\, OBJECT))
(ILEQ (CHAR-INT (\, OBJECT))
\MAXTHINCHAR))))
(DEFMACRO \TYPENUMBER-TO-BITS-PER-ELEMENT (TYPENUMBER)
(* *)
(DECLARE (GLOBALVARS \ARRAY-TYPE-TABLE))
(BQUOTE (SELECTQ %,
TYPENUMBER
%,.
(APPEND (for TYPEENTRY in \ARRAY-TYPE-TABLE
collect (BQUOTE (%, (CAR TYPEENTRY)
%,
(fetch (ARRAY-TYPE-TABLE-ENTRY BITS-PER-ELEMENT)
of (CADR TYPEENTRY)))))
(BQUOTE ((SHOULDNT)))))))
(DEFMACRO \TYPENUMBER-TO-CML-TYPE (TYPENUMBER)
(* *)
(DECLARE (GLOBALVARS \ARRAY-TYPE-TABLE))
(BQUOTE (SELECTQ %,
TYPENUMBER
%,.
(APPEND (for TYPEENTRY in \ARRAY-TYPE-TABLE
collect (BQUOTE (%, (CAR TYPEENTRY)
(QUOTE %, (fetch (ARRAY-TYPE-TABLE-ENTRY CML-TYPE)
of
(CADR TYPEENTRY))))))
(BQUOTE ((SHOULDNT)))))))
(DEFMACRO \TYPENUMBER-TO-DEFAULT-VALUE (TYPENUMBER)
(* *)
(DECLARE (GLOBALVARS \ARRAY-TYPE-TABLE))
(BQUOTE (SELECTQ %,
TYPENUMBER
%,.
(APPEND (for TYPEENTRY in \ARRAY-TYPE-TABLE
collect (BQUOTE (%, (CAR TYPEENTRY)
%,
(fetch (ARRAY-TYPE-TABLE-ENTRY DEFAULT-VALUE)
of (CADR TYPEENTRY)))))
(BQUOTE ((SHOULDNT)))))))
(DEFMACRO \TYPENUMBER-TO-GC-TYPE (TYPENUMBER)
(* *)
(DECLARE (GLOBALVARS \ARRAY-TYPE-TABLE))
(BQUOTE (SELECTQ %,
TYPENUMBER
%,.
(APPEND (for TYPEENTRY in \ARRAY-TYPE-TABLE
collect (BQUOTE (%, (CAR TYPEENTRY)
%,
(fetch (ARRAY-TYPE-TABLE-ENTRY GC-TYPE)
of (CADR TYPEENTRY)))))
(BQUOTE ((SHOULDNT)))))))
(DEFMACRO \TYPENUMBER-TO-NEEDS-INIT-P (TYPENUMBER)
(* *)
(DECLARE (GLOBALVARS \ARRAY-TYPE-TABLE))
(BQUOTE (SELECTQ %,
TYPENUMBER
%,.
(APPEND (for TYPEENTRY in \ARRAY-TYPE-TABLE
collect (BQUOTE (%, (CAR TYPEENTRY)
%,
(fetch (ARRAY-TYPE-TABLE-ENTRY NEEDS-INIT-P)
of (CADR TYPEENTRY)))))
(BQUOTE ((SHOULDNT)))))))
(DEFMACRO \TYPENUMBER-TO-SIZE (TYPENUMBER) (BQUOTE (LOGAND %, TYPENUMBER 15)))
(DEFMACRO \TYPENUMBER-TO-TYPE (TYPENUMBER) (BQUOTE (LRSH %, TYPENUMBER 4)))
(RPAQQ \LIT-ARRAY-SIZES ((1BIT 0)
(8BIT 3)
(16BIT 4)
(32BIT 6)))
(RPAQQ \LIT-ARRAY-TABLE [[STRING-CHAR ([8BIT (STRING-CHAR \GETBASETHINSTRING-CHAR
\PUTBASETHINSTRING-CHAR 8 UNBOXEDBLOCK.GCT |\Space
NIL T (LAMBDA (OBJECT)
(\THIN-STRING-CHAR-P OBJECT]
(16BIT (STRING-CHAR \GETBASESTRING-CHAR \PUTBASESTRING-CHAR 16
UNBOXEDBLOCK.GCT |\Space NIL T (LAMBDA
(OBJECT)
(STRING-CHAR-P
OBJECT]
[T ((32BIT (T \GETBASEPTR \RPLPTR 32 PTRBLOCK.GCT NIL 1 NIL (LAMBDA (OBJECT)
T]
[XPOINTER ((32BIT (XPOINTER \GETBASEPTR \PUTBASEPTR 32 UNBOXEDBLOCK.GCT NIL
1 NIL (LAMBDA (OBJECT)
T]
[SINGLE-FLOAT ((32BIT (SINGLE-FLOAT \GETBASEFLOATP \PUTBASEFLOATP 32
UNBOXEDBLOCK.GCT 0.0 1 NIL (LAMBDA (OBJECT)
(FLOATP
OBJECT]
[UNSIGNED-BYTE ([1BIT ((UNSIGNED-BYTE 1)
\GETBASEBIT \PUTBASEBIT 1 UNBOXEDBLOCK.GCT 0 NIL NIL
(LAMBDA (OBJECT)
(AND (SMALLPOSP OBJECT)
(ILESSP OBJECT 2]
[8BIT ((UNSIGNED-BYTE 8)
\GETBASEBYTE \PUTBASEBYTE 8 UNBOXEDBLOCK.GCT 0 NIL
NIL (LAMBDA (OBJECT)
(AND (SMALLPOSP OBJECT)
(ILESSP OBJECT 256]
(16BIT ((UNSIGNED-BYTE 16)
\GETBASE \PUTBASE 16 UNBOXEDBLOCK.GCT 0 NIL NIL
(LAMBDA (OBJECT)
(SMALLPOSP OBJECT]
(SIGNED-BYTE ([16BIT ((SIGNED-BYTE 16)
\GETBASESMALL-FIXP \PUTBASESMALL-FIXP 16
UNBOXEDBLOCK.GCT 0 NIL NIL (LAMBDA (OBJECT)
(AND (SMALLP OBJECT)
(IGEQ OBJECT
MIN.SMALLFIXP
)
(ILEQ OBJECT
MAX.SMALLFIXP
]
(32BIT ((SIGNED-BYTE 32)
\GETBASEFIXP \PUTBASEFIXP 32 UNBOXEDBLOCK.GCT 0 1 NIL
(LAMBDA (OBJECT)
(AND (FIXP OBJECT)
(IGEQ OBJECT MIN.FIXP)
(ILEQ OBJECT MAX.FIXP])
(RPAQQ \LIT-ARRAY-TYPES ((UNSIGNED-BYTE 0)
(SIGNED-BYTE 1)
(T 2)
(SINGLE-FLOAT 3)
(STRING-CHAR 4)
(XPOINTER 5)))
(DECLARE: DOEVAL@COMPILE DONTCOPY
(GLOBALVARS \ARRAY-TYPE-TABLE \CANONICAL-CML-TYPES)
)
[DECLARE: EVAL@COMPILE
(RECORD ARRAY-TYPE-TABLE-ENTRY (CML-TYPE ACCESSOR SETTOR BITS-PER-ELEMENT GC-TYPE DEFAULT-VALUE
NEEDS-SHIFT-P NEEDS-INIT-P TYPE-TEST))
]
(SETQ \ARRAY-TYPE-TABLE (\MAKE-ARRAY-TYPE-TABLE \LIT-ARRAY-TABLE \LIT-ARRAY-TYPES \LIT-ARRAY-SIZES))
(SETQ \CANONICAL-CML-TYPES (\MAKE-CML-TYPE-TABLE \ARRAY-TYPE-TABLE))
(DECLARE: EVAL@COMPILE
(RPAQQ MAX.SMALLFIXP 32767)
(RPAQQ MIN.SMALLFIXP -32768)
(CONSTANTS MAX.SMALLFIXP MIN.SMALLFIXP)
)
(DECLARE: EVAL@COMPILE
(RPAQ \CHAR-TYPE (\LIT-TYPE-TO-TYPE (QUOTE STRING-CHAR)))
(RPAQ \THIN-CHAR-TYPENUMBER (\TYPE-SIZE-TO-TYPENUMBER (QUOTE STRING-CHAR)
(QUOTE 8BIT)))
(RPAQ \FAT-CHAR-TYPENUMBER (\TYPE-SIZE-TO-TYPENUMBER (QUOTE STRING-CHAR)
(QUOTE 16BIT)))
(RPAQQ \MAXTHINCHAR 255)
(CONSTANTS (\CHAR-TYPE (\LIT-TYPE-TO-TYPE (QUOTE STRING-CHAR)))
(\THIN-CHAR-TYPENUMBER (\TYPE-SIZE-TO-TYPENUMBER (QUOTE STRING-CHAR)
(QUOTE 8BIT)))
(\FAT-CHAR-TYPENUMBER (\TYPE-SIZE-TO-TYPENUMBER (QUOTE STRING-CHAR)
(QUOTE 16BIT)))
\MAXTHINCHAR)
)
)
(* * Compiler options)
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY
(DECLARE: DOEVAL@COMPILE DONTCOPY
(LOCALVARS . T)
)
)
(* * 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 SHRINK-VECTOR VECTOR ASET ARRAY-ROW-MAJOR-INDEX ARRAY-IN-BOUNDS-P AREF)
)
(PUTPROPS CMLARRAY COPYRIGHT ("Xerox Corporation" 1986))
(DECLARE: DONTCOPY
(FILEMAP (NIL (14352 36353 (ADJUSTABLE-ARRAY-P 14362 . 14834) (AREF 14836 . 17391) (ARRAY-DIMENSION
17393 . 19286) (ARRAY-DIMENSIONS 19288 . 20073) (ARRAY-DISPLACED-P 20075 . 20545) (ARRAY-ELEMENT-TYPE
20547 . 21059) (ARRAY-HAS-FILL-POINTER-P 21061 . 21540) (ARRAY-IN-BOUNDS-P 21542 . 22174) (ARRAY-RANK
22176 . 22774) (ARRAY-ROW-MAJOR-INDEX 22776 . 23681) (ARRAY-TOTAL-SIZE 23683 . 24161) (ASET 24163 .
27314) (BIT-AND 27316 . 27516) (BIT-ANDC1 27518 . 27722) (BIT-ANDC2 27724 . 27928) (BIT-EQV 27930 .
28130) (BIT-IOR 28132 . 28332) (BIT-NAND 28334 . 28536) (BIT-NOR 28538 . 28742) (BIT-NOT 28744 . 29789
) (BIT-ORC1 29791 . 29993) (BIT-ORC2 29995 . 30197) (BIT-VECTOR-P 30199 . 30473) (BIT-XOR 30475 .
30675) (CL:ARRAYP 30677 . 30896) (CL:STRINGP 30898 . 31121) (FILL-POINTER 31123 . 31573) (SCHAR 31575
. 31747) (CHAR 31749 . 31906) (SCHARSET 31908 . 32060) (SET-FILL-POINTER 32062 . 32811) (
SIMPLE-ARRAY-P 32813 . 33045) (SIMPLE-BIT-VECTOR-P 33047 . 33336) (SIMPLE-STRING-P 33338 . 33574) (
SIMPLE-VECTOR-P 33576 . 33816) (VECTOR 33818 . 34150) (VECTOR-POP 34152 . 35054) (VECTOR-PUSH 35056 .
36125) (VECTORP 36127 . 36351)) (38279 68209 (SHRINK-VECTOR 38289 . 39214) (\ALTER-AS-DISPLACED-ARRAY
39216 . 41314) (\ALTER-AS-DISPLACED-TO-BASE-ARRAY 41316 . 42336) (\AREF0 42338 . 43199) (\AREF1 43201
. 44482) (\AREF2 44484 . 46424) (\ARRAY-BASE 46426 . 46871) (\ARRAY-CONTENT-INITIALIZE 46873 . 47249)
(\ARRAY-ELEMENT-INITIALIZE 47251 . 47659) (\ARRAY-OFFSET 47661 . 48224) (\ASET0 48226 . 49097) (
\ASET1 49099 . 50704) (\ASET2 50706 . 52943) (\COPY-ARRAY-TO-ARRAY 52945 . 53703) (\COPY-LIST-TO-ARRAY
53705 . 54524) (\DO-LOGICAL-OP 54526 . 56714) (\EQUAL-LIST-DIMENSIONS 56716 . 57169) (
\FAT-STRING-ARRAY-P 57171 . 57434) (\FILL-NEW-ARRAY 57436 . 59023) (\FLATTEN-ARRAY 59025 . 59558) (
\GET-ARRAY-OFFSET 59560 . 59969) (\MAKE-DISPLACED-ARRAY 59971 . 62081) (\MAKE-DISPLACED-TO-BASE-ARRAY
62083 . 62768) (\MAKE-GENERAL-ARRAY 62770 . 63672) (\MAKE-NON-SIMPLE-ARRAY 63674 . 64222) (
\MAKE-ONED-ARRAY 64224 . 64981) (\MAKE-SIMPLE-ARRAY 64983 . 65428) (\MAKE-STRING-FAT 65430 . 67400) (
\MAKE-TWOD-ARRAY 67402 . 67946) (\TOTAL-SIZE 67948 . 68207)) (68472 70417 (\ARRAYP 68482 . 68730) (
\SIMPLE-ARRAY-P 68732 . 69116) (\SIMPLE-STRING-P 69118 . 69372) (\SIMPLE-VECTOR-P 69374 . 69704) (
\STRING-ARRAY-P 69706 . 69961) (\STRINGP 69963 . 70194) (\VECTORP 70196 . 70415)) (70451 71402 (
\GENERAL-ARRAY-P 70461 . 70697) (\ONED-ARRAY-P 70699 . 70915) (\THIN-STRING-ARRAY-P 70917 . 71182) (
\TWOD-ARRAY-P 71184 . 71400)) (84143 84747 (\AREF-EXPANDER 84153 . 84448) (\ASET-EXPANDER 84450 .
84745)) (85639 98975 (\DEFPRINT-ARRAY 85649 . 88102) (\DEFPRINT-BITVECTOR 88104 . 90778) (
\DEFPRINT-VECTOR 90780 . 95070) (\DEFPRINT-STRING 95072 . 96830) (\PRINT-ARRAY-CONTENTS 96832 . 98973)
) (102345 110714 (\CML-TYPE-TO-TYPENUMBER 102355 . 102767) (\GET-CANONICAL-CML-TYPE 102769 . 106305) (
\GET-ENCLOSING-SIGNED-BYTE 106307 . 106696) (\GET-ENCLOSING-UNSIGNED-BYTE 106698 . 107176) (
\LLARRAY-READ 107178 . 107383) (\LLARRAY-WRITE 107385 . 107730) (\REDUCE-INTEGER 107732 . 108608) (
\REDUCE-MOD 108610 . 109086) (\LLARRAY-MAKE-STORAGE 109088 . 109927) (\SMALLFIXP-SMALLPOSP 109929 .
110260) (\SMALLPOSP-SMALLFIXP 110262 . 110712)) (111174 116106 (\GET-TYPE-TABLE-ENTRY 111184 . 111438)
(\GET-TYPE-TABLE-ENTRY-FIELD 111440 . 112733) (\LIT-SIZE-TO-SIZE 112735 . 112981) (\LIT-TYPE-TO-TYPE
112983 . 113229) (\LLARRAY-MAKE-ACCESSOR-EXPR 113231 . 113947) (\LLARRAY-MAKE-SETTOR-EXPR 113949 .
114687) (\MAKE-ARRAY-TYPE-TABLE 114689 . 115203) (\MAKE-CML-TYPE-TABLE 115205 . 115720) (
\TYPE-SIZE-TO-TYPENUMBER 115722 . 116104)))))
STOP