.TITLE	'Lawrence Livermore Labs BASIC'
; NOTE: SEND and READ are ODT routines to handle TTYIN/TTYOUT

MEMST	.EQU	30000O	;MUST BE ON PAGE BOUNDARY
MEMEND	.EQU	37777O
SEND	.EQU	6	;RST FOR ODT
OBUFF	.EQU	MEMST	;INPUT AND OUTPUT BUFFERS OCCUPY
IBUF	.EQU	MEMST+1	;SAME AREA
STLINE	.EQU	MEMST+111O
NLINE	.EQU	MEMST+113O
NL2	.EQU	MEMST+115O
NL4	.EQU	MEMST+117O
NL6	.EQU	MEMST+121O
KLINE	.EQU	MEMST+122O
KL2	.EQU	MEMST+124O
KL4	.EQU	MEMST+126O
KL6	.EQU	MEMST+130O
PLINE	.EQU	MEMST+131O
PL2	.EQU	MEMST+133O
PL4	.EQU	MEMST+135O
SBSAV	.EQU	PL4	;RETURN ADD. SAVE FOR CALL STMT.
PL6	.EQU	MEMST+137O
KASE	.EQU	MEMST+140O
LEN	.EQU	MEMST+141O
MULT1	.EQU	MEMST+142O
MULT2	.EQU	MEMST+144O
NXTSP	.EQU	MEMST+131O
STSPAC	.EQU	MEMST+113O
NORM	.EQU	7707O
FLOAT	.EQU	7712O
ZROL	.EQU	7715O
LPNT	.EQU	MEMST+122O
KLEN	.EQU	MEMST+130O
CPNT	.EQU	MEMST+133O
KFPNT	.EQU	MEMST+126O
FREG2	.EQU	MEMST+200O
CREG	.EQU	MEMST+204O
LADD	.EQU	7720O
LMUL	.EQU	7723O
LDIV	.EQU	7726O
LSUB	.EQU	7731O
DFXL	.EQU	7734O
LMCM	.EQU	7737O
HLINP	.EQU	MEMST+206O
GREG	.EQU	MEMST+167O
FREG1	.EQU	MEMST+174O
SCR	.EQU	MEMST+146O
CONV	.EQU	7745O
MODE	.EQU	MEMST+205O
FINPT	.EQU	7750O
MULT	.EQU	7753O
PTVAL	.EQU	7756O
DCOMP	.EQU	7761O
MCHK	.EQU	7764O
CHAR2	.EQU	7767O
MESCR	.EQU	MEMST+210O	;DEFINE MEMORY SCR AREA PNTR
VARAD	.EQU	MEMST+212O	;TEMP SPACE FOR INP. STMT.
VNAME	.EQU	MEMST+214O	;TEMP SPACE FOR 'FOR-NEXT'
VLOC	.EQU	MEMST+216O	;TEMP SPACE FOR 'FOR-NEXT'
FLIMT	.EQU	MEMST+220O	;TEMP SPACE FOR 'FOR-NEXT'
NEST	.EQU	MEMST+224O	;NESTING STACK-POINTER
STAC	.EQU	MEMST+226O	;FOR-NEXT NESTING STACK
STSIZ	.EQU 	$2C		;STACK SIZE,ALLOWS 10 NESTED FOR-NEXT
TOPNS	.EQU	STAC		;TOP OF STACK
BOTNS	.EQU	STAC+STSIZ	;BOTTOM OF STACK
VEND	.EQU	MEMST+252O	;DEF. END OF VAR. STORAGE AREA

;MAIN ROUTINE--HANDLES ALL USER INPUT
	.ORG	10000O
M1:	LXI	H,OBUFF
	MVI	M,1
	LXI	H,STLINE
	MVI	M,377O
	INR	L
	MVI	M,377O
	LHLD	FWAM	;GET ADDRES OF FWA MEM.
	SHLD	NLINE	;STORE IN FREE SPACE PNTR.
M1A:	LXI	SP,MEMEND
M2:	LXI	H,ODATA
	CALL	FORM1
	CALL	WRIT
M3:	LHLD 	NLINE
	INX	H
	INX	H
	INX	H
	INX	H
	INX	H
	CALL	TTYIN
	MOV	C,A
	CPI	0
	JZ	M3
	CALL	ALPHA
	JC	M4
	CALL	NUMB
	CNC	WHAT
	CALL	INSERT
	JMP 	M3	; END OF PAGE 16

M4:	MVI	A,0
	CALL	SYMSRT
M4A:	INR	A
	CZ	WHAT
	DCR	A
	JZ	RUN
	DCR	A
	CZ	TAPE
	JZ	M2
	DCR	A
	CZ	LIST
	JZ	M2
	DCR	A
	JZ	M1
	DCR	A
	CNZ 	WHAT

; ROUTINE TO INPUT FROM HSR
PTAPE:	CALL	CHAR5
	CPI	0
	JZ	PTAPE
PT1:	CALL	HSRIN
	MOV	C,A
	CPI	0
	JZ	PTAPE
	CALL	ALPHA
	JC	M4
	CALL	INSERT
	CALL	CHAR5
	CPI	0
	JZ	M2
	INX	H
	INX	H
	INX	H
	INX	H
	INX	H
	JMP 	PT1

; ROUTINE TO HANDLE ALL SOURCE LINE INPUT
; THIS INCLUDES INSERTION DELETION, AND
; ADDITION CF NEW SOURCE LINES.
INSERT:	DCX	H
	MOV	M,C
	INX	H
	CALL	CVB
	CPI	5
	JC	ISR1A
	CNZ	WHAT
	MOV	A,E
	RAL
	CC	WHAT
ISR1A:	LHLD 	NLINE
	MOV	M,D
	INX	H
	MOV	M,E
	LXI	H,NLINE
	CALL	PTVAL
	LHLD	STLINE
	CALL	CHK1
	JNC	ISRT3
	LHLD	NLINE
	SHLD	STLINE
ISRT1:	MVI	D,377O
	MOV	E,D
	CALL	STPNT
	INX	H
ISRT2:	MOV	A,M
	ADI	5
	LHLD	NLINE
	ADD	L
	MOV	L,A
	MVI	A,0
	ADC	H
	MOV 	H,A
	SHLD	NLINE
	RET
ISRT3:	SHLD	KLINE
ISRT4:	LXI	H,KLINE
	CALL	PTVAL
	LXI	H,NL2
	MOV	D,M
	INR	L
	MOV	E,M
	LXI	H,KL2
	MOV	B,M
	INR	L
	MOV	C,M
	CALL	DCOMP
	JZ	ISRT6
	JC 	ISR12
	LHLD	KL4
	CALL	CHK1
	JC	ISRT5
	PUSH	H
	LHLD	KLINE	; END OF PAGE 17
	SHLD	PLINE
	LXI	H,PLINE
	CALL	PTVAL
	POP	H
	SHLD	KLINE
	JMP	ISRT4
ISRT5:	LHLD	NLINE
	CALL	NOLINE
	RZ
	XCHG
	LHLD	KLINE
	CALL	STPNT
	XCHG
	JMP	ISRT1
ISRT6:	LHLD	NLINE
	CALL	NOLINE
	JNZ	ISRT8
	LHLD	STLINE
	XCHG
	LHLD	KLINE
	PUSH	H
	POP	B
	CALL	DCOMP
	LHLD	KL4
	JZ	ISRT7
	XCHG
	LHLD	PLINE
	CALL	STPNT
	RET
ISRT7:	SHLD	STLINE
	RET
ISRT8:	LHLD	KL4
	XCHG
	LHLD	NLINE
	CALL	STPNT
ISRT9:	LHLD	KLINE
	XCHG
	LHLD	STLINE
	PUSH	H
	POP	B
	CALL	DCOMP
	JZ	ISR11
	LHLD	NLINE
	XCHG
	LHLD	PLINE
	CALL	STPNT
ISR10:	LXI	H,NL6
	JMP	ISRT2
ISR11:	LHLD	NLINE
	SHLD	STLINE
	JMP	ISR10
ISR12:	LHLD	KLINE
	XCHG
	LHLD	NLINE
	CALL	NOLINE
	RZ
	CALL	STPNT
	JMP	ISRT9

; ROUTINE TO STORE POINTERS INTO MEM ARRAY
STPNT:	INX	H
	INX	H
	MOV	M,E
	INX	H
	MOV	M,D
	RET

; ROUTINE TO CHECK NEW LINE FOR SOURCE STMT.
NOLINE:	PUSH	H
	INX	H
	INX	H
	INX	H
	INX	H
	MOV	C,M
	INX	H
	CALL	LENGTH
	POP	H
	CMP	C
	RET

;ROUTINE TO RESPOND WITH 'WHAT?' FOR UNIDENTIFIED COMMAND.
WHAT:	LXI	H,ODATA
	CALL	FORM7
	CALL	WRIT
	JMP	M1A

; ROUTINE TO PUNCH PAPER TAPE OF SOURCE.
TAPE:	PUSH	PSW
	PUSH	B	; 0XC5
	LXI	H,ODATA
	CALL	FORM2
	CALL	WRIT
	MVI	A,0
	POP	B
	MVI	B,100O
	PUSH	PSW	; END OF PAGE 18
	PUSH	B
	CALL	PAD
	CALL	WRIT
	POP	B
	PUSH	B
	CALL	LIST
	POP	B
	POP	PSW
	CALL	PAD
	CALL	WRIT
	POP 	PSW
	RET

; ROUTINE TO LIST TO TTY THE SOURCE STMTS.
LIST:	LHLD	STLINE
	CALL	CHK1
	JC	M1A
	SHLD	PLINE
	LXI	H,177777O
	SHLD	KLINE
	DCR	C
	CNZ	BOUND
	LHLD	PLINE
LIS1:	INX	H
	INX	H
	MOV	B,M
	INX	H
	MOV	C,M
	PUSH	B
	INX	H
	CALL	FORM5
	CALL	WRIT
	POP	B
	LHLD	KLINE
	XCHG
	CALL	DCOMP
	RZ
	MOV	L,B
	MOV	H,C
	CALL	QUITT	;CHECK FOR INTERRUPTION
	JMP	LIS1	;NONE - CONTINUE

;THIS ROUTINE CHECKS PORT 2 FOR A CNTRL/S CHARACTER
;IF ONE IS FOUND THEN EXECUTION IS TO BE INTERRUPTED
;CONTROL IS PASSED TO M1A
QUITT:	IN	3	;TEST FLAG PORKT
	RAR		;FLAG TO CY
	RNC		;NOTHING THERE
	IN	2	;FLAG WAS SET, GET DATA
QTCHK:	CPI	223O	;WAS IT CNTRL/S?
	JZ	M1A	;YES
	RET		;NO, RETURN

;ROUTINES NUMB AND ALPHA CHECK IF CONTENTS OF MEMORY
;LOCATION IN HL CONTAIN ASCII NUMERIC OR ALPHABETIC
;CHARACTER. RETURN CY=1 IF YES, CY=0 IF NO.
NUMB:	PUSH 	B
	MVI	B,260O
	MVI	C,272O
C1:	MOV	A,M
	CMP	B
	CMC
	JNC	BAC
	CMP	C
BAC:	POP	B
	RET
ALPHA:	PUSH 	B
	MVI	B,301O
	MVI	C,333O
	JMP	C1

;ROUTINE TO CONVERT ASCII NUMERIC CHAR. STRING TO
;EQUIVALENT BINARY NUMBER. RETURNS EQUIVALENT IN
;DE REG. LENGTH OF LINE PASSED IN REG C AND
;RETURNED POINTING TO LAST NUMERIC CHAR. LENGTH
;OF CHAR STRING RETURNED IN REG A.
CVB:	PUSH 	H
	PUSH	B
	CALL	LENGTH
	PUSH	PSW
	PUSH	H
	CPI 	0
	JZ	CVB2
	LXI	H,KASE
	MOV	M,A
	INR	L
	MOV	M,C
	LXI	H,10
	SHLD	MULT1
	LXI	H,0
	SHLD	MULT2
	LXI	H,MULT2+1
CVB1:	CALL	MULT
	XTHL
	MOV	A,M
	SBI 	260O
	ADD 	D	; END OF PAGE 19
	MOV	D,A
	MVI	A,0
	ADC	E
	MOV	E,A
	INX	H
	XTHL
	MOV	M,D
	INR	L
	MOV	M,E
	PUSH	H
	LXI	H,LEN
	DCR	M
	DCR	L
	DCR	M
	POP	H
	JNZ	CVB1
CVB2:	POP	H
	POP	PSW
	POP	B
	LXI	H,LEN
	MOV	C,M
	POP	H
	RET

;ROUTINE TO EVALUATE LENGTH OF ASCII NUMERIC
;CHAR STRLING: PASSED ADD OF FIRST CHAR IN HL REG
;RETURNS LENGTH IN REG A.
LENGTH: 	PUSH	B
	PUSH	H
	MVI	B,0
NLE1:	CALL 	NUMB
	JNC	NLE2
	INX	H
	INR	B
	DCR	C
	JZ	NLE2
	JMP	NLE1
NLE2:	MOV	A,B
	POP	H
	POP	B
	RET

;ROUTINE TO LOCATE SOURCE LINE IN MEM. PASSED BIN VALUE
;OF LINE NUMBER IN DE(LOW HIGH) REG. RETURNS ADDRESS OF
;SOURCE LINE IN HL REGS.(HIGH,LOW). CY SET=@ NOT FOUND.
NSRCH:	LHLD	STLINE
L2:	CALL	CHK1
	RC
	MOV	B,M
	INX	H
	MOV	C,M
	CALL	DCOMP
	JZ	FOUND
	INX	H
	MOV	A,M
	INX	H
	MOV	H,M
	MOV	L,A
	JMP	L2
FOUND:	DCX	H
	ORA	A
	RET

;ROUTINE TO COMPARE CONTENTS OF HL TO 177777Q.
;RETURNS CY=1 IF YES; CY=0 IF NO.
CHK1:	PUSH 	B
	PUSH	H
	MVI	B,0
	MVI	C,1
	DAD	B
	POP	H
	POP	B
	RET

;ROUTINE TO PAD OUTPUT BUFFER WITH CONTENTS OF REG A.
;REG B CONTAINS NUMBER OF CHAR TO PAD.
PAD:	PUSH	B
	PUSH	D
	PUSH 	H
	LXI	H,OBUFF
	MOV	C,L
	MOV	L,M
	MOV	D,A
	MVI	A,73
P1:	CMP	L
	JNZ	P2
	MOV	L,C
	MOV	M,A
	CALL	WRIT
	INR	L
P2:	MOV	M,D
	INR	L
	DCR	B
	JNZ	P1
	MOV	A,D
	MOV	B,L
	MOV	L,C	;END OF PAGE 20
	MOV	M,B
	POP	H
	POP	D
	POP	B
	RET

;ROUTINE TO DUMP OUTPUT BUFFER TO TTY.
WRIT:	MVI	D,0
WRIT1:	PUSH	PSW
	PUSH	H
	PUSH	B
	LXI	H,OBUFF
	PUSH 	H
	MOV	C,M
	DCR	C
	JZ	W2
	INR	L
W1:	MOV	A,M
	RST	SEND	;PRINT VIA ODT
	INR	L
	DCR	C
	JNZ	W1
	DCR	D
	JZ	W2
	MVI	A,215O
	RST	SEND	;PRINT VIA ODT
	MVI	A,212O
	RST	SEND	;PRINT VIA ODT
W2:	POP	H
	MVI	M,1
	POP	B
	POP	H
	POP	PSW
	RET

;ROUTINE TO LOCATE COMMANDS, KEY WORDS, OPERATORS,
;AND FUNCTION. HL CONTAINS ADD OF FIRST CHAR.
;REG C CONTAINS LENGTH OF LINE: RETURNS SYMBOL NUMBER
;IF FOUND IN REG A, 377Q IN A IF NOT FOUND.
SYMSRT:	PUSH	D
	PUSH	B
	PUSH	H
	PUSH	H
	LXI	H,LEN	;SAVE C IN LEN
	MOV	M,C
	LXI	H,KDATA	;LOCATE TYPE OF SYMBOL SOUGHT.
	MVI	E,0	;REG A CONTAINS:
	ADD	L	;0 FOR COMMAND
	MOV	L,A	;1 FOR KEYWORD
	MOV	L,M	;2 FOR OPERATOR AND DELIMITER
S2:	MOV	C,M	;3 FOR FUNCTION
S3:	INR	L
	MOV	B,M
	XTHL
	MOV	A,M
	CMP	B
	JNZ	S4
	DCR	C
	JZ	S5
	PUSH	H
	LXI	H,LEN
	DCR	M
	POP	H
	JZ	S4A
	INX	H
	XTHL
	JMP	S3
S4A:	INR	C
S4:	POP	H
	MOV	A,C
	ADD	L
	MOV	D,H
	POP	H
	POP	B
	PUSH	B
	PUSH	H
	PUSH	H
	LXI	H,LEN
	MOV	M,C
	MOV	L,A
	MOV	H,D
	MOV	A,M
	INR	E
	MOV	C,A
	INR	A
	JNZ	S3
	LXI	H,LEN
	INR	M
	MVI	E,377O
S5:	MOV	A,E	;MOVE SYMBOL NUMBER INTO REG A
	LXI	H,LEN
	MOV	E,M
	DCR	E
	POP	H
	POP	H	;END OF PAGE 21
	POP	B
	MOV	C,E	;MOVE NUMBER OF CHAR. LEFT IN LINE INT
	POP	D
	RET

;***************************************************************
;THE CODE FROM HERE TO THE NEXT LINE OF *'S MUST BE ON ONE PAGE
;THIS MACRO ADDS PARITY BITS TO CHARACTERS
CHPAR	MACRO	CH
	.DB	CH | 200O
	ENDM
KDATA:	.DB	KDAT1 & 377O
	.DB	KDAT2 & 377O
	.DB	KDAT3 & 377O
	.DB	KDAT4 & 377O
KDAT1:	.DB	3,322O,325O,316O	;RUN
	.DB	6,320O,314O,323O	;PLS
	.DB	3,314O,311O 323O	;LIS
	.DB	3,323O,303O,322O	;SCR
	.DB	3,320O,324O,301O	;PTA
	.DB	377O
KDAT2:	.DB	3,314O,305O,324O	;LET
	.DB	3,320O,322O,311O	;PRI
	.DB	3,322O,305O,315O	;REM
	.DB	3,323O,324O,317O	;STO
	.DB	3,305O,316O,304O	;END
	.DB	3,307O,317O,324O	;GOT
	.DB	2,311O,306O	;IF
	.DB	3,311O,316O,320O	;INP
	.DB	3,304O,311O,315O	;DIM
	.DB	3,'C'+200O	;CAL
	.DB	'A'+200O
	.DB	'I'+200O
	.DB	4,'G'+200O	;GOSU
	.DB	'O'+200O
	.DB	'S'+200O
	.DB	'U'+200O
	.DB	3,'R'+200O	;RET
	.DB	'E'+200O
	.DB	'T'+200O
	.DB	3,'F' | 200O	;FOR
	.DB	'O' | 200O
	.DB	'R' | 200O
	.DB	4, 'N' | 200O	;NEXT
	.DB	'E' | 200O
	.DB	'X' | 200O
	.DB	'T' | 200O
	.DB	377O

;DELIMITERS HAVE FOLLOWING VALUES:
;  0  1  2  3  4  5  6     7     8     9  10  11  12
;  <  >  ,  =  )  ;  THEN  STOP  STEP  *  /   +   - 
KDAT3:	.DB	1,274O,1,276O	; <  >
	.DB	1,254O,1,275O	; ,  =
	.DB	1,251O	; )
	.DB	1,';'+200O	; ';'
	.DB	4
	CHPAR	'''T'''
	.DB	'T' | 200O
	CHPAR	'''H'''
	.DB	'H' | 200O
	CHPAR	'''E'''
	.DB	'E' | 200O
	CHPAR	'''N'''
	.DB	'N' | 200O	
	.DB	2	;TO
	CHPAR 	'''T'''
	.DB	'T' | 200O
	CHPAR	 '''O'''
	.DB	'O' | 200O
	.DB	4	;STEP
	CHPAR 	'''S'''
	.DB	'S' | 200O
	CHPAR	'''T'''
	.DB	'T' | 200O
	CHPAR	'''E'''
	.DB	'E' | 200O
	CHPAR	'''P'''
	.DB	'P' | 200O
	.DB	1,'*'+200O	;'*'
	.DB 	1,257O,1,253O	;'/', '+'
	.DB	1,255O		;'-'
				; END OF PAGE 22
			
	.DB 	377O
KDAT4:	.DB	3,307O,305O,324O	;GET
	.DB	3,320O,325O,324O	;PUT
	.DB	377O

;********************************************************
;ROUTINE TO INPUT SOURCE LINE FROM TTY. PASSED ADD
;OF FIRST CHAR IN HL. RETURNS LENGTH OF LINE IN REG A
TTYIN:	PUSH	H
	MVI 	B,0
TIN1:	CALL 	CHAR2
	CPI	231O	;CNTRL Y?
	JZ	TIN5
	CPI	377O
	JZ	TIN2
	CPI	337O	;BACK	(RUBOUT)?
	JZ	TIN2+3
	CPI	212O	;LF?
	JZ	TIN1
	CPI	215O	;CR
	JZ	TIN4
	CPI	214O	;FORM FEED?
	JZ	TIN1	;IGNORE
	MOV	M,A
	INX	H
	INR	B
	CALL	MEMFUL
	JMP	TIN1
TIN2:	MVI	A,337O
	RST	SEND	;PRINT VIA ODT
	DCX	H
	DCR	B
	JP	TIN1
	POP	H
	XRA	A	;ZERO A
	RET
TIN5:	MVI	A,334O
	RST	SEND	;PRTNT VIA ODT
TIN5A:	MVI	A,0
	POP	H
	RET
TIN4:	MVI	A,212O
	RST	SEND	;PRINT VIA ODT
TIN4A:	MVI	C,0
	POP	H
	MOV	A,B
	CMP	C
	RZ

;ROUTINE TO REMOVE BLANKS FROM SOURCE UNLESS ENCLOSED IN I'S
	PUSH	D	;SAVE REG'S
	PUSH	H
	PUSH 	H
	MVI	E,'"'+200O	;INIT E FOR COMPARES
	MVI	D,0	;D=I=>WITHIN QUOTES, LEAVE BLANKS
PK1:	XRA	A	;CLEAR A
	CMP	D	;CHECK INPUT
	MOV	A,M	;GET CHAR
	JNZ	QSTRG	;WITHIN QUOTE STRING
	CMP	E	;IS IT 1ST !?
	JNZ	$+7	;NO - PROCEED
	INR	D	;YES	SET FLAG
	JMP	QSTR1	;CONTINUE
	CPI	240O	;IS IT A SPACE?
	JZ	PK2	;LEAVE OUT
QSTRG:	CMP	E	;2ND "?
	JNZ	$+4	;NO - CONTINUE
	DCR	D	;RESET FLAG
QSTR1:	XTHL		;GET DESTINATION ADDRESS
	MOV	M,A	;SAVE
	INX	H	;BUMP PNTR.
	XTHL		;GET SOURCE ADD.
	INR	C	;BUMP CHAR. CNT
PK2:	INX	H	;BUMP PNTR.
	DCR	B	;DCR INPUT LINE CHAF CNT
	JNZ	PK1	;MORE - DO AGAIN
	MOV	A,C	;CHAR CNT TO A
	POP	H	;RESTORE REG'S, RETURN
	POP	H
	POP	D
	RET

;ROUTINES TO PAD MESSAGES TO OUTPUT BUFFER.
;FOR12 PADS 'UNDERFLOW'
;FOR11 PADS 'OVERFLOW'
;FOR10 PADS 'ZERODIVIDE'
;FORM9 PADS 'INPUT ERROR, TRY AGAIN'
;FORM8 PADS 'MEMORY FULL'
;FORM7 PADS 'WHAT?'
;FORM4 PADS 'IN LINE'
;FORM3 PADS 'ERROR'
;FORM2 PADS 'TURN ON PUNCH'
;FORM1 PADS 'READY'
;FORM5 PADS SOURCE LINE, PASSED ADDRESS OF
;LENGTH OF LINE IN HL REGS.
;FORM6 PADS CHAR STRING, PASSED ADD OF FIRST CHAR IN
;HL, LENGTH OF STRING IN REG C	;END OF PAGE 23

FOR12:	INR	L
FOR11:	INR	L
FOR10:	INR	L
FORM9:	INR	L
FORM8:	INR	L
FORM7:	INR	L
FORM4:	INR	L
FORM3:	INR	L
FORM2:	INR	L
FORM1:	MOV	L,M
FORM5:	MOV	C,M
	MOV	A,C
	CPI	0
	RZ
F1:	INX	H
FORM6:	MOV	A,M
	MVI	B,1
	CALL	PAD
	DCR	C
	JNZ	F1
	RET

;**************************************************************
;THE CODE FROM HERE TO THE NEXT LINE OF *'S MUST BE ON ONE PAGE
ODATA:	.DB	ODAT1 & 377O
	.DB	ODAT2 & 377O
	.DB	ODAT3 & 377O
	.DB	ODAT4 & 377O
	.DB	ODAT5 & 377O
	.DB	ODAT6 & 377O
	.DB	ODAT7 & 377O
	.DB	ODAT8 & 377O
	.DB	ODAT9 & 377O
	.DB	ODA10 & 377O

ODAT1:	.DB	5,"READY"
ODAT2:	.DB	13,"TURN ON PUNCH"
ODAT3:	.DB	8,215O,212O,"ERROR"
ODAT4:	.DB	9," IN-LINE "
ODAT5:	.DB	5,"WHAT?"
ODAT6:	.DB	14,"MEMORY FULL",215O,212O,"?"
ODAT7:	.DB	22,"INPUT ERROR, TRY AGAIN"
ODAT8:	.DB	10,"INDEFINITE"
ODAT9:	.DB	8,"OVERFLOW"
ODA10:	.DB	9,"UNDERFLOW"

;***************************************************
;ROUTINE TO INPUT SOURCE LINE FROM HSR. PASSED ADD
;OF FIRST CHAR IN HL. RETURNS LENGTH OF LINE IN REG A
HSRIN:	PUSH	H
	MVI	B,0
	JMP 	PIN1A
PIN1:	CALL 	CHAR5
PIN1A:	CPI	231O	;CNTRL Y?
	JZ	TIN5A
	CPI	377O
	JZ	PIN3
	CPI	337O
	JZ	PIN3
	CPI	212O
	JZ	TIN4A
	CPI	215O
	JZ	PIN1
	MOV	M,A
	INX	H
	INR	B
	CALL	MEMFUL
	JMP	PIN1
PIN3:	DCX	H
	DCR	B
	JP	PIN1
	POP	H
	XRA	A	;ZERO A
	RET		; END OF PAGE 24
	
;ROUTINE TO INPUT CHAR FROM HSR
CHAR5:	PUSH	B
	MVI	B,4
	OUT	5
	CALL	MCHK
	IN	5
	POP	B
	RET

;ROUTINE TO INSURE SOURCE DOES NOT OVERFLOW MEM SPACE
;COMPARES CURENT MEM ADDRESS TO SP.
MEMFUL:	PUSH	B
	PUSH	D
	PUSH	H
	MVI	A,50
	ADD	L
	MOV	B,A
	MVI	A,0
	ADC	H
	MOV	C,A
	LXI	H,0
	DAD	SP
	MOV	D,L
	MOV	E,H
	CALL	DCOMP
	POP	H
	POP	D
	POP	B
	RNC
	LXI	H,ODATA
	CALL	FORM8
	CALL	WRIT
	CALL	CHAR2
	CALL	PAD
	CALL 	WRIT
	SBI	260O
	CPI	4
	CZ	WHAT
	LXI	SP,MEMEND
	MVI	C,1
	JMP	M4A

; ROUTINE TO EVALUATE BOUNDS FOR LIST AND PLIST
; COMMANDS. RETURNS PLINE AS FIRST LINE, KLINE
; AS LAST LINE TO BE LISTED.
BOUND:	LHLD	NLINE
	MVI	A,9
	ADD	L
	MOV	L,A
	MVI	A,0
	ADC	H
	MOV	H,A
	PUSH	H
	CALL	NUMB
	CNC	WHAT
	CALL	CVB
	PUSH	PSW
	PUSH	B
	CALL	BND2
	POP	B
	DCX	H
	SHLD 	PLINE
BND1:	POP	PSW
	POP	H
	INR	A
	ADD	L
	MOV	L,A
	MVI	A,0
	ADC	H
	MOV	H,A
	MVI	A,0
	CMP	C
	RZ
	DCR	C
	CALL	NUMB
	CNC	WHAT
	PUSH	D
	CALL	CVB
	PUSH	D
	PUSH 	B
	CALL	BND2
	POP	B
	INX	H
	MOV	D,M
	INX	H
	MOV	E,M
	XCHG
	SHLD 	KLINE
	POP	D
	POP	H
	MOV	A,C
	CPI	0
	JNZ	WHAT
	MOV	B,H
	MOV	C,L	; END OF PAGE 25
	CALL	DCOMP
	RNC
	JMP	WHAT
BND2:	LHLD	STLINE
BND3:	MOV	B,M
	INX	H
	MOV	C,M
	CALL	DCOMP
	RC
	RZ
	PUSH 	H
	INX	H
	MOV	A,M
	INX	H
	MOV	H,M
	MOV	L,A
	CALL	CHK1
	POP	B
	JNC	BND3
	PUSH	B
	POP	H
	RET

;ROUIINE TO OUTPUT ERROR MSG. TO USER.
;REG A CONTAINS BCD ERROR NUMBER, HL
;LOADED WITH VALUE OF KLINE.
ERROR:	LXI	H,M1A	;RETURN ADDRESS
	PUSH	H	;PUT ON STACK
	LXI	H,ODATA	;OUTPUT BUFFER DATA TABLES
	PUSH	H
	MOV	D,A	;SAVE ERROR NUMB. IN D
	CALL	FORM3	;PAD 'ERROR '
	MVI	B,1	;INIT FOR PADS
	MOV	C,B	;INIT AS CNTR.
	MOV	A,D	;GET ERROR NUMB.
	RLC		;ROTATE HIGH 4 BITS TO LOW 4
	RLC
	RLC
	RLC
ERRR1:	ANI	17O	;MASK	
	ADI	260O	;CONVERT TO ASCII
	CALL	PAD	;PAD IT
	MOV	A,D	;GET ERROR NUMB
	DCR	C	;ANOTHER PASS?
	JP	ERRR1	;YES
	POP	H	;NO-CONTINUE
ERLN:	CALL	FORM4
	LHLD 	KLINE
	INX	H
	INX	H
	INX	H
	INX	H
	MOV	C,M
	INX	H
	CALL	LENGTH
	MOV	C,A
	CALL	FORM6
	CALL	WRIT
	RET

;THIS ROUTINE INCREMENTS H AND L AND
;DECR. C(CHARS IN LINE) SHOULD C RESULT
;IN 0 THEN THE ERROR CORRES. TO ENTRY PNT.
;IS GIVEN
ICP7:	MVI	A,7
	JMP	INCPT
ICP8:	MVI	A,8
	JMP	INCPT
ICP4:	MVI	A,4
	JMP	INCPT
ICP2:	MVI	A,2
INCPT:
	INX	M
	DCR	C
	RNZ
	JMP 	ERROR

;FSYM FINDS SYMBOLS IN TABLE
;B C CONTAIN SYMBOL
;RET WITH B,C,D,E SAME
;H AND L PNT TO VALUE (1ST BYTE)
;CY=1  =@ FOUND
;CY=0  AND A SCALAR VAR. =@ INSERTED
;   AND SET TO 0
;CY=0  AND AN ARRAY  =@ NO ACTION,
;   H AND L PNT TO LAST ENTRY IN SYMBOL TABLE
FSYM:	PUSH 	D
	XRA	A
	ORA	B	;SET CARRY IF NOT
	JZ	AR	;AN ARRAY AND SAVE
	CMC
AR:	PUSH	PSW
	LHLD	NXTSP	;GET NEXT AVAILABLE
	PUSH	B	;SPACE PNTR.
	MOV	B,H
	MOV	C,L	;CHECK TO SEE
	LHLD	STSPAC	;IF SYMBOL TABLE
			;EMPTY
			; END OF PAGE 26
	MOV	D,H
	MOV	E,L
	CALL	DCOMP	;DOUBLE BYTE COMPARE
	POP	B	;GET VAR. BACK
	JZ	NOSYM
LUKON:	CALL	CHK1	;CHECK FOR END
	JC	NOENT
	MOV	D,H	;SAVE OLD PNTR
	MOV	E,L
	MOV	A,B
	CMP	M	;DO VARIABLES MATCH
	JNZ	NOMAT
	INX	H
	MOV	A,C
	CMP	M
	JZ	ENTRY
	DCX	H
NOMAT:	INX	H	;NO MATCH GET NEW PNT.
	INX	H
	MOV	A,M
	INX	H
	MOV	H,M
	MOV	L,A
	JMP	LUKON
;ARRIVE HERE IF SYMBOL TABLE IS EMPTY
NOSYM:	DCX	D	; =STSPAC-2 SO STPNT WORKS RIGHT
	DCX	D

;ARRIVE HERE WHEN NO ENTRY FOUND
NOENT:	LHLD	NXTSP	;ADD. OF FREE MEMORY
	XCHG		;TO DE, HL HAVE LAST SYM.TAB. ENTRY
	POP	PSW	;ARRAY?
	JNC	FBAC	;YES, RETURN
	CALL	CHKLC	;CHECK FOR PAGE BOUNDARY CROSSING
	CALL	STPNT	;UPDATE PNTR
	XCHG		;NXTSP TO HL
	MOV	M,B	;STORE VAR.
	INX	H
	MOV	M,C
	INX	H
	PUSH	H
	INX	H	;STORE NXTSP+8 IN NXTSP
	INX	H
	INX	H
	INX	H
	INX	H
	INX	H
	SHLD	NXTSP
	CALL	MEMFUL	;MEMORY FULL?
	POP	H	;SET FWD PNT. TO -1
	MVI	M,377O
	INX	H
	MVI	M,377O
	INX	H	;INIT TO FLT. PNT. 0
	CALL	ZROL
	ORA	A	;CLEAR CY
	JMP	FBAC	;RESET CARRY AND RETURN
ENTRY:	POP	PSW	;VAR FOUND
	INX	H	;MOVE PNT. TO FIRST BYTE
	INX	H	;OF FLT. PNT. NO.
	INX	H
	STC		;SET CY AND RET.
FBAC:	POP	D	;RESTORE D 
	RET

;
;
; RUN - THE INTERPRETER
;
;
;INIT NXTSP
RUN:	LHLD	STSPAC
	XCHG
	CALL	CKDIM	;ADJUST START OF SYMBOL TABLE SO
			;IT STARTS ON AN EVEN 4 WORD BOUNDARY
	CALL	CHKLC	;ADJUST START OF SYMBOL TABLE SO IT
	XCHG		;DOES NOT CROSS PAGE BOUNDARY
	SHLD	STSPAC
	SHLD	NXTSP
	LXI	H,BOTNS	;INIT SP FOR NESTING STACK
	SHLD	NEST
	LXI	H,M1A	;PRECAUTION, IN CASE RETURN IS
	PUSH	H	;EXECUTED BEFORE A GOSUB
	PUSH	H
	LHLD	STLINE	;START OF SOURCE
ILOOP:	CALL	QUITT	;CHECK FOR INTERRUPTION
	CALL	CHK1	;HL=-1 =@ NO MORE SOURCE
	JNC	SORCE
	MVI	A,1
	JMP	ERROR	;ERROR 1, NO END STMT.
SORCE:	SHLD	LPNT
	PUSH	H
	LXI	H,LPNT	;DEFINE VALUES OF
	CALL	PTVAL	;KBIN,KFPNT,KLEN
	LDA	KLEN	;CHAR'S IN LINE TO C
			; END OF PAGE 27
	MOV	C,A
	INR	C
	POP	H	;MOVE PNTR. TO 1ST CHAR
	INX	H	;IN SOURCE REC.
	INX	H
	INX	H
	INX	H
L1:	CALL	ICP2	;INCR. H L DCR C
	CALL	ALPHA	;FIND FAST LETTER
	JNC	L1
	XRA	A
	INR	A	;LETTER FOUND
	CALL	SYMSRT	;DETERMINE KEYWORD
	CPI	377O
	JNZ	GKEY
	MVI	A,2	;BAD KEYWORD
	JMP	ERROR
GKEY:	SHLD	CPNT
	LXI	H,JTBL	;LOAD JUMP TABLE PNTR.
	ADD	A	;DOUBLE A
	MOV	E,A
	MVI	D,0
	DAD	D	;PNT. TO PROPER PROC.
	MOV	A,M	;ADD. IN JUMP TABLE
	INX	H	;GET PROC. ADD.
	MOV	H,M
	MOV	L,A
	PCHL		;INDIRECT JUMP TO PROC.
JTBL:	.DW	LET	;JMP TABLE
	.DW	PRI
	.DW	IEND	;REM STMT. - NO ACTION
	.DW	M1A	;STOP STMT.-RETURN TO EDIT MODE
	.DW	ENDD
	.DW	GOTO
	.DW	IFRT
	.DW	INPUT
	.DW	DIM
	.DW	CALLP
	.DW	GOSUB
	.DW	RETRN
	.DW	FOR
	.DW	NEXT
ENDD:	LHLD	KFPNT	;CHECK TO SEE IF MORE
	CALL	CHK1	;SOURCE AFTER END
	JC	M1A
	MVI	A,3	;MORE SOURCE ERROR 3
	JMP	ERROR
GOTO:	LHLD	CPNT	;GOTO STMT. PROC,
GSENT:	INX	H	;INCREMENT PAST KEYWORD
	INX	H
	INX	H
	CALL	ICP4	;POSSIBLE ERROR 4
GTRA:	CALL	CVB	;GET DESTINATION
	ORA	A	;MAKE SURE IT WAS OK
	JNZ	OKN
	MVI	A,4
	JMP	ERROR
OKN:	CALL	NSRCH	;GET NEXT LPNT
	JNC	ILOOP	;MAKE SURE IT EXISTED
	MVI	A,5
	JMP	ERROR	;NON-EXISTENT
DIM:	LHLD	CPNT	;DIM STMT. PROC.
	INX	H	;PNT TO FIRST VAR.
	INX	H
	INX	H
DLOOP:	CALL	ALPHA	;CHECK IF IT IS A VAR.
	JC	OKLET
ER6:	MVI	A,6	;ERROR 6
	JMP	ERROR
OKLET:	MOV	B,M
	CALL	ICP7	;INCR.CPNT
	MVI	A,250O	;CHECK FOR (
	CMP	M
	JNZ	ER6
	CALL	ICP7	;INCR. CPNT
	CALL	CVB	;CCNV. TO BIN NO.
	ADD	L	;UPDATE CPNT
	MOV	L,A	;ED CONTAIN ARRAY LEN.
	MVI	A,0
	ADC	H	;C CONT. NO. CHARS LEFT
	MOV	H,A	;IN LINE
	MVI	A,251O	;CHECK FOR
	CMP	M
	JNZ	ER6
	PUSH	H
	PUSH	B	;SAVE B,C,H,L
	MOV	C,B	;SET UP OR CALL TO FSYM
	MVI	B,0
	CALL	FSYM
	JNC	NDOU
	POP	B
	POP 	H
	MVI	A,11H	;ERROR 11
			; END OF PAGE 28
	JMP	ERROR
NDOU:	PUSH	D	; (COMMENTS MISSING)
	XCHG 
	LHLD	NXTSP 
	XCHG
	CALL	CKDIM
	CALL	STPNT
	XCHG
	POP	D
	MVI	M,0
	INX	H
	MOV	M,C
	INX	H
	MVI	M,377O	;FPNT TO -1
	INX	H
	MVI	M,377O
	INX	H
	MOV	A,D
	CMA
	MOV	C,A
	MOV	A,E
	CMA
	MOV	B,A
CONT:	CALL	ZROL	;ZERO OUT ELEMENTS
	INX	H	;OF ARRAY
	INX	H
	INX	H
	INX	H
	INX	B
	PUSH	H
	CALL	MEMFUL	;MEMORY FULL?
	MOV	H,B
	MOV	L,C
	CALL	CHK1
	POP	H
	JNC	CONT
	SHLD	NXTSP	;NEW VAL
	POP	B	;RESTORE
	POP	H
	INX	H
	DCR	C
	JZ	IEND
	DCR	C
	JZ	ER6
	MVI	A,254O	;NEXT ELEMENT A
	CMP	M
	INX	H
	JZ	DLOOP
	JMP	ER6

;ROUTINE TO COPY CONTENTS PNTED TO
;BY DE TO LOCATION H,L
COPDH:	PUSH	PSW	;SAVE REGISTERS
	PUSH	B
	PUSH	D
	PUSH	H
	MVI	B,4	;COUNT
COPD1:	LDAX	D	;GET FROM SOURCE
	MOV	M,A	;PUT TO DESTINATION
	INX	D	;BUMP PNTRS, CNT
	INX	H
	DCR	B
	JNZ	COPD1
	POP	H	;RESTORE REGIS
	POP	D
	POP	B
	POP	PSW
	RET

;OUTR PADS OUTPUT FROM CONV INTO
;OUTPUT BUFFER USING ROUTINE PAD
;ALL REG'S MAINTAINED
OUTR:	PUSH	B	;SAVE REG B
	MVI	B,1	;PAD ONCE
	CALL	PAD	;DO IT
	POP	B	;RESTORE B AND RET
	RET

;VALUE RETURNS IN D(H) E(L) PNTR.
;TO THE VALUE OF A TOKEN
;C,H,L ARE UPDATED
;A,B ARE DESTROYED
VALUE:	CALL	VAR	;IS ITA VARIABLE?
	RC		;YES	DONE
	MVI	A,3	;NO CALL A FUNC
	CALL	SYMSRT
	CPI	377O
	JZ	KONT	;NOT	A FUNCTION -
	CPI	1	;WAS	IT PUT(--)?
	JNZ	GET	;NO - OK
	JMP	ER10	;ILLEGAL USE OF FUNCTION
GET:	INX	H	;OK, IT'S GET(--)
	INX	H	;UPDATE H,L
	INX	H
	MOV	A,C	;CHECK FOR PREMANENT EOL
	ORA 	A	; END OF PAGE 29
	JZ	ER8
	MVI	A,250O	;CHEK FOR (
	CMP	M
	JNZ	ER8
	CALL	ICP8	;BUMP PNTR'S
	CALL	EVAL	;GET PORT =
	PUSH	H	;SAVE REG H,L
	LXI	H,FREG1
	CALL	COPDH	;COPY IT
	XCHG	
	POP	H	;RESTORE H,L
	CALL	FIX	;FIX IT
	INX	D
	INX	D	;GET LOWEST BYTE TO
	INX	D	;REG D
	LDAX	D
	MOV 	D,A
	MOV	A,C	;EOL?
	ORA	A
	JZ	ER8
	MVI	A,251O	;CHECK FOR )
	CMP	M
	JNZ	ER8
	INX	H	;BUMP PNTR'S
	DCR	C
	PUSH	H	;SAVE H,L,B,C
	PUSH	B	;STORE PROGRAM SEGMENT
	LXI	B,GREG	;IN RAM START AT GREG
	LXI	H,RINST	;ADD. OF INST'S
	MVI	E,5	;NUMB. OF BYTES
V1:	MOV	A,M	;GET BYTE
	STAX	B	;STORE IN RAM
	INX	H
	INX	B
	DCR	E	;BUMP PNTR'S,DCR CNT
	JNZ	V1
	LXI	H,GREG+1	;STORE PORT =
	MOV	M,D	;IN RAM
	JMP	GREG	;OK - TRANSFER
HOME:	LXI	H,GREG+2	;SET UP FOR FLOAT
	MOV	M,A	;STORE AWAY INPUT
	DCX	H
	XRA	A	;ZERO OUT HIGHER BYTES
	MOV	M,A	;BUT CHAR. DOESN'T MATTER
	DCX	H
	MOV	M,A
	CALL	DFXL	;FLOAT IT
	LXI	D,GREG	;FIX D,E RESTORE C,H,L
	POP	b
	POP	H
	RET
RINST:	IN	0	;RAM INSTRUCTIONS
	JMP	HOME
KONT:	CALL	NUMB	;NUMBER
	JC	OKK
	MVI	A,256O	;DEC; PNT.?
	CMP	M
	JNZ	ER8
OKK:	MVI	A,1	;MODE=1, IE INPUT FROM SOURCE
	CALL	RDKON	;READ CONSTANT TO GREG
	JC	ER9	;IF ERROR THEN CY=1
	LXI	D,GREG	;PNTS. TO CONSTANT
	RET

;THIS ROUTINE READS A CONSTANT INTO GREG FROM ASCII
;CHARCTERS POINTED TO BY HL AND C
;ENTER WITH A=0 => DATA FROM TTY
;ENTER WITH A=1 => DATA FROM SOURCE
;TURN WITH CY=1 => ERROR IN CONVERSION
RDKON:	STA	MODE	;SAVE MODE FOR ROUT. INP
	SHLD	HLINP	;SAVE HL FOR ROUT. INP
	MOV	A,C
	STA	CREG	;SAVE C FOR ROUT. INP
	LXI	H,GREG	;WHERE VALUE WILL GO
	MVI	C,SCR & 377O	;SET UP AND CALL FINPT
	CALL	FINPT
	LHLD	HLINP	;RESTORE H,L AND C
	LDA	CREG
	MOV	C,A
	RET		;DONE
ER9:	MVI	A,9
	JMP	ERROR

;VAR DECIDES WHETHER A TOKEN IS
;A VARIABLE IF SO CY=1 AND
;ADDRESS IS COMPUTED (SUBSCRIPT IS
;EVALUATED ETC.) RETURNS WITH DE PNTING
;TO VAR. REFERENCED H,L,C,UPDATED
;A,B DESTROYED
;IF NOT A VARIBLE CY=0
;H,L,C ARE LEFT UNTOUCHED
VAR:	CALL	ALPHA	;1ST CHAR A LETTER?
	RNC		;NO-NOT VAR.
	INX	H	;BUMP PNTR'S
	DCR 	C	; END OF PAGE 30
	JNZ	MORE	;MORE TO LINE
SC1:	PUSH	B	;SAVE B,EOL
	MVI	C,0	;SET FOR CALL TO FSYM
	DCX	H	;GET SINGLE LETTER
	MOV	B,M	;VAR TO B
	INX	H
	JMP	SCALR
MORE:	CALL	ALPHA	;2NO A LETTER?
	JNC	SFSG	;SO FAR SO GOOD
	PUSH	B	;SAVE C
	MVI	A,2	;CHECK FOR DELIMITER
	CALL 	SYMSRT
	POP	B	;RESTORE C
	INR	A	;FOUND?
	JNZ	SC1	;YES
BUPT:	INR	C	;NOT A VAR.
	DCX	H	;BACK UP PNTR'S
	ORA	A	;CY=0 AND RET
	RET

SFSG:	CALL	NUMB	;TEST FOR NUMBER
	JNC	ARCK	;MAYBE AN ARRAY
	INX	H	;ITS A SCALAR
	DCR	C	;BUMP PNTR'S
	JZ	SLOAD	;EOL
	PUSH	B	;SAVE C
	MVI	A,2	;SET UP FOR SYMSRT
	CALL	SYMSRT	;TEST FOR LEGAL
	POP	B	;GET C BACK
	INR	A	;DELIMITER FOUND?
	JZ	ER8	;NO, ERROR
SLOAD:	DCX	H	;MOVE BACK
	PUSH	B	;SAVE C
	MOV	C,M	;GET VAR. INTO
	DCX	H	;B,C FOR FSYM
	MOV	B,M
	INX	H
	INX	H
SCALR:	XCHG		;SAVE H,L IN D,E
	CALL	FSYM	;GET PNTR TO VALUE
	XCHG		;RESTORE H,L PNTR TO DE
	POP	B	;GET C REG BACK
	STC		;SET CY,RET
	RET

ARCK:	MOV	A,M	;ARRAY CHEK, GET CHARACTER
	CPI	250O	;IS IT (?
	JZ	ARYES	;YES,ITS AN ARRAY
	MVI	A,2	;NO-CHEK FOR LEGAL DELIM.
	PUSH	B	;SAVE C
	CALL	SYMSRT
	POP	B	;RESTORE C
	INR	A	;DELIMITER F
	JZ	ER8
	JMP	SC1	;1 CHAR. SCALAR VAR.
ARYES:	DCX	H	;YES-WE HAVE ARRAY
	MOV	A,M	;GET VAR.
	INX	H
	PUSH	PSW	;SAVE VAR.
	CALL	ICP8	;BUMP PNTR'S
	CALL	EVAL	;EVALUATE SUBSCRIPT
	PUSH	H	;SAVE REG H,L
	LXI	H,FREG1
	CALL	COPDH	;COPY IT
	XCHG
	POP	H	;RESTORE H,L
	CALL	FIX	;FIX VALUE
	MVI	A,251O	;CHECK FOR )
	CMP	M
	JNZ	ER8
	INX	H
	DCR	C	;BUMP PNTR'S
	INX 	D	;PNT TO LOWER 2 BYTES
	INX	D	
	LDAX	D
	MOV	B,A	;H-BYTE TO B
	INX	D	;PNT TO LOW BYTE
	LDAX	D	;LOW BYTE TO A
	ORA	A	;KILL CY
	RAL		;START MULT OF OFFSET
	MOV	E,A	;BY 4(BYTES/FLTPT =)
	MOV	A,B	;GET H BYTE
	RAL
	MOV	D,A	;DE IS OFFSET*2
	MOV	A,E	;GET LOW
	ORA	A	;KILL CARRY
	RAL
	MOV	E,A
	MOV	A,D
	RAL
	MOV	D,A
	POP	PSW	;DE CONTAIN OFFSET*4
	PUSH	B	;GET VAR., SAVE C
	MOV	C,A
	MVI	B,0	;SETUP TO CALL
			; END OF PAGE 31
	PUSH	H	;SAVE H,L
	CALL	FSYM	;GET START ADD.
	JC	AFOND
	MVI	A,12H	;ERROR 12
	JMP	ERROR	;ARRAY REF. NOT DIM'ED.
AFOND:	DAD	D	;H,L NOW PNT TO START OF
	XCHG		;ARRAY ADD OFFSET EXCHG
	POP	H	;RESTORE PNTR'S AND RET.
	POP	B
	STC		;SET CY
	RET

;ROUTINE TO FIX FLOATING POINT
;NUMBERS, ALL REG'S BUT A ARE
;MAINTAINED. DE PNT TO 4 BYTES
;OF = TO BE FIXED
FIX:	PUSH	B
	PUSH	H
	PUSH	D	;SAVE REG'S
	INX	D
	INX	D
	INX	D	;PNT TO 4TH BYTE
	LDAX	D
	PUSH	PSW	;SAVE CHAR. (FOR SIGN)
	ANI 	177O
	RAL		;CHEK IF EXP SIGN IS
	RAL
	JC	MINSE
	RAR
	RAR		;RESTORE CHAR
	CPI	30O	;IS IT TOO BIG?
	JC	GOOD
	MVI	A,13H	;ERROR 13
	JMP	ERROR	;FIX = TOO BIG
MINSE:	RAR
	RAR
GOOD:	STAX	D	;ABSOLUTE VALUE
	DCX	D
	DCX	D
	DCX	D	;MOV PNTR BACK
	LXI	H,FREG1
	CALL	COPDH	;COPY TO FREGI
	LXI	H,FREG2	;STORE .5*2**24 IN
	LXI	D,FDAT	;FREG2
	CALL	COPDH	;COPY IT
	LXI	H,FREG1	;SET UP TO CALL LADD
	MVI	B,FREG2 & 377O
	MVI	C,SCR & 377O
	CALL	LADD	;ADD THEM,RESULT IN FREG1
	LXI	H,FREG1
	POP	PSW	;GET SIGN AND ADD.
	POP	D
	RAL
	MVI	A,0	;GET SIGN ONLY
	RAR
	MOV	B,M	;GET BYTE1
	STAX	D	;STORE BYTE 1 OF FIX
	MOV	A,B
	ANI	177O	;CLEAR HIGH BIT (FROM ADD)
	INX	D
	INX	H
	MOV	B,M	;GET BYTE 2
	STAX	D	;STORE BYTE 2 OF FIX
	INX	D
	MOV	A,B
	INX	H
	MOV	B,M	;GET BYTE 3
	STAX	D	;STORE BYTE 3 OF FIX
	MOV	A,B
	INX	D
	STAX	D	;STORE BYTE 4 OF FIX
	DCX	D	;FIX D PNTR
	DCX	D
	DCX	D
	POP	H
	POP	B
	RET
FDAT:	.DB	200O,0,0,30O

;INP SAVES ALL REG'S
;SERVES AS BUFFER BETWEEN FINPT AND
;DATA INPUT. IF MODE=0 DATA COMES FROM TTY
;IF MODE=1 DATA COMES FROM SOURCE STMTS.
;IN ALL CASES HL,C ARE UPDATED FROM HLINP, AND
;CREG AND RETURNED TO THOSE LOCATIONS
INP:	PUSH	H	;SAVE ALL REG'S
	PUSH	D
	PUSH	B
	LHLD	HLINP	;GET PNTR'S
	LDA	CREG
	MOV	C,A
	ORA	A	;CHECK FOR EOL
	JNZ	CHKMD	;NO CHECK MODE
SPACE:	MVI	A,240O	;SEND A SPACE
IDONE:	POP	B	;RESTORE REG'S
			; END OF PAGE 32
	POP	D
	POP	H
	RET		;AND RETURN

CHKMD:	LDA	MODE	;GET MODE
	DCR	A	;CHECK IT
	JZ	MODE1	;MODE IS 1
	MOV	A,M	;MODE 0 GET ????
	CPI	',' | 200O	;IS IT A ','?
	JZ	SPACE	;YES - SEND A SPACE
	JMP	BMPTR	;NO - SEND IT
MODE1:	CALL	NUMB	;NUMBER? (ALSO LOADS IT TO A)
	JC	BMPTR	;YES - SEND IT AND BUMP PNTR'S
	CPI	256O	;DEC. PNT.?
	JZ	BMPTR
	CPI	305O	;E?
	JZ	BMPTR
	CPI	253O	;+?
	JZ	CHEKE
	CPI	255O	;-?
	JNZ	SPACE	;SEND A SPACE
CHEKE:	MOV	B,A	;CHEK IF E PRECEDES +,-
	DCX	H	;BACK UP AND GET PRE-
	MOV	A,M	;CEDING CHARACTER
	CPI	305O	;IS IT E?
	JNZ	SPACE	;NO, +OR- WAS DELIMITTER
	MOV	A,B	;YET GET + OR -
	INX	H	;RESTORE H L
BMPTR:	INX	H	;BUMP AND STORE PNTR'S
	DCR	C
	SHLD	HLINP
	LXI	H,CREG
	MOV	M,C
	JMP	IDONE	;REG'S AND RETURN

;THIS ROUTINE WILL EVALUATE UNARY AND/OR
;BINARY EXPRESIONS CALLED WITH H AND L
;POINTING TO FIRST CHAR. OF EXP. C CONTAINS
;NUMBER OF CHAR'S LEFT IN LINE. RETURNS
;D(H) AND E(L) POINTING TO THE ANSWER
;THIS ROUTINE CALLS ITSELF RECURSIVELY
;IN ORDER TO EVALUATE SUBSCRIPT
;EXPRESIONS. REG A,B DESTROYED
; H L ARE UPDATED
EVAL:	MVI	A,255O	;IS IT UNARY -
	CMP	M	;Z=1 => YES
	PUSH	PSW	;Z=1 => NO
	JNZ	ECAV
	CALL	ICP8	;BUMP POINTER
ECAV:	CALL	VALUE	;GET PNTR. TO VALUE
	PUSH	H	;GET VALUE TO FREG1
	LXI	H,FREG1
	CALL	COPDH
	XCHG
	POP	H
	POP	PSW	;GET SIGN
	JNZ	DOL	;SHALL WE NEGATE?
	INX	D	;YES, POINT TO CHAR.
	INX	D
	INX	D
	LDAX	D	;AND LOAD TO A
	RAL		;ROTATE SIGN TO CY
	CMC		;COMPLEMENT IT
	RAR		;ROTATE BACK
	STAX	D	;STORE AWAY
	DCX	D	;AND FIX PNTR.
	DCX	D
	DCX	D
DOL:	MOV	A,C	;IS THIS END OF LINE?
	ORA	A
	RZ		;YES-RETURN
	PUSH	B	;SAVE C
	MVI	A,2	;NO SET UP TO CALL
	CALL	SYMSRT	;SYMSRT AND CALL
	POP	B	;RESTORE C
	INR	A	;DELIMITER FOUND?
	JZ	ER8	;NO, ERROR
EOK:	SUI	10	;CHECK FOR EXPRESSION
	RC		;DELIMITER
	PUSH	PSW	;SAVE OPERATION
	CALL	ICP8	;BUMP PNTR'S
	ORA	A	;CLEAR CY
AGA:	PUSH	H	;GET BYTES OF NUMBER
	LDAX	D	;AND PLACE ON STACK
	MOV	L,A
	INX	D
	LDAX 	D
	INX	D
	MOV	H,A	;2 BYTES TO H,L
	XTHL		;XCHANGE, RESTORES H,L
	CMC
	JC	AGA	;ANOTHER PASS?
	CALL	VALUE	;GET 2ND VALUE
	MOV	A,C	;CHECK FOR END OF LINE
	ORA	A	;IF SO => WELL FORMED
			; END OF PAGE 33
	JZ	WFOR
	PUSH	B	;SAVE C
	MVI	A,2	;ELSE CALL SYMSRT TO
	CALL	SYMSRT	;CHEK FOR EXP. DEL.
	POP	B	;RECOVER IT
	CPI	10
	JC	WFOR	;YES WELL FORMED
ER8:	MVI	A,8	;ILL-FORMED EXP.
	JMP	ERROR
WFOR:	PUSH	B	;SAVE C, AND H,L
	PUSH	H
	LXI	H,FREG2	;COPY 2ND VALUE TO
	CALL	COPDH	;FREG2
	POP	D	;GET BYTES FROM STACK
	POP	B
	POP	H	;INTO FREG1+2
	SHLD	FREG1+2
	POP	H	;AND NEXT 2 BYTES
	SHLD	FREG1	;FROM STACK TO FREG1
	XCHG		;GET OPERATION
	POP	PSW
;THIS ROUTINE PERFORMS BINARY OFERATIONS ON OPERANDS IN FREG1 AND FREG2
;B,C,H,L ARE LEFT UNDISTURBED. A IS DESTROYED
;D,E PNT TO RESULT
;OPERATIONS ARE SPECIFIED BY A REGISTER AS FOLLOWS:
;	A=0	=>	FREG1	* FREG2
;	A=1	=>	FREG1 / FREG2
;	A=2	=>	FRE01 + FREG2
;	A=3	=>	FREG1 - FREG2
	
; IN CASE OF ARITHMETIC ERROR A MESSAGE IS SENT TO USER.
; IF A CONTAINS ILLEGAL OPERATION REQUEST ERROR IS SENT TO USER
; (ERROR 8) AND THE INTERPRETER IS ABORTED.
BINOP:	PUSH	B	;SAVE REG'S
	PUSH 	H
	LXI	H,FREG1	;SET UP PNTR'S TO
	MVI	B,FREG2 & 377O	;FREG'S AND SCR AREA
	MVI	C,SCR & 377O	;AND DO OPERATION
	DCR	A
	JM	FMULT	;0,1=>* OR /
	JZ	DIV	;2,3=>+ OR -
	DCR	A
	JZ	ADDD
	DCR	A
	JZ	SUBB
	JMP	ER8	;ILLEGAL OPER.
ADDD:	CALL	LADD	;DO ADDITION
ASBC:	MOV	D,H	;FIX PNTR'S FOR RET.
	MOV	E,L
FPERR:	ORA	A	;SET FLAGS
	JZ	NFPER	;NO ERROR
	PUSH	D	;SAVE DE
	PUSH	PSW	;SAVE A
	CALL	WRIT	;DUMP BUFFER
	POP	PSW	;GET A BACK
	LXI	H,WFPER	;RETURN ADDRESS
	PUSH	H	;SAVE ON STACK
	LXI	H,ODATA	;MESSAGE TABLE
	RAL		;UNDERFLOW?
	JC	FOR12	;YES
	RAL		;OVERFLOW?
	JC	FOR11	;YES
	JMP	FOR10	;NO - ITS ZERODIVIDE
WFPER:	LXI	H,ODATA	;MESSAGE TABLE
	CALL	ERLN	;PRINT 'IN LINE	(USE PART OF ERROR)
	POP	D	;RESTORE REG'S
NFPER:	POP	H
	POP	B
	RET
SUBB:	CALL	LSUB	;DO SUBTRACTION
	JMP	ASBC
FMULT:	CALL	LMUL	;DO MULT.
	JMP	MDBC
DIV:	CALL	LDIV	;DO DIV
MDBC:	MOV	D,H	;AND FIX PNTR'S FOR RET.
	MOV	E,C
	JMP	FPERR	;CHECK FOR ERROR

;PRINT PROCESSOR
PRI:	LHLD	CPNT
	INX	H	;INCR. PAST KEYWORD
	INX	H
	INX	H
	CALL 	ICP7
	INX	H	;BUMP PNTRS
	DCR	C
	MVI	B,0	;SET CHAR CNT
	JNZ	PLOOP	;CONTINUE IF MORE
	INR	B	;NOTHING MORE, PAD A MULL
	MVI	A,0
	CALL	PAD
	JMP	PEND	;WRITE IT AND CONTINUE
PLOOP:	MOV	A,M	;GET CHARACTER
	CPI	'"'+200O	;IS IT "?"
			; END OF PAGE 34
	JNZ	EXPRE	;NO
QUOTE:	CALL	ICP7	;GET CHARACTER TO A
	MOV	A,M
	CPI	'"'+200O	;IS IT "?
	JZ	QCHEK
QOTOK:	INR	B	;INCREMENT CNT
	MOV	D,B	;SAVE IN 0
	MVI	B,1	;PAD ONCE
	CALL 	PAD
	MOV	B,D	;RESTORE CNT
	JMP	QUOTE	;AGAIN
QCHEK:	INX	H	;BUMP PNTRS
	DCR	C
	JZ	PEND	;EOL
	MOV	A,M
	CPI	'"'+200O	;ANOTHER
	JZ	QOTOK
	JMP	SCOLN
EXPRE:	CALL	ALPHA	;IS IT A LETTER
	JC	PRTIT	;YES EVALUATE AND PRINT
	CALL	NUMB	;IS IT A NUMB?
	JC	PRTIT	;YES, EVALUATE AND PRINT
	MOV	A,M
	CPI	'.'+200O	;IS IT A DECIMAL PNT?
	JZ	PRTIT	;YES EVALUATE, PRINT
	CPI	'-'+200O	;IS IT A -?
	JNZ	SCOLN	;NO, CHECK FOR ;
PRTIT:	PUSH	B	;SAVE CNT
	CALL	EVAL	;EVALUATE EXPRESION
	PUSH	B	;SAVE C,H,L
	PUSH	H
	XCHG		;DE TO HL
	MVI	C,SCR & 377O	;SET UP, CONVERT
	CALL 	CONV
	POP	H	;RESTORE REG'S
	POP	B
	MOV	A,C
	POP	B
	MOV	C,A
	ORA	A	;CHECK EOL
	JZ	PEND
	MVI	A,11	;UPDATE CNTR
	ADD	B
	MOV	B,A
	MOV	A,M	;GET CHAR.
SCOLN:	CPI	$3B+200O	;IS IT semi-colon?
	JZ	SONWD
	CPI	','+200O	;IS IT ,?
	JNZ	ER6	;NO-UNEXPECTED CHAR.
	XRA	A	;ZERO A
ADFLO:	ADI	13	;ADD FIELD LENGTH
	CMP	B	;CDKPARE TO CNT
	JZ	$+6
	JNC	FLDFD
	CPI	52	;LAST FLD?
	JNZ	ADFLO
	CALL	WRIT	;YES-WRITE LINE
	MVI	B,0	;RESET CNT
ONWD:	INX	H	;BUM PNTRS
	DCR	C
	JZ	PEND
	JMP	PLOOP
FLDFD:	SUB	B	;FOUND FIELD
	MOV	D,B	;DETERMINE #OF SPACES TO PAD
	MOV	E,A	;SET UP TO CALL PAD
	MOV	B,A
	MVI	A,240O
	CALL	PAD	;PAD SPACES
	MOV	A,D
	ADD	E	;NEW CNT
	MOV	B,A	;SAVE IN B
SONWD:	INX	H	;CHECK EOL
	DCR	C
	JNZ	PLOOP
	MVI	D,1	;SUPPRESS CR/LF
	CALL	WRIT1
	JMP	$+6
PEND:	CALL	WRIT	;DUMP BUFFER, CONTINUE
	JMP 	IEND

;INPUT PROCESSOR - READS VALUES FROM TTY
;THEY MUST BE DELIMITED BY COMMAS ONLY
INPUT:	MOV	A,C	;IN CASE OF ERROR
	STA	PL6	;SAVE
INPER:	LHLD	CPNT	;INPUT LINE (V-STRING) PNTR
	INX	H	;ADJUST PNTR'S
	INX	H
	INX	H
	CALL	ICP7
	CALL	ICP7
PRMPT:	PUSH	B	;SAVE PNTR'S
	PUSH	H
	MVI	B,1	;SEND PROMPT
	MVI 	A,':'	; END OF PAGE 35
	MOV	D,B	;TO SUPPRESS CR/LF
	CALL	PAD	;PAD IT
	CALL	WRIT1	;WRITE IT
	LXI	H,IBUF	;ADD. OF INPUT BUFFER
	CALL	TTYIN	;READ A LINE
	XCHG		;ADD. OF K-STRING TO DE
	POP	H	;ADD. OF V-STRING
	POP	B	;V-STRING CNT TO C
	MOV	B,A	;K-STRING CNT TO B
	CALL	STRIN	;TRANSFER CONSTANT TO VARIBLES
	JZ	INPOK	;NO ERROR
	LXI	H,ODATA	;SEND ERROR MESSAGE
	CALL	FORM9
	CALL	WRIT
	LDA	PL6	;GET V-STRING CNT
	MOV	C,A
	JMP	INPER	;START AGAIN
INPOK:	JC	PRMPT	;NEED MORE CONSTANTS
IEND:	LHLD	KFPNT	;ALL OK - GET NEW PNTR.
	JMP	ILOOP	;CONTINUE

;THIS ROUTINE TRANSFERS THE FLOATING POINT VALUES
;OF AN ASCII STRING OF CONSTANTS TO THE LOCATIONS
;SPECIFIED BY AN ASCII STRING OF VARIBLES
;POINTER AND LINE CNT OF VAR. STRING ARE IN HL,C
;POINTER AND LINE CNT OF CONST. STRING ARE IN DE,B
;ON RETURN:
;	Z=0 AND CY=0	ALL OK
;	Z=0 AND CY=0	NEED MORE CONSTANTS
;	Z=1		ERROR IN CONVERSION
;ALL POINTERS AND LINE CNT'S ARE RETURNED UPDATED
STRIN:	MOV	A,C	;GET V-STRING CNT
	ORA	A	;TFJTVFOR EOL
	RZ		;DONE	CY=O => ALL OLK
	MOV	A,M	;GET 6HAR.
	CPI	',' | 200O	;IS IT A ,?
	JNZ	STOKV	;IT'S	NOT A ,
	INX	H	;COMMA, BUMP PNTR'S
	DCR	C
	JZ	ERRET	;POSSIBLE ERROR (IF EOL)
STOKV:	MOV	A,B	;GET K-STRING LENGTH
	ORA	A	;TEST FOR EOL
	STC		;IN CASE IT'S EOL
	RZ		;RETJ CY=I Z@ NEED MORE CONSTANTS
	LDAX	D	;GET CHAR
	CPI	',' | 200O	;TEST FOR ,
	JNZ	STOKK	;NOT A , - READY TO GO
	INX	D	;BUMP PATR'S
	DCR	B	;POSSIBLE ERROR (IF EOL)
	JZ 	ERRET
STOKK:	PUSH	B	;SAVE,K-STRING CNT
	PUSH	D	;SAVE K-STRING PNTR
	CALL	VAR	;ADD. TO VARIBLE TO DE
	XCHG		;VAR. ADD TO H,L
	SHLD	VARAD	;SAVE
	POP	H	;ADDRESS OF K-STRING
	MOV	A,C	;V-STRING CNT TO A
	POP	B	;K-STRING CNT TO B
	MOV	C,B	;K-STRING CNT TO C
	PUSH	PSW	;SAVE V-STRING CNT
	PUSH	D	;SAVE V-STRING ADD.
	MVI	A,0	;A=0 =@ DATA FROM TTY
	CALL	RDKON	;GET CONSTANT TO GREG
	JNC 	STNER
	POP	H	;EMPTY STACK
	POP	H
ERRET:	XRA	A	;ERROR
	INR	A
	RET
STNER:	PUSH	H	;SAVE K-STRING PNTR.
	LHLD	VARAD	;GET VAR. ADD
	LXI	D,GREG	;ADD. TO CONST.
	CALL	COPDH	;COPY IT TO VARIABLE LOC.
	POP	D	;K-STING PNTR. TO DE
	MOV	B,C	;K-STRING LENGTH TO B
	POP	H	;V-STRING PNTR. TO HL
	POP	PSW	;V-STRING LENGTH TO C
	MOV	C,A
	JMP	STRIN	;LOOP

;LET STMT. PROCESSOR
LET:	LHLD	CPNT	;GET PNTR.
	INX	H	;FIX PNTR.
	INX	H
	INX	H
	MOV	A,C	;CHECK FOR EOL
	ORA	A
	JNZ	LOK
ER7:	MVI	A,7
	JMP	ERROR
LOK:	CALL	VAR	;GET ADDRESS TO VAR.
	JC	SAVV	;IT'S A VARIABLE
	MVI	A,3	;NO-CHEK FOR FUNC.
	CALL	SYMSRT
	CPI	377O	; END OF PAGE 36
	JZ	ER8	;DON'T KNOW WHAT IT IS
	DCR	A
	JNZ	ER10	;ILLEGAL USE OF FUNC.
	INX	H	;IT'S PUT,UPDATE H,L
	INX	H
	INX	H
	MOV	A,C	;EOL CHK
	ORA	A
	JZ	ER8
	MOV	A,M	;CHEK FOR (
	CPI	250O
	JNZ	ER8
	CALL	ICP8	;BUMP PNTRS
	CALL	EVAL	;EVALUATE AND FIX
	PUSH	H	;SAVE H,L
	LXI	H,FREG1
	CALL	COPDH	;COPY IT
	XCHG
	POP	H
	CALL	FIX
	INX	D
	INX	D
	INX	D
	LDAX	D	;GET LOWEST BYTE
	PUSH	PSW	;PORT = IS SAVED
	MOV	A,M
	CPI	251O	;CHECK FOR
	JNZ	ER8
	CALL	ICP8	;BUMP PNTR'S
	MVI	D,377O
	MOV	E,D
SAVV:	PUSH	D	;KEEP ADDRESS
	MOV	A,M	;CHEK FOR
	CPI	275O
	JNZ	ER8
	CALL	ICP8	;BUMP PNTRS
	CALL	EVAL	;EVALUATE EXPRESSION
	POP	H	;GET ADDRESS
	CALL	CHK1
	JC	PTFIN	;IT WAS A PUT
	CALL	COPDH	;COPY TO ADDRESS
	JMP	IEND	;CONTINUE
PTFIN:	LXI	H,FREG1	;COPY VALUE TO FREG1
	CALL	COPDH
	XCHG
	CALL	FIX	;FIX THE VALUE
	INX	D
	INX	D
	INX	D
	LDAX 	D
	MOV	C,A	;SAVE IN C
	LXI	H,PINST	;ADD OF BYTES TO GO TO
	LXI	D,GREG	;RAM AT GREG
	MVI	B,5	;BYTE CNT
PRI1:	MOV	A,M	;STORE PROG. SEG. IN
	STAX	D	;RAM
	INX	H
	INX	D
	DCR	B
	JNZ	PRI1
	POP	PSW	;GET PORT
	LXI	H,GREG+1
	MOV	M,A	;STORE
	MOV	A,C	;GET DARA OUT TO A
	DCX	H	;TRANSFER
	PCHL
PINST:	OUT	0	;RAM INSTRUCTIONS
	JMP	IEND
ER10:	MVI	A,10H
	JMP	ERROR

;IF STMT. PROCESSOR
IFRT:	LHLD	CPNT	;GET PNTR., ADJUST
	INX	H
	INR	C	;CHECK EOL
	CALL	ICP7
	CALL	EVAL	;EVALUATE EXPRESSION
	MOV	A,C
	ORA	A	;CHECK EOL
	JZ	ER7
IAGA:	PUSH	H	;SAVE H,L, PUT VALUE ON 3SK
	LDAX	D
	INX	D
	MOV	L,A
	LDAX 	D
	INX	D
	MOV	H,A
	XTHL		;RESTORE H,L
	CMC
	JC	IAGA	;ANOTHER PASS?
	MVI	A,2
	CALL	SYMSRT	;CHEK TYPE OF RELATION
	CPI	4	;WAS IT LEGAL?
	JC	II1	; END OF PAGE 37
ER14:	MVI	A,14H
	JMP	ERROR
II1:	CPI	2	;WAS IT A ,?
	JZ	ER14
	INR	A	;ALL OK, INC,SAVE
	PUSH	PSW
	INR	C
	CALL	ICP7	;BUMP PNTRS
	MVI	A,2	;CALL SYMSRT
	CALL 	SYMSRT
	CPI	377O	;FOUND ANYTHING?
	JZ	RELAT	;DONE
	CPI	2
	JZ	ER14	;IT WAS A ,
	CPI	4
	JNC	ER14	;NOT LEGAL
	INR	A
	MOV	B,A
	INR	C
	CALL	ICP7
	POP	PSW	;GET SECOND RELATION
	ADD	B	;ADD THEM
	PUSH	PSW	;AND SAVE
	CPI	10O	;TEST FOR ==
	JZ 	ER14

;RELATION IS STORED ON TOP OF STACK (PUSH PSW) ACCORDING TO
;THE FOLLOWING
;
;	1 =>	<
;	2 =>	>
;	3 =>	<>
;	4 =>	=
;	5 =>	<=
;	6 =>	>=
;
RELAT:	CALL	EVAL	;EVALUATE
	PUSH	H	;SAVE H,L
	LXI	H,FREG2	;COPY A FREG2
	CALL	COPDH
	POP	H	;GET H,L
	POP	PSW	;AND REATION
	XTHL		;GET 2ND 2 BYTES
	SHLD	FREG1+2	;STORE
	POP	H	;GET 1ST 2 BYTES,STORE
	XTHL
	SHLD	FREG1
	PUSH	B
	PUSH	PSW	;SAVE A,B,C
	CALL	FCOMP	;COMPART NUMBERS
	MOV	D,A	;SAVE RESULT IN D
	POP	PSW	;GET RELATION,B,C
	POP	B
	CMP	D	;SAME?
	JZ	TRUE	;YES
	SUI	4
	JP	NOT3	;NOT RELATION 3?
	INR	A	;IS IT RELATION 3?
	JNZ	FALSE	;NO, ITS FALSE
	MVI	A,4	;IT IS. CHECK FOR INEQUALITY
	CMP	D
	JNZ	TRUE
	JMP	FALSE
NOT3:	CMP	D	;RELATION 5,6 TRUE?
	JZ	TRUE	;YES
	MVI	A,4	;IT WAS, CHECK FOR EQUALITY
	CMP	D
	JZ	TRUE
FALSE:	POP	H	;CONTINUE
	JMP	IEND
TRUE:	POP	H
	MVI	B,4
THEN:	CALL	ICP7	;INCREMENT PAST THEN
	DCR	B
	JNZ	THEN
	JMP	GTRA	;TRANSFER TO GOTO

;ROUTINE FCOMP COMPARES 2 FLOATING POINT #'S. THEY ARE ASSUMED
;TO BE IN FREG1 AND FREG2.
;ALL REGISTERS ARE DESTROYED.
;THE VALUE RETURNED IN REG A IS RESULT OF COMPARISON.
;RESULTS ARE AS FOLLOWS:
;	A=1	=>	FREG1 < FREG2
;	A=2	=>	FREG1 > FREG2
;	A=4	=>	FREG1 = FREG2
FCOMP:	LXI	H,FREG1+3	;PNTS TO CHAR OF 1SR
	LXI	D,FREG2+3	;PNTS TO CHAR OF 2ND
	MOV	A,M	;GET 1 CHAR
	MVI	B,200O	;MASK TO B
	ANA	B	;GET SIGN, 1
	MOV	C,A	;SAVE IN C
	LDAX	D	;GET CHAR 2
	ANA	B	;GET SIGN 2
			; END OF PAGE 38
	XRA	C
	JZ	SINEQ	;SAME SIGNS
	MOV	A,C	;OPPISITE SIGNS,GET 1 SIGN
	RAL		;ROTATE TO CY
	MVI	A,1
	RC		;FREG1 < FREG2 => A=1
	INR	A	;ELSE FREG1 > FREG2
	RET		;AND A=2
SINEQ:	PUSH	B	;SAVE SIGN
	DCX	H	;PNTR TO 1 IN H,L
	DCX	H
	DCX	H
	MOV	B,E	;PNTR TO 2 IN B
	DCR	B
	DCR	B
	DCR	B
	CALL	LMCM	;COMPARE ????
;AT THIS POINT Z=1 => =, CY=1 => 1<2
	POP	B	;GET SIGN
	JNZ	$+6
	MVI	A,1	;EQUAL =>, A=4
	RET
	MOV	A,C	;GET SIGN TO A
	INR	A	;SET SIGN BIT
	MVI	A,1
	JM	$+6	;SIGN IS NEGATIVE
	RC		;SIGN=+ AND ABS(FREGL)<ABS(FREG2)
	INR	A	;ABS(FREG1)>ABS(FREG2)
	RET
	RNC		;SIGN=- AND ABS(FREG1)>ABS(FREG2)
	INR	A	;ABS(FREG1)<ABS(FREG2)
	RET

;CALL PROCESSOR
CALLF:	LXI	H,IEND	;INIT RE 	ADDRESS
	PUSH	H
	LHLD	CPNT
	INX	H
	INX	H
	INX	H
	CALL	ICP7
	MOV	A,M	;GET CHAR
	CPI	'('+200O	;IS IT A (?
	JNZ	ER7	;BAD
	CALL	ICP7	;BUMP PNTRS
	CALL	CVB	;GET SUB
	ADD	L	;UPDATA H,L
	MOV	L,A
	MVI	A,0
	ADC	H
	MOV	H,A	;D NOW CONTAINS SUB
	PUSH	H	;SAVE HL
	LXI	H,SUBS	;GET START OF SUB TABLE
NUSUB:	MOV	A,M	;GET ENTRY
	CMP	D	;COMPARE
	JZ	FNDSB	;FOUND IT
	INX	H	;PNT TO NEXT
	INX	H
	INX	H
	INR	A	;CHECK TO SEE IF LAST WAS 377Q
	JNZ	NUSUB
	MVI	A,15H	;ER 15 - NO SUB BY THIS A *
	JMP	ERROR
FNDSB:	INX	H
	MOV	E,M
	INX	H
	MOV	H,M
	MOV	L,E	;AND SAVE IT
	SHLD	SBSAV
	LHLD	NXTSP	;INIT MEMORY SCRATCH AREA
	SHLD	MESCR
	POP	H	;GET SOURCE PNTR
PARLP:	MOV	A,M	;GET CHAR
	CPI	')'+200O	;IS IT )?
	JZ	CLSUB	;YES - DO CALL SUN
	CPI	','+200O	;DO WE HAVE A ','
	JNZ	ER6	;UEXPECTED CHARACTER
	CALL	ICP7	;BUMP PNTRS
	CALL	VAR	;DO WE HAVE A VARIABLE
	JNC	PREXP	;NO
	PUSH	D	;YES - SAVE ADDRESS
	JMP	PARLP	;CONTINUE
PREXP:	CALL	EVAL	;EVALUATE EXPRESSION
	PUSH	H	;SAVE H,L
	LHLD	MESCR	;GET SCRATCH AREA
	CALL	COPDH	;AND COPY TO IT
	POP	D	;HL TO DE
	PUSH	H	;SAVE ADDRESS
	INX	H	;UPDATE MESCR
	INX	H
	INX	H
	INX 	H
	SHLD	MESCR	;SAVE IT
	XCHG		;GET H,L BACK
			; END OF PAGE 39
	JMP	PARLP	;CONTINUE
CLSUB:	LHLD	SBSAV	;START OF ROUTINE
	PCHL		;TRANSFER

;GOGUB PROCESSOR
GOSUB:	LXI	H,ILOOP	;FOR RETURN STMT.
	PUSH	H	;TO STACK
	LHLD	KFPNT	;PNTR. TO NEXT STMT.
	PUSH	H	;SAVE ON STACK
	LHLD	NXTSP	;CHECK MEMORY
	CALL	MEMFUL
	LHLD	CPNT	;GET CHAR. PNTR
	INX 	H
	JMP	GSENT	;PART OF GOTO TO FINISH

;RETURN STMT. PROCESSOR
RETRN:	POP	H	;GET RETURN ADD. FROM STACK
	RET		;CONTINUE

;FOR STATEMENT PROCESSOR
FOR:	LHLD	CPNT	;FIX PNTRS
	INR	C
	INX	H
	INX	H
	CALL	ICP7
	CALL	ALPHA	;LETTER?
	JNC	ER21	;NO
	MOV	B,M	;GET IT TO B
	CALL	ICP7	;BUMP PNTR'S
	MOV	D,C	;SAVE C
	MVI	C,0	;INIT C TO 0
	CALL	NUMB	;NUMBER?
	JNC	$+9	;NO
	MOV	C,M	;YES GET IT
	INX	H	;BUM6 PNTR'S
	DCR	D
	JZ	ER7	;PREMATURE EOL
	PUSH	H	;SAVE H,L
	CALL	FSYM	;GET VAR. LOCATION
	XTHL		;PUT ON STACK GET H,L
	MOV	E,C	;VARIABLE TO D,E
	MOV	C,D	;RESTORE C
	MOV	D,B
	XCHG		;SAVE VAR NAME
	SHLD	VNAME
	XCHG		;RESTORE H,L
	MOV	A,M	;LOOK FOR =
	CPI	'=' | 200O
	JNZ	ER16
	CALL	ICP7	;BUMP PNTR'S
	CALL	EVAL	;EVALUATE EXPRESSION
	XTHL		;VARIABLE LOCATION
	CALL	COPDH	;WRITE VALUE
	SHLD	VLOC	;SAVE PNTR TO VARIABLE LOCATION
	POP	H	;GET H,L BACK
	MOV	A,C	;CHECK EOL
	ORA	A
	JZ	ER7
	MVI	A,2	;CHECK FOR 'TO'
	CALL	SYMSRT
	CPI	7
	JNZ	ER17
	INX	H	;BUMB PNTR'S
	INX	H
	MOV	A,C	;CHECK EOL
	ORA	A
	JZ	ER7
	CALL	EVAL	;EVALUATE LIMIT
	PUSH	H	;SAVE H,L
	LXI	H,FLIMT	;SAVE LIMIT VALUE
	CALL	COPDH
	MOV	A,C	;CHECK EOL
	ORA	A
	JNZ	STP
	LXI	D,FONE	;DEFAULT STEP=1
	POP	H	;RESTORE H,L
	JMP	FBILD
STP:	POP	H	;GET H,L
	MVI	A,2	;LOOK TOR 'STEP'
	CALL	SYMSRT
	CPI	8
	JNZ	ER17
	INX	H	;FIX H,L
	INX	H
	INX	H
	INR	C	;CHECK EOL
	CALL	ICP7
	CALL	EVAL	;GET STEP SIZE

;AT THIS POINT:
;VARIABLE NAME IS IN LOCATION VNAME
;VARIABLE ADDRESS IS IN LOCATION VLOC
;VARIBLE HAS BEEN INITIALIZED
;LIMIT IS IN 4 BYTE LOCATION FLIMT
;STEP IS POINTED TO BY D,E
;H,L,C ARE POINTER, COUNTER AS USUAL
FBILD:	PUSH	D	;SAVE PNTR TO STEP
			; END OF PAGE 40
		
	LHLD	VNAME	; GET VARIABLE NAME
	MVI	A,77O	;MASK
	ANA	H	;MASK OFF TOP 2 BITS
	MOV	B,A 	;SET UP CALL TO FSYM
	MOV	C,L
	CALL	FSYM	;FIND ENTRY
	JC	FEXST	;IT WAS THERE
	PUSH	H	;IT WASN'T, SAVE H,L
	LHLD	NXTSP	;UPDATE NSTSP
	MVI	A,8	;ADD 8 TO H,L
	ADD	L
	MOV	L,A
	MVI	A,0
	ADC	H
	MOV	H,A
	SHLD	NXTSP	;NEW VALUE OF NXTSP
	CALL	MEMFUL	;CHECK MEMROY
	POP	H	;GET ADD. IN DATA BLOCK
FEXST:	POP	D	;ADDRESS OF STEP SIZE 
	CALL	COPDH	;STORE IT 
	INX	H	;TO WHERE VAR. PNTR GOES
	INX	H
	INX	H
	INX	H
	LDA	VLOC	;FIRST BYTE
	MOV	M,A	;STORE IT 
	INX	H
	LDA	VLOC+1	;SECOND BYTE
	MOV	M,A
	INX	H	;POINT TO WHERE LIMIT GOES
	LXI	D,FLIMT	;WHERE IT IS NOW
	CALL	COPDH	;COPY IT
	INX	H	;PNT TO WHERE KFPNT GOES
	INX	H
	INX	H
	INX	H
	LDA	KFPNT	;1ST BYTE
	MOV	M,A
	INX	H
	LDA	KFPNT+1	;2ND BYTE
	MOV	M,A

;PUT CURRENT VNAME ON NESTING STACK
	LXI	H,0 	;GET STACK-POINTER
	DAD 	SP
	SHLD	VLOC	;SAVE IT
	LHLD	NEST	;GET NEST SP
	MOV	A,L	;COMPARE WITH STACK LIMIT
	CPI	TOPNS & 377O	;NEED ONLY COMPARE PAGE LOCATION
	JZ	ER18	;FOR'S NESTED TOO DEEPLY		
NSTOK: 	SPHL		;LOAD NEW SP
	XCHG		;SAVE NEST SP
	LHLD	VNAME	;GET INDEX NAME
	PUSH	H	;SAVE IT
	DCX	D	;UPDATE NEST SP
	DCX 	D
	XCHG		;SAVE IT
	SHLD	NEST
	LHLD	VLOC	;RESTORE OLD SP
	SPHL
	JMP	IEND
FONE:	.DB	200O,0,0,001O	;FLOATING PNT ONE

;NEXT STATEMENT PROCESSOR
NEXT:	LHLD	CPNT 	;FIX PNTR'S
	INX	H
	INX	H
	INX	H
	INR	C
	CALL	ICP7
	CALL	ALPHA	;LETTER?
	JNC	ER21	;NO ERROR
	MOV	B,M	;YES, GET IT
	MOV	D,C	;SAVE C 
	MVI	C,0	;INIT C TP 0 
	INX	H	;BUMP PNTR'S
	DCR	D
	JZ	NEXT1
	CALL	NUMB	;NUMBER?
	JNC	ER21	;NO ERROR
	MOV	C,M	;YFF, GET IT
	DCR	D	;SHOULD BE EOL
	JNZ	ER21
NEXT1:	LXI	H,0	;GET SP
	DAD	SP
	SHLD	VLOC	;SAVE IT
	LHLD	NEST	;GET NEST SP
	MOV	A,L	;COMPARE WITH BOTTOM
	CPI 	BOTNS & 377O
	JZ	ER19	;NEXT BEFORE FOR
	SPHL		;LOAD SP
	POP	H	;GET LAST INDEX
	MOV	A,B	;COMPARE TO CURRENT
	CMP	H
	JNZ	ER20	;NESTING ERROR
			; END OF PAGE 41
	MOV	A,C
	CMP	L
	JNZ	ER20
	LHLD	VLOC	;ALL OK, RESTORE OLD SID
	SPHL
	MVI	A,77O	;MASK
	ANA	B	;MASK OUT TOP 2 BITS
	MOV	B,A
	CALL	FSYM	;FIND SYMBOL
	XCHG		;ADDRESS TO D,E
	LXI	H,FREG1	;COPY STEP TO FREG1
	CALL	COPDH
	INX	D	;PNT TO CHARACTERISTIC OF STEP
	INX	D
	INX	D
	LDAX	D	;GET LT
	ANI	200O	;GET SIGN
	RAL		;ROTATE IT INTO CARRY
	CMC		;COMPLEMENT IT
	MVI	A,0O	;MAKE SURE ASO
	RAL		;ROTATE TO LS5
	INR	A	;SUMR BY ONE
	STA	VLOC	;SAVE IT	TS AL IF - STEP,ELSES
	INX	D	;PNT TO QARJIABLE PNTR
	XCHG		;GET IT TO DE
	MOV	E,M
	INX	H
	MOV	D,M
	INX	H
	PUSH	H	;SAVE DATA BLOCK PNTR
	LXI	H,FREG2	;COPY VARIBLE VALUE TB FAEG2
	CALL	COPDH	;SAVE VARIABLE LOCATION IN H,L
	XCHG
	MVI	A,2	;SET UP TO ADD
	CALL	BINOP	;AND DO IT
	CALL	COPDH	;COPY TO VARIABLE
	LXI	H,FREG1	;AND TO FREGI FOR COMPARE
	CALL	COPDH
	POP	D	;PNT TO LIMIT
	LXI	H,FREG2	;COPY TO FREG2
	CALL	COPDH
	PUSH	D	;SAVE DATA BLOCK PNTR
	CALL	FCOMP	;COMPARE
	LXI	H,VLOC	;COMPARE WITH STEP TYPE
	CMP	M
	POP	H	;GET DATA BLOCK PNTR.
	JZ	NXTDN	;YES => LOOP DONE
	INX	H	;LOOP NOT DONE
	INX	H	;PNT TO TRANSFER ADD.
	INX	H
	INX	H
	MOV	E,M	;GET IT TO H,L
	INX	H
	MOV	D,M
	XCHG
	JMP	ILOOP
NXTDN:	LXI	H,NEST	;POP NEST STACK
	INR	M
	INR	M
	JMP	IEND	;CONTINUE
ER16:	MVI	A,16H	;'=' EXPECTED(NOTE: NO ARRAY ELEMENTS
	JMP	ERROR	;FOR INDICES)
ER17:	MVI	A,17H	;BAD SYNTAX NEAR 'TO' OR 'STEP'
	JMP	ERROR	;IN FOR STATEMENT
ER18:	MVI	A,18H	;FOR'S NESTED TOO DEEPLY
	JMP	ERROR
ER19:	MVI	A,19H	;'NEXT' EXECUTED BEFORE A 'FOR'
	JMP	ERROR
ER20:	MVI	A,20H	;NESTIMG ERROR, 'FOR'-'NEXT'
	JMP	ERROR
ER21:	MVI	A,21H	;BAD INDEX IN FOR-NEXT
	JMP	ERROR

;THIS SUB CHECKS FOR PAGE BOUNDARY CROSSING
;OF VARIABLE STORAGE BEFORE UPDATING
;FORWARD POINTER
;	D-E POINT TO CURRENT LOCATION OF NEXT VARIABLE
;	H-L POINT TO PREVIOUS VARIABLE LOCATION
;MODIFY D-E ( IF NECESSARY ) SO VARIABLE WILL NOT CROSS PAGE BOUNDARY
CHKLC:
	PUSH	PSW
	PUSH	D	;SEE IF CURRENT VARIABLE
	MVI	A,7	;STORAGE 8 WORD BLOCK
	ADD	E	;WILL CROSS PAGE BOUNDARY
	JC	CHOVL
;OK - DOES NOT CROSS PAGE
	POP	D
	POP	PSW
	RET

;PAGE BOUNDARY CROSSED - SET D-E TO START OF NEXT PAGE
CHOVL:			; END OF PAGE 42
	
	
	POP	D
	INR	D
	MVI	E,0
	POP	PSW
	RET

;THIS SUB IS CALLED PROM 'DIM' PROCESSOR
;REGS. 'D-E' POINT TO NEXT AVAILABLE WORD OF VARIABLE STORAGE
;THIS SUB MAKES SURE THAT STORAGE STARTS ON A 4-WORD
;BOUNDARY SO FLT. PT. NUMBER WILL NOT CROSS PAGE
CKDIM:
	MOV	A,E
	ANI	3
	RZ
	MOV	A,E
	ANI	374O
	ADI	4
	MOV	E,A
	MOV	A,D
	ACI	0
	MOV	D,A
	RET
	
;CALL ROUTINES
FWAM:	.DW VEND	;DEFINE FWAM POINTER
	
;ENTRIES TO SUBTABLE
SUBS:
	.DB 377O	;END OF TABLE

;	////FLOATING POINT PACKAGE FOR THE MCS8
;	////BY DAVID MEAD
;	////MODIFIED BY HAL BRAND 9/6/74
;	////MODIFIED FOR 24.BIT MATNTISSAS**********
;	////PLUS ADDED I/O CONVERSION ROUTINES
;	////NEW ROUTINE COMMENTS
;	////ARE PRECEEDED BY /
;	////OTHER CHANGES ARE NOTED BY **
;	////MODIFIED BY FRANK OLKEN 6/28/75
	
	.ORG 4000O
	
OUTR	.EQU	 7775O	;LINK TO BASIC
OUTL	.EQU	13711O
INL	.EQU 	14606O
INP	.EQU	 7772O	;LINK TO BASIC
MINCH	.EQU	  300O	;MIN. CHARACTERISTIC WITH SIGN EXTENDED
MAXCH	.EQU	  077O	;MAX. CHARACTERISTIC WITH SIGN EXTENDED

;
;************************************************************
;	//// DIVIDE SUBROUTINE
;************************************************************
;
;
LDIV:
	CALL	CSIGN	;COMPUTE SIGN OF RESULT
	CALL	ZCHK	;CHECK IF DIVIDEND = ZERO
	JNZ	DTST2	;IF DIVIDEND .NE. 0 CHECK DIVISOR
	CALL	BCHK	;CHECK FOR ZERO/ZERO
	JZ	INDFC	;ZERO/ZERO = INDEFINITE
	JMP	WZERC	;ZERO/NONZERO = ZERO
DTST2:	CALL	BCHK	;COME HERE IF DIVIDEND .NE. 0
	JZ	OFLWC	;NONZERO/ZERO = OVERFLOW
			;IF WE GET HERE, THINGS LOOK OKAY
	MOV	E,L	;SAVE BASE IN E
	MOV	L,C	;BASE\6 TO L
	CALL	DCLR	;CLEAR QUOTIENT MANTISSA SLOT
	MOV 	L,E	;RESTORE BASE IN L
	CALL	ENT1	;DO FIRST CYCLE
	MOV	L,C	;BASE \6 TO L
	CALL	DLST	;MOVE QUOTIENT OVER ONE PLACE
	MVI	D,23	;NUMBER OF ITERATIONS TO D
REP3: 	MOV	L,E
	CALL	ENT2
	DCR	D	;DEC D
	JZ	GOON
	MOV	A,L
	MOV	L,C	;BASE\6 TO L
	MOV 	C,A
	CALL 	DLST	;MOVE QUOTIENT MANT OVER
	MOV 	A,L	;CPTR TO A
	MOV	E,C	;LPTR TO E
	MOV	C,A	;CPTR TO C
	JMP	REP3
GOON:	CALL	AORS	;CHECK IF RESULT IS NORMALIZED
	JM	CRIN
	MOV	A,L	;LPTR TO A
			;END OF PAGE 43
	
	MOV	L,C	;CPTR TO L
	MOV	C,A	;LPTR TO C
	CALL	DLST	;SHIFT QUOTIENT LEFT
	MOV 	C,L
	MOV 	L,E
	CALL	LDCP	;COMPUTE THE CHARACTERISTIC OF RESULT
	RET

CRIN:	CALL	CFCHE	;GET A=CHAR(H,L), E=CHAR(H,B)
	SUB	E	;NEW CHAR = CHAR(DIVIDEND) - CHAR
	CPI	177O	;CHECK MAX POSITIVE NUMBER (DIVISIOR)
	JZ	OFLWC	;JUMP ON OVERFLOW
	ADI	1	;ADD 1 SINCE WE DID NOT LEFTSHIFT
	CALL	CCHK	;CHECK AND STORE CHARACTERISTIC
	RET		;RETURN
;
;
;**************************************************************	
;	////ADDITION SUBROUTINE
;**************************************************************	
;
;	
LADD:
	XRA	A	;/***SET UP TO ADD
	JMP 	LADS	;/NOW DO IT

;
;
;**************************************************************	
;	////SUBTRACTION SUBROUTINE
;**************************************************************	
;
;	
LSUB:
	MVI	A,200O	;/****SET UP TO SUBTRACT
;			SUBROUTINE LADS
;			FLOATING POINT ADD OR SUB
;			A[128 ON ENTRY [SUB
;			A[0 ON ENTRY [ADD
;			F-S[F,FIRST OPER DESTROYED
;			BASE \11 USED FOR SCRATCH
LADS:	CALL	ACPR	;SAVE ENTRY PUT AT BASE \6
	CALL	BCHK	;CHECK ADDEND/SUBTRAHEND = ZERO
	RZ		;IF SO RESULT=ARG SO RETURN
			;THIS WILL PREVENT UNDERFLOW INDICATION
			;ZERO + OR - ZERO
	CALL	CCMP
	JZ	E002	;IF EQUAL GO ON
	MOV	D,A	;SAVE LPTR CHAR IN D
	JC	LLTB	
	SUB 	E	;L.GT.B IF HERE
	ANI	127
	MOV	D,A	;DIFFERENCE TO D
	MOV	E,L	;SAVE BASE IN E
	MOV	L,C	;C PTR TO L
	INR	L	;C PTR\1 TO L
	MOV	M,E	;SAVE BASE IN C PTR\1
	MOV	L,B	;B PTR TO L
	JMP	NCHK
LLTB:	MOV	A,E	;L.LT.B IF HERE, BPTR TO A
	SUB	D	;SUBTRACT LPTR CHAR FROM BPTR CHAR
	ANI	127
	MOV	D,A	;DIFFERENCE TO 0
NCHK:	MVI	A,24
	CMP	D
	JNC	SH10
	MVI	D,24
SH10:	ORA	A
	CALL	DRST
	DCR	D
	JNZ	SH10
EQUL:	MOV	A,L
	CMP	B
	JNZ	E002	;F.GT.S IF L.NE.B
	MOV	L,C	;C PTR TO L
	INR 	L	;C PTR\1 TO L
	MOV	L,M	;RESTORE L
E002:	CALL	LASD	;CHECK WHAT TO
	CALL	ACPR	;SAVE ANSWER
	CPI	2	;TEST FOR ZERO ANSWER
	JNZ	NOTO
	JMP	WZER	;WRITE FLOATING ZERO AND RETURN
NOTO:	MVI	D,1	;WILL TEST FOR SUB
	ANA	D
	JZ	ADDZ	;LSB[1 IMPLIES SUB
	CALL	TSTR	;CHECK NORMAL/REVERSE
	JZ	SUBZ	;IF NORMAL,GO SUBZ
	MOV	A,L	;OTHERWISE REVERSE
	MOV	L,B	;ROLES
	MOV	B,A	;OF L AND B
SUBZ:	CALL	DSUB	;SUBTRACT SMALLER FROM BIGGER
	CALL	MANT	;SET UP SIGN OF RESULT
	CALL	TSTR	;SEE IF WE NEED TO INTERCHANGE
			;BPTR AND LPTR
			; END OF PAGE 44

	JZ	NORM	;NO INTERCHANGE NECESSARY,NONORMALIZE
			;AND RETURN
	MOV	A,L	;INTERCHANGE
	MOV	L,B	;L
	MOV	B,A	;AND B
	MOV	A,C	;CPTR	TO A
	MOV	C,B	;BPTR TO C
	MOV	E,L	;LPTR TO E
	MOV	B,A	;CPTR TO B
	CALL	LXFR	;MOVE_BPTR> TO _LPTR>
	MOV	A,B
	MOV	B,C
	MOV	C,A
	MOV	L,E
	JMP	NORM	;NORMALIZE RESULT AND RETURN

;
;COPY THE LARGER CHARACTERISTIC TO THE RESULT
;
ADDZ:	CALL	CCMP	;COMPARE THE CHARACTERISTICS
	JNC	ADD2	;IF CHAR(H,L) .GE. CHAR(H,B) CONTINUE
	CALL	BCTL	;IF CHAR(H,L) .LT. CHAR(H,B) THEN COPY
			;CHAR(H,B) TO CHAR(H,L)
ADD2:	CALL	MANT	;CONPUTE SIGN OF RESULT
	CALL	DADD	;ADD MANTISSAS
	JNC	SCCFG	;IF THERE IS NO OVFLW - DONE
	CALL	DRST	;IF OVERFLOW SHIFT RIGHT
	CALL	INCR	;AND INCREMENT CHARACTERISTIC
	RET		;ALL DONE, SO RETURN

;
;THIS ROUTINE STORES THE MANTISSA SIGN IN THE RESULT
;THE SIGN HAS PREVIOCISLY BEEN COMPUTED BY LASD.
;
MANT:	MOV	E,L	;SAVE L PTR
	MOV	L,C	;C PTR TO L
	MOV	A,M	;LOAD INDEX WORD
	ANI	128	;SCARF SIGN
	MOV	L,E	;RESTORE L PTR
	INR	L	;L PTR\2
	INR	L
	INR	L	;TO L
	MOV	E,A	;SAVE SIGN IN E
	MOV	A,M
	ANI	127	;SCARF CHAR
	ADD	E	;ADD SIGN
	MOV	M,A	;STORE IT
	DCR	L	;RESTORE
	DCR	L
	DCR	L	;L PTR
	RET

;SUBROUTINE LASD
;UTILITY ROUTINE FOR LADS
;CALCULATES TRUE OPER AND SGN
;RETURNS ANSWER IN ??
LASD:	CALL	MSFH	;FETCH MANT SIGNS, F IN A,D
	CMP	E	;COMPARE SIGN
	JC	ABCH	;F\,S- MEANS GO TO A BRANCH
	JNZ	BBCH	;F- S\ MEANS GO TO B BRANCH
	ADD	E	;SAME SIGN IF HERE, ADD SIGNS
	JC	BMIN	;IF BOTH MINUS WILL OVERFLOW
	CALL	AORS	;BOTH POS IF HERE
	JP	L000	;IF AN ADD, LOAD 0
COM1:	CALL	DCMP	;COMPARE F WITH S
	JC	L131	;S.GT.F, SO LOAD 131
	JNZ	L001	;F.GT.S, SO LOAD 1
L002:	MVI	A,2	;ERROR CONDITION, ZERO ANSWER
	RET
BMIN:	CALL	AORS	;CHECK FOR ADD OR SUB
	JP	L128	;ADD, SO LOAD 128
COM2:	CALL	DCMP	;COMPARE F WITH S
	JC	L003	;S .GT. F SO LOAD 3
	JNZ	L129	;F.GT.S SO LOAD 129
	JMP	L002	;ERROR
ABCH:	CALL	AORS	;FT,S- SO TEST FOR A/S
	JM	L000	;SUBTRACT, SO LOAD 0
	JMP	COM1	;ADD, SO GO TO DCMP
BBCH:	CALL	AORS	;F-,S\, SO TEST FOR A/S
	JM	L128	;SUB
	JMP	COM2	;ADD
L000:	XRA	A
	RET
L001:	MVI	A,1
	RET
L003:	MVI	A,3
	RET
L128:	MVI	A,128
	RET
L129:	MVI	A,129
	RET
L131:	MVI	A,131
	RET		; END OF PAGE 45
	
	
;SUBROUTINE LMCM
;COMPARES THE MAGNITUDE OF
;TWO FLOATING PNT NUMBERS
;Z[1 IF [,C[1 IF F.LT.S.
LMCM:
	CALL	CCMP	;CHECK CHARS
	RNZ		;RETURN IF NOT EQUAL
	CALL	DCMP	;IF EQUAL, CHECK MANTS
	RET

;
;
;**************************************************************	
;	////MULTIPLY SUBROUTINE
;**************************************************************	
;
;	SUBROUTINE LMUL
;	FLOATING POINT MULTIPLY
;	L PTR X B PTR TO C PTR
LMUL:
	CALL	CSIGN	;COMPUTE SION OF RESULT AND STORE IT
	CALL	ZCHK	;CHECK FIRST OPERAND FOR ZERO
	JZ	WZERC	;ZERO X ANYTHING = ZERO
	CALL	ZCHK	;CHECK SECOND OPERAND FOR ZERO
	JZ	WZERC	;ANYTHING * ZERO = ZERO
	MOV	E,L	;SAVE L PTR
	MOV	L,C	;C PTR TO L
	CALL	DCLR	;CLR PRODCT MANT LOCS
	MOV	L,E	;L PTR TO L
	MVI	D,24	;LOAD NUMBER ITERATIONS
KPGO:	CALL	DRST	;SHIFT L PTR RIGHT
	JC	MADD	;WILL ADD B PTR IF C[1
	MOV	A,L	;INTERCHANGE
	MOV	L,C	;L AND
	MOV	C,A	;C PTRS
INTR:	CALL	DRST	;SHIFT PRODUCT OVER
	MOV	A,L	;INTERCHANGE
	MOV	L,C	;L AND C PTRS_BACK TO
	MOV	C,A	;ORIGINAL>
	DCR	D
	JNZ	KPGO	;MORE CYCLES IF Z[0
	CALL	AORS	;TEST IF RESULT IS NORMALIZED
	JM	LMCP	;IF NORMALIZED GO COMPUTE CHAR
	MOV	E,L	;SAVE LPTR IN E
	MOV	L,C	;SET L=CPTR
	CALL	DLST	;LEFT SHIFT RESULT TO NORMALIZE
	MOV	L,E	;RESTORE LPTR
	CALL	CFCHE	;OTHERWISE SET A=CHAR(H,L),E=CHAR(H,B)
	ADD	E	;CHAR(RESULT) = CHAR(H,L)+CHAR(H,B)
	CPI	200O	;CHECK FOR SMALLEST NEGATIVE NUMBER
	JZ	UFLWC	;IF SO THEN UNDERFLOW
	SUI	1	;SUBTRACT 1 TO COMPENSATE FOR NORMALIZE
	CALL	CCHK	;CHECK CHARACTERISTIC AND STORE IT
	RET		;RETURN

MADD:	MOV	A,L	;INTERCHANGE
	MOV	L,C	;L AND
	MOV	C,A	;C PTRS
	CALL	DADD	;ACCUMULATE PRODUCT
	JMP	INTR

;
;SUBROUTINE NORM
;
;  THIS SUBROUTINE WILL NORMALIZE A FLOATING POINT
;  NUMBER PRESERVTNG ITS ORIGINAL SIGN.
;  WE CHECK FOR UNDERFLOW AND SET THE CONDITION
;  FLAG APPROPRIATELY. (SEE ERROR RETURNS).
;  THER IS AN ENTRY POINT TO FLOAT A SIGNED INTEGER
;  (FLOAT) AND AN ENTRY POINT TO FLOAT AN UNSIGNED
;  INTEGER.
;
;  ENTRY POINTS:
;
;  NORM  -  NORMALIZE FLOATING PT NUMBER AT (H,L)
;  FLOAT -	FLOAT TRIPLE PRECISION INTEGER AT (H,L)
;	PRESERVING SIGN BIT IN (H,L)+3
;  DFXL -	FLOAT UNSIGNED (POSITIVE) TRIPLE PRECISION
;	AT (H,L)
;
;  REGISTERS ON EXIT:
;    A = CONDITION FLAG (SEE ERROR RETURNS)
;    D,E = GARBAGE
;    B,C,H,L = SAME AS ON ENTRY
;	
NORM:
	MOV	E,L	;SAVE L IN E
NORM1:	CALL	GCHAR	;GET CHAR(H,L) IN A WITH SIGN EXTENDED
	MOV	D,A	;SAVE CHAR IN 0
FXL1:	MOV	L,E	;RESTORE L
FXL2:	CALL	ZMCHK	;CHECK FOR ZERO MANTISSA
	JZ	WZER	;IF ZERO MANTISSA THEN ZERO RESULT
REP6:	MOV	A,M	;GET MOST SIGNIFICANT BYTE OF
			;MANTISSA
			; END OF PAGE 46

	ORA	A	;SET FLAGS
	JM	SCHAR	;IF MOST SIGNFICANT BIT = 1 THEN

			;NUMBER IS NORMALIZED AND WE GO TO
			;STORE THE CHARACTERISTIC
	MOV	A,D	;OTHERWISE CHECK FOR UNDERFLOW
	CPI	MINCH	;COMPARE WITH MINIMUM CHAR
	JZ	WUND	;IF EQUAL THEN UNDERFLOW
	CALL	DLST	;SHIFT MANTISSA LEFT
	DCR	D	;DECREMENT CHARACTERSTIC
	JMP	REP6	;LOOP AN TEST NEXT BIT
SCHAR:	JMP	INCR3	;STORE THE CHARACTERISTIC USING
			;THE SAME CODE AS THE INCREMENT
DFXL:
	MOV	E,L	;ENTER HERE TO FLOAT UNSIGNED
			;INTEGER
			;FIRST SAVE L IN E
	INR	L	;MAKE (H,L) POINT TO CHAR
	INR	L	;MAKE (H,L) POINT TO CHAR
	INR	L	;MAKE (H L) POINT TO CHAR
	XRA	A	;ZERO ACCUMULATOR
	MOV	M,A	;STORE A PLUS (+) SIGN
	MOV	L,E	;RESTORE L
FLOAT:
	MVI	D,24	;ENTER HERE TO FLOAT INTEGER
			;PRESERVING ORIGINAL SIGN IN (H,L)+3
			;SET UP CHARACTERISTIC
	JMP	FXL2	;GO FLOAT THE NUMBER

;
;SUBROUTINE ZCHK
;
;  THIS ROUTINE SETS THE ZERO FLAG IF IT DETECTS
;  A FLOATING ZERO AT (H,L)
;
;SUBROUTINE ZMCHK
;  THIS ROUTINE SETS THE ZERO FLAG IF IT DETECTS A
;  ZERO MANTISSA AT (H,L)
;
ZCHK:
ZMCHK:	INR	L	;SET L TO POINT LAST BYTE OF MANTISSA
	INR	L	;SET L TO POINT TO LAST BYTE OF MANT.
	MOV	A,M	;LOAD LEAST SIGNIFICANT BYTE
	DCR	L	;L POINTS TO MIDDLE BYTE
	ORA	M	;OR WITH LEAST SIGNFICANT BYTE
	DCR	L	;L POINTS TO MOST SIGNFICANT BYTE
			;OF MANTISSA (ORIGINAL VALUE)
	ORA	M	;OR IN MOST SIGNFICANT BYTE
	RET		;RETURNS WITH ZERO FLAG SET APPROPRIATELY

;
;SUBROUTINE BCHK
;
;  THIS ROUTINE CHECKS (H,B) FOR FLOATING PT ZERO
BCHK:	MOV	E,L	;SAVE LPTR IN E
	MOV	L,B	;SET L=BPTR
	CALL	ZCHK	;CHECK FOR ZERO
	MOV	L,E	;RESTORE L=LPTR
	RET		;RETURN
	
;
;SUBROUTINE DLST
;
;  SHIFTS .DBL WORD ONE PLACE LF
;
DLST:	INR	L
	INR	L	;/***TP
	MOV	A,M	;LOAD 17
	ORA	A	;KILL CARRY
	RAL		;SHIFT IT LEFT
	MOV	M,A	;STORE IT
	DCR	L
	MOV 	A,M	;LOAD IT
	RAL		;SHIFT IT LEFT
			;IF CARRY SET BY FIRST SHIFT
			;IT WILL BE IN LSB OF SECOND
	MOV	M,A
	DCR	L	;/***TP EXTENSION
	MOV	A,M
	RAL
	MOV	M,A	;/***ALL DONE TP
	RET		;SUBROUTINE DRST
			;SHIFTS DOUBLE WORD ONE PLACE
			;TO THE RIGHT
			;DOES NOT AFFECT D

DRST:	MOV	E,L	;/***TP MODIFIED RIGHT SHIFT TP
	MOV	A,M	;LOAD FIRST WORD
	RAR		;ROTATE IT RIGHT
	MOV	M,A	;STORE IT
	INR	L	;/*** TP
	MOV 	A,M	;LOAD SECOND WORD
	RAR		;SHIFT IT RIGHT
	MOV	M,A	;STORE TT
			; END OF PAGE 47
		
	INR L		;/***TP EXTENSION
	MOV A,M
	RAR
	MOV M,A
	MOV L,E	;/***TP - ALL DONE TP
	RET

; SUBROUTINE DADD
; ADDS TWO DOUBLE PRECISION
; WORDS, C[1 IF THERE IS OVRFLW
DADD:	MOV	E,L	;SAVE BASE IN E
	MOV	L,B	;BASE \3 TO L
	INR	L	;BASE \4 TO L
	INR	L	;/***TP
	MOV	A,M	;LOAD S MANTB
	MOV	L,E	;BASE TO L
	INR	L	;BASE \1 TO L
	INR	L	;/***TP
	ADD	M	;ADD TWO MANTBIS
	MOV	M,A	;STORE ANSWER
	MOV	L,B	;/***TP EXTENSION
	INR	L
	MOV	A,M
	MOV	L,E
	INR	L
	ADC	M
	MOV	M,A	;/***TP - ALL DONE
	MOV	L,B	;BASE \3 TO L
	MOV	A,M	;MANTA OF S TO A
	MOV	L,E	;BASE TO L
	ADC	M	;ADD WITH CARRY
	MOV	M,A	;STORE ANSWER
	RET
;
;SUBROUTINE DCLR
;CLEARS TWO SUCCESSIVE
;LOCATIONS OF MEMORY
DCLR:	XRA	A	
	MOV	M,A
	INR	L
	MOV	M,A
	INR	L	;/**WTP EXTENSION
	MOV	M,A	;/X**TP ZERO 3
	DCR	L	;/***TP - ALL DONE
	DCR	L
	RET

;/****ALL NEW DSUB - SHORTER***
;SUBROUTINE DSUB
;DOUBLE PRECISION SUBTRACT
DSUB:	MOV	E,L	;SAVE BASE IN E
	INR	L	;/***TP EXTENSION
	INR	L	;/START WITH LOWS
	MOV	A,M	;/GET ARG
	MOV	L,B	;/NOW SET UP TO SUB
	INR	L
	INR	L
	SUB	M	;/NOW DO IT
	MOV	L,E	;/NOW MUST PUT IT BACK
	INR	L
	INR	L
	MOV	M,A	;PUT BACK
	DCR	L	;/***TP - ALL DONE
	MOV	A,M	;/GET LOW OF LOP
	MOV	L,B	;/SET TO BOP
	INR	L	;/SET TO BOP LOW
	SBB	M	;/GET DIFF. OF LOWS
	MOV	L,E	;/SAVE IN LOP LOW
	INR	L	;/TO LOP LOW
	MOV	M,A	;/INTO RAM
	DCR	L	;/BACK UP TO LOP HIGH
	MOV	A,M	;/GET LOP HIGH
	MOV	L,B	;/SET TO BOP HIGH
	SBB	M	;/SUB. WITH CARRY
	MOV	L,E	;/SAVE IN LOP HIGH
	MOV	M,A	;/INTO RAM
	RET		;/ALL DONE - MUCH SHORTER

;SUBROUTINE GCHAR
;  THIS SUBROUTINE RETURNS THE CHARACTERISTIC OF
;  THE FLOATING POINT NUMBER POINTED TO BY (H,L)
;  IN THE A REGISTER WITH ITS SIGN EXTENDED IATO THE
;  LEFTMOST BIT.
;
;REGISTERS ON EXIT:
;
;  A = CHARACTERISTIC OF (H,L) WITH SIGN EXTENDED
;  L = (ORIGINAL L) + 3
;  B,C,D,E,H = SAME AS ON ENTRY
GCHAR:	INR	L	;MAKE (H,L)	POINT TO CHAR
	INR	L	;MAKE (H,L)	POINT TO CHAR
	INR	L	;MAKE (H,L)	POINT TO CHAR
	MOV	A,M	;SET A=CHAR	+ MANTISSA SIGN
	ANI	177O	;GET RID OF MANTISSA SIGN BIT
			; END OF PAGE 48

	ADI	100O	;PROPAGATE CHAR SIGN INTO LEFTMOST BIT
	XRI	100O	;RESTORE ORIGINAL CHAR SIGN BIT
	RET		;RETURN WITH (H,L) POINTING TO THE
			;CHAR = ORIGINAL (H,L)+3
			;SOMEONE ELSE WILL CLEAN UP
;
;
; SUBROUTINE CFCHE
;
;  THIS SUBROUTINE RETURNS THE CHARACTERISTICS OF THE
;  FLOATING POINT NUMBERS POINTED TO BY (H,L) AND
;  (H,B) IN THE A AND E REGISTERS RESPECTIVELY,
;  WITH THEIR SIGNS EXTENUED INTO THE LEFTMOST BIT.
;
; REGISTERS ON EXIT:
;
;  A = CHARACTERISTIC OF (H,L) WITH SIGN EXTENDED
;  E = CHARACTERISTIC OF (H,B) WITH SIGN EXTENDED
;  B,C,H,L = SAME AS ON ENTRY
;  D = A
CFCHE:	MOV	E,L	;SAVE LPTR IN E
	MOV	L,B	;SET L = BPTR
	CALL	GCHAR	;GET CHAR(H,B) WITH SIGN EXTENDED IN A
	MOV	L,E	;RESTORE L = LPTR
	MOV	E,A	;SET E=CHAR(H,B) WITH SIGN EXTENDED
	CALL	GCHAR	;SET A=CHAR(H,L) WITH SIGN EXTENDED
	DCR	L	;RESTORE L = LPTR
	DCR	L	;RESTORE L = LPTR
	DCR	L	;RESTORE L = LPTR
	MOV	D,A	;SET D=A=CHAR(H,L) WITH SIGN EXTENDED
	RET

;
; SUBROUTINE CCMP
;  THIS SUBROUTINE COMPARES THE CHARACTERISTICS OF
;  FLOATING POINT NUMBERS POINTED TO BY (H,L) AND (H,B).
;  THE ZERO FLIP-FLOP IS SET IF CHAR(H,L) EQUALS
;  CHAR(H,B) IF CHAR(H,L) IS LESS THAN CHAR(H,B) THEN
;  THE CARRY BIT WILL BE SET.
;
; REGISTERS ON EXIT:
;
;  A = CHARACTERISTIC OF (H,L) WITH SIGN EXTENDED
;  E = CHARACTERISTIC OF (H,B) WITH SIGN EXTENDED
;  D = A
;  B,C,H,L = SAME AS ON ENTRY
;
CCMP:	CALL	CFCHE 	;FETCH CHARACTERTISTICS WITH SIGN EXT'D
			;INTO A (CHAR(H,L)) & E (CHAR(H,B)) REGS
	MOV	D,A	;SAVE CHAR (H,L)
	SUB	E	;SUATRACT E CHAR(H B))
	RAL		;ROTATE SIGN BIT INTO CARRY BIT
	MOV	A,D	;RESTORE A=CHAR(H,L)
	RET		;RETURN
	
;
; ERROR RETURNS
;  THE FOLLOWING CODE IS USED TO RETURN VARIOUS
;  ERROR CONDITIONS. IN EACH CASE A FLOATING POINT
;  NUMBER IS STORED IN THE 4 WORDS POINTED TO BY (H,L)
;  AND A FLAG IS STORED IN THE ACCUMULATOR.
;
;  CONDITION     FLAG    RESULT (+)	       RESULT (-)
;
;  UNDERFLOW	377    000 000 000 100	 000 000 000 300
;  OVERFLOW	      177    377 377 377 077	 377 377 377 277
;  INDEFINITE	077    377 377 377 077	 377 377 377 277
;  NORMAL         000    XXX XXX XXX XXX 	 XXX XXX XXX XXX
;  NORMAL ZERO    000    000 000 000 100	 (ALWAYS RETURNS +0)
;
; ENTRY POINTS:
;
;  WUND - WRITE UNDERFLOW
;  WOVR - WRITE OVERFLOW
;  WIND - WRITE INDEFINITE
;  WZER - WRITE NORMAL ZERO

WFLT	MACRO	VMANT,VCHAR,VFLAG,LABEL 	;WRITE FLOATING NUMBER

	MVI	D,VCHAR	;LOAD CHARACTERISTIC INTO D REGISTER
	CALL	WCHAR	;WRITE CHARACTERISTIC
LABEL::	MVI	A,VMANT	;LOAD MANTISSA VALUE
			;WE ASSUME HERE THAT ALL BYTES OF 
			;MANTISSA ARE THE SAME
	CALL	WMANT	;WRITE THE MANTISSA
	MVI	A,VFLAG	;SET ACCUMULATOR TO FLAG
	ORA	A	;SET FLAGS PROPERLY
	RET		;RETURN (WMANT RESTORED (H,L))
	ENDM
	
WUND:	WFLT	0,100O,377O,UFLW1	;WRITE UNDERFLOW
			; END OF PAGE 49
		
	MVI	D,00040H	;LOAD	CHARACTERISTIC INTO D REGISTER
	CALL	WCHAR	;WRITE CHARACTERISTIC
UFLW1::	MVI	A,00000H	;LOAD	MANTISSA VALUE
			;WE ASSUME HERE THAT ALL BYTES OF MANT.
			;ARE THE SAME
	CALL	WMANT	;WRITE THE MANTISSA
	MVI	A,000FFH	;SET ACCUMULAIOR TO FLAG
	ORA	A	;SET FLAGS PROPERLY
	RET		;RETURN (WMANT RESTORED (H,L))

WOVR:	WFLT	377O,77O,177O,OFLW1 ;WRITE OVERFLOW
	MVI	D,0003FH	;LOAD CHRACTERISTIC INTO D REGISTER
	CALL	WCHAR	;WRITE CHARACTERISTIC
OFLW1::	MVI	A,000FFH	;LOAD MANTISSA VALUE
			;WE ASSUME HERE THAT ALL BYTES OF MANT.
			;ARE THE SAME 	
	CALL	WMANT	;WRITE THE MANTISSA
	MVI	A,0007FH	;SET ACCUMULATOR TO FLAG
	ORA	A	;SET FLAGS PROPERLY
	RET		;RETURN (WMANT RESTORED (H,L))
WIND:	WFLT	377O,77O,77O,INDF1	;WRITE INDEFINITE

	MVI	D,0003FH	;LOAD CHRACTERISTIC INTO D REGISTER
	CALL	WCHAR	;WRITE CHARACTERISTIC
INDF1::	MVI	A,000FFH	;LOAD MANTISSA VALUE
			;WE ASOUME HERE THAT ALL BYTES OF MANT.
			;ARE THE SAME 
	CALL	WMANT	;WRITE THE MANTISSA
	MVI	A,0003FH	;SET ACCMULATOR TO FLAG
	ORA	A	;SET FLAGS PROPERLY
	RET		;RETURN (WMANT RESTORED (H,L))

WZER:	INR	L	;WRITE NORMAL ZERO
	INR	L
	INR	L
	MVI	M,100O	;STORE CHARACTERISTIC FOR ZERO
	XRA	A	;ZERO ACCUMULATOR
	CALL	WMANT	;STORE ZERO MANTISSA
	ORA	A	;SET FLAGS PROPERLY
	RET		;RETURN

;ROUTINE TO WRITE MANTISSA FOR ERROR RETURNS
WMANT:	DCR	L	;POINT LEAST SIGNIFICANT BYTE
	MOV	M,A	;OF MANTISSA
			;STORE LSBYTE OF MANTISSA
	DCR	L	;POINT TO NEXT LEAST SIGNIFICANT BYTE
			;OF MANTISSA
	MOV	M,A	;STORE NLSBYTE OF MANTISSA
	DCR	L	;POINT TO MOST SIGNIFICANT BYTE
	MOV	M,A	;OF MANTISSA
	RET		;STORE MSBYTE OF MANTISSA
			;RETURN (H,L) POINTS TO BEGINNING OF
			;FLOATING POINT RESULT


;ROUTINE TO WRITE CHARACTERTIC FOR ERROR RETURNS
;NOTE: WE PRESERVE ORIGINAL MANTISSA SIGN
;ON ENTRY D CONTAINS NEW CHARICTERSTIC TO BE STORED.
WCHAR:	INR	L	;SET (H,L) TO POINT TO CHARACTERISTIC
	INR	L	;PART OF ABOVE
	INR	L	;PART OF ABOVE
	MOV	A,M	;LOAD CHARACTERISTIC A
			;AND MANTISSA SIGN
	ANI	200O	;JUST KEEP MANTISSA SIGN
	ORA	D	;OR IN NEW CHARACTERISTIC
	MOV	M,A	;STORE IT BACK
	RET		;RETURN WITH (H,L) POINT TO
			;OF RESULT CHARACTERISTIC
			;SOMEONE ELSE WILL FIX UP (H,L)

;
;SUBROUTINE INDFC
;THIS ROUTINE WRITES A FLOATING INDEFINITE
;AT (H,C), SETS THE CONDITION FLAG AND RETURNS
INDFC:	MOV	E,L	;SAVE LPTR IN E
	MOV	L,C	;SET L=CPTR SO (H,L)-ADDR OF RESULT
	CALL	WIND	;WRITE INDEFINITE
	MOV	L,E	;RESTORE L=LPTR
	RET		;RETURN
	
;
;SUBROUTINE WZERC
;THIS ROUTINE WRITES A NORMAL FLAOTING POINT ZERO
;AT (H,C), SETS THE CONDITION FLAG AND RETURNS
WZERC:	MOV	E,L	;SAVE LPTR IN E
	MOV	L,C	;SETL=CPTR SO (H,L)=ADDR OF RESULT
	CALL	WZER	;WRITE NORMAL ZEAO
	MOV	L,E	;RESTORE L=LPTR
	RET		;RETURN
			; END OF PAGE 50
		
;SUBROUTINE INCR
; THIS SUBROUTINE INCREMENTS THE CHARACTERISTIC
; OF THE FLOATING POINT NUMBER POINTED TO BY (H,L).
; WE TEST FOR OVERFLOW AND SET APPROPRIATE FLAG.
; (SEE ERROR RETURNS).
;
; REGISTERS ON EXIT:
;   A = CONDITION FLAG (SEE ERROR RETURNS)
;   D = CLOBBERED
;   B,C,H,L = SAME AS ON ENTRY
INCR:	CALL	GCHAR	;GET CHAR WITH SIGN EXTENDED
	CPI	MAXCH	;COMPARE WITH MAX CHAR PERMITTED
	JZ	OFLW1	;INCREMENT WOULD CAUSE OVERFLOW
	MOV	D,A	;/SAVE IT IN D
	INR	D	;/INCREMENT IT
	JMP	INCR2	;JUMP AROUND ALTERNATE ENTRY POINT
INCR3:	INR	L	;COME HERE TO STORE CHARACTERISTIC
	INR	L	;POINT (H,L) TO CHAR
	INR	L	;POINT (H,L) TO CHAR
INCR2:	MVI	A,177O
	ANA	D	;/KILL SIGN BIT
	MOV	D,A	;/BACK TO D
	MOV	A,M	;/NOW SIGN IT
	ANI	200O	;/GET MANTISSA SIGN
	ORA	D	;/PUT TOGETHER
	MOV	M,A	;/STORE IT BACK
	DCR	L	;/NOW BACK TO BASE
	DCR	L	;/***TP
	DCR	L
SCCFG:	XRA	A	;SET SUCCESS FLAG
	RET
	
;
; SUBROUTINE DECR
;
;THIS SUBROUTINE DECREMENTS THE CHARACTERISTIC
;OF THE FLOATING POINT NUMDER POINTED TO BY (H,L)
;WE TEST FOR UNDERFLOW AND SET APPROPRIATE FLAG.
;(SEE ERROR RETURNS).
;	
; REGISTERS ON EXIT:
;
;   A = CONDITION FLAG (SEE ERROR RETURNS)
;   D = CLOBBERED
;   B,C,H,L = SAME AS ON ENTRY
DECR:	CALL	GCHAR	;GET CHAR WITH SIGN EXTENDED
	CPI	MINCH	;COMPARE WITH MIN CHAR PERMITTED
	JZ	UFLW1	;DECREMENT WOULD CAUSE UNDERFLOW
	MOV	D,A	;SAVE CHARACTERSTIC IN D
	DCR	D	;DECREMENT CHARACTERISTIC
	JMP	INCR2	;GO STORE IT BACK
	
;SUBROUTINE AORS
;RETURN S[1 IF BASE \6
;HAS A 1 IN MSB
AORS:	MOV	E,L	;SAVE BASE
	MOV	L,C	;BASE \6 TO L
	MOV	A,M	;LOAD IT
	ORA	A	;SET FLAGS
	MOV	L,E	;RESTORE BASE
	RET

;SUBROUTINE TSTR
;CHECKS C PTR TO SEE IF
;NLSB[1
;RETURNS Z[1 IF NOT
;DESTROYS E,D
TSTR:	MOV	E,L	;SAVE BAIDE
	MOV	L,C	;C PTR TO L
	MVI	D,2	;MASK TO D
	MOV	A,M	;LOAD VALUE
	MOV	L,E 	;RESTORE BASE
	ANA	D	;AND VALUE WITH MASK
	RET

;SUBROUTINE ACPR
;STORES A IN LOCATION OF CPTR
;LPTR IN E
ACPR:	MOV	E,L	;SAVE LPTR
	MOV	L,C	;CPTR TO L
	MOV	M,A	;STORE A
	MOV	L,E	;RESTORE BASE
	RET

;SUBROUTINE DCMP
;COMPARES TWO DOUBLE LENGTH
;WORDS
DCMP:	MOV	A,M	;NUM MANTA TO A
	MOV	E,L	;SAVE BASE IN E
	MOV	L,B	;BASE\3 TO L
	CMP	M	;COMPARE WITH DEN MANTA
			; END OF PAGE 51
	
	MOV	L,E	;RETURN BASE TO L
	RNZ		;RETURN IF NOT THE SAME
	INR	L	;L TO NUM MANTS
	MOV	A,M	;LOAD IT
	MOV	L,B	;DEN MANTB ADD TO L
	INR	L	;BASE\ 4 TO L
	CMP	M
	MOV	L,E
	RNZ		;/***TP EXTENSION
	INR	L	;/NOW CHECK BYTE 3
	INR	L
	MOV	A,M	;/GET FOR COMPARE
	MOV	L,B
	INR	L
	INR	L	;/BYTE 3 NOW
	CMP	M	;/COMPARE
	MOV	L,E	;/***TP - ALL DONE
	RET

;SUBROUTINE DIVC
;PERFORMS ONE CYCLE OF DOUBLE
;PRECISION FLOATING PT DIVIDE
;ENTER AT ENT1 ON FIRST CYCLE
;ENTER AT ENT2 ALL THEREAFTER
ENT2:	CALL	DLST	;SHIFT MOVING DIVIDEND
	JC	OVER	;IF CARRY[1,NUM.GT.0
ENT1:	CALL	DCMP	;COMPARE NUM WITH DEN
	JNC	OVER	;IF CARRY NOT SET,NUM.GE.DEN
	RET

OVER:	CALL	DSUB	;CALL DOUBLE SUBTRACT
	MOV	E,L	;SAVE BASE IN E
	MOV	L,C	;BASE \6 TO L
	INR	L	;BASE \7 TO L
	INR	L	;/***TP
	MOV	A,M
	ADI	1	;ADD 1
	MOV	M,A	;PUT IT BACK
	MOV	L,E	;RESTORE BASE TO L
	RET

;SUBROUTINE LXFR
;MOVES CPTR TO EPTR
;MOVES 3 WORDS IF ENTER AT LXFR
LXFR:
	MVI	D,4	;/MOVE 4 WORDS
REP5:	MOV	L,C	;CPTR TO L
	MOV	A,M	;_CPTR> TO A
	MOV	L,E	;EPTR TO L
	MOV	M,A
	INR	C	;/INCREMENT C
	INR	E	;/INCREMENT E TO NEXT
	DCR	D	;/TEST FOR DONE
	JNZ	REP5	;/GO FOR FOR TILL D=0
	MOV	A,E	;/NOW RESET C AND E
	SUI	4	;/RESET BACK BY 4
	MOV	E,A	;/PUT BACK IN E
	MOV	A,C	;/NOW RESET C
	SUI	4	;/BY 4
	MOV	C,A	;/BACK TO C
	RET		;/DONE

;
; SUBROUTINE LDCP
;   THIS SUBROUTINE COMPUTES THE CHARACTERISTIC
;   FOR THE FLOATING DIVIDE ROUTINE
;
; REGISTERS ON EXIT:
;   A = CONDITION FLAG (SEE ERROR RETURNS)
;   D,E = GARBAGE
;   B,C,H,L = SAME AS ON ENTRY
;
; REGISTERS ON ENTRY:
;   (H,B) = ADDRESS OFF DIVISOR
;   (H,C) = ADDRESS OF OUOTIENT
;   (H,L) = ADDRESS OF DIVIDEND
;
LDCP:	CALL	CFCHE	;SET E=CHAR(H,B), A=CHAR(H,L)
	SUB	E	;SUBTRACT TO GET NEW CHARATERISTIC
	JMP	CCHK	;GO CHECK FOR OVER/UNDERFLOW
			;AND STORE CHARACTERTISTIC
;
;SUBROUTINE LMCP
;
;  THIS SUBROUTINE COMPUTES THE CHARACTERISTIC
;  FOR THE FLOATING MULTIPLY ROUTINE.
;REGISTERS ON EXIT:
;   A = CONDITION FLAG (SEE ERROR RETURNS)
;   D,E = GARBAGE
;   B,C,H,L = SAME AS ON ENTRY	; END OF PAGE 52
;
;REGISTERS ON ENTRY:
;
;   (H,B) = ADDRESS OFF MULTIPLICAND
;   (H,C) = ADDRESS OF PRODUCT
;   (H,L) = ADDRESS OF MULTIPLIER
;
LMCP:	CALL	CFCHE	;SET E=CHAR(H,B), A=CHAR(H,L)
	ADD	E	;ADD TO GET NEW CHARACTERISTIC
			;NOW FALL INTO THE ROUTINE
			;WHICH CHECKS FOR OVER/UNDERFLOW
			;AND STORE CHARACTERTISTIC

; SUBROUTINE CCHK
;   THIS SUBROUTINE CHECKS A CHARACTERISTIC IN
;   THE ACCUMULATOR FOR OVERFLOW OR UNDERFLOW.
;   IT THEN STORES THE CHARACTERISTIC PRESERVING
;   THE PREVIOUSLY COMPUTED MANTISSA SIGN.
;
; REGISTERS ON ENTRY:
;
;   (H,L) = ADDRESS OF ONE OPERAND
;   (H,B) = ADDRESS OF OTHER OPERAND
;   (H,C) = ADDRESS OF RESULT
;   A     = NEW CHARACTERISTIC OF RESULT
;
; REGISTERS ON EXIT:
;
;   A = CONDITION FLAG (SEE ERROR RETURNS)
;   D,E = GARBAGE
;   B,C,H,L = SAME AS ON ENTRY
;
CCHK:			;ENTER HERE TO CHECK CHARACTERISTIC
	CPI	100O	;CHECK FOR 0 TO +63
	JC	STORC	;JUMP IF OKAY
	CPI	200O	;CHECK FOR +64 TO +127
	JC	OFLWC	;JUMP IF OVERFLOW
	CPI	300O	;CHECK FOR -128 TO -65
	JC	UFLWC	;JLMP IF UNDERFLOW
STORC:	MOv	E,L	;SAVE L IN E
	MOV	L,C	;LET L POINT TO RESULT
	MOV	D,A	;SAVE CHARACTERISTIC IN 0
	CALL	INCR3	;STORE CHARACTERISTIC
	MOV	L,E	;RESTORE L
	RET		;RETURN
;
; SUBROUTINE OFLWC
;
;   THIS ROUTINE WRITES A FLOATING POINT OVERFLOW AT (H,C)
;   SETS THE CONDITION FLAG, AND RETURNS.
;
OFLWC:	MOV	E,L	;SAVE L IN E
	MOV	L,C	;SET L=CPTR, SO (H,L)=ADOR OF RESULT
	CALL	WOVR	;WRITE OUT OVERFLOW
	MOV	L,E	;RESTORE L
	RET		;RETURN

;
; SUBROUTINE UFLWC
;
;   THIS ROUTINE WRITES A FLOATING POINT UNDERFLOW AT (H,C)
;   SETS THE CONDITION FLAG, AND RETURNS.
;
UFLWC:	MOV	E,L	;SAVE L IN E
	MOV	L,C	;SET L=CPTR, SO (H,L)=ADDR OF RESULT
	CALL	WUND	;WRITE OUT UNDERLOW
	MOV	L,E	;RESTORE L
	RET		;RETURN

;
; SUBROUTINE CSIGN
;
;   THIS SUBROUTINE COMPUTES AND STORE THE MANTISSA
;   SIGN FOR THE FLOATING MULTIPLY AND DIVIDE ROUTINES
;
; REGISTERS ON ENTRY:
;
;   (H,L) = ADDRESS OF ONE OPERAND
;   (H,B) = ADDRESS OF OTHER OPERAND
;   (H,C) = ADDRESS OF RESULT
;
; REGISTERS ON EXIT:
;
;   A,D,E = GARBAGE
;   B,C,H,L = SAME AS ON ENTRY
;
CSIGN:	CALL	MSFH	;SET A=SIGN(H,L), E=SIGN(H,B)
	XRA	E	;EXCLUSIVE OR SIGNS TO GET NEW SIGN
	CALL	CSTR	;STORE SIGN INTO RESULT
	RET		;RETURN
			; END OF PAGE 53

;
;SUBROUTINE CSTR
;  STORES VALUE IN A IN
;  CPTR\2
;  PUTS LPTR IN E
CSTR:	MOV	E,L	;SAVE LPTR IN E
	MOV	L,C	;CPTR TO L
	INR	L	;CPTR\2
	INR	L	;TO L
	INR	L	;/***TP
	MOV	M,A	;STORE ANSWER
	MOV	L,E	;LPTR BACK TO L
	RET

;
; SUBROUTINE MSFH
;
;   THIS SUBROUTINE FETCHES THE SIGNS OF THE MANTISSAS
;   OF THE FLOATING POINT NUMBERS POINTED TO BY (H,L)
;   AND (H,B) INTO THE A AND E REGISTERS RESPECTIVEY.
;
; REGISTERS ON EXIT:
;
;   A = SIGN OF MANTISSA OF (H,L)
;   E = SIGN OF MANTISSA OF (H,B)
;   B,C,D,H,L = SAME AS ON ENTAY
;
MSFH:	MOV	E,L	;SAVE LPTR
	MOV	L,B	;BPTR TO L
	INR	L	;BPTR\2
	INR	L	;/***TP
	INR	L	;TO L
	MOV	A,M	;_BPTR\2>TO A
	ANI	128	;SAVE MANT SIGN
	MOV	L,E	;LPTR BACK TO L
	MOV	E,A	;STORE BPTR MANT SIGN
	INR	L	;LPTR\2
	INR	L	;/***TP
	INR	L	;TO L
	MOV 	A,M 	;_LPTR\2>TO A
	ANI	128	;SAVE LPTR MANT SIGN
	DCR	L	;LPTR BACK
	DCR	L	;TO L
	DCR	L	;/***TP
	RET

;SUBROUTINE BCTL
;MOVES BPTR CHAR TO LPTR CHAR
;DESTROYS E
BCTL:	MOV	E,L	;LPTR TO E
	MOV	L,B	;BPTR TO L
	INR	L	;BPTR \2
	INR	L	;/***TP
	INR	L	;TO L
	MOV	A,M	;BPTR CHAR TO A
	MOV	L,E	;LPTR TO L
	INR	L	;LPTR \2
	INR	L	;TO L
	INR	L	;/***TP
	MOV	M,A	;STORE BPTR CHAR IN LPTR CHAR
	MOV	L,E	;LPTR TO L
	RET

;
;
;**************************************************************	
;	//// 5 DIGIT FLOATING POINT OUTPUT
;**************************************************************	
;
;
;	*******ROUTINE TO CONVERT FLOATING PT.
;	***NUM8ERS TO ASCII AND OUTPUT THEM VIA A SUBROUTINE
;	***CALLED OUTR - NOTE: THIS IS CURRENTLY SET
;	***TO ODT'S OUTPUT ROUTINE
;
;
CVRT:	CALL	ZCHK	;CHECK FOR NEW ZERO
	JNZ	NNZRO	;NOT ZERO
	INR	C	;IT WAS, OFFSET C BY 2
	INR	C
	MOV	L,C
	CALL	WZER	;WRITE ZERO
	INR	L	;PNT TO DECIMAL EXPONENT
	INR	L
	INR	L
	INR	L
	XRA	A	;SET IT TO ZERO
	MOV	M,A
	JMP	MDSKP	;OUTPUT IT
NNZRO:	MOV	D,M	;/GET THE NUMBER TO CONVERT
	INR	L
	MOV	B,M
	INR	L
	MOV	E,M
	INR	L	;/4 WORD***TP
			; END OF PAGE 54
	
	
	MOV	A,M	;/***TP
	INR	C	;OFFSET SCRATCH POINTER BY 2
	INR	C
	MOV	L,C	;/L NOT NEEDED ANY MORE
	MOV	M,D	;/SAVE NUMBER IN SCRATCH
	INR	L
	MOV	M,B
	INR	L
	MOV	M,E	;/***TP
	INR	L	;/***TP
	MOV	B,A	;/SAVE COPY OF CHAR & SIGN
	ANI	117O	;GET ONLY CHAR.
	MOV	M,A	;/SAVE ABS(NUMBER)
	CPI	100O	;CK FOR ZERO
	JZ	NZRO
	SUI	1	;/GET SIGN OF DEC. EXP
	ANI	100O	;/GET SIGN OF CHAR.
NZRO:	RLC		;MOVE IT TO SIGN POSITION
	INR	L	;/MOVE TO DECIMAL EXP.
	MOV	M,A	;/SAVE SIGN OF EXP.
	MOV	A,B	;/GET MANT. S!GH BACK
	CALL	SIGN	;OUTPUT SIGN
	MVI	L,(TEN5 & 377O)	;/TRY MULT. OR DIV. BY 100000 FIRST
	CALL	COPT	;/MAKT A COPY IN RAM
TST8:	CALL	GCHR	;/GET CHAR. OF NUMBER
	MOV	B,A	;/SAVE A COPY
	ANI	100O	;/GET ABSOLUTE VALUE DR VAR
	MOV	A,B	;/INCASE PLUS
	JZ	GOTV	;/ALREADY PLUS
	MVI	A,200O	;/MAKE MINUS INTO PLUS
	SUB	B	;/PLUS=200B-CHAR
GOTV:	CPI	22O	;/TEST FOR USE OF 100000
	JM	TRY1	;/WONT GO
	CALL	MORD	;/W!LL GO SO DO IT
	ADI	5	;/INCRENENT DEC. EXPONENT BY 5
	MOV	M,A	;/UPDATE MEM
	JMP	TST8	;/GO TRY AGAIN
TRY1:	MVI	L,(TEN & 377O)	;NOW USE JUST TEN
	CALL	COPT	;/PUT 17 IN RAM
TST1:	CALL	GCHR	;/GET CHARACTERISTIC
	CPI	1	;/MUST GET IN RANGE I TO 5
	JP	OK1	;/ATLEAST ITS 1 OR BIGGER
MDGN:	CALL	MORD	;/MUST MUL OF DIV BY 10
	ADI	1	;/ITICREN.ENT DECIMAL EXP.
	MOV	M,A	;/UPDARE MEM
	JMP	TST1	;/NOW TRY AGAIN
OK1:	CPI	7	;/TEST FOR LESS THAN 7
	JP	MDGN	;/NCPE - 7 OR GREATER
MDSKP:	MOV	L,C	;/SET UP DIGIT COUNT
	DCR	L
	DCR	L	;/IN 1ST WORD OF SCRATCH
	MVI	M,5	;/5 DIGITS
	MOV	E,A	;/SAVE CHAR. AS LEFT SHIFT COUNT
	CALL	LSFT	;/SHIFT LEFT PROPER NUMBER
	CPI	12O	;/TEST FOR 2 DIGITS HERE
	JP	TWOD	;/JM? IF 2 DIGITS TO OUIPUT
	CALL	DIGO	;/OUTPUT FIRST DIGIT
POPD:	CALL	MULTT	;/MULTIPLY THE NUMBER BY 10
INPOP:	CALL	DIGO	;/PRINT DIGIT IN A
	JNZ	POPD	;/MORE DIGITS?
	MVI	A,305O	;/NO SO PRINT E
	CALL	OUTR	;/BASIC CALL TO OUTPUT
	CALL	GETEX	;/GET DECIMAL EXP
	MOV	B,A	;/SAVE A COPY
	CALL	SIGN	;/OUTPUT SIGN
	MOV	A,B	;/GET EXP BACK
	ANI	77O	;/GET GOOD BITS
	CALL	CTWO	;/GO CONVERT 2 DIGITS
DIGO:	ADI	260O	;/MAKE A INTO ASCII
	CALL	OUTR	;/OUTPUT DIGIT
	MOV	L,C	;/GET DIGIT COUNT
	DCR	L	;/BACK UP TO DIGIT COUNT
	DCR	L
	MOV	A,M	;/TEST FOR DECIMAL PT
	CPI	5	;/PRINT . AFTER 1ST DIGIT
	MVI	A,256O	;/JUST IN CASE
	CZ	OUTR	;/OUTPUT . IF 1ST DIGIT
	MOV	D,M	;/NOW DECREMENT DIGIT COUNT
	DCR	D
	MOV	M,D	;/UPDATE MEM AND LEAVE FLOPS SET
	RET		;/SERVES AS TERM FOR DIG & CVRT
MULTT:	MVI	E,1	;/MULT. BY 10 (START WITH X2)
	CALL	LSFT	;/LEFT SHIFT 1 = X2
	MOV	L,C	;/SAVE X2 IN "RESULT"
	DCR	L	;/SET TO TOP OF NUMBER
	MOV	A,C	;/SET C TO RESULT
	ADI	11O
	MOV	C,A	;/NOW C SET RIGHT
	MOV	A,H	;/SHOW RAM TO RAM TRANSFER
	CALL	COPY	;/SAVE X2 FINALLY
	MOV	A,C	;/MUST RESET C
	SUI	11O	;/BACK TO NORMAL
	MOV	C,A	; END OF PAGE 55

	MVI	E,2	;/NOW GET (X2)X4=X8
	MOV	L,C	;/BUT MUST SAVE OVERFLOW
	DCR	L
	CALL	TLP2	;/GET X8
	MOV	L,C	;/SET UP TO CALL DADD
	MOV	A,C	;/SET B TO X2
	ADI	12O	;/TO X2
	MOV	B,A
	CALL	DADD	;/ADD TWO LOW WORDS
	DCR	L	;/BACK UP TO OVERFLOW
	MOV	A,M	;/GET IT
	MOV	L,B	;/NOW SET TO X2 OVERFLOW
	DCR	L	;/ITS AT B-1
	ADC	M	;/ADD WITH CARRY - CARRY WAS PRESERVED
	RET		;/ALL DONE RETURN OVERFLOW IN A
LSFT:	MOV	L,C	;/SET PTR POR LEFT SHIFT OF NUMBER
	DCR	L	;/BACK UP TO OVERFLOW
	XRA	A	;/OVERFLOW=0 IST TIME
TLOOP:	MOV	M,A	;/SAVE OVERFLOW
TLP2:	DCR	E	;/TEST FOR DONE
	RM		;/DONE WHEN E MINUS
	INR	L	;/MOVE TO LOW
	INR	L
	INR	L	;/***TP EXTENSION
	MOV	A,M	;SHIFT LEFT 4 BYTES
	RAL
	MOV	M,A	;/PUT BACK
	DCR	L	;/***TP - ALL DONE
	MOV	A,M	;/GET LOW
	RAL		;/SHIFT LEFT 1
	MOV	M,A	;/RESTORE IT
	DCR	L	;/BACK UP TO HIGH
	MOV	A,M	;/GET HIGH
	RAL		;/SHIFT IT LEFT WITH CARRY
	MOV	M,A	;/PUT IT BACK
	DCR	L	;/BACK UP TO OVERFLOW
	MOV	A,M	;/GET OVERFLOW
	RAL		;/SHIFT IT LEFT
	JMP	TLOOP	;/GO FOR MORE
SIGN:	ANI	200O	;/GET SIGN BIT
	MVI	A,240O	;/SPACE INSTEAD OF PLUS
	JZ	PLSV	;/TEST FOR +
	MVI	A,255O	;/NEGATIVE
PLSV:	CALL	OUTR	;/OUTPUT SIGN
	RET
GCHR:	MOV	L,C	;/GET CHARCTERISTIC
GETA:	INR	L	;/MOVE TO IT
	INR	L
	INR	L	;/***TP
	MOV	A,M	;/FETCH INTO A
	RET		;/DONE
MORD:	CALL	GETEX	;/MVL OR DIV DEPENDING ON EXP
	MOV	E,A	;/SAVE DECIMAL EXP
	MOV	B,L	;/SET UP TO MVLT OR DIV
	INR	B	;/NOW BOP POINTER SET
	MOV	L,C	;/L POINTS TO NUMBER TO CONVERT
	MOV	A,C	;/POINT C AT ''RESULT" AREA
	ADI	11O	;/IN SCRATCH
	MOV	C,A	;/NOW C SET RIGHT
	MOV	A,E	;/NOW TEST FOR MUL
	ANI	200O	;/TEST MEGATIVE DEC. EXP.
	JZ	DIVIT	;/IF EXP IS + THEN DIVIDE
	CALL	LMUL	;/MULT.
FINUP:	MOV	A,C	;/SAVE LMO. OF RESULT
	MOV	C,L	;/C=LOC OF NUMBER (IT WAS DESTROYED)
	MOV	L,A	;/SET L TO LOC. OF RESUTL
	MOV	A,H	;/SHOW RAM TO RAM TRANSFER
	CALL	COPY	;MOVE RESULT TO NUMBER
GETEX:	MOV	L,C	;/NOVI GET DECIMAL EXP
	INR	L
	JMP	GETA	;USE PART OF GCHR
DIVIT:	CALL	LDIV	;/DIVIDE
	JMP	FINUP
TWOD:	CALL	CTWO	;/CONVERT TO 2 DIGITS
	MOV	B,A	;/SAVE ONES DIGIT
	CALL	GETEX	;/GET DECIMAL EXP
	MOV	E,A	;/SAVE A COPY
	ANI	200O	;/TEST FOR MEGATIVE
	JZ	ADD1	;/BUMP EXF BY I SINCE 2 DIGITS
	DCR	E	;/DECREMENT NEGATIVE EXP SINCE 2 DIGITS
FINIT:	MOV	M,E	;/RESTORE EXP WITH NEW VALUE
	MOV	A,B	;/NOW DO 2NC DIGIT
	JMP	INPOP	;/GO OUT 2ND AND REST FO DIGITS
ADD1:	INR	E	;/COMPEN3A7E FOR 2 DIGITS
	JMP	FINIT
CTWO:	MVI	E,377O	;/CONVERT 2 DIGIT BIN TO BCD
LOOP:	INR	E	;/ADD UP TENS DIGIT
	SUI	12O	;/SUBTRACT 10
	JP	LOOP	;/TIIL NEGATIVE RESULT
	ADI	12q	;/RESTORE ONES DIGIT
	MOV	B,A	;/SAVE ONES DIGIT
	MOV	A,E	;/GET TENS DIGIT
	CALL	DIGO	;/OUTPUT IT
			; END OF PAGE 56
	
	MOV	A,B	;/SET A TO 2ND DIGIYV
	RET
COPT:	MOV	A,C	;/COPY FROM 10-N TO RAM
	ADI	5
	MOV	C,A	;/NSET C TO PLACE TO PUT
	MVI	A,(TEN5/256)
	CALL	COPY	;/COPY ET
	MOV	A,C	;/NOW RESET C
	SUI	5	;/ITS RESET
	MOV	C,A
	RET
COPY:	MOV	B,H	;/SAVE RAM H
	MOV	H,A	;/SET TO SOURCE H
	MOV	A,M	;/GET 4 WORDS INTO THE REGS.
	INR	L
	MOV	D,M
	INR	L
	MOV	E,M
	INR	L
	MOV	L,M	;/LAST ONE ERASES L
	MOV	H,B	;/SET TO DESTINATION RAM
	MOV	B,L	;/SAVE 4TH WORD IN B
	MOV	L,C	;/SET TO DESTINATION
	MOV	M,A	;/SAVE FIRST WORD
	INR	L
	MOV	A,M	;/SAVE THIS WORD IN A (INPUT SAVES C HERE
	MOV	M,D	;/NOW PUT 2ND WORD
	INR	L
	MOV	M,E
	INR	L
	MOV	M,B	;/ALL 4 COPIED NOW
	RET		;/ALL DONE
;
;
TEN5:	.DB	303O,20O,0O,21O	;/303240(8) = 100000.
TEN:	.DB	240O,0O,0O,4O	;/12(8) = 10
;
; SCRATCH MAP FOR	I/O CONVERSION ROUTINES
;
; RELATIVE TO (C+2)USE
; C-2	DIGIT COUNT
; C-1	OVERFLOW
; C	HIGH NUMBER - MANTISSA
; C+1	LOW NUMBER
; C+2	CHARACTERISTIC
; C+3	DECIMAL EXPONEXT (SIGN	MAG.)
; C+4	TEN**N
; C+5	TEN**N
; C+6 	TEN**N
; C+7	RESULT OF MULT & DIV
; C+8	AND TEMP FOR X2
; C+9	"	"
; C+10	L FOR NUMBER TO GO INTO (INPUT ONLY)
; C+11	DIGIT JUST INPUT (INPUT ONLY)
;
;	/*****BEGIN INPUT*************
;
;
ERR:	STC		;ERROR FLAG
	RET		;AND RETURN
	
;
;
;**************************************************************	
;	//// 4 1/2 DIGIT INPUT ROUTINE
;**************************************************************	
;
;	/L POINTS TO WHERE TO PUT INPUT NUMBER
;	/C POINTS TO 13(10) WORDS OF SCRATCH
;
INPUT:
	MOV	B,L	;/SAVE ADDRESS WHERE DATA IS TO GO
	MOV	A,C	;/IN SCRATCH
	ADI	17O	;/COMPUTE LOC. IN SCRATCH
	MOV	L,A
	MOV	M,B	;/PUT IT
	INR	C	;/OFFSET SCRATCH POINTER
	INR	C	;/BY 2
	CALL	ZROIT	;/ZERO NUMBER
	INR	L	;/AND ZERO
	MOV	M,A	;/DECIMAL EXPONENT
	CALL	GNUM	;/GET INTEGER PART OF NUM
	CPI	376O	;/TERM=.?
	JZ	DECPT	;/YES
TSTEX:	CPI	25O	;/TEST FOR E
	JZ 	INEXP	;/YES - HANDLE EXP
	CPI	360O	;/TEST FOR SPACE TERM (240B-260B)
	JNZ	ERR	;/NOT LEGAL TERM
	CALL	FLTSGN	;/FLOAT # AND SIGN IT
SCALE:	CALL	GETEX	;/GET DECIMAL EXP
	ANI	177O	;/GET GOOD BITS
	MOV	E,A	;/SAVE COPY
	ANI	100O	;/GET SIGN OF EXP
	RLC		;/INTO SIGN BIT
			; END OF PAGE 57
	
	ORA	A	;/SET FLOPS
	MOV	B,A	;/SAVE SIGN
	MOV	A,E	;/GET EXP BACK
	JZ	APLS	;/JMP IS +
	MVI	A,200O	;/MAKE MINUS +
	SUB	E	;/NOW ITS +
APLS:	ADD	B	;/SIGN NUMBER
	MOV	M,A	;/SAVE EXP (SIGN & MAG.)
	MVI	L,(TEN5 & 377O) ;/TRY MORD WITH 10-5 FIRST
	CALL	COPT	;/TRAN3FER TO RAM
	CALL	GETEX	;/GET+DECIMAL EXP
INT5:	ANI	77O	;/GET MAG. OF EXP
	CPI	5O	;/TEST FOR USE OF 10**5
	JM	TRYTN	;/WONT GO - TRY 10
	CALL	MORD	;/WILL GO SO DO IT
	SUI	5O	;/MAG = MAG -5
	MOV	M,A	;/UPDATE DEC. EXP IN MEM
	JMP	INT5	;/GO TRY AGAIN
TRYTN:	MVI 	L,(TEN & 377O)	;/PUT TEN IN RAM
	CALL	COPT
	CALL	GETEX	;/SET UP FOR LOOP
INT1:	ANI 	77O	;/GET MAGNITUDE
	ORA	A	;/TEST FOR 0
	JZ	SAVEN	;/DONE, MOVE NUM OUT AND GET OUT
	CALL	MORD	;/NOT DONE - DO 10
	SUI	1O	;/EXP = EXP -1
	MOV	M,A	;/UPDATE MEM
	JMP	INT1	;/TRY AGAIN
DECPT:	MOV	L,C	;/ZERO DIGIT COUNT
	DCR	L	;/SINCE ITS NECESSARY
	DCR	L	;/TO COMPUTE EXP.
	MVI	M,0	;/ZEROED
	CALL	EP1	;/GNUM IN MIDDLE
	MOV	E,A	;/SAVE TERMINATOR
	MOV	L,C	;/MOVE DIGIT COUNT TO EXP
	DCR	L	;/BACK UP TO DIGIT COUNT
	DCR	L
	MOV	B,M	;/GOT DIGIT COUNT
	CALL	GETEX	;/SET L TO DEC. EXF
	MOV	M,B	;/PUT EXP
	MOV	A,E	;/TERM BACK TO A
	JMP	TSTEX	;/TEST FOR E+OR-XX
INEXP:	CALL	FLTSGN	;/FLOAT AND SIGN NUMBER
	CALL	SAVEN	;/SAVE NUMBER IN (L) TEMP
	CALL	ZROIT	;/ZERO OUT NUM. FOR INPUTTING EXP
	CALL	GNUM	;/NOW INPUT EXPONENT
	CPI	360O	;/TEST FOR SAPCE TERM
	JNZ	ERR	;/NOT LEGAL - TRY AN N
	MOV	L,C	;/GET EXP OUT OF MEM
	INR	L	;/***TP
	INR	L	;/EXP LIMITED TO 5 BITS
	MOV	A,M	;/GET LOWEST 8 BITS
	ANI	37O	;/GET GOOD BITS
	MOV	B,A	;/SAVE THEM
	INR	L	;/GET SIGN OF EXP
	MOV	A,M	;/INTO A
	ORA	A	;/SET FLOPS
	MOV	A,B	;/INCASE NOTHING TO DO
	JM	USEIT	;/IF NEG. USE AS +
	MVI	A,0O	;/IF + MAKE -
	SUB	A	;/0-X = -X
USEIT:	INR	L	;/POINT AT EXP
	ADD	M	;/GET REAL DEC. EXP
	MOV	M,A	;/PUT IN MEM
	MOV	A,C	;/NOW GET NUMBER BACK
	ADI	15O	;/GET ADD OF L
	MOV	L,A	;/L POINTS TO L OF NUMBER
	MOV	L,M	;/NOW L POINTS TO NUMBER
	CALL	COPY	;/RAM TO RAM COPY
			;/COPY IT BACK
	JMP	SCALE	;/NOW ADIUST FOR EXP
GNUM:	CALL	INP	;/GET A CHAR
	CPI	240O	;/IGNORE LEADING SPACES
	JZ	GNUM
	CPI	255O	;/TEST FOR
	JNZ	TRYP	;/NOT MINUS
	MOV	L,C	;/MINUS SO SET SIGN
	INR	L	;/IN CHAR LOC.
	INR	L	;/***TP
	INR	L
	MVI	M,200O	;/SET - SIGN
	JMP	GNUM
TRYP:	CPI	253O	;/IGNORE +
	JZ	GNUM
TSTN:	SUI	260O	;/STRIP ASCII
	RM		;/RETURN IF TERM
	CPI	12O	;/TEST FOR NUMBER
	RP		;/ILLEGAL
	MOV	E,A	;/SAVE DIGIT
	CALL	GETN	;/LOC. OF DIGIT STORAGE TO L
	MOV	M,E	;/SAVE DIGIT
	CALL	MULTT	;/MULT NUMBER BY 10
	ORA	A	;/TEST FOR TOO MANY DIGITS
			; END OF PAGE 58
	
	RNZ		;/TOO MANY DIGITS
	CALL GETN	;/GET DIGIT
	MOV L,C	;/SET L TO NUMBER
	INR	L
	INR	L	;/***TP
	ADD	M	;/ADD IN THE DIGIT
	MOV	M,A	;/PUT RESULT BACK
	DCR	L	;/OW DO HIGH
	MOV	A,M 	;/GET HIGH TO ADD IN CARRY
	ACI	0O	;/ADD IN CARRY
	MOV	M,A	;/UPDATE HIGH
	DCR	L	;/***TP EXTENSION
	MOV	A,M
	ACI	0O	;/ADD IN CARRY
	MOV	M,A	;/***TP ALL DONE
	RC		;/OVERFLOW ERROR
	DCR	L	;/BUMP DIGIT COUNT NOW
	DCR	L
	MOV 	B,M	;/GET DIGIT COUNT
	INR	B	;/BUMP DIGIT COUNT
	MOV	M,B	;/UPDATE DIGIT COUNT
EP1:	CALL	INP	;/GET NEXT CHAR
	JMP	TSTN	;/MUST BE NUM. OR TERM
FLTSGN:	MOV	L,C	;POINT L AT NUMBER TO FLOAT
	JMP	FLOAT	;GO FLOAT IT
SAVEN:	MOV	A,C 	;/NUMBER IN W
	ADI	15O	;/GET ADD OF L
	MOV	L,A
	MOV	E,M	;/GET L OF RESULT
	MOV	L,E	;/POINT L AT (L)
	INR	L	;/SET TO 2ND WORD TO SAVE C
	MOV	M,C	;/SAVE C IN (L) +1 SINCE IT WILL BE DES'D
	MOV	L,C	;/SET UP TO CALL COPY 
	MOV	C,E	;/NOW L&C SET
	MOV	A,H	;/RAM TO RAM COPY
	CALL	COPY	;/COPY TO L
	MOV	C,A	;/(L)+1 RETURNED HERE SO SET AS C
	ORA	A	;MAKE SURE CY=0 (NO ERROR)
	RET		;/NOW EVERYTHING HUNKY-DORRY
GETN:	MOV	A,C	;/GET DIGIT
	ADI	160	;/LAST LOC. IN SCRATCH
	MOV	L,A	;/PUT IN L
	MOV	A,M	;/GET DIGIT
	RET
ZROIT:	MOV	L,C	;/ZERO NUMBER
	XRA	A
	MOV	M,A	;/***TP
	INR	L	;/***TP
	MOV	M,A
	INR	L
	MOV	M,A
	INR	L	;/NOW SET SIGN TO +
	MOV	M,A
	RET		;/DONE
READ	.EQU	333O	;ODT READ ROUTINE

;CONTAIN LOW BYTE OF TWO BYTE VALUE. RETURNS CY=1 IF
;BC>DE, CY=0 IF BC<DE: Z=1 IF BC=DE.
COMP:	MOV	A,E
	CMP	C
	RNZ	
	MOV	A,D
	CMP	A
	RET

;ROUTINE TO INPUT CHAR FROM TTY
CHAR2:
	PUSH	B
	CALL	READ	;INPUT FROM ODT
	MOV	A,B	;GET CHAR TO A REG.
	POP	B	;RESTORE B,C
	RET

;ROUTINE TO ADJUST VALUES OF BIN FORWARD PNT. AND
;LINE LENGTH OF SOURCE LINE. PASSED ADD OF TEMP VARIABLE
;CONTAINING ADD OF SOURCE LINE.
PTVAL:
	PUSH	PSW
	PUSH	D
	PUSH	H
	MVI	A,002
	MOV	E,M
	INR	L
	MOV	D,M
	INR	L
	PUSH 	D
N1:	XTHL
	MOV	E,M
	INX	H
	MOV	D,M
	INX	H
	XTHL
	MOV	M,E
	INR	L
	MOV	M,D
	INR	L
	DCR	A
	JNZ	N1	; END OF PAGE 59
	XTHL
	MOV	D,M
	POP	H
	MOV	M,D
	POP	H
	POP	D
	POP	PSW
	RET

;ROUTINE TO CHK FLAGS ON INPUT AND OUTPUT.
;PASSED FLAG VALUE IN REG B.
MCHK:
	PUSH	PSW
MCHK1:	IN	3
	ANA	B
	JZ	MCHK1
	POP	PSW
	RET

;MULTIPLICATION ROUTINE (ADD. VALUES)
MULT:
	MOV	E,M
	DCX	H
	MOV	D, M
	MVI	M,11H
	MVI	B,0
	MOV	C,B
TOP:	MOV	A,E
	RAR
	MOV	E,A
	MOV	A,D
	RAR
	DCR	M
	MOV	D,A
	RZ
	JNC	SHIFT
	DCX	H
	DCX	H
	MOV	A,B
	ADD	M
	MOV	B,A
	INX	H
	MOV	A,C
	ADC	M
	MOV	C,A
	INX	H
SHIFT:	MOV	A,C
	RAR
	MOV	C,A
	MOV	A,B
	RAR
	MOV	B,A
	JMP 	TOP

;LINKAGES TO FLOATING POINT ROUTINES
	.ORG	7707O
	JMP	NORM
	JMP	FLOAT
	JMP	WZER
	JMP	LADD
	JMP	LMUL
	JMP	LDIV
	JMP	LSUB
	JMP	DFXL
	JMP	LMCM
	JMP	COPY
	JMP	CVRT
	JMP	INPUT
	JMP	MULT
	JMP	PTVAL
	JMP	DCOMP
	JMP	MCHK
	JMP	CHAR2
	JMP	INL
	JMP	OUTL

.END


	
