(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