Module Node =
Begin

Require 'bliss.req';

External
	FLOOR		: LVL;

Forward Routine
	BINDBIND;

!I. GENERAL:
!
!	1. PUSHES LEXEME IN 'WORD' ONTO THE PARSE STACK ('STK')
!
!	2. GLOBALS:
!
!		A. TOS -- TOP-OF-STACK
!
!II. SPECIFIC:
!
!	1. *
!
!		A. RETURN IF ANY ERRORS
!
!		B. CHECK FOR LEXEMES THAT MAY NOT BE
!		   USED AS EXPRESSIONS, E.G. STRUCTURE NAMES
!
!		C. IF WORD IS EMPTY (0) THEN PUSH A
!		   SPECIAL ZERO LEXEME.

Global Routine Push(W : Ref GT) : Novalue =
Begin
    If .num_error Neq 0 Then
	Return;
    If .W[gt_type] Eql T_VARIABLE And Not ISEXP(W) Then
	Begin
	WARNEM(.pos_sym,B11$_NON_ADDRESSABLE,.W[gt_disp]);
	FreeNode(.W);
	W = MakeLit(0)
	End;
    If .W Eql NIL Then
	W = MakeLit(0);
    STK[TOS = .TOS+1] = .W
End;

! SUBSTITUTE FOR PUSH, WHICH ALLOWS PUSHING OF
! LINKAGE TYPES AND LABELS ONTO THE STACK. CALLED
! BY SPAR, SELABEL, SLABEL, SLEAVE, SEXITLOOP, SENABLE.

Global Routine PUSH1(W : Ref GT) : Novalue =
Begin
    If .num_error Eql 0 Then
	STK[TOS = .TOS+1] = .W
End;

! push a flow queue onto the stack

Global Routine PushQueue(c : Integer) : Novalue =
Begin
    Local
	p		: Ref GT;
    Own
	t1		: Vector[4,Byte] Preset(
			[T_ALPHA] = ALPHAREMOVE,
			[T_OMEGA] = OMEGAREMOVE,
			[T_CHI]   = CHIREMOVE,
			[T_RHO]   = RHOREMOVE),
	t2		: Vector[5,Byte] Preset(
			[T_ALPHA] = ALPHAENTER,
			[T_OMEGA] = OMEGAENTER,
			[T_CHI]   = CHIENTER,
			[T_RHO]   = RHOENTER);

    p = GETSPACE(SZ_QUEUE);
    p[que_type] = T_QUEUE;
    p[que_code] = .c;
    p[que_abc]  = .abcount;
    p[que_head] = MAKHDR(.t1[.c],.t2[.c]);
    Push1(.p)
End;

!I. GENERAL:
!
!	1. MARKS THE FLOOR OF THE CURRENT PORTION OF
!	   THE STACK.
!
!	2. GLOBALS:
!
!		A. LASTMARK -- POINTS TO THE CURRENT FLOOR OF
!			       THE STACK, THE CURRENT FLOOR
!			       POINTS TO THE LAST FLOOR, ETC.
!			       BEHAVES JUST LIKE THE F-
!			       REGISTER AT RUNTIME.
!
!		B. TOS -- TOP OF STACK.
!
!II. SPECIFIC:
!
!	1. *
!
!		A. IF ANY ERRORS AT THIS LEVEL, THEN RETURN.
!
!		B. PUSH THE CURRENT FLOOR ONTO THE STACK.
!
!		C. PUT THE NEW FLOOR HERE, AT THE TOP OF THE
!		   STACK.

Global Routine Mark : Novalue =
Begin
    If .num_error Eql 0 Then
	Begin
	TOS = .TOS + 1;
	STK[.TOS] = .LASTMARK;
	LASTMARK = .TOS
	End
End;

!I. GENERAL:
!
!	1. THIS ROUTINE STARTS FROM THE CURRENT FLOOR OF THE
!	   STACK AND POPS ALL THE LEXEMES FROM IT INTO THE
!	   RESERVED GRAPH TABLE ENTRIES AT THE INDEX '.TOO'.
!
!	2. PARAMETERS:
!
!		A. TOO -- CURRENT NODE INDEX INTO THE GRAPH
!			  TABLE.
!
!	3. GLOBALS:
!
!		A. LASTMARK -- POINTS TO THE CURRENT FLOOR OF
!			       THE STACK.
!
!II. SPECIFIC:
!
!	1. *
!
!		A. IF ANY ERRORS, THEN RETURN.
!
!		B. NEXT POP FROM CURRENT FLOOR UP TO TOP-OF-
!		   STACK INTO THE RESERVED GRAPH TABLE ENTRIES
!		   AT '.TOO'.
!
!		C. NOW SET THE TOP-OF-STACK BELOW THE CURRENT
!		   FLOOR.
!
!		D. RETURN THE POINTER 'LASTMARK' TO ITS LAST
!		   VALUE.

Global Routine POPTOMARK(TOO : Ref GT) : Novalue =
Begin
    If .num_error Eql 0 Then
	Begin
	If .TOS Neq .LASTMARK Then
	    MOVECORE(STK[.LASTMARK+1], TOO[gt_arg1], .TOS-.LASTMARK);
	TOS = .LASTMARK - 1;
	LASTMARK = .STK[.LASTMARK]
	End
End;

! DELETE ALL STACK ELEMENTS ABOVE THE LAST MARK

Global Routine DELETETOMARK : Novalue =
Begin
    TOS = .LASTMARK - 1;
    LASTMARK = .STK[.LASTMARK]
End;


!
! HANDLE N-N
!
Routine CKNAMEDIFF(OPLEX : Ref GT,OP1 : Ref ST,OP2 : Ref ST) =
Begin
    If .OPLEX Neq OP_SUB Then
	Return FALSE;
    If BASESYM(.OP1) Neq BASESYM(.OP2) Then
	Return FALSE;
!
! THE ABOVE TEST WILL BE LESS RESTRICTIVE WHEN WE
! FINALLY GET AROUND TO PUTTING OUT OWNS, ETC. IN
! THE ORDER IN WHICH THEY WERE DECLARED.
!
! that is, the base psect should be compared for OWN variables.

    DELETETOMARK();
    SYM = MakeLit(.OP1[gt_disp]-.OP2[gt_disp]);
    FreeNode(.OP1);
    FreeNode(.OP2);
    Return TRUE
End;

!
! HANDLE N+L,N-L,L+N
!
Routine CKANDDONAME(OPLEX : Ref GT) =
Begin
    Macro
	COMBINE(TYPE1,TYPE2)=((TYPE1)^5 + (TYPE2)) %;
    Local
	O1		: Ref GT,
	O2		: Ref GT,
	N2		: Integer,
	SWAPPED		: Boolean;

    If .OPLEX Neq OP_ADD And .OPLEX Neq OP_SUB Then
	Return FALSE;
    O1 = .STK[.LASTMARK+1];
    O2 = .STK[.LASTMARK+2];
    Selectone COMBINE(.O1[gt_type],.O2[gt_type]) Of Set
	[COMBINE(T_VARIABLE,T_LITERAL)]:
	    SWAPPED = FALSE;
	[COMBINE(T_LITERAL,T_VARIABLE)]:
	    Begin
	    SWAPPED = TRUE;
	    SWAP(O1,O2)
	    End;
	[COMBINE(T_VARIABLE,T_VARIABLE)]:
	    Return CKNAMEDIFF(.OPLEX,.O1[gt_disp],.O2[gt_disp]);
	[Otherwise]:
	    Return 0
    Tes;
    N2 = .O2[gt_disp];
    If .OPLEX Eql OP_SUB Then
	If .SWAPPED Then
	    Return FALSE
	Else
	    N2 = -.N2;

! don't do address arithmetic on registers or locals which are 2 bytes
! in length because they have a TN assigned to them.

    If .O1[gt_type] Eql T_VARIABLE And .O1[st_code] Eql S_LOCAL And
		.Block[.O1[gt_disp],gt_reg] Gequ 8 Then
	WARNEM(.pos_sym,B11$_ADDRESS_ARITH);
    SYM = MakeVar(CREATESWO(.O1[gt_disp],.N2));
    FreeNode(.O1);
    FreeNode(.O2);
    DELETETOMARK();
    Return TRUE
End;

! this handles the cases 'X * 1' and 'X * -1'.  it does not handle
! 'X * 0' because 'X' may have side effects.

Routine SPLMULCASE(LEX : Ref GT) =
Begin
    Local
	L1		: Ref GT,
	L2		: Ref GT;

    L2 = .STK[.LASTMARK+2];
    If .L2[gt_type] Neq T_LITERAL Then
	Begin
	If .LEX Eql OP_DIV Then
	    Return 0;
	L1 = .STK[.LASTMARK+1];
	End
    Else
	Begin
	L1 = .L2;
	L2 = .STK[.LASTMARK+1]
	End;

! X * 1 => X

    If .L1[gt_type] Eql T_LITERAL Then
	If .L1[gt_disp] Eql 1 Then
	    Begin
	    SYM = .L2;
	    DELETETOMARK();
	    Return 1
	    End

! X * -1 => -X

	Else If .L1[gt_disp] Eql -1 Then
	    Begin
	    SYM = TK_NEG;
	    DELETETOMARK();
	    Mark();
	    Push(.L2);
	    Return 2
	    End;
    Return 0
End;

Routine SPLADDCASE(LEX : Ref GT) =
Begin
    Local
	L1		: Ref GT,
	L2		: Ref GT;

    L1 = .STK[.LASTMARK+1];
    L2 = .STK[.LASTMARK+2];

! X +/- 0 => X

    If .L2[gt_type] Eql T_LITERAL And .L2[gt_disp] Eql 0 Then
	Begin
	SYM = .L1;
	DELETETOMARK();
	Return 1
	End;

! 0 - X => -X

    If .L1[gt_type] Eql T_LITERAL And .L1[gt_disp] Eql 0 Then
	If .LEX Eql OP_ADD Then
	    Begin
	    SYM = .L2;
	    DELETETOMARK();
	    Return 1
	    End
	Else
	    Begin
	    SYM = TK_NEG;
	    DELETETOMARK();
	    Mark();
	    Push(.L2);
	    Return 2
	    End;
    Return 0
End;

Routine CKANDDOK(OP : Integer) =
Begin
    Local
	R		: Ref GT,
	O1		: Integer,
	O2		: Integer,
	L1		: Ref GT,
	L2		: Ref GT;
!
! CHECK-AND-DO-CONSTANT ARITHMETIC
!
    OP = .OP<lex_index>;
    If .OP Geq OP_CARRY Then
	Return 0;

! +X => X

    If .OP Eql OP_PLUS Then
	Begin
	If .num_error Eql 0 Then
	    Begin
	    DELETETOMARK();
	    SYM = .STK[.TOS+2]
	    End
	Else
	    SYM = MakeLit(0);
	Return 1
	End;
    If .OP Eql OP_ROT Then		! rot uses carry bit
	Return 0;
    If .OP Eql OP_DOT Then
	Return 0;
    If (Incr I From .LASTMARK+1 To .TOS Do
		Begin
		R = .STK[.I];
		If .R[gt_type] Neq T_LITERAL Then
		    Exitloop FALSE
		End
	) Then
	Begin
	L1 = .STK[.LASTMARK+1];
	L2 = .STK[.LASTMARK+2];
	O1 = .L1[gt_disp];
	O2 = .L2[gt_disp];
	DELETETOMARK();
	R = (Case .OP From 0 To 37 Of Set
		[Inrange,Outrange]:
		    0;
		[OP_ADD]:	.O1 +    .O2;
		[OP_DIV]:	.O1 /    .O2;
		[OP_SUB]:	.O1 -    .O2;
		[OP_MOD]:	.O1 Mod  .O2;
		[OP_MUL]:	.O1 *    .O2;
		[OP_SHIFT]:	.O1 ^    .O2;
		[OP_NEG]:	-.O1;
		[OP_NOT]:	Not .O1;
		[OP_GTR]:	.O1 Gtr  .O2;
		[OP_LEQ]:	.O1 Leq  .O2;
		[OP_LSS]:	.O1 Lss  .O2;
		[OP_GEQ]:	.O1 Geq  .O2;
		[OP_EQL]:	.O1 Eql  .O2;
		[OP_NEQ]:	.O1 Neq  .O2;
		[OP_EQV]:	.O1 Eqv  .O2;
		[OP_AND]:	.O1 And  .O2;
		[OP_OR]:	.O1 Or   .O2;
		[OP_XOR]:	.O1 Xor  .O2;
		[OP_GTRU]:	.O1 Gtru .O2;
		[OP_LEQU]:	.O1 Lequ .O2;
		[OP_LSSU]:	.O1 Lssu .O2;
		[OP_GEQU]:	.O1 Gequ .O2;
		[OP_EQLU]:	.O1 Eqlu .O2;
		[OP_NEQU]:	.O1 Nequ .O2;
		[OP_SWAB]:	.O1 ^8 + .O2<8,8>; 
		[OP_MAX]:	Max(.O1,.O2);
		[OP_MIN]:	Min(.O1,.O2);
		Tes);
	FreeNode(.L1);
	If .OP Neq OP_NEG And .OP Neq OP_NOT And .OP Neq OP_SWAB Then
	    FreeNode(.L2);
	SYM = MakeLit(.R);
	Return 1
	End
    Else
	Begin
	R = (Select .OP Of Set
	    [OP_ADD]:    SPLADDCASE(.OP);
	    [OP_SUB]:    SPLADDCASE(.OP);
	    [OP_MUL]:    SPLMULCASE(.OP);
	    [OP_DIV]:    SPLMULCASE(.OP);
	    [Otherwise]: 0
	    Tes);
	If .R Eql 0 Then
	    Return CKANDDONAME(.OP)
	Else
	    Return .R
	End
End;

! GRAPH TABLE NODE BUILDING ROUTINES
! ----------------------------------

!I. GENERAL:
!
!	1. THE FUNCTION OF THIS ROUTINE IS TO GENERATE
!	   A NEW GRAPH TABLE NODE, USING THE LEXEMES ABOVE
!	   '.LASTMARK' ON THE STACK.
!
!II. SPECIFIC:
!
!	1. *
!
!		A. IF ANY ERRORS, RETURN.
!
!		B. CALL 'GETSPACE' TO FIND SPACE IN THE GRAPH
!		   TABLE FOR A NODE OF LENGTH '.TOS-.LASTMARK
!		   +2' WORDS, IE THE NUMBER OF VALUES PUSHED
!		   ONTO THE STACK WHILE PROCESSING THE GIVEN
!		   NODE TYPE. 'GETSPACE' WILL RETURN THE
!		   INDEX OF THE FIRST WORD OF THE SPACE
!		   OBTAINED.
!
!		C. USE THIS VALUE OF THE INDEX (RETURNED BY
!		   'GETSPACE'), AND MAKE THE FIRST WORD OF
!		   THE GRAPH TABLE ENTRY HAVE THE VALUE OF THE
!		   NUMBER OF LEXEMES IN THAT ENTRY.
!
!		D. THE NEXT WORD HAS THE VALUE '.NODE', IE THE
!		   TYPE OF NODE THIS IS.
!
!		E. CALL 'POPTOMARK' TO ADD ALL THE VALUE
!		   LEXEMES FROM THE STACK INTO THE RESERVED
!		   SPACE FOR THE NODE AT '.L1'.
!
!		F. RETURN A GRAPH TABLE LEXEME WITH THE ADDRESS
!		   OF THE GRAPH TABLE NODE.

Global Routine MAKGT(L : Ref GT,OP : Integer) =
Begin
    Local
	L1		: Ref GT,
	SIZE		: Integer;

    OP = .OP<lex_index>;
    SIZE = SZ_NODE(.TOS-.LASTMARK);
    L1 = GETSPACE(.SIZE);
    L1[gt_argc] = .TOS-.LASTMARK;
    L1[gt_code] = .OP;
    L1[gt_type] = T_NODE;
    L1[gt_occ]  = 1;
    L1[gt_disp] = 0;
    L1[gt_abc]  = .ABCOUNT;
    If .swit_quick Then
	Begin
	L1[gt_csparent] = .L1;
	L1[gt_fparent]  = .L1
	End

! if this is a new formal parent

    Else If .L Eql 0 Then
	Begin
	L1[gt_depth]    = .LOOPDEPTH;
	L1[gt_xdepth]   = .LOOPDEPTH;
	L1[gt_v_fp]     = TRUE;
	L1[gt_v_csp]    = TRUE;
	L1[gt_fparent]  = .L1;
	L1[gt_csparent] = .L1;
	L1[gt_gthread]  = .GTHASH[.OP];
	GTHASH[.OP] = .L1
	End

! if this is not a formal parent but a CSE parent

    Else If .L Lss 0 Then
	Begin
	L = -.L;
	L1[gt_depth]    = .LOOPDEPTH;
	L1[gt_xdepth]   = .LOOPDEPTH;
	L1[gt_v_csp]    = TRUE;
	L1[gt_fparent]  = .L<0,32,1>;
	L1[gt_csparent] = .L1;
	L1[gt_fsthread] = .L[gt_fsthread];
	L[gt_fsthread]  = .L1
	End

! if this is a CSE usage

    Else
	Begin
	Local
	    LCS	: Ref GT,
	    LFP	: Ref GT;

	LCS = .L< 0,32,1>;
	LFP = .L<32,32,1>;
	L1[gt_depth]     = .LCS[gt_xdepth];
	L1[gt_fparent]   = .LFP;
	L1[gt_csparent]  = .LCS;
	L1[gt_csthread]  = .LCS[gt_csthread];
	LCS[gt_csthread] = .L1
	End;

! non-operators not available for CSE recognition

    If .OP Gtr MAXOPERATOR Then
	L1[gt_v_rm] = TRUE;
    L1[gt_crlevel] = .LEVEL;
    POPTOMARK(.L1);
    Return .L1
End;


! CALLED BY GENGT TO DECREASE THE OCCURRENCE
! COUNT ON THE SUBNODES OF CSNODE
!
! before a node is recognized as a CSE to another node, the
! children of the node were recognized as CSE's.  this routine
! decrements the CSE occurence count of those children.

Global Routine DECROCC(CSNODE : Ref GT) : Novalue =
Begin
    Local
	L1		: Ref GT;

    While .CSNODE[gt_v_bogus] Do
	Begin
	CSNODE = .CSNODE[gt_csthread];
	If .CSNODE Eql 0 Then
	    Return
	End;
    Decr I From .CSNODE[gt_argc]-1 To 0 Do
	Begin
	L1 = .CSNODE[gt_argv(.I)];
	If .L1[gt_type] Eql T_NODE Then
	    Begin
	    L1 = .L1[gt_csparent];
	    If .L1[gt_occ] Gtr 0 Then
		L1[gt_occ] = .L1[gt_occ]-1
	    End
	End
End;

!
! DETACHES A NODE FROM GT HASH TABLE;
! WORKS ONLY IF THE NODE CAN HAVE NO CSPARENTS, CSE USES.
!
!	called by SPOINTER when two consecutive '<>'
!	operators are used.
!
!	called by BINDBIND and CHECKONELOCAL to remove useless
!	'<>' operators.
!
!	called by SCREATE to chuck extra nodes created during
!	parsing.

Global Routine PDETACH(NODE : Ref GT) : Novalue =
Begin
    Local
	L		: Ref GT,
	M		: Ref GT;

    If .swit_quick Then
	Return;
    L = M = .GTHASH[.NODE[gt_code]];
    If .L Eql .NODE Then
	Begin		! SPECIAL CASE - NODE IS TOP OF GTHREAD CHAIN
	If .NODE[gt_fsthread] Eqla 0 Then
	    Begin
	    GTHASH[.NODE[gt_code]] = .NODE[gt_gthread];
	    Return
	    End;
	L = GTHASH[.NODE[gt_code]] = .NODE[gt_fsthread];
	L[gt_gthread] = .NODE[gt_gthread];
	Until (M = .M[gt_fsthread]) Eqla 0 Do
	    M[gt_fparent] = .L;
	Return
	End;
    While TRUE Do		! FIRST LOOK DOWN L'S FSTHREAD,
	Begin			! THEN TRY NEXT NODE ON GTHREAD CHAIN
	If .M[gt_fsthread] Eqla 0 Then
	    Begin
	    M = .L[gt_gthread];
	    If .M Eql .NODE Then
		Begin
		If .NODE[gt_fsthread] Eqla 0 Then
		    Begin
		    L[gt_gthread] = .NODE[gt_gthread];
		    Return
		    End;
		L[gt_gthread] = .NODE[gt_fsthread];
		L = .L[gt_gthread];
		L[gt_gthread] = .NODE[gt_gthread];
		Until (M = .M[gt_fsthread]) Eqla 0 Do
		    M[gt_fparent] = .L;
		Return
		End;
	    L = .M
	    End
	Else
	    Begin
	    If .M[gt_fsthread] Eqla .NODE Then
		Begin
		M[gt_fsthread] = .NODE[gt_fsthread];
		Return
		End;
	    M = .M[gt_fsthread]
	    End
	End
End;

! FAKE A CSE
!
!	called by STRUFTOLEX for structure arguments which
!	are nodes.  for structure expansions, there is an
!	implied BIND for each argument.
!
!	called by BINDBIND for BIND symbols bound to an expression.

Global Routine FAKECSE(NODE : Ref GT) =
Begin
    Local
	X		: Ref GT,
	CPNODE		: Ref GT;

    If .NOTREE Then
	Return MakeLit(0);

! find the parent and bump the number of occurences it has.
! it is possible for the occurence count to be zero.  the
! routine DC() decrements the occurence count on structure
! arguments.

    CPNODE = .NODE[gt_csparent];
    CPNODE[gt_occ] = .CPNODE[gt_occ] + 1;

! if this is the first occurence then just return the node
!
! Q: if the occurence count is one then isn't node and cpnode
!    the same?

    If .CPNODE[gt_occ] Eql 1 Then
	Return .NODE;

! create a new bogus node

    X = GETSPACE(SZ_NODE(0));
    MOVECORE(.NODE,.X,SZ_NODE(0));
    X[gt_code] = OP_FAKE_CSE;
    X[gt_argc] = 0;
    CPNODE[gt_v_dont_unlink] = TRUE;	! NOT NECESSARY, BUT SAVES TIME IN UNDOCSE.

! add it to the CSE thread of the node.
!
! Q: does it make any difference whether it is placed at
!    the beginning or the end of the list?

    X[gt_csthread] = .CPNODE[gt_csthread];
    CPNODE[gt_csthread] = .X;
    X[gt_crlevel] = .CPNODE[gt_crlevel];

! Q: what is special about a fake-parm?

    If .CPNODE[gt_code] Eql OP_FPARM Then
	X[gt_fparent] = .CPNODE
    Else
	X[gt_fparent] = .CPNODE[gt_fparent];
    Return .X
End;

! binds BIND symbols, if present.

Global Routine BINDBIND(LEX : Ref GT) =
Begin
    Local
	P		: Ref GT;

    If .LEX[gt_type] Eql T_VARIABLE And .LEX[st_code] Eql S_BIND Then
	Begin
	P = .LEX;
	LEX = .Block[.LEX[gt_disp],st_bind_data];
	FreeNode(.p);
	If .LEX[gt_type] Eql T_NODE Then
	    LEX = FAKECSE(.LEX);
	If .LEX[gt_type] Eql T_SYMBOL Then
	    LEX = MakeVar(.LEX)
	End;
    Return .LEX
End;

! called by WHICHBIND in DECLAR when a bind expression is found which
! requires code to be generated.

Global Routine DYNBIND : Novalue =
Begin
    Mark();
    Push(.SYM);
    SYM = GENGT(TK_FPARM);
    Push(.SYM);
    SYM[gt_v_rm] = FALSE
End;

Routine CHECKONELOCAL(I : Integer) : Novalue =
Begin
    Local
	NODE		: Ref GT,
	LEX		: Ref GT,
	L		: Ref GT;

    NODE = .STK[.I];

! if taking the value of a pointer then only allow <0,8> and <0,16>
! and chuck the pointer.
!
! Q: what is wrong with E<8,8>?  should it not be changed to (E+1)?

    If .NODE[gt_type] Eql T_NODE And .NODE[gt_code] Eql OP_POINTER Then
	Begin
	LEX = .NODE[gt_arg1];
	L = .NODE[gt_arg3];
	If .NODE[gt_arg2] Neq MakeLit(0) Or .L[gt_disp] Mod 8 Neq 0 Then
	    WARNEM(0,B11$_ILLEGAL_POINTER);
	PDETACH(.L);
	RELEASESPACE(.NODE,SZ_NODE(3));
	STK[.I] = .LEX;
	CHECKONELOCAL(.I);
	Return
	End;

! we are only interested in register and local symbols from here on

    If .NODE[gt_type] Neq T_VARIABLE Then
	Return;

! if trying to take the address of a register

    If .NODE[st_code] Eql S_REGISTER Then
	Begin
	WARNEM(0,B11$_NON_ADDRESSABLE,.NODE);
	STK[.I] = MakeLit(0);
	Return
	End;

! if taking the address of a local, force the local to be a stacklocal

    If .NODE[st_code] Neq S_LOCAL Then
	Return;
    NODE = .NODE[gt_disp];
    If .NODE[gt_reg] Lssu 8 Then
	Return;
    NODE = .NODE[gt_reg];
    NODE[tn_request] = BIND_STATIC;		! static local
    NODE[tn_lon_lu]  = ETERNITY - 1;		! from here to eternity
    NODE[tn_fon_lu]  = ETERNITY - 1
End;

! check arguments for bad accesses by value

Routine CHECKLOCALS(L : Integer) : Novalue =
Begin
    Selectone .L Of Set

! for '.' and '<>', the LHS is an address and so we don't check it

	[TK_DOT,TK_LANGLE,TK_MOVP]:
	    0;

! for '=', the LHS is an address but we check the RHS otherwise

	[TK_STORE]:
	    CHECKONELOCAL(.LASTMARK+2);

! for INCR and DECR, the first argument is the loop variable which we don't check

	[TK_INCR,TK_DECR]:
	    Decr I From .TOS To .LASTMARK+2 Do
		CHECKONELOCAL(.I);

! for all other operations, all arguments are values and are checked

	[Otherwise]:
	    Decr I From .TOS To .LASTMARK+1 Do
		CHECKONELOCAL(.I);
    Tes
End;

! SEARCHES TREE FOR FORMALLY IDENTICAL PARENT OF OPERATOR-OPERAND(S)
! SUBTREE.  RETURNS INDEX OF PARENT IF IT SUCCEEDS, -1 OTHERWISE.
!
! notes:
!	see page 27 of "The Design of an Optimizing Compiler".

Routine FPARSEARCH(LEX : Ref GT) =
Begin
    Local
	FPARINDEX	: Integer,
	P		: Ref GT,
	Q		: Ref GT,
	L		: Ref GT,
	M		: Ref GT,
	SIZE		: Integer;

! search the GTHASH chain for a matching formal parent

    SIZE = .TOS - .LASTMARK - 1;
    FPARINDEX = 0;
    M = .GTHASH[.LEX<lex_index>];
    While .M Neqa 0 Do
	Begin
	L = NONBOGUS(.M);

! if the same number of arguments...

	If .SIZE + 1 Eql .L[gt_argc] Then

! match all the arguments

	    FPARINDEX = (
		Decr J From .SIZE To 0 Do
		    Begin
		    P = .STK[.LASTMARK+.J+1];
		    Q = .L[gt_argv(.J)];

! if the arguments are the same type

		    If .P[gt_type] Neq .Q[gt_type] Then
			Exitloop 0;

! if both nodes, they are equivalent if they both have the same
! formal parent

		    Selectone .p[gt_type] Of Set
			[T_NIL]:
			    0;
			[T_LITERAL]:
			    If .p[gt_disp] Neq .q[gt_disp] Then
				Exitloop 0;

			[T_VARIABLE]:
			    If .p[gt_disp] Neq .q[gt_disp] Then
				Exitloop 0;

			[T_NODE]:
			    If .P[gt_fparent] Neqa .Q[gt_fparent] Then
				Exitloop 0
		    Tes
		    End
		);
	If .FPARINDEX Lss 0 Then
	    Return .M;
	M = .M[gt_gthread]
	End;
    Return 0
End;

! SEARCHES TREE FOR POTENTIAL C-S-E GIVEN IT HAS FOUND FORMAL PARENT
! (VIA FPARSEARCH).  IT RETURNS VALUES AS FOLLOWS:
!	NO FORMAL PARENT:	0
!	NOT C-S-E:		-(FORMAL-PARENT-INDEX)
!	C-S-E:			FORMAL-PARENT-INDEX,,C-S-E-INDEX

Routine GTSEARCH(LEX : Ref GT) =
Begin
    Local
	L		: Ref GT,
	F		: Integer,
	FPARINDEX	: Integer,
	CSINDEX		: Ref GT;

! if quick, there are no CSE's

    If .swit_quick Then
	Return 0;

! search for a formal parent

    FPARINDEX = L = FPARSEARCH(.LEX);
    If .FPARINDEX Eqla 0 Then
	Return 0;

! non-operators never are CSE's

    If .LEX<lex_index> Gtr MAXOPERATOR Then
	Return -.FPARINDEX;

! search for a CSE parent which has not been purged and not created
! below the floor

    F = .FLOOR[stk_data];
    CSINDEX = (
	Do
	    Begin
	    If Not .L[gt_v_purge] And Not .L[gt_v_rm] And
		    .L[gt_crlevel] Geq .F Then
		Exitloop .L
	    End
	While (L = .L[gt_fsthread]) Neqa 0
	);

! if no CSE parent found

    If .CSINDEX Lss 0 Then
	Return -.FPARINDEX;

! if a bogus node was recognized as a CSE then convert its potential
! CSE's to real CSE's

    If .CSINDEX[gt_v_bogus] And .CSINDEX[gt_occ] Eql 0 Then
	BINDPCSTHREAD(.CSINDEX);
    Return (.FPARINDEX^32) Or .CSINDEX
End;

!
! GENERATE A GT-LEXEME FOR THE LEXEMES AT THE TOP
! OF 'STK'. THIS MAY INVOLVE EITHER RE-RECOGNITION
! OF AN EXISTING NODE OR GENERATION OF A NEW ONE.
!
Global Routine GENGT(LEX : Integer) =
Begin
    Local
	NEW		: Ref GT,
	L		: Ref GT,
	L1		: Ref GT;

! if in an error condition, generation is turned off.  all items on the
! stack before the error are in limbo and are not recovered.

    If .num_error Neq 0 Then
	Return MakeLit(0);

! if code generation is disabled, discard the arguments and return a literal 0

    If .NOTREE Then
	Begin
	DELETETOMARK();
	Return MakeLit(0)
	End;

! bind all the arguments

    Incr I From .LASTMARK+1 To .TOS Do
	STK[.I] = BINDBIND(.STK[.I]);

! check for constant expressions and special cases (e.g. X+0)

    Case CKANDDOK(.LEX) From 0 To 2 Of Set
	[0]:
	    0;
	[1]:
	    Return(.SYM);
	[2]:
	    LEX = .SYM
    Tes;

! make sure the arguments are ok

    CHECKLOCALS(.LEX);

! create the new node entry and enter it into the chains

    L = GTSEARCH(.LEX);
    NEW = MAKGT(.L,.LEX);

! if slow then note '.' references and '=' deposits

    If Not .swit_quick Then
	If .LEX Eql TK_DOT Then
	    Begin
	    L1 = .NEW[gt_arg1];

! check whether L1 is a symbol which may not be a CSE. it may not be
! a CSE if it is a symbol with a size other than a word or one of
! the special symbols SP, PC, or R0

	    If .L1[gt_type] Eql T_VARIABLE Then
		Begin
		If .L1[gt_len] Neq 16 Then
		    NEW[gt_v_rm] = TRUE;
		If .L1 Eql .VVREG Or .L1 Eql .SPREG Or .L1 Eql .PCREG Then
		    NEW[gt_v_rm] = TRUE
		End;
	    ENTVUSELST(.L1,.NEW)
	    End
	Else If .LEX Eql TK_STORE Then
	    Begin
	    L1 = .NEW[gt_arg1];
	    MRKDOTNODES(.L1);
	    ENTVCHGLST(.L1,.NEW)
	    End;

! try to add this node to the prolog

    GENPRLG(.NEW);

! if this is a CSE parent then note that it must generate code
! for itself and any CSE children

    If .L Leq 0 Then
	NEW[gt_v_mustgencode] = TRUE
    Else

! otherwise this is a CSE use and so give all occurences to the
! CSE parent

	Begin
	L = .L<0,32,1>;
	DECROCC(.L);
	L1 = .L[gt_csparent];
	L1[gt_occ] = .L1[gt_occ] + 1
	End;
    Return .NEW
End;

! create a literal node

Global Routine MakeLit(n : Integer) =
Begin
    Local
	p		: Ref GT;

    p = GETSPACE(SZ_NODE(0));
    p[gt_type]      = T_LITERAL;
    p[gt_disp]      = .n;
    p[gt_fparent]   = .p;
    p[gt_csparent]  = .p;
    p[gt_len]       = 16;
    p[gt_mode]      = IMMEDIATE;
    p[gt_reg]       = PC;
    p[rw_immediate] = TRUE;
    p[rw_literal]   = TRUE;
    p[gt_v_fp]      = TRUE;
    p[gt_v_csp]     = TRUE;
    Return .p
End;

! create a variable node

Global Routine MakeVar(s : Ref ST) =
Begin
    Local
	p		: Ref GT;

    p = GETSPACE(SZ_NODE(0));
    p[gt_type]      = T_VARIABLE;
    p[gt_code]      = .s[st_code];
    p[gt_disp]      = .s;
    p[gt_fparent]   = .p;
    p[gt_csparent]  = .p;
    p[gt_pos]       = .s[gt_pos];
    p[gt_len]       = .s[gt_len];
    p[gt_mode]      = .s[gt_mode];
    p[gt_reg]       = .s[gt_reg];
    p[gt_v_fp]      = TRUE;
    p[gt_v_csp]     = TRUE;
    Return .p
End;

End
Eludom