(FILECREATED " 9-Sep-84 20:30:38" {ERIS}<LISPCORE>LIBRARY>CMLARRAY.;4 57878
changes to: (VARS CMLARRAYCOMS)
previous date: " 7-Sep-84 22:52:48" {ERIS}<LISPCORE>LIBRARY>CMLARRAY.;3)
(* Copyright (c) 1982, 1983, 1984 by Xerox Corporation. All rights reserved.)
(PRETTYCOMPRINT CMLARRAYCOMS)
(RPAQQ CMLARRAYCOMS ((* CommonLisp array facilities.)
(DECLARE: EVAL@COMPILE DONTCOPY (CONSTANTS \AT.MOD.BIT)
(CONSTANTS * CMLARRAYTYPES)
(MACROS \MACRO.MX \CHECKTYPE \INDEXABLE.FIXP))
(RECORDS CMLARRAY)
(LOCALVARS . T)
(COMS (MACROS \0DIM.ASET)
(* Following macros likely differ in the various implementations but at least depend on
the \GETBASE... and \PUTBASE... series)
(MACROS DATATYPE.TEST \WORDREF.PTR \WORDSET.PTR \WORDSET.XPTR \WORDREF.FIXP
\WORDSET.FIXP \WORDREF.FLOATP \WORDSET.FLOATP \WORDREF.16 \WORDSET.16
\WORDREF.8 \WORDSET.8 \WORDREF.4 \WORDSET.4 \WORDREF.1 \WORDSET.1)
(FNS \BubbleWORDSET)
(DECLARE: EVAL@COMPILE DONTCOPY (FNS \BubbleWORDSET)))
(DECLARE: COPYWHEN (NEQ COMPILEMODE (QUOTE D))
(* Patch ups for non-D worlds)
(FILES MACROAUX)
(* Rather than forcibly load in NONDADDARITH we cause it to be loaded only when
compiling this file, or at "last moment" when absolutely needed.)
(FNS \NONDADDARITH.TRAMPOLINE)
(DECLARE: EVAL@LOADWHEN (NEQ (SYSTEMTYPE)
(QUOTE D))
(DECLARE: EVAL@COMPILEWHEN (NEQ COMPILEMODE (QUOTE D))
DONTCOPY
(P (OR (CONSTANTEXPRESSIONP (QUOTE PTRBLOCK.GCT))
(PROGN (SETQ PTRBLOCK.GCT 1)
(CONSTANTS PTRBLOCK.GCT))))
(FILES NONDADDARITH))
(P (MAPC (QUOTE (LOADBYTE DEPOSITEBYTE \GETBASEBIT \GETBASENIBBLE
\GETBASEBYTE \GETBASEDOUBLEBYTE \GETBASEFIXP
\GETBASEFLOATP \GETBASEPTR \PUTBASEBIT
\PUTBASENIBBLE \PUTBASEBYTE \PUTBASEDOUBLEBYTE
\PUTBASEFIXP \PUTBASEFLOATP \PUTBASEPTR))
(FUNCTION (LAMBDA (X)
(MOVD? (FUNCTION \NONDADDARITH.TRAMPOLINE)
X)))))))
(FNS MAKEARRAY \CML.ICP.CHECK \MARGINTO ADJUSTARRAY)
(FNS AREF ASET)
(MACROS AREF ASET)
(DECLARE: EVAL@COMPILE DONTCOPY (MACROS \AREFSET.LINEARIZE \AREFSET.LINEARIZE1
\AREFSET.LINEARIZE2))
(FNS \AREF.1 \ASET.1 \AREF.2 \ASET.2 \AREFLINEAR \ASETLINEAR)
(MACROS ARRAYRANK ARRAYDIMENSIONS ARRAYDIMENSION)
(FNS ARRAYRANK ARRAYDIMENSIONS ARRAYDIMENSION ARRAYELEMENTTYPE ARRAYINBOUNDSP ARRAYTOTALSIZE
ARRAYROWMAJORINDEX)
(PROP ARGNAMES MAKEARRAY AREF ASET ARRAYINBOUNDSP ADJUSTARRAY)
(COMS (* The "fast" versions of AREF and ASET -- following P causes them all to be set up as
macros)
(DECLARE: EVAL@COMPILE
(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 (MKATOM (CONCAT A B))
(QUOTE MACRO)
(LIST (QUOTE X)
(LIST (MKATOM (CONCAT "\Fast"
B
"expander"))
(QUOTE X)
(LIST (QUOTE QUOTE)
C))))
(PUTPROP C (QUOTE MACRO)
(LIST (QUOTE X)
(LIST (MKATOM (CONCAT
"\NoSissy"
B
"expander"))
(QUOTE X)
(LIST (QUOTE QUOTE)
C))))))))))))))
(FNS \FastAREFexpander \NoSissyAREFexpander \FastASETexpander \NoSissyASETexpander
\AREFSET.INDEXFORM \CMLARRAY.LOCFTRAN)
(INITVARS (AREFSissyFLG NIL))
(PROP GLOBALVAR AREFSissyFLG))
(FNS LISTARRAY FILLARRAY \PRINTCMLARRAY \READCMLARRAY)
(FILEPKGCOMS CMLARRAYS)
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
(ADDVARS (NLAMA)
(NLAML)
(LAMA ARRAYROWMAJORINDEX ARRAYINBOUNDSP ASET AREF ADJUSTARRAY MAKEARRAY
\NONDADDARITH.TRAMPOLINE)))))
(* CommonLisp array facilities.)
(DECLARE: EVAL@COMPILE DONTCOPY
(DECLARE: EVAL@COMPILE
(RPAQQ \AT.MOD.BIT 128)
(CONSTANTS \AT.MOD.BIT)
)
(RPAQQ CMLARRAYTYPES (\AT.POINTER \AT.FIXP \AT.WORD \AT.BYTE \AT.BIT \AT.FLOATP \AT.XPOINTER
\AT.NIBBLE \AT.DOUBLEBYTE))
(DECLARE: EVAL@COMPILE
(RPAQQ \AT.POINTER 2)
(RPAQQ \AT.FIXP 3)
(RPAQQ \AT.WORD 4)
(RPAQQ \AT.BYTE 5)
(RPAQQ \AT.BIT 6)
(RPAQQ \AT.FLOATP 7)
(RPAQQ \AT.XPOINTER 8)
(RPAQQ \AT.NIBBLE 9)
(RPAQQ \AT.DOUBLEBYTE 10)
(CONSTANTS \AT.POINTER \AT.FIXP \AT.WORD \AT.BYTE \AT.BIT \AT.FLOATP \AT.XPOINTER \AT.NIBBLE
\AT.DOUBLEBYTE)
)
(DECLARE: EVAL@COMPILE
(PUTPROPS \MACRO.MX MACRO (Z
(PROG ((X (EXPANDMACRO (CAR Z)
T)))
(COND
((EQ X (CAR Z))
(ERROR "No macro property -- \MACRO.MX" X))
(T (RETURN X))))))
(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)))))))))
(PUTPROPS \INDEXABLE.FIXP MACRO (OPENLAMBDA (X)
(AND (FIXP X)
(IGEQ X 0))))
(PUTPROPS \INDEXABLE.FIXP DMACRO (OPENLAMBDA (X)
(AND (SMALLP X)
(IGEQ X 0))))
)
)
[DECLARE: EVAL@COMPILE
(DATATYPE CMLARRAY ((CMLANCHOR POINTER)
(CMLANCHOROFFSET POINTER)
(CMLAETYPE BITS 8)
(CMLMARGINS POINTER)
(CMLMOD#P2P FLAG)
(CMLRANK BITS 7)
(CMLDIML POINTER)
(CMLALIGNHI BITS 8)
(CMLIMAX POINTER)
(CMLALIGNLO BITS 8)
(CMLMOD# POINTER))
(ACCESSFNS (CMLALIGN (LOGOR (LLSH (fetch CMLALIGNHI of DATUM)
8)
(fetch CMLALIGNLO of DATUM))
(PROGN (replace CMLALIGNHI of DATUM
with (LOADBYTE NEWVALUE 8 8))
(replace CMLALIGNLO of DATUM
with (LOADBYTE NEWVALUE 0 8))
NEWVALUE)))
(SYSTEM))
]
(/DECLAREDATATYPE (QUOTE CMLARRAY)
(QUOTE (POINTER POINTER (BITS 8)
POINTER FLAG (BITS 7)
POINTER
(BITS 8)
POINTER
(BITS 8)
POINTER)))
(DECLARE: DOEVAL@COMPILE DONTCOPY
(LOCALVARS)
)
(DECLARE: EVAL@COMPILE
(PUTPROPS \0DIM.ASET MACRO (OPENLAMBDA (FUNNAME \NewVal \Array)
(OR (ZEROP (ARRAYRANK \Array))
(ERROR \Array FUNNAME))
(freplace (CMLARRAY CMLANCHOR) of \Array with \NewVal)))
)
(* Following macros likely differ in the various implementations but at least depend on the
\GETBASE... and \PUTBASE... series)
(DECLARE: EVAL@COMPILE
(PUTPROPS DATATYPE.TEST MACRO (OPENLAMBDA (X TYPE)
(COND
((NOT (TYPENAMEP X TYPE))
(ERROR X (CONCAT (QUOTE Not% of% type% TYPE))))
(T X))))
(PUTPROPS DATATYPE.TEST DMACRO (= . \DTEST))
(PUTPROPS \WORDREF.PTR DMACRO ((ADDRESS I)
(\GETBASEPTR ADDRESS (PROG1 (LLSH I 1) (* (UNFOLD I WORDSPERCELL))
))))
(PUTPROPS \WORDREF.PTR MACRO (= . \GETBASEPTR))
(PUTPROPS \WORDSET.PTR DMACRO (X
(* (UNFOLD DATUM WORDSPERCELL))
(\BubbleWORDSET X (QUOTE \VectorSET))))
(PUTPROPS \WORDSET.PTR MACRO (X
(\BubbleWORDSET X (QUOTE \PUTBASEPTR))))
(PUTPROPS \WORDSET.XPTR DMACRO (X
(* (UNFOLD DATUM WORDSPERCELL))
(\BubbleWORDSET X (QUOTE \PUTBASEPTR)
(QUOTE (LLSH DATUM 1)))))
(PUTPROPS \WORDSET.XPTR MACRO (X
(\BubbleWORDSET X (QUOTE \PUTBASEPTR))))
(PUTPROPS \WORDREF.FIXP DMACRO ((ADDRESS I)
(\GETBASEFIXP ADDRESS (PROG1 (LLSH I 1) (* (UNFOLD I WORDSPERCELL))
))))
(PUTPROPS \WORDREF.FIXP MACRO (= . \GETBASEFIXP))
(PUTPROPS \WORDSET.FIXP DMACRO (X
(* (UNFOLD DATUM WORDSPERCELL))
(\BubbleWORDSET X (QUOTE \PUTBASEFIXP)
(QUOTE (LLSH DATUM 1)))))
(PUTPROPS \WORDSET.FIXP MACRO (X
(\BubbleWORDSET X (QUOTE \PUTBASEFIXP))))
(PUTPROPS \WORDREF.FLOATP DMACRO ((ADDRESS I)
(\GETBASEFLOATP ADDRESS (PROG1 (LLSH I 1) (* (UNFOLD I WORDSPERCELL))
))))
(PUTPROPS \WORDREF.FLOATP MACRO (= . \GETBASEFLOATP))
(PUTPROPS \WORDSET.FLOATP DMACRO (X
(* (UNFOLD DATUM WORDSPERCELL))
(\BubbleWORDSET X (QUOTE \PUTBASEFLOATP)
(QUOTE (LLSH DATUM 1)))))
(PUTPROPS \WORDSET.FLOATP MACRO (X
(\BubbleWORDSET X (QUOTE \PUTBASEFLOATP))))
(PUTPROPS \WORDREF.16 DMACRO (= . \GETBASE))
(PUTPROPS \WORDREF.16 MACRO (=
. \GETBASEDOUBLEBYTE))
(PUTPROPS \WORDSET.16 DMACRO (X
(\BubbleWORDSET X (QUOTE \PUTBASE))))
(PUTPROPS \WORDSET.16 MACRO (X
(\BubbleWORDSET X (QUOTE \PUTBASEDOUBLEBYTE))))
(PUTPROPS \WORDREF.8 DMACRO ((ADDRESS I)
(\GETBASEBYTE ADDRESS I)))
(PUTPROPS \WORDREF.8 MACRO (= . \GETBASEBYTE))
(PUTPROPS \WORDSET.8 DMACRO (X
(\BubbleWORDSET X (QUOTE \PUTBASEBYTE))))
(PUTPROPS \WORDSET.8 MACRO (X
(\BubbleWORDSET X (QUOTE \PUTBASEBYTE))))
(PUTPROPS \WORDREF.4 DMACRO ((BASE OFFST)
(\GETBASENIBBLE BASE OFFST)))
(PUTPROPS \WORDREF.4 MACRO (= . \GETBASENIBBLE))
(PUTPROPS \WORDSET.4 DMACRO (X
(\BubbleWORDSET X (QUOTE \PUTBASENIBBLE))))
(PUTPROPS \WORDSET.4 MACRO (X
(\BubbleWORDSET X (QUOTE \PUTBASENIBBLE))))
(PUTPROPS \WORDREF.1 DMACRO ((ADDRESS I)
(\GETBASEBIT ADDRESS I)))
(PUTPROPS \WORDREF.1 MACRO (= . \GETBASEBIT))
(PUTPROPS \WORDSET.1 DMACRO (X
(\BubbleWORDSET X (QUOTE \PUTBASEBIT))))
(PUTPROPS \WORDSET.1 MACRO (X
(\BubbleWORDSET X (QUOTE \PUTBASEBIT))))
)
(DEFINEQ
(\BubbleWORDSET
(LAMBDA (X FUNNAME SHIFTFORM) (* JonL " 1-JUL-83 19:45")
(PROG ((VAL (LISPFORM.SIMPLIFY (CAR X)
T))
(BASE (LISPFORM.SIMPLIFY (CADR X)
T))
(OFFST (LISPFORM.SIMPLIFY (CADDR X)
T)))
(AND SHIFTFORM (SETQ OFFST (SUBST OFFST (QUOTE DATUM)
SHIFTFORM)))
(RETURN (if (AND (ARGS.COMMUTABLEP VAL BASE)
(ARGS.COMMUTABLEP VAL OFFST))
then (LIST FUNNAME BASE OFFST VAL)
else (LIST (LIST (QUOTE LAMBDA)
(QUOTE (\Val))
(QUOTE (DECLARE (SPECVARS \Val)))
(LIST FUNNAME BASE OFFST (QUOTE \Val)))
VAL))))))
)
(DECLARE: EVAL@COMPILE DONTCOPY
(DEFINEQ
(\BubbleWORDSET
(LAMBDA (X FUNNAME SHIFTFORM) (* JonL " 1-JUL-83 19:45")
(PROG ((VAL (LISPFORM.SIMPLIFY (CAR X)
T))
(BASE (LISPFORM.SIMPLIFY (CADR X)
T))
(OFFST (LISPFORM.SIMPLIFY (CADDR X)
T)))
(AND SHIFTFORM (SETQ OFFST (SUBST OFFST (QUOTE DATUM)
SHIFTFORM)))
(RETURN (if (AND (ARGS.COMMUTABLEP VAL BASE)
(ARGS.COMMUTABLEP VAL OFFST))
then (LIST FUNNAME BASE OFFST VAL)
else (LIST (LIST (QUOTE LAMBDA)
(QUOTE (\Val))
(QUOTE (DECLARE (SPECVARS \Val)))
(LIST FUNNAME BASE OFFST (QUOTE \Val)))
VAL))))))
)
)
(DECLARE: COPYWHEN (NEQ COMPILEMODE (QUOTE D))
(FILESLOAD MACROAUX)
(DEFINEQ
(\NONDADDARITH.TRAMPOLINE
(LAMBDA NARGS (* JonL "11-SEP-83 15:09")
(PROG ((FNAME (STKNAME (STKNTH -1))))
(OR (FMEMB FNAME (QUOTE (LOADBYTE DEPOSITBYTE)))
(AND FNAME (LITATOM FNAME)
(ILESSP 8 (NCHARS FNAME))
(FMEMB (SUBATOM FNAME 2 4)
(QUOTE (GET PUT)))
(EQ (SUBATOM FNAME 5 8)
(QUOTE BASE)))
(SHOULDNT (QUOTE \NONDADDARITH.TRAMPOLINE)))
(PUTD FNAME NIL)
(FILESLOAD (SYSLOAD COMPILED FROM LISPUSERS)
NONDADDARITH)
(if (NOT (DEFINEDP FNAME))
then (MOVD (FUNCTION \NONDADDARITH.TRAMPOLINE)
FNAME)
(ERROR FNAME "Apparently not defined in NONDADDARITH file?")
else (APPLY FNAME (for I to NARGS collect (ARG NARGS I)))))))
)
(DECLARE: EVAL@LOADWHEN (NEQ (SYSTEMTYPE)
(QUOTE D))
(DECLARE: EVAL@COMPILEWHEN (NEQ COMPILEMODE (QUOTE D)) DONTCOPY
(OR (CONSTANTEXPRESSIONP (QUOTE PTRBLOCK.GCT))
(PROGN (SETQ PTRBLOCK.GCT 1)
(CONSTANTS PTRBLOCK.GCT)))
(FILESLOAD NONDADDARITH)
)
(MAPC (QUOTE (LOADBYTE DEPOSITEBYTE \GETBASEBIT \GETBASENIBBLE \GETBASEBYTE \GETBASEDOUBLEBYTE
\GETBASEFIXP \GETBASEFLOATP \GETBASEPTR \PUTBASEBIT \PUTBASENIBBLE
\PUTBASEBYTE \PUTBASEDOUBLEBYTE \PUTBASEFIXP \PUTBASEFLOATP \PUTBASEPTR))
(FUNCTION (LAMBDA (X)
(MOVD? (FUNCTION \NONDADDARITH.TRAMPOLINE)
X))))
)
)
(DEFINEQ
(MAKEARRAY
(LAMBDA NARGS (* JonL " 7-Sep-84 22:49")
(PROG ((A.E.TYPE T)
(DIML (if (EQ NARGS 0)
then NIL
elseif (EVENP NARGS)
then (ERROR "Odd # of keywords")
elseif (NULL (ARG NARGS 1))
then NIL
else (OR (LISTP (ARG NARGS 1))
(LIST (ARG NARGS 1)))))
(#ROWS 0)
(#ELTS/ROW 0)
(#ELTS 1)
(RANK 0)
(ANCHOROFFSET 0)
(DAROFFSET 0)
(THISROWBASE 0)
(ALIGNMENT 0)
(GCTYPE UNBOXEDBLOCK.GCT)
MOD# DAR DARTYPE IV IEP ICP BITSPERELEMENT ANCHOR ARRAY)
(DECLARE (SPECVARS A.E.TYPE #ELTS/ROW THISROWBASE))
(if DIML
then (for I in DIML
do (OR (AND (\INDEXABLE.FIXP I)
(IGEQ I 1))
(ERROR "Invalid dimension" I))
(SETQ #ELTS (ITIMES (SETQ #ROWS #ELTS)
(SETQ #ELTS/ROW I))))
(SETQ RANK (FLENGTH DIML)))
(for I VAL from 2 by 2 until (IGREATERP I NARGS)
do (SETQ VAL (ARG NARGS (ADD1 I)))
(SELECTQ (ARG NARGS I)
(ELEMENTTYPE (SETQ A.E.TYPE VAL))
(INITIALELEMENT (SETQ IEP T)
(SETQ IV VAL))
(INITIALCONTENTS (SETQ ICP T)
(SETQ IV VAL))
(DISPLACEDTO (SETQ DAR (DATATYPE.TEST VAL (QUOTE CMLARRAY)))
(SETQ DARTYPE (ffetch CMLAETYPE of DAR)))
(DISPLACEDTOBASE (SETQ DAR VAL)
(SETQ DARTYPE))
(DISPLACEDINDEXOFFSET
(PROG NIL
(ERRORX (LIST (if (NOT (FIXP VAL))
then 10
elseif (OR (NOT (SMALLP VAL))
(ILESSP VAL 1))
then 27
else (* Jump out if no error!)
(RETURN))
VAL)))
(SETQ DAROFFSET VAL))
(ALIGNMENT (PROG NIL
(ERRORX (LIST (if (NOT (FIXP VAL))
then 10
elseif (OR (NOT (SMALLP VAL))
(ILESSP VAL 0))
then 27
else
(* Jump out if no error!)
(RETURN))
VAL)))
(SETQ ALIGNMENT VAL))
(FILLPOINTER (ERROR "FILLPOINTER option not yet implemented"))
(ERROR "Bad keyword" (ARG NARGS I))))
(* Process keyword arguments)
FINDTYPE
(SETQ BITSPERELEMENT BITSPERCELL) (* Default setting to most common case)
(SETQ A.E.TYPE
(SELECTQ
A.E.TYPE
((NIL T POINTER)
(SETQ GCTYPE PTRBLOCK.GCT)
\AT.POINTER)
((FIXP FIXNUM CELL)
\AT.FIXP)
((FLOATP FLONUM)
\AT.FLOATP)
((WORD SMALLPOSP)
(SELECTQ (SYSTEMTYPE)
(D (SETQ BITSPERELEMENT BITSPERWORD)
(SETQ MOD# (CONSTANT (LLSH 1 BITSPERWORD)))
\AT.WORD)
(ERROR "Only in Interlisp-D" A.E.TYPE)))
((DOUBLEBYTE)
(SETQ BITSPERELEMENT (CONSTANT (TIMES 2 BITSPERBYTE)))
(SETQ MOD# (CONSTANT (LLSH 1 (TIMES 2 BITSPERBYTE))))
\AT.DOUBLEBYTE)
((BYTE CHARACTER)
(SETQ BITSPERELEMENT BITSPERBYTE)
(SETQ MOD# (CONSTANT (LLSH 1 BITSPERBYTE)))
\AT.BYTE)
((NIBBLE)
(SETQ BITSPERELEMENT BITSPERNIBBLE)
(SETQ MOD# (CONSTANT (LLSH 1 BITSPERNIBBLE)))
\AT.NIBBLE)
((BIT)
(SETQ BITSPERELEMENT 1)
(SETQ MOD# 2)
\AT.BIT)
((XPOINTER)
\AT.XPOINTER)
(if (AND (EQ (CAR (LISTP A.E.TYPE))
(QUOTE MOD))
(NULL (CDDR A.E.TYPE))
(FIXP (SETQ MOD# (CADR A.E.TYPE)))
(ILESSP 1 MOD#))
then (PROG NIL
(SETQ A.E.TYPE
(CDR (OR (SASSOC MOD# (CONSTANT
(LIST (CONS (LLSH 1 1)
(QUOTE BIT))
(CONS (LLSH 1 BITSPERNIBBLE)
(QUOTE NIBBLE))
(CONS (LLSH 1 BITSPERBYTE)
(QUOTE BYTE))
(CONS (LLSH 1 (ITIMES 2 BITSPERBYTE))
(SELECTQ (SYSTEMTYPE)
(D (QUOTE WORD))
(QUOTE DOUBLEBYTE))))))
(RETURN)))) (* Only go to FINDTYPE if the SASSOC succeeds)
(GO FINDTYPE))
(SETQ BITSPERELEMENT (INTEGERLENGTH (SUB1 MOD#)))
(OR (ILESSP BITSPERELEMENT \AT.MOD.BIT)
(SHOULDNT "\AT.MOD.BIT"))
(SETQ A.E.TYPE (LOGOR \AT.MOD.BIT BITSPERELEMENT))
else (ERROR "Bad type specifier" A.E.TYPE))))
(* Standardize the type argument, and discern the number
of bits per element (and whether or not the elements are
pointers))
(if (NEQ ALIGNMENT 0)
then (SETQ #ELTS/ROW (ITIMES (IQUOTIENT (IPLUS #ELTS/ROW (SUB1 ALIGNMENT))
ALIGNMENT)
ALIGNMENT))
(SETQ #ELTS (ITIMES #ROWS #ELTS/ROW)))
(if IEP
then (* Check that any initial element specification is of
the right type.)
(if ICP
then (ERROR (QUOTE Inconsistent% options)
(QUOTE (INITIALELEMENT INITIALCONTENTS)))
elseif (SELECTC A.E.TYPE
((LIST \AT.FIXP \AT.WORD \AT.BYTE \AT.NIBBLE \AT.BIT)
(NOT (FIXP IV)))
(\AT.FLOATP (NOT (FLOATP IV)))
(if (IGEQ A.E.TYPE \AT.MOD.BIT)
then (NOT (FIXP IV))))
then (ERRORX (LIST 32 IV)))
elseif (AND ICP (NEQ RANK 0)
(if (type? CMLARRAY IV)
then (NOT (EQUAL DIML (ffetch CMLDIML of IV)))
elseif (LISTP IV)
then (* Must check to see if nested list structures have the
same dimensionality as the array we are creating.)
(\CML.ICP.CHECK DIML IV)
else (* Not any kind of nested structure)
T))
then (ERROR (QUOTE Dimensionality% Mismatch% for% InitialContents)
IV))
(if DAR
then (* Some consistency checks)
(if (OR IEP ICP (EQ RANK 0))
then (ERROR (QUOTE Inconsistent% options)
(APPEND (if IEP
then (QUOTE (INITIALELEMENT)))
(if ICP
then (QUOTE (INITIALCONTENTS)))
(if (EQ RANK 0)
then (QUOTE (Rank=0)))
(QUOTE (DISPLACEDTO))))
elseif (NULL DARTYPE)
then (* User just supplied a BASE address for the displacedto
array)
NIL
elseif (ILESSP (IDIFFERENCE (ADD1 (ffetch CMLIMAX of DAR))
DAROFFSET)
#ELTS)
then (ERROR "Attempt to displace to a cramped array" DAR)
elseif (NEQ (SELECTC A.E.TYPE
((LIST \AT.POINTER \AT.XPOINTER)
T)
NIL)
(SELECTC DARTYPE
((LIST \AT.POINTER \AT.XPOINTER)
T)
NIL))
then (ERROR (if (SELECTC A.E.TYPE
((LIST \AT.POINTER \AT.XPOINTER)
T)
NIL)
then "Displaceing pointer array to non-pointer one."
else "Displaceing non-pointer array to pointer one.")
DAR)))
(SETQ ANCHOR (if (EQ RANK 0)
then (if IEP
then (ERROR (QUOTE Inconsistent% options)
(QUOTE (Rank=0 INITIALELEMENT)))
elseif ICP
then IV
else (SELECTC A.E.TYPE
((LIST \AT.POINTER \AT.XPOINTER)
NIL)
(\AT.FLOATP 0.0)
0))
elseif (NULL DAR)
then (SELECTQ (SYSTEMTYPE)
(D ((LAMBDA (BLOCK#WDS)
(\ALLOCBLOCK (FOLDHI BLOCK#WDS WORDSPERCELL)
GCTYPE))
(FOLDHI (ADD1 (ITIMES #ELTS BITSPERELEMENT))
BITSPERWORD)))
((LAMBDA (#ELTS/WORD)
(ARRAY (IQUOTIENT (IPLUS #ELTS (SUB1 #ELTS/WORD))
#ELTS/WORD)))
(IQUOTIENT 36 BITSPERELEMENT)))
else (* DAROFFSET is now to be converted to a bit offset.)
(* ANCHOROFFSET is in units of the new array's indices)
(SETQ ANCHOROFFSET
(if (NULL DARTYPE)
then DAROFFSET
else (IQUOTIENT (ITIMES (SELECTC DARTYPE
((LIST \AT.POINTER \AT.FIXP
\AT.XPOINTER)
BITSPERCELL)
((LIST \AT.DOUBLEBYTE \AT.WORD)
(CONSTANT (TIMES 2 BITSPERBYTE)))
(\AT.BYTE BITSPERBYTE)
(\AT.NIBBLE BITSPERNIBBLE)
(\AT.BIT 1)
(\AT.FLOATP (SHOULDNT
(QUOTE FLOATP)))
(if (IGEQ DARTYPE \AT.MOD.BIT)
then (BITCLEAR DARTYPE
\AT.MOD.BIT)
else (SHOULDNT)))
DAROFFSET)
BITSPERELEMENT)))
(if DARTYPE
then (ffetch CMLANCHOR of DAR)
else DAR)))
(SETQ ARRAY
(create CMLARRAY
CMLRANK ← RANK
CMLANCHOR ← ANCHOR
CMLAETYPE ← A.E.TYPE
CMLANCHOROFFSET ← ANCHOROFFSET
CMLMARGINS ←(if (IGEQ RANK 2)
then (\MARGINTO DIML)
else 0)
CMLDIML ← DIML
CMLIMAX ←(SUB1 #ELTS)
CMLALIGN ← ALIGNMENT
CMLMOD# ← MOD#
CMLMOD#P2P ←(if (NOT MOD#)
then NIL
elseif (BITTEST A.E.TYPE \AT.MOD.BIT)
then (POWEROFTWOP (BITCLEAR A.E.TYPE \AT.MOD.BIT))
else (* This is the case of the "optimized" ones -- BIT BYTE
WORD etc)
T)))
(if (OR IEP (AND ICP (NEQ RANK 0)))
then (FILLARRAY ARRAY (if IEP
then (* List of length 1 will cause that element to be
repeated throughout the array
(by FILLARRAY))
(LIST IV)
elseif (type? CMLARRAY IV)
then (LISTARRAY IV)
else (* Must check to see if nested list structures have the
same dimensionality as the array we are creating.)
(FRPTQ (SUB1 RANK)
(SETQ IV (APPLY (FUNCTION APPEND)
IV)))
IV)))
(RETURN ARRAY))))
(\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))))))
(\MARGINTO
(LAMBDA (DIML) (* JonL "16-SEP-83 23:46")
(DECLARE (SPECVARS THISROWBASE #ELTS/ROW))
((LAMBDA (#HYPER.ROWS NEXTDIML LASTDIMENSIONP MARGINARRAY)
(SETQ MARGINARRAY (\MakeVector #HYPER.ROWS))
(if LASTDIMENSIONP
then (for I from 0 to (SUB1 #HYPER.ROWS)
do (* Except for the final margining over the real
baseblock, each margin array will be going into another
margin array for the next dimension.)
(\VectorSET MARGINARRAY I THISROWBASE)
(add THISROWBASE #ELTS/ROW))
else (for I from 0 to (SUB1 #HYPER.ROWS) do (\VectorSET MARGINARRAY I (\MARGINTO NEXTDIML)))
)
MARGINARRAY)
(CAR DIML)
(OR (CDR DIML)
(SHOULDNT))
(NULL (CDDR DIML)))))
(ADJUSTARRAY
(LAMBDA NARGS (* JonL "30-SEP-83 22:15")
(PROG ((ARRAY (DATATYPE.TEST (if (OR (ILESSP NARGS 1)
(IGREATERP NARGS 2))
then (if (ILESSP NARGS 2)
then (ERROR (QUOTE Too% few% args))
else (ERROR (QUOTE NotYetImplemented)
"Keywords for ADJUSTARRAY"))
else (ARG NARGS 1))
(QUOTE CMLARRAY)))
(DIML (if (ILEQ NARGS 1)
then NIL
elseif (NULL (ARG NARGS 2))
then NIL
else (OR (LISTP (ARG NARGS 2))
(LIST (ARG NARGS 2)))))
(#ROWS 0)
(#ELTS/ROW 0)
(#ELTS 1)
(THISROWBASE 0)
TEM)
(DECLARE (SPECVARS #ELTS/ROW THISROWBASE))
(if (NEQ (FLENGTH DIML)
(ffetch CMLRANK of ARRAY))
then (ERROR "Rank mismatch")
elseif (NOT (ZEROP (ffetch CMLALIGN of ARRAY)))
then (ERROR (QUOTE NotYetImplemented)
"Adjustment of ALIGN'd arrays"))
(if DIML
then (for I in DIML
do (OR (AND (\INDEXABLE.FIXP I)
(IGEQ I 1))
(ERROR "Invalid dimension" I))
(SETQ #ELTS (ITIMES (SETQ #ROWS #ELTS)
(SETQ #ELTS/ROW I))))
else (RETURN ARRAY))
(if (IGREATERP #ELTS (ADD1 (ffetch CMLIMAX of ARRAY)))
then (PROG ((HAUMANYBITS (ARRAYTOTALSIZE ARRAY T))
(A.E.TYPE (ffetch CMLAETYPE of ARRAY))
(ANCHOROFFSET (ffetch CMLANCHOROFFSET of ARRAY))
(NAOFFSET 0)
BITSPERELEMENT ANCHOR)
(SETQ BITSPERELEMENT (if (IGEQ A.E.TYPE \AT.MOD.BIT)
then (BITCLEAR A.E.TYPE \AT.MOD.BIT)
else (SELECTC A.E.TYPE
(\AT.POINTER BITSPERCELL)
(\AT.BYTE (SETQ NAOFFSET
(IMOD ANCHOROFFSET
BYTESPERCELL))
BITSPERBYTE)
((LIST \AT.DOUBLEBYTE \AT.WORD)
(SETQ NAOFFSET
(IMOD ANCHOROFFSET
(CONSTANT (IQUOTIENT
BYTESPERCELL 2)))
)
(CONSTANT (TIMES 2 BITSPERBYTE)))
(\AT.BIT (SETQ NAOFFSET
(IMOD ANCHOROFFSET
BITSPERCELL))
1)
(\AT.NIBBLE
(SETQ NAOFFSET
(IMOD ANCHOROFFSET
(CONSTANT (QUOTIENT
BITSPERCELL
BITSPERNIBBLE))))
BITSPERNIBBLE)
BITSPERCELL)))
(SELECTQ (SYSTEMTYPE)
(D (\BLT ANCHOR (ffetch CMLANCHOR of ARRAY)
(FOLDLO HAUMANYBITS BITSPERWORD)))
(ERROR (QUOTE NotYetImplemented)
"How to move a block of n bits starting at cell boundaries"))
(SETQ ANCHOR (SELECTQ (SYSTEMTYPE)
((TENEX TOPS20)
(SETQ TEM (IQUOTIENT 36 BITSPERELEMENT))
(* #ELTS/pdp10WORD)
(ARRAY (IQUOTIENT (IPLUS (IPLUS #ELTS NAOFFSET)
(SUB1 TEM))
TEM)))
(\ALLOCBLOCK (FOLDHI (ITIMES BITSPERELEMENT
(IPLUS #ELTS NAOFFSET))
BITSPERCELL))))
(freplace CMLANCHOR of ARRAY with ANCHOR)
(freplace CMLANCHOROFFSET of ARRAY with NAOFFSET)))
(* Process keyword arguments)
(freplace CMLDIML of ARRAY with DIML)
(freplace CMLMARGINS of ARRAY with (if (ILEQ 2 (ffetch CMLRANK of ARRAY))
then (\MARGINTO DIML)
else 0))
(freplace CMLIMAX of ARRAY with (SUB1 #ELTS))
(RETURN ARRAY))))
)
(DEFINEQ
(AREF
(LAMBDA NARGS (* JonL "30-SEP-83 21:45")
(OR (IGEQ NARGS 1)
(ERROR (QUOTE Too% few% args)))
(PROG ((ARRAY (DATATYPE.TEST (ARG NARGS 1)
(QUOTE CMLARRAY)))
RANK)
(RETURN (if (NEQ NARGS (ADD1 (SETQ RANK (ffetch CMLRANK of ARRAY))))
then (ERROR ARRAY (QUOTE Array% Rank% Mismatch))
elseif (ZEROP RANK)
then (ffetch CMLANCHOR of ARRAY)
else (\AREFLINEAR ARRAY (IPLUS (\AREFSET.LINEARIZE ARRAY 2 NARGS)
(ffetch CMLANCHOROFFSET of ARRAY))))))))
(ASET
(LAMBDA NARGS (* JonL "30-SEP-83 22:15")
(OR (IGEQ NARGS 2)
(ERROR (QUOTE Too% few% args)))
(PROG ((VAL (ARG NARGS 1))
(ARRAY (DATATYPE.TEST (ARG NARGS 2)
(QUOTE CMLARRAY)))
RANK)
(RETURN (if (NEQ NARGS (IPLUS 2 (SETQ RANK (ffetch CMLRANK of ARRAY))))
then (ERROR ARRAY (QUOTE Array% Rank% Mismatch))
elseif (SELECTC (ffetch CMLAETYPE of ARRAY)
(\AT.POINTER NIL)
((LIST \AT.BYTE \AT.DOUBLEBYTE \AT.WORD \AT.BIT \AT.FIXP)
(NOT (FIXP VAL)))
((LIST \AT.FLOATP)
(NOT (FLOATP VAL)))
NIL)
then (ERRORX (LIST 32 VAL))
elseif (ZEROP RANK)
then (replace CMLANCHOR of ARRAY with VAL)
VAL
else (\ASETLINEAR VAL ARRAY (IPLUS (\AREFSET.LINEARIZE ARRAY 3 NARGS)
(ffetch CMLANCHOROFFSET of ARRAY))))))))
)
(DECLARE: EVAL@COMPILE
(PUTPROPS AREF DMACRO COMP.AREF)
(PUTPROPS AREF MACRO (X
(SELECTC (LENGTH X)
(2 (CONS (QUOTE \AREF.1)
X))
(3 (CONS (QUOTE \AREF.2)
X))
(QUOTE IGNOREMACRO))))
(PUTPROPS ASET DMACRO COMP.ASET)
(PUTPROPS ASET MACRO (X
(SELECTC (LENGTH X)
(3 (CONS (QUOTE \ASET.1)
X))
(4 (CONS (QUOTE \ASET.2)
X))
(QUOTE IGNOREMACRO))))
)
(DECLARE: EVAL@COMPILE DONTCOPY
(DECLARE: EVAL@COMPILE
(PUTPROPS \AREFSET.LINEARIZE MACRO ((ARRAY STARTAGRI NARGS)
(bind (SETQ I 0)
(SETQ MARGINS (ffetch CMLMARGINS of ARRAY)) for L on (ffetch CMLDIML of ARRAY) as J
from STARTAGRI
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 (ILEQ (add I MARGINS)
(ffetch CMLIMAX of ARRAY))
(SHOULDNT))
else (* Go thru one margin array)
(SETQ MARGINS (\VectorREF MARGINS I)))
finally (RETURN I))))
(PUTPROPS \AREFSET.LINEARIZE1 MACRO (OPENLAMBDA (ARRAY I)
(if (NEQ 1 (ffetch CMLRANK of ARRAY))
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 CMLDIML of ARRAY))))
then (ERROR I (QUOTE Array% index% out% of% bounds)))
(if (IGREATERP I (ffetch CMLIMAX of ARRAY))
then (SHOULDNT))
(IPLUS I (ffetch CMLANCHOROFFSET of ARRAY))))
(PUTPROPS \AREFSET.LINEARIZE2 MACRO (OPENLAMBDA (ARRAY I J)
(* JonL " 7-FEB-83 18:55")
(if (NEQ 2 (ffetch CMLRANK of ARRAY))
then (ERROR ARRAY (QUOTE Array% Rank% Mismatch)))
((LAMBDA (\DimensionsList \LinearIndex)
(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 (\VectorREF \LinearIndex I)
J))
(if (IGREATERP \LinearIndex (ffetch CMLIMAX of ARRAY))
then (SHOULDNT))
(IPLUS \LinearIndex (ffetch CMLANCHOROFFSET of ARRAY)))
(ffetch CMLDIML of ARRAY)
(ffetch CMLMARGINS of ARRAY))))
)
)
(DEFINEQ
(\AREF.1
(LAMBDA (ARRAY I) (* JonL "30-SEP-83 21:51")
(SETQ ARRAY (DATATYPE.TEST ARRAY (QUOTE CMLARRAY)))
(\AREFLINEAR ARRAY (\AREFSET.LINEARIZE1 ARRAY I))))
(\ASET.1
(LAMBDA (VAL ARRAY I) (* JonL "30-SEP-83 21:52")
(SETQ ARRAY (DATATYPE.TEST ARRAY (QUOTE CMLARRAY)))
(\ASETLINEAR VAL ARRAY (\AREFSET.LINEARIZE1 ARRAY I))))
(\AREF.2
(LAMBDA (ARRAY I J) (* JonL "30-SEP-83 21:53")
(SETQ ARRAY (DATATYPE.TEST ARRAY (QUOTE CMLARRAY)))
(\AREFLINEAR ARRAY (\AREFSET.LINEARIZE2 ARRAY I J))))
(\ASET.2
(LAMBDA (VAL ARRAY I J) (* JonL "30-SEP-83 21:53")
(SETQ ARRAY (DATATYPE.TEST ARRAY (QUOTE CMLARRAY)))
(\ASETLINEAR VAL ARRAY (\AREFSET.LINEARIZE2 ARRAY I J))))
(\AREFLINEAR
(LAMBDA (ARRAY I) (* JonL "30-SEP-83 22:15")
(PROG ((ANCHOR (ffetch CMLANCHOR of ARRAY))
(A.E.TYPE (ffetch CMLAETYPE of ARRAY)))
(RETURN (if (IGEQ \AT.MOD.BIT A.E.TYPE)
then (SELECTC A.E.TYPE
(\AT.POINTER (\VectorREF ANCHOR I))
(\AT.BYTE (\WORDREF.8 ANCHOR I))
((LIST \AT.WORD \AT.DOUBLEBYTE)
(\WORDREF.16 ANCHOR I))
(\AT.BIT (\WORDREF.1 ANCHOR I))
(\AT.NIBBLE (\WORDREF.4 ANCHOR I))
(\AT.XPOINTER (\WORDREF.PTR ANCHOR I))
(\AT.FIXP (\WORDREF.FIXP ANCHOR I))
(\AT.FLOATP (\WORDREF.FLOATP ANCHOR I))
(SHOULDNT))
else (* A.E.TYPE will now have the number of bits per
element)
(SETQ I (\GETBASEBITS ANCHOR (ITIMES I (SETQ A.E.TYPE (BITCLEAR A.E.TYPE
\AT.MOD.BIT)))
A.E.TYPE))
(if (ffetch CMLMOD#P2P of ARRAY)
then I
else (IMOD I (ffetch CMLMOD# of ARRAY))))))))
(\ASETLINEAR
(LAMBDA (VAL ARRAY I) (* JonL "12-Apr-84 19:09")
(PROG ((ANCHOR (ffetch CMLANCHOR of ARRAY))
(A.E.TYPE (ffetch CMLAETYPE of ARRAY)))
(if (IGEQ \AT.MOD.BIT A.E.TYPE)
then (SELECTC A.E.TYPE
(\AT.POINTER (\WORDSET.PTR VAL ANCHOR I))
(\AT.BYTE (SETQ VAL (LOADBYTE VAL 0 BITSPERBYTE))
(\WORDSET.8 VAL ANCHOR I))
((LIST \AT.WORD \AT.DOUBLEBYTE)
(SETQ VAL (SELECTQ (SYSTEMTYPE)
(D (LOADBYTE VAL 0 BITSPERWORD))
(LOADBYTE VAL 0 (CONSTANT (TIMES 2 BITSPERBYTE)))))
(\WORDSET.16 VAL ANCHOR I))
(\AT.BIT (SETQ VAL (LOADBYTE VAL 0 1))
(\WORDSET.1 VAL ANCHOR I))
(\AT.NIBBLE (SETQ VAL (LOADBYTE VAL 0 BITSPERNIBBLE))
(\WORDSET.4 VAL ANCHOR I))
(\AT.XPOINTER (\WORDSET.XPTR VAL ANCHOR I))
(\AT.FIXP (SETQ VAL (IPLUS 0 VAL))
(\WORDSET.FIXP VAL ANCHOR I))
(\AT.FLOATP (SETQ VAL (FPLUS 0.0 VAL))
(\WORDSET.FLOATP VAL ANCHOR I))
(SHOULDNT))
else (* A.E.TYPE will now have the number of bits per
element)
(\PUTBASEBITS ANCHOR (ITIMES I (SETQ A.E.TYPE (BITCLEAR A.E.TYPE \AT.MOD.BIT)))
A.E.TYPE
(SETQ VAL (if (ffetch CMLMOD#P2P of ARRAY)
then (LOADBYTE VAL 0 A.E.TYPE)
else (IMOD VAL (ffetch CMLMOD# of ARRAY))))))
(RETURN VAL))))
)
(DECLARE: EVAL@COMPILE
(PUTPROPS ARRAYRANK MACRO ((CMLARRAY)
(fetch CMLRANK of CMLARRAY)))
(PUTPROPS ARRAYDIMENSIONS MACRO (X
(if (AND X (NULL (CDR X)))
then (LIST (QUOTE fetch)
(QUOTE CMLDIML)
(CAR X))
else (QUOTE IGNOREMACRO))))
(PUTPROPS ARRAYDIMENSION MACRO ((CMLARRAY AXIS#)
(CAR (NTH (fetch CMLDIML of CMLARRAY)
(ADD1 AXIS#)))))
)
(DEFINEQ
(ARRAYRANK
(LAMBDA (CMLARRAY) (* JonL "25-SEP-83 22:36")
(\MACRO.MX (ARRAYRANK CMLARRAY))))
(ARRAYDIMENSIONS
(LAMBDA (CMLARRAY OPTIONS) (* JonL "30-SEP-83 21:56")
(SETQ CMLARRAY (DATATYPE.TEST CMLARRAY (QUOTE CMLARRAY)))
(OR (NULL OPTIONS)
(LISTP OPTIONS)
(SETQ OPTIONS (LIST OPTIONS)))
((LAMBDA (L)
(if (AND OPTIONS (MEMB (QUOTE NOCOPY)
OPTIONS))
then L
else (COPY L)))
(ffetch CMLDIML of CMLARRAY))))
(ARRAYDIMENSION
(LAMBDA (CMLARRAY AXIS#) (* JonL "23-SEP-83 21:14")
(\MACRO.MX (ARRAYDIMENSION CMLARRAY (COND
((AND (\INDEXABLE.FIXP AXIS#)
(ILESSP AXIS# (ARRAYRANK CMLARRAY)))
AXIS#)
((ERRORX (LIST 27 AXIS#))))))))
(ARRAYELEMENTTYPE
(LAMBDA (CMLARRAY) (* JonL "30-SEP-83 22:17")
(SETQ CMLARRAY (DATATYPE.TEST CMLARRAY (QUOTE CMLARRAY)))
((LAMBDA (J)
(if (IGEQ \AT.MOD.BIT J)
then (SELECTC J
(\AT.POINTER T)
(\AT.BYTE (QUOTE (MOD 256)))
((LIST \AT.WORD \AT.DOUBLEBYTE)
(QUOTE (MOD 65536)))
(\AT.BIT (QUOTE (MOD 2)))
(\AT.NIBBLE (QUOTE (MOD 16)))
(\AT.FIXP (QUOTE FIXNUM))
(\AT.FLOATP (QUOTE FLONUM))
(\AT.XPOINTER (QUOTE XPOINTER))
(SHOULDNT))
else (ffetch CMLMOD# of CMLARRAY)))
(ffetch CMLAETYPE of CMLARRAY))))
(ARRAYINBOUNDSP
(LAMBDA NARGS (* JonL "25-SEP-83 22:33")
(AND (ZEROP NARGS)
(HELP))
(PROG ((CMLARRAY (ARG NARGS 1)))
(OR (EQ NARGS (ADD1 (ARRAYRANK CMLARRAY)))
(ERROR "Rank Mismatch"))
(RETURN (NOT (find I in (ffetch CMLDIML of CMLARRAY) as K from 2
suchthat (OR (IGREATERP 0 (ARG NARGS K))
(ILEQ I (ARG NARGS K)))))))))
(ARRAYTOTALSIZE
(LAMBDA (CMLARRAY IN.BITS?) (* JonL "30-SEP-83 22:15")
(SETQ CMLARRAY (DATATYPE.TEST CMLARRAY (QUOTE CMLARRAY)))
((LAMBDA (N)
(if IN.BITS?
then (ITIMES ((LAMBDA (TYPE)
(if (IGEQ TYPE \AT.MOD.BIT)
then (BITCLEAR TYPE \AT.MOD.BIT)
else (SELECTC TYPE
(\AT.POINTER BITSPERCELL)
(\AT.BYTE BITSPERBYTE)
((LIST \AT.DOUBLEBYTE \AT.WORD)
(CONSTANT (TIMES 2 BITSPERBYTE)))
(\AT.BIT 1)
(\AT.NIBBLE BITSPERNIBBLE)
BITSPERCELL)))
(ffetch CMLAETYPE of CMLARRAY))
N)
else N))
(if (OR IN.BITS? (ZEROP (ffetch CMLALIGN of CMLARRAY)))
then (ADD1 (ffetch CMLIMAX of CMLARRAY))
else (APPLY (FUNCTION ITIMES)
(ffetch CMLDIML of CMLARRAY))))))
(ARRAYROWMAJORINDEX
(LAMBDA NARGS (* JonL "30-SEP-83 21:48")
(OR (IGEQ NARGS 1)
(ERROR (QUOTE Too% few% args)))
(PROG ((ARRAY (DATATYPE.TEST (ARG NARGS 1)
(QUOTE CMLARRAY))))
(if (NEQ NARGS (ADD1 (ffetch CMLRANK of ARRAY)))
then (ERROR ARRAY (QUOTE Array% Rank% Mismatch))
else (RETURN (\AREFSET.LINEARIZE ARRAY 2 NARGS))))))
)
(PUTPROPS MAKEARRAY ARGNAMES
(INDICESLST (KEYWORDNAMES: ELEMENTTYPE INITIALELEMENT INITIALCONTENTS DISPLACEDTO
DISPLACEDINDEXOFFSET)))
(PUTPROPS AREF ARGNAMES
(CMLARRY ...indices...))
(PUTPROPS ASET ARGNAMES
(NEWVALUE CMLARRY ...indices...))
(PUTPROPS ARRAYINBOUNDSP ARGNAMES
(CMLARRY ...indices...))
(PUTPROPS ADJUSTARRAY ARGNAMES
(CMLARRAY DIMENSIONSLST))
(* The "fast" versions of AREF and ASET -- following P causes them all to be set up as macros)
(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 (MKATOM (CONCAT A B))
(QUOTE MACRO)
(LIST (QUOTE X)
(LIST (MKATOM (CONCAT "\Fast"
B
"expander"))
(QUOTE X)
(LIST (QUOTE QUOTE)
C))))
(PUTPROP C (QUOTE MACRO)
(LIST (QUOTE X)
(LIST (MKATOM (CONCAT
"\NoSissy"
B
"expander"))
(QUOTE X)
(LIST (QUOTE QUOTE)
C))))))))))))
)
(DEFINEQ
(\FastAREFexpander
(LAMBDA (X FFUN) (* JonL " 1-JUL-83 19:49")
(LIST (QUOTE COND)
(LIST (QUOTE AREFSissyFLG)
(CONS (QUOTE AREF)
X))
(LIST (if (NLISTP X)
then (ERROR (QUOTE Too% few% args))
elseif (NLISTP (CDR X))
then (LIST (QUOTE fetch)
(QUOTE (CMLARRAY CMLANCHOR))
(QUOTE of)
(CAR X))
else (\NoSissyAREFexpander X FFUN T))))))
(\NoSissyAREFexpander
(LAMBDA (X FFUN CHECKFLG) (* JonL "20-SEP-83 21:46")
(PROG ((ACCESSOR (OR (CADR (ASSOC (SUBATOM FFUN 2)
(QUOTE ((PAREF \VectorREF)
(8AREF \WORDREF.8)
(16AREF \WORDREF.16)
(4AREF \WORDREF.4)
(1AREF \WORDREF.1)
(NAREF \WORDREF.FIXP)
(LAREF \WORDREF.FLOATP)
(XAREF \WORDREF.PTR)))))
(SHOULDNT)))
(ARRAYFORM (LISPFORM.SIMPLIFY (CAR X)
T))
(INDICES (for Y in (CDR X) collect (LISPFORM.SIMPLIFY Y T)))
ACCESSFORM)
(SETQ ACCESSFORM (LIST (PROG1 ACCESSOR (* Comment PPLossage))
(if CHECKFLG
then (QUOTE (ffetch (CMLARRAY CMLANCHOR)
of
(DATATYPE.TEST \Array (QUOTE CMLARRAY))))
else (QUOTE (fetch (CMLARRAY CMLANCHOR)
of \Array)))
(\AREFSET.INDEXFORM INDICES)))
(if (AND (NLISTP ARRAYFORM)
(ARGS.COMMUTABLEP.LIST INDICES ARRAYFORM))
then (SETQ ACCESSFORM (SUBST ARRAYFORM (QUOTE \Array)
ACCESSFORM))
else (SETQ ACCESSFORM (LIST (LIST (QUOTE LAMBDA)
(QUOTE (\Array))
(QUOTE (DECLARE (LOCALVARS \Array)))
ACCESSFORM)
ARRAYFORM)))
(RETURN ACCESSFORM))))
(\FastASETexpander
(LAMBDA (X FFUN) (* JonL " 2-JUL-83 00:46")
(if (OR (NLISTP X)
(NLISTP (CDR X)))
then (ERROR (QUOTE Too% few% args)))
(LIST (QUOTE COND)
(LIST (QUOTE AREFSissyFLG)
(CONS (QUOTE ASET)
X))
(LIST (if (NLISTP (CDDR X))
then (* Aha! 0-dimensional.)
(CONS (QUOTE \0DIM.ASET)
(CONS (KWOTE (SUBATOM FFUN 2))
X))
else (\NoSissyASETexpander X FFUN T))))))
(\NoSissyASETexpander
(LAMBDA (X FFUN CHECKFLG VAL.LAST.P) (* JonL "30-SEP-83 23:34")
(PROG ((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)))
SETTORNAME SETTINGFORM SIMPLEINDEXP SIMPLEARRAYP TEM)
(SETQ SETTORNAME (OR (CADR (ASSOC FUN (if VAL.LAST.P
then (QUOTE ((PASET \VectorSet)
(8ASET \PUTBASEBYTE)
(16ASET \PUTBASE)
(1ASET \PUTBASEBIT)
(4ASET \PUTBASENIBBLE)
(NASET \PUTBASEFIXP)
(LASET \PUTBASEFLOATP)
(XASET \PUTBASEPTR)))
else (QUOTE ((PASET \WORDSET.PTR)
(8ASET \WORDSET.8)
(16ASET \WORDSET.16)
(1ASET \WORDSET.1)
(4ASET \WORDSET.4)
(NASET \WORDSET.FIXP)
(LASET \WORDSET.FLOATP)
(XASET \WORDSET.XPTR))))))
(SHOULDNT)))
(SETQ SETTINGFORM (CONS SETTORNAME (QUOTE (\NewVal (ffetch (CMLARRAY CMLANCHOR)
of \Array)
(IPLUS (ffetch (CMLARRAY CMLANCHOROFFSET)
of \Array)
\Index)))))
(if CHECKFLG
then (SETQ SETTINGFORM (LIST (QUOTE PROGN)
(LIST (QUOTE AND)
(QUOTE (OR (ILESSP \Index 0)
(IGREATERP \Index
(ffetch (CMLARRAY CMLIMAX)
of (DATATYPE.TEST
\Array
(QUOTE CMLARRAY))))))
(LIST (QUOTE ERROR)
(QUOTE \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 (LIST (LIST (QUOTE LAMBDA)
(QUOTE (\Index))
(QUOTE (DECLARE (LOCALVARS \Index)))
SETTINGFORM)
(\AREFSET.INDEXFORM INDICES T))))
(if SIMPLEARRAYP
then (SETQ SETTINGFORM (SUBST ARRAYFORM (QUOTE \Array)
SETTINGFORM))
else (SETQ SETTINGFORM (LIST (LIST (QUOTE LAMBDA)
(QUOTE (\Array))
(QUOTE (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 (LIST (LIST (QUOTE LAMBDA)
(QUOTE (\NewVal))
(QUOTE (DECLARE (LOCALVARS \NewVal)))
SETTINGFORM)
NEWVALFORM)))
(RETURN SETTINGFORM))))
(\AREFSET.INDEXFORM
(LAMBDA (INDICES NOANCHOROFFSETFLG) (* JonL " 1-JUL-83 22:23")
(* 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 (CMLARRAY CMLMARGINS)
of \Array)))
for I in INDICES
do (* First, compose the chain of accesses through the
margin arrays, if any.)
(SETQ MARGINACCFORM (LIST (QUOTE \VectorREF)
MARGINACCFORM I))
finally (SETQ INDICES (CONS (QUOTE IPLUS)
(CDR MARGINACCFORM)))))
(if NOANCHOROFFSETFLG
then INDICES
else (LIST (QUOTE IPLUS)
(QUOTE (ffetch (CMLARRAY CMLANCHOROFFSET)
of \Array))
INDICES))))
(\CMLARRAY.LOCFTRAN
(LAMBDA (X) (* JonL " 1-JUL-83 20:07")
((LAMBDA (NAME MACP)
(if (AND (LISTP X)
(NNLITATOM (SETQ NAME (CAR X)))
(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 (PROG ((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 (QUOTE (fetch (\CMLARRAY CMLANCHOR)
of \Array)))
OFFSETFORM POINTERBYTEP LVARS LVALS)
(SETQ OFFSETFORM (\AREFSET.INDEXFORM INDICES))
(SELECTQ NBITS
(P (SETQ POINTERBYTEP T))
((X N L)
(SETQ NBITS BITSPERCELL)
(SETQ OFFSETFORM (LIST (QUOTE LLSH)
OFFSETFORM
(CONSTANT (SUB1 (INTEGERLENGTH BITSPERCELL)))
)))
(1 OFFSETFORM)
((16 4 8)
(SETQ OFFSETFORM (LIST (QUOTE 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 (LIST (QUOTE \Array)))
(SETQ LVALS (LIST ARRAYFORM)))
(RETURN (if POINTERBYTEP
then (LIST (QUOTE \POINTERBYTE)
LVARS LVALS BASEFORM OFFSETFORM)
else (LIST (QUOTE \BITSBYTE)
LVARS LVALS BASEFORM OFFSETFORM NBITS)))))))))
)
(RPAQ? AREFSissyFLG NIL)
(PUTPROPS AREFSissyFLG GLOBALVAR T)
(DEFINEQ
(LISTARRAY
(LAMBDA (CMLARRAY STARTI ENDI) (* JonL "30-SEP-83 22:15")
(SETQ CMLARRAY (DATATYPE.TEST CMLARRAY (QUOTE CMLARRAY)))
(PROG ((A.E.TYPE (ffetch CMLAETYPE of CMLARRAY))
(ANCHOR (ffetch CMLANCHOR of CMLARRAY))
(OFFST (ffetch CMLANCHOROFFSET of CMLARRAY))
(IMAX (ffetch CMLIMAX of CMLARRAY))
#ELTS CELLP MODP TEM)
(if (NULL STARTI)
then (SETQ STARTI 0)
else (\CHECKTYPE STARTI (FUNCTION \INDEXABLE.FIXP)))
(if (NULL ENDI)
then (SETQ ENDI IMAX)
else (\CHECKTYPE ENDI (FUNCTION \INDEXABLE.FIXP)))
(SETQ #ELTS (IDIFFERENCE IMAX (SUB1 STARTI)))
(if (IGEQ A.E.TYPE \AT.MOD.BIT)
then (SETQ MODP (BITCLEAR A.E.TYPE \AT.MOD.BIT))
else (SETQ CELLP (SELECTC A.E.TYPE
((LIST \AT.POINTER \AT.XPOINTER \AT.FIXP \AT.FLOATP)
T)
NIL)))
(if (OR (ILESSP #ELTS 0)
(IGREATERP #ELTS (ADD1 IMAX)))
then (ERROR "OUT OF RANGE"))
(add STARTI OFFST)
(add ENDI OFFST)
(RETURN (for I from STARTI to ENDI collect (if CELLP
then (SELECTC A.E.TYPE
(\AT.POINTER (\VectorREF
ANCHOR I))
(\AT.XPOINTER (\WORDREF.PTR
ANCHOR I))
(\AT.FIXP (\WORDREF.FIXP
ANCHOR I))
(\AT.FLOATP (\WORDREF.FLOATP
ANCHOR I))
(SHOULDNT))
elseif MODP
then (SETQ TEM (\GETBASEBITS ANCHOR
(ITIMES I MODP)
MODP))
(if (ffetch CMLMOD#P2P of CMLARRAY)
then TEM
else (IMOD TEM (ffetch CMLMOD#
of CMLARRAY)))
else (SELECTC A.E.TYPE
(\AT.BYTE (\WORDREF.8 ANCHOR I))
((LIST \AT.WORD \AT.DOUBLEBYTE)
(\WORDREF.16 ANCHOR I))
(\AT.NIBBLE (\WORDREF.4 ANCHOR I)
)
(\AT.BIT (\WORDREF.1 ANCHOR I))
(SHOULDNT))))))))
(FILLARRAY
(LAMBDA (CMLARRAY LIST STARTI ENDI) (* JonL " 8-May-84 18:25")
(SETQ CMLARRAY (DATATYPE.TEST CMLARRAY (QUOTE CMLARRAY)))
(OR (LISTP LIST)
(SETQ LIST (LIST LIST)))
(PROG ((A.E.TYPE (ffetch CMLAETYPE of CMLARRAY))
(ANCHOR (ffetch CMLANCHOR of CMLARRAY))
(OFFST (ffetch CMLANCHOROFFSET of CMLARRAY))
(IMAX (ffetch CMLIMAX of CMLARRAY))
(ITEM (CAR LIST))
CELLP MODP #ELTS TEM)
(if (NULL STARTI)
then (SETQ STARTI 0)
else (\CHECKTYPE STARTI (FUNCTION \INDEXABLE.FIXP)))
(if (NULL ENDI)
then (SETQ ENDI IMAX)
else (\CHECKTYPE ENDI (FUNCTION \INDEXABLE.FIXP)))
(SETQ #ELTS (IDIFFERENCE IMAX (SUB1 STARTI)))
(if (IGEQ A.E.TYPE \AT.MOD.BIT)
then (SETQ MODP (BITCLEAR A.E.TYPE \AT.MOD.BIT))
else (SETQ CELLP (SELECTC (ffetch CMLAETYPE of CMLARRAY)
((LIST \AT.POINTER \AT.XPOINTER \AT.FIXP \AT.FLOATP)
T)
NIL)))
(if (OR (ILESSP #ELTS 0)
(IGREATERP #ELTS (ADD1 IMAX)))
then (ERROR "Number of elements not in range" #ELTS))
(add STARTI OFFST)
(add ENDI OFFST)
(for I from STARTI to ENDI
do
(if CELLP
then (SELECTC A.E.TYPE
(\AT.POINTER (\WORDSET.PTR ITEM ANCHOR I))
(\AT.XPOINTER (\WORDSET.XPTR ITEM ANCHOR I))
(\AT.FIXP (\WORDSET.FIXP ITEM ANCHOR I))
(\AT.FLOATP (\WORDSET.FLOATP ITEM ANCHOR I))
(SHOULDNT))
elseif MODP
then (\PUTBASEBITS ANCHOR (ITIMES I MODP)
MODP
(if (ffetch CMLMOD#P2P of CMLARRAY)
then (LOADBYTE ITEM 0 MODP)
else (IMOD ITEM (ffetch CMLMOD# of CMLARRAY))))
elseif (SELECTQ (SYSTEMTYPE)
(D (AND (NULL (CDR LIST))
(SELECTC A.E.TYPE
(\AT.BYTE (AND (EVENP I BYTESPERWORD)
(ILEQ BYTESPERWORD (IDIFFERENCE
ENDI I))))
((LIST \AT.WORD \AT.DOUBLEBYTE)
T)
(\AT.NIBBLE (AND (EVENP I BITSPERNIBBLE)
(ILEQ BITSPERNIBBLE
(IDIFFERENCE ENDI I))))
(\AT.BIT (AND (EVENP I BITSPERWORD)
(ILEQ BITSPERWORD (IDIFFERENCE ENDI I))
))
NIL)))
NIL)
then (* Do a word's worth at a time, but only on the D
machines.)
(SELECTQ
(SYSTEMTYPE)
(D (PROG (I'S WDOFFST WORD BLOCK#WDS)
(SETQ WORD
(SELECTC A.E.TYPE
(\AT.BYTE (SETQ WDOFFST (FOLDLO I BYTESPERWORD))
(SETQ BLOCK#WDS (IDIFFERENCE (ADD1 (FOLDLO ENDI
BYTESPERWORD))
WDOFFST))
(SETQ I'S (UNFOLD BLOCK#WDS BYTESPERWORD))
(ITIMES ITEM (CONSTANT (LOGOR 1 (LLSH 1
BITSPERBYTE)))))
((LIST \AT.WORD \AT.DOUBLEBYTE)
(SETQ WDOFFST I)
(SETQ BLOCK#WDS (IDIFFERENCE (ADD1 ENDI)
I))
(SETQ I'S BLOCK#WDS)
ITEM)
(\AT.NIBBLE (SETQ WDOFFST (FOLDLO I BITSPERNIBBLE))
(SETQ BLOCK#WDS (IDIFFERENCE
(ADD1 (FOLDLO ENDI BITSPERNIBBLE))
WDOFFST))
(SETQ I'S (UNFOLD BLOCK#WDS BITSPERNIBBLE))
(ITIMES
ITEM
(CONSTANT (for I to BITSPERNIBBLE
sum (LLSH 1 (TIMES BITSPERNIBBLE
(SUB1 I)))))))
(\AT.BIT (SETQ WDOFFST (FOLDLO I BITSPERWORD))
(SETQ BLOCK#WDS (IDIFFERENCE (ADD1 (FOLDLO ENDI
BITSPERWORD))
WDOFFST))
(SETQ I'S (UNFOLD BLOCK#WDS BITSPERWORD))
(if (ZEROP ITEM)
then 0
else (CONSTANT (MASK.1'S 0 BITSPERWORD))))
(SHOULDNT)))
(FRPTQ BLOCK#WDS (\PUTBASE ANCHOR WDOFFST WORD)
(add WDOFFST 1))
(add I (SUB1 I'S))))
NIL)
else (SELECTC A.E.TYPE
(\AT.BYTE (\WORDSET.8 ITEM ANCHOR I))
((LIST \AT.WORD \AT.DOUBLEBYTE)
(\WORDSET.16 ITEM ANCHOR I))
(\AT.NIBBLE (\WORDSET.4 ITEM ANCHOR I))
(\AT.BIT (\WORDSET.1 ITEM ANCHOR I))
(SHOULDNT)))
(pop LIST)
(if LIST
then (SETQ ITEM (CAR LIST))))
(RETURN CMLARRAY))))
(\PRINTCMLARRAY
(LAMBDA (VARORVAL FILE) (* JonL " 1-JUL-83 22:25")
(PROG ((A VARORVAL))
(AND A (LITATOM A)
(SETQ A (EVALV A)))
(OR (type? CMLARRAY A)
(ERRORX (LIST 27 VARORVAL)))
(PRIN1 "(" FILE)
(PRINT (LIST (ffetch CMLDIML of A)
(ARRAYELEMENTTYPE A)
(ffetch CMLALIGN of A))
FILE)
(PRINT (LISTARRAY A)
FILE)
(PRIN1 ")" FILE)
(TERPRI FILE))))
(\READCMLARRAY
(LAMBDA (FILE) (* JonL "27-APR-83 02:22")
(PROG ((L (READ FILE))
TEM)
(OR (AND (EQ 3 (LENGTH (SETQ TEM (CAR (LISTP L)))))
(OR (NULL (CAR TEM))
(LISTP (CAR TEM))))
(ERROR L "Wrong object read in"))
(SETQ TEM (MAKEARRAY (CAR TEM)
(QUOTE ELEMENTTYPE)
(CADR TEM)
(QUOTE ALIGNMENT)
(CADDR TEM)))
(FILLARRAY TEM (CADR L))
(RETURN TEM))))
)
(PUTDEF (QUOTE CMLARRAYS) (QUOTE FILEPKGCOMS) (QUOTE
((COM MACRO
(X (E (MAPC (QUOTE X)
(FUNCTION (LAMBDA (VAR)
(PRIN1 "(RPAQ ")
(PRIN2 VAR)
(PRIN1
"(\READCMLARRAY))")
(TERPRI)
(\PRINTCMLARRAY
VAR))))))))))
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
(ADDTOVAR NLAMA )
(ADDTOVAR NLAML )
(ADDTOVAR LAMA ARRAYROWMAJORINDEX ARRAYINBOUNDSP ASET AREF ADJUSTARRAY MAKEARRAY
\NONDADDARITH.TRAMPOLINE)
)
(PUTPROPS CMLARRAY COPYRIGHT ("Xerox Corporation" 1982 1983 1984))
(DECLARE: DONTCOPY
(FILEMAP (NIL (9924 10611 (\BubbleWORDSET 9934 . 10609)) (10645 11332 (\BubbleWORDSET 10655 . 11330))
(11405 12227 (\NONDADDARITH.TRAMPOLINE 11415 . 12225)) (12846 27942 (MAKEARRAY 12856 . 22992) (
\CML.ICP.CHECK 22994 . 23374) (\MARGINTO 23376 . 24271) (ADJUSTARRAY 24273 . 27940)) (27943 29530 (
AREF 27953 . 28564) (ASET 28566 . 29528)) (32456 35976 (\AREF.1 32466 . 32686) (\ASET.1 32688 . 32912)
(\AREF.2 32914 . 33136) (\ASET.2 33138 . 33364) (\AREFLINEAR 33366 . 34466) (\ASETLINEAR 34468 .
35974)) (36391 39700 (ARRAYRANK 36401 . 36550) (ARRAYDIMENSIONS 36552 . 36963) (ARRAYDIMENSION 36965
. 37260) (ARRAYELEMENTTYPE 37262 . 37912) (ARRAYINBOUNDSP 37914 . 38374) (ARRAYTOTALSIZE 38376 .
39260) (ARRAYROWMAJORINDEX 39262 . 39698)) (40948 49657 (\FastAREFexpander 40958 . 41432) (
\NoSissyAREFexpander 41434 . 42763) (\FastASETexpander 42765 . 43308) (\NoSissyASETexpander 43310 .
46893) (\AREFSET.INDEXFORM 46895 . 47936) (\CMLARRAY.LOCFTRAN 47938 . 49655)) (49731 57223 (LISTARRAY
49741 . 51891) (FILLARRAY 51893 . 56172) (\PRINTCMLARRAY 56174 . 56702) (\READCMLARRAY 56704 . 57221))
)))
STOP