(FILECREATED " 5-Aug-85 17:16:10" {DSK}<LISPFILES>ARRAY>CMLARRAY.;3 80557
changes to: (MACROS \CML.TYPEP)
(FNS COPY.ARRAY.TO.STRING \CML.MS.ELEMENT.TYPE MAKE-ARRAY ASET \FastAREFexpander)
(VARS \AT.STRING-CHAR)
previous date: " 2-Aug-85 18:28:35" {DSK}<LISPFILES>ARRAY>CMLARRAY.;1)
(* Copyright (c) 1982, 1983, 1984, 1985 by Xerox Corporation. All rights reserved.)
(PRETTYCOMPRINT CMLARRAYCOMS)
(RPAQQ CMLARRAYCOMS [(* * Commonlisp array facilities. This module implements Commonlisp's array
functionality. Missing are full Commonlisp type specifiers. Based on orginal
code by JonL White)
(DECLARE: EVAL@COMPILE DONTCOPY (* * Utilities)
(MACROS \CHECKTYPE \INDEXABLE.FIXP DATATYPE.TEST))
(CONSTANTS (* * Constants describing the limits of the implementation-)
(ARRAY-RANK-LIMIT (EXPT 2 7))
(ARRAY-TOTAL-SIZE-LIMIT (EXPT 2 23))
(ARRAY-DIMENSION-LIMIT (EXPT 2 23)))
(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)
(FNS \CML.GET.TYPE.ENTRY \CML.OFFSET.EXPANDER)
(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)))
(COMS (* * Headers which describe the array's structure and the storage it uses, and
functions directly relating to them.)
(RECORDS ARRAY VECTOR)
(FNS \ARRAY.DIMENSIONS.MATCH)
(TYPES ARRAY VECTOR)
(DECLARE: EVAL@COMPILE DONTCOPY (*)
(MACROS \CML.GENERIC.FETCH))
(MACROS ASETMACRO DATATYPE.ARRAY TYPE?.ARRAY)
(MACROS \CML.GETMARGIN))
(VARS (*PRINT-ARRAY* T))
(PROP SETFN AREF)
(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)
\COPYARRAY \CML.ELEMENT.INITIALIZE \CML.CONTENT.INITIALIZE
\FLAT.COPY.ARRAY.TO.ARRAY \FLAT.COPY.LIST.TO.ARRAY COPY.LIST.TO.STRING
COPY.ARRAY.TO.STRING \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 ADJUST-ARRAY)
(PROP ARGNAMES MAKE-ARRAY 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)
(PROP ARGNAMES AREF ASET)
(FNS AREF ASET)
(MACROS AREF ASET)
(FNS \AREFLINEAR \ASETLINEAR)
(FNS \AREF.1 \ASET.1 \AREF.2 \ASET.2)
(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.)
(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 (* * Header info functions)
(FNS CML.DIMENSIONS.LINEAR.SIZE)
(MACROS ARRAY-RANK)
(FNS (*)
ADJUSTABLE-ARRAY-P ARRAY-RANK ARRAY-DIMENSIONS ARRAY-DIMENSION ARRAY-ELEMENT-TYPE
ARRAY-IN-BOUNDS-P ARRAY-TOTAL-SIZE ARRAY-ELEMENT-SIZE-IN-BITS
ARRAY-ROW-MAJOR-INDEX)
(PROP ARGNAMES ARRAY-IN-BOUNDS-P ARRAY-ROW-MAJOR-INDEX))
(* * Array IO)
(COMS (* * Array IO)
(VARS \CML.READPREFIX)
(FNS (* Output)
COPY.ARRAY.TO.LIST \COPY.ARRAY.DIMENSION.TO.LIST FLAT.COPY.ARRAY.TO.LIST
DEFPRINT.ARRAY DEFPRINT.VECTOR DEFPRINT.BITVECTOR LIST.VECTOR)
(P (DEFPRINT (QUOTE ARRAY)
(QUOTE DEFPRINT.ARRAY))
(DEFPRINT (QUOTE VECTOR)
(QUOTE DEFPRINT.VECTOR)))
(FNS (* Input)
FILL.VECTOR \ESTIMATE.DIMENSIONALITY))
(* * Compiler gronk)
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
(ADDVARS (NLAMA)
(NLAML)
(LAMA ARRAY-ROW-MAJOR-INDEX ARRAY-IN-BOUNDS-P ASET AREF MAKE-ARRAY
ADJUST-ARRAY])
(* * Commonlisp array facilities. This module implements Commonlisp's array functionality.
Missing are full Commonlisp type specifiers. 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]
)
)
(DECLARE: EVAL@COMPILE
(RPAQ ARRAY-RANK-LIMIT (EXPT 2 7))
(RPAQ ARRAY-TOTAL-SIZE-LIMIT (EXPT 2 23))
(RPAQ ARRAY-DIMENSION-LIMIT (EXPT 2 23))
(CONSTANTS (ARRAY-RANK-LIMIT (EXPT 2 7))
(ARRAY-TOTAL-SIZE-LIMIT (EXPT 2 23))
(ARRAY-DIMENSION-LIMIT (EXPT 2 23)))
)
(* * 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 \GETBASEBYTE \PUTBASEBYTE BITSPERBYTE BITSPERBYTE 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)
)
(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])
)
(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 (CHAR-INT , 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]
)
)
(* * Headers which describe the array's structure and the storage it uses, and functions
directly relating to 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)))
(DATATYPE VECTOR (
(* * A simple vector with elements of any type)
(ELEMENT.TYPE BITS 4) (* Type number from CMLARRAYTYPES)
(ORIGIN BITS 1)
(NIL BITS 27)
(TOTAL.SIZE BITS 32)
(BASE POINTER))
(SYSTEM))
]
(/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))
(/DECLAREDATATYPE (QUOTE VECTOR)
(QUOTE ((BITS 4)
(BITS 1)
(BITS 27)
(BITS 32)
POINTER))
(QUOTE ((VECTOR 0 (BITS . 3))
(VECTOR 0 (BITS . 64))
(VECTOR 0 (LONGBITS . 90))
(VECTOR 2 (LONGBITS . 15))
(VECTOR 4 POINTER)))
(QUOTE 6))
(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])
)
(PUTDEF (QUOTE ARRAY) (QUOTE TYPES) [QUOTE
(DEFTYPE
ARRAY
(&OPTIONAL ELEMENT-TYPE DIMENSIONS)
(PROGN
[if (AND (NLISTP DIMENSIONS)
(NEQ DIMENSIONS (QUOTE *)))
then
(SETQ DIMENSIONS (to DIMENSIONS collect (QUOTE *]
(if
(AND (EQ ELEMENT-TYPE (QUOTE STRING-CHAR))
(EQLENGTH DIMENSIONS 1))
then
[if (EQUAL DIMENSIONS (QUOTE (*)))
then
(QUOTE (DATATYPE STRINGP))
else
(BQUOTE (AND (DATATYPE STRINGP)
(SATISFIES (LAMBDA (X)
(= (NCHARS X)
,
(CAR DIMENSIONS]
elseif
(NEQ ELEMENT-TYPE (QUOTE *))
then
[BQUOTE (AND (ARRAY * (\, DIMENSIONS))
(SATISFIES (LAMBDA
(X)
(EQ (ARRAY-ELEMENT-TYPE X)
(QUOTE (\, ELEMENT-TYPE]
else
(PROGN
(if
(AND (EQ ELEMENT-TYPE (QUOTE *))
(EQ DIMENSIONS (QUOTE *)))
then
(QUOTE (OR (DATATYPE ARRAY)
(DATATYPE VECTOR)
(DATATYPE STRING)))
elseif
(EQUAL DIMENSIONS (QUOTE (*)))
then
(if (EQ ELEMENT-TYPE (QUOTE STRING-CHAR))
then
(QUOTE STRING)
else
(QUOTE VECTOR))
elseif
(EQ ELEMENT-TYPE T)
then
[BQUOTE
(AND
ARRAY
(SATISFIES
(LAMBDA
(X)
,
(if
[OR (NLISTP DIMENSIONS)
(if [EVERY DIMENSIONS
(FUNCTION
(LAMBDA
(X)
(EQ X (QUOTE *]
then
(SETQ DIMENSIONS (LENGTH DIMENSIONS]
then
(BQUOTE (EQ (ARRAY-RANK X)
, DIMENSIONS))
ELSE
(BQUOTE (\ARRAY.DIMENSIONS.MATCH
(ARRAY-DIMENSIONS X)
(QUOTE , DIMENSIONS]
else
(HELP "Unimplemented array type designator"])
(PUTDEF (QUOTE VECTOR) (QUOTE TYPES) [QUOTE (DEFTYPE VECTOR (&OPTIONAL ELEMENT-TYPE SIZE)
(BQUOTE (ARRAY , ELEMENT-TYPE (, SIZE])
(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)
elseif
(type? VECTOR , FROM)
then
(ffetch (VECTOR , FIELD.NAME)
of , FROM)
else
(ERROR "Not an array" , FROM]
)
)
(DECLARE: EVAL@COMPILE
[DEFMACRO ASETMACRO (ARRAY &REST ARGS)
(BQUOTE (ASET (\, (CAR (LAST ARGS)))
(\, ARRAY)
(\,@ (LDIFF ARGS (LAST ARGS]
[PUTPROPS DATATYPE.ARRAY MACRO (LAMBDA (OBJECT)
(if (TYPE?.ARRAY OBJECT)
then OBJECT else (ERROR "Not an array" OBJECT]
[PUTPROPS TYPE?.ARRAY MACRO (LAMBDA (OBJECT)
(OR (type? VECTOR OBJECT)
(type? ARRAY OBJECT]
)
(DECLARE: EVAL@COMPILE
[DEFMACRO \CML.GETMARGIN (MARGIN INDEX)
(BQUOTE (\GETBASEPTR , MARGIN (LLSH , INDEX 1]
)
(RPAQQ *PRINT-ARRAY* T)
(PUTPROPS AREF SETFN ASETMACRO)
(DECLARE: DOEVAL@COMPILE DONTCOPY
(LOCALVARS . T)
)
(* * MAKE-ARRAY ADJUST-ARRAY and friends)
(DEFINEQ
(\DISPLACEARRAY
[LAMBDA (ARRAY DISPLACEDTO DISPLACEDINDEXOFFSET) (* raf "16-Jul-85 23:47")
(* * Check for compatible types)
(if (NOT (IEQP (ffetch (ARRAY ELEMENT.TYPE) of ARRAY)
(ffetch (ARRAY ELEMENT.TYPE) of DISPLACEDTO)))
then (ERROR "Displaced to array must have same type" (ffetch (ARRAY ELEMENT.TYPE)
of DISPLACEDTO)))
(* * Check for compatible sizes)
(if (IGREATERP (IPLUS (ffetch (ARRAY TOTAL.SIZE) of ARRAY)
DISPLACEDINDEXOFFSET)
(ffetch (ARRAY TOTAL.SIZE) of DISPLACEDTO))
then (ERROR "Displacing into an array that's too small"))
(\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 "14-Jul-85 21:57")
(* * If new displaced to array is adjustable, then Link to new displacement chain)
(if (ffetch (ARRAY ADJUSTABLE.P) of 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)
(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])
(\CML.UNLINK.ARRAY
[LAMBDA (ARRAY) (* raf "18-Jul-85 14:37")
(* * 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 (ffetch (ARRAY ADJUSTABLE.P) of ARRAY))
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
(\COPYARRAY
[LAMBDA (OLD.DIMS OLD OLD.MARGIN NEW.DIMS NEW.BASE NEW.MARGIN INITIAL.ELEMENT OOB.LEAVES.P)
(* raf " 2-Aug-85 16:19")
(* * 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 (for EDGE from 0 to MIN.AXIS
do (* Iterate along this edge)
(\COPYARRAY (CDR OLD.DIMS)
OLD
(\CML.GETMARGIN OLD.MARGIN (LLSH EDGE 1))
(CDR NEW.DIMS)
NEW.BASE
(\CML.GETMARGIN NEW.MARGIN (LLSH EDGE 1))
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 (LLSH EDGE 1))
(CDR NEW.DIMS)
NEW.BASE
(\CML.GETMARGIN NEW.MARGIN (LLSH EDGE 1))
INITIAL.ELEMENT T])
(\CML.ELEMENT.INITIALIZE
[LAMBDA (ARRAY INITIAL.ELEMENT) (* raf "30-Jul-85 15:56")
(* * 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 " 2-Aug-85 18:09")
(* * Can't do sequences, but this handles putting other arrays and list structure in)
(DATATYPE.ARRAY ARRAY)
(if (if (TYPE?.ARRAY 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?.ARRAY INITIAL.CONTENTS)
then (* fill the new array with another array)
(\FLAT.COPY.ARRAY.TO.ARRAY INITIAL.CONTENTS ARRAY)
else (* 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])
(\FLAT.COPY.ARRAY.TO.ARRAY
[LAMBDA (FROM TO) (* raf " 2-Aug-85 18:07")
(* * 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 (\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 " 2-Aug-85 18:08")
(* * 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 (\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 " 2-Aug-85 13:59")
(bind (I ← 0) for X in LIST do (RPLCHARCODE STRING (add I 1)
(CHAR-INT X])
(COPY.ARRAY.TO.STRING
[LAMBDA (ARRAY STRING) (* raf " 5-Aug-85 17:08")
(LET ((TOTAL.SIZE (ARRAY-TOTAL-SIZE ARRAY)))
(if (AND (IEQ (ARRAY-RANK ARRAY)
1)
(IEQ TOTAL.SIZE (NCHARS STRING)))
then [for I from 1 to TOTAL.SIZE do (RPLCHARCODE STRING I (CHAR-INT (AREF ARRAY
(SUB1 I]
else (ERROR "Bad array to initialize string" ARRAY])
(\CML.MAKE.STORAGE
[LAMBDA (#ELTS TYPE# INIT.ON.PAGE ALIGNMENT) (* raf " 2-Aug-85 14:25")
(LET ((#CELLS (FOLDHI (ADD1 (ITIMES #ELTS (\CML.BITS.PER.ELEMENT TYPE#)))
BITSPERCELL)))
(if (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 0 HAS.FILL.POINTER)
(DISPLACED-TO NIL D-TO-P)
DISPLACED-TO-BASE DISPLACED-INDEX-OFFSET PAGE-ALIGN ALIGNMENT)
(* raf " 5-Aug-85 17:11")
(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))
(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"))
(CHECK-TYPE DISPLACED-TO ARRAY)
(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 HAS.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 (SUB1 #ELTS))
else (if (GEQ FILL-POINTER #ELTS)
then (ERROR "Fill pointer out of bounds" FILL-POINTER]
(* * Standardize the element type)
(SETQ TYPE# (\CML.MS.ELEMENT.TYPE ELEMENT-TYPE))
(* * 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)
(if (AND (NULL IEP)
(NULL ICP))
then (SETQ IEP T)
(SETQ INITIAL-ELEMENT (\CML.TYPE.DEFAULT.VALUE TYPE#)))
(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))
(* * 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)
(NOT HAS.FILL.POINTER))
then
(* * Make a simple-string)
[SETQ ARRAY (ALLOCSTRING #ELTS (AND IEP (CHAR-INT INITIAL-ELEMENT]
(SETQ IEP NIL)
(if ICP
then (SETQ ICP NIL)
(if (LISTP INITIAL-CONTENTS)
then (COPY.LIST.TO.STRING INITIAL-CONTENTS ARRAY)
elseif (STRINGP INITIAL-CONTENTS)
then (RPLSTRING ARRAY 1 INITIAL-CONTENTS)
elseif (TYPE?.ARRAY INITIAL-CONTENTS)
then (COPY.ARRAY.TO.STRING INITIAL-CONTENTS ARRAY)
elseif (ERROR "Bad type for INITIAL-CONTENTS" INITIAL-CONTENTS)))
elseif (AND NIL (NOT ADJUSTABLE)
(NULL FILL-POINTER)
(NULL DISPLACED-TO)
(OR (EQ RANK 0)
(EQ RANK 1)))
then
(* * Make a simple array)
(SETQ ARRAY
(create VECTOR
ELEMENT.TYPE ← TYPE#
ORIGIN ← 0
TOTAL.SIZE ← #ELTS
BASE ← BASE))
else
(* * Make a "versatile" array)
(SETQ ARRAY
(create ARRAY
ORIGIN ← 0
RANK ← RANK
HAS.FILL.POINTER ← NIL
TOTAL.SIZE ← #ELTS
BASE ← BASE
BASE.OFFSET ← BASE.OFFSET
ELEMENT.TYPE ← TYPE#
MARGINS ← (\MARGINTO DIMENSIONS)
DIMENSIONS ← DIMENSIONS
ADJUSTABLE.P ← ADJUSTABLE
FILL.POINTER ← FILL-POINTER
DISPLACEE.START ← NIL)))
(* * Initialize the storage)
(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)))
(ADJUST-ARRAY
(CL:LAMBDA (ARRAY DIMENSIONS &REST OPTIONS &KEY (ELEMENT-TYPE T)
(INITIAL-ELEMENT NIL IEP)
INITIAL-CONTENTS ADJUSTABLE FILL-POINTER DISPLACED-TO DISPLACED-INDEX-OFFSET
DISPLACED-TO-BASE PAGE-ALIGN) (* lmm " 1-Aug-85 11:18")
(* * Adjust the size of an array, or alter some of its other parameters)
(* *)
(CHECK-TYPE ARRAY ARRAY)
(if (NLISTP DIMENSIONS)
then (SETQ DIMENSIONS (LIST DIMENSIONS)))
(LET ((RANK 0)
(#ELTS 1)
PAGE-ALIGN ALIGNMENT)
(if (NOT (ffetch (ARRAY ADJUSTABLE.P) of ARRAY))
then (ERROR "Array is not adjustable"))
(if DIMENSIONS
then (SETQ #ELTS (CML.DIMENSIONS.LINEAR.SIZE DIMENSIONS))
(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 (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 (CHECK-TYPE DISPLACED-TO ARRAY)
(OR (IEQP (ffetch (ARRAY ELEMENT.TYPE) of ARRAY)
(ffetch (ARRAY ELEMENT.TYPE) of DISPLACED-TO))
(ERROR "Mismatch of array element types" DISPLACED-TO)))
(* * Check for group argument conflicts)
(if (AND IEP INITIAL-CONTENTS)
then (ERROR (QUOTE Inconsistent% options)
(QUOTE (INITIAL-ELEMENT INITIAL-CONTENTS)))
elseif (AND DISPLACED-TO (OR IEP INITIAL-CONTENTS))
then [ERROR (QUOTE 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 (QUOTE 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 (CML.DIMENSIONS.LINEAR.SIZE DIMENSIONS))
(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)))
)
(PUTPROPS MAKE-ARRAY ARGNAMES (INDICES-LIST &KEY ELEMENT-TYPE INITIAL-ELEMENT INITIAL-CONTENTS
ADJUSTABLE FILL-POINTER DISPLACED-TO
DISPLACED-INDEX-OFFSET DISPLACED-TO-BASE PAGE-ALIGN
ALIGNMENT))
(PUTPROPS ADJUST-ARRAY ARGNAMES (ARRAY NEW-DIMENSIONS &KEY ELEMENT-TYPE INITIAL-ELEMENT
INITIAL-CONTENTS FILL-POINTER DISPLACED-TO
DISPLACED-INDEX-OFFSET DISPLACED-TO-BASE PAGE-ALIGN ALIGNMENT))
(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)
(PUTPROPS AREF ARGNAMES (ARRAY &REST SUBSCRIPTS))
(PUTPROPS ASET ARGNAMES (VALUE ARRAY &REST SUBSCRIPTS))
(DEFINEQ
(AREF
[LAMBDA NARGS (* raf " 2-Aug-85 18:28")
(* ARGS: (ARRAY &REST SUBSCRIPTS))
(OR (IGEQ NARGS 1)
(ERROR "Too few args" NARGS))
(SELECTQ NARGS
(2 (\AREF.1 (ARG NARGS 1)
(ARG NARGS 2)))
(LET ((ARRAY (ARG NARGS 1)))
(CHECK-TYPE ARRAY ARRAY)
(LET ((RANK (ARRAY-RANK ARRAY)))
(if (NEQ (SUB1 NARGS)
RANK)
then (if (GREATERP (SUB1 NARGS)
RANK)
then (ERROR "Too many subscripts for array reference.")
else (ERROR "Too few subscripts for array reference."))
else (\AREFLINEAR ARRAY (IPLUS (\AREFSET.LINEARIZE ARRAY 2 NARGS)
(if (type? ARRAY ARRAY)
then (ffetch (ARRAY BASE.OFFSET)
of ARRAY)
else 0])
(ASET
[LAMBDA NARGS (* raf " 5-Aug-85 16:31")
(SELECTQ NARGS
((0 1)
(ERROR "too few args to "))
(3 (\ASET.1 (ARG NARGS 1)
(ARG NARGS 2)
(ARG NARGS 3)))
(LET ((VAL (ARG NARGS 1))
(ARRAY (ARG NARGS 2))
RANK)
(CHECK-TYPE ARRAY ARRAY)
(if [NEQ NARGS (IPLUS 2 (SETQ RANK (ffetch (ARRAY RANK) of ARRAY]
then (ERROR "Array rank mismatch" ARRAY)
elseif (NOT (\CML.TYPEP (ffetch (ARRAY ELEMENT.TYPE) of ARRAY)
VAL))
then (ERROR "Value won't fit into array " VAL ARRAY)
else (\ASETLINEAR VAL ARRAY (IPLUS (\AREFSET.LINEARIZE ARRAY 3 NARGS)
(if (type? ARRAY ARRAY)
then (ffetch (ARRAY BASE.OFFSET)
of ARRAY)
else 0])
)
(DECLARE: EVAL@COMPILE
[PUTPROPS AREF MACRO (X (SELECTC (LENGTH X)
(2 (CONS (QUOTE \AREF.1)
X))
(3 (CONS (QUOTE \AREF.2)
X))
(QUOTE IGNOREMACRO]
[PUTPROPS ASET MACRO (X (SELECTC (LENGTH X)
(3 (CONS (QUOTE \ASET.1)
X))
(4 (CONS (QUOTE \ASET.2)
X))
(QUOTE IGNOREMACRO]
)
(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])
)
(DEFINEQ
(\AREF.1
[LAMBDA (ARRAY I) (* lmm " 1-Aug-85 18:00")
(if (STRINGP ARRAY)
then (INT-CHAR (NTHCHARCODE ARRAY (ADD1 I)))
else (\AREFLINEAR (THE ARRAY ARRAY)
(\AREFSET.LINEARIZE1 ARRAY I])
(\ASET.1
[LAMBDA (VAL ARRAY I) (* lmm " 1-Aug-85 18:04")
(if (STRINGP ARRAY)
then (RPLCHARCODE ARRAY (ADD1 I)
(CHAR-INT VAL))
VAL
else (\ASETLINEAR VAL (CHECK-TYPE ARRAY ARRAY)
(\AREFSET.LINEARIZE1 ARRAY I])
(\AREF.2
[LAMBDA (ARRAY I J) (* raf "10-Jul-85 03:18")
(SETQ ARRAY (DATATYPE.ARRAY ARRAY))
(\AREFLINEAR ARRAY (\AREFSET.LINEARIZE2 ARRAY I J])
(\ASET.2
[LAMBDA (VAL ARRAY I J) (* raf "10-Jul-85 03:18")
(SETQ ARRAY (DATATYPE.ARRAY ARRAY))
(\ASETLINEAR VAL ARRAY (\AREFSET.LINEARIZE2 ARRAY I J])
)
(DECLARE: EVAL@COMPILE DONTCOPY
(DECLARE: EVAL@COMPILE
[PUTPROPS \AREFSET.LINEARIZE MACRO ((A STARTAGRI LASTAGRI)
(for L on (ffetch (ARRAY DIMENSIONS)
of A)
as J from 2 bind (SETQ I 0)
(SETQ MARGINS (ffetch (ARRAY MARGINS)
of A))
do
(SETQ I (ARG NARGS J))
(if (NOT (FIXP I))
then
(ERROR I (QUOTE Array% index% not% FIXP))
elseif
(OR (ILESSP I 0)
(IGEQ I (CAR L)))
then
(ERROR I (QUOTE Array% index% out% of% bounds)))
[if (NULL (CDR L))
then
(* Final index is modified by the result of marginings.)
(OR (ILESSP (add I MARGINS)
(ffetch (ARRAY TOTAL.SIZE)
of A))
(SHOULDNT))
else
(* Go thru one margin array)
(SETQ MARGINS (\GETBASEPTR MARGINS (LLSH I 1]
finally
(RETURN I]
[PUTPROPS \AREFSET.LINEARIZE1 MACRO (OPENLAMBDA (A I)
(if (NEQ 1 (ffetch (ARRAY RANK)
of A))
then
(ERROR ARRAY (QUOTE Array% Rank% Mismatch))
elseif
(NOT (FIXP I))
then
(ERROR I (QUOTE Array% index% not% FIXP))
elseif
[OR (ILESSP I 0)
(IGEQ I (CAR (ffetch (ARRAY DIMENSIONS)
of A]
then
(ERROR I (QUOTE Array% index% out% of% bounds)))
(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 (QUOTE Array% Rank% Mismatch)))
(LET ((\DimensionsList (ffetch (ARRAY DIMENSIONS)
of A))
(\LinearIndex (ffetch (ARRAY MARGINS)
of A)))
(DECLARE (LOCALVARS \DimensionsList))
(if (NOT (FIXP I))
then
(ERROR I (QUOTE Array% index% not% FIXP))
elseif
(OR (ILESSP I 0)
(IGEQ I (pop \DimensionsList)))
then
(ERROR I (QUOTE
Array% index% out% of% bounds))
elseif
(OR (ILESSP J 0)
(IGEQ J (CAR \DimensionsList)))
then
(ERROR J (QUOTE
Array% index% out% of% bounds)))
(SETQ \LinearIndex
(IPLUS (\GETBASEPTR \LinearIndex
(LLSH I 1))
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 "30-Jul-85 15:47")
(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)
(IGREATERP \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])
)
(* * Header info functions)
(DEFINEQ
(CML.DIMENSIONS.LINEAR.SIZE
[LAMBDA (DIML) (* raf " 6-Jul-85 17:30")
(* * Returns the length of a block in elements to hold the given dimensions)
(LET ((#ELTS 1))
(for I in DIML
do (OR (AND (\INDEXABLE.FIXP I)
(IGEQ I 1))
(ERROR "Invalid dimension" I))
(SETQ #ELTS (ITIMES #ELTS I)))
#ELTS])
)
(DECLARE: EVAL@COMPILE
(PUTPROPS ARRAY-RANK MACRO ((A)
(fetch (ARRAY RANK)
of A)))
)
(DEFINEQ
(ADJUSTABLE-ARRAY-P
[LAMBDA (ARRAY) (* raf "29-Jul-85 15:04")
(if (type? VECTOR ARRAY)
then NIL
elseif (type? ARRAY ARRAY)
then (ffetch (ARRAY ADJUSTABLE.P) of ARRAY)
else (ERROR "Not an array of any kind" ARRAY])
(ARRAY-RANK
[LAMBDA (ARRAY) (* lmm " 1-Aug-85 09:27")
(fetch (ARRAY RANK) of ARRAY])
(ARRAY-DIMENSIONS
[LAMBDA (ARRAY) (* raf "29-Jul-85 15:04")
(if (type? VECTOR ARRAY)
then (LIST (ffetch (VECTOR TOTAL.SIZE) of ARRAY))
else (ffetch (ARRAY DIMENSIONS) of (DATATYPE.TEST ARRAY (QUOTE ARRAY])
(ARRAY-DIMENSION
[LAMBDA (ARRAY AXIS#) (* raf "29-Jul-85 15:04")
(if (NOT (\INDEXABLE.FIXP AXIS#))
then (ERRORX (BQUOTE (27 , AXIS#)))
elseif (type? VECTOR ARRAY)
then (if (NOT (IEQP AXIS# 0))
then (ERROR "Bad axis number" AXIS#)
else (SUB1 (ffetch (VECTOR TOTAL.SIZE) of ARRAY)))
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#))
else (DATATYPE.ARRAY ARRAY])
(ARRAY-ELEMENT-TYPE
[LAMBDA (ARRAY) (* raf "16-Jul-85 19:01")
(SELECTC (ffetch (ARRAY ELEMENT.TYPE) of (DATATYPE.ARRAY 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))
(SHOULDNT])
(ARRAY-IN-BOUNDS-P
[LAMBDA NARGS (* raf " 2-Aug-85 16:10")
(LET ((ARRAY (ARG NARGS 1)))
(CHECK-TYPE ARRAY ARRAY)
(if [NOT (IEQ NARGS (ADD1 (ARRAY-RANK ARRAY]
then (ERROR "Rank mismatch" (LIST ARRAY NARGS)))
(NOT (find I in (ARRAY-DIMENSIONS ARRAY) as K from 2 suchthat (OR (IGREATERP 0
(ARG NARGS K))
(ILEQ I (ARG NARGS K])
(ARRAY-TOTAL-SIZE
[LAMBDA (ARRAY) (* raf "30-Jul-85 15:49")
(\CML.GENERIC.FETCH ARRAY TOTAL.SIZE])
(ARRAY-ELEMENT-SIZE-IN-BITS
[LAMBDA (ARRAY) (* raf "30-Jul-85 15:52")
(\CML.BITS.PER.ELEMENT (\CML.GENERIC.FETCH ARRAY ELEMENT.TYPE])
(ARRAY-ROW-MAJOR-INDEX
[LAMBDA NARGS (* lmm "31-Jul-85 21:00")
"Returns the index into the Array's data vector for the given subscripts."
(OR (IGEQ NARGS 1)
(ERROR (QUOTE Too% few% args)))
(LET ((ARRAY (ARG NARGS 1)))
(CHECK-TYPE ARRAY ARRAY)
(if (NEQ NARGS (ADD1 (ffetch (ARRAY RANK) of ARRAY)))
then (ERROR ARRAY (QUOTE Array% Rank% Mismatch))
else (\AREFSET.LINEARIZE ARRAY 2 NARGS])
)
(PUTPROPS ARRAY-IN-BOUNDS-P ARGNAMES (ARRAY &REST SUBSCRIPTS))
(PUTPROPS ARRAY-ROW-MAJOR-INDEX ARGNAMES (ARRAY &REST SUBSCRIPTS))
(* * Array IO)
(* * Array IO)
(RPAQQ \CML.READPREFIX #)
(DEFINEQ
(COPY.ARRAY.TO.LIST
[LAMBDA (ARRAY) (* lmm " 1-Aug-85 11:14")
(\COPY.ARRAY.DIMENSION.TO.LIST ARRAY (fetch (ARRAY MARGINS) of ARRAY)
(ARRAY-DIMENSIONS ARRAY])
(\COPY.ARRAY.DIMENSION.TO.LIST
[LAMBDA (ARRAY MARGIN DIMENSIONS) (* lmm " 1-Aug-85 11:14")
(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 (SUB1 (CAR DIMENSIONS)) collect (\CML.TYPED.GET TYPE BASE
(IPLUS MARGIN
OFFSET I]
else (for I from 0 to (SUB1 (CAR DIMENSIONS)) collect (\COPY.ARRAY.DIMENSION.TO.LIST
ARRAY
(\CML.GETMARGIN MARGIN I)
(CDR DIMENSIONS])
(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) (* lmm " 1-Aug-85 11:15")
(* * This is the DEFPRINT function for the ARRAY type)
(if *PRINT-ARRAY*
then (if (IEQP 1 (ARRAY-RANK A))
then (DEFPRINT.VECTOR A)
else (CONS (CONCAT \CML.READPREFIX (ARRAY-RANK A)
(QUOTE A))
(COPY.ARRAY.TO.LIST A])
(DEFPRINT.VECTOR
[LAMBDA (V) (* lmm " 1-Aug-85 09:53")
(if *PRINT-ARRAY*
then (if (IEQP (\CML.GENERIC.FETCH V ELEMENT.TYPE)
\AT.BIT)
then (DEFPRINT.BITVECTOR V)
else (CONS (CONCAT \CML.READPREFIX (ARRAY-TOTAL-SIZE V))
(LIST.VECTOR V])
(DEFPRINT.BITVECTOR
[LAMBDA (V) (* lmm " 1-Aug-85 09:13")
(LET* ((SIZE (\CML.GENERIC.FETCH V TOTAL.SIZE))
(STR (ALLOCSTRING (IPLUS 2 SIZE)))
(BASE (\CML.GENERIC.FETCH V BASE)))
(RPLSTRING STR 1 \CML.READPREFIX)
(RPLSTRING STR 2 "*")
[for I from 2 to (IPLUS SIZE 2) as J from 0 to (SUB1 SIZE)
do (RPLCHARCODE STR I (IPLUS (\CML.TYPED.GET \AT.BIT BASE J)
(CONSTANT (CHARCODE 0]
(CONS STR NIL])
(LIST.VECTOR
[LAMBDA (ARRAY) (* lmm " 1-Aug-85 10:06")
(* * DEFPRINT formatting function for one dimensional arrays or vectors. Note that this compresses the list
representation by cutting off eq tail elements.)
(SETQ ARRAY (DATATYPE.ARRAY ARRAY))
(LET [(START.INDEX (if (type? ARRAY ARRAY)
then 0
elseif (ffetch (ARRAY HAS.FILL.POINTER) of ARRAY)
then (IPLUS (ffetch (ARRAY FILL.POINTER) of ARRAY)
(ffetch (ARRAY BASE.OFFSET) of ARRAY))
else (ffetch (ARRAY BASE.OFFSET) of ARRAY)))
(END.INDEX (SUB1 (ffetch (ARRAY TOTAL.SIZE) of ARRAY]
(* *)
(for J from (SUB1 END.INDEX) to START.INDEX while (EQ (\AREFLINEAR ARRAY J)
(\AREFLINEAR ARRAY END.INDEX))
do (SETQ END.INDEX J))
(for I from START.INDEX to END.INDEX collect (\AREFLINEAR ARRAY I])
)
(DEFPRINT (QUOTE ARRAY)
(QUOTE DEFPRINT.ARRAY))
(DEFPRINT (QUOTE VECTOR)
(QUOTE DEFPRINT.VECTOR))
(DEFINEQ
(FILL.VECTOR
[LAMBDA (ARRAY LIST) (* raf "24-Jul-85 12:58")
(* * FILL.VECTOR repeats the last element in LIST if it was too short to fill the array)
(SETQ ARRAY (DATATYPE.ARRAY ARRAY))
(OR (LISTP LIST)
(SETQ LIST (LIST LIST)))
(LET [(ITEM (CAR LIST))
(START.INDEX (ffetch (ARRAY BASE.OFFSET) of ARRAY))
(END.INDEX (SUB1 (ffetch (ARRAY TOTAL.SIZE) of ARRAY]
(* *)
[for I from START.INDEX to END.INDEX
do (\ASETLINEAR ITEM ARRAY I)
(pop LIST)
(if LIST
then (SETQ ITEM (CAR LIST]
ARRAY])
(\ESTIMATE.DIMENSIONALITY
[LAMBDA (LIST) (* raf "30-Jul-85 00:55")
(LET ((DIM (LENGTH LIST)))
(if (CONSP LIST)
then (APPEND (LIST DIM)
(\ESTIMATE.DIMENSIONALITY (CAR LIST)))
else NIL])
)
(* * Compiler gronk)
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
(ADDTOVAR NLAMA )
(ADDTOVAR NLAML )
(ADDTOVAR LAMA ARRAY-ROW-MAJOR-INDEX ARRAY-IN-BOUNDS-P ASET AREF MAKE-ARRAY ADJUST-ARRAY)
)
(PRETTYCOMPRINT CMLARRAYCOMS)
(RPAQQ CMLARRAYCOMS [(* * Commonlisp array facilities. This module implements Commonlisp's array
functionality. Missing are full Commonlisp type specifiers. Based on orginal
code by JonL White)
(DECLARE: EVAL@COMPILE DONTCOPY (* * Utilities)
(MACROS \CHECKTYPE \INDEXABLE.FIXP DATATYPE.TEST))
(CONSTANTS (* * Constants describing the limits of the implementation-)
(ARRAY-RANK-LIMIT (EXPT 2 7))
(ARRAY-TOTAL-SIZE-LIMIT (EXPT 2 23))
(ARRAY-DIMENSION-LIMIT (EXPT 2 23)))
(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)
(FNS \CML.GET.TYPE.ENTRY \CML.OFFSET.EXPANDER)
(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)))
(COMS (* * Headers which describe the array's structure and the storage it uses, and
functions directly relating to them.)
(RECORDS ARRAY VECTOR)
(FNS \ARRAY.DIMENSIONS.MATCH)
(TYPES ARRAY VECTOR)
(DECLARE: EVAL@COMPILE DONTCOPY (*)
(MACROS \CML.GENERIC.FETCH))
(MACROS ASETMACRO DATATYPE.ARRAY TYPE?.ARRAY)
(MACROS \CML.GETMARGIN))
(VARS (*PRINT-ARRAY* T))
(PROP SETFN AREF)
(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)
\COPYARRAY \CML.ELEMENT.INITIALIZE \CML.CONTENT.INITIALIZE
\FLAT.COPY.ARRAY.TO.ARRAY \FLAT.COPY.LIST.TO.ARRAY COPY.LIST.TO.STRING
COPY.ARRAY.TO.STRING \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 ADJUST-ARRAY)
(PROP ARGNAMES MAKE-ARRAY 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)
(PROP ARGNAMES AREF ASET)
(FNS AREF ASET)
(MACROS AREF ASET)
(FNS \AREFLINEAR \ASETLINEAR)
(FNS \AREF.1 \ASET.1 \AREF.2 \ASET.2)
(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.)
(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 (* * Header info functions)
(FNS CML.DIMENSIONS.LINEAR.SIZE)
(MACROS ARRAY-RANK)
(FNS (*)
ADJUSTABLE-ARRAY-P ARRAY-RANK ARRAY-DIMENSIONS ARRAY-DIMENSION ARRAY-ELEMENT-TYPE
ARRAY-IN-BOUNDS-P ARRAY-TOTAL-SIZE ARRAY-ELEMENT-SIZE-IN-BITS
ARRAY-ROW-MAJOR-INDEX)
(PROP ARGNAMES ARRAY-IN-BOUNDS-P ARRAY-ROW-MAJOR-INDEX))
(* * Array IO)
(COMS (* * Array IO)
(VARS \CML.READPREFIX)
(FNS (* Output)
COPY.ARRAY.TO.LIST \COPY.ARRAY.DIMENSION.TO.LIST FLAT.COPY.ARRAY.TO.LIST
DEFPRINT.ARRAY DEFPRINT.VECTOR DEFPRINT.BITVECTOR LIST.VECTOR)
(P (DEFPRINT (QUOTE ARRAY)
(QUOTE DEFPRINT.ARRAY))
(DEFPRINT (QUOTE VECTOR)
(QUOTE DEFPRINT.VECTOR)))
(FNS (* Input)
FILL.VECTOR \ESTIMATE.DIMENSIONALITY))
(* * Compiler gronk)
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
(ADDVARS (NLAMA)
(NLAML)
(LAMA ARRAY-ROW-MAJOR-INDEX ARRAY-IN-BOUNDS-P ASET AREF ADJUST-ARRAY
MAKE-ARRAY])
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
(ADDTOVAR NLAMA )
(ADDTOVAR NLAML )
(ADDTOVAR LAMA ARRAY-ROW-MAJOR-INDEX ARRAY-IN-BOUNDS-P ASET AREF ADJUST-ARRAY MAKE-ARRAY)
)
(PUTPROPS CMLARRAY COPYRIGHT ("Xerox Corporation" 1982 1983 1984 1985))
(DECLARE: DONTCOPY
(FILEMAP (NIL (9259 10074 (\CML.GET.TYPE.ENTRY 9269 . 9529) (\CML.OFFSET.EXPANDER 9531 . 10072)) (
16871 17220 (\ARRAY.DIMENSIONS.MATCH 16881 . 17218)) (20347 24460 (\DISPLACEARRAY 20357 . 21223) (
\CML.DCHAIN.UPDATE 21225 . 22040) (\CML.LINK.ARRAY 22042 . 23081) (\CML.UNLINK.ARRAY 23083 . 24458)) (
24461 31353 (\COPYARRAY 24471 . 26696) (\CML.ELEMENT.INITIALIZE 26698 . 27355) (
\CML.CONTENT.INITIALIZE 27357 . 28839) (\FLAT.COPY.ARRAY.TO.ARRAY 28841 . 29581) (
\FLAT.COPY.LIST.TO.ARRAY 29583 . 30059) (COPY.LIST.TO.STRING 30061 . 30293) (COPY.ARRAY.TO.STRING
30295 . 30789) (\CML.MAKE.STORAGE 30791 . 31351)) (31354 36223 (\CML.MS.ELEMENT.TYPE 31364 . 34743) (
\CML.ILTYPE.TO.CLTYPE 34745 . 36221)) (36224 37523 (\MARGINTO 36234 . 36534) (\MARGIN.ONE.DIMENSION
36536 . 37521)) (37524 37928 (\CML.ICP.CHECK 37534 . 37926)) (37929 50542 (MAKE-ARRAY 37939 . 42669) (
ADJUST-ARRAY 42671 . 50540)) (51320 53254 (AREF 51330 . 52301) (ASET 52303 . 53252)) (53583 54307 (
\AREFLINEAR 53593 . 53951) (\ASETLINEAR 53953 . 54305)) (54308 55344 (\AREF.1 54318 . 54603) (\ASET.1
54605 . 54916) (\AREF.2 54918 . 55129) (\ASET.2 55131 . 55342)) (58319 64187 (\FastAREFexpander 58329
. 58558) (\NoSissyAREFexpander 58560 . 59605) (\FastASETexpander 59607 . 59877) (\NoSissyASETexpander
59879 . 63111) (\AREFSET.INDEXFORM 63113 . 64185)) (64188 66125 (\CMLARRAY.LOCFTRAN 64198 . 66123)) (
66160 66609 (CML.DIMENSIONS.LINEAR.SIZE 66170 . 66607)) (66704 70277 (ADJUSTABLE-ARRAY-P 66714 . 67046
) (ARRAY-RANK 67048 . 67205) (ARRAY-DIMENSIONS 67207 . 67524) (ARRAY-DIMENSION 67526 . 68260) (
ARRAY-ELEMENT-TYPE 68262 . 68841) (ARRAY-IN-BOUNDS-P 68843 . 69370) (ARRAY-TOTAL-SIZE 69372 . 69531) (
ARRAY-ELEMENT-SIZE-IN-BITS 69533 . 69727) (ARRAY-ROW-MAJOR-INDEX 69729 . 70275)) (70491 74456 (
COPY.ARRAY.TO.LIST 70501 . 70746) (\COPY.ARRAY.DIMENSION.TO.LIST 70748 . 71496) (
FLAT.COPY.ARRAY.TO.LIST 71498 . 72000) (DEFPRINT.ARRAY 72002 . 72424) (DEFPRINT.VECTOR 72426 . 72791)
(DEFPRINT.BITVECTOR 72793 . 73378) (LIST.VECTOR 73380 . 74454)) (74561 75602 (FILL.VECTOR 74571 .
75292) (\ESTIMATE.DIMENSIONALITY 75294 . 75600)))))
STOP