/ OS/8 SUPPORT TASK FOR RTS-8
/
/
/
/
/
/
/
/
/
/COPYRIGHT  (C)  1974 BY DIGITAL EQUIPMENT CORPORATION
/
/
/
/
/
/
/
/
/
/
/THE INFORMATION IN THIS DOCUMENT IS SUBJECT TO CHANGE WITHOUT NOTICE
/AND SHOULD NOT BE CONSTRUED AS A COMMITMENT BY DIGITAL EQUIPMENT
/CORPORATION.  DIGITAL EQUIPMENT CORPORATION ASSUMES NO RESPONSIBILITY
/FOR ANY ERRORS THAT MAY APPEAR IN THIS DOCUMENT.
/
/THE SOFTWARE DESCRIBED IN THIS DOCUMENT IS FURNISHED TO THE PURCHASER
/UNDER A LICENSE FOR USE ON A SINGLE COMPUTER SYSTEM AND CAN BE COPIED
/(WITH INCLUSION OF DIGITAL'S COPYRIGHT NOTICE) ONLY FOR USE IN SUCH
/SYSTEM, EXCEPT AS MAY OTHERWISE BE PROVIDED IN WRITING BY DIGITAL.
/
/DIGITAL EQUIPMENT CORPORATION ASSUMES NO RESPONSIBILITY FOR THE USE
/OR RELIABILITY OF ITS SOFTWARE ON EQUIPMENT THAT IS NOT SUPPLIED BY
/DIGITAL.
/
/
/
/
/
/
/
/
/
/
	XLIST	1
	IFDEF	OS8	<XLIST 0>
	IFDEF	OS8	<

TASK=	OS8
CUR=	0		/MUST LOAD INTO FIELD 0
INIWT=	0

OS8F0=	HGHFLD
OS8F1=	HGHFLD-10
OS8F2=2%OSFLDS^OSFLDS-2^10+HGHFLD
OS8F3=3%OSFLDS^OSFLDS-3^10+HGHFLD
OS8F4=4%OSFLDS^OSFLDS-4^10+HGHFLD
OS8F5=5%OSFLDS^OSFLDS-5^10+HGHFLD
OS8F6=6%OSFLDS^OSFLDS-6^10+HGHFLD
OS8F7=7%OSFLDS^OSFLDS-7^10+HGHFLD

OS8DCB=	7760	/ADDRESS OF OS/8 DCB TABLE IN FIELD 1
OS8HND=	7647	/ADDRESS OF OS/8 RESIDENT HANDLER TABLE IN FIELD 1
JSBITS=	7746	/ OS/8 JOB STATUS BITS IN FIELD 0

OSKBML=	7671	/LOCATION IN FIELD 1 WHICH READS THE KEYBOARD MONITOR
OSUSRL=	7723	/LOCATION IN FIELD 1 WHICH READS IN THE USR
OSCDLD=	271	/LOCATION IN USR IN FIELD 1 WHICH READS IN CD

CINT=	6204
SUF=	6274

KSFX=	OSKBDV^10+6001
KCCX=	OSKBDV^10+6002
KRSX=	OSKBDV^10+6004
KRBX=	OSKBDV^10+6006
TSFX=	OSTTDV^10+6001
TCFX=	OSTTDV^10+6002
TSKX=	OSTTDV^10+6005
TLSX=	OSTTDV^10+6006

PSKF=	6661		/LINE PRINTER IOT'S
PSIE=	6665
PSLS=	6666
PCIE=	6667

	FIELD	CUR%10
	*166
AC,	0		/OS/8 AC
PC,	0		/OS/8 PC
LINK,	0
UCDF,	0
	HLT		/CDF TO MAPPED OS/8 DF
	JMP I	UCDF
UCIF,	0
	HLT		/CDF TO MAPPED OS/8 IF
	JMP I	UCIF
UIF,	0
/INITIALIZATION CODE - OVERWRITTEN BY RING BUFFERS

	IFDEF	OS8F	<*4600>
	IFNDEF	OS8F	<*6200>

START,	CAL
	SKPINS
	TTINT		/LINK IN OS/8 TELETYPE
	IFZERO	PDP8E	<
	CAL
	SKPINS
	KBINT
	>

OWBASE=	START
OWLEN=	20

IRBASE=	OWBASE+OWLEN
IRLEN=	10
IREND=	IRBASE+IRLEN

	CDF CIF OS8F0	/OS/8 INITIALIZATION CODE LOADS
	JMS I	OSINIT	/INTO OS/8 FAKE FIELD 0
	JMP I	.+1
	STKBMN		/GO LOAD THE OS/8 KEYBOARD MONITOR
OSINIT,	INITOS

	IFNZRO IRBASE&IRLEN	<IRBNDY,__ERROR__>
	IFNZRO	OWBASE&OWLEN	<OWBNDY,__ERROR__>
	IFNZRO	.-IREND&4000	<ZBLOCK IREND-.>

/ TSS/8 INTERRUPT HANDLER

TSINT,	DCA	AC
	RAR
	DCA	LINK
	STA
	TAD	0
	DCA	PC	/SAVE PC , AC, LINK FROM INTERRUPT
	CINT		/CLEAR USER INTERRUPT FLAG
	ION		/RESTORE INTERRUPTS
	JMS	EXECUT	/EXECUTE ONE IOT
GOBACK,	TAD	LINK	/GENERAL OS8 STARTUP
	CLL RAL
	CLA IAC
	TAD	UCIF+1
	DCA	.+2
	JMS	UCDF
OP,	HLT
	TAD	AC
	SUF
	JMP I	PC	/GO TO OS/8 IN USER MODE

PT,	0
/EXECUTE A TRAPPED IOT
/CALLED FROM TRAP ROUTINE AND FROM CIF INTERPRETER ("RECURSIVELY")

EXECUT,	0
UCIFX,	HLT		/CDF TO USERS INSTRUCTION FIELD
	TAD I	PC
	CLL RTR
	RTR
	TAD	(-1310	/CHECK FOR CDF 0 OR CDF 10
	SZA CLA		/SINCE THEY ARE THE MOST COMMON THINGS
	JMP	NCDF01
	RTL		/LINK HAS COMPLEMENT OF FIELD BIT
	RTL
	TAD	(CDF OS8F1	/** DEPENDS ON FACT THAT FIELDS
	DCA	UCDF+1		/** ARE MAPPED IN REVERSE ORDER
XNOP,	ISZ	PC
XERET,	JMP I	EXECUT	/LEAVE EXECUT WITH PC BUMPED

NCDF01,	AC2000
	TAD I	PC	/GET TRAP INSTRUCTION
	SNL		/IF ITS NOT IOT OR OPR, THE PREVIOUS
	JMP I	(ILLIOT	/INST WAS SKP HLT - ERROR
	TAD	(7000
	SNL		/TEST IOT OR OPR
	JMP	MBHALT	/OPR
	AND	(704
	TAD	(-200	/CHECK FOR CDF OR CIF (OR BOTH)
	SNA CLA
	JMP I	(DFSTUF	/YES - SPECIAL ROUTINES FOR THESE
	TAD	(IOTLST-1
	DCA	PT
	TAD I	PC
	DCA	OP	/SEARCH LEGAL OPCODE LIST
	CDF 0
SROPLP,	ISZ	PT
	TAD I	PT
	ISZ	PT
	SNA
	JMP I	(XNOP	/UNDEFINED IOT'S ARE NOP'S
	TAD	OP
	SZA CLA
	JMP	SROPLP
	TAD I	PT
	DCA	PT
	JMP I	PT	/GO PROCESS OPCODE
MBHALT,	AND	(407
	TAD	(-404	/OSR ONLY LEGAL OPR
	SZA CLA
	JMP I	(ILLIOT
	CLA OSR SKP
XRIF,	TAD	UIF
XOR,	DCA	PT	/GENERAL OR WITH AC
	TAD	AC
	CMA
	AND	PT
	TAD	AC
XACSTO,	DCA	AC
	JMP	XNOP

XRDF,	TAD	UCDF+1
	CIA
	TAD	(CDF OS8F0	/CALCULATE VIRTUAL DF FROM REAL ONE
	JMP	XOR
	PAGE
/KEYBOARD HANDLER

XKSF,	IOF
	TAD	IRCNT
	SNA CLA		/INPUT BUFFER EMPTY?
	JMP I	(XKSFWT	/YES - WAIT
	ION
XSKP,	ISZ	PC
	JMP I	(XNOP	/SKIP AND RETURN

XKRB,	TAD I	IRGET	/GET SOMETHING OUT OF THE BUFFER
XKCC,	DCA	AC	/INTO THE ACCUMULATOR
	TAD	IRCNT
	SNA CLA		/DON'T EMPTY FROM AN EMPTY BUFFER
	JMP I	(XNOP
	ISZ	IRCNT
	NOP
	TAD	IRGET
	IAC
	AND	(-IRLEN-1
	DCA	IRGET
	JMP I	(XNOP

XKRS,	TAD I	IRGET
	JMP I	(XOR	/OR CHAR INTO AC
KBINT,	IFZERO	PDP8E	<
	0;0		/LINKAGE INTO SKIP CHAIN
	KSFX
	JMP I	KBINT
	CDF CIF 0
	>
	KRBX
	DCA I	IRPUT
	TAD I	IRPUT
	AND	(177
	TAD	(-3	/IF ^C,^O,^Q OR ^S TYPED,
	SNA
	JMP	CTLCHR
	TAD	(3-17
	AND	(7771
	SZA CLA
	JMP	NOCTRC
CTLCHR,	TAD	IRPUT	/MAKE IT THE ONLY CHAR IN THE BUFFER
	DCA	IRGET
	DCA	IRCNT
NOCTRC,	TAD	IRPUT	/UPDATE PUT POINTER
	IAC
	AND	(-IRLEN-1
	DCA	IRPUT
	TAD	IRCNT
	CIA CLL
	AND	(-IRLEN-1	/BUMP CHAR COUNT MOD IRLEN
	CMA
	DCA	IRCNT
	SZL
	TAD	(KSFEF	/IF FIRST CHAR IN BUFFER SET EVENT FLAG
	POSTDS		/OTHERWISE JUST DISMISS

KSFEF,	1
IRGET,	IRBASE
IRPUT,	IRBASE
IRCNT,	0
/ILLEGAL IOT HANDLER - PRINT MESSAGE AND RETURN TO KEYBOARD MONITOR

ILLIOT,	CLA		/CLEAR AC SINCE IT IS RANDOM
	CDF 0
	TAD	(ILIOMS
	DCA	LINK
ILIOLP,	TAD I	LINK	/PRINT ERROR MESSAGE ON OS/8 TTY
	SPA		/LIST ENDS WITH 4600
	JMP	PRNTPC
	JMS I	(XTLSUB
	ISZ	LINK
	JMP	ILIOLP
PRNTPC,	TAD	UIF	/4600 IN AC HERE
	CLL RTR
	RAR
	JMS I	(XTLSUB	/PRINT FIELD
	TAD	(-4
	DCA	LINK
	TAD	PC
PCPTLP,	CLL RTL
	RAL
	DCA	UCIF
	TAD	UCIF
	RAL
	AND	(7
	TAD	(260
	JMS I	(XTLSUB	/PRINT THE PC IN OCTAL
	TAD	UCIF
	ISZ	LINK
	JMP	PCPTLP	/4 DIGITS WORTH
I7600,	7600		/CLEAR GARBAGE FROM AC
	TAD	PC
	CMA
	AND	I7600	/IF THE ILLEGAL IOT WAS IN THE RESIDENT,
	SNA CLA		/DON'T SAVE CORE ON RELOAD
	TAD	(5	/SINCE SYS: IS PROBABLY WRITE PROTECTED.

/** FALL INTO NEXT PAGE **
/START KEYBOARD MONITOR AT 07600

STKBMN,	TAD	I7600
	DCA	PC
	DCA	AC	/AND AC CLEAR
	TAD	(CDF OS8F0
	DCA	UCDF+1
HNDRET,	DCA	UIF
	TAD	UCDF+1
	DCA	UCIF+1
GOBCKX,	TAD	UCIF+1
	CDF 0
	DCA I	(UCIFX
	JMP I	(GOBACK	/START INTERPRETING
	PAGE
/TELETYPE OUTPUT HANDLER

XTSF,	CIF 0		/INHIBIT INTERRUPTS FOR A WHILE
	TAD	OWCNT
	TAD	(OWLEN
	SZA CLA		/BUFFER FULL?
	JMP I	(XSKP	/NO - SKIP RETURN
	TAD	(TSFEF
	SKP
XKSFWT,	TAD	(KSFEF
	DCA	EF
	CLA IAC
	DCA I	EF
	ION
	TAD	PC
	ISZ	PC
	AND	(177	/CHECK IF NEXT LOCATION IS A "JMP .-1" -
	TAD	(5200
	CIA
	JMS	UCIF
	TAD I	PC	/IF IT IS WE SHOULD HANG
	SZA CLA		/OTHERWISE DO A NON-SKIP RETURN
	JMP I	(XERET
	CAL
	WAITE
EF,	0
	JMP I	(XNOP	/DO A SKIP RETURN AFTER WAITING
XTCF=	XNOP		/??

XTLS,	TAD	AC
	JMS	XTLSUB	/CALL SUBROUTINE USED TO PRINT ERRORS
	IFNZRO	OSFILL	<
	TAD	AC
	AND	(177
	TAD	(-12
	SZA CLA
	JMP I	(XNOP	/ONLY FILL ON LINE FEEDS
	JMS	XTLSUB
	JMS	XTLSUB
	JMS	XTLSUB
	JMS	XTLSUB	/4 FILL CHARS SHOULD SUFFICE
	>
	JMP I	(XNOP	/KEEP ON TRUCKING
XTLSUB,	0		/ROUTINE TO OUTPUT CHAR IN AC
	DCA	UCDF	/SAVE CHAR
	TAD	OWCNT
	TAD	(OWLEN
	SNA CLA		/WAIT FOR BUFFER TO HAVE SPACE
	JMP	.-3
	TAD	UCDF
	DCA I	OWPUT
	TAD	OWPUT	/STORE CHAR IN BUFFER AND BUMP POINTER
	IAC
	AND	(-OWLEN-1
	DCA	OWPUT
	CIF 0		/DELICATE CODE AHEAD
	STA CLL
	TAD	OWCNT
	DCA	OWCNT	/BUMP BUFFER COUNT
	TAD	UCDF
	SNL
	TLSX		/PRINT IF FIRST CHAR IN BUFFER
	CLA
	JMP I	XTLSUB
/TELETYPE OUTPUT INTERRUPT ROUTINE

TTINT,	ZBLOCK	2
	IFZERO	PDP8E	<TSFX>
	IFNZRO	PDP8E	<TSKX>
	JMP I	TTINT
	CDF CIF 0
	IFNZRO	PDP8E	<
	TSFX		/KEYBOARD OR PRINTER?
	JMP I	(KBINT	/KEYBOARD
	>
	TCFX		/CLEAR PRINTER FLAG
	TAD	OWCNT
	SMA CLA		/IGNORE UNSOLICITED INTERRUPTS (LA30)
	POSTDS
	TAD	OWGET
	IAC
	AND	(-OWLEN-1
	DCA	OWGET
	ISZ	OWCNT
	SKP
	POSTDS		/BUFFER NOW EMPTY - LEAVE
	TAD I	OWGET
	TLSX		/PRINT NEXT CHAR FROM BUFFER
	STA
	TAD	OWCNT
	TAD	(OWLEN
	SNA CLA		/IF BUFFER JUST BECAME UNFULL,
	TAD	(TSFEF	/SET EVENT FLAG
	POSTDS		/ELSE JUST DISMISS

TSFEF,	0
OWGET,	OWBASE
OWPUT,	OWBASE
OWCNT,	0
/LINE PRINTER OUTPUT ROUTINE - USES RTS-8 LPT DRIVER

	IFDEF	LPT	<
XLLS,	TAD	AC
	DCA I	LPBUF	/STORE CHAR IN LPT MESSAGE BUFFER
	ISZ	LPBUF
	TAD	AC
	AND	(177
	TAD	(-15	/CHECK TO SEE IF THE CHARACTER
	CLL
	TAD	(3	/IS A FORMS MOVEMENT CHARACTER
	ISZ	LPBUFC	/(I.E. LF,VT,OR FF)
	SZL CLA		/OR IF THE MESSAGE BUFFER IS FULL
	SKP CLA
	JMP I	(XNOP	/NEITHER - RETURN TO OS/8 JOB
	DCA I	LPBUF	/ZERO IS THE BUFFER END CODE
	CAL
	SENDW		/MOVE THE BUFFER TO THE LINE PRINTER
	LPT
	LPMESG
	TAD	(LPTBUF
	DCA	LPBUF	/RE-INITIALIZE THE BUFFER PPOINTER
	TAD	(-LPTCNT
	DCA	LPBUFC	/AND COUNTER
	JMP I	(XNOP	/AND CONTINUE

LPBUF,	LPTBUF
LPBUFC,	-LPTCNT
	>
	IFNDEF	LPT	<
XLLS,	ISZ	LPFST
	SKP
	JMP	.+3
	PSKF
	JMP	.-1	/OH, HOW CRUDE!
	TAD	AC
	PSLS
	DCA	LPFST	/CLEAR FIRST-TIME FLAG
	JMP I	(XNOP
LPFST,	-1
	>
	PAGE
/CODE TO HANDLE CDF'S AND CIF'S

DFSTUF,	TAD I	PC
	DCA	WD
	CLA IAC
	AND	WD	/CHECK CDF BIT
	SNA CLA
	JMP	NOCDF
	TAD	WD
	AND	(70
	JMS I	(GETFLD	/MAP TO CDF TO REAL FIELD
	DCA	UCDF+1	/SAVE IN CDF SUBR

NOCDF,	AC0002
	AND	WD
	SNA CLA
	JMP I	(XNOP	/WHEW!
	TAD	WD	/UNLUCKY US - A CIF
	AND	(70
	DCA	IBR	/SAVE IF BACKUP
	ISZ	PC
	TAD	IBR
	CIA
	TAD	UIF	/IF ITS A CIF TO CURRENT FIELD,
	SNA CLA		/EXIT IMMEDIATELY BYPASSING EXECUT RETURN
	JMP I	(GOBACK	/AND POSSIBLE SUBSEQUENT USELESS SIMULATION

CIFLP,	JMS	UCIF
	TAD I	PC
	DCA	WD	/GET WORD TO INTERPRET
	TAD	WD
	SPA CLA
	JMP	NONSTD
	JMS	GEFADR	/GET EFFECTIVE ADDRESS
	TAD	WD
	AND	T7000	/ISOLATE OPCODE
	TAD	(AND I	WT	/FORM EQUIVALENT INSTRUCTION
	DCA	WD
	JMP	XINLIN	/AND EXECUTE IT IN LINE
/SUBROUTINE TO COMPUTE EFFECTIVE ADDRESSES

GEFADR,	0
	TAD	WD
	AND	(177
	DCA	WT
	TAD	WD
	AND	(200
	CIA
	AND	PC
	TAD	WT
	DCA	WT	/ADD PAGE BITS TO DISPLACEMENT
	JMS	UCIF
	TAD	WD
	AND	(400
	SNA CLA		/IF NO INDIRECT ADDRESS,
	JMP I	GEFADR	/OPERAND FIELD = IF
	TAD	WT
	AND	(7770
	TAD	(7770
	SNA CLA		/TEST FOR AUTO-XRS
	ISZ I	WT
	TAD I	WT
	DCA	WT
	JMS	UCDF	/IF INDIRECT ADDRESSING,
	JMP I	GEFADR	/OPERAND FIELD = DF

NONSTD,	TAD	WD
	CLL RTL
	SNL		/CHECK FOR JMP OR JMS
	JMP	JMPJMS	/YES - NOT LONG NOW
	SPA
	JMP	XOPR	/SEPARATE THE IOTS FROM THE OPRS
	CLA
	JMS I	(EXECUT	/WE CAN CALL EXECUT "RECURSIVELY" HERE SINCE
	JMP	CIFLP	/WE DON'T PLAN ON RETURNING FROM THIS LEVEL

XOPR,	AND	(6014	/7403 ROTATED LEFT 2
	TAD	(-6010	/7402 ROTATED LEFT 2
	SNA CLA
	JMP I	(ILLIOT
XINLIN,	TAD	LINK
	CLL RAL
	TAD	AC
WD,	0
	SKP		/WATCH FOR SKIPS AND ISZ'S
	ISZ	PC
	ISZ	PC
T7000,	NOP		/JUST IN CASE
	DCA	AC
	RAR
	DCA	LINK
	JMP	CIFLP
/INTERPRET JMP OR JMS

JMPJMS,	CLA
	JMS	GEFADR	/GET EFFECTIVE ADDRESS
	TAD	IBR
	JMS I	(GETFLD	/GET TARGET FIELD
	DCA	UCIF+1
	TAD	IBR
	DCA	UIF
	JMS	UCIF
	TAD	WD
	RTL		/CHECK FOR JMS
	SPA CLA
	JMP	XJMP	/NO
	CLA IAC
	TAD	PC
	DCA I	WT	/SAVE RETURN ADDRESS
	CLA IAC		/AND BUMP JUMP ADDRESS
XJMP,	TAD	WT
	DCA	PC
	JMP I	(GOBCKX

WT,	0
IBR,	0
	PAGE
/ROUTINE TO HANDLE SPECIAL OS/8 HANDLER IOT

/FORMAT OF SPECIAL IOT USAGE IS AS FOLLOWS:

/	TAD	(INTERNAL DEVICE CODE
/	6000	/DATA FIELD IS FIELD OF HANDLER ARGUMENTS
/	POINTER TO OS/8 HANDLER ENTRY POINT
/	RETURN IS TO THE ERROR OR NORMAL RETURN OF THE HANDLER

HCALL,	JMS	UCIF
	ISZ	PC	/GO TO NEXT WD
	TAD I	PC
	DCA	PC	/PC CONTAINS HANDLER ENTRY PT ADDR
	TAD I	PC
	DCA	PC	/PC CONTAINS ARGUMENT LIST ADDR
	IFDEF	OS8F	<
	TAD	UCDF+1
	TAD	(-CDF-OS8F1
	SNA CLA		/IF WE ARE CALLING THE
	TAD	PC	/KEYBOARD MONITOR,
	TAD	(-OSKBML
	SZA
	TAD	(OSKBML-OSUSRL	/USR,
	SZA
	TAD	(OSUSRL-OSCDLD	/OR COMMAND DECODER INTO CORE,
	SZA CLA		/RELEASE THE OS8F INTERLOCK
	JMP	NOPOST	/SINCE THE USR DIRECTORY BUFFER IS CLEAR.
	TAD	(INTLOK
	CAL
	POST		/OS8F INTERLOCK IS A STANDARD EVENT FLAG
	CDF CUR		/IN THE CURRENT FIELD
NOPOST,
	>
	TAD	AC
	AND	(7760	/CHECK UNIT NUMBER LT 16.
	SZA CLA
	JMP I	(ILLIOT	/IF NOT, ILLEGAL IOT
	TAD	(HNDTAB
	TAD	AC
	DCA	AC
	JMS	UCDF	/ARG LIST IN DATA FIELD
	TAD I	PC
	AND	(7707
	DCA	ARGS+1	/GET FIRST WORD EXCEPT FOR FIELD
	TAD I	PC
	AND	(70
	JMS	GETFLD	/RELOCATE BUFFER FIELD
	AND	(70
	TAD	ARGS+1
	DCA	ARGS+1
	ISZ	PC
	TAD I	PC
	DCA	ARGS+2
	ISZ	PC
	TAD I	PC
	DCA	ARGS+3
	IFDEF	OS8F	<
	CLA IAC
	TAD	ARGS+3
	AND	(7770	/IF THE I/O IS TO A DIRECTORY BLOCK
	SNA		/WE MUST SET THE OS8F INTERLOCK
	TAD	INTLOK	/(IF IT WAS CLEAR) TO PREVENT
	SNA CLA		/SIMULTANEOUS UPDATE OF
	ISZ	INTLOK	/THE OS/8 DIRECTORY
	>
	ISZ	PC
	CDF CUR
	TAD I	AC	/GET HANDLER TASK NUMBER
	SNA
	JMP I	(ILLIOT	/ILLEGAL HANDLER IOT
	CLL RTR
	RAR
	AND	(177	/IN BITS 3-8 OF TABLE ENTRY
	DCA	HTASK
	TAD I	AC	/GET UNIT NUMBER
	AND	(7	/IN BITS 9-11
	DCA	ARGS
	CAL
	SENDW		/SEND THE I/O REQUEST TO THE APPROPRIATE TASK
HTASK,	0
	IOMESS		/AND WAIT FOR COMPLETION
	TAD	IOSTS	/USE RETURN STATUS TO DETERMINE
	SNA		/WHETHER WE FAKE A NORMAL OR ERROR RETURN
	ISZ	PC
	SZA CLA
	AC4000		/TRADITIONAL ERROR VALUE
	DCA	AC
	TAD	UCDF+1
	CIA
	TAD	FLDTBL	/COMPUTE VIRTUAL RETURN DF
	JMP I	(HNDRET	/RETURN FROM OS/8 HANDLER

IOMESS,	ZBLOCK	3	/HANDLER MESSAGE
ARGS,	ZBLOCK	4
IOSTS,	0
INTLOK,	0		/OS8-OS8F INTERLOCK - 0 MEANS DIR FREE
GETFLD,	0		/ROUTINE TO MAP FIELDS
	CLL RTR
	RAR
	TAD	(TAD FLDTBL
	DCA	.+1	/THIS ROUTINE SHOULD LEAVE THE DF UNCHANGED
	HLT
	JMP I	GETFLD

/TABLE OF REAL FIELDS

FLDTBL,	CDF OS8F0
	CDF OS8F1
	CDF OS8F2
	CDF OS8F3
	CDF OS8F4
	CDF OS8F5
	CDF OS8F6
	CDF OS8F7
	PAGE
/OS8 FILE SUPPORT INTERLOCK TEST ROUTINE
/ON ENTRY, XR POINTS TO HNDTAB AND LENGTH=-17(8)

	IFDEF	OS8F	<	/ONLY ASSEMBLED IF NEEDED
CKINTL,	0
WTINTL,	CAL		/WAIT FOR OS/8 TO REACH A STATE IN WHICH
	WAITE		/THERE IS NO POSSIBILITY OF AN ACTIVE
PINTLK,	INTLOK		/DIRECTORY BUFFER IN THE USR.
HNDLP,	TAD I	(FN
	AND	(1777	/SEE IF OUR DEVICE IS IN THE OS/8 SYSTEM
	CIA
	TAD I	XR	/BY SEARCHING THE OS8 SUPPORT TASK'S
	SNA CLA		/TABLES FOR IT
	JMP	FNDOSD	/FOUND IT
	ISZ	LENGTH
	JMP	HNDLP	/KEEP LOOKING
	JMP I	CKINTL	/NOT THERE - NO INTERLOCK
FNDOSD,	TAD	XR
	TAD	(OS8DCB-1-HNDTAB
	DCA	LENGTH	/GET POINTER INTO THE DCB ENTRY FOR THE
	CDF OS8F1	/DEVICE INVOLVED
	TAD I	LENGTH
	AND	(7	/CHECK FOR OPEN OUTPUT FILE ON THE DEVICE
	CDF CUR
	SNA CLA
	JMP I	CKINTL	/NONE - NO INTERLOCK
	ISZ I	PINTLK	/OOPS - WE CAN'T TOUCH DIRECTORY NOW
	JMP	WTINTL	/WAIT UNTIL THE NEXT QUIET MOMENT
	>

/TABLE OF CORRESPONDENCES BETWEEN OS/8 CODE NUMBER AND TASK NUMBER

HNDTAB,	ZBLOCK	20	/FIRST WORD IS UNUSED - MUST BE 0
/TABLES FOR OS/8 SUPPORT TASK

/TABLE OF LEGAL IOT'S

IOTLST,	-RDF;	XRDF
	-RIF;	XRIF
	-KSF;	XKSF
	-KCC;	XKCC
	-KRS;	XKRS
	-KRB;	XKRB
	-TSF;	XTSF
	-TCF;	XTCF
	-TLS;	XTLS
	-PSLS;	XLLS
	-PSKF;	XSKP
	-6000;	HCALL
	0

LPTCNT=	44		/AS MUCH AS I CAN SPARE RIGHT NOW
	IFNDEF	OS8F	<LPTCNT=LPTCNT+34>
LPMESG,	ZBLOCK	3
	6000		/UNPACKED ASCII, NO CRLF
	0		/DUMMY INPUT BUFFER WORD
LPTBUF,	ZBLOCK	LPTCNT+1	/ASSURE A ZERO AT THE END

ILIOMS,	15;12
	ZBLOCK	OSFILL	/WATCH GARBLING!
	"H;"A;"L;"T;" ;"A;"T;" ;4600
	PAGE
/ OS/8 INITIALIZATION CODE - CREATES FAKE SYSTEM HEAD
/AND ESTABLISHES RELATIONSHIP BETWEEN OS/8 DEVICE HANDLER NAMES
/AND RTS-8 DRIVERS

	FIELD OS8F0%10
	*4000		/A GOOD SAFE PLACE

INITOS,	0
	IOF		/ALL KINDZA HANKY-PANKY GOING ON!
	IFNDEF	LPT	<
	PSIE		/DISABLE LS8E INTS, ENABLE LE8 INTS
	PCIE		/DISABLE LE8 INTS, NOP ON LS8E (I HOPE)
	>
IMOVLP,	CDF 0
	TAD I	P7600
	CDF OS8F0
	DCA I	P7600
	CDF 10
	TAD I	P7600	/MOVE BOTH SYSTEM HEAD PAGES
	CDF OS8F1	/INTO THEIR FAKE FIELDS
	DCA I	P7600
	ISZ	P7600
	JMP	IMOVLP
	CDF 0
	TAD	(TSINT
	DCA I	(200	/SET UP TSS/8 "TRAP VECTOR" IN RTS-8 EXEC
	DCA I	(JSBITS	/MAKE SURE CORE IS SAVED WHEN WE CALL THE USR
IMOVHN,	CDF OS8F0
	TAD I	FKHND1
	DCA I	FKHND2	/MOVE THE RTS-8 FAKE SYSTEM HANDLER INTO PLACE
	ISZ	FKHND1
	ISZ	FKHND2
	ISZ	FKHNDC
	JMP	IMOVHN
	CIF 10
	JMS I	(7700	/LOAD THE OS/8 USR INTO CORE (REAL CORE!)
	10
	JMP I	(INIHNL

FKHND1,	FAKHND
FKHND2,	7607
FKHNDC,	FAKHND-FAKEND
P7600,	7600
FAKHND,	RELOC	7607	/FAKE OS/8 SYSTEM HANDLER

FAKSYS,	ISZ	DVNUM
	ISZ	DVNUM
	ISZ	DVNUM
	ISZ	DVNUM
	ISZ	DVNUM	/17(8) ENTRY POINTS

	ISZ	DVNUM
	ISZ	DVNUM
	ISZ	DVNUM
	ISZ	DVNUM
	ISZ	DVNUM
	ISZ	DVNUM
	ISZ	DVNUM
	ISZ	DVNUM
	ISZ	DVNUM
	ISZ	DVNUM
F17,	17
	CLA		/JUST IN CASE
	TAD	DVNUM	/GET ENTRY POINT NUMBER
	CMA
	TAD	FAKTAD	/TRANSFORM INTO "TAD" ON ENTRY POINT
	DCA	.+1
	HLT		/GET CALLING ADDRESS
	DCA	FAKPTR
	AC2000
	TAD	.-3	/NOW FORM A "DCA ENTRY POINT"
	DCA	.+2
	TAD	FAKISZ
	HLT		/RESTORE ENTRY POINT
	TAD	DVNUM
	CIA
FAKTAD,	TAD	F17	/GET RTS-8 INTERNAL REFERENCE NUMBER
	DCA	FAKT
	DCA	DVNUM	/CLEAR DVNUM FOR NEXT CALL
	TAD	FAKT
	6000		/MAGIC IOT
	FAKPTR		/POINTER TO POINTER TO ARGLIST

DVNUM,	0
FAKT,	0
FAKPTR,	0
FAKISZ,	ISZ	DVNUM
	RELOC
FAKEND=	.
	PAGE
/LOOP WHICH RELATES OS/8 AND RTS HANDLERS

INIHNL,	ISZ	HPTR
	TAD I	HPTR	/GET NEXT HANDLER NAME
	SNA
	JMP	ASDONE	/NO MORE
	DCA	ASNAM1
	ISZ	HPTR
	TAD I	HPTR
	DCA	ASNAM2	/STORE HANDLER NAME IN "INQUIRE"
	ISZ	HPTR
	CIF 10
	JMS I	(200
	12		/IS HANDLER THERE?
ASNAM1,	0
ASNAM2,	0
	0
	JMP	INIHNL	/HANDLER NOT IN SYSTEM CONFIGURATION
	TAD	ASNAM2
	TAD	(OS8HND-1
	DCA	HNDPTR	/GET POINTER INTO RESIDENT HANDLER TABLE
	TAD	ASNAM2
	TAD	(HNDTAB
	DCA	HTBPTR	/AND EQUIVALENT PTR INTO RTS-8 TABLE
	CDF OS8F1
	TAD	(FAKSYS-1
	TAD	ASNAM2	/ASSIGN ONE OF THE 17 ENTRY POINTS IN THE
	DCA I	HNDPTR	/FAKE SYSTEM HANDLER TO THIS DEVICE
	CDF OS8F0
	TAD I	HPTR	/GET THE RTS-8 TASK AND UNIT NUMBER
	CDF 0
	DCA I	HTBPTR	/MAKE THE CORRESPONDING ENTRY IN THE
	CDF OS8F0	/OS8 SUPPORT TASK TABLE
	JMP	INIHNL	/GET THE NEXT HANDLER

ASDONE,	CIF 10
	JMS I	(200
	11		/KICK OUT THE USR
	CDF OS8F0
	TAD I	(INITOS
	DCA	HPTR
	CDF CIF 0
	ION		/INTERRUPTS CAN GO BACK ON NOW
	JMP I	HPTR	/RETURN TO OS8SUP

HTBPTR,	HNDTAB+1
HNDPTR,	0
/DEVICE CORRESPONDENCE TABLE

HPTR,	.

	DEVICE	SYS
	OSSYSD^10
	DEVICE	DSK
	OSSYSD^10

	IFDEF	DTA	<
	DEVICE	DTA0
	DTA^10+0
	DEVICE	DTA1
	DTA^10+1
	DEVICE	DTA2
	DTA^10+2
	DEVICE	DTA3
	DTA^10+3
	DEVICE	DTA4
	DTA^10+4
	DEVICE	DTA5
	DTA^10+5
	DEVICE	DTA6
	DTA^10+6
	DEVICE	DTA7
	DTA^10+7
	>
	IFDEF	RK8	<
	DEVICE	RKA0
	RK8^10+0
	DEVICE	RKB0
	RK8^10+4
	DEVICE	RKA1
	RK8^10+1
	DEVICE	RKB1
	RK8^10+5
	DEVICE	RKA2
	RK8^10+2
	DEVICE	RKB2
	RK8^10+6
	DEVICE	RKA3
	RK8^10+3
	DEVICE	RKB3
	RK8^10+7
	>
	0
	PAGE
	>
	XLIST	0
/OS/8 FILE SUPPORT TASK

	IFNDEF	OS8F	<XLIST 1>
	IFDEF	OS8F	<

/PROVIDES RTS-8 TASKS WITH THE FACILITY TO LOOKUP, ENTER
/AND DELETE FILES IN OS/8 DIRECTORIES.

TASK2=	OS8F
CUR2=	CUR
INIWT2=	0

/THE FORMAT OF A MESSAGE TO THIS TASK IS:
/WORD 1		MESSAGE EVENT FLAG
/WORDS 2&3	RESERVED FOR RTS-8
/WORD 4		FUNCTION WORD:
/    BITS 0-1	00=LOOKUP,10=DELETE,01=11=ENTER
/    BITS 3-8	TASK NUMBER OF DEVICE HANDLER
/    BITS 9-11	UNIT NUMBER
/WORD 5		POINTER TO FILE NAME
/WORD 6		GETS A 0 IF SUCCESSFUL, ERROR CODE IF NOT
/WORD 7		GETS BLOCK NUMBER AFTER SUCCESSFUL LOOKUP OR ENTER
/WORD 8		GETS FILE LENGTH AFTER LOOKUP
/		SPECIFIES DESIRED FILE LENGTH ON ENTER

/PAGE 0 LOCATIONS:

	FIELD	CUR%10
	*16
XR,	0

	*160
BLOCK,	0		/CURRENT BLOCK NUMBER
LENGTH,	0		/CURRENT LENGTH
PTNAME,	0		/POINTER TO FILE NAME
NFILES,	0		/NUMBER OF FILES IN THIS SEGMENT
ETMP,	0		/TEMPORARIES FOR "ENTER"
EPTR,	0
	*6200

START2,	CAL
	RECEIVE		/WAIT FOR A MESSAGE AND PULL IT IN
MADDR,	0
	DCA	MSGCDF
	JMS	MCDF	/SET DF TO MESSAGE FIELD
	TAD I	MADDR
	DCA	FN	/SAVE FUNCTION
	ISZ	MADDR
	TAD I	MADDR
	DCA	PTNAME	/SAVE PTR TO FILE NAME
	ISZ	MADDR
	CDF CUR
	TAD	FN
	AND	(7
	DCA	UNIT	/UNIT NUMBER IN BITS 9-11 OF FUNCTION WORD
	TAD	FN
	CLL RTR
	RAR
	AND	(77	/HANDLER'S TASK NUMBER IN BITS 3-8
	DCA	IOTASK
	TAD	FN
	CLL RAL
	SPA CLA		/FUNCTIONS ARE:
	JMP	ENTER	/0000=LOOKUP, 2000=DELETE, 4000&6000=ENTER
	SNL CLA
	JMP	LOOKUP
	JMS I	(PURGE	/DELETE - PURGE FILE NAME FROM OS/8 DIRECTORY
NOFILE,	IAC		/ERROR RETURN - SET STATUS CODE
FINI,	JMS	MCDF
	DCA I	MADDR	/STORE STATUS CODE
	ISZ	MADDR
	TAD	BLOCK
	DCA I	MADDR
	ISZ	MADDR
	TAD	LENGTH	/STORE BLOCK NUMBER AND LENGTH IN MESSAGE
	DCA I	MADDR
	IFDEF	OS8	<
	TAD	(OS8
	CAL		/RESUME OS/8 EXECUTION
	RUN
	>
	TAD	MSGCDF
	DCA	MEFCDF
	TAD	MADDR
	TAD	(-7
	CAL
	POST
FN,
MEFCDF,	0		/POST MESSAGE EVENT FLAG
	JMP	START2	/GET NEXT MESSAGE

MCDF,	0
MSGCDF,	HLT
	JMP I	MCDF
LOOKUP,	JMS I	(MDSRCH	/FIND FILE NAME IN DIRECTORY
	JMP	NOFILE	/NOT FOUND
	JMP	FINI	/FOUND.

ENTER,	JMS I	(PURGE	/DELETE PREVIOUS COPY OF FILE
	NOP		/FILE NOT FOUND - WHO CARES?
	CLA IAC
	TAD	MADDR
	DCA	LENGTH
	JMS	MCDF
	TAD I	LENGTH	/GET DESIRED LENGTH
	CDF CUR
	JMP I	(ENTERX

MRDCAT,	0		/DIRECTORY READ ROUTINE
	DCA	DBLOCK	/ENTER WITH BLOCK NUMBER IN AC
	JMS	MREADC	/READ DIR BLK
	TAD I	(DSTBLK
	DCA	BLOCK	/INITIALIZE BLOCK NUMBER FROM DIRECTORY HEADER
	TAD I	PDCNT
	DCA	NFILES	/INITIALIZE FILE COUNT
	TAD	(DBODY-1
	DCA	XR	/INITIALIZE DIRECTORY FILE PTR
	JMP I	MRDCAT

MREADC,	0		/LOW-LEVEL DIRECTORY READ/WRITE ROUTINE
	TAD	(200+CUR
	DCA	IOCTLW	/STORE READ OR WRITE CONTROL WORD
	CAL
	SENDW
IOTASK,	0
	IOMSG
	TAD	IOSTAT
	SZA
	JMP	FINI	/I/O ERROR - RETURN I/O STATUS AS ERROR
	TAD I	PDCNT
	CMA CLL
	TAD I	(DLINK
	AND	(7700
	SNL		/VALIDATE THE DIRECTORY BUFFER
	SZA CLA
	SKP		/BAD
	JMP I	MREADC
	AC4000
	JMP	FINI	/ERROR 4000 - BAD OS/8 DIRECTORY BLOCK
IOMSG,	ZBLOCK	3
UNIT,	0		/UNIT NUMBER
IOCTLW,	0		/I/O CONTROL WORD
PDCNT,	DBUF		/BUFFER PTR
DBLOCK,	0		/BLOCK NUMBER
IOSTAT,	0		/COMPLETION STATUS

MEOVLS,	ZBLOCK	10	/TEMPORARY STORAGE FOR DIRECTORY EXPANDER
	PAGE
ENTERX,	DCA	LENGTH	/STORE DESIRED LENGTH
RENTER,	DCA	EPTR	/SET FOUND POINTER TO 0
	CLA IAC
ENSEGL,	JMS I	(MRDCAT	/GET NEXT DIRECTORY SEGMENT
ENSRCL,	TAD I	XR	/GET NEXT ENTRY
	SNA CLA
	JMP	EMPTY	/IT'S EMPTY
	AC7775		/IT'S A FILE - SKIP IT
	JMS I	(BUMPXR
	TAD I	XR
ELEND,	CIA
	TAD	BLOCK	/UPDATE BLOCK NUMBER
	DCA	BLOCK
	ISZ	NFILES
	JMP	ENSRCL
	TAD	EPTR
	SZA CLA		/DID WE FIND A SUITABLE EMPTY IN THIS SEGMENT?
	JMP	EINRTS	/YES
	TAD I	(DLINK	/NO - GO TO NEXT SEGMENT
	SZA
	JMP	ENSEGL
ENTERR,	AC0002		/NO MORE SEGMENTS - ENTER ERROR
	JMP I	(FINI

EMPTY,	TAD I	XR
	DCA	ETMP	/SAVE LENGTH OF EMPTY
	TAD	EPTR
	SZA CLA		/DO WE ALREADY HAVE A GOOD EMPTY?
	JMP	ENOGD	/YES - DISREGARD THIS'N
	CLL STA
	TAD	ETMP
	TAD	LENGTH
	SNL CLA		/IS IT LARGE ENOUGH?
	JMP	ENOGD	/NO
	TAD	XR
	DCA	EPTR
	TAD	BLOCK
	DCA	EBLOCK
ENOGD,	TAD	ETMP
	JMP	ELEND	/UPDATE BLOCK NUMBER
EINRTS,	TAD	XR
	DCA	ETMP	/SAVE POINTER TO END OF SEGMENT
	TAD I	EPTR	/GET LENGTH OF GOOD EMPTY
	TAD	LENGTH
	SNA CLA		/CHECK FOR EXACT FIT
	AC0002		/YES - EMPTY WILL DISAPPEAR
	TAD	(-4
	JMS I	(BUMPXR
	JMS	CKOVFL	/CHECK SEGMENT OVERFLOW
	JMS	MOVEUP
	TAD I	EPTR
	TAD	LENGTH
	SNA
	ISZ I	(DBUF	/REDUCE FILE COUNT BY 1 FOR KILLED EMPTY
	NOP
	SZA
	DCA I	XR	/OTHERWISE STORE UPDATED LENGTH
	STA
	TAD	ETMP
	DCA	XR	/RESTORE END-OF-SEGMENT POINTER TO XR
	TAD	(-4
	DCA	ETMP
NMOVLP,	JMS I	(MCDF
	TAD I	PTNAME
	ISZ	PTNAME
	CDF CUR
	DCA I	XR	/MOVE FILE NAME INTO DIRECTORY SEGMENT
	ISZ	ETMP
	JMP	NMOVLP
	CDF 0
	TAD I	(DATE
	CDF CUR
	DCA I	XR	/STORE SYSTEM DATE IN ADDITIONAL INFO WORD #1
	CLA IAC
	JMS I	(BUMPXR
	TAD	LENGTH
	CIA
	DCA I	XR	/STORE LENGTH OF NEW FILE
	STA
	TAD I	(DBUF	/INCREMENT FILE COUNT
	DCA I	(DBUF
	AC4000		/WRITE THIS SEGMENT BACK OUT
	JMS I	(MREADC
	TAD	EBLOCK
	DCA	BLOCK	/RESTORE BLOCK FOR STORING INTO MESSAGE
	JMP I	(FINI
EBLOCK,	0

MOVEUP,	0		/ROUTINE USED BY ENTER AND "NOROOM"
	TAD I	ETMP
	DCA I	XR	/TRANSFER A WORD
	TAD	ETMP
	CMA
	TAD	EPTR
	SNA CLA
	JMP I	MOVEUP	/ENOUGH WORDS - DONE
	STA
	TAD	ETMP
	DCA	ETMP
	AC7776
	TAD	XR
	DCA	XR
	JMP	MOVEUP+1

CKOVFL,	0		/CHECK DIRECTORY SEGMENT OVERFLOW
	TAD I	(DEXTRA
	CIA
	TAD	XR	/MUST BE ROOM FOR 1 DUMMY ENTRY
	TAD	(-DBUF-372
	SMA CLA
	JMP I	(NOROOM	/THERE ISN'T - MUST ADJUST SEGMENTS
	JMP I	CKOVFL
	PAGE
MDSRCH,	0		/DIRECTORY SEARCH ROUTINE
	CLA IAC
SRSEGL,	JMS I	(MRDCAT
MDSRCL,	TAD	PTNAME
	DCA	PTN	/GET POINTER TO FILE NAME WORD 1
	TAD	(-4
	DCA	CT
	TAD I	XR
	SNA		/CHECK TYPE OF ENTRY
	JMP	SKPMTF	/EMPTY
	SKP		/SKIP INTO SEARCH LOOP
SRCWDL,	TAD I	XR
	CIA
	JMS I	(MCDF
	TAD I	PTN
	ISZ	PTN
	CDF CUR
	SZA CLA		/COMPARE FILE NAME AGAINST DIRECTORY ENTRY
	JMP	NXTFIL
	ISZ	CT
	JMP	SRCWDL
	JMS	BUMPXR	/SUCCESSFUL MATCH
	TAD I	XR	/GET LENGTH WORD
	SNA
	JMP	SKPMTF+1	/LENGTH 0 FILES ARE TENTATIVES
	DCA	LENGTH
	ISZ	MDSRCH
	JMP I	MDSRCH	/TAKE SKIP RETURN IF SUCCESS

NXTFIL,	TAD	CT
	IAC
	JMS	BUMPXR	/SKIP TO END OF FILE NAME IN SEGMENT
SKPMTF,	TAD I	XR
	CIA
	TAD	BLOCK	/UPDATE BLOCK NUMBER
	DCA	BLOCK
	ISZ	NFILES
	JMP	MDSRCL
	TAD I	(DLINK	/SEGMENT EXHAUSTED - ON TO NEXT SEGMENT
	SNA
	JMP I	MDSRCH	/NO NEXT SEGMENT - TAKE ERROR EXIT
	JMP	SRSEGL

BUMPXR,	0
	TAD I	(DEXTRA	/GET NUMBER OF ADDITIONAL INFO WORDS
	CIA
	TAD	XR	/BUMP POINTER BY AC+A.I.WORDS
	DCA	XR
	JMP I	BUMPXR

CT,	0
PTN,	0
PURGE,	0		/ROUTINE TO PURGE A FILE FROM THE DIRECTORY
	TAD	(HNDTAB
	DCA	XR	/PREPARE TO CHECK OS/8 INTERLOCK
	TAD	(-17
	DCA	LENGTH
	JMS I	(CKINTL	/CHECK IT
	TAD	(OS8	/MADE IT! - SUSPEND OS/8
	CAL		/SO WE WON'T HAVE ANY TROUBLE
	SUSPND
	JMS	MDSRCH	/SEARCH DIRECTORY FOR FILE NAME
	JMP I	PURGE	/NO SUCH FILE - ERROR EXIT
	ISZ	PURGE
	AC7776
	TAD	XR
	DCA	XR	/POINT XR AT LENGTH WORD - 1
	TAD	XR
	DCA	SQP
	ISZ	SQP
	DCA I	SQP	/ZERO LENGTH WORD -1
	AC7775
	TAD I	(DEXTRA
	JMS	SQUISH	/SQUISH OUT FILE NAME, LEAVING EMPTY
	JMS	CONSOL	/ELIMINATE PAIRS OF EMPTIES
	AC4000
	JMS I	(MREADC	/WRITE OUT THIS SEGMENT
	JMP I	PURGE	/AND RETURN

CONSOL,	0		/ROUTINE TO CONSOLIDATE A DIRECTORY
	TAD	(DBODY-1
	DCA	XR
	TAD I	(DBUF
	DCA	CT
CONLP,	TAD I	XR
	SNA CLA
	JMP	PEMPTY	/GOT AN EMPTY - CHECK FOR 2
PSKIPF,	TAD	(-4
	JMS	BUMPXR	/SKIP PAST FILE NAMES
	ISZ	CT
	JMP	CONLP
	JMP I	CONSOL	/DONE - RETURN

PEMPTY,	ISZ	XR
	TAD	XR
	DCA	SQUISH	/SAVE POINTER TO FIRST LENGTH WORD
	ISZ	CT
	SKP
	JMP I	CONSOL	/LAST ENTRY WAS EMPTY - WE'RE DONE
	TAD I	XR
	SZA CLA
	JMP	PSKIPF	/NON-EMPTY - NO SQUISH
	TAD I	XR
	TAD I	SQUISH
	DCA I	SQUISH
	AC7776
	JMS	SQUISH	/SQUISH OUT REDUNDANT EMPTY
	ISZ I	(DBUF
	JMP	CONSOL+1	/START ALL OVER AGAIN
SQUISH,	0		/LOW LEVEL COMPRESS ROUTINE
	TAD	XR
	DCA	SQP
SQLOOP,	TAD I	XR
	ISZ	SQP
	DCA I	SQP
	TAD	XR
	TAD	(-DBUF-377
	SZA CLA
	JMP	SQLOOP
	JMP I	SQUISH

SQP,	0
	PAGE
NOROOM,	TAD I	(DLINK
	SNA CLA		/LAST SEGMENT?
	JMP	MELAST	/YES - SPECIAL PROCEDURE
	ISZ I	(DBUF	/DECREASE ENTRY COUNT BY 1
	AC4000
	JMS I	(MREADC	/WRITE OUT THIS SEGMENT
	JMS	MSKIPF	/FIND END OF SHORT SEGMENT
	DCA	MEFCNT	/INITIALIZE LENGTH COUNTER
	TAD	(MEOVLS-1
	DCA	EPTR
MVLP1,	TAD I	XR
	ISZ	EPTR
	DCA I	EPTR
	ISZ	MEFCNT
	TAD	XR
	CIA
	TAD	ETMP	/MOVE LAST FILE NAME TO SAFE PLACE
	SZA CLA
	JMP	MVLP1
	TAD I	ETMP
	DCA	MEOCNT	/SAVE LENGTH OF LAST ENTRY
	TAD I	(DLINK
	JMS I	(MRDCAT
	JMS I	(CONSOL	/PRE-SQUISH NEW SEGMENT
	TAD I	(DSTBLK
	TAD	MEOCNT	/BUMP DOWN FILE ORIGIN
	DCA I	(DSTBLK
	JMS	MSKIPF	/FIND END OF SEGMENT
	TAD	XR
	DCA	ETMP
	STA
	TAD	MEFCNT
	TAD	XR
	DCA	XR	/BUMP XR BACK BY NEW FILE ENTRY LENGTH
	TAD	(DBODY+1
	DCA	EPTR
	JMS I	(MOVEUP
	TAD	(MEOVLS-1
	DCA	XR
	STA
	TAD I	(DBUF
	DCA I	(DBUF	/INCREASE ENTRY COUNT
	TAD	MEFCNT
	CIA
	JMP	MECOMN
MELAST,	TAD	(7	/MOVE 7 FILES INTO BRAND NEW SEGMENT
	TAD I	(DBUF
	DCA I	(DBUF	/DECREASE ENTRY COUNT BY 7
	JMS	MSKIPF	/FIND NEW END OF SEGMENT
	TAD I	(DBLOCK
	AND	(7
	IAC
	DCA I	(DLINK	/LINK THIS SEGMENT TO NEW ONE
	TAD I	(DLINK
	TAD	(-7
	SMA CLA		/HAVE WE RUN OUT OF SEGMENTS?
	JMP I	(ENTERR	/YES
	AC4000
	JMS I	(MREADC	/WRITE OUT TRUNCATED BLOCK
	ISZ I	(DBLOCK	/SET UP TO WRITE NEW BLOCK
	TAD	(-7
	DCA I	(DBUF
	TAD	MEOCNT
	CIA
	TAD I	(DSTBLK	/NEW START BLOCK = OLD START BLOCK
	DCA I	(DSTBLK	/PLUS LENGTH OF OLD SEGMENT
	DCA I	(DLINK	/MARK AS NEW LAST SEGMENT
	TAD	XR
	TAD	(-DBUF-377	/MOVE TOP OF DIRECTORY DOWN
MECOMN,	DCA	MEFCNT
	TAD	(DBODY-1
	DCA	EPTR
MVLP2,	TAD I	XR
	ISZ	EPTR
	DCA I	EPTR	/COPY NEW FILE INTO NEW SEGMENT
	ISZ	MEFCNT
	JMP	MVLP2
	JMS	MSKIPF	/SKIP TO END OF SEGMENT
	TAD	XR
	DCA	ETMP	/SAVE FOR POSSIBLE ITERATION
	JMS I	(CKOVFL	/CHECK FOR NEW SEGMENT OVERFLOW
	AC4000
	JMS I	(MREADC	/WRITE OUT SEGMENT
	JMP I	(RENTER	/START ENTER OVER AGAIN
MSKIPF,	0		/ROUTINE TO SKIP TO END OF SEGMENT
	TAD I	(DBUF
	DCA	MNOFIL
	TAD	(DBODY-1
	DCA	XR
	DCA	MEOCNT	/KEEP RUNNING LENGTH ON THE WAY
MSKPLP,	TAD I	XR
	SNA CLA
	JMP	MEOMTY
	AC7775
	JMS I	(BUMPXR	/BUMP PAST FILE NAME
MEOMTY,	TAD I	XR
	TAD	MEOCNT
	DCA	MEOCNT	/UPDATE LENGTH
	ISZ	MNOFIL
	JMP	MSKPLP
	JMP I	MSKIPF

MNOFIL,	0
MEFCNT,	0
MEOCNT,	0
	PAGE
DBUF,	0		/DIRECTORY BUFFER - FIRST WD IF FILE CT
DSTBLK,	0		/STARTING BLOCK FOR FILES IN THIS SEGMENT
DLINK,	0		/LINK TO NEXT SEGMENT
DOPTR,	0
DEXTRA,	0		/NUMBER OF EXTRA WORDS PER FILE ENTRY
DBODY,	ZBLOCK	373	/BODY OF DIRECTORY
	>
	XLIST 0
	$-$-$
