/RUN TIME SYSTEM FOR COS 300		EDITED 10/8/73
/COPYRIGHT 1972, 1973
/DIGITAL EQUIPMENT CORP.
/MAYNARD MASS.  01754
/
/THIS SOFTWARE IS FURNISHED TO PURCHASER UNDER A LICENSE FOR USE
/ON A SINGLE COMPUTER SYSTEM AND CAN BE COPIED (WITH INCLUSION
/OF DEC'S COPYRIGHT NOTICE) ONLY FOR USE IN SUCH SYSTEM, EXCEPT
/AS MAY OTHERWISE BE PROVIDED IN WRITING BY DEC.
/
/THE INFORMATION IN THIS DOCUMENT IS SUBJECT TO CHANGE WITHOUT
/NOTICE AND SHOULD NOT BE CONSTRUED AS A COMMITMENT BY DIGITAL
/EQUIPMENT CORPORATION.
/
/DEC ASSUMES NO RESPONSIBILITY FOR THE USE OR RELIABILITY
/OF ITS SOFTWARE ON EQUIPMENT WHICH IS NOT SUPPLIED BY DEC.
/

DIGITS=	21	/15 DIGIT ACCURACY REQUIRES 17 DIGIT ACCUMULATORS
/EQUIVALENCES TO EDP-8 MONITOR
TICHR=	56
LPDNFG=	55
P77=	20
P7=	40
P17=	64
P70=	65
PCDF=	71
P7400=	2
P7600=	70
M1=	45
M4=	66
KSPLIT=	76
SYS=	77
MOVE=	23
RDOIO=	26
CDOIO=	27
BREAKP=	7770
TOPFLD=	7775
OPTCHR=	7776
DATE=	7777
INITIO=	72
FINIO=	75
KGPBUF=	41
TTICHR=	30
TTOCHR=	31
LPOUT=	35
OTOPD=	74
LENGTH=	44
CTRLO=	73
GPBUF=	41
PTF0=	62
IZERO=	63
KPTRST=	43
U0=	54
U1=	U0+1
U2=	U1+1
W0=	46
W1=	W0+1
W2=	W1+1
W3=	W2+1
W4=	W3+1
W5=	W4+1
RSLDR=	35
RSYS=	60
EROVLY=	66
DDTBLK=	75

/PAGE 0 -- ALL KINDZA TEMPORARIES AND NOT-SO-TEMPORARIES
	*4
USRERR,	0	/LOC OF USER ERROR ROUTINE (IF ANY)
OLDPDL,	0	/PDL AT BEGINNING OF CURRENT STMT
NUMBFS=	OLDPDL
BP,	BREAKP
	IFZERO	BREAKP-7770	<P7770=BP>
PCTMP,	0	/LOADER SAVE-THE-PC KLUDGE
	*15
XR,	0
XR1,	0
XR2,	0
	*LENGTH
	4000
	*100
PC,	0	/PROGRAM COUNTER
T,		/TEMPORARY
CHNPTR,	CHINIT	/INITIALIZED FOR CHAIN
T1,	0	/"
T2,	0	/"
IST1,	0	/HOLDS ADDRESS FIELD DESCRIPTOR
IST2,	0	/"
PDL,	PDLBEG	/PUSHDOWN LIST POINTER
NUMLEN,	-DIGITS	/LENGTH OF DECIMAL WORK AREAS
A,	ACA	/DEFINITION OF ACCUMULATOR A
AS,	0
B,	ACB	/DEFINITION OF ACCUMULATOR B
BS,	0
	IFNZRO	B-A-2	<__ ERROR__>
ALAST,	ACA+DIGITS-1
QDIGIT,	0	/TEMPORARY FOR MULTIPLY AND DIVIDE
DES1=	.	/DEFINITION OF DESCRIPTOR 1
DES1W,	0	/WORD
DES1B,	0	/BYTE
DES1L,	0	/LENGTH
DES1F,	GETC1F	/POINTER TO CDF LOCATION
DES2=	.	/DEFINITION OF DESCRIPTOR 2
DES2W,	0	/WORD
DES2B,	0	/BYTE
DES2L,	0	/LENGTH
DES2F,	GETC2F	/POINTER TO CDF LOCATION
PUTDES=	.	/DEFINITION OF DESCRIPTOR 3 ( "PUT" DESCRIPTOR)
PUTDW,	0	/WORD
PUTDB,	0	/BYTE
PUTDL,	0	/LENGTH
PUTDF,	PUTCHF	/POINTER TO CDF LOCATION

SYMTAB,	0	/ADDRESS OF SYMBOL TABLE -1
LINENO,	0	/SOURCE LINE NUMBER
TRCJMP,	0	/0 OR "JMP I PUTCHX"
RELBHI,	0	/HIGH ORDER BLOCK # FOR RANDOM ACCESS
RELBLO,	0	/ LOW ORDER "
BLKSIZ,	0	/(DIBOL) BLOCK SIZE FOR R.A.
BUFSIZ,	0	/BUFFER SIZE FOR R.A.
TIFN,	0	/POINTER INTO INITIO
TRPINS,	0	/INST TO BE EXECUTED WHEN LPT DONE
TRCFLG,	0	/TRACE FLAG
	/REDEFINITION OF RANDOM ACCESS TEMPS FOR OTHER PURPOSES
CMPCNT=	RELBHI
DDTLOC=	RELBLO
DDTTRP=	BLKSIZ
CHNFLG=	BUFSIZ

	/RSYS PSEUDO-OPS
AC4000=	CLA CLL CML RAR
AC2000=	CLA CLL CML RTR
AC0002=	CLA CLL CML RTL
AC7776=	CLA CLL CMA RAL
AC7775=	CLA CLL CMA RTL
AC3777=	CLA CLL CMA RAR
PUSH=	JMS I	.;	PUSHX
POPNUM=	JMS I	.;	POPNMX
POPLFT=	JMS I	.;	POPLFX
POPDES=	JMS I	.;	POPDSX
POPDS1=	JMS I	.;	POPD1X
DBCONV=	JMS I	.;	DBCNVX
FATAL=	JMS I	.;	FATALX
ERROR=	JMS I	.;	ERRORX
GETCH1=	JMS I	.;	GETC1X
GETCH2=	JMS I	.;	GETC2X	/GETCH2 MUST BE AT GETCH1+1
PUTCHI=	JMS I	.;	PUTCHX
	PAGE

/PUSHDOWN LIST OVERLAYS LOADER
	JMP I .+1	/PROTECTION FOR RETURN WITHOUT GOTO
	RSYSWR		/CHANGED TO RSINIT BY RSYSWR, ZEROED BY RSINIT
PDLBEG=	.
/RSYS LOADER - LOADS OUTPUT OF DIBOL COMPILER
	LDBUF=1400
RLBUFR,	DCA	PDLBEG-2
	DCA	PDLBEG-1
RLOOP,	CLA IAC
	JMS I	RDOIO	/READ AN INPUT LINE
	LDBUF-1
EOFERR,	FATAL		/END OF FILE SEEN PREMATURELY - ERROR
	TAD	(LDBUF
	DCA	XR
	TAD I	XR	/GET TYPE OF LINE
	TAD	RJUMP
	DCA	RTMP
	ISZ	FSTFLG	/FIRST RECORD SHOULD BE TYPE 5
RTMP,	HLT		/JUMP TO PROPER ROUTINE
	JMP	PROCNM	/CHECK FOR ILLEGAL CHAIN
RJUMP,	JMP I	.+1
	PROG	/PROGRAM INTERPRETIVE CODE
	DATCLA	/DATA CLEAR - ALPHA
	DATCLD	/DATA CLEAR - DECIMAL
	SYMHDR	/SYMBOL TABLE HEADER
	DATASK	/DATA TO BE SPECIFIED AT LOAD TIME
	PROCNM	/END OF DATA - BEGINNING OF PROGRAM
	CORMOV	/FIELD OVERFLOW KLUDGE
	DATSET	/DATA INITIALIZATION
	DATDAT	/INSERT CURRENT DATE
	DCLRCH	/CLEAR DECIMAL FIELD IF NOT A CHAIN
	OPTSET	/OPTION INITIALIZATION
PROGLP,	ISZ	T1
	JMP	PROGXX
	TAD	PRGCDF
	TAD	[10
	DCA	PRGCDF
PROGXX,	TAD I	XR	/GET A WORD
PRGCDF,	HLT
	DCA I	T1	/STORE IT INTO THE PROGRAM AREA
	CDF 0
PROG,	ISZ I	(LDBUF
	JMP	PROGLP
	DCA	FSTFLG	/PREVENT "IMPOSSIBLE" OVERFLOW
	JMP	RLOOP	/GET NEXT INPUT LINE
FSTFLG,	-1

/"PROC" CODE LOADER
PROCNM,	TAD I	XR	/THE FIRST PIECE OF DATA IN THIS LINE IS
	SPA
	JMP	EOFERR	/NEGATIVE IF THERE WERE COMPILATION ERRORS.
	CIA		/OTHERWISE IT IS A STATEMENT BY THE USER AS TO
	DCA	NUMBFS	/THE NUMBER OF BUFFERS USED BY THE PROGRAM
	TAD I	XR
	TAD	PCDF	/THIS IS FOLLOWED BY THE STARTING ADDRESS OF
	DCA	PRGCDF	/THE PROGRAM AS A 15-BIT ADDRESS
	TAD	PRGCDF
	DCA	PCTMP
	TAD I	XR
	DCA	PC
	TAD	PC
	DCA	T1
	TAD I	(TOPFLD
	CLL CMA
	ISZ	XR	/SKIP LENGTH OF OUTPUT FILE
	TAD I	XR	/GET HIGHEST FIELD USED
	TAD	PCDF
	SZL CLA		/DO WE FIT?
PGOERR,	FATAL		/NO
	TAD I	XR
	TAD	VERSON	/ACCEPT VERSION 5 ONLY
	SZA CLA		/CHECK COMPILER VERSION NUMBER
	JMP	EOFERR
	JMP	RLOOP
CORMOV,	JMS	GTDESC	/GET THE DESCRIPTOR
	DCA	CMCDF1	/SAVE CDF TO FIELD
	TAD	CMCDF1
	TAD	[10
	DCA	CMCDF2	/SET UP FOR CORE MOVE
	DCA	T
CMCDF1,	HLT
	TAD I	PUTDW	/MOVE THE END OF THIS FIELD
CMCDF2,	HLT
	DCA I	T	/TO THE BEGINNING OF THE NEXT ONE
	ISZ	T
	ISZ	PUTDW
	JMP	CMCDF1
	CDF 0	/RESTORE DATA FIELD
	JMP	RLOOP	/CONTINUE
GTDESC,	0
	TAD I	XR
	PUSH
	TAD I	XR
	PUSH		/STACK THE DESCRIPTOR
	TAD	[PUTDES-1
	POPDES		/UNSTACK AND EXPAND IT
	JMP I	GTDESC	/EXIT WITH CDF IN AC
VERSON,	-5	/*** RSYS COMPATIBILITY NUMBER ***

DATSM1,	STA		/TURN "GETCH2" TO "GETCH1"
DATSET,	TAD	(GETCH2
DATSTX,	DCA	DATGET	/STORE EITHER "TAD T", "GETCH2", OR "GETCH1"
	JMS	GTDESC	/AGAIN, THE FIRST TWO WORDS ARE A DESCRIPTOR
	DCA I	PUTDF
SRDIES,	CLA IAC
	TAD	XR
	DCA	DES2W	/SET UP DESCRIPTOR 2 JUST IN CASE
	AC7776		/WE'RE USING GETCH2
	DCA	DES2B
DATGET,	HLT		/GET THE CHARACTER ONE WAY OR THE OTHER
	SZA
	JMP	DATPUT	/NON-ZERO MEANS ITS GOOD
	TAD	RLOOP	/OTHERWISE FILL WITH BLANKS
	DCA	DATGET
	JMP	DATGET
DATPUT,	PUTCHI		/MOVE CHARACTERS FROM SOURCE TO DESTINATION
	ISZ	PUTDL
	JMP	DATGET	/THE APPROPRIATE NUMBER OF TIMES
	JMP	RLOOP
TAD21=	TAD	[21	/PAL8 HAS NO PARENTHESES!
DATCLD,	TAD	(TAD21-7201	/DIFF BET "TAD [21" AND "CLA IAC"
DATCLA,	TAD	RLOOP
	DCA	DATGET	/KLUDGE TO HANDLE CLEARS
	JMS	GTDESC	/LONGER THAN 512 CHARACTERS
	DCA I	PUTDF
	TAD I	XR
	DCA	PUTDL
	JMP	SRDIES
	PAGE

/READ IN RSYS PROPER AND SET UP BUFFERS
RDRSYS,	JMS I	SYS
	1400		/READ IN THE REST OF THE RUN-TIME SYSTEM
	1400
	RSYS%20	/SPACE SAVER
	IFNZRO RSYS&17	<__ ERROR __>
	TAD I	(TOPFLD
	DCA I	(SYMCDF	/SET UP SYMBOL TABLE DATA FIELD
	TAD I	(OPTCHR
	AND	G7700
	TAD	(-2400
	SNA CLA		/IS THE "T" OPTION PRESENT?
	ISZ I	(HERET	/YES - BUMP TRACE FLAG
	TAD	DDTTRP
	DCA I	(DDTSW	/STORE CDF CIF OR JMP AROUND

/ALLOCATE FREE CORE INTO I/O BUFFERS
	CLL
	TAD	T1
	TAD	[377
	AND	P7400	/ROUND PC UP TO NEAREST 400 WORD BOUNDARY
	SZL		/IF FIELD OVERFLOW,
	JMP	BMBFLD	/BUMP FIRST FIELD FOR BUFFERS
FLDLP,	ISZ	T2
	DCA I	T2	/SAVE ORIGIN OF FREE AREA
	TAD I	T2
	ISZ	T2
	CIA CLL
	RAR
	TAD	T	/COMPUTE I/O CONTROL WORD SHOWING LENGTH AND FIELD
	DCA I	T2	/OF FREE AREA AND SAVE IT, TOO.
	TAD I	(TOPFLD
	CIA
	TAD	T
	TAD	PCDF
G7700,	SMA CLA		/HAVE WE EXHAUSTED ALL FIELDS?
	JMP	BAFINI	/YES
BMBFLD,	TAD	T
	TAD	[10
	DCA	T
	JMP	FLDLP	/DO NEXT FIELD
BAFINI,	AC0002		/** QDIGIT SET IN "SYMHDR" ***
	TAD	QDIGIT	/BUMP THE LENGTH OF THE FREE AREA IN THE HIGHEST
	AND	P7400	/FIELD DOWN BY THE LENGTH OF THE SYMBOL TABLE
	CLL CML RAR	/(ROUNDED UP TO NEAREST 400, OF COURSE)
	TAD I	T2
	DCA I	T2	/WE KNOW IT WILL BE POSITIVE(OR AT LEAST >7600)
	ISZ	T2
	ISZ	T2
	DCA I	T2

	TAD	(3600	/BE AN OPTOMIST- LOOK FOR 15 BLOCK BUFFERS
BALOOP,	DCA	BLEN	/SAVE BUFFER SIZE
	TAD	NUMBFS
	DCA	BCNT	/SAVE THE DESIRED COUNT
	TAD	(FARRAY-1
	DCA	XR
	TAD	(BARRAY-1
	DCA	XR2
BFLOOP,	TAD I	XR	/GET THE FREE AREA OF THIS FIELD
	DCA	T1
DATADX,	TAD I	XR
	SNA		/LENGTH 0 MEANS WE'VE RUN PAST THE END OF THE TABLE
	JMP	BABUMP	/WE'VE FAILED - TRY A SMALLER BUFFER LENGTH
	DCA	T
BCLOOP,	TAD	BLEN
	CIA CLL
	TAD	T
	SMA		/CAN THIS FIELD HOLD ANOTHER BUFFER OF THIS LENGTH?
	DCA	T	/YES
	SPA CLA
	JMP	BFLOOP	/NO - TRY NEXT FIELD
	TAD	T
	AND	P70
	TAD	BLEN	/CONSTRUCT AN ENTRY IN THE FILE TABLE CONSISTING
	DCA I	XR2	/OF THE BUFFER LENGTH, BUFFER FIELD,
	TAD	T1
	DCA I	XR2	/AND BUFFER STARTING ADDRESS
	TAD	BLEN
	CLL RAL
	TAD	T1
	DCA	T1	/UPDATE BUFFER STARTING ADDRESS
	ISZ	BCNT	/DID WE FIND THE DESIRED NUMBER?
	JMP	BCLOOP	/NOT YET - KEEP LOOKING
	JMP	RSTART	/YES - GO START UP RSYS
BABUMP,	TAD	BLEN
	TAD	P7600	/REDUCE THE BUFFER SIZE
	SZA		/IF WE REDUCE IT TO ZERO,
	JMP	BALOOP
			/MAKE DO WITH THE NUMBER WE'VE FOUND

RSTART,	DCA I	XR2	/FILL IN THE REST OF THE BUFFER TABLE
	TAD	XR2	/WITH UNUSEABLE ENTRIES
	TAD	(-FARRAY-17
	SZA CLA
	JMP	RSTART	/AND ZERO OUT THE F ARRAY
	TAD	M4
	JMS I	MOVE
	CDF 0
	PDFALT-1
	FARRAY+4
	TAD	PCTMP
	DCA I	(PCCDF
	TAD	PC
	CLL CMA RAL	/FROM THE STARTING ADDRESS, FORM THE
	DCA I	(SSLIM2	/UPPER LIMIT OF THE DATA AREA
	CML RTL
	RAL
	TAD I	(PCCDF
	RTR
	AND	P7
	CMA
	DCA I	(SSLIM1	/WHICH WE WILL CHECK SUBSCRIPTS AGAINST
	TAD	DDTLOC
	SNA CLA
	JMP I	[ILOOP	/NO DDT - START UP PROGRAM
	TAD	DDTTRP
	DCA	.+1
	HLT		/CDF CIF DDTFLD
	JMP I	(6400	/AND START DDT
BLEN=	AS
BCNT=	BS
	PAGE

/DATA INITIALIZATION LOAD ROUTINES
DATASK,	TAD I	XR
	DCA	NM1	/THE CONTENTS OF THIS LINE IS THE NAME OF THE
	TAD I	XR
	DCA	NM2	/VARIABLE TO ASK FOR AND ITS DESCRIPTOR
	TAD I	XR
	DCA	NM3
	CLA IAC		/PRINT ON THE TELETYPE
	JMS I	CDOIO
	ENTERM-1	/AN "ENTER NAME" MESSAGE
	NOP
	JMS I	CDOIO	/READ FROM THE KEYBOARD
ASKBUF,	LDBUF+10	/A STRING OF CHARACTERS
	JMP I	RLOOPP	/USE DEFAULT VALUE IF EOF
DATFAK,	AC0002
	TAD	ASKBUF
	DCA	DES1W	/SET UP A FETCH DESCRIPTOR
	AC7776
	DCA	DES1B	/TO POINT TO THE STRING WE JUST READ
	TAD I	(LDBUF+11
	CIA
	TAD	(LDBUF+11
	DCA	XR1	/MAKE SURE THAT THERE IS A ZERO WORD
	DCA I	XR1	/AFTER THE INPUT CHARACTERS
	JMP I	.+1
	DATSM1
ENTERM,	-6
	4657	/EN
	6546	/TE
	6301	/R
NM1,	SYSINI
NM2,	CHNERR
NM3,	CHKDDT
PDFALT,	0104		/PTR
	0105		/LPT
	0100		/KBD
R101,	0101		/TTY

	/CHAIN INITIALIZER
CHINIT,	TAD I	PGET	/JUMPED TO FROM CHAIN PROCESSOR
	DCA I	PGET	/SET "GET" TO POINT TO NEW LOAD FILE
	TAD	RIJMP
	DCA	RSICDF	/BYPASS CORE CLEARER
	ISZ	DCLRCH	/MAKE LOADER CODE 11 A NOP
	ISZ	CHNFLG	/SET CHAIN FLAG FOR DDT
/LOADER ONCE-ONLY CODE
RSINIT,	TAD I	M4
	DCA	SYS
	CLA IAC
	JMS I	NM1	/INIT BINARY INPUT
	1000
	2000
	JMP I	NM2
RSICDF,	CDF 10
	DCA	T
	TAD	R101
	DCA I	T
	ISZ	T
	JMP	.-3	/CLEAR ALL USER CORE TO BLANKS
	CDF 0
	TAD	RSICDF
	TAD	[10
	DCA	RSICDF
	TAD	RSICDF
	CIA
	TAD I	(TOPFLD
	SMA CLA
	JMP	RSICDF	/LOOP FOR AS MANY FIELDS AS NECESSARY
RIJMP,	JMP I	NM3
DCLRCH,	JMP I	.+1	/OR .+2
	DATCLD
RLOOPP,	RLOOP
PGET,	GET

DATDAT,	TAD	ASKBUF	/STICK THE DATE IN AND GO TO "DATASK"
	DCA	XR1
	AC7775
	DCA I	XR1	/SET WORD COUNT SINCE DESTINATION MAY BE LARGE
	TAD I	M1	/DATE
	AND	P7400
	CLL RTL
	RTL
	RAL
	JMS I	OTOPD
	DCA I	XR1
	TAD I	M1	/DATE
	CLL RTR
	AND	P77
	CLL RAR
	JMS I	OTOPD
	DCA I	XR1
	TAD I	M1	/DATE
	AND	P7
	TAD	(110	/YEAR ORIGINS AT 1972
	JMS I	OTOPD
OPTDAT,	DCA I	XR1
	ISZ	XR
	ISZ	XR
	ISZ	XR	/SKIP OVER USELESS NAME
	JMP	DATFAK		/NOW PUT IT INTO THE VARIABLE
	/END OF LOADER CODE
	/EQUIVALENCE CERTAIN ARRAYS WITH THE LOADER CODE
FARRAY=	.-20		/FREE CORE AND FILE NUMBER TABLE - 16 WORDS LONG
BARRAY=	FARRAY-20	/BUFFER TABLE - 16 WORDS LONG, ONLY 14 ARE USED
ACB=	BARRAY-DIGITS	/ACCUMULATOR "B"
ACA=	ACB-DIGITS	/ACCUMULATOR "A"
PDLEND=	ACA-1		/LAST LOCATION OF PUSHDOWN LIST

ATLINE,	DCA	HILINE	/ROUTINE TO PRINT "AT LINE XXXX"
	TAD	LINENO
	ISZ	HILINE	/DIVIDE THE LINE NUMBER BY 100 (DECIMAL)
	CLL
	TAD	(-144	/AND USE THE MONITOR ROUTINE "OTOPD"
	SZL		/TO CONVERT EACH PAIR OF DIGITS TO
	JMP	.-4	/ASCII -237 CODE
	TAD	K144
	JMS I	OTOPD	/CONVERT LOW ORDER DIGITS
	DCA	LOLINE
	STA
	TAD	HILINE
	JMS I	OTOPD	/HIGH ORDER DIGITS
	DCA	HILINE
ATLNDV,	TAD	(5	/GET DEVICE NUMBER
	JMS I	CDOIO	/PRINT MESSAGE
	ATMESG-1
K144,	144
	DCA	TRCJMP
	JMP I	ATRETN	/RETURN TO INTERPRETER
ATRETN,	ILOOP		/CHANGED TO 7600 ON ERRORS
ATMESG,	-6		/AT LINE XXXX
	4265
	0155
	5257
	4601
HILINE,	0
LOLINE,	0
	PAGE

/SYSTEM INITIALIZATION ROUTINE - USED FOR LOADER AND
/ FOR INIT'S TO DEVICE "SYS"
SYSINI,	0
	JMS I	KPTRST
	TAD I	SYSINI
	DCA I	W0
	ISZ	SYSINI
	TAD I	SYSINI
	ISZ	SYSINI
	DCA I	W1
SGETLP,	TAD I	GET
	SNA
	JMP I SYSINI
	ISZ	GET
	CLL RTR
	RTR
	DCA I	W3
	TAD I	W3
	RAR
	AND	P7400
	DCA I	W5
	TAD I	W3
	AND	[377
	DCA I	W4
	DCA I	W3
	ISZ	SYSINI
	JMP I	SYSINI
SBT=6370
GET,	SBT

/ERROR ROUTINE
ERRORX,	0		/ERROR ROUTINE
	CLA
	TAD	ERRORX
	DCA	FATALX
	TAD	USRERR
	SNA		/USER ERROR ON THIS LINE?
	JMP	GTEROV	/NO - GET ERROR OVERLAY
	DCA	T
	DCA	USRERR	/KILL USER ERROR WORD
	TAD	OLDPDL
	DCA	PDL	/RESTORE PUSHDOWN POINTER
	JMP I	(ILOOPE	/EXECUTE USRERR , WHICH IS A BRANCH
FATALX,	0		/FATAL ERROR ROUTINE
	CLA
GTEROV,	CDF 0
	TAD	(EROVLY&17^400
	JMS I	SYS
	200
ERIDNT,	4400
	EROVLY%20
	JMP I	ERIDNT

/VT05/TELETYPE DISPLAY ROUTINES
DSPLYD,	DCA	DES2L
	DBCONV		/DISPLAY SPECIAL CHARACTER
	JMP	.+4
DSPLYA,	TAD	[DES2-1
	POPDES		/DISPLAY ALPHA STRING
	DCA I	DES2F	/STORE CDF
	DCA	T	/STORE SPECIAL CHARACTER OR ZERO IF STRING
	DBCONV
	DCA	T1	/SAVE X COORD
	DBCONV
	SNA
	JMP	NOPOSN	/ROW OF 0 MEANS ONLY PRINT STRING
	DCA	T2
	TAD	(216	/OUTPUT CONTROL/N
	JMS I	TTOCHR
	TAD	T2
	JMS	TTOSPC	/OUTPUT Y-COORD AND WAIT
	TAD	T1
	TAD	[237
	JMS I	TTOCHR
NOPOSN,	TAD	DES2L
	SNA CLA		/STRING?
	JMP	OUTSPC	/NO - TRY SPECIAL CHAR
	GETCH2
	TAD	[237
	JMS I	TTOCHR
	ISZ	DES2L
	JMP	.-4
OUTSPC,	TAD	T
	CIA CLL CML
	IAC	/SPECIAL CHARS -- 1=CLEAR SCREEN [237)
	SZL SPA SNA	/                 2=CLEAR LINE   (236)
	JMS	TTOSPC	/                  0= DO NOTHING
	CLA
	JMP I	[ILOOP

/VT05/TELETYPE STRING ACCEPT ROUTINES
ACCEPT,	JMS I	(STSETP	/INITIALIZE OUTPUT DESCRIPTOR TO ALPHA STRING
ACPTLP,	TAD I	LPDNF1
	AND	TRPINS
	SZA CLA		/DO WE HAVE TO TRAP?
	JMP I	(LPATCH	/YES
	TAD I	KTICHR
	SNA CLA		/TTY READY?
	JMP	ACPTLP	/NO - TEST LPT
	JMS I	TTICHR	/GET A CHAR
	DCA	T
	TAD	T
	TAD	(-336
	CLL CML
	TAD	P77
	SZL SNA		/LEGAL COS CHARACTER?
	JMP	DELIM	/NO
	PUTCHI		/YES - STORE IT
	JMS I	(KLUDGE	/HOO, HAH!
	TAD	T
	JMS I	TTOCHR	/ECHO IT
	ISZ	PUTDL
	JMP	ACPTLP	/AND LOOP
	JMP	.+3	/FIELD OVERFLOW - TREAT AS 0 DELIMITER
DELIM,	SPA
	TAD	[237
	AND	P77	/TRUNCATE TO SIXBIT
	JMS I	[FAKNUM
	JMP I	(STORD	/STORE IT INTO THE DELIMITER FIELD
TTOSPC,	0		/DISPLAY AND WAIT ROUTINE
	TAD	[237
	JMS I	TTOCHR
	JMS I	TTOCHR
	JMS I	TTOCHR	/OUTPUT 4 NULLS AFTER CHAR
	JMS I	TTOCHR
	JMS I	TTOCHR
	JMP I	TTOSPC
KTICHR,	0		/FILLED IN AT INITIAL WRITEOUT TIME
LPDNF1,	0		/DITTO
/
	PAGE

	/UTILITY SUBROUTINES
PUSHX,	0		/PUSH THE CCUMULATOR
	DCA I	PDL	/TIME(10/24):	13 CYCLES
	ISZ	PDL
	TAD	PDL
	TAD	(-PDLEND
	SMA CLA
PDLERR,	FATAL		/PUSHDOWN OVERFLOW
	JMP I	PUSHX
POPDSX,	0		/POP A DESCRIPTOR
	DCA	XR1	/USE AUTO-INDEX
	STA		/TIME(11/23):	50 CYCLES
	TAD	PDL
	DCA	PUSHX	/PUSHX POINTS TO WORD 2 OF DESCRIPTOR ON STACK
	STA
	TAD	PUSHX
	DCA	PDL	/PDL POINTS TO WORD 1
	TAD I	PDL	/A DESCRIPTOR IS A FOUR WORD BLOCK:
	RAR		/WORD 1 IS THE WORD ADDRESS OF THE ITEM
	DCA	GETC1X
	TAD I	PUSHX
	RAR
	DCA I	XR1
	CMA RAL		/WORD 2 HAS THE EVEN/ODD BYTE FLAG
	DCA I	XR1	/(-2 IF EVEN, -1 IF ODD)
	TAD	GETC1X
	CLL RTR
	AND	[777
	CIA		/WORD 3 HAS THE ITEM LENGTH AS A NEGATIVE NUMBER
	SNA
	TAD	(7000	/WATCH OUT FOR A LENGTH OF 512!
	DCA I	XR1
	TAD I	PDL	/IN WHICH WE MUST STORE A CDF
	AND	(6	/TO THE DATA FIELD OF THE ITEM
	SZA
	JMP	NOTPDL	/ITEMS IN FIELD 0 ARE SPECIAL AS THEY ARE
	TAD I	PUSHX	/ON THE PUSHDOWN LIST AND WE MUST ADJUST
	CLL RAR
	DCA	PDL	/THE PUSHDOWN LIST POINTER
NOTPDL,	CLL RTL
	TAD	PCDF
	JMP I	POPDSX

/GET CHARACTER ROUTINES
GETC1X,	0		/GET CHARACTER THROUGH DESCRIPTOR 1
GETC1F,	CDF 0		/SET DATA FIELD
	ISZ	DES1B	/TIME(11/23):	16 CYCLES
	JMP	GETC1L	/GET LEFT HALF OF WORD
	AC7776		/RESET BYTE FLAG TO EVEN
	DCA	DES1B
	TAD I	DES1W
	ISZ	DES1W	/PROCEED TO NEXT WORD
	JMP	GETC1C
	JMP	GETC1C	/JUST IN CASE
GETC1L,	TAD I	DES1W
	RTR
	RTR
	RTR
GETC1C,	AND	P77
	CDF 0
	JMP I	GETC1X	/RETURN WITH DATA FIELD CORRECT
GETC2X,	0		/GET CHARACTER THROUGH DESCRIPTOR 2
GETC2F,	CDF 0		/SET DATA FIELD
	ISZ	DES2B	/TIME(11/23):	16 CYCLES
	JMP	GETC2L	/GET LEFT HALF OF WORD
	AC7776		/RESET BYTE FLAG TO EVEN
	DCA	DES2B
	TAD I	DES2W
	ISZ	DES2W	/PROCEED TO NEXT WORD
	JMP	GETC2C
	JMP	GETC2C	/JUST IN CASE
GETC2L,	TAD I	DES2W
	RTR
	RTR
	RTR
GETC2C,	AND	P77
	CDF 0
	JMP I	GETC2X	/RETURN WITH DATA FIELD CORRECT
POPD1X,	0		/POP DESCRIPTOR 1 (A SPACE-SAVER)
	TAD	(DES1-1
	JMS	POPDSX
	DCA	GETC1F
	JMP I	POPD1X

/PUT CHARACTER ROUTINE
PUTCHX,	0	/PUT CHARACTER THROUGH "PUT" DESCRIPTOR
PUTCHF,	HLT		/SET DATA FIELD
	ISZ	PUTDB	/TIME(11/23):	23 CYCLES
	JMP	PUTCHL	/REPLACE LEFT HALF
	DCA	GETC1X	/STORE AC CHARACTER
	TAD I	PUTDW
	AND	[7700	/MASK OFF RIGHT HALF
	TAD	GETC1X	/INSERT AC CHAR
	DCA I	PUTDW	/RESTORE
	AC7776
	DCA	PUTDB	/RESET BYTE FLAG TO EVEN
	ISZ	PUTDW	/BUMP POINTER TO NEXT WORD
	JMP	PUTCDF
	JMP	PUTCDF	/JUST IN CASE
PUTCHL,	CLL RTL
	RTL
	RTL		/GET AC CHARACTER INTO LEFT HALF
	DCA	GETC1X
	TAD I	PUTDW
	AND	P77	/MASK OFF LEFT HALF OF WORD
	TAD	GETC1X	/INSERT AC CHAR
	DCA I	PUTDW	/RESTORE
PUTCDF,	CDF 0
PUTRET,	JMP I	PUTCHX	/RETURN
	TAD	GETC1X	/AHA, TRACE IS ON - PRINT OUT THE CHARACTER
	AND	P77	/WATCH OUT THOUGH - IT CAN BE IN EITHER HALF
	SZA		/OF "GETC1X".
	JMP	.+5	/RIGHT HALF - GOODIE!
	TAD	GETC1X
	CLL RTR
	RTR
	RTR	/MOVE THE CHARACTER INTO THE RIGHT HALF
	TAD	[237
	JMS I	LPOUT	/PRINT IT ON THE LINE PRINTER IN ASCII
	JMP I	PUTCHX	/NOW RETURN
PUTJMP=	JMP I	PUTCHX
KLUDGE,	0		/KLUDGE FOR "TRAP" INSTRUCTION
	ISZ I	PUSHX	/CALLED FROM "ACCEPT" - BUMP
	STA		/DESCRIPTOR ON PUSHDOWN LIST
	TAD	(7771	/IN CASE WE HAVE TO TRAP
	TAD I	PDL
	DCA I	PDL
	JMP I	KLUDGE
	PAGE

/MAIN INTERPRETER LOOP
/INTERPRETER LOOP TIME:(10/24)	50 CYCLES FOR MRI'S 31 CYCLES OTHERWISE
ILOOP,	IOF
	TAD I	LPDNF2
	AND	TRPINS
	SNA		/SHOULD WE TRAP?
	JMS I	[FETPC	/NO - GET REGULAR INST
	DCA	T
	DCA I	LPDNF2	/ZERO LPT DONE FLAG IF...
	ION		/END OF STICKY SECTION
ILOOPE,	TAD	T
	CLL RTL
	RTL
	AND	P7	/GET OP CODE
	SNA
	JMP	NOSTR	/OPERATE CLASS INSTRUCTION
	TAD	IJUMP
	DCA	IJMP
	TAD	T
	AND	[777
	SNA
BR0ERR,	ERROR		/BRANCH 0 OCCURS JUST AFTER XMIT'S
	CLL RAL
	TAD	SYMTAB
	DCA	XR
SYMCDF,	HLT		/SET TO FIELD OF SYMBOL TABLE
	TAD I	XR
	DCA	IST1
	TAD I	XR
	DCA	IST2	/MOVE THE SYMBOL TABLE ENTRY INTO LOWER CORE
	CDF 0
IJMP,	HLT		/GO TO THE APPROPRIATE ROUTINE
NOSTR,	TAD	T
	TAD	[-100
	SMA		/IS IT A CONDITIONAL SKIP?
	JMP I	(BRACND	/YES
	TAD	IJMP2
	DCA	.+1	/FOR OPERATE CLASS INSTRUCTIONS, THE OPCODE
	HLT		/IS THE LOW-ORDER BITS

/INTERPRETIVE OP-CODE TABLES
IJUMP,	JMP I	.	/TABLE OF "MEMORY REFERENCE" OPERATORS
PPUSHS,	PUSHS
	PUSH1S
	PUSH2S
	BRASUB
	BRANCH
	ERRTRP
	LININC
IJMP2,	JMP I	.+101	/TABLE OF "OPERATE CLASS" OPERATORS
	SETTRP
	MULTPY
	ADD
	IMAGE
	SUB
	UMINUS
	DIVIDE
	NUMSGN
	ROUND
	CLRA
	CLRD
	BCMPTD
	RETURN
	STOP
	INIT
	XMIT
	READ
	WRITE
	FINI
	FORMS
	STORA
	D2A
	A2D
	STORD
	HEREDC
	ADDST
	SUBST
	HERET
	ASUNIT
	DSPLYA
	DSPLYD
	ACCEPT
	INCRMT
	CHAIN
	ONERXX
	HERENT
	/OPERATORS OF THE FORM 40+N ARE CONDITIONAL SKIPS.
	/N INDICATES THE NATURE OF THE SKIP AND THE TYPE OF THE OPERAND

		/PUSH A SUBSCRIPTED DESCRIPTOR ONTO THE STACK
PUSH1S,	DBCONV		/GET THE SUBSCRIPT
	SZA
	TAD	M1	/TREAT ZERO LIKE 1
	SNA
	JMP I	PPUSHS	/SUBSCRIPT OF 1 IS A NO-OP
	DCA	T
	TAD	IST1
	AND	P7770
	CLL CML CMA RTR
	RTR		/LENGTH/2 IN AC, LOW-ORDER BIT IN LINK
	DCA	T1
	STA RAL
	DCA	T2	/T2=-1 IF LENGTH WAS EVEN
	SKP
	TAD	T
	ISZ	T1	/MULTIPLY (SUBSCRIPT-1)*(LENGTH/2)
	JMP	.-2
	CLL RAL		/DOUBLE RESULT
	ISZ	T2
BUMPID,	TAD	T	/ADD IN (SUBSCRIPT-1) IF LENGTH ODD
	TAD	IST2
	DCA	IST2
	SZL
	ISZ	IST1
	TAD	IST1
	AND	P7
	DCA	T	/SET UP TO CHECK THAT WE ARE STILL
	TAD	IST1	/IN THE DATA SPACE
	CLL RAR
	AND	M4
	CLL RTR
	TAD	IST2	/COMPUTE THE ADDRESS OF THE LAST CHARACTER IN
	SZL		/THIS FIELD
	ISZ	T
	CLL
	TAD	SSLIM2	/COMPARE AGAINST DATA SECTION LIMITS
	CLA RAL
	TAD	T
	TAD	SSLIM1
	SZL CLA
SSERR,	FATAL		/WATCH OUT! TRYING TO DESTROY PROCEDURE CODE
	JMP I	PPUSHS	/PUSH THE SUBSCRIPTED DESCRIPTOR
SSLIM1,	0
SSLIM2,	0		/DATA SECTION UPPER LIMIT
	IFNZRO	SSLIM1-1574	<__ERROR DDT __>
LPDNF2,	0		/FILLED IN AT INITIAL WRITEOUT TIME
/
	PAGE

/TRANSFER OF CONTROL INSTRUCTIONS
BRASUB,	TAD	PC	/SUBROUTINE CALL
	PUSH		/PUSH THE CURRENT STATE OF THE PC
	TAD	PCCDF
	PUSH		/(FIELD AND ADDRESS)
	TAD	LINENO
	PUSH
			/UNCONITIONAL GOTO ROUTINE
BRANCH,	TAD	IST2	/TIME(9/14):	33 CYCLES
	DCA	PC	/SET PC TO LOC-1 AS WE BUMP FIRST
	TAD	IST1	/WATCH FOR DUMB FIELD CARRIES
	AND	P7
	CLL RTL
	RAL
	TAD	PCDF
	JMP	PCSUB1	/BUMP PC DOWN 1
RETURN,	TAD	PDL
	TAD	M4
	DCA	XR1
	TAD I	XR1
	DCA	PC
	TAD	XR1
	DCA	PDL
	TAD I	XR1
	SMA
RETERR,	FATAL		/RETURN WITHOUT CORRESPONDING CALL
	DCA	PCCDF	/RETURN FROM SUBROUTINE
	TAD I	XR1
	DCA	LINENO
	JMP I	[ILOOP	/AND CONTINUE
BRACND,	CLL RAR		/CONDITIONAL SKIP - CONDITIONS ARE SPECIFIED
	TAD	P7400	/OPCODES ARE ORGANIZED CLEVERLY
	DCA	COND	/TRANSLATE THEM INTO A SKIP INSTRUCTION
	SNL		/BIT 11 TELLS WHETHER IT IS A DECIMAL
	JMP	ALPHCP	/OR ALPHA COMPARE - 0 IS ALPHA, 1 DECIMAL
	AC4000
	JMS I	(DOADD	/DECIMAL - DO A SUBTRACTION
	JMS I	[SETXRT
	TAD I	XR
	ISZ	T
	JMP	.-2	/ADD UP ALL OF THE DIGITS
	SZA		/DON'T USE SIGN IF MAGNITUDE IS ZERO
	TAD	AS
CONDM1,	CLL RAL		/SIGN IN LINK, 2*(SUM OF DIGITS) IN AC
COND,	HLT		/TEST VARIOUS AC-LINK COMBINATIONS
	JMS	FETPC	/SKIP THE NEXT INSTRUCTION IF NECESSARY
	CLA
	JMP I	[ILOOP
ALPHCP,	POPDS1		/ALPHA COMPARE - POP OFF THE DESCRIPTORS
	TAD	[DES2-1
	POPDES
	DCA I	DES2F
	TAD	DES1L	/IF ONE IS LONGER THAN THE OTHER
	CIA CLL
	TAD	DES2L
	SNL
	CLA		/USE THE SHORTER LENGTH AS THE
	TAD	DES1L	/COMPARISON COUNT
	DCA	DES1L
ALCPLP,	GETCH1		/GET A CHAR FROM DES1
	DCA	T1
	GETCH2		/GET A CHAR FROM DES2
	CIA CLL
	TAD	T1
	SZA
	JMP	COND	/AGAIN, THE LINK TELLS WHICH IS LARGER
	ISZ	DES1L
	JMP	ALCPLP	/LOOP FOR ALL CHARACTERS
	JMP	CONDM1	/ZERO LINK & REPORT EQUALITY

FETPC,	0		/SUBROUTINE TO FETCH NEXT INSTRUCTION
	ISZ	PC	/TIME(10/24):	10 CYCLES
	JMP	PCCDF	/NO FIELD CHANGE
	TAD	PCCDF
	TAD	[10
	DCA	PCCDF	/BUMP FIELD
PCCDF,	CDF 10
	TAD I	PC
	CDF 0
	JMP I	FETPC
BCMPTD,	JMS	FETPC	/COMPUTED GOTO
	DCA	FETPC	/GET LIMIT
	DBCONV		/GET INDEX AND CONVERT TO BINARY
	DCA	T
	TAD	BS	/CHECK IF SIGN WAS NEGATIVE
	AND	[40
	SNA CLA		/IF IT WAS, INDEX IS OUT OF RANGE
	TAD	T
	CIA
	CLL
	TAD	FETPC
	SNL		/TEST FOR 0 OR OUT OF RANGE
	STA
	CMA
	TAD	FETPC
BUMPPC,	TAD	PC
	DCA	PC	/BUMP THE PC BY THE PROPER INCREMENT
	RTL		/SO THAT THE NEXT INSTRUCTION WE WILL EXECUTE
	RTL		/WILL EITHER BE THE DESIRED BRANCH INSTRUCTION
	TAD	PCCDF	/OR (IF THE INDEX WAS ILLEGAL) THE INSTRUCTION
	DCA	PCCDF	/AFTER THE ENTIRE BRANCH LIST
	JMP I	(ONERXX
LPATCH,	ISZ	PDL
	ISZ	PDL
	TAD	PCCDF
PCSUB1,	TAD	P7770
	DCA	PCCDF	/BUMP DOWN DATA FIELD
	STA CLL
	JMP	BUMPPC	/NOW INCREMENT PC BY 4095

/*** CHAIN PROCESSOR ***
CHAIN,	DBCONV		/GET PROGRAM NUMBER
	DCA	COND
	TAD	COND
	AND	P7770
	SZA CLA
CHNERR,	FATAL
	TAD	(RSLDR-1&17^400	/RSYS LOADER CCB ADDRESS
	JMS I	SYS	/PART OF THE LOADER SNEAKILY
	200		/SHARES CORE WITH THE CCB
	4000
	RSLDR-1%20
	TAD	(RSLDR&17^400	/RSYS LOADER ADDRESS
	JMS I	SYS
	600
	0
	RSLDR%20
	TAD	COND
	JMP I	CHNPTR	/START UP LOADER AT CHAIN ENTRY
	PAGE

/ARITHMETIC ROUTINES
SUB,	AC4000
ADD,	JMS I	(DOADD	/ADD AND SUBTRACT USE SAME SUBROUTINE
PUSHA,	TAD	PDL
	DCA	PUTDW
	AC7776
	DCA	PUTDB	/SET UP THE "PUT" DESCRIPTOR TO STORE
	TAD	PCDF	/CHARACTERS ONTO THE PUSHDOWN LIST
	DCA I	PUTDF
	TAD	PDL
	CLL RAL		/SET UP A FAKE DESCRIPTOR TO POINT TO THE
	DCA	IST2	/CURRENT POSITION OF THE PUSHDOWN LIST
	RAL
	TAD	[10
	DCA	IST1
	JMS I	[SETXRT
	TAD I	XR	/ELIMINATE LEADING ZEROS FROM THE NUMBER THAT WE
	SZA		/ARE PUSHING
	JMP	STORIT	/FOUND A SIGNIFICANT DIGIT - START STORING
	ISZ	T
	JMP	.-4
	JMP	STLSDG	/NUMBER WAS ZERO - STORE A SINGLE 0 AS RESULT
STORLP,	TAD	[21
	PUTCHI	/STORE CHARACTER IN -237 ASCII
	TAD	IST1
	TAD	[10
	DCA	IST1	/BUMP LENGTH IN DESCRIPTOR
	TAD I	XR
STORIT,	ISZ	T	/IS THIS THE LAST DIGIT?
	JMP	STORLP	/NO - KEEP GOING
	TAD	AS	/THE LAST DIGIT IS SPECIAL AS WE MUST
	SPA		/FLAG IT IF THE NUMBER IS NEGATIVE
	TAD	(4040	/THE FLAG CONSISTS OF A 40 BIT
STLSDG,	TAD	[21
	PUTCHI		/STORE THE FINAL DIGIT
	AC0002
	TAD	PUTDB	/USE THE LEFT-RIGHT INDICATOR
	TAD	PUTDW	/TO BUMP THE WORD POINTER UP, IF NECESSARY
	DCA	PDL	/SAVE NEW PUSHDOWN POINTER
PUSHS,	TAD	IST1	/PUSH A DESCRIPTOR ONTO THE STACK
	DCA I	PDL	/TIME(11/23):	27 CYCLES
	ISZ	PDL
	TAD	IST2
	PUSH
	JMP I	[ILOOP

ADDAB,	0		/ADD A-REGISTER TO B-REGISTER
	TAD	NUMLEN	/AC ON ENTRY HAS NUMBER OF DIGITS TO IGNORE
	DCA	T
	TAD	ALAST	/TIME(11/4):	28N+9 IF SIGNS ARE EQUAL
	DCA	T1	/		27N+14 IF SIGNS ARE UNEQUAL
	TAD	(ACB+DIGITS-1	/	45N+27 IF SIGN CHANGES
	DCA	T2	/WHERE N=NUMBER OF SIGNIFICANT(NON-IGNORED) DIGITS
	TAD	AS
	TAD	BS
	SMA CLA		/IF SIGNS ARE EQUAL DO AN ADD,
	JMP	ADDPOS	/OTHERWISE DO A SUBTRACT
	TAD	T
	DCA	CMPCNT	/SUBTRACT - SAVE DIGIT COUNT, WE MIGHT NEED IT
	JMP	ADDNEG	/FOR THE RE-COMPLEMENT.  JUMP INTO THE LOOP.
ANEGLP,	STA
	TAD	T1
	DCA	T1
	STA
	TAD	T2	/THIS CODE IS DUPLICATED IN THE ADD LOOP FOR SPEED
	DCA	T2
	RAL		/TWO AC OVERFLOWS LEAVE THE LINK THE SAME
ADDNEG,	TAD I	T2
	CIA
	TAD I	T1	/DO A DIGIT SUBTRACT
	CLL
	SPA		/IF THE RESULT IS NEGATIVE
	TAD	(12	/WE HAVE TO BORROW FROM THE NEXT PLACE
	DCA I	T1
	ISZ	T	/THE CARRY IS NOW IN THE LINK
	JMP	ANEGLP
	SNL CLA		/CARRY AT THE END MEANS THE SIGN CHANGED
	JMP I	ADDAB	/IT DIDN'T - GO AWAY HAPPY
	TAD	ALAST
	DCA	T1
	TAD	CMPCNT
	DCA	T	/SET UP FOR RECOMPLEMENT
	CLL
NEGLP,	CLA RAL		/GET THE PREVIOUS CARRY
	TAD I	T1	/THIS IS ACTUALLY A TEN'S COMPLEMENT OPERATION
	SNA
	JMP	.+4	/WATCH OUT FOR ZEROS SO THEY DON'T BECOME 10'S
	CIA
	TAD	(12
	DCA I	T1
	STA CML		/THIS COMPLEMENTS THE LINK
	TAD	T1	/THIS COMPLEMENTS IT AGAIN
	DCA	T1
	ISZ	T
	JMP	NEGLP
	TAD	BS	/RECOMPLEMENT MEANS CHANGE SIGNS - HOWEVER THIS
	DCA	AS	/IS FASTER SINCE WE KNOW THE SIGNS WERE DIFFERENT
	JMP I	ADDAB
APOSLP,	STA
	TAD	T1	/THIS IS THE DUPLICATED CODE
	DCA	T1
	STA
	TAD	T2
	DCA	T2
	RAL		/GET THE CARRY INTO THE AC
ADDPOS,	TAD I	T1
	TAD I	T2
	TAD	(-12	/CHECK THAT THE SUM OF THESE DIGITS IS NOT > 10
	CLL CML
	SPA
	TAD	(12	/NO - CLEAR THE LINK AND RESTORE THE RESULT
	DCA I	T1
	ISZ	T
	JMP	APOSLP
	JMP I	ADDAB
RNDADD,	TAD	M4
	SMA SZA CLA	/DIGIT GREATER THAN 4 MEANS WE SHOULD BUMP
	IAC
	JMS I	[FAKNUM	/PUT A 0 OR A 1 ON THE STACK
	AC0002
	POPNUM		/AND FROM THERE INTO ACCUMULATOR B
	TAD	AS
	DCA	BS	/SET SIGNS EQUAL FOR MAGNITUDE ADD
	JMS	ADDAB
	JMP	PUSHA	/STORE RESULT ON STACK
	PAGE

/MULTIPLY AND UNARY MINUS ROUTINES
MULTPY,	AC0002
	POPNUM		/GET THE ARGUMENTS
	TAD	T	/GET THE NUMBER OF DIGITS STORED
	TAD	NUMLEN
	CMA		/FORM AN INITIAL COUNT OF THE NUMBER OF DIGITS TO
	DCA	DVTEMP	/IGNORE ON ADDS (LESS ONE FOR CARRIES)
	POPLFT		/(GET THE MULTIPLIER LEFT ADJUSTED)
	JMP	MULZRO	/MULTIPLICAND IS ZERO MEANS RESULT IS ZERO
	TAD	AS
	TAD	BS
	DCA	AS	/COMBINE SIGNS TO GET RESULT SIGN
	TAD	AS
	DCA	BS	/SET SIGNS THE SAME SO ADDITION WILL WORK
	CLA IAC
	TAD	QDIGIT	/GET NUMBER OF LEADING ZEROS IN MULTIPLIER
	TAD	NUMLEN	/CALCULATE THE NUMBER OF SIGNIFICANT DIGITS
	DCA	QDIGIT	/STORE THAT COUNT
MULTLP,	TAD I	AP1	/GET THE LEADING DIGIT OF THE MULTIPLIER
	CMA
	DCA	ALEFT
	JMP	.+3	/USE IT AS AN ADD COUNTER
	TAD	DVTEMP
	JMS I	(ADDAB	/DO AN ADD OF SUITABLE LENGTH
	ISZ	ALEFT
	JMP	.-3
	DCA I	AP1	/KILL THE DIGIT WE JUST USED
	ISZ	QDIGIT	/IS THIS THE LAST DIGIT?
	SKP		/NO
	JMP I	(PUSHA	/YES - DON'T SHIFT, WE'RE THROUGH
	JMS	ALEFT	/SHIFT MULTIPLIER AND PRODUCT LEFT 1
	STA
	TAD	DVTEMP	/BUMP DOWN THE NUMBER OF DIGITS TO IGNORE
	DCA	DVTEMP	/ON ADDS
	JMP	MULTLP	/START ON NEXT MULTIPLIER DIGIT
UMINUS,	POPNUM
	AC4000
	TAD	AS
	DCA	AS
	JMP I	(PUSHA
AP1,	ACA+1

/DIVIDE ROUTINE
DIVIDE,	AC0002
	POPLFT		/GET DIVISOR LEFT ADJUSTED
D0ERR,	ERROR		/DIVISION BY ZERO IS AN ERROR
	TAD	QDIGIT
	DCA	DBCNVX	/STORE NUMBER OF TRAILING BLANKS IN THE DIVISOR
	POPLFT		/GET DIVIDEND LEFT ADJUSTED
	JMP	MULZRO	/DIVISION INTO ZERO GIVES ZERO
	TAD	AS
	TAD	BS
	DCA	DVTEMP	/SAVE THE SIGN OF THE RESULT
	TAD	DBCNVX
	CMA CLL		/FORM THE DIFFERENCE BETWEEN THE NUMBER OF
	TAD	QDIGIT	/TRAILING ZEROS IN THE TWO NUMBERS
	DCA	BS	/SNEAKY - THIS SETS THE DIVIDEND NEGATIVE
	SZL		/OR DID IT? - IF THE DIVIDEND HAS LESS TRAILING
	JMP	MULZRO	/ZEROS THAN THE DIVISOR, THE QUOTIENT IS ZERO!
	SKP		/JUMP INTO THE DIVISION LOOP
DIVLP1,	JMS	ALEFT	/SHIFT DIVIDEND LEFT 1 AND EXPOSE NEW QUOTIENT DIGIT
	DCA	AS	/SET AS DIFFERENT THAN BS (WHICH IS NEGATIVE)
DIVLP2,	TAD I	A
	SZA CLA		/IF A HAS MORE PRECISION THAN B,
	JMP	TRYSUB	/THEN SUBTRACTION WILL SUCCEED
	TAD I	AP1
	CMA CLL		/SINCE SUBTRACTION IS SO TIME-CONSUMING,
	TAD I	BP1	/DO A QUICK TEST TO SEE IF B>A.
	SZL CLA
	JMP	DONTRY	/IT IS - DON'T EVEN TRY TO SUBTRACT
TRYSUB,	JMS I	(ADDAB
	TAD	AS
	SPA CLA		/DID THE SUBTRACTION FORCE A NEGATIVE?
	JMP	DVOOPS	/YES - ADD B BACK IN
	ISZ I	ALAST	/BUMP QUOTIENT DIGIT
	JMP	DIVLP2
DVOOPS,	DCA	AS	/MAKE A AND B SIGNS DIFFERENT AGAIN
	JMS I	(ADDAB	/THIS MAKES A NEGATIVE AGAIN BUT WE DON'T CARE
DONTRY,	ISZ	BS	/BUMP DIGIT COUNT
	JMP	DIVLP1	/KEEP GOING
	TAD	DBCNVX	/DONE - ZERO OUT THE REMAINDER BY FAKING "MULZRO"
MULZRO,	JMS	SETXRT	/ZERO ALL OF A OR ONLY THE HIGH ORDER DIGITS
	DCA I	XR	/DEPENDING ON THE AC ON ENTRY TO MULZRO
	ISZ	T
	JMP	.-2
	TAD	DVTEMP
	DCA	AS	/THIS IS IGNORED ON MULTIPLY AS RESULT IS 0
	JMP I	(PUSHA	/PUSH THE RESULT
DVTEMP,	0
BP1,	ACB+1

ALEFT,	0		/SUBROUTINE TO SHIFT A LEFT ONE PLACE
	TAD	A	/TIME(10/24):	172 CYCLES
	DCA	XR2
	CLA IAC
	JMS	SETXRT	/SET UP FOR SHIFT LOOP
	TAD I	XR2	/MOVE EACH DIGIT
	DCA I	XR	/TO THE DIGIT SLOT BEFORE IT
	ISZ	T	/LOOP N-1 TIMES WHERE N IS THE NUMBER OF DIGITS
	JMP	.-3
	DCA I	XR	/ZERO THE LAST DIGITS PLACE
	JMP I	ALEFT
DBCNVX,	0		/DECIMAL TO BINARY CONVERSION ROUTINE
	POPDS1		/TIME(11/23):	36L+60 CYCLES
DBCVLP,	DCA	QDIGIT
	TAD	QDIGIT
	CLL RTL
	TAD	QDIGIT	/MULTIPLY PREVIOUS RESULT BY 10
	RAL
	DCA	QDIGIT
	GETCH1		/GET A CHARACTER FROM THE NUMBER
	DCA	BS
	STA
	TAD	BS
	AND	P17
	TAD	QDIGIT	/ADD IT TO THE RESULT
	ISZ	DES1L	/MORE?
	JMP	DBCVLP	/YES - STORE NEW RESULT AND LOOP
	JMP I	DBCNVX	/RETURN WITH RESULT IN AC
SETXRT,	0
	TAD	NUMLEN	/** AC MAY NOT BE ZERO ON ENTRY! **
	DCA	T
	TAD	(ACA-1
	DCA	XR	/INITIALIZE COUNT AND INDEX PTR
	JMP I	SETXRT
ASUNIT,	DBCONV		/GET THE NUMBER ON THE STACK
	AND	P17	/MAKE SURE ITS LEGAL
	DCA I	TIFN
	JMP I	[ILOOP	/STORE IT IN THE MONITOR "INIT" ROUTINE
	PAGE

/DECIMAL TO ALPHA CONVERSION (EDITED)
IMAGE,	TAD	[DES2-1
	POPDES		/GET DESCRIPTOR OF EDIT FIELD
	DCA I	DES2F
	DCA	AS	/FIXES EDIT-ZERO KLUDGE
	POPLFT		/GET NUMBER TO BE EDITED
	JMP	ZEROT	/THE NUMBER 0 HAS 0 SIGNIFICANT DIGITS
	TAD	QDIGIT	/COMPUTE THE NUMBER OF
	TAD	NUMLEN	/SIGNIFICANT DIGITS
	CMA
ZEROT,	DCA	T	/AND STORE IT
	TAD	DES2L
	DCA	DES1L
	TAD	DES2W	/COPY THE EDIT DESCRIPTOR,
	DCA	DES1W	/AS WE MUST MAKE 2 PASSES OVER THE FIELD
	TAD	DES2B
	DCA	DES1B
	TAD I	DES2F
	DCA I	DES1F
	TAD	DES2L
	DCA	IMIGNR	/SET COUNTER TO LENGTH OF EDIT FIELD
	CLA IAC
	DCA	IBLCHR	/BLANK FILL
SCANLP,	GETCH2		/GET A CHAR FROM THE EDIT FIELD
	TAD	(-13
	SZA
	JMP	.+3
	TAD	(13
	DCA	IBLCHR
	TAD	(-56
	CLL RTR
	SZA CLA		/IS IT AN X OR A Z?
	JMP	SCANSZ	/NO
	SZL		/YES - IS IT A Z?
	ISZ	IMIGNR	/YES - BUMP COUNTER DOWN BY 1
	STA		/BUMP DOWN THE SIG DIG COUNT
	TAD	T
	DCA	T
SCANSZ,	ISZ	DES2L
	JMP	SCANLP
	JMS I	(STSETP	/SET UP RESULT DESCRIPTOR AND TRACE HOOK
LBLOOP,	TAD	IMIGNR	/GET THE COUNTER (WHICH IS, AS YOU MAY HAVE
	CIA		/GUESSED, THE LENGTH OF THE EDITED FIELD)
	TAD	PUTDL	/AND COMPARE IT TO THE RESULT FIELD LENGTH.
	SMA
	JMP	SETIGN	/IT'S LARGER - WE'LL HAVE TO IGNORE SOME CHARACTERS
	CLA IAC		/ITS SMALLER - PUT OUT A BLANK
	PUTCHI
	ISZ	PUTDL	/REDUCE THE RESULT LENGTH
	JMP	LBLOOP	/AND CONTINUE
	JMP I	[ILOOP	/THE EDITED FIELD IS NULL - THE RESULT IS BLANKS
SETIGN,	CMA
	DCA	IMIGNR	/SET IGNORE COUNT (-1 MEANS NONE, -2 ONE, ETC.)
	TAD	A
	DCA	XR	/INITIALIZE DIGIT XR
	TAD	IMJBLN
	DCA	IPERSW	/INITIALIZE THE PERIOD SWITCH
IMGLP,	GETCH1		/GET A CHARACTER FROM THE EDIT FIELD
	TAD	(-17
	SZA		/IS IT A PERIOD?
	JMP	.+3	/NO
	TAD	IMGSZA
	DCA	IPERSW	/SET PERIOD SWITCH ON
	IAC
IMGSZA,	SZA		/IS IT A MINUS SIGN?
	JMP	NOTMNS	/NO
	TAD	DES1L	/DISTINGUISH BETWEEN IMBEDDED MINUS
	CMA		/SIGNS AND LEADING OR TRAILING ONES -
	SZA CLA		/WE ALWAYS WANT TO PRINT IMBEDDED
	TAD	T	/MINUS SIGNS BECAUSE THEY MIGHT BE PART OF
	SMA SZA CLA	/A PART NUMBER OR SOMETHING
	JMP	NOTMNS	/BIG DEAL.
	TAD	AS
	SMA CLA		/IS THE NUMBER NEGATIVE?
	TAD	(40-55	/NO - PRINT BLANK INSTEAD OF MINUS SIGN
NOTMNS,	IAC
	SZA		/IS IT A COMMA?
	JMP	.+4	/NO
	TAD	T
	SPA SNA CLA	/HAVE WE PRINTED A SIGNIFICANT DIGIT YET?
IMJBLN,	JMP	IMBLNK	/NO - DON'T PRINT COMMA
	TAD	(54-130
	CLL RTR
	SNA		/IS IT AN X OR A Z?
	JMP	XORZ	/YES
	RTL
	TAD	(71
IMOPUT,	ISZ	IMIGNR	/ARE WE STILL IGNORING CHARACTERS
	JMP	IMNXTC	/YES
	PUTCHI		/OUTPUT THIS CHAR
	STA
	DCA	IMIGNR	/RESET IGNORE COUNT
IMNXTC,	CLA
	ISZ	DES1L	/ARE WE DONE?
	JMP	IMGLP	/NO
	JMP I	(STEXIT	/GO TO COMMON CODE WITH "STORA"

XORZ,	ISZ	T	/BUMP SIGNIFICANT DIGIT COUNTER
	TAD	T	/NEGAIVE OR ZERO MEANS NO SIGNIFICANCE YET
	SPA SNA CLA	/SHOULD WE PRINT THIS DIGIT?
IPERSW,	HLT		/EITHER "JMP IMBLNK"(PRINT BLANK) OR "SKP"(PRINT 0)
	TAD I	XR	/GET A DIGIT FROM THE NUMBER
	TAD	[21	/CONVERT TO ALPHA
	SNL		/LINK IS ON IF EDIT CHAR WAS "Z"
	JMP	IMOPUT	/IT WAS "X" - GO PRINT
	JMP	IMNXTC	/"Z" - IGNORE THIS DIGIT
IMBLNK,	TAD	IBLCHR
	JMP	IMOPUT
IBLCHR,	0
CLRD,	TAD	[20	/DECIMAL CLEAR - FILL WITH ZEROS
CLRA,	IAC		/ALPHA CLEAR - FILL WITH BLANKS
	DCA	T1	/TIME(11/23):	31L+85
	JMS I	(STSETP	/SET UP DESCRIPTOR OF CLEAR-EE
CLRLP,	TAD	T1
	PUTCHI		/FILL THE FIELD WITH WHATEVER
	ISZ	PUTDL
	JMP	CLRLP
	JMP I	(STEXIT
IMIGNR,	0
	PAGE

/PACKED DECIMAL TO UNPACKED DECIMAL ROUTINES
POPNMX,	0		/PACKED TO UNPACKED RIGHT JUSTIFIED
	JMS	POPGTA	/SET UP COMMON POINTERS
	TAD	DES1L	/TIME(11/23):	26L+145 CYCLES
	IFZERO	DIGITS-23&4000	<
	CIA
	TAD	NUMLEN
	DCA	POPGTA
	DCA I	XR2	/ZERO OUT HIGH-ORDER DIGITS
	ISZ	POPGTA	/WITH AN ISZ LOOP
	JMP	.-2>
	IFNZRO	DIGITS-23&4000	<
	CMA
	TAD	(JMP DCAXR2	/COMPUTE JUMP INTO ZEROING TABLE
	DCA	.+1
	HLT		/JUMP!
DCAXR2,	IFZERO	DIGITS-2&4000	<DCA I	XR2>
	IFZERO	DIGITS-3&4000	<DCA I	XR2>
	IFZERO	DIGITS-4&4000	<DCA I	XR2>
	IFZERO	DIGITS-5&4000	<DCA I	XR2>
	IFZERO	DIGITS-6&4000	<DCA I	XR2>
	IFZERO	DIGITS-7&4000	<DCA I	XR2>
	IFZERO	DIGITS-10&4000	<DCA I	XR2>
	IFZERO	DIGITS-11&4000	<DCA I	XR2>
	IFZERO	DIGITS-12&4000	<DCA I	XR2>
	IFZERO	DIGITS-13&4000	<DCA I	XR2>
	IFZERO	DIGITS-14&4000	<DCA I	XR2>
	IFZERO	DIGITS-15&4000	<DCA I	XR2>
	IFZERO	DIGITS-16&4000	<DCA I	XR2>
	IFZERO	DIGITS-17&4000	<DCA I	XR2>
	IFZERO	DIGITS-20&4000	<DCA I	XR2>
	IFZERO	DIGITS-21&4000	<DCA I	XR2>
	IFZERO	DIGITS-22&4000	<DCA I	XR2>
	>
	DCA	T	/ZERO DIGIT COUNTER
	JMS	GETDIG	/GET FIRST DIGIT OF NUMBER - BLANK IS ZERO
	JMS	POPCMN	/CALL SUBROUTINE TO UNPACK DIGITS
	JMP I	POPNMX
POPLFX,	0		/PACKED TO UNPACKED LEFT JUSTIFIED
	JMS	POPGTA	/TIME(11/23):	21L+217 CYCLES
	DCA I	XR2	/SET LEFTMOST DIGIT TO ZERO
	TAD	NUMLEN	/INITIALIZE COUNTER USED LATER TO INSERT
	IAC
	DCA	T	/TRAILING ZEROS
	DCA	QDIGIT	/INITIALIZE COUNT OF TRAILING ZEROS
LZLOOP,	JMS	GETDIG
	SZA		/DON'T INSERT LEADING ZEROS
	JMP	SIGDIG
	ISZ	DES1L
	JMP	LZLOOP
	JMP I	POPLFX	/HMN - ALL WE GOT IS LEADING ZEROS - RETURN
SIGDIG,	JMS	POPCMN	/UNPACK DIGITS AND SIGN
	DCA I	XR2
	ISZ	QDIGIT
	ISZ	T	/ZERO OUT LOW ORDER DIGITS OF ACCUMULATOR
	JMP	.-3
	ISZ	POPLFX
	JMP I	POPLFX	/SKIP RETURN TO SHOW SOMETHING IS THERE

POPGTA,	0		/SETUP ROUTINE FOR POPNUM AND POPLFT
	TAD	(A
	DCA	T1	/POINTER TO AC CONTROL BLOCK
	STA		/TIME(10/24):	100 CYCLES
	TAD I	T1
	DCA	XR2	/XR2 POINTS TO ACCUMULATOR -1
	POPDS1		/GET A DESCRIPTOR OFF OF THE STACK
	TAD	NUMLEN
	CMA CLL
	TAD	DES1L	/MAKE SURE THAT THE NUMBER WILL FIT
	SNL CLA		/IN THE ACCUMULATORS
NUMERR,	ERROR		/IT WON'T
	JMP I	POPGTA	/RETURN
POPCMN,	0		/TIME(10/24):	32L-10 CYCLES
	JMP	POPCTS	/START IN MIDDLE OF LOOP
POPCLP,	DCA I	XR2	/STORE DIGIT
	JMS	GETDIG	/GET DIGIT, TREATING BLANK AS 0
POPCTS,	ISZ	T	/BUMP DIGIT COUNTER
	SKP
	JMP	NUMERR	/OOPS - TOO MANY DIGITS IN POPLFT
	ISZ	DES1L	/IS THIS THE LAST DIGIT?
	JMP	POPCLP	/NO - STORE IT AND GET ANOTHER
	CLL
	SPA		/FUDGE FOR A2D CONVERSION
	JMP	.+3
	TAD	(7740	/LAST DIGIT MAY HAVE SIGN FLAG IN 40 BIT
	AND	(37	/PUSH FLAG INTO LINK AND ISOLATE DIGIT IN AC
	DCA I	XR2	/SAVE LAST DIGIT
	RAR		/GET LINK
	ISZ	T1	/SECOND WORD OF CONTROL BLOCK IS SIGN WORD
	DCA I	T1
	JMP I	POPCMN	/RETURN
NUMSGN,	POPDS1		/GET DESCRIPTOR
	GETCH1		/GET FIRST CHARACTER
	JMS I	[FAKNUM	/PUT IT ON THE STACK
	JMP I	[ILOOP	/RETURN

/"INCREMENT" OPERATOR
INCRMT,	POPDS1
	TAD	DES1L
	DCA	PUTDL	/SAVE LENGTH
	SKP
	GETCH1
	ISZ	DES1L	/SKIP TO LAST DIGIT
	JMP	.-2
	CLA
	TAD I	DES1F
	DCA I	PUTDF
	TAD	DES1B
	DCA	PUTDB
INCRLP,	TAD	DES1W
	DCA	PUTDW	/SET PUT DESCR TO GET DESCR
	JMS	GETDIG
	TAD	(-11	/IS THE DIGIT A 9?
	SNA
	JMP	INCARY	/YES - PERFORM A CARRY
	TAD	(33	/INCREMENT IT
	PUTCHI
	JMP I	[ILOOP
INCARY,	TAD	[21
	PUTCHI		/9 GOES TO ZERO
	STA
	TAD	DES1W
	DCA	DES1W	/BUMP CHAR PTR BACK 2 (GETCH1 BUMPED IT +1)
	ISZ	PUTDL	/CHECK FOR OVERFLOW
	JMP	INCRLP
	JMP	NUMERR	/NUMBER OVERFLOWED 99999....
GETDIG,	0
	GETCH1
	TAD	M1
A2DKLG,	SZA		/NOP'D BY A2D ROUTINE
	TAD	(-20	/TREAT BLANK AS 0
	JMP I	GETDIG
	PAGE

/STORE OPERATORS
STSETP,	0		/STORE SETUP SUBROUTINE
	TAD	[PUTDES-1
	POPDES		/GET DESTINATION
	DCA I	PUTDF
	TAD	TRCJMP
	DCA I	(PUTRET	/ENABLE TRACE OUTPUT
	JMP I	STSETP	/RETURN
STORA,	POPDS1		/GET SOURCE
	JMS	STSETP	/STORA ALPHANUMERIC OPERATOR
STALP,	GETCH1
	PUTCHI		/MOVE A CHARACTER
	ISZ	DES1L	/INPUT EXHAUSTED?
	SKP		/EVIDENTLY NOT
	JMP	STEXIT	/YES - DON'T ALTER THE REST OF THE DESTINATION
	ISZ	PUTDL
	JMP	STALP	/GO TILL DESTINATION FULL
STEXIT,	TAD	(PUTJMP	/STORE CLEANUP ROUTINE
	DCA I	(PUTRET	/DISABLE TRACE OUTPUT
	TAD	TRCJMP
	SZA CLA		/WAS THERE ANY?
	JMP I	[ILOOP	/NO
	TAD	S5
	JMS I	CDOIO
	.		/SUAVE WAY OF OUTPUTTING CRLF
S5,	5
	JMP I	[ILOOP
STORD,	POPDS1		/GET SOURCE
	JMS	STSETP	/STORE DECIMAL OPERATOR
TSD2SM,	TAD	DES1L
	CMA CLL
	TAD	PUTDL	/COMPUT NUMBER OF LEADING ZEROS
	SNL
	JMP	NOTOBG	/FIRST MAKING SURE THAT THE DESTINATION IS LARGER
	GETCH1		/IT AIN'T - WASTE A CHARACTER
	CLA
	ISZ	DES1L	/BUMP THE SOURCE LENGTH DOWN
	JMP	TSD2SM	/AND TRY AGAIN
NOTOBG,	DCA	T1
	JMP	.+3	/MAY BE NO LEADING ZEROS
	TAD	[21
	PUTCHI
	ISZ	T1
	JMP	.-3
	JMP	STALP	/NOW TRANSFER THE DIGITS
SUBST,	AC4000		/SUBTRACT AND STORE - A TIME AND CORE SAVER
ADDST,	JMS I	(DOADD	/ADD AND STORE - DITTO
	JMP	SHTCUT	/TAKE THE SHORTCUT

/ALPHA TO DECIMAL CONVERSION
A2D,	TAD	P7400
	DCA I	(A2DKLG	/A KLUDGE FOR KLODS
	POPNUM		/GET THE ALPHA STRING AS A NUMBER
	TAD	A2DSZA
	DCA I	(A2DKLG	/UNKLUDGE
	TAD	AS
	SPA CLA
	JMP	A2DERR	/SIGN SHOULD BE POSITIVE, OTHERWISE ILLEGAL CHAR
	TAD	ALAST
	DCA	T1	/OF COURSE WE MAY HAVE SOME ILLEGAL DIGITS
	TAD	ALAST	/MIXED IN BECAUSE OF SIGNS
	DCA	T2
	TAD	NUMLEN
	DCA	T
A2DLP,	TAD I	T1
	DCA	BS	/SAVE THIS DIGIT
	DCA I	T1	/AND ZERO IT
	TAD	BS
	SPA
	JMP	A2DSGN	/NEGATIVE IMPLIES A SIGN (+ OR -)
	TAD	(-12
	SMA CLA		/MAKE SURE ITS A LEGAL DIGIT
	JMP	A2DERR	/NO - ERROR
	TAD	BS
	DCA I	T2	/STORE IT BACK
	STA
	TAD	T2
	DCA	T2	/BUMP STORE POINTER
A2DCMN,	STA
	TAD	T1
	DCA	T1	/BUMP FETCH POINTER
	ISZ	T
	JMP	A2DLP	/GO THROUGH ALL THE "DIGITS"

SHTCUT,	JMS	STSETP	/SET UP THE DESTINATION AND TRACE FLAG
	DCA	T	/ZERO THE "NON-ZERO" FLAG
	TAD	PUTDL
	TAD	ALAST	/COMPUTE STARTING DIGIT
	DCA	XR
	SKP
SHTPUT,	PUTCHI		/PUT OUT THIS DIGIT
	TAD	PUTDL
	CIA
	TAD	NUMLEN
	SMA SZA CLA
	TAD	(-20	/WATCH OUT FOR LARGE DESTINATIONS
	SZA
	ISZ	XR	/BUMP PAST DUMMIES
	SNA
	TAD I	XR	/GET THE NEXT DIGIT FROM THE DECIMAL AC
A2DSZA,	SZA
	ISZ	T	/SET FLAG IF DIGIT NON-ZERO
	TAD	[21	/CONVERT TO -237 ASCII
	ISZ	PUTDL	/LAST DIGIT?
	JMP	SHTPUT	/NOT YET
	DCA	T1	/SAVE LAST DIGIT
	TAD	T
	SZA CLA		/ANY NON-ZERO DIGITS?
	TAD	AS
	SPA CLA		/IF SO, IS THE SIGN NEGATIVE?
	TAD	[40	/YES - PUT A SIGN BIT OVER THE LAST DIGIT
	TAD	T1
	PUTCHI
	JMP	STEXIT	/CANCEL TRACE AND LEAVE
A2DSGN,	TAD	[20	/IGNORE BLANKS
	SZA
	TAD	(-13	/AND + SIGNS
	CLL RTR
	SZA		/AND RECORD - SIGNS
A2DERR,	ERROR		/ALL OTHER CHARACTERS ARE ILLEGAL
	RAR
	TAD	AS
	DCA	AS	/UPDATE THE SIGN WORD
	JMP	A2DCMN	/AND CONTINUE
	PAGE

/DECIMAL-TO-ALPHA CONVERSION OPERATOR
D2A,	POPNUM		/GET THE NUMBER
	JMS I	[SETXRT
	TAD	XR
	DCA	XR1	/SET UP AUTO-XRS FOR KLUDGE SCAN
D2ASLP,	TAD I	XR	/TURN ALL NON-SIGNIFICANT DIGITS
	SZA CLA
	JMP	D2ASIG	/TO PSEUDO-BLANKS (-20'S)
	TAD	(-20
	DCA I	XR1
	ISZ	T
	JMP	D2ASLP
	DCA I	ALAST	/PUT THE LAST DIGIT BACK
D2ASIG,	TAD	AS	/WHEN WE FIND A SIGNIFICANT DIGIT, WE CHANGE
	SMA CLA
	JMP I	(SHTCUT	/THE LAST BLANK TO A PSEUDO-MINUS SIGN (-3)
	TAD	XR1	/IF THE SIGN OF THE NUMBER IS NEGATIVE
	DCA	T
	DCA	AS	/THEN WE ZERO OUT THE SIGN
	AC7775
	DCA I	T
	JMP I	(SHTCUT	/THEN GO STORE THE RESULTING ABORTION

/INIT - INITIALIZE FILE I/O
INIT,	JMS I	[FETPC
	DCA	T2	/GET I/O DEVICE AND DIRECTION
	TAD	T2
	RAL
	SNL SMA CLA	/DOES THE I/O DEVICE NEED A LABEL?
	JMP	NOLABL	/NO
	POPDS1		/TOP OF STACK DESCRIBES LABEL
	TAD	(LABEL-1
	DCA	XR
	AC7775		/3 WORDS
	DCA	T1
LGETLP,	JMS I	(LGETCH
	CLL RTL
	RTL
	RTL
	DCA	T
	JMS I	(LGETCH
	TAD	T
	DCA I	XR
	ISZ	T1
	JMP	LGETLP
NOLABL,	JMS I	(IOCOMN	/GET FILE NUMBER TABLE ENTRY
	RAL
	SZL SPA CLA	/IS THIS ALREADY BEING USED FOR FILE I/O?
INIERR,	FATAL		/YES - ERROR (NON-MASS STORAGE I/O DOESN'T COUNT)
	TAD	T2	/GET I/O DEVICE AND DIRECTION
	DCA I	T	/PUT IT IN THE TABLE
	TAD I	T
	IAC		/FOR "INIT(N,SYS)" COMMAND
	RAL
	SNL SMA CLA	/IS IT A MASS STORAGE INIT?
	JMP I	[ILOOP	/NO - WE'RE DONE
	TAD	(BARRAY
	DCA	T1	/WE NEED A BUFFER FOR MASS STORAGE I/O
	TAD	(-7
	DCA	T2
GETBLP,	TAD I	T1	/CHECK FOR NONEXISTENT OR USED BUFFER
	SMA SZA CLA	/SIGN BIT OF BUFFER TABLE ENTRIES IS ON
	JMP	FNDBUF	/IF THE BUFFER IS BEING USED
	ISZ	T1
	ISZ	T1
	ISZ	T2
	JMP	GETBLP
BUFERR,	FATAL		/COULDN'T FIND A BUFFER
FNDBUF,	AC4000
	TAD I	T
	RAL
	SNL SMA CLA
	AC4000		/TURN SIGN BIT ON FOR WRITE ONLY
	TAD I	T1	/ADD BUFFER CONTROL WORD
	DCA	INIT1	/SAVE FOR INITIO
	TAD	T1
	DCA	AS	/SAVE PTR TO BUFFER INFO
	ISZ	T1
	TAD I	T1
	DCA	INIT2	/GET BUFFER ADDRESS FOR INITIO
	TAD	(LABEL-1
	DCA	SYSERR
	TAD	INITIO
	DCA	T1	/SET UP FOR "INIT" CALL
	TAD I	T
	RAL
	SZL SPA CLA	/IS IT AN "INIT(N,SYS)"?
	JMP	NOISYS	/NO
	TAD	(ERROR	/YES - SET UP FOR "SYSINIT" CALL
	DCA	SYSERR
	TAD	(SYSINI
	DCA	T1
	ISZ I	T	/BUMP DESCRIPTOR FROM 1777 TO 2000 (READ)
NOISYS,	TAD	T2
	AND	P7	/GET THE INTERNAL FILE NUMBER OF THIS FILE
	TAD I	T
	DCA	T2
	DCA I	T	/IN CASE HE HAS AN "ON ERROR" LABEL
	TAD	T2
	AND	P7	/GET THE IFN INTO THE AC
	JMS I	T1	/INITIALIZE THE FILE (T1="INIT" OR "SYSINIT")
INIT1,	0		/I/O CONTROL WORD
INIT2,	0		/BUFFER ADDRESS
SYSERR,	0		/FILE LABEL OR SYSINIT ERROR RETURN
	TAD	T2
	DCA I	T
	AC4000
	TAD I	AS
	DCA I	AS	/SET "BUFFER IN USE" BIT ON
	JMP I	[ILOOP
LABEL,	ZBLOCK	3	/FILE LABEL ARRAY
ERRTRP,	TAD	T
	TAD	(7000
ONERXX,	DCA	USRERR	/CHANGE FROM A 6000 TO A 5000
	TAD	PDL
	DCA	OLDPDL
	JMP I	[ILOOP
	PAGE

/XMIT - DO SEQUENTIAL MODE I/O
XMIT,	TAD	[DES2-1
	POPDES		/GET THE BLOCK DESCRIPTOR
	DCA	DOCDF	/STORE THE CDF TO THE BLOCK FIELD
	JMS	IOCOMN	/GET THE FILE NUMBER TABLE ENTRY
	SNA		/HAS IT BEEN INITIALIZED?
XMIERR,	FATAL		/NO - ERROR
	CLL
	TAD	(2000
	SMA SNL CLA		/IS IT MASS STORAGE?
	CLA IAC			/NO - USE CDOIO
	TAD	(JMS I RDOIO	/YES - USE RDOIO
	DCA	DOIO
	TAD	DES2L
	CLL CML RAR	/TURN THE BLOCK LENGTH INTO A WORD COUNT
	IAC
	DCA	LENGTH	/STORE IT AS THE MAXIMUM I/O LENGTH
	TAD	LENGTH
	CIA
	TAD	DES2W
	DCA	DES1W	/SAVE A POINTER TO THE LAST WORD IN THE BLOCK
	TAD	LENGTH
DOCDF,	HLT
	DCA I	DES2W	/STORE THE BLOCK LENGTH IN THE BLOCK HEADER
	TAD I	DES1W
	AND	[7700	/DUE TO A KLUDGE, WE MUST ZERO OUT THE LAST
	SZL		/CHARACTER OF ANY BLOCK WITH AN ODD
	DCA I	DES1W	/LENGTH IN CHARACTERS
	CDF 0			/BEGINNING OF THE BLOCK
	STA		/CAUTION - AC MAY NOT BE ZERO HERE
	TAD	DES2W
	DCA	DOIOBF	/GET THE BLOCK ADDRESS -1 FOR DOIO
	TAD I	T
	AND	P7	/GET THE IFN (RDOIO) OR DEVICE NUMBER (CDOIO)
	TAD	DOCDF
	TAD	[-CDF	/ADD IN THE FIELD OF THE BLOCK IN BITS 6-8
DOIO,	HLT		/EITHER "JMS I RDOIO" OR "JMS I CDOIO"
DOIOBF,	0
	JMP	XMIEOF	/END-OF-FILE - CLOSE FILE AND TAKE EOF RETURN
	JMS I	[FETPC
	CLA		/SKIP THE END OF FILE RETURN NORMALLY
	TAD	DOCDF
	DCA	BLCDF	/NOW WE HAVE TO GO AND INSERT TRAILING BLANKS IF
BLCDF,	HLT		/THE RECORD WAS SHORT
	TAD I	DES2W	/CHECK NEW LENGTH AGAINST SPECIFIED LENGTH
	CMA
	TAD	LENGTH
	DCA	LENGTH
	TAD I	DES2W
	CIA
	TAD	DES2W	/COMPUTE THE LAST WORD
	DCA	DES1W	/READ INTO
	TAD I	DES1W
	SNA		/SPECIAL CHECK FOR ENTIRELY NULL LINE
	JMP	BLNKLP+1	/BLANK IT OUT ENTIRELY
	AND	P77	/IF THE LAST CHARACTER IS NULL,
	SNA CLA
	ISZ I	DES1W	/CONVERT IT TO A BLANK
	JMP	BLNKSZ
BLNKLP,	ISZ	DES1W	/FILL IN THE REST OF THE RECORD WITH BLANKS
	TAD	(101
	DCA I	DES1W
BLNKSZ,	ISZ	LENGTH
	JMP	BLNKLP
	ISZ	LENGTH	/FOR SAFETY
	CDF 0
	JMP I	[ILOOP
XMIEOF,	TAD	DOCDF
	DCA	.+1
	HLT		/SET UP DATA FIELD OF BLOCK
	TAD I	DES2W	/BLOCK HEADER WILL TELL WHAT HAPPENED
	SPA CLA		/IF ITS NEGATIVE,
LTLERR,	ERROR		/IT MEANS THAT THE RECORD WAS TOO LONG TO FIT
			/OTHERWISE IT WAS AN END-OF-FILE
	CDF 0
	TAD I	T	/JUMP INTO THE "FINI" PROCESSOR
	JMP	FINI1	/WHICH WILL THEN GO TO THE EOF RETURN

/FINI - TERMINATE I/O OPERATIONS ON A FILE
FINI,	JMS	IOCOMN	/GET THE FILE NUMBER TABLE ENTRY
FINI1,	RAL
	SNL SMA CLA	/IS IT A MASS STORAGE FILE?
	JMP	DONTFN	/NO - SKIP A LOT OF STUFF
	AC2000		/PREPARE TO CHECK FOR UPDATE FILE
FREEBF,	TAD I	T
	AND	P7	/GET THE INTERNAL FILE NUMBER (IFN)
	SZL
	JMP	FINUPD	/SPECIAL CHECK NEEDED FOR UPDATE FILES
	JMS I	FINIO	/TERMINATE BUFFERS AND REWIND TAPES, IF NECESSARY
	TAD I	T
	AND	P7	/GET THE IFN AGAIN
	CLL RAL
	TAD	(BARRAY-2
	DCA	T1	/FORM A POINTER INTO THE BUFFER TABLE
	AC3777
	AND I	T1
	DCA I	T1	/MARK THE BUFFER FREE
DONTFN,	DCA I	T	/MARK THIS FILE NUMBER UNINITIALIZED
	JMP I	[ILOOP
IOCOMN,	0		/ROUTINE TO GET THE FILE NUMBER TABLE ENTRY
	DBCONV		/CONVERT THE TOP OF STACK NUMBER TO BINARY
	AND	P17	/FORCE IT LEGAL
	TAD	(FARRAY	/ADD THE BASE OF THE TABLE
	DCA	T	/TO FORM A POINTER
	TAD I	T	/LOAD THE ENTRY INTO THE AC
	JMP I	IOCOMN	/RETURN
LGETCH,	0		/GET CHARACTER FOR LABEL ROUTINE
	ISZ	DES1L
	TAD	DES1L
	SMA SZA CLA	/RUN OUT OF CHARACTERS?
	IAC		/YES - USE BLANKS
	SNA
	GETCH1		/NO - USE CHAR
	JMP I	LGETCH
SETTRP,	JMS I	[FETPC
	DCA	TRPINS	/SAVE TRAP INST
	JMP I	[ILOOP
FINUPD,	JMS I	KPTRST	/SET UP FILE POINTERS
	JMS I	(WRMAYB	/DO FINAL WRITE, IF NECESSARY
	CLL
	JMP	FREEBF	/NOW DO THE FINI (A NOP FOR UPDATE FILES!)
HERET,	CLA		/TRACE - "CLA IAC" IF /T ON
HERENT,	DCA	TRCFLG	/TURN OFF TRACE
	JMP I	[ILOOP	/SR
	PAGE

/RANDOM DIBOL OPERATIONS
STOP=7600
HEREDC,	JMS I	[FETPC	/HERE WE ARE
	JMP	DCALIN
LININC,	TAD	T	/SHORT FORM OF "HEREDC" - USED IF DIFFERENCE
	CIA
	TAD	LINENO	/BETWEEN THIS LINE NUMBER AND PREVIOUS ONE
DCALIN,	7421		/MQL
	7501		/MQA
	DCA	LINENO	/IS LESS THAN 512
	TAD	PDL
	DCA	OLDPDL	/FOR DDT
	TAD I	BP
DDTSW,	JMP	.+4	/** CHANGED TO CDF CIF DDTFLD IF DDT PRESENT
	TAD	LINENO
	SNA CLA		/BREAKPOINT?
	JMP I	(6401	/YOU BETCHUM!
	CDF CIF 0
	TAD	(PUTJMP
	DCA	TRCJMP
	TAD	TRCFLG
	SNA CLA		/IF TRACE IS ENABLED,
	JMP I	[ILOOP
	JMP I	(ATLINE	/PRINT "AT LINE XXXX" ON LPT

FORMS,	DBCONV		/GET SECOND ARGUMENT
	CIA
	DCA	DOADD	/SAVE IT
	TAD	BS
	AND	[40
	DCA	AS	/SAVE SIGN OF NUMBER
	JMS I	(IOCOMN	/GET FILE NUMBER TABLE ENTRY
	TAD	(-105
	SZA CLA		/IS THE DEVICE THE LINE PRINTER?
	JMP I	[ILOOP	/NO - FORMS CONTROL MEANINGLESS
	TAD	AS
	SZA CLA
	JMP	CNTRNX	/NEGATIVE MEANS SPECIAL FORMS CONTROL
	TAD	DOADD
	SNA CLA		/A ZERO ARGUMENT MEANS A FORM FEED IS NEEDED
	JMP	FFOUT	/OTHERWISE MULTIPLE LINE FEEDS ARE DESIRED
MULTLF,	TAD	(212
	JMS I	LPOUT
	ISZ	DOADD
	JMP	MULTLF
	JMP I	[ILOOP
CNTRNX,	TAD	DOADD
	CLL CMA RTL	/MAGIC TRANSFORMATION
	TAD	DOADD
FFOUT,	TAD	(214
	JMS I	LPOUT	/OUTPUT A FORM FEED
	JMP I	[ILOOP
DOADD,	0		/COMMON ROUTINE FOR ADD, SUBTRACT, AND COMPARE
	DCA	BS	/SAVE SIGN DIDDLE
	POPNUM		/GET ADDEND (OR SUBTRAHEND) FROM STACK
	TAD	AS
	TAD	BS
	DCA	AS	/DIDDLE ITS SIGN
	TAD	T
	DCA	QDIGIT	/SAVE THE NUMBER OF DIGITS
	AC0002
	POPNUM		/GET THE OTHER NUMBER
	TAD	T
	CIA
	TAD	QDIGIT	/FIND THE LARGER OF THE TWO LENGTHS
	SPA
	CLA
	TAD	T
	TAD	NUMLEN	/AND TRANSFORM IT INTO A DIGIT IGNORE COUNT
	CMA
	JMS I	(ADDAB	/WHICH WE USE TO SHORTEN THE ADD TIME
	JMP I	DOADD	/RETURN

		/PUSH A SUBSTRING DESCRIPTOR ONTO THE STACK
PUSH2S,	DBCONV		/GET THE UPPER CHARACTER NUMBER
	DCA	DOADD
	DBCONV		/GET THE LOWER CHARACTER NUMBER
	DCA	T
	TAD	T
	CIA
	CLL
	TAD	DOADD	/MAKE SURE THE LOWER LIMIT IS NOT ZERO
	SNL		/OR GREATER THAN THE UPPER LIMIT
P2ERR,	FATAL
	CLL RTL
	SZL SPA		/CHECK FOR LENGTH > 512
	JMP	P2ERR	/YES - ERROR
	RAL
	TAD	[10	/BUMP DIFFERENCE BY 1 TO GET REAL LENGTH
	DCA	T1
	TAD	IST1
	AND	P7
	TAD	T1
	DCA	IST1	/FORM A NEW DESCRIPTOR
	STA CLL CML	/AND AN ADDRESS EQUAL TO THE ADDRESS
	JMP I	(BUMPID	/OF THE ITEM OFFSET BY THE LOWER LIMIT (-1)
FAKNUM,	0	/ROUTINE TO FAKE A 2 DIGIT NUMBER ON THE PUSHDOWN LIST
	JMS I	OTOPD
	PUSH		/PUT ON PUSHDOWN LIST
	TAD	[20
	PUSH		/PUSH A PHONY DESCRIPTOR
	AC7776
	TAD	PDL
	CLL RAL
	PUSH		/POINTING TO THE 2 DIGIT RESULT
	JMP I	FAKNUM

ROUND,	DBCONV		/ROUND A NUMBER N DECIMAL PLACES
	AND	P7	/CRUDE LIMIT ON N
	CMA
	DCA	T
	DCA I	B	/PROTECTION IF N=0
	JMP	.+3
	DCA I	A	/MOVE ACCUMULATOR A RIGHT N PLACES
	ISZ	A	/ZEROING THE HIGH ORDER DIGITS
	ISZ	T
	JMP	.-3
	POPNUM		/LOAD THE ROUNDEE INTO THE STRANGE AC
	TAD	(ACA
	DCA	A	/RESTORE SANITY
	TAD I	B	/GET THE FIRST OVERFLOW DIGIT
	JMP I	(RNDADD	/CONTINUED ON ANOTHER PAGE
	PAGE

/RANDOM ACCESS I/O
WRITE,	CLA IAC		/RANDOM ACCESS WRITE
READ,	STL RTR		/RANDOM ACCESS READ
	DCA	RAT1	/SAVE READ/WRITE FLAG IN SIGN
	POPDS1		/GET RECORD NUMBER
	TAD	[DES2-1
	POPDES
	DCA I	(RACDF	/GET BLOCK DESCRIPTOR
	TAD	DES2L
	CLL CMA RAR
	IAC		/GET RECORD LENGTH IN WORDS
	DCA	BLKSIZ	/STORE THAT, TOO
	DCA	IST1	/WE MUST NOW MULTIPLY THE RECORD SIZE BY THE
	DCA	IST2	/RECORD NUMBER TO OBTAIN A WORD ADDRESS
	AC7776
	AND	DES2L
	DCA	DES2L	/FORCE LENGTH EVEN
	JMP	MDIGIT
MSHFT,	TAD	IST1
	DCA	T1
	TAD	IST2
	DCA	T2	/WE HAVE TO MULTIPLY (IST1,IST2) BY 10
	JMS	RLEFT
	JMS	RLEFT
	TAD	IST2
	CLL
	TAD	T2
	DCA	IST2
	RAL
	TAD	IST1
	TAD	T1
	DCA	IST1
	JMS	RLEFT	/DONE
MDIGIT,	GETCH1		/GET A DIGIT OF THE MULTIPLIER
	TAD	(-20
	CIA
	DCA	QDIGIT	/TURN IT INTO A COUNT (0=-1,1=-2,ETC.)
	JMP	ISZCNT
MADDLP,	CLL		/WE HAVE TO ADD IN THE RECORD SIZE
	TAD	IST2	/TO THE PRODUCT AS MANY TIMES
	TAD	BLKSIZ	/AS THE VALUE OF THE MULTILIER DIGIT
	DCA	IST2
	SZL
	ISZ	IST1	/IN DOUBLE PRECISION, OF COURSE
ISZCNT,	ISZ	QDIGIT
	JMP	MADDLP
	ISZ	DES1L	/ITERATE FOR THE NUMBER OF DIGITS IN THE MULTIPLIER
	JMP	MSHFT

	JMS I	(IOCOMN	/GET UNIT NUMBER AND UNIT CONTROL WORD
	CMA
	AND	RAT1	/UNIT MUST BE OF TYPE "UPDATE" FOR WRITE
	SZA CLA		/AND OF TYPE "INPUT" OR "UPDATE" FOR READ
RAERR,	FATAL		/WRONG TYPE OF UNIT
	TAD I	T	/GET EDP-8 UNIT NUMBER
	AND	P7
	JMS I	KPTRST	/SET UP POINTERS TO FCB ENTRY
	TAD I	W0	/GET BUFFER CONTROL WORD
	CLL RAL
	AND	P7400
	DCA	BUFSIZ	/STORE BUFFER SIZE
	TAD	BLKSIZ
	CIA CLL		/SUBTRACT ONE FROM THE RECORD NUMBER
	TAD	IST2	/AFTER THE MULTIPLICATION, UNFORTUNATELY
	DCA	IST2
	SNL
	STA
	TAD	IST1
	DCA	IST1	/WATCH THOSE CARRIES!
	CLL		/ADD 400 TO THE PRODUCT TO BUMP THE WORD ADDRESS
	TAD	(400	/BY THE LENGTH OF THE DEVICE LABEL RECORD
	TAD	IST2
	DCA	RELBLO	/THIS PRODUCT NOW HAS TO BE BROKEN UP
	RAL
	TAD	IST1	/INTO AN INTEGRAL MULTIPLE OF THE I/O BUFFER
	DCA	RELBHI	/SIZE AND A REMAINDER.
	TAD	(-15	/TO ACCOMPLISH THIS WE DO A PSEUDO-DIVIDE
	DCA	QDIGIT	/BY THE BUFFER SIZE (ALL WE NEED IS THE REMAINDER
	SKP
DIVLP,	JMS	RLEFT	/SHIFT (IST1,IST2) LEFT 1
	TAD	BUFSIZ
	CIA CLL
	TAD	IST1
	SZL		/IF BUFSIZ .LT. IST1, IST1=IST1-BUFSIZ
	DCA	IST1
	SZL CLA		/IF SUBTRACT SUCCEEDED KEEP TRYING
	JMP	DIVLP+1	/THIS HANDLES CASE OF IST1>2*BUFSIZ
	ISZ	QDIGIT
	JMP	DIVLP	/ITERATE UNTIL IST2 IS TOTALLY SHIFTED IN

	TAD	IST1	/NOW SUBTRACT THE REMAINDER FROM THE WORD ADDRESS
			/TO LEAVE AN INTEGRAL MULTIPLE OF BUFSIZ
	CIA CLL
	TAD	RELBLO
	DCA	RELBLO
	SNL
	STA		/DECREMENT HIGH ORDER ON OVERFLOW (UNDERFLOW?)
	TAD	RELBHI
	DCA	RELBHI
	CLL
	TAD	RELBHI
	TAD I	U2	/COMPARE HIGH-ORDER ADDRESS AGAINST DEVICE LENGTH
	SZL CLA
	JMP I	(RECERR	/RECORD NUMBER WAY TOO LARGE
	TAD I	W0	/CHECK IF THE DESIRED BLOCK IS IN CORE -
	SMA CLA		/THE FCB BLOCK NUMBER POINTS TO THE
	TAD	BUFSIZ	/DEVICE ADDRESS OF THE NEXT BUFFER LOAD IF THE
	TAD	RELBLO	/FILE IS IN READ MODE, AND THE CURRENT
	CIA		/DEVICE ADDRESS IF THE FILE IS IN WRITE MODE.
	TAD I	W5
	AND	P7400
	JMP I	(RAGETB	/CONTINUED ON NEXT PAGE
RLEFT,	0		/SHIFT (IST1,IST2) LEFT 1
	TAD	IST2
	CLL RAL
	DCA	IST2
	TAD	IST1
	RAL
	DCA	IST1
	JMP I	RLEFT
	PAGE

/RANDOM ACCESS I/O - PAGE 2
RAGETB,	SZA CLA
	JMP	RDBLKX	/LOW-ORDERS DON'T MATCH - FORGET IT
	CML RAL		/THE LINK IS ZERO HERE ONLY IF THE SUM
	TAD	RELBHI	/(BUFSIZ+RELBLO) OVERFLOWED, IN WHICH CASE
	CIA		/THERE IS A CARRY ON THE SUBTRACT
	TAD I	W4	/COMPARE HIGH ORDERS
	SNA CLA
	JMP	DONTRD	/THE SAME
RDBLKX,	JMS	WRMAYB	/NOT THE SAME - DO OLD WRITE, IF PENDING
	TAD I	W5
	AND	[377
	TAD	RELBLO
	DCA I	W5	/SET UP THE BLOCK NUMBER IN THE FILE CONTROL BLOCK
	TAD	RELBHI
	DCA I	W4
	JMS I	KGPBUF	/DO THE I/O AND BUMP THE BLOCK NUMBER

DONTRD,	TAD	BUFSIZ
	CIA STL
	TAD	IST1	/COMPUTE # OF WORDS LEFT IN BUFFER
	TAD	BLKSIZ	/SEE IF THIS OPERATION WILL OVERFLOW
	CLA		/LINK TELLS THE TALE
	TAD	RAT1	/IF THE OPERATION IS A READ
	SNL SMA CLA	/AND WILL OVERFLOW,
	JMS	WRMAYB	/CONSIDER DUMPING THE CURRENT BUFFER FIRST
	TAD I	W1
	AND	P7600
	TAD	IST1
	TAD	M1	/COMPUTE THE BUFFER POINTER FROM THE REMAINDER
	DCA I	W2	/OF THE DIVISION
	TAD	BUFSIZ
	CIA
	TAD	IST1	/LIKEWISE COMPUTE THE NUMBER OF WORDS LEFT
	DCA I	W3	/IN THE BUFFER
	TAD	RAT1	/GET THE READ/WRITE FLAG
	SPA CLA		/WHAT IS IT?
	JMP	RAOUTP	/WRITE
	STA		/RANDOM ACCESS INPUT - USE RDOIO
	TAD	DES2W
	DCA	RAIOBF
	TAD I	W0
	DCA	RAT1	/SAVE "WRITE PENDING" FLAG
	JMS	SETW0	/AND FORCE READ
	TAD	BLKSIZ
	CIA
	IAC		/WE DON'T DO EXACT LENGTH CHECKING ON READS,
	DCA	LENGTH	/BUT WE DO CHECK FOR INPUT RECORD TOO BIG
	TAD I	T
	AND	P7	/GET EDP-8 FILE NUMBER
	TAD	RACDF
	TAD	[-CDF	/ADD IN BLOCK FIELD BITS
	JMS I	RDOIO
RAIOBF,	0
	JMP	IRCERR	/EOF OR BUFFER TOO LONG - WHO CARES?
	TAD	RAT1
	DCA I	W0	/RESTORE "WRITE PENDING" FLAG IN W0 BIT 0
	JMP I	[ILOOP

/RANDOM ACCESS WRITE NITTY GRITTY
RAOUTP,	TAD I	W0
	AND	P70	/WE HAVE TO DO THIS ONE OURSELVES
	TAD	PCDF	/GET A CDF INTO THE BUFFER FIELD
	DCA	RAPCDF
	TAD	DES2W
	DCA	XR1	/WE WON'T TRANSMIT THE BLOCK COUNT WORD
	TAD I	W2
	DCA	XR2	/GET POINTER INTO BUFFER
	TAD	RAPCDF
	DCA	.+1
	HLT		/CDF BUFFER FIELD
	STA
	TAD I	XR2
	TAD	BLKSIZ	/MAKE SURE WE'RE OVERWRITING A RECORD
	SZA CLA		/OF THE CORRECT LENGTH
RECERR,	ERROR	/NO - BAD
	CDF 0
	JMP	RABUMP	/BUMP COUNTERS SINCE WE'RE SKIPPING A WORD
RACDF,	HLT		/CDF TO BLOCK FIELD
	TAD I	XR1	/GET A WORD
RAPCDF,	HLT		/CDF TO BUFFER FIELD
	DCA I	XR2	/STORE A WORD
	CDF 0		/CDF TO THIS FIELD
RABUMP,	ISZ I	W3	/BUMP THE BUFFER WORD COUNT
	JMP	RAWRLP	/NO SWEAT - KEEP GOING
	JMS	SETWR	/SET FILE TO WRITE & DIDDLE BLOCK NUMBER
	JMS	WRMAYB	/NO MAYBE ABOUT IT - WRITE!
	JMS I	KGPBUF	/AND READ THE NEXT BUFFER
	TAD I	W2
	DCA	XR2	/INITIALIZE XR2 TO START OF NEW BUFFER
RAWRLP,	ISZ	DES2L	/BUMP CHARACTER COUNT
	ISZ	DES2L	/BUMP IT TWICE - ITS EVEN
	JMP	RACDF
	TAD	XR2
	DCA I	W2	/UPDATE THE BUFFER POINTER (FOR NO GOOD REASON)
	JMS	SETWR	/SET THE FILE TO AN OUTPUT FILE
			/THIS SERVES AS A FLAG THAT A WRITE IS PENDING
	JMP I	[ILOOP	/THE WRITE WILL BE DONE ONLY WHEN WE HAVE TO

/RANDOM ACCESS SUBROUTINES
SETW0,	0
	DCA	T2	/SAVE R/W BIT
	AC3777
	AND I	W0
	TAD	T2
	DCA I	W0	/SAVE W0 BACK WITH PROPER R/W BIT
	JMP I	SETW0
RAT1=	AS
WRMAYB,	0
	TAD I	W0
	SPA CLA		/IF WRITE PENDING,
	JMS I	KGPBUF	/OUTPUT BUFFER LOAD
	JMS	SETW0	/CLEAR THE OUTPUT FLAG
	JMP I	WRMAYB
SETWR,	0
	TAD I	W0
	CLL RAL		/R/W BIT INTO THE LINK
	AND	P7400	/GET BLOCK COUNT IN AC0-3
	CIA		/THIS LEAVES LINK ALONE!
	SZL		/CHECK FOR WRITE BIT
	JMP	FGETIT	/DON'T WORRY - IT'S IN WRITE MODE ALREADY
	TAD I	W5
	DCA I	W5	/DECREASE THE BLOCK NUMBER BY THE
	SNL		/BUFFER LENGTH
	STA
	TAD I	W4	/TO REFLECT THE CURRENT BUFFER ADDRESS
	DCA I	W4	/INSTEAD OF THE NEXT BUFFER ADDRESS ON THE DEVICE
FGETIT,	AC4000
	JMS	SETW0	/FORCE FILE TO WRITE MODE
	JMP I	SETWR
IRCERR,	TAD	RAT1
	DCA I	W0
	JMP	RECERR
/
	PAGE

/INITIAL WRITE - OUT ROUTINE
RSYSWR,	TAD	(RSINIT
	DCA I	(201	/CHANGE STARTING ADDRESS
	CDF 10
	TAD	PTF0
	DCA I	(TF0
	CDF 0
	TAD	IZERO
	DCA	TIFN	/POINTER TO SPECIAL CELL IN "INITIO"
	TAD	TICHR
	DCA I	(KTICHR
	TAD	LPDNFG
	DCA I	(LPDNF1
	TAD	LPDNFG
	DCA I	(LPDNF2
RSYSXX,	TAD	(RSYS&17^400
	JMS I	SYS
	5400
	1400
	RSYS%20		/WRITE OVERLAY
	TAD	(EROVLY&17^400
	JMS I	SYS
	4210
	4400
	EROVLY%20
	TAD	(RSLDR&17^400
	JMS I	SYS
	4600
	0
	RSLDR%20
	TAD	(RSLDR-1&17^400
	JMS I	SYS
	4210
	RSYSCB
	RSLDR-1%20
	IOF
	JMP I	P7600
/
	PAGE

	FIELD 1
*4000
RSYSCB,	-1
	CDF CIF 0
	200		/STARTING ADDRESS
	0
	0
	600		/1400 WORDS STARTING AT 00000
/PART OF THE RSYS LOADER IS RIGHT HERE IN THE CCB!!!
RDSYMT,	0
	DCA	STPTR	/FOR THE LINE LENGTH
	TAD	STPTR
	CMA CLL
	TAD	T1	/SEE IF THE SYMBOL TABLE PLUS PROGRAM
	CLA RTL		/WILL FIT IN AVAILABLE MEMORY.
	RTL
	TAD I	(PRGCDF
	CIA
	TAD I	(TOPFLD	/THIS TEST IS MADE FOR THE REGULAR
	SPA CLA		/AND DDT SYMBOL TABLE (IF ONE EXISTS)
	JMP I	(PGOERR
	TAD	STPTR
	DCA	QDIGIT	/STORE LOWEST S.T. ADDR FOR BUFFER ALLOCATOR
	TAD I	(TOPFLD
	AND	P77
	JMS I	RDOIO	/READ IN THE SYMBOL TABLE INTO THE
STPTR,	0		/UPPERMOST PART OF THE UPPERMOST FIELD
	JMP I	(EOFERR	/END OF FILE ON SYMBOL TABLE - BAD!
	JMP I	RDSYMT
SYMHDR,	TAD I	XR	/GET THE LENGTH OF THE SYMBOL TABLE IN ENTRIES
	CMA CLL RAL	/DOUBLE IT, NEGATE IT AND LEAVE A WORD
	TAD	DDTLOC
	JMS	RDSYMT
	STA
	TAD	STPTR
	DCA	SYMTAB
	TAD I	(PRGCDF
	AND	P70
	DCA	T	/SAVE FIRST FIELD TO CONSIDER BUFFERS IN
	TAD	(FARRAY-1
	DCA	T2
	TAD	DDTLOC
	SNA CLA
	JMP I	(RDRSYS	/NO DDT - NO SWEAT
	TAD I	(LDBUF+3
	CLL RAL
	TAD I	(LDBUF+3
	CMA		/DDT SYMBOL TABLE 3 WORDS PER ENTRY
	TAD	STPTR
	JMS	RDSYMT	/READ DDT SYMTAB BELOW DIBOL SYMTAB
	TAD I	(TOPFLD
	DCA	.+1
	HLT		/CDF DDTFLD
	TAD	STPTR
	DCA I	M1	/STASH DDT SYMBOL TABLE POINTER AWAY
	CDF 0
	JMP I	(RDRSYS	/GO LOAD RSYS & SET UP BUFFERS

/LOADER INITIALIZATION CODE FOR DDT
CHKDDT,	DCA I	BP	/CLEAR BREAKPOINT LOCATION INITIALLY
	TAD	(DDTSW&177+5204	/JMP DDTSW+4
	DCA	DDTTRP	/INITIALIZE TO NO DDT
	TAD I	(OPTCHR
	AND	(7700
	TAD	P7400	/"D"?
	SZA CLA
	JMP I	(RLBUFR	/NO - HO,HUM
	TAD	D6400
	DCA	DDTLOC	/ALLOW ROOM FOR DDT IN HIGHEST FIELD
	AC0002
	TAD I	(TOPFLD
	DCA	DDTTRP	/SET DDTSW TO "CDF CIF DDTFLD"
	TAD	CHNFLG
	SZA CLA		/CHAINING?
	JMP I	(RLBUFR	/YES - DDT IS RESIDENT
	TAD I	(TOPFLD
	AND	P70
	TAD	(600	/CONSTRUCT I/O CTL WD TO READ DDT
	DCA	DDTIOW
	TAD	(DDTBLK&17^400
	JMS I	SYS
DDTIOW,	0
D6400,	6400
	DDTBLK%20
	TAD I	(TOPFLD
	DCA	.+1
	HLT
	TAD I	M1	/GET DDT VERSION #
	CDF 0
	TAD I	(VERSON
	SNA CLA
	JMP I	(RLBUFR	/DEBUGGER IS IN - NOW GET DEBUGGEE
	JMP I	(EOFERR

OPTSET,	TAD	(LDBUF+10
	DCA	XR1
	STA
	DCA I	XR1	/FAKE WORD COUNT
	TAD I	(OPTCHR
	AND	P77
	SZA
	TAD	(40	/CONVERT STRIPPED SIXBIT
	IAC		/TO -237 SIXBIT
	AND	P77	/WITH SPECIAL HACK FOR BLANK
	DCA	T
	TAD I	(OPTCHR
	AND	(7700
	SZA
	TAD	(4000
	TAD	(100
	TAD	T
	JMP I	(OPTDAT
	PAGE

	*4400
ERRLP,	TAD I	PERLST
	ISZ	PERLST
	TAD I	PFATAL	/FIND OUT WHERE WE WERE CALLED FROM
	SNA CLA
	JMP	ERRFND
	ISZ	PERLST
	JMP	ERRLP
ERRFND,	TAD I	PERLST	/GET POINTER TO ERROR MESSAGE
	DCA	ERMESG
	DCA I	CTRLO	/FORCE TELETYPE ON
	DCA I	TF0	/FORCE BATCH FLAG OFF
ERRIAC,	IAC
	JMS I	CDOIO	/PUT THE MESSAGE OUT ON THE TTY
ERMESG,	0
	NOP
	TAD I	BP	/BREAKPOINT PENDING?
	SZA CLA
	TAD	PDC1	/YES - GO TO DDT AFTER PRINTING
	TAD	P7600
	DCA I	PATRTN
	TAD	ERRIAC
	DCA I	PATLDV	/CHANGE DEVICE FROM LPT TO TTY
	JMP I	PATLN
PERLST,	ERRLST
TF0,	0		/SET UP AT LOAD TIME
PFATAL,	FATALX
PATLN,	ATLINE
PATRTN,	ATRETN
PATLDV,	ATLNDV
PDC1,	.+1-7600
	AC0002
	TAD I	PTOPF
	DCA	.+1
	HLT		/CDF CIF DDTFLD
	JMP I	.+1
	6402		/SPECIAL ENTRY FOR ERRORS
PTOPF,	TOPFLD

/ERROR MESSAGE LIST
ERRLST,	-EOFERR-1
	+EOFMSG-1
	-PGOERR-1
	+PGOMSG-1
	-PDLERR-1
	+PDLMSG-1
	-RETERR-1
	+RETMSG-1
	-P2ERR-1
	+P2MSG-1
	-D0ERR-1
	+D0MSG-1
	-A2DERR-1
	+A2DMSG-1
	-INIERR-1
	+INIMSG-1
	-BUFERR-1
	+BUFMSG-1
	-XMIERR-1
	+XMIMSG-1
	-NUMERR-1
	+NUMMSG-1
	-BR0ERR-1
	+BR0MSG-1
	-SSERR-1
	+SSMSG-1
	-LTLERR-1
	+LTLMSG-1
	-RAERR-1
	+RAMSG-1
	-RECERR-1
	+RECMSG-1
	-SYSERR-1
	+SYSMSG-1
	-CHNERR-1
	+CHNMSG-1

/ERROR MESSAGES IN PACKED -237 ASCII
/PRECEDED BY THE LENGTH OF THE MESSAGE
EOFMSG,	-6		/BAD PROGRAM
	4342;4501;6163
	6050;6342;5600
PDLMSG,	-11		/PUSHDOWN OVERFLOW
	6166;6451;4560
	7057;0160;6746
	6347;5560;7000
PGOMSG,	-10		/PROGRAM TOO BIG
	6163;6050;6342
	5601;6560;6001
	4352;5000
RETMSG,	-12		/RETURN WITHOUT CALL
	6346;6566;6357
	0170;5265;5160
	6665;0144;4255
	5500
D0MSG,	-6		/ZERO DIVISOR
	7346;6360;0145
	5267;5264;6063
SSMSG,	-11		/SUBSCRIPT TOO BIG
	6466;4364;4463
	5261;6501;6560
	6001;4352;5000
SYSMSG,	-4		/NO FILE
	5760;0147;5255
	4600
P2MSG,	-11		/ILLEGAL SUBSTRING
	5255;5546;5042
	5501;6466;4364
	6563;5257;5000
LTLMSG,	-7		/LINE TOO LONG
	5552;5746;0165
	6060;0155;6057
	5000
A2DMSG,	-5		/BAD DIGIT
	4342;4501;4552
	5052;6500
INIMSG,	-14		/DIBOL FILE NUMBER IN USE
	4552;4360;5501
	4752;5546;0157
	6656;4346;6301
	5257;0166;6446
BUFMSG,	-10		/NO BUFFERS LEFT
	5760;0143;6647
	4746;6364;0155
	4647;6500
XMIMSG,	-16		/DIBOL FILE NUMBER NOT INITED
	4552;4360;5501
	4752;5546;0157
	6656;4346;6301
	5760;6501;5257
	5265;4645
NUMMSG,	-10		/NUMBER TOO LONG
	5766;5643;4663
	0165;6060;0155
	6057;5000
BR0MSG,	-6		/END OF FILE
	4657;4501;6047
	0147;5255;4600
RAMSG,	-7	/ILLEGAL DEVICE
	5255;5546;5042
	5501;4546;6752
	4446
RECMSG,	-7	/ILLEGAL RECORD
	5255;5546;5042
	5501;6346;4460
	6345
CHNMSG,	-6		/BAD CHAIN #
	4342;4501;4451
	4252;5701;0400
	$-$-$