	PCC	0
	NAME	RTP6800V1.4j
	TITLE	SD BASIC Version 1.4j Runtime Package (c) 1980 Software Dynamics
	INCLUDE	SDOSUSERDEFS.ASM	SO WE GET SDOS INTERFACE STUFF
	TITLE	SD BASIC Version 1.4j Runtime Package (c) 1980 Software Dynamics
	PAGE	***** ERROR AND ADDRESS CONSTANTS *****
	TABS	20,28,44,45
	PAGE
	PGEN	1	I WANT TO SEE ALL THE GENERATED STUFF
*
*	BASIC RUNTIME PACKAGE
*	COPYRIGHT (C) 1977 SOFTWARE DYNAMICS
*	ALL RIGHTS RESERVED
*	EDITED 09/11/79 1100
*	7/9/79	CHANGE BCD FLOATING POINT TO BASE 100 BINARY DIGIT FLOATING POINT -- I.B.
*	7/11/79	REMOVE VALUE STACK OVERFLOW CHECKS ON "LOAD" OPCODES
*		(SPEEDS THINGS UP, ALMOST NEVER FAILS ANYWAY)
*	7/13/79	INSTALL FIX16; SPEED UP "OPSTORE"
*	9/4/79 GET RID OF IO-PACKAGE JUMP TABLE, INSTALL SYSCALLS ***
*	9/22/79 I.B. OPTIMIZE VECTOR/SCALAR LOAD/STORES SIZE/SPEED
*		ALLOW SUBROUTINE PARAMETERS
*		ADD OPCODES LEN(VECTOR), ROWS(ARRAY), COLS(ARRAY)
*		TRAP ON INPUT CONVERSION ON CHANNEL 0 IS ERROR TRAPPING ENABLED
*		SD'S HAVE NON-ZERO MSB TO SIDESTEP SPEED OPTIMIZATION ON SCALAR FETCH
*		INSTALL EXTENDED OPCODE HANDLER; MODIFY SOME OPCODES TO MATCH
*	9/31/79 I.B. CLEANUP FOR 9/22 PASS
*		ALLOW INDEPENDENTLY COMPILED SUBROUTINES/FUNCTIONS
*		CHANGE ERROR HANDLING SO EACH MAIN/SUBR/FN HAS OWN ERROR TRAP
*		MERGED GOSUBSTACK INTO MACHINE STACK
*		OPTIMIZED FOR-NEXT, ALLOW ZERO LOOP ITERATIONS, SLIGHT SPEEDUP
*	10/4/79	I.B. CLEANUP AGAIN... ALSO ADD STRING ARRAY HANDLING
*	3/3/80	I.B. MAKE PATCHES TO 10/4/79 VERSION PERMANENT
*	7/8/80	1.4g	I.B. MORE CLEANUP; INSTALL ERROR <exp>, CHR$(exp),
*			Error propogation from inside fns, PSHDs
*	12/8/80	1.4h	I.B. FIX ERRORS UNCOVERED BY DIAGNOSTICS.
*			CONVERT TO M680C AND TEST ON 6800.
*			SPEEDED UP OPFIND
*			ADDED CHANEL AND ERROR TO CONTEXT BLOCK
*			INSTALLED OPLESCALAR, OPSESCALAR
*
*	4/4/82 1.4i	I.B. EDIT FOR TEST ON 6809.
*		A. CHANGED SUBSTRING ASSIGNMENT TO BLANK PAD IF SOURCE STRING
*		WAS SHORTER THAN DESTINATION SUBSTRING.
*		B. FATAL ERRORS PRINT ADDRESS OF ORIGINAL SIN.
*		C. FIXED SO ^B IN INPUT DIDN'T DESTROY INPUT LINE
*
*	7/29/82 1.4j	I.B. Clean up patches for re-assembly
*
	page
*	THINGS LEFT TO DO/CONSIDER:
*		ALLOW RECURSIVE USE OF CATBUF
*		, IN FORMAT ?
*		* FILL IN FORMAT ?
*		FORMATTED INPUT ?
*		ISSUE SPECIAL SYSCALL TO START UP LINEFLAGS ACQUISITION TASK ?
*		IF TRACE THEN...
*		Lineflags get turned off over a Chain; perhaps shouldn't ?
*		NUM$,NUMF$, CAT should use Stack instead of fixed buffer;
*			this would allow truly recursive use.
*		Input I/O error while in Break on Line causes an error trap.
*			This is only an annoyance.
*
VERSION	EQU	$14	VERSION 1, REVISION 4
	PAGE
*	MACHINE STACK USAGE:
*
*	!-----------------------!
*	!                       !  <-------STACKFRAMEBASE
*	!  GOSUB RETURN ADDR    !
*	!                       !
*	!-----------------------!
*	!           .           !
*	!           .           !
*	!           .           !
*	!-----------------------!
*	!                       !
*	!  GOSUB RETURN ADDR    !
*	!                       !
*	!-----------------------!
*	!                       !  <------ ERRORRECOVERYSTACK
*	!         VALUE         !
*	!                       !
*	!-----------------------!
*	!           .           !
*	!           .           !
*	!           .           !
*	!-----------------------!
*	!                       !
*	!         VALUE         !
*	!                       !
*	!-----------------------!
*	!                       !
*	!    SUBR/FUNCTION      !
*	!    CALL/RETURN BLOCK  !
*	!                       !
*	!-----------------------!
*	!                       !  <------ STACKFRAMEBASE'
*	!                       !
*
	PAGE
*	*** MODIFY RESTORE FOR KEYED FILES!!! *****

	IFUND	PZBASE	PLACE WERE PAGE ZERO VARS GO
PZBASE	EQU	$28	DEFAULT
	FIN

	IFUND	CODE	PLACE WHERE RUNTIME PACKAGE CODE GOES
CODE	EQU	$100	DEFAULT
	FIN

	IFUND	M6800
	IFUND	M6801
	IFUND	M6809
M6800	EQU	1	THIS ASSEMBLY IS FOR 6800 SYSTEMS
M6801	EQU	0	THIS ASSEMBLY IS FOR 6801 SYSTEMS
M6809	EQU	0	THIS ASSEMBLY IS FOR 6809 SYSTEMS
	FIN
	FIN
	FIN
*
*	ERROR CODES
*
:STOP	EQU	0	STOP STATEMENT EXECUTED
:ABORT	EQU	1	OPERATOR ABORT
	EQU	2	*** NOT USED ***
	EQU	3	*** NOT USED ***
	EQU	4	*** NOT USED ***
	EQU	5	*** NOT USED ***
:GSBUND	EQU	6	GOSUB STACK UNDERFLOW
:CONVER	EQU	7	INPUT CONVERSION ERROR
:IBUFOVF	EQU	8	INPUT BUFFER OVERFLOW
:ARYRNG	EQU	9	ARRAY OR VECTOR SUBSCRIPT ERROR
:BADRTP	EQU	10	CHECKSUM OVER RTP FAILED
:SSBRNG	EQU	11	STRING SUBSCRIPT ERROR
:SLNRNG	EQU	12	SUBSTRING LENGTH TOO LONG
:UDFLIN	EQU	13	UNDEFINED LINE # (AN UNLUCKY #)
:FLTOVF	EQU	14	FLOATING OVERFLOW
:FLTNXP	EQU	15	UNEXPECTED FLOATING VALUE
:CATOVF	EQU	16	CATBUF OVERFLOW
:TABBIG	EQU	17	SPECIFIED TAB > 255
:FORMAT	EQU	18	FORMAT STRING ERROR
:STORBE	EQU	19	# IS TOO BIG ON STORE BYTE
:LOGARG	EQU	21	LOG OF ZERO OR NEG #
:SQTERR	EQU	22	SQRT 0F NEG NUMBER
:POKADD	EQU	23	PEEK OR POKE ADD < 0 OR > 65535
:POKVAL	EQU	24	POKE VALUE > 255
:POKRTP	EQU	25	YOU POKED AT THE RUNTIME PACKAGE, TURKEY
:VERERR	EQU	26	BASIC PROGRAM VERSION # DOESN'T AGREE WITH RTP
:ARGCNTERR	EQU	27	WRONG # ARGUMENTS TO FUNCTION/SUBROUTINE
:DATASPACECONFLICT	EQU	28	DATA SPACE OVERLAPS SDOS
:OVERLAPSRTP	EQU	29	PROGRAM (SUBROUTINE) OVERLAPS RTP
:CHNLR	EQU	50	ILLEGAL CHANEL #
:FNAME	EQU	52	FILE NAME IS TOO LONG
:POSERR	EQU	60	POSITIONING ERROR, # TOO BIG
	PAGE	*****  E R R O R   A N D   A D D R E S S   C O N S T A N T S  *****
*	DEFINE LENGTH OF STACK ENTRIES
*
RSESIZ	EQU	6	RUN (VALUE) STACK ENTRY SIZE
*
*	STRING STRUCTURE ADDRESS DISPLACEMENT CONSTANTS
*
MAXLEN	EQU	0	MAX STRING LENGTH
CURLEN	EQU	2	CURRENT STRING LENGTH
STRING	EQU	4	START OF STRING
BYTE	EQU	0	LOAD OR STORE SINGLE BYTE
*
*	IN LINE DATA STRUCTURES & ADDRESS DISPLACEMENT CONSTANTS
*
OPCODE	EQU	-1	DISPLACEMENT OF OPCODE FROM BPC WHEN POP ROUTINE GETS CONTROL
ILADDH	EQU	0	IN LINE ADDRESS HIGH
ILADDL	EQU	1	IN LINE ADDRESS LOW
ILADD	EQU	0	IN LINE ADDRESS
*
ILSDC	EQU	0	IN LINE STRING DESCRIPTOR COUNT
*
ILINTH	EQU	0	IN LINE INTEGER HIGH
ILINTL	EQU	1	IN LINE INTEGER LOW
ILINT	EQU	0	IN LINE INTEGER
*
*	DATA STRUCTURES & ADDRESS DISPLACEMENT CONSTANTS FOR VARIABLES
*
VFLT1	EQU	0	FLOATING VARIABLE FIRST BYTE
VFLT2	EQU	1	2ND BYTE
VFLT3	EQU	2	3RD BYTE
VFLT4	EQU	3	4TH BYTE
VFLT5	EQU	4	5TH BYTE
VFLT6	EQU	5	6TH BYTE
*
VINT1	EQU	4	INTEGER VARIABLE FIRST BYTE
VINT2	EQU	5	2ND BYTE
*
VTYPE	EQU	0	TYPE BYTE, 0 IF INT, ELSE FLOATING
	PAGE
*	DATA STRUCTURE & ADDRESS DISPLACEMENT CONSTANTS FOR
*	RUNTIME (OR VALUE) STACK
*
R1ADDH	EQU	4	TOS ADDRESS HIGH
R1ADDL	EQU	5	TOS ADDRESS LOW
R1ADD	EQU	4	TOS ADDRESS
*
R2ADDH	EQU	10	TOS-1 ADDRESS HIGH
R2ADDL	EQU	11	TOS-1 ADDRESS LOW
R2ADD	EQU	10	TOS-1 ADDRESS
*
R3ADD	EQU	16
R3ADDH	EQU	16
R3ADDL	EQU	17
*
R1FLT1	EQU	0	TOS FLOATING VALUE FIRST BYTE
R1FLT2	EQU	1	2ND BYTE
R1FLT3	EQU	2	3RD BYTE
R1FLT4	EQU	3	4TH BYTE
R1FLT5	EQU	4	5TH BYTE
R1FLT6	EQU	5	6TH BYTE
*
R2FLT1	EQU	6	TOS-1 FLOATING VALUE FIRST BYTE
R2FLT2	EQU	7	2ND BYTE
R2FLT3	EQU	8	3RD BYTE
R2FLT4	EQU	9	4TH BYTE
R2FLT5	EQU	10	5TH BYTE
R2FLT6	EQU	11	6TH BYTE
*
R3FLT1	EQU	12
R3FLT2	EQU	13
R3FLT3	EQU	14
R3FLT4	EQU	15
R3FLT5	EQU	16
R3FLT6	EQU	17
*
R1INT1	EQU	4	TOS INTEGER VALUE MSBYTE
R1INT2	EQU	5	TOS INTEGER 2ND BYTE
*
R2INT1	EQU	10	TOS-1 INTEGER MSBYTE
R2INT2	EQU	11	TOS-1 INTEGER 2ND BYTE
*
R3INT1	EQU	R2INT1+RSESIZ	TOS-2 INTEGER UPPER HALF
R3INT2	EQU	R3INT1+1	TOS-2 INTEGER LOWER HALF
*
R1SDA	EQU	2	TOS STRING DESCRIPTOR ADDRESS
R1SDAH	EQU	2	TOS STRING DESCRIPTOR ADDRESS HIGH
R1SDAL	EQU	3	TOS STRING DESCRIPTOR ADDRESS LOW
R1SDC1	EQU	4	TOS STRING DESCRIPTOR COUNT MSBYTE
R1SDC2	EQU	5	TOS STRING DESCRIPTOR COUNT LSBYTE
R1SDC	EQU	R1SDC1
*
R2SDA	EQU	8	TOS-1 STRING DESCRIPTOR ADDRESS
R2SDAH	EQU	8	TOS-1 STRING DESCRIPTOR ADDRESS HIGH
R2SDAL	EQU	9	TOS-1 STRING DESCRIPTOR ADDRESS LOW
R2SDC1	EQU	10	TOS-1 STRING DESCRIPTOR COUNT MSBYTE
R2SDC2	EQU	11	TOS-1 STRING DESCRIPTOR COUNT LSBYTE
R2SDC	EQU	R2SDC1
*
R3SDA	EQU	14
R3SDAH	EQU	14
R3SDAL	EQU	15
R3SDC1	EQU	16
R3SDC2	EQU	17
R3SDC	EQU	R3SDC1
*
R1TYPE	EQU	0	TYPE BYTE FOR TOS
R2TYPE	EQU	6	TYPE BYTE FOR TOS-1
R3TYPE	EQU	12	TYPE BYTE FOR TOS-2
	PAGE
*	FOR STACK DATA STRUCTURES & ADDRESS DISPLACEMENT CONSTANTS
*
FSTYPE	EQU	0	FLOATING STEP VALUE IN FOR STACK 1ST BYTE
FSTEP2	EQU	1	2ND BYTE
FSTEP3	EQU	2	3RD BYTE
FSTEP4	EQU	3	4TH BYTE
FSTEP5	EQU	4	5TH BYTE
FSTEP6	EQU	5	6TH BYTE
*
FISTEP1	EQU	4
FISTEP2	EQU	5
*
FLTYPE	EQU	6	FLOATING LIMIT VALUE IN FOR STACK 1ST BYTE
FLIM2	EQU	7	2ND BYTE
FLIM3	EQU	8	3RD BYTE
FLIM4	EQU	9	4TH BYTE
FLIM5	EQU	10	5TH BYTE
FLIM6	EQU	11	6TH BYTE
*
FILIM1	EQU	10
FILIM2	EQU	11
	PAGE
*	LINE BYTE DEFINITIONS
*
GOBIT	EQU	$8	GO FROM BREAKPOINT/SINGLE STEP
SSTEPBIT	EQU	$10	SINGLE STEP REQUEST
BREAKBIT	EQU	$20	REQUEST LINE NUMBER BREAKPOINT
TRACEBIT	EQU	$40	REQUEST LINE NUMBER TRACE
ABORTBIT	EQU	$80	REQUEST PROGRAM ABORT
*
*	ASCII CODES
*
BELL	EQU	7
CR	EQU	$D
BLANK	EQU	$20
*
*	POPCODE HEADER DISPLACEMENTS
*
	ORG	0
RTP:VERSIONNUMBER	RMB	1	CONTAINS RTP VERSION NUMBER
RTP:FREFLABELCHAIN	RMB	2	POINTER TO FORWARD REFERENCE LABEL CHAIN
RTP:CATSIZEREQD	RMB	2	AMOUNT OF CONCATENATION BUFFER SPACE NEEDED
RTP:LASTPARAMADDR	EQU	RTP:CATSIZEREQD	POINTER TO LAST PARAMETER IF FUN/SUBR ENTRY
RTP:BASEOFSCALARVARS	RMB	2	POINTER TO...
RTP:TOPOFDATASPACE	RMB	2	POINTER TO 1ST BYTE PAST DATA SPACE
RTP:POPCODESTART	RMB	0	FIRST BASIC POPCODE
RTP:ARGCOUNT	RMB	1	ARG COUNT FOR FUNCTIONS/SUBROUTINES
RTP:FUNSUBPOPCODE	RMB	0	FIRST BASIC POPCODE FOR FUNCTIONS/SUBROUTINES

	IFUND	RTPTOTALCKSUM
RTPTOTALCKSUM	EQU	0
	FIN
	PAGE	*****  P R O G R A M   V A R I A B L E S  *****
*
	ORG	$20	TO AVOID 6801 PAGE ZERO REGISTERS *!?>.
*	SCRATCH VARIABLES -- ANY ROUTINE MAY USE
	IFUND	TEMPA
TEMPA	RMB	1
TEMPB	RMB	1
TEMPX	EQU	TEMPA
	FIN

	ORG	PZBASE

****
FPTRAP	RMB	2	POINTER TO FLOATING POINT ERROR TRAP ROUTINE
****

*	CONTEXT INFORMATION FOR BASIC SUBROUTINE/FUNCTION INCARNATION
*	NOTE: THESE VARIABLES MUST BE IN THE SPECIFIED ORDER!
*	(SEE SUBFUNENTRY,XOPRETURN,XOPERRST)
*
CONTEXTSTART	EQU	*
ERCODE	RMB	2	HOLDS THE ERROR CODE
LINEADDR	RMB	2	POINTER TO LAST EXECUTED "OPLINE"(/OPLABEL) OPCODE
BPC	RMB	2	SIMULATED "BASIC" PROGRAM COUNTER
VARTABLE	RMB	2	POINTER TO BASE OF SCALAR VARIABLES
ERTRAP	RMB	2	HOLDS POINTER TO USER'S ERROR RECOVERY CODE
ERADDR	RMB	2	POINTER TO LINE # OPCODE OF LAST LINE IN WHICH ERROR OCCURRED
STACKFRAMEBASE	RMB	2	POINTER TO BASE OF THIS INCARNATION'S STACK SPACE
ERRORRECOVERYSTACK	RMB	2	POINTER TO TOP OF GOSUB BLOCKS FOR THIS INCARNATION
CHANEL	RMB	1	I/O CHANNEL FOR STATEMENT BEING EXECUTED
USING	RMB	2	POINTS TO REST OF "USING" STRING
USINGMAX	RMB	2	POINTS TO END OF "USING" STRING
ILERR	RMB	2	RECOVERY ADDRESS FOR "XOPINLINE" OPCODE
CONTEXTEND	EQU	*

SUBROUTINENESTING	RMB	1	= NESTING OF SUBROUTINES/FUNCTIONS

ORIGINALSINADDR	RMB	2	HOLDS ADDRESS OF LINE WHERE ORIGINAL SIN OCCURRED
	PAGE

BREAKLINE	RMB	6	HOLDS THE BREAKPOINT LINE NUMBER 
LINEFLAGS	RMB	1	HOLDS THE LINE FLAGS
TBYTE	RMB	1	TEMP BYTE
FLAG	RMB	1	TRUE <> 0 FALSE = 0
*
*	THE FOLLOWING VARS ARE USED BY THE SYSCALL ROUTINE
*	THEY ARE STRATEGICALLY LOCATED SUCH THAT THEY OVERLAP
*	SOME TEMPS WHICH AREN'T USED BY THE SYSCALL FUNCTION
*	IF YOU FOOL AROUND HERE, YOU BETTER BE CAREFULL...
*
SYSCALLSTRHEADPTR	RMB	2	POINTER TO STRING DESCRIPTOR
SYSCALLBLOCKPTR	RMB	2
SYSCALLBLOCK	EQU	*
SCBLK	RMB	2	SYSCALL PARAMETER LIST
SYSCALLPARAMS	RMB	2	PARAMETERS
SYSCALLWRBUF	RMB	2	WRITE BUFFER ADDRESS
SYSCALLWRLEN	RMB	2	WRITE BUFFER LENGTH
SYSCALLRPLEN	RMB	2	READ BUFFER REPLY LENGTH
SYSCALLRDBUF	RMB	2	READ BUFFER ADDRESS
SYSCALLRDLEN	RMB	2	READ BUFFER SIZE
*
*	THESE ARE THE OVERLAPPED VARS
*
	ORG	*-$E	BECAUSE THESE VARS ARE NOT USED BY SYSCALL
TWORD	RMB	2	TEMPORARY WORD
LOOPCT	RMB	1	LOOP COUNTER
S1LEN	RMB	2	HOLDS LEN OF STR 1 FOR COMPARE
S2LEN	RMB	2	HOLDS LEN OF STR 2 FOR COMPARE
S1ADD	RMB	2	HOLDS ADD OF STR 1 FOR COMPARE
S1ADDT	RMB	2	HOLDS ADD OF STR 1 FOR OPFIND
S2ADD	RMB	2	HOLDS ADD OF STR 2 FOR COMPARE
S2ADDT	RMB	2	HOLDS ADD OF STR 2 FOR OPFIND
*
*	THIS IS THE END OF THE OVERLAPPED VARIABLES
	PAGE
INPTR	RMB	2	POINTS TO NEXT CHAR TO SCAN
CATPTR	RMB	2	POINTS PAST CURRENT CATBUF CONTENTS
RTPRET	RMB	2	HOLDS A RETURN ADDRESS
ACMRET	RMB	2	RETURN ADDRESS FOR COMPARE ROUTINE
	IF	M6800!M6801
JMPADD	RMB	2	HOLDS POINTER TO ENTRY IN 1ST HALF OF JUMP TABLE
	FIN
BPCSAV	RMB	2	HOLE FOR SAVING BPC WHILE EXECUTING INTERNAL BASIC POPS
SIGNZ	RMB	6	TEMPORARIES FOR TRANSCENDENTAL ROUTINES
TTEMP1	RMB	6
TTEMP2	RMB	6
OPPOLYARG	RMB	6
SEED	RMB	6	FOR RAND FUNCTION
*
*	FORMATTING VARIABLES
*
LDOLLAR	RMB	1	HOLDS DOLLAR COUNT FOR FORMAT SPEC
LMINUS	RMB	1	HOLDS LEFT MINUS COUNT FOR FORMAT SPEC
LSHARP	RMB	1	HOLDS LEFT SHARP COUNT FOR FORMAT SPEC
RSHARP	RMB	1	HOLDS RIGHT SHARP COUNT FOR FORMAT SPEC
RMINUS	RMB	1	HOLDS RIGHT MINUS COUNT FOR FORMAT SPEC
RCARET	RMB	1	HOLDS RIGHT CARET COUNT FOR FORMAT SPEC
FLENGTH	RMB	1	HOLDS LENGTH OF FORMAT SPEC
SIG	RMB	1	HOLDS # OF SIGNIFICANT DIGITS
LEAD	RMB	1	HOLDS # OF LEADING DIGITS IF E=0
ENDFORMAT	RMB	2	POINTS TO BYTE PAST END OF POSSIBLE NUMBER FORMAT STRING

OUTBUFSIZE	EQU	18	SIZE OF OUTPUT/TEMP BUFFER
OUTBUF	RMB	OUTBUFSIZE	OUTPUT FORMATTING BUFFER
TIMESTR	EQU	OUTBUF	NOTE: TIMESTR IS SHORTER THAT OUTBUFSIZE
DATESTR	EQU	TIMESTR+9
SCRATCH	EQU	OUTBUF
	PAGE
*	MULTIPLY & DIVIDE VARS
*
DIGMAX	EQU	10	MAX NUMBER OF DIGITS ALLOWED
ML	RMB	1	MULTIPLIER DIGIT FOR FMUL, FDIV; TEMP FOR OTHERS
*
MR1	RMB	1	6 BYTES FOR FLOATING POINT ACCUMULATORS
MR2	RMB	1
MR3	RMB	1
MR4	RMB	1
MR5	RMB	1
MR6	RMB	1
*
MSIGN	RMB	1	HOLDS SIGN OF RESULT
MEXP	RMB	1	HOLDS EXP, MUST PRECEED FAC
FAC1	RMB	1	FLOATING ACCUMULATOR WITH EXTENSION
FAC2	RMB	1	FAC, FACEXT MAY NOT CROSS PAGE BOUNDARY
FAC3	RMB	1
FAC4	RMB	1
FAC5	RMB	1
FAC6	RMB	1
FACEXT1	RMB	1
FACEXT2	RMB	1
FACEXT3	RMB	1
FACEXT4	RMB	1
FACEXT5	RMB	1
*
MS1	RMB	1	6 BYTES FOR FLOATING POINT ACCUMULATORS
MS2	RMB	1	MS1 MUST FOLLOW FACEXT5
MS3	RMB	1
MS4	RMB	1
MS5	RMB	1
MS6	RMB	1
*
MINUSDIVISORDIGIT	RMB	1	CONTAINS -(LEADING DIGIT OF DIVISOR) FOR FDIV (GUESSD)
CTNB	RMB	1	HOLDS CARRY (0..199) TO NEXT BYTE
FACX	RMB	2	HOLDS POINTER TO FLOATING ACC
MRX	RMB	2	HOLDS POINTER TO MR
FINTRT	RMB	2	RETURN ADDRESS FOR INT FUNCTION
FCVIRT	RMB	2	RETURN ADDRESS FOR INPUT CONVERSION
FSTORET	RMB	2	RETURN ADDRESS FOR FSTORE
RETADD	RMB	2	RETURN ADDRESS
BUFERP	RMB	2	CONVERSION BUFFER POINTER
DPFLAG	RMB	1	HOLDS DECIMAL POINT COUNT FOR FCONVI
DPCOUNT	RMB	1	HOLDS DECIMAL PLACE COUNT FOR FCONVI
DIGCNT	RMB	1	HOLDS SIG DIGIT COUNT FOR FCONVI
DIGFLG	RMB	1	DIGIT FLAG FOR FCONVI
EXPOVF	RMB	1	HOLDS EXPONENT OVERFLOW FLAG
LOOPX	RMB	2	2 BYTE LOOP COUNTER
MYCHAN	RMB	1
EOFTABLE	RMB	4	TABLE OF 32 BITS, ONE FOR EACH POSSIBLE I/O CHANNEL
CHAR	RMB	1
EOFHITFLAG	RMB	1	LAST ERROR HAD EOF
STORETARGET	RMB	2	POINTER TO SCALAR/TARGET VARIABLE
COPYRIGHTSUM	RMB	1	= SUM OF COPYRIGHT MESSAGE BYTES
CONVERTLIMIT	RMB	2	LIMIT OF CONVERSION
BEGINFORMAT	RMB	2	POINTER TO 1ST BYTE OF FORMAT WITHIN "USING" STRING
	PAGE	INITIALIZATION DATA
*
*
CATBUF	RMB	2	START OF THE CAT BUFFER
CATSIZ	RMB	2	SIZE OF CAT BUFFER
CATSTRINGSIZE	RMB	2	SIZE OF CONCATENATED STRING

	IF	*>/$F0	CHECK FOR SDOS PAGE ZERO OVERFLOW
	?PAGE ZERO OVERFLOW?
	FIN
	PAGE	*** INIT AND ERROR ENTRY POINTS ***
	ORG	CODE
	JMP	INIT	TABLE FORMAT IS SPECIFIED BY BASIC VERSION 1.2 MANUAL
	JMP	IOERROR	BUT NOT MUCH OF IT IS LEFT!
	JMP	SUBFUNENTRY	SUBROUTINE OR FUNCTION ENTRY POINT
*
*	FLOATING POINT ROUTINES -- ENTRY POINTS
*		NOTE: FPTRAP IS IN LOCATION "PZBASE"
*
FLOADX	JMP	FLOAD
FSTOREX	JMP	FSTORE
FCMPX	JMP	FCMP
FNEGX	JMP	FNEG
FADDX	JMP	FADD
FSUBX	JMP	FSUB
FMULX	JMP	FMUL
FDIVX	JMP	FDIV
FCONVOX	JMP	FCONVO
FCONVIX	JMP	FCONVI
FINTX	JMP	FINT
FIXX	JMP	FIX
FIX16X	JMP	FIX16
FLOATX	JMP	FLOAT
DOLLARSIGN	FCB	'$	MONEY CHARACTER ('# FOR BRITAIN)
	PAGE		*****  O P   C O D E   A D D R E S S   T A B L E  *****
	IF	M6809
JMPTBL	SET	*+64*2	WHERE JUMP TABLE REALLY IS
OPCIN	EQU	((*-JMPTBL)&$FF)/2
	FDB	XOPCIN	STRINGS	INIT CATBUF
OPCAT	EQU	((*-JMPTBL)&$FF)/2
	FDB	XOPCAT	STRINGS	CONCATENATE A STRING TO CATBUF
OPCND	EQU	((*-JMPTBL)&$FF)/2
	FDB	XOPCND	STRINGS	PUSH CATBUF SD
OPRIGHT	EQU	((*-JMPTBL)&$FF)/2
	FDB	XOPRIGHT	STRSUB	TAKE RIGHT PART OF STRING
OPRESTR	EQU	((*-JMPTBL)&$FF)/2
	FDB	XOPRESTR	IO	POSITION A FILE TO SPECIFIED RECORD
OPWV	EQU	((*-JMPTBL)&$FF)/2
	FDB	XOPWV	IO	WRITE A NUMBER TO A FILE
OPWS	EQU	((*-JMPTBL)&$FF)/2
	FDB	XOPWS	IO	WRITE A STRING TO A FILE
OPRV	EQU	((*-JMPTBL)&$FF)/2
	FDB	XOPRV	IO	READ A NUMBER FROM A FILE
OPRS	EQU	((*-JMPTBL)&$FF)/2
	FDB	XOPRS	IO	READ A STRING FROM A FILE
OPFOR	EQU	((*-JMPTBL)&$FF)/2
	FDB	XOPFOR	FORNEXT	INITIALIZE A FOR LOOP
OPNEXT	EQU	((*-JMPTBL)&$FF)/2
	FDB	XOPNEXT	FORNEXT	DO NEXT CYCLE OF A FOR LOOP
OPTABCOL	EQU	((*-JMPTBL)&$FF)/2
	FDB	XOPTABCOL	IO	DO TAB TO NEXT PRINT COLUMN
OPINP	EQU	((*-JMPTBL)&$FF)/2
	FDB	XOPINP	INPUT	INPUT A NUMBER
OPEOF	EQU	((*-JMPTBL)&$FF)/2
	FDB	XOPEOF	IO	CHECK FOR END OF FILE
OPINL	EQU	((*-JMPTBL)&$FF)/2
	FDB	XOPINL	INPUT	INPUT A LINE FOR STRING OR NUMERIC INPUT
OPTAB	EQU	((*-JMPTBL)&$FF)/2
	FDB	XOPTAB	IO	TAB TO SPECIFIED COLUMN
OPSEQ	EQU	((*-JMPTBL)&$FF)/2
	FDB	XOPSEQ	COMPARE	STRING COMPARE FOR =
OPSNE	EQU	((*-JMPTBL)&$FF)/2
	FDB	XOPSNE	COMPARE	STRING COMPARE FOR <>
OPSLT	EQU	((*-JMPTBL)&$FF)/2
	FDB	XOPSLT	COMPARE	STRING COMPARE FOR <
OPSLE	EQU	((*-JMPTBL)&$FF)/2
	FDB	XOPSLE	COMPARE	STRING COMPARE FOR <=
OPSGT	EQU	((*-JMPTBL)&$FF)/2
	FDB	XOPSGT	COMPARE	STRING COMPARE FOR >
OPSGE	EQU	((*-JMPTBL)&$FF)/2
	FDB	XOPSGE	COMPARE	STRING COMPARE FOR >=
OPON	EQU	((*-JMPTBL)&$FF)/2
	FDB	XOPON	CONTROL	ON - GOTO OPERATOR
OPXOR	EQU	((*-JMPTBL)&$FF)/2
	FDB	XOPXOR	ARITH	XOR TOS TO TOS-1
OPOKE	EQU	((*-JMPTBL)&$FF)/2
	FDB	XOPOKE	PEEKPOKE	TOS HAS VALUE TOS-1 HAS ADDRESS
OPEEK	EQU	((*-JMPTBL)&$FF)/2
	FDB	XOPEEK	PEEKPOKE	TOS HAS ADDRESS, REPLACE BY VALUE
OPUSE	EQU	((*-JMPTBL)&$FF)/2
	FDB	XOPUSE	PRINT	PRINT USING
OPRMPT	EQU	((*-JMPTBL)&$FF)/2
	FDB	XOPRMPT	PRINT	PUT OUT THE PROMPT
OPINT	EQU	((*-JMPTBL)&$FF)/2
	FDB	XOPINT	FCN	COMPUTE INTEGER PORTION OF TOS	
OPERR	EQU	((*-JMPTBL)&$FF)/2
	FDB	XOPERR	FCN	RETURN ERROR # ON TOS	
OPOPN	EQU	((*-JMPTBL)&$FF)/2
	FDB	XOPOPN	IO	OPEN FILE SPECIFIED BY TOS SD
OPCLS	EQU	((*-JMPTBL)&$FF)/2
	FDB	XOPCLS	IO	CLOSE FILE
OPCREAT	EQU	((*-JMPTBL)&$FF)/2
	FDB	XOPCREAT	IO	CREATE FILE SPECIFIED BY TOS SD
OPCHAIN	EQU	((*-JMPTBL)&$FF)/2
	FDB	XOPCHAIN	IO	CHAIN TO ANOTHER PROGRAM
OPLFREFL	EQU	((*-JMPTBL)&$FF)/2
	FDB	XOPLFREFL	LIKE OPSETLABEL BUT SKIP 5 BYTES
OPELN	EQU	((*-JMPTBL)&$FF)/2
	FDB	XOPELN	FCN	LOAD LAST ERROR LINE NUMBER ONTO TOS
OPPI	EQU	((*-JMPTBL)&$FF)/2
	FDB	XOPPI	FCN	LOAD "3.14159..." ONTO STACK
OPFIND	EQU	((*-JMPTBL)&$FF)/2
	FDB	XOPFIND	STRINGS	FIND OCCUR OF STR TOS IN TOS-1
OPUSL	EQU	((*-JMPTBL)&$FF)/2
	FDB	XOPUSL	PRINT	SET USING STRING TO FORMAT STRING
OPJUC	EQU	((*-JMPTBL)&$FF)/2
	FDB	XOPJUC	PRINT	JUMP AROUND USING STRING
OPINIT	EQU	((*-JMPTBL)&$FF)/2
	FDB	XOPINIT	INIT	INITIALIZE INLINE ADDRESS TO BYTE STRING
OPZCHN	EQU	((*-JMPTBL)&$FF)/2
	FDB	XOPZCHN	IO	ZERO THE CHANNEL #
OPONG	EQU	((*-JMPTBL)&$FF)/2
	FDB	XOPONG	CONTROL	DO "ON ... GOSUB"
OPDEL	EQU	((*-JMPTBL)&$FF)/2
	FDB	XOPDEL	IO	DELETE FILE NAMED TOS
OPREN	EQU	((*-JMPTBL)&$FF)/2
	FDB	XOPREN	IO	RENAME FILE NAMED TOS-1 TO TOS
OPSSL	EQU	((*-JMPTBL)&$FF)/2
	FDB	XOPSSL	STRINGS	SET STRING LENGTH OF SD AT TOS-1 TO TOS
OPSTORE	EQU	((*-JMPTBL)&$FF)/2
	FDB	XOPSTD	STORE	STORE TOS AT INLINE ADDRESS
OPSGN	EQU	((*-JMPTBL)&$FF)/2
	FDB	XOPSGN	FCN	RETURN SIGN OF TOS
OPASM	EQU	((*-JMPTBL)&$FF)/2
	FDB	XOPASM	ASY	ENTER ASSEMBLY CODE
OPLBOOL	EQU	((*-JMPTBL)&$FF)/2
	FDB	XOPLBOOL	LOAD: LOAD BOOLEAN VALUE OF FLAG
OPPRUS	EQU	((*-JMPTBL)&$FF)/2	PRINT REST OF USING STRING
	FDB	XOPPRUS
OPSETLABEL	EQU	((*-JMPTBL)&$FF)/2
	FDB	XOPSETLABEL	SIMILAR TO OPLINE
OPMAXLEN	EQU	((*-JMPTBL)&$FF)/2
	FDB	XOPMAXLEN	SIMILAR TO OPLEN
OPSYSCALL1ARG	EQU	((*-JMPTBL)&$FF)/2
	FDB	XOPSYSCALL1ARG	SYSCALL 1 ARGUMENT
OPSYSCALL2ARG	EQU	((*-JMPTBL)&$FF)/2
	FDB	XOPSYSCALL2ARG	SYSCALL 2 ARGUMENTS
OPSYSCALL3ARG	EQU	((*-JMPTBL)&$FF)/2
	FDB	XOPSYSCALL3ARG	SYSCALL 3 ARGUMENTS
OPSYSCALL4ARG	EQU	((*-JMPTBL)&$FF)/2
	FDB	XOPSYSCALL4ARG	SYSCALL 4 ARGUMENTS
OPCOPYRIGHT	EQU	((*-JMPTBL)&$FF)/2
	FDB	XOPCOPYRIGHT	STRING PUSH COPYRIGHT MESSAGE STRING DESCRIPTOR
OPEXTENDED	EQU	((*-JMPTBL)&$FF)/2
	FDB	XOPEXTENDED	2 BYTE OPCODE: NEEDS FURTHER DECODING
OPSUBRET	EQU	((*-JMPTBL)&$FF)/2
	FDB	XOPSUBRET	CONTROL:	RETURN FROM PARAMETERIZED SUBROUTINE
OPFNCALL	EQU	((*-JMPTBL)&$FF)/2
	FDB	XOPFNCALL	CONTROL	CALL AN ASSEMBLY LANGUAGE FUNCTION
OPLBINT	EQU	((*-JMPTBL)&$FF)/2
	FDB	XOPLBINT	LOAD: LOAD CONSTANT IN RANGE 10-255 (1 BYTE)
OPEXITLOOP	EQU	((*-JMPTBL)&$FF)/2
	FDB	XOPEXITLOOP	CONTROL: PASS CONTROL TO STMT PAST "NEXT"
OPTRP	EQU	((*-JMPTBL)&$FF)/2
	FDB	XOPTRP	CONTROL: ON ERROR GOTO ...
	IF	*>>JMPTBL
	?MAIN JUMP TABLE TOO LARGE? CUT DOWN NUMBER OF 1 BYTE OPCODES !!
	FIN
	FIN
	PAGE
JMPTBL	SET	*	ADDRESS OF POINTER TO "OPLSMI 0" OPCODE ROUTINE
OPLSMI	EQU	(*-JMPTBL)/2
	FDB	XOPLSMI	LOAD	LOAD SMALL INTEGER (0)
	FDB	XOPLSMI	LOAD	LOAD SMALL INTEGER (1)
	FDB	XOPLSMI	LOAD	LOAD SMALL INTEGER (2)
	FDB	XOPLSMI	LOAD	LOAD SMALL INTEGER (3)
	FDB	XOPLSMI	LOAD	LOAD SMALL INTEGER (4)
	FDB	XOPLSMI	LOAD	LOAD SMALL INTEGER (5)
	FDB	XOPLSMI	LOAD	LOAD SMALL INTEGER (6)
	FDB	XOPLSMI	LOAD	LOAD SMALL INTEGER (7)
	FDB	XOPLSMI	LOAD	LOAD SMALL INTEGER (8)
	FDB	XOPLSMI	LOAD	LOAD SMALL INTEGER (9)
OPLOAD	EQU	(*-JMPTBL)/2
	FDB	XOPLOAD	LOAD	LOAD VALUE AT IN LINE ADDRESS
OPLV	EQU	(*-JMPTBL)/2
	FDB	XOPLV	LOAD	LOAD VALUE USING ADDRESS ON TOS
OPSESCALAR	EQU	(*-JMPTBL)/2
	FDB	XOPSESCALAR	STORE: STORE EXTENDED SCALAR
OPLINT	EQU	(*-JMPTBL)/2
	FDB	XOPLINT	LOAD	LOAD 2 BYTE INTEGER
OPLESCALAR	EQU	(*-JMPTBL)/2
	FDB	XOPLESCALAR	LOAD	LOAD EXTENDED SCALAR
OPLFI	EQU	(*-JMPTBL)/2
	FDB	XOPLFI	LOAD	LOAD FLOATING INLINE CONSTANT
OPLDB	EQU	(*-JMPTBL)/2
	FDB	XOPLDB	LOAD	LOAD BYTE USING SD ON TOS
OPDUP	EQU	(*-JMPTBL)/2
	FDB	XOPDUP	LOAD	DUPLICATE TOS
OPLSD	EQU	(*-JMPTBL)/2
	FDB	XOPLSD	STRINGS	PUSH STRING DESCRIPTOR
OPLSC	EQU	(*-JMPTBL)/2
	FDB	XOPLSC	STRINGS	PUSH STRING CONSTANT
OPLEN	EQU	(*-JMPTBL)/2
	FDB	XOPLEN	STRINGS	LOAD LENGTH OF INLINE STRING ADDRESS
OPSS1	EQU	(*-JMPTBL)/2
	FDB	XOPSS1	STRSUB	DO SINGLE STRING SUBSCRIPT
OPSS2	EQU	(*-JMPTBL)/2
	FDB	XOPSS2	STRSUB	DO DOUBLE SUBSCRIPT ON STRING
OPVSA	EQU	(*-JMPTBL)/2
	FDB	XOPVSA	ARYSUB DO SUBSCRIPT ON VECTOR AND PUSH ADDRESS
OPVSV	EQU	(*-JMPTBL)/2
	FDB	XOPVSV	ARYSUB DO SUBSCRIPT ON VECTOR AND PUSH VALUE
OPVSS	EQU	(*-JMPTBL)/2
	FDB	XOPVSS	ARYSUB DO SUBSCRIPT ON VECTOR AND STORE TOS
OPVPA	EQU	(*-JMPTBL)/2
	FDB	XOPVPA	ARYSUB DO SUBSCRIPT ON VECTOR PARAMETER AND PUSH ADDRESS
OPASA	EQU	(*-JMPTBL)/2
	FDB	XOPASA	ARYSUB DO SUBSCRIPT ON ARRAY AND PUSH ADDRESS
OPASV	EQU	(*-JMPTBL)/2
	FDB	XOPASV	ARYSUB DO SUBSCRIPT ON ARRAY AND PUSH VALUE
OPASS	EQU	(*-JMPTBL)/2
	FDB	XOPASS	ARYSUB DO SUBSCRIPT ON ARRAY AND STORE TOS
OPAPA	EQU	(*-JMPTBL)/2
	FDB	XOPAPA	ARYSUB DO SUBSCRIPT ON ARRAY PARAMETER AND PUSH ADDRESS
OPST	EQU	(*-JMPTBL)/2
	FDB	XOPST	STORE	STORE TOS USING TOS-1
OPSTS	EQU	(*-JMPTBL)/2
	FDB	XOPSTS	STORE	STORE STRING ON TOS TO TOS-1
OPSTB	EQU	(*-JMPTBL)/2
	FDB	XOPSTB	STORE	STORE VALUE ON TOS INTO STRING TOS-1
OPADD	EQU	(*-JMPTBL)/2
	FDB	XOPADD	ARITH	ADD TOS TO TOS-1
OPSUB	EQU	(*-JMPTBL)/2
	FDB	XOPSUB	ARITH	SUB TOS FROM TOS-1
OPNEG	EQU	(*-JMPTBL)/2
	FDB	XOPNEG	ARITH	NEGATE TOS
OPMUL	EQU	(*-JMPTBL)/2
	FDB	XOPMUL	ARITH	MULTIPLY TOS BY TOS-1
OPDIV	EQU	(*-JMPTBL)/2
	FDB	XOPDIV	ARITH	DIVIDE TOS INTO TOS-1
OPAND	EQU	(*-JMPTBL)/2
	FDB	XOPAND	ARITH	AND TOS TO TOS-1
OPIOR	EQU	(*-JMPTBL)/2
	FDB	XOPIOR	ARITH	INCLUSIVE OR TOS TO TOS-1
OPSHF	EQU	(*-JMPTBL)/2
	FDB	XOPSHF	ARITH	SHIFT TOS-1 BY TOS
OPCOM	EQU	(*-JMPTBL)/2
	FDB	XOPCOM	ARITH	COMPLEMENT TOS
OPEQ	EQU	(*-JMPTBL)/2
	FDB	XOPEQ	COMPARE	COMPARE TOS TO TOS-1 FOR =, SET FLAG
OPNE	EQU	(*-JMPTBL)/2
	FDB	XOPNE	COMPARE	TOS : TOS-1 FOR <>
OPLT	EQU	(*-JMPTBL)/2
	FDB	XOPLT	COMPARE	TOS : TOS-1 FOR <
OPLE	EQU	(*-JMPTBL)/2
	FDB	XOPLE	COMPARE	TOS : TOS-1 FOR <=
OPGE	EQU	(*-JMPTBL)/2
	FDB	XOPGE	COMPARE	TOS : TOS-1 FOR >=
OPGT	EQU	(*-JMPTBL)/2
	FDB	XOPGT	COMPARE	TOS : TOS-1 FOR >
OPBF	EQU	(*-JMPTBL)/2
	FDB	XOPBF	CONTROL	BRANCH IF FLAG IS FALSE
OPBT	EQU	(*-JMPTBL)/2
	FDB	XOPBT	CONTROL	BRANCH IF FLAG IS TRUE
OPINV	EQU	(*-JMPTBL)/2
	FDB	XOPINV	CONTROL	COMPLEMENT THE FLAG
OPJMP	EQU	(*-JMPTBL)/2
	FDB	XOPJMP	CONTROL	UNCONDITIONAL BRANCH
OPGSB	EQU	(*-JMPTBL)/2
	FDB	XOPGSB	CONTROL	GO TO A SUBROUTINE
OPRET	EQU	(*-JMPTBL)/2
	FDB	XOPRET	CONTROL	RETURN FROM A SUBROUTINE
OPSTP	EQU	(*-JMPTBL)/2
	FDB	XOPSTP	CONTROL	I QUIT...
OPLINE	EQU	(*-JMPTBL)/2
	FDB	XOPLINE	CONTROL	SET LINE NUMBER
OPCALL	EQU	(*-JMPTBL)/2
	FDB	XOPCALL	CONTROL	CALL AN ASSEMBLY LANGUAGE SUBROUTINE
OPPV	EQU	(*-JMPTBL)/2
	FDB	XOPPV	PRINT	PRINT VALUE ON TOS
OPPCR	EQU	(*-JMPTBL)/2
	FDB	XOPPCR	PRINT	PRINT A CR
OPPS	EQU	(*-JMPTBL)/2
	FDB	XOPPS	PRINT	PRINT STRING POINTED TO BY TOS SD
OPPSP	EQU	(*-JMPTBL)/2
	FDB	XOPPSP	PRINT	PRINT A SPACE
OPINS	EQU	(*-JMPTBL)/2
	FDB	XOPINS	STRINGS	INPUT A STRING
OPCHNL	EQU	(*-JMPTBL)/2
	FDB	XOPCHNL	IO	SET CHANNEL FROM TOS
	PAGE
	IF	M6800!M6801
OPCIN	EQU	(*-JMPTBL)/2
	FDB	XOPCIN	STRINGS	INIT CATBUF
OPCAT	EQU	(*-JMPTBL)/2
	FDB	XOPCAT	STRINGS	CONCATENATE A STRING TO CATBUF
OPCND	EQU	(*-JMPTBL)/2
	FDB	XOPCND	STRINGS	PUSH CATBUF SD
OPRIGHT	EQU	(*-JMPTBL)/2
	FDB	XOPRIGHT	STRSUB	TAKE RIGHT PART OF STRING
OPRESTR	EQU	(*-JMPTBL)/2
	FDB	XOPRESTR	IO	POSITION A FILE TO SPECIFIED RECORD
OPWV	EQU	(*-JMPTBL)/2
	FDB	XOPWV	IO	WRITE A NUMBER TO A FILE
OPWS	EQU	(*-JMPTBL)/2
	FDB	XOPWS	IO	WRITE A STRING TO A FILE
OPRV	EQU	(*-JMPTBL)/2
	FDB	XOPRV	IO	READ A NUMBER FROM A FILE
OPRS	EQU	(*-JMPTBL)/2
	FDB	XOPRS	IO	READ A STRING FROM A FILE
OPFOR	EQU	(*-JMPTBL)/2
	FDB	XOPFOR	FORNEXT	INITIALIZE A FOR LOOP
OPNEXT	EQU	(*-JMPTBL)/2
	FDB	XOPNEXT	FORNEXT	DO NEXT CYCLE OF A FOR LOOP
OPTABCOL	EQU	(*-JMPTBL)/2
	FDB	XOPTABCOL	IO	DO TAB TO NEXT PRINT COLUMN
OPINP	EQU	(*-JMPTBL)/2
	FDB	XOPINP	INPUT	INPUT A NUMBER
OPEOF	EQU	(*-JMPTBL)/2
	FDB	XOPEOF	IO	CHECK FOR END OF FILE
OPINL	EQU	(*-JMPTBL)/2
	FDB	XOPINL	INPUT	INPUT A LINE FOR STRING OR NUMERIC INPUT
OPTAB	EQU	(*-JMPTBL)/2
	FDB	XOPTAB	IO	TAB TO SPECIFIED COLUMN
OPSEQ	EQU	(*-JMPTBL)/2
	FDB	XOPSEQ	COMPARE	STRING COMPARE FOR =
OPSNE	EQU	(*-JMPTBL)/2
	FDB	XOPSNE	COMPARE	STRING COMPARE FOR <>
OPSLT	EQU	(*-JMPTBL)/2
	FDB	XOPSLT	COMPARE	STRING COMPARE FOR <
OPSLE	EQU	(*-JMPTBL)/2
	FDB	XOPSLE	COMPARE	STRING COMPARE FOR <=
OPSGT	EQU	(*-JMPTBL)/2
	FDB	XOPSGT	COMPARE	STRING COMPARE FOR >
OPSGE	EQU	(*-JMPTBL)/2
	FDB	XOPSGE	COMPARE	STRING COMPARE FOR >=
OPON	EQU	(*-JMPTBL)/2
	FDB	XOPON	CONTROL	ON - GOTO OPERATOR
OPXOR	EQU	(*-JMPTBL)/2
	FDB	XOPXOR	ARITH	XOR TOS TO TOS-1
OPOKE	EQU	(*-JMPTBL)/2
	FDB	XOPOKE	PEEKPOKE	TOS HAS VALUE TOS-1 HAS ADDRESS
OPEEK	EQU	(*-JMPTBL)/2
	FDB	XOPEEK	PEEKPOKE	TOS HAS ADDRESS, REPLACE BY VALUE
OPUSE	EQU	(*-JMPTBL)/2
	FDB	XOPUSE	PRINT	PRINT USING
OPRMPT	EQU	(*-JMPTBL)/2
	FDB	XOPRMPT	PRINT	PUT OUT THE PROMPT
OPINT	EQU	(*-JMPTBL)/2
	FDB	XOPINT	FCN	COMPUTE INTEGER PORTION OF TOS	
OPERR	EQU	(*-JMPTBL)/2
	FDB	XOPERR	FCN	RETURN ERROR # ON TOS	
OPOPN	EQU	(*-JMPTBL)/2
	FDB	XOPOPN	IO	OPEN FILE SPECIFIED BY TOS SD
OPCLS	EQU	(*-JMPTBL)/2
	FDB	XOPCLS	IO	CLOSE FILE
OPCREAT	EQU	(*-JMPTBL)/2
	FDB	XOPCREAT	IO	CREATE FILE SPECIFIED BY TOS SD
OPCHAIN	EQU	(*-JMPTBL)/2
	FDB	XOPCHAIN	IO	CHAIN TO ANOTHER PROGRAM
OPLFREFL	EQU	(*-JMPTBL)/2
	FDB	XOPLFREFL	LIKE OPSETLABEL BUT SKIP 5 BYTES
OPELN	EQU	(*-JMPTBL)/2
	FDB	XOPELN	FCN	LOAD LAST ERROR LINE NUMBER ONTO TOS
OPPI	EQU	(*-JMPTBL)/2
	FDB	XOPPI	FCN	LOAD "3.14159..." ONTO STACK
OPFIND	EQU	(*-JMPTBL)/2
	FDB	XOPFIND	STRINGS	FIND OCCUR OF STR TOS IN TOS-1
OPUSL	EQU	(*-JMPTBL)/2
	FDB	XOPUSL	PRINT	SET USING STRING TO FORMAT STRING
OPJUC	EQU	(*-JMPTBL)/2
	FDB	XOPJUC	PRINT	JUMP AROUND USING STRING
OPINIT	EQU	(*-JMPTBL)/2
	FDB	XOPINIT	INIT	INITIALIZE INLINE ADDRESS TO BYTE STRING
OPZCHN	EQU	(*-JMPTBL)/2
	FDB	XOPZCHN	IO	ZERO THE CHANNEL #
OPONG	EQU	(*-JMPTBL)/2
	FDB	XOPONG	CONTROL	DO "ON ... GOSUB"
OPDEL	EQU	(*-JMPTBL)/2
	FDB	XOPDEL	IO	DELETE FILE NAMED TOS
OPREN	EQU	(*-JMPTBL)/2
	FDB	XOPREN	IO	RENAME FILE NAMED TOS-1 TO TOS
OPSSL	EQU	(*-JMPTBL)/2
	FDB	XOPSSL	STRINGS	SET STRING LENGTH OF SD AT TOS-1 TO TOS
OPSTORE	EQU	(*-JMPTBL)/2
	FDB	XOPSTD	STORE	STORE TOS AT INLINE ADDRESS
OPSGN	EQU	(*-JMPTBL)/2
	FDB	XOPSGN	FCN	RETURN SIGN OF TOS
OPASM	EQU	(*-JMPTBL)/2
	FDB	XOPASM	ASY	ENTER ASSEMBLY CODE
OPLBOOL	EQU	(*-JMPTBL)/2
	FDB	XOPLBOOL	LOAD: LOAD BOOLEAN VALUE OF FLAG
OPPRUS	EQU	(*-JMPTBL)/2	PRINT REST OF USING STRING
	FDB	XOPPRUS
OPSETLABEL	EQU	(*-JMPTBL)/2
	FDB	XOPSETLABEL	SIMILAR TO OPLINE
OPMAXLEN	EQU	(*-JMPTBL)/2
	FDB	XOPMAXLEN	SIMILAR TO OPLEN
OPSYSCALL1ARG	EQU	(*-JMPTBL)/2
	FDB	XOPSYSCALL1ARG	SYSCALL 1 ARGUMENT
OPSYSCALL2ARG	EQU	(*-JMPTBL)/2
	FDB	XOPSYSCALL2ARG	SYSCALL 2 ARGUMENTS
OPSYSCALL3ARG	EQU	(*-JMPTBL)/2
	FDB	XOPSYSCALL3ARG	SYSCALL 3 ARGUMENTS
OPSYSCALL4ARG	EQU	(*-JMPTBL)/2
	FDB	XOPSYSCALL4ARG	SYSCALL 4 ARGUMENTS
OPCOPYRIGHT	EQU	(*-JMPTBL)/2
	FDB	XOPCOPYRIGHT	STRING PUSH COPYRIGHT MESSAGE STRING DESCRIPTOR
OPEXTENDED	EQU	(*-JMPTBL)/2
	FDB	XOPEXTENDED	2 BYTE OPCODE: NEEDS FURTHER DECODING
OPSUBRET	EQU	(*-JMPTBL)/2
	FDB	XOPSUBRET	CONTROL:	RETURN FROM PARAMETERIZED SUBROUTINE
OPFNCALL	EQU	(*-JMPTBL)/2
	FDB	XOPFNCALL	CONTROL	CALL AN ASSEMBLY LANGUAGE FUNCTION
OPLBINT	EQU	(*-JMPTBL)/2
	FDB	XOPLBINT	LOAD: LOAD CONSTANT IN RANGE 10-255 (1 BYTE)
OPEXITLOOP	EQU	(*-JMPTBL)/2
	FDB	XOPEXITLOOP	CONTROL: PASS CONTROL TO STMT PAST "NEXT"
OPTRP	EQU	(*-JMPTBL)/2
	FDB	XOPTRP	CONTROL: ON ERROR GOTO ...
	IF	(*-JMPTBL)/2>>$80
	?MAIN JUMP TABLE TOO LARGE?
	FIN		FIX BY MOVING SOME MORE OPS TO THE EXTENDED TABLE
	FIN	M6800!M6801
	PAGE	***** E X T E N D E D   O P   J U M P   T A B L E   *****
EXTENDEDJMPTBL	EQU	*
OPATN	EQU	OPEXTENDED*256+(*-EXTENDEDJMPTBL)/2
	FDB	XOPATN	FCN	COMPUTE ARCTANGENT OF TOS	
OPSIN	EQU	OPEXTENDED*256+(*-EXTENDEDJMPTBL)/2
	FDB	XOPSIN	FCN	COMPUTE SINE OF TOS	
OPCOS	EQU	OPEXTENDED*256+(*-EXTENDEDJMPTBL)/2
	FDB	XOPCOS	FCN	COMPUTE COSINE OF TOS	
OPLOG	EQU	OPEXTENDED*256+(*-EXTENDEDJMPTBL)/2
	FDB	XOPLOG	FCN	COMPUTE NATURAL LOG OF TOS	
OPEXP	EQU	OPEXTENDED*256+(*-EXTENDEDJMPTBL)/2
	FDB	XOPEXP	FCN	COMPUTE E RAISED TO TOS POWER	
OPSQR	EQU	OPEXTENDED*256+(*-EXTENDEDJMPTBL)/2
	FDB	XOPSQR	FCN	COMPUTE SQUARE ROOT OF TOS	
OPRND	EQU	OPEXTENDED*256+(*-EXTENDEDJMPTBL)/2
	FDB	XOPRND	FCN	COMPUTE RANDOM # USING TOS	
OPABS	EQU	OPEXTENDED*256+(*-EXTENDEDJMPTBL)/2
	FDB	XOPABS	FCN	COMPUTE ABSOLUTE VALUE OF TOS	
OPDBG	EQU	OPEXTENDED*256+(*-EXTENDEDJMPTBL)/2
	FDB	XOPDBG	IO	ENTER DEBUGGER
OPOWER	EQU	OPEXTENDED*256+(*-EXTENDEDJMPTBL)/2
	FDB	XOPOWER	FCN	TOS-1 IS EXPONENTIATED BY TOS
OPERRST	EQU	OPEXTENDED*256+(*-EXTENDEDJMPTBL)/2
	FDB	XOPERRST	ERROR	ERROR STMT
OPSETSEED	EQU	OPEXTENDED*256+(*-EXTENDEDJMPTBL)/2
	FDB	XOPSETSEED	ASSIGN SET RANDOM SEED
OPCOL	EQU	OPEXTENDED*256+(*-EXTENDEDJMPTBL)/2
	FDB	XOPCOL	FCN	LOAD CURRENT COL COUNT ONTO TOS
OPGPOP	EQU	OPEXTENDED*256+(*-EXTENDEDJMPTBL)/2
	FDB	XOPGPOP	CONTROL	POP OR REAM THE GOSUB STACK BY TOS
OPDAT	EQU	OPEXTENDED*256+(*-EXTENDEDJMPTBL)/2
	FDB	XOPDAT	STRINGS	RETURNS TOS SD FOR DATE
OPTIM	EQU	OPEXTENDED*256+(*-EXTENDEDJMPTBL)/2
	FDB	XOPTIM	STRINGS	RETURNS TOS SD FOR TIME
OPNUM	EQU	OPEXTENDED*256+(*-EXTENDEDJMPTBL)/2
	FDB	XOPNUM	PRINT	CONVERT TOS VALUE TO STRING
OPNUMF	EQU	OPEXTENDED*256+(*-EXTENDEDJMPTBL)/2
	FDB	XOPNUMF	PRINT	CONVERT TOS VALUE TO STRING USING FORMAT
OPVAL	EQU	OPEXTENDED*256+(*-EXTENDEDJMPTBL)/2
	FDB	XOPVAL	PRINT	CONVERT TOS STRING TO VALUE
OPTAN	EQU	OPEXTENDED*256+(*-EXTENDEDJMPTBL)/2
	FDB	XOPTAN	FCN	COMPUTE TANGENT OF TOS
OPPOLY	EQU	OPEXTENDED*256+(*-EXTENDEDJMPTBL)/2
	FDB	XOPPOLY	FCN	EVALUATE INLINE POLYNOMIAL
OPHEX	EQU	OPEXTENDED*256+(*-EXTENDEDJMPTBL)/2
	FDB	XOPHEX	STRINGS	CONVERT TOS INTEGER TO STRING
OPGOELN	EQU	OPEXTENDED*256+(*-EXTENDEDJMPTBL)/2
	FDB	XOPGOELN	"GOTO ELN" OPCODE
OPUPPERC	EQU	OPEXTENDED*256+(*-EXTENDEDJMPTBL)/2
	FDB	XOPUPPERC	CONVERT STRING TO UPPERCASE
OPLOWERC	EQU	OPEXTENDED*256+(*-EXTENDEDJMPTBL)/2
	FDB	XOPLOWERC	CONVERT STRING TO LOWERCASE
OPEXIT	EQU	OPEXTENDED*256+(*-EXTENDEDJMPTBL)/2
	FDB	XOPEXIT
OPLENVECTOR	EQU	OPEXTENDED*256+(*-EXTENDEDJMPTBL)/2
	FDB	XOPLENVECTOR	SUBSCRIPTS:	PUSH DIM'D LENGTH OF VECTOR
OPROWSARRAY	EQU	OPEXTENDED*256+(*-EXTENDEDJMPTBL)/2
	FDB	XOPROWSARRAY	SUBSCRIPTS:	PUSH DIM'D NUMBER OF ROWS
OPCOLSARRAY	EQU	OPEXTENDED*256+(*-EXTENDEDJMPTBL)/2
	FDB	XOPCOLSARRAY	SUBSCRIPTS:	PUSH DIM'D NUMBER OF COLUMNS
OPFUNRET	EQU	OPEXTENDED*256+(*-EXTENDEDJMPTBL)/2
	FDB	XOPFUNRET	CONTROL: RETURN FROM A PARAMETERIZED FUNCTION
OPCHR	EQU	OPEXTENDED*256+(*-EXTENDEDJMPTBL)/2
	FDB	XOPCHR	STRING FN: RETURN SINGLE BYTE STRING
OPERRCAUSE	EQU	OPEXTENDED*256+(*-EXTENDEDJMPTBL)/2
	FDB	XOPERRCAUSE	CONTROL:	CAUSE A SPECIFIED ERROR CODE
OPSSA	EQU	OPEXTENDED*256+(*-EXTENDEDJMPTBL)/2
	FDB	XOPSSA	STRINGS: DO STRING ARRAY SUBSCRIPT
OPSAINIT	EQU	OPEXTENDED*256+(*-EXTENDEDJMPTBL)/2
	FDB	XOPSAINIT	STRINGS: INITIALIZE STRING ARRAY
	IF	(*-EXTENDEDJMPTBL)>/$80
	?EXTENDED JUMP TABLE TOO LARGE?
	FIN
	PAGE
COPYRIGHT	EQU	*
	FCC	"BASIC Runtime Package Version 1.4j"
	FCB	$0D
	FCC	"Copyright (C) 1977 Software Dynamics"
COPYRIGHTEND	EQU	*
	PAGE	*****  I N T E R P E T E R   L O O P S  *****
*
*	TWO BYTE (EXTENDED) OPCODE
*		SECOND BYTE CONTAINS SECONDARY OPCODE
*		PRIMARILY USED FOR RARELY INVOKED FUNCTIONS
*
XOPEXTENDED	EQU	*
	IF	M6800!M6801
	LDB	[BPC]	FETCH 2ND BYTE OF OPCODE
	ASLB		DOUBLE TO MAKE JUMP TABLE INDEX
	LDA	#EXTENDEDJMPTBL/256
	STD	TEMPX	(ASSERT: 2ND BYTE <= 127)
	LDX	TEMPX
	LDX	EXTENDEDJMPTBL&$FF,X
	JMP	,X
	ELSE	(M6809)
	LDB	,X	GET 2ND BYTE OF OPCODE
	ASLB		DOUBLE TO MAKE WORD INDEX
	LDU	#EXTENDEDJMPTBL
	JMP	[B,U]	ASSERT: (B) <= 126
	FIN
	PAGE
	IF	M6800!M6801
PL2PC1	LDB	#RSESIZ*2	PULL 2 VALUE STACK ENTRIES, BUMP BPC BY ONE
	JMP	PL1PC1A
PL1PC1	LDB	#RSESIZ	PULL 1 VALUE STACK ENTRY, BUMP BPC BY ONE
PL1PC1A	STS	TEMPX
	ADDB	TEMPX+1
	STB	TEMPX+1
	BCC	PL1PLA
	INC	TEMPX
PL1PLA	LDS	TEMPX
NTRPT1	LDX	BPC	FINISHED PROCESSING ONE BYTE OP, EXECUTE NEXT OP
NTRPTX	LDB	,X	USE (X) AS NEW BPC
	INX		ADVANCE BPC PAST OPCODE BYTE
	STX	BPC
	ASLB		CONVERT TO JUMP TABLE INDEX
	BCS	XOPLSCALAR	B/MSB IS SET, MUST BE SCALAR REFERENCE
NTRPTJ	STB	JMPADD+1	< 256 BYTES INTO JUMP TABLE, FORM POINTER
	LDX	JMPADD	FETCH POINTER TO JUMP TABLE ENTRY
	LDX	JMPTBL&$FF,X	FETCH ADDRESS OF OPCODE EXECUTION ROUTINE
	JMP	,X	JUMP TO EXECUTION ROUTINE
	PAGE
	ELSE	(M6809)
	PAGE
PL2PC1	LEAS	RSESIZ*2,S	POP 2 VALUE STACK ENTRIES AND DO NEXT POPCODE
NTRPT0	LDX	BPC	GRAB POINTER TO NEXT OPCODE BYTE
	LDB	,X+	FETCH OP, ADVANCE POINTER
	STX	BPC	UPDATE "BASIC" PROGRAM COUNTER
	ASLB		DOUBLE TO OBTAIN WORD INDEX
	BCS	XOPLSCALAR	B/ SCALAR REFERENCE
	LDU	#JMPTBL	BRANCH TO OPCODE ROUTINE
	JMP	[B,U]
PL1PC1	LEAS	RSESIZ,S	POP 1 VALUE STACK ITEM AND DO NEXT OPCODE
NTRPT1	LDX	BPC	FINISHED WITH ONE BYTE OPCODE, DO NEXT OPCODE
NTRPTX	LDB	,X+	USE (X) AS NEW BPC
	STX	BPC
	ASLB
	BCS	XOPLSCALAR
NTRPTJ	LDU	#JMPTBL
	JMP	[B,U]
	FIN
	PAGE
	IF	M6800!M6801
PL1PC2	LDB	#RSESIZ	PULL 1 VALUE STACK ENTRY, BMP PC BY 2
	STS	TEMPX
	ADDB	TEMPX+1
	STB	TEMPX+1
	BCC	PL1PC2A
	INC	TEMPX
PL1PC2A	LDS	TEMPX
NTRPT2	LDX	BPC	BUMP BPC PAST 2 BYTE OPCODE AND EXECUTE NEXT
NTRPT2X	; (X) CONTAINS ADDRESS OF OPCODE+1: ADVANCE PAST 2 BYTE OPCODE
NTRINX	INX		USE (X)+1 AS NEW BPC
	LDB	,X	INTERPRET STARTING AT (X)
	INX
	STX	BPC
	ASLB
	BCS	XOPLSCALAR
	STB	JMPADD+1
	LDX	JMPADD
	LDX	JMPTBL&$FF,X
	JMP	,X
*
PL2PC3	LDB	#RSESIZ*2	PULL 2 VALUE STACK ENTRIES, BUMP BPC BY THREE
	JMP	PLAPC3
PL1PC3	LDB	#RSESIZ	PULL 1 VALUE STACK ENTRY, BUMP BPC BY THREE
PLAPC3	STS	TEMPX	PULL (A)/6 VALUE STACK ENTRIES, BUMP BPC BY THREE
	ADDB	TEMPX+1
	STB	TEMPX+1
	BCC	PL1PLB
	INC	TEMPX
PL1PLB	LDS	TEMPX
NTRPT3X	; (X) CONTAINS ADDRESS OF OPCODE+1: ADVANCE PAST 3 BYTE OPCODE
NTRPT3	LDB	#2	BUMP BPC PAST 3 BYTE OPCODE AND EXECUTE NEXT
NTRADB	ADDB	BPC+1	ADD (B) TO BPC AND EXECUTE NEXT
	STB	BPC+1
	BCC	NTRPT0
	INC	BPC
NTRPT0	LDX	BPC	USE BPC AS ADDRESS OF NEXT INSTRUCTION TO EXECUTE
	LDB	,X	ASSERT: (X)=BPC, USE AS NEXT OP ADDRESS
	INX
	STX	BPC
	ASLB
	BCC	NTRPTJ	B/ NOT SCALAR REFERENCE, GO TO ROUTINE
	PAGE
	ELSE	(M6809)
	PAGE
PC1PC2	LEAS	RSESIZ,S	PULL 1 VALUE STACK ENTRY, ADVANCE BPC PAST 2 BYTE OPCODE
NTRPT2	LDX	BPC	ADVANCE BPC PAST TWO BYTE OPCODE
NTRINX	; USE (X)+1 AS NEXT OPCODE ADDRESS
NTRPT2X	LDD	,X++	FETCH NEXT OPCODE BYTE TO (B) [IGNORE (A)]
	STX	BPC
	ASLB
	BCS	XOPLSCALAR
	LDU	#JMPTBL
	JMP	[B,U]

PL2PC3	LEAS	RSESIZ,S	PULL 2 VALUE STACK ENTRIES, ADVANCE BPC PAST 3 BYTE OPCODE
PL1PC3	LEAS	RSESIZ,S	PULL 1 VALUE STACK ENTRY, ADVANCE BPC PAST 3 BYTE OPCODE
NTRPT3	LDX	BPC	ADVANCE BPC PAST 3 BYTE OPCODE
NTRPT3X	; (X) CONTAINS ADDRESS OF OPCODE+1: ADVANCE PAST 3 BYTE OPCODE
	LEAX	2,X
	LDB	,X+	GET NEXT OPCODE BYTE
	STX	BPC
	ASLB
	BCS	XOPLSCALAR	B/ SCALAR REFERENCE
	LDU	#JMPTBL	GO TO ROUTINE
	JMP	[B,U]

NTRADB	LDX	BPC	ADVANCE BPC PAST (B)+1 BYTE OPCODE
	CLRA		EXTEND (B) TO 16 BITS
	LEAX	D,X
	LDB	,X+	GET NEXT OPCODE BYTE
	STX	BPC
	ASLB
	BCC	NTRPTJ	B/ NOT SCALAR REFERENCE
	FIN
	PAGE	SHORT LOAD AND STORES
*	LOAD SCALAR--OPCODE CONTAINS SCALAR NUMBER (0..63) TO
*	LOAD (OR STORE).  IF OPCODE IS STORE, CALL XOPSSCALAR
*
XOPLSCALAR	EQU	*
	IF	M6800!M6801
	TBA		C=?, A=/<OP>NNNNNNN0/
	ASLA		C=OP, A=/NNNNNN00/
	BCS	XOPSSCALAR	BRANCH ON OP (1--> STORE!)
	ABA		SINCE OP=0, A=6*N
	TAB
	LDA	#0	CARRY NOT CHANGED
	ROLA		A,B=N*6
XOPLSCALAR1
	ADDD	VARTABLE	POINTER TO THING TO LOAD, -$80
	STD	TEMPX
	LDX	TEMPX
	ELSE	(M6809)
	PSHB		C=?, A=/<OP>NNNNNN0/
	ASLB		C=OP, A=/NNNNNN00/
	BCS	XOPSSCALAR	B/ OPCODE = "STORE SCALAR"
	ADDB	,S+	(CARRY,B) = SCALAR NUMBER * 6
	LDA	#0	CAPTURE CARRY BIT IN (A)
	ROLA
XOPLSCALAR1	LDX	VARTABLE	ADD BASE OF SCALAR VARIABLES
	LEAX	D,X
	FIN
	LDD	VFLT5,X	GET LAST BYTE PAIR
	PSHD		MUST PUSH 16 BITS MINIMUM
	LDA	VTYPE,X	WHAT ARE YOU?
	BEQ	XOPLSCALAR2	STEP THIS WAY MR. INTEGER
	IF	M6800
	LDB	VFLT4,X	FLOATING POINT: PUSH THE HARD WAY
	PSHB
	LDB	VFLT3,X
	PSHB
	LDB	VFLT2,X
	PSHD		PUSH MSD AND EXPONENT/TYPE BYTES
	ELSE	(M6801!M6809)
	LDD	VFLT3,X
	PSHD
	LDD	VTYPE,X
	PSHD
	FIN
	JMP	NTRPT1

XOPLSCALAR2	; EXPRESS LANE
	LEAS	-3,S
	PSHA
	JMP	NTRPT1
	PAGE
*	STORE SCALAR
*
XOPSSCALAR	; STORE SCALAR OPCODE
	IF	M6800!M6801
	SUBB	#$80	DROP "STORE" OPCODE BIT
	ABA	; (A)=SCALAR NUMBER * 6
	TAB
	LDA	#0
	ROLA
XOPSSCALAR1
	ADDD	VARTABLE	NOTE: VARTABLE = BASE OF SCALAR VARS
	STD	STORETARGET
	LDX	STORETARGET
	ELSE	(M6809)
	ADDB	,S+	(CARRY,B) = SCALAR NUMBER * 6 + $80
	LDA	#0	CAPTURE CARRY BIT IN (A)
	ROLA
	SUBD	#$80	SUBTRACT $80 EXCESS
XOPSSCALAR1	LDX	VARTABLE	COMPUTE ADDRESS OF SCALAR
	LEAX	D,X
	STX	STORETARGET
	FIN
	PULA		GET TYPE BYTE
	STA	VTYPE,X	=0 (INTEGER)?
	BEQ	SSCALARI	SKIP FIXING IT
	PSHA		DOWN BOY!
	JSR	FIX16	TAKE ROVER TO THE VET...
	BRA	SSCALAR2	HE'S FIXED!
	LDX	STORETARGET	HE'S NOT DOING SO WELL...
	INS		POP GOES THE DATA
	PULD
	STD	VFLT2,X
	PULD
	STD	VFLT4,X
	PULA
	STA	VFLT6,X
	JMP	NTRPT1	AND GO

SSCALAR2	LDX	STORETARGET	STORE FIXED VERSION OF VALUE
	CLR	VTYPE,X	MARK AS "INTEGER"
	JMP	SSCALARI1	STACK LOOKS LIKE: (0,0,V,V)

SSCALARI	INS		STACK LOOKS LIKE: (X,X,X,V,V)
SSCALARI1	LEAS	2,S	INS THE BEGINNING, ...
	PULD
	STD	VINT1,X
	JMP	NTRPT1
	PAGE
	IF	M6800!M6801
XOPLESCALAR	; LOAD EXTENDED SCALAR  (LOAD EXTENDED SCALAR)(SCALAR#-64)
	LDX	BPC
	LDB	ILADD,X	SCALAR #
	CLRA
	ROLD		SCALAR # *2
	ADDB	ILADD,X	SCALAR # *3
	ADCA	#0
	ROLD		SCALAR # *6
	ADDD	#64*6	SINCE SCALAR # IS ACTUALLY -64
	INX
	STX	BPC
	JMP	XOPLSCALAR1

XOPSESCALAR		; STORE EXTENDED SCALAR (STORE EXTENDED SCALAR)(SCALAR#-64)
	LDX	BPC
	LDB	ILADD,X
	CLRA
	ROLD		SCALAR # * 2
	ADDB	ILADD,X	SCALAR # * 3
	ADCA	#0
	ROLD		SCALAR # * RSESIZ
	ADDD	#64*6
	INX
	STX	BPC
	JMP	XOPSSCALAR1
	ELSE	(M6809)
XOPLESCALAR	; LOAD EXTENDED SCALAR NUMBER
	LDB	,X+	FETCH DESIRED SCALAR NUMBER, - 64
	STX	BPC	UPDATE BASIC PC
	LDA	#RSESIZ	MULTIPLY BY SIZE OF SCALAR
	MUL
	ADDD	#64*6	ADD OFFSET FOR 1ST 64 SCALARS
	JMP	XOPLSCALAR1

XOPSESCALAR	; STORE EXTENDED SCALAR NUMBER
	LDB	,X+	FETCH DESIRED SCALAR NUMBER, - 64
	STX	BPC
	LDA	#RSESIZ	MULTIPLY BY SIZE OF SCALAR
	MUL
	ADDD	#64*6	ADD OFFSET FOR 1ST 64 SCALARS
	JMP	XOPSSCALAR1	GO DO THE STORE
	FIN
	PAGE	*****  I N I T  *****
*
*	MAIN PROGRAM ENTRY POINT CODE:
*		JSR	$100
*		FCB	versionnumber
*		FDB	forwardreflabelchain
*		FDB	catbufsizerequired
*		FDB	baseofscalarvariables
*		FDB	addressof1stbyteabovedataspace
*		...basic popcodes...
*
*
INIT	LDX	#0
	STX	BREAKLINE+VINT1
	STX	USING	SET USING:=USINGMAX
	STX	USINGMAX
	STX	ERTRAP
	STX	ERCODE
	STX	ERADDR	TO CAUSE ERROR ON "GOTO ELN" BEFORE ERROR OCCURS
	STX	EOFTABLE	NOT EOF ON CHANNEL 0-15
	STX	EOFTABLE+2	NOT EOF ON CHANNEL 16-31
	IF	M6800!M6801
	LDA	#JMPTBL/256
	STA	JMPADD
	FIN
	CLRA
	STA	LINEFLAGS
	STA	SUBROUTINENESTING	"NO SUBROUTINE CALLED"
	LDX	,S
	STX	BPC
	LDA	RTP:VERSIONNUMBER,X	FETCH VERSION NUMBER OF COMPILER
	CMPA	#VERSION	MATCH RUNTIME PACKAGE VERSION NUMBER ?
	BEQ	INIT2	B/ EVERYTHING IS OK...
*	DON'T WE NEED A STACK POINTER HERE ???????
VERSIONERROR	JSR	RTPERR
	FCB	:VERERR	CAN'T EXECUTE A DIFFERENT VERSION PROGRAM!
INIT2	LDX	RTP:CATSIZEREQD,X	GET DESIRED CAT BUFFER SIZE
	STX	CATSIZ
	LDD	SYSCALL$+1	GET TOP OF THE WORLD
	SUBD	CATSIZ	FIND BASE OF CATBUFFER
	STD	CATBUF
	IF	M6800!M6801
	LDX	CATBUF	FIRST BYTE WE CAN'T USE FOR STACK SPACE!
	TXS		NOW STACK POINTER IS CORRECTLY SET
	ELSE	(M6809)
	LDS	CATBUF
	FIN
	STS	STACKFRAMEBASE	WE WILL NEED THIS LATER
	STS	ERRORRECOVERYSTACK	THIS TOO, IF AN ERROR TRAP OCCURS
	LDX	BPC
	BSR	INITCOMMON	GO DO COMMON SETUP LOGIC
*	NOW COMPUTE CHECKSUM OF ENTIRE RTP
	LDX	#CODE	COMPUTE SUM OVER RTP
	CLRB
TOTALRTPSUM	; LOOP TO ACCUMULATE CHECKSUM OVER RUNTIME PACKAGE
	IF	M6800!M6801
	ADDB	0,X
	INX
	ELSE	(M6809)
	ADDB	,X+	ADD A BYTE
	FIN
	CPX	#BASICRTPEND$
	BNE	TOTALRTPSUM	B/ MORE BYTES TO SUM
	SUBB	DOLLARSIGN	IS CHECKSUM OK, IGNORING VALUE OF DOLLARSIGN ?
*	SET RTPTOTALCKSUM:=RTPTOTALCKSUM-(B) AT THIS POINT
	BNE	INITCKERR		B/ WRONG CHECKSUM!
	LDD	#RTP:POPCODESTART	COMPUTE POINTER TO 1ST POPCODE
	ADDD	BPC
	STD	BPC
	STD	LINEADDR	FOR PROPER ERROR HANDLING PRIOR TO LINE NUMBER (SEE PRINTLINEADDR)
	JMP	XOPLINE0	GO LOOK AT LINE FLAGS

**********************************************************************
	FCB	RTPTOTALCKSUM	*** THIS NEEDS PATCHING AFTER ASSEMBLY ***
**********************************************************************

INITCKERR	JSR	RTPERR	WRONG SUM, GIVE UP NOW!
	FCB	:BADRTP
	PAGE
*	RESOLVEFREFLABELS -- FOLLOW FORWARD REF LABEL CHAIN AND SET VARIABLE VALUES
*
RESOLVEL	STX	TWORD	SAVE VALUE OF THIS LABEL
	LDX	ILADD+1,X	GET ADDRESS OF LABEL VAR
	CLR	VTYPE,X	MAKE IT AN INTEGER
	LDD	TWORD
	STD	VINT1,X
	LDX	TWORD
RESOLVEFREFLABELS	EQU	*
	LDX	RTP:FREFLABELCHAIN+2,X
	BNE	RESOLVEL	B/ NOT END OF LIST, KEEP GOING
	RTS
*
*	INITCOMMON -- DO WORK THAT IS COMMON TO RTP INITZ AND SUB/FUN INITZ
*
INITCOMMON	EQU	*
	IF	CODE=$100	CHECK ONLY IF RTP ORG'D TO STANDARD PLACE
	LDD	RTP:TOPOFDATASPACE,X	CHECK FOR DATA SPACE OVERLAP WITH SDOS
	SUBD	CATBUF
	BCC	DATASPACEERROR
	LDD	BPC
	SUBD	#BASICRTPEND$+3
	BCS	OVERLAPERROR
	FIN
	LDD	RTP:BASEOFSCALARVARS,X
	STD	VARTABLE
	LDX	RTP:FREFLABELCHAIN,X
	BNE	RESOLVEL
	RTS

	IF	CODE=$100	CAN ONLY GET THESE ERRORS IF ORG'D TO STANDARD PLACE
DATASPACEERROR	BSR	FORCEERROR	FORCE UNTRAPPABLE ERROR
	JSR	RTPERR
	FCB	:DATASPACECONFLICT

OVERLAPERROR	BSR	FORCEERROR
	JSR	RTPERR
	FCB	:OVERLAPSRTP
	FIN

FORCEERROR	LDX	#0	MAKE ERROR TRAP ROUTINE DISAPPEAR
	STX	ERTRAP
	CLR	SUBROUTINENESTING	SO NO ERROR PROPOGATION OCCURS
	RTS
	PAGE
*	OPINIT
*	INITIALIZE MEMORY
*	OPINIT, ADDH, ADDL, # BYTES (16 BITS), BYTES
*
XOPINIT	; INITIALIZE STORAGE OPCODE
	IF	M6800!M6801
	LDX	BPC
	LDX	ILADD,X
	STX	TEMPX	= TARGET ADDRESS
	LDX	BPC
	LDD	ILADD+2,X
	ELSE	(M6809)
	LDY	ILADD,X
	LDD	ILADD+2,X
	FIN
	LEAX	ILADD+4,X	(X) = ADDRESS OF 1ST SOURCE BYTE
	JSR	BLOCKMOVEDOWN
	JMP	NTRPTX	ALL DONE!
	PAGE	*****  L O A D  *****
*
*	LOAD INLINE FLOATING CONSTANT
*
XOPLFI	; LOAD FLOATING INLINE CONSTANT
	IF	M6800!M6801
	LDX	BPC
	FIN
	JSR	FLOAD
	LDB	#6	# BYTES TO ADVANCE PAST INSTRUCTION
	JMP	NTRADB
*
*	LOAD VALUE
*	ADDRESS IN LINE, PUSH 6
*
XOPLOAD	; LOAD VALUE AT INLINE ADDRESS OPCODE
	IF	M6800!M6801
	LDX	BPC
	FIN
	LDX	ILADD,X
LOADX	LDD	VFLT5,X	LEAST SIGNIFICANT WORD
	PSHD
	LDA	VFLT1,X	TYPE BYTE
	BEQ	LOADINT1	B/ INTEGER, FINISH IT OFF QUICKLY
	IF	M6800
	LDB	VFLT4,X
	PSHB
	LDB	VFLT3,X
	PSHB
	LDB	VFLT2,X
	PSHD
	ELSE	(M6801!M6809)
	LDD	VFLT3,X
	PSHD
	LDD	VFLT1,X
	PSHD
	FIN
	JMP	NTRPT3
	PAGE
*	LOAD INTEGER
*	2 BYTE INTEGER IN LINE, PUT INTO STACK
*
XOPLINT	EQU	*
XOPLADDR	; LOAD INLINE ADDRESS OPCODE
	IF	M6800!M6801
	LDX	BPC
	FIN
	LDD	ILINT,X
LOADAB	PSHD
	CLRA		MAKE A TYPE BYTE TAGGED "INTEGER"
LOADINT1	LEAS	-3,S	ASSERT: (A)=0 --> "INTEGER", (X) IS GARBAGE
	PSHA
	JMP	NTRPT3
*
*	LOAD 1 BYTE IN-LINE INTEGER ONTO TOS
*	*** WARNING: BYTE REPRESENTS VALUES 0-255, ONLY USED FOR 10-255
*
XOPLBINT	EQU	*
	IF	M6800!M6801
	LDX	BPC
	FIN
	LDB	ILINT,X	FETCH VALUE OF INTEGER
	CLRA		CONVERT TO 16 BITS
	PSHD		PUSH THE INTEGER
	LEAS	-3,S
	PSHA		PUSH "INTEGER" TYPE TAG
	JMP	NTRPT2X
	PAGE
*
*	LOAD BYTE, ADDRESS ON TOS
*
XOPLDB	LDX	R1SDA,S	GET ADDRESS OF BYTE
	LDB	STRING,X	GET BYTE
LOADB1
	IF	M6800!M6801
	TSX
	CLR	R1INT1,X
	STB	R1INT2,X
	CLR	R1TYPE,X	MARK RESULT AS "INTEGER"
	ELSE	(M6809)
	CLR	R1INT1,S
	STB	R1INT2,S
	CLR	R1TYPE,S
	FIN
	JMP	NTRPT1
	PAGE
*	LOAD VALUE
*	ADDRESS ON STACK, REPLACE WITH VALUE
*
XOPLV	LDX	R1ADD,S
LOADV1
	IF	M6800!M6801
	LEAS	RSESIZ,S	POP ADDRESS FROM STACK
	LDD	VFLT5,X
	PSHD
	LDA	VFLT1,X	GET TYPE BYTE
	BEQ	OPLSMI1	B/ INTEGER, TAKE QUICK PATH
	IF	M6800
	LDB	VFLT4,X
	PSHB
	LDB	VFLT3,X
	PSHB
	LDB	VFLT2,X
	PSHD
	ELSE	(M6801)
	LDD	VFLT3,X
	PSHD
	LDD	VFLT1,X
	PSHD
	FIN
	ELSE	(M6809)
	LDD	VFLT1,X	GRAB THE VALUE...
	STD	VFLT1,S	AND STORE IT WHERE THE POINTER WAS
	LDD	VFLT3,X
	STD	VFLT3,S
	LDD	VFLT5,X
	STD	VFLT5,S
	FIN
	JMP	NTRPT1
	PAGE
*
*	LOAD SMALL INTEGER
*	OPCODE VALUE = INTEGER TO PUSH ONTO STACK
*
XOPLSMI	LSRB		GET THE INTEGER
OPLSMICLRA	CLRA		EXTEND TO 16 BITS
	PSHD
OPLSMI1	LEAS	-3,S		ASSERT: (A)=0
	PSHA		PUSH "INTEGER" TAG BYTE
	JMP	NTRPT1
*
*	OPDUP -- DUPLICATE TOS
*
XOPDUP	TSX
	BRA	OPPI1
*
*	OPLBOOL -- LOAD BOOLEAN VALUE (OF FLAG)
*
XOPLBOOL	LDB	FLAG	GET THE TRUE/FALSE FLAG
	NEGB		MAPS 0 TO 0, $FF TO 1
	BRA	OPLSMICLRA	GO PUSH AS VALUE ONTO STACK
	PAGE	*****  F U N C T I O N S  *****
*
*	LOAD VALUE OF PI
*
XOPPI	LDX	#PI
OPPI1	JSR	FLOAD
	JMP	NTRPT1
*
*	FUNERR, PUSH LAST ERROR CODE ON STACK
*
XOPERR	LDD	ERCODE
	BRA	XOPELN2
*
*	LOAD LAST ERROR LINE #
*
XOPELN	LDX	ERADDR	SEE WHAT KIND OF ERROR WE GOT
	LDA	,X
	CMPA	#OPLINE	A LINE # OPCODE ?
	BNE	XOPELN1
	LDD	ILINT+1,X
	BRA	XOPELN2

XOPELN1	LDD	ERADDR	NOTE: "IF ELN=2000 THEN ..." compiles as:
XOPELN2	PSHD			OPELN,OPLINT,#addressofline2000
	CLRA			OPEQ
	BRA	OPLSMI1		OPBT,#...	etc.
	PAGE
*	ABS FUNCTION
*
XOPABS	LDA	R1TYPE,S
	BPL	ABS1
	EORA	#$80	ONLY FP #'S ARE NEG
	IF	M6800!M6801
	STA	R1TYPE,X
	ELSE	(M6809)
	STA	R1TYPE,S
	FIN
ABS1	JMP	NTRPT2
*
*	INTEGER FUNCTION
*
XOPINT	LDA	R1TYPE,S
	BEQ	INT3
	JSR	FINT
INT3	JMP	NTRPT1
	PAGE
*	SIGNUM FUNCTION
*
XOPSGN	LDA	R1TYPE,S
	BEQ	SGN1
	BPL	SGN2
	LDX	#FMONE
	JMP	LOADV1
SGN1
	IF	M6800
	LDA	R1INT1,X
	ORAA	R1INT2,X
	ELSEIF	M6801
	LDD	R1INT1,X
	ELSE	(M6809)
	LDD	R1INT1,S
	FIN
	BEQ	SGN3
SGN2	LDA	#1
	IF	M6800!M6801
	STA	R1INT2,X
	CLR	R1INT1,X
	CLR	R1TYPE,X
	ELSE	(M6809)
	STA	R1INT2,S
	CLR	R1INT1,S
	CLR	R1TYPE,S
	FIN
SGN3	JMP	NTRPT1
	PAGE	*****  A R I T H M E T I C   G R O U P  *****
*	MAKEBOTHFLOAT -- ENSURES THAT TOS, TOS-1 ARE BOTH IN FLOATING POINT FORMAT
*
MAKEBOTHFLOAT	PULD		SAVE RETURN ADDRESS
	STD	RTPRET
	JSR	FORCEFLOAT	FLOAT TOS
	LDA	R2TYPE,S	NOW, CHECK TOS-1 FOR FLOAT
	BNE	MFLOAT2
	LDX	#OPPOLYARG
	JSR	FSTORE
	JSR	BFLOAT	FLOAT TOS-1
	LDX	#OPPOLYARG
	JSR	FLOAD
MFLOAT2	JMP	[RTPRET]	DONE
*
*	MULTIPLY TOS BY TOS-1
*	A,B WILL CONTAIN MULTIPLICAND
*	X WILL CONTAIN MULTIPLIER
*	A,B WILL CONTAIN THE PRODUCT
*
XOPMUL	LDA	R1TYPE,S	ARE BOTH OPERANDS INTEGERS ?
	IF	M6800!M6801
	ORAA	R2TYPE,X
	BNE	MUL1	B/ NO, MUST DO FLOATING MULTIPLY
	LDD	R2INT1,X	YES, GRAB LEFT HAND OPERAND
	LDX	R1INT1,X	GET MULTIPLIER
	ELSE	(M6809)
	ORAA	R2TYPE,S
	BNE	MUL1
	LDD	R2INT1,S
	LDX	R1INT1,S
	FIN
	JSR	MLTPLY
	BRA	TSXSUB3	B/ ALL'S OK
MUL1	BSR	MAKEBOTHFLOAT
	LDX	#FLOATOVFLOW
	STX	FPTRAP
	JSR	FMUL
MULX	JMP	NTRPT1
	PAGE
*	DIVIDE TOS INTO TOS-1
*
XOPDIV	LDA	R1TYPE,S	ARE BOTH OPERANDS INTEGERS ?
	IF	M6800!M6801
	ORAA	R2TYPE,X
	BNE	DIV1	B/ NO, MUST DO FLOATING DIVIDE
	LDD	R2INT1,X	FETCH DIVIDEND
	LDX	R1INT1,X	AND THE DIVISOR
	ELSE	(M6809)
	ORAA	R2TYPE,S
	BNE	DIV1
	LDD	R2INT1,S
	LDX	R1INT1,S
	FIN
	BEQ	FLOATOVFLOW	B/ DIVISION BY ZERO!!! (GULP)
	STX	MS1	SAVE DIVISOR
DIVQL	LSR	MS1	NOW DO QUICK DIVIDE IF DIVISOR IS POWER OF TWO
	ROR	MS2	THIS LOOP TERMINATES BECAUSE DIVISOR IS NON-ZERO
	BCS	DIVQD	B/ NON-ZERO DIVISOR BIT FELL OUT
	LSRD		DIVIDE DIVIDEND BY TWO
	BCC	DIVQL	B/ NO REMAINDER SO FAR
DIV1	JSR	MAKEBOTHFLOAT	MUST DO FLOATING DIVIDE, RATS!!
	LDX	#FLOATOVFLOW
	STX	FPTRAP
	JSR	FDIV
	BRA	MULX
DIVQD	BNE	DIV1	B/ REST OF DIVISOR <>0, CANNOT BE POWER OF TWO
	TST	MS1	CHECK UPPER 8 BITS OF DIVISOR
	BEQ	TSXSUB3	B/ DIVISOR WAS POWER OF TWO, GO STORE ANSWER
	BRA	DIV1	NO SUCH LUCK, GO DO IT THE HARD WAY
	PAGE
*	SUB TOS FROM TOS-1
*
XOPSUB	LDA	R1TYPE,S	ARE BOTH OPERANDS INTEGERS ?
	IF	M6800!M6801
	ORAA	R2TYPE,X
	BNE	SUB1	B/ NO, MUST DO FLOATING SUBTRACT
	LDD	R2INT1,X	YES, GRAB LEFT HAND OPERAND
	SUBD	R1INT1,X
	ELSE	(M6809)
	ORAA	R2TYPE,S
	BNE	SUB1
	LDD	R2INT1,S
	SUBD	R1INT1,S
	FIN
	BCC	SUB3
SUB1	JSR	MAKEBOTHFLOAT
	LDX	#FLOATOVFLOW
	STX	FPTRAP
	JSR	FSUB
	BRA	MULX
	IF	M6800!M6801
TSXSUB3	TSX		SO WE CAN STORE THE RESULT
SUB3	STD	R2INT1,X
	ELSE	(M6809)
TSXSUB3,SUB3	STD	R2INT1,S
	FIN
	JMP	PL1PC1
	PAGE
*
*	ADD TOS TO TOS-1
*
XOPADD	LDA	R1TYPE,S	ARE BOTH OPERANDS INTEGERS ?
	IF	M6800!M6801
	ORAA	R2TYPE,X
	BNE	ADD1	B/ NO, MUST DO FLOATING ADD
	LDD	R2INT1,X	YES, GRAB LEFT HAND OPERAND
	ADDD	R1INT1,X
	ELSE	(M6809)
	ORAA	R2TYPE,S
	BNE	ADD1
	LDD	R2INT1,S
	ADDD	R1INT1,S
	FIN
	BCC	SUB3
ADD1	JSR	MAKEBOTHFLOAT
	LDX	#FLOATOVFLOW
	STX	FPTRAP
	JSR	FADD
	BRA	MULX

FLOATOVFLOW	JSR	RTPERR
	FCB	:FLTOVF
	PAGE
*	AND TOS TO TOS-1, NO FLOATING ARGUMENTS ALLOWED
*
XOPAND	LDA	R1TYPE,S	ARE BOTH OPERANDS INTEGERS ?
	IF	M6800!M6801
	ORAA	R2TYPE,X
	ELSE	(M6809)
	ORAA	R2TYPE,S
	FIN
	BEQ	AND1	B/ GO DO IT!
	BSR	MAKEBOTHLOGICAL	FORCE OPERANDS TO BE LOGICAL
	IF	M6800!M6801
	TSX
AND1	LDD	R2INT1,X	FETCH LEFT OPERAND
	ANDA	R1INT1,X
	ANDB	R1INT2,X
	ELSE	M6809
AND1	LDD	R2INT1,S
	ANDA	R1INT1,S
	ANDB	R1INT2,S
	FIN
	JMP	SUB3
*
*	IOR TOS TO TOS-1, NO FLOATING ARGUMENTS ALLOWED
*
XOPIOR	LDA	R1TYPE,S	ARE BOTH OPERANDS INTEGERS ?
	IF	M6800!M6801
	ORAA	R2TYPE,X
	ELSE	(M6809)
	ORAA	R2TYPE,S
	FIN
	BEQ	IOR1	B/ BOTH OPERANDS ARE ALREADY INTEGERS
	BSR	MAKEBOTHLOGICAL
	IF	M6800!M6801
	TSX
IOR1	LDD	R2INT1,X	YES, GRAB LEFT HAND OPERAND
	ORAA	R1INT1,X
	ORAB	R1INT2,X
	ELSE	(M6809)
IOR1	LDD	R2INT1,S
	ORA	R1INT1,S
	ORB	R1INT2,S
	FIN
	JMP	SUB3
*
*	XOR TOS TO TOS-1, NO FLOATING ARGUMENTS ALLOWED
*
XOPXOR	LDA	R1TYPE,S	ARE BOTH OPERANDS INTEGERS ?
	IF	M6800!M6801
	ORAA	R2TYPE,X
	ELSE	(M6809)
	ORAA	R2TYPE,S
	FIN
	BEQ	XOR1	B/ OPERANDS ARE BOTH LOGICAL
	BSR	MAKEBOTHLOGICAL
	IF	M6800!M6801
	TSX
XOR1	LDD	R2INT1,X	YES, GRAB LEFT HAND OPERAND
	EORA	R1INT1,X
	EORB	R1INT2,X
	ELSE	(M6809)
XOR1	LDD	R2INT1,S
	EORA	R1INT1,S
	EORB	R1INT2,S
	FIN
	JMP	SUB3
	PAGE
*	MAKEBOTHLOGICAL -- FORCE BOTH OPERANDS TO 16 BIT INTEGER FORM
*	OR CAUSE ERROR
*
MAKEBOTHLOGICAL	EQU	*	FORCE BOTH OPERANDS TO BE "LOGICAL" OR ERROR
	PULD		GET RETURN ADDRESS
	STD	RTPRET	AND SAVE IT
	BSR	FIXTOS	MAKE SURE TOS IS FIXED
	LDA	R2TYPE,S	CHECK OUT TOS-1
	BEQ	MAKEBOTHLOGICAL2	B/ TOS-1 IS FIXED ALREADY!
	LDX	#OPPOLYARG	SIGH... SAVE TOS SOMEWHERE SAFE
	JSR	FSTORE
	BSR	FIXTOS	FORCE OLD TOS-1 TO BE INTEGER
	LDX	#OPPOLYARG	GET OLD TOS BACK
	JSR	FLOAD
MAKEBOTHLOGICAL2	EQU	*
	JMP	[RTPRET]	AND EXIT
	PAGE
*	FIXTOS -- CONVERTS TOS TO 16 BIT INTEGER FORM
*	CAUSES ERROR IF NOT CONVERTABLE
*
FIXTOS	EQU	*
	LDA	R1TYPE+2,S	IS IT ALREADY INTEGER ?
	BEQ	FIXTOSRTS	B/ YEP
	PULD
	STD	ACMRET
	JSR	FIX16
	BRA	FIXTOSOK
FIXTOSERR	JSR	RTPERR
	FCB	:FLTNXP

FIXTOSOK	EQU	*
	CLRA		MARK TOS AS "INTEGER"
	PSHA
	PSHA
	JMP	[ACMRET]

FIXTOSRTS	RTS
*
*	COM - COMPLEMENT INTEGER ON TOS
*
XOPCOM	BSR	FIXTOS	FORCE TOS TO BE IN INTEGER FORM
	COM	R1INT1,S
	IF	M6800!M6801
	COM	R1INT2,X
	ELSE	M6809
	COM	R1INT2,S
	FIN
	JMP	NTRPT1
	PAGE
*	LOGICAL SHIFT TOS-1 BY TOS, NO FLOATING ARGUMENTS ALLOWED
*	EXCEPT FLOATING NEGATIVE SMALL CONSTANTS FOR COUNT ONLY
*
XOPSHF	LDA	R1TYPE,S	IS TYPE FLOATING?
	BPL	SHIFT2	B/ MAYBE NOT
	LDX	#FPOINT5
	JSR	FLOAD
	JSR	FADD	NO OVERFLOW HERE
	LDA	R1TYPE,S
	BPL	SHIFT9
	JSR	FINT
	JSR	FNEG
	JSR	FIX16
	BRA	SHIFTM
	CLR	R2TYPE,S	NUMBER IS TOO BIG TO FIX, SET RESULT TO ZERO
	IF	M6800!M6801
	CLR	R2INT1,X
	CLR	R2INT2,X
	ELSE	M6809
	CLR	R1INT1,S
	CLR	R2INT2,S
	FIN
SHIFT9	JMP	PL1PC1

SHIFTM	LEAS	2,S	SHIFT RIGHT DESIRED
	PULD
	TSTA
	BNE	SHZERO	> 256 TO RIGHT
	STB	TBYTE
*	BEQ	SHIFTX	ASSERT: SHIFT COUNT <> 0
	BSR	FIXTOS
	LDA	R1INT1,S
	LDB	TBYTE
SHIFT7	LSRA
	IF	M6800!M6801
	ROR	R1INT2,X
	ELSE	(M6809)
	ROR	R1INT2,S
	FIN
	DECB
	BNE	SHIFT7
	IF	M6800!M6801
SHIFT8	STA	R1INT1,X
	ELSE	(M6809)
SHIFT8	STA	R1INT1,S
	FIN
	BRA	SHIFTX
	PAGE
SHIFT2	JSR	RNDTOS	SHIFT COUNT IS POSITIVE
	FDB	SHZERO	B/ CAN'T ROUND!
	TSTA
	BNE	SHZERO
	STB	TBYTE
	BEQ	SHIFTX	B/ SHIFT COUNT IS ZERO
	BSR	FIXTOS
	LDA	R1INT1,S
	LDB	TBYTE
	IF	M6800!M6801
SHIFT5	ASL	R1INT2,X
	ELSE	(M6809)
SHIFT5	ASL	R1INT2,S
	FIN
	ROLA
	DECB
	BNE	SHIFT5
	BRA	SHIFT8

SHZERO	CLR	R1TYPE,S	RESULT IS 0
	IF	M6800!M6801
	CLR	R1INT1,X
	CLR	R1INT2,X
	ELSE	(M6809)
	CLR	R1INT1,S
	CLR	R1INT2,S
	FIN
SHIFTX	JMP	NTRPT1
*
*	NEGATE TOS
*
XOPNEG	JSR	FORCEFLOAT
	JSR	FNEG
	JMP	NTRPT1
	PAGE	*****  S T R I N G   A N D   A R I T H M E T I C  C O M P A R E S  *****
*	ALGEBRAIC COMPARES
*
XOPEQ	BSR	ACMP
	BNE	CMP0
CMP1	LDA	#$FF	ASSERT: FLAG HAS VALUE 0 OR $FF!
	STA	FLAG
	JMP	NTRPT1

CMP0	CLR	FLAG
	JMP	NTRPT1

XOPNE	BSR	ACMP
NOTEQUALQ	BNE	CMP1
	BRA	CMP0

XOPLT	BSR	ACMP
	BLT	CMP1
	BRA	CMP0

XOPLE	BSR	ACMP
	BLE	CMP1
	BRA	CMP0

XOPGT	BSR	ACMP
	BGT	CMP1
	BRA	CMP0

XOPGE	BSR	ACMP
	BGE	CMP1
	BRA	CMP0
	PAGE
*	STRING COMPARES
*
XOPSEQ	BSR	SCMP
	BEQ	CMP1
	BRA	CMP0

XOPSNE	BSR	SCMP
	BNE	CMP1
	BRA	CMP0

XOPSLT	BSR	SCMP
	BLT	CMP1
	BRA	CMP0

XOPSLE	BSR	SCMP
	BLE	CMP1
	BRA	CMP0

XOPSGT	BSR	SCMP
	BGT	CMP1
	BRA	CMP0

XOPSGE	BSR	SCMP
	BGE	CMP1
	BRA	CMP0
	PAGE
*	ACMP -- ARITHMETIC COMPARE SUBROUTINE
*	COMPARE TOS-1 WITH TOS
*	SET SIGN IF TOS-1 VALUE < TOS VALUE
*	SET "Z" IF TOS-1 VALUE = TOS VALUE
*	RESET "OVERFLOW" BIT
*
ACMPF	PULD		SAVE RETURN ADDRESS
	STD	ACMRET
	JSR	MAKEBOTHFLOAT
	LDD	ACMRET	NOW DO: "JSR FCMP/ RTS"
	PSHD
	JMP	FCMP
*
ACMP	LDA	R1TYPE+2,S	THIS IS MAIN ENTRY POINT OF SUBROUTINE
	IF	M6800!M6801
	ORAA	R2TYPE+2,X
	BNE	ACMPF	B/ A FLOATING OPERAND
	LDA	R2INT1+2,X
	CMPA	R1INT1+2,X
	BNE	ACMPCC
	LDA	R2INT2+2,X
	SUBA	R1INT2+2,X
	BEQ	ACMP4
ACMPCC	BCC	ACMPGT
ACMPLS	LDA	#-1
	SK2
ACMPGT	LDA	#1
ACMP4	LDX	,X	FETCH RETURN ADDRESS
	STS	TEMPX	POP 2 ENTRIES OFF THE STACK
	LDB	#RSESIZ*2+2
	ADDB	TEMPX+1
	STB	TEMPX+1
	BCC	ACMP5
	INC	TEMPX
ACMP5	LDS	TEMPX
	TSTA
	JMP	,X	AND EXIT
	ELSE	(M6809)
	ORA	R2TYPE+2,S
	BNE	ACMPF
	LDX	,S	GET RETURN
	LDD	R2INT1+2,S
	SUBD	R1INT1+2,S	COMPUTE INTEGER DIFFERENCE, SETTING CC BITS
	BEQ	ACMP5	B/ RESULT IS ZERO, CC IS SET PROPERLY
	TPA		MUST CONVERT UNSIGNED COMPARE CC BITS...
	RORA		TO SIGNED COMPARE CC
	RORA		(MOVE BORROW BIT TO SIGN BIT)
	ORA	#1	ENSURE ANSWER IS "NOT ZERO", RESET OVERFLOW
ACMP5	LEAS	RSESIZ*2+2,S	POP RETURN, 1 ENTRY AND 4 BYTES OF OTHER ENTRY
	JMP	,X
	FIN
	PAGE
*	STR1 IS COMPARED TO STR2
*	STATUS OF COMPARE IS RETURNED IN STATUS REG
*	STRINGS EQUAL IFF STRING LENGTHS ARE = AND STRING HEADS ARE =
*	LESS THAN IF (HEADS SAME & SL1 < SL2) OR HEAD1 < HEAD2
*	GT IF (HEADS SAME & SL1 > SL2) OR HEAD1 > HEAD2
*
	IF	M6800!M6801
SCMPLS	TSX		LIKE ACMP WANTS; DON'T TOUCH CC!
	BRA	ACMPLS

SCMPCC	TSX		LIKE ACMP WANTS; DON'T TOUCH CC!
	BRA	ACMPCC

	FIN

SCMP	LDX	R1SDC1+2,S	FIND LENGTH OF STRING ON TOS
	CPX	#$FFFF	= "ALL" ?
	BNE	SCMP1	B/ NO, (X) = LENGTH
	LDX	R1SDA+2,S	YES, GET ACTUAL STRING LENGTH
	LDX	CURLEN,X
SCMP1	STX	S2LEN
	LDX	R2SDC1+2,S	GET S1 LENGTH
	CPX	#$FFFF	USE CURRENT LENGTH?
	BNE	SCMP2	NO
	LDX	R2SDA+2,S	GET S2 ADDRESS
	LDX	CURLEN,X	GET CURRENT LENGTH
SCMP2	STX	S1LEN	TAKE MIN( LEN(S1), LEN(S2) )
	CPX	S2LEN	LENGTHS = ?
	BEQ	SCMP7
	LDD	S1LEN	S1LEN <> S2LEN
	SUBD	S2LEN
	RORA		MAKE -1 OR $7F
	ORAA	#$7F
	STA	TBYTE
	BPL	SCMP3	B/ LEN(S1) >= LEN(S2)
	LDX	S1LEN	LEN(S1) < LEN(S2)
	BEQ	SCMPLS	B/ LEN(S1) = 0 --> S1 < S2
	BRA	SCMP6

SCMP7	CLR	TBYTE	IN CASE STRING BODIES ARE EQUAL
SCMP3	LDX	S2LEN
	BEQ	SCMPEQ	B/ LEN(S2) = 0 --> S1 >= S2
	IF	M6800!M6801
SCMP6	STX	LOOPX	NOW SCAN STRING STRING BODIES FOR FIRST NON-MATCH
	LDX	R1SDA+2,S
	STX	S2ADD
	LDX	R2SDA+2,S
	LDB	LOOPX+1	SET UP LOOP COUNT
	BEQ	SCMP6A	B/ DON'T HAVE TO INC UPPER HALF
	INC	LOOPX	TO MAKE DEC'ING (LOOPX,B) EASY
SCMP6A	SK2
SCMP4	LDX	S1ADD	COMPARE S1 TO S2
	LDA	STRING,X
	INX
	STX	S1ADD
	LDX	S2ADD
	CMPA	STRING,X
	BNE	SCMPCC	STATUS IS SET PROPERLY
	INX
	STX	S2ADD
	DECB		DEC LSBYTE OF LOOP COUNT
	BNE	SCMP4
	DEC	LOOPX	DEC MSBYTE OF LOOP COUNT
	BNE	SCMP4
SCMPEQ	LDA	TBYTE	STRING PREFIXES ARE IDENTICAL
	TSX
	JMP	ACMP4
	ELSE	(M6809)
SCMP6	STX	LOOPX	= # BYTES TO COMPARE
	LDX	R1SDA+2,S	SCAN STRING BODIES FOR FIRST NON-MATCH
	LDY	R2SDA+2,S
	LEAX	STRING,X	POINTER TO 1ST BYTE
	LEAY	STRING,Y
	LDB	LOOPX+1
	BEQ	SCMP6L	B/ DON'T HAVE TO INC UPPER HALF
	INC	LOOPX	SO DEC THAT FOLLOWS WORKS NICELY
SCMP6L	LDA	,Y+	HIGH SPEED LOOP TO FIND STRING DIFFERENCE
	CMPA	,X+
	BNE	SCMPNE	B/ STRINGS ARE DIFFERENT
	DECB		DOWN COUNT REMAINING STRING TO COMPARE
	BNE	SCMP6L	B/ WHIZZZZ
	DEC	LOOPX	EVERY 256 ITERATIONS...
	BNE	SCMP6L	B/ MORE WHIZZZ
SCMPEQ	LDX	,S	STRING PREFIXES ARE EQUAL
	LEAS	RSESIZ*2+2,S	POP STRING DESCRIPTORS FROM STACK
	LDA	TBYTE	= WHICH STRING IS BIGGER
	JMP	,X

SCMPLS	SEC		FORCE CC TO "<"
SCMPNE	RORA		PUT BORROW BIT IN SIGN
	LDX	,S	GRAB RETURN ADDRESS
	LEAS	RSESIZ*2+2,S
	ORAA	#1
	JMP	,X
	FIN
	PAGE	*****  S T R I N G S  *****
*
*	TIME
*
XOPTIM	BSR	GTD
	LDX	#TIMESTR-STRING

TIME1	LDD	#8	PUSH STRING DESCRIPTOR FOR 8 BYTE STRING
	PSHD
	PSHX
	LDA	#1	MARK EXP BYTE OF SD AS "<>0"
	PSHD
	JMP	NTRPT2

*
*	DATE
*
XOPDAT	BSR	GTD
	LDX	#DATESTR-STRING
	BRA	TIME1
	PAGE
*	GET TIME, DATE SUBROUTINE
*
GTD	JSR	SETSCOP
	FCB	SYSCALL:OPEN
	FCB	OPEN:SCLEN
	FCB	CHANGED,IGNORED

	JSR	SETSCWRBUF
	FDB	CLOCKSTR
	FDB	6

	JSR	SETSCRDBUF
	FDB	SCRATCH
	FDB	4

	JSR	FINDACHAN

	JSR	SETSCOP
	FCB	SYSCALL:READA
	FCB	READA:SCLEN
	FCB	CHANGED,IGNORED

	JSR	SETSCRDBUF
	FDB	TIMESTR
	FDB	$11

	JSR	SYSCALLONMYCHAN

CLOSEMYCHAN	JSR	SETSCOP
	FCB	SYSCALL:CLOSE
	FCB	CLOSE:SCLEN
	FCB	CHANGED,IGNORED

SYSCALLONMYCHAN	EQU	*
	LDA	MYCHAN
	STA	SCBLK+SCBLK:PARAMS
	JMP	ISYSCALL
	PAGE
*
*	SET OPCODE
*
SETSCOP	LDX	#0
	STX	SCBLK+SCBLK:WRLEN	SO THAT WE DON'T WRITE
	STX	SCBLK+SCBLK:WRBUF
	STX	SCBLK+SCBLK:RDLEN
	STX	SCBLK+SCBLK:RDBUF
	LDX	#SCBLK
	BRA	COPY4

*	SET RDBUF/WRBUF TO VALUES SUPPLIED IN-LINE
*	CALL FORMAT:
*		JSR	SETSCRD/WRBUF
*		FDB	bufferaddress
*		FDB	buffercount
*		...return here...
*
SETSCRDBUF	LDX	#SCBLK+SCBLK:RDBUF
	BRA	COPY4

SETSCWRBUF	LDX	#SCBLK+SCBLK:WRBUF

COPY4	STX	TEMPX	COPY 4 BYTES FROM INLINE; RETURN TO (X)
	LDX	,S
	LDD	,X
	PSHD
	LDD	2,X
	LDX	TEMPX
	STD	2,X
	PULD
	STD	,X
	PULX
	JMP	4,X
	PAGE
*
*	FIND A CHANNEL FOR MY VERY OWN
*
FINDACHAN	CLR	MYCHAN	START AT 0 (WHO KNOWS...IT MIGHT BE CLOSED)
FINDACHAN2	JSR	SYSCALLONMYCHAN
	BCS	DIDNTFINDACHAN
	RTS		ALL DONE

DIDNTFINDACHAN	INC	MYCHAN
	CPX	#ERR:CHBUSY
	BEQ	FINDACHAN2
	DEC	MYCHAN
	JMP	CHECKBCS

	PAGE
*	OPVAL
*	SD ON TOS REPLACED BY NUMERIC VALUE
*
XOPVAL	JSR	GSTRCNT
	LDX	R1SDA,S
	LEAS	RSESIZ,S
	LDD	TEMPX
	LEAX	STRING,X	MAKE (X) POINT TO 1ST BYTE OF STRING
	JSR	CONVERT
	BRA	OPVAL1	B/ CONVERSION OK **** CONVERT MIGHT BE IMPROVED!!!
	JSR	RTPERR
	FCB	:CONVER	SYNTAX ERROR OR OVERFLOW
OPVAL1	JMP	NTRPT2
	PAGE
*	SET USING STRING TO STRING ON TOS
*
XOPUSE	JSR	GSTRCNT
	LDX	R1SDA,S
	LEAX	STRING,X
	STX	USING
	LDD	TEMPX
	ADDD	USING
	STD	USINGMAX
	JMP	PL1PC1
	PAGE
*	SET USING STRING TO FORMAT STRING
*	IN LINE ADDRESS POINTS TO SET LINE # OPCODE
*	OPUSL,POINTERTOLINENUMBERORLABEL
*	NOTE: LINENUMBERORLABEL CAN ANY OF THE FOLLOWING FORMS:
*	1)	OPLINE,16BITLINENUMBER,OPJUC,LENGTH BYTE,FORMATSTRING
*	2)	OPSETLABEL,OPJUC,LENGTH BYTE,FORMATSTRING
*	3)	OPFREFLBL,4 BYTES,LENGTH BYTE,FORMATSTRING
*
XOPUSL	; SET USING STRING TO FORMAT STRING AT INLINE ADDRESS
	IF	M6800!M6801
	LDX	BPC
	FIN
	LDX	ILADD,X	GET ADDRESS OF LINE # OPCODE
	LDA	,X+	GET LABEL OPCODE
	CMPA	#OPSETLABEL
	BEQ	OPUSL1	B/ SET LABEL, (X) SHOULD NOW POINT TO "OPJUC"
	LEAX	2,X	ASSUME "OPLINE"
	CMPA	#OPLINE
	BEQ	OPUSL1	B/ OPLINE OPCODE, (X) SHOULD NOW POINT TO "OPJUC"
	LEAX	2,X	ASSERT: OPFREFLBL OPCODE, (X) SHOULD NOW POINT TO "OPJUC"
OPUSL1	LDA	,X+	GET PURPORTED "OPJUC" OPCODE
	CMPA	#OPJUC	IS THIS REALLY A FORMAT STATEMENT ?
	BNE	OPUSL3	B/ NO, SCREW YOU.
	LDB	,X+	GET LENGTH
	STX	USING	REMEMBER POINTER TO FORMAT STRING BODY
	CLRA
	ADDD	USING
	STD	USINGMAX
	JMP	NTRPT3

OPUSL3	JSR	RTPERR
	FCB	:FORMAT
	PAGE
*	PUSH STRING CONSTANT DESCRIPTOR
*	OPLSC, COUNT, STRING
*	COUNT < 255
*
XOPLSC	; LOAD STRING CONSTANT
	IF	M6800!M6801
	LDX	BPC
	FIN
	CLRA
	LDB	ILSDC,X	GET STRING COUNT
	PSHD
	LDD	BPC	= POINTER TO NON-EXISTANT STRING HEAD
	SUBD	#STRING-1
	PSHD
	LDA	#1	PUSH "STRING" MARKER
	PSHD
OPLSC1	LDB	ILSDC,X	GET STRING LENGTH
	INCB		ASSERT: LENGTH BYTE < 255
	JMP	NTRADB
*
*	JUC
*	JUMP AROUND USING CONSTANT
*	OPJUC,LENGTH BYTE,STRING
*
	IF	M6800!M6801
XOPJUC	; JUMP AROUND "USING" STRING (FORMAT STRING)
	LDX	BPC
	BRA	OPLSC1
	ELSE	(M6809)
XOPJUC	EQU	OPLSC1
	FIN
	PAGE
*
*	PUSH CATBUF DESCRIPTOR
*	USED ONLY IN OPCIN...OPCAT...OPCND SEQUENCES
*
XOPCND	LDD	CATSTRINGSIZE
	PSHD
	LDD	CATBUF
CATDN2	SUBD	#STRING
CATDN1	PSHD
	LDA	#1	MARK EXP BYTE OF SD AS <> 0
	PSHD
	JMP	NTRPT1
*
*	PUSH COPYRIGHT MESSAGE DESCRIPTOR
*
XOPCOPYRIGHT	LDD	#COPYRIGHTEND-COPYRIGHT
	PSHD
	LDD	#COPYRIGHT-STRING
	BRA	CATDN1
	PAGE
*	INPUT STRING TAKES & PUSHES A SD
*	FOR THE STUFF REMAINING IN THE CATBUF
*	INPTR POINTS TO BYTE IN CATBUF
*
XOPINS	LDD	CATPTR	CALCULATE CURRENT COUNT
	SUBD	INPTR
	PSHD
	LDD	INPTR
	BRA	CATDN2	MAKE INPTR LOOK LIKE STRING POINTER
*
*	PUSH STRING DESCRIPTOR
*	OPCODE, ADDRESS (POINTS TO MAX BYTE OF SOME STRING)
*
XOPLSD	; LOAD STRING DESCRIPTOR (FOR STRING VARIABLE)
	IF	M6800!M6801
	LDX	BPC
	FIN
	LDA	#$FF
	PSHA
	PSHA
	LDD	ILADD,X
	PSHD
	LDA	#1	SET EXP NON-ZERO FOR STRING DESCRIPTOR
	PSHD
	JMP	NTRPT3X
	PAGE
*	MAXLEN, TOS GETS MAX LENGTH OF STRING ON TOS
*
XOPMAXLEN	EQU	*
	LDX	R1SDC,S
	CPX	#$FFFF	= "ALL" ?
	BNE	XOPMAXLEN1	B/ NOPE
	LDX	R1SDA,S	YES, GET MAX LENGTH FROM STRING HEADER
	LDX	MAXLEN,X
XOPMAXLEN1	EQU	*
	STX	TEMPX	NOW CONVERT SD ON TOS INTO INTEGER
	LDD	TEMPX	PICK UP STRING LENGTH
	CLR	R1TYPE,S	MARK AS "INTEGER"
	IF	M6800!M6801
	STD	R1INT1,X
	ELSE	(M6809)
	STD	R1INT1,S
	FIN
	JMP	NTRPT1
*
*	LENGTH, TOS GETS CURRENT LENGTH OF STRING ON TOS
*
XOPLEN	EQU	*
	JSR	GSTRCNT	GET CURRENT LENGTH OF STRING
	BRA	XOPMAXLEN1
	PAGE
*	OPFIND, FIND OCCURENCE OF TOS SD IN TOS-1 SD
*	RETURN 0 IF NOT THERE, ELSE RETURN INDEX IN TOS-1
*	IF LEN(S1: STRING TO BE SEARCHED) = 0, RETURN 0
*	IF LEN(S2: STRING TO SEARCH FOR) = 0, RETURN 1
*	POP BOTH
*
OPFINDNULL	LDD	#1	NULL STRING ALWAYS FOUND AT INDEX 1
	JMP	OPFINDXIT

XOPFIND	JSR	GSTRCNT	SET TEMP:= LENGTH OF STRING TO FIND
	BEQ	OPFINDNULL
	LDX	R2SDC1,S	GET LENGTH OF STRING TO BE SEARCHED
	CPX	#$FFFF
	BNE	OPFIND2
	LDX	R2SDA,S
	LDX	CURLEN,X
OPFIND2	STX	S1LEN	= LENGTH OF STRING TO BE SEARCHED
	LDD	S1LEN	FIND LEN(S1) - LEN(S2) + 1
	SUBD	TEMPX
	BCS	OPFINDCANT	CAN'T COMPARE, LEN(S2) > LEN(S1)
	ADDD	#1
	TSTB		SET UP COUNT TO MAKE (DECB,DEC TWORD) BELOW EASY
	BEQ	OPFIND2A	B/ DON'T HAVE TO INC UPPER HALF
	INCA
OPFIND2A	STA	TWORD	SAVE UPPER 8 BITS OF COUNT
	LDX	R2SDA,S
	IF	M6800!M6801
	STX	S1ADD	STRING TO BE SEARCHED
	LDX	R1SDA,S
	STX	S2ADD	STRING TO SEARCH FOR
	LDA	STRING,X	GET FIRST BYTE OF "SEARCH-FOR" STRING
	LDX	S1ADD	= NEXT PLACE TO LOOK
OPFIND1ST	CMPA	STRING,X	FIND MATCH FOR 1ST BYTE
	BEQ	OPFINDREST	B/ FOUND 1ST BYTE
OPFINDNEXT	INX		TRY NEXT BYTE
	DECB
	BNE	OPFIND1ST	B/ MORE TO TRY
	DEC	TWORD
	BNE	OPFIND1ST
OPFINDCANT	LDD	#0	"NOT FOUND"
	BRA	OPFINDXIT

OPFINDNOTHERE	LDX	S2ADD	GET 1ST BYTE TO SEARCH FOR, AGAIN
	LDA	STRING,X
	LDX	S1ADD
	BRA	OPFINDNEXT

OPFINDREST	STX	S1ADD	SAVE LOCATION OF 1ST BYTE OF STRING
	STX	S1ADDT	SET UP TO SCAN REST OF STRING TO FIND
	LDX	S2ADD
	STX	S2ADDT
	LDX	TEMPX	SET LENGTH OF STRING TO FIND
	STX	LOOPX
OPFINDRESTL	LDX	S1ADDT	COMPARE BYTES OF STRINGS
	LDA	STRING,X
	INX
	STX	S1ADDT
	LDX	S2ADDT
	CMPA	STRING,X
	BNE	OPFINDNOTHERE
	INX
	STX	S2ADDT
	LDX	LOOPX
	DEX
	STX	LOOPX
	BNE	OPFINDRESTL
OPFINDFOUND	LDD	S1ADD	= "WE FOUND IT"
	SUBD	R2SDA,S
	ADDD	#1	= STRING SUBSCRIPT OF TARGET
OPFINDXIT	STD	R2INT1,S	SAVE STRING INDEX
	CLR	R2TYPE,X	SET TYPE = "INTEGER"
	JMP	PL1PC1
	PAGE
	ELSE	(M6809)
	LEAX	STRING,X
	STX	S1ADD	STRING TO BE SEARCHED
	LDX	R1SDA,S
	LEAX	STRING,X
	STX	S2ADD	STRING TO SEARCH FOR
	LDA	,X	GET 1ST BYTE OF STRING TO SEARCH FOR
	LDX	S1ADD	=NEXT PLACE TO LOOK
OPFIND1ST	CMPA	,X+	FIND FIRST BYTE USING FAST SCAN
	BEQ	OPFINDREST
OPFINDNEXT	DECB
	BNE	OPFIND1ST
	DEC	TWORD
	BNE	OPFIND1ST
OPFINDCANT	LDD	#0	"NOT FOUND"
	BRA	OPFINDXIT

OPFINDNOTHERE	LDA	[S2ADD]	FIRE UP FAST SEARCH AGAIN
	LDX	S1ADD
	BRA	OPFINDNEXT

OPFINDREST	STX	S1ADD	SAVE LOCATION OF 1ST BYTE, +1
	LDU	S2ADD	= POINTER TO TARGET STRING
	LDY	TEMPX	= # BYTES TO COMPARE
	BRA	OPFINDRESTL1

OPFINDRESTL	LDA	,X+	COMPARE TARGET STRING TO THIS PLACE
OPFINDRESTL1	CMPA	,U+
	BNE	OPFINDNOTHERE	B/ NO MATCH HERE
	LEAY	-1,Y
	BNE	OPFINDRESTL
OPFINDFOUND	LDD	S1ADD	COMPUTE STRING INDEX OF TARGET
	SUBD	R2SDA,S
	SUBD	#STRING	CONVERT TO ORIGIN 1
OPFINDXIT	STD	R2INT1,S	SAVE STRING INDEX
	CLR	R2TYPE,S	SET TYP = "INTEGER"
	JMP	PL1PC1
	FIN
	PAGE
*	SET LENGTH OF STRING ON TOS-1 TO TOS
*	CHECK MAX LENGTH
*	POP BOTH
*
XOPSSL	JSR	RNDTOS
	FDB	OPSSL1
	LDX	R1SDC,S	CHECK SD TO MAKE SURE...
	INX		IT DOESN'T REFER TO A SUBSTRING!
	BNE	OPSSL1	B/ TRYING TO SET LENGTH OF SUBSTRING PASSED AS PARAM, YUK!
	LDX	R1SDA,S	GET STRING ADDRESS
	CMPD	MAXLEN,X
	BHI	OPSSL1
OPSSL4	STD	CURLEN,X
	JMP	PL1PC1
OPSSL1	JSR	RTPERR
	FCB	:SSBRNG
	PAGE
*	INITIALIZE FOR CATENATE
*
XOPCIN	LDX	#0	SET CONCATENATED STRING SIZE TO ZERO
	STX	CATSTRINGSIZE
*
*	CATENATE 
*	COPY STRING AT TOS ONTO CATBUF
*	ADJUST COUNT & CHECK FOR OVERFLOW
*
XOPCAT	JSR	GSTRCNT
	BEQ	CATEN4	B/ STRING LENGTH = 0
	LDD	TEMPX
	PSHD		SAVE SIZE OF STRING TO CONCATENATE
	ADDD	CATSTRINGSIZE
	CMPD	CATSIZ
	BHI	CATEN5
	STD	CATSTRINGSIZE
	SUBD	TEMPX	COMPUTE ADDRESS OF 1ST TARGET BYTE
	ADDD	CATBUF
	IF	M6800!M6801
	STD	TEMPX	SET TARGET ADDRESS
	ELSE	(M6809)
	TFR	D,Y	SET UP "MOVE TO" ADDRESS
	FIN
	PULD		GET MOVE COUNT
	LDX	R1SDA,S	GET ADDRESS OF STRING TO MOVE
	JSR	BLOCKMOVEDOWNS
CATEN4	JMP	PL1PC1

CATEN5	JSR	RTPERR
	FCB	:CATOVF
	PAGE
*
*	CATBUF = UPPERCASE(TOS STRING)
*	TOS = CATBUF STRING DESCRIPTOR
*
UPPERSUB	LDX	R1SDA+2,S	GET ADDRESS OF STRING
	STX	S1ADD
	LDD	TEMPX	MAKE SURE WE DON'T OVERFLOW THE CATBUF
	CMPD	CATSIZ
	BHI	CATEN5	B/ CATBUF TOO SMALL!!
	STD	R1SDC+2,S	SET SIZE OF TOS SDC TO ACTUAL STRING SIZE
	LDD	CATBUF	AIM TOS SDC AT THE CATBUF
	SUBD	#STRING
	IF	M6800!M6801
	STD	R1SDA+2,X
	ELSE	(M6809)
	STD	R1SDA+2,S
	FIN
	LDX	CATBUF	SAVE ADDRESS OF CATBUF
	STX	S2ADD
	LDX	TEMPX	GRAB # BYTES FORCE CASE ON...
	RTS
	PAGE
*
*	TAKE UPPER CASE OF STRING
*
XOPUPPERC	JSR	GSTRCNT	RESOLVE THE STRING LENGTH
	BSR	UPPERSUB
	BEQ	XOPUPPERC3	B/ DONE
	IF	M6800!M6801
XOPUPPERC1	LDX	S1ADD
	LDA	STRING,X
	INX
	STX	S1ADD
	LDX	S2ADD
	CMPA	#'a
	BCS	XOPUPPERC2	B/ NOT LOWER CASE
	CMPA	#'z
	BHI	XOPUPPERC2	B/ NOT LOWER CASE
	SUBA	#32	MAKE IT UPPER CASE
XOPUPPERC2	STA	,X
	INX
	STX	S2ADD
	LDX	TEMPX
	DEX
	STX	TEMPX
	BNE	XOPUPPERC1	B/ MORE TO DO
	ELSE	(M6809)
	LDX	S1ADD	COPY BYTES CONVERTING TO UPPER CASE
	LEAX	STRING,X	SO AUTO-INCREMENT CAN BE USED IN LOOP
	LDY	S2ADD
	LDB	TEMPX+1
	BEQ	XOPUPPERC1	B/ DON'T HAVE TO INC UPPER HALF
	INC	TEMPX
XOPUPPERC1	LDA	,X+
	CMPA	#'a
	BLO	XOPUPPERC2
	CMPA	#'z
	BHI	XOPUPPERC2
	SUBA	#32	CONVERT TO UPPER CASE ASCII
XOPUPPERC2	STA	,Y+
	DECB
	BNE	XOPUPPERC1
	DEC	TEMPX
	BNE	XOPUPPERC1
	FIN
XOPUPPERC3	JMP	NTRPT2
	PAGE
*
*	TAKE LOWER CASE OF STRING
*
XOPLOWERC	JSR	GSTRCNT	RESOLVE THE STRING LENGTH
	BSR	UPPERSUB
	BEQ	XOPLOWERC3	B/ DONE
	IF	M6800!M6801
XOPLOWERC1	LDX	S1ADD
	LDA	STRING,X
	INX
	STX	S1ADD
	LDX	S2ADD
	CMPA	#'A
	BCS	XOPLOWERC2	B/ NOT UPPER CASE
	CMPA	#'Z
	BHI	XOPLOWERC2	B/ NOT UPPER CASE
	ADDA	#32	MAKE IT LOWER CASE
XOPLOWERC2	STA	,X
	INX
	STX	S2ADD
	LDX	TEMPX
	DEX
	STX	TEMPX
	BNE	XOPLOWERC1	B/ MORE TO DO
	ELSE	(M6809)
	LDX	S1ADD	COPY BYTES CONVERTING TO UPPER CASE
	LEAX	STRING,X	SO AUTOINCREMENT CAN BE USED IN LOOP
	LDY	S2ADD
	LDB	TEMPX+1
	BEQ	XOPLOWERC1	B/ DON'T HAVE TO INC UPPER HALF
	INC	TEMPX
XOPLOWERC1	LDA	,X+
	CMPA	#'A
	BLO	XOPLOWERC2
	CMPA	#'Z
	BHI	XOPLOWERC2
	ADDA	#32	CONVERT LOWER CASE ASCII TO UPPER CASE
XOPLOWERC2	STA	,Y+
	DECB
	BNE	XOPLOWERC1
	DEC	TEMPX
	BNE	XOPLOWERC1
	FIN
XOPLOWERC3	JMP	NTRPT2
	PAGE	*****  S T R I N G   S U B C R I P T I N G  *****
*
*	INDEX ON TOS, SD AT TOS-1
*	CHECK SUBSCRIPT RANGE
*	FIX TOS-1 SD TO POINT TO NEW SUBSTRING
*	FIX COUNT
*
XOPRIGHT	BSR	RNDTOS
	FDB	SSB13	ERROR
	ADDD	#-1
	BCC	SSB13	CATCH HIM ON ZERO SUBSCRIPT
	STD	TWORD
	JSR	GSTRCNT	RESOLVE STRING LENGTH
	LDD	TEMPX	(IT IS POSSIBLE THAT SD CONTAINED ACTUAL LENGTH)
	SUBD	TWORD
	BCS	SSB13
	STD	R1SDC1,S
	LDD	TWORD
	IF	M6800!M6801
	ADDD	R1SDA,X
	STD	R1SDA,X
	ELSE	(M6809)
	ADDD	R1SDA,S
	STD	R1SDA,S
	FIN
	JMP	NTRPT1
	PAGE
*	SINGLE STRING SUBSCRIPT
*	TAKE SD AT TOS-1 ADD VALUE AT TOS
*	CHECK SUBSCRIPT RANGE ON MAX LENGTH
*	MAKE NEW ADDRESS
*	LOWER BOUND BASED AT 1
*
XOPSS1	BSR	RNDTOS	ROUND TOS & FIX
	FDB	SSB13	ERROR
	SUBD	#1
	LDX	R1SDC,S	RESOLVE MAXIMUM LENGTH OF STRING
	CPX	#$FFFF	= "ALL" ?
	BNE	OPSS1B	B/ NO, (X) = MAXIMUM LENGTH OF SUBSTRING
	IF	MAXLEN=0
	LDX	[R1SDA,S]	YES, GET LENGTH FROM STRING HEAD
	ELSE
	??
	FIN
OPSS1B	STX	TEMPX	CHECK SUBSCRIPT AGAINST MAX
	CMPD	TEMPX
	BCC	SSB13	B/ >= NOT ALLOWED, WE ALREADY SUBTRACTED 1!
	ADDD	R1SDA,S
	IF	M6800!M6801
	STD	R1SDA,X
	LDD	#1
	STD	R1SDC,X
	ELSE	(M6809)
	STD	R1SDA,S
	LDD	#1
	STD	R1SDC,S
	FIN
	JMP	NTRPT1

SSB13	JSR	RTPERR	STRING SUBSCRIPT OUT OF RANGE
	FCB	:SSBRNG
	PAGE
*	ROUND & FIX TOS TO POSITIVE NUMBER
*	PLACE ROUNDED & FIXED TOS IN (A,B)
*	CALL FORMAT:
*		JSR	RNDTOS
*		FDB	cantround
*		...continue here with (A,B) containing integer...
*
*	SKIP EXIT IF 0 <= (ROUNDED TOS) <= 65535
*	"CAN'T ROUND" EXIT IF (ROUNDED TOS) <0 OR (ROUNDED TOS) > 65535
*	IN EITHER CASE, TOS IS POPPED
*
RNDTOS	LDA	R1TYPE+2,S	SEE IF WE CAN GET OUT OF HERE FAST
	BEQ	RNDTOSI	B/ INTEGER, GET OUT QUICK!
	PULD		SIGH... ITS A FLOAT, DO IT THE HARD WAY
	STD	RTPRET
	JSR	FIX16	TRY TO FIX IT FIRST...
	BRA	RNDTOS1	B/ IT FIXED!
	LDX	#FPOINT5	WON'T FIX, SO ROUND FIRST...
	JSR	FLOAD
	JSR	FADD	NO OVERFLOW POSSIBLE HERE
	LDA	R1TYPE,S
	BMI	RNDERR
	JSR	FIX	CONVERT TO INTEGER BY THROWING FRACTION PART AWAY
	BRA	RNDTOS2	ALL IS WELL
RNDERR	LEAS	2,S	CAN'T FIX, JUST GET RID OF TOS
RNDERR4	LEAS	4,S
	LDX	[RTPRET]	ERROR
	JMP	,X
*	JMP THRU RETURN ADDRESS HERE SAVES "BRA outofrange" ELSEWHERE
	PAGE
RNDTOS2	; TOS HAS FORM: (X,X,V,V)
	IF	M6800
	LDA	,S
	ORAA	1,X
	ELSE	(M6801!M6809)
	LDD	,S
	FIN
	BNE	RNDERR4	B/ RESULT > 65535!
RNDTOS1	LDX	RTPRET	TOS HAS FORM: (0,0,V,V)
	LEAS	2,S	POP TWO ZERO BYTES
	BRA	RNDTOSX	GRAB RETURN ADDRESS AND GET OUT WITH VALUE

RNDTOSI	EQU	*	TOS IS ALREADY AN INTEGER
	IF	M6800!M6801
	LDX	,X	GRAB THE RETURN ADDRESS
	ELSE	(M6809)
	LDX	,S
	FIN
	LEAS	4+2,S	AND POP RETURN AND GARBAGE FROM STACK
RNDTOSX	PULD
	JMP	2,X	AND TAKE SKIP EXIT
	PAGE
*	DOUBLE STRING SUBSCRIPTING
*	TAKE SD AT TOS-2 & INDEX AT TOS-1 TO FORM
*	A NEW ADDRESS FOR SD. TAKE LENGTH AT TOS FOR
*	SD LENGTH
*
XOPSS2	BSR	RNDTOS	CONVERT DESIRED LENGTH TO AN INTEGER
	FDB	OPSS2ERR	ERROR
	STD	STORETARGET	SAVE SUBSTRING LENGTH
	BSR	RNDTOS	CONVERT INDEX OF 1ST BYTE OF STRING TO INTEGER
	FDB	SSB13	ERROR
	SUBD	#1	CONVERT INDEX TO 0 ORIGIN
	STD	TWORD	SAVE 1ST STRING INDEX
	JSR	GSTRCNT	RESOLVE ACTUAL STRING SIZE (TO TEMPX)
	LDX	STORETARGET
	BEQ	SSB26	DESIRED LENGTH = 0, NO ERROR
	CMPD	TEMPX	1ST STRING INDEX OUT OF RANGE ?
	BCC	SSB13	B/ YES
	ADDD	STORETARGET	COMPUTE LAST INDEX OF SELECTED SUBSTRING
	BCS	OPSS2ERR	B/ OFF THE END OF THE WORLD....
	CMPD	TEMPX
	BHI	OPSS2ERR
	LDD	TWORD
	ADDD	R1SDA,S
	IF	M6800!M6801
	STD	R1SDA,X
	ELSE	(M6809)
	STD	R1SDA,S
	FIN
SSB26	LDD	STORETARGET	STORE SUBSTRING LENGTH INTO SD
	STD	R1SDC,S
	JMP	NTRPT1

OPSS2ERR	JSR	RTPERR	SUBSTRING IS TOO BIG OR IS ILLEGAL
	FCB	:SLNRNG
	PAGE
*	OPSSA -- SUBSCRIPT STRING ARRAY TO PRODUCE STRING DESCRIPTOR ON TOS
*	TOS CONTAINS STRING SUBSCRIPT, TOS-1 CONTAINS STRING ARRAY ADDRESS
*	STRING ARRAY FORMAT: (# STRINGS) (STRING)(STRING)(STRING)....
*
XOPSSA	EQU	*
	JSR	RNDTOS
	FDB	DOSSE	ARRAY SUBSCRIPT ERROR IF NOT AN INTEGER!
	SUBD	#1	MAP 0 INTO LARGE NUMBER, CONVERT TO ZERO OR
	LDX	R1ADD,S	GET STRING ARRAY ADDRESS
	CMPD	,X	CHECK SUBSCRIPT BOUNDS
	BCC	DOSSEJ	B/ TOO BIG!
	LDX	MAXLEN+2,X	GRAB SIZE OF STRING
	LEAX	STRING,X	ADJUST TO INCLUDE STRING HEAD
	JSR	MLTPLY	COMPUTE DISPLACEMENT INTO STRING ARRAY
	BRA	XOPSSA1
DOSSEJ	JMP	DOSSE

XOPSSA1	ADDD	#2	ADJUST DISPLACEMENT TO INCLUDE # STRINGS CO
*			ASSERT: MLTPLY CAN'T OVERFLOW!
	ADDD	R1ADD,S	ADD STRING ARRAY BASE
	IF	M6800!M6801
	STD	R1SDA,X	NOW CONVERT TOS INTO STRING DESCRIPTOR
	LDD	#$FFFF	...FOR THE ENTIRE STRING...
	STD	R1SDC,X
	LDAA	#1	MARK AS STRING DESCRIPTOR
	STAA	R1TYPE,X
	ELSE	(M6809)
	STD	R1SDA,S
	LDD	#$FFFF
	STD	R1SDC,S
	LDDA	#1	MARK AS STRING DESCRIPTOR
	STA	R1TYPE,S
	FIN
	JMP	NTRPT2
	PAGE
*
*	OPSAINIT -- INITIALIZE A STRING ARRAY
*	(OPSAINIT) (ADDR OF STRING ARRAY) (# OF STRINGS) (MAXLEN)
*
XOPSAINIT	EQU	*
	IF	M6800!M6801
	LDX	BPC
	FIN
	LDD	ILADD+3,X	GET STRING COUNT TO (A,B)
	STD	LOOPX
	LDX	ILADD+1,X
	STD	,X	STORE STRING COUNT AT ARRAY HEAD
	STX	STORETARGET
	LDX	BPC
	LDX	ILADD+5,X	MAXLEN OF EACH STRING
	STX	TEMPX
OPSAINITL	LDX	STORETARGET
	LDD	TEMPX
	STD	MAXLEN+2,X
	ADDD	#STRING	ADVANCE POINTER BY LENGTH OF EACH STRING
	ADDD	STORETARGET
	STD	STORETARGET
	LDX	LOOPX
	DEX
	STX	LOOPX
	BNE	OPSAINITL
	LDB	#7	AMOUNT TO ADVANCE BPC PAST OPSAINIT OPCODE
	JMP	NTRADB
	PAGE	***** ARRAY SUBSCRIPTING *****
*	DO DOUBLE SUBSCRIPT (SUBROUTINE)
*		(X) POINTS TO ARRAY
*		(A,B) CONTAINS 2ND SUBSCRIPT
*		TWORD:= (A,B) * ROW DIMENSION
*		ARRAY STRUCTURE:  (# OF ROWS) (# COLUMNS) 6*(#COLS+1)*(#ROWS)
*
DODOUBLESUBSCRIPT	EQU	*
	STX	STORETARGET	SAVE ARRAY BASE
	CMPD	2,X
	BHI	DOSSE
DODS1A	LDX	,X
	INX		ACTUAL # ROWS = DIM'D # ROWS + 1
	JSR	MLTPLY	ASSERT: CAN'T OVERFLOW!
	STD	TWORD	SAVE ROW BASE
	RTS
*
*	FINISHDBLSUBSCRIPT (SUBROUTINE)
*		STORETARGET POINTS TO ARRAY BASE
*		(A,B) CONTAINS 2ND SUBSCRIPT
*
FINISHDBLSUBSCRIPT	EQU	*
	LDX	STORETARGET	GET ARRAY ADDRESS
	CMPD	,X	CHECK ROW SUBSCRIPT BOUNDS
	BHI	DOSSE	B/ ROW SUBSCRIPT OUT OF RANGE
DODS2A	ADDD	TWORD	ADD ROW BASE
	LEAX	2,X	MAKE ARRAY LOOK LIKE VECTOR
	BRA	DOSS2
	PAGE
*	DO SINGLE SUBSCRIPT (SUBROUTINE)
*		(X) POINTS TO VECTOR
*		(A,B) CONTAINS VECTOR INDEX AS INTEGER
*	RETURNS (A,B), (X) AND STORETARGET WITH POINTER TO VECTOR SLOT
*	VECTOR STRUCTURE:	(# SLOTS) (6*# SLOTS BYTES)
*	NOTE: SUBSCRIPT LOGIC ASSUMES VECTORS/ARRAYS FIT INTO MEMORY!
*
DOSINGLESUBSCRIPT	EQU	*
	CMPD	,X	CHECK FOR SUBSCRIPT OUT OF BOUNDS
	BLS	DOSS2	IF <= THEN WE'RE OK!
DOSSE	JSR	RTPERR
	FCB	:ARYRNG

DOSS2	STD	TEMPX
	ASLD		INDEX *2 (ASSERT: CAN'T OVERFLOW)
	ADDD	TEMPX	*3 (ASSERT: CAN'T OVERFLOW)
	ASLD		*6 (ASSERT: CAN'T OVERFLOW)
	STX	TEMPX	+VECTOR NAME
	ADDD	TEMPX	ASSERT: CAN'T OVERFLOW
	ADDD	#2	ADD BIAS TO SKIP SLOT COUNT (CAN'T OVERFLOW)
	STD	STORETARGET
	LDX	STORETARGET
	RTS
	PAGE
*	DO VECTOR SUBSCRIPT AND PUSH ADDRESS
*		TOS CONTAINS INDEX VALUE
*		INSTRUCTION CONTAINS POINTER TO VECTOR
*
XOPVSA	EQU	*
	JSR	RNDTOS	CONVERT INDEX TO INTEGER
	FDB	DOSSE	B/ CAN'T FIX
	LDX	BPC
	LDX	ILADD,X
	BSR	DOSINGLESUBSCRIPT
	JMP	LOADAB
*
*	DO VECTOR SUBSCRIPT AND PUSH VALUE
*		TOS CONTAINS INDEX VALUE
*		INSTRUCTION CONTAINS POINTER TO VECTOR
*
XOPVSV	EQU	*
	JSR	RNDTOS
	FDB	DOSSE	B/ CAN'T FIX
	LDX	BPC
	LDX	ILADD,X
	BSR	DOSINGLESUBSCRIPT
	JMP	LOADX
	PAGE
*	DO VECTOR SUBSCRIPT AND STORE VALUE
*		TOS CONTAINS VALUE TO STORE
*		NEXT-TO-TOS CONTAINS INDEX
*		INSTRUCTION CONTAINS POINTER TO VECTOR
*
XOPVSS	EQU	*
	LDA	R2TYPE,S	CHECK TYPE OF INDEX
	BNE	XOPVSSF	B/ RATS, IT'S FLOAT...
	IF	M6800!M6801
	LDD	R2INT1,X	AHA! INTEGER INDEX (AND WHAT DID YOU EXPECT)
	ELSE	(M6809)
	LDD	R2INT1,S
	FIN
	LDX	BPC
	LDX	ILADD,X
	BSR	DOSINGLESUBSCRIPT
	JSR	STORETOS
	JMP	PL1PC3

XOPVSSF	EQU	*	INDEX IS FLOATING, DAMMIT!
	LDX	#OPPOLYARG	SAVE VALUE TO STORE
	JSR	FSTORE
	JSR	RNDTOS	ROUND THE INDEX
	FDB	DOSSE	B/ CAN'T ROUND
	LDX	BPC	GET VECTOR ADDRESS
	LDX	ILADD,X
	BSR	DOSINGLESUBSCRIPT
XOPVSSF1	LDX	#OPPOLYARG	GET VALUE TO STORE
	JSR	FLOAD
	LDX	STORETARGET	AND STORE IT
	JSR	STORETOS
	JMP	NTRPT3
	PAGE
*	DO VECTOR SUBSCRIPT AND PUSH ADDRESS
*		TOS CONTAINS INDEX VALUE
*		INSTRUCTION CONTAINS POINTER TO VECTOR PARAMETER
*
XOPVPA	EQU	*
	JSR	RNDTOS	CONVERT INDEX TO INTEGER
	FDB	DOSSE	B/ CAN'T FIX
	LDX	BPC	FETCH POINTER TO PARAMETER VECTOR
	LDX	ILADD,X
	LDX	R1ADD,X
	JSR	DOSINGLESUBSCRIPT
	JMP	LOADAB
*
*	DO ARRAY SUBSCRIPT AND PUSH ADDRESS
*		TOS CONTAINS SECOND INDEX (COLUMN)
*		NEXT-TO-TOS CONTAINS FIRST INDEX (ROW)
*		INSTRUCTION CONTAINS POINTER TO ARRAY BASE
*
XOPASA	EQU	*
	JSR	RNDTOS	ROUND AND FIX COLUMN INDEX
	FDB	DOSSE	B/ CAN'T FIX
	LDX	BPC
	LDX	ILADD,X
	JSR	DODOUBLESUBSCRIPT
	JSR	RNDTOS
	FDB	DOSSE	B/ CAN'T FIX
	JSR	FINISHDBLSUBSCRIPT
	JMP	LOADAB
	PAGE
*	DO ARRAY SUBSCRIPT AND PUSH VALUE
*		TOS CONTAINS SECOND INDEX (COLUMN)
*		NEXT-TO-TOS CONTAINS FIRST INDEX (ROW)
*		NEXT-TO-TOS CONTAINS FIRST INDEX (ROW)
*		INSTRUCTION CONTAINS POINTER TO ARRAY BASE
*
XOPASV	EQU	*	ARRAY SUBSCRIPT PUSH VALUE
	JSR	RNDTOS
	FDB	DOSSE	B/ CAN'T FIX
	LDX	BPC
	LDX	ILADD,X
	JSR	DODOUBLESUBSCRIPT
	JSR	RNDTOS
	FDB	DOSSE	B/ CAN'T FIX
	JSR	FINISHDBLSUBSCRIPT
	JMP	LOADX
	PAGE
*	DO ARRAY SUBSCRIPT AND STORE VALUE
*		TOS CONTAINS VALUE TO STORE
*		NEXT-TO-TOS CONTAINS COLUMN INDEX
*		NEXT-TO-TOS CONTAINS ROW INDEX
*		INSTRUCTION CONTAINS POINTER TO ARRAY BASE
*
*
XOPASS	EQU	*	ARRAY SUBSCRIPT AND STORE
	LDA	R2TYPE,S	CHECK SUBSCRIPT TYPES
	IF	M6800!M6801
	ORAA	R3TYPE,X
	BNE	XOPASSF	B/ FLOATING SUBSCRIPT, RATS!
	LDD	R2INT1,X	GET COLUMN INDEX
	ELSE	(M6809)
	ORAA	R3TYPE,S
	BNE	XOPASSF
	LDD	R2INT1,S
	FIN
	LDX	BPC	AND ARRAY BASE
	LDX	ILADD,X
	JSR	DODOUBLESUBSCRIPT
	LDD	R3INT1,S	GET ROW SUBSCRIPT
	JSR	FINISHDBLSUBSCRIPT
	JSR	STORETOS
	JMP	PL2PC3

XOPASSF	EQU	*	SIGH, A SUBSCRIPT IS FLOATING....
	LDX	#OPPOLYARG	SAVE VALUE TO STORE
	JSR	FSTORE
	JSR	RNDTOS	TO GET COLUMN VALUE
	FDB	DOSSE	B/ CAN'T FIX
	LDX	BPC	GET ARRAY ADDRESS
	LDX	ILADD,X
	JSR	DODOUBLESUBSCRIPT
	JSR	RNDTOS	TO GET ROW VALUE
	FDB	DOSSE	B/ CAN'T FIX
	JSR	FINISHDBLSUBSCRIPT
	JMP	XOPVSSF1
	PAGE
*	PARAMETER ARRAY SUBSCRIPT AND PUSH ADDRESS
*		TOS CONTAINS COL INDEX
*		NEXT-TO-TOS CONTAINS ROW INDEX
*		INSTRUCTION CONTAINS POINTER TO ARRAY PARAMETER
*
XOPAPA	EQU	*	ARRAY (PARAMETER) SUBSCRIPT & PUSH ADDRESS
	JSR	RNDTOS	TO GET COLUMN INDEX
	FDB	DOSSE	B/ CAN'T FIX
	LDX	BPC
	LDX	ILADD,X
	LDX	R1ADD,X
	JSR	DODOUBLESUBSCRIPT
	JSR	RNDTOS	TO GET ROW INDEX
	FDB	DOSSE	B/ CAN'T FIX
	JSR	FINISHDBLSUBSCRIPT
	JMP	LOADAB
	PAGE
*
*
*	LEN(vector) or LEN(stringarray)
*		TOS CONTAINS VECTOR/STRINGARRAY ADDRESS
*
XOPLENVECTOR	EQU	*
	LDD	[R1ADD,S]	FETCH # VECTOR SLOTS (= DIM'D VALUE)
XOPLENVECTOR1	EQU	*
	STD	R1INT1,S	REPLACE ADDRESS ON TOS BY INTEGER VALUE
	JMP	NTRPT2
*
*	ROWS(ARRAY)
*		TOS CONTAINS ARRAY ADDRESS
*
*
XOPROWSARRAY	EQU	XOPLENVECTOR	IT WORKS EXACTLY THE SAME!
*
*	COLS(ARRAY)
*	TOS CONTAINS ARRAY ADDRESS
*
XOPCOLSARRAY	EQU	*
	LDX	R1ADD,S	FETCH ARRAY ADDRESS
	LDD	2,X	GET # COLUMNS
	BRA	XOPLENVECTOR1
	PAGE	*****  S T O R E  *****
*
*	STORE TOS USING INLINE ADDRESS
*	OPSTD,ADDRESSOFSCALAR
*
XOPSTD	; STORE DIRECT
	IF	M6800!M6801
	LDX	BPC
	FIN
	LDX	ILADD,X	GET "WHERE TO PUT RESULT"
	PULA		GRAB EXPONENT BYTE
	STA	VFLT1,X	SAVE IT IN TARGET
	BEQ	XOPSTDI	B/ AN INTEGER, TAKE OPTIMIZED PATH
	PSHA		ITS FLOAT, PUSH EXPONENT BYTE BACK ON
	JSR	FIX16	TRY TO FIX TO 16 BITS
	BRA	XOPSTD2	B/ IT FIXED!
	LDX	[BPC]	WON'T FIX, JUST STORE IT LIKE IT IS
	INS		POP EXPONENT BYTE OFF STACK, WE ALREADY STORED IT
	PULA		STORE REST OF VALUE INTO TARGET
	STA	VFLT2,X
	PULD
	STD	VFLT3,X
	PULD
	STD	VFLT5,X
	JMP	NTRPT3

XOPSTD2	LDX	[BPC]	TOS FORM IS (0,0,V,V); GET WHERE TO PUT VALUE
	CLR	VTYPE,X	MARK AS INTEGER
	BRA	XOPSTD3	SKIP OVER EXTRANEOUS "POP"
XOPSTDI	EQU	*	STORE INTEGER OPTIMIZED PATH
	INS		TOS FORM IS (X,X,X,V,V)
XOPSTD3	LEAS	2,S	TOS FORM IS (X,X,V,V), POP THE X,X GARBAGE OFF
	PULD
	STD	VINT1,X
	JMP	NTRPT3
	PAGE
*	STORE TOS USING TOS-1; USED TO STORE INTO PARAMETER VARIABLES
*
XOPST	LDX	R2ADD,S	GET "WHERE TO PUT RESULT"
	BSR	STORETOS	GO STORE THE VALUE
	JMP	PL1PC1	EXIT AND POP TARGET ADDRESS OFF STACK
*
*	STORETOS -- STORES NUMERIC VALUE ON TOS AT (X)
*	FIXES TO 16 BITS IF POSSIBLE
*	POPS TOS VALUE
*
STORETOS	EQU	*
	PULD		SAVE RETURN ADDRESS
	STD	RTPRET
	PULA		EXPONENT BYTE
	STA	VFLT1,X	SAVE IT AT TARGET
	BEQ	STORETOSI	B/ AN INTEGER, TAKE FAST PATH
	PSHA		FLOAT, PUSH EXPONENT BYTE BACK ON STACK
	STX	STORETARGET	SAVE WHERE TO PUT RESULT
	JSR	FIX16	TRY TO FIX IT
	BRA	STORETOSF	B/ IT FIXED!
	LDX	STORETARGET	WON'T FIX, GET TARGET ADDRESS AGAIN
	INS		WE ALREADY STORED THE EXPONENT BYTE
	PULA		FINISH STORING THE F.P. VALUE
	STA	VFLT2,X
	PULD
	STD	VFLT3,X
	PULD
	STD	VFLT5,X
	JMP	[RTPRET]	AND GET OUT
	PAGE
STORETOSF	EQU	*
	LDX	STORETARGET	GET WHERE TO STORE RESULT ACTION
	CLR	VTYPE,X	MARK AS INTEGER
	BRA	STORETOS2
STORETOSI	EQU	*
	INS		TOS FORM IS (X,X,X,V,V)
STORETOS2	LEAS	2,S	TOS FORM IS (X,X,V,V)
	PULD		INTEGER VALUE TO STORE
	STD	VINT1,X
	JMP	[RTPRET]	AND EXIT
	PAGE
*	STORE BYTE, ADDRESS ON TOS-1 VALUE ON TOS
*
XOPSTB	LDA	R1TYPE,S
	BEQ	STORB2
	JSR	FIX16	TRY TO FIX IT
	BRA	STORB5	B/ IT WORKED
STORB3	JSR	RTPERR	NUMBER IS TOO BIG TO STORE INTO A BYTE
	FCB	:STORBE

STORB5	LEAS	-2,S	FILL OUT ENTRY ON TOS TO LOOK LIKE REGULAR 6 BYTE ENTRY
STORB2	LDA	R1INT1,S
	BNE	STORB3
	IF	M6800!M6801
	LDA	R1INT2,X
	LDX	R2SDA,X
	ELSE	(M6809)
	LDA	R1INT2,S
	LDX	R2SDA,S
	FIN
	STA	STRING,X
	JMP	PL2PC1
*
*	CHR$ -- PRODUCE STRING FROM NUMERIC VALUE
*
XOPCHR	JSR	RNDTOS	GENERATE STRING WHOSE FIRST BYTE IS TOS
	FDB	STORB3	B/ CAN'T STORE IT!
	TSTA
	BNE	STORB3
	STB	OUTBUF
	LDA	#1	= STRING LENGTH
	JMP	NUM2
	PAGE
*	STORE STRING
*	S1 IS TARGET STRING (TOS - 1) S2 IS SOURCE STRING (TOS)
*
XOPSTS	LDX	R2SDA,S	GET S1 ADDRESS
	STX	S1ADD
	LDX	R1SDA,S
	STX	S2ADD
	JSR	GSTRCNT	GET SIZE OF SOURCE STRING
	IF	M6800!M6801
	TSX		SET POINTER TO GARBAGE PLACE
	STX	TWORD
	LDX	R2SDC1,X	GET LENGTH OF S1
	ELSE	(M6809)
	STS	TWORD
	LDX	R2SDC1,S
	FIN
	CPX	#$FFFF
	BNE	STORES2
	LDX	R2SDA,S
	STX	TWORD	POINTER TO CURRENT LENGTH
	LDX	MAXLEN,X	USE MAX ON TARGET STRING
STORES2	STX	S1LEN
	CLR	LOOPX	ASSUME ZERO BLANKS REQUIRED TO PAD STRING
	CLR	LOOPX+1
	LDD	S1LEN	FIND LEN(S1) - LEN(S2)
	SUBD	TEMPX
	BCS	STORES3	B/ S1 IS SMALLER, USE ITS LENGTH
	LDX	R2SDC1,S	S1 IS LARGER, IS TARGET "THE ENTIRE STRING" ?
	CPX	#$FFFF	...?
	BEQ	STORES2A	B/ YES, DON'T DO BLANK PADDING!
	STD	LOOPX	S1 IS LARGER, SAVE # BLANK PAD CHARACTERS TO INSERT
	LDD	S1ADD	GET ADDRESS OF 1ST BYTE TO STORE INTO
	ADDD	TEMPX	= ADDRESS OF 1ST PLACE TO PUT BLANKS
	STD	CONVERTLIMIT	SAVE WHERE TO PUT BLANKS
STORES2A	LDX	TEMPX	S1 IS LARGER, USE S2 LENGTH
STORES3	STX	LOOPCT	# OF BYTES TO COPY
	LDX	TWORD	SET CURLEN
	LDD	LOOPCT	WATCH ME CARFULLY, I'LL CHEAT YOU IF I CAN...
	STD	CURLEN,X	LOOK WHERE X POINTS ON THIS STORE...
	LDX	LOOPCT
	BEQ	STORES5	HE SAYS DON'T COPY ANY BYTES
	PAGE
	IF	M6800!M6801
	LDD	S1ADD	NOW SEE IF S1ADD <= S2ADD
	SUBD	S2ADD
	BCC	STORES6	B/ S1ADD >= S2ADD
STORES4	LDX	S1ADD	COPY LEFT TO RIGHT, DO FAST MOVE
	LEAX	STRING,X	MAKE S1ADD POINT DIRECTLY TO TARGET STRING
	STX	TEMPX	MOVE EVERYTHING AROUND UNTIL IT MATCHES BLOCKMOVE ARGUMENTS
	LDX	S2ADD	= SOURCE STRING
	LDD	LOOPCT	= # BYTES TO MOVE
	BSR	BLOCKMOVEDOWNS	GO GET 'EM, TIGER!
STORES5 ; STRING COPY COMPLETE, SEE IF BLANK PADDING IS REQUIRED
	LDB	LOOPX+1	= RIGHT HALF OF BLANK COUNT
	BNE	STORES5A	B/ NONZERO, ALL IS FINE.
	LDA	LOOPX	= LEFT HALF OF BLANK COUNT
	BEQ	STORES5B	B/ PAD WITH ZERO BLANKS, ALL DONE!
STORES5A	INC	LOOPX	TO ALLOW QUICK DECREMENT BELOW
	LDX	CONVERTLIMIT	= WHERE TO PUT BLANKS, IF ANY
	LDA	#ASCII:SPACE	GET CHARACTER TO STORE
STORES5L	STA	STRING,X	PAD WITH ONE BLANK
	INX		ADVANCE POINTER TO NEXT PLACE TO PAD
	DECB		DONE PADDING ?
	BNE	STORES5L	B/ NO
	DEC	LOOPX	...?
	BNE	STORES5L	B/ NO
STORES5B ; BLANK PADDING COMPLETE
	JMP	PL2PC1

STORES6	LDD	S2ADD	FAST STRING MOVE WILL SCREW UP...
	ADDD	LOOPCT	IF THE STRINGS OVERLAP
	SUBD	S1ADD	SO FIND OUT IF OVERLAP OCCURS
	BCS	STORES4	B/ STRINGS DON'T OVERLAP, FAST MOVE IS SAFE!
	ADDD	S1ADD	STRINGS OVERLAP, SHUFFLE BYTES RIGHT TO LEFT
	STD	S2ADD	= ADDRESS OF RIGHTMOST BYTE TO MOVE
	LDD	S1ADD	COPY RIGHT TO LEFT
	ADDD	LOOPCT
	STD	S1ADD
	LDB	LOOPCT+1	SET UP TO DECREMENT LOOPCT QUICKLY
	BEQ	STORES7	B/ DON'T HAVE TO INC UPPER HALF
	INC	LOOPCT
STORES7	LDX	S2ADD	SHUFFLE BYTES THE SLOW WAY...
	DEX
	LDA	STRING,X
	STX	S2ADD
	LDX	S1ADD
	DEX
	STA	STRING,X
	STX	S1ADD
	DECB		DECREMENT # BYTES TO MOVE
	BNE	STORES7
	DEC	LOOPCT
	BNE	STORES7
	BRA	STORES5
	ELSE	(M6809)
	LDY	S1ADD	GET TARGET STRING ADDRESS
	LEAY	STRING,Y	MAKE TARGET POINT TO STRING BODY
	LDX	S2ADD	= SOURCE STRING ADDRESS
	LDD	S1ADD
	SUBD	S2ADD	NOW SEE IF S1ADD <= S2ADD
	BCS	STORES6	B/ S1ADD >= S2ADD	
	LDD	LOOPCT
	BSR	BLOCKMOVEUPS
	BRA	STORES5

STORES6	LDD	LOOPCT
	BSR	BLOCKMOVEDOWNS
STORES5 ; STRING COPY COMPLETE, SEE IF BLANK PADDING IS REQUIRED
	LDB	LOOPX+1	= RIGHT HALF OF BLANK COUNT
	BNE	STORES5A	B/ NONZERO, ALL IS FINE.
	LDA	LOOPX	= LEFT HALF OF BLANK COUNT
	BEQ	STORES5B	B/ PAD WITH ZERO BLANKS, ALL DONE!
STORES5A	INC	LOOPX	TO ALLOW QUICK DECREMENT BELOW
	LDX	CONVERTLIMIT	= WHERE TO PUT BLANKS, IF ANY
	LEAX	STRING,X	(= ADDRESS OF 1ST BYTE TO BLANK PAD)
	LDA	#ASCII:SPACE	GET CHARACTER TO STORE
STORES5L	STA	,X+	PAD WITH ONE BLANK
	DECB		DONE PADDING ?
	BNE	STORES5L	B/ NO
	DEC	LOOPX	...?
	BNE	STORES5L	B/ NO
STORES5B ; BLANK PADDING COMPLETE
	JMP	PL2PC1
	FIN
	IF	M6800!M6801
FROMPOINTER	EQU	2
TOPOINTER	EQU	0
BLOCKMOVEDOWNX	EQU	4	TEMPHOLDING AREA
LIMIT	EQU	6

BLOCKMOVEDOWNS	LEAX	STRING,X	MOVESTRING, COMPUTE POINTER TO 1ST BYTE
*
*	BLOCKMOVEDOWN -- MOVE BLOCK AT (X) TO (Y) FOR (D) BYTES
*	(Y) = LOCATION ZERO
*	COPIES LARGE BLOCKS AT 17uS. PER BYTE
*
BLOCKMOVEDOWN	EQU	*
	STX	FROMPOINTER	SAVE WHERE TO COPY FROM
	ADDD	FROMPOINTER	COMPUTE ADDRESS OF BYTE PAST END OF FROM RE
	STD	LIMIT	SAVE AS LIMIT ADDRESS
	SUBB	FROMPOINTER+1	(B):= COUNT MOD 256
	ANDB	#%00000011	GOING TO MOVE TO A MULTIPLE OF 4 BYTES ?
	BEQ	BLOCKMOVEDOWNA	B/ YES
*
*	MOVE 1 BYTE AT A TIME UNTIL A MULTIPLE OF 4 BYTES TO MOVE REMAINS
*	COPY RATE = 43uS. PER BYTE
*
BLOCKMOVEDOWN1	LDA	,X+	FETCH BYTE FROM FROM AREA
	STX	FROMPOINTER
	LDX	TOPOINTER	STORE BYTE INTO "TO" AREA
	STA	,X+
	STX	TOPOINTER
	LDX	FROMPOINTER	GET SET FOR NEXT LOOP ITERATION
	DECB		DOWN COUNT # BYTES LEFT MOVE, 1 AT A TIME
	BNE	BLOCKMOVEDOWN1	B/ MOVE SOME MORE THIS WAY
BLOCKMOVEDOWNA	LDB	FROMPOINTER+1	DO WE STILL HAVE TO MOVE A MULTIPLE OF 16 BYTES
	SUBB	LIMIT+1	(B):= COUNT MOD 256
	BITB	#%00001111	....?
	BEQ	BLOCKMOVEDOWNB	B/ YEP.
*
*	MOVE 4 BYTES AT A TIME UNTIL A MULTIPLE OF 16 IS LEFT TO MOVE
*	COPY RATE IS 23.5 uS. PER BYTE
*
BLOCKMOVEDOWN4	LDD	2,X	GET 2ND AND 3RD BYTE...
	LDX	,X	AND 1ST AND 2ND BYTES FROM THE "FROM" AREA
	STX	BLOCKMOVEDOWNX	SAVE 1ST AND 2ND BYTES
	LDX	TOPOINTER	NO STORE 4 BYTES TO "TO" AREA
	STD	2,X	STORE 2ND AND 3RD BYTE
	LDD	BLOCKMOVEDOWNX
	STD	,X	STORE 1ST AND SECOND BYTES
	LDB	TOPOINTER+1	ADVANCE POINTERS BY 4 BYTES
	ADDB	#4
	STB	TOPOINTER+1
	BCC	*+5
	INC	TOPOINTER
	LDB	FROMPOINTER+1
	ADDB	#4
	STB	FROMPOINTER+1
	BCC	*+5
	INC	FROMPOINTER
	LDX	FROMPOINTER	SET UP FOR NEXT LOOP ITERATION
	IF	M6800
SAVESPACE	EQU	1
	ELSE	M6801!M6809
SAVESPACE	EQU	0
	FIN

	IF	SAVESPACE
BLOCKMOVEDOWNB	CPX	LIMIT	ALL DONE MOVING BYTES ?
	BNE	BLOCKMOVEDOWN4	B/ NO, GO MOVE SOME MORE!
	ELSE
	SUBB	LIMIT+1	MULTIPLE OF 16 BYTES LEFT TO MOVE ?
	BITB	#%00001111	....?
	BNE	BLOCKMOVEDOWN4	B/ NOPE, MOVE ANOTHER 4 BYTES
BLOCKMOVEDOWNB	CPX	LIMIT	YES, ALL DONE MOVING BYTES ?
	BEQ	BLOCKMOVEDOWND	B/ YES, LEAVE!
*
*	MOVE 16 BYTES AT A TIME UNTIL TRANSFER IS COMPLETE
*	COPY RATE IS 17.1 uS. PER BYTE
*
BLOCKMOVEDOWN16	EQU	*
	LDD	0+2,X	COPY 1ST 4 BYTES
	LDX	0+0,X
	STX	BLOCKMOVEDOWNX
	LDX	TOPOINTER
	STD	0+2,X
	LDD	BLOCKMOVEDOWNX
	STD	0+0,X
	LDX	FROMPOINTER	COPY 2ND GROUP OF 4 BYTES
	LDD	4+2,X
	LDX	4+0,X
	STX	BLOCKMOVEDOWNX
	LDX	TOPOINTER
	STD	4+2,X
	LDD	BLOCKMOVEDOWNX
	STD	4+0,X
	LDX	FROMPOINTER	COPY 3RD GROUP OF 4 BYTES
	LDD	8+2,X
	LDX	8+0,X
	STX	BLOCKMOVEDOWNX
	LDX	TOPOINTER
	STD	8+2,X
	LDD	BLOCKMOVEDOWNX
	STD	8+0,X
	LDX	FROMPOINTER	COPY 4TH GROUP OF 4 BYTES
	LDD	12+2,X
	LDX	12+0,X
	STX	BLOCKMOVEDOWNX
	LDX	TOPOINTER
	STD	12+2,X
	LDD	BLOCKMOVEDOWNX
	STD	12+0,X
	LDB	TOPOINTER+1	ADVANCE POINTERS BY 16 BYTES
	ADDB	#16
	STB	TOPOINTER+1
	BCC	*+5
	INC	TOPOINTER
	LDB	FROMPOINTER+1
	ADDB	#16
	STB	FROMPOINTER+1
	BCC	*+5
	INC	FROMPOINTER
	LDX	FROMPOINTER	CHECK TO SEE IF COPY IS COMPLETE
	CPX	LIMIT	AT LIMIT OF "FROM" REGION ?
	BNE	BLOCKMOVEDOWN16	B/ NO, GO MOVE ANOTHER 16 BYTES
	FIN	SAVESPACE
BLOCKMOVEDOWND	RTS
	PAGE
	ELSE	(M6809)
	PAGE
BLOCKMOVEDOWNS	LEAX	STRING,X	MOVESTRING, COMPUTE POINTER TO 1ST BYTE
*
*	BLOCKMOVEDOWN -- 6809 VERSION (5 uS./byte, average)
*	(X) = from address
*	(Y) = to address
*	(D) = count (0..65535)
*	ASSUMES THAT COPY-TO REGION DOES NOT OVERLAP COPY-FROM REGION,
*	OR THAT "FROM" >= "TO".
*
BLOCKMOVEDOWN	LEAU	D,X	COMPUTE END OF TRANSFER ADDRESS
	PSHS	U	SAVE ON STACK
	BITB	#1	TAKE CARE OF "ODD" BYTE
	BEQ	BLOCKMOVEDOWN0
	LDA	,X+	MOVE ODD BYTE
	STA	,Y+	THEN WE CAN IGNORE LSB OF D
BLOCKMOVEDOWN0
	COMB		MAP BITS 3-1: 0->7,1->6,...,N->7-N
	ANDB	#%1110	BRANCH INTO COPY LOOP...
	LSLB		AT PROPER POINT
	LDU	#BLOCKMOVEDOWNLOOP+4
	JMP	B,U	MULTIPLE OF 16 TAKES US TO CMPX 0,S

BLOCKMOVEDOWNLOOP
	LDD	,X++	(CAN'T GET HERE DIRECTLY FROM JMP B,U)
	STD	,Y++
	LDD	,X++	1110
	STD	,Y++
	LDD	,X++	1100
	STD	,Y++
	LDD	,X++	1010
	STD	,Y++
	LDD	,X++	1000
	STD	,Y++
	LDD	,X++	0110
	STD	,Y++
	LDD	,X++	0100
	STD	,Y++
	LDD	,X++	0010
	STD	,Y++
	CMPX	,S	0000
	BNE	BLOCKMOVEDOWNLOOP
	LEAS	2,S	POP LIMIT ADDRESS
	RTS
	PAGE
BLOCKMOVEUPS	LEAX	STRING,X	MOVESTRING, COMPUTE POINTER TO 1ST BYTE
*
*	BLOCKMOVEUP -- 6809 VERSION ( 5 uS./byte, average)
*	(X) = from address
*	(Y) = to address
*	(D) = count (0..65535)
*	Assumes that Copy-to region does not overlap Copy-from region,
*	or that "FROM" <= "TO"
*
BLOCKMOVEUP
	PSHS	X	SAVE THE LIMIT ADDRESS
	LEAX	D,X	COMPUTE POINTER PAST END OF REGION TO COPY FROM
	LEAY	D,Y	COMPUTE POINTER PAST END OF REGION TO COPY TO
	BITB	#1	TAKE CARE OF ODD BYTE
	BEQ	BLOCKMOVEUP0	B/ NO ODD BYTE
	LDA	,-X	MOVE THE ODD BYTE
	STA	,-Y
BLOCKMOVEUP0	; NOW SET UP TO TRANSFER BYTES IN PAIRS
	COMB		BRANCH INTO LOOP THAT COPIES 16 BYTES PER ITERATION
	ANDB	#%1110	IGNORE "ODD" BIT; WE ALREADY TOOK CARE OF THAT CASE
	LSLB		BRANCH WILL BE TO MULTIPLE OF 4 BYTES (LDD --X, STD --Y)
	LDU	#BLOCKMOVEUPLOOP+4
	JMP	B,U	MULTIPLE OF 16 TAKES US TO CMPX 0,S

BLOCKMOVEUPLOOP
	LDD	,--X	(CAN'T GET HERE DIRECTLY FROM JMP B,U)
	STD	,--Y
	LDD	,--X	1110
	STD	,--Y
	LDD	,--X	1100
	STD	,--Y
	LDD	,--X	1010
	STD	,--Y
	LDD	,--X	1000
	STD	,--Y
	LDD	,--X	0110
	STD	,--Y
	LDD	,--X	0100
	STD	,--Y
	LDD	,--X	0010
	STD	,--Y
	CMPX	,S	0000
	BNE	BLOCKMOVEUPLOOP
	LEAS	2,S	POP LIMIT ADDRESS
	RTS
	FIN
	PAGE	*****  C O N T R O L  *****
*	"BASIC" SYSCALL SUBROUTINE INTERFACE
*
XOPSYSCALL1ARG	EQU	*
	TSX
	BSR	SYSCALLCHOOSESCBLK
	CLR	SCBLK:WRLEN,X	ZERO THE WRITE BUFFER LENGTH
	CLR	SCBLK:WRLEN+1,X
SYSCALL1OR2ARG	EQU	*
	CLR	SCBLK:RDLEN,X	NO REPLY BUFFER, MAKE ITS LENGTH ZERO
	CLR	SCBLK:RDLEN+1,X
	LDX	#0
	STX	SYSCALLSTRHEADPTR
SYSCALLDOIT	EQU	*
	LDX	TEMPX	NOW CLEAN OFF THE STACK
	TXS
	LDX	SYSCALLBLOCKPTR
	CLR	SCBLK:RPLEN,X	ZERO THE REPLY LENGTH IN CASE 
	CLR	SCBLK:RPLEN+1,X	SDOS DOESN'T SET IT
	LDA	SCBLK:PARAMS,X	SAVE CHANNEL # GIVEN IN OPCODE STRING
	STA	TBYTE
	LDA	CHANEL	IS CHANNEL SELECTED <>0?
	BEQ	SYSCALLDOIT0
	STA	SCBLK:PARAMS,X
SYSCALLDOIT0	JSR	SYSCALL$
	BCS	SYSCALLDOIT1	B/ ERROR OCCURRED
	LDX	#0	NO ERROR, PICK UP APPROPRIATE ERROR CODE
SYSCALLDOIT1	EQU	*
	STX	TEMPX	SAVE THE ERROR CODE TEMPORARILY
	LDX	SYSCALLBLOCKPTR	SET REPLY BUFFER LENGTH
	LDD	SCBLK:RPLEN,X
	LDX	SYSCALLSTRHEADPTR	WAS REPLY BUFFER A STRING OR SUBSTRING ?
	BEQ	SYSCALLDOIT2	B/ WAS SUBSTRING, CAN'T SET "LEN"
	STD	CURLEN,X	SET LEN(READBUFFER$) TO REPLY LENGTH
SYSCALLDOIT2	EQU	*
	LDX	SYSCALLBLOCKPTR	RESTORE CHANNEL # BYTE TO ORIGINAL VALUE
	LDA	TBYTE
	STA	SCBLK:PARAMS,X
	LDD	TEMPX	...
	BNED	SYSCALLDOIT4
	JMP	PL1PC1	ALL IS OK!
SYSCALLDOIT4	EQU	*
	JMP	IOERROR	TO THE "BASIC" ERROR HANDLER ENTRY POINT
	PAGE
SYSCALLCHOOSESCBLK	EQU	*
	JSR	SYSCALLGETSTRING	DETERMINE SIZE AND LOCATION OF SYSCALL OPCODE
	CMPD	#SCBLK:DATA	IS USER STRING LARGE ENOUGH ?
	BCC	SYSCALLCHOOSE1	B/ YEP, USE IT DIRECTLY
	LDD	,X	NO, GRAB CRITICAL 4 BYTES OF SYSCALL
	LDX	2,X
	STD	SYSCALLBLOCK	AND SAVE IN WORKING TEMP
	STX	SYSCALLBLOCK+2
	LDX	#SYSCALLBLOCK	REMEMBER WHERE WORKING STRING IS GOING TO BE
SYSCALLCHOOSE1	EQU	*	REMEMBER SYSCALL BLOCK ADDRESS
	STX	SYSCALLBLOCKPTR
	RTS

SSB13J	JMP	SSB13

XOPSYSCALL4ARG	EQU	*
	JSR	RNDTOS	B/ NOT AN INT --> SUBSCRIPT OUT OF RANGE!
	FDB	SSB13	GET READ-BACK BUFFER MAX LENGTH
	STD	TWORD
	TSX		SET UP RDBUF POINTER
	BSR	SYSCALLGETRDBUF	GET READ BUFFER ADDRESS AND SIZE
	CMPD	TWORD	CHECK GIVEN LENGTH AGAINST MAX
	BCS	SSB13J	B/ GIVEN > STRLENGTH!
	LDD	TWORD	OK, GIVEN VALUE IS LEGAL SO USE IT!
	BRA	SYSCALL3ARGA	GO FINISH THE SYSCALL
	PAGE
XOPSYSCALL3ARG	EQU	*
	TSX
	BSR	SYSCALLGETRDBUF	GET READ BUFFER ADDRESS AND SIZE
SYSCALL3ARGA	EQU	*	(A,B) = READ BUFFER MAX LENGTH
	STD	SYSCALLRDLEN
	BSR	SYSCALLGETNEXTSTRING	= WRBUF DESCRIPTOR
	BSR	SYSCALLGETWRBUF1	AND SAVE THE PARAMETERS
	LDX	TEMPX
	LEAX	RSESIZ,X
	BSR	SYSCALLCHOOSESCBLK	DECIDE WHERE SCBLK IS GOING TO BE
	BSR	SYSCALLSETUPRDBUF	STUFF IN RDBUF PARAMS
	BSR	SYSCALLSETUPWRBUF	STUFF IN WRBUF PARAMS
	JMP	SYSCALLDOIT	YOU GUESS!!
	PAGE
SYSCALLGETRDBUF	EQU	*
	STX	TEMPX	DETERMINE SIZE AND LOCATION OF RDBUF
	LDD	4,X	GET SIZE OF RDBUF STRING
	LDX	2,X	AND ITS LOCATION
	CLR	SYSCALLSTRHEADPTR	ASSUME REFERENCE TO SUBSTRING
	CLR	SYSCALLSTRHEADPTR+1
	CMPD	#$FFFF	REFERENCE TO "WHOLE STRING" ?
	BNE	SYSCALLGETRDBUF1	B/ NO
	STX	SYSCALLSTRHEADPTR	YES, SAVE POINTER TO HEAD OF STRING
	LDD	MAXLEN,X	USE STRING DIMENSION AS MAX READ SIZE
SYSCALLGETRDBUF1	EQU	*
	LEAX	STRING,X
	STX	SYSCALLRDBUF	SAVPOINTER TO REPLY BUFFER AREA
	RTS

SYSCALLSETUPRDBUF	EQU	*	(X)=SYSCALLBLKPTR
	LDD	SYSCALLRDBUF
	STD	SCBLK:RDBUF,X
	LDD	SYSCALLRDLEN
	STD	SCBLK:RDLEN,X
	RTS
	PAGE
SYSCALLGETNEXTSTRING	EQU	*
	LDX	TEMPX
	LEAX	RSESIZ,X
SYSCALLGETSTRING	EQU	*	(X) POINTS TO STRING DESCRIPTOR
	STX	TEMPX	SO WE CAN FIND NEXT ARG IN LIST LATER
	LDD	R1SDC1,X	GET STRING SIZE
	LDX	R1SDA,X	GET STRING ADDRESS
	CMPD	#$FFFF	THE "WHOLE STRING" ?
	BNE	SYSCALLGETSTRING1	B/ NO
	LDD	CURLEN,X	YES, USE CURRENT LENGTH OF STRING
SYSCALLGETSTRING1	EQU	*
	LEAX	STRING,X	COMPUTE POINTER TO 1ST DATA BYTE OF STRING
	RTS

SYSCALLGETWRBUF	EQU	*
	BSR	SYSCALLGETSTRING
SYSCALLGETWRBUF1	EQU	*
	STD	SYSCALLWRLEN
	STX	SYSCALLWRBUF
	RTS
	PAGE
XOPSYSCALL2ARG	EQU	*
	TSX
	BSR	SYSCALLGETWRBUF
	LDX	TEMPX
	LEAX	RSESIZ,X
	JSR	SYSCALLCHOOSESCBLK
	BSR	SYSCALLSETUPWRBUF
	JMP	SYSCALL1OR2ARG

SYSCALLSETUPWRBUF	EQU	*
	LDD	SYSCALLWRBUF	(X) CONTAINS SYSCALLBLKPTR
	STD	SCBLK:WRBUF,X	STUFF WRBUF PARAMS INTO CHOSEN SCBLK
	LDD	SYSCALLWRLEN
	STD	SCBLK:WRLEN,X
	RTS
	PAGE
SYSCALLONUSERCHAN	; PERFORM SYSCALL USING USER CHANNEL
	LDA	CHANEL
SYSCALLONCHANNELA	STA	SCBLK+SCBLK:PARAMS
*	JMP	ISYSCALL
*	I(NTERNAL) SYSCALL
*
*	SUPRESS EOF ERRORS ON CHANNELS 0-31
*	ONLY RETURNS ON ERROR IF CALLING ROUTINE HAS BCS OR BCC
*	AFTER THE JSR (OR BSR).  OTHERWISE TRAPS ERROR TO IOERROR
*
*
ISYSCALL	EQU	*
*
*	FIRST, CLEAR EOF FLAG
*
	CLRA
	CLR	EOFHITFLAG	ASSUME 'NO EOF HIT'
	LDB	SCBLK+SCBLK:PARAMS	CHANNEL #=>0
	BITB	#$E0	B<32?
	BNE	EXECISYSCALL	B/ NO, SO CAN'T DO A THING
	BSR	EOFBGEN	MAKE ME AN EOF BIT AND X-REG
	COMA		MAKE A MASK
	ANDA	,X	RESET 'EOF HIT' BIT
	STA	,X

EXECISYSCALL	LDX	#SCBLK	NOW DO SYSCALL
	JSR	SYSCALL$
	BCS	RATS	B/ GOT AN ERROR	
	RTS		ALL DONE!

	PAGE
RATS	CPX	#ERR:EOFHIT	GET AN EOF ERROR?
	BEQ	TRAPEOF	B/ YES, TRAP IT

*	CHECK FOR BCS OR BCC AFTER JSR

CHECKBCS	STX	TEMPX
	LDA	[0,S]
	ANDA	#$FE
	CMPA	#$24	IS IT?
	BEQ	PASSBACKERROR
SYSCALLERRORED	LDD	TEMPX	NO, SO GIVE ERROR TO BASIC PROGRAM
	JMP	IOERROR

PASSBACKERROR	LDX	TEMPX
	SEC
	RTS

	PAGE
TRAPEOF	LDA	SCBLK+SCBLK:PARAMS	IS IT WITHIN THE PROPER RANGE?
	BITA	#$E0	0..31
	BNE	CHECKBCS
	INC	EOFHITFLAG
	BSR	EOFBGEN
	ORAB	,X
	STB	,X
	CLC		WHAT ERROR?  DID YOU SEE AN ERROR?  I DIDN'T!
	RTS

*	GENERATE X-REG AND MASK FOR CHANNEL IN EOF-TABLE
EOFBGEN	LDB	SCBLK+SCBLK:PARAMS
	ANDB	#7
	CLRA
	SEC

EOFBGEN2	ROLA		GENERATE MASK FOR BIT NUMBER (B)
	DECB
	BPL	EOFBGEN2

	LDB	SCBLK+SCBLK:PARAMS
	LSRB
	LSRB
	LSRB
	IF	M6800!M6801
	ADDB	#EOFTABLE&$FF
	STB	TEMPX+1
	CLR	TEMPX	ASSERT: EOFTABLE+7<=$FF
	LDX	TEMPX
	ELSE	(M6809)
	LDX	#EOFTABLE
	LEAX	B,X
	FIN
	TFR	A,B
	RTS
	PAGE
*
*	BRANCH IF FLAG FALSE
*
XOPBF	LDA	FLAG
	BNE	BT1
XOPJMP	EQU	*
BF0	; UNCONDITIONALLY DO THE BRANCH
	IF	M6800!M6801
	LDX	[BPC]	GET TARGET ADDRESS
	ELSE	(M6809)
	LDX	ILADD,X	A SMIDGEN FASTER THAN THE '00 COULD DO IT
	FIN
	JMP	NTRPTX
*
*	BRANCH IF FLAG TRUE
*
XOPBT	LDA	FLAG
	BNE	BF0
BT1	; UNCONDITIONALLY **DON'T** DO THE BRANCH
	IF	M6800!M6801
	JMP	NTRPT3
	ELSE	(M6809)
	JMP	NTRPT3X
	FIN
*
*	INVERT THE FLAG
*
XOPINV	COM	FLAG	MAPS 0 TO $FF, $FF TO 0
	IF	M6800!M6801
	JMP	NTRPT1
	ELSE	(M6809)
	JMP	NTRPTX
	FIN
	PAGE
*	ON TOS GOTO
*	OPCODE, POINTER TO NEXT INSTRUCTION, ADDR1, ADDR2, ...
*
XOPON	JSR	RNDTOS
	FDB	ONGOTO1	B/ FAILED TO ROUND
	BSR	GOTOS
	BRA	ONGOTO3	ALL IS OK
ONGOTO1	LDX	[BPC]	FALL THRU "ON" STMT
	BRA	ONGOTO4
ONGOTO3	LDX	[TWORD]
ONGOTO4	JMP	NTRPTX
*
*	ON GOSUB
*
XOPONG	JSR	RNDTOS
	FDB	ONGOTO1	B/ FAILED TO ROUND!
	BSR	GOTOS
	BRA	OPONG3
	BRA	ONGOTO1
OPONG3	LDD	[BPC]	GET RETURN ADDRESS
	LDX	[TWORD]	GET WHERE TO GO
	BRA	GOSUB1
	PAGE
*	ON GOTO/GOSUB SUBROUTINE TO DETERMINE TARGET LINE NUMBER (ADDRESS)
*	(D) = ROUNDED VALUE OF "ON" EXPRESSION
*	NON-SKIP EXIT IF OK
*	SKIP EXIT IF INDEX OUT OF RANGE
*
GOTOS	SUBD	#1	CONVERT TO ZERO ORIGIN
	ASLD
	BCS	GOTOS2	B/ # WAS TOO BIG OR WAS ZERO!
	ADDD	BPC
	BCS	GOTOS2
	ADDD	#ILADD+2	DISPLACEMENT TO 1ST TARGET ADDRESS
	BCS	GOTOS2
	CMPD	[BPC]	POINTER TO TARGET BEYOND END OF TARGET ADDRESS LIST ?
	BCC	GOTOS2	B/ YES, FALL THROUGH
GOTOS1	STD	TWORD
	RTS

GOTOS2	PULX		INDEX OUT OF RANGE, TAKE SKIP EXIT
	JMP	2,X
	PAGE
*	GOSUB
*	OPGSB,ADDRESSOFSUBROUTINE
*
XOPGSB	; "GOSUB" OPCODE
	IF	M6800!M6801
	LDX	BPC	ASSERT: (S) = ERRORRECOVERYSTACK at this point
	FIN
	LDD	BPC	COMPUTE RETURN ADDRESS
	ADDD	#ILADD+2
	LDX	ILADD,X
*
*	GOSUB1	-- DO THE GOSUB COMMON WORK
*		(X) = GOSUB TARGET PC
*		(D) = RETURN TARGET PC
*
GOSUB1	; PUSH BPC, LINEADDR ONTO GOSUB STACK
	PSHD		SAVE "BASIC" RETURN ADDRESS
	LDD	LINEADDR	LINE # DERIVABLE FROM STACKED LINE ADDRESS!
	PSHD		SAVE LAST ENCOUNTERED OPLINE ADDRESS
	STS	ERRORRECOVERYSTACK	NEW STACK VALUE FOR ERROR TRAP RECOVERY
	JMP	NTRPTX
	PAGE
*	GOSUB POP
*	TOS HAS # TO POP
*	IF POP TOO MANY, CROAK
*	IF TOS IS ZERO, EMPTY THE ENTIRE STACK
*
XOPGPOP	JSR	RNDTOS
	FDB	RTRN1	CAN'T FIX, YOU DIE!
	STD	LOOPX
	BEQD	OPGPOP0	REAM THE STACK
OPGPOP2
	IF	M6800!M6801
	TSX		POP A GOSUB STACK ENTRY
	DEX		IS STACK FRAME EMPTY ?
	CPX	STACKFRAMEBASE	...?
	ELSE	(M6809)
	CMPS	STACKFRAMEBASE	IS STACK FRAME EMPTY?
	FIN
	BEQ	RTRN1	B/ YES, ERROR THE USER
	LEAS	4,S	NO, GET RID OF A GOSUB STACK ENTRY NOTE: GOSUB POP DOES NOT WORK FOR SUB/FUN RETURN ADDRESSES!
	STS	ERRORRECOVERYSTACK	UPDATE THE STACK ERROR RECOVERY POINT
	LDX	LOOPX
	DEX
	STX	LOOPX
	BNE	OPGPOP2	B/ NEED TO POP ANOTHER....
	BRA	OPGPOP3	ALL DONE

OPGPOP0	LDS	STACKFRAMEBASE	"GOSUB POP 0"
	STS	ERRORRECOVERYSTACK	UPDATE STACK ERROR RECOVERY PART
OPGPOP3	JMP	NTRPT2
	PAGE
*	RETURN
*	POP BPC FROM GOSUB STACK & JUMP
*
XOPRET
	IF	M6800!M6801
	TSX		ANY RETURN ADDRESSES STILL IN THIS STACK FRAME ?
	DEX
	CPX	STACKFRAMEBASE	...?
	ELSE	(M6809)
	CMPS	STACKFRAMEBASE	ANY RETURN ADDRESSES LEFT IN THIS STACK FRAME?
	FIN
	BEQ	RTRN1	B/ NO, CAN'T DO A RETURN HERE!
	PULD		RESTORE LAST LINE OPCODE ENCOUNTERED ADDRESS
	STD	LINEADDR	RESTORE LINE ADDRESS AT TIME OF GOSUB
	PULX		RESTORE BPC AT TIME OF GOSUB
	STS	ERRORRECOVERYSTACK	AND UPDATE RECOVERY TIME STACK VALUE
	JMP	NTRPTX

RTRN1	JSR	RTPERR
	FCB	:GSBUND
*	CALL USER SUBROUTINE
*	(OPCALL)(SUBROUTINE ADDR)(ARG COUNT)
*		NOTE: # ARGS LIMITED TO 255/6 = 42!
*
XOPCALL	BSR	CALLIT
*	CAME BACK! (SUB/FUNS COMPILED BY BASIC DON'T COME BACK HERE)
	BCS	XOPCALLERRED	B/ ERROR IN SUBROUTINE
	LDS	ERRORRECOVERYSTACK	MUST HAVE BEEN USER SUBROUTINE CALL
XOPCALL1	LDB	#3	= DISTANCE TO BUMP BPC
	JMP	NTRADB	GO DO NEXT INSTRUCTION
*
*	OPFNCALL -- CALL USER FUNCTION
*	(OPFNCALL) (FUNCTION ADDR) (ARGUMENT COUNT)
*
XOPFNCALL	BSR	CALLIT	GET THE FUNCTION ADDRESS, DUMMY!
	BCS	XOPCALLERRED	B/ ERROR IN FUNCTION
	LDX	#OPPOLYARG	CALL THE FUNCTION
	JSR	FSTORE	SAVE THE RETURNED VALUE
	LDX	BPC	NOW POP ARG LIST FROM STACK
	LDB	2,X
	ASLB		ARG COUNT * 2
	IF	M6800!M6801	ADD #ARGS*6 TO STACK
	TBA
	ASLA		... * 4
	ABA		... * 6
	STS	TEMPX
	ADDA	TEMPX+1
	BCC	XOPFNCALL1
	INC	TEMPX
XOPFNCALL1	EQU	*
	STA	TEMPX+1
	LDS	TEMPX
	ELSE	(M6809)
	ADDB	2,X	ARG COUNT * 3
	ASLB		* 6
	LEAS	B,S	ASSERT: ARG COUNT < 128/3
	FIN
	LDX	#OPPOLYARG	GET THE RETURNED VALUE BACK
	JSR	FLOAD
	BRA	XOPCALL1
	PAGE
CALLIT	; SUBROUTINE FOR XOPCALL, XOPFNCALL
	IF	M6800!M6801
	LDX	BPC
	FIN
	LDD	ILADD,X	GET SUBROUTINE ADDRESS
	PSHD		PUSH ONTO STACK
	LDA	ILADD+2,X	GRAB ARGUMENT COUNT
	IF	M6800!M6801
	TSX		GET POINTER TO PARAMETER LIST
	LEAX	4,X
	ELSE	(M6809)
	LEAX	4,S
	FIN
	RTS		GO TO SUBROUTINE

XOPCALLERRED	; USER FUNCTION/SUBROUTINE ERRORED!
	LDS	ERRORRECOVERYSTACK	SWITCH TO SAFE STACK POINTER
	STX	ERCODE	SAVE THE ERROR CODE
	JMP	ERROR	AND GO PROCESS THE ERROR!
	PAGE
*	PARAMETERIZED SUBROUTINE/FUNCTION ENTRY POINT
*
*	JSR $106	WITH (A) = # ARGUMENTS PASSED BY CALLER
*	FCB	version
*	FDB	forwardreflabelchain
*	FDB	pointer to first byte of last parameter variable storage
*			Argument variables are allocated contiguously
*	FDB	baseofscalarvariables
*	FDB	address of 1st byte above the data space
*	FCB	#arguments given by SUBROUTINE/FUNCTION definition
*		...basic opcodes...
*
*
*	1) CHECK ARG COUNT AND COMPLAIN IF INCORRECT
*	2) COPY ARGS OFF STACK INTO PARAMETER VARIABLES
*	3) PUSH RETURN ADDRESS (BPC) ONTO STACK ALONG WITH:
*		SCALAR VARIABLE TABLE BASE
*		LAST ENCOUNTERED LINE NUMBER/LABEL OPCODE ADDRESS
*		CURRENT VALUE OF ERROR TRAP ADDRESS
*		OLD STACKFRAMEBASE, ERRORRECOVERYSTACK
*	4) GO DO AN XOPSETLABEL
*
*	NOTE: ON A RETURN STATEMENT, CONTROL IS NOT PASSED BACK TO XOPCALL!
*	THIS IS BECAUSE XOPCALL WILL ATTEMPT TO CLEAN OFF THE STACK,
*	AND THIS WILL HAVE ALREADY BEEN DONE.
*
	IF	OPLINE=$BD
	?can't tell JSR from OPLINE?
	FIN

ARGCOUNTERROR	EQU	*
	LDX	#0	KILL OFF THE ERROR TRAP ADDRESS
	STX	ERTRAP	SO THE ERROR IS FATAL
	JSR	RTPERR
	FCB	:ARGCNTERR

VERSIONERRJ	JMP	VERSIONERROR
	PAGE
SUBFUNENTRY	EQU	*
	LDX	,S	= RETURN ADDRESS FROM JSR
	LDB	RTP:VERSIONNUMBER,X	CHECK VERSION NUMBER
	CMPB	#VERSION
	BNE	VERSIONERRJ	B/ WRONG VERSION NUMBER
	CMPA	RTP:ARGCOUNT,X	IS ARG COUNT CORRECT ?
	BNE	ARGCOUNTERROR	B/ NO, GO YELL AND SCREAM AND DIE...
	STX	BPCSAV	REMEMBER ROUGHLY WHERE BPC IS (CALL SITE)
	LEAS	4,S	POP $106 ENTRY POINT JSR RETURN ADDRESS OFF POP RETURN ADDRESS PUSHED BY OPCALL
	TSTA		ANY ARGS LEFT TO COPY FROM STACK ?
	BEQ	SUBFUN2	B/ NOPE
	LDX	RTP:LASTPARAMADDR,X	GET POINTER TO LAST ARGUMENT VARIABLE
	IF	M6800
SUBFUNL	EQU	*	PARAMETER FILL LOOP
	PULB		COPY ARGUMENT VALUE INTO A PARAMETER VARIABLE
	STB	,X
	PULB
	STB	1,X
	PULB
	STB	2,X
	PULB
	STB	3,X
	PULB
	STB	4,X
	PULB
	STB	5,X
	LEAX	-RSESIZ,X
	DECA
	BNE	SUBFUNL	B/ MORE TO FILL!
	ELSE	(M6800!M6801)
	STA	TBYTE
SUBFUNL	; PARAMETER FILL LOOP
	PULD
	STD	,X
	PULD
	STD	2,X
	PULD
	STD	4,X
	LEAX	-RSESIZ,X
	DEC	TBYTE
	BNE	SUBFUNL	B/ MORE TO FILL!
	FIN
	PAGE
*
*	NOW PUSH OLD CONTEXT
SUBFUN2	EQU	*
	LDX	#CONTEXTEND	DO IT THE COMPACT WAY...
SUBFUN2L	; SINCE WE DON'T DO IT OFTEN
	IF	M6800!M6801
	DEX
	LDA	,X
	ELSE	(M6809)
	LDA	,-X
	FIN
	PSHA
	CPX	#CONTEXTSTART
	BNE	SUBFUN2L
	INC	SUBROUTINENESTING	ANOTHER CONTEXT BLOCK HAS BEEN PUSHED!
	LDX	#0	ANOTHER CONTEXT BLOCK PUSHED
	STX	ERTRAP	NEW ENVIRONMENT --> NEW ERROR TRAP MUST BE SET!
	STS	STACKFRAMEBASE	MARK BASE OF STACK FRAME
	STS	ERRORRECOVERYSTACK	MARK GOSUB LIST AS EMPTY
	LDX	BPCSAV	ROUGHLY WHERE SUBROUTINE ENTRY IS
	JSR	INITCOMMON	GO DO COMMON INIT STUFF
	LDX	BPCSAV
	LEAX	-3,X	= EXACTLY WHERE SUBROUTINE ENTRY IS
	STX	LINEADDR
	LDD	BPCSAV	SET BPC UP SO THAT IT POINTS...
	ADDD	#RTP:FUNSUBPOPCODE	TO 1ST BASIC POPCODE TO BE EXECUTED
	STD	BPC
	CPX	BREAKLINE+VINT1	***PREVENT <ESC> ON FUNCTION ENTRY***
	BEQ	XOPLINE6J	B/ BREAKPOINT REQUIRED (ALLOW ESCAPE)
	LDA	LINEFLAGS	BREAKPOINT NOT DESIRED, TRACE OR SINGLE STEP!
	BNE	XOPLINE6J	B/ TRACE OR SINGLE STEP DESIRED
	JMP	NTRPT1	NORMAL CASE, GO DO NEXT OPCODE

XOPLINE6J	JMP	XOPLINE6	GO PROCESS CURRENT LINEFLAGS
	PAGE
*	FUNRETURN -- RETURN FROM A FUNCTION
*
XOPFUNRET	EQU	*
	LDX	#OPPOLYARG
	JSR	FSTORE
*
*	SUBRETURN -- RETURN FROM A SUBROUTINE
*
XOPSUBRET	EQU	*
	LDX	BPC	GRAB OPCODE BYTE
	IF	M6800!M6801
	DEX
	LDB	,X
	ELSE	(M6809)
	LDB	-1,X
	FIN
	LDS	STACKFRAMEBASE	BYE BYE GOSUBS FOR THIS INCARNATION
	LDX	#CONTEXTSTART	RESTORE CONTEXT FROM STACK
OPSUBRETL	PULA
	STA	,X+
	CPX	#CONTEXTEND
	BNE	OPSUBRETL
	DEC	SUBROUTINENESTING	= # CONTEXT BLOCKS PUSHED
	CMPB	#OPSUBRET	RETURNING FROM A PARAMETERIZED SUBROUTINE ?
	BEQ	OPSUBRET1	B/ YES, GO CLEAN UP
	LDX	#OPPOLYARG	NO, MUST BE RETURNING FROM PARAMETERIZED FUNCTION
	JSR	FLOAD	MOVE RESULT VALUE BACK ONTO VALUE STACK
OPSUBRET1	JMP	XOPCALL1	ALL DONE, CONTINUE EXECUTION IN CALLING ENVIRONMENT
	PAGE
*
*	ENTER ASSEMBLY LANGUAGE
*	JUMPS TO ADDRESS OF OPCODE + 1
*	OPASM
*
XOPASM	; ENTER ASSEMBLY LANGUAGE OPCODE
	IF	M6800!M6801
	LDX	BPC
	FIN
	JMP	,X
*
*	FORWARD REFERENCE LABEL
*	THE VALUE OF THE LABEL IS IN A VARIABLE
*	SO THAT IT CAN BE TREATED THE SAME AS A SCALAR
*
*	OPLFREFL
*	FDB	SCALAR ADDRESS
*	FDB	POINTER TO NEXT OPLFREL OPCODE
*
XOPLFREFL	; FORWARD REFERENCE LABEL OPCODE
	IF	M6800!M6801
	LDX	BPC
	FIN
	DEX		MAKE POINTER TO OPCODE BYTE
	STX	LINEADDR	GOTO ELN NEEDS THIS
	LEAX	5,X	BUMP BPC SO NTRPT1 IS CORRECT EXIT
	STX	BPC
	BRA	XOPLFREFL1
*
*	SINGLE BYTE SET LABEL OPCODE
*
*	OPSETLABEL
*
XOPSETLABEL	; SET LABEL POINT
	IF	M6800!M6801
	LDX	BPC
	FIN
	DEX		MAKE IT POINT TO LABEL OPCODE
	STX	LINEADDR	GOTO ELN NEEDS THIS
	BRA	XOPLFREFL1
	PAGE
*
*	PRLINEADDR -- PRINT LINE NUMBER/ADDRESS OF OPCODE @(X)
*		STORES LINE NUMBER/ADDRESS IN OPPOLYARG
*
PRLINEADDR	EQU	*
	CLR	OPPOLYARG	MAKE "OPPOLYARG" INTO AN INTEGER
	LDA	,X	GET OPCODE SELECTED
	CMPA	#OPLINE	A LINE NUMBER OPCODE ?
	BNE	PRLINEADDR1	B/ NO
	LDX	ILINT+1,X	YES, GRAB THE LINE NUMBER
	STX	OPPOLYARG+VINT1
	JSR	XBCODE	NOW DISPLAY THE NUMBER
	OPLOAD
	FDB	OPPOLYARG
	OPPV
	OPPCR
	OPASM
	RTS

PRLINEADDR1	EQU	*
	STX	OPPOLYARG+VINT1	NOT A LINE NUMBER OPCODE, PRINT THE ADDRESS
	JSR	XBCODE
	OPLOAD
	FDB	OPPOLYARG
	OPHEX
	OPPS
	OPPCR
	OPASM
	RTS
	PAGE
*	SET LINE NUMBER
*	PICK UP 2 BYTES & PUT IN THE LINE # REG
*	CHECK LINE FLAG
*	OPLINE,16BITLINENUMBER
*
XOPLINE	; SET LINE NUMBER OPCODE
	IF	M6800!M6801
	LDX	BPC	BUMP BPC SO NTRPT1 IS CORRECT EXIT
	FIN
	LEAX	2,X
	STX	BPC
	LEAX	-3,X	SET LINEADDR = ADDRESS OF LINE # OPCODE
	STX	LINEADDR
	LDX	ILADD+1,X	GET LINE NUMBER
XOPLFREFL1	CPX	BREAKLINE+VINT1	NO, HIT LINE NUMBER BREAKPOINT?
	BEQ	XOPLINE6	**** HELP HELP! WHAT IF LINE # = LINE ADDRESS OF DIFFERENT LINE? ****
	LDA	LINEFLAGS	REQUEST FOR TRACE/SINGLE STEP ?
	BEQ	XOPLINE0	B/ NO, SEE IF NEW REQUEST ARRIVED
*	NONZERO, MUST BE TRACE OR SINGLE STEP --> PRINT LINE NUMBER
XOPLINE6	EQU	*
	JSR	XBSUBR
	OPZCHN		TO PRINT ON CHANNEL 0
	OPLSC
	FCB	5
	FCC	'Line '
	OPPS
	OPASM
	LDX	LINEADDR
	BSR	PRLINEADDR
	LDX	BPCSAV	RESTORE USER'S BASIC PC
	STX	BPC
	LDX	OPPOLYARG+VINT1
	CPX	BREAKLINE+VINT1
	BEQ	XOPLINE7
	LDA	LINEFLAGS	BREAKPOINT OR SINGLE STEP ?
	BITA	#SSTEPBIT	...?
	BEQ	XOPLINE0	B/ NEITHER, CONTINUE EXECUTION
XOPLINE7	BSR	GETLINEFLAGS	WAIT FOR RESPONSE TO BREAK/SS
	TSTA
	BEQ	XOPLINE7
	BSR	PROCESSLINEFLAGS1	GO PROCESS LINE FLAGS JUST COLLECTED
	JMP	NTRPT1
	PAGE
GETLINEFLAGS	; SUBROUTINE TO GET LINE FLAGS
	JSR	SETSCOP	SETUP TO DO A GETLINEFLAGS CALL
	FCB	SYSCALL:STATUS,14
	FCB	0,SC:GETLINEFLAGS
	JSR	SETSCRDBUF
	FDB	TBYTE,1
	JSR	EXECISYSCALL	DO THE CALL
	BCS	GETLINEFLAGS1	B/ CALL ERRORED, USE HINT AS RESULT
	LDA	TBYTE	GET LINE FLAGS...
GETLINEFLAGS2	CLR	$F0	AND ZAP THE HINT
	RTS

GETLINEFLAGS1	LDA	$F0	USE HINT AS LINEFLAGS
	CPX	#ERR:ILLDEVICEOP	INVALID CALL (NOT VT DRIVER?)
	BEQ	GETLINEFLAGS2	B/ NOT VT DRIVER
	STX	ERCODE	OOOH...SOMETHING IS VERY WRONG!
	JMP	ERRORLDS
	PAGE
XOPLINE0	LDA	$F0	DON'T HAVE TO DISPLAY LINE NUMBER, QUICKLY GET LINE FLAGS
	BEQ	XOPLINE4	B/ NOTHING TO DO, TAKE FAST EXIT
	LDX	LINEADDR	DID WE GET CAUGHT AT THE ERROR TRAP POINT?
	CPX	ERTRAP	...?
	BEQ	XOPLINE4	B/ YES, IGNORE
	BSR	PROCESSLINEFLAGS
XOPLINE4	JMP	NTRPT1	ASSERT: BPC POINTS TO NEXT OP TO EXECUTE

*
*	PROCESSLINEFLAGS -- PROCESS LINE FLAGS
*	MUST NOT BE CALLED IN MIDDLE OF I/O STATEMENT TO NON-ZERO CHANNEL #
*
PROCESSLINEFLAGS	EQU	*
	BSR	GETLINEFLAGS	GET FLAGS TO PROCESS
PROCESSLINEFLAGS1 ; COME HERE WITH (A) = LINE FLAGS TO PROCESS
	LDB	LINEFLAGS	GET CURRENT STATE OF DEBUG INFO
	BITA	#GOBIT	DID HE SAY "GO" ?
	BEQ	XOPLINE8	B/ NO
	ANDB	#\SSTEPBIT	YES, DUMP THE SINGLE STEP BIT
XOPLINE8	BITA	#TRACEBIT
	BEQ	XOPLINE1
	EORB	#TRACEBIT	LOOK! THERE'S SOMETHING TO DO!
XOPLINE1	BITA	#SSTEPBIT
	BEQ	XOPLINE2
	ORAB	#SSTEPBIT
XOPLINE2	STB	LINEFLAGS
	BITA	#ABORTBIT
	BNE	XOPABORT
	BITA	#BREAKBIT
	BEQ	PROCESSLINEFLAGSRTS
	PAGE
GETBREAKPOINT	JSR	XBSUBR
	OPZCHN
	OPLSC
	FCB	17,ASCII:CR,ASCII:BEL
	FCC	'Break on Line? '
	OPPS
	OPASM
	LDX	BPCSAV	RESTORE BPC IN CASE OF CONVERSION ERROR, BELOW
	STX	BPC
	JSR	SETSCOP	ISSUE SYSCALL:READA TO GET BREAKPOINT LINE NUMBER
	FCB	SYSCALL:READA,READA:SCLEN
	FCB	0,1	DO READ FROM CONSOLE IN LINE MODE
	JSR	SETSCRDBUF	PUT REPLY IN "OUTBUF" (A NICE TEMP)
	FDB	OUTBUF,OUTBUFSIZE
	JSR	ISYSCALL	ISSUE THE READ
*** WHAT HAPPENS HERE IF AN I/O ERROR OCCURS ???
	LDX	#OUTBUF	CONVERT THE INPUT TO A LINE NUMBER
	LDD	#OUTBUFSIZE
	JSR	CONVERT
	BRA	GETBREAKPOINT1	B/ CONVERTED OK
	BRA	GETBREAKPOINT	B/ FAILED TO CONVERT PROPERLY

GETBREAKPOINT1	JSR	XBSUBR	STORE THE CONVERTED VALUE
	OPSTORE,#BREAKLINE
	OPASM
	IF	0
*	THIS LITTLE STUNT ALLOWS OVERLAYED BASIC DEBUGGER TO GET CONTROL ON BKPT
	LDA	BREAKLINE
	BPL	--	ONE OF IRA'S UNFINISHED SYMPHONIES ???
	--- CHAIN TO BASIC DEBUGGER ---
	FIN	0
	LDX	BPCSAV
	STX	BPC
	LDA	BREAKLINE	IS BREAKPOINT AN INTEGER?
	BNE	GETBREAKPOINT	B/ NO, ASK AGAIN!
PROCESSLINEFLAGSRTS	RTS
	PAGE
XOPABORT	BSR	RTPERR
	FCB	:ABORT

XOPSTP	BSR	RTPERR
	FCB	:STOP

XOPERRCAUSE	; CAUSE SPECIFIED ERROR CODE
	JSR	RNDTOS
	FDB	FIXTOSERR
	BRA	IOERROR

	PAGE	*****  E R R O R   S T U F F  *****
*	OPGOELN -- GOTO LINE NUMBER IN WHICH LAST ERROR OCCURRED
*
XOPGOELN	EQU	*
	LDX	ERADDR	IS ERROR ADDRESS SET ?
	CLR	ERADDR	CLEAR "ERROR OCCURRED" FLAG
	CLR	ERADDR+1
	STX	TEMPX	DID ERROR REALLY OCCUR ?
	BNE	IOERRSTX	B/ ERROR DID OCCUR, CONTINUE EXECUTION
	BSR	RTPERR	ELN WENT TO UNDEFINED LINE NUMBER!?
	FCB	:UDFLIN
*
*	ERROR STUFF
*
RTPERR	LDB	[,S]	FETCH INLINE ERROR CODE
	CLRA
IOERROR	STD	ERCODE	SAVE ERROR CODE
ERRORLDS	LDS	ERRORRECOVERYSTACK	GET US A CLEAN STACK TO WORK WITH...
	LDX	LINEADDR	SAVE POINTER TO LINE ORIGINATING THE ERROR
	STX	ORIGINALSINADDR
ERROR	LDX	USING	WIPE OUT AN ACTIVE USING STRING
	STX	USINGMAX
	LDX	LINEADDR	SAVE ADDRESS OF LINE OPCODE IN WHICH ERROR OCCURRED
	STX	ERADDR	FOR GOTOELN
	CPX	ERTRAP	IS THE ERROR RECOVERY STUCK IN A LOOP?
	BEQ	ERRPRINT	B/ YES, ABORT HIM
	LDX	ERCODE	IS THIS A "STOP" STATEMENT ?
	BEQ	ERRPRINT	B/ YES, NO ERROR RECOVERY POSSIBLE
	LDX	ERTRAP	IS ERROR TRAPPING ENABLED?
	BEQ	XOPERRST	B/ NO, ABORT HIM
IOERRSTX	JMP	NTRPTX
*
*	OPTRP, STICK ADDRESS IN ERTRAP REG
*	OPTRP,POINTERTOERRORTRAPROUTINE
*
XOPTRP	; SET ON ERROR TRAP TO INLINE ADDRESS
	IF	M6800!M6801
	LDX	BPC
	FIN
	LDX	ILADD,X
	STX	ERTRAP
	JMP	NTRPT3
	PAGE
*	OPERR, Prints Line number/address,
*	sets SDOS Error code, Prints it and exits
*	NOTE: COULD CHAIN TO SPECIAL PGM THAT CONVERTED HEX ADDRESS...
*	FOR LINE NUMBER BACK INTO ORIGINAL LABEL NAME BY LOOKING IT UP...
*	IN THE SYMBOL TABLE PRODUCED BY THE ASSEMBLER
*
*
XOPERRST	TST	SUBROUTINENESTING	IN MAIN PROGRAM ?
	BEQ	ERRPRINT	B/ YES, GO PRINT THE ERROR
	LDS	STACKFRAMEBASE	NO, POP A CONTEXT BLOCK
	LDX	#CONTEXTSTART+2	( LEAVE ERCODE ALONE! )
	LEAS	2,S
XOPERRSTL	PULA
	STA	,X+
	CPX	#CONTEXTEND
	BNE	XOPERRSTL
	DEC	SUBROUTINENESTING	= # PUSHED CONTEXT BLOCKS
	LDS	ERRORRECOVERYSTACK	POP CONTEXT TO GET TO CALLER'S CONTEXT
	BRA	ERROR	GO CHECK FOR ERROR RECOVERY

ERRPRINT	JSR	XBSUBR
	OPZCHN		PRINT ON CONSOLE, PLEEZ...
	OPLSC		LOAD CON STRING DES
	FCB	5
	FCC	'Line '
	OPPS		PRINT THE STRING
	OPASM
	LDX	ORIGINALSINADDR	GET ADDRESS OF ORIGINAL SIN
	JSR	PRLINEADDR	PRINT THE LINE NUMBER/ADDRESS
	JSR	SETSCOP	SET ERROR INTO SDOS SO DO FILES SEE THEM
	FCB	SYSCALL:ERROREXIT
	FCB	SETERROR:SCLEN
	FDB	CHANGED

	LDX	ERCODE
	STX	SCBLK+SCBLK:PARAMS
	JSR	EXECISYSCALL	ASSERT: EOF CONDITION CANNOT OCCUR
	BCS	*	GOOD GRIEF! SDOS DIDN'T KNOW WHAT TO DO!
	PAGE
*
*	EXIT ROUTINE
*
XOPEXIT	JSR	SETSCOP
	FCB	SYSCALL:EXIT
	FCB	EXIT:SCLEN
	FDB	IGNORED

	JSR	ISYSCALL
*	BRA	*	CAN'T GET HERE NORMALLY
	PAGE	*****  P E E K - P O K E *****
*	PEEK AT ADDRESS SPECIFIED BY TOS INTEGER
*
XOPEEK	LDA	R1TYPE,S
	BNE	PEEK1
	IF	M6800!M6801
	LDX	R1ADD,X
	ELSE	(M6809)
	LDX	R1ADD,S
	FIN
	LDB	BYTE,X
	JMP	LOADB1
*
*	POKE ADDRESS AT TOS-1, BYTE AT TOS
*	NO POKING AT THE INTERPRETER, PLEEZE
*
XOPOKE	JSR	MAKEBOTHLOGICAL	AFTER ALL, ISN'T THAT THE LOGICAL THING TO DO?
	LDD	#BASICRTPEND$
	SUBD	R2ADDH,S
	BCC	POKE4
	IF	M6800!M6801
	LDA	R1INT1,X
	BNE	POKE5
	LDA	R1INT2,X
	LDX	R2ADD,X
	ELSE	(M6809)
	LDA	R1INT1,S
	BNE	POKE5
	LDA	R1INT2,S
	LDX	R2ADD,S
	FIN
	STA	BYTE,X
	JMP	PL2PC1

POKE4	JSR	RTPERR
	FCB	:POKRTP	OUCH! THAT HURT!
POKE5	JSR	RTPERR
	FCB	:POKVAL
PEEK1	JSR	RTPERR
	FCB	:POKADD
	PAGE	*****  F O R - N E X T  *****
*	XOPFOR -- SETS UP A FOR/NEXT LOOP
*	ON THE VALUE STACK IS:
*	TOS	STEP
*	TOS-1	LIMIT
*	TOS-2	INITIAL VALUE FOR LOOP VARIABLE
*	(OPFOR)(OPNEXT ADDR+3)(INDEXVAR ADDR)(STEP/LIMIT VALUE ADDR)
*
XOPFOR
	IF	M6800!M6801
	LDX	BPC
	FIN
	DEX		MAKE BPC POINT TO FOR OPCODE
	STX	BPC
	; ARE STEP, LIMIT, AND INITIAL VALUES ALL INTEGER ?
	LDA	R1TYPE,S	...?
	IF	M6800!M6801
	ORAA	R2TYPE,X
	ORAA	R3TYPE,X
	ELSE	(M6809)
	ORAA	R2TYPE,S
	ORAA	R3TYPE,S
	FIN
	BEQ	FORINT	B/ YES, THIS IS THE EASY CASE!
	JSR	MAKEBOTHFLOAT	NO, FORCE STEP AND LIMIT TO BE FLOATING
	BSR	STORESTEPANDLIMIT	AND SAVE THEM
	JSR	FORCEFLOAT	FORCE INITIAL VALUE TO BE FLOAT
	JMP	NEXTFS	GO SAVE IT AND CHECK AGAINST LIMIT

FORINT	EQU	*	STEP, LIMIT AND INITIAL VALUE ARE ALL INTEGER!
	BSR	STORESTEPANDLIMIT	SAVE STEP AND LIMIT VALUES
	LDX	BPC	STORE INITIAL VALUE
	LDX	ILADD+3,X	GET LOOP INDEX ADDRESS
	JSR	FSTORE	IT DOESN'T HURT TO BE A LITTLE SLOW HERE, WE ONLY DO THIS ONCE!
	LDX	BPC	GET SET TO CHECK INITIAL VALUE AGAINST LOOP LIMIT
	LDX	ILADD+5,X
	LDD	#0	CHEAT: FAKE STEP VALUE OF ZERO FOR BACK DOOR ENTRY
	BRA	NEXTICHECK	GO CHECK LOOP LIMIT
	PAGE
*	STORESTEPANDLIMIT -- COPIES TOS INTO STEP, TOS-1 INTO LIMIT
*
STORESTEPANDLIMIT	EQU	*
	IF	M6800!M6801
	PULD		HIDE THE RETURN ADDRESS
	STD	RTPRET
	ELSE	(M6809)
	PULS	Y
	FIN
	LDB	#RSESIZ*2	= # BYTES TO PULL OFF THE STACK
	LDX	BPC	GET STEP/LIMIT STORAGE ADDRESS
	LDX	ILADD+5,X	POINTER TO PLACE FOR STEP
STORESTEPANDLIMITL	EQU	*
	PULA
	STA	,X+
	DECB
	BNE	STORESTEPANDLIMITL	YOU FIGURE IT OUT
	IF	M6800!M6801
	JMP	[RTPRET]
	ELSE	(M6809)
	JMP	,Y
	FIN
*
*	OPEXITLOOP -- PASS CONTROL TO STMT PAST "NEXT"
*	(OPEXITLOOP) (OPFORADDR )  [ I.E., POINTER TO "OPFOR" FOR MATCHING INDEX VAR)
*
XOPEXITLOOP	EQU	*
	IF	M6800!M6801
	LDX	BPC	FIND THE "FOR" OPCODE
	FIN
	LDX	ILADD,X
	BRA	NEXT1A	THEN FIND THE "NEXT" THAT MATCHES AND EXIT THE LOOP
	PAGE
*	OPNXT -- DO END OF LOOP PROCESSING FOR "FOR/NEXT" LOOP
*	(OPNXT)(OPFOR ADDR FOR MATCHING INDEX VAR)
*
*	NOTE: INTEGER PATH HAS BEEN OPTIMIZED TO DEATH!
*
XOPNEXT	EQU	*
	IF	M6800!M6801
	LDX	BPC	FIND "OPFOR" OPCODE
	FIN
	LDX	ILADD,X
	STX	BPC	AND REMEMBER WHERE IT IS
	LDX	ILADD+5,X	GRAB POINTER TO STEP VALUE
	LDA	FSTYPE,X	IS STEP AN INTEGER ?
	ORAA	FLTYPE,X	(ARE BOTH STEP AND LIMIT INTEGERS ?)
	BNE	NEXTF	B/ NO, FLOATING OPERATIONS ARE REQUIRED
	LDD	FISTEP1,X	MOVE INTEGER STEP TO (A,B)
*	NOTE: IF USER FLOATED THE INDEX VAR, HE'LL BE SORRY!
NEXTICHECK	LDX	FILIM1,X	GRAB LOOP LIMIT
	STX	TEMPX	SAVE IT A MOMENT
	LDX	BPC	NOW ADD LOOP INDEX VALUE...
	LDX	ILADD+3,X	TO STEP VALUE
	TST	VTYPE,X	CHECK FOR EXTREMELY UNUSUAL CASE
	BNE	NEXTIF	B/ USER FLOATED INDEX VARIABLE, SOMEHOW!
	ADDD	VINT1,X	(A,B):= NEXT INDEX VARIABLE VALUE
	BCS	NEXTIOV	B/ NEW INDEX VALUE > 65535, RATS!
	STD	VINT1,X	SAVE UPDATED LOOP INDEX VALUE
	SEC		CHECK: LOOP INDEX VALUE <= LIMIT ?
	SBCB	TEMPX+1	...?
	SBCA	TEMPX	...?
	BCC	NEXTEXIT	B/ NOPE, TIME TO LEAVE THE LOOP!
NEXTITERATION	EQU	*
	LDB	#7	DO NEXT ITERATION OF LOOP, 7 IS LENGTH OF "OPFOR" OPCODE
	JMP	NTRADB	START EXECUTION FOLLOWING OPFOR OPCODE AGAIN
	PAGE
NEXTIOV	PSHD		RATS, LOOP INDEX > 65535: CONVERT TO 4 BYTE INTEGER
	LDD	#1	EQUIVALENT OF CORRECT SUM
	PSHD		("1" = CARRY WE LOST)
	JSR	FLOAT	FLOAT THE RESULT
	LDX	BPC	SAVE IT BACK IN THE INDEX VARIABLE
	LDX	ILADD+3,X
	JSR	FSTORE	ASSERT: LOOP INDEX > LOOP LIMIT
NEXTEXIT	EQU	*
	LDX	BPC	NOW FALL OUT OF THE LOOP...
NEXT1A	LDX	ILADD+1,X	AND START EXECUTION BEYOND "NEXT" OPCODE
	JMP	NTRPTX
*
NEXT1	LDX	BPC	LOOP INDEX < LIMIT
	LDX	ILADD+5,X	NOW CHECK SIGN OF STEP
	LDA	FSTYPE,X
	BPL	NEXTITERATION	B/ SIGN >= 0, DO NEXT ITERATION
	BRA	NEXTEXIT	STEP IS < 0, LOOP IS COMPLETE!
	PAGE
NEXTIF	EQU	*	INDEX VARIABLE IS FLOATING, BUT STEP AND LIMIT AREN'T!!
	LDX	BPC	PUSH LIMIT AND STEP
	LDX	ILADD+5,X	WE'LL DO THE SLOW WAY SINCE THIS HAPPENS ONCE IN A BLUE MOON
	LDB	#RSESIZ*2	# BYTES TO PUSH
NEXTIFL	LDA	RSESIZ*2-1,X
	DEX
	PSHA
	DECB
	BNE	NEXTIFL	YOU FIGURE IT OUT
	JSR	MAKEBOTHFLOAT	FLOAT STEP AND LIMIT
	JSR	STORESTEPANDLIMIT	SAVE THEM AWAY
	LDX	BPC
	LDX	ILADD+5,X
NEXTF	EQU	*	STEP/LIMIT ARE FLOAT, WE ASSUME INDEX VAR IS, TOO!
	JSR	FLOAD	GRAB STEP VALUE
	LDX	BPC	GET INDEX VARIABLE
	LDX	ILADD+3,X
	JSR	FLOAD
	JSR	FORCEFLOAT	JUST IN CASE!
NEXTF1	LDX	#FLOATOVFLOW	IN CASE WE GET OVERFLOW,...
	STX	FPTRAP	WE WANT TO BE PREPARED!
	JSR	FADD	ADD STEP TO INDEX VARIABLE VALUE
NEXTFS	LDX	BPC	AND STORE UPDATED INDEX VAR VALUE
	LDX	ILADD+3,X
	JSR	FSTORE
	LDX	BPC
	LDX	ILADD+3,X
	JSR	FLOAD	NOW CHECK: IS INDEX VAR VALUE PAST LIMIT ?
	LDX	BPC
	LDX	ILADD+5,X
	LDD	FLIM5,X	PUSH LIMIT...
	PSHD
	LDD	FLIM3,X
	PSHD
	LDD	FLTYPE,X
	PSHD
	JSR	FCMP	I REPEAT, IS INDEX VAR PAST LIMIT ?
	BLT	NEXT1	B LOOP INDEX < LIMIT
	BEQ	NEXTITERATION	B/ LOOP INDEX = LIMIT EXACTLY (UNUSUAL!!)
	LDX	BPC	LOOP INDEX > LIMIT, NOW CHECK SIGN OF STEP
	LDX	ILADD+5,X
	LDA	FSTYPE,X
	BPL	NEXTEXIT	B/ STEP >=0, LOOP IS COMPLETE
	JMP	NEXTITERATION	B/ STEP < 0, DO NEXT ITERATION
	PAGE	*****  I N P U T  *****
*	XINLINE -- OPCODE TO READ IN AN ASCII LINE AT BEGINNING OF "INPUT" STATEMENT
*	READ CHARS INTO CATBUF ON CURRENT CHANNEL
*	UNTIL CR OR CATMAX (INCLUSIVE)
*	PUT CR IN BUFFER IF READ
*	SET INPTR TO 1ST BYTE OF INPUT LINE
*	CATPTR TO LAST BYTE OF INPUT LINE, +1
*
XOPINL	; INPUT LINE OF TEXT FOR PROCESSING BY REST OF INPUT STATEMENT
	LDA	CHANEL	CHANNEL 0 ?
	BNE	OPINL1	B/ NO, DON'T REQUEST BREAK
	JSR	PROCESSLINEFLAGS	COLLECT TRACE AND SINGLE STEP BITS
*				BREAK REQUEST, ABORT IF ESCAPE
OPINL1	EQU	*
	LDX	BPC
	STX	ILERR	SAVE RECOVERY POINT (+1) IN CASE OF ERROR IN INPUT
	LEAX	2,X	ADVANCE BPC PAST "INLINE" INSTRUCTION
	STX	BPC

	JSR	SETSCOP
	FCB	SYSCALL:READA
	FCB	READA:SCLEN
	FCB	CHANGED,1	**** READ IT IN "LINE MODE"

	LDX	CATBUF
	STX	INPTR	NOTE: INPTR POINTS DIRECTLY TO 1ST DATA BYTE!
	STX	SCBLK+SCBLK:RDBUF

	LDX	CATSIZ
	STX	SCBLK+SCBLK:RDLEN

	JSR	SYSCALLONUSERCHAN

	LDA	EOFHITFLAG	IF EOF HIT, SKIP INPUT STATEMENT
	BNE	XOPINL1

	LDX	SCBLK+SCBLK:RPLEN	INPUT LINE ENDS WITH CR --> DROP THE CR
	DEX		(ASSERT: NOT EOF --> RPLEN >=1)
	STX	SCBLK+SCBLK:RPLEN

	LDD	SCBLK+SCBLK:RPLEN

	ADDD	CATBUF
	TDX
	STX	CATPTR	= INPUT LINE LIMIT
	LDA	,X	FETCH LAST BYTE READ
	CMPA	#ASCII:CR	=CR?
	BNE	CATEN5J	B/ NO <CR> PRESENT ON END OF BUFFER
	LDA	CHANEL	INPUT FROM CHANNEL 0 ?
	BNE	INPUT4	B/ NO, DON'T PROCESS LINE FLAGS AFTER INPUT COMPLETED!
	JMP	XOPLINE0	GO PROCESS ^B, ^T, ^V
*			IF ENTERED WHILE IN INPUT MODE

XOPINL1	LDX	[ILERR]	EOF HIT DURING READ
	JMP	NTRPTX	(X) = WHERE TO GO IF EOF HIT

CATEN5J	JSR	RTPERR
	FCB	:IBUFOVF
	PAGE
*	XOPINP -- INPUT A VALUE TO TOS FROM THE INPUT LINE
*
XOPINP	LDD	CATPTR	CALCULATE # OF CHARS TO EAT (MAX)
	SUBD	INPTR
	LDX	INPTR
	BSR	CONVERT
	BRA	INPUT3	ALL IS OK
	LDX	ERTRAP	INPUT CONVERSION ERROR (SYNTAX OR OVERFLOW)
	BNE	INPUT1	B/ ERROR TRAPPING ENABLED, CAUSE TRAP!
	LDA	CHANEL	INPUT CONVERSION ERROR (SYNTAX OR OVF)
	BEQ	INPUT2
INPUT1	JSR	RTPERR
	FCB	:CONVER

INPUT2	JSR	XBCODE
	OPLSC		LOAD STRING CONSTANT
	FCB	14
	FCB	7	BELL CODE IN ERROR MESSAGE
	FCC	'Input Error!'
	FCB	CR
	OPPS		PRINT STRING
	OPRMPT		PRINT PROMPT
	OPASM		ENTER ASSY LANGUAGE
	LDX	ILERR
	DEX		SO IT POINTS TO "OPINL" OPCODE
	LDS	ERRORRECOVERYSTACK	RECOVER FROM ERROR BY RESETTING STACK TO EMPTY...
	JMP	NTRPTX	AND RE-EXECUTING FROM THE "OPINL" OPCODE

INPUT3	STX	INPTR
INPUT4	JMP	NTRPT1
	PAGE
*	CONVERT -- CONVERT HEX VALUE OR FLOATING POINT NUMBER
*	(X) POINTS TO 1ST BYTE OF STRING TO CONVERT
*	(A,B) CONTAINS # CHARACTERS TO PROCESS
*	RETURNS POINTER TO END OF STRING
*
CONVERT	STD	LOOPCT	
	STX	TEMPX	COMPUTE POINTER PAST STRING
	ADDD	TEMPX
	STD	CONVERTLIMIT
	PULD
	STD	RTPRET
	LDD	LOOPCT	GET THE MAX CHARS TO EAT
	JSR	FCONVI
	BRA	CONVER10	ALL IS OK
	BRA	CONVER11	OVERFLOW
	STX	BUFERP	CONVERSION (SYNTAX) ERROR, TRY HEX NUM
	LDX	LOOPCT	SET UP MAX # TO EAT
	STX	LOOPX
CONVER1	JSR	GETCHAR
	CMPA	#ASCII:SPACE
	BEQ	CONVER1	IGNORE LEADING BLANKS
	CMPA	#ASCII:HT
	BEQ	CONVER1
	CMPA	#':
	BNE	CONVER11	INPUT ERROR
	CLRA
	STA	MS1
	STA	MS2
	STA	MS3	DIGIT COUNT
CONVER2	JSR	GETCHAR
	CMPA	#'0	DIGIT?
	BCS	CONVER6	NOT A DIGIT
	CMPA	#'9
	BHI	CONVER3
	SUBA	#'0
	BRA	CONVER4
CONVER3	ANDA	#%01011111	FOLD UPPER INTO LOWER CASE TO ALLOW LOWER CASE HEX!
	CMPA	#'A	'A'-'F' DIGIT?
	BCS	CONVER6	NOT A DIGIT
	CMPA	#'F
	BHI	CONVER6	NOT A DIGIT
	SUBA	#'A-10
CONVER4	LDB	#1	I SAW A DIGIT
	STB	MS3
	ASLA
	ASLA
	ASLA
	ASLA
	LDB	#4
CONVER5	ASLA
	ROL	MS2
	ROL	MS1
	BCS	CONVER11	OVERFLOW
	DECB
	BNE	CONVER5
	BRA	CONVER2
CONVER6	LDB	MS3
	BEQ	CONVER11	NO DIGITS, INPUT ERROR
	LDD	MS1
	PSHD
	LEAS	-3,S
	CLRB
	PSHB
	LDX	BUFERP
	DEX		BECAUSE OF GETCHAR
CONVER10	CPX	CONVERTLIMIT
	BEQ	CONVER9	B/ YES, JUST LEAVE
	LDA	,X	NO, TRAILING COMMA?
	CMPA	#$2C
	BNE	CONVER9	
	INX		YES, EAT THE COMMA
	IF	M6800!M6801
CONVER9	LDD	RTPRET
	PSHD
	ELSE	(M6809)
CONVER9	JMP	[RTPRET]
	FIN
PROUSRTS	RTS

CONVER11	LDX	RTPRET	SYNTAX OR OVERFLOW ERROR
	JMP	2,X
	PAGE	*****  P R I N T  *****
*
*	WASCII-FOR THOSE WHO CAN AFFORD THE VERY WORST
*
WASCII	STA	CHAR
	PSHB
	JSR	SETSCOP
	FCB	SYSCALL:WRITEA
	FCB	WRITEA:SCLEN
	FCB	CHANGED,IGNORED

	JSR	SETSCWRBUF
	FDB	CHAR
	FDB	1

	PULA
	JMP	SYSCALLONCHANNELA	BYE!

*
*	PRINT PROMPT
*
XOPRMPT	LDA	#'?
	CLRB
	BSR	WASCII
	BRA	XOPPSP	NOW OUTPUT A SPACE (WE KNOW CHANNEL # IS ZERO)
	PAGE
*	PRINT REST OF USING STRING
*	USED BY PRINT USING ... ;
*	DOES NOT OUTPUT A CR
*
XOPPRUS	BSR	PROUS	GO PRINT REST OF USING STRING
	JMP	NTRPT1	AND EXECUTE THE NEXT OPCODE
*
PROUS	JSR	SETSCOP	PRINT OUT REST OF USING STRING
	FCB	SYSCALL:WRITEA
	FCB	WRITEA:SCLEN
	FCB	CHANGED,IGNORED	WHERE STRING STARTS
	LDD	USINGMAX	COMPUTE LENGTH OF STRING
	SUBD	USING
	LDX	USING
	JSR	SYSCALLGETWRBUF1
	LDX	USINGMAX	ADVANCE USING TO MAKE NULL USING STRING
	STX	USING
	LDX	SYSCALLWRLEN	POSTAMBLE = 0 BYTES?
	BEQ	PROUSRTS	B/ YES, DON'T BOTHER!
	JMP	SYSCALLONUSERCHAN
*
*	PRINT CR
*	DUMP OUT REST OF USING STRING IF <> 0
*	FOLLOW BY CR
*
XOPPCR	BSR	PROUS	GO PRINT REST OF USING STRING
	LDA	#CR
	BRA	PRINTA
*
*	PUT A SPACE TO THE OUTPUT
*
XOPPSP	LDA	#BLANK
PRINTA	LDB	CHANEL	OUTPUT CHARACTER IN (A)
	JSR	WASCII
	JMP	NTRPT1
	PAGE
*	RESOLVE THE STRING LENGTH ON TOS; RETURNS RESULT IN (X), TEMPX
*	PRESERVES (A,B)!
*
GSTRCNT	LDX	R1SDC1+2,S
	CPX	#$FFFF
	BNE	GSTRCNT1
	LDX	R1SDA+2,S
	LDX	CURLEN,X
GSTRCNT1	STX	TEMPX	AS ADVERTISED
	RTS
*
*	PRINT STRING POINTED TO BY SD ON TOS
*
XOPPS	JSR	SETSCOP
	FCB	SYSCALL:WRITEA
	FCB	WRITEA:SCLEN
	FCB	CHANGED,IGNORED

	TSX
	JSR	SYSCALLGETWRBUF
	JSR	SYSCALLONUSERCHAN
	JMP	PL1PC1
	PAGE
*	ISFORMAT -- CHECK TO SEE IF (X) POINTS TO A VALID FORMAT STRING
*	(A,B) POINTS TO BYTE PAST END OF STRING
*	RETURNS IF FORMAT, (X) POINTS PAST FORMAT STRING
*	(A) RETURNS LENGTH
*	SETS UP LDOLLAR, LMINUS,LSHARP,DPCOUNT,RSHARP,RMINUS,RCARET...
*	TO APPROPRIATE COUNT AS SPECIFIED BY FORMAT STRING
*	SKIP RETURNS IF NOT A FORMAT
*
ISFORMAT	EQU	*
	STD	ENDFORMAT
	CLRA		INITIALIZE
	STA	LDOLLAR
	STA	LMINUS
	STA	LSHARP
	STA	DPCOUNT
	STA	RSHARP
	STA	RMINUS
	STA	RCARET
*
*	RECOGNIZES LEADING '$' '-' '$-' ''
*
	BSR	GETCHR
	CMPA	#'$
	BNE	ISFRMT2
	INC	LDOLLAR
	BSR	GETCHR
	CMPA	#'-
	BNE	ISFRMT4
ISFRMT1	INC	LMINUS
	BRA	ISFRMT3
ISFRMT2	CMPA	#'-
	BEQ	ISFRMT1
	BRA	ISFRMT4
*
*	THIS SECTION SCANS LEFT SHARPS
*
ISFRMT3	BSR	GETCHR	SCAN OFF LEFT SHARPS
ISFRMT4	CMPA	#'#
	BNE	ISFRMT6
	LDA	LSHARP
	INCA
	STA	LSHARP
	CMPA	#9
	BLS	ISFRMT3
	BSR	GETCHR
ISFRMT6	CMPA	#'.	LOOK FOR DP
	BNE	ISFRMT8	NO DP, NO RIGHT SHARPS
	INC	DPCOUNT
	LDA	LSHARP
	CMPA	#9
	BHI	ISFRMT10	IF ENOUGH #'S FOUND, SKIP NEXT SECTION
ISFRMT7	BSR	GETCHR	LOOK FOR RIGHT SHARPS
	CMPA	#'#
	BNE	ISFRMT8
	LDA	RSHARP
	INCA
	STA	RSHARP
	ADDA	LSHARP
	CMPA	#9
	BLS	ISFRMT7
ISFRMT10	BSR	GETCHR
ISFRMT8	LDB	LDOLLAR
	ORAB	LMINUS
	BNE	ISFRMTD
	CMPA	#'-	CAN HAVE '-', 3-5 CARETS, OR NOTHING
	BNE	ISFRMTA
ISFRMT9	INC	RMINUS
	BRA	ISFRMTF	DONE
	PAGE
*	GETCHR -- USED ONLY BY ISFORMAT...
*	TO FETCH POSSIBLE FORMAT STRING BYTES
*	RETURN 0 IN (A) IF END OF FORMAT STRING HIT
*
GETCHR	
	IF	M6800!M6801
	CLRA
	CPX	ENDFORMAT
	BEQ	GETCHR1
	LDA	,X
GETCHR1	INX
	RTS
	ELSE	(M6809)
	LDA	,X+
	CPX	ENDFORMAT
	BLS	GETCHR1
	CLRA
GETCHR1	RTS
	FIN
*
ISFRMTE	EQU	*	LEFT '-', NO LEFT '$': MAY HAVE '^'S OR NOTHING
ISFRMTA	CMPA	#'^
	BNE	ISFRMTX	DONE
	LDB	#5
	BRA	ISFRMTB1
ISFRMTB	BSR	GETCHR
ISFRMTB1	CMPA	#'^
	BNE	ISFRMTC
	INC	RCARET
	DECB
	BNE	ISFRMTB
	BRA	ISFRMTF

ISFRMTC	LDA	RCARET	VERIFY EXPONENT FIELD >=3 CHARACTERS
	CMPA	#2
	BHI	ISFRMTX
ISFRMTC1	DEX		ASSERT: (A) <=2
	DECA
	BNE	ISFRMTC1
	CLR	RCARET
	BRA	ISFRMTX	DONE
*
ISFRMTD	LDB	LDOLLAR	A STILL HAS CHAR
	ANDB	LMINUS
	BNE	ISFRMTX	DONE
	LDB	LDOLLAR
	BEQ	ISFRMTE	B/ LMINUS MUST BE ON
	CMPA	#'-	LEFT '$', MAY HAVE '-' OR NOTHING
	BEQ	ISFRMT9
ISFRMTX	DEX		HANDLES CASE WHERE UNWANTED CHAR IS PICKED UP
ISFRMTF	LDA	LSHARP
	ADDA	RSHARP
	BEQ	ISFRMTG	AHA! THE NO-LEFT-OR-RIGHT-SHARPS TRICK
	CMPA	#10
	BHI	ISFRMTG	NO GOOD
	ADDA	LDOLLAR
	ADDA	LMINUS
	ADDA	DPCOUNT
	ADDA	RMINUS
	ADDA	RCARET
	STA	FLENGTH	REMEMBER THE FORMAT LENGTH HERE
	RTS

ISFRMTG	PULX		NOT A FORMAT STRING
	JMP	2,X
	PAGE
*	PRINT VALUE ON TOS
*
XOPPV	JSR	FORCEFLOAT
	LDX	#FAC1
	JSR	FCONVO
	STA	LEAD
	STB	SIG
	LDX	USING
	CPX	USINGMAX
	BEQ	PRNTV3

PRNTV1	STX	BEGINFORMAT	SAVE START OF POTENTIAL "FORMAT" STRING
	LDD	USINGMAX
	JSR	ISFORMAT	DOES A FORMAT STRING START AT BEGINFORMAT?
	BRA	PRNTV4	B/ YES
	LDX	BEGINFORMAT	NO
	INX		ADVANCE TO NEXT BYTE OF USING STRING
	CPX	USINGMAX	USING STRING EXHAUSTED?
	BNE	PRNTV1	B/ NO.
	JSR	PROUS	YES, NO FORMAT STRING WAS FOUND
PRNTV3	LDA	LEAD	DO UNFORMATTED PRINT
	LDB	SIG
	LDX	#OUTBUF	THIS IS WHERE TO PUT THE STUFF
	BSR	UFPRINT
	BRA	PRNTV5
	PAGE
PRNTV4	STX	ENDFORMAT	SAVE END OF FORMAT STRING
	LDX	BEGINFORMAT	SET USINGMAX := START OF FORMAT STRING
	LDD	USINGMAX
	STX	USINGMAX
	STD	BEGINFORMAT	SAVE REAL USING MAX
	JSR	PROUS	GO PRINT THE NON-FORMAT PART
	LDX	BEGINFORMAT	RESTORE TRUE END OF "USING" STRING
	STX	USINGMAX
	LDX	ENDFORMAT	END OF LAST FORMAT =...
	STX	USING	START OF REST OF USING STRING
	LDA	LEAD
	LDX	#OUTBUF	THIS IS WHERE TO PUT THE STUFF
	JSR	FPRINT
*
*	PRINT NUMBER
*
PRNTV5	PSHA
	JSR	SETSCOP
	FCB	SYSCALL:WRITEA
	FCB	WRITEA:SCLEN
	FCB	CHANGED,IGNORED

	PULA
	STA	SCBLK+SCBLK:WRLEN+1
	LDX	#OUTBUF
	STX	SCBLK+SCBLK:WRBUF
	JSR	SYSCALLONUSERCHAN
	JMP	NTRPT1
	PAGE
*	UNFORMATTED PRINT
*	SUBROUTINE FOR XOPPV, XOPNUM
*
*	A HAS # OF DIGITS LEFT OF THE DP IF E WERE = 0 (# OF INT DIGITS)
*	B HAS # OF SIGNIFICANT DIGITS (10 - # OF RIGHTMOST ZEROES)
*	X POINTS TO WHERE THE STUFF IS TO BE PUT
*	LDOLLAR CONTAINS LEFT DOLLAR COUNT
*	LMINUS CONTAINS LEFT MINUS COUNT
*	LSHARP CONTAINS LEFT SHARP COUNT
*	DP CONTAINS DP COUNT
*	RSHARP CONTAINS RIGHT SHARP COUNT
*	RMINUS CONTAINS RIGHT MINUS COUNT
*	RCARET CONTAINS RIGHT CARET COUNT
*	FLENGTH CONTAINS LENGTH OF ENTIRE FORMAT
*	FAC1-FAC6	CONTAINS	"S.DDDD"
*	FACEXT1-FACEXT5	CONTAINS	"DDDDDD"
*	MS1-MS6	CONTAINS	"DESXXX"
*	WHERE	S IS A '-' OR '+'
*	. IS A '.'
*	D IS AN ASCII DIGIT IN THE RANGE '0'-'9'
*	E IS A 'E'
*	X IS AN ASCII EXPONENT DIGIT IN THE RANGE '0'-'9'
*	ON EXIT, A RETURNS LENGTH
*	X POINTS PAST OUTPUT
*
*	CASE1	(ZERO)
*	A = 0 & ALL DIGITS ARE ZERO
*	(B = 0 SUFFICIENT)
*	PRINT ' 0'
*
*	CASE2	(INTEGER)
*	10 >= A >= 1 & RIGHTMOST 10-A DIGITS ARE ZERO
*	(A >= B)
*	PRINT SIGN, A DIGITS
*
*	CASE3	(INT W/FRAC)
*	9 >= A >=0 & RIGHTMOST 10-A DIGITS ARE NON-ZERO
*	(A < B)
*	PRINT SIGN, A DIGITS, '.' B DIGITS
*
*	CASE4	(SMALL FRACTION ONLY)
*	-1 >= A >= -5
*	PRINT SIGN, '.' (ABS(A)) ZEROES, B DIGITS
*
*	CASE5	(ALL ELSE)
*	PRINT SIGN, '.', B DIGITS
*	PRINT 'E', ESIGN, UP TO 3 DIGITS LEAD ZERO SUPPRESS
*
UFPRINT	STX	TWORD	REMEMBER WHERE TO PUT THE RESULT
	CLR	TBYTE	CLEAR THE LENGTH COUNTER
	TSTB		ANY SIGNIFICANCE?
	BNE	UFPRNT1	YES
	INCA
UFPRNT0	BSR	UFPRSN	CASE 2, PRINT SIGN
	BSR	UFPRLFT	PRINT LEFT DIGITS
	BRA	UFPRNT6	EXIT
UFPRNT1	CMPA	#10
	BGT	UFPRNT4	GO DO CASE 5
	TSTA
	BLE	UFPRNT3	NOT CASE 2 OR 3, TRY 4
	CBA
	BGE	UFPRNT0	CASE 3
	BSR	UFPRSN	CASE 3, PRINT SIGN
	BSR	UFPRLFT	PRINT LEFT DIGITS
	BSR	UFPRDP	PRINT '.'
	BSR	UFPRRT	PRINT RIGHT DIGITS
	BRA	UFPRNT6	EXIT
UFPRNT3	CMPA	#-6	SEE IF CASE 4, A IS ALREADY FOUND <= 0
	BLE	UFPRNT4
	BSR	UFPRSN	CASE 4, PRINT SIGN
	BSR	UFPRDP	PRINT DP
	BSR	UFPRZR	PRINT THE ZEROES IF ANY
	BSR	UFPRRT	PRINT RIGHT DIGITS
	BRA	UFPRNT6	EXIT
UFPRNT4	BSR	UFPRSN	CASE 5, PRINT SIGN
	BSR	UFPRDP	PRINT '.'
	BSR	UFPRRT
	LDA	#'E
	BSR	UFPR	PRINT 'E'
	LDA	MS3
	BSR	UFPR	PRINT SIGN
	LDX	#MS4
UFPRNT5	LDA	,X
	CMPA	#'0
	BNE	UFPRNT7
	INX
	CPX	#MS6
	BNE	UFPRNT5
UFPRNT8	LDA	,X
UFPRNT7	BSR	UFPR
	INX
	CPX	#MS6+1
	BNE	UFPRNT8
UFPRNT6	LDA	TBYTE
	LDX	TWORD
	RTS
	PAGE
*	SUBROUTINES FOR UFPRINT, FPRINT

*	PRINT SIGN
*
UFPRSN	STA	LOOPCT
	LDA	FAC1
	CMPA	#'-
	BEQ	UFPRSN3
UFPRSN2	LDA	#ASCII:SPACE
UFPRSN3	BSR	UFPR
	LDX	#FAC2
	RTS
*
*	PRINT RIGHT DIGITS
*
UFPRRT1	LDB	RSHARP
UFPRRT	STB	LOOPCT
*
*	PRINT LEFT DIGITS
*
UFPRLFT	LDA	LOOPCT
	BLE	UFPRLFT2
UFPRLFT1	INX
	LDA	,X
	BSR	UFPR
	DECB		ADJUST # OF SIG DIGITS RIGHT OF DP
	DEC	LOOPCT
	BNE	UFPRLFT1
UFPRLFT2	RTS
*
*	PRINT A DECIMAL POINT
*
UFPRDP	LDA	#'.
	BSR	UFPR
	RTS
*
*	PRINT ZEROES
*
UFPRZR	LDA	LOOPCT
	BPL	FPRADSP1
	INCA
	STA	LOOPCT
	CLRA
	BSR	UFPR1
	BRA	UFPRZR
*
*	ADD TO SPACE COUNT
*
FPRADSP	LDB	LMINUS
	BEQ	FPRADSP1
	LDB	FAC1
	CMPB	#'+
	BNE	FPRADSP1
	INCA
FPRADSP1	TSTA		FOR THE BENEFIT OF FORMATTED E-TYPE
	RTS
*
*	PRINT LEADING MINUS IF LMINUS <> 0 & FAC1 = '-'
*
FPRLM	LDA	LMINUS
	BEQ	FPRLM1
	LDA	FAC1
	CMPA	#'-
	BNE	FPRLM1
	BSR	UFPR
FPRLM1	RTS
*
*	PUT THE CHAR INTO THE OUTPUT BUFFER, PRESERVING X, B
*
UFPR1	ADDA	#'0
UFPR	STX	LOOPX
	LDX	TWORD
	STA	,X+
	STX	TWORD
	LDX	LOOPX
	INC	TBYTE
	RTS
	PAGE
*	FORMATTED PRINT
*	SUBROUTINE FOR XOPPV, XOPNUMF
*
*	A HAS # OF DIGITS LEFT OF DP IF E WERE = 0 (SEE FCONVO)
*	X POINTS TO WHERE TO PUT THE STUFF
*	(ISFORMAT SETS UP THE FOLLOWING:)
*	LDOLLAR CONTAINS LEFT DOLLAR COUNT
*	LMINUS CONTAINS LEFT MINUS COUNT
*	LSHARP CONTAINS LEFT SHARP COUNT
*	DP CONTAINS DP COUNT
*	RSHARP CONTAINS RIGHT SHARP COUNT
*	RMINUS CONTAINS RIGHT MINUS COUNT
*	RCARET CONTAINS RIGHT CARET COUNT
*	FLENGTH CONTAINS LENGTH OF ENTIRE FORMAT
*	FAC1-FAC6	CONTAINS	"S.DDDD"
*	FACEXT1-FACEXT5	CONTAINS	"DDDDDD"
*	MS1-MS6	CONTAINS	"DESXXX"
*	WHERE	S IS A '-' OR '+'
*	. IS A '.'
*	D IS AN ASCII DIGIT IN THE RANGE '0'-'9'
*	E IS A 'E'
*	X IS AN ASCII EXPONENT DIGIT IN THE RANGE '0'-'9'
*	ON EXIT A RETURNS LENGTH
*	X POINTS PAST OUTPUT
*
*	CASE 1	E-TYPE FORMAT
*	OVERFLOW IF NO '-' SPEC & VALUE IS NEGATIVE OR
*	ABS(A-LSHARP) > 100 & RCARET < 5 (3 EXP DIGITS) OR
*	100 > ABS(A-LSHARP) > 10 & RCARET < 4 (2 EXP DIGITS)
*	# SPACES = 1 IF LMINUS <> 0 & FAC1 = '+', ELSE = 0
*	PRINT LEADING SPACES
*	PRINT '-' IF LMINUS <> 0 & FAC1 = '-'
*	PRINT LSHARP DIGITS
*	PRINT '.' IF DP <> 0
*	PRINT RSHARP DIGITS (MAY BE NONE)
*	PRINT 'E'
*	LET EXP = A - LSHARP
*	PRINT SIGN(EXP) ('-' OR '+')
*	PRINT RCARET - 2 EXP DIGITS
*
*	CASE 2	NOT E-TYPE FORMAT
*	OVERFLOW IF NO '-' SPEC & VALUE IS NEGATIVE OR
*	A > 0 & LSHARP - A < 0 
*	IF A <= 0 THEN
*	# SPACES = LSHARP (+ 1 IF LMINUS <> 0 & FAC1 = '+')...
*			...-1*SGN(LSHARP)
*	IF A > 0 THEN
*	# SPACES = LSHARP - A (+ 1 IF LMINUS <> 0 & FAC1 = '+')
*	IF NUMBER OF LEADING SPACES > 0, THEN PRINT THEM
*	PRINT '$' IF LDOLLAR <> 0
*	PRINT '-' IF LMINUS <> 0 & FAC1 = '-'
*	PRINT A DIGITS ('0' IF A<=0 & LSHARP<>0 )
*	PRINT '.' IF DP <> 0
*	PRINT RSHARP DIGITS (MAY BE NONE)
*	PRINT '-' IF RMINUS <> 0 & FAC1 = '-', ELSE PRINT ' '
*
FPRINT	STA	LOOPCT
	STX	TWORD
	LDX	#FAC2
	CLR	TBYTE
*
	LDB	LMINUS	CHECK OVERFLOW
	ORAB	RMINUS	SIGN PROBLEM?
	BNE	FPRINT1	NO
	LDB	FAC1	POSSIBLY, SEE IF VALUE IS NEG
	CMPB	#'-
	BNE	FPRINT1
FPRINT10J	JMP	FPRINT10	YES, FILL ASTERISKS
FPRINT1	LDB	RCARET	E FORMAT?
	BNE	FPRINT6	YES
*
*	F-TYPE FORMAT (CASE 2)
*
	TSTA
	BPL	FP1
	LDA	LSHARP
	BRA	FP2
FP1	SUBA	LSHARP	NO, CHECK MORE OVERFLOW
	NEGA
	BMI	FPRINT10J	OVERFLOW
FP2	BSR	FPRADSP
	LDB	LOOPCT	PICK UP A
	BGT	FP10
	LDB	LSHARP
	BEQ	FP10
	DECA
FP10	TAB
	BLE	FPRINT0
FPRINT2	JSR	UFPRSN2	PRINT SPACES
	DECB
	BNE	FPRINT2
FPRINT0	LDA	LDOLLAR	NEED A DOLLAR SIGN PRINTED ?
	BEQ	FPRINT3
	LDA	DOLLARSIGN	USE VALUE FROM FIXED LOCATION SO BRITISH CAN CHANGE IT
	BSR	UFPR
FPRINT3	BSR	FPRLM	PRINT LEAD '-' IF REQUIRED
	LDA	LOOPCT
	BGT	FP11
	LDA	LSHARP
	BEQ	FP13
	CLRA
	BSR	UFPR1
FP11	EQU	*
FP13	JSR	UFPRLFT	PRINT LEAD DIGITS
	LDA	DPCOUNT	PRINT DP
	BEQ	FPRINT4	(NOW LOOPCT <= 0!)
	LDA	#'.
	BSR	UFPR
	LDB	RSHARP	COMPUTE # SIGNIFICANT DIGITS TO PRINT
	ADDB	LOOPCT
	STB	LOOPCT
	BPL	FP3A	B/ SIGNIFICANCE EXISTS
	CLRB		PRINT RSHARP LEADING ZEROS
FP3A	SUBB	RSHARP	PRINT OLD LOOPCT LEAD ZEROS
	BEQ	FP4
FP3	CLRA
	BSR	UFPR1
	INCB
	BNE	FP3
FP4	JSR	UFPRLFT
FPRINT4	LDA	RMINUS	DO TRAILING MINUS IF ANY
	BEQ	FPRINTH	EXIT
	LDA	#ASCII:SPACE
	LDB	FAC1
	CMPB	#'-
	BNE	FPRINT5
	TFR	B,A
FPRINT5	JSR	UFPR
FPRINTH	JMP	FPRINTG	EXIT
*
*	E-TYPE FORMAT (CASE 1)
*
FPRINT6	STA	TEMPB	SIGN EXTEND A INTO TEMPA
	CLRB
	ROLA
	SBCB	#0
	STB	TEMPA
	CLRA		GET LSHARP SIGN EXTENDED
	LDB	LSHARP
	STB	LOOPCT
	SUBD	TEMPA	SUBTRACT 'A'
	PSHD
	BPL	FP5	TAKE ABS(LSHARP - 'A')
	NEGD
FP5	TSTA
	BNE	FPRINT8	ABS(EXPONENT) > 255, NEED 5 CARETS
	CMPB	#99
	BHI	FPRINT8
	CMPB	#9
	BLS	FPRINTB	EXP < 10, WE'RE OK
	LDA	RCARET
	CMPA	#4	EXP >= 10 & < 100, REQUIRES AT LEAST 4 CARETS
	BLT	FPRINT9	ERROR
	BRA	FPRINTB	AT LEAST 4 CARETS, WE'RE OK
FPRINT8	LDA	RCARET
	CMPA	#5	EXP >= 100, REQUIRES 5 CARETS
	BEQ	FPRINTB	5 CARETS, WE'RE OK
FPRINT9	LEAS	2,S
FPRINT10	LDB	FLENGTH	PUT OUT '*'
FPRINTA	LDA	#'*
	JSR	UFPR
	DECB
	BNE	FPRINTA
	BRA	FPRINTG	EXIT
FPRINTB	CLRA
	JSR	FPRADSP
	BEQ	FPRINTC	ANY BLANKS?
	JSR	UFPRSN2	ONLY ONE POSSIBLE
FPRINTC	LDX	#FAC2
	JSR	FPRLM	PRINT LEAD '-' IF REQUIRED
	JSR	UFPRLFT	PRINT LEFT DIGITS
	LDA	DPCOUNT	PRINT DP
	BEQ	FPRINTD
	LDA	#'.
	JSR	UFPR
	JSR	UFPRRT1	PRINT RIGHT DIGITS
FPRINTD	LDA	#'E	PRINT 'E'
	JSR	UFPR
	LDA	SIG	ANY SIGNIFICANCE?
	BNE	FP9	YES
	STA	MEXP	NO, USE EXP 'E+000'
	LEAS	2,S
	BRA	FP6
FP9	PULD
	STB	MEXP	PRINT ESIGN
	BEQ	FP6	EXP = 0, USE '+'
	TSTA
	BPL	FPRINTE	EXPONENT IS NON-ZERO AT THIS TEST
	NEGB
	STB	MEXP
FP6	LDA	#'+	THIS IS REVERSED BECAUSE THE SUBTRACT WAS 
	BRA	FP6A
FPRINTE	LDA	#'-
FP6A	JSR	UFPR
	LDX	#0	MAKE BCD EXPONENT DIGITS IN FAC1 & FAC2
	STX	FAC1
	LDB	#8	8 BITS TO SHIFT
FPRINTF	ASL	MEXP
	LDA	FAC2
	ADCA	FAC2
	DAA
	STA	FAC2
	LDA	FAC1
	ADCA	FAC1
	DAA
	STA	FAC1
	DECB
	BNE	FPRINTF
	LDB	RCARET	SEE HOW MANY EXPONENT DIGITS TO USE
	SUBB	#4
	BEQ	FP7	PRINT 2 EXP DIGITS
	BMI	FP8	PRINT 1 EXP DIGIT
	LDA	FAC1	UPPER NIBBLE MUST BE 0, PRINT 3 EXP DIGITS
	JSR	UFPR1
FP7	LDA	FAC2
	LSRA
	LSRA
	LSRA
	LSRA
	JSR	UFPR1
FP8	LDA	FAC2	ALWAYS PRINT THIS DIGIT
	ANDA	#$F
	JSR	UFPR1
FPRINTG	LDA	TBYTE
	LDX	TWORD
	RTS
	PAGE
*	CHANGE TOS VALUE TO HEX STRING
*
XOPHEX	JSR	FIXTOS	AND DON'T COME BACK IF YOU CAN'T
	LEAS	4,S	TOS FORM IS (X,X,X,X,I,I); DROP X,X,X,X
	LDA	#':
	STA	OUTBUF
	LDX	#OUTBUF+1
	PULA
	BSR	HEX1
	PULA
	BSR	HEX1
	LDA	#5
	BRA	NUM2

*
*	CONVERT BYTE TO ASCII HEX
*
HEX1	TFR	A,B
	LSRA
	LSRA
	LSRA
	LSRA
	BSR	HEX2
	TFR	B,A
	ANDA	#$F
*
*	CONVERT NIBBLE TO HEX DIGIT IN ASCII
*
HEX2	CMPA	#9
	BLE	HEX3
	ADDA	#7
HEX3	ADDA	#$30
	STA	,X+
HEXRTS	RTS
	PAGE
*	NUM$
*	REPLACE TOS VALUE WITH SD
*
XOPNUM	BSR	FORCEFLOAT	MAKE SURE TOS IS FLOATING
	LDX	#FAC1
	JSR	FCONVO	CONVERT IT TO RAW STUFF
	LDX	#OUTBUF
	JSR	UFPRINT	DO UNFORMATTED MASSAGING
NUM2	PSHA
	CLRA
	PSHA
	LDD	#(OUTBUF-4)
	PSHD
	LDA	#1	MAKE EXP BYTE OF SD <> 0
	PSHD
	JMP	NTRPT2
*
*	FORCEFLOAT -- ENSURE THAT TOS IS FLOATING
*
FORCEFLOAT	EQU	*
	LDA	R1TYPE+2,S
	BNE	HEXRTS	B/ ALREADY FLOAT, GO 'WAY
*
*	BFLOAT -- INTERFACE TO FP ROUTINE FLOAT
*
BFLOAT	PULD
	STD	,S
	IF	M6800!M6801
	CLR	2,X
	CLR	3,X
	ELSE	(M6809)
	CLR	2,S
	CLR	3,S
	FIN
	JMP	FLOAT
	PAGE
*	NUMF$ CONVERTS VALUE ON TOS TO SD USING FORMAT STRING SD AT TOS-1
*	FORMAT STRING MUST CONTAIN ONLY VALID # FORMAT
*
XOPNUMF	LDX	R2SDC1,S
	CPX	#$FFFF
	BNE	NUMF0
	CLR	R2SDC1,S	SET FORMAT STRING LENGTH TO CURLEN
	IF 	M6800!M6801
	LDX	R2SDA,X
	ELSE	(M6809)
	LDX	R2SDA,S
	FIN
	LDA	CURLEN,X
	BNE	NUMF1
	LDB	CURLEN+1,X
	STB	R2SDC2,S
NUMF0	LDA	R2SDC1,S
	BNE	NUMF1
	IF	M6800!M6801
	LDB	R2SDC2,X	(A,B):= STRING LENGTH
	LDX	R2SDA,X	GET ADDRESS OF FORMAT STRING
	ELSE	(M6809)
	LDB	R2SDC2,S
	LDX	R2SDA,S
	FIN
	LEAX	STRING,X	= ADDRESS OF START OF FORMAT STRING
	STX	TWORD	NOW SET (A,B):=END OF FORMAT STRING
	ADDD	TWORD	= ADDRESS OF STRING + LENGTH IN BYTES
	JSR	ISFORMAT
	BRA	NUMF2

NUMF1	JSR	RTPERR
	FCB	:FORMAT

NUMF2	CMPA	R2SDC2,S	LENGTH MUST MATCH
	BNE	NUMF1
	BSR	FORCEFLOAT	MAKE SURE ITS FLOATING
	LDX	#FAC1
	JSR	FCONVO	CONVERT TO RAW STUFF
	LDX	#OUTBUF
	JSR	FPRINT
	LDD	#(OUTBUF-4)
	STD	R1SDA,S
	JMP	NTRPT2
	PAGE	*****  I / O  *****
*
*	SET CHANNEL NUMBER TO ZERO
*
XOPZCHN	CLR	CHANEL
	IF	M6800!M6801
	JMP	NTRPT1
	ELSE	(M6809)
	JMP	NTRPTX
	FIN
*
*	COLUMN FUNCTION
*
XOPCOL	JSR	RNDTOS
	FDB	SETCHNERR
	TSTA
	BNE	SETCHNERR
	BSR	GETCOL
	CLRA
	ADDD	#1
	PSHD
	LEAS	-3,S
	CLRA
	PSHA
	JMP	NTRPT2
	PAGE
*
*	GET COLUMN NUMBER
*
GETCOL	PSHB
	JSR	SETSCOP
	FCB	SYSCALL:STATUS
	FCB	STATUS:SCLEN
	FCB	CHANGED
	FCB	SC:GETCOL

	JSR	SETSCRDBUF
	FDB	CHAR
	FDB	1

	PULA
	STA	SCBLK+SCBLK:PARAMS
	JSR	ISYSCALL

	LDB	CHAR
	RTS
	PAGE
*
*	SET CHANNEL NUMBER
*
XOPCHNL	JSR	RNDTOS
	FDB	SETCHNERR
	TSTA
	BNE	SETCHNERR
	STB	CHANEL
	JMP	NTRPT1

SETCHNERR	JSR	RTPERR
	FCB	:CHNLR
	PAGE
*
*	DO TAB TO NEXT PRINT COLUMN
*
XOPTABCOL	LDB	CHANEL
	BSR	GETCOL
COLMN0	SUBB	#18	REDUCE COLUMN COUNT MODULO 18
	BCC	COLMN0
	NEGB		= # BLANKS TO OUTPUT (>=1)
COLMN1	STB	TBYTE
	JSR	SETSCOP	SET UP SYSCALL OPCODE
	FCB	SYSCALL:WRITEA	WRITE ASCII
	FCB	WRITEA:SCLEN
	FCB	CHANGED,IGNORED
COLMNL	; WRITE BLOCKS OF BLANKS
	CLR	SYSCALLWRLEN
	LDB	TBYTE	ASSUME WRITE BUF LENGTH = COUNT
	STB	SYSCALLWRLEN+1
	LDB	#BLANKSTRINGEND-BLANKSTRING
	CMPB	TBYTE	IS ACTUAL STRING SIZE < COUNT ?
	BCC	COLMN4	B/ NO
	STB	SYSCALLWRLEN+1	YES, USE LENGTH OF BLANK CONSTANT
COLMN4	LDX	#BLANKSTRING	SET UP WRITE BUFFER
	STX	SYSCALLWRBUF
	JSR	SYSCALLONUSERCHAN	AND DO THE SYSTEM CALL!
	LDB	TBYTE	SUBTRACT # BLANKS PRINTED...
	SUBB	SYSCALLWRLEN+1	FROM ACTUAL COUNT
	BNE	COLMN1	B/ MOVE TO PRINT.
COLMN3	JMP	NTRPT1
BLANKSTRING	FCC	"                  "
BLANKSTRINGEND	EQU	*
	PAGE
*
*	TAB TO SPECIFIED COLUMN #
*
XOPTAB	JSR	RNDTOS
	FDB	TAB3
	TSTA
	BNE	TAB3
	PSHB
	LDB	CHANEL
	JSR	GETCOL
	INCB		TAB(1) = 1ST PRINT COLUMN
	PULA
	BEQ	COLMN3
	SBA
	BCS	COLMN3
	BEQ	COLMN3
	TFR	A,B
	BRA	COLMN1

TAB3	JSR	RTPERR
	FCB	:TABBIG
	PAGE
*	EOF CHECK
*
XOPEOF	JSR	RNDTOS
	BRA	SETCHNERR
EOF2	TSTA
	BNE	SETCHNERR
*
*	GET EOF STATUS ON CHANNEL (B)
*
	BITB	#$E0	B=0..31?
	BNE	SETCHNERR
	STB	SCBLK+SCBLK:PARAMS
	JSR	EOFBGEN
	BITA	,X
	JMP	NOTEQUALQ
	PAGE
*	DEBUG
*
XOPDBG	JSR	SETSCOP
	FCB	SYSCALL:DEBUG
	FCB	DEBUG:SCLEN
	FDB	IGNORED

	JSR	ISYSCALL
	JMP	NTRPT2
*
*	CLOSE A FILE
*
XOPCLS	JSR	SETSCOP
	FCB	SYSCALL:CLOSE
	FCB	CLOSE:SCLEN
	FCB	CHANGED,IGNORED
	JSR	SYSCALLONUSERCHAN
	JMP	NTRPT1
	PAGE
*	READ A # FROM A FILE
*
XOPRV	JSR	SETSCOP
	FCB	SYSCALL:READB
	FCB	READB:SCLEN
	FCB	CHANGED,IGNORED

	IF	M6800!M6801
	LEAS	-(RSESIZ-1),S
	STS	SCBLK+SCBLK:RDBUF
	DES
	ELSE	(M6809)
	LEAS	-RSESIZ,S
	STS	SCBLK+SCBLK:RDBUF
	FIN
	LDA	#6
	STA	SCBLK+SCBLK:RDLEN+1
	JSR	SYSCALLONUSERCHAN
	JMP	NTRPT1
	PAGE
*	OPEN FILE SPECIFIED BY TOS DESCRIPTOR
*
XOPOPN	JSR	SETSCOP
	FCB	SYSCALL:OPEN
	FCB	OPEN:SCLEN
	FCB	CHANGED,IGNORED

XOPOPN2	JSR	SETSCRDBUF
	FDB	SCRATCH
	FDB	4

	TSX
	JSR	SYSCALLGETWRBUF
	JSR	SYSCALLONUSERCHAN
	JMP	PL1PC1

*
*	CHAIN TO FILE SPECIFIED BY TOS DESCRIPTOR
*
XOPCHAIN	JSR	SETSCOP
	FCB	SYSCALL:CHAIN
	FCB	CHAIN:SCLEN
	FDB	IGNORED
	JMP	XOPOPN2

	PAGE
*	CREATE A FILE SPECIFIED BY TOS DESCRIPTOR
*
XOPCREAT	JSR	SETSCOP
	FCB	SYSCALL:CREATE
	FCB	CREATE:SCLEN
	FCB	CHANGED,IGNORED
	JMP	XOPOPN2

*
*	DELETE FILE WHOSE NAME IS STRING ON TOS
*
XOPDEL	JSR	SETSCOP
	FCB	SYSCALL:DELETE
	FCB	DELETE:SCLEN
	FDB	IGNORED
	JMP	XOPOPN2

	PAGE
*	RENAME FILE NAMED TOS-1 (SD) TO TOS (SD)
*	NEW NAME LENGTH ON TOS, THEN ADDRESS, THEN RETURN ADDRESS
*	X PASSES POINTER TO OLD NAME, A TO OLD NAME LENGTH
*
XOPREN	JSR	SETSCOP
	FCB	SYSCALL:OPEN
	FCB	OPEN:SCLEN
	FCB	CHANGED,IGNORED

	IF	M6800!M6801
	TSX
	STX	TEMPX
	ELSE	(M6809)
	STS	TEMPX
	FIN
	JSR	SYSCALLGETNEXTSTRING
	JSR	SYSCALLGETWRBUF1
	JSR	SETSCRDBUF
	FDB	SCRATCH
	FDB	4

	JSR	FINDACHAN

	JSR	SETSCOP
	FCB	SYSCALL:RENAME
	FCB	RENAME:SCLEN
	FCB	CHANGED,IGNORED

	TSX
	JSR	SYSCALLGETWRBUF

	JSR	SETSCRDBUF
	FDB	SCRATCH
	FDB	4

	JSR	SYSCALLONMYCHAN
	JSR	CLOSEMYCHAN
	JMP	PL2PC1

	PAGE
*	POSITION A FILE TO A SPECIFIED RECORD
*
XOPRESTR	PULA
	TSTA
	BEQ	POS1
	PSHA
	LDX	#FPOINT5
	JSR	FLOAD
	JSR	FADD
	JSR	FIX
	BRA	POS4
	JSR	RTPERR	FILE POSITION IS TOO BIG!
	FCB	:POSERR
POS1	INS		CONVERT TOS TO (0,0,X,X)
	CLR	,S
	IF	M6800!M6801
	CLR	1,X
	ELSE	(M6809)
	CLR	1,S
	FIN
POS4	JSR	SETSCOP
	FCB	SYSCALL:CONTROL
	FCB	SCBLK:RPLEN
	FCB	CHANGED
	FCB	CC:POSITION

	IF	M6800!M6801
	TSX
	STX	SCBLK+SCBLK:WRBUF
	ELSE	(M6809)
	STS	SCBLK+SCBLK:WRBUF
	FIN
	LDX	#4
	STX	SCBLK+SCBLK:WRLEN
	JSR	SYSCALLONUSERCHAN

	LEAS	4,S	DITCH POSITION INTEGER
	JMP	NTRPT1
	PAGE
*
*	WRITE A NUMBER TO A FILE
*
XOPWV	JSR	SETSCOP
	FCB	SYSCALL:WRITEB
	FCB	WRITEB:SCLEN
	FCB	CHANGED,IGNORED

	IF	M6800!M6801
	TSX
	STX	SCBLK+SCBLK:WRBUF
	ELSE	(M6809)
	STS	SCBLK+SCBLK:WRBUF
	FIN
	LDX	#RSESIZ
	STX	SCBLK+SCBLK:WRLEN
	JSR	SYSCALLONUSERCHAN

	JMP	PL1PC1
	PAGE
*	READ A STRING USING TOS SD, READ MAX LENGTH IF COUNT = -1
*
XOPRS	JSR	SETSCOP
	FCB	SYSCALL:READB
	FCB	READB:SCLEN
	FCB	CHANGED,IGNORED

	TSX
	JSR	SYSCALLGETRDBUF
	STD	SCBLK+SCBLK:RDLEN
	JSR	SYSCALLONUSERCHAN
	LDX	SYSCALLSTRHEADPTR
	BEQ	READS2
	LDD	SCBLK+SCBLK:RPLEN
	STD	CURLEN,X
READS2	JMP	PL1PC1
	PAGE
*	WRITE A STRING TO A FILE
*
XOPWS	JSR	SETSCOP
	FCB	SYSCALL:WRITEB
	FCB	WRITEB:SCLEN
	FCB	CHANGED,IGNORED

	TSX
	JSR	SYSCALLGETWRBUF
	JSR	SYSCALLONUSERCHAN
	JMP	PL1PC1

CLOCKSTR	FCC	'CLOCK:'
	PAGE
*	QUICK MULTIPLY (UNSIGNED)
*	A,B CONTAIN MULTIPLICAND
*	X CONTAINS MULTIPLIER, SMALLER PREFERRED
*	A,B WILL CONTAIN RESULT
*	SKIP RETURN IF OVERFLOW
*
MLTPLY	STX	MR1	SAVE MULTIPLIER
	BEQ	MLTPLY0	B/ MULTIPLIER IS 0 --> PRODUCT IS ZERO
	STB	MS2	SAVE LOWER 8 BITS OF MULTIPLICAND
	STA	MS1
	BEQ	MLTPLYA	B/ MS1 IS ZERO!
	LDB	MR1	MAKE SURE MR1=0
	BNE	MOVF	B/ PRODUCT WOULD BE >= 2^16
	LDB	MR2	MR2 MUST BE NON-ZERO HERE!
	IF	M6800
MLTPLYU	BSR	MUL6809	DO 6809 STYLE MULTIPLY OF (A) AND (B)
	ELSE	M6801!M6809
MLTPLYU	MUL
	FIN
	TSTA		IS PRODUCT >= 2^16 ?
	BNE	MOVF	B/ YES, BYE!
	STB	MS1	SAVE UPPER 8 BITS
MLTPLYL	LDA	MS2	MS1 <> 0, DON'T BOTHER CHECKING MS2
	LDB	MR2	MR2 <> 0!
	IF	M6800
	BSR	MUL6809
	ELSE	M6801!M6809
	MUL
	FIN
	ADDA	MS1	ADD PARTIAL PRODUCT FROM OTHER CROSS PRODUCT
	BCS	MOVF	B/ SUM >= 2^16
	RTS		PRODUCT IS OK

MLTPLYA	TSTB		MS1=0, CHECK MS2
	BEQ	MLTPLY0RTS	B/ PRODUCT IS ZERO
	LDA	MR1
	BEQ	MLTPLYL	MS1,MR1 = 0
	JMP	MLTPLYU	MR1, MS2 <>0, GO COMPUTE UPPER CROSS PRODUCT

MLTPLY0	LDD	#0	PRODUCT IS ZERO
MLTPLY0RTS	RTS

MOVF	PULX
	JMP	2,X
	PAGE
	IF	M6800
*
*	MUL6809 -- SUBROUTINE TO SIMULATE 6809 STYLE "MUL" INSTRUCTION
*	(A)*(B) --> (A,B)
*
MUL6809	EQU	*
	STA	TEMPA	SAVE MULTIPLICAND
	RORB		LOOK AT 1ST MULTIPLIER BIT
	BCS	*+3	B/ 1ST BIT IS ONE!
	CLRA		1ST MULTIPLIER BIT IS ZERO, SET PARTIAL PRODUCT TO 0
	LSRA		PERFORM MULTIPLY ITERATION
	RORB
	BCC	*+4
	ADDA	TEMPA
	RORA
	RORB
	BCC	*+4
	ADDA	TEMPA
	RORA
	RORB
	BCC	*+4
	ADDA	TEMPA
	RORA
	RORB
	BCC	*+4
	ADDA	TEMPA
	RORA
	RORB
	BCC	*+4
	ADDA	TEMPA
	RORA
	RORB
	BCC	*+4
	ADDA	TEMPA
	RORA
	RORB
	BCC	*+4
	ADDA	TEMPA
	RORA
	RORB
	RTS
	FIN	M6800
	PAGE	*** T R A N S C E N D E N T A L S *** 
*****  R A N D O M   N U M B E R  G E N E R A T I O N *****
*
*	SET SEED (OPSETSEED): COMPILER STMT "LET RND=exp"
*
XOPSETSEED	JSR	FORCEFLOAT	SO ALL THE SIGNIFICANCE IS IN LEFTMOST 4 BYTES
	LDX	#SEED	AND STORE THE VALUE
	JSR	FSTORE	(XOPRND ONLY USES 1ST 4 BYTES OF "SEED")
	JMP	NTRPT2

*
*	OPRND-- GENERATE RANDOM NUMBER BETWEEN 0 AND 1
*	PUSH VALUE ONTO STACK
*	USES SEED':=(SEED*A+C) MOD M
*	RESULT = SEED'/2^31
*	A = 2^23+2^14+2^2+1, C=1, M=2^31 (SEE KNUTH)
*
XOPRND	LDD	SEED+2	SET SEED':=SEED
	PSHD		(SEED' IS TOP 4 BYTES OF STACK)
	LDA	SEED+1
	PSHA
	LDA	SEED
	PSHA
	TSX		NOW (X) POINTS TO SEED'
	ASLB		TEMP:=SEED*2^2
	ROL	SEED+2
	ROL	SEED+1
	ROL	SEED
	ASLB
	ROL	SEED+2
	ROL	SEED+1
	ROL	SEED
	SEC		SEED':=SEED'+TEMP+1
	TFR	B,A	(B CONTAINS LOWER 8 BITS OF SEED)
	ADCA	3,X
	STA	3,X
	LDA	2,X
	ADCA	SEED+2
	STA	2,X
	LDA	1,X
	ADCA	SEED+1
	STA	1,X
	LDA	,X
	ADCA	SEED
	STA	,X
	ASLB		TEMP:=TEMP*2^12 (=2^8*2^4)
	ROL	SEED+2	(*2^8 ACCOMPLISHED BY IGNORING SEED+0)
	ROL	SEED+1	= SEED*2^14
	ASLB
	ROL	SEED+2
	ROL	SEED+1
	TFR	B,A		SEED':=SEED'+SEED*2^14
	ADDA	2,X
	STA	2,X
	LDA	1,X
	ADCA	SEED+2
	STA	1,X
	LDA	,X
	ADCA	SEED+1
	STA	,X
	ASLB		TEMP:=TEMP*2^9 =  SEED*2^23
	ROL	SEED+2	(*2^8 ACCOMPLISHED BY IGNORING SEED+0,SEED+1)
	LDA	SEED+2
	ADDD	,X	SEED':=SEED'+SEED*2^23
	ANDA	#$7F	... MOD ( 2^31 )
	STD	,X
	STD	SEED	SEED:=SEED'
	LDX	2,X
	STX	SEED+2
	JSR	FLOAT	CONVERT 31 BIT INTEGER TO FLOATING VALUE
	LDX	#FP2TOM31	AND DIVIDE BY 2^31
	JSR	FLOAD
	JSR	FMUL	ACCORDING TO THE MANUAL, HE CAN'T OVERFLOW!
XOPSQXIT	EQU	*
	JMP	NTRPT2
	PAGE	*****  T R A N S C E N D E N T A L S  *****
*
*	OPSQR -- COMPUTE SQUARE ROOT OF TOS
*	ESTIMATES SQR(100^X*M):
*	= 100^(X/2)*SQR(M)	IF X IS EVEN
*	= 100^(X/2)*SQR(M)*10	IF X IS ODD
*	ESTIMATES SQR(M) == SQR(AVERAGE(M)) == SQR(AVERAGE(.01,.99)) == SQR(.5) == .7
*	USES ESTIMATE IN NEWTON-RAPHSON ITERATION TO GET ACTUAL SQUARE ROOT
*
XOPSQERR	JSR	RTPERR	SQRT OF NEGATIVE NUMBER
	FCB	:SQTERR

XOPSQR	LDA	VTYPE,S
	BMI	XOPSQERR	B/ TOUGH SHIT, CHARLIE
	BNE	XOPSQ1	B/ HE'S FLOATING AND NOT ZERO
	IF	M6800
	LDA	VINT1,X	TAKE EASY WAY OUT IF NUMBER IS ZERO
	ORAA	VINT2,X
	ELSEIF	M6801
	LDD	VINT1,X
	ELSE	M6809
	LDD	VINT1,S
	FIN
	BEQ	XOPSQXIT	B/ IT IS
	JSR	BFLOAT	MAKE SURE HE'S FLOATING
XOPSQ1	JSR	XBSUBR	DUPLICATE VALUE SO WE CAN GENERATE ESTIMATE...
	OPDUP		OF SQUARE ROOT
	OPASM		= (VALUE MANTISSA)*100^(EXPONENT/2)
	LDA	VTYPE,S	GO GET THE EXPONENT
	SUBA	#$40	CONVERT FROM EXCESS 64 TO SIGNED
	ASRA		DIVIDE BY 2, PRESERVE SIGN
	LDB	#70	EVEN EXPONENT --> USE .7 AS ESTIMATE
	BCC	XOPSQ2	B/ EVEN EXPONENT
	LDB	#07	ODD EXPONENT --> USE .7*10 AS ESTIMATE
XOPSQ2	ADCA	#$40	CONVERT BACK TO EXCESS 64
	IF	M6800!M6801
	STD	VTYPE,X	TOS NOW HAS VERY ROUGH SQRT
	ELSE	(M6809)
	STD	VTYPE,S	STORE ESTIMATED MANTISSA
	FIN
	LDA	#7	NUMBER OF NEWTON-RAPHSON ITERATIONS
	STA	LOOPCT
XOPSQL	JSR	XBCODE	DO NEWTON-RAPHSON ITERATIONS
	OPSTORE		TTEMP1:=ESTIMATE
	FDB	TTEMP1
	OPDUP		STACK NOW HAS VALUE,VALUE
	OPLOAD		VALUE,VALUE,ESTIMATE
	FDB	TTEMP1
	OPDIV		VALUE,VALUE/ESTIMATE
	OPLOAD		VALUE,VALUE/ESTIMATE,ESTIMATE
	FDB	TTEMP1
	OPADD		VALUE,VALUE/ESTIMATE+ESTIMATE
	OPLOAD		VALUE,(VALUE/ESTIMATE+ESTIMATE),.5
	FDB	FPOINT5
	OPMUL		VALUE,(VALUE/ESTIMATE+ESTIMATE)/2.0
	OPASM		TOS HAS NEW, IMPROVED ESTIMATE
	DEC	LOOPCT
	BNE	XOPSQL	B/ NEED MORE ITERATIONS
	JSR	XBCODE	NO, CLEAN UP
	OPSTORE		TTEMP1:=SQR(VALUE)
	FDB	TTEMP1
	OPSTORE		DUMP THE OLD VALUE
	FDB	TTEMP2
	OPLOAD		GET SQR(VALUE) BACK TO STACK
	FDB	TTEMP1
	OPASM
XBRET2	LDX	BPCSAV	RETURN FROM BASIC SUBROUTINE FOR 2 BYTE OPCODE
	JMP	NTRPT2X
	PAGE
*
*	OPOWER -- COMPUTE TOS-1 (Y) RAISED TO TOS POWER (X)
*
XOPOWER	JSR	XBSUBR	ANALYZE POWER PART
	OPDUP		STORE POWER IN CASE OF Y ^ NON-INTEGER
	OPSTORE
	FDB	TTEMP2
	OPDUP		SIGNZ:=SGN(POWER)
	OPSGN
	OPSTORE
	FDB	SIGNZ
	OPABS		NOW COMPUTE ABS(POWER)
	OPDUP		DIVIDE POWER INTO INTEGER AND FRACTION PARTS
	OPINT		INTX:=INT(X) (**WHAT IF FLOAT ?**)
	OPDUP
	OPSTORE
	FDB	TTEMP1	= INT(ABS(POWER))
	OPEQ		COMPARE INT(X) TO X...
	OPASM		AT THIS POINT STACK CONTAINS ONLY (Y)
	LDA	FLAG	IS EXPONENT AN INTEGER ?
	BEQ	XOPOWER1	NO, DO EXP(LOG(TOS-1)*TOS)
	LDA	TTEMP1	YES, IS IT > 65535 ?
	BNE	XOPOWER1	YES, DO EXP(LOG(TOS-1)*TOS)
	JSR	FORCEFLOAT	NO, GENERATE Y^X BY MULTIPLICATIVE PROCESS
	LDX	#TTEMP2
	JSR	FSTORE
	LDX	#FONE	SET TOS TO F.P. "1"
	JSR	FLOAD
	BRA	XOPEXPINT	GO DO MULTIPLICATIVE PROCESS

XOPOWER1	LDX	BPCSAV	MAKE BPC POINT AT OPEXP OPCODE AGAIN
	STX	BPC
	JMP	XOPLOG	GO DO LOG(Y)
*	THE REST IS DONE BY LOG ROUTINE!
	PAGE
*	OPEXP -- COMPUTE EXPONENTIAL OF TOS
*
XOPEXP	JSR	XBSUBR	COMPUTE EXP(TOS)
XOPEXP0	OPDUP		INVOKE BASIC SUBROUTINE
	OPSGN		SIGNZ=SGN(Z)
	OPSTORE
	FDB	SIGNZ
	OPABS		Z=ABS(Z)
	OPDUP
	OPINT
	OPDUP
	OPSTORE
	FDB	TTEMP1	INTX=INT(X)
	OPSUB		Z=Z-INTZ
	OPPOLY
	FCB	$3D,27,94,87,58,42	EVALUATE POLYNOMIAL FOR EXP(Z)
	FCB	$3E,02,79,99,34,44	0<= Z < 1
	FCB	$3E,24,79,94,01,77
	FCB	$3F,01,98,39,09,35
	FCB	$3F,13,88,88,92,56
	FCB	$3F,83,33,33,61,07
	FCB	$40,04,16,66,66,67
	FCB	$40,16,66,66,66,66
	FCB	$40,50,00,00,00,00
	FCB	$41,01,00,00,00,00
	FCB	$41,01,00,00,00,00
	FCB	0	END OF COEFFICIENT LIST
	OPINIT
	FDB	TTEMP2
	FDB	6
	FCB	$41,02,71,82,81,82	2.71828182 IS E!
	OPASM		NOW COMPUTE RESULT:=RESULT*E^INTX
	LDA	TTEMP1	E TO SOME HUGE NUMBER ?
	BNE	XOPEXPO	YES, GO SEE IF 1/E^HUGE
XOPEXPINT	LDX	#XOPEXPO	MULTIPLY E^FRACTION BY E^INTX
	STX	FPTRAP	IN CASE WE GET OVERFLOW
XOPEXPL	LSR	TTEMP1+VINT1	ANY MORE INTX BITS?
	ROR	TTEMP1+VINT2
	BCC	XOPEXP1	B/ THIS BIT IS ZERO, MAYBE NOT...
	LDX	#TTEMP2
	JSR	FLOAD	ASSERT: TTEMP2 IS F.P FORMAT HERE
	JSR	FMUL	ASSERT: TOS IS F.P. FORMAT HERE
XOPEXP1	LDX	TTEMP1+VINT1	MORE INTEGER POWER BITS?
	BEQ	XOPEXP2	B/ NO, WE'RE DONE WITH INTEGER PART
	LDX	#TTEMP2	EXPN:=EXPN*EXPN
	JSR	FLOAD	ASSERT: TTEMP2 ...
	TSX
	JSR	FLOAD	IS F.P. FORMAT HERE!
	JSR	FMUL
	LDX	#TTEMP2
	JSR	FSTORE
	BRA	XOPEXPL

XOPEXP2	LDA	SIGNZ	E TO THE POSITIVE X ?
	BPL	XBRET2J	B/ YES, STACK HAS CORRECT ANSWER
	BSR	XBCODE	NO, MUST TAKE RECIPROCAL
	OPSTORE
	FDB	TTEMP1
	OPLOAD
	FDB	FONE
	OPLOAD
	FDB	TTEMP1
	OPDIV
	OPASM
XBRET2J	JMP	XBRET2	AND EXIT

XOPEXPERR	JMP	FLOATOVFLOW

XOPEXPO	LDA	SIGNZ	OVERFLOW IN COMPUTING EXP(ABS(TOS))
	BPL	XOPEXPERR	B/ TOS WAS POSITIVE ORIGINALLY
	CLRA		OTHERWISE, ANSWER IS ZERO
	STA	VTYPE,S
	IF	M6800!M6801
	STA	VINT1,X
	STA	VINT2,X
	ELSE	(M6809)
	STA	VINT1,S
	STA	VINT2,S
	FIN
	JMP	XBRET2
*
*	EXIT FROM BASIC "POPCODE" AND START EXECUTION OF NEXT USER POPCODE
*
*XBRET	LDX	BPCSAV	RETURN FROM "BASIC" POPCODE SUBROUTINE
*	JMP	NTRINX	FOR 1 BYTE OPCODE
*
*	EXECUTE SUBROUTINE (TOS) WHICH IS WRITTEN IN "BASIC" OPCODES
*	SAVE CURRENT BPC FOR RESTORATION VIA XBRET OR XBRET2
*
XBSUBR	LDX	BPC
	STX	BPCSAV	EXECUTE BASIC SUBROUTINE
*
*	EXECUTE IN-LINE BASIC CODE
*
XBCODE	PULX		RETURN ADDRESS POINTS TO LIST OF BASIC OPCODES
	JMP	NTRPTX
	PAGE
	PAGE
*
*	XOPLOG -- COMPUTE NATURAL LOGARITHM OF TOS
*
XOPLOGERR	JSR	RTPERR
	FCB	:LOGARG

XOPLOG	LDA	VTYPE,S	COMPUTE NATURAL LOG(TOS) USING BOOK INDEX # 2684
	BMI	XOPLOGERR	B/ LOG OF NEGATIVE NUMBER, SCREW YOU!
	BNE	XOPLOG1	MAKE SURE ARGUMENT IS FLOATING
	IF	M6800
	LDA	VINT1,X	AND THAT IT IS NOT ZERO
	ORAA	VINT2,X
	ELSEIF	M6801
	LDD	VINT1,X
	ELSE	(M6809)
	LDD	VINT1,S
	FIN
	BEQ	XOPLOGERR	OH.... THAT'S BAD NEWS....
	JSR	BFLOAT
XOPLOG1	LDB	VTYPE,S	REDUCE ARGUMENT TO RANGE .01 TO 1
	LDA	#$40
	IF	M6800!M6801
	STA	VTYPE,X
	ELSE	(M6809)
	STA	VTYPE,S
	FIN
	CLRA		SET (A,B) TO POWER OF 100
	SUBD	#$40
	LEAS	-2,S	MAKE STACK SPACE FOR "STD 2,S" BELOW
	PSHA		(SIGN EXTEND TO 4 BYTES)

	PSHA
	ASLD		(A,B) := POWER OF 10
	ASLD		(A,B) := POWER OF SQRT(10)
	STD	2,S
	JSR	FLOAT	FLOAT POWER OF SQRT(10)
	BSR	XBSUBR
XOPLOGL	OPSTORE		STORE POWER OF SQRT(10)
	FDB	TTEMP1	REDUCE ARG TO RANGE...
	OPDUP		1/SQRT(10) TO SQRT(10)
	OPLOAD
	FDB	RECIPSQRT10	1/SQRT(10)
	OPLT		IS ARG < 1/SQRT(10) ?
	OPBF
	FDB	XOPLOG2
	OPLOAD		YES, ARG:=ARG*SQRT(10)
	FDB	RECIPSQRT10
	OPDIV
	OPLOAD
	FDB	TTEMP1	POWER OF SQRT(10):=POWER OF SQRT(10) - 1
	OPLOAD
	FDB	FONE
	OPSUB
	OPJMP
	FDB	XOPLOGL

XOPLOG2	OPLOAD		ARG:=(ARG-1)/(ARG+1)
	FDB	FONE
	OPSUB		(ARG:=ARG-1...)
	OPDUP
	OPLOAD		(GENERATE ARG-1+2 GIVES ARG+1)
	FDB	FTWO
	OPADD
	OPDIV
	OPDUP		X2:=X*X
	OPDUP		(LEAVE ARG ON STACK)
	OPMUL
	OPPOLY		COMPUTE PX OF ARGUMENT
	FCB	$C1,16,96,06,81,38
	FCB	$41,78,83,08,31,87
	FCB	$C1,71,98,16,19,89
	FCB	0
	OPMUL		FORM ARG*PX
	OPLOAD
	FDB	OPPOLYARG
	OPPOLY		COMPUTE QX ON ARG SQUARED
	FCB	$41,01,00,00,00,00
	FCB	$C1,18,41,97,25,31
	FCB	$41,51,41,23,56,27
	FCB	$C1,35,99,08,09,99
	FCB	0
	OPDIV		FORM ARG*PX/QX
	OPLOAD
	FDB	TTEMP1	POWER OF SQRT(10)
	OPLFI		LOGE(SQRT(10))
	FCB	$41,01,15,12,92,55
	OPMUL		ADD POWER OF SQRT(10) * LOGE(SQRT(10))...
	OPADD		TO LOGARITHM OF REDUCED RANGE ARGUMENT
	OPASM
	LDA	[BPCSAV]	DID WE DO "LOG" FOR OPLOG...
	CMPA	#OPLOG&$FF	OR FOR OPOWER?
	BEQ	XOPLOG3	WE DID IT FOR LOG, TIME TO GET OUT
*
*	FOLLOWING CODE FINISHES AN "OPOWER" INSTRUCTION
*
	JSR	XBCODE	LOG(Y) NOW ON STACK...
	OPLOAD		MULTIPLY BY POWER
	FDB	TTEMP2
	OPMUL		FORM LOG(Y)*X
	OPJMP		AND TAKE EXP(RESULT)
	FDB	XOPEXP0

XOPLOG3	JMP	XBRET2	THAT'S IT (WOW...)
	PAGE
*	XOPPOLY-- EVALUATE INLINE POLYNOMIAL ON ARGUMENT (TOS)
*	LEAVES ARGUMENT IN "OPPOLYARG"
*	RETURNS RESULT ON VALUE STACK
*
XOPPOLY	JSR	FORCEFLOAT	EVALUATE INLINE POLYNOMIAL
	LDX	#OPPOLYARG	STORE ARGUMENT
	JSR	FSTORE
	LDX	BPC
	LEAX	1,X	PUSH 1ST COEFFICIENT (OPPOLY IS 2 BYTE OPCODE)
	STX	BPC
	JSR	FLOAD
XOPPOLYL	EQU	*
	LDX	BPC	SKIP LAST COEFFFICIENT
	LEAX	RSESIZ,X
	LDA	,X	ANOTHER COEFFICIENT ? (END OF LIST?)
	BEQ	XOPPOLYX	B/NO (NO 0 EXPONENTS ALLOWED!)
	STX	BPC	YES, SAVE COEFFFICIENT ADDRESS
	LDX	#OPPOLYARG	MULTIPLY TOS BY ARG...
	JSR	FLOAD
	JSR	FMUL	(CAN'T OVERFLOW, ***RULE***)
	LDX	BPC
	JSR	FLOAD
	JSR	FADD
	BRA	XOPPOLYL

XOPPOLYX	JMP	NTRINX	ARG HAS ORIGINAL TOS VALUE IN IT
	PAGE
*
*	XOPCOS -- COMPUTE COS(TOS)
*
XOPCOS	JSR	XBSUBR	COMPUTE COS(TOS)=SIN(TOS+HALFPI)
	OPLOAD
	FDB	HALFPI
	OPADD
	OPJMP
	XOPSIN1
*
*	XOPSIN -- COMPUTE SIN(TOS)
*
XOPSIN	JSR	XBSUBR	COMPUTE SIN(TOS) USING BOOK INDEX # 3342
XOPSIN1	OPDUP		SIGNZ:=SIGN OF ARGUMENT
	OPSGN
	OPLOAD		...*10 (ALLOWS MORE ACCURATE COEFFFICIENTS)
	FDB	FTEN
	OPMUL
	OPSTORE
	FDB	SIGNZ
	OPABS		ARG:=ABS(ARG)
	OPLOAD		QUADRANT:=INT(ARG/HALFPI)
	FDB	HALFPI
	OPDIV		(ARG:=ARG/HALFPI-QUADRANT)
	OPDUP
	OPINT
	OPDUP		QUADRANT:=QUADRANT-4*INT(QUADRANT/4)
	OPDUP
	OPLOAD
	FDB	FFOUR
	OPDIV
	OPINT
	OPLOAD
	FDB	FFOUR
	OPMUL
	OPSUB
	OPSTORE
	FDB	TTEMP1	(HOLDS QUADRANT)
	OPSUB		(FINISH SUBTRACTING QUADRANT FROM ARG/HALFPI)
	OPASM
	LDA	TTEMP1+5	(QUADRANT IS GAURANTEED AN INTEGER)
	ASRA		IF QUADRANT IS 1 OR 3,
	BCC	XOPSIN2	(B/ 0 OR 2)
	JSR	XBCODE	THEN ARG:=1-ARG
	OPLOAD
	FDB	FONE
	OPSUB
	OPNEG
	OPASM		CHEAP TRICK AGAIN...
XOPSIN2	JSR	XBCODE
	OPDUP		COMPUTE ARG*ARG
	OPDUP		LEAVING ARG ON STACK, TOO...
	OPMUL
	OPPOLY		COMPUTE SIN(X) USING POLYNOMIAL
	FCB	$3D,34,28,79,07,30
	FCB	$BE,16,02,47,02,88
	FCB	$3F,04,68,16,51,02
	FCB	$BF,79,69,26,01,26
	FCB	$40,06,45,96,40,95
	FCB	$C0,15,70,79,63,27
	FCB	0
	OPMUL		MULTIPLY POLYNOMIAL BY ARG
	OPLOAD
	FDB	SIGNZ	AND BY SIGN OF ARGUMENT
	OPMUL
	OPLOAD	AND BY (QUADRANT&:2)-1...
	FDB	TTEMP1	WHICH PROPERLY FIDDLES SIGN FOR CORRECT QUA
	FCB	OPLSMI+$2
	OPAND
	OPLOAD
	FDB	FONE
	OPSUB
	OPMUL
	OPASM
	JMP	XBRET2
	PAGE
*
*	XOPATN -- COMPUTE ARC TANGENT OF TOS
*
XOPTAN	JSR	XBSUBR	COMPUTE ATN(TOS) USING BOOK # 5094
	OPDUP		SIGNX=SGN(ARG)
	OPSGN
	OPSTORE
	FDB	SIGNZ
	OPABS
	OPDUP		IF X<=1...
	OPLOAD
	FDB	HALFPI
	OPDIV
	OPINT
	OPDUP		(LEAVE A COPY FOR LATER SUBTRACT)
	OPDUP		HEMISPHERE':=HEMISPHERE-2*INT(HEMISPHERE/2)
	OPLOAD
	FDB	FPOINT5
	OPMUL
	OPINT
	OPLOAD
	FDB	FTWO
	OPMUL
	OPSUB
	OPSTORE
	FDB	TTEMP1
	OPLOAD		ARG:=ARG-HEMISPHERE*HALFPI
	FDB	HALFPI
	OPMUL
	OPSUB		NOW 0 <= ARG < HALFPI
	OPASM
	LDA	TTEMP1+VINT2	LOOK AT LSB OF HEMISPHERE
	ASRA
	BCC	XOPTAN1	B/ LEFT HEMISPHERE, LEAVE ARG ALONE
	JSR	XBCODE
	OPLOAD		ARG:=HALFPI-ARG
	FDB	HALFPI
	OPSUB
	OPNEG
	OPASM		CHEAP TRICK
XOPTAN1	JSR	XBCODE	TO GET BACK INTO BASIC CODE
	OPLOAD
	FDB	HALFPI	ARG:=(ARG/2)(PI/4)
	OPDIV
	OPDUP		LEAVE ARG ALONE
	OPDUP		COMPUTE ARG*ARG
	OPMUL
	OPPOLY		COMPUTE P(X)
	FCB	$3F,52,86,44,45,55
	FCB	$C0,88,76,62,37,70
	FCB	$41,12,92,21,03,50
	FCB	0
	OPMUL		COMPUTE ARG*PX
	OPLOAD		GET ARG SQUARED
	FDB	OPPOLYARG
	OPPOLY		COMPUTE Q(X)
	FCB	$40,10,00,00,00,00
	FCB	$C1,04,51,32,05,61
	FCB	$41,16,45,29,33,18
	FCB	0
	OPDIV		TANX2=ARG*PX/QX
	OPDUP
	OPDUP
	OPMUL		TANX2*TANX2
	OPLOAD
	FDB	FONE
	OPSUB
	OPDIV		TANX2/(TANX2*TANX2-1)
	OPLOAD
	FDB	FTWO
	OPMUL		2*TANX2/(TANX2*TANX2-1)
	OPLOAD
	FDB	SIGNZ
	OPMUL		...$SIGN
	OPLOAD
	FDB	TTEMP1	* ( HEMISPHERE + HEMISPHERE - 1)
	OPDUP
	OPADD
	OPLOAD
	FDB	FONE
	OPSUB
	OPMUL
	OPASM
	JMP	XBRET2
	PAGE
*
*	XOPATN -- COMPUTE ARC TANGENT OF TOS
*
XOPATN	JSR	XBSUBR	COMPUTE ATN(TOS) USING BOOK # 5094
	OPDUP		SIGNX=SGN(ARG)
	OPSGN
	OPSTORE
	FDB	SIGNZ
	OPABS
	OPDUP		IF X<=1...
	OPLOAD
	FDB	FONE
	OPLE
	OPBF
	FDB	XOPATN2
	OPLOAD		THEN RESULT=0
	FDB	FZERO
	OPJMP
	FDB	XOPATN1
XOPATN2	OPLOAD		ELSE X=(X-1)/(X+1)
	FDB	FONE
	OPSUB
	OPDUP
	OPLOAD
	FDB	FTWO
	OPADD
	OPDIV		(X-1+2 --> X+1 FOR DIVISOR)
	OPLOAD		AND RESULT = PI/4
	FDB	PIOVER4
XOPATN1	OPSTORE
	FDB	TTEMP1	(RESULT)
	OPDUP		COMPUTE ARG*ARG
	OPDUP		(RETAINING ARG ON THE STACK)
	OPMUL
	OPPOLY		COMPUTE PX ON ARG^2
	FCB	$BF,46,26,98,19,16
	FCB	$40,24,38,05,01,28
	FCB	$41,04,42,89,03,41
	FCB	$41,13,54,23,79,43
	FCB	$41,10,38,83,26,24
	FCB	0
	OPLOAD
	FDB	OPPOLYARG	GET ARG^2 BACK
	OPPOLY		COMPUTE QX
	FCB	$41,01,00,00,00,00
	FCB	$41,08,01,96,25,68
	FCB	$41,17,00,51,54,75
	FCB	$41,10,38,83,26,24
	FCB	0
	OPDIV		PX/QX
	OPMUL		ARG*PX/QX
	OPLOAD
	FDB	TTEMP1	ADD RESULT
	OPADD
	OPLOAD
	FDB	SIGNZ	AND MULTIPLY BY SIGN OF ANSWER
	OPMUL
	OPASM
	JMP	XBRET2
	PAGE	*** F L O A T I N G   P O I N T ***
FMONE	FCB	$C1,01,00,00,00,00
FZERO	FCB	$00,00,00,00,00,00	THIS IS THE ONLY VALID FORM OF "ZERO"
FPOINT5	FCB	$40,50,00,00,00,00
FONE	FCB	$41,01,00,00,00,00
FTWO	FCB	$41,02,00,00,00,00
FFOUR	FCB	$41,04,00,00,00,00
FTEN	FCB	$41,10,00,00,00,00
MINFINITY	FCB	$FF,99,99,99,99,99
INFINITY	FCB	$7F,99,99,99,99,99
PIOVER4	FCB	$40,78,53,98,16,35
HALFPI	FCB	$41,01,57,07,96,33
PI	FCB	$41,03,14,15,92,65
FP2TOM31	FCB	$3C,04,65,66,12,87
RECIPSQRT10	FCB	$40,31,62,27,76,60
*
*	FLOATING NEGATE
*
FNEG	LDA	2,S
	BEQ	FNEG1
	EORA	#$80
	IF	M6800!M6801
	STA	2,X
	ELSE	(M6809)
	STA	2,S
	FIN
FNEG1	RTS
	PAGE
*	FLOATING STORE ROUTINE
*	X REG CONTAINS POINTER TO LOCATION TO STORE
*	NUMBER IS POPPED OFF THE STACK & PUT @X
*
FSTORE
	IF	M6800!M6801
	PULD		POP RETURN ADDRESS OFF OF THE STACK
	STD	FSTORET
	ELSE	(M6809)
	PULS	Y
	FIN
	PULD		GET MSBYTE (SIGN-EXPONENT BYTE)
	STD	,X
	PULD
	STD	2,X
	PULD
	STD	4,X
	IF	M6800!M6801
	JMP	[FSTORET]
	ELSE	(M6809)
	JMP	,Y
	FIN
	PAGE
*	FLOATING COMPARE (TOS-1) TO (TOS)
*	NUMBER AT TOP-OF-STACK-1 IS COMPARED TO TOP-OF-STACK
*	STATUS BITS ARE SET INDICATING RESULT OF COMPARE
*	BOTH NUMBERS ARE POPPED OFF
*
*
	IF	M6800!M6801
FCMPMI	LDA	2,X
	BMI	FCMP4
	BRA	FCMP2

FCMP	STS	TEMPX	COMPUTE POPPED STACK POINTER FOR EXIT
	LDB	#RSESIZ*2+2
	ADDB	TEMPX+1
	STB	TEMPX+1
	BCC	FCMP0
	INC	TEMPX
FCMP0	TSX
	LDB	8,X
	BMI	FCMPMI
	LDA	2,X
	BMI	FCMP2
FCMP4	CMPB	2,X
	BNE	FCMP1
	LDA	9,X
	CMPA	3,X
	BNE	FCMP1
	LDA	10,X
	CMPA	4,X
	BNE	FCMP1
	LDA	11,X
	CMPA	5,X
	BNE	FCMP1
	LDA	12,X
	CMPA	6,X
	BNE	FCMP1
	LDA	13,X
	SUBA	7,X
	BEQ	FCMP5
FCMP1	BHI	FCMP2
	LDA	#-1
	SK2
FCMP2	LDA	#1
	ANDB	#$80
	ABA
FCMP5	LDX	,X
	LDS	TEMPX
	TSTA
	JMP	,X
	ELSE	(M6809)
	PAGE
*	FCMP -- FLOATING COMPARE
*	NOTE: THIS ROUTINE USES (A,B) BACKWARDS COMPARE TO 6800 VERSION OF FCMP!
*
FCMP	LDA	R2FLT1+2,S
	BMI	FCMPMI	B/ TOS-1 < 0
	LDB	R1FLT1+2,S
	BMI	FCMP2A	B/TOS-1 >=0, TOS-1 < 0
FCMP4	CMPA	R1FLT1+2,S	SIGNS MATCH, DO EXPONENTS ?
	BNE	FCMP1	B/ NO, EXPONENTS DETERMINE RESULT OF COMPARE
	LDX	R2FLT2+2,S	COMPARE 16 MANTISSA BITS
	CMPX	R1FLT2+2,S
	BNE	FCMP1
	LDX	R2FLT4+2,S
	CMPX	R1FLT4+2,S
	BNE	FCMP1
	LDA	R2FLT6+2,S
	SUBA	R1FLT6+2,S
	BEQ	FCMP5	B/ EQUAL
FCMP1	BHI	FCMP2	B/ MAGNITUDE (TOS) > MAGNITUDE (TOS-1)
	LDA	R2FLT1+2,S	TOS VALUE < TOS-1 VALUE
	LDX	,S	GET RETURN
	LEAS	RSESIZ*2+2,S	POP VALUES AND RETURN ADDRESS
	ANDA	#$80
	EORA	#$FF	ENSURE RESULT IS "<>" 0
	JMP	,X

FCMP2	LDA	R2FLT1+2,S	TOS VALUE > TOS-1 VALUE
FCMP2A	LDX	,S	GET RETURN ADDRESS TO X
	LEAS	RSESIZ*2+2,S
	ANDA	#$80
	INCA		ENSURE RESULT IS "<>" 0, LEAVES OVERFLOW RESET!
	JMP	,X

FCMP5	LDX	,S	FETCH RETURN ADDRESS
	LEAS	RSESIZ*2+2,S	POP OPERANDS FROM STACK
	TSTA		SET CC BITS TO RESULT
	JMP	,X

FCMPMI	LDB	R1FLT1+2,S
	BMI	FCMP4	B/ SIGNS MATCH
	BRA	FCMP2A
	FIN
	PAGE
*	FLOATING POINT MULTIPLY
*	MS1:MS6 CONTAINS MULTIPLICAND, NOT AFFECTED
*	MR1:MR6 CONTAINS MULTIPLIER, NOT AFFECTED
*	PRODUCT IN FAC WITH X REG POINTING TO IT
*
FMUL	PULD
	STD	RETADD
	LDX	#MR1
	JSR	FSTORE
	LDX	#MS1
	JSR	FSTORE
*
	LDX	#0	CLEAR FAC, FACEXT
	STX	FAC1	NEED THESE IF SOME MULTIPLIER DIGITS = 0
	STX	FAC3
	STX	FAC5
	STX	FACEXT1
	STX	FACEXT3
*
	LDA	MR1	COMPUTE SIGN OF RESULT
	BEQ	FMUL3	MULTIPLIER IS ZERO, DONE
	TFR	A,B
	EORA	MS1
	STA	MSIGN	TRASH MASKED OFF AT FLTEXIT
*
	LDA	MS1	ESTIMATE EXPONENT OF RESULT
	BEQ	FMUL3	MULTIPLICAND IS ZERO, DONE
	ANDA	#$7F
	ANDB	#$7F
	ABA
	SUBA	#$80
	STA	MEXP	CHECK OVERFLOW AT FLTEXIT
*
	LDX	#FACEXT4+1	POINTER INTO RESULT
	STX	FACX
	LDX	#MR6+1	POINTER TO NEXT MULTIPLIER DIGIT
FMUL1	DEC	FACX+1
	DEX
	CPX	#MR1
	BEQ	FMUL3	DONE WITH MULTIPLY
	STX	MRX
FMUL2	LDA	,X	GET MULTIPLIER DIGITS, LSBYTES FIRST
	BEQ	FMUL1	MULTIPLIER BYTE = 0, DO FAST LOOP
	STA	ML	HOLDS MULTIPLIER DIGIT FOR 5 CROSS-PRODUCTS
	CLR	CTNB	= CARRY INTO NEXT BASE 100 DIGIT COLUMN
	LDX	FACX	POINTS INTO FLOATING ACCUMULATOR
	LDB	MS6	GET LBYTE OF MULTIPLICAND DIGIT
	BSR	FCROSP	GO MULTIPLY AND ADD CROSS PRODUCT
	LDB	MS5
	BSR	FCROSP
	LDB	MS4
	BSR	FCROSP
	LDB	MS3
	BSR	FCROSP
	LDB	MS2	MSBYTE OF MULTIPLICAND
	BSR	FCROSP
	STA	,X	STORE LAST CARRY IN A ZEROED BYTE
	LDA	#3
	ADDA	FACX+1
	STA	FACX+1
	LDX	MRX
	DEX
	STX	MRX
	CPX	#MR1
	BNE	FMUL2
*
FMUL3	JMP	FLTEXIT
	PAGE
*	THIS ROUTINE WILL MULTIPLY ML * B REG AND ADD THE
*	RESULT IN A,B TO 0,X THEN DEX & RTS
*
FCROSP	BEQ	FCROSPZ	CHECKING B
	STX	FACX
	JSR	MULBASE100
	LDX	FACX
FCROSP0	ADDB	CTNB	ASSERT: SUM <= 200!
	ADDB	,X	ASSERT: SUM <= 299!
	BMI	FCROSBB	B/ 255>=SUM>=128
	BCS	FCROSBC	B/ 256<=SUM<=299
	CMPB	#100	IS SUM >= 100 ?
	BCS	FCROSP1A	B/ NO, GET OUT!
FCROSP1	SUBB	#100	YES, DO BASE 100 ADJUST
	INCA
FCROSP1A	STB	,X	SAVE PARTIAL PRODUCT DIGIT
	STA	CTNB	ASSERT: CTNB<=101 <=99+ 2 CARRIES)
	DEX		AS PROMISED
	RTS

FCROSBB	CMPB	#200	IS SUM >= 200 ?
	BCS	FCROSP1	B/ 199>=SUM>=128
	SUBB	#200	GET RID OF EXCESS OVER 99
	ADDA	#2	ADJUST CARRY TO NEXT BYTE
	STB	,X	STORE PARTIAL PRODUCT DIGIT
	STA	CTNB
	DEX		AS PROMISED
	RTS

FCROSBC	SUBB	#(200-256)&$FF	SUBTRACT 200 FROM SUM
	ADDA	#2	ADD 2 TO CARRY TO NEXT BYTE
	STB	,X	STORE PARTIAL PRODUCT DIGIT
	STA	CTNB
	DEX		AS PROMISED
	RTS

FCROSPZ	CLRA		MAKE PRODUCT INTO ZERO
	JMP	FCROSP0
	PAGE
	IF	((*/256)=((*+9999//256)/256))!M6809
*	EITHER THIS CONDITIONAL IF IS ON, OR THE ONE FOLLOWING MULBASE 100 IS ON
MULDIV100	EQU	*	CONVERTS MSB OF PRODUCT TO APPROX PRODUCT/100
	RPT	9999//256
	(*-MULDIV100)*256/100	(PRODUCT-(PRODUCT MOD 256))/100
MULDIV100.A	EQU	*
	RPT	9999//256
	(*-MULDIV100.A)*256\100	REMAINDER FOR ABOVE
	FIN
*
*	DIGIT MULTIPLY
*	MULTIPLIES REG B BY ML, RETURNS RESULT IN A,B
*
MULBASE100	EQU	*	ML*(B) -> (A,B) BASE 100 WITH BINARY DIGITS
	IF	M6800
	CLRA		ZERO PARTIAL PRODUCT
	RORB		LOOK AT LSB OF MULTIPLIER
	BCC	*+4	B/ =0, LEAVE PARTIAL PRODUCT AS ZERO
	LDA	ML	USE MULTIPLICAND AS 1ST PARTIAL PRODUCT
	LSRA		SHIFT PARTIAL PRODUCT ONE BIT RIGHT
	RORB		SHIFT OUT MULTIPLIER BIT
	BCC	*+4	B/ MULTIPLIER BIT IS ZERO
	ADDA	ML	IS ONE, ADD MULTIPLICAND TO PARTIAL PRODUCT
	RORA		SHIFT PARTIAL PRODUCT ONE BIT RIGHT
	RORB		SHIFT OUT MULTIPLIER BIT
	BCC	*+4	B/ MULTIPLIER BIT IS ZERO
	ADDA	ML	IS ONE, ADD MULTIPLICAND TO PARTIAL PRODUCT
	RORA		SHIFT PARTIAL PRODUCT ONE BIT RIGHT
	RORB		SHIFT OUT MULTIPLIER BIT
	BCC	*+4	B/ MULTIPLIER BIT IS ZERO
	ADDA	ML	IS ONE, ADD MULTIPLICAND TO PARTIAL PRODUCT
	RORA		SHIFT PARTIAL PRODUCT ONE BIT RIGHT
	RORB		SHIFT OUT MULTIPLIER BIT
	BCC	*+4	B/ MULTIPLIER BIT IS ZERO
	ADDA	ML	IS ONE, ADD MULTIPLICAND TO PARTIAL PRODUCT
	RORA		SHIFT PARTIAL PRODUCT ONE BIT RIGHT
	RORB		SHIFT OUT MULTIPLIER BIT
	BCC	*+4	B/ MULTIPLIER BIT IS ZERO
	ADDA	ML	IS ONE, ADD MULTIPLICAND TO PARTIAL PRODUCT
	RORA		SHIFT PARTIAL PRODUCT ONE BIT RIGHT
	RORB		SHIFT OUT MULTIPLIER BIT
	BCC	*+4	B/ MULTIPLIER BIT IS ZERO
	ADDA	ML	IS ONE, ADD MULTIPLICAND TO PARTIAL PRODUCT
	RORA		ONE MORE RIGHT SHIFT COMPLETE 6809 COMPATIBLE MULTIPLY
	RORB		BINARY PRODUCT OF (A)*(B) IS IN (A,B)
	LSRA		AND ANOTHER FOR BETTER LUCK
	RORB
	ELSE	M6801!M6809
	LDA	ML	GET MULTIPLIER DIGIT
	MUL		DO DIGIT MULTIPLY
	FIN
*	NOW ADJUST BINARY PRODUCT TO MAKE INTO BASE 100
CONVERTTOBASE100	EQU	*	(A,B)<=9999 GETS CONVERTED TO BASE 100
	IF	M6800!M6801
	STA	TEMPB	ASSERT: (A)<=INT(99*99/256)=38?
	LDA	#MULDIV100/256	COMPUTE APPROX PRODUCT DIVIDED BY 100
	STA	TEMPA
	LDX	TEMPA
	LDA	MULDIV100&$FF,X	= (PRODUCT MOD 256)/100
	ADDB	(MULDIV100&$FF)+9999//256,X	= (PRODUCT MOD 256) MOD 100
	ELSE	(M6809)
	LDX	#MULDIV100	GET DIVIDE-BY-100 QUOTIENT TABLE ADDRESS
	LEAX	A,X	= ADDRESS OF SLOT IN TABLE CONTAINING QUOTIENT
	LDA	,X	FETCH QUOTIENT OF (D)/100
	ADDB	9999//256,X	ADD REMAINDER TO WHAT'S LEFT IN (B)
	FIN
	BCC	*+6	B/ PRODUCT MOD 256 + (PRODUCT - (PRODUCT MOD 256)) MOD 100
	ADDA	#2	REMAINDER >= 256, ADJUST LEFT HAND DIGIT
	SUBB	#200	ADJUST REMAINDER
	BPL	*+5	B/ (B)<=127 (.5 OF THE TIME)
	INCA		(B)>=128, ADJUST LEFT HAND DIGIT
	SUBB	#100	ADJUST REMAINDER
	CMPB	#100	(B) STILL TO BIG ?
	BCS	*+5	B/ NO, GET OUT!
	INCA		ADJUST LEFT HAND DIGIT
	SUBB	#100	MAKES RIGHT HAND DIGIT LEGAL
	RTS		TOTAL: 131 CYCLES FOR MULTIPLY AND CONVERT
	IFUND	MULDIV100
	IF	(*/256)=((*+9999//256)/256)
*	EITHER THIS CONDITIONAL IF IS ON, OR THE ONE PRECEEDING MULBASE 100 IS ON
MULDIV100	EQU	*	CONVERTS MSB OF PRODUCT TO APPROX PRODUCT/100
	RPT	9999//256
	(*-MULDIV100)*256/100	(PRODUCT-(PRODUCT MOD 256))/100
MULDIV100.A	EQU	*
	RPT	9999//256
	(*-MULDIV100.A)*256\100	REMAINDER FOR ABOVE
	FIN
	FIN
	PAGE
FDIVNORM	EQU	*-1	MULTIPLICATIVE FACTOR USED TO NORMALIZE DIVISOR
	RPT	100/2-1	(SEE KNUTH VOL 2 PAGE 237)
	FCB	100/(*-FDIVNORM+1)
*
FOVERJ	JMP	FOVER	OVERFLOW OCCURRED
FRZEROJ	JMP	FRZERO	ZERO RESULT
*
*	MULTIPLY DIGIT AT (X) BY ML AND ADD (A); STORE BACK AT (X)
*	RETURN (A) = UPPER BASE 100 DIGIT OF @(X)*ML+(A)
*	DECREMENT X
*
FDIVNORMDIGIT	EQU	*
	STA	CTNB	SAVE CARRY TO NEXT BYTE
	STX	FACX	LOOKS LIKE GOOD IDEA...
	LDB	,X	GET DIGIT TO BE MULTIPLIED
	JSR	MULBASE100	MULTIPLY IT BY ML, PRODUCT GOES TO (A,B)
	ADDB	CTNB	ADD CARRY FROM LAST DIGIT COLUMN
	CMPB	#100	DO BASE 100 ADJUST
	BCS	*+5	B/ DIGIT IS OK
	INCA		BUMP CARRY TO NEXT DIGIT COLUMN
	SUBB	#100	MAKE DIGIT VALID
	LDX	FACX	STORE MODIFIED DIGIT
	STB	,X
	DEX		AS PROMISED
	RTS		WITH CARRY TO NEXT BYTE IN (A)
	PAGE
	PAGE
*
*	FLOATING DIVIDE
*	TOS-1 CONTAINS DIVIDEND
*	TOS CONTAINS DIVISOR
*	QUOTIENT RETURNED ON TOS
*
FDIV	PULD
	STD	RETADD
	LDX	#MS1	DIVISOR
	JSR	FSTORE
	LDX	#FAC1	DIVIDEND
	JSR	FSTORE
*
	LDX	#0	CLEAR FACEXT
	STX	FACEXT1
	STX	FACEXT3
	STX	FACEXT4
*
	LDA	MS1
	BEQ	FOVERJ	DIVISOR IS ZERO, REETCH
	TFR	A,B
	EORA	FAC1
	STA	MSIGN	TRASH MASKED OFF AT FLTEXIT
	LDA	FAC1
	BEQ	FRZEROJ	DIVIDEND IS ZERO, DONE
	ANDA	#$7F
	ANDB	#$7F
	SBA
	INCA		ASSUME FIRST QUO DIG <> 0
	STA	MEXP
*
	CLR	FAC1	U0 IN "KNUTH"IAN NOTATION
	PAGE
*
*	NOW "NORMALIZE" THE DIVISOR (I.E., MAKE MSD >= 50; SEE KNUTH)
*
	LDA	MS2	MSD OF DIVISOR (<>0 BECAUSE THIS IS F.P.)
	CMPA	#100/2	IS DIVISOR NORMALIZED ?
	BCC	FDIVGN	B/ YES, GO DO THE DIVIDE!
	IF	M6800!M6801
	STA	TEMPB	NO, LOOK NORMALIZATION MULTIPLIER UP IN THE TABLE
	LDA	#FDIVNORM/256
	STA	TEMPA
	LDX	TEMPX
	LDA	FDIVNORM&$FF,X
	ELSE	(M6809)
	LDX	#FDIVNORM	GET ADDRESS OF NORMALIZING MULTIPLIER TABLE
	LDA	A,X	FETCH NORMALIZING MULTIPLIER
	FIN
	STA	ML	SAVE MULTIPLICATIVE FACTOR
	LDX	#MS6	MULTIPLY DIVISOR BY (ML)
	CLRA		ZERO CARRY INTO FIRST DIGIT
	BSR	FDIVNORMDIGIT	GAURANTEES MSD DIVISOR >= 100/2
	BSR	FDIVNORMDIGIT	SINCE BOTH DIVISOR AND DIVIDEND ARE MULTIPLIED...
	BSR	FDIVNORMDIGIT	BY SAME VALUE, THE QUOTIENT REMAINS THE SAME
	BSR	FDIVNORMDIGIT
	BSR	FDIVNORMDIGIT
	LDX	#FAC6	MULTIPLY DIVIDENT BY NORMALIZING FACTOR
*	ASSERT (A)=0 HERE BECAUSE WE NORMALIZED MULTIPLIER
	BSR	FDIVNORMDIGIT
	BSR	FDIVNORMDIGIT
	BSR	FDIVNORMDIGIT
	BSR	FDIVNORMDIGIT
	BSR	FDIVNORMDIGIT
	STA	FAC1	NEW MSD OF FAC (MAY BE NON-ZERO)
	LDA	MS2	GRAB MSD OF DIVISOR
FDIVGN	NEGA		COMPUTE NEGATIVE FOR USE IN GUESS QUOTIENT DIGIT ROUTINE
	STA	MINUSDIVISORDIGIT
	LDX	#FAC1	WHERE TO PLACE 1ST QUOTIENT DIGIT
	PAGE
*	GUTS OF THE FLOATING DIVIDE
*
	LDA	FAC2
	LDB	FAC1
	BSR	FDIVS	GENERATE 1ST QUOTIENT DIGIT
	LDA	FAC3
	LDB	FAC2
	BSR	FDIVS	GENERATE 2ND QUOTIENT DIGIT
	LDA	FAC4
	LDB	FAC3
	BSR	FDIVS
	LDA	FAC5
	LDB	FAC4
	BSR	FDIVS
	LDA	FAC6
	LDB	FAC5
	BSR	FDIVS	GENERATE 5TH QUOTIENT DIGIT
	LDA	FAC1	CHECK: FIRST QUOTIENT DIGIT = 0 ?
	BNE	FDIVG1	B/ NO, DONE
	LDA	FACEXT1	YES, GENERATE ONE MORE QUOTIENT DIGIT
	LDB	FAC6
	BSR	FDIVS
FDIVG1	JMP	FLTEXIT
	PAGE
*	THIS ROUTINE WILL FIND THE QUOTIENT DIGIT
*	AND SUBTRACT (QUO DIG * DIVISOR) FROM DIVIDEND
*
FDIVS	EQU	*
*
*	FIRST, GUESS THE QUOTIENT DIGIT (SEE KNUTH VOL 2 PAGE 237)
*	BY COMPUTING ((B)*100+(A))/MS2
*	NOTE: (B)<=MS2; MS2 >=50
*
GUESSD	CMPB	MS2	QUOTIENT DIGIT = 99 ?
	BNE	GUESSD1	B/ NO, COMPUTE IT THE HARD WAY
	LDB	#99	YES, GRAB IT
	JMP	GUESSD2	GO USE IT

	IF	M6800
GUESSD1	STD	TEMPA	(B)<MS2; MULTIPLY (B) BY 100 AND ADD (A)
	CLRA		ZERO UPPER PART OF B*100
	ASLB		ASSERT: <=198
	ADDB	TEMPB	3*(B) <= 297
	ROLA
	ASLD		(A,B):=6*B
	ASLD		(A,B):=12*B
	ASLD		(A,B):=24*B
	ADDB	TEMPB	25*B
	ADCA	#0
	ASLD		(A,B):=50*B
	ASLD		(A,B):=100*B
	ELSE	M6801!M6809
GUESSD1	STA	TEMPA
	LDA	#100
	MUL
	FIN
	ADDB	TEMPA	(A,B):=100*B+A <= 9999
	ADCA	#0	NOTE: NOW B REGISTER <= 39
	ASLD		GENERATE QUOTIENT DIGIT (8 BITS)
*	FIRST QUOTIENT BIT IS 0 SINCE ML2>=50 AND B<=39
	ADDA	MINUSDIVISORDIGIT
	BCS	*+4
	SUBA	MINUSDIVISORDIGIT
	ROLD		SHIFT IN FIRST SIGNIFICANT QUOTIENT BIT OF 8
	ADDA	MINUSDIVISORDIGIT
	BCS	*+4
	SUBA	MINUSDIVISORDIGIT
	ROLD
	ADDA	MINUSDIVISORDIGIT
	BCS	*+4
	SUBA	MINUSDIVISORDIGIT
	ROLD
	ADDA	MINUSDIVISORDIGIT
	BCS	*+4
	SUBA	MINUSDIVISORDIGIT
	ROLD
	ADDA	MINUSDIVISORDIGIT
	BCS	*+4
	SUBA	MINUSDIVISORDIGIT
	ROLD
	ADDA	MINUSDIVISORDIGIT
	BCS	*+4
	SUBA	MINUSDIVISORDIGIT
	ROLD
	ADDA	MINUSDIVISORDIGIT
	BCS	*+4
	SUBA	MINUSDIVISORDIGIT
	ROLD
	ADDA	MINUSDIVISORDIGIT	GENERATE 8TH QUOTIENT BIT
*	BCS	*+4	WE DON'T CARE ABOUT REMAINDER,
*	SUBA	MINUSDIVISORDIGIT	SO DON'T BOTHER WITH THESE
	ROLB		SHIFT IN LAST QUOTIENT BIT
*	ROLA		WE DON'T NEED THIS AT ALL...
	BNE	GUESSD2	B/ DIGIT IS NONZERO
	STB	,X+	STORE QUOTIENT DIGIT OF ZERO
	RTS
	PAGE
GUESSD2	STB	ML	SAVE APPROXIMATE QUOTIENT DIGIT (OFF BY AT MOST 2!)
	CLR	CTNB	HOLDS BORROW FOR THE NEXT DIGIT COLUMN
	LDB	MS6	GET DIVISOR LSBYTE & MULTIPLY & SUBTRACT
	JSR	FDIVSS	(I.E., SUBTRACT QUOTIENT DIGIT*DIVISOR FROM REMAINDER)
	LDB	MS5
	JSR	FDIVSS
	LDB	MS4
	JSR	FDIVSS
	LDB	MS3
	JSR	FDIVSS
	LDB	MS2
	JSR	FDIVSS
	TFR	A,B	COPY CTNB TO (B)
	DEX		BACK UP X
	JSR	FDIVSSL	THIS HANDLES LAST CTNB
	BEQ	FDIVS2	# IS STILL POS, ESTIMATED QUO RIGHT ON
FDIVS1	DEC	ML	EST QUO DIG TOO BIG, TRY 1 LESS
	LDA	MS6	ADD DIVISOR BACK IN ONCE
	ADDA	11,X
	ADDA	#-100	FORCE CARRY IF DIGIT >= 100
	BCS	*+4	B/ CARRY TO NEXT DIGIT
	SUBA	#-100	ASSERT: THIS ZEROS THE CARRY!
	STA	11,X
	LDA	MS5
	ADCA	10,X
	ADDA	#-100	FORCE CARRY IF DIGIT >= 100
	BCS	*+4	B/ CARRY TO NEXT DIGIT
	SUBA	#-100	ASSERT: THIS ZEROS THE CARRY!
	STA	10,X
	LDA	MS4
	ADCA	9,X
	ADDA	#-100	FORCE CARRY IF DIGIT >= 100
	BCS	*+4	B/ CARRY TO NEXT DIGIT
	SUBA	#-100	ASSERT: THIS ZEROS THE CARRY!
	STA	9,X
	LDA	MS3
	ADCA	8,X
	ADDA	#-100	FORCE CARRY IF DIGIT >= 100
	BCS	*+4	B/ CARRY TO NEXT DIGIT
	SUBA	#-100	ASSERT: THIS ZEROS THE CARRY!
	STA	8,X
	LDA	MS2
	ADCA	7,X
	ADDA	#-100	FORCE CARRY IF DIGIT >= 100
	BCS	*+4	B/ CARRY TO NEXT DIGIT
	SUBA	#-100	ASSERT: THIS ZEROS THE CARRY!
	STA	7,X
	LDA	#0	ADJUST REMAINDER SIGN UPWARDS
	ADCA	6,X
	ADDA	#-100	FORCE CARRY IF DIGIT >= 100
	BCS	*+4	B/ CARRY TO NEXT DIGIT
	SUBA	#-100	ASSERT: THIS ZEROS THE CARRY!
	STA	6,X
	BNE	FDIVS1	EST QUO DIG BIG BY UP TO 2, ADD ONE LAST TIME!
FDIVS2	LDA	ML
	STA	6,X
	IF	M6800!M6801
	STX	FACX	SO WE CAN MAKE IT POINT TO NEXT QUOTIENT DIGIT SLOT
	LDA	#7
	ADDA	FACX+1
	STA	FACX+1
	LDX	FACX
	ELSE	(M6809)
	LEAX	7,X
	FIN
	RTS
	PAGE
*	THIS ROUTINE MULTIPLIES THE QUOTIENT DIGIT ML BY REG B
*	AND SUBTRACTS IT FROM 0,X THEN DEX & RTS
*
FDIVSS	BNE	FDIVSS1	B/ DIGIT (B) IS NON-ZERO
	CLRA		DIGIT IS ZERO --> PRODUCT IS ZERO
	JMP	FDIVSS1A	SKIP INTO LOOP AT CORRECT PLACE

FDIVSS1	EQU	*
	STX	FACX
	JSR	MULBASE100	PRODUCE BASE 100 PRODUCT
	LDX	FACX
FDIVSS1A	DEX		--> USE 1,X INSTEAD OF 0,X
	ADDB	CTNB	TOTAL TO SUBTRACT; ASSERT (B)<=200
FDIVSSL	SEC		ADD THE NEGATIVE TO GET A SUBTRACT
	COMB
	ADCB	5+1,X	(0..99)-(0..201) => (99..-201)
	BCS	FDIVSSA	B/ ANSWER IS OK AS IT
	CMPB	#-100	OOPS, ANSWER IS NEGATIVE
	BCC	FDIVSS2	B/ 0>ANSWER>=-100
	ADDA	#2	ANSWER < -100, ADJUST PROPERLY
	ADDB	#200
FDIVSSA	STA	CTNB	MIGHT BE AS LARGE AS 101
	STB	5+1,X	SAVE RESULT DIGIT
	RTS

FDIVSS2	INCA		ADJUST BORROW TO NEXT BYTE
	ADDB	#100	MAKE DIGIT POSITIVE
	STA	CTNB	STORE BORROW
	STB	5+1,X	SAVE RESULT DIGIT LAST TO MAKE EASY TEST
	RTS
	PAGE
*	FLOATING POINT SUBTRACT
*	TOS-1 CONTAINS MINUEND
*	TOS CONTAINS SUBTRAHEND
*	DIFFERENCE RETURNED ON TOS
*
FSUB	LDA	#$80	TWIDDLE SIGN ON TOS
	EORA	2,S
	IF	M6800!M6801
	STA	2,X
	ELSE	(M6809)
	STA	2,S
	FIN
*
*	FLOATING POINT ADD
*	TOS-1 CONTAINS AUGEND (GOES INTO MR1)
*	TOS CONTAINS ADDEND (GOES INTO MS1)
*	SUM RETURNED ON TOS
*	152???*** CYCLES IF NO NORMALIZE, NO CARRY OUT
*
FADD	PULD
	STD	RETADD
	LDA	,S	ADD OR SUBTRACT?
	IF	M6800!M6801
	TAB
	EORA	6,X
	STA	MSIGN
	LDA	6,X	FIND DIFFERENCE IN EXPONENTS
	ELSE	(M6809)
	TFR	A,B
	EORA	6,S
	STA	MSIGN
	LDA	6,S
	FIN
	ANDA	#$7F
	ANDB	#$7F
	SBA		(MR1 EXP) - (MS1 EXP)
	BEQ	FADD23	NO NORMALIZATION REQUIRED
	BPL	FADD10	MS IS SMALLER
FADD23	PULB		SAVE (TOS) AS MS
	STB	MS1
	PULB
	STB	MS2
	PULB
	STB	MS3
	PULB
	STB	MS4
	PULB
	STB	MS5
	PULB
	STB	MS6
	PULB
	STB	MR1
	TSTA
	BNE	FADD22	B/ DIFFERENT EXPONENTS
	TSTB
	BEQ	FADD30	MR = 0, DONE
	PULD
	STD	MR2
	PULD
	STD	MR4
	PULB
	STB	MR6
	BRA	FADD9

FADD22	PULB
	INCA		MR IS SMALLER
	BNE	FADD1
	STB	MR3
	PULB
	STB	MR4
	PULD
	STD	MR5
	CLRB
	BRA	FADD8	CLEARS OUT MR2

FADD1	INCA
	BNE	FADD2
	STB	MR4
	PULD
	STD	MR5
	CLRB
	BRA	FADD7	CLEARS OUT MR2, MR3

FADD2	INCA
	BNE	FADD3
	STB	MR5
	PULB
	STB	MR6
	CLRB
	BRA	FADD6	CLEARS OUT MR2, MR3, MR4

FADD10	BRA	FADD24

FADD3	INCA
	BNE	FADD4
	STB	MR6
	CLRB
FADD5	PULA
	STB	MR5
FADD6	PULA
	STB	MR4
FADD7	PULA
	STB	MR3
FADD8	PULA
	STB	MR2
FADD9	LDA	MS1	MS IS LARGER
	ANDA	#$7F
	SUBA	#$40-1
	STA	MEXP
	BRA	FADD20
*
FADD30	INS
FADD4	LDX	#MS1	DON'T ADD OR SUB, MR HAS NO
	LEAS	4,S	RELATIVE SIGNIFICANCE TO MS
	JMP	FLOAD1
*
FADD14	LEAS	4,S	DON'T ADD OR SUB, MS HAS NO RELATIVE SIGNIFICANCE TO MR
	JMP	FLOAD2
*
FADD24	PULB
	STB	MS1
	DECA
	BNE	FADD11
	PULD
	STD	MS3
	PULD
	STD	MS5
	CLRB
	BRA	FADD18	CLEARS OUT MS2

FADD11	DECA
	BNE	FADD12
	PULB
	STB	MS4
	PULD
	STD	MS5
	CLRB
	BRA	FADD17	CLEARS OUT MS2, MS3

FADD12	DECA
	BNE	FADD13
	PULD
	STD	MS5
	CLRB
	BRA	FADD16	CLEARS MS2, MS3, MS4

FADD13	PULB
	DECA
	BNE	FADD14
	STB	MS6
	CLRB
	PULA
	STB	MS5
FADD16	PULA
	STB	MS4
FADD17	PULA
	STB	MS3
FADD18	PULA
	STB	MS2
	PULD
	STD	MR1
	PULD
	STD	MR3
	PULD
	STD	MR5
	LDA	MR1	MR1 IS LARGER
	ANDA	#$7F
	SUBA	#$40-1
	STA	MEXP
FADD20	LDA	MSIGN	ADD OR SUB?
	BMI	FSUB1	SUBTRACT
	JMP	FADD21

FSUB1	LDX	#0
	STX	FACEXT1
	STX	FACEXT3
	STX	FACEXT4
	LDD	MR5	SUBTRACT MS FROM MR
	SUBB	MS6
	BCC	*+4	B/ STILL POSITIVE, NO ADJUSTMENT NEEDED
	ADDB	#100	WENT NEGATIVE, ADJUST AND LEAVE "BORROW" SET
	STB	FAC6
	SBCA	MS5
	BCC	*+4	B/ STILL POSITIVE, NO ADJUSTMENT NEEDED
	ADDA	#100	WENT NEGATIVE, ADJUST AND LEAVE "BORROW" SET
	STA	FAC5
	LDD	MR3
	SBCB	MS4
	BCC	*+4	B/ STILL POSITIVE, NO ADJUSTMENT NEEDED
	ADDB	#100	WENT NEGATIVE, ADJUST AND LEAVE "BORROW" SET
	STB	FAC4
	SBCA	MS3
	BCC	*+4	B/ STILL POSITIVE, NO ADJUSTMENT NEEDED
	ADDA	#100	WENT NEGATIVE, ADJUST AND LEAVE "BORROW" SET
	STA	FAC3
	LDA	MR2
	SBCA	MS2
	BCC	*+4	B/ STILL POSITIVE, NO ADJUSTMENT NEEDED
	ADDA	#100	WENT NEGATIVE, ADJUST AND LEAVE "BORROW" SET
	STA	FAC2
	BCC	FSUB4J
*
	CLRA		WE WENT NEGATIVE
	SUBA	FAC6	COMPLEMENT THE RESULT, SIGH...
	BCC	*+4	B/ STILL POSITIVE, NO ADJUSTMENT NEEDED
	ADDA	#100	WENT NEGATIVE, ADJUST AND LEAVE "BORROW" SET
	STA	FAC6
	LDA	#0
	SBCA	FAC5
	BCC	*+4	B/ STILL POSITIVE, NO ADJUSTMENT NEEDED
	ADDA	#100	WENT NEGATIVE, ADJUST AND LEAVE "BORROW" SET
	STA	FAC5
	LDA	#0
	SBCA	FAC4
	BCC	*+4	B/ STILL POSITIVE, NO ADJUSTMENT NEEDED
	ADDA	#100	WENT NEGATIVE, ADJUST AND LEAVE "BORROW" SET
	STA	FAC4
	LDA	#0
	SBCA	FAC3
	BCC	*+4	B/ STILL POSITIVE, NO ADJUSTMENT NEEDED
	ADDA	#100	WENT NEGATIVE, ADJUST AND LEAVE "BORROW" SET
	STA	FAC3
	LDA	#0
	SBCA	FAC2	ASSERT: FAC2 <> 0 HERE!
	ADDA	#100	WENT NEGATIVE, ADJUST AND LEAVE "BORROW" SET
	STA	FAC2
	LDA	#$80	SIGN = - (SIGN OF LARGER)
	EORA	MR1
	BRA	FSUB3
FSUB4J	BRA	FSUB4
*
FADD21	LDD	MR5	ADD MS TO MR
	ADDB	MS6
	ADDB	#-100	DO BASE 100 ADJUST
	BCS	*+4	AND PROPOGATE THE CARRY TO NEXT DIGIT
	SUBB	#-100
	STB	FAC6
	ADCA	MS5
	ADDA	#-100	DO BASE 100 ADJUST
	BCS	*+4	AND PROPOGATE THE CARRY TO NEXT DIGIT
	SUBA	#-100
	STA	FAC5
	LDD	MR3
	ADCB	MS4
	ADDB	#-100	DO BASE 100 ADJUST
	BCS	*+4	AND PROPOGATE THE CARRY TO NEXT DIGIT
	SUBB	#-100
	STB	FAC4
	ADCA	MS3
	ADDA	#-100	DO BASE 100 ADJUST
	BCS	*+4	AND PROPOGATE THE CARRY TO NEXT DIGIT
	SUBA	#-100
	STA	FAC3
	LDD	MR1
	ADCB	MS2
	ADDB	#-100	DO BBSE 100 ADJUST
	BCS	*+4	AND PROPOGATE THE CARRY TO NEXT DIGIT
	SUBB	#-100
	STB	FAC2
	STA	MSIGN	USE MR1'S SIGN
	BCC	FLTEXIT1
	LDB	#1	SET FAC1 FOR EXIT
	STB	FAC1
*	NOW FALL INTO FLTEXIT
	PAGE
*	FLOATING POINT EXIT
*	ASSUMES ESTIMATED EXPONENT IN MEXP, SIGN IN MSIGN
*	ASSUMES FAC1 IS LEADING DIGIT OF RESULT
*	CHECKS FOR FLOATING ZERO
*	ALSO ASSUMES RETURN ADDRESS IS IN RETADD
*	EXITS THRU "FPTRAP" IF OVERFLOW
*
FLTEXIT	CLRB
	LDX	#MEXP	= FAC1-1
FLTEX1	LDA	1,X
	BNE	FLTEX2
FLTEX0	INCB
	INX
	CPX	#FAC6
	BNE	FLTEX1
FUNDER	EQU	*
FRZERO	LDX	#FZERO	RETURN FLOATING ZERO AS RESULT
	JMP	FLOAD1

FSUB4	LDA	MR1
FSUB3	STA	MSIGN
FLTEXIT1	LDB	#1	FAST EXIT (FAC1 IS ZERO)
	LDX	#FAC1
	LDA	1,X
	BEQ	FLTEX0
FLTEX2	LDA	MEXP
	SBA
	CMPA	#$7F-$40
	BGT	FOVER
	ADDA	#$40	ADD BIAS
	BEQ	FUNDER	FLOATING UNDERFLOW, REETCH
	BMI	FUNDER
	LDB	MSIGN
	ANDB	#$80
	ABA
	STA	,X
	JMP	FLOAD1

FOVER	LDX	#INFINITY
	JSR	FLOAD
	LDA	MSIGN
	ANDA	#$80
	ORA	,S	
	IF	M6800!M6801
	STA	,X
	ELSE	(M6809)
	STA	,S
	FIN
	JMP	[FPTRAP]
	PAGE
*	FLOATING LOAD ROUTINE
*	X REG CONTAINS POINTER TO FLOATING POINT NUMBER
*	NUMBER POINTED TO IS PUSHED ONTO THE STACK
*	STORE RETURN ADDRESS IN RETADD AND EXITS THRU RETADD
*
FLOAD
	PULD		POP RETURN ADDRESS OFF THE STACK
	STD	RETADD
FLOAD1	LDD	4,X	GET LS 16 BITS
	PSHD
	LDD	2,X
	PSHD
	LDD	,X	GET MSBYTE (SIGN-EXPONENT BYTE)
	PSHD
FLOAD2
	JMP	[RETADD]
	PAGE
*	FLOATING INPUT CONVERSION ROUTINES
*	A,B CONTAIN MAX # OF CHARS TO EAT (INCLUDING BLANKS)
*	X REG CONTAINS POINTER TO CHARACTER STRING TO CONVERT
*	RESULT IS CONVERTED TO FLOATING POINT FORMAT AND PUSHED ONTO THE STACK
*	X REG WILL POINT PAST STRING WHEN DONE
*	DOES NOT EAT THE CR OR ANY OTHER DELIMITER
*	WHOLE STRING IS EATEN EVEN IF ERROR OCCURED
*	ROUTINE WILL EAT STRINGS OF THE FOLLOWING FORMAT:
*	<0 OR MORE BLANKS> FOLLOWED BY
*	<'+' OR '-' OR NOTHING> FOLLOWED BY
*	<1 OR MORE DIGITS WHICH MAY CONTAIN A '.' ANYWHERE IN THIS FIELD
*	FIELD MAY CONTAIN UP TO 10 SIGNIFICANT DIGITS
*	(LEADING ZEROES ARE NOT CONSIDERED SIGNIFICANT
*	EXAMPLE:
*	0.000000103456789
*	THE "0.000000" PART IS NOT CONSIDERED SIGNIFICANT,
*	WHILE THE "103456789" PART IS CONSIDERED SIGNIFICANT)
*	MAY NOT BE > 127 NON-SIG ZEROS RIGHT OF DP & PRECEEDING SIG DIGITS
*	EXCESS SIGNIFICANT DIGITS ARE READ AND IGNORED> FOLLOWED BY
*	<'e', 'E' OR NOT A 'E'> (DONE IF NOT 'E', ELSE...) FOLLOWED BY
*	<'+' OR '-' OR NOTHING> FOLLOWED BY
*	<UP TO 3 DIGITS NOT TO EXCEED 126> FOLLOWED BY
*	<NOT A DIGIT>
*
*	JSR	FCONVI
*	BRA	ALL OK
*	BRA	OVERFLOW
*	BRA	SYNTAX ERROR
*
FCONVI31	BSR	GETCHAR
LEFTDIG	BSR	ISDIG
	BRA	FCONVI32
	CMPA	#'.
	BNE	FCONVI33
	LDA	DPFLAG
	BNE	FCONVI33
	INCA
	STA	DPFLAG
	BRA	FCONVI31
FCONVI32	TFR	A,B	MULTIPLY LEFT DIGIT OF PAIR BY 10
	ASLA
	ASLA
	ABA
	ASLA
	STA	,X
FCONVI36	LDA	DPFLAG
	BNE	FCONVI37
	INC	DPCOUNT
	BPL	FCONVI37
	LEAS	2,S
	JMP	SYNERR
FCONVI37	RTS
FCONVI33	PULX
	JMP	2,X
*
FCONVI34	BSR	GETCHAR
RIGHTDIG	BSR	ISDIG	PICK UP RIGHT HAND DIGIT OF PAIR
	BRA	FCONVI35
	CMPA	#'.
	BNE	FCONVI33
	LDA	DPFLAG
	BNE	FCONVI33
	INCA
	STA	DPFLAG
	BRA	FCONVI34
FCONVI35	ADDA	,X	ADD RIGHT HAND DIGIT TO LEFTHAND ALREADY COLLECTED
	STA	,X+
	BRA	FCONVI36
	PAGE
*	DIGIT CHECK ROUTINE
*	SKIP RETURN IF A IS NOT A DIGIT
*	RETURN W/BCD EQUIVALENT IF CHAR IS A DIGIT
*
ISDIG	CMPA	#'0
	BLT	ISDIG2
	CMPA	#'9
	BGT	ISDIG2
	STA	DIGFLG
	SUBA	#'0
	RTS
ISDIG2	STA	TEMPA	SKIP RETURN, PRESERVE A, X
	PULD
	ADDD	#2
	PSHD
	LDA	TEMPA
	RTS
*
*	GET CHARACTER ROUTINE
*	GET CHAR @BUFERP BUMP X & RETURN
*
GETCHAR	STX	FACX
	LDX	LOOPX	CHECK MAX # OF CHARS READ
	BEQ	GETCHAR0
	DEX
	STX	LOOPX
	LDX	BUFERP
	LDA	,X+
GETCHAR2	STX	BUFERP
	LDX	FACX
	RTS
GETCHAR0	LDX	BUFERP
	INX
	CLRA
	BRA	GETCHAR2
	PAGE
FCONVI	STD	LOOPX	MAX # OF CHARS TO EAT
	CLRA
	STA	DPFLAG
	STA	DPCOUNT
	STA	DIGFLG
	STX	BUFERP
	STX	FCVIRT	NOT USED RIGHT AWAY
	LDX	#0
	STX	FAC1
	STX	FAC3
	STX	FAC5
	STX	FACEXT1	10TH DIGIT GOES INTO LEFT HALF OF FACEXT1
FCONVI1	BSR	GETCHAR
	CMPA	#ASCII:SPACE
	BEQ	FCONVI1	EAT BLANKS
	CMPA	#ASCII:HT
	BEQ	FCONVI1
	CMPA	#'+
	BEQ	FCONVI2
	CMPA	#'-
	BNE	FCONVI3
	LDA	#$80
	STA	FAC1	MAKE SIGN NEG
*
*	IGNORE LEADING ZEROES
*
FCONVI2	BSR	GETCHAR	GO GET SOME DIGITS
FCONVI3	CMPA	#'0
	BNE	FCONVI50
	STA	DIGFLG
	LDA	DPFLAG
	BEQ	FCONVI2	NO DP SEEN YET
	DEC	DPCOUNT
	BMI	FCONVI2
	JMP	SYNERR	TOO MANY ZEROES
FCONVI50	CMPA	#'.
	BNE	FCONVI51
	STA	DPFLAG
	BRA	FCONVI2
*
*	EAT SIGNIFICANT DIGITS
*
FCONVI51	LDX	#FAC2
	LDB	#DIGMAX/2
	STB	DIGCNT	USE THIS AS A COUNTER
	BRA	FCONVI4A
FCONVI4	BSR	GETCHAR
FCONVI4A	JSR	RIGHTDIG
	BRA	FCONVI5	ALL IS OK
	BRA	FCONVI8	2ND DP FOUND, OR NOT A DIGIT
FCONVI5	BSR	GETCHAR
	JSR	LEFTDIG
	BRA	FCONVI6	ALL IS OK
	BRA	FCONVI8	2ND DP FOUND, OR NOT A DIGIT
FCONVI6	DEC	DIGCNT
	BNE	FCONVI4	NOT DONE, KEEP GOING
	LDA	DPFLAG	DECIMAL POINT SEEN ?
	BNE	FCONVI7B	B/ YES, COLLECT AND IGNORE REMAINING DIGITS
	BRA	FCONVI7A	SKIP INTO EXCESS DIGIT COLLECTION LOOP

FCONVI7	INC	DPCOUNT	BUMP # DIGITS SEEN BEFORE DECIMAL POINT
	BMI	SYNERRJ	B/ TOO MANY DIGITS TO LEFT OF DECIMAL POINT
FCONVI7A	JSR	GETCHAR
	JSR	ISDIG
	BRA	FCONVI7	SCAN OFF REMAINING DIGITS
	CMPA	#'.	DECIMAL POINT ?
	BNE	FCONVI8	B/ NOPE
FCONVI7B	JSR	GETCHAR	YES, COLLECT DIGITS AFTER DP
	JSR	ISDIG
	BRA	FCONVI7B
FCONVI8	LDB	DIGFLG	SEE IF SYNTAX OK SO FAR...
	BNE	FCONVI26
SYNERRJ	JMP	SYNERR	NO DIGITS FOUND YET, ERROR
*
*	SYNTAX OK SO FAR, TRY FOR EXPONENT
*
FCONVI26	LDX	BUFERP	REMEMBER THIS POINTER
	STX	FCVIRT
	CLRB
	STB	DIGFLG	EXPONENT DIGIT FLAG
	STB	MSIGN	EXPONENT SIGN
	STB	MEXP	EXPONENT VALUE
	STB	EXPOVF	EXPONENT OVERFLOW FLAG
	CMPA	#'e
	BEQ	FCONVI26A
	CMPA	#'E
	BNE	FCONVI13	GO CLEAN UP, NO ERRORS
FCONVI26A	JSR	GETCHAR
	CMPA	#'+
	BEQ	FCONVI9	B/ IGNORE LEADING PLUS
	CMPA	#'-
	BNE	FCONVI11
	LDA	#$80
	STA	MSIGN
FCONVI9	JSR	GETCHAR
	BRA	FCONVI11
*
*	COLLECT EXPONENT DIGITS
*
FCONVI10	JSR	GETCHAR
FCONVI11	JSR	ISDIG
	BRA	FCONVI12
	BRA	FCONVI90	GO CLEAN UP
FCONVI12	LDB	MEXP
	ASLB		*2
	BCS	FCONVI91	CATCH THE OVERFLOW
	ASLB		*4
	BCS	FCONVI91	CATCH THE OVERFLOW
	ADDB	MEXP	*5
	BCS	FCONVI91	CATCH THE OVERFLOW
	ASLB		*10
	ABA
	STA	MEXP
	BCC	FCONVI10
FCONVI91	LDA	#1
	STA	EXPOVF
	BRA	FCONVI10
FCONVI90	LDA	DIGFLG	ANY EXPONENT DIGITS?
	BNE	FCONVI13
	LDX	FCVIRT	NO, BACKUP AND IGNORE E PHRASE
	STX	BUFERP
*
*	CLEAN UP HERE
*
FCONVI13	LDA	FAC2	IF FAC2 IS ZERO, WE'RE OK
	BNE	FCONVI14	B/ NONZERO DIGIT SEEN
	STA	FAC1
	BRA	UNDERFLOW	(IT ISN'T REALLY, JUST AN OK EXIT)
FCONVI14	LDA	EXPOVF
	BNE	OVERFLOW	EXPONENT OVERFLOW, SEMANTIC ERROR
	LDB	MEXP
	BEQ	FCONVI15
	LDA	MSIGN
	BPL	FCONVI16
	NEGB
	LDA	#$FF
	BRA	FCONVI16
FCONVI15	CLRA
*
*	A,B HAVE 16 BIT SIGNED VALUE REPRESENTING THE VALUE OF
*	THE SPECIFIED EXPONENT. ADD TO THAT THE # OF DIGITS LEFT OF
*	THE DP
*
FCONVI16	STD	FACX
	LDB	DPCOUNT	SIGN EXTEND THE DP COUNT
	CLRA
	ROLB
	SBCA	#0
	ASRD
	ADDB	FACX+1	*** CANNOT OPTIMIZE FOR 6809 ****
	ADCA	FACX
*
*	IF A <> 0 OR A <> $FF, ERROR
*
	BEQ	FCONVI22
	CMPA	#$FF
	BEQ	FCONVI22
	TSTA
	BPL	OVERFLOW
UNDERFLOW	LDX	#FZERO
	BRA	FCONVI21
*
*	NOW NORMALIZE IF EXP IS ODD
*
FCONVI22	ASRD
	BCS	FCONVI18	B/ NO NORMALIZE
	PSHB		SIGN IS PROPOGATED, SAVE EXPONENT
	CLRA		MAKE FORWARD CARRY = 0
	LDB	#10	MULTIPLIER...
	STB	ML
	LDX	#FACEXT1	MULTIPLY COLLECTED RESULT BY TEN
	JSR	FDIVNORMDIGIT
	JSR	FDIVNORMDIGIT
	JSR	FDIVNORMDIGIT
	JSR	FDIVNORMDIGIT
	JSR	FDIVNORMDIGIT
	JSR	FDIVNORMDIGIT	PROCESS MSD
*	ASSERT:	(A)=0 (NO CARRY!)
	PULB
	CLC
FCONVI18	ADCB	#$40	ADD BIAS
	BVS	OVERFLOW
	BLE	UNDERFLOW
	ORAB	FAC1	PICK UP THE SIGN
	STB	FAC1
	LDX	#FAC1
	BRA	FCONVI21
OVERFLOW	LDA	FAC1
	BPL	FCONVI20
	LDX	#MINFINITY
	BRA	FCONVI25
FCONVI20	LDX	#INFINITY
FCONVI25	PULD
	ADDD	#2
	BRA	FCONVI21A
FCONVI21	PULD
FCONVI21A	STD	FCVIRT
	JSR	FLOAD
	LDD	FCVIRT
	PSHD
	LDX	BUFERP
	DEX
	RTS

SYNERR	LDX	FCVIRT	GET ORIGINAL BUFFER POINTER
	PULD
	ADDD	#4
	PSHD
	RTS
	PAGE
*
*	FIX16 -- CONVERT NON-ZERO FP NUM ON TOS TO 4 BYTE INTEGER..
*	IN RANGE 0..65535
*	SKIP 2 BYTES AT EXIT IF CAN'T FIX OR NOT AN INTEGER IN PROPER RANGE
*
FIX16
	IF	M6800	GET POINTER TO VALUE TO FIX
	LDB	7,S	IS THERE A FRACTIONAL PART OR MORE SIGIFICANCE THAN WE CAN FIX ?
	ORAB	6,X	...?
	BNE	FIXERRJ	B/ YEP
	LDA	2,X	GET EXPONENT BYTE (ASSERT: TOS IS NONZERO FP NUM)
	ELSE	M6801!M6809
	LDD	6,S
	BNE	FIXERRJ
	IF	M6809
	LDA	2,S
	ELSE	M6801
	LDA	2,X
	FIN
	FIN
	BMI	FIXERRJ	B/ < 0, CAN'T FIX16
	CMPA	#$43	MAX FIXABLE EXPONENT ?
	BHI	FIXERRJ	B/ CAN'T FIX16
	BEQ	FIX16A	B/ YES, GO CHECK FOR > 65536
	CMPA	#$41	SINGLE DIGIT RESULT ?
	BCS	FIXERRJ	B/ FRACTIONAL, CAN'T FIX16
	BHI	FIX16$42	B/ CAN FIX IF NO FRACTIONAL PART!
	IF	M6800!M6801
	ORAB	4,X	SEE IF FRACTIONAL PART EXISTS
FIX16$42	ORAB	5,X	...
	ELSE	M6809
	ORAB	4,S
FIX16$42	ORAB	5,S
	FIN
	BNE	FIXERRJ	B/ CAN'T FIX16
	TFR	A,B	IT CAN BE FIXED!
	JMP	FIX1	SO GO DO IT

FIX16A
	IF	M6800!M6801
	LDB	3,X	MAX EXPONENT FOUND, CHK <=65535
	ELSE	(M6809)
	LDB	3,S
	FIN
	CMPB	#65535/(100*100)
	BCS	FIX16B	B/ CAN DO IT!
	BHI	FIXERRJ	B/ CAN'T DO IT
	IF	M6800!M6801
	LDB	4,X	RATS, CAN'T TELL FROM FIRST DIGIT
	ELSE	(M6809)
	LDB	4,S
	FIN
	CMPB	#55	=2ND DIGIT OF 6 55 36
	BCS	FIX16B	B/ CAN DO IT!
	BHI	FIXERRJ	B/ > 655XX
	IF	M6800!M6801
	LDB	5,X	MUST LOOK AT LAST DIGIT
	ELSE	(M6809)
	LDB	5,S
	FIN
	CMPB	#36	= LAST DIGIT OF 6 55 36
	BCC	FIXERRJ	B/ > 65536, CAN'T FIX16
FIX16B	TFR	A,B
	BRA	FIX1
	PAGE
	PAGE
*	FIX FLOATING POINT NUMBER
*	6 BYTE NUMBER ON TOS IS CONVERTED TO
*	4 BYTE SIGNED 2'S COMPLEMENT INTEGER
*	SKIP RETURN IF CAN'T FIX (# < - 2^31 OR # > 2^31 - 1)
*	IF # < 1, RETURN ZERO
*
FIX	TSX
	LDA	2,X	GET EXPONENT
	TFR	A,B
	ANDA	#$7F	CHECK EXPONENT RANGE
	CMPA	#$46
	BGE	FIXERRJ	TOO BIG FOR 32 BITS
	CMPA	#$40
	BGT	FIX1
	CLRA		# < 1, LOAD ZERO
	STA	4,X	RETURN ONLY 4 BYTES HERE
	STA	5,X
	STA	6,X
	STA	7,X
	JMP	FIX8

FIXERRJ	JMP	FIXERR

FIX1
	IF	M6809
	TFR	S,X	SIGH... THIS IS THE MOST CONVENIENT WAY TO DO THIS...
	FIN
	CLRA
	STA	FAC3
	STA	FAC4
	STA	FAC5
	LDA	3,X	USE 1ST F.P. DIGIT ON 1ST ITERATION
	STA	FAC6
	ANDB	#7	LOOP CNTR, 5 >= B >= 1
	DECB		ONLY ONE DIGIT ?
	STB	TEMPB	SET UP LOOP COUNT
	BNE	FIX2	B/ MORE THAN 1 DIGIT TO PROCESS
	JMP	FIX4A	B/ ONLY ONE DIGIT, TAKE FAST EXIT
	PAGE
FIX2	INX		INSERT NEXT F.P. DIGIT INTO FIXED RESULT
FIXMULBY100	EQU	*	MULTIPLY (FAC3,4,5,6) BY 100 AND ADD NEW DIGIT
	LDD	FAC3	FACEXT1,2,3,4:=FAC3,4,5,6
	STD	FACEXT1
	LDD	FAC5	(A,B,FAC5,FAC6):=INPUT*3
	STD	FACEXT3
	ASLD
	ROL	FAC4
	ROL	FAC3
	BCS	FIXERRBCS
	ADDD	FACEXT3
	STD	FAC5
	LDD	FAC3
	ADCB	FACEXT2
	ADCA	FACEXT1
	BCS	FIXERRBCS	B/ OVERFLOW, CAN'T FIX
	ASL	FAC6	*2 --> INPUT * 6
	ROL	FAC5
	ROLD
	BCS	FIXERRBCS
	ASL	FAC6	*2 --> INPUT * 12
	ROL	FAC5
	ROLD
	BCS	FIXERRBCS
	ASL	FAC6	*2 --> INPUT * 24
	ROL	FAC5
	ROLD
	BCS	FIXERRBCS
	STD	FAC3
	LDD	FAC5	ADD ORIGINAL VALUE TO GET INPUT * 25
	ADDD	FACEXT3
	STA	FAC5
	LDA	FAC4
	ADCA	FACEXT2
	STA	FAC4
	LDA	FAC3
	ADCA	FACEXT1
	BCS	FIXERRBCS
	ASLB		*2 --> INPUT * 50
	ROL	FAC5
	ROL	FAC4
	ROLA
FIXERRBCS	BCS	FIXERR
	ASLB		*2 --> INPUT * 100
	ROL	FAC5
	ROL	FAC4
	ROLA
	ADDB	3,X	ADD IN NEW DIGIT
	STB	FAC6
	BCC	FIXMUL100A	B/ NO CARRY
	INC	FAC5
	BNE	FIXMUL100A
	INC	FAC4
	BNE	FIXMUL100A
	INCA
	BEQ	FIXERR
FIXMUL100A	STA	FAC3	SAVE FINAL RESULT (WHEW!)
	DEC	TEMPB	DOWN COUNT # DIGITS LEFT TO PROCESS
	BEQ	FIX4A	B/ DONE
	JMP	FIX2
	PAGE
FIX4A	TSX		CLEAN UP AND EXIT
	LDA	2,X	SEE IF # IS POSITIVE
	BPL	FIX5
	LDD	#0
	SUBA	FAC6
	STA	FAC6
	TFR	B,A
	SBCA	FAC5
	STA	FAC5
	TFR	B,A
	SBCA	FAC4
	STA	FAC4
	TFR	B,A
	SBCA	FAC3
	STA	FAC3
	BVS	FIXERR	CAN'T COMPLEMENT
FIX5	LDD	FAC5
	STD	6,X
	LDD	FAC3
	STD	4,X
FIX8
	IF	M6800!M6801
	LDX	,X
	LEAS	4,S	LEAVE 4 BYTES ON STACK
	ELSE	(M6809)
	PULX
	LEAS	2,S
	FIN
	JMP	,X

FIXERR	PULX		ERROR RETURN, CAN'T FIX  LEAVE 6 BYTES ON TOS
	JMP	2,X
	PAGE
*	FLOAT INTEGER
*	4 BYTE INTEGER ON TOS IS CONVERTED TO 6 BYTE FLOATING POINT FORMAT
*	NO ERROR RETURN
*
FLOAT	PULD
	STD	RETADD
	LDX	#0
	STX	FAC2
	STX	FAC4
	STX	FAC6
	PULD		GET MOST SIGNIFICANT BYTES
	STB	FACEXT2
	PULB
	STB	FACEXT3
	PULB
	STB	FACEXT4
	CLRB
	STA	FACEXT1	SAVE MSB; IS VALUE < 0 ?
	BPL	FLOAT1	NO
	TFR	B,A	YES, COMPLEMENT
	SUBA	FACEXT4
	STA	FACEXT4
	TFR	B,A
	SBCA	FACEXT3
	STA	FACEXT3
	TFR	B,A
	SBCA	FACEXT2
	STA	FACEXT2
	TFR	B,A
	SBCA	FACEXT1
	STA	FACEXT1	OVERFLOW ON COMPLEMENT IS NO SWEAT
	LDB	#$80
	PAGE
FLOAT1	STB	MSIGN
	LDA	FACEXT1	CHECK: CAN WE FLOAT IT QUICKLY ?
	ORAA	FACEXT2
	BNE	FLOAT32	B/ NOPE, GO DO IT THE HARD WAY
	LDA	FACEXT3
	BEQ	FLOATQ1	B/ NUMBER MAY BE ZERO!
	CMPA	#9999/256
	BHI	FLOAT16	B/ 2^16>VALUE>9999
	LDB	FACEXT4	NUMBER IS CLOSE TO 9999...
	BCS	FLOATQJ	B/ < 9999
	CMPB	#9999&$FF	IS IT REALLY <= 9999 ?
	BHI	FLOAT16	B/ NO, GO FLOAT 16 BITS
FLOATQJ	JMP	FLOATQUICK	GO DO FLOAT OF VALUE (0..9999)

FLOATQ1	LDB	FACEXT4	GET LOWER 16 BITS
	BNE	FLOATQJ	B/ VALUE IS <> 0 !
	JMP	FRZERO	ENTIRE VALUE IS ZERO

FLOAT16	LDX	FACEXT3	ONLY 16 BITS TO FLOAT
	STX	FACEXT1	SKIP FIRST 16 SHIFTS
	LDB	#16
	BRA	FLOAT32A
FLOAT32	LDB	#32	LOOP COUNTER (32 BITS TO FLOAT)
FLOAT32A	LDA	FACEXT4	TO HELP SPEED UP THE SHIFTING PROCESS
FLOAT3	ASLA		SHIFT OVER LEADING ZEROS
	ROL	FACEXT3
	ROL	FACEXT2
	ROL	FACEXT1
	DECB		CANNOT GO TO ZERO BECAUSE INPUT WAS <> 0
	BCC	FLOAT3	B/ NO SIGNIFICANCE ENCOUNTERED YET
	STA	FACEXT4	SAVE THIS BACK WHERE IT BELONGS
	INCB		BECAUSE WE OVERSHOT BY 1
	BRA	FLOAT14	NOW GO COLLECT SIGNIFICANCE

FLOAT4	ASL	FACEXT4
	ROL	FACEXT3
	ROL	FACEXT2
	ROL	FACEXT1
FLOAT14	LDA	FAC6
	ADCA	FAC6
	ADDA	#-100	DO BASE 100 DIGIT ADJUSTMENT
	BCS	*+4
	SUBA	#-100
	STA	FAC6
	LDA	FAC5
	ADCA	FAC5
	ADDA	#-100	DO BASE 100 DIGIT ADJUSTMENT
	BCS	*+4
	SUBA	#-100
	STA	FAC5
	LDA	FAC4
	ADCA	FAC4
	ADDA	#-100	DO BASE 100 DIGIT ADJUSTMENT
	BCS	*+4
	SUBA	#-100
	STA	FAC4
	LDA	FAC3
	ADCA	FAC3
	ADDA	#-100	DO BASE 100 DIGIT ADJUSTMENT
	BCS	*+4
	SUBA	#-100
	STA	FAC3
	LDA	FAC2
	ADCA	FAC2
	ADDA	#-100	DO BASE 100 DIGIT ADJUSTMENT
	BCS	*+4
	SUBA	#-100
	STA	FAC2
	DECB
	BNE	FLOAT4
*
	LDA	FAC2	PUT THE # INTO THE STACK
	BEQ	FLOAT5
	LDB	FAC6
	PSHB
	LDB	FAC5
	PSHB
	LDB	FAC4
	PSHB
	LDB	FAC3
	PSHD
	LDA	#$45	5 BYTES OF SIGNIFICANCE
	BRA	FLOAT9
FLOAT5	LDA	FAC3
	BEQ	FLOAT6
	CLRB
	PSHB
	LDB	FAC6
	PSHB
	LDB	FAC5
	PSHB
	LDB	FAC4
	PSHD
	LDA	#$44	4 BYTES OF SIGNIFICANCE
	BRA	FLOAT9
FLOAT6	CLRB		MUST BE 3 BYTES OF SIGNIFICANCE
	PSHB
	LDA	FAC6
	PSHD
	LDD	FAC4
	PSHD
	LDA	#$43
	BRA	FLOAT9

FLOATQUICK	EQU	*	USED TO FLOAT VALUES 0..9999
	JSR	CONVERTTOBASE100	RIP VALUE APART TO GET BASE 100 DIGITS
	STA	FAC5	SAVE UPPER DIGIT
	BEQ	FLOAT8	B/ UPPER DIGIT IS ZERO
	CLRA
	PSHA
	PSHA
	PSHA
	LDA	FAC5
	PSHD
	LDA	#$42	2 BYTES OF SIGNIFICANCE
	BRA	FLOAT9

FLOAT8	PSHA	ASSERT: (A)=0
	PSHA
	PSHA
	PSHA
	PSHB		THIS BYTE CANNOT BE ZERO
	LDA	#$41	1 BYTE OF SIGNIFICANCE
FLOAT9	ORAA	MSIGN
	PSHA
	JMP	[RETADD]
	PAGE
*	FLOATING OUTPUT CONVERSION ROUTINE
*	TOS CONTAINS FLOATING POINT NUMBER TO CONVERT
*	X REG POINTS TO THE OUTPUT BUFFER
*	CONVERTS NUMBER TO ASCII STRING IN 'E' FORMAT:
*	<SIGN> <'.'> <10 DIGITS> <'E'> <ESIGN> <3 DIGITS>
*	A RETURNS A NUMBER REPRESENTING # OF DIGITS
*	TO THE LEFT OF THE '.' IF THE # WERE NORMALIZED SUCH THAT 'E' = 0
*	(EXAMPLE: A CONTAINS  0 --> ".DDDDDDDDDD"
*	          A CONTAINS -2 --> ".00DDDDDDDDDD"
*	          A CONTAINS  2 --> "DD.DDDDDDDD"
*	B RETURNS # OF SIGNIFICANT DIGITS (10 - # OF RIGHTMOST ZERO DIGITS)
*	NUMBER IS POPPED OFF TOS
*	NO ERROR EXIT
*	FOR ZERO, THIS ROUTINE RETURNS: ????
FCONVO	STX	BUFERP
	PULD		GET RETURN ADDDRESS
	STD	RETADD
	PULA		GET EXPONENT
	STA	MEXP	SAVE IT
	LDA	#5
	STA	ML
FCVO1	PULB		PUT OUT 10 DIGITS
	LDA	#-1	A = LEFT HAND DIGIT
FCVO1L	INCA		BUMP LEFT HAND DIGIT
	SUBB	#10
	BPL	FCVO1L
	ADDB	#10
	ADDA	#'0
	INX
	STA	1,X
	ADDB	#'0
	INX
	STB	1,X
	DEC	ML
	BNE	FCVO1
	LDB	#'+	PUT OUT SIGN
	LDA	MEXP
	BPL	FCVO2
	LDB	#'-
FCVO2	LDX	BUFERP
	STB	,X
	LDB	#'.	PUT OUT DECIMAL POINT
	STB	1,X
	LDB	#'E	PUT OUT 'E'
	STB	12,X
	LDB	#'+	PUT OUT ESIGN
	ASLA
	BMI	FCVO3
	LDB	#'-
FCVO3	STB	13,X
	STA	MEXP
	LDA	2,X
	CMPA	#'0
	BNE	FCVO5
	TFR	A,B
	DEC	MEXP
	LDA	#9
	STA	ML
FCVO4	INX		ENSURE LEAD DIGIT IS NON-ZERO
	LDA	2,X
	STA	1,X
	DEC	ML
	BNE	FCVO4
	STB	2,X
FCVO5	LDA	MEXP
	SUBA	#$40*2
	PSHA
	BPL	FCVO10
	NEGA
FCVO10	STA	ML	MAKE EXPONENT DIGITS
	CLRA
	STA	TEMPA
	STA	TEMPB
	LDB	#8
FCVO6	ASL	ML
	LDA	TEMPB
	ADCA	TEMPB
	DAA
	STA	TEMPB
	LDA	TEMPA
	ADCA	TEMPA
	DAA
	STA	TEMPA
	DECB
	BNE	FCVO6
	LDX	BUFERP
	LDA	TEMPA	CONVERT BCD TO ASCII
	ADDA	#'0
	STA	14,X
	LDA	TEMPB
	TFR	A,B
	LSRA
	LSRA
	LSRA
	LSRA
	ADDA	#'0
	STA	15,X
	TFR	B,A
	ANDA	#$F
	ADDA	#'0
	STA	16,X
	LDA	#10
	STA	ML
	TFR	A,B
FCVO7	DEX	COUNT # OF SIG DIGITS
	LDA	12,X
	CMPA	#'0
	BNE	FCVO8
	DECB
	DEC	ML
	BNE	FCVO7
FCVO8	PULA
	TSTB		SEE IF # WAS ZERO
	BNE	FCVO9
	CLRA		YES, SET # OF INT DIGITS TO ZERO TOO
FCVO9	JMP	[RETADD]
	PAGE
*	FLOATING POINT INTEGER FUNCTION
*	TRUNCATES FRACTION BITS IF ANY
*	RETURN NEXT INTEGER NOT LARGER THAN TOS
*	EXAMPLE:
*	INT(1.0) = 1.0
*	INT(1.2) = 1.0
*	INT(-2.0) = -2.0
*	INT(-1.2) = -2.0
*	NO ERROR RETURN
*
FINT	PULD
	STA	FINTRT
	STB	FINTRT+1
	LDB	,S
	STB	MSIGN
	ANDB	#$7F
	CMPB	#$44
	BHI	FINT3	DONE
	CMPB	#$40
	BHI	FINT4
	LEAS	RSESIZ,S	POP STACK ENTRY
	LDA	MSIGN
	BPL	FINT2	POSITIVE, MAGNITUDE > 0 & < 1, LOAD UP 0.0
	LDX	#FMONE	NEGATIVE, MAGNITUDE < 0, LOAD UP -1
	BRA	FINT1
FINT2	LDX	#FZERO
FINT1	JSR	FLOAD

FINT3	JMP	[FINTRT]

FINT4	LDA	#$45
	SBA		A HAS # OF RIGHT BYTES TO CHECK
	CLRB		CHECK FOR FRACTIONAL PART
	TSX
FINT5	DEX
	ORAB	6,X	(B) <>0 --> FRACTION
	CLR	6,X	ZERO FRACTIONAL PART
	DECA
	BNE	FINT5
	LDA	MSIGN	IF <0 AND FRACTIONAL PART, SUBTRACT 1
	BPL	FINT3	# IS POSITIVE
	TSTB
	BEQ	FINT3	# IS NEGATIVE, BUT NO FRACTION, DONE
	LDX	#FMONE	SIGH..., SUBTRACT 1 FROM #
	JSR	FLOAD
	JSR	FADD	SUBTRACT 1, NO OVERFLOW POSSIBLE
	BRA	FINT3

BASICRTPEND$	EQU	*

	ORG	(*//256)*256	SKIP UP TO NEXT PAGE BOUNDARY
*	CHAIN AND GO
*	MODELS THE FOLLOWING BASIC PROGRAM:
*		DIM PROGRAM$(50)
*		INPUT '' PROGRAM$
*		CHAIN PROGRAM$
*		END
*
CHAINGO	JSR	$100	OFF TO THE RTP!
	+VERSION		VERSION NUMBER
	#0		FREF LABEL CHAIN
	#$100		CAT BUF SIZE REQUIRED (FOR INPUT LINE)
	#CHAINGOEND	BASE OF SCALAR VARS (USELESS, HERE!)
	#CHAINGOEND		TOP OF DATA SPACE
	OPZCHN		ZERO THE CHANNEL NUMBER
	OPINL		INPUT A LINE FROM THE KEYBOARD
	#:1		WHERE TO GO IF EOF ERROR
:1	OPINS		PUSH DESCRIPTOR FOR INPUT STRING
	OPCHAIN		AND CHAIN TO IT!
CHAINGOEND	EQU	*
	END	CHAINGO

