	PCC	0
	NAME	CTLBASRTP1.4b
	TITLE	SD CONTROL BASIC Version 1.4a Runtime Package (c) 1981 Software Dynamics
	INCLUDE	SDOSUSERDEFS.ASM	SO WE GET SDOS INTERFACE STUFF
	TITLE	SD CONTROL BASIC Version 1.4a Runtime Package (c) 1981 Software Dynamics
	PAGE	***** ERROR AND ADDRESS CONSTANTS *****
	TABS	20,28,44,45
	PAGE
	PGEN	1	I WANT TO SEE ALL THE GENERATED STUFF
*
*	CONTROL BASIC RUNTIME PACKAGE
****** THE CONTENTS OF THIS FILE ARE PROPRIETARY TO SOFTWARE DYNAMICS ****
****** THEY MAY NOT BE RELEASED WITHOUT THE WRITTEN AUTHORIZATION OF SD ****
*	ALL RIGHTS RESERVED
*	EDITED 10/30/81 1100
*
*
*	CONTROL BASIC IS A SUBSET OF SD BASIC
*	THE DIFFERENCES ARE:
*		1) NO FLOATING POINT NUMBERS!
*		2) INTEGERS ARE RESTRICTED TO THE RANGE -32768..32767
*		3) HEX CONSTANTS ARE OK, BUT DO NOT ATTEMPT TO USE A
*		   HEX NUMBER > :7FFF IN A COMPARISON.
*		4) LOGICAL OPERATORS (!,&,XOR,COM) OPERATE ONLY ON "HEX"
*		   VALUES.  NO COMPLAINTS WILL BE ISSUED IF A LOGICAL OP
*		   IS PERFORMED ON A NEGATIVE NUMBER, BUT THE RESULT IS NOT
*		   DEFINED.
*		5) STRING VARIABLES ARE LIMITED TO 255 BYTES, MAX. THEIR
*		   LENGTH IS PERMANENTLY SET TO THE DIM'D LENGTH.
*		   STRING ASSIGNMENT, COMPARE, PRINT, INPUT ARE OK; BUT
*		   NO SUBSTRING REFERENCES ARE ALLOWED (BYTE SUBSCRIPTS
*		   MUST BE USED). FIND WORKS; STRING ARRAYS ARE ILLEGAL,
*		   AS IS THE CAT AND LOWERCASE$ OPERATORS. STRING ASSIGNMENT
*		   WILL PAD A TARGET STRING WITH BLANKS IF IT IS LONGER THAN
*		   THE SOURCE STRING
*		6) NO PRINT USING OR NUMF$
*		7) NO SYSCALL STATEMENT.
*		8) NO RENAME, TIME$ OR DATE$ FUNCTIONS
*		9) NO DOUBLY-SUBSCRIPTED ARRAYS, ONLY VECTORS
*
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
*	CONTROL BASIC String structure
*	StringPointer --> !    x     !     To be compatible with SD BASIC 1.4
*                        !    x     !     (Nominally dimensioned length of string)
*                        !    x     !     (Nominally current length of string)
*                        ! Length   !     0 to 255 bytes, max
*                        !  byte1   !     1st byte of string
*                        !  byte2   !     ...
*                        !  ....    !
*                        ! lastbyte !     Last byte of string
*
*	*** 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
:ILLEGALOP	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	2	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
*
*
VINT1	EQU	4	INTEGER VARIABLE FIRST BYTE
VINT2	EQU	5	2ND BYTE
	PAGE
*	DATA STRUCTURE & ADDRESS DISPLACEMENT CONSTANTS FOR
*	RUNTIME (OR VALUE) STACK
*
R1ADDH	EQU	0	TOS ADDRESS HIGH
R1ADDL	EQU	1	TOS ADDRESS LOW
R1ADD	EQU	0	TOS ADDRESS
*
R2ADDH	EQU	2	TOS-1 ADDRESS HIGH
R2ADDL	EQU	3	TOS-1 ADDRESS LOW
R2ADD	EQU	2	TOS-1 ADDRESS
*
R1INT1	EQU	0	TOS INTEGER VALUE MSBYTE
R1INT2	EQU	1	TOS INTEGER 2ND BYTE
*
R2INT1	EQU	2	TOS-1 INTEGER MSBYTE
R2INT2	EQU	3	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	0	TOS STRING DESCRIPTOR ADDRESS
R1SDAH	EQU	0	TOS STRING DESCRIPTOR ADDRESS HIGH
R1SDAL	EQU	1	TOS STRING DESCRIPTOR ADDRESS LOW
*
R2SDA	EQU	2	TOS-1 STRING DESCRIPTOR ADDRESS
R2SDAH	EQU	2	TOS-1 STRING DESCRIPTOR ADDRESS HIGH
R2SDAL	EQU	3	TOS-1 STRING DESCRIPTOR ADDRESS LOW
	PAGE
*	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

	IF	CODE=$100	SDOS VERSION OF RTP
****
FATALTRAPVECTOR	FDB	ERROREXIT	POINTER TO ROUTINE TO HANDLE FATAL ERRORS
****
	ELSE
****
FATALTRAPVECTOR	RMB	2	POINTER TO ROUTINE TO HANDLE FATAL ERRORS
****
	FIN

*	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
ILERR	RMB	2	RECOVERY ADDRESS FOR "XOPINLINE" OPCODE
CONTEXTEND	EQU	*

SUBROUTINENESTING	RMB	1	= NESTING OF SUBROUTINES/FUNCTIONS

BPCSAV	RMB	2	FOR SUBROUTINE/FUNCTION CALL OPCODE
	PAGE

TBYTE	RMB	1	TEMP BYTE
FLAG	RMB	1	TRUE <> 0 FALSE = 0
*
*	THE FOLLOWING VARS ARE USED BY THE SYSCALL ROUTINE
*
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
*
TWORD	RMB	2	TEMPORARY WORD
S1LEN	RMB	1	HOLDS LEN OF STR 1 FOR COMPARE
S2LEN	RMB	1	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
RTPRET	RMB	2	HOLDS A RETURN ADDRESS
	IF	M6800!M6801
JMPADD	RMB	2	HOLDS POINTER TO ENTRY IN 1ST HALF OF JUMP TABLE
	FIN
	PAGE
BUFERP	RMB	2	CONVERSION BUFFER POINTER
DIGITCOUNT	RMB	1	HOLDS DIGIT COUNT FOR CONVERT
LOOPX	RMB	2	2 BYTE LOOP COUNTER
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
SIGN	RMB	1	SIGN OF RESULT
FNRESULT	RMB	2	RESULT OF FUNCTION
OUTBUF	RMB	8	BUFFER HOLDING OUTPUT DIGIT STRING
MULTIPLIER	RMB	2	MULTIPLIER
MULTIPLICAND	RMB	2	MULTIPLICAND
QUOTIENT	EQU	MULTIPLIER
REMAINDER	EQU	MULTIPLICAND
DIVISOR	RMB	2

INPUTEND	RMB	2	POINTER TO END OF INPUT COLLECT BY OPINL
	PAGE	INITIALIZATION DATA
*
*
CATBUF	RMB	2	START OF THE CAT BUFFER
CATSIZ	RMB	2	SIZE OF CAT BUFFER

	IF	*>/$F0	CHECK FOR SDOS PAGE ZERO OVERFLOW
	?PAGE ZERO OVERFLOW?
	FIN
	PAGE	*** INIT AND ERROR ENTRY POINTS ***
	ORG	CODE
	JMP	INIT	*** ENTRY POINT FOR COMPILED BASIC PROGRAMS ***
	JMP	IOERROR	RETAIN COMPATIBILITY WITH BASIC 1.4 RTP
	JMP	SUBFUNENTRY	SUBROUTINE OR FUNCTION ENTRY POINT
*
	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
	EQU	((*-JMPTBL)&$FF)/2
	FDB	ILLEGALOPCODE
	EQU	((*-JMPTBL)&$FF)/2
	FDB	ILLEGALOPCODE
	EQU	((*-JMPTBL)&$FF)/2
	FDB	ILLEGALOPCODE
	EQU	((*-JMPTBL)&$FF)/2
	FDB	ILLEGALOPCODE
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
	EQU	((*-JMPTBL)&$FF)/2
	FDB	ILLEGALOPCODE
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
	EQU	((*-JMPTBL)&$FF)/2
	FDB	ILLEGALOPCODE
OPFIND	EQU	((*-JMPTBL)&$FF)/2
	FDB	XOPFIND	STRINGS	FIND OCCUR OF STR TOS IN TOS-1
	EQU	((*-JMPTBL)&$FF)/2
	FDB	ILLEGALOPCODE
	EQU	((*-JMPTBL)&$FF)/2
	FDB	ILLEGALOPCODE
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
	EQU	((*-JMPTBL)&$FF)/2
	FDB	ILLEGALOPCODE
	EQU	((*-JMPTBL)&$FF)/2
	FDB	ILLEGALOPCODE
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
	EQU	((*-JMPTBL)&$FF)/2
	FDB	ILLEGALOPCODE
OPSETLABEL	EQU	((*-JMPTBL)&$FF)/2
	FDB	XOPSETLABEL	SIMILAR TO OPLINE
OPMAXLEN	EQU	((*-JMPTBL)&$FF)/2
	FDB	XOPMAXLEN	SIMILAR TO OPLEN
	EQU	((*-JMPTBL)&$FF)/2
	FDB	ILLEGALOPCODE
	EQU	((*-JMPTBL)&$FF)/2
	FDB	ILLEGALOPCODE
	EQU	((*-JMPTBL)&$FF)/2
	FDB	ILLEGALOPCODE
	EQU	((*-JMPTBL)&$FF)/2
	FDB	ILLEGALOPCODE
	EQU	((*-JMPTBL)&$FF)/2
	FDB	ILLEGALOPCODE
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 IN LINE
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
	EQU	((*-JMPTBL)&$FF)/2
	FDB	ILLEGALOPCODE
OPLDB	EQU	(*-JMPTBL)/2
	FDB	XOPLDB	LOAD	LOAD BYTE USING SD ON TOS
	EQU	(*-JMPTBL)/2
	FDB	ILLEGALOPCODE
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
	EQU	((*-JMPTBL)&$FF)/2
	FDB	ILLEGALOPCODE
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
	EQU	(*-JMPTBL)/2
	FDB	ILLEGALOPCODE
	EQU	(*-JMPTBL)/2
	FDB	ILLEGALOPCODE
	EQU	(*-JMPTBL)/2
	FDB	ILLEGALOPCODE
	EQU	(*-JMPTBL)/2
	FDB	ILLEGALOPCODE
OPST	EQU	(*-JMPTBL)/2
	FDB	XOPST	STORE	STORE TOS USING TOS-1
OPSTS	EQU	((*-JMPTBL)&$FF)/2
	FDB	XOPSTS	STORE	STORE STRING ON TOS IN STRING GIVEN BY 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
	EQU	((*-JMPTBL)&$FF)/2
	FDB	ILLEGALOPCODE
	EQU	((*-JMPTBL)&$FF)/2
	FDB	ILLEGALOPCODE
	EQU	((*-JMPTBL)&$FF)/2
	FDB	ILLEGALOPCODE
	EQU	((*-JMPTBL)&$FF)/2
	FDB	ILLEGALOPCODE
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
	EQU	((*-JMPTBL)&$FF)/2
	FDB	ILLEGALOPCODE
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
	EQU	((*-JMPTBL)&$FF)/2
	FDB	ILLEGALOPCODE
OPFIND	EQU	(*-JMPTBL)/2
	FDB	XOPFIND	STRINGS	FIND OCCUR OF STR TOS IN TOS-1
	EQU	((*-JMPTBL)&$FF)/2
	FDB	ILLEGALOPCODE
	EQU	((*-JMPTBL)&$FF)/2
	FDB	ILLEGALOPCODE
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
	EQU	(*-JMPTBL)/2
	FDB	ILLEGALOPCODE
	EQU	((*-JMPTBL)&$FF)/2
	FDB	ILLEGALOPCODE
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
	EQU	(*-JMPTBL)/2
	FDB	ILLEGALOPCODE
OPSETLABEL	EQU	(*-JMPTBL)/2
	FDB	XOPSETLABEL	SIMILAR TO OPLINE
OPMAXLEN	EQU	(*-JMPTBL)/2
	FDB	XOPMAXLEN	SIMILAR TO OPLEN
	EQU	(*-JMPTBL)/2
	FDB	ILLEGALOPCODE
	EQU	(*-JMPTBL)/2
	FDB	ILLEGALOPCODE
	EQU	(*-JMPTBL)/2
	FDB	ILLEGALOPCODE
	EQU	(*-JMPTBL)/2
	FDB	ILLEGALOPCODE
	EQU	(*-JMPTBL)/2
	FDB	ILLEGALOPCODE
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	*
	EQU	OPEXTENDED*256+(*-EXTENDEDJMPTBL)/2
	FDB	ILLEGALOPCODE
	EQU	OPEXTENDED*256+(*-EXTENDEDJMPTBL)/2
	FDB	ILLEGALOPCODE
	EQU	OPEXTENDED*256+(*-EXTENDEDJMPTBL)/2
	FDB	ILLEGALOPCODE
	EQU	OPEXTENDED*256+(*-EXTENDEDJMPTBL)/2
	FDB	ILLEGALOPCODE
	EQU	OPEXTENDED*256+(*-EXTENDEDJMPTBL)/2
	FDB	ILLEGALOPCODE
	EQU	OPEXTENDED*256+(*-EXTENDEDJMPTBL)/2
	FDB	ILLEGALOPCODE
	EQU	OPEXTENDED*256+(*-EXTENDEDJMPTBL)/2
	FDB	ILLEGALOPCODE
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
	EQU	OPEXTENDED*256+(*-EXTENDEDJMPTBL)/2
	FDB	ILLEGALOPCODE
OPERRST	EQU	OPEXTENDED*256+(*-EXTENDEDJMPTBL)/2
	FDB	XOPERRST	ERROR	ERROR STMT
	EQU	OPEXTENDED*256+(*-EXTENDEDJMPTBL)/2
	FDB	ILLEGALOPCODE
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
	EQU	OPEXTENDED*256+(*-EXTENDEDJMPTBL)/2
	FDB	ILLEGALOPCODE
	EQU	OPEXTENDED*256+(*-EXTENDEDJMPTBL)/2
	FDB	ILLEGALOPCODE
OPNUM	EQU	OPEXTENDED*256+(*-EXTENDEDJMPTBL)/2
	FDB	XOPNUM	PRINT	CONVERT TOS VALUE TO STRING
	EQU	OPEXTENDED*256+(*-EXTENDEDJMPTBL)/2
	FDB	ILLEGALOPCODE
OPVAL	EQU	OPEXTENDED*256+(*-EXTENDEDJMPTBL)/2
	FDB	XOPVAL	PRINT	CONVERT TOS STRING TO VALUE
	EQU	OPEXTENDED*256+(*-EXTENDEDJMPTBL)/2
	FDB	ILLEGALOPCODE
	EQU	OPEXTENDED*256+(*-EXTENDEDJMPTBL)/2
	FDB	ILLEGALOPCODE
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
	EQU	OPEXTENDED*256+(*-EXTENDEDJMPTBL)/2
	FDB	ILLEGALOPCODE
OPEXIT	EQU	OPEXTENDED*256+(*-EXTENDEDJMPTBL)/2
	FDB	XOPEXIT
OPLENVECTOR	EQU	OPEXTENDED*256+(*-EXTENDEDJMPTBL)/2
	FDB	XOPLENVECTOR	SUBSCRIPTS:	PUSH DIM'D LENGTH OF VECTOR
	EQU	OPEXTENDED*256+(*-EXTENDEDJMPTBL)/2
	FDB	ILLEGALOPCODE
	EQU	OPEXTENDED*256+(*-EXTENDEDJMPTBL)/2
	FDB	ILLEGALOPCODE
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
	EQU	OPEXTENDED*256+(*-EXTENDEDJMPTBL)/2
	FDB	ILLEGALOPCODE
	EQU	OPEXTENDED*256+(*-EXTENDEDJMPTBL)/2
	FDB	ILLEGALOPCODE
	IF	(*-EXTENDEDJMPTBL)>/$80
	?EXTENDED JUMP TABLE TOO LARGE?
	FIN
	PAGE
COPYRIGHT	EQU	*
	FCC	"CONTROL BASIC Runtime Package Version 1.4a"
	FCB	$0D
	FCC	"Copyright (C) 1981 Software Dynamics"
	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
	LDAA	#EXTENDEDJMPTBL/256
	STD	TEMPX	(ASSERT: 2ND BYTE <= 127)
	LDX	TEMPX
	LDX	EXTENDEDJMPTBL&$FF,X
	JMP	0,X
	ELSE	(M6809)
	LDB	,X	GET 2ND BYTE OF OPCODE
	ASLB		DOUBLE TO MAKE WORD INDEX
	LDX	#EXTENDEDJMPTBL
	JMP	[B,X]	ASSERT: (B) <= 126
	FIN
	PAGE
	IF	M6800!M6801
PL2PC1	LEAS	RSESIZ,S	PULL 2 VALUE STACK ENTRIES, BUMP BPC BY ONE
PL1PC1	LEAS	RSESIZ,S	PULL 1 VALUE STACK ENTRY, BUMP BPC BY ONE
NTRPT1	LDX	BPC	FINISHED PROCESSING ONE BYTE OP, EXECUTE NEXT OP
NTRPTX	LDAB	0,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	STAB	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	0,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
	LDY	#JMPTBL	BRANCH TO OPCODE ROUTINE
	JMP	[B,Y]

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	LDY	#JMPTBL
	JMP	[B,Y]
	FIN
	PAGE
	IF	M6800!M6801
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
	LDAB	0,X	INTERPRET STARTING AT (X)
	INX
	STX	BPC
	ASLB
	BCS	XOPLSCALAR
	STAB	JMPADD+1
	LDX	JMPADD
	LDX	JMPTBL&$FF,X
	JMP	0,X
*
PL1PC3	LEAS	RSESIZ,S	PULL 1 VALUE STACK ENTRY, BUMP BPC BY THREE
NTRPT3X	; (X) CONTAINS ADDRESS OF OPCODE+1: ADVANCE PAST 3 BYTE OPCODE
NTRPT3	LDAB	#2	BUMP BPC PAST 3 BYTE OPCODE AND EXECUTE NEXT
NTRADB	ADDB	BPC+1	ADD (A) TO BPC AND EXECUTE NEXT
	STAB	BPC+1
	BCC	NTRPT0
	INC	BPC
NTRPT0	LDX	BPC	USE BPC AS ADDRESS OF NEXT INSTRUCTION TO EXECUTE
	LDAB	0,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
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
	LDY	#JMPTBL
	JMP	[B,Y]

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
	LDY	#JMPTBL	GO TO ROUTINE
	JMP	[B,Y]

NTRPTB,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
	LDAA	#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
	LDAA	#0	CAPTURE CARRY BIT IN (A)
	ROLA
XOPLSCALAR1	LDX	VARTABLE	ADD BASE OF SCALAR VARIABLES
	LEAX	D,X
	FIN
	LDD	VINT1,X	GET LAST BYTE PAIR
	PSHD		MUST PUSH 16 BITS MINIMUM
	JMP	NTRPT1
	PAGE
*	STORE SCALAR
*
XOPSSCALAR	; STORE SCALAR OPCODE
	IF	M6800!M6801
	SUBB	#$80	DROP "STORE" OPCODE BIT
	ABA	; (A)=SCALAR NUMBER * 6
	TAB
	LDAA	#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
	LDAA	#0	CAPTURE CARRY BIT IN (A)
	ROLA
	SUBD	#$80	SUBTRACT $80 EXCESS
XOPSSCALAR1	LDX	VARTABLE	COMPUTE ADDRESS OF SCALAR
	LEAX	D,X
	FIN
	PULD
	STD	VINT1,X
	JMP	NTRPT1
	PAGE
	IF	M6800!M6801
XOPLESCALAR	; LOAD EXTENDED SCALAR  (LOAD EXTENDED SCALAR)(SCALAR#-64)
	LDX	BPC
	LDAB	ILADD,X	SCALAR #
	CLRA
	ASLD		SCALAR # *2
	ADDB	ILADD,X	SCALAR # *3
	ADCA	#0
	ASLD		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
	LDAB	ILADD,X
	CLRA
	ASLD		SCALAR # * 2
	ADDB	ILADD,X	SCALAR # * 3
	ADCA	#0
	ASLD		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
	LDAA	#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
	LDAA	#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	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
	LDAA	#JMPTBL/256
	STAA	JMPADD
	FIN
	CLR	SUBROUTINENESTING	"NO SUBROUTINE CALLED"
	LDX	0,S
	STX	BPC
	LDAA	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	ADDB	0,X	ADD A BYTE
	INX
	CPX	#BASICRTPEND$
	BNE	TOTALRTPSUM	B/ MORE BYTES TO SUM
	TSTB		PROPER VALUE ? (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	NTRPT1	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
	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	*
	LDD	RTP:TOPOFDATASPACE,X	CHECK FOR DATA SPACE OVERLAP WITH SDOS
	SUBD	CATBUF
	BCC	DATASPACEERROR
	IF	CODE=$100
	LDD	BPC
	SUBD	#BASICRTPEND$+3
	BCS	OVERLAPERROR
	FIN
	LDD	RTP:BASEOFSCALARVARS,X
	STD	VARTABLE
	LDX	RTP:FREFLABELCHAIN,X
	BNE	RESOLVEL
	RTS

DATASPACEERROR	BSR	FORCEERROR	FORCE UNTRAPPABLE ERROR
	JSR	RTPERR
	FCB	:DATASPACECONFLICT

	IF	CODE=$100
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 VALUE
*	ADDRESS IN LINE, PUSH 6
*
XOPLOAD	; LOAD VALUE AT INLINE ADDRESS OPCODE
	IF	M6800!M6801
	LDX	BPC
	FIN
	LDX	ILADD,X
LOADX	LDD	VINT1,X	LEAST SIGNIFICANT WORD
	PSHD
	JMP	NTRPT3
*
*	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
	JMP	NTRPT3X
*
*	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
	LDAB	ILINT,X	FETCH VALUE OF INTEGER
	CLRA		CONVERT TO 16 BITS
	PSHD		PUSH THE INTEGER
	JMP	NTRPT2X
	PAGE
*
*	LOAD BYTE, ADDRESS ON TOS
*
XOPLDB	LDX	R1SDA,S	GET ADDRESS OF BYTE
	LDAB	STRING,X	GET BYTE
LOADB1
	IF	M6800!M6801
	TSX
	CLR	R1INT1,X
	STAB	R1INT2,X
	ELSE	(M6809)
	CLRA
	STD	R1INT2,S
	FIN
	JMP	NTRPT1
	PAGE
*	LOAD VALUE
*	ADDRESS ON STACK, REPLACE WITH VALUE
*
XOPLV	LDX	R1ADD,S
	IF	M6800!M6801
	LEAS	RSESIZ,S	POP ADDRESS FROM STACK
	LDD	VINT1,X
	PSHD
	ELSE	(M6809)
	LDD	VINT1,X	GRAB THE VALUE...
	STD	R1INT1,S	AND STORE IT WHERE THE POINTER WAS
	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
	JMP	NTRPT1
*
*	OPLBOOL -- LOAD BOOLEAN VALUE (OF FLAG)
*
XOPLBOOL	LDAB	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  *****
*	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
	LDAA	0,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
	JMP	NTRPT1		OPEQ,OPBT,#...	etc.
	PAGE
*
*	INTEGER FUNCTION
*
XOPINT	EQU	NTRPT1
*
*	SIGNUM FUNCTION
*
XOPSGN	LDA	R1INT1,S
	BMI	SGNM
	BNE	SGNP
	IF	M6800!M6801
	LDB	R1INT2,X	CHECK LOWER BYTE FOR ZERO
	BEQ	SGNZ	B/ IS ZERO, VALUE IN STACK IS CORRECT RESULT
SGNP	LDD	#1	POSITIVE ARGUMENT, VALUE IS "1"
SGNS	STD	R1INT1,X	STORE RESULT IN STACK
	ELSE	(M6809)
	LDB	R1INT2,S	CHECK LOWER BYTE FOR ZERO
	BEQ	SGNZ	B/ IS ZERO, VALUE IN STACK IS CORRECT RESULT
SGNP	LDD	#1	POSITIVE ARGUMENT, VALUE IS "1"
SGNS	STD	R1INT2,S	STORE RESULT IN STACK
	FIN
SGNZ	JMP	NTRPT1	AND EXIT

SGNM	LDD	#-1	NEGATIVE ARGUMENT, RESULT IS "-1"
	BRA	SGNS
	PAGE	*****  A R I T H M E T I C   G R O U P  *****
*	DIVIDE -- DIVIDE UNSIGNED(D) BY UNSIGNED(X)
*	BOTH (D) AND (X) ARE UNSIGNED
*	SKIP EXIT IF OVERFLOW
*
DIVIDE	STX	DIVISOR	SAVE THE DIVISOR
	BEQ	DIVIDEO	B/ DIVISION BY 0
	LDX	#17	= NUMBER OF QUOTIENT BITS TO GENERATE
	STD	QUOTIENT	SET UP SOURCE OF REMAINDER BITS
	CLRA		SET REMAINDER TO 0
	CLRB
DIVIDEL	SUBD	DIVISOR	COMPUTE QUOTIENT BIT
	BCC	DIVIDE1	B/ Q BIT IS A "ONE"
	ADDD	DIVISOR	Q BIT IS ZERO, RESTORE REMAINDER
*	SEC		"ADDD" DOES THIS
DIVIDE1 ; CARRY BIT IS COMPLEMENT OF TRUE QUOTIENT BIT
	ROL	QUOTIENT+1	SAVE THE Q BIT
	ROL	QUOTIENT
	ROLD		DOUBLE THE REMAINDER FOR NEXT LOOP ITERATION
	DEX		DOWN COUNT REMAINING ITERATIONS
	BNE	DIVIDEL	B/ MORE QUOTIENT BITS TO GENERATE
	LSRD		= FINAL REMAINDER
	STD	REMAINDER	IN CASE SOMEBODY NEEDS IT
	LDD	QUOTIENT	GET INVERTED QUOTIENT
	COMD		MAKE A TRUE QUOTIENT
	RTS		AND EXIT!

DIVIDEO	PULX		TAKE SKIP EXIT ON ERROR
	JMP	2,X
	PAGE
*	DIVIDE TOS INTO TOS-1
*
XOPDIV	; DIVIDE TOS INTO TOS-1
	CLR	SIGN	ASSUME QUOTIENT IS POSITIVE
	LDD	R1INT1,S	FETCH DIVISOR
	BPL	SIGNEDDIVIDE1	B/ DIVISOR IS POSITIVE
	NEGD		NO, TAKE ABSOLUTE VALUE
	INC	SIGN	ODD SIGN --> RESULT WILL BE NEGATIVE
SIGNEDDIVIDE1
	STD	FNRESULT	SAVE ABS OF DIVISOR
	IF	M6800!M6801
	LDD	R2INT1,X
	ELSE	(M6809)
	LDD	R2INT1,S
	FIN
	BPL	SIGNEDDIVIDE2	B/ DIVIDEND IS POSITIVE
	NEGD		TAKE ABSOLUTE VALUE OF DIVIDEND
	INC	SIGN	EVEN SIGN --> RESULT WILL BE POSITIVE
SIGNEDDIVIDE2
	LDX	FNRESULT	FETCH DIVISOR
	BSR	DIVIDE	NEED I SAY MORE ?
	BRA	XOPMUL3
	BRA	OVERFLOW	DIVISION BY 0!

	PAGE
*
*	MULTIPLY TOS BY TOS-1
*	A,B WILL CONTAIN MULTIPLICAND
*	X WILL CONTAIN MULTIPLIER
*	A,B WILL CONTAIN THE PRODUCT
*
XOPMUL	; MULTIPLY
	CLR	SIGN	EVEN --> POSITIVE RESULT
	LDD	R1INT1,S
	BPL	XOPMUL1	B/ MULTIPLIER IS POSITIVE
	INC	SIGN	MULTIPLIER IS NEGATIVE
	NEGD		TAKE ABSOLUTE VALUE
XOPMUL1	STD	FNRESULT	SAVE MULTIPLIER
	IF	M6800!M6801
	LDD	R2INT1,X
	ELSE	(M6809)
	LDD	R2INT1,S	FETCH MULTIPLICAND
	FIN
	BPL	XOPMUL2	B/ MULTIPLICAND IS POSITIVE
	INC	SIGN	REMEMBER THAT MULTIPLICAND IS NEGATIVE
	NEGD
XOPMUL2	LDX	FNRESULT	GET MULTIPLIER
	JSR	MLTPLY
	BRA	XOPMUL3
	BRA	OVERFLOW	RESULT IS TOO BIG!

XOPMUL3	ROR	SIGN	IS PRODUCT POSITIVE ?
	BCC	XOPMULP	B/ YES
	NEGD		TAKE -ABS(PRODUCT)
	BMI	TSXSUB3	AND STORE AS RESULT
	BEQD	TSXSUB3	ZERO IS OK AS RESULT, TOO!
	BRA	OVERFLOW

XOPMULP	TSTA		IS PRODUCT TOO BIG TO BE POSITIVE INTEGER ?
	BPL	TSXSUB3	B/ PRODUCT IS OK
	BRA	OVERFLOW	PRODUCT CANNOT BE STORED AS 16 BIT SIGNED INTEGER
	PAGE
*	ABS FUNCTION
*
XOPABS	LDA	R1INT1,S
	BPL	ABS1	B/ NUMBER IS ALREADY POSITIVE
	IF	M6800!M6801
	LDB	R1INT2,X
	NEGD
	BMI	OVERFLOW
	STD	R1INT1,X	STORE ANSWER
	ELSE	(M6809)
	LDB	R1INT2,S
	NEGD
	BMI	OVERFLOW
	STA	R1INT1,S
	FIN
ABS1	JMP	NTRPT2
	PAGE
*	SUB TOS FROM TOS-1
*
XOPSUB	; SUBTRACT TOS FROM TOS-1
	IF	M6800!M6801
	LDD	R2INT1,S	YES, GRAB LEFT HAND OPERAND
	SUBD	R1INT1,X
	ELSE	(M6809)
	LDD	R2INT1,S
	SUBD	R1INT1,S
	FIN
	BVS	OVERFLOW
	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
*
*	ADD TOS TO TOS-1
*
XOPADD	; ADD TOS TO TOS-1
	IF	M6800!M6801
	LDD	R2INT1,S	YES, GRAB LEFT HAND OPERAND
	ADDD	R1INT1,X
	ELSE	(M6809)
	LDD	R2INT1,S
	ADDD	R1INT1,S
	FIN
	BVC	SUB3
OVERFLOW	JSR	RTPERR
	FCB	:FLTOVF
	PAGE
*	AND TOS TO TOS-1, NO FLOATING ARGUMENTS ALLOWED
*
XOPAND	; AND TOS TO TOS-1
	IF	M6800!M6801
	TSX
	LDD	R2INT1,X	FETCH LEFT OPERAND
	ANDA	R1INT1,X
	ANDB	R1INT2,X
	ELSE	M6809
	LDD	R2INT1,S
	ANDA	R1INT1,S
	ANDB	R1INT2,S
	FIN
	JMP	SUB3
*
*	IOR TOS TO TOS-1, NO FLOATING ARGUMENTS ALLOWED
*
XOPIOR	; IOR TOS TO TOS-1
	IF	M6800!M6801
	TSX
	LDD	R2INT1,X	YES, GRAB LEFT HAND OPERAND
	ORAA	R1INT1,X
	ORAB	R1INT2,X
	ELSE	(M6809)
	LDD	R2INT1,S
	ORA	R1INT1,S
	ORB	R1INT2,S
	FIN
	JMP	SUB3
*
*	XOR TOS TO TOS-1, NO FLOATING ARGUMENTS ALLOWED
*
XOPXOR	; XOR TOS TO TOS-1
	IF	M6800!M6801
	TSX
	LDD	R2INT1,X	YES, GRAB LEFT HAND OPERAND
	EORA	R1INT1,X
	EORB	R1INT2,X
	ELSE	(M6809)
	LDD	R2INT1,S
	EORA	R1INT1,S
	EORB	R1INT2,S
	FIN
	JMP	SUB3
	PAGE
*	COM - COMPLEMENT INTEGER ON TOS
*
XOPCOM	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	; SHIFT TOS-1 BY TOS
	PULD
	TSTA
	BMI	SHIFTRIGHT	B/ SHIFT COUNT NEGATIVE, MUST SHIFT RIGHT!
	BNE	SHZERO	> 256 TO LEFT
SHIFTLEFT	LDA	R1INT1,S	GET UPPER BYTE OF VALUE TO SHIFT
	TSTB		SHIFT ZERO ?
	BEQ	SHIFTDONE	B/ YES, ALL DONE!
SHIFTLEFTLOOP
	IF	M6800!M6801
	ASL	R1INT2,X
	ELSE	(M6809)
	ASL	R1INT2,S
	FIN
	ROLA
	DECB
	BNE	SHIFTLEFTLOOP
	BRA	SHIFTDONE

SHIFTRIGHT
	INCA		SHIFT MORE THAN 256 LEFT ?
	BNE	SHZERO	B/ YES, RESULT IS ZERO
	LDA	R1INT1,S
SHIFTRIGHTLOOP	LSRA
	IF	M6800!M6801
	ROR	R1INT2,X
	ELSE	(M6809)
	ROR	R1INT2,S
	FIN
	INCB
	BNE	SHIFTRIGHTLOOP
SHIFTDONE
	IF	M6800!M6801
	STAA	R1INT1,X
	ELSE	(M6809)
	STAA	R1INT1,S
	FIN
SHIFTX	JMP	NTRPT1

SHZERO	CLR	R1INT1,S	RESULT IS 0
	IF	M6800!M6801
	CLR	R1INT2,X
	ELSE	(M6809)
	CLR	R1INT2,S
	FIN
	BRA	SHIFTX
*
*	NEGATE TOS
*
XOPNEG	LDD	R1INT1,S
	NEGD
	BVS	OVERFLOW
	IF	M6800!M6801
	STD	R1INT1,X
	ELSE	(M6809)
	STD	R1INT1,S
	FIN
	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	LDAA	#$FF	ASSERT: FLAG HAS VALUE 0 OR $FF!
	STAA	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
*	INTEGER COMPARE
ACMP	; INTEGER COMPARE
	IF	M6800!M6801
	TSX
	LDAA	R2INT1+2,X
	CMPA	R1INT1+2,X
	BNE	ACMPCC
	LDAA	R2INT2+2,X
	SUBA	R1INT2+2,X
ACMPCC	TPA
ACMP4	LDX	0,X	FETCH RETURN ADDRESS
	STS	TEMPX	POP 2 ENTRIES OFF THE STACK
	LDAB	#RSESIZ*2+2
	ADDB	TEMPX+1
	STAB	TEMPX+1
	BCC	ACMP5
	INC	TEMPX
ACMP5	LDS	TEMPX
	TAP
	ELSE	(M6809)
	LDX	0,S	GET RETURN
	LDD	R1INT1+2,S
	LEAS	RSESIZ*2+2-2,S	POP RETURN, 1 ENTRY AND 4 BYTES OF OTHER ENTRY
	CMPD	,S++	COMPARE TO INTEGER PART OF OTHER ENTRY AND POP
	FIN
	JMP	0,X
	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
*
SCMP	LDX	R1SDA+2,S	FIND LENGTH OF STRING ON TOS
	IF	M6800!M6801
	STX	S2ADD
	FIN
	LDB	CURLEN+1,X	GET ACTUAL STRING LENGTH
	LDX	R2SDA+2,S	GET S1 LENGTH
	LDA	CURLEN+1,X	GET CURRENT LENGTH
	STA	S1LEN	COMPARE FOR MIN( LEN(S1), LEN(S2) ) BYTES
	SBA		LENGTHS = ?
	BEQ	SCMP7
	RORA		MAKE -1 OR $7F
	ORAA	#$7F
	STAA	TBYTE
	BPL	SCMP3	B/ LEN(S1) >= LEN(S2), COMPARE FOR S2LEN BYTES
	LDB	S1LEN	LEN(S1) < LEN(S2), COMPARE FOR S1LEN BYTES
	BNE	SCMP6	B/ LEN(S1) > 0, MUST COMPARE PREFIXES OF STRINGS
	BRA	SCMPEQ	B/ LEN(S1) = 0 --> S1 < S2

SCMP7	CLR	TBYTE	IN CASE STRING BODIES ARE EQUAL
SCMP3	TSTB		CHECK LENGTH OF S2 FOR ZERO...
	BEQ	SCMPEQ	B/ LEN(S2) = 0 --> S1 >= S2
	IF	M6800!M6801
	BRA	SCMP6

SCMP4	LDX	S1ADD	COMPARE S1 TO S2
SCMP6	LDAA	STRING,X
	INX
	STX	S1ADD
	LDX	S2ADD
	CMPA	STRING,X
	BNE	SCMP2	STATUS IS SET PROPERLY
	INX
	STX	S2ADD
	DECB		DEC LSBYTE OF LOOP COUNT
	BNE	SCMP4
SCMPEQ	LDA	TBYTE	SET CC TO RESULT OF COMPARISON
SCMP2	TPA		STRING PREFIXES ARE IDENTICAL
	TSX
	BRA	ACMP4
	ELSE	(M6809)
SCMP6	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
SCMP6L	LDA	,X+	HIGH SPEED LOOP TO FIND STRING DIFFERENCE
	CMPA	,Y+
	BNE	SCMPNE	B/ STRINGS ARE DIFFERENT
	DECB		DOWN COUNT REMAINING STRING TO COMPARE
	BNE	SCMP6L	B/ WHIZZZZ
SCMPEQ	LDX	0,S	STRING PREFIXES ARE EQUAL
	LEAS	RSESIZ*2+2,S	POP STRING DESCRIPTORS FROM STACK
	LDAA	TBYTE	= WHICH STRING IS BIGGER
	JMP	0,X

SCMPNE	RORA		PUT BORROW BIT IN SIGN
SCMPNE1	LDX	0,S	GRAB RETURN ADDRESS
	LEAS	RSESIZ*2+2,S
	ORAA	#1
	JMP	0,X
	FIN
	PAGE	*****  S T R I N G S  *****
*	OPVAL
*	SD ON TOS REPLACED BY NUMERIC VALUE
*
XOPVAL	PULX
	LDB	CURLEN+1,X	GET LENGTH OF STRING TO CONVERT
	CLRA		EXTEND TO 16 BITS
	LEAX	STRING,X	MAKE POINTER 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
*
*	PUSH STRING CONSTANT DESCRIPTOR
*	OPLSC, COUNT, STRING
*	COUNT < 255
*
XOPLSC	; LOAD STRING CONSTANT
	LDD	BPC	= POINTER TO NON-EXISTANT STRING HEAD
	SUBD	#STRING-1
	PSHD
	LDX	BPC
	LDAB	ILSDC,X	GET STRING LENGTH
	INCB		ASSERT: LENGTH BYTE < 255
	JMP	NTRADB
	PAGE
*	INPUT STRING TAKES & PUSHES A SD
*	FOR THE STUFF REMAINING IN THE CATBUF
*	INPTR POINTS TO BYTE IN CATBUF
*
XOPINS	LDD	INPTR	CALCULATE CURRENT COUNT
	SUBD	#STRING	CONVERT INTO STANDARD STRING DESCRIPTOR
	PSHD
	LDD	INPUTEND	COMPUTE SIZE OF REMAINING CATBUF
	SUBD	INPTR
	LDX	0,S	AND STORE AS STRING LENGTH
	STB	CURLEN+1,X
	JMP	NTRPT1
*
*	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
	LDD	ILADD,X
	PSHD
	JMP	NTRPT3X
	PAGE
*	LENGTH, TOS GETS CURENT LENGTH OF STRING ON TOS
*
XOPLEN ; PUSH ACTUAL LENGTH OF STRING ON TOS
*
*	MAXLEN, TOS GETS MAX LENGTH OF STRING ON TOS
*
XOPMAXLEN	EQU	*
	LDX	R1SDA,S
	LDB	MAXLEN+1,X
	CLRA
	STD	R1INT1,S
	JMP	NTRPT1
	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

	IF	M6800!M6801
XOPFIND	PULX		FETCH STRING DESCRIPTOR OF STRING TO BE FOUND
	STX	S2ADD	SAVE POINTER TO STRING BODY
	LDB	CURLEN+1,X	GET STRING LENGTH OF STRING TO FIND
	BEQ	OPFINDNULL
	LDX	R1SDA,S	FETCH STRING DESCRIPTOR OF STRING TO SEARCH
	LDA	CURLEN+1,X	GET LENGTH OF STRING TO SEARCH
	STA	S1LEN	= LENGTH OF STRING TO BE SEARCHED
	SBA		FIND LEN(S1) - LEN(S2) + 1 (= # PLACES TO LOOK)
	BCS	OPFINDCANT	CAN'T COMPARE, LEN(S2) > LEN(S1)
	INCA
	TAB		NEED COUNT IN (B), BELOW
	STX	S1ADD	STRING TO BE SEARCHED
	LDX	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
OPFINDCANT	LDD	#0	"NOT FOUND"
	BRA	OPFINDXIT

OPFINDNOTHERE	PULB		RESTORE # PLACES LEFT TO LOOK, +1
	LDX	S2ADD	GET 1ST BYTE TO SEARCH FOR, AGAIN
	LDA	STRING,X
	LDX	S1ADD
	BRA	OPFINDNEXT

OPFINDREST	PSHB		SAVE # PLACES LEFT TO LOOK, +1
	STX	S1ADD	SAVE LOCATION OF 1ST BYTE OF STRING
	STX	S1ADDT	SET UP TO SCAN REST OF STRING TO FIND
	LDX	S2ADD
	STX	S2ADDT
	LDB	CURLEN+1,X	GET LENGTH OF STRING TO FIND
OPFINDRESTL	LDX	S1ADDT	COMPARE BYTES OF STRINGS
	LDAA	STRING,X
	INX
	STX	S1ADDT
	LDX	S2ADDT
	CMPA	STRING,X
	BNE	OPFINDNOTHERE
	INX
	STX	S2ADDT
	DECB
	BNE	OPFINDRESTL
	INS		DON'T NEED SAVED # PLACES LEFT TO LOOK
	LDD	S1ADD	= "WE FOUND IT"
	SUBD	R1SDA,S
	ADDD	#1	= STRING SUBSCRIPT OF TARGET
OPFINDXIT	STD	R1INT1,S	SAVE STRING INDEX
	JMP	NTRPT1
	PAGE
	ELSE	(M6809)
XOPFIND	PULX		FETCH STRING DESCRIPTOR OF STRING TO BE FOUND
	STX	S2ADD	SAVE POINTER TO STRING BODY
	LDB	CURLEN+1,X	GET STRING LENGTH OF STRING TO FIND
	BEQ	OPFINDNULL
	LDX	R1SDA,S	FETCH STRING DESCRIPTOR OF STRING TO SEARCH
	LDA	CURLEN+1,X	GET LENGTH OF STRING TO SEARCH
	STA	S1LEN	= LENGTH OF STRING TO BE SEARCHED
	SBA		FIND LEN(S1) - LEN(S2) + 1
	BCS	OPFINDCANT	CAN'T COMPARE, LEN(S2) > LEN(S1)
	INCA
	TAB		NEED COUNT IN (B), BELOW
	LEAX	STRING,X
	STX	S1ADD	STRING TO BE SEARCHED
	LDX	R1SDA,S
	LEAX	STRING,X
	STX	S2ADD	STRING TO SEARCH FOR
	LDA	0,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
OPFINDCANT	LDD	#0	"NOT FOUND"
	BRA	OPFINDXIT

OPFINDNOTHERE	PULB		RESTORE # PLACES TO LOOK, +1
	LDA	[S2ADD]	FIRE UP FAST SEARCH AGAIN
	LDX	S1ADD
	BRA	OPFINDNEXT

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

OPFINDRESTL	LDA	,X+	COMPARE TARGET STRING TO THIS PLACE
OPFINDRESTL1	CMPA	,Y+
	BNE	OPFINDNOTHERE	B/ NO MATCH HERE
	LEAU	-1,U
	BNE	OPFINDRESTL
	INS		THROW AWAY # PLACES LEFT TO LOOK
	LDD	S1ADD	COMPUTE STRING INDEX OF TARGET
	SUBD	R1SDA,S
	SUBD	#STRING-1	CONVERT TO ORIGIN 1
OPFINDXIT	STD	R1INT1,S	SAVE STRING INDEX
	JMP	NTRPT1
	FIN
	PAGE	*****  S T R I N G   S U B C R I P T I N G  *****
*
*	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
	IF	M6809
	TSTA
	FIN
	BNE	SSB13
	LDX	R1SDA,S	GET MAXIMUM LENGTH OF STRING
	CMPB	MAXLEN+1,X
	BCC	SSB13	B/ >= NOT ALLOWED, WE ALREADY SUBTRACTED 1!
	ADDD	R1SDA,S
	IF	M6800!M6801
	STD	R1SDA,X
	ELSE	(M6809)
	STD	R1SDA,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	PULX		= RETURN ADDRESS
	PULD		= VALUE
	TSTA		IS IT POSITIVE ?
	BMI	RNDERR	B/ NEGATIVE
	JMP	2,X	ALL IS OK

RNDERR	JMP	[0,X]	TAKE ERROR EXIT
*	QUICK MULTIPLY (UNSIGNED)
*	A,B CONTAIN MULTIPLICAND
*	X CONTAINS MULTIPLIER, SMALLER PREFERRED
*	A,B WILL CONTAIN RESULT
*	SKIP RETURN IF OVERFLOW
*
MLTPLY	STX	MULTIPLIER	SAVE MULTIPLIER
	BEQ	MLTPLY0	B/ MULTIPLIER IS 0 --> PRODUCT IS ZERO
	STAB	MULTIPLICAND+1	SAVE LOWER 8 BITS OF MULTIPLICAND
	STAA	MULTIPLICAND
	BEQ	MLTPLYA	B/ UPPER 8 BITS OF MULTIPLICAND IS ZERO!
	LDAB	MULTIPLIER	MAKE SURE UPPER 8 BITS MULTIPLIER=0
	BNE	MOVF	B/ PRODUCT WOULD BE >= 2^16
	LDAB	MULTIPLIER+1	MULTIPLIER+1 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!
	STAB	MULTIPLICAND	SAVE UPPER 8 BITS
MLTPLYL	LDAA	MULTIPLICAND+1	MULTIPLICAND <> 0, DON'T BOTHER CHECKING MULTIPLICAND+1
	LDAB	MULTIPLIER+1	MULTIPLIER+1 <> 0!
	IF	M6800
	BSR	MUL6809
	ELSE	M6801!M6809
	MUL
	FIN
	ADDA	MULTIPLICAND	ADD PARTIAL PRODUCT FROM OTHER CROSS PRODUCT
	BCS	MOVF	B/ SUM >= 2^16
	RTS		PRODUCT IS OK

MLTPLYA	TSTB		MULTIPLICAND=0, CHECK MULTIPLICAND+1
	BEQ	MLTPLY0RTS	B/ PRODUCT IS ZERO
	LDAA	MULTIPLIER
	BEQ	MLTPLYL	MULTIPLICAND,MULTIPLIER = 0
	JMP	MLTPLYU	MULTIPLIER, MULTIPLICAND+1 <>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	*
	STAA	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	***** ARRAY SUBSCRIPTING *****
*	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	0,X	CHECK FOR SUBSCRIPT OUT OF BOUNDS
	BHI	DOSSE	B/ SUBSCRIPT TOO LARGE
	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
	PSHD
	JMP	NTRPT3
*
*	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

DOSSE	JSR	RTPERR
	FCB	:ARYRNG
	PAGE
*	DO VECTOR SUBSCRIPT AND STORE VALUE
*		TOS CONTAINS VALUE TO STORE
*		NEXT-TO-TOS CONTAINS INDEX
*		INSTRUCTION CONTAINS POINTER TO VECTOR
*
XOPVSS	EQU	*
	LDD	R2INT1,S
	IF	M6809
	TSTA
	FIN
	BMI	DOSSE	B/ NEGATIVE SUBSCRIPT ILLEGAL
	LDX	BPC
	LDX	ILADD,X
	BSR	DOSINGLESUBSCRIPT
	PULD
	STD	VINT1,X
	JMP	PL1PC3

	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	VINT1,X
	BSR	DOSINGLESUBSCRIPT
	PSHD
	JMP	NTRPT3
*
*	LEN(vector) or LEN(stringarray)
*		TOS CONTAINS VECTOR/STRINGARRAY ADDRESS
*
XOPLENVECTOR	EQU	*
	LDD	[R1ADD,S]	FETCH # VECTOR SLOTS (= DIM'D VALUE)
	STD	R1INT1,S	REPLACE ADDRESS ON TOS BY INTEGER VALUE
	JMP	NTRPT2
	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"
	PULD
	STD	VINT1,X
	JMP	NTRPT3
*
*	STORE TOS USING TOS-1; USED TO STORE INTO PARAMETER VARIABLES
*
XOPST	PULD		GET VALUE TO STORE
	PULX		AND WHERE TO STORE IT
	STD	VINT1,X
	JMP	NTRPT1	GO DO NEXT OPCODE
*
	PAGE
*	STORE BYTE: ADDRESS ON TOS-1, VALUE ON TOS
*
XOPSTB	JSR	RNDTOS	FORCE TO POSITIVE INTEGER VALUE
	FDB	STORB3	B/ NOT POSITIVE!
	TSTA		>= 256 ?
	BEQ	STORB2	B/ NO
STORB3	JSR	RTPERR	NUMBER IS TOO BIG TO STORE INTO A BYTE
	FCB	:STORBE

STORB2	PULX		FETCH TARGET ADDRESS
	STB	STRING,X
	JMP	NTRPT1
*
*	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
	STAB	OUTBUF+1
	LDAA	#1	= STRING LENGTH
	JMP	NUM2
	PAGE
	PAGE	*****  C O N T R O L  *****
SYSCALLONUSERCHAN	; PERFORM SYSCALL USING USER CHANNEL
	LDAA	CHANEL
SYSCALLONCHANNELA	STAA	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'
	LDAB	SCBLK+SCBLK:PARAMS	CHANNEL #=>0
	BSR	EOFBGEN	MAKE ME AN EOF BIT AND X-REG
	COMA		MAKE A MASK
	ANDA	0,X	RESET 'EOF HIT' BIT
	STAA	0,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	LDAA	SCBLK+SCBLK:PARAMS	IS IT WITHIN THE PROPER RANGE?
	INC	EOFHITFLAG
	BSR	EOFBGEN
	ORAB	0,X
	STAB	0,X
	CLC		WHAT ERROR?  DID YOU SEE AN ERROR?  I DIDN'T!
	RTS

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

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

	LDAB	SCBLK+SCBLK:PARAMS
	LSRB
	LSRB
	LSRB
	IF	M6800!M6801
	ADDB	#EOFTABLE&$FF
	STAB	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	LDAA	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	LDAA	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
	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
	PAGE
*	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	LDAB	#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
	PULD		CALL THE FUNCTION
	STD	FNRESULT	SAVE THE RESULT
	LDX	BPC	NOW POP ARG LIST FROM STACK
	LDB	2,X
	IF	M6800!M6801	ADD #ARGS*6 TO STACK
	ASLB
	STS	TEMPX
	ADDB	TEMPX+1
	BCC	XOPFNCALL1
	INC	TEMPX
XOPFNCALL1	EQU	*
	STAB	TEMPX+1
	LDS	TEMPX
	ELSE	(M6809)
	ASLB
	LEAS	B,S	ASSERT: ARG COUNT < 128/3
	FIN
	LDD	FNRESULT	GET RETURNED VALUE BACK
	PSHD
	BRA	XOPCALL1
	PAGE
CALLIT	; SUBROUTINE FOR XOPCALL, XOPFNCALL
	IF	M6800!M6801
	LDX	BPC
	FIN
	LDD	ILADD,X	GET SUBROUTINE ADDRESS
	PSHD		PUSH ONTO STACK
	LDAA	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	0,S	= RETURN ADDRESS FROM JSR
	LDAB	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
	STAB	VINT1,X
	PULB
	STAB	VINT1+1,X
	LEAX	-(VINT1+2),X
	DECA
	BNE	SUBFUNL	B/ MORE TO FILL!
	ELSE	(M6800!M6801)
	STAA	TBYTE
SUBFUNL	; PARAMETER FILL LOOP
	PULD
	STD	VINT1,X
	LEAX	-(VINT1+2),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
	LDAA	0,X
	ELSE	(M6809)
	LDAA	,-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
	JMP	NTRPT1	GO DO NEXT OPCODE
	PAGE
*	FUNRETURN -- RETURN FROM A FUNCTION
*
XOPFUNRET	EQU	*
	PULD
	STD	FNRESULT	SAVE FUNCTION RESULT
*
*	SUBRETURN -- RETURN FROM A SUBROUTINE
*
XOPSUBRET	EQU	*
	LDX	BPC	GRAB OPCODE BYTE
	IF	M6800!M6801
	DEX
	LDB	0,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
	LDD	FNRESULT	NO, MUST BE RETURNING FROM PARAMETERIZED FUNCTION
	PSHD		MOVE RESULT VALUE 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	0,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
	LDB	#4	= AMOUNT TO ADVANCE BPC
	JMP	NTRADB
*
*	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
	JMP	NTRPT1
	PAGE
*	SET LINE NUMBER
*	PICK UP 2 BYTES & PUT IN THE LINE # REG
*	OPLINE,16BITLINENUMBER
*
XOPLINE	; SET LINE NUMBER OPCODE
	IF	M6800!M6801
	LDX	BPC	BUMP BPC SO NTRPT1 IS CORRECT EXIT
	FIN
	DEX		SET LINEADDR = ADDRESS OF LINE # OPCODE
	STX	LINEADDR
	JMP	NTRPT3

ILLEGALOPCODE ; ILLEGAL OPCODE ENCOUNTERED
	BSR	RTPERR
	FCB	:ILLEGALOP

XOPABORT	BSR	RTPERR
	FCB	:ABORT

XOPSTP	BSR	RTPERR
	FCB	:STOP

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

XOPERRCAUSE1	JSR	RTPERR
	FCB	:FLTNXP
	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	LDX	0,S	FETCH INLINE ERROR CODE
	LDAB	0,X
	CLRA
IOERROR	STD	ERCODE	SAVE ERROR CODE
ERRORLDS	LDS	ERRORRECOVERYSTACK	GET US A CLEAN STACK TO WORK WITH...
ERROR	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	FATALERROR	B/ YES, ABORT HIM
	LDX	ERCODE	IS THIS A "STOP" STATEMENT ?
	BEQ	FATALERROR	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	FATALERROR	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
	BRA	ERRORLDS	GO CHECK FOR ERROR RECOVERY

FATALERROR ; SIGNAL ERROR TO HIGHER AUTHORITY!
	LDX	ERADDR	GET ERROR ADDRESS
	LDB	0,X	A SET LINE NUMBER OPCODE ?
	CMPB	#OPLINE	... ?
	BNE	FATALERROR1	B/ NO
	LDX	ILINT,X	YES, GET THE LINE NUMBER
FATALERROR1
	LDD	FATALTRAPVECTOR	SET UP TO EXIT TO FATAL TRAP ROUTINE
	PSHD
	LDD	ERCODE	FETCH THE ERROR CODE TO (D)
	RTS		LET HIGHER AUTHORITY KNOW WHAT HAPPENED!
	PAGE
	PAGE	*****  P E E K - P O K E *****
*	PEEK AT ADDRESS SPECIFIED BY TOS INTEGER
*
XOPEEK	LDX	R1ADD,S
	LDAB	BYTE,X
	JMP	LOADB1
*
*	POKE ADDRESS AT TOS-1, BYTE AT TOS
*	NO POKING AT THE INTERPRETER, PLEEZE
*
XOPOKE ; "POKE" OPCODE
	IF	CODE=$100
	LDD	#BASICRTPEND$
	SUBD	R2ADDH,S
	BCC	POKE4
	FIN
	LDAA	R1INT1,X
	BNE	POKE5
	LDAA	R1INT2,X
	LDX	R2ADD,X
	STAA	BYTE,X
	JMP	PL2PC1

	IF	CODE=$100
POKE4	JSR	RTPERR
	FCB	:POKRTP	OUCH! THAT HURT!
	FIN

POKE5	JSR	RTPERR
	FCB	:POKVAL
	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 "OPFOR" OPCODE
	STX	BPC
	LDX	ILADD+5,X	POINTER TO PLACE FOR STEP
	PULD
	STD	VINT1,X	STORE STEP VALUE
	PULD
	STD	VINT1+6,X	STORE LIMIT VALUE
	LDX	BPC	STORE INITIAL VALUE
	LDX	ILADD+3,X	GET LOOP INDEX ADDRESS
	PULD
	STD	VINT1,X	STORE INITIAL VALUE OF LOOP INDEX VARIABLE
	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
	TST	VINT1,X	IS LOOP STEP POSITIVE ?
	BPL	NEXTICHECK	B/ YES, CHECK LOOP LIMIT
	BRA	NEXTMSTEP	B/ NO, GO CHECK LOOP LIMIT
	PAGE
*	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!
*	BUT IT CAN BE OPTIMIZED SOME MORE FOR '09!
*
XOPNEXT	EQU	*
	IF	M6800!M6801
	LDX	BPC
	FIN
	LDX	ILADD,X	FIND "OPFOR" OPCODE ADDRESS
	STX	BPC	AND REMEMBER WHERE IT IS
	LDX	ILADD+5,X	GRAB POINTER TO STEP VALUE
	LDD	VINT1,X	MOVE INTEGER STEP TO (A,B)
	BMI	NEXTMSTEP	B/ STEP IS NEGATIVE!
NEXTICHECK	LDX	VINT1+6,X	GRAB LOOP LIMIT
	STX	TEMPX	SAVE IT A MOMENT
	LDX	BPC	NOW ADD LOOP INDEX VALUE...
	LDX	ILADD+3,X	TO STEP VALUE
	ADDD	VINT1,X	(A,B):= NEXT INDEX VARIABLE VALUE
	BVS	NEXTIOV	B/ NEW INDEX VALUE OUT OF RANGE, RATS!
	STD	VINT1,X	SAVE UPDATED LOOP INDEX VALUE
	SEC		CHECK: LOOP INDEX VALUE <= LIMIT ?
	SBCB	TEMPX+1
	SBCA	TEMPX
	BGE	NEXTEXIT	B/ NOPE, TIME TO LEAVE THE LOOP!
NEXTITERATION	EQU	*
	LDAB	#7	DO NEXT ITERATION OF LOOP, 7 IS LENGTH OF "OPFOR" OPCODE
	JMP	NTRADB	START EXECUTION FOLLOWING OPFOR OPCODE AGAIN
	PAGE
NEXTMSTEP	; STEP IS NEGATIVE
	LDX	VINT1+6,X	GRAB LOOP LIMIT
	STX	TEMPX	AND SAVE
	LDX	BPC	NOW ADD STEP TO LOOP INDEX VALUE...
	LDX	ILADD+3,X
	ADDD	VINT1,X
	BVS	NEXTIOV	B/ OVERFLOW!
	STD	VINT1,X
	SUBD	TEMPX	CHECK: LOOP INDEX VALUE >= LIMIT ?
	BGE	NEXTITERATION	B/ YES, CONTINUE LOOP EXECUTION
NEXTEXIT	EQU	*
	LDX	BPC	NOW FALL OUT OF THE LOOP...
NEXT1A	LDX	ILADD+1,X	AND START EXECUTION BEYOND "NEXT" OPCODE
	JMP	NTRPTX

NEXTIOV	JMP	OVERFLOW
	PAGE	*****  I N P U T  *****
*
*	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	0,S
	LDD	0,X
	PSHD
	LDD	2,X
	LDX	TEMPX
	STD	2,X
	PULD
	STD	0,X
	PULX
	JMP	4,X
	PAGE
*	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
*	INPUTEND TO LAST BYTE OF INPUT LINE, +1
*
XOPINL	; INPUT LINE OF TEXT FOR PROCESSING BY REST OF INPUT STATEMENT
	LDX	BPC
	STX	ILERR	SAVE RECOVERY POINT (+1) IN CASE OF ERROR IN INPUT
	JSR	SETSCOP
	FCB	SYSCALL:READA
	FCB	READA:SCLEN
	FCB	CHANGED,1	**** READ IT IN "LINE MODE"

	LDX	CATBUF
	INX		MAKE ROOM FOR LENGTH BYTE
	STX	INPTR	NOTE: INPTR POINTS DIRECTLY TO 1ST DATA BYTE!
	STX	SCBLK+SCBLK:RDBUF

	LDX	CATSIZ	= CAT BUFFER SIZE
	DEX		TO LEAVE ROOM FOR LENGTH BYTE !
	STX	SCBLK+SCBLK:RDLEN

	JSR	SYSCALLONUSERCHAN

	LDAA	EOFHITFLAG	IF EOF HIT, SKIP INPUT STATEMENT
	BNE	XOPINL1

	LDD	SCBLK+SCBLK:RPLEN	GET SIZE OF REPLY, + 1
	ADDD	CATBUF	INPUT LINE ENDS WITH CR --> DROP THE CR
	TDX
	STX	INPUTEND	= INPUT LINE LIMIT
	LDA	0,X	FETCH LAST BYTE READ
	CMPA	#ASCII:CR	=CR?
	BNE	CATEN5J	B/ NO <CR> PRESENT ON END OF BUFFER
	JMP	NTRPT3	GO DO NEXT OPCODE

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	INPUTEND	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!
	LDAA	CHANEL	INPUT CONVERSION ERROR (SYNTAX OR OVF)
	BEQ	INPUT2
INPUT1	JSR	RTPERR
	FCB	:CONVER

INPUT2	LDX	#INPUT2A	= BASIC POPCODES TO EXECUTE
	JMP	NTRPTX

INPUT2A	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
	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	LOOPX	
	STX	BUFERP	COMPUTE POINTER PAST STRING
	ADDD	BUFERP
	STD	CONVERTLIMIT
	PULD
	STD	RTPRET
	CLRA		ZERO OUT THE RESULT
	STA	FNRESULT
	STA	FNRESULT+1
	STA	SIGN
CONVER1	BSR	GETCHAR
	CMPA	#ASCII:SPACE
	BEQ	CONVER1	IGNORE LEADING BLANKS
	CMPA	#ASCII:HT
	BEQ	CONVER1
	CMPA	#':
	BNE	CONVERD	MUST BE DECIMAL NUMBER
CONVER2	BSR	GETCHAR
	BSR	ISDIGIT	DIGIT ?
	BCC	CONVER4	B/ YEP
	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	LDAB	#1	I SAW A DIGIT
	STAB	SIGN
	ASLA
	ASLA
	ASLA
	ASLA
	LDAB	#4
CONVER5	ASLA
	ROL	FNRESULT+1
	ROL	FNRESULT
	BCS	CONVER11	OVERFLOW
	DECB
	BNE	CONVER5
	BRA	CONVER2
CONVER6	LDAB	SIGN
	BEQ	CONVER11	NO DIGITS, INPUT ERROR
	LDD	FNRESULT
CONVER10	PSHD		PUSH RESULT
	LDX	BUFERP
	DEX		BECAUSE OF GETCHAR
	CPX	CONVERTLIMIT
	BEQ	CONVER9	B/ YES, JUST LEAVE
	LDAA	0,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
	RTS

CONVER11	LDX	RTPRET	SYNTAX OR OVERFLOW ERROR
	JMP	2,X

ISDIGIT ; CHECK (A) FOR DECIMAL DIGIT, CONVERT TO BINARY IF FOUND
	CMPA	#'0	DIGIT?
	BCS	ISDIGITRTS	NOT A DIGIT
	CMPA	#'9
	BHI	ISDIGITNO
	SUBA	#'0
	RTS

ISDIGITNO	SEC
ISDIGITRTS	RTS
*
*	GETCHAR -- GET CHARACTER USING BUFERP, ADVANCE BUFERP
*	RETURNS 0 IF NO INPUT BYTES LEFT
*
GETCHAR	LDX	BUFERP	GET NEXT BYTE FROM INPUT STREAM
	LDA	,X+
	STX	BUFERP	(WILL ONLY READ 1 PAST END, MAX)
	LDX	LOOPX	CHECK MAX # OF CHARS READ
	BEQ	GETCHAR0	B/ NO INPUT BYTES LEFT!
	DEX
	STX	LOOPX
	RTS

GETCHAR0	CLRA		RETURN "0" AS END OF STRING CHARACTER
	RTS

CONVERD ; NOT HEX NUMBER, MUST BE DECIMAL NUMBER
	CMPA	#'-	MINUS SIGN GIVEN ?
	BNE	CONVERD1	B/ NO
	INC	SIGN	YES, REMEMBER THE SIGN
	BSR	GETCHAR	GET NEXT INPUT STREAM CHARACTER
CONVERD1
	BSR	ISDIGIT	A DIGIT GIVEN ?
	BCS	CONVER11	B/ NO DIGITS !
CONVERD2
	STA	TEMPB	SAVE THE BINARY VALUE OF THE DIGIT
	LDD	FNRESULT	MULTIPLY OLD NUMBER BY 10...
	ASLD		*2
	BCS	CONVER11	B/ NUMBER TOO BIG!
	ASLD		*4
	BCS	CONVER11	B/ NUMBER TOO BIG!
	ADDD	FNRESULT	*5
	BCS	CONVER11
	ASLD
	BCS	CONVER11	B/ NUMBER TOO BIG!
	ADDB	TEMPB		ADD IN THE NEW DIGIT
	ADCA	#0
	BCS	CONVER11	B/ NUMBER TOO BIG!
	STD	FNRESULT	SAVE THE COLLECTED RESULT
	BSR	GETCHAR	GET NEXT INPUT STREAM CHARACTER
	BSR	ISDIGIT	ANOTHER DIGIT GIVEN ?
	BCC	CONVERD2	B/ YES, GO PROCESS
	LDD	FNRESULT	NO, GRAB THE RESULT
	BEQD	CONVER10J	B/ RESULT ZERO, IGNORE SIGN!
	TST	SIGN	RESULT SPOS'D TO BE POSITIVE ?
	BEQ	CONVERDP	B/ YES
	NEGD		NO, TAKE -ABS(VALUE) TO GET RESULT
	BPL	CONVER11	RESULT IS TOO BIG!
CONVER10J	JMP	CONVER10	B/ RESULT IS OK, GO STORE IT

CONVERDP ; POSITIVE INPUT GIVEN
	TSTA		NUMBER TOO BIG ?
	BMI	CONVER11	B/ YES!
	BRA	CONVER10J	B/ NO

	PAGE	*****  P R I N T  *****
*
*	WASCII-FOR THOSE WHO CAN AFFORD THE VERY WORST
*
WASCII	STAA	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	LDAA	#'?
	CLRB
	BSR	WASCII
	BRA	XOPPSP	NOW OUTPUT A SPACE (WE KNOW CHANNEL # IS ZERO)
	PAGE
*
*	PRINT CR
*	DUMP OUT REST OF USING STRING IF <> 0
*	FOLLOW BY CR
*
XOPPCR	LDAA	#CR
	BRA	XOPPSP1
*
*	PUT A SPACE TO THE OUTPUT
*
XOPPSP	LDAA	#BLANK
XOPPSP1	LDAB	CHANEL
	BSR	WASCII
	JMP	NTRPT1
	PAGE
*
*	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

SYSCALLGETWRBUF	EQU	*
	BSR	SYSCALLGETSTRING
SYSCALGETWRBUF1	EQU	*
	STD	SYSCALLWRLEN
	STX	SYSCALLWRBUF
	RTS

SYSCALLGETSTRING	EQU	*
	LDX	R1SDA,X	SO WE CAN FIND NEXT ARG IN LIST, LATER
	LDB	CURLEN+1,X	GET STRING LENGTH
	CLRA		EXTEND TO 16 BITS
	LEAX	STRING,X	COMPUTE POINTER TO 1ST BYTE OF STRING
	RTS
	PAGE
*	PRINT VALUE ON TOS
*
XOPPV	PULD		= VALUE TO PRINT
	LDX	#OUTBUF	THIS IS WHERE TO PUT THE STUFF
	BSR	UFPRINT
	PSHA
	JSR	SETSCOP
	FCB	SYSCALL:WRITEA
	FCB	WRITEA:SCLEN
	FCB	CHANGED,IGNORED

	PULA
	STAA	SCBLK+SCBLK:WRLEN+1
	LDX	#OUTBUF
	STX	SCBLK+SCBLK:WRBUF
	JSR	SYSCALLONUSERCHAN
	JMP	NTRPT1
	PAGE
*	UNFORMATTED PRINT
*	SUBROUTINE FOR XOPPV, XOPNUM
*
UFPRINT ; UNFORMATTED PRINT
	STD	FNRESULT	SAVE VALUE TO BE PRINTED
	BMI	UFPRINTM	B/ NEGATIVE VALUE TO BE PRINTED
	LDA	#ASCII:SPACE	POSITIVE VALUE, GET SIGN CHARACTER
	BRA	UFPRINT1
UFPRINTM ; PRINT NEGATIVE VALUE
	NEGD
	STD	FNRESULT
	LDA	#'-	GET SIGN CHARACTER
UFPRINT1 ; PRINT SIGN CHARACTER
	STA	,X+	PLACE SIGN CHARACTER IN TARGET BUFFER
	STX	TWORD	SAVE TARGET BUFFER POINTER
	CLR	DIGITCOUNT	= # DIGITS GENERATED
UFPRINTL ; PRINT DIGIT LOOP
	LDD	FNRESULT	GET REST OF VALUE TO BE PRINTED
	LDX	#10	= DIVISOR
	JSR	DIVIDE	COMPUTE QUOTIENT AND REMAINDER
	STD	FNRESULT	SAVE QUOTIENT FOR NEXT ROUND
	BEQD	UFPRINTD	B/ QUOTIENT IS ZERO, LAST DIGIT IS COLLECTED!
	LDA	REMAINDER+1	GET REMAINDER DIGIT
	PSHA		SAVE ON STACK (6 MAX!)
	INC	DIGITCOUNT	= # DIGITS GENERATED
	BRA	UFPRINTL	B/ GO GENERATE ANOTHER DIGIT

UFPRINTD ; ALL DIGITS GENERATED
	LDX	TWORD	WHERE TO PUT THE DIGITS
	LDA	REMAINDER+1	= FIRST DIGIT
	LDB	DIGITCOUNT	= # DIGITS GENERATED, -1
	PSHA		SO WE CAN FALL INTO LOOP BELOW
UFPRINTDL ; MOVE DIGITS TO OUTPUT BUFFER
	PULA		GET NEXT DIGIT FROM STACK
	ADDA	#'0	CONVERT TO ASCII DIGIT
	STA	,X+	STORE INTO OUTPUT BUFFER
	DECB		= # DIGITS REMAINING IN STACK
	BPL	UFPRINTDL	B/ MORE DIGITS TO COPY FROM STACK
	LDA	DIGITCOUNT	= # DIGITS, NOT COUNTING FIRST
	ADDA	#2	ACCOUNT FOR 1ST DIGIT, AND SIGN CHARACTER
	RTS		ALL DONE!
	PAGE
*	CHANGE TOS VALUE TO HEX STRING
*
XOPHEX	LDAA	#':
	STAA	OUTBUF+1
	LDX	#OUTBUF+2
	PULA
	BSR	HEX1
	PULA
	BSR	HEX1
	LDAA	#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	PULD		= VALUE TO GENERATE STRING FOR
	LDX	#OUTBUF+1	GENERATE DIGIT STRING
	JSR	UFPRINT	DO UNFORMATTED MASSAGING
NUM2	STA	OUTBUF	SAVE STRING LENGTH
	LDD	#(OUTBUF+1-STRING)
	PSHD
	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
	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
	STAA	SCBLK+SCBLK:PARAMS
	JSR	ISYSCALL

	LDAB	CHAR
	RTS
	PAGE
*
*	SET CHANNEL NUMBER
*
XOPCHNL	PULD
	TSTA
	BNE	SETCHNERR
	CMPB	#32	MAX OF 32 I/O CHANNELS
	BHI	SETCHNERR	B/ I/O CHANNEL NUMBER TOO BIG!
	STAB	CHANEL
	JMP	NTRPT1

SETCHNERR	JSR	RTPERR
	FCB	:CHNLR
	PAGE
*
*	DO TAB TO NEXT PRINT COLUMN
*
XOPTABCOL	LDAB	CHANEL
	BSR	GETCOL
COLMN0	SUBB	#10	REDUCE COLUMN COUNT MODULO 10
	BCC	COLMN0
	NEGB		= # BLANKS TO OUTPUT (>=1)
COLMN1	STAB	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
	LDAB	TBYTE	ASSUME WRITE BUF LENGTH = COUNT
	STAB	SYSCALLWRLEN+1
	LDAB	#BLANKSTRINGEND-BLANKSTRING
	CMPB	TBYTE	IS ACTUAL STRING SIZE < COUNT ?
	BCC	COLMN4	B/ NO
	STAB	SYSCALLWRLEN+1	YES, USE LENGTH OF BLANK CONSTANT
COLMN4	LDX	#BLANKSTRING	SET UP WRITE BUFFER
	STX	SYSCALLWRBUF
	JSR	SYSCALLONUSERCHAN	AND DO THE SYSTEM CALL!
	LDAB	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	PULD
	TSTA
	BNE	TAB3
	PSHB
	LDAB	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	PULD
EOF2	TSTA
	BNE	SETCHNERR
*
*	GET EOF STATUS ON CHANNEL (B)
*
	CMPB	#32	I/O CHANNEL < 32 ?
	BCC	SETCHNERR
	STAB	SCBLK+SCBLK:PARAMS
	JSR	EOFBGEN
	BITA	0,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!6801
	LEAS	-(RSESIZ-1),S
	STS	SCBLK+SCBLK:RDBUF
	DES
	ELSE	(M6809)
	LEAS	-RSESIZ,S
	STS	SCBLK+SCBLK:RDBUF
	FIN
	LDAA	#RSESIZ
	STAA	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	OUTBUF	USED AS SCRATCH AREA
	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
*	POSITION A FILE TO A SPECIFIED RECORD
*
XOPRESTR ; POSITION FILE TO SPECIFIED LOCATION
	LDA	0,S	GET SIGN OF INTEGER
	ROLA		INTO CARRY BIT...
	LDD	#0	EXTEND SIGN
	SBCB	#0
	SBCA	#0
	PSHD		TO MAKE 32 BIT INTEGER
	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
*
XOPRS	JSR	SETSCOP
	FCB	SYSCALL:READB
	FCB	READB:SCLEN
	FCB	CHANGED,IGNORED
	PULX
	CLRA
	LDB	MAXLEN+1,X	SET CURLEN=MAXLEN
	STB	CURLEN+1,X
	LEAX	STRING,X	= TARGET OF READ
	STX	SYSCALLRDBUF
	STD	SCBLK+SCBLK:RDLEN	= HOW MANY TO READ
	JSR	SYSCALLONUSERCHAN
READS2	JMP	NTRPT1
	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
	PAGE
*	STORE STRING; STRINGS CANNOT OVERLAP!
*	S1 IS TARGET STRING (TOS - 1) S2 IS SOURCE STRING (TOS)
*
	IF	M6800!M6801
XOPSTS	PULX		= SOURCE STRING ADDRESS
	STX	S2ADD
	LDB	CURLEN+1,X	GET LENGTH OF SOURCE STRING
	PULX		= TARGET STRING ADDRESS
	LDA	MAXLEN+1,X	SET STRING SIZE TO DIM'D SIZE
	STA	CURLEN+1,X
	TBA		SAVE SOURCE LENGTH
	SUBA	CURLEN+1,X	COMPUTE MIN(SOURCE,TARGET) LENGTHS
	BLS	XOPSTS1	B/ SOURCE IS SHORTER THAN TARGET, (A) IS BLANK COUNT
	LDB	CURLEN+1,X	USE TARGET LENGTH TO LIMIT COPY
	CLRA		NO BYTES TO BLANK PAD
XOPSTS1	PSHA		SAVE BLANK PAD COUNT
	LEAX	STRING,X	COMPUTE POINTER TO 1ST TARGET BYTE
	STX	TEMPX	SAVE TARGET ADDRESS
	LDX	S2ADD	= SOURCE STRING ADDRESS
	BSR	BLOCKMOVEDOWNS
	PULB		= # BYTES TO BLANK PAD
	TSTB		PAD ZERO BYTES ?
	BEQ	XOPST1	B/ YES, JUST EXIT!
	LDA	#ASCII:SPACE	NOW DO THE BLANK PADDING
	LDX	TEMPX	= END OF COPY-TO STRING
XOPSTSBL	STA	,X+	STORE A BLANK
	INCB		DOWN COUNT BLANK PAD COUNT
	BNE	XOPSTSBL
XOPST1	JMP	NTRPT1	ALL DONE!
	ELSE	(M6809)
XOPSTS	PULX		= SOURCE STRING ADDRESS
	LDB	CURLEN+1,X	GET LENGTH OF SOURCE STRING
	PULS	Y		= TARGET STRING ADDRESS
	LDA	MAXLEN+1,Y	SET STRING SIZE TO DIM'D SIZE
	STA	CURLEN+1,Y
	TBA		SAVE SOURCE LENGTH
	SUBA	CURLEN+1,Y	COMPUTE MIN(SOURCE,TARGET) LENGTHS
	BLS	XOPSTS1	B/ SOURCE STRING IS SHORTER THAN TARGET, (A) = BLANK COUNT
	LDB	CURLEN+1,Y	USE TARGET LENGTH TO LIMIT COPY
	CLRA		= # BYTES TO BLANK PAD
XOPSTS1	PSHA		SAVE BLANK PAD COUNT
	LEAY	STRING,Y	COMPUTE POINTER TO 1ST TARGET BYTE
	BSR	BLOCKMOVEDOWNS
	PULB		= # BYTES TO BLANK PAD
	TSTB		PAD ZERO BYTES ?
	BEQ	XOPST1	B/ YES, JUST EXIT!
	LDA	#ASCII:SPACE	NOW DO THE BLANK PADDING
XOPSTSBL	STA	,Y+	STORE A BLANK
	INCB		DOWN COUNT BLANK PAD COUNT
	BNE	XOPSTSBL
XOPST1	JMP	NTRPT1	ALL DONE!
	FIN
	PAGE
	IF	M6800!M6801
BLOCKMOVEDOWNS	LEAX	STRING,X	MOVESTRING, COMPUTE POINTER TO 1ST BYTE
FROMPOINTER	EQU	2
TOPOINTER	EQU	0
BLOCKMOVEDOWNX	EQU	4	TEMPHOLDING AREA
LIMIT	EQU	6

*
*	BLOCKMOVEDOWN -- MOVE BLOCK AT (X) TO (Y) FOR (B) BYTES
*	(Y) = LOCATION ZERO
*	COPIES LARGE BLOCKS AT 23uS. PER BYTE
*
BLOCKMOVEDOWN	EQU	*
	STX	FROMPOINTER	SAVE WHERE TO COPY FROM
	CLRA		EXTEND (B) TO 16 BITS
	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	CPX	LIMIT	ALL BYTES MOVED ?
	BEQ	BLOCKMOVEDOWND	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	0,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	0,X	STORE 1ST AND SECOND BYTES
	LDAB	TOPOINTER+1	ADVANCE POINTERS BY 4 BYTES
	ADDB	#4
	STAB	TOPOINTER+1
	BCC	*+5
	INC	TOPOINTER
	LDAB	FROMPOINTER+1
	ADDB	#4
	STAB	FROMPOINTER+1
	BCC	*+5
	INC	FROMPOINTER
	LDX	FROMPOINTER	SET UP FOR NEXT LOOP ITERATION
	CPX	LIMIT	ALL DONE MOVING BYTES ?
	BNE	BLOCKMOVEDOWN4	B/ NO, MOVE SOME MORE BYTES!!
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
*	(B) = count (0..255)
*	ASSUMES THAT COPY-TO REGION DOES NOT OVERLAP COPY-FROM REGION,
*	OR THAT "FROM" >= "TO".
*
BLOCKMOVEDOWN	TSTB		ANY BYTES TO MOVE ?
	BEQ	BLOCKMOVEDOWNRTS	B/ NO
BLOCKMOVEDOWNLOOP
	LDAA	,X+	MOVE A BYTE
	STAA	,Y+
BLOCKMOVEDOWNRTS
	RTS
	FIN
	PAGE
*
*	TAKE UPPER CASE OF STRING
*
XOPUPPERC	PULX		GET ADDRESS OF STRING
	LDD	CATBUF	AIM TOS SDC AT THE CATBUF
	SUBD	#STRING-1
	PSHD
	STX	S1ADD
	LDB	CURLEN+1,X	MAKE SURE WE DON'T OVERFLOW THE CATBUF
	CMPB	CATSIZ+1
	BHS	XOPUPPERC5	B/ CATBUF TOO SMALL!!
	LDX	CATBUF	SAVE ADDRESS OF CATBUF
	STX	S2ADD	WHERE TO COPY TO
	STB	0,X	SET CURLEN OF STRING
	BEQ	XOPUPPERC3	B/ DONE
	IF	M6800!M6801
XOPUPPERC1	LDX	S1ADD
	LDAA	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	STAA	1,X
	INX
	STX	S2ADD
	DECB
	BNE	XOPUPPERC1	B/ MORE TO DO
	ELSE	(M6809)
	LDX	S1ADD	COPY BYTES CONVERTING TO UPPER CASE
	LDY	S2ADD
	LEAY	1,Y	SO WE CAN TO AUTO-INC IN COPY LOOP
	LDB	TEMPX+1
XOPUPPERC1	LDA	,X+
	CMPA	#'a
	BLO	XOPUPPERC2
	CMPA	#'z
	BHI	XOPUPPERC2
	SUBA	#32	CONVERT TO UPPER CASE ASCII
XOPUPPERC2	STA	,Y+
	DECB
	BNE	XOPUPPERC1
	FIN
XOPUPPERC3	JMP	NTRPT2

XOPUPPERC5	JSR	RTPERR
	FCB	:CATOVF

*
*	EXIT ROUTINE
*
XOPEXIT
	CLRA
	CLRB
ERROREXIT	; PANIC EXIT TO SDOS
	LDX	#SYSCALL:ERROREXIT*256+ERROREXIT:SCLEN
	STX	SYSCALLBLOCK	SET UP SYSCALL BLOCK TO CONTAIN ERROREXIT CALL
	STD	SYSCALLPARAMS	STORE ERROR CODE IN SYSCALL BLOCK
	JMP	EXECISYSCALL	AND GO TELL SDOS WE ARE IN TROUBLE!

*************************************************************
BASICRTPEND$	EQU	*
BASICRTPSIZE	EQU	*-CODE	SHOULD BE <$1000
*************************************************************

	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

