A large commit.

[pdp8.git] / sw / os8 / v3d / sources / extensions / dectapes / dectape2 / bcomp.pa

/OS8 BASIC COMPILER, V5
/
/
/
/
/
/
/
//
/
/
/
/
/COPYRIGHT (C) 1972, 1973, 1974, 1975
/DIGITAL EQUIPMENT CORPORATION, MAYNARD, MASS.
/
/
/
/THIS SOFTWARE IS FURNISHED UNDER A LICENSE FOR USE ONLY ON A
/SINGLE COMPUTER SYSTEM AND MAY BE COPIED ONLY WITH THE INCLU-
/SION OF THE ABOVE COPYRIGHT NOTICE.  THIS SOFTWARE, OR ANT OTHER
/COPIES THEREOF, MAY NOT BR PROVIDED OR OTHERWISE MADE AVAILABLE
/TO ANY OTHER PERSON EXCEPT FOR USE ON SUCH SYSTEM AND TO ONE WHO
/AGREES TO THESE LICENSE TERMS.  TITLE TO AND OWNERSHIP OF THE
/SOFTWARE SHALL AT ALL TIMES REMAIN IN DEC.
/
/
/THE INFORMATION IN THIS SOFTWARE IS SUBJECT TO CHANGE WITHOUT
/NOTICE AND SHOULD NOT BE CONSTRUED AS A COMMITMENT BY DIGITAL
/EQUIPMRNT COROPATION.
/
/DEC ASSUMES NO RESPONSIBILITY FOR THE USE OR RELIABILITY OF ITS
/SOFTWARE ON EQUIPMENT WHICH IS NOT SUPPLIED BY DEC.
/
/
/
/
/
/
\f/DEC-S8-LBASA-B-LA
/
/COPYRIGHT  C  1972, 1973, 1974
/
/DIGITAL EQUIPMENT CORPORATION
/MAYNARD,MASSACHUSETTS 01754
/
/AUGUST 19, 1972
/
/HANK MAURER, 1972
/SHAWN SPILMAN, 1973
/
/
/ASSEMBLE AND LOAD AS FOLLOWS:
/
/	.R PAL8
/	*BCOMP,BCOMP<BCOMP.03
/	.R ABSLDR
/	*BCOMP$
/	.SA SYS BCOMP;7000
/
/NOTE DIFFERENCES FROM VERSION 1 AS FOLLOWS:
/
/	.R SRCCOM
/	*LPT:<BCOMP.01,BCOMP.03
/	*
/
/
	VERSON=5	/VERSION LOCATED IN CORE AT TAG "VERLOC"
			/LEFT HALF OF VERLOC = 60+VERSON
			/RIGHT HALF OF VERLOC = PATCH LEVEL (01=A)

/
/CORRECTION & ADDITION MADE FOR V4	 J.K. 1975
/
/ ./V FOR VERSION NUMBER
/ . ABILITY TO INPUT FROM PTR
/ .CORRECT TEST FOR BATCH RUNNIG
/ .IGNORE MORE THAN 10 SIGNIFICANT DIGITS 
/ OF NUMERIC CONSTANTS
/JR	30-APR-77	UPDATE VERSION
\f	*5
TEMP3,	0
XABORT,	ABORT		/ADDR OF ABORT ROUTINE
	0
X10,	INFO-5		/AUTO INDEX REGISTERS
X11,	NAMLST-1
X12,	INFO-5
X13,	BOSINFO-1
OSTACK,	STACKO-1	/OPERAND STACK POINTER
STACK,	STACKA-1	/GENERAL STACK POINTER
NEXT,	FREE-1		/NEXT FREE LOCATION
CHRPTR,	0		/INPUT BUFFER POINTER
NCHARS,	0		/SIZE OF INPUT LINE
TEMP,	-4
TEMP2,	0
DECPT,	0		/SET 1 IF .
NDIGIT,	0		/NUM DIGITS RIGHT OF .
EXPON,	0		/EXPONENT FOR NUM CONV
TYPE,	0		/TYPE OF CURRENT OPERAND
SYMBOL,	0		/SYMBOL NUMBER OF CUR. OPERAND
LEFT,	0		/LEFT SIDE SWITCH
OLDOP,	0		/OLD OPERATOR
NEWOP,	0		/NEW OPERATOR
TMPCNT,	0		/TEMP COUNTER
TMPLVL,	3		/TEMP LEVEL
STMPCT,	0		/TEMP COUNT (STRINGS)
STMPLV,	1		/TEMP LEVEL (STRINGS)
STPTR,	0		/POINTER TO S.T. ENTRY
VARCNT,	-401		/NUMBER OF POSSIBLE NUMERIC
			/VARIABLES, LITERALS, AND TEMPS
SVCNT,	-401		/SAME FOR STRING VARS
ACNT,	-41		/ARRAY COUNTER
SACNT,	-41		/STRING ARRAY COUNTER
LOCTRH,	0		/HIGH ORDER LOCATION COUNTER
LOCTRL,	0		/LOW ORDER     "        "
BLOCK,	0		/START BLOCK OF TEMP FILE
HIFLD,	0		/HIGHEST CORE FIELD
BRTS,	0		/START OF BRTS.SV
DLSIZE,	0		/NEG. SIZE OF DATA LIST
ABORTX,	0		/START OF EDITOR
LINEH,	0		/LINE NUMBER (HIGH)
LINEL,	0		/LINE NUMBER (LOW)
MODE,	0		/INTERPRETER MODE
TYPE1,	0		/TYPE AFTER JMS GETA1
SYMBL1,	0		/SYM # AFTER JMS GETA1
OLDSTK,	0		/STACK SAVER FOR DEF
ARGCNT,	0		/ARG COUNTER FOR DEF
PCRLF,			/CR SWITCH FOR PRINT STMT
DACNT,			/ARG COUNT FOR UDEF STMT
FORJMP,			/FOR LOOP JUMP INSTR
NOSN,			/STMT NUMBER PRESENT SWITCH
COLON,			/: SWITCH FOR GETFN ROUTINE
JAROND,	0		/END OF DEF ADDR GOES HERE (INDIRECTLY)
IFNREG,	0		/CONTENTS OF IFN REG
SSREG1,	0		/EXECUTION TIME CONTENTS
SSREG2,	0		/OF THE SS REGISTORS
STKLVL,	STACKA-1	/STACK BASE LEVEL
FINDEX,	0		/FOR LOOP INDEX
SETFLD,	0		/FIELD CHANGE RTNE FOR LUKUP2
LUFLD,	CDF	10	/FIELD OF ENTRY FOR LUKUP2
	JMP I	SETFLD
QERMSG,	ERMSG		/SUBROUTINE POINTERS
QLODSN,	LODSN
QCHKWD,	CHKWD
QMODSET,MODSET
QSNUM,	SNUM
QOUTWRD,OUTWRD
QSAVECP,SAVECP
QGETC,	GETC
QGETCWB,GETCWB
QRESTCP,RESTCP
QEXPR,	EXPR
QOUTOPR,OUTOPR
QNEWLIN,NEWLIN
QREMARK,REMARK
QGETA1,	GETA1
QLOADSS,LOADSS
QCHECKC,CHECKC
QGETNAM,GETNAM
QCOMARP,COMARP
QLOOKUP,LOOKUP
QLUKUP2,LUKUP2
QLOAD,	LOAD
QPUSH,	PUSH
QPOP,	POP
QPUSHO,	PUSHO
QSAVAC,	SAVAC
QBACK1,	BACK1
QNUMBER,NUMBER
QSTRING,STRING
QLETTER,LETTER
QDIGIT,	DIGIT
QNOREGS,NOREGS
Q400,	400
NAME1,			/VARIABLE OR FUNCT NAME
WORD1,	0		/3 WORD LITERAL BUFFER
NAME2,
WORD2,	0
NAME3,
WORD3,	0
ACO,	0		/FAC OVERFLOW WD
OP1,	0		/4 WORD ARG FOR "NUMBER"
OP2,	0
OP3,	0
OPO,	0
NUMDIG,	-13
SIGDIG,	0
\f	INFO=	7604	/INFORMATION AREA
/INFO    STARTING BLOCK +1 OF BASIC.SV
/INFO+1  STARTING BLOCK +1 OF BCOMP.SV
/INFO+2  STARTING BLOCK +1 OF BLOAD.SV
/INFO+3  STARTING BLOCK +1 OF BRTS.SV
/INFO+4  STARTING BLOCK +1 OF BASIC.AF
/INFO+5  STARTING BLOCK +1 OF BASIC.SF
/INFO+6  STARTING BLOCK +1 OF BASIC.FF
/INFO+7  STARTING BLOCK +1 OF BASIC.UF
/INFO+10 STARTING BLOCK OF BASIC.TM
/INFO+11 SIZE IN BLOCKS OF BASIC.TM
/INFO+12 INPUT HANDLER ENTRY ADDRESS
/INFO+13 SIZE AND DEVICE NUMBER OF INPUT FILE
/INFO+14 STARTING BLOCK OF INPUT FILE
/INFO+15 THROUGH
/INFO+20 NAME OF WORKSPACE
/
/
	BOSINFO=	7774	/BOS PARAMETER AREA
	EDTSIZ=	2100	/SIZE OF BASIC.SV
	EDTBGN=	3212	/RESTART FOR EDITOR
	ERMSG2=	1712	/POST PROCESSOR ERROR SWITCH
	EOST=	7570	/UPPER LIMIT FOR SYMBOL TABLE
	INDEVH=	4600	/INPUT DEVICE HANDLER
	LINE=	7000	/LINE BUFFER
	LINMAX=	121	/MAXIMUM BASIC STMT
	STACKA=	7120	/MAIN STACK
	STAKSZ=	60	/SIZE OF MAIN STACK
			/OPERAND STACK DEFINED IN-LINE
	STRLIM=	120	/MAXIMUM STRING SIZE
	INBUF=	7200	/INPUT BUFFER
/
/
/FIELD ONE STUFF
/
/
	OUBUF=	0		/OUTPUT BUFFER
	VARST=	400	/VARIABLE SYMBOL TABLE
	SVARST=	VARST+436/STRING VAR SYMBOL TABLE
	ARAYST=	SVARST+1074/ARRAY SYMBOL TABLE
	SARYST=	ARAYST+200/STRING ARRAY SYMBOL TABLE
	SNUMS=	SARYST+200/STMT NUMBER BUCKETS
	TEMPS=	SNUMS+24	/NUMERIC TEMP BUCKET
	STEMPS=	TEMPS+2	/STRING TEMP BUCKET
	LITRL=	STEMPS+2	/NUMERIC LITERAL BUCKET
	SLITRL=	LITRL+2	/STRING LITERAL BUCKET
	DATLST=	SLITRL+2	/DATA LIST
	FUNCTN=	DATLST+2	/FUNCTION LIST
	FREE=	FUNCTN+2	/START OF FREE CORE
\f/	INTERPRETER OPCODES
/
/	MEMORY REFERENCE SET
	FADD=	0000
	FSUB=	0400
	FMPY=	1000
	FDIV=	1400
	FLDA=	2000
	FSTA=	2400
	FISUB=	3000
	FIDIV=	3400
	LSS1=	4000
	LSS2=	4400
	JEOF=	5400
	LOADSN=	6000
/
/	JOC CLASS
	JSUB=	5000
	JUMP=	5001
	JGE=	5002
	JNE=	5003
	JGT=	5004
	JLT=	5005
	JEQ=	5006
	JLE=	5007
	JFOR=	5010
/
/	ARRAY CLASS
	AISUB=	6400
	AFADD=	6440
	AFSUB=	6500
	AFMPY=	6540
	AFDIV=	6600
	AFLDA=	6640
	AFSTA=	6700
	AIDIV=	6740
/
/	STRING CLASS
	SCON=	FADD
	SCOMP=	FSUB
	SREAD=	FMPY
	SLOAD=	FLDA
	SSTORE=	FSTA
	SACON=	AISUB
	SACOMP=	AFADD
	SAREAD=	AFSUB
	SALOAD=	AFLDA
	SASTOR=	AFSTA
/
/	OPERATE CLASS
	SETJF=	7401
	RNDO=	7421
	STOP=	7441
	SRDL=	7461
	CHN=	7414
	NRDL=	7521
	CLOSEF=	7434
	OPENAV=	7474
	OPENAF=	7454
	OPENNV=	7534
	OPENNF=	7514
	CLRFN=	7501
	FILENO=	7402
	FNEG=	7403
	RET=	7404
	REST=	7405
	LSS1AC=	7406
	LSS2AC=	7407
	FESC=	7410
	READ=	7411
	WRITE=	7412
	SWRITE=	7413
	SMODE=	7561
	NMODE=	7541
	FUNC1=	7416
	FUNC2=	7417
	FUNC3=	7400
	FUNC4=	7415
	USE=	7540
\f/ ASSEMBLE LINE
	*STRLIM%2+1+WORD1 /ORG PAST BIGGEST STRING LIT
NEWLIN,	JMS I	QGETC	/ANY CHARS LEFT ?
	JMP	REMARK	/NO, LINE ENDED OK
	JMS I	QERMSG	/EXTRA CHARACTERS
	3003
REMARK,	DCA	NOSN	/CLEAR STMT NUMBER SWITCH
	TAD	TMPLVL	/RESET TEMP LEVELS
	DCA	TMPCNT	/FOR NUMERIC
	TAD	STMPLV	/AND STRING
	DCA	STMPCT	/TEMPORARIES
	TAD	(STACKO-1
	DCA	OSTACK	/RESET STACK POINTERS
	TAD	STKLVL	/(CHANGED BY FOR LOOPS)
	DCA	STACK
	TAD	(LINE-1	/GET THE NEXT LINE
	DCA	X10
	TAD	(-LINMAX/MAX SIZE
	DCA	TEMP3
GETLIN,	JMS	ICHAR	/GET NEXT CHAR
	JMP	GOTCR	/CR
	DCA I	X10	/PUT INTO LINE BUFFER
	ISZ	TEMP3	/BUMP MAX COUNTER
	JMP	GETLIN
	JMP	GOTCR
ERLTL,	JMS I	QERMSG	/LINE TOO LONG
	1424
	JMS	ICHAR	/SKIP REST OF LINE
	JMP	NOSNUM+3
	CLA
	JMP	.-3
GOTCR,	TAD	X10	/COMPUTE SIZE
	CMA
	TAD	(LINE-1	/OF LINE
	DCA	NCHARS
	TAD	(LINE-1	/SETUP LINE POINTER
	DCA	CHRPTR
/	TAD	LOCTRL	/PUT LOCATION COUNTER
/	7421		/INTO MQ
	CLA CLL CML RAR	/ALLOW DEFINITION
	JMS I	QSNUM	/GET THE STATEMENT NUMBER
	JMP	NOSNUM	/NO STMT NUMBER ON THIS LINE
	ISZ	NOSN	/SET STMT NUMBER PRESENT
	JMS I	QMODSET	/IN N MODE AT ALL LABELS
	JMS I	QNOREGS	/FORGET REG CONTENTS
	TAD	WORD1	/SAVE NEW LINE NUMBER
	DCA	LINEH
	TAD	WORD2
	DCA	LINEL
	JMS	SETFLD	/GET TO FIELD OF ENTRY
	TAD I	TEMP2	/GET DEFINED/REFNCED BITS
	TAD	LOCTRH	/ADD IN HIGH ORDER LOCATION CTR
	DCA I	TEMP2	/PUT IT AWAY
	ISZ	TEMP2
	TAD	LOCTRL	/NOW PUT IN LOW ORDER LOCATION
	DCA I	TEMP2
	CDF
NOSNUM,	TAD	TEMP3
	SNA CLA
	JMP	ERLTL
	JMS	KBDCHK	/CHECK FOR ^C OR ^O
	TAD	(KEYWRD-1
	DCA	X10	/SET UP FOR KEYWORD SEARCH
	JMS I	QSAVECP	/SAVE CHAR POS
KWLOOP,	TAD I	X10	/GET NEXT CHAR OF KEYWORD
	SMA
	JMP	GOTKW	/OK, THIS IS THE KW
	DCA	TEMP
	JMS I	QGETC	/GET NEXT CHAR FROM STMT
	JMP	NOGOOD	/THIS ISN'T IT
	TAD	TEMP	/IS THIS CHAR OK ?
	SNA CLA
	JMP	KWLOOP	/YES, CONTINUE LOOKING
NOGOOD,	JMS I	QRESTCP	/BACK TO START OF STMT
	TAD I	X10	/SKIP OVER REST OF KEYWORD
	SPA CLA
	JMP	.-2
	TAD I	X10	/IS THIS END OF LIST ?
	SZA
	JMP	KWLOOP+3/NO, KEEP LOOKING
	JMP	LET	/TREAT AS LET STMT
GOTKW,	DCA	TEMP	/SAVE ADDR OF ROUTINE
	JMP I	TEMP	/GO PROCESS THE STMT
\f/ LET STATEMENT PROCESSOR
LET,	JMS I	QLODSN	/LOAD THE STMT NUMBER
	CLL CML RAR	/COMPILE LEFT SIDE
	JMS I	QEXPR	/GET EXPRESSION
	JMP	REMARK
	JMS I	QCHECKC	/LOOK FOR =
	-75
	JMP	BADLET	/BAD IF MISSING
	JMS I	QEXPR	/GET RIGHT SIDE
	JMP	REMARK
	CLA CMA		/GET TYPE OF
	TAD	OSTACK	/RIGHT SIDE
	DCA	TEMP	/OF EQUAL SIGN
	TAD I	TEMP	/SO THAT WE GENERATE
	SPA CLA
	CLL CMA RAL	/THE CORRECT STORE
	TAD	(ASSIGN-1
	JMS I	QOUTOPR	/GENERATE STORE
	JMP	NEWLIN
BADLET,	JMS I	QERMSG	/BAD LET STMT
	1423
	JMP	REMARK
END,	TAD	(STOP	/OUTPUT STOP OPCODE
	JMS I	QOUTWRD
	JMS	OUDUMP	/DUMP BUFFER
	JMS I	(7607	/READ IN POST PROCESSOR
	1300		/ELEVEN PAGES
POSTX,	400		/FROM 400
LDRBLK,	0		/FROM THIS BLOCK
	IFNZRO	LDRBLK-357 <__FIX BLOAD__>
	JMP I	XABORT
	TAD I	QERMSG	/SET POST PROCESSOR ERROR SWITCH
	DCA	ERMSG2
	JMP I	POSTX	/START IT UP
\f/  RESTORE, PRINT, AND INPUT PROCESSORS
	PAGE
INPUT,	JMS I	QLODSN	/OUTPUT STMT NUM
	JMS	GETFN	/LOOK FOR #<FILE NUM EXPR>:
INPUTL,	CLL CML RAR	/PROCESS INPUT STMT
	JMS I	QEXPR	/GET EXPR
	JMP I	QREMARK
	JMS I	QGETA1	/GET TOP OF STACK
	TAD	TYPE1	/LOOK AT THE TYPE
	SPA CLA
	JMP	RSTRNG	/READ STRING
	JMS I	QMODSET	/SET MODE
	CLL CML RTR	/IS IT DIMENSIONED ?
	AND	TYPE1
	SZA CLA
	JMP I	(DIMREAD/YES
	TAD	(READ	/OUTPUT READ COMMAND
	JMS I	QOUTWRD
	TAD	(FSTA	/USE SCALAR STORE
FININP,	TAD	SYMBL1	/PLUS SYMBOL NUMBER
	JMS I	QOUTWRD	/OUTPUT INSTR
	JMS I	QCHECKC	/LOOK FOR ,
	-54
	JMP I	QNEWLIN	/END OF INPUT
	JMP	INPUTL	/YES, LOOP
RSTRNG,	CLL CML RAR	/SET MODE
	JMS I	QMODSET	/TO STRING
	CLL CML RTR	/SUBSCRIPTED ?
	AND	TYPE1
	SNA CLA
	JMP	.+3	/NO
	JMS I	QLOADSS	/LOAD SS REG
	TAD	(SAREAD-SREAD
	TAD	(SREAD	/STRING READ
	JMP	FININP	/USE SOME COMMON CODE
PRINT,	JMS I	QLODSN	/OUTPUT STMT NUM
	JMS	GETFN	/GET FILE NUMBER
	DCA I	QEXPR	/USE ENTRY AS SWITCH
PRINTL,	DCA	PCRLF	/CLEAR THE FLAG
	JMS I	QGETC	/LOOK FOR A CHAR
	JMP	PRTEND	/NONE LEFT, END PRINT
	TAD	(-73	/; ?
	SNA
	JMP	NOCR	/YES, DON'T SPACE OUTPUT
	TAD	(73-54	/, ?
	SZA CLA
	JMP	TABPNT	/LOOK FOR TAB OR PNT
	TAD	(FUNC3+20
	JMS I	QOUTWRD	/OUTPUT FUNC3+20 (COMMA)
NOCR,	DCA I	QEXPR	/CLEAR THE SWITCH
	CLA IAC		/SET NO CRLF FLAG
	JMP	PRINTL
TABPNT,	TAD I	QEXPR	/WAS LAST THING AN EXPR ?
	SZA CLA
	JMP I	QNEWLIN	/YES, CAN'T HAVE TWO IN A ROW
	JMS I	QBACK1	/PUT THAT CHAR BACK
	JMS I	QSAVECP	/SAVE CHAR POS
	JMS I	QCHKWD	/LOOK FOR "TAB("
	WTAB
	JMP	TRYPNT	/NO TAB
	TAD	(FUNC3+100
PFCALL,	DCA	PRFUN	/SAVE PRINT FUNCTION
	JMS I	QEXPR	/GET ARG
	JMP I	QREMARK
	JMS I	QLOAD	/LOAD ARG
	TAD	TYPE1	/MUST BE NUMERIC
	SMA CLA
	JMP	.+4	/OK, IT IS
BADPF,	JMS I	QERMSG	/PRINT ERROR
	0622		/BAD FUNCTION REFERENCE
	JMP I	QREMARK
	JMS I	QCHECKC	/LOOK FOR )
	-51
	JMP	BADPF	/BAD FUN REFERENCE
	TAD	PRFUN	/OUTPUT FUNCTION CALL
	JMP	PUT1
TRYPNT,	JMS I	QRESTCP	/RESTORE CHAR POS
	JMS I	QCHKWD	/LOOK FOR PNT(
	WPNT
	JMP	PEXP	/NO
	TAD	(FUNC3+120
	JMP	PFCALL	/GO DO FUN CALL
PEXP,	JMS I	QRESTCP	/RESTORE CHAR POS
	JMS I	QEXPR	/GET EXPR TO BE PRINTED
	JMP I	QREMARK
	JMS I	QLOAD	/PUT THING INTO FAC (OR SAC)
	CLL CML RAR
	AND	TYPE1	/GET TYPE BIT
	CLL RTL		/INTO AC 11
	TAD	(WRITE	/SWRITE=WRITE+1
PUT1,	JMS I	QOUTWRD
	JMP	PRINTL
PRTEND,	TAD	PCRLF	/DID PRINT END WITH
	SZA CLA		/, OR ;
	JMP I	QNEWLIN	/YES, NO CR LF
	TAD	(FUNC3+40
PUT2,	JMS I	QOUTWRD	/CALL TO CRLF ROUTINE
	JMP I	QNEWLIN	/END OF PRINT
RESTOR,	JMS I	QLODSN	/OUTPUT LOAD STMT NUMBER
	CLA IAC		/NO COLON NEEDED
	JMS	GETFN	/LOAD FILE REG
	TAD	(REST	/OUTPUT RESTORE OP
	JMP	PUT2
PRFUN,
LODSN,	0		/OUTPUT STMT NUMBER INTO CODE
	TAD	NOSN	/ANY STMT NUMBER ?
	SNA CLA
	JMP I	LODSN	/NO, JUST RETURN
	TAD	WORD1	/NOW OUTPUT "LOAD STMT NUM REG"
	TAD	(LOADSN
	JMS I	QOUTWRD
	TAD	WORD2
	JMS I	QOUTWRD
	JMP I	LODSN

XADD,	FADD;AFADD
\f/ DIM PROCESSOR
	PAGE
DIM,	JMS I	QGETNAM	/GET VAR NAME
	JMP	DIMERR
	TAD	TYPE	/CHECK TYPE
	RTL		/MOVE BITS TO BE TESTED
	SMA CLA		/IF FUNC BIT SET THEN ERROR
	SNL		/IF DIM BIT NOT SET THEN ERROR
	JMP	DIMERR	/NO DIMENSIONS
	JMS	SMLNUM	/GET DIMENSION
	TAD	EXPON	/SAVE IT
	DCA	DIM1
	JMS I	QCOMARP	/, OR )  ??
	JMP	DIMERR	/NEITHER IS BAD
	JMP	TWODIM	/, THERE'S ANOTHER DIMENSION
	JMS	CHKSDM	/CHECK SIZE IF STRING
	JMP	CHKDIM	/NUMERIC VECTOR, CHECK PREV REF
	CLL CML RAR	/THIS WAS A STRING SIZE DIM
	DCA	TYPE	/PERFORM THE SPECIAL CASE
	JMS I	QLOOKUP
	CDF	10	/OF NOT CHECKING PREVIOUS REFS
	JMP	FINDIM
TWODIM,	JMS	SMLNUM	/GET SECOND
	JMS I	QCHECKC	/LOOK FOR )
	-51
	JMP	DIMERR
	JMS	CHKSDM	/CHECK SIZE IF STRING ARRAY
	TAD	(7000	/NUMERIC ARRAY
CHKDIM,	TAD	(7000	/GET NUMBER OF DIMS
	DCA	TEMP
	JMS I	QLOOKUP	/FIND ST ENTRY
	CDF	10
	TAD I	STPTR	/LOOK AT DIM BITS
	AND	(7000	/PREVIOUSLY REFERENCED ?
	SNA
	JMP	UNREFD	/NO
	SMA		/IF MINUS, CAUSE ERROR
	TAD	TEMP	/COMPARE NUMBER
	SZA CLA
	JMP	DIMERR	/NUMBER OF DIMS DON'T MATCH
	DCA	TEMP	/ZERO TEMP
UNREFD,	CLL CML RAR	/PUT IN DIMENSIONED BIT
	TAD	TEMP	/AND NUMBER OF DIMENSIONS
	CIA		/NEGATE WHOLE MESS (4000=-4000)
	TAD I	STPTR	/TOGETHER WITH SYM NUMBER
	DCA I	STPTR
	ISZ	STPTR
	TAD	DIM1	/NOW FIRST DIMENSION (IF 2)
	DCA I	STPTR
FINDIM,	ISZ	STPTR
	TAD	EXPON	/NOW SECOND (IF 2, OTHERWISE FIRST)
	DCA I	STPTR
	CDF
	JMS I	QCHECKC	/LOOK FOR ,
	-54
	JMP I	QNEWLIN	/NONE, ASSUME END OF DIM
	JMP	DIM	/GET NEXT ELEMENT
CHKSDM,	0		/CHECK SIZE OF STRINGS
	TAD	TYPE	/WAS THIS A STRING DIM ?
	SMA CLA
	JMP I	CHKSDM	/NO, RETURN IMMEDIATE
	ISZ	CHKSDM	/YES, SKIP ON RETURN
	TAD	EXPON	/SIZE MUST BE < 73
	CLL
	TAD	(-STRLIM-1
	SNL CLA
	JMP I	CHKSDM	/OK, SIZE < 73
DIMERR,	JMS I	QERMSG	/GIVE ERROR
	0411
	JMP I	QREMARK	/ABORT STMT
\f/ NEXT PROCESSOR
NEXTX,	JMS I	QGETNAM	/GET INDEX VARIABLE
	JMP	BADNXT
	JMS I	QLOOKUP
	TAD	TYPE	/MUST BE NUMERIC
	SPA CLA
	JMP	BADNXT	/IT ISN'T
	JMS I	QMODSET	/N MODE
NEXTL,	TAD	(-STACKA-3
	TAD	STACK	/ANY FOR'S LEFT ?
	SPA CLA		/(OK IF STACKA ABOVE 4000)
	JMP	BADNXT	/NO
	JMS I	QPOP	/GET LABEL ADDR
	DCA	TEMP
	JMS I	QPOP	/GET LABEL FIELD
	DCA	LUPFLD
	JMS I	QPOP	/GET STEP VAR
	TAD	XLOAD	/LOAD IT
	JMS I	QOUTWRD
	JMS I	(PSETJF	/PATCH!
	TAD	FINDEX	/ADD IT TO STEP (FADD=0)
	JMS I	QOUTWRD
	TAD	LUPFLD	/CREATE JUMP TO LOOP
	AND	(70
	CLL RTL
	TAD	(JUMP
	JMS I	QOUTWRD
	CLL CMA RAL	/GET LABEL DEFINITION ADDR
	TAD	TEMP
	JMS I	QOUTWRD	/OUTPUT IT AS LOW PART OF JUMP
DIM1,
LUPFLD,	HLT
	CLL CML RAR	/SET LABEL DEFINED BIT
	TAD	LOCTRH	/DEFINE END OF LOOP LABEL
	DCA I	TEMP
	ISZ	TEMP
	TAD	LOCTRL
	DCA I	TEMP
	CDF
	TAD	STACK	/BACK OFF STACK LEVEL
	DCA	STKLVL
	JMS I	QNOREGS	/FORGET REGS
	TAD	SYMBOL	/IS THIS THE RIGHT NEXT ?
	CIA
	TAD	FINDEX
	SNA CLA
	JMP I	QNEWLIN	/YES, FINISHED
BADNXT,	JMS I	QERMSG	/NEXT WITHOUT FOR
	1606
	JMP I	QREMARK
UMOPR,	40;1;UMRTNE-1
XLOAD,	FLDA;AFLDA
\f/ UDEF PROCESSOR (DEFINE USER FUNCTION)
	PAGE
UDEF,	ISZ	NFUNS	/ROOM FOR ANOTHER FUN ?
	JMS I	QLETTER	/GET FIRST LETTER
	JMP	DEFBAD	/ERROR IN DEFINE
	CLL RTL		/PUT INTO HIGH ORDER
	RTL
	RTL
	DCA	NAME1	/SAVE CHAR 1
	JMS I	QLETTER	/GET SECOND LETTER
	JMP	DEFBAD	/ERROR
	TAD	NAME1	/COMBINE THE TWO CHARS
	CIA
	DCA I	FUNPTR	/SAVE IN FUN TABLE
	ISZ	FUNPTR
	JMS I	QLETTER	/GET THIRD LETTER
	JMP	DEFBAD
	CIA		/SAVE NEG OF THIRD LETTER
	DCA I	FUNPTR
	ISZ	FUNPTR	/BUMP POINTER
	TAD	M5	/NUMERIC ARG COUNT
	DCA	TEMP	/ (MAX OF 4 ARGS)
	CLL CMA RTL	/STRING ARG COUNT
	DCA	TEMP2	/ (MAX OF 2 ARGS)
	JMS I	QCHECKC	/IS IT A STRING FUN ?
	-44
	SKP CLA
	CLL CML RAR	/YES, SET TYPE OF FUNCTION
	DCA	TYPE1
	JMS I	QCHECKC	/LOOK FOR (
	-50
	JMP	DEFBAD	/ERROR IF MISSING
DALOOP,	JMS I	QGETNAM	/GET AN ARG
	JMP	DEFBAD
	TAD	TYPE	/LOOK AT ITS TYPE
	CLL RAL		/SHIFT TYPE BIT INTO LINK
	SZA CLA
	JMP	DEFBAD	/OTHER BITS MUST BE OFF
	SZL
	JMP	STRARG	/STRING ARG
	TAD	TEMP	/GET ARG NUMBER
	ISZ	TEMP	/INCREMENT IT
	JMP	DAPUSH	/GO SAVE IT
DEFBAD,	JMS I	QERMSG	/BAD USER DEF
	2504
	JMP I	QREMARK
STRARG,	TAD	TEMP2	/GET ARG NUMBER
	ISZ	TEMP2	/AND INCREMENT IT
	JMP	DAPUSH+1
	JMP	DEFBAD	/TOO MANY STRING ARGS
DAPUSH,	TAD	Q2	/ADJUST ARG NUMBER
	TAD	Q2	/ADD 4 FOR NUM, 2 FOR STRING
	SPA
	CLA CLL CML RTR	/FIRST ARG STAYS IN AC
	TAD	TYPE	/ADD IN TYPE BIT
	JMS I	QPUSH	/SAVE IT ON STACK
	JMS I	QCOMARP	/LOOK FOR , OR )
	JMP	DEFBAD	/ERROR IF NEITHER
	JMP	DALOOP	/, GET NEXT ARG
	TAD	TEMP2	/GET TOTAL NUMBER OF ARGS
	TAD	TEMP
	TAD	Q10	/ADJUST COUNT
	CIA		/NEGATED
	DCA	DACNT
	TAD I	FUNPTR	/GET FUNCTION CODE
	ISZ	FUNPTR	/BUMP POINTER
	DCA	WORD1	/MAKE IT THE SEARCH OBJECT
	JMS I	XSTCHEK	/MAKE SURE THERE'S ROOM
	EOST-10
	JMS I	QLUKUP2	/ENTER NEW FUNCTION
	FUNCTN
	-1
	TAD	DACNT	/PUT IN ARG COUNT
	JMS	SETFLD	/(FIRST SET THE FIELD)
	DCA I	NEXT
DAPUT,	CDF
	JMS I	QPOP	/GET ARG TYPE (LAST TO FIRST)
	JMS	SETFLD	/SET THE FIELD
	DCA I	NEXT	/SAVE IT
	ISZ	DACNT	/ANY MORE ?
	JMP	DAPUT	/YES
	TAD	TYPE1	/PUT IN TYPE OF FUNCTION
	DCA I	NEXT
	CDF
	JMS I	QCHECKC	/LOOK FOR A COMMA
	-54
	JMP I	QNEWLIN	/NO COMMA, END OF LINE
	JMP	UDEF	/GET NEXT DEFINITION
XSTCHEK,STCHEK
FUNPTR,	ENDFNS
Q2,	2		/THESE FOUR WORDS
M5,	-5		/PREVENT ERRONEOUS "SAVES"
Q10,	10		/BY THE ROUTINE SAVAC
NFUNS,	-21		/WHEN THE OP STACK IS EMPTY
STACKO,			/OPERAND STACK
	STOKSZ=UDEF+200-STACKO
\f/ DEF PROCESSOR
	PAGE
DEF,	JMS I	QNOREGS	/FORGET REGS
	JMS I	QGETNAM	/GET FUN NAME
	JMP	BADDEF	/NO GOOD
	TAD	TYPE	/SAVE ITS TYPE
	DCA	TEMP2
	DCA	ARGCNT	/ZERO ARG COUNT
	TAD	TYPE	/TYPE MUST BE 3000 OR 7000
	RTL		/MOVE BITS TO BE TESTED
	SPA CLA		/FUN BIT OFF IS AN ERROR
	SNL		/DIM BIT OFF IS AN ERROR
	JMP	BADDEF
	JMS I	QMODSET	/ENTER N MODE
	TAD	SYMBOL	/SAVE FUNCTION NAME
	DCA	FUNNAM
ARGLUP,	JMS I	QGETNAM	/GET ARG NAME
	JMP	BADDEF
	CLL CMA RAR	/LOOK AT TYPE
	AND	TYPE
	SZA CLA
	JMP	BADDEF	/ARG WAS AN ARRAY OR FUNC
	JMS I	QLOOKUP	/ENTER INTO S.T.
	TAD	STPTR	/SAVE ST ADDRESS
	JMS I	QPUSH
	TAD	SYMBOL	/AND SYMBOL NUMBER
	JMS I	QPUSH
	TAD	TYPE	/AND ARG TYPE
	JMS I	QPUSH
	ISZ	ARGCNT	/BUMP ARG COUNT
	JMS I	QCOMARP	/LOOK FOR , OR )
	JMP	BADDEF
	JMP	ARGLUP	/, GET NEXT ARG
	TAD	FUNNAM	/ENTER FUNCTION
	DCA	WORD1
	TAD	ARGCNT	/FIRST GET ENOUGH ROOM
	CIA
	TAD	(EOST-3
	DCA	FUNNAM
	JMS	STCHEK	/CHECK IT
FUNNAM,	0
	JMS I	QLUKUP2	/LOOK UP FUNCTION
	FUNCTN
	-1
	JMP	OKFUN	/OK, NOT MULTIPLY DEFINED
BADDEF,	JMS I	QERMSG	/BAD DEFINE
	0405
	JMP I	QREMARK
OKFUN,	TAD	NEXT	/SAVE "NEXT"
	DCA	X12
	TAD	NEXT	/INCREMENT NEXT BY
	TAD	ARGCNT	/NUMBER OF ARGS
	TAD	(4	/PLUS 4
	DCA	NEXT
	JMS	SETFLD	/GET ROOM FOR LABEL
	CLL CML RAR	/FOR JUMP AROUND
	DCA I	NEXT	/SET DEFINED BIT
	TAD	NEXT	/SAVE ADDR
	DCA	JAROND	/FOR LATER
	ISZ	NEXT
	CDF
	TAD	LUFLD	/SAVE FIELD OF FUN BLOCK
	DCA	FUNFLD
	TAD	LUFLD	/ALSO FIELD OF LABEL
	DCA	JARFLD
	TAD	LUFLD	/GET FIELD
	AND	(70	/ISOLATE BITS
	CLL RTL		/INTO JUMP INSTR
	TAD	(JUMP
	JMS I	QOUTWRD	/OUTPUT IT
	TAD	JAROND	/OUTPUT LOW PART
	JMS I	QOUTWRD	/OF JUMP ADDR
	TAD	STACK	/SAVE STACK
	DCA	OLDSTK
	TAD	ARGCNT	/GET COUNT
	CMA
	DCA	TEMP
	TAD	ARGCNT	/TWICE
	CIA
	DCA	ARGCNT
	TAD	ARGCNT	/STORE COUNT FIRST
	JMP	FUNFLD
CHGARG,	CDF
	JMS I	QPOP	/GET ARG TYPE
	DCA	TYPE
	TAD	TYPE
	JMS	GENTMP	/GENERATE A TEMPORARY
SWTARG,	JMS I	QPOP	/PURGE SYMBOL NUMBER
	CLA
	JMS I	QPOP	/GET ST ADDR OF
	DCA	STPTR	/OF DUMMY ARG
	CDF	10
	TAD	SYMBOL	/PUT IN TEMP SYMBOL NUMBER
	DCA I	STPTR	/TO FAKE EXPR
	TAD	TYPE	/CREATE ARG DESCRIPTOR
	TAD	SYMBOL	/FOR FUNC BLOCK
FUNFLD,	HLT
	DCA I	X12	/AND PUT IT INTO F.B.
	ISZ	TEMP	/MORE ARGS?
	JMP	CHGARG	/YUP
	CLL CML RAR
	AND	TEMP2	/SAVE TYPE OF FUNCTION
	DCA I	X12
	CLL CML RAR	/SET DEFINED BIT
	TAD	LOCTRH	/AND LOCATION COUNTER
	DCA I	X12	/AT START OF FUNCTION
	TAD	LOCTRL
	DCA I	X12
	CDF
	TAD	STACK	/SAVE BOTTOM OF STACK
	DCA	X13
	TAD	OLDSTK	/RESTORE TO TOP
	DCA	STACK
	JMS I	QCHECKC	/FIND =
	-75
	JMP	BADDEF
	JMS I	QEXPR	/COMPILE FUNCTION
	JMP I	QREMARK
	JMS I	QLOAD	/GET IT INTO AC
	TAD	X13	/RESTORE STACK
	DCA	STACK	/TO BOTTOM
	JMP	RESARG	/FINISH DEF
\f/ DEF PROCESSOR (FINALE)
	PAGE
RESARG,	TAD I	X13	/GET ST ADDR
	DCA	STPTR
	TAD I	X13	/PUT BACK CORRECT SYM #
	CDF	10
	DCA I	STPTR
	CDF
	ISZ	X13	/SKIP OTHER STUFF
	ISZ	ARGCNT
	JMP	RESARG	/RESTORE NEXT
	TAD	(RET	/OUTPUT RETURN CODE
	JMS I	QOUTWRD
JARFLD,	HLT
	CLL CML RAR	/SET LABEL DEFINED BIT
	TAD	LOCTRH	/STICK IN ADDR
	DCA I	JAROND	/OF END OF FUNCT
	ISZ	JAROND	/PLUS ONE
	TAD	LOCTRL	/STORE LOW ADDR
	DCA I	JAROND
	CDF
	TAD	TMPCNT	/SAVE NEW TEMP LEVELS
	DCA	TMPLVL
	TAD	STMPCT
	DCA	STMPLV
	JMS I	QNOREGS	/FORGET REGS
	JMP I	QNEWLIN	/END OF DEF
\f/ DATA STATEMENT PROCESSOR
DATA,	JMS I	QNUMBER	/LOOK FOR NUMBER
	JMP	DSTRNG	/MUST BE A STRING
	JMS	DENTRY	/MAKE AN ENTRY
	-3		/3 WORDS LONG
MORDAT,	JMS I	QCHECKC	/LOOK FOR ,
	-54
	JMP I	QNEWLIN	/END OF DATA
	JMP	DATA	/DO NEXT ELEMENT
DSTRNG,	JMS I	QSTRING	/LOOK FOR STRING
	JMP I	QNEWLIN	/BAD
	TAD	WORD1	/COMPUTE SIZE
	IAC
	CLL CML CMA RAR
	DCA	DSSIZE	/INCLUDING CHAR COUNT
	TAD	WORD1	/NEGATE COUNT
	CIA
	DCA	WORD1
	JMS	DENTRY	/CREATE ENTRY
DSSIZE,	0
	JMP	MORDAT	/GO DO MORE
DENTRY,	0		/MAKE AN ENTRY IN DATA LIST
	TAD I	DENTRY	/GET SIZE
	DCA	TEMP
	ISZ	DENTRY
	TAD	TEMP	/INCREMENT SIZE COUNT
	TAD	DLSIZE
	DCA	DLSIZE
	TAD	(EOST	/HOW MUCH DO WE NEED ?
	TAD	TEMP
	DCA	.+2
	JMS	STCHEK	/ASK FOR IT
	0
	TAD	FREFLD	/GET FIELD OF FREE SPACE
	DCA	LUFLD	/SAVE IT IN SETFLD SUBROUTINE
DATFLD,	CDF	10
	TAD	NEXT	/HOOK IN NEW ENTRY
	IAC
	DCA I	DATPTR
PATCH3,	ISZ	DATPTR	/POINTER THEN FIELD
	TAD	LUFLD
	DCA I	DATPTR
	JMS	SETFLD
	TAD	TEMP	/SAVE SIZE OF ENTRY
	DCA I	NEXT
	TAD	(WORD1-1/MAKE READY TO MOVE
	DCA	X10
DELOOP,	CDF
	TAD I	X10	/GET WORD
	JMS	SETFLD
	DCA I	NEXT	/SAVE IT
	ISZ	TEMP	/MORE ?
	JMP	DELOOP
	DCA I	NEXT	/SAVE ROOM FOR POINTER&CDF
	TAD	NEXT	/THIS IS NOW LAST ENTRY
	DCA	DATPTR
PATCH4,	TAD	LUFLD
	DCA	DATFLD	/AND THIS IS ITS FIELD
	DCA I	NEXT
	CDF
	JMP I	DENTRY
DATPTR,	DATLST
\f/ READ PROCESSOR
READX,	JMS I	QLODSN	/OUTPUT STMT NUMBER
	CLL CML RAR	/GET VAR TO READ
	JMS I	QEXPR	/SAME AS LEFT SIDE OF LET
	JMP I	QREMARK
	JMS I	QGETA1	/GET VAR INFO FROM STACK
	TAD	TYPE1	/SET MODE
	JMS I	QMODSET
	TAD	TYPE1	/WHAT TYPE ?
	SPA CLA
	TAD	(SRDL-NRDL
	TAD	(NRDL	/STRING OR NUMERIC
	JMS I	QOUTWRD
	CLL CML RTR	/SUBSCRIPTS ?
	AND	TYPE1
	SNA CLA
	JMP	.+3	/NO
	JMS I	QLOADSS	/YES, LOAD SS REGS
	TAD	(AFSTA-FSTA
	TAD	(FSTA	/ARRAY OR SCALAR STORE
	TAD	SYMBL1
	JMS I	QOUTWRD
	JMS I	QCHECKC	/ANY MORE ?
	-54		/CHECK FOR COMMA
	JMP I	QNEWLIN	/NO
	JMP	READX+1	/YUP
AMPSND,	40;1;AMPRTN-1;4000;SCONTS;SCONTS
SCONTS,	FADD;AISUB
\f/ FOR PROCESSOR
	PAGE
FOR,	JMS I	QLODSN	/OUTPUT STMT NUMBER
	JMS I	QGETNAM	/GET INDEX VARIABLE
	JMP	BADFOR	/BAD
	TAD	TYPE	/MUST BE NUMBER
	SZA CLA
	JMP	BADFOR	/ITS NOT
	JMS I	QLOOKUP	/ST SEARCH
	TAD	SYMBOL	/SAVE INDEX VAR
	DCA	FINDEX	/FOR LATER
	JMS I	QCHECKC	/FIND =
	-75
	JMP	BADFOR
	TAD	CHRPTR	/SAVE CHAR POSITION
	DCA	FORCP	/IN A SPECIAL PLACE
	TAD	NCHARS
	DCA	FORNC
	SKP
FINDTO,	JMS I	QRESTCP	/RESTORE CHAR POS
	JMS I	QGETC	/SKIP A CHAR
	JMP	BADFOR
	CLA
	JMS I	QSAVECP	/SAVE THIS POSITION
	JMS I	QCHKWD	/LOOK FOR "TO"
	WTO
	JMP	FINDTO	/KEEP GOING
	JMS	FSUB2	/LOAD LIMIT AND SAVE IN TEMP
	DCA	FLIMIT	/SAVE LIMIT VAR
	JMS I	QCHKWD	/LOOK FOR "STEP"
	WSTEP
	JMP	STEP1	/USE 1.0 FOR THE STEP
	JMS	FSUB2	/LOAD STEP AND SAVE IN TEMP
	DCA	FSTEP	/SAVE STEP VAR
	TAD	(SETJF	/OUTPUT SETJF
	JMS I	QOUTWRD
	TAD	(JFOR	/STEP IS VARIABLE, USE JFOR
SAVEJF,	DCA	FORJMP	/SAVE CORRECT JUMP
	JMS I	QGETC	/ANY MORE CHARS ?
	SKP
	JMP	BADFOR	/YES, ERROR
	TAD	FORNC	/RESTORE CHAR POSITION
	DCA	NCHARS	/FROM SPECIAL PLACE
	TAD	FORCP
	DCA	CHRPTR
	JMS	FSUB1	/COMPILE INITIAL VALUE INTO FAC
	JMS	STCHEK	/CHECK FOR ROOM
	EOST
	TAD	FREFLD	/SAVE FIELD OF LABELS
	DCA	FORFLD
FORFLD,	HLT
	CLL CML RAR	/SET LABEL DEFINED BIT
	TAD	LOCTRH	/DEFINE THE LOOP LABEL
	DCA I	NEXT
	TAD	LOCTRL
	DCA I	NEXT
	CLL CML RAR	/SET LABEL DEFINED BIT
	DCA I	NEXT	/FOR END OF LOOP LABEL
	CDF
	TAD	FLIMIT	/TEST FOR DONE
	TAD	XSUB	/BY SUBTRACTING THE LIMIT
	JMS I	QOUTWRD
	TAD	FORFLD	/OUTPUT JUMP TO DONE
	AND	(70
	CLL RTL		/SHIFT FIELD BITS
	TAD	FORJMP	/USE PROPER JUMP INS
	JMS I	QOUTWRD
	TAD	NEXT	/OUTPUT LOW PART OF JMP
	JMS I	QOUTWRD
	TAD	FLIMIT	/FADD FLIMIT (FADD=0)
	JMS I	QOUTWRD
	TAD	FINDEX	/FSTA INDEX
	TAD	(FSTA
	JMS I	QOUTWRD
	TAD	FINDEX	/PUT STUFF ONTO STACK
	JMS I	QPUSH
	TAD	FSTEP
	JMS I	QPUSH
	TAD	FORFLD
	JMS I	QPUSH
	TAD	NEXT
	JMS I	QPUSH
	ISZ	NEXT	/BUMP NEXT AGAIN
	TAD	TMPCNT	/RESERVE THESE TEMPS
	DCA	TMPLVL
	JMS I	QNOREGS	/FORGET REGISTORS
	TAD	STACK	/SET NEW STACK LEVEL
	DCA	STKLVL
	JMP I	QREMARK
STEP1,	TAD	(3	/1.0 IS SLOT #3
	DCA	FSTEP
	TAD	(JGT	/USE JGT
	JMP	SAVEJF	/GO DO THE REST
FLIMIT,	0		/FOR LOOP UPPER LIMIT
FSTEP,	0		/FOR LOOP STEP
FORNC,	0		/FOR STMT CHAR POSITION
FORCP,	0
WTHEN,	-124;-110;-105;-116
XSUB,	FSUB;AFSUB
\f/ USE PROCESSOR
USEX,	TAD	(USE	/OUTPUT USE OPERATOR
	JMS I	QOUTWRD
	JMS I	QGETNAM	/GET ARRAY NAME
	JMP	USEERR	/ERROR
	TAD	TYPE	/CHECK TYPE
	SMA CLA		/(MUST BE NUMERIC)
	JMP	.+3	/IT WAS
USEERR,	JMS I	QERMSG	/ERROR IN USE STMT
	2525
	CLL CML RTR	/SET DIM BIT
	DCA	TYPE
	JMS I	QLOOKUP	/LOOKUP SYMBOL
	TAD	SYMBOL	/OUTPUT ARRAY NUMBER
	JMS I	QOUTWRD
	JMP I	QREMARK
\f/ IF AND IFEND PROCESSORS
	PAGE
IF,	JMS I	QLODSN	/OUTPUT STMT NUMBER
	JMS I	QEXPR	/GET LEFT EXPRESSION
	JMP I	QREMARK
	JMS I	QGETC	/GET RELATIONAL OPERATOR
	JMP	BADIF	/ERROR IF NONE
	CLL RTL
	RTL		/MOVE TO LEFT HALF
	RTL
	DCA	TEMP	/AND SAVE IT
	JMS I	QGETC	/GET 2 CHAR RELATIONALS
	JMP	BADIF
	TAD	TEMP	/COMBINE THE 2
	DCA	TEMP2
	TAD	(IFOPS-1/SETUP POINTER
	DCA	X10
IFLUP1,	TAD I	X10	/GET JUMP OPCODE
	SNA
	JMP	IFLUP2-1/NOT A 2 CHAR RELATIONAL
	DCA	RELOPR	/SAVE IT
	TAD I	X10	/COMPARE CHARS
	TAD	TEMP2
	SZA CLA
	JMP	IFLUP1	/NOT THIS OOE
GOTREL,	JMS I	QEXPR	/GET RIGHT HALF
	JMP I	QREMARK
	CLA CMA		/GET TYPE OF RIGHT SIDE
	TAD	OSTACK
	DCA	TEMP
	TAD I	TEMP
	SPA CLA
	JMP	STRCMP	/STRING, DO STRING COMPARE
	TAD	(MINUS	/NUMERIC, DO A SUBTRACT
	JMS I	QOUTOPR
NUMCMP,	JMS I	QSAVECP	/SAVE CHAR POSITION
	JMS I	QCHKWD	/LOOK FOR "THEN"
	WTHEN
	JMP	NOTHEN	/NOT THEN
GETIFN,	JMS I	QSNUM	/GET STATEMENT NUMBER
	JMP	BADGO2
	TAD	TEMP	/OUTPUT JUMP
	TAD	RELOPR
	JMS I	QOUTWRD
	TAD	TEMP2	/TWO WORDS
	JMS I	QOUTWRD
	JMP I	QNEWLIN
NOTHEN,	JMS I	QRESTCP	/BACKUP CHAR POS
	JMS I	QCHKWD	/LOOK FOR "GOTO"
	WGOTO
	SKP
	JMP	GETIFN	/OK, GO GET STMT NUMBER
BADIF,	JMS I	QERMSG	/BAD IF STMT
	1106
	JMP I	QREMARK
STRCMP,	TAD	(SCOMPR-1
	JMS I	QOUTOPR	/OUTPUT STRING COMPARE
	JMS I	QMODSET	/BACK TO N MODE
	JMP	NUMCMP	/REST IS LIKE NUMERIC COMPARES
	JMS I	QBACK1	/PUT BACK NON OPERATOR
IFLUP2,	TAD I	X10	/GET CONDITIONAL JUMP
	SNA
	JMP	BADIF	/RELATIONAL INCORRECT
	DCA	RELOPR
	TAD I	X10	/COMPARE OPERATORS
	TAD	TEMP
	SNA CLA
	JMP	GOTREL	/GOTIT
	JMP	IFLUP2
IFEND,	JMS I	QLODSN	/OUTPUT STMT NUMBER
	CLA IAC		/(NO COLON)
	JMS	GETFN	/GET FILE NUMBER
	TAD	(JEOF	/SETUP CORRECT JUMP
	DCA	RELOPR
	JMP	NUMCMP	/GO FIND "THEN" OR "GOTO"
RELOPR,
GETFN,	0		/GET FILE NUMBER
	DCA	COLON	/SAVE COLON SWITCH
	JMS I	QCHECKC	/LOOK FOR #
	-43
	JMP	TTYFIL	/NONE, MUST BE TTY
	JMS I	QEXPR	/GET FILE EXPR
	JMP I	QREMARK	/ERROR
	TAD	COLON	/DO WE NEED A COLON ?
	SZA CLA
	JMP	.+4	/NO, SKIP THIS TEST
	JMS I	QCHECKC	/YES, LOOK FOR IT
	-72
	JMP	BADFN	/NOT THERE, BAD
	JMS I	QLOAD	/LOAD IT
	TAD	TYPE1	/TYPE MUST BE NUMERIC
	SPA CLA
BADFN,	JMS I	QERMSG	/NOPE, IT ISN'T
	0616
	CLA IAC		/SET IFNREG TO "NOT TTY"
	DCA	IFNREG	/SAVE NEW IFNREG
	TAD	(FILENO	/OUTPUT SET IFN COMMAND
	JMS I	QOUTWRD
	JMP I	GETFN
TTYFIL,	TAD	IFNREG	/IS IFNREG 0 ?
	SNA CLA
	JMP I	GETFN	/IF YES, QUIT
	TAD	(CLRFN	/OTHERWISE ZERO AC
	JMS I	QOUTWRD
	DCA	IFNREG	/SET IFNREG TO TTY
	JMP I	GETFN	/RETURN
\f/ GOTO AND GOSUB
GOTO,	JMS I	QSNUM	/GET NUMBER
	JMP	BADGO2
	JMS I	QMODSET	/ALL GOTO'S IN NMODE
	CLA IAC		/JUMP=JSUB+1
	JMP	.+5
GOSUB,	JMS I	QLODSN	/OUTPUT STMT NUM LOAD
	JMS I	QSNUM	/GET NUMBER
	JMP	BADGO2
	JMS I	QMODSET	/ALL GOTO'S IN NMODE
	TAD	(JSUB	/GET GOSUB OPCODE
	TAD	TEMP	/PLUS ADDRESS
	JMS I	QOUTWRD	/OUTPUT IT
	TAD	TEMP2	/BOTH WORDS
	JMS I	QOUTWRD
	JMP I	QNEWLIN
BADGO2,	JMS I	QERMSG	/BAD GOTO OR GOSUB
	1615		/NUMBER MISSING
	JMP I	QREMARK
\f/ TABLE SEARCH FOR LITERALS, STMT NUMBERS, TEMPS, ETC.
	PAGE
LUKUP2,	0
	TAD I	LUKUP2	/GET THE BUCKET START
	DCA	OLDN3	/SAVE IT AS THE PREVIOUS ENTRY
	ISZ	LUKUP2
	TAD I	LUKUP2	/GET THE ENTRY SIZE
	ISZ	LUKUP2
	DCA	N3SIZE
	TAD	(6211	/PRIME THE FIELD SETTER
	DCA	LUFLD
	JMS	SETFLD	/NOW SET THE FIELD
LOOK2,	TAD I	OLDN3	/GET ADDR OF NEXT ENTRY
	DCA	NEWN3	/SAVE IT
PATCH1,	ISZ	OLDN3	/GET TO FIELD OF NEW ENTRY
	TAD I	OLDN3	/GET INTO AC
	DCA	NEWFLD	/AND SAVE IT
	TAD	NEWN3
	SNA
	JMP	HOOKIN	/IF 0 ITS END OF LIST
PATCH5,	IAC
	DCA	X10	/START OF VALUE INFO
	TAD	(WORD1-1/SETUP POINTER TO VALUE
	DCA	X11
	TAD	N3SIZE	/AND TEMP OF ENTRY SIZE
	DCA	LTEMP
CHKVAL,	CDF
	TAD I	X11
	CIA CLL		/COMPARE THIS WORD
NEWFLD,	CDF	10	/FIELD OF NEW ENTRY
	TAD I	X10
	SZA CLA
	JMP	NOTSAM	/NOT THIS ONE
	ISZ	LTEMP	/INCR SIZE COUNT
	JMP	CHKVAL	/MORE STUFF
	TAD I	X10	/GET SYMBOL NUMBER
L6201,	CDF
	DCA	SYMBOL
	TAD	NEWFLD	/MAKE ENTRY ADDRESSABLE
	DCA	LUFLD	/THROUGH SETFLD
	ISZ	LUKUP2	/BUMP RETURN
	JMP I	LUKUP2
NOTSAM,	SZL
	JMP	HOOKIN	/NEW SYMBOL < CURRENT
	TAD	NEWN3	/GO TO NEXT ENTRY
	DCA	OLDN3	/(MOVE POINTER)
	TAD	NEWFLD	/(AND FIELD)
	DCA	LUFLD
	JMP	LOOK2
HOOKIN,	CLL CMA RAL	/HOW MANY WORDS NEEDED ?
	TAD	N3SIZE
	TAD	(EOST
	DCA	.+2
	JMS	STCHEK	/MAKE SURE
	0		/WE GOT ENOUGH
	TAD	NEWN3	/HOOK IN NEW ENTRY
FREFLD,	CDF	10	/CHANGE TO FREE FIELD
	DCA I	NEXT
PATCH2,	TAD	NEWFLD	/HOOK IN FIELD
	DCA I	NEXT
	JMS	SETFLD	/BACK TO FIELD OF OLD
	TAD	FREFLD	/PUT FIELD OF NEW
	DCA I	OLDN3
	CLA CMA		/BACK UP OLDN3
	TAD	OLDN3	/SO THAT IT POINTS TO POINTER
	DCA	OLDN3
	CLA CMA
	TAD	NEXT	/PUT POINTER TO NEW ENTRY
	DCA I	OLDN3	/INTO OLD
	TAD	FREFLD	/SAVE ENTRY FIELD
	DCA	LUFLD	/FOR POSSIBLE POST PROCESSING
	TAD	(WORD1-1/PREPARE TO STICK IN THE VALUE
	DCA	X11
ENTERV,	CDF
	TAD I	X11	/MOVE IN THE VALUE
FFLD2,	CDF	10
	DCA I	NEXT
	ISZ	N3SIZE	/INCR SIZE COUNT
	JMP	ENTERV
	CDF
	JMP I	LUKUP2
STCHEK,	0		/CHECK FOR ENOUGH ROOM
	TAD	NEXT	/CHECK FOR OVERFLOW
	CIA CLL
	CDF
	TAD I	STCHEK	/THIS IS LIMIT
	ISZ	STCHEK
	SZL CLA
	JMP I	STCHEK
	TAD	FREFLD	/BUMP FREE FIELD
	TAD	(10
	DCA	FREFLD
	TAD	FREFLD	/PUT IN TWO PLACES
	DCA	FFLD2
	DCA	NEXT	/START POINTER AT 0
	ISZ	NFLDS	/GONE TOO FAR ?
	JMP I	STCHEK	/NO
STOVER,	JMS I	QERMSG	/S.T. FULL
	2324
	JMP I	XABORT	/ABORT COMPILATION
OLDN3,	0		/ADDR OF PREVIOUS ENTRY
NEWN3,	0		/ADDR OF NEW ENTRY
LTEMP,	0
NFLDS,	0		/- COUNT OF AVAILABLE FIELDS
N3SIZE,			/SIZE OF ENTRY
KBDCHK,	0		/CHECK FOR ^C OR ^O
	KSF
	JMP I	KBDCHK	/NO CHAR
	KRB
	AND	(177	/REMOVE PARITY BIT
	TAD	(-3	/^C ??
	SNA
	JMP I	XABORT	/YES, EXIT TO OS8
	TAD	(3-17	/^O ??
	SZA CLA
	JMP I	KBDCHK	/NO, RETURN
	DCA	TTX+1	/NOP TTY OUTPUT ROUTINE
	JMP I	KBDCHK
/
WSTEP,	-123;-124;-105;-120;0
\f/ SYMBOL TABLE LOOKUP
	PAGE
LOOKUP,	0		/LOOK UP SYMBOL
	TAD	NAME1	/GET NAME1*11+NAME2
	CLL RTL
	TAD	NAME1
	CLL RAL
	TAD	NAME1
	TAD	NAME2
	DCA	NAME1	/THIS IS IT
	TAD	TYPE	/WHAT KIND SYMBOL ?
	CLL RTL		/MOVE TYPE BITS
	RTL		/INTO AC 9,10,11
	TAD	JTABLE
	DCA	.+1
VCPTR,	0		/GO THERE
JTABLE,	JMP I	.+1
	LUVAR
	LURETN
	LUARAY
	LURETN
	LUSTRG
	LURETN
	LUSARY
	LURETN
LUVAR,	TAD	(VARCNT	/POINTER TO VAR COUNT
	DCA	VCPTR
	TAD	(VARST-13
DOLU,	TAD	NAME1
	DCA	STPTR	/ST POINTER
	CDF	10	/THATS WHERE ST IS
	TAD I	STPTR	/IS THIS VAR DEFINED YET ?
	SMA
	JMP	GOTSYM	/YES
	TAD	(4401	/GET 401 INTO AC
CHEKST,	CDF
	TAD I	VCPTR	/PLUS VAR COUNT
	CDF	10
	DCA	SYMBOL	/THATS THE NEW SYMBOL NUMBER
	TAD	SYMBOL	/PUT SYMBOL NUMBER
	DCA I	STPTR	/INTO S.T. ENTRY
	CDF
	ISZ I	VCPTR	/BUMP SYMBOL NUMBER
LURETN,	JMP I	LOOKUP
	JMP	STOVER	/S.T. OVERFLOW
GOTSYM,	DCA	SYMBOL	/PUT NUMBER INTO SYMBOL
	CDF
	JMP I	LOOKUP
LUSTRG,	TAD	(SVCNT	/POINTER TO STRING VAR COUNT
	DCA	VCPTR
	TAD	(SVARST-26
	TAD	NAME1	/TWO WORDS PER ENTRY
	JMP	DOLU
LUARAY,	TAD	(ACNT	/ARRAY VAR COUNT
	DCA	VCPTR
	TAD	(ARAYST	/ARRAY SYMBOL TABLE
	DCA	STPTR
	CDF	10
FINDA,	TAD I	STPTR	/SEARCH TABLE
	SNA
	JMP	NEWARY	/NEW ENTRY
	CIA
	TAD	NAME1	/IS THIS IT ?
	ISZ	STPTR
	SNA CLA
	JMP	GOTARY	/YES
	ISZ	STPTR
	ISZ	STPTR
	ISZ	STPTR	/GO TO NEXT ENTRY
	JMP	FINDA
GOTARY,	TAD	(37	/GET NUMBER
	AND I	STPTR
	DCA	SYMBOL	/INTO SYMBOL
	CDF
	JMP I	LOOKUP
NEWARY,	TAD	NAME1	/PUT IN NEW ENTRY
	DCA I	STPTR
	ISZ	STPTR
	TAD	(41	/PUT IN NUMBER
	JMP	CHEKST	/GO DO THE REST
LUSARY,	TAD	(SACNT	/STRING ARRAY COUNT
	DCA	VCPTR
	TAD	(SARYST	/USE STRING ARRAY TABLE
	JMP	FINDA-2	/GO DO SEARCH
\f/ FILE AND CLOSE PROCESSORS
FILE,	JMS I	QLODSN	/OUTPUT STMT NUMBER
	TAD	(FOPENS	/POINTER TO FILE OPENS
	DCA	FILESW
	JMS I	QCHECKC	/LOOK FOR "V"
	-126
	SKP		/NOT V
	ISZ	FILESW	/YUP, INCR FILESW
	JMS I	QCHECKC	/LOOK FOR "N"
	-116
	JMP	.+3
	ISZ	FILESW	/INCR FILESW BY TWO IF "N"
	ISZ	FILESW
	JMS	GETFN	/GET FILE NUMBER
	JMS I	QEXPR	/GET DEVICE/FILE DESCRIPTOR
	JMP I	QREMARK
	JMS I	QLOAD	/LOAD INTO SAC
	TAD	TYPE1	/TYPE MUST BE STRING
	SPA CLA
	JMP	.+3	/IT WERE
	JMS I	QERMSG	/IT WEREN'T
	0616
	TAD I	FILESW	/GET CORRECT OPEN
	JMS I	QOUTWRD
	JMP I	QNEWLIN
FOPENS,	OPENAF;OPENAV;OPENNF;OPENNV
FILESW,	0
PLUS,	40;0;XADD;XADD
\f/ EXPRESSION ANALYZER
	PAGE
EXPR,	0		/POLISHIZE EXPRESSION
	DCA	TEMP	/SAVE LEFT
	TAD	LEFT	/SO WE CAN PUSH OLD VALUE
	JMS I	QPUSH	/OF IT
	TAD	TEMP	/NOW SET NEW VALUE
	DCA	LEFT	/OF THAT SWITCH
	TAD	EXPR
	JMS I	QPUSH	/SAVE RETURN ADDR
	JMS I	QPUSH	/MARK STACK
	TAD	LEFT	/IS THIS LEFT SIDE ?
	SPA CLA
	JMP	OPRAND+1/YES, NO UNARY MINUS
UNOPR,	JMS I	QGETC	/LOOK FOR UNARY OPERATOR
	JMP	MISARG	/THERE HAS TO BE AN OPERAND
	TAD	(-53	/UNARY+(NOP)
	SNA
	JMP	UNOPR
	TAD	(53-55	/UNARY -
	SZA
	JMP	NOTMIN	/NOT UNARY MINUS
	TAD	(UMOPR	/PUSH UNARY MINUS
	JMS I	QPUSH
	JMP	UNOPR
NOTMIN,	TAD	(55-50	/LOOK FOR (
	SZA CLA
	JMP	OPRAND	/NOT A SUB EXPRESSION
	JMS I	QEXPR	/COMPILE SUB EXPRESSION
	JMP	BADEXP	/BAD SUB EXPRESSION
	JMS I	QCHECKC	/LOOK FOR )
	-51
	SKP		/ERROR
	JMP	OPR8R	/GOTIT
	JMS I	QERMSG	/PARENTHESIS MIS MATCH
	1520
	JMP	BADEXP
OPRAND,	JMS I	QBACK1	/PUT BACK NON UNARY OP
	JMS I	QGETNAM	/LOOK FOR VARIABLE REF
	JMP	NOTVAR	/NOPE.
	JMS I	QLOOKUP	/SYMBOL TABLE SEARCH
	TAD	SYMBOL	/SAVE SYMBOL NUMBER
	DCA	TEMP2	/BECAUSE SAVAC MIGHT KILL IT
	JMS I	QSAVAC	/GENERATE FSTA (MAYBE)
	-3
	TAD	TYPE	/WAS THIS A FUNCTION OR ARRAY ?
	AND	(3000
	SZA
	JMP	FUNSS	/YES, GO PROCESS IT
	TAD	TYPE	/MAKE OPERAND STACK ENTRY
	JMS I	QPUSHO
	TAD	TEMP2	/FIRST TYPE THEN SYMBOL #
	JMS I	QPUSHO
OPR8R,	TAD	LEFT	/LEFT SIDE ?
	SMA CLA		/YES, NO OPERATORS LEGAL
	JMS I	QGETC	/LOOK FOR OPERATOR
	JMP	ENDEXP	/END OF EXPR
	TAD	(-52	/** IS SPECIAL CASE
	SZA
	JMP	NOSTAR	/NOT *
	JMS I	QGETC	/LOOK FOR SECOND *
	JMP	NOSTAR
	TAD	(-52
	SNA CLA
	TAD	(136-52	/** -> ^
	SNA
	JMS I	QBACK1	/PUT IT BACK
NOSTAR,	TAD	(52	/RESTORE CHAR
	DCA	TEMP
	TAD	(OPR8RS-1
	DCA	X10	/PTR TO LIST
OPRLUP,	TAD I	X10	/GET OPERATOR PTR
	SNA
	JMP	ENDEXP-3/END OF LIST
	DCA	NEWOP	/SAVE IT IN CASE
	TAD I	X10	/COMPARE
	TAD	TEMP
	SZA CLA
	JMP	OPRLUP	/KEEP LOOKING
GOTOPR,	JMS I	QPOP	/GET STACK TOP
	SNA
	JMP	PUSH2	/EMPTY
	DCA	OLDOP
	TAD I	OLDOP	/COMPARE PREC.
	CIA
	TAD I	NEWOP	/NEW-OLD
	SPA SNA	CLA
	JMP	OUTOLD	/OLD>NEW
	TAD	OLDOP
PUSH2,	JMS I	QPUSH	/OLD < NEW
	TAD	NEWOP	/GO PUSH BOTH
	JMS I	QPUSH
	JMP	UNOPR	/GO LOOK FOR NEXT OPERAND
OUTOLD,	TAD	OLDOP	/OUTPUT CODE FOR OLD OPR8R
	JMS I	QOUTOPR
	JMP	GOTOPR	/LOOK AT NEXT TOP OF STACK
	JMS I	QBACK1	/PUT BACK NON OPERATOR
	SKP
	JMS I	QOUTOPR	/OUTPUT OPERATOR
ENDEXP,	JMS I	QPOP	/LOOK FOR STACK MARK
	SZA
	JMP	ENDEXP-1/NOT THIS
	JMS I	QPOP	/GET RETURN ADDR
	IAC
	DCA	TEMP
	JMS I	QPOP	/GET LEFT SIDE SWITCH
	DCA	LEFT
	JMP I	TEMP	/RETURN
MISARG,	JMS I	QERMSG	/MISSING OPERAND
	1517
	JMP	BADEXP
MINUS,	40;0;XISUB;XSUB
SLASH,	50;0;XIDIV;XDIV
\f/ EXPRESSION ANALYZER (HANDLE SUBSCRIPTS)
	PAGE
FUNSS,	AND	(1000	/IS IT FUN CALL ?
	SNA CLA
	JMP	.+3	/NO
	JMS I	QSAVAC	/YES, SAVE AC
	-1
	TAD	TYPE	/SAVE TYPE
	JMS I	QPUSH
	TAD	TEMP2	/AND SYMBOL NUMBER
	JMS I	QPUSH
	TAD	STPTR	/AND SYMBOL TABLE PTR
	JMS I	QPUSH
	SKP
SSLOOP,	JMS I	QPOP	/GET ARG/SS COUNT
	IAC
	JMS I	QPUSH	/INCREMENT IT
	JMS I	QEXPR	/GET NEXT ARG/SS
	JMP	BADFSS
	JMS I	QGETA1	/IS THIS ARG(SS) AN ARRAY REF ?
	CLL CML RTR
	AND	TYPE1	/CHECK THE TYPE
	SNA CLA
	JMP	NOTSSD	/NOT AN ARRAY REFERENCE
	JMS I	QLOADSS	/LOAD THE SS REGS
	JMS I	QSAVAC	/SAVE AC IF NEEDED
	-1
	TAD	TYPE1	/SET THE MODE
	JMS I	QMODSET
	TAD	(AFLDA	/LOAD THIS ARG/SS
	TAD	SYMBL1
	JMS I	QOUTWRD
	TAD	Q400	/SET THE IN-AC BIT
	TAD	MODE	/WE JUST CALLED MODSET
	DCA I	OSTACK	/CHANGE THIS STACK ENTRY
	SKP
NOTSSD,	ISZ	OSTACK	/FIX UP OSTACK
	ISZ	OSTACK
	JMS I	QCOMARP	/LOOK FOR , OR )
	JMP	BADFSS	/NEITHER IS BAD
	JMP	SSLOOP	/, MEANS MORE ARGS/SS
	JMS I	QPOP	/GET # OF ARG/SS
	DCA	TEMP	/GET ARG/SS COUNT
	JMS I	QPOP	/RESTORE S.T. ADDR
	DCA	STPTR
	JMS I	QPOP
	DCA	SYMBOL	/GET BACK THE SYMBOL #
	JMS I	QPOP
	DCA	TYPE	/GET BACK THE TYPE
	TAD	TYPE	/IS IT AN ARRAY OR FUN REF ?
	AND	(1000
	SZA CLA
	JMP	DOCALL	/FUNCTION REFERENCE
	TAD	TEMP	/MOVE SS COUNT
	CLL RTR		/INTO THE CORRECT
	RTR		/FIELD
	DCA	TEMP2	/AND SAVE IT
	CDF	10
	TAD I	STPTR	/ANY PREV REFERENCE ?
	AND	(3000
	SZA
	JMP	NOTNEW	/YES, GO CHECK NUMBERS
	TAD	TEMP2	/IF NONE, PUT IN NUMBER
	TAD I	STPTR
	DCA I	STPTR
	JMP	NDOK	/THATS ALL
NOTNEW,	CIA		/COMPARE NUMBER OF SS
	TAD	TEMP2	/WITH ANY PREVIOUS
	SZA CLA
	JMP	BADFSS+3/THEY DON'T MATCH
NDOK,	CDF
	TAD	TYPE	/PUT TYPE
	TAD	TEMP	/AND DIM COUNT
ONSTAK,	JMS I	QPUSHO	/ONTO ARGUMENT STACK
	TAD	SYMBOL
	JMS I	QPUSHO	/AND SYMBOL NUMBER
	JMS I	QSAVAC	/SAVE FIRST SS IF LEFT IN AC
	-5
	JMP	OPR8R	/GO GET AN OPERATOR
BADFSS,	TAD	(-4	/PURGE STACK JUNK
	TAD	STACK
	DCA	STACK
	JMS I	QERMSG	/PUT ERROR MESSAGE
	2323
BADEXP,	JMS I	QPOP	/LOOK FOR STACK MARK
	SZA CLA
	JMP	BADEXP	/NOT YET
	JMS I	QPOP	/RETURN ADDR
	DCA	TEMP
	JMS I	QPOP	/SS LOAD SWITCH
	DCA	LEFT
	JMP I	TEMP	/TAKE ERROR EXIT
WTAB,	-124;-101;-102;-50
NOTVAR,	TAD	LEFT	/LEFT SIDE ?
	SPA CLA
	JMP	MISARG	/YES, NO LITERALS LEGAL
	JMS I	QNUMBER	/LOOK FOR LITERAL
	JMP	NOTNUM	/NOT A NUMBER
	JMS I	QLUKUP2	/SEARCH LITERAL TABLE
	LITRL
	-3
	JMS	NEWVAR	/IF NEW, GIVE IT NUMBER
	JMP	ONSTAK	/GO PUT IT ONTO THE STACK
NOTNUM,	JMS I	QSTRING	/LOOK FOR STRING LITERAL
	JMP	MISARG	/NO, MISSING ARG
	TAD	WORD1	/GET -NUMBER WORDS - 1
	IAC
	CLL CML CMA RAR
	DCA	.+3	/FOR LOOKUP
	JMS I	QLUKUP2	/LOOK UP LITERAL
	SLITRL
	0
	JMS	NWSVAR	/IF NEW, GIVE IT NUMBER
	CLL CML RAR	/SET TYPE BIT FOR STRING
	JMP	ONSTAK	/PUT INFO ONTO STACK

UPAROW,	60;1;EXPRTN-1
\f/ EXPRESSION ANALYZER (HANDLE FUNCTION CALLS)
	PAGE
DOCALL,	TAD	LEFT	/IS THIS LEFT SIDE ?
	SMA CLA		/IF YES, FUN ILLEGAL
	JMS	OUTCAL	/GENERATE CALL
	SKP		/SKIP IF ERROR
	JMP	OPR8R	/GO LOOK FOR OPERATOR
	JMS I	QERMSG	/BAD FUNCTION REFERENCE
	0622
	JMP	BADEXP
OUTCAL,	0		/GENERATE FUN CALL; TYPE,
			/SYMBOL AND TEMP ARE INPUTS
	TAD	SYMBOL	/SAVE FUNCTION NUMBER AROUND SAVAC
	DCA	FUNNUM
	JMS I	QSAVAC	/SAVE SECOND FROM TOP
	-3
	TAD	FUNNUM	/SETUP FOR FINDING FUNCTION
	DCA	WORD1	/INFO BLOCK
	JMS I	QLUKUP2	/ON THE FUNCTION LIST
	FUNCTN
	-1
	JMP I	OUTCAL	/UNDEFINED FUNCTION
	TAD	SYMBOL	/CHECK NUMBER OF ARGS
	TAD	TEMP
	SZA CLA
	JMP I	OUTCAL
MOVARG,	JMS I	QLOAD	/GET TOP OF STACK INTO AC
	JMS	SETFLD	/GET FIELD OF FORMAL-PARAMS
	TAD I	X10	/GET FIRST ONE
	CDF
	DCA	TEMP
	CLL CML RAR	/COMPARE TYPE OF ARG
	AND	TYPE1	/WITH THAT OF FORMAL PARAMETER
	TAD	TEMP
	SPA CLA		/THEY MUST MATCH
	JMP I	OUTCAL	/(THEY DON'T)
	CLL CML RTR	/SHOULD WE LEAVE IT IN THE AC ?
	AND	TEMP
	SZA CLA
	JMP	OKINAC	/YES, SAVES AN INSTRUCTION
	TAD	TYPE1	/SET MODE
	JMS I	QMODSET	/APPROPRIATELY
	CLL CMA RAR	/3777
	AND	TEMP	/GET SYM NUMBER
	TAD	(FSTA	/STORE VALUE IN FORM PARAM
	JMS I	QOUTWRD
OKINAC,	ISZ	SYMBOL	/MORE ARGS ?
	JMP	MOVARG
	JMS	SETFLD
	TAD I	X10	/GET TYPE OF FUNCTION
	DCA	TYPE1	/(ITS RESULT THAT IS)
	CDF
	TAD	TYPE	/IS TYPE OF FUNCTION
	TAD	TYPE1	/SAME AS TYPE OF CALL
	SPA CLA
	JMP I	OUTCAL	/NO, ERROR
	JMS I	QMODSET	/ALL CALLS IN N MODE
	TAD	WORD1	/CHECK FOR USER FUNCTION
	SMA
	JMP	CALLUF	/YES, DO SPECIAL CALL
FINCAL,	ISZ	OUTCAL	/FIX RETURN
	JMS I	QOUTWRD	/OUTPUT CODE
	TAD	Q400	/SET TOP OF STACK
	TAD	TYPE1
	DCA I	OSTACK	/TO AC
	DCA I	OSTACK	/SYMBOL NUMBER IS MEANINGLESS
	CLL CML RAR
	AND	TYPE1	/INTERPRETER MODE SAME
	DCA	MODE	/AS FUNCTION TYPE
	JMP I	OUTCAL	/ON RETURN
CALLUF,	JMS I	QNOREGS	/FORGET REGS ON USER FUNC
	TAD	LUFLD	/OUTPUT JSUB
	AND	(70	/WITH POINTER TO
	CLL RTL		/DOUBLE WORD
	TAD	(JSUB	/VALUE OF LOCATION
	JMS I	QOUTWRD	/COUNTER FOR THE
	TAD	X10	/START OF THE
	IAC		/USER "DEF"INED FUNC
	JMP	FINCAL
FSUB1,	0		/FOR SUBROUTINE #1
	JMS I	QEXPR	/GET AN EXPRESSION
	JMP	BADFOR
	JMS I	QLOAD	/LOAD VALUE
	TAD	TYPE1	/MUST BE NUMERIC
	SMA CLA
	JMP I	FSUB1	/OK
BADFOR,	JMS I	QERMSG	/BAD FOR LOOP PARAMETERS
	0620
	JMP I	QREMARK
FSUB2,	0		/FOR SUBROUTINE #2
	JMS	FSUB1	/GET EXPR AND LOAD IT
	JMS	GENTMP	/MAKE A TEMP FOR IT
	TAD	SYMBOL	/STORE EXPR IN TEMP
	TAD	(FSTA
	JMS I	QOUTWRD
	TAD	SYMBOL	/RETURN SLOT #
	JMP I	FSUB2
FUNNUM,
NOREGS,	0		/FORGET REGISTORS
	CLA IAC		/FILE NUMBER REG
	DCA	IFNREG
/	CMA		/SUBSCRIPT REG #1
/	DCA	SSREG1
/	CMA		/SUBSCRIPT REG #2
/	DCA	SSREG2
	JMP I	NOREGS
CLOSE,	JMS I	QLODSN	/OUTPUT STMT NUMBER
	CLA IAC		/NO COLON NEEDED AFTER FILE NUM
	JMS	GETFN	/GET FILE NUM
	TAD	(CLOSEF	/OUTPUT CLOSE
	JMS I	QOUTWRD
	JMP I	QNEWLIN
PSETJF,	0
	TAD	(SETJF
	JMS I	QOUTWRD
	JMS I	QPOP	/GET INDEX VAR
	DCA	FINDEX
	JMP I	PSETJF
DIMREAD,JMS I	QLOADSS	/PATCH TO INPUT PROC. SET UP SS REG
	TAD	(READ	/OUTPUT INSTR
	JMS I	QOUTWRD
	TAD	(AFSTA
	JMP I	(FININP	/RESUME IN LINE
\f/ CODE GENERATOR
	PAGE
OUTOPR,	0		/OUTPUT CODE FOR OPERATOR
	DCA	X10	/SAVE POINTER TO SKELETON
	TAD I	X10	/GET CONTROL WORD
	SMA SZA
	JMP	SPCIAL	/TREAT AS SPECIAL CASE
	DCA	TYPE	/ITS THE TYPE ALLOWANCE
	TAD	(XLOAD	/GET SKEL ADDRS
	DCA	CASEMM	/FOR THE THREE CASES
	TAD I	X10
	DCA	CASEMA
	TAD I	X10
	DCA	CASEAM
	TAD	TYPE	/ENTER CORRECT MODE
	JMS I	QMODSET
	CLL CMA RAL	/GET THE SECOND OPERAND
	TAD	OSTACK
	DCA	OSTACK
	TAD	OSTACK
	DCA	X10	/BY BACKING UP THE STACK
	TAD I	X10	/TYPE
	DCA	TYPE2
	TAD I	X10
	DCA	SYMBL2	/SYMBOL NUMBER
	TAD	TYPE2
	AND	(3
	DCA	TEMP	/SS COUNT
	TAD	TYPE2	/LOOK AT OPERAND 2
	AND	Q400
	SZA CLA
	JMP	MAC	/MUST BE CASE M,AC
	CLL CML RTR	/ITS IN MEMORY, IS IT SS'D
	AND	TYPE2
	SNA CLA
	JMP	A2OK	/NO, ITS SCALAR
	JMS I	QLOADSS	/LOAD NECESSARY SS REGS
	ISZ	CASEMM	/FIXUP THE SKELETON POINTERS
	ISZ	CASEAM
A2OK,	JMS	GETA1	/GET STUF FOR ARG1
	TAD	TYPE1	/LOOK AT IT
	AND	Q400
	SZA CLA
	JMP	ACM	/ITS CASE AC,M
MM,	TAD I	CASEMM	/ITS CASE M,M  LOAD OPERAND 2
	TAD	SYMBL2
	JMS I	QOUTWRD
	SKP
MAC,	JMS	GETA1	/GET STUF FRO ARG1
	CLL CML RTR	/IS IT SS'D ?
	AND	TYPE1
	SNA CLA
	JMP	A1OK	/NO, ITS SCALAR
	JMS I	QLOADSS	/LOAD THE SS REGS
	ISZ	CASEMA	/BUMP SKELETON ADDR
A1OK,	TAD I	CASEMA	/GET CORRECT INSTRUCTION
	TAD	SYMBL1	/PLUS SYMBOL NUMBER
TYPCHK,	JMS I	QOUTWRD	/OUTPUT IT
	CLL CML RAR	/TYPES OF OPERANDS MUST MATCH
	AND	TYPE1
	TAD	TYPE2
	SPA CLA
	JMP	MIXED	/THEY DON'T
	TAD	TYPE	/TYPE OF OPERATOR
	TAD	TYPE1	/MUST MATCH
	SPA CLA		/THAT OF OPERANDS
	JMP	MIXED	/THEY DON'T
	TAD	Q400	/GENERATE STACK ENTRY
	TAD	TYPE
	DCA I	OSTACK
	DCA I	OSTACK	/THIS IS SAFE
	JMP I	OUTOPR
ACM,	TAD I	CASEAM	/ITS CASE AC,M
	TAD	SYMBL2	/GEN OPERATION FOR OPERAND 2
	JMP	TYPCHK	/GO FINISH IT UP
MIXED,	JMS I	QERMSG	/MIXED TYPES
	1524
	JMP I	OUTOPR
SPCIAL,	TAD I	X10	/GET ADDR OF SPECIAL RTNE
	DCA	TEMP	/(PLUS 1 FROM THE TYPE WORD)
	JMP I	TEMP	/HANDLE SPECIAL CASE
GETA1,	0		/GET STUFF FOR ARG 1
	CLL CMA RAL	/BACK UP STACK
	TAD	OSTACK
	DCA	OSTACK
	TAD	OSTACK
	DCA	X11
	TAD I	X11	/GET TYPE1
	DCA	TYPE1
	TAD I	X11	/GET SYMBL1
	DCA	SYMBL1
	TAD	TYPE1	/GET SS COUNT
	AND	(3
	DCA	TEMP
	JMP I	GETA1
UMRTNE,	JMS I	QSAVAC	/SAVE CURRENT AC IF NEEDED
	-3
	JMS I	QLOAD	/GET ARG IN AC
	DCA	TYPE	/TYPE MUST BE NUMERIC
	DCA	TYPE2
	TAD	(FNEG	/DO NEGATE
	JMP	TYPCHK
EXPRTN,	DCA	TYPE	/SET FUNC TYPE
	CLL CML RTL	/SET NUMBER OF ARGS
	DCA	TEMP
	TAD	(FUNC1+60
	DCA	SYMBOL	/EXP2
	JMS	OUTCAL	/OUTPUT FUNCTION CALL
	JMP	MIXED	/ERROR
	JMP I	OUTOPR	/DONE
CASEMA,	0
CASEMM,	0
CASEAM,	0
TYPE2,	0
SYMBL2,	0
RETURN,	JMS I	QLODSN	/OUTPUT STMT NUM LOAD
	JMS I	QMODSET	/ALWAYS RETURN IN N MODE
	TAD	(RET-RNDO
RANDOM,	TAD	(RNDO-STOP
STOPX,	TAD	(STOP	/RETURN, RANDOMIZE, OR STOP
	JMS I	QOUTWRD
	JMP I	QNEWLIN
\f/ LETTER AND DIGIT SCANNERS
	PAGE
LETTER,	0		/SKIP ON LETTER
	JMS I	QGETC
	JMP I	LETTER	/NO LETTER
	TAD	(-133	/MUST BE .LT. 133
	SMA
	JMP	NOLETR
	TAD	(133-100/MUST BE .GT. 100
	SPA
	JMP	NOLETR
	AND	(77	/RESTORE 6 BITS
	ISZ	LETTER	/BUMP RETURN ADDR
	JMP I	LETTER
NOLETR,	JMS I	QBACK1	/PUT CHAR BACK
	JMP I	LETTER
DIGIT,	0		/SKIP ON DIGIT
	JMS I	QGETC
	JMP I	DIGIT	/NO DIGIT
	TAD	(-72	/MUST BE .LT. 72
O7100,	CLL		/(USED AS LITERAL BY "TTY")
	TAD	(72-60	/MUST BE .GE. 60
	SNL
	JMP	NODIGT	/NOPE
	ISZ	DIGIT	/RETURN DIGIT MINUS 60
	JMP I	DIGIT
NODIGT,	JMS I	QBACK1	/PUT IT BACK
	JMP I	DIGIT
\f/ STATEMENT NUMBER GETTER
SNUM,	0		/GET A STATEMENT NUMBER
	DCA	TEMP	/SAVE DEFINED SWITCH
	JMS I	QDIGIT	/GET FIRST DIGIT
	JMP I	SNUM	/NO STATEMENT NUMBER
	DCA	WORD2	/THIS WILL BE THE BUCKET
	TAD	WORD2
	CLL RAL		/TWO WORDS PER BUCKET
	TAD	(SNUMS
	DCA	BUCKET
	ISZ	SNUM	/OK, ITS A STMT NUMBER
	TAD	(-4	/FIVE DIGITS MAX
	DCA	TEMP2
	DCA	WORD1	/CLEAR TOP WORD
SNLOOP,	JMS I	QDIGIT	/GET NEXT DIGIT
	JMP	GOTSN	/END OF NUMBER
	DCA	WORD3	/SAVE IT
	TAD	(-4	/SET SHIFT COUNT
	DCA	ACO
SHIFT,	TAD	WORD2	/SHIFT LEFT ONE BIT
	CLL RAL
	DCA	WORD2
	TAD	WORD1
	RAL
	DCA	WORD1
	ISZ	ACO	/BUMP SHIFT COUNTER
	JMP	SHIFT
	TAD	WORD2	/PUT IN NEW DIGIT
	TAD	WORD3
	DCA	WORD2
	ISZ	TEMP2	/BUMP DIGIT COUNT
	JMP	SNLOOP
GOTSN,	JMS I	QLUKUP2	/FIND STMT NUMBER
BUCKET,	0
	-2
	JMP	NEWSN	/ITS A NEW STMT NUM
	CLL CML RAR	/CHECK FOR MULTIPLY DEFINED
	AND	SYMBOL
	AND	TEMP
	SZA CLA
	JMP	MDLABL	/YES, IT IS
	TAD	X10	/GET ADDR OF LABEL VALUE
	DCA	TEMP2
	JMS	SETFLD	/GET TO FIELD OF ENTRY
	TAD	TEMP	/OR IN THESE BITS
	TAD	SYMBOL
	DCA I	TEMP2
FINSN,	CDF
	TAD	LUFLD	/GET FIELD BITS
	AND	(70
	CLL RTL
	DCA	TEMP	/INTO A CONVIENIENT
	JMP I	SNUM	/PLACE
NEWSN,	JMS	SETFLD	/GET FIELD
	TAD	TEMP	/PUT IN BITS
	DCA I	NEXT
	TAD	NEXT	/SAVE N3 ADDR
	DCA	TEMP2
	DCA I	NEXT	/1 EXTRA WORD
	JMP	FINSN
MDLABL,	JMS I	QERMSG	/MULTIPLY DEFINED
	1504		/LABEL
	JMP I	SNUM
TTY,	0		/CONVERT TO ASCII AND PRINT
	AND	(77	/SIX BITS ONLY
	TAD	(-40	/WHAT SIDE OF FORTY ?
	SPA
	TAD	O7100	/LOW SIDE
	TAD	(240	/HIGH SIDE
	JMS	TTX	/PRINT CHAR
	JMP I	TTY	/RETURN
TTX,	0		/PRINT CHAR ON TTY
	SKP		/(CONTROL O ZEROES THIS WORD)
	JMP	.+4	/(THUS KILLING ERROR REPORTING)
	TSF
	JMP	.-1
	TLS
	CLA
	JMP I	TTX
\f/ CHAIN PROCESSOR
CHAIN,	JMS I	QLODSN	/OUTPUT STMT NUMBER
	JMS I	QEXPR	/GET CHAIN STRING
	JMP I	QREMARK
	JMS I	QLOAD	/INTO SAC
	TAD	TYPE1	/TYPE MUST BE STRING
	SMA CLA
	JMS I	QERMSG	/IT WASN'T
	0616		/(OK IF ERROR CODE IS NOP)
	TAD	(CHN	/OUTPUT CHAIN OPCODE
	JMS I	QOUTWRD
	JMP I	QNEWLIN
XISUB,	FISUB;AISUB
\f/ SEVERAL SHORT UTILITY ROUTINES
	PAGE
BACK1,	0		/BACK UP ONE CHAR
	CLA CMA
	TAD	NCHARS
	DCA	NCHARS
	CLA CMA
	TAD	CHRPTR
	DCA	CHRPTR
	JMP I	BACK1
GETCWB,	0		/GET A CHARACTER (PRESERVE BLANKS)
	ISZ	NCHARS
	JMP	.+4
	CLA CMA
	DCA	NCHARS	/RESET NCHARS
	JMP I	GETCWB
	ISZ	GETCWB
	TAD I	CHRPTR	/GET THE CHAR
	JMP I	GETCWB
SAVECP,	0		/SAVE CHAR POSITION
	TAD	NCHARS
	DCA	NCSAVE
	TAD	CHRPTR
	DCA	CPSAVE
	JMP I	SAVECP
RESTCP,	0		/RESTORE CHAR POS
	TAD	CPSAVE
	DCA	CHRPTR
	TAD	NCSAVE
	DCA	NCHARS
	JMP I	RESTCP
GETC,	0		/GET A CHARACTER (IGNORING BLANKS)
	ISZ	NCHARS
	JMP	.+4
	CLA CMA
	DCA	NCHARS
	JMP I	GETC
	TAD I	CHRPTR
	TAD	(-40	/IS IT A BLANK
	SNA
	JMP	GETC+1	/YES IGNORE IT
	TAD	(40	/FIX CHAR
	ISZ	GETC
	JMP I	GETC
POP,	0		/GET TOP OF STACK
	TAD	STACK
	DCA	PUSH
	CLA CMA
	TAD	STACK
	DCA	STACK	/DECREMENT STACK POINTER
	TAD I	PUSH
	JMP I	POP
PUSH,	0		/PUT AC ONTO STACK
	DCA I	STACK	/STORE
	TAD	(-STACKA-STAKSZ+1
	TAD	STACK	/CHECK FOR OVERFLOW
	SPA CLA
	JMP I	PUSH	/OK, RETURN
STKOVR,	JMS I	QERMSG
	2004
	JMP I	XABORT	/ABORT COMPILATION
PUSHO,	0		/PUSH OPERAND STACK
	DCA I	OSTACK	/PUSHIT
	TAD	(-STACKO-STOKSZ+1
	TAD	OSTACK	/CHECK FOR STACK OVERFLOW
	SPA CLA
	JMP I	PUSHO
	JMP	STKOVR	/TOO FULL
COMARP,	0		/SKIP ON COMA OR RITE PAREN
	JMS I	QGETC	/GET CHAR
	JMP I	COMARP
	TAD	(-51
	SNA
	ISZ	COMARP	/RITE PAREN, SKIP 2
	SZA
	TAD	(51-54	/CHECK FOR ,
	SNA
	ISZ	COMARP	/, SKIP 1
	SZA CLA
	JMS I	QBACK1	/NEITHER PUT BACK
	JMP I	COMARP
LOAD,	0		/LOAD SAC OR FAC
	JMS I	QGETA1	/GET TOP OF STACK
	TAD	TYPE1	/SET MODE
	JMS I	QMODSET
	TAD	TYPE1	/IS IT IN THE AC?
	AND	Q400
	SZA CLA
	JMP I	LOAD	/YUP
	CLL CML RTR	/SUBSCRIPTED ?
	AND	TYPE1
	SNA CLA
	JMP	.+3	/NO
	JMS I	QLOADSS	/FILL SS REGS
	TAD	(AFLDA-FLDA
	TAD	(FLDA	/ARRAY OR SCALAR LOAD
	TAD	SYMBL1	/PLUS SYMBOL NUMBER
	JMS I	QOUTWRD
	JMP I	LOAD
IFOPS,	JNE;-7476	/<>
	JNE;-7674	/><
	JGE;-7576	/=>
	JGE;-7675	/>=
	JLE;-7574	/=<
	JLE;-7475	/<=
	0
	JEQ;-7500	/=
	JGT;-7600	/>
	JLT;-7400	/<
	0
NCSAVE,	0
CPSAVE,	0
\f/ TEMP GENERATORS AND AC SAVING ROUTINES
	PAGE
GENTMP,	0		/GENERATE A TEMP
	SZA CLA
	JMP	STRTMP	/ITS A STRING TEMP
	TAD	TMPCNT
	ISZ	TMPCNT	/BUMP COUNT
	DCA	NAME1
	JMS I	QLUKUP2	/LOOK UP THIS TEMP
	TEMPS
	-1
	JMS	NEWVAR	/NEW ONE ON ME
	JMP I	GENTMP
STRTMP,	TAD	STMPCT
	ISZ	STMPCT	/BUMP COUNT
	DCA	NAME1
	JMS I	QLUKUP2	/LOOK UP THIS TEMP
	STEMPS
	-1
	JMS	NWSVAR	/NEW STRING TEMP
	JMP I	GENTMP
NEWVAR,	0		/MAKE SYM NUM FOR VAR
	TAD	VARCNT	/PUT SYM NUM
	TAD	(401
	DCA	SYMBOL	/INTO SYMBOL
	TAD	SYMBOL	/AND INTO ST ENTRY
	JMS	SETFLD
	DCA I	NEXT
	CDF
	ISZ	VARCNT	/BUMP COUNT
	JMP I	NEWVAR	/RETURN WITH SYM NUM
	JMP	STOVER	/S.T. OVERFLOW
NWSVAR,	0		/MAKE SYM NUM FOR VAR$
	TAD	SVCNT	/PUT SYM NUM
	TAD	(401
	DCA	SYMBOL
	TAD	SYMBOL	/INTO SYMBOL AND
	JMS	SETFLD
	DCA I	NEXT	/S.T. ENTRY
	CDF
	ISZ	SVCNT	/OVERFLOW ?
	JMP I	NWSVAR	/NO, WE'RE OK
	JMP	STOVER
SAVAC,	0		/SAVE FAC (OR SAC) IF NECESSARY
	TAD I	SAVAC	/GET ENTRY POINTER
	TAD	OSTACK
	ISZ	SAVAC
	DCA	SVTEMP	/ADDR OF TYPE WORD
	TAD I	SVTEMP	/LOOK AT IT
	AND	Q400
	SNA CLA
	JMP I	SAVAC	/NOT IN AC
	CLL CML RAR	/SAVE STRING BIT ONLY
	AND I	SVTEMP	/OF TYPE WORD
	DCA I	SVTEMP
	TAD I	SVTEMP
	JMS	GENTMP	/GENERATE TEMP
	TAD I	SVTEMP
	JMS I	QMODSET	/SET MODE
	TAD	XSTOR
	TAD	SYMBOL	/GENERATE STORE
	JMS I	QOUTWRD
	TAD	SYMBOL	/RETURN S.T. NUMBER
	ISZ	SVTEMP	/MOVE TO SYMBOL NUM WORD
	DCA I	SVTEMP	/SAVE THE TEMP NUM THERE
	JMP I	SAVAC	/RETURN WITH SAVE MADE
SVTEMP,	0
XSTOR,	FSTA;AFSTA
\f/ SUBSCRIPT REGISTER LOADING ROUTINE
LOADSS,	0		/LOAD SS REGS
	CLL CMA RAL	/LOOK AT NUMBER OF SS
	TAD	TEMP
	SNA CLA
	JMP	LODSS2	/2 SS
	SNL
	JMP	TOOMNY	/MORE THAN 2
	JMS	SSLOAD	/LOAD SS REG 1
	JMP I	LOADSS
LODSS2,	CLA IAC
	JMS	SSLOAD	/LOAD SS REG 2
	JMS	SSLOAD	/NOW SS REG 1
	JMP I	LOADSS
SSTYPE,
TOOMNY,	JMS I	QERMSG	/SUBSCRIPTING ERROR
	2323
	JMP I	LOADSS
SSLOAD,	0		/LOAD A SS REG FROM TOP OF STACK
	DCA	TEMP2	/SS REG 1 OR 2 SWITCH
	CLL CMA RAL	/BACK UP ONE ENTRY
	TAD	OSTACK	/ON THE OPERAND STACK
	DCA	OSTACK
	TAD	OSTACK
	DCA	X11	/USE X11 TO GET STUFF
	TAD I	X11	/GET TYPE WORD
	SPA
	JMP	SSTYPE	/SS MUST BE A NUMBER
	AND	Q400	/GET AC BIT
	SZA CLA
	JMP	SSINAC	/ITS IN THE AC
	TAD	TEMP2
	SZA CLA
	TAD	(LSS2-LSS1
	TAD	(LSS1	/LOAD REG 1 OR 2 ??
	TAD I	X11	/ANYHOW, THIS IS THE SOURCE
	JMS I	QOUTWRD	/OUTPUT THE CODE
	JMP I	SSLOAD
SSINAC,	TAD	TEMP2
	TAD	(LSS1AC	/NOTE: LSS2AC=LSS1AC+1
	JMS I	QOUTWRD	/SO OUTPUT ONE OF THEM
	JMP I	SSLOAD
/
XSCOMP,	SCOMP;SACOMP
XDIV,	FDIV;AFDIV
/
PATCH6,	0
	ISZ	SIGDIG
	JMP I	PATCH6
	CMA
	DCA	SIGDIG
	JMP	CONVLP
/
STAR,	50;0;XMUL;XMUL
\f/ NUMERIC CONVERSION ROUTINE (PART ONE)
	PAGE
NUMBER,	0		/GENERAL NUMBER CONVERSION ROUTINE
	DCA	DECPT	/ZERO DECIMAL POINT SWITCH
	DCA	WORD1	/ZERO FAC
	DCA	WORD2
	DCA	WORD3
	DCA	ACO
	DCA	SIGN	/CLEAR SIGN SWITCH
	TAD	NUMDIG
	DCA	SIGDIG
	JMS I	QGETC	/GET A CHAR
	JMP I	NUMBER	/NO CHAR IS NO NUMBER
	JMS	CHKSGN	/CHECK FOR SIGN
SIGN,	0		/THIS SWITCH GETS SET
	DCA	NDIGIT	/ZERO DIGIT COUNT
CONVLP,	JMS I	QDIGIT	/GET A DIGIT
	JMP	TRYDEC	/IS THERE A DECIMAL POINT ?
	DCA	NXTDGT	/SAVE THE DIGIT
	JMS	PATCH6
	ISZ	NDIGIT	/INCR NUMBER OF DIGITS
	TAD	WORD2	/PREPARE TO MULT BY 10
	DCA	OP2
	TAD	WORD3
	DCA	OP3
	TAD	ACO
	DCA	OPO
	JMS I	(AL1	/DOUBLE FAC
	JMS I	(AL1	/DOUBLE AGAIN
	JMS I	(OADD	/TIMES FIVE
	JMS I	(AL1	/ONE MORE DOUBLING IS TIMES 10
	DCA	OP2
	DCA	OP3	/PUT NEWEST DIGIT INTO OPERAND
	TAD	NXTDGT
	DCA	OPO
	JMS I	(OADD	/ADD IN NEWEST DIGIT
	JMP	CONVLP
TRYDEC,	TAD	DECPT	/DECIMAL ALREADY ?
	SZA CLA
	JMP	TRYE2	/YES, LOOK FOR EXPONENT
	JMS I	QGETC	/LOOK FOR .
	JMP	DIGTST	/SEE IF THERE WAS ANYTHING
	TAD	(-56
	SZA CLA
	JMP	TRYE1	/TRY FOR E
	ISZ	DECPT	/SET DECIMAL POINT SW
	JMP	CONVLP-1/LOOP FOR OTHER DIGITS
TRYE1,	JMS I	QBACK1	/PUT BACK NON .
DIGTST,	TAD	NDIGIT	/ANY DIGITS YET ?
	SNA CLA
	JMP I	NUMBER	/NO, NO NUMBER
TRYE2,	JMS I	QGETC	/LOOK FOR E
	JMP	NOEXP+1	/GO HANDLE EXPONENT
	TAD	WSTEP+2	/USE PART OF "STEP" LITERAL
	SZA CLA
	JMP	NOEXP	/NO EXPONENT
GETEXP,	DCA	ESIGN	/ZERO EXPONENT SIGN SWITCH
	JMS I	QGETC	/GET A CHAR
	JMP	NOEXP	/TREAT AS NO EXPONENT
	JMS	CHKSGN	/IS IT A SIGN
FPRTNE,
ESIGN,	0		/THIS IS THE SWITCH TO SET
	JMS	SMLNUM	/GO GET THE EXPONENT
FIXEXP,	TAD	ESIGN	/CHECK EXPONENT SIGN
	SNA CLA
	JMP	NOEXP+2
	TAD	EXPON	/COMPLEMENT EXPONENT
	CIA
	SKP
NOEXP,	JMS I	QBACK1	/PUT BACK NON E
	DCA	EXPON	/ZERO EXPONENT
	TAD	(43	/NORMALIZE THE NUMBER
	DCA	WORD1
	JMS I	(ANORM
	TAD	DECPT	/WAS THERE A DECIMAL POINT ?
	SZA CLA
	TAD	NDIGIT	/HOW MANY DIGITS TO THE RIGHT ?
	CIA
	TAD	EXPON	/SUBTRACT THAT NUMBER FROM EXP
	SMA
	JMP	POSEXP	/EXPONENT IS POSITIVE
	CIA
	DCA	EXPON	/ONLY NEED ABS VALUE
	TAD	(FPDIV	/DO DIVIDES
	JMP	.+3
POSEXP,	DCA	EXPON
	TAD	(FPMUL	/DO MULTIPLIES
	DCA	FPRTNE	/MULTIPLY/DIVIDE ROUTINE
	TAD	(PETABL-1
	DCA	X11	/POWERS OF TEN TABLE
EXPMUL,	TAD	EXPON	/LOOK AT THE EXPONENT
	SNA
	JMP	DOSIGN	/IF 0 ITS THRU
	CLL RAR
	DCA	EXPON	/PUT LOWEST BIT INTO LINK
	SNL
	JMP	SKPEXP	/THIS ONE DOESN'T COUNT
	TAD I	X11	/MOVE FACTOR INTO OPERAND
	DCA	OP1
	TAD I	X11
	DCA	OP2
	TAD I	X11
	DCA	OP3
	TAD I	X11
	DCA	OPO
	JMS I	FPRTNE	/MULTIPLY OR DIVIDE BY THIS FACTOR
	JMP	EXPMUL	/CHECK NEXT BIT
SKPEXP,	TAD	X11	/SKIP OVER THIS FACTOR
	TAD	(4
	JMP	EXPMUL-1
DOSIGN,	TAD	SIGN	/CHECK THE SIGN
	SZA CLA
	JMS I	(NEGFAC	/NEGATE IF NEGATIVE
	ISZ	NUMBER	/BUMP RETURN
	JMP I	NUMBER	/RETURN
NXTDGT,	0
\f
/INPUT DEVICE HANDLER
	*INDEVH
	0
\f/INITIALIZATION CODE FOR RUN CASE
	PAGE
RUNNED,	CIF	10	/COME HERE IF .R BCOMP
	JMS I	(200	/CALL COMMAND DECODER
	5
	0201		/ASSUMED EXTENSION "BA"
	CDF 10
	TAD I	(7644	/TEST FOR /V
	CDF
	AND	(4
	SZA CLA
	JMS	VERNUM
	TAD	(INFO-1
	DCA	X10
	CDF	10
	TAD	7617
	CDF
	SNA CLA		/NULL INPUT?
	JMP	RUNNED	/YES: NAUGHTY
	TAD	7777
	CLL RAL		/BATCH RUNNING
	SPA CLA
	JMP	SAVBOS	/YES
	CDF 10
	JMP	FINDSV-2
SAVBOS,	TAD	(INFO-5
	DCA	X10
	TAD	7777
	AND	(70
	TAD	CDFZRO
	DCA	.+1	/CDF TO BATCH FIELD
	CDF	10
	TAD I	BOSCTR
	CDF	10
	DCA I	X10	/SAVE BOS WRDS IN INFO AREA
	ISZ	BOSCTR
	JMP	.-5
	DCA I	X10	/ZERO EDITOR BLOCK NUMBER
	CDF
FINDSV,	TAD I	X11	/LOOKUP SOME SAVE FILES
	SNA
	JMP	LUBUF	/GO LOOK FOR BASIC.UF
	DCA	XXXXSV	/SAVE POINTER TO NAME
	CLA IAC		/THEY'RE ON SYS
	CIF	10
	JMS I	(200
	2
XXXXSV,	0
	0
	JMP	NG	/ERROR
	TAD	XXXXSV	/GET STARTING BLOCK
	IAC		/PLUS 1
	CDF	10
	DCA I	X10	/INTO INFO AREA
CDFZRO,	CDF
	JMP	FINDSV	/LOOP
LUBUF,	CLA IAC
	CIF	10
	JMS I	(200	/LOOKUP BASIC.UF
	2
	BUFN		/(USER DEFINED FUNCTIONS)
	0
	JMP	.+3	/OK IF NOT THERE
	TAD	.-3	/GET STARTING BLOCK +1
	IAC
	CDF	10
	DCA I	X10	/INTO INFO BLOCK
STRT3,	CDF
	CLA IAC		/ENTER TEMPORARY FILE
	CIF	10
	JMS I	(200
	3
TMPBLK,	TMPFIL
	0
	JMP	NG
	TAD	TMPBLK	/SAVE START OF TEMP FILE
	DCA	OUBLOK
	TAD	TMPBLK	/IN A COUPLE PLACES
	DCA	BLOCK
	TAD	TMPBLK+1/ALSO THE SIZE
	DCA	OUSIZE
	JMP	GETDEV	/GO FETCH DEVICE HANDLER
BOSCTR,	7774
VERNUM,	0
	TAD	(VTEXT
	DCA	TEMP
	TAD	(-5
	DCA	TEMP2
	TLS
MOREV,	TAD I	TEMP
	CLL RTR
	RTR
	RTR
	JMS	TTY
	TAD I	TEMP
	JMS	TTY
	ISZ	TEMP
	ISZ	TEMP2
	JMP	MOREV
	TAD	(215
	JMS	TTX
	TAD	(212
	JMS	TTX
	TSF		/WAIT FOR TTY TO GET DONE
	JMP .-1		/BEFORE RETURNING
	JMP I	VERNUM
/
VTEXT,	TEXT	/BCOMP  V/
	*.-1
VERLOC,	VERSON^100+6001
	0
\f/ NUMERIC CONVERSION ROUTINE (PART TWO)
	PAGE
FPMUL,	0		/FLOATING MULTIPLY ROUTINE
	TAD	WORD1	/COMPUTE NEW EXPONENT
	TAD	OP1
	DCA	OP1
	TAD	WORD2	/SAVE AC MANTISSA
	DCA	TW2
	TAD	WORD3
	DCA	TW3
	TAD	(-30	/SET ITERATION COUNTER
	DCA	ITRCNT
	DCA	WORD2	/ZERO FAC MANTISSA
	DCA	WORD3
	DCA	ACO
MULLUP,	JMS I	(AR1	/SHIFT FAC RIGHT ONE
	TAD	TW2	/SHIFT MULTIPLIER RIGHT
	CLL RAR
	DCA	TW2
	TAD	TW3
	RAR
	DCA	TW3
	SZL
	JMS	OADD	/ADD IF LINK IS ONE
	ISZ	ITRCNT	/BUMP COUNT
	JMP	MULLUP	/LOOP
	TAD	OP1	/PUT IN CORRECT EXPONENT
	DCA	WORD1
	JMS	ANORM	/NORMALIZE THE RESULT
	JMP I	FPMUL
D2,
TW2,	0
D3,
TW3,	0
NFCNT,
ANORM,	0		/NORMALIZE FAC
	TAD	WORD2	/IS MANTISSA 0 ?
	SNA
	TAD	WORD3
	SNA
	TAD	ACO
	SNA CLA
	JMP	ZEXP	/YES, ZERO EXPONENT
NORMLP,	CLA CLL CML RTR	/IS HIGH ORDER MANTISSA = 6000
	TAD	WORD2
	SZA
	JMP	NO6000	/NO, SKIP THIS CRAP
	TAD	WORD3	/YES, IS THE REST 0 ?
	SNA
	TAD	ACO
	SZA CLA		/SKIP IF 600000 ... 0000
NO6000,	SPA CLA
	JMP I	ANORM	/NORM IS DONE WHEN BITS DIFFER
	JMS I	(AL1	/SHIFT LEFT ONE
	CLA CMA		/DECREMENT EXPONENT
	TAD	WORD1
	DCA	WORD1
	JMP	NORMLP	/LOOP
ZEXP,	DCA	WORD1
	JMP I	ANORM
NEGFAC,	0		/NEGATE FAC
	TAD	(ACO	/GET POINTER TO OPERAND
	DCA	NFPTR
	CLL CMA RTL	/THREE WORD NEGATE
	DCA	NFCNT
	CLL
NFLOOP,	RAL
	TAD I	NFPTR	/GET NEXT WORD
	CLL CML CIA
	DCA I	NFPTR	/RESTORE AFTER COMPLEMENTING
	CML CLA CMA	/LINK GETS COMPLEMENTED ONCE HERE
	TAD	NFPTR	/AND ONCE AGAIN HERE
	DCA	NFPTR	/RESTORE DECREMENTED POINTER
	ISZ	NFCNT
	JMP	NFLOOP
	JMP I	NEGFAC
NFPTR,	0
FPDIV,	0
	JMS I	(AR1	/UNNORMALIZE AC BY ONE
	TAD	OP1	/COMPUTE FINAL EXPONENT
	CIA
	TAD	WORD1
	DCA	OP1	/AND SAVE IT
	TAD	(-30	/SET ITERATION COUNTER
	DCA	ITRCNT
	TAD	WORD2
	RAL		/INITIALIZE LINK
FPDVLP,	CLA RAR		/COMPARE SIGNS
	TAD	OP2
	SPA CLA
	JMP	.+3
	TAD	(OPO-ACO/NEGATE OPERAND
	JMS	NEGFAC
	JMS	OADD	/ADD OPERAND AND FAC
	TAD	D3
	RAL
	DCA	D3
	TAD	D2
	RAL
	DCA	D2
	JMS I	(AL1	/LEFT SHIFT FAC ONE
	ISZ	ITRCNT	/TEST ITERATION COUNT
	JMP	FPDVLP
	TAD	OP1	/PUT QUOTIENT INTO FAC
	DCA	WORD1
	TAD	D2
	DCA	WORD2
	TAD	D3
	DCA	WORD3
	DCA	ACO
	JMS	ANORM	/NORMALIZE
	JMP I	FPDIV
OADD,	0		/ADD OPERAND TO FAC
	CLL
	TAD	OPO
	TAD	ACO
	DCA	ACO
	RAL
	TAD	OP3
	TAD	WORD3
	DCA	WORD3
	RAL
	TAD	OP2
	TAD	WORD2
	DCA	WORD2
	JMP I	OADD
ITRCNT,	0
\f/ NUMERIC CONVERSION ROUTINE (FINALE)
	PAGE
SMLNUM,	0		/INPUT A NUMBER <= 4095
EXPLUP,	DCA	EXPON	/ZERO THE EXPONENT
	JMS I	QDIGIT	/GET THE NEXT DIGIT
	JMP I	SMLNUM	/NUMBER DONE
	DCA	OPO	/SAVE THE DIGIT
	TAD	EXPON	/MULT BY 10
	CLL RAL
	CLL RAL
	TAD	EXPON
	CLL RAL
	TAD	OPO	/ADD IN DIGIT
	JMP	EXPLUP	/STORE BACK INTO EXPONENT
AR1,	0		/SHIFT FAC RIGHT 1 BIT
	TAD	WORD2
	CLL RAR
	DCA	WORD2
	TAD	WORD3
	RAR
	DCA	WORD3
	TAD	ACO
	RAR
	DCA	ACO
	ISZ	WORD1
	JMP I	AR1
	JMP I	AR1
AL1,	0		/SHIFT FAC LEFT ONE
	TAD	ACO
	CLL RAL
	DCA	ACO
	TAD	WORD3
	RAL
	DCA	WORD3
	TAD	WORD2
	RAL
	DCA	WORD2
	JMP I	AL1
CHKSGN,	0		/CHECK FOR SIGN
	TAD	(-55	/IS IT - ?
	SNA
	ISZ I	CHKSGN	/YES, SET SWITCH
	SZA
	TAD	(55-53	/IS IT + ?
	SZA CLA
	JMS I	QBACK1	/RETURN CHAR OTHERWISE
	JMP I	CHKSGN
\f/ STRING LITERAL SCANNER
STRING,	0		/LOOK FOR A STRING
	JMS I	QCHECKC	/LOOK FOR "
M42,	-42
	JMP I	STRING	/NONE MEANS NO STRING
	ISZ	STRING
	DCA	WORD1	/ZERO CHAR COUNT
	TAD	(WORD2	/SETUP POINTER
	DCA	TEMP
	TAD	(-STRLIM%2	/AND MAX SIZE
	DCA	TEMP2
SLOOP,	JMS	GCS	/GET HIGH ORDER CHAR
	JMP I	STRING	/END OF STRING
	CLL RTL
	RTL
	RTL
	DCA I	TEMP	/PUT INTO UPPER HALF OF WORD
	JMS	GCS	/GET LOWER CHAR
	JMP	PUT40	/FILL LAST WORD WITH BLANK
	TAD I	TEMP	/COMBINE THEM
	DCA I	TEMP
	ISZ	TEMP	/BUMP POINTER
	ISZ	TEMP2	/TOO BIG YET ?
	JMP	SLOOP	/NO, LOOP
	JMS I	QGETC	/MAX SIZE STRING, MUST FIND "
	JMP	STRGER	/BAD STRING LITERAL
	TAD	M42
	SNA CLA
	JMP I	STRING	/OK
STRGER,	JMS I	QERMSG	/STRING ERROR
	2123
	JMP I	STRING
PUT40,	TAD I	TEMP	/GET LAST WORD
	TAD	(40	/PUT BLANK IN LOW CHAR
	DCA I	TEMP	/STORE NEW WORD
	JMP I	STRING	/RETURN
GCS,	0		/GET A CHAR FOR STRING
	JMS I	QGETCWB	/GET A CHAR (INCLUDE BLANKS)
	JMP	STRGER	/BAD
	TAD	M42	/IS IT "
	SZA
	JMP	NOTQOT	/NO
	JMS I	QGETCWB	/IS IT ""
	JMP I	GCS	/NO, THAT WAS IT
	TAD	M42	/LOOK FOR SECOND "
	SNA CLA
	JMP	NOTQOT	/"" BECOMES "
	JMS I	QBACK1	/PUT IT BACK
	JMP I	GCS	/LITERAL IS DONE
NOTQOT,	TAD	(42	/RECREATE CHAR
	AND	(77	/ELIMINATE EXTRA BITS
	ISZ	WORD1	/BUMP STRING COUNT
	ISZ	GCS	/FIX RETURN
	JMP I	GCS
MODSET,	0		/SET INTERPRETER MODE
	TAD	MODE	/SUM OF DESIRED AND CURRENT
	SMA CLA
	JMP I	MODSET	/THEY WERE THE SAME
	TAD	MODE	/OTHERWISE SWITCH MODES
	SZA CLA
	TAD	(NMODE-SMODE
	TAD	(SMODE	/ENTER NMODE OR MAYBE SMODE
	JMS I	QOUTWRD
	CLL CML RAR
	TAD	MODE	/CHANGE THE SWITCH
	DCA	MODE
	JMP I	MODSET	/AND RETURN
XIDIV,	FIDIV;AIDIV
WPNT,	-120;-116;-124;-50;0
\f/ VARIABLE OR FUNCTION REFERENCE SCANNER
	PAGE
GETNAM,	0		/LOOK FOR VARIABLE OR FUNCT REFNCE
	DCA	TYPE	/ZERO TYPE
	JMS I	QLETTER	/MUST START WITH LETTER
	JMP I	GETNAM	/NO NAME
	DCA	NAME1
	JMS I	QDIGIT	/<LETTER><DIGIT> ?
	JMP	TRYFUN	/NO, LOOK FOR FUN REF
	IAC		/INCREMENT DIGIT
LFDOLR,	DCA	NAME2	/STORE AS NAME2
	JMS I	QGETC	/LOOK FOR $ (STRING)
	JMP	GOTNAM+2/NOT THERE
	TAD	(-44
	SZA
	JMP	NOSTRG	/NO $ MEANS NO STRING
	CLL CML RAR	/SET STRING BIT
	TAD	TYPE
	DCA	TYPE
	JMS I	QGETC	/LOOK FOR ( (ARRAY)
	JMP	GOTNAM+2/NAME FINI
	TAD	(-44	/PRIME THE CHAR
NOSTRG,	TAD	(44-50	/LOOK FOR ( (ARRAY)
	SNA CLA
	CLL CML RTR	/YES, SET ARRAY BIT
	SNA
	JMS I	QBACK1	/NO, BACKUP 1 CHAR
GOTNAM,	TAD	TYPE	/MODIFY TYPE
	DCA	TYPE
	ISZ	GETNAM	/BUMP RETURN
	JMP I	GETNAM
TRYFUN,	JMS I	QSAVECP	/SAVE CHAR POSITION
	TAD	NAME1	/MOVE FIRST CHAR OVER
	CLL RTL
	RTL
	RTL
	DCA	NAME2
	JMS I	QLETTER	/LOOK FOR SECOND LETTER
	JMP	LFDOLR	/NONE THERE, LOOK FOR $
	TAD	NAME2	/COMBINE WITH FIRST LETTER
	DCA	NAME2
	JMS I	QLETTER	/LOOK FOR THIRD LETTER
	JMP	NOFNAM	/NOT A FUNCTION NAME
	DCA	NAME3	/PUT INTO NAME
	TAD	NAME2	/IS IT A USER FUNCT ?
	TAD	(-616	/FN
	SNA CLA
	JMP	USRFUN	/YES
	TAD	(FUNS-1	/NO, CHECK VALIDITY OF NAME
	DCA	X10
FUNSRC,	TAD I	X10	/GET NEXT FUN NAME
	SNA
	JMP	NOFNAM	/END OF LIST, INVALID NAME
	TAD	NAME2	/COMPARE FIRST 2 CHARS
	SZA CLA
	JMP	NOMATC	/THEY DON'T MATCH
	TAD I	X10	/COMPARE 3RD CHAR
	TAD	NAME3
	SZA CLA
	JMP	NOMATC+1/DON'T MATCH
	TAD I	X10	/GET FUNCTION CODE
FUNOK,	DCA	SYMBOL	/SAVE IT AS SYMBOL VALU
	TAD	(1000	/SET FUNCTION BIT
	DCA	TYPE
	JMP	LFDOLR	/LOOK FOR Q$] Q(]
NOMATC,	ISZ	X10	/SKIP THIRD CHAR
	ISZ	X10	/SKIP FUNCTION NUMBER
	JMP	FUNSRC	/KEEP LOOKING
NOFNAM,	JMS I	QRESTCP	/RESTORE CHAR POS
	JMP	LFDOLR	/LOOK FOR Q$] Q(]
USRFUN,	TAD	NAME3	/GENERATE FUN NUMBER
	JMP	FUNOK
\f/ ERROR MESSAGE REPORTER
ERMSG,	0		/PRINT ERROR MESSAGE
	CLA
	CDF
	TAD I	ERMSG	/GET CODE
	CLL RTR		/PRINT FIRST CHAR
	RTR
	RTR
	JMS	TTY
	TAD I	ERMSG	/PRINT SECOND CHAR
	JMS	TTY
	ISZ	ERMSG	/FIX RETURN ADDR
	TAD	SPACE	/PRINT SPACE
	JMS	TTY
	DCA	TTY	/USE TTY AS A SWITCH
	TAD	LINEH	/PRINT HIGH ORDER
	JMS	PSN
	TAD	LINEL	/THEN LOW ORDER
	JMS	PSN	/(LINE NUMBER NATCH !)
	TAD	(215	/PRINT CARRIAGE RETURN
	JMS	TTX
	TAD	(212	/PRINT LINE FEED
	JMS	TTX
	JMP I	ERMSG	/RETURN
PSN,	0		/PRINT 3 DIGITS DECIMAL
	DCA	WORD2
	CLL CMA RTL	/-3
	DCA	TEMP
PRNTSN,	TAD	WORD2	/GET NEXT DIGIT
	CLL RTL		/INTO THE LOW ORDER
	RTL		/THREE BITS AND THE LINK
	DCA	WORD2	/SAVE SHIFTED NUMBER
	TAD	WORD2	/NOW DO LAST SHIFT
	RAL
	AND	(17	/ONLY FOUR BITS
SPACE,	SZA
	JMP	NOZERO	/NOT A ZERO
	TAD	TTY	/ANY DIGITS YET ?
	SNA CLA
	JMP	LEAD0	/NO, ITS A LEADING ZERO
NOZERO,	TAD	(60	/MAKE IT ASCII
	JMS	TTY	/PRINT DIGIT
LEAD0,	ISZ	TEMP	/BUMP COUNT
	JMP	PRNTSN	/MORE DIGIT(S)
	JMP I	PSN
XMUL,	FMPY;AFMPY
\f/ EXPONENT TABLE
	PAGE
PETABL,	0004;2400;0000;0000
	0007;3100;0000;0000
	0016;2342;0000;0000
	0033;2765;7020;0000
	0066;2160;6744;6770
	0153;2356;1326;6501
	0325;3023;6017;5120
	0652;2235;6443;7114
	1523;2523;7565;7735
	3245;3430;6320;2565
\f/ OPERATOR TABLE
OPR8RS,	PLUS;-53
	MINUS;-55
	STAR;-52
	SLASH;-57
	UPAROW;-136
	AMPSND;-46
	0
SASIGN,	4000;XSTOR
ASSIGN,	0;XSTOR
\f/ FUNCTION NAME TABLE (INTERNAL FUNCTIONS)
FUNS,	-0102;-23;FUNC3
	-0123;-03;FUNC2
	-0124;-16;FUNC1
	-0310;-22;FUNC2+20
	-0317;-23;FUNC1+20
	-0401;-24;FUNC2+40
	-0530;-20;FUNC1+40
	-1116;-24;FUNC1+100
	-1405;-16;FUNC2+60
	-1417;-07;FUNC1+120
	-2017;-23;FUNC2+100
	-2216;-04;FUNC1+200
	-2305;-07;FUNC2+120
	-2307;-16;FUNC1+140
	-2311;-16;FUNC1+160
	-2321;-22;FUNC1+220
	-2324;-22;FUNC2+140
	-2601;-14;FUNC2+160
	-2422;-03;FUNC2+220
ENDFNS,	0;0;FUNC4	/SPACE FOR NEW FUNCTIONS
	0;0;FUNC4+20
	0;0;FUNC4+40
	0;0;FUNC4+60
	0;0;FUNC4+100
	0;0;FUNC4+120
	0;0;FUNC4+140
	0;0;FUNC4+160
	0;0;FUNC4+200
	0;0;FUNC4+220
	0;0;FUNC4+240
	0;0;FUNC4+260
	0;0;FUNC4+300
	0;0;FUNC4+320
	0;0;FUNC4+340
	0;0;FUNC4+360	/SIXTEEN OF THEM
	0
\f/ KEYWORD LIST
KEYWRD,	-114;-105;-124;LET
	-111;-106;-105;-116;-104;IFEND
	-111;-106;IF
	-106;-117;-122;FOR
	-116;-105;-130;-124;NEXTX
WGOTO,	-107;-117
WTO,	-124;-117;GOTO
	-107;-117;-123;-125;-102;GOSUB
	-111;-116;-120;-125;-124;INPUT
	-120;-122;-111;-116;-124;PRINT
	-104;-111;-115;DIM
	-104;-101;-124;-101;DATA
	-104;-105;-106;DEF
	-106;-111;-114;-105;FILE
	-122;-105;-101;-104;READX
	-122;-105;-115;REMARK
	-122;-105;-123;-124;-117;-122;-105;RESTOR
	-122;-105;-124;-125;-122;-116;RETURN
	-123;-124;-117;-120;STOPX
	-122;-101;-116;-104;-117;-115;-111;-132;-105;RANDOM
	-103;-114;-117;-123;-105;CLOSE
	-103;-110;-101;-111;-116;CHAIN
	-125;-104;-105;-106;UDEF
	-125;-123;-105;USEX
	-105;-116;-104;END
	0
\f/ OS-8 OUTPUT ROUTINE
OWTEMP,	0
OUPTR,	OUBUF
OCOUNT,	-401
OUTWRD,	0		/OUTPUT ROUTINE
	DCA	OWTEMP	/SAVE WORD
	ISZ	LOCTRL	/INCREMENT PSEUDO CODE
	SKP		/LOCATION COUNTER
	ISZ	LOCTRH	/BOTH HALVES
	NOP		/IT'LL NEVER HAPPEN
	ISZ	OCOUNT	/TEST FOR BUFFER FULL
	JMP	NOWRIT	/STILL SOME ROOM
	JMS	OUDUMP	/DUMP THE BUFFER
	TAD	OUBLOK-1/RESET BUFFER PARAMETERS
	DCA	OUPTR
	TAD	(-400
	DCA	OCOUNT
NOWRIT,	TAD	OWTEMP	/PUT WORD
	CDF	10
	DCA I	OUPTR	/INTO BUFFER
	CDF
	ISZ	OUPTR	/MOVE POINTER
	JMP I	OUTWRD
OUDUMP,	0		/DUMP OUT BUFFER
	JMS I	(7607	/CALL OUTPUT HANDLER
	4210
	OUBUF
OUBLOK,	0
	JMP	OUERR
	ISZ	OUBLOK	/INCREMENT BLOCK NUMBER
	ISZ	OUSIZE	/CHECK FOR HOLE FULL
	JMP I	OUDUMP
OUERR,	JMS I	QERMSG	/OUTPUT FILE ERROR
	1706
	JMP I	XABORT	/ABORT COMPILATION
ODEVH,	0
OUSIZE,	0
AMPRTN,	JMS	LOD1ST	/LOAD OP1$
	AMPSND+2	/CONC OP2$
SCRTN,	JMS	LOD1ST	/LOAD OP1$
	SCOMPR+1	/COMP OP2$
LOD1ST,	0		/HANDLE ONE WAY INSTRUCTIONS
	JMS I	QSAVAC	/STORE 2ND ARG IF IN SAC
	-1
	CLA CMA		/GET TYPE OF 2ND ARG
	TAD	OSTACK
	DCA	TEMP
	CLL CML RTR	/IS IT SUBSCRIPTED ?
	AND I	TEMP
	SNA CLA
	JMP	SKIP2	/NO, ENTRY IS ONLY 2 WORDS
	TAD I	TEMP	/GET NUMBER OF DIMS
	AND	SCOMPR	/LITERAL 3
	CLL RAL		/DOUBLE IT
	CIA
SKIP2,	TAD	(-2	/FIND SIZE OF 2ND ARG
	DCA	OP2SIZ	/AND SAVE IT
	TAD	OSTACK	/BACK UP STACK
	TAD	OP2SIZ
	DCA	OSTACK
	TAD	OSTACK	/AND SAVE THIS ADDR
	DCA	X12
	JMS I	QLOAD	/LOAD ARG 1
	CLL CML RAR	/GET TYPE BIT
	AND	TYPE1	/PUT BACK ARG1
	TAD	Q400
	DCA I	OSTACK
	DCA I	OSTACK
	TAD I	X12	/PUT BACK ARG 2
	DCA I	OSTACK
	ISZ	OP2SIZ
	JMP	.-3
	TAD I	LOD1ST	/GET OPERATOR FINISH
	JMP	OUTOPR+1/GO FINISH CODE
OP2SIZ,	0		/SACRED COUNT WORD
CHECKC,	0		/CHAR CHECKER
	JMS I	QGETC	/GET A CHARACTER
	JMP	.+6	/FAILED
	TAD I	CHECKC	/COMPARE
	SNA
	ISZ	CHECKC	/MATCHES, SKIP TWO
	SZA CLA
	JMS I	QBACK1	/NO MATCH, REPLACE
	ISZ	CHECKC	/ALWAYS SKIP AT LEAST 1
	JMP I	CHECKC
SCOMPR,	3;SCRTN-3;4000;XSCOMP;XSCOMP
\f/ OS-8 FILE INPUT ROUTINE
	PAGE
ICHAR,	0		/READ CHAR FROM INPUT FILE
	ISZ	INJMP	/BUMP THREE WAY UNPACK SWITCH
	ISZ	INCHCT
INJMPP,	JMP	INJMP
	TAD	INEOF	/LAST READ YEILD END OF FILE ?
	SZA CLA
	JMP	ENDFIL	/YES
INGBUF,	TAD	INCTR	/BUMP RECORD COUNTER
	CLL IAC
	SNL
	DCA	INCTR	/RESTORE IF IT HASN'T OVERFLOWED
	SZL
	ISZ	INEOF	/SET END OF FILE SWITCH
	JMS I	INHNDL	/DO THE READ
	0200		/ONE BLOCK TO FIELD 0
INBUFP,	INBUF
INREC,	0
	JMP	INERR	/HANDLER ERROR
INBREC,	ISZ	INREC	/BUMP RECORD NUMBER
	TAD	(-601	/SET CHAR COUNT
	DCA	INCHCT
	TAD	INJMPP	/RESET THREE WAY JUMP SWITCH
	DCA	INJMP
	TAD	INBUFP	/RESET BUFFER POINTER
	DCA	INPTR
	JMP	ICHAR+1	/GO AGAIN
INERR,	SMA CLA
	JMP	INBREC
ENDFIL,	JMS I	QERMSG	/INPUT FILE ERROR
	1505
ABORT,	TAD	(4207	/RESTORE ^C LOCZTIONS
	DCA	7600
	TAD	(6213
	DCA	7605
	CDF	10
	TAD	INFO	/GET START OF BASIC.SV
	CDF
	SNA
	JMP	7605	/T'WERE RUNNED
	DCA	EDTBLK	/SAVE MAGICAL BLOCK NUMBER
	JMS	7607	/USE SYS HANDLER
	EDTSIZ		/TO READ IN THIS MUCH
	0		/INTO ZERO
EDTBLK,	0		/FROM HERE
	HLT		/HALT IF BAD READ
	JMP	EDTBGN	/GO RESTART EDITOR
INJMP,	HLT		/3 WAY CHAR UNPACK JUMP
	JMP	ICHAR1
	JMP	ICHAR2
ICHAR3,	TAD	INJMPP	/RESET JUMP SWITCH
	DCA	INJMP
	TAD I	INPTR
	AND	(7400	/COMBINE THE HIGH ORDER BITS
	CLL RTR		/OF THE TWO WORDS
	RTR
	TAD	INTMP	/TO FORM THE THIRD CHAR
	RTR
	RTR
	ISZ	INPTR	/BUMP WORD POINTER
	JMP	ICHAR1+1/DO SOME COMMON STUFF
ICHAR2,	TAD I	INPTR	/SAVE THE HIGH ORDER BITS
	AND	(7400
	DCA	INTMP	/FOR THE THIRD CHAR
	ISZ	INPTR	/GO TO THE SECOND WORD
ICHAR1,	TAD I	INPTR	/GET THE LOW 7 BITS
	AND	(177	/AND I MEAN ONLY 7 !!
	SNA		/IGNOR LEADER-TRAILER
	JMP	ICHAR+1
	TAD	(-134	/CHECK FOR \ (STMT SEPARATOR)
	SNA
	JMP I	ICHAR	/TREAT LIKE CR
	TAD	(134-32	/IS IT ^Z (END OF FILE)
	SNA
	JMP	ENDFIL	/YES, ITS END OF FILE
	TAD	(32-12
	SNA
	JMP	ICHAR+1	/IGNORE LINE FEEDS
	IAC		/TABS -> BLANKS
	SNA
	TAD	(40-11
	TAD	(11-15
	SNA
	JMP I	ICHAR	/RETURN ON CARRIAGE RETURN
	IAC
	SNA
	JMP	ICHAR+1	/IGNORE FORM FEEDS
	TAD	(14	/FIX CHAR
	ISZ	ICHAR
	JMP I	ICHAR	/RETURN TO THE CALLING WORLD
INTMP,	0
INEOF,	0
INCHCT,	-1
INHNDL,	0		/ENTRY ADDR GOES HERE
INCTR,	0
INPTR,	0
CHKWD,	0		/WORD CHECKER
	TAD I	CHKWD	/GET POINTER
	ISZ	CHKWD
	DCA	CWTEMP	/SAVE POINTER
WDLOOP,	TAD I	CWTEMP	/GET NEXT CHAR
	SMA
	ISZ	CHKWD	/IF NON NEG, FIX RETURN
	SPA CLA
	JMS I	QGETC	/GET CHAR
	JMP I	CHKWD	/RETURN
	TAD I	CWTEMP	/COMPARE
	ISZ	CWTEMP	/INCR POINTER
	SNA CLA
	JMP	WDLOOP	/MORE
	JMP I	CHKWD	/FAILED
CWTEMP,	0
\f/ INITIALIZATION CODE
	*LINE
START,	JMP	RUNNED	/DO LOOKUPS, AND FIND TEMPFILE
CHAINED,CDF	10
	TAD I	(7644	/WAS IT A CHAIN FROM BRTS ?
	CDF
	AND	(100
	SNA CLA
	JMP	CHEDIT	/NO, FROM THE EDITOR
	CIF	10	/CHAIN FROM BRTS, RESET
	JMS I	(200	/TO FORGET DSK: HANDLER
	13
	JMP	STRT3	/NOW GO OPEN TEMP FILE
CHEDIT,	TAD	(INFO+7	/PICK UP SOME STUFF
	DCA	X10
	CDF	10	/FROM THE INFO BLOCK
	TAD I	X10	/START OF TEMP FILE
	SNA
	JMP I	(RUNNED+4	/MUST BE CHAIN FROM CCL
	DCA	BLOCK
	TAD I	X10	/SIZE OF HOLE
	CDF
	DCA	OUSIZE
	TAD	BLOCK
	DCA	OUBLOK
	CDF	10
	TAD I	X10	/ENTRY ADDR OF HANDLER
	CDF
	DCA	INHNDL
	JMP	STRT2
GETDEV,	CDF	10
	TAD	7617	/GET DEVICE NUM FOR INPUT FILE
	CDF
	CIF	10
	JMS I	(200	/GO FETCH THE DEVICE
	1
	INDEVH+1	/2 PAGE HANDLER IS OK
	JMP	NG	/ERROR
	TAD	.-2	/GET HANDLER ADDRESS
	DCA	INHNDL	/SAVE IT
	CIF	10
	JMS I	(200	/RESET SYSTEM TABLES
	13		/DELETING TENTATIVE FILES
STRT2,	CDF	10
	TAD	7617	/SET UP INPUT FILE PARAMS
	CDF
	AND	(7760	/GET SIZE
	TAD	(17
	CLL CML RTR
	RTR
	DCA	INCTR
	CDF	10
	TAD	7620	/GET BLOCK NUMBER
	CDF
	DCA	INREC
	CDF	10
	TAD	INFO+3	/GET START OF BRTS.SV (+1)
	DCA	BRTS
	TAD	INFO	/GET START OF BASIC.SV (+1)
	DCA	ABORTX	/BOTH FOR BLOAD
	TAD	INFO+2	/GET START OF BLOAD.SV
	CDF
	DCA	LDRBLK	/FOR CHAIN TO BLOAD
	TLS		/SET TTY FLAG
	ISZ	WASTE
	JMP	.-1
	ISZ	TIME
	JMP	.-1
INITST,	TAD	(VARST-1/INITIALIZE ST AREA
	DCA	X12
	TAD	(-436-436-436
	DCA	X11	/SIZE OF NUM AND STRING TABLES
	CDF	10
	CLL CML RAR	/SET TO 4000
	DCA I	X12
	ISZ	X11
	JMP	.-3
	TAD	(-440	/NOW ARRAY TABLES
	DCA	X11	/AND BUCKETS
	DCA I	X12
	ISZ	X11	/SET THEM TO ZERO
	JMP	.-2
	CDF
	TAD	JABORT	/MODIFY ^C LOCATIONS
	DCA	7600
	TAD	JABORT
	DCA	7605
	JMP	CORE	/GET CORE SIZE
NG,	TLS
	JMS I	QERMSG	/SUPER ERROR
	2331
	TSF
	JMP	.-1
JABORT,	JMP I	XABORT	/ABORT COMPILATION
WASTE,	0
TIME,	200
\f	*INBUF
CORE,	TAD 7777	/MODIFIED CORE SIZE ROUTINE FROM
	AND (70
	SNA
	JMP COR0
	CLL RAR
	RTR
	IAC
	DCA CORSIZ
	JMP COREX	/OS8 SOFTWARE SUPPORT MANUAL
COR0,	CDF
	TAD	CORSIZ
	RTL
	RAL
	AND	COR70
	TAD	COREX
	DCA	.+1
COR1,	CDF
	TAD I	CORLOC
COR2,	NOP
	DCA	COR1
	TAD	COR2
	DCA I	CORLOC
COR70,	70
	TAD I	CORLOC
CORX,	7400
	TAD	CORX
	TAD	CORV
	SZA CLA
	JMP	COREX
	TAD	COR1
	DCA I	CORLOC
	ISZ	CORSIZ
	JMP	COR0
COREX,	CDF
	CLA CMA		/HI FIELD IS #FIELDS-1
	TAD	CORSIZ
	DCA	HIFLD
	TAD	HIFLD
	CIA
	DCA	NFLDS
	CMA		/HOW MANY FIELDS ?
	TAD	HIFLD	/MUST THIS BASIC USE ?
	SZA CLA		/(SOUNDS LIKE A LINE BY DYLAN)
	JMP	GENER
	TAD	(PATCH1+3&177+5200
	DCA	PATCH1	/ONLY 8K, DON'T USE CDF'S
	TAD	(PATCH2+11&177+5200
	DCA	PATCH2
	TAD	(PATCH3+4&177+5200
	DCA	PATCH3
	TAD	(PATCH4+3&177+5200
	DCA	PATCH4
	TAD	(7000
	DCA	PATCH5
GENER,	JMS	GENTMP	/GENERATE TEMP 0
	JMS	GENTMP	/GENERATE TEMP 1
	JMS	GENTMP	/GENERATE TEMP 2
	CLA IAC		/GENERATE STRING TEMP 0
	JMS	GENTMP
	CLA IAC
	DCA	WORD1	/GENERATE LITERAL 1.0
	CLL CML RTR
	DCA	WORD2
	JMS I	QLUKUP2	/ENTER INTO ST
	LITRL
	-3
	JMS	NEWVAR
	TAD	(FNINIT	/SET UP FUNCTIONS
	DCA	FDPTR
FDLOOP,	TAD	(WORD1-1
	DCA	X12
	TAD I	FDPTR	/GET FIRST WORD
	ISZ	FDPTR
	SNA
	JMP I	QREMARK	/DONE, START COMPILER
	DCA I	X12	/SAVE IN WORD1
	CLL CMA RTL	/GET LOOKUP COUNT
	TAD I	FDPTR
	DCA	FUNSIZ
	TAD	FUNSIZ	/GET SIZE OF MOVE
	IAC
	DCA	TEMP
	TAD I	FDPTR	/GET A WORD
	ISZ	FDPTR
	DCA I	X12	/PUT INTO WORDN
	ISZ	TEMP
	JMP	.-4
	JMS I	QLUKUP2	/ENTER INTO S.T.
	FUNCTN
FUNSIZ,	0
	JMP	FDLOOP	/LOOP
FDPTR,	0
CORLOC,	CORX
CORV,	1400
CORSIZ,	1
NAMLST,	BCOMPN		/SAVE FILE NAME-POINTER LIST
	BLOADN
	BRTSN
	BAFN
	BSFN
	BFFN
	0
\f	PAGE
FNINIT,	FUNC3;-1;2000;0			/ABS
	FUNC1;-1;2000;0			/ATN
	FUNC2;-1;6000;0			/ASC
	FUNC1+20;-1;2000;0		/COS
	FUNC2+20;-1;2000;4000		/CHR
	FUNC1+40;-1;2000;0		/EXP
	FUNC2+40;-1;2000;4000		/DAT
	FUNC1+220;-1;2000;0		/SQR
	FUNC1+60;-2;0;2000;0		/EXP2
	FUNC2+60;-1;6000;0		/LEN
	FUNC1+100;-1;2000;0		/INT
	FUNC2+100;-3;2000;4000;6000;0	/POS
	FUNC1+120;-1;2000;0		/LOG
	FUNC2+120;-3;0;2000;6000;4000	/SEG
	FUNC1+140;-1;2000;0		/SGN
	FUNC2+140;-1;2000;4000		/STR
	FUNC1+160;-1;2000;0		/SIN
	FUNC2+160;-1;6000;0		/VAL
	FUNC1+200;-1;2000;0		/RND
	FUNC2+220;-1;2000;0		/TRC
	0
BASICN,	FILENAME BASIC.SV		/FILE NAMES
BCOMPN,	FILENAME BCOMP.SV		/FOR LOOKUPS
BLOADN,	FILENAME BLOAD.SV
BRTSN,	FILENAME BRTS.SV
BAFN,	FILENAME BASIC.AF
BSFN,	FILENAME BASIC.SF
BFFN,	FILENAME BASIC.FF
BUFN,	FILENAME BASIC.UF
TMPFIL,	FILENAME BASIC.TM
	$
\f\f