/OS8 BASIC RUNTIME SYSTEM, V5C
/
/
/
/
/
/
/
/
/
/
/
/COPYRIGHT (C) 1972, 1973, 1974, 1975
/DIGITAL EQUIPMENT CORPORATION, MAYNARD, MASS.
/
/
/
/THIS SOFTWARE IS FURNISHED UNDER A LICENSE FOR USE ONLY ON A
/SINGLE COMPUTER SYSTEM AND MAY BE COPIED ONLY WITH THE INCLU-
/SION OF THE ABOVE COPYRIGHT NOTICE.  THIS SOFTWARE, OR ANT OTHER
/COPIES THEREOF, MAY NOT BR PROVIDED OR OTHERWISE MADE AVAILABLE
/TO ANY OTHER PERSON EXCEPT FOR USE ON SUCH SYSTEM AND TO ONE WHO
/AGREES TO THESE LICENSE TERMS.  TITLE TO AND OWNERSHIP OF THE
/SOFTWARE SHALL AT ALL TIMES REMAIN IN DEC.
/
/
/THE INFORMATION IN THIS SOFTWARE IS SUBJECT TO CHANGE WITHOUT
/NOTICE AND SHOULD NOT BE CONSTRUED AS A COMMITMENT BY DIGITAL
/EQUIPMRNT COROPATION.
/
/DEC ASSUMES NO RESPONSIBILITY FOR THE USE OR RELIABILITY OF ITS
/SOFTWARE ON EQUIPMENT WHICH IS NOT SUPPLIED BY DEC.
/
/
/
/
/
/
/AUGUST 19, 1972
/
/R.G. BEAN, 1972
/SHAWN SPILMAN, 1973
/ J.K.,1975
/JR	21-APR-77	ADDED EXTENDED DATE CODE, CLEANED UP LISTING
/JR	26-APR-77	TIGHTENED UP STRING ROUTINES
/JR	28-APR-77	ADD SOURCE FIX FOR SEVERAL KNOWN BUGS
/JR	4-MAY-77	REWROTE FLOATING POINT OUTPUT ROUTINE TO INCREASE ACCURACY

// 15-DEC-2018  LHN - ADDED DSN PATCHES TO SOURCE
//			- DSN 31.11.1 M
//			- DSN 21.11.2 M
//		    - INCLUDED BPAT.PA CODE IN SOURCE
//

/
/
	VERSON=	5	/VERSION OF BRTS
			/VERSION LOCATED AT TAG "VERLOC" AND VERLOC+1
			/VERLOC = 260+VERSON
			/VERLOC+1 = 300+SUBVER (01 = A)
	SUBVER=	03	/SUBVERSION OF BRTS
	SUBVAF=	01	/SUBVERSION OF BASIC.AF OVERLAY
	SUBVSF=	01	/SUBVERSION OF BASIC.SF OVERLAY
	SUBVFF=	01	/SUBVERSION OF BASIC.FF OVERLAY
			/FIRST WORD OF EACH OVERLAY CONTAINS
			/60+VERSON IN LEFT HALF AND SUBVERSION OF OVERLAY
			/IN RIGHT HALF.
	MDATE=	7666	/CONTAINS OS/8 DATE IN FIELD 1
	BIPCCL=	7777	/CONTAINS YEAR EXTENSION BITS
	SCOPWD=	7726	/WORD CONTAINING SCOPE FLAG IN 200 BIT
	EDBLK=	7604	/CONTAINS BLOCK NUMBER OF EDITOR
	WIDTH=	120	/WIDTH OF PRINTER
	COLWID=	16	/WIDTH OF ONE PRINT COLUMN
	SACLIM=	120	/DEFINE WIDTH OF STRING ACCUMULATOR
	OVERLAY=3400	/ADDRESS OF START OF 5 PAGE OVERLAY BUFFER



/ASSEMBLY INSTRUCTIONS
/	.R PAL8
/	*BRTS<BRTS.PA/W
/	.R ABSLDR
/	*BRTS$			(THEN SAVE AS SHOWN BELOW)
/

/WHEN ASSEMBLED AND LOADED VIA THE ABS. LOADER,THE
/CORE LAYOUT IS AS FOLLOWS:
/
/BRTS IS AT 0-6777
/OVERLAY BASIC.AF IS AT 3400-4577
/OVERLAY BASIC.SF IA AT 12000-13177
/OVERLAY BASIC.FF IS AT 13400-14577
/
/TO CREATE SAVE IMAGE FILES PRIOR TO RUNNING BASIC,
/ASSEMBLE THIS SOURCE IN A 12K OR MORE MACHINE,THEN
/PERFORM THE FOLLOWING SEQUENCE OF OS/8 COMMANDS
/
/.R ABSLDR
/*BRTS$
/.SAVE SYS:BRTS 0-6777
/
/.SAVE SYS:BASIC.AF 3400-4577
/
/.SAVE SYS:BASIC.SF 12000-13177
/
/.SAVE SYS:BASIC.FF 13400-14577
/
/THE BASIC RUN-TIME SYSTEM IS CONDITIONALIZED TO TAKE ADVANTAGE
/OF THE PDP-8/E KE8/E EAE OPTION.
/NORMALLY,THE SYSTEM IS ASSEMBLED SUCH THAT IT WILL RUN ON ANY
/PDP-8 OR PDP-12. TO TAKE ADVANTAGE OF THE ADDITIONAL HARDWARE,SET
/THE SWITCH EAE=1 IF THE SYSTEM INCLUDES A KE8/E EAE.
/YOU MAY DO THIS BY CONCATENATING TTY: ONTO BRTS.PA AS FOLLOWS
/.PAL EABRTS<TTY:,SYS:BRTS.PA/W
/EAE=1
/^Z
/^Z
/.   BINARY IS CREATED...
/NOW EABRTS IS LOADED INSTEAD OF BRTS
/TO GET A LISTING, USE THE /J SWITCH TO INHIBIT THE FPP CODE YOU
/ARE NOT USING (EAE ON A NON EAE ASSEMBLY FOR EXAMPLE)

/EAE=0		/USE STANDARD FLOATING POINT PACKAGE
/EAE=1		/USE EAE FLOATING POINT PACKAGE
/
/V4 FIXES
/.EAE ADD FOR NUMS <.00001 TO 0
/.FILE INPUT FROM TTY
/.OUTPUT OF NUMS > 80,000
/.STRING FETCH WHEN COUNT IS IN ONE FLD &
/   TEXT IS IN THE NEXT
	AC4000=	CLA STL RAR
	AC2000=	CLA STL RTR
	AC0002=	CLA STL RTL
	AC7775=	CLL STA RTL
	AC7776=	CLL STA RAL
	AC3777=	CLL STA RAR
	AC5777=	CLL STA RTR

	IFNDEF EAE <EAE=0>

	/PAGE 0 LOCATIONS

	*6
USECON,	0		/USE CONSTANT GENERATED BY "USE" STATEMENT
FSTOP1,	FSTOPI		/POINTER TO RTS EXIT ROUTINE USED
			/BY ^C HOOKS IN SYSTEM HANDLER.
			/IF THIS IS MOVED, BLOAD MUST BE ALTERED

	*10
SACXR,	15		/INDEX REGISTER FOR STRING ROUTINES
XR1,	VCHECK
XR2,	0
XR3,	0
XR4,	4		/INDEX REGISTERS
XR5,	0
DATAXR,	0		/POINTER FOR IN-CORE DATA LIST
SPINNR,	2713		/AT RUNTIME,THIS LOCATION IS SPUN FOR RND SEED

	*20

/COMPILER-INTERPRETER CONTROL BLOCK. LOCATIONS MARKED BY
/A /* ARE EXPECTED TO CONTAIN VALUES SUPPLIED BY THE COMPILER PRIOR
/TO THE BRTS LOAD

CDFIO,	6211		/* CDF FOR I/O TABLE AND SYMBOL TABLES
SCSTRT,	0		/* POINTER TO START OF SCALAR SYMBOL TABLE
ARSTRT,	0		/* POINTER TO START OF ARRAY SYMBOL TABLE-1
STSTRT,	0		/* POINTER TO START OF STRING SYMBOL TABLE-1
SASTRT,	0		/* POINTER TO START OF STRING ARRAY TABLE-1
CDFPS,	0		/* CDF FOR START OF PSEUDO-CODE
PSSTRT,	0		/* POINTER TO START OF PSEUDO CODE-1
DLSTOP,	0		/* POINTER TO TOP OF DATA LIST
DLSTRT,	0		/* POINTER TO BOTTOM OF INCORE DATA LIST-1
PSFLAG,	0		/* OS/8 SWAPPING FLAGS WORD
			/BIT 0 SET IF OS/8 SAVED IN N7400 INSTEAD OF N7600 (TD8E)
			/BIT 1 SET IF ROM TD8E HANDLER NOT NEEDING CDF CHANGES
			/BIT 11 SET IF 17600 IS IN 17600. BIT 11 TOGGLED BY
			/PSWAP ROUTINE

/SYSTEM REGISTERS

SACLEN,	0		/LENGTH OF STRING IN SAC
S1,	0		/SUBSCRIPT 1 (MUST BE FOLLOWED BY S2!)
S2,	0		/SUBSCRIPT 2 (MUST BE PRECEEDED BY S1!)
DMAP,	0		/MAP OF DRIVER PAGES
BMAP,	0		/MAP OF FILE BUFFERS

	*37
/FLOATING POINT PACKAGE LOCATIONS. THE FOLLOWING 21 LOCATIONS ARE USED
/FOR VARIOUS PURPOSES BY THE FLOATING POINT PACKAGE. THOSE WITH DOUBLE
/LABELS ARE USED BY BRTS AS TEMPORARIES WHEN NOT CALLING THE PACKAGE.
/THE SECOND TAG IS THE ONE USED BY THE FLOATING POINT PACKAGE,THE FIRST
/IS USED BY BRTS.

FF,	0		/SPECIAL MODE FLIP-FLOP
TEMP1,
AC0,	0
AC1,	0
TEMP3,
AC2,	0	
TM,
TEMP4,	6201
ACX,	0		/FAC-EXPONENT
ACH,	0		/FAC-HIGH ORDER MANTISSA
ACL,	0		/FAC-MANTISSA LOW
TEMP5,
OPX,	0
TEMP6,
OPH,	0
TEMP7,
OPL,	0
DSWIT,	0		/SWITCH USED BY INPUT ROUTINE
CHAR,	215		/TERMINATOR OF LAST INPUT
TEMP10,	0		/LOC NEEDED BY FPP

	DECEXP=	TEMP10

	/SYSTEM REGISTERS USED OFTEN BY INTERPRETER CODE

MODESW,	0		/0 FOR ARTHIMETIC MODE,1 FOR STRING MODE
INSAV,	0		/CURRENT PSEUDO-INSTRUCTION BEING EXECUTED
LINEHI,	0		/HI ORDER BITS OF LINE # CURRENTLY BEING EXECUTED
LINELO,	0		/LOW ORDER BITS OF CURRENT LINE NUMBER
STRMAX,	0		/MAXIMUM # OF CHARS ALLOWED IN CURRENT STRING
STRCNT,	0		/- # OF CHARACTERS IN CURRENT STRING
STRPTR,	0		/POINTER TO SIZE WORD OF CURRENT OPERAND STRING
TEMP2,	0

/I/O TABLE POINTER AREA-THIS BLOCK HOLDS POINTERS TO THE I/O TABLE
/ENTRY FOR THE CURRENT FILE.THE POINTERS ARE CHANGED EVERY TIME AN
/SFN IS EXECUTED. A TAD I OFF ONE OF THE POINTERS WILL GET THE INFORMATION
/NOTED IN THE COMMENT FOR THE CURRENT I/O DEVICE
/THIS BLOCK IS INITIALIZED FOR TTY

	IOTSIZ=	15	/CURRENT SIZE OF IO TABLE

	/THE FORMAT OF THE HEADER WORD IS AS FOLLOWS
	/BITS	USAGE
	/0-3	OS/8 DEVICE NUMBER
	/4-5	3 FOR 2 CHARACTER UNPACKING COUNT
	/6	SET IF BUFFER HAS BEEN MODIFIED AND NEEDS TO BE WRITTEN
	/7	SET IF NOT FILE STRUCTURED DEVICE
	/8	SET IF HANDLER IS 2 PAGES LONG
	/9	SET IF VARIABLE LENGTH (OUTPUT) FILE
	/10	SET IF EOF
	/11	SET IF ASCII FILE, CLEAR IF NUMERIC IMAGE FILE


ENTNO,	0		/ENTRY NUMBER NOW IN AREA 
IOTHDR,	TTYF		/HEADER WORD
IOTBUF,	TTYF+1		/BUFFER ADDRESS
IOTBLK,	TTYF+2		/CURRENT BLOCK IN BUFFER
IOTPTR,	TTYF+3		/READ\WRITE POINTER
IOTHND,	TTYF+4		/HANDLER ENTRY POINT
IOTLOC,	TTYF+5		/FILE STARTING BLOCK #
IOTLEN,	TTYF+6		/ACTUAL FILE LENGTH
IOTMAX,	TTYF+7		/	DEVICE / (FILE MAXIMUM LENGTH)
IOTPOS,	TTYF+10		/	NAME / (POSITION OF PRINT HEAD)
IOTFIL,	TTYF+11		/
/	TTYF+12		/	FILE
/	TTYF+13		/	NAME
/	TTYF+14		/	.EX

IOTDEV=	IOTMAX
	*200

	/FETCH NEXT PSEUDO WORD

PWFECH,	JMP	START1	/START ONCE ONLY CODE IN TTY BUFFER
	ISZ	INTPC	/BUMP PSEUDO-CODE PROGRAM COUNTER
	JMP	CDFPSU	/NO-SKIP;JUST GET NEXT PSEUDO-CODE WORD
	TAD	CDFPSU	/SKIP MEANS WE HAVE TO INCREMENT PS-CODE FIELD
	TAD	[10
	DCA	CDFPSU
CDFPSU,	VCHECK		/SET DF TO FIELD OF PSEUDO-CODE
	TAD I	INTPC	/GET NEXT WORD OF CODE
	CDF 0		/SET DATA FIELD BACK TO INTERPRETER FIELD
	JMP I	PWFECH	/RETURN
O7770,	7770

SSMODE,	IAC		/SET INTERPRETER TO STRING MODE
AMODE,	DCA	MODESW	/SET INTERPRETER TO ARITH MODE
			/FALL BACK INTO I-LOOP

	/BRTS I-LOOP

ILOOP,	CLA CLL		/FLUSH
	DCA	FF	/PUT FPP IN SI MODE
	JMS	PWFECH	/GET NEXT PSEUDO-INSTRUCTION
	DCA	INSAV	/SAVE FOR LATER
	JMS I	[XPRINT	/CALL TO TTY DRIVER
	NOP
	TAD	INSAV
	AND	[7400	/STRIP TO OPCODE BITS
	CLL RTL
	RTL
	RAL		/OPCODE NOW IN BITS 8-11
	TAD	O7770	/SUBTRACT 10
	SMA 		/IS OPCODE <10?
	JMP	SCASE	/CALL TO INSTRUCTION COMMON TO SMODE AND AMODE
	DCA	TEMP1	/YES-SAVE THE OFFSET
	TAD	MODESW	/WHICH MODE?
	SZA CLA
	JMP	SMODE	/STRING MODE
	TAD	TEMP1	/ARITHMETIC MODE-GET OFFSET
	TAD	JMSI	/MAKE JMS TO FP PACKAGE ROUTINE
	DCA	.+2		/PUT IN LINE
	JMS	ARGPRE	/SET UP ARGUMENT FROM SYMBOL TABLE
ILOOPF,	.		/JMS TO THE FLOATING POINT PACKAGE ROUTINE
	NOP		/FPP SOMETIMES RETURNS TO CALL+2
	JMP	ILOOP	/DONE

SCASE,	TAD	JMPI	/JUST DISPATCH TO ROUTINE CALLED FOR
	DCA	.+1
	.		/JUMP TO APPROPRIATE ROUTINE

JMSI,	JMS I	SEP1	/JMS USED FOR CALLS TO FPP BY AMODE INST
JMPI,	JMP I	SEP1	/JMP USED TO CALL ROUTINES COMMON TO AMODE AND SMODE
	/JUMP TABLE FOR AMODE INSTRUCTIONS

	FFADD		/FAC_C(A)+FAC		OPCODE 0
	FFSUB		/FAC_FAC-C(A)		OPCODE 1
	FFMPY		/FAC_FAC*C(A)		OPCODE 2
	FFDIV		/FAC_FAC/C(A)		OPCODE 3
	FFGET		/FAC_C(A)		OPCODE 4
	FFPUT		/C(A)_FAC		OPCODE 5
	FFSUB1		/FAC_C(A)-FAC		OPCODE 6
	FFDIV1		/FAC_C(A)/FAC		OPCODE 7
/ALL INSTRUCTIONS BEYOND THIS POINT ARE COMMON TO AMODE AND SMODE
SEP1,	LS1I		/S1_C(A)		OPCODE 10
	LS2I		/S2_C(A)		OPCODE 11
	FJOCI		/IF TRUE,PC_C(PC,PC+1)	OPCODE 12
	JEOFI		/IF EOF,PC_C(PC,PC+1)	OPCODE 13
	LINEI		/LINE NUMBER		OPCODE 14
	ARRAYI		/ARRAY INST		OPCODE 15
	ILOOP		/NOP			OPCODE 16
	OPERI		/OPERATE INST		OPCODE 17


SMODE,	TAD	TEMP1	/INST OFFSET
	TAD	JMSSI	/BUILD JMP OFF STRING TABLE
	DCA	SDIS	/PUT IN LINE
	CLL		/STRING SCALAR TABLE
	JMS I	STFINL	/SET UP ARGUMENT ADDRESS
SDIS,	.		/CALL STRING ROUTINE REQUESTED


/JUMP TABLE FOR SMODE INSTRUCTIONS
/ A "/*" IN THE COMMENT MEANS THAT THAT OPCODE IS NOT USED,SO WE
/USE THE SLOT FOR REGULAR STORAGE

	SCON1		/SAC_SAC&C(A$)		
	SCOMP		/IF SAC .NE. C(A$),PC_PC+2
	SREAD		/C(A$)_DEVICE
INTPC,	.		/* INTERPRETER PC
	SLOAD		/SAC_C(A$)
	SSTORE		/C(A$)_SAC
STFINL,	STFIND		/* LINK TO STRING FINDING ROUTINE
JMSSI,	JMP I	.+1	/* DISPATCH JUMP FOR SMODE INSTRUCTIONS
/ARGPRE-ROUTINE TO TRANSLATE OPERAND FIELD INTO 12 BIT POINTER
/INTO SCALAR TABLE FOR USE IN FPP CALLS.

ARGPRE,	0
	TAD	INSAV	/GET INSTRUCTION
	AND	[377	/STRIP TO OPERAND FIELD
	DCA	TEMP1	/SAVE
	TAD	TEMP1
	CLL RAL		/*2
	TAD	TEMP1	/PTR*3
	TAD	SCSTRT	/MAKE 12 BIT ADDR
SCALDF,	1000		/DF TO SCALAR FIELD (CDF INITIALIZED BY LOADER)
	JMP I	ARGPRE	/RETURN

/ROUTINE TO ZERO FAC

FACCLR,	-4
L7600,	7600		/CLA
	DCA	ACX	/ZERO EXPONENT
	DCA	ACL	/ZERO LOW MANTISSA
	DCA	ACH	/ZERO HIGH MANTISSA
	JMP I	FACCLR

	/STRING ACCUMULATOR USED BY STRING OPCODES AND FUNCTIONS
	/CONTAINS ONE 6BIT CHAR PER WORD

START1,
SAC,	OSR
	SZA CLA
	NOP		/A HLT PLACED HERE WILL ALLOW YOU TO STOP
			/MACHINE BEFORE RUNTIME SYSTEM STARTS BY 
			/SETTING SWITCH REGISTER
	TLS		/SET TTY FLAG
	ISZ	SPINNR	/SPIN RANDOM NUMBER SEED
	NOP		/WHILE WAITING FOR INITIALIZING TLS
	TSF		/FLAG UP YET?
	JMP	.-3	/NO
	TAD	CDFIO
	DCA I	PS1L	/SET UP CDFS IN PSWAP
	TAD	CDFIO
	DCA I	PS2L
	JMS I	PFUDSC	/SWAP 17600 IN IF NOT ALREADY IN AND SAVE SCOPE FLAG
	JMS I	CDFPSU
	TAD	SCALDF	/SET PROG NOT RESTARTABLE BIT
	DCA I	L7746	/TELL USR TO SAVE 1000-1777
	TAD	PINFO	/POINTER TO INFO TABLE IN 17600
	DCA	XR1
	TAD	POVTAB	/POINTER TO BLOCK TABLE IN OVERLAY DRIVER
	DCA	XR2
	TAD	FACCLR	/WE HAVE TO GET 4 BLOCK NUMBERS
	DCA	TEMP1
OVML,	CDF 10
	TAD I	XR1	/GET BLOCK NUMBER FOR THIS OVERLAY FROM INFO AREA
	CDF
	DCA I	XR2	/PUT IN TABLE IN OVERLAY DRIVER
	ISZ	TEMP1	/DONE?
	JMP	OVML	/NO
	JMS I	[PSWAP	/SWAP 17600 BACK TO HIGH CORE NOW
	JMP I	.+1
	START3		/CONTINUE THE INITIALIZING CODE IN INTERMEDIATE BUFFER
L7746,	7746
PINFO,	7607
POVTAB,	ARITHA-1
PS1L,	P1CDF
PS2L,	P1CDF1
PFUDSC,	FUDSC

	PAGE

FUDSC,	0
	TAD	PSFLAG	/TEST WHERE 17600 IS LOCATED
	SMA CLA
	TAD	[200	/IF NOT TD8E USE 7600
	TAD	[7400	/IF TD8E USE 7400
	DCA I	PHICORE	/STORE FOR SWAPPER
	CLA IAC
	AND	PSFLAG
	SNA CLA		/SKP IF PAGE 17600 IS ALREADY IN
	JMS I	[PSWAP	/ELSE BRING IT IN
	CDF	10
	TAD I	PSCOPW
	CDF
	AND	[200	/GET SCOPE BIT FROM RES MONITOR
	DCA I	PSCOPF
	TAD I	PHEIGHT
	DCA I	PHCTR	/NOW INITIALIZE THE SCREEN HEIGHT COUNTER
	JMP I	FUDSC	/RETURN
PHEIGHT,HEIGHT
PHCTR,	HCTR
PSCOPW,	SCOPWD
PSCOPF,	SCOPFG
PHICOR,	HICORE
	*SAC+SACLIM+1	/ORIGIN PAST SAC+ONE GUARD CHAR

	/JUMP ON CONDITION

FJOCI,	TAD	INSAV	/GET JUMP INSTRUCTION
	AND	[17	/MASK OFF JUMP CONDITION
	SNA		/IS IT GOSUB?
	JMP I	(GOSUB	/YES-PUSH PC ON STACK THEN JUMP
	TAD	FSTOPI	/BASE TAD FOR BUILD OF TAD INSTRUCTION
	DCA	.+1		/PUT IN LINE
	.		/GET PROPER SKIP
	DCA	.+2		/PUT IN LINE
	TAD	ACH	/GET HIGH ORDER FAC
	.		/SKIP INSTRUCTION
	JMP	SUCJMP	/CONDITION TRUE-JUMP
JFAIL,	JMS I	[PWFECH	/CONDITION FALSE-DON'T JUMP,BUT BUMP PC
	JMP I	[ILOOP	/DONE

/JUMP ON END OF FILE

JEOFI,	JMS I	[IDLE	/SEE IF FILE OPEN
	TAD I	IOTHDR	/1ST WORD OF I/O TABLE ENTRY
	CLL RTR		/GET EOF BIT IN LINK
	SNL CLA		/EOF?
	JMP	JFAIL	/NO-DON'T JUMP
			/YES, FALL INTO JUMP ROUTINE

SUCJMP,	JMS I	[PWFECH	/GET WORD FOLLOWING JUMP INS.
	DCA I	INTPCL	/STORE AS NEW PC
	TAD	INSAV	/GET JUMP INSTRUCTION
	AND	[340	/MASK OFF DESTINATION FIELD
	CLL RTR		/SLIDE OVER
	TAD	CDFINL	/MAKE A CDF INSTRUCTION
	DCA I	[CDFPSU	/AND SET NEW PC INSTRUCTION FIELD
	JMP I	[ILOOP	/NEXT INSTUCTION

K7554,	7554		/MUST PRECEDE SKIP TABLE

/SKIP TABLE USED TO HOLD TESTS FOR VARIOUS CONDITIONS

K7600,	7600		/UNCONDITIONAL (CLA)
	SMA CLA		/JPA
	SZA CLA		/JNA
	SMA SZA CLA	/JPA JNA
	SPA CLA		/JMA
	SNA CLA		/JZA
	SPA SNA CLA	/JMA JZA
	JMP I	JFORL	/FORLOOP JUMP ROUTINE

JFORL,	JFOR
INTPCL,	INTPC
	0000;0		/MARK BEGINNING OF GOSUB STACK
GSTCK,	6000;0
	6000;0
	6000;0
	6000;0
	6000;0
	6000;0
	6000;0
	6000;0
	6000;0
	0		/MARK THE END OF THE GOSUB STACK
/CALL TO DEVICE DRIVER FOR FILE I/O. ASSUMES ARGS HAVE BEEN SET UP

DRCALL,	0
	DCA	DRARG1	/FUNCTION WORD INTO DRIVER CALL
CDFINL,	CDF		/DF TO CURRENT FIELD
	TAD I	IOTBUF	/GET BUFFER ADDRE FROM I/O TABLE ENTRY
	DCA	DRARG2	/PUT IN DRIVER CALL
	TAD I	IOTBLK	/GET BLOCK NUMBER FROM I/O TABLE
	DCA	DRARG3	/PUT IN DRIVER CALL
	TAD I	IOTHND	/GET DRIVER ENTRY
	DCA	DRIVER	/SAVE
	JMS I	DRIVER	/CALL DRIVER
DRARG1,	0		/FUNCTION CONTROL WORD
DRARG2,	0		/BUFFER ADDRESS
DRARG3,	0		/BLOCK #
	SMA CLA		/DEVICE ERROR-IS IT FATAL?
	JMP I	DRCALL	/ALLS WELL
DE,	JMS I	[ERROR	/FATAL
DRIVER,	0

/CALL TO INTERPRETER EXITING ROUTINE

FSTOPN,	JMS I	[XPRINT	/ON NORMAL EXITS,WE MUST EMPTY RING BUFFER
	JMP	.-1	/FIRST
FSTOPI,	TAD	K7554
	DCA	INSAV	/FAKE A CALL TO BASIC.FF FUNCTION 6
	JMP I	.+1	/CALL OVERLAY
	FUNC5I

/USE FUNCTION-TAKES WORD FOLLOWING CALL AND STUFFS IT IN USECON FOR
/USE A BUFFER POINTER FOR USER SUBROUTINE

USE,	JMS I	[PWFECH	/GET NEXT WORD FROM PSEUDO-CODE STREAM
	DCA	USECON	/STORE IN PAGE 0 SLOT
	JMP I	[ILOOP	/RETURN

	PAGE
/ARRAY INSTRUCTIONS
/ARRAY INSTRUCTIONS WORK BY FINDING THE ADDRESS OF THE ARGUMENT FROM THE ARRAY SYMBOL
/TABLE,THEN CALLING THE APPROPRIATE FLOATING POIN PACKAGE ROUTINE.

ARRAYI,	TAD	MODESW	/WHICH MODE?
	SZA CLA
	JMP	SARRAY	/SMODE
	TAD	INSAV	/GET ARRAY INSTRUCTION
	AND	K0037	/MASK OFF ARRAY OPERAND
	CLL RTL		/MULTIPLY BY 4 (ENTRY LENGTH)
	TAD	ARSTRT	/MAKE POINTER INTO ARRAY TABLE
	DCA	XR1	/POINTS TO ARRAY FOR THIS OPERATION
ATABDF,	.		/CHANGE DF TO ARRAY TABLE FIELD (SET BY START)
	TAD I	XR1	/GET POINTER TO FIRST ARRAY ELEMENT
	DCA	TEMP2	/SAVE FOR LATER
	TAD I	XR1	/GET DF FOR VARIABLE
	DCA	ADFC	/PUT IN LINE AT END OF ROUTINE
	TAD I	XR1	/GET ARRAY DIMENSION 1
	DCA	TEMP3	/SAVE
	TAD	S1	/GET SUBSCRIPT 1
	CLL CMA		/SET UP 12 BIT COMPARE
	TAD	TEMP3	/DIMENSION 1 +1
	SNL CLA		/S1 TOO BIG?
SU,	JMS I	[ERROR	/YES-SUBSCRIPT OUT OF BOUNDS ERROR
	DCA	TEMP6	/CLEAR TEMPORARY
	TAD I	XR1	/GET DIMENSION 2
	SNA		/IS SECOND DIMENSION 0?(ARRAY UNIDIMENSIONAL)
	JMP	ADCALC	/YES-DON'T CHECK S2 FOR OUT OF BOUNDS
	DCA	ARJMP	/SAVE DIM2+1
	TAD	S2	/GET SUBSCRIPT 2
	CLL CMA		/SAVE 12 BIT COMPARE
	TAD	ARJMP
	SNL CLA		/S2 BIGGER THAN DIM2?
	JMP	SU	/YES
	TAD	S2	/MULTIPLY DIM1+1 BY S2
	JMS I	[MPY	/12 BY 12 MULTIPLY ROUTINE
ADCALC,	CLL
	TAD	S1	/LORD OF S1+(DIM1+1)*S2
	DCA	TEMP5	/SAVE
	RAL		/CARRY TO BIT 11
	TAD	TEMP6	/HORD OF S1+(DIM1+1)*S2
	DCA	TEMP6	/SAVE
	TAD	TEMP5	/LORD OF S1+(DIM1+1)*S2
	CLL RAL		/*2
	DCA	TEMP7	/LORD OF [S1+(DIM1+1)*S2]*2
	TAD	TEMP6	/HORD OF S1+(DIM1+1)*S2
	RAL		/*2
	DCA	TEMP3	/HORD OF [S1+(DIM1+1)*S2]*2
	CLL
	TAD	TEMP5	/LORD OF S1+(DIM1+1)
	TAD	TEMP7	/LORD OF [S1+(DIM1+1)*S2]
	DCA	TEMP7	/LORD OF 3*[S1+(DIM1+1)*S2]
	RAL		/CARRY TO BIT 11
	TAD	TEMP6	/HORD OF [S1+(DIM1+1)*S2)*2
	TAD	TEMP3	/HORD OF S1+(DIM1+1)*S2
	DCA	TEMP6	/HORD OF 3*[S1+(DIM1+1)*S2]
	CLL
	TAD	TEMP7	/INDEX TO ELEMENT
	TAD	TEMP2	/AC POINTS TO CORRECT ARRAY ELEMENT
	DCA	XR1	/SAVE POINTER
	RAL		/CARRY TO BIT 11
	TAD	TEMP6	/COMBINE TO MAKE TOTAL # OF FIELD OVERLAPS
	CLL RTL
	RAL		/SLIDE OVERLAPS TO FIELD BITS (6-8)
	TAD	ADFC	/ADD ANY CHANGE IN DATA FIELD TO CDF
	DCA	ADFC	/PUT ABSOLUTE CDF IN LINE
	TAD	INSAV	/GET ARRAY INSTRUCTION AGAIN
	AND	[340	/MASK OFF ARRAY OPCODE
	CLL RTR
	RTR
	RAR		/SLIDE TO BITS 9-11
	TAD	JMPI2	/AND USE AS INDEX INTO JUMP TABLE
	DCA	ARJMP	/PUT JUMP IN LINE OF CODE
	IAC
	DCA	FF	/PUT FPP IN "SPECIAL MODE"
ADFC,	.		/CHANGE DF TO DF OF ARRAY ELEMNT
	TAD	XR1	/AC POINTS TO ARRAY ELEMENT
ARJMP,	.		/PERFORM THE REQUIRED OPERATION
	NOP		/FPP SOMETIMES RETURNS TO CALL+2
	JMP I	[ILOOP	/DONE

/ARRAY JUMP TABLE

AJT,	FFSUB1		/FAC=A(S1,S2)-FAC		OPCODE 0
	FFADD		/FAC=FAC+A(S1,S2)		OPCODE 1
	FFSUB		/FAC=FAC-A(S1,S2)		OPCODE 2
	FFMPY		/FAC=FAC*A(S1,S2)		OPCODE 3
	FFDIV		/FAC=FAC/A(S1,S2)		OPCODE 4
	FFGET		/FAC=C(A(S1,S2)			OPCODE 5
FPUTLL,	FFPUT		/C(A(S1,S2)=FAC			OPCODE 6
	FFDIV1		/FAC=A(S1,S2)/FAC		OPCODE 7
	/STRING ARRAY DISPATCH

SARRAY,	TAD	INSAV	/GET INSTRUCTION
	AND	[340	/ISOLATE ARRAY OPCODE
	CLL RTR
	RTR		/AND SLIDE IT OVER FOR AN OFFSET
	RAR
	TAD	JMPISA	/BUILD A JUMP TO STRING INSTRCUTION
	DCA	SAD	/AND PUT IN LINE
	STL		/TELL SFIND TO USE ARRAY TABLE
	JMS I	STFILK	/SET UP ARGUMENT ADDRESS
SAD,	.		/EXECUTE INSTRCUTION

/STRING ARRAY JUMP TABLE
/USED WHEN ARRAYI CALLED IN SMODE
/ A "/*" IN THE COMMENT MEANS THAT OPCODE IS UNDEFINED AND THE SLOT
/IN THE TABLES IS USED FOR NORMAL STORAGE

JMPISA,	JMP I	.+1	/DISPATCH JUMP FOR STRING ARRAY INSTRUCTIONS

	SCON1		/SAC_SAC&C(A$(S1))
	SCOMP		/SKIP IF SAC=C(A$(S1))
	SREAD		/A$(S1)_DEVICE
K0037,	37		/*
STFILK,	STFIND		/* LINK TO STRING FINDING ROUTINE
	SLOAD		/SAC_C(A$(S1))
	SSTORE		/C(A$(S1))_SAC
JMPI2,	JMS I	AJT	/* DISPATCH JUMP FOR ARRAY INST
/ROUTINE TO PUT ONE WORD IN FILE BUFFER IN FIELD 1

BCPUT,	0
	DCA	TEMP6	/SAVE AC
	JMS I	[IDLE	/CHECK IF FILE OPEN
	TAD I	IOTPTR	/GET READ/WRITE POINTER
	DCA	TEMP7	/SAVE
	TAD	ENTNO	/GET FILE #
	SZA CLA		/IF TTY,BUFFER FIELD IS 0
	CDF 10
	TAD	TEMP6	/GET WORD TO STORE AGAIN
	DCA I	TEMP7	/STORE IT IN BUFFER
CDF0,	CDF
	TAD I	IOTHDR	/HEADER WORD
	AND	(7737	/TURN OFF BLOCK WRITTEN BIT
	TAD	(40		/TURN IT ON AGAIN
	DCA I	IOTHDR
	JMP I	BCPUT	/RETURN

	PAGE
/TELETYPE DRIVING ROUTINE
/2 ENTRY POINTS-XPUTCH PUTS A CHARCTER IN THE RING BUFFER
/               XPRINT TYPES A CHARACTER IF POSSIBLE
/		AND	RETURNS TO CALL+1 IF THERE
/		ARE MORE CHARCTERS IN THE BUFFER,CALL+2
/		IF THE BUFFER IS EMPTY
/THE IDEA IS THE PLACE CALLS TO XPRINT AT VARIOUS POINTS IN THE INTER-
/PRETER AND THUS KEEP THE TTY BUSY WITHOUT WASTING THE TIME WAITING FOR
/THE TTY FLAG. THE SUCCESS OF THIS SCHEME DEPENDS HEAVILY ON THE NUMBER
/AND PLACEMENT OF THE CALLS TO XPRINT.

XPUTCH,	0
	DCA	CHRSAV	/SAVE THE CHARACTER
XPUT1,	ISZ	SPINNR	/SPIN RANDOM # SEED
	JMS	XPRINT	/START A CHAR IF POSSIBLE
	NOP
	TAD	BCNT	/GET THE NUMBER OF AVAILABLE SLOTS
	SNA CLA		/ARE THERE ANY?
	JMP	XPUT1	/NO-TRY TO RPINT 1 AND FREE UP A SPACE
PUTCHR,	TAD	CHRSAV	/GET CHARACTER AGAIN
	DCA I	BUFIN	/PUT CHARACTER IN RING BUFFER
	ISZ	BUFIN	/BUMP BUFEER POINTER OF INPUT
	CLA CLL CMA	/-1 IN AC
	TAD	BCNT	/DECREMENT AVAILABLE SLOT COUNT
	DCA	BCNT
	TAD	BUFIN	/GET BUFFER INPUT POINTER
	TAD	MBEND	/SUBTRACT ADDR OF END OF BUFFER
	SPA SNA CLA	/PAST EDN OF BUFFER?
	JMP I	XPUTCH	/NO-RETURN
	TAD	BSTRTA	/YES-RESET INPUT POINTER TO BEGINNING OF BUFFER
	DCA	BUFIN
	JMP I	XPUTCH	/RETURN

BUFIN,	BSTRT		/POINTER TO NEXT SLOT FOR BUFFER INPUT
BUFOUT,	BSTRT		/POINTER TO NEXT CHARACTER TO BE PRINTED
BSTRTA,	BSTRT		/ADDR OF START OF TTY BUFFER
BCNT,	30		/# OF AVAILABLE SLOTS IN BUFFER (40 INITIALLY)
CHRSAV=TEMP1
MBEND,	-BEND		/-ADDR OF END OF RING BUFFER
MCTRLC,	-3
M50,	-30
MXON,	-21+3
MXOFF,	-23+21
XFLAG,	0


XPRINT,	0
	KSF		/IS KEYBOARD FLAG UP?
	JMP	NOCC	/NO-NO CHANCE FOR A CTRL/C
	KRB		/YES-GET THE CHAR IN KEYBOARD BUFFER
	AND	[177	/GET RID OF PARAITY
	TAD	MCTRLC	/IS IT CTRL/C
	SNA
	JMP I	FSTOP1	/YES-ABORT TO EDITOR
	TAD	MXON
	SZA
	JMP	.+3
	DCA	XFLAG
	JMP	NOCC+3
	TAD	MXOFF
	SZA CLA
	JMP	NOCC
	ISZ	XFLAG
	JMP	XPRINT+1
NOCC,	TAD	XFLAG
	SZA CLA
	JMP	XPRINT+1
	TAD	BCNT	/# OF AVAILABLE SLOTS IN BUFFER
	TAD	M50		/IS BUFFER EMPTY?
	SNA CLA
	JMP	RECP2	/YES-RETURN TO CALL+2
	TSF		/NO-TTY FLAG UP YET?
	JMP I	XPRINT	/NO-GO ABOUT YOUR BUSINESS
	TAD I	BUFOUT	/GET NEXT CHARACTER
/*****************************************************************:
/N.B. BECAUSE OF THE ABOVE INSTRUCTION,THE DF MUST BE SET TO THE
/INTERPRETER FIELD WHENEVER XPRINT IS CALLED. WATCH YOUR HOOK PLACEMENT!
/****************************************************************:
	JMS I	(PCH	/TYPE THE CHAR
	ISZ	BUFOUT	/BUMP BUFFER OUTPUT POINTER
	TAD	BUFOUT	/GET OUTPUT POINTER
	TAD	MBEND	/SUBTRACT END OF BUFFER
	SPA SNA CLA	/IS OUTPUT POINTER PAST END?
	JMP	BOUTRS	/NO-FREE UP A SPOT
	TAD	BSTRTA	/YES-RESET POINTER TO BEGINNING
	DCA	BUFOUT
BOUTRS,	ISZ	BCNT	/INCREMENT # OF FREE SLOTS (WE JUST PRINTED ONE)
	JMP I	XPRINT	/RETURN

RECP2,	ISZ	XPRINT	/BUMP RETURN
	JMP I	XPRINT	/RETURN TO CALL+2 FOR EMPTY BUFFER


/TELETYPE RING BUFFER

BSTRT,	"B		/START OF BUFFER
	"R
	"T
	"S
	" 
	"V
VERLOC,	260+VERSON
	300+SUBVER
	0215
	0212
VEREND,	0212
VCHECK,	0
	CDF 10
	TAD I	N7644
	CDF 0
	AND	XR4
	SNA CLA
	JMP I	VCHECK
	TAD	XR1
	DCA	BUFIN
	TAD	SACXR
	DCA	BCNT
	JMP I	VCHECK
BEND,
N7644,	7644

	/LINE NUMBERS

LINEI,	TAD	INSAV	/GET INSTRUCTION
	DCA	LINEHI	/SAVE
	JMS I	[PWFECH	/GET WORD FOLLOWING LINE # INST
	DCA	LINELO	/SAVE  AS LOW ORDER LINE #
TRHOOK,	JMP I	[ILOOP	/RETURN TO I-LOOP
	TAD	KC240	/IF TRACE IS ON,FAKE CALL
	DCA	INSAV	/TO FUNC2,#12
	JMP I	.+1
	FUNC2I		/DISPATCH TO TRACE FUNCTION

/INTERMEDIATE TTY BUFFER
/USED TO BUFFER OUTPUT FROM FPP BEFORE WE PUT IT
/IN BASIC FORMAT FOR TRANSPORTATION TO THE TTY RING
/BUFFER

KC240,	240		/STOPPER TO MARK BEGINNING OF BUFFER
INTERB,
START3,	TAD	CDFPS	/CDF FOR PSEUDO-CODE
	DCA I	[CDFPSU	/PUT IN-LINE TO ILOOP
	TAD	PSSTRT	/START OF PSEUDO-CODE
	DCA I	INTPCK	/PUT INTO PC
	JMS I	[FACCLR	/ZERO FAC
	TAD	CDFIO	/CDF FOR SYMBOL TABLE FIELD
	DCA I	STDFL	/PUT IN LINE FOR STRING FUNCTIONS
FPPTM5,	TAD	CDFIO	/CDF FOR SYMBOL TABLES
	DCA I	ATABDL	/PUT IN LINE FOR ARRAY CALCULATIONS
	TAD	CDFIO	/CDF FOR SCALAR TABLE
FPPTM4,	DCA I	SCALDL	/PUT IN LINE FOR ARGPRE
	TAD	CDFIO
	DCA I	DLCDFL	/DATA FIELD FOR DATA LIST
FPPTM3,	TAD	DLSTRT
	DCA	DATAXR	/DO A RESTORE IN INCORE DATA LIST
	JMP I	.+1	/CONTINUE INITAILIZATION CODE IN TTY INPUT BUFFER
FPPTM2,	START4
ATABDL,	ATABDF
STDFL,	STDF
FPPTM1,			/FLOATING POINT TEMPORARY
INTPCK,	INTPC
DLCDFL,	DLCDF
SCALDL,	SCALDF

	PAGE
	/VT52 DELAY PARAMETERS (MUST BE AT BEGINNING OF PAGE)

HEIGHT,	0		/NEGATIVE SCREEN HEIGHT
DELAY,	0		/NEGATIVE DELAY VALUE
	IFNZRO HEIGHT-1200 <__FIX SET COMMAND__>
HCTR,	0		/HEIGHT COUNTER INITIALIZED BY SET
DCTR,	0		/DELAY COUNTER INITIALIZED BY SET

	/LOW LEVEL ROUTINE TO TYPE A CHAR

PCH,	0
	TSF		/WAIT FOR PREV CHAR
	JMP	.-1
	TLS		/TYPE THE CURRENT ONE
	AND	[177	/MASK TO 7BIT
	TAD	(-15	/TEST IF LINE FEED WILL BE SENT NEXT
	SZA CLA
	JMP I	PCH	/RETURN IF NOT
	ISZ	HCTR	/TEST SCREEN HEIGHT IF LF
	JMP I	PCH	/RETURN IF NOT AT BOTTOM OF SCREEN
	TAD	HEIGHT
	DCA	HCTR	/RESET HEIGHT COUNTER NOW
	TAD	DELAY
	SNA		/TEST FOR ZERO DELAY
	JMP I	PCH	/RETURN IF SO
	DCA	DCTR	/ELSE SET DELAY COUNTER
DLOOP,	ISZ	PSWAP	/NOW EXEC INNER LOOP 4096 TIMES (USUALLY)
	JMP	.-1
	KSF		/TEST IF KEY STRUCK
	SKP
	JMP I	PCH	/RETURN AT ONCE IF YES
	ISZ	DCTR	/TEST DELAY TIMER
	JMP	DLOOP	/REITERATE
	JMP I	PCH	/NOW ALLOW PRINTING TO CONTINUE

	/OPERATE CLASS INSTRUCTIONS

OPERI,	TAD	INSAV	/GET OPERATE INSTRUCTION
	AND	[17	/MASK OFF OPERATE OPCODE
	TAD	JMPI3	/BUILD JUMP OFF OPERATE JUMPTABLE
	DCA	.+1		/STORE THE JUMP IN LINE
	.		/DISPATCH TO PROPER OPERATE ROUTINE

JMPI3,	JMP I	.+1	/JUMP TO OPERATE ROUTINE CALLED FOR

	/OPERATE JUMP TABLE

	FUNC3I		/CALL RESIDENT FUNCTION	OPCODE 0
	SPFUNC		/SPECIAL FUNCTIONS	OPCODE 1
	SFN		/SET FILE NUMBER	OPCODE 2
	FNEGI		/NEGATE FAC		OPCODE 3
	RETRNI		/GOSUB RETURN		OPCODE 4
	RESTOR		/RESTORE DEVICE		OPCODE 5
	LSUB1I		/LOAD S1 FROM FAC	OPCODE 6
	LSUB2I		/LOAD S2 FROM FAC	OPCODE 7
MSPACE,	20		/THIS OPCODE NOT DEFINED,SO WE PUT A CONST HERE
	READI		/READ DEVICE		OPCODE 11
	WRITEI		/WRITE DEVICE		OPCODE 12
	SWRITE		/STRING WRITE		OPCODE 13
	FUNC5I		/CALL FILE FUNCTION	OPCODE 14
	FUNC4I		/CALL USER FUNCTION	OPCODE 15
	FUNC1I		/CALL FUNCTIONS 1	OPCODE 16
	FUNC2I		/CALL FUNCTIONS 2	OPCODE 17
/ROUTINE TO SWAP PG 17600 WITH N7400 OR N7600 (WHICHEVER THE CASE MAY BE)
/WHERE N IS THE HIGH CORE FIELD

PSWAP,	0
	TAD	KK7600	/POINTER TO 17600 AND COUNTER
	DCA	TEMP1
	TAD	PSFLAG	/GET SWAPPING FLAGS
	RAR
	CML RAL		/TOGGLE THE INPLACE BIT
	DCA	PSFLAG	/STORE IT BACK
	TAD	HICORE	/PICK UP ADDR OF HIGH CORE
	DCA	TEMP2	/POINTER TO HIGH CORE
P1CDF,	HLT		/DF TO HI CORE
	TAD I	TEMP2	/GET WORD FROM HI CORE
	DCA	TEMP4	/SAVE IT
P2CDF,	CDF 10
	TAD I	TEMP1	/GET WORD FROM 17600
P1CDF1,	HLT		/DF TO HI CORE AGAIN
	DCA I	TEMP2	/PUT 17600 WORD IN HI CORE
P2CDF1,	CDF 10
	TAD	TEMP4	/GET SAVED HI CORE WORD
	DCA I	TEMP1	/AND PUT IN 17600
	ISZ	TEMP2	/BUMP HI CORE POINTER
KK7600,	7600		/CLA
	ISZ	TEMP1	/BUMP 17600 POINTER AND CHECK FOR DONE
	JMP	P1CDF	/NO DONE-MOVE NEXT WORD
	CDF
	JMP I	PSWAP	/DONE-RETURN
HICORE,	0		/POINTS TO LOCATION OF 17600 SAVE AREA

	IFNZRO	EAE	<

	/TEMPORARY INCLUSION FOR FFOUT

	/ADD OP TO FAC

OADD,	0
	CLL
	TAD	AC2
	TAD	AC1
	DCA	AC1	/ADD GUARD BITS
	RAL
	TAD	OPL
	TAD	ACL
	DCA	ACL	/ADD LOW ORDER BITS
	RAL
	TAD	OPH
	TAD	ACH
	DCA	ACH	/ADD HIGH ORDER BITS
	JMP I	OADD

	/SHIFT FAC LEFT 1 BIT

AL1,	0
	TAD	AC1
	CLL RAL
	DCA	AC1
	TAD	ACL
	RAL
	DCA	ACL
	TAD	ACH
	RAL
	DCA	ACH
	JMP I	AL1
	>

/1	RL01 PATCH FOR BRTS

//	WAS PART OF THE BPAT.PA FILE

	*1345
HFIX,	0
	CLL STA RTL	/AC7775
	TAD I	H7612
	SZA CLA		/SKP IF 2 PAGE HANDLER
	JMP I	HFIX	/ELSE EXIT NOW
FIXLUP,	TAD I	FIXPTR	/GET A WORD FROM HANDLER
	TAD	M6300
	CLL		/RANGE CHECK FOR CIF/CDF N0
	TAD	H70
	SNL CLA		/SKP IF CDF OR CIF
	JMP	NOFIX	/ELSE DON'T FIX IT
	TAD I	FIXPTR	/GET INSTRUCTION
	AND	H7707	/ZERO FIELD BITS
	TAD	H20	/PUT BACK FIELD 2
	DCA I	FIXPTR	/STORE INSTRUCTION BACK
NOFIX,	ISZ	FIXPTR
	JMP	FIXLUP
	JMP I	HFIX	/--RETURN--
FIXPTR,	7635
H20,	20
H70,	70
H7612,	7612
H7707,	7707
M6300,	-6300

	PAGE
	/LOAD SUBSCRIPT 1 OR 2 FROM FAC OR MEMORY

LSUB2I,	ISZ	DCASUB
	JMP	LSUB1I
LS2I,	ISZ	DCASUB
LS1I,	JMS I	[FACSAV	/PRESERVE FAC
	JMS I	ARGPRL	/GET ARG POINTER INTO AC
	JMS I	[FFGET	/LOAD ARG INTO FAC (SKIPS NEXT INST ON RETURN)
LSUB1I,	JMS I	[FACSAV	/SAVE THE FAC
	JMS I	[UNSFIX	/GET INT(FAC)
DCASUB,	DCA	S1	/SET RESULT AS SUBSCRIPT 1
	JMS I	[FACRES	/RESTORE FAC
	TAD	DCAS1
	DCA	DCASUB	/FUDGE INSTR BACK
	JMP I	[ILOOP	/NEXT INSTRCUTION
DCAS1,	DCA	S1
ARGPRL,	ARGPRE

/JMP DISPATCH FOR FUNC1 CALLS

JMSI4,	JMS I	.+1	/CALL FOR CANNED FUNCTION SET 1

/JUMP TABLE FOR FUNCTION CALL 1

	ATAN		/FUNCTION BITS=	0
	COS		/		1
	EXPON1		/		2
	EXPON		/		3
	INT		/		4
	LOG		/		5
	SGN		/		6
	SIN		/		7
	RND		/		10
	FROOT		/		11

/JUMP FOR FUNC2 DISPATCH

JMSI5,	JMP I	.+1	/JMP OFF THE SET 2 TABLE

/JUMP TABLE FOR FUNCTION SET 2

	ASC		/FUNCTION BITS=	0
	CHR		/		1
	DATE		/		2
	LEN		/		3
	POS		/		4
	SEG		/		5
	STR		/		6
	VAL		/		7
	ERRORR		/		10
/ERRORR MUST BE FUNCTION #10,ELSE "ERROPC" MUST CHANGE
	TRACE		/		11
	TPRINT		/		12
/TPRINT MUST BE #12 OR TRHOOK+1 MUST CHANGE

/DISPATCH FOR FUNC5 CALLS

JMPFIL,	JMP I	.+1	/CALL FORR FILE MANIPULATING FUNCTIONS

/JUMP TABLE FOR FILE FUNCTIONS

	CHAIN		/FUNCTION BITS=	0
	CLOSE		/		1
	OPENAF		/		2
	OPENAV		/		3
	OPENNF		/		4
	OPENNV		/		5
	FSTOP		/INT. EXIT	6

/ERROR CALL FOR USER FUNCTIONS-USER FUNCTION SHOULD "JMS I (IA"

IA,	JMS I	[ERROR
	/FUNCTION OVERLAY DRIVER

FUNC4I,	JMS I	[XPRINT	/PURGE TTY RING BUFFER
	JMP	.-1	/BEFORE CALLING USER FUNCTION
	IAC		/LOOK FOR OVERLAY FLAG=3
FUNC5I,	IAC		/LOOK FOR OVERLAY FLAG=2
FUNC2I,	IAC		/LOOK FOR OVERLAY FLAG=1
FUNC1I,	DCA	TEMP1	/LOOK FOR OVERLAY FLAG=0
	CDF		/DF TO THIS FIELD
	TAD	TEMP1	/GET OVERLAY # AGAIN
	CIA		/NEGATE
	TAD	OVRLAY	/COMPARE AGAINST OVERLAY FLAG
	SNA CLA		/IS THE ONE WE WANT ALREADY RESIDENT?
	JMP	OVDNE	/YES-JUST JUMP TO FUNCTION
	TAD	TEMP1	/NO-GET NUMBER OF OVERALY DESIRED
	TAD	OATADI	/USE AS OFFSET TO BUILD STARTING BLOCK TAD
	DCA	TEMP2	/POINTS TO PROPER STARING BLOCK #
	TAD I	TEMP2	/GET STARTING BLOCK FOR THIS OVERLAY
	DCA	OVADD	/PUT IN DRIVER CALL
	JMS I	L7607	/CALL SYSTEM HANDLER
	0500		/OVERLAY 3400-4600
	3400
OVADD,	.		/STARTING BLOCK # OF OVERLAY
OE,	JMS I	[ERROR	/I/O ERROR
	TAD	TEMP1
	DCA	OVRLAY	/CHANGE RESIDENT FLAG
OVDNE,	TAD	[SAC-1	/ENTER STRING FUNCTIONS WITH SACXR SET UP
	DCA	SACXR
	TAD	TEMP1	/FUNCTION #
	TAD	JMSTAD	/BUILD A TAD OF THE PROPER DISPATCH JMS
	DCA	.+2	/PUT IN LINE
	JMS I	[FBITGT	/GET # OF FUNCTION DESIRED
	.		/BUILD JUMP OFF JUMP TABLE
FUJUMP,	DCA	.+1	/PUT JUMP IN LINE
	.		/GO TO DESIRED FUNCTION
	JMP I	[ILOOP	/DONE

OATADI,	ARITHA
L7607,	7607
OVRLAY,	0		/# OF CURRENTLY RESIDENT OVERLAY
			/0=ARITHMETIC,1=STRING,2=FILE,3=USER

/OVERLAY TABLE-CONTAINS STARTING BLOCK # OF SYSTEM OVERLAYS
/INITIALIZED BY LOADER

ARITHA,	.		/STARTING BLOCK OF ARITHMETIC OVERLAY
STRNGA,	.		/STARTING BLOCK OF STRING OVERLAY
FILEFA,	.		/STARTING BLOCK OF FILE OVERLAY
USRA,	.		/STARTING BLOCK OF USER FUNCTIONS

JMSTAD,	TAD I	TADTAB

TADTAB,	JMSI4
	JMSI5
	JMPFIL
	JMSUSR

/CALL FOR RESIDENT FUNCTION

FUNC3I,	JMS I	[FBITGT	/ISOLATE FUNCTION #
	TAD	JMSI7	/MAKE A JUMP OFF JUMP TABLE
	JMP	FUJUMP	/PUT THE JUMP IN LINE AND EXECUTE IT

JMSI7,	JMP I	.+1

/JUMP TABLE FOR RESIDENT FUNCTIONS

	XABSVL		/FUNCTION BITS=	0
	COMMA		/		1
	CRFUNC		/		2
	ILOOPF		/		3
	TAB		/		4
	PNT		/		5
	USE		/		6


	*1557	/****N.B.****
		/THIS TABLE CANNOT BE MOVED!!!!

/JUMP DISPATCH FOR USER ROUTINES
JMSUSR,	JMS I	.+1

/JUMP TABLE FOR USER FUNCTIONS
	ILOOPF		/USER FUNCTION	1
	ILOOPF		/		2
	ILOOPF		/		3
	ILOOPF		/		4
	ILOOPF		/		5
	ILOOPF		/		6
	ILOOPF		/		7
	ILOOPF		/		8
	ILOOPF		/		9
	ILOOPF		/		10
	ILOOPF		/		11
	ILOOPF		/		12
	ILOOPF		/		13
	ILOOPF		/		14
	ILOOPF		/		15
	ILOOPF		/		16

	PAGE
/SPECIAL FUNCTIONS

SPFUNC,	JMS I	[FBITGT	/ISOLATE FUNCTION BITS
	TAD	JMPI6	/MAKE A JUMP OFF SPECIAL FUNCTION TABLE
	DCA	.+1		/PUT IN LINE
	.

JMPI6,	JMP I	.+1	/JUMP TO SPECIAL FUNCTION ROUTINE

/SPECIAL FUNCTION JUMP TABLE

	SETF		/SET FSWITCH			0
	FRANDM		/RANDOMIZE			1
	FSTOPN		/LEAVE INTERPRETER		2
	SRLIST		/STRING READ FROM DATA LIST	3
	CSFN		/SET FILE # TO TTY		4
	RDLIST		/READ DATA LIST			5
	AMODE		/SWITCH TO A MODE		6
	SSMODE		/SWITCH TO S MODE		7
/SUBROUTINE UNSFIX-UNSIGNED INTEGER FIX ROUTINE. FIXS A POSITIVE 12 BIT
/NUMBER OUT OF FAC MANTISSA AND LEAVES RESULT IN AC.RESULT IS AN UNSIGNED,
/12 BIT INTEGER

UNSFIX,	0
	CDF 0
	TAD	ACL	/LOW MANTISSA
	CLL RAL		/HI BIT OF LO MANTISSA TO LINK
	CLA
	TAD	ACH	/HIGH MANTISSA
	SPA		/IS NUMBER POSITIVE?
FM,	JMS I	[ERROR	/NO-BOO!!!
	RAL		/SHIFT THE SIGN BIT OUT AND THE MANTISSA OVER,
	DCA	ACH	/MAKING 12 BITS OF MANTISSA AND BINARY POINT BEFORE BIT 0
	TAD	ACX		/GET EXPONENT
	SPA SNA CLA	/IS X>1?
	JMP I	UNSFIX	/NO-FIX IT TO 0
	TAD	ACX		/YES-GET EXPONENT
	TAD	[-14		/SET BINARY POINT AT 12
	SNA		/DONE ALREADY?
	JMP	UNSOUT	/YES
	SMA		/NO-IS # TOO BIG?
FO,	JMS I	[ERROR	/YES
	DCA	ACX		/NO-STORE COUNT
	TAD	ACH	/HI MANTISSA
UNSLP,	CLL RAR		/SCALE RIGHT
	ISZ	ACX		/DONE?
	JMP	UNSLP	/NO
	JMP I	UNSFIX	/YES-RETURN

UNSOUT,	TAD	ACH	/ANSWER IN AC
	JMP I	UNSFIX

/RESTORE ROUTINE

RESTOR,	TAD	ENTNO	/GET CURRENT FILE #
	SNA CLA		/IS IT 0?
	JMP	RESDLS	/YES-RESTORE DATA LIST
	JMS I	(WRBLK	/NO-WRITE CURRENT BUFFER
	STA		/-1
	TAD I	IOTLOC	/STARTING BLOCK-1
	DCA I	IOTBLK	/SET CURRENT BLOCK #
	TAD I	IOTBUF	/GET BUFFER ADDRESS
	DCA I	IOTPTR	/USE IT TO RESET READ\WRITE POINTER
	TAD I	IOTHDR	/GET HEADER WORD
	AND	(7435	/CLEAR EOF BIT,BUFFER WRITTEN BIT,AND CHAR #
	DCA I	IOTHDR
	JMS I	[NEXREC	/READ FIRST BLOCK INTO BUFFER
	JMP I	[ILOOP	/DONE
RESDLS,	TAD	DLSTRT	/ADDRESS OF START OF INCORE DATA LIST
	DCA	DATAXR	/USE IT TO RESET DATA LIST POINTER
	JMP I	[ILOOP	/THATS ALL!
/SUBROUTINE STFIND-WHEN CALLED,IF LINK=1 STRING ARRAY TABLE IS
/USED,IF LINK=0 STRING SYMBOL TABLE IS USED. RETURNS WITH AC SET
/TO CDF OF OPERAND STRING,STRPTR POINTING TO THE FIRST WORD
/IN THE STRING, AND THE MAX LENGTH OF THE STRING IS IN STRMAX. ALSO,
/THE ACTUAL LENGTH OF THE STRING IS IN STRCNT

STFIND,	0
	SZL		/IS THIS AN ARRAY INST?
	JMP	SAFIND	/YES-POINTER IS INTO ARRAY TABLE
	TAD	INSAV	/GET INST AGAIN
	AND	[377	/ISOLATE OPERAND POINTER
	DCA	TEMP1	/NO-SAVE OPERAND POINTER
	TAD	TEMP1	/N
	CLL RAL		/2N
	TAD	TEMP1	/3N (3 WORDS/ENTRY)
	TAD	STSTRT	/ADD BASE ADR OF STRING TABLE
STCOM,	DCA	XR2	/POINTER TO THIS ENTRY IN STRING TABLE
STDF,	.		/DF TO THAT OF SYMBOL TABLES (SET BY START)
	TAD I	XR2	/GET POINTER TO STRING
	DCA	STRPTR
	TAD I	XR2	/GET CDF FOR OPERAND STRING
	DCA	STRCDF	/SAVE
	TAD I	XR2	/GET -(MAX LENGTH OF STRING)
	DCA	STRMAX	/SAVE
	SNL		/ARRAY ELEMENT?
	JMP	STRCDF	/NO-SKIP THIS SUBSCRIPT CALCULATION
	TAD	S1	/GET SUBSCRIPT
	CLL CMA		/SET UP 12 BIT COMPARE
	TAD I	XR2	/GET DIMENSION
	SNL CLA		/IS S1>DIMENSION?
	JMP I	(SU	/YES
	TAD	STRMAX	/NO-GET ELEMENT LENGTH
	CIA		/MAKE POSITIVE
	CLL IAC		/ROUND OFF TO NEAREST MULTIPLE OF 2
	CLL RAR		/ DIVIDE BY TWO (COUNT/2=WORD COUNT)
	CLL IAC		/ADD A WORD FOR HEADER
	DCA	TEMP3	/# OF WORDS IN EACH ARRAY ELEMENT
	TAD	S1	/GET SUBSCRIPT
	JMS I	[MPY	/S1*ELEMENT LENGTH (ASSUMES LINK UNCHANGED ON RETURN)
	TAD	STRPTR	/ARRAY OFFSET+POINTER TO A(0)
	DCA	STRPTR	/FINAL STRING POINTER
	RAL		/CARRY TO BIT 11
	TAD	TEMP6	/ADD TO ACCUMLATED OVERLAPS FROM MULTIPLY
	CLL RTL
	RAL		/PUT OVERLAP # INTO BITS 6-8
	TAD	STRCDF	/ADD TO CDF IF NECESSARY
	DCA	STRCDF	/SAVE AGAIN
STRCDF,	0		/DF TO STRING FIELD
	TAD I	STRPTR
	CDF
	DCA	STRCNT	/STORE -(CURRENT LENGTH OF STRING)
	TAD	STRCDF	/CDF TO OPERAND IN AC
	DCA I	(SSTEX	/SETUP STRING STORE EXIT DF HERE
	JMS I	(BYTSET	/ENTER FUNCTIONS WITH BYTE POINTERS SETUP
	JMP I	STFIND	/RETURN

SAFIND,	TAD	INSAV	/GET INST
	AND	(37	/ISOLATE OPERAND POINTER
	CLL RTL		/4N (4 WORDS/ENTRY)
	TAD	SASTRT	/USE STRING ARRAY TABLE
	STL		/SET LINK FOR ARRAY INST
	JMP	STCOM	/RETURN TO SUBROUTINE MAINLINE

	/PNT(X)
	/SEND 7BIT CHAR TO THE CURRENT FILE

PNT,	JMS I	[UNSFIX	/FIX X
	AND	[177	/STRIP TO 7 ASCII BITS
//
//		DSN 31.11.2 M
//
	NOP	//

//	TAD	[200	/FORCE CHANNEL 8
	JMS I	[PUTCH	/PUT IN FILE BUFFER
	JMP I	[ILOOP	/DONE

	PAGE
/ROUTINE SFN-ROUTINE TO RESET POINTERS IN PAGE ZERO FILE POINTER
/AREA TO REFLECT A CHANGE IN THE CURRENT FILE NUMBER

SFN,	JMS I	[UNSFIX	/FIX FAC TO GET FILE #
CSFN,	DCA	ENTNO	/IF ENTRY IS HERE,FILE #=0 (TTY)
	TAD	ENTNO
	STL
	TAD	(-4	/IS RESULT A LEGAL FILE #?
	SNL SZA CLA
FN,	JMS I	[ERROR	/NO-ERROR
	TAD	ENTNO	/PICK UP FILE NUMBER
//
//		DSN PATCH 31.11.1.M
//
	CLL RAL		//
	TAD ENTNO	//
	RTL		//
	TAD ENTNO	//
	NOP		//

//	CLL RTL
//	RTL
//	CIA
//	TAD	ENTNO
//	CIA		/MULTIPLY BY SIZE OF IOTABLE

	IFNZRO	IOTSIZ-15 <__ASSEMBLY ERROR__>
	TAD	(TTYF	/ADD TO BASE
	DCA	XR1	/STORE IN TEMP
	TAD	(IOTHDR-1 /NOW POINT AT PAGE 0 AREA
	DCA	XR2
	TAD	(-IOTSIZ+3 /SETUP ALL BUT LAST 3
	DCA	TEMP2
	TAD	XR1
	DCA I	XR2
	ISZ	XR1
	ISZ	TEMP2
	JMP	.-4	/SET UP THE POINTERS NOW
	JMP I	[ILOOP	/--RETURN--
	/GOSUB

GOSUB,	TAD I	GSP
	SMA CLA
GS,	JMS I	[ERROR	/ERROR IF STACK OVERFLOW
	TAD I	[CDFPSU	/ELSE GET CDF INSTR
	DCA I	GSP
	ISZ	GSP
	TAD I	(INTPC
	DCA I	GSP	/STORE INT PC
	ISZ	GSP
	JMP I	(SUCJMP	/EXEC AS NORMAL GOTO NOW

	/GOSUB RETURN

RETRNI,	STA
	TAD	GSP
	DCA	GSP	/POP STACK
	TAD I	GSP	/GET PC
	DCA I	(INTPC
	STA
	TAD	GSP	/POP STACK
	DCA	GSP
	TAD I	GSP
	SMA
GR,	JMS I	[ERROR	/FATAL ERROR IF NO RETURN
	DCA I	[CDFPSU
	JMP I	(JFAIL	/BUMP PC PAST ADDR WORD AND CONTINUE

GSP,	GSTCK		/GOSUB STACK POINTER

	/FOR-LOOP JUMP ROUTINE
	/ENTER WITH AC = HORD

JFOR,	SNA		/IS FAC=0?
	JMP I	(JFAIL	/YES-DO NOT JUMP
	TAD	FSWITC	/ADD FSWITCH
	SPA CLA		/ARE SIGN BIT=FSWITCH?
	JMP I	(JFAIL	/NO-DO NOT JUMP
	JMP I	(SUCJMP	/YES-DO JUMP

/ROUTINE TO INITIALIZE FSWITCH

SETF,	AC4000
	AND	ACH	/ISOLATE SIGN OF MANTISSA
	DCA	FSWITC	/STORE IN FSWITCH
	JMP I	[ILOOP	/DONE
FSWITC,	0
/ROUTINE TO RESET CHARACTER NUMBER TO 1

CNOCLR,	0
	TAD I	IOTHDR
	AND	[7477	/SET CHAR BITS TO 0
	DCA I	IOTHDR
	JMP I	CNOCLR	/RETURN

	/ROUTINE TO ZERO THE CURRENT I/O BUFFER

BLZERO,	0
	STA
	TAD I	IOTBUF
	DCA	XR1	/POINT INTO THE BUFFER
	TAD	[7400
	DCA	CNOBML	/SET COUNT TO 400 WORDS
	TAD	(232	/INSERT A ^Z IN THE BUFFER FIRST
	CDF 10
	DCA I	XR1
	ISZ	CNOBML
	JMP	.-2	/LOOP FOR THE REST
	CDF
	JMP I	BLZERO	/--RETURN--

	/BUMP 3 FOR 2 CHAR NUMBER FOR CURRENT FILE

CNOBML,	0
	TAD I	IOTHDR	/HEADER WORD
	TAD	[100	/ADD 1 TO THE COUNT BITS
	DCA I	IOTHDR
	JMP I	CNOBML	/DONE
	/STRING COMPARE
	/COMPARE SAC WITH MEMORY, BLANK EXTENDING THE
	/SHORTER STRING ON THE RIGHT

SCOMP,	DCA	MODESW	/SET INTERPRETER TO ARITH MODE NOW
	JMS I	[FACCLR	/TENTATIVELY ASSUME EQUAL (FAC = 0)
SCOMLP,	TAD	STRCNT	/IS THE MEMORY STRING EMPTY NOW?
	SNA CLA
	TAD	L40	/PAD WITH SPACE IF YES
	SNA
	JMS I	(LDB	/LOAD NEXT BYTE IF NOT
	DCA	TEMP2
	TAD	SACLEN	/NOW IS THE SAC EMPTY
	SNA CLA
	TAD	L40	/YES, PAD IT
	SNA
	TAD I	SACXR	/NO GET IT
	CLL CIA		/COMPARE TO MEMORY
	TAD	TEMP2
	SZA CLA
	JMP	SNEQ	/JMP IF NOT EQUAL, L=SENSE OF COMPARE
	TAD	STRCNT	/IS MEMORY STRING DONE
	SZA CLA
	ISZ	STRCNT	/NO, BUMP COUNT
L40,	40		/EFFECTIVE NOP
	TAD	SACLEN	/IS THE SAC EMPTY
	SZA CLA
	ISZ	SACLEN	/NO BUMP COUNT
	TAD	SACLEN	/GET SAC REMAINDER (SKP IF IS JUST ZERO)
	TAD	STRCNT	/ADD ARG REMAINDER
	SZA CLA
	JMP	SCOMLP	/LOOP IF BOTH NOT EMPTY
	JMP I	[ILOOP	/OTHERWISE EQUAL
SNEQ,	STA RAR
	DCA	ACH	/STORE SIGN BIT
	JMP I	[ILOOP	/--RETURN--

	PAGE
	/STRING DATA LIST READ, STRING LOAD AND STRING CONCATENATE

SRLIST,	JMS I	(DLREAD	/FIRST READ NEG BYTE COUNT
	DCA	STRCNT	/STORE IT
	STL		/SET LINK MEANS USE PHONY DATA LIST BYTE LOAD
	SKP		/SKP INTO STRING LOAD ROUTINE
SLOAD,	CLL		/CLEAR LINK TO USE NORMAL LOAD BYTE ROUTINE
	DCA	SACLEN	/CLEAR SAC LENGTH COUNTER
	SZL
	TAD	(DRGCH-LDB /USE PHONY LOAD BYTE
SCON1,	TAD	(LDB	/USE REAL LDB FOR CONCATENATE
	DCA	SCLDB
	TAD	STRCNT
	SNA CLA
	JMP I	[ILOOP	/NOTHING TO DO IF NULL STRING
	TAD	SACLEN	/COMPUTE OFFSET INTO SAC
	CIA
	TAD	[SAC-1
	DCA	SACXR	/TO STORE AFTER END OF PREV STRING
SEGCOM,	JMS I	SCLDB	/GET A BYTE
	DCA I	SACXR	/STORE IT
	STA
	TAD	SACLEN	/NOW BUMP SIZE OF SAC
	DCA	SACLEN
	TAD	SACLEN	/CHECK IF ROOM LEFT
	TAD	(SACLIM
	SPA CLA
SC,	JMS I	[ERROR	/FATAL ERROR IF SAC OVERFLOW
	ISZ	STRCNT
	JMP	SEGCOM	/ITERATE IF MORE
	JMP I	[ILOOP	/--RETURN--

SCLDB,	0

	/ROUTINE TO GET A BYTE FROM THE DATA LIST

DRGCH,	0
	TAD	SACLEN	/TEST FOR EVEN OR ODD
	CLL RAR
	SZL CLA
	JMP	CHR2	/SECOND CHAR
	JMS I	(DLREAD	/FIRST CHAR, READ ANOTHER WORD
	DCA	DRCHR
	TAD	DRCHR
	CLL RTR
	RTR
	RTR		/SHIFT RIGHT
	SKP
CHR2,	TAD	DRCHR	/GET SECOND CHAR
	AND	[77	/MASK TO 6BIT
	JMP I	DRGCH	/RETURN

DRCHR,	0

/ROUTINE TO SET EOF BIT IN I/O ENTRY
EOFSET,	TAD I	IOTHDR	/HEADER
	CLL RTR		/EOF BIT TO LINK
	STL RTL		/SET LINK
			/PUT LINK IN EOF BIT
	DCA I	IOTHDR	/STORE IN I/O TABLE ENTRY
	JMP I	[ILOOP	/EOF BIT SET-ABORT TO ILOOP

/SUBROUTINE MPY- 12 BIT BY 12 BIT MULTIPLY. MULTIPLIES THE CONTENTS
/OF TEMP3 BY THE CONTENTS OF THE AC,LEAVING THE HI RESULT IN TEMP6
/AND THE LOW RESULT IN THE AC

MPY,	0
	DCA	TEMP10
	DCA	TEMP6
	TAD	[-14
	DCA	TEMP5
MP12LP,	TAD	TEMP3
	RAR
	DCA	TEMP3
	TAD	TEMP6
	SNL
	JMP	.+3	/12 BIT MULTIPLY USED TO FIND (DIM1+1)*S2
	CLL
	TAD	TEMP10
	RAR
	DCA	TEMP6
	ISZ	TEMP5
	JMP	MP12LP
	TAD	TEMP3	/LORD OF (DIM1+1)*S2 IN AC
	RAR		/HORD OF (DIM1+1)*S2 IN TEMP6
	JMP I	MPY	/RETURN

	/ROUTINE TO CHECK IF FILE IDLE

IDLE,	0
	TAD I	IOTHND	/GET HANDLER ENTRY
	SNA CLA		/IS IT EMPTY?
FI,	JMS I	[ERROR	/YES-USER TRIED TO DO SOMETHING TO AN UNOPEN FILE
	JMP I	IDLE	/NO-RETURN
/ROUTINE TO READ NEXT WORD IN DATALIST INTO AC

DLREAD,	0
	TAD	DATAXR	/DATA LIST POINTER
	CLL CMA		/SET UP 12 BIT COMPARE
	TAD	DLSTOP	/ADDR OF END OF DATA LIST
	SNL CLA		/POINTER AT END OF LIST?
DA,	JMS I	[ERROR	/YES
DLCDF,	.		/NO-DF TO DATA LIST
	TAD I	DATAXR	/FETCH WORD FROM DATA LIST
	CDF
	JMP I	DLREAD	/DONE

	/RANDOMIZE STATEMENT

FRANDM,	TAD	SPINNR	/USE SPINNR FOR NEW SEED FOR RND(X)
	STL RAL		/MAKE SURE SEED IS ODD
	DCA	RSEED
	JMP I	[ILOOP	/DONE
RSEED,	2713

/SUBROUTINE CR,LF

CRLFR,	0
	TAD	[215
	JMS I	[PUTCH
	TAD	(212
	JMS I	[PUTCH	/PRINT A CR,AND LF
	DCA I	IOTPOS	/ZERO NUMBER OF CHARS PRINTED SO FAR
	JMP I	CRLFR

/SUBROUTINE FOTYPE
/RETURNS TO CALL+1 IF FILE FIXED LENGTH,CALL+2 IF VARIABLE

FOTYPE,	0
	TAD I	IOTHDR	/GET HEADER
	AND	(4	/ISOLATE TYPE BIT
	SZA CLA		/IS IT FIXED LENGTH?
	ISZ	FOTYPE	/NO-BUMP RETURN
	JMP I	FOTYPE	/RETURN

	/ABS(X) FUNCTION

XABSVL,	JMS	ABSVAL	/NEGATE FAC IF NEGATIVE
	JMP I	[ILOOP	/--RETURN--

	/SUBROUTINE TO TAKE ABS VALUE OF FAC

ABSVAL,	0
	TAD	ACH
	SPA CLA		/IS FAC<0?
	JMS I	[FFNEG	/YES-NEGATE IT
	JMP I	ABSVAL	/RETURN

/ROUTINE TO RESTORE THE FAC FROM FP TEMP

FACRES,	0
	JMS I	[FFGET	/GET FAC
	INTERB		
	JMP I	FACRES	/RETURN

	PAGE
	/STRING STORE

SSTORE,	TAD	SACLEN
	SNA
	JMP I	(SSTEX	/EXIT IF NULL STRING IN SAC
	DCA	TEMP1	/SET COUNT
	TAD	SACLEN	/SEE IF WILL FIT
	CIA
	TAD	STRMAX
	SMA SZA CLA	/SKP IF LEN.LE.MAX LEN
SL,	JMS I	[ERROR	/ERROR IF TARGET STRING TOO SMALL
	TAD I	SACXR	/PICK UP SAC BYTE
	JMS I	(DPB	/STORE IT
	ISZ	TEMP1
	JMP	.-3
	JMP I	(SSTEX	/--RETURN--

	/STRING READ FROM FILE TO MEMORY

SREAD,	JMS I	[GETCH	/GET CHAR FROM FILE
	TAD	CHAR
	TAD	[-215	/IS IS CR?
	SNA
	JMP I	(SSTEX	/YES, EXIT
	TAD	(3	/IS IT LF?
	SNA CLA
	JMP	SREAD	/YES, IGNORE IT
	TAD I	(BYTCNT	/SEE IF THIS CHAR WILL FIT
	TAD	STRMAX
	SMA CLA
	JMP	ST	/NO, SOFT ERROR
	TAD	CHAR	/YES, STORE IT
	JMS I	(DPB
	JMP	SREAD
ST,	JMS I	[ERROR
	TAD	[215	/FAKE OUT INPUT ROUTINE
	DCA	CHAR
	JMP I	(SSTEX	/SET STRING SIZE AND EXIT
	/STRING WRITE FROM SAC TO DEVICE

SWRITE,	DCA	COMMAS
	TAD	SACLEN	/SEE IF NULL STRING
	SNA
	JMP I	[ILOOP	/RETURN IF SO
	CIA
	TAD I	IOTPOS	/ADD TO NUMBER OF CHARS PRINTED SO FAR
	TAD	(-WIDTH
	SMA SZA CLA	/SKP IF LE WIDTH OF LINE
	JMS I	[CRLFR	/ELSE RESET CARRAIGE
	TAD	SACLEN
	DCA	STRCNT	/SET LOOP COUNTER
	TAD	[SAC-1
	DCA	SACXR	/POINT AT SAC
SWRLP,	TAD I	SACXR
	TAD	(240
	AND	[77
	TAD	(240	/CONVERT TO 8BIT
	JMS I	(PUTCH
	ISZ	STRCNT
	JMP	SWRLP	/ITERATE IF MORE
	JMP I	[ILOOP	/--RETURN--

/COMMA FUNCTION (KNOWN ONLY TO COMPILER FOR FORMATTING PRINT
/STATEMENTS)

COMMA,	JMS I	[FTYPE	/SKP IF FILE IS ASCII
	JMP I	[ILOOP	/NO-COMMA FUNCTION IS A NOP
	TAD	COMMAS	/GET COMMA SWITCH
	SNA CLA		/WAS LAST THING PRINTED A COMMA?
	JMP	.+3	/NO-WE ARE OK
	TAD	(" 	/YES-PRINT A SPACE BEFORE DOING COMMA CALCULATION
	JMS I	[PUTCH
	IAC
	DCA	COMMAS	/SET COMMA SWITCH
	TAD	(-4
	DCA	TEMP2
	TAD I	IOTPOS	/GET NUMBER OF CHARS PRINTED SO FAR
COMLOP,	TAD	(-COLWID
	SPA		/PAST THIS ONE?
	JMP	SLOVER	/YES-SLIDE PRINT HEAD TO START OF NEXT
	SNA		/EXACTLY ON A COLUMN?
	JMP I	[ILOOP	/YES-DONE
	ISZ	TEMP2	/ALL MARKERS CHECKED YET?
	JMP	COMLOP	/NO-DO NEXT
	CLA		/FALL INTO CR ROUTINE TO RESET COL TO 0

/CARRIAGE RETURN FUNCTION (KNOWN ONLY TO COMPILER FOR TERMINATING
/PRINT STATEMENTS)

CRFUNC,	TAD I	IOTHDR
	CLL RTR
	SNL CLA		/SKP IF EOF IS SET
	JMS I	[FTYPE	/SKP IF FILE IS ASCII
	JMP I	[ILOOP	/WE DON'T WANT TO OUTPUT CLFR
	JMS I	[CRLFR	/DO AS WE ARE TOLD
	JMP I	[ILOOP	/NEXT INST

	/TAB FUNCTION

TAB,	JMS I	[UNSFIX	/FIX X TO INTEGER
	CIA		/NEGATE
	TAD I	IOTPOS	/COMPARE DESIRED COLUMN TO REAL COLUMN
	IAC		/BUMP BY 1 (WORD 7=COL #-1)
	SMA		/IS X>=CURRENT COLUMN?
	JMP I	[ILOOP	/YES-THEN DO NOTHING
			/FALL INTO SPACE OUT ROUTINE

SLOVER,	DCA	COLCNT	/-# OF COLUMNS TO NEXT MARKER
	JMS I	[FTYPE	/IS FILE NUMERIC?
	JMP I	[ILOOP	/YES-THIS IS A NOP
	TAD	(" 	/GET SPACE
	JMS I	[PUTCH	/PRINT IT
	ISZ	COLCNT	/THERE YET?
	JMP	.-3	/NO-TYPE ANOTHER SPACE
	JMP I	[ILOOP	/YES-DONE

COMMAS,	1		/SET TO 1 IF LAST PRINT WAS A COMMA MOVE
COLCNT,	0

/ROUTINE TO CALL ERROR ROUTINE BY FAKING A FUNC2 CALL TO FUNCTION #10

ERROR,	0
	CLA CLL IAC	/ENTRY AC RANDOM
	AND	PSFLAG	/TEST IF OS/8 17600 RESIDENT
	SZA CLA		/SKP IF NOT
	JMS I	[PSWAP	/ELSE FORCE IT OUT (THESE ERRORS ARE FATAL)
	TAD	(7607
	DCA	INSAV	/FAKE A FUNC CALL TO FUNC2 #10
	JMP I	(FUNC2I
XERRRET,JMP I	ERROR	/RETURN TO CALLER IF NON FATAL ERROR

	/FLOATING NEGATE

FNEGI,	JMS I	[FFNEG	/CALL NEGATE ROUTINE
	JMP I	[ILOOP	/RETURN TO ILOOP

NUMBUF,	ZBLOCK	6	/6 DIGIT BUFFER USED BY FFOUT

	PAGE
	/INCREMENT AND LOAD 6BIT BYTE FROM MEMORY

LDB,	0
	JMS	BUMP	/INCREMENT POINTER AND SET DF
	TAD I	BYTPTR	/PICK UP BYTE
	CDF
	ISZ	BYTSWT	/TEST HALFWORD SWITCH
	JMP	.+4
	CLL RTR
	RTR
	RTR
	AND	[77	/MASK TO 6BIT
	JMP I	LDB	/RETURN WITH CHAR IN AC

	/INCREMENT AND DEPOSIT BYTE IN MEMORY

DPB,	0
	AND	[77	/MASK TO 6BIT NOW
	DCA	BYTE
	JMS	BUMP	/INCREMENT POINTER AND SET DF
	TAD	[77	/GET MASK
	ISZ	BYTSWT	/SKP IF PTR BUMPED
	CMA CML		/ELSE PRESERVE LEFT HALF
	AND I	BYTPTR	/ZERO OUT TARGET BYTE
	DCA I	BYTPTR
	TAD	BYTE	/GET BYTE
	SZL
	JMP	.+4	/JMP IF NO SHIFT
	CLL RTL
	RTL
	RTL
	TAD I	BYTPTR
	DCA I	BYTPTR	/STORE BYTE
	CDF
	ISZ	BYTCNT	/TALLY NUMBER OF BYTES STORED
	JMP I	DPB	/--RETURN--

	/BUMP BYTE POINTER

BUMP,	0
	TAD	BYTSWT	/BUMP LOW ORDER BIT
	CLL CMA
	DCA	BYTSWT
	ISZ	BYTSWT	/SKP IF NO CARRY
	ISZ	BYTPTR	/ELSE BUMP WORD PTR
	JMP	BYTCDF	/JMP OUT IF FIELD NOT CROSSED
	TAD	[10
	TAD	BYTCDF
	DCA	BYTCDF	/PROPAGATE CARRY INTO CDF INSTR
BYTCDF,	0		/GETS SET BY BYTSET TO TARGET FIELD
	JMP I	BUMP	/RETURN WITH A CLEAR LINK

	/BYTE LOAD/STORE INITIALIZE ROUTINE

BYTSET,	0
	TAD	SSTEX	/GET FIELD OF STRING
	DCA	BYTCDF	/STORE INLINE
	TAD	STRPTR	/NOW GET ADDR OF COUNT WORD
	DCA	BYTPTR	/STORE
	IAC
	DCA	BYTSWT	/SET LOW ORDER BIT TO CARRY NEXT TIME
	DCA	BYTCNT	/CLEAR DEPOSITED BYTE COUNT
	TAD	[SAC-1
	DCA	SACXR	/ALWAYS RETURN WITH SAC POINTER SET UP
	JMP I	BYTSET	/--RETURN--

	/STRING STORE EXIT ROUTINE

SSTEX,	0		/GETS SET BY STFIND TO DF OF STRING
	TAD	BYTCNT	/ENTER WITH POSITIVE LENGTH IN COUNT
	CIA
	DCA I	STRPTR	/STORE IN STRING
	JMP I	[ILOOP	/--RETURN-- (ILOOP RESETS DF)

BYTCNT,	0
BYTPTR,	0
BYTSWT,	0
BYTE,	0
/SUBROUTINE BUFCHK-CHECKS THE POSITION OF THE BUFFER POINTER FOR
/THE DEVICE WHOSE I/O TABLE ENTRY IS IN WORKING AREA. RETURNS TO CALL+1
/IF THE POINTER IS AT THE END AND CHAR NUMBER IS 1 (LAST
/AVAILABLE CHAR 3 HAS BEEN USED),CALL+2 IF THE POINTER IS AT THE
/END BUT THE CHAR # IS NOT 1 (THERE IS 1 CHAR 3 LEFT), CALL+3
/IF THERE IS 1 WORD LEFT IN BUFFER,CALL+4 IF MORE THAN 1 LEFT.

BUFCHK,	0
	TAD	ENTNO	/GET DEVICE #
	SNA CLA		/IS IT TTY?
	TAD	(62-400	/YES-CHECK FOR A BUFFER 60 WORDS LONG
	TAD	[400	/NO-CHECK FOR A BUFFER 400 WORDS LONG
	TAD I	IOTBUF	/ADD LENGTH TO BUFFER ADDRESS
	CIA		/-ADDR OF END OF BUFFER
	TAD I	IOTPTR	/CHECK AGAINST CURRENT POINTER
	SNA		/IS POINTER AT END OF BUFFER?
	JMP	EBC	/AT END-CHECK THE CHAR #
	ISZ	BUFCHK
	ISZ	BUFCHK	/NO-BUMP RETURN
	IAC
	SNA CLA		/WAS POINTER AT LAST WORD?
	JMP I	BUFCHK	/YES-RETURN TO CALL+3
	ISZ	BUFCHK	/NO
	JMP I	BUFCHK	/RETURN TO CALL+4

EBC,	JMS I	[CHARNO	/GET CHAR #
	JMP I	BUFCHK	/IT WAS 1-RETURN TO CALL+1
	NOP		/IT WAS 3-RETURN TO CALL+2
	ISZ	BUFCHK	/IT WAS 2-RETURN TO CALL+2
	JMP I	BUFCHK

/SUBROUTINE PACKCH-PACKS ASCII CHARS,3 FOR 2, INTO BUFFER FOR THE
/DEVICE IN WORK AREA. CALL WITH THE CHARACTER IN THE AC

PACKCH,	0
	DCA	TEMP1	/SAVE
	JMS I	[CHARNO	/DETERMINE CHARACTER NUMBER
	SKP		/1
	JMP	CHAR3P	/3
	TAD	TEMP1	/1 OR 2-GET CHAR AGAIN
	JMS I	[WRITFL	/STORE IN BUFFER
	JMS I	(CNOBML	/BUMP CHARACTER NUMBER
	JMP I	PACKCH	/DONE

CHAR3P,	AC7776
	TAD I	IOTPTR	/BACK BUFFER POINTER UP TO POINT TO CHAR 1
	DCA I	IOTPTR
	TAD	TEMP1	/CHAR
	CLL RTL
	RTL		/SLIDE LEFT HALF INTO BITS 0-3
	DCA	TEMP1	/SAVE
	TAD	TEMP1
	JMS	COMBNE	/ISOLATE LEFT HALF,COMBINE WITH CHAR1,AND PUT IN FILE
	TAD	TEMP1	/CHAR AGAIN
	CLL RTL
	RTL		/SLIDE RIGHT HALF INTO BITS 0-3
	JMS	COMBNE	/ISOLATE RIGHT HALF,COMBINE WITH CHAR 2,AND PUT IN FILE
	JMS I	[CNOCLR	/CLEAR THE CHARACTER NUMBER (RESET IT TO 1)
	JMP I	PACKCH	/DONE

COMBNE,	0
	AND	[7400	/ISOLATE HALF IN QUESTION
	DCA	TEMP2	/SAVE
	JMS I	(BCGET	/GET A WORD FROM FILE BUFFER IN FIELD 1
	AND	[377	/FLUSH ANY SLUSH IN BITS 0-3
	TAD	TEMP2	/COMBINE
	JMS I	[WRITFL	/PUT IN BUFFER
	JMP I	COMBNE	/RETURN

	PAGE
/ROUTINE TO READ WORD FROM FILE BUFFER AND BUMP POINTER

READFL,	0
	JMS I	(FOTYPE	/IS FILE VARIABLE LENGTH
	SKP
VR,	JMS I	[ERROR	/YES-IT IS AN ERROR TO TRY AND READ IT
	TAD I	IOTHDR	/CHECK IF MORE THERE
	CLL RTR		/EOF BIT TO LINK
	SNL CLA		/EOF?
	JMP	.+3	/NO-CONTINUE
RE,	JMS I	[ERROR	/YES-ATTEMPT TO READ BEYOND EOF
	JMP I	[ILOOP	/NOT FATAL-RETURN TO I LOOP
	JMS	BCGET	/GET WORD FROM FILE BUFFER
	ISZ I	IOTPTR	/BUMP POINTER
	JMP I	READFL	/DONE

/ROUTINE TO WRITE AC IN FILE BUFFER AND INCREMENT POINTER

WRITFL,	0
	JMS I	(BCPUT	/STORE AC IN FILE BUFFER
	ISZ I	IOTPTR	/BUMP POINTER
	TAD I	IOTHDR	/GET FILE HEADER WORD
	CLL RTR		/EOF BIT TO LINK
	SNL CLA		/WAS FILE PAST END?
	JMP I	WRITFL	/NO-RETURN
WE,	JMS I	[ERROR	/YES-ATTEMPT TO WRITE PAST END OF FILE
	JMP I	[ILOOP	/NON-FATAL RETURN TO ILOOP

/ROUTINE TO GET ONE WORD FROM FILE BUFFER IN FIELD 1

BCGET,	0
	JMS I	[IDLE	/CHECK IF FILE OPEN
	TAD I	IOTPTR	/GET READ WRITE POINTER
	DCA	WRITFL	/SAVE
	TAD	ENTNO	/GET FILE #
	SZA CLA		/IF TTY,BUFFER FIELD IS 0
	CDF 10		/DF TO BUFFER FIELD
	TAD I	WRITFL	/GET WORD FROM BUFFER
	CDF
	JMP I	BCGET	/RETURN
/SUBROUTINE UNPACK-UNPACKS ASCII, 3 FOR 2 ,FROM THE FILE IN THE I/O
/WORKING AREA. RETURNS WITH THE CHAR IN CHAR.

UNPACK,	0
	JMS I	[CHARNO	/GET CHAR #
	SKP		/1
	JMP	CHAR3U	/3
	JMS I	(CNOBML	/BUMP CHAR NUMBER
	JMS	READFL	/GET CHAR AGAIN
U123C,	AND	[177	/STRIP OFF 7 BITS
	SNA
	JMP	UNPACK+1	/ZERO
	TAD	[200
	DCA	CHAR	/SAVE
	TAD	CHAR
	TAD	(-232	/IS IT CTRL/Z?
	SNA CLA
	JMP I	[EOFSET	/YES-SET EOF BIT
	JMP I	UNPACK	/RETURN

CHAR3U,	JMS I	[CNOCLR	/RESET CHAR # TO 1
	AC7776
	TAD I	IOTPTR
	DCA I	IOTPTR	/BACK BUFFER POINTER UP 2
	JMS	READFL	/GET LEFT HALF OF CHAR
	AND	[7400
	DCA	XR5	/SAVE
	JMS	READFL	/GET NEXT WORD WITH RIGHT HALF
	AND	[7400	/ISOLATE RIGHT HALF
	CLL RTR
	RTR		/SLIDE RIGHT HALF OVER
	TAD	XR5	/COMBINE WITH LEFT HALF
	CLL RTR
	RTR		/MOVE TO BITS 4-11
	JMP	U123C	/REJOIN MAINLINE
/READ FUNCTION-GETS NUMBERS INTO VARIABLES

READI,	JMS I	[FTYPE	/SKP IF FILE IS ASCII
	JMP	RIMAGE	/READ NUMERIC IMAGE
	JMS I	(FFIN	/READ ASCII INTO NUMBER
	JMP I	[ILOOP	/--RETURN--
RIMAGE,	JMS I	[BUFCHK	/YES-CHECK BUFFER POINTER
	NOP		/PAST END-NEXT RECORD
	NOP		/AT END-NEXT RECORD
	JMS I	[NEXREC	/ONLY 1 WORD LEFT-IT IS UNUSED IN NUMERIC FMT
	JMS	READFL	/GET WORD FROM FILE
	DCA	ACX		/STORE AS EXPONENT
	JMS	READFL	/GET WORD FROM FILE
	DCA	ACH	/STORE AS HIGH MANTISSA
	JMS	READFL	/GET WORD FROM FILE
	DCA	ACL	/STORE AS LOW MANTISSA
	JMP I	[ILOOP	/DONE

/ROUTINE TO FETCH ASCII CHARACTERS FROM FILE BUFFER

GETCH,	0
	JMS I	[FTYPE	/IS FILE ASCII?
SR,	JMS I	[ERROR	/NO-ERROR
	TAD	ENTNO
	SZA CLA
	JMP	NTTY
	TAD	TCHAR
	TAD	[-215
	SNA CLA
	JMS I	[DRCALL
NTTY,	JMS I	[BUFCHK	/NO-CHECK STATUS OF BUFFER
	JMS I	[NEXREC	/LAST CHAR READ-NEXT RECORD
	NOP		/CHAR 3 NOT USED YET
TCHAR,	215		/NOP: CHAR 2 AND 3 LEFT
	JMS	UNPACK	/UNPACK CHAR FROM BUFFER
	TAD	ENTNO
	SZA CLA
	JMP I	GETCH	/RETURN
	TAD	CHAR
	DCA	TCHAR
	JMP I	GETCH

/SUBROUTINE CHARNO-RETURNS TO CALL+1 IF CHAR #=1,CALL+2 IF 3,CALL+3
/IF 2

CHARNO,	0
	TAD I	IOTHDR	/HEADER
	AND	(300	/ISOLATE CHAR #
	CLL RTL
	RTL		/CHAR # TO BITS 0,1
	SMA SZA		/IS IT 2?
	ISZ	CHARNO	/YES-BUMP RETURN
	SZA CLA		/IS IT 2 OR 3?
	ISZ	CHARNO	/YES-BUMP RETURN
	JMP I	CHARNO	/RETURN

	PAGE
/WRITE FUNCTION-PUTS NUMBERS IN FILE BUFFERS

WRITEI,	JMS I	[FTYPE	/SKP IF FILE IS ASCII
	JMP	WIMAGE	/ELSE DO IMAGE WRITE
	JMS I	(FFOUT	/CONVERT INTERNAL TO ASCII
	TAD	XR1
	CIA
	TAD	(INTERB-1 /CALCULATE NUMBER OF CHARS STORED IN BUFFER
	DCA	TEMP10	/SAVE
	TAD	(INTERB-1
	DCA	SACXR	/NOW POINT SACXR INTO BUFFER
	TAD	TEMP10	/GET COUNT OF CHARS TO BE PRINTED
	CIA
	TAD I	IOTPOS	/ADD TO PRINT HEAD POSITION
	TAD	(-WIDTH	/COMPARE AGAINST "72"
	SMA SZA CLA	/WILL THE NUMBER FIT ON THIS LINE?
	JMS I	[CRLFR	/NO-ISSUE A CR,LF
CPLOOP,	TAD I	SACXR	/GET CHAR FROM INTERMEDIATE BUFFER
	JMS	PUTCH	/PUT ON DEVICE
	ISZ	TEMP10	/BUMP COUNTER
	JMP	CPLOOP	/NEXT
	TAD	O240
	JMS	PUTCH	/SEND OUT A SPACE AFTER NUMBER
	JMP	WDONE	/TAKE COMMON EXIT
WIMAGE,	JMS I	[BUFCHK	/FILE IS NUMERIC-CHECK BUFFER STATUS
O240,	240		/PAST END-NEW RECORD (AND INST SERVES AS NOP)
O210,	0210		/AT END-NEW RECORD (AND SERVES AS NOP)
	JMS I	[NEXREC	/ONE WORD LEFT-DON'T USE IT
	TAD	ACX	/EXPONENT
	JMS I	[WRITFL	/WRITE IN BUFFER
	TAD	ACH	/HIGH MANTISSA
	JMS I	[WRITFL	/WRITE IN BUFFER
	TAD	ACL	/LOW MANTISSA
	JMS I	[WRITFL	/WRITE IN BUFFER
WDONE,	DCA I	(COMMAS	/CLEAR COMMA SWITCH
	JMP I	[ILOOP	/WRITE IS DONE
/ROUTINE TO PUT ASCII CHARS IN FILE BUFFER. IGNORES RUBOUTS.

PUTCH,	0
	DCA	TEMP1	/SAVE CHAR
	TAD	TEMP1	/GET CHAR AGAIN
	TAD	(-377
	SNA CLA		/IS IT A RUBOUT?
	JMP I	PUTCH	/YES-RETURN
	JMS I	[FTYPE	/IS FILE NUMERIC?
SW,	JMS I	[ERROR	/YES-ERROR
	ISZ I	IOTPOS	/BUMP COULMN NUMBER
	TAD	ENTNO	/GET ENTRY #
	SNA CLA		/IS IT TTY?
	JMP	TOUT	/YES-JUST PUT CHARS IN RING BUFFER
	JMS I	[BUFCHK	/NO-IS BUFFER FULL?
	JMS I	[NEXREC	/YES-NEXT RECORD
O40,	40		/THERE IS A CHAR 3 LEFT (AND IS A NOP)
O20,	20		/THERE IS A CHAR 2 AND 3 LEFT (AND IS A NOP)
	TAD	TEMP1	/GET CHAR AGAIN
	JMS I	[PACKCH	/PUT IN BUFFER
	JMP I	PUTCH	/RETURN

TOUT,	TAD	TEMP1	/GET CHAR
	JMS I	[XPUTCH	/PUTCH CHAR IN OUTPUT BUFFER FOR TTY
	JMP I	PUTCH	/RETURN
/SUBROUTINE NEXREC-WRITES THIS BUFFER IN FILE,THEN READS IN NEXT BUFFER
/IF POSSIBLE,ELSE SETS EOF BIT. IF DEVICE IS READ OR WRITE ONLY
/IT JUST READS OR WRITES A BLOCK,WHICHEVER IS APPROPRIATE

NEXREC,	0
	TAD I	IOTHDR	/GET HEADER
	AND	O20		/GET READ/WRITE ONLY BIT
	SNA CLA		/IS IT ON?
	JMP	FILSTR	/NO-DEVICE IS FILE STRUCTURED
	JMS I	(FOTYPE	/YES-IS IT INPUT OR OUTPUT FILE?
	JMP	RONLY
	JMS	WRBLK
RWONC,	ISZ I	IOTBLK
	JMS	BLINIT	/INIT FILE TABLE ENTRIES
	JMP I	NEXREC	/DONE

RONLY,	JMS	BLREAD
	JMP	RWONC

FILSTR,	JMS	WRBLK	/WRITE THE CURRENT BLOCK IF IT HAS BEEN CHANGED
	JMS	BLINIT	/INIT FILE TABLE ENTRIES
	ISZ I	IOTBLK	/BUMP BLOCK #
	TAD I	IOTLOC	/STARTING BLOCK
	CIA		/NEGATE
	TAD I	IOTBLK	/SUBTRACT FROM CURRENT BLOCK FOR FILE LENGTH
	CLL CMA		/SET UP CURRENT FILE LENGTH FOR 12 BIT COMPARE
	TAD I	IOTLEN	/COMPARE TO ACTUAL LENGTH
	SNL CLA		/IS IT > CURRENT LENGTH?
	JMP	LASTB	/YES-EXTEND THE FILE IF IT IS OUTPUT
	JMS	BLREAD	/READ IN THE NEXT RECORD
	JMP I	NEXREC	/RETURN


LASTB,	JMS I	(FOTYPE	/IS FILE FIXED LENGTH?
	JMP I	[EOFSET	/YES-SET EOF FLAG
	TAD I	IOTLEN	/NO-GET ACTUAL LENGTH
	CLL CMA	
	TAD I	IOTMAX	/MAXIMUM LENGTH
	SNL CLA		/IS ACTUAL LENGTH >= MAXIMUM LENGTH?
	JMP I	[EOFSET	/YES-SET EOF BITS
	ISZ I	IOTLEN	/NO-BUMP ACTUAL LENGTH
	JMP I	NEXREC	/RETURN WITHOUT READING NEXT RECORD
/ROUTINE TO READ 2 PAGES FROM DEVICE

BLREAD,	0
	JMS I	(BLZERO
	TAD	O210	/"READ 2 PAGES"
	JMS I	[DRCALL	/HANDLER CALL
	JMP I	BLREAD

/ROUTINE TO WRITE 2 PAGES ONTO DEVICE

WRBLK,	0
	TAD I	IOTHDR	/GET FILE HEADER
	AND	O40	/GET FILE WRITTEN BIT
	SNA CLA		/HAS THIS BLOCK BEEN CHANGED?
	JMP I	WRBLK	/NO-RETURN
	TAD	(4210	/"WRITE 2 PAGES"
	JMS I	[DRCALL	/CALL TO DEVICE HANDLER
	JMS I	(BLZERO
	JMP I	WRBLK

/ROUTINE TO INITIALIZE I/O TABLE ENTRIES AFTER READ OR WRITE

BLINIT,	0
	TAD I	IOTBUF
	DCA I	IOTPTR	/INIT READ/WRITE POINTER
	TAD I	IOTHDR
	AND	(7437	/SET CHAR # TO 1 AND CLEAR BLOCK WRITTEN BIT
	DCA I	IOTHDR
	JMP I	BLINIT

/ROUTINE TO SAVE THE FAC IN FP TEMP 

FACSAV,	0
	JMS I	[FFPUT	/STORE FAC
	INTERB		/USE INTERMEDIATE BUFFER FOR TEMP STORAGE
	JMP I	FACSAV	/RETURN

	PAGE






/////////////////////////////////////////////////////////////
/////////////////////////////////////////////////////////////
////////////  OVERLAY BUFFER  3400-4600  ////////////////////
////////////  CONTAINS FUNCTION OVERLAYS ////////////////////
////////////  AT RUN TIME                ////////////////////
/////////////////////////////////////////////////////////////
/////////////////////////////////////////////////////////////


/////////////////////////////////////////////////////////////
/////////////////////////////////////////////////////////////
////////////// OVERLAY 1-ARITHMETIC FUNCTIONS ///////////////
/////////////////////////////////////////////////////////////
/////////////////////////////////////////////////////////////

	*OVERLAY



/INTEGER FUNCTION
/RANGE=ALL X

INT,	VERSON^100+SUBVAF+6000 /INITIALLY CONTAINS VERSION OF ARITH OVERLAY
	JMS I	[FFPUT	/SAVE X
	FPPTM1
	TAD	ACX	/GET EXPONENT
	SMA SZA CLA	/IS EXP<0?
	JMP	INSC	/NO-GO ON
	TAD	ACH	/YES
	SPA CLA		/IS X<0?
	JMP	M1R	/YES-INT=-1
	JMS I	[FACCLR	/YES-RETURN A 0
	JMP I	INT
INSC,	TAD	ACH	/GET HI MANTISSA
	SMA CLA		/IS IT <0?
	JMP	INTPOS	/NO-USE FAC AS IS
	JMS I	[FFNEG	/YES-NEGATE FAC (MAKE IT POS)
	IAC		/AND SET FLAG
INTPOS,	DCA	TEMP3	/FLAG FOR NEGATIVE
	DCA	TEMP5	/ZERO LORD MASK
	CLL CML RAR
	DCA	TEMP4	/INITIALIZE HORD MASK TO 4000
	TAD	ACX
	CIA		/- COUNT
	DCA	TEMP2
MASKL,	TAD	TEMP4
	CLL CML RAR	/ROTATE 1'S THROUGH 3 WORD MASK
	DCA	TEMP4	/
	TAD	TEMP5	/UNTIL THERE IS A COUNT OF ZERO
	RAR
	DCA	TEMP5
	ISZ	TEMP2	/DONE?
	JMP	MASKL	/NO
	TAD	ACH	/YES-MASK HORD
	AND	TEMP4
	DCA	ACH
	TAD	ACL	/MASK LORD
	AND	TEMP5
	DCA	ACL
	TAD	TEMP3	/NEG FLAG
	SNA CLA		/WAS ORIGINAL NUMER <0?
	JMP I	INT	/NO-DONE
	JMS I	[FFPUT	/SAVE INT(X)
	FPPTM2
	JMS I	(FFADD	/-INT(X)+(X)
	FPPTM1
	TAD	ACH	/SAVE HORD
	DCA	TEMP3
	JMS I	[FACCLR	/FLUSH FAC
	TAD	TEMP3	/WAS INT(X)=X?
	SNA CLA
	JMP	JUSNEG	/YES-JUST NEGATE INT(X)
	JMS I	(FFADD	/NO-ADD 1
	ONE
JUSNEG,	JMS I	(FFADD	/GET INT(X)
	FPPTM2
JNEG,	JMS I	[FFNEG	/AND  NEGATE (INT(5.3)=-6)
	JMP I	INT	/DONE

M1R,	JMS I	[FFGET	/LOAD FAC WITH 1
	ONE
	JMP	JNEG	/JUST NEGATE AND RETURN

ONE,	1
	2000
	0

/EXPONENTIATION FUNCTION
/IF B=0,A^B=1
/IF A=0 AND B>0,A^B=0
/IF A=0 AND B<0,DIVIDE BY ZERO ERROR MESSAGE RESULTS AND A^B=0
/IF B=INTEGER > 0, A^B=A*A*A*.......*A
/IF B=INTEGER < 0, A^B=1/A*A*A*.......*A
/IF B=REAL AND A>0, A^B=EXP(B*LOG(A))
/IF B=REAL AND A<0, A FATAL ERROR RESULTS

EXPON,	0
	JMS I	[FFPUT	/SAVE A
	FPPTM5
	JMS I	[FFPUT	/SET UP RUNNING PRODUCT IN CASE OF
	FPPTM4		/MULTIPLIES
	TAD	ACH	/HI ORDER OF A
	DCA	EXPON	/SAVE IT
	DCA	INSAV	/POINTER TO B IN SYMBOL TABLE
	JMS I	ARGPLL	/FIND B
	JMS I	[FFGET	/GET B
ARGPLL,	ARGPRE		/LOC SKIPPED BY FPP,SO WE USE IT FOR CONSTANT
	CDF
	TAD	ACH	/HI ORDER OF B
	SNA		/IS B=0?
	JMP I	(RETRN1	/YES A^B=1
	SMA CLA		/IS B<0?
	JMP	.+4	/NO
	TAD	EXPON	/YES-GET HI ORDER A
	SNA CLA		/IS A=0?
	JMP I	(DV	/YES-DIVIDE BY ZERO ERROR
	TAD	EXPON	/B>0. IS A=0?
	SNA CLA
	JMP	RET0	/YES A^B=0
	JMS I	[FFPUT	/SAVE B
	FPPTM3
	JMS	INT		/GET INT(B)
	JMS I	(MULLIM	/TEST EXPONENT OF RESULT TO LIMIT LARGE MULTIPLY LOOPS
	JMS I	(FFSUB	/INT(B)-B
	FPPTM3
	TAD	ACH	/IS INT(B)-B=0?
	SZA CLA
	JMP I	(USELOG	/NO-USE LOGS
	JMS I	[FFGET	/NO-USE REPETITIVE MULTIPLY
	FPPTM3		/GET B AGAIN
	TAD	ACH
	DCA	EXPON	/SAVE SIGN OF B
	JMS I	(ABSVAL	/!B!
	JMS I	[FFPUT	/USE ABS(B) AS MULTIPLY COUNT
	FPPTM3
EMLOOP,	JMS I	[FFGET	/GET B
	FPPTM3
	JMS I	(FFSUB	/B-1
	ONE
	JMS I	[FFPUT	/SAVE NEW COUNT
	FPPTM3
	TAD	ACH
	SNA CLA		/IS COUNT ZERO YET
	JMP I	(EMDONE	/YES-MULTIPLIES ARE DONE
	JMS I	[FFGET	/NO-GET RUNNING PRODUCT
	FPPTM4
	JMS I	(FFMPY	/MULTIPLY BY A
	FPPTM5
	JMS I	[FFPUT	/SAVE NEW RUNNING PRODUCT
	FPPTM4
	JMP	EMLOOP

RET0,	JMS I	[FACCLR	/RETURN WITH 0 IN FAC
	JMP I	[ILOOP

	PAGE
EMDONE,	JMS I	[FFGET	/GET RUNNING PRODUCT
	FPPTM4
	TAD I	EXPONK	/GET SIGN OF B
	SMA CLA		/WAS IT -?
	JMP I	[ILOOP	/NO-A^B=A*A*A*...*A
	JMS I	FIDVP	/YES-INVERT
	ONE
	JMP I	[ILOOP	/A^B=1/A:A*A*...*A

RETRN1,	JMS I	[FFGET
	ONE		/SET FAC TO 1
	JMP I	[ILOOP

USELOG,	TAD I	EXPONK	/SIGN OF A
	SPA CLA		/A<0?
EM,	JMS I	[ERROR	/YES-PRINT A MESSAGE
	JMS I	[FFGET	/LOAD A
	FPPTM5
	JMS I	FFLOGL	/LOG(A)
	JMS I	FMPYLV	/B*LOG(A)
	FPPTM3
	JMS I	FFEXPL	/EXP(B*LOG(A))
	JMP I	[ILOOP	/DONE


FFEXPL,	EXPON1
FFLOGL,	LOG
FMPYLV,	FFMPY
EXPONK,	EXPON
FIDVP,	FFDIV1

/SGN FUNCTION

SGN,	0
	TAD	ACH	/GET HIGH MANTISSA
	SNA		/IS X=ZERO?
	JMP I	[ILOOP	/YES-THEN LEAVE IT ALONE
	SPA CLA		/IS X>0?
	JMP	.+3	/NO
	IAC		/YES-SET FAC=1
	SKP
	CMA		/NO-SET FAC=-1
	DCA	ACX		/SET UP FLOAT
	JMS I	[FFLOAT	/FLOAT VALUE OF SGN FUNCTION
	JMP I	[ILOOP	/DONE
	IFZERO EAE <
/FLOATING SQUARE ROOT
/USES A HARDWARE TYPE ALGORITHM FOR BINARY SQUARE ROOTS
/REF: THE LOGIC OF COMPUTER ARITHMETIC-IVAN FLORES-P 409
/
FROOT,	0
	CLA CLL CML RTR	/SET RESULT TO 2000;0000
	DCA	AN1
	DCA	AN2
	CDF		/DF TO PACKAGE FIELD
	TAD	KM22	/SET COUNTER FOR DEVELOPING 22 BITS OF RESULT
	DCA	AC2	/ALREADY HAVE 1
	TAD	ACH
	SNA
	JMP I	FROOT	/ZERO FAC-NORMALIZED!-RETN. SAME
	SPA	CLA
	JMS I	[FFNEG	/TAKE ROOT OF ABSOL VALUE
	TAD	ACX	/GET EXPONENT OF FAC
	SPA		/IF NEGATIVE-MUST PROPAGATE SIGN
	CML
	RAR		/DIVIDE EXP. BY 2
	DCA	ACX	/STORE IT BACK
	SZL		/INCREMENT EXP. IF ORIGINAL EXP 
	ISZ	ACX	/WAS ODD
	NOP
	SNL		/DO A PRE-SHIFT FOR EVEN EXPONENTS
	JMS I	AL1K	/SO FIRST BIT PAIR IS 10 NOT 01
	CLA CLL CMA RAL	/SET COUNTER FOR DETECTING A
	DCA	ZCNT	/ZERO REMAINDER
	CLA CLL CML RTR	/SET UP POSITION OF TRIAL BIT
	RTR		/FOR FIRST PASS THRU LOOP
	DCA	OPH
	DCA	OPL
	TAD	K6000	/GET A FAST FIRST BIT-WE KNOW 
	TAD	ACH	/THIS WILL WORK SINCE # IS NORMALIZED
	DCA	ACH	/IF # IS A POWER OF TWO, AND A PERFECT
	TAD	ACH	/SQUARE-WE ARE DONE HERE!
	SNA		/WELL IS IT?
	TAD	ACL	/COULD BE-CHECK LOW ORDER
	SNA	CLA
	JMP	DONE	/WHOOPPEE-WE WIN BIG.
	JMP	LOP01	/NOPE-LOOP DON'T SHIFT FIRST TIME
SLOOP,	TAD	OPH	/SHIFT TRIAL BIT 1 PLACE
	CLL	RAR	/TO THE RIGHT
	DCA	OPH	/AND STORE BACK
	TAD	OPL
	RAR
	DCA	OPL
	JMS I	AL1K	/SHIFT FAC LEFT 1 PLACE
LOP01,	TAD	OPL	/ADD TRIAL BIT TO`ANSWER
	TAD	AN2	/SO FAR
	CLL CMA IAC	/NEGATE IT
	TAD	ACL	/AND ADD TO FAC (REMAINDER SO FAR)
	SNA		/IS RESULT ZERO?
	ISZ	ZCNT	/YES-INCREMENT COUNTER
	DCA	TM	/STORE RESULT IN TEMPORARY
	CML	RAL	/ADD CARRY TO HIGH ORDER FOR SUBTRACT
	TAD	OPH	/ADD TRIAL BIT
	TAD	AN1	/ADD RESULT SO FAR (HI ORDER)
	CLL CMA IAC	/AND SUBTRACT FROM HI ORDER FAC
	TAD	ACH
	SNL		/RESULT NEGATIVE?
	JMP	GON	/YES-NEXT RESULT BIT IS 0
	SZA		/NO-IS HI ORDER RESULT=0?
	JMP	LOP02	/NO-GO ON
	ISZ	ZCNT	/YES-WAS LOW ORDER =0?
	JMP	.+3	/NO-GO ON
	CMA		/YES-REM.=0-SET COUNTER SO
	DCA	AC2	/LOOKS LIKE WE'RE DONE
LOP02,	DCA	ACH	/STORE HIGH ORDER REM. IN FAC
	TAD	TM	/STORE LO ORDER REM. IN FAC
	DCA	ACL
	TAD	OPL	/TRIAL BIT SHIFTED LEFT 1 IS
	CLL	RAL	/RESULT BIT-ADD IT TO ROOT DEVELOPED
	TAD	AN2	/SO FAR
	DCA	AN2
	TAD	OPH
	RAL
	TAD	AN1
	DCA	AN1
GON,	CLA CLL CMA RAL	/RESET COUNTER FOR ZERO REM.
	DCA	ZCNT	
	ISZ	AC2	/DONE ALL 23 RESULT BITS?
	JMP	SLOOP	/NO-GO ON
DONE,	TAD	AN1	/YES-STORE ANSWER IN FAC
	DCA	ACH	/ITS NORMALIZED ALREADY
	TAD	AN2
	DCA	ACL
	JMP I	FROOT	/AND RETURN

K6000,	6000
ZCNT,	0
AL1K,	AL1
AN1,	0
AN2,	0
KM22,	-26

	PAGE
	>
	IFNZRO EAE <
/
/FLOATING SQUARE ROOT
/USES MODIFIED HARDWARE ALGORITHM FOR BINARY SQUARE ROOTS
/REF: THE LOGIC OF COMPUTER ARITHMETIC-IVAN FLORES; P-409
	*SGN+14
FROOT,	0
	CLA CLL CML RTR	/SET RESLT TO 2000,0000
	DCA	OPL
	DCA	OPH
	SWAB		/MODE B OF EAE-ALSO DOES MQL
	CDF
	DCA	RBCNT	/CLR. SHIFT COUNTER
	TAD	KM22
	DCA	AC2	/SET COUNTER FOR 23 BITS OF RESULT
	TAD	ACX	/GET EXPONENT OF FAC
	ASR		/DIVIDE BY 2
	1
	DCA	ACX	/STORE IT BACK
	DPSZ		/INCREMENT EXP. IF ORIG. EXP
	ISZ	ACX	/WAS ODD
	NOP
	MQA		/DETERMINE WHETHER TO DO A 
	CLL	RAL	/PRE-SHIFT FOR EVEN EXPONENTS.
	CML	RAL
	DCA	RKNT	/STORE BIT-0 OR 1 SHIFT CNT
	CLL CML RTR	/SET UP FIRST TRIAL BIT
	RTR
	DCA	AC1
	DCA	AC0	/STORE AWAY
	DCA	ACNT	/ZERO COUNTER
	DLD		/GET THE FAC
	ACH
	SWP		/GET IN RIGHT ORDER
	SNA		/IS IT ZERO? (HI ORD=0)
	JMP I	FROOT	/YES-ROOT = 0
	SPA		/NEGATIVE?
	DCM		/YES-TAKE ABSOL. VALUE
	SHL		/SHIFT # 1 BIT IF EXP WAS EVEN
RKNT,	0		/SO FIRST BIT PAIR IS 10 NOT 01
	TAD	K6000	/SUBTRACT 2000-KNOW FIRST BIT
	DPSZ		/IS 1(NORMALIZED)-DONE??
	JMP	LOP1	/NO-WE MUST LOOP
	JMP	DONE	/YES-AN EASY ONE!!!
LOOP,	DLD		/GET THE FAC
	ACH
	SHL		/SHIFT FAC APPROPRIATELY
	1
LOP1,	DST		/MUST STOR BACK IN CASE RESLT
	ACH		/BIT IS 0
	DLD		/GET TRIAL BIT
	AC0

	ASR		/SHIFT THE BIT APPROPRIATELY
ACNT,	0
	ISZ	ACNT	/SHIFT 1 MORE NEXT TIME
	DAD		/ADD IN RESULT SO FAR
	OPH
	DCM		/NEGATE IT
	ISZ	RBCNT	/BUMP COUNTER FOR RESLT BIT
	DAD		/DO THE SUBTRACT
	ACH
	SNL		/RESULT NEGATIVE?
	JMP	GON	/YES-NEXT RESULT BIT = 0

	DPSZ		/NO-DID WE GET A ZERO REMAINDER?
	JMP	NOTZRO	/NOPE
ZREM,	CMA		/YES-SET SO LOOKS LIKE WE'RE DONE
	DCA	AC2
NOTZRO,	DST		/GOOD SUBTR.-MODIFY FAC
	ACH		/ITS NOT CHANGED BY BAD SUBTRACT
	CAM		/CLEAR EVERYTHING
	RTR
	ASR		/SHIFT RESLT BIT TO RIGHT PLACE
RBCNT,	0
	DAD		/ADD IT TO THE RESULT SO FAR
	OPH		/WE APPEND IT TO RIGHT OF LAST 
	DST		/BIT
	OPH		/STORE IT BACK
GON,	ISZ	AC2	/DONE 23 BITS?
	JMP	LOOP	/NO-GO ON
DONE,	DLD		/YES-GET RESULT-ITS NORMALIZED
	OPH
	DCA	ACH	/STORE HIGH ORDER BACK
	SWP
	DCA	ACL	/STORE LOW ORDER BACK
	JMP I	FROOT	/RETURN
KM22,	-26
K6000,	6000

	PAGE
	>
/23-BIT EXTENDED FUNCTIONS

/1-31-72       R BEAN

/******SINE******

SIN,	0
	JMS	NHNDLE	/IF X<0,NEGATE X AND SET NFLAG
	JMS I	(FFMPY	/X*2/PI
	TOVPI
	JMS	FRACT	/SAVE X IN TEMP1,THE INTEGER PART OF X IN NUM,AND GET FRACTIONAL PART IN FAC
	TAD	NUM		/GET INTEGER PART OF (2/PI)*X
	AND	(3		/ISOLATE BITS 10,11
	TAD	JMPISN
	DCA	.+1		/MAKE JUMP TO ARGUMENT REDUCING ROUTINE
	JMP	.		/AND ADJUST ARG ACCORDING TO QUADRANT OF X
JMPISN,	JMP I	.+1
	POLYSN		/X IN QUAD1,SIN(X)=SIN(X)
	QUAD2		/X IN QUAD2,SIN(X)=SIN(1-X)
	QUAD3		/X IN QUAD3,SIN(X)=SIN(-X)
	QUAD4		/X IN QUAD4,SIN(X)=SIN(X-1)

QUAD2,	JMS I	(FFSUB1	/1-X
	ONE
	JMP	POLYSN	/CALCULATE SIN(1-X)
QUAD3,	JMS I	[FFNEG	/-X
	JMP	POLYSN	/CALCULATE SIN(-X)
QUAD4,	JMS I	(FFSUB	/X-1
	ONE
POLYSN,	JMS I	[FFPUT	/SAVE X
	FPPTM1
	JMS I	(FFSQ	/U=X**2
	JMS I	[FFPUT	/SAVE U
	FPPTM2
	JMS I	(FFMPY	/A7*U
	SINA7
	JMS I	(FFADD	/A5+A7*U
	SINA5
	JMS I	(FFMPY	/A5*U+A7*U**2
	FPPTM2
	JMS I	(FFADD	/A3+A5(U)+A7(U**2)
	SINA3
	JMS I	(FFMPY	/A3(U)+A5(U**2)+A7(U**3)
	FPPTM2
	JMS I	(FFADD	/A1+A3(U)+A5(U**2)+A7(U**3)
	SINA1
	JMS I	(FFMPY	/A1(X)+A3(X**3)+A5(X**5)+A7(X**7)
	FPPTM1
	JMS	NCHK	/IF NFLAG IS SET,SET SIN(X)=-SIN(X)
	JMP I	SIN	/FAC=SIN(X)


/******COSINE******
/USES SIN ROUTINE TO CALCULATE COS(X)

COS,	0
	JMS I	(FFADD	/COS(X)=SIN(PI/2+X)
	PIOV2
	JMS	SIN
	JMP I	COS	/RETURN
/ROUTINE TO SEPERATE THE INTEGER AND FRACTIONAL PARTS OF FAC
/ORIGINAL FAC IS SAVED IN TEMP1,THE INTEGER PORTION OF FAC IS
/SAVED AT NUM,AND THE FRACTIONAL FORTION OF THE FAC IS LEFT IN THE FAC

FRACT,	0
	JMS I	[FFPUT	/SAVE X
	FPPTM1
	JMS I	(FFIX	/INTEGER PORTION OF X
	TAD	ACX
	DCA	NUM		/SAVE FIXED FORTION OF X
	JMS I	[FFLOAT	/FAC=FLOAT(FIX(X))
	JMS I	(FFSUB1	/FAC=X-INT(X)=FRACTION (X)
	FPPTM1
	JMP I	FRACT	/RETURN

/ROUTINE TO CHECK IF FAC<0; IF IT IS,FAC IS NEGATED AND NFLAG IS
/SET TO 1

NHNDLE,	0
	TAD	ACH	/FETCH HIGH ORDER MANTISSA
	SMA CLA		/IS IT <0?
	JMP	NFLGST	/NO-CLEAR NFLAG
	JMS I	[FFNEG	/YES-NEGATE FAC
	IAC		/AND SET NFLAG
NFLGST,	DCA	NFLAG
	JMP I	NHNDLE

/ROUTINE TO NEGATE FAC IF NFLAG IS NOT =0

NCHK,	0		/LOC ALSO USED FOR TEMP STORAGE
	TAD	NFLAG
	SZA CLA		/IS NFLAG=0?
	JMS I	[FFNEG	/NO-NEGATE FAC
	JMP I	NCHK	/YES-RETURN

	NUM=NCHK
/******EXPONENTIAL******

EXPON1,	0		/LOC USED FOR TEMP STORAGE BY SIN,ARCTAN
	JMS I	(FFMPY	/Y=XLOG2(E)
	LOG2E
	JMS	FRACT	/GET FRACTIONAL PART OF Y
	JMS I	(FFMPY	/(FRACTION(Y))*(LN2/2)
	LN2OV2
	JMS I	[FFPUT	/SAVE Y
	FPPTM1
	JMS I	(FFSQ	/Y**2
	JMS I	(FFADD	/B1+Y**2
	EXPB1
	JMS I	(FFDIV1	/A1/(B1+Y**2)
	EXPA1
	JMS I	(FFADD	/A0+A1/(B1+Y**2)
	EXPA0
	JMS I	(FFSUB	/A0-Y+A1/(B1+Y**2)
	FPPTM1
	JMS I	[FFPUT	/SAVE
	FPPTM2
	JMS I	[FFGET	/GET Y
	FPPTM1
	ISZ	ACX		/MULT. BY 2=2Y
	NOP
	JMS I	(FFDIV	/2Y/(A0-Y+A1/(B1+Y**2))
	FPPTM2
	JMS I	(FFADD	/1+2Y/(AO-Y+A1/(B1+Y**2))
	ONE
	JMS I	(FFSQ	/[1+2Y/(A0-Y+A1/(B1+Y**2))]**2=EXP(Y)
	TAD	NUM
	TAD	ACX		/EXP(X)=(2**N)(EXPY)
	DCA	ACX
	JMP I	EXPON1	/FAC=EXPON(X)

	NFLAG=EXPON1

/CONSTANT THAT WOULDN'T FIT ELSEWHERE
TOVPI,	0		/.6366198
	2427
	6302

MULLIM,	0
	TAD	ACX	/CHECK IF NUMBER OF MULTIPLIES IS TOO LARGE
	SPA
	CLA		/RETURN IF EXPONENT IS NEGATIVE (WE'LL USE LOGS)
	TAD	(-4	/ONLY A ROUGH ROUGH LIMIT ON THE EXPONENT
	SPA SNA CLA	/SKP IF NUMBER GT 15 APPROX
	JMP I	MULLIM	/NO, CONTINUE
	JMP I	(USELOG	/YES, USE LOG INSTEAD

	PAGE
/******ARC TANGENT******

ATAN,	0
	JMS I	NHNDLL	/IF X<0,SET NFLAG AND NEGATE
	JMS I	[FFPUT	/SAVE X
	FPPTM1
	JMS I	FSUBM	/X-1
	ONE
	TAD	ACH	/GET HI MANTISSA
	SPA CLA		/WAS X>1?
	JMP	ARGPOL	/NO-CLEAR GT1FLG
	JMS I	[FFGET	/YES-ATAN(X)=PI/2-ATAN(1/X)
	ONE
	JMS I	FDIVM	/1/X
	FPPTM1
	JMS I	[FFPUT
	FPPTM1
	IAC		/SET GT1FLG
ARGPOL,	DCA	GT1FLG
	JMS I	[FFGET	/GET X OR 1/X
	FPPTM1
	JMS I	FSQRM	/Y**2
	JMS I	[FFPUT	/SAVE
	FPPTM2
	JMS I	FADDM	/Y**2+B3
	ATANB3
	JMS I	FDIV1M	/A3/(Y**2+B3)
	ATANA3
	JMS I	FADDM	/B2+A3/(Y**2+B3)
	ATANB2
	JMS I	FADDM	/Y**2+B2+A3/(Y**2+B3)
	FPPTM2
	JMS I	FDIV1M	/A2/(Y**2+B2+A3/(Y**2+B3))
	ATANA2
	JMS I	FADDM	/B1+A2/(Y**2+B2+A3/(Y**2+B3))
	ATANB1
	JMS I	FADDM	/Y**2+B1+A2/(Y**2+B2+A3/(Y**2+B3))
	FPPTM2
	JMS I	FDIV1M	/A1/(Y**2+B1+A2/(Y**2+B2+A3/(Y**2+B3)))
	ATANA1
	JMS I	FADDM	/B0+A1/(Y**2+B1+A2/(Y**2+B2+A3/(Y**2+B3)))
	ATANB0
	JMS I	FMPYM	/ATAN(Y)=X*(B0+A1/(Y**2+B1+A2/(Y**2+B2+A3/(Y**2+B3))))
	FPPTM1
	TAD	GT1FLG	/WAS X>1?
	SNA CLA
	JMP	NGT	/NO-TEST IF X<0?
	JMS I	FSUB1M	/ATAN(X)=PI/2-ATAN(1/X)
	PIOV2
NGT,	JMS I	NCHKL	/IF NFLAG SET,NEGATE FAC
	JMP I	ATAN	/FAC=ATAN(X)
NHNDLL,	NHNDLE
NCHKL,	NCHK
/******NAPERIAN LOGARITHM******

	GTFLG=ATAN

LOG,	0
	TAD	ACH
	SPA SNA		/X<0 OR X=0?
	JMP I	ARTRAP	/YES-TAKE ILLEGAL ARGUMENT TRAP
	CLL RTL
	SNA		/NO-HORD=2000?
	TAD	ACX	/YES-EXP=1?
	CMA IAC
	IAC
	SNA
	TAD	ACL	/YES-LORD=0?
	SZA CLA
	JMP	POLYNL	/NO-ARG IS LEGAL AND NOT 1
	DCA	ACX
	DCA	ACL
LTRPRT,	DCA	ACH
	JMP I	LOG	/YES-LOG(1)=0
POLYNL,	TAD	ACX
	DCA	GTFLG	/SAVE EXPONENT FOR LATER
	DCA	ACX		/ISOLATE MANTISSA IN FAC
	JMS I	[FFPUT	/SAVE F
	FPPTM1
	JMS I	FADDM	/F+SQR(.5)
	SQRP5
	JMS I	[FFPUT	/SAVE
	FPPTM2
	JMS I	[FFGET
	FPPTM1
	JMS I	FSUBM	/F-SQR(.5)
	SQRP5
	JMS I	FDIVM	/Z=F+SQR(.5)/F-SQR(.5)
	FPPTM2
	JMS I	[FFPUT
	FPPTM1
	JMS I	FSQRM	/Z**2
	JMS I	[FFPUT
	FPPTM2
	JMS I	FMPYM	/C5(Z**2)
	LOGC5
	JMS I	FADDM	/C3+C5(Z**2)
	LOGC3
	JMS I	FMPYM	/C3(Z**2)+C5(Z**4)
	FPPTM2
	JMS I	FADDM	/C1+C3(Z**2)+C5(Z**4)
	LOGC1
	JMS I	FMPYM	/C1(Z)+C3(Z**3)+C5(Z**5)
	FPPTM1
	JMS I	FSUBM	/C1(Z)+C3(Z**3)+C5(Z**5)-1/2=LOG2(F)
	ONEHAF
	JMS I	[FFPUT	/SAVE LOG2(F)
	FPPTM2
	TAD	GTFLG	/I
	DCA	ACX		/SET UP FLOAT
	JMS I	[FFLOAT
	JMS I	FADDM	/I+LOG2(F)
	FPPTM2
	JMS I	FMPYM	/[I+LOG2(F)]*LOGE(2)=LOGE(X)
	LN2
	JMP I	LOG	/FAC=LN(X)

	GT1FLG=LOG
FMPYM,	FFMPY
FADDM,	FFADD
FDIVM,	FFDIV
FDIV1M,	FFDIV1
FSUBM,	FFSUB
FSUB1M,	FFSUB1
FSQRM,	FFSQ
ARTRAP,	LM
/CONSTANTS USED BY VARIOUS FUNCTIONS

SINA1,	1		/1.5707949
	3110
	3747
SINA3,	0		/-.64592098
	5325
	1167
SINA5,	7775		/.07948766
	2426
	2466
SINA7,	7771		/-.004362476
	5610
	3164
PIOV2,	1		/1.5707963
	3110
	3756
LOG2E,	1		/1.442695
	2705
	2434
LN2OV2,	7777		/.34657359
	2613
	4415
EXPB1,	6		/60.090191
	3602
	7054
EXPA1,	12		/-601.80427
	5514
	3104
EXPA0,	4		/12.015017
	3001
	7301
ATANB0,	7776		/.17465544
	2626
	6157
ATANA1,	2		/3.7092563
	3553
	1071
ATANB1,	3		/6.762139
	3303
	670
ATANA2,	3		/-7.10676
	4344
	5267
ATANB2,	2		/3.3163354
	3241
	7554
ATANA3,	7777		/-.26476862
	5703
	4040
ATANB3,	1		/1.44863154
	2713
	3140
SQRP5,	0		/.7071068
	2650
	1170
LOGC1,	2		/2.8853913
	2705
	2440
LOGC3,	0		/.9614706
	3661
	566
LOGC5,	0		/.59897865
	2312
	5525
ONEHAF,	0		/.5
	2000
	0
LN2,	0		/.6931472
	2613
	4415
	*4500

	/******FIX******
/ROUTINE TO FIX ANY FLOATING NUMBER IN FAC BETWEEN -2047 AND +2047 TO
/A TWELVE BIT INTEGER AND LEAVE RESULT IN EXP (LOC 44)

FFIX,	0
	CLA
	TAD	ACX		/FETCH EXPONENT
	SZA SMA		/IS NUMBER <1?
	JMP	.+3	/NO-CONTINUE ON
FTRPRT,	CLA
	JMP	FIXDNE+1	/YES-FIX IT TO ZERO
	TAD	(-13		/SET BINARY POINT AT 11
	SNA		/PLACES TO RIGHT OF CURRENT POINT?
	JMP	FIXDNE	/NO-NUMBER IS ALREADY FIXED THEN.
	SMA		/YES-IS NUMBER TOO LARGE TO FIX?
	JMP I	(FO	/YES-TAKE OVERFLOW TRAP
	DCA	ACX		/NO-SET SCALE COUNT
FIXLP,	CLL		/0 IN LINK
	TAD	ACH	/GET HIGH MANTISSA
	SPA		/IS IT <0?
	CML		/YES-PUT A 1 IN LINK
	RAR		/SCALE RIGHT
	DCA	ACH	/SAVE
	ISZ	ACX		/DONE YET?
	JMP	FIXLP	/NO
FIXDNE,	TAD	ACH	/YES-ANSWER IN AC
	DCA	ACX		/RETURN WITH ANSWER IN 44
	JMP I	FFIX	/RETURN

/******FLOAT******
/ROUTINE TO FLOAT ANY INTEGER IN EXP (LOC 44) INTO FAC

FFLOAT,	0
	TAD	ACX
	DCA	ACH	/PUT NUMBER IN HI MANTISSA
	DCA	ACL	/CLEAR LOW MANTISSA
	TAD	(13		/11(10) INTO EXPONENT
	DCA	ACX
	JMS I	[FFNOR	/NORMALIZE
	JMP I	FFLOAT	/RETURN
/RANDOM NUMBER GENERATOR

RND,	0
	TAD I	(RSEED	/GET SEED
	DCA	TEMP3	/PUT IN MULTIPLY OPERAND
	TAD	(73
	JMS I	[MPY	/MULTIPLY SEED BY 73
	DCA I	(RSEED	/USE LOW ORDER 12 BITS AS NEW SEED
	TAD I	(RSEED	/LOW ORDER OF PRODUCT ALSO SERVES
	CLL RAR		/AS RANDOM NUMBER
	DCA	ACH	/SET SIGN TO 0 AND STORE AS HORD
	DCA	ACX
	RAR
	DCA	ACL	/USE 12 BITS AS MANTISSA
	DCA	AC1		/CLEAR FPP OVERFLOW
	JMS I	[FFNOR	/AND NORMALIZE
	JMP I	[ILOOP	/DONE

	PAGE
	/FLOATING POINT OUTPUT ROUTINE
	/CONVERT INTERNAL NUMBER TO ASCII
	/EXIT WITH CHAR STRING IN 'INTERB'
	/XR1 = POINTER TO LAST CHAR STORED

FFOUT,	0
	TAD	(INTERB-1
	DCA	XR1	/SET POINTER TO ASCII BUFFER
	TAD	ACH	/SEE IF FAC NEGATIVE
	SMA CLA
	JMP	OKPOS	/JMP IF POSITIVE
	JMS I	[FFNEG	/TAKE ABS VALUE IF NEGATIVE
	TAD	("-	/PRINT MINUS SIGN
	SKP
OKPOS,	TAD	(240	/PRINT SPACE IF POSITIVE
	DCA I	XR1
	TAD	ACH	/SEE IF NUMBER IS ZERO
	SNA CLA
	JMP	ZERXIT	/SPECIAL CASE IF SO
	JMS I	(CVTNUM	/CALL ROUTINE TO UNPACK TO BASE 10
	TAD	(NUMBUF-1
	DCA	XR2	/POINT XR2 AT DIGIT BUFFER
	TAD	(5	/TEST FORMAT TO USE
	TAD	DECEXP
	CLL
	TAD	(-4
	SNL
	JMP	SMLFMT	/JMP IF .0NNNNNN TO .0000NNNNNN
	TAD	(-7
	SZL CLA
	JMP	REGFMT	/JMP IF .NNNNNN TO NNNNNN
			/OTHERWISE USE E FORMAT N.NNNNNE+NNN OR N.NNNNNE-NNN
	TAD I	XR2	/GET DIGIT TO LEFT OF POINT
	JMS	PUTD	/PUT IT OUT
	TAD	(".
	DCA I	XR1	/NOW SEND OUT DECIMAL POINT
	TAD	(-5
	DCA	AC2	/DO 5 MORE DIGITS
	TAD I	XR2	/PICK UP DIGIT
	JMS	PUTD	/CONVERT TO ASCII AND STORE
	ISZ	AC2
	JMP	.-3	/LOOP FOR MORE
	TAD	("E	/PRINT E
	DCA I	XR1
/	CLL
	TAD	DECEXP	/TAKE ABS(DECEXP)
	SPA
	CML CIA
	DCA	DECEXP
	RTL		/CONVERT "+" TO "-" IF NEGATIVE
	TAD	("+
	DCA I	XR1
	JMS	IDIV	/PRINT 3 DIGITS OF EXPONENT NOW
	-144
	JMS	IDIV
	-12
	TAD	DECEXP
	JMS	PUTD
	JMP I	FFOUT	/ALL DONE --RETURN--
	/HANDLE .0NNNNNN TO .0000NNNNNN

SMLFMT,	DCA	AC0	/STORE NUMBER OF LEADING ZEROES
	TAD	(".	/PUT OUT DECIMAL POINT
	DCA I	XR1
	JMS	PUTD	/SEND A 0
	ISZ	AC0
	JMP	.-2	/LOOP FOR LEADING 0'S

	/GENERAL NON E FORMAT .NNNNNN TO NNNNNN

REGFMT,	TAD	(-7
	DCA	AC1	/INIT COUNT OF NONZERO DIGITS
	TAD	(NUMBUF+6
	DCA	AC2	/POINT AT END OF DIGIT BUFFER
SHRINK,	STA		/DECREMENT DIGIT POINTER
	TAD	AC2
	DCA	AC2
	ISZ	AC1	/REDUCE SIGNIFICANT DIGIT COUNT
	TAD	DECEXP
	IAC
	TAD	AC1
	SMA CLA
	JMP	PRTLP	/JMP OUT IF NOT TO RIGHT OF DECIMAL POINT
	TAD I	AC2	/ELSE LOOK AT DIGIT
	SNA CLA
	JMP	SHRINK	/DISCARD IT IF ZERO
PRTLP,	STA
	TAD	DECEXP
	DCA	DECEXP	/SEE IF DIGIT TO BE PRINTED FOLLOWS DP
	AC0002
	TAD	DECEXP
	SZA CLA
	JMP	NODP	/NO
	TAD	(".	/YES, PRINT DP
	DCA I	XR1
NODP,	TAD I	XR2	/PICK UP DECIMAL DIGIT
	JMS	PUTD	/PUT OUT
	ISZ	AC1
	JMP	PRTLP	/JMP IF MORE DIGITS TO PRINT
	JMP I	FFOUT	/--RETURN--

ZERXIT,	JMS	PUTD
	JMP I	FFOUT	/--RETURN--

	/DIVIDE DECEXP BY -DIVISOR IN CALL+1

IDIV,	0
	DCA	AC1	/CLEAR QUOTIENT
IDIVLP,	TAD	DECEXP
	TAD I	IDIV
	SPA
	JMP	IDVOUT	/JMP OUT IF LESS THAN DIVISOR
	DCA	DECEXP	/ELSE UPDATE IT
	ISZ	AC1	/TALLY QUOTIENT
	JMP	IDIVLP	/ITERATE
IDVOUT,	CLA
	TAD	AC1	/GET QUOT AS NEXT DIGIT
	JMS	PUTD	/PUT OUT
	ISZ	IDIV
	JMP I	IDIV

	/CONVERT NUMBER IN AC TO ASCII DIGIT
	/MUST NOT TOUCH THE LINK

PUTD,	0
	TAD	("0	/ADD IN 0
	DCA I	XR1	/STORE IN BUFFER
	JMP I	PUTD

	PAGE
	/CONVERT NUMBER IN FAC TO FORMAT N.NNNNNE NNN
	/DECIMAL EXPONENT RETURNED AS SIGNED NUMBER IN DECEXP
	/6 DIGITS STORED IN NUMBUF AS BINARY 0-9
	/FIRST REDUCES MANTISSA TO FORM 0DD DDF FFF FFF...
	/BY SUCCESSIVE MULTIPLIES OR DIVIDES BY 10. FOLLOWED BY
	/RENORMALIZATIONS UNTIL INTIGER BITS
	/DDDD ARE LT 10.
	/DECIMAL DIGITS ARE ISOLATED BY REPEATED MULTIPLICATION BY 10.

CVTNUM,	0
	DCA	AC1	/CLEAR OVERFLOW WORD
	SKP		/SKP IN AND CLEAR DECIMAL EXPONENT
ADJDEC,	TAD	DECEXP
	DCA	DECEXP	/STORE UPDATED DECIMAL EXPONENT
NORML,	TAD	ACH	/SEE IF FRACTION IS NORMALIZED
	RAL
	SPA CLA
	JMP	NORMED	/JMP IF YES
	JMS I	(AL1	/SHIFT AC LEFT 1 BIT
	STA
	TAD	ACX	/COMPENSATE BINARY EXPONENT
	DCA	ACX
	JMP	NORML	/TRY AGAIN
NORMED,	TAD	ACX	/RANGE CHECK BINARY EXPONENT NOW
	SMA SZA
	JMP	DIVCHK	/JMP IF NUMBER GE 1
	TAD	O4
	DCA	ACX	/INCREASE BINARY EXP TOWARDS ZERO
	JMS	AR1	/SHIFT 4 BITS RIGHT
	JMS	AR1	/MAX RELATIVE ERROR WILL BE LT 15*2^-34 PER MULTIPLY
	JMS	AR1
	JMS	AR1
	JMS	MPY10	/NOW MULTIPLY BY 10.
	STA		/DECREASE DECIMAL EXPONENT
	JMP	ADJDEC	/RENORMALIZE AND TRY AGAIN

DIVCHK,	TAD	(-5	/SEE IF EXP GT 4
	SPA
	JMP	INRANG	/JMP IF NOT, NUMBER MAY BE IN RANGE
DIVGO,	CLA CLL
	TAD	(-40	/SET 32. STAGE SUBTRACT-SHIFT DIVIDE (SLOW BUT ACCURATE)
	DCA	AC2	/(THE LEN ELEKMAN TECHNIQUE)
			/MAX RELATIVE ERROR WILL BE LT 9*2^-34. PER DIVIDE
DVLOOP,	TAD	ACH	/SEE IF GE 10.
	TAD	(5400
	SMA
	DCA	ACH	/UPDATE IF YES
	CML STA RAL
	DCA	AC0	/SAVE LOW ORDER BIT
	JMS I	(AL1	/SHIFT MANTISSA NOW
	ISZ	AC0	/STORE BIT NOW
	ISZ	AC1
	ISZ	AC2	/BUMP COUNT
	JMP	DVLOOP	/ITERATE
	TAD	ACH	/NOW ZERO OUT REMAINDER
	AND	[377
	DCA	ACH
	IAC		/NOW INCREASE DECIMAL EXPONENT
	JMP	ADJDEC

INRANG,	DCA	AC2	/SET SHIFT COUNTER
	SKP
	JMS	AR1	/SHIFT FAC RIGHT
	ISZ	AC2
	JMP	.-2	/LEAVE EFFECTIVE BINARY POINT RIGHT OF ACH BIT 4
	TAD	ACH	/ACH = 0DD DDF FFF FFF (D=DECIMAL DIGIT BITS)
	TAD	(5400	/SEE IF DDDD GE 10
	SMA CLA
	JMP	DIVGO	/DIVIDE AGAIN (NORMALIZATION WILL WORK)
	CLL
	TAD	AC1	/NOW ROUND BY ADDING 0.000005
	TAD	(4761
	DCA	AC1
	IAC		/ADD 24761 TO LOW BITS
	RAL
	TAD	ACL
	DCA	ACL
	SZL
	ISZ	ACH
	TAD	ACH
	TAD	(5400	/SEE IF CARRY INTO 9.XXX...
	SZA CLA
	JMP	CVT10	/JMP IF NO
	TAD	[200	/ELSE SET TO 1.00000
	DCA	ACH
	DCA	ACL
	DCA	AC1
	ISZ	DECEXP	/AND BUMP DECIMAL EXPONENT
O4,	4		/EFFECTIVE NOP

	/NOW CONVERT TO DECIMAL DIGITS

CVT10,	TAD	(-6	/DO 6 DIGITS
	DCA	AC0
	TAD	(NUMBUF-1
	DCA	XR3
	JMP	CVTGO	/FIRST DIGIT IS ALREADY IN
CVTLP,	TAD	ACH	/ZERO OUT PREV DIGIT
	AND	[177
	DCA	ACH
	JMS	MPY10	/MULTIPLY BY 10.
CVTGO,	TAD	ACH	/GET DIGIT FROM 0DD DDF FFF FFF
	RTL
	RTL
	RTL
	AND	[17
	DCA I	XR3	/STORE IT
	ISZ	AC0
	JMP	CVTLP	/LOOP IF MORE
	JMP I	CVTNUM	/--RETURN--

	/MULTIPLY ACH,,ACL,,AC1 BY 10.

MPY10,	0
	TAD	ACH
	DCA	OPH	/COPY AC TO OP
	TAD	ACL
	DCA	OPL
	TAD	AC1
	DCA	AC2
	JMS I	(AL1	/N*2
	JMS I	(AL1	/N*4
	JMS I	(OADD	/N*5
	JMS I	(AL1	/N*10.
	JMP I	MPY10

	/SHIFT FAC RIGHT 1 BIT

AR1,	0
	TAD	ACH
	CLL RAR
	DCA	ACH
	TAD	ACL
	RAR
	DCA	ACL
	TAD	AC1
	RAR
	DCA	AC1
	JMP I	AR1	/DONE

	PAGE
	IFZERO	EAE <

/FLOATING POINT INPUT ROUTINE

FFIN,	0
	CLA	CMA
	DCA I	FDVPT	/INITIALIZE PERIOD SWITCH TO -1
	CMA		/SET SIGN SWITCH TO -1
	DCA	SIGNF
	CDF		/DF TO PACKAGE FIELD
	DCA	DSWIT	/ZERO CONVERSION SWITCH
DECONV,	DCA	ACX	/ZERO OUT THE FAC!
	DCA	ACL
P200,	200
	DCA	ACH
DECNV,	DCA	DNUMBR	/ZERO # OF DIGITS SINCE DEC. PT.
DECON,	JMS	GCHR	/GET A CHAR.FROM TTY.
	JMP	FFIN1	/TERMINATOR-
	ISZ	DSWIT	/DIGIT-BUMP CONVERSION SWITCH
	ISZ	DNUMBR	/BUMP # OF DIGITS-# IS STORED IN
	JMS I	FMPYLL	/"FMPY	TEN"
	TEN
	JMS I	[FFPUT	/"FPUT I	TM3PT"
	FPPTM1
	JMS I	[FFGET	/"FGET	TP"
	TP
	JMS I	[FFNOR	/"FNOR"
	JMS I	FADDLL	/"FADD I	TM3PT"
	FPPTM1
	JMP	DECON	/GO ON
FFIN1,	ISZ I	FDVPT	/HAVE WE HAD A PERIOD YET?
	JMP	FIGO2	/YES-GO ON
	ISZ	TP1	/NO-IS THIS A PERIOD?
	ISZ	TP1
	SKP	CLA
	JMP	DECNV	/YES-ZERO DIG. COUNT AFTER DEC. PT.
			/AND GO CONVERT REST
	DCA	DNUMBR	/NO-TERMINATOR-ZERO COUNT OF
			/DIGITS AFTER DECIMAL POINT.
FIGO2,	ISZ	SIGNF	/IS # NEGATIVE?(DID WE GET - SIGN?)
	JMS I	FFNEGP	/YES-NEGATE IT
	CLA	CMA	/RESET SIGN SWITCH FOR EXP.
	DCA	SIGNF
	TAD	CHAR	/NO-WAS THE TERMINATOR AN 'E'?
	TAD	KME	
	SNA	CLA
GETE,	JMS	GCHR	/YES-GET A CHAR. OF EXPONENT
	JMP	EDON	/END OF EXPONENT
	TAD	TM	/GOT DIG. OF EXP-STORED IN TP1
	CLL	RTL	/MULT. ACCUMULATED EXP BY 10
	TAD	TM
	CLL	RAL
	TAD	TP1	/ADD DIGIT
	JMP	GETE	/CONTINUE
EDON,	TAD	TM	/GET EXPONENT
	ISZ	SIGNF	/WAS EXPONENT NEGATIVE?
	CMA	IAC	/YES-NEGATE IT
	CMA	IAC	/AND CALC. DNUMBR - EXPON.
	TAD	DNUMBR	/GET # TIMES TO DIV MANTISSA BY TEN
	CLL CMA IAC
	SPA		/RESULT POSITIVE?
	CLL CMA CML IAC	/NO-MAKE POS. AND SET LINK
	CMA		/NEGATE FOR COUNTER
	DCA	DNUMBR	/AND STORE
	RAL		/LINK=1-DIV;=0-MUL. # BY TEN
	TAD	MDV	/FORM CORRECT INSTRUCTION
	DCA	SIGNF	/AND STORE FOR EXECUTION
FCNT,	ISZ	DNUMBR	/DONE ALL OPERATIONS?
	JMP	SIGNF	/NO
	JMP I	FFIN	/YES-RETURN
SIGNF,	0		/NO- MUL OR DIV. MANTISSA
	TEN		/BY TEN
	JMP	FCNT	/GO ON
FFNEGP,	FFNEG
DNUMBR,	0
KME,	-305
MDV,	JMS I	.+1	/THESE 3 WDS. MUST BE IN THIS ORDER
FMPYLL,	FFMPY
FDVPT,	FFDIV		/!!!!!!!!!!!!!!!!!
FADDLL,	FFADD

KK12,	12
TP,	13
TP1,	0
	0
TEN,	4
	2400
	0
/ROUTINE TO GET A CHAR FROM THE TTY AND SEE IF IT IS DIGIT
/OR A TERMINATOR.
/RETURN TO CALL + 1 IF TERMINATOR, TO CALL + 2 IF DIGIT
/THIS ROUTINE MUST NOT MODIFY THE MQ!!
GCHR,	0
	DCA	TM	/STORE ACCUMULATED EXPONENT (MAYBE)
	JMS	INPUT	/GET A CHAR FROM TTY.
	TAD	CHAR	/PICK IT UP
	TAD	PLUS	/WAS IT PLUS SIGN?
	SNA
	JMP	DECON1	/YES-GET ANOTHER CHAR.
	TAD	MINUS	/NO WAS IT MINUS SIGN?
	SZA	CLA
	JMP	.+3
	DCA	SIGNF	/YES-FLIP SWITCH
DECON1,	JMS	INPUT	/GET A CHAR.
	TAD	CHAR
	TAD	K7506	/SEE IF ITS A DIGIT
	CLL
	TAD	KK12
	DCA	TP1	/STORE FOR LATER
	SZL		/DIGIT?
	ISZ	GCHR	/YES-RETN. TO CALL+2
	JMP I	GCHR	/NO-RETN. TO CALL+1
K7506,	7506
/
/INPUT ROUTINE-IGNORES LEADING SPACES
/
INPUT,	0
	JMS I	IGETCH	/USE OUR ROUTINE TO GET CHAR
	TAD	DSWIT	/GET TERMINATOR
	SZA CLA		/VALID INPUT YET?
	JMP	IOUT	/YES-CONTINUE
	TAD	CHAR	/NO-GET CHAR
	TAD	M240	/COMPARE AGAINST SPACE
	SZA		/SKP IF SPACE
	TAD	(240-212 /COMPARE TO LF
	SNA CLA		/IS IT A SPACE OR LF?
	JMP	INPUT+1	/YES-IGNORE IT
IOUT,	JMP I	INPUT	/RETURN
IGETCH,	GETCH		/POINTER TO GET CHAR ROUTINE
			/ALTERED BY "VAL" FUNCTION TO PICK FROM SAC (BE CAREFULL)
M240,	-240
PLUS,	-253
MINUS,	253-255
/
/ROUTINE TO DECIDE CALLING MODE IN LIEU OF "SPECIAL MODE" PROBLEMS
/
PATCHF,	0
	SZA		/IS AC EMPTY
	JMP	RTN2	/NO-THIS IS ALWAYS SI MODE WITH ADDR IN AC
	TAD	FF		/YES-GET SPECIAL MODE FLIP-FLOP
	SZA CLA		/IF ON,THE ZERO AC MEANS ADDRESS OF 0
RTN2,	ISZ	PATCHF	/USE AC AS ADDRESS OF OPERAND
	JMP I	PATCHF	/RETURN
	PAGE
/
/INVERSE FLOATING SUBTRACT-USES FLOATING ADD
/!!FSW1!!-THIS IS OP-FAC
/
FFSUB1,	0
	JMS I	[PATCHF	/WHICH MODE?
	TAD I	FFSUB1	/CALLED BY USER-GET ADDR. OF OP.
	JMS I	ARGETL	/GO PICK UP OPERAND
	CDF
	JMS I	FFNEGA	/NEGATE FAC
	TAD	FFSUB1	/AND GO ADD
	JMP I	SUB0P
FFNEGA,	FFNEG
SUB0P,	SUB0
/
/INVERSE FLOATING DIVIDE
/FSWITCH=1
/THIS IS OP/FAC
/
FFDIV1,	0
	JMS I	[PATCHF	/WHICH MODE OF CALL?
	TAD I	FFDIV1	/CALLED BY USER-GET ADDR.
	JMS I	ARGETL	/PICK UP OPERAND
	TAD	ACL	/SWAP THE FAC AND OPERAND
	DCA	OPL	/THERE IS A POINTER TO OPL
	TAD I	AC2	/IN AC2 LEFT FROM ARGET SUBR.
	DCA	ACL
	TAD	ACX	/MIGHT AS WELL SUBTRACT THE
	CLL CMA IAC	/EXPONENTS HERE (SAVES A WORD)
	TAD	OPX	/THEN ZERO OPX SO WILL NOT
	DCA	ACX	/MESS UP WHEN ITS DONE AGAIN
	DCA	OPX	/LATER (SEE DIV. ROUTINE)
	TAD	ACH
	DCA	AC2	/NOW SWAP HIGH ORDER MANTISSAS
	TAD	OPH
	DCA	ACH
	TAD	AC2
	DCA	OPH
	CDF		/DF TO PACKAGE FIELD
	TAD	FFDIV1	/NOW KLUDGE UP A SUBROUTINE LINKAGE
	DCA I	FFDP
	TAD	KFD1
	DCA I	MDSETP
	JMP I	MD1P	/GO SET UP AND DIVIDE

MD1P,	MD1
ARGETL,	ARGET
MDSETP,	MDSET
FFDP,	FFDIV
KFD1,	FFD1
/MDSET-SETS UP SIGNS FOR MULTIPLY AND DIVIDE
/ALSO SHIFTS OPERAND ONE BIT TO THE LEFT.
/EXIT WITH EXPONENT OF OPERAND IN AC FOR EXPONENT
/CALCULATION-CALLED WITH ADDRESS OF OPERAND IN AC AND
/DATA FIELD SET PROPERLY FOR OPERAND.
/
MDSET,	0
	JMS I	ARGETK	/GET ARGUMENT
MD1,	CDF		/DF TO PACKAGE FIELD
	CLA CLL CMA RAL	/SET SIGN CHECK TO -2
	DCA	TM
	TAD	OPH	/IS OPERAND NEGATIVE?
	SMA	CLA
	JMP	.+3	/NO
	JMS I	OPNEGP	/YES-NEGATE IT
	ISZ	TM	/BUMP SIGN CHECK
	TAD	OPL	/AND SHIFT OPERAND LEFT ONE BIT
	CLL	RAL
	DCA	OPL
	TAD	OPH
	RAL
	DCA	OPH
	DCA	AC1	/CLR. OVERFLOW WORF OF FAC
	TAD	ACH	/IS FAC NEGATIVE
	SMA	CLA
	JMP	LEV	/NO-GO ON
	JMS I	FFNEGK	/YES-NEGATE IT
	ISZ	TM	/BUMP SIGN CHECK
	NOP		/MAY SKIP
LEV,	TAD	OPX	/EXIT WITH OPERAND EXPONENT IN AC
	JMP I	MDSET

FFNEGK,	FFNEG
OPNEGP,	OPNEG
ARGETK,	ARGET

/
/CONTINUATION OF FLOATING DIVIDE ROUTINE
/
FD1,	TAD	AC2	/NEGATE HI ORDER PRODUCT
	CLL CMA IAC
	TAD	ACH	/COMPARE WITH REMAINDER OF FIRST DIV.
	SNL		/WELL?
	JMP I	DVOPSP	/GREATER THAN REM.-ADJUST QUOT OF 1ST DIV.
	CLL		/OK-DO  (REM-(Q*OPL))/OPH
	DCA	ACH	/FIRST STORE ADJUSTED PRODUCT
	JMS I	DV24P	/DIVIDE BY OPH (HI ORDER OPERAND)
DVL1,	TAD	AC1	/GET QUOT. OF FIRST DIV.
	SMA		/IF HI ORDER BIT SET-MUST SHIFT 1 RIGHT
	JMP	FD	/NO-ITS NORMALIZED-DONE
	CLL
	ISZ	ACL
	SKP
	IAC
	RAR
	DCA	ACH	/STORE IN FAC
	TAD	ACL	/P@ LOW ORDER RIGHT
	RAR
	DCA	ACL	/STORE BACK
	ISZ	ACX	/BUMP EXPONENT
	NOP
	TAD	ACH
	JMP	DVL1+1
FD,	DCA	ACH	/STORE HIGH ORDER RESULT
	JMP I	FDDONP	/GO LEAVE DIVIDE

FDDONP,	FDDON		/END OF FLTG. DIV. ROUTINE
DV24P,	DV24		/ROUTINE TO DO A 24X12BIT DIVIDE
DVOPSP,	DVOPS		/ROUTINE TO ADJUST QUOT OF FIRST DIV.
/
/CONTINUATION OF ROUTINE TO ADJUST QUOT. OF FIRST DIV.
/DBAD1 IS ONLY EXECUTED ON DIVIDE OVERFLOW-OTHERWISE THE
/ROUTINE STARTS AT DVOP2
/
DBAD1,	DCA	ACX	/DIVIDE OVERFLO-ZERO ALL
DVOP2,	SNA		/IS IT ZERO?
	DCA	ACL	/YES-MAKE WHOLE THING ZERO
	DCA	ACH
	JMS I	DV24P	/DIVIDE EXTENDED REM. BY HI DIVISOR
	TAD	ACL	/NEGATE THE RESULT
	CLL CMA IAC
	DCA	ACL
	SNL		/IF QUOT. IS NON-ZERO, SUBTRACT
	CMA		/ONE FROM HIGH ORDER QUOT.
	JMP	DVL1	/GO TO IT

	PAGE
/FLOATING MULTIPLY-DOES 2 24X12 BIT MULTIPLIES
FFMPY,	0
	JMS I	[PATCHF	/WHICH MODE OF CALL?
	TAD I	FFMPY	/CALLED BY USER-GET OPERAND ADDR.
	JMS I	MDSETK	/SET UP FOR MPY-OPX IN AC ON RETN.
	TAD	ACX	/DO EXPONENT ADDITION
	DCA	ACX	/STORE FINAL EXPONENT
	DCA	DV24	/ZERO TEM STORAGE FOR MPY ROUTINE
	DCA	AC2
	TAD	ACH	/IS FAC=0?
	SNA	CLA
	DCA	ACX	/YES-ZERO EXPONENT
	JMS	MP24	/NO-MULTIPLY FAC BY LOW ORDER OPR.
	TAD	OPH	/NOW MULTIPLY FAC BY HI ORDER MULTIPLIER
	DCA	OPL
	JMS	MP24
	TAD	AC2	/STORE RESULT BACK IN FAC
RTZRO,	DCA	ACL	/LOW ORDER
	TAD	DV24	/HIGH ORDER
	DCA	ACH
	TAD	ACH	/DO WE NEED TO NORMALIZE?
	RAL
	SMA	CLA
	JMP	SHLFT	/YES-DO IT FAST
MDONE,	DCA	AC1	/NO-ZERO OVERFLOW WD(DO I NEED THIS???)
	ISZ	FFMPY	/BUMP RETURN POINTER
	ISZ	TM	/SHOULD RESULT BE NEGATIVE?
	JMP I	FFMPY	/NOPE-RETN.
	JMS I	FFNEGR	/YES-NEGATE IT
	JMP I	FFMPY	/RETURN
SHLFT,	CMA		/SUBTRACT 1 FROM EXP.
	TAD	ACX
	DCA	ACX
	JMS I	AL1PTR	/SHIFT FAC LEFT 1 BIT
	JMP	MDONE+1	/DONE.
AL1PTR,	AL1
/
/24 BIT BY 12 BIT MULTIPLY.  MULTIPLIER IS IN OPL
/MULTIPLICAND IS IN ACH AND ACL
/RESULT LEFT IN DV24,AC2, AND AC1
MP24,	0
	TAD	KKM12	/SET UP 12 BIT COUNTER
	DCA	OPX
	TAD	OPL	/IS MULTIPLIER=0?
	SZA
	JMP	MPLP1	/NO-GO ON
	DCA	AC1	/YES-INSURE RESULT=0
	JMP I	MP24	/RETURN
MPLP,	TAD	OPL	/SHIFT A BIT OUT OF LOW ORDER
MPLP1,	RAR		/OF MULTIPLIER AND INTO LINK
	DCA	OPL
	SNL		/WAS IT A 1?
	JMP	MPLP2	/NO-0-JUST SHIFT PARTIAL PRODUCT
	CLL		/YES-ADD MULTIPLICAND TO PARTIAL PRODUCT
	TAD	AC2
	TAD	ACL	/LOW ORDER
	DCA	AC2
	RAL		/PROPAGATE CARRY
	TAD	ACH	/HI ORDER
MPLP2,	TAD	DV24
	RAR		/NOW SHIFT PARTIAL PROD. RIGHT 1 BIT
	DCA	DV24
	TAD	AC2
	RAR
	DCA	AC2
	RAR		/1 BIT OF OVERFLOW TO AC1
	DCA	AC1
	ISZ	OPX	/DONE ALL 12 MULTIPLIER BITS?
	JMP	MPLP	/NO-GO ON
	JMP I	MP24	/YES-RETURN
/
/PART OF DIVIDE ROUTINE-FFDIV MUST BE AT LOC. 6722
MP12L,	DCA	OPL	/STORE BACK MULTIPLIET
	TAD	AC2	/GET PRODUCT SO FAR
	SNL		/WAS MULTIPLIER BIT A 1?
	JMP	.+3	/NO-JUST SHIFT THE PARTIAL PRODUCT
	CLL		/YES-CLEAR LINK AND ADD MULTIPLICAND
	TAD	ACL	/TO PARTIAL PRODUCT
	RAR		/SHIFT PARTIAL PRODUCT-THIS IS HI ORDER
	DCA	AC2	/RESULT-STORE BACK
DVLP1,	TAD	OPL	/SHIFT A BIT OUT OF MULTIPLIER
	RAR		/AND A BIT OR RESLT. INTO IT (LO ORD. PROD.)
	ISZ	FFMPY	/DONE ALL BITS?
	JMP	MP12L	/NO-LOOP BACK
	CLL CMA IAC	/YES-LOW ORDER PROD. OF QUOT. X OPL IN AC
	DCA	ACL	/NEGATE AND STORE
	CML	RAL	/PROPAGATE CARRY
	JMP I	FD1P	/GO ON
FD1P,	FD1	/POINTER TO REST OF DIVIDE ROUTINE
/
/FLOATING DIVIDE ROUTINE
/USES THE METHOD OF TRIAL DIVISION BY HI ORDER
FFDIV,	0		/(USED AS A TEM. BY I/O ROUTINES)
	JMS I	[PATCHF	/WHICH MODE OF CALL?
	TAD I	FFDIV	/CALLED BY USER-GET ARG. ADDR.
	JMS I	MDSETK	/GO SET UP FOR DIVIDE-OPX IN AC ON RETN.
FFD1,	CMA	IAC	/NEGATE EXP. OF OPERAND
	TAD	ACX	/ADD EXP OF FAC
	DCA	ACX	/STORE AS FINAL EXPONENT
	TAD	OPH	/NEGATE HI ORDER OP. FOR USE
	CLL CMA IAC	/AS DIVISOR
	DCA	OPH
	JMS	DV24	/CALL DIV.--(ACH+ACL)/OPH
	TAD	ACL	/SAVE QUOT. FOR LATER
	DCA	AC1
	TAD	KM13	/SET COUNTER FOR 12 BIT MULTIPLY
	DCA	FFMPY	/TO MULTIPLY QUOT. OF DIV. BY 
	JMP	DVLP1	/LOW ORDER OF OPERAND (OPL)
/
/END OF FLOATING DIVIDE-FUDGE SOME
/STUFF THEN JUMP INTO MULTIPLY
/
FDDON,	TAD	FFDIV	/STORE RETN. ADDR. IN MULT ROUTINE
	DCA	FFMPY
	JMP	MDONE	/GO CLEAN UP
/
/DIVIDE ROUTINE--24 BITS IN ACH,ACL ARE DIVIDED BY 12 BITS
/IN OPH.  OPH IS ASSUMED NEGATIVE AND .GT. ACH IN ABSOLUTE VALUE
/ELSE-DIVIDE OVERFLOW--WE RETURN NORMALLY WITH QUOTIENT
/IN ACL AND REM. IN ACH.  (AC2=0 ON RETN.)
/
DV24,	0
	TAD	ACH	/CHECK THAT DIVISOR IS .GT. DIVIDEND
	TAD	OPH	/DIVISOR IN OPH (NEGATIVE)
	SZL	CLA	/IS IT?
	JMP I	DVOVR	/NO-DIVIDE OVERFLOW
	TAD	KM13	/YES-SET UP 12 BIT LOOP
	DCA	AC2
	JMP	DV1	/GO BEGIN DIVIDE
DV2,	TAD	ACH	/CONTINUE SHIFT OF FAC LEFT
	RAL
	DCA	ACH	/RESTORE HI ORDER
	TAD	ACH	/NOW SUBTRACT DIVISOR FROM HI ORDER
	TAD	OPH	/DIVIDEND
	SZL		/GOOD SUBTRACT?
	DCA	ACH	/YES-RESTORE HI DIVIDEND
	CLA		/NO-DON'T RESTORE--OPH.GT.ACH
DV1,	TAD	ACL	/SHIFT FAC LEFT 1 BIT-ALSO SHIFT
	RAL		/1 BIT OF QUOT. INTO LOW ORD OF ACL
	DCA	ACL
	ISZ	AC2	/DONE 12 BITS OF QUOT?
	JMP	DV2	/NO-GO ON
	JMP I	DV24	/YES-RETN W/AC2=0
FFNEGR,	FFNEG
MDSETK,	MDSET
KKM12,	-14
KM13,	-15
DVOVR,	DV

	PAGE
/
/FLOATING ADD
/
FFADD,	0
	JMS I	[PATCHF	/WHICH MODE FO CALL?
	TAD I	FFADD	/CALLED BY USER-GET ADDR. OF OPR.
	JMS I	ARGETP	/PICK UP OPERAND
FAD1,	CDF		/DF TO PACKAGE FIELD
	TAD	OPH	/IS OPERAND = 0
	SNA	CLA
	JMP	DONA	/YES-DONE
	TAD	ACH	/NO-IS FAC=0?
	SNA	CLA
	JMP	DOADD	/YES-DO ADD
	TAD	ACX	/NO-DO EXPONENT CALCULATION
	CLL CMA IAC
	TAD	OPX
	SMA	SZA	/WHICH EXP. GREATER?
	JMP	FACR	/OPERANDS-SHIFT FAC
	CMA	IAC	/FAC'S-SHIFT OPERAND=DIFFRNCE+1
	JMS	OPSR
	JMS	ACSR	/SHIFT FAC ONE PLACE RIGHT
DOADD,	TAD	OPX	/SET EXPONENT OF RESULT
	DCA	ACX
	JMS	OADD	/DO THE ADDITION
	JMS I	FNORP	/NORMALIZE RESULT
DONA,	ISZ	FFADD	/BUMP RETURN
	JMP I	FFADD	/RETURN
FACR,	JMS	ACSR	/SHIFT FAC = DIFF.+1
	JMS	OPSR	/SHIFT OPR. 1 PLACE
	JMP	DOADD	/DO ADDITION
/
/OPERAND SHIFT RIGHT-ENTER WITH POSITIVE COUNT-1
/IN AC
OPSR,	0
	CMA		/- (COUNT+1) TO SHIFT COUNTER
	DCA	AC0
LOP2,	TAD	OPH	/GET SIGN BIT
	RAL		/TO LINK
	CLA
	TAD	OPH	/GET HI MANTISSA
	RAR		/SHIFT IT RIGHT, PROPAGATING SIGN
	DCA	OPH	/STORE BACK
	TAD	OPL
	RAR
	DCA	OPL	/STORE LO ORDER BACK
	RAR		/SAVE 1 BIT OF OVERFLOW
	DCA	AC2	/IN AC2
	ISZ	OPX	/INCREMENT EXPONENT
NOP2,	NOP	
	ISZ	AC0	/DONE ALL SHIFTS?
	JMP	LOP2	/NO-LOOP
	JMP I	OPSR	/YES-RETN.
/
/SHIFT FAC LEFT 1 BIT
/
AL1,	0
	TAD	AC1	/GET OVERFLOW BIT
	CLL	RAL	/SHIFT LEFT
	DCA	AC1	/STORE BACK
	TAD	ACL	/GET LOW ORDER MANTISSA
	RAL		/SHIFT LEFT
	DCA	ACL	/STORE BACK
	TAD	ACH	/GET HI ORDER
	RAL
	DCA	ACH	/STORE BACK
	JMP I	AL1	/RETN.
/
/SHIFT FAC RIGHT-ENTER WITH COUNT-1 IN AC (POSITIVE)
/
ACSR,	0
	CMA	/AC CONTAINS COUNT-1
	DCA	AC0	/STORE COUNT
LOP1,	TAD	ACH	/GET SIGN BIT OF MANTISSA
	RAL		/SET UP SIGN PROPAGATION
	CLA
	TAD	ACH	/GET HIGH ORDER MANTISSA
	RAR		/SHIFT RIGHT`1, PROPAGATING SIGN
	DCA	ACH	/STORE BACK
	TAD	ACL	/GET LOW ORDER
	RAR		/SHIFT IT
	DCA	ACL	/STORE BACK
	RAR
	DCA	AC1	/SAVE 1 BIT OF OVERFLOW
	ISZ	ACX	/INCREMENT EXPONENT
NOP1,	NOP
	ISZ	AC0	/DONE?
	JMP	LOP1	/NO-LOOP
	JMP I	ACSR	/YES-RETN-AC=L=0
/
/DIVIDE OVERFLOW-ZERO ACX,ACH,ACL
/
DBAD,	CLA	CLL	/NECESSARY SO WE DON'T GET OVRFLO AGAIN
	JMP I	DBAD1P	/GO ZERO ALL
/
/FLOATING SUBTRACT
/
FFSUB,	0
	JMS I	[PATCHF	/WHICH MODE OF CALL?
	TAD I	FFSUB	/CALLED BY USER-GET ADDR. OF OP
	JMS I	ARGETP	/PICK UO THE OP.
	JMS	OPNEG	/NEGATE OPERAND
	TAD	FFSUB	/JMP INTO FLTG. ADD
SUB0,	DCA	FFADD	/AFTER SETTING UP RETURN
	JMP	FAD1
ARGETP,	ARGET
	*6135
/
/FLOATING NEGATE
/
FFNEG,	0		/(USED AS A TEM. BY OUTPUT ROUTINE)
	TAD	ACL	/GET LOW ORDER FAC
	CLL CMA IAC	/NEGATE IT
	DCA	ACL	/STORE BACK
	CML	RAL	/ADJUST OVERFLOW BIT AND
	TAD	ACH	/PROPAGATE CARRY-GET HI ORD
	CLL CMA IAC	/NEGATE IT
	DCA	ACH	/STORE BACK
	JMP I	FFNEG
/
/NEGATE OPERAND
/
OPNEG,	0
	TAD	OPL	/GET LOW ORDER
	CLL CMA IAC	/NEGATE AND STORE BACK
	DCA	OPL
	CML	RAL	/PROPAGATE CARRY
	TAD	OPH	/GET HI ORDER
	CLL CMA IAC	/NEGATE AND STORE BACK
	DCA	OPH
	JMP I	OPNEG
/
/ADD OPERAND TO FAC
/
OADD,	0
	CLL
	TAD	AC2	/ADD OVERFLOW WORDS
	TAD	AC1
	DCA	AC1
	RAL		/ROTATE CARRY
	TAD	OPL	/ADD LOW ORDER MANTISSAS
	TAD	ACL
	DCA	ACL
	RAL
	TAD	OPH	/ADD HI ORDER MANTISSAS
	TAD	ACH
	DCA	ACH
	JMP I	OADD	/RETN.
DBAD1P,	DBAD1
FNORP,	FFNOR
	>
	IFNZRO EAE <
/EAE FLOATING POINT PACKAGE
/FOR PDP8/E WITH KE8-E EAE
/
/W.J. CLOGHER
/
/DEFINITIONS OF EAE INSTRUCTIONS
	SWP=	7521
	CAM=	7621
	MQA=	7501
	MQL=	7421
	SGT=	6006
	SWAB=	7431
	SWBA=	7447
	SCA=	7441
	MUY=	7405
	DVI=	7407
	NMI=	7411
	SHL=	7413
	ASR=	7415
	LSR=	7417
	ACS=	7403
	SAM=	7457
	DAD=	7443
	DLD=	7663
	DST=	7445
	DPIC=	7573
	DCM=	7575
	DPSZ=	7451
	/
	TM=	TEMP4
	/
/FLOATING POINT INPUT ROUTINE
/
	PAGE
FFIN,	0
	CLA	CMA
	DCA	PRSW	/INITIALIZE PERIOD SWITCH TO -1
	CMA		/SET SIGN SWITCH TO -1
	DCA	SIGNF
	CDF		/CHANGE TO DF OF PACKAGE
	DCA	DSWIT	/ZERO CONVERSION SWITCH
DECONV,	DCA	ACX	/ZERO OUT THE FAC!
	DCA	ACL
	DCA	ACH
DECNV,	DCA	DNUMBR	/ZERO # OF DIGITS SINCE DEC. PT.
DECON,	JMS	GCHR	/GET A CHAR.FROM TTY.
	JMP	FFIN1	/TERMINATOR-
	ISZ	DSWIT	/DIGIT-BUMP CONVERSION SWITCH
	ISZ	DNUMBR	/BUMP # OF DIGITS
	DCA	TP1	/STORE IT IN FORM EASILY FLOATIBLE
	JMS I	FMPYLL	/MULTIPLY # BY 10
	TEN
	JMS I	[FFPUT	/STORE IT AWAY
	FPPTM1
	JMS I	[FFGET	/GET NEW DIGIT
	TP
	JMS I	[FFNOR	/FLOAT IT
	JMS I	FADDLL	/ADD IT TO THE ACCUMULATED #
	FPPTM1
	JMP	DECON	/GO ON
FFIN1,	ISZ	PRSW	/HAVE WE HAD A PERIOD YET?
	JMP	FIGO2	/YES-GO ON
	TAD	K2	/NO-IS THIS A PERIOD?
	SNA	CLA
	JMP	DECNV	/YES-ZERO DIG. COUNT AFTER DEC. PT.
			/AND GO CONVERT REST
	DCA	DNUMBR	/NO-TERMINATOR-ZERO COUNT OF
			/DIGITS AFTER DECIMAL POINT.
FIGO2,	CLA	MQL	/0 TO MQ FOR LATER MULTIPLY
	ISZ	SIGNF	/IS # NEGATIVE?(DID WE GET - SIGN?)
	JMS I	FFNEGP	/YES-NEGATE IT
	SWAB
	CMA		/RESET SIGN SWITCH FOR EXP.
	DCA	SIGNF
	TAD	CHAR	/NO-WAS THE TERMINATOR AN 'E'?
	TAD	KME	
	SNA	CLA
GETE,	JMS	GCHR	/YES-GET A CHAR. OF EXPONENT
	JMP	EDON	/END OF EXPONENT
	MUY		/GOT DIGIT OF EXP-MULT ACCUMULATED
	K12		/EXPONENT BY TEN AND ADD DIGIT
	JMP	GETE	/CONTINUE
EDON,	ISZ	SIGNF	/WAS EXPONENT NEGATIVE?
	DCM		/YES-NEGATE IT
	CLA	CLL	/CLEAR AC AND LINK
	TAD	DNUMBR	/GET # TIMES TO DIV MANTISSA BY TEN
	SAM		/SUBTRACT FROM EXPONENT
	CLL
	SPA		/RESULT POSITIVE?
	CLL CMA CML IAC	/NO-MAKE POS. AND SET LINK
	CMA		/NEGATE FOR COUNTER
	DCA	DNUMBR	/AND STORE
	RAL		/LINK=1-DIV;=0-MUL. # BY TEN
	TAD	MDV	/FORM CORRECT INSTRUCTION
	DCA	FINST	/AND STORE FOR EXECUTION
FCNT,	ISZ	DNUMBR	/DONE ALL OPERATIONS?
	JMP	FINST	/NO
	JMP I	FFIN	/YES-RETURN
FINST,	0		/NO- MUL OR DIV. MANTISSA
	TEN		/BY TEN
	JMP	FCNT	/GO ON
FFNEGP,	FFNEG
PRSW,	0
DNUMBR,	0
SIGNF,	0
K2,	2
KME,	-305
MDV,	JMS I	.+1	/THESE 3 WDS. MUST BE IN THIS ORDER
FMPYLL,	FFMPY
	FFDIV		/!!!!!!!!!!!!!!!!!
FADDLL,	FFADD

K12,	12
TP,	13
TP1,	0
	0
TEN,	4
	2400
	0
/ROUTINE TO GET A CHAR FROM THE TTY AND SEE IF IT IS DIGIT
/OR A TERMINATOR.
/RETURN TO CALL + 1 IF TERMINATOR, TO CALL + 2 IF DIGIT
/THIS ROUTINE MUST NOT MODIFY THE MQ!!
GCHR,	0
	JMS	INPUT	/GET A CHAR FROM TTY.
	TAD	CHAR	/PICK IT UP
	TAD	PLUS	/WAS IT PLUS SIGN?
	SNA
	JMP	DECON1	/YES-GET ANOTHER CHAR.
	TAD	MINUS	/NO WAS IT MINUS SIGN?
	SZA	CLA
	JMP	.+3
	DCA	SIGNF	/YES-FLIP SWITCH
DECON1,	JMS	INPUT	/GET A CHAR.
	TAD	CHAR
	TAD	K7506	/SEE IF ITS A DIGIT
	CLL
	TAD	K12
	SZL		/DIGIT?
	ISZ	GCHR	/YES-RETN. TO CALL+2
	JMP I	GCHR	/NO-RETN. TO CALL+1
K7506,	7506
PLUS,	-253
MINUS,	253-255
/
/
/INPUT ROUTINE-IGNORES LEADING SPACES
/
INPUT,	0
	JMS I	IGETCH	/USE OUR ROUTINE TO GET CHAR
	TAD	DSWIT	/GET TERMINATOR
	SZA CLA		/VALID INPUT YET?
	JMP	IOUT	/YES-CONTINUE
	TAD	CHAR	/NO-GET CHAR
	TAD	M240	/COMPARE AGAINST SPACE
	SZA
	TAD	(240-212 /IS IT AN LF?
	SNA CLA		/IS IT A SPACE OR LF?
	JMP	INPUT+1	/YES-IGNORE IT
IOUT,	JMP I	INPUT	/RETURN
M240,	-240
IGETCH,	GETCH		/ALTERED BY VAL FUNCITON TO PICK FROM SAC
/
/ROUTINE TO DECIDE CALLING MODE IN LIEU OF "SPECIAL MODE" PROBLEMS
/
PATCHF,	0
	SZA		/IS AC EMPTY
	JMP	RTN2	/NO-THIS IS ALWAYS SI MODE WITH ADDR IN AC
	TAD	FF		/YES-GET SPECIAL MODE FLIP-FLOP
	SZA CLA		/IF ON,THE ZERO AC MEANS ADDRESS OF 0
RTN2,	ISZ	PATCHF	/USE AC AS ADDRESS OF OPERAND
	JMP I	PATCHF	/RETURN
/
	PAGE
/
/FLOATING SUBTRACT-USES FLOATING ADD
/FSW1!!
FFSUB1,	0
	JMS I	[PATCHF	/WHICH MODE?
	TAD I	FFSUB1	/CALLED BY USER-GET ADDR. OF OP
	JMS I	ARGETL	/PICK UP ARGUMENT
	CDF
	JMS I	FFNEGA	/NEGATE FAC!
	TAD	FFSUB1
	JMP I	SUB0P
FFNEGA,	FFNEG
SUB0P,	SUB0


/
/FLOATING DIVIDE
/FSWITCH=1
/THIS IS OP/FAC
/
FFDIV1,	0
	JMS I	[PATCHF	/WHICH MODE OF CALL?
	TAD I	FFDIV1	/CALLED BY USER-GET ADDR.
	JMS I	ARGETL	/(INTERP.)-GET OPRND.-ADDR. IN AC
	CDF		/CDF TO FIELD OF PACKAGE
	TAD	ACH	/SWAP FAC AND OPRND-OPH IN MQ!
	DCA	OPH	/STORE ACH IN OPH
	TAD	ACX	/GET EXP OF FAC
	SWP		/OPH TO AC, ACX TO MQ
	DCA	ACH	/STORE OPH IN ACH
	TAD	OPX	/STORE OPX IN ACX
	DCA	ACX
	TAD	OPL	/OPL TO MQ, ACX TO AC
	SWP
	DCA	OPX	/STORE ACX IN OPX
	TAD	ACL
	DCA	OPL	/STORE ACL IN OPL
	TAD	OPH	/OPH TO MQ FOR LATER
	SWP
	DCA	ACL	/STORE OPL IN ACL
	TAD	FFDIV1	/SET UP SO WE RETN TO
	DCA I	FFDP	/NORMAL DIVIDE ROUTINE
	TAD	FD1
	DCA I	MDSETP
	JMP I	MD1P	/GO ARRANGE OPERANDS

MD1P,	MD1
ARGETL,	ARGET
MDSETP,	MDSET
FFDP,	FFDIV
FD1,	FFD1


/PATCH TO EAE ADD ROUTINE

ADDPCH,	0
	TAD	AC1	
	TAD	RB4000
	DPSZ
	JMP	ADDP1
	CLL CML RTR
	ISZ	ACX
	NOP
ADDP1,	TAD	RB4000
	JMP I	ADDPCH
RB4000,	4000


/
PTCHAD,	CDF
	TAD	OPH
	SNA CLA	/OPERAND ZERO
	JMP I	JADON	/YES
	TAD	ACH	/FAC ZERO
	SZA CLA
	JMP I	JFAD1	/NO
	TAD	OPX
	DCA	ACX
	TAD	OPH
	DCA	ACH
	TAD	OPL
	DCA	ACL
	JMP I	JADON
JADON,	ADON
JFAD1,	FAD1
/
/FLOATING MULTIPLY--DOES 4 SINGLE MULTIPLIES WITH EAE
/THIS USES THE FACT THAT IF AC IS NON-ZERO WHEN YOU DO
/A MUY INSTR, THE AC IS ADDED TO RESULT OF THE MULTIPLY.
/(IN THE LOW ORDER, NATCHERLY)
	PAGE
FFMPY,	0
	JMS I	[PATCHF	/WHICH MODE?
	TAD I	FFMPY	/CALLED BY USER-GET ADDRESS
	JMS	MDSET	/SET UP FOR MULT
	CLA	MUY	/MULTIPLY-LOW ORDER FAC STILL IN MQ
	OPH		/THIS IS PRODUCT OF LOW ORDERS
	MQL		/ZAP LOW ORDER RESULT-INSIGNIFICANT
	TAD	ACH	/GET LOW ORDER(!) OF FAC
	SWP	MUY	/TO MQ-HIGH ORD. RESLT OF LAST MPY
	OPL		/TO AC-WILL BE ADDED TO RESLT-THIS
	DST		/IS PRODUCT-LOW ORD FAC,HI ORD OP
	AC0		/STORE RESULT
	DLD		/HIGH ORDER FAC TO MQ, OPX TO AC
	ACL
	TAD	ACX	/ADD FAC EXPONENT-GET SUM OF EXPS.
	DCA	ACX	/STORE RESULT
	MUY		/MUL. HIGH ORDER FAC BY LOW ORD OP.
	OPH		/HIGH ORDER FAC WAS IN MQ
	DAD		/ADD IN RESULT OF SECOND MULTIPLY
	AC0
	DCA	ACH	/STORE HIGH ORDER RESULT
	TAD	ACL	/GET HIGH ORDER FAC
	SWP		/SEND IT TO MQ AND LOW ORD. RESULT
	DCA	AC0	/OF ADD TO AC-STORE IT
	RAL		/ROTATE CARRY TO AC
	DCA	ACL	/STORE AWAY
	MUY		/NOW DO PRODUCT OF HIGH ORDERS
	OPL		/FAC HIGH IN MQ, OP HIGH IN OPL
	DAD		/ADD IN THE ACCUMULATED #
	ACH
	SNA		/ZERO?
	JMP	RTZRO	/YES-GO ZERO EXPONENT
	NMI		/NO-NORMALIZE (1 SHIFT AT MOST!)
	DCA	ACH	/STORE HIGH ORDER RESULT
	CLA	SCA	/GET STEP CNTR-DID WE NEED A SHIFT?
	SNA	CLA
	JMP	SNCK	/NO-JUST CHECK SIGN
	CLA	CMA	/YES-MUST DECREASE EXP. BY 1
	TAD	ACX
RTZRO,	DCA	ACX	/STORE BACK

	TAD	AC0
	SPA	CLA	/IS HIGH ORDER OF OVERFLO WD. 1?
	DPIC		/YES-ADD 1 TO LOW ORDER-STILL IN MQ
SNCK,	ISZ	MSIGN	/RESULT NEGATIVE?
	JMP	MPOS	/NO-GO ON
	TAD	ACH	/YES-GET HIGH ORDER BACK
	DCM		/LOW ORDER STILL IN MQ-NEGATE
	DCA	ACH	/STORE HIGH ORDER BACK
MPOS,	SWP		/LOW ORDER TO AC
	DCA	ACL	/STORE AWAY
	ISZ	FFMPY	/BUMP RETURN
	JMP I	FFMPY	/RETIRN
MSIGN,	0
ARGETK,	ARGET
DVOFL,	DV

/
/ROUTINE TO SET UP FOR MULTIPLY AND DIVIDE
/
MDSET,	0
	JMS I	ARGETK	/GET OPERAND (ADDR. IN AC)
	CDF		/CHANGE TO DATA FIELD OF PACKAGE
MD1,	CLA CLL CMA RAL	/MAKE A MINUS TWO
	DCA	MSIGN	/AND STORE IN MSIGN.
	TAD	OPL	/GET LOW ORDER MANTISSA OF OP.
	SWP		/GET INTO RIGHT ORDER ( OPH IN MQ)
	SMA		/NEGATIVE?
	JMP	.+3	/NO
	DCM		/YES-NEGATE IT
	ISZ	MSIGN	/BUMP SIGN COUNTER
	SHL		/SHIFT OPRND LEFT 1 TO AVOID OVRFLO
	1
	DST		/STORE BACK-OPH CONTAINS LOW ORDER
	OPH		/	OPL CONTAINS HIGH ORDER
	DLD		/GET THE MANTISSA OF THE FAC
	ACH
	SWP		/MAKE IT CORRECT ORDER
	SMA		/NEGATIVE?
	JMP	FPOS	/NO
	DCM		/YES-NEGATE IT
	ISZ	MSIGN	/BUMP SIGN COUNTER (MAY SKIP)
	NOP
FPOS,	DST		/STORE BACK-ACH CONTAINS LOW ORDER
	ACH		/	ACL CONTAINS HIGH ORDER
	JMP I	MDSET	/RETURN



/
/FLOATING DIVIDE
/
	*5722
FFDIV,	0
	JMS I	[PATCHF	/WHICH MODE?
	TAD I	FFDIV	/CALLED BY USER-GET ARG. ADDRESS
	JMS	MDSET	/GET ARG. AND SET UP SIGNS
FFD1,	DVI		/DIVIDE-ACH AND ACL IN AC,MQ
	OPL		/THIS IS HI (!) ORDER DIVISOR
	DST		/QUOT TO AC0,REM TO AC1
	AC0
	SZL	CLA	/DIVIDE ERROR?
	JMP I	DVOFL	/YES-HANDLE IT
	TAD	OPX	/DO EXPONENT CALCULATION
	CMA	IAC	/EXP. OF FAC - EXP. OF OP
	TAD	ACX
	DCA	ACX
	DPSZ		/IS QUOT = 0?
	SKP		/NO-GO ON
	DCA	ACX	/YES-ZERO EXPONENT
DVLP,	MUY		/NO-THIS IS Q*OPL*2**-12
	OPH
	DCM		/NEGATE IT
	TAD	AC1	/SEE IF GREATER THAN REMAINDER
	SNL
	JMP I	DVOPSP	/YES-ADJUST FIRST DIVIDE
	DVI		/NO-DO Q*OPL*2**-12/OPH
	OPL
	SZL	CLA	/DIV ERROR?
	JMP I	DVOFL	/YES
DVLP1,	TAD	AC0	/NO-GET QUOT OF FIRST DIV.
	SMA		/NEGATIVE?
	JMP	.+5	/NO-REMEMBER-QUOT OF 2ND DIV. IN MQ
	LSR		/YES-MUST SHIFT IT RIGHT 1
	1
	ISZ	ACX	/ADJUST EXPONENT
	NOP
	ISZ	MSIGN	/SHOULD SIGN BE MINUS?
	SKP		/NO
	DCM		/YES-DO IT
DBAD1,	DCA	ACH	/STORE IT BACK
	SWP
	DCA	ACL
	ISZ	FFDIV
	JMP I	FFDIV	/BUMP RETN. AND RETN.

DVOPSP,	DVOPS
DBAD,	CAM
	DCA	ACX	/ZERO EXPONENT
	JMP	DBAD1	/GO ZERO MANTISSA
/FLOATING ADDITION-IN ORDER NOT TO LOSE BITS, WE DO NOT
/SHIFT BOTH NUMBERS RIGHT 1 BIT BEFORE ADD-ONLY SHIFTS DONE
/ARE TO ALIGN EXPONENTS.
/
	PAGE
FFADD,	0
	JMS I	[PATCHF	/WHICH MODE OF CALLING
	TAD I	FFADD	/CALLED DIRECTLY BY USER
	JMS I	ARGETP	/PICK UP ARGUMENTS
	JMP I	PATCHK	/CHECK FOR ADDITION BY ZERO
FAD1,	TAD	OPX	/PICK UP EXPONENT OF OPERAND
	MQL		/SEND IT TO MQ FOR SUBTRACT
	TAD	ACX	/GET EXPONENT OF FAC
	SAM		/SUBTRACT-RESULT IN AC
	SPA		/NEGATIVE RESULT?
	CMA	IAC	/YES-MAKE IT POSITIVE
	DCA	CNT	/STORE IT AS A SHIFT COUNT
	TAD	CNT	/COUNT TOO BIG?(CAN'T BE ALIGNED)
	TAD	M27
	SPA SNA CLA
	CMA		/NO-OK
	DCA	AC0	/YES-MAKE IT A LOAD OF LARGEST #
	DLD		/GET ADDRESSES TO SEE WHO'S SHIFTED
	ADDRS
	SGT		/WHICH EXP GREATER(GT FLG SET
			/BY SUBTR. OF EXPS.)
	SWP		/OPERAND'S-SHIFT THE FAC
	DCA	SHFBG	/STORE ADDRESS OF WHO GETS SHIFTED
	SWP		/GET ADDRESS OF OTHER (0 TO MQ)
	DCA	DADR	/THIS ONE JUST GETS ADDED
	SGT		/WHICH EXPONENT WAS GREATER?
	JMP	.+3	/FAC'S - DO NOTHING
	TAD	OPX	/OPERAND'S-PUT FINAL EXP. IN ACX
	DCA	ACX
	DLD		/GET THE LARGER # TO AC,MQ
DADR,	0
	SWP		/PUT IN THE RIGHT ORDER
	ISZ	AC0	/COULD EXPONENTS BE ALIGNED?
	JMP	LOD	/NO-JUST LEAVE LARGER IN AC,MQ
	DST		/YES-STORE THIS TEMPORARILY
	AC0		/(IF ONLY FAC STORAGE WAS REVERSED)
	DLD		/GET THE SMALLER #
SHFBG,	0
	SWP		/PUT IT IN RIGHT ORDER
	ASR		/DO THE ALIGNMENT SHIFT
CNT,	0
	DAD		/ADD THE LARGER #
	AC0
	DST		/STORE RESULT
	AC0
	SZL		/OVERFLOW?(L NOT = SIGN BIT)
	CMA		/NOTE-WE DIDN'T SHIFT BOTH RIGHT 1
	SMA	CLA
	JMP	NOOV	/NOPE
	CLA CLL CML RAR	/MAYBE-SEE IF 2 #S HAD SAME SIGN
	AND	ACH
	TAD	OPH
	SMA	CLA	/SIGNS ALIKE?
	JMP	OVRFLO	/YES-OVERFLOW
NOOV,	JMS I	ADDPCL	/JUMP TO PATCH FOR THIS ROUTINE
LOD,	NMI		/NORMALIZE (LOW ORDER STILL IN MQ)
	DCA	ACH	/STORE FINAL RESULT
	SWP		/GET AND STORE LOW ORDER
	DCA	ACL
	SCA		/GET SHIFT COUNTER(# OF NMI SHIFTS)
	CMA	IAC	/NEGATE IT
	TAD	ACX	/AND ADJUST FINAL EXPONENT
	DCA	ACX
ADON,	ISZ	FFADD	/BUMP RETURN PAST ADDRESS
	JMP I	FFADD	/RETURN
OVRFLO,	TAD	AC1	/OVERFLOW-GET HIGH ORDER RESLT BACK
	ASR		/SHIFT IT RIGHT 1
	1
	TAD	KK4000	/REVERSE SIGN BIT
	DCA	ACH	/AND STORE
	SWP
	DCA	ACL	/STORE LOW ORDER
	ISZ	ACX	/BUMP EXPONENT
	NOP
	JMP	ADON	/DONE
KK4000,	4000
M27,	-27
ADDRS,	OPH
	ACH
ARGETP,	ARGET
/FLOATING SUBTRACT-USES FLOATING ADD
/FSW0!!
FFSUB,	0
	JMS I	[PATCHF	/WHICH MODE?
	TAD I	FFSUB	/CALLED BY USER-GET ADDRESS OF OP.
	JMS I	ARGETP
	CDF
	TAD	OPL	/OPH IS IN MQ!
	SWP		/PUT IT IN RIGHT ORDER
	DCM		/NEGATE IT
	DCA	OPH	/STORE BACK
	MQA
	DCA	OPL
	TAD	FFSUB	/GO TO ADD
SUB0,	DCA	FFADD
	JMP	FAD1-1
/
/FLOATING NEGATE--NEGATE FLOATING AC
/
FFNEG,	0
	SWAB		/MUST BE MODE B
	DLD		/GET MANTISSA
	ACH
	SWP		/CORRECT ORDER PLEASE!
	DCM		/NEGATE IT
	DCA	ACH	/RESTORE
	SWP		/SEND 0 TO MQ
	DCA	ACL
	JMP I	FFNEG


/
/CONTINUATION OF DIVIDE ROUTINE
/WE ARE ADJUSTING THE RESULT OF THE
/FIRST DIVIDE.
/
DVOPS,	CMA	IAC
	DCA	AC1	/ADJUST REMAINDER
	TAD	OPL	/WATCH FOR OVERFLOW
	CLL CMA IAC
	TAD	AC1
	SNL
	JMP	DVOP1	/DON'T ADJUST QUOT.
	DCA	AC1
	CMA
	TAD	AC0
	DCA	AC0	/REDUCE QUOT BY 1
DVOP1,	CLA	CLL
	TAD	AC1	/GET REMAINDER
	SNA		/ZERO?
	CAM		/YES-ZERO EVERYTHING
	DVI		/NO
	OPL
	SZL	CLA	/DIV. OVERFLOW?
	JMP I	DVOVR	/YES
	DCM		/NO-ADJUST HI QUOT (MAYBE)
	JMP I	DVLP1P	/GO BACK
DVLP1P,	DVLP1
DVOVR,	DV
ADDPCL,	ADDPCH
PATCHK,	PTCHAD
	>
	PAGE
/ARGUMENT PICK UP ROUTINE-ENTER WITH DATA FIELD SET TO EITHER
/FLTG. DATA FIELD OR FLTG. INSTR. FIELD.
/ADDRESS OF OPERAND IS IN THE AC ON ENTRY.
/ON RETURN, THE`AC IS CLEAR
/
ARGET,	0
	DCA	AC2	/STORE ADDRESS OF OPERAND
	TAD I	AC2	/PICK UP EXPONENT
	DCA	OPX
	JMS	ISZAC2	/MOVE POINTER TO HORD,WATCH FOR FIELD OVERLAP
	TAD I	AC2	/PICK IT UP
	IFZERO EAE <
	NOP
	NOP
	>

	IFNZRO EAE <
	SWAB		/OPH INTO MQ BECAUSE EAE ROUTINES
	MQA		/EXPECT TO FIND IT THERE
	>
	DCA	OPH	/STORE
	JMS	ISZAC2	/MOVE POINTER TO LORD,WATCHING FOR OVERLAP
	TAD I	AC2	/PICK IT UP
	DCA	OPL	/STORE IT
	JMP I	ARGET	/RETURN
	IFZERO EAE <
/
/ROUTINE TO NORMALIZE THE FAC
/
FFNOR,	0
	TAD	ACH	/GET THE HI ORDER MANTISSA
	SNA		/ZERO?
	TAD	ACL	/YES-HOW ABOUT LOW?
	SNA
	TAD	AC1	/LOW=0, IS OVRFLO BIT ON?
	SNA	CLA
	JMP	ZEXP	/#=0-ZERO EXPONENT
NORMLP,	AC2000		/NOT 0-MAKE A 2000 IN AC
	TAD	ACH	/ADD HI ORDER MANTISSA
	SZA		/HI ORDER = 6000
	JMP	.+3	/NO-CHECK LEFT MOST DIGIT
	TAD	ACL	/YES-6000 OK IF LOW=0
	SZA	CLA	
	SPA	CLA	/2,3,4,5,ARE LEGAL LEFT MOST DIGS.
	JMP	FFNORR	/FOR NORMALIZED #-(+2000=4,5,6,7)
	JMP	FNLP	/JUMP SO FFGET AND PUT ARE ORGED RIGHT

FFNORR,	DCA	AC1	/DONE W/NORMALIZE-CLEAR AC1
	JMP I	FFNOR	/RETURN
AL1P,	AL1
	>
	IFNZRO EAE <

/
/ROUTINE TO NORMALIZE THE FAC
/
	*6215
FFNOR,	0
	CDF		/CHANGE D.F. TO FIELD OF PACKAGE
	SWAB		/FORCE MODE B
	DLD		/PICK UP MANTISSA
	ACH
	SWP		/PUT IT IN CORRECT ORDER
	NMI		/NORMALIZE IT
	SNA		/IS THE # ZERO?
	DCA	ACX	/YES-INSURE ZERO EXPONENT
	DCA	ACH	/STORE HIGH ORDER BACK
	SWP		/STORE LOW ORDER BACK
	DCA	ACL
	CLA	SCA	/STEP COUNTER TO AC
	CMA	IAC	/NEGATE IT
	TAD	ACX	/AND ADJUST EXPONENT
	DCA	ACX
	JMP I	FFNOR	/RETURN
	>
/FLOATING GET

	*6241
FFGET,	0
	JMS I	[PATCHF	/WHICH MODE OF CALL
	TAD I	FFGET	/CALLED BY USER-GET ADDR. OF OP
	JMS	ARGET	/PICK UP OPERAND
	TAD	OPX
	DCA	ACX	/LOAD THE OPERAND INTO FAC
	TAD	OPL
	DCA	ACL
	TAD	OPH
	DCA	ACH
	ISZ	FFGET
	CDF
	JMP I	FFGET	/RETN. TO CALL +2
/
/FLOATING PUT
/
FFPUT,	0
	JMS I	[PATCHF	/WHICH MODE OF CALL?
	TAD I	FFPUT	/CALLED BY USER-GET OPR. ADDR
	DCA	FFGET	/STORE IN A TEMP
	TAD	ACX	/GET FAC AND STORE IT
	DCA I	FFGET	/AT SPECIFIED ADDRESS
	JMS	ISZFGT	/BUMP POINTER,WATCHING FOR FIELD OVERLAP
	TAD	ACH
	DCA I	FFGET
	JMS	ISZFGT
	TAD	ACL
	DCA I	FFGET
	ISZ	FFPUT	/BUMP RETN.
	CDF
	JMP I	FFPUT	/RETN. TO CALL+2

/ROUTINES TO BUMP ARGET AND FPUT POINTERS AND INCREMENT THE
/DATA FIELD IF THE POINTER CROSSES A FIELD BOUNDARY

ISZFGT,	0
	ISZ	FFGET	/BUMP POINTER
	JMP I	ISZFGT	/NO SKIP MEANS JUST RETURN
	SKP		/SKIP MEANS WE HAVE TO INCREMENT DATA FIELD
NEWCDF,	DCA	ISZFGT	/THIS INST EXECUTED ONLY BY ISZAC2
	RDF		/GET THE DATA FIELD
	TAD	CDF10	/BUMP BY 1 AND MAKE A CDF
	DCA	.+1		/PUT IN LINE
	.
	JMP I	ISZFGT	/RETURN

CDF10,	CDF 10

ISZAC2,	0
	ISZ	AC2		/BUMP POINTER
	JMP I	ISZAC2	/NOTHING HAPPENED
	TAD	ISZAC2	/NEED NEW DF. GET RETURN ADDR
	JMP	NEWCDF	/AND BUMP DF
	IFZERO EAE <
/
/ROUTINE TO ADJUST QUOTINET OF FIRST DIVIDE (MAYBE) WHEN THE
/REMAINDER OF THE FIRST`DIVIDE IS LESS THAN QUOT*OPL
/USED BY FLTG. DIVIDE ROUTINE
/
DVOPS,	CMA	IAC	/NEGATE AND STORE REVISED REMAINDER
	DCA	ACH	
	CLL
	TAD	OPH
	TAD	ACH	/WATCH FOR OVERFLOW
	SNL
	JMP	DVOP1	/OVERFLOW-DON'T ADJUST QUOT. OF 1ST DIV.
	DCA	ACH	/NO OVERFLOW-STORE NEW REM.
	CMA		/SUBTRACT 1 FROM QUOT OF
	TAD	AC1	/FIRST DIVIDE
	DCA	AC1
DVOP1,	CLA 	CLL
	TAD	ACH	/GET HI ORD OF REMAINDER
	JMP I	DVOP2P	/GO ON
DVOP2P,	DVOP2

FNLP,	CLL CML CMA	/-1
	TAD	ACX	/SUBTR. 1 FROM EXPONENT
	DCA	ACX
	JMS I	AL1P	/SHIFT FAC LEFT 1
	JMP	NORMLP	/GO BACK AND SEE IF NORMALIZED
ZEXP,	DCA	ACX
	JMP	FFNORR
	>
/
/FSQUARE-SQUARE FAC-CALLS MULTIPLY TO MUL. FAC BY ITSELF
/
	*6347
A,
FFSQ,	0
	JMS I	TMPY	/CALL MULTIPLY TO MULTIPLY
	ACX		/FAC BY ITSELF
	JMP I	FFSQ	/DONE
TMPY,	FFMPY
/
/	ERROR TRAPS
O0,	JMS I	[ERROR	/OVERFLOW
DV,	JMS I	[ERROR	/DIVISION ERROR
	JMS I	[FACCLR	/RETURN 0 IN FAC
	JMP I	[ILOOP
LM,	JMS I	[ERROR	/ILLEGAL ARGUMENT

	PAGE

	*OVERLAY+3000


/TELETYPE "DRIVER"-WHEN CALLED,GRABS CHARACTERS FROM THE
/TELETYPE UNTIL A CR IS SENT OR THE BUFFER IS FULL. ASSUMES TTY ENTRY
/IS IN I/O WORK AREA.

TTYDRI,	0
	JMP	LFLUSH+1
IO,	JMS I	[ERROR
LFLUSH,	JMS I	[CRLFR	/PRINT A CR,LF
	TAD	K277	/PRINT A ? SIGNIFYING WAIT FOR INPUT
	JMS I	[XPUTCH
	TAD I	IOTBUF	/BUFFER ADDRESS
	DCA I	IOTPTR	/INITIALIZE POINTER TO START OF BUFFER
	JMS I	[CNOCLR	/INITIALIZE CHAR # TO 1
TTYIN,	JMS I	[XPRINT	/EMPTY TTY BUFFER BEFORE AWAITING INPUT
	JMP	.-1
	TAD I	(HEIGHT	/ALWAYS RESET SCREEN HIEGHT ON INPUT
	DCA I	(HCTR
	TAD	K5252	/DESIGN INTO AC
KSFA,	KSF		/CHAR READY?
	JMP	SPIN	/NO-DIDDLE WHILE WE WAIT
	CLA CLL		/FLUSH SPINNER OUT OF AC
	TAD	[200	/FORCE PARITY BIT
	KRS		/GET CHAR
	DCA	CHAR	/SAVE
	TAD	CHAR
	JMS I	[XPUTCH	/ECHO IT
	KCC		/CLEAR KEYBOARD FLAG AND SET READER RUN
	TAD	CHAR
	TAD	MCTRLU	/IS IT CTRL/U?
	SNA CLA
	JMP	LFLUSH	/YES-START AGAIN
	TAD	CHAR	/NO
	TAD	CRUBOT	/IS IT RUBOUT?
	SNA
	JMP	BACKUP	/YES-BACK UP BUFFER POINTER
	TAD	MCR	/NO-IS IT CR?
	SNA CLA
	JMP	CR	/YES-DONE
	TAD	CHAR
	JMS I	[PACKCH	/PACK CHAR IN BUFFER
	JMS I	[BUFCHK	/BUFFER FULL?
	JMP	IO	/YES-ERROR
	NOP		/NO-CHAR 3 LEFT
	NOP		/NO-2 AND 3 LEFT
	JMP	TTYIN	/NO-NEXT CHAR
MCTRLU,	-225
MCR,	377-215
CRUBOT,	-377
K5252,	5252
K277,	277

BACKUP,	TAD I	IOTPTR	/BUFFER POINTER
	CIA		/NEGATE
	TAD I	IOTBUF	/COMPARE AGAINST START OF BUFFER
	SNA CLA		/BUFFER EMPTY?
	JMP	TTYIN	/YES-THERE IS NOTHING TO RUBOUT
	TAD	SCOPFG	/TEST IF CONSOLE IS A SCOPE
	SNA CLA
	JMP	NOSCOP	/JMP IF NOT
	TAD	(10
	JMS I	[XPUTCH	/PRINT BS,SP,BS TO RUBOUT IF SCOPE
	TAD	(40
	JMS I	[XPUTCH
	TAD	(10
	SKP
NOSCOP,	TAD	K334
	JMS I	[XPUTCH	/ECHO "\"
	JMS I	[CHARNO	/GET CHAR # OF NEXT CHAR (LAST #+1)
	JMP	C1B	/1
	JMP	C3B	/3
	JMS I	[CNOCLR	/IT WAS 2-MAKE IT 1
PBACK,	CLA CMA		/-1
	TAD I	IOTPTR	/BACK UP BUFFER POINTER
	DCA I	IOTPTR
	JMP	TTYIN	/NEXT CHAR
K334,	334

C1B,	TAD I	IOTHDR
	AND	[7477
	TAD	[200	/IT WAS 1-MAKE IT 3
	DCA I	IOTHDR
	JMP	TTYIN	/NO NEED TO BACK UP POINTER

C3B,	TAD I	IOTHDR
	AND	[7477
	TAD	[100	/IT WAS 3,MAKE IT 2
	DCA I	IOTHDR
	JMP	PBACK	/BACK UP POINTER


CR,	JMS I	[CRLFR	/ECHO A CR,LF
	TAD	K4
	TAD	TTYDRI	/BUMP DRIVE RETURN TO NORMAL
	DCA	TTYDRI
	TAD	CHAR
	JMS I	[PACKCH	/PACK CHAR IN BUFFER
	TAD I	IOTBUF
	DCA I	IOTPTR	/INITAILZE BUFFER POINTERS
	JMS I	[CNOCLR
	JMP I	TTYDRI	/RETURN
K4,	4


SPIN,	ISZ	SPINNR	/SPIN RANDOM # SEED
	SKP
	CMA CML RAL	/MARCH TO THE LEFT
	JMP	KSFA	/CHECK FOR CHAR YET
SCOPFG,	0		/GETS SET TO SCOPE FLAG BY STARTUP CODE
/SUBROUTINE FBITGT-ROUTINE TO PUT FUNCTION BITS FROM INSTRUCTION INTO AC

FBITGT,	0
	TAD	INSAV
	CLL RTR
	RTR		/PUT FUNCTION BITS IN BITS 8-11
	AND	[17	/MASK THEM OFF
	JMP I	FBITGT	/RETURN

/DATA LIST READ (NUMERIC)

RDLIST,	JMS I	(DLREAD	/FETCH WORD FROM LIST
	DCA	ACX		/STORE AS EXPONENT
	JMS I	(DLREAD
	DCA	ACH	/HIGH MANTISSA
	JMS I	(DLREAD
	DCA	ACL	/LOW MANTISSA
	JMP I	[ILOOP

/SUBROUTINE FTYPE-RETURNS TO CALL+1 IF FILE NUMERIC,CALL+2 IF ASCII

FTYPE,	0
	TAD I	IOTHDR	/GET HEADER
	CLL RAR		/TYPE TO LINK
	SZL CLA		/IS IT NUMERIC?
	ISZ	FTYPE	/NO-BUMP RETURN
	JMP I	FTYPE	/RETURN

	PAGE
/LAST PAGE OF BRTS-CONTAINS SAC,I/O TABLE, AND SOME MISCELLANEOUS CODE

/TELETYPE INPUT BUFFER (74. CHARACTERS LONG)
/THIS BUFFER CONTAINS ONCE ONLY START CODE WHEN LOADED

TTYBUF,
START4,	TAD	CDFPS	/DF FOR BOTTOM OF PSEUDO-CODE
	TAD	MCDF1	/COMPARE TO A CDF 10
	SZA CLA		/DO THEY MATCH?
	JMP I	[ILOOP	/NO-ALL BUFFERS ARE FREE-START INTERPRETER
	TAD	PSSTRT
	CLL CMA
	TAD	[400
	SNL CLA		/IS START OF PSEUDO-CODE BELOW 400
	JMP	CHKB2	/NO-CHECK FOR 1000
	TAD	[17		/YES-SET ALL BUFFERS BUSY
	JMP	BAS
CHKB2,	TAD	PSSTRT
	CLL CMA
	TAD	C1000
	SNL CLA		/IS START OF PSEUDO-CODE BELOW 1000
	JMP	CHKB3	/NO-CHECK 1400
	TAD	C16		/YES-ONLY BUFFER 1 IS AVAILABLE
	JMP	BAS
CHKB3,	TAD	PSSTRT
	CLL CMA
	TAD	C1400
	SNL CLA		/IS START OF CODE BELOW 1400?
	JMP	CHKB4	/YES-CHECK 2000
	TAD	C14		/YES-ONLY BUFFER 1 AND 2 AVAILABLE
	JMP	BAS
CHKB4,	TAD	PSSTRT
	CLL CMA
	TAD	K2000
	SNL CLA		/IS CODE START BELOW 2000?
	JMP I	[ILOOP	/NO-START INTERPRETER-ALL BUFFER FREE
	TAD	[10	/YES-BUFFERS 1,2, AND 3 AVAILABLE
BAS,	DCA	BMAP
	JMP I	[ILOOP	/START INTERPRETER
	0
MCDF1,	-6211
K2000,	2000
C14,	14
C16,	16
C1000,	1000
C1400,	1400
	ZBLOCK	10
TTYEND,	0
        *OVERLAY+3277

////////////////////////////////////////////////////////////////
/////// I/O TABLE 5 13-WORD ENTRIES ////////////////////////////
////////////////////////////////////////////////////////////////

TTYF,   1               /TELETYPE ENTRY-FILE IS ASCII
        TTYBUF          /BUFFER ADDRESS
        0               /CURRENT BLOCK IN BUFFER
        TTYBUF          /READ WRITE POINTER
        TTYDRI          /HANDLER ENTRY
	ZBLOCK	10
FILE1,  ZBLOCK	15             /FILE #1
FILE2,  ZBLOCK	15             /FILE #2
FILE3,  ZBLOCK	15             /FILE #3
FILE4,  ZBLOCK	15             /FILE #4

	PAGE
	/CROSS FIELD LITERAL EQUATES

	PGETCH=	[GETCH
	PILOOP=	[ILOOP
	PPUTCH=	[PUTCH
	PSACM1=	[SAC-1
	PXPUTCH= [XPUTCH
	PXPRINT= [XPRINT
	PFFNOR=	[FFNOR
	PFFGET=	[FFGET
	PFFPUT=	[FFPUT
	PUNSFIX= [UNSFIX
	PERROR= [ERROR
	PFACCLR= [FACCLR
	PIDLE=	[IDLE
	PPSWAP=	[PSWAP
	PFTYPE=	[FTYPE
	USR=	[200
	O200=	[200
	O400=	[400
	O100=	[100
	O10=	[10
	O17=	[17
	O7400=	[7400
	O77=	[77
	O215=	[215
	O7700=	[7700
	M215=	[-215
/////////////////////////////////////////////////////////////
/////////////////////////////////////////////////////////////
////////////// OVERLAY 2- STRING FUNCTIONS  /////////////////
/////////////////////////////////////////////////////////////
/////////////////////////////////////////////////////////////

	FIELD 1
	*2000
	RELOC	OVERLAY

	/VERSION NUMBER WORD FOR STRING OVERLAY

	VERSON^100+SUBVSF+6000

/CHR$ FUNCTION
/RETURNS 1 6BIT CHAR STRING FOR THE VALUE OF X

CHR,	JMS I	PUNSFIX	/FIX X TO 12 BIT INTEGER
	AND	O77	/MASK TO 6BIT
	DCA I	(SAC	/AND PUT INTO SAC
	CMA
	DCA	SACLEN	/SET SAC LENGTH TO 1
	JMP I	(SSMODE	/SET TO SMODE AND RETURN

/ASC FUNCTION
/RETURNS DECIMAL ASCII FOR 1 CHAR STRING IN FAC

ASC,	TAD I	(SAC	/GET FIRST CHAR OF STRING
	JMP	FLOATS	/FLOAT RESULT INTO FAC AND RETURN

/LEN FUNCTION
/RETURNS LENGTH OF SAC IN FAC

LEN,	TAD	SACLEN	/LENGTH OF STRING IN SAC
	CIA		/MAKE POSITIVE

/ROUTINE TO FLOAT FAC AND RETURN

FLOATS,	DCA	ACH	/NUMBER TO BE FLOATED IN HORD
	DCA	ACL	/CLEAR LORD
	DCA	TEMP2	/CLEAR FPP OVERFLOW
	TAD	(13	/SET EXP TO 11
	DCA	ACX
	JMS I	PFFNOR	/NORMALIZE
	JMP I	PILOOP	/RETURN



/STR$ FUNCTION
/RETURNS ASCII STRING FOR NUMBER IN FAC

STR,	JMS I	(FFOUT	/GET NUMBER INTO INTERMEDIATE BUFFER FIRST
	TAD	XR1
	CIA
	TAD	(INTERB-1
	DCA	SACLEN
	TAD	SACLEN	/NOW SAVE COUNTER
	DCA	TEMP2
	TAD	(INTERB-1
	DCA	XR1	/POINT AT BUFFER
STRLUP,	TAD I	XR1	/GET A CHAR
	AND	O77	/MASK TO 6BIT
	TAD	(-40	/CROCK TO DELETE BLANKS
	SZA
	JMP	.+3
	ISZ	SACLEN	/IGNORE THE BLANK
	JMP	.+3
	TAD	(40
	DCA I	SACXR	/STORE IN SAC
	ISZ	TEMP2
	JMP	STRLUP	/LOOP FOR MORE
	JMP I	(SSMODE	/DONE-RETURN IN SMODE

/VAL FUNCTION
/RETURNS NUMBER IN FAC FOR STRING IN SAC

VAL,	TAD	SACLEN
	DCA	VALCNT	/COUNT OF CHARS TO INPUT
	TAD	(VALGET	/ADDR OF PHONY INPUT ROUTINE
	DCA I	(IGETCH	/PUT IN INPUT ROUTINE IN PLACE OF KRB
	JMS I	(FFIN	/CALL FPP INPUT ROUTINE
	TAD	PGETCH	/NOW RESTORE REAL INPUT ADDR
	DCA I	(IGETCH	/RESTORE IN INPUT ROUTINE
	JMP I	PILOOP	/DONE

VALGET,	0
	TAD	VALCNT	/TEST NUMBER OF CHARS LEFT
	SNA CLA
	JMP	EOVAL	/NONE
	ISZ	VALCNT	/ELSE BUMP
	NOP
	TAD I	SACXR	/GET A BYTE
	TAD	(240
	AND	O77
	TAD	(240	/CONVERT TO 8BIT
	SKP
EOVAL,	TAD	O215
	DCA	CHAR
	JMP I	VALGET	/RETURN WITH CHAR IN 'CHAR'

VALCNT,	0

	PAGE
/	DATE FUNCTION
/	RETURNS STRING OF THE FORM "MM/DD/YY" IN SAC IF DATE IS PRESENT
/	RETURNS NULL STRING OTHERWISE


DATE,	TAD	CDFIO	/COPY CDF TO FIELD 17600 IN LINE
	DCA	.+1
YEAREX,	0
	TAD	PSFLAG	/GET TD8E BIT TO LINK
	CLL RAL
	SNL CLA
	TAD I	(MDATE	/IF ZERO LOOK AT MDATE IN N7600
	SZL
	TAD I	(MDATE-200 /ELSE LOOK AT N7400
	DCA	DATEWD	/STORE (DATE IS NOT A CLOSED SUBROUTINE)
	CDF		/DATE IS IN THE FORM MMM MDD DDD YYY
	TAD	DATEWD	/PICK UP DATE
	SZA CLA
	TAD	(-10	/RETURN 8. BYTES IF NOT NULL DATE
	DCA	SACLEN	/SET SAC LENGTH
	TAD I	(BIPCCL	/NOW GET YEAR EXTENSION
	AND	(600	/IT'S IN THE 600 BITS
	CLL RTR
	RTR		/SHIFT INTO PLACE
	DCA	YEAREX	/HOLD YEAR EXTENSION
	TAD	DATEWD	/NOW ISOLATE MONTH
	AND	O7400
	CLL RTL
	RTL
	RAL
	JMS	PUTN	/PUT "MM/" INTO THE SAC
	TAD	DATEWD	/NOW GET DAY OF MONTH
	AND	(370
	CLL RTR
	RAR
	JMS	PUTN	/PUT "DD/" IN SAC
	TAD	DATEWD	/FINALLY GET YEAR
	AND	(7
	TAD	YEAREX	/ADD TO EXTENSION BITS
	TAD	(106	/ADD 70. FOR BASE YEAR
	JMS	PUTN	/PUT OUT "YY/" (EXTRA SLASH WILL BE IGNORED)
	JMP I	(SSMODE	/RETURN IN STRING MODE

PUTN,	0
	ISZ	NHIGH	/BUMP HIGH ORDER DIGIT
	TAD	(-12	/-10.
	SMA
	JMP	.-3	/LOOP IF NOT REDUCED YET
	TAD	(12+60	/CONVERT TO DECIMAL DIGIT
	DCA	NLOW	/HOLD MOMENTARILY
	TAD	NHIGH	/NOW GET HI ORDER DIGIT
	TAD	(57	/MAKE 6BIT
	DCA I	SACXR
	TAD	NLOW	/SEND OUT LOW DIGIT
	DCA I	SACXR
	TAD	(57
	DCA I	SACXR	/SEND OUT "/"
	DCA	NHIGH	/CLEAR NHIGH FOR NEXT TIME (BE CAREFULL!!)
	JMP I	PUTN
NHIGH,	0
NLOW,	0
DATEWD,	0
/TRACE FUNCTION PRINTER. WHEN TRACE IS ENABLED,THIS ROUTINE
/PRINTS THE LINE # EACH TIME IT IS STORED

TPRINT,	JMS I	(LMAKE	/MAKE LINE # INTO FIVE DIGITS
	TAD	("%
	JMS I	PXPUTCH	/PRINT "%"
	TAD	(" 
	JMS I	PXPUTCH	/PRINT A SPACE
	TAD	(DIG1-1	/ADDR OF FIRST DIGIT-1
	DCA	XR5		/IN XR5
IGS,	TAD I	XR5	/GET DIGIT OF LINE NUMBER
	DCA	TCHR	/SAVE IT
	TAD	(-"0
	TAD	TCHR	/COMPARE IT TO 0
	SNA CLA		/IS IT A 0?
	JMP	IGS	/YES-IGNORE LEADING ZEROES
PREST,	TAD	TCHR	/NO-GET CHAR AGAIN
	TAD	M215
	SNA CLA		/IS IT A CR?
	JMP	TDONE	/YES-LINE NUMBER IS PRINTED
	TAD	TCHR	/NO-GET CHAR A THIRD TIME
	JMS I	PXPUTCH	/TYPE IT
	TAD I	XR5	/GET NEXT CHAR
	DCA	TCHR
	JMP	PREST	/AND LOOP
TDONE,	TAD	(" 
	JMS I	PXPUTCH	/FOLLOW LINE # WITH A SPACE
	TAD	("%
	JMS I	PXPUTCH	/TYPE ANOTHER "%"
	TAD	(215
	JMS I	PXPUTCH	/TYPE,CR,LF
	TAD	(212
	JMS I	PXPUTCH
	JMS I	PXPRINT	/EMPTY RING BUFFER OF TRACE NUMBER
	JMP	.-1
	JMP I	PILOOP	/DONE
TCHR,	0

	PAGE
/TRACE FUNCTION-ROUTINE TO TURN TRACE ON AND OFF

TRACE,	TAD	ACH	/GET HI MANTISSA OF ARG
	SNA CLA		/SKP TO TURN TRACE ON
	TAD	TRREST	/ELSE RESTORE TRACE BYPASS INSTR IN LINE NUMBER ROUTINE
	DCA I	HOOKL	/BY NOP ING INSTRUCTION AT TRHOOK
TRREST,	JMP I	PILOOP

HOOKL,	TRHOOK

/ERROR ROUTINE

ERRORR,	JMS I	PXPRINT	/PURGE TTY RING BUFFER
	JMP	.-1	/BEFORE PRINTING ERROR
	TAD	ETABA	/ADDR OF ERROR TABLE
	DCA	XR4		/POINTS INTO ERROR TABLE
FERRLP,	TAD I	XR4	/GET 2 CHAR ERROR CODE
	DCA	TEMP1	/SAVE
	TAD	TEMP1
	CLL RTR
	RTR
	RTR
	AND	O77	/STRIP TO 6 BIT
	TAD	K0300	/MAKE 8 BIT (LETTERS ONLY ALLOWED)
	DCA	ESTRNG	/PUT IN MESSAGE
	TAD	TEMP1	/2 CHAR CODE AGAIN
	AND	O77	/SECOND CHAR
	TAD	K0300	/MAKE LETTER
	DCA	ESTRNG+1	/PUT IN MESSAGE
	TAD I	XR4	/GET ERROR CODE +1
	TAD I	PERROR	/COMPARE AGAINST RETURN ADDR
	SZA CLA		/MATCH?
	JMP	FERRLP	/NO-TRY NEXT ONE
	JMS	LMAKE	/MAKE THE LINE # INTO DECIMAL DIGITS
	TAD	ESTRA	/ADDR OF MESSAGE
	DCA	XR5
ETLOP,	TAD I	XR5	/GET MESSAGE CHAR
	SPA		/DONE? (MESSAGE ENDNS WITH - NUMBER
	JMP	FATCHK	/YES-DETERMINE ERROR TYPE
	JMS I	PXPUTCH	/NO-PUT CHAR IN RING BUFFER
	JMP	ETLOP

FATCHK,	CLA
	TAD	MFATAL	/-ADDR OF FATAL ERRORS
	TAD	XR4		/ADDR OF THIS ERROR
	SMA CLA		/FATAL ERROR?
	JMP I	ERRETN	/NO-NEXT INST
	JMP I	STOPI	/YES-TERMINATE RUN

ERRETN,	XERRRET
STOPI,	FSTOPN

MAKED,	0
	AND	O17	/ISOLATE BCD DIGIT
	TAD	K260	/MAKE ASCII DIGIT
	JMP I	MAKED

K260,	260
K0300,	300
/SUBROUTINE LMAKE-MAKES THE CURRENT LINE NUMBER INTO FIVE DIGITS
/STARTING AT DIG1

LMAKE,	0
	TAD	LINEHI	/YES:GET HI LINE #
	JMS	MAKED	/GET DIGIT 2
	DCA	DIG2	/PUT IN MESSAGE
	TAD	LINEHI
	CLL RTR
	RTR
	JMS	MAKED	/GET DIGIT 1
	DCA	DIG1	/AND PUT IN MESSAGE
	TAD	LINELO	/DOGOTS 3,4, AND 5
	JMS	MAKED	/GET DIGIT 5
	DCA	DIG5
	TAD	LINELO
	CLL RTR
	RTR
	JMS	MAKED	/GET DIGIT 4
	DCA	DIG4	/AND PUT IN MESSAGE
	TAD	LINELO
	CLL RAL
	RTL
	RTL
	JMS	MAKED	/GET DIGIT 3
	DCA	DIG3	/MESSAGE NOW COMPLETE
	JMP I	LMAKE
/ERROR MESSAGE

EMESS,	215
	212
ESTRNG,	0000
	0000
	" 
	"A
	"T
	" 
	"L
	"I
	"N
	"E
	" 
DIG1,	0
DIG2,	0
DIG3,	0
DIG4,	0
DIG5,	0
	215
	212
ESTRA,	EMESS-1		/MINUS NUMBER TO END ABOVE MESSAGE
/ERROR TABLE
/ENTRY FORMAT-   2 CHAR 6-BIT ERROR CODE (LETTERS ONLY)
/		-(ADDR OF CALL)-1

ETABA,	ETAB-1		
MFATAL,	-EFATAL
ETAB,	0602		/FB
	-FB-1		/ATTEMPT TO OPEN AN ALREADY OPEN FILE
	0722		/GR
	-GR-1		/RETURN WITHOUT A GOSUB
	2622		/VR
	-VR-1		/ATTEMPT TO READ VARIABLE LENGTH FILE
	2325		/SU
	-SU-1		/SUBSCRIPT ERROR
	0405		/DE
	-DE-1		/DEVICE DRIVER ERROR
	1705		/OE
	-OE-1		/DRIVER ERROR WHILE OVERLAYING
	0615		/FM
	-FM-1		/ATTEMPT TO FIX MINUS NUMBER
	0617		/FO
	-FO-1		/ATTEMPT TO FIX NUMBER >4095
	0616		/FN
	-FN-1		/ILLEGAL FILE #
	2303		/SC
	-SC-1		/ATTEMPT TO OVERFLOW SAC ON CONCATENATE
	0611		/FI
	-FI-1		/ATTEMPT TO CLOSE OR USE UNOPENED FILE
	0401		/DA
	-DA-1		/ATTEMPT TO READ PAST END OF DATA LIST
	0723		/GS
	-GS-1		/TOO MANY NESTED GOSUBS
	2322		/SR
	-SR-1		/ATTEMPT TO READ STRING FROM NUMERIC FILE
	2327		/SW
	-SW-1		/ATTEMPT TO WRITE STRING INTO NUMERIC FILE
	2001		/PA
	-PA-1		/ILLEGAL ARG IN POS
	0603		/FC
	-FC-1		/OS/8 ERROR WHILE CLOSING TENTATIVE FILE
	0311		/CI
	-CI-1		/INQUIRE FAILURE IN CHAIN
	0314		/CL
	-CL-1		/LOOKUP FAILURE IN CHAIN
	1116		/IN
	-IN-1		/INQUIRE FAILURE IN OPEN
	0417		/DO
	-DO-1		/NO MORE ROOM FOR DRIVERS
	0605		/FE
	-FE-1		/FETCH ERROR IN OPEN
	0217		/BO
	-BO-1		/NO MORE FILE BUFFERS AVAILABLE
	0516		/EN
	-EN-1		/ENTER ERROR IN OPEN
	1106		/IF
	-IF-1		/ILLEGAL DEV:FILENAME SPECIFICATION
	2314		/SL
	-SL-1		/STRING TOO LONG OR UNDEFINED
	1726		/OV
	-O0-1		/NUMERIC OR INPUT OVERFLOW
	1415		/LM
	-LM-1		/ATTEMPT TO TAKE LOG OF NEG # OR 0
	0515		/EM
	-EM-1		/ATTEMPT TO EXPONENTIATE A NEG NUMBER TO A REAL ROWER
	1101		/IA
	-IA-1		/ILLEGAL ARGUMENT IN USER FUNCTION
	0330		/CX
	-CX-1		/ILLEGAL FILENAME EXTENSION IN A CHAIN STATEMENT
/***********************************************************
EFATAL,			/ERRORS BEFORE THIS LABEL ARE FATAL
/*******************************************************
	2205		/RE
	-RE-1		/ATTEMPT TO READ PAST EOF
	2705		/WE
	-WE-1		/ATTEMPT TO WRITE PAST EOF
	0426		/DV
	-DV-1		/ATTEMPT TO DIVIDE BY 0
	2324		/ST
	-ST-1		/STRING TRUNCATION ON INPUT
	1117		/IO
	-IO-1		/TTY INPUT BUFFER OVERFLOW
	T=	.
	*ETAB
	*T
/SEG$ FUNCTION
/RETURNS SEGMENT OF X$ BETWEEN Y AND Z
/IF Y<=0,THEN Y TAKEN AS 1
/IF Y>LEN(X$),NULL STRING RETURNED
/IF Z<=0,NULL STRING RETURNED
/IF Z>LEN(X$),Z IS SET=LEN(X$)
/IF Z<Y,NULL STRING IS RETURNED

SEG,	CLA IAC
	DCA	MODESW	/RETURN IN STRING MODE
	TAD	ACH	/IS Y>0?
	SMA SZA CLA
	JMS I	PUNSFIX	/FIX IF POSITIVE
	SNA
	IAC		/SET Y TO 1 IF Y.LE.0
	DCA	YARG
	TAD	SACLEN	/COMPARE YARG TO SACLEN
	CIA
	STL CIA
	TAD	YARG
	SNL SZA CLA	/SKP IF YARG.LOS.LEN(X$)
	JMP	NULLST	/NO-RETURN THE NULL STRING
	DCA	INSAV	/FAKE POINTER TO SCALAR #0
	JMS I	ARGPLK	/GET ADDR OF Z
	JMS I	PFFGET	/LOAD Z INTO FAC
ARGPLK,	ARGPRE		/LOC SKIPPED BY FPP SO WE PUT CONST HERE
	TAD	ACH	/HI MANTISSA OF Z
	SPA SNA CLA	/IS Z<0?
	JMP	NULLST	/YES-RETURN THE NULL STRING
	JMS I	PUNSFIX	/NO-FIX Z
	STL
	TAD	SACLEN	/CALC Z-LEN(SAC)
	SNL		/SKP IF Z.LO.LEN(SAC)
	CLA		/ELSE TAKE LEN(SAC)
	CMA
	TAD	SACLEN
	TAD	YARG	/NUMBER OF BYTES TO USE
	SMA
	JMP	NULLST	/NONE, RETURN NULL STRING
	DCA	STRCNT
	TAD	YARG	/INDEX INTO STRING FOR SOURCE BYTES
	TAD	(SAC-2
	DCA	XR2	/SET SOURCE XR
	TAD	STRCNT
	DCA	SACLEN	/SET NEW LENGTH OF SAC NOW
	TAD I	XR2	/NOW MOVE THE BYTES
	DCA I	SACXR
	ISZ	STRCNT
	JMP	.-3
	JMP I	PILOOP	/--RETURN--
NULLST,	CLA CLL
	DCA	SACLEN	/ZERO SAC
	JMP I	PILOOP	/--RETURN--
YARG,	0

	PAGE
	/POS FUNCTION
	/RETURNS THE POSITION IN X$ OF Y$ STARTING AFTER Z

POS,	CLA CLL
	DCA	INSAV	/FAKE AS STRING CALL TO STRING 0
	JMS I	(STFIND	/FIND Y$
	TAD	STRCNT	/# OF CHARS IN Y$
	SNA CLA		/IS Y$ THE NULL STRING?
	JMP	ONERET	/YES-RETURN 1 AS POSITION
	TAD	SACLEN	/NO-# OF CHARS IN X$
	SNA CLA		/IS X$ THE NULL STRING?
	JMP	ZRORET	/YES-RETURN 0
	TAD	ACH	/NO-GET HORD OF Z
	SPA SNA CLA	/IS Z GT 0?
PA,	JMS I	PERROR	/NO-ILLEGAL ARGUMENT
	JMS I	PUNSFIX	/FIX Z
	DCA	POSITN	/USE IT AS POSITION TO START SEARCH
	TAD	POSITN
	STL
	TAD	SACLEN	/COMPARE POSITION TO MAXIMUM LENGTH OF STRING
	SNL SZA CLA
	JMP	PA	/Z IS PAST END OF STRING-ERROR
POSSET,	TAD	STRCNT
	CMA
	TAD	POSITN	/GET POSITION NOW CHECKING+SIZE IF Y$
	TAD	SACLEN	/COMPARE AGAINST LENGTH OF STRING
	SMA SZA CLA	/ANY MORE TO COME?
	JMP	ZRORET	/NO-SEARCH FAILS
	JMS I	(BYTSET	/SETUP BYTE LOAD ROUTINE
	TAD	POSITN	/SEARCH START POSITION IN X$
	TAD	(SAC-2	/ADD TO BASE OF SAC
	DCA	SACXR
	TAD	STRCNT	/# OF CHARS IN Y$
	DCA	TEMP3	/COUNTER
SRCLP,	JMS I	(LDB
	CIA
	TAD I	SACXR	/COMPARE CHARS
	SNA CLA		/DO THEY MATCH?
	JMP	SCONTU	/YES-CONTINUE MATCH TO NEXT CHAR IN X$ AND Y$
	ISZ	POSITN	/BUMP POSITION TO BE CHECKED
	JMP	POSSET	/ITERATE

SCONTU,	ISZ	TEMP3	/MORE CHARS IN Y$?
	JMP	SRCLP	/YES, ITERATE
	TAD	POSITN	/NO FOUND A MATCH
	JMP I	(FLOATS
ZRORET,	JMS I	PFACCLR	/SEARCH FAILS-RETURN 0
	JMP I	PILOOP

ONERET,	CLA IAC
	JMP I	(FLOATS	/RETURN 1
POSITN,	0

	PAGE
	RELOC

//////////////////////////////////////////////////
//////////////////////////////////////////////////
///////// OVERLAY 3-FILE MANIPULATING ////////////
/////////     FUNCTIONS              ////////////
//////////////////////////////////////////////////
//////////////////////////////////////////////////

	*3400

	/FILE CLOSING ROUTINE

	VERSON^100+SUBVFF+6000	/VERSION WORD FOR FILES OVERLAY

ANDPTR,	ANDLST
ANDLST,	7776	/MASKS FOR CLEARING BUFFER AND HANDLER STATUS BITS
	7775
	7773
	7767

CLOSE,	TAD	ENTNO	/GET FILE #
	SNA CLA		/IS IT TTY?
	JMP I	PILOOP	/YES-DON'T DO ANYTHING
	JMS I	PIDLE	/SEE IF FILE OPEN
	JMS I	PFTYPE	/IS FILE NUMERIC?
	JMP	NOCZ	/YES-DON'T OUTPUT ^Z
	JMS I	(FOTYPE	/NO-IS FILE VARIABLE LENGTH?
	JMP	NOCZ	/NO-DON'T OUTPUT ^Z
	TAD	(232	/YES
	JMS I	PPUTCH	/WRITE A ^Z IN FILE
NOCZ,	JMS I	(WRBLK	/WRITE LAST BLOCK IF IT HAS CHANGED
	JMS I	PPSWAP	/RESTORE 17600
	JMS I	(FOTYPE	/IS FILE FIXED LENGTH?
	JMP	CLOSED	/YES-NO NEED TO CLOSE THE FILE
	TAD I	IOTLEN	/NO-GET FILE LENGTH
	DCA	CLENG	/PUT IN CLOSE CALL
	TAD	IOTFIL
	DCA	FNAP	/POINTER TO FILE NAME
	TAD I	IOTHDR
	CLL RTL
	RTL
	RAL		/GET DEVICE NUMBER INTO BITS 8-11
	AND	O17	/ISOLATE IT
	CIF 10
	JMS I	O7700	/CALL USR
	4		/CLOSE
FNAP,	.		/POINTER TO FILE NAME
CLENG,	.
FC,	JMS I	PERROR	/FILE CLOSING ERROR
CLOSED,	TAD I	IOTBUF	/GET BUFFER ADDRESS
	CLL RTL
	RTL		/BUFFER NUMBER INTO AC
	RAL		/BITS 10,11
	AND	(3	/STRIP
	TAD	ANDPTR	/USE AS INDEX INTO MASKS
	DCA	TEMP1
	TAD	BMAP	/BUFFER STATUS MAP
	AND I	TEMP1	/CLEAR THE BIT FOR THIS BUFFER
	DCA	BMAP
	TAD I	IOTHDR	/HEADER WORD
	AND	O7400	/STRIP HEADER TO DEVICE # ONLY
	DCA I	IOTHDR
	TAD	MM4		/-4
	DCA	TEMP3	/USE AS COUNTER
CHECKL,	TAD	TEMP3	/GET 3 OF FILE TO CHECK
	TAD	(W0PTR	/MAKE POINTER TO PROPER W0 HEADER
	DCA	TEMP1	/SAVE POINTER
	TAD	TEMP3	/-# OF FILE WERE CHECKING
	TAD	ENTNO	/COMPARE TO CURRENT NUMBER
	SNA CLA		/IS IT THIS ONE?
	JMP	PSTCHK	/YES-DON'T CHECK DRIVER
	TAD I	TEMP1	/GET HEADER WORD FOR THE FILE OF INTEREST
	AND	O7400	/ISOLATE DEVICE #
	CIA		/NEGATE
	TAD I	IOTHDR	/COMPARE TO CURRENT DEVICE #
	SNA CLA		/SAME DEVICE?
	JMP	CRETN	/YES-LEAVE DRIVER IN CORE
PSTCHK,	ISZ	TEMP3	/ALL 4 CHECKED?
	JMP	CHECKL	/NO-CHECK THE NEXT 1
	TAD I	IOTHDR
	AND	O10	/GET HANDLER LENGTH BIT
	SZA CLA		/TWO PAGES?
	JMP	TPREL	/YES-FREE BOTH PAGES
	TAD I	IOTHND	/THIS IS THE ONLY FILE USING HANDLER THEN
	CLL RTL
	RTL		/SLIDE BITS 4,5 OF HANDLER PAGE TO AC BITS 10,11
	RAL
	AND	(3	/ISOLATE HANDLER BUFFER NUMBER
	TAD	ANDPTR	/MAKE POINTER TO PROPER AND MASK
RELCOM,	DCA	TEMP1
	TAD	DMAP	/DRIVER PAGE MAP
	AND I	TEMP1	/CLEAR HANDLER PAGE BIT
	DCA	DMAP
CRETN,	DCA I	IOTHND	/SET FILE AS IDLE
	JMS I	PPSWAP	/GET RID OF 17600 AGAIN
	JMP I	PILOOP	/DONE

TPREL,	TAD I	IOTHND	/ONLY FILE USING HANDLER
	CLL RTL
	RTL		/ISOLATE HANDLER BUFFER NUMBER
	RAL
	AND	(3
	TAD	(ANDLS2	/USE AS INDEX TO AND MASK
	JMP	RELCOM

W0PTR,	FILE1
	FILE2		/FILE TABLE ENTRIES
	FILE3
	FILE4

MM4,
ANDLS2,	7774
	7701

/CODE TO READ IN COMPILER AND START IT
/THIS CODE GETS MOVED TO FIELD 1 AND EXECUTED FROM 
/LOC 2001-2013 IN FIELD 1

CREAD,	CDF 10
	CIF 0
	4613		/"JMS I L7607K"
	3700		/31 PAGES
	0		/0-7577
CBLK,	7617		/STARTING BLOCK OF COMPILER
	HLT		/SYSTEM ERROR,AND SINCE WE ARE PROBABLY CLOBBERED,WE CAN'T REPORT IT
	CIF 0
	5612		/"JMP I .+1"-START THE COMPILER
	7001		/STARTING ADDR OF COMPILER
K7607K,	7607
			/LESS THAN THE DESIRED VALUE

EXTCHK,	0		/SKIP RETURN IF CURRENT
	AC0002
	IAC
	TAD	IOTFIL	/IS .SV
	DCA	EXTEMP	/JUST A TEMP
	TAD I	EXTEMP	/GET EXTENSION
	TAD	(-2326
	SNA CLA		/IS IT .SV?
	ISZ	EXTCHK	/YES: SKIP
	JMP I	EXTCHK
EXTEMP,	0

	PAGE
/CHAIN FUNCTION
/SETS UP COMMAND DECODER AREA,THEN CHAINS TO BCOMP.SV

CHAIN,	JMS I	PXPRINT	/EMPTY TTY RING BUFFER
	JMP	.-1
	JMS I	PPSWAP	/RESTORE PG 17600
	JMS I	DNA2	/GET FILE NAME IN NAME AREA FROM CURRENT FILE
	CIF 10
	JMS I	O7700	/CALL USR
	10		/LOCK IN CORE
	TAD I	IOTDEV
	DCA	DNA1	/FIRST TWO CHARS OF DEV NAME
	TAD I	IOTDEV+1 /LAST TWO CHARS
	DCA	DNA2
	CIF 10
	JMS I	USR
	12		/INQUIRE
DNA1,	0		/DEVICE NAME
DNA2,	NAMEG
CDIN,	0
CI,	JMS I	PERROR	/ERROR
	TAD	CDIN	/GET ENTRY POINT OF DRIVER FOR CHAIN FILE
	SZA CLA		/IS IT IN CORE?
	JMP	DISIN	/YES-NO NEED TO FETCH IT
	TAD	DNA2	/NO-DEVICE # INTO AC
	CIF 10
	JMS I	USR
	1		/FETCH HANDLER
	7001		/INTO PAGE 7000
	JMP	CI	/MAKE IT LOOK LIKE INQUIRE ERROR
DISIN,	TAD	IOTFIL
	DCA	STB	/POINTER TO FILE NAME
	TAD	DNA2	/GET DEVICE #
	CIF 10
	JMS I	USR
	2		/LOOKUP
STB,	0		/POINTER TO FILE NAME
FLN,	0
CL,	JMS I	PERROR	/LOOKUP ERROR
	TAD	STB	/GET STARTING BLOCK
	CDF 10
	DCA I	(7620	/STARTING BLOCK IN CD AREA
	TAD	FLN	/FILE LENGTH
	CLL RTL
	RTL
	AND	(7760	/PUT IN BITS 0-7
	TAD	DNA2	/COMBINE WITH DEVICE #
	DCA I	(7617	/PUT IN CD AREA
	TAD	O100	/SET R SWITCH
	DCA I	(7644
	TAD I	(7605	/STARTING BLOCK OF COMPILER
	SNA		/(IS THIS A CORE IMAGE?
	JMP	CICHAIN	/YES: HANDLE SOMEWHAT DIFFERENTLY
	CDF
	DCA I	(CBLK	/INTO COMPILER READ CODE
	CDF
	JMS I	(EXTCHK	/SKP IF EXTENSION .SV
	SKP
	JMP	CX	/ERROR IF IT IS
	JMS I	(PSWAP2	/NOW EXEC DESTRUCTIVE EXIT CODE
	CDF	10
	JMP I	(CSMOVE	/MOVE THE COMPILER READ TO FIELD 1 AND EXECUTE IT

CICHAIN,CDF
	JMS I	(EXTCHK	/SKP IF EXTENSION IS .SV
CX,	JMS I	PERROR	/ERROR IF NOT
	JMS I	(PSWAP2	/NOW EXEC ONCE ONLY CLEAN UP ROUTINE
	TAD	STB
	DCA	CHNSTB
	CIF	10	/NOW DO A RESET AND DELETE TENTATIVE FILES
	JMS I	USR
	13		/RESET
	CIF 10		/FLAG TENTATIVE FILE CLEANUP
	JMS I	USR
	6
CHNSTB,	HLT
	/FILE LOOKUP

FLOOK,	AC0002
	JMS I	(ENTLOK	/LOOKUP
	DCA I	IOTLEN	/ACTUAL LENGTH
	TAD I	IOTLEN
	DCA I	IOTMAX	/ALSO EQUALS MAXIMUM LENGTH
CLEANP,	DCA I	IOTPOS	/ZERO COLUMN POINTER
	CMA		/-1
	TAD I	IOTLOC	/STARTING BLOCK-1
	DCA I	IOTBLK	/CURRENT BLOCK #=STARTING BLOCK-1
	TAD I	IOTBUF
	DCA I	IOTPTR	/READ/WRITE POINTER AT BEGINNING OF BUFFER
	CIF 10
	JMS I	USR	/CALL TO USR
	11		/USROUT
	JMS I	PPSWAP	/GET RID OF 17600
	JMS I	(BLZERO
	JMS I	(NEXREC	/DO A NEXREC TO READ IN FIRST FILE BLOCK
	JMP I	PILOOP	/DONE

	/ROUTINE FOR INTERPRETER EXIT

FSTOP,	KSF		/IS THE KEYBOARD FLAG SET?
	JMP	NOCTC	/NO-THERE IS NO CHANGE ^C SENT US HERE
	TAD	O200	/YES-FORCE PARITY BIT
	KRB		/GET CHARACTER
	TAD	(-203	/COMPARE AGAINST ^C
	SZA CLA		/WAS IT ^C?
	JMP	NOCTC	/NO-THIS IS A NORMAL EXIT
	TSF
	JMP	.-1
	TAD	("^	/YES -ECHO ^
	TLS
	CLA
	TSF
	JMP	.-1
	TAD	("C	/ECHO "C"
	TLS
NOCTC,	TSF
	JMP	.-1
	JMP I	(MEXIT

	PAGE
	/FILE OPENING ROUTINE

OPENAV,	TAD	(4	/ALPHANUMERIC,VARIABLE LENGTH
OPENAF,	IAC		/ALPHANUMERIC,FIXED LENGTH
	JMP	OPENNF
OPENNV,	TAD	(4		/NUMERIC,VARIABLE LENGTH
OPENNF,	DCA I	IOTHDR	/SET UP HEADER WORD
	TAD	ENTNO	/IS FILE TTY?
	SNA CLA
	JMP I	PILOOP	/YES-DON'T DO ANYTHING
	TAD I	IOTHND	/GET HANDLER ENTRY
	SZA CLA		/IS FILE IDLE?
FB,	JMS I	PERROR	/ATTEMPT TO OPEN FILE ALREADY OPEN
	JMS I	PPSWAP	/RESTORE 17600
	JMS I	(NAMEG	/GET FILE DEVICE NAME AND FILE NAME INTO WORDS 7-14 FROM SAC
	CIF 10
	JMS I	O7700	/CALL TO USR
	10		/LOCK USR IN CORE
	TAD I	IOTDEV
	DCA	DEVNA1	/DEVICE NAME INTO INQUIRE CALL
	TAD I	IOTDEV+1
	DCA	DEVNA2
	CIF 10
	JMS I	USR	/CALL TO USR
	12		/INQUIRE
DEVNA1,	.		/DEVICE NAME
DEVNA2,	.
ENTRYN,	0		/ENTRY POINT
IN,	JMS I	PERROR	/INQUIRE ERROR
	TAD	DEVNA2	/GET DEVICE #
	CLL RAR
	RTR		/PUT INTO BITS 0-3
	RTR
	TAD I	IOTHDR
	DCA I	IOTHDR	/STORE IN HEADER WORD
	TAD	ENTRYN	/GET DRIVER ADDRESS
	SZA		/IS IT IN CORE?
	JMP I	(DRIVRN	/YES-NO NEED TO FETCH IT
	TAD	DMAP	/NO-GET MAP OF DRIVER PAGES
	CLL RAR		/PAGE 7000 BIT IN LINK
	SNL		/IS PAGE 7000 FREE?
	JMP	FREE70	/YES
	CLL RAR		/NO-7200 BIT TO LINK
	SNL		/IS PAGE 7200 FREE?
	JMP	FREE72	/YES
	CLL RAR		/NO-7400 BIT TO LINK
	SZL CLA		/IS PAGE 7400 FREE?
DO,	JMS I	PERROR	/NO-NO MORE ROOM FOR DRIVERS
	TAD	O7400	/YES-LOAD HANDLER INTO 7400
	DCA	FETPAG	/SET UP IN FETCH CALL
	TAD	(4	/SET BIT 9 TO SHOW PAGE 7400 OCCUPIED
	JMP	DFETCH	/FETCH DRIVER

FREE70,	CLL RAR		/PAGE 7200 BIT TO LINK
	SNL CLA		/IS 7200 FREE?
	IAC		/YES-THERE IS ROOM FOR A TWO PAGE HANDLER
	TAD	(7000
	DCA	FETPAG	/SET UP FETCH TO USE PAGE 7000
	CLL CLA CML RTL	/TURN ON BIT 10
	DCA	TPH	/SAVE IN TWO PAGE SET WORD
	IAC		/SET BIT 11 TO SHOW PAGE 7000 OCCUPIED
	JMP	DFETCH	/FETCH HANDLER

FREE72,	CLL RAR		/7400 BIT TO LINK
	SNL CLA		/IS 7400 PAGE FREE?
	IAC		/YES-THEN THERE IS ROOM FOR A 2 PAGE HANDLER
	TAD	(7200
	DCA	FETPAG	/SET ADDRESS IN FETCH CALL
	TAD	(4
	DCA	TPH	/IF TWO PAGE LOADED,SET BIT 9 ALSO
	AC0002		/TURN ON BIT 10 TO SHOW PAGE 7200 OCCUPIED
DFETCH,	TAD	DMAP	/TURN ON PAGE BIT FOR WHERE BUFFER WILL BE LOADED
	DCA	DMAP
	TAD	DEVNA2	/DEVICE # IN AC
	CIF 10
	JMS I	USR	/CALL TO USR
	1		/FETCH
FETPAG,	.		/DRIVER ADDRESS
FE,	JMS I	PERROR	/FETCH ERROR
	CDF 10
	CLA CMA
	TAD I	(37	/GET ADDR OF HANDLER INFO TABLE
	TAD	DEVNA2	/USE THE DEVICE # AS AN INDEX INTO THAT TABLE
	DCA	TEMP1	/SAVE POINTER
	TAD I	TEMP1	/GET THE INFO WORD FOR THE HANDLER JUST FETCHED
	CDF
	SMA CLA		/IS HANDLER 2 PAGES LONG?
	JMP	DRAP	/NO MAP IS COMPLETE
	TAD	TPH		/YES-UPDATE DRIVER MAP TO INCLUDE
	TAD	DMAP	/SECOND PAGE OF TWO PAGE HANDLERS
	DCA	DMAP
	TAD	O10
	TAD I	IOTHDR	/SET 2 PAGE BIT IN HEADER WORD
	DCA I	IOTHDR
DRAP,	TAD	FETPAG	/HANDLER ENTRY ADDRESS
	JMP I	(DRIVRN	/PAGE ESCAPE

TPH,	0
/ROUTINE TO MOVE THE COMPILER READER INTO FIELD 1 AND START IT

CSMOVE,	TAD	(CREAD-1
	DCA	XR1	/POINTES TO COMPILER STARTING CODE
	TAD	(-13
	DCA	TEMP1	/COUNTER
	TAD	(2000
	DCA	XR2	/MOVE TO LOC 2001 IN FIELD 1
	CDF
	TAD I	XR1	/GET WORD OF CODE
	CDF 10
	DCA I	XR2	/MOVE IT
	ISZ	TEMP1	/DONE?
	JMP	.-5	/NO
	CIF 10		/YES-START IT
	JMS I	(2000

	PAGE
DRIVRN,	DCA I	IOTHND	/DRIVER ENTRY INTO I/O TABLE
	TAD	BMAP	/GET BUFFER MAP
	CLL RAR		/BUFF1 BIT TO LINK
	SNL		/IS IT FREE?
	JMP	B1	/YES-ASSIGN BUFF1
	RAR		/BUFF2 BIT TO LINK
	SNL		/IS IT FREE?
	JMP	B2	/YES-ASSIGN BUFF2
	RAR		/BUFF3 BIT TO LINK
	SNL		/IS IT FREE
	JMP	B3	/YES-ASSIGN BUFF3
	RAR		/NO-BUFF4 BIT TO LINK
	SZL CLA		/IS IT FREE?
BO,	JMS I	PERROR	/NO-NO MORE BUFFERS AVAILABLE
	TAD	(1400
	DCA I	IOTBUF	/SET BUFFER ADDRESS TO 1400
	TAD	O10	/SET BUFF4 BIR IN MAP
	JMP	BUFASS

B3,	CLA
	TAD	(1000
	DCA I	IOTBUF	/SET BUFFER ADDRESS TO 1000
	TAD	(4
	JMP	BUFASS	/SET BUFF3 BIT IN MAP

B2,	CLA
	TAD	O400
	DCA I	IOTBUF	/SET BUFF ADDRESS TO 400
	CLL CML CLA RTL	/SET BUFF2 BIT IN MAP
	JMP	BUFASS

B1,	CLA
	DCA I	IOTBUF	/SET BUFF ADDRESS TO 0000
	CLA IAC		/TURN ON BUFF1 BIT IN MAP
BUFASS,	TAD	BMAP
	DCA	BMAP	/UPDATE BUFFER ASSIGNMENT MAP
	TAD I	IOTHDR	/GET HEADER WORD
	CLL RTR
	RAR		/FIXED,VARIABLE BIT TO LINK
	SNL CLA		/IS IT FIXED?
	JMP I	(FLOOK	/YES-DO A LOOKUP
	TAD	(3		/NO-DO AN ENTER
	JMS	ENTLOK	/ENTER
	DCA I	IOTMAX	/MAXIMUM LENGTH IN WORD 7
	DCA I	IOTLEN	/ZERO ACTUAL LENGTH
	JMP I	(CLEANP	/FINALIZE I/O TABLE ENTRY

MEXIT,	CLA
	JMS I	PPSWAP
	JMS I	(PSWAP2	/RESTORE PG 27600
	CDF 10
	TAD I	(EDBLK	/GET BLOCK # FOR EDITOR
	CDF
	SNA		/SHALL WE CALL THE EDITOR?
	JMP I	(7600	/NOkJUST CALL OS/8
	DCA	EBLK	/YES-PUT THE BLOCK # IN DRIVER CALL
	JMS I	(7607	/CALL SYS DRIVER
	2100		/READ 8 BLOCKS
	0		/INTO 0-3377
EBLK,	.		/BLOCK # OF EDITOR
	HLT		/SYS ERROR,AND SINCE WE ARE PROBABLY CLOBBERED,WE CAN'T REPORT IT
	JMP I	.+1	/START THE EDITOR
	3212
ENTLOK,	0
	DCA	FNOM	/FUNCTION NUMBER IN PLACE
	TAD	IOTFIL	/POINTER TO FILE NAME
	DCA	STARTB	/INTO CALL
	TAD I	(DEVNA2	/DEVICE NUMBER
	CIF 10
	JMS I	USR	/CALL TO USR
FNOM,	.		/ENTER OR LOOKUP
STARTB,	.
FLEN,	.
EN,	JMS I	PERROR	/ENTER ERROR
	TAD	STARTB	/FILE STARTING BLOCK #
	SZA CLA		/IS IT NON-ZERO?
	JMP	FILSTU	/YES-DEVICE IS FILE STRUCTURED
	TAD	FLEN	/NO-GET FILE LENGTH
	SZA CLA		/IS IT EMPTY?
	JMP	FILSTU	/NO-DEVICE IS FILE STRUCTURED
	TAD	(20		/NO-FILE IS READ/WRITE ONLY
	TAD I	IOTHDR
	DCA I	IOTHDR	/SET READ/WRITE ONLY BIT
	TAD	FNOM
	CLL RAR
	SNL CLA
	IAC
FILSTU,	TAD	STARTB	/GET STARTING BLOCK # OF FILE
	DCA I	IOTLOC	/PUT IN I/O TABLE
	TAD	FLEN	/FILE LENGTH
	CIA		/MAKE FILE LENGTH POSITIVE
	JMP I	ENTLOK	/RETURN
/SUBROUTINE P2SWAP-RESTORE OS/8 RESIDENT MONITOR PRIOR TO EXIT FROM INTERPRETERTER
/THIS IS DESTRUCTIVE CODE,AND ONCE THIS ROUTINE HAS BEEN EXECUTED
/THERE IS NO PLACE TO GO BUT OUT.
/HAS 3 FUNCTIONS:
/        1) REMOVES CTRL/C HOOKS FROM SYS DRIVER
/        2) RESTORES BATCH CONTROL WORDS TO 27774-27777
/        3) IF SYS=TD/8E,RESTORES PAGE 27600 AND RETURNS CDFS TO PAGE 07600

PSWAP2,	0
	TAD	(4207
	DCA I	(7600	/REMOVE CTRL/C HOOKS
	TAD	(6213
	DCA I	(7605
	TAD	(7600
	DCA I	(HICORE	/FUDGE POINTER IN SWAP ROUTINE (IN CASE IT WAS TD8E)
	TAD	PSFLAG	/GET RESIDENT STATUS FLAG
	SPA CLA		/IS THIS TD8/E SYS?
	JMS I	(PSWP2P	/YES-RESTORE PAGE 27600 AND PAGE 07600
	TAD	CDFIO
	DCA	.+3	/CDF TO HI CORE
	CDF 10
	TAD I	BOSPT1	/GET BATCH WORD
	CDF 10
	DCA I	BOSPT2	/BACK INTO LOFTY STATE
	ISZ	BOSPT1
	ISZ	BOSPT2
	JMP	.-6
	CDF
	JMP I	PSWAP2	/YES-WE ARE FINISHED,SO RETURN
BOSPT1,	7600
BOSPT2,	7774

	PAGE
	/PARSE A FILENAME OF THE FORM "DEVN:FILENM.EX" IN THE SAC
	/DSK: AND A NULL EXTENSION ARE THE DEFAULTS
	/THE END OF THE SAC IS USED AS A WORK AREA
	/IF SYNTAX IS CORRECT, THE NAME IS PACKED INTO
	/THE FILENAME FIELD OF THE CURRENT FILE
	/OTHERWISE A FATAL ERROR IS RETURNED
	/ENTERED WITH OS/8 SWAPPED IN

	WKAREA=	SAC+16	/DEFINE SCRATCH AREA

NAMEG,	0
	TAD	SACLEN
	TAD	(16	/COMPARE STRING LENGTH TO 16
	SPA CLA
IF,	JMS I	PERROR	/TOO MANY CHARS IN "DEV:FILENM.EX"
	TAD	SACLEN
	DCA	TEMP2	/STRING LENGTH COUNTER
	TAD	PSACM1
	DCA	SACXR
	TAD	(DSK-1	/FIRST USE THE DEFAULT DEVICE
	JMS	DEVFUD
NCG,	TAD I	SACXR	/GET CHAR FROM SAC
	DCA	TEMP1	/SAVE
	TAD	TEMP1
	TAD	(-72	/IS IT A COLON?
	SNA
	JMP	CAD	/YES-CHARS SO FAR=DEVICE NAME
	TAD	(14	/NO-IS IT A PERIOD?
	SNA CLA
	JMP	SSAD	/YES-NEXT TWO CHARS=EXTENSION
	TAD	TEMP1	/NO-GET CHAR AGAIN
	DCA I	XR2	/STORE IN WORK AREA
	ISZ	TEMP4	/BUMP COUNT FOR CURRENT SECTION
NCGS,	ISZ	TEMP2	/END OF STRING YET?
	JMP	NCG	/NO-NEXT CHAR
	TAD	TEMP4	/YES-GET CHAR COUNT FOR THIS SECTION (NAME)
	TAD	(-6
	SMA SZA CLA	/IS IT >6?
	JMP	IF	/YES-TOO MANY CHARACTERS IN FILE NAME
	TAD	(WKAREA-1 /NO-ADDRESS OF SCRATCH NAME BLOCK
	DCA	XR1
	STA		/-1
	TAD	IOTDEV	/ADDRESS OF FINAL NAME BLOCK-1
	DCA	XR2
	TAD	(-6		/MOVE 6 WORDS
	DCA	TEMP2
MML,	TAD I	XR1
	CLL RTL
	RTL
	RTL
	TAD I	XR1
	DCA I	XR2	/MOVE NAME WORD FROM SCRATCH AREA TO FINAL DEST
	ISZ	TEMP2	/DONE?
	JMP	MML	/NO
	JMP I	NAMEG	/YES-RETURN

CAD,	TAD	TEMP4	/GET CHAR COUNT FOR THIS SECTION
	TAD	(-4	/COMPARE AGAINST 4
	SMA SZA CLA	/TOO MANY CHARS?
	JMP	IF	/YES-DEVICE NAME TOO LONG
	TAD	(WKAREA-1+4
	JMS	DEVFUD	/CLEAR BUF AND GET NAME FROM FILE FIELD THIS TIME
	JMP	NCGS

SSAD,	TAD	TEMP4	/COUNT FOR THIS SECTION (FILE NAME)
	TAD	(-6
	SMA SZA CLA	/TOO MANY?
	JMP	IF	/YES-FILE NAME TOO LONG
	DCA	TEMP4	/NO-CLEAR COUNT
	TAD	DSK
	TAD	TEMP2	/COMPARE AGAINST # OF CHARS LEFT
	SPA SNA CLA
	JMP	IF	/TOO MANY CHARS IN EXTENSION
	TAD	(WKAREA-1+12
	DCA	XR2
	JMP	NCGS

DEVFUD,	0
	DCA	XR1	/POINT AT LOC OF DEV:
	TAD	(WKAREA-1
	DCA	XR2	/POINT AT START OF WORK AREA
	TAD	(-10
	DCA	TEMP4
	TAD	(-4
	DCA	TEMP3
	TAD I	XR1	/GET A DEVICE NAME BYTE
	DCA I	XR2	/STORE IN WORK AREA DEVICE FIELD
	ISZ	TEMP3
	JMP	.-3	/ITERATE
	DCA I	XR2	/NOW CLEAR REST OF FILE NAME
	ISZ	TEMP4
	JMP	.-2	/ITERATE
	TAD	(WKAREA-1+4 /POINT XR2 AT FILENAME FIELD
	DCA	XR2
	JMP I	DEVFUD	/RETURN WITH TEMP4 CLEAR

DSK,	4;23;13;0	/6BIT DEFAULT DEVICE NAME "DSK"
/SUBROUTINE TO RESTORE PAGE 27600 OF TD8/E DRIVER
/AND READJUST THE CDFS IN FIELD 0

PSWP2P,	0
	TAD	PSFLAG
	RTL
	SNL CLA		/BIT 1 SET MEANS PHONEY TD8E
	JMP	.+3
	DCA	PSFLAG
	JMP I	PSWP2P
	DCA	PSFLAG	/CLEAR RESIDENT STATUS FLAG
	TAD	(CDF 20
	DCA I	(P2CDF	/PUT CDF 20 IN SWAP ROUTINE
	TAD	(CDF 20
	DCA I	(P2CDF1
	JMS I	PPSWAP	/MOVE DOWN PAGE 27600
//
//	NEXT 3 LINES WERE PART OF BPAT.PA
//
	JMS I	PHFIX	//
	JMP I	PSWP2P	//
PHFIX,	HFIX

//	TAD	(6223
//	DCA I	(7642
//	TAD	(6222
	DCA I	(7721
	TAD	(6222	/RESTORE CDFS IN PAGE 07600
	DCA I	(7727
	JMP I	PSWP2P	/RETURN

	PAGE



	FIELD 0














/////////////////////////////////////////////////////////////////////
/////////////////////////////////////////////////////////////////////
/////////////// END OF OVERLAY AREA /////////////////////////////////
/////////////////////////////////////////////////////////////////////
/////////////////////////////////////////////////////////////////////

	$
<:STTYF,	1+1"E0;'
J<SPRINT;R-5DI[XPRINT>
J<SSACPTR;R-6DI[SAC-1>
J<SPUTCHL;R-6DI[PUTCH>
J<SILOOPL;R-6DI[ILOOP>
J<SINTL;R-4DI[UNSFIX>
J<SCDFPSL;R-6DI[CDFPSU>
J<SERROR;R-5DI[ERRDIS>
J<SFBITS;R-5DI[FBITGT>
J<SPWFECL;R-5DI[PWFECH>
J<SMPYLNK;R-6DI[MPY>
J<SXPUT;R-4DI[XPUTCH>
J<SFIDLE;R-5DI[IDLE>
J<SDEVCAL;R-6DI[DRCALL>
J<SWRITFW;R-6DI[WRITFL>
J<SSTHINL;R-6DI[STHINI>
J<SLDHINL;R-6DI[LDHINI>
J<SSTH;R-3DI[STHL>
J<SLDH;R-3DI[LDHL>
J<SFACSAL;R-6DI[FACSAV>
J<SFACREL;R-6DI[FACRES>
J<SFGETL;R-5DI[FFGET>
J<SFPUTL;R-5DI[FFPUT>
J<SFNORL;R-5DI[FFNOR>
J<SFCLR;R-4DI[FACCLR>
J<SFNEGL;R-5DI[FFNEG>
J<SFLOATL;R-6DI[FFLOAT>
J<SGETCHL;R-6DI[GETCH>
J<SEOFSEL;R-6DI[EOFSET>
J<SBSWL;R-4DI[BSWP>
J<SPACKL;R-5DI[PACKCH>
J<SCNOCLL;R-6DI[CNOCLR>
J<SBUFCHL;R-6DI[BUFCHK>
J<SFTYPL;R-5DI[FTYPE>
J<SCHRNOL;R-6DI[CHARNO>
J<SNEXREL;R-6DI[NEXREC>
J<SCRLF;R-4DI[CRLFR>
J<SVALLK;R-5DI[VALGET>
J<SPATCHP;R-6DI[PATCHF>
J<SP1SWAP;R-6DI[PSWAP>
J<SLDHRST;R-6DI[LRESET>
J<SSTHRST;R-6DI[SRESET>
P>

