Google
 

Trailing-Edge - PDP-10 Archives - AP-5471B-BM - sources/algfun.mac
There are 8 other files named algfun.mac in the archive. Click here to see a list.
;
;
;
;
;
;
;	COPYRIGHT (C) 1975,1976,1977,1978
;	DIGITAL EQUIPMENT CORPORATION, MAYNARD, MASS.
;
;
;	THIS SOFTWARE IS FURNISHED UNDER A LICENSE FOR USE ONLY ON A
;	SINGLE COMPUTER SYSTEM AND MAY BE COPIED ONLY WITH THE INCLUSION
;	OF THE ABOVE COPYRIGHT NOTICE.  THIS SOFTWARE, OR ANY OTHER
;	COPIES THEREOF, MAY NOT BE PROVIDED OR OTHERWISE MADE AVAILABLE
;	TO ANY OTHER PERSON EXCEPT FOR USE ON SUCH SYSTEM AND TO ONE WHO
;	AGREES TO THESE LICENSE TERMS.  TITLE TO AND OWNERSHIP OF THE
;	SOFTWARE SHALL AT ALL TIMES REMAIN IN DEC.
;
;	THE INFORMATION IN THIS SOFTWARE IS SUBJECT TO CHANGE WITHOUT
;	NOTICE AND SHOULD NOT BE CONSTRUED AS A COMMITMENT BY DIGITAL
;	EQUIPMENT CORPORATION.
;
;	DEC ASSUMES NO RESPONSIBILITY FOR THE USE OR RELIABILITY OF ITS
;	SOFTWARE ON EQUIPMENT WHICH IS NOT SUPPLIED BY DEC.
;
;SUBTTL CODE GENERATION ROUTINES PART 2

; COPYRIGHT 1971,1972,1973,1974 DIGITAL EQUIPMENT CORPORATION, MAYNARD, MASS.

; WRITTEN BY H. VAN ZOEREN, C.M.U.
; EDITED BY R. M. DE MORGAN and Andrew J. Skinner

	HISEG

	SEARCH ALGPRM,ALGMAC	; SEARCH PARAMETER FILES
MODULE MFUN;
$PLEVEL=2;
BEGIN

EXPROC CGBIN
EXPROC CLOSE
EXPROC EMITCODE
EXPROC ERRLEX
EXPROC FAIL
EXPROC GLOAD
EXPROC IPLUNK
EXPROC LOAD
EXPROC MERGEPORTIONS
EXPROC PLUNK
EXPROC REOPEN
EXPROC REVORDER
EXPROC TOCT1
EXPROC TOCT2
EXPROC UNSTACK

INTERN CTILR,CTLRI,CTLRR
INTERN POWC1,POWC2,POWC3

EXTERN PRASE,ZABS,ZBOOL,ZENTIER,ZINT,ZSIGN
EXTERN OPABS,OPENT1,OPENT2,OPENT3,OPJSPX,OPMVMS,OPUMIN
EXTERN OPPSJP,OPSGN1,OPSGN2,OPSGN3,OPSETO
EXTERN OPADDB,OPAOS,OPSOS,OPMVSM
EXTERN OPJMPE,OPJMPG,OPJRST,OPMVLP
EXTERN OPCONC,OPCONV,OPMOVE,OPABS1,OPLNEG
EXTERN OPENT4,OPENT5
	SUBTTL COMPILE-TIME TYPE-CONVERSION ROUTINES

;*CTIR	INTEGER TO REAL
; CTILR	INTEGER TO LONG REAL
;*CTRI	REAL TO INTEGER
;*CTRLR	REAL TO LONG REAL
; CTLRI	LONG REAL TO INTEGER
; CTLRR	LONG REAL TO REAL

; ON ENTRY, THE ARGUMENT IS IN A0 OR A0,A1
; THE LINK IS ON THE STACK

; ON EXIT, THE RESULT IS IN A0 OR A0,A1


CTLRI:	DFAD	A0,[
	EXP	0.5,0.0]
	HLRZ	A2,A0
	LSH	A2,-11
	ANDI	A2,000377	; EXTRACT HIGH ORDER EXPONENT
	TLZ	A0,377000	; AND CLEAR IT OUT
	JUMPGE	A0,.+3		; NUMBER POSITIVE?
	TRC	A2,000377	; NO -- COMPLEMENT EXTRACTED EXPONENT
	TLO	A0,377000	; AND SET ALL ONES
	SUBI	A2,243		; ADJUST EXPONENT
	JUMPG	A2,.+3		; TOO BIG - OVERFLOW
EDIT(006); CORRECT SHIFT
	ASHC	A0,10(A2)	; [E006] SHIFT MANTISSA TO INTEGER
	POPJ	SP,
	FAIL(128,SOFT,SYM,INTEGER TOO LARGE)
	JUMPL	A0,CTLRI5	; NEG ?
	HRLOI	A0,377777	; SET LARGEST POSITIVE NUMBER
	POPJ	SP,

CTLRI5:	MOVSI	A0,(400000,,0)	; LARGEST NEGATIVE
	POPJ	SP,


CTILR:	ASHC	A0,-^D35	; SHIFT SIGNIFICANCE TO A1
	TLC	A0,276000	; JUGGLE THE EXPONENT
	DFAD	A0,[
	EXP	0.0,0.0]	; NORMALIZE
	POPJ	SP,		; AND RETURN
CTLRR:	JUMPGE	A0,.+3		; ARGUMENT POSITIVE?
	DMOVN	A0,A0		; NO - NEGATE IT
CTLRRD:	TLZA	A1,400000	; AND CLEAR BIT 0 FLAG
CTLRRC:	TLO	A1,400000	; YES - SET BIT 0 FLAG
	TLNN	A1,200000	; ROUNDING REQUIRED?
	JRST	CTLRRA		; NO
	CAMN	A0,[
	XWD	377777,777777]	; YES - HIGH WORD TOO LARGE?
	JRST	CTLRRA		; YES - FORGET IT
	ADDI	A0,1		; NO
	TLO	A0,400		; CARRY

CTLRRA:	JUMPL	A1,.+2		; EXIT IF POSITIVE
	MOVN	A0,A0		; OTHERWISE NEGATE
	POPJ	SP,
SUBTTL	POWC1 -- INTEGER TO INTEGER EXPONENTIATION ROUTINE


; ON ENTRY:
; THE BASE IS IN A0
; THE EXPONENT IS IN A2
; THE LINK IS ON THE STACK

; ON EXIT, THE RESULT (INTEGER OR REAL) IS IN A0


POWC1:	JUMPN	A0,POWC11	; BASE = 0?
	JUMPLE	A2,POWCER	; YES. ERROR IF EXPONENT <= 0
POWC10:	POPJ	SP,		; RESULT = 0 FOR ZERO BASE AND POS. EXP.
	
POWC11:	JUMPL	A2,POWC13	; NEG. EXP. YIELDS REAL RECIPROCAL
	MOVE	A1,A0		; COPY BASE
	MOVEI	A0,1		; PREPARE FOR MULTIPLICATION
	JUMPE	A2,POWC10	; IF EXP. = 0 THEN I^0 = 1

POWC12:	TRZE	A2,000001	; BIT SET IN EXPONENT?
	IMUL	A0,A1		; YES -- MULTIPLY
	JUMPE	A2,POWC25	; EXIT IF FINISHED
	IMUL	A1,A1		; OTHERWISE SQUARE MULTIPLIER
	LSH	A2,-1		; SHIFT BIT OUT OF EXPONENT
	JRST	POWC12		; AND CARRY ON

POWC13:	FLTR	A0,A0		; CONVERT INTEGER BASE TO REAL
	JRST	POWC22		; COMPUTE REAL POWER
SUBTTL	POWC2 -- REAL TO INTEGER EXPONENTIATION ROUTINE

; ON ENTRY:
; THE BASE IS IN A0
; THE EXPONENT IS IN A2
; THE LINK IS ON THE STACK

; ON EXIT, THE RESULT IS IN A0


POWC2:	JUMPE	A0,POWC24	; BASE = 0?
	JUMPN	A2,POWC21	; NO. EXPONENT = 0?
	MOVSI	A0,(1.0)	; YES.  R^0 = 1.0
POWC20:	POPJ	SP,		; EXIT

POWC21:	CAIG	A2,0		; EXPONENT POSITIVE?
POWC22:	TDZA	A3,A3		; NO. CLEAR POSITIVE FLAG AND SKIP
	MOVEI	A3,1		; YES. SET POSITIVE FLAG
	MOVM	A2,A2		; GET MAGNITUDE OF EXPONENT
	MOVE	A1,A0		; COPY BASE
	MOVSI	A0,(1.0)	; PREPARE FOR "*" (OR "/")

POWC23:	TRZE	A2,000001	; BIT SET IN EXPONENT?
	XCT	[
	FDVR	A0,A1
	FMPR	A0,A1](A3)	; YES -- MULTIPLY/DIVIDE
	JUMPE	A2,POWC25	; EXIT IF FINISHED
	FMPR	A1,A1		; OTHERWISE SQUARE MULTIPLIER
	LSH	A2,-1		; SHIFT BIT OUT OF EXPONENT
	JRST	POWC23		; AND CARRY ON

POWC24:	JUMPG	A2,POWC20	; BASE = 0 -- EXIT IF EXPONENT > 0
POWCER:
	FAIL(76,FRIED,SYM,OVERFLOW OR UNDEFINED RESULT FOR "CONSTANT ^ CONSTANT");
	POPJ	SP,		; ERROR EXIT

POWC25:	JFOVO	POWCER		; ERROR IF OVERFLOW FLAG ON
	POPJ	SP,		; NORMAL EXIT
SUBTTL	POWC3 -- LONG REAL TO INTEGER EXPONENTIATION ROUTINE

; ON ENTRY:
; THE BASE IS IN (A0,A1)
; THE EXPONENT IS IN A2
; THE LINK IS ON THE STACK

; ON EXIT, THE RESULT (TYPE LONG REAL) IS IN A0,A1


POWC3:	JUMPN	A0,.+3		; BASE = 0?
	JUMPLE	A2,POWCER	; YES - ERROR IF EXP LEQ 0
	POPJ	SP,
	MOVE	A3,A0		; NO -- COPY BASE
	MOVE	A4,A1
	MOVSI	A0,(1.0)	; INITIALIZE RESULT TO 1.0&&0
	MOVEI	A1,0
	JUMPN	A2,POWC31	; EXPONENT = 0?
	POPJ	SP,0		; YES -- RESULT = 1.0&&0

POWC31:	PUSH	SP,A6		; SAVE REGISTERS
	PUSH	SP,A7
	MOVM	A7,A2		; COPY MAGNITUDE OF EXPONENT
	JUMPG	A2,POWC32	; EXPONENT POSITIVE?
	TDZA	A6,A6		; NO -- CLEAR POSITIVE FLAG
POWC32:	MOVEI	A6,1		; YES -- SET POSITIVE FLAG

POWL1:	TRZE	A7,1		; STRICTLY KI
	XCT	[
	DFDV	A0,A3		; IF BIT SET IN EXPT, THEN DIVIDE/MULTIPLY
	DFMP	A0,A3](A6)
	JUMPE	A7,POWLEX	; ELSE EXIT IF FINISHED
	DFMP	A3,A3		; OTHERWISE SQUARE MULTIPLIER
	LSH	A7,-1		; SHIFT BIT OUT OF EXPT
	JRST	POWL1		;  AND CONTINUE
POWLEX:	POP	SP,A7		; RESTORE REGISTERS
	POP	SP,A6
	JFOVO	POWCER		; ERROR RETURN IF OVERFLOW FLAG ON
	POPJ	SP,0		; NORMAL RETURN
	SUBTTL	CODE GENERATION ROUTINES	* CGFUN *

PROCEDURE CGFUN

	;..GENERATE CODE FOR CALLS ON STANDARD FUNCTIONS;
	    ;  ON ENTRY, FUNCTION LEXEME IS IN LOP;
	    ;  ARGUMENT LEXEME IS IN SYM;
	;  FOR LIBRARY FUNCTIONS, ARGUMENT WILL BE CONVERTED
	    ;  TO PROPER TYPE AND LOADED INTO A0.
	;  IN-LINE CODE WILL BE GENERATED FOR:
	    ;		INT
	    ;		BOOL
	    ;		ABS
	    ;		SIGN
	    ;		ENTIER
	;  RESULT IS A CLOSED PORTION WHOSE LEXEME IS IN SYM;

BEGIN
 IF SYM IS AN ERROR LEXEME
				JUMPGE	SYM,FALSE;$
 THEN;..SET ERROR LEXEME AND LEAVE;
   ERRLEX;
 ELSE;..NO ERRORS YET ..... GO ON;
 BEGIN
  ;..SET REV OFF;
				MOVNI	REV,SYM;$
  IF LOP IS A LIBRARY FUNCTION
				HRRZ	T,LOP;$
				CAIGE	T,PRASE;$
				GOTO	FALSE;$
  THEN;..WE MUST CALL A SUBROUTINE;
    BEGIN
      IF SYM<TYPE> NEQ ARITHMETIC
				TN.ARITH(SYM);
      THEN
	FAIL(77,FRIED,SYM,NON-ARITHMETIC ARGUMENT FOR STANDARD LIBRARY FUNCTION);
      ELSE;..ARGUMENT IS ARITHMETIC;
	BEGIN
	  IF LOP<TYPE> = REAL AND SYM<TYPE> NEQ REAL
				TLNN	LOP,$TYPE-$R;$
				TN.R	(SYM);
	  THEN;..ARGUMENT MUST BE CONVERTED TO REAL;
	    ;CONVERT(REAL,SYM);
				MOVEI	T,$R;$
	      CONVERT;
	  ELSE;..LOP HAD BETTER BE LONG REAL;
	    BEGIN					; [E044]
	      IF LOP<TYPE> = LONG REAL AND SYM<TYPE> NEQ LONG REAL
				TLNN	LOP,$TYPE-$LR;$
				TN.LR	(SYM);
	      THEN;..ARGUMENT MUST BE CONVERTED TO LONG REAL;
	        ;CONVERT(LONG REAL,SYM);
				MOVEI	T,$LR;$
		CONVERT;
	      FI;
EDIT(044); Dont force constants to D.P. unnecessarily
	      ;.SYM IS LONG REAL - CHECK IF GENUINE	; [E044]
	      IF SYM = PSEUDO-LONG CONSTANT		; [E044]
				TLNN	SYM,$TYPE-$LR	; [E044]
				T.CONST	(SYM)		; [E044]
				TLNE	SYM,$CT-$IMM	; [E044]
				TLNN	SYM,$DEC	; [E044]
				GOTO	FALSE		; [E044]
				F.LOCN	(T2,SYM)	; [E044]
				ADD	T2,CONTAB	; [E044]
				SKIPL	T4,3(T2)	; [E044]
				GOTO	FALSE		; [E044]
	      THEN;.MAKE IT A GENUINE LONG REAL CONSTANT; [E044]
				MOVE	T3,2(T2)	; [E044]
				TLZ	T4,(1B0)	; [E044]
				TOCT	(2,SYM)		; [E044]
	      FI;					; [E044]
	    ENDD;					; [E044]
	  FI
	  IF SYM IS A POINTER
				T.PTR	(SYM);
	  THEN;..PUT ITS VALUE INTO A0;
	    ;GO TO NEXT "THEN";
				GOTO	LCGFN1;$
	  FI
	  IF VALUE OF SYM NOT IN A0
				TN.AC0	(SYM);
	  THEN;..ARGUMENT FOR A LIBRARY FUNCTION MUST BE IN A0;
	    LCGFN1:
	    LOAD(SYM,A0);
	  FI
	  REOPEN(SYM);
	  ;..GENERATE CALL ON LIBRARY FUNCTION;
	  IF LOP<TYPE> = LONG REAL
				T.LR(LOP);
	  THEN
				MOVSI	T,7777;$
	  ELSE
				MOVSI	T,77;$
	  FI
				IORM	T,HANDLE;$
	  ;PLUNK(PUSHJ,SP,LOP);
				MOVE	T,OPPSJP;$
				PLUNKI	(LOP);
	  ;LEX(SYM) _ (EXPR,SAME,STATEMENT,ACC);
				TLZ	SYM,$KIND!$STATUS!$AM;$
				TLO	SYM,$EXP!$STMT!$ACC;$
	  CLOSE(SYM);
	ENDD
      FI
    ENDD
      ELSE;..NOT A LIBRARY FUNCTION - MUST BE IN-LINE;
	IF LOP = "INT"
				CAIE	T,ZINT;$
				GOTO	FALSE;$
	THEN;..BOOLEAN-TO-INTEGER TRANSFER FUNCTION -- NO CODE GENERATED;
	  BEGIN
	    IF SYM<TYPE> NEQ BOOLEAN
				TN.B	(SYM);
	    THEN
	      FAIL(78,FRIED,SYM,NON-BOOLEAN ARGUMENT FOR "INT" FUNCTION);
	    ELSE;..ARGUMENT IS BOOLEAN. MAKE IT AN INTEGER EXPR;
	      BEGIN
		IF SYM IS A POINTER
				T.PTR	(SYM);
		THEN;..LOAD VALUE INTO SAME ACC USED BY PTR;
				F.LOCN	(T2,SYM);
		  LOAD(SYM,@T2);
		ELSE;..NOT A POINTER;
		  IF SYM IS SINGLE
				T.SINGLE(SYM);
		  THEN;..MAKE IT A PORTION IN AN ACC;
		    LOAD(SYM,ANYAC);
		  FI
		FI
	        ;LEX(SYM) _ (SAME,INTEGER,STATEMENT,SAME);
				TLZ	SYM,$TYPE!$STATUS;$
				TLO	SYM,$I!$STMT;$
	      ENDD
	    FI
	  ENDD
	ELSE;..FUNCTION IS NOT "INT";
	  IF LOP = "BOOL"
				CAIE	T,ZBOOL;$
				GOTO	FALSE;$
	  THEN;..INTEGER-TO-BOOLEAN TRANSFER FUNCTION -- NO CODE GENERATED;
	    BEGIN
	      IF SYM<TYPE> NEQ INTEGER
				TN.I	(SYM);
	      THEN
		FAIL(79,FRIED,SYM,NON-INTEGER ARGUMENT FOR "BOOL" FUNCTION);
	      ELSE;..ARGUMENT IS INTEGER. MAKE IT A BOOLEAN EXPR;
		BEGIN
		  IF SYM IS A POINTER
				T.PTR	(SYM);
		  THEN;..LOAD VALUE INTO SAME ACC USED BY PTR;
				F.LOCN	(T2,SYM);
		    LOAD(SYM,@T2);
		  ELSE;..NOT A POINTER;
		    IF SYM IS SINGLE
				T.SINGLE(SYM);
		    THEN;..MAKE IT A PORTION IN AN ACC;
		      LOAD(SYM,ANYAC);
		    FI
		  FI
		  ;LEX(SYM) _ (SAME,BOOLEAN,STATEMENT,SAME);
				TLZ	SYM,$TYPE!$STATUS;$
				TLO	SYM,$B!$STMT;$
		ENDD
	      FI
	    ENDD
	  ELSE;..FUNCTION IS NOT "INT" OR "BOOL";
	   IF SYM<TYPE> NEQ ARITHMETIC
				TN.ARITH(SYM);
	   THEN
	     FAIL(80,FRIED,SYM,NON-ARITHMETIC ARGUMENT FOR BUILT-IN FUNCTION);
	   ELSE;..ARGUMENT IS ARITHMETIC;
EDIT(044); Dont force constants to D.P. unnecessarily
	    BEGIN;					; [E044]
	    IF SYM = PSEUDO-LONG REAL CONSTANT		; [E044]
				TLNN	SYM,$TYPE-$LR	; [E044]
				T.CONST	(SYM)		; [E044]
				TLNE	SYM,$CT-$IMM	; [E044]
				TLNN	SYM,$DEC	; [E044]
				GOTO	FALSE		; [E044]
				F.LOCN	(T2,SYM)	; [E044]
				ADD	T2,CONTAB	; [E044]
				SKIPL	T4,3(T2)	; [E044]
				GOTO	FALSE		; [E044]
	    THEN;..CONVERT IT TO A REAL			; [E044]
				MOVE	T3,A0		; [E044]
				MOVE	A0,2(T2)	; [E044]
				MOVE	A1,3(T2)	; [E044]
				TLZ	A1,(1B0)	; [E044]
				PUSHJ	SP,CTLRR	; [E044]
				EXCH	T3,A0		; [E044]
				TLZ	SYM,$TYPE
				TLO	SYM,$R
	    STOCON;					; [E044]
				HRRZ	T,LOP		; [E044]
	    FI;						; [E044]
	    IF LOP = "ABS"
				CAIE	T,ZABS;$
				GOTO	FALSE;$
	    THEN;..ABSOLUTE VALUE FUNCTION;
	      BEGIN
	       ;..RESULT WILL HAVE SAME TYPE AS ARGUMENT
	       ;  (TECHNICALLY NOT CORRECT ALGOL 60);
	       IF SYM<TYPE> = LONG REAL
				T.LR	(SYM);
	       THEN;..WE MUST LOAD THE VALUE AND TEST IT;
		BEGIN
		  IF SYM IS A POINTER
				T.PTR	(SYM);
		  THEN;..LOAD VALUE INTO SAME ACC USED BY PTR;
				F.LOCN	(T2,SYM);
		    LOAD(SYM,@T2);
		  ELSE;..NOT A POINTER;
		    IF SYM IS SINGLE
				T.SINGLE(SYM);
		    THEN;..MAKE A PORTION TO LOAD SYM IN AN ACC;
		      LOAD(SYM,ANYAC);
		    FI
		  FI
		  REOPEN(SYM);
		  ;..EMIT IN-LINE CODE TO TEST SIGN AND NEGATE NEG. VALUE;
		  ;..SKIP THE NEGATION FOR POSITIVE VALUES;
		  ;PLUNK(JUMPGE,SYM,.+2);
				MOVE	T,OPABS1;$
				F.LOCN	(T1,SYM);
				PLUNK;
		  ;..NEGATE THE NEGATIVE VALUE;
		  ;PLUNK(LONG NEGATE,SYM,SYM+1);
				MOVE	T,OPLNEG;$
				F.LOCN	(T1,SYM);
				MOVE	T2,SYM;$
				TLZ	T2,777777-$AM;$
				ADD	T,T2;$
				PLUNK;
		  CLOSE(SYM);
		ENDD
	       ELSE;..SYM IS INTEGER OR REAL;
		IF SYM IS AN EXPR OR A POINTER IN ACC
				T.ACC	(SYM);
		THEN;..WE ALREADY HAVE A PORTION FOR SYM;
		  BEGIN
		    ;..APPEND CODE TO GET MAGNITUDE OF SYM;
		    REOPEN(SYM);
		    ;PLUNK(MABS,SYM,SYM);
				MOVE	T,OPABS;$
				F.LOCN	(T1,SYM);
				PLUNK	(SYM);
		    CLOSE(SYM);
		  ENDD
		ELSE;..NO PORTION YET. LOAD MAGNITUDE OF SINGLE ARGUMENT;
		  ;LOADM(SYM,ANYAC);
				MOVEI	T1,ANYAC;$
				HLL	T1,OPMVMS;$
				PUSHJ	SP,.LOAD;$
		FI
	       FI
	       ;LEX(SYM) _ (EXPR,SAME,STATEMENT,ACC);
				TLZ	SYM,$KIND!$STATUS!$AM;$
				TLO	SYM,$EXP!$STMT!$ACC;$
	      ENDD
	    ELSE;..FUNCTION IS NOT "INT" OR "BOOL" OR "ABS";
	      IF LOP = "SIGN"
				CAIE	T,ZSIGN;$
				GOTO	FALSE;$
	      THEN;..SIGN FUNCTION;
		BEGIN
		  IF SYM IS A POINTER
				T.PTR	(SYM);
		  THEN;..LOAD VALUE INTO SAME ACC USED BY POINTER;
				F.LOCN	(T2,SYM);
		    LOAD(SYM,@T2);
		  ELSE;..NOT A POINTER;
		    IF SYM IS SINGLE
				T.SINGLE(SYM);
		    THEN;..MAKE A PORTION TO LOAD SYM INTO AN ACC;
		      LOAD(SYM,ANYAC);
		    FI
		  FI
		  REOPEN(SYM);
		  ;..EMIT IN-LINE CODE TO COMPUTE "SIGN" FUNCTION;
		  ;..IF ARGUMENT = 0 THEN SIGN(ARG) = 0;
		  ;PLUNK(JUMPE,SYM,.+3);
				MOVE	T,OPSGN1;$
				F.LOCN	(T1,SYM);
				PLUNK;
		  ;..SHIFT OUT ALL BUT SIGN BITS (YIELDS 0 OR -1);
		  ;PLUNK(ASH,SYM,-43);
				MOVE	T,OPSGN2;$
				F.LOCN	(T1,SYM);
				PLUNK;
		  ;..SET LOW-ORDER BIT TO 1 (YIELDS 1 OR -1);
		  ;PLUNK(TRO,SYM,1);
				MOVE	T,OPSGN3;$
				F.LOCN	(T1,SYM);
				PLUNK;
		  ;LEX(SYM) _ (EXPR,INTEGER,STATEMENT,ACC);
				TLZ	SYM,$KIND!$TYPE!$STATUS!$AM;$
				TLO	SYM,$EXP!$I!$STMT!$ACC;$
		  CLOSE(SYM);
		ENDD
	      ELSE;..FUNCTION IS NOT "INT" OR "BOOL" OR "ABS" OR "SIGN";
		IF LOP = "ENTIER"
				CAIE	T,ZENTIER;$
				GOTO	FALSE;$
		THEN;..LARGEST-INTEGER FUNCTION;
		  BEGIN
		    IF SYM<TYPE> = INTEGER
				T.I	(SYM);
		    THEN
		      ;CONVERT(REAL,SYM);
				MOVEI	T,$R;$
			CONVERT;
		    FI
			IF SYM<TYPE> = LONG REAL
				T.LR	(SYM);
			THEN;..LONG REAL ENTIER. CALL SUBROUTINE;
			  BEGIN
			    IF SYM IS A POINTER
				T.PTR	(SYM);
			    THEN;..MUST GET ITS VALUE;
			      ;GO TO NEXT "THEN";
				GOTO	LCGFN2;$
			    FI
			    IF VALUE OF SYM NOT IN A0
				TN.AC0	(SYM);
			    THEN;..LOAD IT INTO A0;
			      LCGFN2:
			      LOAD(SYM,A0);
			    FI
			    REOPEN(SYM);
			    ;..GENERATE INST. TO CALL LONG REAL ENTIER SR;
			    ;PLUNK(JSP,AX,ENTIEL);
				MOVE	T,OPJSPX;$
				PLUNKI;
			    ;LEX(SYM) _ (EXPR,INTEGER,STATEMENT,ACC);
				TLZ	SYM,$KIND!$TYPE!$STATUS!$AM;$
				TLO	SYM,$EXP!$I!$STMT!$ACC;$
			    CLOSE(SYM);
			  ENDD
			ELSE;..ARGUMENT IS REAL. EMIT IN-LINE REAL ENTIER;
			  BEGIN
			    ;..GIVE SYM SPECIAL TYPE SO LOAD WILL USE 2 ACS;
				TLZ	SYM,$TYPE;$
				TLO	SYM,$IDI;$
			    IF SYM IS A POINTER
				T.PTR	(SYM);
			    THEN;..MUST GET VALUE OF PTR INTO AN AC;
			      ;..LOAD INTO SAME AC USED FOR PTR;
				F.LOCN	(T2,SYM);
				LOAD	(SYM,@T2);
			    ELSE;..NOT A POINTER;
			      BEGIN
				IF SYM IS SINGLE OR IN LAST AC <AC13>
				TLNN	SYM,$SINGLE;$
				GOTO	TRUE;$
				F.LOCN	(T,SYM);
				CAIE	T,A13;$
				GOTO	FALSE;$
				THEN;..MUST MOVE SYM TO A FREE AC PAIR;
				  LOAD(SYM,ANYAC);
				FI
			      ENDD
			    FI
			    IF LAST GENERATED INST. WAS "MOVEI"
				MOVE	T,INDEX;$
				HLRZ	T2,-2(T);$
				ANDI	T2,777000;$
				CAIE	T2,<MOVEI 0,0>_-22;$
				GOTO	FALSE;$
			    THEN;..SYM WAS AN IMMEDIATE REAL CONSTANT;
			      ;..   BUT "LOAD" THOUGHT IT WAS INTEGER;
			      ;..CHANGE INSTRUCTION TO "HRLZI";
				MOVE	T2,-2(T);$
				TLZ	T2,777000;$
				TLO	T2,<HRLZI 0,0>_-22;$
				MOVEM	T2,-2(T);$
			    FI
			    REOPEN(SYM);
			    ;..EMIT IN-LINE CODE TO COMPUTE "ENTIER";
EDIT(031); CAN'T USE FIX OR FIXR, SO DO IT THE HARD WAY
		;......SPLIT OFF EXPONENT;
			    ;EMITCODE(MULI,SYM,400,2);
				MOVE	T,OPENT1;$
				F.LOCN	(T1,SYM);
				HRLI	T1,2;$
				EMITCODE;
			    ;..COMPLEMENT EXPONENT FOR NEGATIVE ARGUMENT;
			    ;PLUNK(TSC,SYM,SYM);
				MOVE	T,OPENT2;$
				F.LOCN	(T1,SYM);
				PLUNK	(SYM);
			    ;EXCHANGE EXPONENT AND FRACTION;
			    ;PLUNK(EXCH,SYM+1,SYM);
				HRLZI	T,<EXCH 0,0>_-22;$
				F.LOCN	(T1,SYM);
				ADDI	T1,1;$
				PLUNK	(SYM);
			    ;..SHIFT ARGUMENT TO ZERO EXPONENT;
			    ;PLUNK(ASH,SYM<LOCN>,-243(SYM<LOCN>+1));
				MOVE	T,OPENT3;$
				F.LOCN	(T1,SYM);
				PLUNK;
			    ;LEX(SYM)_(EXPR,INTEGER,STATEMENT,SYM<LOCN>);
				TLZ	SYM,$KIND!$TYPE!$STATUS!$AM;$
				TLO	SYM,$EXP!$I!$STMT!$ACC;$
			    CLOSE(SYM);
			  ENDD
			FI
		  ENDD
		;..ELSE NOT ENTIER;
		FI;..IF LOP = ENTIER
	      FI;..IF LOP = SIGN
	    FI;..IF LOP = ABS
	    ENDD;
	   FI;..IF SYM<TYPE> NEQ ARITHMETIC
	  FI;..IF LOP = BOOL
	FI;.. IF LOP = INT
      FI;..IF LOP IS A LIBRARY FUNCTION
    ENDD;
  FI;..IF SYM IS AN ERROR LEXEME
ENDD	; CGFUN
	SUBTTL	CODE GENERATION ROUTINES	* CGDOT *

PROCEDURE CGDOT

	;..GENERATE CODE TO LOAD OPERANDS FOR "DOT" OPERATOR;
	    ;  ON ENTRY, LEXEME FOR STRING POINTER IS IN LOP;
	    ;  LEXEME FOR INDEX IS IN SYM;
	;  CODE WILL BE GENERATED TO PUT STRING POINTER INTO A2
	    ;  AND INDEX INTO A1;
	;  RESULT IS A SINGLE CLOSED PORTION WHOSE LEXEME IS IN SYM;

BEGIN
  IF LOP IS AN ERROR LEXEME
				JUMPGE	LOP,FALSE;$
  THEN;..SET RESULT LEXEME AND LEAVE;
    ERRLEX;
  ELSE;..NO ERRORS YET ..... GO ON;
    BEGIN
      ;..SET REV OFF;
				MOVNI	REV,SYM;$
      IF SYM = SINGLE
				T.SINGLE(SYM);
      THEN;..NO PORTION YET FOR SYM;
	REOPEN(LOP);
      ELSE;..BOTH LOP AND SYM ARE PORTIONS -- JOIN THEM;
	BEGIN
	  REVER;
	  MERGEPORTIONS;
	  COMBLEX;
	ENDD
      FI
      IF SYM IN AC2
				TLNN	SYM,$AMAC;$
				TRNN	SYM,2;$
				JRST	FALSE;$
				TRNE	SYM,-3;$
				JRST	FALSE;$
	THEN
	  BEGIN;..PUSH IT
				HRLZI	T,(<PUSH SP,0>);$
	    PLUNKI(SYM);$
	    ;..SYM<AM> _ SP
				TLZ	SYM,$AM;$
				TLO	SYM,$SP;$
	    ;..SYM<RHS> _ 0
				TRZ	SYM,-1;$
	    ;..SYM<SA> _ SYM<SA> + 1
				HRLZI	T,1;$
				ADDM	T,LEXEX;$
	    IF LOP IS ON STACK
				T.STK	(LOP);$
	      THEN;..ADJUST STACK OFFSET
				SUBI	LOP,1;$
	    FI;
	  ENDD;
      FI;
      IF LOP NOT IN AC2
				TLNE	LOP,$AMAC;$
				GOTO	TRUE;$
				HRRZ	T,LOP;$
				JUMPE	T,FALSE;$
      ; N.B. IF LOP IS IN AC0, ADDRESS IS IN AC2;
				CAIN	T,A2;$
				GOTO	FALSE;$
      THEN;..PUT IT INTO AC2;
        BEGIN
          ;..FUDGE MODE TO MOVE POINTER ITSELF (NOT @PTR);
          IF LOP IS ON THE STACK
				T.STK	(LOP);
          THEN;..FUDGE AS STACKED EXPRESSION;
				TLZ	LOP,$AM;$
				TLO	LOP,$SP;$
          ELSE;..FUDGE AS EXPRESSION IN ACC;
				TLZ	LOP,$AM;$
				TLO	LOP,$ACC;$
          FI
	  ;PLUNK(MOVE,AC2,LOP);
				MOVE	T,OPMOVE;$
				MOVEI	T1,A2;$
				PLUNK	(LOP);
        ENDD
      FI
      IF SYM NOT IN AC1
				TLNE	SYM,$AMAC;$
				GOTO	TRUE;$
				HRRZ	T,SYM;$
				CAIN	T,A1;$
				GOTO	FALSE;$
      THEN;..PUT IT INTO AC1;
				MOVE	T,OPMVSM;$
				MOVEI	T1,A1;$
	GLOAD;
      FI
      ;LEX(SYM) _ (VAR,STRING,REGULAR,PTR,AC2);
				TLZ	SYM,$KIND!$TYPE!$STATUS!$AM;$
				TLO	SYM,$VAR!$S!$REG!$PTR;$
				HRRI	SYM,A2;$
      CLOSE(SYM);
    ENDD
  FI
ENDD	; CGDOT
	SUBTTL	CODE GENERATION ROUTINES	* CGFTEST *

PROCEDURE CGFTEST

	;..GENERATE CODE FOR THE "STEP-UNTIL" TEST IN A "FOR" STATEMENT
	    ;  ON ENTRY, LEXEME FOR CONTROLLED VARIABLE IS IN LOP;
	    ;  LEXEME FOR FINAL VALUE IS IN SYM;
	    ;  LEXEME FOR INCREMENT IS IN FBSYMSAVE;
	;  IF INCREMENT = CONSTANT, ITS SIGN WILL NOT BE
	    ;  TESTED AT RUN TIME.
	;  IF INCREMENT NEQ CONSTANT, THE GENERAL ALGOL TEST
	    ;  SEQUENCE WILL BE GENERATED;
	;  RESULT IS A CLOSED PORTION WHOSE LEXEME IS IN SYM;

BEGIN
  IF LOP IS AN ERROR LEXEME
				JUMPGE	LOP,FALSE;$
  THEN;..SET ERROR LEXEME AND LEAVE;
    ERRLEX;
  ELSE;..LOP IS OK;
    IF INCREMENT IS AN ERROR LEXEME
				MOVE	T,FBSYMSAVE;$
				JUMPGE	T,FALSE;$
    THEN;..SET ERROR LEXEME AND LEAVE;
      ERRLEX;
    ELSE;..NO ERRORS YET ..... GO ON;
      BEGIN
	;..SET REV OFF;
				MOVNI	REV,SYM;$
	;..PUT INCREMENT LEXEME INTO A REGISTER;
				MOVE	T2,FBSYMSAVE;$
	IF INCREMENT IS CONSTANT
				T.CONST	(T2);
	THEN;..CONSTANT INCREMENT. NO NEED TO TEST IT ON EACH CYCLE;
	  BEGIN
	    ;..PUT VALUE OF INCREMENT IN T3;
	    IF INCREMENT = IMMEDIATE CONSTANT
				T.IMM	(T2);
	    THEN;..IMMEDIATE CONSTANT;
	      BEGIN
		IF INCREMENT<TYPE> = INTEGER
				T.I	(T2);
		THEN;..IMMEDIATE INTEGER CONSTANT;
		  ;..RH(T3) _ INCREMENT<LOCN>;
				HRRZ	T3,T2;$
		ELSE;..IMMEDIATE REAL CONSTANT;
		  ;..LH(T3) _ INCREMENT<LOCN>;
				HRLZ	T3,T2;$
		FI
	      ENDD
	    ELSE;..NON-IMMEDIATE CONSTANT;
	      BEGIN
		;T1 _ INCREMENT<LOCN> + CONSTANT TABLE BASE;
				F.LOCN	(T1,T2);
				ADD	T1,CONTAB;$
		IF INCREMENT<TYPE> = LONG REAL
				T.LR	(T2);
		THEN;..GET FIRST WORD OF LONG REAL CONSTANT;
				MOVE	T3,2(T1);$
		ELSE;..GET REAL OR INTEGER CONSTANT;
				MOVE	T3,1(T1);$
		FI
	      ENDD
	    FI
	    ;..VALUE OF CONSTANT IS NOW IN T3. TEST ITS SIGN;
EDIT(046); Do the correct thing for a zero increment
	    IF CONSTANT GEQ 0
				JUMPL	T3,FALSE	; [E046]
	    THEN;..CONSTANT >= 0. NORMAL TEST		; [E046]
				MOVE	T,ZLEQ;$
	    ELSE;..CONSTANT < 0. REVERSE THE TEST	; [E046]
				MOVE	T,ZGTE;$
	    FI
				MOVEM	T,OP;$
	    ;..GENERATE CODE FOR THE RELATION. IF THE INCREMENT
	    ;..   IS GREATER THAN 0, THE TEST WILL BE:
	    ;..        IF CONT.VAR. > FINAL VAL. THEN GO TO ELM.-EXH.;
	    ;..   OTHERWISE THE TEST WILL BE
	    ;..        IF CONT.VAR. < FINAL VAL. THEN GO TO ELM.-EXH.;
	      CGBIN;
	    ;..NOW BACK UP THE STACK POINTER;
	      UNSTACK;
	    ;..NOW PUT IN THE JUMP TO "ELEMENT-EXHAUSTED";
	    REOPEN(SYM);
	    IF THE LAST GENERATED INSTRUCTION = "SETO"
				MOVE	T,INDEX;$
				HLLZ	T1,-1(T);$
				TLZ	T1,000777;$
				CAME	T1,OPSETO;$
				GOTO	FALSE;$
	    THEN;..NOTHING WAS STACKED. NO NEED TO GENERATE "TRUE" OR "FALSE";
	      BEGIN
		;..REPLACE THE "TDZA" AND "SETO" BY A "JRST";
		;INDEX _ INDEX - 2;
				SUBI	T,2;$
				MOVEM	T,INDEX;$
		;PLUNK(JRST,0,0);
				MOVE	T,OPJRST;$
				PLUNKI;
	      ENDD
	    ELSE;..CAN'T BACK UP - "UNSTACK" PUT IN AN INSTRUCTION;
	      ;..APPEND A JUMPE;
	      ;PLUNK(JUMPE,SYM,0);
				HLLZ	T,-2(T);$
				TLZ	T,777000;$
				TDO	T,OPJMPE;$
				F.LOCN	(T1,SYM);
				PLUNKI;
	    FI
	  ENDD
	ELSE;..INCREMENT IS NOT CONSTANT. MUST GENERATE THE GENERAL TEST;
	  BEGIN
	    ;..TEST WILL BE
	    ;..    IF (CONTR. VAR. - FINAL VALUE)*SIGN(INCREMENT) > 0
	    ;..          THEN GO TO ELEMENT-EXHAUSTED;
	    ;..
	    ;..GENERATE CODE FOR (CONTR. VAR. - FINAL VALUE);
				MOVE	T,ZMINUS;$
				MOVEM	T,OP;$
	      CGBIN;
	    ;..LOP _ LEXEME AND LEXEX FOR (CONT. VAR. - FINAL VALUE);
				MOVE	LOP,SYM;$
				MOVE	T,LEXEX;$
				MOVEM	T,LLEXEX;$
				MOVE	T,LEXEX+1;$
				MOVEM	T,LLEXEX+1;$
	    ;..SYM _ LEXEME AND LEXEX FOR INCREMENT;
				MOVE	SYM,FBSYMSAVE;$
				MOVE	T,FBLEXSAVE;$
				MOVEM	T,LEXEX;$
				MOVE	T,FBCOMPSAVE;$
				MOVEM	T,LEXEX+1;$
	    ;..GENERATE CODE FOR MULTIPLICATION BY SIGN OF INCREMENT;
	    ;..SET OP THOROUGHLY NON-REVERSIBLE;
				MOVEI	T,0;$
				MOVEM	T,OP;$
	    SETUP;$
	    ;PLANT <SKIPGE SYM>
				HRLZI	T,(<SKIPGE>);$
				PLUNKI(SYM);$
	    IF LOP<TYPE> IS LONG.REAL;
				T.LR	(LOP);$
	      THEN;..PLANT(LMOVN,LOP);
				MOVE	T,OPLNEG;$
	    ELSE;..PLANT(MOVN,LOP);
				MOVE	T,OPUMIN;$
	    FI;
				F.LOCN	(T1,LOP);$
				PLUNK(LOP);$
	    CLOSE(SYM);
	    COMBLEX;
	    ;..MAKE SURE THE STACK POINTER IS RESET;
	    UNSTACK;
	    ;..NOW APPEND THE TEST WHICH JUMPS TO "ELEMENT-EXHAUSTED";
	    REOPEN(SYM);
	    ;PLUNK(JUMPG,LOP,0);
				MOVE	T1,INDEX;$
				HLLZ	T,-1(T1);$
				TLZ	T,000037;$
				CAMN	T,[SUB	SP,0];$
				HLLZ	T,-2(T1);$
				TLZ	T,777037;$
				TDO	T,OPJMPG;$
				F.LOCN	(T1,LOP);
				PLUNK;
	  ENDD
	FI
	CLOSE(SYM);
      ENDD
    FI
  FI
ENDD	; CGFTEST
	SUBTTL	CODE GENERATION ROUTINES	* CGINCR *

PROCEDURE CGINCR

	;..GENERATE EFFICIENT CODE FOR INCREMENTING A CONTROLLED VARIABLE;
	    ;  ON ENTRY, LEXEME FOR CONTROLLED VARIABLE IS IN LOP;
	    ;  LEXEME FOR INCREMENT IS IN SYM;
	    ;  NUMBER OF PREFERRED ACC IS IN PREFACC;
	;  IF INCREMENT = 1 THEN CODE IS "AOS" 
	    ;  ELSE IF INCREMENT = -1 THEN CODE IS "SOS" 
	    ;  ELSE IF INCREMENT = 0 THEN CODE IS "MOVE"
	    ;  ELSE CODE IS "ADDB";
	;  CLOSED PORTION FOR ASSIGNMENT OF INCREMENTED VALUE
	    ;  IS GENERATED AND ITS RESULT LEXEME IS PUT IN SYM;

BEGIN
  IF LOP IS AN ERROR LEXEME
				JUMPGE	LOP,FALSE;$
  THEN;..SET ERROR LEXEME AND LEAVE;
    ERRLEX;
  ELSE;..LOP IS OK;
    IF INCREMENT IS AN ERROR LEXEME
				JUMPGE	SYM,FALSE;$
    THEN;..SET ERROR LEXEME AND LEAVE;
      ERRLEX;
    ELSE;..NO ERRORS YET ..... GO ON;
      BEGIN
	;..SET REV OFF;
				MOVNI	REV,SYM;$
	EDIT(046); Don't generate an "ADDB" for a zero increment !
	IF SYM IS A CONSTANT WITH VALUE ZERO		; [E046]
				T.CONST	(SYM)		; [E046]
				F.LOCN	(T,SYM)		; [E046]
				TLNN	SYM,$AM-$IMM	; [E046]
				JRST	.+3		; [E046]
				ADD	T,CONTAB	; [E046]
				MOVE	T,1(T)		; [E046]
				JUMPN	T,FALSE		; [E046]
	THEN;..NO NEED TO GENERATE AN ADDB		; [E046]
				MOVE	T4,OPMOVE	; [E046]
				GOTO	LCGIN0		; [E046]
	FI;						; [E046]
	IF LOP<TYPE> = INTEGER
				T.I	(LOP);
	THEN;..LOP AND SYM ARE BOTH OF TYPE INTEGER;
	  BEGIN
	    IF VALUE OF INCREMENT = 1
				F.LOCN	(T,SYM);
				CAIN	T,1;$
				TLNE	SYM,$AM-$IMM;$
				GOTO	FALSE;$
	    THEN;..INCREMENT = 1. DO THE INCREMENT WITH AN "AOS";
	      ;OPN _ "AOS";
				MOVE	T4,OPAOS;$
	    ELSE;..INCREMENT IS NOT 1;
	      IF VALUE OF INCREMENT = -1
				TLNN	SYM,$AM-$CT;$
				TLNN	SYM,$CT-$IMM;$
				GOTO	FALSE;$
				F.LOCN	(T2,SYM);
				ADD	T2,CONTAB;$
				MOVN	T,1(T2);$
				CAIE	T,1;$
				GOTO	FALSE;$
	      THEN;..INCREMENT = -1. DO THE INCREMENT WITH A "SOS";
	        ;OPN _ "SOS";
				MOVE	T4,OPSOS;$
	      ELSE;..INCREMENT IS NOT 1;
		;..GO TO CODE WHICH LOADS INCREMENT INTO AN ACC;
				GOTO	LCGIN1;$
	      FI
	    FI
	    LCGIN0:	; [E046] LABEL ADDED FOR ZERO CONSTANTS
	    IF LOP IS NOT SINGLE
				TN.SINGLE(LOP);
	    THEN;..WE ALREADY HAVE A PORTION FOR LOP;
	      REOPEN(LOP);
	    FI
	    IF PREFACC = 0
				SKIPE	0,PREFACC;$
				GOTO	FALSE;$
	    THEN;..CAN'T AOS OR SOS INTO AC0. CHANGE IT TO AC1
		; [E046] UNLESS OPCODE = MOVE, WHEN AC0 IS O.K.
				TLNE	T4,174000	; [E046]
				AOS	0,PREFACC;$
	    FI
	    ;EMITCODE(OPN,PREFACC,LOP);
				MOVE	T,T4;$
				MOVE	T1,PREFACC;$
				HRLI	T1,1;$
				EMITCODE(LOP);
	    ;LEX(SYM) _ (EXPR,SAME,SIMPLE,PREFACC);
				TLZ	SYM,$KIND!$STATUS!$AM;$
				TLO	SYM,$EXP!$SIM!$ACC;$
				HRR	SYM,PREFACC;$
	  ENDD
	ELSE;..LOP<TYPE> MUST BE REAL;
	  BEGIN
	    IF SYM<TYPE> = INTEGER
				T.I	(SYM);
	    THEN;..CONVERT SYM TO REAL;
	      ;CONVERT(REAL,SYM);
				MOVEI	T,$R;$
		CONVERT;
	    FI
		LCGIN1:
		IF SYM IS A POINTER
				T.PTR	(SYM);
		THEN;..MUST LOAD ITS VALUE;
		  ;GO TO NEXT "THEN";
				GOTO	LCGIN2;$
		FI
		IF SYM = SINGLE
				T.SINGLE(SYM);
		THEN;..INCREMENT IS NOT YET IN AN ACC. LOAD IT;
		  LCGIN2:
		  ;..LOAD INCREMENT INTO PREFERRED REGISTER (GIVEN BY PREFACC);
				MOVE	T2,PREFACC;$
		    LOAD(SYM,@T2);
		ELSE;..VALUE OF INCREMENT IS ALREADY IN AN ACC;
		  IF SYM<LOCN> = LOP<LOCN>
				F.LOCN	(T,SYM);
				F.LOCN	(T1,LOP);
				CAMN	T,T1;$
				TLNE	LOP,$AMAC;$
				GOTO	FALSE;$
		  THEN;..ACC CONFLICT. RELOAD INCREMENT INTO PREFERRED ACC;
				GOTO	LCGIN2;$
		  FI
		FI
	    IF LOP = SINGLE
				T.SINGLE(LOP);
	    THEN;..NO PORTION NEEDED FOR LOP;
	      REOPEN(SYM);
	    ELSE;..BOTH LOP AND SYM ARE PORTIONS;
	      MERGEPORTIONS;
	    FI
	    ;..GENERATE AN ADD-TO-BOTH;
				F.TRANK	(T,SYM);
				MOVE	T,OPADDB(T);$
				F.LOCN	(T1,SYM);
				PLUNK	(LOP);
	    ;LEX(SYM) _ (EXPR,SAME,SIMPLE,ACC);
				TLZ	SYM,$KIND!$STATUS!$AM;$
				TLO	SYM,$EXP!$SIM!$ACC;$
	  ENDD
	FI
	CLOSE(SYM);
	COMBASSIGN;
      ENDD
    FI
  FI
ENDD	; CGINCR
	SUBTTL	CODE GENERATION ROUTINES	* CHECKARITH *

PROCEDURE CHECKARITH;

	;..FORCE BINARY OPERANDS TO HAVE MATCHING ARITHMETIC TYPES;
	    ;  ERROR FLAG (T) IS SET IF TYPES ARE NOT ARITHMETIC
	    ;  (INTEGER OR REAL OR LONG REAL);
	;  ON ENTRY, OPERAND LEXEMES ARE IN LOP AND SYM.
	;  IF TYPES OF OPERANDS ARE NOT ALIKE, CODE IS GENERATED TO
	    ;  CONVERT ONE OPERAND TO THE TYPE OF THE OTHER
	    ;  (IN THE ORDER INTEGER => REAL => LONG REAL).
	;  OPERAND PORTIONS ARE LEFT CLOSED WITH LEXEMES 
	    ;  IN LOP AND SYM.

BEGIN
  IF SYM<TYPE> IS INT OR REAL OR LONG REAL
	; AND LOP<TYPE> IS INT OR REAL OR LONG REAL;
				TLNE	SYM,$IRLR;$
				T.IRLR	(LOP);
  THEN;..OPERANDS HAVE TYPES WHICH CAN BE MATCHED;
    BEGIN
      IF SYM<TYPE> NEQ LOP<TYPE>
				F.TYPE	(T,SYM);
				F.TYPE	(T1,LOP);
				CAMN	T,T1;$
				GOTO	FALSE;$
      THEN;..TYPES DO NOT MATCH -- GENERATE CODE TO MATCH THEM;
        BEGIN
          IF SYM<TYPE> LSS LOP<TYPE>
				CAML	T,T1;$
				GOTO	FALSE;$
          THEN
	  ;..CONVERT SYM TO THE TYPE OF LOP;
				PUSHJ	SP,TCHECK	; [E044]
          ELSE
	  ;..CONVERT LOP TO THE TYPE OF SYM;
	  ;..MUST REVERSE LEXEMES AND LEXEXES BECAUSE CONVERT WORKS ON SYM;
				EXCH	LOP,SYM;$
				MOVNI	REV,SYM+LOP(REV);$
				PUSHJ	SP,TCHECK	; [E044]
				EXCH	SYM,LOP;$
				MOVNI	REV,SYM+LOP(REV);$
          FI;
	ENDD;
      FI;
      EDIT(044);Don't force constants to D.P. unnecessarily
      ; TYPES MATCH - CHECK FOR PSEUDO-LONG REAL	; [E044]
      IF TYPE = LONG REAL				; [E044]
				T.LR	(SYM)		; [E044]
      THEN;						; [E044]
	BEGIN;						; [E044]
	  IF SYM = PSEUDO-LONG REAL CONSTANT & LOP # CONSTANT
				TLNE	LOP,$CONST	; [E044]
				T.CONST	(SYM)		; [E044]
				TLNE	SYM,$CT-$IMM	; [E044]
				TLNN	SYM,$DEC	; [E044]
				GOTO	FALSE		; [E044]
				F.LOCN	(T2,SYM)	; [E044]
				ADD	T2,CONTAB	; [E044]
				SKIPL	T4,3(T2)	; [E044]
				GOTO	FALSE		; [E044]
	  THEN;..CONVERT SYM TO A GENUINE LONG REAL CONSTANT
				MOVE	T3,2(T2)	; [E044]
				TLZ	T4,(1B0)	; [E044]
				TOCT	(2,SYM)		; [E044]
	  ELSE;						; [E044]
	    BEGIN;					; [E044]
	      IF LOP = PSEUDO-LONG REAL CONSTANT & SYM # CONSTANT
				TLNE	SYM,$CONST	; [E044]
				T.CONST	(LOP)		; [E044]
				TLNE	LOP,$CT-$IMM	; [E044]
				TLNN	LOP,$DEC	; [E044]
				GOTO	FALSE		; [E044]
				F.LOCN	(T2,LOP)	; [E044]
				ADD	T2,CONTAB	; [E044]
				SKIPL	T4,3(T2)	; [E044]
				GOTO	FALSE		; [E044]
	      THEN;..CONVERT LOP TO A GENUINE LONG REAL CONSTANT
				MOVE	T3,2(T2)	; [E044]
				TLZ	T4,(1B0)	; [E044]
				TOCT	(2,LOP)		; [E044]
	      FI;					; [E044]
	    ENDD;					; [E044]
	  FI;						; [E044]
	ENDD;						; [E044]
      FI;						; [E044]
    ;T_FALSE	; TURN ERROR FLAG OFF
				SETZ	T,0;$
    ENDD;
  ELSE;..TYPES CANNOT BE MATCHED;
  ;T_TRUE	; SET ERROR FLAG ON
				SETO	T,0;$
  FI;
ENDD	; CHECKARITH
TCHECK:	Edit(044)  ;New routine to match type of SYM to LOP
BEGIN;							; [E044]
  IF LOP = PSEUDO-LONG CONSTANT & SYM # CONSTANT	; [E044]
				TLNN	LOP,<$TYPE-$LR>!$CONST;
				TLNN	SYM,$CONST	; [E044]
				GOTO	FALSE		; [E044]
				TLNE	LOP,$CT-$IMM	; [E044]
				TLNN	LOP,$DEC	; [E044]
				GOTO	FALSE		; [E044]
				F.LOCN	(T2,LOP)	; [E044]
				ADD	T2,CONTAB	; [E044]
				SKIPL	A1,3(T2)	; [E044]
				GOTO	FALSE		; [E044]
  THEN;  FIRST WE MUST TRUNCATE LOP TO A REAL		; [E044]
				MOVE	T3,A0		; [E044]
				MOVE	A0,2(T2)	; [E044]
				TLZ	A1,(1B0)	; [E044]
				PUSHJ	SP,CTLRR	; [E044]
				EXCH	T3,A0		; [E044]
				TLZ	LOP,$TYPE	; [E044]
				TLO	LOP,$R		; [E044]
				EXCH	LOP,SYM		; [E044]
				PUSHJ	SP,.STOCON	; [E044]
				EXCH	LOP,SYM		; [E044]
  ;  IF SYM<TYPE> # REAL, SKIP INTO THE "ELSE" CLAUSE	; [E044]
				TLNN	SYM,$TYPE-$R	; [E044]
  ELSE;  WE NEED TO CONVERT SYM TO THE TYPE OF LOP	; [E044]
				HLRZ	T,LOP		; [E044]
				ANDI	T,$TYPE		; [E044]
				PUSHJ	SP,.CONVERT	; [E044]
  FI;							; [E044]
				POPJ	SP,		; [E044]
ENDD;	TCHECK						; [E044]
	SUBTTL	CODE GENERATION ROUTINES	* COMBASSIGN *

PROCEDURE COMBASSIGN;

	;..GENERATE THE NEW LEXEX RESULTING FROM AN ASSIGNMENT;
	    ;  NEW LEXEX COMES FROM THOSE FOR SYM AND LOP.
	;  COMPUTES EXTYPE, BLOCK LEVEL, STACK ADDRESS, AND
	    ;  COMPOSITE NAME FOR THE ASSIGNMENT EXPRESSION.
	;  RESULT LEXEX IS ALWAYS THAT BELONGING TO SYM;

BEGIN
  IF LEXEX(SYM) GEQ 0
				F.BL	(T1,SYM);
				JUMPL	T1,FALSE;$
  THEN;..SYM HAS EXTYPE "V".  SET IT TO "P" AND SET C.N. _ 0;
    BEGIN
      ;SYM<BLOCK LEVEL> _ -1  (I.E., EXTYPE _ "P");
				HRLZI	T2,777000;$
				S.BL	(T2);
      ;SYM<COMPOSITE NAME> _ 0;
				SETZ	T2,0;$
				S.CN	(T2);
    ENDD
  FI
  ;SYM<COMPOSITE NAME> _ SYM<C. NAME> OR LOP<C. NAME>;
				F.CN	(T2,LOP);
				F.CN	(T1,SYM);
				OR	T2,T1;$
				S.CN	(T2);
  ;..BLOCK LEVEL _ MIN(BLOCK LEVELS); .... (SETS EXTYPE ALSO);
  IF LOP<BLOCK LEVEL> LSS SYM<BLOCK LEVEL>
				F.BL	(T3,LOP);
				F.BL	(T2,SYM);
				CAML	T3,T2;$
				GOTO	FALSE;$
  THEN
    ;SYM<BLOCK LEVEL> _ LOP<BLOCK LEVEL>;
				S.BL	(T3);
  FI
  ;..STACK ADDRESS _ SUM OF STACK ADDRESSES;
  ;T2 _ LOP<STACK ADDRESS> + SYM<STACK ADDRESS>;
				F.SA	(T2,LOP);
				F.SA	(T1,SYM);
				ADD	T2,T1;$
  IF STACK ADDRESS GEQ 2^9 (512)
				TLNN	T2,$LEXBL;$
				GOTO	FALSE;$
  THEN;..STACK OVERFLOW ERROR;
    FAIL(66,FRIED,SYM,STACK-ADDRESS OVERFLOW);
  ELSE;..SYM<STACK ADDRESS> _ T2;
				S.SA	(T2);
  FI
ENDD	; COMBASSIGN
	SUBTTL	CODE GENERATION ROUTINES	* COMBLEX *

PROCEDURE COMBLEX

	;..GENERATE THE NEW LEXEX RESULTING FROM A BINARY OPERATION;
	;  NEW LEXEX COMES FROM THOSE FOR SYM AND LOP.
	;  COMPUTES EXTYPE, BLOCK LEVEL, STACK ADDRESS, AND
	    ;  COMPOSITE NAME FOR THE RESULT EXPRESSION.
	;  RESULT LEXEX IS ALWAYS THAT BELONGING TO SYM;

BEGIN
  IF EXTYPE(LOP) = EXTYPE(SYM)
				F.BL	(T3,LOP);
				F.BL	(T2,SYM);
				MOVE	T,T2;$
				XOR	T,T3;$
				JUMPL	T,FALSE;$
  THEN;..EXTYPES MATCH  (BOTH "P" OR BOTH "V");
    ;SYM<COMPOSITE NAME> _ LOP<C. NAME> OR SYM<C. NAME>;
				F.CN	(T1,LOP);
				F.CN	(T,SYM);
				OR	T,T1;$
				S.CN	(T);
  ELSE;..EXTYPES DO NOT MATCH. RESULT GETS C.N. OF TYPE "P" LEXEME;
    IF LOP<LEXEX> LSS 0
				JUMPGE	T3,FALSE;$
    THEN;..LOP HAS EXTYPE "P". GRAB ITS C. NAME FOR THE RESULT;
      ;SYM<COMPOSITE NAME> _ LOP<C. NAME>;
				F.CN	(T,LOP);
				S.CN	(T);
    ;..ELSE SYM HAS E