;  HAMPSHIRE COLLEGE 5K BASIC
;  ==========================
;
;
;  KEVIN JORDAN'S CP/M ADAPTATION OF PROCESSOR TECH
;  5K BASIC.
;
;  THIS IS VERSION Z1.0 FROM JEFF ZURKOW, WITH THE FOLLOWING
;  ADDITIONAL FEATURES:
;
;	1. THE BEAM AND DRAW STATEMENTS FOR TEKTRONIX TERMINALS.
;	2. LLIST COMMAND AND LPRINT STATEMENT FOR LINE PRINTER OUTPUT.
;	3. ARRAYS CLEARED ONLY WHEN DIMENSION STATEMENT EXECUTED,
;	   ONLY USED SYMBOL TABLE SPACE CLEARED. (ORIGINAL VERSION
;	   CLEARED ALL OF NON-PROGRAM MEMORY EACH TIME A STATEMENT
;	   WAS TYPED IN).
;
;
;
;
;	SYSTEM GLOBAL EQUATES
;
	ORG	100H
SYSTEM	EQU	5	;ENTRY TO CP/M
TFCB	EQU	5CH	;DEFAULT FCB ADDR
TBUFF	EQU	80H	;DEFAULT DMA ADDR
NR	EQU	TFCB+32	;NEXT RECORD INDEX
FPSIZ	EQU	5
LINLEN	EQU	80	;# CHARS IN LEGAL INPUT LINE
FP123	EQU	FPSIZ-2
FPNIB	EQU	FP123*2
DIGIT	EQU	FPNIB/2
CR	EQU	15Q
NULL	EQU	0
LF	EQU	12Q
ESC	EQU	3Q	;CONTROL-C
RUBOUT	EQU	7FH
CNTRU	EQU	15H	;CONTROL-U
EOF	EQU	1	;END OF FILE
BELL	EQU	7	;BELL CHARACTER
STESIZ	EQU	2+FPSIZ	;SYMBOL TABLE ELEMENT SIZE
OPBASE	EQU	'('
FTYPE	EQU	1	;CONTROL STACK FOR ENTRY TYPE
FORSZ	EQU	FPSIZ*2+2+2+1	;'FOR' CONTROL STACK ENTRY SIZE
GTYPE	EQU	2	;CONTROL STACK GOSUB ENTRY TYPE
ETYPE	EQU	0	;CONTROL STACK UNDERFLOW TYPE
UMINU	EQU	61Q	;UNARY MINUS
;
;	STARTUP BASIC SYSTEM
;
START:	LXI	SP,CMNDSP
	XRA	A
	STA	NULLCT	;INITIALIZE NULL COUNT
	STA	PFLAG	;TURN OF LINE-PRINTER FLAG
	INR	A
	STA	DIRF	;INITIALIZE DIRECT INPUT FLAG
	LXI	H,MEMTOP+2 ;FIRST FREE BYTE AFTER INTERPRETTER
	SHLD	BOFA	;START OF USER ASSIGNED MEMORY
	LHLD	SYSTEM+1 ;ADDRESS OF BDOS
	DCX	H	;SET LAST POSSIBLE FREE BYTE BEFORE BDOS
	SHLD	MEMTOP	;END OF ASSIGNED MEMORY POINTER
	SHLD	STB	;INITIALIZE END OF SYMBOL TABLE
	CALL	CSCR	;INITIALIZE FREE-SPACE
	CALL	CRLF
	LXI	H,HEAD	;OUTPUT HEADER MESSAGE
	CALL	PRNT
	CALL	CRLF
	CALL	CRLF2
	LXI	H,TFCB+1;TEST FOR FILE NAME IN BASIC INVOCATION
	MOV	A,M
	CPI	' '
	JZ	ST0	;IF NO FILE NAME
	LXI	D,WSIDN
	MVI	C,8
	CALL	COPY
	MOV	A,M	;TEST FOR FILE TYPE SPECIFIED
	CPI	' '
	JNZ	STRT1	;IF TYPE SPECIFIED
	LXI	H,WSIDD+8 ;DEFAULT TYPE
STRT1:	LXI	D,WSIDT
	MVI	C,3
	CALL	COPY	;SET FILE TYPE
	JMP	COLD3	;FETCH THE FILE
;
;	COPY - COPIES NUMBER OF BYTES IN C
;	FROM ADDRESS IN HL TO ADDR IN DE
;
COPY:	MOV	A,M
	STAX	D
	INX	H
	INX	D
	DCR	C
	JNZ	COPY
	RET
;
ST0:	LXI	H,PLS	;'NEW OR OLD' MESSAGE
	CALL	PRNT
STAR1:	CALL	INLINE
	LDA	IBUF
	CPI	'N'	;IS IT A 'NEW' COMMAND?
	JZ	CNEW1	;IF 'NEW' COMMAND
	CPI	'O'
	JZ	COLD1	;IF 'OLD' COMMAND
	JMP	ST0
;
COLD:	CALL	CSCR	;CLEAR WORK-SPACE
	CALL	GC	;FIND FIRST NON-BLANK
	CPI	CR
	JNZ	COLD2	;IF FILE NAME IN-LINE
COLD1:	LXI	H,OPN	;PRINT 'OLD PROGRAM NAME: '
	CALL	PRNT
	CALL	INLINE	;GET THE WSID
	LXI	H,IBUF
	SHLD	TXA
COLD2:	CALL	WSID	;GET THE WORK-SPACE ID
COLD3:	CALL	FETCH	;LOAD THE PROGRAM
	JMP	ST4
;
CNEW:	CALL	CSCR	;CLEAR WORK-SPACE
	CALL	GC
	CPI	CR
	JNZ	CNEW2	;IF FILE NAME IN-LINE
CNEW1:	LXI	H,NPN	;PRINT 'NEW PROGRAM NAME: '
	CALL	PRNT
	CALL	INLINE	;GET THE WSID
	LXI	H,IBUF
	SHLD	TXA
CNEW2:	CALL	WSID	;SAVE IT
ST4:	MVI	A,2*FPNIB
	STA	INFES
;
;	INITIALIZE RANDOM NUMBER
;
	LXI	D,FRAND
	LXI	H,RANDS
	CALL	VCOPY	;FRAND=RANDOM NUMBER SEED
;
;	COMMAND PROCESSOR
;
CMND1:	CALL	CRLF2
	LXI	H,RDYS	;PRINT READY MESSAGE
	CALL	PRNT
CMNDR:	MVI	A,1	;SET DIRECT INPUT FLAG
	STA	DIRF
	LXI	SP,CMNDSP
	CALL	CRLF
CMND2:	CALL	INLINE	;GET INPUT FROM OPERATOR
	CALL	PP	;PRE-PROCESS IT
	JC	CMND3
	CALL	LINE	;LINE NUMBER . . . GO EDIT
	CALL	CCLEAR
	JMP	CMND2
;
CMND3:	CALL	CMND4
	JMP	CMNDR
;
CMND4:	LXI	H,IBUF	;POINT TO COMMAND OR STATEMENT
	SHLD	TXA
	CALL	GC
	ANI	240Q
	CPI	240Q	;CHECK FOR COMMAND
	LXI	D,CMNDD
	JZ	ISTA1	;PROCESS COMMAND
	CALL	ISTAT	;PROCESS STATEMENT (IF ALLOWED)
	CALL	GCI
	CPI	CR
	RZ
E1:	LXI	H,SYNTX
	JMP	ERROR
;
;	ERROR MESSAGE PRINTOUT
;
E3:	LXI	H,ARGUM
	JMP	ERROR
;
E4:	LXI	H,CSTAK
	JMP	ERROR
;
E5:	LXI	H,BOUND
	JMP	ERROR
;
E6:	LXI	H,DIMEN
;
ERROR:	PUSH	H
	LDA	DIRF	;CHECK INPUT MODE
	ORA	A
	JNZ	ERRO1	;IF DIRECT INPUT MODE
	LHLD	TRPSP	;CHECK FOR TRAPS SET
	LXI	B,-TRPSTK
	DAD	B
	MOV	A,H
	ORA	L
	JZ	ERRO1	;IF TRAP STACK EMPTY
	LHLD	TRPSP	;POP LINE NUMBER
	INX	H
	MOV	E,M
	INX	H
	MOV	D,M
	SHLD	TRPSP
	CALL	FINDLN	;FIND THE LINE
	INX	H	;ADVANCE POINTER BEYOND LINE # AND COUNT
	INX	H
	INX	H
	SHLD	TXA	;UPDATE TXA
	LXI	SP,CMNDSP ;CLEAN UP
	JMP	ILOOP	;CONTINUE EXECUTION FROM TRAP LINE
;
ERRO1:	CALL	CRLF
	POP	H
	CALL	PRNT
	LXI	H,ERS
ERM1:	CALL	PRNT
	LDA	DIRF
	ORA	A
	JNZ	CMND1
	LXI	H,INS
	CALL	PRNT
;
;	FIND LINE NUMBER
;
	LHLD	BOFA
ERM2:	MOV	B,H
	MOV	C,L
	MOV	E,M
	MVI	D,0
	DAD	D
	XCHG
	LXI	H,TXA
	CALL	DCMP
	XCHG
	JC	ERM2
	INX	B
	LDAX	B
	MOV	L,A
	INX	B
	LDAX	B
	MOV	H,A
	LXI	D,IBUF	;USE IBUF TO ACCUMULATE LINE NO. STRING
	CALL	CNS
	MVI	A,CR
	STAX	D
	LXI	H,IBUF
	CALL	PRNTCR
	JMP	CMND1
;
;	LINE EDITOR
;
LINE:	LHLD	BOFA	;CHECK FOR EMPTY FILE
FIN:	MOV	A,M	;CHECK IF APPENDING LINE AT END
	DCR	A
	JZ	APP
	XCHG
	INX	D
	LHLD	IBLN	;GET INPUT LINE NUMBER
	XCHG
	CALL	DCMP	;COMPARE WITH FILE LINE NUMBER
	DCX	H
	JC	INSR	;LESS THAN
	JZ	INSR	;EQUAL
	MOV	A,M	;LENGTH OF LINE
	CALL	ADR	;JUMP FORWARD
	JMP	FIN
;
;	APPEND LINE AT END CASE
;
APP:	LDA	IBCNT	;DONT APPEND NULL LINE
	CPI	4
	RZ
	CALL	FULL	;CHECK FOR ROOM IN FILE
	LHLD	EOFA	;PLACE LINE IN FILE
	CALL	IMOV
	MVI	M,EOF
	SHLD	EOFA
	RET
;
;	INSERT LINE IN FILE CASE
;
INSR:	MOV	B,M	;OLD LINE COUNT
	SHLD	INSA	;INSERT LINE POINTER
	LDA	IBCNT	;NEW LINE COUNT
	JC	LT	;JMP IF NEW LINE #<>OLD LINE #
	SUI	4
	JZ	LT1	;TEST IF SHOULD DELETE NULL LINE
	ADI	4
LT1:	SUB	B
	JZ	LIN1	;LINE LENGTHS EQUAL
	JC	GT
;
;	EXPAND FILE FOR NEW OR LARGER LINE
;
LT:	MOV	B,A
	LDA	IBCNT
	CPI	4	;DON'T INSERT NULL LINE
	RZ
	MOV	A,B
	CALL	FULL
	LHLD	INSA
	CALL	NMOV
	LHLD	EOFA
	XCHG
	SHLD	EOFA
	INX	B
	CALL	RMOV
	JMP	LIN1
;
;	CONTRACT FILE FOR SMALLER LINE
;
GT:	CMA
	INR	A
	CALL	ADR
	CALL	NMOV
	XCHG
	LHLD	INSA
	CNZ	LMOV
	MVI	M,EOF
	SHLD	EOFA
;
;	INSERT CURRENT LINE INTO FILE
;
LIN1:	LHLD	INSA
	LDA	IBCNT
	CPI	4
	RZ
;
;	INSERT CURRENT LINE AT ADDR HL
;
IMOV:	LXI	D,IBCNT
	LDAX	D
	MOV	C,A
	MVI	B,0
;
;	COPY BLOCK FROM BEGINNING
;	HL IS DESTIN ADDR, DE IS SOURCE ADDR, BC IS COUNT
;
LMOV:	LDAX	D
	MOV	M,A
	INX	D
	INX	H
	DCX	B
	MOV	A,B
	ORA	C
	JNZ	LMOV
	RET
;
;	COPY BLOCK STARTING AT END
;	HL IS DESTIN ADDR, DE IS SOURCE ADDR, BC IS COUNT
;
RMOV:	LDAX	D
	MOV	M,A
	DCX	H
	DCX	D
	DCX	B
	MOV	A,B
	ORA	C
	JNZ	RMOV
	RET
;
;	COMPUTE FILE MOVE COUNT
;
;	BC GETS (EOFA)-(HL), RET Z SET MEANS ZERO COUNT
;
NMOV:	LDA	EOFA
	SUB	L
	MOV	C,A
	LDA	EOFA+1
	SBB	H
	MOV	B,A
	ORA	C
	RET
;
;	ADD A TO HL
;
ADR:	ADD	L
	MOV	L,A
	RNC
	INR	H
	RET
;
;	CHECK FOR FILE OVERFLOW, LEAVES NEW EOFA IN DE
;	A HAS INCREASE IN SIZE
;
FULL:	LHLD	EOFA
	CALL	ADR
	XCHG
	LXI	H,MEMTOP
	CALL	DCMP
	JNC	E8
	RET
;
;	COMMANDS
;
CSCR:	LHLD	BOFA
	MVI	M,EOF
	SHLD	EOFA
;
;	'CLEAR'
;
CCLEAR:	LHLD	EOFA	;CLEAR FROM EOFA TO MEMTOP
	INX	H
	SHLD	MATA
	LHLD	STB
	XCHG
	LXI	H,MEMTOP;END OF ASSIGNED MEMORY
CCLR1:	XRA	A
	STAX	D
	CALL	DCMP
	INX	D
	JNZ	CCLR1
	LHLD	MEMTOP
	SHLD	STB
	LXI	H,CSTKL+CSTKSZ-1
	MVI	M,ETYPE
	SHLD	CSTKA
	LXI	H,ASTKL+ASTKSZ+FPSIZ-1
	SHLD	ASTKA
	RET
;
;	'NULL'
;
CNULL:	CALL	INTGER
	JC	E3	;NO ARGUMENT SUPPLIED
	MOV	A,L
	STA	NULLCT
	JMP	CMND1
;
;	'LIST'
;
CLIST:	CALL	GC
	CPI	CR
	LXI	D,0
	JZ	CL0	;JUMP IF NO ARGUMENT SUPPLIED
	CALL	INTGER	;ERROR DEFAULT IS LIST
CL0:	LHLD	BOFA
CL1:	MOV	A,M
	DCR	A
	RZ
	INX	H
	CALL	DCMP
	DCX	H	;POINT TO COUNT CHAR AGAIN
	JC	CL2
	JZ	CL2
;
;	INCREMENT TO NEXT LINE
;
	MOV	A,M
	CALL	ADR
	JMP	CL1
CL2:	PUSH	D
	LXI	D,IBUF	;AREA TO UNPREPROCESS TO
	CALL	UPPL
	INX	H
	PUSH	H
	LXI	H,IBUF
	CALL	PRNTCR
	CALL	PCHECK
	CALL	CRLF
	POP	H
	POP	D
	JMP	CL1
;
;	'LLIST'
;
LLIST:	MVI	A,1	;SWITCH OUTPUT TO LINE PRINTER
	STA	PFLAG
	CALL	CRLF2
	CALL	CLIST	;CALL NORMAL LIST ROUTINE
	CALL	CRLF2
	XRA	A	;SWITCH OUTPUT BACK TO CONSOLE
	STA	PFLAG
	RET
;
;	'RUN'
;
CRUN:	CALL	CCLEAR
	LHLD	BOFA
	MOV	A,M
	DCR	A	;CHECK FOR NULL PROGRAM
	JZ	CEND
	INX	H
	INX	H
	INX	H
	SHLD	TXA
	SHLD	RTXA	;POINTER FOR 'READ' STATEMENT
	XRA	A
	STA	DIRF	;CALL DIRECT FLAG AND FALL THRU TO DRIVER
	CALL	CRLF
;
;	INTERPRETTER DRIVER
;
ILOOP:	CALL	PCHECK
	CALL	ISTAT	;INTERPRET CURRENT STATEMENT
	CALL	JOE	;TEST FOR JUNK ON END
	JNC	ILOOP	;CONTINUE IF NOT AT END OF PROGRAM
	JMP	CEND	;EXECUTE END STATEMENT
;
;	INTERPRET STATEMENNT LOCATED BY TXA
;
ISTAT:	CALL	GC	;GET FIRST NON BLANK
	ORA	A
	JM	ISTA0	;IF RW
	CPI	CR
	JZ	CMND1	;OUTPUT 'READY' IF BLANK LINE
	JMP	LET	;MUST BE 'LET' IF NOT RW OR CR
;
ISTA0:	CPI	IRWLIM	;IS IT AN INITIAL RW
	JNC	E1
	LXI	D,STATD	;STATEMENT DISPATCH TABLE BASE
ISTA1:	CALL	GCI	;ADVANCE TEXT POINTER
	ANI	37Q
	RLC		;MULTIPLY BY TWO PREPARING FOR TABLE LOOKUP
	MOV	L,A
	MVI	H,0
	DAD	D
	CALL	LHLI
	PCHL		;BRANCH TO STATEMENT OR COMMAND
;
;	STATEMENTS
;
;	'LET'
;
LET:	CALL	VAR	;CHECK FOR VARIABLE
	JC	E1
	PUSH	H	;SAVE VALUE ADDRESS
	MVI	B,EQRW
	CALL	EATC
	CALL	EXPRB
	POP	D	;DESTINATION ADDRESS
	CALL	POPA1	;COPY EXPRESSION VALUE TO VARIABLE
	RET
;
;	'FOR'
;
SFOR:	CALL	DIRT
	CALL	VAR	;CONTROL VARIABLE
	JC	E1
	PUSH	H	;CONTROL VARIABLE VALUE ADDRESS
	MVI	B,EQRW
	CALL	EATC
	CALL	EXPRB	;INITIAL VALUE
	POP	D	;VARIABLE VALUE ADDRESS
	PUSH	D	;SAVE
	CALL	POPA1	;SET INITIAL VALUE
	MVI	B,TORW	;RW FOR 'TO'
	CALL	EATC
	CALL	EXPRB	;LIMIT VALUE COMPUTATION
	CALL	GC	;CHECK NEXT CHARACTER FOR POSSIBLE STEP EXPRESSION
	CPI	STEPRW
	JZ	FOR1
;
;	USE STEP OF 1
;
	LXI	D,FPONE
	CALL	PSHA1
	JMP	FOR2
;
;	COMPUTE STEP VALUE
;
FOR1:	CALL	GCI	;EAT THE STEP RW
	CALL	EXPRB	;THE STEP VALUE
;
;	HERE THE STEP AND LIMIT ARE ON ARG STACK
;
FOR2:	LXI	D,-2	;PREPARE TO ALLOCATE 2 BYTES ON CONTROL STACK
	CALL	PSHCS	;RETURNS ADDRESS OF THOSE 2 BYTES IN HL
	XCHG
	CALL	JOE	;TEST FOR JUNK ON END
	JC	E4	;NO 'FOR' STATEMENT AT END OF PROGRAM
	XCHG		;DE HAS LOOP TEXT ADDR, HL HAS CONTROL STACK ADDR
	MOV	M,D	;HIGH ORDER TEXT ADDRESS BYTE
	DCX	H
	MOV	M,E	;LOW ORDER TEXT ADDRESS BYTE
	LXI	D,-FPSIZ;ALLOCATE SPACE FOR LIMIT ON CONTROL STACK
	CALL	PSHCS
	PUSH	H	;ADDR ON CONTROL STACK FOR LIMIT
	LXI	D,-FPSIZ;ALLOCATE SPACE FOR STEP ON CONTROL STACK
	CALL	PSHCS
	CALL	POPAS	;COPY STEP VALUE TO CONTROL STACK
	POP	D	;CONTROL STACK ADDR FOR LIMIT VALUE
	CALL	POPA1	;LIMIT VALUE TO CONTROL STACK
	LXI	D,-3	;ALLOCATE SPACE FOR TEXT ADDR AND CS ENTRY
	CALL	PSHCS
	POP	D	;CONTROL VARIABLE ADDR
	MOV	M,D	;HIGH ORDER BYTE OF CONTROL VARIABLE ADDR
	DCX	H
	MOV	M,E	;LOW ORDER BYTE OF CONTROL VARIABLE ADDR
	DCX	H
	MVI	M,FTYPE	;SET CONTROL STACK ENTRY TYPE FOR 'FOR'
	JMP	NEXT5	;GO FINISH OFF CAREFULLY
;
;	'NEXT'
;
NEXT:	CALL	DIRT
	LHLD	CSTKA	;CONTROL STACK ADDR
	MOV	A,M	;STACK ENTRY TYPE BYTE
	DCR	A	;MUST BE FOR TYPE ELSE ERROR
	JNZ	E4	;IMPROPER NESTING ERROR
	INX	H	;CONTROL STACK POINTER TO CONTROL VARIABLE ADDR
	PUSH	H
	CALL	VAR	;CHECK VARIABLE, IN CASE USER WANTS
	JC	NEXT1	;SKIP CHECK IF VAR NOT THERE
	XCHG
	POP	H	;CONTROL VARIABLE ADDRESS
	PUSH	H	;SAVE IT AGAIN
	CALL	DCMP
	JNZ	E4	;IMPROPER NESTING IF NOT THE SAME
NEXT1:	POP	H	;CONTROL VARIABLE ADDR
	PUSH	H
	PUSH	H
	LXI	D,FPSIZ+2-1 ;COMPUTE ADDR TO STEP VALUE
	DAD	D
	XTHL		;NOW ADDR TO VAR IN HL
	CALL	LHLI	;VARIABLE ADDR
	MOV	B,H	;COPY VAR ADDR TO BC
	MOV	C,L
	POP	D	;STEP VALUE ADDR
	PUSH	D
	CALL	FADD	;DO INCREMENT
	POP	H	;STEP VALUE
	DCX	H	;POINT TO SIGN OF STEP VALUE
	MOV	A,M	;SIGN 0=POS, 1=NEG
	LXI	D,FPSIZ+1
	DAD	D	;PUTS LIMIT ADDR IN HL
	XCHG
	POP	H	;VARIABLE ADDR
	CALL	LHLI	;GET ADDR
	PUSH	D	;SAVE CONTROL STACK POINTER TO GET TEXT ADDR
	ORA	A	;SET CONDITIONS BASED ON SIGN OF STEP VALUE
	JZ	NEXT2	;REVERSE TEST ON NEGATIVE STEP VALUE
	XCHG
NEXT2:	MOV	B,H	;SET UP ARGS FOR COMPARE
	MOV	C,L
	CALL	RELOP	;TEST <=
	POP	D	;TEXT ADDR
	JM	NEXT3	;STILL SMALLER?
	JZ	NEXT3	;JUMP IF WANT TO CONTINUE LOOP
;
;	TERMINATE LOOP
;
	LXI	H,3	;REMOVE CSTACK ENTRY
	DAD	D
	SHLD	CSTKA
	RET
;
NEXT3:	INX	D	;TEXT ADDR
	XCHG
	CALL	LHLI	;GET TEXT ADDR IN HL
;
;	ITERATE, SKIPPING NORMAL JUNK ON END TEST AT ILOOP
;
NEXT4:	XCHG		;SAVE NEW TEXT ADDR IN DE
	CALL	JOE
	XCHG
NEXT6:	SHLD	TXA
NEXT5:	LXI	H,ILOOP
	XTHL
	RET		;TO DISPATCHER SKIPPING JOE CALL THERE
;
;	'IF'
;
SIF:	MVI	B,1	;SPECIFY PRINCIPAL OPERATOR IS RELATIONAL
	CALL	EXPB1
	LHLD	ASTKA	;ADDR OF BOOLEAN VALUE ON ARG STACK
	INR	M	;SETS ZERO CONDITION IF RELATIONAL WAS TRUE
	PUSH	PSW	;SAVE CONDITIONS TO TEST LATER
	CALL	POPAS	;REMOVE VALUE FROM ARG STACK COPY TO SELF
	POP	PSW
	JNZ	REM	;IF TEST FALSE TREAT REST OF STATEMENT AS REM
;
;	TEST SUCCEEDED
;
	MVI	B,THENRW
	CALL	EATC
	CALL	INTGER	;CHECK IF LINE NUMBER IS DESIRED ACTION
	JC	ISTAT
	JMP	GOTO1
;
;	'GOTO'
;
SGOTO:	XRA	A
	STA	DIRF	;CLEAR DIRECT STATEMENT FLAG
	CALL	INTGER	;RETURNS INTEGER IN HL IF LINE NUMBER PRESENT
	JC	E1	;SYNTAX ERROR, NO LINE NUMBER
GOTO1:	XCHG		;LINE IN DE
	CALL	FINDLN	;RETURNS TEXT ADDR POINTS TO COUNT VALUE
GOTO2:	INX	H
	INX	H
	INX	H	;ADVANCE TEXT POINTER PAST LINE NUMBER AND COUNT
	JMP	NEXT4
;
;	'GOSUB'
;
GOSUB:	CALL	DIRT
	LXI	D,-3	;CREATE CONTROL STACK ENTRY
	CALL	PSHCS
	PUSH	H	;SAVE STACK ADDRESS
	CALL	INTGER
	JC	E1
	XCHG		;LINE NUMBER TO DE
	CALL	JOE
	MOV	B,H
	MOV	C,L
	POP	H	;STACK ADDR
	MOV	M,B	;STACK RETURN ADDR RETURNED BY JOE
	DCX	H
	MOV	M,C
	DCX	H
	MVI	M,GTYPE	;MAKE CONTROL STACK ENTRY TYPE 'GOSUB'
	CALL	FINDLN
	INX	H
	INX	H
	INX	H
	JMP	NEXT6
;
;	'RETURN'
;
RETRN:	CALL	DIRT
	STA	DIRF	;CLEARS DIRF IF ACC IS CLEAR
	LHLD	CSTKA
RET1:	MOV	A,M
	ORA	A	;CHECK FOR STACK EMPTY
	JZ	E4
	CPI	GTYPE	;CHECK FOR GOSUB TYPE
	JZ	RET2
;
;	REMOVE FOR TYPE ENTRY FROM STACK
;
	LXI	D,FORSZ
	DAD	D
	JMP	RET1
;
;	FOUND A GTYPE STACK ENTRY
;
RET2:	INX	H
	MOV	E,M	;LOW ORDER TEXT ADDR
	INX	H
	MOV	D,M	;HIGH ORDER TEXT ADDR
	INX	H	;ADDR OF PREVIOUS CONTROL STACK ENTRY
	SHLD	CSTKA
	XCHG		;PUT TEXT ADDR IN HL
	MOV	A,M	;ADDR POINTS TO EOF IF GOSUB WAS LAST LINE
	DCR	A	;END OF FILE?
	JNZ	NEXT4
	JMP	CEND
;
;	'DATA' AND 'REM'
;
DATA:	CALL DIRT	;DATA STATEMENT ILLEGAL AS DIRECT
REM:	CALL	GCI
	CPI	CR
	JNZ	REM
	DCX	H	;BACKUP POINTER SO NORMAL JOE WILL WORK
	SHLD	TXA
	RET
;
;	'DIMENSION'
;
DIM:	CALL	NAME	;LOOK FOR VARIABLE NAME
	JC	E1
	MOV	A,C	;PREPARE TURN ON 200Q BIT TO SIGNIFY MATRIX
	ORI	200Q
	MOV	C,A
	CALL	STLK
	JNC	E6	;ERROR IF NAME ALREADY EXISTS
	PUSH	H	;SYMBOL TABLE ADDR
	MVI	B,LPARRW
	CALL	EATC
	CALL	EXPRB
	MVI	B,')'
	CALL	EATC
	CALL	PFIX	;RETURN INTEGER IN DE
	LXI	H,MATUB	;MAX SIZE FOR MATRIX
	CALL	DCMP
	JNC	E6
	POP	H	;SYMBOL TABLE ADDR
	CALL	DIMS
	CALL	GC	;SEE IF MORE TO DO
	CPI	','
	RNZ
	CALL	GCI	;EAT THE COMMA
	JMP	DIM
;
;	'STOP'
;
STOP:	CALL	DIRT
STOP1:	CALL	CRLF2
	LXI	H,STOPS
	JMP	ERM1
;
;	'END'
;
CEND	EQU	CMND1
;
;	'READ'
;
READ:	CALL	DIRT
	LHLD	TXA
	PUSH	H	;SAVE TXA TEMPORARILY
	LHLD	RTXA	;THE 'READ' TXA
READ0:	SHLD	TXA
	CALL	GCI
	CPI	','
	JZ	READ2	;PROCESS INPUT VALUE
	CPI	DATARW
	JZ	READ2
	DCR	A
	JZ	READ4
;
;	SKIP TO NEXT LINE
;
	CALL	REM	;LEAVES ADDR OF LAST CR IN HL
	INX	H
	MOV	A,M
	DCR	A
	JZ	READ4
	INX	H
	INX	H
	INX	H	;HL NOW POINTS TO FIRST BYTE OF NEXT LINE
	JMP	READ0
;
;	PROCESS VALUE
;
READ2:	CALL	EXPRB
	CALL	GC
	CPI	','	;SKIP JOE TEST IF COMMA
	JZ	READ3
;
;	JUNK ON END TEST
;
	CALL	JOE
READ3:	LHLD	TXA
	SHLD	RTXA	;SAVE NEW 'READ' TEXT ADDR
	POP	H
	SHLD	TXA
	CALL	VAR
	JC	E1
	CALL	POPAS	;PUT READ VALUE INTO VARIABLE
	CALL	GC
	CPI	','	;CHECK FOR ANOTHER VARIABLE
	RNZ
	CALL	GCI	;EAT THE COMMA
	JMP	READ
;
READ4:	POP	H	;PROGRAM TXA
	SHLD	TXA
	LXI	H,RDERR
	JMP	ERROR
;
;	'RESTORE'
;
RESTOR:	LHLD	BOFA	;BEGINNING OF FILE POINTER
	INX	H
	INX	H
	INX	H
	SHLD	RTXA
	RET
;
;	'LPRINT'
;
LPRINT:	MVI	A,1	;SWITCH OUTPUT TO LINE PRINTER
	STA	PFLAG
	CALL	PRINT	;CALL NORMAL PRINT ROUTINE
	XRA	A	;SWITCH OUTPUT BACK TO CONSOLE
	STA	PFLAG
	RET
;
;	'PRINT'
;
PRINT:	CALL	GC
	CPI	CR	;CHECK FOR STAND ALONE PRINT
	JZ	CRLF
PRIN0:	CPI	'"'
	JZ	PSTR	;PRINT THE STRING
	CPI	TABRW
	JZ	PTAB	;TABULATION
	CPI	'%'
	JZ	PFORM	;SET FORMAT
	CPI	CR
	RZ
	CPI	';'
	RZ
	CALL	EXPRB	;MUST BE EXPRESSION TO PRINT
	LXI	D,FPSINK
	CALL	POPA1	;POP VALUE TO FPSINK
	LDA	PHEAD
	LXI	H,LWID
	CMP	M
	CNC	CRLF	;IF PRINT HEAD PAST LINE WIDTH LIMIT
	LXI	H,FPSINK
	CALL	FPOUT
	MVI	B,' '
	CALL	CHOUT
PR1:	CALL	GC	;GET DELIMITER
	CPI	','
	JNZ	CRLF
PR0:	CALL	GCI
	CALL	GC
	JMP	PRIN0
;
PSTR:	CALL	GCI	;GOBBLE THE QUOTE
	CALL	PRNT	;PRINT UP TO DOUBLE QUOTE
	INX	H
	SHLD	TXA
	JMP	PR1
;
PFORM:	MVI	A,2*FPNIB
	STA	INFES
	CALL	GCI	;GOBBLE PREVIOUS CHARACTER
PFRM1:	CALL	GCI
	LXI	H,INFES
	CPI	'%'	;DELIMITER
	JZ	PR1
	MVI	B,200Q
	CPI	'Z'	;TRAILING ZEROES?
	JZ	PF1
	MVI	B,1
	CPI	'E'	;SCIENTIFIC NOTATION?
	JZ	PF1
	CALL	NMCHK
	JNC	E1
	SUI	'0'	;NUMBER OF DECIMAL PLACES
	RLC
	MOV	B,A
	MOV	A,M
	ANI	301Q
	MOV	M,A
PF1:	MOV	A,M
	ORA	B
	MOV	M,A
	JMP	PFRM1
;
PTAB:	CALL	GCI	;GOBBLE TAB RW
	MVI	B,LPARRW
	CALL	EATC
	CALL	EXPRB
	MVI	B,')'
	CALL	EATC
	CALL	PFIX
PTAB1:	LDA	PHEAD
	CMP	E
	JNC	PR1
	MVI	B,' '
	CALL	CHOUT
	JMP	PTAB1
;
;	'INPUT'
;
INPUT:	CALL	GC
	CPI	'"'	;CHECK FOR USER-DEFINED PROMPT
	JNZ	INPU1	;IF NO PROMPT
	CALL	GCI
	CALL	PRNT	;OUTPUT PROMPT
	INX	H	;UPDATE TXA
	SHLD	TXA
	CALL	GC
INPU1:	CPI	','
	JZ	NCRLF
	CALL	CRLF
INP0:	MVI	B,'?'
	CALL	CHOUT
LINP:	CALL	INLINE
	LXI	D,IBUF
IN1:	PUSH	D	;SAVE FOR FPIN
	CALL	VAR
	JC	E1
	POP	D
	MVI	B,0
	LDAX	D
	CPI	'+'	;LOOK FOR LEADING PLUS OR MINUS ON INPUT
	JZ	IN2
	CPI	'-'
	JNZ	IN3
	MVI	B,1
IN2:	INX	D
IN3:	PUSH	B
	PUSH	H
	CALL	FPIN	;INPUT FP NUMBER
	JC	INERR
	POP	H
	DCX	H
	POP	PSW
	MOV	M,A
	CALL	GC
	CPI	','
	RNZ		;DONE IF NO MORE
	CALL	GCI	;EAT THE COMMA
	MOV	A,B	;GET THE TERMINATOR TO A
	CPI	','
	JZ	IN1	;GET THE NEXT INPUT VALUE FROM STRING
;
;	GET NEW LINE FROM USER
;
	MVI	B,'?'
	CALL	CHOUT
	JMP	INP0
;
NCRLF:	CALL	GCI
	JMP	LINP	;NOW GET LINE
;
INERR:	LXI	H,INPER
	JMP	ERROR
;
;
;	- TPUT -  ROUTINE TO OUTPUT CHARACTER FROM C TO TEKTRONIX
;
TPUT:	IN	3
	ANI	1
	JZ	TPUT
	MOV	A,C
	OUT	2
	RET
;
;
;	- TEKOUT -  ROUTINE TO OUTPUT X OR Y ADDRESS FROM DE TO
;			TEKTRONIX.
;
;
TEKOUT:	MOV	A,D
	RLC
	RLC
	RLC
	ANI	18H
	ORI	20H
	MOV	D,A
	MOV	A,E
	RLC
	RLC
	RLC
	ANI	7H
	ORA	D
	MOV	D,A
	MOV	A,E
	ANI	1FH
	ORA	B
	MOV	E,A
	MOV	C,D
	CALL	TPUT
	MOV	C,E
	CALL	TPUT
	RET
;
;
BEAM:	MVI	C,29
	CALL	TPUT	;PUT TEK IN GRAPH MODE
DRAW:	CALL	EXPRB
	CALL	PFIX
	PUSH	D	;SAVE X VALUE
	MVI	B,','
	CALL	EATC
	CALL	EXPRB
	CALL	PFIX
	MVI	B,60H
	CALL	TEKOUT
	POP	D
	MVI	B,40H
	CALL	TEKOUT
	RET
;
;
;
;	- CPUSH - ROUTINE TO PUSH 16-BIT INTEGERS ON
;		MACHINE LANGUAGE LINKAGE STACK
;
CPUSH:	CALL	EXPRB	;EVALUATE EXPRESSION
	CALL	PFIX	;CONVERT RESULT TO INTEGER
	LHLD	MACSP	;SET UP FOR BOUNDS CHECK
	LXI	B,-(MACSTK-MACSIZ)
	CALL	ARGPSH	;PUSH INTEGER ON STACK (IF ROOM)
	SHLD	MACSP	;UPDATE STACK POINTER
	CALL	EATCOM	;CHECK FOR MORE
	JMP	CPUSH	;IF MORE
;
;	- STRAP - ROUTINE TO PUSH LINE NUMBERS ON TRAP STACK
;
STRAP:	CALL	INTGER	;GET LINE NUMBER
	JC	E1	;IF INVALID
	XCHG
	LHLD	TRPSP	;SET UP BOUNDS CHECK
	LXI	B,-(TRPSTK-TRPSIZ)
	CALL	ARGPSH	;PUSH LINE NUMBER (IF ROOM)
	SHLD	TRPSP	;UPDATE STACK POINTER
	CALL	EATCOM	;CHECK FOR MORE
	JMP	STRAP	;IF MORE
;
;	- CPOKE - ROUTINE TO WRITE BYTES INTO MEMORY
;
CPOKE:	CALL	EXPRB	;EVALUATE ADDR EXPRESSION
	CALL	PFIX	;CONVERT TO INTEGER
	PUSH	D	;SAVE ADDR
	MVI	B,5BH
	CALL	EATC
CPOK1:	CALL	BYTARG	;CONVERT NEXT EXPRESSION TO BYTE
	POP	H	;RETRIEVE ADDR
	MOV	M,E	;WRITE BYTE
	INX	H
	PUSH	H	;SAVE NEW ADDR
	LXI	H,CPOK2	;SET UP RETURN ADDR IF NEXT NON-BLANK<>','
	PUSH	H
	CALL	EATCOM
	POP	H	;CHAR=','
	JMP	CPOK1
;
CPOK2:	MVI	B,']'	;TEST FOR ']'
	CALL	EATC
	POP	H	;CLEAN OUT STACK IN CASE DONE
	CALL	EATCOM
	PUSH	H
	JMP	CPOKE
;
;	- COUT - ROUTINE TO OUTPUT BYTES TO OUTPUT DEVICES
;
COUT:	CALL	BYTARG	;GET PORT NUMBER
	MOV	A,E
	STA	COUT3+1	;SET UP OUTPUT INSTRUCTION
	MVI	B,'['	;FIND '['
	CALL	EATC
COUT1:	CALL	BYTARG	;GET OUTPUT BYTE
	MOV	A,E
	CALL	COUT3	;OUTPUT IT
	LXI	H,COUT2	;IN CASE NEXT NON-BLANK<>','
	PUSH	H
	CALL	EATCOM
	POP	H
	JMP	COUT1
;
COUT2:	MVI	B,']'	;TEST FOR ']'
	CALL	EATC
	CALL	EATCOM
	JMP	COUT
;
COUT3:	OUT	0
	RET
;
;	- BYTARG - ROUTINE TO EVALUATE TEXT EXPRESSIONS, CONVERT
;		RESULT TO INTEGER, AND MAKE SURE INTEGER IS A
;		BYTE VALUE
;
BYTARG:	CALL	EXPRB
BYTAR1:	CALL	PFIX
	XRA	A
	ORA	D
	RZ
	JMP	E3
;
;	- ARGPSH - ROUTINE TO PUSH 16-BIT VALUES ON STACKS
;		AND DO BOUNDS CHECKING ON STACKS
;	ENTRY - HL IS STACK POINTER, BC IS NEGATIVE OF UPPER LIMIT
;		OF STACK
;	EXIT - HL IS UPDATED STACK POINTER
;
ARGPSH:	PUSH	H	;SAVE SP
	DAD	B	;DO BOUNDS CHECK
	MOV	A,H
	ORA	L
	JNZ	ARPS1	;IF ROOM ON STACK
	LXI	H,ISTAK
	JMP	ERROR
;
ARPS1:	POP	H	;RETRIEVE SP
	MOV	M,D	;PUSH WORD
	DCX	H
	MOV	M,E
	DCX	H
	RET
;
;	- EATCOM - ROUTINE TO CHECK NEXT NON-BLANK FOR ','
;		IF ',' THEN EAT IT AND ADVANCE TO NEXT NON-BLANK
;		RETURN TO CALLER
;		IF NOT ',' THEN POP ONE WORD OFF STACK AND RETURN
;		TO CALLER OF CALLER
;
EATCOM:	CALL	GC
	CPI	','
	JZ	ETCO1
	POP	H
	RET
;
ETCO1:	CALL	GCI
	CALL	GC
	RET
;
;		EVALUATE AN EXPRESSION FROM TEXT
;	HL TAKE OP TABLE ADDR OF PREVIOUS OPERATOR (NOT CHANGED)
;	RESULT VALUE LEFT ON TOP OF ARG STACK, ARGF LEFT TRUE
;
EXPRB:	MVI	B,0
EXPB1:	LXI	H,OPBOL
	XRA	A
	STA	RELTYP
;
;	ZERO IN B MEANS PRINCIPAL OPERATOR MAY NOT BE RELATIONAL
;
EXPR:	PUSH	B
	PUSH	H	;PUSH OPTBA
	XRA	A
	STA	ARGF
EXPR1:	LDA	ARGF
	ORA	A
	JNZ	EXPR2
	CALL	VAR	;LOOK FOR VARIABLE PERHAPS SUBSCRIPTED
	CNC	PSHAS
	JNC	EXPR2
	CALL	CONST
	JNC	EXPR2
	CALL	GC
	CPI	LPARRW
	LXI	H,OPLPAR
	JZ	XLPAR
;
;	ISN'T OR SHOULDN'T BE AN ARGUMENT
;
EXPR2:	CALL	GC
	CPI	340Q	;CHECK FOR RESERVED WORD OPERATOR
	JNC	XOP
	CPI	300Q	;CHECK FOR BUILT IN FUNCTION
	JNC	XBILT
;
;	ILLEGAL EXPRESSION CHARACTER
;
	POP	H	;GET OPTABA
	LDA	ARGF
	ORA	A
	JZ	E1
XDON1:	POP	PSW
	LXI	H,RELTYP;CHECK IF LEGAL PRINCIPAL OPERATOR
	CMP	M
	RZ
	JMP	E1
;
XOP:	ANI	37Q	;CLEANS OFF RW BITS
	LHLD	ARGF	;TEST FOR ARGF TRUE
	DCR	L
	JZ	XOP1
;
;	ARGF WAS FALSE, UNARY OPS ONLY POSSIBILITY
;
	CPI	'-'-OPBASE
	JZ	XOPM
	CPI	'+'-OPBASE
	JNZ	E1
	CALL	GCI	;EAT THE '+'
	JMP	EXPR1
;
XOPM:	MVI	A,UMINU-OPBASE
XOP1:	CALL	OPADR
	POP	D	;PREVIOUS OPTBA
	LDAX	D
	CMP	M
	JNC	XDON1	;NON-INCREASING PRECEDENCE
;
;	INCREASING PRECEDENCE CASE
;
	PUSH	D	;SAVE PREVIOUS OPTBA
	PUSH	H	;SAVE CURRENT OPTBA
	CALL	GCI	;TO GOBBLE OPERATOR
	POP	H
	PUSH	H
	MVI	B,0	;SPECIFY NON-RELATIONAL
	CALL	EXPR
	POP	H
;
;	HL HAS OPTBA ADDR
;	SET UP ARGS AND PERFORM OPERATION ACTION
;
XOP2:	PUSH	H
	MOV	A,M
	LHLD	ASTKA
	MOV	B,H
	MOV	C,L
	ANI	1
	JNZ	XOP21
;
;	DECREMENT SP BY 1 VALUE BINARY CASE
;
	LXI	D,FPSIZ
	DAD	D
	SHLD	ASTKA
	MOV	D,H
	MOV	E,L
XOP21:	LXI	H,EXPR1
	XTHL		;CHANGE RETURN LINK
	INX	H	;SKIP OVER PRECEDENCE
	CALL	LHLI	;LOAD ACTION ADDR
	PCHL
;
;	ACTION ROUTINE CONVENTION
;	DE LEFT ARG AND RESULT FOR BINARY
;	BC RIGHT ARG FOR BINARY, ARG AND RESULT FOR UNARY
;	BUILT IN FUNCTION PROCESSING
;
XBILT:	CALL	GCI	;EAT TOKEN
	ANI	77Q	;CLEAN OFF RW BITS
	LHLD	ARGF	;BUILT IN FUNCTION MUST COME AFTER OPERATOR
	DCR	L
	JZ	E1
	CALL	OPADR	;OPTBA TO HL
XLPAR:	PUSH	H
	MVI	B,LPARRW
	CALL	EATC
	CALL	EXPRB
	MVI	B,')'
	CALL	EATC
	POP	H	;CODE FOR BUILT IN FUNCTION
	JMP	XOP2
;
;	COMPUTE OP TABLE ADDR FOR OPERATOR IN ACC
;
OPADR:	MOV	C,A
	MVI	B,0
	LXI	H,OPTAB
	DAD	B
	DAD	B
	DAD	B	;OPTAB ENTRY ADDR IS 3*OP+BASE
	RET
;
;	PREPROCESSOR, UN-PREPROCESSOR
;	PREPROCESS LINE IN IBUF BACK INTO IBUF
;	SETS CARRY IF LINE HAS NO LINE NUMBER
;	LEAVES CORRECT LENGTH OF LINE AFTER PREPROCESSING IN IBCN
;	IF THERE IS A LINE NUMBER, IT IS LOCATED AT IBLN=IBUF-2
;	TXA IS CLOBBERED
;
PP:	LXI	H,IBUF	;FIRST CHARACTER OF INPUT LINE
	SHLD	TXA	;SO GCI WILL WORK
	CALL	INTGER	;SETS CARRY IF NO LINE NUMBER
	SHLD	IBLN	;STORE LINE NUMBER VALUE (EVEN IF NONE)
	PUSH	PSW	;SAVE STATE OF CARRY BIT
	LHLD	TXA	;ADDRESS OF NEXT CHARACTER IN IBUF
	MVI	C,4	;SET UP INITIAL VALUE FOR COUNT
	LXI	D,IBUF	;INITIALIZE WRITE POINTER
;
;	COME HERE TO CONTINUE PREPROCESSING LINE
;
PPL:	PUSH	D
	LXI	D,RWT	;BASE OF RWT
PPL1:	PUSH	H	;SAVE TEXT ADDRESS
	LDAX	D	;RW VALUE FOR THIS ENTRY IN RWT
	MOV	B,A	;SAVE IN B IN CASE OF MATCH
PPL2:	INX	D	;ADVANCE ENTRY POINTER TO NEXT BYTE
	LDAX	D	;GET NEXT CHARACTER FROM ENTRY
	CMP	M	;COMPARE WITH CHARACTER IN TEXT
	JNZ	PPL3
	INX	H	;ADVANCE TEXT POINTER
	JMP	PPL2
;
;	COME HERE WHEN COMPARISON OF BYTE FAILED
;
PPL3:	ORA	A
	JM	PPL6	;JUMP IF FOUND MATCH
;
;	SCAN TO BEGINNING OF NEXT ENTRY
;
PPL4:	INX	D	;ADVANCE ENTRY POINTER
	LDAX	D	;NEXT BYTE IS EITHER CHARACTER OR RW BYTE
	ORA	A
	JP	PPL4	;KEEP SCANNING IF NOT RW BYTE
;
;	NOW SEE IF AT END OF TABLE, AND FAIL OR RETURN CONDITION
;
	POP	H	;RECOVER ORIGINAL TEXT POINTER
	XRI	377Q	;CHECK FOR END OF TABLE BYTE
	JNZ	PPL1	;CONTINUE SCAN OF TABLE
;
;	DIDN'T FIND AN ENTRY AT THE GIVEN TEXT ADDR
;
	POP	D
	MOV	A,M	;GET TEXT CHARACTER
	CPI	CR	;CHECK FOR END OF LINE
	JZ	PPL8	;GO CLEAN UP AND RETURN
	STAX	D
	INX	D
	INR	C
	INX	H	;ADVANCE TEXT POINTER
	CPI	'"'	;CHECK FOR QUOTED STRING POSSIBILITY
	JNZ	PPL	;RESTART RWT SEARCH AT NEXT CHARACTER POSITION
;
;	HERE WE HAVE A QUOTED STRING, SO EAT TILL ENDQUOTE
;
PPL5:	MOV	A,M	;NEXT CHARACTER
	CPI	CR
	JZ	PPL8	;NO STRING ENDQUOTE, LET INTERPRETTER WORRY
	STAX	D
	INX	D
	INR	C
	INX	H	;ADVANCE TEXT POINTER
	CPI	'"'
	JZ	PPL	;BEGIN RWT SCAN FROM NEW CHARACTER POSITION
	JMP	PPL5
;
;	FOUND MATCH SO PUT RW VALUE IN TEXT
;
PPL6:	POP	PSW	;REMOVE UNNEEDED TEST POINTER FROM STACK
	POP	D
	MOV	A,B
	STAX	D
	INX	D
	INR	C
	ANI	240Q	;TEST FOR COMMAND RW
	CPI	240Q
	JNZ	PPL	;IF NOT COMMAND
	MOV	A,B	;TEST FOR BIT 6 SET
	ANI	100Q
	JNZ	PPL	;IF SET
	JMP	PPL5	;END PREPROCESSING OF COMMAND LINE
;
;	COME HERE WHEN DONE
;
PPL8:	MVI	A,CR
	STAX	D
	LXI	H,IBCNT	;SET UP COUNT IN CASE LINE OF LINE NUMBER
	MOV	M,C
	POP	PSW	;RESTORE CARRY (LINE NUMBER FLAG)
	RET
;
;	UN-PREPROCESS LINE ADDRESSES IN HL TO DE BUFFER
;	RETURN SOURCE ADDRESS OF CR IN HL ON RETURN
;
UPPL:	INX	H	;SKIP OVER COUNT BYTE
	PUSH	H	;SAVE SOURCE TEXT POINTER
	CALL	LHLI	;LOAD LINE NUMBER VALUE
	CALL	CNS	;CONVERT LINE NUMBER
	MVI	A,' '
	STAX	D	;PUT BLANK AFTER LINE NUMBER
	INX	D	;INCREMENT DESTINATION POINTER
	POP	H
	INX	H	;INCREMENT H PAST LINE NUMBER
UPP0:	INX	H
	MOV	A,M	;NEXT TOKEN IN SOURCE
	ORA	A
	JM	UPP1	;JUMP IF TOKEN IS RW
	STAX	D	;PUT CHARACTER IN BUFFER
	CPI	CR	;CHECK FOR DONE
	RZ
	INX	D	;ADVANCE DESTINATION BUFFER ADDRESS
	JMP	UPP0
;
;	COME HERE WHEN RW BYTE DETECTED IN SOURCE
;
UPP1:	PUSH	H	;SAVE SOURCE POINTER
	LXI	H,RWT	;BASE OF RWT
UPP2:	CMP	M	;SEE IF RW MATCHED RWT ENTRY
	INX	H	;ADVANCE RWT POINTER
	JNZ	UPP2	;CONTINUE LOOKING IF NOT FOUND
;
;	FOUND MATCH, ENTRY POINTER LOCATES FIRST CHARACTER
;
UPP3:	MOV	A,M	;CHARACTER OF RW
	ORA	A	;CHECK FOR DONE
	JM	UPP4
	STAX	D
	INX	D
	INX	H
	JMP	UPP3
;
;	COME HERE IF DONE WITH RW TRANSFER
;
UPP4:	POP	H	;SOURCE POINTER
	JMP	UPP0
;
;	CONSTANTS AND TABLES
;
HEAD:	DB	'BASIC/5 INTERACTIVE INTERPRETER    V Z1.0  10/16/77"'
RDYS:	DB	'READY"'
RNING:	DB	'RUNNING"'
PLS:	DB	'NEW OR OLD? "'
;
;	TABLE OF ERROR MESSAGES
;
ARGUM:	DB	'ARGUMENT "'
SYNTX:	DB	'SYNTAX "'
CSTAK:	DB	'CONTROL STACK "'
ISTAK:	DB	'INTERNAL STACK "'
DIRIN:	DB	'DIRECT INPUT "'
DIMEN:	DB	'DIMENSION "'
FLOAT:	DB	'FLOATING POINT "'
INPER:	DB	'INPUT "'
LENGT:	DB	'LINE OVERFLOW "'
LNUMB:	DB	'LINE NUMBER "'
NGSQR:	DB	'NEGATIVE SQUARE ROOT "'
BOUND:	DB	'BOUNDS "'
RDERR:	DB	'READ "'
STOVL:	DB	'STORAGE OVERFLOW "'
FSERR:	DB	'FILE SPACE "'
DSERR:	DB	'DIRECTORY SPACE "'
FSIZE:	DB	'FILE SIZE "'
FNAME:	DB	'FILE NAME "'
RNDER:	DB	'RANDOM ACCESS FILE "'
;
;
ERS:	DB	'ERROR"'
INS:	DB	' IN LINE "'
STOPS:	DB	'STOP"'
OPN:	DB	'OLD PROGRAM NAME: "'
NPN:	DB	'NEW PROGRAM NAME: "'
;
	DB	0FFH	;FLAGS END OF SINE COEFFICIENT LIST
	DB	0
	DB	1*16
	DW	0
	DB	0
FPONE:	DB	129	;EXPONENT
;
;	SINE COEFFICIENT LIST
;	NOTE:  THE FLOATING PNT 1 ABOVE IS A PART OF THIS TABLE
;
	DB	1*16+6
	DB	6*16+6
	DB	6*16+7
	DB	1
	DB	128	;-.166667 E 0 (-1/3 FACTORIAL)
	DB	8*16+3
	DB	3*16+3
	DB	3*16+3
	DB	0
	DB	128-2	;.833333 E-2 (1/5 FACT)
	DB	1*16+9
	DB	8*16+4
	DB	1*16+3
	DB	1
	DB	128-3	;-.198413 E-3 (-1/7 FACT)
	DB	2*16+7
	DB	5*16+5
	DB	7*16+3
	DB	0
	DB	128-5	;.275573 E-5 (1/9 FACT)
	DB	2*16+5
	DB	0*16+5
	DB	2*16+1
	DB	1
SINX:	DB	128-7	;-.250521 E-7 (-1/11 FACT)
;
;	COSINE COEFFICIENT LIST
;
	DB	0FFH	;MARKS END OF LIST
	DB	0
	DB	1*16+0
	DB	0
	DB	0
	DB	0
	DB	128+1	;.100000 E 1 (1/1 FACT)
	DB	5*16+0
	DB	0
	DB	0
	DB	1
MATUB:	DB	128	;-.500000 E 0 (-1/2 FACT)
	DB	4*16+1
	DB	6*16+6
	DB	6*16+7
	DB	0
RANDS:	DB	128-1	;.416667 E-1 (1/4 FACT)
	DB	1*16+3
	DB	8*16+8
	DB	8*16+9
	DB	1
	DB	128-2	;.138889 E-2 (-1/6 FACT)
	DB	2*16+4
	DB	8*16+0
	DB	1*16+6
	DB	0
	DB	128-4	;.248016 E-4 (1/8 FACT)
	DB	2*16+7
	DB	5*16+5
	DB	7*16+3
	DB	1
COSX:	DB	128-6	;.275573 E-6 (-1/10 FACT)
	DB	2*16
	DW	0
	DB	0
FPTWO:	DB	129
	DB	1*16+5
	DB	7*16+0
	DB	8*16+0
	DB	0
PIC2:	DB	128+1	;PI/2  .157080 E 1
	DB	6*16+3
	DB	6*16+6
	DB	2*16+0
	DB	0
PIC1:	DB	128	;2/PI  .636620 E 0
LCSTKA:	DW	CSTKL
;
;	COMMAND TABLE
;
CMNDD:	DW	CRUN	;0
	DW	LLIST	;1 LIST ON LINE PRINTER

	DW	CNULL	;2
	DW	CSCR	;3
	DW	CNEW	;4 SET UP MEMORY BOUNDS
	DW	SAVE	;5 DISK SAVE BASIC PROGRAM
	DW	COLD	;6 LOAD BASIC PROGRAM FROM DISK
	DW	CSYS	;7 RETURN TO CP/M SYSTEM
	DW	CNAME	;8 RENAME OR OUTPUT NAME OF WS
	DW	ERA	;9 ERASE FILE
	DW	CLIST	;10 LIST
;
;	STATEMENT TABLE
;
STATD:	DW	LET	;0
	DW	NEXT	;1
	DW	SIF	;2
	DW	SGOTO	;3
	DW	GOSUB	;4
	DW	RETRN	;5
	DW	READ	;6
	DW	DATA	;7
	DW	SFOR	;8
	DW	LPRINT	;9
	DW	INPUT	;10
	DW	DIM	;11
	DW	STOP	;12
	DW	CEND	;13
	DW	RESTOR	;14
	DW	REM	;15
	DW	CCLEAR	;16
	DW	CPUSH	;17
	DW	CPOKE	;18
	DW	COUT	;19
	DW	STRAP	;20
	DW	BEAM	;21
	DW	DRAW	;22
	DW	PRINT	;23
;
;	R/W WORD TABLE FORMAT IS RESERVED WORD FOLLOWED BY CHR
;	OF RESERVED WORD.  LAST ENTRY IS FOLLOWED BY A 377Q
;	RW'S THAT ARE SUBSTRINGS OF OTHER RW'S (E. G. >) MUST
;	FOLLOW THE LARGER WORD.
;
RWT:	DB	200Q
	DB	'LET'
	DB	201Q
	DB	'NEXT'
	DB	202Q
	DB	'IF'
	DB	203Q
	DB	'GOTO'
	DB	204Q
	DB	'GOSUB'
	DB	205Q
	DB	'RETURN'
	DB	206Q
	DB	'READ'
	DB	207Q
	DB	'DATA'
DATARW	EQU	207Q
	DB	210Q
	DB	'FOR'
	DB	211Q
	DB	'LPRINT'
	DB	211Q
	DB	':'
	DB	212Q
	DB	'INPUT'
	DB	213Q
	DB	'DIM'
	DB	214Q
	DB	'STOP'
	DB	215Q
	DB	'END'
	DB	216Q
	DB	'RESTORE'
	DB	217Q
	DB	'REM'
	DB	220Q
	DB	'CLEAR'
CLRRW	EQU	220Q
	DB	221Q
	DB	'PUSH'
	DB	222Q
	DB	'POKE'
	DB	223Q
	DB	'OUT'
	DB	224Q
	DB	'TRAP'
	DB	225Q
	DB	'BEAM'
	DB	226Q
	DB	'DRAW'
	DB	227Q
	DB	'PRINT'
IRWLIM	EQU	230Q	;LAST INITIAL RESERVED WORD VALUE+1
;
;
	DB	237Q
	DB	'STEP'
STEPRW	EQU	237Q
	DB	236Q
	DB	'TO'
TORW	EQU	236Q
	DB	235Q
	DB	'THEN'
THENRW	EQU	235Q
	DB	234Q
	DB	'TAB'
TABRW	EQU	234Q
;
;	COMMANDS
;
	DB	240Q
	DB	'RUN'
RUNRW	EQU	240Q
	DB	241Q
	DB	'LLIST'
	DB	242Q
	DB	'NULL'
NULLRW	EQU	242Q
	DB	243Q
	DB	'SCR'
SCRRW	EQU	243Q
	DB	244Q
	DB	'NEW'
NEWRW	EQU	244Q
	DB	245Q
	DB	'SAVE'
	DB	246Q
	DB	'OLD'
	DB	247Q
	DB	'SYSTEM'
	DB	250Q
	DB	'NAME'
	DB	251Q
	DB	'ERA'
	DB	251Q
	DB	'UNSAVE'
	DB	252Q
	DB	'LIST'
LISTRW	EQU	252Q
;
;
LPARRW	EQU	'('-OPBASE+340Q
	DB	LPARRW
	DB	'('
	DB	'*'-OPBASE+340Q
	DB	'*'
PLSRW	EQU	'+'-OPBASE+340Q
	DB	PLSRW
	DB	'+'
MINRW	EQU	'-'-OPBASE+340Q
	DB	MINRW
	DB	'-'
	DB	'/'-OPBASE+340Q
	DB	'/'
	DB	67Q-OPBASE+340Q
	DB	'>='
	DB	70Q-OPBASE+340Q
	DB	'<='
	DB	71Q-OPBASE+340Q
	DB	'<>'
	DB	62Q-OPBASE+340Q
	DB	'=>'
	DB	63Q-OPBASE+340Q
	DB	'=<'
	DB	'<'-OPBASE+340Q
	DB	'<'
EQRW	EQU	'='-OPBASE+340Q
	DB	EQRW
	DB	'='
	DB	'>'-OPBASE+340Q
	DB	'>'
	DB	301Q
	DB	'ABS'
	DB	306Q
	DB	'INT'
	DB	314Q
	DB	'ARG'
	DB	315Q
	DB	'CALL'
	DB	316Q
	DB	'RND'
	DB	322Q
	DB	'SGN'
	DB	323Q
	DB	'SIN'
	DB	304Q
	DB	'SQR'
	DB	327Q
	DB	'TAN'
	DB	330Q
	DB	'COS'
	DB	331Q
	DB	'POP'
	DB	332Q
	DB	'PEEK'
	DB	333Q
	DB	'INP'
	DB	334Q
	DB	'UNTRAP'
	DB	377Q	;END OF TABLE
;
;	OPERATION TABLE
;
OPTAB:	DB	15
OPLPAR	EQU	OPTAB
	DW	ALPAR
	DB	15
	DW	AABS
	DB	10
	DW	AMUL
	DB	6
	DW	AADD
	DB	15
	DW	ASQR
	DB	6
	DW	ASUB
	DB	15
	DW	AINT
	DB	10
	DW	ADIV
OPBOL:	DB	1
	DW	0
	DB	13
	DW	ANEG
	DB	4
	DW	AGE
	DB	4
	DW	ALE
	DB	15
	DW	AARG
	DB	15
	DW	ACALL
	DB	15
	DW	ARND
	DB	4
	DW	AGE
	DB	4
	DW	ALE
	DB	4
	DW	ANE
	DB	15
	DW	ASGN
	DB	15
	DW	ASIN
	DB	4
	DW	ALT
	DB	4
	DW	AEQ
	DB	4
	DW	AGT
	DB	15
	DW	ATAN
	DB	15
	DW	ACOS
	DB	15
	DW	APOP
	DB	15
	DW	APEEK
	DB	15
	DW	AINP
	DB	15
	DW	AUNTRP
;
;	ACTION ROUTINES FOR RELATIONAL OPEATORS
;
AGT:	CALL	RELOP
	JZ	RFALSE
	JM	RTRUE
RFALSE:	XRA	A
	STAX	D
	RET
ALT:	CALL	RELOP
	JZ	RFALSE
	JM	RFALSE
RTRUE:	MVI	A,377Q
	STAX	D
	RET
AEQ:	CALL	RELOP
	JZ	RTRUE
	JMP	RFALSE
;
ANE:	CALL	RELOP
	JZ	RFALSE
	JMP	RTRUE
;
AGE:	CALL	RELOP
	JZ	RTRUE
	JM	RTRUE
	JMP	RFALSE
;
ALE:	CALL	RELOP
	JZ	RTRUE
	JM	RFALSE
	JMP	RTRUE
;
;	COMMON ROUTINE FOR RELATIONAL OPERATOR ACTION
;
;	LEFT ARG ADDR IN DE, SAVED
;	RIGHT ARG ADDR IN BC
;	ON RETURN, SIGN SET=GT, ZERO SET=EQUAL
;
RELOP:	PUSH	D
	DCX	B
	DCX	D
	MOV	H,B
	MOV	L,C
	LDAX	D
	SUB	M
	INX	H
	INX	D
	JNZ	RLOP1	;TEST SIGNS OF ARGS IF DIFFERENT THEN RET
	LXI	B,FPSINK
	CALL	FSUB
	LDA	FPSINK	;CHECK FOR ZERO RESULT
	ORA	A
	JZ	RLOP1
	LDA	FPSINK-1;SIGN OF FPSINK
	RLC
	DCR	A
RLOP1:	MVI	A,1
	STA	RELTYP	;SET RELTYPE TRUE
	POP	D
	RET
;
;	ACTION ROUTINES FOR ARITHMETIC OPERATORS
;		(CODE WASTERS)
;
AADD:	MOV	H,B
	MOV	L,C
	MOV	B,D
	MOV	C,E
AADD1:	CALL	FADD
	JMP	FPETST
;
ASUB:	MOV	H,B
	MOV	L,C
	MOV	B,D
	MOV	C,E
ASUB1:	CALL	FSUB
	JMP	FPETST
;
AMUL:	MOV	H,B
	MOV	L,C
	MOV	B,D
	MOV	C,E
AMUL1:	CALL	FMUL
	JMP	FPETST
;
ADIV:	MOV	H,B
	MOV	L,C
	MOV	B,D
	MOV	C,E
ADIV1:	CALL	FDIV
FPETST:	XRA	A
	STA	RELTYP
	LDA	ERRI
	ORA	A
	RZ
	LHLD	ASTKA	;ZERO RESULT ON UNDERFLOW
FPET1:	MVI	M,0
ALPAR:	RET
;
;	UNARY AND BUILT IN FUNCTION ACTION ROUTINES
;
ANEG:	LDAX	B
	ORA	A
	JZ	ANEG1
	DCX	B
	LDAX	B
	XRI	1
	STAX	B
ANEG1:	XRA	A
	STA	RELTYP
	RET
;
AABS:	DCX	B
	XRA	A
	STAX	B
	JMP	ANEG1
;
ASGN:	CALL	ANEG1
	MOV	D,B
	MOV	E,C
	LDAX	B	;GET EXPONENT
	ORA	A
	JNZ	ASGN1
	STAX	D	;MAKE ARGUMENT ZERO
	RET
;
ASGN1:	DCX	B
	LDAX	B
	ORA	A
	LXI	H,FPONE
	JZ	VCOPY
	LXI	H,FPNONE
	JMP	VCOPY
;
;	COMPUTE SINE(X) X=TOP OF ARG STACK
;	RETURN RESULT IN PLACE OF X
;
ASIN:	CALL	QUADC	;COMPUTE QUADRANT
	LHLD	ASTKA
	MOV	D,H
	MOV	E,L
	LXI	B,FTEMP
	CALL	AMUL1	;FTEMP = X*X
	POP	PSW
	PUSH	PSW	;A=QUADRANT
	RAR
	JC	SIN10	;QUAD ODD. COMPUTE COSINE
;
;	COMPUTE X*P(X*X) -- SINE
;
	LXI	D,FTEM1
	LHLD	ASTKA
	CALL	VCOPY	;FTEM1=X*X
	LXI	B,SINX
	CALL	POLY	;P(X*X)
	CALL	PREPOP
	LXI	H,FTEM1
	CALL	AMUL1	;X*P(X*X)
;
;	COMPUTE SIGN OF RESULT
;	POSITIVE FOR QUADRANT 0,1.  NEGATIVE FOR 2,3
;	NEGATE ABOVE FOR NEGATIVE ARGUMENTS
;
SIN5:	POP	PSW	;QUADRANT
	MOV	B,A
	POP	PSW	;SIGN
	RLC		;SIGN, 2 TO THE 1ST BIT
	XRA	B	;QUADRANT, MAYBE MODIFIED FOR NEGATIVE ARG
	LHLD	ASTKA
	DCX	H	;PTR TO SIGN
	SUI	2
	RM		;QUADRANT 0 OR 1
	INR	M	;ELSE SET RESULT NEGATIVE
	RET
;
;	COMPUTE P(X*X) -- COSINE
;
SIN10:	LXI	B,COSX
	CALL	POLY	;P(X*X)
	JMP	SIN5
;
;		COMPUTE COS(X)   X=TOP OF ARGUMENT STACK
;	RETURN RESULT IN PLACE OF X
;	COS(X)=SIN(X+PI/2)
;
ACOS:	CALL	PREPOP
	LXI	H,PIC2	;PI/2
	CALL	AADD1	;TOS=TOS+PI/2
	JMP	ASIN
;
;	COMPUTE TAN(X) X=TOP OF ARGUMENT STACK
;	RETURN RESULT IN PLACE OF X
;	TAN(X)=SIN(X)/COS(X)
;
ATAN:	LHLD	ASTKA
	CALL	PSHAS	;PUSH COPY OF X ONTO ARG STACK
	CALL	ACOS	;COS(X)
	LXI	D,FTEM2
	CALL 	POPA1	;FTEM2=COS(X)
	CALL	ASIN
	CALL 	PREPOP
	LXI	H,FTEM2
	JMP	ADIV1	;SIN(X)/COS(X)
;
;	COMPUTE SQR(X) X=TOP OF ARGUMENT STACK
;	RETURN RESULT IN PLACE OF X
;
ASQR:	LHLD 	ASTKA
	LXI	D,FTEMP
	CALL	VCOPY	;SAVE X IN FTEMP
;
;	COMPUTE EXPONENT OF FIRST GUESS AS EXPONENT OF X/2
;
	LHLD	ASTKA
	MOV	A,M
	ORA	A
	RZ	;	X=0
	SUI	128
	JM	SQR5	;NEGATIVE EXPONENT
	RRC
	ANI	127
	JMP	SQR6
;
SQR5:	CMA
	INR	A
	RRC
	ANI	127
	CMA
	INR	A
SQR6:	ADI	128
	MOV	M,A
;
;	TEST FOR NEGATIVE ARGUMENT
	DCX	H
	MOV	A,M
	LXI	H,NGSQR
	ORA	A
	JNZ	ERROR	;NEG ARG
;
;	DO NEWTON ITERATIONS
;	NEWGUESS=(X/OLDGUESS+OLDGUESS)/2
;
	MVI	A,6	;DO 6 ITERATIONS
SQR20:	PUSH	PSW	;SET NEW ITERATION COUNT
	LXI	B,FTEM1
	LXI	D,FTEMP	;FTEMP IS 'X'
	LHLD	ASTKA	;GUESS
	CALL	ADIV1	;FTEM1 = X/GUESS
	LXI	D,FTEM1
	LHLD	ASTKA
	MOV	B,H
	MOV	C,L
	CALL	AADD1	;TOS=(X/GUESS)+GUESS
	CALL	PREPOP
	LXI	H,FPTWO
	CALL	ADIV1	;TOS=(X/GUESS+GUESS)/2
	POP	PSW
	DCR	A	;DECREMENT COUNT
	JNZ	SQR20	;DO ANOTHER ITERATION
	RET
;
;	COMPUTE RND(X)  X=TOP OF ARG STACK
;	FRAMD IS UPDATED TO NEW RANDOM VALUE
;	A RANDOM NUMBER IN THE RANGE 0<RND<1 IS RETURNED IN PLACE
;
ARND:	CALL	PREPOP
	LXI	D,FRAND
	LXI	H,FRAND
	CALL	AMUL1	;TOS= FRAND*FRAND
;
;	SET EXPONENT = 0
;
	LHLD	ASTKA
	MVI	M,128	;EXPONENT=128  (0 IN EXTERNAL FORM)
;
;	PERMUTE DIGITS OF X AS
;	123456 INTO 345612
;
	LXI	B,-4
	DAD	B
	MOV	B,M	;SAVE 12
	INX	H
	INX	H
	CALL	PERMU	;56=12
	CALL	PERMU	;34=56
	CALL	PERMU	;12=34
;
;	NORMALIZE NUMBER
;
RND5:	LHLD	ASTKA	;TOS
	LXI	B,-FPSIZ+1
	DAD	B
	MOV	A,M	;FIRST DIGIT PAIR
	ANI	15*16
	JNZ	RND10	;NUMBER IS NORMALIZED
;
;	SHIFT LEFT 1 DIGIT
;
	LHLD	ASTKA
	MOV	A,M	;EXPONENT
	DCR	A
	STA	EXP
	CALL	LOAD	;TOS INTO TEMP
	MVI	B,4
	CALL	LEFT	;SHIFT LEFT
	CALL	PREPOP
	CALL	STORE
	JMP	RND5	;TEST IF NORMALIZED
;
;	SAVE NEW RANDOM NUMBER FRAND CELL
;
RND10:	LXI	D,FRAND
	LHLD	ASTKA
	CALL	VCOPY	;FRAND=TOS
	RET
;
;	PERMUTE PAIR OF DIGIT PAIRS
;
PERMU:	MOV	A,M
	MOV	M,B
	MOV	B,A
	DCX	H
	RET
;
;	EVALUATE P(X) USING HORNERS METHOD (X IS IN FTEMP)
;	COEFFICIENT LIST POINTER IS IN BC
;	RESULT REPLACES NUMBER ON TOP OF ARG STACK (Y)
;
POLY:	LHLD	ASTKA
	XCHG	;	DE=PTR TO Y
	MOV	H,B
	MOV	L,C	;HL PTR TO COEFFICIENT LIST
	CALL	VCOPY	;Y=FIRST COEFFICIENT
;
;	MULTIPLY BY X
;
POLY1:	PUSH	H	;SAVE COEFF. LIST POINTER
	CALL	PREPOP
	LXI	H,FTEMP
	CALL	AMUL1	;Y=Y*X
;
;	ADD NEXT COEFFICIENT
;
	CALL	PREPOP
	POP	H
	PUSH	H	;HL=COEFF. LIST POINTER
	CALL	AADD1	;Y=Y+COEFF
;
;BUMP POINTER TO NEXT COEFFICIENT
;
	POP	H	;COEFF POINTER
	LXI	B,-FPSIZ-1
	DAD	B	;NEXT COEFF SIGN
	MOV	A,M
	INX	H	;PTR TO EXPONENT
	ORA	A
	JP	POLY1	;PROCESS NEXT COEFF
	RET	;	NEGATIVE SIGN (-1) ENDS LIST
;
;	PREPARE FOR OPERATION
;
PREPOP:	LHLD	ASTKA
	XCHG	;	DE=ASTKA
	MOV	B,D
	MOV	C,E
	RET
;
;	QUADRANT COMPUTATION
;	POPS TOP OF ARGUMENT STACK
;	COMPUTE/GETS SIGN OF ARGUMENT,QUADRANT OF ARGUMENT
;	AND INDEX INTO QUADRANT
;
;	EXITS WITH
;	SP POINTING TO QUADRANT,MOD 4
;	SP+2 POINTING TO SIGN OF ARGUMENT
;	TOP OF ARGUMENT STACK HAS INDEX INTO QUADRANT
;
QUADC:	LHLD	ASTKA
	DCX	H	;POINT TO SIGN
	MOV	B,M
	XRA	A
	MOV	M,A	;ARG SIGN=0
	MOV	H,B
	XTHL	;	PUT SIGN ON STACK, POP RETURN
	PUSH	H	;PUSH RETURN
;
;	COMPUTE QUADRANT OF ABS(X)
;
	LHLD	ASTKA
	CALL	PSHAS	;PUT COPY OF ARG ONTO STACK
	CALL	PREPOP
	LXI	H,PIC1	;2/PI
	CALL	AMUL1	;TOS=X*2/PI
	CALL	PREPOP
	CALL	AINT	;TOS=INT(X*2/PI)
	LHLD	ASTKA
	CALL	PSHAS	;ANOTHER COPY
	CALL	PFIX	;POPS TOS TO DE
	MOV	A,E
	PUSH	PSW	;QUADRANT
	CALL	PREPOP
	LXI	H,PIC2
	CALL	AMUL1	;TOS=INT(X*2/PI)
	LXI	D,FTEMP
	CALL	POPA1	;FTEMP=TOS
	CALL	PREPOP
	LXI	H,FTEMP
	CALL	ASUB1	;TOS=TOS-FTEMP
	POP	PSW
	ANI	3	;MOD 4
	POP	H
	PUSH	PSW	;SAVE QUADRANT ON STACK
	PCHL	;	RETURN
;
;	SET UP ARG FOR USER CALL
;
AARG:	CALL	PFIX
	XCHG
	SHLD	CALLA
	LXI	D,FPSINK
	JMP	PSHA1	;PUTS BACH THE ARG VALUE ON ARG STACK
;
;	USED TO CALL USER ROUTINE
;
ACALL:	CALL	PFIX	;GET THE ADDRESS
	LHLD	CALLA	;GET THE USER ARGUMENT
	LXI	B,ACAL1	;RETURN LINK FOR USER ROUTINE
	PUSH	B
	MOV	B,H	;MOVE ARG TO BC (PL/M CONVENTION)
	MOV	C,L
	LHLD	MACSP	;GET MACHINE LANGUAGE LINKAGE SP
	XCHG
	PCHL
ACAL1:	MOV	H,B	;CONVERT FROM PL/M TO BASIC
	MOV	L,A	
	LXI	D,CALST
	CALL	CNS
	MVI	A,CR
	STAX	D
	LXI	D,CALST
	LXI	H,FPSINK
	CALL	FPIN
	LXI	D,FPSINK
	JMP	PSHA1	;PUT THE RETURNED USER VALUE ON ARG STACK
;
;	- AUNTRP - FUNCTION TO POP LINE NUMBERS FROM TRAP STACK
;
AUNTRP:	CALL	PFIX	;GET POP COUNT
	LHLD	TRPSP	;SET TRAP SP
AUNT1:	LXI	B,-TRPSTK ;SET UP BOUNDS CHECK
	CALL	ARGPOP	;POP LINE NUMBER INTO BC
	SHLD	TRPSP	;UPDATE TRAP SP
	CALL	ARGPA	;PUSH LINE NUMBER ON ARG STACK IF COUNT=0
	JMP	AUNT1	;LOOP TILL COUNT=0
;
;	- APOP - FUNCTION TO POP 16-BIT INTEGERS FROM MACHINE
;		LANGUAGE LINKAGE STACK
;
APOP:	CALL	PFIX	;GET POP COUNT
	LHLD	MACSP	;SET MACHINE LANGUAGE LINKAGE  SP
APOP1:	LXI	B,-MACSTK ;SET UP BOUNDS CHECK
	CALL	ARGPOP	;POP A PARAMETER INTO BC
	SHLD	MACSP	;UPDATE SP
	CALL	ARGPA	;PUSH PARAM ONTO ARG STACK IF COUNT=0
	JMP	APOP1	;LOOP TILL COUNT=0
;
;	- ARGPOP - SUBROUTINE TO POP 16-BIT WORDS FROM STACKS
;		AND DO BOUNDS CHECKING ON STACKS
;	ENTRY - HL IS STACK POINTER, BC IS NEGATIVE OF STACK BASE
;	EXIT - BC IS POPPED WORD, HL IS UPDATED STACK POINTER
;
ARGPOP:	PUSH	H	;SAVE VALUE OF SP
	DAD	B	;CHECK FOR STACK EMPTY
	XRA	A
	ORA	H
	JM	ARGP1	;IF STACK NOT EMPTY
	LXI	H,ISTAK
	JMP	ERROR
;
ARGP1:	POP	H	;RETRIEVE SP
	INX	H	;POP	WORD
	MOV	C,M
	INX	H
	MOV	B,M
	RET
;
;	- ARGPA - ARGPOP AUXILIARY SUBROUTINE
;		DECREMENTS A COUNT IN DE
;		JUMPS TO ACAL1 IF COUNT=0, RETURNS IF NOT
;	ENTRY - BC CONTAINS WORD TO PASS TO ACAL1, DE IS COUNT
;	EXIT - BA CONTAINS WORD
;
ARGPA:	DCX	D
	MOV	A,D
	ORA	E
	RNZ
	MOV	A,C
	POP	H
	JMP	ACAL1
;
;	- APEEK - FUNCTION TO READ CONTENTS OF MEMORY
;
APEEK:	CALL	PFIX	;SET MEMORY ADDR
	LDAX	D	;FETCH BYTE
	MVI	B,0
	JMP	ACAL1	;PUT BYTE ON ARGUMENT STACK
;
;	- AINP - FUNCTION TO INPUT BYTE FROM PORT
;
AINP:	CALL	BYTAR1	;GET PORT ADDR
	MOV	A,E
	STA	AINP1+1	;SET UP INPUT INSTRUCTION
AINP1:	IN	0
	MVI	B,0
	JMP	ACAL1	;PUT BYTE ON ARG STACK
;
;	INT FUNCTION ACTION ROUTINE
;
AINT:	LDAX	B
	SUI	129
	JP	AINT1
;
;	ZERO IF VALUE LESS THAN ONE
;
	MVI	D,FPSIZ
	XRA	A
AINT0:	STAX	B
	DCX	B
	DCR	D
	JNZ	AINT0
	RET
;
;	EXP>0
;
AINT1:	SUI	FPNIB-1
	RNC
	MOV	D,A	;COUNT
	DCX	B
AINT2:	DCX	B
	LDAX	B
	ANI	360Q
	STAX	B
	INR	D
	RZ
	XRA	A
	STAX	B
	INR	D
	JNZ	AINT2
	RET
;
;		DIMENSION MATRIX
;	SYMTAB ADDR IN HL, HL NOT CLOBBERED
;	DE CONTAINS SIZE IN NUMBER OF ELEMENTS
;
DIMS:	PUSH	H
	INX	D
	PUSH	D
	LXI	H,0
	MVI	C,FPSIZ
	CALL	RADD	;MULTIPLY NELTS BY BYTES PER VALUE
	XCHG
	LHLD	MATA	;HL = MATRIX BASE ADDRESS
	MOV	B,H	;COPY HL TO BC
	MOV	C,L
	PUSH	H
	DAD	D	;HL = ADDR. OF 1ST LOC. AFTER THIS MATRIX
MATCLR:	XRA	A	;ZERO STORAGE FOR THIS MATRIX
	STAX	B
	INX	B
	MOV	A,C	;END LOOP WHEN BC=HL
	SUB	L
	MOV	A,B
	SBB	H
	JNZ	MATCLR
	CALL	STOV	;CHECK THAT STORAGE NOT EXHAUSTED
	SHLD	MATA	;UPDATA MATRIX FREE POINTER
	POP	B	;BASE ADDR
	POP	D	;NELTS
	POP	H	;SYMTAB ADDR
	PUSH	H
	MOV	M,D
	DCX	H
	MOV	M,E
	DCX	H
	MOV	M,B
	DCX	H
	MOV	M,C	;SYMTAB ENTRY NOW SET UP
	POP	H
	RET
;
;		FIND VARIABLE OPTIONALLY SUBSCRIPTED IN TEXT
;	SETS CARRY IF NOT FOUND
;	RETURNS ADDR OF VARIABLE IN HL
;	UPDATES TXA IF FOUND
;
VAR:	CALL	ALPHA
	RC
	CALL	NAME2
	CALL	GC
	CPI	LPARRW
	JZ	VAR1	;TEST IF SUBSCRIPTED
;
;	MUST BE SCALAR VARIABLE
;
	CALL	STLK	;RETURNS ENTRY ADDR IN HL
	ORA	A	;CLEAR CARRY
	RET
;
;	MUST BE SUBSCRIPTED
;
VAR1:	CALL	GCI	;GOBBLE LEFT PAREN
	MVI	A,200Q
	ORA	C
	MOV	C,A	;SET TYPE TO MATRIX
	CALL	STLK
	PUSH	H	;SYMBOL TABLE
	LXI	D,10	;DEFAULT MATRIX SIZE
	CC	DIMS	;DEFAULT DIMENSION MATRIX
	CALL	EXPRB	;EVALUATE SUBSCRIPT EXPRESSION
	CALL	PFIX	;DE NOW HAS INTEGER
	MVI	B,')'
	CALL	EATC	;GOBBLE RIGHT PAREN
	POP	H
	DCX	H
	CALL	DCMP	;BOUNDS CHECK INDEX
	JNC	E5
	DCX	H
	DCX	H
	CALL	LHLI	;GET BASE ADDR
	MVI	C,FPSIZ
	INX	D	;BECAUSE BASE ADDR IS TO ELEMENT -1
	CALL	RADD	;ADD INDEX, CLEAR CARRY
	RET
;
;	JUNK ON END OF STATEMENT, TEST IF AT END OF FILE
;	DOES NOT CLOBBER DE
;	EATS CHARACTER AND LINE COUNT AFTER CR
;	LEAVES NEW TXA IN HL
;	SETS CARRY IF END OF FILE
;
JOE:	CALL	GCI
	CPI	';'
	RZ
	CPI	CR
	JNZ	E1
	MOV	A,M
	DCR	A
	JZ	JOE2
	INX	H
	INX	H
	INX	H	;SKIP OVER COUNT AND LINE NUMBER
JOE1:	SHLD	TXA
	RET
;
JOE2:	STC
	JMP	JOE1
;
;		GET NAME FROM TEXT
;	SETS CARRY IF NAME NOT FOUND
;	IF SUCCEEDS RETURNS NAME IN BC, C=0 IF NO DIGIT IN NAME
;
NAME:	CALL	ALPHA
	RC
NAME2:	MOV	B,A
	MVI	C,0
	CALL	DIG
	CMC
	RNC
	MOV	C,A
	ORA	A	;CLEAR CARRY
	RET
;
;		SYMBOL TABLE LOOKUP
;	BC CONTAIN NAME AND CLASS
;	IF NOT FOUND THEN CREATE ZERO'ED ENTRY AND SET CARRY
;	HL HAS ADDRESS ON RET
;
STLK:	LHLD	MEMTOP
	LXI	D,-STESIZ;SET UP BASE AND INCREMENT FOR SEARCH LOOP
STLK0:	MOV	A,M
	ORA	A
	JZ	STLK2	;TEST IF END OF TABLE
	CMP	B
	JNZ	STLK1	;TEST IF ALPHA COMPARES
	DCX	H
	MOV	A,M	;LOOK FOR DIGIT
	CMP	C
	DCX	H
	RZ		;CARRY CLEAR SO RET
	INX	H
	INX	H
STLK1:	DAD	D	;DIDN'T COMPARE, DECREMENT POINTER
	JMP	STLK0
;
;	ADD ENTRY TO SYMTAB
;
STLK2:	MOV	M,B
	DCX	H
	MOV	M,C
	INX	H
	XCHG
	DAD	D
	SHLD	STB	;STORE NEW END OF SYMTAB POINTER
	DCX	D
	DCX	D
	XCHG
	STC
	RET
;
;	GOBBLES NEXT CHARACTER IF ALPHABETIC
;	SETS CARRY IF NOT
;	NEXT CHAR IN ACC ON FAILURE
;
ALPHA:	CALL	GC
	CPI	'A'
	RC
	CPI	'Z'+1
	CMC
	RC
	JMP	DIGT1
;
;	GOBBLES NEXT TEXT CHAR IF DIGIT
;	SETS CARRY IF NOT
;	NEXT CHAR IN ACC ON FAILURE
;
DIG:	CALL	GC
	CPI	'0'
	RC
	CPI	'9'+1
	CMC
	RC
DIGT1:	INX	H
	SHLD	TXA
	RET
;
;	COPYS FPSIZ BYTES AT ADDR HL TO ADDR DE
;	ON EXIT HL POINTS TO ADR-1 OF LAST BYTE COPIED
;
VCOPY:	MVI	C,FPSIZ
VCOP1:	MOV	A,M
	STAX	D
	DCX	H
	DCX	D
	DCR	C
	JNZ	VCOP1
	RET
;
;	PUSH VALUE ADDRESSED BY HL ONTO ARG STACK
;	SETS ARGF, CLEARS CARRY
;
PSHAS:	XCHG
PSHA1:	LHLD	ASTKA
	LXI	B,-FPSIZ
	DAD	B
	SHLD	ASTKA	;DECREMENT ARG STACK POINTER
	XCHG
	CALL	VCOPY
	MVI	A,1
	STA	ARGF	;CLEAR ARGF
	ORA	A	;CLEAR CARRY
	RET
;
;		POP ARG STACK
;	HL CONTAINS ADDRESS TO PUT POPPED VALUE AT
;
POPAS:	XCHG
POPA1:	LHLD	ASTKA
	PUSH	H
	LXI	B,FPSIZ
	DAD	B
	SHLD	ASTKA	;INCREMENT STACK POINTER
	POP	H
	JMP	VCOPY
;
;		PUSH FRAME ONTO CONTROL STACK
;	TAKES MINUS AMOUNT TO SUB FROM CSTKA IN DE
;	DOES OVERFLOW TEST AND RETURNS OLD CSTKA-1
;
PSHCS:	LHLD	CSTKA
	PUSH	H
	DAD	D
	SHLD	CSTKA
	XCHG
	LXI	H,LCSTKA;ADDR CONTAINS CSTKL
	CALL	DCMP
	JC	E4
	POP	H
	DCX	H
	RET
;
;		STORAGE OVERFLOW TEST
;	TEST THAT VALUE IN HL IS BETWEEN MATA AND STB
;	DOES NOT CLOBBER HL
;
STOV:	XCHG
	LXI	H,MATA
	CALL	DCMP
	JC	E8
	LXI	H,STB
	CALL	DCMP
	XCHG
	RC
E8:	LXI	H,STOVL
	JMP	ERROR
;
;	INCREMENT TXA IF NEXT NON-BLANK CHAR IS EQUAL TO B
;	ELSE SYNTAX ERROR
;
EATC:	CALL	GCI
	CMP	B
	RZ
	JMP	E1
;
;	GET NEXT NON-BLANK CHAR INTO ACC
;	INCREMENT PAST BLANKS ONLY
;
GC:	CALL	GCI
	DCX	H
	SHLD	TXA
	RET
;
;		GET NEXT NON-BLANK TEXT CHAR AND INCREMENT TXA
;	DOES NOT CLOBBER DE, BC
;	RETURN CHAR IN ACC
;
GCI:	LHLD	TXA
GCI0:	MOV	A,M
	INX	H
	CPI	' '
	JZ	GCI0
	SHLD	TXA
	RET
;
;		REPEAT ADD
;	ADDS DE TO HL C TIMES
;
RADD:	DAD	D
	DCR	C
	JNZ	RADD
	RET
;
;		PRINT MESSAGE ADDRESSED BY HL
;	ENDS WITH CHARACTER PROVIDED IN C
;	RETURN IN HL ADDRESS OF TERMINATOR
;
PRNTCR:	MVI	C,CR
	JMP	PRN1
;
PRNT:	MVI	C,'"'
PRN1:	MOV	A,M	;GET NEXT CHAR
	MOV	B,A	;FOR CHOUT
	CMP	C	;END OF MESSAGE TEST
	RZ
	CPI	CR
	JZ	E1	;NEVER PRINT A CR IN THIS  ROUTINE
	CALL	CHOUT
	INX	H
	JMP	PRN1
;
;	16 BIT UNSIGNED COMPARE
;	COMPARE DE AGAINST VALUE ADDRESSED BY HL
;	CLOBBERS A ONLY
;
DCMP:	MOV	A,E
	SUB	M
	INX	H
	MOV	A,D
	SBB	M
	DCX	H
	RNZ
	MOV	A,E
	SUB	M
	ORA	A	;CLEAR CARRY
	RET
;
;	INDIRECT LOAD HL THRU HL
;
LHLI:	PUSH	PSW
	MOV	A,M
	INX	H
	MOV	H,M
	MOV	L,A
	POP	PSW
	RET
;
;	GET FP CONSTANT FROM TEXT
;	PUSHES VALUE ON ARG STACK AND SETS ARGF FLAG
;	SETS CARRY IF NOT FOUND
;
CONST:	LHLD	TXA	;PREPARE CALL FPIN
	XCHG
	LXI	H,FPSINK
	CALL	FPIN
	RC
	DCX	D
	XCHG
	SHLD	TXA	;NOW POINTS TO TERMINATOR
	LXI	D,FPSINK
	CALL	PSHA1
	XRA	A
	INR	A	;SET A TO 1 AND CLEAR CARRY
	STA	ARGF
	RET
;
;	DIRECT STATEMENT CHECKING ROUTINE
;
DIRT:	LDA	DIRF
	ORA	A
	RZ
	LXI	H,DIRIN
	JMP	ERROR
;
;	FIND TEXT LINE WITH LINE NUMBER GIVEN IN DE
;	RETURNS TEXT ADDR COUNT BYTE IN HL
;
FINDLN:	LHLD	BOFA
	MVI	B,0
FIND1:	MOV	C,M
	MOV	A,C
	CPI	EOF
	JZ	LERR
	INX	H
	CALL	DCMP
	DCX	H
	RZ
	DAD	B
	JMP	FIND1
;
LERR:	LXI	H,LNUMB
	JMP	ERROR
;
;		FIX FLOATING TO POSITIVE INTEGER
;	RETURN INTEGER VALUE IN DE
;	FP VALUE FROM TOP OF ARG STACK, POP ARG STACK
;
PFIX:	LHLD	ASTKA
	MOV	B,H
	MOV	C,L
	PUSH	H
	CALL	AINT
	LXI	H,FPSINK
	CALL	POPAS
	POP	H
	MOV	C,M	;EXPONENT
	DCX	H
	MOV	A,M	;SIGN
	ORA	A
	JNZ	E5	;NEGATIVE NO GOOD
	LXI	D,-FPSIZ+1
	DAD	D
	LXI	D,0
	MOV	A,C
	ORA	A
	RZ
	DCR	C	;SET UP FOR LOOP CLOSE TEST
PFIX1:	INX	H
	MOV	A,M
	RRC
	RRC
	RRC
	RRC
	CALL	MUL10
	JC	E5
	DCR	C
	RP
	MOV	A,M
	CALL	MUL10
	JC	E5
	DCR	C
	JM	PFIX1
	RET
;
;	TAKE NEXT  DIGIT IN A (MASK TO 17Q), ACCUMULATE TO DE
;	PRESERVES ALL BUT A, DE
;
MUL10:	PUSH	H
	INX	SP
	INX	SP
	MOV	H,D	;GET ORIGINAL VALUE TO HL
	MOV	L,E
	DAD	H	;DOUBLE IT
	RC
	DAD	H	;AGAIN
	RC
	DAD	D	;PLUS ORIGINAL MAKES 5 TIMES ORIG
	RC
	DAD	H	;TIMES TWO MAKES TEN
	RC
	XCHG
	DCX	SP
	DCX	SP
	POP	H
	ANI	17Q
	ADD	E
	MOV	E,A
	MOV	A,D
	ACI	0	;PROPOGATE THE CARRY
	MOV	D,A
	RET
;
;		GET INTEGER FROM TEXT
;	SET CARRY IF NOT FOUND
;	RETURN INTEGER VALUE IN HL
;	RETURN TERMINATOR IN ACC
;
INTGER:	CALL	DIG
	RC
	LXI	D,0
	JMP	INTG2
;
INTG1:	CALL	DIG
	MOV	H,D
	MOV	L,E
	CMC
	RNC
INTG2:	SUI	'0'
	CALL	MUL10
	JNC	INTG1
	RET
;
;		CONVERT INTEGER TO STRING
;	DE CONTAINS ADDR OF STRING, RETURN UPDATED VALUE IN DE
;	HL CONTAINS VALUE TO CONVERT
;
CNS:	XRA	A	;SET FOR NO LEADING ZEROES
	LXI	B,-10000
	CALL	RSUB
	LXI	B,-1000
	CALL	RSUB
	LXI	B,-100
	CALL	RSUB
	LXI	B,-10
	CALL	RSUB
	LXI	B,-1
	CALL	RSUB
	RNZ
	MVI	A,'0'
	STAX	D
	INX	D
	RET
;
;	TAKE VALUE IN HL
;	SUB MINUS NUMBER IN BE THE MOST POSSIBLE TIMES
;	PUT VALUE ON STRING AT DE
;	IF A=0 THEN DONT PUT ZERO ON STRING
;	RETURN NON-ZERO IN A IF PUT ON STRING
;
RSUB:	PUSH	D
	MVI	D,0FFH
RSUB1:	PUSH	H
	INX	SP
	INX	SP
	INR	D
	DAD	B
	JC	RSUB1
	DCX	SP
	DCX	SP
	POP	H
	MOV	B,D
	POP	D
	ORA	B	;A GETS 0 IF A WAS 0 AND B IS 0
	RZ
	MVI	A,'0'
	ADD	B
	STAX	D
	INX	D
	RET
;
;	INPUT CHARACTER FROM TERMINAL
;
INCHAR:	PUSH	B
	PUSH	H
	MVI	C,1
	CALL	SYSTEM
	POP	H
	POP	B
	CPI	ESC
	JZ	CMND1
	CPI	LF	;IGNORE LINE FEEDS
	JZ	INCHAR
	CPI	NULL	;IGNORE NULLS
	JZ	INCHAR
	MOV	B,A
	RET
;
INL0:	CALL	CRLF
INLINE:	LXI	H,IBUF
	MVI	C,LINLEN
INL1:	CALL	INCHAR
	CPI	RUBOUT
	JZ	INL2	;RUBOUT LAST CHAR
	MOV	M,A
	MOV	A,B
	CPI	CNTRU	;LINE DELETION
	JZ	INL0
	MVI	B,LF	;IN CASE WE ARE DONE
	CPI	CR
	JZ	CHOUT	;DO LF THEN RETURN
	INX	H
	DCR	C
	JNZ	INL1
	LXI	H,LENGT
	JMP	ERROR
;
INL2:	MOV	A,C
	MVI	B,BELL
	CPI	LINLEN
	JZ	INL3	;IF DELETION BEFORE BEGINNING OF LINE
	DCX	H
	INR	C
	MOV	B,M
INL3:	PUSH	B
	PUSH	H
	CALL	CHOUT
	POP	H
	POP	B
	JMP	INL1
;
;		OUPUT ROUTINES
;
CHOUT:	PUSH	B
	PUSH	D
	PUSH	H
	MVI	C,2
	MOV	E,B
	LDA	PFLAG	;SELECT LINE PRINTER OR CONSOLE
	ORA	A
	JZ	CHO1	;IF CONSOLE
	MVI	C,5
CHO1:	CALL	SYSTEM	;OUTPUT CHARACTER THRU CP/M
	POP	H
	POP	D
	POP	B
	MOV	A,B
CHCHK:	CPI	CR
	JNZ	CHLF	;NOT CR IS IT LF?
	XRA	A
	JMP	PSTOR	;RETURN PHEAD TO ZERO
;
CHLF:	CPI	LF
	JZ	NULCH	;IF LINE FEED PROCESS THE NULLS
	CPI	40Q	;NO PHEAD INC IF CONTROL CHAR
	RC
	LDA	PHEAD
	INR	A
PSTOR:	STA	PHEAD
	RET
;
NULCH:	LDA	NULLCT	;OUTPUT NULL CHARS
	ORA	A
	RZ
	PUSH	B
	MOV	C,A
	MVI	B,NULL
CH2:	CALL	CHOUT	;OUTPUT COUNT 'C' NULLS
	DCR	C
	JNZ	CH2
	POP	B
	RET
;
CRLF2:	CALL	CRLF
CRLF:	MVI	B,CR
	CALL	CHOUT
	MVI	B,LF
	JMP	CHOUT
;
;	CHECK IF PANIC CHARACTER HAS BEEN HIT
;
PCHECK:	MVI	C,11
	CALL	SYSTEM	;CHECK FOR A CHARACTER TYPED
	ORA	A
	RZ		;IF NO CHARACTER TYPED
	MVI	C,1	;GET THE CHARACTER
	CALL	SYSTEM
	CPI	ESC
	JZ	BREAK	;IF OPERATOR INTERRUPT REQUEST
	CPI	CR
	RNZ		;IF NOT PROGRAM STATUS REQUEST
	LDA	PFLAG	;SAVE I/O FLAG AND SELECT CONSOLE
	PUSH	PSW
	XRA	A
	STA	PFLAG
	LXI	H,RNING	;OUTPUT 'RUNNING' MESSAGE
	CALL	PRNT
	CALL	CRLF2
	POP	PSW	;RESTORE I/O FLAG
	STA	PFLAG
	RET
;
BREAK:	XRA	A	;TURN OFF PFLAG INCASE LLIST OR LPRINT IN PROGRESS
	STA	PFLAG
	JMP	STOP1
;
;	OUTPUT FP NUMBER ADDRESSED BY HL
;
FPOUT:	LXI	B,-DIGIT-1
	DAD	B
	MOV	B,H
	MOV	C,L
	LXI	H,ABUF	;OUTPUT BUFFER
	LDA	INFES	;OUTPUT FORMAT
	STA	FES	;STORE IT
	MVI	E,DIGIT
	MVI	M,0	;CLEAR ROUND OFF OVERFLOW BUFFER
	INX	H	;ABUF+1
;
NXT:	LDAX	B	;GET DIGIT AND UNPACK
	MOV	D,A
	RAR
	RAR
	RAR
	RAR
	ANI	17Q	;REMOVE BOTTOM DIGIT
	MOV	M,A	;STORE TOP DIGIT IN OUTPUT BUFFER (ABUF)
	INX	H
	MOV	A,D	;NOW GET BOTTOM DIGIT
	ANI	17Q
	MOV	M,A	;STORE IT
	INX	H
	INX	B
	DCR	E
	JNZ	NXT
	LDAX	B
	STA	FSIGN	;STORE SIGN OF NUMBER
	XRA	A
	MOV	M,A	;CLEAR ROUND-OFF BUFFER (ABUF+13) 12 DIG NO RND
	LXI	H,XSIGN	;EXPONENT SIGN STORE
	MOV	M,A	;CLEAR XSIGN
;
FIX:	INX	B	;GET EXPONENT
	LDAX	B
	ORA	A	;EXPONENT ZERO?
	JZ	ZRO
	SUI	128	;REMOVE NORMALIZING BIAS
	JNZ	FIX2
	INR	M	;INCREMENT XSIGN TO NEGATIVE FLAG (1) LATER ZERO
FIX2:	JP	CHK13
	CMA		;ITS A NEGATIVE EXPONENT
	INR	M	; INCREMENT XSIGN TO NEGATIVE (1)
ZRO:	INR	A
CHK13:	LXI	H,EXPO	;EXPONENT TEMP STORE
	MOV	M,A
	MOV	E,A
	CPI	DIGIT*2
	LXI	H,FES	;FORMAT TEMP BYTE
	JC	CHKXO
CHK40:	MVI	A,1	;FORCE EXPONENTIAL PRINTOUT
	ORA	M	;SET FORMAT FOR XOUT
	MOV	M,A
;
CHKXO:	MOV	A,M	;CHECK IF EXPONENTIAL PRINTOUT
	RAR
	JNC	CHKX3
	ANI	17Q
	CPI	DIGIT*2
	JC	CHKX2
	MVI	A,DIGIT*2-1 ;MAX DIGITS
CHKX2:	MOV	D,A
	INR	A
	JMP	ROUND
;
CHKX3:	ANI	17Q	;ADD EXPONENT AND DECIMAL PLACES
	MOV	D,A
	ADD	E
	CPI	DIGIT*2+1
	MOV	B,A
	JC	CHKXN
	MOV	A,M
	ANI	100Q
	JNZ	CHK40
;
CHKXN:	LDA	XSIGN	;CHECK EXPONENT SIGN
	ORA	A
	JNZ	XNEG	;ITS NEGATIVE
	MOV	A,B
	JMP	ROUND
;
XNEG:	MOV	A,D	;SUBTRACT EXPONENT AND DECIMAL PLACE COUNT
	SUB	E
	JNC	XN2
XN1:	LDA	INFES
	ORA	A
	JP	ZERO
	ANI	16Q
	JZ	ZERO
	RRC
	MOV	E,A
	DCR	E
	MVI	C,1
	LXI	H,ABUF-1
	JMP	NRND
;
XN2:	JZ	XN1
	JMP	ROUND
;
;
CLEAN:	MVI	B,37Q	;CLEAR FLAGS
	ANA	B
	CPI	DIGIT*2+1
	RC
	MVI	A,DIGIT*2+1 ;MAX DIGITS OUT
	RET
;
;	THIS ROUTINE IS USED TO ROUND DATA TO THE
;	SPECIFIED DECIMAL PLACE
;
ROUND:	CALL	CLEAN
	MOV	C,A
	MVI	B,0
	LXI	H,ABUF+1
	DAD	B	;GET ROUND-OFF ADDRESS
	SHLD	ADDT
	MOV	A,M
	CPI	5	;ROUND IF >=5
	JC	TRL2-1
;
LESS1:	DCX	H
	INR	M	;ROUND UP
	MOV	A,M
	ORA	A
	JZ	TRL2
	CPI	10	;CHECK IF ROUNDED NUMBER >9
	JNZ	TRAIL
	MVI	M,0
	JMP	LESS1
;
;	THIS ROUTINE IS USED TO ELIMINATE TRAILING ZERO'S
;
TRAIL:	LHLD	ADDT
	DCX	H
TRL2:	LDA	FES	;CHECK IF TRAILING ZERO'S ARE WANTED
	RAL
	JC	FPRNT	;YES- GO PRINT DATA
TRL3:	MOV	A,M
	ORA	A	;IS IT ZERO?
	JNZ	FPRNT	;NO- GO PRINT
	DCX	H
	DCR	C	;YES- FIX OUTPUT DIGIT COUNT
	JM	ZERO
	JMP	TRL3
;
;	HERE STARTS THE PRINT FORMAT ROUTINES
;
FPRNT:	LXI	H,ABUF
	MOV	A,M	;CHECK IF ROUNDED UP TO 1
	ORA	A
	JZ	NRND	;JUMP IF NOT
	MVI	B,1
	LDA	XSIGN	;IS EXPONENT NEGATIVE?
	ORA	A
	JZ	POSR
	MVI	B,0FFH
;
POSR:	LDA	EXPO	;GET EXONENT
	ORA	A
	JNZ	PO2	;IS IT ZERO?	(E+0)
	STA	XSIGN
	MVI	B,1
PO2:	ADD	B	;FIX EXPONENT COUNT
	STA	EXPO
	INR	E
	INR	C
	DCX	H
;
NRND:	INX	H
	MOV	A,C
	CPI	DIGIT*2+1	;CHECK FOR MAX DIGITS OUT
	JNZ	NRND1
	DCR	C
NRND1:	LDA	FSIGN	;CHECK IF NEGATIVE NUMBER
	RAR
	JNC	PRIN2	;GO OUTPUT RADIX AND NUMBER
	CALL	NEG	;OUTPUT (-)
	JMP	PRI21
;
;
PRIN2:	CALL	SPACE	;OUTPUT A SPACE
PRI21:	LDA	FES	;GET OUTPUT FORMAT
	RAR		;CHECK IF EXPONENTIAL OUTPUT FORMAT
	JC	XPRIN
	LDA	XSIGN	;GET EXPONENT SIGN
	ORA	A	;CHECK IF NEGATIVE EXPONENT
	JZ	POSIT
	MOV	A,C
	ORA	A
	JNZ	PRIN4	;OUTPUT RADIX AND NUMBER
	CALL	ZERO	;NO DIGITS AFTER RADIX, OUTPUT ZERO AND DONE
	RET
;
PRIN4:	CALL	RADIX	;PRINT DECIMAL POINT
	XRA	A
	ORA	E
	JZ	PRIN5	;JUMP IF NO ZEROS TO PRINT
	CALL	ZERO	;FORCE PRINT A ZERO
	DCR	E
	JNZ	PRIN4+3
;
PRIN5:	CALL	NOUT	;PRINT ASCII DIGIT
	JNZ	PRIN5
	RET
;
POSIT:	CALL	NOUT
	DCR	E	;BUMP EXPONENT COUNT
	JNZ	POSIT
	MOV	A,C	;CHECK IF MORE DIGITS TO OUTPUT
	ORA	A
	RZ		;NO, DONE
	RM
	JMP	PRIN4	;NOW PRINT DECIMAL POINT
;
;	GET HERE FOR EXPONENTIAL OUTPUT FORMAT
;
XPRIN:	CALL	NOUT
	JZ	NDEC	;INTEGER?
	CALL	RADIX	;NO.....PRINT DECIMAL POINT
XPRI2:	CALL	NOUT
	JNZ	XPRI2
;
NDEC:	MVI	B,'E'	;OUTPUT 'E'
	CALL	CHOUT
	LDA	XSIGN
	ORA	A
	JZ	XPRI3
	CALL	NEG	;PRINT EXPONENT SIGN (-)
	LDA	EXPO
	INR	A
	JMP	XOUT2
;
XPRI3:	MVI	B,'+'	;EXPONENT (+)
	CALL	CHOUT
;
;	THIS ROUTINE IS USED TO CONVERT THE EXPONENT
;	FROM BINARY TO ASCII AND PRINT THE RESULT
;
XOUT:	LDA	EXPO
	DCR	A
XOUT2:	MVI	C,100
	MVI	D,0
	CALL	CONV
	CPI	'0'	;SKIP LEADING ZEROES
	JZ	XO21
	INR	D
	CALL	CHOUT
XO21:	MOV	A,E
	MVI	C,10
	CALL	CONV
	CPI	'0'
	JNZ	XO3
	DCR	D
	JNZ	XO4
XO3:	CALL	CHOUT
XO4:	MOV	A,E
	ADI	'0'	;ADD ASCII BIAS
	MOV	B,A
	CALL	CHOUT
	RET
;
CONV:	MVI	B,'0'-1
	INR	B
	SUB	C
	JNC	CONV+2
	ADD	C
	MOV	E,A
	MOV	A,B
	RET
;
;	THIS ROUTINE ADDS ASCII BIAS TO A BCD DIGIT
;	AND CALLS THE OUTPUT ROUTINE
;
NOUT:	MOV	A,M
	ADI	'0'
	MOV	B,A
	CALL	CHOUT
	INX	H
	DCR	C	;DECREMENT TOTAL DIGITS OUT COUNT
	RET
;
;	COMMON SYMBOL LOADING ROUTINES
;
NEG:	MVI	B,'-'
	JMP	CHOUT
ZERO:	MVI	B,'0'
	JMP	CHOUT
SPACE:	MVI	B,' '
	JMP	CHOUT
RADIX:	MVI	B,'.'
	JMP	CHOUT
;
;	CONVERTS FP STRING AT DE, UPDATE DE PAST TERMINATOR
;	PUTS TERMINATOR IN B, PUTS FP NUMBER AT ADDR IN HL
;	SETS CARRY IF NOT FOUND
;
FPIN:	PUSH	H
	PUSH	D
	XCHG
	DCX	H
	SHLD	ADDS
	LXI	H,OPST	;CLEAR TEMP STORAGE AREAS AND BC BUFFER
	MVI	C,DIGIT+6
	CALL	CLEAR
;
SCANC:	LXI	D,0
	LXI	H,BC	;BC=PACK BUFFER
SCAN0:	SHLD	BCADD	;PACK BUFFER POINTER
SCANP:	LXI	H,SCANP
	PUSH	H	;USED FOR RETURN FROM OTHER ROUTINES
	XRA	A
	STA	XSIGN	;CLEAR EXPONENT SIGN BYTE
;
SCANG:	CALL	IBSCN
	JC	SCANX	;FOUND A NUMBER, GO PACK IT
	CPI	'.'	;RADIX?
	JZ	SCAN5	;PROCESS RADIX POINTERS
	CPI	'E'	;EXPONENT?
	JZ	EXCON	;FOUND 'E', GO PROCESS EXPONENT NUMBER
;
;	NOT A CHARACTER LEGAL IN NUMBER
;
	MOV	B,A	;MOVE TERMINATOR TO B
	LDA	OPST	;CHECK IF ANY DIGITS YET
	ANI	20Q
	JNZ	ENTR2
;
;	GET HERE IF LEGAL FP NUMBER NOT FOUND
;
FPIN1:	POP	H	;SCANP LINK
	POP	D	;TEXT POINTER
	POP	H	;FP # ADDR
	STC
	RET
;
;	FOUND DECIMAL POINT
;
SCAN5:	XRA	A	;FOUND RADIX PROCESS RADIX POINTERS FOR EXP
	ORA	D	;ANY DIGITS YET?
	JNZ	SCAN6
	ADI	300Q	;SET ECNT - STOP COUNTING DIGITS
	ORA	E	;NO INT DIGITS, BIT 7 IS COUNT/DONT COUNT FLAG
	MOV	E,A	;BIT 6 IS NEGATIVE EXPONENT FLAG
	RET
;
SCAN6:	MVI	A,200Q	;SET ECNT TO COUNT DIGITS
	ORA	E
	MOV	E,A
	RET
;
SCANX:	ANI	17Q	;FOUND NUMBER-REMOVE ASCII BIAS
	MOV	B,A
	LXI	H,OPST	;SET FIRST CHARACTER FLAG
	MVI	A,60Q
	ORA	M
	MOV	M,A
	XRA	A
	ORA	B	;IS CHAR ZERO?
	JNZ	PACK
	ORA	D	;LEADING ZERO I. E. ANY INT DIGITS?
	JNZ	PACK
	ORA	E
	MOV	E,A
	RZ		;IF COUNTING YET,
	INR	E	;ECNT+1-COUNT ZEROS FOR EXPONENT COUNT
	RET
;
;	THIS SUBROUTINE BCD PACKS DIGITS INTO REG BC
;
PACK:	MOV	A,E
	RAL
	JC	PACK1
	INR	E
PACK1:	MOV	A,E
	STA	ECNT	;DIGIT COUNT FOR EXPONENT COUNT
	INR	D	;TOTAL DIGIT COUNT (D ALSO HAS TOP/BOTM FLAG BIT 7
	MOV	A,D
	ANI	177Q	;REMOVE TOP/BOTTOM FLAG
	CPI	DIGIT*2+1 ;LIMIT INPUT DIGITS
	RNC
	XRA	A
	ORA	D
	JM	BOTM
;
TOP:	ORI	200Q	;SET MSB FOR TOP FLAG
	MOV	D,A
	MOV	A,B
	LHLD	BCADD	;GET BC ADDRESS
	RLC
	RLC
	RLC
	RLC
	MOV	M,A	;SAVE CHR IN BC
	RET
;
BOTM:	ANI	177Q	;STRIP MSB (BOTTOM FLAG)
	MOV	D,A
	MOV	A,B
	LHLD	BCADD
	ORA	M	;OR IN TOP NUMBER
	MOV	M,A	;PUT NUMBER BACK IN BC
	INX	H
	POP	B
	JMP	SCAN0
;
IBSCN:	LHLD	ADDS	;INPUT BUFFER POINTER
	INX	H	;GET NEXT BYTE
	MOV	A,M
	CPI	' '
	JZ	IBSCN+3
	SHLD	ADDS	;NOTE:  THIS ROUTINE FALLS THROUGH TO BELOW
;
;	THIS ROUTINE CHECKS FOR ASCII NUMBERS (0-9)
;
NMCHK:	CPI	'9'+1
	RNC
	CPI	'0'
	CMC
	RET
;
;	THIS ROUTINE IS USED TO ADJUST A NUMBER IN BC BUFFER
;	AND RETURNS VALUE
;
ENTR2:	LXI	D,0
ENT1:	PUSH	B	;TERMINATOR
	CALL	FIXE	;NORMALIZE FLOATING POINT NUMBER
	POP	B	;TERMINATOR
	POP	D	;SCANP LINK
	POP	D	;OLD TEXT ADDR
	POP	D	;RETURN ADDR
	MVI	C,DIGIT+2
	LXI	H,BC+DIGIT+1
	CALL	VCOPY
	LHLD	ADDS
	XCHG
	INX	D
	ORA	A
	RET
;
;	THIS ROUTINE IS USED TO CLEAR STORAGE AREAS
;	THE STARTING ADDRESS IS IN HL AND THE COUNT
;	IS IN REG C
;
CLEAR:	XRA	A
	MOV	M,A
	INX	H
	DCR	C
	JNZ	CLEAR+1
	RET
;
;	THIS ROUTINE CONVERTS THE ASCII EXPONENT OF
;	NUMBER IN THE INPUT BUFFER TO BINARY, AND
;	NORMALIZES EXPONENT ACCORDING TO THE INPUT
;	FORMAT OF THE NUMBER
;
EXCON:	CALL	IBSCN	;GET CHARACTER
	JC	EXC3
	CPI	PLSRW	;CHECK FOR UNARY SIGNS
	JZ	EXC4
	CPI	'+'
	JZ	EXC4
	CPI	'-'
	JZ	EXC2
	CPI	MINRW
	JNZ	FPERR	;NO SIGN OR NUMBER?
EXC2:	MVI	A,1
	STA	XSIGN	;SAVE SIGN
EXC4:	CALL	IBSCN
	JNC	FPERR	;NO NUMBER?
EXC3:	CALL	ASCDC	;CONVERT ASCII TO BINARY
	JMP	ENT1	;NORMALIZE NUMBER AND RETURN
;
;	THIS ROUTINE CONVERTS ASCII TO BINARY
;	THREE CONSECUTIVE NUMBERS <128 MAY BE CONVERTED
;
ASCDC:	XCHG
	LXI	H,0
ASC1:	LDAX	D	;GET CHR FROM INPUT BUFFER, NO SPACES ALLOWED
	CALL	NMCHK	;CHECK IF NUMBER
	JNC	ASC2
	SUI	'0'	;REMOVE ASCII BIAS
	MOV	B,H
	MOV	C,L
	DAD	H
	DAD	H
	DAD	B
	DAD	H
	MOV	C,A
	MVI	B,0
	DAD	B
	INX	D
	JMP	ASC1
;
ASC2:	XCHG
	MOV	B,A	;SAVE TERMINATOR
	SHLD	ADDS	;SAVE IBUF ADDR
	MOV	A,D
	ORA	A
	JNZ	FPERR	;TOO BIG >255
	MOV	A,E
	RAL
	JC	FPERR	;TOO BIG >127
	RAR
	RET
;
FPERR:	POP	B	;ASCDC RET LINK
	JMP	FPIN1
;
;	THIS ROUTINE NORMALIZES THE INPUT NUMBER
;
FIXE:	XCHG
	LDA	BC
	ORA	A	;IS IT ZERO
	JZ	ZZ2
	CALL	CHKPN	;SET EXPONENT POSITIVE/NEGATIVE
	ADI	200Q	;ADD EXPONENT BIAS
ZZ2:	STA	BC+DIGIT+1 ;STORE NORMALIZED EXPONENT IN BC
	RET
;
CHKPN:	LDA	ECNT	;GET EXPONENT COUNT-SET IN 'SCAN' ROUTINE
	MOV	E,A
	ANI	77Q	;STRIP BITS 7 AND 8
	MOV	B,A
	LDA	XSIGN
	ORA	A
	JZ	LPOS	;EXPONENT IS POSITIVE
	INR	H	;SET SIGN IN H **THIS SHOULD BE INR H NOT INX H
	MVI	A,100Q	;L IS NEGATIVE
	ANA	E	;CHECK IF E IS NEGATIVE
	JZ	EPOS
	MOV	A,L	;BOTH E AND L NEGTIVE
	MOV	L,B
	CALL	BPOS+1
	CMA
	INR	A
	RET		;BACK TO FIXE
;
EPOS:	MOV	A,L	;E AND L NEGATIVE
	CMA
	INR	A
	ADD	B
	RET		;TO FIXE
;
LPOS:	MVI	A,100Q	;EXPONENT POSITIVE
	ANA	E
	JZ	BPOS	;IF E POSITIVE
	MOV	A,B
	MOV	B,L
	JMP	EPOS+1
;
BPOS:	MOV	A,B	;E AND L POSITIVE
	ADD	L
	RP
;
	POP	H
	JMP	FPERR
	DB	1*16
	DW	0
	DB	1
FPNONE:	DB	129
;
;	THIS PROGRAM IS A FOUR FUNCTION FLOATING POINT BCD
;	MATH PACKAGE
;	EACH FUNCTION MAY BE EXPRESSED AS:  BC=DE # HL
;	<BC> = ADDR OF RESULT
;	<DE> = ADDR OF 1ST ARGUMENT
;	<HL> = ADDR OF 2ND ARGUMENT
;	# IS ONE OF THE FUNCTIONS:  +, -, *, /
;	ALL ADDRESSES ON ENTRY, POINT TO THE EXPONENT PART OF
;	THE FLOATING POINT NUMBER
;	EACH FLOATING POINT NUMBER CONSISTS OF (2*DIGIT) PACKED
;	DECIMAL DIGITS, A SIGN AND A BIASED BINARY EXPONENT.  THE
;	EXPONENT RANGE IS 10**-127 TO 10**127.
;	THE NUMBER ZERO IS REPRESENTED BY THE EXPONENT 0.
;	THE NUMBERS ARE STORED IN MEMORY AS (DIGIT) BYTES OF
;	DECIMAL DIGITS.
;	STARTING AT THE LOW ORDER ADDRESS
;	ALL NUMBERS ARE ASSUMED TO BE NORMALIZED.  THAT IS EACH
;	NUMBER CAN BE REPRESENTED AS F**E.
;	WHERE .1<=F<=1.0 AND F IS THE EXPONENT.
;
;	FLOATING POINT ADDITION
;
FADD:	PUSH	B
	CALL	EXPCK	;FETCH ARGUMENTS
	MVI	C,0
ADSUM:	DCX	D
	XCHG
	LDA	SIGN
	XRA	M	;FORM SIGN OF RESULT
	MOV	B,A
	XCHG
	LDAX	D
	DCX	D
	XRA	C
	STA	SIGN
	LXI	H,RCTRL	;ROUNDING CONTROL FLAG
	MOV	A,M
	ORA	A
	INX	H
	MOV	A,M	;GET ROUNDING DIGIT
	JZ	ADS8
	RLC
	RLC
	RLC
	RLC
ADS8:	ADI	0B0H	;FORCE CARRY IF DIGIT > 5
	MOV	A,B
	RAR
	JC	ADS1	;HAVE SUBTRACTION
	RAL		;RESTORE CARRY
	CALL	ADDF	;PERFORM ADDITION
	JNC	ADS2
	MVI	B,4
	CALL	RIGHT
	LXI	H,EXP
	INR	M	;INCREMENT EXPONENT
	JZ	OVER
ADS2:	POP	B	;GET RESULTS ADDRESS
	CALL	STORE	;SAVE RESULTS
	RET
;
ZEREX:	POP	H
	JMP	ADS2
;
ADDF:	LXI	H,BUF+DIGIT-1
	MVI	B,DIGIT
ADD1:	LDAX	D
	ADC	M
	DAA
	MOV	M,A
	DCX	H
	DCX	D
	DCR	B
	JNZ	ADD1
	RNC
	INR	M
	RET
;
;	FLOATING POINT SUBTRACTION
;
FSUB:	PUSH	B
	CALL	EXPCK	;GET ARGUMENTS
	LDA	SIGN
	XRI	1	;COMPLEMENT SIGN
	STA	SIGN
	JMP	ADSUM
;
ADS1:	RAL		;RESTORE CARRY
	CMC		;COMPLEMENT FOR ROUNDING
	CALL	SUBF	;SUBTRACT ARGUMENTS
	LXI	H,SIGN
	JC	ADS4
	MOV	A,M	;GET SIGN
	XRI	1	;COMPLEMENT
	MOV	M,A
ADS7:	DCX	H
	MVI	B,DIGIT
ADS3:	MVI	A,9AH
	SBB	M	;COMPLEMENT RESULT
	ADI	0
	DAA
	MOV	M,A
	DCX	H
	DCR	B
	CMC
	JNZ	ADS3
ADS4:	LXI	H,BUF
	LXI	B,DIGIT
ADS5:	MOV	A,M
	ORA	A
	JNZ	ADS6
	INX	H
	INR	B
	INR	B
	DCR	C
	JNZ	ADS5
	XRA	A
	STA	EXP
	JMP	ADS2
;
ADS6:	CPI	10H
	JNC	ADS9
	INR	B
ADS9:	LXI	H,EXP
	MOV	A,M
	SUB	B
	JZ	UNDER
	JC	UNDER
	MOV	M,A
	MOV	A,B
	RLC
	RLC
	MOV	B,A
	CALL	LEFT
	JMP	ADS2
;
SUBF:	LXI	H,BUF+DIGIT-1
	MVI	B,DIGIT
SUB1:	MVI	A,99H
	ACI	0
	SUB	M
	XCHG
	ADD	M
	DAA
	XCHG
	MOV	M,A
	DCX	H
	DCX	D
	DCR	B
	JNZ	SUB1
	RET
;
;	FLOATING POINT MULTIPLY
;
FMUL:	PUSH	B
	MOV	A,M
	ORA	A	;ARGUMENT=0?
	JZ	FMUL1+2
	LDAX	D
	ORA	A	;ARGUMENT=0?
	JZ	FMUL1+2
	ADD	M	;FORM RESULT EXPONENT
	JC	FMOVR
	JP	UNDER
	JMP	FMUL1
;
FMOVR:	JM	OVER
FMUL1:	SUI	128	;REMOVE EXCESS BIAS
	STA	EXP	;SAVE EXPONENT
	DCX	D
	DCX	H
	LDAX	D
	XRA	M	;FORM RESULT SIGN
	DCX	H
	DCX	D
	PUSH	H
	LXI	H,SIGN	;GET SIGN ADDRESS
	MOV	M,A
	DCX	H
	XRA	A
	MVI	B,DIGIT+2
FMUL2:	MOV	M,A	;ZERO WORKING BUFFER
	DCX	H
	DCR	B
	JNZ	FMUL2
	LDA	EXP
	ORA	A
	JZ	ZEREX
	MVI	C,DIGIT
	LXI	H,HOLD1+DIGIT
;
;	GET MULTIPLIER INTO HOLDING REGISTER
;
FMUL3:	LDAX	D
	MOV	M,A	;PUT IN REGISTER
	DCX	H
	DCX	D
	DCR	C
	JNZ	FMUL3
	MOV	M,C
	DCX	H
	MVI	B,250	;SET LOOP COUNT
FMUL4:	LXI	D,DIGIT+1
	MOV	C,E
	DAD	D
	XCHG
	DAD	D	;HL=NEXT HOLDING REGISTER
	INR	B
	JP	FMUL8	;FINISHED
FMUL5:	LDAX	D	;GET DIGITS
	ADC	A	;TIMES 2
	DAA
	MOV	M,A	;PUT IN HOLDING REGISTER
	DCX	D
	DCX	H
	DCR	C
	JNZ	FMUL5
	INR	B	;INCREMENT LOOP COUNT
	JNZ	FMUL4
;
;	FORM 10X BY ADDING 8X AND 2X
;	FIRST GET 8X
;
	INX	H
	LXI	D,HOLD5	;NEXT HOLDING REGISTER
	MVI	C,DIGIT+1
	MOV	B,C
FMUL6:	MOV	A,M
	STAX	D
	INX	H
	INX	D
	DCR	C
	JNZ	FMUL6
	LXI	H,HOLD2+DIGIT ;GET 2X
	DCX	D
FMUL7:	LDAX	D
	ADC	M	;FORM 10X
	DAA
	STAX	D
	DCX	D
	DCX	H
	DCR	B
	JNZ	FMUL7
	MVI	B,249
	XCHG
	JMP	FMUL4
;
FMUL8:	XCHG
	INX	H
	MVI	M,DIGIT+1 ;SET NEXT LOOP COUNT
;
;	PERFORM ACCUMULATION OF PRODUCT
;
FMUL9:	POP	B	;GET MULTIPLIER
	LXI	H,HOLD8+DIGIT+1
	DCR	M	;DECREMENT LOOP COUNT
	JZ	FMU14	;FINISHED
	LDAX	B
	DCX	B
	PUSH	B
	DCX	H
	XCHG
FMU10:	ADD	A	;CHECK FOR BIT IN CARRY
	JC	FMU11	;FOUND A BIT
	JZ	FMU12	;ZERO- FINISHED THIS DIGIT
	LXI	H,-DIGIT-1
	DAD	D	;POINT TO NEXT HOLDING REGISTER
	XCHG
	JMP	FMU10
;
FMU11:	MOV	C,A
	ORA	A	;CLEAR CARRY
	CALL	ADDF	;ACCUMULATE PRODUCT
	LDAX	D
	ADD	M
	DAA
	MOV	M,A
	MOV	A,C
	DCX	D
	JMP	FMU10
;
;	ROTATE RIGHT 1 BYTE
;
FMU12:	MVI	B,8
	CALL	RIGHT
	JMP	FMUL9
;
FMU14:	LDA	BUF
	ANI	0F0H	;CHECK IF NORMALIZED
	JZ	FMU17
	MOV	A,D
	ANI	0F0H
	LXI	H,SIGN-1
	JMP	FMU18
;
FMU17:	MVI	B,4
	LXI	H,EXP
	DCR	M
	JZ	UNDER
	CALL	LEFT	;NORMALIZE
	MOV	A,D	;GET DIGIT SHIFTED OFF
;
;	PERFORM ROUNDING
;
	RRC
	RRC
	RRC
	RRC
FMU18:	CPI	50H
	JC	FMU16
	INR	A
	ANI	0FH
	MVI	C,DIGIT
FMU15:	ADC	M
	DAA
	MOV	M,A
	MVI	A,0
	DCX	H
	DCR	C
	JNZ	FMU15
;
;	CHECK FOR ROUNDING OVERFLOW
;
	JNC	ADS2	;NO OVERFLOW
	INX	H
	MVI	M,10H
	LXI	H,EXP
	INR	M
	JNZ	ADS2
	JMP	OVER
;
;	ROUNDING NOT NEEDED
;
FMU16:	ANI	0FH
	ADD	M
	MOV	M,A
	JMP	ADS2
;
;	FLOATING POINT DIVISION
;
FDIV:	PUSH	B
	MOV	A,M	;FETCH DIVISOR EXP
	ORA	A	;DIVIDE BY 0?
	JZ	 DIVZ
	LDAX	D
	ORA	A	;DIVIDEND=0?
	JZ	INSP
	SUB	M
	JC	DIVUN
	JM	OVER
	JMP	FDI1
;
DIVUN:	JP	UNDER
FDI1:	ADI	129	;FORM QUOTIENT EXP
	STA	EXPD
	XCHG
	PUSH	D
	CALL	LOAD	;FETCH DIVIDEND
	POP	D
	XCHG
	LDA	SIGN
	DCX	H
	XRA	M	;FORM QUOTIENT SIGN
	STA	SIGND
	XCHG
	DCX	D
	LXI	B,HOLD1
DIV0:	MVI	L,DIGIT+DIGIT
DIV1:	PUSH	B
	PUSH	H
	MVI	C,0	;QUOTIENT DIGIT=0
DIV3:	STC		;SET CARRY
	LXI	H,BUF+DIGIT-1
	MVI	B,DIGIT
DIV4:	MVI	A,99H
	ACI	0
	XCHG
	SUB	M
	XCHG
	ADD	M
	DAA
	MOV	M,A
	DCX	H
	DCX	D
	DCR	B
	JNZ	DIV4
	MOV	A,M
	CMC
	SBI	0
	MOV	M,A
	RAR
	LXI	H,DIGIT
	DAD	D
	XCHG
	INR	C	;INCREMENT QUOTIENT
	RAL
	JNC	DIV3
	ORA	A	;CLEAR CARRY
	CALL	ADDF	;RESTORE DIVIDEND
	LXI	H,DIGIT
	DAD	D
	XCHG
	PUSH	B
	MVI	B,4
	CALL	LEFT	;SHIFT DIVIDEND
	POP	B
	DCR	C
	POP	H
	MOV	H,C
	POP	B
	MOV	A,L
	JNZ	DIV5
	CPI	DIGIT+DIGIT
	JNZ	DIV5
	LXI	H,EXPD
	DCR	M
	CZ	UNDER
	JMP	DIV0
;
DIV5:	RAR
	MOV	A,H
	JNC	DIV6
	LDAX	B
	RLC
	RLC
	RLC
	RLC
	ADD	H
	STAX	B	;STORE QUOTIENT
	INX	B
	JMP	DIV7
;
DIV6:	STAX	B	;STORE QUOTIENT
DIV7:	DCR	L	;DECREMENT DIGIT COUNT
	JNZ	DIV1
	LXI	H,EXPD
	POP	B
	CALL	STORO
	RET
;
;	FETCH AND ALIGN ARGUMENTS FOR
;	ADDITION AND SUBTRACTION
;
EXPCK:	LDAX	D
	SUB	M	;DIFFERENCE OF EXPS
	MVI	C,0
	JNC	EXPC1
	INR	C
	XCHG
	CMA
	INR	A
EXPC1:	MOV	B,A
	LDAX	D
	STA	EXP
	MOV	A,B
	CPI	DIGIT+DIGIT
	JC	EXPC2
	MVI	A,DIGIT+DIGIT
EXPC2:	RLC
	RLC
	MOV	B,A
	ANI	4
	STA	RCTRL	;SET ROUNDING CONTROL
	PUSH	B
	PUSH	D
	CALL	LOAD	;LOAD SMALLER VALUE
	MVI	A,8*DIGIT+16
	SUB	B
	CPI	8*DIGIT+16
	JZ	EXPC3
	ANI	0F8H
	RAR
	RAR
	RAR
	ADD	E
	MOV	E,A
	MOV	A,D
	ACI	0
	MOV	D,A
	LDAX	D	;GET ROUNDING DIGIT
	STA	RDIGI	;SAVE
EXPC3:	CALL	RIGHT	;ALIGN VALUES
	POP	D
	POP	B
	RET
;
;	LOAD ARGUMENT INTO BUFFER
;
LOAD:	LXI	D,SIGN
	MVI	C,DIGIT+1
	DCX	H
LOAD1:	MOV	A,M
	STAX	D
	DCX	H
	DCX	D
	DCR	C
	JNZ	LOAD1
	XRA	A
	STAX	D
	DCX	D
	STAX	D
	STA	RDIGI	;ZERO ROUNDING DIGIT
	RET
;
;	STORE RESULTS IN MEMORY
;
STORE:	LXI	H,EXP
STORO:	MVI	E,DIGIT+2
STOR1:	MOV	A,M
	STAX	B
	DCX	B
	DCX	H
	DCR	E
	JNZ	STOR1
	RET
;
;	SHIFT RIGHT NUMBER OF DIGITS
;	IN B/4
;
RIGHT:	MVI	C,DIGIT+1
RIGH1:	LXI	H,BUF-1
	MOV	A,B
	SUI	8	;CHECK IF BYTE CAN BE SHIFTED
	JNC	RIGH3
	DCR	B
	RM
	ORA	A
RIGH2:	MOV	A,M
	RAR
	MOV	M,A
	INX	H
	DCR	C
	JNZ	RIGH2
	JMP	RIGHT
;
;	SHIFT RIGHT ONE BYTE
;
RIGH3:	MOV	B,A
	XRA	A
RIGH4:	MOV	D,M
	MOV	M,A
	MOV	A,D
	INX	H
	DCR	C
	JNZ	RIGH4
	JMP	RIGHT
;
;	SHIFT LEFT NUMBER OF DIGITS
;	IN B/4
;
LEFT:	MVI	C,DIGIT+1
	LXI	H,SIGN-1
LEF1:	MOV	A,B
	SUI	8
	JNC	LEF3
	DCR	B
	RM
	ORA	A
LEF2:	MOV	A,M
	RAL
	MOV	M,A
	DCX	H
	DCR	C
	JNZ	LEF2
	JMP	LEFT
;
;	SHIFT LEFT ONE BYTE
;
LEF3:	MOV	B,A
	XRA	A
LEF4:	MOV	D,M
	MOV	M,A
	MOV	A,D
	DCX	H
	DCR	C
	JNZ	LEF4
	JMP	LEFT
;
;	SET FLAGS FOR OVERFLOW, UNDERFLOW,
;	AND DIVIDE BY ZERO
;
OVER:	LXI	H,FLOAT
	JMP	ERROR
UNDER:	MVI	A,0FFH
	STA	ERRI
INSP:	INX	SP
	INX	SP
	RET
;
DIVZ	EQU	OVER
;
;	HAMPSHIRE ADDED COMMANDS
;
CSYS:	JMP	0
;
SAVE:	CALL	GC
	CPI	CR
	CNZ	WSID	;RENAME THE WORK-SPACE
	CALL	SETFCB	;SET UP FCB
	MVI	C,19	;ERASE PREVIOUS FILE (IF ANY)
	LXI	D,TFCB
	CALL	SYSTEM
	MVI	C,22	;CREATE A NEW FILE
	LXI	D,TFCB
	CALL	SYSTEM
	CPI	0FFH
	JZ	SAV6	;IF NO DIRECTORY SPACE
	LHLD	BOFA	;INITIALIZE DMA ADDR
	XCHG
	MOV	A,D
	CMA
	MOV	B,A
	MOV	A,E
	CMA
	MOV	C,A
	INX	B	;NEGATE BOFA
	LHLD	EOFA	;COUNT=EOFA-BOFA+1
	DAD	B
	INX	H
SAV1:	XRA	A	;COUNT<256?
	ORA	H
	JNZ	SAV2	;IF COUNT>255
	MOV	A,L
	CPI	128
	JM	SAV3	;IF COUNT<128
SAV2:	PUSH	D	;SAVE COUNT AND DMA ADDRESS
	PUSH	H
	MVI	C,26	;SET DMA ADDR
	CALL	SYSTEM
	MVI	C,21	;WRITE SECTOR
	LXI	D,TFCB
	CALL	SYSTEM
	ORA	A
	JNZ	SAV5	;IF NO DISK SPACE
	POP	H	;RETRIEVE COUNT AND DMA ADDR
	POP	D
	LXI	B,-128	;COUNT=COUNT-128
	DAD	B
	XCHG
	LXI	B,128	;DMA ADDR=DMA ADDR+128
	DAD	B
	XCHG
	JMP	SAV1
;
SAV3:	ORA	A
	JNZ	SAV4	;IF COUNT>0
	MVI	C,26	;RESET DMA ADDRESS TO 80H
	LXI	D,TBUFF
	CALL	SYSTEM
	MVI	C,16	;CLOSE FILE
	LXI	D,TFCB
	CALL	SYSTEM
	JMP	CMND1	;RETURN TO TOP LEVEL OF INTERPRETTER
;
SAV4:	XCHG		;HL=DMA ADDR, E=COUNT
	LXI	B,TBUFF
SAV41:	MOV	A,M	;MOVE BYTE TO TBUFF
	STAX	B
	INX	H
	INX	B
	DCR	E
	JNZ	SAV41	;LOOP FOR ALL BYTES
	LXI	H,128	;SO COUNT WILL BE 0 ON NEXT PASS
	LXI	D,TBUFF	;DMA ADDR=TBUFF
	JMP	SAV2
;
SAV5:	LXI	H,FSERR
	JMP	ERROR
;
SAV6:	LXI	H,DSERR
	JMP	ERROR
;
FETCH:	CALL	SETFCB	;SET UP FCB
	MVI	C,15	;OPEN FILE
	LXI	D,TFCB
	CALL	SYSTEM
	CPI	0FFH
	JZ	FET11	;IF FILE NOT FOUND
	LXI	H,NR	;INITIALIZE NEXT RECORD INDEX
	MVI	M,0
	LHLD	BOFA	;INITIALIZE DMA ADDR
	XCHG
	MOV	A,D	;NEGATE BOFA
	CMA
	MOV	B,A
	MOV	A,E
	CMA
	MOV	C,A
	INX	B
	LHLD	SYSTEM+1;FREE SPACE LENGTH=FL-BOFA
	DAD	B
FET1:	XRA	A	;COUNT<=255?
	ORA	H
	JNZ	FET2	;IF COUNT>255
	MOV	A,L
	CPI	128
	JM	FET4	;IF COUNT<128
	JZ	FET4	;IF COUNT=128
FET2:	PUSH	D	;SAVE DMA ADDR AND LENGTH
	PUSH	H
	MVI	C,26	;SET DMA ADDR
	CALL	SYSTEM
	MVI	C,20	;READ SECTOR
	LXI	D,TFCB
	CALL	SYSTEM
	POP	H	;RETRIEVE DMA ADDR AND COUNT
	POP	D
	ORA	A
	JZ	FET3	;IF SUCCESSFUL READ
	RRC
	JC	FET9	;IF EOF READ
	LXI	H,RNDER	;RANDOM ACCESS FILE ERROR
	JMP	ERROR
;
FET3:	LXI	B,-128	;LENGTH=LENGTH-128
	DAD	B
	XCHG
	LXI	B,128	;DMA ADDR=DMA ADDR+128
	DAD	B
	XCHG
	JMP	FET1
;
FET4:	ORA	A
	JZ	FET5	;IF LENGTH=0
	PUSH	D	;SAVE DMA ADDR AND LENGTH
	PUSH	H
	LXI	H,128
	LXI	D,TBUFF	;DMA ADDR=TBUFF
	JMP	FET2
;
FET5:	LXI	H,TBUFF	;FIND FIRST CR IN TBUFF
	LXI	D,TBUFF+127 ;SET UPPER LIMIT OF SEARCH
	MVI	C,128	;SET MAXIMUM NUMBER OF BYTES TO SEARCH
	MOV	A,M
	CPI	EOF
	JZ	FET6	;IF FIRST BYTE IS EOF
FET51:	CPI	CR
	INX	H
	JNZ	FET52	;IF NOT CR
	DCR	C
	JZ	FET12	;IF CR IS LAST BYTE IN TBUFF
	CALL	FET10	;FIND EOF
	JMP	FET6
;
FET52:	MOV	A,M
	DCR	C
	JNZ	FET51	;IF MORE BYTES TO SEARCH
	JMP	FET12	;FILE SIZE ERROR
;
FET6:	LXI	B,-TBUFF-1 ;SET COUNT OF BYTES TO MOVE
	DAD	B
	POP	B	;RETRIEVE LENGTH OF FREE SPACE
	MOV	A,B
	CMP	H
	JM	FET12	;IF FILE TOO LONG
	JNZ	FET7	;IF FILE NOT TOO LONG
	MOV	A,C
	CMP	L
	JM	FET12	;IF FILE TOO LONG
FET7:	POP	B	;SET FREE SPACE ADDR
	LXI	D,TBUFF
FET8:	LDAX	D	;MOVE COUNT BYTES TO FREE SPACE
	STAX	B
	INX	D
	INX	B
	DCR	L
	JNZ	FET8	;IF MORE BYTES TO MOVE
;
FET9:	LHLD	SYSTEM+1	;FIND EOF
	DCX	H
	XCHG
	LHLD	BOFA
	CALL	FET10
	SHLD	EOFA
	MVI	C,26
	LXI	D,TBUFF
	CALL	SYSTEM
	RET
;
FET10:	MOV	A,M
	CPI	EOF
	RZ		;IF EOF FOUND
	ORA	A
	JZ	FET11	;IF ILLEGAL FILE
	CALL	ADR
	MOV	A,E
	SUB	L
	MOV	A,D
	SBB	H
	JC	FET12	;IF FILE TOO LONG
	JMP	FET10
;
FET11:	LXI	H,FNAME
	JMP	ERROR
;
FET12:	LXI	H,FSIZE
	JMP	ERROR
;
CNAME:	CALL	GC
	CPI	CR
	JZ	CNAM1	;IF CURRENT WSID WANTED
	CALL	WSID	;RENAME THE WORK-SPACE
	JMP	CMND1
;
CNAM1:	LXI	D,IBUF	;ASSEMBLE OUTPUT INTO IBUF
	LXI	H,WSIDN
	MVI	C,8
	CALL	COPY	;COPY FILE NAME
	MVI	A,' '
	STAX	D
	INX	D
	MVI	C,3
	CALL	COPY	;COPY FILE TYPE
	MVI	A,'"'
	STAX	D
	LXI	H,IBUF	;OUTPUT WSID
	CALL	PRNT
	CALL	CRLF
	JMP	CMND1
;
ERA:	CALL	SETFCB	;INITIALIZE TFCB
	CALL	GC
	CPI	CR
	JZ	ERA1	;IF FILE NAME=WSID
	LXI	D,TFCB+1;SET UP FILE NAME AND TYPE IN TFCB
	MVI	A,' '	;PRESET NAME AND TYPE
	MVI	C,11
ERA0:	STAX	D
	INX	D
	DCR	C
	JNZ	ERA0
	LXI	D,TFCB+1;SET NAME AND TYPE
	LHLD	TXA
	MVI	C,9
	CALL	SETFN	;SET NAME
	CPI	CR
	JZ	ERA1	;IF DONE
	CPI	'.'
	JNZ	ERA2	;IF FILE NAME ERROR
	INX	H
	LXI	D,TFCB+9
	MVI	C,4
	CALL	SETFN	;SET TYPE
	CPI	CR
	JNZ	ERA2	;IF FILE NAME ERROR
ERA1:	MVI	C,19	;DELETE FILE
	LXI	D,TFCB
	CALL	SYSTEM
	JMP	CMND1
;
ERA2:	LXI	H,FNAME
	JMP	ERROR
;
WSID:	LXI	H,WSIDN	;INITIALIZE NAME ADDR
	LXI	D,WSIDD	;INITIALIZE DEFAULT WSID ADDR
	MVI	C,11
WSID1:	LDAX	D	;INITIALIZE WSID
	MOV	M,A
	INX	H
	INX	D
	DCR	C
	JNZ	WSID1
	LHLD	TXA
	CALL	GC
	CPI	CR
	RZ		;IF NO FILE NAME SPECIFIED
	MVI	A,' '	;PREPARE NAME FIELD
	MVI	C,8
	LXI	D,WSIDN
WSD10:	STAX	D
	INX	D
	DCR	C
	JNZ	WSD10	;IF MORE TO DO
	LXI	D,WSIDN
	MVI	C,9
	CALL	SETFN	;SET FILE NAME
	CPI	CR
	RZ		;IF DONE
	CPI	'.'
	JNZ	WSID3	;IF FILE NAME ERROR
	MVI	A,' '	;PREPARE TYPE FIELD
	MVI	C,3
	LXI	D,WSIDT
WSID2:	STAX	D
	INX	D
	DCR	C
	JNZ	WSID2
	MVI	C,4
	LXI	D,WSIDT
	INX	H
	CALL	SETFN
	CPI	CR
	RZ		;IF DONE
WSID3:	LXI	H,FNAME
	JMP	ERROR
;
SETFN:	MOV	A,M
	CPI	CR
	RZ
	CPI	'.'
	RZ
	STAX	D
	INX	H
	INX	D
	DCR	C
	RZ
	JMP	SETFN
;
SETFCB:	LXI	H,TFCB	;SET FCB ADDR
	MVI	M,0	;CLEAR ET
	INX	H
	MVI	C,11
	LXI	D,WSIDN	;SET ADDR OF WSID
SETF1:	LDAX	D	;COPY WSID TO TFCB
	MOV	M,A
	INX	H
	INX	D
	DCR	C
	JNZ	SETF1	;IF MORE CHARS
	MVI	C,21
SETF2:	MVI	M,0	;CLEAR REST OF FCB
	INX	H
	DCR	C
	JNZ	SETF2
	RET
;
;	FLOATING POINT RAM
;
HOLD1:	DS	DIGIT+1
HOLD2:	DS	DIGIT+1
HOLD3:	DS	DIGIT+1
HOLD4:	DS	DIGIT+1
HOLD5:	DS	DIGIT+1
HOLD6:	DS	DIGIT+1
HOLD7:	DS	DIGIT+1
HOLD8:	DS	DIGIT+1
	DS	1
ERRI:	DS	1	;ERROR FLAG
	DS	1
BUF:	DS	DIGIT	;WORKING BUFFER
SIGN:	DS	1	;SIGN BIT
EXP:	DS	1	;EXPONENT
RCTRL:	DS	1	;ROUNDING CONTROL FLAG 1=MSD
RDIGI:	DS	1	;ROUNDING DIGIT
SIGND	EQU	HOLD1+DIGIT
EXPD	EQU	HOLD1+DIGIT+1
;
;	SYSTEM RAM
;
LWID:	DB	80	;LINE WIDTH LIMIT
WSIDN:	DS	8	;WORK-SPACE NAME FIELD
WSIDT:	DS	4	;WORK-SPACE TYPE FIELD
WSIDD:	DB	'PROGRAM BSC' ;DEFAULT NAME AND TYPE
EROM:	DS	0
	DS	100
CMNDSP:	DB	0
MACSIZ	EQU	34
MACSP:	DW	MACSTK
	DS	MACSIZ-1
MACSTK:	DB	0	;DB TO PREVENT MACSTK=TRPSP
TRPSIZ	EQU	20
TRPSP:	DW	TRPSTK
	DS	TRPSIZ-1
TRPSTK:	DB	0	;DB TO PREVENT TRPSTK=PHEAD
PHEAD:	DS	1
RELTYP:	DS	1
NULLCT:	DS	1
PFLAG:	DB	0	;I/O SWITCH- 1=PRINTER, 0=CONSOLE
ARGF:	DS	1
DIRF:	DS	1
TXA:	DS	2
CSTKSZ	EQU	100
ASTKSZ	EQU	FPSIZ*LINLEN/2
CSTKL:	DS	CSTKSZ
ASTKL:	DS	ASTKSZ
RTXA:	DS	2
STB:	DS	2
CSTKA:	DS	2
SINK:	DS	FPSIZ-1
FPSINK:	DS	1
	DS	FPSIZ-1
FTEMP:	DS	1
	DS	FPSIZ-1
FTEM1:	DS	1
	DS	FPSIZ-1
FTEM2:	DS	1
	DS	FPSIZ-1
FRAND:	DS	1
IBCNT:	DS	1
IBLN:	DS	2
IBUF:	DS	LINLEN
ASTKA:	DS	2
MATA:	DS	2
ADDS:	DS	2
ADDT:	DS	2
BCADD:	DS	2
OPST:	DS	1
OPSTR:	DS	1
ECNT:	DS	1
FSIGN:	DS	1
BC:	DS	DIGIT+2
ABUF:	DS	DIGIT*2+2
XSIGN:	DS	1
EXPO:	DS	1
FES:	DS	1
INFES:	DS	1
MAXL:	DS	2
INSA:	DS	2
;
;	SPECIAL INTERFACE GLOBAL
;
CALST:	DS	6
CALLA:	DS	2
EOFA:	DS	2	;END OF FILE ADDRESS
BOFA:	DS	2	;START OF FILE ADDRESS
MEMTOP:	DS	2	;STORAGE FOR LAST ASSIGNED MEMORY LOCATION
;
;
	END
