/ U/W-FOCAL VERSION 4E FOR 16K
/ 16KCPR.PA
/ REVISIONS:
/	NEW FLAGS CLEARED AT 13112 - 13126



/	COPYRIGHT (C) 1978  -  ALL RIGHTS RESERVED BY
/	LAB DATA SYSTEMS - SEATTLE, WASHINGTON  98125



/			**CORE  MAP**
/			(16K VERSION)



/FIELD 0:  USER AREA, STACK, OS/8 ROUTINES, & I/O BUFFERS

/FIELD 1:  INTERPRETER, FUNCTIONS, FLOATING POINT PACKAGE

/FIELD 2:  PROGRAM TEXT ASCENDING - FCOM AREA COMING DOWN

/FIELD 3:  VARIABLES



/		ADDITIONAL INSTRUCTION CODES:


			FENT=JMS I 7
		FIXMRI	FGET=0000
		FIXMRI	FADD=1000
		FIXMRI	FSUB=2000
		FIXMRI	FDIV=3000
		FIXMRI	FMUL=4000
		FIXMRI	FPWR=5000
		FIXMRI	FPUT=6000
		FIXMRI	FNOR=7000
			FEXT=0000

			CDI=CDF CIF
			FIXTAB

/	SPECIAL PSEUDO-OPS FOR CROSS-FIELD CALLS:

		FGETIPT1=FGET I 0
		FADDIPT1=FADD I 0
		FMULIPT1=FMUL I 0
		FPUTIPT1=FPUT I 0

/	ASSEMBLY INSTRUCTIONS USING PAL8-V10:

/	UWF.BN<16KCPR,12KFNS,8KFIO,8KFPP,16KLIB/L/K=100
/	EAE VERSION:	  8XFIO,8XFPP
/	
	FIELD 1		/PROCESSOR FIELD
	PAGE  0

P134,	"\&177		/SCOPE INPUT LIST
BELL,	"G&277		/MODIFY  "    "
P337,	"_		/COMMAND "    "
CFF,	FF
CLF,	LF
CCR,	CR
TRACE,	RO		/SEARCH CHAR & TRACE SWITCH
	FPNT		/ADDRESS OF F.P. INTERPRETER

/AUTO-INDEX REGISTERS

SAVMQ,	0		/INTERRUPT REGISTERS
SAVAC,	0
SAVLK,	0
PDLXR,	PCHK-1		/PUSHDOWN LIST INDEX REGISTER
XRT,	0		/FOR POPF, GETARG, DELETE, FINDLN
XRT2,	0		/FOR  SORTJ, DELETE, FLOATING PT.
AXIN,	0		/INPUT (PACKING) POINTER

TEXTP=.
AXOUT,	0		/OUTPUT (UNPACKING) REG.
GTEM,	0		/UNPACKING TEMP. STORAGE
XCT,	RANDOM+1	/UNPACKING SWITCH
PC,	100		/PROGRAM (LINE) POINTER

/PACKING AND STORAGE CONSTANTS

BOTTOM,	PCHK-1		/BEGINNING OF PDL
LEVEL0,	RANDOM		/BEGINNING OF 'FOR' STACK
FORLVL,	RANDOM		/'FOR' LOOP STACK POINTER

HEADER,	LINE0		/BEGINNING OF TEXT BUFFER
BUFEND,	-7557		/LAST PROGRAM LOCATION
TXTEND,	-7577		/LAST LOCATION FOR INPUT

FIRSTV,	STVAR		/**MASTER LOCATION**
SECRTV,	STVAR-1		/BEGINNING OF VARIABLES
TABEND,	-3		/END OF THE SYMBOL TABLE
			/'E1' FOR 8K, '2200' FOR 12K

IFNDEF	STVAR <STVAR=0>	/'3200' FOR 8K, '2200' FOR 12K

/MISCELLANEOUS THINGS

CONTINUE=JMP I .	/COMMAND RETURN
	CONT
NORMALIZE=JMS I .	/NORMALIZE C(FLAC)
	NORM
ABSOL,	ABSOLV		/TAKE THE ABSOLUTE VALUE
RESOL,	RESOLV		/RESTORE THE PROPER SIGN
/FLOATING POINT REGISTERS (LOC *40)

SIGN,	0		/FOR ABS VALUE & MUL/DIV
T1,	0		/FOR INSTRUCTIONS & F.P.P.
T2,	0		/FOR FUNCTIONS & I/O
T3,	0		/ARGUMENT SIGN & DEC. EXP.

FLAC=.
EXP,	0		/FLOATING ACCUMULATOR
HORD,	0
LORD,	0
OVER,	0

FLOP=.
EX1,	0		/FLOATING OPERAND
AC1H,	0
AC1L,	0
OVR1,	0

TELSW,	0		/OUTPUT DONE FLAG
INBUF,	0		/INPUT BUFFER (*LOC 55)
INDEV,	XI33		/POINTER TO INPUT DEVICE
OUTDEV,	XOUTL		/AND OUTPUT DEVICE (TTY)

BUFR,	LINE1		/NEXT LOCATION IN TEXT BUFFER
LASTV,	STVAR		/NEXT LOCATION IN SYMBOL TABLE

PT1,	0		/VARIABLE POINTER
THISOP,	0		/CURRENT OP, FN OR VARIABLE NAME
LASTOP,	0		/PREVIOUS ARITHEMETIC OPERATION
SORTCN,	0		/RELATIVE POSITION IN A LIST

CHAR,	0		/THE MOST IMPORTANT REGISTER
LINENO,	0		/SET BY 'GETLN'
NAGSW,	0		/'NOT ALL' AND/OR 'GROUP' SWITCH
LASTC,	0		/FOR 'NEXT', 'ASK', 'ON' & FSF'S
FISW,	0		/CODED OUTPUT FORMAT

THISLN=	THISOP		/NOT USED SIMULTANEOUSLY
LASTLN=	LASTOP
/CONSTANTS USEFUL THROUGHOUT FOCAL:

P7,	7		/FOR 'FPOW' AND DIGIT MASK
P13,	13		/FOR FLOAT AND PDLXR POINTER
P177,	177		/STEP MASK & POINTER
P43,	43		/35 BITS
P77,	77		/RIGHT MASK
C100,	100		/CHARACTER TESTS & PC0
P17,	17		/BCD MASK AND CONSTANT
C200,	200		/TEST CONSTANT & POINTER
C240,	240		/SPACE
P7600,	7600		/GROUP MASK & FLARG POINTER
FLARGP=	P7600		/TEMPORARY STORAGE FOR 'EVAL'

M4,	-4		/FOR 'GETARG', 'FPOW', & 'FRAN'
M5,	-5		/FOR 'PRINTN', 'QUIT', ' 'FSQT'
M14,	-14		/FOR 'LPRTST', 'TESTN'
MCR,	-CR		/FOR 'WRITE','IF','DELETE','PRINTC'
FP1,	FLTONE		/FOR 'FLOG', 'FSIN', 'Y' & 'DBLSUB'
GINC,	WORDS+2		/FOR 'GETARG', 'TDUMP' & 'FSF'S

	*.+5		/FOR USER CONSTANTS


/TEMPORARY STORAGE HAS ALL BEEN PLACED ON THE LAST
/PAGE USING THE COMMAND DECODER AREA FROM 7600-7646.

FLARG=	7600		/TEMPORARY FOR 'EVAL'
NEXTP=	7604		/TEXT POINTERS FOR 'NEXT' & 'BREAK'
BUFFER=	7610		/TEMPORARY FOR FUNCTIONS & OUTPUT
RANDOM=	7642		/UPPER LIMIT FOR STACK POINTERS

/SYMBOLS USEFUL THROUGHOUT FOCAL:

	WORDS=4		/HURRAY!
	DIGITS=12

	L=00		/DATA FIELD FOR LIBRARY
	V=30		/DATA FIELD FOR VARIABLES
	S=00		/DATA FIELD FOR THE STACK
	P=10		/DATA FIELD FOR PROCESSOR
	T=20		/DATA FIELD FOR THE TEXT

	LF=212
	FF=214
	CR=215
	SP=240
	RO=377
/NEW INSTRUCTIONS:

PUSHA=	JMS I .		/SAVE THE AC ON THE STACK
	XPUSHA
POPA=	JMS I .		/UNLOAD THE STACK
	XPOPA
PUSHJ=	JMS I .		/CALL A SUBROUTINE
	XPUSHJ
POPJ=	JMP I .		/RETURN FROM A SUBROUTINE
	XPOPJ
PUSHF=	JMS I .		/SAVE 4 WORDS
	XPUSHF
POPF=	JMS I .		/RESTORE THEM
	XPOPF
SORTJ=	JMS I .		/SORT AND BRANCH ON AC OR CHAR
	SORTB
SORTX=	JMS I .		/LOOK FOR SP, COMMA, SEMI, CR
	XSORT
TESTC=	JMS I .		/TEST FOR TERM, FN, NO., OR VAR.
	CTEST
TESTX=	JMS I .		/TEST FOR TERM AND SET SORTCN
	XTEST
TESTN=	JMS I .		/TEST FOR PERIOD, NUMBER
	NTEST
READC=	JMS I .		/READ & ECHO A CHARACTER (AC=0)
ECHOC=	JMS I .		/PRINT C(AC) WHEN ECHO IS ENABLED
	CHIN
PRINTC=	JMS I .		/PRINT C(AC) OR 'CHAR' (IF AC = 0)
	CHOUT
PRINTD=	JMS I .		/PRINT A SINGLE DIGIT FROM THE AC
	OUTDG
READN=	JMS I .		/USE 'FETCH' TO INPUT A NUMBER
	FLINTP
PRINTN=	JMS I .		/CONVERT BINARY TO ASCII & PRINT
ATSW,	FLOUTP		/FOR 'ASK', 'TYPE', 'FBLK' & 'FRA'
PACKC=	JMS I .		/PACK A CHARACTER
	PACBUF
GETC=	JMS I .		/UNPACK A CHARACTER
BKSW,	UTRA		/'BREAK' SWITCH
SPNOR=	JMS I .		/IGNORE LEADING SPACES
	XSPNOR
TSTCMA=	JMS I .		/SKIP IF CHAR=COMMA & MOVE PAST IT
	CMATST
TESTCR=	JMS I .		/SKIP IF CHAR = CR
	CRTEST
GETLN=	JMS I .		/COMPUTE A LINE NUMBER (RECURSIVE)
	XGETLN
FINDLN=	JMS I .		/SEARCH TEXT FOR A GIVEN LINE
	XFIND
PRNTLN=	JMS I .		/PRINT LINE NUMBER
DMPSW,	XPRNT		/TRACE DISABLE SWITCH
DELETE=	JMS I .		/REMOVE A LINE AND
PACEND,	XDELETE		/RECOVER THE SPACE
DCAIAXIN=JMS I .	/'DCA I AXIN' IN FIELD T
	AXIND
/FLOATING POINT PSEUDO INSTRUCTIONS:

FLOAT=	JMS I .		/FLOAT THE AC
	FIGO6
FLOATR=	JMP I .		/FLOAT THE AC AND RETURN
	FIN+2
FL0ATR=	JMP I .		/UNSIGNED FLOAT & RETURN
	FL0AT
RETURN=	JMP I .		/REGULAR FUNCTION RETURNS
FINISH,	EFUN3
SHIFTL=	JMS I .		/MULTIPLY FLAC BY 2
	MULT2
NEGATE=	JMS I .		/COMPLEMENT AND INCREMENT FLAC
	INVERT
FIXIT=	JMS I .		/CONVERT FLAC TO A 24-BIT INTEGER
	INTEGER
MULT10=	JMS I .		/MULTIPLY FLAC BY TEN & ADD THE AC
	XTEN
CHKSGN=	JMS I .		/TAKE ABSOLUTE VALUE + CHECK FOR 0
	SGNCHK
RTL6=	JMS I .		/ROTATE THE AC LEFT 6
BETA,	XRTL6		/FOR THE PDP12 OVERLAY

	*.+4		/PATCH AREA

PRODUCT=.		/FOR SOFTWARE MULTIPLY

	*176
ERROR2=	JMS I .		/FIELD 1 ERROR
TABCNT,	ERROR		/ENTRY POINT IS THE TAB COUNTER

/DEFINE SOME MICROCODED INSTRUCTIONS:

SP1=	CLA STL RAL
SP2=	CLA STL RTL
SM0=	CLA STL RAR
SM1=	CMA STL RAL	/NO CLA
SM2=	STA CLL RAL
SM3=	STA CLL RTL

I0N=	ION		/MAKE THESE EASY TO CHANGE
I0F=	IOF		/OR 'NOP'
/ COMMAND PROCESSOR FOR VERSION 4

	*177
START=.			/PROGRAM SELF-START (=7610)
BUFFPT,	SKP CLA		/OUTPUT BUFFER IS AT 17610.
	JMP I "*	/CONSOLE START (FROM 10200)
	TAD .-1		/ANNOUNCE PRESENCE
	ECHOC		/(DON'T PRINT IF THE ECHO IS OFF)
	TAD BOTTOM
	DCA PDLXR	/RESET THE STACK POINTERS
	TAD LEVEL0
	DCA FORLVL
	TAD TXTEND	/SET THE INPUT LIMIT
	DCA I PACEND
	TAD C100	/SET PC FOR COMMAND MODE
	DCA PC
IBAR,	DCA T3		/RESET THE PACKING SWITCH

	*FF		/RETURN FROM LINEFEED
	TAD BUFR	/INITIALIZE THE BUFFER POINTER
	DCA AXIN	/=*CR
	DCA TRACE	/TURN OFF THE TRACE
	DCA I DMPSW	/BUT ENABLE THE TRAP

IGNOR,	READC		/READ THE COMMAND STRING
	SORTJ
	    P337-1
	    INLIST-P337
	PACKC		/SAVE EACH LITTLE CHARACTER
	JMP IGNOR
/////

INLIST,	IBAR		/B.A. = RESTART
	IGNOR		/F.F. = IGNORE
	LNFEED		/L.F. = RETYPE
	IRETN		/C.R. = TERMINATE
/////

IRETN,	PACKC		/PACK THE CR
	PACKC		/BE SURE ITS ALL THERE
	TAD BUFEND
	DCA I PACEND	/SET REPACKING LIMIT
	TAD BUFR	/INITIALIZE 'TEXTP'
/////

/TEXT BUFFER FORMAT:

/#1 : POINTER OR ZERO IN LAST
/#2 : LINENO
/#3 - #N-1 : TEXT
/#N : CR  (=7715)
/IMMEDIATE AND SEQUENTIAL COMMAND EXECUTION:

NEXTLN,	DCA AXOUT	/SET LINE POINTERS
	DCA XCT
	GETC		/READ FIRST CHARACTER
	SPNOR		/IGNORE LEADING BLANKS
	TESTN		/DOES THE LINE BEGIN WITH 0-9?
	SKP		/PERIOD: ALLOW GROUP ZERO
	JMP INPUTX	/NO, ITS A DIRECT COMMAND
	ISZ I DMPSW	/YES, KILL TRACE TO PROTECT '?'
	GETLN		/READ THE LINE NUMBER
	JMS I MODIFY+2	/INITIALIZE THE NEW LINE
	JMP SRETN	/REPACK THE FIRST CHARACTER

	*"*		/FOR 'LINEFEED'
	M20-1		/MANUAL RESTART
ECHOFF,	PRINTC		/ECHO FF TO CLEAR THE SCREEN
	JMP IGNOR	/(FOR THE SCOPE VERSIONS)

	GETC		/GET THE NEXT CHARACTER
SRETN,	PACKC		/REPACK
	TESTCR		/TEST FOR THE END OF LINE
	JMP .-3
	PACKC		/FINISH THE CR

	DELETE		/REMOVE THE OLD LINE, IF ANY
	CDF T
	TAD I LASTLN	/INSERT NEW ONE
	DCA I BUFR
	TAD BUFR
	DCA I LASTLN
	TAD T3		/-1 IF CR NEEDED 2ND WORD
	CIA
	TAD AXIN	/COMPUTE NEW END-OF-BUFFER
	DCA BUFR
	CDI L
	DCA I P77	/SET 'PROGRAM MODIFIED' FLAG
	JMP 100		/TURN ON INTERRUPTS & RESTART
/////
	*"?		/FOR 'QUIT' VIA 'PACLST'
	TAD M5		/CREATES 'PUSHJ;GOTO+1'
INPUTX,	PUSHJ		/PROCESS THE IMMEDIATE COMMAND
	    PROC
	CDF T
	TAD I PC
	SNA		/END OF THE PROGRAM?
	JMP START	/YES
	DCA PC		/SAVE THE NEW LINE POINTER
	TAD PC
	IAC		/ADVANCE TO THE LINENO
	JMP NEXTLN	/AND CONTINUE PROCESSING
/LINE NUMBER EVALUATION: 'GETLN'

XGETLN,	0		/NOW HANDLES NEGATIVE NUMBERS
	TAD .-1		/ AND PERMITS RECURSIVE CALLS
	PUSHA
	PUSHJ		/EVALUATE THE ARGUMENT
	    EVAL
MODEPT,	TAD EXP		/MODIFY AND FSF ENTRY POINT
	TAD M5
	SMA SZA CLA	/.GT. 31?
	ERROR2
	TAD PC		/POINT TO THE CURRENT LINE
	DCA XRT
TYPEPT,	SM1		/TFRMT ENTRY POINT
	DCA NAGSW	/SET NAGSW FOR 'ALL'
	CHKSGN		/TAKE THE ABSOLUTE VALUE
	JMP ALL		/ZERO=ALL, L=1 FROM 'FPUT'
	SMA SZA CLA	/CHECK THE ORIGINAL SIGN
	DCA NAGSW	/CLEAR SWITCH IF POSITIVE
	FIXIT		/GET THE GROUP NUMBER
	RTL6		/SHIFT INTO PLACE ('BSW')
	CLL RAL
	CDF T		/SHIFT TO TEXT BUFFER
	SNA		/RELATIVE ADDRESSING?
	TAD I XRT	/YES, USE CURRENT GROUP
	AND P7600
	DCA LINENO	/SAVE GROUP NUMBER
	NEGATE
	FENT		/RESETS D.F.
	FADD I FLARGP	/SUBTRACT THE GROUP NUMBER
	FMUL FL100	/SHIFT THE DECIMAL POINT
	FADD FLP5	/ROUND OFF THE RESULT
	FEXT
	FIXIT		/LEAVES L=0
	ISZ NAGSW	/FORCE ZERO FOR NEG LINENO
	DCA NAGSW	/SET 'NOT-ALL/GROUP SWITCH'
	TAD NAGSW	/AC = LINENO IF WE SKIPPED
	TAD LINENO	/COMBINE LINE & GROUP NUMBERS
ALL,	DCA LINENO
	POPJ		/LINK=1 IF ALL (SET BY CHKSGN)

FL100,	7;3100;0	/CONSTANTS FOR 'GETLN'
FLP5,	0;2000;ZBLOCK 2	/ ALSO USED BY  'FSQT'

/LINE NUMBERS MAY RANGE FROM 0 TO +- 31.99
/NEGATIVE NUMBERS FORCE THE 'GROUP' SWITCH.

/	NAGSW:
/ALL=	7777(1)
/GROUP=	0000(0)
/LINE=	0XXX(0)
/'MODIFY' AND 'MOVE' COMMANDS DIFFER ONLY IN THAT 'MOVE'
/HAS A SECOND LINE NUMBER (SEPARATED BY A COMMA) WHICH
/BECOMES THE LINENO OF THE CORRECTED LINE.  THE OLD LINE
/REMAINS UNCHANGED IN THIS CASE.

MODIFY,	GETLN		/READ THE FIRST LINENO
	TSTCMA		/PASS THE COMMA IF THERE IS ONE
	INITLN		/'NOP'
	PUSHJ		/OTHERWISE 'EVAL' GIVES ZERO
	    EVAL
	FINDLN		/LOOK UP THE OLD LINE
	ERROR2		/NOT THERE
	TAD HORD	/TEST SECOND ARGUMENT
	SZA CLA		/NEW LINENO?
	PUSHJ		/YES: 'MOVE' AS WELL AS 'MODIFY'
	    MODEPT	/.LT. 1000 SO WE CAN DO THIS
MODLN,	PRNTLN		/'NOP' TO OMIT THE NUMBER
/////
	JMS INITLN	/SAVE LINENO
SCONT,	JMS I INDEV	/GET SEARCH CHARACTER (SILENTLY)
	DCA TRACE
SCHAR,	GETC		/PLAYBACK TEXT
	TAD CHAR
	ECHOC		/ALLOW SILENT EDITING
	SORTJ		/LOOK FOR A MATCH
	    CCR-1
	    LISTGO-CCR
	PACKC		/SAVE THE NEW LINE
	JMP SCHAR
/////
SBAR,	JMS INITLN	/RESTART AFTER A '_'
SFOUND,	READC		/READ FROM KEYBOARD
	SORTJ		/AND TEST
	    BELL-1
	    SRNLST-BELL
SGOT,	SP1		/PROTECT LINENO FROM RUBOUTS
	PACKC		/PACK CHAR
	JMP SFOUND	/MORE
/////
SRNLST,	SCONT		/BELL = CHANGE SEARCH CHARACTER
	SBAR		/B.A. = DELETE LINE TO THE LEFT
	SCHAR		/F.F. = LOOK FOR NEXT OCCURANCE
	SCONT+1		/L.F. = FINISH THE LINE AS BEFORE
LISTGO,	SRETN		/C.R. = END THE LINE RIGHT HERE
	SGOT		/CHAR = STOP ON SEARCH CHARACTER
/////

INITLN,	ZBLOCK 2	/INITIALIZE A NEW LINE
	DCA T3
	TAD BUFR	/RESET INPUT POINTERS
	DCA AXIN
	TAD LINENO	/PACK LINENO
	DCAIAXIN
	ISZ I DMPSW	/KILL THE TRACE
	JMP I INITLN	/USED BY MODIFY, ERASE AND INPUT
/OUTPUT THE INDIRECT PROGRAM

WEND,	POPA		/RESTORE TEXT POINTERS
	DCA CHAR
	POPF
	    TEXTP
	DCA I DMPSW	/RESTORE TRACE
	TSTCMA		/CHECK FOR MULTIPLE LISTING
	CONTINUE
	TAD CCR
	PRINTC		/SEPARATE MULTIPLE CALLS
/////
WRITE,	GETLN		/SET LINENO
	PUSHF		/SAVE TEXT POSITION
	    TEXTP
	TAD CHAR
	PUSHA
WCONT,	FINDLN		/SEARCH FOR LINE NUMBER
	JMP WTESTG	/NOT THERE OR GROUP
	PRNTLN		/ALSO DISABLES THE TRACE
	GETC
	PRINTC		/PRINT A LINE OF TEXT
	TESTCR		/SKIP AT THE END
	JMP .-3
	TAD THISLN	/POINT TO THE NEXT LINE
WTESTG,	JMS GRPCHK	/CHECK ITS VALIDITY
	JMP WEND	/LAST ONE OR ONLY ONE
	TAD LASTLN	/STILL IN THE GROUP?
	SZA CLA
	PRINTC		/SEPARATE GROUPS
	JMP WCONT	/RETURN TO LOOP

/DELETE SINGLE LINES, GROUPS OR EVERYTHING

ERASE,	GETLN		/WHICH SHALL IT BE?
	SZL		/ALL?
	JMP ERA		/YES
	JMS INITLN	/SET MEMORY PROTECTION
ERG,	DELETE		/REMOVE A SINGLE LINE
	TAD LASTLN	/WATCH OUT FOR THE END
	JMS GRPCHK	/CHECK IF NEXT LINE IS OK
	JMP ERX		/DONE: CLEAR PROGRAM FLAG
	JMP ERG		/DELETE SOME MORE
/////
	LINE1
ERA,	TAD .-1		/RESET THE COMMAND BUFFER
	DCA BUFR
	CDF T		/PUT ZERO IN THE FIRST LINE
	DCA I HEADER
ERX,	CDI L		/AND REMOVE THE PROGRAM NAME
	JMP NONAME
/CLEAR THE SYMBOL TABLE AND/OR SELECTED VARIABLES

ZERO,	TESTC		/CHECK FOR AN ARGUMENT
	JMP ZALL	/NO ARG = ALL VARIABLES
	GETC		/F (SLIGHT FUDGE)
	SPNOR		/N (ALSO ILLEGAL)
	SORTJ		/L VARIABLE NAME
	    ZLIST-1
	    ZGO-ZLIST
	PUSHJ		/NOT A TERMINATOR
	    GETARG	/SO IT MUST BE A NAME
	ISZ XRT2	/ADVANCE DATA POINTER
	PUSHJ
	    ZFOUND	/THEN ZAP IT
	JMP ZERO+3

ZALL,	TAD FIRSTV	/RESET THE TABLE
	DCA LASTV
	JMP ZERO+4	/E.G. Z,A,B,C...
/////


GRPCHK,	0		/FOR REPEATED OPERATIONS
	CDF T		/TEXT BUFFER
	SNA		/AC = POINTER TO NEXT
	JMP .+6		/FIRST LINE IN A GROUP
	DCA INITLN	/SAVE POINTER
	TAD I INITLN	/'THISLN', 'LASTLN', 'PC'
	SNA		/END OF TEXT BUFFER?
	JMP GRPXIT+1	/YES
	DCA THISLN	/SAVE NEW POINTER
	TAD NAGSW	/CHECK THE TYPE OF OPERATION
	SMA SZA		/FIRST EXIT = SINGLE OR E.O.G.
	JMP GRPXIT	/ALSO SERVES FOR END-OF-TEXT
	DCA LASTLN	/SAVE A COPY OF NAGSW
	ISZ THISLN	/POINT TO LINE NUMBER
	TAD I THISLN
	AND P7600
	CIA
	TAD LINENO	/COMPARE WITH CURRENT
	AND P7600
	ISZ LASTLN	/FORCE 2ND EXIT FOR 'ALL'
	SNA CLA
	ISZ GRPCHK	/SECOND EXIT = KEEP GOING
	DCA LASTLN	/NON-ZERO = 'ALL' BUT N.I.G.
	TAD I THISLN
GRPXIT,	DCA LINENO	/UPDATE THE LINE NUMBER
	CDF P
	JMP I GRPCHK
/////
/ THE IMPROVED 'RETURN' COMMAND PERMITS AN OPTIONAL LINE
/NUMBER WHICH WILL TRANSFER TO THAT LINE RATHER THAN RE-
/TURNING TO THE CALL.  A VERY USEFUL FEATURE!

RETRN,	PUSHF		/SAVE FSF RESULTS
	    FLARG
	GETLN		/CHECK FOR A LINENO
	TAD LINENO	/SAVE IT
	DCA THISLN
	TAD C100	/POINT TO PC0
	DCA PC
	CML CMA RAR	/ 3777  OR  7777
	DCA LASTLN	/SET RETURN FLAG
	POPF		/RESTORE FSF
	    FLARG	/'CLA'
	POPJ		/GO BACK A LEVEL

/PRIMARY CONTROL AND TRANSFER

GOTO,	GETLN		/READ THE LINE NUMBER REQUESTED
	FINDLN		/LOCATE IT AND RESET TEXTP
	ERROR2		/NOT THERE - 'NOP' TO USE NEXT!
	TAD THISLN	/SET THE PC
	DCA PC

	GETC		/TEST FOR THE END OF THE LINE
PROC,	TAD CHAR
	AND P337	/EXECUTE LOWER CASE TOO!
	DCA LASTC	/SAVE COMMAND & CLEAR A FLAG
	SORTX		/CHECK FOR SP, COMMA, SEMI, CR
	JMP PC1+1	/NONE OF THE ABOVE
	JMS CRTEST	/CR?
	JMP PROC-1	/IGNORE SPACES, COMMAS, SEMIS
PC1,	JMP I COMGO-1	/EXIT AT THE END OF A LINE

	GETC		/SKIP TO END OF THE COMMAND
	SORTX
	JMP .-2
	TAD LASTC	/RECALL COMMAND LETTER
	TAD (-"Z-1
	STL IAC
	TAD ("Z-"?
	SZL SNA		/IS IT @-Z?
CERR,	ERROR2		/ILLEGAL COMMAND
	TAD PC1
	DCA .+1		/EXECUTE AN INDIRECT JUMP
/////

CRTEST,	0		/SKIP IF CHAR IS A CR: 'TESTCR'
	TAD CHAR
	TAD MCR
	SNA CLA
	ISZ CRTEST
	JMP I CRTEST
/RECURSIVE OPERATE, EXECUTE, OR CALL

LGOSUB,	TAD P7600	/GET RETURN FLAG
	JMP DO+1	/EXECUTE THE SUBROUTINE
LCMNDS,	SPNOR		/'L' COMMAND ENTRY POINT
	CIF L
	JMP I FENT&177	/SAME ADDRESS AS THE FPP
/////

DOXIT,	SZA		/CHECK FOR 'DO' OR 'GOSUB'
	JMP LCMNDS+1	/RETURN TO CALLING PROGRAM
	TSTCMA		/CHECK FOR ADDITIONAL CALLS
	CONTINUE	/NONE: PROCESS NEXT COMMAND
/////
DO,	GETLN		/EXECUTE A LINE, GROUP, OR ALL
	DCA SORTCN	/ENTRY POINT FOR GOSUB
	PUSHF		/ENTRY POINT FOR FSF'S
	    TEXTP	/SAVE TEXT POINTERS
/////
DOGRP,	PUSHF		/SAVE SORTCN, CHAR, LINENO, NAGSW
	    SORTCN
	FINDLN		/FIND THE OBJECT LINE
	JMP DOERR	/NOT THERE: DO WE CARE?
	PUSHJ		/EXECUTE A SINGLE LINE
	    GOTO+3
	POPF		/RESTORE THE DATA
	    SORTCN
	TAD PC		/CHECK THE NEXT LINE
	JMS I (GRPCHK	/SHOULD WE EXECUTE IT?
	JMP DORTN	/ALL DONE
	JMP DOGRP	/CONTINUE SUBROUTINE
/////
DORTN,	POPF		/RESTORE TEXT POINTERS
	    TEXTP
	TAD SORTCN	/CHECK RETURN FLAG
	SMA SZA
	JMP GOTO-2	/FSF RETURN ('CLA;POPJ')
	ISZ LASTLN	/CHECK RETURN OPTION
	JMP DOXIT	/NONE, RETURN TO CALL
	SZA CLA		/GOSUB?
	POPF		/YES, DUMP PROGRAM INFO
	    FLOP	/OTHERWISE 'NOP'
	TAD THISLN
	DCA LINENO	/GET THE LINE NUMBER
	JMP GOTO+1	/AND GO SOMEWHERE ELSE
/////
	ERROR		/PATCHED BY PROGRAM INTERRUPT
DOERR,	JMS I (GRPCHK	/TEST FOR A GOOD LINE OR GROUP
	JMS I .-2	/SORRY
	JMP DOGRP+2	/OK- GET THE FIRST LINE
/////
/COMMAND BRANCH TABLE:  NINE NEW COMMANDS ARE AVAILABLE

	XPOPJ		/STARTS THE TABLE
COMGO,	CERR		/@	INDIRECT
	ASK		/A
	BREAK		/B
	PC1		/C
	DO		/D
	ERASE		/E
	FOR		/F
	GOTO		/G
	HESI		/H	HESITATE
	IF		/I
	JUMP		/J
	CERR		/K	KONTROL
	LCMNDS		/L
	MODIFY		/M
	NEXT		/N
	ON		/O
	CERR		/P	PLOT
	QUIT		/Q
	RETRN		/R
	SET		/S
	TYPE		/T
	CERR		/U	USER
	CERR		/V	VIEW
	WRITE		/W
	SET		/X	XECUTE
	YNCR		/Y	YNCREMENT
	ZERO		/Z
/////

CONT,	SKP CLA		/COMMAND RETURN - 'CONTINUE'
	GETC
	SORTJ		/SEARCH FOR A ';' OR A C.R.
	    ILIST-1
	    IGO-ILIST
	JMP CONT+1
/////

CMATST,	0		/TEST FOR A COMMA: 'TSTCMA'
	CLA
	TAD CHAR
	TAD (-",
	SZA CLA
	JMP I CMATST	/FIRST RETURN IF IT'S NOT
	GETC
	ISZ CMATST
	JMP I CMATST	/REMOVE IT AND TAKE 2ND RTN
/////
	PAGE 4
FOR,	PUSHJ		/LOOP CONTROL BEGINS WITH 'SET'
	    EVAL
	SORTJ		/TEST LAST CHAR FROM 'EVAL'
	    TLIST-1
	    FGO-TLIST
	JMP FOR		/ALLOW SPACES BUT DON'T ADVERTISE
MEQ,	-"=

/'EVAL' FOUND A REPLACEMENT OPERATOR (=): STACK THE
/ LAST OPERATION AND LOCK THE VARIABLE IN POSITION.

	*TAD FENT&177	/WIERD!
EQLS,	0		/PLACED HERE TO SAVE A WORD
	TAD CHAR
	TAD MEQ
	SZA CLA
	JMP I EQLS
	CDF V		/SOLVE THE 'ZVR' PROBLEM!
	TAD I XRT2
	SNA CLA
	CMA		/PROTECT ZERO VARIABLES
	TAD I PT1
	DCA I PT1
	TAD LASTOP	/STACK CURRENT OPERATOR
	PUSHA
	TAD PT1
	PUSHA		/SAVE POINTER TO VARIABLE
	SP1
	JMP I FCONT-1	/SET 'LASTOP' TO 1 FOR '='
/////

FINCR,	GETC		/SKIP THE COMMA THAT GOT US HERE
	TAD LASTC	/IS IT 'SET' OR 'FOR' ?
	SNA CLA
	JMP FOR		/'SET I=1,N=2'
	TAD PT1		/'FOR I=1,N'
	PUSHA		/RESAVE THE VARIABLE POINTER
	PUSHJ		/EVALUATE THE INCREMENT
	    EVAL
	SORTJ		/TEST THE NEW TERMINATOR
	    ILIST-1
	    FLIST-ILIST
	ERROR2		/ILLEGAL TERMINATOR IN 'FOR'
/////

FINFIN,	PUSHF		/STANDARD INCREMENT
	    FLTONE
	JMP FCONT

FLIMIT,	PUSHF		/SAVE THE INCREMENT; GET THE LIMIT
	    FLAC
	PUSHJ		/(NO ERROR DETECTION AFTER LIMIT)
	    EVAL-3
FCONT,	PUSHF		/SAVE THE LIMIT
	    FLAC
/THE POINTER TO THE TOP OF THE STACK IS SAVED EACH TIME.
/THIS PERMITS 'BREAKS' WHICH CUT THROUGH ALL INTERVENING
/SUBROUTINE CALLS.  THE LEVEL POINTERS ARE STACKED FROM
/'RANDOM' DOWNWARDS, PERMITTING 15 OR MORE NESTED LOOPS.
/NO CHECKING IS PERFORMED SINCE THE PROBABILITY OF AN
/OVERFLOW OCCURING IS VANISHINGLY SMALL.

	PUSHF		/SAVE THE CURRENT TEXT POSITION
	    TEXTP
	CMA
	TAD FORLVL	/ADJUST LEVEL COUNTER
	DCA FORLVL
	CMA
	TAD PDLXR	/SAVE RETURN POINTER
	DCA I FORLVL
	PUSHJ		/EXECUTE TO THE END
FPROC,	    PROC-1

/RETURN FROM OBJECT STATEMENTS

	POPF		/RESET THE TEXT POINTERS
	    TEXTP
	POPF		/RECOVER THE LIMIT
	    BUFFER
	POPF		/LOAD THE INCREMENT
	    FLAC
	POPA		/RESTORE THE VARIABLE POINTER
	DCA PT1
	ISZ I BKSW	/TEST FOR A 'BREAK'
	JMP FTEST	/NONE

FEXIT,	ISZ FORLVL	/REMOVE ONE LEVEL
	ISZ LASTC	/CHECK FOR CONTINUATION
	POPJ		/NONE, END THIS LINE
	PUSHF
	    NEXTP
	POPF		/MOVE TO NEW TEXT POSITION
	    TEXTP
	JMP I MCR	/CHECK FOR A LINENO (CF. 'IF')

FTEST,	SM0
	AND HORD
	DCA SIGN	/SAVE SIGN OF THE INCREMENT
	FENT
	FADDIPT1	/INCREMENT LOOP INDEX
	FPUTIPT1 	/AND SAVE IT AGAIN
	FSUB I BUFFPT	/COMPARE WITH LIMIT
	FEXT
	TAD SIGN
	TAD HORD	/TEST RESULT
	SMA SZA CLA
	JMP FEXIT	/EXIT FROM 'FOR'
	TAD I FORLVL	/EFFECTIVE PUSHDOWN FOR
	DCA PDLXR	/PT1, INCREMENT, LIMIT
	JMP I FPROC	/TEXTP, & PUSHJ(PROC-1)
/THE 'NEXT' AND 'BREAK' COMMANDS ADD A NEW DIMENSION TO
/FOCAL'S LOOPS BY PERMITTING NESTED OPERATIONS AND EARLY
/TERMINATION.  THEY ARE PATTERNED AFTER SIMILAR COMMANDS
/IN 'COLPAC' & 'FOCLF'.  SPECIAL THANKS TO THESE AUTHORS!

/BOTH COMMANDS MAY INCLUDE A LINENO TO SPECIFY A BRANCH.
/WHEN NO LOOPS ARE IN PROGRESS THESE COMMANDS ARE SIMPLY
/'NOPS' UNLESS A BRANCH IS SPECIFIED, IN WHICH CASE IT
/WILL BE TAKEN.  THUS A LINE CONTAINING AN 'N' OR A 'B'
/COMMAND CAN BE EXECUTED BY ANY PART OF THE PROGRAM.

BREAK,	SM1		/SET THE 'BREAK' FLAG
	DCA I BKSW	/ (RESET BY 'GETC')
NEXT,	TAD I FORLVL	/IS THERE A MATCHING 'FOR'?
	SNA
	JMP I MCR	/NO, TREAT LIKE A SPECIAL 'GOTO'
	DCA PDLXR	/YES, DROP THE STACK TO THIS LEVEL
	SM1		/SET THE 'NEXT' SWITCH
	DCA LASTC
	PUSHF
	    TEXTP
	POPF		/AND SAVE THE CURRENT POSITION
	    NEXTP
	POPJ		/THEN RETURN TO THE 'FOR' LOOP
/////

/SEARCH FOR A GIVEN LINE NUMBER: 1ST RETURN IF MISSING,
/ 2ND IF FOUND.  'THISLN'= TARGET LINE OR NEXT LARGER -
/'LASTLN'=LESSER AND OR LAST.  'GETC' POINTERS ARE SET,
/BUT NOT THE PC SO ERRORS SHOW THE CORRECT LINE NUMBER.

XFIND,	0		/FIND A LINE OF TEXT - 'FINDLN'
	CDF T
	TAD HEADER
	DCA LASTLN	/INITIALIZE TO THE HEADER LINE
	TAD LASTLN

FINDN,	DCA THISLN	/SAVE NEW LINE POINTER
	TAD THISLN
	DCA AXOUT	/INITIALIZE UNPACKING REG.
	TAD LINENO
	STL CIA
	TAD I AXOUT	/ADVANCE AND COMPARE
	SNA CLA
	ISZ XFIND	/FOUND IT - TAKE 2ND EXIT
	SNL
	JMP FINDX	/FOUND IT OR PAST IT
	TAD THISLN
	DCA LASTLN	/SAVE POINTER
	TAD I THISLN
	SZA		/END OF TEXT?
	JMP FINDN	/NOT YET
FINDX,	DCA XCT		/CLEAR UNPACKING SWITCH
	CDF P
	JMP I XFIND	/1ST RETURN = NOT FOUND
/INPUT-OUTPUT COMMANDS:  -ASK- AND -TYPE-
/'SET' TURNS INTO 'TYPE' WHEN THE TRACE SWITCH IS ON

	*.!177-3	/PUT 'SET' JUST BEFORE 'TYPE'
SET,	DCA LASTC	/THE MOST IMPORTANT COMMAND !
	TAD TRACE	/CHECK THE TRACE SWITCH
	SMA CLA		/SKIP IF ITS ON
	JMP FOR		/OFF: USE THE 'FOR' ROUTINE
/////

TYPSET,	PUSHJ		/EVALUATE THE EXPRESSION
	    EVAL
	PRINTN		/OUTPUT IT & RESET 'ATSW'

TASK,	SPNOR		/MOVE TO NEXT ARGUMENT
	SORTJ		/!,",#,$,%,:  ?
	    ALIST-1
	    AGO-ALIST
	ISZ I ATSW	/'ASK' OR 'TYPE'?
	JMP TYPSET
/////

	PUSHJ		/LOOKUP THE VARIABLE
	    GETARG
	TAD CHAR	/SAVE THE CHARACTER
	DCA LASTC
	TAD PROMPT
	NOP		/'ECHOC'
READ,	SP1
	READN		/GET THE NUMBER
YLST,	";
	CR		/SORT LIST FOR 'YNCR'
	"-		/IS THE INPUT SWITCH
	FENT
	FPUTIPT1	/SAVE THE VALUE
	FEXT
ENDFI,	TAD CHAR	/'ALTMODE' RETURN
	DCA I ASK	/SAVE THE TERMINATOR
	TAD LASTC
	DCA CHAR	/RESTORE TEXT CHARACTER
ASK,	CLA SM1		/POINTS TO 'TERM'
TYPE,	DCA I ATSW	/SET THE SWITCH
	JMP TASK
/////

TBACK,	TAD CCR		/'#' = CR ONLY
	JMS I OUTDEV
	DCA I TABCNT
	TAD (200-CR	/CREATE A NULL FOR DELAY
TCRLF,	TAD CCR		/'!' = CR AND LF
	PRINTC
TASK4,	GETC		/MOVE ALONG
	JMP TASK
/////
/DISPATCH TABLE FOR 'ASK' 'TYPE' 'ZERO' 'FOR' 'SET' 'IF'

AGO,	TQUOT+1		/" - PRINT CHAR STRING
	TASK4		/, - END OF EXPRESSION
	TCRLF		/! - CR AND LF
	TFRMT		/% - SET OUTPUT FORMAT
	TBACK		/# - CARRIAGE RETURN ONLY
	TDUMP		/$ - DUMP THE SYMBOL TABLE
	TABX		/: - TABULATE OR SKIP
ZGO,	ZERO+2		/, - MULTIPLE ZERO COMMAND
FGO,	FINCR		/, - MULTIPLE SETS OR FOR
IGO,	THEN		/, - UNUSED 'IF' BRANCHES
YGO,	PROC-1		/; - END OF COMMAND
	PROC+2		/CR  END OF LINE
	DECR		/- - DECREMENT A VARIABLE
/////
ALIST,	""		/'SORTJ' CONTROL TABLE
	",
	"!
	"%
	"#
	"$
PROMPT,	":		/FOR 'ASK'
ZLIST,	",		/FOR 'ZERO'
TLIST,	",		/FOR 'SET'
ILIST,	",		/FOR 'IF/ON'
	";
	CR		/'PUSHJ' ENDS THE LIST
/////

TFRMT,	PUSHJ		/MOVE PAST THE '%'
	    EVAL-3
	TAD C100	/POINT TO PC0
	DCA XRT
	PUSHJ		/READ FORMAT
	    TYPEPT
	TAD LINENO
	DCA FISW	/SAVE FOR LATER
	JMP TASK
/////
TQUOT,	PRINTC		/ECHO
	ISZ I DMPSW	/DISABLE TRACE
	GETC		/PASS QUOTE - READ NEXT
	DCA I DMPSW	/RESTORE THE TRACE
	SORTJ
	    TLIST2-1	/QUOTE OR CR
	    TLIST3-TLIST2
	JMP TQUOT
/////

AXIND,	0		/'DCAIAXIN'
	CDF T
	DCA I AXIN
	CDF P
	JMP I AXIND
/PUSHDOWN LIST SUBROUTINES - STACK IS IN FIELD 0

XPUSHJ,	0		/RECURSIVE SUBROUTINE CALL
	TAD I XPUSHJ	/GET THE TARGET ADDRESS
	DCA XPUSHA	/SAVE FOR THE INDIRECT JUMP
	TAD XPUSHJ	/GET THE RETURN ADDRESS
	IAC		/BUMP IT
	SKP		/AND PUSH IT ON THE STACK

XPUSHA,	0		/PUSH THE AC ONTO THE STACK
	CDI L
	JMP I (APUSHX
	JMP I XPUSHA

XPOPJ,	CDF S
	TAD I PDLXR	/GET THE RETURN ADDRESS
	DCA XPOPA
	JMP XPOPA+3	/RESTORE D.F. AND BRANCH

XPOPA,	0		/PULL SOMETHING OFF THE STACK
	CDF S
	TAD I PDLXR
	CDF P
	JMP I XPOPA

XPUSHF,	0		/SAVE A FLOATING-POINT NUMBER
	TAD XPUSHF
	CDI L		/USE LOWER FIELD ROUTINE FOR THIS
	DCA I (MPUSHF
	CDF P		/RESET THE CALLING FIELD
	JMP I (MPUSHF+2	/UPPER FIELD ENTRY POINT

XPOPF,	0		/RESTORE A FLOATING-POINT NUMBER
	CLA CMA
	TAD I XPOPF	/BACKUP DATA POINTER
	ISZ XPOPF	/AND ADVANCE THE RETURN
	DCA XRT
	JMS XPOPA	/DUMP FOUR WORDS
	DCA I XRT
	JMS XPOPA
	DCA I XRT
	JMS XPOPA
	DCA I XRT
	JMS XPOPA
	DCA I XRT
	JMP I XPOPF

	PAGE
/FIND OR ENTER A VARIABLE IN THE SYMBOL TABLE

GETARG,	TESTC		/GET FIRST LETTER OF NAME
	LPRTST		/FUNCTIONS AND NUMBERS
XINC,	WORDS+1		/ARE NOT GOOD VARIABLES
	ERROR2		/BAD ARG IN ASK, YNCR OR ZERO
GETVAR,	SM1		/ENTRY POINT FOR 'EVAL'
	FLOAT		/SET COUNTER & CLEAR SUBSCRIPT
	TAD CHAR
	AND P77		/USE 6-BIT CODES
	RTL6		/MOVE TO THE LEFT - 'BSW'
	DCA THISOP	/SAVE WHERE WE CAN PUSH IT
GETLP,	GETC		/GET NEXT CHARACTER
	TESTX		/END OF THE NAME?
	JMP GSERCH	/YES
	ISZ HORD	/IS THIS THE SECOND CHAR?
	JMP GETLP	/IGNORE ADDITIONAL CHARS
	TAD CHAR
	AND P77		/MASK IT OFF
	TAD THISOP	/MERGE THE OTHER HALF
	JMP GETLP-1
/////
GSERCH,	JMS I GETARG+1	/CHECK FOR A SUBSCRIPT
	JMP GS1		/NONE
	JMS I (ECALL	/PICK IT UP
	JMS I (DBLSUB	/CHECK FOR DOUBLE SUBSCRIPTS
	POPA		/GET VARIABLE NAME FROM PDL
	JMS I (PARTEST	/CHECK FOR PROPER RIGHT PAREN.
	GETC		/MOVE PAST CLOSING PARENS
	FIXIT		/CONVERT ALL THIS TO AN INTEGER
	CIA		/INVERT FOR FAST CHECKING
GS1,	DCA T3		/SAVE SUBSCRIPT
	TAD THISOP
	CIA		/INVERT NAME FOR THE SAME REASON
	DCA T1
	CDF V
	DCA I LASTV	/DEFINE THE END OF THE TABLE
	TAD SECRTV	/BEGIN WITH SECRET VARIABLES
	JMP GLOOP+2
/////
	CMA		/BACKUP TO NAME
GLOOP,	TAD XINC	/ADVANCE ONE
	TAD XRT2
	DCA XRT2
	TAD I XRT2	/CHECK NAME
	SNA		/END OF THE TABLE?
	JMP MAKVAR	/YES
	TAD T1		/'SAM'
	SZA CLA		/MATCH?
	JMP GLOOP	/TRY AGAIN
	TAD T3
	TAD I XRT2	/CHECK SUBSCRIPT
	SZA CLA
	JMP GLOOP-1	/NOT THIS ONE
	STL		/L=1 IF FOUND
	ISZ XRT2	/POINT TO DATA
GEXIT,	TAD XRT2
	DCA PT1
	POPJ		/RESETS D.F.
/////
MAKVAR,	TAD TABEND	/SYMBOL TABLE LIMIT
	STL CIA
	TAD LASTV
	TAD GINC	/COMPARE WITH NEW END POINT
	SNL
	JMP ZSERCH	/FULL: TRY TO REPLACE A ZERO
	TAD TABEND
	DCA LASTV	/UPDATE STORAGE POINTER
	STL CMA
	JMP ZFOUND+2	/INSERT NAME & CLEAR DATA
/////
ZSERCH,	CLA STL IAC	/INITIATE SEARCH FOR ZERO
	TAD FIRSTV
	JMP ZINITL

ZLOOP,	TAD LASTV	/CHECK PROGRESS
	CLL CMA
	TAD XINC	/ADVANCE TO NEXT ONE
	TAD XRT2
	SZL		/ALL DONE?
	ERROR2		/YES: SYMBOL TABLE IS FULL
	TAD LASTV	/SETS THE LINK
ZINITL,	DCA XRT2	/XRT2=XRT2+XINC-1
	TAD I XRT2	/EXPONENT +
	TAD I XRT2	/HIGH ORDER
	SNA CLA		/CHECK THAT BOTH ARE ZERO
	SNL		/AND NOT ADDITIVE INVERSES
	JMP ZLOOP
/////
ZFOUND,	CDF V		/ALSO USED BY 'ZERO'
	TAD M4		/POINT TO THE NAME
	TAD XRT2	/CLEAR THE LINK
	DCA XRT2
	TAD THISOP	/REPLACE IT
	DCA I XRT2
	TAD LORD	/AND THE SUBSCRIPT TOO
	DCA I XRT2

	DCA I XRT2	/ZERO THE DATA
	TAD XRT2
	DCA XRT		/SWITCH INDEX REGISTERS
	DCA I XRT
	DCA I XRT
	DCA I XRT	/'NOP' FOR 3-WORD VERSION
	JMP GEXIT	/L=0
/////
TLIST3,	TASK4		/SORT LIST FOR QUOTED STRINGS
	XPOPJ		/AUTOMATIC RIGHT QUOTE MARK
/CONDITIONAL TRANSFER PROCESSES: 'IF', 'ON' AND 'JUMP'

/'IF' TRANSFERS WITH A 'GOTO' BRANCH WHILE 'ON' USES A
/'DO' CALL AND RETURNS TO THE CALLING POINT AFTERWARDS.
/'JUMP' USES THE VALUE OF THE EXPRESSION TO SELECT CALL

ON,	TESTC		/THIS IS ALSO THE 'O' COMMAND
	SM1		/T R-PAR MEANS ITS 'ON'
	DCA LASTC	/F ILLEGAL - WILL BE TRAPPED
	JMP IF+1	/N CONTINUE WITH 'IF'
	CIF L		/L DOUBLE-WORD 'O' COMMAND
	JMP I .+1	/CONTINUE WITH LOWER-FIELD CHECKS
	OCMND

JM,	JMS I (ECALL	/'JUMP (...) S1,S2,S3,S4,S5,...'
	SM1		/SET THE 'DO' FLAG
	DCA LASTC
	FIXIT		/GET SUBROUTINE CALL
	CIA
	JMP IF+3	/THEN USE 'IF' TO FINISH UP

IF,	TESTC		/IGNORE SPACES AND TEST
	JMS I (ECALL	/T
	SM2		/F
	ISZ PDLXR	/N DUMP 'THISOP'
	JMS I (PARTEST	/L CHECK FOR PAREN MATCH
	TAD HORD	/TEST -,0,+
	SPA
	ISZ THISOP
	SPA SNA CLA
THEN,	ISZ THISOP	/COUNT COMMAS
	JMP I (CONT+1	/KEEP LOOKING
	GETC		/MOVE PAST IT
	JMP I MCR	/CHECK WHETHER ITS 'IF' OR 'ON'
/////

	*-CR		/VIA MCR !

	GETLN		/PATCH TO CHECK FOR MISSING LINENO
	SZL		/AND TO CHOOSE BETWEEN 'IF' & 'ON'
	CONTINUE	/NO NUMBER = CONT. WITH SAME LINE
	ISZ LASTC	/TEST FLAG
	JMP I (GOTO+1	/IF (ALSO 'NEXT' OR 'BREAK')
	TSTCMA		/ON (ALSO 'JUMP')
	JMP I (DO+1	/CALL THE SUBROUTINE
	JMP .-2		/PREVENT MULTIPLE 'DO' CALLS

	PAGE 7
/EVALUTE AN EXPRESSION ENDING WITH A TERMINATOR AND LEAVE
/THE RESULT IN 'FLAC' AND 'FLARG'.  'JMS ECALL' EVALUATES
/SUB-EXPRESSIONS, 'PUSHJ;EVAL' SCANS THE CURRENT ONE. NOW
/HANDLES MULTIPLE REPLACEMENT OPERATORS AND CHAR VALUE OP
/ALA FOCAL65.  THANKS TO WAYNE WALL FOR SOME SUPER IDEAS!

ECALL,	0		/RECURSIVE CALL TO 'EVAL'
	TAD .-1
	DCA PT1
	PUSHF		/= 'PT1, THISOP, LASTOP, SORTCN'
	    PT1
ARGNXT,	DCA LASTOP	/SET OR CLEAR THE OP CODE
	GETC		/SKIP THE TERMINATOR
	SKP		/CONTINUE 'EVAL'
/////

EVAL,	DCA LASTOP	/EVALUATION CONTROLLER
	TESTC		/TEST CHARACTER & IGNORE SPACES
	JMP ETERM1	/TERMINATOR
	JMP EFUN	/FUNCTION
	JMP ENUM	/NUMBER
	PUSHJ		/LETTER OF VARIABLE
	    GETVAR	/LOOKUP THE NAME
	SPNOR		/SKIP TO THE OPERATOR
	JMS I EQLSPT	/IS IT AN 'EQUAL SIGN'?
	FENT
	FGETIPT1	/NO, MOVE VALUE TO FLAC
	FEXT
/////

OPNEXT,	TESTC		/CHECK NEXT OPERATOR
	JMP ETERMN	/T
TLIST2,	""		/F - ERROR IN FORMAT
	CR		/N
	JMP EMINUS+1	/L - MISSING OPERATOR
/////

ETERM1,	SM2		/DO SPECIAL CHAR CHECK
	TAD LASTOP
	SMA CLA		/INITIALLY OR AFTER AN '='
	JMP ELPAR
	FLOAT		/SET UP DEFAULT VALUE
	DCA FLAC
	TAD SORTCN	/CHECK FOR '-', '+', PARENS
	TAD M4
	SNA
	JMP EMINUS	/CREATE DUMMY FOR UNARY MINUS
	SPA CLA
	JMP EVAL-2	/IGNORE UNARY PLUS, EXTRA '='
	TAD SORTCN	/TEST FOR NULL PARENTHESES
	TAD M14
	SPA CLA
	JMP ELPAR	/MIGHT BE A LEFT PARENTHESIS
ETERMN,	JMS LPRTST	/ETERM1 FALLS THROUGH 'LPRTST'
	TAD SORTCN
	SNA		/PARENS OR AN '=' OUT OF PLACE
	ERROR2		/MISSING OPERATOR OR ILLEGAL '='
	TAD M14
	SPA CLA		/CHECK FOR END OF THE EXPRESSION
EMINUS,	TAD SORTCN
	DCA THISOP	/ZERO = **THE END**

ETERM2,	TAD THISOP	/COMPARE PRIORITIES
	CIA
	TAD LASTOP
	SPA CLA
	JMP ESTACK	/STACK AND CONTINUE
	FENT
BASE,	FPUT I FLARGP	/MOVE THE OPERAND
	FEXT
	SM1
	TAD LASTOP	/FIND OPERATION
	SNA
	JMP EQUALS	/PROCESS AN '='
M10,	SPA SNA SZL CLA
	POPJ		/NONE, EXIT 'EVAL'
	POPF
	    FLAC	/GET THE PREVIOUS RESULT
	TAD LASTOP
	CLL RTR		/SHIFT OP CODE INTO PLACE
	RTR
	TAD BASE	/COMPENSATES FOR OP CODE
	DCA OPER
	FENT
OPER,	0000		/'FXXX I FLARGP'
	FEXT
	POPA		/GET NEXT OPERATION
	DCA LASTOP
	JMP ETERM2
/////

EQUALS,	POPA		/GET VARIABLE POINTER
	DCA PT1
EQLSPT,	TAD FENT&177	/DOUBLE KLUDGE = 'FPUTIPT1'
	JMP OPER-2
/////

ESTACK,	JMS LPRTST	/TEST FOR SUB-EXPRESSION
	SKP
	JMP EPAR2	/GO EVALUATE EXPRESSION
	TAD LASTOP	/STACK CURRENT OPERATOR
	PUSHA
	PUSHF		/SAVE THE RESULT TOO
	    FLAC
	TAD THISOP	/ADVANCE THE OPERATOR
	JMP ARGNXT
/////
EFUN,	DCA THISOP	/CLEAR THE FUNCTION NAME
	GETC
	TESTX		/LOOK FOR A TERMINATOR
	JMP EFUN2	/FOUND ONE
	TAD THISOP
	CLL RTL		/GENERATE THE HASH CODE
	TAD CHAR
	TAD P7600
	JMP EFUN
/////

EFUN2,	JMS LPRTST	/MUST BE FOLLOWED BY PARENS
	ERROR2		/VARIABLE NAME BEGINS WITH 'F'
	JMS ECALL	/CALL 'EVAL' TO READ THE ARGUMENT
	POPA
	SNA		/IS IT A FSF?
	JMP I .-1
	SORTJ		/BRANCH ON FUNCTION CODE
	    FNTABL-1
	    FNTABF-FNTABL

ELPAR,	JMS LPRTST	/LEFT PAREN OR FELL THROUGH TABLE
ERROR3,	ERROR2		/DOUBLE OPERATORS OR UNKNOWN FUNC
EPAR2,	JMS ECALL	/EVALUATE NESTED EXPRESSION
	ISZ PDLXR	/DUMP THE EXTRA ARGUMENT
	RETURN		/COMPLETE THE FUNCTION CALL
/////

LPRTST,	0		/SKIP IF CHAR IS A LEFT PAREN
	TAD SORTCN
	TAD M10
	SNA		/AND CATCH SINGLE QUOTES TOO
	JMP ECHR
	AND M4		/=7774
	SNA CLA
	ISZ LPRTST	/1-3 ARE PARENS
	JMP I LPRTST
/////

ENUM,	READN		/READ A NUMBER FROM TEXT
	JMP OPNEXT	/'JMP' IS NEGATIVE
/////

	*.!177-4	/PUT THIS RIGHT AT THE END
ECHR,	ISZ I DMPSW
	GETC		/GET THE NEXT CHARACTER
	DCA I DMPSW
	TAD CHAR	/FLOAT IT
	FLOAT
	JMP EFUN3+1	/ALMOST LIKE A 'RETURN'
/////
/FUNCTION RETURNS AND CHARACTER TESTING:

	*2001
PARTEST,0		/TEST THE PAREN MATCHING
	DCA THISOP	/SAVE THE AC IN 'THISOP'
	POPA		/RESTORE LAST OPERATION
	DCA LASTOP
	SP2		/GET OPENING PAREN + TWO
	POPA
	CMA		/NEGATE AND SUBTRACT ONE
	TAD SORTCN	/(PARENS DIFFER BY THREE)
	SZA CLA		/DO THEY MATCH?
	ERROR2		/NO THEY DON'T - TOO BAD!
	JMP I PARTEST	/ENTRY POINT IS A BETA REGISTER
/////

XRTL6,	0		/ROTATE THE AC LEFT SIX - 'RTL6'
	CLL RTL
	RTL
	RTL
	JMP I XRTL6	/'XRTL6' IS ALSO A BETA REGISTER
/////

FL0AT,	CLL RAR		/UNSIGNED INTEGER FLOAT ROUTINE
	FLOAT
	RAR
	DCA LORD	/JUST SHIFT EVERYTHING RIGHT ONE
	ISZ EXP

EFUN3,	JMS PARTEST	/'RETURN' - CLEARS AC & RESETS DF
	NORMALIZE
	GETC		/SKIP THE TERMINATOR
	JMP I .+1
	OPNEXT		/CONTINUE WITH 'EVAL'
/////
MF,	-"F		/'FN' CHECK FOR 'TESTC'
C232,	232		/'EOF' CHECK FOR 'FIND'
/////

CTEST,	0		/TEST THE NEXT CHARACTER - 'TESTC'
	SPNOR		/IGNORE SPACES
	JMS XTEST	/CHECK ALL THE TERMINATORS
	JMP I CTEST	/IT WAS A TERM - 'SORTCN' IS SET
	TAD CHAR
	TAD MF
	SNA CLA
	JMP XT3		/FUNCTION
	JMS NTEST
	SKP		/PERIOD
	ISZ CTEST	/OTHER
	ISZ CTEST	/NUMBER
XT3,	ISZ CTEST
	JMP I CTEST	/RETURNS: T;F;N;L
/////
/NEW ROUTINE TO TEST IF 'CHAR' IS A TERMINATOR - 'TESTX'

/THIS ROUTINE WAS DEVISED BY JIM CRAPUCHETTES (FOCAL8-269)
/TO SHORTEN THE TIME REQUIRED FOR THIS TEST BY A FACTOR OF
/3-5.  THIS RESULTS IN A NET IMPROVEMENT OF ABOUT 12%.

XTEST,	0		/TERMINATOR TEST - SETS 'SORTCN'
	TAD CHAR
	TAD M336
	SMA SZA		/IS IT > 336?
	JMP NO		/NOT A TERMINATOR
	TAD P4
	SMA SZA		/IS IT > 332?
	JMP YES
RANK,	TAD P34
	SMA SZA		/IS IT > 276?
	JMP NO		/IT'S A LETTER
	TAD P3
	SMA		/IS IT > 272?
	JMP YES+2
	TAD P14
	SMA SZA		/IS IT > 257?
	JMP NO		/IT'S A NUMBER
	TAD P11
	SMA SZA		/IS IT > 247?
	JMP YES+1
	TAD P6
	SZA		/IS IT A SPACE?
	TAD P23
NO,	SNA CLA		/IS IT A CR?
	JMP YES+2
	ISZ XTEST	/NOT A TERMINATOR
	JMP I XTEST

YES,	TAD P11		/ [ \ ] ^
	TAD P3		/ ' ( ) * + , - . /
	TAD RANK	/ ; < = > CR
	DCA .+1
	TAD RANK	/GET PRIORITY NO.
	SPA
	JMP NO		/OMIT PERIOD &  \
	DCA SORTCN
	JMP I XTEST
/////
NTEST,	0		/TEST FOR PERIOD, NUMBER - 'TESTN'
	TAD CHAR
	TAD MPER
	SZA
	ISZ NTEST
	TAD M14		/TEST FOR 0-9
	CLL
	TAD P12
	DCA SORTCN	/SAVE RESULT
	SZL
	ISZ NTEST	/IF A NUMBER
	JMP I NTEST
/////

/ PRIORITY TABLE FOR 'EVAL'

P34,	34		/;	01 =  =
	13		/<	03 =  +
	 0		/=	04 =  -
	16		/>	05 =  /
	10		/'	06 =  *
P11,	11		/(	07 =  ^
P14,	14		/)	10 =  '
P6,	 6		/*	11 =  (
P3,	 3		/+	12 =  [
P23,	23		/,	13 =  <
P4,	 4		/-	14 =  )
MPER,  -".		/.	15 =  ]
	 5		//	16 =  >
P12,	12		/[	23 =  ,
M336,  -"^		/\	34 =  ;
	15		/]	34 =  CR
	 7		/^	34 =  SPACE
/////

/TRANSFER LIST FOR 'SET' AND 'FOR'

FLIST,	FLIMIT		/,
	FINFIN		/;
	FINFIN-1	/CR
/////
/LIST OF CODED FUNCTION NAMES (LOCATIONS IN 'FNTABF')


	F2=200^4+200
	F3=200^4+200^4+200

FNTABL=.
	"C^4+"O^4+"M-F3	/COM
	"I^4+"T^4+"R-F3	/ITR
	"R^4+"A^4+"C-F3	/RAC
	"S^4+"G^4+"N-F3	/SGN
	"A^4+"B^4+"S-F3	/ABS
	"S^4+"Q^4+"T-F3	/SQT
	"R^4+"A^4+"N-F3	/RAN
	"S^4+"I^4+"N-F3	/SIN
	"C^4+"O^4+"S-F3	/COS
	"A^4+"T^4+"N-F3	/ATN
	"L^4+"O^4+"G-F3	/LOG
	"E^4+"X^4+"P-F3	/EXP

	     "R^4+"A-F2	/RA
	     "L^4+"S-F2	/LS
	     "S^4+"R-F2	/SR
	     "M^4+"Q-F2	/MQ
	     "I^4+"N-F2	/IN
	"O^4+"U^4+"T-F3	/OUT
	"I^4+"N^4+"D-F3	/IND
	"M^4+"I^4+"N-F3	/MIN
	"M^4+"A^4+"X-F3	/MAX
	"B^4+"L^4+"K-F3	/BLK
	"L^4+"E^4+"N-F3	/LEN
	"T^4+"R^4+"M-F3	/TRM

	"D^4+"A^4+"C-F3	/DAC
	"A^4+"D^4+"C-F3	/ADC
	"T^4+"R^4+"G-F3	/TRG
	"B^4+"U^4+"F-F3	/BUF
	"T^4+"I^4+"M-F3	/TIM
	"D^4+"I^4+"N-F3	/DIN
	"R^4+"E^4+"Q-F3	/REQ
	"C^4+"T^4+"R-F3	/CTR
	"D^4+"V^4+"M-F3	/DVM
	"X^4+"T^4+"R-F3	/XTR
	"N^4+"E^4+"W-F3	/NEW
	"D^4+"A^4+"Y-F3	/DAY


/THE HASH CODE HAS BEEN CHANGED TO IMPROVE UNIQUENESS.
/CHARACTERS ARE SHIFTED 2 BITS AT A TIME AFTER MASKING
/THE LEADING BIT.  THE TABLE IS ENDED BY 'EXTR'
/UNPACK A CHARACTER FROM THE TEXT BUFFER: 'GETC'

EXTR,	JMS GET1	/EXTENDED CHARACTER
	SNA		/300?
	JMP UTE-1	/RESTORE '@'
	TAD M40
	SMA		/REVERSE THE TEST
	JMP UTE+1	/340-376
	JMP UTE+2	/201-237
/////
TOGL,	ISZ TRACE	/TOGGLE THE TRACE FLOP
	SM1
	DCA TRACE
M40,	SMA SZA CLA	/GET THE NEXT CHARACTER

UTRA,	0		/UNPACK A CHARACTER
	JMS GET1
	SZA		/TURN NULLS INTO SPACES
	TAD M40		/SUBTRACT 40
UTE,	SPA		/WHICH SET?
	TAD C100	/300-337
	TAD M77		/240-276, 200
	SZA		/IS IT A QUESTION MARK?
	JMP UTX		/NO,  RESTORE THE CHAR
	TAD XPRNT	/YES
	SNA CLA		/DOES IT GET SPECIAL ATTN?
	JMP TOGL	/YES, TOGGLE THE TRACE FLOP
	TAD M40		/NO,  TREAT IT NORMALLY
UTX,	TAD P337
	DCA CHAR
	TAD XPRNT	/IF XPRNT=0, TRAP '?' MARKS
	TAD TRACE	/	 >0, IGNORE '?' MARKS
	SPA CLA		/IF TRACE=0, THE TRACE IS OFF
	PRINTC		/	 -1, THE TRACE IS ON
	JMP I UTRA	/PRINT ONLY IF SUM IS NEGATIVE
/////
GET1,	0		/UNPACK 6 BITS
	ISZ XCT		/STARTS WITH 0
	JMP GET3
	TAD GTEM
GEND,	AND P77
	TAD M77
	SNA
	JMP EXTR	/EXTENDED
	TAD P77
	JMP I GET1
M77,	-77
/////
XSPNOR,	0		/IGNORE INTERVENING SPACES: 'SPNOR'
	TAD CHAR
	TAD M240
	SZA CLA
	JMP I XSPNOR
	JMS UTRA
	JMP XSPNOR+1
GET3,	CLA CMA		/RESET THE FLIP-FLOP
	DCA XCT
	CDF T
	TAD I AXOUT	/GET 12-BITS
	CDF P
	DCA GTEM
	TAD GTEM
	RTR
	RTR		/BSW
	RTR
	JMP GEND	/RETURN WITH THE FIRST CHARACTER
/////

XPRNT,	0		/PRINT A LINE NO. - 'PRNTLN'
	TAD C240	/SET UP A SPACE
	DCA CHAR
	TAD LINENO	/THE ENTRY POINT IS 'DMPSW'
	SNA
	JMP I XPRNT	/NO NUMBER FOR THE HEADER
	RTL6
	AND P77
	JMS I PRNTX	/TWO-DIGIT 'GROUP' NUMBER
	SM2		/TO GENERATE A '.'
	PRINTD
	TAD LINENO
	JMS I PRNTX	/TWO-DIGIT 'STEP' NUMBER
	PRINTC
	JMP I XPRNT
PRNTX,	PRNT
/////

/  NEW ROUTINE TO TEST IF 'CHAR' IS A SPACE, SEMICOLON,
/COMMA OR CARRIAGE RETURN; SKIPS IF IT IS ANY OF THESE.

XSORT,	0		/COMMAND WORD SORT - 'SORTX'
	TESTCR
	TAD M240	/-SPACE
	SZA
	TAD CHAR	/NOT CR
M240,	SMA SZA
	TAD MSC		/SEMICOLON
	SPA
	TAD P17		/COMMA
	SNA CLA
	ISZ XSORT	/ONE OF THE ABOVE
	JMP I XSORT
MSC,	SP-";
/////

/'PACKC' LIST - ALLOWS ROOM FOR 'FNTABF' TO GROW

PACGO,	PQST		/?
	PCAT		/@
	RUB1		/RO
/LIST OF FUNCTION ADDRESSES (NAMES ARE IN 'FNTABL')


FNTABF=.
	FCOM		/COM	-COMMON STORAGE
	FITR		/ITR	-NEW INTEGER FN
	FRAC		/RAC	-FRACTIONAL PART
	FSGN		/SGN	-SIGN= -1, 0, +1
	FABS		/ABS	-ABSOLUTE VALUE
	FSQT		/SQT	-SQUARE ROOT
	FRAN		/RAN	-RANDOM NUMBER
	FSIN		/SIN	-TRIG FUNCTIONS FOR
	FCOS		/COS	-ANGLES IN RADIANS
	FATN		/ATN	-USE PI TO CONVERT
	FLOG		/LOG	-NAPERIAN LOGARITHM
	FEXP		/EXP	-EXPONENTIAL (BASE E)

/END OF BASIC NUMERICAL FUNCTIONS - REMAINDER DO I/O

	FRA		/RA	-RANDOM ACCESS STORAGE
	ERROR3		/LS	-READ THE LEFT SWITCHES
	FSR		/SR	-SW. REG. OR R. SWITCHES
	FMQ		/MQ	-DISPLAY A NO. IN THE MQ
	FIN		/IN	-SINGLE CHARACTER INPUT
	FOUT		/OUT	-SINGLE CHARACTER OUTPUT
	FIND		/IND	-CHARACTER SEARCH
	FMIN		/MIN	-MINIMUM VALUE
	FMAX		/MAX	-MAXIMUM VALUE
	FBLK		/BLK	-STARTING BLOCK
	FLEN		/LEN	-FILE LENGTH
	FTRM		/TRM	-INPUT TERMINATOR

/ADDITIONAL LABORATORY-TYPE FUNCTIONS

	ERROR3		/DAC	-ANALOG OUTPUT
	ERROR3		/ADC	-ANALOG INPUT
	ERROR3		/TRG	-SCHMITT TRIGGERS
	ERROR3		/BUF	-DISPLAY BUFFER STORAGE
	ERROR3		/TIM	-ELAPSED TIME INTERVAL
	ERROR3		/DIN	-DIGITAL INPUT REGISTER
	ERROR3		/REQ	-PROGRAMABLE OSCILLATOR
	ERROR3		/CTR	-FREQUENCY COUNTER
	ERROR3		/DVM	-DIGITAL VOLTMETER
	ERROR3		/XTR	-EXTRA FUNCTION SLOT
	ERROR3		/NEW	-UNDEFINED FUNCTION
	FDAY		/DAY	-SET THE OS/8 DATE
/INSERT A CHAR IN THE TEXT BUFFER  -  'PACKC'

PACBUF,	0		/ALSO HANDLES DELETIONS
	DCA PCK1	/SAVE LINENO PROTECTION
	SORTJ
	    PACLST-1	/CHECK FOR '?', '@', 'RO'
	    PACGO-PACLST
	TAD CHAR
	TAD C240	/DECODE
	AND C100
	SZA CLA		/EXTENDED?
	JMP .+3
PCAT,	TAD P77		/201-237, 300, 340-376
	JMS PCK1
	TAD CHAR	/200, 240-276, 301-336
	JMS PCK1
PACX,	CDF P
	DCA RUB3	/RESET ERROR TRAP
	JMP I PACBUF
/////

PCK1,	0
	AND P77
	ISZ T3		/=0 TO START
	JMP PCK2
	TAD LASTC
	DCAIAXIN
	JMP I PCK1
/////

PCK2,	RTL6		/'BSW'
	DCA LASTC
	STL CMA
	DCA T3
	TAD AXIN
	TAD I PACEND	/CHECK TEXT LIMIT
	SNL CLA
	ERROR2		/TEXT BUFFER FULL
	JMP I PCK1
/////

PQST,	TAD P337	/REPLACE 277 WITH 337
	JMP PACX-1
/////

/A NOTE OF APPRECIATION TO EDWARD TAFT III
/FOR HELPING WITH THIS APPROACH TO 'PACKC'.
/REFERENCE:  DECUS FOCAL8-52  (FOCAL 5/69)
RUB1,	TAD T3		/RUBOUT ONE LETTER
	SMA CLA		/HALF-WORD?
	JMS RUB3	/CHECK POSITION
	TAD P134	/'TAD START'
	JMP .+4		/'ECHOC' PRODUCES
	TAD SPAC	/'BS', 'SP', 'BS'
	ECHOC		/FOR VIDEO TERMINALS
	TAD START
	ECHOC		/7-BIT '\' OTHERWISE
	TAD AXIN
	DCA PT1
	CDF T
	ISZ T3		/WHICH HALF?
	JMP RUB2

	TAD I PT1	/'T3' HAS BEEN RESET!
	CMA
	AND P77		/TEST FOR EXTENDED CHAR
SPAC,	SZA CLA
	JMP PACX
	JMS RUB3	/LOOK OUT FOR LINE NUMBERS!

RUB2,	CLL CMA		/REMOVE 2ND HALF OF STORED WORD
	TAD AXIN
	DCA AXIN	/RESET STORAGE POINTER
	TAD I PT1
	AND RUB1+1	/=7700
	DCA LASTC
	TAD LASTC
	TAD C100	/CHECK FOR EXTENDED
	CLA CMA RAR	/L=1 IF NOT   "
	DCA T3		/RESET BYTE COUNTER
	JMP PACX
/////

RUB3,	0		/WATCH OUT FOR THE BEGINNING
	TAD AXIN
	STL CIA
	TAD BUFR
	TAD PCK1	/PROTECT THE LINENO
	SNL CLA
	JMP PACX	/DON'T DO ANYTHING!
	JMP I RUB3
/////
/THE QUIT COMMAND NOW HAS A 'RESTART' OPTION: 'QUIT 5.1'
/WILL STOP THE PROGRAM, AND THEN RESTART IT AT LINE 5.1.
/'QUIT 0' (OR JUST 'Q') WORKS AS BEFORE. THE RESTART CAN
/BE DEFERRED UNTIL THE OCCURRENCE OF ANY ERROR BY SPECI-
/FYING A NEGATIVE LINE NUMBER: 'QUIT -5.1' WILL SAVE THE
/LINE NUMBER UNTIL YOU ACTUALLY GET AN ERROR.

QUIT,	GETLN		/GET THE LINE NUMBER
	SZL
	JMP START	/ZERO:  (OR NO ARGUMENT)
	TAD T3
	SMA CLA		/CHECK THE SIGN
	JMP ERTRAP+1	/POSITIVE:  AUTO-RESTART
	TAD LINENO
	DCA RUB3	/NEGATIVE:  SAVE FOR LATER
	CONTINUE
/////

ERTRAP,	DCA LINENO	/MOVE THE LINE NUMBER
	TAD BOTTOM
	DCA PDLXR
	TAD LEVEL0	/CLEAR THE STACKS
	DCA FORLVL
	JMP I PACLST	/THEN RESTART THE PROG.

/ERROR RECOVERY ROUTINE:  MODIFIED FOR THE ERROR TRAP

ERROR,	0		/TAB COUNTER TOO !
	I0N
	CLA
	TAD TELSW	/WAIT FOR TTY TO FINISH
	SZA CLA
	JMP .-3
	CDF P
	TAD RUB3	/SHOULD WE TRAP THIS ONE?
	SZA
	JMP ERTRAP	/YES
	TAD ERROR	/PROCESS ERROR CODE TO
	AND C100	/ELIMINATE NON-NUMERICS
	CMA STL RAR	/7777 OR 7737
	JMP I .+1	/NO - REPORT IT
	M20+1

/THE EXPANDED 'JUMP' COMMAND PROVIDES KEYBOARD CHECKING

	JM
JUMP,	TESTC		/CHECK WHICH FORM WE'VE GOT
	JMP I JUMP-1	/T  = 'JUMP (...) *, *, *, *, '
PACLST,	"?		/N 'PACKC' LIST FITS IN HERE TO
	"@		/F  SERVE AS 'NOPS' FOR 'TESTC'
	RO		/L
	TAD INBUF	/ IF NOT A TERMINATOR, ASSUME A
	SZA CLA		/ LINE NUMBER & CHECK THE INPUT
	CONTINUE	/ BUFFER. NOTHING THERE: BRANCH
	JMP I MCR	/ OTHERWISE CONTINUE WITH PROG.
SORTB,	0		/SORT AND BRANCH ROUTINE - 'SORTJ'
	SNA
	TAD CHAR	/ASSUME CHAR IF AC=0
	CIA
	DCA DCAT2
	TAD I SORTB	/FIRST ARGUMENT IS LIST-1
	ISZ SORTB
	DCA XRT
	TAD I XRT
	SPA		/LISTS ARE ENDED BY NEGATIVE NOS.!
	JMP SEX		/NOT THERE!
	TAD DCAT2
	SZA CLA		/MATCH?
	JMP .-5		/NOT REALLY
	TAD XRT
	TAD I SORTB	/COMPUTE ADDRESS
	DCA SORTB
	TAD I SORTB	/DEBUG: AC = ADDRESS
	DCA SORTB
SEX,	SZA CLA		/CLEAR AC IF NO MATCH
	ISZ SORTB	/TAKE THE SECOND EXIT
	JMP I SORTB
/////



/IMPROVED SYMBOL TABLE DUMP

/THE NUMBER OF VARIABLES PER LINE IS DETERMINED BY THE EX-
/PRESSION FOLLOWING THE '$'.  THUS 'TYPE $4' WILL PRINT 4
/VARIABLES PER LINE.  IF NO VALUE IS SPECIFIED (OR 0) THE
/PREVIOUS VALUE WILL BE USED.  THE DEFAULT IS INITIALLY 3.

TDUMP,	PUSHJ		/GET NUMBER OF VARIABLES PER LINE
	    EVAL-3
	FIXIT
	CIA
	SZA
	DCA DMPNO	/CHANGE DEFAULT VALUE
	TAD TRACE
	DCA LASTC	/SAVE THE TRACE SWITCH
	TAD FIRSTV
	DCA PT1		/START AT THE BEGINNING
	TAD DMPNO
	DCA TRACE	/INITIALIZE THE COUNTER
	JMP DUMPT+4	/(THESE THREE COULD GO)
/////
DUMPT,	TAD DMPNO	/SET COUNTER AND TURN ON TRACE
	DCA TRACE
	TAD CCR
	PRINTC		/RESETS THE DF
	TAD GINC
	CIA
	DCA XCT		/INITIALIZE LOOP
	TAD DCAT1
	DCA DCAT2

	CDF V
	DCA I LASTV	/CLEAR THE LAST NAME
	TAD I PT1	/MOVE VAR. TO THIS FIELD
	ISZ PT1		/NO HARM IF IT SKIPS
	ISZ .+1
DCAT2,	DCA T1		/T2, T3, ETC.
	ISZ XCT		/RESETS THE SWITCH TOO!
	JMP .-5

	TAD T2		/LAST ONE?
	SNA
	JMP DUMPX	/YES
	CDF T
	DCA I C200	/SAVE THE NAME
	TAD P177
	DCA AXOUT	/SET 'TEXTP'

	GETC		/RESETS THE DF
	GETC
	GETC		/PRINT 'XX('
	JMS I (FGO6	/PRINT SUBSCRIPT
	GETC		/PRINT  ')'
	PRINTN		/PRINT VALUE

	CDF V
	ISZ TRACE	/FINISHED THIS LINE?
	TAD I PT1	/NO, LAST ENTRY?
	SNA CLA		/NEITHER
	JMP DUMPT	/START A NEW LINE
	TAD C240
	JMP DUMPT+3	/SEPARATE THE VARIABLES
/////
DMPNO,	-3		/DEFAULT = 3

DUMPX,	TAD LASTC	/RESET THE TRACE SWITCH
	DCA TRACE
	POPJ		/RESET DF AND END THE LINE
/////
/REMOVE A LINE OF TEXT AND RECOVER THE SPACE - 'DELETE'

XDELETE,0		/ENTRY POINT IS PACKING LIMIT
	TAD LINENO	/TRYING TO DELETE LINE 0?
	SNA CLA
	JMP START	/JUST IGNORE SUCH COMMANDS
	FINDLN		/SETS THISLN, LASTLN, AND TEXTP
	JMP I XDELETE	/ALREADY GONE
/////
	I0F		/PROTECT TEXT POINTERS
	GETC		/MEASURE LENGTH
	TESTCR
	JMP .-2
	TAD AXOUT	/GET LAST ADDRESS
	CMA
	TAD THISLN	/SUBTRACT FROM FIRST
DCAT1,	DCA T1
	TAD T1		/CORRECT BUFFER POINTER
	TAD BUFR
	DCA BUFR

	CDF T
	TAD I THISLN	/DISCONNECT
	DCA I LASTLN
	TAD HEADER	/START AT THE BEGINNING
XLOOP,	DCA LASTLN	/CORRECT LINE POINTERS
	TAD I LASTLN	/GET THE NEXT ADDR
	DCA GTEM	/SAVE
	TAD GTEM	/COMPARE LINE POSITIONS
	CLL CIA
	TAD THISLN
	SNL CLA		/SKIP IF THISLN > X
	TAD T1		/CHANGE (X) TO ACCOUNT
	TAD GTEM	/FOR GARBAGE COLLECTION
	DCA I LASTLN
	TAD GTEM	/GET NEXT
	SZA		/TEST FOR END
	JMP XLOOP
/////
	TAD AXIN	/COMPUTE COUNT
	CIA
	TAD AXOUT
	DCA XCT
	CMA
	TAD THISLN	/RESET AXIN
	DCA AXIN
	TAD I AXOUT
	DCA I AXIN	/SHIFT REMAINDER OF BUFFER DOWN
	ISZ XCT
	JMP .-3
	JMP XDELETE+4	/RESET 'LASTLN', 'THISLN' AND D.F.

	PAGE
/TTY INTERUPT I/O HANDLERS:
/OUTPUT BUFFER HAS BEEN MOVED AND THE INPUT MODIFIED
/TO INCREMENT A RANDOM NO. OR CALL A DISPLAY ROUTINE

KEYCK,	XI33+1		/PATCHED BY DISPLAY ROUTINE

XOUTN,	TAD XI33
	TLS		/TYPE FIRST CHARACTER
	DCA TELSW	/SET IN-PROGRESS FLAG
	CDF P
	JMP I XOUTL
P7757,	7757		/LOC = PAGE+6

XI33,	(REKOVR		/VIA (INDEV)
	ISZ I XCT	/BUMP RANDOM NUMBER
	TAD INBUF	/ANY INPUT?
	SNA		/YES AND NON-ZERO RNDM NO.
	JMP I KEYCK	/NO OR ZERO RANDOM NUMBER
	DCA XI33+1	/SAVE AND KILL 'ISZ'
	DCA INBUF	/CLEAR INPUT BUFFER
	TAD XI33+1	/PLACE CHARACTER IN AC
	JMP I XI33

MCP,	"C-"P		/OINK, OINK

XOUTL,	0		/VIA (OUTDEV)
	DCA XI33	/SAVE CURRENT CHARACTER
	CDF L
	I0N		/BE SURE INTERRUPT IS ON
	TAD I OPTRI	/ANY ROOM?
	SZA CLA		/A CHARACTER IS NON-ZERO
	JMP .-3		/NO = WAIT
	CIF P		/INHIBIT POINTER CHANGES
	TAD TELSW	/IN PROGRESS?
	SNA CLA
	JMP XOUTN	/NO
	TAD XI33	/PUT DATA IN EXTRA
	DCA I OPTRI	/BUFFER SPACE
	TAD OPTRI	/ADVANCE POINTER
	IAC		/MODULO 20
	AND P7757	/(CIRCULAR STORE)
	DCA OPTRI	/NEW VALUE
	JMP XOUTN+3	/RE-ENABLE INTERRUPTS

MINT,	CDI		/CTRL/C EXIT
	JMP I P7600	/MONITOR = 07600

	SM8=6254
	DCMA=6601
	PCLF=6662
	RCTF=6677
/INTERRUPT PROCESSOR: CHANGES FOR ^C AND ^F OR ^P

INTRPT,	DCA SAVAC	/SAVE WORKING REGISTERS
	RAR
	DCA SAVLK

TINT,	TSF		/CHECK OUTPUT FIRST WHILE DF=0
	JMP KINT
	TCF
	DCA TELSW	/TURN OFF THE IN-PROGRESS FLAG
	TAD I OPTRO	/I/O BUFFER IS IN FIELD 0 NOW
	SNA
	JMP KINT	/DONE
	TLS		/TYPE NEXT CHARACTER
	DCA TELSW	/CLEAR AC & TURN ON THE FLAG
	DCA I OPTRO	/ZERO OUT THE DATA JUST USED
	TAD OPTRO	/GET POINTER AND
	IAC		/ADVANCE MODULO 20
CTRLF,	AND P7757	/(CIRCULAR BUFFER)
	DCA OPTRO	/NEW POINTER

KINT,	KSF		/NOW CHECK THE KEYBOARD
	JMP UINT
	KRS		/READ BUFFER
	AND P177	/IGNORE PARITY
	TAD (-3
	SNA		/TEST FOR CTRL C
	JMP MINT
	TAD (-3		/'TAD MCP' -> ^P
	SNA CLA		/TEST FOR CTRL F
	JMP M20+2
	TAD INBUF	/CHECK BUFFER
	CLL CIA
	KRB		/RE-READ CHAR
	AND P177
	SNA		/LEADER/TRAILER?
	JMP UINT
	TAD C200
	SNL		/OVERFLOW?
	ERROR2		/'NOP' IF YOU DON'T CARE
	DCA INBUF

UINT,	NOP	/RESERVED FOR PLOTTER OVERLAY
	NOP	/	"
	NOP	/	"
	6302	/NOW CLEAR SOME ANNOYING FLAGS
	6312
	6322
	6332
	6342
	6076
	6402
	JMP XINT /CDI 0		/USE THS PATCH FOR ADDITIONAL
	NOP	 /JMP I .+1	/INTERRUPT SERVICE 
	NOP	 /DDRESS	/IN ANY FIELD
XINT,	NOP	/16KXII.PA OVERLAYS HERE
	NOP	/	"
	RCTF
	DCMA
	PCLF	/LPT8I.PA OVERLAYS HERE
	PCF
	TAD SAVLK
	CLL RAL
	TAD SAVAC
	CDI
	JMP PRNTC	/RETURN FROM THE INTERRUPT

OPTRI,	TBUF		/OUTPUT BUFFER POINTERS
OPTRO,	TBUF		/'I'= 'IN',  'O'= 'OUT'

/PRINT THE ERROR MESSAGE

	DCA TELSW	/CLEAR THE BUSY FLAG
M20,	SMA SZA SNL CLA	/SKIP ERROR CODE
	TAD I TABCNT	/AC= -1 OR -41
	DCA LINENO
	DCA INBUF
	TAD OPTRI	/RESET POINTER
	DCA OPTRO
	CDI L
	JMS REKOVR	/CLEAR OUTPUT BUFFER
/////
	TAD ("?-"_	/RETURN VIA 'EOF'
	PRINTC		/PRINT A "?"
	PRNTLN		/FOLLOWED BY ERROR CODE
	ISZ PC
	CDF T
	TAD I PC	/GET PROGRAM STEP
	SNA
	JMP .+6		/DIRECT COMMAND ERROR
	DCA LINENO
	TAD C100	/ATSIGN
	PRINTC		/RESETS DF
	PRINTC		/SPACE
	PRNTLN		/LINE NO.
	TAD CCR
	PRINTC
BATXIT,	JMP START	/OR RETURN TO BATCH
/////

	PAGE		/END OF COMMAND PROCESSOR

/IN THE 8K VERSION THE VARIABLES COME NEXT AND EXTEND TO
/THE BEGINNING OF THE FUNCTIONS. IN THE 12K VERSION THIS
/SPACE IS AVAILABLE FOR USER ADDITIONS - HELP FOCAL GROW!
