(FILECREATED "16-Feb-86 13:53:10" {QV}<IDL>SOURCES>SELECTOR.;21 24546
changes to: (VARS SELECTORCOMS)
previous date: "16-Feb-86 13:16:59" {QV}<IDL>SOURCES>SELECTOR.;20)
(* Copyright (c) 1983, 1984, 1985, 1986 by Xerox Corporation. All rights reserved.)
(PRETTYCOMPRINT SELECTORCOMS)
(RPAQQ SELECTORCOMS ((* This file contains the functions that support system selections)
(FNS ADJUST.LINLOC ADJUST.SELECTION ADJUST.SELTTE AELTPTR AELTPTR1 AELTPTR2 COMPOSE.SLTRS
FORMATOF FSELECT LINELT LINELTPTR LTOPLOC MAKEDIMMAP PHYSELT SUBSCRIPTP SYMELTLOC
TTELTDIMS TTELTTYPE TTGETELT VSCALARP VSCALARPTR)
(IF: TESTSYS (MACROS BASEDIM TTABDIM LINELT LINELTPTR PHYSELT)
(DECLTYPES TTELT))))
(* This file contains the functions that support system selections)
(DEFINEQ
(ADJUST.LINLOC
[DLAMBDA ((ARY SIMARRAY)
(LINLOC IJK [SATISFIES (BETWEEN LINLOC 1 (NLOGICALELTS (fetch SHAPE of ARY])
(DIM POSINT (SATISFIES (DIMENSIONP ARY DIM)))
(DELTA IJKDELTA (SATISFIES (ILEQ (IABS DELTA)
(GETRELT (fetch SHAPE of ARY)
DIM))))
(RETURNS IJK [SATISFIES (BETWEEN VALUE 1 (NLOGICALELTS (fetch SHAPE of ARY]))
(* jop: "26-Nov-85 00:26")
(* ADJUST.LINLOC moves the linear index LINLOC to the linear offset corresponding to an adjustment of DELTA on the
DIM dimension. It is used by system code to produce the offsets that will be turned into AELTPTRs by RELTPTR.)
(IJKBOX (IPLUS LINLOC (ITIMES (GETRELT (fetch (SIMARRAY OFFSETS) of ARY)
DIM)
DELTA)))])
(ADJUST.SELECTION
[DLAMBDA ((SEL SELARRAY (* Selection to be adjusted))
(ODIM POSINT (* Dimension wrt original object to be adjusted))
(NEW [ONEOF TTELT (LISTP (SATISFIES (AND (FIXP (CAR NEW))
(FIXP (CDR NEW))
(NOT (IGREATERP (CAR NEW)
(CDR NEW]
(* New selector for DIM)))
(* jop: "12-Nov-84 16:33" posted: "26-AUG-78 16:53")
(DPROG ((TTAB (fetch TTAB of SEL) ROWPTR)
(BDIM 0 INTEGER (* Adjustment dimension in terms of base of selection))
(TDIM NIL INTEGER (* Adjustment dimension within TTAB element))
(TTCAR NIL TTELT)
(TTCDR NIL (ONEOF NIL SELARRAY (MEMQ HIDDEN))))
[bind V (S ← 0) while (ILESSP S ODIM)
do (SETQ TTCDR (GETRELTD TTAB (add BDIM 1)))
[OR (EQ TTCDR (QUOTE HIDDEN))
(add S (SETQ V (if TTCDR
then (fetch NDIMS of (fetch BASEARRAY of TTCDR))
else 1]
finally (SETQ TDIM (IPLUS V ODIM (IMINUS S] (* Finding the dimensions of interest)
(SETQ TTCAR (GETRELT TTAB BDIM))
[if (type? SELARRAY TTCDR)
then
(* TTCDR is the selarray formed in the COMPOSE.SLTR that formed TTE. The original selector is its base array and the
later selection is its ttab)
(ADJUST.SELECTION TTCDR TDIM NEW)
(* The COPYAELT in ADJUST.SELTTE could be producing largep's. Perhaps should use a GETAELT there and copy the LARGEP
sharing logic from down below to fix up TTCAR.)
(SETRELT TTAB BDIM (ADJUST.SELTTE TTCDR TTCAR TDIM))
elseif (LISTP NEW)
then (if (EQ TTCAR (QUOTE ALL))
then [SETRELT TTAB BDIM (VFROMR (GENROW (CAR NEW)
(CDR NEW]
else (* Possible bug: Should we be smashing the EB if its
refcount is gt 1? -- rmk)
(DPROG ((EB (fetch ELEMENTBLOCK of (the VECTOR TTCAR)) ROWINT)
(L (ADD1 (IDIFFERENCE (CDR NEW)
(CAR NEW))) INTEGER))
[if (IGREATERP L (fetch PHYSICALNELTS of EB))
then (replace ELEMENTBLOCK of TTCAR with (GENROW (CAR NEW)
(CDR NEW)))
else (replace NELTS of EB with L)
(for J to L do (SETRELT EB J (IPLUS (CAR NEW)
J -1]
(SETRELT (fetch SHAPE of TTCAR)
1 L)))
else (DPROGN ((NEW [TTELT (SATISFIES (IEQP (TTELTDIMS TTCAR)
(TTELTDIMS NEW]))
(* The fancy LARGEP logic guarantees that the TTAB will have its own large box allocated the first time it gets a
large NEW. Thus, the TTAB won't share with any other code. The IEQP test guarantees compatible types.
This code is commented out, since it only matters for efficiency on the 10)
(SELECTQ (SYSTEMTYPE)
((TENEX TOPS-20)
(if (type? LARGEP TTCAR)
then (replace I of TTCAR with (the INTEGER NEW))
elseif (type? LARGEP NEW)
then (SETRELT TTAB BDIM (fetch I of NEW))
else (SETRELT TTAB BDIM NEW)))
(D (SETRELT TTAB BDIM NEW))
(HELP)))]
[if (NOT (type? INTEGER NEW))
then (DPROG ((NDL (for I to (SUB1 BDIM) sum (TTELTDIMS (GETRELT TTAB I))) INTEGER
(* Number of Dimensions to the Left of BDIM))
(BASE (fetch BASEARRAY of SEL) SIMARRAY)
(SELSHP (fetch SHAPE of SEL) ROWINT))
[if (type? SIMARRAY NEW)
then (for I from (ADD1 NDL) as J to (fetch NDIMS of NEW)
do (SETRELT SELSHP I (GETRELT (fetch SHAPE of NEW)
J)))
else (SETRELT SELSHP (ADD1 NDL)
(if (LISTP NEW)
then (ADD1 (IDIFFERENCE (CDR NEW)
(CAR NEW)))
else (GETRELT (fetch SHAPE of BASE)
BDIM]
(replace FORMAT of SEL with (FORMATOF BASE TTAB)))]
(* Making any necessary adjustments in the shape)
(SETTITLE SEL NIL) (* Removing title that might reflect previous slices)
)])
(ADJUST.SELTTE
[DLAMBDA ((S SELARRAY)
(A (ONEOF INTEGER SIMARRAY))
(D INTEGER)
(RETURNS (ONEOF INTEGER SIMARRAY)))
(* bas: "28-AUG-78 03:20" posted: "26-AUG-78 16:53")
(if (VSCALARP S)
then (COPYAELT S (VSCALARPTR S))
else
(* This is chicken-shit code. There is lots of potentially sharable structure in A but I dont know how to update it
all safely. Someday ...)
(CONV.SIMARRAY S LABPROPFLAG))])
(AELTPTR
[DLAMBDA ((A ARRAY)
(IDX ROWINT (SATISFIES (SUBSCRIPTP A IDX)))
(RETURNS AELTPTR))
(* jop: "27-Nov-85 17:27")
(* takes an array and a subscript for the array and
returns a pointer that can be used by getaelt and
putaelt.)
(create
AELTPTR
SOURCE ← A
PTR ←(SELECTQ
(fetch (ARRAYFRAME TYPE) of A)
[SIMPLE (LINELTPTR A (for I (LL ← 1) to (fetch NDIMS of A) declare (LL IJK)
do [SETQ LL (ADJUST.LINLOC A LL I (SUB1 (GETRELT IDX I]
finally (RETURN LL]
[SELECTION
(DPROG ((CDIM 0 CARDINAL (* Current dimension))
(BLOC 1 IJK (* Base array linloc))
(TTLOC NIL IJK (* TTab linloc))
(TTI NIL TTELT (* Holds the current TTAB))
(BASE (fetch BASEARRAY of A) SIMARRAY))
[for I to (fetch NDIMS of BASE)
do (SETQ BLOC
(ADJUST.LINLOC
BASE BLOC I
(SUB1 (SELECTQ (TTELTTYPE (SETQ TTI (GETRELT (fetch TTAB
of A)
I)))
(INTEGER TTI)
(ALL (GETRELT IDX (add CDIM 1)))
(ARRAY (SETQ TTLOC 1)
[for J to (fetch NDIMS of TTI)
do (SETQ TTLOC
(ADJUST.LINLOC
TTI TTLOC J
(SUB1 (GETRELT IDX
(add CDIM 1]
(LINELT TTI TTLOC))
(SHOULDNT]
(RETURN (LINELTPTR BASE BLOC)))]
(SHOULDNT)))])
(AELTPTR1
[DLAMBDA ((V VECTOR)
(I IJK (SATISFIES (LEVELP V 1 I)))
(RETURNS AELTPTR))
(* jop: "27-Nov-85 17:28" posted: " 9-SEP-77 17:32")
(* AELTPTR specialized for vectors)
(create AELTPTR
SOURCE ← V
PTR ←(SELECTQ (fetch (ARRAYFRAME TYPE) of V)
(SIMPLE (RELTPTR (fetch ELEMENTBLOCK of V)
I))
[SELECTION (DPROG ((BASE (fetch (SELARRAY BASEARRAY) of V) SIMARRAY)
(BL 1 IJK)
(TK NIL TTELT))
[for K to (fetch NDIMS of BASE)
do (SETQ TK (GETRELT (fetch TTAB
of V)
K))
(SETQ BL
(ADJUST.LINLOC
BASE BL K
(SUB1 (SELECTQ (TTELTTYPE TK)
(INTEGER TK)
(ALL I)
(ARRAY (PHYSELT
TK I))
(SHOULDNT]
(RETURN (LINELTPTR BASE BL)))]
(SHOULDNT)))])
(AELTPTR2
[DLAMBDA ((A MATRIX)
(I INTEGER (SATISFIES (LEVELP A 1 I)))
(J INTEGER (SATISFIES (LEVELP A 2 J)))
(RETURNS AELTPTR))
(* jop: "26-Nov-85 00:22" posted: "18-MAY-77 01:03")
(* Takes a matrix and i and j indicies for it and returns an element pointer. Like AELTPTR except macro expanded
for the common two dimensional case.)
(create AELTPTR
SOURCE ← A
PTR ←(SELECTQ
(fetch (ARRAYFRAME TYPE) of A)
[SIMPLE (RELTPTR (fetch ELEMENTBLOCK of A)
(SELECTQ (fetch FORMAT of A)
(FULL (IPLUS (ITIMES (SUB1 I)
(GETRELT
(fetch (SIMARRAY OFFSETS)
of A)
1))
J))
(SYMMETRIC (SYMELTLOC I J))
(SHOULDNT]
[SELECTION (DPROG ((BASELIN 1 IJK (* Base array linloc))
(TTLIN NIL IJK (* TTab elt linloc))
(BASE (fetch BASEARRAY of A) SIMARRAY)
(TK NIL TTELT (* The current TTAB))
(NEXTINDEX I IJK (* a place to hold an index)))
[for K to (fetch NDIMS of BASE)
do (SETQ TK (GETRELT (fetch TTAB of A)
K))
(SETQ BASELIN
(ADJUST.LINLOC
BASE BASELIN K
(SUB1 (SELECTQ (TTELTTYPE TK)
(INTEGER TK)
(ALL (PROG1 NEXTINDEX (SETQ
NEXTINDEX J)))
(ARRAY (SETQ TTLIN 1)
(for L
to (fetch NDIMS
of TK)
do
(SETQ TTLIN
(ADJUST.LINLOC
TK TTLIN L
(SUB1 NEXTINDEX)))
(SETQ NEXTINDEX J))
(LINELT TK TTLIN))
(SHOULDNT]
(RETURN (LINELTPTR BASE BASELIN)))]
(SHOULDNT)))])
(COMPOSE.SLTRS
[DLAMBDA ((OLD ROWPTR)
(NEW ROWPTR [SATISFIES (IEQP NEW:NELTS (for I to OLD:NELTS sum (TTELTDIMS OLD$I])
(RETURNS ROWPTR))
(* bas: " 3-OCT-78 12:16" posted: " 7-AUG-78 23:03")
(* Composes two translation tables, OLD and NEW, to
form a newer translation table which is their
composite.)
(DPROG ((L (OLD:NELTS) INTEGER)
THEN (AC (create ROWPTR
NELTS ← L) ROWPTR)
(H NIL TTELT (* Scratch TTELT))
(X NIL ROWPTR (* Scratch ROWPTR))
(Y NIL SELARRAY (* Scratch selarray)))
[for I J←0 to L
do (H←OLD$I)
(AC$I←(the TTELT (SELECTQ (TTELTTYPE H)
(INTEGER (GETRELTD AC I)
←'HIDDEN (* Mark HIDDEN dimension)
H)
(ALL NEW$ (add J 1))
(ARRAY X← (create ROWPTR
NELTS ← H:NDIMS)
(for K to X:NELTS do (X$K←NEW$(add J 1)))
Y←
(FSELECT H X)
(GETRELTD AC I)
←Y (* Leave selarray for adjustor)
(if (VSCALARP Y)
then (COPYAELT Y (VSCALARPTR Y))
else (CONV.SIMARRAY Y LABPROPFLAG)))
(SHOULDNT]
(RETURN AC))])
(FORMATOF
[DLAMBDA ((A SIMARRAY)
(B ROWPTR (SATISFIES (IEQP A:NDIMS B:NELTS)))
(RETURNS FORMATCODE))
(* bas: "27-AUG-78 18:18" posted: "27-AUG-78 18:18")
(* Determines the format of the result of selecting A with B. Is SYMMETRIC for a symmetric selector on a vector or
two equivalent vector selectors on a symmetric)
(OR (AND (IEQP B:NELTS 1)
(type? ARRAY (B$1))
(B$1):FORMAT)
(AND A:FORMAT='SYMMETRIC (DPROG ((X (B$1) TTELT)
(Y (B$2) TTELT))
[RETURN (OR X=Y (AND (type? SIMARRAY X)
(type? SIMARRAY Y)
(EQUALROW X:SHAPE Y:SHAPE)
(EQUALROW X:ELEMENTBLOCK Y:ELEMENTBLOCK])
'SYMMETRIC)
'FULL)])
(FSELECT
[DLAMBDA ((A ARRAY)
(B ROWPTR (SATISFIES A:NDIMS=B:NELTS))
(RETURNS SELARRAY))
(* jop: "27-Nov-85 17:29" posted: " 7-AUG-78 23:12")
(* Builds a selarray from A and the selector B.)
(SELECTQ (fetch (ARRAYFRAME TYPE) of A)
[SIMPLE (DPROG ((SHAPE (fetch SHAPE of A) ROWINT)
(N (for I to (fetch NELTS of B)
sum (TTELTDIMS (GETRELT B I))) INTEGER
(* New array's dimensions))
THEN (NEWSHP (create ROWINT
NELTS ← N) ROWINT
(* Output shape))
(RETURNS SELARRAY))
(for I (L ← 0) to (fetch NELTS of B)
do (SELECTQ (TTELTTYPE (GETRELT B I))
(ALL (SETRELT NEWSHP (add L 1)
(GETRELT SHAPE I)))
[ARRAY (DPROG ((BIS (fetch SHAPE
of (GETRELT B I)) ROWINT))
(for J to (fetch NELTS
of BIS)
do (SETRELT NEWSHP
(add L 1)
(GETRELT BIS J))))]
(INTEGER (* We copy LARGEP's so clients, particularly of
ADJUST.SELECTION, don't have to worry about implicit
sharing.)
(SELECTQ
(SYSTEMTYPE)
[(TENEX TOPS-20)
(if (type? LARGEP (GETRELT B I))
then (SETRELT
B I (fetch I
of (GETRELT
B I]
NIL))
NIL))
(RETURN (create SELARRAY
BASEARRAY ← A
SHAPE ← NEWSHP
TTAB ← B
FORMAT ←(FORMATOF A B))))]
(SELECTION (FSELECT (fetch (SELARRAY BASEARRAY) of A)
(COMPOSE.SLTRS (fetch TTAB of A)
B)))
(SHOULDNT))])
(LINELT
[DLAMBDA ((A SIMARRAY (SATISFIES A:AELTTYPE='INTEGER))
(L INTEGER)
(RETURNS INTEGER))
(* bas: "11-AUG-78 17:06" posted: "11-AUG-78 02:00")
(* Retrieves the element of A corresponding to linear
index L)
(PHYSELT A (LTOPLOC A L))])
(LINELTPTR
[DLAMBDA ((A SIMARRAY)
(L INTEGER)
(RETURNS RELTPTR))
(* rmk: "16-APR-79 12:17" posted: "11-AUG-78 15:01")
(RELTPTR A:ELEMENTBLOCK (LTOPLOC A L))])
(LTOPLOC
[DLAMBDA ((A SIMARRAY)
(N INTEGER)
(RETURNS INTEGER))
(* jop: "27-Nov-85 17:37" posted: "11-AUG-78 02:01")
(* Maps a linear to a physical index for the array)
(SELECTQ (fetch FORMAT of A)
(FULL N)
[SYMMETRIC (DPROG ((S (GETRELT (fetch (SIMARRAY OFFSETS) of A)
1) IJK)
THEN (I (IQUOTIENT N S) IJK)
(J (IREMAINDER N S) IJK))
(if (IEQP J 0)
then (SETQ J S)
else (add I 1))
(RETURN (SYMELTLOC I J)))]
(SHOULDNT))])
(MAKEDIMMAP
[DLAMBDA ((SEL SELARRAY)
(RETURNS ROWPTR (SATISFIES VALUE:NELTS=SEL:NDIMS)))
(* rmk: " 2-MAR-80 22:44" posted: " 7-AUG-78 23:32")
(* Makes map from virtual to base and ttab dimensions)
(DPROG ((K 0 CARDINAL)
(TT (SEL:TTAB) ROWPTR)
(DM (create ROWPTR
NELTS ← SEL:NDIMS) ROWPTR))
(for I to TT:NELTS do (for J to (TTELTDIMS TT$I)
do (add K 1)
(DM$K←I)
((GETRELTD DM K)←J)))
(RETURN DM))])
(PHYSELT
[DLAMBDA ((A SIMARRAY (SATISFIES A:AELTTYPE='INTEGER))
(P INTEGER)
(RETURNS INTEGER))
(* bas: "11-AUG-78 16:59" posted: "11-AUG-78 01:59")
(* Retrieves the element of A corresponding to physical
index P)
(the ROWINT A:ELEMENTBLOCK)$P])
(SUBSCRIPTP
[DLAMBDA ((ARY ARRAY)
(SUB ROWINT)
(RETURNS BOOL))
(* bas: " 5-JUN-77 13:50")
(* checks subscript for an array, compares it with the
shape)
(AND (IEQP SUB:NELTS ARY:NDIMS)
(for I to SUB:NELTS always (LEVELP ARY I SUB$I)))])
(SYMELTLOC
[DLAMBDA ((I IJK)
(J IJK)
(RETURNS IJK))
(* jop: "12-Nov-84 16:39")
(* Calculates the linear location of a subscript pair
in a symmetric array elementblock.)
[if (ILESSP I J)
then (SETQ I (PROG1 J (SETQ J I]
(IPLUS (IQUOTIENT (ITIMES I (SUB1 I))
2)
J)])
(TTELTDIMS
[DLAMBDA ((TT TTELT)
(RETURNS IJK))
(* jop: "12-Nov-84 16:24" posted: "20-JUL-77 15:10")
(* Returns the dimensionality subtended by this ttab
elt in the virtual object)
(SELECTQ (TTELTTYPE TT)
(INTEGER 0)
(ALL 1)
(ARRAY (fetch NDIMS of TT))
(SHOULDNT))])
(TTELTTYPE
[DLAMBDA ((TTE TTELT)
(RETURNS (MEMQ ALL ARRAY INTEGER)))
(* bas: " 5-AUG-78 19:59" posted: " 5-AUG-78 19:55")
(* Returns the type of a translation table element)
(if TTE='ALL
then 'ALL
elseif (FIXP TTE)
then 'INTEGER
else 'ARRAY)])
(TTGETELT
[DLAMBDA ((TTELT TTELT (SATISFIES (NOT (type? INTEGER TTELT))))
(INDEX INTEGER)
(RETURNS IJK))
(* bas: "10-FEB-83 14:57")
(* Used in various functions to map a virtual level
thru a ttab element into a base level)
(IJKBOX (SELECTQ (TTELTTYPE TTELT)
(ALL INDEX)
(ARRAY (PHYSELT TTELT INDEX))
(SHOULDNT)))])
(VSCALARP
[DLAMBDA ((S ANY)
(RETURNS BOOL))
(* bas: "10-FEB-83 15:35")
(* This function determines, for a given object,
whether it represents a scalar formed by selecting an
array down to a single element.)
(AND (type? SELARRAY S)
(IEQP 0 (fetch NDIMS of S)))])
(VSCALARPTR
[DLAMBDA ((VS SELARRAY (SATISFIES (VSCALARP VS)))
(RETURNS AELTPTR))
(* bas: "15-FEB-83 15:04")
(* Produces the aeltptr that fingers the location of a
virtual scalar)
(DPROG ((LL 1 IJK)
(BASE (fetch BASEARRAY of VS) SIMARRAY)
(TT (fetch TTAB of VS) ROWPTR)
(RETURNS AELTPTR))
[for I to (fetch NDIMS of BASE) do (SETQ LL (ADJUST.LINLOC BASE LL I
(SUB1 (GETRELT TT I]
(RETURN (create AELTPTR
SOURCE ← VS
PTR ←(LINELTPTR BASE LL))))])
)
(DECLARE: DOCOPY
(DECLARE: EVAL@LOADWHEN TESTSYS
(DECLARE: EVAL@COMPILE
(PUTPROPS BASEDIM MACRO ((SEL DIM)
(GETRELT (fetch DIMMAP of SEL)
DIM)))
(PUTPROPS TTABDIM MACRO ((SEL DIM)
(GETRELTD (fetch DIMMAP of SEL)
DIM)))
[PUTPROPS LINELT MACRO (OPENLAMBDA (A L)
(PHYSELT A (LTOPLOC A L]
[PUTPROPS LINELTPTR MACRO (OPENLAMBDA (A L)
(RELTPTR (fetch ELEMENTBLOCK of A)
(LTOPLOC A L]
(PUTPROPS PHYSELT MACRO ((A P)
(GETRELT (the ROWINT (fetch ELEMENTBLOCK of (the SIMARRAY A)))
P)))
)
(DECLARE: EVAL@COMPILE
(DECLTYPE TTELT [ONEOF (MEMQ ALL)
IJK
(SIMARRAY (SATISFIES (EQ (fetch AELTTYPE of VALUE)
(QUOTE INTEGER])
)
)
)
(PUTPROPS SELECTOR COPYRIGHT ("Xerox Corporation" 1983 1984 1985 1986))
(DECLARE: DONTCOPY
(FILEMAP (NIL (807 23749 (ADJUST.LINLOC 817 . 1741) (ADJUST.SELECTION 1743 . 6839) (ADJUST.SELTTE 6841
. 7413) (AELTPTR 7415 . 9323) (AELTPTR1 9325 . 10615) (AELTPTR2 10617 . 12820) (COMPOSE.SLTRS 12822
. 14359) (FORMATOF 14361 . 15257) (FSELECT 15259 . 17498) (LINELT 17500 . 17926) (LINELTPTR 17928 .
18193) (LTOPLOC 18195 . 19013) (MAKEDIMMAP 19015 . 19677) (PHYSELT 19679 . 20107) (SUBSCRIPTP 20109 .
20551) (SYMELTLOC 20553 . 21055) (TTELTDIMS 21057 . 21539) (TTELTTYPE 21541 . 21974) (TTGETELT 21976
. 22520) (VSCALARP 22522 . 22991) (VSCALARPTR 22993 . 23747)))))
STOP