/TSS/8 BASIC INTERPRETER  (BASIN) VERSION 24
/
/REVISION: 13-AUG-71		IDC/GWB/PJK
/
/COPYRIGHT 1969, 1970, 1971	DIGITAL EQUIPMENT CORP.
/				MAYNARD, MASSACHUSETTS
/
/
/ORIGINALLY WRITTEN BY:
/	INFORMATION DEVELOPMENT CO.
/	DEDHAM,MASS.
/
/THE TSS/8 BASIC INTERPRETER EXECUTES CODE GENERATED
/BY THE BASIC-8 COMPILER.
/
/THIS CODE CONSISTS OF SIX BIT OPERATORS OPTIONALLY
/FOLLOWED BY A SIX OR TWELVE BIT ADDRESS.
/IN ADDITION TO OPERATOR DECODE AND EXECUTE LOGIC,
/THE INTERPRETER CONTAINS THE ROUTINES NECESSARY FOR
/REAL ARITHMETIC, THE INTRINSIC FUNCTIONS, AND THE I/O
/PROCESSOR.
/

/SUPERCRITICAL LOCATIONS****


/THE FOLLOWING IS THE HIGHEST CORE LOCATION WHICH IS
/OVERLAYED WHEN THE INTERPRETER IS CALLED.  THE END STATEMENT PROCESSOR
/CHECKS TO MAKE SURE NO CONSTANTS ARE OVERLAYED.

INTSAV=6227		/TOP OF CORE (BASED,BASLDR)
INTLOW=5400		/START OF VARIABLE AREA IF NO FILE I/O (BASCOM)
INTEND=6020		/START OF VARIABLE AREA IF FILE I/O (BASCOM,BASLDR)

ISTACK=100			/STACK SIZE (BASLDR)
PSTSX=364			/ENTRY TO SAS SUBROUTINE (BASED)
UFIL0=357			/USER FILE 0 OPEN BLOCK IN 200 PAGE (BASED)
LINE=34				/LINE NUMBER (ERROR ROUTINE IN BASED)
LCSAV=352			/SAVE AREA FOR LC DURING CHAIN (BASED)
PRC=353				/LPT PRINT COLUMN; MUST SURVIVE CHAIN (BASED)
SASOP=374			/LOCATION OF SEND A STRING IOT IN SYSTEM SAS ROUTINE (BASED)
PRGNM=354			/NAME OF CHAIN PROGRAM (BASED)
INTX1=347			/VALUE OF LOC 11 IF INTERPRETER WAS JUST LOADED BY SYP (BASED)

/
/ LOCATIONS NEEDED BY CHAIN PROCESSOR IN BASEXC
/
LC=45
CVTFIL=4243
DSKNO=5555
DSKWC=5556
IFNZRO FILNAM-5557 <YOU GOOFED! /CHANGE BASEXC>

/
/ OTHER LOCATIONS NEEDED BY BASCOM
/
DPOW1=4764		/CHANGE INTONE IN BASCOM
DPOW0=4765		/CHANGE INTZER IN BASCOM
IFZERO DPOW1&4000 <YOU GOOFED/IF IT'S .LT. 4000 REFERENCES WILL BE RELOCATED>
IFZERO DPOW0&4000 <YOU GOOFED/IF IT'S .LT. 4000 REFERENCES WILL BE RELOCATED>

	NOPUNCH

 *0
INTRET,	0		/INTERRUPT RETURN ADDRESS
INTJMP,	0
INTPRG,	0		/INTERRUPT PROCESSOR ADDRESS
ENDINT,	0		/ADDRESS OF LAST WORD OF INTERPRETER;
			/  SET BY LOADER OR EXECUTOR

 *5
SYSERR,       0 	 /SYSTEM ERROR PROCESSOR VECTOR
SYSIOE,       0 	 /SYSTEM I-O ERROR
SYSPRG,       0 	 /SYSTEM PROGRAM CALL VECTOR

ERROR=JMS I SYSERR

 *10
T2,	      0 	 /AUTO-INDEX
T3,	      0 	 /AUTO-INDEX
AX2,	0		/AUTO INDEX NAMES
AX3,	0
AX4,	0
AX5,	0
L16,	      0 	 /AUTO-INDEX FP MATH
L17,	      0 	 /AUTO-INDEX FP MATH
/
/SYSTEM FILE VARIABLES
/
FINAME,       0 	 /CURRENT FILE NAME
	      0 	 /THREE WORDS
	      0 	 /FOR A NAME
FISIZE,       0 	 /CURRENT FILE SIZE
FITYPE,       0
SEGMNT,       0 	 /-(SEGMENT SIZE IN WORDS)
SRSIZE,       0 	 /SOURCE FILE, FILE 1, SIZE IN SEGMENTS
DEVSTS,	0		/DEVICE STATUS BITS
			/  BIT	   DEVICE
			/   0	    DTA 0
			/  ...	     ...
			/   7	    DTA 7
			/   8	    DSK 8
			/   9	    DSK 9
			/  10	    PTP
			/  11	    LPT
START,	      0 	 /ADDRESS OF EXEC LIST
LLIMIT,       0 	 /LOWER STACK LIMIT
HLIMIT,       0 	 /UPPER STACK LIMIT
DATBND,       0 	 /LOWER END OF NUMERIC DATA
LINE,	      0 	 /LINE NUMBER OF PRESENT INSTRUCTION
DSTBND,       0          /LOWER END OF STRING DATA
/
/CONSTANTS AND VARIABLES:
/
PROGRM,       0 	 /FIRST PROGRAM STEP IN CORE
PRSIZE,       0 	 /CALC ROOM LEFT IN CORE
STACK,	      0 	 /STACK POINTER
AF,	      0 	 /STORAGE FOR ADDRESS
BYTE,	      0 	 /LAST CHAR OUTPUT
DP,	      0 	 /DATA POINTER (NUMERIC)
DS,           0          /DATA POINTER (STRING)
/! ! ! N O T E ! ! ! DS MUST BE DP+1!!! KEEP TOGETHER.
LC,	      0 	 /LINE COUNT-CHARACTERS
LP,	      0 	 /SUB-STACK POINTER
MF,	      0 	 /ADDRESSING MODE FLAG
SF,	      0 	 /SIDE FLAG
XL,	      0 	 /EXEC LIST POINTER
T1,	      0 	 /TEMP STORAGE
T4,	      0 	 /TEMP STORAGE
XCNT,	      0 	 /EXECUTION CNTR
TS,	      0 	 /3 WORD TEMPORARY STORAGE
TS1,	      0
TS2,	      0
BE,	      0 	 /BINARY EXPONENT
DE,	      0 	 /DECIMAL EXPONENT
LINF,         0          /LINE FLAG
STRFLG,       0          /STRING FLAG (-1 WHEN STRING ON STACK)
PL,	      0 	 /PLACE FLAG
PE,	      0 	 /PREVIOUS EXPONENT FLAG
PN,	      0 	 /PREVIOUS NUMBER FLAG
SN,	      0 	 /SIGN OF NUMBER
SE,	      0 	 /SIGN OF EXPONENT
/KEEP THE NEXT 10 LOCATIONS (AC AND SR) ALWAYS TOGETHER
ACS,	      0 	 /SIGN
ACX,	      0 	 /EXPONENT
ACH,	      0 	 /BINARY FRACTION
ACM,	      0
ACL,	      0
ID=ACH;	ID1=ACM;	ID2=ACL	/SECOND FLOATING AC
ACO,	0
/ID+3 IS USED BY PRT ROUTINE***********
SRS,	      0 	 /SIGN
SRX,	      0 	 /EXPONENT
SRH,	      0 	 /BINARY FRACTION
SRM,	      0
SRL,	      0
SRO,	0		/OVERFLOW BIT
TEM,	      0 	 /FP MATH
PZERO=.		/PAGE ZERO CONSTANTS AREA
/
/ PAGE ZERO CONSTANTS AREA GETS LOADED AT END OF PROGRAM!
/
	ENPUNCH

*6135

	NOPUNCH

*PZERO			/RESET FOR ASSEMBLY BUT NOT FOR LOADING

	ENPUNCH
COB,	OB		/OUTPUT BUFFER ADDRESS
ADSRAC,	LASRAC		/FP MATH
COM,	LCOM		/FP MATH
NORMAC,	LNRMAC		/FP MATH
SPLIT,	LSPLIT		/FP MATH
ALS,	LALS		/FP MATH
ARS,	LARS		/FP MATH
/
/ADDRESSES:
/
INRENT,	INR		/RETURN TO INTERPRETER
LFOP,	FOP		/FETCH NEXT OPERATION
LXAD,	XAD		/EXAMINE ADDRESS IN AF
LFBT,	FBT		/FETCH NEXT BYTE
LFAD,	FAD		/FETCH ADDRESS
LCAD,	CAD		/USED BY MPY AND DVD
LRAD,	RAD		/FETCH RELOCATED ADDRESS
LCLM,	CLM		/CHECK STACK LIMIT
LSAS,	STG		/OUTPUT A STRING FROM BUFFER
LTYPE,	TYPE      	/TYPE A STRING
LID,	ID-1
LOUT,	OUT
RECERR,	RER		/RECOVERABLE ERROR ROUTINE
LDADD,	DADD		/DECADD ROUTINE
LDSUB=LDADD 		/ENTER ADD WITH AC=0
			/ENTER SUBTRACT WITH AC=4000
LRLF,	RLF		/LINK TO CARRIAGE RETURN-LINE FEED
LXPY,	XPY		/LINK TO MULTIPLY BY 10
TEXTS,	 TEXTX     	/LINK TO TEXT OUTPUT ROUTINE
LFRT,	FRT       	/LINK TO FUNCTION RETURN
LCIN,	CIN       	/CONVERT TO INTEGER
LINMOV,	INMOV		/MOVE SUBROUTINE
WOQS,	OQS		/READ A LINE OF INPUT
PPRC,	PRC		/LPT PRINT POSITION
/
/PAGE ZERO CONSTANTS:
/
P3,	3
P4,	4
M4,	-4
M5,	-5
M6,	-6
P7,	7
M10,	-10
P11,	11
C15,	15
M15,	-15
CM33,	-33
P240,	240
P100,	100
P77,	77
C177,	177
P200,	200
M200,	-200
C7400,	7400
CM201,	-201
C256,	256
C260,	260
C377,	377
P4000,	4000
FIXSW=P4000		/BE VERY CAREFUL!!  NO SUBROUTINE OF FIX FUNCTION
			/SHOULD USE P4000
C5400,	5400
C7740,	7740
C7771,	7771
MQUO,	-42
M70,	-70
M40=C7740
DTMP,	INTBL-ITPRT
C7=P7
M7=C7771
/
/ TSS/8 IOT'S
/
RFILE=6603
WFILE=6605
SBC=6401
SAS=6040
KSR=6030		/READ INPUT STRING FROM TTY
TOD=6412
STM=6416
ASD=6440
REL=6442
OPEN=6601
CLOS=6602
PROT=6604
CRF=6610
EXTEND=6611
RED=6612
LST=6660
LLS=6666
PZCNT=PZERO-.
/
/EQUATES FOR FUNCTION EXECUTION
/
XNOP=0
XADD=1
XSUB=2
XMPY=3
XDVD=4
XEXP=5
XNEG=6
EXIT=16
LSTD=20
SSTD=21
GOTO=31
IFF=32
TEST=50
IFUN=51
FNRT=52
DUMM=53
SMFA=54
FEXP=4

SIN=0
COS=1
LOG=5
ABS=7
INT=10
SGN=12
FIX=15

GE=3
LE=5
NE=6
LS=4
	*400
/
/ INPUT OVERLAY AND INTERPRETER STARTUP
/
	TAD T3		/IS THIS INTERPRETER CALL
	TAD KINT
	SNA CLA
	JMP I LIIN	/YES, GO INITIALIZE INTERPRETER
	JMP I TS	/NO, GO TO APPROPRIATE INPUT ROUTINE

/
/ SWAP ROUTINE
/
/  AC .EQ. 0:  FUNCTION OVERLAY REQUEST
/  AC .NE. 0:  INPUT OVERLAY REQUEST
/
SWAP=.
	SZA CLA		/REQUEST FOR FUNCTION OVERLAY
	JMP I TS	/NO, GO TO APPROPRIATE INPUT ROUTINE
	TAD P7		/YES, CALL SYSTEM SWAPPER TO LOAD IT
	JMP I SYSPRG

KINT,	-INTX1
LIIN,	IIN
/
/ LINPUT, INPUT INDIRECT AND INPUT DIRECT ENTRY POINTS
/  THESE THREE ADDRS MUST BE ADJACENT AND IN THE ABOVE ORDER;
/  ELSE THE ROUTINES IN THE RESIDENT INTERPRETER WHICH CALL
/  THEM WILL MISS.
/
/LINPUT:
LINPX,	JMP I PLINP1

/INPUT INDIRECT:
/USE THE TOP WORD OF THE STACK AS
/A POINTER TO THE ADDRESS IN WHICH TO STORE
/THE INPUT ELEMENT.  HANDLES CONVERSION FOR
/BOTH STRING AND NUMERIC DATA.
	JMS I PDNI		/LOAD AF FROM STACK
/SKIP NEXT INSTRUCTION!!


/INPUT DIRECT:
/USE THE CALL (A) AS A POINTER TO THE ADDRESS IN
/WHICH TO STORE THE INPUT ELEMENT.  HANDLES CONVERSION
/FOR BOTH STRING AND NUMERIC DATA.
	JMS I LRAD	/GET ADDRESS IN AF
	ISZ	STRFLG		/TEST FOR STRING INPUT
	JMP I	LINN		/GET NUMERIC INPUT

/INPUT STRING
INW,	TAD	M6
	DCA	XCNT		/SET TO READ FIRST 6 CHARS
	DCA	PE		/SET IN CASE OF LINPUT
	TAD I PINLG		/TEST FOR LINE INPUT
	SZA CLA
	JMP	INWL
	JMS I	WOQS		/BRING IN A LINE
	TAD I	AX2		/GET FIRST CHAR
	AND	C177
	DCA	CH
	TAD	CH
	TAD	MQUO		/TEST FOR QUOTE FIRST
	SZA CLA			/SKIP IF QUOTE
	JMP	INW1		/QUOTE IS NOT A TERMINATOR
	TAD	INQUO
	DCA	PE		/SET TERM TO QUOTE

INWL,	TAD	CH
	SPA CLA			/SKIP IF READING NEXT CHAR
INW1,	TAD	CH		/USE CH AGAIN
	SNA
	TAD I	AX2		/GET NEXT CHARACTER
	JMS	INWTR		/TEST FOR TERMINATOR

	TAD	M6		/SHIFT ID SIX BITS LEFT
	DCA	DE		/PUTTING ZEROES IN RH SIXBITS OF ID2
	CLL
	JMS I	ALS		/ONE BIT SHIFT
	ISZ	DE
	JMP	.-3

	TAD	CH
	TAD	INCOM			/SPECIAL -337 ASCII MODE
	AND	P77
	TAD	ID2
	DCA	ID2		/SAVE ONE CHAR
	ISZ	XCNT
	JMP	INWL

INW2,	TAD I PINLG		/TEST FOR LINPUT
	SZA SMA CLA		/SMA IS HACK FOR CHANGE!
	JMP	INXR		/EXIT
	TAD	CH		/COMES HERE WHEN SIX CHARS ARE FOUND
	SPA CLA			/NOW PASS OFF CHARS UNTIL TERM
	JMP	INXR
	TAD I	AX2
	JMS	INWTR
	JMP	INW2		/CONTINUE LOOKING FOR TERM

PDNI,	DNI
PLINP1,	LINP1
/-CR- FOUND SET FLAG AND ECHO
INWCR,	TAD I PINLG		/CHECK FOR CHANGE
	SPA CLA
	JMP	INWCM-1		/HACK FOR CHANGE
	CLA CLL CML RAR
	DCA	LINF
	JMS I	LRLF		/ECHO
	JMP	INWCM

/TEST FOR COMMA
INWTR1,	TAD	INCOM		/CHECK FOR COMMA
	SNA
	TAD I PINLG		/TEST FOR LINE INPUT
	SNA CLA			/EXIT IF NOT ZERO
	SNL			/LINK=1 IFF CH IS COMMA!!!!
	JMP I	INWTR		/COMMA IS NOT A TERM IN LINE MODE
	DCA I PINLG		/CLEAR IN CASE OF CHANGE
INWCM,	TAD	INWF
	JMP	INWTR+1



/ILLEGAL CHARACTER (NON-TERM FOLLOWING QUOTE)
INWIC,	JMS I	RECERR		/TYPE "IC IN ...."
	1103
	STA CLL RAL
	DCA	LINF		/SET TO REREAD LINE
	JMP	INW		/TRY AGAIN

/SUBROUTINE TESTS FOR TERMINATOR
/ENTRY:	AC IS CHAR TO TEST
/EXIT:	CH IS CHAR IF TERM NOT FOUND
/	CH IS <0 IF TERM FOUND (TERM IS -CR-,-COMMA-, AND SOMETIMES -QUOTE-)

INWTR,	0
	DCA	CH		/SAVE CHAR
	TAD	CH
	AND	C177
	TAD	M15
	SNA
	JMP	INWCR		/FOUND -CR-
	CLL			/MAGIC!!! USE PE TO CHECK BOTH COMMA AND QUOTE
	TAD	PE		/TEST FOR QUOTE
	SZA
	JMP	INWTR1		/TRY FOR COMMA
	DCA	PE		/AVOID DUPLICATE QUOTES!
	TAD I	AX2		/FOUND QUOTE...NEXT MUST BE TERM
	JMS	INWTR		/CHECK THAT IT IS
	TAD	CH
	SMA CLA
	JMP	INWIC		/ITS NOT! ILLEGAL
	TAD	XCNT		/ARE WE DONE?
	SPA CLA
	JMP	INWL	/CONTINUE UNTIL 6 CHARS FILLED
/FALL INTP INXR TO END INPUT.



/EXIT FOR BOTH NUMERIC AND STRING CONVERSION
INXR,	CLA CMA
	TAD	AF
	DCA	T2		/SAVE "TO" ADDRESS
	TAD	LID
	JMS I	LINMOV		/GO TO MOVE
	JMP I	LFOP		/RETURN TO FETCH

/USE INPUT PROCESSOR TO FINISH CHANGE A TO A$!!
CHD3,	CLA CMA
	DCA I PINLG
	DCA	CH		/CLEAR CHARACTER FOR CHANGE
	JMP	INW

LINN,	INN


CH,	0		/STORE CHARACTER DURING INPUT

INCOM,	-37
INQUO,	-25
INWF,	4037		/TERMINATOR FOR STRING
PINLG,	INLG
/PERFORM INPUT IN LINE MODE
/DO A SERIES OF STRING READS
LINP1,	ISZ I PINLG	/SET FLAG
	JMS I WOQS	/READ THE LINE OF INPUT
	DCA CH		/HACK---FIRST TIME THRU
	JMP I LFOP	/GO AND DO INPUT

DELM,	TEXT /$ DELETED/
PAGE
/
/INPUT A NUMBER:
/
/
INN14,	JMS I	RECERR		/ERROR IC (ILLEGAL CHARACTER)
	1103
	STA CLL RAL
	DCA	LINF	/GET MORE INPUT

INN,	DCA   PE	 /INITIALIZE CONTROL LOCATIONS
	DCA   DE
	DCA   ID
	DCA   ID1
	DCA   ID2
	DCA   PN
	STA
	DCA   SE
	STA
	DCA   SN
	DCA PL
	DCA T1
	DCA T4		/RESET SKIP FLAG
	JMS I WOQS
INN10,	TAD I	AX2		/GET NEXT CHAR
	AND C177	/SAVE LO 7 BITS ONLY
	DCA   TEM	/SAVE LOW 6 BITS
	TAD   TEM
	TAD   M72
	CLL
	TAD   P12
	SZL		 /# 0-9?
	JMP INN2
	TAD   P2
	SNA		 /.?
	JMP   INN4
	IAC
	SNA		 /-?
	JMP   INN3
	IAC
	SNA		 /,?
	JMP   INN5
	IAC
	SNA		/+?
	JMP INN6
	TAD	P13
	SNA		 /SPACE?
	JMP   INN10
	TAD   P23
	SNA		 /CR?
	JMP   INN19
	TAD   M70
	SZA CLA		/E?
	JMP	INN14		/ILLEGAL CHARACTER

INN1,	TAD PE		/PREVIOUS E INPUT OR
	CLL RAR		/  NO PREVIOUS NUMERAL INPUT
	TAD PN
	SNA SZL CLA
	JMP INN14	/YES, ERROR
	ISZ PE		/INDICATE E WAS INPUT
	DCA PN		/CLEAR PREVIOUS NUMBER FLAG
	JMP INN10	/GET NEXT CHARACTER

INN3,	TAD   PE	 /- WAS INPUT
	SZA CLA
	JMP INN3A	/THIS IS SIGN OF EXPONENT
	ISZ SN		/IS THIS SECOND MINUS
	JMP INN14	/YES, ERROR
INN6,	TAD PN		/+ OR - IS VALID ONLY IF NO DIGITS INPUT SO FAR
	SZA CLA
	JMP INN14	/ERROR
	JMP INN10	/GET NEXT CHARACTER

INN3A,	ISZ SE		/IS THIS SECOND MINUS
	JMP INN14	/YES, ERROR
	JMP INN6	/NO, GO MAKE SURE THIS IS NOT EMBEDDED MINUS

INN4,	ISZ PL		/IS THIS FIRST .
	SKP		/YES
	JMP INN14	/NO, ERROR
	STA
	DCA   PL	 /SET PL TO -1
	JMP   INN10	 /GET NEXT CHARACTER

INN19,	CLA CLL CML RAR	 /CR/LF, SET LINE FLAG
	DCA	LINF
	JMS I	LRLF		/ECHO THE CR-LF
INN5,	TAD T1		/CHECK SIZE OF EXPONENT
	TAD M70
	SMA CLA 	 /EXPONENT TOO LARGE?
	JMP   INN14	 /YES;ERROR
	TAD T1		/DE=DE+EXPONENT
	ISZ SE
	CIA
	TAD DE
	DCA DE
	JMP I LFLT	 /FLOAT NUMBER
LFLT,	FLT

INN7,	TAD   T1	 /ACCUMULATE EXPONENT
	RTL CLL
	TAD   T1	 /T1=T1*10
	RAL CLL
	TAD   SRL
	DCA   T1
	JMP   INN10	 /GET NEXT CHARACTER
/
M72,	-72
P2,	2
P13,	13
P12,	12
P23,	23

INN2,	DCA   SRL		/SAVE DIGIT TO USE ADSRAC
	DCA	SRM
	DCA	SRH
	ISZ PN		/SET PREVIOUS NUMBER FLAG
	TAD   PE
	SZA CLA 	 /EXPONENT OR NUMBER?
	JMP INN7	 /EXPONENT
	TAD T4		/SKIP ID*10
	SZA CLA
	JMP INN15	/YES
	TAD ID		/CAN WE MULTIPLY BY 10(DECIMAL)
	TAD CM314
	SNA
	JMP I LINN2A
INN2B,	SMA CLA
	JMP INN13	/NO
	CLL		/XPY NEEDS TO HAVE LINK CLEAR
	JMS I LXPY	 /MULTIPLY ID BY 10
	JMS I ADSRAC	/ADD DIGIT TO ID

INN11,	TAD   DE
	TAD   PL
	DCA   DE
	JMP INN10	/GET NEXT CHARACTER

INN13,	ISZ T4		/SET SKIP MULTIPLY FLAG
INN15,	CLA IAC
	JMP INN11

CM314,	-314
LINN2A,	INN2A

PAGE
/INPUT A LINE
/THIS ROUTINE TYPES OUT A '?', AND READS A STRING
/INTO THE LOBUFF AREA.  THE FOLLOWING CONTROL
/CHARACTERS ARE MEANINGFUL--
/	RETURN	TERMINATES THE INPUT LINE
/	RUBOUT	DELETES PREVIOUS CHARACTER, ECHOES _
/	_	SAME AS RUBOUT
/	ALTMODE	DELETES THE ENTIRE LINE AND RESTARTS
/CHARACTERS OTHER THAN THE ABOVE PLUS ASCII 240-336 ARE ILLEGAL
/AND ECHO AS "BELL-BELL" (THEY ARE DELETED FROM THE INPUT STRING.

OQS,	0
	TAD	LINF		/DO I REALLY WANT INPUT?
	SMA CLA			/NO--LINE IS ALREADY IN CORE
	JMP I	OQS
	ISZ	LINF		/FLAG SET?
	JMP OQQUES		/NO, WE NEED TO PROMPT USER
OQS0,	TAD	OQMSIZ
	DCA	ACS		/STORE INPUT BUFFER SIZE
	TAD	OQBUFF
	DCA	ACX		/STORE ADDRESS OF INPUT BUFFER
	TAD	OQBUFF
	DCA	AX2		/ESTABLISH POINTER FOR INPUT ROUTINE

OQS1,	CLA
	TAD	OQACS
	KSR
	TAD I	ACX		/GET LAST CHAR
	AND	C177		/ONLY 7-BITS ARE MEANINGFUL
	SZA
	TAD	OM12
	SNA
	JMP	OQSDEL		/DELETE BLANK TAPE AND LF'S
	TAD	M3
	SNA			/CR?
	JMP I	OQS		/EXIT ON CARRIAGE RETURN
	TAD	OM16
	SNA
	JMP	OQSALT		/TREAT ASCII 33 AS ALTMODE
	TAD	OM104
	SNA
	JMP	OQSRUB		/TREAT _ AS A RUBOUT
	CLL
	TAD	P4
	SZL
	JMP	OQS1		/CHARS 333-336 ARE LEGAL
	TAD	OM43
	SZA
	IAC			/TRY FOR 176
	SNA
	JMP	OQSALT		/175 AND 176 ARE ALTMODES
	TAD	M2
	SZA CLA
	JMP	OQSBAD		/ITS ILLEGAL
	JMS I	LTYPE		/RUBOUT
	"_			/ECHO _
OQSRUB,	TAD	ACS
	TAD	M2
	TAD	OQSIZE
	SPA			/TEST FOR PAST START OF LINE
	JMP	OQSREE		/YES,RESTART INPUT
	TAD	OQMSIZ
	DCA	ACS
	TAD	ACX
	TAD	M2
	DCA	ACX
	JMP	OQS1		/CONTINUE INPUT

OQSBAD,	TAD	ACS
	SMA CLA
	JMP	OQSLL		/LINE TOO LONG
	TAD	P7
	TLS
	TLS
OQSDEL,	CLA			/ECHO-BELL-BELL
	ISZ	ACS
OQSIZE,	INSIZ			/USE AS NOP
	ISZ	ACX
	JMP	OQSRUB		/DELETE ILLEGAL CHARACTER

OQSLL,	JMS I	LRLF
	JMS I	TEXTS
	LTLM			/LINE TOO LONG
	CLA STL RTR
	SBC			/CLEAR JUNK OUT OF INPUT BUFFER
	JMP	OQSREE		/RESTART

OQSALT,	JMS I	TEXTS		/$ DELETED
	DELM
OQSREE,	JMS I	LRLF		/TYPE A CR-LF
OQMOR,	JMS I	TEXTS		/"MORE? "
	MRMES
	DCA	LINF		/CLEAR LINE FLAG
	JMP	OQS0

OQQUES,	ISZ LINF	/IS THIS START OF LINE
	JMP OQMOR	/NO, SO GO SAY "MORE?"
	JMS I TEXTS	/YES, JUST GIVE "?"
	QMQM
	JMP OQS0

OQMSIZ,	-INSIZ
OM43,	-43
OM104,	-104
OQBUFF,	LOBUFF-1
OM12,	-12
OM16,	-16
OQACS,	ACS
M2,	-2
M3,	-3
/TERMINATE INPUT LINE
/
ITM,	TAD	LINF		/TEST FOR LINE COMPLETE
	SPA CLA
	JMP ITM1
	JMS I	LRLF		/FIRST SEND A CR-LF
	TAD	INLG		/TEST FOR LINPUT
	SZA CLA
	JMP ITM1	/AVOID "TOO MUCH INPUT" ERROR
	JMS I	TEXTS		/THEN INSERT MESSAGE
	ITMES			/"TOO MUCH INPUT"
	JMS I	LRLF		/PUT OUT A -CR-LF-
ITM1,	DCA	INLG		/CLEAR LINE FLAG FOR NEXT TIME
	JMP I	LFOP		/RETURN TO ENTRY

INLG,	0			/LINE INPUT FLAG

INN2A,	TAD ID1
	TAD CM6314
	JMP I .+1
	INN2B
CM6314,	-6314

ITMES,	TEXT	/TOO MUCH INPUT, EXCESS IGNORED/
PAGE
/
/FLT- FLOAT A NUMBER INTO INTERNAL FORM
/
/FLT TAKES THE NO. IN ID AREA AND ACCORDING TO THE DE
/SCALES IT. FLT DIVIDES BY 10 FOR A - NO. AND MULT'S BY 10
/FOR A + NO.-IT NORMALIZES THE NO. AND FORMATS IT ACCORDING
/TO BE & SN. IF THE NUMBER ID =0 ALONE IT IS LEFT.
/
FLT,	TAD   P243	 /SET BASIC ASSUMED EXPONENT
	DCA   BE
	TAD	ID		/TEST ID FOR ZERO
	SNA
	TAD	ID1
	SNA
	TAD	ID2
	SNA CLA
	JMP I	FINXR

FLT1,	JMS I PNRM	 /NORMALIZE NUMBER
	TAD   DE
	SNA
	JMP   FLT3	 /DECIMAL EXP IS ZERO
	SMA CLA
	JMP   FLT2	 /IS PLUS,MAKE NO LARGER
	JMS I LDIV
	ISZ   DE	 /DECREASE SIZE
P243,	243
	JMP   FLT1	 /MORE
FLT2,	CLL
	JMS I ARS
	JMS I ARS
	JMS I ARS
	JMS I ARS
	TAD   BE
	TAD   P4
	DCA   BE	 /ACCOUNT FOR THE SHIFTS
	JMS I LXPY	 /MULTIPLY BY 10
	CLA CMA
	TAD   DE
	DCA   DE	 /SET UP NEW DE
	JMP   FLT1
FLT3,	TAD   BE
	AND   C7400	 /ALL DONE,CHECK
	SZA   CLA
	JMP I FINN14	 /ERROR TOO BIG
	TAD	M10
	DCA   XCNT	 /EXEC CNTR
	CLL		/LINK MUST BE CLEARED FOR SHR
	JMS I ARS	 /SHIFT RT MAKE RM FOR A MPY BY 10
	ISZ   XCNT
	JMP   .-2
	ISZ SN		/PUT NUMBER TOGETHER
	TAD C5400	/SET MINUS SIGN
	TAD	BE		/GET EXP IN BITS 4-11
	RAL CLL
	RTL CLL
	TAD	ID
	DCA	ID
	JMP I	FINXR		/EXIT ALL DONE
/
PNRM,	NRM
LDIV,	DIV		 /LINK TO DIVIDE
FINXR,	INXR		/NORMAL EXIT
FINN14,	INN14			/ERROR EXIT
/CHANGE A TO A$(I)
CHDIX,	JMS I	LDNI		/LOAD AF FROM STACK
/SKIP NEXT INSTRUCTION

/CHANGE A TO A$ ENTRY POINT
	JMS I LRAD	/LOAD AF

	TAD	KOBUFF
	DCA	AX2		/SET UP POINTER TO BUFFER
	TAD 	STACK
	DCA	SRS		/SAVE POINTER
	CLA CMA
	TAD I	STACK
	DCA	STACK		/SET FOR FETCH
	JMS	CHFET		/GET COUNT
	TAD	P371		/MAX 6 CHARS (BACK)
	SMA
	CLA CMA			/FORCE 6 CHARS
	TAD	P7
	CMA
	DCA	XCNT
CHD1,	ISZ	XCNT
	JMP	CHD2		/STASH A CHAR
	TAD	C15		/STORE A CR
	DCA I	AX2
	TAD	KOBUFF
	DCA	AX2		/RESET POINTER
	STA
	TAD	SRS
	DCA	STACK
	JMP I	.+1		/CALL INPUT TO FINISH
	CHD3

CHD2,	JMS	CHFET
	AND	C177		/VERIFY THAT CHAR IS LEGAL
	TAD	M137
	CLL
	TAD	P77
	SNL
	JMP	CHDER		/BAD CHAR
	TAD	P240		/RESTORE CHAR
	DCA I	AX2		/STASH CHAR
	JMP	CHD1		/CONTINUE

LDNI,	DNI			/LOAD AF FROM STACK

/FETCH NEXT VALUE FROM ARRAY
/VERIFY THAT VALUE IS IN RANGE 0 TO 255

CHFET,	0
	TAD	P3
	TAD	STACK
	DCA	STACK		/FIX POINTER
	JMS I	CIFIX		/CONVERT TO INTERGER
	TAD	ACH
	SNA
	TAD	ACM
	SZA CLA
	JMP	CHDER
	TAD	ACL
	CLL
	TAD	C7400
	SNL
	JMP I	CHFET		/RETURN VALUE
CHDER,	ERROR		/CHANGE ERROR
	20
KOBUFF,	LOBUFF-1		/POINTER TO BUFFER
P371,	371
CIFIX,	LIFIX			/FIX SUBROUTINE
M137,	-137
LTLM,	TEXT /LINE TOO LONG/
MRMES,	TEXT /MORE? /
	*1400
/
/FETCH BYTE:  RETRIEVE NEXT  6 BITS FROM EXECUTION LIST.
/
/IF:	SF=-1   -EXTRACT LH SIDE
/	SF=0   EXTRACT RH SIDE
/
/	      RDF (READ FILE) CAN BE CALLED IF NEXT STEP
/	      /NOT IN CORE
/
/EXIT: BYTE LEFT IN AC
/
FBT,	0
	ISZ	SF		/SF=-1 IF LH SIDE
	JMP   FBT1	 /RH SIDE
	CLA CLL
	TAD   LLIMIT	 /IN CORE?
	TAD   XL
	SZL CLA
	JMP   FBT2
	TAD I XL
	CLL RTR
	RTR
	RTR
	AND	P77
	JMP I FBT
FBT1,	CLA CMA		/SET TO LH SIDE NEXT
	DCA   SF
	TAD   I XL
	AND   P77
	ISZ   XL
	JMP I FBT
FBT2,	TAD   PROGRM	 /FIRST STEP IN CORS
	TAD   PRSIZE
	DCA   AF
	JMS   XAD	 /EXAMINE ADDRESS. AND READ FILE
	JMP   FBT+1
/
/EXAMINE ADDRESS:	 DETERMINE IF PROGRAM RELATIVE ADDRESS
/			 IS IN CORE. IF IN UPDATE XL & SG.
/
/			 IF NOT IN CORE,CALL RFL(READ FILE)
/
/ENTRY: AF=ADDRESS TO BE EXAMINED
/
/EXIT:	SF=-1
/	XL=PROGRAM CORE ADDRESS
/
XAD,	0
	TAD   MF
	SZA CLA 	 /MODE FLAG SET TO PROGRAM?
	JMP   XAD4	 /NO;SET XL TO AF
	TAD	PROGRM
	TAD	PRSIZE
	CIA
	TAD	AF
	CLL
	TAD	PRSIZE		/LINK=1 IFF ADDR IS IN CORE
	SNL CLA			/SKIP IFF PROGRM<AF<PROGRM+PRSIZE
	JMP   XAD2	 /YES; READ FILE
	TAD   PROGRM
	CIA
	TAD   START
XAD4,	TAD	AF		/RESET XL
	DCA   XL	 /XL=(AF-PROGRM)+CORE START
	CLA CMA			/SET SF TO -1
	DCA   SF
	JMP I XAD


XAD2,	TAD	AF
	DCA	PROGRM		/READ NEXT CHUNCK OF FILE
	JMS	RFL
	JMP I	XAD
/
/READ DISK FILE:	 CHECK MODE FLAG (MF); IF =1,EXIT
/			 IF =0 READ FILE
/			 READ FROM PROGRM TO PROGRM+PRSIZE.
/
/ENTRY: PROGRM= PROGAM ADDRESS WANTED
/
/EXIT:	SF=-1
/	XL=START OF CORE
/
RFL,	0
	TAD   PRSIZE	 /SET UP FOR READ
	CIA
	DCA   RFWD3	 /NO. WORDS
	CMA
	TAD   START
	DCA   RFWD4
	TAD   PROGRM	 /DISK START ADDRESS
	DCA   RFWD5
	TAD   RFLIST
       RFILE
	CLA CLL CMA RTL
	AND	RFWD6
	JMS I SYSIOE	 /CHECK THIS OUT
	CLA CMA
	DCA   SF
	TAD   START
	DCA   XL
	JMP I RFL
/
RFLIST,       .+1
RFWD1,	      0 	 /UPPER DISK ADDRESS
RFWD2,	      1 	 /USER FILE NO.
RFWD3,	      0 	 /NO. WORDS- 2 S COMPL.
RFWD4,	      0 	 /CORE ADDRESS
RFWD5,	      0 	 /DISK START ADDRESS
RFWD6,	      0 	 /ERROR WORD FOR WRITE FILE
/
/NO OPERATION:		 PERFORM NO OPERATION
/
NIX=FOP
/
/ADD-	   TOP TWO ELEMENTS OF STACK ARE ADDED.
/	STACK = STACK-3; RESULT AT TOP OF STACK.
/
ADD,	JMS CAD		/CALCULATE ARGUMENT ADDRESSES
	JMP SUB1

/
/SUBTRACT- TOP TWO ELEMENTS ARE SUBTRACTED.
/	STACK = STACK-3; RESULT AT TOP OF STACK.
/
SUB,	JMS CAD		/CALCULATE ARGUMENT ADDRESSES
	CLA STL RAR	/AC=4000 INDICATES SUBTRACT
SUB1,	JMS I LDADD
	JMP I LFOP

/
/CALCULATE ADDRESS FOR MATH FUNCTIONS:
/USE STACK POINTER FOR CALC OF ADDRESSES
/
/EXIT:	STACK-3
/
CAD,	0
	STA CLL RAL	/GET ADDR OF ARG1
	TAD STACK
	DCA BE
	TAD M5		/GET ADDR OF ARG2 (DESTINATION ADDRESS)
	TAD STACK
	DCA DE
	STA CLL RTL	/FIX STACK POINTER
	TAD STACK
	DCA STACK
	JMP I CAD

/
/ SLE - SLEEP
/
SLE,	JMS I LCIN	/MAKE NO. OF SECONDS INTO INTEGER
	JMP E55		/RETURNS HERE IF ARG OUT OF RANGE
	STM		/SET TIMER
	JMP I LFOP

E55,	ERROR
	11		/*** BAD SLEEP ARGUMENT ***
/
/STORE LINE NUMBER
/LINE:	STORE (A) AS CURRENT LINE NUMBER.
/
LIN,	JMS I LFAD	 /FETCH ADDRESS,AF=ADDRESS
	TAD   AF
	DCA   LINE	 /SET LINE
SAME,	NOP		/CHANGE TO "JMP LINX" FOR TIMEOUT TEST
LINY,	STA		 /SET LINE FLAG TO -1
	DCA   LINF
	DCA	STRFLG		/CLEAR STRING FLAG FOR LINE
	JMP I LFOP	 /FETCH NEXT OPERATION CODE


/THIS IS THE "TIMEOUT" PATCH.
/WHEN IT IS ENABLED, EVERY LINE EXECUTED IN A PROGRAM IS COUNTED
/AND IF THE COUNTER (24 BITS) OVERFLOWS, THEN THE RUNTIME EXECUTION
/ABORTS AND THE MESSAGE "TIME LIMIT EXCEEDED" IS PRINTED.
LINX,	ISZ	XC1
	JMP	LINY
	ISZ	XC2
	JMP	LINY
	ERROR
	21			/"TIME LIMIT EXCEEDED" ERROR

XC1,	0
XC2,	0
/
/ LOAD ADDRESS (LDA) AND LOAD RELOCATED ADDRESS (LDR)
/
/ EXIT:  STACK+1
/	 ERROR(20) CAN BE CALLED
/
LDR,	JMS I LRAD	/GET RELOCATED ADDR INTO AF
	SKP
LDA,	JMS I LFAD	/GET ADDRESS INTO AF
	CLA IAC		/INCREMENT STACK POINTER
	JMS I LCLM
	TAD AF		/LOAD ADDRESS ONTO STACK
	DCA I STACK
	JMP I LFOP
/
/
/
/
/
/ENTER INTERPRETER:	 RETURN FROM MACHINE CODE. RECOVER ADDRESS
/			 AND START INTERPRETER.
/
/EXIT:	SF=-1
/	XL=INR
/
INR,	0
	CLA CMA
	DCA	SF
	TAD   INR
	DCA   XL	 /RECOVER ADDRESS NXT INSTRUCTION
	JMP I LFOP	 /FETCH NEXT OPERATION CODE

PAGE
/
/SUBSCRIPT:   TOP ELEMENT IS CONVERTED TO AN INTEGER,
/	MULTIPLIED BY 3, ADDED TO (A) AND PLACED ON
/	TOP OF STACK.
/
/EXIT:	STACK-2
/	ERROR (20) CAN BE CALLED
/
SSC,	JMS I LRAD	 /FETCH ADDRESS,AF=ADDRESS
	JMS I LCIN	 /CONVERT TOP EL TO INTEGER;DECR STK-2
	JMP   SSC1	 /ERROR RETURN; AC#0
	ISZ STACK	/NORMAL RETURN; AC=INTEGER
	CLL RAL
	TAD ACL		/INTEGER IS ALSO IN ACL
	TAD   AF	 /AF+(3*INTEGER)
	DCA I	STACK
	TAD I	STACK		/CHECK FOR IN RANGE
	TAD	SSST
	CLL
	TAD	SSSE
	SZL CLA		/VAL MUST BE IN RANGE INTEND<=VAL<STACK
	JMP I	LFOP
SSC1,	ERROR
	31

SSST,	0		/SET UP TO -START
SSSE,	0		/SET UP TO START-ENDINT-1
/
/ THIS SUBROUTINE SEPARATES THE SIGN, EXPONENT, AND FRACTION
/ RETURN TO CALL + 2 IF ZERO ARGUMENT, ELSE TO CALL + 3
/
LSPLIT, 0
	DCA	TEM	/TEM POINTS TO THE FLOATING POINT NUMBER
	TAD I	LSPLIT	/USE AUTO INDEXING FOR RESULTS
	ISZ	LSPLIT
	DCA	L17
	CLA CLL CML RAR
	AND I	TEM
	DCA I	L17
	TAD I	TEM	/GET THE EXPONENT
	RAR
	RTR
	AND	C377
	DCA I	L17
	TAD I	TEM	/GET THE FRACTION
	ISZ	TEM
	SZA		/DO WE HAVE A ZERO ARGUMENT?
	ISZ	LSPLIT
	AND	C7
	DCA I	L17
	TAD I	TEM
	ISZ	TEM
	DCA I	L17
	TAD I	TEM
	DCA I	L17
	DCA I L17	/CLEAR OVERFLOW BIT
	JMP I	LSPLIT
/
/FETCH ADDRESS		 RETRIEVE NEXT 12 BITS ON EXECUTION LIST
/			 TO BE USED AS ADDRESS.
/
/ENTRY: NO SPECIAL CONDITIONS
/
/EXIT:	AF=12 BIT ADDRESS.
/
FAD,	0
	ISZ	SF		/TEST FOR LH OR RH
	JMP	FAD2		/RH THIS TIME
	JMS	INCORE		/IS XL IN CORE?
	TAD I	XL		/GET A FULL WORD
	ISZ	XL		/BUMP XL POINTER
FAD3,	DCA	AF
	JMP I	FAD		/...RETURN

FAD2,	CLA
	TAD I	XL		/GET RH OF XL
	ISZ	XL
	AND	P77		/MASK OFF
	DCA	TEM		/SAVE IT A WHILE
	JMS	INCORE		/IS XL STILL OK?
	DCA	SF		/NEXT IS RH FETCH
	TAD I	XL		/GET WORD
	AND	C7740		/MASK LH
	RAL CLL
	TAD	TEM		/WOULDN'T BSW BE NEAT
	RTL			/BUT ITS GOT TO RUN ON
	RTL			/AN 8 AND 8I ALSO.
	RTL
	JMP	FAD3

INCORE,	0
	CLA CMA CLL
	DCA	SF		/SET SF
	TAD	LLIMIT		/LINK IS CLEAR
	TAD	XL
	SNL CLA			/SKIP IF XL OUT OF RANGE
	JMP I	INCORE
	TAD	PROGRM
	TAD	PRSIZE
	DCA	AF		/SET UP AF TO FORCE READ
	JMS I	LXAD
	JMP I	INCORE		/ITS IN CORE NOW!
/
/CHARACTER FUNCTION...TYPE A CHARACTER ON THE OUTPUT DEVICE
/
DCHR,	DUMM^100+0		/GET ARGUMENT
	EXIT
	0		/USED TO "FOOL" FRT SUBROUTINE
	JMS I	LFRT	/PSEUDO-FUNCTION RETURN
	JMS I	LFBT	/IS THIS A LEGAL USE OF CHR$
	TAD	DTMP
	SZA CLA
DCHRR,	ERROR		/ILLEGAL USE OF CHR$
	32
	JMS I	LCIN	/CONVERT TO INTEGER
	JMP	DCHRR
	DCA DCHRC
	JMS I	LTYPE		/TYPE CHARACTER
DCHRC,	0
	TAD DCHRC	/RELOAD CHARACTER
	AND	C177
	TAD	M15		/TEST FOR -CR-
	SNA
	JMP DCHR3	/CR MEANS RESET COL POSITION
	TAD CM157	/CHECK FOR PRINTING CHAR
	CLL
	TAD C134
	SNL CLA
	JMP DCHRN	/NO, IT WAS NOT A PRINTING CHAR
DCHR1,	ISZ	LC		/YES, THIS WAS A PRINTING CHAR
C134,	134			/NOP JUST IN CASE
	JMP I LFOP

DCHRN,	TAD I PSASOP	/ARE WE IN LPT MODE
	TAD CM6660
	SZA CLA
	JMP I LFOP	/NO, SO WE'RE ALL DONE
	TAD DCHRC	/YES, CHECK FOR CHAR WHICH RESETS LP08
	AND C177
	TAD M14		/LINE FEED
	SZA
	TAD C2		/FORM FEED
	SZA CLA
	JMP DCHR1	/NOT RESET CHAR; ALL OTHERS CAUSE SPACE
DCHR3,	DCA LC		/RESET COLUMN POSITION
	JMP I LFOP

C2,	2
CM157,	-157
M14,	-14
CM6660,	-6660
PSASOP,	SASOP
/RESTART DATA NUMERIC
/CALLED BY RESTORE*
RDP,	CLA CMA
	DCA	DP		/SET POINTER TO TOP OF CORE
	JMP I	LFOP

PAGE
/
/STORE STACK INDIRECT: USE WORD BELOW TOP ELEMENT
/	AS ADDRESS WHERE TOP ELEMENT IS STORED.
/
/	STACK = STACK-4
/	ERROR(20) CAN BE CALLED
/
SSI,	TAD	M4
	TAD	STACK		/BUMP STACK BACK FOUR
	DCA	STACK
	TAD	STACK		/NOW GET ADDRESS OFF STACK
	DCA	T3		/AUTO INDEX
	TAD I	T3
	DCA	AF		/SET UP ADDRESS
	IAC			/CONSTANT PLUS 1
	JMP	DMOV1
/
/STORE DATA INDIRECT: USE TOP WORD OF STACK AS ADDRESS
/	WHERE NEXT DATA ELEMENT IS TRANSFERRED.
/
/	STACK = STACK-1
/	ERROR(20) CAN BE CALLED
/
DTI,	JMS DNI		/LOAD AF FROM STACK
/SKIP NEXT INSTRUCTION


/MOVE DATA (DIRECT READ)
DTD,	JMS I	LRAD		/LOAD ADDR OF STORE
/
/CHECK DATA POINTERS, AND READ DATA
/SAME ROUTINE HANDLES NUMERIC AND STRINGS
/
CDP,	ISZ	STRFLG		/CHECK FOR STRING
	CLA CMA
	TAD	KDS		/SET TO STRING
	DCA	TEM
	CLA CLL CMA RTL
	TAD I	TEM		/BUMP POINTER DOWN THREE
	DCA I	TEM
	TAD	STRFLG
	SNA CLA
	TAD	DSTBND		/CHECK AGAINST STRING FIELD
	SNA
	TAD	DATBND		/CHECK AGAINST DATA FIELD
	CIA CLL
	TAD I	TEM
	SNL CLA
	ERROR		/OUT OF DATA
	25
	CLA CMA
	TAD I	TEM
	JMP	DMOVE		/MOVE (READ) DATA

KDS,	DS
/THIS SUBROUTINE IS USED BY INI, DTI, AND CHDI
/IT DOES, AS FOLLOWS:	AF_(STACK)
/			STACK_STACK-1
/	SKIP THE INSTRUCTION FOLLOWING CALL.
DNI,	0
	TAD I	STACK
	DCA	AF
	CLA CMA
	JMS I	LCLM
	ISZ	DNI
	JMP I	DNI
/
/STORE STACK:	STORE TOP ELEMENT INTO (A).
/
/EXIT:	STACK-3
/	ERROR (20) CAN BE CALLED
/
SSD,	CLA CLL CMA RTL
	TAD	STACK	/BUMP STACK BACK THREE
	DCA	STACK
	JMS I LRAD	 /FETCH ADDRESS,AF=ADDRESS
DMOV1,	TAD   STACK
DMOVE,	DCA   T3	 /AUTO-INDEX
	TAD I	T3		/MOVE THREE WORDS
	DCA I	AF
	ISZ	AF
	TAD I	T3
	DCA I	AF
	ISZ	AF
	TAD I	T3
	DCA I	AF
	JMP I LFOP		 /FETCH NEXT OPERATION CODE
/
/EXPONENTIATE: RAISE THE NEXT ELEMENT BY THE TOP ELEMENT
/	AND LEAVE RESULT ON TOP (JUST CALL DPOW)
/	STACK=STACK-3
EXP,	CLA CMA		/MAKE EXP AN INTERNAL FUNCTION
	JMP	IFN2			/CALL FUNCTION

/
/INTERNAL FUNCTION: LOAD CONTENTS OF LINK POINTER
/	AND ADDRESS OF NEXT PROGRAM STEP AS NEXT
/	STACK WORDS AND GO TO ROUTINE SPECIFIED
/	BY C. MODE FLAG SET TO ABSOLUTE.
/
/ENTRY: IFN FOR NORMAL FUNCTIONS; IFN1 FOR EXPONENTIATE
/EXIT:	STACK+2
/	ERROR (20) CAN BE CALLED
/
IFN,	JMS I LFBT	 /FETCH NEXT BYTE
	DCA TEM		/SAVE FUNCTION ID
	TAD TEM		/IS THIS A SWAPPED FUNCTION
	TAD M6
	SPA SNA CLA
	JMP I PSWAP	/YES
IFN1,	TAD TEM		/!!! ENTRY POINT AFTER SWAP !!!
IFN2,	TAD	AFNTBL		/ADD TABLE OFSET
	DCA   AF
	TAD   STACK
	DCA   TEM	 /SAVE IT
	ISZ   STACK
	TAD   LP
	DCA I STACK	 /PUT LP ON STACK
	TAD   TEM
	DCA   LP	 /PRESET LP TO STACK
	ISZ   STACK
	TAD   XL
	DCA I STACK	 /LOAD NXT PROG STEP
	JMS I LCLM	 /CHECK STACK LIMIT
	TAD I AF	 /GET ADDRESS OF FUNCTION
	DCA   XL	 /PRESET EXECUTION COUNTER
	CLA CMA		/SET TO LH SIDE
	DCA   SF	 /RESET SIDE FLAG.
/SET MODE FLAG ABSOLUTE ENTRY
SMF,	CLA IAC
	DCA	MF
	JMP I	LFOP	 /RETURN
AFNTBL,       FNTBL
PSWAP,	SWAP
/
/ LOAD INPUT OVERLAY
/
/  INPUT DIRECT, INPUT INDIRECT AND LINPUT OUTPUT "?" IF
/  NECESSARY, SET UP OVERLAY ROUTINE ADDRESS AND CALL SWAPPER.
/
/  CHANGE STRING TO MATRIX DIRECT AND INDIRECT USE THE INPUT
/  ROUTINES.  THEY SET UP OVERLAY ROUTINE ADDRESS AND CALL SWAPPER.
/
/  NOTE THAT INPUT TERMINATE DOES NOT CALL SWAPPER SINCE INPUT
/  OVERLAY MUST ALREADY BE IN CORE WHEN IT IS CALLED.
/
IND,	IAC		/INPUT DIRECT ENTRY POINT
INI,	IAC		/INPUT INDIRECT ENTRY POINT
LINP,	TAD PINP	/LINPUT ENTRY POINT
	DCA TS		/SAVE OVERLAY ROUTINE ADDRESS
	CLA IAC		/SEND "?" IF THIS IS FIRST CALL
	TAD LINF
	SZA CLA
	JMP .+3
	JMS I TEXTS
	QMQM
OVLY,	STA		/INDICATE INPUT OVERLAY REQUEST
	JMP I PSWAP

PINP,	LINPX
PCHG,	CHDIX

CHDD,	IAC		/CHANGE DIRECT ENTRY POINT
CHDI,	TAD PCHG	/CHANGE INDIRECT ENTRY POINT
	DCA TS		/SAVE OVERLAY ROUTINE ADDRESS
	JMP OVLY	/GO CALL SWAPPER
/ ABSOLUTE VALUE FUNCTION 'ABS'

DABS,	DUMM^100+0		/GET THE ARGUMENT
	EXIT		/LEAVE INTERP MODE
	CLA CLL CMA RAL
	TAD	STACK
	DCA	ACH	/ACH POINTS TO THE HI-ORDER WORD
	CLA CLL CMA RAR
	AND I	ACH
	DCA I	ACH
	JMS I	INRENT	/AND RETURN ...
	FNRT^100+0
/RESTART DATA STRING
/CALLED BY RESTORE$
RDS,	TAD	DATBND		/TOP OF STRING
	DCA	DS
	JMP I	LFOP



/
/ NORMALIZE ID
/
NRM,	0
NRM1,	CLA CLL CML RTR
	AND	ID
	SZA	CLA
	JMP  I	NRM
	JMS I	ALS		/LINK IS CLEAR AT THIS POINT!!
	CLA	CMA
	TAD	BE
	DCA	BE
	JMP	NRM1



/
/FUNCTION RETURN(PROGRAM):  USE WORD BELOW TOP
/	WORD OF STACK AS A PROGRAM RELATIVE ADDRESS
/	TO GO TO AND REPLACE THE LINK POINTER WITH
/	NEXT STACK WORD. TOP STACK ELEMENT IS
/	RETAINED. MODE FLAG SET TO PROGRAM.
/
/	CALLS ROUTINE FRT TO PERFORM STACK MANIPULATION
/	FRT COMMON TO FRP & FRA.
/
FRP,	JMS I   LFRT	 /PERFORM FUNCTION.
	JMP I LFOP	 /FETCH NEXT OPERATION CODE

PAGE

/! ! ! ! N O T E ! ! ! !--LOBUFF-1 MUST BE OTHER THAN 240.
SBLPNT,	SUBLST-1		/POINTER TO GOSUB RETURN LIST

/THE FOLLOWING BUFFER IS USED BOTH FOR OUTPUT AND INPUT OPERATIONS
LOBUFF=.

XVAL2,	0		/HIGH ORDER COUNTER
XVAL1,	0		/LOW ORDER COUNTER

/ONCE ONLY CODE GOES INTO THIS BUFFER
CLR,	NOP		/TIME OUT PATCH
/CHANGE NOP TO "JMP CLR3" IF TIMEOUT FEATURE IS DESIRED.
CLR2,	JMS I LRFL	 /READ FILE INITIALLY
	TAD START	/CLEAR VARIABLE AREA
	CIA
	TAD ENDINT
	DCA   XCNT	 /CALC NO LOCS TO BE CLEARED
	TAD   ENDINT
	DCA   T2	 /AOUT-INDEX
CLR1,	ISZ XCNT
	SKP
	JMP I LFOP	/BEGIN
	DCA I T2
	JMP   CLR1
/
LRFL,	RFL		/CALL TO READ FILE ROUTINE

LLIN,	LIN		/SET UP LOCATION
LLINX,	LINX&177+5200	/JMP TO LINX
XXC1,	XC1
XXC2,	XC2
CLR3,	TAD	LLINX
	DCA I	LLIN	/SET UP PATCH
	TAD	XVAL1
	DCA I	XXC1
	TAD	XVAL2
	DCA I	XXC2
	JMP	CLR2

NOPUNCH

*LLIN


/VARIABLES FOR VARIOUS INTERPRETIVE ROUTINES
DSQR1,	0;  0;  0
DSQR2,	0;  0;  0
DTAN1,	0;  0;  0
DLOGX,	0;  0;  0
DPOWA,	0;  0;  0
DPOWR,	0;  0;  0
DPOWX,	0;  0;  0
OB,	ZBLOCK 15

INSIZ=.-LOBUFF

ENPUNCH

*.
/
/DO LIST:     CONTAINS ADDRESS OF CONTROL VARIABLE & STACK
/	      POINTER WHILE DO IS OPERATING. MAX=8
/
DOLST,	      0
	      0
	      0
	      0
	      0
	      0
	      0
	      0
	      0
	      0
	      0
	      0
	      0
	      0
	      0
	      0
/
/
/
/
/SUBRT:       USE TOP WORD OF STACK AS ADDRESS
/	      OF NEXT EXECUTABLE INSTRUCTION.
/	ADDRESS TO GO TO.
/
/	STACK = STACK-1
/	ERROR(20) CAN BE CALLED
/
/EXIT:	AF=PROGRAM ADDRESS
/
SGO,	TAD   BSBLST	 /NO ENTRIES IN LIST?
	TAD   SBLPNT
	SNA CLA
	JMP	SBRERR		/NOTHING ON LIST--ERROR
	TAD I SBLPNT	 /REMOVE STACK POINTER
	DCA   AF
	CMA CLL
	TAD   SBLPNT
	DCA   SBLPNT	 /DECR LIST POINTER
	JMP   SBR1	 /EXIT
/
/GO TO SUBROUTINE:  LOAD ADDESSS OF NEXT PROGRAM STEP
/	AS NEXT STACK WORD AND GO TO PROGRAM LOCATION(A).
/
/
/SUBR WILL MAINTAIN A PUSHDOWN LIST TO KEEP TRACK OF SUBROUTINE
/ENTRIES AND EXITS. THE LIST WILL CONTAIN THE STACK POINTER ON ENTRY.
/THIS ENTRY WILL BE REMOVED ON EXIT.
/
/EXIT:	STACK+1
/	ERROR (20) CAN BE CALLED
/
SBR,	JMS I LFAD	 /FETCH ADDRESS;AF=ADDRESS
	ISZ   SBLPNT	 /INCR LIST POINTER
	TAD   SBLPNT
	AND	P77	/LIST EXTENDS TO LOC 1377
	SNA CLA 	 /LIST EXCEEDED?
SBRERR,	ERROR		/SUBROUTINE ERROR
	33
	TAD   START
	CIA
	TAD   XL	 /AC=XL-START
	TAD   PROGRM	 /AC=REL PROG ADDRESS
	DCA I SBLPNT	 /STORE PROG LOC CNTR
SBR1,	JMS I LXAD	 /EXAMINE ADDRESS IN AF
	JMP I  LFOP	 /FETCH NEXT OPERATION
/
BSBLST,      -SUBLST+1	 /START-1 OF LIST
SUBLST=.
/SUBROUTINE STACK EXTENDS FOR HERE TO END OF PAGE
ZBLOCK	7600-.&177


PAGE
/
/RECOVERABLE ERROR:	 TYPEOUT 2 CHARACTER ERROR MESSAGE & RETURN
/			 TO CALLER.
/
/ENTRY: 2 CHARACTER MESSAGE IN AC
/
RER,	0
	CLA
	TAD I	RER
	DCA I	RINMX
	ISZ	RER
	JMS I	LRLF		/PUT IN A CR-LF
	JMS	TEXTX
RINMX,	RINM			/TYPE OUT THE ERROR MESSAGE

	DCA	SRL		/CLEAR SUPPRESS FLAG
	TAD	LINE
	DCA	SRH
	JMS	RERDIV		/PRINT LINE #
	-1750
	JMS	RERDIV
	-144
	JMS	RERDIV
	-12
	JMS	RERDIV
	-1

	JMS I	LRLF
	JMP I	RER

/
/CONVERT LINE NUMBER:	 CONVERT LINE TO A 1-4 DIGIT NUMBER
/
/THIS ROUTINE PERFORMS A DIVISION, LEAVING THE REMAINDER
/IN ID, AND THE RESULT IN ID1.  IT THEN OUTPUTS THE CHARACTER
/USING ID2 AS A FLAG TO DETERMINE WHETHER OR NOT TO
/SUPPRESS LEADING ZEROS.

RERDIV,	0
	DCA	SRM
RERD1,	TAD	SRH
	TAD I	RERDIV
	SPA			/NO NEED TO TEST LINK SINCE LINE .LS. 3776
	JMP	RERD2
	DCA	SRH
	TAD	C260
	DCA	SRL		/CLEAR SUPPRESS FLAG
	ISZ	SRM
	JMP	RERD1

RERD2,	CLA
	ISZ RERDIV	/INCR RETURN ADDR
	TAD SRM		/IS THIS A SUPPRESSED ZERO
	TAD SRL
	SNA
	JMP I RERDIV	/YES
	DCA .+2		/NO, PRINT IT
	JMS I LTYPE	/  VIA LTYPE SO IT GOES TO CURRENT OUTPUT DEVICE
	HLT		/FILLED WITH OUTPUT DIGIT
	JMP I RERDIV
/OUTPUT ALPHA LITERAL IN PRINT STATEMENT
/STRING IS TERMINATED BY A QUOTE CHARACTER.
/
ALF,	JMS I	LFBT		/GET NEXT PRINT CHAR
	TAD	MQUO
	SNA
	JMP I	APRFEX		/EXIT FORM PRINT
	TAD	PQUO
	JMS	OUT		/OUTPUT CHARACTER
	TAD	OBUFF
	TAD	XOBUFF		/IS THE BUFFER FULL?
	SMA CLA
	JMS	STG		/YES...OUTPUT BUFFER
	JMP	ALF		/NO...CONTINUE

APRFEX,	PRFEX			/EXIT THROUGH ANOTHER ROUTINE
PQUO,	42
XOBUFF,	-LOBUFF-17		/FULL BUFFER IS 17 CHARACTERS
/
/OUTPUT CHARACTER:
/
/OUTPUT CHARACTER IS PASSED A 6 BIT CHARACTER IN AC.
/OUT-PLACES CHARACTER IN CORRECT RANGE (+200 OR +300)
/
/ENTRY: AC=6 BIT CHARACTER
OUT,	0
	AND   P77
	DCA   BYTE	 /SAVE CHARACTER
	TAD   LC	 /LINE COUNT > 72?
	TAD   M110
	SMA CLA
	JMS I	LRLF	 /OUTPUT A CR/LF
OUTA,	TAD	M40		/NOTE! CHANGE TO CLA CMA SOMETIMES
	TAD   BYTE	 /PICK UP THE CHAR AGAIN
	SPA
	TAD   P100	 /CHAR < 40
	TAD   P240	 /CHAR >= 40
	DCA I	OBUFF
	ISZ	OBUFF
	ISZ	LC
	JMP I OUT	 /RETURN

M110,	-110

/OUTPUT A TEXT STRING
/STRING IS PACKED AS IN PAL10
/TEXT PSEUDO-OP FORMAT

/ALTERNATE ENTRY--PRT CALLS TEXTX WITH CLA CMA IN THE AC,
/THIS CHANGES THE CONVERSION FROM STRAIGHT SIXBIT TO
/THE STRING KLUDGE.

TEXTX,	0
	SNA			/SET TO PROPER CONVERSION CODE
	TAD	XTM40
	DCA	OUTA		/SET UP CONVERSION
	TAD I	TEXTX
	DCA	TEM		/SAVE POINTER
	ISZ	TEXTX		/SET FOR EXIT

TEXTX1,	TAD I	TEM		/GET LH CHAR
	CLL RTR;  RTR;  RTR
	SZA
	JMS	OUT		/OUTPUT CHAR
	TAD I	TEM
	AND	P77
	SNA
	JMP	TEXTX2
	JMS	OUT		/OUTPUT CHAR
	ISZ	TEM		/GET NEXT CHAR
	JMP	TEXTX1		/CONTINUE

TEXTX2,	JMS	STG		/OUTPUT STRING
	TAD	XTM40		/RESET OUTA
	DCA	OUTA
	JMP I	TEXTX

XTM40,	TAD	M40
/
/OUTPUT STRING OF CHARACTERS IN OUTPUT BUFFER
/
STG,	      0
	CLA IAC
	TAD   COBUFF
	CIA
	TAD   OBUFF	 /CALC # OF CHARS IN STRING
	SNA		 /EMPTY BUFFER?
	JMP I STG
	CIA		 /FORM 2'S COMP
	DCA	.+2		/NUMBER OF CHARACTERS TO TYPE
	JMS I	STSX		/CALL SAS ROUTINE
	0
COBUFF,	LOBUFF-1		/ADDRESS OF OUTPUT BUFFER
	CLA IAC
	TAD   COBUFF
	DCA   OBUFF	 /RE-INITIALIZE BUFFER PNTR
	JMP I  STG
/
OBUFF,	LOBUFF		 /BUFFER POINTER

STSX,	PSTSX			/ENTRY TO SAS SUBROUTINE
/MOVES THREE WORDS FROM (T3) INTO (T2)
INMOV,	0
	DCA	T3	/SET UP FROM ADDRESS
	TAD I	T3
	DCA I	T2
	TAD I	T3
	DCA I	T2
	TAD I	T3
	DCA I	T2
	JMP I	INMOV

DT72,	2074; 4000; 0	/72 USED BY TAB
PAGE
/TEST:	SUBTRACT TOP ELEMENT FROM NEXT ELEMENT.
/	IF RESULT CORRESPONDS TO C VALUE AS INDICATED
/	BELOW, SET TOP WORD OF STACK TO NON-ZERO.
/	OTHERWISE SET TOP WORD TO ZERO.
/
/	RESULT:EQ 0,NE 0,LS 0,LE 0,GR 0,GE 0
/	C VALUE 1    6	  4    5    2	 3
/
/EXIT:	STACK-5
/	ERROR (20) CAN BE CALLED
/
/IF THE STRING FLAG IS SET, THEN THE SUBTRACT
/IS DONE ABSOLUTE UNSIGNED.
/! ! ! N O T E ! ! ! THIS ROUTINE IS TRICKY IN THE
/WAY IT USES THE LINK BIT.

TST,	CLA CLL CMA RTL
	TAD	STACK
	DCA	T2		/SET POINTER TO B
	TAD	M6
	TAD	STACK
	DCA	T3		/SET POINTER TO A
	TAD	M5
	JMS I	LCLM		/RESET STACK=STACK-5
	JMS I	LFBT		/GET C VALUE
	DCA	TEM

	ISZ	STRFLG
	JMP	TSTG		/GO TO SIGNED SUB HACK
TST1,	DCA	TST3		/CLEAR, TST3 IS NOW: AND 0

	CLA CLL CMA RTL
	DCA	XCNT		/SET UP LOOP
TST2,	TAD I	T2
	CIA CLL
	TAD I	T3		/GET A-B
	SZA CLA
	JMP	TST3		/GO SET AS .GT. OR .LS.
	ISZ	XCNT
	JMP	TST2

	IAC			/A AND B ARE EQUAL!
TST4,	AND	TEM		/CHECK CONDITION CODE
	DCA I	STACK		/SAVE RESULT
	JMP I	LFOP		/RETURN TO FETCH NEXT OP
TST3,	0			/!!!!NOTE--MAY BE SET TO CML
/AT THIS POINT:
/	LINK=1 IMPLIES A.GT.B
/	LINK=0 IMPLIES A.LS.B
	SNL CLA
	IAC
	RTL
/NOW:
/	AC=4 IFF A.LS.B
/	AC=2 IFF A.GT.B
/WASN'T THAT EASY
	JMP	TST4

/ROUTINE SETS TST3 :: CML
/IFF A OR B IS NEGATIVE.
TSTG,	TAD I	STACK		/GET SIGN OF A
	SPA CLA
	JMP	TSTGX
	TAD	T2
	DCA	AX2
	TAD I	AX2		/GET SIGN OF B
	SPA CLA
TSTGX,	TAD	TSCML		/SET TST3 TO A CML!
	JMP	TST1

TSCML,	CML
/
/PRINT: PRINT TOP ELEMENT OF STACK
/
PRT,	CLA CLL CMA RTL
	JMS I LCLM	 /CHECK STACK LIMIT
	TAD   LID	 /ADDRESS OF ID-1
	DCA   T2	 /AUTO-INDEX
	TAD	STACK
	JMS I LINMOV		/MOVE STACK TO LID
	ISZ	STRFLG
	JMP I	LOCA		/GO TO NUMERIC OUTPUT
	DCA	ID+3		/SET UP TERMINATOR FOR STRING
	TAD	PRTX		/LOAD A "CLA CMA" (=7240)
	JMS I	TEXTS		/TYPE STRING
	ID
	JMP I	LFOP		/RETURN TO FETCH


LOCA,	OCA		/OUTPUT CONVERSION ROUTINE
/
/TERMINATE A FIELD: OUTPUT A SPACE IF LAST CHARACTER
/			 OUTPUT WAS A NUMBER.
/
PRF,	ISZ	BYTE
	JMP	PRFEX+1
PRTX,	CLA CMA		/TYPE ONE SPACE ONLY
	JMP	PRZ1-1		/USE PRZ LOOP



/
/TERMINATE A ZONE: SPACE TO NEXT ZONE BOUNDARY
/
PRZ,	TAD   LC	 /LINE COUNT > 56?
	TAD   M70
	SMA CLA
	JMS I	LRLF	 /OUTPUT A CRLF
	TAD   LC
	SNA		 /LC=0?
	JMP	PRFEX+1		/YES, EXIT NOTHING TO DO
PRZ2,	CLL
	TAD   M16
	SNA		 /ON A ZONE?
	JMP	PRFEX+1		/YES, NO SPACING TO DO
	SZL
	JMP   PRZ2
	DCA   T2
PRZ1,	TAD   P240
	JMS I	LOUT
	ISZ   T2
	JMP   PRZ1
PRFEX,	JMS I	LSAS
	DCA	BYTE		/CLEAR FLAG FOR NEXT TIME
	JMP I	LFOP		/RETURN TO NEXT INST.


M16,	-16
/
/NEXT:	ADD THE ELEMENT BELOW TOP WORD OF STACK TO (A) AND LEAVE
/	RESULT AS TOP ELEMENT AND IN (A). THEN GO TO PROGRAM LOCATION
/	GIVEN IN WORD THAT HAD BEEN TOP WORD OF STACK.
/
/EXIT:	STACK+3
/	ERROR (20) CAN BE CALLED
/
NXT,	JMS I LRAD	 /FETCH ADDRESS,AF=ADDRESS
	TAD	AF
	JMS I	PDOPOP	 /POP NEXT ENTRIES OFF DOLST
	JMP I	PDOERR	/ENTRY NOT FOUND
	DCA   STACK	 /PRESET STACK POINTER
	TAD I STACK
	DCA   NXTM	 /SAVE TOP WORD
	TAD   AF	 /(A)
	DCA DE		/ARG2 AND DESTINATION FOR ADD ROUTINE
	TAD   STACK
	DCA   T2	 /SAVE STACK
	CLA CMA CLL RTL
	TAD	STACK	/BUMP STACK DOWN THREE
	DCA	STACK
	TAD   STACK
	DCA BE		/ARG1 FOR ADD ROUTINE
	JMS I LDADD	 /DECADD
	CLA CMA
	TAD   AF
	JMS I LINMOV
	TAD   T2
	DCA   STACK
	TAD   NXTM
	DCA   AF	 /LAST ADDRESS ON STACK
	JMS I LXAD	 /EXAMINE ADDRESS IN AF
	JMP I LFOP	 /FETCH NEXT OPERATION CODE

PDOPOP,	DOPOP
PDOERR,	DOERR
NXTM,	0		/TEMP STORE
QMQM,	TEXT /? /
/
/ DIV - DIVIDE ID BY 10
/
DIV,	0
	CLA CLL
	TAD	C7740
	DCA	TS
DIV1,	TAD	ID
	TAD	C5400
	SMA
	DCA	ID
	CLA
	JMS I	ALS
	ISZ	TS
	JMP	DIV1
	TAD	ID
	AND	C377
	DCA	ID
	JMP I	DIV

PAGE


/CHANGE A$ TO A
CHS,	TAD I	STACK
	DCA	AF		/SAVE POINTER TO ARRAY
	DCA I	STACK		/SET UP FOR SCAN
	DCA	XCNT		/CLEAR COUNTER
	TAD	M4
	JMS I	LCLM
	TAD	STACK
	DCA	TEM		/SAVE POINTER
	DCA	ACS		/ALWAYS POSITIVE
	DCA	ACL		/CLEAR LOW ORDER
	DCA ACO
	STA		/SET FIRST TIME FLAG
	DCA AX3
CHS1,	ISZ	TEM		/NEXT WORD
	TAD I	TEM
	RTR CLL;RTR;RTR		/GET LH CHAR
	JMS	CHSTR		/STORE VALUE
	TAD I	TEM		/GET RH VALUE
	JMS	CHSTR
	JMP CHS1	/YES, CONTINUE

CHS2,	ISZ AX3		/IS THIS FIRST END-OF-STRING CHAR
	JMP CHS21	/NO, DON'T DO ANYTHING
	TAD	XCNT
	DCA	ACM
	TAD	CHXP		/SET UP EXP
	DCA	ACX
	DCA	ACH		/CLEAR HIGH ORDER
	TAD	AF
	JMS I	NORMAC		/LOAD VALUE
CHS21,	TAD XCNT
	TAD M6
	SMA CLA
	JMP I LFOP
	JMP CHSTR1	/FINISH REST OF STRING

/SUBROUTINE CONVERTS VALUE AND NORMALIZES IT
CHSTR,	0
	AND	P77
	SNA
	JMP	CHS2		/ALL DONE
	TAD	P37		/CONVERT VALUE
CHSTR1,	DCA	ACM
	TAD	CHXP		/SET UP EXP
	DCA	ACX
	DCA	ACH		/CLEAR HIGH ORDER
	ISZ	XCNT
	TAD	XCNT
	TAD	XCNT
	TAD	XCNT
	TAD	AF		/ADDRESS FOR ENTRY
	JMS I	NORMAC
	JMP I	CHSTR		/CONTINUE
CHXP,	217			/EXPONENT IS 15 (DECIMAL)
/TAB FUNCTION
/TAB IS A "PSEUDO FUNCTION" THAT IS APPLICABLE ONLY TO
/THE PRINT COMMAND.
/	ERROR (41) MAY BE CALLED

DTAB,	DUMM^100+0		/CONVERT ARGUMENT TO MOD-72
	LSTD;	DT72
	DUMM^100+0
	LSTD;	DT72
	XDVD
	IFUN^100+INT	/INT(ARG/72)
	SMFA^100+XMPY

	XSUB^100+EXIT		/ARG-72*INT(ARG/72)
P37,	37			/LH MUST BE ZERO TO FOOL FRT!!!
	JMS I	LFRT		/PSEUDO RETURN TO PROGRAM
	JMS I	LCIN
D110,	110			/NOP
	TAD	DM110		/TEST FOR ROUNDOFF TROUBLES
	SMA
	CLA CMA			/CORRECT FOR ROUNDOFF
	TAD	D110		/RESTORE VALUE
	DCA	BYTE
	JMS I	LFBT		/GET NEXT COMMAND
	TAD	DTMP		/IS IT A PRT COMMAND?
	SZA CLA
	ERROR		/NO, MISUSED TAB
	41			/IS JUST A NOP

DTAB1,	TAD	BYTE
	CLL CMA IAC		/MAGIC! ! !
	TAD	LC
	SMA SZA
	JMP	DTAB2		/INSERT A -CR-
/NOTE THAT THE LINK=0 AT THIS POINT, UNLESS AC=0!!!!!
DM110,	SNA SZL CLA		/USED AS CONST -110
	JMP I	LFOP		/ALL DONE
	JMS I	LTYPE
	" 			/TYPE A SPACE
	ISZ	LC
	JMP	DTAB1
DTAB2,	JMS I	LTYPE
	215			/INSERT A -CR-
	JMS I	LTYPE
	215			/PUT CR AFTER CR (ALL OTHERS CAUSE SPACE ON LP08)
	DCA	LC		/RESET LC
	JMP	DTAB1		/CONTINUE
/
/FUNCTION RETURN:	 COMMON FOR FRA &FRP
/
/EXIT:	STACK-(3*C+5); AF=ADDRESS; SF=0
FRT,	0
	JMS I LFBT	 /FETCH NEXT BYTE
	DCA   T2
	TAD   T2
	CLL CML RAL
	TAD   T2
	TAD   P7	 /3C+8 FOR AUTO INDEX
	CIA
	TAD   STACK	 /CALC 'TO' ADDRESS
	DCA   T2
	CLA CLL CMA RTL
	TAD   STACK
	DCA   T3	 /STACK-5 FOR AUTO-INDEX
	CLA CLL CMA RTL
	DCA   XCNT
	TAD   M4
	JMS I LCLM	 /DECR STACK-4
	TAD I STACK
	DCA   LP	 /REPLACE LINK POINTER
	ISZ   STACK
	TAD I STACK
	DCA   AF	 /PRESET EXEC CNTR
FRT1,	TAD I T3	 /MOVE ELEMENT DOWN
	DCA I T2
	ISZ   XCNT
	JMP   FRT1
	TAD   T2
	DCA   STACK	 /STACK-(3C+5)
	CLA CMA
	DCA   SF	 /RESET SIDE FLAG.
	JMS I LCLM	 /CHECK STACK LIMIT
	JMS I	LXAD
	DCA	MF	/SET TO PROGRAM
	JMP I FRT	 /RETURN
/


PAGE
/
/
/MATH FUNCTION TABLE: VECTOR TABLE TO INTERNAL FUNCTIONS
/
		DPOW	/-1
FNTBL,		DSIN	/  0
		DCOS	/  1
		DTAN	/  2
		DATN	/  3
		DEXP	/  4
		DLOG	/  5
		DSQR	/  6
		DABS	/  7
		DINT	/ 10
		DRND	/ 11
		DSGN	/ 12
		DTAB	/ 13
		DCHR	/ 14
		DFIX	/ 15
/
/CHECK STACK LIMITS:
/
/ENTRY: AC=STACK VARIATION
/
/EXIT:	NORMAL IF WITHIN STACK LIMITS
/	ERROR(20) IF OUTSIDE LIMITS.
/
CLM,	0
	TAD	STACK
	DCA	STACK		/RESET STACK POINTER
	TAD	HLIMIT		/-TOP OF STACK+1
	TAD	STACK		/CURRENT STACK POINTER
	CLL
	TAD	STKSIZ		/SIZE OF STACK
	SZL CLA
	JMP I	CLM		/NO GOOD

	ERROR		/STACK OVERFLOW
	24

STKSIZ,	ISTACK+1		/STACK POINTER RANGES FROM LLIMIT TO HLIMIT
				/STACK CAN POINT TO LLIMIT-1 WHEN EMPTY


/
/FETCH RELOCATED ADDRESS
/
/ENTRY:  NO SPECIAL CONDITIONS
/
/EXIT:  AF=12-BIT RELOCATED ADDRESS
/
RAD,	0
	JMS I LFAD	/FETCH ADDRESS
	TAD MF		/RELOCATE IT IF ABSOLUTE MODE OR
	CLL RAR		/  ADDR OF CONSTANT (.GE. 4000)
	TAD AF
	SMA SNL
	TAD ENDINT
	DCA AF
	JMP I RAD

NXTADR,	0		/SAVED ADDRESS FOR POSSIBLE DO

/
/LOAD STACK INDIRECT: USE TOP WORD OF STACK AS ADDRESS
/	OF QUANTITY WHICH IS LOADED AS NEXT STACK
/	ELEMENT.
/
/	STACK = STACK+2
/	ERROR(20) CAN BE CALLED
/
LSI,	TAD I	STACK
	DCA	AF		/GET ADDRESS FOR MOVE
	JMP	LODS		/USE LOAD


/
/LOAD STACK:   LOAD QUANTITY POINTED TO BY (A) AS
/	NEXT STACK ELEMENT.
/
/EXIT:	STACK+3
/	ERROR (20) CAN BE CALLED
/
LSD,	JMS	RAD	 /FETCH ADDRESS,AF=ADDRESS
	TAD   AF	 /SAVE ADDRESS FOR NEXT POSSIBLE DO
	DCA	NXTADR
	ISZ	STACK
LODS,	TAD I	AF
	DCA I	STACK
	ISZ	AF		/WORD 1 MOVED
	ISZ	STACK
	TAD I	AF
	DCA I	STACK
	ISZ	AF		/WORD 2 MOVED
	ISZ	STACK
	TAD I	AF
	DCA I	STACK		/WORD 3 MOVED
	JMS	CLM	 /CHECK STACK LIMIT
/FALL INTO FOP!!



/
/ FETCH NEXT OPERATION
/
FOP,	JMS I LFBT	/FETCH NEXT BYTE, I.E. THE OP CODE
	TAD JFOP	/ADD IN THE JMP INSTRUCTION
	DCA .+1
	HLT
JFOP,	JMP I INTBL

ONG,	ERROR		/*** INVALID OPERATION CODE ***
	30


/
/PRINT END-OF-LINE
/
PRL,	JMS I	LRLF		/SEND A CR-LF
	JMP I	LFOP
/
/INTERPRETER INSTRUCTION JUMP TABLE:
/
/ONG=OPERATION INDEFINED.
/TYPE1:
/
INTBL,	NIX	/ 00 = NO-OPERATION
	ADD	/ 01 = ADD
	SUB	/ 02 = SUBTRACT
	MPY	/ 03 = MULTIPLY
	DVD	/ 04 = DIVIDE
	EXP	/ 05 = EXPONENTIATE
	NEG	/ 06 = NEGATE
	SGO	/ 07 = GO TO SUBROUTINE
	LSI	/ 10 = LOAD INDIRECT.
	SSI	/ 11 = STORE INDIRECT
	RDS	/ 12 = RESTART DATA (STRING)
	DTI	/ 13 = STORE DATA INDIRECT
	INI	/ 14 = INPUT INDIRECT
	RDP	/ 15 = RESTART DATA (NUMERIC)
	EXT	/ 16 = EXIT
	END	/ 17 = TERMINATE
/
/TYPE3:
/
	LSD	/ 20 = LOAD STACK DIRECT
	SSD	/ 21 = STORE STACK DIRECT
	SSC	/ 22 = SUBSCRIPT
	DTD	/ 23 = DATA TRANSFER
	IND	/ 24 = INPUT
	LIN	/ 25 = STORE LINE NUMBER
	LDA	/ 26 = LOAD ADDRESS.
	ITM	/ 27 = TERMINATE INPUT
	NXT	/ 30 = NEXT
	GTO	/ 31 = GO TO
	IFZ	/ 32 = IF
	SBR	/ 33 = SUBROUTINE
	FUN	/ 34 = FUNCTION
	DOO	/ 35 = DO
	RDZ	/ 36 = RANDOMIZE
	CHS	/ 37 = CHANGE STRING TO NUMBERS
        CHDD	/ 40 = CHANGE A TO A$
/
/TYPE1:
/
ITPRT,	PRT	/ 41 = PRINT TOP ELEMENT
	ALF	/ 42 = ALPHA OUTPUT
	PRF	/ 43 = END PRINT FIELD
	PRZ	/ 44 = END PRINT ZONE
	PRL	/ 45 = END PRINT LINE
	SSF	/ 46 = SET STRING FLAG
	LINP	/ 47 = LINE INPUT MODE (FOR STRINGS)
/
/TYPE2:
/
	TST	/ 50 = TEST
	IFN	/ 51 = INTERNAL FUNCTION
	FRP	/ 52 = FUNCTION RETURN PROGRAM
	DUM	/ 53 = DUMMY
	SMF	/ 54 = SET MODE FLAG ABSOLUTE
	CHDI	/ 55 = CHANGE A TO A$(I)
	PUT	/ 56 = OUTPUT TO FILE
	GET	/ 57 = INPUT FROM FILE
	OPE	/ 60 = OPEN FILE
	CHN	/ 61 = CHAIN
	CLO	/ 62 = CLOSE FILE (OR RELEASE DEVICE)
	SLE	/ 63 = SLEEP
	UNS	/ 64 = UNSAVE FILE
	LPRT	/ 65 = BEGIN LPRINT
	LPEND	/ 66 = END LPRINT
	ONGT	/ 67 = ON ... GOTO
	SAME	/ 70 = NEW STMNT ON SAME LINE
	LDR	/ 71 = LOAD RELOCATED ADDRESS
	ONG	/ 72 = RESERVED FOR FUTURE USE
	ONG	/ 73 = RESERVED FOR FUTURE USE
	ONG	/ 74 = RESERVED FOR FUTURE USE
	ONG	/ 75 = RESERVED FOR FUTURE USE
	ONG	/ 76 = RESERVED FOR FUTURE USE
	ONG	/ 77 = RESERVED FOR FUTURE USE


PAGE
C17,	17		/MASK...!!!MUST BE FIRST LOC IN PAGE!!!
/
/OUTPUT CONVERSION:
/
CNRM,		NRM	/TRANSFER VECTOR FOR NORMALIZE
CDIV,		DIV	/TRANSFER VECTOR FOR DIVIDE
COCBEY,	OCBEY		/TRANSFER FOR EXIT
/
/
/
C7610,	7610		/USEFUL CONSTANT
C2062,	2062		/0.0000005 SCALED AT B=4 FOR ROUNDING


OCA,	TAD   ID		/ENTRY TO OUTPUT CONVERSION!!!
	SPA CLA
	TAD	C15
	TAD   P240
	JMS I LOUT	 /OUTPUT A CHARACTER
/
/
/
OCB,	TAD   ID	/TEST FOR ID=0
	SNA
	JMP I	COCBEY		/GOTO EXIT
/
	RTR		/SEPARATE ID INTO FRACTION AND EXPONENT
	RAR
	AND   C377
	TAD   C7610
	DCA   BE
	TAD   ID
	AND   C7
	SNA
	TAD	P4		/HACK...TO PROTECT STRINGS FROM DEATH
	DCA   ID
	DCA   DE	/INITIALIZE DE TO 0
/
/
/
OCC,	TAD   DE	/ADJUST DECIMAL EXPONENT BY AC
	DCA   DE	/RESTORE ADJUSTED DECIMAL EXPONENT
	JMS I	CNRM	/PERFORM DECIMAL NORMALIZATION
	TAD   BE
	SPA	SNA	/SKIP IF BINARY EXPONENT GREATER THAN ZERO
	JMP   OCE	/GO TO MULTIPLY BY 10
	CIA
	CLL CML IAC
	SNA
	JMP   OCF1	/GO TO RIGHT SHIFT 3
	CLL CML IAC
	SNA
	JMP   OCF2	/GO TO RIGHT SHIFT 2
	CLL CML IAC
	SNA
	JMP   OCF3	/GO TO RIGHT SHIFT 1
	IAC
	SZA	CLA
	JMP   OCD	/GO TO DIVIDE BY 10
	TAD   ID
	TAD   C5400
	SPA CLA
	JMP   OCF	/GO TO RIGHT SHIFT NONE
/
/
/
OCD,	JMS I	CDIV	/DIVIDE ID BY TEN
	CLA	IAC	/DE IS TO BE INCREMENTED BY 1
	JMP   OCC	/BINARY EXPONENT WILL BE ADJUSTED BY NORMALIZE
/
/
/
OCE,	CLL CLA
	JMS I ARS
	JMS I ARS
	JMS I ARS
	JMS I ARS
	JMS I	LXPY	/MULTIPLY ID BY TEN
	TAD   C4	/ADJUST BINARY EXPONENT BY +4
	TAD   BE
	DCA   BE
	CLA	CMA	/ADJUST DECIMAL EXPONENT BY -1
	JMP   OCC
OCF1,	JMS I ARS	/SHIFT ID RIGHT 3
OCF2,	JMS I ARS	/SHIFT ID RIGHT 2
OCF3,	JMS I ARS	/SHIFT ID RIGHT 1
OCF,	CLA	CLL	/SHIFT ID RIGHT 0
	TAD   C2062	/.0000005 AT A BINARY SCALE OF 4
	TAD   ID2
	DCA   ID2	/ROUND ID BY ADDING .0000005
	SZL CLA
	ISZ	ID1
	JMP	.+3
	ISZ	ID
C4,	4		/CONSTANT FOR ADJUSTING BINARY EXP
	TAD   ID
	TAD   C5400	/TEST FOR 'OVERFLOW'
	SZA	CLA
	JMP   OCG	/JUMP IF NO 'OVERFLOW'
	TAD   C200	/RESET ID TO 1
	DCA   ID
	DCA   ID1
	DCA   ID2
	TAD   DE	/AND ADJUST THE DECIMAL EXPONENT
	IAC
	DCA   DE
/
/
/
OCG,	TAD	C7771	/CONVERT ID FROM BINARY TO DECIMAL
	DCA	T1
	TAD	COB
	DCA	BE
	JMP	OCG2
/
OCG1,	TAD	ID
	AND	C177
	DCA	ID
	JMS I	LXPY
OCG2,	TAD	ID
	RTL
	RTL
	RTL
C200,	AND	C17
	TAD	C260
	DCA I	BE
	ISZ	BE
	ISZ	T1
	JMP	OCG1
	JMP I	COCH	/CROSS PAGE BOUNDARY
COCH,		OCH
/
/
/
/NEGATE: NEGATE TOP ELEMENT OF STACK
/
NEG,	CLA CLL CMA RAL
	TAD   STACK
	DCA	TEM
	TAD I	TEM
	SZA		/IGNORE IF ZERO
	TAD	P4000
	DCA I	TEM	/STORE BACK ON STACK
	JMP I LFOP	 /FETCH NEXT OPERATION


/
/ADD THE SR TO THE AC REGISTER
/
LASRAC,	0
	CLA CLL
	TAD	ACL
	TAD	SRL
	DCA	ACL
	RAL
	TAD	ACM
	TAD	SRM
	DCA	ACM
	RAL
	TAD	ACH
	TAD	SRH
	DCA	ACH
	JMP I	LASRAC

PAGE
/
/
/
OCH,	CLA CLL CML RTL
	TAD	DE	/CHECK FOR FORMAT TYPE
	SNA
	JMP	OCI	/JUMP IF FORMAT = .0NNNNNNN
	SPA
	JMP	OCK	/FORMAT = N.NNNNNNE-EE
	TAD	C7770
	SMA	CLA
	JMP	OCK	/FORMAT=N.NNNNNNE+EE
	JMP	OCJ	/NUMBER WITHIN DIFFICULT RANGE
/
/
/
OCI,	TAD	C256	/OUTPUT DECIMAL POINT FOLLOWED BY ZERO
	JMS I LOUT	 /OUTPUT A CHARACTER
	TAD	C260
	JMS I LOUT	 /OUTPUT A CHARACTER
/
/
/
OCJ,	TAD	C7771	/SCAN OFF TRAILING ZEROES, SETTING T1
	DCA	T1
	TAD	COB6
OCJ1,	DCA	BE
	TAD I	BE
	TAD	C7520
	SZA	CLA
	JMP	OCJ2
	ISZ	T1
	CLA	CMA
	TAD	BE
	JMP	OCJ1
/
OCJ2,	TAD	T1	/SET T1 TO MAX(T1,DE+1)
	TAD	DE	/AC=DE-T1
	SPA	CLA
	JMP	OCJ3
	TAD	DE
	CMA
	DCA	T1
/
OCJ3,	TAD	COB	/OUTPUT T1 CHARACTERS
	DCA	BE
	CLA	IAC	/ADJUSTMENT SUCH THAT DE IS A . POINTER
	JMP	OCJ4+1
/
OCJ4,	CLA	CMA
	TAD	DE
	SZA		/SKIP IF IT IS TIME TO OUTPUT A DECIMAL POINT
	JMP	OCJ5
	TAD	C256
	JMS I LOUT	 /OUTPUT A CHARACTER
OCJ5,	DCA	DE
	TAD I	BE
	JMS I LOUT	 /OUTPUT A CHARACTER
	ISZ	BE
	ISZ	T1
	JMP	OCJ4
	JMP	OCBEX		/EXIT OUTPUT CONVERSION

OCK,	CLA		/OUTPUT THE FRACTIONAL PART OF THE NUMBER
	TAD I	COB
	JMS I LOUT	 /OUTPUT A CHARACTER
	TAD	C256
	JMS I LOUT	 /OUTPUT A CHARACTER
	TAD	COB
	DCA	L17
	TAD	C7772
	DCA	T1
OCK1,	TAD I	L17
	JMS I LOUT	 /OUTPUT A CHARACTER
	ISZ	T1
	JMP	OCK1
/
/
/
	TAD	C305	/OUTPUT THE EXPONENT OF THE NUMBER
	JMS I LOUT	 /OUTPUT A CHARACTER
	CLL
	TAD	DE		/CHECK FOR + OR MINUS EXPONENT
	SPA
	CML CMA IAC		/COMPLEMENT AND SET LINK
	DCA	DE
	RTL			/GET +2 IF MINUS
	TAD	C253		/MAKE A + OR -
	JMS I LOUT	 /OUTPUT A CHARACTER
	DCA	BE
OCL3,	TAD	C7766
	TAD	DE
	SPA
	JMP	OCL4
	DCA	DE
	ISZ	BE
	JMP	OCL3
OCL4,	CLA
	TAD	BE
	SNA
	JMP	OCL5
	TAD	C260
	JMS I LOUT	 /OUTPUT A CHARACTER
OCL5,	TAD	DE
OCBEY,	TAD   C260	 /OUTPUT A 0
	JMS I LOUT	 /STORE IN BUFFER
OCBEX,	JMS I  LSAS	 /OUTPUT A STRING
	CLA CMA
	DCA	BYTE		/SET FLAG FOR SPACE
	JMP I	LFOP		/AND EXIT BACK TO FETCH OP

C253,		253	/ASCII CODE FOR +
C305,		305	/ASCII CODE FOR E
C7520,		7520	/NEGATIVE OF THE ASCII CHARACTER FOR ZERO
C7766,		7766	/MINUS TEN, USED IN CONVERSION OF DE
C7770=M10		/CONSTANT TO COMPARE DE WITH 8
C7772=M6		/CONSTANT -6 TO COUNT DIGITS
COB6,		OB+6	/CONSTANT FOR ADDRESSING OUTPUT BUFFER
/
/IF:	IF TOP WORD OF STACK IS NON-ZERO,GO TO PROGRAM
/	LOCATION (A).
/
/EXIT:	STACK-1
/	ERROR (20) CAN BE CALLED
/
IFZ,	JMS I LFAD	 /FETCH ADDRESS,AF=ADDRESS
	TAD I	STACK
	SZA CLA
	JMS I	LXAD		/PREFORM GOTO
	CLA CMA		 /AC=-1
	JMS I LCLM	 /CHECK STACK LIMIT
	JMP I LFOP	 /FETCH NEXT OPERATION CODE


/
/TERMINATE A LINE: OUTPUT A CR-LF& RESET LINE COUNT
/
RLF,	0
	JMS	TYPE
	215			/CR
	JMS	TYPE
	212			/LF
	TAD I	POBUFF
	TAD	MLOBUF
	DCA   LC	 /CLEAR LINE COUNT
	JMP I RLF
/
POBUFF,	OBUFF
MLOBUF,	-LOBUFF
/
/
/TYPE OUT ONE CHARACTER
TYPE,	0
	CLA
	TAD I	TYPE
TLSOP,	TLS
	CLA
	ISZ	TYPE
	JMP I	TYPE




RINM,	0			/FIRST TWO CHARACTERS OF ERROR
	4011			/" I
	1640			/"N 
	0			/TERMINATE


	PAGE

/
/DO:	IF THE TOP ELEMENT IS GREATER THAN SECOND
/	ELEMENT BELOW WORD TOP ELEMENT AND
/	FIRST ELEMENT IS POSITIVE, OR THE COMPARSION IS
/	LESS THAN AND THE FIRST ELEMENT IS NEGATIVE,
/	GO TO PROGRAM LOCATION(A).
/	STACK=STACK-10
/	ANY OTHER CASE CONTINUES AND.
/	STACK=STACK-3
/
/EXIT:	STACK-10 OR STACK-3 DEPENDING
/	ON COMPARSIONS
/	ERROR (20) CAN BE CALLED
/
DOO,	JMS I LFAD	 /FETCH ADDRESS ,AF=ADDRESS
	CLA CLL CMA RTL
	JMS I LCLM	 /CHECK STACK LIMIT
/
/NOW CHECK TO SEE IF THERE IS ANY GARBAGE ASSOCIATED WITH
/THIS FOR-NEXT LOOP ON THE STACK, AND IF SO FLUSH IT.
	TAD	DOCNT		/SAVE POINTERS BEFORE CALLING DOPOP
	DCA	TEM
	TAD	DOPNT
	DCA	T2
	TAD I	ANXADR
	JMS	DOPOP		/SEARCH STACK FOR THIS VARIABLE
	JMP	DOREST		/NO ENTRY FOUND--ALL OK
	TAD	M7		/COMPUTE POINTERS FOR FLUSH
	DCA	AX3
	TAD	AX3
	TAD	P7
	DCA	AX4
DOCLP,	TAD I	AX4		/I AM TAKING SEVEN WORDS
	DCA I	AX3		/OUT OF THE MIDDLE OF THE STACK
	CLA CLL CMA RTL
	TAD	AX4
	CIA
	TAD	STACK
	SMA SZA CLA
	JMP	DOCLP		/KEEP MOVING

	TAD	M7		/RESET STACK POINTER
	JMS I	LCLM

	TAD	DOPNT
	IAC
	DCA	AX3		/SET UP POINTER TO DOO STACK
DOCPP,	TAD	DOCNT		/I AM TAKING TWO WORDS OUT
	CMA			/OF THE MIDDLE OF THE DOO STACK
	TAD	TEM
	SPA SNA CLA			/SKIP IF THERE IS STILL MORE TO MOVE
	JMP	DOCR
	TAD I	AX3		/MOVE JUST TWO WORDS AT A TIME
	DCA I	DOPNT
	ISZ	DOPNT
	TAD I	AX3
	TAD	M7		/CORRECT FOR THE SEVEN WORDS REMOVED
	DCA I	DOPNT
	ISZ	DOPNT
	ISZ	DOCNT		/COUNT OFF ENTRY
	JMP	DOCPP

DOREST,	TAD	TEM
	DCA	DOCNT		/RESTORE POINTERS
	TAD	T2
	DCA	DOPNT		/RESET DO POINT AND COUNT
/
/DOPUSH:      ENTER CONTROL ADDRESS & STACK PNTR ON LIST
/
/EXIT:	DOCNT+1,DOPNT+2
/
DOCR,	ISZ   DOCNT
	JMP   .+3
DOERR,	ERROR		/NESTING ERROR
	34
	TAD I	ANXADR		/CONTROL ADDRESS SAVED BY LSTD
	DCA I DOPNT	 /PUT ON LIST
	ISZ   DOPNT
	TAD   STACK
	DCA I DOPNT	 /SAVE STACK PNTR ON LIST
	ISZ   DOPNT
	IAC
	TAD   STACK
	DCA DE		/ARG2 AND DESTINATION FOR ADD ROUTINE
	CLA CLL CMA RTL
	TAD   STACK	 /FIRST ELEMENT
	DCA   T4
	TAD	M6
	TAD   STACK
	DCA BE		/ARG1 FOR ADD ROUTINE
	TAD	M7
	JMS I LCLM	 /DECR STACK 1
	TAD I T4
	SNA CLA 	 /FIRST ELEMENT NON-ZERO?
	JMP   DOO3	 /DEFAULT;STEP=0
	CLA STL RAR	/INDICATE SUBTRACT TO BE DONE
	JMS I LDSUB	 /DEC SUBTRACT
	TAD I DE
	SNA
	JMP   DOO3	 /RESULT=0;TOP=SECOND
	SPA CLA 	 /SIGN +?
	CMA		 /NO;STORE -1
	DCA   T1	 /RESULT -=-1; +=0
	TAD I T4	 /FIRST ELEMENT -STEP
	SPA CLA 	 /STEP +?
	JMP   DOO1
	ISZ   T1
	JMP   DOO2	 /STEP- & DIFF -
DOO3,	TAD   P7
	JMS I LCLM	 /DECR STACK-6
	JMP I LFOP	 /FETCH NEXT OPERATION
DOO1,	ISZ   T1
	JMP   DOO3
DOO2,	CMA
	DCA   REMFLG	 /SET REMOVE FLAG
	JMS   DOPOP	 /POP NEXT ENTRIES OFF LIST
	JMP	DOERR	/ENTRY NOT FOUND
	CLA
	JMS I LXAD	 /EXAMINE ADDRESS IN AF
	JMP I LFOP	 /FETCH NEXT OPERATION
/
REMFLG, 0		 /REMOVE FLAG

/
/DOPOP:       REMOVE CONTROL ADDRESS & STACK PNTR FROM LIST
/
/EXIT:	DOCNT-1,DOPNT-2
/
DOPOP,	0
	DCA	T3
POP2,	TAD	DOCNT		/ANY VALUES ON LIST?
	TAD	P11
	SPA SNA CLA
	JMP I	DOPOP		/NOT FOUND EXIT
	CMA
	TAD   DOCNT
	DCA   DOCNT	 /DECR CNT BY 1
	CLA CLL CMA RAL
	TAD   DOPNT
	DCA   DOPNT	 /DECR PNTR BY 2
	ISZ   REMFLG	 /REMOVE FLAG SET?
	SKP		 /NO
	JMP	POPEXI	 /YES, LEAVE
	DCA   REMFLG
	TAD   T3
	CIA
	TAD I DOPNT	 /CONTROL ADDRESSES= ?
	SZA CLA
	JMP   POP2
	TAD   T3
	DCA I	ANXADR	 /SAVE CONTROL ADDRESS FOR DO
	IAC
	TAD   DOPNT
	DCA   T1
POPEXI,	TAD I T1	 /GET STACK PNTR FROM LIST
	ISZ	DOPOP		/NORMAL EXIT IS ENTRY+2
	JMP I DOPOP	 /LEAVE
DOCNT,	      -11 	 /DO COUNT OF ITEMS ON LIST
DOPNT,	      DOLST 	 /DO LIST POINTER
ANXADR,	NXTADR		/ADDRESS OF CONTROL VARIABLE SAVED

PAGE
/
/ LRPT - BEGIN LPRINT STATEMENT
/
LPRT,	TAD DEVSTS	/LPT OR PTP ASSIGNED?
	CMA RTR
	SZL SPA CLA
	JMP LPRT1	/YES
	DCA I PPRC	/NO, SET COLUMN POS TO 0
	TAD C4002	/ASSIGN LPT
	ASD
	SZA CLA		/WAS IT AVAILABLE
	ERROR		/NO
	43		/*** DEVICE BUSY ***
	STA CLL RAL	/INDICATE THAT LPT IS ASSIGNED
	AND DEVSTS
	DCA DEVSTS
	TAD C214	/YES, SEND FORM-FEED AND LP08 AUTOMATICALLY SENDS CR
CLLS,	LLS
LPRT1,	CLA
	TAD CLLS	/LOAD LP08 IOT'S AND PRINT POSITION
LPSWIT,	DCA I CTLSOP	/STORE TLS OR LLS
	TAD I CTLSOP	/STORE SAS OR LST
	TAD M6
	DCA I CSASOP
	TAD LC		/SWAP LPT AND TTY PRINT POSITION COUNTERS
	DCA AX4
	TAD I PPRC
	DCA LC
	TAD AX4
	DCA I PPRC
	JMP I LFOP

CTLSOP,	TLSOP
CSASOP,	SASOP
C214,	214
C4002,	4002

/
/ LPEND - END LPRINT STATEMENT
/
LPEND,	TAD CTLS	/LOAD TELEPRINTER IOT'S AND PRINT POSITION
	JMP LPSWIT
CTLS,	TLS
/
/ CVTFIL - CONVERT FILE NAME FROM MINI-STRING CODE TO SIXBIT CODE
/
/ EXIT:  STACK-3
/	 CONVERTED FILE NAME IN FILNAM+0, +1, +2
/
CVTFIL,	0
	STA CLL RTL	/POP FILE NAME OFF STACK
	JMS I LCLM
	TAD STACK	/INIT POINTERS AND COUNT FOR CONVERSION
	DCA T1
	TAD PSIXB
	DCA T2
	STA CLL RTL
	DCA T4
CVT1,	ISZ T1		/INCREMENT M-S POINTER
	TAD I T1	/GET M-S WORD
	SNA		/WAS IT TWO NULLS?
	JMP CVT2	/YES
	AND P77		/NO, WAS IT LETTER FOLLOWED BY NULL
	SZA CLA
	STA		/NO, SUBTRACT 1 FROM EZCH HALF OF WD
	TAD CM100	/YES, ONLY SUBTRACT 1 FROM LEFT HALF
	TAD I T1	/ADD IN M-S WORD
CVT2,	DCA I T2	/STORE SIXBIT
	ISZ T4		/MORE?
	JMP CVT1	/YES
	JMP I CVTFIL	/NO, RETURN

PSIXB,	FILNAM-1
CM100,	-100
/
/
/
/FUNCTION:    LOAD CONTENTS OF LINK POINTER AND ADDRESS OF
/	      NEXT PROGRAM STEP AS BEXT STACK WORDS AND GO
/	      TO PROGRAM LOCATION (A).
/
/EXIT:	STACK+2
/	ERROR (20) CAN BE CALLED
/
FUN,	JMS I LFAD	 /FETCH ADDRESS;AF=ADDRESS
	TAD   STACK
	DCA   T3
	TAD   LP
	DCA I T3
	TAD	STACK		/SAVE POINTER TO DUMMY ARGS
	DCA	LP
	CLA CLL CML RTL
	JMS I	LCLM		/PUSH STACK POINTER DOWN
	TAD	START		/COMPUTE RELATIVE FILE ADDRESS
	CIA
	TAD   XL
	TAD	PROGRM
	DCA I T3
	JMS I LXAD	 /EXAMINE ADDRESS IN AF
	JMP I LFOP	 /FETCH NEXT OPERATION
/GOTO COMMAND:	JUMP TO NEW LINE
GTO,	JMS I LFAD	/GET LINE ADDRESS
	JMS I LXAD	/BRING INTO CORE; UPDATE POINTERS
	JMP I LFOP	/RETURN TO EXECUTE IT
/RANDOM NUMBER GENERATOR FUNCTION 'RND'

/GENERATES PSEUDO-RANDOM NUMBERS
/USING THE MULTIPLIER METHOD:
/	XN=XN*(2^17+3)MOD 2^27
/	R=XN/2^27

/SEE DECUS 5-25.

DRND,	LSTD
DRNDEX,	DRNDHI			/STORE X IN ACH,ACM,ACL
	SSTD^100+0
	ACH^100+LSTD;DRNDHI			/STORE X IN SRH,SRM,SRL
	SSTD^100+01
	SRH^100+EXIT			/ENTER BINARY
	CLA CLL				/LINK MUST BE CLEARED
	JMS I	ALS			/SHIFT ACH,ACM,ACL LEFT
	JMS I	ADSRAC			/3*XN IN ACH,ACM,ACL
	TAD	DRNDLO			/MULTIPLY XN BY 2^17 MOD 2^27
	RTL
	RTL
	RTL
	DCA	DRNDHI			/HIGH ORDER BITS
	TAD	DRNDHI
	RAR
	TAD	ACM
	AND	C7740			/MASK OFF 6 LOW ORDER BITS
	DCA	DRNDMI			/ADD MIDDLE BITS
	RAL				/GET OVERFLOW
	TAD	ACH
	TAD	DRNDHI
	DCA	DRNDHI			/SAVE HIGH ORDER BIT
	TAD	ACL			/GET LOW ORDER BITS
	DCA	DRNDLO
	DCA	ACS			/CLEAR SIGN
	TAD	P200			/EXPONENT IS ZERO
	DCA	ACX
	TAD	DRNDHI			/GET HIGH ORDER BITS
	AND	P7			/MASK OFF VALID BITS
	DCA	ACH
	TAD	DRNDMI			/GET MIDDLE BITS
	DCA	ACM
	DCA ACO		/CLEAR OVERFLOW BIT
	TAD	DRNDA			/POINTER TO RESULT
	JMS I	NORMAC			/NORMALIZE RESULT
	JMS I	INRENT			/RETURN TO INTERPRETIVE MODE
	LSTD
DRNDA,	SRH				/GET RESULT
	FNRT^100+0				/EXIT ROUTINE

DRNDHI,		1			/RANDOM INTEGER
DRNDMI,		203			/THREE WORDS
DRNDLO,		5555

/VERB:  RANDOMIZE
/RANDOMIZE STARTS OFF THE RANDOM
/NUMBER GENERATOR AT A "RANDOM" POINT.

RDZ,	TAD	DRNDEX
	TOD			/PUT THE TIME OF DAY IN DRNDHI&DRNDMI
	TAD	DRNDMI		/USE ONLY LOW ORDER BITS
	DCA	DRNDHI
	JMP I	LFOP		/EXIT FROM ROUTINE


PAGE

/	FLOATING POINT MULTIPLICATION
/
/MULTIPLY-  TOP TWO ELEMENTS TOGETHER
/	STACK=STACK-3; RESULT ON TOP OF STACK
MPY,	JMS I	LCAD
	TAD BE		/GET ARG1 INTO THE SR
	JMS I	SPLIT
		SRS-1
	JMP	MZRO	/WE HAVE A ZERO ARGUMENT
	TAD DE		/GET ARG2 INTO THE MQ
	JMS I	SPLIT
		MQS-1
	JMP	MZRO	/WE HAVE A ZERO ARGUMENT
	TAD	MQS	/GET THE SIGN BIT
	TAD	SRS
	DCA	ACS
	TAD	MQX	/GET THE EXPONENT
	TAD	SRX
	TAD	CM201
	DCA	ACX
	DCA	ACH
	TAD	CM33	/SHIFT 27 TIMES
	DCA	CTR
	CLL
MULT,	JMS	LARS
	TAD	MQH
	RAR		/SHIFT THE MQ REGISTER RIGHT
	DCA	MQH
	TAD	MQM
	RAR
	DCA	MQM
	TAD	MQL
	RAR
	DCA	MQL
	SZL		/DID WE SHIFT OUT A ZERO OR ONE?
	JMS I	ADSRAC	/IT WAS A ONE, ADD IN THE SR REGISTER
	ISZ	CTR	/TEST THE SHIFT COUNT
	JMP	MULT
DVEND,	TAD DE
	JMS I	NORMAC	/ALL DONE, NORMALIZE
	JMP I	LFOP		/EXIT BACK TO CONTROL LEVEL

ZDVD,	JMS I	RECERR		/0 ERROR
	5760
	DCA	ACS		/FORCE POSITIVE RESULT
	CLA CMA
MZRO,	DCA	TEM
	CLA CMA
	TAD DE
	DCA	L17
	TAD	TEM
	JMS I	ZERO
	JMP I	LFOP		/EXIT
CTR=BE		/THIS IS THE SHIFT COUNTER FOR MULT AND DIVD

/		FLOATING POINT DIVISION

/ NOTE: DIVISION USES THE FOLLOWING ALGORITHM ...
/	DIVIDEND TO THE AC, DIVISOR TO THE MQ REGISTER.
/	IF THE SR AND THE AC HAVE THE SAME SIGN, THEN COMPLEMENT THE
/	SR AND ADD IT TO THE AC.  THE MQ AND THE AC ARE THEN SHIFTED
/	LEFT WITH THE HI-ORDER BIT OF THE AC BECOMMING THE LOW ORDER
/	BIT OF THE MQ.	THE RESULT WINDS UP IN THE MQ AFTER 29 SHIFTS.

/DIVIDE- TOP STACK ELEMENT BY NEXT ELEMENT
/	STACK=STACK-3;	RESULT TO TOP OF STACK
DVD,	JMS I	LCAD
	TAD BE		/GET ARG1 INTO THE SR
	JMS I	SPLIT
		SRS-1
	JMP	ZDVD	/ZERO DIVIDE ERROR ...
	TAD DE		/GET ARG2 INTO THE AC
	JMS I	SPLIT
		ACS-1
	JMP	MZRO	/WE HAVE A ZERO DIVIDEND
	TAD	ACS
	TAD	SRS
	DCA	ACS
	TAD	SRX	/COMPUTE THE EXPONENT
	CIA
	TAD	ACX
	TAD	C177
	DCA	ACX
	DCA	MQL
	TAD	CM35	/SET UP THE SHIFT COUNTER
	DCA	CTR
DVID,	CLA CLL CML RAR
	AND	SRH
	TAD	ACH
	SMA CLA
	JMS I	COM	/COMPLEMENT THE SR
	JMS I	ADSRAC	/AND ADD IT TO THE AC
	TAD	MQL
	RAL		/SHIFT THE MQ REGISTER LEFT
	DCA	MQL
	TAD	MQM
	RAL
	DCA	MQM
	TAD	MQH
	RAL
	DCA	MQH
	CLL			/LINK MUST BE CLEARED
	JMS I ALS
	ISZ	CTR	/TEST THE SHIFT COUNTER
	JMP	DVID
	TAD	MQH	/ALL DONE, MOVE THE MQ INTO THE AC
	DCA	ACH
	TAD	MQM
	DCA	ACM
	TAD	MQL
	DCA	ACL
	JMP	DVEND		/ALL DONE--EXIT
CM35,	-35
ZERO,	LZERO
MQS,	0
MQX,	0
MQH,	0
MQM,	0
MQL,	0
MQO,	0		/OVERFLOW BIT (NEVER USED, BUT CLEARED BY SPLIT)



/
/CONVERT TO INTEGER: CONVERT TOP ELEMENT OF STACK TO INTEGER
/
/ENTRY:  STACK POINTS TO LEAST SIGNIF WORD
/
/EXIT:	STACK=STACK-3
/	RETURNS TO +0 IF INTEGER IS .LT. 0 OR .GT. 4095
/	RETURNS TO +1 OTHERWISE
/
CIN=MQO		/SAVE A LOCATION
	JMS I PLFIX	/MAKE TOP OF STACK INTO INTEGER
	STA CLL RTL	/STACK=STACK-3
	TAD STACK
	DCA STACK
	TAD ACH		/TEST FOR MINUS OR TOO BIG
	SNA
	TAD ACM
	SZA CLA
	JMP I CIN	/MINUS OR TOO BIG
	ISZ CIN		/OK, SO INCR RETURN ADDR
	TAD ACL		/LOAD RESULT INTO AC
	JMP I CIN
PLFIX,	LIFIX
LARS,	0		/THIS ROUTINE SHIFTS THE AC  RIGHT
	TAD	ACH
	RAR
	DCA	ACH
	TAD	ACM
	RAR
	DCA	ACM
	TAD	ACL
	RAR
	DCA	ACL
	RAL
	DCA ACO		/SAVE OVERFLOW BIT FOR ROUNDING
	JMP I	LARS

PAGE

/		FLOATING POINT NORMALIZATION

/ THIS ROUTINE NORMALIZES THE LOCAL AC AND RETURNS THE RESULT
/ TO THE ADDRESS WHICH IS IN THE AC + 1

LNRMAC, 0
	TAD	CM1	/USE AUTO INDEXING
	DCA	L17
LNR1,	TAD	ACH
	TAD	M10
	SPA CLA 	/IS HI-ORDER WORD .GE. 10?
	JMP	RUND
	CLL
	JMS I	ARS	/YES, SHIFT RIGHT
	ISZ	ACX
	JMP LNR1
RUND,	TAD ACO		/ROUND IF NECESSARY
	SZA CLA 	/IS IT?
	ISZ	ACL
	JMP	LEFTST
	ISZ	ACM
	JMP	LEFTST
	ISZ	ACH
	DCA ACO
	JMP LNR1

LEFTST,	TAD ACH		/TEST FOR ZERO
	SNA
	TAD ACM
	SNA
	TAD ACL
	SNA CLA
	JMP LNZRO	/ZERO EXIT
LEF2,	STA CLL RTL
	TAD ACH
	SMA SZA CLA
	JMP COMBIN	/NORMALIZED
	STL STA		/DECREMENT EXPONENT
	TAD ACX		/LINK=0!!!
	DCA ACX
	JMS I ALS	/SHIFT LEFT
	JMP LEF2

COMBIN,	TAD ACX		/GET EXPONENT
	SPA
	JMP UNDERF	/FLOATING POINT UNDERFLOW
	CLL RAL
	RTL
	SPA
	JMP OVERFL	/FLOATING POINT OVERFLOW
	TAD ACS		/SIGN
	TAD ACH		/HIGH-ORDER
LNZRO,	DCA I L17	/STORE FIRST NORMALIZED WORD
	TAD ACM
	DCA I L17	/STORE MIDDLE NORMALIZED WORD
	TAD ACL
	DCA I L17	/STORE LOW-ORDER OF NORMALIZED WORD
	JMP I LNRMAC

UNDERF,	JMS I RECERR
	2516
	JMP LNZRO

OVERFL,	JMS I RECERR
	1726
	STA
	JMS LZERO
	JMP I LNRMAC

/
/ LCOM - GETS TWOS COMPLEMENT OF A TRIPLE PRECISION NUMBER PLUS OVERFLOW BIT
/
/  NUMBER IS IN SR;
/  NON-ZERO AC AT ENTRY CAN BE USED TO HAVE NUMBER ELSEWHERE
/
LCOM,	0
	TAD PSRO
	DCA LZERO	/SET POINTER
	TAD M4
	DCA LNRMAC	/SET COUNTER
	STL		/GET LINK READY FOR THE ACTION
	JMP LCOM2

LCOM1,	STA
	TAD LZERO
	DCA LZERO	/BACKUP POINTER (NOTE LINK FLIPPED)
LCOM2,	RAL CML
	TAD I LZERO
	CML CIA		/OVERFLOW IN LINK
	DCA I LZERO
	ISZ LNRMAC
	JMP LCOM1
	JMP I LCOM
PSRO,	SRO

/		THE FOLLOWING ROUTINE RETURNS EITHER ZERO OR THE
/		MAXIMUM POSITIVE OR NEGATIVE RESULT FROM AN ARITHMETIC
/		OPERATION.  IF ZERO IS IN THE AC ONENTRY THE ROUTINE
/		GENERATES A ZERO, IF MINUS ONE IT GENERATES LARGEST
/		POSSIBLE NUMBER.  SIGN IS DETERMINED BY ACS
LZERO,	0
	CLL	RAR
	SZA
	TAD	ACS
	DCA I	L17
	SZL
	CMA
	DCA I	L17
	SZL
	CMA
	DCA I	L17
	JMP I	LZERO



LALS,	0		/THIS ROUTINE SHIFTS THE AC  LEFT
	TAD	ACL
	RAL
	DCA	ACL
	TAD	ACM
	RAL
	DCA	ACM
	TAD	ACH
	RAL
	DCA	ACH
	JMP I	LALS
/ SIGN FUNCTION 'SGN'

DSGN,	DUMM^100+0		/GET THE ARGUMENT
	EXIT		/LEAVE INTERP MODE
	CLA CLL CMA RAL
	TAD	STACK
	DCA	TEM	/SET UP POINTER
	TAD I	TEM
	SNA		/DO WE HAVE A ZERO ARGUMENT?
	JMP	DSGNZ	/YES
	AND	P4000
	TAD	P2014	/AND MAKE IT A ONE
DSGNZ,	DCA I	TEM
	ISZ	TEM
	DCA I	TEM
	DCA I	STACK
	JMS I	INRENT	/AND RETURN
	FNRT^100+0
/
DPOW1,	2014
DPOW0,	0;	0;	0		/CONSTANTS 1 AND 0
P2014=DPOW1
CM1,	-1

PAGE
/		FLOATING POINT ADDITION AND SUBTRACTION
/ENTER WITH AC=0 FOR ADDITION
/ENTER WITH AC=4000 FOR SUBTRACTION

DADD,	0		/FLOATING POINT ADDITION
	DCA	SBSW
	TAD BE		/GET ARG1 INTO THE SR
	JMS I SPLIT
		SRS-1
	JMP I DADD	/ZERO ARGUMENT, SO WE ARE ALL DONE
	TAD SBSW	/ARE WE SUBTRACTING
	TAD	SRS
	DCA   SRS
	TAD DE		/GET ARG2 INTO THE AC
	JMS I SPLIT
	      ACS-1
	JMP SHFAC	/AC REGISTER IS ZERO
	TAD	ACX
	CIA
	TAD	SRX	/NOW ALIGN THE NUMBERS ...
	SMA		/SHIFT AC OR SR?
	JMP	SHFAC
	DCA	SBSW	/THIS IS THE SHIFT COUNTER
SHFSR,	TAD	SRH
	CLL RAR 	/SHIFT THE SR RIGHT ...
	DCA	SRH
	TAD	SRM
	RAR
	DCA	SRM
	TAD	SRL
	RAR
	DCA	SRL
	RAR
	DCA SRO
	ISZ	SBSW	/DONE SHIFTING?
	JMP	SHFSR	/NOT YET
	JMP	JD1

SHFAC,	CLL CMA		/SHIFT TH FP AC RIGHT
	DCA	SBSW
	TAD	SRX	/SWAP THE EXPONENTS
	DCA	ACX
	JMP SHFA1
	JMS I	ARS	/THIS DOES THE SHIFTING
SHFA1,	ISZ	SBSW	/ALL DONE?
	JMP .-2		/NO

JD1,	TAD ACS		/IS AC NEGATIVE
	SMA CLA
	JMP .+3
	TAD ACOP	/YES, COMPLEMENT IT
	JMS I COM
	TAD SRS		/IS SR NEGATIVE
	SPA CLA
	JMS I COM	/YES, COMPLEMENT IT
	JMS I	ADSRAC	/OK ADD THE SR TO THE AC
	TAD ACO		/PUT ANY OVERFLOW BIT INTO ACO
	TAD SRO		/  NOTE: ACO AND SRO CANNOT BOTH BE NON-ZERO
	DCA ACO
	TAD	ACH
	SMA CLA 	/IS THE RESULT NEGATIVE?
	JMP	.+4
	TAD ACOP	/YES, COMPLEMENT
	JMS I	COM
	CLA CLL CML RAR	/AND SET SIGN BIT
	DCA	ACS
	TAD DE		/SET UP THE ARGUMENTS
	JMS I	NORMAC	/AND NORMALIZE
	JMP I	DADD	/AND RETURN
SBSW,	0		/ADD-SUBTRACT SWITCH
ACOP,	ACO-SRO		/POINTER FOR LCOM
DSUB=DADD		/ENTRIES FOR ADD AND SUB ARE THE SAME
/
/DUMMY: LOAD ELEMENT WHICH IS (C+1)'TH ELEMENT
/	BELOW THE TWO WORDS WHICH ARE AT TOP OF
/	SUB STACK POINTED TO BY LINK POINTER AS
/	NEXT STACK ELEMENT.
/
/EXIT:	STACK+3
/	ERROR (20) CAN BE CALLED
/
DUM,	TAD	STACK
	DCA	T2
	JMS I LFBT	 /FETCH NEXT BYTE
	DCA   T3
	TAD   T3
	CLL RAL
	TAD   T3	 /3*C
	TAD	P3
	CIA			/-3*C-3 FOR AUTO INDEX
	TAD   LP	 /SUB STACK TOP
	JMS I	LINMOV		/MOVE THREE WORDS UP ON STACK
	TAD   P3
	JMS I LCLM	 /CHECK STACK LIMIT
	JMP I LFOP	 /FETCH NEXT OPERATION CODE
/SET STRING FLAG COMMAND
SSF,	CLA CMA
	DCA	STRFLG		/SET STRING FLAG
	JMP I	LFOP



/
/EXIT FROM INTERPRETER:  TREAT LINES FOLLOWING AS MACHINE CODE.
/			 RETURN TO INTERPRETIVE CODE BY JMS I INRENT.
/
/EXIT: TREAT LINES FOLLOWING AS MACHINE CODE. RETURN
/	TO INTERPRETIVE CODE BY JMS INRENT.
/
EXT,	TAD   SF
	SNA CLA
	ISZ XL
	JMP I XL



/
/ CHN - CHAIN
/
CHN,	DCA I PPRGNM	/INDICATE CHAIN TO BASEXR
	TAD P4		/CALL BASEXC
END,	JMP I SYSPRG	/END STMNT PROCESSOR ENTERS HERE AND GOES TO EDITOR
PPRGNM,	PRGNM
XPY,	0		 /MULTIPLY ID BY 10
	JMS I	ALS
	TAD	ID
	DCA	TS
	TAD	ID1
	DCA	TS1
	TAD	ID2
	DCA	TS2
	JMS I	ALS
	JMS I	ALS
	TAD	ID2
	TAD	TS2
	DCA	ID2
	GLK
	TAD	ID1
	TAD	TS1
	DCA	ID1
	GLK
	TAD	ID
	TAD	TS
	DCA ID
	JMP I XPY
/
/ ONGT - ON ... GOTO STATEMENT
/
ONGT,	JMS I LCIN	/MAKE INDEX AN INTEGER
	JMP ONGTE	/INDEX OUT OF RANGE
	CIA		/STORE INDEX AS COUNTER
	DCA T1
ONGT1,	JMS I LFAD	/GET GOTO ADDRESS
	TAD AF		/IS IT THE END MARKER
	SNA CLA
ONGTE,	ERROR		/YES, ERROR
	45		/*** ON INDEX OUT OF RANGE ***
	ISZ T1		/IS INDEX ZERO
	JMP ONGT1	/NO, GO TRY AGAIN
	JMS I LXAD	/YES, BRING GOTO ADDR INTO CORE
	JMP I LFOP	/CONTINUE EXECUTION AT THAT POINT
/ TRUNCATION FUNCTION 'FIX'

DFIX,	DUMM^100+0
	EXIT
	DCA FIXSW
	JMP FIXE

/ INTEGER FUNCTION 'INT'

DINT,	DUMM^100+0		/GET THE ARGUMENT
	EXIT		/LEAVE INTERP MODE
FIXE,	JMS	LIFIX	/MAKE AN INTEGER ...
	DCA ACO		/DON'T ROUND
	JMS	CCOMP	/COMPLEMENT IF NEGATIVE
	CLA CLL CMA RAL
	TAD	STACK
	JMS I	NORMAC	/NORMALIZE AND PUT IT ON THE STACK
	STL CLA RAR	/RESET FIX SWITCH
	DCA FIXSW
	JMS I	INRENT	/BACK TO INTERP MODE
	FNRT^100+0

/ THE FOLLOWING SUBROUTINE CONVERTS THE TOP STACK ITEM TO A TRIPLE
/ PRECISION BINARY NUMBER IN ACH, ACM, AND ACL. NOTE THAT THE NUMBER
/ IS ALWAYS POSITIVE, ITS SIGN IS IN ACS, AND THE PROPER EXPONENT IS
/ IN ACX.  WARNING: IF THE VALUE OF ACX IS NOT EQUAL TO 233 (OCTAL)
/ THEN THE NUMBER IS TOO LARGE TO REPRESENT AS A PRECISE INTEGER VALUE
LIFIX,	0		/CONVERT TO INTEGER
	CLA CLL CMA RAL
	TAD	STACK
	JMS I	SPLIT
	ACS-1
P233,	233
	TAD   CM33	 /DON'T SHIFT MORE THAN 27 TIMES
	DCA	LIFIX1
	JMS	CCOMP	/COMPLEMENT IF NEGATIVE
ALOT,	TAD	ACX
	TAD	M233
	SMA CLA 	/DO WE HAVE AN INTEGER YET?
	JMP I	LIFIX	/YES, WE HAVE THE NUMBER
	TAD	ACS	/PICK UP SIGN BIT
	AND FIXSW
	CLL RAL
	JMS I	ARS	/NO, SHIFT AGAIN ...
	ISZ	ACX
	ISZ	LIFIX1	/SHIFTED 27 TIMES?
	JMP	ALOT
	TAD	P233	/YES, WE HAVE A ZERO OR -1
	DCA	ACX
	TAD ACS		/IF THIS IS FIX, WE HAVE A ZERO; MAKE SURE IT IS POSITIVE
	AND FIXSW
	DCA ACS
	JMP I	LIFIX	/AND RETURN
/
LIFIX1,       0
M233,	      -233

CCACL,	ACL-SRL		/POINTER FOR LCOM


CCOMP,	0		/COMPLEMENT IF ACS < 0
	TAD	ACS
	AND FIXSW
	SMA CLA
	JMP I	CCOMP	/EXIT
	TAD	CCACL
	JMS I	COM
	JMP I	CCOMP



DPOWEE,	LSTD;	DPOWX
	IFUN^100+INT
	SMFA^100+LSTD;	DPOWX
	TEST^100+NE			/IS X AN INTEGER<64
	IFF;	DPOW5T		/IF NOT USE LOGS
	LSTD;	DPOW1

DPOW6T,	LSTD;	DPOWX
	LSTD;	DPOW1
	XSUB^100+SSTD;	DPOWX
	LSTD;	DPOWX
	LSTD;	DPOW0
	TEST^100+LS
	IFF;	DPOW7T
	LSTD;	DPOWA
	XMPY^100+GOTO;	DPOW6T



/ THE FOLLOWING ROUTINE RAISES A NUMBER TO A POWER
/WHEN CALLED BY A^X


/THIS IS A NEW VERSION OF THE POWER ROUTINE
DPOW,	DUMM^100+0
	SSTD			/GET X
DPOWXP,	DPOWX
	DUMM^100+1
	SSTD			/GET A
DPOWAP,	DPOWA
	EXIT
	TAD I	DPOWAP		/TEST A=0
	SNA CLA
	JMP	DPOW1T		/IF SO RETURN 0 RESULT
DPOW9T,	TAD I	DPOWXP
	SPA			/TEST X<0
	JMP	DPOW2T		/IF SO LET A=1/A
	TAD	DP1710		/TEST X>=2^16
	SPA CLA
	JMP	DPOW4T		/IF SO USE LOGS
	JMS I	INRENT
	GOTO;	DPOWEE


DPOW1T,	JMS I	INRENT
	LSTD;	DPOW0
DPOW7T,	FNRT^100+1

DPOW2T,	TAD	P4000
	DCA I	DPOWXP
	JMS I	INRENT
	LSTD;	DPOW1
	DUMM^100+1
	XDVD^100+GOTO;	DPOWAP-1


DPOW5T,	EXIT
DPOW4T,	TAD I	DPOWAP
	SPA
	JMP	DPOW8T
	JMS I	INRENT
	LSTD;	DPOWA
	IFUN^100+LOG
	SMFA^100+LSTD;	DPOWX
	XMPY
	IFUN^100+FEXP
	SMFA
	FNRT^100+1


DPOW8T,	TAD	P4000
	DCA I	DPOWAP
	JMS I	RECERR		/ERROR PW
	2027
	JMP	DPOW9T

DP1710,	1710

PAGE
IFNZRO INTLOW-.&4000 <YOU GOOFED>

/CODE FROM HERE TO END OF INTERPRETERIS EXECUTED ONLY
/IF FILE I/O FACILITIES ARE USED.  IF NONE OF THE
/FOLLOWING STATEMENTS ARE INCLUDED IN THE PROGRAM
/THIS AREA IS USED FOR VARIABLE STORAGE:
/
/	RECORD, OPEN, CLOSE, UNSAVE, GET, PUT
/

/
/ PUT - OUTPUT TO FILE
/ GET - INPUT FROM FILE
/
PUT,	STA
GET,	DCA GPFLG	/SAVE TYPE OF REQUEST
	JMS I LRAD	/GET ADDRESS OF AUTO-INCREMENT VARIABLE
	TAD AF
	DCA DE
	JMS I LRAD	/GET BUFFER ADDR - 1
	TAD AF
	DCA CA
	JMS I LFAD	/GET DISK WORD COUNT
	TAD AF
	DCA DSKCNT
	TAD DSKCNT	/NEGATE WORD COUNT FOR TSS8
	CIA
	DCA DSKWC
	JMS I LFAD	/GET -(NO OF DECTAPE BLOCKS PER RECORD); LEAVE IT IN AF
	JMS I LCIN	/CONVERT REC NO TO INTEGER
	JMP GPE1	/REC NO .LT. 0 OR .GT. 4095
	CMA
	DCA RECCNT	/SAVE -(REC NO + 1)
	TAD PDPOW1	/MAKE 1 THE OTHER ARG OF ADD
	DCA BE
	JMS I LDADD	/PERFORM AUTO-INCREMENT OF REC NO VARIABLE
	JMS I PCHK	/CHECK DEVICE STATUS
	JMP GPDTA	/DTA:  GO DO DECTAPE I/O
	JMP I PERRD	/LPT,PTP:  BAD DEVICE NO.
	SZL		/  DSK  :  IS IT OPEN
	ERROR		/NO
	42		/*** UNOPEN DISK UNIT ***
	ISZ GPFLG	/STORE READ OR WRITE DISK IOT
	STA CLL RAL
	TAD CWFILE
	DCA DSKOP
	DCA DSKHFA	/COMPUTE DISK FILE ADDRESS
	JMP DSKST
DSKLP,	CLL
DSKLP1,	TAD DSKCNT	/  ADD IN NO. OF WDS/REC
	SZL
	ISZ DSKHFA	/  IF OVERFLOW THEN INCREMENT HIGH-ORDER ADDR
DSKST,	ISZ RECCNT
	JMP DSKLP
	DCA DSKLFA	/  STORE REST IN LOW-ORDER ADDR
	TAD DSKWC	/REMEMBER NUMBER OF WORDS TO BE WRITTEN
	CIA		/  IN CASE WE MUST EXTEND
	DCA DSKCNT
	TAD DSKCB	/PERFORM I/O
DSKOP,	HLT		/FILLED WITH WFILE OR RFILE IOT
	STA CLL RAL	/FILE TOO SHORT?
	TAD DSKERR
	SNA CLA
	JMP DSKEXT	/YES, GO EXTEND
	TAD DSKERR	/NO, CHECK FOR OTHER ERRORS
	SZA
GPE2,	ERROR
	50		/*** GET/PUT ERROR ***
	JMP I LFOP	/NO ERRORS SO WE ARE DONE

DSKEXT,	TAD GPFLG	/CHECK FOR PUT OPERATION
	SZA CLA
	ERROR
	47		/*** GET BEYOND END OF FILE ***
	TAD DSKNO	/GET INTERNAL FILE NO
	DCA I EXTCB
	TAD EXTCB	/EXTEND FILE LENGTH BY ONE SEGMENT
	EXTEND
	SPA SNA		/DID EXT OCCURR
	JMP .+3		/YES
	CLA		/NO, IF COULD NOT EXTEND 1 SEG THEN DISK IS FULL
	TAD C7400	/SO MAKE ERROR HANDLER SAY SO
	JMS I SYSIOE	/GO CHECK FOR ERRORS; NO RETURN IF ERROR
	STA STL		/TRICKY SETUP TO UPDATE DISK FILE ADDRESS
	DCA RECCNT
	TAD DSKWC	/SUBTRACT NO OF WORDS THAT WERE NOT WRITTEN
	TAD DSKLFA	/ADD IN STARTING ADDR
	JMP DSKLP1	/GO DO THE REST

GPDTA,	SNL		/WAS IT ALREADY ASSIGNED
	JMP GPDTA1	/YES
	TAD DSKNO	/NO,TRY TO ASSIGN IT
	TAD P4015
	ASD
	SZA CLA		/ASSIGN OK
	ERROR		/NO
	43		/*** DEVICE BUSY ***
GPDTA1,	TAD DSKNO	/GET UNIT NO - 8
	ISZ GPFLG
	TAD C7400	/ADD IN MAGIC NO. TO SET OP TO READ
	TAD C1010	/ADD IN MAGIC NO. TO GET OP CODE TO WRITE
	CLL RTR		/SHIFT UNIT NO AND OP CODE TO CORRECT POSITIONS
	RTR
	DCA DTAOP	/STORE DECTAPE COMMAND WORD
	SKP
	TAD AF		/COMPUTE DECTAPE BLOCK NO
	ISZ RECCNT
	JMP .-2
	CIA
	DCA DTABLK
DTALP,	TAD DTACB	/INITIATE DECTAPE I/O
	DTXA
	DTRB		/READ DECTAPE STATUS BUFFER
	SPA CLA		/SKIP IF NO ERROR OCCURRED
	JMP GPE2	/DECTAPE ERROR
	TAD CA		/UPDATE CURRENT ADDRESS
	TAD C201
	DCA CA
	ISZ DTABLK	/INCREMENT BLOCK NO.
	ISZ AF		/CHECK TO SEE IF DONE
	JMP DTALP	/GO DO ANOTHER BLOCK
	JMP I LFOP	/ALL DONE

DTACB,	DTAOP
DSKCB,	DSKHFA

DSKHFA,	0		/HIGH-ORDER FILE ADDRESS
DSKNO,	0		/INTERNAL FILE NO
DSKWC,	0		/WORD COUNT
CA,	0		/CURRENT ADDRESS
DSKLFA,	0		/LOW-ORDER FILE ADDRESS
DSKERR,	0		/ERROR WORD

DTAOP=DSKNO
DTABLK=DSKWC

FILNAM=CA
RECCNT=DSKERR

EXTCB,	EXTNO
GPFLG,	0
DSKCNT,	0

PDPOW1,	DPOW1		/POINTER TO A FLOATING POINT  1.0
CWFILE,	WFILE
C1010,	1010
C201,	201
PCHK,	CHKDEV
PERRD,	ERRDNO
P4015,	4015

GPE1,	ERROR
	44		/*** INVALID RECORD NO. ***

EXTNO,	0		/FILE NO.
	1		/NO. OF SEGMENTS TO EXTEND

	PAGE
/
/ CHKDEV - CHECK DEVICE STATUS
/
/ CHECKS DEVICE NUMBER AND STATUS
/
/ EXIT:
/	STACK-3; POPS DEVICE NO. OFF STACK
/	BIT IN DEVSTS CORRESPONDING TO DEVICE NO. IS SET TO 0
/	  TO INDICATE DEVICE HAS BEEN REFERENCED
/	BIT IN DNBIT CORRESPONDING TO DEVICE NO. IS SET TO 1;
/	  OTHER BITS IN DNBIT ARE SET TO ZERO
/	DSKNO IS SET AS FOLLOWS:
/	  DEVICE	NO.	DSKNO
/	   DTA0 	 0	 -8
/	   ...		...	 ...
/	   DTA7 	 7	 -1
/	   DSK		 8	  2
/	   DSK		 9	  0
/	   PTP		10	 -12
/	   LPT		11	 -11
/	LINK IS 0 IFF DEVICE WAS "OPEN"
/	LINK IS 1 IFF DEVICE WAS "CLOSED"
/
/ ERROR:
/	DEVICE NO. NOT BETWEEN -(DNLIM) AND 11
/
/ RETURNS TO :
/	+0:  DEVICE IS DTA
/	+1:  DEVICE IS LPT OR PTP
/	+2:  DEVICE IS DSK
/
CHKDEV,	0
	JMS I LCIN	/CONVERT DEV. NO. TO INTEGER
	JMP ERRDNO	/RETURNS HERE IF .LT. 0 OR .GT. 4095
	DCA I DSKN
	TAD I DSKN	/CHECK FOR DEV NO BETWEEN -(DNLIM) AND 9
	TAD DNLIM
	SPA CLA
	JMP ERRDNO
	TAD I DSKN
	TAD CM14
	SMA
	JMP ERRDNO
	DCA T1		/STORE DEV NO - 12
	CLA STL
	RAL		/SET UP 1 IN BIT CORRESPONDING TO DEV
	ISZ T1
	JMP .-2
	DCA DNBIT	/SAVE SELECTION MASK
	TAD DNBIT
	AND DEVSTS	/WAS FILE PREVIOUSLY REFERENCED
	SZA
	STL		/FILE UNREFERENCED MEANS SET LINK TO 1
	CMA		/TURN OFF BIT IN DEVSTS
	AND DEVSTS
	DCA DEVSTS
/
/ LINK=0 IFF DEVICE "OPEN"
/     =1 IFF DEVICE "CLOSED"
/
/ ANY POSSIBLE ROUTE THROUGH THE FOLLOWING CODE HAS THE
/ NET EFFECT ON THE LINK OF LEAVING IT UNCHANGED
/
	TAD I DSKN	/SET DSKNO AND RETURN ADDR AS WE SAID ABOVE
	TAD M10
	SPA
	JMP CHKD3
	TAD CM1A
	SPA SNA
	JMP CHKD4
	TAD M15
CHKD2,	ISZ CHKDEV
CHKD3,	DCA I DSKN
	JMP I CHKDEV

CHKD4,	SZA
	TAD P3
	ISZ CHKDEV
	JMP CHKD2

ERRDNO,	CLA CLL		/INVALID DEVICE NO. ERROR
	ERROR
	46		/*** INVALID DEVICE NO. ***

DNLIM,	0		/-(UNIT NO. OF LOWEST NUMBERED AVAILABLE DTA)
DNBIT,	0
CM1A,	-1
CM14,	-14
/
/ OPE - OPEN FILE
/
OPE,	JMS I LFAD	/GET ELSE ADDRESS
	JMS I PCVT	/CONVERT FILE NAME FROM M-S TO SIXBIT
	JMS CHKDEV	/CHECK FOR PREVIOUSLY REFERENCED DEVICE
	JMP OPASD	/DTA:  OPEN MEANS ASSIGN IT
	JMP OPASD	/LPT,PTP:  JUST ASSIGN IT; NO FORM-FEED
	DCA I OPEACT	/  DSK  :  (RE)OPEN IT
	TAD OPENCB
	OPEN
DSKOPE,	SZA		/ERRORS?
	JMP OPE1	/YES
	TAD I DSKN	/IS THIS DSK 9 (I.E. FILE NO. 0)
	SZA CLA
	JMP I LFOP	/NO, DONE
	TAD FPTR	/YES, SAVE FILE NAME
	DCA T2
	TAD OPEACT
	JMS I LINMOV
	JMP I LFOP

OPE1,	TAD C1000	/WAS IT NON-EXISTENT FILE?
	SZA CLA
	ERROR		/NO
	26		/*** BAD FILE NAME ***
	TAD CRFCB	/YES, CREATE FILE
	CRF
	SZA CLA		/ERRORS?
	ERROR		/YES
	22		/*** CAN'T CREATE FILE ***
	TAD OPENCB	/NO, OPEN IT
	OPEN
	SZA
	JMP OPE1
	TAD I DSKN	/GIVE IT EXTENSION OF "DAT"
	CLL RTL
	RTL
	RAL
	TAD C2212
	PROT
	JMP DSKOPE

OPASD,	SNL		/WAS DTA ALREADY ASSIGNED
	JMP I LFOP	/YES, NOTHING TO DO
	TAD I DSKN	/CONSTRUCT ASSIGN CONSTANT
	TAD C4015
	ASD		/TRY TO ASSIGN THE DEVICE
	SNA CLA		/WAS ASD SUCCESSFUL
	JMP I LFOP	/YES
	TAD AF		/NO, TAKE ELSE BRANCH IF ONE EXISTS
	SNA CLA
	ERROR		/NO ELSE SO GIVE ERROR MSG
	43		/*** DEVICE BUSY ***
	JMS I LXAD	/BRING ELSE ADDRESS INTO CORE
	JMP RESET	/GO TURN OFF OPEN BIT AND EXIT

C1000,	1000
C2212,	2212
PCVT,	CVTFIL
OPEACT,	DSKWC
OPENCB,	DSKNO
DSKN=OPENCB
CRFCB,	FILNAM
FPTR,	UFIL0+1
C4015,	4015
/
/ CLO - CLOSE FILE OR RELEASE DEVICE
/
CLO,	JMS CHKDEV	/GET DEVICE NO.
	JMP CLREL	/  DTA  :  RELEASE DEVICE
	JMP CLREL	/LPT,PTP:  RELEASE IT
	SZL		/  DSK  :  WAS DSK OPEN
	JMP RESET	/NO, GO TURN OFF OPEN BIT AND EXIT
	TAD I DSKN	/YES, SO CLOSE IT
	SNA CLA
	TAD C3000
	TAD C1000
	CLOS
RESET,	TAD DNBIT	/INDICATE DEVICE IS CLOSED
	TAD DEVSTS
	DCA DEVSTS
	JMP I LFOP

CLREL,	TAD I DSKN	/RELEASE DEVICE (WHETHER WE KNOW IT'S ASSIGNED OR NOT)
	TAD C4015
	REL
	CLA
	JMP RESET

C3000,	3000
/
/ UNS - UNSAVE FILE
/
UNS,	JMS CHKDEV	/GET DEVICE NO.
	JMP ERRDNO	/  DTA  :  INVALID DEVICE NO.
	JMP I PERRDN	/LPT,PTP:  INVALID DEVICE NO.
	SZL		/  DSK  :  WAS IT OPEN
	ERROR		/NO
	42		/*** UNOPEN DISK UNIT ***
	STA CLL RAR	/REDUCE FILE BY OCTAL 3777 SEGMENTS
	DCA I REDLEN
	TAD REDCB
	RED
	SNA CLA
	JMP I PRESET	/TURN OFF OPEN BIT AND EXIT
	ERROR
	23		/*** CAN'T DELETE FILE ***

PERRDN,	ERRDNO
REDLEN,	DSKWC
REDCB,	DSKNO
PRESET,	RESET

IFNZRO INTEND-.&4000 <YOU GOOFED>
/END OF INTERPRETER
/INITIALIZE INTERPRETER-PRESETS VARIOUS SYSTEM VARIABLES
LABUFF,	COBUFF		/ADDRESS-1 OF OUTPUT BUFFER
OBUFPT,	OBUFF
OFIL0,	UFIL0
APZSTT,PZSTT-1
APZIMG,PZERO-1
LPZCNT,PZCNT

IIN,	TAD   APZSTT	/PREPARE FOR MOVE OF PAGE  0 CONSTANTS
	DCA   T2
	TAD   APZIMG
	DCA   T3
	TAD	LPZCNT	 /NO ITEMS TO BE MOVED
	DCA   XCNT
PZMOV,	TAD I T2
	DCA I T3
	ISZ   XCNT
	JMP   PZMOV
	TAD P4		/WAS USER FILE 0 OPEN?
	AND DEVSTS
	SZA CLA
	JMP IIN1	/NO
	TAD OFIL0	/YES, REOPEN IT
	OPEN
	JMS I SYSIOE	/CHECK FOR ERROR
IIN1,	STA
	TAD   LLIMIT
	DCA   STACK
	TAD   START
	CIA
	TAD   LLIMIT
	DCA   PRSIZE
	TAD   START
	DCA   XL	 /EXECUTION COUNTER
	DCA   LC
	CLA CMA
	DCA   SF	 /SIDE FLAG
	DCA   MF	 /MODE FLAG
	DCA   AF	 /ADDRESS FLAG
	DCA   LP	 /LINK POINTER
	DCA   BYTE
	CLA CMA		/DATA TOP ADDRESS IS 7777
	DCA   DP
	TAD	DATBND
	DCA	DS
	TAD   LLIMIT
	CIA
	DCA   LLIMIT
	TAD	HLIMIT	/COMPLEMENT HLIMIT
	CIA
	DCA	HLIMIT
	DCA   PROGRM	 /START USER AT 0
	IAC
	TAD I LABUFF	 /AADRESS OF OUTPUT BUFFER
	DCA I OBUFPT
	TAD	START		/SET UP FOR SSC!!!!
	CIA
	DCA I	ASSST
	TAD ENDINT
	CMA
	TAD	START
	DCA I	ASSSE
	TAD I PPRGN	/IS THIS A CHAIN
	TAD CM3737
	SNA CLA
	JMP IINCHN	/NO
	TAD I PLCSAV	/YES, RESTORE TTY POSITION
	DCA LC
	JMP I PCLR	/CLEAR VARIABLE AREA
IINCHN,	JMS I LRLF	/SEND SOME CR-LF'S
	JMS I LRLF
	DCA I PPRC	/SET LPT PRINT POSITION TO LEFT MARGIN
	JMP I PCLR

PLCSAV,	LCSAV
PCLR,	CLR
PPRGN,	PRGNM
CM3737,	-3737
ASSST,	SSST
ASSSE,	SSSE

PZSTT=.
IFNZRO PZSTT-6135 <YOU GOOFED!	/CHANGE PAGE ZERO>


TOPOFCORE=PZSTT-PZCNT
IFNZRO INTSAV-TOPOFCORE&4000 <YOU GOOFED! /FIX INTSAV, ETC.>
*TOPOFCORE

NOPUNCH

*400

ENPUNCH

/
/ FUNCTION OVERLAY STARTUP
/
	JMP I PIFN1	/GO FINISH FUNCTION CALL
PIFN1,	IFN1

K5,	5
DL2000,	2000
DL0203,	203

/
/ SWAP ROUTINE
/
/  AC .EQ. 0:  FUNCTION OVERLAY REQUEST
/  AC .NE. 0:  INPUT OVERLAY REQUEST
/
SWAP,	SNA CLA		/IS THIS FUNCTION OVERLAY REQUEST
	JMP I PIFN1	/YES, SO WE ARE ALL DONE
	TAD K5		/NO, CALL SWAPPER TO LOAD INPUT OVERLAY
	JMP I SYSPRG
/
/TANGENT FUNCTION
/

DTAN,	DUMM^100+0
	IFUN^100+SIN
	SMFA
	DUMM^100+0
	IFUN^100+COS
	SMFA^100+EXIT
	CLA CLL CMA RAL
	TAD	STACK
	DCA	TEM
	TAD I	TEM		/TEST FOR COS(X)=0
	SZA CLA
	JMP	DTAN2		/OK, VALID
	TAD	M6
	JMS I	LCLM		/RESET STACK
	JMS I	INRENT
	LSTD;	DLOGP		/RETURN A LARGE POSITIVE NUMBER AS ANSWER
	FNRT^100+0

DTAN2,	JMS I	INRENT
	XDVD
	FNRT^100+0
/ NATURAL LOG FUNCTION 'LOG'

DLOGZ,	JMS I RECERR	 / ERROR 'LN'
	1416
	JMS I INRENT
	LSTD;	   DLOGM
	FNRT^100+0

/ CONSTANTS FOR LOG ROUTINE




DLOG,	DUMM^100+0		 / X = FRACTION,  EXPONENT STAYS ON STACK
	SSTD
DLOGXP,	DLOGX
	EXIT
	TAD I	DLOGXP
	DCA	ACX
	TAD	ACX
	SPA SNA
	JMP	DLOGZ		/ERROR...ZERO OR NEGATIVE VALUE
	AND	P7
	TAD	DL2000
	DCA I	DLOGXP
	TAD	ACX	/ WE ARE FORMING THE EXPONENT
	RTR; RAR
	AND C377
	TAD	M200
	CLL
	SPA		/ EXPONENT NEGATIVE OR POSITIVE
	CIA CML
	DCA	ACH
	DCA	ACM
	DCA	ACL
	RAR
	DCA	ACS
	TAD	DL0203
	DCA	ACX
	DCA ACO		/DON'T ROUND
	TAD	P3
	JMS I	LCLM	/MAKE ROOM ON STACK
	CLA CLL CMA RAL
	TAD	STACK
	JMS I	NORMAC	 / PUT THE EXPONENT TOGETHER
	JMS I	INRENT
	LSTD;	   DLOGX / X = (X-SQR(.5))/(X+SQR(.5))
	LSTD;	   DLOGS5
	XSUB^100+LSTD; DLOGX
	LSTD;	   DLOGS5
	XADD^100+XDVD
	SSTD;	   DLOGX

	LSTD;	   DLOGX / LOG2(X) = (X*X*(X*X*C5+C3)+C1)*X-.5
	LSTD;	   DLOGX
	XMPY^100+LSTD; DLOGX
	LSTD;	   DLOGX
	XMPY^100+LSTD; DLOGC5
	XMPY^100+LSTD; DLOGC3
	XADD
	XMPY^100+LSTD; DLOGC1
	XADD^100+LSTD; DLOGX
	XMPY^100+LSTD; DLOG5
	XSUB^100+XADD
	LSTD;	   DLOG2 / LOG(X) = ( <EXPONENT> + LOG2(<FRAC>) ) * LOG(2)
	XMPY
	FNRT^100+0
/ DSIN - SINE FUNCTION

DSIN1=DPOW1
DSINX=DPOWA
DSINX2=DPOWR


DSIN,	DUMM^100+0		 / X = ARG / ( 2 * PI )
DCOSE,	LSTD;	   DSIN3
	XDVD^100+SSTD; DSINX
	LSTD;	   DSIN4 / X = 4 * ( X - FIX( X ) )
	LSTD;	   DSINX
	LSTD;	   DSINX
	IFUN^100+FIX
	SMFA^100+XSUB
	XMPY

DSIN10,	SSTD;	   DSINX / IF ABS( X ) <= 1.0 GOTO 20
	LSTD;	   DSINX
	IFUN^100+ABS
	SMFA^100+LSTD; DSIN1
	TEST^100+LE
	IFF;	   DSIN20
	LSTD;	   DSIN2 / X = 2 * SGN( X ) - X
	LSTD;	   DSINX
	IFUN^100+SGN
	SMFA^100+XMPY
	LSTD;	   DSINX
	XSUB^100+GOTO; DSIN10

DSIN20,	LSTD;	   DSINX  / X2 = X * X
	LSTD;	   DSINX
	XMPY^100+SSTD; DSINX2

	LSTD;	   DSINC9 / EVALUATE THE POLYNOMIAL
	LSTD;	   DSINX2
	XMPY^100+LSTD; DSINC7
	XADD^100+LSTD; DSINX2
	XMPY^100+LSTD; DSINC5
	XADD^100+LSTD; DSINX2
	XMPY^100+LSTD; DSINC3
	XADD^100+LSTD; DSINX2
	XMPY^100+LSTD; DSINC1
	XADD^100+LSTD; DSINX
	XMPY
	FNRT^100+0		 /NOW RETURN TO CALLING ROUTINE
/THIS ROUTINE COMPUTES ATN(X)
/THE METHOD IS DESCRIBED BY THE
/FOLLOWING BASIC PROGRAM
/	100 LET T=ABS(X)
/	110 IF T>2^-14 THEN 140
/	120 LET T=X
/	130 RETURN
/	140 IF T<=1 THEN 160
/	150 LET T=1/T
/	160 LET C=0
/	170 IF T<2-SQR(3) THEN 200
/	180 LET T=SQR(3)-4/(T+SQR(3))
/	190 LET C=P/6
/	200 LET T=((((A9*T^2+A7)*T^2+A5)*T^2+A3)*T^2+1.)*T+C
/	210 IF ABS(X)<=1 THEN 230
/	220 LET T=P/2-T
/	230 LET T=SGN(X)*T
/	240 RETURN
/WHERE T IS THE ARCTAN(X), AND P=3.14159...



DATN,	DUMM^100+0
	SSTD
	DATNT
	EXIT
	TAD I	DATNEX
	CLL			/TEST SIGN
	SPA 
	TAD	P4000		/CHANGE SIGN
	DCA I	DATNEX
	SZL
	TAD	DATNQ2		/NEGATE IF MINUS
	DCA	DATN8
	TAD I	DATNEX
	TAD	DATNQ3		/UNDERFLOW TEST
	SMA CLA			/IS ABS(X)<2^-14?
	JMP	DATN1
	TAD	DATNQ8
	DCA	DATN5		/CLEAR RESET FLAG
	JMS I INRENT

	LSTD
DATNEX,	DATNT
	LSTD;	DPOW1
	TEST^100+LE			/IS T .LE. 1
	IFF;	DATN2		/YES, GOTO DATN2
	EXIT
	TAD	DATNQ6
	DCA	DATN5	/SET RESET FLAG
	JMS I INRENT
	LSTD;	DPOW1
	LSTD;	DATNT
	XDVD^100+SSTD;	DATNT	/LET T=1/T
DATN2,	LSTD;	DATNT
	LSTD;	DATN2S
	TEST^100+GE			/IS T .GE. 2-SQR(3)
	IFF;	DATN3		/YES - GO TO CORRECTION ROUTINE
	LSTD;	DPOW0		/LET C=0
DATN4,	SSTD;	DPOWX
	LSTD;	DATNT
	LSTD;	DATNT
	XMPY^100+SSTD;	DLOGX	/COMPUTE T^2
	LSTD;	DATNA9
	LSTD;	DLOGX
	XMPY^100+LSTD;	DATNA7
	XADD^100+LSTD;	DLOGX
	XMPY^100+LSTD;	DATNA5
	XADD^100+LSTD;	DLOGX
	XMPY^100+LSTD;	DATNA3
	XADD^100+LSTD;	DLOGX
	XMPY^100+LSTD;	DPOW1
	XADD^100+LSTD;	DATNT
	XMPY^100+LSTD;	DPOWX
	XADD^100+GOTO
DATN5,	0			/SWITCH IS DATN6 OR DATN8
DATN6,	XNEG^100+LSTD;	DSINC1
	XADD
DATN8,	0			/NEGATE IF NECESSARY
	FNRT^100+0

DATN1,	JMS I	INRENT
	DUMM^100+0
	FNRT^100+0



DATNQ2,	XNEG

DATNQ8,	DATN8
DATNQ3,	2150
DATNQ6,	DATN6

DATNT=DPOWR
/ EXPONENTIAL FUNCTION 'EXP'

DEXPU=DPOWA
DEXPI=DPOWR
DEXPF=DPOWA
DEXPZ1=DLOGP
DEXP2=DLOG2
DEXP5=DLOG5
IFIX,	LIFIX

DEXP,	DUMM^100+0		 / IF  ARG<88.02 GOTO 10
	LSTD;	   DEXP8
	TEST^100+LE
	IFF;	  DEXP10
	LSTD;	  DEXPZ1
	FNRT^100+0
DEXP10,	DUMM^100+0		 / IF ARG>-88.02 GOTO 20
	LSTD;	   DEXP8
	XNEG^100+TEST
	GE^100+IFF;   DEXP20
	LSTD;	   DPOW0
	FNRT^100+0

DEXP20,	DUMM^100+0		 / LET U = ARG/LOG(2)
	LSTD;	   DEXP2
	XDVD^100+SSTD; DEXPU
	LSTD;	   DEXPU
	IFUN^100+INT	 / LET I = INT(U)
	SMFA^100+EXIT
	JMS I	IFIX	 /CONVERT TO AN INTEGER
	TAD	ACL
	IAC
	DCA	DEXPX
	JMS I	INRENT
	SSTD;	DEXPI
	LSTD;	   DEXPU
	LSTD;	   DEXPI
	XSUB^100+SSTD; DEXPF
	LSTD;	   DEXPF
	LSTD;	   DEXPA
	LSTD;	   DEXPB
	LSTD;	   DEXPF
	XMPY^100+LSTD; DEXPF
	XMPY^100+XADD
	LSTD;	   DEXPF
	XSUB^100+LSTD; DEXPC
	LSTD;	   DEXPF
	LSTD;	   DEXPF
	XMPY^100+LSTD; DEXPD
	XADD^100+XDVD
	XSUB^100+XDVD
	LSTD;	   DEXP5
	XADD^100+EXIT
	CLA CLL CMA RAL
	TAD	STACK
	JMS I	SPLIT
		ACS-1
	NOP
	TAD	ACX
	TAD	DEXPX
	DCA	ACX
	CLA CLL CMA RAL
	TAD	STACK
	JMS I	NORMAC
	JMS I	INRENT
	FNRT^100+0


DEXPX,	0		/INTEGER PART
DSIN2,	2024		 / 2.0
	0
	0
DSIN3,	2036		 / 2 * PI = 6.28 ...
	2207
	7325
DSIN4,	2034		 / 4.0
	0
	0

/CONSTANTS FOR THE POLYNOMIAL EVALUATION

DSINC1,	2016		 / 1.5707963   ( PI/2 )
	2207
	7325
DSINC3,	6005		 / -.64596371
	1256
	7406
DSINC5,	1755		 / .07968968
	0632
	1276
DSINC7,	5714		 / -.0046737656
	6223
	1432
DSINC9,	1644		 / .00015148418
	7553
	6722


/ COSINE FUNCTION 'COS'

DCOS,	DUMM^100+0		/COS(X) = SIN(X+PI/2)
	LSTD;	DSINC1
	XADD^100+GOTO;	DCOSE		/FALL THRU SINE ROUTINE

/CONSTANTS FOR EXP FUNCTION
DEXPA,	2044;	7643;	0062
DEXPB,	1744;	3372;	3400
/THIS IS PART OF THE ARCTAN ROUTINE

DATN3,	LSTD;	DSIN4
	XNEG^100+LSTD;	DATNT
	LSTD;	DATNS3
	XADD^100+XDVD
	LSTD;	DATNS3
	XADD^100+SSTD;	DATNT	/LET T=SQR(3)-4/(T+SQR(3))
	LSTD;	DATNP6
	GOTO;	DATN4
/ SQUARE ROOT FUNCTION 'SQR'

DSQR,	DUMM^100+0
	IFUN^100+ABS
	SMFA^100+SSTD;	DSQR1
	DUMM^100+0		/GET THE ARGUMENT
	EXIT		/LEAVE INTERP MODE
	CLA CLL CMA RAL
	TAD	STACK
	JMS I	SPLIT	/PUT IT IN THE LOCAL AC
		ACS-1
	JMP	DSQRZ	/WE HAVE A ZERO
	TAD	ACS
	SNA CLA 	/DO WE HAVE A MINUS ARG?
	JMP	DSQXX
	JMS I	RECERR
	2321
	DCA	ACS
DSQXX,	TAD	ACX	/LOOK AT THE BINARY EXPONENT ...
	TAD	M200
	CLL CML IAC		/THIS IS MAGIC
	SMA SZA		/MORE MAGIC...BUT NECESSARY!!
	CML
	RAR
	TAD	P200	/OK RESTORE BINARY EXPONENT / 2
	DCA	ACX
	TAD	M4
	DCA	DSQRC
	CLA CLL CMA RAL
	TAD	STACK
	JMS I	NORMAC	/NORMALIZE AND PUT IT ON STACK
DSQRA,	JMS I	INRENT
	SSTD;	DSQR2

	LSTD		/STACK = 1/2
	DLOG5
	LSTD
	DSQR1
	LSTD
	DSQR2
	XDVD^100+LSTD	/WE NOW HAVE STACK = N/A
	DSQR2
	XADD^100+XMPY	/ NOW STACK = .5*(N/A+A)
	EXIT		/LEAVE INTERP MODE
	ISZ	DSQRC	/HAVE WE GONE FOUR TIMES?
	JMP	DSQRA
DSQRZ,	JMS I	INRENT	/YES, RETURN THE VALUE ...
	FNRT^100+0
DSQRC,	0
/CONSTANTS
DATNP6,	2004;	1405;	2216	/PI/6
DATN2S,	1774;	2230;	2427	/2-SQR(3)

DATNS3,	2016;	7331;	7272	/SQR(3)
DATNA9,	1756;	0462;	4562	/A9
DATNA7,	5764;	4221;	3403	/A7
DATNA5,	1766;	3141;	6672	/A5
DATNA3,	5775;	2525;	2337	/A3
DLOGP,	3777			/LARGEST POSITIVE NUMBER
DLOGM,	7777;	7777;	7777	/LARGEST NEGATIVE NUMBER
DLOGC5,	2004; 6253; 2521	/C5=.59897864
DLOG5,	2004;	0;	0	/0.5
DLOGC1,	2025;	6125;	1007	/C1=2.8853912
DLOGC3,	2007;	5421;	3604	/C3=.96147063
DLOG2,	2005;	4271;	0300	/LOG(2)=.69314118
DLOGS5,	2005; 5202; 3632	/SQR(.5)=.70710678
DEXP8,	2075; 4007; 1260	/=88.02
DEXPC,	2124;	6477;	0715
DEXPD,	2075;	3552;	7022
TOPOFFUNCS=TOPOFCORE+.-400

	$