/25 OS/8 Commercial BASIC Compiler, V6A
/
/
/
/
/
/
/
/
/
/
/
/COPYRIGHT (C) 1972, 1973, 1974, 1975, 1978
/Digital Equipment Corporation, Maynard, Ma.
/
/
/
/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 any other
/copies thereof, may not be 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 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
/Equipment Corporation.
/
/DEC assumes no responsibility for the use or reliability of its
/software on equipment which is not supplied by DEC.
/
/
/
/
/
/
/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:

/	T.B.S.

	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

/JR	4-Dec-77	Begin commercial Basic mods
/JR	23-Jan-78	Re-layout core
/JR	31-Jan-78	Add 7 bit ASCII support
/JR	15-Feb-78	Add string arithmetic parsing
/JR	22-Feb-78	Add PRINT USING
/JR	3-Apr-78	Add direct access statements
/JR	14-May-78	Put in fancy error messages, do misc clean ups
/JR	15-May-78	Add ON-GOTO/GOSUB feature, fix DATA statement bug
	*1
	CIF	30	/Symbiosis interrupt linkage
	JMP	.-1
	*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
THSFLD,			/HIGHEST FIELD USDE BY S.T. PASSED TO BLOAD HERE
LINEH,	0		/LINE NUMBER (HIGH)
OUTFLG,			/FLAG PASSED TO BLOAD NONZERO IF TEMP FILE WRITES DONE
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
NXTDGT,	0
TRLDIG,	0
	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.OV
/INFO+5  STARTING BLOCK +1 OF BASIC.UF
/INFO+6  *UNUSED*
/INFO+7  *UNUSED*
/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

	/OS/8 DEFINES

	BIPCCL=	7777	/BATCH IN PROGRESS/CORE SIZE WORD IN FIELD 0
	JSW=	7746	/JOB STATUS WORD IN FIELD 0
	CDOPT2=	7642	/HIGH ORDER CD = OPTION
	CDOPT3=	7643	/CD SWITCHES ABC DEF GHI JKL
	CDOPT4=	7644	/CD SWITCHES MNO PQR STU VWX
	CDOPT5=	7645	/CD SWITCHES YZ0 123 456 789
	CDOPT6=	7646	/LOW ORDER CD = OPTION
	BOSINF=	7774	/BOS PARAMETER AREA

	/BASIC DEFINES

	EDTSIZ=	2400	/SIZE OF BASIC.SV
	EDTBGN=	0201	/RESTART FOR EDITOR
	BLDSZ0=	1500	/SIZE CONTROL WORD FOR BLOAD.SV ROOT
	ERMSG2=	1712	/POST PROCESSOR ERROR SWITCH
	EOST=	7570	/UPPER LIMIT FOR SYMBOL TABLE
	INDEVH=	5600	/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=	205	/MAXIMUM STRING SIZE
	OUBUF=	400	/TEMP FILE OUTPUT BUFFER IN FIELD 1
	INBUF=	1000	/SOURCE FILE INPUT BUFFER IN FIELD 1
	BCERRO=	4	/OFFSET TO ERROR MESSAGE OVERLAY IN FIELD 1
	TXTOFS=	5	/OFFSET TO ERROR MESSAGE TEXT OVERLAY FOR FIELD 1
	F0OFFS=	11	/BLOCK OFFSET TO FIELD 0 FOR CHAIN FROM BASIC.SV OR BRTS

	AC4000=	CLA STL RAR
	AC2000=	CLA STL RTR
	AC7776=	CLL STA RAL
	AC7775=	CLL STA RTL
	/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
	LOADSN=	6000

	/JOC CLASS

	JSUB=	5000
	JUMP=	5001
	JGE=	5002
	JNE=	5003
	JGT=	5004
	JLT=	5005
	JEQ=	5006
	JLE=	5007
	JFOR=	5010
	JFOPEN=	5011
	JEOF=	5012

	/ARRAY CLASS

	AFADD=	6400
	AFSUB=	6440
	AFMPY=	6500
	AFDIV=	6540
	AFLDA=	6600
	AFSTA=	6640
	AISUB=	6700
	AIDIV=	6740

	/STRING CLASS

	SCON=	FADD
	SCOMP=	FSUB
	SREAD=	FMPY
	SARITH=	FDIV
	SLOAD=	FLDA
	SSTORE=	FSTA

	SACON=	AFADD
	SACOMP=	AFSUB
	SAREAD=	AFMPY
	ASARITH=AFDIV
	SALOAD=	AFLDA
	SASTOR=	AFSTA
	/OPERATE CLASS

	SETJF=	7401
	RNDO=	7421
	STOP=	7554
	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
	ONPFX=	7441
	SMODE=	7561
	NMODE=	7541
	FUNC1=	7416
	FUNC2=	7417
	FUNC3=	7400
	FUNC4=	7415
	FUNC5=	7414
	FUNC6=	7410
	USE=	7540
	SNEG=	FUNC2+240
	PUINIT=	FUNC3+160
	PUEXEC=	FUNC3+200
	WSUB=	FUNC6+020
	DEFREC=	FUNC6+100
	LOCATE=	FUNC6+040
	WEOR=	FUNC6+060
	RSUB=	FUNC6+000
	RECSIZ=	FUNC6+120
	VALFUN=	FUNC2+160
	STRFUN=	FUNC2+140
	/MAIN BCOMP ENTRY POINT

	*200

	JMP I	PRUNNED	/RUN VIA .R COMMAND
	JMP I	PCHAIN	/RUN VIA USR CHAIN FROM CCL
PRUNNED,RUNNED
PCHAIN,	CHAINED

	*STRLIM+1^2%3+1+WORD1	/ORIGIN PAST BIGGEST STRING LITERAL

	STOKSZ=	60

	2;-5;10;-21
STACKO,	ZBLOCK	STOKSZ

	PAGE
	/ASSEMBLE LINE

NEWLIN,	JMS I	QGETC	/ANY CHARS LEFT ?
	JMP	REMARK	/NO, LINE ENDED OK
	JMS I	QERMSG	/EXTRA CHARACTERS
	XCMSG
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,	CIF CDF	10
	JMS I	(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
	LTMSG
FLUSH,	CIF CDF	10
	JMS I	(ICHAR	/SKIP REST OF LINE
	JMP	NOSNUM+3
	CLA
	JMP	FLUSH
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 I	(KBDCHK	/CHECK FOR ^C OR ^O
	TAD	(KEYWRD-1
	DCA	X10	/SET UP FOR KEYWORD SEARCH
	JMS I	QSAVECP	/SAVE CHAR POS
KWLOOP,	JMS	KWGCH	/GET A KEYWORD CHAR FROM FIELD 1
	SZL		/LINK SET IF GOT DISPATCH ADDR
	JMP	GOTKW	/OK, THIS IS THE KW
NEXTKW,	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
	JMS	KWGCH	/SKIP OVER REST OF KEYWORD
	SNL CLA		/SKP IF AT END
	JMP	.-2
	CDF	10
	TAD I	X10	/IS THIS END OF LIST ?
	CDF
	SZA
	JMP	NEXTKW	/NO, KEEP LOOKING
	JMP I	(LET	/TREAT AS LET STMT
GOTKW,	DCA	TEMP	/SAVE ADDR OF ROUTINE
	JMP I	TEMP	/GO PROCESS THE STMT
KWGCH,	0
	CDF	10
	TAD I	X10	/PICK UP WORD
	CDF
	TAD	(200	/SEE IF IN RANGE 7600 TO 7777
	CLL
	TAD	(7600	/SET LINK IF NO
	JMP I	KWGCH	/RETURN WITH THE WORD
	/RESTORE STATEMENT

RESTOR,	JMS I	QLODSN	/OUTPUT LOAD STMT NUMBER
	CLA IAC		/NO COLON NEEDED
	JMS I	(GETFN	/LOAD FILE REG
	TAD	(REST	/OUTPUT RESTOR OP CODE
	JMS I	QOUTWRD
	JMP I	QNEWLIN

	/RETURN, RANDOMIZE AND STOP STATEMENTS

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

	PAGE
	/DIM PROCESSOR

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 I	(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 I	(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
	DIMSG
	JMP I	QREMARK	/ABORT STMT
	/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
	NFMSG
	JMP I	QREMARK
UMOPR,	40;1;UMRTNE-1
XLOAD,	FLDA;AFLDA

	PAGE
	/UDEF PROCESSOR (DEFINE USER FUNCTION)

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
	JMS	FUNSTK	/SAVE IN FUN TABLE
	JMS I	QLETTER	/GET THIRD LETTER
	JMP	DEFBAD
	JMS	FUNSTK	/SAVE NEG OF THIRD CHAR
	TAD	(-5	/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
	UDMSG
	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	(2	/ADJUST ARG NUMBER
	TAD	(2	/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	(10	/ADJUST COUNT
	CIA		/NEGATED
	DCA	DACNT
	CDF	10
	TAD I	FUNPTR	/GET FUNCTION CODE
	ISZ	FUNPTR	/BUMP POINTER
	CDF
	DCA	WORD1	/MAKE IT THE SEARCH OBJECT
	JMS I	(STCHEK	/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

FUNSTK,	0
	CIA		/NEGATE WORD
	CDF	10
	DCA I	FUNPTR	/STORE IN FIELD 1 TABLE
	ISZ	FUNPTR
	CDF		/RESET DF
	JMP I	FUNSTK

FUNPTR,	ENDFNS
NFUNS,	-21

	PAGE
	/DEF PROCESSOR

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 I	(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
	DEMSG
	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 I	(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 I	(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 I	(RESARG	/FINISH DEF

	PAGE
	/DEF PROCESSOR (FINALE)

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
	/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
	CMA		/NEGATE AND INCLUDE SIZE WORD
	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	DLSIZE	/Increment negative size count and test for overflow
	CIA
	STL CIA		/Force limit test to succeed for first entry
	TAD	TEMP
	SNL SZA		/Link must transition on above add
	JMP	DATAOK	/JMP if ok
	JMS I	QERMSG	/else give error
	TDMSG
	JMP I	(ABORT	/We must abort on this error
DATAOK,	DCA	DLSIZE
	TAD	(EOST	/HOW MUCH DO WE NEED ?
	TAD	TEMP
	DCA	.+2
	JMS I	(STCHEK	/ASK FOR IT
	0
	TAD I	(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
	/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

	PAGE
	/FOR PROCESSOR

FOR,	JMS I	QLODSN	/OUTPUT STMT NUMBER
	JMS I	QGETNAM	/GET INDEX VARIABLE
	JMP I	(BADFOR	/BAD
	TAD	TYPE	/MUST BE NUMBER
	SZA CLA
	JMP I	(BADFOR	/ITS NOT
	JMS I	QLOOKUP	/ST SEARCH
	TAD	SYMBOL	/SAVE INDEX VAR
	DCA	FINDEX	/FOR LATER
	JMS I	QCHECKC	/FIND =
	-75
	JMP I	(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 I	(BADFOR
	CLA
	JMS I	QSAVECP	/SAVE THIS POSITION
	JMS I	QCHKWD	/LOOK FOR "TO"
	WTO
	JMP	FINDTO	/KEEP GOING
	JMS I	(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 I	(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 I	(BADFOR	/YES, ERROR
	TAD	FORNC	/RESTORE CHAR POSITION
	DCA	NCHARS	/FROM SPECIAL PLACE
	TAD	FORCP
	DCA	CHRPTR
	JMS I	(FSUB1	/COMPILE INITIAL VALUE INTO FAC
	JMS I	(STCHEK	/CHECK FOR ROOM
	EOST
	TAD I	(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
	/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
	UUMSG
	CLL CML RTR	/SET DIM BIT
	DCA	TYPE
	JMS I	QLOOKUP	/LOOKUP SYMBOL
	TAD	SYMBOL	/OUTPUT ARRAY NUMBER
	JMS I	QOUTWRD
	JMP I	QREMARK

	PAGE
	/IF AND IFEND PROCESSORS

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 I	(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
	IFMSG
	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
IFOPEN,	TAD	(JFOPEN-JEOF
IFEND,	TAD	(JEOF	/SETUP CORRECT JUMP
	DCA	RELOPR
	JMS I	QLODSN	/OUTPUT STMT NUMBER
	CLA IAC		/(NO COLON)
	JMS	GETFN	/GET FILE NUMBER
	JMP	NUMCMP	/GO FIND "THEN" OR "GOTO"
RELOPR,	0

	/GET FILE NUMBER

GETFN,	0	
	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	/SEE IF COLON REQUIRED
	SZA CLA		/SKP IF YES
	JMP	NCNEED	/ELSE SKP THIS TEST
	JMS I	QGETC	/Get a char
	JMP	BADFN	/Error if none
	TAD	(-72	/Test if :
	SZA
	TAD	(72-54	/Test if ,
	SZA CLA		/SKP If either of above
	JMP	BADFN	/Else error
NCNEED,	JMS I	QLOAD	/LOAD IT
	TAD	TYPE1	/TYPE MUST BE NUMERIC
	SPA CLA
BADFN,	JMS I	QERMSG	/NOPE, IT ISN'T
	FNMSG
	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

	PAGE
	/TABLE SEARCH FOR LITERALS, STMT NUMBERS, TEMPS, ETC.

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

	/CHECK FOR ENOUGH ROOM

STCHEK,	0	
	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
	STMSG
	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 I	(TTX+1	/NOP TTY OUTPUT ROUTINE
	JMP I	KBDCHK

WSTEP,	-123;-124;-105;-120;0

	PAGE
	/SYMBOL TABLE LOOKUP

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 I	(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
	/FILE AND CLOSE PROCESSORS

FILE,	JMS I	QLODSN	/OUTPUT STATEMENT 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 I	(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
	FN2MSG
	TAD I	FILESW	/GET CORRECT OPEN
	JMS I	QOUTWRD
	JMS I	(GRSIZE	/GO GET RECORD SIZE (IF ANY)
	JMP I	QNEWLIN
FOPENS,	OPENAF;OPENAV;OPENNF;OPENNV
FILESW,	0

	PAGE
	/EXPRESSION ANALYZER

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 I	(BADEXP	/BAD SUB EXPRESSION
	JMS I	QCHECKC	/LOOK FOR )
	-51
	SKP		/ERROR
	JMP	OPR8R	/GOTIT
	JMS I	QERMSG	/PARENTHESIS MIS MATCH
	MPMSG
	JMP I	(BADEXP
OPRAND,	JMS I	QBACK1	/PUT BACK NON UNARY OP
	JMS I	QGETNAM	/LOOK FOR VARIABLE REF
	JMP I	(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 I	(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
	MOMSG
	JMP I	(BADEXP

MINUS,	40;0;XISUB;XSUB
SLASH,	50;0;XIDIV;XDIV

	PAGE
	/EXPRESSION ANALYZER (HANDLE SUBSCRIPTS)

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 I	(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 I	(OPR8R	/GO GET AN OPERATOR
BADFSS,	TAD	(-4	/PURGE STACK JUNK
	TAD	STACK
	DCA	STACK
	JMS I	QERMSG	/PUT ERROR MESSAGE
	SSMSG
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 I	(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 I	(NEWVAR	/IF NEW, GIVE IT NUMBER
	JMP	ONSTAK	/GO PUT IT ONTO THE STACK
NOTNUM,	JMS I	QSTRING	/LOOK FOR STRING LITERAL
	JMP I	(MISARG	/NO, MISSING ARG
			/RETURN WITH NUMBER OF WORDS OF 3 FOR 2 DATA
	CMA		/NEGATE AND INCLUDE SIZE WORD
	DCA	.+3	/FOR LOOKUP
	JMS I	QLUKUP2	/LOOK UP LITERAL
	SLITRL
	0
	JMS I	(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

	PAGE
	/EXPRESSION ANALYZER (HANDLE FUNCTION CALLS)

DOCALL,	TAD	LEFT	/IS THIS LEFT SIDE ?
	SMA CLA		/IF YES, FUN ILLEGAL
	JMS	OUTCAL	/GENERATE CALL
	SKP		/SKIP IF ERROR
	JMP I	(OPR8R	/GO LOOK FOR OPERATOR
	JMS I	QERMSG	/BAD FUNCTION REFERENCE
	FRMSG
	JMP I	(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
	FPMSG
	JMP I	QREMARK
FSUB2,	0		/FOR SUBROUTINE #2
	JMS	FSUB1	/GET EXPR AND LOAD IT
	JMS I	(GENTMP	/MAKE A TEMP FOR IT
	TAD	SYMBOL	/STORE EXPR IN TEMP
	TAD	(FSTA
	JMS I	QOUTWRD
	TAD	SYMBOL	/RETURN SLOT #
	JMP I	FSUB2

	/FORGET REGISTERS

FUNNUM,
NOREGS,	0	
	CLA IAC		/FILE NUMBER REG
	DCA	IFNREG
/	CMA		/SUBSCRIPT REG #1
/	DCA	SSREG1
/	CMA		/SUBSCRIPT REG #2
/	DCA	SSREG2
	JMP I	NOREGS
	/CLOSE STATEMENT

CLOSE,	JMS I	QLODSN	/OUTPUT STMT NUMBER
CLOSLP,	CLA IAC		/NO COLON NEEDED AFTER FILE NUM
	JMS I	(GETFN	/GET FILE NUM
	TAD	(CLOSEF	/OUTPUT CLOSE
	JMS I	QOUTWRD
	JMS I	QCHECKC	/See if another file number
	-54
	JMP I	QNEWLIN	/Jmp if no
	JMP	CLOSLP	/Else do another CLOSE

PSETJF,	0
	TAD	(SETJF
	JMS I	QOUTWRD
	JMS I	QPOP	/GET INDEX VAR
	DCA	FINDEX
	JMP I	PSETJF

	PAGE
	/CODE GENERATOR

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 I	(GETA1	/GET STUF FOR ARG1
	TAD	TYPE1	/LOOK AT IT
	AND	Q400
	SZA CLA
	JMP	ACM	/ITS CASE AC,M
MM,	TAD	TYPE2	/FORCE CORRECT MODE IN CASE OF STRING ARITH
	JMS I	QMODSET	/(A USELESS MODSET MAY BE OUTPUT-UGH!)
	TAD I	CASEMM	/ITS CASE M,M  LOAD OPERAND 2
	TAD	SYMBL2
	JMS I	QOUTWRD
	SKP
MAC,	JMS I	(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	TYPE1	/SEE IF STRING OPERAND
	SMA CLA
	JMP	A1NUM	/JMP IF NUMERIC TO BYPASS STRING ARITH CONVERT
	JMS I	(SARCVT	/ELSE CONVERT OPCODE IF +,-,* OR /
CASEMA,	0
	SYMBL1		/POINTER TO SYMBOL NUMBER FOR OPERAND 1
A1NUM,	TAD I	CASEMA	/GET CORRECT INSTRUCTION IF NUMERIC OR NOT STRING ARITH
	TAD	SYMBL1	/PLUS SYMBOL NUMBER
OUTIT,	JMS I	QOUTWRD	/OUTPUT IT
TYPCHK,	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	TYPE2	/SEE IF OPERAND 2 STRING
	SMA CLA
	JMP	ACMNUM	/NO, PROCESS NORMALLY
	JMS I	(SARCVT	/YES, DO STRING OPCODE CONVERT IF NECESSARY
CASEAM,	0		/POINTER TO CODE SKELETON FOR AC,M CASE
	SYMBL2		/POINTER TO OPERAND 2 ADDR
ACMNUM,	TAD I	CASEAM	/ITS CASE AC,M
	TAD	SYMBL2	/GEN OPERATION FOR OPERAND 2
	JMP	OUTIT	/GO FINISH IT UP
MIXED,	JMS I	QERMSG	/MIXED TYPES
	MTMSG
	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

UMRTNE,	JMS I	QSAVAC	/SAVE CURRENT AC IF NEEDED
	-3
	JMS I	QLOAD	/GET ARG IN AC
	TAD	TYPE1	/TEST TYPE OF ARG
	SMA CLA
	JMP	NUMUMI	/JMP IF NUMERIC UNARY MINUS
	CLA STL RAR	/SET UP FOR STRING UNARY MINUS
	DCA	TYPE
	TAD	TYPE
	DCA	TYPE2
	TAD	(SNEG	/NOW OUTPUT STRING NEGATE
	JMP	OUTIT
NUMUMI,	DCA	TYPE	/TYPE MUST BE NUMERIC
	DCA	TYPE2
	TAD	(FNEG	/DO NEGATE
	JMP	OUTIT

EXPRTN,	DCA	TYPE	/SET FUNC TYPE
	CLL CML RTL	/SET NUMBER OF ARGS
	DCA	TEMP
	TAD	(FUNC1+60
	DCA	SYMBOL	/EXP2
	JMS I	(OUTCAL	/OUTPUT FUNCTION CALL
	JMP	MIXED	/ERROR
	JMP I	OUTOPR	/DONE
CASEMM,	0
TYPE2,	0
SYMBL2,	0

	PAGE
	/LETTER AND DIGIT SCANNERS

	/SKIP ON LETTER

LETTER,	0	
	JMS I	QGETC
	JMP I	LETTER	/NO LETTER
	TAD	(-133	/MUST BE .LT. 133
	STL
	TAD	(133-100 /MUST BE .GT. 100
	SZA SNL
	ISZ	LETTER	/BUMP RETURN IF IN RANGE, AC=6 BIT CHAR
	SNA SZL
	JMS I	QBACK1	/RESET SCAN PTR IF OUT OF RANGE
	JMP I	LETTER	/RETURN

	/SKIP ON DIGIT

DIGIT,	0	
	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
	SZL
	ISZ	DIGIT	/RETURN DIGIT MINUS 60
	SNL
	JMS I	QBACK1	/PUT IT BACK
	JMP I	DIGIT
	/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
	SNA		/SKP IF NON LEADING ZERO
	JMP	.-3	/ELSE IGNORE, (LINE NUMBER ZERO PROHIBITED)
	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
	MDMSG
	JMP I	SNUM

	/CONVERT TO ASCII AND PRINT

TTY,	0	
	TAD	(240
	AND	(77
	TAD	(240	/EXPAND TO 7BIT
	JMS	TTX	/PRINT CHAR
	JMP I	TTY	/RETURN

	/PRINT CHAR ON TTY

TTX,	0	
	SKP		/(CONTROL O ZEROES THIS WORD)
	JMP	.+4	/(THUS KILLING ERROR REPORTING)
	TSF
	JMP	.-1
	TLS
	CLA
	JMP I	TTX
	/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
	FN2MSG		/(OK IF ERROR CODE IS NOP)
	TAD	(CHN	/OUTPUT CHAIN OPCODE
	JMS I	QOUTWRD
	JMP I	QNEWLIN

XISUB,	FISUB;AISUB

	PAGE
	/SEVERAL SHORT UTILITY ROUTINES

	/BACK UP 1 CHAR

BACK1,	0	
	CLA CMA
	TAD	NCHARS
	DCA	NCHARS
	CLA CMA
	TAD	CHRPTR
	DCA	CHRPTR
	JMP I	BACK1

	/GET A CHAR PRESERVING BLANKS

GETCWB,	0	
	ISZ	NCHARS
	JMP	.+4
	CLA CMA
	DCA	NCHARS	/RESET NCHARS
	JMP I	GETCWB
	ISZ	GETCWB
	TAD I	CHRPTR	/GET THE CHAR
	JMP I	GETCWB

	/SAVE CHAR POSITION

SAVECP,	0	
	TAD	NCHARS
	DCA	NCSAVE
	TAD	CHRPTR
	DCA	CPSAVE
	JMP I	SAVECP

	/RESTORE CHAR POSITION

RESTCP,	0	
	TAD	CPSAVE
	DCA	CHRPTR
	TAD	NCSAVE
	DCA	NCHARS
	JMP I	RESTCP

	/GET A CHARACTER IGNORING BLANKS AND TABS
	/CONVERTS LOWER CASE TO UPPER CASE

GETC,	0	
	ISZ	NCHARS
	JMP	.+4
GETCX,	CLA CMA
	DCA	NCHARS
	JMP I	GETC
	TAD I	CHRPTR
	TAD	(-41	/IS IT !
	SNA		/SKP IF NO
	JMP	GETCX	/ELSE TREAT AS END OF LINE
	IAC		/IS IT BLANK
	SZA		/SKP IF BLANK
	TAD	(40-11	/TRY TAB INSTEAD
	SNA
	JMP	GETC+1	/YES IGNORE IT
	TAD	(11-173	/NOW SEE IF LOWER CASE
	CLL
	TAD	(32
	SZL		/SKP IF NOT LOWER CASE
	TAD	(-40	/ELSE CONVERT TO UPPER CASE
	TAD	(173-32	/NOW RESTORE CHARACTER
	ISZ	GETC
	JMP I	GETC

	/GET TOP OF STACK

POP,	0	
	TAD	STACK
	DCA	PUSH
	CLA CMA
	TAD	STACK
	DCA	STACK	/DECREMENT STACK POINTER
	TAD I	PUSH
	JMP I	POP

	/PUT AC ONTO STACK

PUSH,	0	
	DCA I	STACK	/STORE
	TAD	(-STACKA-STAKSZ+1
	TAD	STACK	/CHECK FOR OVERFLOW
	SPA CLA
	JMP I	PUSH	/OK, RETURN
STKOVR,	JMS I	QERMSG
	PDMSG
	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

NCSAVE,	0
CPSAVE,	0

	PAGE
	/TEMP GENERATORS AND AC SAVING ROUTINES

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 I	(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 I	(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
	/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
	SSMSG
	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
STAR,	50;0;XMUL;XMUL

	PAGE
	/NUMERIC CONVERSION ROUTINE (PART ONE)

NUMBER,	0		/GENERAL NUMBER CONVERSION ROUTINE
	DCA	DECPT	/ZERO DECIMAL POINT SWITCH
	DCA	WORD1	/ZERO FAC
	DCA	WORD2
	DCA	WORD3
	DCA	ACO
	DCA	TRLDIG	/CLEAR COUNT OF EXCESS DIGITS TO LEFT OF DP
	DCA	SIGN	/CLEAR SIGN SWITCH
	JMS I	QGETC	/GET A CHAR
	JMP I	NUMBER	/NO CHAR IS NO NUMBER
	JMS I	(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
	TAD	WORD2	/SEE IF NEXT DIGIT WILL FIT IN REGISTER
	TAD	(-304	/WILL FIT IF HIGH WORD LT 2048/10 = 204
	SPA CLA		/SKP IF NO FIT
	JMP	DGFITS
	TAD	DECPT	/COUNT DIGIT IF DECIMAL POINT NOT SEEN YET
	SNA CLA
	ISZ	TRLDIG
	JMP	CONVLP	/BUT IGNORE DIGIT OTHERWISE
DGFITS,	ISZ	NDIGIT	/INCR NUMBER OF DIGITS
	JMS I	(MPY10	/MULT 35 BIT REGISTER BY 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	(-105	/COMPARE TO "E"
	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 I	(CHKSGN	/IS IT A SIGN
FPRTNE,
ESIGN,	0		/THIS IS THE SWITCH TO SET
	JMS I	(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
	TAD	TRLDIG	/ADD COUNT OF EXCESS DIGITS LEFT OF DP
	SMA
	JMP	POSEXP	/EXPONENT IS POSITIVE
	CIA
	DCA	EXPON	/ONLY NEED ABS VALUE
	TAD	(FINV10-1 /DO INVERSE POWERS OF 10
	JMP	.+3
POSEXP,	DCA	EXPON
	TAD	(F10-1	/USE POWERS OF TEN
	DCA	X11	/POINT AT 4 WORD FLOATING POINT VALUES
	TAD	(-6	/INITIAL EXPONENT
	SKP
NEWEXP,	STA		/DROP DOWN TO UNITY POWER OF 10
	DCA	TEMP2
	TAD I	X11	/GET THE MULTIPLIER
	DCA	OP1
	TAD I	X11
	DCA	OP2
	TAD I	X11
	DCA	OP3
	TAD I	X11
	DCA	OPO
EXPMUL,	TAD	EXPON	/SEE IF DECIMAL EXPONENT REDUCED TO ZERO
	SNA
	JMP	DOSIGN	/YES, ROUNDOFF AND SET SIGN
	TAD	TEMP2	/NO, REDUCE IT
	SPA		/SKP IF NOT NEAR ZERO YET
	JMP	NEWEXP	/ELSE REDUCE TO 1E1 OR 1E-1
	DCA	EXPON	/UPDATE DECIMAL EXP
	JMS I	(FPMUL	/DO 36 BIT MULTIPLY AND NORMALIZE
	JMP	EXPMUL	/TRY AGAIN
DOSIGN,	JMS I	(ROUND	/NOW ROUND TO 23 BITS
	TAD	SIGN	/CHECK THE SIGN
	SZA CLA
	JMS I	(NEGFAC	/NEGATE IF NEGATIVE
	ISZ	NUMBER	/BUMP RETURN
	JMP I	NUMBER	/RETURN

	PAGE
	/NUMERIC CONVERSION ROUTINE (PART TWO)

FPMUL,	0		/FLOATING MULTIPLY ROUTINE
	TAD	WORD1	/COMPUTE NEW EXPONENT
	TAD	OP1
	DCA	WD1SAV
	TAD	WORD2	/SAVE AC MANTISSA
	DCA	TW2
	TAD	WORD3
	DCA	TW3
	TAD	ACO
	DCA	TWO
	TAD	(-44	/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
	TAD	TWO
	RAR
	DCA	TWO
	SZL
	JMS	OADD	/ADD IF LINK IS ONE
	ISZ	ITRCNT	/BUMP COUNT
	JMP	MULLUP	/LOOP
	TAD	WD1SAV	/PUT IN CORRECT EXPONENT
	DCA	WORD1
	JMS	ANORM	/NORMALIZE THE RESULT
	JMP I	FPMUL

WD1SAV,	0
TW2,	0
TW3,	0
TWO,	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

ROUND,	0
	TAD	ACO	/SEE IF BIT 24 SET
	SMA CLA
	JMP	RNDXIT	/NO, EXIT
	ISZ	WORD3	/PROPAGATE TO LOW WORD
	JMP	RNDXIT
	ISZ	WORD2
	TAD	WORD2	/SEE IF CARRY OUT OF NORMALIZE BIT
	SPA CLA
	JMS I	(AR1	/YES, ADJUST RIGHT
RNDXIT,	DCA	ACO	/CLEAR OVERFLOW
	JMP I	ROUND	/--RETURN--

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

F10,	24;3641;1000;0		/10^6
	4;2400;0;0		/10^1
FINV10,	-23;2061;5736;4055	/10^-6
	-03;3146;3146;3146	/10^-1

	PAGE
	/NUMERIC CONVERSION ROUTINE (FINALE)

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
	/STRING LITERAL SCANNER

STRING,	0
	JMS I	QCHECKC	/LOOK FOR "
M42,	-42
	JMP I	STRING	/NONE MEANS NO STRING
	ISZ	STRING
	DCA	WORD1	/ZERO CHAR COUNT
	TAD	(WORD2-1	/SETUP POINTER
	DCA	TEMP
	TAD	(-STRLIM%3	/AND MAX SIZE
	DCA	TEMP2
SLOOP,	JMS	GCS	/GET HIGH ORDER CHAR
	ISZ	TEMP	/TALLY ANOTHER WORD USED
	DCA I	TEMP	/STORE CHAR
	TAD	TEMP	/SAVE POINTER TO WORD 1
	DCA	STMP
	JMS	GCS	/GET ANOTHER CHAR
	ISZ	TEMP	/TALLY ANOTHER WORD
	DCA I	TEMP	/STORE LOW 7 BITS
	JMS	GCS	/GET ANOTHER CHAR
	DCA	GCS	/SAVE IT
	TAD	GCS
	CLL RTL		/SHIFT UP
	RTL
	AND	(7400	/MASK
	TAD I	STMP	/ADD TO PREV WORD AND STORE
	DCA I	STMP
	TAD	GCS	/GET LOW NIBBLE AND STORE
	CLL RTR
	RTR
	RAR
	AND	(7400
	TAD I	TEMP
	DCA I	TEMP
	ISZ	TEMP2	/TEST BUFFER LIMIT
	JMP	SLOOP	/JMP IF MORE ROOM
	JMS I	QGETC	/MAX SIZE STRING MUST HAVE " TERMINATING
	JMP	STRGER	/ERROR
	TAD	M42	/TEST IF "
	SNA CLA
	JMP	STROUT	/OK, RETURN
STRGER,	JMS I	QERMSG	/STRING ERROR
	QSMSG
	JMP I	QREMARK	/FLUSH REST OF STATEMENT
STROUT,	TAD	TEMP	/RETURN NUMBER OF WORDS REQUIRED FOR STRING
	TAD	(-WORD2+1
	JMP I	STRING
STMP,	0
	/GET A CHAR FOR STRING

GCS,	0
	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	STROUT	/NO, THAT WAS IT
	TAD	M42	/LOOK FOR SECOND "
	SNA CLA
	JMP	NOTQOT	/"" BECOMES "
	JMS I	QBACK1	/PUT IT BACK
	JMP	STROUT	/LITERAL IS DONE
NOTQOT,	TAD	(42	/RECREATE CHAR
	ISZ	WORD1	/BUMP STRING COUNT
	JMP I	GCS

XIDIV,	FIDIV;AIDIV
WPNT,	-120;-116;-124;-50;0

	PAGE
	/VARIABLE OR FUNCTION REFERENCE SCANNER

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
	CDF	10	/GET INTO FIELD 1
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,	CDF
	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,	CDF
	JMS I	QRESTCP	/RESTORE CHAR POS
	JMP	LFDOLR	/LOOK FOR Q$] Q(]
USRFUN,	TAD	NAME3	/GENERATE FUN NUMBER
	JMP	FUNOK
	/Error message reporter
	/CALL+1 = relative address of message text in error overlay
	/Since all errors are fatal, the temp file output buffer is
	/used for the overlay and compilation is aborted after first pass

ERMSG,	0		/PRINT ERROR MESSAGE
	CLA
	CDF	10
	TAD I	(INFO+1	/GET BASE BLOCK OF BCOMP.SV
	TAD	(BCERRO	/ADD OFFSET TO ERROR MESSAGE OVERLAY
	DCA	ERRBK	/STORE INLINE
	CDF
	JMS I	(7607	/READ OFF SYS:
	0210		/2 PAGES TO FIELD 1
	OUBUF		/INTO OUTPUT BUFFER
ERRBK,	0		/FROM HERE
	HLT		/CRASH ON I/O ERROR
	CIF CDF	10	/JMP TO ERROR MESSAGE PRINTER
	JMS I	(XERMSG
	ISZ	ERMSG
	JMP I	ERMSG	/RETURN TO CALLER

WGOSUB,	-107;-117;-123;-125;-102
AMPSND,	40;1;AMPRTN-1;4000;SCONTS;SCONTS
SCONTS,	FADD;AISUB

	/MULTIPLY FAC BY 10.

MPY10,	0
	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
	JMP I	MPY10	/--RETURN--

	PAGE
	/LET STATEMENT PROCESSOR

LET,	JMS I	QGETC	/SEE IF ANYTHING IN LINE
	JMP I	QREMARK	/IGNORE LINE IF NO
	JMS I	QBACK1	/OK, PUT BACK CHARACTER
	JMS I	QLODSN	/LOAD THE STMT NUMBER
	CLL CML RAR	/COMPILE LEFT SIDE
	JMS I	QEXPR	/GET EXPRESSION
	JMP I	QREMARK
	JMS I	QCHECKC	/LOOK FOR =
	-75
	JMP	BADLET	/BAD IF MISSING
	JMS I	QEXPR	/GET RIGHT SIDE
	JMP I	QREMARK
	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 I	QNEWLIN
BADLET,	JMS I	QERMSG	/BAD LET STMT
	LSMSG
	JMP I	QREMARK
	/RESTORE, PRINT, AND INPUT PROCESSORS

INPUT,	JMS I	QLODSN	/OUTPUT STMT NUM
	JMS I	(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	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
DIMREA,	JMS I	QLOADSS
	TAD	(READ
	JMS I	QOUTWRD
	TAD	(AFSTA
	JMP	FININP
	/ON <expr> GOTO or GOSUB l1,l2,l3,...
	/This statement emits the expression followed by a prefix opcode
	/A list of GOTO or GOSUB opcode/address pairs follows for each
	/line number, terminated by a zero pair.  Runtime scans this vector
	/for the branch addr.

ONGO,	JMS I	QLODSN	/load the statement number first
	JMS I	QMODSET	/be sure interpreter is in NMODE
	JMS I	QEXPR	/Compile <expr>
	JMP I	QREMARK
	JMS I	QLOAD	/Load FAC with result
	TAD	TYPE1	/Type must be numeric
	SPA CLA		/Skp if yes
	JMP	ONSNTX	/Jmp if no, syntax error
	TAD	(ONPFX	/Emit ON prefix opcode
	JMS I	QOUTWRD
	JMS I	QSAVECP	/Save scan pointer
	JMS I	QCHKWD	/See if GOSUB
	WGOSUB
	SKP		/Skp if no
	JMP	ONGOSU	/Jmp if yes
	JMS I	QRESTCP	/Reset scan pointer
	JMS I	QCHKWD	/See if GOTO
	WGOTO
	JMP	ONSNTX	/Jmp if neither
	IAC		/JUMP = GOSUB+1
ONGOSUB,TAD	(JSUB
	DCA	ONTEMP	/Save the branch opcode
ONLUP,	JMS I	QSNUM	/Get a line number
	JMP	ONSNTX	/Syntax error if none
	TAD	TEMP	/Make branch opcode
	TAD	ONTEMP
	JMS I	QOUTWRD	/Emit it
	TAD	TEMP2	/Emit the addr too
	JMS I	QOUTWRD
	JMS I	QCHECKC	/See if ,
	-54
	SKP		/No, finish off
	JMP	ONLUP	/Else get next line number
	JMS I	QOUTWRD	/Now mark end of vector
	JMP I	QNEWLIN	/Done
ONSNTX,	JMS I	QERMSG	/Report error
	ONMSG
	JMP I	QREMARK	/Flush statement
ONTEMP,	0

	PAGE
	/INPUT DEVICE HANDLER

	*INDEVH

NAMLST,	BCOMPN		/SAVE FILE NAME-POINTER LIST
	BLOADN
	BRTSN
	BOVN
	0

BASICN,	FILENAME BASIC.SV		/FILE NAMES
BCOMPN,	FILENAME BCOMP.SV		/FOR LOOKUPS
BLOADN,	FILENAME BLOAD.SV
BRTSN,	FILENAME BRTS.SV
BOVN,	FILENAME BASIC.OV
BUFN,	FILENAME BASIC.UF
TMPFIL,	FILENAME BASIC.TM

VTEXT,	TEXT	/BCOMP  V/
	*.-1
VERLOC,	VERSON^100+6001
	0
VERNUM,	0
	TAD	(VTEXT
	DCA	TEMP
	TAD	(-5
	DCA	TEMP2
	TLS
MOREV,	TAD I	TEMP
	CLL RTR
	RTR
	RTR
	JMS I	(TTY
	TAD I	TEMP
	JMS I	(TTY
	ISZ	TEMP
	ISZ	TEMP2
	JMP	MOREV
	TAD	(215
	JMS I	(TTX
	TAD	(212
	JMS I	(TTX
	TSF		/WAIT FOR TTY TO GET DONE
	JMP .-1		/BEFORE RETURNING
	JMP I	VERNUM

	PAGE
	/INITIALIZATION CODE FOR RUN CASE

RUNNED,	CIF	10	/COME HERE IF .R BCOMP
	JMS I	(200	/CALL COMMAND DECODER
	5
	0201		/ASSUMED EXTENSION "BA"
RUNGO,	CDF 10
	TAD I	(CDOPT4	/TEST FOR /V
	CDF
	AND	(4
	SZA CLA
	JMS I	(VERNUM
	TAD	(INFO-1
	DCA	X10
	CDF	10
	TAD I	(7617
	CDF
	SNA CLA		/NULL INPUT?
	JMP	RUNNED	/YES: NAUGHTY
	TAD I	(BIPCCL
	CLL RAL		/BATCH RUNNING
	SPA CLA
	JMP	SAVBOS	/YES
	CDF 10
	JMP	ZEREDT	/GO ZERO EDITOR BLOCK NUMBER
SAVBOS,	TAD	(INFO-5
	DCA	X10
	TAD I	(BIPCCL
	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
ZEREDT,	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 I	(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
	DCA I	X10	/CLEAR UNUSED WORDS
	DCA I	X10
STRT3,	CDF
	CLA IAC		/ENTER TEMPORARY FILE
	CIF	10
	JMS I	(200
	3
TMPBLK,	TMPFIL
	0
	JMP I	(NG
	TAD	TMPBLK	/SAVE START OF TEMP FILE
	DCA I	(OUBLOK
	TAD	TMPBLK	/IN A COUPLE PLACES
	DCA	BLOCK
	TAD	TMPBLK+1/ALSO THE SIZE
	DCA I	(OUSIZE
	JMP I	(GETDEV	/GO FETCH DEVICE HANDLER

BRTCHN,	CIF	10	/DO A RESET ON CHAIN FROM BRTS
	JMS I	(200	/TO FORGET ANY UNCLOSED FILES
	13		/RESET
	JMP	STRT3	/GO ENTER TEMPORARY FILE

BOSCTR,	7774

	PAGE
	/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
	TAD I	QERMSG	/SEE IF ANY ERRORS SO FAR
	SZA CLA		/SKP IF NONE
	JMP I	OUDUMP	/ELSE QUICKLY EXIT
	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
	OFMSG
	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 I	(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
	/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
	NMMSG		/NUMBER MISSING
	JMP I	QREMARK

	PAGE
	/WORD CHECKER

CHKWD,	0	
	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

	/END STATEMENT

END,	TAD	(STOP	/OUTPUT STOP OPCODE
	JMS I	QOUTWRD
	TAD I	(OUDUMP	/SKP IF NO TEMP FILE WRITES WERE DONE
	SZA CLA
	JMS I	(OUDUMP	/DUMP BUFFER
	TAD I	(OUDUMP	/PASS FLAG TO BLOAD
	DCA	OUTFLG
	TAD I	(FREFLD	/ALSO PASS HIGHEST S.T. CDF USED
	DCA	THSFLD	/'NEXT' CONTAINS THE HIGHEST ADDRESS
	TAD I	QERMSG	/SEE IF ANY PASS 1 ERRORS
	SZA CLA		/SKP IF NONE
	JMP	ABORT	/ELSE ABORT COMPILATION
			/NECESSARY SINCE ERROR MESSAGE OVERLAY CLOBBERS OUBUF
	JMS I	(7607	/READ IN POST PROCESSOR
	BLDSZ0		/THIS MUCH
POSTX,	400		/FROM 400
LDRBLK,	0		/FROM THIS BLOCK
	JMP I	XABORT
/	TAD I	QERMSG	/SET POST PROCESSOR ERROR SWITCH
/	DCA I	(ERMSG2
	JMP I	POSTX	/START IT UP

	/HANDLE END OF FILE

ENDFIL,	TAD	TEMP3	/TEST IF FILE ENDED CLEANLY
	TAD	(LINMAX
	SNA CLA		/SKP IF EXTRA CHARS AT END OF FILE
	JMP	END	/ELSE ALLOW LACK OF END STATEMENT
	JMS I	QERMSG	/INPUT FILE ERROR
	MEMSG
ABORT,	TAD	(4207	/RESTORE ^C LOCZTIONS
	DCA I	(7600
	TAD	(6213
	DCA I	(7605
	CDF	10
	TAD I	(INFO	/GET START OF BASIC.SV
	CDF
	SNA
	JMP I	(7605	/T'WERE RUNNED
	DCA	EDTBLK	/SAVE MAGICAL BLOCK NUMBER
	JMS I	(7607	/USE SYS HANDLER
	EDTSIZ		/TO READ IN THIS MUCH
	0		/INTO ZERO
EDTBLK,	0		/FROM HERE
	HLT		/HALT IF BAD READ
	JMP I	(EDTBGN	/GO RESTART EDITOR

	/SET INTERPRETER MODE

MODSET,	0	
	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

	/ROUTINE TO GET RECORD SIZE IN FILE STMT

GRSIZE,	0
	JMS I	QCHECKC	/SEE IF ,
	-54
	JMP I	GRSIZE	/NO, RETURN
	JMS I	QEXPR	/OK, GET EXPRESSION
	JMP I	GRSIZE
	JMS I	QLOAD	/LOAD TO AC
	TAD	TYPE1	/SEE IF NUMERIC
	SMA CLA
	JMP	.+3
	JMS I	QERMSG	/ERROR IF NOT
	REMSG
	TAD	(RECSIZ	/EMIT RECSIZE OPCODE
	JMS I	QOUTWRD
	JMP I	GRSIZE	/DONE

WGOTO,	-107;-117
WTO,	-124;-117	/FOLLOWED BY POSITIVE WORD
PLUS,	40;0;XADD;XADD

IFOPS,	JNE;-7476	/<>
	JNE;-7674	/><
	JGE;-7576	/=>
	JGE;-7675	/>=
	JLE;-7574	/=<
	JLE;-7475	/<=
	0
	JEQ;-7500	/=
	JGT;-7600	/>
	JLT;-7400	/<
	0

	PAGE
	/ROUTINE TO CONVERT ARITHMETIC OPCODES TO
	/STRING ARITHMETIC PREFIX AND OPCODE
	/CALLED IF TYPE OF OPERAND IS STRING

SARCVT,	0
	TAD I	SARCVT	/PICK UP ADDR OF SKELETON IN CALL+1
	ISZ	SARCVT
	DCA	SARCAS	/STORE POINTER TO IT
	TAD I	SARCVT	/NOW GET POINTER TO SYMBOL
	ISZ	SARCVT
	DCA	SARSYM	/SAVE IT

	TAD	(SARTAB-2 /SEE IF SKELETON IS MEMBER OF +,-,*,/ SET
	DCA	X10
SRCHL,	ISZ	X10	/SKIP OVER STRING SUB OPCODE
	TAD I	X10	/GET SKELETON TO COMPARE TO
	SNA
	JMP I	SARCVT	/RETURN AND PROCESS NORMALLY IF END OF LIST
	TAD	SARCAS	/COMPARE TO SKELETON POINTER
	SNA
	JMP	SARARY	/IF EQUAL, ITS AN ARRAY OPCODE
	IAC		/ELSE SEE IF ITS SCALAR
	SZA CLA		/SKP IF YES
	JMP	SRCHL	/ELSE TRY AGAIN
	TAD	(SARITH-ASARITH /OUTPUT SCALAR PREFIX OPCODE
SARARY,	TAD	(ASARITH	/OUTPUT ARRAY PREFIX
	TAD I	SARSYM	/ADD IN THE SYMBOL NUMBER
	DCA	SARSYM	/HOLD IT
	CLA STL RAR	/NOW FORCE STRING MODE
	JMS I	QMODSET
	TAD	SARSYM	/GET OPCODE AGAIN
	JMS I	QOUTWRD	/OUT IT
	TAD I	X10	/NOW OUTPUT THE SUB OPCODE
	JMS I	QOUTWRD
	CLA STL RAR	/CONVERT TYPE OF OPCODE TO STRING NOW
	TAD	TYPE
	DCA	TYPE
	SZL		/***CONSISTANCY TEST***
	HLT		/CRASH SYSTEM
	JMP I	(TYPCHK	/NOW TEST CONSISTANCY OF OPERAND TYPES

SARCAS,	0
SARSYM,	0
	/CONVERSION TABLE FROM NUMERIC SKELETONS TO
	/STRING ARITHMETIC PREFIX AND SUB-OPCODES

SARTAB,	-XADD-1;0
	-XSUB-1;1
	-XISUB-1;2
	-XMUL-1;3
	-XDIV-1;4
	-XIDIV-1;5
	0		/MARK END OF TABLE

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

	/OPERATOR TABLE

OPR8RS,	PLUS;-53
	MINUS;-55
	STAR;-52
	SLASH;-57
	UPAROW;-136
	AMPSND;-46
	0
SASIGN,	4000;XSTOR
ASSIGN,	0;XSTOR
XMUL,	FMPY;AFMPY

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

	PAGE
	/INITIALIZATION CODE

	*LINE

CHAINED,TAD	(INFO+7	/PICK UP SOME STUFF
	DCA	X10
	CDF	10	/FROM THE INFO BLOCK
	TAD I	X10	/SEE IF START OF TEMP FILE HERE
	SNA		/SKP IF HAVE TEMP FILE
	JMP I	(RUNGO	/ELSE MUST BE CHAIN FROM CCL
	DCA	BLOCK
	TAD I	X10	/SIZE OF HOLE
	CDF
	DCA I	(OUSIZE
	TAD	BLOCK
	DCA I	(OUBLOK
	CDF	10
	TAD I	X10	/ENTRY ADDR OF HANDLER
	DCA	HADDR	/PASS HANDLER FROM EDITOR AS IF A FETCH
	JMP	CLOBBER
GETDEV,	CDF	10
	TAD I	(7617	/GET DEVICE NUM FOR INPUT FILE
	CDF
	CIF	10
	JMS I	(200	/GO FETCH THE DEVICE
	1
HADDR,	INDEVH+1	/2 PAGE HANDLER IS OK
	JMP	NG	/ERROR
	CIF	10
	JMS I	(200	/RESET SYSTEM TABLES
	13		/DELETING TENTATIVE FILES
STRT2,	CDF	10
CLOBBER,TAD I	IOAD1	/CLOBBER THE USR NOW
	DCA I	IOAD2
	ISZ	IOAD1
	ISZ	IOAD2
	ISZ	IOCTR
	JMP	CLOBBER
	TAD I	(7617	/SET UP INPUT FILE PARAMS
	CDF
	AND	(7760	/GET SIZE
	TAD	(17
	CLL CML RTR
	RTR
	CDF	10	/INPUT ROUTINE IS IN FIELD 1
	DCA I	(INCTR
	TAD	HADDR
	DCA I	(INHNDL	/NOW PASS HANDLER ENTRY ADDR
	TAD I	(7620	/GET BLOCK NUMBER
	DCA I	(INREC
	TAD I	(INFO+3	/GET START OF BRTS.SV (+1)
	DCA	BRTS
	TAD I	(INFO	/GET START OF BASIC.SV (+1)
	DCA	ABORTX	/BOTH FOR BLOAD
	TAD I	(INFO+2	/GET START OF BLOAD.SV
	CDF
	DCA I	(LDRBLK	/FOR CHAIN TO BLOAD
	TLS		/SET TTY FLAG
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 I	(7600
	TAD	JABORT
	DCA I	(7605
	JMP I	(CORE	/GET CORE SIZE
NG,	TLS
	JMS I	QERMSG	/SUPER ERROR
	SYMSG
	TSF
	JMP	.-1
JABORT,	JMP I	XABORT	/ABORT COMPILATION
IOAD1,	2000		/START OF FIELD 1 LOAD AREA JUST ABOVE USR
IOAD2,	0000		/START OF ACTUAL EXECUTE AREA
IOCTR,	-2000		/8. PAGES

	PAGE
	/THIS PAGE GETS LOADED WITH THE RECORD I/O 
	/STATEMENT PROCESSORS JUST PRIOR TO STARTUP

CORE,	TAD I	(BIPCCL	/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
	CDF	10
	TAD I	(CDOPT6	/SEE IF = OPTION PASSED
	AND	(7	/LOOK AT LOW 3 BITS FOR FIELD
	SZA		/SKP IF NONE
	JMP	GOTLIM	/ELSE GOT A CORE LIMIT SPEC
	TAD I	(CDOPT3	/SEE IF /B PASSED
	RAL
	SMA CLA		/SKP IF YES, REDUCE ONE FIELD TO PRESERVE BATCH
	JMP	GOTLIM	/ELSE NO CORE RESTRICTION
	TAD	HIFLD
	TAD	(-7	/REDUCE 2 FIELDS IF 32 K, SINCE BATCH ONLY USES 6
	SNA		/ FIELDS FOR ROM-TD8E COMPATIBILITY
	STA
	TAD	(6
GOTLIM,	CDF
	CIA		/NEGATE
	SZA		/SKP IF ONLY 8K SYSTEM
	TAD	HIFLD	/CHECK DIFFERENCE
	SPA SNA		/SKP IF ROOM TO KEEP BATCH
	JMP	NOLIM	/JMP IF NO ROOM OR INVALID = OPTION
	CIA		/REDUCE CORE SIZE
	TAD	HIFLD
	DCA	HIFLD
	TAD	(400	/SAY BATCH IS PRESERVED
	DCA I	(JSW
NOLIM,	CLA
	TAD	HIFLD
	CIA
	DCA I	(NFLDS
			/8K OPTIMIZATION REMOVED
GENER,	JMS I	(GENTMP	/GENERATE TEMP 0
	JMS I	(GENTMP	/GENERATE TEMP 1
	JMS I	(GENTMP	/GENERATE TEMP 2
	CLA IAC		/GENERATE STRING TEMP 0
	JMS I	(GENTMP
	CLA IAC
	DCA	WORD1	/GENERATE LITERAL 1.0
	CLL CML RTR
	DCA	WORD2
	JMS I	QLUKUP2	/ENTER INTO ST
	LITRL
	-3
	JMS I	(NEWVAR

	TAD	(FNINIT	/SET UP FUNCTIONS
	DCA	FDPTR
FDLOOP,	TAD	(WORD1-1
	DCA	X12
	CDF	10
	TAD I	FDPTR	/GET FIRST WORD
	CDF
	ISZ	FDPTR
	SNA
	JMP	FDFIN
	DCA I	X12	/SAVE IN WORD1
	CLL CMA RTL	/GET LOOKUP COUNT
	CDF	10
	TAD I	FDPTR
	DCA	FUNSIZ
	TAD	FUNSIZ	/GET SIZE OF MOVE
	IAC
	DCA	TEMP
FDLUP2,	CDF	10
	TAD I	FDPTR	/GET A WORD
	CDF
	ISZ	FDPTR
	DCA I	X12	/PUT INTO WORDN
	ISZ	TEMP
	JMP	FDLUP2
	JMS I	QLUKUP2	/ENTER INTO S.T.
	FUNCTN
FUNSIZ,	0
	JMP	FDLOOP	/LOOP
FDFIN,	CIF CDF	10	/JMP TO MOVE GET/PUT OVER THIS PAGE NOW
	JMP I	(MOVPAG

FDPTR,	0
CORLOC,	CORX
CORV,	1400
CORSIZ,	1

	PAGE
	/PRINT STATEMENT

PRINT,	JMS I	QLODSN	/OUTPUT STMT NUM
	JMS I	(GETFN	/GET FILE NUMBER
	DCA	USINGF	/TENTATIVELY ASSUME NORMAL PRINT
	JMS I	QSAVECP	/SAVE SCAN POINTER
	JMS I	QCHKWD	/LOOK FOR "USING"
	WUSING
	JMP	PRINTGO	/NOT THERE, HANDLE NORMALLY
	ISZ	USINGF	/SET FLAG IF THERE
	JMS I	QEXPR	/OK, GET PATTERN EXPRESSION
	JMP	PRTERR	/ERROR IF NONE
	JMS I	QLOAD	/LOAD SAC
	TAD	TYPE1	/MUST BE STRING
	SMA CLA
	JMP	PRTERR	/ERROR
	TAD	(PUINIT	/NOW OUTPUT PATTERN INIT OPCODE
	JMS I	QOUTWRD
	JMS I	QCHECKC	/CHECK IF , IS DELIMITER
	-54
	JMP	PRTERR	/ERROR IF NOT
	SKP		/SKP INTO NORMAL PRINT ROUTINE NOW
PRINTGO,JMS I	QRESTCP	/RESTORE SCAN POINTER IF NO "USING"
	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	USINGF	/TREAT AS ; IF PRINT USING MODE
	SZA CLA
	JMP	NOCR
	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
	FRMSG		/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)
	TAD	USINGF	/SEE IF PRINT USING
	SNA CLA
	JMP	NORMPR	/JMP IF NOT
	TAD	TYPE1	/MUST BE STRING
	SMA CLA
	JMP	PRTERR	/ERROR IF NOT
	TAD	(PUEXEC	/OK, OUTPUT PRINT USING EXECUTE OPCODE
	JMS I	QOUTWRD	/OUTPUT IT
			/FALL INTO STRING WRITE OUTPUT CODE
NORMPR,	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
	JMS I	QOUTWRD	/CALL TO CRLF ROUTINE
	JMP I	QNEWLIN	/END OF PRINT

PRTERR,	JMS I	QERMSG	/ERROR IN PRINT USING SYNTAX
	PUMSG
	JMP I	QREMARK
PRFUN,	0
USINGF,	0
WUSING,	-125;-123;-111;-116;-107;0

	PAGE
	FIELD	1

	*2000

	RELOC	0

	/FUNCTION NAME TABLE (INTERNAL FUNCTIONS)

FUNS,	-0102;-23;FUNC3		/ABS(X)
	-0123;-03;FUNC2		/ASC
	-0124;-16;FUNC1		/ATN(X)
	-0310;-22;FUNC2+20	/CHR$(C)
	-0317;-23;FUNC1+20	/COS(X)
	-0401;-24;FUNC2+40	/DAT$(0)
	-0530;-20;FUNC1+40	/EXP(X)
	-1116;-24;FUNC1+100	/INT(X)
	-1405;-16;FUNC2+60	/LEN(X$)
	-1417;-07;FUNC1+120	/LOG(X)
	-2017;-23;FUNC2+100	/POS(X$,Y$,Z)
	-2216;-04;FUNC1+200	/RND(0)
	-2305;-07;FUNC2+120	/SEG$(A$,B,E)
	-2307;-16;FUNC1+140	/SGN(X)
	-2311;-16;FUNC1+160	/SIN(X)
	-2321;-22;FUNC1+220	/SQR(X)
	-2401;-16;FUNC1+240	/TAN(X)
	-2324;-22;STRFUN	/STR$(X)
	-2601;-14;VALFUN	/VAL(S$)
	-0611;-30;FUNC2+200	/FIX$(X$)
	-2422;-03;FUNC2+220	/TRC(X)
	-0325;-22;FUNC3+220	/CUR$(V,H)
	-0116;-04;FUNC3+240	/AND(A,B)
	-1117;-22;FUNC3+260	/IOR(A,B)
	-0317;-14;FUNC3+300	/COL(N)
	-1305;-31;FUNC2+300	/KEY$(M)
	-0303;-14;FUNC5+160	/CCL(L$)
	-2015;-24;FUNC6+140	/PMT$(Q$)
	-0301;-20;FUNC2+260	/CAP$(L$)
	-1703;-24;FUNC2+320	/OCT(O$)
	-0211;-16;FUNC2+340	/BIN(B$)
	-1703;-23;FUNC2+360	/OCS$(O)
ENDFNS,	0;0;FUNC4		/SPACE FOR NEW (USER) 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

	*222		/ORIGIN INTO INPUT ROUTINE NOW
	/OS-8 FILE INPUT ROUTINE

ICHAR,	0		/READ CHAR FROM INPUT FILE
ICHLP,	CLA CLL
	ISZ	INJMP	/BUMP THREE WAY UNPACK SWITCH
	ISZ	INCHCT
INJMPP,	JMP	INJMP
	TAD	INEOF	/LAST READ YEILD END OF FILE ?
	SZA CLA
	JMP	INERR	/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
	CIF
	JMS I	INHNDL	/DO THE READ
	0210		/ONE BLOCK TO FIELD 1
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	ICHLP	/GO AGAIN
INERR,	CLA
	CIF CDF
	JMP I	(ENDFIL

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		/IGNORE LEADER-TRAILER
	JMP	ICHLP
	TAD	(-134	/CHECK FOR \ (STMT SEPARATOR)
	SNA
	JMP	INBKSL	/TREAT LIKE CR IF NOT BETWEEN QUOTES
QTBKSL,	TAD	(134-32	/IS IT ^Z (END OF FILE)
	SNA
	JMP	INERR	/YES, ITS END OF FILE
	TAD	(32-15
	SNA
	JMP	INEOL	/RETURN IF CR
	CLL
	TAD	(3
	SZL		/SKP IF NOT LF, VT OR FF
	JMP	ICHLP	/ELSE IGNORE
	TAD	(12-42	/SEE IF QUOTE
	SNA
	ISZ	QUOTCT	/TALLY IT IF YES
	TAD	(42	/FIX CHAR
	ISZ	ICHAR
ICHXIT,	CIF CDF
	JMP I	ICHAR	/RETURN TO THE CALLING WORLD
INBKSL,	TAD	QUOTCT	/SEE IF BETWEEN QOUTES
	RAR
	SZL CLA		/TREAT AS CR IF YES
	JMP	QTBKSL	/RETURN IT OTHERWISE
INEOL,	DCA	QUOTCT	/CLEAR THE COUNTER ON GENUINE CR
	JMP	ICHXIT	/RETURN
INTMP,	0
INEOF,	0
INCHCT,	-1
INHNDL,	0		/ENTRY ADDR GOES HERE
INCTR,	0
INPTR,	0
QUOTCT,	0

	/CODE TO RELOCATE RECORD I/O PROCESSOR DOWN

MOVPAG,	TAD I	PAGPT1
	CDF
	DCA I	PAGPT2
	CDF	10
	ISZ	PAGPT1
	ISZ	PAGPT2
	ISZ	PAGCNT
	JMP	MOVPAG
	CIF CDF
	JMP I	(REMARK	/START THE COMPILER NOW!!
PAGPT1,	XGET
PAGPT2,	CORE
PAGCNT,	-200

	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+240;-1;2000;0		/TAN
	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
	FUNC2+200;-1;6000;4000		/FIX$
	FUNC1+200;-1;2000;0		/RND
	FUNC2+220;-1;2000;0		/TRC
	FUNC3+220;-2;0;2000;4000	/CUR$(V,H)
	FUNC3+240;-2;0;2000;0		/AND(A,B)
	FUNC3+260;-2;0;2000;0		/IOR(A,B)
	FUNC3+300;-1;2000;0		/COL(N)
	FUNC2+300;-1;2000;4000		/KEY$(M)
	FUNC5+160;-1;6000;0		/CCL(L$)
	FUNC6+140;-1;6000;4000		/PMT$(Q$)
	FUNC2+260;-1;6000;4000		/CAP$(L$)
	FUNC2+320;-1;6000;0		/OCT(O$)
	FUNC2+340;-1;6000;0		/BIN(B$)
	FUNC2+360;-1;2000;4000		/OCS$(O)
	0

				/TABLE CROSSES PAGE BOUNDRY
	*INBUF			/ORIGIN INTO INPUT BUFFER NOW
	/IMAGE OF RECORD I/O PROCESSORS

XGET,	RELOC	CORE	/FITS IN HOLE IN FIELD 0

	/GET STATEMENT

GET,	JMS	RECCOM	/DO COMMON CODE
GETLUP,	JMS I	QCHECKC	/SEE IF COMMA FOLLOWS
	-54
	JMP I	QNEWLIN	/JMP OUT IF NOTHING ELSE
	STL RAR		/SET LEFT SIDE SWITCH
	JMS I	QEXPR	/PARSE EXPRESSION
	JMP I	QREMARK	/IGNORE IT
	JMS I	QGETA1	/GET TOP OF STACK
	TAD	TYPE1	/LOOK AT TYPE BITS
	SPA CLA		/SKP IF NUMERIC EXPRESSION
	JMP	GSTRNG	/ELSE GET STRING
	JMS I	QMODSET	/SET INTERPRETER MODE TO NUMERIC
	STL RTR		/LOOK AT SUBSCRIPTED BIT
	AND	TYPE1
	SZA CLA		/SKP IF SCALAR
	JMP	DIMGET	/ELSE DO DIMENSIONED TYPE
	TAD	(RSUB	/EMIT READ FIELD OPERATOR (INTO SAC)
	JMS I	QOUTWRD
	TAD	(VALFUN	/NOW EMIT VAL(SAC) TO GET INTO FAC
	JMS I	QOUTWRD
	TAD	(FSTA	/DO THE STORE NOW
	JMP	FINGET
DIMGET,	JMS I	QLOADSS	/LOAD SUBSCRIPT REGISTERS
	TAD	(RSUB	/NOW DO THE READ FIELD OPERATION
	JMS I	QOUTWRD
	TAD	(VALFUN	/CONVERT TO FAC
	JMS I	QOUTWRD
	TAD	(AFSTA	/STORE INTO ARRAY
	JMP	FINGET
GSTRNG,	TAD	(RSUB	/SEND OUT READ FIELD TO SAC
	JMS I	QOUTWRD
	STL RAR
	JMS I	QMODSET	/SET TO STRING MODE
	STL RTR		/LOOK AT DIMENSIONED BIT
	AND	TYPE1
	SNA CLA
	JMP	.+3	/JMP AROUND IF SCALAR
	JMS I	QLOADSS	/ELSE LOAD SUBSCRIPTS
	TAD	(SASTOR-SSTORE	/CONVERT TO STRING ARRAY STORE
	TAD	(SSTORE	/OR SCALAR STRING STORE
FINGET,	TAD	SYMBL1	/ADD TO SYMBOL
	JMS I	QOUTWRD
	JMP	GETLUP	/LOOP FOR MORE
	/PUT STATEMENT

PUT,	JMS	RECCOM	/DO COMMON STUFF
PUTRCL,	JMS I	QCHECKC	/SEE IF COMMA FOLLOWS
	-54
	JMP	EOREC	/END OF RECORD IF NO MORE
	JMS I	QEXPR	/GET EXPRESSION
	JMP	EOREC	/END OF REC IF NONE
	JMS I	QLOAD	/LOAD TO FAC OR SAC
	TAD	TYPE1
	SPA CLA		/SKP IF NUMERIC
	JMP	NOCVT	/ELSE JMP AROUND CONVERSION
	TAD	(STRFUN	/SEND OUT STR TO LOAD SAC FROM FAC
	JMS I	QOUTWRD
	STL RAR		/TELL OURSELVES WE'RE IN STRING MODE
	JMS I	QMODSET
NOCVT,	TAD	(WSUB	/NOW DO WRITE FIELD OPERATION
	JMS I	QOUTWRD
	JMP	PUTRCL	/ITERATE
EOREC,	TAD	(WEOR	/AT END,EMIT END OF RECORD OPCODE
	JMS I	QOUTWRD
	JMP I	QNEWLIN	/DONE

	/HANDLE COMMON PORTION OF GET/PUT STATEMENTS

RECCOM,	0
	JMS I	QLODSN	/OUTPUT STATEMENT NUMBER
	JMS I	(GETFN	/GET #N:
	JMS I	QEXPR	/NOW GET RECORD NUMBER EXPRESSION
	JMP I	QREMARK	/FLUSH IF NOT THERE
	JMS I	QLOAD	/LOAD FAC (OR POSSIBLY SAC)
	TAD	TYPE1	/BE SURE NUMERIC EXPR
	SMA CLA
	JMP	.+3	/OK
	JMS I	QERMSG	/PRINT ERROR IF STRING
	BRMSG		/BAD RECORD NUMBER
	TAD	(LOCATE	/NOW EMIT LOCATE OPERATOR
	JMS I	QOUTWRD
	JMP I	RECCOM	/RETURN WITH SCAN AT COMMA FOLLOWING RECORD NUMBER

	/DEFINE RECORD STATEMENT

DEFINE,	JMS I	QLODSN	/SEND OUT STATEMENT NUMBER
	JMS I	(GETFN	/GET #N: NEXT
DEFINL,	JMS I	QEXPR	/PARSE EXPRESSION
	JMP I	QREMARK	/END OF DEFINE
	JMS I	QLOAD	/LOAD FAC OR SAC
	TAD	TYPE1	/TEST IF NUMERIC
	SMA CLA
	JMP	.+3
	JMS I	QERMSG	/IF STRING GIVE ERROR
	BDMSG		/BAD DEFINE
	TAD	(DEFREC	/SEND OUT DEFINE FIELD OPCODE
	JMS I	QOUTWRD
	JMS I	QCHECKC	/SEE IF ANOTHER FIELD FOLOWS
	-54		/,
	JMP I	QNEWLIN	/END IF NO COMMA
	JMP	DEFINL	/ELSE GET ANOTHER

	PAGE
	RELOC	1200

	JMP	DORUN1	/JMP IF CHAINED TO BY EDITOR

	/CODE TO READ IN FIELD 0 OF COMPILER ON A CHAIN FROM BRTS
	/THIS CODE EXECUTES IN LOCATION *13200

	TAD I	(INFO+1	/ON ENTRY FROM RUNTIME CHAIN CODE,
	TAD	F0BLK	/ADD OFFSET TO FIELD 0 SECTION OF BCOMP TO
	DCA	F0BLK	/START OF BCOMP AND STORE INLINE
	CIF		/CALL TO SYS:
	JMS I	(7607
	3700		/READ 31. PAGES INTO FIELD 0
	0000		/STARTING AT *0
F0BLK,	F0OFFS		/CONTAINS OFFSET TO FIELD 0 ON ENTRY
	HLT		/FATAL ERROR
	CIF CDF
	JMP I	(BRTCHN	/JMP TO CHAIN CODE NOW
	/ENTRY ADDR FOR CHAIN FROM EDITOR
	/SAVES INPUT HANDLER AND READS FIELD 0 OF BRTS, AND
	/RESTORES FIELD 0 OF HANDLER

DORUN1,	JMS	XMOVE	/FIRST SAVE HANDLER
	CDF		/CDF OF SOURCE
	INDEVH		/LOCATION IN FIELD 0 WHERE HANDLER IS STORED
	CDF	10	/CDF OF SAVE AREA
	7200		/A SAFE SLOT IN FIELD 1
	-400		/THIS MUCH
	TAD I	(INFO+1	/GET START OF BCOMP
	TAD	BCBLOK	/OFFSET 8. PAGES FOR FIELD 0 STUFF
	DCA	BCBLOK	/STORE INLINE
	CIF		/CALL SYS: TO READ IT IN
	JMS I	(7607
	3700		/ALL BUT ONE PAGE
	0000		/STARTING HERE
BCBLOK,	F0OFFS		/FROM HERE
	JMP	WHUPS	/SYSTEM ERROR
	JMS	XMOVE	/NOW SHIFT HANDLER BACK
	CDF	10	/FROM HERE
	7200
	CDF		/TO HERE
	INDEVH
	-400		/2 PAGES
	CLA IAC
	JMS I	(200	/ENTER THE TEMP FILE
	3
TMPBK,	TMPFL
TMPSZ,	0
	JMP	WHUPS	/SYSTEM ERROR
	JMS I	(200	/NOW DO A RESET
	13
	TAD	TMPBK	/GET BLOCK NUMBER OF TMP FILE
	DCA I	(INFO+10 /STORE IN INFORMATION AREA
	TAD	TMPSZ	/NOW GET SIZE OF TMP FILE
	DCA I	(INFO+11 /ALSO STORE IN INFORMATION AREA
	TAD I	(CDOPT4	/ZERO OUT ALL BUT /S SWITCH
	AND	(40
	DCA I	(CDOPT4
	TAD	(40	/SET /G TO LOAD AND GO
	DCA I	(CDOPT3
	CIF CDF		/JMP TO CHAINED CODE IN FIELD 0 NOW
	JMP I	(CHAINED

	/ROUTINE TO MOVE CORE FROM ONE AREA TO ANOTHER

XMOVE,	0
	JMS	GMOVE	/GET SOURCE CDF
	DCA	MFFLD
	JMS	GMOVE	/GET SOURCE PTR
	DCA	MFPTR
	JMS	GMOVE	/GET DESTINATION CDF
	DCA	MTFLD
	JMS	GMOVE	/GET DESTINATION PTR
	DCA	MTPTR
	JMS	GMOVE	/GET -NUMBER OF WORDS TO MOVE
	DCA	MCNT
MFFLD,	HLT
	TAD I	MFPTR
	ISZ	MFPTR
MTFLD,	HLT
	DCA I	MTPTR
	ISZ	MTPTR
	ISZ	MCNT
	JMP	MFFLD	/ITERATE FOR ALL WORDS
	CDF	10	/RESET TO OUR DF
	JMP I	XMOVE
MFPTR,	0
MTPTR,	0
MCNT,
GMOVE,	0
	TAD I	XMOVE
	ISZ	XMOVE
	JMP I	GMOVE

TMPFL,	FILENAME BASIC.TM

	/PRINT "SY" IF SYSTEM ERROR DURING INITIALIZATION

WHUPS,	TAD	("S
	JMS	TTYO
	TAD	("Y
	JMS	TTYO
	TAD	(15
	JMS	TTYO
	TAD	(12
	JMS	TTYO	/BETTER THAN NOTHING...
	TSF
	JMP	.-1	/WAIT FOR FLAG TO SETTLE
	CIF CDF		/NOW BACK TO OS/8
	JMP I	(7605

TTYO,	0
	TSF
	JMP	.-1
	TLS
	CLA CLL
	JMP I	TTYO

	PAGE

	ZBLOCK	1400-.		/FILL OUT THE INPUT BUFFER
	/KEYWORD LIST

KEYWRD,	-114;-105;-124;LET
	-111;-106;-105;-116;-104;IFEND
	-111;-106;-117;-120;-105;-116;IFOPEN
	-111;-106;IF
	-106;-117;-122;FOR
	-116;-105;-130;-124;NEXTX
	-107;-117;-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;-111;-116;-105;DEFINE
	-107;-105;-124;GET
	-120;-125;-124;PUT
	-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
	-117;-116;ONGO
	-105;-116;-104;END
	0

	KEYEND=.

	IFNZRO	KEYEND-1631 <__FIX BLOAD__>

	/FIELD ONE STUFF

	VARST=	KEYEND		/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

	RELOC
	*4000
	RELOC	OUBUF
	*OUBUF+200
	*OUBUF

	/ERROR MESSAGE OVERLAY
	/EXECUTES OUT OF TEMP FILE OUTPUT BUFFER
	/OUTPUT IS INHIBITED AFTER FIRST CALL TO QERMSG

XERMSG,	0
	JMS I	(ESETUP	/DO ONCE ONLY SETUP
	CIF
	JMS I	(7607	/READ IN THE TEXT PAGE
	0110		/ONE PAGE TO FIELD 1
	TXTHOL		/TO HERE
ETXTOV,	0		/FROM HERE
	HLT
	TAD	(77	/PRINT ? IN FRONT OF MESSAGE
	JMS	SPCH
	JMS	SCRIBE	/PRINT THE MESSAGE
EADDR,	0
	JMS	SCRIBE	/PRINT "AT LINE NNNN"
	ATLINE
	TAD	(12	/NOW RETURN CARRAIGE
	JMS	SPCH
	TAD	(15
	JMS	SPCH
	CIF CDF		/RETURN TO CALLER
	JMP I	XERMSG

ATLINE,	TEXT	/ AT ^LINE /
	*.-1
ATLNO,	ZBLOCK	3		/BUFFER FOR LINE NUMBER
	/ROUTINE TO EXPAND AND PRINT FANCY ERROR MESSAGES
	/CALL+1 = ABSOLUTE ADDR OF MESSAGE IN FIELD 1
	/MESSAGE TERMINATED BY NULL 6 BIT CHAR

SCRIBE,	0
	DCA	MSGCNT	/ZERO CHAR COUNT
GOTCRT,	JMS	SGCH	/GET AN UPPER CASE CHAR
SPRTCH,	JMS	SPCH	/PRINT IT
SNXTCH,	JMS	SGCH	/GET ANOTHER CHAR
	TAD	(-136	/SEE IF ^
	SNA
	JMP	GOTCRT	/JMP IF NEXT CHAR IS UPPER CASE
	TAD	(136-133 /SEE IF [
	SNA
	JMP	GOTBRK	/JMP IF NEXT WORD IS UPPER CASE
	CLL		/SEE IF ALPHABETIC
	TAD	(32
	SZL		/SKP IF NO
	TAD	(40	/ELSE CONVERT TO LOWER CASE
	TAD	(133-32
	JMP	SPRTCH	/GO PRINT CHAR
GOTBRK,	JMS	SGCH	/GET NEXT CHAR
	TAD	(-135	/SEE IF ]
	SNA
	JMP	SNXTCH	/JMP IF YES
	TAD	(135	/ELSE FIX CHAR
	JMS	SPCH	/PRINT IT AS IS
	JMP	GOTBRK

SGCH,	0
	TAD	MSGCNT	/GET CHAR COUNT
	ISZ	MSGCNT
	CLL RAR		/DIVIDE BY 2
	TAD I	SCRIBE	/ADD TO MESSAGE BASE
	DCA	MSGPTR	/POINT AT WORD
	TAD I	MSGPTR
	SZL		/SKP IF LEFT BYTE
	JMP	NOROT
	RTR
	RTR
	RTR
NOROT,	AND	(77	/GET 6 BITS
	SNA
	JMP	SOUT	/EXIT IF NULL
	TAD	(40	/DO UNPACK
	AND	(77
	TAD	(40
	JMP I	SGCH	/RETURN CHAR
SOUT,	ISZ	SCRIBE	/BUMP RETURN ADDR
	JMP I	SCRIBE

MSGCNT,	0
MSGPTR,	0

SPCH,	0
	TSF
	JMP	.-1
	TLS
	CLA
	JMP I	SPCH

	PAGE
	TXTHOL=	.

	/SETUP ROUTINE FOR ERROR MESSAGE PRINTING

ESETUP,	0
	CDF
	TAD I	(ERMSG	/GET ADDR OF MESSAGE ADDR
	DCA	EPTR
	TAD I	EPTR	/GET MESSAGE ADDR
	CDF	10
	DCA I	(EADDR	/SAVE IT
	TAD I	(EADDR	/GET BLOCK OFFSET TO AC8-11
	AND	(7400	/ONLY BLOCK BITS
	CLL RTL
	RTL
	RAL
	TAD I	(INFO+1	/ADD TO BASE OF BCOMP.SV
	TAD	(TXTOFS	/ADD BLOCK OFFSET OF TEXT
	DCA I	(ETXTOV	/STORE INLINE
	TAD I	(EADDR	/NOW MAKE MESSAGE ADDR ABSOLUTE
	AND	(377
	TAD	(TXTHOL
	DCA I	(EADDR	/STORE IT
	TAD	(ATLNO	/SET POINTER TO LINE NUMBER BUFFER
	DCA	LNPTR
	DCA I	(ATLNO	/CLEAR LEFT ZERO SUPRESSION FLAG
	CDF
	TAD I	(LINEH	/GET HIGH ORDER DIGITS
	JMS	PSN	/FORMAT THEM
	CDF
	TAD I	(LINEL
	JMS	PSN	/FORMAT THEM
	TAD I	(ATLNO	/KLUDGE TO FORCE DIGIT OUT IF LINE ZERO
	SNA
	TAD	(6000	/WAS ZERO, PUT DIGIT OUT
	DCA I	(ATLNO
	JMP I	ESETUP	/RETURN

EPTR,	0

	/PUT STATEMENT NUMBER INTO "AT LINE" TEXT

PSN,	0
	CDF	10
	DCA	LNWORD	/SAVE DIGITS
	AC7775		/DO 3 DIGITS
	DCA	LNCNT
LNLUP,	TAD	LNWORD	/GET WORD
	RTL
	RTL		/SHIFT LEFT 4 BITS
	DCA	LNWORD
	TAD	LNWORD	/GET DIGIT
	RAL
	AND	(17
	SZA		/SKP ZERO
	JMP	NOZERO	/ELSE OUTPUT IT
	TAD I	(ATLNO	/IS IT LEADING ZERO
	SNA CLA
	JMP	LEAD0	/YES, FORGET IT
NOZERO,	TAD	(60	/MAKE PRINTABLE
	DCA	LNCHAR	/SAVE IT
	TAD I	LNPTR	/GET WORD
	SZA		/SKP IF LEFT CHAR
	JMP	NOBSW
	TAD	LNCHAR
	CLL RTL
	RTL
	RTL
	JMP	NXTLCH	/GO STORE IT
NOBSW,	TAD	LNCHAR	/ADD TO HI CHAR
	DCA I	LNPTR
	ISZ	LNPTR
NXTLCH,	DCA I	LNPTR
LEAD0,	ISZ	LNCNT
	JMP	LNLUP	/DO NEXT DIGIT
	JMP I	PSN
LNCNT,	0
LNCHAR,	0
LNWORD,	0
LNPTR,	0

	PAGE
	RELOC
	RELOC	0	/ASSIGN RELATIVE ADDRESSES

	/BCOMP ERROR MESSAGES

EPART1,
XCMSG,	TEXT	/EXTRA ^CHARACTERS/
LTMSG,	TEXT	/LINE TOO LONG/
DIMSG,	TEXT	/D[IM S]TATEMENT ERROR/
NFMSG,	TEXT	/N[EXT] WITHOUT [FOR/
UDMSG,	TEXT	/BAD [UDEF] STATEMENT/
UUMSG,	TEXT	/ERROR IN [USE S]TATEMENT/
IFMSG,	TEXT	/BAD [IF S]TATEMEMT/
FNMSG,	TEXT	/BAD ^FILE ^NUMBER/
STMSG,	TEXT	/SYMBOL ^TABLE ^OVERFLOW/
FN2MSG,	TEXT	/NUMERIC ^EXPRESSION IN ^FILENAME/
MOMSG,	TEXT	/MISSING ^OPERAND/
	PAGE
	ZBLOCK	200
EPART2,
SSMSG,	TEXT	/SUBSCRIPT ^ERROR/
FRMSG,	TEXT	/BAD ^FUNCTION ^REFERENCE/
FPMSG,	TEXT	/BAD [FOR] LOOP PARAMETERS/
MTMSG,	TEXT	/MIXED ^OPERATOR OR ^OPERAND TYPES/
MDMSG,	TEXT	/MULTIPLY ^DEFINED ^STATEMENT ^NUMBER/
PDMSG,	TEXT	/STACK ^OVERFLOW/
SS2MSG,	TEXT	/TOO MANY ^SUBSCRIPTS/
QSMSG,	TEXT	/ERROR IN ^QOUTED ^STRING/
LSMSG,	TEXT	/L[ET S]TATEMENT ^SYNTAX ^ERROR/
	PAGE
	ZBLOCK	200
EPART3,
OFMSG,	TEXT	/OUTPUT ^FILE ^ERROR/
NMMSG,	TEXT	/MISSING ^LINE ^NUMBER IN [GOTO] OR [GOSUB/
REMSG,	TEXT	/STRING IN ^RECORD ^SIZE ^EXPRESSION/
MEMSG,	TEXT	/MISSING [END S]TATEMENT/
SYMSG,	TEXT	/SYSTEM ^ERROR/
PUMSG,	TEXT	/BAD [PRINT USING S]YNTAX/
BDMSG,	TEXT	/STRING ^EXPRESSION IN [DEFINE S]TATEMENT/
MPMSG,	TEXT	/MISMATCHED ^PARENTHESIS/
	PAGE
	ZBLOCK	200
EPART4,
BRMSG,	TEXT	/STRING IN ^RECORD ^NUMBER ^EXPRESSION/
DEMSG,	TEXT	/SYNTAX ERROR IN USER [DEF]INED ^FUNCTION/
ONMSG,	TEXT	/O[N S]TATEMENT ^SYNTAX ^ERROR/
TDMSG,	TEXT	/D[ATA L]IST ^OVERFLOW/

	RELOC

	$
