.IIF	NDF	RSX	RSX	=	1	;Assume RSX	;01+183
	.TITLE	CC203
	.ident	/X01.09/

	.NLIST	BEX, CND
	.ENABL	LC, GBL
	.LIST	MEB						;01-

;
; C COMPILER
; CODER, PART II (NON EIS)
;
; VERSION X01
;
; DAVID G. CONROY	01-APR-78
; LAST UPDATED:		23-MAY-79
;
; Edit history
; 01 04-Mar-80 MM	Added RT11 support
; 02 20-May-80 jam	Fixed bug in clasfy
; 03 21-May-80 jam	changed ccabrt to abort2
; 04 02-Jun-80 MM	Added EIS stuff
; 05 05-Mar-81 MM	Added FPU stuff
; u1 28-Aug-81 CCG	Modified CLASFY to support new register allocation.
; u2 14-Dec-81 CCG	Added a new constant value.
;			Forced indirect float/double to non-addressable.
; 06 10-Feb-82 MM	Merged Unimation sources
; 07 25-Feb-82 MM	Better "Bad initializor" messages
; 08 31-Jul-82 MM	Output '_' before global names
; u3 06-Aug-82 CCG	Removed part of u2, allow addressable float/double/long
; u4 08-Sep-82 CCG	Fixed hang if int zero used as float/double initializer
; u5 28-Sep-82 CCG	Fixed CLASFY bug.  Changed CLASFY calling sequence.
; u6 04-Jan-83 CCG	Fixed CLASFY bug when using long pointers
; 09 30-Jan-83 MM	Merged Unimation and Dec sources
;

	.GLOBL	ADDRES
	.GLOBL	HASADR
	.GLOBL	CLASFY
	.GLOBL	ITREE

.IF NE	RSX							;01
	.MCALL	CALL
	.MCALL	CALLR
	.MCALL	RETURN
.ENDC								;01

;
; NODE CLASSES
; CHANGE AT YOUR PERIL!
;

CON0	==	0		;CONST 0
CON1	==	1		;CONST 1
CON2	==	2		;CONST 2
CON3	==	3		;CONST 3
CON4	==	4		;CONST 4
CON5	==	5		;CONST 5
CON6	==	6		;CONST 6
CON7	==	7		;CONST 7
CON8	==	10		;CONST 8
CON9	==	11		;CONST 9
CON10	==	12		;CONST 10
CON12	==	13		;CONST 12
CON16	==	14		;CONST 16
CON32	==	15		;CONST 32
CON256	==	16		;CONST 256			;u2
ADDR	==	17		;ADDRESSABLE
EASY	==	20		;REGISTER TEMP. AVAILABLE
ANY	==	21		;ANYTHING ELSE

;
; THIS TABLE IS USED TO HELP CLASSIFY CONSTANTS.
;

CONTB:	.WORD	0,	CON0	;ONE ENTRY PER SPECIAL CONSTANT
	.WORD	1,	CON1	;
	.WORD	2,	CON2	;
	.WORD	3,	CON3	;
	.WORD	4,	CON4	;
	.WORD	5,	CON5	;
	.WORD	6,	CON6	;
	.WORD	7,	CON7	;
	.WORD	10,	CON8	;
	.WORD	11,	CON9	;
	.WORD	12,	CON10	;
	.WORD	14,	CON12	;
	.WORD	20,	CON16	;
	.WORD	40,	CON32	;
	.WORD	256.,	CON256	;				;u6
CONTBE:	.BLKW	0		;END OF TABLE


;
; STRINGS AND ERROR MESSAGES.
;
BEX:	.BLKW	1			; Float exponent must be before
BUF:	.BLKW	4			; Float buffer

STR01:	.ASCIZ	"	.word	"
STR02:	.ASCIZ	"	.byte	"
STR03:	.ASCIZ	<176><176>"facc"	; Fpu simulator accumulator	;05+
ERR01:	.ASCIZ	"Long and floating-point initializors must be constants"
ERR02:	.ASCIZ	"Bad call: addres"
ERR03:	.ASCIZ	"Int or byte initializor -- need a constant expression"
	.EVEN
	.PAGE
;+
; ** ADDRES - PUT OUT AN ADDRESS
;
; THIS ROUTINE OUTPUTS A TREE AS A STANDARD PDP-11 ADDRESS FIELD. THE
; TREE MUST DESCRIBE AN ADDRESSABLE THING OR THE COMPILER ABORTS.
;
; INPUTS:
;	R5=TREE
; 	R4=A FLAG
;		0	ORDINARY
;		1	NO SIDE EFFECTS
;		-1	SECOND (LOW ORDER) PART OF A LONG
;		-2	THIRD WORD OF A DOUBLE
;		-3	FOURTH WORD OF A DOUBLE
;-

ADDRES:	MOV	R5,-(SP)	;SAVE REGISTERS
	MOV	R1,-(SP)	;
	MOV	R0,-(SP)	;

	CMP	(R5),#OP.IND	;INDIRECTION REQUIRES AN '*'
	BNE	10$		;
	CMP	@E.LOP(R5),#OP.REG ;REGISTERS PRINT AS (REG)
	BEQ	20$		;
	MOVB	#'*,R0		;OUTPUT THE '*'
	CALL	CODC		;
	MOV	E.LOP(R5),R5	;AND DELETE THE INDIRECTION
	BR	20$		;

10$:	CMP	(R5),#OP.ADR	;ADR OF NAME
	BNE	20$		;NO
	MOVB	#'$,R0		;MODE 2 ADDRESS
	CALL	CODC		;
	MOV	E.LOP(R5),R5	;DELETE ADR

20$:	MOV	(R5),R0		;PICK UP THE OPERATOR
	CMP	R0,#OP.IND	;INDIRECTION
	BNE	23$		;NO
	MOV	E.LOP(R5),R5	;THIS MAKES **REG INTO @(REG)
	CMP	(R5),#OP.REG	;
	BEQ	2000$		;
	JMP	100$		;DIE
2000$:	MOV	R4,R0		;IS THIS THE SECOND PART OF A LONG
	BGE	21$		;NO
	NEG	R0		;YES, GET ACTUAL VALUE
	ASL	R0		;DOUBLED TO GET THE OFFSET
	ADD	#'0,R0		;NOW IT'S FOR REAL
	CALL	CODC		;
21$:	CALL	PREG		;THE INDEX REGISTER
	JMP	90$		;DONE					;05

23$:	CMP	R0,#OP.CON	;CONSTANT
	BNE	25$		;NO
	MOVB	#'$,R0		;USE LITERAL MODE
	CALL	CODC		;
	MOV	E.VAL(R5),R0	;THE VALUE
	TST	R4		;IS IT A FUNNY ONE?			;05+
	BPL	24$		;NOPE, SIMPLICITY ITSELF
	MOV	R4,R0		;GET THE RIGHT
	BPL	24$		;PART OF A LONG OR DOUBLE
	NEG	R0		;GET SIGNAL AS A POSITIVE VALUE
	ASL	R0		;* 2 AS AN INDEX
	ADD	R5,R0		;+ TREE BASE
	MOV	E.VAL(R0),R0	;GET ACTUAL VALUE (E.VAL+(-R4 * 2))[R5]	;05-
24$:	CALL	CODNUM		;
	BR	90$		;

25$:	CMP	R0,#OP.LID	;LOCAL ID
	BNE	30$		;NO
	MOV	E.LAB(R5),R0	;DO THE NAME
	CALL	CODLAB		;
	BR	31$		;THEN GO DO OFFSETS

30$:	CMP	R0,#OP.ID	;ID
	BNE	40$		;NO
	MOV	R5,R0		;PUT OUT THE NAME
	ADD	#E.NAME,R0	;
	CALL	CODID		;					;08

31$:	MOV	E.OFFS(R5),R1	;GET OFFSET
	TST	R4		;IS IT THE 2ND PART OF A LONG OR DOUBLE
	BGE	32$		;NO
	SUB	R4,R1		;YES, FIX THE OFFSET BY SUBTRACTING	;05
	SUB	R4,R1		;TWICE THE FLAG VALUE			;05
32$:	MOVB	#'+,R0		;DEFAULT SIGN FOR THE OFFSET
	TST	R1		;TEST FOR NO OFFSET
	BEQ	90$		;
	BPL	34$		;POSITIVE
	MOVB	#'-,R0		;GET SIGN
	NEG	R1		;FIX VALUE
34$:	CALL	CODC		;PUT OUT OFFSET SEPERATOR
	MOV	R1,R0		;THEN THE OFFSET
	CALL	CODNUM		;
	BR	90$		;

40$:	CMP	R0,#OP.INX	;INDEX
	BNE	50$		;NO
	MOV	E.OFFS(R5),R1	;GET THE OFFSET
	TST	R4		;FIXUP FOR LONGS AND DOUBLES
	BGE	42$		;
	SUB	R4,R1		;SUBTRACT TWICE THE VALUE		;05
	SUB	R4,R1		;TO GET THE TRUE OFFSET			;05
42$:	TST	R1		;TEST FOR ZERO OFFSET
	BEQ	46$		;
	BPL	44$		;POSITIVE
	MOVB	#'-,R0		;GET CORRECT SIGN
	CALL	CODC		;
	NEG	R1		;AND VALUE
44$:	MOV	R1,R0		;INDEX CONSTANT
	CALL	CODNUM		;
46$:	CALL	PREG		;INDEX REGISTER
	BR	90$		;

50$:	CMP	R0,#OP.REG	;REGISTER
	BNE	60$		;NO
;
; DO FLOATING POINT HACKS IF NECESSARY					;05+
;
	CMPB	#TY.FLT,E.TYPE(R5)	;IS IT FLOATING?
	BEQ	5000$			;YES, WE DO IT
	CMPB	#TY.DBL,E.TYPE(R5)	;NO, BUT IS IT DOUBLE?
	BNE	5100$			;IF NOT, DON'T BOTHER

5000$:				;FLOAT/DOUBLE REGISTER ADDRESS.
	TSTB	FFLAG		;DO IT INLINE?
	BNE	5100$		;IF SO, IT'S QUITE SIMPLE, REALLY.
	MOV	#STR03,R0	;EMULATE -- THERE'S ONLY ONE FLOAT REGISTER
	CALL	CODSTR		;SO OUTPUT IT
	BR	90$		;AND CONTINUE

5100$:				;"NORMAL" SITUATION			;05-
	MOVB	#'r,R0		;THE 'R'
	CALL	CODC		;
	MOV	E.REG(R5),R0	;THE REGISTER NUMBER
	TST	R4		;IF LOW HALF OR LONG
	BGE	52$		;THEN
	INC	R0		;ITS REG+1
52$:	ADD	#'0,R0		;
	CALL	CODC		;
	BR	90$		;

60$:	CMP	R0,#OP.AUI	;AUTOINCREMENT
	BNE	70$		;NO
	CALL	PREG		;PUT OUT THE REGISTER PART
	TST	R4		;IF SIDE EFFECTS
	BGT	90$		;
	MOVB	#'+,R0		;PUT OUT THE '+'
	CALL	CODC		;
	BR	90$		;

70$:	CMP	R0,#OP.AUD	;AUTODECREMENT
	BNE	100$		;NO
	TST	R4		;IF SIDE EFFECTS
	BGT	72$		;
	MOVB	#'-,R0		;PUT OUT THE '-'
	CALL	CODC		;
72$:	CALL	PREG		;THE REGISTER

90$:	MOV	(SP)+,R0	;RETURN
	MOV	(SP)+,R1	;
	MOV	(SP)+,R5	;
	RETURN			;

100$:	MOV	#ERR02,R0	;DEATH
	JMP	ABTREE		;WITH TREES				;05

;
; OUTPUT A REGISTER IN PARENTHESES.
;

PREG:	MOVB	#'(,R0		;LEFT PARENTHESIS
	CALL	CODC		;
	MOVB	#'r,R0		;'R'
	CALL	CODC		;
	MOV	E.REG(R5),R0	;REGISTER NUMBER
	ADD	#'0,R0		;
	CALL	CODC		;
	MOVB	#'),R0		;RIGHT PARENTHESIS
	CALLR	CODC		;

; HASADR
;+
; ** HASADR - TEST IF A NODE HAS AN ADDRESS
;
; THIS ROUTINE DETERMINES IF A TREE IS AN 'ADDRESSABLE' TREE; THAT IS,
; IF A PDP-11 ADDRESS FIELD CAN DESCRIBE IT.
; ALL LEAF NODES ARE ADDRESSABLE.
; INDIRECTION ON TOP OF A LEAF NODE IS ADDRESSABLE IF THE RESULT TYPE
; IS NOT LONG.
; ADDRESS OF ON TOP OF EITHER TYPE OF ID (GLOBAL OR LOCAL) IS ADDRESS
; ABLE ALSO.
;
; INPUTS:
;	R5=TREE
;
; OUTPUTS:
;	C=0 IF ADDRESSABLE
;-

HASADR:	MOV	R5,-(SP)	;SAVE POINTER TO TREE

	CMP	(R5),#OP.IND	;IF INDIRECTION
	BNE	10$		;AND
	CMPB	E.TYPE(R5),#TY.LNG ;NOT LONG			;u2/u3
	BEQ	20$		;THEN				;u2/u3
	MOV	E.LOP(R5),R5	;DELETE THE INDIRECTION
	CMPB	E.TYPE(R5),#TY.LNG ;IF LONG, FLOAT, OR DOUBLE	;u3
	BHIS	40$		;NOT ADDRESSABLE		;u3
	BR	20$		;

10$:	CMP	(R5),#OP.ADR	;ADDRESS OF NAME
	BNE	20$		;
	MOV	E.LOP(R5),R5	;GET SUBTREE
	CMP	(R5),#OP.ID	;CHECK FOR BOTH TYPES OF ID
	BEQ	30$		;
	CMP	(R5),#OP.LID	;
	BEQ	30$		;
	BR	40$		;NOT ADDRESSABLE

20$:	MOV	(R5),R5		;LOOK FOR LEAF NODE
	ASL	R5		;
	BIT	#LEAF,OPDOPE(R5);
	BEQ	40$		;NOT ADDRESSABLE

30$:	CLC			;SUCCESSFUL RETURN
	BR	50$		;
40$:	SEC			;NON SUCCESSFUL RETURN
50$:	MOV	(SP)+,R5	;RETURN
	RETURN			;

;+
; ** CLASFY - CLASSIFY BINARY NODES
;
; GIVEN A TREE, AND AN 'OTHER' TREE (USUALLY THE OTHER BINARY OPERATOR
; SUBTREE) RETURN A TREE CLASS AS USED BY THE MATCHER. THIS ROUTINE IS
; SOMETIMES USED TO DETERMINE THE ADDRESSABILITY OF THE SINGLE OPERAND
; OF A UNARY OP; IN THIS CASE THE OTHER TREE IS POINTED AT A LEAF.
;
; CLASIFY previously ignored the "middle" tree if evaluating a binary	;u5+
; operator.  Therefore, it couldn't tell that a DIV required two regs
; even when the right and left operators were both EASY.  Caused
; R1 to be used twice in divide code if all higher regs were used.
; Same problem occurs even if operators are indirect.			;u6
;
; INPUTS:
;	R1 = TREE TO CLASSIFY
;	R0 = THE OTHER TREE
;	R5 = THE OPERATOR IN THE MIDDLE
;
; OUTPUTS:
;	R0=CLASS
;	R1,R5 NOT MODIFIED						;u5-
;-

.if ne 0
foo1:	.asciz	/Current tree/<12>
foo2:	.asciz	/Other binop tree/<12>
foo3:	.asciz	/ntwo succeeds/<12>
foo4:	.asciz	/e.hgpr(), r4, hgpra = /
foo5:	.asciz	/easy/<12>
	.even
.endc

CLASFY:	MOV	R4,-(SP)	;SAVE REGISTERS
	MOV	R3,-(SP)	;
	MOV	R5,-(SP)	;SAVE MIDDLE TREE		;u5
	MOV	R1,R5		;POINT R5 AT CURRENT TREE	;u5

.if ne 0
	mov	r1,-(sp)
	mov	r0,-(sp)
	mov	#foo1,r0
	call	codstr
	call	tdump
	mov	#foo2,r0
	call	codstr
	mov	(sp),r5
	call	tdump
	mov	(sp)+,r0
	mov	(sp)+,r5
.endc

;
; CONSTANTS.
;

	CMP	(R5),#OP.CON	;IS THIS A CONSTANT
	BNE	30$		;NO
	MOVB	E.TYPE(R5),R3	;IS THE TYPE INTEGER
	CMP	R3,#TY.INT	;
	BNE	30$		;NO

	MOV	E.VAL(R5),R3	;GET CONSTANT VALUE
	MOV	#CONTB,R4	;POINT AT TABLE OF MAGIC VALUES

10$:	CMP	R3,(R4)+	;MAGIC
	BEQ	20$		;YES
	TST	(R4)+		;NO, MOVE TO THE NEXT
	CMP	R4,#CONTBE	;DONE
	BLO	10$		;NO, TRY MORE
	BR	30$		;NOT A SPECIAL CONSTANT

20$:	MOV	(R4),R0		;GET CLASSIFICATION
	BR	100$		;

;
; TEST IF ADDRESSABLE.
;

30$:	CALL	HASADR		;WELL
	BCS	40$		;NO
	MOV	#ADDR,R0	;RETURN VALUE
	BR	100$		;

;
; TEST IF REGISTER TEMP. AVAILABLE.

40$:	CLR	R4		;1 REG
	CMP	(R5),#OP.IND	;TOP LEVEL '*'
	BEQ	43$		;YES, 1 REG NEEDED		;u1+	;u6

 	CMPB	E.TYPE(R5),#TY.FLT	; IS IT FP ?
	BHIS	60$		; SKIP IF SO

; General reg

	CALL	NTWO		;TEST IF TWO REG'S REQUIRED	;03
	BCC	45$		;	YES				;u5+
43$:	MOV	(SP),R5		;GET "MIDDLE" OPERATOR			;u6
	CALL	NTWO		;DOES IT REQUIRE TWO REG'S?
	BCS	50$		;	NO
45$:	INC	R4		;FIX REQUIREMENTS			;u5-

50$:	ADD	E.HGPR(R0),R4	;SEE IF ENOUGH REGISTERS
	CMP	R4,HGPRA	;
	BLOS	90$		;YES, EASY
 	BR	80$		; ELSE ANY

; Floating reg
;
60$:	ADD	E.HFPR(R0),R4	;SEE IF ENOUGH REGISTERS
	CMP	R4,HFPRA	;
	BLOS	90$		;YES, EASY			;u1-

80$:	MOV	#ANY,R0		;RETURN VALUE
	BR	100$		;

90$:	MOV	#EASY,R0	;RETURN VALUE

100$:	MOV	(SP)+,R5	;DONE					;u5
	MOV	(SP)+,R3	;DONE
	MOV	(SP)+,R4	;
	RETURN			;

; ITREE
; ** ITREE - INITIALISOR TREE
;
; THIS ROUTINE TAKES A TREE, AND OUTPUTS THE VALUE OF IT AS AN INITIAL
; ISOR. THE TYPE OF THE INITIALISOR IS TAKEN FROM THE TYPE OF THE TREE
; WHICH USUALLY HAS A CONVERSION ON THE TOP.
;
; LONGS AND DOUBLES ARE DONE HERE. WORD INITIALISORS ARE SOMEWHAT MORE
; INVOLVED, AND HAVE THEIR OWN ROUTINE.
;
; THE TOP NODE ON THE TREE IS ALWAYS AN OP.CVR CONTAINING THE TYPEOF
; THE VARIABLE WE ARE INITIALIISING. IT IS ALWAYS REMOVED HERE.   THIS
; MUST BE DONE BEFORE TREE MODIFICATION BECAUSE SOME OP.CVR NODES  GET
; CHANGED INTO MULTIPLICATIONS.
;
; INPUTS:
;	R5=TREE
;-

ITREE:	MOV	#STR01,R0	;.WORD
	MOVB	E.TYPE(R5),R1	;GET TREE TYPE
	CMP	R1,#TY.CHR	;IS IT CHAR
	BNE	10$		;NO
	MOV	#STR02,R0	;.BYTE
10$:	CALL	CODSTR		;PUT IT OUT

	MOV	R1,-(SP)	;SAVE TYPE
	MOV	E.LOP(R5),R5	;DELETE THE DUMMY CVR NODE
	CALL	MODIFY		;THEN MODIFY THE TREE
	MOV	(SP)+,R1	;RECOVER TYPE

;
; WORDS AND BYTES.
;

30$:	CMP	R1,#TY.LNG	;TEST FOR WORDS OR BYTES
	BHIS	40$		;NO
	CALL	IWTREE		;
	BR	130$		;

;
; LONGS.
;

40$:	CMP	(R5),#OP.CON	;MAKE SURE ITS A CONSTANT
	BNE	120$		;ERROR IF NOT

	CMP	R1,#TY.FLT	;FLOATING POINT
	BHIS	80$		;YES

	MOVB	E.TYPE(R5),R1	;PICK UP THE CONSTANT TYPE
	CMP	R1,#TY.INT	;INTEGER
	BNE	50$		;NO
	CLR	R0		;MAKE LONG INTEGER
	MOV	E.VAL(R5),R1	;
	BPL	70$		;
	COM	R0		;
	BR	70$		;

50$:	CMP	R1,#TY.LNG	;LONG CONSTANT
	BNE	60$		;NO
	MOV	E.VAL(R5),R0	;GET LONG CONSTANT VALUE
	MOV	E.VAL+2(R5),R1	;
	BR	70$		;

60$:	CALL	DTOL		;MUST BE A DOUBLE

70$:	CALL	CODNUM		;UPPER HALF
	CALL	140$		;COMMA
	MOV	R1,R0		;LOWER HALF
	CALL	CODNUM		;
	BR	130$		;

;
; DOUBLES.
;

80$:	MOV	R1,R4		;SAVE TYPE (FLT OR DBL)
	MOVB	E.TYPE(R5),R1	;PICK UP CONSTANT TYPE
	CMP	R1,#TY.INT	;INTEGER
	BNE	90$		;NO
	CLR	R0		;MAKE LONG INTEGER
	MOV	E.VAL(R5),R1	;
	BPL	85$		;
	COM	R0		;
85$:	CALL	LTOD		;FLOAT IT
	BR	110$		;GO OUTPUT IT

90$:	CMP	R1,#TY.LNG	;LONG
	BNE	100$		;NO
	MOV	E.VAL(R5),R0	;GET LONG CONSTANT VALUE
	MOV	E.VAL+2(R5),R1	;
	CALL	LTOD		;FLOAT IT
	BR	110$		;OUTPUT IT

100$:	MOV	E.VAL(R5),R0	;GET DOUBLE VALUE
	MOV	E.VAL+2(R5),R1	;
	MOV	E.VAL+4(R5),R2	;
	MOV	E.VAL+6(R5),R3	;

110$:	CALL	CODNUM		;PUT OUT FIRST 2 WORDS
	CALL	140$		;
	MOV	R1,R0		;
	CALL	CODNUM		;

	CMP	R4,#TY.FLT	;DUCK OUT IF FLOAT
	BEQ	130$		;
	CALL	140$		;2 MORE WORDS
	MOV	R2,R0		;
	CALL	CODNUM		;
	CALL	140$		;
	MOV	R3,R0		;
	CALL	CODNUM		;
	BR	130$		;

120$:	MOV	#ERR01,R0	;ILLEGAL INITIALISOR -- Not a constant
	CALL	ERROR		;

130$:	CALLR	CODNL		;DONE


;
; LOCAL SUBROUTINE TO PUT OUT A ','.
;

140$:	MOVB	#',,R0		;PUT OUT COMMA
	CALLR	CODC		;

;+
; ** IWTREE - TREE WORD INITIALISOR
;
; THIS IS A SPECIAL ROUTINE THAT COMPILES THE INITIALISORS  FOR  WORDS
; AND BYTES. IT EXPANDS OUT THE '+' AND '-' SIGNS, PRINTS THE NAMES IN
; ADDRESS OF NAME, AND OUTPUTS THE CONSTANTS.
;
; INPUTS:
;	R5=TREE
;
; USES:
;	R0
;-

IWTREE:	MOV	R5,-(SP)	;SAVE TREE POINTER

	MOV	(R5),R0		;OP
	CMP	R0,#OP.ADD	;TEST FOR '+' OR '-'
	BEQ	10$		;
	CMP	R0,#OP.SUB	;
	BNE	30$		;
10$:	MOV	E.LOP(R5),R5	;DO LEFT SUBTREE
	CALL	IWTREE		;
	MOV	(SP),R5		;RECOVER TREE
	MOVB	#'+,R0		;OPERATOR
	CMP	(R5),#OP.ADD	;
	BEQ	20$		;
	MOVB	#'-,R0		;
20$:	CALL	CODC		;
	MOV	E.ROP(R5),R5	;DO RIGHT SUBTREE
	CALL	IWTREE		;
	BR	60$		;DONE

30$:	CMP	R0,#OP.ADR	;ADDRESS OF NAME
	BNE	40$		;
	MOV	E.LOP(R5),R5	;
	CMP	(R5),#OP.ID	;
	BNE	50$		;ILLEGAL INITIALISOR
	MOV	R5,R0		;PUT OUT NAME
	ADD	#E.NAME,R0	;
	CALL	CODID		;					;08
	MOVB	#'+,R0		;DEFAULT SIGN
	TST	E.OFFS(R5)	;IS THERE AN OFFSET
	BEQ	60$		;NO
	BPL	35$		;POSITIVE
	MOVB	#'-,R0		;FIX SIGN
	NEG	E.OFFS(R5)	;AND OFFSET
35$:	CALL	CODC		;OUTPUT SIGN
	MOV	E.OFFS(R5),R0	;AND
	CALL	CODNUM		;OFFSET
	BR	60$		;

40$:	CMP	R0,#OP.CON	;INTEGER CONSTANT
	BNE	50$		;ILLEGAL INITIALISOR
	CMPB	E.TYPE(R5),#TY.INT ;
	BNE	50$		;ILLEGAL INITIALISOR
	MOV	E.VAL(R5),R0	;PUT OUT THE CONSTANT
	CALL	CODNUM		;
	BR	60$		;DONE

50$:	MOV	#ERR03,R0	;ERROR -- Can't compute expression	;07
	CALL	ERROR		;

60$:	MOV	(SP)+,R5	;RETURN
	RETURN			;

;+
; ** LTOD - LONG TO DOUBLE
;
; INPUTS:
;	R0-R1=THE LONG
;
; OUTPUTS:
;	R0-R3=THE DOUBLE
;-

LTOD:								;05+
	CLR	-(SP)		;GETS SIGN
	MOV	R1,BUF+6	;MAKE IT A LONG
	MOV	R0,BUF+4	;INTEGER
	BPL	10$		;POSITIVE?
	MOV	#100000,(SP)	;SET SIGN
	NEG	BUF+6		;NEGATE TO
	NEG	BUF+4		;GET ABSOLUTE VALUE
10$:	CLR	BUF+2		;CLEAR HIGH-ORDER
	CLR	BUF+0		;WORDS, TOO.
	BIS	R1,R0		;CHECK FOR ZERO INPUT VALUE	;u4
	BEQ	50$		;	EARLY EXIT IF ZERO	;u4
	MOV	#65.,BEX	;BINARY SHIFT COUNTER
20$:	DEC	BEX		;NORMALIZE AND
	CALL	LLS		;GOBBLE UP THE
	BCC	20$		;HIDDEN BIT.
	MOV	#BUF+10,R0	;BEGIN D.P. ROUND
	ADD	#400,-(R0)	;JUST BELOW LAST BIT WE KEEP
	ADC	-(R0)		;
	ADC	-(R0)		;
	ADC	-(R0)		;
	BCC	30$		;IF NO CARRY, HIDDEN BIT WAS 1
	INC	BEX		;CARRY, COMPLEMENT THE HIDDEN BIT
	CALL	LRS		;AND SHIFT RIGHT
30$:
	ADD	#200,BEX	;EXCESS 128. EXPONENT
				; ** IGNORE UNDER/OVERFLOW **
	MOV	#BUF+10,R0	;SLIDE DOWN BY 8 BITS
	MOV	#BUF+6,R1
40$:	CMP	-(R0),-(R1)	;
	MOVB	(R1),(R0)	;SLIDE A BYTE
	SWAB	(R0)		;WATCH BYTE ORDER
	CMP	R0,#BUF		;DO IT ALL
	BHI	40$		;INCLUDING BEX
	CALL	LRS		;MAKE ROOM FOR SIGN
50$:	ADD	(SP)+,BUF	;AND ADD IT IN.			;u4
	MOV	#BUF+10,R0	;LOAD
	MOV	-(R0),R3	;UP
	MOV	-(R0),R2	;FOR
	MOV	-(R0),R1	;RETURN
	MOV	-(R0),R0	;
	RETURN


;+
; ** DTOL - DOUBLE TO LONG
;
; INPUTS:
;	R5=POINTER TO DOUBLE CONSTANT NODE
;
; OUTPUTS:
;	R0-R1=THE LONG
;-

DTOL:	MOV	R5,R0		;R0 -> DOUBLE
	MOV	#BUF,R1		;R1 -> WORK AREA
	MOV	(R0)+,(R1)+	;MOVE
	MOV	(R0)+,(R1)+	;'EM
	MOV	(R0)+,(R1)+	;OUT
	MOV	(R0)+,(R1)+	;
	MOV	BUF,R1		;GET EXPONENT
	ASL	R1		;SHIFT RIGHT
	SWAB	R1		;BY SEVEN
	BIC	#177000,R1	;MASK OUT JUNK
	ADD	#24.+0200,R1	;PARTIAL EXPONENT
	BIC	#^C0177,BUF	;REMOVE EXPONENT
	BIS	#0200,BUF	;RESTORE HIDDEN BIT
	BR	20$

10$:	CALL	LRS		;SHIFT OUT
20$:	DEC	R1		;THE DOUBLE
	BNE	10$		;UNTIL IT'S NORMAL AGAIN
	MOV	BUF+6,R1	;RETURN LOW WORD
	MOV	BUF+4,R0	;AND HIGH WORD
	RETURN

;
; ** LLS	LONG LEFT SHIFT
; ** LRS	LONG RIGHT SHIFT
;
; SHIFT THE FLOAT BUFFER ONCE IN THE INDICATED DIRECTION
;
; USES R0
;

LLS:	MOV	#BUF+10,R0
	ASL	-(R0)
	ROL	-(R0)
	ROL	-(R0)
	ROL	-(R0)
	RETURN

LRS:	MOV	#BUF,R0
	CLC
	ROR	(R0)+
	ROR	(R0)+
	ROR	(R0)+
	ROR	(R0)
	RETURN

	.END