Google
 

Trailing-Edge - PDP-10 Archives - BB-KL11L-BM_1990 - t20src/reaper.mac
There are 27 other files named reaper.mac in the archive. Click here to see a list.
; Edit= 306 to REAPER.MAC on 22-Apr-88 by EVANS, for SPR #21560
;Fix edit 304. Be sure JFN and file being worked on are in sync.
; *** Edit 305 to REAPER.MAC by EVANS on 10-Apr-87, for SPR #21320
; Release JFNs when SCAN-only.
; *** Edit 304 to REAPER.MAC by EVANS on 10-Apr-87, for SPR #21435
; Prevent JFNS% error by getting JFN from right place if last file. Add ERJMP
; too.
; *** Edit 303 to REAPER.MAC by MAYO on 3-Jan-86, for SPR #21030
; Do not allow REAPER's internal mail buffer to overflow; notice when it gets
; filled and send what we have, restarting the buffer afterwards to allow for
; more mail. Also, make the buffer much bigger.
; *** Edit 302 to REAPER.MAC by MAYO on 20-Dec-85, for SPR #21031
; Check only those entries in DIRS that have meaningful values at CHKDI1.
	TITLE	REAPER

	SEARCH	MONSYM,MACSYM
	.REQUIRE SYS:ARMAIL
	EXTERN	MLINIT,MLTOWN,MLTLST,MLDONE,.MLNFL,.MLOFL

	.DIRECT	FLBLST		;DON'T EXPAND TEXT
	SALL			;KEEP LISTING READABLE



CPYRIG:	ASCIZ +

	REAPER - TOPS-20 Archival Utility
	Copyright (C) 1984 by Digital Equipment Corporation, Maynard, Mass

	THIS SOFTWARE IS FURNISHED UNDER A LICENSE AND MAY ONLY BE USED
	OR COPIED IN ACCORDANCE WITH THE TERMS OF SUCH LICENSE.

+
	SUBTTL	Version info and edit history

	.MAJOR==6
	.MINOR==0
	.EDIT=^D306
	.WHO=0			;SM

COMMENT +
 #  who	  date		Edit description, decreasing order
--- --- ---------	---------------------------------------------------
302 SM	24-Jul-85	Twofold bug in TRIM. FB%NOD should not be checked, as
			 it cannot prevent Migration, and make sure a file with
			 AR%NAR can be migrated if needed


301 SM	15-May-85	Have TAKE try connected directory first, then SYSTEM:
			 if it can't find the file.

300 SM	23-Jan-85	Add POLICY command, since TAKE<CR> no longer
			 takes SYSTEM:REAPER.CMD automatically.  Fix
			 version number.

200 SM	14-Nov-84	Clean up code, fix SKIP to handle non-existant
			 directories, catch ill. inst. problems.
+
	SUBTTL	Definitions
; AC def's
	F==0			;FLAGS (F.????)
	T1==1			;THE USUAL SCRAP
	T2==2
	T3==3
	T4==4
	Q1==5
	Q2==6
	Q3==7
	P1==10
	P2==11
	P3==12
	P4==13
	DIRPGS==14
	ITMSTK==16		;FOR DIRECTORY INFORMATION
	P=17			;STACK POINTER

; flags in AC F
	F.PRIV==1B0		;WHEEL
	F.TRIM==1B1		;TRIMMING OVER-ALLOCATION DIRECTORIES
	F.TAPE==1B2		;CHECK TAPES IN USE
	F.FLSH==1B3		;FLUSH OFFLINE FILES OLDER THAN (PERIOD)

	F.PURG==1B5		;PURGE EXPIRED FDBS
	F.INVL==1B6		;REQUIRE MIGRATION OF OLD FILES
	F.SCAN==1B7		;SCAN ONLY
	F.NDIR==1B8		;NEW DIRECTORY
	F.TRES==1B9		;TAKE RESISTED FILES

	F.ORDR==1B11		;HAVE A SYSTEM ORDER LIST
	F.USOD==1B12		;HAVE A USER ORDER LIST

	F.CMMA==1B18		;COMMA FOR OUTPUT FLAG
	F.PEND==1B19		;ARCHIVE PENDING ON THIS FILE
	F.TMP==1B20		;FOR TEMPORARY THINGS
	F.GOTN==1B21

	LS.TTY==1B0		;FLAGS IN LSTFLG
	LS.LST==1B1


;Useful symbols
	FTONEX==0		;-1 FOR ONLINE EXP. CODE
	PERWRN==^D14		;2 WEEKS WARNING

	JFNSAL=1B2+1B5+1B8+1B11+1B14+JS%PAF+JS%TMP	;JFNS%, do all fields
	JFNSNE=1B8+1B11+1B14+JS%PAF+JS%TMP		;JFNS%, name, ext, gen
	JFNSNX=1B8+1B11+JS%PAF+JS%TMP			;JFNS%, name, ext

	NFILMX==^D8000
;**; [303] At NFILMX+1, add 1 line	SM	 3-Jan-86
	MSGSIZ=12000		;[303] LOTS OF SPACE FOR MESSAGES
	NTAPES==500
	NDIRS==400
	NJFNS==150
	TAKLEN==10
	TMPLEN==100
	PAGLIN=56
	BFRSIZ==1300		;PARSE BUFFER SIZE (LARGE FOR LONG SKIP CMDS)
	ATMSIZ==70		;ATOM BUFFER SIZE
	 BFRLEN=BFRSIZ*5-1	;CHARS ALLOWED IN CMD BUFFER
	 ATMLEN=ATMSIZ*5-1	;CHARS ALLOWED IN ATOM BUFFER
	PAGSIZ=1000		;For DDT, mostly

	PTAP==0			;FOR THE TAPE STORE ROUTINES
	TNAM==1
	TCNT==2

	IFNDEF	VI%DEC,<VI%DEC==0>
;words for variables
	%WRDAT==70000	;Start of word assignments
  ;Allocate word macro
	DEFINE	W$(name,num<1>),<
	 name=%WRDAT
	 %WRDAT==%WRDAT+num>

	W$	STACK,250

	W$	DONEFL,NFILMX
	W$	MSGPTR
;**; [303] At W$ MSGSPC, change number to symbol 	SM	 3-Jan-86
	W$	MSGSPC,MSGSIZ
	W$	DIRCNT
	W$	DIRPTR
;**; [302] At W$ DIRPTR+1 Add 1 line	SM	20-Dec-85
	W$	SKPCNT			;[302] for count of skippables
	W$	FILPTR
	W$	DIRS,NDIRS+1
	W$	JFNSTP
	W$	JFNPTR
	W$	JFNLST,NJFNS+1
	W$	RPSSTK
	W$	RPSSTR,400

	W$	PEOCNT
	W$	COLTMP
	W$	TMP
	W$	INTTMP,2
	W$	AGEIS
	W$	LSTFLG
	W$	FLGTMP
	W$	STKSAV
	W$	LSTTMP
	W$	IFCTMP
	W$	INPTMP
	W$	TAKSTK
	W$	TAKSTR,TAKLEN+1
	W$	OUTMST
	W$	OUTMSX
	W$	TABTMP,6
	W$	STRING,TMPLEN
	W$	TEMP2,100
	W$	DEFDEV,20
	W$	DEFDIR,15
	W$	DEFNAM,15
	W$	DEFEXT,15
	W$	DIRWLD,15
	W$	FILPTH,50
	W$	GOTNAM,50
	W$	FDB,.FBLEN
	W$	TAPBLK,.ARPSZ+1
	W$	FINDSP
	W$	LOCJFN
	W$	ARCJFN
	W$	MAILFL
	W$	MLBLK,3

	W$	LSTIS,25
	W$	ATOM,ATMSIZ
	W$	BFFR,BFRSIZ

;Things that get zeroed at start time
	W$	CLRDAT,0
	W$	CURDIR
	W$	TODAY
	W$	PERIOD
	W$	LVPC3
	W$	PREHIT
	W$	EXPHIT
	W$	LSTJFN
	W$	CURCMD
	W$	LSTLIN
	W$	LSTPOS
	W$	LSTPGN
;Keep the following in order
	W$	NFILES
	W$	TOTPGS
	W$	NFLFIL
	W$	FLPGS
	W$	NTMFIL
	W$	TMPGS
	W$	NPURGE
	W$	ZERO
;things above here get zero'd at start time
	W$	CLREND

	W$	TAPCNT,NTAPES*3
;Writables
GUIINB:	<.CMNOI>B8
	BLOCK	1

LISINB:	<.CMOFI>B8+CM%SDH+CM%HPP+CM%DPP
	0
	-1,,[ASCIZ/LIST file specification/]
	0			;filled in at runtime

CMDBLK:	0,,TRAPRP
	.PRIIN,,.PRIOU		;< FOR BALANCE
	-1,,[ASCIZ/REAPER>/]
	-1,,BFFR
	-1,,BFFR
	BFRLEN
	BFRLEN
	-1,,ATOM
	ATMLEN
	GTJBLK

GTJBLK:	BLOCK	16
;TYPE addr types the string at that address. Literals are acceptable.
	DEFINE	TYPE(locstr),<
	 CALL	[PUSH 	P,T1
		 HRROI	T1,locstr
		 JRST	OUTMSA] >

;TYPCHR "chr" types the character out.
	DEFINE	TYPCHR(chr),<
	 CALL	[PUSH	P,T1
		 MOVEI	T1,<chr>
		 JRST	OUTMSC] >

;TYPEAT addr is just like TYPE, but the addr contains a byte pointer to
; the text
	DEFINE	TYPEAT(locptr),<
	 CALL	[PUSH	P,T1
		 MOVE	T1,locptr
		 JRST	OUTMSG] >

;SELECT sets the output flags as listed, return flagword in the AC
	DEFINE	SELECT(flags,ac<T1>),<
	 MOVX	ac,flags
	 MOVEM	ac,LSTFLG >

;JSERRD for jsys errors that just shouldn't happen
	DEFINE	JSERRD(text, where<BAKOUT>, entri<ERJMP>),<
	 entri	[CALL	ANNERR		;;ANNOUNCE COMMAND IF TAKING
		 HRROI	T1,[ASCIZ\?text\]
		 CALL	LSTERR		;;REPORT WHAT ERROR WAS
		 JRST	where] >	;;GO WHEREVER REQUESTED

;ERROR for general errors that just shouldn't happen.
	DEFINE	ERROR(text, where<BAKOUT>),<
	 JRST	[CALL	ANNERR
		 TYPE	[ASCIZ\?text\]
		 JRST	where] >

;WARN types a message with the approprate leadin character.
	DEFINE	WARN(locstr),<
	 CALL	[CALL	IFCRLF
		 TYPE	[ASCIZ ~%'locstr~]
		 RET] >

;Command table macro
	DEFINE	CTB (addr,txt,fla<0>),<
	 IF1, <	%%C==0>
	 IF2, <	IFDEF addr, <	%%C=addr>
		IFNDEF addr, <	%%C=NOCMD
				PRINTX ?txt not in
			     >
	      >
	 XWD [ IFN fla,<EXP	CM%FW!fla>
		ASCIZ \txt\],%%C
				      >

;GUIDES does the GUIDE call and dispatches to NOCMD if it fails.  Don't
; call this in a literal.
	DEFINE	GUIDES(text,whr<NOCMD>),<
	 JRST	[HRROI	T1,[ASCIZ ~text~]
		 CALL	GUIDE
		  JRST	whr
		 JRST	.+1] >

;CONFIRM does a confirm.  Dispatches to NOCMD on error, hurts no AC's.
	DEFINE	CONFIRM(whr<NOCMD>),<
	 CALL	CONFRM
	  JRST	whr >
	SUBTTL	Startup and Branching code

ENTVEC:	JRST	START
	JRST	START
	BYTE (3).WHO (9).MAJOR (6).MINOR (18) <VI%DEC+.EDIT>	;VERSION

START:	MOVEI	P,STACK-1		;SET STACK UP
	MOVX	T1,LS.TTY
	MOVEM	T1,LSTFLG		;OUTPUT TO TTY: ONLY FOR NOW
	RESET%				;CLEAR THE UNIVERSE
	SETZB	F,CLRDAT		;AND THE FLAGS
	MOVE	T1,[CLRDAT,,CLRDAT+1]
	BLT	T1,CLREND
	SETZM	DIRS			;NO DIRECTORIES STORED YET
	SETZM	JFNLST			;NO JFNS EITHER
	MOVSI	T1,-NDIRS
	MOVEM	T1,DIRPTR
	MOVE	T1,[-NJFNS,,JFNLST]
	MOVEM	T1,JFNPTR
	MOVEI	T1,TAKSTR
	MOVEM	T1,TAKSTK		;SET UP TAKE STACK
	MOVEI	T1,.FHSLF		;Set up interrupts
	MOVE	T2,[LEVTAB,,CHNTAB]
	SIR%				;DECLARE INTERRUPT TABLES
	EIR%
	MOVE	T2,CHNMSK		;TURN ON THE CHANNELS
	AIC%				;ACTIVATE CHANNELS
	MOVE	T1,[.TICCA,,CFCHN]
	ATI%				;SETUP ^A
	MOVX	T1,.FHSLF
	RPCAP%
	TXNN	T3,SC%WHL+SC%OPR	;WHEEL OR OPR PRIVS ON?
	TXOA	F,F.SCAN		;NO, ONLY SCANNING BY DEFAULT
	TXOA	F,F.PRIV		;YES, PRIVS!
	JRST	PEON			;NO, PEON TIME
	HRROI	T1,[ASCIZ/REAPER>/]	;INSURE NONPEON PROMPT
	MOVEM	T1,CMDBLK+.CMRTY
;Here after cleaning up after a bad error.
PANIC:	MOVEI	P,STACK-1		;GET A CLEAN STACK
	CALL	GCMD			;DO A COMMAND
	JRST	.-1			;DO ANOTHER COMMAND

GCMD:	SETZM	CURCMD			;NO COMMAND IN PROGRESS
GCMDP:	DMOVE	T1,[EXP CMDBLK,INIINB]	;DO THE COMMAND INIT
	CALL	PARSE			;PROMPT
	 JFCL				;SNH
	MOVEM	F,FLGTMP
	MOVEM	P,STKSAV		;SAVE STACK IN CASE REPARSE
	MOVEI	T1,RPSSTR
	MOVEM	T1,RPSSTK		;SAY NO REPARSE OPS NEED DOING YET
RPRS:	TXNN	F,F.PRIV		;PEON?
	JRST	[CALL	WHERE		;YES, WHERE IS INPUT FROM?
		 JRST	.+1		;FROM FILE, FINE
		 JRST	PENPAR]		;FROM TERMINAL, DO PEON PARSE
	DMOVE	T1,[EXP CMDBLK,CMDINB]
	CALL	PARSE			;PARSE A COMMAND
	 JRST	UKCERR			;UNKNOWN COMMAND
	MOVEM	T2,CURCMD		;STORE THE COMMAND INFO
	HRRZ	T1,(T2)
	JRST	(T1)
;Routine should RET (if all OK), BAKOUT (if failing or ABORTed),
; or NOCMD (if the parse didn't work alright).
UKCERR:	CALL	ANNERR			;SOME SORT OF ERROR COMING UP
	TYPE	[ASCIZ/?Not a defined command/]
NOCMD:	CALL	UNDO			;GET THINGS LEFT BY PARSING
	CALL	WHERE			;IF INPUT FROM PRIMARY..
	 CALL	UNTAKE			;DON'T UNDO TAKE FILES ON HIM
	MOVE	F,FLGTMP
	JRST	GCMDP

;Here if ^U or rubout
TRAPRP:	CALL	UNDO		;UNDO THE EFFECTS OF THE PARTIAL PARSE
GRPRS:	MOVE	F,FLGTMP	;RECOVER FLAGS BEFORE PARSE
	MOVE	P,STKSAV	;RESTORE THE STACK
	JRST	RPRS		;AND GO REPARSE

;Here if a command fails midstream or gets an ABORT.
BAKOUT:	CALL	WHERE		;IF INPUT FROM PRIMARY, DON'T HURT TAKES
	 CALL	UNTAKE		;TOSS ANY COMMAND FILES
	CALL	UNDO		;GET ANYTHING LEFT BY PARSING
	JRST	PANIC		;AND SET UP ANEW

;Peon code, done if not an enables wheel at startup time.  This forces a take
; on SYSTEM:REAPER.CMD if available, then forces the commands hardcoded in at
; PARTAB.
PEON:	MOVX	T1,GJ%SHT+GJ%OLD
	HRROI	T2,[ASCIZ/SYSTEM:REAPER.CMD/]
	GTJFN%
	 JSERRD	<Policy file not available>,DIENOW
	TYPE	[ASCIZ/ REAPER, reading policy file...
/]
	CALL	TAKE1		;IF IT'S THERE, TAKE IT
PEON1:	CALL	GCMD
	JRST	PEON1		;RUN UNTIL PAREOF GETS AN EOF

PEON2:	TYPE	CRLF		;PAREOF BRANCHES HERE FOR PEONS
	SETOM	PEOCNT		;SET UP FOR LIST OF IN-YOUR-BEHALF COMMANDS
PEOSET:	AOS	T3,PEOCNT	;GET OPERATION INDEX
	SKIPN	T3,PARTAB(T3)	;ANY SUCH OPERATION?
	JRST	DIENOW		;NO, DONE
	HLRO	T1,T3		;GET THE PROMPT
	MOVEM	T1,CMDBLK+.CMRTY ;SET UP PROMPT
	JRST	GCMD		;STEAL INIT CODE AT GCMD FOR THIS

PENPAR:	MOVE	T3,PEOCNT	;GCMD BRANCHES HERE FOR US. GET INDEX
	HRRZ	T1,PARTAB(T3)	;DETERMINE WHERE TO ENTER ROUTINE
	CALL	(T1)		;ENTER IT
	JRST	PEOSET		;DONE.  GO GET NEXT COMMAND

PARTAB:	[ASCIZ/ Output to: /],,LIST1
	[ASCIZ/ Check files: /],,ARCH1
	0
	SUBTTL	Interrupt stuff

CFINT:	SKIPN	CURDIR		; Processing a BEGIN command?
	DEBRK%
	DMOVEM	T1,INTTMP
	MOVEI	T1,.PRIOU
	DOBE%
	RFPOS%
	HRROI	T1,CRLF
	TRNE	T2,-1
	PSOUT%
CFINT2:	HRROI	T1,[ASCIZ/ Working on /]
	PSOUT%
	MOVX	T1,.PRIOU
	MOVE	T2,CURDIR
	DIRST%
	 ERJMP	.+1		;DOESN'T FAIL
	HRROI	T1,CRLF
	PSOUT%
	DMOVE	T1,INTTMP
	DEBRK%

LEVTAB:	BLOCK	2
	LVPC3

CFCHN==1

CHNTAB:	0			;0 Free
	3,,CFINT		;1 ^A
	0			;2-5 free
	0
	0
	0
	0			;6 Arith overflow
	0			;7 Float overflow
	0			;8 Reserved
	0			;9 PDL overflow
	0			;10 EOF
	0			;11 File Data error	.ICDAE
	0			;12 Disk full
	0			;13 Reserved
	0			;14 Reserved
	0			;15 Ill Inst
	0			;16 Ill mem read
	0			;17 Ill mem write
	0			;18 Reserved
	0			;19 Inferior stopped
	0			;20 Sys res exhausted
	0			;21 Reserved
	0			;22 Non existant page
	BLOCK	^D35-^D23+1	;23 Free, 23-35

CHNMSK:	1B<CFCHN>
	SUBTTL	Quick commands

.FLUSH:	GUIDES	<Of old offline files>
	MOVX	T1,F.FLSH
	JRST	ONFLAG

.INVOL:	GUIDES	<Old files to offline storage>
	MOVX	T1,F.INVL
	JRST	ONFLAG

.TAPE:	GUIDES	<Check of tapes in use>
	MOVX	T1,F.TAPE
	JRST	ONFLAG

.TRIM:	GUIDES	<Directories over allocation>
	MOVX	T1,F.TRIM
	JRST	ONFLAG

.PURGE:	GUIDES	<Expired FDBs from disk>
	MOVX	T1,F.PURG
	JRST	ONFLAG

.REAPE:	GUIDES	<Everything possible>
	MOVX	T1,F.PURG!F.TRIM!F.INVL!F.FLSH
	JRST	ONFLAG

.SCAN:	GUIDES	<Only>
	MOVX	T1,F.SCAN
ONFLAG:	CONFIRM
	IOR	F,T1
	RET

.PERIO:	GUIDES	<For migration>
	DMOVE	T1,[EXP CMDBLK,PERINB]
	CALL	PARSE
	 ERROR	<Bad Period>
	GUIDES	<Days>
	CONFIRM
	CAIGE	T2,0
	WARN	<Negative PERIOD values are usually meaningless>
	MOVEM	T2,PERIOD
	RET

.EXIT:	GUIDES	<To Monitor>
	CONFIRM
	HLLZ	T1,TAKSTK
	CAIE	T1,0
	WARN	<EXIT command encountered in TAKE file>
	HALTF%
	RET
.SKIP:	GUIDES	<Directories>
	MOVE	ITMSTK,DIRPTR
SKIP1:	DMOVE	T1,[EXP CMDBLK,SKPINB]
	CALL	PARSE
	 JRST	[HLLZ	T1,TAKSTK	;IN A TAKE FILE?
		 CAIN	T1,0		;NONZERO IF YES
		 ERROR	<Bad directory name in SKIP list> ;NO, DIE
		 WARN	<Bad directory name "> ;YES, LET'S TRY TO IGNORE IT
		 MOVEI	T1,[EXP ",", 0]
		 CALL	SKIPTR		;SKIP UNTIL COMMA
		 TYPE	ATOM		;SKIPTR LEAVES SKIPPED TEXT HERE
		 TYPE	[ASCIZ/" ignored/]
		 JUMPE	T3,SKIP2	;THIS WOULD IMPLY CONFIRMED
		 JRST	SKIP1]		;OTHERWISE, HIT A COMMA, GO ON
	MOVE	T3,T2
SKIP3:	MOVEM	T3,DIRS(ITMSTK)	; Save #
	AOBJP	ITMSTK,[WARN	<SKIP space full>
			JRST	SKIP2]
	MOVX	T1,RC%STP+RC%AWL
	HRROI	T2,ATOM
	RCDIR%
	 ERJMP	SKIP4
	TXNN	T1,RC%NOM+RC%AMB+RC%NMD
	JRST	SKIP3
SKIP4:	DMOVE	T1,[EXP CMDBLK,CMCINB]
	CALL	PARSE
	 ERROR	<Bad syntax in SKIP command>
	CAIE	T3,.CMCFM	;Confirm?
	JRST	SKIP1
SKIP2:	SETZM	DIRS(ITMSTK)
	MOVEM	ITMSTK,DIRPTR
;**; [302] At SKIP2:+2L Add 1 line	SM	20-Dec-85
	HRLZM	ITMSTK,SKPCNT	; [302] Save count in LH of SKPCNT
	RET

.ORDER:	GUIDES	<For trimming>
	MOVE	ITMSTK,JFNPTR	; Free space
ORDER1:	SETO	T1,		; Parse only pls
	CALL	GETFIL
	 ERROR	<Bad filespec in ORDER list>
	MOVEM	T2,(ITMSTK)	; Save JFN
	CALL	RPSJFN
	AOBJP ITMSTK,[
		WARN	<ORDER space is full>
		JRST	ORDER2]
	DMOVE	T1,[EXP CMDBLK, CMCINB]
	CALL	PARSE
	 ERROR	<Bad syntax in ORDER command>  ; Garbage
	CAIE	T3,.CMCFM
	JRST	ORDER1
ORDER2:	SETZM	(ITMSTK)
	MOVEM	ITMSTK,JFNPTR	; Cover stack
	TXO	F,F.ORDR	;SYSTEM ORDER LIST IN
	RET

.LIST:	GUIDES	<Output to file>
	HRROI	T1,[ASCIZ/REAPER.LIST/]
	TXNN	F,F.PRIV
LIST1:	HRROI	T1,[ASCIZ/TTY:/]
	MOVEM	T1,LISINB+.CMDEF
	DMOVE	T1,[EXP CMDBLK,LISINB]
	CALL	PARSE
	 ERROR	<Bad filespec in LIST Command>
	CALL	RPSJFN
	CONFIRM
	HRRZ	T1,T2
	MOVX	T2,<FLD(7,OF%BSZ)+OF%WR>
	OPENF%
	 JSERRD	<Can't open LIST file>
	EXCH	T1,LSTJFN
	CAIE	T1,0
	CLOSF%
	 JFCL
	RET
	SUBTTL	BEGIN command
.ARCHI:	TXNN	F,F.PRIV	; Allowed?
	RET		; Not really, just ignore the command
	GUIDES	<Processing files>
	SETZ	T1,		; Real JFNs
ARCH1:	CALL	GETFIL		; Get a file spec
	 ERROR	<Bad file specification>
	CONFIRM
	MOVEM	T2,ARCJFN		; Path to check
	GTAD%
	HLRZM	T1,TODAY
	SETZM	DIRCNT
	TXNE	F,F.PRIV
	TXNE	F,F.TRIM
	JRST	NOPERW
	SKIPN	PERIOD
	WARN	<No period specified, continuing...>
; Get a directory number so we can step with RCDIR
NOPERW:	HRROI	T1,DIRWLD		; Area for string with wildcards
	MOVX	T3,<FLD(.JSAOF,JS%DEV)+FLD(.JSAOF,JS%DIR)+JS%PAF>
	JFNS%			; Get STR:<DIR>
	MOVX	T1,RC%AWL		; Allow wildcards
	HRROI	T2,DIRWLD		; Point to directory string
	SETZ	T3,		; No previous dir #
	RCDIR%			; Get a dir #
	TXNE	T1,RC%NOM		; No match???
	 ERROR <Failed to translate string to directory number>
	MOVEM	T3,CURDIR		; Save the result
	HRROI	T1,FILPTH		; Area for complete filespec
	MOVE	T2,ARCJFN
	MOVX	T3,JFNSAL
	JFNS%

; Set up default strings for name and extension

	HRROI	T1,DEFNAM		; Area for name string
	MOVX	T3,<FLD(.JSAOF,JS%NAM)>
	JFNS%			; Get the name specified
	HRROI	T1,DEFEXT		; Area for extension string
	MOVX	T3,<FLD(.JSAOF,JS%TYP)>
	JFNS%			; Get the extension
	MOVE	T1,T2		; JFN to T1
	RLJFN%			; No longer need this
	 JFCL

	CALL	MLINIT		; Init stuff for sending mail
; Put in the listing file to describe what we were told to do

	SKIPN T1,LSTJFN		; Have a listing file?
	JRST [	MOVX	T1,GJ%FOU+GJ%SHT
		HRROI	T2,[ASCIZ /REAPER.LIST/]
		GTJFN%
		 JSERRD	<Can't create list file>
		MOVE	T2,T1
		CALL	RPSJFN
		HRRZ	T1,T2
		MOVX	T2,<FLD(7,OF%BSZ)+OF%WR>
		OPENF%
		 JSERRD	<Can't create list file>
		MOVEM	T1,LSTJFN	; Save it
		JRST	.+1]
	SELECT	LS.LST
	TYPE	[ASCIZ /
 REAPER run started at /]
	CALL	TADOUT
	TYPE	CRLF2
	TYPE	[ASCIZ / Specified file path: /]
	TYPE	FILPTH
	TXNN	F,F.PRIV
	JRST	[TYPE	[ASCIZ /
 The following would happen if the OPERATOR ran REAPER now:

/]
		JRST STAT9]
	TYPE	CRLF
	SKIPN	T2,PERIOD		; Any period given to us?
	JRST	STAT0		; No
	TYPE	[ASCIZ / Period is: /]
	CALL	DECOUT
	TYPE	[ASCIZ / days
/]
STAT0:	TXNE	F,F.SCAN
	TYPE	[ASCIZ / SCAN ONLY
/]
	TXNE	F,F.FLSH
	TYPE	[ASCIZ / Deleting disk contents of old offline files
/]
	TXNE	F,F.PURG
	TYPE	[ASCIZ / Purging expired offline files
/]
	TXNN	F,F.TRIM		; Triming directories?
	JRST	STAT1		; No, skip that
	TYPE	[ASCIZ / Trimming directories over permanent allocation
 Order during TRIM for taking files is: /]
	TXNN	F,F.ORDR
	JRST	[TYPE	[ASCIZ/Not specified
/]
		 JRST	STAT1]
	MOVE	ITMSTK,[-NJFNS,,JFNLST] ;Where things needing printing live
	MOVEI	T4,TYJFNF	;Routine to call to output an element
	MOVX	T3,JFNSNX
	CALL	PRTORD		; Print it
STAT1:	TYPE	[ASCIZ / Skipping directories: /]
	SKIPN	DIRS		; Any spec'd?
	JRST [	TYPE	[ASCIZ / None specified
/]
		JRST	STAT9]
	MOVE	ITMSTK,[-NDIRS,,DIRS]
	MOVEI	T4,TYDIRS
	CALL	PRTORD	; Listing is started, now start processing
STAT9:	TXZ	F,F.NDIR		; New directory
DODIR:	CALL	CHKDIR		; Make sure of good directory
	 JRST	ENDARC		; That's the last of them
	SETZ	DIRPGS,		; No pages collected yet
	SETO	T1,
	CALL	SETGTD		; Set up the block
	MOVE	T1,[.NULIO,,.NULIO]
	MOVEM	T1,GTJBLK+.GJSRC
	HRROI	T1,STRING		; Scratch area
	MOVE	T2,CURDIR		; Dir we are working on
	DIRST%			; Get the string
	 JSERRD	<DIRST failure>
	MOVE	T1,[POINT 7,STRING]
	MOVE	T2,[POINT 7,DEFDEV]	; Make structure name
	MOVEM	T2,GTJBLK+.GJDEV
DODIR1:	ILDB	T3,T1
	CAIN	T3,":"
	SETZ	T3,
	IDPB	T3,T2
	JUMPN	T3,DODIR1
DODIR2:	IBP	T1		; Flush "<"
	MOVE	T2,[POINT 7,DEFDIR]	; Make directory name
	MOVEM	T2,GTJBLK+.GJDIR
DODIR3:	ILDB	T3,T1
	CAIN	T3,">"
	SETZ	T3,
	IDPB	T3,T2
	JUMPN	T3,DODIR3
	TXNE	F,F.TRIM	;GOING TO TRIM BACK THE DIRECTORY?
	CALL 	GETORD		;YES, GET ANY USER ORDER
	HRROI	T1,DEFNAM
	MOVEM	T1,GTJBLK+.GJNAM
	HRROI	T1,DEFEXT
	MOVEM	T1,GTJBLK+.GJEXT
DOFIL:	SETZM	FILPTR		; Reset count of entries in DONEFL

	CALL	DOKEEP		; Touch files WE want around
	CALL	DOPERI		; Migrate old files
	CALL	DOFLSH		; Delete contents of old archive files
	CALL	DOMISC		; Delete old temp files, etc.
	CALL	DOTRIM		; Trim directory back to quota
	CALL	DOTAPE		; Check tapes reference by this directory

	AOS	T1,DIRCNT
	TRNE	T1,17		;CHECKPOINT EVERY 16 DIRECTORIES
	JRST	NXTDIR		;NOT YET
	MOVE	T1,LSTJFN
	TXO	T1,CO%NRJ
	CLOSF%			;CLOSE LISTING FILE, BUT KEEP JFN
	 ERJMP	.+2
	CALL	OPNLST
	 JRST	[SELECT	LS.TTY
		 WARN	<List file didn't reopen>
		 JRST	NXTDIR]
NXTDIR:	CALL	INCDIR
	 JRST	ENDARC
	JRST	DODIR		; Loop

INCDIR:	MOVX	T1,RC%STP+RC%AWL	; Gotta go to next directory
	HRROI	T2,DIRWLD		; Point to wildcard string
	MOVE	T3,CURDIR		; Current dir #
	RCDIR%				; Find next one
	 ERJMP	CPOPJ
	TXNE	T1,RC%NMD		; No more dirs?
	RET
	MOVEM	T3,CURDIR		; Remember new dir #
	TXZ	F,F.NDIR		; New directory
	MOVE	ITMSTK,JFNPTR
	CALL	RLJFNS		; Release any user ORDER JFNs
	JRST	CPOPJ1

; Check CURDIR to see if SKIPping this directory; if so, advance
; to one we aren't SKIPping
CHKDIR:	SKIPN	DIRS		; Skipping anything?
	JRST	CPOPJ1
	MOVE	T3,CURDIR	; Get current dir #
;**; [302] At CHKDIR:+3L Replace 1 line		SM	20-Dec-85
	MOVN	T1,SKPCNT	;[302] Get -count,,0 of skippable directories
CHKDI1:	CAME	T3,DIRS(T1)	; Skip this guy?
	AOBJN	T1,CHKDI1	; Loop
	JUMPGE	T1,CPOPJ1	; Done, no match
CHKDI2:	CALL	INCDIR		; To next directory
	 RET			; No next
	JRST	CHKDIR		; Check this one too

ENDARC:	TYPE	CRLF2
	SETZ	Q2,
LSTTTL:	HLRZ	Q1,LSTTAB(Q2)
	JUMPE	Q1,ENDAR1
	MOVE	T2,(Q1)
	TYPCHR	" "
	CALL	DESOUT
	HRRO	T1,LSTTAB(Q2)
	TYPEAT	T1
	MOVEI	T2,^D40
	CALL	TABOUT
	MOVE	T2,1(Q1)
	CALL	DESOUT
	TYPE	[ASCIZ/ pages
/]
	AOJA	Q2,LSTTTL
ENDAR1:	SKIPE	EXPHIT		; Did any tapes get noted?
	CALL	DMPTAP		; Yes, dump out the info now
ENDAR2:	MOVE	T1,LSTJFN
	CLOSF%			; Close the listing file
	 JFCL
	SETZM	LSTJFN		; No longer valid
	CALL	MLDONE		; Clean up mail stuff
	MOVE	ITMSTK,[-NJFNS,,JFNLST]
	CALL	RLJFNS
DIENOW:	HALTF%
	JRST	START

DMPTAP:	SETOM	LSTLIN		; Start a new page
	TYPE	[ASCIZ/
Tape ID   Count		Tape ID   Count		Tape ID   Count
/]
	SETZM	COLTMP		;Start in column 1, please
	MOVEI	T3,TAPCNT	; Beginning of the tree
CHASE:	PUSH	P,T1
CHASE1:	MOVE	T1,T3
	HRRZ	T3,PTAP(T3)
	CAIE	T3,0
	CALL	CHASE
	CALL	DOOP		;Do for each element in the tree
	MOVE	T3,T1
	HLRZ	T3,PTAP(T3)
	CAIE	T3,0
	JRST	CHASE1		;TAIL RECURSION, JUST LIKE CALL CHASE
	POP	P,T1
	RET

DOOP:	PUSH	P,T1
	MOVE	T2,TNAM(T1)
	TLNE	T2,-1		;SIXBIT OT NUMERIC?
	JRST	[MOVE	T3,T2
		 CALL	SIXOUT
		 JRST	DOOP1]
	MOVE	T3,[NO%OOV+NO%MAG+NO%LFL+7B17+^D10]
	CALL	NUMOUT
DOOP1:	MOVE	T2,COLTMP
	MOVE	T2,[DEC 10,34,58](T2)
	CALL	TABOUT		;..
	MOVE	T1,(P)		;POINTER TO BLOCK CONTAINING INFO
	MOVE	T2,TCNT(T1)	;GET THE COUNT
	CALL	DESOUT		;OUTPUT
	AOS	T2,COLTMP
	SKIPN	T2,[DEC 24,48,0]-1(T2)
	JRST	[SETZM	COLTMP	;YES
		 TYPE	CRLF
		 JRST	DOOP2]
	CALL	TABOUT
DOOP2:	POP	P,T1		;RESTORE T1
	RET

;LH address of a pair of words, the first is typed before the RH text, the
; 2nd after it.
LSTTAB:	NFILES,,[ASCIZ /	files marked for migration/]
	NFLFIL,,[ASCIZ /	archive files deleted from disk/]
	NTMFIL,,[ASCIZ /	temporary files deleted/]
	NPURGE,,[ASCIZ /	expired files purged/]
	0
; Period checker

DOPERI:	TXNN	F,F.INVL		; Switch for this turned on?
	RET			; No
	MOVX	T1,GJ%IFG+GJ%XTN+.GJALL
	MOVEM	T1,GTJBLK+.GJGEN	; Fix up GTJFN bits
	MOVEI	T1,GTJBLK
	SETZ	T2,		; As if the user took default
	GTJFN%
	 RET			; Done, none here
	MOVEM	T1,LOCJFN	; Save the JFN
DOPER1:	CALL	GTFDBF		;GET FDB INFORMATION
	MOVE	T1,FDB+.FBCTL
	TXNE	T1,FB%ARC!FB%OFF!FB%DIR!FB%NOD!FB%TMP!FB%PRM
	JRST	DOPER9		; Go to next file
	MOVE	T1,FDB+.FBBBT
	TXNE	T1,AR%RAR!AR%RIV!AR%NAR!AR%EXM ; If requested or resist, skip it
	JRST	DOPER9
	CALL	HAVTAP		; See if we have tape ID's already
	 JRST	DOPER9		; We do, don't migrate the file again

; Check to see if online expiration has occured

 IFN FTONEX,<
	SKIPN T2,FDB+.FBNET	; Have on online expiration?
	JRST DOPER3		; No, file can't expire then
	HLRZS T2		; Want date portion of online exp
	CAML T2,TODAY
	JRST DOPER3		; No (& does have exp. date)
	JUMPN T2,DOPER5		; Expired date if non-zero--take it
	MOVE T1,FDB+.FBCRE	; Interval, find most recent date
	CAMG T1,FDB+.FBCRV
	MOVE T1,FDB+.FBCRV
	CAMG T1,FDB+.FBWRT
	MOVE T1,FDB+.FBWRT
	CAMG T1,FDB+.FBREF
	MOVE T1,FDB+.FBREF
	HRRZ T2,FDB+.FBNET	; Get the interval
	HLRZS T1
	ADD T2,T1		; Form expiration date
	CAML T2,TODAY
	JRST DOPER3		; No, check for age
DOPER5:	SETO T2,		; Flag file is expired
	JRST DOPER2
> ; End IFN FTONEX

; Now check for too old a file

DOPER3:	SKIPG	PERIOD		; Have a real period?
	JRST	DOPER9		; No, skip this then
	CALL	GTAGE		; Get age of file
	CAMGE	T2,PERIOD		; Old enough?
	JRST	DOPER9		; No, skip it
DOPER2:	CALL	CKDNFL		; Has this one been done before?
	 JRST	DOPER9		; Yes, skip it this time
	MOVEM	T2,AGEIS
	HRRZ	T1,LOCJFN
	MOVEI	T2,.ARRIV		; Request file be migrated
	MOVEI	T3,.ARSET
	TXNN	F,F.SCAN	; Only a scan?
	ARCF%			; No, real thing
	 ERJMP [HRROI T2,[ASCIZ / ARCF failed/]
		CALL	LSTFIL
		JRST	DOPER9]
	HRRZ	T1,FDB+.FBBYV
	ADD	DIRPGS,T1		; Accum what we've taken
	ADDM	T1,TOTPGS		; Into running total
	AOS	NFILES		; Count files
	HRROI	T2,STRING
	MOVE	T1,AGEIS	;fetch age again
 IFN FTONEX,<
	JUMPL	T1,[
		HRROI	T1,[ASCIZ /Online expiration reached/]
		JRST DOPER4]
>; end IFN FTONEX
	CALL	NOUTB
	HRROI	T1,[ASCIZ / days old/]
DOPER4:	CALL	CSTR
	HRROI	T2,STRING
	CALL	LSTFIL		; Into listing
DOPER9:	MOVE	T1,LOCJFN
	GNJFN%
	 JRST [	SETZM	LOCJFN
		RET]
	JRST	DOPER1
; Flush contents of OLD online files with tape backup
DOFLSH:	TXNE	F,F.FLSH
	SKIPN	PERIOD
	 RET
	MOVX	T1,GJ%IFG+GJ%XTN+.GJALL
	MOVEM	T1,GTJBLK+.GJGEN
	MOVEI	T1,GTJBLK
	SETZ	T2,		; Take default
	GTJFN%
	 RET			; No files to do
	MOVEM	T1,LOCJFN		; Save the JFN
	HRROI	T1,[ASCIZ /Old file contents deleted from disk/]
	MOVX	T2,.MLOFL		; Use the offline msg file
	CALL	BEGUSR		; Start user message
DOFLS1:	CALL	GTFDBF
	MOVE	T1,FDB+.FBCTL
	TXNE	T1,FB%OFF		; Already off-line?
	JRST	DOFLS9		; Yes, skip it
	SKIPE	TAPBLK+.ARTP1	; First tape exist?
	SKIPN	TAPBLK+.ARTP2	; AND 2nd? (HAVTAP is OR not AND)
	 JRST	DOFLS9		; Both tapes don't exist yet
	CALL	GTAGE		; Get its age
	CAMGE	T2,PERIOD		; Old enough?
	JRST	DOFLS9		; No, skip the file
	MOVEM	T2,AGEIS		; Save the age
	TXNE	F,F.SCAN
	JRST	DOFLS2
	MOVX	T1,DF%CNO+DF%NRJ	; Disk contents only
	HRR	T1,LOCJFN
	DELF%			; No, real thing
	 JRST [	HRROI	T2,[ASCIZ / DELF failed/]
		CALL	LSTFIL
		JRST	DOFLS9]
DOFLS2:	HRROI	T1,[ASCIZ / - Disk contents deleted/]
	CALL	TOUSR		; Include in the message
	AOS	NFLFIL
	HRRZ	T1,FDB+.FBBYV	; Get # of pages
	ADD	DIRPGS,T1
	ADDM	T1,FLPGS		; To total
	HRROI	T1,[ASCIZ / Disk contents deleted, /]
	HRROI	T2,STRING
	CALL	CSTRB
	MOVE	T1,AGEIS
	CALL	NOUTB
	HRROI	T1,[ASCIZ / days old/]
	CALL	CSTR
	HRROI	T2,STRING
	CALL	LSTFIL
DOFLS9:	MOVE	T1,LOCJFN
	GNJFN%
	 JRST [	SETZM	LOCJFN	; Done JFN is garbage
		JRST	ENDUSR]	; End the message
	JRST	DOFLS1
; Here to touch various files that shouldn't get migrated...

DOKEEP:	TXNE	F,F.SCAN
	 RET				;SCANNING, IGNORE THIS
	MOVX	T1,GJ%OLD+GJ%XTN	; All files must exist
	MOVEM	T1,GTJBLK+.GJGEN
	MOVX	T1,G1%IIN
	MOVEM	T1,GTJBLK+.GJF2

	HRROI	T2,[ASCIZ /DIRECTORY.OWNER/]
	CALL	DOKEP1
	HRROI	T2,[ASCIZ /MAIL.TXT.1/]
	CALL	DOKEP1
	HRROI	T2,[ASCIZ /OFFLINE-FILE-MSGS.TXT/]
	;JRST	DOKEP1

DOKEP1:	MOVE	T1,[.NULIO,,.NULIO]
	MOVEM	T1,GTJBLK+.GJSRC
	MOVEI	T1,GTJBLK
	GTJFN%
	 RET			; File doesn't exist
	MOVEM	T1,TMP		; Save the JFN
	MOVE	T2,[1,,.FBBBT]	;Get archival flags
	MOVEI	T3,T4		;into T4
	GTFDB%
	TXNE	T4,AR%EXM	;is it already migrate proof?
	JRST	DOKEP2		;yes.  It's safe.  Go on.
	MOVX	T2,.AREXM	;Set prohibit migration
	MOVX	T3,.ARSET	; This disturbs the access date, but should
	ARCF%			; only happen once.
	 ERJMP DOKEP2		;shouldn't happen
DOKEP2:	MOVE	T1,TMP		;done, lose jfn
	RLJFN%
	 JFCL
	RET
; Trim directory back to size

DOTRIM:	TXNN	F,F.TRIM
	 RET			; We weren't told to do this
	MOVX	T1,GJ%IFG+GJ%XTN+.GJALL
	MOVEM	T1,GTJBLK+.GJGEN
	MOVE	T1,CURDIR		; Get current directory #
	GTDAL%
	SUB	T2,T3		; Pages they are over
	SUB	T2,DIRPGS		; And those already stolen
	JUMPLE	T2,CPOPJ		; Done if under allocation
	TXON	F,F.NDIR		; Need to print directory name?
	CALL	LSTDIR		; Yes, do that
	MOVE	DIRPGS,T2		; Those required from user
	TYPE	[ASCIZ / Collecting /]
	MOVE	T2,DIRPGS
	CALL	DECOUT
	TYPE	[ASCIZ / pages

/]
	MOVE	ITMSTK,JFNSTP	; Get pointer to ORDER list
	TXZ	F,F.TRES	; Leave RESIST's (AR%NAR) if possible
DOTRI1:	SKIPN	T2,(ITMSTK)	; Anything?
	JRST	DOTRI2		; No, go to next phase
	CALL	DOTRM		; Do the work
	 JRST	DOTRIX		; Done
	AOBJN	ITMSTK,DOTRI1
DOTRI2:	HRROI	T2,[ASCIZ /*.*.*/]
	CALL	DOTRMS
	 JRST	DOTRIX		; Done, enough collected
	MOVE	ITMSTK,JFNSTP	; Current ORDER list
	TXO	F,F.TRES	; Take RESIST's if necessary
DOTRI3:	SKIPN	T2,(ITMSTK)	; Any there?
	JRST	DOTRI4		; No, done
	CALL	DOTRM
	 JRST	DOTRIX		; Done, enough pages collected
	AOBJN	ITMSTK,DOTRI3
DOTRI4:	HRROI	T2,[ASCIZ /*.*.*/]
	CALL	DOTRMS
	 JRST	DOTRIX		; Got all we needed
DOTRIX:	JUMPLE	DIRPGS,CPOPJ		; Leave
	TXON	F,F.NDIR		; Make sure we said what directory
	CALL	LSTDIR		; We didn't yet, do it now
	TYPE	[ASCIZ / Still over allocation by /]
	MOVE	T2,DIRPGS
	CALL	DECOUT
	TYPE	[ASCIZ / pages
/]
	RET

; Do actual work; Expects T2 to have JFN of files to consider (ORDER)

DOTRM:	HRROI	T1,STRING
	MOVX	T3,<FLD(.JSAOF,JS%NAM)+FLD(.JSAOF,JS%TYP)+JS%PAF>
	JFNS%			; Default name string
	HRROI	T2,STRING		; Point to default string

; Enter here with a string pointer in AC2 (also fallen into from DOTRM)

DOTRMS:	MOVEI	T1,GTJBLK		; Enter here with string
	GTJFN%
	 JRST	CPOPJ1		; Done, none of correct flavor
	MOVEM	T1,LOCJFN		; Save the local JFN
DOTRM1:	TXZ	F,F.PEND		; No archive pending on this file
	CALL	GTFDBF		; Get FDB
	TXNE	F,F.TRES	; Interested in resisting files?
	JRST	DOTRM4		; Yes - try to take it
	MOVE	T3,FDB+.FBBBT
	TXNE	T3,AR%NAR	; No. Is this a Resisting file?
	JRST	DOTRM9		; Yes. Skip it this time
DOTRM4:	CALL	CKDNFL		; Check if file already done
	 JRST	DOTRM9		; Yes, don't do it again
	MOVE	T3,FDB+.FBBBT
	TXNE	T3,AR%RAR!AR%RIV	; Archive already pending?
	JRST [	TXNE	T3,AR%NDL	; Will we get any pages of it?
		JRST	DOTRM9	; No, skip the file
		TXO	F,F.PEND	; Yes, flag archive already pending
		JRST	DOTRM8]	; And enter further down the line
	MOVE	T2,FDB+.FBCTL
	TXNN	T3,AR%EXM		; Not allowed to migrate it?
	TXNE	T2,FB%ARC!FB%OFF!FB%DIR!FB%TMP!FB%PRM
	JRST	DOTRM9		; Skip it
	CALL	HAVTAP		; Already have tape backup?
	 JRST	DOTRM9		; Yes, skip the file
	HRRZ	T1,LOCJFN
	MOVX	T2,.ARRIV		; Migrate it
	MOVEI	T3,.ARSET
	TXNN	F,F.SCAN		; Only a scan?
	ARCF%			; No, real
	 ERJMP [HRROI	T2,[ASCIZ / ARCF failed/]
		CALL	LSTFIL
		JRST	DOTRM9]
DOTRM8:	HRRZ	T2,FDB+.FBBYV	; Get # of pages we got back
	SUB	DIRPGS,T2
	TXNN	F,F.PEND		; Actually mark it?
	ADDM	T2,TOTPGS		; Yes, add to total pages
	AOS	NFILES		; And count the files
	MOVE	T1,T2
	HRROI	T2,STRING
	CALL	NOUTB
	HRROI	T1,[ASCIZ / pages claimed/]
	TXNE	F,F.PEND		; Was archive already pending?
	HRROI	T1,[ASCIZ / migration already pending/]
	CALL	CSTR
	HRROI	T2,STRING
	CALL	LSTFIL		; Into listing
DOTRM9:	JUMPLE	DIRPGS,DOTRMD	; Done, end up things
	MOVE	T1,LOCJFN
	GNJFN%
	 JRST	CPOPJ1
	JRST	DOTRM1		; Around for more

DOTRMD:	HRRZ	T1,LOCJFN
	RLJFN%
	 JFCL
	SETZM	LOCJFN
	RET			; Signal directory done
; Do miscellaneous operations  -- delete old temp files,
; expunge FDBs which are past offline expiration.

DOMISC:	TXNN	F,F.PURG	;PURGING?
	RET			;NO, NO MISC FUNCTIONS NEED DOING
	MOVX	T1,GJ%IFG+GJ%XTN+.GJALL
	MOVEM	T1,GTJBLK+.GJGEN
	MOVEI	T1,GTJBLK		; Get defaults
	SETZ	T2,			; Use them
	GTJFN%
	 RET			; Nothing to do
	MOVEM	T1,LOCJFN		; Save local JFN
	HRROI	T1,[ASCIZ /Offline expired files/]
	MOVX	T2,.MLNFL		; Don't send to offline msg file
	CALL	BEGUSR		; Start a message
DOMSC1:	CALL	GTFDBF
	MOVE	T1,FDB+.FBCTL	; Get ctl bits
	TXNE	T1,FB%TMP	; Temp file?
	JRST	DOTMP		; Delete it if too old
	JRST	DOFET		; Yes, check offline expiration

DOADVA:	MOVE	T1,LOCJFN
	GNJFN%
	 SETZM	LOCJFN
ENDMSC:	SKIPE	LOCJFN
	JRST	DOMSC1
	JRST	ENDUSR		; Finish up and return
; Check offline file to see if it has reached offline expiration.
; If so, expunge it.

DOFET:	TXNN	F,F.PURG		; Purge expired FDBs?
	JRST	DOADVA		; No, done here
	LDB	T1,[POINT 7,FDB+.FBHDR,35]
	CAIGE	T1,.FBLXT		; Long enough?
	JRST	DOADVA		; No, skip this file
	SKIPN	FDB+.FBTP1	; Have any tape info?
	SKIPE	FDB+.FBTP2
	SKIPA	T1,FDB+.FBFET
	JRST	DOADVA		; Has none, skip this file
	TLNN	T1,-1		; Which is it?
	JRST [	HRLZS	T1	; Make # days,,0
		ADD	T1,FDB+.FBTDT ; Date when will be expired
		JRST	.+1]
	HLRZS	T1
	CAML	T1,TODAY
	JRST	DOFET2
	MOVE	T1,FDB+.FBBBT
	TXNN	T1,AR%WRN		; User been warned about this?
	JRST	DOFET3		; No, do so now
	CALL	JOJAR		; try to get (in T1) and advance jfn
	MOVE	T2,FDB+.FBCTL	;GET FLAGS ON THIS FILE
	TXNN	T2,FB%OFF	;OFFLINE?
	JRST	DOFETD		;YES. GO DISCARD TAPE BACKUP INFO
;**;[305] Change 1 line and add 5 at DOFET:+23L		DEE	10-APR-87
	TXNN	F,F.SCAN	;[305] Just SCANning?
	IFSKP.			;[305]			
	 RLJFN%			;[305] Yes, release the JFN now
	  ERJMP .+1		;[305]
	 JRST 	DOFETA		;[305] And don't DELF%
	ENDIF.			;[305]
;**;[306] Change 1 line at DOFET:+30L			DEE	22-APR-88
	TXO	T1,DF%EXP+DF%ARC+DF%NRJ ;[306]
	DELF%
	 JRST	DELERR
;**;[306] Rework DOFETA:				DEE	22-APR-88
DOFETA:	AOS	NPURGE
	PUSH 	P,LOCJFN	;[306] Save stepping JFN
	HRRZM	T1,LOCJFN	;[306] Move TMP to LOCJFN
	HRROI	T2,[ASCIZ / Expunged, offline expiration reached/]
	CALL	LSTFIL
	HRROI	T1,[ASCIZ / - File deleted and expunged (expired)/]
	CALL	TOUSR
	MOVE 	T1,TMP		;[306]Get back TMP JFN
	RLJFN%			;[306] Release it
	 JFCL			;[306]
	POP 	P,LOCJFN	;[306] Get back stepping JFN
	JRST	ENDMSC
DOFET2:	MOVE	T3,FDB+.FBBBT
	TXNE	T3,AR%WRN		; Been warned?
	JRST	DOADVA		; Yes, don't do it again
	SUBI	T1,PERWRN	; Make it look later than it is
	CAML	T1,TODAY		; Now is it expired?
	JRST	DOADVA		; No, on to the next file
DOFET3:	HRRZ	T1,LOCJFN
	HRLI	T1,.FBBBT		; Set the warning flag
	MOVX	T2,AR%WRN
	MOVE	T3,T2
	TXNN	F,F.SCAN		; Don't if only a listing
	CHFDB%
	HRROI	T1,[ASCIZ / - Offline expiration approaching/]
	CALL	TOUSR		; Put this in the msg
	JRST	DOADVA		; And go on

DOFETD:	MOVX	T2,.ARDIS		; Discard tape info
	MOVX	T3,AR%CR1+AR%CR2	; Clear both sets of tape info
	TXNN	F,F.SCAN		; Don't if only a listing
	ARCF%
	 ERJMP [HRROI	T2,[ASCIZ/ ARCF discard failure/]
		JRST	OPERR]
	HRROI	T2,[ASCIZ / Tape backup information discarded/]
	CALL	LSTFIL
	HRROI	T1,[ASCIZ / - Tape backup information discarded (expired)/]
	CALL	TOUSR
	MOVE	T1,TMP
	RLJFN%			; 2nd JFN no longer needed
	 JFCL
	JRST	ENDMSC
;JFN the file pointed to by LOCJFN, and advance LOCJFN. Returns GOTNAM
; containing the filename to operate on, T1/ jfn on that file, and
; F.GOTN on (for subsequent LSTFIL calls).
JOJAR:	HRROI	T1,GOTNAM
	HRRZ	T2,LOCJFN
	MOVX	T3,JFNSAL
	JFNS%
;**;[304]Add 1 line at JOJAR:+4L		DEE	10-APR-87
;**;[306] Change one line at JOJAR:+4L		DEE	22-APR-88
 	  ERJMP [TYPE [ASCIZ /JFNS% failure...continuing...
/]
	  RET]			;[306]
	TXO	F,F.GOTN	;LSTFIL please use this name
	MOVE	T1,LOCJFN
	GNJFN%
	 SETZM	LOCJFN
	MOVX	T1,GJ%IFG+GJ%XTN+GJ%DEL
	MOVEM	T1,GTJBLK+.GJGEN
	MOVEI	T1,GTJBLK
	HRROI	T2,GOTNAM
	GTJFN%
	 JSERRD	<2nd JFN failure>,DIENOW
	HRRZS	T1
	MOVEM	T1,TMP
	RET

;Release the JFN stored by JOJAR, and report a failed operation
DELERR:	HRROI	T2,[ASCIZ / DELF failed/]
OPERR:	MOVE	T1,TMP
	RLJFN%
	 JFCL
	CALL	LSTFIL
	JRST	ENDMSC

BEGUSR:	TXNE	F,F.SCAN
	RET			; Scan only, don't do message
	MOVEM	T2,MAILFL		; Save flag handed us
	MOVEM	T1,MLBLK+1	; Remember the subject
CONUSR:	MOVE	T1,CURDIR	;[303] Add label
	MOVEM	T1,MLBLK+0	; Save directory #
	MOVE	T1,[POINT 7,MSGSPC]
	MOVEM	T1,MSGPTR
	MOVEM	T1,MLBLK+2	; Text field
	RET			; All set up

ENDUSR:	TXNE	F,F.SCAN
	RET			; Don't if scan only
	MOVE	T2,MSGPTR
	CAMN	T2,[POINT 7,MSGSPC] ; Have anything for the user?
	RET			; No, don't bother sending then
EN2USR:	HRROI	T1,CRLF		;[303] Add label
	CALL	CSTR
	MOVEI	T1,MLBLK
	MOVE	T2,MAILFL	; Pick up flag type user wanted
	JRST	MLTOWN		; Mail to owner of the files

TOUSR:	TXNE	F,F.SCAN
	RET			; Don't if scan only
	PUSH	P,T1		; Save comment line
;**;[304] Add 2 lines and change 1 at TOUSR:+3L		DEE	10-APR-87
;**;[306] Delete 2 lines and change 1 at TOUSR:+3L	DEE	22-APR-88
	MOVE	T1,MSGPTR
	HRRZ	T2,LOCJFN
	MOVX	T3,JFNSAL
	JFNS%
;**;[304] Add 1 line at TOUSR:+9L		DEE	10-APR-87
;**;[306] Change one line at TOUSR:+9L		DEE	22-APR-88
 	  ERJMP [TYPE [ASCIZ /JFNS% failure...continuing...
/]
	  RET]			;[306]
	MOVE	T2,T1
	POP	P,T1		; Comment line
	TLNE	T1,-1		; Look like a string ptr?
	CALL	CSTRB
	HRROI	T1,CRLF
	CALL	CSTRB
	MOVEM	T2,MSGPTR
;**; [303] At DOTMP-4L, Replace 1 line with 5	SM	 3-Jan-86
	MOVEI	T3,-MSGSPC(T2)	;[303] GET SIZE OF STRING
	CAIGE	T3,MSGSIZ-60	;[303] GETTING NEAR THE END?
	RET			;[303] NO, PLENTY ROOM, NOT TO WORRY
	CALL	EN2USR		;[303] FULL UP. DUMP WHAT WE HAVE..
	JRST	CONUSR		;[303] SET UP FOR MORE, AND THEN RETURN

; Delete temporary files PERIOD days old.

DOTMP:	SKIPN	PERIOD		; Period specified?
	JRST	DOADVA		; No, nothing to do
	CALL	GTAGE
	CAMGE	T2,PERIOD		; File old enough?
	JRST	DOADVA		; No, skip it
	MOVEM	T2,AGEIS
	CALL	JOJAR
;**;[305] Change 1 line and add 5 at DOTMP:+7L		DEE	10-APR-87
	TXNN	F,F.SCAN	;[305]just scanning?
	IFSKP.			;[305]
	 RLJFN%			;[305] Yup - better release the JFN now
	  ERJMP .+1		;[305]
	 JRST DOTMP1		;[305] And skip the DELF%
	ENDIF.			;[305]
	TXO	T1,DF%EXP
	DELF%			; No, do it for real
	 JRST 	DELERR
DOTMP1:	HRRZ	T1,FDB+.FBBYV	; Get pages claimed
	ADD	DIRPGS,T1		; Accumulate dir total
	ADDM	T1,TOTPGS		; Account total pages in this directory
	ADDM	T1,TMPGS		; Accumulate temp file total
	AOS	NTMFIL		; Count temp files deleted
	HRROI	T2,STRING
	MOVE	T1,AGEIS
	CALL	NOUTB
	HRROI	T1,[ASCIZ / days old, deleted and expunged/]
	CALL	CSTR
	HRROI	T2,STRING
	CALL	LSTFIL
	JRST	ENDMSC
DOTAPE:	TXNN	F,F.TAPE
	RET			;DON'T BOTHER IF NOT WANTED
	MOVX	T1,GJ%IFG+GJ%XTN+.GJALL
	MOVEM	T1,GTJBLK+.GJGEN
	MOVEI	T1,GTJBLK
	SETZ	T2,
	GTJFN%
	 RET			; None to do
	MOVEM	T1,LOCJFN
DOTAP1:	HRRZ	T1,LOCJFN
	MOVX	T2,.ARGST
	MOVEI	T3,TAPBLK
	ARCF%			; Get the tape info
	 ERJMP	DOTAP2		; Isn't any for that file
	CALL	STOTAP
DOTAP2:	MOVE	T1,LOCJFN
	GNJFN%
	 RET			; All done
	JRST	DOTAP1

;Here with TAPBLK set up to store both tape names
STOTAP:	SKIPE	T2,TAPBLK+.ARTP1
	CALL	FIND
	SKIPN	T2,TAPBLK+.ARTP2
	RET
;Here with tape name to match in T2.  This routine is written to expect
; lots of calls with T2 alternating between FOO1 and FOO2 on entry.  Ie,
; before it searches the tree, it checks to see if it is looking for
; what it was looking for 2 calls ago.
FIND:	SKIPN	PREHIT			;FIRST CALL?
	JRST	FFIND			;YES. GO SET UP AND ADD 1ST ENTRY.
	SKIPN	T1,EXPHIT		;MIGHT IT BE THE ONE WE EXPECT?
	JRST	FIND2			;WE DON'T EXPECT ANYTHING, GO FIND PLACE
	CAMN	T2,TNAM(T1)		;MATCH EXPECTED ENTRY?
	AOSA	TCNT(T1)		;YES - UP THE COUNT AND GO HOME
	JRST	FIND2			;NO, HAVE TO GO FIND OR ADD
	RET
FFIND:	MOVE	T1,[-NTAPES,,TAPCNT]	;HERE TO ADD FIRST ENTRY. SET UP THE
	MOVEM	T1,FINDSP		;"LAST USED" POINTER, AND ADD ENTRY
	JRST	ADDIN2			;..
NXTINT:	SKIPA	T1,T3			;COPY POINTER
FIND2:	MOVEI	T1,TAPCNT		;HERE TO START AT THE BEGINNING
	CAMN	T2,TNAM(T1)		;MATCH THIS ENTRY?
	JRST	FOUND			;GOTCHA
	HLRZ	T3,PTAP(T1)		;NO, GUESS NAME IS GREATERTHAN
	CAMG	T2,TNAM(T1)		;IS IT?
	HRRZ	T3,PTAP(T1)		;NO, USE LESSTHAN POINTER
	JUMPN	T3,NXTINT		;ANYTHING THERE?
	SKIPL	T3,FINDSP		;NO - HAVE TO ADD AN ENTRY
	RET				;LOSING ENTIRES, & ALREADY WARNED
	ADD	T3,[3,,3]		;SKIP OVER LAST ADDED
	MOVEM	T3,FINDSP		;YES, STORE FREESPACE POINTER BACK
	JUMPG	T3,[
		WARN	<Increase the size of NTAPES, entries being lost>
		RET]			;IS THERE ROOM?
	CAMG	T2,TNAM(T1)		;LESS THAN OR GREATER?
	JRST	[HRRM	T3,PTAP(T1)	;MAKE LESS POINTER POINT TO NEW ENTRY
		 JRST	ADDIN]
	HRLM	T3,PTAP(T1)		;MAKE GREATER POINTER POINT HERE
ADDIN:	MOVE	T1,T3
ADDIN2:	SETZM	PTAP(T1)		;NEW ENTRY. NO POINTERS,..
	SETZM	TCNT(T1)		;AND NO COUNT
FOUND:	MOVEM	T2,TNAM(T1)		;STORE NAME
	AOS	TCNT(T1)		;AND INCR COUNT
	EXCH	T1,PREHIT		;GET LAST HIT IF ANY
	HRRZM	T1,EXPHIT		;MAKE IT THE EXPECTED HIT
	RET
;This returns in T2 the age of the file looked at by GTFDBF in days.
GTAGE:	MOVX	T1,1B0+1B17
	MOVSI	T4,-NDATES
GTAGE1:	HLRZ	T2,@DATES(T4)
	SUB	T2,TODAY
	CAMLE	T2,T1
	MOVE	T1,T2
	AOBJN	T4,GTAGE1
	MOVN	T2,T1
	CAIL	T2,0		;Make sure the value is 0 or greater
	CAILE	T2,^D365*14
	SETZ	T2,
	RET

DATES:	FDB+.FBCRV
	FDB+.FBWRT
	FDB+.FBREF
	FDB+.FBTDT			; Last archive d&t
NDATES==.-DATES

; Here to see if a file has already been done once, & record if not
; Ret +1 if already done, +2 if not
CKDNFL:	MOVE	T1,FDB+.FBADR	; Assume caller has obtained the FDB
	SKIPN	T4,FILPTR		; Get current count
	JRST	CKFLD1		; None, make 1st entry
	HRLZS	T4		; Make an AOBJN ptr
CKFLD2:	CAMN	T1,DONEFL(T4)	; This match?
	RET			; Yes, note we've seen the file before
	AOBJN	T4,CKFLD2		; No match yet
CKFLD1:	MOVEM	T1,DONEFL(T4)	; Record new guy
	SOS	T1,FILPTR		; Update the count
	MOVNS	T1		; Make positive count
	CAIGE	T1,NFILMX		; Over running the buffer?
	JRST	CPOPJ1		; No
	AOS	FILPTR		; Yes, keep using last cell
	WARN	<File buffer full in CKDNFL - increase NFILMX>
	JRST	CPOPJ1

;Call with ITMSTK containing an AOBJN pointer, and T4 contaning the address
; of a routine to call to do the output of whetever is in T2.
PRTORD:	TXZ	F,F.CMMA
PRTO2:	SKIPN	T2,(ITMSTK)
	JRST	PROT3		; Done
	TXOE	F,F.CMMA
	TYPE	[ASCIZ/, /]
	CALL	(T4)		;MUSTN'T HURT T3,T4
	AOBJP	ITMSTK,PROT3
	MOVE	T1,LSTPOS
	CAIGE	T1,^D57
	JRST	PRTO2
	TYPE	[ASCIZ/
	/]
	JRST	PRTORD
PROT3:	TYPE	CRLF
	RET

;Read user's MIGRATION.ORDER and set up JFNSTK approprately.
GETORD:	TXNN	F,F.TRIM		; Will the order be useful?
	JRST	GETOR4		; Flag no user order & return
	TXO	F,F.USOD		; Assume the user will have one
	MOVE	ITMSTK,JFNPTR	; Where free space starts
	PUSH	P,GTJBLK+.GJGEN	; Save this, it's set up for someone
	MOVX	T1,GJ%OLD
	MOVEM	T1,GTJBLK+.GJGEN	; Set what we need
	MOVEI	T1,GTJBLK
	HRROI	T2,[ASCIZ /MIGRATION.ORDER/]
	GTJFN%
	 JRST	GETOR3		; No order list for us
	HRRZS	T1		; Probably got flags back
	MOVEM	T1,TMP		; Save the JFN
	MOVX	T2,<FLD(7,OF%BSZ)+OF%RD>
	OPENF%
	 JRST [	MOVE	T1,TMP	; JFN
		RLJFN%
		 JFCL
		JRST	GETOR3]
	MOVEM	ITMSTK,JFNSTP	; Set for user ORDER list

GETOR1:	MOVX	T1,GJ%OFG+GJ%SHT+GJ%FNS+.GJALL
	HRL	T2,TMP		; Read from file
	HRRI	T2,.NULIO		; No output
	GTJFN%
	 JRST	GETOR2		; Abort on error of any kind
	MOVEM	T1,(ITMSTK)	; Save it
	AOBJN	ITMSTK,GETOR1	; Loop until...
	WARN	<User's ORDER list caused JFN storage to fill up>
GETOR2:	SETZM	(ITMSTK)
	MOVE	T1,TMP
	CLOSF%
	 JFCL
GETOR3:	POP	P,GTJBLK+.GJGEN	; Restore GTJFN block
	CAME	ITMSTK,JFNPTR	; Get anything?
	RET
	MOVE	T1,[-NJFNS,,JFNLST]
	MOVEM	T1,JFNSTP
GETOR4:	TXZ	F,F.USOD		; User didn't have an order list
	RET
	SUBTTL	TAKE command
;TAKE and friends

.POLIC:	GUIDES	<does a TAKE on SYSTEM:REAPER.CMD>
	CONFIRM
	MOVX	T1,GJ%SHT+GJ%OLD
	HRROI	T2,[ASCIZ/SYSTEM:REAPER.CMD/]
	GTJFN%
	 JSERRD	<Policy file not available>
	JRST	TAKE1

.TAKE:	HLRZ	T1,TAKSTK	;GET THE TAKE STACK COUNT
	CAIL	T1,TAKLEN	;ALL FULL UP?
	 ERROR	<TAKEs nested too deeply, aborting.>
	GUIDES	<Commands from file>
	MOVX	T1,GJ%OLD	;JUST AN OLD FILE, PLEASE
	MOVEM	T1,GTJBLK+.GJGEN
	SETZM	GTJBLK+.GJDIR
	SETZM	GTJBLK+.GJDEV
	HRROI	T1,[ASCIZ/REAPER/]
	MOVEM	T1,GTJBLK+.GJNAM
	HRROI	T1,[ASCIZ/CMD/]
	MOVEM	T1,GTJBLK+.GJEXT
	DMOVE	T1,[EXP CMDBLK,FICINB]	;INPUT FILE OR CONFRM
	CALL	PARSE
	 TRNA
	JRST	TAKEOK
	HRROI	T1,[ASCIZ/SYSTEM/]
	MOVEM	T1,GTJBLK+.GJDEV
	DMOVE	T1,[EXP CMDBLK,FICINB]
	CALL	PARSE
	 ERROR	<Not a Confirm or a File Specification>,NOCMD
TAKEOK:	CAIN	T3,.CMCFM	;CONFIRM OR FILE?
	JRST	TAKEND
	CALL	RPSJFN		;SAVE JFN FOR REPARSE
	CONFIRM
	HRRZ	T1,T2		;GET JFN IN T1
TAKE1:	MOVX	T2,7B5+OF%RD	;TRY TO OPEN
	OPENF%
	 JSERRD	<Can't OPEN file>,NOCMD ;IF AN ERROR OCCURS, SAY WHY AND DIE
	HRLZS	T1		;JFN IN LH
	HRRI	T1,.NULIO	;OUTPUT (NOWHERE) IN RH
	;JRST	PUSTAK

;HERE WITH T1/ INJFN,,OUTJFN TO PUSH TO NEW INPUT & OUTPUT
PUSTAK:	MOVE	Q1,TAKSTK	;GET THE TAKE STACK
	EXCH	T1,CMDBLK+.CMIOJ;WHERE COMND LOOKS NOW
	PUSH	Q1,T1		;SAVE OLD SOURCE ON TAKE JFN STACK
	MOVEM	Q1,TAKSTK	;SAVE STACK POINTER
	RET

TAKEND:	CALL	TAKEOS
	 ERROR	<No TAKE files active>,CPOPJ
	RET

TAKEOS:	TXOA	F,F.TMP		;DON'T WANT ENDING MESSAGE
TAKEOF:	TXZ	F,F.TMP		;ALLOW END MESSAGE
	MOVE	Q1,TAKSTK	;GET TAKE STACK
TAKEO2:	TLNN	Q1,-1
	RET			;NO OPERATION IF EMPTY STACK
	POP	Q1,T1		;RESTORE PREVIOUS JFNS
	MOVEM	Q1,TAKSTK
	EXCH	T1,CMDBLK+.CMIOJ;GIVE BACK LAST JFNS
	HLRZ	T2,T1		;GET COMMAND INPUT JFN IN T2
	CAIN	T2,.PRIIN	;IS IT MAIN INPUT?
	JRST	CPOPJ1		;YEAH, DON'T ANNOUNCE OR CLOSE
	TXZE	F,F.TMP
	JRST	TAKEO3		;NO ENDING MESSAGE
	CALL	IFCRLF		;ANNOUNCE WHAT'S ENDING
	TYPE	<[ASCIZ/[Ending /]>
	CALL	TYJFNS
	TYPE	CBCR		;CLOSE BRACKET CRLF
TAKEO3:	MOVE	T1,T2
	CLOSF%			;CLOSE THE FILE OUT
	 JSERRD	<>,CPOPJ1	;FAILURE SEEMS UNLIKELY
	JRST	CPOPJ1		;+2 RET

;Here to blow away all take files
UNTAKE:	CALL	TAKEOF		;END THE CURRENT TAKE FILES
	 RET			;DONE
	JRST	UNTAKE		;GO UNTIL NONE LEFT
	SUBTTL	Parsing

;To parse a wild filespec
GETFIL:	PUSH	P,T1		; Save parse only param
	SETO	T1,		; Say we want *'s
	CALL	SETGTD		; Set the defaults for GTJFN
	MOVX	T1,GJ%OLD+GJ%IFG+GJ%DEL
	IORM	T1,GTJBLK+.GJGEN
	POP	P,T1
	JUMPGE	T1,GETFL2
	MOVX	T1,GJ%IFG+GJ%OLD
	ANDCAM	T1,GTJBLK+.GJGEN
	MOVX	T1,GJ%OFG
	IORM	T1,GTJBLK+.GJGEN
GETFL2:	DMOVE	T1,[EXP CMDBLK, FILINB]
	;JRST	PARSE

; Sucessful parse returns usual flags in T1, usual stuff in T2, the
; type of block in T3. Bad parse returns +1, good +2.
PARSE:	COMND%
HITME:	 ERJMP	PAREOF
	TXNE	T1,CM%NOP
	RET			;DIDN'T PARSE
	LDB	T3,[POINT 9,(T3),8]
CPOPJ1:	AOS	(P)
	RET

PAREOF:	MOVX	T1,.FHSLF	;WHAT WENT WRONG?
	GETER%			;..
	HRRZ	T1,T2		;ISOLATE ERROR CODE
	CAIN	T1,DESX3	;DID WE LOSE THE JFN?
	 JRST	[MOVEI	T1,TAKSTR	;YES, ASSUME ^C/START
		 MOVEM	T1,TAKSTK	;BLOW AWAY COMMAND STACK
		 MOVE	T1,[.PRIIN,,.PRIOU] ;AND TALK TO TERMINAL
		 MOVEM	T1,CMDBLK+.CMIOJ
		 JRST	PANIC]
	CAIE	T1,IOX4		;EOF?
	 JSERRD	<Can't parse command>,PANIC,JRST ;NO, COMPLAIN
	CALL	TAKEOF		;ASSUME EOF, DROP A COMMAND LEVEL
	 JSERRD	<Parse error>,PANIC,JRST ;IF THERE ISN'T A TAKE FILE, WEIRD
	TXNE	F,F.PRIV	;IS THIS A PEON?
	JRST	PANIC		;NO, RESTART
	JRST	PEON2		;YES, SECOND STAGE PEON CODE PLEASE
;CALL to confirm.  Skip ret if all OK.
CONFRM:	DMOVEM	T1,1(P)
	MOVEM	T3,3(P)
	DMOVE	T1,[EXP CMDBLK,CONINB]
	COMND%
	 ERJMP	PAREOF
	TXNE	T1,CM%NOP
	 ERROR	<Not confirmed>,CPOPJ
	MOVE	T3,3(P)
	DMOVE	T1,1(P)
	JRST	CPOPJ1

;Here with a word address of a string to guide with in T1.  Skip if OK.
GUIDE:	HRROM	T1,GUIINB+.CMDAT
	DMOVEM	T2,1(P)
	DMOVE	T1,[EXP CMDBLK,GUIINB]
	COMND%
	 ERJMP	PAREOF
	TXNE	T1,CM%NOP
	 ERROR	<Illegal guide word>,CPOPJ
	DMOVE	T2,1(P)
	JRST	CPOPJ1


;Call with T1 pointing to a 0 terminated list of characters to stop on.
; This copies characters out of the COMND% buffer into the atom buffer,
; stopping on null or one of the characters listed. T3 is returned as the
; character matched, or 0 if noting did.
SKIPTR:	MOVEM	T1,TMP
	MOVE	T4,[POINT 7,ATOM]
	SETZ	T3,
	JRST	SKIPT3
SKIPT1:	CAIE	T2,.CHCRT
	CAIN	T2,.CHLFD
	TRNA			;DON'T COPY THESE TO ATOM BUFFER
	IDPB	T2,T4
SKIPT3:	SOS	CMDBLK+.CMINC
	ILDB	T2,CMDBLK+.CMPTR
	JUMPE	T2,NFIND
	MOVE	T1,TMP
SKIPT2:	SKIPN	T3,(T1)
	JRST	SKIPT1
	CAIE	T2,(T3)
	AOJA	T1,SKIPT2
	SETZ	T2,
NFIND:	IDPB	T2,T4
	RET

SETGTD:	MOVE	T2,[GTJBLK,,GTJBLK+1]
	SETZM	-1(T2)
	BLT	T2,GTJBLK+.GJBFP	; Clear it to start
	MOVE	T2,[.PRIIN,,.PRIOU]
	MOVEM	T2,GTJBLK+.GJSRC
	MOVX	T2,GJ%XTN
	IORM	T2,GTJBLK+.GJGEN
	MOVX 	T2,G1%IIN
	MOVEM	T2,GTJBLK+.GJF2	; Into extended blk
	JUMPE	T1,CPOPJ	; Done if doesn't want stars
	HRROI	T2,[ASCIZ /*/]
	MOVEM	T2,GTJBLK+.GJDIR	; For directory name
	MOVEM	T2,GTJBLK+.GJNAM	; For file name
	MOVEM	T2,GTJBLK+.GJEXT	; For extention
	MOVX	T2,GJ%IFG+.GJALL
	IORM	T2,GTJBLK+.GJGEN
	RET
	SUBTTL	Error support
;ERROR and special output routines.

;ANNERR is good to call when you hit an error.  If you are in a TAKE file,
; it <CRLF>s at need and types the failing command back to the user.  It
; makes sure the next output starts at the margin and clears the input
; buffer.
ANNERR:	DMOVEM	T1,IFCTMP
	MOVX	T1,.CTTRM
	RFMOD%
	TXZE	T2,TT%OSP	;CLEAR ^O
	SFMOD%
	CFIBF%
	CALL	WHERE
	 JRST	.+2		;FROM FILE
	JRST	IFCRL2		;FROM TERMINAL
	MOVEM	T1,INPTMP
	CALL	IFCRL2
	TYPE	[ASCIZ/?In command /]
	TYPE	BFFR		;TYPE COMMAND
	CALL	IFCRL2
	TYPE	[ASCIZ/?In file /]
	MOVE	T2,INPTMP
	CALL	TYJFNS
	JRST	IFCRL2		;DO IFCRLF, RESTORING CALLER'S AC'S

IFCRLF:	DMOVEM	T1,IFCTMP
IFCRL2:	MOVEI	T1,.PRIOU
	DOBE%
	RFPOS%
	TRNE	T2,-1
YSCRLF:	TYPE	CRLF
NOCRLF:	DMOVE	T1,IFCTMP
CPOPJ:	RET

;WHERE skips if the commands are coming in from .PRIIN
; The current input JFN is returned in T1
WHERE:	HLRZ	T1,CMDBLK+.CMIOJ ;GET THE INPUT SOURCE
	CAIN	T1,.PRIIN	;PRIMARY INPUT?
	AOS	(P)		;YES, SKIP RET
	RET

LSTERR:	TLCE	T1,-1		;ANY LEADER STRING BEYOND "?"
	TLCN	T1,-1
	HRLI	T1,(POINT 7)
	MOVEI	T2,2		;POINT TO 2ND CHARACTER
	ADJBP	T2,T1
	LDB	T2,T2		;FETCH
	TYPEAT	T1
	CAIE	T2,0		;JUST ONE CHAR (IE, "?") ?
LSTERD:	TYPE	[ASCIZ/ - /]	;IF YES, DON'T TYPE THIS
LSTERO:	HRLOI	T2,.FHSLF
LSTERC:	HRROI	T1,STRING
	SETZ	T3,
	ERSTR%
	 JFCL
	 JFCL
	TYPE	STRING
	RET
	SUBTTL	Terminal and List file output
;Terminal and list file, etc I/O subroutines

;Get text to proper places (Terminal, list file, etc).  OUTMSG if the pointer
; passed could be anything, including null.  OUTMSS if the pointer certainly
; contains some sort of pointer.  OUTMSA if the pointer is PSOUT% legal.
; OUTMTT if the string is in TEMP2.
; TYPE and TYPEAT come here.  Enter with T1 on the stack.
OUTMSG:	JUMPE	T1,OUTMS3	;NULL POINTER OR CHARACTER? NOOP IF SO.
OUTMSS:	TLNE	T1,-1		;POINTER OR CHARACTER?
	JRST	OUTMSA		;POINTER, GO USE
OUTMSC:	HRLZM	T1,OUTMSX	;CHARACTER.  TUCK INTO STORAGE..
	SKIPA	T1,[POINT 7,OUTMSX,10] ;AND FETCH A POINTER TO IT
OUTMTT:	HRROI	T1,TEMP2	;WHERE CALLER WROTE STRING
OUTMSA:	MOVEM	T1,OUTMST	;STORE THE POINTER TO THIS TEXT
	PUSH	P,T4		;SAVE T4
	MOVE	T4,LSTFLG	;ARE WE WRITING THIS ANYWHERE?
	TXNE	T4,LS.TTY	;OUT TO PRIMARY OUTPUT?
	PSOUT%			;YES
	TXNE	T4,LS.LST
	SKIPN	T1,LSTJFN	;FETCH LIST JFN
	JRST	OUTMSD		;NOT AVAILABLE, FINE
	PUSH	P,T2
	PUSH	P,T3
	SKIPGE	LSTLIN		;NEED A HEADER FIRST?
	CALL	FSTPGN		;YES, DO THAT
	MOVE	T2,OUTMST	;POINTER TO TEXT
	SETZ	T3,		;GO UNTIL NULL SEEN
	SOUT%			;WRITE TO LIST FILE
	 ERJMP	NOLSTF
	SKIPGE	T3,LSTPOS	;DID CALLER ALREADY FIGURE LSTPOS FOR US?
	JRST	[MOVNS	T3	;YES, JUST SET IT RIGHT
		 JRST	CNTSP2]
	MOVE	T1,OUTMST
	TLC	T1,-1		;UPDATE LSTPOS
	TLCN	T1,-1
	HRLI	T1,(POINT 7)
CNTSPC:	ILDB	T2,T1
	JUMPE	T2,CNTSP2
	CAIN	T2,.CHCRT
	JRST	[SETZ	T3,
		 JRST	CNTSPC]
	CAIN	T2,.CHLFD
	JRST	PAGTST		;<LF> DONE BELOW
	CAIN	T2,.CHTAB
	JRST	[TRO	T3,7
		 AOJA	T3,CNTSPC]
	CAIGE	T2," "
	ADDI	T3,1		;ASSUME CTRL CHARS ARE 2 WIDE (^x)
	AOJA	T3,CNTSPC

PAGTST:	AOS	T4,LSTLIN
	CAIL	T4,PAGLIN	;LINES/PAGE
	CALL	FSTPGN		;NEED A PAGE HEADER
	JRST	CNTSPC		;NOT A NEW PAGE YET, GO ON

FSTPGN:	PUSH	P,T1
	MOVE	T1,LSTJFN	;SET UP TO OUT A ^L
	MOVEI	T2,.CHFFD
	BOUT%
	 ERJMP	.+1
	SETZM	LSTLIN
	POP	P,T1
	RET

CNTSP2:	MOVEM	T3,LSTPOS
	POP	P,T3
	POP	P,T2
OUTMSD:	POP	P,T4
OUTMS3:	POP	P,T1
	RET

;Error while writing list file - end the list file
NOLSTF:	SKIPE	T1,LSTJFN	;LIST FILE HERE?
	CLOSF%			;YES, CLOSE IT
	 ERJMP	.+1
	SETZM	LSTJFN
	MOVX	T4,LS.LST	;SAY NO MORE LIST FILE
	ANDCAM	T4,LSTFLG
	CALL	ANNERR		;ANNOUNCE ERROR
	TYPE	[ASCIZ/?Error writing LIST file, list file ended
/]				;RECURSION!
	SETZ	T3,
	JRST	CNTSP2

;TABOUT only works for the list file (because OUTMSG only follows the line
; position of the list file)
; Give it the column to get to in T2.  This always outputs at least 1 space.
TABOUT:	PUSH	P,T1		;BECAUSE OUTMSA WANTS THAT
	MOVE	T1,[POINT 7,TABTMP] ;A PLACE TO WRITE TO
	MOVE	T3,LSTPOS	;FIND OUT WHERE WE ARE
	MOVEM	T3,LSTTMP	;SAVE IT
	MOVEI	T4,.CHTAB	;PREPARE TO WRITE SOME TABS
	TRZ	T3,7		;FIGURE THE EFFECT OF THE FIRST TAB
	ADDI	T3,8		;..
TABITH:	IDPB	T4,T1		;IN GOES THE TAB
	CAIL	T3,(T2)		;FAR ENOUGH?
	JRST	TTOFAR		;YES, MAYBE TOO FAR
	MOVEM	T3,LSTTMP	;TAB WAS OK, REMEMBER WHERE WE ARE
	ADDI	T3,8		;SIMULATE THE NEXT TAB
	JRST	TABITH		;AND GO DO IT
TTOFAR:	CAIG	T3,(T2)		;DID WE GO TOO FAR?
	JRST	TOKOUT		;NO, JUST RIGHT, FINISH UP
	MOVEI	T4," "		;TOO FAR, OVERWRITE LAST TAB WITH SPACE
	DPB	T4,T1		;..
	AOS	T3,LSTTMP	;ACCOUNT FOR SPACE
TSPOUT:	CAIL	T3,(T2)		;ENOUGH SPACES?
	JRST	TOKOUT		;YES, FINISH UP
	IDPB	T4,T1		;NO, SPACE GOES IN
	AOJA	T3,TSPOUT	;ADVANCE THE COUNT AND GO ON
TOKOUT:	MOVNM	T3,LSTPOS	;TELL OUTMSA WE FIGURED THE LENGTH FOR IT
	SETZ	T4,		;NULL TO END
	IDPB	T4,T1		;..
	HRROI	T1,TABTMP	;THE STRING WE WROTE
	JRST	OUTMSA		;GETS WRITTEN NOW
; Listing routines

;LSTFIL types out the current filename, either from the JFN in LOCJFN (if
; F.GOTN is off) or directly from the text at GOTNAM (if F.GOTN is on).  It
; also clears F.GOTN when called.
LSTFIL:	TXON	F,F.NDIR	; New directory?
	CALL	LSTDIR		; Yes, spit it out
	PUSH	P,T2		; Save note
	TXZE	F,F.GOTN	; Got name already?
	JRST	[TYPE	GOTNAM
		 JRST	LSTFI1]
	HRRZ	T2,LOCJFN
	MOVX	T3,JFNSNE	;Filnam, type, gen, and punctuation
	CALL	TYJFNF
LSTFI1:	MOVEI	T2,^D40
	CALL	TABOUT
	POP	P,T2		; Note
	CAIE	T2,0		; Any?
	TYPEAT	T2
	TYPE	CRLF
	RET

LSTDIR:	PUSH	P,T2
	TYPE	[ASCIZ/
   /]
	CALL	TYDIRC		;Type current directory name
	TYPE	CRLF
	TXNN	F,F.USOD	;HAVE A USER ORDERING?
	JRST	LSTDI1
	TYPE	[ASCIZ/ user ordering: /]
	MOVEM	ITMSTK,TMP
	MOVE	ITMSTK,JFNSTP
	MOVX	T3,JFNSNX
	MOVEI	T4,TYJFNF
	CALL	PRTORD
	MOVE	ITMSTK,TMP
LSTDI1:	POP	P,T2
	RET

OPNLST:	HRRZS	T1
	MOVE	T2,[7B5+OF%APP]
	OPENF%
	 ERJMP	NOLISF
	JRST	CPOPJ1
NOLISF:	HRRZS	T1
	RLJFN%
	 ERJMP	.+1
	RET

;Here to output time and date
TADOUT:	PUSH	P,T1
	SETO	T2,
	MOVX	T3,OT%NSC+OT%NCO+OT%SCL+OT%DAY
	HRROI	T1,TEMP2
	ODTIM%
	 ERJMP	.+1
	JRST	OUTMTT

;Here with a number in T2 to output. DECOUT loses T3.  DECOUT & NUMOUT
; act identically to TYPE (it calls OUTMSG).  NUMOUT can be treated
; exactly like NOUT% in terms of radixs and flags.
DESOUT:	SKIPA	T3,[NO%LFL+NO%OOV+5B17+^D10]
DECOUT:	MOVEI	T3,^D10		;RADIX 10
NUMOUT:	PUSH	P,T1		;MOSTLY BECAUSE OUTMSA WANTS IT
	HRROI	T1,TEMP2
	NOUT%
	 ERJMP	.+1
	JRST	OUTMTT

;Type JFN in T2
TYJFNS:	MOVE	T3,[JFNSAL]
TYJFNF:	HRROI	T1,TEMP2
	JFNS%
	 ERJMP	CPOPJ
	PUSH	P,T1
	JRST	OUTMTT		;TYPE STRING

;Type the directory name referenced by T2
TYDIRC:	MOVE	T2,CURDIR
TYDIRS:	PUSH	P,T1
	HRROI	T1,TEMP2
	DIRST%
	 ERJMP	.+1
	JRST	OUTMTT

;Acts like CSTRB, except T1/ number to output (decimal)
NOUTB:	EXCH	T1,T2
	MOVEI	T3,^D10
	NOUT%
	 ERJMP .+1
	EXCH	T1,T2
	RET

;Copy string and back up T2 on exit.  Return last character in T3.
CSTRB:	CALL	CSTR
	SETO	T3,
	ADJBP	T3,T2
	MOVE	T2,T3
	RET

;More string copy stuff.  Takes T1 and T2 as the from and to, and returns
; T3 as 0.
CSTR:	TLCE	T1,-1
	TLCN	T1,-1
	HRLI	T1,(POINT 7)
	TLCE	T2,-1
	TLCN	T2,-1
	HRLI	T2,(POINT 7)
CSTRA:	ILDB	T3,T1
	IDPB	T3,T2
	JUMPN	T3,CSTRA
	RET

;Output sixbit string in T3.  Hurts T2 and T3
SIXOUT:	PUSH	P,T1
	SETZ	T2,		;PREPARE TO CONVERT TO ASCIZ
	JUMPE	T3,SIXOU1	;IF NONE, ALREADY CONVERTED, SO TO SPEAK
	JRST	V6TO7B
V6TO7:	LSH	T2,1		;ROOM FOR ASCII BIT (OR, MAKE LEFT JUSTIFIED)
	TLNE	T2,774K		;DONE? (ANYTHING IN 1ST BYTE?)
	JRST	V6TO7D		;YES, GO STORE
V6TO7B:	LSHC	T2,6		;FETCH NEXT 6BIT BYTE INTO T2
	TRNE	T2,77		;IS IT REAL?
	ADDI	T2," "		;YES, CONVERT TO ASCII
	JRST	V6TO7
V6TO7D:	JUMPE	T3,SIXOU1	;IS 6TH BYTE NONEXISTANT?
	LSH	T3,-1		;NO, NEEDS CONVERTING
	ADD	T3,[BYTE(7) " ",0]
SIXOU1:	DMOVEM	T2,TEMP2
	JRST	OUTMTT
;Here to push the JFN in T2 and the address of the "delete jfn" routine
; on the reparse stack.
RPSJFN:	MOVEI	T1,RPSJFD
	HRL	T1,T2
	EXCH	T1,RPSSTK	;SAVE DATA, GET STACK POINTER
	PUSH	T1,RPSSTK	;PUT DATA ON REPARSE STACK
	EXCH	T1,RPSSTK	;GET T1 BACK, PUT STACK POINTER AWAY AGAIN
	RET
;Here to get something off the reparse stack. +1 ret with something in T1,
; +2 with nothing on stack anymore.
RPSGET:	EXCH	T2,RPSSTK
	TLNN	T2,-1		;EMPTY STACK?
	AOSA	(P)		;YES, SKIP RETURN
	POP	T2,T1
	EXCH	T2,RPSSTK
	RET

UNDO:	CALL	RPSGET
	JRST	GOUNDO		;RH OF T1 HAS THE ADDR OF A ROUTINE TO CALL
	RET			;NOTHING LEFT TO UNDO
GOUNDO:	CALL	(T1)		;GO DO ROUTINE
	JRST	UNDO		;GO UNTIL REPARSE STACK EMPTY
	JRST	UNDO		;IN CASE OF A SKIP RETURN

RLJFNS:	SKIPE	T1,(ITMSTK)	; Anything?
	RLJFN%			; Yes, release it
	 JFCL
	SETZM	(ITMSTK)
	AOBJN	ITMSTK,RLJFNS
	RET

RPSJFD:	HLRZS	T1		;DROP THE JFN IN THE LF OF T1
;Here to drop the JFN in T1 as though we never touched it
DRPJFN:	JUMPE	T1,CPOPJ	;IF NO JFN, FINE
	GTSTS%			;IS THE JFN OPEN AT ALL?
	JUMPL	T2,DRPOFN	;IF SO, CLOSF%
	RLJFN%
	 ERJMP	.+1		;IF NOT, RLJFN%, IF FAILS, CLOSF%
	RET
DRPOFN:	HRLI	T1,(CZ%ABT+CZ%NUD)
	CLOSF%			;THIS JFN NEVER HAPPENED
	 ERJMP	.+1
	RET
	SUBTTL	File information subroutines
; Here to determine if file has ANY tape info associated with it
HAVTAP:	SKIPN TAPBLK+.ARTP1	; Tape 1 ID there?
	SKIPE TAPBLK+.ARTP2	; No, how about tape 2 ID?
	RET			; At least one is there
	JRST	CPOPJ1		; Neither are there


GTFDBF:	HRRZ	T1,LOCJFN
	MOVSI	T2,.FBLEN
	MOVEI	T3,FDB
	GTFDB%
	 ERJMP [HRLI	T2,.FBLN0	; Probably a short FDB
		GTFDB%
		JRST	.+1]
	LDB	T2,[POINT 7,(T3),35]
	CAIGE	T2,.FBLXT		; Long enough for tape info?
	JRST [	SETZM	.FBTDT(T3) ; No, date is not valid then
		SETZM	TAPBLK+.ARTP1 ; No tape info
		SETZM	TAPBLK+.ARTP2 ; ...
		RET]
	HRRZS	T1		; JFN only
	MOVX	T2,.ARGST		; Get tape info
	MOVEI	T3,TAPBLK
	ARCF%
	 ERJMP	.+1
	RET
CRLF:	ASCIZ/
/
CRLF2:	ASCIZ/

/
CBCR:	ASCIZ/]
/

;Some parsing tokens
CMDINB:	<.CMKEY>B8
	CMDLST
CMDLST:	 CMDLEN,,CMDLEN
	CTB	.ARCHI,	<BEGIN>
	CTB	.FLUSH,	<DELETE-CONTENTS>
	CTB	.EXIT,	<EXIT>
	CTB	.LIST,	<LIST>
	CTB	.INVOL,	<MIGRATE>
	CTB	.ORDER,	<ORDER>
	CTB	.PERIO,	<PERIOD>
	CTB	.POLIC,	<POLICY>
	CTB	.PURGE,	<PURGE>
;	CTB	.REAPE, <REAP>
	CTB	.SCAN,	<SCAN>
	CTB	.SKIP,	<SKIP>
	CTB	.TAKE,	<TAKE>
	CTB	.TAPE,	<TAPE>
	CTB	.TRIM,	<TRIM>
	CMDLEN=.-CMDLST-1

FICINB:	<.CMCFM>B8+FILINB
FILINB:	<.CMFIL>B8
PERINB:	<.CMNUM>B8+CM%SDH+CM%HPP
	^D10
	-1,,[ASCIZ/Number of days/]
SKPINB:	<.CMDIR>B8+CM%SDH+CM%HPP
	 CM%DWC
	-1,,[ASCIZ/Name of directory to SKIP/]
CMCINB:	<.CMCMA>B8+CONINB
INIINB:	<.CMINI>B8
CONINB:	<.CMCFM>B8

	END	<3,,ENTVEC>