(FILECREATED "16-Feb-86 13:46:22" {QV}<IDL>SOURCES>GENERATORS.;17 15853
changes to: (VARS GENERATORSCOMS)
previous date: "16-Feb-86 13:06:17" {QV}<IDL>SOURCES>GENERATORS.;16)
(* Copyright (c) 1983, 1984, 1985, 1986 by Xerox Corporation. All rights reserved.)
(PRETTYCOMPRINT GENERATORSCOMS)
(RPAQQ GENERATORSCOMS ((* Generator package. This file contains the generation functions used for
simple and selected arrays, plus data definitions and utility routines
used in the generation of functional arrays.)
(FNS GENTOARY SETUP RESETUP SKIP NEXT SIMPLE.NEXTFN SYMSELECT.NEXTFN
SELECTION.NEXTFN)
(INITRECORDS GENSTATEBLOCK)
(IF: TESTSYS (RECORDS GENSTATEBLOCK SELECTIONETC)
(DECLTYPES GORDER)
(I.S.OPRS rowmajor))))
(* Generator package. This file contains the generation functions used for simple and selected
arrays, plus data definitions and utility routines used in the generation of functional
arrays.)
(DEFINEQ
(GENTOARY
[DLAMBDA ((GDIM INTEGER (SATISFIES (BETWEEN GDIM 1 NDIM)))
(ORDR GORDER)
(NDIM INTEGER)
(RETURNS INTEGER (SATISFIES (BETWEEN VALUE 1 NDIM))))
(* bas: " 7-AUG-78 22:08" posted: " 1-JUL-77 23:50")
(* Maps a dimension in the generator sequence into a
dimension in the array being generated)
(if (ORDR='ROWMAJOR)
then NDIM+1-GDIM
else GDIM)])
(SETUP
[DLAMBDA ((ARY ARRAY)
(ORD GORDER)
(GSB (ONEOF NIL GENSTATEBLOCK))
(RETURNS GENSTATEBLOCK))
(* jop: "27-Nov-85 17:25" posted: " 7-AUG-78 21:15")
(* SETUP routine: Does it itself for arrays, else
calls setup function if argument is a functional
array)
(if (NOT GSB)
then (SETQ GSB (create GENSTATEBLOCK)))
(DPROGN ((GSB GENSTATEBLOCK))
(replace SOURCEARRAY of GSB with ARY)
(replace LINLOC of GSB with 0)
[replace ELTCNT of GSB with (if (EQ ORD (QUOTE SYMMETRIC))
then (NPHYSICALELTS (fetch SHAPE of ARY)
(fetch FORMAT of ARY))
else (NLOGICALELTS (fetch SHAPE of ARY]
(replace ORDER of GSB with (if (EQ ORD (QUOTE DONTCARE))
then (QUOTE ROWMAJOR)
else ORD))
(SELECTQ (fetch (ARRAYFRAME TYPE) of ARY)
[SIMPLE (if (SELECTQ (fetch FORMAT of ARY)
(FULL (EQ (fetch ORDER of GSB)
(QUOTE ROWMAJOR)))
(SYMMETRIC (EQ (fetch ORDER of GSB)
(QUOTE SYMMETRIC)))
(SHOULDNT))
then (replace NEXTFN of GSB with (QUOTE PHYSICAL.NEXTFN))
(replace ETC of GSB with (fetch ELEMENTBLOCK
of ARY))
else (replace NEXTFN of GSB with (QUOTE SIMPLE.NEXTFN))
(replace ETC of GSB with (create ROWINT
NELTS ←(fetch NDIMS
of ARY)
INIT ← 1]
(SELECTION (SELECTQ (fetch FORMAT of ARY)
[FULL (replace NEXTFN of GSB with (QUOTE
SELECTION.NEXTFN))
(replace ETC of GSB
with (create SELECTIONETC
TTABLINLOC ←(create
ROWINT
NELTS ←(fetch NDIMS
of (fetch BASEARRAY
of ARY))
INIT ← 1)
VIRTSUBSCRIPT ←(create
ROWINT
NELTS ←(fetch NDIMS
of ARY)
INIT ← 1]
(SYMMETRIC (replace NEXTFN of GSB with (QUOTE
SYMSELECT.NEXTFN))
(replace ETC of GSB with (CONS 1 1)))
(SHOULDNT)))
(SHOULDNT)) (* Correct code for FUNCTIONAL arrays would be
something like (APPLY* (fetch SETUPFN of ARY) GSB))
GSB)])
(RESETUP
[DLAMBDA ((GSB GENSTATEBLOCK)
(RETURNS GENSTATEBLOCK))
(* bas: " 6-AUG-78 17:39" posted: " 1-JUL-77 23:52")
(* RESETs a GSB so that the next NEXT will start the
generation over)
GSB:LINLOC←0
GSB:ELTCNT←(NLOGICALELTS GSB:SOURCEARRAY:SHAPE)
(SELECTQ GSB:NEXTFN
(PHYSICAL.NEXTFN GSB:ELTCNT←GSB:ETC:NELTS)
(SIMPLE.NEXTFN (ROWBLT GSB:ETC 1))
(SELECTION.NEXTFN (ROWBLT GSB:ETC:TTABLINLOC 1)
(ROWBLT GSB:ETC:VIRTSUBSCRIPT 1))
(SYMSELECT.NEXTFN GSB:ETC:1←1 GSB:ETC::1←1)
(SHOULDNT))
GSB])
(SKIP
[DLAMBDA ((GSB GENSTATEBLOCK)
(N INTEGER (SATISFIES ~(MINUSP N)))
(RETURNS GENSTATEBLOCK))
(* bas: " 6-AUG-78 13:54" posted: " 1-JUL-77 23:51")
(* Skips the next N elements in the generation)
(if N GEQ GSB:ELTCNT
then (GSB:ELTCNT←0)
elseif GSB:NEXTFN='PHYSICAL.NEXTFN
then (add GSB:LINLOC N)
(add GSB:ELTCNT (-N))
else (RPTQ N (NEXT GSB)))
GSB])
(NEXT
[DLAMBDA ((GSB GENSTATEBLOCK (SATISFIES ~(GSB:DONE)))
(RETURNS AELTPTR))
(* bas: " 6-AUG-78 17:20" posted: " 7-AUG-78 21:20")
(add (fetch ELTCNT of GSB)
-1)
(create AELTPTR
SOURCE ←(fetch SOURCEARRAY of GSB)
PTR ←(SELECTQ (fetch NEXTFN of GSB)
(PHYSICAL.NEXTFN (RELTPTR (fetch ETC of GSB)
(add (fetch LINLOC of GSB)
1)))
(SIMPLE.NEXTFN (SIMPLE.NEXTFN GSB))
(SELECTION.NEXTFN (SELECTION.NEXTFN GSB))
(SYMSELECT.NEXTFN (SYMSELECT.NEXTFN GSB))
(APPLY* (fetch NEXTFN of GSB)
GSB)))])
(SIMPLE.NEXTFN
[DLAMBDA ((GSB GENSTATEBLOCK [SATISFIES (AND (EQ (fetch NEXTFN of GSB)
(QUOTE SIMPLE.NEXTFN))
(SUBSCRIPTP (fetch SOURCEARRAY of GSB)
(fetch ETC of GSB])
(RETURNS RELTPTR))
(* bas: "15-FEB-83 15:14")
(* SIMPLE.NEXTFN does generation for all simple arrays unless generation is in physical element order.
In that case, a specialized routine is used which handles this common case using the physical layout for
efficiency.)
(DPROG ((SOURCE (fetch SOURCEARRAY of GSB) SIMARRAY)
(CGD 0 INTEGER (* Once incremented will satisfy
(DIMENSIONP SOURCE CGD)))
(CAD NIL INTEGER (SATISFIES (DIMENSIONP (fetch SOURCEARRAY of GSB)
CAD)))
(LL (fetch LINLOC of GSB) IJK)
(DELTA NIL IJKDELTA (* Used to hold the offset))
(SUB (fetch ETC of GSB) ROWINT)
(RETURNS RELTPTR))
(if (IEQP LL 0)
then (SETQ LL 1)
else (do (SETQ CAD (GENTOARY (add CGD 1)
(fetch ORDER of GSB)
(fetch NDIMS of SOURCE)))
[SETQ DELTA (if (ILESSP (GETRELT SUB CAD)
(GETRELT (fetch SHAPE of SOURCE)
CAD))
then 1
else (IDIFFERENCE 1 (GETRELT SUB CAD]
(add (GETRELT SUB CAD)
DELTA) (* Adjust the subscript)
(SETQ LL (ADJUST.LINLOC SOURCE LL CAD DELTA))
(* Adjust the linloc)
repeatuntil (IGREATERP DELTA 0)))
(RETURN (LINELTPTR SOURCE (replace LINLOC of GSB with LL))))])
(SYMSELECT.NEXTFN
[DLAMBDA ((GSB GENSTATEBLOCK (SATISFIES GSB:NEXTFN='SYMSELECT.NEXTFN))
(RETURNS RELTPTR))
(* rmk: "16-APR-79 12:19" posted: " 6-JUN-77 18:25")
(* SYMSELECT.NEXTFN does generation for all sym selarrays. These are of two types: (1) Equivalent vector or ALL
sltrs on a sym base or (2) A sym sltr on a vector base. In both cases generation is done by subscript arithmetic
driven off the indices of the last element stored in GSB:ETC.)
(DPROG ((A (GSB:SOURCEARRAY) SELARRAY (SATISFIES A:FORMAT='SYMMETRIC))
(E (GSB:ETC) LISTP (SATISFIES (LEVELP GSB:SOURCEARRAY 1 E::1)
(LEVELP GSB:SOURCEARRAY 2 E:1))
(* Current indices as j,i))
(RETURNS RELTPTR))
(if (IEQP GSB:LINLOC 0)
then (* First call: indices already set)
elseif E:1 LT (if GSB:ORDER='SYMMETRIC
then E::1
else A:SHAPE$2)
then (add E:1 1)
else (FRPLACA E 1)
(add E::1 1)) (* GSB:ETC now set to the new indices)
[RETURN (RELTPTR A:BASEARRAY:ELEMENTBLOCK GSB:LINLOC←(SELECTQ A:BASEARRAY:FORMAT
(FULL (PHYSELT A:TTAB$1
(SYMELTLOC
E::1 E:1)))
(SYMMETRIC
(SYMELTLOC (TTGETELT
A:TTAB$1
E::1)
(TTGETELT
A:TTAB$2 E:1)
))
(SHOULDNT])])
(SELECTION.NEXTFN
[DLAMBDA ((GSB GENSTATEBLOCK (SATISFIES (EQ (fetch NEXTFN of GSB)
(QUOTE SELECTION.NEXTFN))))
(RETURNS RELTPTR))
(* edited: "16-Feb-86 12:37")
(* NEXT function for selections. Note: Except for the first call (flagged by LINLOC=0), it is assumed that
GSB:LINLOC and GSB:VSUB come in set to the values for the last cell returned, as do the TTABLL.
Any time a dimension is exhausted, the LINLOC is reset back to the place it started from, so that the offset that
is applied to the dimension that is incremented is considered to be the only adjustment that is made.)
(DPROG ((SOURCE (fetch SOURCEARRAY of GSB) SELARRAY)
THEN (BASE (fetch BASEARRAY of SOURCE) SIMARRAY)
(TTAB (fetch TTAB of SOURCE) ROWPTR)
(BLL (fetch LINLOC of GSB) IJK (* Base array LINLOC))
(TT NIL TTELT (* Scratch trans tab elt))
(RETURNS RELTPTR))
[if (IEQP BLL 0)
then (SETQ BLL 1) (* Place LINLOC on the first element)
(for I to (fetch NDIMS of BASE)
do (SETQ TT (GETRELT TTAB I))
[OR (EQ TT (QUOTE ALL))
(SETQ BLL (ADJUST.LINLOC BASE BLL I
(SUB1 (SELECTQ
(TTELTTYPE TT)
(INTEGER TT)
(ARRAY (PHYSELT TT 1))
(SHOULDNT]
(* ALL test should be inside the switch on TTELTTYPE but optimization is too attractive. Also uses the fact that
TTABELT$1 is the index of the first element in any enumeration.)
)
else (DPROG ((TTABLL (fetch TTABLINLOC of (fetch ETC of GSB)) ROWINT)
(VSUB (fetch VIRTSUBSCRIPT of (fetch ETC of GSB)) ROWINT)
(CGD 0 INTEGER (* Current generator dimension of SOURCE))
(CVD NIL INTEGER (SATISFIES (DIMENSIONP SOURCE CVD)))
(CBD NIL INTEGER (SATISFIES (DIMENSIONP BASE CBD)))
(DELTA NIL IJKDELTA (* adjustment offsets))
(OLL NIL IJK (* LinLoc)))
(* The first 2 bindings simply unpack the GSB for
clarity)
(do [(SETQ CVD (GENTOARY (add CGD 1)
(fetch ORDER of GSB)
(fetch NDIMS of SOURCE)))
(* Current virtual dimension)
(SETQ CBD (BASEDIM SOURCE CVD))
(* Corresponding base dim)
(SETQ TT (GETRELT TTAB CBD))
(* Its translation table)
[SETQ DELTA (if (ILESSP (GETRELT VSUB CVD)
(GETRELT (fetch SHAPE of SOURCE)
CVD))
then 1
else (IDIFFERENCE 1 (GETRELT VSUB CVD]
(* Amount of adjustment that must be made)
(add (GETRELT VSUB CVD)
DELTA) (* Update the virtual position)
(SETQ BLL
(ADJUST.LINLOC
BASE BLL CBD
(SELECTQ (TTELTTYPE TT)
(ALL DELTA)
(ARRAY (SETQ OLL (GETRELT TTABLL CBD))
(IDIFFERENCE
(LINELT TT (SETRELT TTABLL CBD
(ADJUST.LINLOC
TT OLL
(TTABDIM SOURCE CVD)
DELTA)))
(LINELT TT OLL)))
(SHOULDNT]
repeatuntil (IEQP DELTA 1)))]
(RETURN (LINELTPTR BASE (replace LINLOC of GSB with BLL))))])
)
(/DECLAREDATATYPE (QUOTE GENSTATEBLOCK)
(QUOTE (WORD WORD POINTER POINTER POINTER POINTER))
(QUOTE ((GENSTATEBLOCK 0 (BITS . 15))
(GENSTATEBLOCK 1 (BITS . 15))
(GENSTATEBLOCK 2 POINTER)
(GENSTATEBLOCK 4 POINTER)
(GENSTATEBLOCK 6 POINTER)
(GENSTATEBLOCK 8 POINTER)))
(QUOTE 10))
(DECLARE: DOCOPY
(DECLARE: EVAL@LOADWHEN TESTSYS
[DECLARE: EVAL@COMPILE
(DATATYPE GENSTATEBLOCK ((ELTCNT WORD)
(LINLOC WORD)
ORDER SOURCEARRAY NEXTFN ETC)
[ACCESSFNS GENSTATEBLOCK ((DONE (ZEROP (fetch ELTCNT of DATUM])
(ACCESSFNS SELECTIONETC [(TTABLINLOC (CAR (the LISTP DATUM)))
(VIRTSUBSCRIPT (CDR (the LISTP DATUM]
[CREATE (CONS (BUMPREFCNT (the ROWINT TTABLINLOC))
(BUMPREFCNT (the ROWINT VIRTSUBSCRIPT]
(TYPE? LISTP))
]
(/DECLAREDATATYPE (QUOTE GENSTATEBLOCK)
(QUOTE (WORD WORD POINTER POINTER POINTER POINTER))
(QUOTE ((GENSTATEBLOCK 0 (BITS . 15))
(GENSTATEBLOCK 1 (BITS . 15))
(GENSTATEBLOCK 2 POINTER)
(GENSTATEBLOCK 4 POINTER)
(GENSTATEBLOCK 6 POINTER)
(GENSTATEBLOCK 8 POINTER)))
(QUOTE 10))
(DECLARE: EVAL@COMPILE
(DECLTYPE GORDER (MEMQ ROWMAJOR COLMAJOR SYMMETRIC DONTCARE))
)
(DECLARE: EVAL@COMPILE
[I.S.OPR (QUOTE rowmajor)
NIL
(QUOTE (BIND $$GSB ← (SETUP BODY (QUOTE ROWMAJOR))
DECLARE
($$GSB GENSTATEBLOCK)
EACHTIME
(COND ((FETCH DONE OF $$GSB)
(GO $$OUT))
(T (SETQ I.V. (NEXT $$GSB]
)
)
)
(PUTPROPS GENERATORS COPYRIGHT ("Xerox Corporation" 1983 1984 1985 1986))
(DECLARE: DONTCOPY
(FILEMAP (NIL (1002 14236 (GENTOARY 1012 . 1580) (SETUP 1582 . 4345) (RESETUP 4347 . 5093) (SKIP 5095
. 5678) (NEXT 5680 . 6438) (SIMPLE.NEXTFN 6440 . 8407) (SYMSELECT.NEXTFN 8409 . 10106) (
SELECTION.NEXTFN 10108 . 14234)))))
STOP