;
;
; BAS80 - BASIC INTERPRETER FOR INTEL 8080 MICRO-PROCESSOR
;
; VERSION 1.2	3/07/78	CHANGES FROM IDAHO
; VERSION 1.3	4/20/78	CHANGES FROM IDAHO
; VERSION 1.4	5/09/78	CORRECT BUG IN 'CALLP'
; VERSION 1.5	5/25/78	CORRECT BUGS IN 'FORMT'
; 1. NEGATIVE NUMBERS NOT ROUNDED PROPERLY
; 2. SMALL NEGATIVE NUMBERS PRINTED AS POSITIVE
;
; WRITTEN AT THE UNIVERSITY OF IDAHO BY:
; JOHN W. DICKINSON, JOHN A. TEETER, AND KAREN VAN HOUTEN
; DEPT. OF ELECTRICAL ENGINEERING
; UNIVERSITY OF IDAHO
; MOSCOW, IDAHO
;
; GERALD R. BARBER
; DEPT. OF ELECTRICAL ENGINEERING AND COMPUTER SCIENCE
; MASSACHUSETTES INSTITUTE OF TECHNOLOGY
; CAMBRIDGE, MASSACHUTTES
;
;
; DEFINE ADDRESSES OF I/O,USER-SUBS, AND STACK POINTER TABLE
STAACK	EQU	800H
USUB	EQU	802H
CMDIN	EQU	804H
MSGO	EQU	807H
PROGI	EQU	80AH
PROGO	EQU	80DH
PROM	EQU	810H
;
;
; DEFINE ADDRESSES OF ACTIVE VARIABLES
MEMST	EQU	1000H	;MUST BE ON PAGE BOUNDARY
LENST	EQU	10	;LENGTH OF STRINGS
OBUFF	EQU	MEMST	;INPUT AND OUTPUT BUFFERS OCCUPY
STLINE	EQU	MEMST+111Q	;FIRST LINE OF USER PROGRAM
NLINE	EQU	MEMST+113Q	;POINTER TO NEW LINE OF USER TEXT
NL2	EQU	MEMST+115Q	;BINARY VALUE OF NEW LINE NUMBER
NL4	EQU	MEMST+117Q	;FORWARD POINTER OF NEW LINE
NL6	EQU	MEMST+121Q	;LENGTH OF NEW LINE
KLINE	EQU	MEMST+122Q	;POINTER TO CURRENT LINE--LINE INSERTI
KL2	EQU	MEMST+124Q	;BINARY EQU. OF CURRENT LINE NUMBER
KL4	EQU	MEMST+126Q	;FORWARD POINTER OF CURRENT LINE
KL6	EQU	MEMST+130Q	;LENGTH OF NEW LINE
PLINE	EQU	MEMST+131Q	;PREVIOUS LINE POINTER--LINE INSERTION
PL2	EQU	MEMST+133Q	;BINARY LINE NUMBER OF PREVIOUS LINE
PL4	EQU	MEMST+135Q	;FORWARD POINTER OF PREVIOUS LINE
SBSAV	EQU	PL4	;RETURN ADD. SAVE FOR CALL STMT.
PL6	EQU	MEMST+137Q	;LENGTH OF PREVIOUS LINE
KASE	EQU	MEMST+140Q	;SPARE STORAGE USED AS NEEDED
LEN	EQU	MEMST+141Q	;ALSO SPARE-OFTEN LENGTH VARIABLE
MULT1	EQU	MEMST+142Q	;FIRST OF TWO WORDS USED FOR MULT.
MULT2	EQU	MEMST+144Q	;SECOND WORD
LPNT	EQU	KLINE	;SOURCE LINE PTR DURING EXEC.
KLEN	EQU	KL6	;SPARE-USED AS NEEDED
CPNT	EQU	PL2	;CHAR. PTR DURING EXEC.
KFPNT	EQU	KL4	;FWD LINE PTR DURING EXEC.
FREG2	EQU	MEMST+200Q	;FLOATING POINT REG. #2
CREG	EQU	MEMST+204Q	;TEMP. SPACE FOR ROUTINE 'INP'
HLINP	EQU	MEMST+206Q	;TEMP. SPACE FOR ROUTINE 'INP'
GREG	EQU	MEMST+167Q	;GENERAL PURPOSE REGISTER
FREG1	EQU	MEMST+174Q	;FLOATING PNT. REGISTER #1
SCR	EQU	MEMST+146Q	;SCRATCH AREA FOR I/O ROUTINES
MODE	EQU	MEMST+205Q	;MODE FLAG FOR ROUTINE 'INP'
MESCR	EQU	MEMST+210Q	;DEFINE MEMORY SCR AREA PNTR
VARAD	EQU	MEMST+212Q	;TEMP SPACE FOR INP. STMT.
VNAME	EQU	MEMST+214Q	;TEMP SPACE FOR 'FOR-NEXT'
VLOC	EQU	MEMST+216Q	;TEMP SPACE FOR 'FOR-NEXT'
FLIMT	EQU	MEMST+220Q	;TEMP SPACE FOR 'FOR-NEXT'
NEST	EQU	MEMST+224Q	;NESTING STACK-POINTER
STAC	EQU	MEMST+226Q	;FOR-NEXT NESTING STACK
STSIZ	SET	20	;STACK SIZE, ALLOWS 10 NESTED FOR-NEXT
TOPNS	EQU	STAC	;TOP OF STACK
BOTNS	EQU	STAC+STSIZ	;BOTTOM OF STACK
VTYPE	EQU	VARAD	;TEMP SPACE FOR EVAL TYPE
SREG1	EQU	BOTNS	;TEMP STORE FOR STRINGS
SREG2	EQU	SREG1+LENST+1	;TEMP STORE FOR STRINGS
IPVAR	EQU	SREG2+LENST+1	;INPUT-PROCEED VAR ADDR
IPVPT	EQU	IPVAR+2	;INPUT-PROCEED VAR LIST ADDR
IPVLN	EQU	IPVPT+2	;INPUT-PROCEED VAR LIST LEN
IOFLAG	EQU	IPVLN+1	;THE I/O IN PROGRESS FLAG
PPVAR	EQU	IOFLAG+1	;PRINT-PROCEED VAR ADRR
IBUF	EQU	PPVAR+2	;INPUT BUFFER
CPOS	EQU	IBUF+73	;CURRENT POITION OF PRINT BUFF
AM9511	EQU	CPOS+1	;AMD STACK
FREG	EQU	AM9511+16	;TEMP FOR POWER ROUTINE
STSPAC	EQU	FREG+4	;START OF SYM. TABLE
NXTSP	EQU	NLINE	;POINTER TO NEXT AVAILABLE MEM. SPACE
GRBFLG	EQU	STSPAC+2	;GARB. COLL. FLAG 0=YES	1=NO
EXPSGN	EQU	STSPAC+3
PWRTEN	EQU	STSPAC+4
SGNMANT	EQU	STSPAC+5
EXPVAL	EQU	STSPAC+6
DIGKNT	EQU	STSPAC+7
DECFLAG	EQU	STSPAC+8
VEND	EQU	STSPAC+9	;DEF. END OF VAR. STORAGE AREA

	ORG	8000H

	JMP	M1
	JMP	M1A
	JMP	PROMR
;
;
;
; MAIN ROUTINE--HANDLES ALL USER INPUT
;
;
M1:	LXI	H,OBUFF	;INITIALIXE THE OUTPUT BUFFER
	MVI	M,1	;TO HAVE LENGTH ONE.
	LXI	H,0FFFFH	;ST STLINE TO -1, NO SOURCE
	SHLD	STLINE
	SHLD	STSPAC
	LXI	H,VEND	;GET ADDRES OF FWA MEM.
	SHLD	NLINE	;STORE IN FREE SPACE PNTR.
M1A:	LHLD	STAACK	;SET STACK TO HEIGHT OF MEMORY
	SPHL
	LXI	H,GRBFLG	;TURN GARB. COLL. FLAG ON
	MVI	M,0
M2:	LXI	H,LPNT
	CALL	NEG1
	XRA	A
	STA	IOFLAG	;IOFLAG=NOTHING HAPPENING
	LXI	H,ODAT1
	CALL	FORM	;PAD "READY"
	CALL	WRIT
M3:	LHLD	NLINE	;GET NEXT LINE FOR ACCEPTING NEW DATA
	MVI	A,4	;MOVE PAST POINTERS
	CALL	DADHL
	CALL	TTYIN	;GET INPUT LINE.
	CPI	0	;WAS ANYTHING INPUT?
	JZ	M3	;NO--TRY AGAIN
	CALL	PACK	;REMOVE THE BLANKS
	JC	M4	;LINE INPUT- GO INSERT IT
	INX	H	;COMMAND OR KEYWRD. GET TOKEN
	MOV	A,M
	RAL
	JC	COMND	;A COMMAND--GO PROCESS
	RAR	;A KEY WORD--GO PROCESS
	JMP	IMEDAT
COMND:	RAR
	CMA	;RE-ESTABLISH COMMAND TOKEN
	LXI	H,M1A	;SET UP RETURN ADDR.
	PUSH	H
	LXI	H,CTABL
	ADD	A
	CALL	DADHL	;GET PROPER JUMP ADDR.
	MOV	E,M
	INX	H
	MOV	D,M
	XCHG
	XRA	A	;SET A=0 FOR LIST CMMD
	PCHL
;
;
M4:	CALL	INSERT	;GO INSERT THE LINE
	JMP	M3	;GO GET NEXT LINE
;
IMEDAT:	DCX	H	;POINT TO FIRST LENGTH
	PUSH	H
	MOV	A,M
	INX	H
	CALL	DADHL
	SHLD	NLINE
	SHLD	NXTSP	;UPDATE SYM. TAB POINTER
	POP	H
	MVI	D,0FFH	;SET -1 IN DE
	MOV	E,D
	CALL	IMMED	;GO EXECUTE IMMEDIATE
	JMP	M2
;
CTABL:	DW	RUN
	DW	TAPE
	DW	LIST
	DW	M1
	DW	PTAPE
	DW	UGARB
;
;
; ROUTINE TO INPUT FROM HSR
; THIS CONDITION IS DEFAULT NOW
;
PTAPE:	LHLD	NLINE
	MVI	A,4
	CALL	DADHL
PT1:	CALL	CHAR5	;GET CHAR. FROM READER
	CPI	0	;IS IT LEADER?
	JZ	PT1	;YEP -- WAIT FOR GOOD INFO
PT2:	CALL	HSRIN	;GOT CHAR.
	MOV	C,A
	CPI	0	;IS CHAR COUNT = 0?
	JZ	PT1	;YEP-- KEEP WAITING
	MOV	M,B	; STORE LENGTH OF STATEMENT
	CALL	PACK	;GO PACK LINE AND DECIPHER
	RNC	;NOT SOURCE LINE. GO TO READY
	CALL	INSERT	;NOPE--SO GO INSERT IT
PT3:	CALL	CHAR5	;GET NEXT CHAR.
	CPI	0AH	;LINE-FEED?
	JZ	PT3	;IGNORE
	CPI	0	;IS IT LEADER?
	RZ
	PUSH	PSW	;SAVE CHAR
	LHLD	NLINE
	MVI	A,4	;MOVE PAST POINTERS OF NEXT LINE
	CALL	DADHL
	POP	PSW
	JMP	PT2	;LOOP ON PROCESS
;
; ROUTINE TO HANDLE ALL SOURCE LINE INPUT.
; THIS INCLUDES INSERTION, DELEATION, AND
; ADDITION OF NEW SOURCE LINES.
;
INSERT:	LXI	H,NLINE
	CALL	PTVAL	;FIND THE POINTER VALUES
	LHLD	STLINE	;GET START OF SOURCE
	CALL	CHK1	;CHECK FOR NO TEXT
	JNC	ISRT3	;THERE IS SOMETHING-START SERCH
	LHLD	NLINE	;THIS IS FIRST LINE
	SHLD	STLINE	;MOVE NLINE TO STLINE
ISRT1:	MVI	D,377Q	;SET UP -1 FOR END OF LIST
	MOV	E,D
	CALL	STPNT	;STORE IT AWAY IN POINTERS
	INX	H
ISRT2:	MOV	A,M	;GETLINE LENGTH
	ADI	5	;ADJUST TO LEN+5
	LHLD	NLINE
	ADD	L
	MOV	L,A
	MVI	A,0
	ADC	H
	MOV	H,A
	SHLD	NLINE	;STEP PAST NEW LINE
	SHLD	NXTSP	;UPDATE SYB. TAB PNTR.
	RET
ISRT3:	SHLD	KLINE	;SET UP CURRENT LINE
ISRT4:	LXI	H,KLINE	;GET CURRENT LINE AND
	CALL	PTVAL	;SET UP POINTERS
	LXI	H,NL2	;GET BINARY VALUE
	MOV	D,M	;OF NEW LINE
	INX	H
	MOV	E,M
	LXI	H,KL2	;GET CURRENT LINE BINARY
	MOV	B,M
	INX	H
	MOV	C,M
	CALL	DCOMP	;HOW DO THEY COMPARE?
	JZ	ISRT6	;REPLACE/DELETE
	JC	ISR12	;KLINE>NLINE
	LHLD	KL4	;MOVE ON TO NEXT LINE
	CALL	CHK1	;ARE WE DONE?
	JC	ISRT5
	PUSH	H
	LHLD	KLINE
	SHLD	PLINE	;SET UP PREVIOUS LINE
	LXI	H,PLINE
	CALL	PTVAL	;SET POINTERS
	POP	H
	SHLD	KLINE	;SET UP CURRENT LINE
	JMP	ISRT4	;LOOP ON PROCESS
ISRT5:	LHLD	NLINE	;GET NLINE ADDRESS
	CALL	NOLINE	;IS IT 0 LEN. LINE?
	RZ	;YES-DO NOTHING
	XCHG
	LHLD	KLINE	;GET CURRENT LINE
	CALL	STPNT	;STORE AWAY POINTERS
	XCHG
	JMP	ISRT1	;GO SET END OF LIST
ISRT6:	LHLD	KLINE	;GET MATCHED ADDR.
	CALL	SBIT8	;SET DELETION BIT
	LHLD	NLINE	;DO DELETE OR REPLACE
	CALL	NOLINE	;NOLINE MEANS DELETE
	JNZ	ISRT8	;GO REPLACE IF NOT 0
	LHLD	STLINE	;GET STLINE
	XCHG
	LHLD	KLINE	;IF STLINE=KLINE THEN LIST
	PUSH	H	;NOW ZERO
	POP	B
	CALL	DCOMP
	LHLD	KL4
	JZ	ISRT7	;IF NOT STLINE THEN GO DELETE
	XCHG
	LHLD	PLINE
	CALL	STPNT
	RET
ISRT7:	SHLD	STLINE
	RET
ISRT8:	LHLD	KL4	;REPLACE LINE
	XCHG
	LHLD	NLINE
	CALL	STPNT
ISRT9:	LHLD	KLINE
	XCHG
	LHLD	STLINE
	PUSH	H
	POP	B
	CALL	DCOMP
	JZ	ISR11	;IF KLINE =STLINE GOTO ISR11
	LHLD	NLINE
	XCHG
	LHLD	PLINE
	CALL	STPNT	;PREVIOUS LINE PNTS. TO NLINE
ISR10:	LXI	H,NL6	;SET UP NEW LINE TO
	JMP	ISRT2	;POINT TO M(KL4)
ISR11:	LHLD	NLINE	;NLINE=STLINE
	SHLD	STLINE
	JMP	ISR10
ISR12:	LHLD	KLINE	;NLINE IN FRONT OF KLINE
	XCHG
	LHLD	NLINE
	CALL	NOLINE
	RZ
	CALL	STPNT
	JMP	ISRT9
;
;
; ROUTINE SBIT8 SETS THE EIGTH BIT OF BYTE 2 TO INDICATE THE
; LINE HAS BEEN DELETED.
SBIT8:	PUSH	H
	INX	H
	MVI	A,0FFH
	MOV	M,A
	POP	H
	RET
;
;
; ROUTINE NEG1 IS USED TO SET	HL _ -1, HL+1 _ -1 .
; THAT IS TO TERMINATE THE SOURCE LISTS.
NEG1:	MVI	A,0FFH
	MOV	M,A
	INX	H
	MOV	M,A
	RET
;
;
; ROUTINE TO STORE POINTERS INTO MEM ARRAY
; HL CONTAIN ADDR. OF FIRST WORD OF ENTRY.
; THE CORESPONDING ELEMENTS (HL2,HL4,HL6) CONTAIN
; THE NEW ENTRIES.
STPNT:	INX	H
	INX	H
	MOV	M,E	;MOVE HL2/NL2/PL2 INTO MEM'HL)
	INX	H
	MOV	M,D
	RET
;
; ROUTINE TO CHECK NEW LINE FOR SOURCE STMT.
NOLINE:	PUSH	H
	MVI	A,4	;MOVE PAST POINTERS
	CALL	DADHL
	MOV	A,M	;GET LENGTH OF LINE IN A
	CPI	0	;IS ANYTHING THERE?
	POP	H
	RET
;
;
; ROUTINE TO RESPOND WITH 'WHAT?' FOR UNIDENTIFIED COMMAND.
WHAT:	LXI	H,ODAT5	;GET OUTPUT BUFFER ADDR.
	CALL	FORM	;PAD IT
	CALL	WRIT	;DUMP IT
	JMP	M1A	;JUMP TO RESTART.
;
; ROUTINE TO PUNCH PAPER TAPE OF SOURCE.
; CALLED IN RESPONSE TO TAPE COMMAND
TAPE:	PUSH	PSW
	PUSH	B
	LXI	H,ODAT2	;GET OUTPUT BUFFER ADDR.
	CALL	FORM	;PAD IN TURN ON PUNCH
	CALL	WRIT	;DUMP IT
	MVI	A,0	;SET UP TO CUMP LEADER
	POP	B
	MVI	B,100Q
	PUSH	PSW
	PUSH	B
	CALL	PAD	;PAD 100 0'S
	CALL	PWRIT
	POP	B
	PUSH	B
	MVI	A,1	;TO INDICATE PUNCH OUTPUT
	CALL	LIST	;GO DO STANDARD LIST
	POP	B
	POP	PSW
	CALL	PAD	;GO PAD AND DUMP TRAILER.
	CALL	PWRIT
	POP	PSW
	RET
;
; ROUTINE TO LIST TO TTY THE SOURCE STMTS.
; ALSO USED TO DUMP TAPE.
; ALLOWS THE USER TO INPUT FIRST LINE OR
; OR FIRST AND LAST LINES.
; A=0 MEANS LIST TO TTY, A=1 MEANS PUNCH OUTPUT
LIST:	PUSH	PSW	;SAVE DESTINATION FLAG
	LHLD	STLINE
	CALL	CHK1	;CHECK FOR NO SOURCE
	JC	M1A	;GO RESTART
	SHLD	PLINE	;SET UP TO START LOOKING FOR FIRST LIN
	LXI	H,0FFFFH
	SHLD	KLINE
	LHLD	NLINE	;CHECK FOR LINE LENGTH
	MVI	A,4
	CALL	DADHL
	MOV	C,M
	INR	C
	CALL	BUMP	;MOVE TO START OF NUMBER
	CNZ	BOUND	;GO FIND FIRST LINE
	LHLD	PLINE	;STORE IT AWAY
LIS1:	CALL	DNUMB	;CALL FLOATING POINTS ROUTINES
	INX	H
	MOV	C,M
	INX	H	;GET FORWARD PTR IN REG BC
	MOV	B,M
	PUSH	B	;SAVE FPTR
	INX	H
	MOV	C,M
	INX	H
	MOV	A,M	;GET FIRST CHARACTER
	RAL	;CHECK FOR IMBEDDED BLANKS
	JNC	LIS2
	RAR
	CMA	;SET FOR POSSITIVE # OF BLANKS
	MOV	B,A	;GET READY TO PAD
	MVI	A,' '
	CALL	PAD	;PAD THE BLANKS
	DCR	C
	INX	H	;MOVE TO NEXT CHARACTER-KEY TOKEN
LIS2:	MOV	A,M	;GET KEYWORD TOKEN
	PUSH	H
	PUSH	B
	LXI	H,KPAD	;GET ADDR. OF KW STRINGS
	ADD	A	;MULT. BY 2
	CALL	DADHL	;POINT TO RIGHT ONE
	MOV	E,M	;GET LOW ADDR
	INX	H
	MOV	D,M	;GET HIGH ADDR
	XCHG
	MOV	C,M	;GET STRING LENGTH
	INX	H
	CALL	FORM6	;PADD IT
	POP	B
	POP	H
	INX	H
	DCR	C	;CHECK FOR END OF LINE
	JZ	LIS4
	CALL	FORM6	;PADD REST OF LINE
LIS4:	POP	B	;GET FPTR
	POP	PSW	;GET DESTINATION FLAG
	PUSH	PSW
	ORA	A	;TEST IF LIST OR PUNCH
	JNZ	LISP	;GO PUNCH
	CALL	WRIT	;GO DUMP LINE
LIS5:	LHLD	KLINE	;CHECK FOR LAST LINE
	XCHG
	POP	H
	CALL	DCOMP
	RZ
	PUSH	H
	PUSH	B
	POP	H
	CALL	QUITT	;CHECK FOR INTERRUPTION
	JMP	LIS1	;NONE - CONTINUE
LISP:	CALL	PWRIT	;PUNCH IT
	JMP	LIS5
;
BOUND:	PUSH	H
	CALL	NUMB	;SEE IF THERE IS A NUMBER THERE
	JNC	WHAT	;IT IS NOT
	CALL	CVB	;CONVERT NUMBER TO BINARY
	PUSH	PSW
	PUSH	B
	CALL	BND2	;GO FIND FIRST LINE
	POP	B
	DCX	H
	SHLD	PLINE	;STORE IT WAY AS FIRST LINE
	POP	PSW
	POP	H
	CALL	DADHL
	MVI	A,0
	CMP	C	;IS THAT END OF LINE?
	RZ
	CALL	BUMP
	CALL	NUMB	;IS NEXT CHAR NUMB?
	JNC	WHAT	;NOT NUMBER --WHATS UP
	PUSH	D
	CALL	CVB	;CONVERT TO BINARY
	PUSH	D
	PUSH	B
	CALL	BND2	;GO FIND SECOND BOUND
	POP	B
	INX	H
	MOV	E,M
	INX	H
	MOV	D,M	;SETUP TO STORE IT IN KLINE
	XCHG
	SHLD	KLINE
	POP	D
	POP	H
	MOV	A,C
	CPI	0	;ARE WE AT END OF LINE
	JNZ	WHAT
	MOV	B,H
	MOV	C,L
	CALL	DCOMP
	RNC
	JMP	WHAT
BND2:	LHLD	STLINE	;SET UP TO SEARCH FROM FROUNT
BND3:	MOV	B,M
	INX	H
	MOV	C,M
	CALL	DCOMP	;COMPARE BINARY OF REQUESTED LINE
	RC	;TO CURRENT LINE
	RZ
	PUSH	H
	INX	H
	MOV	A,M
	INX	H
	MOV	H,M
	MOV	L,A	;MOVE TO NEXT LINE
	CALL	CHK1	;IS THAT ALL?
	POP	B
	JNC	BND3	;NOPE--LOOP ON PROCESS
	PUSH	B
	POP	H
	RET
;
; WRITES TO PUNCH OUTPUT DEVICE
PWRIT:	PUSH	B
	LXI	H,OBUFF
	PUSH	H	;SAVE TO INITIALIZE LEN AT END
	MOV	C,M	;GET LENGTH
	DCR	C	;IS BUFF EMTPY
	JZ	PW2
	INX	H
PW1:	MOV	A,M	;GET CHAR
	CALL	PUNCH
	INX	H	;MOVE TO NEXT CHAR
	DCR	C	;DONE?
	JNZ	PW1	;NOT YET
	MVI	A,15Q	;;CR
	CALL	PUNCH
	MVI	A,12Q	;LF
	CALL PUNCH
PW2:	POP	H
	MVI	M,1	;LENGTH OF OBUFF
	POP	B
	RET
;
;
; THE FOLLOWING TABLE IS USED TO PAD THE STRINGS FOR THE KEYWORDS
; DURING THE LISTING PROCESS.	THE KEYWORD STRINGS ARE LOCATED IN
; THE ROUTINE SYMSRT.
KPAD:	DW	KDAT2
	DW	T3
	DW	T4
	DW	T5
	DW	T6
	DW	T7
	DW	T8
	DW	T9
	DW	T10
	DW	T11
	DW	T12
	DW	T13
	DW	T14
	DW	T15
;
; ROUTINES NUMB AND ALPHA CHECK IF CONTENTS OF MEMORY
; LOCATION IN HL CONTAIN ASCII NUMERIC OR ALPHBETIC
; CHARACTER. RETURN CY=1 IF YES, CY=0 IF NO.
NUMB:	PUSH	B
	MVI	B,'0'	;SET UP ASCII 0
	MVI	C,':'	;CHAR AFTER 9
C1:	MOV	A,M
	CMP	B
	CMC
	JNC	BAC
	CMP	C
BAC:	POP	B
	RET
ALPHA:	PUSH	B
	MVI	B,'A'	;SET UP ASCII A
	MVI	C,5BH	;CHAR AFTER Z
	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	;GET LENGTH OF STRING
	PUSH	PSW
	PUSH	H
	CPI	0	;IS LENGTH=0?
	JZ	CVB2	;YEP--GO TO CVB2
	LXI	H,KASE	;SET UP TEMP VAR KASE
	MOV	M,A	;SAVE LENGTH IN KASE
	INX	H	;SET UP TO MULT. BY
	MOV	M,C	;DEC 10
	LXI	H,10
	SHLD	MULT1
	LXI	H,0
	SHLD	MULT2
	LXI	H,MULT2+1
CVB1:	CALL	MULT
	XTHL
	MOV	A,M	;GET NEXT CHAR.
	SBI	'0'	;STRIP ASCII
	ADD	D	;THE CONVERSION ALGORITHM GOES:
	MOV	D,A
	MVI	A,0	;DE_0
	ADC	E	;DO WHILE A>0
	MOV	E,A	;DE_(HL(M)-260B)+DE*10:
	CALL	BUMP	;END:
	XTHL
	MOV	M,D
	INX	H
	MOV	M,E
	PUSH	H
	LXI	H,LEN
	DCR	M
	DCX	H
	DCR	M
	POP	H
	JNZ	CVB1
CVB2:	POP	H	;THE PROCESS IS COMPLETE,
	POP	PSW	;RESULT IN DE
	POP	B
	LXI	H,LEN
	MOV	C,M
	POP	H
	RET
;
; ROUTINE TO EVALUATE LENGTH OF ASCII NUMERIC
; CHAR STRING: PASSED ADD OF FIRST CHAR IN HL REG.
; RETURNS LENGTH IN REG A.
LENGTH:	PUSH	B	;SAVE REGISTERS
	PUSH	H
	MVI	B,0	;INITIALIZE REG B
NLE1:	CALL	NUMB	;IS HL(M) AN ASCII NUMBER?
	JNC	NLE2	;NO DONE- REG B CONTAINS LEN
	INR	B
	CALL	BUMP	;CHECK FOR END OF LINE
	JZ	NLE2
	JMP	NLE1	;LOOP ON PROCESS
NLE2:	MOV	A,B	;MOVE LENGTH INTO A
	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	;GET FIRST LINE
	CALL	CHK1	;ANY SOURCE?
	RC	;NO--RETURN
SRCH1:	PUSH	H	;SAVE LINE ADDR.
	MOV	B,M
	INX	H
	MOV	C,M	;GET LINE BIN. IN BC
	POP	H
	CALL	DCOMP	;COMPARE THEM
	RC
	RZ
	PUSH	H
	MVI	A,2	;FOLLOW THE POINTER
	CALL	DADHL
	MOV	C,M
	INX	H
	MOV	B,M
	PUSH	B
	POP	H
	POP	B
	CALL	CHK1	;CHECK FOR END OF LIST
	JNC	SRCH1
	RET	;YES--DONE
;
; ROUTINE TO COMPARE CONTENTS OF HL TO 0FFFFH .
; RETURNS CY=1 IF YES: CY=0 IF NO.
CHK1:	PUSH	B	;SAVE REGISTERS
	PUSH	H
	MVI	B,0	;MOVE 1 INTO BC
	MVI	C,1
	DAD	B	;DOUBLE ADD TO SET STATUS
	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	;SAVE REGISTERS
	PUSH	D
	PUSH	H
	LXI	H,OBUFF	;GET OBUFF ADDRESS
	MOV	C,L	;POINT TO PROPER ENTRY
	MOV	L,M
	MOV	D,A
	MOV	A,B	;TEST FOR 0 OR NEG PADS
	ORA	A
	JZ	P3
	JM	P3
P1:	MVI	A,73	;CHECK FOR LINE LENGTH
	CMP	L
	JNZ	P2	;ROOM LEFT--GO FILL
	MOV	L,C	;OBUFF IS FULL- AUTO PRINT
	MOV	M,A
	LDA	IOFLAG	;TURN OFF I/O PROCEEDS
	PUSH	PSW	;SAVING IOFLAG
	XRA	A
	STA	IOFLAG
	PUSH	D	;SAVE CHAR
	CALL	WRIT
	POP	D
	POP	PSW	;RESTORE IOFLAG
	STA	IOFLAG
	LXI	H,OBUFF
	INR	L	;RE-INITIALIZE L
P2:	MOV	A,D	; PUT CHAR IN A
	CPI	13H
	JNZ	P2A	; TEST IF COLON SUBST CHAR
	MVI	A,':'
P2A:	MOV	M,A	; STORE CHAR IN BUFFER
	INR	L
	DCR	B	;DECREMENT NUMB. CHAR. TO PAD
	JNZ	P1	;GO TO P1 IF ANY LEFT
	MOV	B,L
	MOV	L,C
	MOV	M,B
P3:	MOV	A,D
	POP	H
	POP	D
	POP	B
	RET
;
; ROUTINE TO LOCATE COMMANDS, KEY WORDS, OPERATORS,
; AND FUNCTIONS.	HL CONTAINS ADD OF FIRST CHAR.:
; REG C CONTAINS LENGTH OF LINE: RETURNS SYMBOL NUMBER
; IF FOUND IN REG A, 0FFH IN A IF NOT FOUND.
; ON ENTRY REG. A CONTAINS TYPE OF ENTRY SOUGHT:
;	0 FOR COMMAND
;	1 FOR KEYWORD
;	2 FOR OPERATOR AND DELIMITER
;	3 FOR FUNCTION
SYMSRT:	PUSH	D
	PUSH	B
	PUSH	H
	PUSH	H
	LXI	H,KDATA
	ADD	A	;DOUBLE FOR FIRST CHAR.
	CALL	DADHL	;ADD TO ADDR. LIST
	MOV	E,M
	INX	H
	MOV	D,M
	XCHG
	MVI	E,0
	MOV	D,M
S3:	INX	H	;LEN IN D AND BUMP L
	MOV	B,M	;FIRST CHAR. IN B
	XTHL	;FIRST CHAR OF USER STRING IN A
S3A:	MOV	A,M	;AND COMPARE
	CPI	' '	;IGNORE BLANKS
	JNZ	S3B	;NOT BLANK--CONTINUE
	CALL	BUMP	;DCR. LINE LENGTH
	JZ	S4	;TERMINATE THIS SERCH
	JMP	S3A
S3B:	CMP	B
	JNZ	S4	;NO MATCH-TRY AGAIN
	DCR	D	;SET UP FOR NEXT CHAR
	JZ	S5	;IF DONE EXIT
	CALL	BUMP	;DECREMENT LINE LENGTH
	JZ	S4A	;IF 0 THEN MOVE ON
	XTHL
	JMP	S3
S4A:	INR	D
S4:	POP	H	;GET ADDR. OF TABLE
	MOV	A,D
	CALL	DADHL	;A+HL, NEW L IS ALSO IN A
	MOV	D,H
	POP	H
	POP	B	;RESTORE C, HL
	PUSH	B
	PUSH	H
	PUSH	H
	MOV	L,A	;RESTORE HL PTR TO SYM TAB
	MOV	H,D
	MOV	A,M
	INR	E
	MOV	D,A
	INR	A
	JNZ	S3
	POP	H
	CALL	UNBUMP
	PUSH	H
	MVI	E,0FFH	;E=-1 IF NO MATCH
S5:	MOV	A,E	;MOVE SYMBOL NUMBER INTO REG A
	CALL	BUMP
	MOV	E,C	;SAVE C COUNT IN E
	POP	B
	POP	B
	POP	B
	MOV	C,E	;MOVE NUMBER OF CHAR. LEFT IN LINE INTO C
	POP	D
	RET
;
;
KDATA:	DW	KDAT1
	DW	KDAT2
	DW	KDAT3
	DW	KDAT4
KDAT1:	DB	3,'RUN'
	DB	5,'PLIST'
	DB	4,'LIST'
	DB	3,'SCR'
	DB	5,'PTAPE'
	DB	4,'FREE'
	DB	0FFH
KDAT2:	DB	3,'LET',1,'L'
T3:	DB	5,'PRINT',1,'P'
T4:	DB	6,'RETURN',2,'RT'
T5:	DB	4,'STOP',1,'S'
T6:	DB	3,'END',1,'E'
T7:	DB	2,'IF',2,'IF'
T8:	DB	5,'INPUT',1,'I'
T9:	DB	3,'DIM',1,'D'
T10:	DB	4,'CALL',1,'C'
T11:	DB	5,'GOSUB',2,'GS'
T12:	DB	4,'GOTO',1,'G'
T13:	DB	3,'REM',1,'R'
T14:	DB	3,'FOR',1,'F'
T15:	DB	4,'NEXT',1,'N'
	DB	0FFH
;
;DELIMITERS HAVE FOLLOWING VALUES:
;
;	<	0
;	>	1
;	,	2
;	=	3
;	)	4
;	;	5
;	THEN	6
;	TO	7
;	STEP	8
;	*	9
;	/	10
;	+	11
;	-	12
;	AS	13
;	?	14	(UP ARROW)
;	[	15	(RIGHT OR CLOSING SQUARE BRACKET)
;
KDAT3:	DB	1,'<',1,'>'
	DB	1,',',1,'='
	DB	1,')'
	DB	1,';'
	DB	4,'THEN'
	DB	2,'TO'
	DB	4,'STEP'
	DB	1,'*'
	DB	1,'/',1,'+'
	DB	1,'-'
	DB	2,'AS',1,5EH	;5E IS UP ARROW
	DB	1,5DH	;5D IS RIGHT BRACKET
	DB	0FFH
;
;
KDAT4:	DB	3,'GET'
	DB	3,'PUT'
	DB	3,'ABS'
	DB	3,'SQR'
	DB	3,'SIN'
	DB	3,'COS'
	DB	3,'TAN'
	DB	3,'ASN'
	DB	3,'ACN'
	DB	3,'ATN'
	DB	3,'EXP'
	DB	2,'LN'
	DB	3,'INT'
	DB	3,'LOG'
	DB	3,'RND'
	DB	0FFH
;
;
; THE ROUTINE PACK ENCODES ALL BLANKS IN THE LINE EXCEPT THOSE
; IN QUOTES. IF THE LINE CONTAINS A COMMAND OR AN IMMEDIATE
; KEYWORD, THEN THERE WILL BE NO RETURN. I.E. RETURNS ONLY FOR
; SOURCE LINE INSERTION. THE ROUTINE IS ACCESSED FROM TTYIN AND
; PTAPE(HRSIN).	FOR COMMAND-KEYWORD RETURN, SEE PK100.
;
; ROUTINE TO REMOVE BLANKS FROM SOURCE UNLESS ENCLOSED IN "'S
PACK:	INX	H
	PUSH	H
	LHLD	NLINE	;SET BIN. WORD 2 TO -1
	INX	H
	MVI	M,0FFH
	POP	H
	PUSH	H
PK1:	MOV	A,M	;CHECK FIRST CHARACTER
	CPI	' '	;IS IT BLANK?
	JNZ	PK2	;NOPE--CONTINUE
	DCR	B	;TEST FOR END OF LINE
	JZ	M3
	INX	H	;YEP--DELETE IT
	JMP	PK1	;CONTINUE
PK2:	MOV	C,B	;SET LINE LENGTH IN C
	MVI	B,0	;INIT. CHARS STORED.
	CALL	NUMB	;TEST FOR LINE NUMBER
	SHLD	PLINE	;SAVE CURRENT HL
	POP	H	;GET ENTRY HL
	PUSH	H
	PUSH	PSW	;SAVE CARRY BIT.
	PUSH	H
	PUSH	H
	LHLD	PLINE	;RESTORE CURRENT HL.
	JNC	PK4	;NOT NUMBER--COMMAND/KEYWORD
	CALL	CVB	;COVERT LINE # TO BINARY
	PUSH	PSW
	CPI	5	;TEST FOR VALID LINE #
	JC	PK3	;GOOD--CONTINUE
	CNZ	WHAT	;ASK FOR NEW #
	MOV	A,E
	RAL	;TES FOR OVERSIZED #
	CC	WHAT	;ASK FOR NEW #
PK3:	POP	PSW	;RETRIEVE STRING LENGTH
	PUSH	H	;SAVE CURRENT HL.
	LHLD	NLINE	;GET ADDDR OF NLINE POINTER
	MOV	M,D	;SAVE LOW BINARY
	INX	H	;BUMP IT
	MOV	M,E	;SAVE HIGH BINARY
	POP	H	;RETREIVE ADDR.
	JZ	PK6	;NO MORE SOURCE--END IT.
	CALL	DADHL
	CALL	CBLNK	;REVOVE ANY BLANKS
	JZ	PK4A
	XTHL	;SET TO STORE ENCODED BLANKS
	MOV	M,A
	INX	H
	INR	B	;INCREMENT STORED COUNT
	XTHL
	JMP	PK4A
PK4:	MVI	A,0	;SET UP TO LOCATE COMMAND TOKEN
	CALL	SYMSRT
	CMA
	CPI	0	;WAS IT FOUND?
	JNZ	PK4B	;YES--GO SAVE IT
PK4A:	MVI	A,1	;SEARCH FOR KEY WORD
	CALL	SYMSRT
	CPI	0FFH
	JZ	WHAT	;NOT FOUND--REPORT IT
	ORA	A	;CLEAR CARRY
	RAR	;DIVIDE BY TWO
PK4B:	XTHL	;STORE TOKEN WAY
	MOV	M,A
	INX	H
	INR	B
	MOV	A,C	;TEST FO NO MORE SOURCE
	CPI	0
	JZ	PK6
	XTHL
	MVI	E,'"'	;INIT E FOR COMPARES
	MVI	D,0	;D=1=>WITHIN QUOTES, LEAVE BLANKS
PK5:	XRA	A	;CLEAR A
	CMP	D	;CHECK INPUT MODE
	MOV	A,M	;GET CHAR
	JNZ	QSTR0	;WITHIN QUOTE STRING
	CMP	E	;IS TI FIRST "
	JNZ	QSTR2	;NOPE -- CONTINUE PROCESSING
	INR	D	;YEP-- SET FLAG
	JMP	QSTR3	;STORE IT AWAY
QSTR0:	CPI	':'	; LOOK FOR COLONS
	JNZ	QSTR1
	MVI	A,13H	; USE CONTROL-S FOR SUBST CHAR
	JMP	QSTR3
QSTR1:	CMP	E	;TEST FOR SECOND "
	JNZ	QSTR2	;STORE VERBATUM
	DCR	D	;CLEAR FLAG
	JMP	QSTR3	;STORE IT AWAY
QSTR2:	CPI	' '	;IS IT A BLANK
	JNZ	QSTR3
	CALL	CBLNK	;GO COMPRESS IT
	DCX	H	;MOVE POINTER BACK
	INR	C	;INCR. # CHAR. LEFT
QSTR3:	XTHL
	MOV	M,A	;SAVE CHAR.
	INX	H	;BUMP SAVE ADDR.
	XTHL
	INR	B	;BUMP LINE LENGTH
	INX	H	;POINT TO NEXT CHAR.
	DCR	C	;DECREMENT # CHAR. LEFT
	JNZ	PK5	;LOOP ON PROCESS
PK6:	POP	H
	POP	H
	POP	PSW
	POP	H	;GET ADDR OF FIRST SOURCE CHAR.
	DCX	H
	MOV	M,B	;STORE LENGTH
	RET	;GO INSERT THE LINE.
;
;
; CBLNK-- ROUTINE TO TEST SOURCE LINE FOR BLANK STRINGS. PASSED
; ADDRESS OF FIRST CHAR. TO TEST IN HL.	# CHAR. LEFT IN PENDING LINE IN
; REG. C. RETURNS WHITH HL POINTING TO FIRST CHAR. BEYOND THE
; STRING AND REG C CONTAINING THE # OF CHARACTERS LEFT IN THE
; LINE SANS BLANKS IN STRING.
; REG A WILL CONTAIN 0 IF NO BLANKS, OR COMPLEMENT OF THE NUMBER
; OF BLANKS FOUND.
CBLNK:	PUSH	D
	MVI	D,0	;INITIATE THE COUNT
CBLK1:	MOV	A,M	;GET CHAR.
	CPI	' '	;BLANK?
	JNZ	CBLK2	;NOPE-- GO END
	INR	D	;BUMP COUNT
	INX	H
	DCR	C	;DCR. # CHAR LEFT
	JZ	LEND	;SPECIAL RETURN. SOURCE LINE GONE.
	JMP	CBLK1	;LOOP ON PROCESS
CBLK2:	MOV	A,D
	CPI	0	;ANY BLANKS?
	JZ	CBLRT
	CMA	;COMPLEMENT # OF BLANKS
CBLRT:	POP	D
	RET
LEND:	POP	D	;ABNORMAL RETURN. LINE ENDED
	POP	H	;BUMP RETURN ADDR.
	JMP	PK6	;GO TERMINATE SOURCE INPUT.
;
;
; DADHL-- ROUTINE TO ACCOMPLISH DOUBLE ADD OF HL WITH REG
; A USING CARRY.
DADHL:	ADD	L
	MOV	L,A
	RNC
	INR	H
	RET
;
;
FORM:	MOV	C,M	;MOVE LENGTH INTO C
	MOV	A,C	;AND STORE IN A
	CPI	0	;IS IT 0?
	RZ
F1:	INX	H	;INCREMENT TO GET FIRST CHAR.
FORM6:	MOV	A,M	;THE PAD LOOP
	RAL	;CHECK FOR IMBEDDED BLANKS
	JNC	F2
	RAR
	CMA	;CONVERT TO + # OF BLANKS
	MOV	B,A
	MVI	A,' '
	CALL	PAD
	DCR	C
	RZ
	INX	H	;POINT TO NEXT WORD
F2:	MOV	A,M
	MVI	B,1
	CALL	PAD
	DCR	C
	JNZ	F1
	RET
;
;*****************************************************
ODAT1:	DB	7,15Q,12Q,'READY'
ODAT2:	DB	13,'TURN ON PUNCH'
ODAT3:	DB	8,15Q,12Q,'ERROR '
ODAT5:	DB	5,'WHAT?'
ODAT6:	DB	10,'MEM FULL',15Q,12Q
ODA18:	DB	6,'GARB',15Q,12Q
ODA20:	DB	11,' WORDS FREE'
;
;**************************************************************
;
; ROUTINE TO INSURE SOURCE DOES NOT OVERFLOW MEM SPACE
; COMPARES CURENT MEM ADDRESS TO SP.
MEMFUL:	PUSH	B	;SAVE REG B,D,H
	PUSH	D
	PUSH	H
	MVI	A,50	;SET FOR 50 BYTE BUFFER
	CALL	DADHL
	PUSH	H	;MOVE HL+50 TO B REG
	POP	B
	LXI	H,0	;GET CURRENT STACK
	DAD	SP
	XCHG	;SET UP FOR COMPARE
	CALL	XCOMP
	POP	H
	POP	D
	POP	B
	RNC	;ALL OK	CONTINUE
	LXI	H,ODAT6
	CALL	FORM
	CALL	WRIT
UGARB:	CALL	GARB	;PACK IT WAY
	LXI	H,ODA18
	CALL	FORM
	CALL	WRIT
	LHLD	NLINE
	XCHG	;FIND NUMBER OF FREE WORDS
	LHLD	STAACK
	MOV	A,L
	SUB	E
	MOV	L,A
	MOV	A,H
	SBB	D
	XCHG
	MOV	M,E	;PUT IT IN MEM.
	INX	H
	MOV	M,A
	DCX	H
	CALL	DNUMB	;PAD IT
	LXI	H,ODA20
	CALL	FORM
	CALL	WRIT
	JMP	M1A	;START OALL OVER AGAIN
;
;
; THE GARBAGE COLLECTION ROUTINE -- USED ONLY WHEN NECESARY
; AND THEN ONLY BY THE BRAVE.
GARB:	LHLD	STLINE	;CHECK FOR ANY THING IN MEM.
	CALL	CHK1
	JC	GARBR	;NO SOURCE--RETURN
	LXI	H,0FFFFH	;SET UP TO COUNT # OF LINES
	SHLD	KASE	;SAVED
	LXI	H,VEND	;GET FWAM
	SHLD	KLINE	;INITIALIZE SAVE ADDR.
GARB1:	SHLD	PLINE	;GET ADDR.
	INX	H	;POINT TO SECOND BYTE OF
	MOV	A,M	;BINARY LINE #
	RAL	;CY=1 IF LINE DELETED
	PUSH	PSW	;SAVE CARRY
	MVI	A,3	;MOVE TOLINE LENGTH
	CALL	DADHL
	POP	PSW
	MOV	A,M	;GET LINE LENGTH
	CNC	SAVE	;SAVE IF NOT DELETED
	CALL	DADHL	;MOVE PAST LINE
	INX	H
	CALL	FSTAB	;CHECK FOR SYM. TAB. OR END
	JC	GARB1	;CY=0	THEN CONTINUE
	CALL	IPNTS	;GO SET ALL THE POINTERS
GARB2:	LXI	H,0FFFFH	;INITIALIZE STSPAC
	SHLD	STSPAC
	RET	;DONE!!?!!?!!?
 
GARBR:	LXI	H,VEND
	SHLD	NLINE
	JMP	GARB2
;
;
; ROUTINE SAVE TO MOVE LINES INTO PACKED STORAGE.
SAVE:	PUSH	PSW
	PUSH	H
	LHLD	KASE
	INX	H
	SHLD	KASE	;INCREMENT # LINES SAVED
	LHLD	KLINE	;GET SAVE ADDR.
	PUSH	H
	LHLD	PLINE	;GET 'GET' ADDR.
	POP	B	;CHECK IF MOVEMENT NEXX.
	PUSH	PSW	;SAVE REG A
	XCHG
	CALL	XCOMP
	XCHG
	JZ	NCHG
	POP	PSW
	PUSH	B
	ADI	5	;ADD 5 TO LENGTH TO INCLUDE POINTERS
	MOV	B,A
SAVE1:	MOV	A,M	;GET FIRST BYTE
	XTHL	;SAVE IT AWAY
	MOV	M,A
	INX	H	;BUMP	SAVE ADDR.
	DCR	B	;DCR LINE LENGTH
	JZ	SAVER	;DONE--ADJUST KLINE--RET
	XTHL
	INX	H	;BUMP 'GET' ADDR.
	JMP	SAVE1
SAVER:	SHLD	KLINE	;SET NEW SAVE ADDR.
	POP	H
	POP	H
	POP	PSW
	RET	;DONE.
;
NCHG:	MVI	A,4
	CALL	DADHL
	MOV	A,M
	INX	H
	CALL	DADHL	;POINT PAST CURR. LINE
	JMP	SAVER
;
;
; ROUTINE IPNTS PREFORMS ALL OF THE POINTER ADJUSTMENT
; OF THE PACKED SOURCE BY SIMPLY INSERTING THE LINES
; ONE AT A TIME AS IF THEY WERE ENTERED EXTERNALLY.
IPNTS:	LHLD	KASE	;GET NUMBER OF LINES LEFT
	MOV	B,H
	MOV	C,L
	LXI	H,VEND	;INITIALIZE NLINE
	SHLD	NLINE
	LXI	H,0FFFFH	;SET STLINE TO NO SOURCE
	SHLD	STLINE
	PUSH	B
	POP	H
IPNT1:	PUSH	H
	CALL	INSERT	;GO INSERT LINE
	POP	H
	DCX	H
	CALL	CHK1
	JNC	IPNT1
	RET	;DONE.
;
;
; ROUTINE FSTAB CHECKS FOR:
;	A) BEGINNING OF SYMBOL TABLE. IF THIS OCCURES THEN THE
;	VALUE OF PLINE ( 'GET' ADDR.) IS RETURNED POINTING TO THE
;	NEXT SOURCE LINE. THAT IS IT BYPASSES THE BLOCK OF
;	SYMBOL TABLE. IF THE LAST BLOCK OF SYM TAB IS ENCOUNTERED,
;	THEN CY IS SET TO 1 TO INDICATE COMPLETION.
;	B) CHECKS FOR PLINE = NLINE.INDICATES THAT THERE IS NO
;	SYMBOL TABLE AND WE ARE DONE.CY SET TO 1
;	C) IF NONE OF THE ABOVE.THE RETURN IS WITH CY=0 AND
;	ALL ELSE UNCHANGED
FSTAB:	SHLD	PLINE	;SAVE CURRENT PLINE
	PUSH	H
	POP	B
	LHLD	NLINE
	XCHG	;PLINE=NLINE
	CALL	XCOMP
	RZ	;IF EQUAL THEN DONE
	LHLD	STSPAC
	XCHG	;STSPAC=PLINE
	CALL	XCOMP
	CZ	PTABL
	LHLD	NLINE
	XCHG
	CALL	XCOMP
	RZ	;PROCESS COMPLETE
	LHLD	PLINE
	STC	;SET CARRY TO CONTINUE
	RET
;
;
; ROUTINE PTABLE PACKS THE SYMBOL TABLE REMOVING IT FROM
; THE SOURCE AND MEMORY.THE ROUINE IS ENTERED WITH
; HL POINTING TO THE FIRST ENTRY OF A SYM TAB BLOCK AND RETURNS
; WITH STSPAC UPDATED TO POINT TO THE NEXT BLOCK ( OR -1) AND
; PLINE POINTING TO THE NEXT SOURCE BLOCK.
PTABL:	PUSH	B
	POP	H
	PUSH	H
	MVI	A,2	;MOVE TO FRD. PNTER.
	CALL	DADHL
	MOV	C,M	;SAVE IN BC.
	INX	H
	MOV	B,M
	POP	H	;MMOVE HL BACK TO FIRST
	MOV	A,M
	ORA	A
	JZ	ARRP	;GO PACK ARRAY
	INX	H	; SO COUNTS COME OUT RIGHT
	CPI	'$'	; LOOK FOR TEM VAR FOR CALL
	JZ	STRGP
	CPI	'%'
	JZ	VARRP
	DCX	H	; SO ALPHA WORKS RIGHT
	CALL	ALPHA	;IF NOT A LETTER
	JNC	STPRP	;THEN IT'S A FOR-STEP VAR
	INX	H
	MOV	A,M
	CPI	'$'
	JZ	STRGP	;GO PACK STRING
VARRP:	MVI	A,7	;ADJUST TO POINT PAST VARIABLE
	JMP	TSTIT	;GO SEE IF ITS STILL SYB TAB.
STPRP:	MVI	A,16	;MOVE PASSED FOR STEP VAR
	JMP	TSTIT
ARRP:	MVI	A,4	;SET TO POINT TO LENGTH
	CALL	DADHL
	MOV	E,M	;GET HIGH LEN INTO D
	INX	H
	MOV	D,M	;GET LOW LENGTH INTO E
	DAD	D	;ADD TO HL
	INX	H	;POINT TO FIRST WORD OF NEXT ENT.
	JMP	TSTI2
;
STRGP:	MVI	A,4+(LENST AND 0FFH)	;SET TO ADD LEN OF POINTERS
TSTIT:	CALL	DADHL	;POINT PAST ENTRY
TSTI2:	XCHG
	CALL	XCOMP	;ARE THEY EQUAL?
	JZ	PTABL	;YES--TRY AGAIN
	PUSH	B	;NO--SET FWD. PNTR. TO STSPAC
	POP	H
	SHLD	STSPAC
	XCHG	;END OF CURRENT ENTRY IN HL
	SHLD	PLINE	;CONTINUE PACKING FROM THERE
	PUSH	H
	POP	B
	RET
;
;
XCOMP:	MOV	A,D
	CMP	B
	RNZ
	MOV	A,E
	CMP	C
	RET
;
;
; ROUTINE TO OUTPUT ERROR MSG. TO USER.
; REG A CONTAINS BCD ERROR NUMBER, HL
; LOADED WITH VALUE OF KLINE.
ERROR:	LHLD	STAACK
	SPHL
	LXI	H,ODAT3	;OUTPUT BUFFER DATA TABLES
	MOV	D,A	;SAVE ERROR NUMB. IN D
	XRA	A
	STA	IOFLAG	;TURN OFF I/O PROCEEDS
	CALL	FORM	;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	17Q	;MASK
	ADI	60Q	;CONVERT TO ASCII
	CALL	PAD	;PAD IT
	MOV	A,D	;GET ERROR NUMB.
	DCR	C	;ANOTHER PASS?
	JP	ERRR1	;YES
ERRR2:	LHLD	KLINE
	CALL	CHK1	;SEE IF IMMEDIATE STMT
	JC	ERR12
	XCHG	;SAVE PTR TO LINE NUMBER IN DE
	LXI	H,ODAT4
	CALL	FORM	;PAD 'IN LINE'
	XCHG
	CALL	DNUMB	;DUMP LINE #
ERR12:	CALL	WRIT	;WRITE MESSAGE
	JMP	M1A
;
; THIS ROUTINE COPIES A STRING FROM DE PTR
; TO HL PTR. ALL REGS ARE SAVED
STD2H:	LDAX	D	;SAVE REGS
	PUSH	B
	PUSH	D
	PUSH	H
	MOV	C,A	;START CNTR
	INR	C
STLOP:	LDAX	D	;GET CHAR
	MOV	M,A	;MOVE CHAR
	INX	D	;INCR PTRS
	INX	H
	DCR	C	;DECR CNTR
	JNZ	STLOP	;TEST IF DONE
	POP	H	;RESTORE REGS AND RET
	POP	D
	POP	B
	MOV	A,M
	RET
;
; THIS ROUTINE FILLS A STRING VAR WITH BLANKS
; AND SETS THE LENGTH TO ZERO.
BSTRG:	PUSH	H	;SAVE REGS
	PUSH	B
	MVI	B,0
	MOV	M,B	;SET LENGTH TO ZERO
	INX	H	;INCR PTR IN STRING
	MVI	C,(LENST AND 0FFH)	;COUNT OF STRING
	MVI	B,' '	;BLANK
BSTR2:	MOV	M,B	;STORE BLANK
	INX	H
	DCR	C	; BUMP CNTRS
	JNZ	BSTR2	;TEST IF DONE
	POP	B
	POP	H
	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
ICP6:	MVI	A,6
	JMP	INCPT
ICP8:	MVI	A,8
	JMP	INCPT
ICP4:	MVI	A,4
	JMP	INCPT
ICP2:	MVI	A,2
INCPT:	CALL	BUMP
	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 A STRING VAR. => INSERTED
;	AND SET TO LENGTH 0 AND FILLED BLANK.
; 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
	CALL	CHK1	;IS STSPAC= -1
	JNC	AR1	;NO--TEST FOR NXTSP
	PUSH	B
	POP	H	;SET STSPAC=NXTSP=NLINE
	SHLD	STSPAC
	POP	B
	XCHG
	JMP	NOENT
AR1:	MOV	D,H	;EMPTY
	MOV	E,L
	CALL	DCOMP	;DOUBLE BYTE COMPARE
	POP	B	;GET VAR. BACK
	JZ	NOENT
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 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	STPNT	;UPDATE PNTR
	XCHG	;NXTSP TO HL
	MOV	M,B	;STORE VAR.
	INX	H
	MOV	M,C
	INX	H
	PUSH	H
	MVI	A,6	;ADJUST ADDR
	CALL	DADHL
	MOV	A,B
	CPI	'$'	; CHECK FOR TEMP STRING VAR
	JZ	STFUL
	MOV	A,C	;CHEK FOR STRING VAR
	CPI	'$'	;COMPARE WITH $
	JNZ	CKFUL
	;(STRINGS ARE 1 BYTE FOR
STFUL:	MVI	A,(LENST AND 0FFH)-3	;LENGTH AND 10 BYTES FOR
	CALL	DADHL	;CHARS)
CKFUL:	SHLD	NXTSP
	XTHL
	MVI	M,0FFH	;SET FWD. PNTR. TO -1
	INX	H
	MVI	M,0FFH
	INX	H	;INIT TO FLT. PNT. 0
	XTHL	;GET READY TO CHECK MEMORY
	CALL	MEMFUL	;MEMORY FULL?
	POP	H	;RESTORE NORMAL H-L
	MOV	A,C	;TEST IF STRING
	CPI	'$'
	JZ	MTSTR	;INSERT STRING
	MOV	A,B
	CPI	'$'
	JZ	MTSTR
	CALL	WZER
	ORA	A	;CLEAR CY
	JMP	FBAC	;RESET CARRY AND RETURN
MTSTR:	CALL	BSTRG	;CREATE BLANK STRING
	ORA	A	;CLEAR CY (VAR INSERT)
	JMP	FBAC
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
;
;
; CONTAIN LOW BYTE OF TWO BYTE VALUE. RETURNS CY=1 IF
; BC>DE, CY=0 IF BC<DE: Z=1 IF BC=DE.
DCOMP:	MOV	A,E
	CMP	C
	RNZ
	MOV	A,D
	CMP	B
	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
	INX	H
	MOV	D,M
	INX	H
	PUSH	D
N1:	XTHL
	MOV	E,M
	INX	H
	MOV	D,M
	INX	H
	XTHL
	MOV	M,E
	INX	H
	MOV	M,D
	INX	H
	DCR	A
	JNZ	N1
	XTHL
	MOV	D,M
	POP	H
	MOV	M,D
	POP	H
	POP	D
	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
;
; INP SAVES ALL REG'S
; SERVES AS A BUFFER ROUTINE 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,' '	;SEND A SPACE
IDONE:	POP	B	;RESTORE REG'S
	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 CHAR.
	CPI	','	;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	'.'	;DEC. PNT.?
	JZ	BMPTR
	CPI	'E'	;E?
	JZ	BMPTR
	CPI	'+'	;+?
	JZ	CHEKE
	CPI	'-'	;-?
	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	'E'	;IS IT E?
	JNZ	SPACE	;NO,+OR- WAS DELIMITTER
	MOV	A,B	;YES,GET + OR -
	INX	H	;RESTORE H,L
BMPTR:	CALL	BUMP	;BUMP AND STORE PNTR'S
	SHLD	HLINP
	LXI	H,CREG
	MOV	M,C
	JMP	IDONE	;RESTORE REG'S AND RETURN
;
;
; RUN - THE INTERP.

RUN:	LHLD	NLINE	;SAVE ADDR OF RUN CMD
	PUSH	H
	LDA	GRBFLG
	ANA	A	;JUMP AROUND GARB. COLL. IF
	JNZ	RUN1	;GRBFLG=1
	CALL	GARB	;COLLECT ALL FREE MEM.
RUN1:	XRA	A
	STA	IOFLAG
	LXI	H,BOTNS	;INIT SP FOR NESTING STACK
	SHLD	NEST
	POP	D	;GET ADDR OF RUN CMD
	LXI	H,M1A	;PRECAUTION, IN CASE RETURN IS
	PUSH	H	;EXECUTED BEFORE A GOSUB
	PUSH	H
	LDA	GRBFLG	;DO NOT TEST FOR RUN(LINE #)
	ANA	A	;IF WE ARE RUNNING FROM PROM
	JNZ	RUN2
	XCHG	;CHECK FOR LINE NO AFTER RUN
	MVI	A,4
	CALL	DADHL
	MOV	C,M	;GET LENGTH OF LINE
	INR	C
	CALL	BUMP
	JNZ	RUNNO	;TRANSFER TO LINE NO.
RUN2:	LHLD	STLINE	;START OF SOURCE
ILOOP:	CALL	QUITT	;CHECK FOR INTERRUPTION
	CALL	CHK1	;HL=-1 => NO MORE SOURCE
	JC	M1A	;END OF PROGRAM, GO TO M1A
	SHLD	LPNT
	INX	H	;STEP PASSED BINAY VALUE
	INX	H
	MOV	E,M	;GET FORWARD PTR
	INX	H
	MOV	D,M
	INX	H
;
;
; ENTER HERE FOR IMMEDIATE EXECUTION. DE= -1 AND HL PT TO SOURCE-1
IMMED:	MOV	A,M	;GET LENGTH OF SOURCE
	XCHG	;SAVE HL
	SHLD	KFPNT	;SAVE FORWARD PTR
	STA	KLEN	;SAVE LENGTH
	XCHG	;RESTORE HL
	MOV	C,A
	INR	C
	CALL	BUMP
	MOV	A,M	;GET CODED KEYWORD
	SHLD	CPNT
	LXI	H,JTBL	;LOAD JUMP TABLE PNTR.
	ADD	A	;DOUBLE A
	CALL	DADHL	;PT TO PROPER STMT PROCESSOR
	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	RETRN
	DW	M1A	;STOP STMT.-RETURN TO EDIT MODE
	DW	ENDD
	DW	IFRT
	DW	INPUT
	DW	DIM
	DW	CALLP
	DW	GOSUB
	DW	GOTO
	DW	IEND	;REM STMT. - NO ACTION
	DW	FOR
	DW	NEXT
;
;
; RUN LINE# PROCESS
RUNNO:	CALL	BOUND	;GET NEAREST LINE NUMBER
	LHLD	PLINE	;PUT INTO H-L
	JMP	ILOOP	;EXECUTE
;
;
; END PROCESSOR
ENDD:	LHLD	KFPNT	;CHECK TO SEE IF MORE
	CALL	CHK1	;SOURCE AFTER END
	JC	M1A
	MVI	A,3	;MORE SOURCE ERROR 3
	JMP	ERROR
;
;
; GO TO PROCESSOR
GOTO:	LHLD	CPNT	;GOTO STMT. PROC.
GSENT:	CALL	ICP4	;INCREMENT PAST KEYWORD
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
;
;
; DIMENSION PROCESSOR
DIM:	LHLD	CPNT	;DIM STMT. PROC.
	CALL	ICP6
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,'('	;CHECK FOR (
	CMP	M
	JNZ	ER6
	CALL	ICP7	;INCR. CPNT
	CALL	CVB	;CONV. TO BIN NO.
	CALL	DADHL	;UPDATE HL
	MVI	A,')'	;CHECK FOR )
	CMP	M
	JNZ	ER6
	PUSH	H
	PUSH	B	;SAVE B,C,H,L
	MOV	C,B	;SET UP FOR CALL TO FSYM
	MVI	B,0
	CALL	FSYM
	JNC	NDOU
	POP	B
	POP	H
	MVI	A,11H	;ERROR 11
	JMP	ERROR	;DUPLICATE ARRAY DEF.
NDOU:	PUSH	H	;ADD. OF LAST SYM. TAB. ENTRY TO DE
	LHLD	NXTSP	;GET ADD. OF AVAILABLE MEM.
	MVI	M,0
	INX	H	;INSERT VAR IN SYMB. TAB.
	MOV	M,C
	INX	H
	INX	H
	MOV	A,D	;GET VALUE INTO PROPER ORDER
	MOV	D,E
	MOV	E,A
	INX	D	;NOW DE HAVE NUMBER OF ELEMENTS
	MOV	A,D	;GET ONE'S COMPLEMENT OF
	CMA	;NUMBER OF ELEMENTS
	MOV	B,A	;IN ARRAY TO B,C
	MOV	A,E
	CMA
	MOV	C,A
	XCHG	;CALCULATE NUMBER OF BYTES
	DAD	H
	DAD	H	;MULT BY 4
	XCHG
	INX	H	;STORE LEN OF ARRAY
	MOV	M,E
	INX	H
	MOV	M,D
	INX	H	;PNTS TO FIRST DATA
CONT:	CALL	WZER	;ZEROE OUT ELEMTS.
	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
	POP	D	;RETRIEVE ADDR OF LAST SYMBOL
	PUSH	H	;SAVE NEW NXTSP
	LHLD	NXTSP	;GET OLD NXTSP (START OF ARRAY)
	XCHG
	CALL	STPNT	;STORE FPNT IN PREVIOUS SYMBOL
	XCHG	;SET CURRENT FPTR TO -1
	INX	H
	INX	H
	MVI	M,0FFH
	INX	H
	MVI	M,0FFH
	POP	H	;UPDATE NXTSP-NLINE
	SHLD	NXTSP
	SHLD	NXTSP	;NEW VALUE OF NXTSP.NLINE
	POP	B	;RESTORE REG'S
	POP	H
	CALL	BUMP	;MORE ELEMTS IN LINE?
	JZ	IEND
	MVI	A,','	;NEXT ELEMENT A ,
	CMP	M
	JNZ	ER6	;ERROR IF NOT COMMA
	CALL	ICP6	;INCR HL AND C
	JMP	DLOOP
;
;
; 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 REGISTERS
	POP	D
	POP	B
	POP	PSW
	RET
;
;
; VALUE RETURNS IN AM9511 STACK IF NUMBER
; IF STRING DE PT TO LOCATION OF STRING
; C,H,L ARE UPDATED
; A,B ARE DESTROYED
VALUE:	CALL	VAR	;IS IT A VARIABLE?
	JNC	NOVAR	;NOT A VARIABLE
	CPI	2	;TEST IF STRING VARIABLE
	RZ	;YES IT IS, NOT PUT ON AM9511
	XCHG	;LET HL PT TO VALUE
	CALL	HL2AM	;PUT VALUE ON AM9511
	XCHG	;RESTORE REGS
	RET
NOVAR:	MVI	A,3	;NO CHEK IF A FUNC.
	CALL	SYMSRT
	CPI	377Q
	JZ	KONT	;NOT A FUNCTION -
	PUSH	PSW	;SAVE FUNCTION
	MOV	A,C	;CHECK FOR PREMATURE EOL
	ORA	A
	JZ	ER8
	MVI	A,'('	;CHEK FOR (
	CMP	M
	JNZ	ER8
	CALL	ICP8	;BUMP PNTR'S
	MVI	B,0	;SET INITIAL PRECEDENCE
	CALL	EVAL	;GET PORT #
	CPI	1	;NO STRING ARGS ALLOWED
	JZ	ER10
	POP	PSW	;PUT BC, HL ON STACK
	PUSH	B
	PUSH	H
	LXI	H,ENDFUN	;PUSH A RETURN ADDR SO THAT
	PUSH	H	; THE FUNCTION ROUTINE CAN BE
	; LIKE SUBROUTINES
	ADD	A	;DOUBLE FUNCTON NUMBER
	LXI	H,FTABLE
	CALL	DADHL	;FORMJUMP ADDR
	MOV	A,M
	INX	H
	MOV	H,M
	MOV	L,A
	PCHL	;GO DO IT
;
;
FTABLE:	DW	GET
	DW	ER10	;PUT IS AN ERROR
	DW	ABS
	DW	SQR
	DW	SIN
	DW	COS
	DW	TAN
	DW	ASN
	DW	ACN
	DW	ATN
	DW	EXP
	DW	LOG
	DW	INT
	DW	LGT	;LOG BASE 10
	DW	RANDOM
;
ENDFUN:	POP	H
	POP	B
	MOV	A,C	;EOL?
	ORA	A
	JZ	ER8
	MVI	A,')'	;CHECK FOR )
	CMP	M
	JNZ	ER8
	CALL	BUMP	;BUMP PNTR'S
	MVI	A,0	;INDICATE NUMBER VALUE
	RET
;
;
; THE FUNCTIONS GO HERE
GET:	CALL	FIXD	;FIX PORT NUMBER
	LXI	H,FREG1
	CALL	AM2HL	;PUT PORT NUMBER IN FREG
	XCHG	;LET DE PT TO PORT NUMBER
	INX	D
	INX	D	;GET LOWEST BYTE TO
	INX	D	;REG D
	LDAX	D
	MOV	D,A
	;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+3	;SET UP FOR FLOAT
	MOV	M,A	;STORE AWAY INPUT
	DCX	H
	XRA	A	;ZERO OUT HIGHER BYTES
	MOV	M,A	;ALL 3 NEED TO BE ZERO
	DCX	H	;TO PRODUCE A 4 BYTE INTEGER
	MOV	M,A
	DCX	H
	MOV	M,A
	CALL	HL2AM	;PUT VALUE ON AM9511
	CALL	FLTD	;FLOAT IT
	RET	;DONE
RINST:	IN	0	;RAM INSTRUCTIONS
	JMP	HOME
ABS:	CALL	XCHF
	CALL	XCHF
	CALL	STATUS
	RP
	CALL	CHSF
	RET
KONT:	CALL	NUMB	;NUMBER
	JC	OKK
	MOV	A,M
	CPI	'.'	;DEC PT?
	JZ	OKK
	CPI	'"'	;IS IT "?
	JZ	SKOUT
	CPI	'('	;IS IT (?
	JNZ	ER8
	CALL	ICP8	;WE HAVE A (EXPR)
	MVI	B,0	;SET INITIAL PRECEDENCE
	CALL	EVAL	;EVAL EXPRESSION
	MOV	A,M	;IN FUTURE CHECK EXPRS TYPE
	CPI	')'	;CHECK FOR )
	JNZ	ER8
	CALL	BUMP	;BUMP POINTERS
	MVI	A,0	;INDICATE NUMREIC RESULT
	RET
SKOUT:	PUSH	H	;YES WE HAVE A STRING
	LXI	H,SREG2	;PT TO SREG2
	CALL	BSTRG	;PUT BLANKS IN SREG2
	XCHG	;PUT STRING ADDR IN DE
	INX	D
	POP	H	;RESTORE HL
	MVI	B,0	;SET CNTR=0
LTQLP:	INX	H	; BUMP PNTRS
	DCR	C
	JZ	ER8
	MOV	A,M	; GET NEXT CHAR
	CPI	'"'	; IS IT QUOTE?
	JZ	LTQOT
	ORA	A	; SET PSW TO SEE IF IMBEDDED BLANKS
	JP	LTCHR	; REGULAR CHAR
	CMA	; IMBEDDED SPACES.SINCE
LTBED:	INX	D	; SPACES ALREADY IN BUFFER
	INR	B	; JUST MOVE POINTERS B & DE
	DCR	A
	JNZ	LTBED
	JMP	LTLTS	; GO TEST IF STRING TOO LONG
LTCHR:	STAX	D	; PUT CHAR IN SREG2
	INX	D
	INR	B	; INCREMENT PTR AND CNT
LTLTS:	MOV	A,B
	CPI	LENST+1	; TEST IF 10 CHAR IN SREG2
	JM	LTQLP	; IF NOT 10, LOOP UNTIL "
	MVI	A,'"'
LTPP:	CALL	ICP8	;BUMP PTRS
	CMP	M	;TEST NEXT CHAR
	JNZ	LTPP
	MVI	A,LENST
LTSDN:	LXI	D,SREG2	; STORE LENGTH
	STAX	D
	CALL	BUMP
	MVI	A,2	; INDICATES STRING
	RET
LTQOT:	INX	H	; BUMP POINTERS
	DCR	C
	JZ	LTQTE	; END OF STRING AT END OF LINE
	MOV	A,M	; CHECK FOR A DOUBLE QUOTE
	CPI	'"'
	JZ	LTCHR	; DOUBLE QUOTE BECOMES THE CHAR "
LTQTE:	CALL	UNBUMP	; SETS POINTERS UP CORRECTLY
	MOV	A,B	; PREPARE TO PUT LENGTH IN BUFFER
	JMP	LTSDN	; DONE.
OKK:	MVI	A,1	;MODE=1, IE. INPUT FROM SOURCE
	CALL	RDKON	;READ CONSTANT TO GREG
	JC	ER9	;IF ERROR THEN CY=1
	XCHG	;SAVE HL IN DE
	LXI	H,GREG	;POINT TO CONSTANT
	CALL	HL2AM	;PUT ON AM9511
	XCHG	;RESTORE HL
	XRA	A	;SET A=0 TO INDICATE NUMBER RESULT
	RET
;
;
; THIS ROUTINE READS A CONSTANT INTO GREG FROM ASCII
; CHARACTERS POINTED TO BY HL AND C
; ENTER WITH A=0 => DATA FROM TTY
; ENTER WITH A=1 => DATA FROM SOURCE
; RETURN 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 AND 377Q	;SET UP AND CALL FINPT
	CALL	FINPT
	LHLD	HLINP	;RETORE H,L AND C
	LDA	CREG
	MOV	C,A
	RET	;DONE
;
;
; 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
; B DESTROYED,A=0(VARIABLE),1(ARRAY),2(STRING VAR)
; IF NOT A VARIBLE CY=0
; H,L,C ARE LEFT UNTOUCHED
VAR:	CALL	ALPHA	;1ST CHAR A LETTER?
	RNC	;NO-NOT VAR.
	CALL	BUMP	;BUMP PNTR'S
	JNZ	MORE	;MORE TO LINE
SC1:	PUSH	B	;SAVE B,EOL
	CALL	UNBUMP	;GET SINGLE LETTER
	MOV	B,M	;VAR TO B
	CALL	BUMP
	MVI	C,0	;SET FOR CALL TO FSYM
	MOV	A,C
	JMP	SCALR
MORE:	CALL	ALPHA	;2ND A LETTER?
	JNC	SFSG	;SO FAR SO GOOD
	PUSH	B	;SAVE C
	PUSH	H
	MVI	A,2	;CHECK FOR DELIMITER
	CALL	SYMSRT
	POP	H
	POP	B	;RESTORE C
	INR	A	;FOUND?
	JNZ	SC1	;YES
	CALL	UNBUMP	;NOT A VAR.
	ORA	A	;CY=0 AND RET
	RET
SFSG:	CALL	NUMB	;TEST FOR NUMBER
	JNC	ARCK	;MAYBE AN ARRAY
	MVI	A,0	;INDICATE NUMBER VAR FOUND
SFSG2:	CALL	BUMP	;ITS A SCALAR
	JZ	SLOAD	;EOL
	PUSH	H
	PUSH	B	;SAVE C
	PUSH	PSW	;SAVE VAR TYPE
	MVI	A,2	;SET UP FOR SYMSRT
	CALL	SYMSRT	;TEST FOR LEGAL
	POP	B	;GET VAR TYPE BACK
	INR	A	;DELIMITER FOUND?
	MOV	A,B	;MOVE VAR TYPE TO A
	POP	B	;GET BACK C-REG
	POP	H
	JZ	ER8	;NO, ERROR
SLOAD:	PUSH	B	;SAVE C,
	CALL	UNBUMP
	MOV	B,M	;GET VAR. INTO
	CALL	UNBUMP	;B,C FOR FSYM
	MOV	C,B
	MOV	B,M
	PUSH	B	;SAVE BC
	CALL	BUMP
	CALL	BUMP
	POP	B
SCALR:	XCHG	;SAVE H,L IN D,E
	PUSH	PSW
	CALL	FSYM	;GET PNTR TO VALUE
	POP	PSW
	XCHG	;RESTORE H,L PNTR TO DE
	POP	B	;GET C REG BACK
	STC	;SET CY,RET
	RET
ARCK:	MOV	A,M	;ARRAY & STRING CHEK, GET CHARACTER
	CPI	'('	;IS IT (?
	JZ	ARYES	;YES,ITS AN ARRAY
	CPI	'$'	;IS IT $?
	JZ	VSTR	;YES IT IS A STRING VAR
	MVI	A,2	;NO-CHEK FOR LEGAL DELIM.
	PUSH	H
	PUSH	B	;SAVE C
	CALL	SYMSRT
	POP	B	;RESTORE C
	POP	H
	INR	A	;DELIMITER FOUND?
	JZ	ER1
	XRA	A	;SET A=0 TO INDICATE VAR
	JMP	SC1	;1 CHAR. SCALAR VAR.
VSTR:	MVI	A,2	;INDICATE STRING VAR
	JMP	SFSG2	;FIND ADDR OF VAR
ARYES:	CALL	UNBUMP	;YES-WE HAVE ARRAY
	MOV	A,M	;GET VAR.
	CALL	BUMP
	PUSH	PSW	;SAVE VAR.
	CALL	ICP1	;BUMP PNTR'S
	MVI	B,0	;SET INITIAL PRECEDENCE
	CALL	EVAL	;EVALUATE SUBSCRIPT
	PUSH	H	;SAVE HL PTRS
	LXI	H,HALF	;ROUND SUBSCRIPT
	CALL	HL2AM
	CALL	FADD	;BY ADDING 1/2
	CALL	STATUS	;CHECK IF SUBSCRIPT NEG.
	JM	ER22	;NOT ALLOWED IN IDAHO
	CALL	FIXD	;FIX SUBSCRIPT
	LXI	H,FREG1
	CALL	AM2HL	;PUT SUBSCRIPT IN FREG
	XCHG	;LET DE PT TO SUBSCRIPT
	POP	H	;RESTORE HL
	MVI	A,')'	;CHECK FOR )
	CMP	M
	JNZ	ER1
	CALL	BUMP	;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
	MOV	D,B	;PUT SUBSCRIPT IN DE
	MOV	E,A
	XCHG
	DAD	H	;MULT BY 4
	DAD	H
	XCHG
	POP	PSW	;DE CONTAIN OFFSET*4
	PUSH	B	;GET VAR., SAVE C
	MOV	C,A
	MVI	B,0	;SETUP TO CALL FSYM
	PUSH	H	;SAVE H,L
	CALL	FSYM	;GET START ADD.
	JC	AFOND
	MVI	A,12H	;ERROR 12
	JMP	ERROR	;ARRAY REF. NOT DIM'ED.
ER1:	MVI	A,1
	JMP	ERROR
ICP1:	MVI	A,1
	CALL	BUMP
	RNZ
	JMP	ERROR
AFOND:	MOV	A,M	;1'S COMPLEMENT
	CMA
	MOV	C,A
	INX	H
	MOV	A,M
	CMA
	MOV	B,A	;BC= - LENGTH OF ARRAY
	INX	B	;MAKE IT 2'S COMPL
	INX	H	;PT TO START OF DATA
	PUSH	D	;SAVE SUBSCRIPT
	XCHG
	DAD	B	;SUBSCRIPT-LENGTH
	JC	ER22	;SUBSCRIPT OUT OF RANGE
	XCHG
	POP	D
	DAD	D	;H,L NOW PNT TO START OF
	XCHG	;ARRAY, ADD OFFSET, EXCHG
	POP	H	;RESTORE PNTR'S AND RET.
	POP	B
	MVI	A,1	;INDICATE NUM. ARRAY FOUND
	STC	;SET CY
	RET
ER22:	MVI	A,22H	;SUBSCRIPT TOO LARGE
	JMP	ERROR
;
;
; BUMP AND UNBUMP INCR AND DECR HL, C PTRS TO NEXT
; NORMAL CHARACTER, SKIPPING SPACES IN EITHER DIRECTION
; HL, C ALWAYS RETURN POINTING AT A CHARACTER.
; IMBEDDED BLANKS ARE RECOGNIZED BY A ONE IN THE SIGN BIT.
; FOR BUMP, THE PSW RETURNS WITH THE ZERO FLAG SET AFTER
; THE DCR C INSTRUCTION, SO IT INDICATES EOL OR NOT.
BUMP:	PUSH	D	;SAVE TO ENABLE A TO BE RESTORED
	PUSH	PSW	;SAVE A
LBUMP:	INX	H	;BUMP PTRS
	DCR	C
	JZ	BEND	;AT EOL
	PUSH	PSW	;SAVE ZERO FLAG (SAVE PSW)
	MOV	A,M
	CPI	':'	;COLON WILL END SOURCE LINE
	JZ	COLON
	ORA	A	;TEST FOR BLANKS
	JP	BOK	;REGULAR CHAR
	POP	PSW
	JMP	LBUMP	;SKIP OVER SPACES
COLON:	POP	PSW	;GET RID OF OLD PSW
	XRA	A	;SET ZERO FLAG=1
	MOV	C,A	;SET LENGTH TO ZERO
	PUSH	PSW	;PUT PSW IN ITS PLACE
BOK:	POP	PSW	;RESTORE PSW TO STATE AFTER DCR C
BEND:	POP	D	;POP A INTO D
	MOV	A,D	;RESTORE A
	POP	D	;RESTORE DE
	RET
UNBUMP:	PUSH	PSW	;SAVE A
LUNBUMP:	DCX	H	;UNBUMP PTRS
	INR	C
	MOV	A,M	;GET CHAR
	ORA	A	;TEST FOR SPACES
	JM	LUNBUMP	;FOUND IMBEDDED SPACES
	POP	PSW	;RESTORE A AND PSW
	RET
;
;
;CALCULATES PRECEDENCE OR BINDING POWER OF OPERATIONS
;	+ -	2
;	* /	4
;	?	6
;OPERATOR POINTED AT BY HL,PRECEDENCE RETURNED IN A
BIND:	MOV	A,M	;GET OPERATOR
	CPI	'+'	;COMPARE WITH +-*/?
	JZ	BIND2
	CPI	'-'
	JZ	BIND2
	CPI	'*'
	JZ	BIND4
	CPI	'/'
	JZ	BIND4
	CPI	5EH	;UP ARROW DOES NOT COMPUTE
	JZ	BIND6
	MVI	A,0	;PREC = 0 IF NOT OPERATOR
	RET
BIND2:	MVI	A,2	;IF OPERATOR ASSIGN PREC
	RET
BIND4:	MVI	A,4
	RET
BIND6:	MVI	A,6
	RET
;
;
;EVAL EVALUATES EXPRESSIONS. VALUE IS USED TO GET
;A VALUE (WHICH MAY BE A CONST, VAR, ARRAY, FUNCTION,
;OR EXPRESSION IN PARENTHESES).	EVAL THEN OPERATES
;ON THESE VALUES USING THE PROPER PRECEDENCE OF THE
;OPERATORS.
;ON ENTRY B=BINDING POWER (BP) OF PREVIOUS OP (INITIALLY 0)
;ON EXIT A=1 FOR STRING, A<=0 FOR NUMBER
;	C,HL ARE UPDATED
;	DE POINT TO RESULT IF STRING, IF NUMBER
;	RESULT IN AM9511.
EVAL:	MVI	A,'-'	;IS IT UNARY -
	CMP	M	;Z=1 => YES
	PUSH	PSW	;Z=0 => NO
	JNZ	ECAV
	CALL	ICP8	;BUMP POINTER
ECAV:	MOV	A,B
	PUSH	PSW	;SAVE BP
	CALL	VALUE	;GET NEXT VALUE
	CPI	2	;TEST IF STRING RESULT
	JZ	EVSTR	;MOVE STRING TO SREG2
	POP	PSW
	MOV	B,A	;RESTORE BP
	POP	PSW	;RESTORE ZERO FLAG (NEGATE INDICATOR)
	JNZ	DOL	;DO NOT NEGATE
	CALL	CHSF	;CHANGE SIGN OF TOS ON AM9511
DOL:	MOV	A,C	;TEST FOR END-OF-LINE
	ORA	A
	RZ	;RETURN WITH A=0 (INDICATES NUMBER)
	MOV	A,M	;GET OPERATOR
	CALL	BIND	;DETERMINE PRECEDENCE
	CMP	B	;COMPARE BIND(OP) WITH BP
	JZ	ERET	;BIND(OP) = BP
	JC	ERET	;BIND(OP) < BP
	XCHG	;SAVE HL IN DE (AM2HL DESTROYS HL)
	CALL	AM2SP	;PUT VALUE ON 8080 STACK
	XCHG	;RESTORE HL
	PUSH	B	;SAVE BP
	MOV	B,A	;SET NEW BP,PREPARE FOR CALL TO EVAL
	MOV	A,M	;GET OPERATOR
	PUSH	PSW	;SAVE OPERATOR
	CALL	ICP8	;BUMP PTRS
	CALL	EVAL	;EVAL REST OF EXPRESSION
	XCHG	;SAVE HL IN DE
	POP	PSW	;OPERATOR IN A
	POP	H	;BP IN H
	MOV	B,H	;RESTORE BP TO B
	CALL	SP2AM	;PUT 1ST OPERAND ON AM9511
	CALL	XCHF	;PUT OPERANDS IN PROPER ORDER
	XCHG	;RESTORE HL
	CALL	BINOP	;DO OPERATION
	JMP	DOL	;LOOP WHILE BIND(OP) > BP
ERET:	XRA	A	;INDICATE NUMERIC RESULT BY A=0
	RET
ER8:	MVI	A,8
	JMP	ERROR
EVSTR:	POP	PSW	;GET RID OF PRECEDENCE ON STACK
	PUSH	H
	LXI	H,SREG2
	CALL	STD2H	;MOVE STRING TO SREG2
	XCHG
	POP	H	;DE PNTS TO SREG2,HL TOSOURCE
	POP	PSW
	MOV	A,C	;END OF LINE?
	ORA	A
	JZ	ESRET
	PUSH	H
	PUSH	B
	MVI	A,2	;TEST FOR DELIMITER
	CALL	SYMSRT
	POP	B
	POP	H
	INR	A
	JZ	ER8
	CPI	8	;ONLY VALID ENDS FOR STRINGS:
	JNC	ER8	;	<	>	,	= )	;	THEN
ESRET:	MVI	A,1	;INDICATE RESULT IS STRING
	RET
;
;
; THIS ROUTINE PERFORMS BINARY OPERATIONS ON OPERANDS IN FREG1 AND FREG2
; A,B,C,H,L ARE LEFT UNDISTURBED.
; D,E PNT TO RESULT
; OPERATIONS ARE SPECIFIED BY A REGISTER AS FOLLOWS:
;
;	A='*'	=>	OPND1 * OPND2
;	A='/'	=>	OPND1 / OPND2
;	A='+'	=>	OPND1 + OPND2
;	A='-'	=>	OPND1 - OPND2
;	A='?'	=>	OPND1 ? OPND2	(OPND2 ASSUMED INTEGER)
;
; 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 RUN (THE INTERPRETER) IS ABORTED.
;
BINOP:	CPI	'+'
	JZ	ADDD
	CPI	'-'
	JZ	SUBB
	CPI	'*'
	JZ	FMULT
	CPI	'/'
	JZ	DIV
	CPI	5EH	;UP ARROW DOES NOT COMPUTE
	JZ	PWR
	JMP	ER8	;ILLEGAL OP
PWR:	CALL	PWRF
	RET
ADDD:	CALL	FADD
	RET
SUBB:	CALL	FSUB
	RET
FMULT:	CALL	FMUL
	RET
DIV:	CALL	FDIV
	RET
;
;ADJUSTS THE IOFLAG VALUE
;
ADJIO:	LXI	H,IOFLAG
	MOV	A,M	;GET IOFLAG INTO A
	ORA	A	;TEST FOR ZERO
	JZ	ADJ7
	DCR	A	;TEST FOR 1
	JZ	ADJ12
	DCR	A	;TEST FOR 2
	JZ	ADJ12
	DCR	A	;FOR 3
	JZ	ADJ5
	DCR	A	;4
	JZ	ADJ13
	DCR	A	;5
	JZ	ADJ13
	DCR	A	;6
	JZ	ADJ13
	RET
ADJ5:	MOV	A,M	;GET IOFLAG AND THEN
	ADI	5	;ADD A VALUE TO IT AND
	MOV	M,A	;STORE IT AWAY
	JMP	ADCPOS
ADJ7:	MOV	A,M
	ADI	7
	MOV	M,A
	JMP	ADCPOS
ADJ12:	MOV	A,M
	ADI	12
	MOV	M,A
ADCPOS:	MVI	A,1
	STA	CPOS	;INITIALISE CPOS
	RET
ADJ13:	MOV	A,M
	ADI	13
	MOV	M,A
	RET
;
; PRINT PROCESSOR
;
PRI:	CALL	QUITT
	LDA	IOFLAG
	CPI	7	;LOOP UNTIL IOFLAG<7
	JNC	PRI
	LHLD	CPNT
PRIS2:	CALL	BUMP
	MVI	B,0	;SET CHAR CNT
	JNZ	PPTST	;CONTINUE IF MORE
PRIS3:	INR	B	;NOTHING MORE, PAD A NULL
	PUSH	PSW	;SET PSW NON-ZERO(NORMAL PRINT)
	JMP	PEND	;WRITE IT AND CONTINUE
PPTST:	MOV	A,M
	CPI	5BH	;FIRST BRACKET?
	PUSH	PSW	;SAVE IN CASE A PRINT-PROCEED
	JNZ	PLOOP	;NORMAL PRINT
	CALL	IOPVR	;GET PRINT-PROCEED VAR
	JNZ	PPRO	;WE DO A PRINT-PROCEED (VAR=0)
	POP	D	;GET RID OF LOLD PSW
	JMP	PRIS2	;NORMAL PRINT
PPRO:	XCHG
	SHLD	PPVAR	;SAVE PRINT-PROCEED VAR ADDR
	XCHG
	CALL	BUMP
	JZ	PRIS3
PLOOP:	MOV	A,M	;GET CHARACTER
	CPI	'"'	;IS IT "?
	JNZ	EXPRE	;NO
QUOTE:	INX	H	;GET CHARACTER TO A
	DCR	C
	JZ	ER7
	MOV	A,M
	CPI	'"'	;IS IT "?
	JZ	QCHEK
	ORA	A	; CHECK FOR IMBEDDED BLANKS
	JP	QOTOK	; NOPE..
	CMA
	MOV	D,A	; SAVE NUMBER OF SPACES
	ADD	B	; UPDATE CHAR COUNTER
	MOV	B,D	; READY FOR PAD
	MOV	D,A	; SAVE CHAR COUNTER
	MVI	A,' '	; PAD SPACES
	CALL	PAD
	MOV	B,D	; CHAR COUNTER INTO B
	JMP	QUOTE
QOTOK:	INR	B	;INCREMENT CNT
	MOV	D,B	;SAVE IN D
	MVI	B,1	;PAD ONCE
	CALL	PAD
	MOV	B,D	;RESTORE CNT
	JMP	QUOTE	;AGAIN
QCHEK:	CALL	BUMP	;BUMP PNTRS
	JZ	PEND	;EOL
	MOV	A,M
	CPI	'"'	;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	'('	;IS IT THE START OF XPRES
	JZ	PRTIT	;YES
	CPI	'.'	;IS IT A DECIMAL PNT?
	JZ	PRTIT	;YES EVALUATE, PRINT
	CPI	'-'	;IS IT A -?
	JZ	PRTIT	;YES EVALUATE AND PRINT
	CPI	'+'	;IS IT A +?
	JNZ	SCOLN	;NO, CHECK FOR ;
PRTIT:	PUSH	B	;SAVE CNT
	MVI	B,0	;SET INITIAL PRECEDENCE
	CALL	EVAL	;EVALUATE EXPRESION
	DCR	A
	JZ	PRSTR	;PRINT STRING
	PUSH	H
	PUSH	B	;SAVE BC COUNTERS
	MVI	A,2	;LOOK FOR KEYWORD AS
	CALL SYMSRT
	CPI	13	;TEST FOR AS
	JNZ	PSAME	;NO FORMAT, USE 11E4
	POP	PSW	;GET RID OF OLD C, HL
	POP	PSW
	MOV	A,C	;TEST FOR EOL
	ORA	A
	JZ	ER7
	CALL CVB	;GET FIELD WIDTH INTO D
	ORA	A
	JZ	ER8	;ERROR IF NO WIDTH
	CALL DADHL	;UPDATE HL PTRS
	MOV	A,C	;TEST FOR EOL
	ORA	A
	JZ	ER8
	MOV	B,D	;RE-ORDER STACK SO
	POP	D	;WIDTH IS UNDER BC
	PUSH	B	;PUT D ON STACK
	PUSH	D	;NOW PUT B
	MOV	D,B	;RESTORE D
	PUSH	D	;PUT WIDTH ON AGAIN
	MOV	A,M	;TEST FOR TYPE OF FORMAT
	CALL	BUMP
	CPI	'I'
	JZ	IFMT
	CPI	'E'
	JZ	EFMT
	CPI	'F'
	JZ	FFMT
	JMP	ER8
IFMT:	POP	D	;GET WIDTH
	PUSH B	;SAVE HL,C
	PUSH H
	MOV	B,D
	MVI	C,0
FDO:	CALL	FORMT
	JMP	POVER
EFMT:	POP	D
	MOV B,D
	MVI	A,80H
	PUSH	PSW
	JMP	OFMT
FFMT:	POP	D
	MOV	B,D
	MVI	A,40H
	PUSH	PSW
OFMT:	CALL CVB
	ORA	A
	JZ	ER8
	CALL DADHL	;UPDATE PNTS
	POP	PSW
	ORA	D
	PUSH	B
	PUSH	H
	MOV	C,A
	JMP	FDO
PSAME:	POP	B	;RESTORE BC
	POP	H
	XCHG
	MVI	H,11	;STORE WIDTH FOR 11E4
	XTHL
	PUSH	H	;SAVE ON STACK
	XCHG
	PUSH	B	;SAVE HL,C
	PUSH	H
	LXI	B,0B84H	;SET UP FOR 11E4
	JMP	FDO	;PRINT VALUE
POVER:	POP	H	;RESTORE REG'S
	POP	B
	MOV	A,C
	POP	B
	MOV	C,A
	ORA	A	;CHECK EOL
	JZ	PEND1
	POP	PSW	;UPDATE CNTR
	ADD	B
	MOV	B,A
	MOV	A,M	;GET CHAR.
SCOLN:	CPI	';'	;IS IT ;?
	JZ	SONWD	;YES
	CPI	','	;IS IT ,?
	JNZ	ER6	;NO-UNEXPECTED CHAR.
	XRA	A	;ZERO A
ADFLD:	ADI	13	;ADD FIELD LENGTH
	CMP	B	;COMPARE TO CNT
	JZ	LSTFLD
	JNC	FLDFD
LSTFLD:	CPI	52	;LAST FLD?
	JNZ	ADFLD
	MVI	B,1
	MVI	A,0DH	;PAD A CR AND LF
	CALL	PAD
	MVI	A,0AH
	CALL	PAD
	PUSH	H	;SAVE HL BECAUSE ADJIO USES HL
	CALL	ADJIO
	POP	H
	CALL	WRIT	;YES-WRITE LINE
	MVI	B,0	;RESET CNT
	CALL	BUMP	;BUMP PNTRS
	JZ	PEND
	JMP	PLOOP
PRSTR:	POP	PSW	;GET RID OF OLD BC FROM STK
	MOV	B,A	;RESTORE B
	LDAX	D	;GET LENGTH OF STRING
	INX	D
	ORA	A
	JZ	PRSND	;TEST FOR ZERO LEN
	PUSH	H
	MOV	L,A	;SAVE LEN
	ADD	B	;UPDATE COUNT IN B
	MOV	B,A
	PUSH	B	;SAVE BC
	MVI	B,1	;SET B FOR SUBR PAD
PRSLP:	LDAX	D	;GET CHAR
	CALL	PAD	;PUT CHAR IN OBUFF
	INX	D
	DCR	L	;TEST LEN
	JNZ	PRSLP	;REPEAT
	POP	B
	POP	H
PRSND:	MOV	A,C	;CHEK EOL
	ORA	A
	JZ	PEND
	MOV	A,M	;GET NEXT CHAR FROM SOURCE
	JMP	SCOLN	;DETERMINE CARRIAGE CNTRL
FLDFD:	SUB	B	;FOUND FIELD
	MOV	D,B	;DETERMIN	OF SPACES TO PAD
	MOV	E,A	;SET UP TO CALL PAD
	MOV	B,A
	MVI	A,' '
	CALL	PAD	;PAD SPACES
	MOV	A,D
	ADD	E	;NEW CNT
	MOV	B,A	;SAVE IN B
SONWD:	CALL	BUMP	;CHECK EOL
	JNZ	PLOOP
PREND:	CALL	ADJIO
	POP	PSW	;TEST IF NORMAL OR P-PROCEED
	JZ	IEND	;WE HAVE A PRINT-PROCEED
	LXI	H,OBUFF+1	;SET PPVAR TO FREE SPACE
	SHLD	PPVAR	;BECAUSE PRINTING DONE IN QUITT
	MVI	D,1	;SUPPRESS CR/LF
	CALL	WRIT1
	JMP	IEND
PEND1:	POP	PSW	;GET RID OF FIELD WIDTH
PEND:	MVI	B,1
	MVI	A,0DH	;PUT CR AND LF AT END OF BUFF
	CALL	PAD
	MVI	A,0AH
	CALL	PAD
	JMP	PREND	;GO PRINT BUFFER
;
; 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
	CALL	ICP7
	MOV	A,M	;LOOK FOR FIRST BRACKET
	CPI	5BH	;INPUT AND PROCEED????
	JZ	IPROC	;YES
PRMPT:	PUSH	B	;SAVE PNTR'S
	PUSH	H
INLOP:	CALL	QUITT	;LOOP UNTIL IOFLAG=0
	LDA	IOFLAG
	ORA	A
	JNZ	INLOP
	MVI	B,1	;SEND PROMPT
	MVI	A,'?'
	MOV	D,B	;TO SUPPRESS CR/LF
	CALL	PAD	;PAD IT
	MVI	A,' '
	CALL	PAD	;PROMT IS A '? ' (TWO CHAR)
	CALL	WRIT1	;WRITE IT
	LXI	H,IBUF	;ADD. OF INPUT BUFFER
	CALL	TTYIN	;READ A LINE
	INX	H	;PT TO DATA
	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 CONSTANTS TO VARIBLES
	JZ	IEND	;NO ERROR
	LXI	H,ODAT7	;SEND ERROR MESSAGE
	CALL	FORM
	CALL	WRIT
	LDA	PL6	;GET V-STRING CNT
	MOV	C,A
	JMP	INPER	;START AGAIN
IPROC:	CALL	IOPVR	;GET IO-PROCEED VAR
	PUSH	PSW
	CALL	ICP7	;BUMP PASSED 2ND BRACKET
	POP	PSW	;RETAIN PSW FROM IOPVR
	JZ	PRMPT	;VAR = 0. NORMAL INPUT
	SHLD	IPVPT	;SAVE PT TO VAR LIST
	XCHG
	SHLD	IPVAR	;SAVE INPUT-PROCEED VAR ADDR
	MOV	A,C
	STA	IPVLN	;SAVE LENGTH OF VAR LIST
IPTST:	CALL	QUITT
	LDA	IOFLAG
	ORA	A
	JZ	IFO1
	CPI	7
	JNZ	IPTST
	MVI	A,11	;PROMPT AFTER PRINTING
	STA	IOFLAG
	JMP	IEND
IFO1:	INR	A	;DO PROMPT
	STA	IOFLAG
IEND:	LHLD	KFPNT	;ALL OK - GET NEW PNTR.
	JMP	ILOOP	;CONTINUE
IOPVR:	CALL	ICP2
	CALL	VAR
	JNC	ER2	;NOT A VARIABLE IN ^[
	ORA	A
	JNZ	ER2	;MUST BE A SIMPLE VAR
	MOV	A,M
	CPI	5DH	;CHECK FOR FINAL BRACKET
	JNZ	ER2
	XCHG	;POINT TO VAR WITH HL
	CALL	HL2AM	;PUT VAR ON AM9511
	CALL	XCHF
	CALL	XCHF
	CALL	STATUS
	XCHG	;RESTORE HL
	RET
ER2:	MVI	A,2
	JMP	ERROR
;
; 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=1	ALL OK
;	Z=0	ERROR IN CONVERSION OR
;	NUMBER OF CONSTANTS
;
; ALL POINTERS AND LINE CNT'S ARE RETURNED UPDATED
;
STRIN:	MOV	A,C	;GET V-STRING CNT
	ORA	A	;TEST FOR EOL
	JZ	STDNE	;DONE? TEST IF CONSTANTS DONE
	MOV	A,M	;GET CHAR.
	CPI	','	;IS IT A ,?
	JNZ	STOKV	;IT'S NOT A ,
	CALL	BUMP	;COMMA, BUMP PNTR'S
	JZ	ERRET	;POSSIBLE ERROR (IF EOL)
STOKV:	MOV	A,B	;GET K-STRING LENGTH
	ORA	A	;TEST FOR EOL
	JNZ	STOK1
	INR	A	;NOT ENOUGH CONSTANT DATA
	RET
STOK1:	LDAX	D	;GET CHAR
	CPI	','	;TEST FOR ,
	JNZ	STOKK	;NOT A , - READY TO GO
	INX	D	;BUMP PNTR'S
	DCR	B
	JZ	ERRET	;POSSIBLE ERROR (IF EOL)
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
	CPI	2	;IS IT STRING VAR?
	JZ	STINP	;INPUT STRING VALUE
	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
STDNE:	MOV	A,B	;GET K-LEN
	ORA	A
	RET	;OK IF ZERO, ELSE ERROR
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
STINP:	MOV	A,C	;SAVE V-LEN
	POP	B	;RESTORE K-LEN TO B
	PUSH PSW	;SAVE V-LEN
	PUSH D	;SAVE V-PTR
	XCHG	;LOAD DE WITH K-PTR
	LHLD VARAD	;GET V-ADDR
	CALL BSTRG	;SET VAR TO BLANKS
	XCHG	;DE=V-ADDR, HL=K-PTR
	MVI C,0	;INITIAL CHAR COUNT
	PUSH D	;SAVE V-ADDR
	INX D	;STEP PASSED LENGTH
SINP2:	MOV A,M	;GET CHAR
	CPI ','	;LOOK FOR ,
	JZ SINP3	;DONE
	CPI ' '	;IS IT A SPACE
	JNZ SILLY	;SKIP SPACES
	INX	H	;MOVE PTR TO SKIP SPACES
	DCR	B
	JMP	SINP2
SILLY:	CPI '"'
	JNZ SINQU	;STRING WITHOUT QUOTE MARKS
SINP4:	INX H
	DCR B
	JZ SERRET	;ERROR IF CONST LIST ENDS HERE
	MOV A,M	;GET CHAR
	CPI '"'
	JNZ SSSVE	;SAVE CHAR
	INX H
	DCR B
	JZ SINP3	;DONE IS CONST LIST ENDS HERE
	MOV A,M	;GET CHAR, CHECK IF " " (DOUBLE ")
	CPI '"'
	JNZ SINP3	;END OF STRING, MOVE PTS BACK
SSSVE:	INR C
	MOV A,C
	CPI (LENST AND 0FFH)+1
	JZ SERRET	;STRING TOO LONG
	MOV	A,M	;RESTORE CHAR
	CPI	':'	; TEST FOR COLON
	JNZ	SSSV2
	MVI	A,13H	; CONTROL-S IS SUBST CHAR FOR :
SSSV2:	STAX	D	; SAVING CHAR IN DE POINTER
	INX D
	JMP SINP4
SINP3:	POP D	;GET V-ADDR
	MOV A,C
	STAX D	;STORE LEN OF STRING
	XCHG	;PUT K-PTR IN DE
	POP H	;PUT V-PTR IN HL
	POP PSW	;GET V-LEN IN A
	MOV C,A	;PUT V-LEN IN C
	JMP STRIN	;ARE THERE MORE VARIABLES?
SINQU:	INR C
	MOV A,C	;TEST LENGTH
	CPI (LENST AND 0FFH)+1
	JZ	SERRET	;NO ROOM
	MOV	A,M	;RESTORE CHAR LOST IN TEST
	CPI	':'
	JNZ	SINQZ	; CONTROL-S IS SUBST CHAR FOR :
	MVI	A,13H
SINQZ:	STAX	D	; SAVING CHAR
	INX D
	JMP SINQ2	;STILL ROOM
SINQ3:	INX H	;LOOP UNTIL COMMA OR EOL
	DCR B	;IF NON-SPACES THEN ERROR
	JZ SINQD	;DONE
	MOV A,M	;GET CHAR
	CPI ','	;IS IT A COMMA
	JZ SINQD	;DONE
	CPI ' '	;IS IT A SPACE
	JZ SINQ3	;REPEAT
	JMP SERRET	;NON-SPACE SO IT IS AN ERROR
SINQ2:	INX H
	DCR B
	JZ SINQD	;DONE
	MOV A,M	;TEST FOR COMMA
	CPI ','
	JNZ SINQU	;REPEAT
SINQD:	MVI A,LENST AND 0FFH
	MOV C,A	;NEED TO DELETE TRAILING SPACES
	POP D	;GET PTR TO START OF STRING
	PUSH D	;SAVE IT AGAIN
	XCHG	;SAVE K-PTR IN DE
	CALL DADHL	;HL PT TO END OF STRING
SINQ4:	MOV A,M	;LOOP UNTIL NON-SPACE
	CPI ' '
	JNZ SINQ5	;GOT A NON-SPACE
	DCX H
	DCR C	;NO NEED TO TEST IF C=0
	JMP SINQ4	;REPEAT
SINQ5:	XCHG	;RESTORE HL
	JMP SINP3	;STORE LEN INFO
SERRET:	POP PSW	;EMPTY STACK
	POP PSW
	POP PSW
	JMP ERRET	;ERROR RETURN
;
; LET STMT. PROCESSOR
;
LET:	LHLD	CPNT	;GET PNTR.
	CALL	BUMP	;FIX PNTR.
	JNZ	LOK
ER7:	MVI	A,7
	JMP	ERROR
LOK:	CALL	VAR	;GET ADDRESS TO VAR.
	MOV	B,A	;SAVE TYPE OF VARIABLE
	JC	SAVV	;IT'S A VARIABLE
	MVI	A,3	;NO-CHEK FOR FUNC.
	CALL	SYMSRT
	CPI	377Q
	JZ	ER1	;DON'T KNOW WHAT IT IS
	DCR	A
	JNZ	ER10	;ILLEGAL USE OF FUNC.
	MOV	A,C	;EOL CHK
	ORA	A
	JZ	ER7
	MOV	A,M	;CHEK FOR (
	CPI	'('
	JNZ	ER7
	CALL	ICP7	;BUMP PNTRS
	MVI	B,0	;SET INTIAL PRECEDENCE
	CALL	EVAL	;EVALUATE AND FIX
	CALL	FIXD	;FIX PORT NUMBER
	XCHG	;SAVE HL IN DE
	LXI	H,FREG1
	CALL	AM2HL	;PUT PORT NUMBER INTO FREG
	XCHG	;RESTORE HL
	INX	D
	INX	D
	INX	D
	LDAX	D	;GET LOWEST BYTE
	PUSH	PSW	;PORT # IS SAVED
	MOV	A,M
	CPI	')'	;CHECK FOR )
	JNZ	ER7
	CALL	ICP7	;BUMP PNTR'S
	MVI	D,377Q
	MOV	E,D
	MVI	B,0	;SET TYPE TO NUMBER
SAVV:	PUSH	D	;KEEP ADDRESS
	MOV	A,M	;CHEK FOR =
	CPI	'='
	JNZ	ER7
	CALL	ICP8	;BUMP PNTRS
	PUSH	B	;SAVE TYPE IN B
	MVI	B,0	;SET INITIAL PRECEDENCE
	CALL	EVAL	;EVALUATE EXPRESSION
	POP	B	;RESTORE TYPE OF LEFT SIDE IN B
	POP	H	;GET ADDRESS
	CPI	1	;TEST IF RT SIDE IS STRING
	JZ	LTSR
	MOV	A,B
	CPI	2
	JZ	ER8	;BOTH SIDES MUST BE SAME TYPE
	CALL	CHK1
	JC	PTFIN	;IT WAS A PUT
	CALL	AM2HL	;COPY TO ADDRESS
	JMP	IEND	;CONTINUE
PTFIN:	CALL	FIXD	;FIX VALUE TO BE PUT
	LXI	H,FREG1	;COPY VALUE TO FREG1
	CALL	AM2HL
	XCHG
	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 DATA OUT TO A
	DCX	H	;TRANSFER
	PCHL
PINST:	OUT	0	;RAM INSTRUCTIONS
	JMP	IEND
LTSR:	MOV	A,B
	CPI	2
	JNZ	ER8	;BOTH SIDES MUST BE STRINGS
	CALL	STD2H	;COPY STRING
	JMP	IEND
ER10:	MVI	A,10H
	JMP	ERROR
;
; IF STMT. PROCESSOR
;
IFRT:	LHLD	CPNT	;GET PNTR., ADJUST
	CALL	ICP7
	MVI	B,0	;SET INITIAL PRECEDENCE
	CALL	EVAL	;EVALUATE EXPRESSION
	STA VTYPE	;SAVE TYPE
	CPI 1	;IS VALUE A STRING
	JNZ IFRT2	;NO,VALUE IS NUMBER
	PUSH D	;SAVE DE,HL
	PUSH H
	LXI D,SREG2
	LXI H,SREG1
	CALL STD2H	;MOVE STRING TO SREG1
	POP H
	POP D
	JMP IFRT3	;GET DELIMITER
IFRT2:	MOV	A,C
	ORA	A	;CHECK EOL
	JZ	ER7
	XCHG	;SAVE HL
	CALL	AM2SP	;PUT VALUE ON 8080 STACK
	XCHG	;RESTORE HL
IFRT3:	MVI	A,2
	CALL	SYMSRT	;CHEK TYPE OF RELATION
	CPI	4	;WAS IT LEGAL?
	JC	II1
ER14:	MVI	A,14H
	JMP	ERROR
II1:	CPI	2	;WAS IT A ,?
	JZ	ER14
	INR	A	;ALL OK, INC,SAVE
	PUSH	PSW
	MOV	A,C	;CHECK FOR EOL
	ORA	A
	JZ	ER7
	MVI	A,2	;CALL SYMSRT
	CALL	SYMSRT
	CPI	377Q	;FOUND ANYTHING?
	JZ	RELAT	;DONE
	CPI	2
	JZ	ER14	;IT WAS A ,
	CPI	4
	JNC	ER14	;NOT LEGAL
	INR	A
	MOV	B,A
	MOV	A,C	;CHECK FOR EOL
	ORA	A
	JZ	ER7
	POP	PSW	;GET SECOND RELATION
	ADD	B	;ADD THEM
	PUSH	PSW	;AND SAVE
	CPI	10Q	;TEST FOR ==
	JZ	ER14
;
; AT THIS POINT:
; RELATION IS STORED ON TOP OF STACK (PUSH PSW) ACCORDING TO
; THE FOLLOWING
;
;	1 =>	<
;	2 =>	>
;	3 =>	<>
;	4 =>	=
;	5 =>	<=
;	6 =>	>=
;
RELAT:	MVI	B,0	;SET INITIAL PRECEDENCE
	CALL	EVAL	;EVALUATE
	CPI 1	;2ND VALUE A STRING?
	JZ IFST1	;YES
	LDA VTYPE ;GET TYPE OF 1ST VALUE
	CPI 1
	JZ ER8	;BOTH MUST BE SAME
	JMP RELA2 ;BOTH ARE NUMBERS
IFST1:	LDA VTYPE
	CPI 1	;TEST TYPE OF 1ST VALUE
	JNZ ER8	;BOTH MUST BE SAME
	XTHL
	PUSH H	;PUT HL PTR UNDER OLD TOP OF ST.
	LXI D,SREG1
	LXI H,SREG2
	CALL STCMP	;COMPARE SREG1 AND SREG2
	MOV D,A	;SAVE RESULT
	POP PSW	;GET RELATION
	JMP RELA3	;TEST IF REL IS TRUE OR FALSE
RELA2:	POP	PSW	;GET RELATION
	XCHG	;SAVE HL
	CALL	SP2AM	;PUT ON 1ST OPERAND
	PUSH	D	;SAVE HL
	PUSH	PSW	;SAVE RELATION
	CALL	FCOMP	;COMPARE NUMBERS
	MOV	D,A	;SAVE RESULT IN D
	POP	PSW	;GET RELATION,B,C
RELA3:	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
;
; COMPARES STRING POINTED TO BY DE, HL
; RETURNS RESULT IN A REG.
; A=1	->	DE<HL
; A=2	->	DE>HL
; A=4	->	DE=HL
;
STCMP:	PUSH B	;SAVE BC
	LDAX D
	CMP M	;COMPARE LENGTHS OF STRINGS
	PUSH PSW	;SAVE LENGTH COMPARISON
	INX D	;SKIP OVER LEN INFO
	MOV B,M
	INX H
STCLP:	LDAX D	;GET CJAR FROM DE
	CMP M	;COMPARE TO HL CHAR
	JNZ STCND	;UNEQUAL STRINGS
	INX D	;BUMP PTRS
	INX H
	DCR B	;DECR CNT
	JNZ STCLP	;NOT DONE YET
	POP PSW	;CHECK LENGTHS
	JNZ STCN2	;UNEQUAL LENGTHS
	MVI A,4	;STRING EQUAL
	POP B	;RESTORE BC
	RET
STCND:	POP B	;GET RID OF LENGTH COMPARISON
STCN2:	POP B	;RESTORE BC
	MVI A,1	;SET A=1
	RC	;RET IF DE<HL
	INR A	;SET A=2
	RET	;RET FOR DE>HL
;
; ROUTINE FCOMP COMPARES 2 FLOATING POINT #'S.THEY ARE ASSUMED
; TO BE ON THE AM9511 STACK (THE SECOND OPND PUSHED 1ST)
; THE VALUE RETURNED IN REG A IS RESULT OF COMPARISON.
; RESULTS ARE AS FOLLOWS:
;
;	A=1	=>	OPND1 < OPND2
;	A=2	=>	OPND1 > OPND2
;	A=4	=>	OPND1 = OPND2
;
FCOMP:	CALL	FSUB	;SUBRTRACT OPNDS (OPND2-OPND1)
	CALL	STATUS	;GET STATUS OF RESULT
	JZ	COMP4
	JP	COMP1	;SET A TO CORRECT VALUE
	MVI	A,2
	RET
COMP1:	MVI	A,1
	RET
COMP4:	MVI	A,4
	RET
;
; CALL PROCESSOR
;
CALLP:	LXI	H,IEND	;INIT RETURN ADDRESS
	PUSH	H
	LHLD	CPNT	;INIT POINTERS
	CALL	ICP7
	MOV	A,M	;GET CHAR
	CPI	'('	;IS IT A (?
	JNZ	ER7	;BAD
	CALL	ICP7	;BUMP PNTRS
	CALL	CVB	;GET SUB
	CALL	DADHL	;UPDATA H,L
	PUSH	H	;SAVE HL
	LHLD	USUB	;GET START OF SUB TABLE
NUSUB:	MOV	A,M	;GET ENTRY
	CMP	D	;COMPARE
	JZ	FNDSB	;FOUND IT
	INX	H	;PNT TO NEXT ENTRY
	INX	H
	INX	H
	INR	A	;CHECK TO SEE IF LAST WAS 377Q
	JNZ	NUSUB
	MVI	A,15H	;ER 15 - NO SUB BY THIS #
	JMP	ERROR
FNDSB:	INX	H	;FOUND IT,GET STARTING ADD.
	MOV	E,M
	INX	H
	MOV	H,M
	MOV	L,E	;AND SAVE IT
	SHLD	SBSAV
	LXI	H,0	; INITIALIZE TEMP VAR NAMES
	SHLD	MESCR
	POP	H	;GET SOURCE PNTR BACK
PARLP:	MOV	A,M	;GET CHAR
	CPI	')'	;IS IT )?
	JZ	CLSUB	;YES - GO CALL SUB
	CPI	','	;DO WE HAVE A ,?
	JNZ	ER6	;UEXPECTED CHARACTER
	CALL	ICP7	;BUMP PNTRS
	PUSH	H
	PUSH	B
	CALL	VAR	;DO WE HAVE A VARIABLE
	JNC	PREXR	;NO
	MOV	A,M	; TEST IF ACTUALLY AN EXPR.
	CPI	')'
	JZ	PREXV
	CPI	','
	JNZ	PREXX
PREXV:	POP	PSW
	POP	PSW
	PUSH	D	;YES - SAVE ADDRESS
	JMP	PARLP	;CONTINUE
PREXX:	POP	B
	POP	H
	JMP	PREXP
PREXR:	POP	PSW
	POP	PSW
PREXP:	MVI	B,0	;SET INITIAL PRECEDENCE
	CALL	EVAL	;EVALUATE EXPRESSION
	PUSH	B	; SAVE C-REG
	PUSH	H	;SAVE H,L
	CPI	1	;TEST FOR STRING CONSTANT
	JZ	PARMST	;YES IT IS
	MVI	B,'%'	; GENERATE NUMERIC NAME
	LDA	MESCR
	INR	A
	STA	MESCR
	MOV	C,A
	CALL	FSYM
	CALL	AM2HL	;AND COPY TO IT
PCONT:	POP	D	;HL TO DE
	POP	B	; RESTORE C-REG
	PUSH	H	;SAVE ADDRESS
	XCHG	;GET H,L BACK
	JMP	PARLP	;CONTINUE
PARMST:	MVI	B,'$'	; GENERATE TEMP STRING VAR
	LDA	MESCR+1
	INR	A
	STA	MESCR+1
	MOV	C,A
	CALL	FSYM
	CALL	STD2H	;COPY STRING
	JMP	PCONT	;STD2H RETURNS LEN IN A
CLSUB:	LHLD	SBSAV	;START OF ROUTINE
	PCHL	;TRANSFER
;
; GOSUB 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
	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
	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	NOTNUM	;NO
	MOV	C,M	;YES, GET IT
	INX	H	;BUMP PNTR'S
	DCR	D
	JZ	ER7	;PREMATURE EOL
NOTNUM:	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	'='
	JNZ	ER16
	CALL	ICP7	;BUMP PNTR'S
	MVI	B,0	;SET INITIAL PRECEDENCE
	CALL	EVAL	;EVALUATE EXPRESSION
	XTHL	;VARIABLE LOCATION
	CALL	AM2HL	;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
	MOV	A,C	;CHECK EOL
	ORA	A
	JZ	ER7
	MVI	B,0	;SET INITIAL PRECEDENCE
	CALL	EVAL	;EVALUATE LIMIT
	PUSH	H	;SAVE H,L
	LXI	H,FLIMT	;SAVE LIMIT VALUE
	CALL	AM2HL
	MOV	A,C	;CHECK EOL
	ORA	A
	JNZ	STP
	LXI	H,FONE	;DEFAULT STEP = 1
	CALL	HL2AM	;PUT ON AM9511
	POP	H	;RESTORE H,L
	JMP	FBILD
STP:	POP	H	;GET H,L
	MVI	A,2	;LOOK FOR 'STEP'
	CALL	SYMSRT
	CPI	8
	JNZ	ER17
	MOV	A,C	;TEST FOR EOL
	ORA	A
	JZ	ER7
	MVI	B,0	;SET INITIAL PRECEDENCE
	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 ON THE TOP OF THE AM9511 STACK
; H,L,C ARE POINTER, COUNTER AS USUAL
;
FBILD:	LHLD	VNAME	;GET VARIABLE NAME
	MVI	A,77Q	;MASK
	ANA	H	;MASK OFF TOP 2 BITS
	MOV	B,A	;SET UP TO CALL FSYM
	MOV	C,L
	CALL	FSYM	;FIND ENTRY
	JC	FEXST	;IT WAS THERE
	PUSH	H	;IT WASN'T, SAVE H,L
	LHLD	NXTSP	;UPDATE NXTSP
	MVI	A,8	;ADD 8 TO H,L
	CALL	DADHL
	SHLD	NXTSP	;NEW VALUE OF NXTSP
	CALL	MEMFUL	;CHECK MEMORY
	POP	H	;GET ADD. IN DATA BLOCK
FEXST:	CALL	AM2HL	;STORE STEP SIZE
	INX	H	;PNT 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	;PNT 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 AND 377Q	;NEED ONLY COMPARE PAGE LOCATION
	JZ	ER18	;FOR'S NEXTED TOO DEEPLY
	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	;ALL DONE
;
; NEXT STATEMENT PROCESSOR
;
NEXT:	LHLD	CPNT	;FIX PNTR'S
	CALL	ICP7
	CALL	ALPHA	;LETTER?
	JNC	ER21	;NO, ERROR
	MOV	B,M	;YES, GET IT
	CALL	BUMP	;INCR PTRS (IF C=0, ALL SET FOR FSYM)
	JZ	NEXT1
	CALL	NUMB	;NUMBER?
	JNC	ER21	;NO, ERROR
	MOV	D,M	;YES, GET IT
	CALL	BUMP	;SHOULD BE EOL
	JNZ	ER21
	MOV	C,D	;RESTORE C
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 AND 377Q
	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
	MOV	A,C
	CMP	L
	JNZ	ER20
	LHLD	VLOC	;ALL OK, RESTORE OLD SP
	SPHL
	MVI	A,77Q	;MASK
	ANA	B	;MASK OUT TOP 2 BITS
	MOV	B,A
	CALL	FSYM	;FIND SYMBOL
	CALL	HL2AM	;PUT STEP ON AM9511
	MVI	A,2
	CALL	XCHF
	CALL	XCHF
	CALL	STATUS
	JM	NEXT2
	MVI	A,1	;SET A=2 IF STEP NEG, ELSE A=1
NEXT2:	STA	VLOC
	MVI	A,4	;PT TO VARIABLE PTR
	CALL	DADHL
	MOV	E,M
	INX	H
	MOV	D,M
	INX	H
	PUSH	H	;SAVE DATA BLOCK PNTR.
	XCHG
	CALL	HL2AM	;PUT VARIABLE ON AM9511
	CALL	FADD	;ADD STEP TO VARIABLE
	CALL	PTOF	;MAKE TWO COPIES OF RESULT
	CALL	AM2HL	;COPY TO VARIABLE
	POP	H	;PNT TO LIMIT
	CALL	HL2AM
	PUSH	H	;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
ER9:	MVI	A,9
	JMP	ERROR
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:	LHLD	VLOC	; REESTABLISH STACK-POINTER
	SPHL
	MVI	A,20H	;NESTING ERROR, 'FOR'-'NEXT'
	JMP	ERROR
ER21:	MVI	A,21H	;BAD INDEX IN FOR-NEXT
	JMP	ERROR
;
;
; ROUTINE TO DUMP OUTPUT BUFFER TO TTY.
WRIT:	MVI	D,0
WRIT1:	PUSH	PSW
	PUSH	H
	PUSH	B
	LXI	H,OBUFF	;GET OBUFF ADDR.
	PUSH	H
	LDA	IOFLAG
	ORA	A	;TEST FOR ZERO
	JNZ	WRTIO	;GO USE QUITT TO WRITE
	MOV	C,M	;GET NUMB. OF CHAR.
	DCR	C	;IS OBUFF EMPTY
	JZ	W2
	INX	H
W1:	MOV	A,M	;MOVE CHAR.
	CALL	SEND	;PRINT
	INX	H	;MOVE TO NEXT CHAR.
	DCR	C
	JNZ	W1
	DCR	D
	JZ	W2
	MVI	A,15Q	;PUT OUT CR. LF.
	CALL	SEND	;PRINT
	MVI	A,12Q
	CALL	SEND	;PRINT
W2:	POP	H
	MVI	M,1
	POP	B
	POP	H
	POP	PSW
	RET
WRTIO:	LXI	H,IOFLAG	;PUT ADDR OF IOFLAG IN HL
WRLOP:	CALL	QUITT	;USE QUITT TO DO PRINT
	MOV	A,M	;GET IOFLAG
	CPI	7
	JNC	WRLOP	;LOOP WHILE IOFLAG < 7
	JMP	W2
;
;	FILL BUFFER
;	HL=PTR TO LEN OF INPUT BUFFER
;	RETURNS WITH BUFFER LENGTH IN B, CY=0 MEANS DONE,
;	CY=1 MEANS MORE TO COME
;
BFILL:	PUSH	H
	CALL	CHAR2
	POP	H
	RC	;RETURN IF CANNOT GET CHAR
BFILX:	PUSH	H	;ENTRY WHEN CHAR ALREADY HAD
	PUSH	PSW	;SAVE START OF STMT AND CHAR
	MOV	A,M	;GET LEN
	MOV	B,A	;SAVE LEN
	INX	H
	CALL	DADHL	;PT TO NEXT LOC IN BUFFER
	CALL	MEMFUL
	POP	PSW	;GET CHAR AGAIN
	CPI	0DH	;CR?
	JZ	BFDONE
	CPI	0AH	;LF?
	JZ	BFMORE
	CPI	0CH	;FF?
	JZ	BFMORE
	CPI	0	;NULL?
	JZ	BFMORE
	CPI	7FH	;RUBOUT? (CHAR DELETE)
	JZ	BFCHAR
	CPI	19H	;CONTROL Y? (LINE DELETE)
	JZ	BFLINE
	CPI	13H	;CONTROL S
	JZ	STOPS
BFSTORE:	MOV	M,A	;PUT CHAR IN BUFF
	CALL	ECHO
	INR	B	;INCR LEN
	MOV	A,B
	CPI	70	;IS LEN OF LINE>=70
	JZ	BFDONE
BFMORE:	POP	H
	MOV	M,B	;STORE LEN
	STC	;INDICATE MORE TO COME
	RET
BFCHAR:	MVI	A,5FH	;BACK ARROW '_'
	JMP	BFSTORE
BFLINE:	MVI	A,5CH	;BACK SLASH ' '
	JMP	BFSTORE
BFDONE:	MVI	A,0DH
	MOV	M,A	;PUT CR IN BUFFER
	CALL	ECHO
	INX	H
	MVI	A,0AH
	MOV	M,A	;PUT LF IN BUFFER
	CALL	ECHO
	INR	B
	INR	B
	POP	H	;PUT LENGTH IN IBUF
	MOV	M,B
	ORA	A	;CLEAR CY TO MEAN DONE
	RET
TTYBF:	PUSH	D	;SAVE REGS
	PUSH	B
	PUSH	H
	MVI	C,0
	INX	H	;INITAILIZE CTNR AND PTR
	MOV	D,H
	MOV	E,L	;SET DE=HL BOTH PT TO START
TTLOOP:	MOV	A,M	;GET CHAR
	INX	H
	CPI	0DH	;CR?
	JZ	TBFDN	;YES, ALL DONE
	CPI	0AH	;LF?
	JZ	TTLOOP	;IGNOR
	CPI	5CH	;BACK SLASH ' ' (LINE DELETE)
	JZ	TTLINE
	CPI	5FH	;BACK ARROW (CHAR DELETE)
	JZ	TTCHAR
	STAX	D	;SAVE CHAR IN BUFFER
	INX	D	;BUMP NEW BUFF PTRS
	INR	C
	JMP	TTLOOP	;REPEAT
TTLINE:	POP	D	;RESET NEW BUFFER PTR TO BEGINNING
	PUSH	D
	INX	D
	MVI	C,0	;SET LEN TO ZERO
	JMP	TTLOOP	;REPEAT
TTCHAR:	MOV	A,C
	ORA	A	;TEST IF A START OF LINE
	JZ	TTLOOP	;NO CHAR TO DELETE
	DCX	D	;DELETE CHAR BY DECR PTR AND CTR
	DCR	C
	JMP	TTLOOP	;REPEAT
TBFDN:	POP	H	;SAVE LENGTH
	MOV	M,C
	POP	B
	POP	D
	RET
ECHO:	PUSH	H	;SAVE HL
	MOV	H,A	;SAVE CHAR
	LDA	IOFLAG
	ORA	A	;ONLY ECHO IS NOTHING HAPPENING (0)
	MOV	A,H	;RESTORE CHAR
	POP	H	; AND HL
	RNZ
	CALL	SEND
	RET
;
CPOS1:	MVI	A,1	;SET CPOS TO 1
	STA	CPOS
	RET
;
;
;QUITT WILL LOOK FOR CONTROL S AND ALSO HANDLE
;THE SIMULATED INTERRUPT BY MEANS OF A SPECIAL
;FLAG CALLED IOFLAG.	THE VALUES THAT THE FLAG TAKES
;ON AND THE MEANING IS GIVEN BELOW.
;
;IOFLAG	MEANING
;	0	NOTHING HAPPENING
;	1	OUTPUT A ?	(START OF PROMPT)
;	2	OUTPUT SPACE
;	3	WAIT FOR INPUT TO START
;	4	INPUTTING
;	5	DUMP INPUT BUFFER WHILE INPUTTING
;	6	DUMP INPUT BUFFER (INPUT COMPLETE)
;	7	PRINT
;	8	PRINTING WHILE WAITING FOR INPUT
;	9	PRINTING WHILE INPUTTING
; 10	PRINTING WHILE INPUTTING BUT INPUT COMPLETE
; 11	PRINTING THEN DO PROMPT
; 12	PRINTING THEN DO ERROR ON INPUT MESSAGE
; 13	PRINT AFTER ?
; 14	PRINT AFTER SPACE
; 15	PRINT AFTER RETURN
; 16	PRINT AFTER LINE FEED
; 17	PRINT AFTER INPUT COMPLETE
; 18	PRINT AFTER INPUT COMPLETE, CURRENTLY
;	DUMPING INPUT BUFFER
; 19	PRINT AFTER INPUT COMPLETE, CURRENTLY
;	DUMPING INPUT BUFFER BUT INPUT IS
;	COMPLETE
;
QUITT:	PUSH	PSW	;SAVE A
	LDA	IOFLAG	;GET I/O FLAG
	ORA	A
	JNZ	IOTST	;SOMETHING HAPPENING, GO TEST
CNTRS:	CALL	CHAR2	;TRY TO GET INPUT CHAR
	JC	TOUT	;NO CHAR INPUT
	CPI	13H	;IS IT A CNTRL S
	JZ	STOPS	;YES, STOP EXECUTION
TOUT:	POP	PSW	;RESTORE A
	RET
IOTST:	PUSH	B	;SAVE ALL REGS
	PUSH	D
	PUSH	H
	LXI	H,IODNE	;SET RETURN ADDR TO IODNE
	PUSH	H
	ADD	A	;DOUBLE IOFLAG
	LXI	H,IOTAB	;GET START OF IOFLAG TABLE
	CALL	DADHL	;CALC JUMP TABLE ADDR
	MOV	A,M
	INX	H
	MOV	H,M
	MOV	L,A
	PCHL	;TRANSFER TO IO OPER.
IOTAB:	DW	CNTRS	;IOFLAG=0
	DW	IOF1	;IOFLAG=1
	DW	IOF2	;ETC.	FOR DESCIPTIONS
	DW	IOF3	;OF IOFLAG VALUES SEE
	DW	IOF4	;QUITT COMMENTS
	DW	IOF5
	DW	IOF6
	DW	IOF7
	DW	IOF8
	DW	IOF9
	DW	IOF10
	DW	IOF11
	DW	IOF12
	DW	IOF13
	DW	IOF14
	DW	IOF15
	DW	IOF16
	DW	IOF17
	DW	IOF18
	DW	IOF19
IOF1:	MVI	A,'?'
	CALL	MSGO	;OUTPUT A ?
	RC	;NOT ABLE TO
	MVI	A,2
	STA	IOFLAG	;IOFLAG 1=>2
	RET
IOF2:	MVI	A,' '
	CALL	MSGO	;OUTPUT A SPACE
	RC
	MVI	A,3
	STA	IOFLAG	;IOFLAG 2=>3
	RET
IOF3:	CALL	CHAR2
	RC	;NO CHAR
	MOV	B,A	;SAVE CHAR
	MVI	A,5
	STA	IOFLAG	;IOFLAG 3=>5
	CALL	CPOS1
	MOV	A,B	;RESTORE CHAR TO A
	LXI	H,IBUF
	MVI	M,0	;SET LEN IBUF TO ZERO
	CALL	BFILX	;ENTER BFILL AFTER CHAR2
	JNC	IOF4E	;NO CHAR ON INPUT LINE IS AN ERROR
	RET
IOF4:	CALL	CHAR2
	RC
	MOV	B,A
	MVI	A,5
	STA	IOFLAG	;IOFLAG 4=>5
	MOV	A,B
	LXI	H,IBUF
	CALL	BFILX
	RC	;NOT END OF LINE
	MVI	A,6
	STA	IOFLAG	;IOFLAG 4=>6
	RET
IOF4X:	CALL	IOF4S
	RZ
IOF4E:	XRA	A
	STA	IOFLAG	;ENABLE WRIT TO OUTPUT MESSAGE
	LXI	H,ODAT7
	CALL	FORM
	CALL	WRIT	;WRITE ERROR MESSAGE
	MVI	A,1
	STA	IOFLAG	;IOFLAG	=>1	FOR PROMPT
	RET
IOF4S:	LXI	H,IBUF
	MOV	B,M	;K-STRING LEN TO B
	INX	H
	XCHG	;K-STRING ADDR TO DE
	LHLD	IPVPT	;V-STRING ADDR TO HL
	LDA	IPVLN
	MOV	C,A	;V-STRING LEN TO C
	CALL	STRIN
	RNZ	;ERROR ON INPUT
	LHLD	IPVAR	;ADDR OF INPUT-PROCEED VAR
	LXI	D,FZERO
	CALL	COPDH	;SET VAR=0
	XRA	A
	STA	IOFLAG	;IOFLAG 4=>0
	RET
FZERO:	DB	0,0,0,0	;A FLOATING POINT ZERO
ODAT7:	DB	24,'INPUT ERROR, TRY AGAIN',0DH,0AH
IOF5:	CALL	IOF5S	;DUMP CHAR FROM INPUT BUFFER
	JC	IOF5I	;DONE IF NO CARRY
	MVI	A,4
	STA	IOFLAG	;IOFLAG 5=>4
	JMP	IOF4	;GO DO INPUT
IOF5I:	LXI	H,IBUF
	CALL	BFILL
	RC	;NOT END OF LINE YET
	MVI	A,6
	STA	IOFLAG	;IOFLAG	5=>6
	RET
IOF5S:	LDA	CPOS
	LXI	H,IBUF
	CALL	DADHL
	MOV	A,M	;GET CHAR
	CALL	MSGO
	RC	;NOT ABLE TO OUTPUT
	LDA	CPOS
	INR	A	;UPDATE PTRS
	STA	CPOS
	LXI	H,IBUF	;TEST FOR END
	DCR	A	;PREPARE FOR COMPARISON
	CMP	M
	RET	;CHECK FOR RESULT AFTER RETURNING
IOF6:	CALL	IOF5S	;OUTPUT INPUT BUFFER
	RC
	LXI	H,IBUF
	CALL	TTYBF	;DO LINE AND CHAR EDITS
	JMP	IOF4X	;ASSIGN INPUT VALUES
IOF7:	CALL	IOF7S
	RC
	CALL	IOF7D	;SET PROCEED VAR=0 AND INITIAL OBUFF
	XRA	A
	STA	IOFLAG	;IOFLAG	7=>0
	RET
IOF7S:	LDA	CPOS
	LXI	H,OBUFF
	CALL	DADHL
	MOV	A,M	;GET NEXT CHAR
	CALL	MSGO
	RC	;NOT PRINTED
	LDA	CPOS
	INR	A
	STA	CPOS
	LXI	H,OBUFF
	CMP	M	;TEST IF END OF PRINT LINE
	RET
IOF7D:	LHLD	PPVAR	;SET PRINT-PROCEED VAR TO ZERO
	LXI	D,FZERO
	CALL	COPDH
	LXI	H,OBUFF	;SET START OF OBUFF TO ONE
	MVI	M,1
	RET
IOF8:	CALL	IOF7S	;PRINT CHAR
	JC	IOF8I	;SEE IF INPUT BEING DONE
	CALL	IOF7D	;SET PPVAR AND OBUFF
	MVI	A,3
	STA	IOFLAG	;IOFLAG	8=>3
	JMP	IOF3	;LOOK FOR INPUT
IOF8I:	CALL	CHAR2
	RC	;NO INPUT
	MOV	B,A
	MVI	A,9
	STA	IOFLAG	;IOFLAG	8=>9
	MOV	A,B	;RESTORE CHAR
	LXI	H,IBUF
	MVI	M,0	;SET LEN IBUF TO ZERO
	CALL	BFILX	;PROCESS CHAR
	RC
	MVI	A,12	;ERROR IN INPUT
	STA	IOFLAG	;IOFLAG	=>12
	RET
IOF9:	CALL	IOF7S	;PRINT CHAR
	JC	IOF9I	;GO CHECK INPUT
	CALL	IOF7D	;SET PPVAR AND OBUFF
	MVI	A,5
	STA	IOFLAG	;IOFLAG 9=>5
	CALL	CPOS1
	JMP	IOF5	;BEGIN TO DUMP INPUT BUFFER
IOF9I:	LXI	H,IBUF
	CALL	BFILL	;GET CHAR
	RC
	MVI	A,10
	STA	IOFLAG	;IOFLAG 9=>10
	RET
IOF10:	CALL	IOF7S	;PRINT
	RC	;DONE?
	CALL	IOF7D	;SET PPVAR AND OBUFF
	MVI	A,6
	STA	IOFLAG	;IOFLAG 10=>6
	CALL	CPOS1
	RET
IOF11:	CALL	IOF7S
	RC
	CALL	IOF7D	;SET PPVAR AND OBUFF
	MVI	A,1
	STA	IOFLAG	;IOFLAG 11=>1
	RET
IOF12:	CALL	IOF7S
	RC
	JMP	IOF4E	;PRINT ERROR MESSAGE
IOF13:	MVI	A,'?'
	CALL	MSGO
	RC	;NOT SENT
	MVI	A,14
	STA	IOFLAG	;IOFLAG 13=>14
IOF14:	MVI	A,' '
	CALL	MSGO
	RC	;NOT SENT
	MVI	A,15
	STA	IOFLAG	;IOFLAG	14=>15
	RET
IOF15:	MVI	A,0DH	;PRINT RETURN
	CALL	MSGO
	RC	;NOT SENT
	MVI	A,16
	STA	IOFLAG	;IOFLAG 15=>16
	RET
IOF16:	MVI	A,0AH	;PRINT LINE FEED
	CALL	MSGO
	RC
	MVI	A,8	;PROMPT DONE NOW PRINT
	STA	IOFLAG	;IOFLAG 16=>8
	CALL	CPOS1
	RET
IOF17:	CALL	CHAR2	;LOOK FOR CHAR
	RC	;NONE YET
	MOV	B,A	;SAVE CHAR
	MVI	A,18
	STA	IOFLAG	;IOFLAG 17=>18
	MOV	A,B	;RESTORE CHAR
	LXI	H,IBUF	;PREPARE FOR STRING CHAR N BUFF
	CALL	BFILX	;PUT CHAR IN BUFF
	RC
	MVI	A,19	;INPUT IS DONE
	STA	IOFLAG	;IOFLAG 17=>19
	RET
IF17X:	CALL	IOF4S	;ASSIGN INPUT VALUES
	JNZ	IF17E	;ERROR ON INPUT
	MVI	A,7
	STA	IOFLAG	;IOFLAG 17=>7
	CALL	CPOS1
	RET
IF17E:	CALL	IOF4E
	MVI	A,13
	STA	IOFLAG	;IOFLAG 17=>13
	RET
IOF18:	CALL	IOF5S
	JC	IF18I
	MVI	A,17
	STA	IOFLAG	;IOFLAG 18=>17
	JMP	IOF17
IF18I:	LXI	H,IBUF
	CALL	BFILL
	RC
	MVI	A,19
	STA	IOFLAG	;IOFLAG 18=>19
	RET
IOF19:	CALL	IOF5S
	RC
	LXI	H,IBUF
	CALL	TTYBF	;DO LINE AND CHAR EDITS
	JMP	IF17X	;INPUT COMPLETE
IODNE:	POP	H	;RESTORE ALL REGS
	POP	D
	POP	B
	POP	PSW
	RET
;
;TTYIN IS THE NORMAL WAY TO FILL A BUFFER
TTYIN:	MVI	M,0	;INITIALIZE BUFF LEN
TTY1:	CALL	BFILL	;FILL BUFFER
	JC	TTY1
	CALL	TTYBF	;DO CHAR AND LINE DELETE
	MOV	A,M	;PUT LENGTH IN A AND B
	MOV	B,A
	RET
;
;TTY INPUT ROUTINE. CARRY INDICATES IF CHAR
;AVAILABLE (CY=1 MEANS NO CHAR). PARITY BIT
;IS REMOVED.
;
CHAR2:	CALL	CMDIN	;TRY AND GET CHAR
	RC	;RETURN IF NO CHAR
	ANI	7FH	;MASK OUT PARITY BIT
	RET
;
;OUTPUT TO TTY, WAITS UNTIL CHAR PRINTED
;
SEND:	CALL	MSGO	;OUTPUT CHAR IN A
	JC	SEND	;WAIT UNTIL CHAR PRINTS
	RET
; ROUTINE TO INPUT SOURCE LINE FROM HSR. PASSED ADD
; OF FIRST CHAR IN HL. RETURNS LENGTH OF LINE IN REG A
;
HSRIN:	PUSH	H	;SAVE ADDR.
	MVI	B,0	;INIT. NUMB. OF CHAR. READ
	JMP	PIN1A
PIN1:	CALL	CHAR5	;GET A CHAR.
PIN1A:	CPI	31Q	;CNTRL Y?
	JZ	PIN2
	CPI	0	;NULL?
	JZ	PIN1
	CPI	177Q	;DEL?
	JZ	PIN3
	CPI	12Q	;LF?
	JZ	PIN1
	CPI	15Q	;CR?
	JZ	PIN4
	INX	H	;MOVE TO NEXT SLOT
	MOV	M,A	;GOOD CHAR--STORE IT AWAY
	INR	B
	CALL	MEMFUL	;IS MEM. FULL?
	JMP	PIN1	;LOOP ON PROCESS
PIN3:	DCX	H	;DELETE THE LAST CHAR.
	DCR	B	;MUST INSURE THE LINE IS NOT EMPTY
	JP	PIN1
PIN2:	POP	H
	XRA	A	;ZERO A
	RET
PIN4:	POP	H	;DONE
	MOV	A,B
	RET
;
; ROUTINE TO OUTPUT TO PUNCH DEVICE
;
PUNCH:	CALL	PROGO	;OUTPUT CHAR TO PUNCH
	JC	PUNCH	;WAIT UNTIL IT GETS OUTPUT
	RET
;
; ROUTINE TO INPUT CHAR FROM HSR
;
CHAR5:	CALL	PROGI
	JC	CHAR5
	ANI	7FH	;BANISH THE PARITY BIT FOREVER
	RET
;
;
; ENTER INTERPRETER HERE IF USER SOURCE RESIDES IN PROM
PROMR:	LHLD	STAACK	; INITIALIZE STACK-POINTER
	SPHL
	LHLD	PROM	; PICK UP PROM USER SOURCE LOCATION
	SHLD	STLINE
	LXI	H,VEND	; PICK UP RAM ADDRESS FOR VARIABLE STORAGE
	SHLD	NLINE
	LXI	H,OBUFF	; INITIALIZE OUTPUT BUFFER
	MVI	M,1
	LXI	H,M1A	; SET UP RETURN ADDRESS IF
	PUSH	H	; PROGRAM HITS A 'STOP' OR 'END'
	LXI	H,GRBFLG	; SET FLAG TO TURN GARBAGE COLLECTION OFF
	MVI	M,1
	LXI	H,0FFFFH
	SHLD	STSPAC	; SIGNIFY SYMBOL TABLE EMPTY
	JMP	RUN	; R U N  T H E  I N T E R P R E T E R
;
;
;PWRF RAISES NOS TO THE POWER OF TOS.
;TOS IS ASSUMED TO BE A FLOATING PT INTEGER.
PWRF:	PUSH	H	;SAVE REGS
	PUSH	PSW
	PUSH	D
	CALL	FIXD	;MAKE TOS AN INTEGER
	LXI	H,FREG1
	CALL	AM2HL	;POP POWER TO FREG
	INX	H
	INX	H
	MOV	D,M	;MOVE 3RD BYTE TO D
	INX	H
	MOV	E,M	;MOVE 4TH BYTE TO E
	MOV	A,D	;TEST IF NUMBER TOO LARGE
	ORA	A
	JNZ	ER13	;TOO LARGE
	MOV	A,E	;TEST IF POWER IS 0
	ORA	A
	JZ	ZPOW	;PUT A ONE ON AM9511
	LXI	H,FREG
	CALL	AM2HL
	CALL	HL2AM	;GET VALUE IN FREG
PWRL:	DCR	E	;LOOP UNTIL POWER = 0
	JZ	RETPWR ;POWER = POWER-1
	CALL	HL2AM
	CALL	FMUL	;MULTIPLY
	JMP	PWRL	;REPEAT
RETPWR:	POP	D	;RESTORE REGS
	POP	PSW
	POP	H
	RET
ZPOW:	LXI	H,0
	PUSH	H
	INX	H	;SET H=1
	PUSH	H	;PUT INTEGER 1 ON STACK
	CALL	POPF	;POP OFF VALUE
	CALL	SP2AM	;PUT INTEGER 1 ON AM9511
	CALL	FLTD	;FLOAT IT
	JMP	RETPWR ;RETURN
ER13:	MVI	A,13H
	JMP	ERROR
FPERR:	ORA	A	;SET FLAGS
	RZ	;NO ERROR
	PUSH	PSW	;SAVE A
	XRA	A
	STA	IOFLAG	;TURN OFF I/O PROCEEDS
	CALL	WRIT	;DUMP BUFFER
	POP	PSW	;GET A BACK
	LXI	H,WFPER	;RETURN ADDRESS
	PUSH	H	;SAVE ON STACK
	LXI	H,ODA10	;MESSAGE TABLE
	RAL	;UNDERFLOW?
	JC	FORM	;YES
	LXI	H,ODAT9
	RAL	;OVERFLOW?
	JC	FORM	;YES
	LXI	H,ODAT8
	JMP	FORM	;NO - ITS ZERODIVIDE
WFPER:	LXI	H,ODAT4	;MESSAGE TABLE
	JMP	ERRR2	;PRINT 'IN LINE --' (USE PART OF ERROR)
ODAT4:	DB	9,' IN LINE '
ODAT8:	DB	10,'INDEFINITE'
ODAT9:	DB	8,'OVERFLOW'
ODA10:	DB	9,'UNDERFLOW'
; CHECKS IF VALUE IS ZERO
ZSTAT:	PUSH	H
	PUSH	PSW
	LXI	H,AM9511
	XRA	A	;SET A=0
	CMP	M	; TEST FOR FOUR ZEROS
	JNZ	ZSTR
	INX	H
ZSTFL:	CMP	M	;ENTRY FOR FLOAT TEST FOR ZERO
	JNZ	ZSTR
	INX	H
	CMP	M
	JNZ	ZSTR
	INX	H
	CMP	M
ZSTR:	POP	H	;GET A INTO H
	MOV	A,H	;RESTORE A
	POP	H	;ZERO FLAG SET TO RESULT
	RET
ZSTAF:	PUSH	H	;SAVE REGS
	PUSH	PSW
	LXI	H,AM9511	;SET UP FOR CALL TO ZSTFL
	XRA	A	;SET A=0
	JMP	ZSTFL
; CHECKS IF VALUE IS POS OR NEG
SSTAT:	PUSH	H
	PUSH	PSW
	LXI	H,AM9511+3
	MOV	A,M
	ANI	80H
	ORA	A
	POP	H	;MOVE A INTO H
	MOV	A,H	;RESTORE A WITHOUT DISTURBING PSW
	POP	H
	RET
SISTAT:	PUSH	H
	LXI	H,AM9511
	MOV	A,M
	ANI	80H
	ORA	A
	POP	H
	RET
;STAUS FOR INTEGERS
ISTAT:	PUSH	B
	MOV	B,A
	CALL	SISTAT	;GET INTEGER SIGN STATUS
	JP	STATP
	JMP	STATM
; MAIN CALL FOR STATUS
STATUS:	PUSH	B
	MOV	B,A	;SET UP PSW IN C REG
	CALL	SSTAT
	JP	STAFP
	CALL	ZSTAF
	JZ	MZ
	JMP	MNZ
STAFP:	CALL	ZSTAF
	JZ	PZ
	JMP	PNZ
STATM:	CALL	ZSTAT
	JZ	MZ
MNZ:	MVI	C,82H	;NEG,NOT ZERO
	JMP	FSTAT
MZ:	MVI	C,0C2H	;NEG,ZERO
	JMP	FSTAT
STATP:	CALL	ZSTAT
	JZ	PZ
PNZ:	MVI	C,2	;POS,NOT ZERO
	JMP	FSTAT
PZ:	MVI	C,42H
FSTAT:	PUSH	B
	POP	PSW	;USE THE STACK TO SET UP FLAGS IN PSW
	POP	B
	RET
; SP2AM DESTROYS HL AND VALUE ON STACK. VALUE IS ASSUMED
; TO BE PUSHED ON STACK AS 1ST BYTES 1&2 THEN BYTES 3&4.
SP2AM:	PUSH	PSW
	PUSH	B
	PUSH	D
	LXI	H,8
	DAD	SP	;HL POINT TO STACK
	MOV	D,M	;GET VALUE INTO REGS BCDE.
	INX	H
	MOV	E,M
	INX	H
	MOV	B,M
	INX	H
	MOV	C,M
	XCHG	;3&4 BYTES TO HL
	SHLD	FREG1+2
	MOV	H,B
	MOV	L,C
	SHLD	FREG1
	LXI	H,FREG1
	CALL	HL2AM	;PUT ON AM9511 STACK
	POP	D
	POP	B
	POP	PSW	;RESTORE REGS
	POP	H	;DELETE VALUE ON STACK
	XTHL
	POP	H
	XTHL
	RET
AM2SP:	LXI	H,FREG1
	CALL	AM2HL	;GET VALUE
	LHLD	FREG1	;GET BYTES 1 &2
	PUSH	PSW	;EXHHANGE H AND L VALUES
	MOV	A,H
	MOV	H,L
	MOV	L,A
	POP	PSW
	XTHL	;PUT ON STACK
	PUSH	H	;SAVE RET ADDR
	LHLD	FREG1+2
	PUSH	PSW	;EXCHANGE H AND L VALUES
	MOV	A,H
	MOV	H,L
	MOV	L,A
	POP	PSW
	XTHL	;PUT 1ST BYTES ON STACK
	PUSH	H
	RET
;
; 4 BYTE FIXED ARITHMETIC
; ALL DONE IN FLOATINT PT
;
DSUB:	CALL	FLTD
	CALL	XCHF
	CALL	FLTD
	CALL	XCHF
	CALL	FSUB
	CALL	FIXD
	RET
DMUL:	CALL	FLTD
	CALL	XCHF
	CALL	FLTD
	CALL	XCHF
	CALL	FMUL
	CALL	FIXD
	RET
DDIV:	CALL	FLTD
	CALL	XCHF
	CALL	FLTD
	CALL	XCHF
	CALL	FDIV
	CALL	FIXD
	RET
; THESE ARE SUBROUTINES THAT PROVIDE A MINIMAL
; SET OF STACK OPERATIONS SO THAT SOFTWARE THAT
; WILL USE THE AM9511 CHIP MAY BE TESTED.
;
;
; PUSH TOS TO NOS
PTOF:	PUSH	H
	PUSH	D	;SAVE ALL REGS
	PUSH	B
	PUSH	PSW
	LXI	H,AM9511+11	;POINTERS
	LXI	D,AM9511+15
	MVI	B,12
PTOFL:	MOV	A,M
	STAX	D
	DCX	D
	DCX	H
	DCR	B
	JNZ	PTOFL
	POP	PSW
	POP	B
	POP	D
	POP	H
	RET
; POP TOS, NOS TO TOS
POPF:	PUSH	H
	PUSH	D
	PUSH	B
	PUSH	PSW
	LXI	H,AM9511+4
	LXI	D,AM9511
	MVI	B,12
POPFL:	MOV	A,M
	STAX	D
	INX	D
	INX	H
	DCR	B
	JNZ	POPFL
	POP	PSW
	POP	B
	POP	D
	POP	H
	RET
; PUTS DATA ON STACK OF AM9511, PNT IS HL
HL2AM:	PUSH	H
	PUSH	D
	CALL	PTOF
	LXI	D,AM9511
	XCHG
	CALL	COPDH
	POP	D
	POP	H
	RET
; GET DATA FROM AM9511 STACK. PNT IS HL
AM2HL:	PUSH	H
	PUSH	D
	LXI	D,AM9511
	CALL	COPDH
	CALL	POPF
	POP	D
	POP	H
	RET
; DOES A FADD
FADD:	PUSH	H
	PUSH	D
	PUSH	B
	PUSH	PSW
	CALL	SETUP
	CALL	LADD
	CALL	SAVEV
	POP	PSW
	POP	B
	POP	D
	POP	H
	RET
; PREPARES FOR A FLOAT OPERATION
SETUP:	CALL	QUITT	;TEST FOR I/O
	LXI	H,FREG2
	CALL	AM2HL
	LXI	D,AM9511
	LXI	H,FREG1
	CALL	COPDH
	LXI	H,FREG1
	MVI	B,FREG2 AND 0FFH
	MVI	C,SCR AND 0FFH
	RET
; SAVES VALUE AFTER A FADD OR FSUB
SAVEV: CALL FPERR	;CHECK FOR ERROR
	LXI	D,AM9511
	XCHG
	CALL	COPDH
	RET
; F SUBTRACT
FSUB:	PUSH	H
	PUSH	D
	PUSH	B
	PUSH	PSW
	CALL	SETUP
	CALL	LSUB
	CALL	SAVEV
	POP	PSW
	POP	B
	POP	D
	POP	H
	RET
; F MULT
FMUL:	PUSH	H
	PUSH	D
	PUSH	B
	PUSH	PSW
	CALL	SETUP
	CALL	LMUL
	MOV	L,C
	CALL	SAVEV
	POP	PSW
	POP	B
	POP	D
	POP	H
	RET
FDIV:	PUSH	H
	PUSH	D
	PUSH	B
	PUSH	PSW
	CALL	SETUP
	CALL	LDIV
	MOV	L,C
	CALL	SAVEV
	POP	PSW
	POP	B
	POP	D
	POP	H
	RET
; EXCHANGE TOS AND NOS
XCHF:	PUSH	H
	PUSH	D
	LXI	H,FREG1
	LXI	D,AM9511
	CALL	COPDH
	LXI	H,AM9511
	LXI	D,AM9511+4
	CALL	COPDH
	LXI	H,AM9511+4
	LXI	D,FREG1
	CALL	COPDH
	POP	D
	POP	H
	RET
; FIX A FLOATING PT NUMBER
FIXD:	PUSH	D
	PUSH	PSW
	LXI	D,AM9511
	CALL	FIX
	POP	PSW
	POP	D
	RET
; FLOAT A FIXED NUMBER
FLTD:	PUSH	B
	PUSH	D
	PUSH	H
	PUSH	PSW
	LXI	H,AM9511
	LXI	D,AM9511+1
	MVI	C,3
	MOV	B,M	;THERE IS A NEED TO REARRANGE
FLTDL:	LDAX	D	;THE INTEGER BEFORE FLOATING IT.
	MOV	M,A
	INX	D
	INX	H
	DCR	C
	JNZ	FLTDL
	MOV	M,B
	LXI	H,AM9511
	CALL	FLOAT
	POP	PSW
	POP	H
	POP	D
	POP	B
	RET
; CHANGES SIGN FOR SIGNED INTEGER
CHSD:	PUSH	H
	PUSH	PSW
	LXI	H,AM9511
	MOV	A,M
	RAL
	CMC
	RAR
	MOV	M,A
	POP	PSW
	POP	H
	RET
; CHANGES SIGN OF FLOATING NUMBER
CHSF:	PUSH	H
	PUSH	PSW
	LXI	H,AM9511+3
	MOV	A,M
	RAL
	CMC
	RAR
	MOV	M,A
	POP	PSW
	POP	H
	RET
;
;
; 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
;
; 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
;
;
; SBUROUTINE 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	100Q	;CHECK FOR 0 TO +63
	JC	STORC	;JUMP IF OKAY
	CPI	200Q	;CHECK FOR +64 TO +127
	JC	OFLWC	;JUMP IF OVERFLOW
	CPI	300Q	;CHECK FOR -128 TO -65
	JC	UFLWC	;JUMP IF UNDERFLOW
STORC:	MOV	E,L	;SAVE L IN E
	MOV	L,C	;LET L POINT TO RESULT
	MOV	D,A	;SAVE CHARACTERISTIC IN D
	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)=ADDR 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 UNDEFLOW
	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
;
;
; 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 RESPECTIVELY.
;
; 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 ENTRY
;
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
; DESTROYSE
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
;
; 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
;
; WRITE UNDERFLOW
WUND:	MVI	D,100Q	;LOAD CHARACTERISTIC INTO D REGISTER
	CALL	WCHAR	;WRITE CHARACTERISTIC
	MVI	A,0	;LOAD MANTISSA VALUE
	;WE ASSUME HERE THAT ALL BYTES
	;OF MANTISSA ARE THE SAME
	CALL	WMANT	;WRITE THE MANTISSA
	MVI	A,377Q	;SET ACCUMULATOR TO FLAG
	ORA	A	;SET FLAGS PROPERLY
	RET	;RETURN (WMANT RESTORED (H,L))
;
; WRITE OVERFLOW
WOVR:	MVI	D,77Q	;LOAD CHARACTERISTIC INTO D REGISTER
	CALL	WCHAR	;WRITE CHARACTERISTIC
OFLW1:	MVI	A,377Q	;LOAD MANTISSA VALUE
	;WE ASSUME HERE THAT ALL BYTES
	;OF MANTISSA ARE THE SAME
	CALL	WMANT	;WRITE THE MANTISSA
	MVI	A,177Q	;SET ACCUMULATOR TO FLAG
	ORA	A	;SET FLAGS PROPERLY
	RET	;RETURN (WMANT RESTORED (H,L))
;
;	WRITE INDEFINITE
WIND:	MVI	D,77Q	;LOAD CHARACTERISTIC INTO D REGISTER
	CALL	WCHAR	;WRITE CHARACTERISTIC
	MVI	A,377Q	;LOAD MANTISSA VALUE
	;WE ASSUME HERE THAT ALL BYTES
	;OF MANTISSA ARE THE SAME
	CALL	WMANT	;WRITE THE MANTISSA
	MVI	A,77Q	;SET ACCUMULATOR TO FLAG
	ORA	A	;SET FLAGS PROPERLY
	RET	;RETURN (WMANT RESTORED (H,L))
;
;
WZER:	INX	H	;WRITE NORMAL ZERO
	INX	H
	INX	H
	MVI	M,100Q	;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:	DCX	H	;POINT TO LEAST SIGNIFICANT BYTE
	;OF MANTISSA
	MOV	M,A	;STORE LSBYTE OF MANTISSA
	DCX	H	;PNT TO NEXT LEAST SIGNIFICANT BYTE
	;OF MANTISSA
	MOV	M,A	;STORE NLSBYTE OF MANTISSA
	DCX	H	;POINT TO MOST SIGNIFICANT BYTE
	;OF MANTISSA
	MOV	M,A	;STORE MSBYTE OF MANTISSA
	RET	;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 CHARACTERTISTIC 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	200Q	;JUST KEEP MANTISSA SIGN
	ORA	D	;OR IN NEW CHARACTERISTIC
	MOV	M,A	;STORE IT BACK
	RET	;RETURN WITH (H,L) POINT TO CHARACTERISTIC
	;OF RESULT
	;SOMEONE ELSE WILL FIX UP (H,L)
;
; SUBROUTINE INDFC
;
; THIS ROUTINE WRITES A FLOATING INDEFINITE, SETS
; THIS WRITES WRITES A FLOATING POINT 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 ZERO
	MOV	L,E	;RESTORE L=LPTR
	RET	;RETURN
;
; 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 ERRROR 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,177Q
	ANA	D	;/KILL SIGN BIT
	MOV	D,A	;/BACK TO D
	MOV	A,M	;/NOW SIGN IT
	ANI	200Q	;/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 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 BASE
	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
	MOV	L,E	;RETURN BASE TO L
	RNZ	;RETURN IF NOT THE SAME
	INR	L	;L TO NUM MANTB
	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.D
ENT1:	CALL	DCMP	;COMPARE NUM WITH DEN
	JNC	OVER	;IF CARRY NOT SET,NUM.GE.DEN
	RET
OVER:	CALL	DSUB2	;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 QUOTIENT
; (H,L) = ADDRESS OF DIVIDEND
;
LDCP:	CALL	CFCHE	;SET E=CHAR(H,B), A=CHAR(H,L)
	SUB	E	;SUBTRACT TO GET NEW CHARACTERISTIC
	JMP	CCHK	;GO CHECK FOR OVER/UNDERFLOW
	;AND STORE CHARACTERTISTIC
; SUBROUTINE DCLR
; CLEARS TWO SUCCESSIVE
; LOCATIONS OF MEMORY
DCLR:	XRA	A
	MOV	M,A
	INR	L
	MOV	M,A
	INR	L	;/***TP EXTENSION
	MOV	M,A	;/***TP ZERO 3
	DCR	L	;/***TP - ALL DONE
	DCR	L
	RET
; /*****ALL NEW DSUB2 - SHORTER***
; SUBROUTINE DSUB2
; DOUBLE PRECISION SUBTRACT
DSUB2:	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 INTO 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	177Q	;GET RID OF MANTISSA SIGN BIT
	ADI	100Q	;PROPAGATE CHAR SIGN INTO LEFTMOST BIT
	XRI	100Q	;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 EXTENDED 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 EXTENDED
	;INTO A (CHAR(H,L)) AND E (CHAR(H,B)) REGISTERS
	MOV	D,A	;SAVE CHAR (H,L)
	SUB	E	;SUBTRACT E (CHAR(H,B))
	RAL	;ROTATE SIGN BIT INTO CARRY BIT
	MOV	A,D	;RESTORE A=CHAR(H,L)
	RET	;RETURN
;
;
;***************************************************
;	//// MULTIPLY SUBROUTINE
;***************************************************
;
; SUBROUTINE LMUL
; FLOATING POINT MULTIPLY
; L PTR X B PTR TO C PTR
;
LMUL:	CALL	CSIGN	;COMPUTE SIGN OF RESULT AND STORE IT
	CALL	ZCHK	;CHECK FIRST OPERAND FOR ZERO
	JZ	WZERC	;ZERO * ANYTHING = ZERO
	CALL	BCHK	;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 PRODUCT 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	200Q	;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	DADD2	;ACCUMULATE PRODUCT
	JMP	INTR
;
; SUBROUTINE NORM
;
; THIS SUBROUTINE WILL NORMALIZE A FLOATING POINT
; NUMBER, PRESERVING 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
	CALL	GCHAR	;GET CHAR(H,L) IN A WITH SIGN EXTENDED
	MOV	D,A	;SAVE CHAR IN D
	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
	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
	;FIRT 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 MANTISSA
	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 IT
	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 IT
	INR	L	;/*** TP EXTENSION
	MOV	A,M
	RAR
	MOV	M,A
	MOV	L,E	;/***TP - ALL DONE TP
	RET
;
; COMPANION FILE FOR BAS80
; CONTAINS FLOATING POINT ROUTINES AND SOME
; UTILITY ROUTINES.
;
; ////FLOATING POINT PACKAGE FOR THE MCS8
; ////BY DAVID MEAD
; ////MODIFIED BY HAL BRAND 9/6/74
; ////MODIFIED FOR 24 BIT MANTISSAS***********
; ////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 2200H
;
MINCH	EQU	300Q	;MINIMUM CHARACTERISTIC WITH SIGN EXTENDED
MAXCH	EQU	077Q	;MAXIMUM 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
	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(DVISIOR)
	CPI	177Q	;CHECK MAX POSITIVE NUMBER
	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,200Q	;/****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 PNT AT BASE ?6
	CALL	BCHK	;CHECK ADDEND/SUBTRAHEND = ZERO
	RZ	;IF SO, RESULT=ARG SO RETURN
	;THIS WILL PREVENT UNDERFLOW INDICATION ON
	;ZERO + OR - ZERO
	CALL CCMP
	JZ	EQ02	;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 D
 NCHK:	MVI A,24
	CMP D
	JNC SH10
	MVI D,24
 SH10:	ORA A
	CALL DRST
	DCR D
	JNZ SH10
	MOV A,L
	CMP B
	JNZ EQ02	;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
 EQ02:	CALL LASD	;CHECK WHAT TO
	CALL ACPR	;SAVE ANSWER
	CPI 2	;TEST FOR ZERO ANSWER
	JNZ NOT0
	JMP	WZER	;WRITE FLOATING ZERO AND RETURN
;
 NOT0:	MVI D,1	;WILL TEST FOR SUB
	ANA D
	JZ	ADDZ	;LSB[1 INPLIES 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	DSUB2	;SUBTRACT SMALLER FROM BIGGER
	CALL	MANT	;SET UP SIGN OF RESULT
	CALL	TSTR	;SEE IF WE NEED TO INTERCHANGE
	;BPTR AND LPTR
	JZ	NORM	;NO INTERCHANGE NECESSARY, SO NORMALIZE
	;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) THE COPY
	;CHAR(H,B) TO CHAR(H,L)
ADD2:	CALL	MANT	;COMPUTE SIGN OF RESULT
	CALL	DADD2	;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 PREVIOUSLY 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 SIGNS
	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	;FGT.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
;
; 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	177Q
	RAL	;CHEK IF EXP SIGN IS -
	RAL
	JC	MINSE
	RAR
	RAR	;RESTORE CHAR
	CPI	30Q	;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 FREG1
	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 AND 377Q
	MVI	C,SCR AND 377Q
	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	177Q	;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	200Q,0,0,30Q
INT:	CALL	FIXD
	CALL	ISTAT
	JM	INT2	;NEGATIVE INTEGER
	CALL	FLTD
	RET
INT2:	LXI	H,0	;SUBRTACT ONE
	PUSH	H
	LXI	H,1
	PUSH	H
	CALL	SP2AM
	CALL	DSUB
	CALL	FLTD
	RET
SQR: RET
SIN: RET
COS: RET
TAN: RET
ASN: RET	;NONE OF THESE FUNCTIONS ARE AVAILABLE YET
ACN: RET
ATN: RET
EXP: RET
LOG: RET
LGT: RET	;LOG BASE 10
RANDOM: RET
	;
	;
	;	ROUTINE FORMT USED FOR FORMATTED OUTPUT.
	;	IT IS ASSUMED THAT THE FOLLOWING REGISTERS ARE SET BEFORE
	;	CALLING:
	;	REG. B CONTAINS THE FIELD WIDTH
	;	REG. C CONTAINS THE FRACTION FIELD WIDTH,
	;	FOR E OR F FORMAT
	;	THE TWO HIGH ORDER BITS OF REG C ALSO CONTAIN A
	;	CODE INDICATING THE TYPE OF FORMAT:
	;	00 = I
	;	01 = F
	;	10 = E
	;
	;	FORMT ALSO USES THE HIGH ORDER BITS OF REG C TO INDICATE
	;	THAT *'S HAVE BEEN PRINTED BECAUSE OF THE FIELD WIDTH NOT
	;	BEING LARGE ENOUGH.	11 IS THE ERROR CODE.
	;
	;	THE NUMBER TO BE PRINTED IS STORED AS A FLOATING POINT NUMBER
	;	ON THE TOP OF THE AM9511 STACK.
	;
	;	THE CONTENTS OF ALL REGISTERS AND THE AM9511 STACK ARE DESTROYED.
	;
FORMT:
	MVI	E,' '	;SET PAD CHARACTER TO BLANK
	; TYPE I, E, OR F?
	MOV	A,C
	ANI	0C0H	;SELECT TOP TWO BITS OF REG C
	ORA	A
	JZ	CALLI	;TYPE I IS DETECTED (00)
	SUI	40H	;CHECK FOR TYPE F
	JZ	CALLF	;TYPE F IS DETECTED (01)
	CALL	EFORM	;TYPE E IS ASSUMED
	RET
CALLI:	CALL	ROUND
	CALL	IFORM
	RET
CALLF:	CALL	ROUND
	CALL	FFORM
	RET
	;	ROUTINE IFORM OUTPUTS AN INTEGER
	;	REG B = FIELD WIDTH
	;	REG E = PAD CHARACTER (0 OR BLANK)
	;	IFORM IS CALLED BY FFORM AND EFORM TO OUTPUT
	;	INTEGRAL AND FRACTIONAL PART OF A NUMBER.
	;	THE HIGH ORDER BITS OF REG C ARE SET TO 11 IF THE FIELD
	;	WIDTH IS TOO SMALL.
	;	THE VALUE TO BE PRINTED IS A FLOATING POINT NUMBER
	;	AT THE TOP OF THE AM9511 STACK.
	;
IFORM:
	; FOLLOWING TWO OPS SET STATUS OF 'TOS'
	CALL	XCHF
	CALL	XCHF
	CALL	STATUS
	JP	IFOR1
	CALL	CHSF	; MAKE 'TOS' POSITIVE
	MOV	A,E
	ORI	80H	; SET HIGH ORDER BIT OF E-REG
	MOV	E,A	; TO INDICATE NUMBER WAS NEGATIVE
IFOR1:
	CALL	FIXD	;CHANGE VALUE TO DOUBLE PRECISION
	;FIXED POINT (NV)
	MOV	A,B	;TEST FOR ZERO FIELD WIDTH
	ORA	A
	RZ	;ZERO SO RETURN WITH NOTHING DONE
IFOR2:	MVI	D,0	;SET REG D TO ZERO, REG D COUNTS DIGITS
NEXTDIG:	CALL	PTOF	;TOS=NV, NOS=NV
	CALL	PTOF	;TOS=NOS=NNOS=NV
	CALL	DIVTEN	;TOS=NV/10,NOS=NNOS=NV
	CALL	PUTTEN	;PUT 10 ON TOS
	CALL	DMUL	;TOS=(NV/10)*10,NOS=NNOS=NV
	CALL	DSUB	;TOS=NV-(NV/10)*10,NOS=NV
	CALL	AM2SP	;TOS=NV,MOVE 4 BYTES FROM AM STACK
	;TO 8080 STACK
	;GET DIGIT TO BE PRINTED
	POP	H
	MOV	A,L	;FIRST VALUE POPPED OFF STACK IS THE DIGIT
	POP	H	;FINISH CLEARING STACK
	ORI	30H	;CHANGE NUMBER TO CHARACTER
	PUSH	PSW	;SAVE CHARACTER TO PRINT
	INR	D	;COUNT NUMBER OF DIGITS
	CALL	DIVTEN	;NEXT VALUE(NV)=LAST VALUE/10,PUT ON TOS
	CALL	ISTAT	;CHECK TO SEE IF NV=0
	JNZ	NEXTDIG	;NV NOT 0, MORE DIGITS
	;NO MORE DIGITS
	MOV	A,E
	ORA	A	;CHECK FOR NEGATIVE SIGN
	JP	WIDTH
	MVI	A,'-'	;PUT NEGATIVE SIGN ON STACK
	PUSH	PSW	;AND
	INR	D	;COUNT AS DIGIT
WIDTH:	MOV	A,B	;REG A NOW CONTAINS FIELD WIDTH
	SUB	D	;REG A = FIELD WIDTH - NUMBER OF DIGITS
	JP	OUTPUT	;WIDTH>=NUMBER OF DIGITS, OUTPUT NUMBER
	;WIDTH<NUMBER OF DIGITS, SET ERROR CODE
	MOV	A,C
	ORI	0C0H	;SET ERROR BITS TO 11
	MOV	C,A	;REG C CONTAINS ERROR BITS
	MVI	A,'*'	;OUTPUT *'S
	CALL	PAD	;*'S OUTPUT FOR FIELD WIDTH
CLEAR:	POP	PSW	;CLEAR DIGITS OFF STACK BEFORE RETURN
	DCR	D
	RZ	;RETURN TO CALLING ROUTINE, STACK IS CLEAR
	JMP	CLEAR	;FINISH CLEARING STACK
;
;
;OUTPUT DIGITS
OUTPUT:	MOV	B,A	;REG A=FIELD WIDTH-# OF DIGITS=PAD WIDTH
	MOV	A,E	;REG E CONTAINS PAD CHARACTER
	CALL	PAD	;OUTPUT PAD CHARACTERS
OUTDIG:	POP	PSW	;GET DIGIT OR - TO PRINT
	MVI	B,1
	CALL	PAD	;PRINT ONE CHARACTER
	DCR	D	;COUNT NUMBER OF DIGITS
	RZ	;RETURN IF ALL DIGITS PRINTED
	JMP	OUTDIG	;FINISH OUTPUT OF DIGITS
;END OF IFORM
;ALL DIGITS OR *'S PRINTED
;
;
; ROUTINE TO DIVIDE TOS BY 10 (FIXED POINT DIVISION)
DIVTEN:	CALL	PUTTEN	;PUT 4 BYTE 10 ON STACK
	CALL	DDIV	;TOS=TOS/10
	RET
	;
	; ROUTINE TO PUT FIXED POINT DOUBLE PRECISION 10 ON TOS
PUTTEN:	LXI	H,0
	PUSH	H
	LXI	H,0AH	;PUT 10 IN H AND L
	PUSH	H	;NOW HAVE DOUBLE PRECISION 10 ON 8080 STACK
	CALL	SP2AM	;PUT ON AM STACK
	RET
	;
	; ROUTINE FFORM OUTPUTS A NUMBER IN F-FORMAT
FFORM:	MOV	A,C
	ANI	3FH	;REMOVE CODE FROM TOP TWO BITS OF REG C
	MOV	C,A
	MOV	A,B
	SUB	C
	DCR	A	;REG A=FIELDWIDTH - FRACTION WIDTH -1
	JM	NODIG	;NO ROOM TO PRINT INTEGRAL PART - ERROR
	JZ	NODIG
	MOV	B,A	;REG B CONTAINS WIDTH OF INTEGRAL PART
	MVI	E,' '	;SET PAD CHARACTER TO BLANK
	CALL	PTOF
	CALL	AM2SP	;SAVE COPY OF VALUE
	CALL	IFORM	;PRINT INTEGRAL PART OF NUMBER
	;CHECK TO SEE IF INTEGRAL PART WAS PRINTED
	;OR IF *'S WERE PRINTED
	MOV	A,C
	ANI	0C0H	;SELECT TWO LEFTMOST BITS OF C
	JZ	FRACTION	;BITS=00, NO ERROR
	;
	;
	;INTEGRAL PART NOT PRINTED
	;OUTPUT	MORE *'S
	MOV	A,C
	ANI	3FH	;GET RID OF ERROR CODE IN REG C
	MOV	B,A
	INR	B	;REG B = FRACTION WIDTH + 1
	MVI	A,'*'
	CALL	PAD	;OUTPUT *'S
	CALL	SP2AM	;CLEAR STACK FOR RETURN
	RET	;ERROR RETURN FROM FFORM
	;
	;
	;NO ERROR, OUTPUT DECIMAL POINT
FRACTION: MVI	A,'.'
	MVI	B,1
	CALL	PAD
	;SEPARATE FRACTIONAL PART
	CALL	SP2AM	;PUT ORIGIANL NUMBER ON AM STACK
	CALL	STATUS	;CHECK IF NEGATIVE
	JP	POSFRAC
	CALL	CHSF	;FRACTION IS NEGATIVE, MAKE POSITIVE
POSFRAC:	CALL	PTOF	;TOS=NOS=V
	CALL	FIXD	;TOS=INTEGER PART OF V
	CALL	FLTD	;TOS=INTEGER PART OF V, CHANGED TO FLOATING PT
	CALL	FSUB	;TOS CONTAINS FRACTIONAL PART (F)
	CALL	FPOWER	;TOS=F*10**# OF FRACTIONAL DIGITS
	MOV	B,C	;FRACTION WIDTH = NUMBER WIDTH
	MVI	E,'0'	;SET PAD CHARACTER TO ZERO
	CALL	IFORM	;OUTPUT FRACTIONAL PART
	RET	;NORMAL END OF FFORM
	;
	;
	;FRACTION WIDTH>=FIELD WIDTH
NODIG:	MVI	A,'*'	;REG B=FIELD WIDTH, OUTPUT *'S
	CALL	PAD
	MOV	A,C	;SET ERROR BITS
	ORI	0C0H
	MOV	C,A
	RET	;ERROR RETURN FROM FFORM
	;
	;	ROUTINE TO MAKE TOS=TOS*10**REG C
FPOWER:	MOV	A,C	;TEST IF C<=0
	ORA	A
	RM	;RETURN IF C<=0
	RZ
	PUSH	B	;SAVE C
FPOWLOOP: CALL	FPUTTEN	;PUSH A 10 ON AM9511
	CALL	FMUL	;MULTIPLY
	DCR	C
	JNZ	FPOWLOOP	;WHILE C NOT 0 REPEAT
	POP	B	;RESTORE C
	RET
;
;
; ROUTINE TO ROUND VALUE ON TOP OF AM9511 STACK
ROUND:	PUSH	B	; SAVE BC. DE NOT CHANGED. A,HL DESTROYED
	CALL	XCHF
	CALL	XCHF
	CALL	STATUS	; GET SIGN OF INPUT SO ROUNDING
	PUSH	PSW	; IS DONE CORRECTLY AND SAVE ON STACK
	MOV	A,C	; GET FRACTIONAL WIDTH FROM C-REG
	ANI	3FH
	MOV	C,A
	LXI	H,TWO	; PUT A TWO ON THE STACK
	CALL	HL2AM
	CALL	FPOWER	; 2*10**(C-REG). INVERSE OF ROUNDING TERM
	LXI	H,FONE	; INVERT TOS
	CALL	HL2AM
	CALL	XCHF
	CALL	FDIV
	POP	PSW	; RETRIEVE SIGN OF INPUT
	JP	ROUN1
	CALL	FSUB	; ROUND NEGATIVE INPUT
	JMP	ROUN2
ROUN1:	CALL	FADD	; ROUND POSITIVE INPUT
ROUN2:	POP	B
	RET
TWO:	DB	80H,0,0,2
;
;
; ROUTINE EFORM OUTPUTS DATA IN E-FORMAT
EFORM:	MOV	A,B
	SUI	4	;REG A = WIDTH - 4
	MOV	B,A	;NEW WIDTH LEAVES ROOM FOR EXXX
	MVI	D,0	;SET REG D TO 0, D WILL CONTAIN EXPONENT
	CALL	STATUS	;CHECK TO SEE IF NEGATIVE
	JZ	EZERO	;ZERO IS A SPECIAL CASE
	JP	POSNUM
	CALL	CHSF	;CHANGE TO POSITIVE
	MOV	A,E
	ORI	80H
	MOV	E,A	;SET REG E TO INDICATE NEGATIVE
POSNUM:	PUSH	D	;SAVE REG E
	CALL	CHEKTEN	;MAKE VALUE LESS THAN 10
	CALL	CHEKONE	;MAKE VALUE>=1
	CALL	ROUND	; ROUND VALUE
	CALL	CHEKTEN	; VALUE MAY HAVE BEEN ROUNDED OVER 10
	;CHANGE VALUE BACK TO NEGATIVE, IF NECESSARY
	POP	H	;REG L CONTAINS SAVED REG E
	PUSH	D	;SAVE REG D (CONTAINS EXPONENT)
	XRA	A
	ORA	L	;CHECK FOR NEGATIVE IN E REG (NOW REG L)
	JP	OUTMAIN	;POSITIVE NUMBER, OUTPUT IT
	CALL	CHSF	;NEGATIVE NUMBER, CHANGE BACK TO NEGATIVE
OUTMAIN:	CALL	FFORM	;OUTPUT NUMBER
	POP	D	;RESTORE REGISTER D
	MOV	A,C
	ANI	0C0H	;SEE IF * PRINTED
	JZ	EXPONENT	;NO *, SO OUTPUT EXPONENT
	MVI	A,'*'	;OUTPUT 4 MORE *'S
	MVI	B,4
	CALL	PAD
	RET	;ERROR END OF EFORM
EZERO:	MOV	L,E
	PUSH	D	;SAVE EXPONENT
	JMP	OUTMAIN	;GO OUTPUT NUMBER
EXPONENT: MVI	A,'E'
	MVI	B,1
	CALL	PAD	;PRINT E
	XRA	A	;ZERO REG A
	ORA	D	;CHECK TO SEE IF REG D (EXPONENT) IS NEG
	JP	EXPOS
	MVI	A,'-'	;EXPONENT IS NEGATIVE
	MVI	B,1
	CALL	PAD	;OUTPUT NEGATIVE SIGN
	XRA	A
	SUB	D	;REG A = ABS(REG D)
	MOV	D,A	;REG D IS POSITIVE
	JMP	EXOUT
EXPOS:	MVI	A,' '	;EXPONENT IS A POSITIVE NUMBER
	MVI	B,1
	CALL	PAD	;OUTPUT A BLANK IN SIGN POSITION
EXOUT:	LXI	H,0
	PUSH	H
	MOV	L,D
	PUSH	H
	CALL	SP2AM	;DOUBLE PRECISION EXPONENT ON AM STACK
	MVI	E,'0'	;SET PAD CHARACTER TO ZERO
	MVI	B,2	;WIDTH OF FIELD FOR EXPONENT IS 2
	CALL	IFOR2	;OUTPUT INTEGER FORMAT
	RET	;NORMAL END OF EFORM
;
;
; ROUTINE TO SEE IF VALUE IS <10
; DIVIDE BY 10 UNTIL IT IS AND COUNT NUMBER OF DIVIDES FOR EXPONENT
CHEKTEN:	CALL	PTOF	;SAVE VALUE (V)
	CALL	FPUTTEN	;TOS=10,NOS=NV,NNOS=V
	CALL	FSUB	;TOS=NV-10,NOS=V
	CALL	STATUS	;SEE IF NEGATIVE
	PUSH	PSW
	CALL	POPF	;DISCARD NV-10, TOS=V
	POP	PSW
	RM	;DONE IF NEGATIVE
	CALL	FPUTTEN	;DIVIDE V BY FLOATING POINT 10
	CALL	FDIV	;TOS=TOS/10
	INR	D	;COUNT EXPONENT
	JMP	CHEKTEN
;
;
; ROUTINE TO INSURE VALUE IS >=1
; MULT BY 10 UNTIL IT IS AND COUNTS NUMBER OF MULTIPLIES FOR NEGATIVE EXPONENT
CHEKONE:	CALL	PTOF	;SAVE VALUE(V)
	CALL	FIXD	; IF VALUE IS LESS THAN 1 CONVERTING
	CALL	ISTAT	; TO INTEGER IS ZERO. LOOP UNTIL NOT 0
	PUSH	PSW
	CALL	POPF	;DISCARD NV, TOS=V
	POP	PSW
	RNZ	;DONE IF NV-1 IS >=0
	CALL	FPUTTEN
	CALL	FMUL	;MULTIPLY V BY FLOATING POINT 10
	DCR	D	;COUNT NEGATIVE EXPONENT
	JMP	CHEKONE
;
;
; ROUTINE TO PUT FLOATING POINT 10 ON TOS
FPUTTEN:	LXI	H,0A000H
	PUSH	H
	LXI	H,4
	PUSH	H
	CALL	SP2AM
	RET
;
;
; ROUTINE TO DUMP BINARY NUMBER TO USER THROUGH FLOATING PNYT. PACKAGE.
DNUMB:	LXI	B,0
	PUSH	B
	MOV	E,M
	INX	H
	MOV	D,M
	XCHG
	PUSH	H
	CALL	SP2AM
	PUSH	D
	CALL	FLTD
	LXI	B,600H
	CALL	FORMT
	POP	H
	RET
;
;
; SUBROUTINE DADD2 ADDS TWO DOUBLE PRECISION WORDS, C[1 IF THERE IS OVRFLW
DADD2:	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 MANTB?S
	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
;
;
; MISCELLANEOUS NUMBER CONVERSION SUBROUTINES
;
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	11Q
	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	11Q	;/BACK TO NORMAL
	MOV	C,A
	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 DADD2
	MOV	A,C	;/SET B TO X2
	ADI	12Q	;/TO X2
	MOV	B,A
	CALL	DADD2	;/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 FOR LEFT SHIFT OF NUMBER
	DCR	L	;/BACK UP TO OVERFLOW
	XRA	A	;/OVERFLOW=0 1ST 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
GETA:	INR	L	;/MOVE TO IT
	INR	L
	INR	L	;/***TP
	MOV	A,M	;/FETCH INTO A
	RET	;/DONE
MORD:	CALL	GETEX	;/MUL OR DIV DEPENDING ON EXP
	MOV	E,A	;/SAVE DECIMAL EXP
	MOV	B,L	;/SET UP TO MULT 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	11Q	;/IN SCRATCH
	MOV	C,A	;/NOW C SET RIGHT
	MOV	A,E	;/NOW TEST FOR MUL
	ANI	200Q	;/TEST NEGATIVE DEC. EXP.
	JZ	DIVIT	;/IF EXP IS + THEN DIVIDE
	CALL	LMUL	;/MULT.
FINUP:	MOV	A,C	;/SAVE LOC. 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	;/NOW GET DECIMAL EXP
	INR	L
	JMP	GETA	;/USE PART OF GCHR
DIVIT:	CALL	LDIV	;/DIVIDE
	JMP	FINUP
COPT:	MOV	A,C	;/COPY FROM 10^N TO RAM
	ADI	5
	MOV	C,A	;/SET C TO PLACE TO PUT
	MVI	A,(TEN5/256)
	CALL	COPY	;/COPY IT
	MOV	A,C	;/NOW RESET C
	SUI	5
	MOV	C,A	;/ITS RESET
	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
;
;
;
; 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
;
FINPT:	MOV	B,L	;/SAVE ADDRESS WHERE DATA IS TO GO
	MOV	A,C	;/IN SCRATCH
	ADI	17Q	;/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	376Q	;/TERM=.?
	JZ	DECPT	;/YES
TSTEX:	CPI	25Q	;/TEST FOR E
	JZ	INEXP	;/YES - HANDLE EXP
	CPI	360Q	;/TEST FOR SPACE TERM (240B-260B)
	JNZ	ERR	;/NOT LEGAL TERM
	CALL	FLTSGN	;/FLOAT # AND SIGN IT
SCALE:	CALL	GETEX	;/GET DECIMAL EXP
	ANI	177Q	;/GET GOOD BITS
	MOV	E,A	;/SAVE COPY
	ANI	100Q	;/GET SIGN OF EXP
	RLC	;/INTO SIGN BIT
	ORA	A	;/SET FLOPS
	MOV	B,A	;/SAVE SIGN
	MOV	A,E	;/GET EXP BACK
	JZ	APLS	;/JMP IS +
	MVI	A,200Q	;/MAKE MINUS +
	SUB	E	;/NOW ITS +
APLS:	ADD	B	;/SIGN NUMBER
	MOV	M,A	;/SAVE EXP (SIGN & MAG.)
	MVI	L,(TEN5 AND 377Q)	;/TRY MORD WITH 10**5 FIRST
	CALL	COPT	;/TRANSFER TO RAM
	CALL	GETEX	;/GET DECIMAL EXP
INT5:	ANI	77Q	;/GET MAG. OF EXP
	CPI	5	;/TEST FOR USE OF 10**5
	JM	TRYTN	;/WONT GO - TRY 10
	CALL	MORD	;/WILL GO SO DO IT
	SUI	5	;/MAG = MAG -5
	MOV	M,A	;/UPDATE DEC. EXP IN MEM
	JMP	INT5	;/GO TRY AGAIN
TRYTN:	MVI	L,(TEN AND 377Q)	;/PUT TEN IN RAM
	CALL	COPT
	CALL	GETEX	;/SET UP FOR LOOP
INT1:	ANI	77Q	;/GET MAGNITUDE
	ORA	A	;/TEST FOR 0
	JZ	SAVEN	;/DONE, MOVE NUM OUT AND GET OUT
	CALL	MORD	;/NOT DONE - DO 10
	SUI	1	;/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. EXP
	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	360Q	;/TEST FOR SPACE TERM.
	JNZ	ERR	;/NOT LEGAL - TRY AGAIN
	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	37Q	;/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,0	;/IF + MAKE -
	SUB	B	;/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	15Q	;/GET ADD OF L
	MOV	L,A	;/L POINTS TO L OF NUMBER
	MOV	L,M	;/NOW L POINTS TO NUMBER
	MOV	A,H	;/RAM TO RAM COPY
	CALL	COPY	;/COPY IT BACK
	JMP	SCALE	;/NOW ADJUST FOR EXP
GNUM:	CALL	INP	;/GET A CHAR
	CPI	' '	;/IGNORE LEADING SPACES
	JZ	GNUM
	CPI	'-'	;/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,200Q	;/SET - SIGN
	JMP	GNUM
TRYP:	CPI	'+'	;/IGNORE +
	JZ	GNUM
TSTN:	SUI	60Q	;/STRIP ASCII
	RM	;/RETURN IF TERM
	CPI	12Q	;/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
	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	;/NOW DO HIGH
	MOV	A,M	;/GET HIGH TO ADD IN CARRY
	ACI	0	;/ADD IN CARRY
	MOV	M,A	;/UPDATE HIGH
	DCR	L	;/***TP EXTENSION
	MOV	A,M
	ACI	0	;/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	;/PUT NUMBER IN (L)
	ADI	15Q	;/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 DESTROYED
	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	16Q	;/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
;
;
;PRINTS THE LINE NUMBER WHERE EXECUTION STOPPED,UNLESS LINE NUMBER IS -1.
;CALLED WHENEVER PROGRAM EXEC IS HALTED WITH A CONTROL S.
STOPS:	XRA	A
	STA	IOFLAG	;TURN OFF ALL PROCEED I/O
	CALL	WRIT	;DUMP ANY DATA IN OUTPUT BUFF
	LXI	H,OSTP1
	CALL	FORM	;PAD FIRST PART OF OUTPUT MESSAGE
	LHLD	LPNT
	CALL	CHK1	;ARE WE EXEC A NUMBERED STMT
	JC	STPWR	;NO, GO WRITE BUFFER
	MOV	E,M
	INX	H
	MOV	D,M	;GET LINE NUMBER TO DE
	LXI	H,OSTP2
	CALL	FORM
	CALL	LNUM	;PAD LINE NUMBER
STPWR:	CALL	WRIT	;WRITE MESSAGE
	JMP	M1A	;RETURN TO MONITOR
OSTP1:	DB	5,15Q,12Q,'INT'
OSTP2:	DB	6,' AT # '
;LNUM PRINTS LINE NUMBER IN DE
LNUM:	PUSH	D	;PUT NUMBER ON STACK
	XCHG	;SAVE HL IN DE
	LXI	H,0
	XTHL	;PUT ZEROS (HIGH BYTES ON STACK)
	PUSH	H	;PUT LOW BYTES
	CALL	SP2AM	;PUT VALUE ONTO AM9511
	CALL	FLTD	;FLOAT IT
	PUSH	B	;SAVE B,C
	PUSH	D	;SAVE HL (WAS STORED IN DE)
	LXI	B,600H	;SET UP B,C FOR CALL TO FORMAT
	CALL	FORMT	;PAD FORMATTED LINE NUMBER
	POP	H	;RESTORE REGS
	POP	B
	RET
;
;
TEN5:	DB	303Q,120Q,0Q,21Q	;/303240(8) = 100000.
TEN:	DB	240Q,0Q,0Q,4Q	;/12(8) = 10
FONE:	DB	200Q,0,0,001Q	;FLOATING PNT ONE
HALF:	DB	80H,0,0,0	;FLOATING 1/2
	END
