	.TITLE FOCAL
/
/FOCAL FOR THE PDP-9 ADVANCED SOFTWARE SYSTEM
/
/COPYRIGHT 1969
/DIGITAL EQUIPMENT CORP.
/MAYNARD, MASS.
/
/DAVE LENEY
/2-7-69
/
/FOCAL IS A REGISTERED TRADEMARK OF
/DIGITAL EQUIPMENT CORPORATION
/
/DEFINE MULTI=N IF MULTI-USER VERSION WHERE N=2 OR 4 USERS
/	BGD=0 IF FOR BACKGROUND OF B/F SYSTEM
/	FGD=0 IF FOR FOREGROUND OF B/F SYSTEM
	.IFZER MULTI-4
USR4=0
	.ENDC
	.IFDEF BGD
BF=0
	.ENDC
	.IFDEF FGD
BF=0
	.ENDC
/
/GLOBAL CALLS TO F4 ARITHMETIC PACKAGE
/
	.GLOBL .AA		/EXPONENT
	.GLOBL .AB		/HIGH ORDER MANTISSA
	.GLOBL .AC		/LOW ORDER MANTISSA
	.GLOBL .AO		/LOAD (3 WORDS)
	.GLOBL .AP		/STORE (3 WORDS)
	.GLOBL .AQ		/ADD
	.GLOBL .AR		/SUBTRACT
	.GLOBL .AS		/MULTIPLY
	.GLOBL .AT		/DIVIDE
	.GLOBL .AX		/FIX
	.GLOBL .BA		/NEGATE
	.GLOBL .AW		/FLOAT
	.GLOBL .CD		/NORMALIZE
	.GLOBL .BH		/A**B-POWER
	.GLOBL DSIN		/SINE
	.GLOBL DCOS		/COSINE
	.GLOBL DATAN		/ARCTANGMENT
	.GLOBL DLOG		/LOGARITHM
	.GLOBL DEXP		/EXPONENTIAL
	.GLOBL DSQRT		/SQUARE ROOT
	.GLOBL .ER		/.OTS ERROR (?36)
/
/.GLOBL REFERENCES FOR EXTERNAL FUNCTIONS
/
	.GLOBL	.NEWF		/FUNCTION TABLE
	.GLOBL	XPUSHJ		/PUSH JUMP
	.GLOBL	XPUSHA		/PUSH AC
	.GLOBL	PD2		/PUSH FLOATING
	.GLOBL	PD3		/POP FLOATING
	.GLOBL	UTRA		/UNPACK
	.GLOBL	XSPNOR		/IGNORE SPACES 
	.GLOBL	FUNERR		/ERROR IN EXTERNAL FUNCTION
	.GLOBL	EFUN3		/FUNCTION RETURN
	.GLOBL	FINT		/FLOATING INTERPRETER
	.GLOBL	CHAR		/CHRACTER STORAGE
	.GLOBL	EVAL		/EVALUATION ROUTINE
	.GLOBL	LASTV		/END OF TEXT/VARIABLES
	.GLOBL	BOTTOM		/START OF PUSH-DOWN LIST
	.GLOBL	LINENO		/CURRENT LINE
	.GLOBL	FLARG		/FLOATING ARGUMENT
	.GLOBL	BUFSTX		/POINTER TO 3 WD UNPACK AREA
	.GLOBL	XGETLN		/FETCH LINE NUMBER
	.GLOBL	XPOPJ		/POP JUMP
	.GLOBL	FETVAR		/GET 3,6,OR 9 .SIXBT CHARS
/
FPOW=000000  /PSEUDO-FLOATING POINT INSTRUCTIONS.
FADD=100000
FSUB=200000
FMPY=300000
FMUL=300000
FDIV=400000
FGET=500000
FPUT=600000
FNOR=700000
FEXT=0
FXIT=0
WORDS=3
DIGITS=11
.SCOM=100
XX=0
	.EJECT
	.IFUND	MULTI
	.IODEV	-3,-2,3,5
TTI=776
TTO=775
BKI=3
BKO=5
	.ENDC
	.IFDEF	MULTI
	.IODEV	1,2,3,4
	.IFDEF	USR4
	.IODEV	5,6,7,10
	.ENDC
TTI=0
TTO=0
BKI=0
BKO=0
TTI1=1
TTO1=1
BKI1=2
BKO1=2
TTI2=3
TTO2=3
BKI2=4
BKO2=4
	.IFDEF	USR4
TTI3=5
TTO3=5
BKI3=6
BKO3=6
TTI4=7
TTO4=7
BKI4=10
BKO4=10
	.ENDC
COMEIN=0
COMOUT=0
IMBUFF=0
INBUF=0
OUTBUF=0
	.ENDC
/AUTO-INDEX REGISTERS
AXIN=10		/STORAGE INDEX
XRT=11		/EXTRA XR
XRT2=12		/EXTRA XR
PDLXR=13		/PUSHDOWN LIST INDEX REGISTER.
FLTXR=14		/IOBUF-1 XR14 FOR FLOATING POINT
X15=15		/FOR COMMON RESTORE
X16=16		/FOR COMMON RESTORE
/
/IN THE MULTI USER SYSTEM 15 AND 16 ARE ALSO USED BY THE SWAP ROUTINES
/
	.EJECT
/
/THE FOLLOWING BLOCK IS THE ENTIRE IMPURE
/	AREA FOR EACH FOCAL JOB
/
	.IFDEF	MULTI
SWPSZE	SWPBGN-SWPEND	/BLOCK SIZE
SWPBGN=.
/
RESTAR	XSBEGN		/RESTART ADDRESS FOR THIS JOB
CTLP	XX		/ADDRESS OF ^P SWITCH FOR THIS USER
BWAIT	XX
/
FLAC	0		/.AA SAVE
	0		/.AB SAVE
	0		/.AC SAVE
/
FRSTSV	0		/FRST SAVE
LIST31	0		/LIST3+1 SAVE
/
AUTOXR	0		/X10 SAVE
	0		/X11 SAVE
	0		/X12 SAVE
	0		/X13 SAVE
	0		/X14 SAVE
/
IMBFSV	XX		/BUFFER HEADER POINTERS
IMBF2S	XX
INBFSV	XX
OTBFSV	XX
.FLINP	XX		/SUBROUTINE ENTRY POINTERS
.XI33	XX
.XOUTL	XX
.INPUT	XX
.DECON	XX
.DECNV	XX
.IMAGR	XX
.IMAGW	XX
/
	XX		/RCAL01
	XX		/RCAL03
	XX		/WCAL01
	XX		/WCAL03
	XX		/WCAL04
	XX		/LBIN01
	XX		/LBIN1A
	XX		/LBIN02
	XX		/LBIN03
	XX		/LBOUT1
	XX		/LBOUT2
	XX		/LBOUT3
	XX		/LBOUT4
	XX		/FILE01
	XX		/FILE02
	XX		/FILE03
	.ENDC
/
/REENTRANT VARIABLES
/
BOTTOM	XX		/TOP OF PUSH-DOWN LIST
BUFSTX	XX		/3 REG AREA BELOW TEXT AND VARIABLES
			/USED TO CONSTRUCT VARIABLES AND FILE
			/NAMES(FILE01 AND FILE02 CONTAIN SAME ADDR)
ENDT	XX		/START OF TEXT
STARTV	XX		/LAST LOCATION OF TEXT
BUFR	XX		/NEXT LOCATION IN BUFFER (VARIABLES)
LASTCV=STARTV		/ADDRESS OF LAST COMMON VARIABLE
FRSTCV	XX		/ADDRESS OF FIRST COMMON VARIABLE
LASTV	XX		/ADDRESS OF LAST VARIABLE
COMBUF	COMEIN		/COMMAND BUFFER START
COMBOT	COMOUT		/AND END
IMBUFP	IMBUFF+2		/BUFFER DATA POINTERS
INBUFP	INBUF+2
OTBUFP	OUTBUF+2
TEXTP=.		/TEXT POINTERS
AXOUT	XX	/OUTPUT INDEX
XCTX	0	/UNPACK SWITCH
GTEM	0	/UNPACK STORAGE
MODBUF	0	/POINTER FOR MODIFY
ENDCR	215	/LAST CHAR FOR GETC
GETVCT	0	/VARIABLE COUNT
SAVEOT	0	/OUTPUT CHAR
PUTCNT	-1	/OUTPUT COUNTER FOR HEADER PAIR
TEMPK	0	/TEMP FOR PACK
INSUB	0	/0= GETC; #0 = READC
TTIN	TTI
TTOUT	TTO
BLKIN	BKI
BLKOUT	BKO
LIBRSW	0	/IN LIBRARY MODE
EX1	0
AC1H	0
AC1L	0
OVER1	0
OVER2	0
OTEMP=OVER1
LTEMP=AC1L
HTEMP=AC1H
FISW	10
GETP	0		/ASCII STRING POINTER
GETCX	0		/CHAR COUNTER (2'S COMP)
GET1X	0		/TEMP
GET2	0		/TEMP
GET3	0		/TEMP
PUTP	0		/ASCII STRING POINTER
PUTC	0		/CHAR COUNTER
PUT6	0		/TEMP
SORTCN	0	/NUMBER IN TABLE FROM SORTC
LASTOP	0	/LAST OPERATION FOR EVAL
EFOP=.		/FUNCTION CODE.
ATSW	0	/ASK-TYPE CODE.
CNTR	-20	/DELETE AND ERROR COUNTER(USED BY F.P. ALSO)
DECP	4	/NUMBER OF DECIMAL POINTS
ADD	XX	/CHAR. BUF. IN.	(DEBUG AIDS.SEE BELOW.)
XCTIN	XX	/PACK SWITCH
NAGSW	0001	/NOT ALL AND/OR GROUP SWITCH (4000=ONE;1=ALL;0=GROUP)
CHAR	215	/THE MOST IMPORTANT REGISTER
LINENO	0000	/LINE NUMBER READ BY GETLN
PC	FRST+1	/PROGRAM COUNTER
THISLN	0	/LINE POINTER FROM 'FINDLN'
THISOP	0	/CURRENT 'EVAL' OPERATION
LASTLN	0	/BACK POINTER FROM 'FINDLN'
DEBGSW	1	/DEBUG SWITCH ; NON-ZERO FOR LITERAL.
DMPSW	1	/=0 FOR TRACE ON.
PACKST	0	/RUBOUT PROTECTION
PT1	0	/VARIABLE POINTER
T1	0	/TEMPORARY REGISTER - MAIN
T2	0	/TEMP REGISTER - FOR NEW INST. ROUTINES.
SACH	0	/SEARCH CHAR STORAGE
FLARG	0	/DATA TEMPORARY STORAGE
	0
	0
FLARG2	0
	0
	0
	.IFDEF MULTI
SWPEND=.
	.ENDC
/
/NON-REENTRANT VARIABLES
/
BOX	0			/FOR DIGIT PRINT
ER2T	0			/ERROR TEMP
ERR2CT	0			/ERROR COUNT
OP	.
	XX			/VARIABLE NAME (.SIXBT)
	.SIXBT	/()=/
RANPT	0			/PUSEDO RANDOM POINTER
FRST	0			/TEXT POINTER
	0			/DUMMY LINE NUMBER
	.SIXBT	/C FOCAL V3A/<77><15>
SIGN2	0			/TEMP SIGN
SCOUNT	0
PLCE=.
FCOUNT	0
TEMPO	0
REMAIN	0
DIGIT	0			/DIGIT STORAGE (CURRENT)
ISIGN	0			/0=MINUS,-1=PLUS
DNUMBR	0			/NUMBER OF DIGITS
BEXP	0
SEXP	0			/DECIMAL EXPONENT
MODBF1=.
JUMP	0
MODBF2=.
JUMP2	0
ADDR	0
X=.			/TEMP FLOATING POINT
FUNAME	0			/FUNCTION NAME
FUNCTR	0			/FUNCTION COUNTER
FUNPTR	0			/FUNCTION POINTER
ARRAYN	0		/ARRAY NAME
/
/CONSTANTS
/
P13	13
P17	17
C277	277
P3	3
P2	2
C100	100
C77	77
C260	260
M100	-100
C200	200
P177	177
GINC	WORDS+2
CFRS	FRST			/DUMMY LINE ADDRESS
FLARGP	FLARG			/DATA ADDRESS
FILEXT	.SIXBT	/FCL/
CFRSX	FLTZER			/FLOATING 0 ADDRESS
C306	306
C314	314
M137	-137
P337	337
C1=.
FLTONE	000001			/FLOATING 1.0
	200000	
FLTZER	000000			/FLOATING 0.0
	000000
	000000
P40	40
C140	140
M140	-140
FOCAL9	4002
	0
	.ASCII	/FOCAL V3A/<15>
CEX1	EX1-1
RND2	DIGITS+1
BUFST	BUFFER-1
C144	144
M144	-144
TEN	000004			/FLOATING 10.0
	240000
	000000
P43	43
INDRCT	20000
MASK7	17777
C7	7
TABLE	JMP*	ITABLE
OPTABL	OPTABS
	.EJECT
/
/SUBROUTINE CONVENTIONS
/
/1)USE AC OR 'CHAR' ON ENTRY
/	SORTJ
/	PRINTC
/2)USE 'CHAR' ONLY ON ENTRY
/	PACKC
/	SORTC
/	SPNOR
/	TESTN
/	TESTC
/3)RETURN WITH 'CHAR' IN AC
/	READC
/	GETC
/	PACKC
/	SPNOR
/	SORTC
/	PRINTC
/	TESTC
/	INPUT
/4)USE AC ONLY ON ENTRY
/	DECON
/
	.EJECT
/NEW INSTRUCTIONS:
	.DEFIN PUSHJ,A
	JMS	XPUSHJ	/RECURSIVE SUBROUTINE CALL
		A
	.ENDM
	.DEFIN POPA
	LAC*	PDLXR		/RESTORE AC
	.ENDM
	.DEFIN POPJ
	JMP	XPOPJ		/SUBROUTINE RETURN
	.ENDM
	.DEFIN PUSHA
	JMS	XPUSHA	/SAVE AC
	.ENDM
	.DEFIN PUSHF,A
	JMS	PD2	/SAVE GROUP OF DATA
		A
	.ENDM
	.DEFIN POPF,A
	JMS	PD3	/RESTORE GROUP
		A
	.ENDM
	.DEFIN GETC
	JMS	UTRA	/UNPACK A CHARACTER
	.ENDM
	.DEFIN PACKC
	JMS	PACBUF	/PACK A CHARACTER
	.ENDM
	.DEFIN SORTJ,A,B
	JMS	SORTB	/SORT AND BRANCH ON AC OR CHAR
		A-1
		B-A
	.ENDM
	.DEFIN	SORTJX,A		/SORT + BRANCH ON COMMAND
	JMS	XSORTX
		A-1
	.ENDM
	.DEFIN SORTC,A
	JMS	XSORTC	/SORT CHAR
		A-1
	.ENDM
	.DEFIN PRINTC
	JMS	XOUTL		/PRINT AC OR CHAR
	.ENDM
	.DEFIN READC
	JMS	XI33	/READ KSR-33/35 INTO CHAR
	.ENDM
	.DEFIN PRNTLN
	JMS	XPRNT		/PRINT C(LINENO)
	.ENDM
	.DEFIN GETLN
	JMS	XGETLN		/UNPACK AND FORM A LINENUMBER
	.ENDM
	.DEFIN FINDLN
	JMS	XFIND		/SEARCH FOR A GIVEN LINE
	.ENDM
	.DEFIN ENDLN
	JMS	XENDLN		/INSERT LINE POINTERS
	.ENDM
	.DEFIN RTL6
	JMS	XRTL6		/ROTATE LEFT SIX
	.ENDM
	.DEFIN SPNOR
	JMS	XSPNOR		/IGNORE SPACES
	.ENDM
	.DEFIN TESTN
	JMS	XTESTN		/PERIOD; OTHER; NUMBER
	.ENDM
	.DEFIN TSTLPR
	JMS	LPRTST		/SKIP IF 5<SORTCN<= 11 (I.E. AN L-PAR)
	.ENDM
	.DEFIN TSTGRP
	JMS	GRPTST		/SKIP IF G(AC) = G(LINENO)
	.ENDM
	.DEFIN TESTC
	JMS	XTESTC		/TERM; NUMBER; FUNCTION; LETTER
	.ENDM
	.DEFIN ERROR,A
	.DEC
	JMP	ERR2-A		/ERROR MSG
	.ENDM
	.DEFIN GETSGN
	LAC*	.AB
	.ENDM
	.DEFIN RETURN
	JMP	EFUN3
	.ENDM
	.IFDEF BF
	.DEFIN .RLXIT,A
	CAL	A
	20
	.ENDM
	.ENDC
	.IFUND BF
	.DEFIN .RLXIT,A
	DBR
	JMP*	A
	.ENDM
	.ENDC
	.EJECT
/
/FOCAL COMMAND TABLES
/
COMLST	-22
	.SIXBT	/IF@/
	JMP	IF
	.SIXBT	/DO@/
	JMP	DO
	.SIXBT	/GO@/
	JMP	GOTO
	.SIXBT	/GOTO@/
	JMP	GOTO
	.SIXBT	/SET@/
	JMP	SET
	.SIXBT	/FOR@/
	JMP	FOR
	.SIXBT	/COMMENT@/
	JMP	COMMEN
	.SIXBT	/CONTINUE@/
	JMP	COMMEN
	.SIXBT	/ERASE@/
	JMP	ERASE
	.SIXBT	/WRITE@/
	JMP	WRITE
	.SIXBT	/MODIFY@/
	JMP	MODIFY
	.SIXBT	/QUIT@/
	JMP	START
	.SIXBT	/RETURN@/
	JMP	RETURX
	.SIXBT	/*@/
	JMP	HSPX
	.SIXBT	/ASK@/
	JMP	ASK
	.SIXBT	/TYPE@/
	JMP	TYPE
	.SIXBT	/LIBRARY@/
	JMP	LIBRAR
	.SIXBT	/COMMON@/
	JMP	COMMON
/
ALLCM1	-1
	.SIXBT	/ALL@/
	JMP	GEXIT
/
ALLCM2	-2
	.SIXBT	/ALL@/
	JMP	XSBEGN
	.SIXBT	/COMMON@/
	JMP	STARTQ
/
LIBCMD	-5
	.SIXBT	/OUT@/
	JMP	LBOUT
	.SIXBT	/IN@/
	JMP	LBIN
	.SIXBT	/CLOSE@/
	JMP	LBCLOS
	.SIXBT	/KILL@/
	JMP	LBKILL
	.SIXBT	/WRITE@/
	JMP	LBWRIT
/
/TABLES FOR FOCAL FUNCTIONS (INTERNAL)
/
FNTABF	FNTABE-.-1/2\777777+1
	.SIXBT	/SIN/
	JMP	FSIN
	.SIXBT	/COS/
	JMP	FCOS
	.SIXBT	/ATN/
	JMP	ARTN
	.SIXBT	/EXP/
	JMP	FEXP
	.SIXBT	/LOG/
	JMP	FLOG
	.SIXBT	/SQT/
	JMP	XSQRT
	.SIXBT	/ABS/
	JMP	XABS
	.SIXBT	/SGN/
	JMP	XSGN
	.SIXBT	/ITR/
	JMP	XINT
	.SIXBT	/RAN/
	JMP	XRAN
FNTABE=.
/
/OPERATION TABLES FOR FLOATING POINT INTERPRETER
/
OPTABS	FGET*	PT1
	FADD*	PT1
	FSUB*	PT1
	FDIV*	PT1
	FMUL*	PT1
	FPOW*	PT1
/
ITABLE	EXITF			/EXIT OR POWER
	FLAD			/ADD
	FLSU			/SUBTRACT
	FLMY			/MULTIPLY
	FLDV			/DIVIDE
	FLGT			/GET FLOATING POINT
	FLPT			/PUT FLOATING POINT
	NORF			/NORMALIZE
/
/TABLE OF TERMINATORS (FOR EVAL AND GETVAR)
/
C305	305			/E - FOR INPUT NUMBERS
PER	256			/. - FOR INPUT NUMBERS
TERMS=.
C240	240			/SPACE 0
	253			/+     1
C255=.
SMIN	255			/-     2
	257			/1      3
C252	252			/*     4
	336			/^     5
C250	250			/(     6 L - PARENS
	333			/[     7
	274			/<     10
C251	251			/)     11 R - PARENS
	335			/]     12
	276			/>     13
C254	254			/,     14
C273	273			/;     15
	215			/CR    16
C275	275			/=     17
/
/CONTROL TABLE FOR ASK/TYPE OPERATIONS
/
ATLIST	JMP	TINTR
	JMP	TQUOT
	JMP	TCRLF
	JMP	TCRLF2
	JMP	TDUMP
	JMP	TASK4
	JMP	TASK4
	JMP	PROCES
	JMP	PC1
/
ALIST	245			/% - FLOATING FORMAT
C242	242			/" - LITERAL
	241			/! - CR AND LF
	243			/# - CR ONLY
	244			/$ - SYMBOL DUMP
GLIST	240			/SPACE - END NAMES
TLIST	254			/, - END EXPRESSIONS
TLISTX	273			/; - END COMMANDS
	215			/C.R. - END STRINGS
/
/DISPATCH TABLES FOR IF AND COMMON STATEMENTS
/
ILIST	JMP	IF1		/,
	JMP	PROCES		/;
	JMP	PC1		/CR
/
FLIST2	JMP	FLIMIT		/,
	JMP	FINFIN		/;
	ERROR	11		/CR
/
FLIST1	JMP	FINCR		/,
	JMP	PROCES		/;
	JMP	PC1		/CR
/
CLISTX	JMP	COMMON-1		/,
	JMP	PROCES		/;
	JMP	PC1		/CR
/
/CONTROL TABLE FOR MODIFY OPERATION
/
LIST6	225			/^U - KILL LINE
C375	375			/ALTMODE - NEXT OCCURANCE OF SEARCH CHAR.
	207			/BELL - NEW SEARCH CHAR
C212	212			/L.F. - END LINE SAVING REST
C377	377			/RUBOUT - DELETE LAST CHAR
LIST3=.
CCR=.
C215	215			/C.R. - END LINE DELETING REST
	000			/SEARCH CHAR
/
SRNLST	JMP	SBAR		/^U
	JMP	SCHAR		/F.F.
	JMP	SCONT		/BELL
	JMP	SCONTX		/L.F.
	JMP	SCRUB		/RUBOUT
LISTGO	JMP	SRETN		/CR
	JMP	SFOUND		/SEARCH CHAR
/
	.EJECT
	.IFDEF	MULTI
/
/THIS CODE CONTROLS THE MULTI-USER PROCESSING
/	OF TWO OR FOUR CONCURENT FOCAL USERS.
/
BUFFER=.
MSTART	LAC*	(.SCOM+2
	DAC	T1
	JMS	TWOS
	TAD*	(.SCOM+3	/GET SIZE
	CLL!RAR		/DIVIDE BY TWO OR FOUR
	.IFDEF	USR4
	CLL!RAR
	.ENDC
	DAC	ENDT		/AMT FOR EACH
	LAC	T1		/GO INITIALIZE REGS
	DAC	BUF1
	DAC	FILA1
	DAC	FILB1
	DAC	FILC1
	TAD	(3
	DAC	ENDT1
	DAC	ENDT1+1
	DAC	ENDT1+3
	DAC	ENDT1+4
	LAW	-1
	TAD	T1
	TAD	ENDT
	DAC	BOT1
	TAD	C1
	DAC	T1
	DAC	BUF2
	DAC	FILA2
	DAC	FILB2
	DAC	FILC2
	TAD	(3
	DAC	ENDT2
	DAC	ENDT2+1
	DAC	ENDT2+3
	DAC	ENDT2+4
	LAW	-1
	TAD	T1
	TAD	ENDT
	DAC	BOT2
	.IFDEF	USR4
	TAD	C1
	DAC	T1
	DAC	BUF3
	DAC	FILA3
	DAC	FILB3
	DAC	FILC3
	TAD	(3
	DAC	ENDT3
	DAC	ENDT3+1
	DAC	ENDT3+3
	DAC	ENDT3+4
	LAW	-1
	TAD	T1
	TAD	ENDT
	DAC	BOT3
	TAD	C1
	DAC	T1
	DAC	BUF4
	DAC	FILA4
	DAC	FILB4
	DAC	FILC4
	TAD	(3
	DAC	ENDT4
	DAC	ENDT4+1
	DAC	ENDT4+3
	DAC	ENDT4+4
	LAW	-1
	TAD	T1
	TAD	ENDT
	DAC	BOT4
	.ENDC
	.INIT	TTO1,1,CP1+400000
	.INIT	TTO2,1,CP2+400000
	.IFDEF	USR4
	.INIT	TTO3,1,CP3+400000
	.INIT	TTO4,1,CP4+400000
	.ENDC
	.WRITE	TTO1,2,FOCAL9,40
	.WRITE	TTO2,2,FOCAL9,40
	.IFDEF	USR4
	.WRITE	TTO3,2,FOCAL9,40
	.WRITE	TTO4,2,FOCAL9,40
	.ENDC
	JMP	WAIT1
CTLP1	0
CTLP2	0
	.IFDEF	USR4
CTLP3	0
CTLP4	0
	.ENDC
CP1	0
	ISZ CTLP1
	.RLXIT CP1
CP2	0
	ISZ CTLP2
	.RLXIT CP2
	.IFDEF	USR4
CP3	0
	ISZ CTLP3
	.RLXIT CP3
CP4	0
	ISZ CTLP4
	.RLXIT CP4
	.ENDC
	.EJECT
/MAIN PROCESSING LOOP
WAIT1	.WAITR	TTI1,WAIT2
WAITB1	.WAITR	TTI1,WAIT2
	LAC	(AREA1-1
	JMS	RUN
WAIT2	.WAITR	TTI2,WAIT3
WAITB2	.WAITR	TTI2,WAIT3
	LAC	(AREA2-1
	JMS	RUN
	.IFUND	USR4
WAIT3=.
	.ENDC
	.IFDEF	USR4
WAIT3	.WAITR	TTI3,WAIT4
WAITB3	.WAITR	TTI3,WAIT4
	LAC	(AREA3-1
	JMS	RUN
WAIT4	.WAITR	TTI4,SCANQ
WAITB4	.WAITR	TTI4,SCANQ
	LAC	(AREA4-1
	JMS	RUN
	.ENDC
	.IFDEF FGD
SCANQ	CAL		/NO - GIVE BGD SOME TIME
	14
	IDLE+700000
	-12
	CAL+1000		/.IDLEC ROUTINE WILL BYPASS THIS ON
	17			/TIMER OVERFLOW
	CAL+1000
	14
	IDLE+700000
	0
	JMP	WAIT1		/GO SEE IF ANYTHING DONE NOW
	.ENDC
/
	.IFDEF	BGD
SCANQ=WAIT1
	.ENDC
	.EJECT
/RUN INITIALIZATION
RUN	0
	DAC	NEWUSR		/CHECK FOR SAME USER
	SAD	CURUSR		/?
	JMP	RESTAX		/YES - NO SWAP
	LAC	(MVSZE		/SET TO SAVE INLINE
	DAC*	(16		/TEMPORARIES
	LAC	(BWAIT
	DAC*	(17
	LAC	MVSZE
	DAC	RUNCT
	LAC*	16		/SAVE REGS LOOP
	DAC	RUNTP
	LAC*	RUNTP
	DAC*	17
	ISZ	RUNCT
	JMP	.-5
	LAC	CURUSR		/SWAP USERS INITIALIZATION
	DAC*	(16
	LAC	NEWUSR
	DAC*	(17
	DAC	CURUSR
	LAC	(SWPBGN
	DAC	RUNTP
	LAC	SWPSZE
	DAC	RUNCT
	LAC*	RUNTP		/NOW DO SWAP
	DAC*	16
	LAC*	17
	DAC*	RUNTP
	ISZ	RUNTP
	ISZ	RUNCT
	JMP	.-6
	LAC	(MVSZE		/SET TO RESTORE INLINE
	DAC*	(16		/TEMPORARIES
	LAC	(BWAIT
	DAC*	(17
	LAC	MVSZE
	DAC	RUNCT
	LAC*	16		/RESTOR REGS LOOP
	DAC	RUNTP
	LAC*	17
	DAC*	RUNTP
	ISZ	RUNCT
	JMP	.-5
RESTAX	CAL
	14
	TIME+700000
	-12
	DZM DELAY
	LAC* CTLP
	SZA
	JMP RECOVR
	JMP*	RESTAR		/GO START UP USER
/I/O BUSY OR OUT OF TIME RETURNS HERE
IOBUSY	0
	LAC	.-1		/GET RETURN PC
	DAC	RESTAR
	.IFDEF BF
	CAL+1000		/CLEAR OUT CALL FOR TIME
	14
	TIME+700000
	0
	.ENDC
	JMP*	RUN
/
RUNTP	0
RUNCT	0
DELAY	0
/
TIME	0			/SET DELAY ON OVERFLOW
	ISZ	DELAY
	.RLXIT TIME
/
IDLE	0			/FORCE RETURN TO FGD
	.RLXIT IDLE
/
	.EJECT
/
/COMMUNICATION BLOCK
/
CURUSR	SWPBGN-1		/CURRENT USER AREA-1
NEWUSR	0			/NEW USER AREA-1
/
/SPECIAL POINTERS FOR SAVE/RESTORE
/
MVSZE	.+1-MVEND
FLAC14	XX			/.AA
FLAC15	XX			/.AB
FLAC16	XX			/.AC
	FRST
	LIST3+1
	10
	11
	12
	13
	14
	IMBF01
	IMBF02
	INBF01
	OTBF01
	FLINTP
	XI33
	XOUTL
	INPUT
	DECON
	DECONV
	IMAGER
	IMAGEW
	RCAL01
	RCAL03
	WCAL01
	WCAL03
	WCAL04
	LBIN01
	LBIN1A
	LBIN02
	LBIN03
	LBOUT1
	LBOUT2
	LBOUT3
	LBOUT4
	FILE01
	FILE02
	FILE03
MVEND=.
/
/SAVE AREAS AND BUFFERS FOR EACH JOB
/
AREA1	XSBEGN			/RESTART -1 REG
	CTLP1
	WAITB1
	0			/FLAC -3 REGS
	0
	0
	0			/FRST
	0			/LIST3+1
	0			/AUTOXR -5 REGS
	0
	0
	0
	0
	IMB1			/BUFFER HEADER POINTERS -4 REGS
	IMB1
	INB1
	OTB1
	0			/SUBROUTINE ENTRY POINTS - 10(8) REGS
	0
	0
	0
	0
	0
	0
	0
	2000+TTI1			/CAL SAVES -14(8) REGS
	3000+TTI1
	2000+TTO1
	3000+TTO1
	2000+TTO1
	0
	0
	0
	0
	0
	0
	0
	0
FILA1	0			/FILE POINTERS - 3 REGS
FILB1	0
FILC1	0
BOT1	XX			/FREE CORE POINTERS - 6 REGS
BUF1	XX
ENDT1	XX
	XX
	XX
	XX
	XX
	CMB1			/COMBUF=COMEIN
	CMB1+77			/COMBOT=COMOUT
	IMB1+2			/IMBUFP=IMBUFF+2
	INB1+2			/INBUFP=INBUF+2
	OTB1+2			/OTBUFP=OUTBUF+2
	0			/AXOUT (TEXTP)
	0			/XCTX
	0			/GTEM
	0			/MODBUF
	215			/ENDCR
	0			/GETVCT
	0			/SAVEOT
	-1			/PUTCNT
	0			/TEMPK
	0			/INSUB
	TTI1			/TTIN
	TTO1			/TTOUT
	BKI1			/BLKIN
	BKO1			/BLKOUT
	0			/LIBRSW
	0			/EX1
	0			/AC1H
	0			/AC1L
	0			/OVER1
	0			/OVER2
	10			/FISW
	0			/GETP
	0			/GETCX
	0			/GET1X
	0			/GET2
	0			/GET3
	OTB1+2			/PUTP
	0			/PUTC
	0			/PUT6
	0			/SORTCN
	0			/LASTOP
	0			/ATSW (EFOP)
	-20			/CNTR
	4			/DECP
	0			/ADD
	0			/XCTIN
	1			/NAGSW
	215			/CHAR
	0			/LINENO
	FRST+1			/PC
	0			/THISLN
	0			/THISOP
	0			/LASTLN
	1			/DEBGSW
	1			/DMPSW
	0			/PACKST
	0			/PT1
	0			/T1
	0			/T2
	0			/SACH
	0			/FLARG -3 REGS
	0
	0
	0			/FLARG2 -3 REGS
	0
	0
AREA1S=.-AREA1
IMB1	2003; 0; 0; -1
INB1	.BLOCK	60		
	.ASCII	<15>
OTB1	1000
	.BLOCK	57
	.ASCII	<15>
CMB1	.BLOCK	100
	215
/
AREA2	XSBEGN		/RESTART - 1 REG
	CTLP2
	WAITB2
	0		/FLAC - 3 REGS
	0
	0
	0			/FRST
	0		/LIST3+1
	0		/AUTOXR - 5 REGS
	0
	0
	0
	0
	IMB2		/BUFFER HEADER POINTERS - 4 REG
	IMB2
	INB2
	OTB2
	0		/SUBROUTINE ENTRY POINTS - 10(8) REGS
	0
	0
	0
	0
	0
	0
	0
	2000+TTI2		/CAL SAVES - 14(8) REGS
	3000+TTI2	
	2000+TTO2
	3000+TTO2
	2000+TTO2
	0
	0
	0
	0
	0
	0
	0
	0
FILA2	0		/FILE POINTERS - 3 REGS
FILB2	0
FILC2	0
BOT2	XX		/FREE CORE POINTERS - 6 REGS
BUF2	XX
ENDT2	XX
	XX
	XX
	XX
	XX
	CMB2		/COMBUF=COMEIN
	CMB2+77		/COMBOT=COMOUT
	IMB2+2		/INBUFP=IMBUFF+2
	INB2+2		/INBUFP=INBUF+2
	OTB2+2		/OTBUFP=OUTBUF+2
	0		/AXOUT(TEXTP)
	0		/XCTX
	0		/GTEM
	0		/MODBUF
	215		/ENDCR
	0		/GETVCT
	0		/SAVEOT
	-1		/PUTCNT
	0		/TEMPK
	0		/INSUB
	TTI2		/TTIN
	TTO2		/TTOUT
	BKI2		/BLKIN
	BKO2		/BLKOUT
	0		/LIBRSW
	0		/EX1
	0		/AC1H
	0		/AC1L
	0		/OVER1
	0		/OVER2
	10		/FISW
	0		/GETP
	0		/GETCX
	0		/GET1X
	0		/GET2
	0		/GET3
	OTB2+2		/PUTP
	0		/PUTC
	0		/PUT6
	0		/SORTCN
	0		/LASTOP
	0		/ATSW(EFOP)
	-20		/CNTR
	4		/DECP
	0		/ADD
	0		/XCTIN
	1		/NAGSW
	215		/CHAR
	0		/LINENO
	FRST+1		/PC
	0		/THISLN
	0		/THISOP
	0		/LASTLN
	1		/DEBGSW
	1		/DMPSW
	0		/PACKST
	0		/PT1
	0		/T1
	0		/T2
	0		/SACH
	0		/FLARG - 3 REGS
	0
	0
	0		/FLARG2 - 3 REGS
	0
	0
AREA2S=.-AREA2
IMB2	2003; 0; -1
INB2	.BLOCK	60
	.ASCII	<15>
OTB2	1000
	.BLOCK	57
	.ASCII	<15>
CMB2	.BLOCK	100
	215
/
	.IFDEF	USR4
AREA3	XSBEGN		/RESTART - 1 REG
	CTLP3
	WAITB3
	0		/FLAC - 3 REGS
	0
	0
	0		/FRST
	0		/LIST3+1
	0		/AUTOXR - 5 REGS
	0
	0
	0
	0
	IMB3		/BUFFER HEADER POINTERS - 4 REG
	IMB3
	INB3
	OTB3
	0		/SUBROUTINE ENTRY POINTS - 10(8) REG
	0
	0
	0
	0
	0
	0
	0
	2000+TTI3		/CAL SAVES - 14(8) REGS
	3000+TTI3
	2000+TTO3
	3000+TTO3
	2000+TTO3
	0
	0
	0
	0
	0
	0
	0
	0
FILA3	0		/FILE POINTERS - 3 REGS
FILB3	0
FILC3	0
BOT3	XX		/FREE CORE POINTERS - 6 REGS
BUF3	XX
ENDT3	XX
	XX
	XX
	XX
	XX
	CMB3		/COMBUF=COMEIN
	CMB3+77		/COMBOT=COMOUT
	IMB3+2		/IMBUFP=IMBUFF+2
	INB3+2		/INBUFP=INBUF+2
	OTB3+2		/OTBUFP=OUTBUF+2
	0		/AXOUT(TEXTP)
	0		/XCTX
	0		/GTEM
	0		/MODBUF
	215		/ENDCR
	0		/GETVCT
	0		/SAVEOT
	-1		/PUTCNT
	0		/TEMPK
	0		/INSUB
	TTI3		/TTIN
	TTO3		/TTOUT
	BKI3		/BLKIN
	BKO3		/BLKOUT
	0		/LIBRSW
	0		/EX1
	0		/AC1H
	0		/AC1L
	0		/OVER1
	0		/OVER2
	10		/FISW
	0		/GETP
	0		/GETCX
	0		/GET1X
	0		/GET2
	0		/GET3
	OTB3+2		/PUTP
	0		/PUTC
	0		/PUT6
	0		/SORTCN
	0		/LASTOP
	0		/ATSW(EFOP)
	-20		/CNTR
	4		/DECP
	0		/ADD
	0		/XCTIN
	1		/NAGSW
	215		/CHAR
	0		/LINEND
	FRST+1		/PC
	0		/THISLN
	0		/THISOP
	0		/LASTLN
	1		/DEBGSW
	1		/DMPSW
	0		/PACKST
	0		/PT1
	0		/T1
	0		/T2
	0		/SACH
	0		/FLARG - 3 REGS
	0
	0
	0		/FLARG2 - 3 REGS
	0
	0
AREA3S=.-AREA3
IMB3	2003; 0; 0; -1
INB3	.BLOCK	60
	.ASCII	<15>
OTB3	1000
	.BLOCK	57
	.ASCII	<15>
CMB3	.BLOCK	100
	215
/
AREA4	XSBEGN		/RESTART - 1 REG
	CTLP4
	WAITB4
	0		/FLAC - 3 REGS
	0
	0
	0		/FRST
	0		/LIST3+1
	0		/AUTOXR - 5 REGS
	0
	0
	0
	0
	IMB4		/BUFFER HEADER POINTERS - 4 REG
	IMB4
	INB4
	OTB4
	0		/SUBROUTINE ENTRY POINTS - 10 (8) REG
	0
	0
	0
	0
	0
	0
	0
	2000+TTI4		/CAL SAVES - 14(8) REGS
	3000+TTI4
	2000+TTO4
	3000+TTO4
	2000+TTO4
	0
	0
	0
	0
	0
	0
	0
	0
FILA4	0		/FILE POINTERS - 3 REGS
FILB4	0
FILC4	0
BOT4	XX		/FREE CORE POINTERS - 6 REGS
BUF4	XX
ENDT4	XX
	XX
	XX
	XX
	XX
	CMB4		/COMBUF=COMEIN
	CMB4+77		/COMBOT=COMOUT
	IMB4+2		/IMBUFP=IMBUFF+2
	INB4+2		/INBUFP=INBUF+2
	OTB4+2		/OTBUFP=OUTBUF+2
	0		/AXOUT(TEXPT)
	0		/XCTX
	0		/GTEM
	0		/MODBUF
	215		/ENDCR
	0		/GETVCT
	0		/SAVEOT
	-1		/PUTCNT
	0		/TEMPK
	0		/INSUB
	TTI4		/TTIN
	TTO4		/TTOUT
	BKI4		/BLKIN
	BKO4		/BKOUT
	0		/LIBRSW
	0		/EX1
	0		/AC1H
	0		/AC1L
	0		/OVER1
	0		/OVER2
	10		/FISW
	0		/GETP
	0		/GETCX
	0		/GET1X
	0		/GET2
	0		/GET3
	OTB4+2		/PUTP
	0		/PUTC
	0		/PUT6
	0		/SORTCN
	0		/LASTOP
	0		/ATSW(EFOP)
	-20		/CNTR
	4		/DECP
	0		/ADD
	0		/XCTIN
	1		/NAGSW
	215		/CHAR
	0		/LINENO
	FRST+1		/PC
	0		/THISLN
	0		/THISOP
	0		/LASTLN
	1		/DEBGSW
	1		/DMPSW
	0		/PACKST
	0		/PT1
	0		/T1
	0		/T2
	0		/SACH
	0		/FLARG - 3 REGS
	0
	0
	0		/FLARG2 - 3 REGS
	0
	0
AREA4S=.-AREA4
IMB4	2003; 0; 0; -1
INB4	.BLOCK	60
	.ASCII	<15>
OTB4	1000
	.BLOCK	57
	.ASCII	<15>
CMB4	.BLOCK	100
	215
/
	.ENDC
	.ENDC
	.EJECT
START	LAC	FRSTCV
	SAD	LASTCV		/ANY COMMON?
	JMP	STARTQ		/NO - GO RESET POINTERS
	LAC	MOVCOM
	SZA!CLA
	LAC	C100
	DAC	T1
	LAC	FRSTCV
	TAD	M1
	TAD	T1
	DAC*	(X15
	LAC	BUFR		/SETUP NEW COMMON START
	DAC	FRSTCV
	TAD	M1
	DAC*	(X16
STARTL	LAC	T1
	JMS	TWOS
	TAD*	(X15
	SAD	LASTCV		/ANY MORE COMMON?
	JMP	STARTC		/NO
	LAC*	X15		/YES - MOVE REG
	DAC*	X16		
	JMP	STARTL
STARTC	LAC*	(X16		/SET NEW LAST ADDR
	JMP	STARTB
STARTQ	LAC	BUFR
	DAC	FRSTCV
STARTB	DAC	LASTCV
	DAC	LASTV		/AND VARIABLE POINTERS
STARTZ	ISZ	DEBGSW	/DISABLE TRACE FOR INPUT
	DZM	MOVCOM
	LAC	COMBOT	/PROTECT COMMAND BUFFER
	DAC*	(PDLXR
	ISZ	DMPSW	/INIT UNPACK AND TRACE SWITCH
	DZM	LIST3+1	/CLEAR SEARCH CHARACTER FOR INPUT
	LAC	RCAL01	/IS INPUT TTY IN?
	AND	(777
	SAD	TTIN
	SKP
	JMP IBAR		/DON'T PRINT *
	LAC WCAL01
	AND	(777
	SAD TTOUT		/MAKE SURE TTY OUT
	JMP IBARX
	LAC C252		/IF NOT TTY OUT USE IMAGE MODE
	JMS IMAGEW
	JMP IBAR
IBARX	LAC C252		/ANNOUNCE PRESENCE
	PRINTC
	LAC	C375
	PRINTC
IBAR	LAC	COMBUF	/INITIALIZE COMMAND BUFFER.
	DAC*	(AXIN
	DZM	XCTIN
	LAC	CFRSX
	DAC	PC
IGNOR	READC		/READ COMMAND STRING
	SAD	C215
	JMP	IRETN
	PACKC		/SAVE STRING CHARACTER.
	JMP	IGNOR
/////
IRETN	PACKC		/ PACK C.R.
	ISZ	PC
	LAC	COMBUF	/INITIALIZE "TEXTP"
GONE	TAD	C1
	DAC	AXOUT	/SETUP CURRENT LINE
M1	LAW	-1
	DAC	XCTX
	GETC		/READ FIRST CHARACTER.
	LAC	BOTTOM	/INIT PUSH-DOWN-LIST
	DAC*	(PDLXR
	SPNOR
	TESTN		/DOES THE LINE BEGIN WITH 1-9?
	ERROR	1
	SKP
	JMP	INPUTX	/YES
	DZM	DEBGSW	/ENABLE TRACE
	DZM	LINENO
	PUSHJ	PROC	/PROCESS IMMEDIATE COMMAND.
	LAC*	PC	/CHECK NEXT LINE (X-MEM)
	SNA		/END OF PROGRAM? 
	JMP	STARTZ	/YES
	DAC	PC		/SAVE NEW LINE NO.
	TAD	C1	/START NEW LINE
	JMP	GONE	/PROCESS OTHER COMMANDS
/////
INPUTX	GETLN		/READ THIS LINE NUMBER
	LAC	NAGSW
	SMA!CLA		/TEST FOR SINGLE LINE
	ERROR	2
	JMS	MOVCOM		/OFFSET COMMON
	LAC	BUFR	/SET POINTERS
	DAC*	(AXIN
	DZM	XCTIN
	LAC	LINENO	/SAVE LINE #
	DAC*	AXIN	/(X-MEM)
	SKP!CLA
	GETC		/READ 1ST AFTER LINENO TERMINATOR.
	PACKC		/SAVE SPACE AND OTHERS - RESTORE DATA FIELD
	SAD	C215	/TEST FOR END
	SKP
	JMP	.-4
	PUSHJ	DELETE	/REMOVE OLD LINE, IF ANY.
	ENDLN		/INSERT NEW LINE
	JMP	START
	.EJECT
/TEXT LINE BUFFER FORMAT*
/#1 : POINTER OR ZERO IN LAST
/#2 : LINENO
/#3 - #N+1 : TEXT
/#N : C.R.
XGETLN	0		/DEVELOP I.D. - "GETLN"
	SPNOR		/IGNORE LEADING ZEROS AND SPACES.
	TESTN
	NOP
	JMP	TESTA
	DZM	INSUB	/CALL 'GETC' FROM 'INPUT' FROM 'DECON'
	DZM* .AB
	DZM* .AC
	DZM	OVER2
	JMS	DECON
	LAC OVER2
	RTL6
	RAL
	DAC	LINENO
	AND	P177	/GROUP TOO LARGE
	SZA!CLA
	ERROR	3	/YES
	LAC* .AC
	SZA
	ERROR	3	/GROUP TOO LARGE
	TESTN		/TEST3
	GETC		/READ STEP NUMBER.
/OTHER
	TESTN		/TEST4
	ERROR	5	/DOUBLE PERIODS
	JMP	GEXIT	/OTHER
	CLL		/NUMBER *12
	RTL
	TAD	SORTCN
	RAL
	TAD	LINENO
	DAC	LINENO
	GETC		/GET FINAL DIGIT
	TESTN		/TEST5
	ERROR	5	/MULTIPLE PERIODS
	JMP	GEXIT	/OTHER
	TAD	LINENO
	DAC	LINENO
	GETC		/TEST FOR CORRECT TERMINATOR
	TESTN		/TEST6 - I.E. NOT A NUMBER OR "."
	SKP
	JMP	GEXIT
	ERROR	6	/TOO LARGE A LINE NUMBER.
TESTA	LAC	CHAR
	SAD	C242
	JMP	LBTEXT
	DZM	LINENO
	SORTC	GLIST
	JMP	GEXIT
	LAW	-11
	JMS	FETVAR
	LAC*	BUFSTX
	SNA
	JMP	GEXIT
	SORTJX	ALLCM1
	ERROR	23
GEXIT	LAC	LINENO	/TEST FOR GROUP NUMBER.
	AND	P177
	SZA!CLA!CLL
	CML
	TAD	LINENO
	AND	P7600
	SNA!CLA
	TAD	P2
	RAR
	DAC	NAGSW
	JMP*	XGETLN
/RANGE OF ACCEPTIBLE LINE NUMBERS = 1.01 TO 99.99
/NAGSW:
/GROUP=000000
/LINE=400000
/ALL=000001
XRTL6	0	/ROTATE AC LEFT SIX - "RTL6"
	CLL
	RTL
	RTL
	RTL
	JMP*	XRTL6
	.EJECT
/RECURSIVE OPERATE, EXECUTE, OR CALL 
DO	GETLN		/EXECUTE ONE LINE, A GROUP,OR ALL
	LAC	PC		/SAVE ADDRESS
	PUSHA		/OF CURRENT LINE
	PUSHF	TEXTP	/SAVE REST OF THIS LINE
DGRP	PUSHF	NAGSW	/SAVE NAGSW; CHAR; AND LINENO.
	LAC	NAGSW	/CHECK DATA FROM GETLN.
	SPA!CLA		/SKIP IF GROUP OR ALL
	JMP	ONE		/DO ONE LINE
	FINDLN		/INIT FOR GROUP AND SET THISLN
	JMP	TGRP2
DGRP1	PUSHJ	PROCES-2	/EXECUTE OBJECT LINE AND SET PC.
	POPF	NAGSW	/RESTORE THE DATA
	LAC*	PC	/CHECK FOR END OF TEXT (X-MEM)
	SNA
	JMP	DCONT	/ALL DONE
	TAD	C1
	DAC	PT1		/SAVE POINTER TO LINENO
	LAC	NAGSW	/CHECK FOR GROUP
	SMA!SZA!CLA
	JMP	.+4		/DO ALL
	TAD*	PT1	/TEST GROUP (X-MEM)
	TSTGRP
	JMP	DCONT	/NOT IN GROUP
	LAC*	PT1	/READ NEXT LINE NO. (X-MEM)
	DAC	LINENO
	JMP	DGRP	/CONTINUE THE SUBROUTINE
/////
ONE	FINDLN		/FIND THE LINE
	ERROR	7
	PUSHJ	PROCES	/EXECUTE IT
LPROCS=.-1
	POPF	NAGSW	/RESTORE CHAR
DCONT	POPF	TEXTP	/RESTORE TEXT POINTERS
	POPA		/RESTORE ADDRESS OF CURRENT LINE.
	DAC	PC
	JMP	PROC	/CONTINUE PROCESSING THIS LINE.
///////
TGRP2	LAC	THISLN	/TEST FOR GOOD GROUP NUMBER.
	DAC*	(XRT
	LAC*	XRT
	TSTGRP
	ERROR	8
	JMP	DGRP1
	.EJECT
/PUSHDOWN LIST CONTROLS
XPUSHA	0		/PUSHDOWN THE AC - "PUSHA"
	DAC	T2		/BACKUP POINTER
	CLA!CMA		/AND THEN	
	JMS	PCHK	/CHECK CORE USAGE
	LAC	T2		/OK
	DAC*	PDLXR	/PUSH DOWN LIST POINTER
	CLA!CMA		/BACKUP AGAIN
	JMS	PCHK
	LAC	T2
	JMP*	XPUSHA
PCHK	0
	TAD*	(PDLXR	/INC IN AC
	DAC*	(PDLXR
	JMS	TWOS
	CLL
	TAD	LASTV
	SZL!CLA	
	ERROR	9	/STORAGE FILLED BY PUSH-DOWN LIST
	JMP*	PCHK
XPUSHJ	0		/RECURSIVE SUBROUTINE CALL - "PUSHJ"
	LAC*	XPUSHJ
	DAC	T2		/SAVE SUBR. ADDR.
	CLA!CMA
	JMS	PCHK
	TAD	XPUSHJ
	TAD	C1
	DAC*	PDLXR	/SAVE RETURN
	CLA!CMA
	JMS	PCHK
	JMP*	T2	/TRANSFER CONTROL
PD2	0		/SAVE A FLOATING POINT NUMBER - "PUSHF"
	CLA!CMA		/COMPUTE VARIABLE ADDR
	TAD*	PD2
	DAC*	(XRT
	ISZ	PD2		/FIX RETURN
MFLT	LAW	-WORDS	/COMPUTE PUSH. POINTER
	DAC	T2
	JMS	PCHK
	LAC*	XRT	/(X-MEM)
	DAC*	PDLXR
	ISZ	T2
	JMP	.-3
	LAC	MFLT	/RESET POINTER
	JMS	PCHK
	JMP*	PD2
PD3	0		/ RESTORE A FLOATING POINT NUMBER - "POPF"
	CLA!CMA		/GET VAR. ADDR.
	TAD*	PD3
	ISZ	PD3
	DAC*	(XRT
	LAC	MFLT
	DAC	T2
	LAC*	PDLXR	/MOVE
	DAC*	XRT
	ISZ	T2
	JMP	.-3
	JMP*	PD3	/EXIT
/////
MOVCOM	0			/MOVE COMMON AREA
	LAC	FRSTCV
	SAD	LASTCV		/ANY COMMON?
	JMP*	MOVCOM		/NO
	DAC	MODBUF
	LAC	LASTCV
	DAC	T2		/CURRENT END
	TAD	C100
	DAC	T1		/NEW END
	JMS	TWOS
	TAD*	(PDLXR
	SPA			/OVERFLOW
	ERROR	16
MOVUPX	LAC*	T2		/MOVE BLOCK
	DAC*	T1
	LAC	T2		/IS IT AT END?
	SAD	MODBUF
	JMP*	MOVCOM		/YES - EXIT
	TAD	M1		/NO - BACKUP POINTERS
	DAC	T2
	LAC	T1
	TAD	M1
	DAC	T1
	JMP	MOVUPX
/
	.EJECT
/PRIMARY CONTROL AND TRANSFER
GOTO	GETLN		/READ THE LINE NUMBER REQUESTED
	FINDLN		/LOCATE IT AND RESET TEXTP
	ERROR	7	/NOT THERE
	LAC	THISLN	/SET PC
	DAC	PC
PROCES	GETC		/TEST FOR END OF LINE
PROC=.
	.IFDEF MULTI
	LAC	DELAY
	SZA
	JMS	IOBUSY
	.ENDC
	LAC	C273
	DAC	TLISTX	/RESET IN CASE ENTRY FROM COMMON STMT
	LAC	CHAR	/FIRST CHARACTER READY = USE PROC
	SAD	C215
PC1	POPJ		/EXIT "PROCESS"
	SORTC	GLIST	/IGNORE "SPACE",",", AND ";".
	JMP PROCES
	LAC	LIBRSW
	RAL
	LAC	CHAR
	SAD	C314
	JMP	.+3
	SZL
	ERROR	31
	LAW	-11
	JMS	FETVAR		/GET COMMAND (3 WORDS)
	SORTC	GLIST
	SKP
	ERROR	10
	SORTJX	COMLST		/GO DO COMMAND
	ERROR	10	/ILLEGAL COMMAND
	.EJECT
/////
COMMEN=PC1	/IS CONTINUE OR COMMENT
/OUTPUT COMMAND TEXT
WRITE	GETLN		/SET LINENO
	ISZ	DEBGSW	/DISABLE TRACE (ALWAYS DURING WRITE)
	FINDLN		/SEARCH FOR LINE NUMBER
	JMP	WTESTG	/NOT THERE OR GROUP
	LAC	LINENO
	SZA!CLA
	JMP .+4
	LAC C215
	PRINTC
	SKP
	PRNTLN		/PRINT LINE NUMBER
	GETC
	PRINTC		/PRINT TEXT OF A LINE.
	SAD	C215
	SKP		/SKIP IF END OF LINE
	JMP	.-4
	LAC*	THISLN	/TEST FOR END OF TEXT (X-MEM)
WTEST2	SNA
	JMP	WRITED	/EXIT;DO NEXT INDIRECT LINC.
	TAD	C1
	DAC	PT1		/SAVE POINTER TO LINENO OF NEXT (X-MEM)
	LAC	NAGSW
	SMA!CLA
	TAD*	PT1	/(X-MEM)
	TSTGRP		/TRY NEXT LINENO FOR GROUP.
	JMP	WX
WALL	LAC*	PT1	/SET LINENO (X-MEM)
	DAC	LINENO
	JMP	WRITE+2
///
WTESTG	LAC	THISLN	/INIT GROUP PRINTOUT
	JMP	WTEST2
/////
WX	LAC	NAGSW
	SMA!SZA!CLA		/SKIP IF NOT ALL
	JMP	WALL
WRITED	LAC C215
	PRINTC
	POPJ
LPOPJ=.-1
	.EJECT
/////
XTESTC	0	/TEST THE NATURE OF THE NEXT ALPHANUMERIC - "TESTC"
	SPNOR		/IGNORE SPACES AND ZEROS HERE
	SORTC	TERMS	/TEST THE VARIABLE TERMINATOR FOR EVAL
	JMP	XTESTX	/YES - SORTCN IS SET
	ISZ	XTESTC
	SAD	C306	/TEST FOR "F"
	JMP	XT3
	TESTN		/TEST FOR . OR 0-9
	JMP	XTESTX
	SKP
	JMP	XTESTX
	ISZ	XTESTC
XT3	ISZ	XTESTC	/RETURNS:T;N;F;A
XTESTX	LAC	CHAR
	JMP*	XTESTC
XSORTC	0	/SORT CHAR AGAINST TABLE - "SORTC"
	LAC*	XSORTC
	DAC*	(XRT2	/1ST ARG IS LIST-1
	LAC*	XRT2
	SPA		/LIST IS ENDED BY A NEGATIVE NUMBER
	JMP	SEXC	/2AND EXIT = NOT IN LIST
	SAD	CHAR
	SKP		/COMPARE
	JMP	.-5
	LAC*	XSORTC	/COMPUTE INCREMENT : 0 - N
	CMA
	TAD*	(XRT2
	DAC	SORTCN
	SKP		/1ST EXIT = YES
SEXC	ISZ	XSORTC
	ISZ	XSORTC
	LAC	CHAR
	JMP*	XSORTC
GRPTST	0	/AC VS LINENO - "TSTGRP"
	AND	P7600
	JMS	TWOS
	DAC	T2
P7600	LAW	17600
	AND	LINENO
	TAD	T2
	SNA!CLA
	ISZ	GRPTST
	JMP*	GRPTST
	.EJECT
/CONDITIONAL TRANSFER PROCESS.
	GETC		/IF (EXP) A,B,C;
IF	LAC	CHAR
	SAD	C240
	JMP	IF-1
	SAD	C250
	SKP
	ERROR	11	/NO SPACE AFTER IF OR ILLEGAL FORMAT.
	PUSHJ	EVAL-1	/EVALUATE EXPRESSION
	GETC		/MOVE PAST ")"
M2	LAW	-2
	DAC	T1
	LAC	FLARG+1	/TEST -,0,+
	SPA
	ISZ	T1		/TO 	-1,-2,-3
	SPA!SNA!CLA
IF3	ISZ	T1		/COUNT COMMAS
	SKP
	JMP	GOTO	/TRANSFER
	SORTJ	TLIST,ILIST	/SEARCH TEXT UNTILL ,;C.R.
	GETC
	JMP	.-4
IF1	GETC		/MOVE PAST 
	JMP	IF3
	.EJECT
/////
/LOOP CONTROL STATEMENT
SET=.			/SUBSET OF "FOR".
FOR	PUSHJ	GETARG	/LOOPS, ETC.
	SPNOR		/IGNORE SPACES
	SAD	C275
	SKP
	ERROR	12	/LEFT OF "=" IN ERROR: 'FOR' OR 'SET'
	LAC	PT1
	PUSHA		/SAVE POINTER TO VARIABLE
	PUSHJ	EVAL-1	/GET INITIAL VALUE EXPRESSION
	POPA
	DAC	PT1
	JMS	FINT		/INITIALIZE NOW.
	FGET FLARG
	FPUT* PT1
	FXIT
	SORTJ	TLIST,FLIST1	/TEST LAST CHAR FROM "EVAL"
	ERROR	13	/EXCESS R-PAR
/////
FINCR	LAC	LPROCS		/SET OPERATION
	DAC	FPUSHJ
	LAC	LPOPJ		/SET EXIT
	DAC	FPOPJ
FINCRX	LAC	PT1		/SAVE VARIABLE ADDRESS *
	PUSHA
	PUSHJ	EVAL-1	/EVALUATE THE INCREMENT,IF ANY.
	SORTJ	TLIST,FLIST2	/TEST TERMINATORS
	ERROR	14
/////
FLIMIT	PUSHF	FLARG	/SAVE THE INCRE.	*
	PUSHJ	EVAL-1	/GET THE LIMIT
FCONT	PUSHF	FLARG	/SAVE THE LIMIT *
	PUSHF	TEXTP	/SAVE TEXT OF OBJECT STATEMENTS
	PUSHJ	PROCES	/DO THE OBJECT STATEMENTS
FPUSHJ=.-1
	POPF	TEXTP	/RESTORE REMAINING TEXT.
	POPF	FLARG	/GET LIMIT
	POPF	FLARG2	/GET INCREMENT
	POPA		/GET VARIABLE ADDRESS
	DAC	PT1
	JMS	FINT		/INCREMENT AND TEST
	FGET* PT1	/LOAD THE VARIABLE
	FADD FLARG2	/INCREMENT IT
	FPUT* PT1	/CHANGE IT
	FSUB FLARG	/TEST IT
	FXIT
	GETSGN
	SMA!SZA!CLA
	POPJ		/END OF LOOP
FPOPJ=.-1
	LAC	PT1
	PUSHA		/SAVE ADDRESS *
	PUSHF	FLARG2	/SAVE INCREMENT AGAIN *
	JMP	FCONT
/////
FINFIN	PUSHF	FLTONE	/SET INCREMENT TO ONE.
	JMP	FCONT
	.EJECT
	GETC
COMMON	LAC	STARTV		/CHECK FOR LEGALITY
	SAD	LASTV		/OF COMMON STATEMENT
	SKP
	JMP	COMMEN		/NOT LEGAL - COMMENT
	SPNOR			/OK
	SAD	C250		/IS IT LEFT PAREN
	JMP	COMARY		/YES - PROCESS ARRAY
	PUSHJ	GETARG		/NO - NORMAL VARIABLE
COMMX	SPNOR
	LAC	LASTV		/SET END OF COMMON
	DAC	LASTCV
	LAC	CHAR
	SORTJ	TLIST,CLISTX	/CHECK FOR TERMINATOR
	ERROR	37		/FORMAT ERROR
COMARY	GETC
	TESTC			/CHECK FIRST CHAR
	NOP
	NOP
	ERROR	15		/FORMAT ERROR
	LAW	-3		/GET WHOLE VARIABLE
	JMS	FETVAR		/NAME
	LAC	CHAR
	SAD	C254		/MUST BE A COMMA
	SKP
	ERROR	37		/FORMAT ERROR
	LAC*	BUFSTX		/GET VARIABLE NAME
	DAC	ARRAYN
	PUSHJ	EVAL-1		/SKIP COMMA AND EVALUATE
	JMS	FINT
	FGET	FLARG
	FPUT	X
	FXIT
	LAC	LITX		/USE X AS COUNTER
	DAC	PT1
	LAC	C251		/SET TERMINATOR
	DAC	TLISTX
	LAC	(COMDEC		/SET OPERATION
	DAC	FPUSHJ
	LAC	(JMP COMEND	/SET EXIT
	DAC	FPOPJ
	JMP	FINCRX		/GO PROCESS ARRAY DEF
COMDEC	LAC	ARRAYN		/GET NAME
	DAC*	BUFSTX
	JMS*	.AO		/GET COUNTER
LITX	X
	JMP	GS1A
COMEND	LAC	LASTV
	DAC	LASTCV
	LAC	CHAR
	SAD	C251		/LAST PAREN?
	JMP	COMMX		/YES
	ERROR	37		/NO - FORMAT ERROR
/
	.EJECT
/INPUT-OUTPUT STATEMENTS
ASK	SKP!CLA!CMA	/REMEMBER WHICH CALL. (-1) FOR ASK
TYPE	CLA		/0 FOR TYPE
	DAC	ATSW
TASK	DZM	DEBGSW	/RE-ENABLE THE TRACE
	CLA
	SORTJ	ALIST,ATLIST	/SPECIAL CHARACTER? 
	ISZ	ATSW	/TEST QUOTE SWITCH
	JMP	TYPE2
	PUSHJ	GETARG	/DO ASK; SETUP PT1
	LAW	272	/TYPE COLON
	PRINTC
	LAC C375
	PRINTC
	PUSHA		/SAVE IN-LINE CHARACTER
	ISZ	INSUB	/INDICATE 'READC'
	LAC	C215
	DAC	ENDCR
	LAC	C1	/POINT PAST CHAR
	JMS	FLINTP	/READ DATA AND SAVE
	LAC	C215
	DAC	ENDCR
	POPA		/RE-TEST LAST TERMINATOR
	DAC	CHAR
	JMP	ASK		/CONTINUE PROCESSING
////
TYPE2	PUSHJ	EVAL	/DO TYPE
	JMS	FLOUTP	/PRINT
	SORTC	GLIST
	JMP	TYPE
	ERROR	4
/////
TQUOT	ISZ	DEBGSW	/DISABLE TRACE
	GETC		/TYPE LITERALS
	SAD	C242	/"
	JMP	TASK4
	SAD	C215	/CR
	JMP	PC1
	PRINTC
	JMP	TQUOT+1
//////
TCRLF	LAC	CCR		/SLASH=CR,LF.
	PRINTC
TASK4	GETC		/MOVE TO NEXT CHARACTER
	JMP	TASK
////
TCRLF2	LAC	C375
	PRINTC
	LAC	C215
	JMS	IMAGEW
	LAC C200
	JMS IMAGEW
	JMP	TASK4
/IF DEBGSW=0 : ENABLE FLIP-FLOP "DMPSW"
/	#0: DISABLE AND RETURN ALL"?" ' S.
/IF DMPSW = 0: TRACE ON, IF ENABLED
/	#0: TRACE OFF
/IF BOTH = 0 : PRINT TRACE.
TINTR	GETC		/PASS PERCENT SIGN
	GETLN		/READ FORMAT CONTROL: "%7.03"
	LAC	LINENO
	AND	C77
	DAC	DECP
	LAC	LINENO
	RAR
	RTR
	RTR
	RTR
	AND	C77
	DAC	FISW
	JMP	TASK
	.EJECT
////
/SEARCH ROUTINES
MODIFY	GETLN		/READ LINE NO.
	FINDLN		/LOOK IT UP NOW.
	ERROR	7	/NOT THERE = BAD COMMAND UNLESS ZERO.
	JMS	MOVCOM	/DISPLACE COMMON
	LAC	BUFR	/SET POINTERS
	DAC*	(AXIN	/FOR INPUT
	DZM	XCTIN
	LAC	LINENO	/COPY THE SAME LINE NUMBER.
	SNA		/CHECK FOR ALL
	ERROR	7
	DAC*	AXIN	/(X-MEM)
	LAC*	(AXIN	/SAVE START OF NEW LINE
	DAC	PACKST
	LAC	COMBUF
	DAC	MODBUF	/SET MODIFY COMMAND BUFFER
SCONT	JMS	IMAGER	/GET SEARCH CHAR
	SKP
SCONTX	CLA		/CLEAR SEARCH CHAR
	DAC	SACH	/SAVE SEARCH CHARACTER
	ISZ	DEBGSW	/NO BREAKS.
SCHAR	LAC SACH
	DAC LIST3+1	/PUT IN "SORTJ" LIST
	GETC
	DAC	CHAR		/SAVE FOR SORTJ
	DAC*	MODBUF
	ISZ	MODBUF
	JMS	IMAGEW
	SORTJ	LIST3,LISTGO	/LOOK FOR MATCH
	JMP	SCHAR
/////
SBAR	LAW	300	/ECHO @ FOR ^U
	JMS	IMAGEW
	LAC	COMBUF	/RESET TO BEGINNING OF BUFFER
	DAC	MODBUF
SFOUND	DZM	LIST3+1
	JMS	IMAGER	/READ FROM KEYBOARD
	DAC	CHAR
	SORTJ	LIST6,SRNLST	/CHECK FOR ACTION CHANGE
	LAC	CHAR
	DAC*	MODBUF	/PACK CHAR
	ISZ	MODBUF
	JMP	SFOUND	/GO GET MORE
SRETN	LAC	C215
	DAC*	MODBUF	/SAVE CR
	LAC	COMBUF
	DAC	MODBUF
	LAC*	MODBUF	/FINISH LINE AND SAVE IT
	DAC	CHAR
	PACKC
	ISZ	MODBUF
	SAD	C215	/END LINE?
	SKP		/YES
	JMP	.-6
	LAC C212
	JMS IMAGEW
	PUSHJ	DELETE		/REPLACE WITH NEW LINE
	ENDLN
	JMP	START	/RESET POINTERS
SCRUB	LAC	MODBUF
	SAD	COMBUF	/AT BEGINNING?
	JMP	SFOUND	/YES
	TAD	M1	/NO
	DAC	MODBUF
	LAW	334	/ECHO BACK SLASH
	JMS	IMAGEW
	JMP	SFOUND	/GO PROCESS NEXT
	.EJECT
SORTB	0	/SORT AND BRANCH ROUTINE. - "SORTJ"
	SNA
	LAC	CHAR	/ASSUME CHAR IF AC=0
	DAC	T2		/SAVE SORT ITEM
	LAC*	SORTB	/FIRST ARG IS LIST LESS ONE
	ISZ	SORTB	/2AND IS INTRA-LIST LENGTH
	DAC*	(XRT2
	LAC*	XRT2
	SPA		/**LIST ENDED BY NEGATIVE NUMBER**
	JMP	SEX
	SAD	T2		/FIND ADDRESS
	SKP
	JMP	.-5
	LAC*	(XRT2	/MATCH FOUND.
	TAD*	SORTB
	DAC	T2
	CLA
	JMP*	T2
SEX	ISZ	SORTB	/MATCH NOT FOUND.
	CLA!CLL
	JMP*	SORTB	/RETURN TO CALLING SEQUENCE.
/
/SORT AND BRANCH ON COMMAND
/
XSORTX	0		/"SORTJX"
	LAC*	XSORTX	/GET TABLE START
	DAC*	(XRT2
	LAC*	XRT2	/SET SIZE
	DAC	T2
ANYMAT	LAC	BUFSTX	/GET COMMAND POINTER
	DAC	MODBF1
	DZM	MODBF2
MORMAT	LAC*	XRT2	/GET COMMAND TABLE ENTRY
	SAD*	MODBF1
	JMP	ENDMAT	/FULL WORD MATCH
	DAC	SORTB	/SAVE FOR END TEST
	AND	(770000
	SAD*	BUFSTX
	JMP	YESMAT	/ONE LETTER MATCH
	JMP	NOTMAT
ENDMAT	AND	C77	/IS IT END OF COMMAND
	SNA
	JMP*	XRT2	/DISPATCH
	ISZ	MODBF1
	ISZ	MODBF2	/DISABLE ONE LETTER MATCH
	JMP	MORMAT	/TEST REST OF COMMAND
	LAC*	XRT2
	SKP
YESMAT	LAC	SORTB	/TEST FOR COMMAND END
	AND	C77
	SZA
	JMP	YESMAT-2
	LAC	MODBF2	/ONE LETTER OK
	SNA
	JMP*	XRT2	/DISPATCH
NOTMAT	LAC*	XRT2	/SKIP REST OF COMMAND
	AND	(700000
	SAD	(600000	/ENDS WITH JMP
	SKP
	JMP	.-4
	ISZ	T2	/ANY MORE IN TABLE
	JMP	ANYMAT	/YES
	ISZ	XSORTX	/NO - ERROR RETURN
	JMP*	XSORTX
/
	.EJECT
/FETCH VARIABLE FROM INPUT
FETVAR	0
	DAC	GETVCT	/-3 OR -6 OR -9
	LAW	-1	/(BUFFER-1
	TAD	BUFSTX
	DAC*	(AXIN
	DZM	XCTIN	/BEGIN PACK OF VARIABLE NAME
GETVAP	PACKC		/PACK CHAR
	GETC
	SORTC	TERMS	/CHECK FOR TERMINATORS
	JMP	GETVAX
	ISZ	GETVCT	/HAVE THREE CHARS BEEN USED
	JMP	GETVAP	/NO-GO PACK THIS ONE
	LAW	-1	/IGNORE REST
	DAC	GETVCT
	JMP	GETVAP+1
GETVAX	ISZ	GETVCT
	SKP!CLA
	JMP*	FETVAR
	JMS	PCK1	/USE NULLS
	JMP	GETVAX
/FIND OR ENTER A VARIABLE IN THE LIST.
GETARG	TESTC		/FIRST LETTER OF ARG
	NOP
	NOP		/ FUNCTION OR NUMBER IS NOT AN ARG.
	ERROR	15	/BAD ARGUEMENT IN 'FOR', 'SET', OR 'ASK'
GETVAR	LAW	-3
	JMS	FETVAR
	TSTLPR		/LOOK FOR SUBSCRIPT VIA SORTCN
	JMP	GS1		/NOT SUBSCRIPTED BY L-PAR.
	LAC	LASTOP	/SAVE LAST OPERATION
	PUSHA
	LAC*	BUFSTX		/SAVE NAME
	PUSHA
	PUSHJ	EVAL-1	/MOVE PAST L-PAR AND EVALUATE SUBSCRIPT
	POPA
	DAC*	BUFSTX		/RESTORE NAME
	GETC		/MOVE PAST R-PAR
	POPA
	DAC	LASTOP	/RECALL LAST OPERATION
GS1A	JMS	FIX
GS1	DAC	SUBS	/SAVE SUBSCRIPT
	LAC	FRSTCV	/SEARCH FOR VARIABLE
GS3	DAC	PT1
	SAD	LASTV	/TEST FOR END OF LIST
	JMP	GS2		/END SEARCH
	LAC*	PT1	/GET TABLE ENTRY
	SAD*	BUFSTX
	JMP	GFND1	/FOUND XX
GS4	LAC	PT1		/TRY NEXT ONE
	TAD	GINC
	JMP	GS3
GS2	LAC	LASTV	/ADD THE VARIABLE
	TAD	P13		/TEST RAN LIMITS
	CLL
	JMS	TWOS
	TAD*	(PDLXR
	SNL!CLA
	ERROR	16
	LAC	LASTV
	TAD	GINC
	DAC	LASTV
	LAC*	BUFSTX		/SAVE NAME
	DAC*	PT1
	ISZ	PT1		/SAVE SUBSCRIPT
	LAC	SUBS
	DAC*	PT1
	ISZ	PT1		/SET PT1
	JMS	FINT
	FGET	FLTZER
	FPUT* PT1
	FXIT
	POPJ		/EXIT
////
GFND1	LAC	PT1		/FOUND SAME
	DAC*	(XRT		/TEST SUBSCRIPTS
	LAC*	XRT
	JMS	TWOS
	TAD	SUBS
	SZA!CLA
	JMP	GS4		/WRONG SUBSCRIPT
	ISZ	PT1		/SET POINTER TO DATA
	ISZ	PT1
	POPJ
	.EJECT
////
///IGNORE LEADING SPACES - "SPNOR"
SUBS=.
XSPNOR	0
	LAC	CHAR
	SAD	C240
	SKP
	JMP*	XSPNOR
	GETC
	JMP	XSPNOR+2
XTESTN	0		/RETURNS: .; OTHER; NUMBER - "TESTN"
MPER	LAW	-256
	TAD	CHAR
	SZA!CLA
	ISZ	XTESTN
	LAW	-260
	TAD	CHAR
	DAC	SORTCN	/SAVE VALUE
	SPA!CLA
	JMP	ZTESTN
	LAW	-271
	TAD	CHAR
	SPA!SNA!CLA
	ISZ	XTESTN	/IF A NUMBER
ZTESTN	LAC	SORTCN
	JMP*	XTESTN
/EXIT FROM A "DO" SUBROUTINE
RETURX	LAC	CFRS	/(PC) => 0
	TAD	C1	/TO PRETEND END OF TEXT
	DAC	PC
XPOPJ	LAC*	PDLXR	/RECURSIVE EXIT - "POPJ"
	DAC	T2
	CLA
	JMP*	T2
	.EJECT
/EVALUATE AN EXPRESSION WHICH
/TERMINATES WITH AN R-PAR,; OR C.R. AND
/LEAVE THE RESULT IN FLAC AND IN FLARG.
	GETC		/MOVE PAST EXTRA CHARACTER
EVAL	DZM	LASTOP	/EVAUATION CONTROLLER
	TESTC		/TEST CHARACTER AND IGNORE SPACES
	JMP	ETERM1	/TERMINATION
	JMP	ENUM	/NUMBER
	JMP	EFUN	/FUNCTION
	PUSHJ	GETVAR	/FIND OR CREATE VARIABLE;ALSO SET PT1.
OPNEXT	TESTC		/PT1=>ARG
	JMP	ETERMN	/T
	NOP		/N-ERROR IN FORMAT
	NOP		/F
	ERROR	17	/L - MISSING OPERATOR
/////
ETERM1	LAC CHAR
	SAD C275
	ERROR	17
	PUSHF	FLTZER	/INITIALIZE RESULT TO ZERO.
	POPF	FLARG
	LAC	FLARGP	/SET PT1.
	DAC	PT1
	LAC	M2		/TEST FOR UNARY OPERATIONS
	TAD	SORTCN
	SNA
	JMP	ETERM	/CREATE DUMMY FOR UNARY MINUS
	TAD	C1
	SNA!CLA
	JMP	ARGNXT	/IGNORE UNARY PLUS
	TAD	SORTCN	/TEST FOR NULL PARENS.
	TAD	M11
	SPA!CLA
	JMP	ELPAR	/MIGHT BE AN L-PAR.
ETERMN	TSTLPR
	SKP
	ERROR	18	/OPERATOR MISSING BEFORE PAREN
ETERM	LAC	SORTCN	/SET FROM "TESTC"-"SORTC"
	DAC	THISOP
	TAD	M11
	SMA!CLA		/END?
	DAC	THISOP	/"THISOP" EQUIV. TO END OF EXP.
ETERM2	LAC	THISOP	/COMPARE PRIORITIES
	JMS	TWOS
	TAD	LASTOP
	SPA!CLA
	JMP	EPAR	/CONTINUE
	TAD	LASTOP	/FIND OPERATION FROM TABLE
	TAD	OPTABL
	DAC	FLOP
	LAC*	FLOP
	DAC	FLOP
	LAC	LASTOP
	SNA!CLA		/TEST FOR END OF DATA INTO FLOATING AC.
	JMP .+3
	POPF	XX	/GET LAST DATA
FLAC1=.-1			/.AA
	JMS	FINT
FLOP	00		/(FLOPR I PT1)+-*/
	FPUT FLARG	/SAVE RESULT
	FXIT
	LAC	FLARGP
	DAC	PT1
	LAC	THISOP
	TAD	LASTOP	/=0?
	SNA!CLA
	POPJ		/EXIT "EVAL"
	POPA		/GET PRIOR OP
	DAC	LASTOP
	JMP	ETERM2	/COMPARE THIS OP
/////
EPAR	TSTLPR		/TEST FOR SUB-EXPRESSION
	SKP
	JMP	EPAR2	/GO EVALUATE EXPRESSION
	LAC	LASTOP	/CONTINUE READING THE EXPRESSION
	PUSHA		/SAVE "LASTOP".
	LAC	PT1
	DAC	.+2
	PUSHF	XX	/SAVE LAST ARGUMENT
	LAC	THISOP	/MORE TO COME
	DAC	LASTOP
ARGNXT	GETC		/READ 1ST CHAR OF AN ARG.
	TESTC		/DO SPECIAL CHECK
	JMP	ELPAR	/COULD BE LEFT PAREN
	JMP	ENUM	/N
	JMP	EFUN	/F
	JMP	OPNEXT-2	/L
/////
ENUM	PUSHF	XX	/TO PROCESS A NUMBER,SAVE AC
FLAC2=.-1			/.AA
	LAC	FLARGP	/SET POINTER AS FOR VARIABLE.
	DAC	PT1
	DZM	INSUB	/POINT TO 'GETC' AND USE CHAR
	CLA		/READ NEXT
	JMS	FLINTP	/READ TEXT NUMBER => (PT1)
	POPF	XX	/RESTORE THE AC
FLAC3=.-1			/.AA
	JMP	OPNEXT	/CONTINUE
/////
EFUN	GETC
	LAW	-3
	JMS	FETVAR		/GET FUNCTION NAME
	LAC	SORTCN	/SAVE 'SORTCN','LASTOP',AND 'EFOP'
	PUSHA
	LAC	LASTOP
	PUSHA
	LAC*	BUFSTX	/SAVE FUNCTION NAME
	PUSHA
	TSTLPR
	ERROR	19	/MUST BE FOLLOWED BY PARENS TO SET ARGUMENT
	PUSHJ	EVAL-1 	/YES
	POPA
	DAC	FUNAME		/SAVE FUNCTION NAME
	LAC	(FNTABF
	JMS	FUNCHK		/IS IT INTERNAL FUNCTION
	LAC	.NEWF
	JMS	FUNCHK		/IS IT EXTERNAL FUNCTION
	ERROR	20		/ILLEGAL FUNCTION NAME
FUNCHK	0			/DISPATCH ON FUNCTION NAME
	DAC	FUNPTR		/FUNCTION TABLE START
	LAC*	FUNPTR
	SMA
	JMP*	FUNCHK
	DAC	FUNCTR		/FUNCTION TABLE COUNT
FUNLOP	ISZ	FUNPTR		/POINTS TO NEXT NAME
	LAC	FUNAME
	SAD*	FUNPTR		/RIGHT FUNCTION?
	JMP	FUNFND		/YES - GO DISPATCH
	ISZ	FUNPTR		/NO - TRY NEXT
	ISZ	FUNCTR		/ANY MORE IN TABLE?
	JMP	FUNLOP		/YES
	JMP*	FUNCHK		/NO - RETURN
FUNFND	ISZ	FUNPTR		/TO FUNCTION ADDRESS
	JMP*	FUNPTR		/DISPATCH
/////
ELPAR	TSTLPR
	ERROR	21	/DOUBLE OPERATORS
EPAR2	LAC	SORTCN	/LEFT PARENS FOUND.
	PUSHA
	LAC	LASTOP	/SAVE DATA
	PUSHA
	PUSHJ	EVAL-1	/EVALUATE THE EXPRESSION
	RETURN
	.EJECT
/////
/SOME MINOR FUNCTIONS
XINT	JMS	FIX	/INTEGER PART
	RETURN
XSGN	JMS*	.AO	/TAKE SIGN*1 OF FLARG
	FLTONE
	LAC	FLARG+1
	SKP
XABS	GETSGN		/TAKE ABSOLUTE VALUE OF FLAC
	SPA!CLA		/SKIP TO CONTINUE
	JMS*	.BA	/NEGATE THE FLOATING AC
/CONTINUATION OF FUNCTION CALLS.
EFUN3	POPA		/RESTORE LAST OPERATION
	DAC	LASTOP
	JMS*	.CD	/NORMALIZE FUNCTION RETURN
	JMS*	.AP	/SAVE FUNCTION VALUE
	FLARG
	LAC	FLARGP	/SET POINTER
	DAC	PT1
	POPA		/GET LAST PAREN CODE.
	TAD	P3
	JMS	TWOS	/CHECK FOR PAREN MATCH.
	TAD	SORTCN	/(STILL SET FROM THE LAST "EVAL")
	SZA!CLA		/SKIP IF MATCH	
	ERROR	22	/PAREN ERROR
	GETC		/MOVE PAST R-PAR, AND RETURN TO OPNEX.
	JMP	OPNEXT	/FUNTION RETURN IS OK
LPRTST	0		/SKIP IF LEFT PAREN. - 'TSTLPR'
M11	LAW	-11
	TAD	SORTCN
	SMA!CLA
	JMP*	LPRTST
	LAW	-5
	TAD	SORTCN
	SMA!SZA!CLA
	ISZ	LPRTST
	JMP*	LPRTST
	.EJECT
/THE DELETE A LINE ROUTINE
DELETE	FINDLN	/SETS "THISLN" AND "LASTLN".
	POPJ		/ALREADY GONE
	ISZ	DEBGSW	/DISABLE TRACE
	GETC		/MEASURE LENGTH
	SAD	C215
	SKP!CLA!CMA
	JMP	.-3
	TAD	AXOUT	/SAVE LAST ADDRESS
	CMA
	TAD	THISLN
	DAC	CNTR	/LENGTH < 0
	LAC*	THISLN	/DISCONNECT
	DAC*	LASTLN
	LAC	CFRS	/START LIST AT TOP
DOK	DAC	T2		/EXAMINATION ADDRESS
	LAC*	T2	/GET THE NEXT ADDR.
	SNA		/TEST FOR END
	JMP	DONE	/YES-WRAP UP ALL.
	DAC	T1		/SAVE NEXT ADDRESS.
	LAC	THISLN	/COMPARE LINE POSITIONS
	CLL
	JMS	TWOS
	TAD	T1
	SZL!CLA		/SKIP IF THISLN > X
	TAD	CNTR	/CHANGE (X) TO ACCOUNT FOR
	TAD	T1		/GARBAGE COLLECTION.
	DAC*	T2
	LAC	T1		/GET NEXT
	JMP	DOK
	.EJECT
/////
/GARBAGE COLLECTION
DONE	CLA!CMA		/BACKUP L FOR XR
	TAD	THISLN
	DAC*	(XRT
	LAC	CNTR	/SETUP END OF HOSE
	CMA
	TAD	THISLN
	DAC*	(XRT2
	LAC	CNTR	/CORRECT END OF BUFFER POINTER.
	TAD	BUFR
	DAC	BUFR
	LAC*	(AXIN	/COMPUTE COUNT
	CMA
	TAD*	(XRT2
	DAC	T1
	LAC*	(AXIN
	TAD	CNTR
	DAC*	(AXIN
	LAC*	XRT2	/SIPHON LOWER PART.
	DAC*	XRT
	ISZ	T1
	JMP	.-3
	JMP	DELETE	/RESET 'LASTLN','THISLN', AND DATA FIELD.
/////
	.EJECT
ERASE	TESTC		/TEST THE SECOND WORD, IF ANY.
	JMP	ERVX	/ERASE VARIABLES
	JMP	ERL		/LINES OR GROUPS
	ERROR	23
	LAW	-11
	JMS	FETVAR
	SORTJX	ALLCM2
	ERROR	23	/BAD ARG FOR ERASE.
XSBEGN	LAC	ENDT	/ERASE ALL TEXT **
	DAC	BUFR
	DZM*	CFRS
	JMP	START	/POINTERS MAY BE DIFFERENT NOW.
//////
ERL	GETLN		/ERASE LINES.
	LAC	LINENO
	AND	P7600
	SNA
	ERROR	7
	LAC	BUFR	/PROTECT REST OF TEXT.
	DAC*	(AXIN
ERG	PUSHJ	DELETE	/EXTRACT ONE LINE
	ISZ	THISLN
	LAC	NAGSW
	SMA!CLA
	TAD*	THISLN	/(X-MEM)
	TSTGRP		/SKIP IF G(AC) = G(LINENO)
	JMP	START
	LAC*	THISLN	/(X-MEM)
	DAC	LINENO
	JMP	ERG
/////
ERVX	LAC	STARTV	/INIT VARIABLES MAY BE IN THE TEXT
	DAC	LASTV
	POPJ
	.EJECT
/ROUTINE CALLED VIA "FINDLN":
/SEARCH FOR A GIVEN LINE I.D. =[ "LINENO" ]
/1ST RETURN IF NOT FOUND,
/2AND IF FOUND.
/"THISLN" = FOUND LINE OR NEXT LARGER.
/"LASTLN" = LESSER AND/OR LAST.
/"TEXTP" IS SET
XFIND	0
	LAC	CFRS	/INITIALIZE POINTERS TO FIRST LINE
	DAC	LASTLN
FINDN	DAC	THISLN	/SAVE THIS ONE
	DAC*	(XRT2
	LAC	LINENO
	SPA		/MAX 99.99
	ERROR	24
	JMS	TWOS
	TAD*	XRT2	/LINENO=0 WILL ALSO BE FOUND
	SNA
	JMP	FEND2	/FOUND IT.
	SMA!CLA
	JMP	FEND3	/PAST IT.
	TAD	THISLN	/MOVE POINTERS
	DAC	LASTLN
	LAC*	THISLN
	SZA
	JMP	FINDN
	SKP
FEND2	ISZ	XFIND	/2ND EXIT = FOUND
FEND3	LAC	THISLN
	TAD	P2
	DAC	AXOUT	/SET "TEXTP".
	LAW	-1
	DAC	XCTX
	.IFUND	MULTI
	LAC DEBGSW
	TAD DMPSW
	SZA!CLA
	JMP* XFIND
	LAC SAVEOT
	SAD C215
	SKP
	SAD C375
	JMP .+3
	LAC C375
	PRINTC
	LAC IMBUFF+2
	SAD C215
	JMP .+3
	LAC C215
	JMS IMAGEW
	LAC C212
	JMS IMAGEW
	.ENDC
	JMP*	XFIND
UTRA	0		/UNPACK CHARACTER. - "GETC"
	JMS	GET1
UTE	SPA!CLA		/NORM & EXTEND
	TAD	C100	/300-337 & 340-376
	TAD	M137	/240-276 & 200-236
	TAD	CHAR
	SNA
	JMP	UTX		/"?" FOUND
	TAD	P337
UTQ	DAC	CHAR
	.IFUND	MULTI
	LAC	DEBGSW
	TAD	DMPSW
	SZA!CLA		/PRINT ONLY IF BOTH ARE ZERO.
	JMP	UTRAX
	LAC	SAVEOT
	SAD	C215
	SKP
	SAD	C375
	JMP	.+3
	LAC	C375
	PRINTC
	LAC CHAR
	JMS	IMAGEW
UTRAX	LAC	CHAR
	.ENDC
	JMP*	UTRA
//////
EXTR	JMS	GET1
	CMA
	JMP	UTE
///
UTX	LAC	DEBGSW	/TEST FOR TRACE-ENABLED
	SZA!CLA
	JMP	UTXP6
	TAD	DMPSW	/FLIP THE TRACE FLOP
	SNA!CLA
	TAD	C1
	DAC	DMPSW
	JMP	UTRA+1	/GET NEXT CHARACTER INSTEAD.
UTXP6	TAD	C277	/TRACE DISABLED = RETURN "?"
	JMP	UTQ
GET1	0		/UNPACK 6-BITS
	ISZ	XCTX		/STARTS=-1
	JMP	GENDX
	LAW	-3
	DAC	XCTX
	LAC*	AXOUT	/NEXT WORD
	ISZ	AXOUT
	DAC	GTEM
GENDX	LAC	GTEM
	RTL6
	DAC	GTEM
	RAL
	AND	C77
	DAC	CHAR	/SAVE
	SAD	C77
	JMP	EXTR	/EXTENDED
	LAW	-40
	TAD	CHAR
	JMP*	GET1
	.EJECT
XENDLN	0	/TERMINATE THE BUFFERED LINE - "ENDLN"
	LAC*	LASTLN	/SAVE OLD POINTER
	DAC*	BUFR
	LAC	BUFR
	DAC*	LASTLN
	LAC	ADD
	SZA
	DAC*	AXIN
	LAC*	(AXIN
	TAD	C1
	DAC	BUFR
	JMP*	XENDLN
XPRNT	0	/PRINT A LINE NUMBER - "PRNTLN"
	LAC	LINENO
	RTR
	RTR
	RTR
	RAR
	JMS	PRNT
	LAC	PER
	PRINTC
	LAC	LINENO
	JMS	PRNT
	JMP*	XPRNT
//////
PRNT	0	/PRINT TWO DIGITS
	AND	P177
	DAC	VAL
	LAC	C260
	DAC	BOX
	LAC	VAL
	JMP	.+3
	ISZ	BOX
XYZ	DAC	VAL
	TAD	M12
	SMA
	JMP	XYZ-1
	LAC	BOX
	PRINTC
	LAC	VAL
	TAD	C260
	PRINTC
	JMP*	PRNT
	.EJECT
	.IFUND	MULTI
IMBUFF	2003;	0;	0;	-1
INBUF	.BLOCK 60
	.ASCII	<15>
OUTBUF	1000
	.BLOCK 57
	.ASCII	<15>
	.ENDC
IMAGEW	0
	DAC*	IMBUFP
IMBF01=.+2
WCAL03	.WRITE	-3,3,IMBUFF,3
	.IFUND	MULTI
	.WAIT	-3
	.ENDC
	.IFDEF MULTI
	JMS IOBUSY
	.ENDC
	JMP*	IMAGEW
IMAGER	0
IMBF02=.+2
RCAL03	.READ	-2,3,IMBUFF,3
	.IFUND MULTI
	.WAIT	-2
	.ENDC
	.IFDEF MULTI
	JMS IOBUSY
	.ENDC
	LAC*	IMBUFP
	AND	P177
	XOR	C200
	JMP*	IMAGER
	.EJECT
/////
VAL=.
XI33	0		/"READC"
	LAC	ENDCR	/WAS LAST INPUT CR
	SAD	C215
	SKP		/YES
	JMP	XI33NX	/NO - GO GET NEXT FROM BUFFER
INBF01=.+2
RCAL01	.READ	-2,2,INBUF,48
	.IFUND MULTI
RCAL02	.WAIT	-2
	.ENDC
	.IFDEF MULTI
	JMS IOBUSY
	.ENDC
	LAC*	INBF01
	AND	P17
	SAD	(5	/EOF?
	JMP	RDEOM	/YES
	SAD	(6	/EOM?
	JMP	RDEOM	/YES
	LAC	INBUFP
	JMS	.GETI	/UNPACK INITIALIZATION
XI33NX	JMS	.GET	/UNPACK CHARACTER
	XOR	C200
	SAD	C200	/IGNORE NULL
	JMP	XI33NX
	SAD	C377	/IGNORE RUBOUTS
	JMP	XI33NX
	SAD	C212	/IGNORE LINE-FEED
	JMP	XI33NX
	SAD	C375	/USE CR FOR ESC
	LAC	C215
	DAC	ENDCR
	DAC	CHAR
	JMP*	XI33
	.EJECT
XOUTL	0		/"PRINTC"	
	SNA		/USE AC OR CHAR
	LAC	CHAR
	DAC	SAVEOT	/SAVE CHAR
	ISZ	PUTCNT	/READY TO BUMP WPC?
	JMP	XOUTLQ		/NO
	LAC*	OTBF01	/YES
	SAD	(31000	/HAS THE BUFFER OVERFLOWED?
	JMP	XOUTLI	/YES - IGNORE CHAR
	TAD	(1000	/NO - UPDATE WPC
	DAC*	OTBF01
	LAW	-5
	DAC	PUTCNT	/RESET COUNT
XOUTLQ	LAC*	OTBF01
	SAD	(31000
	JMP	XOUTLI	/BUFFER OVERFLOWED - DONT SAVE CHAR
	LAC	SAVEOT	/GET CHAR
	JMS	.PUT
XOUTLI	LAC	SAVEOT
	SAD	C215	/OUTPUT BUFFER ON CR OR ESC
	JMP	XOUTLX
	SAD	C375
	JMP	XOUTLX
	JMP	XOUTLZ
XOUTLX=.
OTBF01=.+2
WCAL01	.WRITE	-3,2,OUTBUF,48
	LAC	OTBUFP
	JMS	.PUTI
	LAW	-1
	DAC	PUTCNT
	.IFUND	MULTI
WCAL02	.WAIT	-3
	.ENDC
	.IFDEF MULTI
	JMS	IOBUSY
	.ENDC
	LAC	(1000
	DAC*	OTBF01
XOUTLZ	LAC	CHAR
	JMP*	XOUTL
	.EJECT
	.DEC
	.REPT 37
	ISZ ERR2CT
	.OCT
ERR2=.
ERRPCX	LAC C277
	PRINTC
	LAC ERR2CT
	JMS PRNT
	DZM ERR2CT		/CLEAR FOR NEXT ERROR
	ISZ	PC	/PRINT LINENO IF INDIRECT COMMAND
	LAC*	PC
	SNA
	JMP ERR2T
	DAC LINENO	/SAVE FOR PRINTING
	LAC C240
	PRINTC
	PRNTLN
ERR2T	LAC	CCR
	PRINTC
	JMP	RECVR
FUNERR	DAC	ERR2CT		/SAVE TWO DIGIT ERROR CODE
	LAC	C277
	PRINTC			/PRINT DOUBLE ?
	JMP	ERRPCX
	.IFUND MULTI
RECOVR	LAC	CCR
	PRINTC
	.ENDC
	.IFDEF	MULTI
RECOVR	DZM*	CTLP
	LAC CCR
	PRINTC
	JMS	IOBUSY
	.ENDC
WCAL04	.WRITE	-3,2,FOCAL9,40
RECVR=.
	.IFDEF MULTI
	JMS IOBUSY
	.ENDC
	LAC OTBUFP
	JMS .PUTI
	LAC C215
	DAC ENDCR
	LAW -1
	DAC PUTCNT
	LAC (1000
	DAC* OTBF01
	LAC	TTIN	/RESET CAL FOR NORMAL INPUT
	JMS	SETRCL
	LAC	TTOUT
	JMS	SETWCL
	JMP	STARTZ
	.EJECT
/SET WRITE CAL'S SUBROUTINE
SETWCL	0
	.IFUND	MULTI
	DAC	WCAL02	/.WAIT
	.ENDC
	XOR	(1000
	.IFDEF	MULTI
	DAC*	BWAIT	/PROPER .WAITR
	.ENDC
	DAC	LBOUT1	/.INIT
	TAD	(1000
	DAC	WCAL01	/.WRITE
	JMP*	SETWCL
/SET READ CAL'S SUBROUTINE
SETRCL	0
	.IFUND	MULTI
	DAC	RCAL02	/.WAIT
	XOR	(2000
	.ENDC
	.IFDEF	MULTI
	XOR	(1000
	DAC*	BWAIT	/PROPER .WAITR
	TAD	(1000
	.ENDC
	DAC	RCAL01	/.READ
	TAD	(1000
	DAC	LBIN1A
	JMP*	SETRCL
/
	.EJECT
PACBUF	0		/PACK A CHARACTER - "PACKC"
	LAW	-277
	TAD	CHAR
	SNA		/CHANGE 277 TO 337
	TAD	P40
	TAD	M100
	SNA		/TEST FOR RUBOUT.
	HLT
	TAD	C377
	DAC	T2		/SAVE INPUT ITEM
				/SO THAT QUESTION DOESN'T MAKE
	AND	C140	/CHAR LOOK LIKE A LEFT-ARROW
	TAD	M140
	SZA		/DATA WORD.
	TAD	C140
	SNA!CLA
	JMP	ESCA	/340-377 AND 200-237
TR1	LAC	T2		/240-337
	AND	C77
	SZA	 	/IGNORE 300
	JMS	PCK1
	LAC	T2
	SAD	C215
	JMP	.+3
PACBXT	LAC	CHAR
	JMP*	PACBUF
	LAC	XCTIN
	SNA!CLA
	JMP	PACBXT
	JMS	PCK1
	JMP	.-4
//////
ESCA	LAC	C77
	JMS	PCK1
	JMP	TR1
	.EJECT
PCK1	0
	DAC	TEMPK
	LAC	XCTIN	/=0 TO START
	TAD	(JMP PCKTB
	DAC	.+2
	LAC	ADD
	XX
PCKTB	JMP	ROT-1
	JMP	ROT
	RTL6
	DZM XCTIN
	TAD	TEMPK
	DAC*	AXIN
	DZM	ADD		/CLEAR PACKING WORD
	LAC*	(PDLXR	/CHECK FOR OVERFLOW (TAD P7600) TO PROTECT (X-MEM)
	CMA!CLL
	TAD	C1
	TAD	P13		/RESERVATIONS
	TAD*	(AXIN
	SNL!CLA
	JMP*	PCK1
	ERROR	16	/FULL BUFFER
/////
	CLA
ROT	RTL6
	TAD	TEMPK
	DAC	ADD
	ISZ	XCTIN
	JMP*	PCK1
	.EJECT
TDUMP	LAC	FRSTCV	/INIT POINTER FOR SYMBOL DUMP.
	ISZ	DMPSW	/TURN OFF THE TRACE FOR EXIT
	DAC	PT1
	SAD	LASTCV
	JMS	TDUMPC
	SAD	LASTV	/TEST FOR END OF LIST.
	POPJ
	LAC*	PT1
	DAC	OP+1	/(DCA I XOP)-FOR(X-MEM)
	LAC	OP
	TAD	C1
	DAC	AXOUT
	LAW	-1
	DAC	XCTX
	LAW	-4
	JMS	TDUMPX
	ISZ	PT1
	LAC*	PT1	/READ SUBSCRIPT TO 99
	JMS	PRNT
	LAW	-2
	JMS	TDUMPX
	ISZ	PT1
	JMS*	.AO	/PICK UP VALUE
	PT1+400000
	JMS	FLOUTP	/PRINT VALUE
	LAC	C215
	PRINTC
	LAC	GINC
	TAD	M2
	TAD	PT1
	JMP	TDUMP+2
///
TDUMPX	0
	DAC	T1
	GETC
	PRINTC
	ISZ	T1
	JMP	.-3
	JMP*	TDUMPX
TDUMPC	0
	LAC	C255
	PRINTC
	LAC	C215
	PRINTC
	LAC	PT1
	JMP*	TDUMPC
	.EJECT
///
XRAN	LAC*	RANPT	/RANDOM NUMBER GENERATOR.
	ISZ	RANPT
	RAL
	TAD	RANPT
	TAD*	PT1
	RAL
	DAC* .AB
	TAD*	RANPT
	DAC* .AC
	DZM* .AA
	LAC	RANPT
	SAD*	(.SCOM
	DZM	RANPT
	RETURN
/TWOS COMPLEMENT - CIA
TWOS	0
	CMA
	TAD	C1
	JMP*	TWOS
	.EJECT
	.IFUND	MULTI
COMEIN=.
BEGIN	LAC*	(.SCOM+3
	DAC	BOTTOM
	LAC*	(.SCOM+2
	DAC	BUFSTX
	DAC	FILE01
	DAC	FILE02
	DAC	FILE03
	TAD	(3
	DAC	ENDT
	DAC	FRSTCV
	DAC	LASTCV
	DAC	LASTV
	LAC	FILE01
	TAD	(2
	DAC	FLAC1
	LAC	FILEXT
	DAC*	FLAC1
	.INIT -3,0,RECOVR
	.WRITE	-3,2,FOCAL9,40
	.ENDC
	.IFDEF	MULTI
BEGIN=.
	.ENDC
	LAC .AA
	DAC FLAC1
	DAC FLAC2
	DAC FLAC3
	.IFUND	MULTI
	LAC (OUTBUF+2
	JMS	.PUTI
	JMP	XSBEGN
BUFFER=COMEIN+70
COMOUT=COMEIN+110
	.LOC	COMOUT
	215		/STOPPER
	.ENDC
	.IFDEF	MULTI
	DAC	FLAC14
	TAD	(1
	DAC	FLAC15
	TAD	(1
	DAC	FLAC16
	JMP	MSTART
	.ENDC
	.EJECT
/LIBRARY COMMAND FORMAT:
/	LIBRARY IN FILE
/	LIBRARY OUT FILE
/	LIBRARY WRITE "ANY COMMAND
/	LIBRARY WRITE ALL
/	LIBRARY WRITE XX.00
/	LIBRARY WRITE XX.YY
/	LIBRARY KILL
/	LIBRARY CLOSE
/
LIBRAR	SPNOR		/IGNORE SPACES
	SAD	C215	/IGNORE COMMAND IF CR
	POPJ
	SAD	C273	/IGNORE IF;
	POPJ
	LAW	-11
	JMS	FETVAR
	SORTC	GLIST
	SKP
	ERROR	32
	SORTJX	LIBCMD
	ERROR	32	/BAD LIBR CMD ARG
/
LBIN	JMS	LBFILE	/GET FILE NAME
	LAC	BLKIN	/SETUP INPUT CAL'S
	DAC	LIBRSW	/SIGN BIT 0
	DAC	LBIN01
	DAC	LBIN02
	DAC	LBIN03
	JMS	SETRCL
	.IFDEF	MULTI
	JMS	IOBUSY
	.ENDC
LBIN01	.INIT 0,0,RECOVR
	.IFDEF	MULTI
	JMS	IOBUSY
	.ENDC
	LAC	FILE03
	AND	(77777
	DAC	FILE03
FILE03=.+2
LBIN1A	.FSTAT	0,XX
	DAC	LBFILE
	LAC	FILE03
	AND	(700000
	SNA
	JMP	.+4
	LAC	LBFILE
	SNA
	ERROR	34
	.IFDEF MULTI
	JMS IOBUSY
	.ENDC
FILE01=.+2
LBIN02	.SEEK 0,XX
	.IFDEF	MULTI
	JMS	IOBUSY
	.ENDC
	LAC	CFRSX
	DAC	PC
LBINLP	LAC	CHAR
	SAD	C215
	POPJ		/ALL DONE
	SAD	C273
	JMP	PROCES	/MORE IN COME IN
	GETC
	JMP	LBINLP+1
RDEOM	JMS	LBIEND	/END LIBR IF OPEN
	LAC	C215
	JMP	XI33NX+2
HSPX	JMS	LBIEND	/END LIBR IF OPEN
	JMP	LBINLP
/
LBOUT	JMS	LBFILE	/GET FILE NAME
	LAC	BLKOUT	/SETUP OUTPUT CAL'S
	DAC	LBOUT2
	DAC	LBOUT3
	DAC	LBOUT4
	JMS	SETWCL
	.IFDEF	MULTI
	JMS	IOBUSY
	.ENDC
LBOUT1	.INIT 0,0,RECOVR
	.IFDEF	MULTI
	JMS	IOBUSY
	.ENDC
FILE02=.+2
LBOUT2	.ENTER 0,XX
	.IFDEF	MULTI
	JMS	IOBUSY
	.ENDC
	LAW -1
	DAC LIBRSW
	JMP LBINLP
/
LBCLOS	LAC	LIBRSW
	SMA
	ERROR	35
	.IFDEF	MULTI
	JMS	IOBUSY
	.ENDC
LBOUT3	.CLOSE	0
	JMP	LBOUTZ
LBKILL	LAC	LIBRSW
	SMA
	ERROR	35
	.IFDEF	MULTI
	JMS	IOBUSY
	.ENDC
LBOUT4	.INIT	0,0,RECOVR
LBOUTZ	DZM	LIBRSW	/CLEAR LIBR SWITCH
	LAC	TTOUT	/RESET WRITE CAL'S
	JMS	SETWCL
	JMP	LBINLP	/GO FINISH CMD
/
LBWRIT	LAC	LIBRSW
	SMA
	ERROR	35
	JMP	WRITE
LBTEXT	LAC	LIBRSW
	SMA
	ERROR	8
LBTEXX	GETC		/PUT COMMAND INTO
	PRINTC		/OUTPUT BUFFER
	SAD	C215	/ALL DONE?
	POPJ		/YES
	JMP	LBTEXX	/NO-MORE
/
LBFILE	0
	LAC	FILE03
	TAD	(2
	DAC	LBIEND
	LAC	FILEXT	/SETUP 'FCL' AS EXTENSION
	DAC*	LBIEND
	LAC CHAR
	SAD C240
	SKP
	JMP .+3
	GETC
	JMP .-4
	LAW	-6
	JMS	FETVAR	/GET FILE NAME
	LAC	CHAR
	SAD	C215	/CR
	SKP
	SAD	C273	/;
	JMP*	LBFILE
	ERROR	33
/
LBIEND	0
	LAC	TTIN	/RESTORE INPUT
	JMS	SETRCL
	LAC	LIBRSW	/IF LIBRARY OPEN,
	SNA		/CLOSE IT
	JMP*	LBIEND
LBIN03	.CLOSE	0
	DZM	LIBRSW	/CLEAR SWITCH
	JMP*	LBIEND
/
	.EJECT
/FLOATING POINT ARITHMETIC INTERPRETER FOR FOCAL
/FLOATING POINT PACKAGE - EXPONENTIAL
FEXP	GETSGN
	SMA!CLA
	JMP	.+3
	JMS*	.BA
	CLA!CMA
	DAC	SIGN2	/C(SIGN)=-1 IF X<0
	JMS*	.AP	/PUT
	FLARG
	JMS*	DEXP
	JMP	.+2
	FLARG
	ISZ	SIGN2
	RETURN
	JMS	FINT
	FPUT X
	FGET FLTONE
	FDIV X
	FEXT
	RETURN
/FLOATING POINT ARC TANGENT
ARTN	JMS*	DATAN
	JMP	.+2
	FLARG
	RETURN
/FLOATING LOGARITHM
FLOG	GETSGN
	SNA
	ERROR	25	/ZERO ARGUEMENT FOR LOG
	SPA!CLA
	JMS*	.BA	/NEGATIVE ARGUMENT
	JMS*	.AP	/PUT
	FLARG
	JMS*	DLOG
	JMP	.+2
	FLARG
	RETURN
/FLOATING POINT SINE AND COSINE
FCOS	JMS*	DCOS
	JMP	.+2
	FLARG
	RETURN
FSIN	JMS*	DSIN
	JMP	.+2
	FLARG
	RETURN
	.EJECT
/INPUT/OUTPUT ROUTINES FOR THE FOCAL
/FLOATING POINT PACKAGE.
/IN THE COMMENTS BELOW:-
/ F = NUMBER OF DIGITS TO BE OUTPUT	=FISW
/ D = NUMBER OF DECIMAL PLACES	=DECP
/ E = DECIMAL EXPONENT		=BEXP
/ P = NUMBER OF PLACES REMAINING TO BE
/ 	PRINTED BEFORE DECIMAL POINT
TGO	0
	DAC	SCOUNT	/SAVE NUMBER OF DIGITS AVAILABLE - *SET COUNTS*
	 LAC	FISW
	SNA		/FLOATING OUTPUT?
	JMP	R6		/YES, ROUND OFF TO 6 PLACES
	JMS TWOS	/NO, COMPUTE FIELD SIZES
	TAD	DECP
	SPA		/ F-D > 0 ?
	JMP	.+5		/YES
	CLA!CMA		/NO,
	TAD	FISW
	DAC	DECP	/MAKE D = F-1
	CLA!CMA
	TAD	BEXP	/COMPARE DECIMAL EXPONENT
	SMA		/ F-D > E?
	CLA		/NO, ROUND OFF TO .F PLACES
	TAD	FISW	/YES
	SPA		/ D+E < 0 ?	
	JMP	FPRNT-1	/YES, NO ROUNDING NEEDED, GO TO PRINT
	TAD	MD		/NO, ROUND TO D+E PLACES,
	SMA		/TO A MAXIMUM OF D PLACES
	CLA
R6	TAD	RND2	/ *ROUND UP *
	DAC	TEMPO	/SAVE NUMBER+1 OF PLACES TO ROUND TO
	TAD	BUFST	/SET UP BUFFER ADDRESS AT WHICH
	DAC	PLCE	/ROUNDING OFF SHOULD START
	LAC	TEMPO
	JMS TWOS		/SET UP COUNT OF MAXIMUM NUMBER
	DAC	TEMPO	/OF CARRIES ALLOWABLE
	LAC	(5		/LITTLE EXTRA ON FIRST DIGIT.
RET	ISZ*	PLCE	/ADD 1 TO DIGIT AT CURRENT POSITION
	TAD*	PLCE
	TAD	M12
	SPA!CLA		/CARRY REQUIRED?
	JMP	FPRNT	/NO, GO TO OUTPUT
	DAC*	PLCE	/YES, MAKE CURRENT DIGIT ZERO
	ISZ	TEMPO	/BEGINNING OF BUFFER REACHED?
	JMP	DECR	/NO, DECREMENT BUFFER ADDRESS AND REPEAT
	ISZ*	PLCE	/YES, SET MANTISSA TO 0.1
	ISZ	BEXP	/COMPENSATE BY INCREMENTING EXPONENT
FPRNT	LAC	FISW	/AUTO-INDEX REGISTER ALREADY SET. - *PRINT*
	SNA		/ F = 0 ?
	JMP	FLOPX	/YES, OUTPUT AS FLOATING NUMBER
	JMS TWOS		/NO,
	DAC	FCOUNT	/SET UP COUNT TO PRINT F PLACES
	TAD	BEXP
	SMA!SZA		/ E > F ?
	JMP	XXX		/YES, PRINT X'S
	TAD	DECP
	SMA		/ E < F-D ?
	CLA		/NO, TAKE P = E
	JMS TWOS		/YES, TAKE P = F-D
	TAD	BEXP
	JMS TWOS
	DAC	TEMPO	/SET UP MINUS P
BACK	LAC	BEXP	/PRINT DD.DDD
	TAD	TEMPO
	SNA!CLA		/ P = E ?
	JMP	DIG		/YES, PRINT DIGIT
	TAD	TEMPO	/NO,
	TAD	C1
	SPA!CLA		/ P > 1 ?
	LAW	240-260	/YES, TAKE SPACE; OTHERWISE ZERO
IN	JMS	OUTA	/PRINT CHARACTER
	ISZ	TEMPO	/P CHARACTERS PRINTED?
	JMP	BACK	/NO
	LAC	PER	/YES,
	PRINTC		/PRINT DECIMAL POINT
	JMP	BACK
/////
DECR	CLA!CMA
	TAD	PLCE
	DAC	PLCE
	CLA
	JMP	RET
/////
OUTA	0
	JMS	OUTDG	/PRINT CHARACTER
	ISZ	FCOUNT	/F CHARACTERS PRINTED?
	JMP*	OUTA	/NO, RETURN
	JMP*	TGO	/YES, NUMBER FINSHED
/////
DIG	CLA!CMA
	TAD	BEXP	/REDUCE E, BY 1
	DAC	BEXP
	ISZ	SCOUNT	/ARE ALL SIG. FIGS. USED?
	JMP	DIGP5		/NO
	CLA!CMA		/YES,
	DAC	SCOUNT	/RESET COUNT TO -1
	CLA
	JMP	IN		/AND LEAVE C(AC) = 0
DIGP5	LAC*	FLTXR	/TAKE NEXT DIGIT FROM BUFFER
	JMP	IN
////
/DO FLOATING OUTPUT
XXX	LAC	FISW
	SKP
FLOPX	LAC	DECP
	JMS	TWOS
	SNA
MD	LAW	-DIGITS		/SET COUNT TO PRINT
	DAC	FCOUNT	/6 DIGITS AFTER DECIMAL POINT
	CLA
	JMS	OUTDG	/PRINT "0"
	LAC	PER
	PRINTC		/PRINT "."
	ISZ	TGO		/SEND RETURN
	LAC*	FLTXR	/TAKE NEXT DIGIT FROM BUFFER
	JMS	OUTA	/PRINT IT
	ISZ	SCOUNT	/TEST FOR END OF INPUT
	JMP	.-3		/AND REPEAT
	CLA!CMA
	DAC	SCOUNT	/OUTPUT EXTRA ZEROS.
	CLA
	JMP	.-6
	.EJECT
/DOUBLE PRECISION DECIMAL-BINARY
/INPUT AND CONVERSION FOR + OR - XXX...
DECONV	0
	DZM* .AB
	DZM* .AC
	DZM	OVER2
	DZM	DNUMBR
	CLA!CMA
	DAC	ISIGN
	LAW	-253
	TAD	CHAR
	SNA
	JMP	.+5		/+SIGN; GET NEXT
	TAD	M2		/CHECK - SIGN
	SZA!CLA
	JMP	.+3
	DAC	ISIGN
	JMS	INPUT	/GET NEXT
	SAD	C240
	JMP	.-4
	JMS	DECON
	JMP*	DECONV
/////
DECON	0
	SAD	C305	/TEST LEAD CHARACTER FOR TERMINATOR
	JMP*	DECON
	TESTN
	JMP*	DECON
	JMP	DTST
DSAVE	DAC	DIGIT	/YES - SORTCN IN AC
	ISZ	DNUMBR	/INDEX NUMBER OF DIGITS
	JMS	MULT10	/REMAIN MUST =0 SINCE OVERFLOW IS CHECKED
	SZA
	ERROR	26	/INPUT-OVERFLOW ERROR
	JMS	INPUT
	JMP	DECON+1	/CONTINUE
MINUSA=.
DTST	LAW	-301
	TAD	CHAR
	SPA!CLA
	JMP*	DECON
	LAW	-332
	TAD	CHAR
	SMA!CLA
	JMP*	DECON
	LAC	CHAR
	AND	C77
	JMP	DSAVE
/////
MULT10	0	/ROUTINE TO MULTIPLY
	LAC	OVER2	/FROM TAD
	DAC	OTEMP
	LAC*	.AC	/DOUBLE PRECISION WORD
	DAC	LTEMP	/BY TEN (DECIMAL)
	LAC*	.AB	/REMAIN=REMAINDER
	DAC	HTEMP
	DZM	REMAIN
	JMS	MULT2	/CALL SUBROUTINE TO
	JMS	MULT2	/MULTIPLY BY TWO
	JMS	DUBLAD	/CALL DOUBLE ADD
	JMS	MULT2
	LAC	DIGIT	/ADD LAST DIGIT RECEIVED
	DAC	OTEMP
	DZM	LTEMP
	DZM	HTEMP
	JMS	DUBLAD
	LAC	REMAIN	/EXIT WITH REMAINDER
	JMP*	MULT10	/IN AC
/////
MULT2	0	/MULTIPLY OVER2, LORD, HORD BY 2
	LAC	OVER2
	CLL!RAL
	DAC	OVER2
	LAC* .AC
	RAL
	DAC* .AC
	LAC* .AB
	RAL
	DAC* .AB
	LAC	REMAIN
	RAL
	DAC	REMAIN
	JMP*	MULT2
DUBLAD	0	/TRIPLE PRECISION ADDITION
	CLA!CLL
	LAC	OVER2
	TAD	OVER1
	DAC	OVER2
	CLA!RAL
	TAD* .AC
	TAD	AC1L
	DAC* .AC
	CLA!RAL
	TAD* .AB
	TAD	AC1H
	DAC* .AB
	CLA!RAL
	TAD	REMAIN
	DAC	REMAIN
	JMP*	DUBLAD
/////
/INPUT FROM TEXT OR KEYBOARD;
INPUT	0		/INPUT A CHARACTER
	LAC	INSUB	/NON-ZERO FOR KEYBOARD
	SZA!CLA
	JMP	.+3
	GETC
	JMP*	INPUT
	READC
	JMP*	INPUT
	.EJECT
/FLOATING OUTPUT CONVERSION ROUTINE
FLOUTP	0
	LAC*	.AB	/NUMBER>0??
	SMA!CLA
	LAW	240-255		/PRINT DASH OR SPACE
	TAD	SMIN
	PRINTC
	LAC*	.AB		/TAKE ABSOLUTE VALUE
	SPA!CLA
	JMS*	.BA
	CLA!CMA		/SUBTRACT 1 FROM BINARY EXPONENT
	TAD*	.AA		/COMPENSATE AT FGO4
	DAC*	.AA
	DZM	BEXP	/INITIALIZE DECIMAL EXPONENT
FGO2	LAC* .AA		/IS -4<EXPONENT<-1?
	SMA
	JMP	FGO3
	TAD	TEN
	SMA!CLA
	JMP	FGO4
	JMS*	.AS	/MULTIPLY
	TEN
	CLA!CMA
FGO3M2	TAD	BEXP
	DAC	BEXP
	JMP	FGO2
FGO3	JMS*	.AT	/DIVIDE
	TEN
	LAC	C1
	JMP	FGO3M2
/////
FGO4	DZM	DIGIT	/MULTIPLY BY TWO
	JMS	MULT2	/I.E.SHIFT LEFT
	LAC	BUFST	/INIT BUFFER POINTER
	DAC*	(FLTXR
	LAC* .AA
	DAC OUTDG	/TEMP COUNT
	JMS	MULT10	/MULTIPLY BY TEN
	JMP	FGO5
FGO5A	CLL!RAR
	DAC	TGO	/TEMP
	LAC* .AB
	RAR
	DAC* .AB
	LAC* .AC
	RAR
	DAC* .AC
	LAC	OVER2
	RAR
	DAC	OVER2
	LAC	TGO	/TEMP
FGO5	ISZ	OUTDG	/TEMP COUNT
	JMP	FGO5A
	SNA		/IS FIRST DIGIT A ZERO
	JMP	FGO7	/YES, IGNORE
	DAC*	FLTXR	/MULTIPLICATIONS YIELD
FGO6	LAC	DCOUNT
	DAC* .AA
	JMS	MULT10	/IE. .672X10=6+.72.. ETC
	DAC*	FLTXR
	ISZ* .AA		/ALL DIGITS OUTPUT??
	JMP	.-3		/NO: CONTINUE
	LAC	BUFST	/INIT BUFFER POINTER
	DAC*	(FLTXR
M12=.
DCOUNT	LAW	-DIGITS-1
	JMS	TGO	/OUTPUT MANTISSA AND EXPONENT
	JMP*	FLOUTP
	LAC	C305
	PRINTC
/OUTPUT THE EXPONENT
	LAC	BEXP	/TAKE ABSOLUTE VALUE OF EXPONENT
	SPA
	JMS	TWOS
	DAC* .AA
	LAC	BEXP	/PRINT SIGN
	SMA!CLA
	LAW	253-255
	TAD	SMIN
	PRINTC
	DZM* .AB		/CLEAR COUNT
	LAC* .AA
	ISZ* .AB
	TAD	M144
	SMA
	JMP	.-3
	TAD	C144
	DAC* .AA		/SAVE TENS AND UNITS
	CLA!CMA		/OUTPUT HUNDREDS
	TAD* .AB
	SZA		/UNLESS ZERO
	JMS	OUTDG
	LAC* .AA		/PRINT TWO DIGITS
	JMS	PRNT
	JMP*	FLOUTP
FGO7	CLA!CMA		/IGNORE FIRST DIGIT
	TAD	BEXP	/SUBTRACT 1 FROM
	DAC	BEXP	/DECIMAL EXPONENT
	LAC* .AB
	SNA		/IS MANTISSA ZERO?
	TAD* .AC
	SNA!CLA
	DAC	BEXP	/YES:EXP=0
	JMP	FGO6
/////
OUTDG	0	/OUTPUT ONE DIGIT
	TAD	C260
	PRINTC
	JMP*	OUTDG
	.EJECT
/FLOATING POINT INPUT
FLINTP	0		/IF C(AC) = 0, USE CHAR
	SZA!CLA		/IF C(AC) NON-ZERO , GET NEXT
	JMS	INPUT	/GET FIRST CHARACTER
	SAD C240		/IGNORE LEADING SPACES
	JMP	.-2
	JMS	DECONV	/READ FIRST DIGIT GROUP
	LAC	CHAR
	TAD	MPER
	SZA!CLA		/ENDED BY PERIOD?
	JMP	FIGO1
	JMS	INPUT	/YES, READ 2AND GROUP
	DZM	DNUMBR
	JMS	DECON
	LAC	DNUMBR	/NUMBER OF DIGITS IN SEXP
	JMS	TWOS	/NO
FIGO1	DAC	SEXP
	LAC* .AB
	SZA
	ERROR	27
	LAC* .AC
	DAC* .AB
	LAC OVER2
	DAC* .AC
	LAC	P43
	DAC* .AA
	JMS*	.CD	/NORMALIZE FIRST
	ISZ	ISIGN	/SKIP IF POSITIVE
	JMS*	.BA
	JMS*	.AP
	PT1+400000	/SAVE NUMBER
	LAW	-305
	TAD	CHAR
	SZA!CLA		/"E" READ IN?
	JMP	ENDFIX	/NO
	JMS	INPUT
	JMS	DECONV	/YES - CONVERT DECIMAL EXPONENT
	LAC	OVER2	/DECIMAL POINT IS
	ISZ	ISIGN
	JMS	TWOS
	TAD	SEXP	/C(SEXP)PLACES TO RIGHT
	DAC	SEXP	/OF LAST DIGIT
/END OF FLOATING POINT INPUT
/COMPENSATE FOR DECIMAL EXPONENTS
ENDFI	JMS*	.AO	/RESTORE MANTISSA
	PT1+400000
ENDFIX	LAC	SEXP	/TEST DECIMAL EXPONENT
	SNA
	JMP*	FLINTP
	SMA!CLA
	JMP	FIGO4
	JMS	FINT		/. IS TO THE LEFT:
	FDIV	TEN	/TIMES .1000
	FPUT*	 PT1
	FEXT
	LAC	C1
	JMP	FIGO4X
FIGO4	JMS FINT		/. IS TO THE RIGHT:
	FMPY TEN	/MULTIPLY BY 10
	FPUT*	 PT1
	FEXT
	CLA!CMA
FIGO4X	TAD	SEXP
	DAC	SEXP
	JMP	ENDFIX
	.EJECT
/BASIC FLOATING-POINT INTERPRETER.
FINT=.
FPNT	0
	LAC*	FPNT	/GET NEXT INSTRUCTION
	ISZ FPNT
	SNA
	JMP*	FPNT
	DAC	JUMP
	AND	MASK7	/GET 13 BIT ADDRESS
	DAC	ADDR
	LAC FPNT
	AND (60000
	XOR ADDR
	DAC ADDR
	LAC	INDRCT	/INDIRECT BIT=1?
	AND	JUMP
	SNA!CLA
	JMP	LOOP01	/NO-GO ON
	LAC*	ADDR	/YES ,DEFER ,W/O AUTO-INDEX
	DAC	ADDR
LOOP01	LAC	ADDR
	AND	MASK7
	SNA
	JMP	FNULL
	LAC	ADDR
	DAC	JUMP2
	LAC	CEX1	/SAVE FLOATING ARGUEMENT
	DAC*	(FLTXR
	LAC	MFLT
	DAC	CNTR
	LAC*	JUMP2
	DAC*	FLTXR
	ISZ	JUMP2
	ISZ	CNTR
	JMP	.-4
FNULL	DZM	OVER1
	LAC	JUMP	/GET COMMAND
	RTL
	RTL
	AND	C7		/GET BITS 0-2, IE OPCODE
	TAD	TABLE	/LOOKUP IN TABLE
	DAC	.+2
	LAC ADDR
	XX	/GO THERE
	.EJECT
/////
FLPT	DAC .+2
	JMS* .AP		/STORE
	XX
	JMP FPNT+1
FLGT	DAC .+2
	JMS* .AO		/LOAD
	XX
	JMP FPNT+1
FLSU	DAC .+2
	JMS* .AR		/SUBTRACT
	XX
	JMP FPNT+1
FLAD	DAC .+2
	JMS* .AQ		/ADD
	XX
	JMP FPNT+1
NORF	JMS* .CD		/NORMALIZE
	JMP FPNT+1
/////
EXITF	DAC	X.BH	/POWER
	TAD	C1
	DAC	BOX
	GETSGN
	SZA
	JMP	EXITFZ
	DZM* .AA
	DZM* .AC
	JMP	FPNT+1
EXITFZ	SMA!CLA		/IS BASE NEGATIVE
	JMP	.+3	/NO
	JMS*	.BA	/YES
	CLA!CMA
	DAC	SAVPOW	/SAVE SIGN OF BASE
	LAC	FPNT
	PUSHA		/SAVE INTERPRETER ENTRY
	JMS	FPNT	/SAVE BASE AND GET POWER
	FPUT	X
	FGET*	X.BH
	FXIT
	JMS	FIX	/GET INTEGER POWER
	DAC	OVER2
	JMS*	.AR
	X.BH+400000	/SEE IF INTEGER
	GETSGN
	SZA!CLL!CML	/L=1 IF INTEGER POINTER
	CLL		/L=0 IF NON-INTEGER
	LAC	SAVPOW
	SNL!SZA		/NON-INTEGER POWER OF
	ERROR	28	/NEG NUMBER
	LAC	OVER2	/CHECK POWER
	SMA		/POS OR NEG?
	JMP	EXITFQ	/POS-
	JMS*	.AO	/NEG - CHANGE SIGN
	X.BH+400000	/WITH GET,NEGATE,PUT
	JMS*	.BA
	JMS*	.AP
	X.BH+400000
EXITFQ	LAC*	BOX
	SNA
	JMP	ZERPOW
	JMS*	.AO	/GET BASE
	X
	JMS*	.BH
X.BH	XX
	LAC	SAVPOW	/GET SIGN OF BASE
	SMA
	JMP	EXITFP	/POS BASE
	LAC	OVER2	/GET POWER
	RAR		/PUT ODD OR EVEN IN LINK
	SZL
	JMS*	.BA	/CHANGE SIGN
EXITFP	LAC	OVER2	/GET POWER
	SMA
	JMP	EXITFX	/NO CHANGE
	JMS	FPNT	/DIVIDE ANSWER INTO ONE
	FPUT	X
	FGET	FLTONE
	FDIV	X
	FXIT
	JMP	EXITFX
ZERPOW	JMS*	.AO	/ANY BASE TO ZERO POWER
	FLTONE		/IS ONE
EXITFX	POPA
	DAC FPNT
	JMS* .CD
	JMP	FPNT+1
/////
FLMY	DAC .+2
	JMS* .AS		/MULTIPLY
	XX
	JMP FPNT+1
/ FORM AN INTEGER FROM C(FLAC-FLAC+1)
FIX	0		/VIA (INTEGER)
	JMS* .AX		/FIX
	DAC OVER2
	JMS* .AW		/FLOAT
	LAC OVER2
	DZM OVER2
	JMP* FIX
FLDV	DAC FLDVX
	ISZ ADDR
	LAC* ADDR
	AND	(377777
	SNA
	ERROR	29	/DIVISION BY ZERO
	JMS* .AT		/DIVIDE
FLDVX	XX
	JMP FPNT+1
	.EJECT
/FLOATING SQUARE ROOT FUNCTION
XSQRT	GETSGN
	SPA!CLA
	ERROR	30	/NUMBER IS NEGATIVE=IMAGINARY ROOTS
	JMS*	DSQRT
	JMP	.+2
	FLARG
	RETURN
/
/.OTS ERROR ROUTINE
/
SAVPOW=.
.ER	0
	ERROR	36
	.EJECT
/
/UNPACK INITIALIZATION
/
.GETI	0			/POINTER IN AC
	DAC	GETP		/INIT POINTER
	LAW	-1
	DAC	GETCX		/INIT COUNTER
	JMP*	.GETI
/
/UNPACK
/
.GET	0
	ISZ	GETCX
	JMP	GET4		/WORD PAIR STARTED
	LAC*	GETP		/NEED NEXT PAIR
	ISZ	GETP
	DAC	GET1X		/FIRST PART
	LAC*	GETP
	ISZ	GETP
	DAC	GET2		/LAST PART
	LAW	-5		/RESET CHAR COUNT
	DAC	GETCX
GET4	LAW	-10		/SHIFT LOOP 7 +1/2 TIMES
	DAC	GET3
GET5	LAC	GET2		/DOUBLE AC ROTATE LOOP
	RAL
	ISZ	GET3
	JMP	.+3		/KEEP LOOPING
	AND	P177		/GOT CHARACTER
	JMP*	.GET		/EXIT WITH CHARACTER IN AC
	DAC	GET2
	LAC	GET1X
	RAL
	DAC	GET1X
	JMP	GET5
/
/PACK INITIALIZATION
/
.PUTI	0			/POINTER IN AC
	DAC	PUTP		/INIT POINTER
	DZM	PUTC		/INIT COUNTER
	JMP*	.PUTI
/
/PACK
/
.PUT	0			/CHARACTER IN AC
	AND	P177
	DAC	PUT6		/SAVE CHARACTER
	CLL
	LAC	PUTC		/CHARACTER POSITION
	TAD	(JMP* PUT7	/BUILD DISPATCH
	DAC	.+2
	LAC	PUT6		/GET CHARACTER
	XX			/MODIFIED JMP* PUT7
PUT7	PUT1			/CHAR1
	PUT2			/CHAR2
	PUT3			/CHAR3
	PUT4			/CHAR4
	PUT5			/CHAR5
PUT1	RTR			/8 RIGHT
	RTR
	RTR
	RTR
PUT8	DZM*	PUTP		/CLEAR DATA WORD
	JMP	PUT9
PUT2	RTL			/4 LEFT
	RTL
	JMP	PUT9
PUT3	RTR			/3 RIGHT - 1ST HALF
	RAR
	AND	P17		/4 BITS ONLY
	XOR*	PUTP		/FINISH 1ST WORD OF PAIR
	DAC*	PUTP
	ISZ	PUTP		/TO LAST WORD OF PAIR
	LAC	PUT6		/GET CHARACTER
	RTR			/4 RIGHT - 2ND HALF
	RTR
	AND	(700000		/3 BITS ONLY
	JMP	PUT8
PUT4	RTL6			/8 LEFT
	RTL
	JMP	PUT9
PUT5	DZM	PUTC		/RESET 5/7 COUNTER
	SKP!RAL			/1 LEFT
PUT9	ISZ	PUTC		/TO NEXT CHARACTER
	XOR*	PUTP
	DAC*	PUTP		/MERGE INTO WORD PAIR
	LAC	PUTC
	SNA
	ISZ	PUTP		/2ND WORD COMPLETE
	JMP*	.PUT		/RETURN
	.END BEGIN
