Google
 

Trailing-Edge - PDP-10 Archives - bb-m836c-bm_tops20_v6_1_tools - tools/blis10/ar2n.bli
There are 18 other files named ar2n.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:	H2ARIT.BLI
!DATE:		10 JANUARY 74	MGM/FLD/KR


!  REVISION HISTORY :
!  12-30-77 ROUTINE GPTR IS MODIFIED TO CHECK P,S,X FIELDS
!	    IN OR OUTOFF RANGE. IT GIVES WARNING IF THE VALUES ARE
!	    OUTOFF RANGE AND LSS ZERO.
!
!  10-19-77  ROUTINE GMOD IS MODIFIED TO FIX A BUG RELATED TO MOD FUNCTION.
!            MODFLAG IS A FLAG TO IDENTIFY THIS AND IS RESET IN DUMPREG.
!
!   5-9-77   COMPILER LOST TRACK OF REGISTERS WHEN ANDCAM OR IORM
!            IS ONE OF THE INSTRUCTIONS.IT USES OLD VALUE.
!            ROUTINE GSTO IS MODIFIED TO TAKE CARE OF THE PROBLEM.
!
%3.41%	GLOBAL BIND H2ARV=5;	!MODULE VERSION NUMBER



!			GENERAL DOCUMENTATION FOR ARITH.BLI
!	
!		THIS MODULE CONCERNS ITSELF WITH GENERATING CODE FOR
!	THE BINARY AND UNARY OPERATORS. ONE CAN DIVIDE THE ACTIVITIES OF EACH
!	OF THE OPERATOR ROUTINES INTO THREE CASES:
!		(1)	CONSTANT ARITHMETIC
!				THE ARITHMETIC OPERATORS (AND LOGICAL TOO)
!			WHEN PASSED COMPILE-TIME LITERAL LEXEMES DO THE
!			OPERATION AND RETURN THE LITERAL LEXEME OF THE
!			RESULT.
!	
!		(2)	DELAYING (AND SPECIAL CASES)
!				THE PREMIER EXAMPLE OF DELAYING IS EXEMPLIFIED BY
!			THE ADD-SUBTRACT ROUTINE (GAS).  HERE THE OPERATOR
!			ROUTINES ALWAYS ATTEMPT TO AVOID PRODUCING CODE IF THEY
!			CAN INDICATE THE RESULT OF THEIR EXECUTION IN THE LEXEME.
!			E.G. GNEG AND GNOT SIMPLY SET THE NEG OR NOT BITS
!			IN THE LEXEME WHEN POSSIBLE
!	
!		(3)	ACTUALLY PRODUCE CODE
!				ONCE THE OPERATOR DECIDES TO ACTUALLY PRODUCE
!			CODE IT THEN INSPECTS ITS OPERANDS TO SEE IF EITHER
!			FURNISHES AN ACCUMULATOR WHICH CAN BE USED TO PERFORM
!			THE OPERATION.









EXTERNAL MODFLAG;
FORWARD EXCHANGE,FLOATB,GFADR;
FORWARD GADD,GAND,GANL,GAS,GAT,GBREL,GDIV,GDIVMOD,GDOT,GEQL,GEQV;
FORWARD GGEQ,GGTR,GLEQ,GLOG,GLSH,GLSS,GMOD,GMUL,GNEG,GNEQ,GNOT,GOR;
FORWARD GPTR,GREL,GSUB,GXOR,LOG2,PASH,SMLFLP,SMLFLV;
GLOBAL ROUTINE GPTR(Y,P,S,X,I)=
  !CALLED FOR EXPRESSIONS  OF THE FORM Y<P,S,X,I>.
  ! A)	EVALUATES P,S,I,X IF LITERAL
  ! B)	ATTEMPTS TO DELAY CODE BY BUILDING A LEXEME.  SEE IF STATEMENT
  !	BEGINNING AT %[B]% BELOW.
  ! C)	FAILING THIS IT WILL GENERATE CODE TO BUILD THE POINTER IN A
  !	REGISTER.

  BEGIN
    LOCAL	R,	! ADDRESS OF REG. USED TO CALC POINTER (IF NEC.)
		P2,	! VALUE OF LITERAL P
		S2,	! VALUE OF LITERAL S
		X2,	! VALUE OF LITERAL X
		I2,	! VALUE OF LITERAL I
		SUMVAL;	! P2+S2+X2+I2
    LOCAL 	TEMP;		! 12-30-77 TEMPORARY VARIABLE
! CHECK FOR 0>P>36 , 0>S>36 , 0>X>15 , 0>I>1
	MACRO VALVALID(VAL1,VAL2)=
			((VAL1 LSS 0) OR ((VAL1 AND #777777) GTR VAL2))
			$;
    REGISTER R1;
    MACRO	P1=R1<0,1>$,	! LITERAL P
		S1=R1<1,1>$,	! LITERAL S
		X1=R1<2,1>$,	! LITERAL X
		I1=R1<3,1>$;	! LITERAL I

    PCIVR(.Y,0);
    IF (.Y AND (NEGM OR NOTM OR COPM)) NEQ 0 THEN
      RETURN GPTR(GLAR(.Y),.P,.S,.X,.I);

%3.10%   R1_0;  IF PTRTYPP(.Y) THEN Y_MLEXFRPTRTYP(.Y);
    PCIVR(.P,.S);PCIVR(.X,.I);
    P2_IF LITP(.P) THEN (P1_1; 
			 TEMP=LITV(.P); IF VALVALID(.TEMP,36) THEN WARNEM(.NSYM,#767);  %12-30-77%
			 .TEMP AND #77   
			);		%12-30-77%
    S2_IF LITP(.S) THEN (S1_1; 
			% 12-30-77 THE FOLLOWING LINES ARE ADDED %
			 TEMP=LITV(.S); IF VALVALID(.TEMP,36) THEN
			    WARNEM(.NSYM,#767);
			 .TEMP AND #77
			);
    X2_IF LITP(.X) THEN (X1_1; 
			% 12-30-77 THE FOLLOWING LINES ARE ADDED %
			 TEMP=LITV(.X); IF VALVALID(.TEMP,15) THEN
			    WARNEM(.NSYM,#767);
			 .TEMP AND #17
			);
    I2_IF LITP(.I) THEN (I1_1;
		% THE FOLLOWING LINES ARE ADDED ON 12-30-77 %
			 TEMP=LITV(.I); IF VALVALID(.TEMP,1) THEN
				WARNEM(.NSYM,#767);
			 .TEMP AND 1
			);

    BEGIN BIND DUMMY=0;	%[B]%
      IF .P1 THEN
	IF .S1 THEN
	IF .X1 THEN
	IF .I1 THEN
	  BEGIN
	    !V2G- IF ALL PARAMETERS ARE CONSTANTS, WE SIMPLY GENERATE A LITERAL
	    IF LITP(.Y) THEN			!V2G-
	      RETURN				!V2G-
		LITLEXEME((LITV(.Y) AND RIGHTM) OR .P2^30 OR .S2^24 OR .I2^22 OR .X2^18);	!V2G-
	    IF .I2 NEQ 0 OR .X2 NEQ 0 THEN
	      BEGIN
		IF .Y<RTEF> NEQ 0 THEN EXITBLOCK;
		IF .Y<LSF> THEN IF STACKVARP(.Y<STEF>) THEN EXITBLOCK;
		RETURN MPTRTYP(.P2^12 OR .S2^6 OR .I2^4 OR .X2,.Y)
	      END;
	    IF .Y<RTEF> NEQ 0 THEN
	      IF (.P2^6 OR .S2) EQL 0 THEN EXITBLOCK;
	    RETURN LEXNPSD(.Y,.P2,.S2,0)
	  END;
    END;

    Y_GMA(.Y OR DOTM);
    SUMVAL_.P2+.S2+.X2+.I2;
    IF .Y<INDXF> EQL 0 THEN
      IF .SUMVAL EQL 0 THEN CODE(HRRZI,R_ACQUIRE(-1,1),.Y,1)
      ELSE CODE(MOVE,R_ACQUIRE(-1,1),COPTR(.P2,.S2,.Y OR .I2^22 OR .X2^18),1)
    ELSE
      BEGIN
	IF USABLEINDEXREG(.Y) AND .SUMVAL NEQ 0 THEN
	  R_.Y<INDXF>
        ELSE CODE(HRRZI,R_ACQUIRE(-1,1),.Y,1);
	IF .SUMVAL NEQ 0 THEN
	  CODE(HRLI,.R,.P2^12 OR .S2^6 OR .I2^4 OR .X2,1)
      END;
    IF NOT .P1 THEN CODEDPB(.P,30,6,.R);
    IF NOT .S1 THEN CODEDPB(.S,24,6,.R);
    IF NOT .I1 THEN CODEDPB(.I,22,1,.R);
    IF NOT .X1 THEN CODEDPB(.X,18,4,.R);
    LEXRA(.R)
  END;
GLOBAL ROUTINE GDOT(Y)=
  ! CALLED TO EXECUTE THE DOT OPERATOR

  BEGIN LOCAL R;
    PCIVR(.Y,0);
    IF .Y<NGNTF> NEQ 0 THEN
      RETURN (SESTOG_.SESTOG OR 2;GDOT(GLTR(.Y)));

    IF .Y<COPF> THEN
      BEGIN
	CODE(LDB,R_ACQUIRE(-1,1),MEMORYA(.Y),0);
	SESTOG_.SESTOG OR 2;
	RETURN LEXRA(.R)
      END;

    IF .Y<POSNSIZEF> EQL 36 THEN
      RETURN GAT(.Y AND NOT(POSNSIZEM));

    IF LITP(.Y) THEN
      BEGIN REGISTER P,S,I,X;
        Y_LITV(.Y);
        P_.Y<30,6>;
        S_.Y<24,6>;
        I_.Y<22,1>;
        X_.Y<18,4>;
        Y_.Y AND IXYM;
        IF .I THEN
          BEGIN
	    SESTOG_.SESTOG OR 2;
	    R_ACQUIRE(-1,1);
	    IF (.P^6 OR .S) EQL 36 THEN
	      CODE(MOVE,.R,.Y,1)
            ELSE CODE(LDB,.R,COPTR(.P,.S,.Y),1);
            RETURN LEXRA(.R)
          END;

	IF .X NEQ 0 THEN
	  RETURN LEXNPSD(LITLEXEME(.Y AND RIGHTM) OR LEXRA(.X),
			 .P,.S,1);

	!V2G- WE CAN'T USE REG 0 IN THE REG FIELD OF A LEXEME BECAUSE WE
	!V2G- CAN'T DELAY GETTING ITS CONTENTS BECAUSE IT CAN'T BE USED
	!V2G- LATER AS AN INDEX REGISTER. THEREFORE, WE TREAT
	!V2G- 0 AS A REGULAR MACHINE ADDRESS, NOT A GENERAL PURPOSE REGISTER.
        IF .Y LEQ 15 THEN IF .Y GTR 0 THEN IF .P EQL 0 THEN IF .S EQL 36 THEN	!V2G-
          RETURN LEXRA(.Y);

        RETURN LEXNPSD(LITLEXEME(.Y),.P,.S,1)

      END;

    IF PTRTYPP(.Y) THEN
      BEGIN REGISTER ADDRESS,OPCODE,RGHTHALF,PS;
	IF NORELOCPTRYPP(.Y<STEF>) THEN
	  RETURN GDOT(LITLEXEME(VALPTRTYP(.Y<STEF>)));
	PS_PSPTRTYP(.Y<STEF>);
	IF NOT INDPTRTYPP(.Y<STEF>) THEN IF .PS NEQ 0 THEN
	  RETURN MLEXFRPTRTYP(.Y) OR DOTM;
	ADDRESS_
	  IF .PS EQL 36 THEN
	    (OPCODE_MOVE; MADDRFRPTRTYP(.Y) OR INDIRM) ELSE
	  IF (RGHTHALF_.PS EQL 18) OR .PS EQL #2222 THEN
	    (OPCODE_CASE .RGHTHALF OF SET HLRZ; HRRZ TES;
	     MADDRFRPTRTYP(.Y) OR INDIRM)
	  ELSE (OPCODE_LDB; MCOPTRFRPTRTYP(.Y));
	CODE(.OPCODE,R_ACQUIRE(-1,1),.ADDRESS,1);
	SESTOG_.SESTOG OR 2;
	RETURN LEXRA(.R)
      END;

    .Y OR DOTM

  END;
GLOBAL ROUTINE GAT(X)=
  ! CALLED TO EXECUTE THE @ OPERATOR

  BEGIN
    PCIVR(.X,0);
    IF .X<NGNTF> NEQ 0 THEN
      RETURN (SESTOG_.SESTOG OR 2;GAT(GLTR(.X)));

    IF .X<COPF> THEN
      RETURN (SESTOG_.SESTOG OR 2;GAT(GLAR(.X)));

    IF LITP(.X) THEN
      BEGIN
	IF (X_LITV(.X) AND RIGHTM) LEQ 15 THEN IF .X GTR 0 THEN	!V2G- SEE NOTE FOR V2G IN GDOT ABOVE.
	  RETURN LEXRA(.X);

	RETURN LEXNPSD(LITLEXEME(.X),0,36,1)

      END;

    IF PTRTYPP(.X) THEN
      BEGIN
	IF NORELOCPTRTYPP(.X<STEF>) THEN
	  RETURN GAT(LITLEXEME(VALPTRTYP(.X<STEF>) AND RIGHTM));

	RETURN LEXNPSD(LSSTEFPTRTYP(.X<STEF>),0,36,1)

      END;

    LEXNPSD(.X,0,36,1)

  END;
GLOBAL ROUTINE GSLSH(Y)=

  ! CALLED TO EXECUTE THE \ OPERATOR

  BEGIN LOCAL REG,ADDRESS,V;
    REGISTER YSAV;

    YSAV_.Y;
    Y_.Y AND NOT (POSNSIZEM);
    IF NOT PTRTYPP(.YSAV) THEN IF ZERONAMP(.Y) THEN RETURN .Y OR (DOTM OR ZERO36);

    PCIVR(.Y,0);

    IF LITP(.Y) THEN
      BEGIN
      IF (V_LITV(.Y) AND IXYM) LEQ #17777777 THEN RETURN GDOT(LITLEXEME(36^24 OR .V));

      ADDRESS_.V;

      END ELSE

    IF REGP(.Y) THEN
      ADDRESS_REGAR(.Y) ELSE

    IF PTRTYPP(.YSAV) THEN
      BEGIN
	IF NORELOCPTRTYPP(.Y<STEF>) THEN
	  RETURN GSLSH(LITLEXEME(VALPTRTYP(.Y<STEF>) AND IXYM));

	IF NOT INDPTRTYPP(.Y<STEF>) THEN
	  RETURN LEXNPSD(MLEXFRPTRTYP(.Y<STEF>),0,36,1);

	ADDRESS_MADDRFRPTRTYP(.Y)

      END ELSE

    IF .Y<RTEF> EQL 0 OR (.Y<COPF> AND (.YSAV<POSNSIZEF> EQL 36)) THEN
      ADDRESS_MEMORYA(.YSAV OR DOTM)

    ELSE
      RETURN
	BEGIN
	  Y_
	    IF .YSAV<COPF> THEN GLAR(.YSAV)
	    ELSE .YSAV;
	  IF REGP(.Y) THEN GSLSH(.Y)
	  ELSE GSLSH(LEXRA(GPA(.Y AND NOT(POSNSIZEM)) AND RIGHTM))
	END;

    SESTOG_.SESTOG OR 2;
    CODE(MOVE,REG_ACQUIRE(-1,1),.ADDRESS OR INDIRM,0);
    LEXRA(.REG)
  END;
GLOBAL ROUTINE GSTO(X,Y)=

  %GENERATE CODE FOR X_Y.  BECAUSE OF ITS SIZE THIS ROUTINE IS COMMENTED INLINE%

  BEGIN
    PCIVR(.X,.Y);
    IF .X<NGNTF> NEQ 0 THEN RETURN GSTO(GLTR(.X),.Y);

    BEGIN
%4.03%	EXTERNAL TRYVREG;
      LOCAL
	VALUE,	! VALUE OF LITERAL Y
	XVALUE, ! VALUE OF LITERAL X
	OLDY,	! COPY OF INPUT VALUE OF Y
	NEGNOTMASK,	! MASK TO OR INTO LEXEME TO CODEN AND TO BE RET'D
	OPCODE, ! INST. GENERATED FOR STORE
	REG,	! REG USED IN STORE INST.
	ADDRESS,! ADDRESS USED IN STORE INST.
	RETLEX, ! LEXEME RETURNED REP. VALUE OF STORE
	PSFIELD,! .X<POSNSIZEF>
	INDIRMASK,	! POTENTIAL IND. BIT FROM PTRTYP
	CHOICE; ! TEMP TO HOLD INDEX INTO TABLE OF HALFWD INSTRS.

      REGISTER R;

      MACRO
	LITY=R<0,1>$,	! LITERAL Y
	LITX=R<1,1>$,	! LITERAL X
	NEGBIT=R<2,1>$, ! .Y<NEGF>
	NOTBIT=R<3,1>$, ! .Y<NOTF>
	RTUPDATE=R<4,1>$,	! BOOLEAN: SETCAB CLOBBERED REG
	RGHTHALF=R<5,1>$,	! BOOLEAN: RIGHT HALF OF HALFWD
	YLHALF=R<6,1>$;		! BOOLEAN: L.H. OF Y TO HALFWD REG

      IF (LITY_LITP(.Y)) THEN VALUE_LITV(.Y);
      OLDY_.Y;
      NEGBIT_.Y<NEGF>;
      NOTBIT_.Y<NOTF>;
      Y_.Y AND NOT (NEGM OR NOTM);
      NEGNOTMASK_0;
      RTUPDATE_0;
      INDIRMASK_0;

      IF PTRTYPP(.X) THEN
        BEGIN LOCAL PTR;
	  PTR_VALPTRTYP(.X<STEF>);
	  IF .PTR<24,12> NEQ 36 THEN
	    IF .PTR<24,12> NEQ 18 THEN
	    IF .PTR<24,12> NEQ #2222 THEN
	    IF .PTR<22,1> OR .PTR<24,12> EQL 0 THEN EXITBLOCK X<POSNSIZEF>_0;
	  X_MLEXFRPTRTYP(.X);
	  INDIRMASK_.PTR AND INDIRM
        END;


      OPCODE_
	IF .LITY THEN
	  IF .VALUE EQL 0 THEN SETZM ELSE
	  IF .VALUE EQL -1 THEN SETOM
	  ELSE MOVEM ELSE
	IF .NEGBIT THEN (NEGNOTMASK_NEGM; MOVNM) ELSE
	IF .NOTBIT THEN
	  IF DCRP(.Y) THEN (NEGNOTMASK_NOTM; SETCAM)
	  ELSE (RTUPDATE_1;SETCAB)
	ELSE MOVEM;

      RETLEX_.Y;

	!!! HANDLES ".(EXP)_" AND ".NAME_"

      IF .X<COPF> THEN
	BEGIN
	  IF (.X AND (POSNSIZEM)) NEQ ZERO36 THEN RETURN GSTO(GLTR(.X),.OLDY);
	  CODE(DPB,REGAK(RETLEX_GLAR(.OLDY)),GMA(.X),5);
	  RETURN(.RETLEX)
	END;

      IF (LITX_LITP(.X AND (LSSTEM OR RTEM))) THEN XVALUE_LITV(.X);
      PSFIELD_IF .LITX AND (.X<POSNSIZEF> EQL 0) THEN .XVALUE<24,12> ELSE .X<POSNSIZEF>;

	!!! HANDLES CASE WHERE LEFT SIDE IS REGISTER OR SUBFIELD OF REG

      IF (IF .LITX THEN (.XVALUE AND IXYM) LEQ 15) AND .PSFIELD NEQ 0
	AND .INDIRMASK EQL 0 THEN
	BEGIN
	  REG_.XVALUE<RIGHTF>;
	  SETFUNBIT(.X);
	  SESTOG_.SESTOG OR 1;

	!!! IF IT IS FULLWORD STORE THEN GLR(GLPR) WILL PROVIDE

	  IF .PSFIELD EQL 0 OR .PSFIELD EQL 36 THEN
	    RETURN (RETLEX_GLR(.OLDY,2,.REG); RMREFREG(.REG); .RETLEX);

	!!! HANDLE HALF WORD LOAD OF REGISTER

	  IF (RGHTHALF_.PSFIELD EQL 18) OR .PSFIELD EQL #2222 THEN
	    BEGIN
	      OPCODE_
		IF .LITY THEN
		  BEGIN
		    ADDRESS_.VALUE<RIGHTF>;
		    IF .RGHTHALF THEN HRRI ELSE HRLI
		  END ELSE
		IF ZERONAMP(.Y) THEN
		  BEGIN
		    ADDRESS_GMA(.Y OR DOTM);
		    IF .RGHTHALF THEN HRRI ELSE HRLI
		  END
		ELSE
		  BEGIN
		    YLHALF_0;
		    ADDRESS_
!%3.16%		      IF READY(.OLDY) THEN
!%3.16%			GMA(RETLEX_.OLDY) ELSE
		      IF (.OLDY<POSNSIZEF> EQL 18 OR
			(YLHALF_.OLDY<POSNSIZEF> EQL #2222)) AND
			READY((.OLDY AND NOT POSNSIZEM) OR ZERO36) THEN
			  GMA(RETLEX_.OLDY)
		      ELSE REGAK(RETLEX_GLTR(.OLDY));
		    CASE 2*.RGHTHALF+.YLHALF OF SET HRL; HLL; HRR; HLR TES
		  END;
	      CODEN(.OPCODE,.REG,.ADDRESS,2,
	           LEXNPSD(.REG,.PSFIELD<6,6>,.PSFIELD<0,6>,1));
	      RETURN(.RETLEX)
	    END;

	!!! HANDLES STORE OF CONSTANT INTO SUBF. USING TRO, TRZ, ETC

	  IF .LITY THEN IF .PSFIELD<6,6> LEQ 35 THEN
	    IF (.PSFIELD<6,6> + .PSFIELD<0,6>) LEQ 36 THEN
	    BEGIN
	      LOCAL BITMASK[2],PSMASK;
		! BITMASK[0]=MASK OF BITS TO BE ZEROED
		! BITMASK[1]=MASKOF BITS TO BE SET ("ONED")
		! PSMASK=MASK OF SUBFIELD

	      PSMASK_((1^.PSFIELD<0,6>)-1)^.PSFIELD<6,6>;
	      BITMASK[1]_(.VALUE^.PSFIELD<6,6>) AND .PSMASK;
	      BITMASK[0]_(NOT .BITMASK[1]) AND .PSMASK;
	      INCR I FROM 0 TO 1 DO
		BEGIN
		  OPCODE_
		    IF .BITMASK[.I] NEQ 0 THEN
		      IF .BITMASK[.I]<LEFTF> EQL 0 THEN
			BEGIN
			  ADDRESS_.BITMASK[.I];
			  CASE .I OF SET TRZ;TRO TES
			END ELSE
		      IF .BITMASK[.I]<RIGHTF> EQL 0 THEN
			BEGIN
			  ADDRESS_.BITMASK[.I]<LEFTF>;
			  CASE .I OF SET TLZ;TLO TES
			END
		      ELSE
			BEGIN
			  ADDRESS_LITA(LITLEXEME(.BITMASK[.I]));
			  CASE .I OF SET TDZ; TDO TES
			END
		    ELSE EXITCOMP;
		  CODEN(.OPCODE,.REG,.ADDRESS,2,
			LEXNPSD(.REG,.PSFIELD<6,6>,.PSFIELD<0,6>,1))
		END;
	      RETURN(.RETLEX)
	    END;

	!!! HANDLES STORE OF NON-CONSTANT INTO SUBFIELD

	  CODEN(DPB,REGAK(RETLEX_GLAR(.OLDY)),GPA(X_.X OR DOTM),2,.X);
	  RETURN(.RETLEX)

	END;

	!!! FULLWORD STORE TO MEMORY

      IF .PSFIELD EQL 36 THEN
	BEGIN
	  ADDRESS_(IF .LITX THEN .XVALUE AND IXYM ELSE GMA(X_.X OR DOTM)) OR .INDIRMASK;
	  REG_IF .LITY AND (.OPCODE NEQ MOVEM) THEN 0 ELSE REGAK(RETLEX_GLAR(.Y));
	  IF .RTUPDATE THEN IF .ART[.REG]<DTF> THEN CLEARONE(RT[.ART[.REG]<RTEF>]);
	  CODEN(.OPCODE,.REG,.ADDRESS,2,
	        (X<POSNSIZEF>_36; .X OR .NEGNOTMASK));
	  RETURN(.RETLEX OR .NEGNOTMASK)
	END;

	!!! HALFWORD STORE TO MEMORY

      IF (RGHTHALF_.PSFIELD EQL 18) OR .PSFIELD EQL #2222 THEN
	BEGIN
	  OPCODE_
	    CASE CHOICE_
		  (IF .LITY THEN
		     4-2*(.VALUE<RIGHTF> EQL 0)-4*(.VALUE<RIGHTF> EQL 1^18-1)
		   ELSE 4) +.RGHTHALF OF
		SET HRROS;HLLOS;HRRZS;HLLZS;HRLM;HRRM TES;
	  REG_IF .CHOICE LEQ 3 THEN 0 ELSE REGAK(RETLEX_GLAR(.OLDY));
	  ADDRESS_(IF .LITX THEN .XVALUE AND IXYM ELSE GMA(X_.X OR DOTM)) OR .INDIRMASK;
	  CODEN(.OPCODE,.REG,.ADDRESS,2,.X);
	  RETURN(.RETLEX)
	END;

	BEGIN	LOCAL PTPOS,PTSIZ,PTMASK,PTVAL;
		LABEL STOPT;
		PSFIELD_.X<POSNSIZEF>;
		PTPOS_.PSFIELD^(-6);
		PTSIZ_.PSFIELD AND #77;
		IF .LITY AND (.PTSIZ LEQ 18) AND (.PTPOS LEQ 35) AND (.PTPOS+.PTSIZ LEQ 36)
		THEN
	STOPT:	BEGIN
		  IF .PTPOS LSS 18 AND .PTPOS+.PTSIZ GTR 18
		  THEN LEAVE STOPT
		  ELSE
		  BEGIN
			PTMASK_1^.PTSIZ-1;
			IF ((.PTMASK AND .VALUE) NEQ .PTMASK AND (.PTMASK AND .VALUE) NEQ 0) OR .PTSIZ EQL 0
				THEN LEAVE STOPT;
			PTVAL_.VALUE;
			VALUE_.PTMASK^.PTPOS;
			IF TRYVREG()
			THEN REG_.VREG
			ELSE IF (REG_.ART[18]<FCHAINF>) GEQ 16
				THEN
				IF (REG_.ART[19]<FCHAINF>) GEQ 17
					THEN LEAVE STOPT;
%4.12%
%4.12%			%(***** CHECK TO MAKE SURE THE REG ISNT AN
				OPTIMIZED SUBEXPRESSION		*****)%
%4.12%
%4.12%			INCR I FROM RT[5] TO RT[31]	DO
%4.12%				IF .(.I)<32,4> EQL .REG THEN LEAVE STOPT;
%4.12%
			IF .VALUE EQL 0 THEN (OPCODE_SETZ; ADDRESS_0) ELSE
			IF .VALUE EQL -1 THEN (OPCODE_SETO; ADDRESS_0) ELSE
			IF SMNEGLITVP(.VALUE) THEN (OPCODE_MOVNI; ADDRESS_-.VALUE) ELSE
			IF SMPOSLITVP(.VALUE) THEN (OPCODE_MOVEI; ADDRESS_.VALUE) ELSE
			IF .VALUE<RIGHTF> EQL 0 THEN (OPCODE_HRLZI;ADDRESS_.VALUE<LEFTF>) ELSE
			IF .VALUE<RIGHTF> EQL 1^18-1 THEN (OPCODE_HRLOI; ADDRESS_.VALUE<LEFTF>)
			ELSE (OPCODE_MOVE; ADDRESS_LITA(.X));
			CODEN(.OPCODE,.REG,.ADDRESS,0,0);
			OPCODE_IF (.PTMASK AND .PTVAL) EQL 0
				THEN ANDCAM
				ELSE IORM;
			ADDRESS_(IF .LITX THEN .XVALUE AND IXYM
					ELSE GMA(X_.X OR DOTM)) OR .INDIRMASK;
			CODEN(.OPCODE,.REG,.ADDRESS,2,.X);  %4-7-77%
			RETURN .OLDY
		  END;
		END;
	END;
	!!! PARTIAL WORD STORE TO MEMORY

      CODEN(DPB,REGAK(RETLEX_GLAR(.OLDY)),GPA(X_.X OR DOTM),2,.X);
      .RETLEX

    END

  END;
GLOBAL ROUTINE CODEDPB(L,P,S,Y)=
!  (CODE DEPOSIT BYTE)
!  GENERATE CODE TO DEPOSIT THE
!  EXPRESSION L INTO Y<P,S> WHERE P,S ARE CONSTANT.
  CODE(DPB,RAGLAR(.L),COPTR(.P,.S,.Y),0);




ROUTINE GARLS(X,Y,F) =
  !GENERATE CODE FOR ASH WHEN .F EQL 0
  !GENERATE CODE FOR ROT WHEN .F EQL 1
  !GENERATE CODE FOR LSH WHEN .F EQL 2 OR
  !GENERATE CODE FOR X^Y
  ! SPECIAL CASES FOR X^Y:
  !	Y=0 --> X
  !	Y>35,Y<-35  --> 0
  !	Y=18,Y=-18  --> HALF-WORD INST.
  !

  BEGIN LOCAL OPCODE,ADDRESS; REGISTER L,V;
    PCIVR(.X,.Y);
    IF LITP(.Y) THEN
      BEGIN
      V_LITV(.Y);
      IF LITP(.X) THEN
	RETURN LITLEXEME(
	    BEGIN
	    MACHOP ASH = #240, ROT = #241, LSH = #242;
	    L_LITV(.X);
	    CASE .F OF
		SET
		ASH(L,.V);
		ROT(L,.V);
		LSH(L,.V) 
		TES
	    END		);

      IF .V EQL 0 THEN RETURN .X;

      IF .F EQL 2 THEN
      BEGIN
      IF .V GEQ 36 OR .V LEQ -36 THEN RETURN (DULEX(.X); ZERO);

      IF (L_.V EQL 18) OR .V EQL -18 THEN
	BEGIN
	  OPCODE_CASE .L OF SET HLRZ; HRLZ TES;
	  IF ZERONAMP(.X) THEN
	    (OPCODE_.OPCODE+1;
	     ADDRESS_GMA(.X OR DOTM))
	  ELSE ADDRESS_MEMORYA(.X);
	  CODE(.OPCODE,Y_ACQUIRE(-1,1),.ADDRESS,1);
	  RETURN LEXRA(.Y)
	END;
      END;

      CODE(ASH+.F,REGAK(X_GLTR(.X)),.V AND RIGHTM,1);
      RETURN .X
      END;
    CODE(ASH+.F,REGAK(X_GLTR(.X)),MADRIR(GLAR(.Y),0),1);
    .X
  END;


GLOBAL ROUTINE GASH(X,Y) = GARLS(.X,.Y,0);

GLOBAL ROUTINE GROT(X,Y) = GARLS(.X,.Y,1);

GLOBAL ROUTINE GLSH(X,Y) = GARLS(.X,.Y,2);
ROUTINE SHOULDEXCH(X,Y)=
  ! MAKES DECISION WHETHER THE LEXEMES X AND Y SHOULD BE INTERCHANGED
  BEGIN
    IF .RT[.X<RTEF>]<ARTEF> EQL .OPTTOREGADDR THEN RETURN 0;
    IF .RT[.Y<RTEF>]<ARTEF> EQL .OPTTOREGADDR THEN RETURN 1;
    IF .RT[.X<RTEF>]<ARTEF> EQL .VREG THEN RETURN 0;
    .RT[.Y<RTEF>]<ARTEF> EQL .VREG
  END;


GLOBAL ROUTINE GMUL(X,Y)=
  !GENERATE CODE FOR EXPRESSION X*Y
  ! SPECIAL CASES:
  !	Y=0 --> 0
  !	Y=1 --> X
  !	Y=-1 --> -X
  !	Y=POWER OF 2 --> ASH INST.

  BEGIN LOCAL TEMPX,TEMPY;
    PCIVR(.X,.Y);
    IF LITP(.X) THEN
      RETURN IF LITP(.Y) THEN LITLEXEME(LITV(.X)*LITV(.Y))
             ELSE GMUL(.Y,.X);

    IF LITP(.Y) THEN
      BEGIN LOCAL L,V;
        IF .Y EQL ZERO THEN RETURN (DULEX(.X);ZERO);

	V_LITV(.Y);
        IF .Y EQL ONE THEN RETURN .X;

        IF .V EQL -1 THEN RETURN GNEG(.X);

        IF (L_LOG2(.V)) NEQ 0 THEN         !Y IS A POWER OF 2
          BEGIN
            IF .L LSS 0 THEN (X_GNEG(.X);L_-.L);
            RETURN PASH(.X,.L)
          END;

        IF SMNEGLITVP(.V) THEN
          RETURN GMUL(GNEG(.X),LITLEXEME(-.V));

        IF SMPOSLITVP(.V) THEN
          RETURN (CODE(IMULI,REGAK(X_GOLTR(.X)),.V,1);.X);

        RETURN (CODE(IMUL,REGAK(X_GOLTR(.X)),LITA(.Y),1);.X)

      END;

    IF .X<NEGF> XOR .Y<NEGF> THEN
      RETURN GNEG(GMUL(.X AND NOT NEGM,.Y AND NOT NEGM));

    IF ZERONAMP(.X) THEN
      RETURN (CODE(IMULI,REGAK(Y_GLTR(.Y)),GMA(.X OR DOTM),1);.Y);

    IF ZERONAMP(.Y) THEN RETURN GMUL(.Y,.X);

    X_.X AND NOT NEGM; Y_.Y AND NOT NEGM;

    REGSEARCH(X,Y);
    IF (TEMPX_TVRP(.X)) AND (TEMPY_TVRP(.Y)) THEN
      IF SHOULDEXCH(.Y,.Y) THEN EXCHANGE(X,Y);
    IF .TEMPX THEN
      RETURN (CODE(IMUL,REGAK(X_GLTR(.X)),MEMORYA(.Y),1);.X);

    IF .TEMPY THEN RETURN GMUL(.Y,.X);

    IF TVMP(.X) THEN
      BEGIN
        Y_GLAR(.Y);
        IF DCRP(.Y) THEN
          RETURN (CODE(IMULM,REGAK(.Y),X_GLTM(.X),0);.X);

        RETURN GMUL(.Y,.X)

      END;

    IF TVMP(.Y) THEN RETURN GMUL(.Y,.X);

    IF READY(.X) THEN RETURN GMUL(GLTR(.Y),.X);

    GMUL(GLTR(.X),.Y)

  END;




GLOBAL ROUTINE LOG2(X)=
  %X MUST BE A CONSTANT. LOG2(X)=0 IF X IS NOT A POWER OF 2.
   OTHERWISE LOG2(X)=SGN(X)*CLOG2(ABS(X)).%
  BEGIN LOCAL LOG;
    IF (-.X AND .X) EQL ABS(.X) THEN
      BEGIN
	LOG_IF (.X AND NOT 1^35) NEQ 0 THEN 35-FIRSTONE(ABS(.X));
	IF .X LSS 0 THEN LOG_-.LOG
      END
    ELSE
      LOG_0;
    .LOG
  END;




ROUTINE PASH(X,Y)=
  %GENERATE CODE FOR ARITHMETIC SHIFT. Y IS AN 18 BIT CONSTANT%
  BEGIN
    CODE(ASH,REGAK(X_GLTR(.X)),.Y,1);
    .X
  END;


ROUTINE GDIVMOD(X,Y,F)=
  !GENERATE CODE FOR .X&.Y WHERE & IS CASE .F OF SET /;MOD TES
  ! SPECIAL CASES:
  !	Y=0 --> ERROR
  !	Y=1 --> X,0
  !	Y=-1 --> -X,0
  !	Y= POWER OF 2 ASH INST., CAN'T OPTOMIZE SINCE MOD HAS SIGN OF DIVIDEND

 !     ASH INST IS NOT USED BECAUSE FOR X LSS 0 AND Y= POWER OF 2
!      GIVES INCORRECT VALUE. USE IDIV... 12/28/76
  BEGIN LOCAL A,V,L,RTUPDATE;
    MACRO RESULT=CASE .F OF SET (RELREG(.A+1,1);.X);
                                (CLEARONE(RT[.ART[.A]<RTEF>]);
				 RELREG(.A,1);LEXRA(.A+1))TES$;
    PCIVR(.X,.Y);
    RTUPDATE_.F XOR 1;
    IF LITP(.Y) THEN
      BEGIN
      V_LITV(.Y);
      IF .V EQL 0 THEN
	RETURN (DULEX(.X); WARNEM(.NSYM,#201); LITLEXEME(1^35-1));

      IF LITP(.X) THEN
        BEGIN
          X_LITV(.X);
          RETURN LITLEXEME(CASE .F OF SET .X/.V;.X MOD .V TES)
        END;

      IF .V EQL ONE THEN
        RETURN CASE .F OF SET .X; (DULEX(.X);ZERO) TES;

      IF .V EQL -1 THEN
        RETURN CASE .F OF SET GNEG(.X); (DULEX(.X);ZERO) TES;

    %  12/29/76
      IF (L_LOG2(.V)) GTR 0 AND NOT .F THEN
	RETURN PASH(.X,(-.L) AND RIGHTM);

      IF (.L LSS 0) AND NOT .F THEN
	RETURN GNEG(PASH(.X,.L AND RIGHTM));

   %
      IF SMPOSLITVP(.V) THEN
        CODE(IDIVI,A_REGAK(X_GLTR2(.X)),.V,.RTUPDATE)

      ELSE CODE(IDIV,A_REGAK(X_GLTR2(.X)),LITA(.Y),.RTUPDATE)

      END ELSE
    IF ZERONAMP(.Y) THEN
      CODE(IDIVI,A_REGAK(X_GLTR2(.X)),GMA(.Y OR DOTM),.RTUPDATE) ELSE

    IF DCRP(.X) AND TVMP(.Y) AND NOT .F THEN
      (CODE(IDIVM,REGAK(X_GLAR(.X)),Y_GLTM(.Y),0);RETURN .Y)

    ELSE CODE(IDIV,A_REGAK(X_GLTR2(.X)),
               MEMORYA(.Y),.RTUPDATE);
    RESULT
  END;
GLOBAL ROUTINE GDIV(X,Y)=GDIVMOD(.X,.Y,0);



GLOBAL ROUTINE GMOD(X,Y)=
			 BEGIN
			 MODFLAG = 1;
			 GDIVMOD(.X,.Y,1)
			 END;




GLOBAL ROUTINE GADD(X,Y)=GAS(.X,.Y,0);



GLOBAL ROUTINE GSUB(X,Y)=GAS(.X,.Y,1);



GLOBAL ROUTINE GNEG(X)=
  ! CALLED TO EVALUATE UNARY MINUS. SPECIAL CASE: - NOT X --> X+1

  BEGIN
    PCIVR(.X,0);
    IF LITP(.X) THEN LITLEXEME(-LITV(.X)) ELSE
    IF .X<NOTF> THEN GADD(GYES(.X),ONE) ELSE
    .X XOR NEGM
  END;
ROUTINE GAS(X,Y,F)=
  !GENERATE CODE FOR X&Y WHERE & IS CASE F OF SET +;- TES.
  !	THIS IS UNDOUBTEDLY THE BEST (WORST?) CASE FOR SHOWING THE
  ! COMPLEXITY OF THE "POSTPONING" MECHANISMS.  IT WOULD BE FAIR TO SAY
  ! THAT THIS ROUTINE IS BIASED TOWARDS OPTIMIZING STRUCTURE ACCESSING,
  ! I.E. ADDITION BY INDEXING.  FOR EXAMPLE, WHEN PASSED THE OPERANDS
  ! FOR .A + 1, GAS LOADS .A INTO A REGISTER (SAY R) AND RETURNS A LEXEME
  ! OF THE FORM (.R+1) (I.E. RETF=R AND LSSTEF=1).  THE IDEA HERE IS THAT
  ! IF THE EXPRESSION .A + 1 HAS APPEARED IN THE CONTEXT "(.A+1)<0,36>_EXP"
  ! THEN THE ADDITION WOULD BE ACCOMPLISHED BY INDEXING IN THE INSTRUCTION:
  ! "MOVEM EXP,1(R)."
  !	THE SET OF SPECIAL CASES IS COMMENTED ON THE RIGHT SIDE OF
  ! THE CODE.  E.G. !(@R+N)+L IS TO BE INTERPRETED TO MEAN:
  !		X= LEXEME REP. REG + NAME
  !		Y= LITERAL L
  !		F= +.
  !	FOLLOWING THE SET OF SPECIAL CASES THE ROUTINE ATTEMPTS  TO
  ! HANDLE THE EIGHT CASSES THAT ARISE FROM F AND THE POSSIBILITY OF
  ! UNARY MINUS ON X OR Y OR BOTH.
  !	(1) X+Y		(2) X-Y
  !	(3) X+-Y	(4) X--Y
  !	(5) -X+Y	(6) -X--Y
  !	(7) -X+-Y	(8) -X-Y
  !	THERE IS A CODING TRICK TO SAVE ON THE SIZE OF GAS.  IN MANY
  ! CASES THE DECISION IS MADE TO RECUR ON GAS AFTER EXCHANGING X AND Y.
  ! THE TRICK CONSISTS OF EXITING THE INNER (LOGICALLY MAIN) BLOCK
  ! (VIA GASCOMMUTE) AND THERE RECALLING GAS (VIA COMMUTE).

  BEGIN !DUMMY BLOCK TO SAVE ON COMMUTATIVE CALLS
    MACRO COMMUTE=(GAS(IF .F THEN GNEG(.Y) ELSE .Y,.X AND NOT NEGM,.X<NEGF>))$;

  BEGIN
    MACRO GASCOMMUTE=EXITBLOCK$;
    ROUTINE RLITP(X)=((.X AND NOT RTESTEM) EQL 0 AND
                   (.X AND RTEM) NEQ 0);
    MACRO RLEX(X)=(X AND RTEM)$;
    MACRO NAMELEX(X)=((X AND LSSTEM) OR ZERO36)$;
    MACRO SLEX(X)=(X AND (LSSTEM OR POSNSIZEM))$;
    ROUTINE RNAMP(X)=
		IF .X<POSNSIZEF> EQL 0 THEN
		IF (.X AND RTEM) NEQ 0 THEN
		  NAMP((.X AND NOT RTEM) OR ZERO36);
    LOCAL
	YVALUE,	! VALUE OF LITERAL Y
	ABSY,	! GABS(.Y)
	ABSX;	! GABS(.X)

    BIND
	XREG=ABSX,	!  SAVE STACK SPACE
	YREG=ABSY;

    REGISTER R;

    MACRO
	TEMPX=R<0,1>$,	! X IS A TEMP REG
	TEMPY=R<1,1>$;  ! Y IS A TEMP REG

    REGISTER
	ADDPOSSIBLE;	! .F EQL SIGN(.Y)

    PCIVR(.X,.Y);
    ABSY_GABS(.Y); ABSX_GABS(.X);
    IF LITP(.Y) THEN
										!X-L
      BEGIN
      IF .F THEN RETURN GAS(.X,GNEG(.Y),0);
										!X+0
      IF .Y EQL ZERO THEN RETURN .X;
      IF LITP(.X) THEN
										!L+L
         RETURN LITLEXEME(LITV(.X)+LITV(.Y));
      IF RLITP(.ABSX) THEN
										!(@R+L)+L
	 RETURN GAS(SLEX(.X),.Y,.X<NEGF>) OR (.X AND (NEGM OR RTEM));
      IF NAMP(.X) THEN
										!N+L
         RETURN GANL(0,.X,.Y);
      IF RNAMP(.X) THEN
										!(@R+N)+L
         RETURN GANL(RLEX(.X),NAMELEX(.X),.Y);
										!X+L
      IF (IF ZERONAMP(.X) THEN
	    BEGIN
	      YVALUE_LITV(.Y);
	      (.YVALUE AND RIGHTM) EQL 0
		AND NOT STACKVARP(.X<STEF>)
	    END
	  ELSE 0) THEN
										!X<0,0>+L
	RETURN MPTRTYP(.YVALUE<LEFTF>,.X);
      RETURN GLTR(.X) OR .Y
      END;
    IF LITP(.X) THEN
										!L+Y
       GASCOMMUTE;
    IF ZERONAMP(.Y) THEN
										!X&Y<0,0>
      RETURN(
	CODE(CASE .F OF SET ADDI;SUBI TES, REGAK(X_GLTR(.X)), GMA(.Y OR DOTM),1);
	.X);
    IF ZERONAMP(.X) THEN GASCOMMUTE;
										!X<0,0>&Y
    ADDPOSSIBLE_.F EQL SIGN(.Y);
    IF NAMP(.ABSY) AND .ADDPOSSIBLE THEN
      BEGIN
      IF REGP(.X) THEN
										!@R+N
         RETURN .X OR (.ABSY AND LSSTEM);
      IF RLITP(.X) THEN
										!(@R+L)+N
         RETURN GANL(RLEX(.X),.ABSY,SLEX(.X));
										!X+N
      RETURN GLTR(.X) OR (.ABSY AND LSSTEM)
      END;
    IF NAMP(.ABSX) THEN
										!N&Y
       GASCOMMUTE;
    IF RNAMP(.ABSX) THEN
      BEGIN
      IF  (IF RLITP(.ABSY) THEN LITV(SLEX(.Y)) NEQ 0) AND .ADDPOSSIBLE THEN
										!(@R+N)+(@R'+L)
	BEGIN
	  IF TVRP(RLEX(.X)) THEN
	    (XREG_RLEX(.X);YREG_RLEX(.Y))
	  ELSE (XREG_RLEX(.Y);YREG_RLEX(.X));
	  RETURN GAS(GANL(.XREG,NAMELEX(.X),SLEX(.Y)),.YREG,0) XOR (.X AND NEGM)
	END;
										!(@R+N)&Y
      RETURN GAS(GAS(RLEX(.X),.Y,.F),(.X AND NOT RTEM) OR ZERO36,0);
      END;
    IF RNAMP(.ABSY) THEN
										!X&(@R+N)
      GASCOMMUTE;
    IF (IF RLITP(.ABSX) THEN LITV(SLEX(.ABSX)) NEQ 0) THEN
										!(@R+L)&Y
      BEGIN BIND X1=ABSX;
	X1_GAS(.X AND NOT LSSTEM,.Y,.F);
	IF .X<NEGF> AND .X1<NEGF> THEN
	  RETURN GNEG(GAS(SLEX(.X),GABS(.X1),0));
	RETURN GAS(IF .X<NEGF> THEN GNEG(SLEX(.X)) ELSE SLEX(.X),GABS(.X1),.X1<NEGF>)
      END;
    IF (IF RLITP(.ABSY) THEN LITV(SLEX(.ABSY)) NEQ 0) THEN
										!X&(@R+L)
      GASCOMMUTE;
    IF TVMP(.Y) AND DCRP(.X) THEN
										!D&M
      (CODE(IF .ADDPOSSIBLE THEN ADDM ELSE SUBM,
            REGAK(X_GLAR(.X)),GMA(Y_GLTM(.ABSY)),0);RETURN .Y);
    IF TVMP(.X) THEN
										!M&Y
       GASCOMMUTE;
    REGSEARCH(X,Y);
    ABSX_GABS(.X); ABSY_GABS(.Y);
    IF (TEMPX_TVRP(.ABSX)) AND (TEMPY_TVRP(.ABSY)) THEN
      BEGIN
        IF SHOULDEXCH(.X,.Y) THEN
	  GASCOMMUTE;
        IF SIGN(.X) THEN
	  BEGIN
          IF .ADDPOSSIBLE AND .RT[.X<RTEF>]<ARTEF> NEQ .VREG THEN
										!5,6
            GASCOMMUTE;
										!7,8
          RETURN GNEG(GAS(.ABSX,.ABSY,.ADDPOSSIBLE));
	  END;
        CODE(IF .ADDPOSSIBLE THEN ADD ELSE SUB,
              REGAK(X_GLTR(.X)),REGAR(GLTR(.ABSY)),1);
										!1-4
        RETURN .X
      END;
    IF .TEMPX THEN
      BEGIN
      IF SIGN(.X) THEN
										!5-8
        RETURN GNEG(GAS(.ABSX,.ABSY,.ADDPOSSIBLE));
      CODE(IF .ADDPOSSIBLE THEN ADD ELSE SUB,
            REGAK(X_GLTR(.X)),
										!1-4
            MEMORYA(.Y),1);
      RETURN .X
      END;
    IF .TEMPY THEN
       GASCOMMUTE;
    IF SIGN(.X) THEN
      BEGIN
      IF .ADDPOSSIBLE THEN
										!5-6
         GASCOMMUTE;
										!7-8
      X_GOLTR(.X);
      IF SIGN(.X) THEN
        RETURN GNEG(GAS(GABS(.X),.ABSY,0));
      RETURN GAS(.X,.ABSY,1)
      END;
										!1-4
    IF READY(.X) THEN
      BEGIN
      IF .ADDPOSSIBLE THEN RETURN GAS(GLTR(.ABSY),.X,0);
      IF READY(.ABSY) THEN RETURN GAS(GLTR(.X),.ABSY,1);
      RETURN GNEG(GAS(GLTR(.ABSY),.X,1))
      END;
    RETURN GAS(GLTR(.X),.ABSY,.F XOR SIGN(.Y))

    END; ! DUMMY END EXITED FOR COMMUTATIVE CALL

    COMMUTE

  END;
GLOBAL ROUTINE FALR(R,X)=
  ! (FORCE-ADD-LITERAL-REGISTER) R IS THE ADDRESS OF A REGISTER AND L
  ! IS THE LEXEME OF A LITERAL TO BE ADDED TO THAT REGISTER

  BEGIN REGISTER VALUE,OPCODE,ADDRESS;
    VALUE_LITV(.X<LSSTEF>);
    IF .VALUE EQL 0 THEN RETURN .R;
    OPCODE_
      IF .VALUE EQL 1 THEN (ADDRESS_0; AOJ) ELSE
      IF .VALUE EQL -1 THEN (ADDRESS_0; SOJ) ELSE
      IF SMPOSLITVP(.VALUE) THEN (ADDRESS_.VALUE; ADDI) ELSE
      IF SMNEGLITVP(.VALUE) THEN (ADDRESS_-.VALUE; SUBI)
      ELSE (ADDRESS_LITA(.X<LSSTEF>); ADD);
    CODE(.OPCODE,.R,.ADDRESS,1);
    .R
  END;
ROUTINE GANL(R,X,Y)=
  ! (GENERATE-ADD-NAME-LITERAL)
  ! PARAMETERS:
  !	R	LEXEME  OF REGISTER (OR ZERO IF NONE)
  !	X	LEXEME OF A NAME
  !	Y	LITERAL LEXEME
  !	THIS ROUTINE ATTEMPTS TO GENERATE A NEW NAME FROM THE EXPRESSION
  ! X+Y.  FAILING THIS IT GENERATES CODE TO  ADD THE TWO.
  !	"NEW" NAMES COME IN TWO VARIETIES:
  ! (1) COMPILE TIME NEW NAMES:
  !	ALL THE CASES (SEE %[C]%) EXCEPT EXTERNALS.  A NEW ENTRY IS
  ! CREATED ON THE GENSYMS LIST (SEE GENLOCAL IN H2REGIST) WITH THE SAME
  ! BLOCKLEVEL BUT OFFSET= OFFSET-OF-X + VALUE-OF-Y.
  ! (2) LOAD-TIME NEW NAMES:
  !	EXTERNALS AND EXPRESIONS ALREADY INVOLVING LOAD-TIME NEW NAMES.
  ! SYMBOL TABLE ENTRIES FOR THESE NEW NAMES ARE COMPOSED OF TWO-WORD CELLS
  ! SINGLY LINKED OFF A HASH TABLE (EXPHT).  THE "NAME" OF AN EXTERNAL
  ! EXPRESSION (2ND WORD OF ENTRY) IS COMPOSED OF TWO HALVES:
  ! LEFTHALF= ST. INDEX OF EXTERNAL VARIABLE, RIGHTHALF=18-BIT VALUE OF Y.
  ! THE UNIQUENESS OF THIS NAME IS INSURED BY THE FACT THAT THE EXTERNAL-TYPE
  ! ENTRIES ARE NEVER PURGED FROM THE SYMBOL TABLE BECAUSE THE LOADER MUST
  ! CHAIN REFERENCES AND OUTPUT THE NAMES.

  BEGIN LOCAL TYPE,YVALUE,HASHVALUE;
    TYPE_.ST[.X<STEF>,0]<TYPEF>;
    YVALUE_(IF .TYPE NEQ EXTRNT THEN .ST[.X<STEF>,1]<OFFSETF> ELSE 0);
    IF .YVALUE<17,1> EQL 1 THEN YVALUE_.YVALUE OR (#777777^18);  ! SIGN-EXTEND
    YVALUE_LITV(.Y)+.YVALUE;
%6(213) THE FOLLOWING LINE IS MODIFIED ON FEB-28-77 TO HANDLE
         X+1^17 AND GIVE ERROR FOR X+5^17 OR X+2^17    %
%3.41%    IF (ABS(.YVALUE) AND LEFTM) EQL 0 THEN
    IF (1^GLOBALT OR 1^OWNT OR 1^LOCALT OR 1^FORMALT OR 1^STFORMT	%[C]%
	OR 1^PLITT OR 1^GPLITT OR 1^EXTRNT OR 1^EXPRT)^(-.TYPE)  THEN
      BEGIN REGISTER LINK,STINDEX,NAME;
	MACRO EXPHASH(X)=((X) MOD EXPHTSIZE)$;
	YVALUE_.YVALUE<RIGHTF>;
	IF (1^EXTRNT OR 1^EXPRT)^(-.TYPE) THEN
	  BEGIN
	    NAME_(IF .TYPE EQL EXTRNT THEN .X<STEF>
		  ELSE .ST[.X<STEF>,1]<LEFTF>)^18 OR .YVALUE;
	    LINK_.EXPHT[HASHVALUE_EXPHASH(.NAME)];
		!!NOW COMES THE SEARCH-LOOP OF EXPRT SYMBOL
	    STINDEX_
	      WHILE .LINK NEQ 0 DO
		IF .ST[.LINK,1] EQL .NAME THEN EXITLOOP .LINK
		ELSE LINK_.ST[.LINK,0]<LINKF>;
	    IF .STINDEX LSS 0 THEN
	      BEGIN
		STINDEX_GETSPACE(1);
		LINK_.EXPHT[.HASHVALUE];
		EXPHT[.HASHVALUE]_.STINDEX;
		ST[.STINDEX,0]_.LINK;
		ST[.STINDEX,0]<TYPEF>_EXPRT;
		ST[.STINDEX,1]_.NAME
	      END
	  END
	ELSE
	  BEGIN
	    STINDEX_GETSPACE(1);
	    ST[.STINDEX,0]_.ST[.X<STEF>,0];
	    ST[.STINDEX,0]<BLF>_.BLOCKLEVEL;
	    ST[.STINDEX,0]<LINKF>_.GENSYMS;
	    ST[.STINDEX,1]_.YVALUE;
	    GENSYMS_.STINDEX
	  END;
	STINDEX_.STINDEX OR LSM;
	RETURN(IF .R NEQ 0 THEN .R OR .STINDEX
		ELSE .STINDEX OR ZERO36)
      END;  !!END OF BLOCK FOR OPTIMIZABLE EXPRESSIONS
    IF .R EQL 0 THEN RETURN GAS(GLTR(.X),.Y,0);
    IF TVRP(.R) THEN RETURN GAS(LEXRA(FALR(.RT[.R<RTEF>]<ARTEF>,.Y)),.X,0);
    GAS(.R,GAS(GLTR(.Y),.X,0),0)
  END;
ROUTINE GREL(X,Y,R)=
  %GENERATE CODE FOR .X&.Y WHERE & IS CASE .R-1 OF SET LSS;
   EQL;LEQ;;GEQ;NEQ;GTR;TES%
  ! THE MANIPULATION OF VTARGET (SEE TRYVREG IN H2REGIST) HERE IS INTENDED
  ! TO DELAY THE USE OF VREG UNTIL GBREL IS CALLED SO THAT
  ! THE RESULT REG WILL BE VREG.  E.G. .A LSS 0 WILL COMPILE TO:
  !	MOVEI $V,1
  !	SKIPL  R,A
  !	SETZ  $V,0
  ! INSTEAD OF
  !	MOVEI  R,1
  !	SKIPL $V,A
  !	SETZ   R,0

  BEGIN
    REGISTER SAVVTARGET;  ! ENTRY VALUE OF VTARGET

    LOCAL
	REVREL;		! X ".R" Y <--> -X ".REVREL" -Y
			! X ".R" Y <-->  Y ".REVREL"  X

    MACRO RESTOREVTARGET=VTARGET_.SAVVTARGET$;

    BEGIN
      MACRO COMMUTE=EXITBLOCK$;

    PCIVR(.X,.Y);
    SAVVTARGET_.VTARGET; VTARGET_-1;

    IF LITP(.X) AND LITP(.Y) THEN
      BEGIN
        X_LITV(.X); Y_LITV(.Y); RESTOREVTARGET;
        RETURN LITLEXEME(CASE .R-1 OF SET .X LSS .Y; .X EQL .Y; .X LEQ .Y;;
	                  .X GEQ .Y; .X NEQ .Y; .X GTR .Y TES)
      END;

    REVREL_(#16305270 AND (7^(3*.R)))^(-(3*.R));

    IF LITP(.Y) THEN COMMUTE;

    IF .X<NEGF> AND .Y<NEGF> THEN
      RETURN (RESTOREVTARGET; GREL(GABS(.X),GABS(.Y),.REVREL));

    IF .X<NEGF> THEN COMMUTE;

    IF LITP(.X) THEN
      BEGIN
	LOCAL	V,	! VALUE OF LITERAL Y
		EQ,	! BOOLEAN: R --> EQL
		REG,	! LEXEME OF REGISTER
		TESTMASK,	! MASK TO USE IN TEST INST.
		ABSY;	! GABS(.Y)

	MACRO DPWREGP(L)=
%3.7%			(IF NOT LITP(.L AND (RTEM OR LSSTEM)) THEN EXITCOMP 0;
%3.7%			 IF .L<COPF> EQL 0 THEN EXITCOMP 0;
%3.7%			 IF (LITV(.L<RIGHTF>) AND IXYM) GTR 15 THEN EXITCOMPOUND 0;
			 IF (.L<30,6> + .L<24,6>) GEQ 36 THEN EXITCOMPOUND 0;
			 IF .L<POSNSIZEF> EQL 0 THEN EXITCOMPOUND 0;
%3.7%			 REG_GAT(.L AND LSSTEM);
			 1)$,
		! DOTTED-PARTIAL-WORD-REGISTER PREDICATE

	      FWINREG(L)=((REG_MATCH((L AND NOT(POSNSIZEM)) OR ZERO36,1))
			    NEQ ((L AND NOT(POSNSIZEM)) OR ZERO36))$;
		! FULL-WORD-IN-REGISTER PREDICATE

	  ! THESE MACROS (IF TRUE) ALLOW  US TO BUILD INSTRUCTIONS OF THE
	  ! FORM:  TRNN R,MASK,  FOR TESTS OF SUBFIELDS AGAINST ZERO.

      V_LITV(.X); REGSEARCH(Y,0);
      IF .V EQL 0 THEN IF .Y<COPF> THEN IF FULLWORD(.Y) THEN IF READY(.Y) THEN
	BEGIN
	  REG_LEXRA(ACQUIRE(-1,1)); ENTER(.REG<RTEF>,.Y);
	  RETURN GBREL(.SAVVTARGET,SKIP+.REVREL,REGAR(.REG),GMA(.Y))
	END;

      IF .V EQL 0 THEN
	BEGIN
	  IF NOT (EQ_.R EQL 2) THEN IF NOT (.R EQL 6) THEN EXITCOMPOUND;
%3.7%	  IF NOT DPWREGP(Y) THEN IF NOT FWINREG(.Y) THEN EXITCOMPOUND;
	  TESTMASK_(1^.Y<SIZEF>-1)^.Y<POSNF>;
	  RETURN GBREL(.SAVVTARGET,
		        IF .TESTMASK<LEFTF> EQL 0 THEN
			  CASE .EQ OF SET TRNN;TRNE TES ELSE
		        IF .TESTMASK<RIGHTF> EQL 0 THEN
			  (TESTMASK_.TESTMASK^(-18);CASE .EQ OF SET TLNN; TLNE TES)
		        ELSE CASE .EQ OF SET TDNN;TDNE TES,
		        REGAR(.REG),
		        IF (.TESTMASK<LEFTF> * .TESTMASK<RIGHTF>) NEQ 0 THEN
			  LITA(LITLEXEME(.TESTMASK))
		        ELSE .TESTMASK)
	END;

      IF SMPOSLITVP(.V) THEN
	BEGIN
        IF .Y<NEGF> AND (NOT READY(ABSY_GABS(.Y))
          OR REGP(.ABSY)) THEN
          RETURN GBREL(.SAVVTARGET,CAM+.R,REGAR(GLAR(.ABSY)),LITA(LITLEXEME(-.V)));
        RETURN GBREL(.SAVVTARGET,CAI+.REVREL,REGAR(GLAR(.Y)),.V)
	END;

      RETURN GBREL(.SAVVTARGET,CAM+.REVREL,REGAR(GLAR(.Y)),LITA(.X))
      END;

    IF ZERONAMP(.Y) THEN
      RETURN GBREL(.SAVVTARGET,CAI+.R,REGAR(GLAR(.X)),GMA(.Y OR DOTM));

    IF ZERONAMP(.X) THEN COMMUTE;

    REGSEARCH(X,Y);
    IF TVRP(.X) THEN
      RETURN GBREL(.SAVVTARGET,CAM+.R,REGAR(GLTR(.X)),MEMORYA(.Y));

    IF TVRP(.Y) THEN COMMUTE;

    IF DCRP(.X) THEN
      RETURN GBREL(.SAVVTARGET,CAM+.R,REGAR(GLAR(.X)),MEMORYA(.Y));

    IF DCRP(.Y) THEN COMMUTE;

    IF READY(.X) THEN
      RETURN GBREL(.SAVVTARGET,CAM+.REVREL,REGAR(GLAR(.Y)),GMA(.X));


    RETURN GBREL(.SAVVTARGET,CAM+.R,REGAR(GLAR(.X)),MEMORYA(.Y))

    END;  ! COMMUTES EXIT THIS BLOCK

    RESTOREVTARGET;
    GREL(.Y,.X,.REVREL)
  END;
ROUTINE GBREL(SAVVTARGET,F,A,M)=
  %GENERATE CODE FOR RELATIONAL EXPRESSION BY BRACKETING CAM OR CAI
   INSTRUCTION BETWEEN MOVEI T,1 AND SETZ T,0 WHERE T IS A TEMPORARY
   REGISTER WHICH WILL CONTAIN THE RESULT.  THESE THREE INSTRUCTIONS
   ARE HUNG FROM A RELC HEADER IN PREPARATION FOR ROUTINE GCUJUMP.
   GBREL IS CALLED FROM GREL.%
  BEGIN
      REGISTER C,T;

    VTARGET_.SAVVTARGET;
    C_FOLLCPH(2,RELC,1);
    CT[.C,2]_T_GLTR(ONE);
    CT[.C,3]_CODE(.F,.A,.M,0);
    CODE(SETZ,REGAK(.T),0,1);
    FOLLCPH(0,CODEC,0);
    .T
  END;


GLOBAL ROUTINE GLSS(X,Y)=GREL(.X,.Y,1);



GLOBAL ROUTINE GEQL(X,Y)=GREL(.X,.Y,2);



GLOBAL ROUTINE GLEQ(X,Y)=GREL(.X,.Y,3);



GLOBAL ROUTINE GGEQ(X,Y)=GREL(.X,.Y,5);



GLOBAL ROUTINE GNEQ(X,Y)=GREL(.X,.Y,6);



GLOBAL ROUTINE GGTR(X,Y)=GREL(.X,.Y,7);




GLOBAL ROUTINE GAND(X,Y)=GLOG(.X,.Y,0);



GLOBAL ROUTINE GOR(X,Y)=GLOG(.X,.Y,1);



GLOBAL ROUTINE GXOR(X,Y)=GLOG(.X,.Y,2);


GLOBAL ROUTINE GEQV(X,Y)=GLOG(.X,.Y,3);
GLOBAL ROUTINE GNOT(X)=
  ! CALLED TO EXECUTE UNARY NOT.
  ! SPECIAL CASE :   NOT -X -->  X-1

  BEGIN
    PCIVR(.X,0);
    IF LITP(.X) THEN LITLEXEME(NOT LITV(.X)) ELSE
    IF SIGN(.X) THEN GSUB(GABS(.X),ONE) ELSE
    .X XOR NOTM
  END;




STRUCTURE LOG[F,A,M]=(.LOG+.F)<9*(2*.M+.A),9>;

BIND LOG LOGOP=PLIT(#440420410404,   !ANDCB  ANDCM  ANDCA  AND
                    #470464454434,   ! ORCB   ORCM   ORCA   OR
                    #430444444430,   !  XOR    EQV    EQV  XOR
                    #444430430444);  !  EQV    XOR    XOR  EQV
                                     ! ANDI=AND + 1 ETC.
                                     ! ANDM=AND + 2 ETC.
ROUTINE GLOG(X,Y,F)=
  !GENERATE CODE FOR LOGICAL EXPRESSION X&Y WHERE & IS
  !CASE F OF SET AND; OR; XOR; EQV TES
  ! ALWAYS ATTEMPT TO DO "NOTTING" OF ACC AND MEM VIA THE INSTRUCTION.
  ! SPECIAL CASES:
  !	Y=0 --> (0,X,X,NOT X)
  !	Y=-1 --> (X,-1,NOT X,X)
  !	Y=X --> (X,X,0,-1)
  !	Y=NOT X --> (0,-1,-1,0)

  BEGIN
    MACRO GLOGCOMMUTE=GLOG(.Y,.X,.F)$;
    LOCAL
	ACC,	! ADDRESS OF REGISTER
	COMPLEMENT,  ! USE COMPLEMENT OF OPERAND
	YVALUE,	! VALUE OF LITERAL Y
	L,	! LEFT HALF OF YVALUE
	XYES,	! GYES(.X)
	YYES,	! GYES(.Y)
	TEMPX,	! TVRP(.X)
	TEMPY;	! TVRP(.Y)

    PCIVR(.X,.Y);
    XYES_GYES(.X);  YYES_GYES(.Y);
    IF LITP(.Y) THEN
      BEGIN
      IF LITP(.X) THEN
        BEGIN
          X_LITV(.X);Y_LITV(.Y);
          RETURN LITLEXEME(CASE .F OF SET .X AND .Y;.X OR .Y;
                                   .X XOR .Y;.X EQV .Y TES)
        END;

      IF .Y EQL ZERO THEN
        RETURN CASE .F OF SET (DULEX(.X);ZERO);.X;.X;GNOT(.X) TES;

      IF (YVALUE_LITV(.Y)) EQL -1 THEN
        RETURN CASE .F OF SET .X;(DULEX(.X);LITLEXEME(-1));GNOT(.X);.X TES;

      IF (IF ZERONAMP(.X) THEN
	(CASE .F OF SET
	  (.YVALUE<RIGHTF> EQL 0) OR (.YVALUE<RIGHTF> EQL RIGHTM);
	  (.YVALUE AND RIGHTM) EQL 0 AND NOT STACKVARP(.X<STEF>);
	  0;
	  0 TES) ELSE 0) THEN
	RETURN(
	  IF .F EQL 0 THEN
	    IF .YVALUE<RIGHTF> EQL 0 THEN (DULEX(.X);ZERO)
	    ELSE .X
	  ELSE MPTRTYP(.YVALUE<LEFTF>,.X));

      COMPLEMENT_NO(.X);
      ACC_REGAK(X_GLTR(.XYES));
      L_.YVALUE^(-18);
      IF .L EQL 0 THEN CODE(.LOGOP[.F,.COMPLEMENT,0]+1,.ACC,.YVALUE,1) ELSE
      IF .L EQL RIGHTM THEN CODE(.LOGOP[.F,.COMPLEMENT,1]+1,.ACC,NOT .YVALUE,1) ELSE
      CODE(.LOGOP[.F,.COMPLEMENT,0],.ACC,LITA(.Y),1);
      RETURN .X

      END;
    IF LITP(.X) THEN RETURN GLOGCOMMUTE;

    IF ZERONAMP(.YYES) THEN
      RETURN (CODE(.LOGOP[.F,NO(.X),NO(.Y)]+1,
		     REGAK(X_GLTR(.XYES)),GMA(.YYES OR DOTM),1);.X);

    IF ZERONAMP(.XYES) THEN RETURN GLOGCOMMUTE;

    IF ((.X EQV .Y) AND NOT NOTM) EQL (NOT NOTM) THEN
      RETURN CASE 2*.F OR NO(.X) NEQ NO(.Y) OF
	        SET .X;(DULEX(.X);ZERO);
	            .X;(DULEX(.X);LITLEXEME(-1));
		    (DULEX(.X);ZERO); (DULEX(.X);LITLEXEME(-1));
		    (DULEX(.X);LITLEXEME(-1));(DULEX(.X);ZERO) TES;

    REGSEARCH(X,Y);
    XYES_GYES(.X); YYES_GYES(.Y);
    TEMPX_TVRP(.XYES);  TEMPY_TVRP(.YYES);
    IF .TEMPX AND .TEMPY THEN
      IF SHOULDEXCH(.X,.Y)  THEN (EXCHANGE(X,Y); EXCHANGE(XYES,YYES));

    IF .TEMPX THEN
      RETURN (CODE(.LOGOP[.F,NO(.X),NO(.Y)],REGAK(X_GLTR(.XYES)),MEMORYA(.YYES),1); .X);

    IF .TEMPY THEN RETURN GLOGCOMMUTE;

    IF TVMP(.X) AND DCRP(.YYES) THEN
      RETURN (CODE(.LOGOP[.F,NO(.Y),NO(.X)]+2,REGAR(GLAR(.YYES)),GMA(X_GLTM(.XYES)),0); .X);

    IF TVMP(.Y) AND DCRP(.YYES) THEN GLOGCOMMUTE;

    IF READY (.XYES) THEN
	RETURN GLOG(GLTR(.YYES) OR (.Y AND NOTM),.X,.F);

    GLOG(GLTR(.XYES) OR (.X AND NOTM),.Y,.F)
  END;
%FLOATING POINT OPERATORS FOR THE BLISS COMPILER.
 MAINLY THE FAULT OF R.F. BRENDER (DEC).

 THE FOLLOWING OPERATIONS ARE IMPLEMENTED:
   BINARY:
     FADR - FLOATING ADD AND ROUND
     FSBR - FLOATING SUBTRACT AND ROUND
     FMLR - FLOATING MULTIPLY AND ROUND
     FDVR - FLOATING DIVIDE AND ROUND
   UNARY:
     FNEG  - FLOATING NEGATION
     FLOAT - FLOAT AN INTEGER
     FIX   - FIX A FLOATING VALUE
%


ROUTINE GFADFML (OP,X,Y) =

%FLOATING ADDITION AND MULTIPLICATION
%

BEGIN LOCAL YP,XP; REGISTER T;
   T_.OP^(-1);
   XP_.X; YP_.Y;
   PCIVR(.XP,.YP);
   IF LITP(.XP) THEN
      IF LITP(.YP) THEN
         RETURN LITLEXEME(FLOATB(.OP,LITV(.XP),LITV(.YP)))
      ELSE EXCHANGE(XP,YP);

%HERE XP IS NOT A CONSTANT%
   IF LITP(.YP) THEN
      IF .YP EQL ZERO THEN RETURN CASE2(.T,.XP,(DULEX(.XP);ZERO)) ELSE
      IF SMLFLP(.YP) THEN
         (CODE(CASE2(.T,FADRRI,FMLRRI),REGAK(XP_GLTR(.XP)),
          SMLFLV(.YP),1);
          RETURN .XP)
      ELSE (CODE(CASE2(.T,FADRR,FMLRR),REGAK(XP_GLTR(.XP)),
            LITA(.YP),1);
            RETURN .XP);

%NEITHER XP NOR YP IS CONSTANT%

   REGSEARCH(XP,YP);
   IF TVRP(.YP) THEN
     IF NOT (TVRP(.XP) AND .RT[.XP<RTEF>]<ARTEF> EQL .OPTTOREGADDR) THEN
        EXCHANGE(XP,YP);
   IF TVRP(.XP) THEN
      (CODE(CASE2(.T,FADRR,FMLRR),REGAK(XP_GLTR(.XP)),
       MEMORYA(.YP),1);
       RETURN .XP);

   IF TVMP(.YP) THEN EXCHANGE(XP,YP);
   IF TVMP(.XP) THEN
      (YP_GLAR(.YP);
       IF DCRP(.YP) THEN
         (CODE(CASE2(.T,FADRR,FMLRR),REGAK(.YP),
          GLTM(.X),0);
          RETURN .XP AND NOT NGNTM)
       ELSE GFADR(.YP,.XP));

%ALL THE REST%

   CODE(CASE2(.T,FADRR,FMLRR),REGAK(XP_GLTR(.XP)),MEMORYA(.YP),1);
   .XP
END;


GLOBAL ROUTINE GFADR(X,Y) = GFADFML(0,.X,.Y);

GLOBAL ROUTINE GFMLR(X,Y) = GFADFML(2,.X,.Y);


ROUTINE GFSBFDV (OP,X,Y) =

%FLOATING SUBTRACT AND DIVIDE%

BEGIN
   LOCAL T,XP,YP;
   T_.OP^(-1);
   XP_.X;  YP_.Y;

   PCIVR(.XP,.YP);
   IF LITP(.XP) THEN
      IF LITP(.YP) THEN
         RETURN LITLEXEME(FLOATB(.OP,LITV(.XP),LITV(.YP)))
      ;
   ;
   IF LITP(.YP) THEN
     (CASE .T OF SET
         IF .YP EQL ZERO THEN RETURN .XP;
         BEGIN
            IF .YP EQL FLOATONE THEN RETURN .XP;
            IF .YP EQL ZERO THEN
               (WARNEM(.NSYM,#201);
                RETURN (DULEX(.XP);VERYBIG))
         END
      TES ;
      IF SMLFLP(.YP) THEN
        (CODE(CASE2(.T,FSBRRI,FDVRRI),REGAK(XP_GLTR(.XP)),
         SMLFLV(.YP),1);
         RETURN .XP)
         ELSE (CODE(CASE2(.T,FSBRR,FDVRR),REGAK(XP_GLTR(.XP)),
            LITA(.YP),1); RETURN .XP)
   );

% ALL THE REST%

   CODE(CASE2(.T,FSBRR,FDVRR),REGAK(XP_GLTR(.XP)),MEMORYA(.YP),1);
   .XP

END ;

GLOBAL ROUTINE GFSBR (X,Y) = GFSBFDV(1,.X,.Y);

GLOBAL ROUTINE GFDVR (X,Y) = GFSBFDV(3,.X,.Y);

%SERVICE ROUTINES FOR THE ABOVE%

ROUTINE EXCHANGE (A,B) =
%A AND B ARE CALLED BY REFERENCE.
 THEIR VALUES ARE EXCHANGED%
BEGIN LOCAL T;
   T_..A;
   .A_..B;
   .B_.T
END;

ROUTINE SMLFLP(X) =
%ASSUMMING X IS A LITERAL, SEE IF IT CAN BE
 REPRESENTED IN BUT 18 BITS%
   (LITV(.X) AND 1^18-1) EQL 0
;

ROUTINE SMLFLV (X) =
   LITV(.X)^(-18);



GLOBAL ROUTINE GFNEG (X) =

%FLOATING NEGATION%

   GFSBR(ZERO,.X);

GLOBAL ROUTINE GFIX (X) =

%  YES THIS IS DONE IN LINE!
   (MAYBE) SOMEDAY IT CAN BE MADE AN
   INTERNAL ROUTINE.
%

IF LITP(.X) THEN LITLEXEME(FIX LITV(.X)) ELSE

BEGIN LOCAL A,Y;

   CODE(MOVM,Y_ACQUIRE(-1,2),A_MEMORYA(.X),1);
   CODE(MULI,.Y,#400,1);
   CODE(EXCH,.Y,.Y+1,1);
   CODE(ASH,.Y,(.Y+1)^18 OR (-#243 AND 1^18-1),1);
   CODE(SKIPGE,0,.A,1);
   CODE(MOVNS,0,.Y,1);
   RELREG(.Y+1,1);
   LEXRA(.Y)

END;

GLOBAL ROUTINE GFLOAT (X) =
%FLOAT A FIXED NUMBER%

IF LITP(.X) THEN LITLEXEME(FLOAT LITV(.X)) ELSE

BEGIN LOCAL REG1,REG2;
  REG1_REGAK(X_GLTR2(.X));
  REG2_.REG1+1;
  CODE(IDIVI,.REG1,#400000,0);
  CODE(SKIPE,0,.REG1,0);
  CODE(TLC,.REG1,#254000,0);
  CODE(TLC,.REG2,#233000,0);
  CODE(FAD,.REG1,.REG2,1);
  RELREG(.REG2,1);
  .X
END;




GLOBAL ROUTINE FLOATB (OP,P1,P2) =

%NEEDED TO BOOTSTRAP THE FLOATING ROUTINES INTO THE
 BLISS COMPILER.%

BEGIN REGISTER R;

   MACHOP FFADR=#144, FFSBR=#154, FFMLR=#164, FFDVR=#174;

   R_.P1;
   CASE .OP OF SET
      FFADR(R,P2);
      FFSBR(R,P2);
      FFMLR(R,P2);
      FFDVR(R,P2) TES	!DO THE OPERATION
   ; .R
END %OF THE ROUTINE% ;
%%
%  ROUTINE GOTM CALLED TO GENERATE CODE FOR X_(NOT OR - OR EMPTY) .X OP Y.
%
%%

GLOBAL ROUTINE GOTM(Y,X,RESINREG,OPLEX)=
  ! GOTM ATTEMPTS TO OPTIMIZE TO-MEMORY TYPE INSTRUCTIONS.  CASES IT
  ! CANNOT OPTIMIZE SUCH AS X<3,4>_.X<3,4>+2, IT CALLS THE PROPER OPERATOR
  ! ROUTINE AND THE STORE ROUTINE.  IN THE CASE WHERE X IS A REGISTER, RATHER
  ! THAN DUPLICATE MUCH OF THE OPTIMIZATIONS IN THE PARTICULAR OPERATOR
  ! ROUTINE IT CALLS THE OPERATOR ROUTINE
  ! WITH LEXEMS FOR .X AND .Y AFTER SETTING THE GLOBAL VARIABLE
  ! OPTTOREGADDR TO THE ADDRESS OF X.  THE OPERATOR ROUTINES ARE
  ! GEARED TO LEAVING THE RESULT IN  THIS REGISTER.

  BEGIN LOCAL GTINDEX,REGLEX;

REGISTER R;
  MACRO
	LIT=R<0,1>$,	! LITERAL Y
	L0=R<1,1>$,	! Y=0
	L1=R<2,1>$,	! Y=1
	LM1=R<3,1>$,	! Y=-1
	L18=R<4,1>$,	! Y=18
	LM18=R<5,1>$,	! Y=-18
	NEGL=R<6,1>$,	! .X<NEGF>
	NEGR=R<7,1>$,	! .Y<NEGF>
	NOTL=R<8,1>$,	! .X<NOTF>
	NOTR=R<9,1>$,	! .Y<NOTF>
	UNOP=R<10,1>$,	! UNARY OPERATOR
	FLOP=R<11,1>$,	! FL. PT. OPERATOR
	NONEGNOTL=R<12,1>$,	! .X<NEGF>=.X<NOTF>=0
	NONEGNOTR=R<13,1>$,	! .Y<NEGF>=.Y<NOTF>=0
	FL1=R<14,1>$,	! Y=1.0
	FLM1=R<15,1>$,	! Y=-1.0
	OPTOREG=R<16,1>$,	! X IS A REGISTER
	LEFTSIDEREG=R<17,1>$;	! ADDR. OF REG X

  MACRO REG(X)=REGP(X AND NOT NGNTM)$;

  PCIVR(.X,.Y);
  R_0;
  GTINDEX_.RESINREG<LEFTF>;
  RESINREG<LEFTF>_0;
  IF .GTINDEX NEQ 0 THEN
    GT[.GTINDEX,0]<OCCF>_MAXER(.GT[.GTINDEX,0]<OCCF>-1,0);
  DULEX(.X);
  IF FULLWORD(.X) OR REG(.X) THEN
    BEGIN
      LOCAL
	LITVAL,	! VALUE OF LITERAL Y
	OPPTR,	! ADDRESS OF OPERATOR ROUTINE
	ACCUM,	! ACCUMULATOR FOR INST.
	OPCODE;	! FUNSTION FOR INSTRUCTION

      REGISTER RES;	! RESULT TO BE LEFT IN REGISTER

      FORWARD NOOP, ZEROP, ONESOP, CODEIT, GLOGIC, CODECY;

      ROUTINE NOOP(LEX)=
	! CALLED TO COMPLEMENT OR NEGATE X IF NECESSARY

        IF .NONEGNOTL 
          THEN .LEX
          ELSE
            (NONEGNOTL_1;
	     IF .OPTOREG THEN GLPR(.LEX,.RT[.LEX<RTEF>]<ARTEF>) ELSE
             CODECY(.LEX,(IF .NOTL THEN SETCMM+.RES ELSE MOVNS)));

      ROUTINE ZEROP(LEX)=
	! CALLED TO STORE ZERO INTO X

        (NONEGNOTL_1;
	 IF .OPTOREG THEN RETURN(GLPR(ZERO,.RT[.LEX<RTEF>]<ARTEF>); ZERO);
	 LEX_CODECY(.LEX,SETZM+.RES);
         IF .RES THEN DUN(.LEX<RTEF>); ZERO);

      ROUTINE ONESOP(LEX)=
	! CALLED TO STORE -1 INTO X

        (NONEGNOTL_1;
	 IF .OPTOREG THEN
	   RETURN(R_LITLEXEME(-1);
		  GLPR(.R,.RT[.LEX<RTEF>]<ARTEF>);
		  .R);
	 LEX_CODECY(.LEX,SETOM+.RES);
         IF .RES THEN DUN(.LEX<RTEF>); LITLEXEME(-1));

      ROUTINE CODEIT(NEWY, X, OPC)=
	! CALLED TO ACTUALLY PRODUCE CODE

        BEGIN
          LOCAL ACCUM, ADDRESS;
	  X_.X AND NOT NGNTM;
	  IF .OPTOREG THEN
	    BEGIN
	      ACCUM_.RT[.X<RTEF>]<ARTEF>;
	      RES_1;
	      OPC_.OPC-2;
	      ADDRESS_MEMORYA(.NEWY)
	    END
	  ELSE
	    BEGIN
	      ACCUM_REGAK(GLAR(.NEWY));
	      RES_(.RES OR .CODEPROP);
	      IF (.ART[.ACCUM]<RTEF> LSS 16
		   OR .RT[.ART[.ACCUM]<RTEF>]<USEF> GTR 1) THEN RES_0;
	      OPC_.OPC+.RES;
	      ADDRESS_MEMORYA(.X)
	    END;
	  CODEN(.OPC,.ACCUM,.ADDRESS,6+.RES,.X);
          IF .RES THEN LEXRA(.ACCUM) ELSE .X
        END;

      ROUTINE GLOGIC(CODE,X,Y)=
	! CALLED TO PRODUCE CODE FOR AND, OR, ETC.

        (CODEPROP_0;
	 IF .OPTOREG THEN EXCHANGE(NOTR,NOTL);
	 CODEIT(GYES(.Y), .X, .LOGOP[.CODE, .NOTR, .NOTL]+2));

      ROUTINE CODECY(X,OPC)=
	! CALLED  FOR CASES WITH CONSTANT Y

        BEGIN
          LOCAL ACCUM,SAVRES;
          IF NOT .NONEGNOTL THEN (SAVRES_.RES; RES_0; NOOP(.X); RES_.SAVRES);
          ACCUM_IF .RES THEN ACQUIRE(-1,1);
          CODEN(.OPC,.ACCUM,MEMORYA(X_.X AND NOT (NEGM OR NOTM)),
                6+.RES, .X);
          IF .ACCUM NEQ 0 THEN LEXRA(.ACCUM) ELSE .X
        END;

      RES_.RESINREG;
      LEFTSIDEREG_OPTOREG_REG(.X);
      OPPTR_(DISPAD(.OPLEX<ADDRESSF>))<0,0>;
      IF .X<NEGF> THEN NEGL_1 ELSE IF .X<NOTF> THEN NOTL_1
                                               ELSE NONEGNOTL_1;

      IF NOT (UNOP_.OPLEX<HUNARY>) THEN
        IF LITP(.Y)
          THEN
            (LITVAL_LITV(.Y);
             LIT_1;
             IF .LITVAL EQL 0 THEN L0_1 ELSE
             IF .LITVAL EQL 1 THEN L1_1 ELSE
             IF .LITVAL EQL 1.0 THEN FL1_1 ELSE
             IF .LITVAL EQL -1 THEN LM1_1 ELSE
             IF .LITVAL EQL -1.0 THEN FLM1_1 ELSE
             IF .LITVAL EQL 18 THEN L18_1 ELSE
             IF .LITVAL EQL -18 THEN LM18_1 )
          ELSE
            IF .Y<NEGF> THEN NEGR_1 ELSE
              IF .Y<NOTF> THEN NOTR_1 ELSE NONEGNOTR_1;
      IF NOT .LEFTSIDEREG THEN X<POSNSIZEF>_36 ELSE
	IF .X<DTF> THEN ERROR(.NDEL,#777);

      IF NOT .UNOP
        THEN

% SHIFTS %

          IF .OPPTR EQL GLSH<0,0>
            THEN
              (IF NOT .LIT THEN EXITBLOCK;
               IF .L0 THEN RETURN NOOP(.X);
               IF .LITVAL GEQ 36 THEN RETURN ZEROP(.X);
               IF .LITVAL LEQ -36 THEN RETURN ZEROP(.X);
               IF NOT (.L18 OR .LM18) THEN EXITBLOCK;
               RETURN CODECY(.X,IF .L18 THEN HRLZS ELSE HLRZS))
            ELSE

% MULTIPLY %

          IF .OPPTR EQL GMUL<0,0> OR (FLOP_.OPPTR EQL GFMLR<0,0>) 
            THEN
              (IF .L0 THEN RETURN ZEROP(.X);
	       IF .FLOP THEN IF .FL1 THEN RETURN NOOP(.X);
	       IF NOT .FLOP THEN IF .L1 THEN RETURN NOOP(.X);
               IF .FLOP AND .FLM1 OR NOT .FLOP AND .LM1
                 THEN RETURN GOTM(0,.X,.RESINREG,GNEG OR HUNARYM);
               IF .NOTL THEN EXITBLOCK;
	       IF .OPTOREG THEN IF .LIT THEN EXITBLOCK;
               CODEPROP_0;
               Y<NEGF>_0;
               IF .NEGL XOR .NEGR THEN Y_GNEG(.Y);
               RETURN CODEIT(.Y,.X,
                             IF .FLOP THEN FMPRM ELSE IMULM))
            ELSE

% DIVIDE %

           IF .OPPTR EQL GDIV<0,0> OR (FLOP_.OPPTR EQL GFDVR<0,0>)
             THEN
              (IF .L0 THEN EXITBLOCK;
	       IF .FLOP THEN IF .FL1 THEN RETURN NOOP(.X);
	       IF NOT .FLOP THEN IF .L1 THEN RETURN NOOP(.X);
               IF .FLOP AND .FLM1 OR NOT .FLOP AND .LM1 
                 THEN RETURN GOTM(0,.X,.RESINREG,GNEG OR HUNARYM)
                 ELSE EXITBLOCK)
            ELSE

% MOD %

           IF .OPPTR EQL GMOD<0,0>
             THEN
               (IF .L0 THEN EXITBLOCK;
                IF .L1 OR .LM1 THEN RETURN ZEROP(.X)
                               ELSE EXITBLOCK)
            ELSE

% LOGIC OPERATORS %

          IF .OPPTR EQL GAND<0,0>
            THEN
              (IF .L0 THEN RETURN ZEROP(.X);
               IF .LM1 THEN RETURN NOOP(.X);
	       IF .NEGL THEN EXITBLOCK;
	       IF .OPTOREG AND .LIT THEN EXITBLOCK;
	       RETURN GLOGIC(0,.X,.Y))
            ELSE

          IF .OPPTR EQL GOR<0,0>
            THEN
              (IF .L0 THEN RETURN NOOP(.X);
               IF .LM1 THEN RETURN ONESOP(.X);
               IF .NEGL THEN EXITBLOCK;
	       IF .OPTOREG AND .LIT THEN EXITBLOCK;
	       RETURN GLOGIC(1,.X,.Y))
            ELSE

          IF .OPPTR EQL GXOR<0,0> OR (FLOP_(.OPPTR EQL GEQV<0,0>))
            THEN
	      (IF NOT .FLOP THEN IF .L0 THEN RETURN NOOP(.X);
	       IF .FLOP THEN IF .LM1 THEN RETURN NOOP(.X);
               IF NOT .FLOP AND .LM1 OR .FLOP AND .L0
                 THEN RETURN GOTM(0,.X,.RESINREG,GNOT OR HUNARYM);
               IF .NEGL THEN EXITBLOCK; 
	       IF .OPTOREG AND .LIT THEN EXITBLOCK;
               RETURN GLOGIC(2+.FLOP,.X,.Y))
            ELSE

% ADD %

          IF .OPPTR EQL GADD<0,0> OR (FLOP_.OPPTR EQL GFADR<0,0>)
            THEN
              (IF .L0 THEN RETURN NOOP(.X);
               IF .NOTL THEN EXITBLOCK;
               IF .NEGL THEN
		 IF .OPTOREG THEN (NOOP(.X); X_.X AND NOT NGNTM) ELSE
                 (CODEPROP_0; RETURN CODEIT(.Y,.X,
                                            IF .FLOP THEN FSBRM ELSE SUBM));
	       IF .OPTOREG AND .LIT THEN (OPTOREG_.FLOP; EXITBLOCK);
               IF NOT .FLOP THEN
                 IF .L1 OR .LM1 THEN RETURN CODECY(.X, IF .L1 THEN AOS ELSE SOS);
               CODEPROP_0;
	       OPCODE_
		 IF .OPTOREG AND .NEGR THEN (Y<NEGF>_0;
					     IF .FLOP THEN FSBRR+2 ELSE SUB+2)
		 ELSE IF .FLOP THEN FADRM ELSE ADDM;
	       RETURN CODEIT(.Y,.X,.OPCODE))
            ELSE

% SUB %

          IF .OPPTR EQL GSUB<0,0> OR (FLOP_.OPPTR EQL GFSBR<0,0>)
            THEN
              (IF .L0 THEN RETURN NOOP(.X);
               IF .NOTL THEN EXITBLOCK;
               IF .NEGL THEN
	         IF .OPTOREG THEN (NOOP(.X); X_.X AND NOT NGNTM) ELSE
                 (CODEPROP_0;
                  RETURN CODEIT(GNEG(.Y),.X,IF .FLOP THEN FSBRM ELSE SUBM));
	       IF .OPTOREG AND .LIT THEN (OPTOREG_.FLOP; EXITBLOCK);
               IF NOT .FLOP THEN IF .L1 OR .LM1
                 THEN RETURN CODECY(.X,IF .L1 THEN SOS ELSE AOS);
               CODEPROP_0;
	       OPCODE_
		 IF .OPTOREG AND .NEGR THEN
		   (Y<NEGF>_0; IF .FLOP THEN FADRR+2 ELSE ADD+2) ELSE
		 IF .OPTOREG THEN IF .FLOP THEN FSBRR+2 ELSE SUB+2
	         ELSE (Y_GNEG(.Y); IF .FLOP THEN FADRM ELSE ADDM);
               RETURN CODEIT(.Y,.X,.OPCODE))
             ELSE EXITBLOCK % ALL OTHER BINARIES LEAVE FROM HERE %
        ELSE

% UNARY OPERATORS %
          IF .OPPTR EQL GNEG<0,0> OR (FLOP_.OPPTR EQL GFNEG<0,0>)
            THEN
              (NONEGNOTL_1;
               IF .NEGL THEN RETURN NOOP(.X AND NOT NEGM);
               IF .NOTL AND .FLOP THEN EXITBLOCK;
               RETURN CODECY(.X,IF .NOTL THEN AOS ELSE MOVNS))
            ELSE

          IF .OPPTR EQL GNOT<0,0>
            THEN
              (NONEGNOTL_1;
               IF .NOTL THEN RETURN NOOP(.X AND NOT NOTM);
               RETURN CODECY(.X,IF .NEGL THEN SOS ELSE (SETCMM+.RESINREG)));
    END;

% EXITBLOCKS ABOVE COME HERE %

  IF .OPTOREG THEN
    ! NOW WE TRY TO OPTIMIZE REG_.REG OP EXP

    BEGIN
      REGLEX_.X AND (NGNTM OR RTEM);
      OPTTOREGADDR_.RT[.REGLEX<RTEF>]<ARTEF>;
      REGLEX_GLPR(IF .UNOP THEN (@OPLEX)(.REGLEX)
		  ELSE (@OPLEX)(.REGLEX,.Y),.OPTTOREGADDR);
      OPTTOREGADDR_-1;
      GTUPDATE(0,.REGLEX);
      RETURN .REGLEX
    END;

  ! SORRY CHARLIE! NO LUCK

  IF .X<DTF> THEN INCRUSEN(.X<RTEF>);
  GSTO(IF .LEFTSIDEREG THEN .RT[.X<RTEF>]<ARTEF> OR ZERO36
	ELSE .X AND NOT (NEGM OR NOTM OR COPM),
       IF .OPLEX<HUNARY>
         THEN (@OPLEX)(.X)
         ELSE (@OPLEX)(.X,.Y))
  END;

!END OF H2ARIT.BLI