(FILECREATED "16-Feb-86 17:56:46" {QV}<IDL>SOURCES>GLOBAL.;34 19901
changes to: (VARS GLOBALCOMS)
previous date: "16-Feb-86 13:50:58" {QV}<IDL>SOURCES>GLOBAL.;33)
(* Copyright (c) 1983, 1984, 1985, 1986 by Xerox Corporation. All rights reserved.)
(PRETTYCOMPRINT GLOBALCOMS)
(RPAQQ GLOBALCOMS [(* Global functions and definitions)
(FNS AELTTYPE ALLOC.SARRAY ARRAYTYPEP COPYIDLARRAY DIMENSIONP GETAELT GETARRAYPROP LEVELP
MAKEOFFSETS NLOGICALELTS NPHYSICALELTS PRESERVE SERIALNUMBER SETARRAYPROP SETAELT VFROMR
ZEROFORARRAY)
(INITRECORDS ARRAYFRAME)
(IF: TESTSYS (RECORDS ARRAYFRAME SIMARRAY SELARRAY)
(RECORDS ID KEEPS)
(RECORDS AELTPTR)
(MACROS IJKBOX IVALUE)
(PROP CLISPWORD fadd FADD)
(PROP CHANGEWORD fadd))
(P (MOVD (QUOTE GETAELT)
(QUOTE COPYAELT)))
(IF: TESTSYS (DECLTYPES ARRAY (ARRAY COERCION)
VECTOR MATRIX)
(DECLTYPES FORMATCODE))
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA)
(NLAML)
(LAMA])
(* Global functions and definitions)
(DEFINEQ
(AELTTYPE
[DLAMBDA ((A ARRAY)
(RETURNS (MEMQ INTEGER FLOATING)))
(* jop: "27-Nov-85 17:22" posted: "27-AUG-78 15:33")
(* Returns array elementtype.
Subfunctioned because of the volume of code it
generates)
[fetch RELTTYPE of (fetch ELEMENTBLOCK of (SELECTQ (fetch (ARRAYFRAME TYPE)
of A)
(SIMPLE A)
(SELECTION (fetch (SELARRAY
BASEARRAY)
of A))
(SHOULDNT]])
(ALLOC.SARRAY
[DLAMBDA ((SHAPE ROWINT)
(FORMAT FORMATCODE)
(RELTVAL (ONEOF SCALAR (MEMQ INTEGER FLOATING)))
(RETURNS SIMARRAY))
(* rmk: "16-AUG-78 00:30")
(* builds a simple array of shape SHAPE format FORMAT and with elements initialized to RELTVAL.
NPHYSICALELTS called on the shape returns the size in elements)
(* Note: Element type is determined by type of RELTVAL,
with NIL -> INTEGER)
(SETQ RELTVAL (SELECTQ RELTVAL
(INTEGER 0)
(FLOATING 0.0)
RELTVAL))
(create SIMARRAY
SHAPE ← SHAPE
FORMAT ← FORMAT
ELEMENTBLOCK ←(create ROWSCALAR
NELTS ←(NPHYSICALELTS SHAPE FORMAT)
RELTTYPE ←(if (type? FLOATING RELTVAL)
then (QUOTE FLOATING)
else (QUOTE INTEGER))
INIT ← RELTVAL))])
(ARRAYTYPEP
[LAMBDA (A TYPE) (* jop: "27-Nov-85 17:22" posted: " 5-JUL-77 10:04")
(* A predicate for checking the type of an
array-frame. This is fast-compiled open)
(AND (type? ARRAYFRAME A)
(SELECTQ TYPE
(ARRAY T)
((SIMPLE SELECTION)
(EQ TYPE (fetch (ARRAYFRAME TYPE) of A)))
(VECTOR (EQ (fetch NDIMS of A)
1))
(MATRIX (EQ (fetch NDIMS of A)
2))
(SHOULDNT])
(COPYIDLARRAY
[DLAMBDA ((A ARRAY)
(NEWELTTYPE (MEMQ NIL FLOATING INTEGER))
(RETURNS SIMARRAY))
(* bas: " 9-FEB-83 15:19" posted: "13-MAY-77 00:30")
(* Produces a simple copy of an array, converting
elements to NEWELTTYPE)
(DPROG ((RESULT (ALLOC.SARRAY (fetch SHAPE of A)
(fetch FORMAT of A)
(OR NEWELTTYPE (fetch AELTTYPE of A))) SIMARRAY)
(GSBOLD (SETUP A (if (EQ (fetch FORMAT of A)
(QUOTE FULL))
then (QUOTE DONTCARE)
else (QUOTE SYMMETRIC))) GENSTATEBLOCK)
THEN (GSBNEW (SETUP RESULT (fetch ORDER of GSBOLD)) GENSTATEBLOCK))
[if (AND (EQ NEWELTTYPE (QUOTE INTEGER))
(EQ (fetch AELTTYPE of A)
(QUOTE FLOATING)))
then [bind TEMP until (fetch DONE of GSBOLD)
do (SETAELT RESULT (NEXT GSBNEW)
(AND (SETQ TEMP (GETAELT A (NEXT GSBOLD)))
(IVALUE (FIXR TEMP]
else (until (fetch DONE of GSBOLD) do (SETAELT RESULT (NEXT GSBNEW)
(GETAELT A (NEXT GSBOLD]
(LAB.COPYALL A RESULT)
(RETURN RESULT))])
(DIMENSIONP
[DLAMBDA ((ARY ARRAY)
(DIM INTEGER)
(RETURNS BOOL))
(* bas: "24-MAR-78 16:50")
(* DIMENSIONP returns true if DIM is a plausible
dimension index for ARY.)
(BETWEEN DIM 1 (fetch NDIMS of ARY))])
(GETAELT
[DLAMBDA ((ARR ARRAY)
(AP AELTPTR (SATISFIES ARR=AP:SOURCE))
(RETURNS SCALAR))
(* jop: "11-Feb-86 22:54")
(* Retrieves the element pointed to by AP, with type
determined by ARR)
(if [NOT (TESTMISSING (fetch I of (fetch (AELTPTR PTR) of AP]
then (SELECTQ (fetch AELTTYPE of ARR)
(INTEGER (fetch I of (fetch (AELTPTR PTR) of AP)))
(FLOATING (fetch F of (fetch (AELTPTR PTR) of AP)))
(SHOULDNT)))])
(GETARRAYPROP
[DLAMBDA ((A ARRAY)
(P LITATOM))
(* bas: "24-MAR-78 16:54" posted: "16-NOV-77 15:24")
(* Gets the value of the P property of A)
(CDR (FASSOC P (fetch SLOT5 of A)))])
(LEVELP
[DLAMBDA ((A ARRAY)
(DIM INTEGER (SATISFIES (DIMENSIONP A DIM)))
(LEV INTEGER)
(RETURNS BOOL))
(* bas: " 7-SEP-78 00:04" posted: " 4-MAY-77 10:57")
(BETWEEN LEV 1 (GETRELT (fetch SHAPE of A)
DIM))])
(MAKEOFFSETS
[DLAMBDA ((SHP ROWINT)
(RETURNS ROWINT))
(* bas: "16-FEB-83 17:56")
(* ex. {2,3,4}=>{12,4,1})
(if (IEQP (fetch NELTS of SHP)
1)
then (CONSTANT (ROWINTOF 1))
else (bind [Y ←(create ROWINT (SETQ NELTS (fetch NELTS of SHP]
(VAL ← 1)
declare (Y ROWINT)
(VAL IJK)
for J from (fetch NELTS of SHP) by -1 to 1
do (SETRELT Y J VAL)
(SETQ VAL (ITIMES (GETRELT SHP J)
VAL))
finally (RETURN Y)))])
(NLOGICALELTS
[DLAMBDA ((SHP ROWINT)
(RETURNS IJK))
(* bas: "10-FEB-83 14:43")
(* Returns the number of logical elements in an array with this shape. In particular, the number of elements that a
generator of this array will return.)
(if (IEQP (fetch NELTS of SHP)
0)
then (IJKBOX 0)
else (for I (C ← 1) to (fetch NELTS of SHP)
declare (I INTEGER)
(C IJK)
do (SETQ C (ITIMES C (GETRELT SHP I))) finally (RETURN C)))])
(NPHYSICALELTS
[DLAMBDA ((SHP ROWINT)
(FMT FORMATCODE)
(RETURNS IJK))
(* bas: "10-FEB-83 14:48")
(* Returns the number of elements that a simple array
with these attributes would have in its elementblock.)
(SELECTQ FMT
(FULL (NLOGICALELTS SHP))
(SYMMETRIC [ASSERT (AND (IEQP 2 (fetch NELTS of SHP))
(IEQP (GETRELT SHP 1)
(GETRELT SHP 2]
(SYMELTLOC (GETRELT SHP 1)
(GETRELT SHP 1)))
(SHOULDNT))])
(PRESERVE
[DLAMBDA ((A ARRAY)
(RETURNS ARRAY))
(* jop: "29-Nov-85 12:11" posted: " 8-OCT-77 18:02")
(* Returns a "copy" of A which will survive intact even though A is side-effected later. Labels in TTAB arrays do
not have to be preserved b/c the arrays were preserved in MAKESLTR)
(DPROG ((NEWA NIL ARRAY)
(RETURNS ARRAY))
(SELECTQ (fetch (ARRAYFRAME TYPE) of A)
(SIMPLE (SETQ NEWA (create SIMARRAY using A))
[if (fetch LABELBLOCK of A)
then (PROG [(PTR (fetch DIMLABELBLOCK
of (replace LABELBLOCK of NEWA
with (create LABELBLOCK
using (fetch LABELBLOCK
of A]
(if PTR
then (BUMPREFCNT PTR]
(* Copy top level of labelblock and bump refcount of
dimlabblock)
)
[SELECTION (SETQ NEWA (create SELARRAY using A))
(replace (SELARRAY BASEARRAY) of NEWA
with (PRESERVE (fetch (SELARRAY BASEARRAY) of A]
(SHOULDNT))
(replace (ARRAYFRAME ID) of NEWA with NIL) (* Smash to ID block)
(SETTITLE NEWA (GETTITLE A)) (* Both copies the title and sets a new serial number)
(RETURN NEWA))])
(SERIALNUMBER
[DLAMBDA ((A ARRAY)
(RETURNS INTEGER))
(* jop: "27-Nov-85 17:38" posted: " 9-MAR-78 16:12")
(* Returns the serial number of A, constructing one if necessary. Relies on the fact that this is the ONLY place
where IDs are created so the existence of an ID implies a preassigned serialnumber)
[PROG [(LST (CONSTANT (LIST 0]
(RETURN (fetch SNF of (OR (fetch (ARRAYFRAME ID) of A)
(replace (ARRAYFRAME ID) of A
with (create ID
SNF ←(add (CAR LST)
1]])
(SETARRAYPROP
[DLAMBDA ((A ARRAY)
(P LITATOM)
(V ANY))
(* bas: "24-MAR-78 16:54" posted: "16-NOV-77 15:27")
(* Attaches property P with value V to A)
(push A:SLOT5 (<P ! V>))
V])
(SETAELT
[DLAMBDA ((ARY ARRAY)
(AP AELTPTR (SATISFIES ARY=AP:SOURCE))
(V SCALAR)
(RETURNS SCALAR))
(* jop: "11-Feb-86 22:58")
(* Primitive function for setting an element in an
array)
(if V
then (SELECTQ (fetch AELTTYPE of ARY)
[INTEGER (if (type? INTEGER V)
then (replace I of (fetch (AELTPTR PTR)
of AP)
with V)
else (HELP "Attempt to store FLOAT into INTEGER array"
(LIST ARY V]
(FLOATING (replace F of (fetch (AELTPTR PTR) of AP)
with (FLOAT V)))
(SHOULDNT))
else (replace MAYHAVENIL of (fetch ELEMENTBLOCK
of (SELECTQ (fetch (ARRAYFRAME TYPE) of ARY)
(SIMPLE ARY)
(SELECTION (fetch (SELARRAY BASEARRAY)
of ARY))
(SHOULDNT)))
with T)
(replace I of (fetch (AELTPTR PTR) of AP) with (CONSTANT MIN.FIXP)))
V])
(VFROMR
[DLAMBDA ((R ROWSCALAR)
(TITLE (ONEOF NIL TITLE))
(RETURNS SIMARRAY))
(* bas: " 9-FEB-83 15:23")
(* Constructs a vector with elementblock=R and
title=TITLE)
(DPROG ((A (create SIMARRAY
FORMAT ←(QUOTE FULL)
SHAPE ←(ROWINTOF (IJKBOX (fetch NELTS of R)))
ELEMENTBLOCK ← R) SIMARRAY))
(if TITLE
then (SETTITLE A TITLE))
(RETURN A))])
(ZEROFORARRAY
[DLAMBDA ((A ARRAY)
(RETURNS ARITH))
(* rmk: " 6-Oct-84 14:18")
(* Returns a zero of the type of A)
(SELECTQ (fetch AELTTYPE of A)
(INTEGER 0)
(FLOATING 0.0)
(SHOULDNT))])
)
(/DECLAREDATATYPE (QUOTE ARRAYFRAME)
(QUOTE (POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER))
(QUOTE ((ARRAYFRAME 0 POINTER)
(ARRAYFRAME 2 POINTER)
(ARRAYFRAME 4 POINTER)
(ARRAYFRAME 6 POINTER)
(ARRAYFRAME 8 POINTER)
(ARRAYFRAME 10 POINTER)
(ARRAYFRAME 12 POINTER)
(ARRAYFRAME 14 POINTER)))
(QUOTE 16))
(DECLARE: DOCOPY
(DECLARE: EVAL@LOADWHEN TESTSYS
[DECLARE: EVAL@COMPILE
(DATATYPE ARRAYFRAME (TYPE SHAPESLOT FORMAT SLOT1 SLOT2 SLOT3 ID SLOT5)
(ACCESSFNS ARRAYFRAME ([SHAPE (the ROWINT (fetch SHAPESLOT
of DATUM))
(replace SHAPESLOT of DATUM
with (the ROWINT (BUMPREFCNT NEWVALUE]
(NDIMS (fetch NELTS of (fetch SHAPE of DATUM)))
(AELTTYPE AELTTYPE)
(TITLE GETTITLE SETTITLE)
(SERIALNUMBER SERIALNUMBER))))
[DATATYPE (SIMARRAY ARRAYFRAME)
(TYPE SHAPESLOT FORMAT LABELBLOCK SLOT2 SLOT3 ID SLOT5)
TYPE ←(QUOTE SIMPLE)
[ACCESSFNS SIMARRAY ([SHAPE (the ROWINT (fetch SHAPESLOT of DATUM))
(replace SHAPESLOT of DATUM
with (the ROWINT (BUMPREFCNT NEWVALUE]
(ELEMENTBLOCK (the ROWSCALAR (fetch SLOT2 of DATUM))
(replace SLOT2 of DATUM with (the ROWSCALAR NEWVALUE))
)
(OFFSETS (the ROWINT (fetch SLOT3 of (the SIMARRAY DATUM]
(TYPE? (ARRAYTYPEP DATUM (QUOTE SIMPLE)))
(* The CCREATE prevents re-computation of OFFSETS when
SHAPE is being shared in a create-using)
(CCREATE (COND
((AND (EQ USINGTYPE (QUOTE using))
(NOT (ASSOC (QUOTE SHAPE)
FIELDS.IN.CREATE)))
(QUOTE ([LAMBDA (.AF.)
(ASSERT (type? FORMATCODE (fetch FORMAT of .AF.)))
(BUMPREFCNT (fetch SHAPE of .AF.))
(replace ELEMENTBLOCK of .AF. with (BUMPREFCNT
ELEMENTBLOCK))
.AF.]
DATUM)))
(T (QUOTE ([LAMBDA (.AF.)
(ASSERT (type? FORMATCODE (fetch FORMAT of .AF.)))
(replace SHAPE of .AF. with SHAPE)
(replace ELEMENTBLOCK of .AF. with (BUMPREFCNT
ELEMENTBLOCK))
(replace SLOT3 of .AF.
with (MAKEOFFSETS (fetch SHAPE of .AF.)))
.AF.]
DATUM]
(DATATYPE (SELARRAY ARRAYFRAME)
(TYPE SHAPESLOT FORMAT SLOT1 BASEARRAY SLOT3 ID SLOT5)
TYPE ←(QUOTE SELECTION)
[ACCESSFNS SELARRAY ([SHAPE (the ROWINT (fetch SHAPESLOT of DATUM))
(replace SHAPESLOT of DATUM
with (the ROWINT (BUMPREFCNT NEWVALUE]
(TTAB (the ROWPTR (fetch SLOT1 of DATUM))
(replace SLOT1 of DATUM with (the ROWPTR NEWVALUE)))
(DIMMAP (the ROWPTR (fetch SLOT3 of DATUM]
(TYPE? (ARRAYTYPEP DATUM (QUOTE SELECTION)))
(CREATE ([LAMBDA (.AF.)
(ASSERT (type? FORMATCODE (fetch FORMAT of .AF.)))
(ASSERT (type? SIMARRAY (fetch BASEARRAY of .AF.)))
(replace SHAPE of .AF. with SHAPE)
(replace TTAB of .AF. with (BUMPREFCNT TTAB))
(replace SLOT3 of .AF. with (BUMPREFCNT (MAKEDIMMAP .AF.)))
.AF.]
DATUM)))
]
(/DECLAREDATATYPE (QUOTE ARRAYFRAME)
(QUOTE (POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER))
(QUOTE ((ARRAYFRAME 0 POINTER)
(ARRAYFRAME 2 POINTER)
(ARRAYFRAME 4 POINTER)
(ARRAYFRAME 6 POINTER)
(ARRAYFRAME 8 POINTER)
(ARRAYFRAME 10 POINTER)
(ARRAYFRAME 12 POINTER)
(ARRAYFRAME 14 POINTER)))
(QUOTE 16))
(/DECLAREDATATYPE (QUOTE ARRAYFRAME)
(QUOTE (POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER))
(QUOTE ((ARRAYFRAME 0 POINTER)
(ARRAYFRAME 2 POINTER)
(ARRAYFRAME 4 POINTER)
(ARRAYFRAME 6 POINTER)
(ARRAYFRAME 8 POINTER)
(ARRAYFRAME 10 POINTER)
(ARRAYFRAME 12 POINTER)
(ARRAYFRAME 14 POINTER)))
(QUOTE 16))
(/DECLAREDATATYPE (QUOTE ARRAYFRAME)
(QUOTE (POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER))
(QUOTE ((ARRAYFRAME 0 POINTER)
(ARRAYFRAME 2 POINTER)
(ARRAYFRAME 4 POINTER)
(ARRAYFRAME 6 POINTER)
(ARRAYFRAME 8 POINTER)
(ARRAYFRAME 10 POINTER)
(ARRAYFRAME 12 POINTER)
(ARRAYFRAME 14 POINTER)))
(QUOTE 16))
[DECLARE: EVAL@COMPILE
(RECORD ID (SNF . TITLEF)
(TYPE? LISTP))
(ACCESSFN KEEPS [(KEEPS (GETARRAYPROP DATUM (QUOTE KEEPS))
(SETARRAYPROP DATUM (QUOTE KEEPS)
(the (LST OF INTEGER)
NEWVALUE])
]
[DECLARE: EVAL@COMPILE
(RECORD AELTPTR (SOURCE . PTR)
[TYPE? (AND (LISTP DATUM)
(type? ARRAY (FETCH SOURCE OF DATUM])
]
(DECLARE: EVAL@COMPILE
(PUTPROPS IJKBOX DMACRO (= . PROGN))
(PUTPROPS IVALUE DMACRO (= . PROGN))
)
(PUTPROPS fadd CLISPWORD (CHANGETRAN . fadd))
(PUTPROPS FADD CLISPWORD (CHANGETRAN . fadd))
(PUTPROPS fadd CHANGEWORD [LAMBDA (F)
(LIST (QUOTE DATUM←)
(APPEND (QUOTE (FPLUS DATUM))
(CDDR F])
)
)
(MOVD (QUOTE GETAELT)
(QUOTE COPYAELT))
(DECLARE: DOCOPY
(DECLARE: EVAL@LOADWHEN TESTSYS
(DECLARE: EVAL@COMPILE
(DECLTYPES (ARRAY (SYNONYM ARRAYFRAME)
COERCION (CONV.ARRAY))
(ARRAY ARRAY COERCION (CONV.ARRAY))
(VECTOR (SUBTYPE ARRAY)
TESTFN [LAMBDA (VALUE)
(ARRAYTYPEP VALUE (QUOTE VECTOR]
COERCION (CONV.VECTOR))
(MATRIX (SUBTYPE ARRAY)
TESTFN [LAMBDA (VALUE)
(ARRAYTYPEP VALUE (QUOTE MATRIX]
COERCION (CONV.ARRAY (ARRAYTYPEP UARG (QUOTE MATRIX)))))
)
(DECLARE: EVAL@COMPILE
(DECLTYPE FORMATCODE (MEMQ FULL SYMMETRIC)
COERCION ((OR (MISSPELLED? UARG 80 (QUOTE (FULL SYMMETRIC)))
(UERROR "Invalid format specification: " .P2 UARG))))
)
)
)
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
(ADDTOVAR NLAMA )
(ADDTOVAR NLAML )
(ADDTOVAR LAMA )
)
(PUTPROPS GLOBAL COPYRIGHT ("Xerox Corporation" 1983 1984 1985 1986))
(DECLARE: DONTCOPY
(FILEMAP (NIL (1105 13398 (AELTTYPE 1115 . 1764) (ALLOC.SARRAY 1766 . 2773) (ARRAYTYPEP 2775 . 3391) (
COPYIDLARRAY 3393 . 4828) (DIMENSIONP 4830 . 5227) (GETAELT 5229 . 5918) (GETARRAYPROP 5920 . 6267) (
LEVELP 6269 . 6613) (MAKEOFFSETS 6615 . 7336) (NLOGICALELTS 7338 . 7970) (NPHYSICALELTS 7972 . 8649) (
PRESERVE 8651 . 10161) (SERIALNUMBER 10163 . 10842) (SETARRAYPROP 10844 . 11194) (SETAELT 11196 .
12416) (VFROMR 12418 . 13023) (ZEROFORARRAY 13025 . 13396)))))
STOP