.IIF	NDF	RSX	RSX	=	1	;Assume RSX	;01+
	.TITLE	AS3C
	.ident	/X01.09/

	.NLIST	BEX
	.ENABL	LC,GBL
	.LIST	MEB,CND						;01-

;
; AS
; LEXICAL THINGS
;
; VERSION X01
;
; DAVID G. CONROY	24-MAY-78
; LAST UPDATED:		11-JUN-79
;
; Edit history
; 01 04-Mar-80 MM	Added RT11 support
; 02 17-Mar-80 MM	HACK -- "_" -> ".", "~" -> "$"
; 03 06-Jan-81 RBD	IDBUF -> global for binary searcher
; 04 26-Feb-82 RBD	INSERT no longer used ... deleted
;			Change GLOBS for tree UST
; 05 22-Jul-82 CCG	Added arguments to .psect directives
; 06 02-Aug-82 MM	Preserve '_' in symbols, becomes '.' at rad50 convert
; 07 07-Aug-82 MM	Symbol table changes
; 08 08-Jan-83 MM	Move IDBUF to root for RT11 linker
; 09 21-Mar-83 MM	Don't need padding byte now
;

;;	.GLOBL	IDBUF							;03/08
	.GLOBL	ERRORS
	.GLOBL	GETLIN
	.GLOBL	GETPCH
	.GLOBL	GETOKN
	.GLOBL	GETNB
	.GLOBL	GETC
	.GLOBL	ATOF
	.GLOBL	UNGET
;	.GLOBL	LOOKUP		; No longer globalized			;07
	.GLOBL	GLOBS
	.GLOBL	GETPS
	.GLOBL	FBOK
	.GLOBL	MAPC
	.GLOBL	LINBUF
	.GLOBL	LINPTR

.IF NE	RSX							;01
	.MCALL	CALL
	.MCALL	CALLR
	.MCALL	RETURN
.ENDC								;01

;
; 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
;;	.BLKB	1		;GETS SIZE IN SRCUST			;07/09
;;IDBUF:	.BLKB	8.	;IDENTIFIER -- SHORT ID'S ARE NULL PADDED ;08
;;	.BYTE	0		;ALWAYS NULL-TERMINATE ID BUFFER	;07/08
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!"
.IF NE	RSX							;01
COLON:	.ASCIZ	":"
.ENDC								;01

	.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

.IF NE	RSX							;01
	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		;
.ENDC								;01

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		;
	MOV	#LINBUF,R5	;ECHO THE INPUT LINE			;07
	CALL	MSG		;TOO.					;07

	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:								;01+
	MOV	#SFILE,R0	;FILE DATA BLOCK
	MOV	#80.,-(SP)	;LINE LENGTH
	MOV	#LINBUF,-(SP)	;LINE BUFFER START
	CALL	RDLINE		;GO GET IT
	BIT	(SP)+,(SP)+	;DUMP THE STACK			;01-
	BCS	10$		;ERROR (ASSUME EOF)
	CLRB	LINBUF(R0)	;
;DEBUG+
.if ne 0
	movb	pass,r0
	add	#'0,r0
	movb	r0,20$
	.mcall .print
	.print	#20$
	.print	#linbuf
.iftf
	MOV	#LINBUF,LINPTR	;BACK UP LINE POINTER
	INC	LNO		;ADD 1 LINE UP
10$:	RETURN			;DONE
.ift
20$:	.ascii	/0/<200>
	.even
.endc
;DEBUG-

;+
; ** 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,#<176>	;HACK TILDE BECOMES $		;02
	BEQ	60$		;				;02
	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,#<176>	;HACK -- CHANGE TILDE INTO	;02
	BNE	72$		; $ FOR RAD50.  DON'T YOU WISH	;02
	MOVB	#'$,R0		; UNIX WASN'T SO CLEVER?	;02
72$:								;02
;	CMPB	R0,#'_		;IS THE CHARACTER AN '_'	;06
;	BNE	75$		;NO				;06
;	MOVB	#'.,R0		;BECAUSE OF RAD50		;02/06
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,#<176>	;HACK ACCEPT TILDE		;02
	BEQ	70$		;HACK				;02
	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 -- NEEDED TO OUTPUT RAD50
	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 IN PSECT TABLE
;
; 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, NULL-TERMINATED
;
; OUTPUTS:
;	R5=POINTER TO SYMBOL IF FOUND
;	C-BIT CLEAR IF FOUND, SET IF NOT 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	#P.N,R3
	MOV	#IDBUF,R2	;AND AT THE ID BUFFER

20$:	CMPB	(R2)+,(R3)	;SEE IF THEY MATCH			;07+
	BNE	30$		;NO
	TSTB	(R3)+		;SO FAR.  ARE WE AT THE END?
	BNE	20$		;NOT YET				;07-
	CLC			;FOUND IT
	BR	50$

30$:	ADD	#P.SIZE,R5	;MOVE TO NEXT ENTRY			;07
	BR	10$

40$:	SEC			;NOT THERE
50$:	MOV	(SP)+,R2	;RETURN
	MOV	(SP)+,R3
	MOV	(SP)+,R4
	RETURN
;+
; ** GLOBS - MAKE UNDEFINED SYMBOLS GLOBAL
;
; USES:
;	R5							;04+
;-
GLOBS:	MOV	#10$,R5		;WHOM TO CALL			;07+
	CALLR	SYWALK		;THAT'S ALL FOLKS.

10$:	CMP	S.T(R5),#ST.UND	;IS IT UNDEFINED
	BNE	20$		;NO
	BIS	#SF.GBL,S.F(R5)	;YES, MAKE IT GLOBAL
20$:	RETURN			;RETURN				;04-/07-
;+
; ** 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+PF.BT3,(R5)+	;P.F			;01
	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$:								;05+
;
; Allow arguments
;
	CALL	GETOKN		;Seize parameters
	BCS	170$		;Exit if EOL
	CMP	R0,#ID		;Is it an ident.
	BNE	160$		;NO, Q error and exit.
130$:	MOV	#PSARGS,R4	;Point to psect arg. table
140$:	CMPB	(R4)+,IDBUF	;Match?
	BNE	150$		;Skip if not
	BISB	(R4),P.F(R5)	;If match, set flag
	BR	20$		;And try again
150$:	INC	R4		;Skip over flags
	TSTB	(R4)		;At end of table?
	BNE	140$		;Loop for more if not
160$:	INCB	QERROR		;No match, flag error
170$:				;				;05-
	MOV	(SP)+,R4
	RETURN

30$:								;01
.IF NE	RSX							;01
	TST	ARGV+2		;1 FILE
	BEQ	40$		;YES, NO NAME
	MOV	@ARGVPT,R4	;PSECT TABLE OVERFLOW
	BEQ	40$
	MOV	#COLON,R5
	CALL	FMSG
.ENDC								;01
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

