(FILECREATED "16-Oct-85 14:59:10" {ERIS}<FISCHER>LIBRARY>CMLARRAY.;5 72446
changes to: (FNS COPY.ARRAY.TO.STRING MAKE-ARRAY \CML.CHARCODE) (VARS CMLARRAYCOMS)
previous date: "16-Oct-85 00:57:53" {ERIS}<FISCHER>LIBRARY>CMLARRAY.;3)
(* Copyright (c) 1982, 1983, 1984, 1985 by A A A A A Aation. All rights reserved.)
(PRETTYCOMPRINT CMLARRAYCOMS)
(RPAQQ CMLARRAYCOMS ((* * Commonlisp style array facilities - Missing are - 1 full Commonlisp type
specifiers - 2 bit array operations - 3 displacement to existing array types - Note: EXISTING array
types may be used with this package and can be passed to any of the top level array functions - This
package is based on orginal code by JonL White) (DECLARE: EVAL@COMPILE DONTCOPY (* * Utilities) (
MACROS \CHECKTYPE \INDEXABLE.FIXP DATATYPE.TEST)) (COMS (* * The limits of the implementation-) (
DECLARE: EVAL@COMPILE DONTCOPY (*) (CONSTANTS (ARRAY-RANK-LIMIT (EXPT 2 7)) (ARRAY-TOTAL-SIZE-LIMIT
\MaxArrayNCells) (ARRAY-DIMENSION-LIMIT \MaxArrayNCells))) (VARS ARRAY-RANK-LIMIT
ARRAY-TOTAL-SIZE-LIMIT ARRAY-DIMENSION-LIMIT)) (COMS (* * an encapsulation of type specific operations
) (DECLARE: EVAL@COMPILE DONTCOPY (*) (CONSTANTS * CMLARRAYTYPES) (RECORDS CML.TYPE.ENTRY) (CONSTANTS
CMLARRAY.TYPE.TABLE CML.SETTOR.TO.TYPE.ALIST CML.ACCESSOR.TO.TYPE.ALIST) (MACROS \CML.TYPEP
\CML.TYPED.GET \CML.TYPED.PUT \CML.BITS.PER.ELEMENT \CML.ELEMENT.GC.TYPE \CML.TYPE.DEFAULT.VALUE
\CML.UNBOXED.TYPE.P \GETBASESTRING-CHAR \PUTBASESTRING-CHAR)) (MACROS (* This is for Herbie...)
\CML.GET.ARRAY.BASE) (FNS \CML.GENERIC.ELEMENT.TYPE \CML.ARRAYP.TYPE.TO.CML.TYPE
\CML.BITMAP.TYPE.TO.CML.TYPE) (FNS \CML.GET.TYPE.ENTRY \CML.OFFSET.EXPANDER)) (COMS (* * Headers which
describe the array's structure and the storage it uses, and functions for testing them.) (RECORDS
ARRAY) (FNS (* Types ARRAY and VECTOR are abstract from their DATATYPES) CL:ARRAYP VECTORP) (FNS
\ARRAY.DIMENSIONS.MATCH) (DECLARE: EVAL@COMPILE DONTCOPY (*) (MACROS \CML.GENERIC.FETCH \CML.GETMARGIN
)) (MACROS DATATYPE.ARRAY TYPE?.ARRAY)) (LOCALVARS . T) (COMS (* * MAKE-ARRAY ADJUST-ARRAY and friends
) (FNS (* Handlers for displaced arrays) \DISPLACEARRAY \CML.DCHAIN.UPDATE \CML.LINK.ARRAY
\CML.UNLINK.ARRAY) (FNS (* Creating, initializing and moving storage around)
SLOW.COPY.ELEMENT.INTO.ARRAY \COPYARRAY \CML.ELEMENT.INITIALIZE \CML.CONTENT.INITIALIZE
\FLAT.COPY.ARRAY.TO.ARRAY \FLAT.COPY.LIST.TO.ARRAY COPY.LIST.TO.STRING
COPY.STRING-CHAR.TO.SIMPLE-STRING COPY.ARRAY.TO.STRING COPY.BITMAP.TO.ARRAY COPY.STRING.TO.ARRAY
COPY.LIST.TO.BITMAP COPY.ARRAY.TO.BITMAP COPY.ELEMENT.TO.BITMAP \CML.MAKE.STORAGE) (FNS (* Type
coercion) \CML.MS.ELEMENT.TYPE \CML.ILTYPE.TO.CLTYPE) (FNS (* Creation of reference vectors) \MARGINTO
\MARGIN.ONE.DIMENSION) (FNS (*) \CML.ICP.CHECK) (FNS (* The stars of our show) MAKE-ARRAY VECTOR
ADJUST-ARRAY) (SPECVARS ARRAYWARNINGFLG) (* If this flag is true, we print a warning when creating
arrays in non-GC-able space)) (COMS (* * Accessor and settor function group) (FNS AREF ASET) (FNS
\AREF.1 \AREF.2 \ASET.1 \ASET.2) (PROP SETFN AREF) (MACROS ASETMACRO) (FNS \AREFLINEAR \ASETLINEAR) (
COMS (* Makes it work in the absence of the CML system) (FNS \CML.CHARCODE) (P (MOVD? (QUOTE CHARACTER
) (QUOTE INT-CHAR)) (MOVD? (QUOTE \CML.CHARCODE) (QUOTE CHAR-INT)) (MOVD? (QUOTE \CML.CHARCODE) (QUOTE
STRING-CHAR-P)))) (DECLARE: EVAL@COMPILE DONTCOPY (*) (MACROS \AREFSET.LINEARIZE \AREFSET.LINEARIZE1
\AREFSET.LINEARIZE2)) (COMS (*) (DECLARE: EVAL@COMPILE (* * The following sets up accessor and settor
macros for all the possible types of array. Their names are prefixed with a single character
indicating the element type. - THESE ONLY WORK WITH DATATYPE ARRAY) (P ((LAMBDA (C) (MAPC (QUOTE (P X
1 4 8 16 N L)) (FUNCTION (LAMBDA (A) (MAPC (QUOTE (AREF ASET)) (FUNCTION (LAMBDA (B) (SETQ C (MKATOM (
CONCAT A B))) (PUTPROP C (QUOTE MACRO) (BQUOTE (X (, (MKATOM (CONCAT "\Fast" B "expander")) X (QUOTE ,
C))))))))))))))) (FNS (* Expanders for the above macros) \FastAREFexpander \NoSissyAREFexpander
\FastASETexpander \NoSissyASETexpander \AREFSET.INDEXFORM) (FNS (*) \CMLARRAY.LOCFTRAN) (COMS (* *
Type specific accessors and settors) (COMS (* Simple Vector) (FNS SVREF SVSET) (PROP SETFN SVREF)) (
COMS (* Bit arrays) (FNS BIT SBIT SBITSET) (PROP SETFN BIT SBIT) (* * ! BIT-AND BIT-IOR BIT-XOR
BIT-EQV BIT-NAND BIT-NOR BIT-ANDC1 BIT-ANDC2 BIT-ORC1 BIT-ORC2 BIT-NOT)) (COMS (* Strings) (FNS CHAR
SCHAR SCHARSET) (PROP SETFN CHAR SCHAR))))) (COMS (* * Fill pointer operations) (INITVARS (
*DEFAULT-PUSH-EXTENSION-SIZE* 20)) (GLOBALVARS *DEFAULT-PUSH-EXTENSION-SIZE*) (FNS
ARRAY-HAS-FILL-POINTER-P FILL-POINTER FILL-POINTER-SET VECTOR-PUSH VECTOR-PUSH-EXTEND VECTOR-POP) (
PROP SETFN FILL-POINTER)) (COMS (* * Header info) (FNS CML.DIMENSIONS.LINEAR.SIZE) (FNS (*)
ADJUSTABLE-ARRAY-P ARRAY-RANK ARRAY-DIMENSIONS ARRAY-DIMENSION ARRAY-ELEMENT-TYPE ARRAY-IN-BOUNDS-P
ARRAY-TOTAL-SIZE ARRAY-ROW-MAJOR-INDEX)) (COMS (* * Array IO) (INITVARS (*PRINT-ARRAY* NIL) (
*PRINT-LEVEL* NIL) (*PRINT-LENGTH* NIL)) (FNS (* Output) COPY.ARRAY.TO.LIST
\COPY.ARRAY.DIMENSION.TO.LIST FLAT.COPY.ARRAY.TO.LIST \DEFPRINT.ARRAY \DEFPRINT.VECTOR
\DEFPRINT.BITVECTOR \DEFPRINT.BITMAP LIST.VECTOR) (P (DEFPRINT (QUOTE ARRAY) (QUOTE \DEFPRINT.ARRAY))
(DEFPRINT (QUOTE BITMAP) (QUOTE \DEFPRINT.BITMAP)) (DEFPRINT (QUOTE ARRAYP) (QUOTE \DEFPRINT.VECTOR)))
(FNS (* Input) FILL.VECTOR)) (* * Compiler gronk) (DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY
COMPILERVARS (ADDVARS (NLAMA) (NLAML) (LAMA ARRAY-ROW-MAJOR-INDEX ARRAY-IN-BOUNDS-P VECTOR-PUSH-EXTEND
SBIT BIT ASET AREF ADJUST-ARRAY VECTOR MAKE-ARRAY)))))
(* * Commonlisp style array facilities - Missing are - 1 full Commonlisp type specifiers - 2
bit array operations - 3 displacement to existing array types - Note: EXISTING array types may
be used with this package and can be passed to any of the top level array functions - This
package is based on orginal code by JonL White)
(DECLARE: EVAL@COMPILE DONTCOPY
(DECLARE: EVAL@COMPILE
(PUTPROPS \CHECKTYPE MACRO (X (PROG ((VAR (CAR X)) (PRED (CADR X))) (if (AND (LISTP PRED) (MEMB (CAR
PRED) (QUOTE (QUOTE FUNCTION)))) then (SETQ PRED (LIST (CADR PRED) VAR))) (RETURN (SUBPAIR (QUOTE (MSG
VAR PRED)) (LIST (CONCAT "
is not a suitable value for the variable: " VAR) VAR PRED) (QUOTE (until PRED do (SETQ VAR (ERROR
VAR MSG)))))))))
(PROGN (PUTPROPS \INDEXABLE.FIXP MACRO (OPENLAMBDA (X) (AND (FIXP X) (IGEQ X 0)))) (PUTPROPS
\INDEXABLE.FIXP DMACRO (OPENLAMBDA (X) (AND (SMALLP X) (IGEQ X 0)))))
(PROGN (PUTPROPS DATATYPE.TEST DMACRO (= . \DTEST)) (PUTPROPS DATATYPE.TEST MACRO (OPENLAMBDA (X TYPE)
(COND ((NOT (TYPENAMEP X TYPE)) (ERROR X (CONCAT (QUOTE Not% of% type% TYPE)))) (T X)))))
)
)
(* * The limits of the implementation-)
(DECLARE: EVAL@COMPILE DONTCOPY
(DECLARE: EVAL@COMPILE
(RPAQ ARRAY-RANK-LIMIT (EXPT 2 7))
(RPAQ ARRAY-TOTAL-SIZE-LIMIT \MaxArrayNCells)
(RPAQ ARRAY-DIMENSION-LIMIT \MaxArrayNCells)
(CONSTANTS (ARRAY-RANK-LIMIT (EXPT 2 7)) (ARRAY-TOTAL-SIZE-LIMIT \MaxArrayNCells) (
ARRAY-DIMENSION-LIMIT \MaxArrayNCells))
)
)
(RPAQQ ARRAY-RANK-LIMIT 128)
(RPAQQ ARRAY-TOTAL-SIZE-LIMIT 65533)
(RPAQQ ARRAY-DIMENSION-LIMIT 65533)
(* * an encapsulation of type specific operations)
(DECLARE: EVAL@COMPILE DONTCOPY
(RPAQQ CMLARRAYTYPES (\AT.XPOINTER \AT.POINTER \AT.DOUBLEPOINTER \AT.BIT \AT.BYTE \AT.SMALLPOSP
\AT.FIXP \AT.FLOATP \AT.STRING-CHAR))
(DECLARE: EVAL@COMPILE
(RPAQQ \AT.XPOINTER 0)
(RPAQQ \AT.POINTER 1)
(RPAQQ \AT.DOUBLEPOINTER 2)
(RPAQQ \AT.BIT 3)
(RPAQQ \AT.BYTE 4)
(RPAQQ \AT.SMALLPOSP 5)
(RPAQQ \AT.FIXP 6)
(RPAQQ \AT.FLOATP 7)
(RPAQQ \AT.STRING-CHAR 8)
(CONSTANTS \AT.XPOINTER \AT.POINTER \AT.DOUBLEPOINTER \AT.BIT \AT.BYTE \AT.SMALLPOSP \AT.FIXP
\AT.FLOATP \AT.STRING-CHAR)
)
[DECLARE: EVAL@COMPILE
(ACCESSFNS CML.TYPE.ENTRY ((TYPE.NAME (CAR DATUM)) (ACCESSOR (CADR DATUM)) (SETTOR (CADDR DATUM)) (
BITS.PER.ELEMENT (CADDDR DATUM)) (BITS.PER.ADDRESS.UNIT (CAR (CDDDDR DATUM))) (GC.TYPE (CADR (CDDDDR
DATUM))) (DEFAULT.VALUE (CADDR (CDDDDR DATUM))) (TYPE.TEST (CADDDR (CDDDDR DATUM)))) (* * TYPE.NAME
BITS.PER.ELEMENT BITS.PER.ADDRESS.UNIT GC.TYPE are assumed to be expressions. TYPE.TEST is assumed to
be a function which when applied returns T if the applied to object is of the type.))
]
(DECLARE: EVAL@COMPILE
(RPAQQ CMLARRAY.TYPE.TABLE ((\AT.XPOINTER \GETBASEPTR \PUTBASEPTR BITSPERCELL BITSPERWORD T NIL (
LAMBDA (OBJECT) T)) (\AT.DOUBLEPOINTER \GETBASEPTR \RPLPTR (LLSH BITSPERCELL 1) BITSPERWORD T NIL (
LAMBDA (OBJECT) T)) (\AT.POINTER \GETBASEPTR \RPLPTR BITSPERCELL BITSPERWORD T NIL (LAMBDA (OBJECT) T)
) (\AT.SMALLPOSP \GETBASE \PUTBASE BITSPERWORD BITSPERWORD NIL 0 (LAMBDA (OBJECT) (NOT (NULL (
SMALLPOSP OBJECT))))) (\AT.BYTE \GETBASEBYTE \PUTBASEBYTE BITSPERBYTE BITSPERBYTE NIL 0 (LAMBDA (
OBJECT) (AND (SMALLPOSP OBJECT) (ILESSP OBJECT (LLSH 1 BITSPERBYTE))))) (\AT.BIT \GETBASEBIT
\PUTBASEBIT 1 1 NIL 0 (LAMBDA (OBJECT) (AND (SMALLPOSP OBJECT) (ILEQ OBJECT 1)))) (\AT.FIXP
\GETBASEFIXP \PUTBASEFIXP BITSPERCELL BITSPERWORD NIL 0 (LAMBDA (OBJECT) (NOT (NULL (FIXP OBJECT)))))
(\AT.FLOATP \GETBASEFLOATP \PUTBASEFLOATP BITSPERCELL BITSPERWORD NIL 0.0 (LAMBDA (OBJECT) (NOT (NULL
(FLOATP OBJECT))))) (\AT.STRING-CHAR \GETBASESTRING-CHAR \PUTBASESTRING-CHAR BITSPERWORD BITSPERWORD
NIL 32 CHAR-INT)))
(RPAQQ CML.SETTOR.TO.TYPE.ALIST ((XASET . \AT.XPOINTER) (PASET . \AT.POINTER) (8ASET . \AT.BYTE) (
16ASET . \AT.SMALLPOSP) (1ASET . \AT.BIT) (NASET . \AT.FIXP) (LASET . \AT.FLOATP)))
(RPAQQ CML.ACCESSOR.TO.TYPE.ALIST ((XAREF . \AT.XPOINTER) (PAREF . \AT.POINTER) (8AREF . \AT.BYTE) (
16AREF . \AT.SMALLPOSP) (1AREF . \AT.BIT) (NAREF . \AT.FIXP) (LAREF . \AT.FLOATP)))
(CONSTANTS CMLARRAY.TYPE.TABLE CML.SETTOR.TO.TYPE.ALIST CML.ACCESSOR.TO.TYPE.ALIST)
)
(DECLARE: EVAL@COMPILE
(DEFMACRO \CML.TYPEP (TYPE.NUMBER OBJECT) (* raf "15-Jul-85 17:17") (* * Test if an element is of the
given array element type) (BQUOTE (SELECTC , TYPE.NUMBER (\AT.STRING-CHAR (STRING-CHAR-P , OBJECT)) ((
LIST \AT.XPOINTER \AT.POINTER \AT.DOUBLEPOINTER) T) (\AT.BIT (AND (SMALLPOSP , OBJECT) (ILEQ , OBJECT
1))) (\AT.BYTE (AND (SMALLPOSP , OBJECT) (ILESSP , OBJECT (LLSH 1 BITSPERBYTE)))) (\AT.SMALLPOSP (NOT
(NULL (SMALLPOSP , OBJECT)))) (\AT.FIXP (NOT (NULL (FIXP , OBJECT)))) (\AT.FLOATP (NOT (NULL (FLOATP ,
OBJECT)))) (SHOULDNT))))
(DEFMACRO \CML.TYPED.GET (TYPE BASE OFFSET) (LET ((TYPE.NUMBER (CONSTANTEXPRESSIONP TYPE))) (if
TYPE.NUMBER then (LET* ((ENTRY (\CML.GET.TYPE.ENTRY (CAR TYPE.NUMBER))) (ACCESSOR (ffetch (
CML.TYPE.ENTRY ACCESSOR) of ENTRY))) (BQUOTE (, ACCESSOR , BASE , (\CML.OFFSET.EXPANDER ENTRY OFFSET))
)) else (BQUOTE (LET ((\base , BASE) (\offset , OFFSET)) (SELECTQ , TYPE ., (APPEND (for ENTRY in
CMLARRAY.TYPE.TABLE collect (LET ((ENTRY.NUM (EVAL (ffetch (CML.TYPE.ENTRY TYPE.NAME) of ENTRY)))) (
BQUOTE (, ENTRY.NUM , (EXPANDMACRO (BQUOTE (\CML.TYPED.GET , ENTRY.NUM \base \offset)) T))))) (BQUOTE
((SHOULDNT))))))))))
(DEFMACRO \CML.TYPED.PUT (TYPE BASE OFFSET VALUE) (LET ((TYPE.NUMBER (CONSTANTEXPRESSIONP TYPE))) (if
TYPE.NUMBER then (LET* ((ENTRY (\CML.GET.TYPE.ENTRY (CAR TYPE.NUMBER))) (SETTOR (ffetch (
CML.TYPE.ENTRY SETTOR) of ENTRY))) (BQUOTE (, SETTOR , BASE , (\CML.OFFSET.EXPANDER ENTRY OFFSET) ,
VALUE))) else (BQUOTE (LET ((\base , BASE) (\offset , OFFSET) (\value , VALUE)) (SELECTQ , TYPE ., (
APPEND (for ENTRY in CMLARRAY.TYPE.TABLE collect (LET ((ENTRY.NUM (EVAL (ffetch (CML.TYPE.ENTRY
TYPE.NAME) of ENTRY)))) (BQUOTE (, ENTRY.NUM , (EXPANDMACRO (BQUOTE (\CML.TYPED.PUT , ENTRY.NUM \base
\offset \value)) T))))) (BQUOTE ((SHOULDNT))))))))))
(DEFMACRO \CML.BITS.PER.ELEMENT (TYPE) (LET ((TYPE.NUMBER (CONSTANTEXPRESSIONP TYPE))) (if TYPE.NUMBER
then (EVAL (ffetch (CML.TYPE.ENTRY BITS.PER.ELEMENT) of (\CML.GET.TYPE.ENTRY (CAR TYPE.NUMBER))))
else (BQUOTE (SELECTQ , TYPE ., (APPEND (for ENTRY in CMLARRAY.TYPE.TABLE collect (LET ((ENTRY.NUM (
EVAL (ffetch (CML.TYPE.ENTRY TYPE.NAME) of ENTRY)))) (BQUOTE (, ENTRY.NUM , (EXPANDMACRO (BQUOTE (
\CML.BITS.PER.ELEMENT , ENTRY.NUM)) T))))) (BQUOTE ((SHOULDNT)))))))))
(DEFMACRO \CML.ELEMENT.GC.TYPE (TYPE) (LET ((TYPE.NUMBER (CONSTANTEXPRESSIONP TYPE))) (if TYPE.NUMBER
then (EVAL (ffetch (CML.TYPE.ENTRY GC.TYPE) of (\CML.GET.TYPE.ENTRY (CAR TYPE.NUMBER)))) else (BQUOTE
(SELECTQ , TYPE ., (APPEND (for ENTRY in CMLARRAY.TYPE.TABLE collect (LET ((ENTRY.NUM (EVAL (ffetch (
CML.TYPE.ENTRY TYPE.NAME) of ENTRY)))) (BQUOTE (, ENTRY.NUM , (EXPANDMACRO (BQUOTE (
\CML.ELEMENT.GC.TYPE , ENTRY.NUM)) T))))) (BQUOTE ((SHOULDNT)))))))))
(DEFMACRO \CML.TYPE.DEFAULT.VALUE (TYPE) (LET ((TYPE.NUMBER (CONSTANTEXPRESSIONP TYPE))) (if
TYPE.NUMBER then (EVAL (ffetch (CML.TYPE.ENTRY DEFAULT.VALUE) of (\CML.GET.TYPE.ENTRY (CAR TYPE.NUMBER
)))) else (BQUOTE (SELECTQ , TYPE ., (APPEND (for ENTRY in CMLARRAY.TYPE.TABLE collect (LET ((
ENTRY.NUM (EVAL (ffetch (CML.TYPE.ENTRY TYPE.NAME) of ENTRY)))) (BQUOTE (, ENTRY.NUM , (EXPANDMACRO (
BQUOTE (\CML.TYPE.DEFAULT.VALUE , ENTRY.NUM)) T))))) (BQUOTE ((SHOULDNT)))))))))
(DEFMACRO \CML.UNBOXED.TYPE.P (TYPE) (LET ((TYPE.NUMBER (CONSTANTEXPRESSIONP TYPE))) (if TYPE.NUMBER
then (IEQP UNBOXEDBLOCK.GCT (EXPANDMACRO (BQUOTE (\CML.ELEMENT.GC.TYPE , (CAR TYPE.NUMBER))) T)) else
(BQUOTE (IEQP UNBOXEDBLOCK.GCT , (EXPANDMACRO (BQUOTE (\CML.ELEMENT.GC.TYPE , TYPE)) T))))))
(DEFMACRO \GETBASESTRING-CHAR (PTR DISP) (BQUOTE (INT-CHAR (\GETBASE (\, PTR) (\, DISP)))))
(DEFMACRO \PUTBASESTRING-CHAR (PTR DISP CHAR) (BQUOTE (\PUTBASE (\, PTR) (\, DISP) (CHAR-INT (\, CHAR)
))))
)
)
(DECLARE: EVAL@COMPILE
(DEFMACRO \CML.GET.ARRAY.BASE (ARRAY) (BQUOTE (LET ((A , ARRAY)) (if (type? ARRAY A) then (\ADDBASE (
ffetch (ARRAY BASE) of , ARRAY) (ffetch (ARRAY BASE.OFFSET) of , ARRAY)) elseif (type? ARRAYP A) then
(\ADDBASE (ffetch (ARRAYP BASE) of A) (ffetch (ARRAYP OFFST) of A)) elseif (type? STRINGP A) then (
\ADDBASE (ffetch (STRINGP BASE) of A) (ffetch (STRINGP OFFST) of A)) elseif (type? BITMAP A) then (
ffetch (BITMAP BITMAPBASE) of A) else (ERROR "Not an array (can't GET.BASE)" A)))))
)
(DEFINEQ
(\CML.GENERIC.ELEMENT.TYPE
(CL:LAMBDA (ARRAY) (* raf "16-Sep-85 16:26") (if (type? ARRAY ARRAY) then (ffetch (ARRAY ELEMENT.TYPE)
of ARRAY) elseif (type? ARRAYP ARRAY) then (\CML.ARRAYP.TYPE.TO.CML.TYPE ARRAY) elseif (type? STRINGP
ARRAY) then \AT.STRING-CHAR elseif (type? BITMAP ARRAY) then (\CML.BITMAP.TYPE.TO.CML.TYPE ARRAY)
else (ERROR "Not an array" ARRAY))))
(\CML.ARRAYP.TYPE.TO.CML.TYPE
(CL:LAMBDA (ARRAY) (* raf " 6-Sep-85 18:02") (SELECTC (ffetch (ARRAYP TYP) of ARRAY) (\ST.BYTE
\AT.BYTE) (\ST.POS16 \AT.SMALLPOSP) (\ST.INT32 \AT.FIXP) (\ST.PTR \AT.POINTER) (\ST.FLOAT \AT.FLOATP)
(\ST.BIT \AT.BIT) (\ST.PTR2 \AT.DOUBLEPOINTER) (HELP
"Element type in ARRAYP can't be converted to CMLARRAY type number"))))
(\CML.BITMAP.TYPE.TO.CML.TYPE
(CL:LAMBDA (BITMAP) (* raf " 6-Sep-85 17:13") (SELECTC (BITSPERPIXEL BITMAP) (BITSPERBYTE \AT.BYTE) (1
\AT.BIT) (HELP "Element type in BITMAP can't be converted to CMLARRAY type number"))))
)
(DEFINEQ
(\CML.GET.TYPE.ENTRY
(LAMBDA (TYPE) (* raf "30-Jul-85 15:19") (for X in CMLARRAY.TYPE.TABLE thereis (IEQP (EVAL (ffetch (
CML.TYPE.ENTRY TYPE.NAME) of X)) TYPE))))
(\CML.OFFSET.EXPANDER
(LAMBDA (ENTRY OFFSET.EXPR) (* raf "30-Jul-85 15:30") (LET ((BITS.PER.ELEMENT (EVAL (ffetch (
CML.TYPE.ENTRY BITS.PER.ELEMENT) of ENTRY))) (BITS.PER.ADDRESS.UNIT (EVAL (ffetch (CML.TYPE.ENTRY
BITS.PER.ADDRESS.UNIT) of ENTRY)))) (if (IEQP BITS.PER.ELEMENT BITS.PER.ADDRESS.UNIT) then OFFSET.EXPR
else (BQUOTE (LLSH , OFFSET.EXPR , (LRSH (IQUOTIENT BITS.PER.ELEMENT BITS.PER.ADDRESS.UNIT) 1)))))))
)
(* * Headers which describe the array's structure and the storage it uses, and functions for
testing them.)
[DECLARE: EVAL@COMPILE
(DATATYPE ARRAY ((ELEMENT.TYPE BITS 4) (* Type number from CMLARRAYTYPES) (ORIGIN BITS 1) (* Always
0 for ARRAY) (NIL BITS 18) (HAS.FILL.POINTER FLAG) (ADJUSTABLE.P FLAG) (* Can ADJUST.ARRAY munge it?)
(RANK BITS 7) (TOTAL.SIZE BITS 32) (BASE POINTER) (* Actual storage regardless of DISPLACED.TO chain)
(DIMENSIONS POINTER) (MARGINS POINTER) (* Index multiply by table lookup) (BASE.OFFSET BITS 32) (*
Actual storage offset regardless of DISPLACED.INDEX.OFFSET chain) (FILL.POINTER BITS 32) (* For
variable size vectors) (DISPLACED.TO POINTER) (* First in chain of content sharing arrays) (
DISPLACED.INDEX.OFFSET BITS 32) (* Offset for references in the first of the chain) (* * Used to
update cached info in BASE and BASE.OFFSET) (DISPLACEE.START FULLXPOINTER) (DISPLACEE.NEXT
FULLXPOINTER)))
]
(/DECLAREDATATYPE (QUOTE ARRAY) (QUOTE ((BITS 4) (BITS 1) (BITS 18) FLAG FLAG (BITS 7) (BITS 32)
POINTER POINTER POINTER (BITS 32) (BITS 32) POINTER (BITS 32) FULLXPOINTER FULLXPOINTER)) (QUOTE ((
ARRAY 0 (BITS . 3)) (ARRAY 0 (BITS . 64)) (ARRAY 0 (LONGBITS . 225)) (ARRAY 0 (FLAGBITS . 80)) (ARRAY
0 (FLAGBITS . 96)) (ARRAY 0 (BITS . 118)) (ARRAY 2 (LONGBITS . 15)) (ARRAY 4 POINTER) (ARRAY 6 POINTER
) (ARRAY 8 POINTER) (ARRAY 10 (LONGBITS . 15)) (ARRAY 12 (LONGBITS . 15)) (ARRAY 14 POINTER) (ARRAY 16
(LONGBITS . 15)) (ARRAY 18 FULLXPOINTER) (ARRAY 20 FULLXPOINTER))) (QUOTE 22))
(DEFINEQ
(CL:ARRAYP
(CL:LAMBDA (ARRAY) (* raf "26-Sep-85 00:29") (OR (type? ARRAY ARRAY) (type? ARRAYP ARRAY) (type?
BITMAP ARRAY) (type? STRINGP ARRAY))))
(VECTORP
(CL:LAMBDA (VECTOR) (* raf "16-Sep-85 16:16") (OR (type? ARRAYP VECTOR) (type? STRINGP VECTOR) (AND (
type? ARRAY VECTOR) (IEQP 1 (ffetch (ARRAY RANK) of VECTOR))))))
)
(DEFINEQ
(\ARRAY.DIMENSIONS.MATCH
(LAMBDA (DIMS VAL) (if (NULL DIMS) then (NULL VAL) elseif (NULL VAL) then NIL else (AND (OR (EQL (CAR
DIMS) (CAR VAL)) (EQ (CAR VAL) (QUOTE *))) (\ARRAY.DIMENSIONS.MATCH (CDR DIMS) (CDR VAL))))))
)
(DECLARE: EVAL@COMPILE DONTCOPY
(DECLARE: EVAL@COMPILE
(DEFMACRO \CML.GENERIC.FETCH (FROM FIELD.NAME) (BQUOTE (if (type? ARRAY , FROM) then (ffetch (ARRAY ,
FIELD.NAME) of , FROM) else (ERROR "Not an array" , FROM))))
(DEFMACRO \CML.GETMARGIN (MARGIN INDEX) (BQUOTE (\GETBASEPTR , MARGIN (LLSH , INDEX 1))))
)
)
(DECLARE: EVAL@COMPILE
(PUTPROPS DATATYPE.ARRAY MACRO (LAMBDA (OBJECT) (if (TYPE?.ARRAY OBJECT) then OBJECT else (ERROR
"Not an array" OBJECT))))
(PUTPROPS TYPE?.ARRAY MACRO (LAMBDA (OBJECT) (type? ARRAY OBJECT)))
)
(DECLARE: DOEVAL@COMPILE DONTCOPY
(LOCALVARS . T)
)
(* * MAKE-ARRAY ADJUST-ARRAY and friends)
(DEFINEQ
(\DISPLACEARRAY
(LAMBDA (ARRAY DISPLACEDTO DISPLACEDINDEXOFFSET) (* raf " 9-Sep-85 03:02") (* * Assumes that only an
ARRAY can have displaced contents) (* * Check for compatible types) (if (NOT (IEQP (ffetch (ARRAY
ELEMENT.TYPE) of ARRAY) (\CML.GENERIC.ELEMENT.TYPE DISPLACEDTO))) then (ERROR
"DISPLACED-TO array must have same element type" NIL)) (* * Check for compatible sizes) (if (IGREATERP
(IPLUS (ffetch (ARRAY TOTAL.SIZE) of ARRAY) DISPLACEDINDEXOFFSET) (ARRAY-TOTAL-SIZE DISPLACEDTO))
then (ERROR "Displacing into an array that's too small")) (* * Setup the displacement) (
\CML.UNLINK.ARRAY ARRAY) (\CML.LINK.ARRAY ARRAY DISPLACEDTO DISPLACEDINDEXOFFSET) (\CML.DCHAIN.UPDATE
ARRAY)))
(\CML.DCHAIN.UPDATE
(LAMBDA (ARRAY) (* raf "18-Jul-85 14:23") (* * Set the array's base and base offset, then set all its
displacees appropriately) (LET ((ANCHOR (ffetch (ARRAY BASE) of ARRAY)) (ANCHOROFFSET (ffetch (ARRAY
BASE.OFFSET) of ARRAY))) (for I first (SETQ I (ffetch (ARRAY DISPLACEE.START) of ARRAY)) until (NULL I
) do (freplace (ARRAY BASE) of I with ANCHOR) (freplace (ARRAY BASE.OFFSET) of I with (IPLUS (ffetch (
ARRAY DISPLACED.INDEX.OFFSET) of I) ANCHOROFFSET)) (\CML.DCHAIN.UPDATE I) (SETQ I (ffetch (ARRAY
DISPLACEE.NEXT) of I))))))
(\CML.LINK.ARRAY
(LAMBDA (ARRAY DISPLACEDTO DISPLACEDINDEXOFFSET) (* raf " 6-Sep-85 20:38") (* * Assumes that ARRAY is
the only kind of adjustable array - One which would need to propogate adjustments to arrays displaced
to it) (* * If new displaced to array is adjustable, then Link to new displacement chain) (if (
ADJUSTABLE-ARRAY-P DISPLACEDTO) then (freplace (ARRAY DISPLACEE.NEXT) of ARRAY with (ffetch (ARRAY
DISPLACEE.START) of DISPLACEDTO)) (freplace (ARRAY DISPLACEE.START) of DISPLACEDTO with ARRAY)) (* *
Setup basic displacement fields) (freplace (ARRAY DISPLACED.TO) of ARRAY with DISPLACEDTO) (freplace (
ARRAY DISPLACED.INDEX.OFFSET) of ARRAY with DISPLACEDINDEXOFFSET) (* * If we're displaced to a non-CML
type array these fields are blank and special handling is called for) (if (TYPE?.ARRAY DISPLACEDTO)
then (freplace (ARRAY BASE) of ARRAY with (ffetch (ARRAY BASE) of DISPLACEDTO)) (freplace (ARRAY
BASE.OFFSET) of ARRAY with (IPLUS DISPLACEDINDEXOFFSET (ffetch (ARRAY BASE.OFFSET) of DISPLACEDTO)))
else (freplace (ARRAY BASE) of ARRAY with NIL) (freplace (ARRAY BASE.OFFSET) of ARRAY with 0))))
(\CML.UNLINK.ARRAY
(LAMBDA (ARRAY) (* raf " 6-Sep-85 20:38") (* * If array is displaced and old displaced to array is
adjustable, then unlink from old displacement chain) (LET ((NEXTDOWN (ffetch (ARRAY DISPLACED.TO) of
ARRAY)) (NEXTUP (ffetch (ARRAY DISPLACEE.NEXT) of ARRAY))) (if (AND NEXTDOWN (ADJUSTABLE-ARRAY-P
NEXTDOWN)) then (* We're the first one in the chain) (if (EQ ARRAY (ffetch (ARRAY DISPLACEE.START) of
NEXTDOWN)) then (freplace (ARRAY DISPLACEE.START) of NEXTDOWN with NEXTUP) else (* Chase through chain
of references) (for I first (SETQ I (ffetch (ARRAY DISPLACEE.START) of NEXTDOWN)) until (EQ ARRAY (
ffetch (ARRAY DISPLACEE.NEXT) of I)) do (if (NULL (SETQ I (ffetch (ARRAY DISPLACEE.NEXT) of I))) then
(ERROR "Couldn't find array in displacee chain")) finally (freplace (ARRAY DISPLACEE.NEXT) of I with (
ffetch (ARRAY DISPLACEE.NEXT) of (ffetch (ARRAY DISPLACEE.NEXT) of I)))))))))
)
(DEFINEQ
(SLOW.COPY.ELEMENT.INTO.ARRAY
(CL:LAMBDA (ELEMENT ARRAY) (* raf " 5-Sep-85 17:50") (* * First, this works by creating a list of
coordinates. It is decremented through all positions from left to right resetting the appropriate
positions at the end of each row. When the coordinates reach all zeroes we're through.) (* * Second,
this doesn't work yet) (LET* ((DIMENSIONS (for I in (ARRAY-DIMENSIONS ARRAY) collect (SUB1 I))) (
ARRAY.RANK (ARRAY-RANK ARRAY)) (TOP-RANK 0) (RANK 0) (POSITION (COPY-LIST DIMENSIONS))) (until (for I
in POSITION always (IEQ I 0)) do (CL:APPLY (FUNCTION ASET) ELEMENT ARRAY POSITION) (LET ((COORD.TAIL (
NTH POSITION (ADD1 RANK)))) (if (IEQ 0 (CAR COORD.TAIL)) then (* Next coord) (if (ILESSP RANK TOP-RANK
) then (* Next rank) (for I from 1 to (ADD1 RANK) do (RPLACA (NTH POSITION I) (CAR (NTH DIMENSIONS I))
)) (add RANK 1) elseif (ILESSP TOP-RANK ARRAY.RANK) then (* Reached top rank) (for I from 1 to (ADD1
TOP-RANK) do (RPLACA (NTH POSITION I) (CAR (NTH DIMENSIONS I)))) (add TOP-RANK 1) (SETQ RANK 0) else (
* Reached final coord)) else (* Just decrement the current coord) (RPLACA COORD.TAIL (SUB1 (CAR
COORD.TAIL)))))))))
(\COPYARRAY
(LAMBDA (OLD.DIMS OLD OLD.MARGIN NEW.DIMS NEW.BASE NEW.MARGIN INITIAL.ELEMENT OOB.LEAVES.P) (* raf
"15-Oct-85 22:33") (* * Copies OLD to NEW.BASE by coordinates using the side vectors) (LET ((MIN.AXIS
(IMIN (SUB1 (CAR OLD.DIMS)) (SUB1 (CAR NEW.DIMS)))) (MAX.AXIS (SUB1 (CAR NEW.DIMS)))) (if (NULL (CDR
OLD.DIMS)) then (* We've reached the leaves) (LET ((TYPE# (ffetch (ARRAY ELEMENT.TYPE) of OLD))) (if
OOB.LEAVES.P then (SETQ MIN.AXIS -1) else (LET ((OLD.BASE (ffetch (ARRAY BASE) of OLD))) (for COORD
from 0 to MIN.AXIS do (* Copy old leaves (if any)) (\CML.TYPED.PUT TYPE# NEW.BASE (IPLUS COORD
NEW.MARGIN) (\CML.TYPED.GET TYPE# OLD.BASE (IPLUS COORD OLD.MARGIN)))))) (if (IGREATERP MAX.AXIS
MIN.AXIS) then (for COORD from (ADD1 MIN.AXIS) to MAX.AXIS do (* Fill the out of bounds positions with
the initial element) (\CML.TYPED.PUT TYPE# NEW.BASE (IPLUS COORD NEW.MARGIN) INITIAL.ELEMENT)))) else
(if OOB.LEAVES.P then (SETQ MIN.AXIS -1) else (for EDGE from 0 to MIN.AXIS do (* Iterate along this
edge) (\COPYARRAY (CDR OLD.DIMS) OLD (\CML.GETMARGIN OLD.MARGIN EDGE) (CDR NEW.DIMS) NEW.BASE (
\CML.GETMARGIN NEW.MARGIN EDGE) INITIAL.ELEMENT NIL)) (if (IGREATERP MAX.AXIS MIN.AXIS) then (for EDGE
from (ADD1 MIN.AXIS) to MAX.AXIS do (* Fill the out of bounds positions with the initial element) (
\COPYARRAY (CDR OLD.DIMS) OLD (\CML.GETMARGIN OLD.MARGIN EDGE) (CDR NEW.DIMS) NEW.BASE (\CML.GETMARGIN
NEW.MARGIN EDGE) INITIAL.ELEMENT T))))))))
(\CML.ELEMENT.INITIALIZE
(LAMBDA (ARRAY INITIAL.ELEMENT) (* raf "15-Oct-85 23:27") (* * Initialize an array with a value) (
DATATYPE.ARRAY ARRAY) (LET ((TYPE (\CML.GENERIC.FETCH ARRAY ELEMENT.TYPE)) (BASE (\CML.GENERIC.FETCH
ARRAY BASE))) (if (NOT (\CML.TYPEP TYPE INITIAL.ELEMENT)) then (ERRORX (LIST 32 INITIAL.ELEMENT))) (*
* ! Could be speeded up for unboxed types using propagating \BLT) (for I from 0 to (SUB1 (
\CML.GENERIC.FETCH ARRAY TOTAL.SIZE)) do (\CML.TYPED.PUT TYPE BASE I INITIAL.ELEMENT)))))
(\CML.CONTENT.INITIALIZE
(LAMBDA (ARRAY INITIAL.CONTENTS) (* raf "19-Sep-85 13:28") (* * Can't do sequences, but this handles
putting other arrays and list structure in) (DATATYPE.ARRAY ARRAY) (if (if (OR (TYPE?.ARRAY
INITIAL.CONTENTS) (type? BITMAP INITIAL.CONTENTS)) then (*) (NOT (EQUAL (ARRAY-DIMENSIONS ARRAY) (
ARRAY-DIMENSIONS INITIAL.CONTENTS))) elseif (LISTP INITIAL.CONTENTS) then (* Check to see if nested
list structures have the same dimensionality as the array we are creating) (\CML.ICP.CHECK (
ARRAY-DIMENSIONS ARRAY) INITIAL.CONTENTS) else (* Not any kind of nested structure) T) then (ERROR (
QUOTE "Dimensionality mismatch for INITIAL-CONTENTS") INITIAL.CONTENTS)) (if (type? BITMAP
INITIAL.CONTENTS) then (*) (COPY.BITMAP.TO.ARRAY INITIAL.CONTENTS ARRAY) elseif (type? STRINGP
INITIAL.CONTENTS) then (*) (COPY.STRING.TO.ARRAY INITIAL.CONTENTS ARRAY) elseif (TYPE?.ARRAY
INITIAL.CONTENTS) then (* fill the new array with another array) (\FLAT.COPY.ARRAY.TO.ARRAY
INITIAL.CONTENTS ARRAY) elseif (LISTP INITIAL.CONTENTS) then (* Flatten the contents list and fill the
new array with it) (FRPTQ (SUB1 (ARRAY-RANK ARRAY)) (SETQ INITIAL.CONTENTS (APPLY (FUNCTION APPEND)
INITIAL.CONTENTS))) (\FLAT.COPY.LIST.TO.ARRAY INITIAL.CONTENTS ARRAY) else (ERROR
"Bad type of object for INITIAL-CONTENTS" INITIAL.CONTENTS))))
(\FLAT.COPY.ARRAY.TO.ARRAY
(LAMBDA (FROM TO) (* raf "19-Sep-85 13:36") (* * Assumes it is given arrays of same size.) (LET ((
FROM.TYPE (\CML.GENERIC.FETCH FROM ELEMENT.TYPE)) (FROM.BASE (\CML.GENERIC.FETCH FROM BASE)) (TO.TYPE
(\CML.GENERIC.FETCH TO ELEMENT.TYPE)) (TO.BASE (\CML.GENERIC.FETCH TO BASE))) (if (NOT (IEQP FROM.TYPE
TO.TYPE)) then (ERROR "Can't initialize array with another array of different type" NIL)) (for I from
0 to (SUB1 (\CML.GENERIC.FETCH FROM TOTAL.SIZE)) do (\CML.TYPED.PUT TO.TYPE TO.BASE I (\CML.TYPED.GET
FROM.TYPE FROM.BASE I))))))
(\FLAT.COPY.LIST.TO.ARRAY
(LAMBDA (LIST ARRAY) (* raf "19-Sep-85 13:33") (* * Assumes it is given an array and a list of
appropriate (and same) length) (LET ((BASE (\CML.GENERIC.FETCH ARRAY BASE)) (TYPE (\CML.GENERIC.FETCH
ARRAY ELEMENT.TYPE))) (for I from 0 to (SUB1 (\CML.GENERIC.FETCH ARRAY TOTAL.SIZE)) do (\CML.TYPED.PUT
TYPE BASE I (CAR LIST)) (pop LIST)))))
(COPY.LIST.TO.STRING
(LAMBDA (LIST STRING) (* raf "16-Oct-85 00:43") (if (IEQP (NCHARS STRING) (LENGTH LIST)) then (bind (I
← 0) for X in LIST do (RPLCHARCODE STRING (add I 1) (CHAR-INT X))) else (ERROR "Length mismatch" (
LIST LIST STRING)))))
(COPY.STRING-CHAR.TO.SIMPLE-STRING
(CL:LAMBDA (STRING-CHAR SIMPLE-STRING) (* raf "28-Aug-85 15:26") (for I from 0 to (CL:LENGTH
SIMPLE-STRING) do (SCHARSET STRING-CHAR SIMPLE-STRING I))))
(COPY.ARRAY.TO.STRING
(LAMBDA (ARRAY STRING) (* raf "16-Oct-85 14:57") (LET ((TOTAL.SIZE (ARRAY-TOTAL-SIZE ARRAY))) (if (NOT
(IEQ 1 (ARRAY-RANK ARRAY))) then (ERROR "Rank mismatch" (LIST ARRAY STRING))) (if (NOT (IEQ
\AT.STRING-CHAR (\CML.GENERIC.ELEMENT.TYPE ARRAY))) then (ERROR "Type mismatch" (LIST ARRAY STRING)))
(if (NOT (IEQ TOTAL.SIZE (NCHARS STRING))) then (ERROR "Size mismatch" (LIST ARRAY STRING))) (for I
from 0 to (SUB1 TOTAL.SIZE) do (RPLCHARCODE STRING (ADD1 I) (CHAR-INT (AREF ARRAY I)))))))
(COPY.BITMAP.TO.ARRAY
(CL:LAMBDA (BITMAP ARRAY) (* raf "25-Sep-85 22:14") (if (NOT (EQUAL (ARRAY-DIMENSIONS ARRAY) (
ARRAY-DIMENSIONS BITMAP))) then (ERROR "INITIAL-CONTENTS dimensions don't match array" BITMAP)) (if (
NOT (IEQ (BITSPERPIXEL BITMAP) (\CML.BITS.PER.ELEMENT ARRAY))) then (ERROR
"INITIAL-CONTENTS wrong type for array" BITMAP)) (for J from 0 to (SUB1 (BITMAPHEIGHT BITMAP)) do (for
I from 0 to (SUB1 (BITMAPWIDTH BITMAP)) do (ASET (BITMAPBIT BITMAP I J) ARRAY I J)))))
(COPY.STRING.TO.ARRAY
(CL:LAMBDA (STRING ARRAY) (* raf "16-Sep-85 18:13") (if (NOT (EQUAL (ARRAY-DIMENSIONS ARRAY) (
ARRAY-DIMENSIONS STRING))) then (ERROR "INITIAL-CONTENTS dimensions don't match array" STRING)) (if (
NOT (IEQ \AT.STRING-CHAR (\CML.GENERIC.FETCH ARRAY ELEMENT.TYPE))) then (ERROR
"INITIAL-CONTENTS wrong type for array" STRING)) (for I from 0 to (NCHARS STRING) bind (BASE ← (
\CML.GENERIC.FETCH ARRAY BASE)) do (\CML.TYPED.PUT \AT.STRING-CHAR BASE I (SCHAR STRING I)))))
(COPY.LIST.TO.BITMAP
(CL:LAMBDA (LIST BITMAP) (* raf "25-Sep-85 22:15") (if (CDDR LIST) then (ERROR
"Bad dimensions for LIST to initialize BITMAP" (LENGTH LIST))) (LET ((FLAT.LIST (TCONC NIL (pop LIST))
)) (for I from 0 to (BITMAPHEIGHT BITMAP) do (TCONC FLAT.LIST (pop LIST))) (SETQ FLAT.LIST (CAR
FLAT.LIST)) (for J from 0 to (SUB1 (BITMAPHEIGHT BITMAP)) do (for I from 0 to (SUB1 (BITMAPWIDTH
BITMAP)) do (BITMAPBIT BITMAP I J (pop FLAT.LIST)))))))
(COPY.ARRAY.TO.BITMAP
(CL:LAMBDA (ARRAY BITMAP) (* raf "25-Sep-85 22:15") (* * Test suitability of the array) (if (NOT (IEQ
(BITSPERPIXEL BITMAP) (\CML.BITS.PER.ELEMENT (\CML.GENERIC.ELEMENT.TYPE ARRAY)))) then (ERROR
"Bad array element type to initialize BITMAP" ARRAY)) (if (NOT (EQUAL (ARRAY-DIMENSIONS ARRAY) (
ARRAY-DIMENSIONS BITMAP))) then (ERROR "Mismatched dimensions for INITIAL-CONTENTS" ARRAY)) (* * Copy
the elements) (for J from 0 to (SUB1 (BITMAPHEIGHT BITMAP)) do (for I from 0 to (SUB1 (BITMAPWIDTH
BITMAP)) do (BITMAPBIT BITMAP I J (AREF ARRAY I J))))))
(COPY.ELEMENT.TO.BITMAP
(CL:LAMBDA (ELEMENT BITMAP) (* raf "25-Sep-85 22:16") (for J from 0 to (SUB1 (BITMAPHEIGHT BITMAP)) do
(for I from 0 to (SUB1 (BITMAPWIDTH BITMAP)) do (BITMAPBIT BITMAP I J ELEMENT)))))
(\CML.MAKE.STORAGE
(LAMBDA (#ELTS TYPE# INIT.ON.PAGE ALIGNMENT) (* raf "17-Sep-85 00:49") (LET ((#CELLS (FOLDHI (ADD1 (
ITIMES #ELTS (\CML.BITS.PER.ELEMENT TYPE#))) BITSPERCELL))) (if (ZEROP #ELTS) then NIL elseif (ILEQ
#ELTS (CONSTANT \MaxArrayNCells)) then (\ALLOCBLOCK #CELLS (\CML.ELEMENT.GC.TYPE TYPE#) INIT.ON.PAGE
ALIGNMENT) else (if ARRAYWARNINGFLG then (PROMPTPRINT
"Warning: allocating fixed pages for large array")) (\ALLOCPAGEBLOCK (FOLDHI #CELLS CELLSPERPAGE))))))
)
(DEFINEQ
(\CML.MS.ELEMENT.TYPE
(LAMBDA (ELEMENTTYPE) (* raf " 5-Aug-85 17:09") (* * Returns the most specific (array) element type
NUMBER which will hold a given type.) (* * Note: This function accepts only a limited subset of the
CommonLISP type specifiers: T FLOAT SINGLE-FLOAT FIXNUM BIT (MOD n) (UNSIGNED-BYTE n) (INTEGER low
high) XPOINTER DOUBLE-POINTER) (SELECTQ ELEMENTTYPE (STRING-CHAR \AT.STRING-CHAR) (T \AT.POINTER) (
FIXNUM \AT.FIXP) (BIT \AT.BIT) (XPOINTER \AT.XPOINTER) ((SINGLE-FLOAT FLOAT) \AT.FLOATP) (if (AND (EQ
(CAR (LISTP ELEMENTTYPE)) (QUOTE MOD)) (NULL (CDDR ELEMENTTYPE)) (FIXP (CADR ELEMENTTYPE)) (ILESSP 1 (
CADR ELEMENTTYPE))) then (* (MOD n) is converted to the next higher enclosing type.) (LET ((MOD# (CADR
ELEMENTTYPE))) (if (IEQP MOD# 2) then \AT.BIT elseif (ILEQ MOD# (LLSH 1 BITSPERBYTE)) then \AT.BYTE
elseif (ILEQ MOD# (LLSH 1 BITSPERWORD)) then \AT.SMALLPOSP elseif (ILEQ MOD# MAX.FIXP) then \AT.FIXP
else \AT.POINTER)) elseif (AND (EQ (CAR (LISTP ELEMENTTYPE)) (QUOTE UNSIGNED-BYTE)) (NULL (CDDR
ELEMENTTYPE)) (FIXP (CADR ELEMENTTYPE)) (ILESSP 0 (CADR ELEMENTTYPE))) then (* (UNSIGNED.BYTE n) is
converted to the next higher enclosing type.) (LET ((#BITS (CADR ELEMENTTYPE))) (if (IEQP #BITS 1)
then \AT.BIT elseif (ILEQ #BITS BITSPERBYTE) then \AT.BYTE elseif (ILEQ #BITS BITSPERWORD) then
\AT.SMALLPOSP elseif (ILEQ #BITS (CONSTANT (INTEGERLENGTH MAX.FIXP))) then \AT.FIXP else \AT.POINTER))
elseif (AND (EQ (CAR (LISTP ELEMENTTYPE)) (QUOTE INTEGER)) (NULL (CDDDR ELEMENTTYPE)) (FIXP (CADR
ELEMENTTYPE)) (FIXP (CADDR ELEMENTTYPE)) (ILESSP (CADR ELEMENTTYPE) (CADDR ELEMENTTYPE))) then (* (
INTEGER low high)) (LET* ((LOW (CADR ELEMENTTYPE)) (HIGH (CADDR ELEMENTTYPE)) (RANGE (IDIFFERENCE HIGH
LOW))) (* Type simplification should probably be done somewhere else) (if (IEQP LOW 0) then (* (
INTEGER 0 high) => (MOD nbits)) (\CML.MS.ELEMENT.TYPE (BQUOTE (MOD , (ADD1 RANGE)))) elseif (AND (IGEQ
LOW MIN.FIXP) (ILEQ HIGH MAX.FIXP)) then (* (INTEGER >= MIN.FIXP <= MAX.FIXP) == FIXNUM) \AT.FIXP
else \AT.POINTER)) elseif (FMEMB ELEMENTTYPE (USERDATATYPES)) then \AT.POINTER else (ERROR
"Bad type specifier" ELEMENTTYPE)))))
(\CML.ILTYPE.TO.CLTYPE
(LAMBDA (TYPE) (* raf "26-Jul-85 18:35") (* * This function converts some Interlisp array and record
element type specifiers to CommonLISP type specifiers. Returns NIL if the type is bad or unknown.) (*
* There are a few types that are returned rather than converted: XPOINTER DOUBLEPOINTER) (* * Note:
some conversions return types that are much more specific than CommonLISP would use for the same
names, eg INTEGER => FIXNUM whereas in CommonLISP INTEGER => (INTEGER * *)) (SELECTQ TYPE ((XPOINTER
DOUBLEPOINTER) TYPE) ((POINTER FLAG NIL) (QUOTE T)) ((FLOATING FLOATP) (QUOTE SINGLE.FLOAT)) ((INTEGER
FIXP SIGNEDWORD) (QUOTE FIXNUM)) ((SMALLP SMALLPOSP WORD) (BQUOTE (UNSIGNED.BYTE , BITSPERWORD))) (
BYTE (BQUOTE (UNSIGNED.BYTE , BITSPERBYTE))) (if (AND (EQ (CAR (LISTP TYPE)) (QUOTE BITS)) (NULL (CDDR
TYPE)) (FIXP (CADR TYPE)) (ILESSP 0 (CADR TYPE))) then (* (BITS n)) (BQUOTE (UNSIGNED.BYTE , (CADR
TYPE))) elseif (FMEMB TYPE (USERDATATYPES)) then (* RECORD types) TYPE else NIL))))
)
(DEFINEQ
(\MARGINTO
(LAMBDA (DIML) (* raf "18-Jul-85 16:59") (if (ILESSP (FLENGTH DIML) 2) then 0 else (LET ((
THIS.ROW.BASE 0)) (DECLARE (SPECVARS THIS.ROW.BASE)) (\MARGIN.ONE.DIMENSION DIML)))))
(\MARGIN.ONE.DIMENSION
(LAMBDA (DIML) (* raf "17-Jul-85 00:21") (DECLARE (SPECVARS THIS.ROW.BASE)) (LET* ((#HYPER.ROWS (CAR
DIML)) (NEXTDIML (OR (CDR DIML) (SHOULDNT))) (LASTDIMENSIONP (NULL (CDR NEXTDIML))) (MARGINARRAY (
\ALLOCBLOCK #HYPER.ROWS T))) (* * Except for the final margining over the real baseblock, each margin
array will be going into another margin array for the next dimension.) (if LASTDIMENSIONP then (LET ((
#ELTS/ROW (CAR NEXTDIML))) (for I from 0 to (SUB1 #HYPER.ROWS) do (\RPLPTR MARGINARRAY (LLSH I 1)
THIS.ROW.BASE) (add THIS.ROW.BASE #ELTS/ROW))) else (for I from 0 to (SUB1 #HYPER.ROWS) do (\RPLPTR
MARGINARRAY (LLSH I 1) (\MARGIN.ONE.DIMENSION NEXTDIML)))) MARGINARRAY)))
)
(DEFINEQ
(\CML.ICP.CHECK
(LAMBDA (DIML L) (* JonL "22-May-84 21:01") (* Returns non-NIL iff there is a mismatch.) (if (NEQ (CAR
DIML) (LENGTH L)) else (pop DIML) (AND DIML (find LL in L suchthat (\CML.ICP.CHECK DIML LL))))))
)
(DEFINEQ
(MAKE-ARRAY
(CL:LAMBDA (DIMENSIONS &KEY (ELEMENT-TYPE T) (INITIAL-ELEMENT NIL IEP) (INITIAL-CONTENTS NIL ICP)
ADJUSTABLE FILL-POINTER (DISPLACED-TO NIL D-TO-P) DISPLACED-TO-BASE DISPLACED-INDEX-OFFSET PAGE-ALIGN
ALIGNMENT) (* raf "16-Oct-85 14:05") (LET (TYPE# (#ELTS 1) (RANK 0) BASE (BASE.OFFSET 0) DAR.TYPE#
ARRAY) (if DIMENSIONS then (if (NLISTP DIMENSIONS) then (SETQ DIMENSIONS (LIST DIMENSIONS))) (SETQ
#ELTS (CML.DIMENSIONS.LINEAR.SIZE DIMENSIONS "dimension")) (SETQ RANK (FLENGTH DIMENSIONS))) (if
D-TO-P then (if (OR IEP ICP DISPLACED-TO-BASE) then (ERROR
"DISPLACED-TO inconsistent with other options in call to MAKE-ARRAY")) (* * ! Bogus nonsense caused by
last moment confusion) (if (NOT (TYPE?.ARRAY DISPLACED-TO)) then (ERROR
"Can only DISPLACE-TO new type arrays" DISPLACED-TO)) (if (NOT (CL:ARRAYP DISPLACED-TO)) then (ERROR
"DISPLACED-TO must be an array" DISPLACED-TO)) (SETQ DAR.TYPE# (ffetch (ARRAY ELEMENT.TYPE) of
DISPLACED-TO)) (OR DISPLACED-INDEX-OFFSET (SETQ DISPLACED-INDEX-OFFSET 0)) elseif DISPLACED-TO-BASE
then (if (OR IEP ICP DISPLACED-INDEX-OFFSET D-TO-P) then (ERROR
"Inconsistent options in call to MAKE-ARRAY")) elseif DISPLACED-INDEX-OFFSET then (ERROR
"Missing displaced to array for displaced index offset" DISPLACED-INDEX-OFFSET)) (if (AND IEP ICP)
then (ERROR "Both INITIAL-ELEMENT and INITIAL-CONTENTS in call to MAKE-ARRAY")) (if FILL-POINTER then
(if (NEQ RANK 1) then (ERROR "Array must be one dimensional to have fill pointer")) (if (EQ
FILL-POINTER T) then (SETQ FILL-POINTER #ELTS) else (if (IGREATERP FILL-POINTER #ELTS) then (ERROR
"Fill pointer out of bounds" FILL-POINTER)))) (* * Standardize the element type) (SETQ TYPE# (
\CML.MS.ELEMENT.TYPE ELEMENT-TYPE)) (* * Specs ready, cases separated by type of the data structure it
is implemented by.) (if (AND (IEQ RANK 1) (IEQ TYPE# \AT.STRING-CHAR) (NOT ADJUSTABLE) (NULL
FILL-POINTER) (ILEQ (CAR DIMENSIONS) (CONSTANT \MaxArrayLen))) then (* * Make a simple-string) (SETQ
ARRAY (ALLOCSTRING #ELTS (OR (AND IEP (CHAR-INT INITIAL-ELEMENT)) 32))) (if ICP then (SETQ ICP NIL) (
if (LISTP INITIAL-CONTENTS) then (COPY.LIST.TO.STRING INITIAL-CONTENTS ARRAY) elseif (type? STRINGP
INITIAL-CONTENTS) then (RPLSTRING ARRAY 1 INITIAL-CONTENTS) elseif (OR (type? ARRAY INITIAL-CONTENTS)
(type? ARRAYP INITIAL-CONTENTS)) then (COPY.ARRAY.TO.STRING INITIAL-CONTENTS ARRAY) else (ERROR
"Bad type for INITIAL-CONTENTS" INITIAL-CONTENTS)) elseif IEP then (SETQ IEP NIL) (if (STRING-CHAR-P
INITIAL-ELEMENT) then (COPY.STRING-CHAR.TO.SIMPLE-STRING INITIAL-ELEMENT ARRAY) else (ERROR
"Bad type for INITIAL-ELEMENT" INITIAL-ELEMENT))) elseif (AND (IEQ RANK 2) (NOT ADJUSTABLE) (NULL
FILL-POINTER) (FMEMB TYPE# (CONSTANT (LIST \AT.BIT \AT.BYTE))) (ILEQ (CAR DIMENSIONS) (CONSTANT
\MaxBitMapWidth)) (ILEQ (CADR DIMENSIONS) (CONSTANT \MaxBitMapHeight)) (ILEQ (LLSH (ITIMES BITSPERWORD
(ITIMES (CAR DIMENSIONS) (CADR DIMENSIONS))) (\CML.BITS.PER.ELEMENT TYPE#)) (CONSTANT \MaxBitMapWords
))) then (* * Make a simple bitmap) (SETQ ARRAY (BITMAPCREATE (CAR DIMENSIONS) (CADR DIMENSIONS) (
\CML.BITS.PER.ELEMENT TYPE#))) (if ICP then (SETQ ICP NIL) (if (LISTP INITIAL-CONTENTS) then (
COPY.LIST.TO.BITMAP INITIAL-CONTENTS ARRAY) elseif (OR (type? ARRAY INITIAL-CONTENTS) (type? BITMAP
INITIAL-CONTENTS)) then (COPY.ARRAY.TO.BITMAP INITIAL-CONTENTS ARRAY) else (ERROR
"Bad type for INITIAL-CONTENTS" INITIAL-CONTENTS)) elseif IEP then (SETQ IEP NIL) (
COPY.ELEMENT.TO.BITMAP INITIAL-ELEMENT ARRAY)) else (* * Handle storage requirements (this should move
into implementing structure cases below)) (if (AND (NOT DISPLACED-TO-BASE) (NOT D-TO-P)) then (* * A
non-displaced array, make some new storage) (SETQ BASE (\CML.MAKE.STORAGE #ELTS TYPE# PAGE-ALIGN
ALIGNMENT)) (SETQ BASE.OFFSET 0) else (* * DISPLACED-TO-BASE User just supplied storage for us to use)
(SETQ BASE DISPLACED-TO-BASE) (SETQ BASE.OFFSET 0)) (* * Make an array) (SETQ ARRAY (create ARRAY
ORIGIN ← 0 RANK ← RANK HAS.FILL.POINTER ← FILL-POINTER TOTAL.SIZE ← #ELTS BASE ← BASE BASE.OFFSET ←
BASE.OFFSET ELEMENT.TYPE ← TYPE# MARGINS ← (\MARGINTO DIMENSIONS) DIMENSIONS ← DIMENSIONS ADJUSTABLE.P
← ADJUSTABLE FILL.POINTER ← (OR FILL-POINTER 0) DISPLACEE.START ← NIL))) (* * Initialize the storage
- These functions should only be called if ARRAY is of type? ARRAY) (if DISPLACED-TO then (
\DISPLACEARRAY ARRAY DISPLACED-TO DISPLACED-INDEX-OFFSET) elseif ICP then (\CML.CONTENT.INITIALIZE
ARRAY INITIAL-CONTENTS) elseif IEP then (\CML.ELEMENT.INITIALIZE ARRAY INITIAL-ELEMENT)) ARRAY)))
(VECTOR
(CL:LAMBDA (&REST OBJECTS) (* raf "16-Sep-85 16:19") (MAKE-ARRAY (LENGTH OBJECTS) :ELEMENT-TYPE T
:ADJUSTABLE NIL :INITIAL-CONTENTS OBJECTS)))
(ADJUST-ARRAY
(CL:LAMBDA (ARRAY DIMENSIONS &KEY (ELEMENT-TYPE T ELEMENT-TYPE-SUPPLIED) (INITIAL-ELEMENT NIL IEP)
INITIAL-CONTENTS ADJUSTABLE FILL-POINTER DISPLACED-TO DISPLACED-INDEX-OFFSET DISPLACED-TO-BASE
PAGE-ALIGN) (* raf "15-Oct-85 16:55") (* * Adjust the size of an array, or alter some of its other
parameters) (* *) (if (NOT (type? ARRAY ARRAY)) then (ERROR "Can only adjust datatype ARRAY" ARRAY)) (
if (NLISTP DIMENSIONS) then (SETQ DIMENSIONS (LIST DIMENSIONS))) (LET ((RANK 0) (#ELTS 1) PAGE-ALIGN
ALIGNMENT) (if (NOT (ADJUSTABLE-ARRAY-P ARRAY)) then (ERROR "Array is not adjustable")) (if DIMENSIONS
then (SETQ #ELTS (CML.DIMENSIONS.LINEAR.SIZE DIMENSIONS "dimension")) (SETQ RANK (FLENGTH DIMENSIONS)
) else (SETQ #ELTS 1) (SETQ RANK 0)) (if (NOT (IEQP RANK (ffetch (ARRAY RANK) of ARRAY))) then (ERROR
"Rank mismatch")) (* * Parse keyword args, test individual correctness here) (if (AND
ELEMENT-TYPE-SUPPLIED (NOT (IEQP (\CML.MS.ELEMENT.TYPE ELEMENT-TYPE) (ffetch (ARRAY ELEMENT.TYPE) of
ARRAY)))) then (* Note this does not change its type) (ERROR "Array could not be of this type"
ELEMENT-TYPE)) (if IEP then (OR (\CML.TYPEP (ffetch (ARRAY ELEMENT.TYPE) of ARRAY) INITIAL-ELEMENT) (
ERROR "Bad type for initial element" INITIAL-ELEMENT))) (if FILL-POINTER then (if (NULL (ffetch (ARRAY
HAS.FILL.POINTER) of ARRAY)) then (ERROR "Array doesn't have a fillpointer to set" ARRAY)) (if (EQ
FILL-POINTER T) then (SETQ FILL-POINTER (SUB1 #ELTS)) elseif (GEQ FILL-POINTER #ELTS) then (ERROR
"Fill pointer out of bounds" FILL-POINTER))) (if DISPLACED-TO then (if (NOT (type? ARRAY DISPLACED-TO)
) then (ERROR "DISPLACED-TO must be datatype ARRAY" DISPLACED-TO))) (* * Check for group argument
conflicts) (if (AND IEP INITIAL-CONTENTS) then (ERROR "Inconsistent options" (QUOTE (INITIAL-ELEMENT
INITIAL-CONTENTS))) elseif (AND DISPLACED-TO (OR IEP INITIAL-CONTENTS)) then (ERROR
"Inconsistent options" (BQUOTE (DISPLACED-TO , (if IEP then (QUOTE INITIAL-ELEMENT) else (QUOTE
INITIAL-CONTENTS))))) elseif (AND DISPLACED-TO-BASE (OR IEP INITIAL-CONTENTS)) then (ERROR
"Inconsistent options" (BQUOTE (DISPLACED-TO-BASE , (if IEP then (QUOTE INITIAL-ELEMENT) else (QUOTE
INITIAL-CONTENTS))))) elseif (AND DISPLACED-INDEX-OFFSET (NULL DISPLACED-TO)) then (ERROR
"Missing displaced to array for displaced index offset" DISPLACED-INDEX-OFFSET)) (* *) (if
FILL-POINTER then (freplace (ARRAY FILL.POINTER) of ARRAY with FILL-POINTER)) (* * The four (five
including DISPLACED-TO-BASE) cases of an adjust: new displacement, undisplace any size, different
size, and same size) (if DISPLACED-TO-BASE then (if (ffetch (ARRAY DISPLACED.TO) of ARRAY) then (
\CML.UNLINK.ARRAY ARRAY)) (freplace (ARRAY BASE) of ARRAY with DISPLACED-TO-BASE) (freplace (ARRAY
DIMENSIONS) of ARRAY with DIMENSIONS) (freplace (ARRAY TOTAL.SIZE) of ARRAY with #ELTS) (freplace (
ARRAY MARGINS) of ARRAY with (\MARGINTO DIMENSIONS)) (if IEP then (\CML.ELEMENT.INITIALIZE ARRAY
INITIAL-ELEMENT) elseif INITIAL-CONTENTS then (\CML.CONTENT.INITIALIZE ARRAY INITIAL-CONTENTS)) (
\CML.DCHAIN.UPDATE ARRAY) elseif DISPLACED-TO then (* Provide a new displacement) (\DISPLACEARRAY
ARRAY DISPLACED-TO DISPLACED-INDEX-OFFSET) (freplace (ARRAY DIMENSIONS) of ARRAY with DIMENSIONS) (
freplace (ARRAY TOTAL.SIZE) of ARRAY with #ELTS) (freplace (ARRAY MARGINS) of ARRAY with (\MARGINTO
DIMENSIONS)) else (* * The following cases alter storage in a significant way-) (if (ffetch (ARRAY
DISPLACED.TO) of ARRAY) then (* * Remove displacement and make new storage for it) (\CML.UNLINK.ARRAY
ARRAY) (freplace (ARRAY BASE) of ARRAY with (\CML.MAKE.STORAGE #ELTS (ffetch (ARRAY ELEMENT.TYPE) of
ARRAY) PAGE-ALIGN ALIGNMENT)) (freplace (ARRAY DIMENSIONS) of ARRAY with DIMENSIONS) (freplace (ARRAY
TOTAL.SIZE) of ARRAY with #ELTS) (freplace (ARRAY MARGINS) of ARRAY with (\MARGINTO DIMENSIONS)) (if
IEP then (\CML.ELEMENT.INITIALIZE ARRAY INITIAL-ELEMENT) elseif INITIAL-CONTENTS then (
\CML.CONTENTS.INITIALIZE ARRAY INITIAL-CONTENTS)) elseif (NOT (IEQP (ffetch (ARRAY TOTAL.SIZE) of
ARRAY) #ELTS)) then (* * Change size by copying block- Update displacees) (LET* ((TYPE# (ffetch (ARRAY
ELEMENT.TYPE) of ARRAY)) (NEWBASE (\CML.MAKE.STORAGE #ELTS TYPE# PAGE-ALIGN ALIGNMENT)) (NEWMARGINS (
\MARGINTO DIMENSIONS))) (if INITIAL-CONTENTS then (* * Old contents discarded) (freplace (ARRAY BASE)
of ARRAY with NEWBASE) (freplace (ARRAY DIMENSIONS) of ARRAY with DIMENSIONS) (freplace (ARRAY
TOTAL.SIZE) of ARRAY with #ELTS) (freplace (ARRAY MARGINS) of ARRAY with NEWMARGINS) (
\CML.CONTENT.INITIALIZE ARRAY INITIAL-CONTENTS) else (* * Old (in bounds) contents copied- OOB
positions filled with INITIAL-ELEMENT) (\COPYARRAY (ARRAY-DIMENSIONS ARRAY) ARRAY (ffetch (ARRAY
MARGINS) of ARRAY) DIMENSIONS NEWBASE NEWMARGINS (if IEP then INITIAL-ELEMENT else (
\CML.TYPE.DEFAULT.VALUE TYPE#))) (freplace (ARRAY BASE) of ARRAY with NEWBASE) (freplace (ARRAY
DIMENSIONS) of ARRAY with DIMENSIONS) (freplace (ARRAY TOTAL.SIZE) of ARRAY with #ELTS) (freplace (
ARRAY MARGINS) of ARRAY with NEWMARGINS))) else (* * Same size, just change dimensions list) (freplace
(ARRAY DIMENSIONS) of ARRAY with DIMENSIONS) (freplace (ARRAY MARGINS) of ARRAY with (\MARGINTO
DIMENSIONS)) (* * IEP has no effect in this case- INITIAL-CONTENTS completely resets the contents- No
initializers means old elements are now seen rearranged by row major rules (even though they don't
move in memory the margin vectors change)) (if INITIAL-CONTENTS then (\CML.CONTENT.INITIALIZE ARRAY
INITIAL-CONTENTS))) (* * Update displacees) (\CML.DCHAIN.UPDATE ARRAY)) ARRAY)))
)
(DECLARE: DOEVAL@COMPILE DONTCOPY
(SPECVARS ARRAYWARNINGFLG)
)
(* If this flag is true, we print a warning when creating arrays in non-GC-able space)
(* * Accessor and settor function group)
(DEFINEQ
(AREF
(CL:LAMBDA (ARRAY &REST SUBSCRIPTS) (* raf "15-Oct-85 23:02") (if (NOT (IEQP (ARRAY-RANK ARRAY) (
LENGTH SUBSCRIPTS))) then (ERROR "Rank mismatch" (LIST ARRAY SUBSCRIPTS))) (if (type? STRINGP ARRAY)
then (SCHAR ARRAY (CAR SUBSCRIPTS)) elseif (type? BITMAP ARRAY) then (BITMAPBIT ARRAY (CAR SUBSCRIPTS)
(CADR SUBSCRIPTS)) elseif (type? ARRAYP ARRAY) then (ELT ARRAY (ADD1 (CAR SUBSCRIPTS))) elseif (type?
ARRAY ARRAY) then (\AREFLINEAR ARRAY (IPLUS (\AREFSET.LINEARIZE ARRAY SUBSCRIPTS) (ffetch (ARRAY
BASE.OFFSET) of ARRAY))) else (ERROR "Not an array" ARRAY))))
(ASET
(CL:LAMBDA (VALUE ARRAY &REST SUBSCRIPTS) (* raf "15-Oct-85 23:11") (if (NOT (IEQP (ARRAY-RANK ARRAY)
(LENGTH SUBSCRIPTS))) then (ERROR "Rank mismatch" (LIST ARRAY SUBSCRIPTS))) (if (type? STRINGP ARRAY)
then (SCHARSET ARRAY (CAR SUBSCRIPTS) VALUE) elseif (type? BITMAP ARRAY) then (BITMAPBIT ARRAY (CAR
SUBSCRIPTS) (CADR SUBSCRIPTS) VALUE) elseif (type? ARRAYP ARRAY) then (SETA ARRAY (ADD1 (CAR
SUBSCRIPTS)) VALUE) elseif (type? ARRAY ARRAY) then (if (NOT (\CML.TYPEP (ffetch (ARRAY ELEMENT.TYPE)
of ARRAY) VALUE)) then (ERROR "Value of wrong type for array" VALUE) else (\ASETLINEAR VALUE ARRAY (
IPLUS (\AREFSET.LINEARIZE ARRAY SUBSCRIPTS) (ffetch (ARRAY BASE.OFFSET) of ARRAY)))) else (ERROR
"Not an array" ARRAY))))
)
(DEFINEQ
(\AREF.1
(LAMBDA (ARRAY I) (* raf "16-Sep-85 16:10") (if (type? STRINGP ARRAY) then (SCHAR ARRAY I) elseif (
type? ARRAYP ARRAY) then (ELT ARRAY (ADD1 I)) elseif (type? ARRAY ARRAY) then (\AREFLINEAR ARRAY (
\AREFSET.LINEARIZE1 ARRAY I)) else (ERROR "Not a 1D array" ARRAY))))
(\AREF.2
(LAMBDA (ARRAY I J) (* raf " 8-Sep-85 19:48") (if (type? ARRAY ARRAY) then (\AREFLINEAR ARRAY (
\AREFSET.LINEARIZE2 ARRAY I J)) elseif (type? BITMAP ARRAY) then (BITMAPBIT ARRAY I J) else (ERROR
"Not a 2D array" ARRAY))))
(\ASET.1
(LAMBDA (VAL ARRAY I) (* raf "16-Sep-85 16:11") (if (type? STRINGP ARRAY) then (SCHARSET ARRAY I VAL)
elseif (type? ARRAYP ARRAY) then (SETA ARRAY (ADD1 I) VAL) elseif (type? ARRAY ARRAY) then (
\ASETLINEAR VAL ARRAY (\AREFSET.LINEARIZE1 ARRAY I)) else (ERROR "Not a 1D array" ARRAY))))
(\ASET.2
(LAMBDA (VAL ARRAY I J) (* raf " 8-Sep-85 19:48") (if (type? ARRAY ARRAY) then (\ASETLINEAR VAL ARRAY
(\AREFSET.LINEARIZE2 ARRAY I J)) elseif (type? BITMAP ARRAY) then (BITMAPBIT ARRAY I J VAL) else (
ERROR "Not a 2D array" ARRAY))))
)
(PUTPROPS AREF SETFN ASETMACRO)
(DECLARE: EVAL@COMPILE
(DEFMACRO ASETMACRO (ARRAY &REST ARGS) (BQUOTE (ASET (\, (CAR (LAST ARGS))) (\, ARRAY) (\,@ (LDIFF
ARGS (LAST ARGS))))))
)
(DEFINEQ
(\AREFLINEAR
(LAMBDA (ARRAY I) (* raf "26-Jul-85 18:44") (* * Reference an array element. Does not take offsets
into account. Does not check argument types) (\CML.TYPED.GET (ffetch (ARRAY ELEMENT.TYPE) of ARRAY) (
ffetch (ARRAY BASE) of ARRAY) I)))
(\ASETLINEAR
(LAMBDA (VAL ARRAY I) (* raf "26-Jul-85 18:45") (* * Set an array element. Does not take offsets into
account. Does not check argument types) (\CML.TYPED.PUT (ffetch (ARRAY ELEMENT.TYPE) of ARRAY) (ffetch
(ARRAY BASE) of ARRAY) I VAL)))
)
(* Makes it work in the absence of the CML system)
(DEFINEQ
(\CML.CHARCODE
(LAMBDA (C) (* raf "16-Oct-85 14:00") (APPLY* (FUNCTION CHARCODE) C)))
)
(MOVD? (QUOTE CHARACTER) (QUOTE INT-CHAR))
(MOVD? (QUOTE \CML.CHARCODE) (QUOTE CHAR-INT))
(MOVD? (QUOTE \CML.CHARCODE) (QUOTE STRING-CHAR-P))
(DECLARE: EVAL@COMPILE DONTCOPY
(DECLARE: EVAL@COMPILE
(PUTPROPS \AREFSET.LINEARIZE MACRO ((A SUBSCRIPTS) (for L on (ffetch (ARRAY DIMENSIONS) of A) as I on
SUBSCRIPTS bind (MARGINS ← (ffetch (ARRAY MARGINS) of A)) (FI ← 0) do (if (NOT (FIXP (CAR I))) then (
ERROR "Bad array index" (CAR I)) elseif (OR (ILESSP (CAR I) 0) (IGEQ (CAR I) (CAR L))) then (ERROR
"Array index out of bounds" (CAR I))) (if (NULL (CDR L)) then (* Final index is modified by the result
of marginings.) (OR (ILESSP (SETQ FI (add (CAR I) MARGINS)) (ffetch (ARRAY TOTAL.SIZE) of A)) (
SHOULDNT)) else (* Go thru one margin array) (SETQ MARGINS (\CML.GETMARGIN MARGINS (CAR I)))) finally
(if (AND (NULL I) (NULL L)) then (RETURN FI) else (ERROR "Rank mismatch" (LIST A SUBSCRIPTS))))))
(PUTPROPS \AREFSET.LINEARIZE1 MACRO (OPENLAMBDA (A I) (if (NEQ 1 (ffetch (ARRAY RANK) of A)) then (
ERROR "Array rank mismatch" ARRAY) elseif (NOT (FIXP I)) then (ERROR "Bad array index" I) elseif (OR (
ILESSP I 0) (IGEQ I (CAR (ffetch (ARRAY DIMENSIONS) of A)))) then (ERROR "Array index out of bounds" I
)) (if (IGEQ I (ffetch (ARRAY TOTAL.SIZE) of A)) then (SHOULDNT)) (IPLUS I (ffetch (ARRAY BASE.OFFSET)
of A))))
(PUTPROPS \AREFSET.LINEARIZE2 MACRO (OPENLAMBDA (A I J) (* JonL " 7-FEB-83 18:55") (if (NEQ 2 (ffetch
(ARRAY RANK) of A)) then (ERROR "Array rank mismatch" ARRAY)) (LET ((\DimensionsList (ffetch (ARRAY
DIMENSIONS) of A)) (\LinearIndex (ffetch (ARRAY MARGINS) of A))) (DECLARE (LOCALVARS \DimensionsList))
(if (NOT (FIXP I)) then (ERROR "Bad array index" I) elseif (OR (ILESSP I 0) (IGEQ I (pop
\DimensionsList))) then (ERROR "Array index out of bounds" I) elseif (OR (ILESSP J 0) (IGEQ J (CAR
\DimensionsList))) then (ERROR "Array index out of bounds" J)) (SETQ \LinearIndex (IPLUS (
\CML.GETMARGIN \LinearIndex I) J)) (if (IGEQ \LinearIndex (ffetch (ARRAY TOTAL.SIZE) of A)) then (
SHOULDNT)) (IPLUS \LinearIndex (ffetch (ARRAY BASE.OFFSET) of A)))))
)
)
(*)
(DECLARE: EVAL@COMPILE
((LAMBDA (C) (MAPC (QUOTE (P X 1 4 8 16 N L)) (FUNCTION (LAMBDA (A) (MAPC (QUOTE (AREF ASET)) (
FUNCTION (LAMBDA (B) (SETQ C (MKATOM (CONCAT A B))) (PUTPROP C (QUOTE MACRO) (BQUOTE (X (, (MKATOM (
CONCAT "\Fast" B "expander")) X (QUOTE , C)))))))))))))
)
(DEFINEQ
(\FastAREFexpander
(LAMBDA (X FFUN) (* raf " 5-Aug-85 16:42") (if (NLISTP X) then (ERROR "Too few args") else (
\NoSissyAREFexpander X FFUN T))))
(\NoSissyAREFexpander
(LAMBDA (X FFUN CHECKFLG) (* raf "30-Jul-85 15:47") (LET* ((TYPE.ENTRY (OR (CDR (ASSOC FFUN
CML.ACCESSOR.TO.TYPE.ALIST)) (SHOULDNT))) (ARRAYFORM (LISPFORM.SIMPLIFY (CAR X) T)) (INDICES (for Y in
(CDR X) collect (LISPFORM.SIMPLIFY Y T))) (ACCESSFORM (BQUOTE (, (ffetch (CML.TYPE.ENTRY ACCESSOR) of
TYPE.ENTRY) , (if CHECKFLG then (BQUOTE (ffetch (ARRAY BASE) of (DATATYPE.ARRAY \Array))) else (
BQUOTE (fetch (ARRAY BASE) of \Array))) , (\CML.OFFSET.EXPANDER TYPE.ENTRY (\AREFSET.INDEXFORM INDICES
)))))) (if (AND (NLISTP ARRAYFORM) (ARGS.COMMUTABLEP.LIST INDICES ARRAYFORM)) then (SUBST ARRAYFORM (
QUOTE \Array) ACCESSFORM) else (BQUOTE ((LAMBDA (\Array) (DECLARE (LOCALVARS \Array)) , ACCESSFORM) ,
ARRAYFORM))))))
(\FastASETexpander
(LAMBDA (X FFUN) (* raf "15-Jul-85 00:20") (if (OR (NLISTP X) (NLISTP (CDR X))) then (ERROR (QUOTE
Too% few% args))) (\NoSissyASETexpander X FFUN T)))
(\NoSissyASETexpander
(LAMBDA (X FFUN CHECKFLG) (* raf "19-Sep-85 13:38") (LET* ((FUN (SUBATOM FFUN 2)) (NEWVALFORM (
LISPFORM.SIMPLIFY (CAR X) T)) (ARRAYFORM (LISPFORM.SIMPLIFY (CADR X) T)) (INDICES (for Y in (CDDR X)
collect (LISPFORM.SIMPLIFY Y T))) (TYPE.ENTRY (\CML.GET.TYPE.ENTRY (EVAL (OR (CDR (ASSOC FUN
CML.SETTOR.TO.TYPE.ALIST)) (SHOULDNT))))) (SETTINGFORM (BQUOTE (, (ffetch (CML.TYPE.ENTRY SETTOR) of
TYPE.ENTRY) (ffetch (ARRAY BASE) of \Array) , (\CML.OFFSET.EXPANDER TYPE.ENTRY (BQUOTE (IPLUS (ffetch
(ARRAY BASE.OFFSET) of \Array) \Index))) \NewVal))) SIMPLEINDEXP SIMPLEARRAYP TEM) (if CHECKFLG then (
SETQ SETTINGFORM (BQUOTE (PROGN (AND (OR (ILESSP \Index 0) (IGEQP \Index (ffetch (ARRAY TOTAL.SIZE) of
(DATATYPE.ARRAY \Array (QUOTE ARRAY))))) (ERROR \Array , (KWOTE FFUN))) , SETTINGFORM)))) (SETQ TEM T
) (if (OR (NOT CHECKFLG) (AND (NULL (CDR INDICES)) (OR (CONSTANTEXPRESSIONP (CAR INDICES)) (AND (
NLISTP (CAR INDICES)) (SETQ TEM (ARGS.COMMUTABLEP ARRAYFORM (CAR INDICES))))))) then (* 1-dim case,
where index commutes with array) (SETQ SIMPLEINDEXP T)) (if (if (NLISTP ARRAYFORM) then (
ARGS.COMMUTABLEP.LIST INDICES ARRAYFORM) else (CONSTANTEXPRESSIONP ARRAYFORM)) then (SETQ SIMPLEARRAYP
T) elseif (NULL TEM) then (* TEM will remain T unless the index for the 1-dim case is a single
variable which didn't quite commute with the array) (SETQ SIMPLEINDEXP T)) (SETQ SETTINGFORM (if
SIMPLEINDEXP then (SUBST (\AREFSET.INDEXFORM INDICES T) (QUOTE \Index) SETTINGFORM) else (BQUOTE ((
LAMBDA (\Index) (DECLARE (LOCALVARS \Index)) , SETTINGFORM) , (\AREFSET.INDEXFORM INDICES T))))) (if
SIMPLEARRAYP then (SETQ SETTINGFORM (SUBST ARRAYFORM (QUOTE \Array) SETTINGFORM)) else (SETQ
SETTINGFORM (BQUOTE ((LAMBDA (\Array) (DECLARE (LOCALVARS \Array)) , SETTINGFORM) , ARRAYFORM)))) (if
(OR (CONSTANTEXPRESSIONP NEWVALFORM) (AND (ARGS.COMMUTABLEP NEWVALFORM ARRAYFORM) (
ARGS.COMMUTABLEP.LIST INDICES NEWVALFORM))) then (SETQ SETTINGFORM (SUBST NEWVALFORM (QUOTE \NewVal)
SETTINGFORM)) else (SETQ SETTINGFORM (BQUOTE ((LAMBDA (\NewVal) (DECLARE (LOCALVARS \NewVal)) ,
SETTINGFORM) , NEWVALFORM)))) SETTINGFORM)))
(\AREFSET.INDEXFORM
(LAMBDA (INDICES NOANCHOROFFSETFLG) (* raf " 9-Jul-85 19:18") (* INDICES is a list whose elements
should have already been THROUGH LISPFORM.SIMPLIFY) (if (NLISTP (CDR INDICES)) then (* Aha!
1-dimensional) (SETQ INDICES (CAR INDICES)) else (bind (MARGINACCFORM ← (QUOTE (ffetch (ARRAY MARGINS)
of \Array))) for I in INDICES do (* First, compose the chain of accesses through the margin arrays,
if any.) (SETQ MARGINACCFORM (BQUOTE (\GETBASEPTR , MARGINACCFORM (LLSH , I 1)))) finally (SETQ
INDICES (BQUOTE (IPLUS ., (CDR MARGINACCFORM)))))) (if NOANCHOROFFSETFLG then INDICES else (BQUOTE (
IPLUS (ffetch (ARRAY BASE.OFFSET) of \Array) , INDICES)))))
)
(DEFINEQ
(\CMLARRAY.LOCFTRAN
(LAMBDA (X) (* lmm "31-Jul-85 21:33") (* * This is not fully implemented) ((LAMBDA (NAME MACP) (if (
AND (LISTP X) (SETQ NAME (CAR X)) (LITATOM NAME) (LISTP (SETQ MACP (GETP NAME (QUOTE MACRO)))) (EQ (
CAR MACP) (QUOTE X)) (NULL (CDDR MACP)) (LISTP (SETQ MACP (CADR MACP))) (FMEMB (CAR MACP) (QUOTE (
\FastAREFexpander \FastASETexpander)))) then (LET* ((ARRAYFORM (LISPFORM.SIMPLIFY (CADR X) T)) (
INDICES (for Z in (CDDR X) collect (LISPFORM.SIMPLIFY Z T))) (NBITS (SUBATOM (CADR (CADDR MACP)) 2 -5)
) (BASEFORM (BQUOTE (fetch (ARRAY BASE) of \Array))) (OFFSETFORM (\AREFSET.INDEXFORM INDICES))
POINTERBYTEP LVARS LVALS) (SELECTQ NBITS (P (SETQ POINTERBYTEP T)) ((N L) (SETQ NBITS BITSPERCELL) (
SETQ OFFSETFORM (BQUOTE (LLSH , OFFSETFORM , (CONSTANT (SUB1 (INTEGERLENGTH BITSPERCELL))))))) (1
OFFSETFORM) ((16 8) (SETQ OFFSETFORM (BQUOTE (LLSH , OFFSETFORM , (SUB1 (INTEGERLENGTH NBITS)))))) (
SHOULDNT)) (if (AND (NLISTP ARRAYFORM) (ARGS.COMMUTABLEP.LIST INDICES ARRAYFORM)) then (SETQ BASEFORM
(SUBST ARRAYFORM (QUOTE \Array) BASEFORM)) (SETQ OFFSETFORM (SUBST ARRAYFORM (QUOTE \Array) OFFSETFORM
)) else (SETQ LVARS (BQUOTE (\Array))) (SETQ LVALS (BQUOTE (, ARRAYFORM)))) (if POINTERBYTEP then (
BQUOTE (\POINTERBYTE , LVARS , LVALS , BASEFORM , OFFSETFORM)) else (BQUOTE (\BITSBYTE , LVARS , LVALS
, BASEFORM , OFFSETFORM , NBITS)))))))))
)
(* * Type specific accessors and settors)
(* Simple Vector)
(DEFINEQ
(SVREF
(LAMBDA (VECTOR INDEX) (* raf "26-Sep-85 00:32") (if (NOT (VECTORP VECTOR)) then (ERROR "Not a vector"
VECTOR)) (AREF VECTOR INDEX)))
(SVSET
(CL:LAMBDA (VECTOR INDEX VALUE) (* raf "26-Sep-85 00:32") (if (NOT (VECTORP VECTOR)) then (ERROR
"Not a vector" VECTOR)) (ASET VALUE VECTOR INDEX)))
)
(PUTPROPS SVREF SETFN SVSET)
(* Bit arrays)
(DEFINEQ
(BIT
(CL:LAMBDA (ARRAY &REST SUBSCRIPTS) (* raf " 8-Aug-85 16:20") (APPLY (FUNCTION AREF) (CONS ARRAY
SUBSCRIPTS))))
(SBIT
(CL:LAMBDA (ARRAY &REST SUBSCRIPTS) (* raf " 8-Aug-85 16:20") (APPLY (FUNCTION AREF) (CONS ARRAY
SUBSCRIPTS))))
(SBITSET
(CL:LAMBDA (BIT-VECTOR INDEX VALUE) (ASET VALUE BIT-VECTOR INDEX)))
)
(PUTPROPS BIT SETFN SBITSET)
(PUTPROPS SBIT SETFN SBITSET)
(* * ! BIT-AND BIT-IOR BIT-XOR BIT-EQV BIT-NAND BIT-NOR BIT-ANDC1 BIT-ANDC2 BIT-ORC1 BIT-ORC2
BIT-NOT)
(* Strings)
(DEFINEQ
(CHAR
(CL:LAMBDA (STRING INDEX) (SCHAR STRING INDEX)))
(SCHAR
(CL:LAMBDA (SIMPLE-STRING INDEX) (* raf "16-Sep-85 18:13") (INT-CHAR (NTHCHARCODE SIMPLE-STRING (ADD1
INDEX)))))
(SCHARSET
(CL:LAMBDA (SIMPLE-STRING INDEX VALUE) (* raf "16-Sep-85 18:13") (RPLCHARCODE SIMPLE-STRING (ADD1
INDEX) (CHAR-INT VALUE))))
)
(PUTPROPS CHAR SETFN SCHARSET)
(PUTPROPS SCHAR SETFN SCHARSET)
(* * Fill pointer operations)
(RPAQ? *DEFAULT-PUSH-EXTENSION-SIZE* 20)
(DECLARE: DOEVAL@COMPILE DONTCOPY
(GLOBALVARS *DEFAULT-PUSH-EXTENSION-SIZE*)
)
(DEFINEQ
(ARRAY-HAS-FILL-POINTER-P
(CL:LAMBDA (ARRAY) (* raf " 8-Sep-85 20:19") (if (type? ARRAY ARRAY) then (ffetch (ARRAY
HAS.FILL.POINTER) of ARRAY) elseif (CL:ARRAYP ARRAY) then NIL else (ERROR "Not an array" ARRAY))))
(FILL-POINTER
(CL:LAMBDA (ARRAY) (* raf " 9-Sep-85 03:23") (if (AND (type? ARRAY ARRAY) (ffetch (ARRAY
HAS.FILL.POINTER) of ARRAY)) then (ffetch (ARRAY FILL.POINTER) of ARRAY) elseif (CL:ARRAYP ARRAY) then
(ERROR "Array has no fill pointer" ARRAY) else (ERROR "Not an array" ARRAY))))
(FILL-POINTER-SET
(CL:LAMBDA (ARRAY VALUE) (* raf "14-Sep-85 02:16") (if (AND (type? ARRAY ARRAY) (ffetch (ARRAY
HAS.FILL.POINTER) of ARRAY)) then (if (AND (IGREATERP VALUE 0) (ILEQ VALUE (ffetch (ARRAY TOTAL.SIZE)
of ARRAY))) then (freplace (ARRAY FILL.POINTER) of ARRAY with VALUE) else (ERROR
"Fill pointer out of bounds" VALUE)) elseif (CL:ARRAYP ARRAY) then (ERROR
"Array has no fill pointer to set" ARRAY) else (ERROR "Not an array" ARRAY))))
(VECTOR-PUSH
(CL:LAMBDA (NEW-ELEMENT VECTOR) (* raf " 9-Sep-85 03:27") (if (AND (type? ARRAY VECTOR) (ffetch (ARRAY
HAS.FILL.POINTER) of VECTOR)) then (LET ((FILL.POINTER (ffetch (ARRAY FILL.POINTER) of VECTOR))) (if
(ILESSP FILL.POINTER (ffetch (ARRAY TOTAL.SIZE) of VECTOR)) then (\CML.TYPED.PUT (ffetch (ARRAY
ELEMENT.TYPE) of VECTOR) (ffetch (ARRAY BASE) of VECTOR) FILL.POINTER NEW-ELEMENT) (freplace (ARRAY
FILL.POINTER) of VECTOR with (ADD1 FILL.POINTER)) FILL.POINTER else NIL)) elseif (CL:ARRAYP VECTOR)
then (ERROR "Array has no fill pointer" VECTOR) else (ERROR "Not an array" VECTOR))))
(VECTOR-PUSH-EXTEND
(CL:LAMBDA (NEW-ELEMENT VECTOR &OPTIONAL (EXTENSION-SIZE *DEFAULT-PUSH-EXTENSION-SIZE*)) (* raf
" 9-Sep-85 03:28") (if (NOT (\INDEXABLE.FIXP EXTENSION-SIZE)) then (ERROR "Bad extension size"
EXTENSION-SIZE)) (if (AND (type? ARRAY VECTOR) (ffetch (ARRAY HAS.FILL.POINTER) of VECTOR)) then (LET
((FILL.POINTER (ffetch (ARRAY FILL.POINTER) of VECTOR))) (if (ILESSP FILL.POINTER (ffetch (ARRAY
TOTAL.SIZE) of VECTOR)) then (\CML.TYPED.PUT (ffetch (ARRAY ELEMENT.TYPE) of VECTOR) (ffetch (ARRAY
BASE) of VECTOR) FILL.POINTER NEW-ELEMENT) (freplace (ARRAY FILL.POINTER) of VECTOR with (ADD1
FILL.POINTER)) FILL.POINTER elseif (ffetch (ARRAY ADJUSTABLE.P) of VECTOR) then (ADJUST-ARRAY (LIST (
IPLUS (ffetch (ARRAY TOTAL.SIZE) of VECTOR) EXTENSION-SIZE))) else (ERROR
"Can't extend VECTOR, not adjustable" VECTOR))) elseif (CL:ARRAYP VECTOR) then (ERROR
"Array has no fill pointer" VECTOR) else (ERROR "Not an array" VECTOR))))
(VECTOR-POP
(CL:LAMBDA (VECTOR) (* raf " 9-Sep-85 03:29") (if (AND (type? ARRAY VECTOR) (ffetch (ARRAY
HAS.FILL.POINTER) of VECTOR)) then (LET ((FILL.POINTER (ffetch (ARRAY FILL.POINTER) of VECTOR))) (if (
IGREATERP FILL.POINTER 0) then (add FILL.POINTER -1) (freplace (ARRAY FILL.POINTER) of VECTOR with
FILL.POINTER) (\CML.TYPED.GET (ffetch (ARRAY ELEMENT.TYPE) of VECTOR) (ffetch (ARRAY BASE) of VECTOR)
FILL.POINTER NEW-ELEMENT) else (ERROR "Can't pop from zero fill pointer" FILL.POINTER))) elseif (
CL:ARRAYP VECTOR) then (ERROR "Array has no fill pointer" VECTOR) else (ERROR "Not an array" VECTOR)))
)
)
(PUTPROPS FILL-POINTER SETFN FILL-POINTER-SET)
(* * Header info)
(DEFINEQ
(CML.DIMENSIONS.LINEAR.SIZE
(LAMBDA (DIML NAME) (* raf "15-Oct-85 16:58") (* * Returns the length of a block in elements to hold
the given dimensions) (if (IGEQ (LENGTH DIML) ARRAY-RANK-LIMIT) then (ERROR
"Rank must be < ARRAY-RANK-LIMIT" RANK)) (for I in DIML bind (#ELTS ← 1) do (if (OR (NOT (FIXP I)) (
ILESSP I 0)) then (ERROR (CONCAT "Invalid " NAME) I) elseif (IGEQ I ARRAY-DIMENSION-LIMIT) then (ERROR
(CONCAT NAME " must be < ARRAY-DIMENSION-LIMIT") I)) (SETQ #ELTS (ITIMES #ELTS I)) finally (if (IGEQ
#ELTS ARRAY-TOTAL-SIZE-LIMIT) then (ERROR (CONCAT "Total " NAME "s must be < ARRAY-TOTAL-SIZE-LIMIT")
#ELTS) else (RETURN #ELTS)))))
)
(DEFINEQ
(ADJUSTABLE-ARRAY-P
(LAMBDA (ARRAY) (* raf "16-Sep-85 16:29") (if (type? ARRAY ARRAY) then (ffetch (ARRAY ADJUSTABLE.P) of
ARRAY) elseif (OR (type? STRINGP ARRAY) (type? ARRAYP ARRAY) (type? BITMAP ARRAY)) then NIL else (
ERROR "Not an array" ARRAY))))
(ARRAY-RANK
(LAMBDA (ARRAY) (* raf "19-Sep-85 14:18") (if (type? ARRAY ARRAY) then (fetch (ARRAY RANK) of ARRAY)
elseif (OR (type? STRINGP ARRAY) (type? ARRAYP ARRAY)) then 1 elseif (type? BITMAP ARRAY) then 2 else
(ERROR "Not an array" ARRAY))))
(ARRAY-DIMENSIONS
(LAMBDA (ARRAY) (* raf "16-Sep-85 16:29") (if (type? STRINGP ARRAY) then (LIST (NCHARS ARRAY)) elseif
(type? BITMAP ARRAY) then (LIST (BITMAPWIDTH ARRAY) (BITMAPHEIGHT ARRAY)) elseif (type? ARRAY ARRAY)
then (ffetch (ARRAY DIMENSIONS) of ARRAY) elseif (type? ARRAYP ARRAY) then (LIST (ARRAYSIZE ARRAY))
else (ERROR "Not an array" ARRAY))))
(ARRAY-DIMENSION
(LAMBDA (ARRAY AXIS) (* raf "16-Sep-85 16:30") (if (NOT (\INDEXABLE.FIXP AXIS)) then (ERRORX (BQUOTE (
27 , AXIS))) elseif (type? STRINGP ARRAY) then (if (IEQP AXIS 0) then (NCHARS ARRAY) else (ERROR
"Bad axis number" AXIS)) elseif (type? ARRAY ARRAY) then (if (ILEQ AXIS (ffetch (ARRAY RANK) of ARRAY)
) then (CAR (NTH (ffetch (ARRAY DIMENSIONS) ARRAY) (ADD1 AXIS))) else (ERROR "Bad axis number" AXIS))
elseif (type? ARRAYP ARRAY) then (if (IEQP AXIS 0) then (ARRAYSIZE ARRAY) else (ERROR
"Bad axis number" AXIS)) elseif (type? BITMAP ARRAY) then (SELECTQ AXIS (0 (BITMAPWIDTH ARRAY)) (1 (
BITMAPHEIGHT ARRAY)) (ERROR "Bad axis number" AXIS)) else (ERROR "Not an array" ARRAY))))
(ARRAY-ELEMENT-TYPE
(LAMBDA (ARRAY) (* raf " 6-Sep-85 21:12") (SELECTC (\CML.GENERIC.ELEMENT.TYPE ARRAY) (\AT.XPOINTER (
QUOTE XPOINTER)) (\AT.POINTER T) (\AT.DOUBLEPOINTER (QUOTE DOUBLE-POINTER)) (\AT.BIT (QUOTE BIT)) (
\AT.BYTE (BQUOTE (UNSIGNED-BYTE , BITSPERBYTE))) (\AT.SMALLPOSP (BQUOTE (UNSIGNED-BYTE , BITSPERWORD))
) (\AT.FIXP (QUOTE FIXNUM)) (\AT.FLOATP (QUOTE SINGLE-FLOAT)) (\AT.STRING-CHAR (QUOTE STRING-CHAR)) (
SHOULDNT))))
(ARRAY-IN-BOUNDS-P
(CL:LAMBDA (ARRAY &REST SUBSCRIPTS) (* raf "15-Oct-85 17:01") (CML.DIMENSIONS.LINEAR.SIZE SUBSCRIPTS
"subscript") (if (type? STRINGP ARRAY) then (if (CDR SUBSCRIPTS) then (ERROR "Rank mismatch" (LIST
ARRAY SUBSCRIPTS)) else (ILESSP (CAR SUBSCRIPTS) (NCHARS ARRAY))) elseif (type? ARRAY ARRAY) then (if
(NOT (IEQ (LENGTH SUBSCRIPTS) (ARRAY-RANK ARRAY))) then (ERROR "Rank mismatch" (LIST ARRAY SUBSCRIPTS)
) else (NOT (find I in (ARRAY-DIMENSIONS ARRAY) as K in SUBSCRIPTS suchthat (OR (IGREATERP 0 K) (ILEQ
I K))))) elseif (type? BITMAP ARRAY) then (if (CDDR SUBSCRIPTS) then (ERROR "Rank mismatch" (LIST
ARRAY SUBSCRIPTS)) else (AND (ILESSP (CAR SUBSCRIPTS) (BITMAPWIDTH ARRAY)) (ILESSP (CAR SUBSCRIPTS) (
BITMAPHEIGHT ARRAY)))) elseif (type? ARRAYP ARRAY) then (if (CDR SUBSCRIPTS) then (ERROR
"Rank mismatch" (LIST ARRAY SUBSCRIPTS)) else (ILESSP (CAR SUBSCRIPTS) (ARRAYSIZE ARRAY))) else (ERROR
"Not an array" ARRAY))))
(ARRAY-TOTAL-SIZE
(LAMBDA (ARRAY) (* raf "16-Sep-85 16:30") (if (type? STRINGP ARRAY) then (NCHARS ARRAY) elseif (type?
ARRAY ARRAY) then (\CML.GENERIC.FETCH ARRAY TOTAL.SIZE) elseif (type? ARRAYP ARRAY) then (ARRAYSIZE
ARRAY) elseif (type? BITMAP ARRAY) then (ITIMES (BITMAPHEIGHT ARRAY) (BITMAPWIDTH ARRAY)) else (ERROR
"Not an array" ARRAY))))
(ARRAY-ROW-MAJOR-INDEX
(CL:LAMBDA (ARRAY &REST SUBSCRIPTS) (* raf "15-Oct-85 16:58")
"Returns the index into the Array's data vector for the given subscripts." (CML.DIMENSIONS.LINEAR.SIZE
SUBSCRIPTS "subscript") (if (OR (type? STRINGP ARRAY) (type? ARRAYP ARRAY)) then (if (CDR SUBSCRIPTS)
then (ERROR "Rank mismatch" (LIST ARRAY SUBSCRIPTS)) else (CAR SUBSCRIPTS)) elseif (type? BITMAP
ARRAY) then (if (CDDR SUBSCRIPTS) then (ERROR "Rank mismatch" (LIST ARRAY SUBSCRIPTS)) else (IPLUS (
CAR SUBSCRIPTS) (ITIMES (CADR SUBSCRIPTS) (BITMAPWIDTH ARRAY)))) elseif (type? ARRAY ARRAY) then (
\AREFSET.LINEARIZE ARRAY SUBSCRIPTS) else (ERROR "Not an array" ARRAY))))
)
(* * Array IO)
(RPAQ? *PRINT-ARRAY* NIL)
(RPAQ? *PRINT-LEVEL* NIL)
(RPAQ? *PRINT-LENGTH* NIL)
(DEFINEQ
(COPY.ARRAY.TO.LIST
(LAMBDA (ARRAY) (* raf "26-Sep-85 01:16") (if (IEQP 0 (ARRAY-RANK ARRAY)) then (LIST (AREF ARRAY))
else (\COPY.ARRAY.DIMENSION.TO.LIST ARRAY (fetch (ARRAY MARGINS) of ARRAY) (ARRAY-DIMENSIONS ARRAY))))
)
(\COPY.ARRAY.DIMENSION.TO.LIST
(LAMBDA (ARRAY MARGIN DIMENSIONS) (* raf "11-Oct-85 15:45") (DECLARE (SPECVARS \CML.READPREFIX)) (LET*
((END.INDEX (SUB1 (CAR DIMENSIONS))) (FINAL.INDEX (if (OR (NULL *PRINT-LENGTH*) (ILESSP END.INDEX
*PRINT-LENGTH*)) then END.INDEX else *PRINT-LENGTH*))) (if (NULL (CDR DIMENSIONS)) then (LET ((OFFSET
(ffetch (ARRAY BASE.OFFSET) of ARRAY)) (BASE (ffetch (ARRAY BASE) of ARRAY)) (TYPE (ffetch (ARRAY
ELEMENT.TYPE) of ARRAY))) (for I from 0 to FINAL.INDEX collect (if (OR (NULL *PRINT-LENGTH*) (ILESSP I
*PRINT-LENGTH*)) then (\CML.TYPED.GET TYPE BASE (IPLUS MARGIN OFFSET I)) else (QUOTE ...)))) else (
RESETVAR *PRINT-LEVEL* (AND *PRINT-LEVEL* (SUB1 *PRINT-LEVEL*)) (for I from 0 to FINAL.INDEX collect (
if (OR (NULL *PRINT-LENGTH*) (ILESSP I *PRINT-LENGTH*)) then (if (AND *PRINT-LEVEL* (ILEQ
*PRINT-LEVEL* 0)) then (MKATOM \CML.READPREFIX) else (\COPY.ARRAY.DIMENSION.TO.LIST ARRAY (
\CML.GETMARGIN MARGIN I) (CDR DIMENSIONS))) else (QUOTE ...))))))))
(FLAT.COPY.ARRAY.TO.LIST
(LAMBDA (ARRAY) (* raf "29-Jul-85 23:38") (SETQ ARRAY (DATATYPE.ARRAY ARRAY)) (LET ((START.INDEX (
ffetch (ARRAY BASE.OFFSET) of ARRAY)) (END.INDEX (SUB1 (ffetch (ARRAY TOTAL.SIZE) of ARRAY))) (TYPE (
ffetch (ARRAY ELEMENT.TYPE) of ARRAY))) (* *) (for I from START.INDEX to END.INDEX collect (
\CML.TYPED.GET TYPE ARRAY I)))))
(\DEFPRINT.ARRAY
(LAMBDA (A) (* raf "14-Oct-85 18:44") (* * This is the DEFPRINT function for the ARRAY type) (DECLARE
(SPECVARS \CML.READPREFIX)) (if *PRINT-ARRAY* then (if (IEQP 1 (ARRAY-RANK A)) then (\DEFPRINT.VECTOR
A) elseif (AND *PRINT-LEVEL* (ILEQ *PRINT-LEVEL* 0)) then (CONS \CML.READPREFIX NIL) else (CONS (
CONCAT \CML.READPREFIX (ARRAY-RANK A) (QUOTE A)) (COPY.ARRAY.TO.LIST A))))))
(\DEFPRINT.VECTOR
(LAMBDA (V) (* raf "14-Oct-85 18:54") (DECLARE (SPECVARS \CML.READPREFIX)) (if *PRINT-ARRAY* then (if
(AND *PRINT-LEVEL* (LEQ *PRINT-LEVEL* 0)) then (CONS \CML.READPREFIX NIL) else (if (IEQP (
\CML.GENERIC.ELEMENT.TYPE V) \AT.BIT) then (\DEFPRINT.BITVECTOR V) else (CONS (CONCAT \CML.READPREFIX
(ARRAY-TOTAL-SIZE V)) (LIST.VECTOR V)))))))
(\DEFPRINT.BITVECTOR
(LAMBDA (V) (* raf "11-Oct-85 15:46") (* * *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*.) (DECLARE (SPECVARS \CML.READPREFIX)) (LET ((END.INDEX (SUB1 (
ARRAY-TOTAL-SIZE V))) FINAL.INDEX) (* * Remove EQ tail elements) (bind (LAST.VALUE ← (AREF V END.INDEX
)) for J from (SUB1 END.INDEX) to 0 by -1 while (EQ (AREF V J) LAST.VALUE) do (SETQ END.INDEX J)) (* *
Limit by *PRINT-LENGTH*) (SETQ FINAL.INDEX (if (OR (NULL *PRINT-LENGTH*) (ILESSP END.INDEX
*PRINT-LENGTH*)) then END.INDEX else (IPLUS *PRINT-LENGTH* 2))) (* * Setup string, watching for end
condition) (LET ((STR (ALLOCSTRING (IPLUS 3 FINAL.INDEX)))) (RPLSTRING STR 1 \CML.READPREFIX) (
RPLSTRING STR 2 "*") (for I from 3 to (IPLUS FINAL.INDEX 3) as J from 0 to FINAL.INDEX do (RPLCHARCODE
STR I (if (OR (NULL *PRINT-LENGTH*) (ILESSP J *PRINT-LENGTH*)) then (IPLUS (BIT V J) (CONSTANT (
CHARCODE 0))) else (CONSTANT (CHARCODE %.))))) (CONS STR NIL)))))
(\DEFPRINT.BITMAP
(CL:LAMBDA (BITMAP) (* raf "11-Oct-85 15:46") (DECLARE (SPECVARS \CML.READPREFIX)) (if *PRINT-ARRAY*
then (if (AND *PRINT-LEVEL* (ILEQ *PRINT-LEVEL* 0)) then (CONS \CML.READPREFIX NIL) else (CONS (CONCAT
\CML.READPREFIX 2 (QUOTE A)) (LET* ((END.J (SUB1 (BITMAPHEIGHT BITMAP))) (FINAL.J (if (OR (NULL
*PRINT-LENGTH*) (ILESSP END.J *PRINT-LENGTH*)) then END.J else *PRINT-LENGTH*))) (for J from 0 to
FINAL.J collect (if (OR (NULL *PRINT-LENGTH*) (ILESSP J *PRINT-LENGTH*)) then (if (AND *PRINT-LEVEL* (
ILEQ *PRINT-LEVEL* 1)) then (MKATOM \CML.READPREFIX) else (LET* ((END.I (SUB1 (BITMAPWIDTH BITMAP))) (
FINAL.I (if (OR (NULL *PRINT-LENGTH*) (ILESSP END.I *PRINT-LENGTH*)) then END.I else *PRINT-LENGTH*)))
(for I from 0 to FINAL.I collect (if (OR (NULL *PRINT-LENGTH*) (ILESSP I *PRINT-LENGTH*)) then (
BITMAPBIT BITMAP I J) else (QUOTE ...))))) else (QUOTE ...)))))) else NIL)))
(LIST.VECTOR
(LAMBDA (ARRAY) (* raf "26-Sep-85 02:32") (* * DEFPRINT formatting function for one dimensional arrays
or vectors - NOTE that this compresses the list representation by cutting off eq tail elements.) (LET
((END.INDEX (SUB1 (ARRAY-TOTAL-SIZE ARRAY))) FINAL.INDEX) (bind (LAST.VALUE ← (AREF ARRAY END.INDEX))
for J from (SUB1 END.INDEX) to 0 by -1 while (EQ (AREF ARRAY J) LAST.VALUE) do (SETQ END.INDEX J)) (
SETQ FINAL.INDEX (if (OR (NULL *PRINT-LENGTH*) (ILESSP END.INDEX *PRINT-LENGTH*)) then END.INDEX else
*PRINT-LENGTH*)) (for I from 0 to FINAL.INDEX collect (if (OR (NULL *PRINT-LENGTH*) (ILESSP I
*PRINT-LENGTH*)) then (AREF ARRAY I) else (QUOTE ...))))))
)
(DEFPRINT (QUOTE ARRAY) (QUOTE \DEFPRINT.ARRAY))
(DEFPRINT (QUOTE BITMAP) (QUOTE \DEFPRINT.BITMAP))
(DEFPRINT (QUOTE ARRAYP) (QUOTE \DEFPRINT.VECTOR))
(DEFINEQ
(FILL.VECTOR
(LAMBDA (ARRAY LIST) (* raf "13-Sep-85 23:32") (* * FILL.VECTOR repeats the last element in LIST if it
was too short to fill the array) (if (NOT (VECTORP ARRAY)) then (ERROR "Not a vector" ARRAY)) (OR (
LISTP LIST) (SETQ LIST (LIST LIST))) (LET ((ITEM (CAR LIST))) (for I from 0 to (SUB1 (ARRAY-DIMENSION
ARRAY 0)) do (ASET ITEM ARRAY I) (pop LIST) (if LIST then (SETQ ITEM (CAR LIST)))) ARRAY)))
)
(* * Compiler gronk)
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
(ADDTOVAR NLAMA )
(ADDTOVAR NLAML )
(ADDTOVAR LAMA ARRAY-ROW-MAJOR-INDEX ARRAY-IN-BOUNDS-P VECTOR-PUSH-EXTEND SBIT BIT ASET AREF
ADJUST-ARRAY VECTOR MAKE-ARRAY)
)
(PUTPROPS CMLARRAY COPYRIGHT (" A A A A A Aation" 1982 1983 1984 1985))
(DECLARE: DONTCOPY
(FILEMAP (NIL (14185 15156 (\CML.GENERIC.ELEMENT.TYPE 14195 . 14568) (\CML.ARRAYP.TYPE.TO.CML.TYPE
14570 . 14928) (\CML.BITMAP.TYPE.TO.CML.TYPE 14930 . 15154)) (15157 15761 (\CML.GET.TYPE.ENTRY 15167
. 15334) (\CML.OFFSET.EXPANDER 15336 . 15759)) (17298 17642 (CL:ARRAYP 17308 . 17459) (VECTORP 17461
. 17640)) (17643 17880 (\ARRAY.DIMENSIONS.MATCH 17653 . 17878)) (18515 21837 (\DISPLACEARRAY 18525 .
19228) (\CML.DCHAIN.UPDATE 19230 . 19789) (\CML.LINK.ARRAY 19791 . 20920) (\CML.UNLINK.ARRAY 20922 .
21835)) (21838 30988 (SLOW.COPY.ELEMENT.INTO.ARRAY 21848 . 23013) (\COPYARRAY 23015 . 24487) (
\CML.ELEMENT.INITIALIZE 24489 . 25002) (\CML.CONTENT.INITIALIZE 25004 . 26347) (
\FLAT.COPY.ARRAY.TO.ARRAY 26349 . 26919) (\FLAT.COPY.LIST.TO.ARRAY 26921 . 27292) (COPY.LIST.TO.STRING
27294 . 27543) (COPY.STRING-CHAR.TO.SIMPLE-STRING 27545 . 27737) (COPY.ARRAY.TO.STRING 27739 . 28256)
(COPY.BITMAP.TO.ARRAY 28258 . 28747) (COPY.STRING.TO.ARRAY 28749 . 29243) (COPY.LIST.TO.BITMAP 29245
. 29703) (COPY.ARRAY.TO.BITMAP 29705 . 30284) (COPY.ELEMENT.TO.BITMAP 30286 . 30500) (
\CML.MAKE.STORAGE 30502 . 30986)) (30989 34199 (\CML.MS.ELEMENT.TYPE 30999 . 33171) (
\CML.ILTYPE.TO.CLTYPE 33173 . 34197)) (34200 35112 (\MARGINTO 34210 . 34401) (\MARGIN.ONE.DIMENSION
34403 . 35110)) (35113 35345 (\CML.ICP.CHECK 35123 . 35343)) (35346 45703 (MAKE-ARRAY 35356 . 39919) (
VECTOR 39921 . 40076) (ADJUST-ARRAY 40078 . 45701)) (45910 47237 (AREF 45920 . 46496) (ASET 46498 .
47235)) (47238 48318 (\AREF.1 47248 . 47528) (\AREF.2 47530 . 47765) (\ASET.1 47767 . 48067) (\ASET.2
48069 . 48316)) (48504 49026 (\AREFLINEAR 48514 . 48767) (\ASETLINEAR 48769 . 49024)) (49086 49187 (
\CML.CHARCODE 49096 . 49185)) (51564 55476 (\FastAREFexpander 51574 . 51723) (\NoSissyAREFexpander
51725 . 52471) (\FastASETexpander 52473 . 52647) (\NoSissyASETexpander 52649 . 54794) (
\AREFSET.INDEXFORM 54796 . 55474)) (55477 56861 (\CMLARRAY.LOCFTRAN 55487 . 56859)) (56936 57255 (
SVREF 56946 . 57091) (SVSET 57093 . 57253)) (57313 57652 (BIT 57323 . 57444) (SBIT 57446 . 57568) (
SBITSET 57570 . 57650)) (57852 58189 (CHAR 57862 . 57920) (SCHAR 57922 . 58046) (SCHARSET 58048 .
58187)) (58425 61586 (ARRAY-HAS-FILL-POINTER-P 58435 . 58653) (FILL-POINTER 58655 . 58945) (
FILL-POINTER-SET 58947 . 59403) (VECTOR-PUSH 59405 . 60012) (VECTOR-PUSH-EXTEND 60014 . 60966) (
VECTOR-POP 60968 . 61584)) (61663 62326 (CML.DIMENSIONS.LINEAR.SIZE 61673 . 62324)) (62327 66347 (
ADJUSTABLE-ARRAY-P 62337 . 62594) (ARRAY-RANK 62596 . 62848) (ARRAY-DIMENSIONS 62850 . 63214) (
ARRAY-DIMENSION 63216 . 63921) (ARRAY-ELEMENT-TYPE 63923 . 64365) (ARRAY-IN-BOUNDS-P 64367 . 65320) (
ARRAY-TOTAL-SIZE 65322 . 65675) (ARRAY-ROW-MAJOR-INDEX 65677 . 66345)) (66463 71505 (
COPY.ARRAY.TO.LIST 66473 . 66701) (\COPY.ARRAY.DIMENSION.TO.LIST 66703 . 67700) (
FLAT.COPY.ARRAY.TO.LIST 67702 . 68057) (\DEFPRINT.ARRAY 68059 . 68460) (\DEFPRINT.VECTOR 68462 . 68824
) (\DEFPRINT.BITVECTOR 68826 . 69908) (\DEFPRINT.BITMAP 69910 . 70817) (LIST.VECTOR 70819 . 71503)) (
71657 72084 (FILL.VECTOR 71667 . 72082)))))
STOP