Google
 

Trailing-Edge - PDP-10 Archives - ap-c796e-sb - cn1n.bli
There are 18 other files named cn1n.bli in the archive. Click here to see a list.
!THIS SOFTWARE IS FURNISHED UNDER A LICENSE AND MAY ONLY BE USED
!  OR COPIED IN ACCORDANCE WITH THE TERMS OF SUCH LICENSE.
!
!COPYRIGHT (C) 1972,1973,1974,1977,1978 DIGITAL EQUIPMENT CORPORATION, MAYNARD, MASS. 01754
!FILENAME:		H1CNTR.BLI
!%4.11%			10 SEPTEMBER 1974	MGM/FLD/KR/GJB

%4.01,4.02,4.05,4.09,4.11%	GLOBAL BIND H1CNV=18;	!MODULE VERSION NUMBER
! REVISION HISTORY
! 9-21-77 ROUTINE GSE0 IS MODIFIED TO REMOVE CAI MACHINE
!             FROM MACRO LISTING. IT IS A NOP.
!
! 7-15_77  ROUTINE GSE5 IS MODIFIED TO HAVE NO OPTIMIZATION
!              IN SELECT EXPRESSION WHEN TESN IS PROCESSED.
!
!			GENERAL DOCUMENTATION FOR CONTROL.BLI
!	
!		THIS MODULE IS CONCERNED WITH MANIPULATING THE LINKED-LISTS
!	WHICH CONTAIN THE CODE AND WITH GENERATING THE CODE FOR CONTROL
!	EXPRESSIONS.   THE READER IS ADVISED TO READ THE MODULE LOLSTPKG
!	BEFORE OR IN PARALLEL WITH THIS ONE.   THE FORMATS OF THE LIST 
!	HEADERS AND ELEMENTS ARE EXPLAINED THERE.
!	
!		EACH CONTROL ENVIRONMENT GENERATES A SKELETON FROM WHICH
!	THE CODE FOR THAT CONTROL EXPRESSION IS SUSPENDED.  THE GLOBAL VARIABLE
!	CODEPTR IS ALWAYS LEFT POINTING AT THE HEADER FROM WHICH SUBSEQUENT
!	CODE IS TO BE GENERATED.  IT IS THE RESPONSIBILITY OF THE ROUTINES IN
!	THIS MODULE TO POSITION CODEPTR AT THE APPROPRIATE HEADER.
!	
!		IT IS PROBABLY EASIEST TO INDOCTRINATE THE READER INTO THE
!	TYPICAL ACTIVITY OF THESE ROUTINES BY AN EXAMPLE:
!	
!		... BEGIN LOCAL A,B; A_F(); ... ; .B END ...
!	
!	(WHILE READING THIS EXAMPLE YOU WILL NEED TO REFER TO THE FIRST THREE
!	ROUTINES OF THIS MODULE.)
!	
!		WHEN SA(SYNTAX ANALYZER) ENCOUNTERS "BEGIN" FOLLOWED BY A
!	DECLARATION IT CALLS GCE0 WITH A PARAMETER OF 1.  GCE0 BEGINS BY CREATING
!	A SKELETON CONSISTING OF A HEADER AND 4 SUBHEADERS:
!	
!			\        /
!			 \      /
!			  \----/
!		          !BEC !
!		          !0   !
!		          /----\
!		         /      \
!	  /-------------/        \-------------\
!	 /				        \
!	/----\      /----\      /----\      /----\
!	!BEC !\----/!BEC !\----/!BEC !\----/!BEC !
!	!1   !      !2   !      !3   !      !4   !
!	 ----        ----        ----        ----
!	
!	
!	
!		THIS HAS THE SIDE-EFFECT OF LEAVING CODEPTR POINTING TO THE
!	HEADER.  (NOTE: THROUGHOUT THE MODULE THE POSITION OF CODEPTR IS INDICATED
!	BY COMMENTS OF THE FORM:  ! --> X WHERE X CORRESPONDS TO A POSITION
!	ON THE RELEVANT SKELETON).  CODEPTR IS THEN MOVED TO POINT TO SUBHEADER #1
!	AND FROM THERE A CODE-CLASS HEADER IS SUSPENDED. A NOOP IS GENERATED
!	(GLICH TO AVOID BACKWARD JUMPS PASSING BEYOND A BLOCK).   THEN CODEPTR
!	IS MOVED TO SUBHEADER #2 (BODY OF THE BLOCK).  AT THIS POINT ANY REGISTERS
!	WHICH ARE IN USE ARE SAVED.  THEN A HEADER OF TYPE CURRENTC IS
!	GENERATED.  THIS IS USED TO DISTINGUISH THE CODE FOR THE PRESENT EXPRESSION
!	IN THE COMPOUND EXPRESSION FROM THE PRECEDING.  FINALLY A CODEC HEADER
!	IS CREATED FROM WHICH THE CODE OF THE FIRST EXPRESSION WILL BE SUSPENDED.
!	
!		NOW THE DECLARATION PROCESSOR PROCESSES THE DECLARATIONS OF THE
!	BLOCK AND WHEN THE ";" FOLLOWING A_F() IS ENCOUNTERED, GCE1 IS CALLED
!	WITH THE LEXEME FOR THE VALUE OF THE EXPRESSION.   NOTE THAT CODE FOR
!	THE ROUTINE CALL AND THE STORE HAS BEEN HUNG OFF THE CODEC HEADER
!	GENERATED IN GCE0.  GCE1 FIRST CLEARS THE TRCT LIST OF THE VALUE REGISTER
!	IF IT IS INVOLVED IN THE VALUE LEXEME SINCE SIDE-EFFECTS POTENTIALLY
!	OCCURED.  NEXT THE USE OF ANY REGISTER INVOLVED IN THE VALUE LEXEME
!	IS DECREASED (DULEX) SINCE THE FOLLOWING SEMICOLON MEANS THE VALUE WON'T
!	BE USED.  THE CODEPTR IS MOVED TO THE CURRENTC HEADER.   THE LIST
!	(POTENTIALLY) OF HEADERS SUSPENDED FROM THE CTC IS SCANNED FOR THOSE
!	OF TYPE CONVEY WHICH ARE DISCARDED.  A CONVEY HEADER IS ONE WHICH CONTAINS
!	THE CODE NECESSARY TO LOAD VREG WITH THE RESULT OF A CONTROL EXPRESSION.  IF
!	THE VALUE OF THE CONTROL EXPRESSION IS NOT NEEDED, THEN THIS CODE IS
!	DISCARDED BY LOSECONV.  FOR EXAMPLE:
!	
!		...; IF .A THEN C_.B; ...
!	
!	THE VALUE OF THE IF-EXPRESSION IS NOT USED.  THERE MAY ALSO BE HEADERS OF TYPE
!	RELC (RELATIONAL-EXPRESSION-CLASS: SEE GREL AND GBREL IN H2ARITH) HANGING
!	FROM CTC.  IF SO THESE ARE PROMOTED TO TYPE CODEC (SEE PROMOTE IN LOLSTPKG).
!	THIS LEAVES CTC EMPTY AND WE CONCLUDE GCE1 BY CREATING A NEW CODEC HEADER
!	BENEATH IT.
!	
!		WHEN SA ENCOUNTERS THE "END", IT CALLS GCE2 WITH THE VALUE
!	LEXEME X AND -(# OF LOCALS + 1).  FIRST GCE2 CONVEYS THE VALUE LEXEME.
!	THAT IS IT GENERATES (IF NECESSARY) CODE TO LOAD VREG WITH X SUSPENDING
!	THE CODE FROM A CONVEYC HEADER SO THAT IF THE VALUE IS NOT NEEDED (I.E.
!	SEMI-COLON AFTER THE END) THIS CODE CAN BE DISCARDED. GCE2 NOW MIMICS
!	GCE1 (PROMOTE-SYPHON) BUT THEN MOVES TO SUBHEADER #2 AND ERASES CTC.
!	THEN IT SCANS SUBHEADER #2 FOR ANY XBLOCKC HEADERS AND PROMOTES THEM
!	TO CONVEYS.  THEN CODEPTR MOVES TO SUBHEADER #3 AND CLASSIFIES IT AS A
!	LABEL.  NOTE THAT ANY JUMP GENERATED INSIDE THE BODY TO EXIT THIS BLOCK
!	WAS MADE TO THIS CELL.  ALSO ANY EXIT OF THIS BLOCK TO SOME HIGHER
!	CONTROL ENVIRONMENT GENERATED AN XCT OF THIS CELL WHICH SUBSEQUENTLY
!	WILL CONTAIN (POTENTIALLY) THE SUBTRACT FROM THE STACK POINTER FOR
!	LOCALS OF THE BLOCK.  CLASSLAB HAS THE SIDE-EFFECT OF MOVING CODEPTR
!	TO SUBHEADER #4.  A CODEC CELL IS PUSHED AND THE SUBTRACT IS GENERATED.
!	CODEPTR IS SET TO THE CODEC CELL SUPENDED FROM SUBHEADER #1 WHERE THE 
!	ADD IS GENERATED.  THEN CODEPTR IS MOVED TO THE MAIN HEADER, BEC #0.
!	THE SKELETON IS REMOVED (NOTE: HEADERS BEC #0, #1, #2, #4 DISAPPEAR BUT
!	BEC #3 WHICH IS NOW LABELC REMAINS).  THEN GCE2 RETURNS A LEXEME 
!	REPRESENTING VREG (FROM CONVEY) TO SA WHERE IT BECOMES THE VALUE OF SYM.
!	
!		HOPEFULLY THIS DISCUSSION BY EXAMPLE WILL GIVE THE READER
!	AT LEAST A VAGUE FEELING FOR WHAT TRANSPIRES IN ALL THE CONTROL CLASSES.
!	YOU WILL NOTE THAT IN MANY OF THE CLASSES THE MAIN HEADER (#0) IS A
!	MULTI-WORD (>2) CELL WHICH CONTAINS INFORMATION NEEDED BY SEVERAL
!	OF THE CONTROL ROUTINES OF THE CLASS BUT LOCAL TO THIS PARTICULAR
!	INSTANCE OF THE CONTROL EXPRESSION.
!	
!	
!	GLOBALS USED BY THIS MODULE:
!	
!		CODEPTR		POINTS TO HEADER WHERE CODE IS BEING GENERATED
!		SFORLABEL	BOOLEAN SET WHEN SEARCH BACKWARDS FOR A LABELC
!				CELL TO INSURE THAT A LABELC CELL IS FOUND
!		NOSAVREG	# OF REGISTERS SAVED IN GPROLOG (USED BY GEPILOG)
!		PROGRAM		INDEX OF CELL WHICH HOLDS CODE OF OUTER BLOCK
FORWARD CONVEY,GCE0,GCE1,GCE2,GCOST0,GCOST1,GCOST2,GCOST3,GCOST4;
FORWARD GCUJUMP,GDWU0,GDWU1,GDWU2,GESCAPE,GEXIT,GID0,GID1,GID2,GID3;
FORWARD GITE0,GITE1,GITE2,GITE3,GRETURN,GUJUMP,GWUD0,GWUD1,GWUD2,LABLE;
FORWARD PUSHMSET,PUSHNSET,PUSHSET;
FORWARD SGC12,SGC34,SGSE12,SGSE3,SINGINSTP;



	%
PARENTHESES

                      ( E1 ; ... ; EN )
                       ^    ^     ^    ^
                       ^    ^     ^    ^
  GCE0(0)  ------------^    ^     ^    ^
                            ^     ^    ^
  GCE1(E1)  ----------------^-----^    ^
                                       ^
  GCE2(EN,0)  -------------------------^


                  BEGIN E1 ; ... ; EN END
                       ^    ^     ^    ^
                       ^    ^     ^    ^
  GCE0(1)  ------------^    ^     ^    ^
                            ^     ^    ^
  GCE1(E1)  ----------------^-----^    ^
                                       ^
  GCE2(EN,--) -------------------------^

  SKELETON
    0 BEC		0 CMPEXC
			    0.2 BOOLEAN: CMPEXC'S EXIT LABEL REF'D
      1 LOCAL ADD	  1 BODY
      2 BODY		  2 LABEL
      3 LABEL
      4 LOCAL SUB
%
GLOBAL ROUTINE GCE0(N)=
  %   LEFT PARENTHESIS/BEGIN MET.   %
  BEGIN
    IF .N THEN
      BEGIN LOCAL A;
        TEMPLATE(2,BEC,4);	! --> 0
        ACPDT();	! --> 1
	PUSHCODE();	! --> \1
	CODE(JUMP,0,0,0);
        ACPR2();	! --> 2
        PUSHCODE();	! --> \2
        INCR I FROM 16 TO 31 DO
          IF .RT[.I]<USEF> NEQ 0 AND NOT .RT[.I]<RSF> THEN
            BEGIN
              DUMPREG(A_.RT[.I]<ARTEF>);
              RELREG(.A,1)
            END;
      END
    ELSE
      BEGIN
	TEMPLATE(2,CMPEXC,2);	! --> 0
	ACPDT();	! --> 1
	PUSHCODE()	! --> \1
      END;
    FOLLCPH(0,CURRENTC,0);	! --> CTC
    CT[.CODEPTR,1]<HDRCLASSF>_#40;
    PUSHCODE()	! --> \CTC
  END;



GLOBAL ROUTINE GCE1(X)=
  %   SEMICOLON MET WITHIN PARENTHESES.   %
  BEGIN
    IF .RT[.X<RTEF>]<ARTEF> EQL .VREG THEN CLEARONE(RT[.X<RTEF>]);
    DULEX(.X);
    ACPR1();	! --> CTC
    LOSECONV();
    PROMOTE(1^RELC);
    SYPHON(.CODEPTR);
    PUSHCODE()	! --> \CTC
  END;
GLOBAL ROUTINE GCE2(X,N)=
  ! RIGHT PARENTHESIS OR END MET
  !	N=0	COMPOUND EXPRESSION
  !	N=-1	LOCAL-LESS BLOCK
  !	N<-1	BLOCK WITH -(N+1) LOCALS
  !
  BEGIN LOCAL B;	! BOOLEAN INDICATING THE LABEL (CMPEXC #2) HAS
			! BEEN REFERENCED.  IF THE LABEL HAS NOT BEEN
			! REF'D, WE DISCARD IT AT THE END OF GCE2 TO
			! FACILITATE OPTIMIZATIONS WHICH SEARCH BACKWARD
			! AND WOULD OTHERWISE STOP AT A LABEL.  ALSO
			! DETERMINES WHETHER THE VALUE OF CMPEXC MUST
			! BY CONVEYED IN VREG.

    IF .N LSS 0 OR (B_IF .N EQL 0 THEN .CT[LOCATE(CMPEXC,0),2]) THEN
      X_CONVEY(.X);
    IF .N LSS 0 THEN IF .CT[LOCATE(BEC,0),2] THEN SESTOG_.SESTOG OR 8;
    ACPR1();	! --> CTC
    PROMOTE(1^RELC);
    SYPHON(.CODEPTR);
    ACPR1();	! --> 2
    ERASEBOT(.CODEPTR);
    PROMOTE(IF .N EQL 0 THEN 1^XCMPEXC ELSE 1^XBLOCKC);
    IF .N LSS -1 THEN
      BEGIN LOCAL C,L;
        ACPR1();	! --> 3
        CLASSLAB();	! --> 4
        C_.CODEPTR;
        PUSHCODE();	! --> \4
        CODE(SUB,.SREG,L_LITA(LITLEXEME(((-.N)-1)*#1000001)),0);
        CODEPTR_.CT[LOCATE(BEC,1),1]<NEXTF>;	! --> \1
	EMPTY(.CODEPTR);
        CODE(ADD,.SREG,.L,0);
        CODEPTR_.C;	! --> 4
        ACPR1();	! --> 0
      END ELSE
    IF .N EQL -1 THEN
      BEGIN
	EMPTY(.CT[LOCATE(BEC,1),1]<NEXTF>);
        ACPR1();	! --> 3
        CLASSLAB();	! --> 4
        PUSHCODE();	! --> \4
        CODE(#320,0,0,0);
        ACPR2();	! --> 0
      END
    ELSE
      BEGIN
	ACPR1();	! --> 2
	IF .B THEN CLASSLAB() ELSE ACPR1();	! --> 0
	IF NOT .B THEN ERASEBOT(.CODEPTR) ELSE SESTOG_.SESTOG OR 8
      END;
    UNTEMPLATE();
    IF .CT[.CODEPTR,0]<CLASSF> NEQ CODEC THEN PUSHCODE();
    .X
  END;
%

	
                      DO E1 WHILE E2
                        ^  ^        ^
                        ^  ^        ^
  GDWU0()  -------------^  ^        ^
                           ^        ^
  GDWU1(E1)  --------------^        ^
                                    ^
  GDWU2(E2,1)  ---------------------^

                      DO E1 UNTIL E2
                        ^  ^        ^
                        ^  ^        ^
  GDWU0()  -------------^  ^        ^
                           ^        ^
  GDWU1(E1)  --------------^        ^
                                    ^
  GDWU2(E2,0)  ---------------------^

  SKELETON
    0 DWU
	0.3 INDEX AND SUBCLASS OF REAL LABEL
      1 LABEL
      2 DO
      3 WHILE/UNTIL
      4 LABEL
%



GLOBAL ROUTINE GDWU0=
  %   DO HAS BEEN MET COMMENCING A DO-WHILE/UNTIL.   %
  ! THE ROUTINE SWALABEL WHICH IS CALLED HERE AND IN GWUD0 SEARCHES
  ! BACK FROM THE DWU HEADER TO SEE IF THIS CELL IS PRECEDED BY A LABEL
  ! CELL WITH NO INTERVENING CODE.  IF SO, THE LABEL (DWUC #1) IS
  ! DISCARDED.  THE BACKWARD JUMP AT THE END OF DWUC #3 IS THEN BACK
  ! TO THIS LABEL.  THIS INSURES TO THE LATER OPTIMIZING PASS IN FLATFUNC
  ! THAT ALL BACKWARD REFERENCES TO A LIST OF CONTIGUOUS LABELS ARE
  ! ALWAYS TO THE LAST SUCH LABEL.  GWUD2 RESOTRES THE SUBCLASS NUMBER
  ! IF IT WAS CHANGED.

  BEGIN
    FREEVREG();
    TEMPLATE(2,DWUC,4);	! --> 0
    SWALABEL();	! --> 2
    PUSHCODE();	! --> \2
  END;



GLOBAL ROUTINE GDWU1(X)=
  %   DO CLAUSE COMPLETED WITHIN A DO-WHILE/UNTIL.   %
  BEGIN
    IF .RT[.X<RTEF>]<ARTEF> EQL .VREG THEN CLEARONE(RT[.X<RTEF>]);
    DULEX(.X);
    ACPR1();	! --> 2
    LOSECONV();
    PROMOTE(1^RELC OR 1^XLOOPC);
    ACPR1();	! --> 3
    PUSHCODE();	! --> \3
  END;



GLOBAL ROUTINE GDWU2(X,N)=
  %   WHILE(N=1)/UNTIL(N=0) CLAUSE OF DO-WHILE/UNTIL COMPLETED.   %
  BEGIN LOCAL C;
    SFORLABEL_1;
    GCUJUMP(.X,LOCATE(DWUC,1),.N,1);
    SFORLABEL_0;
    ACPR1();	! --> 3
    PROMOTE(1^CNVEYC OR 1^RELC);
    ACPDB();	! --> \3
    X_CONVEY(LITLEXEME(-1));
    ACPR2();	! --> 4
    CLASSLAB();	! --> 0
    IF (C_.CT[.CODEPTR,3]<LEFTF>) GTR 1 THEN
      (.CT[.CODEPTR,3]+1)<CLASSF>_.C;
    UNTEMPLATE();
    .X
  END;
%
WHILE/UNTIL-DO

                      WHILE E1 DO E2
                           ^  ^     ^
                           ^  ^     ^
  GWUD0()  ----------------^  ^     ^
                              ^     ^
  GWUD1(E1,0)  ---------------^     ^
                                    ^
  GWUD2(E2)  -----------------------^

                      UNTIL E1 DO E2
                           ^  ^     ^
                           ^  ^     ^
  GWUD0()  ----------------^  ^     ^
                              ^     ^
  GWUD1(E1,1)  ---------------^     ^
                                    ^
  GWUD2(E2)  -----------------------^

  SKELETON
    0 WUD
	0.2 VALUE RETURNED FROM GCUJUMP
      1 LABEL
      2 WHILE
      3 DO
      4 LABEL
      5 -1
      6 LABEL
%



GLOBAL ROUTINE GWUD0=
  %   WHILE/UNTIL HAS BEEN MET COMMENCING A WHILE/UNTIL-DO.   %
  BEGIN
    FREEVREG();
    TEMPLATE(2,WUDC,6);	! --> 0
    SWALABEL();	! --> 2
    PUSHCODE();	! --> \2
  END;



GLOBAL ROUTINE GWUD1(X,N)=
  %  WHILE(N=0)/UNTIL(N=1) CLAUSE COMPLETED WITHIN A WHILE/UNTIL-DO. %
  ! THE ROUTINE DROP (SEE LOLSTPKG) IS CALLED HERE TO DISCARD:
  !	(1) THE DO PORTION IF WE HAVE A WHILE 0 OR UNTIL 1
  !  OR
  !	(2) THE CONVEY OF -1 IN THE CASES WHILE 1 OR UNTIL 0.
  ! NOTE THAT THIS DECISION IS DETERMINED BY THE VALUE RETURNED FROM
  ! GCUJUMP (LATER IN THIS MODULE

  BEGIN
    CT[LOCATE(WUDC,0),2]_GCUJUMP(.X,LOCATE(WUDC,4),.N,0);
    ACPR1();	! --> 2
    PROMOTE(1^CNVEYC OR 1^RELC);
    ACPR1();	! --> 3
    PUSHCODE();	! --> \3
  END;



GLOBAL ROUTINE GWUD2(X)=
  %   DO CLAUSE COMPLETED WITHIN A WHILE/UNTIL-DO.   %
  BEGIN LOCAL C;
    SFORLABEL_1;
    GUJUMP(LOCATE(WUDC,1));
    SFORLABEL_0;
    IF .RT[.X<RTEF>]<ARTEF> EQL .VREG THEN CLEARONE(RT[.X<RTEF>]);
    DULEX(.X);
    ACPR1();	! --> 3
    LOSECONV();
    PROMOTE(1^RELC OR 1^XLOOPC);
    ACPR1();	! --> 4
    CLASSLAB();	! --> 5
    PUSHCODE();	! --> \5
    X_CONVEY(LITLEXEME(-1));
    ACPR2();	! --> 6
    CLASSLAB();	! --> 0
    DROP(CASE .CT[.CODEPTR,2] OF
          SET 1^4 OR 1^5;  1^3 OR 1^4 OR 1^6; 0 TES);
    IF (C_.CT[.CODEPTR,3]<LEFTF>) GTR 1 THEN
      (.CT[.CODEPTR,3]+1)<CLASSF>_.C;
    UNTEMPLATE();
    .X
  END;
%
INCR/DECR-FROM-TO-DO

                   INCR N FROM E1 TO E2 BY E3 DO E4
                         ^       ^     ^     ^     ^
                         ^       ^     ^     ^     ^
  GID0(N)  --------------^       ^     ^     ^     ^
                                 ^     ^     ^     ^
  GID1(E1)  ---------------------^     ^     ^     ^
                                       ^     ^     ^
  GID2(E2)  ---------------------------^     ^     ^
                                             ^     ^
  GID3(E3,0)  -------------------------------^     ^
						   ^
  GID4(E4,0)  -------------------------------------^

                   DECR N FROM E1 TO E2 BY E3 DO E4
                         ^       ^     ^     ^     ^
                         ^       ^     ^     ^     ^
  GID0(N)  --------------^       ^     ^     ^     ^
                                 ^     ^     ^     ^
  GID1(E1)  ---------------------^     ^     ^     ^
                                       ^     ^     ^
  GID2(E2)  ---------------------------^     ^     ^
                                             ^     ^
  GID3(E3,1)  -------------------------------^     ^
						   ^
  GID4(E4,1)  -------------------------------------^

  SKELETON
    0 IDFTD
	0.2 INCR/DECR REGISTER LEXEME
	0.3 TO-EXPRESSION LEXEME
	0.4 BY-EXPRESSION LEXEME
	0.5 BOOLEAN: LITERAL FROM-EXPRESSION
	0.6 BOOLEAN: VALUE OF LITERAL FROM-EXPRESSION
	0.7 BOOLEAN: BODY CAN BE DISCARDED
      1 INITIAL
      2 LABEL
      3 DO
      4 LABEL
      5 SETO
      6 LABEL
%



MACRO	IDREGLEXEME=CT[.H,2]$,
	LITERALFROM=CT[.H,5]$,
	FROMVALUE=CT[.H,6]$,
	TOLEXEME=CT[.H,3]$,
	BYLEXEME=CT[.H,4]$,
	DROPBODY=CT[.H,7]$;


GLOBAL ROUTINE GID0(X)=
  %   INDEX OF INCR/DECR-FROM-TO-DO MET.   %
  BEGIN
    FREEVREG();
    TEMPLATE(4,IDFTDC,6);	! --> 0
    CT[.CODEPTR,2]_.X;
    ACPDT();	! --> 1
    PUSHCODE();	! --> \1
  END;



GLOBAL ROUTINE GID1(X)=
  %   FROM CLAUSE OF INCR/DECR-FROM-TO-DO COMPLETED.   %
  BEGIN REGISTER H;
    H_LOCATE(IDFTDC,0);
    DULEX(GSTO(.IDREGLEXEME,.X));
    IF (LITERALFROM_LITP(.X)) THEN FROMVALUE_LITV(.X);
    ACPR1();	! --> 1
    PROMOTE(1^CNVEYC OR 1^RELC);
    ACPDB();	! --> \1
  END;


GLOBAL ROUTINE GID2(X)=
    !THE TO-CLAUSE HAS BEEN COMPLETED IN AN INCR-DECR LOOP
  BEGIN REGISTER H;
    H_LOCATE(IDFTDC,0);
    IF LITP(.X) THEN TOLEXEME_.X
    ELSE DULEX(GSTO(TOLEXEME_GENLOCAL(),.X));
    ACPR1();	! --> 1
    PROMOTE(1^CNVEYC OR 1^RELC);
    ACPDB()	! --> \1
  END;



GLOBAL ROUTINE GID3(X,N)=
    !BY CLAUSE IN AN INCR(N=0)/DECR(N=1) LOOP COMPLETED
  BEGIN REGISTER IDREG,TOVALUE,BYVALUE,H; LOCAL CPTRSAV,OPCODE;
    H_LOCATE(IDFTDC,0);
    IDREG_LITV(.IDREGLEXEME) AND #17;
    IF LITP(.X) THEN BYLEXEME_.X
    ELSE DULEX(GSTO(BYLEXEME_GENLOCAL(),.X));
    ACPR1();	! --> 1
    PROMOTE(1^CNVEYC OR 1^RELC);
    ACPR1();	! --> 2
    CLASSLAB();	! --> 3
    PUSHCODE();	! --> \3
    IF LITP(.TOLEXEME) THEN
      BEGIN
      TOVALUE_LITV(.TOLEXEME);
      IF .LITERALFROM THEN 
	DROPBODY_
	  CASE .N OF SET .FROMVALUE GTR .TOVALUE; .FROMVALUE LSS .TOVALUE TES;
      OPCODE_
	IF LITP(.X) THEN
	  BEGIN
	    BYVALUE_LITV(.X);
	    IF ABS(.BYVALUE) NEQ 1 THEN EXITCOMPOUND;
	    IF ABS(.TOVALUE) GTR 1 THEN EXITCOMPOUND;
	    IF .TOVALUE EQL 0 THEN IF ABS(.BYVALUE) EQL 1 THEN
	      EXITCOMPOUND
		CASE .N OF SET JUMPG; JUMPL TES;
	    IF .TOVALUE EQL 1 THEN
	      EXITCOMPOUND
	        IF (.BYVALUE EQL -1) EQL (.N EQL 0) THEN JUMPLE ELSE 0;
	    IF (.BYVALUE EQL 1) EQL (.N EQL 0) THEN JUMPGE
	  END
	ELSE 0;
      IF .OPCODE NEQ 0 THEN
	BEGIN
	IF NOT .LITERALFROM THEN
	  BEGIN
	    CPTRSAV_.CODEPTR;
	    CODEPTR_.CT[.H,1]<NEXTF>;
	    PUSHCODE();
            CODE(.OPCODE,.IDREG,LABLE(LOCATE(IDFTDC,4)),0);
	    CODEPTR_.CPTRSAV
	  END
	END ELSE
      IF SMPOSLITVP(.TOVALUE) THEN
        BEGIN
          CODE(CAILE+2*.N,.IDREG,.TOVALUE,0);
          GUJUMP(LOCATE(IDFTDC,4))
        END
      ELSE
	BEGIN
	  CODE(CAMLE+2*.N,.IDREG,LITA(.TOLEXEME),0);
	  GUJUMP(LOCATE(IDFTDC,4))
	END
      END
    ELSE
      BEGIN
        CODE(CAMLE+2*.N,.IDREG,GMA(GAT(.TOLEXEME)),0);
        GUJUMP(LOCATE(IDFTDC,4))
      END
  END;


GLOBAL ROUTINE GID4(X,N)=
    !DO CLAUSE COMPLETED IN AN INCR(N=0)/DECR(N=1) LOOP
  BEGIN
    LOCAL IDREG,	!ADDRESS OF INCR REGISTER
	  BYVALUE,	!VALUE OF LITERAL BY-EXPRESSION
	  OPCODE;	!FUNCTION FOR BACKWARD JUMP AND INCR-DECR

    REGISTER R,H;

    MACRO ADDONECASE=R<0,1>$,	!BY-EXPRESSION HAS LITERAL VALUE OF 1
	  LITERALBY=R<1,1>$,	!LITERAL BY-EXPRESSION
	  AOJSOJCASE=R<2,1>$;	!CAN GENERATE AOJ-SOJ TYPE JUMP

    IF .RT[.X<RTEF>]<ARTEF> EQL .VREG THEN CLEARONE(RT[.X<RTEF>]);
    DULEX(.X);
    H_LOCATE(IDFTDC,0);
    IDREG_LITV(.IDREGLEXEME) AND #17;
    AOJSOJCASE_
      IF (LITERALBY_LITP(.BYLEXEME)) THEN
	BEGIN
	  BYVALUE_LITV(.BYLEXEME);
	  (ADDONECASE_.BYVALUE EQL 1) OR (.BYVALUE EQL -1)
	END;
    SFORLABEL_1;
    IF .LITERALBY THEN
      IF .AOJSOJCASE THEN
	(OPCODE_
	  BEGIN REGISTER TOVALUE;
	    IF LITP(.TOLEXEME) THEN
	      BEGIN
		TOVALUE_LITV(.TOLEXEME);
		IF .TOVALUE EQL 0 THEN
		  EXITBLOCK
		    IF .N EQL .ADDONECASE THEN SOJGE ELSE AOJLE;
		IF .TOVALUE EQL 1 THEN
		  IF .N EQL .ADDONECASE THEN EXITBLOCK SOJG;
		IF .TOVALUE EQL -1 THEN
		  IF .N NEQ .ADDONECASE THEN EXITBLOCK AOJL;
	      END;
	    IF .N EQL .ADDONECASE THEN SOJA ELSE AOJA
	  END;
        CODE(.OPCODE,.IDREG,LABLE(LOCATE(IDFTDC,2)),0))
      ELSE
        BEGIN
          IF SMPOSLITVP(.BYVALUE) THEN
            CODE(IF .N THEN SUBI ELSE ADDI,.IDREG,.BYVALUE,0) ELSE
          IF SMNEGLITVP(.BYVALUE) THEN
            CODE(IF .N THEN ADDI ELSE SUBI,.IDREG,-.BYVALUE,0)
          ELSE
            CODE(IF .N THEN SUB ELSE ADD,.IDREG,LITA(.BYLEXEME),0);
          GUJUMP(LOCATE(IDFTDC,2))
        END
    ELSE
      BEGIN
        CODE(IF .N THEN SUB ELSE ADD,.IDREG,GMA(GAT(.BYLEXEME)),0);
        GUJUMP(LOCATE(IDFTDC,2))
      END;
    SFORLABEL_0;
    ACPR1();	! --> 3
    LOSECONV();
    PROMOTE(1^RELC OR 1^XLOOPC);
    ACPR1();	! --> 4
    CLASSLAB();	! --> 5
    PUSHCODE();	! --> \5
    X_CONVEY(LITLEXEME(-1));
    ACPR2();	! --> 6
    CLASSLAB();	! --> 0
    IF .DROPBODY THEN DROP(1^2 OR 1^3 OR 1^4 OR 1^6);
    UNTEMPLATE();
    .X
  END;

%
IF-THEN-ELSE

                      IF E1 THEN E2 ELSE E3
                        ^  ^       ^       ^
                        ^  ^       ^       ^
  GITE0()  -------------^  ^       ^       ^
                           ^       ^       ^
  GITE1(E1)  --------------^       ^       ^
                                   ^       ^
  GITE2(E2)  ----------------------^       ^
                                           ^
  GITE3(E3)  ------------------------------^

  SKELETON
    0 ITE
      1 IF
      2 THEN
      3 LABEL
      4 ELSE
      5 LABEL
%



GLOBAL ROUTINE GITE0=
  %   IF HAS BEEN MET COMMENCING AN IF-THEN-ELSE.   %
  BEGIN
    TEMPLATE(1,ITEC,5);	! --> 0
    ACPDT();	! --> 1
    PUSHCODE();	! --> \1
  END;

MACRO GCASEJMP(DEST)=
   CODE(JRST,0,(DEST) OR CASEJMPRELOC^30,0)$;

ROUTINE GSUJUMP(X,J)=
  % THIS ROUTINE GENERATES A JRST INSTRUCTION FOLLOWING
    THE 'BOOLEAN' PART OF AN IFSKIP.  CALL DULEX(.X)
    SINCE WE REALLY DON'T NEED THE VALUE OF THE EXPRESSION.
    THE JRST IS FLAGGED AS A CASE JUMP TO PREVENT
    FLATFUNC FROM OPTIMIZING IT AWAY. %

    BEGIN
	IF .FREEVHEADER LSS 0 THEN
	    BEGIN
	    FREEVHEADER_FOLLCPH(0,CODEC,0);
	    FOLLCPH(0,CODEC,0)
	    END;
	DULEX(.X);
	GCASEJMP(.J)
    END;


GLOBAL ROUTINE GITE1(X,TOG)=
  %   IF CLAUSE COMPLETED WITHIN IF-THEN-ELSE.   %
  !TOG=0 --> IF,    TOG=1 --> IFSKIP
  !THE MANIPULATION HERE FOR POSTPONING THE CALL ON FREEVREG IS
  !TO INSURE OPTIMAL CODE GENERATION FOR THE CASES "IF 0" AND "IF 1"

  BEGIN
    FREEVHEADER_-1;

    IF .TOG
      THEN  GSUJUMP (.X,LOCATE(ITEC,3))
      ELSE  GCUJUMP (.X,LOCATE(ITEC,3),0,1);

    ACPR1();	! --> 1
    PROMOTE(1^CNVEYC OR 1^RELC);
    CODEPTR_.FREEVHEADER;
    FREEVREG();
    CODEPTR_LOCATE(ITEC,2);	! --> 2
    FREEVHEADER_0;
    PUSHCODE();	! --> \2
  END;




GLOBAL ROUTINE GITE2(X)=
  %   THEN CLAUSE COMPLETED WITHIN AN IF-THEN-ELSE.   %
  BEGIN REGISTER CNVYIND,MUSTPROMOTE,I;
    CONVEY(.X);
    ACPR1();	! --> 2
    PROMOTE(1^RELC OR 1^XCONDC);
    !!!THE FOLLOWING 9 LINES OF CODE ARE NECESSARY TO INSURE THAT WE
    !!!DO NOT BUILD A EMPTY THEN CLAUSE.

    I_.CT[.CODEPTR,1]<NEXTF>; MUSTPROMOTE_0;
    UNTIL .I EQL .CODEPTR DO
      BEGIN
      IF NOT (NULL(.I) OR ALLNOS(.I)) THEN
	IF .CT[.I,0]<CLASSF> EQL CODEC THEN EXITLOOP(MUSTPROMOTE_0)
	ELSE IF .CT[.I,0]<CLASSF> EQL CNVEYC THEN (CNVYIND_.I; MUSTPROMOTE_1);
      I_.CT[.I,0]<NEXTF>
      END;
    IF .MUSTPROMOTE THEN CT[.CNVYIND,0]<CLASSF>_CODEC;
    ACPDB();	! --> \2
    GUJUMP(LOCATE(ITEC,5));
    ACPR2();	! --> 3
    CLASSLAB();	! --> 4
    PUSHCODE();	! --> \4
  END;



GLOBAL ROUTINE GITE3(X)=
  %   ELSE CLAUSE COMPLETED WITHIN AN IF-THEN-ELSE.   %
  BEGIN
    X_CONVEY(.X);
    ACPR1();	! --> 4
    PROMOTE(1^RELC OR 1^XCONDC);
    ACPR1();	! --> 5
    CLASSLAB();	! --> 0
    UNTEMPLATE();
    .X
  END;
%
CASE-OF-SET-TES

               CASE E1, ... ,EN OF SET S1; ... ;SM TES
                 ^    ^         ^        ^          ^
  GCOST0()-------^    ^         ^        ^          ^
                      ^         ^        ^          ^
  GCOST1(E1)----------^         ^        ^          ^
                                ^        ^          ^
  GCOST2(EN,N)------------------^        ^          ^
                                         ^          ^
  GCOST3(S1)-----------------------------^          ^
                                                    ^
  GCOST4(SM)----------------------------------------^

  SKELETONS:
    SINGLE-SELECTOR:          MULTI-SELECTOR:
      0 COST                  0 COST
	  0.2 NOT USED		  0.2 COUNTREG INFO.
	  0.3 BOOLEAN:MULTI-SEL   0.3 BOOLEAN:MULTI-SEL
	1 SELECTOR		1 SELECTOR SET
	2 NOT-USED		2 REGS OF SELECTORS/LABEL
	3 INDIRECT JUMP		3 INDIRECT JUMP
	4 LABEL			4 LABEL
	5 JUMP TABLE		5 JUMPTABLE
	6 SET-TES		6 SET-TES
	7 LABEL			7 LABEL
    SET ELEMENT:              SET ELEMENT:
     0 SET		       0 SET
       1 LABEL			 1 LABEL
       2 SET CODE		 2 SET CODE
				 3 LABEL
				 4 AOJA


%



MACRO	MULTISELECTOR=CT[.H,3]$,
	COUNTREGADDR=CT[.H,2]<RIGHTF>$,
	COUNTREGNAME=CT[.H,2]<LEFTF>$;
!	TO HELP IN FOLLOWING THESE ROUTINES FOR THE CASE STATEMENT, WE
!	INCLUDE SAMPLE CODE FOR THE TWO TYPES:
!
!	  A_CASE .B OF SET .B+.C; F(); 3; G(.E) TES
!
!
!		MOVE	04,B
!		XCT	$S,L1426(04)
!		JRST	$S,L1230
!	L1426:	JRST	$S,L1414
!		PUSHJ	$S,F
!		MOVEI	$V,3
!		JRST	$S,L1446
!	L1414:	ADD	04,C
!		MOVE	$V,4
!		JRST	$S,L1230
!	L1446:	PUSH	$S,E
!		PUSHJ	$S,G
!		SUB	$S,[000001,,000001]
!	L1230:	MOVEM	$V,A
!
!
!	  A_CASE .B,.C+.D,F() OF SET G(); .A*.B; .D*F(.A) TES
!
!
!		MOVE	04,B
!		MOVEM	04,1($F)
!		MOVE	05,D
!		ADD	05,C
!		MOVEM	05,2($F)
!		PUSHJ	$S,F
!		MOVEM	$V,3($F)
!		SETOM	$S,4($F)
!		MOVEI	06,1($F)
!	L1260:	MOVE	07,0(06)
!		JRST	$S,@L1322(07)
!		JRST	$S,L1420
!	L1322:	JRST	$S,L1306
!		JRST	$S,L1356
!		JRST	$S,L1360
!	L1306:	MOVEM	06,5($F)
!		PUSHJ	$S,G
!		MOVE	06,5($F)
!		AOJA	06,L1260  ^^^
!	L1356:	MOVE	$V,B
!		IMUL	$V,A
!		AOJA	06,L1260  ^^^
!	L1360:	PUSH	$S,A
!		MOVEM	06,6($F)
!		PUSHJ	$S,F
!		SUB	$S,[000001,,000001]
!		IMUL	$V,D
!		MOVE	06,6($F)
!		AOJA	06,L1260  ^^^
!	L1420:	MOVEM	$V,A
GLOBAL ROUTINE GCOST0=

  ! CASE HAS BEEN MET COMMENCING CASE-OF-SET-TES
  BEGIN
    TEMPLATE(2,COSTC,7);	! --> C0
    ACPDT();	! --> C1
    PUSHCPH(SELELC);	! --> SLC
    CT[.CODEPTR,1]<HDRCLASSF>_#40;
    PUSHCODE()	! --> \SLC
  END;



ROUTINE SINGINSTP(H)=
    !USED TO TEST IF CODE HANGING FROM CT[.H,0] CONTAINS ONLY ONE
    !INSTRUCTION.  PREDICATE IS TRUE IFF RIGHT HALF OF RETURNED VALUE IS A 1.
    !IF TRUE, THE LEFT HALF CONTAINS INDEX OF THE INSTRUCTION.
  BEGIN REGISTER C,I;
    C_0;
    I_.CT[.H,1]<NEXTF>;
    UNTIL .I EQL .H DO
      BEGIN
	IF .CT[.I,0]<HDRF> THEN C_.C+SINGINSTP(.I)
	ELSE IF .CT[.I,1]<FUNCF> NEQ 0 THEN C_.C+(.I^18 OR 1);
	IF .C<RIGHTF> GTR 1 THEN BREAK ELSE I_.CT[.I,0]<NEXTF>
      END;
    .C
  END;


GLOBAL ROUTINE GCOST1(E)=
  ! COMMA ENCOUNTERED IN THE SELECTOR LIST OF A MULTI-SEL CASE STATEMENT

  BEGIN
    SGC12(.E);
    PUSHCPH(SELELC);	! --> SLC
    CT[.CODEPTR,1]<HDRCLASSF>_#40;
    PUSHCODE()	! --> \SLC
  END;


ROUTINE SGC12(E)=
  !SUBROUTINE CALLED FROM GCOST1 AND GCOST2 TO PUT REGISTER ADDRESS
  !FOR EACH ELEMENT OF SELECTOR LIST ON COSTC #2.  CALLED ONLY WHEN
  !COMPILING A MULTISELECTOR CASE STATEMENT.

  BEGIN
    E_GLAR(.E);
    ACPR1();	! --> SLC
    PROMOTE(1^CNVEYC OR 1^RELC);
    ACPR1();	! --> C1
    CT[NEWBOT(LOCATE(COSTC,2),1),1]_.RT[.E<RTEF>]<ARTEF>;
    DULEX(.E)
  END;
GLOBAL ROUTINE GCOST2(E,N)=
  ! OF ENCOUNTERED IN SINGLE (N=1) OR MULTI (N>1) SELECTOR CASE STATEMENT

  BEGIN
    REGISTER	H,	! INDEX OF COSTC HEADER
		I,	! TEMP FOR INDEXING THRU LIST
		J,	!  "    "      "     "    "
		R;	! MULTI-NAMED REGISTER

    LOCAL	P,	! TEMP INDEX HOLDER
		LOCBASE;! FIRST ALLOCATED LOCAL OF CONTIGUOUS CHUNK

    MACRO	L=R$,	! TEMP FOR LOCAL LEXEMES
		COUNTINGREG=R$,	! ADDRESS OF COUNTING REG(MULTISELECTOR)
		INDEXREG=R$;	! ADDRESS OF INDEX REGISTER FOR JUMPS


    H_LOCATE(COSTC,0);
    IF .N EQL 1 THEN
      BEGIN
	E_GLAR(.E);
	ACPR1();	! --> SLC
	PROMOTE(1^CNVEYC OR 1^RELC);
	SYPHON(I_.CODEPTR);
	ACPR3();	! --> C3
	RELEASESPACE(TAKE(.I),1);
	PUSHCODE();

%4.11%	IF NOT (.NPTFLG) THEN
%4.01%			CODE(PEEPHOLE,0,PEEPOFF,0);

	CODE(XCT,0,LABLE(MADRIR(.E,LOCATE(COSTC,4))),0);
	GCASEJMP(LOCATE(COSTC,7));
      END
    ELSE
      BEGIN
	MULTISELECTOR_1;
	SGC12(.E);
	I_.CT[.CODEPTR,1]<NEXTF>;
	J_.CT[LOCATE(COSTC,2),1]<NEXTF>;
	!! THIS LOOP GENERATES CODE TO STORE EACH SELECTOR RESULT INTO A
	!! LOCAL.  THIS WILL RESULT IN A CHUNK (N+1) OF LOCALS WITH
	!! THE N SELECTOR VALUES AND THE LAST CONTAINING A -1 SO THAT
	!! WHEN THE LIST IS EXHAUSTED CONTROL PASSES TO THE END OF THE
	!! CASE STATEMENT

	INCR K FROM 1 TO .N DO
	  BEGIN
	    CODEPTR_.CT[.I,1]<PREVF>;	! --> SLC
	    L_GENLOCAL();
	    IF .K EQL 1 THEN LOCBASE_.L;
	    CODE(MOVEM,.CT[.J,1],GMA(GAT(.L)),0);
	    SYPHON(P_.I);
	    I_.CT[.I,0]<NEXTF>;
	    J_.CT[.J,0]<NEXTF>;
	    RELEASESPACE(TAKE(.P),1)
	  END;
	CODEPTR_.CT[.CT[.H,1]<NEXTF>,1]<PREVF>;	! --> \C1
	CODE(SETOM,0,GMA(GAT(GENLOCAL())),0);
	CODE(MOVEI,COUNTINGREG_ACQUIRE(-1,1),GMA(GAT(.LOCBASE)),0);
	COUNTREGADDR_.COUNTINGREG;
	COUNTREGNAME_.ART[.COUNTINGREG]<RTEF>;
	ACPR2();	! --> C2
	EMPTY(.CODEPTR);
	CLASSLAB();	! --> C3
	PUSHCODE();	! --> \C3

%4.11%	IF NOT (.NPTFLG) THEN
%4.01%			CODE(PEEPHOLE,0,PEEPOFF,0);

	CODE(MOVE,INDEXREG_ACQUIRE(-1,1),.COUNTREGADDR^18,0);
	GUJUMP(MADRIR(LEXRA(.INDEXREG),LOCATE(COSTC,4)));
	CT[.CT[.CODEPTR,1]<PREVF>,1]<INDRF>_1;
	GCASEJMP(LOCATE(COSTC,7));
      END;
    CODEPTR_LOCATE(COSTC,1);	! --> C1
    PUSHCODE();	! --> \C1
    RT[.COUNTREGNAME]<RSF>_1;
    FREEVREG();
    RT[.COUNTREGNAME]<RSF>_0;
    CODEPTR_LOCATE(COSTC,4);	! --> C4
    CLASSLAB();	! --> C5
    PUSHCODE();	! --> \C5
    ACPR2();	! --> C6
    PUSHCPH(CURRENTC);	! --> CTC
    CT[.CODEPTR,1]<HDRCLASSF>_#40;
    IF .N EQL 1 THEN PUSHSET() ELSE PUSHMSET()
  END;



ROUTINE PUSHMSET=
  ! CREATES A SETC ELEMENT IN A MULTI-SEL CASE STATEMENT

  BEGIN
    CODEPTR_PUSHBOT(.CODEPTR,SKELETON(1,SETC,4));	! --> MS0
    ACPDT();	! --> MS1
    CLASSLAB();	! --> MS2
    PUSHCODE()	! --> \MS2
  END;




ROUTINE PUSHSET=
  ! CREATS A SETC ELEMENT IN A SINGLE-SEL CASE STATEMENT

  BEGIN
    CODEPTR_PUSHBOT(.CODEPTR,SKELETON(1,SETC,2));	! --> S0
    ACPDT();	! --> S1
    CLASSLAB();	! --> S2
    PUSHCODE();	! --> \S2
  END;



GLOBAL ROUTINE GCOST3(S)=
  %   A SET ELEMENT HAS BEEN COMPLETED IN A CASE STATEMENT.   %
  BEGIN
    SGC34(.S,0)
  END;



ROUTINE SGC34(S,LAST)=
  ! SUBROUTINE CALLED BY GCOST3 (LAST=0) AND GCOST4 (LAST=1). IN THE
  ! SINGLE SELECTOR CASE IT ATTEMPTS TO PUT SINGLE INSTRUCTION SET ELEMENTS
  ! DIRECTLY INTO THE JUMP TABLE

  BEGIN
    REGISTER 	H,	! INDEX OF COSTC HEADER
		ONEIND, ! INDEX OF INST. WHERE SET ELEMENT COMPILES TO ONE INSTRUCTION
		ONERELOC; ! RELOCATION TYPE FOR ONE-INSTRUCTION CASE


    LOCAL	SETLABEL,	! INDEX OF MOST RECENT SET-ELEMENT'S LABEL
		ONECODE,	! ONE-INSTRUCTION ITSELF
		ONEINST,	! BOOLEAN INDICATING ONE-INSTRUCTION
		H1;		! TEMP FOR INDEX

    H_LOCATE(COSTC,0);
    SETLABEL_.CT[.CT[.CODEPTR,0]<NEXTF>,0]<PREVF>;
    S_CONVEY(.S);
    IF NOT .MULTISELECTOR THEN
      BEGIN
	ONEIND_SINGINSTP(.CT[.CODEPTR,0]<NEXTF>);
	IF .ONEIND<RIGHTF> EQL 1 THEN
          BEGIN ONEIND_.ONEIND<LEFTF>; ONEINST_1 END ELSE
	IF .ONEIND EQL 0 THEN
	  BEGIN
	    GUJUMP(LOCATE(COSTC,7));
	    ONEIND_.CT[.CODEPTR,1]<PREVF>;
            CT[.ONEIND]<RELOCF>=CASEJMPRELOC;		! DON'T ERASE THE CODE THAT FOLLOWS THE
							! JUMP  **U1**
	    ONEINST_1
	  END
	ELSE ONEINST_0;
	IF NOT .LAST AND NOT .ONEINST THEN GUJUMP(LOCATE(COSTC,7));
	ACPR1();	! --> S2
	PROMOTE(1^RELC OR 1^XCOSTC);
	IF .ONEINST THEN
	  BEGIN
	    ONERELOC_.CT[.ONEIND,0]<RELOCF>;
	    ONECODE_.CT[.ONEIND,1];
	    EMPTY(.CODEPTR)
	  END
      END
    ELSE
      BEGIN
	ONEINST_0;
	ACPR1();	! --> MS2
	PROMOTE(1^RELC OR 1^XCOSTC);
	ACPR1();	! --> MS3
	CLASSLAB();	! --> MS4
	PUSHCODE();	! --> \MS4
	SFORLABEL_1;
	IF .RT[.COUNTREGNAME]<RSF> THEN
	  RELOADTEMP(.COUNTREGADDR,.COUNTREGNAME);
	CODE(AOJA,.COUNTREGADDR,LABLE(LOCATE(COSTC,2)),0);
	SFORLABEL_0;
      END;
    IF NOT .LAST THEN DULEX(.S);
    CODEPTR_LOCATE(COSTC,5);	! --> C5
    ACPDT();	! --> \C5
    IF .ONEINST THEN
      BEGIN
	CT[H1_NEWBOT(.CODEPTR,1),0]<RELOCF>_.ONERELOC;
	CT[.H1,1]_.ONECODE
      END
    ELSE GCASEJMP(.SETLABEL);
    !! THIS INSTRUCTION IS PUT OUT AS MARKER TO FLATFUNC SO IT WILL NOT
    !! ATTEMPT TO BACKOVER THE JUMP-TABLE

%4.01%	    IF .LAST THEN BEGIN
%4.01%				CODE(#257,0,NOBORELOC^30,0);

%4.11%				IF NOT (.NPTFLG) THEN
%4.01%						CODE(PEEPHOLE,0,PEEPREV,0);
%4.01%			  END;

    ACPR2();	! --> C6
    ACPDT();	! --> \C6==CTC
    IF NOT .LAST THEN IF .MULTISELECTOR THEN PUSHMSET() ELSE PUSHSET();
    .S
  END;


GLOBAL ROUTINE GCOST4(S)=
  ! THE FINAL SET ELEMENT HAS BEEN MET IN A CASE STATEMENT

  BEGIN REGISTER H;
    S_SGC34(.S,1);
    H_LOCATE(COSTC,0);
    SCAN(.CODEPTR,SETC,CLASSP,UNSKELETON);
    SYPHON(.CODEPTR);
    ERASE(.CODEPTR);
    IF .COUNTREGADDR NEQ 0 THEN DUA(.COUNTREGADDR);
    CODEPTR_.CT[.H,1]<PREVF>;	! --> C7
    CLASSLAB();	! --> C0
    UNTEMPLATE();
    .S
  END;
%
SELECT-OF-NSET-TESN

		SELECT E1, ... ,EN OF NSET L1:S1; ... :SM TESN
		    ^    ^	    ^	     ^  ^	   ^
  GSE0 -------------^    ^	    ^	     ^  ^	   ^
			 ^	    ^	     ^  ^	   ^
  GSE1(E1) --------------^	    ^	     ^  ^	   ^
			  	    ^	     ^  ^	   ^
  GSE2(EN) -------------------------^	     ^  ^  	   ^
					     ^  ^	   ^
  GSE3(L1) ----------------------------------^  ^	   ^
						^	   ^
  GSE4(S1) -------------------------------------^	   ^
							   ^
  GSE5(SM) ------------------------------------------------^

  SKELETONS:

  0 SELECT
      0.2 LEXEME OF LOCAL FOR RESULT
      0.3 BOOLEAN: ALWAYS OR OTHERWISE GENERATED
    1 SELECTOR CODE
    2 SELECTOR LEXEME(S)
    3 NSET-TESN
    4 SETO CODE
    5 EXIT LABEL

  NSET ELEMENT:
    0 NSET
      1 LABEL CODE
      2 LABEL
      3 NSET CODE
      4 LABEL

%
!	AN EXAMPLE OF THE CODE FOR A SELECT STATEMENT FOLLOWS:
!
!
!	  A_SELECT .B,0,2 OF NSET .D:F(.E); .E:0 TESN
!
!
!		MOVE	04,B
!		MOVEM	04,1($F)
!		SETOM	$S,2($F)
!		MOVE	05,D
!		CAMN	05,1($F)
!		JRST	$S,L1276
!		JUMPE	05,L1276
!		CAIE	05,2
!		JRST	$S,L1316
!	L1276:	AOS	$S,2($F)
!		PUSH	$S,E
!		PUSHJ	$S,F
!		SUB	$S,[000001,,000001]
!	L1316:	MOVE	06,E
!		CAMN	06,1($F)
!		JRST	$S,L1334
!		JUMPE	06,L1334
!		CAIE	06,2
!		JRST	$S,L1256
!	L1334:	AOS	$S,2($F)
!		SETZ	$V,0
!	L1256:	SKIPGE	$S,2($F)
!		SETO	$V,0
!		MOVEM	$V,A
MACRO MINUSONELOCAL=CT[LOCATE(SELECTC,0),2]$;
    !LEXEME OF LOCAL USED TO DETERMINE IF A NSET ELEMENT HAS BEEN EXECUTED

GLOBAL ROUTINE GSE0=
  ! SELECT MET COMMENCING A SELECT-OF-NSET-TESN

%4.01%  BEGIN  LOCAL TEMP;
    FREEVREG();
    TEMPLATE(2,SELECTC,5);	! --> S0
    ACPDT();	! --> S1
    PUSHCPH(CURRENTC);	! --> CTC
    CT[.CODEPTR,1]<HDRCLASSF>_#40;

%     9-21-77
4.11	IF NOT (.NPTFLG) THEN
4.11	BEGIN
4.01		TEMP_.CODEPTR;
4.01		PUSHCODE();
4.01		CODE(PEEPHOLE,0,PEEPOFF,0);
4.01		CODEPTR_.TEMP;
4.11	END;
%

    PUSHCODE()	! --> \CTC
  END;


ROUTINE SGSE12(E)=
  ! SUBROUTINE CALLED FROM GSE1 AND GSE2 TO HANG LEXEME OF SELECTOR
  !ELEMENT FROM SELECTC #2

  BEGIN LOCAL H,LEX,V;
    H_LOCATE(SELECTC,2);
    IF NOT (IF LITP(.E) THEN (V_LITV(.E);SMPOSLITVP(.V))) THEN
      (LEX_GENLOCAL();DULEX(GSTO(.LEX,.E)))
    ELSE LEX_.E;
    CT[NEWBOT(.H,1),1]_.LEX
  END;


GLOBAL ROUTINE GSE1(E)=
  ! COMMA MET IN SELECTOR LIST OF SELECT-OF-NSET-TESN

  BEGIN
    SGSE12(.E);
    ACPR1();	! --> CTC
    PROMOTE(1^CNVEYC OR 1^RELC);
    SYPHON(.CODEPTR);
    PUSHCODE()	! --> \CTC
  END;



GLOBAL ROUTINE GSE2(E)=
  ! OF MET IN SELECT EXPRESSION.  GENERATES LOCAL LEXEME TO BE USED
  ! TO CHECK IF ANY NSET-TESN ELEMENT IS EXECUTED

  BEGIN LOCAL H,LEX;
    SGSE12(.E);
    LEX_GAT(GENLOCAL());
    MINUSONELOCAL_.LEX;
    CODE(SETOM,0,GMA(.LEX),0);
    ACPR1();	! --> CTC
    PROMOTE(1^CNVEYC OR 1^RELC);
    SYPHON(H_.CODEPTR);
    ACPR3();	! --> C3
    ERASE(.H);
    PUSHCPH(CURRENTC);	! --> CTC
    CT[.CODEPTR,1]<HDRCLASSF>_#40;
    PUSHNSET()
  END;


ROUTINE PUSHNSET=
  ! CREATE A NSET ELEMENT

  BEGIN
    CODEPTR_PUSHBOT(.CODEPTR,SKELETON(1,NSETC,4));	! --> NS0
    ACPDT();	! --> NS1
    PUSHCODE()	! --> \NS1
  END;


GLOBAL ROUTINE GSE3(E)=
  ! A COLON ENCOUNTERED IN A SELECT EXPRESSION. CODE IS GENERATE TO
  ! CHECK SELECTOR LIST AGAINST VALUE OF LABEL.

  BEGIN LOCAL LAB1,LAB2,RLEX; REGISTER I;
    LAB1_LABLE(LOCATE(NSETC,2));
    LAB2_LABLE(LOCATE(NSETC,4));
    E_REGAK(RLEX_GLAR(.E));
    I_.CT[LOCATE(SELECTC,2),1]<NEXTF>;
    UNTIL LAST(.I) DO
      BEGIN
	SGSE3(.CT[.I,1],.LAB1,.E,0);
	I_.CT[.I,0]<NEXTF>
      END;
    SGSE3(.CT[.I,1],.LAB2,REGAR(.RLEX),1);
    ACPR1();	! --> NS1
    PROMOTE(1^RELC OR 1^CNVEYC);
    ACPR1();	! --> NS2
    CLASSLAB();	! --> NS3
    PUSHCODE();	! --> \NS3
    CODE(AOS,0,GMA(.MINUSONELOCAL),0)
  END;


ROUTINE SGSE3(LEX,LAB,REG,LAST)=
  ! SUBROUTINE CALLED BY GSE3 TO GENERATE TEST (VS. LEX) AND
  ! JUMP TO LAB.  LAST INDICATES THAT LEX IS THE LAST
  ! SELECTOR ON THE LIST.

  BEGIN REGISTER V;
    IF(IF LITP(.LEX) THEN
         (V_LITV(.LEX);SMPOSLITVP(.V))) THEN
      IF .V EQL 0 THEN
	CODE(JUMPE+4*.LAST,.REG,.LAB,0)
      ELSE
	BEGIN
	  CODE(CAIN-4*.LAST,.REG,.V,0);
	  CODE(JRST,0,.LAB,0)
	END
    ELSE
      BEGIN
	CODE(CAMN-4*.LAST,.REG,GMA(GAT(.LEX)),0);
	CODE(JRST,0,.LAB,0)
      END
  END;



GLOBAL ROUTINE GSE3O=
  ! OTHERWISE ENCOUNTERED AS A LABEL

  BEGIN
    CT[LOCATE(SELECTC,0),3]_-1;
    CODE(AOSE,0,GMA(.MINUSONELOCAL),0);
    CODE(JRST,0,LABLE(LOCATE(NSETC,4)),0);
    ACPR3();	! --> NS3
    PUSHCODE()	! --> \NS3
  END;


GLOBAL ROUTINE GSE3A=
  ! ALWAYS ENCOUNTERED AS A LABEL

  BEGIN
    CT[LOCATE(SELECTC,0),3]_-1;
    ACPR3();	! --> NS3
    PUSHCODE();	! --> \NS3
    CODE(AOS,0,GMA(.MINUSONELOCAL),0)
  END;


GLOBAL ROUTINE GSE4(E)=
  ! NSET ELEMENT COMPLETED IN A SELECT EXPRESSION

  BEGIN
    DULEX(CONVEY(.E));
    ACPR1();	! --> NS3
    PROMOTE(1^RELC OR 1^XSELECTC);
    ACPR1();	! --> NS4
    CLASSLAB();	! --> NS0
    ACPR1();	! --> CTC
    PUSHNSET()
  END;




GLOBAL ROUTINE GSE5(E)=
  ! LAST NSET ELEMENT ENCOUNTERED IN SELECT EXPRESSION.  IF E=0, THEN
  ! WE HAVE THE CASE WHERE THE LAST ELEMENT IS MISSING. E.G.:
  !	SELECT .A OF NSET .B:.C; .D:.E; TESN
  ! IF NO ALWAYS OR OTHERWISE LABELS WERE GENERATED, THEN THE -1 VALUE
  ! IS CONVEYED

  BEGIN LOCAL I;
    EMPTY(LOCATE(SELECTC,2));
    IF .E EQL 0 THEN CODEPTR_LOCATE(NSETC,4)	! --> NS4
    ELSE
      BEGIN
	E_CONVEY(.E);
	ACPR1();	! --> NS3
	PROMOTE(1^RELC OR 1^XSELECTC);
	ACPR1()	! --> NS4
      END;
    CLASSLAB();	! --> NS0
    ACPR1();	! --> CTC
    SCAN(.CODEPTR,NSETC,CLASSP,UNSKELETON);
%4.01%	I_.CODEPTR;

%  6-24-77 DO NOT DELETE A CELL BECAUSE THE CODE IS
   BAD FOR SELECT . X OF NSET 1:RETURN 1; OTHERWISE: RETURN  0
   TESN;
4.11	IF NOT (.NPTFLG) THEN
4.11	BEGIN
4.01		PUSHCODE();
4.01		CODE(PEEPHOLE,0,PEEPREV,0);
4.01		CODEPTR_.I;
4.11	END;
%

%4.01%	SYPHON(.I);
    ACPR2();	! --> S4
    ERASE(.I);
    IF NOT .CT[LOCATE(SELECTC,0),3] THEN
      BEGIN
	PUSHCODE();	! --> \S4
	CODE(SKIPGE,0,GMA(.MINUSONELOCAL),0);
	CODE(SETO,.VREG,0,0);
	ACPR2();	! --> S5
      END
    ELSE ACPR1();	! --> S5
    CLASSLAB();	! --> S0
    UNTEMPLATE();
    IF .E EQL 0 THEN GETVREG() ELSE .E
  END;
%
FUNCTION-ROUTINE CALL

                E0(E1,EM)
                     ^  ^
GFRC1(E1)____________^  ^
                        ^
GFRC2(EM,E0,M)__________^
                          %



GLOBAL ROUTINE GFRC1(X)=
  ! A PARAMETER (NOT THE LAST) HAS BEEN COMPLETED

  BEGIN
    PCIVR(.X,0);
    REGSEARCH(X,0);
    CODE(PUSH,.SREG,MEMORYA(.X),0)
  END;
%    		COROUTINES.


			- - - - GENERAL FORMAT - - - -

THE STACK OF A COROUTINE INSTANCE CONSISTS OF A STATE AREA WITH A NORMAL  STACK  ON  TOP.
THE  STATE  AREA  AND  LOWER  PART OF STACK DESCRIBED BELOW. NOTE THAT THE LOWEST 'RETURN
ADDRESS' IS REPLACED BY THE ADDR. OF THE THEN-PART OF THE APPROPRIATE  CREATE-EXPR.,  AND
THE ORIGINAL CONTENTS OF THE F-REG IS THAT OF THE CREATOR.


STATE AREA:

THE LAYOUT OF THE STATE AREA IS:

   !            !
   !            !   ^ NORMAL STACK AS DESCRIBED IN MANUAL. ^
   !            !
   !------------!
   !THEN ADDRESS!   ADDR. OF THEN-PART OF CREATE (IN RETURN ADDR. POSITION).
   !------------!
   !LAST ACTUAL !
   !--        --!
   !            !   THIS AREA OMITTED IF NO ACTUALS.
   !--        --!
   !1'ST ACTUAL !
   !------------!
   ! SAVE AREA  !
   ! FOR ALL    !   THIS AREA OMITTED IF /R OPTION INVOKED.
   ! DECLARABLE !
   ! REGISTERS  !
   !------------!
 2 ! F REGISTER !
   !------------!   THESE TWO ALWAYS SAVED AND RESTORED.
 1 ! S REGISTER !
   !------------!
 0 ! REACTIVA-  !   ADDRESS WHERE EXECUTION SHOULD RESUME.
   ! TION POINT !__ BASE REGISTER POINTS HERE DURING EXECUTION.
    ------------


REGISTERS:

ALL DECLARABLE REGISTERS, WHETHER IN USE OR NOT, ARE NORMALLY SAVED IN THE STATE AREA  OF
THE  NEW  PROCESS DURING CREATE. THEY ARE RESTORED/SAVED WHEN THE PROCESS IS ENTERED/LEFT
BY AN EXCHJ. THE USER MAY OMIT THIS SAVING AND RESTORING BY USING  THE  /R  SWITCH.  THIS
WILL  CLEAR THE "SVERGFLG" IN THE COMPILER. NO SPACE FOR THE REGISTERS IS RESERVED IN THE
STATE AREA WHEN THIS OPTION IS USED.

TEMPORARY REGISTERS ARE SAVED ACROSS EXCHJ'S IN THE STACK, AS FOR FUNCTION/ROUTINE CALLS.
			- - - - CREATE: - - - -

THE SEQUENCE OF EVALUATIONS AND EVENTS DURING
	CREATE E1(ELIST) AT E2 LENGTH E3 THEN E4
WILL BE:
	E2, E3, ELIST IN SEQUENCE, E1, REGISTERS SAVED IN NEW STATE.
HOWEVER, IF E1 IS NOT A NAME IT WILL BE EVALUATED BEFORE E2.


THE THEN - PART:

DURING THE EVALUATION OF E4 THE VALUES OF THE RUN-TIME REGISTERS ARE AS FOR  THE  OUTMOST
LEVEL  OF THE PROCESS THAT RETURNED, EXEPT THAT THE F-REGISTER IS AS FOR THE PROCESS THAT
CREATED THE ONE WHICH IS NOW RETURNING.  HENCE USE OF LOCAL VARIABLES IN E4 WILL  USUALLY
BE  MEANINGFULL.   E4  IS  TERMINATED  BY A HALT INSTRUCTION, WITH THE VALUE OF E4 IN THE
VALUE-REGISTER.

VALUE OF CREATE:

IF THE INSPECT OPTION (/I) IS USED, THE VALUE OF A CREATE IS:
      --------- --------- ------------------
     ^ RAFL    ^ RALF    ^ BASE ADDRESS     ^
      --------- --------- ------------------
      0       8 9      17 18              35
WHERE:
    RAFL = RELATIVE ADDRESS OF FIRST LOCAL
    RALF = RELATIVE ADDRESS OF LAST FORMAL
BOTH RELATIVE TO THE BASE ADDRESS, AND TAKING INTO ACCOUNT THAT THE NO.  OF  ACTUALS  MAY
DIFFER  FROM  THE  NO.  OF  FORMALS. IF THE INSPECT OPTION IS NOT USED, RAFL AND RALF ARE
ZERO, THEY WILL ALSO BE ZERO IF THERE ARE NO LOCALS OR ACTUALS.

	
THE INSPECT WORD.

THE SPECIAL WORD MENTIONED IN THE DESCRIPTION OF THE INSPECT- SWITCH IN THE MANUAL IS:
      --------- --------- ------------------
     ! RAFL    ! NFORM   ! OBJECT SIZE      !
      --------- --------- ------------------
      0       8 9      17 18              35
WHERE
    RAFL = RELATIVE ADDRESS OF FIRST LOCAL
           (RELATIVE TO THE LOCATION BELOW THE RETURN ADDRESS),
    NFORM = # OF FORMALS,
    OBJECT SIZE = # OF FORMALS + # OF DISPLAYS + # OF SAVED
           REGISTERS + # OF LOCALS + 2.

USE OF THE /I SWITCH WILL SET THE "LUNDEFLG" IN THE COMPILER.
			- - - - EXCHJ: - - - -

DURING THE EVALUATION OF
	EXCHJ(<PROC>,<VAL>)
<PROC>  WILL  IN THE MOST GENERAL CASE BE EVALUATED BEFORE <VAL>, AND SAVED IN THE STACK.
HOWEVER, THE COMPILER TRIES TO RECOGNICE WHEN <PROC> CAN BE OBTAINED BY A  SINGLE  'MOVE'
AND IS NOT LIABLE TO SIDEEFFECTS FROM <VAL>.  IN SUCH CASES <VAL> WILL BE EVALUATED FIRST
AND <PROC> 'MOVE'D DIRECTLY INTO BREG WHEN NEEDED.  THE COMPILER WILL FIRST GENERATE CODE
MAKING NO ASSUMPTIONS, THEN REMOVE IT IF THE OPTIMIZABLE CASE IS RECOGNIZED.



                        CREATE F(P1,...,PN) AT E1 LENGTH E2 THEN E3
                                ^  ^      ^       ^         ^      ^
                                ^  ^      ^       ^         ^      ^
GCREA0() -----------------------^  ^      ^       ^         ^      ^
                                   ^      ^       ^         ^      ^
GCREA1(PJ) --- J < N --------------^      ^       ^         ^      ^
                                          ^       ^         ^      ^
GCREA2(PN,F,N) ---------------------------^       ^         ^      ^
                                                  ^         ^      ^
GCREA3(E1) ---------------------------------------^         ^      ^
                                                            ^      ^
GCREA4(E2) -------------------------------------------------^      ^
                                                                   ^
GCREA5(E3) --------------------------------------------------------^



                        CREATE F(P1,...,PN) AT E1 LENGTH E2 THEN E3
                                ^  ^      ^       ^         ^      ^
                                ^  ^      ^       ^         ^      ^
GCREA0() -----------------------^  ^      ^       ^         ^      ^
                                   ^      ^       ^         ^      ^
GCREA1(PJ) --- J < N --------------^      ^       ^         ^      ^
                                          ^       ^         ^      ^
GCREA2(PN,F,N) ---------------------------^       ^         ^      ^
                                                  ^         ^      ^
GCREA3(E1) ---------------------------------------^         ^      ^
                                                            ^      ^
GCREA4(E2) -------------------------------------------------^      ^
                                                                   ^
GCREA5(E3) --------------------------------------------------------^



  THE STACK- AND BASE REGISTERS OF CREATED PROCESS ARE SIMULATED IN
  REGISTERS SP AND BP.  THESE REGISTERS MAY BE SAVED BY THE PARAMETER
  CODE, IN WHICH CASE THEY ARE RELOADED BY THESE ROUTINES.



    SKELETON
    O CREATC
	0.2  REGISTER SIMULATING SREG, AS   XWD  NAME,ADDRESS.
	0.3  REGISTER SIMULATING BREG, AS   XWD  NAME,ADDRESS.
      1 CODE TO BUILD SP,BP FROM E1,E2.
      2 CODE FOR F(P1,...,PN), STATE AREA, RAFL.
      3 LABEL FOR <RAFL> = 0
      4 CODE FOR <RALF> AND VALUE.
      5 LABEL
      6 CODE FOR E3
      7 LABEL
%
GLOBAL ROUTINE GCREA0 =
%_SET UP TEMPLATE AND ACQUIRE REGISTERS FOR SP AND BP
  READY TO RECEIVE CODE FOR FUNCTION/ROUTINE NAME AND PARAMETERS.
  CODEPTR AT \2 ON EXIT.
_%
BEGIN
  LOCAL H;
  TEMPLATE(2,CREATC,7);
  ACPDT();    ! --> 1;
  H _ .CT[.CODEPTR,0]<PREVF>;
  PUSHCODE();	!--> \1;

      ! SAVE IDENTITY OF SP, BP AS XWD  NAME,ADDRESS.
  CT[.H,2] _ ACQUIRE(-1,1);  CT[.H,3] _ ACQUIRE(-1,1);
  CT[.H,2]<LEFTF> _ .ART[.CT[.H,2]]<RTEF>;
  CT[.H,3]<LEFTF> _ .ART[.CT[.H,3]]<RTEF>;
  ACPR2();   ! -->2
  PUSHCODE();   ! -->\2
END;    ! END OF GCREA0.




GLOBAL ROUTINE GCREA1(P) =
%_GENERATE CODE FOR PARAMETERS EXEPT LAST.
  CODEPOINTER AT \2 THROUGHOUT.
_%
BEGIN
  LOCAL H;
  PCIVR(.P,0);
    !  RELOAD SP IF NECESSARY.
  H _ LOCATE(CREATC,0);
  IF .RT[.CT[.H,2]<LEFTF>]<RSF>
    THEN RELOADTEMP(.CT[.H,2]<RIGHTF>,.CT[.H,2]<LEFTF>);
  REGSEARCH(P,0);
  CODE(PUSH,.CT[.H,2]<RIGHTF>,MEMORYA(.P),0);
END;    ! END OF GCREA1.




GLOBAL ROUTINE GCREA2(P,F,M) =
%_P IS PARAMETER LEXEME,
  F IS FUNCTION/ROUTINE LEXEME,
  M IS # OF PARAMETERS.
  PUSH DOWN LAST PARAMETER, THEN PUT RETURN POINT, S-REGISTER, F-REGISTER,
  DECLARABLE REGISTERS, REACTIVATION POINT INTO STATE AREA.  IF THE
  INSPECTION FEATURE IS USED, GENERATE CODE TO COMPUTE CORRECT RAFL AND
  RALF FIELDS.   -->\2 ON ENTRY;  -->\1 ON EXIT.
_%
BEGIN
  LOCAL K,RETLEX;
  REGISTER H;
  MACRO SP = (.H)<RIGHTF>$,
        BP = (.H+1)<RIGHTF>$;
  H _ CT[LOCATE(CREATC,0),2]<0,0>;    ! ADDR OF SP,BP IS NOW .SP, .BP.
  IF .M NEQ 0 THEN GCREA1(.P);   ! CODE FOR LAST PARAMETER.

    !  RELOAD BP IF NECESSARY.
  IF .RT[.(.H+1)<LEFTF>]<RSF> THEN
    RELOADTEMP(.BP,.(.H+1)<LEFTF>);
      ! NOW INITIALIZE STATE AREA.
%3.38%  CODE(PUSH,.SP,COPTR(0,0,LABLE(LOCATE(CREATC,5))),0);  ! RETURN ADDR.
  CODE(MOVEM,.SP,.BP^18 OR 1,0);  ! SAVE PROCESS SREG
  CODE(HRRZM,.FREG,.BP^18 OR 2,0);  ! SAVE PROCESS FREG.
  CODE(HRRZI,.SP,GMA(GAT(.F)),0);
  CODE(MOVEM,.SP,.BP^18,0);    ! SAVE REACTIVATION POINT.

  IF .SVERGFLG THEN
      ! NOW CODE TO SAVE ALL DECLARABLE REGISTERS IN PROCESS STATE.
  ( K _ 2;
    INCR I FROM 0 TO 15 DO
      IF (.SVREGM AND 1^.I) NEQ 0 THEN
        CODE(MOVEM,.I,.BP^18 OR (K _ .K+1),1);
  );
      ! K NOW HOLDS SIZE OF STATEAREA - 1.
      ! NOW CODE TO SET RALF, RAFL FIELDS AND TRANSMIT VALUE OF CREATE.
  RETLEX _ GETVREG();
  IF .LUNDEFLG THEN
	! YES, RALF/RAFL MUST BE CALCULATED.
  ( K _ .M + 2 + (IF .SVERGFLG THEN .NOSVR ELSE 0);
	! K NOW HOLDS REL. ADDR. OF FIRST 'PSEUDO LOCAL'.
    CODE(LDB,.VREG,LITA(LITLEXEME(#331100777777 OR .SP^18)),1);
      ! NOW RAFL FROM SPECIAL WORD IN CODE IS IN VREG.
    CODE(JUMPE,.VREG,LABLE(LOCATE(CREATC,3)),1);  ! JUMP IF RAFL = 0.
    CODE(ADDI,.VREG,.K,0);   ! ADD SIZE OF STATE+PARAMETERAREA.
    CODE(LSH,.VREG,9,0);
      ! NOW MOVE PAST LABEL.
    ACPR2();   CLASSLAB();   PUSHCODE();   ! -->3;  -->4;  -->\4;
    IF .M NEQ 0 THEN CODE(IORI,.VREG,.K,0);   ! OR IN RALF.
      ! NOW FINISH THE VALUE.
    CODE(LSH,.VREG,18,0);
    CODE(IOR,.VREG,.BP,0);   ! OR IN BASE ADDR. FROM BR.
  )
  ELSE
	! NO, RAFL/RALF NOT WANTED.
  ( CODE(MOVE,.VREG,.BP,0);
%3.38%    ACPR2();   CLASSLAB();   PUSHCODE();   ! -->3;  -->4;  -->\4;
  );

      ! NOW CODE TO JUMP PAST THEN PART.
  CODE(JRST,0,LABLE(LOCATE(CREATC,7)),1);
      ! FIRST CLASSIFY THEN-LABEL.
  ACPR2();    CLASSLAB();   !  -->5;   -->6;
      ! NOW BE READY TO RECEIVE CODE FOR LOCATION AND LENGTH OF PROCESS.
  CODEPTR _ LOCATE(CREATC,1);    PUSHCODE();   ! -->1;   -->\1;

  DULEX(.RETLEX);
  .RETLEX
END;    ! END OF GCREA2.




GLOBAL ROUTINE GCREA3(S) =
%_COMPILE CODE TO LOAD BASE OF PROCESS INTO SIMULATED STACK REGISTER.
  -->\1 THROUGHOUT.
_%
BEGIN
  REGISTER H;
  H _ LOCATE(CREATC,0);
	! RELOAD SP IF NECESSARY.
  IF .RT[.CT[.H,2]<LEFTF>]<RSF> THEN
    RELOADTEMP(.CT[.H,2]<RIGHTF>,.CT[.H,2]<LEFTF>);
  PCIVR(.S,0);
  CODE(HRRZ,.CT[.H,2]<RIGHTF>,MEMORYA(.S),0)
END;    ! END OF GCREA3.




GLOBAL ROUTINE GCREA4(S) =
%_COMPILE CODE TO LOAD NEGATIVE LENGTH OF PROCESS INTO LEFT HALF OF
  SIMULATED S-REGISTER, INITIALIZE SIMULATED BASE, AND MOVE SP PAST
  STATE-AREA.    -->\1 ON ENTRY;   -->\6 ON EXIT;
_%
BEGIN
  LOCAL L,R;
  REGISTER H;
  MACRO SP = (.H)<RIGHTF>$,
        BP = (.H+1)<RIGHTF>$;
  H _ CT[LOCATE(CREATC,0),2]<0,0>;   ! NOW .SP, .BP IS ADDRESS OF SP, BP.
  PCIVR(.S,0);
	! RELOAD SP, BP IF NECESSARY.
  IF .RT[.(.H)<LEFTF>]<RSF> THEN
    RELOADTEMP(.SP,.(.H)<LEFTF>);
  IF .RT[.(.H+1)<LEFTF>]<RSF> THEN
    RELOADTEMP(.BP,.(.H+1)<LEFTF>);
  CODE(MOVN,.BP,MEMORYA(.S),1);
  CODE(HRL,.SP,.BP,0);
  CODE(HRRZ,RMA(.BP,0,.BP),.SP,0);
  L _ (IF .SVERGFLG THEN .NOSVR ELSE 0) + 2;
  CODE(ADD,RMA(.SP,0,.SP),LITA(LITLEXEME((.L)^18 OR .L)),0);

      ! NOW MAKE READY FOR THEN-PART.
  CODEPTR _ LOCATE(CREATC,6);    !  -->6.
  PUSHCODE();			!   -->\6.
END;    ! END GCREA4.



GLOBAL ROUTINE GCREA5(S) =
%_S IS THE THEN-PART LEXEME.
  TERMINATE CODE FOR THEN-PART WITH A HALT.
  CLEAN UP THE MESS.    -->\6 ON ENTRY.
_%
BEGIN
  DULEX(CONVEY(.S));
  CODE(JRST,4,0,0);
  ACPR2();    ! -->7.
  CLASSLAB(); ! -->0.
  UNTEMPLATE();

END;	! OF GCREA5.
% ROUTINES FOR EXCHJ.

                                        EXCHJ(PP,VAL)
                                                ^   ^
                                                ^   ^
   GEXCH0(PP) ----------------------------------^   ^
                                                    ^
   GEXCH1(VAL,TOG) ---------------------------------^


  SKELETON:
  0 EXCHC
    1 CODE TO SAVE PROCESS STATE
    2 PROCESS-EXPR IF NOT ONE-MOVER
    3 REST OF CODE
    4 LABEL - REACTIVATION POINT

_%


GLOBAL ROUTINE GEXCH0(PP) =
%_SET UP TEMPLATE,  GENERATE CODE FOR STATE AND NEW BASE.
  BE READY TO RECEIVE CODE FOR VALUE-EXPRESSION
  VALUE RETURNED IS TRUE IF PP CAN BE PUSHED WITHOUT PREVIOUS CALCULATION.
  ITS LEFTF THEN HOLDS CT-INDEX OF THAT PUSH-INSTR.
  --> \3 ON EXIT.
_%
BEGIN
%3.36%  EXTERNAL RBREG;
  LOCAL R,ONEINSTR;
  TEMPLATE(1,EXCHC,4);
  ACPDT();     ! --> 1.
  PUSHCODE();  ! --> \1.
%>
    FIRST SAVE PROCESS STATE REGISTERS, WHICH ARE UNCHANGED ACROSS THE
    PARAMETER EXPRESSIONS.  THEN SET THE REACTIVATION POINT.
<%
%3.36%  CODE(MOVE,BREG_ACQUIRE(-1,1),GMA(.RBREG),0);
  CODE(MOVEM,.FREG,.BREG^18 OR 2,0);
  CODE(MOVEM,.SREG,.BREG^18 OR 1,0);
  CODE(MOVEI,R_ACQUIRE(-1,1),LABLE(LOCATE(EXCHC,4)),1);
  CODE(MOVEM,RMA(.R,0,.R),.BREG^18,1);
%>
    NOW PUSH NEW BASE, ASSUMING IT HAS SIDEEFFECTS ON VALUE.
<%
  ACPR2();	PUSHCODE();	! --> 2;   --> \2.
  CODE(PUSH,.SREG,(PP _ MEMORYA(.PP)),1);
  NEXTLOCAL _ .NEXTLOCAL + 1;
  DULEX(.PP);
  ONEINSTR _ SINGINSTP(.CT[.CODEPTR,0]<NEXTF>);  ! WAS PUSH THE ONLY INSTR. GENERATED?
  ACPR2();    ! --> 3;
  PUSHCODE(); ! --> \3;
  .ONEINSTR
END;    ! END ROUTINE GEXCH0.




GLOBAL ROUTINE GEXCH1(VAL,TOG) =
%_VAL IS LEXEME FOR VALUE-EXPRESSION.
  TOG IS TRUE IF WE CAN MOVE PP DIRECTLY TO BASE REGISTER, AND ITS
  LEFTF HOLDS THE CT-INDEX OF PUSH-INSTR. GENERATED BY GEXCH0.
  --> \3 ON ENTRY.
_%
BEGIN
%3.36%  EXTERNAL RBREG;
  LOCAL R,K,MASK1,B18;
  B18 _ .BREG^18;   MASK1 _ 0;
  VAL _ CONVEY(.VAL);

     ! NOW CODE TO SAVE HI-TEMPS.
  INCR I FROM 16 TO 31 DO
    IF .RT[.I]<USEF> NEQ 0 THEN
      IF NOT (.RT[.I]<RSF>) THEN
        IF (((1^(R_.RT[.I]<ARTEF>)) AND .HITREGM) NEQ 0)
           OR (IF .R EQL .VREG THEN .RT[.I]<USEF> GTR 1 ELSE 0)
        THEN
          DUMPREG(.R);

      ! NOW CODE TO SAVE ALL DECLARABLES.
  IF .SVERGFLG THEN
  ( K _ 2;
    INCR I FROM 0 TO 15 DO
      IF (.SVREGM AND 1^.I) NEQ 0 THEN
        ( MASK1 _ .MASK1 OR 1^.I;
          CODE(MOVEM,.I,.B18 OR (K _ .K+1),1));
  );

      ! NOW READY TO SWAP BASES.
  IF .TOG THEN
	! YES, WE MAY REPLACE THE PUSH BY A MOVE AFTER THE VALUE CALCULATION.
    ( R _ PUSHBOT(.CODEPTR,TAKE(.TOG<LEFTF>));
      CT[.R,1]<FUNCF> _ MOVE;
      CT[.R,1]<ACCF> _ .BREG)
  ELSE
	!  NO, MUST COMPUTE PP BEFORE VAL.  NOW POP IT INTO BREG.
    CODE(POP,.SREG,.BREG,0);
  IF .NEXTLOCAL GTR .MAXLOCAL THEN MAXLOCAL _ .NEXTLOCAL;
  NEXTLOCAL _ .NEXTLOCAL - 1;

      ! BREG NOW CONTAINS BASE OF DESTINATION, AND WE MAY RESTORE ALL
      ! REGISTERS.
%3.36%  CODE(MOVEM,.BREG,GMA(.RBREG),0);
  CODE(MOVE,.SREG,.B18 OR 1,0);
  CODE(MOVE,.FREG,.B18 OR 2,0);
  IF .SVERGFLG THEN
  ( K _ 2;
    INCR I FROM 0 TO 15 DO
      IF .MASK1^(-.I) THEN
        CODE(MOVE,.I,.B18 OR (K _ .K+1),1);
  );
      ! NOW READY TO JUMP ACROSS INDIRECTLY VIA STORED REACTIVATION POINT.
  CODE(JRST,0,(1^22) OR .B18,0);
%3.36%  RELREG(.BREG);
  ACPR1();     ! -->3.
  PROMOTE(1^CNVEYC OR 1^RELC);
  ACPR1();      ! --> 4
  CLASSLAB();   ! --> 0
  UNTEMPLATE();
  SESTOG _ .SESTOG OR 4;
  .VAL
END;    ! END ROUTINE GEXCH1.
GLOBAL ROUTINE GSPUNOP(TYPE,PARAMETER)=
  !THIS ROUTINE SERVES AS A SWITCH TO CALL THE SPECIAL-UNARY-OPERATOR
  !ROUTINES
  BEGIN
	 ROUTINE GJFFO(X)=
	  BEGIN
	    !GENERATE CODE FOR FIRSTONE(X)
	    BIND JFFOC=CMPEXC;
	    LOCAL REG,RESREG;
	    IF LITP(.X) THEN RETURN LITLEXEME(FIRSTONE(LITV(.X)));
	    PCIVR(.X,0);
	    REGSEARCH(X,0);
	    TEMPLATE(1,JFFOC,2);
	    ACPDT();
	    PUSHCODE();
	    CODEN(JFFO,RESREG_REGAR(REG_GLTR2(.X)),LABLE(LOCATE(JFFOC,2)),3,.X);
	    CODE(SETO,RESREG_.RESREG+1,0,0);
	    ACPR2();
	    CLASSLAB();
	    UNTEMPLATE();
	    LEXRA(.RESREG)
	  END;


	 ROUTINE GMOVM(X)=
	  !GENERATE CODE FOR ABS(X)
	  BEGIN LOCAL REG;
	    IF LITP(.X) THEN RETURN LITLEXEME(ABS(LITV(.X)));
	    PCIVR(.X,0);
	    REGSEARCH(X,0);
	    CODE(MOVM,REG_ACQUIRE(-1,1),MEMORYA(.X),1);
	    LEXRA(.REG)
	  END;


	 ROUTINE GSGN(X)=
	  !GENERATE CODE FOR SIGN(X)
	  BEGIN LOCAL REG,ADDR;
	    IF LITP(.X) THEN RETURN LITLEXEME(SIGN(LITV(.X)));
	    PCIVR(.X,0);
	    CODE(SKIPE,REG_ACQUIRE(-1,1),ADDR_MEMORYA(.X),0);
	    CODE(SETO,.REG,0,0);
	    CODE(SKIPLE,0,.ADDR,0);
	    CODE(MOVEI,.REG,1,0);
	    LEXRA(.REG)
	  END;
EXTERNAL GOFFSET;
    CASE .TYPE OF SET
      GJFFO(.PARAMETER);
      GMOVM(.PARAMETER);
%2.10%  GSGN(.PARAMETER);
%2.10%	GOFFSET(.PARAMETER)
    TES
  END;
GLOBAL ROUTINE GSPLF(T,P1,P2)=
  ! GENERATE CODE FOR SP-FCNS:
  !	1 --> SCANN
  !	2 --> SCANI
  !	3 --> REPLACEN
  !	4 --> REPLACEI
  !	5 --> COPYNN
  !	6 --> COPYNI
  !	7 --> COPYIN
  !	8 --> COPYII
  !	9 --> INCP
  !	10--> ASH	%5-17-77%
  !	11--> ROT	%5-17-77%
  !	12--> LSH	%5-17-77%

  IF .T GEQ 10
  THEN
    BEGIN
    EXTERNAL GASH,GROT,GLSH;
    CASE .T - 10 OF
        SET
	GASH(.P1,.P2);
	GROT(.P1,.P2);
	GLSH(.P1,.P2)
	TES
    END
  ELSE
  BEGIN LOCAL R;
    PCIVR(.P1,.P2);
    P1_IF .P1<COPF> THEN GAT(.P1) ELSE GDOT(.P1);
    IF .T GEQ 5 THEN (P2_IF .P2<COPF> THEN GAT(.P2) ELSE GDOT(.P2));
    IF (T_.T-1) LEQ 1 THEN
      BEGIN  !SCANN AND SCANI
	CODE(LDB-.T,R_ACQUIRE(-1,1),GMA(.P1),1);
	SESTOG_.SESTOG OR 1
      END ELSE
    IF .T LEQ 3 THEN
      !REPLACEN AND REPLACEI
%3.25%	CODE(DPB-(.T-2),R_REGAK(GLAR(.P2)),GMA(.P1),5) ELSE
    IF .T EQL 8 THEN
      !INCP
	CODE(IBP,R_0,GMA(.P1),5)
    ELSE
      !COPYNN, COPYNI, COPYIN, COPYII
	BEGIN
	  CODE(LDB-(.T GTR 5),R_ACQUIRE(-1,1),GMA(.P1),1);
	  CODE(DPB-(.T AND 1),REGAK(LEXRA(.R)),GMA(.P2),5)
	END;
    SESTOG_.SESTOG OR 8;
    IF .R NEQ 0 THEN LEXRA(.R) ELSE ZERO
  END;
GLOBAL ROUTINE GML(F,A,M,X,I)=
  ! GENERATE CODE FOR MACHINE LANGUAGE CONSTRUCT. A IS GUARANTEED TO
  ! BE A LITERAL.  NOTE THAT I MUST ALSO BE A LITERAL OTHERWISE AN
  ! ERROR IS GIVEN

  BEGIN LOCAL VA,INDIRMASK;
    VA_LITV(.A) AND 1^4-1;
    IF LITP(.I) THEN (INDIRMASK_(LITV(.I) AND 1)^22; I_0)
	    ELSE  RETURN ERROR(.NDEL,#147);
    M_GPTR(.M,0,36,.X,.I);
    IF NOT REGP(.M) THEN M_GDOT(.M);
    CODE(.F,REGAK(A_LEXRA(.VA)),MEMORYA(.M) OR .INDIRMASK,.ART[.VA]<DTF>);
    IF .F LEQ #130 THEN SESTOG_.SESTOG OR 8;
    .A
  END;



%3.1%	GLOBAL ROUTINE CONVEY(X)=
  %   GENERATE CODE TO MOVE X TO .VREG, THE VALUE-REGISTER.   %
  GESCAPE(.X,CNVEYC);



GLOBAL ROUTINE GRETURN(X)=
  %   GENERATE CODE FOR RETURN X.   %
  BEGIN
    LOCAL V,C,I; REGISTER PTRTOI;
    PCIVR(.X,0);
    V_GESCAPE(.X,CODEC);
    I_.CODEPTR; PTRTOI_I;
    DO C_.CT[ADVR1(.PTRTOI),0]<CLASSF> UNTIL
      IF .C GEQ BEC THEN
          CASE .C-BEC OF
            SET
            %BEC%
              BEGIN
                CODE(XCT,0,LABLE(ADVR1(.PTRTOI)),0);
                SURFACE(.PTRTOI)
              END;
            %FRC%
              GUJUMP(ADVR1(.PTRTOI));
            %CURRENTC%
              0
            TES ELSE
      IF .I EQL .PROGRAM THEN RETURN ERROR(.NDEL,#144) ELSE
      SURFACE(.PTRTOI);
    .V
  END;
!		OVERALL COMMENT ON HOW EXIT STATEMENTS ARE HANDLED:
!	
!		TO INSURE THAT CODE TO CONVEY UNUSED VALUES IS DISCARDED WHEN AN
!	EXIT STATEMENT IS GENERATED, THE CONVEYING CODE IS HUNG OFF A HEADER OF
!	TYPE XLOOPC, XCASEC, ETC. DEPENDING ON THE CONTROL ENVIRONMENT BEING
!	EXITED.  FOR EXAMPLE, THE EXIT STATEMENT:
!		DO DO IF .A THEN .B ELSE EXIT[2] WHILE C() UNTIL D()
!	IS GENERATED INTERNALLY BY GXEXIT AS THOUGH IT WAS AN EXITLOOP[1].  THE
!	SUBCLASS FIELD OF THE EXITC HEADER CONTAINS THE COUNT OF THE NUMBER OF
!	LEVELS OF CONTROL OF THIS CLASS TO BE EXITED.  EACH TIME THE PROMOTE
!	ROUTINE (SEE LOLSTPKG) IS CALLED BY THE APPROPRIATE CONTROL ROUTINE OF
!	THIS CLASS IT DECREMENTS THIS COUNT BY 1.  WHEN THE COUNT REACHES 0, THEN
!	THE EXITCLASS IS CHANGED TO A CONVEYC AND THE VALUE IS SUBSEQUENTLY
!	RETAINED OR DISCARDED.


%V2H%	GLOBAL ROUTINE GLEAVE(X,N)=
%V2H%	  !THIS ROUTINE WILL EVENTUALLY REPLACE GXEXIT AND THE
%V2H%	  !INDIVIDUAL EXIT CONTROL ROUTINES EXCEPT FOR PERHAPS
%V2H%	  !EXITLOOP FOR BLIS11 COMPATIBILITY.  THIS REPLACES
%V2H%	  !ALL "EXIT" TYPE EXCAPES WITH "LEAVE" TYPE ESCAPES.  IT
%V2H%	  !IS BASICALLY PATTERNED AFTER GXEXIT AND USES PRETTY MUCH THE
%V2H%	  !THE SAME MECHANISM.
%V2H%	  ! GENERATE JUMP TO PROPER LABEL. SEE COMMENT ABOVE.
%V2H%	
%V2H%	  BEGIN
%V2H%	    STRUCTURE EXITVECT[I]=[I](.EXITVECT-2+.I)<0,36>;
%V2H%	
%V2H%	    BIND XCLASSES=1^COSTC+1^SELECTC+1^CMPEXC+1^ITEC+1^DWUC+1^WUDC+1^IDFTDC+1^BEC;
%V2H%	    REGISTER 	C,	! CLASS OF CELL BEING TESTED
%V2H%			SUBCLASS,	! SUBCLASS OF CELL BEING TESTED
%V2H%			EXTYPE,	! TYPE(CLASS) OF CONTROL ACTUALLY EXITED
%V2H%			CODEPTRSAV,	! A TEMP TO HOLD CODEPTR (NEC. BECAUSE LOCATE STARTS SEARCH AT .CODEPTR)
%V2H%			PTRTOI;	! HOLDS POINTER TO I TO PASS TO ADVR1, ETC.
%V2H%	
%V2H%	    LOCAL	V,	! LEXEME OF VALUE REGISTER
%V2H%			EXCODIND,	! INDEX OF HEADER W/ CODE TO LOAD VREG
%V2H%			I,	! INDEX OF CELL BEING TESTED
%V2H%			CODEPROD,	! BOOLEAN INDICATING CODE GENERATED TO LOAD VREG
%V2H%			EXITVECT NUM[6],! A VECTOR IN WHICH NUM[I] CONTAINS THE
%V2H%					! NUMBER OF LEVELS OF EXITABLE CONTROL
%V2H%					! OF TYPE I ACTUALLY EXITED
%V2H%			ICURR,		!TO SAVE CURRENT CONTENTS OF I
%V2H%			HEADER;		!INDEX OF HEADER OF WHICH .I IS CURRENTLY A SUBHEADER.
%V2H%	
%V2H%	    PCIVR(.X,0);
%V2H%	    CODEPROP_0;
%V2H%	    V_GESCAPE(.X,XITC);
%V2H%	    CODEPROD_.CODEPROP;
%V2H%	    I_.CODEPTR;
%V2H%	    PTRTOI_I;
%V2H%	    EXCODIND_.CT[.CODEPTR,0]<PREVF>;
%V2H%	    NUM[2]_NUM[3]_NUM[4]_NUM[5]_NUM[6]_NUM[7]_0;
%V2H%	    DO C_.CT[ADVR1(.PTRTOI),0]<CLASSF> UNTIL
%V2H%	      IF (1^.C AND XCLASSES) NEQ 0 OR (.C GEQ BEC) THEN
%V2H%		BEGIN
%V2H%		  SUBCLASS_.CT[.I,1]<CLASSF>;
%V2H%		  ICURR_.I;		!SAVE CURRENT INDEX
%V2H%		  SURFACE(.PTRTOI);	!GET HEADER INDEX
%V2H%		  HEADER_.I;		!SAVE HEADER INDEX
%V2H%		  I_.ICURR;		!RESTORE OLD I
%V2H%		  CASE .C - COSTC OF
%V2H%		    SET
%V2H%		      !COSTC	********  #16
%V2H%			BEGIN
%V2H%			  NUM[XCOSTC]_.NUM[XCOSTC]+1;
%V2H%			  IF .N EQL .HEADER
%V2H%			    THEN
%V2H%			      BEGIN
%V2H%				EXTYPE_XCOSTC;
%V2H%				CODEPTRSAV_.CODEPTR; CODEPTR_.I;
%V2H%				I_LOCATE(COSTC,7);
%V2H%				CODEPTR_.CODEPTRSAV;
%V2H%				GUJUMP(.I)
%V2H%			      END
%V2H%			    ELSE SURFACE(.PTRTOI)
%V2H%		        END;
%V2H%		      !SELECTC	********  #17
%V2H%			BEGIN
%V2H%			  NUM[XSELECTC]_.NUM[XSELECTC]+1;
%V2H%			  IF .N EQL .HEADER THEN
%V2H%			    BEGIN
%V2H%			      EXTYPE_XSELECTC;
%V2H%			      CODEPTRSAV_.CODEPTR; CODEPTR_.I;
%V2H%			      I_LOCATE(SELECTC,5);
%V2H%			      CODEPTR_.CODEPTRSAV;
%V2H%			      GUJUMP(.I)
%V2H%			    END
%V2H%			  ELSE SURFACE(.PTRTOI)
%V2H%			END;
%V2H%		0;	!SELELC	********  #20
%V2H%		0;	!EXCHC	********  #21
%V2H%		0;	!CREATC	********  #22
%V2H%		0;	!UNUSED	********  #23
%V2H%		0;	!UNUSED	********  #24
%V2H%		0;	!CASEC	********  #25
%V2H%		0;	!SETC	********  #26
%V2H%		0;	!NSETC	********  #27
%V2H%		      !CMPEXC	********  #30
%V2H%			BEGIN
%V2H%			  NUM[XCMPEXC]_.NUM[XCMPEXC]+1;
%V2H%			  IF .N EQL .HEADER THEN
%V2H%			    (EXTYPE_XCMPEXC;GUJUMP(ADVR1(.PTRTOI));CT[.CT[.I,0]<NEXTF>,2]_1)
%V2H%			  ELSE SURFACE(.PTRTOI)
%V2H%			END;
%V2H%		      !ITEC	********  #31
%V2H%			BEGIN
%V2H%			  NUM[XCONDC]_.NUM[XCONDC]+1;
%V2H%			  IF .N EQL .HEADER
%V2H%			    THEN
%V2H%			      BEGIN
%V2H%				EXTYPE_XCONDC;
%V2H%				CODEPTRSAV_.CODEPTR; CODEPTR_.I;
%V2H%				I_LOCATE(ITEC,5);
%V2H%				CODEPTR_.CODEPTRSAV;
%V2H%				GUJUMP(.I)
%V2H%			      END
%V2H%			    ELSE SURFACE(.PTRTOI)
%V2H%		        END;
%V2H%		      !DWUC	********  #32
%V2H%			BEGIN
%V2H%			  NUM[XLOOPC]_.NUM[XLOOPC]+1;
%V2H%			  IF .N EQL .HEADER
%V2H%			    THEN
%V2H%			      BEGIN
%V2H%				EXTYPE_XLOOPC;
%V2H%				CODEPTRSAV_.CODEPTR; CODEPTR_.I;
%V2H%				I_LOCATE(DWUC,4);
%V2H%				CODEPTR_.CODEPTRSAV;
%V2H%				GUJUMP(.I)
%V2H%			      END
%V2H%			    ELSE SURFACE(.PTRTOI)
%V2H%		        END;
%V2H%		      !WUDC	********  #33
%V2H%			BEGIN
%V2H%			  NUM[XLOOPC]_.NUM[XLOOPC]+1;
%V2H%			  IF .N EQL .HEADER
%V2H%			    THEN
%V2H%			      BEGIN
%V2H%				EXTYPE_XLOOPC;
%V2H%				CODEPTRSAV_.CODEPTR; CODEPTR_.I;
%V2H%				I_LOCATE(WUDC,6);
%V2H%				CODEPTR_.CODEPTRSAV;
%V2H%				GUJUMP(.I)
%V2H%			      END
%V2H%			    ELSE SURFACE(.PTRTOI)
%V2H%		        END;
%V2H%		      !IDFTDC	********  #34
%V2H%			  BEGIN
%V2H%			    NUM[XLOOPC]_.NUM[XLOOPC]+1;
%V2H%			    IF .N EQL .HEADER THEN
%V2H%			      BEGIN
%V2H%				EXTYPE_XLOOPC;
%V2H%				CODEPTRSAV_.CODEPTR; CODEPTR_.I;
%V2H%				I_LOCATE(IDFTDC,6);
%V2H%				CODEPTR_.CODEPTRSAV;
%V2H%				GUJUMP(.I)
%V2H%			      END
%V2H%			    ELSE SURFACE (.PTRTOI)
%V2H%			  END;
%V2H%		      !BEC	********  #35
%V2H%			BEGIN
%V2H%			  NUM[XBLOCKC]_.NUM[XBLOCKC]+1;
%V2H%			  IF .N EQL .HEADER THEN (EXTYPE_XBLOCKC;GUJUMP(ADVR1(.PTRTOI)); CT[ADVR2(.PTRTOI),2]_1)
%V2H%			  ELSE (CODE(XCT,0,LABLE(ADVR1(.PTRTOI)),0);SURFACE(.PTRTOI))
%V2H%			END;
%V2H%		      !FRC	********  #36
%V2H%			RETURN(ERROR(.NDEL,#144));
%V2H%		      !CURRENTC	********  #37
%V2H%			0
%V2H%		    TES
%V2H%		END ELSE
%V2H%	      IF .I EQL .PROGRAM THEN RETURN ERROR(.NDEL,#144)
%V2H%	      ELSE SURFACE (.PTRTOI);
%V2H%	    IF .CODEPROD NEQ 0 THEN
%V2H%	      BEGIN
%V2H%	        CT[.EXCODIND,0]<CLASSF>_.EXTYPE;
%V2H%	        CT[.EXCODIND,1]<HDRCLASSF>_.NUM[.EXTYPE]
%V2H%	      END;
%V2H%	    .V
%V2H%	  END;
ROUTINE GXEXIT(X,N,XTYPE,XCLASSES)=
  ! CALLED BY ALL THE EXIT ROUTINES TO GENERATE CODE TO CONVEY VALUE
  ! GENERATE JUMP TO PROPER LABEL. SEE COMMENT ABOVE.

  BEGIN
    STRUCTURE EXITVECT[I]=[I](.EXITVECT-2+.I)<0,36>;

    REGISTER 	C,	! CLASS OF CELL BEING TESTED
		SUBCLASS,	! SUBCLASS OF CELL BEING TESTED
		EXTYPE,	! TYPE(CLASS) OF CONTROL ACTUALLY EXITED
		CODEPTRSAV,	! A TEMP TO HOLD CODEPTR (NEC. BECAUSE LOCATE STARTS SEARCH AT .CODEPTR)
		PTRTOI;	! HOLDS POINTER TO I TO PASS TO ADVR1, ETC.

    LOCAL	V,	! LEXEME OF VALUE REGISTER
		EXCODIND,	! INDEX OF HEADER W/ CODE TO LOAD VREG
		I,	! INDEX OF CELL BEING TESTED
		CODEPROD,	! BOOLEAN INDICATING CODE GENERATED TO LOAD VREG
		EXITVECT NUM[6];! A VECTOR IN WHICH NUM[I] CONTAINS THE
				! NUMBER OF LEVELS OF EXITABLE CONTROL
				! OF TYPE I ACTUALLY EXITED

    PCIVR(.X,0);
    CODEPROP_0;
    V_GESCAPE(.X,.XTYPE);
    CODEPROD_.CODEPROP;
    I_.CODEPTR;
    PTRTOI_I;
    EXCODIND_.CT[.CODEPTR,0]<PREVF>;
    NUM[2]_NUM[3]_NUM[4]_NUM[5]_NUM[6]_NUM[7]_0;
    DO C_.CT[ADVR1(.PTRTOI),0]<CLASSF> UNTIL
      IF (1^.C AND .XCLASSES) NEQ 0 OR (.C GEQ BEC) THEN
	BEGIN
	  SUBCLASS_.CT[.I,1]<CLASSF>;
	  CASE .C - SETC OF
	    SET
	      !SETC
		BEGIN
		  N_.N-1;NUM[XCOSTC]_.NUM[XCOSTC]+1;
		  IF .N EQL 0 THEN
		    BEGIN
		      CODEPTRSAV_.CODEPTR; CODEPTR_.I;
		      I_IF .CT[LOCATE(COSTC,0),3] AND
			  ((1^CASEC AND .XCLASSES) EQL 0) THEN
			  LOCATE(SETC,3)
			ELSE LOCATE(COSTC,7);
		      CODEPTR_.CODEPTRSAV;
		      EXTYPE_XCOSTC;
		      GUJUMP(.I)
		    END
		  ELSE SURFACE(.PTRTOI)
		END;
	      !NSETC
		BEGIN
		  N_.N-1;NUM[XSELECTC]_.NUM[XSELECTC]+1;
		  IF .N EQL 0 THEN
		    BEGIN
		      EXTYPE_XSELECTC;
		      CODEPTRSAV_.CODEPTR; CODEPTR_.I;
		      I_LOCATE(SELECTC,5);
		      CODEPTR_.CODEPTRSAV;
		      GUJUMP(.I)
		    END
		  ELSE SURFACE(.PTRTOI)
		END;
	      !CMPEXC
		BEGIN
		  N_.N-1;NUM[XCMPEXC]_.NUM[XCMPEXC]+1;
		  IF .N EQL 0 THEN
		    (EXTYPE_XCMPEXC;GUJUMP(ADVR1(.PTRTOI));CT[.CT[.I,0]<NEXTF>,2]_1)
		  ELSE SURFACE(.PTRTOI)
		END;
	      !ITEC
		IF .SUBCLASS EQL 1 THEN SURFACE(.PTRTOI)
		ELSE
		  BEGIN
		    N_.N-1;NUM[XCONDC]_.NUM[XCONDC]+1;
		    IF .N EQL 0 THEN
		      (EXTYPE_XCONDC;GUJUMP(IF .SUBCLASS EQL 2 THEN ADVR3(.PTRTOI) ELSE ADVR1(.PTRTOI)))
		    ELSE SURFACE(.PTRTOI)
		  END;
	      !DWUC
		IF .SUBCLASS NEQ 2 THEN SURFACE(.PTRTOI)
		ELSE
		  BEGIN
		    N_.N-1;NUM[XLOOPC]_.NUM[XLOOPC]+1;
		    IF .N EQL 0 THEN (EXTYPE_XLOOPC;GUJUMP(ADVR2(.PTRTOI)))
		    ELSE SURFACE(.PTRTOI)
		  END;
	      !WUDC
		IF .SUBCLASS NEQ 3 THEN SURFACE (.PTRTOI)
		ELSE
		  BEGIN
		    N_.N-1;NUM[XLOOPC]_.NUM[XLOOPC]+1;
		    IF .N EQL 0 THEN (EXTYPE_XLOOPC;GUJUMP(ADVR3(.PTRTOI)))
		    ELSE SURFACE(.PTRTOI)
		  END;
	      !IDFTDC
		IF .SUBCLASS NEQ 3 THEN SURFACE(.PTRTOI)
		ELSE
		  BEGIN
		    N_.N-1;NUM[XLOOPC]_.NUM[XLOOPC]+1;
		    IF .N EQL 0 THEN
		      BEGIN
			EXTYPE_XLOOPC;
			CODEPTRSAV_.CODEPTR; CODEPTR_.I;
			I_LOCATE(IDFTDC,6);
			CODEPTR_.CODEPTRSAV;
			GUJUMP(.I)
		      END
		    ELSE SURFACE (.PTRTOI)
		  END;
	      !BEC
		BEGIN
		  IF (1^BEC AND .XCLASSES) NEQ 0 THEN
		    (N_.N-1;NUM[XBLOCKC]_.NUM[XBLOCKC]+1);
		  IF .N EQL 0 THEN (EXTYPE_XBLOCKC;GUJUMP(ADVR1(.PTRTOI)); CT[ADVR2(.PTRTOI),2]_1)
		  ELSE (CODE(XCT,0,LABLE(ADVR1(.PTRTOI)),0);SURFACE(.PTRTOI))
		END;
	      !FRC
		RETURN(ERROR(.NDEL,#144));
	      !CURRENTC
		0
	    TES
	END ELSE
      IF .I EQL .PROGRAM THEN RETURN ERROR(.NDEL,#144)
      ELSE SURFACE (.PTRTOI);
    IF .CODEPROD NEQ 0 THEN
      BEGIN
        CT[.EXCODIND,0]<CLASSF>_.EXTYPE;
        CT[.EXCODIND,1]<HDRCLASSF>_.NUM[.EXTYPE]
      END;
    .V
  END;
GLOBAL ROUTINE GXBLOCK(X,N)=GXEXIT(.X,.N,XBLOCKC,1^BEC);



GLOBAL ROUTINE GXLOOP(X,N)=GXEXIT(.X,.N,XLOOPC,1^DWUC OR 1^WUDC OR 1^IDFTDC);



GLOBAL ROUTINE GXCOND(X,N)=GXEXIT(.X,.N,XCONDC,1^ITEC);



GLOBAL ROUTINE GXCMPEX(X,N)=GXEXIT(.X,.N,XCMPEXC,1^CMPEXC);



GLOBAL ROUTINE GXSELECT(X,N)=GXEXIT(.X,.N,XSELECTC,1^NSETC);



GLOBAL ROUTINE GXSET(X,N)=GXEXIT(.X,.N,XCOSTC,1^SETC);



GLOBAL ROUTINE GXCASE(X,N)=GXEXIT(.X,.N,XCOSTC,1^CASEC OR 1^SETC);



GLOBAL ROUTINE GEXIT(X,N)=GXEXIT(.X,.N,XITC,1^SETC OR 1^NSETC OR
				 1^CMPEXC OR 1^ITEC OR 1^DWUC OR 1^WUDC
				 OR 1^IDFTDC OR 1^BEC);



ROUTINE GESCAPE(X,N)=
  %   CALLED FOR CONVEY AND ALL EXIT STATEMENTS.  GENERATES CODE TO LOAD
     VREG WITH X (IF NECESSARY).  %
  BEGIN
    LOCAL	V,	! LEXEME OF VALUE REGISTER
		NAME;	!RT-INDEX OF VREG'S NAME

    IF LEXRN(.ART[.VREG]<RTEF>) EQL .X THEN RETURN .X;
    NAME_.ART[.VREG]<RTEF>;
    V_
      IF .NAME NEQ 0 THEN
	IF .X<RTEF> EQL .NAME THEN
	  INCRUSEN(.NAME)
	ELSE
	  IF .NAME GEQ 16 THEN LEXRN(.NAME)
	  ELSE LEXRN(GETRN(.VREG,0,0))
      ELSE LEXRN(GETRN(.VREG,0,0));
    FOLLCPH(0,.N,0);
    GLPR(.X,.VREG);
    FOLLCPH(0,CODEC,0);
    CLEARONE(RT[.V<RTEF>]);
    .V
  END;
ROUTINE GCUJUMP(X,J,N,U)=
  %   GENERATE CODE TO JUMP TO CODE TABLE ENTRY J,
    CONDITIONALLY ON LEXEME X EQV N.   FOR THE SPECIAL
    CASE X EQV N AT COMPILE TIME, GENERATE AN
    UNCONDITIONAL JUMP ONLY IF U=1, OTHERWISE GENERATE
    NO CODE.   %
  ! RETURNS:
  !	0	--> X NOT EQV AT COMPILE TIME
  !	1	--> X EQV N AT COMPILE TIME
  !	2	--> EQUIVALENCE NOT KNOWN AT COMPILE TIME
  !
  ! THIS IS THE ROUTINE THAT OPTIMIZES THE RELATIONAL BOOLEANS.  E.G.:
  ! "IF .A LSS 0 THEN ..." ETC.  GLSS (H2ARITH) HAS HUNG THE CODE FOR
  ! ".A LSS 0" OFF A RELC HEADER AND THIS ROUTINE MANIPULATES THAT CODE
  ! DISCARDING SOME OF IT.  IT ALSO ATTEMPTS TO PRODUCE AOJLE ETC. FOR
  ! CONSTRUCTS OF THE FORM  ... (A_.A+1) LEQ 0 ...

  BEGIN
    IF LITP(.X) THEN
      RETURN
	IF LITV(.X) EQV .N THEN
	  IF .U THEN GUJUMP(.J)
	  ELSE 1
	ELSE 0;
    IF NO(.X) THEN RETURN GCUJUMP(GYES(.X),.J,.N XOR 1,.U);
    IF SIGN(.X) THEN RETURN GCUJUMP(GABS(.X),.J,.N,.U);
    IF REGP(.X) AND (NULL(.CODEPTR) OR ALLNOS(.CODEPTR)) THEN
      BEGIN
	LOCAL AOJTYPE,CAI0TYPE,RELINST,INEQ,AOIND,FUNC;
	MACRO	AOINST=CT[.AOIND,1]$;

	REGISTER	HEADIND, ! INDEX OF RELC HEADER
			PCH;     ! INDEX OF CODE LIST PREVIOUS TO RELC
	HEADIND_.CT[.CODEPTR,0]<PREVF>;
	IF NOT .CT[.HEADIND,0]<CLASSF> EQL RELC THEN EXITBLOCK;
	IF NOT .CT[.HEADIND,2] EQL .X THEN EXITBLOCK;
	IF .CT[.CT[.HEADIND,1]<NEXTF>,1]<FUNCF> EQL MOVEI THEN ERASETOP(.HEADIND);
	ERASEBOT(.HEADIND);
	AOJTYPE_0;
	CAI0TYPE_(.CT[.HEADIND,3] AND NOT (7^27 OR #17^23)) EQL CAI^27
		 AND .CT[RELINST_.CT[.HEADIND,1]<NEXTF>,0]<RELOCF> EQL 0;
	INEQ_.CT[.HEADIND,3]<27,3>;
	IF .CAI0TYPE THEN
	  BEGIN
	    PCH_.CT[.HEADIND,0]<PREVF>;
	    IF .CT[.PCH,0]<CLASSF> NEQ CODEC THEN EXITCOMP;
	    IF NULL(.PCH) OR ALLNOS(.PCH) THEN EXITCOMP;
	    AOIND_PREVCODE(.CT[.PCH,1]<PREVF>,.PCH);
	    AOINST_.CT[.AOIND,1];
	    FUNC_.AOINST<FUNCF>;
	    IF .AOINST<ACCF> NEQ .CT[.HEADIND,3]<ACCF> THEN EXITCOMP;
	    AOJTYPE_ .FUNC EQL AOJ OR .FUNC EQL SOJ;
	    IF .FUNC EQL AOS OR
	       .FUNC EQL SOS OR
	       .AOJTYPE THEN
	      BEGIN
		EMPTY(.HEADIND);
		RELINST_PUSHBOT(.HEADIND,TAKE(.AOIND));
		CT[.HEADIND,3]_.AOINST;
		CT[.HEADIND,3]<27,3>_CT[.RELINST,1]<27,3>_.INEQ;
		CAI0TYPE_0
	      END
	  END;
	FUNC_.CT[.HEADIND,3]<FUNCF>;
	IF .CAI0TYPE OR .AOJTYPE THEN
	  BEGIN
	    FUNC_IF .AOJTYPE THEN .FUNC AND #770 ELSE JUMP;
	    CODE(.FUNC OR (.N^2 XOR .INEQ XOR 4),
		 .CT[.HEADIND,3]<ACCF>,LABLE(.J),0)
	  END
	ELSE
	  BEGIN
	    CT[.RELINST,1]<27,3>_.INEQ XOR .N^2;
	    PUSHBOT(.CODEPTR,TAKE(.RELINST));
	    GUJUMP(.J)
	  END;
	IF .FREEVHEADER LSS 0 THEN
	  BEGIN
	    EMPTY(.HEADIND);
	    CT[.HEADIND,0]<CLASSF>_CODEC;
	    CT[.HEADIND,1]<HDRCLASSF>_0;
	    RELEASESPACE(.HEADIND+2,1);
	    FREEVHEADER_.HEADIND
	  END
	ELSE ERASE(.HEADIND);
	DULEX(.X);
	CLEARONE(RT[.X<RTEF>]);
	RETURN 2
      END;
    BEGIN LOCAL P,S;
	IF .FREEVHEADER LSS 0 THEN
	  BEGIN
	    FREEVHEADER_FOLLCPH(0,CODEC,0);
	    FOLLCPH(0,CODEC,0)
	  END;
        IF .X<COPF> NEQ 0 AND (S_.X<SIZEF>) NEQ 0 AND
          (P_.X<POSNF>) LSS 36 THEN
              CODE(CASE .P/18*2+.N OF SET TRNN; TRNE; TLNN; TLNE TES,
                    RAGLAR(GAT(.X AND (RTEM OR LSSTEM))),
		    1^(.P MOD 18),0)
        ELSE CODE(IF .N THEN TRNE ELSE TRNN,REGAR(GLAR(.X)),1,0);
        GUJUMP(.J);
    END;
    2
  END;
ROUTINE GUJUMP(J)=
  %   GENERATE UNCONDITIONAL JUMP TO J.   %
  BEGIN
    CODE(JRST,0,LABLE(.J),0);
    1
  END;






ROUTINE LABLE(J)=
  %   SET RELOCATION FIELD OF J TO BE LABEL.   %
  BEGIN
    J<RELOCF>_CTRELOC;
    .J
  END;
%%
%
	THIS SUB-MODULE GENERATES THE LINKAGE CODE FOR
	TIMING BLISS ROUTINES.  

	TIMSTE CONTAINS THE INDEX OF THE STE OF THE
	     TIMER ROUTINE NAME
%
%%


ROUTINE TIMLINK(MPINST,INST)=
BEGIN	MACRO	MAKEOP(OP,REG,ADDR)=((OP)<0,0>^27 + (REG)<0,0>^23 + (ADDR)<0,0>)$;
LOCAL REG;
	CODE(.INST,.JSPREG,0,0);
	IF .MPINST NEQ 0 THEN CODE(.MPINST,.JSPREG,#400000,0);
	CODE (PUSH, .SREG,.JSPREG, 0);
	CODE (PUSHJ,.SREG, GMA(.TIMSTE OR LSM OR DOTM), 0);
	CODE (SUB, .SREG, LITA(LITLEXEME(1^18+1)), 0);

	IF .DEBFLG THEN			!PUT PUSHJ TO TIMER ROUTINE IN USERS .JB41
	   (WRITE9(#41,MAKEOP(PUSHJ,.SREG,0));		! CODE
	    WRIT10(#41,GETNAM(TABLE[.TIMSTE + 2],6)));	! EXTERNAL REQUEST

%%
%
	.INST 	R,0
	PUSH 	$S,R
	PUSHJ 	$S,<ROUTINE>
	SUB	$S,[1000001]
%
%%
END;

GLOBAL ROUTINE TIMEIN=TIMLINK(0,HRRZI);

GLOBAL ROUTINE TIMEOUT=BEGIN
	CODE(PUSH,.SREG,.VREG,0);
	TIMLINK(0,HRROI);
	CODE(POP,.SREG,.VREG,0);
	END;


GLOBAL ROUTINE MPTIMIN=TIMLINK(TLO,HRRZI);

GLOBAL ROUTINE MPTIMOUT=TIMLINK(TLZ,HRROI);


GLOBAL ROUTINE DEBIN(RTNSTE)=CODE(DEBUGUUO,0,GMA(.RTNSTE OR LSM OR DOTM),0);
GLOBAL ROUTINE DEBOUT(RTNSTE)=CODE(DEBUGUUO,1,GMA(.RTNSTE OR LSM OR DOTM),0);



!END OF H1CNTR.BLI