(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