.TITLE	AS3C
	.IDENT	/X01/
 
	.NLIST	BEX
	.ENABL	LC
 
;
; AS
; LEXICAL THINGS
;
; VERSION X01
;
; DAVID G. CONROY	24-MAY-78
; LAST UPDATED:		11-JUN-79
;
 
	.GLOBL	ERRORS
	.GLOBL	GETLIN
	.GLOBL	GETPCH
	.GLOBL	GETOKN
	.GLOBL	GETNB
	.GLOBL	GETC
	.GLOBL	ATOF
	.GLOBL	UNGET
	.GLOBL	LOOKUP
	.GLOBL	INSERT
	.GLOBL	GLOBS
	.GLOBL	GETPS
	.GLOBL	FBOK
	.GLOBL	MAPC
	.GLOBL	LINBUF
	.GLOBL	LINPTR
 
	.MCALL	CALL
	.MCALL	CALLR
	.MCALL	RETURN
	.MCALL	GET$S
 
;
; EQUIVALENCES
;
 
BLANK	=	40		;ASCII BLANK
TAB	=	11		;ASCII TAB
 
;
; DATA, ETC.
;
 
ECT:	.WORD	1000.		;LINE NUMBER CONVERSION TABLE
	.WORD	100.		;
	.WORD	10.		;
	.WORD	1.		;
ECTE:	.BLKW	0		;END OF TABLE

LINPTR:	.BLKW	1		;WORKING LINE BUFFER POINTER
LINLST:	.BLKW	1		;UNGET LINE BUFFER POINTER
LINBUF:	.BLKB	81.		;80 BYTES + THE NUL
IDBUF:	.BLKB	8.		;IDENTIFIER BUFFER
EBUF:	.BLKB	7.		;CODE + BLANK + 4 DIGITS + NULL
 
;
; FOR ATOF.
; FBEX MUST BE JUST BEFORE FBUF.
; FESGN MUST BE LAST.
;

	.EVEN

FBEX:	.BLKW	1		;BINARY EXP.
FBUF:	.BLKW	4		;MAIN ACC.
FSAV:	.BLKW	4		;AUX. ACC.
FSGN:	.BLKW	1		;SIGN.
FEXP:	.BLKW	1		;DECIMAL EXP.
FDOT:	.BLKW	1		;DOT FLAG.
FANY:	.BLKW	1		;ANY FLAG.
FESGN:	.BLKW	1		;EXP. SIGN.

;
; MESSAGES.
;

STOVER:	.ASCIZ	"Symbol table overflow!"
PSTOVR:	.ASCIZ	"Psects table overflow!"
COLON:	.ASCIZ	":"
 
	.EVEN
 
;+
; ** ERRORS - PUT OUT ERRORS ONTO TI:
;
; THIS ROUTINE IS CALLED (FROM ASEMBL) AFTER EVERY SOURCE LINE
; IS PROCESSED BY PASS 3. IT SEARCHES THE ERROR FLAGS AND  ANY
; ERRORS FOUND ARE REPORTED.
;
; USES:
;	ALL
;-
 
ERRORS:	MOV	#ERRTAB,R3	;POINT AT FIRST ERROR

10$:	CMP	R3,#ERREND	;GOT THEM ALL
	BHIS	60$		;YES
	TSTB	(R3)+		;IS THE ERROR FLAG SET
	BEQ	50$		;NO

	TST	ARGV+2		;IS THERE ONLY 1 FILE
	BEQ	15$		;YES, FORGET THE NAME
	MOV	@ARGVPT,R4	;PUT OUT NAME IF NEEEDED
	BEQ	15$		;
	CLR	@ARGVPT		;
	MOV	#COLON,R5	;
	CALL	FMSG		;

15$:	MOV	#EBUF,R5	;POINT AT ERROR BUFFER
	MOVB	(R3),(R5)+	;CODE
	MOVB	#' ,(R5)+	;BLANK

	MOV	LNO,R0		;CONVERT LINE NUMBER
	MOV	#ECT,R1		;
20$:	MOV	#'0,R2		;START WITH "0"
30$:	CMP	R0,(R1)		;COMPUTE A DIGIT
	BLO	40$		;VIA
	SUB	(R1),R0		;VERY LONG DIVISION
	INC	R2		;
	BR	30$		;
40$:	MOVB	R2,(R5)+	;STORE CHARACTER
	TST	(R1)+		;NEXT TABLE ENTRY
	CMP	R1,#ECTE	;DONE
	BLO	20$		;NO

	CLRB	(R5)		;NULL ON THE END
	MOV	#EBUF,R5	;PUT IT OUT
	CALL	MSG		;

	CLRB	DFLAG		;CANCEL A -D

50$:	INC	R3		;NEXT ENTRY
	BR	10$		;

60$:	RETURN			;
 
;+
; ** GETLIN - GET A SOURCE LINE
;
; READ A SOURCE RECORD.
; UPDATE THE POINTERS USED TO SCAN THE LINE.
;
; USES:
;	R0
;-
 
GETLIN:	GET$S	#SFILE,#LINBUF,#80. ;READ SOURCE RECORD
	BCS	10$		;ERROR (ASSUME EOF)
	MOV	F.NRBD(R0),R0	;MARK END OF LINE WITH A NUL
	CLRB	LINBUF(R0)	;
	MOV	#LINBUF,LINPTR	;BACK UP LINE POINTER
	INC	LNO		;ADD 1 LINE UP
10$:	RETURN			;DONE
 
;+
; ** GETPCH - PEEK AT NEXT NON BLANK CHARACTER
; ** GETNB  - GET NEXT NON BLANK CHARACTER
; ** GETC   - GET NEXT CHARACTER
;
; OUTPUTS:
;	C BIT SET IF THE LINE RUNS OUT 
;	R0=CHARACTER (IF C BIT CLEAR)
;-
 
	.ENABL	LSB
 
GETPCH:	CALL	GETNB		;GET NEXT NONBLANK CHARACTER
	BCS	30$		;ISN'T ONE
	DEC	LINPTR		;PUT THE CHARACTER BACK
	BR	10$		;RETURN
 
GETNB:	CALL	GETC		;GET CHARACTER
	BCS	30$		;LINE RAN OUT
	CMPB	R0,#BLANK	;SKIP WHITE SPACE
	BEQ	GETNB		;
	CMPB	R0,#TAB		;
	BEQ	GETNB		;
	BR	10$		;RETURN
 
GETC:	MOVB	@LINPTR,R0	;GET SOURCE CHARACTER
	BEQ	20$		;END OF LINE
	INC	LINPTR		;BUMP POINTER
10$:	CLC			;COMMON RETURN, C BIT CLEAR
	BR	30$		;
20$:	SEC			;COMMON RETURN, C BIT SET
30$:	RETURN			;
 
	.DSABL	LSB
 
;+
; ** FBOK - CHECK OUT FB LABEL NUMBER
;
; INPUTS:
;	R1=THE NUMBER
;-
 
FBOK:	CMP	R1,#10.		;MUST BE 0 <= R1 <= 9
	BLO	10$		;
	CLR	R1		;FORCE IN RANGE FOR LOOKUP
	INCB	QERROR		;Q ERROR FOR FUNNY LABEL
10$:	RETURN			;
 
;+
; ** GETOKN - GET INPUT TOKEN
;
; GET THE NEXT BASIC SYMBOL FROM THE INPUT. THE VALUE OF THE
; SCANNING POINTER IS SAVED IN LINLST FOR THE BENEFIT OF THE
; UNGET ROUTINE; UNGET ONLY WORKS ONCE.
;
; OUTPUTS:
;	R0=TOKEN
;	R1=VALUE OF CONSTANTS
;-
 
GETOKN:	MOV	R2,-(SP)	;SAVE REGISTERS
	MOV	LINPTR,LINLST	;FOR UNGET
	CALL	GETNB		;GET CHARACTER, SKIPPING SPECES
	BCS	41$		;LINE RAN OUT
 
	CMPB	R0,#'0		;TEST FOR DIGITS
	BLO	42$		;
	CMPB	R0,#'9		;
	BHI	42$		;
	MOV	R0,R1		;BEGIN DECIMAL NUMBER
	MOV	R0,R2		;BEGIN OCTAL NUMBER
10$:	SUB	#'0,R1		;ASCII TO BINARY
	SUB	#'0,R2		;
	CALL	GETC		;GET A CHARACTER
	BCS	30$		;LINE RAN OUT, ITS OCTAL
	CMPB	R0,#'0		;BREAK IF NON DIGIT
	BLO	20$		;
	CMPB	R0,#'9		;
	BHI	20$		;
	ASL	R1		;MULTIPLY BY 10
	MOV	R1,-(SP)	;
	ASL	R1		;
	ASL	R1		;
	ADD	(SP)+,R1	;
	ADD	R0,R1		;ADD IN THE DIGIT
	ASL	R2		;NEXT OCTAL DIGIT
	ASL	R2		;
	ASL	R2		;
	ADD	R0,R2		;
	BR	10$		;GO FOR MORE
20$:	CMPB	R0,#'f		;TEMP LABELS
	BEQ	400$		;YES
	CMPB	R0,#'b		;
	BEQ	400$		;YES
	CMPB	R0,#'.		;DECIMAL NUMBER
	BEQ	40$		;YES, NUMBER IS IN R1
	DEC	LINPTR		;PUT THE CHARACTER BACK
30$:	MOV	R2,R1		;AND CALL THE NUMBER OCTAL
40$:	MOV	#CON,R0		;TOKEN TYPE
	BR	115$		;RETURN
 
41$:	BR	120$		;LINE RAN OUT 'MAKE IT REACH' BR
 
400$:	CALL	FBOK		;INSURE IN RANGE
	ASL	R1		;THEN
	CMPB	R0,#'f		;GET POINTER FROM APPROPRIATE TABLE
	BNE	402$		;
	MOV	FBF(R1),R1	;
	BNE	406$		;
	BR	404$		;
402$:	MOV	FBB(R1),R1	;
	BNE	406$		;
404$:	INCB	UERROR		;U ERROR IF NO LABEL
	MOV	#CON,R0		;UNDEFINED TEMP LABEL IS A CONST 0
	BR	115$		;
406$:	MOV	#TLAB,R0	;TOKEN TYPE
	BR	115$		;
	
42$:	CMPB	R0,#'<		;LEFT AND RIGHT SHIFTS
	BEQ	44$		;
	CMPB	R0,#'>		;
	BNE	50$		;
44$:	MOV	R0,R2		;SAVE THE CHARACTER
	CALL	GETC		;GET THE NEXT ONE
	BCS	48$		;NO NEXT ONE
	CMPB	R0,R2		;TEST FOR '>>' AND '<<'
	BNE	46$		;NO
	MOV	#SL,R0		;GET CORRECT TOKEN
	CMP	R2,#'<		;
	BEQ	115$		;
	MOV	#SR,R0		;
	BR	115$		;
46$:	DEC	LINPTR		;ORDINARY CHARACTER
48$:	MOV	R2,R0		;
	BR	115$		;
 
50$:	CMPB	R0,#'.		;CHECK IF LEGAL TO BEGIN AN ID
	BEQ	60$		;
	CMPB	R0,#'_		;
	BEQ	60$		;
	CMPB	R0,#'A
	BLO	115$
	CMPB	R0,#'Z
	BLOS	60$
	CMPB	R0,#'a
	BLO	115$
	CMPB	R0,#'z
	BHI	115$
60$:	MOV	#IDBUF,R1	;GET POINTER TO ID BUFFER
70$:	CMP	R1,#IDBUF+8.	;WILL THE CHARACTER FIT
	BHIS	80$		;NO, IGNORE IT
	CMPB	R0,#'_		;IS THE CHARACTER AN '_'
	BNE	75$		;NO
	MOVB	#'$,R0		;BECAUSE OF RAD50
75$:	MOVB	R0,(R1)+	;YES, SAVE IT
80$:	CALL	GETC		;GET NEXT CHARACTER
	BCS	100$
	CMPB	R0,#'.		;LOOP BACK IF LEGAL
	BEQ	70$
	CMPB	R0,#'_
	BEQ	70$
	CMPB	R0,#'0
	BLO	90$
	CMPB	R0,#'9
	BLOS	70$
	CMPB	R0,#'A
	BLO	90$
	CMPB	R0,#'Z
	BLOS	70$
	CMPB	R0,#'a
	BLO	90$
	CMPB	R0,#'z
	BLOS	70$
90$:	DEC	LINPTR		;PUT THE CHARACTER BACK
100$:	CMP	R1,#IDBUF+8.	;PAD THE NAME
	BHIS	110$
	CLRB	(R1)+
	BR	100$
110$:	MOV	#ID,R0		;RETURN ID
115$:	CLC			;GOOD RETURN
120$:	MOV	(SP)+,R2	;ELSE RETURN THE CHARACTER
	RETURN
 
;+
; ** UNGET - PUT 1 TOKEN BACK
;
; THIS ROUTINE 'UNGETS' THE LAST TOKEN OBTAINED BY CALLING GETOKN.
; CAVEAT: IT ONLY WORKS ONCE; YOU CANNOT PUSH BACK SEVERAL TOKENS
; INTO THE INPUT.
;-
 
UNGET:	MOV	LINLST,LINPTR	;BACK UP THE SOURCE POINTER
	RETURN
 
;+
; ** LOOKUP - LOOKUP SYMBOL
;
; INPUTS:
;	R5=POINTER TO SYMBOL TABLE
;		(R5)=POINTER TO JUST PAST THE LAST ENTRY
;	       2(R5)=START OF THE FIRST SYMBOL
;    IDBUF=THE NAME TO LOOK UP
;
; OUTPUTS:
;	R5=POINTER TO SYMBOL IF FOUND
;-
 
LOOKUP:	MOV	R4,-(SP)	;SAVE REGISTERS
	MOV	R3,-(SP)
	MOV	R2,-(SP)
	MOV	(R5)+,R4	;GET POINTER TO TABLE END
 
10$:	CMP	R5,R4		;IS THERE MORE
	BHIS	40$		;NO
	MOV	R5,R3		;POINT AT NAME IN THE NODE
	ADD	#S.N,R3
	MOV	#IDBUF,R2	;AND AT THE ID BUFFER
 
20$:	CMPB	(R2)+,(R3)+	;SEE IF THEY MATCH
	BNE	30$		;NO
	CMP	R2,#IDBUF+8.	;PERHAPS
	BLO	20$		;NOT YET
	CLC			;FOUND IT
	BR	50$
 
30$:	ADD	#S.SIZE,R5	;MOVE TO NEXT ENTRY
	BR	10$
 
40$:	SEC			;NOT THERE
50$:	MOV	(SP)+,R2	;RETURN
	MOV	(SP)+,R3
	MOV	(SP)+,R4
	RETURN
 
;+
; ** INSERT - ADD A SYMBOL TO THE USER TABLE
;
; PUT SYMBOL IN IDBUF INTO THE USER SYMBOL TABLE. CHECK FOR THE
; TABLE OVERFLOWING, BUT NOT FOR DUPLICATE ENTRIES.
;
; OUTPUTS:
;	R5=POINTER TO THE NEW ENTRY
;-
 
INSERT:	MOV	R4,-(SP)	;SAVE REGISTERS
	MOV	UST,R5		;GET POINTER TO THE END OF THE TABLE
	CMP	R5,#USTMAX	;CHECK FOR NO ROOM
	BHIS	20$
 
	CLR	(R5)+		;S.V = 0
	MOV	#ST.UND,(R5)+	;S.T = UNDEFINED
	CLR	(R5)+		;S.F = 0
	MOV	#IDBUF,R4	;COPY IN THE NAME
10$:	MOVB	(R4)+,(R5)+
	CMP	R4,#IDBUF+8.
	BLO	10$
 
	MOV	R5,UST		;SET NEW TOP OF TABLE
	SUB	#S.SIZE,R5	;POINT AT THE NEW ENTRY
	MOV	(SP)+,R4	;RETURN
	RETURN
 
20$:	TST	ARGV+2		;1 FILE
	BEQ	30$		;YES, NO NAME
	MOV	@ARGVPT,R4	;SYMBOL TABLE OVERFLOW
	BEQ	30$
	MOV	#COLON,R5
	CALL	FMSG
30$:	MOV	#STOVER,R5
	CALL	MSG
	MOV	SPSAVE,SP
	RETURN			;THIS IS A RETURN FROM ASEMBL
 
;+
; ** GLOBS - MAKE UNDEFINED SYMBOLS GLOBAL
;
; USES:
;	R4, R5
;-
 
GLOBS:	MOV	UST,R4		;END POINTER
	MOV	#UST+2,R5	;START POINTER
10$:	CMP	R5,R4		;BREAK IF AT THE END
	BHIS	30$
	CMP	S.T(R5),#ST.UND	;IS IT UNDEFINED
	BNE	20$		;NO
	BIS	#SF.GBL,S.F(R5)	;YES, MAKE IT GLOBAL
20$:	ADD	#S.SIZE,R5
	BR	10$
30$:	RETURN
 
;+
; ** GETPS - GET PSECT TABLE POINTER
;
; INPUTS:
;    IDBUF=NAME OF THE PSECT
;
; OUTPUTS:
;	R5=POINTER TO PSECT TABLE ENTRY
;-
 
GETPS:	MOV	R4,-(SP)	;LOOK IT UP
	MOV	#PSECT,R5
	CALL	LOOKUP
	BCC	20$		;FOUND IT
	MOV	PSECT,R5	;ADD NEW ENTRY TO TABLE
	CMP	R5,#PSECTM	;SEE IF FULL
	BHIS	30$
	CLR	(R5)+		;P.L
	MOV	#PF.REL,(R5)+	;P.F
	CLR	(R5)+		;P.FUZZ
	MOV	#IDBUF,R4	;P.N
10$:	MOVB	(R4)+,(R5)+
	CMP	R4,#IDBUF+8.
	BLO	10$
	MOV	R5,PSECT	;FIX END OF TABLE POINTER
	SUB	#P.SIZE,R5
20$:	MOV	(SP)+,R4
	RETURN
 
30$:	TST	ARGV+2		;1 FILE
	BEQ	40$		;YES, NO NAME
	MOV	@ARGVPT,R4	;PSECT TABLE OVERFLOW
	BEQ	40$
	MOV	#COLON,R5
	CALL	FMSG
40$:	MOV	#PSTOVR,R5
	CALL	MSG
	MOV	SPSAVE,SP
	RETURN			;FROM ASEMBL
 
;+
; ** MAPC -- GET CHARACTER IN STRING.
;
; INPUTS:
;	R5=DELIMITER
;
; OUTPUTS:
;	R0=CHARACTER.
;	C BIT SET ON END OF STRING
;-

MAPC:	CALL	GETC		;GET A CHARACTER
	BCS	100$		;EOF IS BAD.
	CMP	R0,R5		;MATCH DELIMITER?
	BEQ	110$		;END

	CMP	R0,#'\		;ESCAPE?
	BNE	90$		;NOPE.

	CALL	GETC		;GET ANOTHER.
	BCS	100$		;EOF IS AN ERROR.

	CMP	R0,#'t		;\T IS TAB
	BNE	10$
	MOV	#11,R0
	BR	90$

10$:	CMP	R0,#'n		;\N IS NEWLINE
	BNE	20$
	MOV	#12,R0
	BR	90$

20$:	CMP	R0,#'b		;\B IS BACKSPACE
	BNE	30$
	MOV	#10,R0
	BR	90$

30$:	CMP	R0,#'r		;\R IS CARRIAGE RETURN
	BNE	40$
	MOV	#15,R0
	BR	90$

40$:	CMP	R0,#'f		;\F IS FORM FEED
	BNE	50$
	MOV	#14,R0
	BR	90$

50$:	CMP	R0,#'0		;\NNN
	BLO	100$
	CMP	R0,#'9
	BHI	100$

	MOV	R2,-(SP)	;SAVE REGISTERS
	MOV	R3,-(SP)
	MOV	#3,R2		;LOOP COUNTER
	MOV	R0,R3		;ACCUMULATOR

60$:	SUB	#'0,R3		;MAKE BIN.
	DEC	R2		;TEST IF MORE DIGITS
	BLE	80$		;NO
	CALL	GETC
	BCS	80$		;QUICK END
	CMP	R0,#'0
	BLO	70$		;HARD END
	CMP	R0,#'9
	BHI	70$
	ASL	R3		;R3 = 8*R3 + CHAR
	ASL	R3
	ASL	R3
	ADD	R0,R3
	BR	60$

70$:	DEC	LINPTR		;PUT DELIMITER BACK
80$:	MOV	(SP)+,R3	;RESTORE REGISTERS
	MOV	(SP)+,R2

90$:	CLC
	RETURN

100$:	INCB	QERROR		;FUNNY STUFF
110$:	SEC
	RETURN

;+
; ** ATOF -- ASCII TO FLOATING.
;
; THIS ROUTINE CONVERTS A STRING OF ASCII CHARACTERS TO DOUBLE LENGTH
; FLOATING POINT BINARY. THE NUMBER IS ROUNDED TO DOUBLE LENGTH.  THE
; SCAN STOPS ON THE FIRST CHARACTER THAT IS NOT LEGAL.
;
; OUTPUTS:
;	R0=WORD 0.
;	R1=WORD 1.
;	R2=WORD 2.
;	R3=WORD 3.
;-

ATOF:	MOV	#FBUF,R0	;CLEAR WORK AREAS.
10$:	CLR	(R0)+		;
	CMP	R0,#FESGN+2	;
	BLO	10$		;
	MOV	#65.,FBEX	;SET BINARY EXP.

	CALL	GETNB		;GET A CHARACTER.
	BCS	107$		;EOL
	CMP	R0,#'+		;IS IT A "+"
	BEQ	19$		;YES, IGNORE
	CMP	R0,#'-		;IS IT A "-"
	BNE	30$		;NO
	MOV	#100000,FSGN	;YES, SET SIGN FLAG

19$:	INC	FANY		;GOT SOMETHING.
20$:	CALL	GETC		;GET NEXT CHARACTER
	BCS	107$		;EOL

30$:	CMP	R0,#'0		;IS IT A DIGIT
	BLO	60$		;NO
	CMP	R0,#'9		;WELL
	BHI	60$		;NO
	INC	FANY		;GOT SOME
	BIT	#174000,FBUF	;CAN WE HANDLE ANOTHER DIGIT.
	BEQ	40$		;YES
	INC	FEXP		;NO, ADJUST SCALE.
	BR	50$		;

40$:	CALL	FM5		;MULTIPLY BY 10
	CALL	FLS		;
	MOV	#FBUF+10,R1	;ADD IN THE DIGIT
	SUB	#'0,R0		;
	ADD	R0,-(R1)	;
	ADC	-(R1)		;
	ADC	-(R1)		;
	ADC	-(R1)		;

50$:	ADD	FDOT,FEXP	;FDOT IS -1 AFTER THE "."
	BR	20$		;

60$:	CMP	R0,#'.		;DECIMAL POINT
	BNE	70$		;NO
	INC	FANY		;GOT SOME
	COM	FDOT		;FLIP DOT FLAG
	BMI	20$		;GO FOR MORE
	BR	110$		;SECOND ".", QUIT

70$:	CMP	R0,#'E		;EXPONANT
	BEQ	80$		;YES
	CMP	R0,#'e		;IN EITHER CASE
	BNE	110$		;NO, END

80$:	INC	FANY		;GOT SOME
	CLR	R1		;GET EXPONANT
	CALL	GETC		;GET FIRST CHARACTER
	BCS	107$		;EOL
	CMP	R0,#'+		;IS IT A "+"
	BEQ	90$		;YES, IGNORE
	CMP	R0,#'-		;IS IT A "-"
	BNE	100$		;NO
	INC	FESGN		;SET FLAG

90$:	CALL	GETC		;GRAB NEXT
	BCS	107$		;EOL

100$:	CMP	R0,#'0		;IS IT A DIGIT
	BLO	105$		;NO
	CMP	R0,#'9		;
	BHI	105$		;NO
	ASL	R1		;ADD IN THE DIGIT
	MOV	R1,R2		;
	ASL	R1		;
	ASL	R1		;
	ADD	R2,R1		;
	SUB	#'0,R0		;
	ADD	R0,R1		;
	BR	90$		;

105$:	TST	FESGN		;IS IT NEGATIVE
	BEQ	106$		;NO
	NEG	R1		;FIX

106$:	ADD	R1,FEXP		;FIX EXPONANT
	BR	110$		;

;
; ON EOL CHECK IF WE GOT ANYTHING
; IF NO, ERROR.
;

107$:	TST	FANY		;ANYTHING?
	BNE	111$		;YES
	INCB	NERROR		;UGH!
	BR	111$		;

;
; DONE COLLECTING.
; IF "FEXP" IS NON ZERO (DECIMAL SCALE) APPLY
; THE SCALING TO THE BINARY NUMBER.
;

110$:	DEC	LINPTR		;UNGET.
111$:	MOV	#FBUF,R0	;QUICK CHECK FOR "0".
	MOV	(R0)+,R1	;
	BIS	(R0)+,R1	;
	BIS	(R0)+,R1	;
	BIS	(R0)+,R1	;
	BEQ	200$		;BR IF 0.

	TST	FEXP		;ANY SCALING?
	BEQ	180$		;NO
	BLT	150$		;YES, DIVIDE

120$:	CMP	FBUF,#31426	;CAN IT HANDLE A * 5?
	BHI	130$		;NO
	CALL	FM5		;YES, MULTIPLY BY 5
	INC	FBEX		;AND BY 2
	BR	140$		;

130$:	CALL	FM54		;MULTIPLY BY 5/4
	ADD	#3,FBEX		;AND BY 8

140$:	DEC	FEXP		;LOOP UNTIL ALL DONE
	BNE	120$		;
	BR	180$		;

150$:	TST	FBUF		;LEFT JUSTIFY
	BMI	155$		;
	DEC	FBEX		;
	CALL	FLS		;
	BR	150$		;

155$:	MOV	#40,R1		;SET STEP COUNT
	CALL	FRS		;SHIFT RIGHT ONCE AND
	CALL	FSV		;COPY TO SAVE BUFFER

160$:	BIT	#1,R1		;ODD ITERATION?
	BNE	170$		;YES.
	CALL	FRS		;NO, 2 EXTRA
	CALL	FRS		;SHIFTS.

170$:	CALL	FRS		;SHIFT RIGHT.
	CALL	FAD		;ADD IN SAVE BUFFER.
	DEC	R1		;
	BNE	160$		;

	SUB	#3,FBEX		;DIVIDE BY 8.
	INC	FEXP		;DO ALL THE SCALING.
	BNE	150$		;

;
; NORMALIZE.
; D.P. ROUND.
; PUT THE NUMBER TOGETHER.
;

180$:	DEC	FBEX		;NORMALISE AND
	CALL	FLS		;GOBBLE UP THE
	BCC	180$		;HIDDEN BIT.

	MOV	#FBUF+10,R0	;BEGIN D.P. ROUND.
	ADD	#400,-(R0)	;JUST BELOW LAST BIT WE KEEP.
	ADC	-(R0)		;RIPPLE
	ADC	-(R0)		;IN
	ADC	-(R0)		;CARRIES.
	BCC	185$		;IF NC, HIDDEN BIT STILL "1".
	INC	FBEX		;CARRY COMPLEMENTS THE
	CALL	FRS		;HIDDEN BIT.

185$:	ADD	#200,FBEX	;EXCESS 128.
	BLE	186$		;UNDERFLOW
	TSTB	FBEX+1		;AND
	BEQ	187$		;OVERFLOW
186$:	INCB	NERROR		;NUMBER SYNTAX

187$:	MOV	#FBUF+10,R0	;SLIDE DOWN BY 8 BITS.
	MOV	#FBUF+6,R1	;
190$:	CMP	-(R0),-(R1)	;BACK UP 1 WORD.
	MOVB	(R1),(R0)	;SLIDE A BYTE.
	SWAB	(R0)		;WATCH BYTE ORDER.
	CMP	R0,#FBUF	;DO IT ALL
	BHI	190$		;INCLUDING FBEX.

	CALL	FRS		;THEN MAKE ROOM FOR SIGN
	ADD	FSGN,FBUF	;AND ADD IT IN.

200$:	MOV	FBUF,R0		;MOVE
	MOV	FBUF+2,R1	;TO
	MOV	FBUF+4,R2	;RIGHT
	MOV	FBUF+6,R3	;PLACE

	RETURN			;

;
; LOCAL ROUTINES.
;

FSV:	MOV	#FBUF,R2	;MOVE FBUF TO FSAV
	MOV	#FSAV,R3	;

10$:	MOV	(R2)+,(R3)+	;
	CMP	R2,#FBUF+10	;
	BLO	10$		;
	RETURN			;

FRS:	MOV	#FBUF,R2	;RIGHT SHIFT
	CLC			;
	ROR	(R2)+		;
	ROR	(R2)+		;
	ROR	(R2)+		;
	ROR	(R2)		;
	RETURN			;

FLS:	MOV	#FBUF+10,R2	;LEFT SHIFT
	ASL	-(R2)		;
	ROL	-(R2)		;
	ROL	-(R2)		;
	ROL	-(R2)		;
	RETURN			;

FM54:	CMP	FBUF,#146314	;MULTIPLY BY 5/4
	BLO	10$		;ROOM.
	CALL	FRS		;ADJUST.
	INC	FBEX		;

10$:	CALL	FSV		;SAVE IN FSAV
	CALL	FRS		;SCALE
	CALL	FRS		;RIGHT.
	BR	FAD		;ADD AND RETURN.

FM5:	CALL	FSV		;MULTIPLY BY 5.
	CALL	FLS		;
	CALL	FLS		;

FAD:	MOV	#FBUF+10,R2	;ADD FSAV TO FBUF
	MOV	#FSAV+10,R3	;

10$:	ADD	-(R3),-(R2)	;DO AN ADD
	BCC	30$		;NO CARRIES.
	MOV	R2,R4		;RIPPLE UP THE CARRIES.
20$:	ADC	-(R4)		;
	BCS	20$		;

30$:	CMP	R2,#FBUF	;LOOP TIL DONE
	BHI	10$		;
	RETURN			;
	.END