Google
 

Trailing-Edge - PDP-10 Archives - BB-D608D-SB_1982 - algfun.mac
There are 8 other files named algfun.mac in the archive. Click here to see a list.
;
;
;COPYRIGHT (C) 1975,1981,1982 BY
;DIGITAL EQUIPMENT CORPORATION, MAYNARD, MASS.
;
;
;THIS SOFTWARE IS FURNISHED UNDER A LICENSE AND MAY BE USED AND COPIED
;ONLY  IN  ACCORDANCE  WITH  THE  TERMS  OF  SUCH LICENSE AND 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.  NO TITLE TO AND OWNERSHIP OF THE  SOFTWARE  IS  HEREBY
;TRANSFERRED.
;
;THE INFORMATION IN THIS SOFTWARE IS SUBJECT TO CHANGE WITHOUT  NOTICE
;AND  SHOULD  NOT  BE  CONSTRUED  AS A COMMITMENT BY DIGITAL EQUIPMENT
;CORPORATION.
;
;DIGITAL ASSUMES NO RESPONSIBILITY FOR THE USE OR RELIABILITY  OF  ITS
;SOFTWARE ON EQUIPMENT WHICH IS NOT SUPPLIED BY DIGITAL.
;
;
;
;SUBTTL CODE GENERATION ROUTINES PART 2

; 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 CTIR,CTILR,CTRI,CTRLR,CTLRI,CTLRR
INTERN LFADC,LFSBC,LFMPC,LFDVC
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
EXTERN	SRCEMC,TARGMC			; SOURCE/TARGET FLAGS
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


CTIR:	SKIPN	SRCEMC		; IS IT A KI10 ?
	JRST	CTIR1		; NO
	FLTR	A0,A0
	POPJ	SP,

CTIR1:				; THIS WAY ON A KA
	IDIVI	A0,400000	; SEPARATE HIGH AND LOW HALVES
	JUMPE	A0,.+2		; ONLY 18 BITS?
	TLC	A0,254000	; NO -- SET UP HIGH HALF EXPONENT
	TLC	A1,233000	; SET UP LOW HALF EXPONENT
	FADR	A0,A1		; AND ADD BITS TOGETHER
	POPJ	SP,


CTILR:				;[172]
	SKIPE	SRCEMC		;[172] ARE WE A KA PROCESSOR?
	 JRST	CTILR1		;[172] NO, SKIP KA CODE
	IDIVI	A0,400000	; SEPARATE HIGH AND LOW HALVES
	JUMPE	A0,.+2		; ONLY 18 BITS?
	TLC	A0,254000	; NO -- SET UP HIGH HALF EXPONENT
	TLC	A1,233000	; SET UP LOW HALF EXPONENT
	FADL	A0,A1		; AND ADD BITS TOGETHER
	SKIPN	TARGMC		; IF TARGET IS A KA, FINISH
	POPJ	SP,
	TLZ	A1,777000	; IF KI10 TARGET, WIPE OUT LOW WORD EXPONENT
	LSH	A1,10		; AND SHIFT UP FRACTION
	POPJ	SP,

CTILR1:	SETZ	A1,		;[172] HERE IF WE ARE A KI OR KL
	ASHC	A0,-8		;[172] CLEAR SECOND WORD AND SHIFT
	TLC	A0,243000	;[172] INSERT EXPONENT
	DFAD	A0,[EXP 0,0]	;[172] NORMALIZE
	SKIPE	TARGMC		;[172] IF TARGET MACHINE IS KI OR KL
	 POPJ	SP,		;[172] THEN FINISHED, SO RETURN
	LSH	A1,-10		;[172] TARGET IS KA, SHIFT SECOND MANTISSA
	SKIPN	A1		;[172] FAKE RESULTS OF A "FADL" INSTRUCTION
	 POPJ	SP,		;[172] DONE IF SECOND WORD IS ZERO
	PUSH	SP,A2		;[172] ELSE GET A REGISTER TO MAKE EXPONENT IN
	LDB	A2,[POINT 8,A0,8] ;[172] GET HIGH-ORDER EXPONENT
	CAIGE	A2,200		;[172] SKIP IF POSITIVE EXPONENT
	 MOVN	A2,A2		;[172] ELSE MAKE IT POSITIVE
	ANDI	A2,377		;[172] AND OFF ANY EXTRA BITS THIS CAUSED
	SUBI	A2,^D27		;[172] SUBTRACT 27 BITS OF HIGH-ORDER MANTISSA
	SKIPGE	A2		;[172] IF NOTHING LEFT FOR LOW ORDER,
	 SKIPA	A1,0		;[172] THEN FORCE SECOND WORD TO ZERO
	  DPB	A2,[POINT 8,A1,8] ;[172] ELSE INSERT SECOND EXPONENT
	POP	SP,A2		;[172] PUT BORROWED REGISTER BACK
	POPJ	SP,		;[172] AND RETURN (WHEW!)
	;
	Edit(153);  Perform rounding correctly.
	;
CTRI:	FAD	A0,[		; [E153] CTRI -- ADD 0.5
	exp	0.5]
	MULI	A0,000400	; SEPARATE EXPONENT AND MANTISSA
	EXCH	A0,A1
	TSC	A1,A1		; FIX UP EXPONENT
	HRREI	A1,-243(A1)	; [E130] ADJUST EXPONENT
	JUMPG	A1,.+3		; [E130] TOO BIG - OVERFLOW
	ASH	A0,(A1)		; [E130] SHIFT MANTISSA TO FORM INTEGER
	POPJ	SP,
	FAIL(128,SOFT,SYM,INTEGER TOO LARGE)	; [E130]
	JUMPL	A0,.+3		; [E130] POSITIVE OR NEGATIVE ?
	HRLOI	A0,377777	; [E130] POSITIVE - SET ALL ONES
	POPJ	SP,		; [E130]
	MOVSI	A0,(1B0)	; [E130] NEGATIVE
	POPJ	SP,		; [E130]

CTRLR:	MOVEI	A1,0		; ZERO LOW ORDER WORD
	POPJ	SP,

CTLRI:	SELMCC(CTLRI1,CTLRI2,CTLRI3)	; DECIDE THE MIX
	DFAD	A0,[
	EXP	0.5,0.0]
	GOTO	CTLRI4

CTLRI1:	MOVE	A2,A1		; STRICTLY KA
	FADL	A0,[0.5]
	UFA	A1,A2
	FADL	A0,A2
	GOTO	CTLRI4

CTLRI2:	DMOVE	A3,[
	EXP	0.5,0.0]
	PUSHJ	SP,LRADAI

CTLRI4:	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
	SKIPN	TARGMC		; ONLY SHIFT FOR A KA TARGET
	LSH	A1,10		; IT'S FOR KA10,SO  SHIFT UP LOW ORDER FRACTION
	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,

CTLRR:	SELMCC(CTLRR1,CTLRR2,CTLRR3)	; LONG REAL TO REAL
				; KI TARGET AND SOURCE
	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,

CTLRR1:				; KA TARGET
	JUMPL	A0,.+3		; NEGATIVE NUMBER?
	FADR	A0,A1		; NO -- ADD HIGH AND LOW WORDS TOGETHER
	POPJ	SP,
	DFN	A0,A1		; YES -- NEGATE
	FADR	A0,A1		; AND ADD HIGH AND LOW WORDS TOGETHER
	MOVN	A0,A0		; NEGATE RESULT
	POPJ	SP,

CTLRR2:				; KI TARGET - KA PROCESSOR
	JUMPGE	A0,CTLRRC	; ONLY A PROBLEM IF -VE
	SETCM	A0,A0
	MOVNS	A1
	TLZ	A1,(1B0)
	JUMPN	A1,CTLRRD
	AOJA	A1,CTLRRD
SUBTTL	LONGREAL COMPILE-TIME ARITHMETIC
;
;	THIS CODE SORTS OUT THE TARGET AND SOURCE PROCESSORS
;	AND PERFORMS THE BASIC OPERATIONS OF + - * /
;	ACCCORDINGLY.
;
LFADC:				; ADDITION
	SELMCC(LRADAA,LRADAI,LRADII)
LRADII:	DFAD	A0,A3
	POPJ	SP,

LFSBC:				; SUBTRACTION
	SELMCC(LRSBAA,LRSBAI,LRSBII)
LRSBII:	DFSB	A0,A3
	POPJ	SP,

LFMPC:				; MULTIPLICATION
	SELMCC(LRMPAA,LRMPAI,LRSBII)
LRMPII:	DFMP	A0,A3
	POPJ	SP,

LFDVC:					; DIVISION
	SELMCC(LRDVAA,LRDVAI,LRDVII)
LRDVII:	DFDV	A0,A3
	POPJ	SP,
SUBTTL	LONG REAL ARITHMETIC SUBROUTINES

; ON ENTRY:
; THE LEFT HAND OPERAND IS IN A0,A1
; THE RIGHT HAND OPERAND IS IN (A3,A4) 
; THE LINK IS ON THE STACK

; ON EXIT, THE RESULT IS IN A0,A1


LRADAA:	UFA	A1,A4		; ADD LOW ORDER PARTS IN A2
	FADL	A0,A3		; ADD HIGH ORDER PARTS IN A0,A1
LFAD1:	UFA	A1,A2		; ADD LOW PART OF HIGH SUM TO A2
	FADL	A0,A2		; ADD LOW SUM TO HIGH SUM
	JFOVO	LFERR		; ERROR IF UNDER- OR OVERFLOW
	POPJ	SP,0


LRSBAA:	DFN	A0,A1		; NEGATE LEFT HAND OPERAND
	PUSHJ	SP,LFADC	; PERFORM A LONG ADD
	DFN	A0,A1		; AND NEGATE RESULT
	POPJ	SP,0


LRMPAA:	MOVE	A2,A0		; COPY HIGH WORD OF LEFT HAND OPERAND
	FMPR	A2,A4		; FORM ONE CROSS PRODUCT IN A2
	FMPR	A1,A3		; FORM OTHER CROSS PRODUCT IN A1
	UFA	A1,A2		; ADD CROSS PRODUCTS IN A2
	FMPL	A0,A3		; FORM HIGH ORDER PRODUCT IN A0,A1
	JRST	LFAD1		; FINISH UP LONG ADD


LRDVAA:	FDVL	A0,A3		; GET HIGH PART OF QUOTIENT
	MOVN	A2,A0		; AND NEGATE IT
	FMPR	A2,A4		; MULTIPLY BY LOW PART OF DIVISOR
	UFA	A1,A2		; ADD REMAINDER
	FDVR	A2,A3		; DIVIDE SUM BY HIGH PART OF DIVISOR
	FADL	A0,A2		; ADD RESULT TO ORIGINAL QUOTIENT
	JFOVO	LFERR		; ERROR IF UNDER- OR OVERFLOW
	POPJ	SP,0

LFERR:
	FAIL(75,FRIED,SYM,OVERFLOW IN LONG REAL OPERATION ON CONSTANTS);
	POPJ	SP,0		; ERROR EXIT

SUBTTL	LONG REAL KI10 ARITHMETIC SIMULATION FOR KA10
; THESE ROUTINES ADD OR SUBTRACT TWO DOUBLE PRECISION
; NUMBERS.  EACH NUMBER IS COMPOSED OF 8 BITS OF EXPONENT
; IN THE HI ORDER WORD WITH THE REMAINING 27 HI ORDER BITS
; AND THE 33 FIRST ARITHMETIC BITS OF THE LO ORDER AS THE
; MANTISSA.  THE LAST 2 LO ORDER BITS ARE UNUSED.  THE
; ANSWER IS RETURNED IN AC 0-1 AND THE ARGUMENTS ARE IN
;  A0-1 AND A3-4 RESPECTIVELY



LREXP1:	POINT	^D9,A0,^D8		;  EXPONENT FOR ARG1

LREXP2:	POINT	^D9,A3,^D8		;  EXPONENT FOR ARG2

SGNA0==1
SGNA3==2
BITNEG==1B18
BIT1==200000
BIT2==100000
BITCRY==1000
BITEST==3400

LRLOW0:	377777777777

DEFINE	MAKNEG(A)<
	SETCM	A,A
	MOVNS	A+1
	TDNN	A+1,LRLOW0
	AOS	A
>
LRSBAI:	MAKNEG(A3)		; ENTRY FOR SUBTRACT

LRADAI:	JUMPE	A3,.+4		; ENTRY FOR ADD
	JUMPN	A0,GA		; NEITHER ARG IS ZERO, SO GO ADD
	MOVE	A0,A3		; A0=0 MEANS ARG2 IS ANSWER
	MOVE	A0+1,A3+1	; RETURN IT TO EITHER AC OR MEM
	POPJ	SP,

GA:	PUSH	SP,A7
	LDB	A2,LREXP1	; ARG1 EXP AND SIGN
	LDB	A5,LREXP2	; ARG2 EXP AND SIGN
	SKIPG	A0		; MAKE EXPS +
	ANDCAI	A2,777		; ...
	SKIPG	A3		; ...
	ANDCAI	A5,777		; ...
	MOVE	A6,A5		; GET EXP DIFFERENCE
	SUB	A6,A2		; ...
	SKIPLE	A6		; SAVE HIGHER EXP
	AOS	A2,A5		; SAVED IN A2
	TLZ	A7,SGNA0+SGNA3	; MARK SIGNS BEFORE SHIFT
	JUMPGE	A0,A0PL		; SKIP HAIR IF A0 +
	TLO	A7,SGNA0	; MARK SIGN = -
	MAKNEG	A0

A0PL:	JUMPGE	A3,A3PL		; SKIP HAIR IF A3 = +
	TLO	A7,SGNA3	; MARK SIGN = -
	MAKNEG	A3

A3PL:	TLZ	A0,777000	; REMOVE EXPS
	TLZ	A3,777000	; ...
	JUMPLE	A6,SHFT2	; SHIFT ARG2
	MOVNS	A6		; SHIFT ARG1 RIGHT
	ASHC	A0,(A6)		; UNNORMALIZE ARG1
CADD:	TLNN	A7,SGNA0	; WAS A0 =-?
	JRST	A0WPL		; NO, SKIP RECOMPL
	TLNE	A7,SGNA3	; IF BOTH WERE NEG,...
	JRST	BOTHN		; DON'T RECOMPL EITHER
	MAKNEG	A0

A0WPL:	TLNN	A7,SGNA3	; WAS A3=-?
	JRST	A3WPL		; NO, SKIP RECOMPL
	MAKNEG	A3

A3WPL:	TLZ	A0,477000	; SET TESTABLE BITS
	TLZ	A3,477000	; TURN OTHERS OFF
	JCRY1	.+1		; TURN OFF OVFLO FLAG
	ADD	A0+1,A3+1	; LO ORDER ADD
	JCRY1	[
	AOJA	A0,TADD]	; ADD IN HI ORDER CARRY

TADD:	ADD	A0,A3		; HI ORDER ADD
	TLNE	A0,BIT2		; IS CARRY BIT TRUE
	TLC	A0,BITCRY	; NO, COMPL. IT
	TLZN	A0,BIT1		; IS SUM -
	JRST	NORMA		; NO ON FIRST GLANCE
	TLZE	A0,BIT2		; ...
	TLNE	A0,BITCRY	; ...
	PUSHJ	SP,NEG1		; SUM=-,GO MAKE IT +


NORMA:	TRO	A2,200000	; PROTECT AGAINST BORROWS FROM BITNEG
	TLNN	A0,1000		; SKIP UNNORM IF NOT NEEDED
	SOSA	A2		; BUT TELL THE EXPONENT ABOUT IT
	ASHC	A0,-1		; THERE WAS SOMETHING THERE

D.MORM:	TRO	A2,200000	; PROTECT AGAINST BORROWS FROM BITNEG
	TLZ	A0,777000	; NO STRAY BITS
	JUMPN	A0,LOOPA+1	; CHECK FOR ZERO
	TDNN	A0+1,LRLOW0	; ...
	JRST	2,@[
	XWD	0,RET0]		; RETURN ZERO ANSWER
	SKIPA			; ENTER NORMALIZE ROUTINE
LOOPA:	ASHC	A0,1		; 1 BIT NORMALIZE
	TLNN	A0,400		; IS NORMALIZE DONE?
	SOJA	A2,LOOPA	; IF NOT, SUB1 FROM EXP
	TRNE	A2,BITEST	; DID FP OV/UNDER FLO OCCUR?
	JRST	[
	TRNN	A2,040000	; UNDERFLOW?
	JRST	OVTM2		; NO, OVERFLOW
	JRST	UFLOW]		; YES
	TRZE	A2,BITNEG	; SHOULD ANS BE -
	PUSHJ	SP,NEG2		; GO MAKE IT SO
	DPB	A2,LREXP1	; STORE EXP AND SIGN

OVTM1:	JRST	2,@[OVTA]	; CLEAR AR FLAGS	


OVTM2:	TRZ	A2,400
	TRZE	A2,BITNEG	; SHOULD ANS BE -
	PUSHJ	SP,NEG2		; GO MAKE IT SO
	DPB	A2,LREXP1	; STORE EXPONENT AND SIGN
	JRST	2,@[XWD 440200,OVTA]

RET0:	SETZB	A0,A0+1		; RETURN ANS=0

OVTA:	TLZ	A0+1,400000	; SET LOW SIGN +VE

LRKAEX:	POP	SP,A7
	POPJ	SP,


UFLOW:	TRZ	A2,400
	TRZE	A2,BITNEG
	PUSHJ	SP,NEG2
	DPB	A2,LREXP1
	JRST	2,@[XWD 440300,OVTA]

SHFT2:	ASHC	A3,0(A6)	; UNNORMALIZE ARG2
	AOJA	A2,CADD		; INDICATE UNNORMALIZATION


NEG2:	ANDCAI	A2,777		; MAKE EXP -

NEG1:	TRO	A2,BITNEG	; SET MARKER FOR -
	MOVNS	A0+1		; TWOS COMPL
	SETCMM	A0		; ...
	TDNN	A0+1,LRLOW0	; ...
	AOS	A0		; ...
	JRST	LRKAEX		; RESTORE A7 & RETURN


BOTHN:	TRO	A3,BITNEG	; SINCE BOTH WERE NEG, ANS ...
	JRST	A3WPL		; MUST BE NEG

; BASED ON THE FORTRAN ROUTINES IN DPSIM.MAC
; THESE ROUTINES MULTIPLY TWO DOUBLE PRECISION FLOATING
; NUMBERS.THE ARGUMENTS ARE IN  A0-1 AND A3-4.


LRMPAI:	PUSH	SP,A7
	JUMPE	A3,RET0		; ZERO PRODUCT
	JUMPL	A3,NEG2A	; IF -, PICK UP COMPL

NEG2RT:	MOVE	A7,A0		; GET ARG1
	JUMPE	A0,RET0		; ZERO PRODUCT
	XOR	A7,A0		; GET ANSWER SIGN
	JUMPL	A0,NEG1A	; IF -, PICK UP ARG1 COMPL

NEG1RT:	LDB	A2,LREXP1	; GET EXPS
	LDB	A5,LREXP2	; ...
	ADDI	A2,-200(A5)	; GET PREDICTED EXP (EXCESS 200)
	ANDI	A2,077777	; MASK EXPONENT TO 15 BITS
	TLNE	A7,400000	; IF RESULT SHOULD BE NEG, ...
	TRO	A2,BITNEG	; SET INDICATOR
	HRL	A7,A2		; SALT AWAY PROPOSED EXP
	TLZ	A0,777000	; REMOVE EXPS
	TLZ	A3,777000	; ...
	ASHC	A0,5		; MAKE SEMI-PRODUCTS MORE SIGNIFICANT
	ASHC	A3,5		; ...
	MUL	A0+1,A3		; FORM LO ORDER SEMI-PRODS
	MUL	A3+1,A0		; ...
	MOVE	A5,A0+1		; PROTECT FROM CREEPING SIGNIFICANCE
	MUL	A0,A3		; HI ORDER SEMI-PROD
	JCRY1	.+1		; CLEAR FLAG
	ADD	A0+1,A5		; FIRST LO SEMI-PROD
	JCRY1	[AOJA A0,A1RT]	; ADD IN CARRY

A1RT:	ADD	A0+1,A3+1	; SECOND LO SEMI-PROD
	JCRY1	[AOJA A0,A3RT]	; ADD IN CARRY

A3RT:	TRNE	A0+1,2		; PATCH FOR MORE PRECISION
	ADDI	A0+1,2
	ASHC	A0,-2
	HLRZ	A2,A7		; RECLAIM EXP
	JRST	D.MORM		; GO NORMALIZE AND RETURN

NEG2A:	SETCM	A3,A3		; TW0S COMPL ARG2
	MOVNS	A3+1		; ...
	TDNN	A3+1,LRLOW0	; ...
	AOJA	A3,NEG2RT	; ...
	JRST	NEG2RT	; ...


NEG1A:	SETCM	A0,A0		; TWOS COMPL ARG2
	MOVNS	A0+1		; ...
	TDNN	A0+1,LRLOW0	; ...
	AOJA	A0,NEG1RT	; ...
	JRST	NEG1RT		; ...

; THESE ROUTINES FORM THE QUOTIENT OF TWO DOUBLE
; PRECISION FLOATING POINT NUMBERS. THE DIVIDEND
; IS IN A0-1 THE DIVISOR IS IN A3-4.  THE QUOTIENT IS RETURNED
; IN A0-1.


LRDVAI:	PUSH	SP,A7
	JUMPL	A3,NEG2B	; IF -, PICK UP COMPL

NEG2RB:	MOVE	A7,A0		; GET AT DIVIDEND
	XOR	A7,A0		; SIGN OF A7= SIGN OF QUOTIENT
	JUMPL	A0,NEG1B	; IF A0=-, PICK UP COMPL

NEG1RB:	TDNE	A0,[777777777]	; IS DIVIDEND ZERO?
	JRST	RET0
	TDNN	A3,[777777777]	; OR HAS 11TH COMMANDMENT BEEN VIOLATED?
	JRST 2,@[XWD 440240,RET0]	; SET DIVIDE CHECK, RETURN 0
	LDB	A2,LREXP1	; GET EXPS
	LDB	A5,LREXP2	; ...
	SUBI	A2,-201(A5)	; GET EXP DIFFERENCE
	ANDI	A2,077777	; MASK RESULTANT EXP TO 15 BITS
	TLNE	A7,400000	; MARK QUOTIENT SIGN
	TRO	A2,BITNEG	; ...
	HRL	A7,A2		; SAVE PROPOSED EXP
	TLZ	A0,777000	; GRONK EXPS
	ASHC	A3,8		; AND MAKE QUOTIENT TO RIGHT PLACE

ARITH:	DIV	A0,A3		; FIRST DIVISION
	MUL	A3+1,A0		; FORM Q1*D
	SETCA	A3+1,		; TWO'S COMPL OF Q1*D
	TDNN	A3+2,LRLOW0	; ...
	AOS	A3+1		; ...
	ADD	A0+1,A3+1	; A0+1 CONTAINS A0+1-Q1*D
	DIV	A0+1,A3		; SECOND DIVISION
	HLRZ	A3,A7		; GET EXP
	JUMPGE	A0+1,D.MORM	; GO NORMALIZE IF POSITIVE
	SOJA	A0,D.MORM	; ADJUST BEFORE NORMALIZE IF NEGATIVE
NEG2B:	SETCM	A3,A5		; TWOS COMPL OF DIVISOR
	MOVNS	A3+1	; ...
	TDNN	A3+1,LRLOW0	; ...
	AOJA	A3,NEG2RB	; ...
	JRST	NEG2RB		; ...


NEG1B:	SETCM	A0,A0		; TWOS COMPL OF DIVIDEND
	MOVNS	A0+1		; ...
	TDNN	A0+1,LRLOW0	; ...
	AOJA	A0,NEG1RB	; ...
	JRST	NEG1RB		; ...
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:	PUSHJ	SP,CTIR		; 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

	SELMCC(POWL2,POWL3,POWL1)

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


; KA TARGET ON KA SOURCE M/C

POWL2:	TRZE	A7,000001	; BIT SET IN EXPONENT?
	XCT	[
	PUSHJ	SP,LRDVAA
	PUSHJ	SP,LRMPAA](A6)
	JUMPE	A7,POWLEX	; EXIT IF FINISHED
	MOVE	A5,A3		; OTHERWISE SQUARE THE MULTIPLIER
	FMPR	A5,A4		;   LONG REAL MULTIPLY
	FMPR	A4,A3		;     (A3,A4) * (A3,A4)
	UFA	A4,A5
	FMPL	A3,A3
	UFA	A4,A5
	FADL	A3,A5
	LSH	A7,-1		; SHIFT BIT OUT OF EXPONENT
	JRST	POWL2		; AND CARRY ON


; KI SIMULATION ON KA M/C

POWL3:	TRZE	A7,1		; BIT SET IN EXPONENT ?
	XCT	[
	PUSHJ	SP,LRDVAI
	PUSHJ	SP,LRMPAI](A6)	; YES - DO MULTIPLY/DIVIDE
	JUMPE	A7,POWLEX	; FINISHED ?
	PUSH	SP,A0		; SAVE A0 & A1, BECAUSE 
	PUSH	SP,A1		;  SIMULATION ROUTINES USE THEM
	MOVE	A0,A3
	MOVE	A0+1,A3+1
	PUSHJ	SP,LRMPAI	; SQUARE THE EXPONENT - ANS IN A0,A1
	MOVE	A3,A0
	MOVE	A3+1,A0+1	; GET IT TO RIGHT PLACE
	POP	SP,A0+1
	POP	SP,A0
	LSH	A7,-1		; SHIFT BIT OUT OF EXPONENT
	JRST	POWL3

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;$
	EDIT(225)		;DELETE IN PROC. CGDOT IN ALGFUN [JBS 4/11/80]
;[225]				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 EXTYPE "P" AND ITS C.N. IS THAT OF THE RESULT;
    FI
  FI
  ;..BLOCK LEVEL _ MIN(BLOCK LEVELS); .... (SETS EXTYPE ALSO);
  IF LOP<BLOCK LEVEL> LSS SYM<BLOCK LEVEL>
				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	; COMBLEX
	SUBTTL	CODE GENERATION ROUTINES	* CONVERT *

PROCEDURE CONVERT

	;..GENERATES CODE TO CONVERT AN OPERAND TO A GIVEN TYPE;
	    ;  ON ENTRY, OPERAND LEXEME IS IN SYM;
	    ;  DESIRED TYPE IS IN T;
	;  IF OPERAND IS A CONSTANT, A NEW CONSTANT WILL BE GENERATED
	    ;  (AND NO CODE WILL BE PRODUCED).
	;  RESULT IS A CLOSED PORTION WHOSE LEXEME IS IN SYM;

BEGIN
OWN RESTYPE;	;..TEMP FOR THE DESIRED TYPE BITS;
  ;RESTYPE _ T;
				MOVEM	T,RESTYPE;$
  IF SYM = CONSTANT
				T.CONST	(SYM);
  THEN;..OPERAND IS A CONSTANT. WE CAN DO THE CONVERSION RIGHT NOW;
    BEGIN
      ;..SAVE A0 (GBREG);
				MOVE	T3,A0;$
      IF SYM = IMMEDIATE
				T.IMM	(SYM);
      THEN;..IMMEDIATE CONSTANT.  PUT VALUE INTO A0;
        BEGIN
	  IF SYM<TYPE> = INTEGER
				T.I	(SYM);
	  THEN
	    ;RH(A0) _ SYM<LOCN>;
				HRRZ	A0,SYM;$
	  ELSE;..IMMEDIATE REAL CONSTANT;
	    ;LH(A0) _ SYM<LOCN>;
				HRLZ	A0,SYM;$
	  FI
	ENDD
      ELSE;..NON-IMMEDIATE CONSTANT;
	BEGIN
	  ;T2 _ SYM<LOCN> + CONSTANT TABLE BASE;
				F.LOCN	(T2,SYM);
				ADD	T2,CONTAB;$
	  IF SYM<TYPE> = LONG REAL
				T.LR	(SYM);
	  THEN;..LONG CONSTANT;
	    ;..PUT CONSTANT INTO A0 AND A1;
	    ;.. * * * NOTE THAT A1 IS THE SAME REGISTER AS T;
				MOVE	A0,2(T2);$
				MOVE	A1,3(T2);$
				TLZ	A1,(1B0)	; [E044]
	  ELSE;..SHORT CONSTANT;
	    ;..PUT CONSTANT INTO A0;
				MOVE	A0,1(T2);$
	  FI
	ENDD
      FI
      ;..EXECUTE APPROPRIATE CONVERSION ROUTINE (RESULT GOES TO A0 (AND A1));
      ;.. * * * NOTE THAT A2 (T1) MAY BE CLOBBERED HERE;
				MOVE	T2,RESTYPE;$
				LSH	T2,-14;$
				F.TRANK	(T1,SYM);
				LSH	T1,2;$
				OR	T2,T1;$
				XCT	OPCONC-1(T2);$
      ;LEX(SYM) _ (SAME,RESTYPE,SAME,SAME);
				TLZ	SYM,$TYPE;$
				TSO	SYM,RESTYPE;$
      ;..WE NOW HAVE A NEW OPERAND. IT MUST BE PUT IN THE CONSTANT TABLE;
      ;..MOVE HIGH ORDER WORD OF CONSTANT TO T3 AND RESTORE A0;
				EXCH	T3,A0;$
      IF SYM<TYPE> = LONG REAL
				T.LR	(SYM);
      THEN;..LONG REAL CONSTANT;
	BEGIN
	  ;..MOVE LOW ORDER WORD OF CONSTANT TO T4;
				MOVE	T4,A1;$
				TLO	T4,(1B0)	; [E044]
	  ;..PUT IN CONSTANT TABLE (T3,T4);
	    TOCT(2,SYM);
	ENDD
      ELSE;..SHORT CONSTANT;
	STOCON;
      FI
    ENDD
  ELSE;..OPERAND IS NOT A CONSTANT;
    BEGIN
      ;..OPERAND MUST BE IN AC0 (AND 1) FOR THE CONVERSION ROUTINES;
      IF SYM IS A POINTER
				T.PTR	(SYM);
      THEN;..LOAD ITS VALUE INTO AC0;
				GOTO	LCONV1;$
      FI
      IF VALUE OF SYM NOT IN AC0
				TN.AC0	(SYM);
      THEN;..PUT IT IN;
	LCONV1:
	;..GENERATE CODE TO MOVE OPERAND TO AC0 (AND 1);
	  LOAD(SYM,A0);
      FI
      REOPEN(SYM);
      ;..GENERATE CALL ON CONVERSION SUBROUTINE;
      ;PLUNKI(CONVERTOP);
				MOVE	T1,RESTYPE;$
				LSH	T1,-14;$
				F.TRANK	(T,SYM);
				LSH	T,2;$
				OR	T,T1;$
				MOVE	T,OPCONV-1(T);$
				PLUNKI;
      ;..BOOK A1 IN HANDLE
				HRLZI	T,2;$
				IORM	T,HANDLE;$
      ;LEX(SYM) _ (EXPR,RESTYPE,SIMPLE,AC0);
				TLZ	SYM,$KIND!$TYPE!$STATUS!$AM;$
				TSO	SYM,RESTYPE;$
				TLO	SYM,$EXP!$SIM!$ACC;$
				HRRI	SYM,0;$
      CLOSE(SYM);
    ENDD
  FI
ENDD	; CONVERT
	SUBTTL	CODE GENERATION ROUTINES	* MARRY *

PROCEDURE MARRY

	;..MAKE A SINGLE OPEN PORTION FOR TWO BINARY OPERANDS,
	    ;  REVERSING THE ORDER IF POSSIBLE;
	;  ON ENTRY, LEXEMES FOR THE OPERANDS ARE IN LOP AND SYM;
	;  UNLESS THE OPERATION = "^", MARRY WILL MAKE SURE THAT
	    ;  THE RESULT PORTION INCLUDES CODE TO LOAD 
	    ;  THE "LEFT" OPERAND INTO AN AC;

BEGIN
  IF SYM = SINGLE
				T.SINGLE(SYM);
  THEN;..SYM IS NOT A PORTION;
    BEGIN
      IF LOP NEQ SINGLE
				TN.SINGLE(LOP);
      THEN;..LOP IS A PORTION AND SYM IS NOT;
	REOPEN(LOP);
      ELSE;..BOTH LOP AND SYM ARE SINGLE;
	BEGIN
	  IF OP NEQ "^"
				TN.OPER	(ZPOW);
	  THEN;..MAKE A PORTION TO PUT A VALUE IN AN ACC;
	    BEGIN
	      IF LOP = ONE-WORD CONSTANT AND OP IS REVERSIBLE
				TLNN	LOP,$VAR1;$
				T.CONST	(LOP);
				TRNN	T,$ODROP;$
				GOTO	FALSE;$
	      THEN;..REVERSE THE ORDER SO VARIABLE IS LOADED FIRST;
		BEGIN
		  ;..EXCHANGE THE LEXEMES;
				EXCH	LOP,SYM;$
		  ;..SET REV ON;
				MOVNI	REV,LOP;$
		ENDD
	      FI
	      LOAD(LOP,ANYAC);
	      REOPEN(LOP);
	    ENDD
	  ;..ELSE NO PORTIONS ARE NECESSARY FOR POWERS;
	  FI
	ENDD
      FI
    ENDD
  ELSE;..SYM IS A PORTION;
    BEGIN
      REVORDER;
      IF LOP = SINGLE
				T.SINGLE(LOP);
      THEN;..AFTER REORDERING, LOP IS STILL NOT A PORTION.
		;..MAKE IT ONE AND MERGE WITH SYM;
        BEGIN
	  LOAD(LOP,ANYAC);
          MERGEPORTIONS;
        ENDD
      ELSE;..LOP IS A PORTION AFTER REORDERING;
        IF SYM = SINGLE
				T.SINGLE(SYM);
        THEN;..THERE IS ONLY ONE PORTION;
          REOPEN(LOP);
        ELSE;..TWO PORTIONS;
	  BEGIN
	    IF LOP IS A POINTER
				T.PTR	(LOP);
	    THEN;..WE MAY HAVE TO EVALUATE LOP BEFORE MERGING;
	      BEGIN
		IF REVERSAL NOT ALLOWED OR LOP IS A ONE WORD OPERAND
				JUMPN	T3,TRUE;$
		  ;..(T3 IS A SWITCH WHICH IS SET BY REVORDER);
				T.ONE	(LOP);
		THEN;..EVALUATE LOP NOW;
		  ;..LOAD VALUE OF LOP INTO SAME ACC USED BY POINTER;
				F.LOCN	(T2,LOP);
		    LOAD(LOP,@T2);
		FI
	      ENDD
	    FI
	    MERGEPORTIONS;
	  ENDD
        FI
      FI
    ENDD
  FI
ENDD	; MARRY
	SUBTTL	CODE GENERATION ROUTINES	* SETUP *

PROCEDURE SETUP

	;..SET UP THE OPERANDS FOR A BINARY OPERATION BY
	    ;  MAKING A SINGLE OPEN PORTION, REORDERED IF POSSIBLE,
	    ;  WITH THE VALUE OF THE (REORDERED) LEFT OPD (LOP) IN AN AC;
	;  ON ENTRY, OPERAND LEXEMES ARE IN LOP AND SYM;
	;  SETUP MAY CHANGE THE OPERATOR IF THE OPERATION
	    ;  IS REVERSIBLE, (E.G., "<" => ">", LFDV => RLFDV).

BEGIN
  ;..FIRST MAKE A SINGLE OPEN PORTION FOR THE OPERANDS;
    MARRY;
  IF REV
				T.REV;
  THEN;..PORTIONS WERE REVERSED BY MARRY;
    BEGIN
      ;..EXCHANGE THE LEXEMES AGAIN;
				EXCH	LOP,SYM;$
      ;..SET REV OFF;
				MOVNI	REV,SYM;$
    ENDD
  FI
  IF LOP NOT AN EXPRESSION IN ACC
				TN.ACC	(LOP);
  THEN;..VALUE OF LOP IS NOT NOW IN AN AC;
    BEGIN
      IF VALUE OF SYM IN AN ACC
				TLNE	SYM,$AM-$ACC;$
				GOTO	FALSE;$
      THEN;..WE MAY BE ABLE TO DO AN OPERATOR REVERSAL;
	BEGIN
	  IF OP IS NOT REVERSIBLE
				MOVE	T,OP;$
				TRNE	T,$ODROP;$
				GOTO	FALSE;$
	  THEN;..OP IS NOT USUALLY REVERSIBLE;
	    BEGIN
	      IF SYM<TYPE> = LONG REAL
				T.LR	(SYM);
	      THEN;..OPERANDS ARE LONG REAL;
		BEGIN
		  IF OP = SLASH
				T.OPER	(ZSLASH);
		  THEN;..WE CAN CALL A REVERSE DIVIDE SR;
				GOTO	LSETU1;$
		  FI
		  IF OP = "-"
				T.OPER	(ZMINUS);
		  THEN;..WE CAN CALL A REVERSE SUBTRACT SR;
				GOTO	LSETU1;$
		  FI
		ENDD
	      FI
	      ;..NO CHANCE OF OPERATOR REVERSAL.  LOAD VALUE OF LOP INTO AN AC;
				GOTO	LSETU2;$
	    ENDD
	  ELSE;..OP IS REVERSIBLE;
	    BEGIN
	      LSETU3:
	      IF OP IS NOT COMMUTATIVE
				MOVE	T,OP;$
				TRNE	T,$ODCOP;$
				GOTO	FALSE;$
	      THEN;..MAKE OP INTO ITS REVERSE;
		LSETU1:
		;..OP _ REVERSE(OP);
				MOVE	T,OP;$
				ADDI	T,2_^D8;$
				MOVEM	T,OP;$
	      ;..ELSE COMMUTATIVE OP IS ITS OWN REVERSE;
	      FI
	      ;..REVERSE THE OPERANDS BY EXCHANGING LEXEMES AND LEXEXES;
				MOVE	T,LEXEX;$
				EXCH	T,LEXEX+2;$
				MOVEM	T,LEXEX;$
				MOVE	T,LEXEX+1;$
				EXCH	T,LEXEX+3;$
				MOVEM	T,LEXEX+1;$
				EXCH	LOP,SYM;$
	    ENDD
	  FI
	ENDD
      ELSE;..NEITHER SYM NOR LOP HAS A LOADED VALUE;
	BEGIN
	  IF LOP = SINGLE AND SYM = POINTER AND OP IS REVERSIBLE
				T.PTR	(SYM);
				MOVE	T,OP;$
				TRNE	T,$ODROP;$
				TLNE	LOP,$SINGLE;$
				GOTO	FALSE;$
	  THEN;..WE SHOULD LOAD THE VALUE OF SYM NOW;
	    BEGIN
	      ;..LOAD VALUE OF SYM INTO SAME ACC, LEAVING PORTION OPEN;
				MOVE	T,OPMVSM;$
				F.LOCN	(T1,SYM);
		GLOAD;
	      ;..GO BACK TO REVERSE THE LEXEMES;
				GOTO	LSETU3;$
	    ENDD
	  FI
	  LSETU2:
	  ;..PUT THE VALUE OF LOP IN AN AC;
	  IF LOP IS A POINTER
				T.PTR	(LOP);
	  THEN;..USE SAME ACC FOR VALUE AS FOR POINTER;
				F.LOCN	(T1,LOP);
	  ELSE;..USE NEXT FREE ACC;
				MOVEI	T1,ANYAC;$
	  FI
	  IF OP = "DIV" OR "REM"
				MOVE	T,OP;$
				CAMN	T,ZDIV;$
				GOTO	TRUE;$
				CAME	T,ZREM;$
				GOTO	FALSE;$
	  THEN;..GIVE LOP SPECIAL TYPE SO LOAD WILL USE 2 AC'S;
				TLZ	LOP,$TYPE;$
				TLO	LOP,$IDI;$
	  FI
	  ;..LOAD THE VALUE, LEAVING THE PORTION OPEN;
				MOVE	T,OPMVLP;$
	    GLOAD;
	ENDD
      FI
    ENDD;
  FI
ENDD	; SETUP

	SUBTTL	CODE GENERATION ROUTINES	* STOCON *

PROCEDURE STOCON

	;..FIX UP LEXEME AND CONSTANT TABLE (IF NECESSARY)
	    ;  FOR A NEWLY GENERATED ONE WORD CONSTANT;
	;  ON ENTRY, VALUE OF CONSTANT IS IN T3;
	    ;  PARTIAL LEXEME FOR CONSTANT IS IN SYM;
	;  IF CONSTANT CAN BE IMMEDIATE, IT WILL BE STORED IN THE LEXEME;
	    ;  IF NOT IT WILL BE PUT INTO THE CONSTANT TABLE;
	;  COMPLETED LEXEME WILL BE PUT INTO SYM;

BEGIN
  IF LEFT HALF OF CONSTANT = 0 AND SYM<TYPE> NEQ REAL
				TLNN	T3,777777;$
				TN.R	(SYM);
  THEN;..WE HAVE A BOOLEAN OR INTEGER IMMEDIATE CONSTANT;
    ;LEX(SYM) _ (IMMED,SAME,SIMPLE,RH(T3));
				TLZ	SYM,$STATUS!$AM;$
				TLO	SYM,$SIM!$IMM;$
				HRR	SYM,T3;$
  ELSE;..IT MAY BE REAL IMMEDIATE;
    IF RIGHT HALF OF CONSTANT = 0 AND SYM<TYPE> = REAL
				TRNN	T3,777777;$
				T.R	(SYM);
    THEN;..WE HAVE A REAL IMMEDIATE CONSTANT;
      ;LEX(SYM) _ (IMMED,SAME,SIMPLE,LH(T3));
				TLZ	SYM,$STATUS!$AM;$
				TLO	SYM,$SIM!$IMM;$
				HLR	SYM,T3;$
    ELSE;..CONSTANT CANNOT BE IMMEDIATE;
      ;..PUT CONSTANT IN TABLE;
	TOCT(1,SYM);
    FI
  FI
ENDD	; STOCON
ENDD; END OF MODULE MFUN

LIT
END