(FILECREATED "28-Jan-86 15:30:39" {ERIS}<LISPCORE>LIBRARY>CMLARRAY.;74 144091
changes to: (FNS \CML.MS.ELEMENT.TYPE)
previous date: " 4-Dec-85 00:37:47" {ERIS}<LISPCORE>LIBRARY>CMLARRAY.;73)
(* Copyright (c) 1982, 1983, 1984, 1985, 1986 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)
(FILES CMLARRAYINSPECTOR)
(DECLARE: EVAL@COMPILE DONTCOPY (* * Utilities)
(MACROS \CHECKTYPE \INDEXABLE.FIXP DATATYPE.TEST))
(COMS (* * The implementation-)
(DECLARE: DONTCOPY EVAL@COMPILE (*)
(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 (* * Encapsulation of type specifics)
[DECLARE: DONTCOPY EVAL@COMPILE (*)
(CONSTANTS * CMLARRAYTYPES)
(CONSTANTS [CMLARRAY.TYPE.TABLE
(BQUOTE ([, \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]
[CML.SETTOR.TO.TYPE.ALIST (BQUOTE ((XASET ., \AT.XPOINTER)
(PASET ., \AT.POINTER)
(8ASET ., \AT.BYTE)
(16ASET ., \AT.SMALLPOSP)
(1ASET ., \AT.BIT)
(NASET ., \AT.FIXP)
(LASET ., \AT.FLOATP]
(CML.ACCESSOR.TO.TYPE.ALIST (BQUOTE ((XAREF ., \AT.XPOINTER)
(PAREF ., \AT.POINTER)
(8AREF ., \AT.BYTE)
(16AREF .,
\AT.SMALLPOSP)
(1AREF ., \AT.BIT)
(NAREF ., \AT.FIXP)
(LAREF ., \AT.FLOATP]
(VARS * CMLARRAYTYPES)
(VARS CMLARRAY.TYPE.TABLE CML.SETTOR.TO.TYPE.ALIST
CML.ACCESSOR.TO.TYPE.ALIST)
(DECLARE: EVAL@COMPILE DONTCOPY (*)
(RECORDS CML.TYPE.ENTRY)
(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 SHRINK-VECTOR \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 SIMPLE-BIT-VECTOR-P SIMPLE-VECTOR-P BIT-VECTOR-P
SIMPLE-ARRAY-P)
(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 AREF ADJUST-ARRAY VECTOR MAKE-ARRAY ASET])
(* * 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)
(FILESLOAD CMLARRAYINSPECTOR)
(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 implementation-)
(DECLARE: DONTCOPY EVAL@COMPILE
(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)
(* * Encapsulation of type specifics)
(DECLARE: DONTCOPY EVAL@COMPILE
(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
(RPAQ CMLARRAY.TYPE.TABLE (BQUOTE ([, \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))))
(RPAQ CML.SETTOR.TO.TYPE.ALIST (BQUOTE ((XASET ., \AT.XPOINTER)
(PASET ., \AT.POINTER)
(8ASET ., \AT.BYTE)
(16ASET ., \AT.SMALLPOSP)
(1ASET ., \AT.BIT)
(NASET ., \AT.FIXP)
(LASET ., \AT.FLOATP))))
(RPAQ CML.ACCESSOR.TO.TYPE.ALIST (BQUOTE ((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 (BQUOTE ([, \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]
[CML.SETTOR.TO.TYPE.ALIST (BQUOTE ((XASET ., \AT.XPOINTER)
(PASET ., \AT.POINTER)
(8ASET ., \AT.BYTE)
(16ASET ., \AT.SMALLPOSP)
(1ASET ., \AT.BIT)
(NASET ., \AT.FIXP)
(LASET ., \AT.FLOATP]
(CML.ACCESSOR.TO.TYPE.ALIST (BQUOTE ((XAREF ., \AT.XPOINTER)
(PAREF ., \AT.POINTER)
(8AREF ., \AT.BYTE)
(16AREF ., \AT.SMALLPOSP)
(1AREF ., \AT.BIT)
(NAREF ., \AT.FIXP)
(LAREF ., \AT.FLOATP]
)
)
(RPAQQ CMLARRAYTYPES (\AT.XPOINTER \AT.POINTER \AT.DOUBLEPOINTER \AT.BIT \AT.BYTE \AT.SMALLPOSP
\AT.FIXP \AT.FLOATP \AT.STRING-CHAR))
(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)
(RPAQQ CMLARRAY.TYPE.TABLE ([0 \GETBASEPTR \PUTBASEPTR 32 16 T NIL (LAMBDA (OBJECT)
T]
[2 \GETBASEPTR \RPLPTR 64 16 T NIL (LAMBDA (OBJECT)
T]
[1 \GETBASEPTR \RPLPTR 32 16 T NIL (LAMBDA (OBJECT)
T]
[5 \GETBASE \PUTBASE 16 16 NIL 0 (LAMBDA (OBJECT)
(NOT (NULL (SMALLPOSP OBJECT]
[4 \GETBASEBYTE \PUTBASEBYTE 8 8 NIL 0 (LAMBDA (OBJECT)
(AND (SMALLPOSP OBJECT)
(ILESSP OBJECT
(LLSH 1
BITSPERBYTE
]
[3 \GETBASEBIT \PUTBASEBIT 1 1 NIL 0 (LAMBDA (OBJECT)
(AND (SMALLPOSP OBJECT)
(ILEQ OBJECT 1]
[6 \GETBASEFIXP \PUTBASEFIXP 32 16 NIL 0 (LAMBDA
(OBJECT)
(NOT (NULL (FIXP OBJECT]
[7 \GETBASEFLOATP \PUTBASEFLOATP 32 16 NIL 0.0
(LAMBDA (OBJECT)
(NOT (NULL (FLOATP OBJECT]
(8 \GETBASESTRING-CHAR \PUTBASESTRING-CHAR 16 16 NIL 32 CHAR-INT)))
(RPAQQ CML.SETTOR.TO.TYPE.ALIST ((XASET . 0)
(PASET . 1)
(8ASET . 4)
(16ASET . 5)
(1ASET . 3)
(NASET . 6)
(LASET . 7)))
(RPAQQ CML.ACCESSOR.TO.TYPE.ALIST ((XAREF . 0)
(PAREF . 1)
(8AREF . 4)
(16AREF . 5)
(1AREF . 3)
(NAREF . 6)
(LAREF . 7)))
(DECLARE: EVAL@COMPILE DONTCOPY
[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
[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 (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 (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 (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 (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 (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 (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 (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 (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
(SHRINK-VECTOR
(CL:LAMBDA (VECTOR NEW-SIZE) (* raf " 4-Dec-85 00:21")
(COND
((type? ARRAYP VECTOR)
(freplace (ARRAYP LENGTH) of VECTOR with NEW-SIZE))
((type? STRINGP VECTOR)
(freplace (STRINGP LENGTH) of VECTOR with NEW-SIZE))
((AND (type? ARRAY VECTOR)
(IEQP 1 (ffetch (ARRAY RANK) of VECTOR)))
(freplace (ARRAY TOTAL.SIZE) of VECTOR with NEW-SIZE))
(T (ERROR "Not a vector " VECTOR)))
VECTOR))
(\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 "11-Nov-85 14:16")
(for X in CMLARRAY.TYPE.TABLE thereis (IEQP (ffetch (CML.TYPE.ENTRY TYPE.NAME)
of X)
TYPE])
(\CML.OFFSET.EXPANDER
[LAMBDA (ENTRY OFFSET.EXPR) (* raf "11-Nov-85 14:16")
(LET ((BITS.PER.ELEMENT (ffetch (CML.TYPE.ENTRY BITS.PER.ELEMENT) of ENTRY))
(BITS.PER.ADDRESS.UNIT (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])
(SIMPLE-BIT-VECTOR-P
(CL:LAMBDA (VECTOR)
(AND (SIMPLE-VECTOR-P VECTOR)
(BIT-VECTOR-P VECTOR))))
(SIMPLE-VECTOR-P
[CL:LAMBDA (VECTOR) (* raf " 2-Oct-85 17:43")
(AND (OR (type? ARRAYP VECTOR)
(AND (type? ARRAY VECTOR)
(IEQP 1 (ARRAY-RANK VECTOR))
(SIMPLE-ARRAY-P VECTOR)))
(IEQP \AT.POINTER (\CML.GENERIC.ELEMENT.TYPE VECTOR])
(BIT-VECTOR-P
[CL:LAMBDA (VECTOR)
(AND (VECTORP VECTOR)
(EQ (ARRAY-ELEMENT-TYPE VECTOR)
(QUOTE BIT])
(SIMPLE-ARRAY-P
[CL:LAMBDA (ARRAY) (* raf " 2-Oct-85 18:27")
(OR (type? STRINGP ARRAY)
(type? ARRAYP ARRAY)
(type? BITMAP ARRAY)
(AND (type? ARRAY ARRAY)
(NOT (OR (ffetch (ARRAY DISPLACED.TO) of ARRAY)
(ffetch (ARRAY HAS.FILL.POINTER) of ARRAY)
(ffetch (ARRAY ADJUSTABLE.P) of ARRAY])
)
(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
"28-Jan-86 15:29")
(* * 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 CHARACTER)
\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 (OR (FMEMB ELEMENTTYPE (USERDATATYPES))
(GETPROP ELEMENTTYPE (QUOTE DEFTYPE)))
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 "11-Nov-85 14:14")
(LET* [(TYPE.ENTRY (OR (\CML.GET.TYPE.ENTRY (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 FUN CHECKFLG) (* raf "11-Nov-85 21:37")
(LET* ((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 (OR (EVAL (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)
(IGEQ \Index (ffetch (ARRAY TOTAL.SIZE)
of (DATATYPE.ARRAY
\Array
(QUOTE ARRAY]
(ERROR \Array , (KWOTE FUN)))
, 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)
(QUOTE \Index)
SETTINGFORM)
else (BQUOTE ([LAMBDA (\Index)
(DECLARE (LOCALVARS \Index))
, SETTINGFORM]
,
(\AREFSET.INDEXFORM INDICES]
[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 "11-Nov-85 21:35")
(* 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 on INDICES while (CDR I)
do (* First, compose the chain of accesses through the
margin arrays, if any.)
[SETQ MARGINACCFORM (BQUOTE (\GETBASEPTR , MARGINACCFORM
(LLSH , (CAR I)
1]
finally (SETQ INDICES (BQUOTE (IPLUS , MARGINACCFORM , (CAR I]
(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 " 6-Nov-85 19:56")
(* * Returns the length of a block in elements to hold the given dimensions)
(if (IGREATERP (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 (IGREATERP I ARRAY-DIMENSION-LIMIT)
then (ERROR (CONCAT NAME " must be < ARRAY-DIMENSION-LIMIT")
I))
(SETQ #ELTS (ITIMES #ELTS I))
finally (if (IGREATERP #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 " 6-Nov-85 16:02")
(* * *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* ((SIZE (ARRAY-TOTAL-SIZE V))
(END.INDEX (SUB1 SIZE))
LENSTR LENLENSTR 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)))
(SETQ LENSTR (if (NOT (IEQP FINAL.INDEX (SUB1 SIZE)))
then (MKSTRING SIZE)
else ""))
(SETQ LENLENSTR (NCHARS LENSTR))
(* * Setup string, watching for end condition)
(LET [(STR (ALLOCSTRING (IPLUS 3 FINAL.INDEX LENLENSTR]
(* * The prefix character)
(RPLSTRING STR 1 \CML.READPREFIX)
(* * Put length into string)
(RPLSTRING STR 2 LENSTR)
(* * The "bit vector" character)
(RPLSTRING STR (IPLUS 2 LENLENSTR)
"*")
(* * The digits of the bit vector)
[bind (OFFSET ← (IPLUS 3 LENLENSTR)) for J from 0 to FINAL.INDEX
do (RPLCHARCODE STR (IPLUS J OFFSET)
(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 AREF ADJUST-ARRAY
VECTOR MAKE-ARRAY ASET)
)
(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)
(FILES CMLARRAYINSPECTOR)
(DECLARE: EVAL@COMPILE DONTCOPY (* * Utilities)
(MACROS \CHECKTYPE \INDEXABLE.FIXP DATATYPE.TEST))
(COMS (* * The implementation-)
(DECLARE: DONTCOPY EVAL@COMPILE (*)
(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 (* * Encapsulation of type specifics)
[DECLARE: DONTCOPY EVAL@COMPILE (*)
(CONSTANTS * CMLARRAYTYPES)
(CONSTANTS [CMLARRAY.TYPE.TABLE
(BQUOTE ([, \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]
[CML.SETTOR.TO.TYPE.ALIST (BQUOTE ((XASET ., \AT.XPOINTER)
(PASET ., \AT.POINTER)
(8ASET ., \AT.BYTE)
(16ASET ., \AT.SMALLPOSP)
(1ASET ., \AT.BIT)
(NASET ., \AT.FIXP)
(LASET ., \AT.FLOATP]
(CML.ACCESSOR.TO.TYPE.ALIST (BQUOTE ((XAREF ., \AT.XPOINTER)
(PAREF ., \AT.POINTER)
(8AREF ., \AT.BYTE)
(16AREF .,
\AT.SMALLPOSP)
(1AREF ., \AT.BIT)
(NAREF ., \AT.FIXP)
(LAREF ., \AT.FLOATP]
(VARS * CMLARRAYTYPES)
(VARS CMLARRAY.TYPE.TABLE CML.SETTOR.TO.TYPE.ALIST
CML.ACCESSOR.TO.TYPE.ALIST)
(DECLARE: EVAL@COMPILE DONTCOPY (*)
(RECORDS CML.TYPE.ENTRY)
(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 SHRINK-VECTOR \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 SIMPLE-BIT-VECTOR-P SIMPLE-VECTOR-P BIT-VECTOR-P
SIMPLE-ARRAY-P)
(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])
(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 1986))
(DECLARE: DONTCOPY
(FILEMAP (NIL (37367 39278 (SHRINK-VECTOR 37377 . 37945) (\CML.GENERIC.ELEMENT.TYPE 37947 . 38473) (
\CML.ARRAYP.TYPE.TO.CML.TYPE 38475 . 38966) (\CML.BITMAP.TYPE.TO.CML.TYPE 38968 . 39276)) (39279 40079
(\CML.GET.TYPE.ENTRY 39289 . 39541) (\CML.OFFSET.EXPANDER 39543 . 40077)) (43499 45062 (CL:ARRAYP
43509 . 43740) (VECTORP 43742 . 44012) (SIMPLE-BIT-VECTOR-P 44014 . 44139) (SIMPLE-VECTOR-P 44141 .
44477) (BIT-VECTOR-P 44479 . 44620) (SIMPLE-ARRAY-P 44622 . 45060)) (45063 45427 (
\ARRAY.DIMENSIONS.MATCH 45073 . 45425)) (46276 50916 (\DISPLACEARRAY 46286 . 47190) (
\CML.DCHAIN.UPDATE 47192 . 48011) (\CML.LINK.ARRAY 48013 . 49537) (\CML.UNLINK.ARRAY 49539 . 50914)) (
50917 64060 (SLOW.COPY.ELEMENT.INTO.ARRAY 50927 . 52691) (\COPYARRAY 52693 . 54999) (
\CML.ELEMENT.INITIALIZE 55001 . 55656) (\CML.CONTENT.INITIALIZE 55658 . 57736) (
\FLAT.COPY.ARRAY.TO.ARRAY 57738 . 58449) (\FLAT.COPY.LIST.TO.ARRAY 58451 . 58931) (COPY.LIST.TO.STRING
58933 . 59310) (COPY.STRING-CHAR.TO.SIMPLE-STRING 59312 . 59558) (COPY.ARRAY.TO.STRING 59560 . 60291)
(COPY.BITMAP.TO.ARRAY 60293 . 60967) (COPY.STRING.TO.ARRAY 60969 . 61593) (COPY.LIST.TO.BITMAP 61595
. 62290) (COPY.ARRAY.TO.BITMAP 62292 . 63084) (COPY.ELEMENT.TO.BITMAP 63086 . 63443) (
\CML.MAKE.STORAGE 63445 . 64058)) (64061 70093 (\CML.MS.ELEMENT.TYPE 64071 . 68646) (
\CML.ILTYPE.TO.CLTYPE 68648 . 70091)) (70094 71455 (\MARGINTO 70104 . 70412) (\MARGIN.ONE.DIMENSION
70414 . 71453)) (71456 71859 (\CML.ICP.CHECK 71466 . 71857)) (71860 86375 (MAKE-ARRAY 71870 . 78097) (
VECTOR 78099 . 78307) (ADJUST-ARRAY 78309 . 86373)) (86574 88418 (AREF 86584 . 87384) (ASET 87386 .
88416)) (88419 89958 (\AREF.1 88429 . 88839) (\AREF.2 88841 . 89177) (\ASET.1 89179 . 89612) (\ASET.2
89614 . 89956)) (90183 90905 (\AREFLINEAR 90193 . 90549) (\ASETLINEAR 90551 . 90903)) (90961 91133 (
\CML.CHARCODE 90971 . 91131)) (98376 104352 (\FastAREFexpander 98386 . 98615) (\NoSissyAREFexpander
98617 . 99714) (\FastASETexpander 99716 . 99983) (\NoSissyASETexpander 99985 . 103225) (
\AREFSET.INDEXFORM 103227 . 104350)) (104353 106451 (\CMLARRAY.LOCFTRAN 104363 . 106449)) (106518
106979 (SVREF 106528 . 106748) (SVSET 106750 . 106977)) (107029 107482 (BIT 107039 . 107212) (SBIT
107214 . 107388) (SBITSET 107390 . 107480)) (107666 108103 (CHAR 107676 . 107744) (SCHAR 107746 .
107914) (SCHARSET 107916 . 108101)) (108323 112810 (ARRAY-HAS-FILL-POINTER-P 108333 . 108660) (
FILL-POINTER 108662 . 109083) (FILL-POINTER-SET 109085 . 109723) (VECTOR-PUSH 109725 . 110594) (
VECTOR-PUSH-EXTEND 110596 . 111939) (VECTOR-POP 111941 . 112808)) (112879 113818 (
CML.DIMENSIONS.LINEAR.SIZE 112889 . 113816)) (113819 119559 (ADJUSTABLE-ARRAY-P 113829 . 114221) (
ARRAY-RANK 114223 . 114618) (ARRAY-DIMENSIONS 114620 . 115167) (ARRAY-DIMENSION 115169 . 116195) (
ARRAY-ELEMENT-TYPE 116197 . 116812) (ARRAY-IN-BOUNDS-P 116814 . 118160) (ARRAY-TOTAL-SIZE 118162 .
118673) (ARRAY-ROW-MAJOR-INDEX 118675 . 119557)) (119659 127697 (COPY.ARRAY.TO.LIST 119669 . 120013) (
\COPY.ARRAY.DIMENSION.TO.LIST 120015 . 121576) (FLAT.COPY.ARRAY.TO.LIST 121578 . 122078) (
\DEFPRINT.ARRAY 122080 . 122660) (\DEFPRINT.VECTOR 122662 . 123194) (\DEFPRINT.BITVECTOR 123196 .
125243) (\DEFPRINT.BITMAP 125245 . 126715) (LIST.VECTOR 126717 . 127695)) (127870 128489 (FILL.VECTOR
127880 . 128487)))))
STOP