/FORTRAN IV RUNTIME SYSTEM, V5A
/
/
/
/
/
/
/
//
/
/
/
/
/COPYRIGHT (C) 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.
/
/
/
/
/
/
/FORTRAN 4 RUNTIME SYSTEM - R.LARY
/AND NOW WITH DOUBLE PRECISION! - MKH
/RTS-8 SUPPORT ADDED 5/20/74 - RL
/LAST EDITED 5/19/74

XVERSN=5		/UPDATE WITH EVERY RELEASE!
XPATCH="A		/PATCH LEVEL A

/NOTES TO MAINTAINERS:

/THIS PROGRAM IS DESIGNED TO SUPPORT MANY DIFFERENT HARDWARE
/CONFIGURATIONS IN A MINIMAL AMOUNT OF SPACE.  IT ACHIEVES THIS GOAL
/BY "TAILORING" ITSELF AT INITIALIZATION TIME
/BASED ON A SURVEY OF ITS HARDWARE/SOFTWARE ENVIRONMENT.  THIS MAKES
/THIS PROGRAM DIFFICULT TO MODIFY UNLESS THE MODIFYING PROGRAMMER
/KNOWS WHAT IS GOING ON.  IT IS THEREFORE SUGGESTED THAT YOU READ THIS
/LISTING THOROUGHLY AND UNDERSTAND THE MAJOR ROUTINES BEFORE
/MAKING EVEN "TRIVIAL" CHANGES.

/ALL SYMBOLS BEGINNING WITH THE LETTER "Q" ARE ENTRIES IN THE
/HEADER BLOCK OF THE LOADER-IMAGE (.LD) FILE.

/ALL SYMBOLS BEGINNING WITH THE LETTER "Y" DENOTE THE BEGINNING OF
/A BLOCK OF CODE WHICH WILL BE REPLACED BY DIFFERENT CODE IF FRTS
/IS RUNNING IN THE BACKGROUND UNDER RTS-8.  THE REPLACEMENT CODE
/CAN BE FOUND IN THE TABLE "BKRLST".

/ALL SYMBOLS BEGINNING WITH THE LETTER "V" ARE DEFINED IN THE LOADER
/SYMBOL TABLE AND CANNOT BE MOVED WITHOUT CHANGING THE LOADER. ONLY
/A VERY FEW OF THESE SYMBOLS OCCUR IN PLACES OTHER THAN
/PAGE 200 OR THE FIRST LOCATION OF OTHER PAGES.

/CODE WHICH CONTAINS THE CHARACTER SEQUENCE "*K*" IN THE COMMENT FIELD
/IS PARTICULARLY SUBTLE/OBSCURE (THE "K" IS FOR "KLUDGE").  THE REST OF THE
/COMMENT SHOULD INDICATE WHAT IS GOING ON.
/
/
/ FIXES FOR V4	J.K.	1975
/
/ .SCALE FACTOR PRINTED BY P FORMAT OPERATOR
/ .FRTS /P
/ .RK8E HANDLER TO RUN WITH INTERRUPTS ON
/ .SLASH AT END OF FORMAT STATEMENT
/
/
/	CHANGES FOR OS/78 AND OS/8 V3D BY P.T.
/	.CHANGED THE VERSION NUMBER TO 5A
/	.FIXED THE FIELD OVERFLOW PROBLEM
/	.FIXED THE "K=K+1" PROBLEM
/DEFINITIONS:

AC7775=	STA CLL RTL
AC7776=	STA CLL RAL
AC4000=	CLA STL RAR
AC3777=	STA CLL RAR
AC2000=	CLA STL RTR
AC0002=	CLA STL RTL

/DEFINITIONS OF KE-8/E INSTRUCTIONS

MQL=	7421
MQA=	7501
CAM=	CLA MQL
SWP=	MQA MQL
SWAB=	7431
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
SGT=	6006

/DEFINITIONS OF FPP IOT'S

FPINT=	6551
FPICL=	6552
FPCOM=	6553
FPHLT=	6554
FPST=	6555
FPRST=	6556
/FPP OPCODES:

FLDA=	0000
FADD=	1000
FSUB=	2000
FDIV=	3000
FMUL=	4000
FADDM=	5000
FSTA=	6000
FMULM=	7000
		LONG=	400	/TWO-WORD ADDRESSING
		BASE=	200	/BASEPAGE ADDRESSING
		IND=	600	/INDIRECT ADDRESSING

FEXIT=	0000
FNORM=	0004
STARTF=	0005
STARTD=	0006
JAC=	0007
XTA=	0030
STARTE=	0050
LDX=	0100

JA=	1030
JNE=	1040
TRAP3=	3000

/OS8 EQUIVALENCES:

OS8SWS=	7643
OSJSWD=	7746
OS8DVT=	7647
OS8DCB=	7760
OS8DAT=	7666

/VARIOUS OTHER IOT'S:

LSF=	6661
LCF=	6662
LSE=	6663
LIE=	6665
LLS=	6666
LIF=	6667
/PAGE ZERO FOR FORTRAN IV RTS

	*0		/INTERRUPT STUFF
	0
	JMP I	.+1
	INTRPT
LPGET,	LPBUFR		/LINE PRINTER RING BUFFER FETCH POINTER
TOCHR,	0		/TELETYPE STATUS WORD
KBDCHR,	0		/KEYBOARD INPUT CHARACTER
POCHR,	0		/P.T. PUNCH COMPLETION FLAG
RDRCHR,	0		/P.T. READER STATUS
FMTPXR,	0		/XR USED TO INDEX FORMAT PARENTHESIS ARRAY
INXR,	INBUFR-1	/XR USED TO GET CHARS FROM INPUT LINE
XR,	0
XR1,	0

*16
VEOFSW,	0		/USED BY "EOFCHK" TO STORE VARIABLE ADDRESS
	0		/*K* MUST BE IN AUTO - XR
T,	0		/TEMPORARY
DFLG,	0		/0 = F.P., 1 = D.P.
INST,	0		/CURRENT INSTRUCTION WORD

/IOH PAGE ZERO LOCATIONS

RWFLAG,	0		/READ/WRITE FLAG
FMTTYP,	0		/TYPE OF CONVERSION BEING DONE
EOLSW,	0		/EOL SW ON INPUT - CHAR POS ON OUTPUT
N,	0		/REPEAT FACTOR
W,	0		/FIELD WIDTH
D,	0		/NUMBER OF PLACES AFTER DECIMAL POINT

DATCDF,	0		/SUBROUTINE TO CHANGE DATA FIELD
DATAF,	0		/CONTAINS VARIOUS CDF'S
	JMP I	DATCDF	/RETURN

ERR,	ERROR		/POINTER TO ERROR ROUTINE
FATAL,	0		/FATAL ERROR FLAG - 0=FATAL
MCDF,	MAKCDF

/FPP PARAMETER TABLE LOCATIONS:

APT,	0		/VARIOUS FIELD BITS FOR FPP
PC,	DPTEST		/FPP PROGRAM COUNTER
XRBASE,	0		/FPP INDEX REGISTER ARRAY ADDRESS
BASADR,	0		/FPP BASE PAGE ADDRESS
ADR,	0		/ADDRESS TEMPORARY
ACX,	0
ACH,	0		/*** FLOATING ACCUMULATOR ***
ACL,	0
EAC1,	0
EAC2,	0		/** FOR EXTENDED PRECISION OPTION **
EAC3,	0
/FLOATING POINT PACKAGE LOCATIONS

AC0,	0
AC1,	0		/FLOATING AC OVERFLOW WORD
AC2,	0		/OPERAND OVFLOW WORD
OPX,	0
OPH,	0		/*** FLOATING OPERAND REGISTER ***
OPL,	0

/RTS I/O CONVERSION SYSTEM LOCATIONS

FMTBYT,	0		/FORMAT BYTE POINTER
IFLG,	0		/I FOEMAT FLAG
GFLG,	0		/G FORMAT FLAG
EFLG,	0		/E FORMAT FLAG - SOMETIMES ON FOR G FMT
OD,	0
SCALE,	0
PFACT,	0		/P-SCALE FACTOR
PFACTX,	0		/TEMP FOR PFACT
ACI,	0		/INTEGERIZED FAC FROM "FFIX" SUBR
CHCH,	0
FMTNUM,	0		/CONTAINS ACCUMULATED NUMERIC VALUE
CTCINH,	0		/^C INHIBIT FLAG
LOGUNT,	0		/DSRN POINTER - ONLY USED FROM ONE PAGE!
PTTY,	TTY		/POINTER TO TTY HANDLER - USED BY LDDSRN
	0		/ SO FORMS CONTROL WILL WORK ON UNIT 0
FPNXT,	ICYCLE		/USED AS INTERPRETER ADDRESS IF NO FPP

/DSRN IMAGE

HAND,	0		/HANDLER ENTRY POINT
HCODEW,	0		/HANDLER LOAD ADDR & FIELD + IOFFLG + FORMS CTL FLG
BADFLD,	0		/BUFFER ADDRESS AND FIELD
CHRPTR,	0		/ACTUALLY A WORD POINTER
CHRCTR,	0		/COUNTER - RANGES FROM -3 TO -1
STBLK,	0		/STARTING BLOCK OF FILE
RELBLK,	0		/CURRENT RELATIVE BLOCK NUMBER
TOTBLK,	0		/LENGTH OF FILE
FFLAGS,	0		/FILE FLAGS:
			/BIT 0 - "HAS BEEN WRITTEN" FLAG
			/BITS 1-2 - FORMATTED/UNFORMATTED FLAGS
			/BIT 11 - "END-FILED" FLAG

BUFFLD,	0		/ROUTINE TO SET DF TO BUFFER FIELD
BUFCDF,	HLT
	JMP I	BUFFLD

FADD1,	FADD+LONG	/FPP CODE TO ADD 1.0 TO FAC
	ONE		/AND FALL INTO STORE CODE
FGPBF,	0		/THESE THREE WORDS ARE USED
BIOPTR,	0		/TO FETCH AND STORE FLOATING POINT NUMBERS
	FEXIT		/FROM RANDOM MEMORY
	PAGE
/STARTUP CODE

FTEMP2,	ISZ	.+3	/ALSO USED AS I/O F.P. TEMPORARY
	CDF CIF 10
	JMP I	.+1
VDATE,	RTSLDR		/USED TO STORE OS/8 DATE

/RTS ENTRY POINTS - "VERSION INDEPENDENT"

VUERR,	JMP I	(USRERR	/USER ERROR
			/** LOADER MUST DEFINE #ARGER AS VARGER-1 **
VARGER,	JMS I	ERR	/LIBRARY ARGUMENT ERROR
VRENDO,	ISZ	RWFLAG	/END OF I/O LIST
VRFSV,	JMP I	GETLMN	/I/O LIST ARG ENTRY - COROUTINE WITH GETLMN
VBAK,	JMP I	(BKSPC	/"BACKSPACE" ROUTINE
VENDF,	JMP I	(ENDFL	/"END FILE" ROUTINE
VREW,	JMP I	(RWIND	/"REWIND" ROUTINE
VDEF,	JMP I	(DFINE	/"DEFINE FILE" ROUTINE
VWUO,	AC4000		/UNFORMATTED WRITE
VRUO,	JMP I	(RWUNF	/UNFORMATTED READ
VWDAO,	AC4000		/DIRECT ACCESS WRITE
VRDAO,	JMP I	(RWDACC	/DIRECT ACCESS READ
VWRITO,	AC4000		/FORMATTED (ASCII) WRITE
VREADO,	JMP I	(RWASCI	/FORMATTED (ASCII) READ
VSWAP,	JMP I	(SWAP	/OVERLAY PROCESSOR
VEXIT,	TRAP3;	CALXIT	/"STOP" ROUTINE - ENTERED IN FPP MODE
V8OR12,	0;0		/0;1 IF CPU IS A PDP-12
VBACKG,	JMP I	(NULLJB	/BACKGROUND JOB DISPATCHER
	0
	CDF CIF 0	/USED BY ROUTINE "ONQB" IN LIBRARY
	JMS I	.-2
	JMP	VBACKG

/IOH GET VARIABLE ROUTINE.
/THIS ROUTINE MAKES THE FORMATTED I/O PROCESSOR AND THE USER'S
/PROGRAM CO-ROUTINES (DEF(COROUTINE)= 2 ROUTINES EACH THINKING THE OTHER
/ IS A SUBROUTINE).  ON ENTRY FAC=INPUT NUMBER
/IF I/O IS A READ, ON RETURN FAC=OUTPUT NUMBER IF I/O IS A WRITE.

GETLMN,	0
VRETRN,	JMP I	[RETURN	/SHORT ROUTINE FOR ALL THOSE COMMENTS, NO?
/INTERRUPT DRIVEN I/O HANDLERS

LPT,	0		/RING-BUFFERED - LP08 OR LS8E
	AND	[377	/JUST IN CASE
LPTSNA,	SNA
	JMP I	(IOERR	/CANNOT BE USED FOR INPUT
YLPT,	IOF
	DCA I	LPPUT
	TAD	LPGET
	CIA
	TAD	LPPUT
	SZA CLA		/IS LPT QUIET?
	JMP	.+3	/NO
	TAD I	LPPUT
	LLS		/YES - START 'ER UP
	CLA IAC
	LIE		/ENABLE LPT INTERRUPTS
	TAD	LPPUT	/1 IN AC, REMEMBER?
	DCA	LPPUT
	TAD I	LPPUT
	SPA
	JMP	.-3	/NEGATIVE NUMBERS ARE BUFFER LINKS
	SZA CLA		/ANY ROOM LEFT IN BUFFER?
	JMS I	(HANG
	LPUHNG		/WAIT FOR LINE PRINTER
	ION		/TURN INTERRUPTS BACK ON
	JMP I	LPT	/RETURN

LPPUT,	LPBUFR

PTP,	0		/PAPER TAPE PUNCH HANDLER
YPTP,	SNA
	JMP I	(IOERR	/INPUT IS ERROR
	DCA	LPT	/SAVE CHAR
	IOF
	TAD	POCHR	/IF PUNCH IS NOT IDLE,
	SZA CLA		/WE DISMISS JOB
	JMS I	(HANG
	PPUHNG		/WAIT FOR PUNCH INTERRUPT
	TAD	LPT
	PLS		/OUTPUT CHAR
	DCA	POCHR	/SET FLAG NON-ZERO
	ION
	JMP I	PTP

/*K* THE FOLLOWING ADDRESSES GET FALLEN INTO & MUST BE SMALL

	IFNZRO	PPUHNG&7000	<__ERROR__>
	IFNZRO	TTUHNG&7000	<__ERROR__>
	IFNZRO	KBUHNG&7000	<__ERROR__>
	IFNZRO	RDUHNG&7000	<__ERROR__>
	IFNZRO	LPUHNG&7000	<__ERROR__>
/INTERRUPT-DRIVEN PTR AND TELETYPE HANDLER

PTR,	0		/CRUDE READER HANDLER
YPTR,	SZA CLA
	JMP I	(IOERR	/OUTPUT ILLEGAL TO PTR
	IOF
	RFC		/START READER
	JMS I	(HANG
	RDUHNG		/HANG UNTIL COMPLETE
	TAD	RDRCHR	/GET CHARACTER
	ION
	JMP I	PTR	/RETURN

TTY,	0		/BUFFERS 2 CHARS ON OUTPUT, 1 ON INPUT
YTTY,	IOF		/DELICATE CODE AHEAD
	SNA		/INPUT OR OUTPUT?
	JMP	KBD	/INPUT
	DCA	LPT	/OUTPUT - SAVE CHAR
	TAD	TOCHR	/GET TTY STATUS
	SMA SZA CLA	/G.T. 0 MEANS A CHAR IS BACKED UP
	JMS I	(HANG
	TTUHNG		/WAIT FOR LOG JAM TO CLEAR
	TAD	TOCHR	/NO CHAR BACKED UP - SEE IF TTY BUSY
	CLL RAL		/"BUSY" FLAG IN LINK - INTERRUPTS ARE OFF!
	CLA CML RAR	/COMPLEMENT OF BUSY IN SIGN
	TAD	LPT	/GET CHAR
	SPA		/IF TTY NOT BUSY,
	TLS		/OUTPUT CHAR
	DCA	TOCHR	/STORE POS OR NEG, BACKED UP OR BUSY
TTYRET,	ION		/TURN INTERRUPTS BACK ON
	JMP I	TTY	/AND LEAVE
KBD,	TAD	KBDCHR	/HAS A CHARACTER BEEN INPUT?
	SNA CLA
	JMS I	(HANG
	KBUHNG		/NO - RUN BACKGROUND UNTIL ONE IS
	TAD	KBDCHR	/GET CHARACTER
	DCA	LPT
	DCA	KBDCHR	/CHEAR CHARACTER BUFFER
	TAD	LPT
	JMP	TTYRET	/RETURN WITH INTERRUPTS ON

KILFPP,	FPHLT		/BRING FPP TO A SCREECHING HALT
	ISZ	.-1
	JMP	.-1	/WAIT FOR IT TO STOP
	FPICL		/CLEAN UP MESS HALT HAS MADE IN FPP
BEEORC,	SZL		/^C OR ^B?
	JMP I	(7600	/^C - HIYO SILVER, AWAY!
	KCC		/CLEAR KBD FLAG ON ^B
CTLBER,	JMS I	ERR	/*** THIS MAY BE DANGEROUS! **
	PAGE
/INTERRUPT SERVICE ROUTINES

INTRPT,	DCA	INTAC
	RAR
	DCA	INTLNK
VINT,	JMP	.+4	/** MUST BE AT 403 **
	IFNZRO	VINT-403	<___ CHANGE LOADER!!!>
	0
	CDF CIF 0	/USER INTERRUPT ROUTINE GOES HERE
	JMS I	.-2

	FPINT		/CHECK FOR FPP DONE
	JMP	LPTEST
FPUHNG,	JMP	DISMIS	/ALWAYS GOES TO RESTRT

VDISMS,	JMP	DISMIS	/FOR USE BY USERS
	JMP	DISMIS
	JMP	DISMIS

LPTEST,	LSF
	JMP	NOTLPT
LPTLCF,	LCF		/CLEAR FLAG
	TAD I	LPGET
	SNA CLA		/CHECK FOR SPURIOUS INTERRUPT
JMPDIS,	JMP	DISMIS	/GO AWAY IF SO
	DCA I	LPGET	/ZERO CHAR JUST OUTPUT
	ISZ	LPGET
	TAD I	LPGET
	SPA
	DCA	LPGET	/TAKE CARE OF BUFFER LINKS
	SNA
	TAD I	LPGET	/MAKE SURE CHAR IS IN AC
	SZA		/IS THERE A CHARACTER?
	LLS		/YES - PRINT IT
	CLA
	LSF		/CHECK FOR IMMEDIATE FLAG
LPUHNG,	JMP	DISMIS	/NO - MAYBE RESTART PROGRAM
	JMP	LPTLCF	/YES - LOOP

NOTLPT,	TSF		/CHECK TTY
	JMP	NOTTTY
	TCF		/CLEAR FLAG
	TAD	TOCHR	/GET TTY STATUS
	SMA SZA		/IF THERE IS A CHARACTER WAITING,
	TLS		/OUTPUT IT.
	SMA SZA CLA	/CHANGE "WAITING" TO "BUSY",
	STL RAR		/"BUSY" TO "IDLE".
	DCA	TOCHR
TTUHNG,	JMP	DISMIS
/KBD AND PTP INTERRUPTS

NOTTTY,	KSF
	JMP	NOTKBD
	TAD	[200
	KRS		/USE KRS TO FORCE PARITY BIT
	DCA	KBDCHR	/AND ALSO SO THAT ^C WILL STILL BE IN BUFFER IN OS/8
	TAD	KBDCHR
	TAD	(-202	/CHECK FOR ^C OR ^B
	CLL RAR
	SNA CLA
	JMP	CTCCTB	/YUP - TAKE SOME DRASTIC ACTION
	KCC		/DATA CHARACTER - CLEAR FLAG
KBUHNG,	JMP	DISMIS

CTCCTB,	TAD	CTCINH
	SNA CLA		/ARE WE IN A HANDLER?
	JMP	NOTINH	/NO
	TAD	INTLNK
	CLL RAL		/YES - RETURN WITH INTERRUPTS OFF
	TAD	INTAC	/TRUST IN GOD AND RTS
	RMF
	JMP I	0

NOTKBD,	PSF
	JMP	NOTPTP
	PCF		/P.T. PUNCH INTERRUPT - CLEAR FLAG
	DCA	POCHR	/CLEAR SOFTWARE FLAG
PPUHNG,	JMP	DISMIS

NOTPTP,	RSF
	JMP	LPTERR
	TAD	[200
	RRB		/GET RDR CHAR
	DCA	RDRCHR
RDUHNG,	JMP	DISMIS

LPTERR,	LSE		/TEST FOR LP08 ERROR FLAG
	SKP
	LIF		/DISABLE LP08 INTERRUPTS IF ERROR FLAG ON
DISMIS,	TAD	INTLNK
	CLL RAL
	TAD	INTAC	/RESTORE AC AND LINK
	RMF
	ION
	JMP I	0	/RETURN FROM THE INTERRUPT

INTAC,	0
INTLNK,	0
/BACKGROUND INITIATE/TERMINATE ROUTINE

HANG,	0		/ALWAYS CALLED WITH INTERRUPTS OFF!
	TAD I	HANG	/GET POINTER TO UNHANGING LOCATION
	DCA	UNHANG
	RDF		/GET FIELD CALLED FROM
	TAD	HCIDF0
	DCA	HNGCDF	/SAVE FOR RETURN
HCIDF0,	CDF CIF 0
	TAD	(JMP RESTRT	/CHANGE THE "JMP DISMIS" AT THAT LOC
	DCA I	UNHANG	/TO A "JMP RESTRT"
	TAD	BACKLK
	CLL RAL
	TAD	BACKAC	/SET UP BACKGROUND AC AND LINK
BAKCIF,	CIF 0
BAKCDF,	CDF 0
	ION
	JMP I	BACKPC	/INITIATE BACKGROUND

/	COME HERE WHEN THE HANG CONDITION HAS GONE AWAY

RESTRT,	TAD	JMPDIS	/RESTORE THE UNHANG LOCATION
	DCA I	UNHANG
	TAD	INTAC	/SUSPEND THE BACKGROUND
	DCA	BACKAC
	TAD	INTLNK
	DCA	BACKLK
	TAD	0
	DCA	BACKPC
	RIB
	AND	[70
	TAD	HCIDF0
	DCA	BAKCIF
	RIB
	JMS I	MCDF	/*K* OK SINCE BACKGROUND DOESN'T USE MAKCDF
	DCA	BAKCDF
	ISZ	HANG
HNGCDF,	HLT
	JMP I	HANG	/INTERRUPTS ARE OFF - RETURN

NOTINH,	TAD	JMPDIS	/IN CASE WE WERE HUNG, WE DON'T WANT
	DCA I	UNHANG	/TO GET "UNHUNG" OUT OF THE ERROR ROUTINE!
	JMP I	(KILFPP	/KILL FPP AND GO TO EXIT OR ERROR

UNHANG,	0
BACKAC,	0
BACKLK,	0
BACKPC,	VBACKG
VHANG=	HANG
	IFNZRO	VHANG-0524	<__ CHANGE LOADER!>
	PAGE
/I-O CONVERSION ROUTINES - STARTUP CODE

RWASCI,	JMS I	[RWINIT	/"READ(N,FMT)" OR "WRITE(N,FMT)"
	2000		/"FORMATTED" BIT
	JMS I	[FETPC	/GET ADDRESS OF FORMAT STMT
	DCA	FMTDF
	JMS I	[FETPC
	DCA	FMTADR
	DCA	FMTTYP
	DCA	PFACT	/CLEAR SCALE FACTOR
	JMS I	[GETLMN	/EXIT TO MAIN PROGRAM TO GET 1ST VARIABLE

	TAD	(FMTPDL-1
FMTSET,	DCA	FMTPXR	/STORE NEW FORMAT PUSHDOWN POINTER
	TAD I	FMTPXR
	DCA	FMTBYT	/GET NEW BYTE POINTER (NOTE-FMTPDL CONTAINS A 0)
/MAIN FORMAT DECODING LOOP

FMTFLP,	TAD	FMTBYT
	DCA	FMPBYT	/SAVE CURRENT BYTE PTR FOR PARENTHESES HACK
FMTDLP,	DCA	FMTNUM	/ZERO ACCUMULATED NUMBER
FMTCLP,	JMS	FMTGCH	/GET A CHARACTER
	ISZ	FMTBYT	/BUMP BYTE POINTER
	JMS I	[CHTYPE	/CLASSIFY CHAR
	1234;	FMTDIG	/DIGIT
	-42;	DBLQOT	/"
	-44;	ABORTO	/$
	-55;	FMINUS	/-
	-56;	FMTPER	/.
	-57;	SLASH	//
	-54;	COMMA	/,
	-50;	LPAREN	/(
	-51;	RPAREN	/)
	-47;	KWOTE	/'
	-40;	FMTCLP	/SPACE
	0		/ANYTHING ELSE

	TAD	FMTTYP
	SZA CLA		/CHECK THAT WE DO NOT HAVE A FIELD OUTSTANDING
	JMP I	(FMTERR	/IF WE DO - ERROR
	TAD	CHCH	/GET FIELD CHARACTER
	DCA	FMTTYP
	TAD	FMTNUM
	SNA		/IF REPEAT COUNT WAS MISSING OR ZERO
	IAC		/MAKE IT ONE
	CMA
	DCA	N	/STORE -(REPEAT COUNT +1)
	DCA	W	/CLEAR WIDTH INITIALLY
	ISZ	FMTNUM	/PRECLUDE "FORMAT ERROR" ON X,P, OR H FORMATS
	TAD	FMTTYP
	AND	[7	/IS THE CHARACTER P, X, OR H?
	SNA CLA		/IF SO, DON'T WAIT
COMMA,	JMS I	(DOFMT	/EXECUTE THE STORED FIELD SPECIFICATION
	JMP	FMTFLP	/BACK FOR MORE

FMTADR,	0		/ADDRESS OF FORMAT
FMTGCH,	0		/GET CHARACTER FROM FORMAT
	JMS	FMTGAD	/GET WORD CONTAINING CHAR AND L/R SWITCH
	CDF 0
	JMS I	(FMTGLR	/EXTRACT CHARACTER
	JMP I	FMTGCH

FMTGAD,	0		/SUBR TO GET A WORD FROM A CHARACTER OFFSET
	TAD	FMTBYT	/GET OFFSET
	CLL RAR
	CLL
	TAD	FMTADR	/COMPUTE BASE ADDR + [OFFSET/2]
	DCA	D
	RAL
	TAD	FMTDF
	JMS I	MCDF	/SET UP PROPER DATA FIELD
	DCA	.+1
	HLT
	TAD	FMTBYT
	RAR
	CLA		/LEAVE L/R SWITCH IN LINK
	TAD I	D
	JMP I	FMTGAD	/RETURN WITH WORD IN AC

FMTDF,	0		/FIELD OF 1ST CHAR OF FORMAT IN BITS 9-11

FMTDIG,	TAD	FMTNUM	/DIGIT PROCESSOR
	CLL RTL
	TAD	FMTNUM
	CLL RAL		/MULTIPLY FMTNUM BY 10
	TAD	CHCH	/ADD IN THE DIGIT
	JMP	FMTDLP	/STORE IT BACK AND CONTINUE
/PARENTHESIS AND DIGIT ROUTINES

LPAREN,	TAD	FMTPXR
	TAD	(2-FMTPDL
	SZA		/ARE WE AT PARENTHESIS LEVEL 1?
	JMP	.+3	/NO
	TAD	FMPBYT	/YES - STORE A POINTER TO THE FIRST DIGIT OF THE
	DCA I	(FMTPDL-2	/GROUP COUNT PRECEDING THIS PAREN
			/AS THE LOOP POINTER FOR LEVEL 1
	TAD	[7
	SPA CLA		/PUSHDOWN OVERFLOW?
FPOERR,	JMS I	ERR	/YES
	AC7775
	TAD	FMTPXR
	DCA	FMTPXR	/BUMP PARENTHESIS PUSHDOWN POINTER
	TAD	FMTBYT
	DCA I	FMTPXR	/SAVE BYTE POINTER
	TAD	FMTNUM
	SNA
	IAC		/NO GROUP COUNT MEANS COUNT = 1
	CIA
	DCA I	FMTPXR	/SAVE LOOP COUNT
	DCA I	(FMTPDL-1	/INITIAL GROUP COUNT IS INFINITE!
RPLOOP,	AC7776	/COME HERE ON RIGHT PAREN ALSO
	TAD	FMTPXR	/BACK UP FORMAT PDL POINTER
	JMP	FMTSET	/RESTORE FMTBYT FROM TOP OF LIST

FMPBYT,	0

RPAREN,	JMS I	(DOFMT	/EXECUTE PREVIOUS SPEC IF ANY
	TAD	FMTPXR
	TAD	(2-FMTPDL	/IS THIS THE FINAL RIGHT PAREN?
	SNA CLA
	JMS I	[ENDREC	/YES - CHECK FOR END OF FORMAT
	ISZ I	FMTPXR	/BUMP COUNT
	JMP	RPLOOP	/DIDN'T OVERFLOW - LOOP TO BYTE AFTER (
	ISZ	FMTPXR	/POP UP PARENTHESES STACK
	JMP	FMTFLP	/CONTINUE PAST RIGHT PAREN
	PAGE
/QUOTE AND HOLLERITH FORMAT PROCESSORS

KWOTE,	TAD	MINUS5	/APOSTROPHE PROCESSOR
DBLQOT,	TAD	(-42	/QUOTE PROCESSOR
	DCA	KWODEL	/SAVE TERMINATOR
	JMS	DOFMT	/PROCESS PRECEDING FIELD , IF ANY
	SKP
KWOTLP,	JMS	FMTHCV	/PROCESS ONE CHARACTER
	JMS I	[FMTGCH	/GET THE NEXT FORMAT CHAR
	TAD	KWODEL
	SZA CLA		/IS IT THE TERMINATOR?
	JMP	KWOTLP	/NO - PROCESS IT AND CONTINUE
	ISZ	FMTBYT	/BUMP OVER TERMINATOR
	JMS I	[FMTGCH
	TAD	KWODEL
	SNA CLA		/IS THIS ANOTHER TERMINATOR?
	JMP	KWOTLP	/TWO TERMINATORS PRINT AS ONE
	JMP I	(FMTFLP	/OTHERWISE GO BACK TO FORMAT LOOP

HFMT,	JMS	MORE	/MORE CHARACTERS?
	JMS	FMTHCV	/YES - PROCESS ONE
	JMP	HFMT	/AND LOOP

FMTHCV,	0		/ROUTINE COMMON TO H AND QUOTED FORMATS
	TAD	RWFLAG	/PROCESSES ONE CHAR IN OR OUT OF THE FORMAT
H7700,	SMA CLA		/IN OR OUT?
	JMP	FMTHIN	/IN
	JMS I	[FMTGCH	/OUT - GET THE CHAR
	JMS I	[FMTOUT	/PRINT IT
	JMP	FMTHCR	/RETURN
FMTHIN,	JMS I	[FMTIN	/INPUT - GET THE CHAR FROM THE INPUT LINE
	DCA	W	/SAVE IT
	JMS I	(FMTGAD
	SZL		/WHICH SIDE?
	JMP	FHRGHT	/RIGHT SIDE
	AND	[77	/LEFT - KEEP RIGHT CHAR
	DCA	MORE
	TAD	W
	CLL RTL
	RTL
	RTL
	TAD	MORE	/ADD NEW CHAR IN ON THE LEFT
	JMP	.+3
FHRGHT,	AND	H7700	/KEEP THE CHAR ON THE LEFT
	TAD	W	/ADD NEW CHAR IN ON THE RIGHT
	DCA I	D	/RESTORE ALTERED WORD
	CDF 0
FMTHCR,	ISZ	FMTBYT	/BUMP BYTE POINTER
	JMP I	FMTHCV

KWODEL,	0		/MUST BE UNIQUE!
MORE,	0		/SUBR TO BUMP REPEAT COUNT AND EXIT ON OVFLO
	ISZ	N
	JMP I	MORE
DOFRTN,	DCA	FMTTYP	/INDICATE NO SPECIFICATION COLLECTED
	JMP I	DOFMT	/RETURN FROM "DOFMT"

DOFMT,	0		/ROUTINE TO PROCESS A FORMAT SPECIFICATION
	TAD	FMTNUM	/GET THE CURRENT NUMBER
	DCA	D	/STORE IT AS DECIMAL POINT SPEC
	DCA	IFLG
	DCA	EFLG
	DCA	GFLG	/ZERO CONVERSION FLAGS
	TAD	FMTTYP
	SNA CLA		/ANY SPECIFICATION WAITING?
	JMP I	DOFMT	/NO - JUST RETURN
	TAD	W
	TAD	D	/IF THERE WAS NO W OR D SPECIFICATION,
	SNA CLA
	JMP	FMTERR	/ITS AN ERROR
	TAD	FMTTYP
	JMS I	[CHTYPE	/YES - WHICH ONE?
	-30;	XFMT	/X
	-24;	TFMT	/T
	-20;	PFMT	/P
	-14;	LFMT	/L
	-11;	IFMT	/I
	-10;	HFMT	/H
	-7;	GFMT	/G
	-6;	FFMT	/F
MINUS5,	-5;	EFMT	/E
	-4;DF,	EFMT	/D - EQUIVALENT TO E IF NO D.P. FPP
	-2;BF,	FFMT	/B - EQUIVALENT TO F IF NO D.P. FPP
	-1;	AFMT	/A
	0		/NONE OF THE ABOVE - ERROR
FMTERR,	JMS I	ERR
ENDREC,	0		/ROUTINE TO END A LINE AND MAYBE THE I/O
	JMS I	[EOLINE
	CLA IAC
	AND	RWFLAG	/LO BIT OF RWFLAG IS "I/O LIST EXHAUSTED" FLAG
	SNA CLA		/SKIP IF NO MORE ELEMENTS IN I/O LIST
	JMP I	ENDREC
	JMP I	[ENDIO	/NOW FINISH UP AND LEAVE

SLASH,	JMS	DOFMT	/EXECUTE THE FIELD SPEC IF ANY
	JMS I	[EOLINE	/TERMINATE CURRENT LINE
	JMP I	(FMTFLP

PFMT,	CLA CMA
	TAD	FMTNUM
	ISZ	MINFLG	/P FORMAT - CHECK FOR NEGATIVE SCALE
	CIA
	DCA	PFACT
	STA		/FALL INTO CODE TO CLEAR MINFLG
	DCA	MINFLG	/SET FLAG ON MINUS
	JMP	DOFRTN

FMINUS,	JMS	DOFMT	/EXECUTE PRECEDING SPEC
	DCA	MINFLG	/CLEAR MINUS FLAG
	JMP I	(FMTFLP

MINFLG,	-1

FMTPER,	TAD	FMTNUM	/PERIOD PROCESSOR
	DCA	W	/STORE WIDTH
	JMP I	(FMTFLP

ABORTO,	JMS	DOFMT	/$ - SPECIAL HACK TO ALLOW PROMPTS
	DCA	EOLSW	/FAKE BEGINNING OF LINE
	DCA I	(TTYLF	/INHIBIT LF BEFORE NEXT TTY INPUT
	JMP I	[ENDIO	/GO AWAY
	PAGE
CHTYPE,	0		/ROUTINE TO CLASSIFY CHARACTERS
	DCA	CHCH	/SAVE CHAR
	JMP	CHLOOP+1
CDIGIT,	TAD	CHCH	/CHECK FOR DIGIT
	TAD	(-72
	CLL
	TAD	[12
	SZL		/IS CHAR A DIGIT?
	JMP	JMPOUT	/YES
CHLOOP,	ISZ	CHTYPE	/SKIP OVER ADDRESS
	CLA
	TAD I	CHTYPE
	ISZ	CHTYPE
	SMA		/END OF LIST?
	JMP	JMPOTX	/MAYBE - JUMP WITH CODE IN AC
	TAD	CHCH
	SZA CLA		/DOES CHAR MATCH CHAR ON LIST?
	JMP	CHLOOP	/NO - KEEP LOOKING
JMPOUT,	DCA	CHCH	/ZERO CHAR
	TAD I	CHTYPE
	DCA	CHTYPE	/SET UP TO RETURN INDIRECTLY
JMPOTX,	SZA CLA		/IS THIS THE END?
	JMP	CDIGIT	/NO - GO CHECK FOR DIGIT
	JMP I	CHTYPE	/GO TO SPECIFIED ADDRESS


SKPOUT,	0		/ROUTINE USED BY DATA-HANDLING SPECIFICATIONS
	JMS I	[MORE	/CHECK FOR REPEAT COUNT EXHAUSTED
	TAD	RWFLAG
	CLL RAR
	SZA CLA		/IF OUTPUT,
	ISZ	SKPOUT	/SKIP RETURN
	SZL CLA		/IF END OF I/O LIST,
	JMS I	[ENDREC	/DON'T RETURN AT ALL - GO AWAY
	JMP I	SKPOUT
/A FORMAT PROCESSOR

AINPUT,	TAD	(4040
	DCA	ACH
	TAD	(4040
	DCA	ACL	/INITIALIZE LOW-ORDER WORDS TO BLANKS
AINPTL,	JMS	GADR
	SZL		/LEFT OR RIGHT?
	JMP	AINPTR	/RIGHT
	JMS I	[FMTIN
	STL RTL		/INPUT CHAR GOES IN HIGH-ORDER
	RTL		/WITH BLANK IN LOW-ORDER
	RTL
	JMP	AINPTC
AINPTR,	JMS I	[FMTIN
	TAD I	FMTGLR	/COMBINE INPUT CHAR AND OLD LEFT HALF
	TAD	[-40	/DELETE PREVIOUS RIGHT-HALF SPACE
AINPTC,	DCA I	FMTGLR	/STORE WORD
	ISZ	W
	JMP	AINPTL	/LOOP AROUND WIDTH
ANXT,	JMS I	[GETLMN	/GET NEXT ELEMENT
AFMT,	TAD	D
	CIA
	DCA	W	/SAVE FIELD WODTH AS A COUNT
	JMS I	[SKPOUT	/CHECK FOR REPEAT COUNT OVFLO AND I/O DIR
	JMP	AINPUT
AOTPUT,	JMS	GADR	/OUTPUT - GET ADDRESS OF BYTE
	TAD I	FMTGLR
	JMS	FMTGLR	/GET BYTE
	JMS I	[FMTOUT	/PRINT IT
	ISZ	W
	JMP	AOTPUT	/LOOP ON WIDTH
	JMP	ANXT

FMTGLR,	0		/SUBR TO EXTRACT A CHAR FROM A WORD
	SZL
	JMP	.+4	/RIGHT HALF
	RTR
	RTR
	RTR		/LEFT HALF - ROTATE INTO RIGHT HALF
	AND	[77
	JMP I	FMTGLR

GADR,	0		/BYTE ADDRESS ROUTINE FOR A FORMAT PROCESSOR
	TAD	D
	TAD	W	/FORM BYTE OFFSET IN THE RANGE 0 THRU D-1
	CLL RAR
	TAD	(ACX
	DCA	FMTGLR
	JMP I	GADR	/LEAVE WITH L/R FLAG IN LINK
/"STOP" ROUTINE - TERMINATES JOB

CALXIT,	TAD	EXDVNO
	CIA
	DCA	ACI	/GO THROUGH THE FORTRAN UNIT NUMBERS.
	DCA I	(ENDFLS	/*K* TURN "ENDFL" INTO A SUBROUTINE
	JMS I	(LDDSRN	/IF WE FIND A UNIT WHICH IS BEING USED
	SNA CLA		/AND HAS NOT BEEN ENDFILED,
	JMP	XITISZ	/WE WILL DUMP THE CURRENT BUFFER (IF IT
	CLA IAC		/IS A FORMATTED OUTPUT FILE) AND
	AND	FFLAGS	/END-FILE IT
	SNA CLA
	JMS I	(ENDFL
XITISZ,	ISZ	EXDVNO
	JMP	CALXIT
LPTTWT,	TAD I	LPGET	/WAIT FOR LINE PRINTER AND TELETYPE TO
	TAD	TOCHR	/GO QUIET.
	SZA CLA
	JMP	LPTTWT
	ISZ	CLNADR	/SET UP TO CLOSE OUTPUT FILES
PDPXIT,	IOF		/ENTER HERE FROM 7605
	CDF 0		/TO PROTECT CLODS WITH PDP 8/E'S
	JMS I	(7607
	0210
	7400		/READ IN CLEANUP ROUTINE
	37		/AND OS/8 PAGE 17600
	JMP	.-5	/AYEEEE!! SYSTEM DEVICE GONZO!
	CDF CIF 10
	JMP I	CLNADR	/CLOSE TENTATIVE FILES AND EXIT
CLNADR,	CLNUP
EXDVNO,	-11

ARGLD,	0		/ROUTINE TO GET VALUE OF AN ARG
	JMS I	[FETPC
	AND	[7	/THROW AWAY OPCODE (JA)
	TAD	FLDTM2
	DCA	FGPBF
	JMS I	[FETPC	/CONSTRUCT AN FPP INSTRUCTION
	DCA	BIOPTR
	JMS I	[FPGO
	FGPBF
	JMP I	ARGLD

FLDTM2,	FLDA+LONG
	FTEMP2
	FEXIT
	PAGE
/SUBROUTINE TO OPEN A UNIT FOR I/O

RWINIT,	0
	DCA	RWFLAG	/DIRECTION IN AC ON ENTRY
	AC7776
	AND I	RWINIT	/IF CALLED FROM BACKSPACE, REWIND OR ENDFILE
	SZA CLA		/UNIT NUMBER IS IN FAC
	JMS I	[ARGLD	/OTHERWISE, GET UNIT NUMBER
	JMS I	[FFIX
	TAD	ACI
	CLL CMA
	TAD	[12
	SZL CLA		/CHECK DEVICE NUMBER IN RANGE 0-9
	JMS	LDDSRN	/LOAD DSRN ENTRY INTO PAGE 0
	SNA CLA		/IS UNIT INITIALIZED?
UNTERR,	JMS I	ERR	/NO - ERROR
	TAD	RWFLAG
	SPA		/IF WE ARE WRITEING FOR THE FIRST TIME
	TAD	FFLAGS	/ON A UNIT WHICH WAS BEING READ,
	CMA RAL		/WE MUST BUMP THE RELATIVE BLOCK NUMBER DOWN
	SNL SMA CLA	/ONE BECAUSE OF A PHILOSOPHICAL DIFFERENCE
	JMS I	(RD2WR	/BETWEEN READ AND WRITE
	TAD I	RWINIT
	TAD	RWFLAG	/OR THE I/O TYPE AND
	CMA
	AND	FFLAGS	/DIRECTION BITS INTO THE FLAG WORD
	TAD I	RWINIT
	TAD	RWFLAG
	DCA	FFLAGS
	TAD	FFLAGS
	CMA RTL
	SNL SMA CLA	/IT IS ILLEGAL TO ACCESS A FILE IN
	JMP	UNTERR	/FORMATTED AND UNFORMATTED MODES
	ISZ	RWINIT
	TAD	ACI
	CLL RAL
	TAD	ACI
	TAD	(DATABL-4
	DCA	XR	/STORE POINTER INTO DIRECT-ACCESS TABLE
	JMP I	RWINIT
/REWIND AND END FILE

RWIND,	JMS	RWINIT	/GET THE DSRN ENTRY
	0		/DON'T PLAY WITH MODES
	AC2000
	TAD	FFLAGS
	SNA CLA		/IF FORMATTED OUTPUT FILE AND NOT EOF'D
	JMS	DMPBUF	/DUMP LAST BUFFER AS A FAVOR
ATLDMK,	CLA IAC
	AND	FFLAGS	/KILL ALL FLAG BITS
	DCA	FFLAGS	/EXCEPT "END-FILED" BIT
	TAD	BADFLD
	AND	[7400
	DCA	CHRPTR
	AC7775
	DCA	CHRCTR	/INITIALIZE BUFFER POINTERS
	DCA	RELBLK	/AND RELATIVE BLOCK #
	JMP I	[ENDIO	/RESTORE DSRN AND EXIT

ENDFL,	JMS	RWINIT	/*K* USED AS A SUBROUTINE BY CALXIT
	1		/GET DSRN, SET "END FILE" FLAG
	TAD	FFLAGS	/IF THE FILE IS UNFORMATTED,
	CMA RAL		/OR WAS NOT OUTPUT ONTO,
	SNL SMA CLA	/THEN ENDFILE DOES NOTHING.
	JMS	DMPBUF	/ELSE DUMP THE FINAL BUFFER
	AC3777
	AND	FFLAGS	/CLEAR WRITE BIT SO WE WILL NOT TRY
SETTOT,	DCA	FFLAGS	/ANYTHING ON A SUBSEQUENT ENDFILE
	TAD	RELBLK	/SET NEW LENGTH OF FILE IN CASE ITS TENTATIVE,
	DCA	TOTBLK	/AND SO WE WON'T READ PAST EOF.
ENDIO,	JMS	INITMV	/SET UP DSRN POINTERS
	TAD I	XR1
	DCA I	XR	/STORE BACK THE DSRN ENTRY
	ISZ	T	/FOR THIS LOGICAL UNIT
	JMP	.-3
	DCA	VEOFSW	/CLEAR EOFSW AT END OF EVERY READ
ENDFLS,	JMP I	[RETURN	/RETURN TO THE CALLING PROGRAM
	JMP I	ENDFL	/*K* OR RETURN TO CALXIT

INITMV,	0		/ROUTINE TO SET UP STUFF
ICDF0,	CDF 0
	TAD	LOGUNT
	DCA	XR
	TAD	(HAND-1
	DCA	XR1
	TAD	(-11
	DCA	T
	JMP I	INITMV
/ROUTINE TO DUMP CURRENT OUTPUT BUFFER WITH ^Z AT THE END

DMPBUF,	0
	ISZ	EOLSW	/FORCE COLUMN 1 SWITCH OFF
	TAD	(7712	/OUTPUT A LINE FEED
	JMS I	[FMTOUT
	TAD	HAND	/IF THE FILE IS BEING OUTPUT VIA
	SMA CLA		/AN OS/8 HANDLER,
	JMP	CLREOL	/WE MUST TERMINATE THE BUFFER PROPERLY.
	TAD	(32
CTZLP,	TAD	Z7700	/OUTPUT A ^Z AND FILL BUFFER WITH ZEROES.
	JMS I	[FMTOUT	/NEGATIVE NUMBERS TURN INTO CONTROL CHARS
	TAD	CHRPTR
	AND	[377
	TAD	CHRCTR	/FILL THE BUFFER UNTIL CHRPTR POINTS TO
	IAC		/A BLOCK BOUNDARY AND CHRCTR = -3
Z7700,	SMA CLA		/WE ARE THEN AT BUFFER-END
	JMP	CTZLP
CLREOL,	DCA	EOLSW	/RESET TO BEGINNING OF LINE
	JMP I	DMPBUF	/RETURN

/ROUTINE TO MOVE THE PROPER DSRN ENTRY INTO PAGE 0

LDDSRN,	0
	TAD	ACI	/ READ/WRITE INIT SINGS THIS SONG,
	CLL RTL		/ (DOO DAH, DOO DAH,)
	RAL		/ DSRN ENTRIES 9 WORDS LONG
	TAD	ACI	/ (OH, DEE DOO DAH DAY).

	SNA			/DEVICE NUMBER 0 IS SPECIAL -
	TAD	(PTTY+11-DSRN	/IT'S ALWAYS THE TELETYPE
	TAD	(DSRN-12
	DCA	LOGUNT
	JMS	INITMV	/SET UP FOR MOVE
	TAD I	XR
	DCA I	XR1	/PUT DSRN ENTRY IN PAGE 0
	ISZ	T
	JMP	.-3
	TAD	BADFLD
	AND	[70
	TAD	ICDF0
	DCA	BUFCDF	/SAVE BUFFER FIELD AS A CDF
	TAD	HAND
	JMP I	LDDSRN
	PAGE
/BACKSPACE ROUTINE - WORKS ON BINARY OR ASCII FILES

BKSPC,	JMS I	[RWINIT
	0		/GET THE DSRN ENTRY WITHOUT ALTERING MODE
	TAD	HAND
	SMA CLA
	JMP I	[UNTERR	/UNIT MUST BE BLOCK ORIENTED
	AC2000
	AND	FFLAGS
	SZA CLA		/IS FILE FORMATTED?
	JMP	BKASCI	/YES - PAIN IN NECK
	JMS	BMPBLK	/UNFORMATTED FILE - REREAD LAST BLOCK
	TAD	CHRPTR
	TAD	[377
	DCA	T
	JMS	BUFFLD	/SET DATA FIELD TO FIELD OF BUFFER
	TAD I	T	/LOOK AT LAST WORD IN BUFFER
	CIA		/REGARD IT AS THE NUMBER OF BLOCKS/RECORD
	TAD	RELBLK
	DCA	RELBLK	/RELBLK POINTS TO FIRST BLOCK OF PREV. REC
	JMP I	[ENDIO

BMPBLK,	0		/SUBR TO BUMP BLOCK # BACK AND READ
	CMA CLL		/AC MAY NOT BE 0 ON ENTRY
	TAD	RELBLK
	DCA	RELBLK	/BUMP BLOCK BACK
	SNL
	JMP I	(ATLDMK	/BACKSPACED TOO FAR - CALL IT QUITS
	DCA	CHRPTR	/ZERO CHRPTR TO FORCE A READ FROM MASSIO
	JMS I	[MASSIO	/READ A BLOCK
	JMP I	BMPBLK

/****	NULL JOB GOES HERE FOR LACK OF A BETTER PLACE ****

NULLJB,	TAD	N2525
NULLLP,	ISZ	N2525	/PUT THE FAMOUS "POLY BASIC PATTERN"
	JMP	NULLLP	/IN THE AC LIGHTS
	ISZ	NUMISZ
	JMP	NULLLP
	CML CMA RAR
	DCA	N2525
	TAD	[-4
	DCA	NUMISZ
	JMP I	(VBACKG	/GOT SOMETHING MORE USEFUL TO DO?
N2525,	2525
NUMISZ,	-4
/BACKSPACE FOR FORMATTED FILES

BKLORD,	TAD I	CHRPTR
	ISZ	CHRPTR
	NOP
	AND	[177	/GET 7 BITS
	TAD	(-15	/COMPARE WITH C.R. - SINCE WE SKIPPED
	SNA CLA		/THE FIRST ONE THIS WILL BELONG TO THE PREVIOUS
	JMP I	[ENDIO	/LINE AND WE WILL BE DONE (HAH!)
BKASCI,	JMS I	(MASBMP	/A COMPLICATED MESS - FIRST BUMP THE 
	SKP		/CHARACTER POINTER BACK TWO PLACES
	JMP	BKGTCH	/AND THEN FETCH A CHARACTER.  THIS WILL IGNORE
	TAD	BADFLD	/THE LAST CHAR READ/WRITTEN (WHICH SHOULD
	AND	[7400	/BE A CARRIAGE RETURN).
	CIA
	TAD	CHRPTR
	CLL RAR
	SZA CLA		/TEST WHETHER WE HAVE TO READ AN OLD BUFFER
	JMP	BKNORD	/NO
	TAD	CHRCTR	/SAVE POSITION IN CURRENT DOUBLEWORD
	DCA	GETCH3
	DCA	CHRPTR
	AC4000		/IF WE ARE BACKSPACING AN OUTPUT FILE,
	TAD	FFLAGS	/WE MUST SAVE THE INFORMATION IN THE
	SPA		/CURRENT BUFFER BY WRITING IT OUT.
	JMP	.+4
	DCA	FFLAGS	/ALSO CHANGE THE UNIT TO AN INPUT FILE
	AC4000		/(RWINIT TAKES CARE OF SWITCHING BACK TO OUTPUT)
	JMS I	[MASSIO
	CLA IAC		/WE DON'T WANT THE LAST BLOCK READ/WRITTEN,
	JMS	BMPBLK	/THAT'S IN CORE - WE WANT THE ONE
	TAD	GETCH3	/BEFORE THAT.
	DCA	CHRCTR
	TAD	CHRCTR
	TAD	(401
	SKP		/COMPUTE WORD POINTER FROM CHAR POINTER
BKNORD,	STA
	TAD	CHRPTR
	DCA	CHRPTR	/BUMP WD PTR BACK 1
BKGTCH,	JMS I	(MASBMP	/NOW GET A CHARACTER - THIS LOOKS A LOT
	JMP	BKLORD	/LIKE THE INPUT ROUTINE
	JMS	GETCH3
	JMP	BKLORD+1
GETCH3,	0		/COMMON CODE BETWEEN BACKSPACE AND INPUT
	TAD I	CHRPTR
	AND	[7400
	DCA	BMPBLK	/HANDY TEMPORARY
	ISZ	CHRPTR
	TAD I	CHRPTR
	AND	[7400
	CLL RTR
	RTR		/COMBINE TWO 4-BIT QUANTITIES
	TAD	BMPBLK	/INTO A CHARACTER
	CLL RTR
	RTR
	JMP I	GETCH3

DATABL,	ZBLOCK	33	/DIRECT ACCESS TABLE
	PAGE
/I,E,F,AND G FORMAT CONVERSIONS

IFMT,	TAD	D
	DCA	W	/SET WIDTH PROPERLY
	DCA	D	/FOR SCALING PURPOSES
	STA
	DCA	IFLG
	JMP	FFMT

GFMT,	STA
	DCA	GFLG	/SET G AND E FLAGS

EFMT,	STA
	DCA	EFLG	/SET E FLAG
	JMP	FFMT

IGEF,	JMS I	[GETLMN	/MAIN LOOP FOR CONVERSIONS - SKIPPED 1ST TIME
FFMT,	TAD	D
	DCA	OD	/SAVE COUNT OF POST-D.P. DIGITS
	TAD	IFLG
	SNA CLA		/APPLY THE P-SCALE FACTOR
	TAD	PFACT	/ONLY IF THE FORMAT IS NOT I
	DCA	PFACTX
	DCA	SCALE	/DON'T LOOK FOR TROUBLE
	JMS I	[SKPOUT	/CHECK IF MORE AND TEST DIRECTION
	JMP I	(IGEFIN	/INPUT
	STA
	DCA I	[FFNEG	/USE NEGATE ROUTINE HEADER AS SIGN FLAG
	TAD	EFLG
	CLL RAL
	CLL RAL		/0 IF NOT E, -4 IF E
	TAD	W	/THIS PROVIDES FOR THE EXP. FIELD (IF E FMT)
	DCA	OW	/OR THE 4 TRAILING SPACES (IF G FMT)
	TAD	ACH
	SNA
	JMP	SKPSHT	/AC IS ZERO - SKP A LOT OF SHT
	SPA CLA
	JMS I	[FFNEG	/AC<0 - NEGATE IT AND SET FLAG (CLEVER)
SCALUP,	DCA	SCALE
	TAD	ACX
	SMA SZA CLA	/AC<1.0?
	JMP	GT1	/NO
	JMS I	[FPGO	/YES - MULTIPLY BY 10.0
	FMUL10
	STA
	TAD	SCALE	/BUMP POWER OF TEN
	JMP	SCALUP
/I,G,E,F, OUTPUT CONVERSIONS - NUMBER IS NOW =>1.0

GT1,	JMS I	(SCALDN	/NOW DECREASE IT TO THE INTERVAL [0,1)
	JMS I	[FPGO	/SAVE IT AWAY
	FSTTMP
	TAD	[7
	JMS 	OSCALE
	JMS I	[FPGO	/USE IT TO ROUND THE NUMBER TO BE OUTPUT
	FADTMP
	JMS I	(SCALDN	/WE COULD HAVE ROUNDED FROM .999... TO 1.000...
SKPSHT,	TAD	GFLG	/ENTER HERE IF NUM WAS 0 - SCALE=0
	SNA CLA
	JMP	NOTG	/NOT G FORMAT
	TAD	SCALE	/G FORMAT - TEST FOR OUT OF F FORMAT RANGE
	TAD	PFACTX
	CIA CLL		/F FORMAT RANGE IS [.1,10**(D VALUE))
	TAD	OD
	SNL
	JMP	USEE	/IF OUT OF BOUNDS USE E FORMAT (FLAG IS SET)
	DCA	OD	/REDUCE D VALUE BY SCALE FACTOR
	DCA	EFLG	/TO RETAIN CORRECT # OF SIG. DIGITS
USEE,	CLA
	JMP	NOTG

/SET UP TO PRINT DIGITS


DIGCNT,	0
	TAD	PFACTX	/COMPUTE EXPONENT JUST IN CASE E FORMAT
	CIA
	TAD	SCALE
	DCA	FMTNUM
	TAD	EFLG
	SNA CLA		/NOW COMPUTE THE NUMBER OF DIGITS BEFORE THE D.P.
	TAD	SCALE	/TAKE SCALE FACTOR INTO ACCOUNT IF NOT E FORMAT
	TAD	PFACTX	/TAKE P FACTOR INTO ACCOUNT IF NOT I OR F/G
	DCA	SCALE	/STORE THE NUMBER OF DIGITS BEFORE THE D.P.
	TAD I	[FFNEG	/INCREASE NUMBER OF LEADING BLANKS BY 1
	SPA CLA		/IF THE NUMBER IS POSITIVE. THIS DEPENDS ON
	ISZ	OW	/THIS LOCATION BEING BELOW 4000.
	TAD	SCALE	/GET THE NUMBER OF PRE-D.P. DIGITS (AS NEGATIVE #)
	SPA SNA
	CLA IAC		/IF NONE, PRINT A 0 SO COUNT AS 1
	TAD	OD	/REDUCE THE WIDTH BY THIS NUMBER
	CMA
	TAD	OW	/REDUCE IT AGAIN BY THE POST-D.P. DIGIT COUNT
	CIA
	TAD	IFLG	/AND AGAIN BY 1 FOR THE D.P. (IF NOT I FORMAT)
	JMP I	DIGCNT
OW,	0
/I,G,E,F FORMAT - ROUTINE TO SCALE ROUNDING FACTOR

OSCALE,	0		/SUBR TO SCALE .5 THE CORRECT # OF TIMES
	DCA	NPLCS	/MAX IN AC ON ENTRY
	DCA	ACX
	AC2000		/FORM A FLOATING 0.5 IN ORDER
	DCA	ACH	/TO ROUND THE NUMBER BEFORE PRINTING.
	DCA	ACL
	TAD	EFLG	/FIGURE OUT HOW TO SCALE IT -
	SNA CLA		/THE THEORY IS THAT IT SHOULD BE SCALED
	TAD	SCALE	/DOWN BY THE NUMBER OF SIGNIFICANT
	DCA	T	/PRINTING DIGITS.  THIS CAN BE
	TAD	SCALE	/EXPRESSED AS:
	CIA CLL		/(P FACTOR) * (NOT (G FMT PRINTING AS F))
	TAD	OD	/ + (SCALE FACTOR) * (NOT E FMT) + (D VALUE).
	SZL CLA		/THE SCALE FACTOR IS < 0 FOR
	TAD	GFLG	/NUMBERS < .1, WHICH REDUCES
	SNA CLA		/THE # OF SIG. DIGITS VIA LEADING ZEROS.
	TAD	PFACTX	/IF THERE ARE < 0 SIG. DIGITS
	TAD	T	/IT DOESN'T MATTER WHAT WE DO
	TAD	OD	/SINCE THE NUMBER WILL PRINT AS
	SMA		/0.00000 ANYWAY.
	CMA		/IF THERE ARE >NPLCS SIG. PRINTING DIGITS
	TAD	NPLCS	/THE ROUNDING GETS MEANINGLESS SO MAKE
	SPA		/THE EXCESS DIVISIONS DIVIDES BY 2 INSTEAD
	DCA	ACX	/ OF BY 10.  THIS FUDGE WORKS QUITE WELL
	CIA		/FOR NUMBERS OF UP TO NPLCS+2
	TAD	NPLCS	/SIGNIFICANT DIGITS.
	CIA
	DCA	T
	JMP	.+3
FDIVLP,	JMS I	[FPGO	/SCALE THE .5 DOWN THE CORRECT NUMBER OF TIMES
	FDIV10
	ISZ	T
	JMP	FDIVLP
	JMP I	OSCALE
NPLCS,	0
ONE,	1;2000;0
	PAGE
/I,G,E,F OUTPUT CONVERSION - ACTUAL OUTPUT SECTION

OUTNUM,	SMA		/CHECK FOR FIELD OVERFLOW
	JMP	ASTSK1	/YES - PRINT *******
	JMS	OBLNKS	/PRINT LEADING BLANKS - AC IS NOT 0!
			/***IMPORTANT - OBLNKS CLEARS AC1 ***
	AC7775
	ISZ I	[FFNEG	/IF SIGN IS NEGATIVE,
	JMS	DIGIT	/OUTPUT A MINUS SIGN
	CLA		/OTHERWISE OUTPUT NOTHING
	TAD	ACX
	SNA		/ALIGN THE FAC MANTISSA INTO A DOUBLEWORD
	JMS I	[AL1	/FRACTION IN THE RANGE [.1,1)
	IAC		/THIS INVOLVES SHIFTING THE MANTISSA
	CMA		/RIGHT BY (-ACX-1) PLACES
	SMA		/WHERE A NEGATIVE NUMBER MEANS A LEFT SHIFT.
	JMS I	[ACSR
	CLA
	TAD	ACL	/NOW MOVE THE FAC DOWN A WORD SO THAT
	DCA	AC1	/WHEN WE MULTIPLY BY 10 THE OVERFLOW APPEARS
	TAD	ACH	/IN THE HIGH-ORDER WORD
	DCA	ACL
	TAD	SCALE
	SPA SNA		/DO WE HAVE DIGITS TO THE LEFT OF THE D.P.?
	JMP	PRZERO	/NO - PRINT A ZERO THERE
	JMS	DIGITS	/YES - PRINT THEM
PRDCPT,	TAD	IFLG
	SZA CLA
	JMP I	(IGEF	/IF I FORMAT, WE'RE DONE NOW
	AC7776
	JMS	DIGIT	/OTHERWISE PRINT DECIMAL POINT
	TAD	SCALE
	SMA CLA		/CHECK WHETHER WE NEED TO PRINT LEADING ZEROS
	JMP	NOLZRO	/NO
	TAD	SCALE
	DCA	T
LZLOOP,	STA CLL
	TAD	OD	/BUMP D VALUE DOWN BY ONE
	SNL		/IF IT GOES NEGATIVE,
	JMP	NOMOAC	/WE'VE RUN OUT OF FIELD WIDTH
	DCA	OD	
	JMS	DIGIT	/PRINT A ZERO
	ISZ	T	/UNTIL THE COUNT (OR THE WIDTH) RUNS OUT
	JMP	LZLOOP
NOLZRO,	TAD	OD
	SZA		/IF THERE ARE ANY DIGITS YET TO BE PRINTED,
	JMS	DIGITS	/PRINT THEM
/I,G,E,F OUTPUT CONVERSION - FINISH UP

NOMOAC,	CLA
	TAD	EFLG
	SNA CLA		/E FORMAT?
	JMP	CHKG	/NO - CHECK FOR G FORMAT OUTPUT AS F
	JMS 	EXPFLD
	JMP I	(IGEF
EXPFLD,	0
	TAD	(5
	JMS I	[FMTOUT	/OUTPUT "E"
	TAD	FMTNUM	/GET EXPONENT
	CLL
	SPA
	CML CIA		/SEPARATE INTO MAGNITUDE AND SIGN
	DCA	FMTNUM	/SAVE MAGNITUDE
	RTL
	TAD	(-5	/PRINT + OR -
	JMS	DIGIT
	DCA	T	/INITIALIZE QUOTIENT OF DIVISION
DVELP,	TAD	FMTNUM	/SUBTRACT 10 FROM EXPONENT
	TAD	[-12
	SPA		/DID IT GO NEGATIVE?
	JMP	PRNTXP	/YES - DONE
	DCA	FMTNUM	/NO - STORE IT BACK
	ISZ	T	/BUMP QUOTIENT
	JMP	DVELP	/LOOP
PRNTXP,	CLA
	TAD	T
	TAD	[-12
	SMA CLA
	JMP	ASTSK3
	TAD	T
	JMS	DIGIT
	TAD	FMTNUM
	JMS	DIGIT	/PRINT TWO DIGITS OF EXPONENT
	JMP I	EXPFLD

CHKG,	TAD	GFLG
	SNA		/WAS IT G FORMAT?
	JMP I	(IGEF	/NO - F OR I - DONE
	DCA	EFLG	/RE-SET EFLG SINCE WE ZEROED IT BEFORE
	TAD	(-5
	JMS	OBLNKS	/OUTPUT 4 BLANKS
	JMP I	(IGEF	/DONE WITH G FORMAT OUTPUT

PRZERO,	CLA		/COME HERE IF NO SIG. DIGITS LEFT OF D.P.
	JMS	DIGIT	/PRINT A ZERO
	JMP	PRDCPT	/CONTINUE

ASTSK3,	AC0002
	JMP	.+3
ASTSK1,	CLA		/CLEAR THE AC
	TAD	W	/GET THE FIELD WIDTH
	JMS I	[ASTRSK
	JMP I	(IGEF
/I,G,E,F OUTPUT CONVERSION - OUTPUT SUBROUTINES

OBLNKS,	0		/SUBROUTINE TO PRINT A STRING OF BLANKS
	DCA	AC1	/MUST LEAVE AC1 ZERO ON EXIT SO THAT
	JMP	.+3	/FAC LEFT SHIFT WON'T SHIFT IN GARBAGE LATER ON
	TAD	[40
	JMS I	[FMTOUT	/OUTPUT A BLANK
	ISZ	AC1
	JMP	.-3	/LOOP
	JMP I	OBLNKS	/RETURN

DIGITS,	0		/ROUTINE TO OUTPUT A STRING OF DECIMAL DIGITS
	CIA
	DCA	T
DGLOOP,	TAD	AC1
	DCA	AC2	/COPY AC INTO OPERAND FOR ADDITION LATER ON
	TAD	ACL
	DCA	OPL
	DCA	ACH	/CLEAR "OVERFLOW WORD"
	JMS I	[AL1
	JMS I	[AL1	/FAC=FAC*4
	DCA	OPH
	JMS I	[OADD
	JMS I	[AL1	/FAC=ORIGINAL FAC*10
	TAD	ACH	/GET OVERFLOW
	JMS	DIGIT	/PRINT IT
	ISZ	T	/LOOP FOR SPECIFIED NUMBER
	JMP	DGLOOP
	JMP I	DIGITS	/RETURN

DIGIT,	0		/ROUTINE TO OUTPUT A DIGIT
	TAD	[60
	JMS I	[FMTOUT	/TRIVIAL, ISN'T IT?
	JMP I	DIGIT
	PAGE
/I,G,E,F INPUT CONVERSION

IGEFIN,	STA		/OD CONTAINS SCALING IF NO D.P. IN INPUT
	DCA	DPSW	/INITIALIZE D.P. SW
	STA
	DCA	INESW	/DITTO EXPONENT SWITCH
	TAD	W
	CMA
	DCA	FMTNUM	/GET CHAR COUNT
INERSM,	DCA	ACX	/RE-ENTER HERE AFTER SEEING "E"
	DCA	ACH	/CLEAR FLOATING AC
	DCA	ACL
	STA
	JMP	INMINS	/SET SIGN PLUS

INGCH,	JMS I	[FMTIN	/GET A CHAR
	JMS I	[CHTYPE	/CLASSIFY IT
	1234;	IDIGIT	/DIGIT
	-56;	INDCPT	/.
	-53;	INLOOP	/+
	-55;	INMINS	/-
	-5;	INE	/E
	-40;	IBLDIG	/BLANK - TREAT LIKE 0 IN FORTRAN STANDARD
	-54;	INEONM	/,
	0		/OTHER - ERROR
INER,	JMS I	ERR

INDCPT,	DCA	OD	/ZERO COUNT OF DIGITS AFTER D.P.
	ISZ	DPSW	/TEST AND SET D.P. SWITCH
	JMP	INER	/WHOOPS - TWO D.P.S IN A NUMBER
	JMP	INLOOP	/KEEP GOING

IBLDIG,	TAD	EOLSW	/SINCE THE BLEEPING STANDARD DOESN'T COVER
	SZA CLA		/TELETYPE I/O, WE KEEP SOME COOL BY IGNORING
	JMP	INLOOP	/BLANKS CREATED BY EARLY LINE TERMINATION.

IDIGIT,	TAD	CHCH
	DCA	DGT+1	/SAVE THE DIGIT
	JMS I	[FPGO	/FORM 10*FAC + DIGIT IN FAC
	ACMDGT
	TAD	DPSW
	SNA CLA
	ISZ	OD	/BUMP DIGIT COUNT IF D.P. SEEN
	JMP	INLOOP
INMINS,	DCA I	[FFNEG	/SET SIGN NEGATIVE

INLOOP,	ISZ	FMTNUM
	JMP	INGCH	/LOOP UNTIL WIDTH EXHAUSTED
INEONM,	ISZ I	[FFNEG	/CHECK IF SIGN NEGATIVE
	JMS I	[FFNEG	/YES - NEGATE
	ISZ	INESW	/SEE IF "E" SEEN
	JMP	FIXUPE	/YES - WE HAVE EXPONENT, NOT NUMBER
	TAD	PFACTX	/NO "E" SEEN - SCALE USING P FACTOR

SCALIN,	TAD	OD	/GET SCALING FACTOR
	STL
	SNA
	JMP I	(IGEF	/NO SCALING NECESSARY
	SMA
	CIA CLL		/AC CONTAINS MAGNITUDE, LINK CONTAINS SIGN
	DCA	OD
	RTL
	RAL		/AC CONTAINS 0 IF DIVIDE, 4 IF MULTIPLY
	TAD	(FDIV10
	DCA	IGEFOP
	JMS I	[FPGO	/MULTIPLY OR DIVIDE BY 10.0
IGEFOP,	0
	ISZ	OD
	JMP	IGEFOP-1/MULT OR DIV APPROPRIATE NUMBER OF TIMES
	JMP I	(IGEF	/RETURN FOR MORE

INE,	ISZ	INESW	/SEE IF THIS IS THE SECOND "E"
	JMP	INER	/YES - ERROR
	ISZ	DPSW	/FORCE DP SW ON (TO INHIBIT D.P. AFTER E)
	TAD	OD	/USE SCALE FACTOR ONLY IF D.P. SEEN
	DCA	SCALE	/SAVE SCALE FACTOR
	ISZ I	[FFNEG
	JMS I	[FFNEG	/GET SIGN OF NUMBER CORRECT
	JMS I	[FPGO	/SAVE IT TEMPORARILY
	FSTTM2
	JMP	INERSM	/GO COLLECT EXPONENT

FIXUPE,	JMS I	[FFIX
	TAD	ACI	/GET EXPONENT
	CIA
	TAD	SCALE	/ADD IN EXPONENT TO D.P. SCALE FACTOR
	DCA	OD
	JMS I	[FPGO	/GET NUMBER BACK IN FAC
	FLDTM2
	JMP	SCALIN

DPSW,	0
DGT,	13;0;0;0;0;0
NOTG,	JMS I	(DIGCNT
	DCA	SCALDN
	TAD	IFLG
	SNA CLA
	JMP	NOTI
	TAD	SCALE
	TAD	(-7
	SPA CLA
NOTI,	TAD	SCALDN
	JMP I	(OUTNUM
SCALDN,	0		/SUBROUTINE TO SCALE THE FAC LESS THAN 1.0
	TAD	ACX
	SPA SNA CLA	/IS THE FAC => 1.0?
	JMP I	SCALDN	/NO - WE'RE DONE
	JMS I	[FPGO	/DIVIDE BY TEN
	FDIV10
	ISZ	SCALE	/BUMP POWER OF TEN
	0		/BACKUP FOR WIDTH
	JMP	SCALDN+1	/LOOP

ASTRSK,	0
	CIA
	DCA	T
	TAD	(52
	JMS I	[FMTOUT
	ISZ	T
	JMP	.-3
	JMP I	ASTRSK	/GET NEXT ELEMENT

INESW,	0		/"E SEEN" SWITCH ON INPUT
	PAGE
/L AND X FORMATS , T FORMAT INPUT

TFMTIN,	JMS I	[FMTIN	/FORCE INPUT BUFFER NON-EMPTY
	CLA		/BY FETCHING AND WASTING A CHARACTER
	TAD	(INBUFR
	DCA	INXR
	DCA	EOLSW	/SET TO BEGINNING OF LINE
	JMP	XFMT
XFMTIN,	JMS I	[FMTIN
H7600,	7600		/WASTE AN INPUT CHAR
XFMT,	JMS I	[MORE	/ANY MORE CHARS?
	TAD	RWFLAG	/YES - IN OR OUT?
	SMA CLA
	JMP	XFMTIN	/IN
TPPLBL,	TAD	[40	/HERE WITH AC=13 TO OVERPRINT ON T OUTPUT
	JMS I	[FMTOUT	/OUT
	JMP	XFMT

LINGCH,	JMS I	[FMTIN
	JMS I	[CHTYPE	/GET AND CLASSIFY CHARACTER
	-40;	LINLP	/BLANK
	-24;	LINTRU	/T
	-6;	LINFLS	/F
	0		/OTHER - ERROR
	JMP I	(INER

LINTRU,	TAD	(4001
LINFLS,	CLL RAR		/PUT EITHER 0.0 OR 1.0 IN THE FAC
	DCA	ACH
	DCA	ACL
	RAL
	DCA	ACX
LINLP,	ISZ	W
	JMP	LINGCH	/LOOP ON FIELD WIDTH

LNXT,	JMS I	[GETLMN	/GET NEXT ELEMENT FOR I/O
LFMT,	TAD	D
	CMA
	DCA	W	/SAVE WIDTH AS A COUNT
	JMS I	[SKPOUT	/IN OR OUT?
	JMP	LINFLS	/IN
	CLA IAC
	TAD	W
	JMS I	(OBLNKS	/OUTPUT W-1 BLANKS
	TAD	ACH
	SZA CLA
	TAD	(16
	TAD	(6	/NON-ZERO IS TRUE, ZERO FALSE
	JMS I	[FMTOUT	/OUTPUT T OR F
	JMP	LNXT	/NEXT VICTIM
/T FORMAT OUTPUT AND RANDOM SUBROUTINES

TFMT,	TAD	D
	CIA
	DCA	N	/USE N TO FAKE OUT "X" FMT ROUTINE
	TAD	RWFLAG
	SMA CLA
	JMP	TFMTIN	/INPUT
	TAD	N
	TAD	EOLSW	/COMPARE DESIRED POSITION WITH CURRENT ONE
	SPA
	JMP	TPBLNK	/AFTER - SPACE TO IT
	JMS	EOLINE	/OUTPUT CR AND ZERO EOLSW
	JMS I	[MORE	/KLUDGE FOR "T1" FORMAT
	TAD	(13	/FAKE X FORMAT INTO PRINTING
	JMP	TPPLBL	/A + AND (N-1) SPACES
TPBLNK,	DCA	N	/SAVE DIFFERENCE BETWEEN POSITIONS
	JMP	XFMT	/GO SPACE OUT

EOLINE,	0		/SUBROUTINE TO TERMINATE I/O LINE
	TAD	RWFLAG	/CAUTION - AC LO-ORDER BITS MAY NOT BE 0
	SPA CLA		/INPUT OR OUTPUT?
	JMP	EOOUTL	/OUTPUT
	JMS I	[FMTIN	/FORCE INPUT BUFFER NON-EMPTY
	CLA
	TAD	(INBUFR-1
	DCA	INXR	/SET XR TO NEGATIVE WORD AT THE
	JMP	.+3	/BEGINNING OF THE INPUT BUFFER
EOOUTL,	TAD	(7715
	JMS I	[FMTOUT	/OUTPUT A CARRIAGE RETURN
	DCA	EOLSW	/CLEAR EOLSW FOR INPUT AND OUTPUT
	JMP I	EOLINE
/ROUTINE TO MOVE A HANDLER INTO FIELD 0

GETHND,	0		/HANDLER CODE WORD IN AC ON ENTRY
	DCA	HCW	/SAVE HANDLER CODE WORD
	TAD	[7774
	AND	HCW	/KNOCK OUT ION AND FORMS CTL BITS
	CIA
	SZA		/IF HANDLER IS NOT RESIDENT,
	TAD	HKEY	/SEE IF THE HANDLER IS ALREADY
	SNA CLA		/IN THE HANDLER AREA IN FIELD 0
	JMP	HINF0	/YES
	TAD	HCW	/NO - PUT IT THERE
	AND	[70
	TAD	HCDF0
	DCA	HNDCDF	/GET CDF TO FIELD IN WHICH HANDLER RESIDES
	TAD	HCW
	AND	H7600
	TAD	(-1	/GET POINTER TO HANDLER ADDRESS
	DCA	XR1	/IN THAT FIELD
	TAD	(HPLACE-1
	DCA	XR	/ALSO TO HANDLER AREA IN FIELD 0
	TAD	[7400	/SET UP COUNT OF 7400
	DCA	HKEY	/INDEPENDENT OF HANDLER SIZE
HNDCDF,	HLT
	TAD I	XR1
HCDF0,	CDF 0
	DCA I	XR	/MOVE HANDLER INTO HANDLER AREA
	ISZ	HKEY
	JMP	HNDCDF
	TAD	[7774
	AND	HCW
	DCA	HKEY	/SET NEW KEY CODE WORD
HINF0,	CLA IAC
	AND	HCW
	SNA CLA		/INTERRUPTS ALLOWED?
YHIOF,	IOF		/NO - TOO BAD
	ISZ	CTCINH	/INHIBIT ^C DURING HANDLER CALL
	JMP I	GETHND
HKEY,	0
HCW,	0
	PAGE
/CHARACTER INPUT ROUTINE - LINE AT A TIME

FMTIN,	0
	TAD	EOLSW
	SNA		/END OF LINE ALREADY FOUND?
	TAD I	INXR	/NO - GET CHAR FROM LINE BUFFER
	SPA		/TIME TO READ A NEW LINE?
	JMP	READLN	/YES
	SNA		/END OF LINE?
	JMP	INEOL	/YES - SET INDICATOR
	AND	[77	/CONVERT TO SIXBIT
	JMP I	FMTIN	/RETURN WITH IT
INEOL,	TAD	[40
UNPKLN,	DCA	EOLSW	/SET EOL INDICATOR TO A BLANK
	JMP	FMTIN+1	/AND RETURN BLANKS FROM HERE ON IN
READLN,	DCA	EOLSW	/USE EOLSW AS A COUNT SO IT WINDS UP 0
	TAD	HAND
	TAD	(-TTY
	SNA CLA		/IS IT TELETYPE INPUT?
	STA		/YES - SET TTY FLAG
	DCA	TTYFLG
	JMS	ECHO
TTYLF,	12		/ECHO LF IF TTY INPUT
	TAD	[12	/TTYLF IS ZEROED BY ABORTO
	DCA	TTYLF

READLP,	CLA
	TAD	HAND
	SPA CLA		/CHARACTER ORIENTED DEVICE?
	JMP	MASSIN	/NO - UNPACK CHAR FROM BUFFER
	JMS I	HAND	/GET A CHARACTER
GOTCHR,	AND	[177	/STRIP OFF PARITY
	JMS I	[CHTYPE	/CLASSIFY IT
	-15;	INCRET	/CARRIAGE RETURN
	-177;	RUBOUT	/RUBOUT
	-11;	INTAB	/TAB
	-25;	CTRLU	/^U
	-32;	INEOF	/^Z
	0		/ANYTHING ELSE
	TAD	CHCH
	TAD	[-40
	SMA		/IF CHARACTER IS >37,
	JMS	INPUTC	/STORE IT AND ECHO IT IF TTY
	JMP	READLP
/CHARACTER INPUT ROUTINE - SPECIAL CHARACTER HANDLERS

INTAB,	JMS	INPUTC	/TAB - INSERT (AND ECHO) BLANKS
	TAD	INXR
	AND	[7
	SZA CLA		/UNTIL A COLUMN MULTIPLE OF 8 IS REACHED
	JMP	INTAB
	JMP	READLP

RUBOUT,	TAD	EOLSW
	CIA
	TAD I	(INBUFR	/IGNORE RUBOUTS IF LINE EMPTY
	AND	TTYFLG
	SNA CLA
	JMP	READLP	/OR IF NON-TTY INPUT
	JMS	ECHO
	134		/ECHO A BACKSLASH
IBAKUP,	STA
	TAD	INXR
	DCA	INXR	/BACK UP LINE POINTER
	STA
	TAD	EOLSW
	DCA	EOLSW	/AND CHAR COUNTER
	JMP	READLP

INEOF,	TAD	VEOFSW	/CHECK SWITCH SET BY "CHKEOF" LIBRARY ROUTINE
	SNA		/WAS HE EXPECTING AN EOF?
EOFERR,	JMS I	ERR	/NO
	JMS I	MCDF
	DCA	.+1
	HLT		/CDF TO FIELD OF INDICATOR VARIABLE
	AC2000
	DCA I	VEOFSW+1	/SET VARIABLE TO .5
	CDF 0		/FALL INTO CARRIAGE RETURN CODE

INCRET,	DCA I	INXR	/CARRIAGE RETURN - ZERO OUT REST OF LINE
	SKP
CTRLU,	STA		/SNEAKY, SNEAKY!
	TAD	(INBUFR
	DCA	INXR	/RESET XR TO FETCH LINE CHARS
	JMS	ECHO
	15		/ECHO THE C.R.
	JMP	UNPKLN	/BACK TO FETCH FIRST CHAR

INPUTC,	0		/ROUTINE TO STORE AND ECHO A CHAR
	TAD	[40
	DCA	INTMP
	JMS	ECHO
INTMP,	0		/ECHO CHAR IF TTY INPUT
	TAD	INTMP
	DCA I	INXR	/STORE CHAR IN LINE BUFFER
	ISZ	EOLSW
	JMP I	INPUTC	/RETURN IF NO OVERFLOW
	JMP	IBAKUP	/IGNORE CHAR IF OVERFLOW
ECHO,	0		/ROUTINE TO ECHO CHAR IF TTY INPUT
	TAD I	ECHO	/GET CHAR
	AND	TTYFLG
	SZA		/SHOULD WE ECHO?
	JMS I	HAND	/YES
	JMP I	ECHO	/RETURN TO CHARACTER - ITS SMALL
TTYFLG,	0

/CHARACTER INPUT ROUTINE - MASS STORAGE SECTION

MASSIN,	JMS	MASBMP	/GET BUFFER FIELD AND CHAR NUMBER
	JMP	INLORD	/CHAR 1 OR 2 - STRAIGHTFORWARD
	JMS I	(GETCH3	/USE COMMON SUBROUTINE
	JMP	MASICM	/GO TO COMMON CODE

INLORD,	JMS I	[MASSIO	/CHECK IF WE SHOULD READ IN A BUFFERLOAD
	JMS	BUFFLD	/SET FIELD OF BUFFER
	TAD I	CHRPTR
MASICM,	ISZ	CHRPTR	/GET THE CHAR (IN LOW 8 BITS) AND BUMP PTR
	NOP		/WATCH END OF FIELD FUNNYBUSINESS!
	CDF 0		/RESET DATA FIELD
	JMP	GOTCHR	/GO EXTRACT SEVEN BIT CHARACTER

MASBMP,	0
	JMS	BUFFLD	/SET TO BUFFER'S DATA FIELD
	ISZ	CHRCTR	/BUMP CHAR COUNTER
	JMP I	MASBMP	/CHAR 1 OR 2 - NO SWEAT
	AC7775
	DCA	CHRCTR	/CHAR 3 - RESET CHAR CTR
	AC7776
	TAD	CHRPTR	/BUMP BACK CHAR PTR
	DCA	CHRPTR
	ISZ	MASBMP
	JMP I	MASBMP	/SKIP RETURN
	PAGE
/CHARACTER OUTPUT ROUTINE

FMTOUT,	0
	TAD	[40	/FIRST CONVERT SIXBIT TO ASCII
	SMA		/CTL CHARS COME IN NEGATIVE
	AND	[77
	TAD	(240
	DCA	OCHAR	/SAVE ASCII CHAR (WITHOUT PARITY BIT)
	TAD	EOLSW
	SZA CLA
	JMP	NOT1ST	/FIRST CHAR IS DECODED FOR FORMS CONTROL
	AC0002		/CHECK TO SEE IF THIS UNIT
	AND	HCODEW	/SHOULD RECEIVE FORMS CONTROL
	SZA CLA
	JMP	LFPLCH	/NO - JUST PRINT A LINE FEED AND THE CHAR
	TAD	OCHAR
	JMS I	[CHTYPE	/CLASSIFY CONTROL CHAR
	-261;	OUTFFX	/1 - TOP OF FORM
	-260;	OUT2LF	/0 - DOUBLE SPACE
	-253;	NOLF	/+ - OVERPRINT
	0		/ANYTHING ELSE - SINGLE SPACE
	JMP	OUTLF

OUTFFX,	TAD	HAND
	TAD	(-TTY	/IF HANDLER IS TTY OUTPUT TWO LINE FEEDS
	SZA CLA		/INSTEAD OF A FORM FEED
	JMP	OUTFF
OUT2LF,	TAD	[12
	DCA	OCHAR	/SET 2ND CHAR TO LINE FEED
LFPLCH,	STA
	DCA	EOLSW	/SET SWITCH FOR 2ND CHAR
	TAD	OCHAR
	DCA	CHCH	/SAVE CHARACTER AWAY
OUTLF,	AC7776
OUTFF,	TAD	F214	/SUBSTITUTE THE APPROPRIATE FORM CONTROL
	DCA	OCHAR	/FOR THE CHARACTER
NOT1ST,	TAD	HAND
	SPA CLA		/CHARACTER ORIENTED DEVICE?
	JMP	MASOUT	/NO - PACK CHAR INTO BUFFER
	TAD	OCHAR
	JMS I	HAND	/OUTPUT CHAR
NOLF,	ISZ	EOLSW	/BUMP CHAR CTR
	JMP I	FMTOUT	/NO - RETURN
	TAD	CHCH	/AHA - ANOTHER CHARACTER SHOULD BE OUTPUT
	JMP	OUTFF+1	/GO TO IT
/CHARACTER OUTPUT - MASS STORAGE OUTPUT

MASOUT,	JMS I	(MASBMP	/GET BUFFER FIELD AND CHAR NUMBER
	JMP	OULORD	/CHAR 1 OR 2 - STRAIGHTFORWARD
	JMS	OSUBR	/CHAR 3 - PACK FIRST HALFBYTE
	JMS	OSUBR	/PACK SECOND HALFBYTE
	AC4000
	JMS	MASSIO	/CHECK IF WE SHOULD DUMP THE BUFFER
MASOCM,	CDF 0
	JMP	NOLF	/GO RETURN OR REENTER

OULORD,	TAD	OCHAR
	DCA I	CHRPTR	/STORE CHAR, ZAPPING HIGH-ORDER BITS
	ISZ	CHRPTR	/BUMP CHAR PTR
F214,	214		/GUARD AGAINST OVFLO
	JMP	MASOCM	/RETURN

OSUBR,	0		/ROUTINE TO PACK A HALFBYTE
	TAD	OCHAR
	CLL RTL
	RTL		/SHIFT CHAR 4 LEFT
	DCA	OCHAR
	TAD I	CHRPTR	/CLEAR OUT ANY RESIDUE
	AND	[377	/FROM HIGH-ORDER OF BUFFER WORD
	DCA I	CHRPTR	/IN CASE WE ARE WRITING AFTER A BACKSPACE.
	TAD	OCHAR
	AND	[7400	/GET 4 BITS
	TAD I	CHRPTR
	DCA I	CHRPTR	/ADD INTO HIGH-ORDER OF BUFFER WORD
	ISZ	CHRPTR	/BUMP POINTER
	200		/OVERFLOW!
	JMP I	OSUBR

MASSIO,	0		/SUBROUTINE TO READ/WRITE BUFFER IF NECESSARY
	CDF 0
	TAD	BUFCDF	/ADD BUFFER CDF TO R/W BIT IN AC
	TAD	(-6001	/TAKE AWAY CDF, LEAVE BIT 4 ON
	DCA	IOCTL	/STORE I/O CONTROL WORD
	TAD	CHRPTR
	AND	[377
	SZA CLA		/SEE IF POINTER IS AT BUFFER BOUNDARY
	JMP I	MASSIO	/YES - RETURN DOING NOTHING
	TAD	RELBLK
	TAD	STBLK	/STORE BLOCK # IN HANDLER CALL
	DCA	BLOCK
	TAD	BADFLD
	AND	[7400
	DCA	BUFFER	/STORE BUFFER ADDRESS IN HANDLER CALL
/CHARACTER OUTPUT - BUFFER I/O ROUTINE CONTINUED

	TAD	TOTBLK
	CIA CLL
	TAD	RELBLK
	SZL CLA		/CHECK FOR FILE OVERFLOW
IOVFLO,	JMS I	ERR	/YES - ERROR
	TAD	HCODEW
	JMS I	(GETHND	/GET HANDLER INTO FIELD 0
	JMS I	HAND	/CALL HANDLER
IOCTL,	0
BUFFER,	0
BLOCK,	0
	SMA CLA		/HANDLER ERROR - ABORT
	SKP		/IF NOT EOF
IOERR,	JMS I	ERR
	JMS I	(RECOVR	/CLEAR ANY FLAGS SET BY OS8 HANDLER
	ISZ	RELBLK	/BUMP RELATIVE BLOCK NUMBER
	TAD	BUFFER
	DCA	CHRPTR	/RESET CHAR PTR
	JMP I	MASSIO	/RETURN
/FPP CODE FOR I/O CONVERSION

FDIV10,	FDIV+LONG
	TEN
	FEXIT
OCHAR,	0		/*** NEEDED FOR PADDING ***
FMUL10,	FMUL+LONG	/FMUL10 MUST BE AT FDIV10+4
	TEN
	FEXIT

FWTOBL,	FSUB+LONG
	ONE
	FDIV+LONG
	FLTG85
	FEXIT
	PAGE
/UNFORMATTED (BINARY) INPUT-OUTPUT

RWUNF,	JMS I	[RWINIT	/"READ(N)" OR "WRITE(N)"
	1000		/"UNFORMATTED" BIT
	TAD	SZLCLA	/ENABLE SEQUENCE CHECKING
UNFIO,	DCA	SEQCHK	/*** SET SEQCHK TO "SZL CLA" OR "CLA"
	DCA	RECCTR	/ENTER HERE FROM DIRECT ACCESS
	TAD	HAND
	SMA CLA		/CHECK FOR MASS-STORAGE HANDLER
	JMP I	[UNTERR	/NO - ERROR
	JMS I	[GETLMN	/GET FIRST VARIABLE
	TAD	RWFLAG
	SPA CLA
RSETBP,	TAD	(125	/INITIALIZE COUNT TO -86 FOR WRITE,
	CMA		/-1 FOR READ
	DCA	CHRCTR
	TAD	BADFLD
	AND	[7400
	DCA	BIOPTR	/INITIALIZE BUFFER POINTER
	TAD	BADFLD
	AND	[70
	IAC
	CLL RTR		/AC BIT 0 NOW ON
	TAD	RWFLAG	/AC BIT 0 CONTAINS COMP. OF R/W FLAG
	CLL RAR		/AC=(.NOT.RW)*2000+BUFFER FIELD
	TAD	(FSTA+LONG	/AC=(FSTA OR FLDA) + BUFFLD
	DCA	FGPBF
	JMP	UIOVLP	/SKIP FIRST VARIABLE FETCH/STORE
BFINCR,	JMS I	[FPGO
	FGPBF		/LOAD OR STORE A BUFFER ENTRY
	ISZ	BIOPTR
	ISZ	BIOPTR	/INCREASE BUFFER POINTER
	ISZ	BIOPTR
	JMS I	[GETLMN	/GET A VARIABLE FROM THE CALLING PROGRAM
UIOVLP,	TAD	RWFLAG
	CLL RAR		/LOWORDER BIT OF RWFLAG = END LIST FLAG
	SZL CLA
	JMP	ENDUIO	/NO MORE VARIABLES - TERMINATE
	ISZ	CHRCTR	/BUMP COUNTER
	JMP	BFINCR	/ROOM IN BUFFER - MOVE VARIABLE
	JMS	UDOIO	/GET A NEW BUFFER
	JMP	RSETBP	/RESET BUFFER POINTERS AND COUNTERS

ENDUIO,	TAD	RWFLAG	/COME HERE WHEN I/O LIST EXHAUSTED
	SPA CLA		/WRITE?
	JMS	UDOIO	/YES - WRITE OUT THE LAST BUFFER
	JMP I	[ENDIO	/RESTORE DSRN ENTRY AND QUIT

RECCTR,	0
/DIRECT-ACCESS I/O

RWDACC,	JMS I	[RWINIT	/"READ(N'R)" OR "WRITE(N'R)"
	1000		/DIRECT ACCESS IS UNFORMATTED I/O
	TAD I	XR
	DCA	T	/GET BLOCKS/RECORD FACTOR FROM D.A. TABLE
	JMS I	[ARGLD	/GET RECORD NUMBER
	JMS I	[FFIX	/CONVERT TO INTEGER
	TAD	T
	TAD	ACI
	ISZ	T	/MULTIPLY RECORD NUMBER BY BLOCKS/RECORD
	JMP	.-2	/TO GET RELATIVE BLOCK NUMBER
	DCA	RELBLK
	TAD I	XR
	SNA		/THIS LOC SHOULD NOT BE ZERO!
DAERR,	JMS I	ERR
	DCA	FGPBF	/IT SHOULD BE AN FSTA + THE FIELD
	TAD I	XR	/IN WHICH THE CONTROL VARIABLE IS
	DCA	BIOPTR	/STORED. THE NEXT WORD IS THE ADDRESS
	JMS I	[FPGO	/OF THE CONTROL VARIABLE IN THAT FIELD
	FADD1		/ADD 1 TO RECORD # AND STORE IN CONTROL VAR
	TAD	DUMPIT	/*K* "DCA T" SAME AS "CLA" HERE
	JMP	UNFIO	/NOW GO DO A REGULAR BINARY READ/WRITE

UDOIO,	0
	ISZ	RECCTR	/BUMP NUMBER OF RECORDS TRANSFERRED
	TAD	BADFLD
	AND	[7400
	TAD	[377	/FORM POINTER TO LAST WORD IN BUFFER
	DCA	BIOPTR
	TAD	RECCTR
	JMS	BUFFLD
	DCA I	BIOPTR	/FOR WRITE, PUT RECORD NUMBER IN 256TH WORD
UDOIOL,	DCA	CHRPTR
	AC4000
	AND	RWFLAG
	JMS I	[MASSIO	/DO I/O (CHRPTR=0 TO FORCE I/O)
	JMS	BUFFLD
	TAD	RECCTR
	CMA STL		/FOR READ, CHECK THE INPUT
	TAD I	BIOPTR	/SEQUENCE NUMBER TO MAKE SURE IT IS
	CDF 0		/NO LARGER THAN THE ONE WE EXPECT.
SEQCHK,	SZL CLA		/*K* IF IT IS LARGER THIS IMPLIES THAT WE
	JMP I	UDOIO	/ARE STILL IN THE MIDDLE OF THE LAST
	JMP	UDOIOL	/RECORD AND SO WE READ AGAIN.
/DEFINE FILE PROCESSOR

DFINE,	JMS I	[RWINIT	/SET UP A POINTER INTO THE D.A. TABLE
	1000		/DIRECT ACCESS I/O IS UNFORMATTED
	JMS I	[ARGLD	/GET NUMBER OF RECORDS
	JMS I	[FFIX
	TAD	ACI
	CIA
DUMPIT,	DCA	T	/SAVE IT FOR MULTIPLY
	JMS I	[ARGLD	/GET THE NUMBER OF WORDS/RECORD
	JMS I	[FPGO	/CONVERT WORDS TO BLOCKS
	FWTOBL
	JMS I	[FFIX	/CONVERT TO INTEGER
	ISZ	ACI
	TAD	ACI	/MULTIPLY THE NUMBER OF BLOCKS/RECORD
	ISZ	T	/BY THE NUMBER OF RECORDS
	JMP	.-2
	DCA	RELBLK	/TO GET THE FILE LENGTH IN BLOCKS
	TAD	ACI
	CIA
	DCA I	XR	/STORE NUMBER OF BLOCKS/RECORD
	JMS I	[ARGLD	/GET POINTER TO CONTROL VARIABLE
	TAD	FGPBF
	TAD	(FSTA-FLDA	/CHANGE A LOAD TO A STORE
	DCA I	XR	/SAVE "FSTA CONTROL-VARIABLE"
	TAD	BIOPTR
	DCA I	XR
	TAD	TOTBLK
	CMA CLL
	TAD	RELBLK	/MAKE SURE WE HAVE ROOM FOR THE FILE
SZLCLA,	SZL CLA
DFERR,	JMS I	ERR	/WE DON'T
	AC7776
	AND	FFLAGS
	IAC		/FORCE "END-FILED" BIT FOR CLOSE
	JMP I	(SETTOT	/SET LENGTH AND EXIT
	PAGE
/SWAPPER AND ERROR ROUTINE

SWAP,	JMS I	[FETPC	/SWAPPER CALLING SEQUENCE:
	DCA	T	/	TRAP3 SWAP
	TAD	T	/	ADDR OVLY*4000000+LVL*100000+ENTRYADR
	AND	[7
	TAD	(JA
	DCA	STRTUP	/STORE JA TO ENTRY POINT
	JMS I	[FETPC
	DCA	STRTUP+1
	TAD	T
	AND	[70
	CLL RAR		/FORM 4*LVL
	TAD	(OVLYTB	/INDEX INTO LEVEL TABLE
	DCA	ADR
	TAD	T
	AND	[7400
	DCA	T	/T CONTAINS OVERLAY NUMBER IN BITS 0-3
	CDF 0		/WATCH D.F.!
	TAD I	ADR
	TAD	T	/SEE IF THIS OVERLAY IS IN CORE
	SNA CLA
	JMP	ITSIN	/YES - DON'T LOAD
	TAD	T
	CIA
	DCA I	ADR	/MARK THIS OVERLAY IN CORE (OPTIMIST)
	ISZ	ADR
	TAD I	ADR
	AND	[7400
	DCA	OVADR	/SAVE INITIAL OVERLAY LOAD ADDRESS
	TAD I	ADR
	AND	[70
	DCA	OVIOW	/AND FIELD
	ISZ	ADR
	TAD I	ADR	/GET STARTING BLOCK OF THIS LEVEL
	DCA	OVBLK
	ISZ	ADR
	TAD I	ADR
	DCA	OVLEN	/STORE LENGTH OF OVERLAY IN BLOCKS
OVADLP,	TAD	T	/LEVEL STARTING BLOCK +
	SNA		/(OVERLAY #) * (OVERLAY LENGTH)
	JMP	LOADOV	/= OVERLAY STARTING BLOCK
	TAD	[7400
	DCA	T
	TAD	OVBLK
	TAD	OVLEN
	DCA	OVBLK
	JMP	OVADLP
/SWAPPER - CONTINUED

LOADLP,	DCA	OVLEN	/STORE UPDATED OVERLAY LENGTH
	TAD	OVIOW	/GET LAST READ CONTROL WORD
	RAL
	AND	[7400	/CONVERT BLOCK COUNT TO WORD COUNT
	TAD	OVADR	/INCREMENT OVERLAY LOAD ADDRESS (LINK = 0)
	DCA	OVADR
	RTL
	RTL		/USE THE CARRY
	TAD	OVIOW	/TO INCREMENT THE LOAD FIELD IF NECESSARY
	AND	[70
	DCA	OVIOW	/OVIOW CONTAINS ONLY THE LOAD FIELD NOW

LOADOV,	TAD	OVADR
	CIA		/LOTSA CALCULATIONS HERE - OS/8 HANDLERS
	SNA		/CAN'T READ MORE THAN 15 BLOCKS AT A TIME
	TAD	[7400	/AND CANNOT READ OVER FIELD BOUNDARIES
	CLL RTL
	RTL		/SO WE MUST BREAK UP THE OVERLAY READ
	CMA CML RAL	/INTO SEVERAL SMALL READS OF MAXIMAL LENGTH.
	TAD	OVLEN	/THE NUMBER OF BLOCKS TO READ IS GIVEN BY:
	CMA		/MINIMUM(B,L,15)
	SMA		/WHERE B IS THE # OF BLOCKS LEFT IN THIS FIELD
	CLA		/AND L IS THE # OF BLOCKS LEFT IN THE OVERLAY
	TAD	OVLEN	/AND 15 IS THE # OF BLOCKS A HANDLER CAN READ
	DCA	T	/	ANSWER IN T
	TAD	T
	CLL RTR
	RTR
	RTR		/TURN NUMBER OF BLOCKS INTO 0S/8 BLOCK COUNT
	TAD	OVIOW
	DCA	OVIOW	/ADD FIELD BITS AND STORE AS I/O CONTROL WD
	TAD	OVHCDW	/GET OVERLAY HANDLER CODE WORD
	JMS I	(GETHND	/LOAD HANDLER INTO FIELD 0
	JMS I	OVHND
OVIOW,	0
OVADR,	0
OVBLK,	0
OVERR,	JMS I	ERR	/WHOOPS - OVERLAY READ ERROR
	JMS	RECOVR	/CLEAR ANY NASTY FLAGS LEFT BY HANDLER
	TAD	T
	TAD	OVBLK
	DCA	OVBLK	/UPDATE BLOCK NUMBER
	TAD	T
	CIA
	TAD	OVLEN	/BUMP DOWN RECORD COUNT
	SZA		/SEE IF WE ARE DONE
	JMP	LOADLP	/NO - PREPARE FOR NEXT READ
/OVERLAY IN CORE - EXECUTE IT

ITSIN,	JMS I	[FPGO	/START UP FPP
	STRTUP		/AND JA TO ENTRY POINT

TRAP5I,
TRAP6I,
TRAP7I,
FPAUSE,
FPPERR,	JMS I	ERR	/SHOULD NEVER GET HERE

STRTUP,	0;0		/JA ENTRY
OVLEN,	0
OVHND,	0		/SET BY LOADER
OVHCDW,	0		/SET BY LOADER

RECOVR,	0		/ROUTINE TO CLEAN UP ANY FLAGS
	DCA	CTCINH	/LEFT ON BY SLOPPY OS/8 HANDLERS.
YRCOVR,	NOP
	NOP
	NOP
	NOP		/RIGHT NOW I DON'T KNOW OF ANY.
	NOP
	NOP
	NOP
	NOP
	ION
	JMP I	RECOVR

FSTTMP,	FSTA+LONG
	FTEMP
	FEXIT

TEN,	4;2400;0;0;0;0	/10.0D0
FLTG85,	7;2520;0	/85.0
	PAGE
/INPUT BUFFER - CONTAINS STARTUP CODE

INBUFR,	-206		/LENGTH
	0		/INPUT LINE BUFFER - FIRST A LITTLE PADDING,

/RTS EXECUTION INITIALIZATION - IN INPUT BUFFER

FPSTRT,	6601		/CLEAR DF32 FLAG
	PCF		/HSP FLAG
	RRB		/HSR FLAG
PP7600,	7600		/CLEAR READER CHAR
	6135		/CLEAR KW12 OR DK8-EP EVENT FLAGS
	CLA
	6132		/STOP KW12 CLOCKS
	6134		/DISABLE KW12 INTERRUPTS
	6530		/CLEAR AD8-EA FLAGS
	6050		/CLEAR VC8/E FLAG
	6500		/DISABLE XY8/E INTERRUPTS
	STA
	6130		/DISABLE DK8-EP INTERRUPTS
	CLA		/LEAVE SPACE FOR ADDITIONAL CLEARS
	NOP
	NOP
	NOP
	NOP
	NOP
	NOP
	NOP
	NOP
	NOP
	NOP
	NOP
	DCA	EOLSW
LDPROG,	JMS I	[FPGO	/START UP FPP OR PSEUDO-FPP
	STSWAP
HLTNOP,	NOP		/SET TO HLT IF /H SPECIFIED,
	JMP	PRTCR	/SKP IF /P SPECIFIED
	TAD	.-1
	DCA	LDPROG	/BYPASS LOADING ON STARTUP
	TAD	PCHWD	/HLT
	DCA I	(PDPXIT+1
/ROUTINE TO PUNCH RTS+PROGRAM ON FORTRAN UNIT 9 (UNCOMMENTED)

PPTR,	TAD	P11
PCKSUM,	DCA	ACI
	JMS I	(LDDSRN
	SMA CLA
	JMP I	[UNTERR
	JMP	LDRTLR
FLDLP,	DCA	PPTR
	DCA	PCKSUM
	TAD	(100
	JMS	SIXOUT
	JMS	SIXOUT
	TAD	FLD
	AND	[70
JFMOUT,	JMS I	[FMTOUT	/*K* ONLY WORKS FOR FIELD 0-3
	TAD	(100
	JMS	SIXOUT
	JMS	SIXOUT
FLD,	CDF 0
	TAD I	PPTR
	CDF 0
	JMS	PCHWD
	ISZ	PPTR
P11,	11
	ISZ	PCTR
	JMP	FLD
	TAD	PCKSUM
	JMS	PCHWD
	TAD	FLD
	TAD	(10
	DCA	FLD
LDRTLR,	TAD	PP7600
	DCA	ACH
	TAD	[200
	JMS	SIXOUT
	ISZ	ACH
	JMP	.-3
	ISZ	FCNT
	JMP	FLDLP
	TAD	(6000
	DCA	FFLAGS
	DCA I	(ENDFLS	/*K* SAME KLUDGE AS CALXIT
	JMS I	(ENDFL
	DCA I	(PDPXIT+1	/WIPE HALT SO WE CAN RETURN TO OS/8
	JMP I	(PDPXIT-1
PCHWD,	HLT
	DCA	ACH
	TAD	ACH
	RTR
	RTR
	RTR
	AND	[77
	JMS	SIXOUT
	TAD	ACH
	AND	[77
	JMS	SIXOUT
	JMP I	PCHWD

SIXOUT,	0
	DCA	T
	CLA IAC
	DCA	EOLSW
	TAD	PCKSUM
	TAD	T
	DCA	PCKSUM
	TAD	T
	TAD	(-300
	JMS I	[FMTOUT
	JMP I	SIXOUT

PCTR,	200		/DON'T PUNCH 07600!
FCNT,	0
PRTCR,	TAD	(215
	JMS I	PTTY	/PRINT CARRIAGE RETURN
	TAD	JFMOUT
	DCA I	(ERRENB	/ENABLE ERROR TRACEBACK
	JMS I	[FPGO
	STJUMP		/NOW JUMP TO THE NEWLY-LOADED CODE
STSWAP,	TRAP3		/TRAP3
	SWAP
	0
	.+1
	TRAP3
	HLTNOP
	PAGE
STJUMP,	0
	0
	ZBLOCK	INBUFR+210-.	/PAD OUT TO END OF BUFFER
/OVERLAY AND DSRN TABLES

	*.-4	/FIRST ENTRY IN OVLYTB ONLY NEEDED TO LOAD MAIN PGM

OVLYTB,	ZBLOCK	40	/OVERLAY TABLE

DSRN,	PTR;	ZBLOCK	10
	PTP;	ZBLOCK	10
	LPT;	ZBLOCK	10
	TTY;	0;0
	1234		/*K* PREVENT PROBLEM IN
	ZBLOCK	5	/RWINIT INVOLVING WRITE
			/AFTER READ ON TELETYPE
	ZBLOCK	55

	ZBLOCK	12	/FORMAT PARENTHESIS PUSHDOWN LIST
FMTPDL,	0		/GUARD WORD
	PAGE
/SOFTWARE FLOATING POINT ROUTINES WHICH ARE USED
/EVEN IF FLOATING HARDWARE IS PRESENT

/** MUST NOT DESTROY FAC! **

FFIX,	0		/ROUTINE TO FIX FAC
	STA		/ANSWER IS RETURNED IN ACI
TADACX,	TAD	ACX	/ABS(FAC) MUST BE LESS THAN 2048
	CLL		/DETERMINE IF FAC EXPONENT IS
	TAD	(-13	/BETWEEN 1 AND 14
	SNA
	JMP	FIXBIG	/14 IS A SPECIAL CASE
EAEFIX,	DCA	ACI
	SZL
	JMP	FIXDNE	/EXP GT 14 OR LT 1 - RETURN 0
	TAD	ACH
	JMP	FIXISZ
FIXLP,	CLL		/0 IN LINK
	SPA		/IS IT LESS THAN 0?
	CML		/YES-PUT A 1 IN LINK
	RAR		/SCALE RIGHT
FIXISZ,	ISZ	ACI	/DONE YET?
	JMP	FIXLP	/NO
FIXDNE,	DCA	ACI	/RETURN WITH ANSWER IN ACI
	JMP I	FFIX	/RETURN

FIXBIG,	TAD	ACL	/IF EXP IS 14 WE MUST SHIFT AC FRACTION
	RAL		/LEFT ONE PLACE TO INTEGERIZE IT.
	CLA
	TAD	ACH
	RAL
	JMP	FIXDNE	/STORE ANSWER AND RETURN

SETB,	TAD	DATAF
	DCA I	(BASCDF	/SET BASE PAGE LOCATION
	TAD	ADR
	DCA	BASADR
	JMP I	FPNXT
/
/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 HIGH ORDER MANTISSA
	CLL
	SPA		/PROPAGATE SIGN
	CML
	RAR		/SHIFT RIGHT 1, PROPAGATING SIGN
	DCA	ACH	/STORE BACK
	TAD	ACL	/GET LOW ORDER
	RAR		/SHIFT IT
	DCA	ACL	/STORE BACK
	ISZ	ACX	/INCREMENT EXPONENT
	NOP
	ISZ	AC0	/DONE?
	JMP	LOP1	/NO-LOOP
	RAR
	DCA	AC1	/SAVE 1 BIT OF OVERFLOW
	JMP I	ACSR	/YES-RETN-AC=L=0
/
/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
OADD,	0		/ADD OPERAND TO FAC
	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.

FETPC,	0
	ISZ	PC
	JMP	PCCDF	/NO FIELD BUMP
	ISZ	APT	/BUMP FIELD FOR FPP RESTART (IN CASE FPP EXISTS)
FPC10,	10		/PROTECTION FOR ISZ
	TAD	PCCDF
	TAD	FPC10
	DCA	PCCDF
PCCDF,	HLT
	TAD I	PC
	JMP I	FETPC

EEPUT,	STL		/EXTENDED PRECISION STORE
EEGET,	DCA	ADR	/EXTENDED PRCISION FETCH
	TAD	[-6
	DCA	DATCDF
	SNL
	AC2000		/SET UP "TAD ACX" OR "DCA ACX"
	TAD	TADACX
	DCA	EEINST
EELOOP,	SNL		/LINK=1 MEANS STORE
	TAD I	ADR
EEINST,	HLT
	SZL
	DCA I	ADR
	ISZ	ADR
	SKP
	JMS I	(DFBUMP
	ISZ	EEINST
	ISZ	DATCDF
	JMP	EELOOP
	JMP I	FPNXT

FSTTM2,	FSTA+LONG
	FTEMP2
	FEXIT
/
FTEMP,	ZBLOCK	6
/
	PAGE
/RUN-TIME SYSTEM ERROR LIST

ERRLST,	VARGER;	ARGMSG
	UERR;	UMSG
	FPOERR;	FPOMSG
	FMTERR;	FMTMSG
	UNTERR;	UNTMSG
	CTLBER;	CTLBMS
	INER;	INMSG
	IOVFLO;	IOVMSG
	IOERR;	IOMSG
	DAERR;	DAMSG
	FPPERR;	FPPMSG
	OVERR;	OVMSG
	EOFERR;	INEMSG
	FPOVER;	OFLMSG
	DFERR;	DFMSG
	-1;	DV0MSG	/BY ELIMINATION
/RTS ERROR MESSAGES

ARGMSG,	TEXT	/BAD ARG/
UMSG,	TEXT	/USER ERROR/
FPOMSG,	TEXT	/PARENS TOO DEEP/
FMTMSG,	TEXT	/FORMAT ERROR/
UNTMSG,	TEXT	/UNIT ERROR/
INMSG,	TEXT	/INPUT ERROR/
OVMSG,	TEXT	/OVERLAY /
	*.-1
IOMSG,	TEXT	%I/O ERROR%
DAMSG,	TEXT	/NO DEFINE FILE/
FPPMSG,	TEXT	/FPP ERROR/
INEMSG,	TEXT	/EOF ERROR/
DV0MSG,	TEXT	/DIVIDE BY 0/
DFMSG,	TEXT	/D.F. TOO BIG/
IOVMSG,	TEXT	/FILE  /
	*.-1
OFLMSG,	TEXT	/OVERFLOW/
CTLBMS,	TEXT	/^B/

USRERR,	TAD	ERRFLG	/USER ERROR - OPTIONALLY NON-FATAL
	DCA	FATAL
UERR,	JMS I	ERR	/PRINT MESSAGE
	JMP I	[RETURN	/IF NON-FATAL, CONTINUE PROCESSING
ERRFLG,	0		/SET TO NON-ZERO IF /E SWITCH SPECIFIED

TRPPRT,	TRAP3		/CODE WHICH IS LOADED INTO PROGRAM PROLOGUES
	PRTNAM		/BY THE ERROR TRACEBACK ROUTINE
	PAGE
MAKCDF,	0		/ROUTINE TO MAKE A CDF FROM AC9-11
	RTL
	RAL
	AND	[70
	TAD	ERCDF	/STRAIGHTFORWARD ENOUGH, ISN'T IT?
	JMP I	MAKCDF

RD2WR,	0		/ROUTINE CALLED WHEN SWITCHING
	STA		/FROM READ TO WRITE. (CALLED ONLY ONCE!)
	TAD	RELBLK	/BUMP BLOCK # BACK FROM "NEXT BUFFER'S BLOCK #"
	DCA	RELBLK	/TO "THIS BUFFER'S BLOCK #".
	TAD	CHRCTR	/HOWEVER, IF WE ARE AT THE VERY END OF A
	IAC		/BUFFER, WRITE ROUTINE EXPECTS US TO
	SZA CLA		/BE AT THE BEGINNING OF THE NEXT BUFFER,
	JMS I	[MASSIO	/SO RE-READ THIS BUFFER AND SET POINTERS
	JMP I	RD2WR

/RUN-TIME-SYSTEM ERROR ROUTINE

ERROR,	0
ERCDF,	CDF 0
	CLA
	TAD	(ERRLST-2
	DCA	XR
ERRLP,	ISZ	XR	/SEARCH ERROR LIST FOR CALLING ADDRESS
	TAD I	XR	/ERROR LIST CONTAINS
	CMA
	SZA		/CALLING ADDRESSES AND
	TAD	ERROR	/CORRESPONDING MESSAGES
	SZA CLA
	JMP	ERRLP
	TAD I	XR
	DCA I	(FMTADR
	DCA I	(FMTDF
	TAD	PTTY
	DCA	HAND	/QUICK FUDGE FOR TTY OUTPUT
	DCA	HCODEW	/TO SET CARRIAGE CONTROL
	AC4000
	DCA	RWFLAG
	JMS I	[EOLINE	/TYPE CARRET AND SET EOLSW
	DCA	FMTBYT	/INITIALIZE MESSAGE PTR
ERPTLP,	JMS I	[FMTOUT	/OUTPUTS LF FIRST TIME
	JMS I	[FMTGCH	/GET CHAR USING FORMAT ROUTINES
	ISZ	FMTBYT
	SZA
	JMP	ERPTLP	/LOOP UNTIL 0 CHAR
/PRINT ROUTINE NAME AND LINE NUMBER

PRTNAM,	TAD	[40
ERRENB,	JMP I	E7605	/*K* IN CASE INITIALIZATION OR /P GET ERRORS
/		PREVIOUS LINE REPLACED WITH:
/	JMS I	[FMTOUT	/OUTPUT A BLANK(LF ON EXTRA LINES)
	JMS I	[FPGO	/START UP FPP
	GTNMPT		/GET POINTER TO NAME IN FAC
	TAD	ACH
	DCA I	(FMTDF	/SET UP FORMAT GET CHARACTER ROUTINE
	TAD	ACL	/TO GET CHARACTERS OF ROUTINE NAME
	DCA I	(FMTADR
	DCA	FMTBYT
	TAD	[-6
	DCA	ISN	/6 CHARACTER NAME
PRTNML,	JMS I	[FMTGCH
	SNA
	TAD	[40	/AVOID PRINTING RANDOM @S
	JMS I	[FMTOUT	/GET AND PRINT A CHARACTER
	ISZ	FMTBYT
	ISZ	ISN
	JMP	PRTNML
	TAD	[40
	JMS I	[FMTOUT	/SEPARATE THE NAME BY A SPACE
	TAD	[-4	/FROM THE LINE NUMBER.
	DCA	ISN
PTLNLP,	TAD	ISN+1
	CLL RTL
	RAL
	DCA	ISN+1	/PRINT LINE NUMBER IN OCTAL
	TAD	ISN+1	/BECAUSE THAT IS THE WAY IT APPEARS
	RAL		/IN THE FORTRAN PROGRAM LISTING
	AND	[7
	JMS I	(DIGIT
	ISZ	ISN
	JMP	PTLNLP

	JMS I	[EOLINE	/OUTPUT FINAL CR
	TAD	FATAL
	SNA CLA		/FATAL ERROR?
	JMP	TRCBAK	/YES - GIVE FULL TRACEBACK
	DCA	FATAL	/"NON-FATAL" FLAG MUST BE SET EACH TIME
	JMP I	ERROR
TRCBAK,	JMS I	[FPGO	/START UP FPP
	UP1LEV		/MOVE UP TO CALLING ROUTINE
			/FPP CODE DOES A "TRAP3 PRTNAM"
ISN,	0;0
/FPP CODE FOR ERROR ROUTINE

GTNMPT,	STARTD
	XTA	0	/LOAD LINE NUMBER FROM XR 0
	FSTA+LONG
	ISN		/STORE AWAY
	FLDA+BASE 10	/LOAD POINTER TO PROLOGUE
	FSUB+LONG
	THREE		/NAME IS 3 LOCATIONS BEFORE PROLOGUE
	STARTF		/FOR NON-FPP VERSION
THREE,	FEXIT;3		/*K* DEPENDS ON FACT THAT FEXIT=0

UP1LEV,	STARTD
	FLDA+BASE 11	/GET THE UPWARD POINTER
	JNE
	NOTMN		/ZERO MEANS MAIN PROGRAM
	TRAP3
E7605,	7605		/GO AWAY IF MAIN PROGRAM
NOTMN,	FSTA+BASE 0
	LDX	1
	2		/WE WILL STORE A "TRAP3 PRTNAM"
	FLDA+LONG	/IN THE FIFTH LOCATION OF THE PROLOGUE,
	TRPPRT
	FSTA+IND 0+10	/WHERE THE FIRST 4 LOCS WERE A SETX AND SETB.
	FLDA+BASE 0	/GET THE PROLOGUE ADDRESS AGAIN
	JAC		/JUMP TO IT.

ACMDGT,	FMUL+LONG
	TEN
	FSTA+LONG
	FTEMP
	FLDA+LONG
	DGT		/GET UNNORMALIZED DIGIT INTO AC
	FNORM		/NORMALIZE IT
FADTMP,	FADD+LONG
	FTEMP
	FEXIT
LPBUFR,	ZBLOCK	4
	LPBUF2
	PAGE
HPLACE,	/ZBLOCK	400	/HANDLER SWAP AREA

/VARIOUS INITIALIZATION STUFF OVERLAYING THE RTS HANDLER AREA

QLHDR,	0		/SHOULD BE A 2 FOR A LOADER IMAGE
QRTSWP,	ZBLOCK	2	/INITIAL SWAP ARGS TO LOAD USER MAIN
QHGHAD,	ZBLOCK	2	/HIGHEST ADDRESS USED
QVERNO,	0		/LOADER VERSION #
QDPFLG,	0		/"PROGRAM USES D.P." FLAG
QUSRLV,	ZBLOCK	40	/USER OVERLAY INFO

/EAE OVERLAY TO FIX AND FLOAT

EFXFLT,	RELOC	EAEFIX

FIXEAE,	CMA
	DCA	FIXSH	/SHIFT COUNT BETWEEN 0 AND 12
	SZL
	JMP	FIX0	/NOT INTEGERIZABLE
	TAD	ACH
	ASR
FIXSH,	0
FIX0,	DCA	ACI
	JMP I	FFIX

FXFLTC=	.-FIXEAE
	RELOC
/SUBR TO DETERMINE MACHINE SIZE - RETURNS NUMBER OF
/BANKS IN AC.
/MUST RUN IN FIELD 0.

CORE,	0
	TAD	C6203
	RDF
	DCA	CORRET
CORELP,	CDF 0		/NEEDED FOR PDP-8L
	TAD I	C7777
	AND	COR70	/IF BITS 6-8 OF LOCATION 7777 ARE NOT ZERO,
	CLL RTR		/THEY SPECIFY THE LAST FIELD OF CORE
	RAR		/WHICH WE SHOULD USE.
	SZA
	JMP	CORRET	/SO RETURN THAT AMOUNT
	TAD TRYFLD	/GET FLD TO TST
	CLL RTL
	RAL
	AND	COR70	/MASK USEFUL BITS
	TAD	CORELP
	DCA	COR706	/SET UP CDF TO FLD
COR706,	0
	TAD I	CORLOC	/SAV CURRENT CONTENTS
	NOP		/HACK FOR PDP-8
	DCA	.-3
	TAD	.-2	/7000 IS A GOOD PATTERN
	DCA I	CORLOC
COR70,	70		/HACK FOR PDP-8.,NO-OP
	TAD I	CORLOC	/TRY TO READ BK 7000
CO7400,	7400		/HACK FOR PDP-8,.NO-OP
	TAD	CO7400	/GUARD AGAINST WRAP AROUND
	TAD	CORLOC+1	/TAD 1400
	SZA CLA
	JMP	.+5	/NON EXISTENT FLD EXIT
	TAD	COR706	/RESTORE CONTENS DESTROYED
	DCA I	CORLOC
	ISZ	TRYFLD /TRY NXT HIGHER FLD
	JMP	CORELP
	STA
	TAD	TRYFLD
CORRET,	0
	JMP I	CORE
CORLOC,	CO7400		/ADR TO TST IN EACH FLD
	1400		/7000+7400+1400=0
TRYFLD,	1		/CURRENT FLD TO TST
C6203,	6203
C7777,	7777

DPTEST,	STARTE		/EXECUTED BY FPP DURING INITIALIZATION
	FEXIT		/CHECK WHETHER DOUBLE PRECISION ENABLED
/TABLE OF MODIFICATIONS TO MAKE TO FRTS FOR BACKGROUND OPERATION
/UNDER RTS-8.  FORMAT OF TABLE IS: POINTER TO FIRST WORD OF BLOCK - 1
/ (0 TERMINATES) FOLLOWED BY LIST OF REPLACEMENT WORDS (0 TERMINATES).

BKRLST,	YLPT-1		/LINE PRINTER OUTPUT ROUTINE
	RELOC	YLPT
	LLS
	CLA		/DON'T DO RING-BUFFERING - JUST "OUTPUT" CHAR.
	JMS	CTCBCK	/CHECK FOR ^C OR ^B
	JMP I	LPT
FJCTCT,	JMS	CTCBCK	/COME HERE FROM INTERPRETED FPP JUMPS
	JMP I	FPNXT	/CHECK FOR ^C,^B AND RETURN TO INTERPRETER
	RELOC
	0

	YPTP-1		/PAPER-TAPE PUNCH ROUTINE
	CLA		/ALL PAPER-TAPE I/O ILLEGAL
	0
	YPTR-1		/PAPER TAPE READER ROUTINE
	CLA		/ALL PAPER-TAPE I/O ILLEGAL
	0

	YTTY-1		/TELETYPE INPUT/OUTPUT ROUTINE
	RELOC	YTTY
	SNA
	JMP	KBDRTS	/AC=0 MEANS INPUT
	TSF
	JMP	.-1	/HANG UNTIL OUTPUT BUFFER NOT FULL
	TLS
	CLA
	JMS	CTCBCK	/CHECK FOR ^C OR ^B TYPED
	JMP I	TTY
KBDRTS,	KSF
	JMP	.-1	/HANG UNTIL CHAR RECEIVED
	JMS	CTCBCK	/CHECK FOR ^C OR ^B
	KRB
	AND	KB177	/STRIP PARITY
	TAD	KB177
	IAC		/NOW FORCE PARITY BIT ON (177+1=200)
	JMP I	TTY

CTCBCK,	.		/*K* CAN'T BE 0!
	KRS		/PEEK AT NEXT CHAR IN BUFFER
	AND	KB177
	TAD	KBM2
	CLL RAR
	SNA CLA		/IS IT ^C OR ^B?
	KSF		/AND IS IT REALLY PENDING?
	JMP I	CTCBCK	/NO - JUST RETURN WITH AC=0
	JMP	BEEORC	/TERMINATE JOB - LINK HAS ^C/^B FLAG
KB177,	177
KBM2,	-2
	RELOC
	0
/CONTINUATION OF TABLE OF RTS-8 OVERLAYS TO FRTS

	YHIOF-1		/"GET OS/8 HANDLER" ROUTINE
	NOP		/ELIMINATE "IOF" INSTRUCTION
	0

	YRCOVR-1	/"RECOVER FROM OS/8 HANDLER" ROUTINE
	RELOC	YRCOVR
	JMP I	RECOVR	/SHORT-CIRCUIT PORTION OF ROUTINE WHICH DOES
	RELOC		/AN "ION"
	0

	YFJMP-1		/FPP INTERPRETER - SUCCESSFUL JUMP SECTION
	FJCTCT		/TEST FOR ^C OR ^B TYPED BEFORE
	0		/RETURNING TO THE INTERPRETER

	0		/** LIST TERMINATOR **
/ERROR MESSAGES FOR RUN-TIME LOADER - IN HANDLER BUFFER
/*K* CANNOT LOAD BELOW HPLACE+200 AS HPLACE-HPLACE+177 ARE DESTROYED BY HEADER!

	IFNZRO	.-HPLACE-200&4000	<__ERROR__>

NOLI,	TEXT	/NOT A LOADER IMAGE/
NONMSG,	TEXT	/NO NUMERIC SWITCH/
FILMSG,	TEXT	/FILE ERROR/
SYSMSG,	TEXT	/SYSTEM DEVICE ERROR/
TOOMCH,	TEXT	/MORE CORE REQUIRED/
TOMNYH,	TEXT	/TOO MANY HANDLERS/
LIOEMS,	TEXT	/CAN'T READ IT!/
NODPMS,	TEXT	/CAUTION - NO DP/
XVERMS,	TEXT	/FRTS V/
	*.-1
	XVERSN&70^7+XVERSN+4060		/VERSION NUMBER IN SIXBIT
	XPATCH&77^100+40		/PATCH LEVEL
	TEXT	/     /
	PAGE
/FPP INTERPRETER STARTUP ROUTINE

FPPINT=	.		/FOR FPP OVERLAY
RETURN,	JMP I	FPNXT	/RETURN DOES SOMETHING DIFFERENT IF FPP PRESENT

FPGO,	0
FPGCDF,	CDF 0		/NECESSARY?
	CLA
	TAD	PC
	DCA	SAVPC	/ALLOW ONE LEVEL OF RECURSIVENESS
	TAD I	(PCCDF
	DCA	SPCCDF
	STA
	TAD I	FPGO
	DCA	PC
	ISZ	FPGO
	TAD	FPGCDF	/FPGO STARTS UP THE FPP FROM FIELD 0 ONLY
	DCA I	(PCCDF
	JMP I	FPNXT

EXIT,	TAD	SAVPC
	DCA	PC
	TAD	SPCCDF
	DCA I	(PCCDF	/RESTORE OLD PC
	JMP I	FPGO	/RETURN TO PDP-8 CODE
SAVPC,	0
SPCCDF,	0

FPXTA,	TAD	[27	/XR TO AC - NORMALIZE IF FLOATING MODE
	DCA	ACX
	JMS	DATCDF
	TAD I	ADR
CLFAC,	DCA	ACL
	TAD	ACL
	SPA CLA		/SIGN-EXTEND 12-BIT WORD
	STA		/INTO FAC FRACTION
	DCA	ACH
NRMFAC,	DCA	AC1	/CLEAR OVERFLOW WORD
	TAD	DFLG
	SPA SNA CLA	/UNLESS WE ARE IN D.P.I. MODE,
	JMS I	NORMX	/NORMALIZE THE FAC
	JMP I	FPNXT
/MISCELLANEOUS JUMP CLASS INSTRUCTIONS

JSA,	TAD	ADR
	DCA	PUTM
	TAD	DATAF
	DCA	JSCDF	/SET UP LOC TO SAVE PC IN
	AC0002
	TAD	ADR
	DCA	ADR	/BUMP ADDRESS BY 2
	RTL
	RTL
	TAD	DATAF
	DCA	DATAF	/INCLUDING DATA FIELD
JSAR,	TAD I	(PCCDF	/JSA/JSR COMMON CODE
	CLL RTR
	RAR
	ISZ	PC	/BUMP PC BEFORE STORING
	SKP
	IAC		/INCLUDING FIELD BITS
	TAD	(JA-2620	/FORM "JA" INSTRUCTION
JSCDF,	HLT
	DCA I	PUTM
	ISZ	PUTM
	SKP
	JMS I	(DFBUMP	/BUMP TARGET ADDRESS
	TAD	PC
	DCA I	PUTM
	JMP I	(DOJMP	/NOW JUMP TO DESTINATION

JSR,	CLA CLL IAC
	TAD	BASADR
	DCA	PUTM
	RTL
	RTL
	TAD I	(BASCDF	/SET JSCDF&PUTM TO BASE PAGE LOC +1
	DCA	JSCDF
	JMP	JSAR

FPJAC,	TAD	ACL
	DCA	ADR
	TAD	ACH
	JMS I	MCDF
	DCA	DATAF
	JMP I	(DOJMP

SPCATX,	TAD	ACL
	SKP
FPLDX,	JMS I	[FETPC
	JMS	DATCDF
	DCA I	ADR	/SET XR TO NEXT INST WD
	JMP I	FPNXT
/MORE INDEX REGISTER & AC-TO-MEMORY INSTRUCTIONS

ADDX,	JMS I	[FETPC
	JMS	DATCDF
	TAD I	ADR	/ADD NEXT INST WD TO XR
	JMP	FPLDX+1

ATX,	TAD	DFLG	/ATX WORKS DIFFERENTLY IN D.P.I. MODE
	SMA SZA CLA
	JMP	SPCATX
	JMS I	NORMX	/FAC MAY NOT BE NORMALIZED
	JMS I	[FFIX
	TAD	ACI
	JMP	FPLDX+1

OPMEM,	DCA	AD1	/GENERAL AC-TO-MEMORY INTERPRETER
	TAD	AD1
	DCA	AD2
	RDF
	CLL RTR
	RAR
	TAD	KLUDGM	/FORM FSTA X INSTRUCTION
	DCA	PUTM
	AC2000
	AND	INST	/TURN OP 5 TO OP 1,
	SZA CLA
	TAD	[3000	/     OP 7 TO OP 4.
	TAD	[3000
	TAD	PUTM	/STICK IN FIELD BITS
	DCA	OPM
	JMS I	[FPGO
	KLUDGM
	JMP I	FPNXT

KLUDGM,	FSTA+LONG
	FTEMP		/SAVE AC
OPM,	0
AD1,	0		/PERFORM OP
PUTM,	0
AD2,	0		/STORE RESULT
	FLDA+LONG
	FTEMP		/RESTORE AC
	FEXIT

NORMX,	FFNOR		/*K* CHANGED TO EFFNOR IF EAE
	PAGE
/MAIN INTERPRETER LOOP

NEGFAC,	JMS I	[FFNEG

ICYCLE,	CLA
	JMS I	[FETPC	/GET INST
	DCA	INST
	TAD	INST
	CLL RTL
	RTL
	SMA		/SKIP IF BASEPAGE ADDRESSING
	JMP	LONGI
	AND	[7
	TAD	BASJMP
	DCA	OPJMP	/SAVE OPCODE CALL ADDRESS
	TAD	INST	/DATA FIELD IS STILL SET UP
	SZL		/SO IS LINK (WITH INSTRUCTION BIT 3)
	JMP	BPAGEI	/INDIRECT ADDRESSING
	CLL RAL
	TAD	INST	/MULTIPLY BASE OFFSET BY 3
	TAD	[200	/ELIMINATE ANY
	AND	(777	/HIGH ORDER BITS
IMFUDJ,	CLL		/CLL IAC IF D.P. INTEGER MODE
	TAD	BASADR	/ADD IN BASE PAGE ORIGIN
BASCDF,	HLT		/CDF TO BASE PAGE FIELD
	SZL
	JMS	DFBUMP	/BUMP DF IF ADDITION OVERFLOWED
OPJCLL,	CLL
OPJMP,	HLT		/JMP I EXECUTIONROUTINE

BPAGEI,	AND	[7
	DCA	ADR
	TAD	ADR
	CLL CML RAL
	TAD	ADR	/FORM 3*OFFSET+1
	TAD	BASADR
	DCA	ADR
	RTL
	RTL
	TAD	BASCDF	/FORM PROPER CDF
	DCA	ADDRLO
ADDRLO,	HLT		/EXECUTE IT
	TAD I	ADR	/GET FIELD BITS OF REAL ADDRESS
	DCA	ADDRHI	/FROM 2D WORD OF BASE PAGE LOC
	ISZ	ADR
	SKP
	JMS	DFBUMP	/WATCH FOR FIELD OVERFLOW
	TAD I	ADR	/GET LOW-ORDER ADDRESS FROM 3D WORD
	JMP	INDEX	/NOW GO DO INDEXING (IF ANY)
/COME HERE IF BIT 4 OF INSTRUCTION IS OFF

LONGI,	AND	[7
	SNL		/TEST BIT 3 OF INSTRUCTION
	JMP I	(SPECAL	/SPECIAL INSTRUCTION
	TAD	BASJMP
	DCA	OPJMP
	TAD	INST
	DCA	ADDRHI	/HIGH-ORDER ADDRESS BITS IN INST WD
	JMS I	[FETPC	/NEXT INST WORD CONTAINS LOW-ORDER ADDRESS
INDEX,	DCA	ADDRLO
	TAD	INST
	AND	[70
	SNA		/IS XR NUMBER 0?
	JMP	NOINDX	/YES - NO INDEXING
	JMS	DCDIDX	/GET XR VALUE (MAYBE INCREMENTED)
	AC7775
	TAD	DFLG	/GET -3 IF F, -2 IF D, -6 IF E MODE
	DCA	DCDIDX
	TAD	ADDRLO
XRADLP,	CLL
	TAD I	T
	SZL
	ISZ	ADDRHI
	ISZ	DCDIDX	/ADD THE XR IN THE PROPER NUMBER OF TIMES
	JMP	XRADLP
	DCA	ADDRLO
NOINDX,	TAD	ADDRHI
	JMS I	MCDF
	DCA	ADDRHI	/TURN HIGH-ORDER ADDRESS INTO A CDF
ADDRHI,	HLT		/AND EXECUTE IT
	TAD	ADDRLO
	JMP	OPJCLL	/GO EXECUTE THE INSTRUCTION

DFBUMP,	0		/BUMP DATA FIELD
	DCA	DFTMP	/SAVE AC
	RDF
	TAD	(CDF 10
	DCA	.+1
	HLT
	TAD	DFTMP	/RESTORE AC
	JMP I	DFBUMP
DFTMP,	0
DCDIDX,	0
	CLL RTR
	RAR
	TAD	XRBASE	/ADD IN BASE ADDRESS OF XR ARRAY
XRCDF,	HLT		/CDF TO XR ARRAY FIELD
	SZL
	JMS	DFBUMP	/OR MAYBE NEXT FIELD
	DCA	T	/SAVE POINTER TO XR
	TAD	INST
	AND	DCD100
	SZA CLA		/INCREMENT BIT ON?
	ISZ I	T	/YES - BUMP XR
DCD100,	100		/** PROTECTION
	JMP I	DCDIDX

BASJMP,	JMP I	JMPTB1	/JMP I JMPTB2 FOR D.P. MODE

JMPTB1,	FFGET		/ F MODE (FLOATING POINT)
	FFADD
	FFSUB
	FFDIV
	FFMPY
	OPMEM	/FADDM
	FFPUT
	OPMEM	/FMULM

	DDGET		/ D MODE ( DOUBLE PRECISION INTEGER)
	DDADD
	DDSUB
	DDDIV
	DDMPY
	OPMEM	/DADDM
	DDPUT
	OPMEM	/DMULM

	EEGET		/ E MODE ( 6 WD FLOATING POINT)
	FFADD
	FFSUB
	FFDIV
	FFMPY
	OPMEM
	EEPUT
	OPMEM
	PAGE
/MORE I CYCLE

SPECAL,	SNA
	JMP	XRINST	/OPCODE 0 HAS MANY MANSIONS
	TAD	SPECOP
	DCA	SPCJMP	/GET OPCODE JUMP ADDRESS
	JMS I	[FETPC
	DCA	ADR
	TAD	INST	/ALL OF THESE ARE TWO-WORD INSTRUCTIONS
	JMS I	MCDF	/SO FORM THE ADDRESS NOW
	DCA	DATAF
	CDF 0
	TAD	INST
SPCJMP,	HLT

XRINST,	TAD	INST
	AND	(7770
	CDF 0
	SNA CLA		/IF SUB-OPCODE IS ZERO,
	JMP	OPERAT	/DECODE SUB-SUB-OPCODE
	TAD	INST
	AND	[7
	CLL
	TAD	XRBASE
	DCA	ADR	/COMPUTE INDEX REGISTER ADDRESS
	RTL
	RTL
	TAD I	(XRCDF
	DCA	DATAF
XJCOMN,	TAD	INST
	CLL RTR
	RAR
	AND	[77	/GET OPCODE - HIGH ORDER 2 BITS ARE 0
OXCOMN,	TAD	(JMP I SP2
	DCA	.+1	/EXECUTE APPROPRIATE JUMP
	HLT

OPERAT,	TAD	INST
	CIA
	JMP	OXCOMN

SETX,	TAD	DATAF	/SET XR0 LOC
	DCA I	(XRCDF
	TAD	ADR
	DCA	XRBASE
	JMP I	FPNXT
/JUMP DECODER

JUMPS,	AND	(100	/INSTRUCTION IN AC
	CLL RTR		/20 IN AC IF NOT COND. JUMP
	SZA		/IF NOT COND. JUMP, DECODE FURTHER
	JMP	XJCOMN
	TAD	INST
	AND	[70
	CLL RTR
	RAR
	TAD	(CNDSKT
	DCA	T	/INDEX INTO CONDITIONAL SKIP TABLE
	TAD I	T
	DCA	CNDSKP
	TAD	ACH
	SZA
	JMP	CNDSKP
	TAD	ACL
	SZA CLA		/IF HIGH ORDER ZERO, AC MIGHT BE UNNORMALIZED.
	IAC		/USE LOW ORDER ON 0/NOT 0 BASIS
CNDSKP,	HLT		/TEST AC
	JMP I	FPNXT	/FAILED - DON'T JUMP

DOJMP,	STA CLL
	TAD	ADR
	DCA	PC
	SNL
	TAD	(-10
	TAD	DATAF
	CDF 0
	DCA I	(PCCDF	/ADDRESS-1 TO PC
	JMP I	.+1
YFJMP,	ICYCLE		/** CHANGED IF RUNNING UNDER RTS-8

JXN,	AND	[70	/GET XR FIELD
	JMS I	(DCDIDX	/GET XR VALUE WITH INCREMENTING
	TAD I	T
	SNA CLA		/ZERO?
	JMP I	FPNXT	/YES
	JMP	DOJMP	/JUMP ON INDEX NON-ZERO, RIGHT?

CNDSKT,	SZA CLA		/JEQ
	SPA CLA		/JGE
	SMA SZA CLA	/JLE
	SKP CLA		/JA
	SNA CLA		/JNE
	SMA CLA		/JLT
	SPA SNA CLA	/JGT
	JMP	TSTALN	/JAL

TSTALN,	CLA
	TAD	ACX
	TAD	(-27
	SPA SNA CLA
	JMP I	FPNXT
	JMP	DOJMP
/OPCODE TABLES

SPECOP,	JMP I	SPECOP	/SPECIAL OPCODE TABLE
	JUMPS
	JXN
	TRAP3I
	TRAP4I
	TRAP5I
	TRAP6I
	TRAP7I

	FPJAC
	STRTD
	STRTF
	NRMFAC
	NEGFAC
	CLFAC
	FPAUSE
SP2,	EXIT
	ALN
	ATX
	FPXTA
	ICYCLE	/NOP
	STRTE
	ICYCLE	/UNDEF OP
	ICYCLE	/"
	FPLDX
	ADDX
	SETX
	SETB
	JSA
	JSR
	PAGE
/MISCELLANEOUS OPCODE ROUTINES

TRAP3I,
TRAP4I,	AC0002
	TAD	DATAF
	DCA	.+1	/FORM CDF CIF N
	HLT		/EXECUTE IT
	TAD	INST
	SMA CLA		/TRAP4 JMS'S TO ITS TARGET ADDRESS,
	JMP I	ADR	/TRAP3 JMP'S TO IT
	JMS I	ADR
	JMP I	FPNXT

ALN,	TAD	ACX	/ALIGN SIMULATOR
	DCA	OPX	/SAVE EXPONENT IN CASE WE'RE IN D.I. MODE
	TAD	DFLG
	SMA SZA CLA
	DCA	ACX	/ZERO EXP IF D.I. MODE
	JMS	DATCDF	/SET TO XR FIELD
	TAD	INST
	AND	[7
	TAD	DFLG	/IF WE'RE IN FLOATING POINT MODE,
	SNA CLA		/AND DOING AN "ALN 0",
	TAD	[27	/ALIGN UNTIL EXPONENT = 23
	SNA
	TAD I	ADR	/OTHERWISE ALIGN UNTIL EXPONENT = XR VALUE
	CDF 0
	CIA
	TAD	ACX
	CMA		/FORM DIFFERENCE - 1
	SPA		/IF EXPONENT IS LARGER THEN DESIRED EXPONENT,
	JMP	ALNSHL	/SHIFT LEFT
	JMS I	[ACSR	/OTHERWISE SHIFT RIGHT
ALNXIT,	TAD	DFLG
	SPA SNA CLA	/IF DOUBLE INTEGER MODE,
	JMP I	FPNXT
	TAD	OPX	/ALIGNMENT LEAVES THE EXPONENT UNCHANGED
	DCA	ACX
	JMP I	FPNXT
ALNSHL,	DCA	T	/STORE SHIFT COUNT
	SKP		/SHIFT LEFT ONE LESS THAN COUNT
	JMS I	[AL1BMP
	ISZ	T
	JMP	.-2
	JMP	ALNXIT	/GO TO COMMON CODE
/ARG FETCH SUBROUTINES AND MODE CHANGE OPERATORS

DARGET,	0
	DCA	ADR
	TAD	DARGET
	DCA	ARGET
	DCA	ACX
	JMP	ARGET2	/FAKE OUT FLOATING POINT ROUTINE

ARGET,	0		/SUBROUTINE TO FETCH ARG FOR ADD, SUBT, ETC.
	DCA	ADR	/STORE ADDRESS OF OPERAND
	TAD I	ADR	/PICK UP EXPONENT
	ISZ	ADR	/MOVE POINTER TO HI MANTISSA WD
	SKP
	JMS I	(DFBUMP
ARGET2,	DCA	OPX
	TAD I	ADR	/PICK IT UP
	DCA	OPH	/STORE
	ISZ	ADR	/MOVE PTR. TO LO MANTISSA WD.
	SKP
	JMS I	(DFBUMP	/WATCH THOSE FIELD TRANSITIONS!
	TAD I	ADR	/PICK IT UP
	DCA	OPL	/STORE IT
	CDF 0
	JMP I	ARGET	/RETURN

STRTE,	TAD	DFLG	/START EXTENDED PRECISION MODE
	SPA CLA
	JMP	.+4	/CLEAR EXTENDED FAC
	DCA	EAC1	/IF NOT ALREADY IN E MODE
	DCA	EAC2
	DCA	EAC3
	AC7775
	DCA	DFLG
	JMP	DFECMN

STRTD,	CLA IAC		/START DOUBLE PRECISION INTEGER MODE
STRTF,	DCA	DFLG	/START FLOATING POINT MODE
	TAD	DFLG
DFECMN,	TAD	(CLL
	DCA I	(IMFUDJ	/SET D.P.I FUDGE TO "CLL" OR "CLL IAC"
	TAD	DFLG
	SPA
	CMA		/CHANGE -3 FOR E MODE TO +2
	CLL RTL
	RAL
	TAD	(JMPTB1&177+5600
	DCA I	(BASJMP
	JMP I	FPNXT
/DOUBLE PRECISION INTEGER OPERATORS

DDSUB,	JMS	DARGET
	JMS I	(OPNEG
	SKP
DDADD,	JMS	DARGET
	DCA	AC1	/CLEAR OVERFLOW JUSTINCASE
	JMS I	[OADD
	JMP I	FPNXT

FFGET,	DCA	ADR	/GET A FLOATING POINT NUMBER
	TAD I	ADR
	DCA	ACX	/SAVE EXPONENT
	ISZ	ADR
	JMP	.+3	/NO FIELD OVERFLOW
	JMS I	(DFBUMP	/BUMP DATA FIELD
DDGET,	DCA	ADR	/SUAVE - ENTRY POINT FOR D.P. INTEGER GET
	TAD I	ADR
	DCA	ACH
	ISZ	ADR
	SKP
	JMS I	(DFBUMP
	TAD I	ADR
	DCA	ACL
	JMP I	FPNXT

FFPUT,	DCA	ADR	/STORE A FLOATING POINT NUMBER
	TAD	ACX	/GET FAC AND STORE IT
	DCA I	ADR	/AT SPECIFIED ADDRESS
	ISZ	ADR
	JMP	.+3
	JMS I	(DFBUMP
DDPUT,	DCA	ADR	/ENTRY FOR D.P. INTEGER PUT
	TAD	ACH
	DCA I	ADR
	ISZ	ADR
	SKP
	JMS I	(DFBUMP
	TAD	ACL
	DCA I	ADR
	JMP I	FPNXT
	PAGE
FPPKG=	.		/FOR EAE OVERLAY

/23-BIT FLOATING PT INTERPRETER
/W.J. CLOGHER, MODIFIED BY R.LARY FOR FORTRAN

LPBUF2,	ZBLOCK	16
	LPBUF3

AL1BMP,	0		/*K* UTILITY SUBROUTINE - USED BY INTERPRETER
	STA
	TAD	ACX
	DCA	ACX
	JMS I	[AL1
	JMP I	AL1BMP

/FLOATING MULTIPLY-DOES 2 24X12 BIT MULTIPLIES
DDMPY,	JMS I	(DARGET
	SKP
FFMPY,	JMS I	(ARGET	/GET OPERAND
	JMS	MDSET	/SET UP FOR MPY-OPX IN AC ON RETN.
	TAD	ACX	/DO EXPONENT ADDITION
	DCA	ACX	/STORE FINAL EXPONENT
	DCA	MDSET	/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
	DCA	ACL	/LOW ORDER
	TAD	MDSET	/HIGH ORDER
	DCA	ACH
	TAD	ACH	/DO WE NEED TO NORMALIZE?
	RAL
	SMA	CLA
	JMS	AL1BMP	/YES-DO IT FAST
	TAD	AC1
	SPA CLA		/CHECK OVERFLOW WORD
	ISZ	ACL	/HIGH BIT ON - ROUND RESULT
	JMP	MDONE
	ISZ	ACH	/LOW ORDER OVERFLOWED - INCREMENT HIGH ORDER
	TAD	ACH
	SPA		/CHECK FOR OVERFLOW TO 4000 0000
	JMP I	(SHR1	/WE HANDLE A SIMILIAR CASE IN FLOATING DIVIDE
	CLA
MDONE,	DCA	AC1	/ZERO OVERFLOW WD(DO I NEED THIS???)
	ISZ	MSIGN	/SHOULD RESULT BE NEGATIVE?
	SKP		/NO
	JMS I	[FFNEG	/YES-NEGATE IT
	TAD	ACH
	SNA CLA		/A ZERO AC MEANS A ZERO EXPONENT
	DCA	ACX
	TAD	DFLG
	SMA SZA CLA	/D.P. INTEGER MODE?
	TAD	ACX	/WITH ACX LESS THAN 0?
	SNA
	JMP I	FPNXT	/NO - RETURN
	CMA
	JMS I	[ACSR	/UN-NORMALIZE RESULT
	JMP I	FPNXT	/RETURN
/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
	CLA CLL CMA RAL	/SET SIGN CHECK TO -2
	DCA	MSIGN
	TAD	OPH	/IS OPERAND NEGATIVE?
	SMA	CLA
	JMP	.+3	/NO
	JMS I	(OPNEG	/YES-NEGATE IT
	ISZ	MSIGN	/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	[FFNEG	/YES-NEGATE IT
	ISZ	MSIGN	/BUMP SIGN CHECK
	NOP		/MAY SKIP
LEV,	TAD	OPX	/EXIT WITH OPERAND EXPONENT IN AC
	JMP I	MDSET
MSIGN,	0
/24 BIT BY 12 BIT MULTIPLY.  MULTIPLIER IS IN OPL
/MULTIPLICAND IS IN ACH AND ACL
/RESULT LEFT IN MDSET,AC2, AND AC1

MP24,	0
	TAD	(-14	/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
	TAD	AC2	/YES-ADD MULTIPLICAND TO PARTIAL PRODUCT
	TAD	ACL	/LOW ORDER
	DCA	AC2
	CML RAL		/*K* NOTE THE "SNL" 5 WORDS BACK!
	TAD	ACH	/HI ORDER
MPLP2,	TAD	MDSET
	RAR		/NOW SHIFT PARTIAL PROD. RIGHT 1 BIT
	DCA	MDSET
	TAD	AC2
	RAR
	DCA	AC2
	TAD	AC1
	RAR		/OVERFLOW TO AC1
	DCA	AC1
	ISZ	OPX	/DONE ALL 12 MULTIPLIER BITS?
	JMP	MPLP	/NO-GO ON
	JMP I	MP24	/YES-RETURN
	PAGE
/DIVIDE-BY-ZERO ROUTINE - MUST BE AT BEGINNING OF PAGE

DBAD,	ISZ	FATAL	/DIVIDE BY 0 NON-FATAL
	JMS I	ERR	/GIVE ERROR MSG
	TAD	DBAD
	DCA	ACX	/RETURN A VERY LARGE POSITIVE NUMBER
	AC2000
	JMP	FD

/FLOATING DIVIDE - USES DIVIDE-AND-CORRECT METHOD

DDDIV,	JMS I	(DARGET
	SKP
FFDIV,	JMS I	(ARGET	/GET OPERAND
	JMS I	(MDSET	/GO SET UP FOR DIVIDE-OPX IN AC ON RETN.
	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	OPL
	SNA CLA
	JMP	DVL2	/AVOID MULTIPLYING BY 0
	TAD	(-15	/SET COUNTER FOR 12 BIT MULTIPLY
	DCA	DV24	/TO MULTIPLY QUOT. OF DIV. BY 
	JMP	DVLP1	/LOW ORDER OF OPERAND (OPL)

/DIVIDE ROUTINE - (ACH,ACL)/OPH = ACL REMAINDER REM  (AC2=0)

DV24,	0
	TAD	ACH	/CHECK THAT DIVISOR IS .GT. DIVIDEND
	TAD	OPH	/DIVISOR IN OPH (NEGATIVE)
	SZL	CLA	/IS IT?
	JMP	DBAD	/NO-DIVIDE OVERFLOW
	TAD	(-15	/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
/DIVIDE ROUTINE CONTINUED

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	DV24	/DONE ALL BITS?
	JMP	MP12L	/NO-LOOP BACK
	CLL CIA		/YES-LOW ORDER PROD. OF QUOT. X OPL IN AC
	DCA	ACL	/NEGATE AND STORE
	CML	RAL	/PROPAGATE CARRY
	TAD	AC2	/NEGATE HI ORDER PRODUCT
	STL CIA	
	TAD	ACH	/COMPARE WITH REMAINDER OF FIRST DIV.
	SZL		/WELL?
	JMP	DVOPS	/GREATER THAN REM.-ADJUST QUOT OF 1ST DIV.
	DCA	ACH	/OK - DO (REM - (Q*OPL)) / OPH
DVL3,	JMS	DV24	/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
SHR1,	CLL
	ISZ	ACL	/ROUND AND SHIFT RIGHT ONE
	SKP
	IAC		/DOUBLE PRECISION INCREMENT
	RAR
	DCA	ACH	/STORE IN FAC
	TAD	ACL	/SHIFT LOW ORDER RIGHT
	RAR
	DCA	ACL	/STORE BACK
	ISZ	ACX	/BUMP EXPONENT
	NOP
	TAD	ACH
	JMP	DVL1+1	/IF FRACT WAS 77777777 WE MUST SHIFT AGAIN
FD,	DCA	ACH	/STORE HIGH ORDER RESULT
	JMP I	(MDONE	/GO LEAVE DIVIDE

DVL2,	DCA	ACL	/COME HERE IF LOW-ORDER QUO=0
	JMP	DVL3	/SAVE SOME TIME
/ROUTINE TO ADJUST QUOTINET OF FIRST DIVIDE (MAYBE) WHEN THE
/REMAINDER OF THE FIRST DIVIDE IS LESS THAN QUOT*OPL

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
	SNA		/IS IT ZERO?
DVOP2,	DCA	ACL	/YES-MAKE WHOLE THING ZERO
	DCA	ACH
	JMS	DV24	/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

LPBUF3,	ZBLOCK	12
	LPBUF4
	PAGE
/"OPNEG" MUST BE AT 0 ON PAGE

OPNEG,	0		/ROUTINE TO NEGATE OPERAND
	TAD	OPL	/GET LOW ORDER
	CLL CIA		/NEGATE AND STORE BACK
	DCA	OPL
	CML	RAL	/PROPAGATE CARRY
	TAD	OPH	/GET HI ORDER
	CLL CIA		/NEGATE AND STORE BACK
	DCA	OPH
	JMP I	OPNEG
/
/FLOATING SUBTRACT AND ADD
/
FFSUB,	JMS I	(ARGET	/PICK UO THE OP.
	JMS	OPNEG	/NEGATE OPERAND
	SKP
FFADD,	JMS I	(ARGET	/PICK UP OPERAND
	TAD	OPH	/IS OPERAND = 0
	SNA	CLA
	JMP I	FPNXT	/YES-DONE
	TAD	ACH	/NO-IS FAC=0?
	SNA	CLA
	JMP	CLROFL	/CLEAR OUT THE OVERFLOW BITS
	TAD	ACX	/NO-DO EXPONENT CALCULATION
	CLL CIA
	TAD	OPX
	SMA	SZA	/WHICH EXP. GREATER?
	JMP	FACR	/OPERANDS-SHIFT FAC
	CIA		/FAC'S-SHIFT OPERAND=DIFFRNCE+1
	TAD	(-30
	SMA		/TEST FOR INSIGNIFICANCE
	JMP	OPINSG	/YES - ANSWER IS FAC
	TAD	(30
	JMS	OPSR
	JMS I	[ACSR	/SHIFT FAC ONE PLACE RIGHT
DOADD,	TAD	OPX	/SET EXPONENT OF RESULT
	DCA	ACX
	JMS I	[OADD	/DO THE ADDITION
	JMS	FFNOR	/NORMALIZE RESULT
	JMP I	FPNXT	/RETURN
FACR,	TAD	(-30
	SMA		/TEST FOR INSIGNIFICANCE
	JMP	ACINSG	/YES - ANSWER IS OPR
	TAD	(30
	JMS  I	[ACSR	/SHIFT FAC = DIFF.+1
	JMS	OPSR	/SHIFT OPR. 1 PLACE
	JMP	DOADD	/DO ADDITION

OPINSG,	CLA
	JMP I	FPNXT
/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
	CLL		/TO LINK
	SPA
	CML		/WITH HI MANTISSA IN AC
	RAR		/SHIFT IT RIGHT, PROPAGATING SIGN
	DCA	OPH	/STORE BACK
	TAD	OPL
	RAR
	DCA	OPL	/STORE LO ORDER BACK
	ISZ	OPX	/INCREMENT EXPONENT
	NOP	
	ISZ	AC0	/DONE ALL SHIFTS?
	JMP	LOP2	/NO-LOOP
	RAR		/SAVE 1 BIT OF OVERFLOW
	DCA	AC2	/IN AC2
	JMP I	OPSR	/YES-RETN.

FFNOR,	0		/ROUTINE TO NORMALIZE THE FAC
	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,	CLA CLL CML RTR	/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)
	JMS I	[AL1BMP	/SHIFT AC LEFT AND BUMP ACX DOWN
	JMP	NORMLP	/GO BACK AND SEE IF NORMALIZED
ZEXP,	DCA	ACX
FFNORR,	DCA	AC1	/DONE W/NORMALIZE - CLEAR AC1
	JMP I	FFNOR	/RETURN

ACINSG,	CLA		/COME HERE IF AC IS INSIGNIFICANT ON ADDITION
	DCA	ACH
	DCA	ACL
	JMP	DOADD-1	/FAKE AN ADD WITH OPR=0

LPBUF4,	ZBLOCK	40
	LPBUFE
CLROFL,	DCA	AC1	/CLEAR  THE FLOATING AC OVERFLOW WORD
	DCA	AC2	/CLEAR THE OPERAND OVERFLOW WORD
	JMP	DOADD	/FAC=0;   DO THE ADD
	PAGE
/PAGE 7400 UNUSED RIGHT NOW

LPBUFE,	ZBLOCK	177
	LPBUFR
	FIELD 1

