Google
 

Trailing-Edge - PDP-10 Archives - SRI_NIC_PERM_SRC_1_19910112 - 6-exec/execse.mac
There are 47 other files named execse.mac in the archive. Click here to see a list.
;[SRI-NIC]SRC:<6-EXEC>EXECSE.MAC.17, 15-May-85 17:08:01, Edit by HSS
; [NIC1041] Different SET TERMINAL COMMAND
;[SRI-NIC]SRC:<6-EXEC>EXECSE.MAC.16,  9-May-85 16:59:07, Edit by HSS
; [NIC1033] Add autokeep sttribute code.
;[SRI-NIC]PS:<HSS.EXEC>EXECSE.MAC.15, 17-Apr-85 12:33:15, Edit by HSS
; [NIC1017] Add SET HISTORY
;[SRI-NIC]PS:<HSS.EXEC>EXECSE.MAC.14, 11-Apr-85 14:05:33, Edit by HSS
; [NIC1011] Allow ^C-capability in batch jobs so Augment will work.
;<6-EXEC>EXECSE.MAC.13,  4-Jan-85 14:04:59, Edit by SATZ
; Make the SET [NO] TRAP [NO] PROCEED confirm before recording the facts
;<6-EXEC>EXECSE.MAC.12, 19-Oct-84 19:30:23, Edit by LOUGHEED
; Fix bug in edit 10
;<6-EXEC>EXECSE.MAC.11,  6-Sep-84 17:43:38, Edit by SATZ
; CM156 Fix COMMAND-TRACE ^U bug from CMU
;<6-EXEC>EXECSE.MAC.10, 26-Aug-84 23:09:40, Edit by SATZ
; Add some sanity code against the input protection
;<6-EXEC>EXECSE.MAC.9, 25-Aug-84 01:27:53, Edit by SATZ
; Add in SET [NO] LEVEL-INDICATION
;<6-EXEC>EXECSE.MAC.8, 24-Aug-84 16:03:55, Edit by SATZ
; Add in SET PROMPT
;<6-EXEC>EXECSE.MAC.7, 23-Aug-84 16:07:41, Edit by SATZ
; Removed extraneous line causing INPDIR to not default the correct directory
;<6-EXEC>EXECSE.MAC.6,  9-Aug-84 01:22:09, Edit by LOUGHEED
;<6-EXEC>EXECSE.MAC.5,  8-Aug-84 23:49:43, Edit by LOUGHEED
; Remove SET EXTRA cruft
; Reinstall account string code everywhere.  Yes, only SUMEX uses it, but
;  why mess up sources with pointless conditionals?
;SCORE:<MERGED-6-EXEC>EXECSE.MAC.2, 12-Jul-84 07:48:14, Edit by JPBION
;SUMEX changes:
; Reinstall account stuff but not session remark
; Check for valid account in SET DIRECTORY ACCOUNT-DEFAULT command
; ^ESET ETHERNET ON/OFF.
;LOTS changes:
; SET EXTRA commands
; CERAS and TERMAN nodes
; Check new passwords for special chars
;Stanford changes:
; New passwords must be six or more characters in length (in SET DIR PASS).
;    - BUILD will still accept shorter passwords
; Various ^ESET PUP ... commands
; SET [NO] NEW-FORK (ON RESET)
; SET FILE PERMANENT
; SET FILE SAVE-BY-BACKUP-SYSTEM
; SET FILE TEMPORARY
; ^ESET [NO] LOGINS-ALLOWED (ON) ETHERNET-TERMINALS
; Remove all account and session remark stuff
; Fix error if % in an alert message text
; Remove unnecessary code duplication in .DPASS
; Initialize block in DMODE
; Allow defaulting in SET DIRECTORY commands
; Remove ^ESET DATE-AND-TIME
; Stanford CEASE command
; Add SET TYPEOUT RADIX
;
; UPD ID= 401, SNARK:<6.EXEC>EXECSE.MAC.42,  26-Apr-84 15:11:07 by PRATT
;TCO 6.2050 - Fix problem with arpa monitor / no host # set
; UPD ID= 398, SNARK:<6.EXEC>EXECSE.MAC.41,   3-Apr-84 09:19:11 by EVANS
;TCO 6.2012 - Replace FORTRAN ".LE." in message prompt for SET ALERT.
; UPD ID= 391, SNARK:<6.EXEC>EXECSE.MAC.40,  27-Feb-84 09:43:20 by PRATT
;TCO 6.1956 - Add ^Eset [no] FAST-LOGINS-ALLOWED
; UPD ID= 390, SNARK:<6.EXEC>EXECSE.MAC.38,  27-Feb-84 09:27:30 by PRATT
;TCO 6.1982 - Fix the ^ESET commands which aren't "confirm"ing
; UPD ID= 389, SNARK:<6.EXEC>EXECSE.MAC.37,  27-Feb-84 08:15:25 by PRATT
;More TCO 6.1956 - Fix typeo at CEASE3 code
; UPD ID= 388, SNARK:<6.EXEC>EXECSE.MAC.36,  27-Feb-84 07:35:55 by PRATT
;TCO 6.1967 - Do a confirm, and add the NOW arg for ^ECEASE
; UPD ID= 382, SNARK:<6.EXEC>EXECSE.MAC.35,  24-Jan-84 16:56:13 by PAETZOLD
;more TCO 6.1953 - Add some ^ESET commands.  Add entries to the no table.
; UPD ID= 381, SNARK:<6.EXEC>EXECSE.MAC.34,  24-Jan-84 16:46:27 by PAETZOLD
;more TCO 6.1953 - Add some ^ESET commands.  fix a typeo.
; UPD ID= 380, SNARK:<6.EXEC>EXECSE.MAC.33,  24-Jan-84 16:35:43 by PAETZOLD
;TCO 6.1953 - Add some ^ESET commands.
; UPD ID= 347, SNARK:<6.EXEC>EXECSE.MAC.32,  28-Nov-83 16:37:33 by LOMARTIRE
;More TCO 6.1676 - Improve error message "Invalid terminal range specified"
; UPD ID= 341, SNARK:<6.EXEC>EXECSE.MAC.31,  20-Nov-83 19:45:16 by PRATT
;TCO 6.1870 - Get rid of code which is under NONEWF. Remove NEWF's.
; UPD ID= 316, SNARK:<6.EXEC>EXECSE.MAC.30,  26-Oct-83 13:58:05 by PRATT
;TCO 6.1842 - No negative args and new error messages for SET TIME-LIMIT
; UPD ID= 287, SNARK:<6.EXEC>EXECSE.MAC.29,  14-Jun-83 11:56:25 by LOMARTIRE
;TCO 6.1676 - Allow range of terminal lines in ^ESET TERMINAL command
; UPD ID= 259, SNARK:<6.EXEC>EXECSE.MAC.28,  11-Feb-83 14:29:09 by TSANG
;TCO 6.1500 - Don't allow ESC to confirm SET LATE-CLEAR-TYPEAHEAD command
; UPD ID= 257, SNARK:<6.EXEC>EXECSE.MAC.27,   8-Feb-83 10:29:29 by TSANG
;TCO 6.1494 - Fix SET TRAP NO NO NO..... problem
; UPD ID= 249, SNARK:<6.EXEC>EXECSE.MAC.26,  15-Jan-83 19:27:15 by CHALL
;TCO 6.1464 - UPDATE COPYRIGHT NOTICE
; UPD ID= 220, SNARK:<6.EXEC>EXECSE.MAC.25,  11-Jan-83 13:51:56 by TSANG
;TCO 6.1116 - Fix SET TIME-LIMIT confusion
; UPD ID= 213, SNARK:<6.EXEC>EXECSE.MAC.24,   3-Jan-83 17:08:41 by LOMARTIRE
;TCO 6.1433 - Add code for ^ESET [NO] LOGINS-ALLOWED DECNET-LINES command
; UPD ID= 196, SNARK:<6.EXEC>EXECSE.MAC.23,  18-Nov-82 10:46:31 by PAETZOLD
;TCO 6.1384- Remove the ^ESET ARPANET commands
; UPD ID= 189, SNARK:<6.EXEC>EXECSE.MAC.22,   1-Nov-82 16:22:55 by WEETON
;TCO 6.1335 - Only ask for old password when nessesary
; UPD ID= 163, SNARK:<6.EXEC>EXECSE.MAC.21,  27-Sep-82 16:58:27 by ACARLSON
;Add USERID option to ^ESET PRIVATE-QUASAR (for GALAXY)
; UPD ID= 149, SNARK:<6.EXEC>EXECSE.MAC.20,   5-Aug-82 20:35:33 by LEACHE
;TCO 6.1215 Remove bogus JUMPN from JSYS trap code
; UPD ID= 142, SNARK:<6.EXEC>EXECSE.MAC.19,   4-Aug-82 17:28:57 by LEACHE
;TCO 6.1209 Fix JSYS trapping
; UPD ID= 100, SNARK:<6.EXEC>EXECSE.MAC.17,   8-Jan-82 15:59:45 by CHALL
;TCO 6.1052 - UPDATE COPYRIGHT NOTICE AND DELETE PRE-V4.1 EDIT HISTORY
; UPD ID= 80, SNARK:<6.EXEC>EXECSE.MAC.16,  20-Dec-81 18:10:18 by CHALL
;TCO 6.1049 .LOCAT- DON'T REQUIRE "::" IN NODE NAME (SET CM%NSF)
; UPD ID= 77, SNARK:<6.EXEC>EXECSE.MAC.15,   6-Nov-81 12:59:10 by CHALL
;TCO 5.1602 ALRDL7- FIX: "SET NO AL BEF" CLEARED ALL ALERTS
; UPD ID= 42, SNARK:<6.EXEC>EXECSE.MAC.12,  27-Aug-81 14:31:40 by GROUT
;TCO 5.1477 .PAXL- ADD ERJMP CJERRE AFTER SCVEC
; UPD ID= 41, SNARK:<6.EXEC>EXECSE.MAC.11,  21-Aug-81 14:31:40 by CHALL
;ADD DEFAULTS FOR THESE COMMANDS, WHICH TAKE A SINGLE KEYWORD:
;"SET DEF TAKE NO", "SET DIR NO", "^ESET TERM"
; UPD ID= 38, SNARK:<6.EXEC>EXECSE.MAC.9,  19-Aug-81 10:57:37 by CHALL
;TCO 5.1463 .NODEF: MOVE "SET NO DEFAULT" OPTIONS TABLE TO EXECCA
; UPD ID= 22, SNARK:<6.EXEC>EXECSE.MAC.8,  17-Aug-81 10:19:31 by CHALL
;TCO 5.1454 CHANGE NAME FROM XDEF TO EXECDE
;.TYPEO: MAKE "MODE" BE THE DEFAULT FOR SET TYPEOUT
;TCO 5.1443 - TJSYS: ALLOW SET TRAP JSYS TO TAKE OCTAL ARGUMENTS
; UPD ID= 3, SNARK:<6.EXEC>EXECSE.MAC.6,  14-Jul-81 12:54:32 by CHALL
;TCO 5.1411 - DMODE: NEED TO SET LENGTH IN GTDIR BLOCK
; UPD ID= 2257, SNARK:<6.EXEC>EXECSE.MAC.4,  26-Jun-81 09:12:33 by CHALL
;TCO 5.1388 - .ALERT: IF NEW ALERT IS AT SAME TIME AS AN OLD ONE, SUPERCEDE OLD
;<6.EXEC>EXECSE.MAC.3, 12-Jun-81 14:18:33, EDIT BY HELLIWELL
;MAKE .KFRKC AND .NOLM INTERNAL (::)
; UPD ID= 1729, SNARK:<6.EXEC>EXECSE.MAC.2,  18-Mar-81 16:34:40 by OSMAN
;tco 6.1007 - Fix "SET ALERT +0" to not set alert to be tomorrow.
;REMOVE MFRK CONDITIONALS
;<4.EXEC>EXECSE.MAC.1, 28-Jul-80 15:06:24, Edit by DK32
;Programmable Command Language
; UPD ID= 1439, SNARK:<5.EXEC>EXECSE.MAC.18,  15-Jan-81 10:52:03 by OSMAN
;Tco 5.1233 - Make FILE-OPENINGS and JSYS OPENF independent
; UPD ID= 1427, SNARK:<5.EXEC>EXECSE.MAC.17,   9-Jan-81 11:18:02 by OSMAN
;More 5.1225 - Make "SET TRAP NO" and "SET NO TRAP" equivalent.  Also,
;make "SET NO TRAP<cr>" get rid of all traps
; UPD ID= 1402, SNARK:<5.EXEC>EXECSE.MAC.16,   6-Jan-81 10:28:05 by OSMAN
;tco 5.1225 - Implement jsys trapping and file-opening trapping!
; UPD ID= 1386, SNARK:<5.EXEC>EXECSE.MAC.15,  29-Dec-80 09:12:09 by OSMAN
; Make SET NO ALERT take input the same as SET ALERT, so SET ALERT 300 followed
;immediately by SET NO ALERT 300 will usually work (not always since day may
;change!)
; UPD ID= 1338, SNARK:<5.EXEC>EXECSE.MAC.14,   8-Dec-80 10:07:54 by ACARLSON
;<GALAXY.DEVELOPMENT>EXECSE.MAC.2,  8-Dec-80 09:55:28, EDIT BY ACARLSON
;TCO 5.1210 - Add commands ^ESET (NO) PRIVATE-QUASAR for debugging GALAXY
; UPD ID= 1325, SNARK:<5.EXEC>EXECSE.MAC.13,   1-Dec-80 16:02:58 by OSMAN
; UPD ID= 1203, SNARK:<5.EXEC>EXECSE.MAC.12,  27-Oct-80 14:32:35 by OSMAN
;Fix SET NO ALERT
; UPD ID= 1132, SNARK:<5.EXEC>EXECSE.MAC.11,   6-Oct-80 10:44:10 by OSMAN
;tco 5.1167 - Remove "SET FILE [NO] AUTOKEEP"
; UPD ID= 1045, SNARK:<5.EXEC>EXECSE.MAC.10,  25-Sep-80 14:21:53 by OSMAN
;tco 5.1156
; UPD ID= 1027, SNARK:<5.EXEC>EXECSE.MAC.9,  22-Sep-80 10:38:01 by OSMAN
;tco 5.1150 - Add SET PROGRAM
; UPD ID= 859, SNARK:<5.EXEC>EXECSE.MAC.8,  10-Aug-80 15:20:23 by OSMAN
;tco 5.1129 - Add symbolic address and expression support
; UPD ID= 804, SNARK:<5.EXEC>EXECSE.MAC.7,  28-Jul-80 10:25:44 by OSMAN
;tco 5.1114 - Don't give error on SET NO ALERT if none to remove
;<5.EXEC>EXECSE.MAC.6, 30-May-80 16:49:20, EDIT BY MURPHY
;PUT NEW MAIL WATCH AND ALERT UNDER NEWF
; UPD ID= 539, SNARK:<5.EXEC>EXECSE.MAC.5,  20-May-80 15:46:45 by MURPHY
;CHANGE SOME XTND TO NEWF OR MFRK
; UPD ID= 520, SNARK:<5.EXEC>EXECSE.MAC.4,  14-May-80 13:20:26 by OSMAN
;Don't make past time mean tomorrow if date was typed
; UPD ID= 495, SNARK:<5.EXEC>EXECSE.MAC.3,  30-Apr-80 14:34:58 by OSMAN
;Fix confirmation on TAKE subcommands and SET DEFAULT TAKE
;<4.1.EXEC>EXECSE.MAC.6, 25-Mar-80 10:39:43, EDIT BY OSMAN
;More ONEWRD fixes on SET PAGE-ACCESS
;<4.1.EXEC>EXECSE.MAC.5, 17-Mar-80 14:07:49, EDIT BY OSMAN
;Get rid of ONEWRD checks
; UPD ID= 93, SNARK:<4.1.EXEC>EXECSE.MAC.4,   5-Dec-79 10:24:11 by OSMAN
;tco 4.2589 - Change $DEFAU to TDEFAU to not conflict with GLXLIB
;<4.1.EXEC>EXECSE.MAC.2, 20-Nov-79 14:01:16, EDIT BY OSMAN
;TCO 4.1.1023 - Fix TAKE stuff
;TOPS20 'EXECUTIVE' COMMAND LANGUAGE

;THIS SOFTWARE IS FURNISHED UNDER A LICENSE AND MAY ONLY BE USED
;  OR COPIED IN ACCORDANCE WITH THE TERMS OF SUCH LICENSE.
;
;COPYRIGHT (C) 1980,1981,1982,1983 BY DIGITAL EQUIPMENT CORPORATION, MAYNARD, MASS.

	SEARCH EXECDE
	TTITLE EXECSE

;THIS FILE CONTAINS
;SET AND ^ESET COMMANDS

DEFINE SETSTG
<	TRVAR <ATIME,NOW,AHELP,<ARANGE,2>,ENTADR,WBITS,SETNOF,CDRDEV,CDRSTR,CDRDCK,DIRP,PASSP,<SEBLK,GTDLN>,SPERF,SPCNT,SPPAG,SPERR,ACDIR> ;KEEP DEV,STR,DCK IN ORDER FOR JSYS
>
;"ESET" AND "ESET NO"

ESET::	SETSTG			;ALLOCATE LOCAL STORAGE
	SETZM SETNOF		;CLEAR NO FLAG
	KEYWD $ESET
	 0
	 JRST CERR
	TXNN P3,NOLG		;NEED TO BE LOGGED IN?
	SKIPE CUSRNO		;YES, ARE WE?
	CAIA			;OK
	ERROR <LOGIN please>
	JRST (P3)		;DISPATCH TO COMMAND

;"SET" AND "SET NO"

.SET::	SETSTG			;ALLOCATE STORAGE
	SETZM SETNOF		;CLEAR NO FLAG
	KEYWD $SET0
	 0
	 JRST CERR
	TXNN P3,NOLG		;NEED TO BE LOGGED IN?
	SKIPE CUSRNO		;YES, ARE WE?
	CAIA			;OK
	ERROR <LOGIN please>
	JRST (P3)		;DISPATCH TO COMMAND

;SET ACCOUNT

.CHANG::NOISE <TO>		;OR STRING.
	CALL ACCT		;INPUT, CHECK, CONVERT ACCT INTO A (USES A B1)
	PUSH P,A		;SAVE POINTER TO ACCOUNT
	NOISE (SESSION REMARK)
	CALL GSR		;GET SESSION REMARK
	EXCH A,(P)		;GET ACCOUNT, SAVE REMARK
	CONFIRM
	CACCT			;JSYS TO CHANGE ACCOUNT #
	 CALL CJERR
	POP P,A			;GET SESSION REMARK POINTER
	CALL SSR		;SET SESSION REMARK
	JRST CMDIN4

;ACCOUNT (OF FILE) <NAME> (IS) <ACCOUNT # OR STRING>

.ACCOU::NOISE <OF FILES>
	CALL INFGNS		;* VERSION, NO SEARCH, GROUP OK
	MOVE B,INIFH1		;START HERE
	MOVEM B,OUTDSG
	CAIA
ACCOU3:	AOS B,OUTDSG
	CAMLE B,INIFH2		;ALL GONE YET?
	JRST [	MOVX A,1B1	;INDICATE STRING ACCOUNT
		JRST ACCOU4]
	HRRZ A,(B)
	CAIN A,-2		;FOUND REAL JFN YET?
	JRST ACCOU3		;NO, KEEP LOOKING
	DVCHR			;DEVICE CHARACTERISTICS
	LDB A,[POINT 9,B,17]	;DEVICE TYPE
	CAIE A,.DVDSK
	JRST ACCOU3		;LOOP TILL WE FIND ONE

;DETERMINE WHETHER SPECIFIED FILE TAKES STRING OR NUMERIC ACCOUNT

	STKVAR <<ABUF,FILWDS>>
	HRROI A,ABUF
	HRRZ B,@OUTDSG
	LDF C,1B2+1B5+JS%PAF	;GET STR:<DIR>
	JFNS			;GET STRING
	 ERCAL JERRE
	MOVSI A,(RC%EMO)	;NO RECOGNITION
	HRROI B,ABUF
	RCDIR			;CONVERT STRING BACK TO DIR # TO GET BITS
	TLNE A,(RC%NOM+RC%AMB)	;SKIP IF EXACT MATCH
	 JRST ACCOU3		;TRY TO FIND LEGAL ONE
ACCOU4:	NOISE <TO>
	CALL ACCT		;GET ACCOUNT # OR STRING, USING A.
	CONFIRM
	MOVEM A,ACDIR		;SAVE ACCT # OR STRING HERE
	SETOM TYPGRP		;TYPE FILES
	MOVE A,JBUFP		;GET POINTER TO JFN STACK
	MOVEM A,.JBUFP		;MARK HOW FAR BACK TO RELEASE JFNS
ACCOU1:	CALL RLJFNS		;RELEASE TEMPORARY JFNS
	CALL NXFILE		;CHECK FOR NON-EX FILE TERM
	 JRST ACCOU2		;GO SEE IF ANY MORE TO DO
	CALL TYPIF		;TYPE NAME, GET JFN
	CALL MFINP		;GET A TEMP JFN AND STEP TO NEXT FILE
	 JRST ACCOU2		;FAILED
	MOVE B,ACDIR		;ACCT # OR STRING PTR
	SACTF			;SET ACCOUNT OF FILE
	 JRST [	TYPE <  >
		CALL $ERSTR
		ETYPE<%_>
		JRST ACCOU2]
	CALL TYPOK
ACCOU2:	SKIPE INIFH1		;ANYTHING LEFT TO BE DONE?
	JRST ACCOU1		;YES, LOOP BACK FOR REST OF FILES
	RET
;SET ADDRESS-BREAK

.ADDRE::SKIPGE SETNOF		;"NO" TYPED?
	JRST [	CONFIRM		;YES, CONFIRM IT
		SKIPG A,FORK	;FORK HANDLE
		ERROR <No program>
		HRLI A,.ABCLR	;FUNCTION TO REMOVE BREAKS
		ADBRK		;DO IT
		 ERJMP CJERRE	;FAILED-- TYPE ERROR STRING
		SETZM ABKCNT	;ZERO REPEAT COUNT
		RET]		;AND RETURN
	PUSH P,P1		;GET A SAFE REGISTER
	SETZ P1,		;CLEAR IT (HOLDS FLAG BITS)
	NOISE <AT>
	ADDRX <Location on which to break>
	 ERROR <Invalid address>
	TDNN B,[777776,,777760]	;CAN'T SET BREAK ON ANY ACS
	ERROR <Address break won't work on the ACs>
	TLNE B,777740		;CHECK FOR TOO LARGE AN ADDRESS
	ERROR <Break address not between 0 and 37,,777777>
	PUSH P,B		;SAVE ADDRESS
	CALL SPRTR		;CHECK FOR COMMA OR CONFIRM
	 SUBCOM $ADBK		;COMMA TYPED, GET SUBCOMMANDS
	TRZN P1,1		;ANY SUBCOMMANDS TYPED?
	TXO P1,AB%RED!AB%WRT!AB%XCT ;NO, TAKE DEFAULTS
	SKIPG A,FORK		;FORK HANDLE
	ERROR <No program>
	HRLI A,.ABSET		;FUNCTION TO SET BREAK
	POP P,B			;RECOVER ADDRESS
	MOVE C,P1		;PUT FLAGS IN RIGHT AC
	POP P,P1		;RESTORE P1
	ADBRK			;SET IT
	 ERJMP CJERRE		;FAILED-- SAY WHY
	RET			;AND RETURN

$ADBK:	TABLE
	T AFTER,,.AFT
	T ALL,,.ALL
	T EXECUTE,,.EXE
	T NONE,,.NON
	T READ,,.REA
	T WRITE,,.WRI
	TEND

.AFT:	DECX <Number of times to allow reference before trapping, in decimal>
	 CMERRX
	NOISE <REFERENCES>
	MOVEM B,ABKCNT		;REMEMBER IT
	CALLRET CONF		;CONFIRM AND RETURN

.ALL:	TXO P1,AB%RED!AB%WRT!AB%XCT!1
	NOISE <TYPES OF REFERENCES>
	CALLRET CONF		;CONFIRM AND RETURN

.EXE:	TXOA P1,AB%XCT!1
.REA:	TXO P1,AB%RED!1
	NOISE <REFERENCES>
	CALLRET CONF		;CONFIRM AND RETURN

.WRI:	TXOA P1,AB%WRT!1
.NON:	TXOA P1,1
	NOISE <REFERENCES>
	CALLRET CONF		;CONFIRM AND RETURN
.SETNO::SETOM SETNOF		;FLAG NO TYPED
	KEYWD $SETN
	 0
	 JRST CERR
	TXNN P3,NOLG		;NEED TO BE LOGGED IN?
	SKIPE CUSRNO		;YES, ARE WE?
	CAIA			;OK
	ERROR <LOGIN please>
	JRST (P3)		;DISPATCH TO COMMAND
;SET TRAP IS FOR CONTROLLING JSYS AND UUO TRAPPING

.TRAP::	KEYWD TRAPT
	 0			;NO DEFAULT
	 CMERRX			;INVALID KEYWORD AFTER "TRAP" TYPED
	CALLRET (P3)		;DO WHAT WAS ASKED AND RETURN

;SET NO TRAP AND SET TRAP NO TURN OFF VARIOUS TRAPPING

TRAPN:	SETOM SETNOF		;REMEMBER THAT "NO" TYPED
NTRAP::	SKIPGE SETNOF		;IS "NO" ALREADY TYPED?
	SKIPA B,[[FLDDB. .CMCFM,CM%SDH,,<Carriage return to turn off all traps>,,[
		 FLDDB. .CMKEY,,TRAPT1]]] ;YES, USE TABLE TRAPT1
        MOVEI B,[FLDDB. .CMCFM,CM%SDH,,<Carriage return to turn off all traps>,,[
		 FLDDB. .CMKEY,,TRAPT]]	;NO, USE TABLE TRAPT
	CALL FLDSKP		;READ WHAT'S AFTER "SET NO TRAP" OR "SET TRAP NO"
	 CMERRX
	LOAD D,CM%FNC,.CMFNP(C)	;GET WHAT WAS TYPED
	CAIN D,.CMCFM		;JUST CARRIAGE RETURN?
	JRST UNTRAP		;YES, GO UNTRAP EVERYTHING
	CALL GETKEY		;KEYWORD TYPED, GET INFO
	CALLRET (P3)

TRAPT:	TABLE
	T FILE-OPENINGS,,FOPEN	;SET TRAP FILE-OPENINGS
	T JSYS,,TJSYS		;SET TRAP JSYS X
	T NO,,TRAPN		;SET TRAP NO
	T PROCEED,,TPROC	;SET TRAP PROCEED
	TEND

TRAPT1:	TABLE
	T FILE-OPENINGS,,FOPEN	;SET TRAP FILE-OPENINGS
	T JSYS,,TJSYS		;SET TRAP JSYS X
	T PROCEED,,TPROC	;SET TRAP PROCEED
	TEND

;SET [NO] TRAP PROCEED CONTROLS WHETHER A JSYS OR UUO TRAPPED PROGRAM
;SHOULD PROCEED AUTOMATICALLY FROM THE TRAP.  THIS COMMAND CONTROLS THE
;CURRENT FORK ONLY.

TPROC:	NOISE (AUTOMATICALLY AFTER TRAPS)
IFN STANSW,<
	CONFIRM
>;IFN STANSW
	SKIPN SETNOF		;DIFFERENT ACTION ACCORDING TO "NO" FLAG
	SETZM TSTOPF		;SET TRAP PROCEED
	SKIPE SETNOF
	SETOM TSTOPF		;SET NO TRAP PROCEED
IFE STANSW,<
	CALLRET CONF		;CONFIRM AND RETURN
>;IFE STANSW
IFN STANSW,<
	RET
>;IFN STANSW

;SET TRAP JSYS X CAUSES AN ANNOUNCEMENT EVERY TIME JSYS X IS EXECUTED
;FOR ANY FORK

TJSYS:	MOVEM P,SAVSP		;SAVE STACK POINTER
	MOVEI A,RESP		;GET CLEANUP ROUTINE
	PUSH P,A		;PUT IT ON STACK
	SETZM Q3		;RESET FLAG
	NOISE (NAMED OR NUMBERED)
	MOVEI B,[FLDDB. .CMSWI,CM%DPP,JSWI,,</DEFINED>,[
		 FLDDB. .CMNUM,CM%SDH,10,<Octal JSYS number>,,[
		 FLDBK. .CMKEY,CM%SDH,JTAB,<JSYS name>,,[
		   BRMSK. (KEYB0.,KEYB1.,KEYB2.,KEYB3.,<%>)],]]]

	JRST PRSJ0		;GO PARSE INPUT

PRSJSY:	SETOM Q3		;INDICATE PAST FIRST FIELD
	MOVEI B,[FLDDB. .CMNUM,CM%SDH,10,<Octal JSYS number>,,[
		 FLDBK. .CMKEY,CM%SDH,JTAB,<JSYS name>,,[
		   BRMSK. (KEYB0.,KEYB1.,KEYB2.,KEYB3.,<%>)]]]
PRSJ0:	CALL SAVCM		;SAV COMND POINTERS
	CALL FLDSKP		;READ JSYS NAME OR NUMBER
PRSJ1:	JRST	[SKIPN Q3
		ETYPE <%@?JSYS name, JSYS number or switch required:  %b%%_>
		SKIPE Q3
		ETYPE <%@?JSYS name or JSYS number required:  %b%%_>
		MOVE P,SAVSP	;RESET STACK MANUALLY
		RET ]
PRSJ2:	LOAD D,CM%FNC,.CMFNP(C)	;SEE WHAT WAS TYPED
NAMTST:	CAIE D,.CMKEY		;NAME?
	JRST NUMTST		;NO
	HRRZI A,-JTAB(B)	;GET THE JTAB INDEX
	LDB A,[POINT 9,JTAB(A),26] ;GET THE JSYS NUMBER
	PUSH P,A		;STORE ON STACK
	JRST PRSCOM		;TRY FOR COMMA/CONFIRM
NUMTST:	CAIE D,.CMNUM		;AN OCTAL NUMBER?
	JRST SWTST		;NO
	SKIPLE B		;GREATER THAN ZERO?
	CAIL B,JLEN		;LESS THAN MAX JSYS?
	JRST [ETYPE <%@?Not a valid JSYS number:  %b%%_>
	     MOVE P,SAVSP	;RESET STACK
	      CALLRET RESCM]	;BACK UP TO PREVIOUS ATOM
	PUSH P,B		;SAVE VALUE
	JRST PRSCOM		;TRY FOR COMMA/CONFIRM
SWTST:	SKIPN Q3		;SKIP TEST 2- N'TH TIME
	CAIE D,.CMSWI		;A SWITCH?
	JRST PRSJ1		;NO, GO COMPLAIN
	JRST [	CALL GETKEY	;YES, SEE WHICH ONE
		JRST (P3)]	;GO EXECUTE THE SWITCH

PRSCOM:	MOVEI B,[FLDDB. .CMCMA,,,,,[
		 FLDDB. .CMCFM]]
	CALL FLDSKP
PRSCM1:	JRST [ETYPE <?Comma or confirmation required%_>
	     RET]
	LOAD D,CM%FNC,.CMFNP(C)	;SEE WHAT WAS TYPED
CMATST:	CAIN D,.CMCMA		;COMMA?
	JRST PRSJSY		;YES - BACK FOR MORE

CFMTST:	CAIE D,.CMCFM		;CONFIRMED?
	JRST PRSCM1		;NO - GO COMPLAIN, UNKNOWN ATOM


POPLP:	HRRZ A,(P)		;GET TOP OF STACK
	CAIN A,RESP		;DONE ALL?
	JRST SETBR		;YES, SET TRAP STATUS AND RETURN

	POP P,A			;GET THE JSYS NUMBER
	CAMN A,[FLD(OPENF,YFLD)];IS THIS OPENF?
	JRST [	SETCM C,SETNOF	;YES, GET CORRECT VALUE FOR TOPENF
		MOVEM C,TOPENF	;REMEMBER WHETHER WE'RE TRAPPING OPENF OR NOT
		JRST .+1]

	MOVE C,A		;GET THE JSYS NUMBER
	MOVE Q1,A		;ALSO GET IT HERE
	MOVE D,[POINT 1,JSBDEF]	;GET BYTE POINTER TO BIT MASK
	ADJBP C,D		;INCREMENT TO THE BIT FOR THAT JSYS
	ILDB D,C		;GET THE BIT
	MOVEI B,JSBDEF		;GET ADDRESS OF BREAK MASK
	SKIPN SETNOF		;CLEAR OR SET BIT ACCORDING TO YES OR NO
	JRST SETB		;SET IT

	JUMPE D,POPLP		;IT WAS ALREADY CLEAR, BACK FOR NEXT JSYS
	LDB D,[POINT 9,JTAB(Q1),35]  ;BIT WAS SET.  DEFINED JSYS?
	SKIPE D			; ...
	SOS TRAPD		;IT WAS DEFINED
	SKIPN D			;...
	SOS TRAPU		;IT WAS UNDEFINED
	CALL CLRBIT		;AND CLEAR THE BIT
	JRST POPLP		;BACK FOR NEXT JSYS

SETB:	JUMPN D,POPLP		;THE BIT WAS ALREADY SET, BACK FOR NEXT JSYS
	LDB D,[POINT 9,JTAB(Q1),35]  ;BIT WAS CLEAR.  DEFINED JSYS?
	SKIPE D			;...
	AOS TRAPD		;IT WAS DEFINED
	SKIPN D			;...
	AOS TRAPU		;IT WAS UNDEFINED
	CALL SETBIT		;SET IT
	JRST POPLP		;BACK FOR NEXT JSYS

SETBR:	CALL MRKTRP		;SET UP NEW TRAP STATUS
SJTRET:	RET			;RETURN

RESP:	MOVE P,SAVSP		;THIS IS A STACK CLEAN-UP ROUTINE
	RET

;JSWI IS TABLE OF SWITCHES FOR SET TRAP JSYS

JSWI:	TABLE
	T ALL,,JALL		;SET TRAP JSYS /ALL
	T DEFINED,,JDEF		;  /DEFINED
	T UNDEFINED,,JUND	;  /UNDEFINED
	TEND

;UNTRAP UNTRAPS EVERYTHING

UNTRAP:	SETZM TFILEF		;SAY WE'RE NOT TRAPPING FILE-OPENINGS
	CALLRET JALL3		;GO UNTRAP ALL JSYS'S TOO

;JALL CONFIRMS AND EXECUTES "SET (NO) TRAP JSYS /ALL"

JALL:	CONFIRM			;NOTE THAT SWITCH INTEAD OF KEYWORD ALLOWS A JSYS TO BE CALLED "ALL"
JALL3:	MOVEI A,JSBDEF		;SAY WHERE BLOCK IS
	SKIPE SETNOF		;CLEAR OR SET ALL BITS ACCORDING TO "NO"
	JRST JALNO		;GO HANDLE SET NO TRAP JSYS /ALL
	CALL SETALL
	SETOM TOPENF		;SAY OPENF SHOULD BE TRAPPED
	MOVEI B,SJLEN		;GET DEFINED COUNT
	MOVEM B,TRAPD		;SAVE IT
	MOVEI A,JLEN-1		;GET TOTAL COUNT
	SUB A,B			;GET UNDEFINED COUNT
	MOVEM A,TRAPU		;SAVE IT
	JRST JALL2

JALNO:	CALL CLRALL
	SETZM TRAPU		;CLEAR UNDEFINED COUNT
	SETZM TRAPD		;CLEAR DEFINED COUNT
	SETZM TOPENF		;SAY OPENF IS NOT BEING TRAPPED AS A JSYS
JALL2:	MOVE A,FORK		;SAY WHICH FORK
	CALLRET MRKTRP		;SET UP NEW TRAP STATUS


	;JDEF COMFIRMS AND EXECUTES SET (NO) JSYS TRAP /DEFINED

JDEF:	CONFIRM
	SETOM TOPENF		;ASSUME TRAPPING OPENF
	SKIPE SETNOF		;DID HE SAY NO?
	SETZM TOPENF		;YES, SAY OPENF SHOULD NOT BE TRAPPED

	MOVE Q1,[-SJLEN,,1]	;GET AOBJN POINTER
JDSLP:	LDB C,[POINT 9,JTAB(Q1),26] ;GET THE JSYS NUMBER
	MOVEM C,A		;KEEP A COPY IN A
	MOVE B,[POINT 1,JSBDEF]	;GET BYTE POINTER TO BIT MASK
	ADJBP C,B		;INCREMENT TO THE BIT FOR THAT JSYS
	ILDB C,C		;GET THE BIT
	MOVEI B,JSBDEF		;GET MASK ADDRESS
	SKIPN SETNOF		;CLEAR OR SET ALL BITS ACCORDING TO "NO"
	CALL SETBIT		;SET THE BIT
	SKIPE SETNOF		;...
	CALL CLRBIT		;CLEAR THE BIT
JDSN:	AOBJN Q1,JDSLP		;BACK FOR MORE
	MOVEI A,SJLEN		;GET NUMBER OF DEFINED JSYSES
	MOVEM A,TRAPD		;MAKE THAT THE COUNT
	SKIPE SETNOF		;DID HE SAY NO?
	SETZM TRAPD		;YES
	CALLRET MRKTRP		;SET UP NEW TRAP STATUS

	;JUND COMFIRMS AND EXECUTES SET (NO) JSYS TRAP /UNDEFINED

JUND:	CONFIRM
	MOVE Q1,[-JLEN+1,,1]	;GET INCREMENTED AOBJN POINTER
JUSLP:	LDB A,[POINT 9,JTAB(Q1),35] ;IS THIS AN UNDEFINED JSYS?
	JUMPN A,JUSN		;NO
	HRRZ D,Q1		;GET THE JSYS NUMBER
	MOVE B,[POINT 1,JSBDEF]	;GET BYTE POINTER TO BIT MASK
	ADJBP D,B		;INCREMENT TO THE BIT FOR THAT JSYS
	ILDB D,D		;GET THE BIT
	HRRZ A,Q1		;GET JSYS NUMBER
	MOVEI B,JSBDEF		;GET MASK ADDRESS
	SKIPN SETNOF		;CLEAR OR SET ALL BITS ACCORDING TO "NO"
	CALL SETBIT		;SET THE BIT
	SKIPE SETNOF		;...
	CALL CLRBIT		;CLEAR THE BIT
JUSN:	AOBJN Q1,JUSLP		;BACK FOR MORE
	MOVEI A,JLEN-1		;GET NUMBER OF ALL JSYS'S
	SUBI A,SJLEN		;SUBTRACT DEFINED JSYS'S
	MOVEM A,TRAPU		;MAKE THAT THE COUNT
	SKIPE SETNOF		;DID HE SAY NO?
	SETZM TRAPU		;YES
	CALLRET MRKTRP		;SET UP NEW TRAP STATUS



	;HERE WE BUILD A TBLUK-FORMAT TABLE THAT GETS SORTED IN THE
	;EXEC'S ONCE-ONLY CODE.

DEFINE DEFJS (NAME,VALUE,TRASH,NIM,OLDNEW)
<
	IFB <NIM>,<
	  RELOC JTAB+VALUE	;;ALLOW FOR GAPS IF SOME JSYSES UNDEFINED
	  IFB <OLDNEW>,<
		[1B7
		ASCIZ/NAME'%/],,VALUE_9
		>
	  IFIDN <OLDNEW><OLD>,<
		[1B7
		ASCIZ/NAME/],,VALUE_9
		>
		   SJLN=SJLN+1
	  >

	IFG VALUE-LARGST,<LARGST==VALUE>
>


	LARGST==0
JTAB::	SJLEN,,JLEN
	SJLN=0			;RESET COUNTER
	JSLIST			;USE JSYS LISTER FROM MONSYM (CALLS DEFJS)
	JLEN==:.-JTAB		;LENGTH OF TABLE
	RELOC JTAB+LARGST+1	;ALLOW FOR JSYSES NOT BEING IN ORDER IN JSLIST
	SJLEN==:SJLN		;COUNT OF ALL DEFINED JSYS'S
;SET TRAP FILE-OPENINGS causes all forks' file-openings to be announced

FOPEN:	CONFIRM			;MAKE SURE HE MEANS IT
	SETCM A,SETNOF		;SET OR CLEAR TFILEF ACCORDING TO SETNOF
	MOVEM A,TFILEF
;	CALLRET MRKTRP		;GO UPDATE TRAP STATUS

;MRKTRP MARKS THAT TRAP STATUS HAS CHANGED AND HENCE HAS TO BE UPDATED.
;IT IS NOT UPDATED IMMEDIATELY, BECAUSE DOING SO CAN PREVENT EXECUTE-ONLY
;PROGRAMS FROM BEING LOADED WITH GET JSYS, SINCE SETTING TRAPS MAKES
;THE PROCESS NON-VIRGIN

MRKTRP::SETZM TRPOKF		;SAY TRAPS ARE NOT OK
	LOAD A,YFLD,[OPENF]	;GET BIT POSITION OF OPENF JSYS
	MOVEI B,JSBDEF		;POINT AT TRAP BITS
	CALL CLRBIT		;FIRST CLEAR THE BIT
	LOAD A,YFLD,[OPENF]	;GET BIT POSITION OF OPENF JSYS
	MOVEI B,JSBDEF		;POINT AT TRAP BITS
	SKIPN TOPENF		;TURN OPENF BIT ON IF TRAPPING OPENF JSYS
	SKIPE TFILEF		;OR IF TRAPPING FILE-OPENINGS
	JRST SETBIT
	RET

.CIDLY::NOISE <FOR COMMANDS>
	CALL CONF		;CONFIRM
	SETCM A,SETNOF
	MOVEM A,CIDLYF
	RET

IFN NICSW,<			;[NIC1017]
;[NIC1017] SET HISTORY

.SEHST::SKIPE SETNOF		;[NIC1017] WAS "NO" SPECIFIED
	 JRST .SEHS1		;[NIC1017] YES
	DECX <Decimal number of commands to remember> ;[NIC1017] GET NUMBER
	 CMERRX			;[NIC1017] BAD INPUT
	CAIG B,HSTMAX		;[NIC1017] LARGER THAN MAX?
	 JUMPG B,.SEHS2		;[NIC1017] INPUT IS LEGIT.
	MOVEI A,HSTMAX+1	;[NIC1017] GET MAX NUMBER
	ETYPE <?Number must be larger than zero but smaller then %1Q>
	RET			;[NIC1017] AND RETURN
.SEHS1:	SETZ B,			;[NIC1017] SET NO HISTORY
.SEHS2:	CONFIRM			;[NIC1017] GET EOL
	PUSH P,B		;[NIC1017] SAVE NEW VALUE
	SKIPN A,HCNT		;[NIC1017] DO WE HAVE ANYTHING NOW?
	 JRST .SEHS4		;[NIC1017] NO, SO JUST GO ALLOCATE ANEW
	MOVEM A,CNUM		;[NIC1017] SAVE THIS NUMBER FOR LATER
.SEHS3:	HLRZ C,HPTR		;[NIC1017] GET ADDRESS OF PTR BLOCK
	ADD C,HCNT		;[NIC1017] LOOK AT EACH STRING
	SUBI C,1		;[NIC1017] BASE 0. OFFSET CORRECTLY
	SKIPE A,(C)		;[NIC1017] GET PTR TO COMMAND STRING
	 CALL STREM		;[NIC1017] RETURN IF NOT NULL
	SOSE HCNT		;[NIC1017] WORK UP THE LIST
	 JRST .SEHS3		;[NIC1017] UNTIL IT IS EXHAUSTED
	MOVE A,CNUM		;[NIC1017] GET NUMBER OF WORDS TO RETURN
	HLRZ B,HPTR		;[NIC1017] ADDRESS OF PTR BLOCK
	CALL RETBUF		;[NIC1017] RETURN IT
.SEHS4:	POP P,A			;[NIC1017] GET NEW COUNT BACK
	MOVEM A,HCNT		;[NIC1017] AND SAVE IT
	SKIPN A			;[NIC1017] DON'T CALL ALLOCATION ROUTINE
	 JRST R			;[NIC1017] SKIP THIS MESS
	CALL GTBUFX		;[NIC1017] IF NON-ZERO, GET PERM. SPACE
	HRLZM A,HPTR		;[NIC1017] SAVE ADDRESS OF PTR BLOCK
	ADD A,HCNT		;[NIC1017] MAKE PTR POINT TO LAST ENTRY
	HRRM A,HPTR		;[NIC1017] AND SAVE IT
	MOVN A,HCNT		;[NIC1017] GET -NUMBER OF WORDS TO CLEAR
	HRLZS A			;[NIC1017] MOVE TO LEFT HALF
	HLR A,HPTR		;[NIC1017] GET BASE ADDRESS BACK
	SETZM (A)		;[NIC1017] CLEAR ALL WORDS TO ZERO
	AOBJN A,.-1		;[NIC1017] UNTIL DONE
	SETZM CNUM		;[NIC1017] ALWAYS RESET COMMAND COUNT
	RET			;[NIC1017] AND THEN RETURN
>;IFN NICSW

;SET LOCATION

IFN STANSW,<
IFN LOTSW,<
NEWFDB:	FLDDB. (.CMNOD,CM%PO)	;ALTERNATIVE FDB FOR PARSING
>;IFN LOTSW
>;IFN STANSW

.LOCAT::NOISE (TO)
	STKVAR <<NODFDB,.CMDEF+1>>
IFE STANSW,<
	MOVX A,FLD(.CMNOD,CM%FNC)!CM%PO!CM%DPP!CM%NSF
>;IFE STANSW
IFN STANSW,<
IFE LOTSW,<
	MOVX A,FLD(.CMNOD,CM%FNC)!CM%PO!CM%DPP!CM%NSF
>;IFE LOTSW
IFN LOTSW,<
	MOVX A,FLD(.CMKEY,CM%FNC)!CM%DPP+NEWFDB
>;IFN LOTSW
>;IFN STANSW
	MOVEM A,.CMFNP+NODFDB	;NODE FUNCTION, PARSE ONLY, DEFAULT PRESENT
IFN STANSW,<
IFN LOTSW,<
	MOVEI A,[3,,3
		[ASCIZ/CERAS/],,[ASCIZ/CERAS/]
		[ASCIZ/REMOTE/],,[ASCIZ/CERAS/]
		[ASCIZ/TERMAN/],,[ASCIZ/TERMAN/]
		]
	MOVEM A,.CMDAT+NODFDB
>;IFN LOTSW
>;IFN STANSW
	CALL GETNOD		;GET POINTER TO OUR NODE NAME
	 JRST [	MOVX A,CM%DPP	;FAILED, PROBABLY NO DECNET ON THIS SYSTEM
		ANDCAM A,.CMFNP+NODFDB	;SAY NO DEFAULT PRESENT
		JRST .+1]
	MOVEM A,.CMDEF+NODFDB	;STORE POINTER TO DEFAULT
	MOVEI B,NODFDB
	CALL FLDSKP		;READ NODE NAME, DEFAULT TO SYSTEM'S
	 CMERRX			;FAILED, TELL USER WHY
IFN STANSW,< 
IFN LOTSW,<
	LDB D,[331100,,(C)]	;GET FUNCTION CODE
	CAIN D,.CMKEY		;KEYWORD?
	 JRST [	HRRO A,(B)	;GET POINTER TO NODE FOUND
		JRST .+2 ]	;AND GO CONFIRM
>;IFN LOTSW
>;IFN STANSW
	CALL BUFFF		;REMEMBER NODE NAME TYPED BY USER
	CONFIRM			;WAIT FOR COMMAND CONFIRMATION
	MOVE C,A		;POINTER TO NODE NAME POINTER IN C
	HRROI A,-1		;OURSELF
	MOVEI B,.SJLLO		;SET LOGICAL LOCATION
	SETJB			;DO IT
	 ERCAL CJERRE		;FAILED, TELL USER WHY
	RET			;DONE
;MORE COMPREHENSIVE MAIL-WATCH AND ALERT FACILITY

.MWATC::NOISE <FOR USER>
	CALL USRNAM		;INPUT USER NAME
	 ERROR <No such user>
	STKVAR <USRNUM>
	MOVEM C,USRNUM		;SAVE USER NUMBER
	SKIPE SETNOF		;SET NO?
	 JRST .MWAT0		;TURN WATCH OFF
	NOISE <MESSAGE COUNT>
	DEFX <10000>		;DEFAULT TO LOTS
	DECX <Number of times to tell of old "new" mail>
	 HRLOI B,377777		;+INF IF NONE TYPED
	MOVE Q1,B		;SAVE COUNT
.MWAT0:	CONFIRM
	MOVE A,USRNUM		;USER NUMBER
	MOVEI C,NMWAT-1		;INIT COUNT
	SETO D,
.MWAT1:	SKIPN B,MWATDR(C)	;LOOK FOR EMPTY SLOT
	 SKIPA D,C		;SAVE INDEX
	  CAME A,B		;MATCH USER?
	   JRST .MWAT2		;FOUND EMPTY SLOT
	SKIPN SETNOF		;FOUND USER - SET NO?
	 JRST .MWAT3		;MATCH FOUND USE IT INSTEAD
	SETZM MWATDR(C)		;TURN OFF MAIL WATCH ON THIS ONE
	RET			;DONE

.MWAT2:	SOJGE C,.MWAT1		;LOOP OVER ALL SLOTS
	SKIPE SETNOF		;SET NO?
	 RET			;YES - ALREADY TURNED OFF
	SKIPGE C,D		;HAVE EMPTY SLOT?
	 ERROR <Maximum number of watches used up.>
	MOVEM A,MWATDR(C)	;SET TO WATCH THIS USER
.MWAT3:	SETOM MWATCF		;TURN ON WATCHING
;	SETZM MWATAT		;RESET TIMERS
;	SETZM MWATCT
	MOVEM Q1,MWATN(C)	;STASH REPEAT COUNTS
	MOVEM Q1,MWATN0(C)
	RET			;EXIT

;SET ALERT (AT)

.ALERT::GTAD			;GET VALUE OF NOW FOR DATE DEFAULT IF NOT GIVEN
	MOVEM A,NOW
	SKIPE SETNOF		;SET NO?
	 JRST ALRDEL		;YES - GO DELETE AN ALERT
	NOISE <AT TIME>
	MOVEI A,[ASCIZ /Date and time, or time/]
	CALL REDALT		;READ THE ALERT TIME
	 CMERRX			;COULDN'T
	NOISE <MESSAGE>
	LINEX <Message, must be 80 characters or less>
	 CMERRX
	MOVE A,CMABP		;SAVE STRING IN PERMANENT FREE SPACE
	ILDB C,A		;SEE IF STRING GIVEN
	JUMPE C,.ALRT1		;IF NOT DON'T READ IT
	MOVE A,CMABP		;GET POINTER AGAIN
	CALL XBUFFS
	MOVE C,A		;GET STRING POINTER IN C
.ALRT1:	CONFIRM
	MOVE B,ATIME		;RESTORE TIME
	SKIPG ALRTIM		;ALERTS ON?
	 JRST [	MOVEM B,ALRTIM	;NO - SET UP TIMER
		MOVEM C,REASON	;SAVE THE FIRST ALERT
		RET]		;EXIT - CHECK ON COMMAND RETURN

	MOVSI D,-NALTS		;ALERTS ON - SEE IF THERE IS A DUPLICATE
.ALRT2:	CAMN B,ALRTIM(D)	;GOT AN ALERT AT THIS TIME?
	JRST [	EXCH C,REASON(D) ;YES - SWAP THE NEW MESSAGE FOR THE OLD
		SKIPE A,C	 ;WAS THERE AN OLD MESSAGE?
		 CALLRET STREM	 ;YES - REMOVE IT FROM THE FREE POOL; DONE
		RET]		 ;NO - DONE
	AOBJN D,.ALRT2		;LOOP LOOKING FOR DUPLICATES

	MOVSI D,-NALTS		;NOW SEARCH TABLE FOR AN EMPTY SLOT
	SKIPE ALRTMS(D)		;FIND EMPTY SLOT
	AOBJN D,.-1
	JUMPGE D,[ERROR <Alert table full>]
	CAMG B,ALRTIM		;IS NEW ONE EARLIER THAN CURRENT PENDING?
	 JRST [	EXCH B,ALRTIM	;YES - EXCHANGE TIMES
		EXCH C,REASON	; AND MESSAGE
		JRST .+1]	;AND GO RE-SAVE THE OLD PENDING MESSAGE
	MOVEM B,ALRTMS(D)	;FILL IN SLOT (ORDER LATER)
	MOVEM C,REASON+1(D)
	RET			;DONE

;REDALT READS IN THE INTERNAL TIME-AND-DATE OF AN ALERT.
;
;ACCEPTS:	A/	ADDRESS OF HELP STRING
;
;RETURNS+1:	USER TYPED SOMETHING ELSE
;	+2:	ATIME/	INTERNAL DATE AND TIME

REDALT:	MOVEM A,AHELP		;REMEMBER ADDRESS OF HELP STRING
	UDTR @AHELP
	 RET			;COULDN'T
	TXNE A,DATBIT		;WAS A DATE TYPED?
	JRST AL1		;YES, SO NEVER TRY TO CHANGE THE DAY
	CAMGE B,NOW		;DID HE SPECIFY A TIME BEFORE NOW?
	 ADD B,[1B17]		;YES - ASSUME TOMORROW
AL1:	MOVEM B,ATIME		;SAVE TIME
	RETSKP

;HERE TO REMOVE ONE OR MORE ALERTS

ALRDEL:	MOVEI A,[ASCIZ /Date and time or BEFORE or AFTER time
    at which to remove alert/]
	CALL REDALT		;READ THE TIME
	 JRST ALRDL5		;COULDN'T (MAYBE BEFORE, AFTER, CRLF)
	CONFIRM
	MOVSI D,-<NALTS+1>	;SCAN FULL TABLE AND PENDING
ALRDL2:	MOVE A,ATIME		;DATE/TIME REQUESTED
	SUB A,ALRTIM(D)		;GET DIFFERENCE FROM ENTRY
	MOVM A,A		;ABSOLUTE VALUE
	CAIL A,^D182		;WITHIN ONE MINUTE?
	 JRST ALRDL3		;NO - STEP TO NEXT
	TLO Z,F1		;SAY WE FOUND ONE
	SETZM ALRTIM(D)		;CLEAR ENTRY
	SKIPE A,REASON(D)	;REMOVE MESSAGE
	 CALL STREM		;FROM FREE POOL
	SETZM REASON(D)		;CLEAR POINTER
ALRDL3:	AOBJN D,ALRDL2		;LOOP
	TLNN Z,F1		;FOUND ANY?
	 ERROR <No alerts found>
ALRDL4:	SKIPE ALRTIM		;CLEARED CURRENT PENDING ALERT?
	 RET			;NO - DONE
	SETZ B,			;YES - SET UP FOR TABLE RE-ORDER
	HRLOI Q1,377777
	JRST ALRCH1		;AND GO FIND A NEW ONE
;COME HERE TO PARSE "BEFORE" & "AFTER"

ALRDL5:	SETZB C,Q1		;INIT RANGE VARIABLES
	HRLOI B,377777
	DMOVEM B,ARANGE		;SAVE
	KEYWD $ALERT
	 0			;NO DEFAULT
	 JRST [	CONFIRM		;HANDLE "SET NO ALERT<CR>"
		JRST ALRD5A]
	CALL 0(P3)		;INVOKE SUBR
ALRD5A:	DMOVE B,ARANGE		;GET RANGE TO CHECK
	MOVSI D,-<NALTS+1>	;CHECK ALL
ALRDL6:	CAMG C,ALRTIM(D)
	 CAMGE B,ALRTIM(D)	;THIS ONE?
	  JRST ALRDL7		;NOT IN RANGE
	SETZM ALRTIM(D)		;IN RANGE - DELETE
	SKIPE A,REASON(D)	;REMOVE MESSAGE IF ANY
	 CALL STREM
	SETZM REASON(D)
ALRDL7:	AOBJN D,ALRDL6		;LOOP
	JRST ALRDL4		;RE-ORDER THE TABLE AND FINISH OFF

$ALERT:	TABLE
	T AFTER,,ALRAFT
	T BEFORE,,ALRBEF
	TEND

ALRAFT:	TLOA Z,F2		;FLAG AFTER
ALRBEF:	TLZ Z,F2		;FLAG BEFORE
	NOISE <TIME>
	DTRX <Date and time>
	 CMERRX
	MOVE A,B		;SAVE USER INPUT IN A
	MOVE B,ARANGE		;PREVIOUS TOP RANGE
	TLNE Z,F2		;RE-ORDER DEPENDING ON BEFORE/AFTER
	 SKIPA C,A
	  MOVE B,A		;USER INPUT AT TOP OR BOTTOM
	DMOVEM B,ARANGE		;SAVE ARGS
	CALLRET CONF		;CONFIRM AND RETURN

;CHECK FOR ALERT AND RE-ORDER

ALRCHK::SKIPG B,ALRTIM		;ANY ALERTS PENDING?
	 RET			;NOPE - EXIT
	GTAD			;GET TIME NOW
	CAMGE A,B		;IS IT TIME FOR ALERT
	 RET			;NOPE - EXIT
	SUBI A,^D728		;4 MINUTES
	CAMG A,B		;LATER THAN 4 MINS?
	 TDZA Q1,Q1		;NO - OK
	HRROI Q1,[ASCIZ "%2D "]	;YES - SPECIAL MESSAGE
	MOVE A,COJFN
	DOBE			;WAIT FOR TYPEOUT TO STOP
	TYPE <>		;THEN RING THE CHIMES
	ETYPE <[%5\%%2E% alert>	;START THE MESSAGE
	SKIPE Q1		;IS THE ALERT COMING OUT LATE?
	 ETYPE < at %D %E>	;YES - APOLOGIZE
IFE STANSW,<
	SKIPE B,REASON		;GIVE MESSAGE SAVED
	 TYPE < - >
	ETYPE <%2\]%_>
>;IFE STANSW
IFN STANSW,<
	SKIPN B,REASON		; GIVE MESSAGE SAVED
	 JRST ALRCH0
	TYPE < - >
	UTYPE (B)
ALRCH0:	ETYPE <]%_>
>;IFN STANSW
	GTAD			;GET TIME NOW
	MOVE B,A		; INTO B
	HRLOI Q1,377777		; FOR RE-ORDER
ALRCH1:	MOVSI D,-NALTS
	SETO C,			;INIT FLAG
ALRCH2:	SKIPN A,ALRTMS(D)	;GOT AN ENTRY?
	 JRST ALRCH3		;NO - SKIP IT
	CAMG A,Q1		;YES - WITHIN RANGE
	 CAMG A,B
	  JRST [SETZM ALRTMS(D)	;OUT OF RANGE - REMOVE IT
		SKIPE A,REASON+1(D)
		 CALL STREM
		SETZM REASON+1(D)
		JRST ALRCH3]
	SKIPL C			;FOUND ONE YET?
	 CAMGE A,ALRTMS(C)	;YES - BETTER ONE NOW?
	  MOVEI C,(D)		;YES - REMEMBER THIS ENTRY
ALRCH3:	AOBJN D,ALRCH2		;LOOP
	MOVE A,ALRTMS(C)	;SET NEW ENTRY (OR CLEAR ALRTIM)
	MOVEM A,ALRTIM
	SETZM ALRTMS(C)		;...
	SKIPE A,REASON		;CLEAR OLD MESSAGE
	 CALL STREM
	SETZM REASON		;IN CASE IT WAS THE ONLY ONE
	MOVE A,REASON+1(C)	;MOVE MESSAGE ALSO
	MOVEM A,REASON
	RET			;DONE

;SET AUTOMATIC MAIL-WATCH AND ALERTS

.AUTOM::NOISE <MAIL AND ALERT CHECKS>
	CONFIRM
	SKIPE SETNOF		;MAYBE SET NO
	 JRST .AUTO2		;YES
	SETZM MWATAT		;CLEAR AUTO TIME
	SKIPE IITSET		;TIMERS ON?
	 RET			;YES - EXIT
	MOVE A,[.FHSLF,,.TIMEL]	;NO - SET UP TIMER INTERRUPT
	MOVEI B,^D60000		;AT 1 MINUTE INTERVALS
	MOVEI C,IITCHN		;GET CHANNEL
	TIMER
	 JRST CJERR		;JSYS LOSAGE
	SETOM IITSET		;INTERRUPT ARMED
	RET			;EXIT

.AUTO2:	GTAD			;FLUSH TIMER IF
	ADDI A,^D182		; WITHIN ONE MINUTE
	MOVE B,A
	MOVE A,[.FHSLF,,.TIMBF]	;ALL TIMES BEFORE NOW + 1 MIN
	MOVEI C,IITCHN		;*** MONITOR CROCK REQUIRES CHL
	TIMER
	 JFCL
	SETZM IITSET		;NO MORE INTERRUPTS
	RET
;SET (NO) UUO-SIMULATION

.PAXL::	NOISE <FOR PROGRAM>
	CONFIRM
	SKIPN SETNOF
	TDZA A,A
	SETO A,
	MOVEM A,PAXLFL		;PA1050 FLAG
	SKIPG A,FORK		;HANDLE OF CURRENT INFERIOR
	RET			;NONE, LEAVE NOW
	GCVEC			;GET CURRENT VECTOR
	CAMN B,[-1]		;DISABLED?
	JRST [	SKIPE PAXLFL	;YES, IS THAT WHAT WE WANT?
		RET		;YES
		SETZ B,		;NO, ENABLE
		JRST PAXL1]
	SKIPN PAXLFL		;ENABLED, IS THAT WHAT WE WANT?
	RET			;YES
	SETO B,			;NO, DISABLE IT
PAXL1:	SETZ C,
	SCVEC			;SET COMPATIBILITY ENTRY
	 ERJMP CJERRE		;FAILED - SAY WHY
	RET

XTND,<
.KFRKC::NOISE <ON <CTRL-C>>
	SKIPE SETNOF		;SET NO?
	TDZA A,A		;YES - CLEAR
	SETO A,			;SET
	MOVEM A,CCKEEP		;CTRL-C KEEP FLAG
	CALLRET CONF		;CONFIRM AND RETURN

;SET NO LOGIN-MAIL
;DON'T DO ANY OF THE NORMAL MAIL PROCESSING ON LOGIN

.NOLM::	SETZM SYSMF		;THIS SHOULD BE SUFFICIENT
	SETZM MESMSF
	RET
>
;SET PAGE-ACCESS (OF PAGES) P1,P2:P3... (ACCESS) ACCESS-TYPES

.PAC::	SETZM SPCNT		;NO ERRORS YET
	SKIPGE FORK		;MAKE SURE THERE'S A PROCESS
	ERROR <No program>
	NOISE (OF PAGES)
	CALL OCTLST		;GET LIST OF OCTAL PAGE RANGES
	NOISE (ACCESS)
	SETZB Q1,Q2		;Q1 ARE "YESES" AND Q2 ARE "NOS"
	MOVEI Q3,0		;Q3 NON-0 IF "NO" JUST TYPED
PAC2:	MOVEI B,[FLDDB. .CMCFM,,,,,[
		 FLDDB. .CMKEY,,$ACCES,<Access type,>,,]]
	TRNE Q3,1		;WAS "NO" JUST TYPED?
	MOVE B,(B)		;YES, SO EOL ILLEGAL NOW
	CALL FLDSKP		;GET EOL OR ACCESS-TYPE
	 CMERRX			;NO
	LDB C,[331100,,(C)]	;FIND OUT WHAT TYPED
	CAIN C,.CMCFM		;END OF LINE?
	 JRST PAC3		;YES, GO EXECUTE COMMAND
	CALL GETKEY		;KEYWORD TYPED, GET DATA
	MOVE P3,(P3)		;GET CONTROL BITS
	CAIN P3,0		;IS KEYWORD "NO"?
	AOJA Q3,PAC2		;YES, REMEMBER AND GET NEXT KEYWORD
	TRNN Q3,1		;NO, DID "NO" PRECEDE THIS KEYWORD?
	IOR Q1,P3		;NO, ACCUMULATE TO "YES" LIST
	TRNE Q3,1
	IOR Q2,P3		;YES, ACCUMULATE TO "NO" LIST
	TRNN Q3,1
	TDZ Q2,P3		;IF "YES", CANCEL PREVIOUS "NO"
	TRNE Q3,1
	TDZ Q1,P3		;IF "NO", CANCEL PREVIOUS "YES"
	TRZ Q3,1		;CLEAR "NO"
	JRST PAC2		;GO GET MORE INPUT
PAC3:	SOSGE C,RLIST		;PREPARE TO GET NEXT SET OF PAGES FROM LIST
	JRST PAC4		;NO MORE PAGES
	MOVE D,RLIST(C)		;GET BEGINNING OF RANGE
	CAMLE D,RLIST+1(C)	;MAKE SURE RANGE GOES FROM SMALL TO LARGE
	JRST BADRAN		;NO
	HLR D,RLIST+1(C)	;MAKE SURE BOTH ENDS OF RANGE FIT IN 18 BITS
	JUMPN D,BADPAG		;JUMP IF THEY DON'T
	HRR A,RLIST(C)		;GET FIRST PAGE NUMBER OF RANGE TO SET
	HRRZM A,SPPAG		;REMEMBER PAGE
PAC5:	CAMN Q2,[-1]		;"NO NONEXISTENT"?
	JRST PAC6		;YES, DO NOTHING
	HRL A,FORK		;USE CURRENT FORK
	CAMN Q1,[-1]		;"NONEXISTENT"?
	JRST PAC7		;YES, GO REMOVE PAGE
	RPACS			;GET OLD PAGE ACCESS
	 ERJMP [CALL NOSPAC	;PRINT ERROR, RPACS FAILED.
		JRST PAC6]	;GO ON TO NEXT PAGE
	IOR B,Q1		;TURN ON ACCESS DESIRED
	TDZ B,Q2		;TURN OFF ACCESS NOT WANTED
	SPACS			;DO IT
	 ERCAL NOSPAC		;COULDN'T, TYPE ERROR MESSAGE
PAC6:	HRRZ D,SPPAG		;ISOLATE PAGE NUMBER JUST DONE
	AOS A,SPPAG		;STEP TO NEXT PAGE
	MOVE C,RLIST		;C GETS CLOBBERED BY NOSPAC
	CAMGE D,RLIST+1(C)	;HAVE WE DONE ENTIRE RANGE YET?
	JRST PAC5		;NOT YET
PAC8:	SOS RLIST		;YES, GO TO NEXT SET
	JRST PAC3
PAC4:	CALL SPREP		;PERHAPS LAST ERROR CHUNK TO REPORT
	CALLRET UNMAP		;ALL DONE, UNMAP PAGES AND RETURN

;HERE FOR THE CASE OF "SET PAGE N NONEXISTENT"

PAC7:	MOVE B,A		;PUT PAGE IDENTIFIER IN B
	HRROI A,-1		;SAY GET RID OF PAGE
	MOVEI C,0		;SAY NO REPEAT COUNT
	PMAP			;GET RID OF PAGE
	 ERCAL NOSPAC		;FAILED, GO PRINT ERROR
	JRST PAC6

;PAGE NUMBERS OUT OF RANGE 0-777777

BADPAG:	ETYPE <%%Page number negative or larger than 777777 - being skipped
>
	JRST PAC8		;SKIP THIS SET

;BEGINNING OF RANGE NOT LESS THAN OR EQUAL TO END

BADRAN:	ETYPE <%%Beginning of range larger than end - Range being skipped
>
	JRST PAC8

;GET HERE WHEN COULDN'T SET PAGE ACCESS.  JUST PRINT WARNING ABOUT
;THAT PAGE AND RETURN

NOSPAC:	CALL DGETER		;GET LATEST ERROR REASON
	MOVEM A,SPERR		;REMEMBER
NOSP1:	SKIPN SPCNT		;ANY ACCUMULATED ERRORS?
	JRST [	MOVE A,SPPAG	;NO, GET STARTING PAGE NUMBER
		HRRM A,SPERF	;REMEMBER WHERE NEW SET BEGINS
		MOVE A,SPERR	;SEE WHAT THE ERROR IS
		HRLM A,SPERF	;REMEMBER ERROR
		MOVEI A,1
		MOVEM A,SPCNT	;SAY ONE IN A ROW
		RET]		;DONE UNTIL NEXT ERROR
	HRRZ A,SPERF		;THERE'S ACCUMULATED ERRORS, GET STARTING PAGE
	ADD A,SPCNT		;GET NEXT PAGE IN GROUP
	HLRZ C,SPERF		;GET REASON WHY THIS GROUP FAILED
	CAMN A,SPPAG		;IS THIS PAGE NOT NEXT ONE IN GROUP?
	CAME C,SPERR		;OR IS REASON DIFFERENT THAT CURRENT GROUP?
	CAIA			;SOMETHING'S DIFFERENT
	JRST [	AOS SPCNT	;SAME ERROR AND CONSECUTIVE PAGE, JUST REMEMBER HOW MANY IN A ROW
		RET]
	CALL SPREP		;DIFFERENT REASON, REPORT PREVIOUS GROUP
	SETZM SPCNT		;CAUSE NEW GROUP TO START
	JRST NOSP1		;LOOP TO GRAB THIS LATEST ERROR

;ROUTINE TO PRINT ERROR. TAKES NUMBER OF CONSECUTIVE PAGES THAT FAILED IN SPCNT.
;TAKES REASON FOR FAILURE IN LEFT HALF OF SPERF AND STARTING PAGE NUMBER IN
;RIGHT HALF OF SPERF.

SPREP:	SKIPN C,SPCNT		;SEE HOW MANY FAILED IN A ROW
	RET			;NONE, SO NOTHING TO REPORT
	HLRZ A,SPERF		;GET REASON
	HRRZ B,SPERF		;GET FIRST PAGE THAT FAILED
	CAIN C,1		;1 IS SPECIAL CASE
	JRST [	LERROR <Couldn't set access of page %2O - %1?>
		RET]
	ADD C,B			;GET LAST PAGE THAT FAILED
	SOJ C,
	LERROR <Couldn't set access of pages %2O through %3O - %1?>
	RET

$ACCES:	TABLE			;OF ACCESS TYPES
	T COPY-ON-WRITE,,[PA%CPY]
	T EXECUTE,,[PA%EX]
	T NO,,[0]
	T NONEXISTENT,,[-1]
	T READ,,[PA%RD]
	T WRITE,,[PA%WT]
	TEND

.CTRAC::NOISE <OF GENERATED COMMANDS> ;PCL
IFN STANSW,<
	CONFIRM			;CM156
>;IFN STANSW
	MOVX A,PCFTRC		;TRACE BIT
	ANDCAM A,PCFLAG		;CLEAR IT
	SKIPN SETNOF		;WANT IT SET?
	IORM A,PCFLAG		;SET IT
IFE STANSW,<
	CALLRET CONF		;CONFIRM AND RETURN
>;IFE STANSW
IFN STANSW,<
	RET			;CM156
>;IFN STANSW

.CTRLC::NOISE <OF PROGRAM>
	CONFIRM
IFE NICSW,<			;[NIC1011] LET BATCH JOBS HAVE ^C CAPABILITY
	IFNBATCH (ILLBAT)
>;IFE NICSW
	SKIPN SETNOF
	TDZA A,A
	SETO A,
	MOVEM A,CCFLAG		;CONTROL-C FLAG
	SKIPG A,FORK		;CURRENT FORK?
	RET			;NO, LEAVE NOW
	RPCAP			;YES, GET CAPS
	SKIPE CCFLAG		;ENABLE OR DISABLE?
	TXZA B,SC%CTC		;DISABLE
	TXO B,SC%CTC		;ENABLE
	SKIPE PRVENF		;IF NO CAPS ENABLED, CLEAR ^C
	SKIPE CCFLAG		;ENABLE OR DISABLE?
	TXZA C,SC%CTC		;DISABLE
	TXO C,SC%CTC		;ENABLE
	EPCAP			;YES, SET
	RET

ILLBAT:	ERROR	<Illegal under BATCH>
;SET DEFAULT (FOR)

.SEDEF::NOISE (FOR)
	KEYWD TDEFAU		;SEE WHICH COMMAND DEFAULT BEING SET FOR
	 0			;NO DEFAULT
	 CMERRX <Invalid command to set defaults for>
	JRST (P3)		;DISPATCH TO DEFAULTING ROUTINE

;SET NO DEFAULT (FOR)

.NODEF::NOISE (FOR)
	KEYWD $NODEF		;SEE WHICH COMMAND DEFAULT BEING CLEARED FOR
	 0			;NO DEFAULT
	 CMERRX <Invalid command to clear defaults for>
	JRST (P3)		;DISPATCH TO DEFAULTING ROUTINE

.TKD::	KEYWD $TKD		;PARSE NEXT KEYWORD ("ECHO" OR "NO")
	 0			;NO DEFAULT
	 CMERRX <invalid option for SET DEFAULT TAKE command>
	JRST (P3)		;DISPATCH TO DEFAULTING ROUTINE

$TKD:	TABLE
	T ALLOW
	T DISALLOW
	T ECHO,,.ECHO
	T NO,,.TKND
	TEND

.ECHO:	CALL ECHNOI		;FINISH COMMAND
	MOVX A,TKECOF		;GET BIT SAYING ECHOING WANTED
	IORM A,TAKDEF		;REMEMBER IN DEFAULTS WORD
	RET

.TKND:	KEYWD $NTKD		;PARSE NEXT KEYWORD ("ECHO")
	 T ECHO,,.NOECH
	 CMERRX <invalid option for SET DEFAULT TAKE command>
	JRST (P3)		;DISPATCH TO DEFAULTING ROUTINE

$NTKD:	TABLE
	T ECHO,,.NOECH
	TEND

.NOECH:	CALL ECHNOI
	MOVX A,TKECOF		;BIT SAYING WE WANT ECHOING
	ANDCAM A,TAKDEF		;TURN IT OFF IN DEFAULT WORD
	RET

.SDDCL::MOVEI B,[FLDDB. .CMSWI,,$SDEF,,,] ;PCL
	CALL FLDSKP		;SEE WHAT HE WANTS
	 CMERRX
	CALL GETKEY		;GET THE DATA WORD
	CONFIRM			;FINISH IT OFF
	MOVX B,PCFQDC		;GET THE QUIET-DECLARATION BIT
	ANDCAM B,PCFLAG		;CLEAR IT TO ASSUME NOISY DECLARATION
	SKIPN P3		;NOCONFIRM?
	IORM B,PCFLAG		;YES, USE QUIET DECLARATION
	RET			;PCL All done

.ALLOW:	CALL ALONOI		;FINISH COMMAND
	MOVX A,TKALEF
	IORM A,TAKDEF		;ALLOW ERRORS
	RET

.DISAL:	CALL ALONOI		;FINISH COMMAND
	MOVX A,TKALEF
	ANDCAM A,TAKDEF		;DISALLOW ERRORS DURING TAKE FILES
	RET

ALONOI::NOISE (ERRORS DURING "TAKE" FILE)	;THE "NOISE" CALL *MUST* STAY ON THIS TAG
	CALLRET CONF		;CONFIRM AND RETURN

ECHNOI::NOISE (COMMANDS FROM "TAKE" FILE)	;THE "NOISE" CALL *MUST* STAY ON THIS TAG
	CALLRET CONF		;CONFIRM AND RETURN
;"SET DIRECTORY"

.SDIR::	SETZM SETNOF		;ASSUME "NO" NOT TYPED
	SETZM PASSP		;TELL CRDIR THERE'S NO PASSWORD SUPPLIED YET
	KEYWD $SDIR
	 0
	 JRST CERR
	JRST (P3)

$SDIR:	TABLE
	T ACCOUNT-DEFAULT,,.DAD
XARC <
	T ARCHIVE-ONLINE-EXPIRED-FILES,WHLU,.DARF
   >
	T FILE-PROTECTION-DEFAULT,,.DFPD
	T GENERATION-RETENTION-COUNT-DEFAULT,,.DGRCD
XARC <
	T NO,,.SDNO
	T OFFLINE-EXPIRATION-DEFAULT,,.DOFXP
	T ONLINE-EXPIRATION-DEFAULT,,.DONXP
   >
	T PASSWORD,,.DPASS
	T PROTECTION,,.DPRO
	TEND

.SDNO:	SETOM SETNOF		;FLAG THAT NO WAS SAID
	KEYWD $SDNO
	 T ARCHIVE-ONLINE-EXPIRED-FILES,WHLU,.DARF
	 JRST CERR
	JRST (P3)

$SDNO:	TABLE
	T ARCHIVE-ONLINE-EXPIRED-FILES,WHLU,.DARF
	TEND

;SET PROGRAM ENTRY (VECTOR LOCATION) <OCTAL> (LENGTH) <OCTAL>

.ENTRY::SKIPGE FORK
	ERROR <No program>
	NOISE <LOCATION TO>
	ADDRX <Memory location of entry vector>
	 ERROR <Invalid location>
	MOVEM B,ENTADR		;REMEMBER ENTRY VECTOR LOCATION
	NOISE <LENGTH>
	DEFX <1>		;DEFAULT
	ADDRX <Value between 1 and 777 octal
or 254000 for TOPS10-compatible entry vector.>
	 ERROR <Invalid length>
	CAILE B,777		;TOO LONG?
	JRST [	CAIN B,254000	;ALLOW JRST FOR COMPATIBLE
		JRST .+1
		ERROR <Invalid length>]
	CONFIRM
	MOVE C,ENTADR		;GET LOCATION OF VECTOR
	MOVE A,FORK
	CALLRET SETENT		;SET ENTRY VECTOR AND RETURN
IFN STANSW,<
;"SET NEW-FORK"

.NWFRK::NOISE <ON RESET>
	CONFIRM			;FINISH COMMAND PARSE
	SKIPE SETNOF		;NO TYPED?
	 TDZA A,A		;YES, CLEAR FLAG
	  SETO A,		;ELSE SET IT
	MOVEM A,RNFORK		;SAVE FOR LATER
	RET			;ALL DONE
>;IFN STANSW
;"SET FILE"

.SFILE::SETZM SETNOF		;FLAG "NO" WAS NOT SAID YET
	KEYWD $SFILE
	 0
	 JRST CERR
	JRST (P3)

.SFNO::	SETOM SETNOF
	KEYWD $SFNO
	 0
	 JRST CERR
	TXNN P3,NOLG		;NEED TO BE LOGGED IN?
	SKIPE CUSRNO		;YES, AND ARE WE?
	CAIA			;YES, GO AHEAD
	ERROR <LOGIN please>
	JRST (P3)		;DO WHATEVER
;OFFLINE/ONLINE/EXPIRED CODE

.FLINX::SETZ A,			;NO EXPIRATION YET
	MOVX B,.RSFET		;OFFSET TO GUY WE'RE CHANING
	JRST DOEXPI		;JOIN OTHER CODE
.FEXP::	GTAD			;EXPIRE THE FILE, NOW WILL DO
	CAIA
.FLONX::SETZ A,			;SAY NO DATE/TIME OR INTERVAL
	MOVX B,.RSNET		;CELL WHERE THIS VALUE GOES
DOEXPI:	PUSH P,A		;SAVE THE VALUE
	PUSH P,B		;AND THE OFFSET
	CAIN A,0		;DOING FILE EXPIRED? (HAVE VALUE IF SO)
	NOISE <OF FILES>
	CAIE A,0		;HAVE A VALUE?
	NOISE <FILES>		;YES, "SET FILE EXPIRED (FILES) <FILES>"
	CALL INFGNS		;GET FILE GROUPS
	SKIPE -1(P)		;HAVE A VALUE YET?
	JRST DOEXI4		;YES
	NOISE <TO>
	DTIVX <Expiration date>
	 JRST CERR		;LOSES
	MOVEM B,-1(P)		;REMEMBER VALUE GIVEN US
	CAIA
DOEXI4:	CONFIRM
	SETOM FTDBLK
	MOVE A,[FTDBLK,,FTDBLK+1]
	BLT A,FTDBLK+.RSFET	;SET UP THE BLK
	POP P,A			;GET DESIRED OFFSET
	POP P,FTDBLK(A)		;VALUE REQUESTED
	SETOM TYPGRP		;TYPE FILE NAMES
	MOVE A,JBUFP		;SET UP JFN STACK FENCE
	MOVEM A,.JBUFP
DOEXI1:	CALL RLJFNS
	CALL NXFILE
	 JRST DOEXI2		;NO MORE FILES...
	CALL TYPIF		;DO FILE NAME
	CALL MFINP		;GET A TEMP JFN FOR THE FILE
	 JRST DOEXI2		;FAILED...
	MOVEI B,FTDBLK
	MOVEI C,.RSFET+1	;BLK LENGTH
	SFTAD			;SET
	 ERJMP DOEXI3		;FAILED, SAY WHY
	CALL TYPOK		;SAY IT WENT FINE
DOEXI2:	SKIPE INIFH1		;ANYTHING LEFT TO DO?
	JRST DOEXI1		;YES, KEEP GOING
	RET

DOEXI3:	ETYPE < %?
>
	JRST DOEXI2
;PROHIBIT/RESIST-MIGRATION

.FPROH::MOVX A,.AREXM
	CAIA
.FRESI::MOVX A,.ARNAR		;DO RESIST
	MOVX B,.ARSET		;ASSUME USER IS SETTING IT
	SKIPE SETNOF		;USER SAY "NO" ?
	MOVX B,.ARCLR		;YES, CLEAR THE BIT
	PUSH P,A		;SAVE FUNCTION CODE
	PUSH P,B		;AND SET/CLEAR CODE
	NOISE <MIGRATION OF FILES>
	CALL TYPFLS		;COLLECT FILE NAME GROUPS
	SETOM TYPGRP		;TYPE THE NAMES AS WE GO
	MOVE A,JBUFP
	MOVEM A,.JBUFP		;COVER JFN STACK
DOPRRS:	CALL RLJFNS		;RELEASE SPARE JFNS
	CALL NXFILE
	 JRST DOPRR1		;NO MORE
	CALL TYPIF
	CALL MFINP		;GET A SECOND JFN
	 JRST DOPRR1		;COULDN'T
	MOVE B,-1(P)		;GET DESIRED FUNCTION
	MOVE C,0(P)		;WHICH WAY TO SET IT
	ARCF			;DO IT
	 ERJMP [ETYPE < %?
>
		JRST DOPRR1]	;FAILED
	CALL TYPOK
DOPRR1:	SKIPE INIFH1		;ANYTHING LEFT?
	JRST DOPRRS		;NO
	ADJSP P,-2		;DITCH PARAMS
	RET
;PROTECTION (OF FILE) <EXISTING NAME> (IS) <18 BIT OCTAL>
;VERSION-RETENTION-COUNT ...
;INVISIBLE/VISIBLE

.VISIB::TXO Z,IGINV		;FIND INVISIBLE FILES
	TDZA B,B		;MAKE FILES VISIBLE
.INVIS::MOVX B,FB%INV		;MAKE FILES INVISIBLE
	TLO Z,F2		;FLAG DOING INV/VIS STUFF
	NOISE <FILES>
	PUSH P,B		;SAVE OUR PARAM NOW
	CALL TYPFLS		;NOT INFGNS, SINCE NO GUIDE WORD AFTER FILESPEC
	JRST FILEV2		;ENTER DOWN A LITTLE WAY
.FILEV::TLOA Z,F1		;FLAG VERSION-RET...
.PROTE::TLO Z,F3
	NOISE <OF FILES>
	CALL INFGNS
	NOISE <TO>
	TLNE Z,F1
	JRST [	DECX <Decimal generation retention count>
		 CMERRX
		CAILE B,^D63	;LEGAL?
		ERROR <Generation retention count must be 0-63>
		LSH B,^D36-^D6	;LEFTMOST 6 BITS
		JRST FILEV1]
	OCTX <Octal file protection value>
	 CMERRX
IFE STANSW,<
	TLO B,500000		;INDICATE THAT THERE'S 18-BIT PROTECTION IN RH
>;IFE STANSW
FILEV1:	CONFIRM
IFN STANSW,<
	IFXN. Z,F3		;WAS THIS A PROTECTION COMMAND
	  MOVE C,B		;SAVE INPUT PROTECTION
	  MOVX B,WHLU+OPRU	;SEE IF USER IS PRIVILEGED
	  SKIPE PRVENF		;IS HE ENABLED
	   IFSKP.
	     CALL PRVCK		;YES, SEE IF HE WAS WOPR
	   ANNSK.		;NOT PRIVILEGED, CHECK PROTECTION
	     SETZ B,		;INITIALIZE FOR ERROR STRING
	     TRNN C,20000	;OR NO LIST ACCESS BY OWNER
	      HRROI B,[ASCIZ/No list access for owner/]
	     TLNE C,-1		;LARGER THAN 18 BITS
	      HRROI B,[ASCIZ/Larger than 18 bits/] ;SAY WHAT IS WRONG
	     IFN. B		;OUTPUT ERROR IF SET
	       ETYPE<%@ %2M specified> ;OUTPUT ERROR
	       CALL FCONF	;MAKE SURE HE AGREES
	     ENDIF.
	   ENDIF.
	  MOVE B,C		;GET PROTECTION BACK
	  TLO B,500000		;INDICATE THAT THERE'S 18-BIT PROTECTION IN RH
	ENDIF.
>;IFN STANSW
FILEV2:	SETOM TYPGRP		;PRINT ALL FILES
	TLNN Z,F2		;VIS/INVIS?
	PUSH P,B		;YES, ALREADY HAVE PARAM SAVED
PROTE1:	CALL NXFILE
	 JRST [	SKIPE INIFH1	;END OF TERMS?
		JRST PROTE1	;NO, DO ANOTHER
		POP P,(P)
		RET]
	HRRZ A,@INIFH1		;GET JFN
	DVCHR
	TXNN B,DV%MDD		;MULTIPLE DIRECTORY DEVICE?
	JRST [	TLNE Z,F1
		ETYPE <?%1H: Generation retention count not implemented for this device
>
		TLNE Z,F2
		ETYPE <?%1H: Invisible files not implemented for this device
>
		TLNE Z,F3
		ETYPE <?%1H: Protection not implemented for this device
>
		MOVSI A,(77B5)
		ANDCAM A,@INIFH1 ;CLEAR * INDICATIONS TO FORCE STEPPING TO NEXT JFN
		JRST PROTE2]
	TLNE Z,F2		;INV/VIS?
	JRST [	SKIPE 0(P)	;SET FILE VISIBLE?
		JRST .+1	;NO
		HRRZ A,@INIFH1	;YES, GET JFN
		MOVE B,[1,,.FBCTL] ;FIND OUT IF CURRENTLY INVISIBLE
		MOVEI C,C
		GTFDB
		 ERJMP PROTE2	;SKIP FILE IF WE CAN'T TELL
		TXNE C,FB%INV	;IS IT INVISIBLE NOW?
		JRST .+1	;YES, PRINT NAME & MAKE VISIBLE
		JRST PROTE2]
	CALL TYPIF		;TYPE NAME IF GROUP (RETURNS JFN IN A)
	TLNE Z,F2		;INV/VIS?
	JRST [	HRLI A,.FBCTL	;WHERE THE BIT BE CHANGED IS
		MOVX B,FB%INV	;BIT IN QUESTION
		JRST DOSFL1]
	HRLI A,.FBPRT		;PROTECTION WORD IN FDB
	TLNE Z,F1
	HRLI A,.FBBYV		;THIS IS VER RET WORD
	MOVEI	B,777777	;CHANGE RHS ONLY
	TLNE	Z,F1
	LDF	B,FB%RET	;RETENTION COUNT PART
DOSFL1:	MOVE	C,(P)		;GET PROTECTION OR VER RET COUNT
	CALL	$CHFDB
	 JRST [	TYPE <   Access not allowed
>
		JRST PROTE2]
	CALL TYPOK
PROTE2:	CALL GNFIL
	SKIPA
	JRST PROTE1
	POP P,(P)		;FIX STACK
	RET
;[NIC1033] SET FILE AUTOKEEP
IFN NICSW,<			;[NIC1033]
.AUTOK::MOVSI A,.FBKEP		;[NIC1033] CODE FOR KEEP THIS FILE
	MOVX B,FB%FCF		;[NIC1033] THE MASK
	JRST .EPHM0		;[NIC1033] JOIN COMMON ROUTINE
>;IFN NICSW
IFN STANSW,<
;SET FILE PERMANENT

.PRMNT::MOVX A,FB%PRM		; CODE FOR PERMANENT
	MOVX B,FB%PRM		; SELECT PERMANENT BIT AS BIT MASK
	JRST .EPHM0		; JOIN COMMON CODE WITH EPHEMERAL

.TMPRY::MOVX A,FB%TMP		; CODE FOR TEMPORARY
	MOVX B,FB%TMP		; SELECT TEMPORARY BIT AS BIT MASK
	JRST .EPHM0		; JOIN COMMON CODE WITH EPHEMERAL

.SVBAK::STKVAR <FCODE,FBEPM>	;MUST BE SAME STKVAR AS AT .EPHM0!!
	MOVX A,FB%NOD		;NOT TO BE DUMPED BY BACKUP SYSTEM
	MOVEM A,FBEPM		;SAVE SELECTED BIT MASK
	SETZM FCODE		;CLEAR CODE
	SKIPE SETNOF		;SET NO ...?
	 MOVEM A,FCODE		;STORE ACTUAL CODE TO SET
	JRST .EPHM1		;GO FINISH PARSE
>; IFN STANSW
;SET FILE EPHEMERAL (ALSO SET NO ...)

.EPHM::	MOVSI A,.FBEPH		;CODE FOR EPHEMERAL
IFE STANSW,<
.EPHM0:	STKVAR <FCODE>
>;IFE STANSW
IFN STANSW,<
	MOVX B,FB%FCF		;SELECT FILE CLASS FIELD AS BIT MASK
.EPHM0:	STKVAR <FCODE,FBEPM>
	MOVEM B,FBEPM		;SAVE SELECTED BIT MASK
>;IFN STANSW
	SETZM FCODE		;CLEAR CODE
	SKIPN SETNOF		;SET NO ...?
	 MOVEM A,FCODE		;STORE ACTUAL CODE TO SET
IFE STANSW,<
	CALL INFGNS		;COLLECT FILE NAME GROUPS
	CONFIRM
>;IFE STANSW
IFN STANSW,<
.EPHM1:	NOISE <FILES>
	CALL TYPFLS		;COLLECT FILE NAME GROUPS (NOT WITH INFGNS!)
>;IFN STANSW
	SETOM TYPGRP		;TYPE THE NAMES AS WE GO
	MOVE A,JBUFP
	MOVEM A,.JBUFP		;COVER JFN STACK
EPHM1:	CALL RLJFNS		;RELEASE SPARE JFNS
	CALL NXFILE		;GET THE NEXT FILE
	 JRST EPHM2		;NO MORE - FINISH UP
	CALL TYPIF		;TYPE OUT THE FILE NAME
	CALL MFINP		;GET A SECOND JFN
	 JRST EPHM2		;COULDN'T - ON TO NEXT FILE
	HRLI A,.FBCTL		;WORD IN FDB TO CHANGE
IFE STANSW,<
	MOVX B,FB%FCF		;MASK FOR FILE TYPE CODE
>;IFE STANSW
IFN STANSW,<
	MOVE B,FBEPM		; GET REQUESTED EPHEMERAL OR PERMANENT MASK
>;IFN STANSW
	MOVE C,FCODE		;GET CODE OR 0
	CALL $CHFDB		;SET CODE IN FDB
	 JRST [	TYPE <  Access not allowed
>
		JRST EPHM2]
	CALL TYPOK		;SAY THE CHANGE SUCCEEDED
EPHM2:	SKIPE INIFH1		;ANYTHING LEFT?
	 JRST EPHM1		;YES - LOOP
	RET			;NO - DONE
;SET DIRECTORY [NO] ARCHIVE-ONLINE-EXPIRED-FILES (OF DIRECTORY)

.DARF:	CALL INPDIR		;GET THE DIRECTORY IN QUESTION
	MOVX A,CD%DAR		;BIT TO CHANGE
	CALLRET DMODE		;GO CHANGE A SINGLE MODE BIT

;SET DIRECTORY GENERATION-RETENTION-COUNT-DEFAULT

.DGRCD:	CALL INPDIR		;GET DIRECTORY NAME
	NOISE <TO>
	DECX <Decimal number of generations per file to be retained>
	 CMERRX
	MOVEM B,.CDRET+SEBLK	;REMEMBER NUMBER
	CAIE B,1		;DON'T SAY "1 (GENERATIONS...)"
	NOISE <GENERATIONS PER FILE>
	CAIN B,1
	NOISE <GENERATION PER FILE>
	LDF A,CD%RET		;SPECIFY WHICH PARAMETER TO CHANGE
;	CALLRET DWORK		;FALL TO DO THE WORK AND RETURN

;ROUTINE USED FOR SET DIRECTORY COMMANDS.  IT ATTEMPTS TO DO THE CRDIR
;JSYS, AND IF IT FAILS DUE TO A PASSWORD BEING REQUIRED, IT ASKS FOR ONE
;AND TRIES AGAIN.
;
;ACCEPTS:	A/	BITS SHOWING PARAMETER TO CHANGE (CRDIR AC2)
;
;RETURNS:	+1 ALWAYS

DWORK:	MOVEM A,WBITS		;REMEMBER WHICH BITS
	CONFIRM			;CONFIRM THE COMMAND
	MOVE A,WBITS		;GET BITS TO SET
	CALL CREDIR		;TRY TO CHANGE THE DIRECTORY
	 JRST DWORK1		;FAILED, SEE WHY
	RET			;SUCCEEDED WITHOUT PASSWORD

DWORK1:	CALL DGETER		;SEE WHY IT FAILED
	CAIE A,ACESX3		;PASSWORD REQUIRED AND NOT GIVEN?
	CALL CJERRE		;OTHER ERROR, FAIL NOW
	CALL GETPAS		;FAILED, ASK FOR A PASSWORD
	MOVE A,WBITS		;TRY AGAIN
	CALL CREDIR
	 CALL CJERRE		;FAILED AGAIN, TELL USER WHY AND DIE.
	RET			;SUCCEEDED, DONE

;ROUTINE TO GET PASSWORD FOR SET DIRECTORY COMMANDS.

GETPAS:	CALL PASLIN		;INPUT THE PASSWORD
	MOVEM A,PASSP		;SAVE POINTER TO IT IN PASSP
	RET

;ROUTINE TO EXECUTE CRDIR FOR USER-SETTABLE PARAMETERS.
;ACCEPTS:
;	A/	BITS DESIGNATING PARAMETERS BEING CHANGED
;RETURNS:	+1 ERROR
;		+2 SUCCESS

;NOTE:  THIS ROUTINE IS NOT GENERALLY CALLABLE, AS PASSP IS A LOCAL
;VARIABLE.  TO MAKE IT GENERAL, MAKE PASSP BE AN ARG.

CREDIR:	MOVE B,A		;PUT CONTROL BITS IN AC2 FOR JSYS
	MOVE A,DIRP		;GET DIRECTORY NUMBER
	MOVE C,PASSP		;AND POINTER TO PASSWORD
	HRRI B,SEBLK		;SPECIFY WHERE PARAMETER BLOCK IS.
	CRDIR			;MAKE THE DIRECTORY MODIFICATION
	 ERJMP R		;FAILED, PROBABLY BECAUSE PASSWORD REQUIRED OR WRONG
	RETSKP			;SUCCEEDED, SKIP

;SET DIRECTORY OFFLINE-EXPIRATION-DEFAULT

.DONXP:	MOVX A,.CDDNE
	CAIA
.DOFXP:	MOVX A,.CDDFE
	PUSH P,A		;SAVE WHAT WE'RE CHANGING
	CALL INPDIR		;GET A DIRECTORY NAME
	NOISE <TO>
	DTIVX <Expiration date>
	 CMERRX
	POP P,A			;WHAT WE'RE CHANGING
	CAIN A,.CDDNE		;GUESS WE'RE CHANGING ONLINE
	JRST [	MOVEM B,.CDDNE+SEBLK ;WE ARE
		MOVX B,CD%NED
		JRST DOFXP1]
	MOVEM B,.CDDFE+SEBLK	;WRONG, IS OFFLINE DEFAULT
	MOVX B,CD%FED
DOFXP1:	HRRI B,.CDDFE+1		;LENGTH OF THE BLK
	MOVEM B,.CDLEN+SEBLK
	MOVX A,CD%LEN		;SET THIS SO BITS IN CDLEN ARE NOTICED
	CALLRET DWORK		;DO IT & RETURN

;SET DIRECTORY FILE-PROTECTION-DEFAULT

.DFPD:	CALL INPDIR		;GET DIRECTORY NAME
	NOISE <TO>
	OCTX <Octal default file-protection value>
	 CMERRX
	MOVEM B,.CDFPT+SEBLK	;REMEMBER GIVEN VALUE
	LDF A,CD%FPT		;SPECIFY WHICH PARAMETER WE'RE CHANGING
	CALLRET DWORK		;GO DO THE WORK
;SET DIRECTORY PASSWORD

.DPASS:
IFE STANSW,<
	NOISE <OF DIRECTORY>
	TLO Z,F1		;DON'T DEFAULT THE DIRECTORY NAME
	CALL DIRNAM		;READ THE DIRECTORY NAME
	 ERROR <Invalid directory name or syntax>
	CALL BUFFF		;GET POINTER TO DIRECTORY NAME
	MOVEM A,DIRP		;LEAVE DIRECTORY NAME IN DIRP
>;IFE STANSW
IFN STANSW,<
	CALL INPDIR		;WHY NOT DEFAULT THE DIRECTORY NAME
>;IFN STANSW
	CONFIRM			;INPUT PASSWORDS ON SEPARATE LINES
	SETZM PASSP		;DON'T WANT TO CHANGE ANYTHING
	LDF A,CD%PSW		;SPECIFY WHAT WE'RE CHANGING
	CALL CREDIR		;GO SEE IF WE NEED THE OLD PASSWORD
	 SKIPA A,[.FHSLF]	;PASSWORD MAY BE NEEDED
	JRST DPASS1		;NO PASSWORD NEEDED
	GETER			;GET LAST ERROR FOR THIS PROCESS
	HRRZS B			;CLEAR LH OF B
	CAIE B,ACESX3		;WAS LAST ERROR "PASSWORD NEEDED"?
	CAIN B,CRDIX1		;OR "WHEEL OR OPERATOR CAPABILITY REQUIRED"?
	SKIPA			;YES, GET OLD PASSWORD
	 CALL CJERRE		;NO, PRINT MONITOR'S ERROR MESSAGE
DPASS0:	MOVEI A,[ASCIZ /Old password: /]
	CALL PASSX		;INPUT THE CURRENT PASSWORD
	MOVEM A,PASSP		;SAVE POINTER TO IT IN PASSP
DPASS1:	MOVEI A,[ASCIZ /New password: /]
	CALL PASSX		;READ PASSWORD WITH NOISE WORDS "NEW PASSWORD"
	MOVEM A,.CDPSW+SEBLK	;SAVE POINTER TO NEW PASSWORD STRING
IFN STANSW,<
	CALL PASCHK		;MAKE SURE ALPHANUMERICS WERE USED
	 ERROR <Only alphanumeric characters and dashes allowed in passwords>
	CAIGE C,6		;MUST BE SIX CHARACTERS OR MORE
	 ERROR <Password must be six or more characters in length>
>;IFN STANSW
	MOVEI A,[ASCIZ /Retype new password: /]
	CALL PASSX		;READ NEW PASSWORD AGAIN
	MOVE B,.CDPSW+SEBLK	;GET FIRST ATTEMPT AT TYPING IT
	STCMP			;MAKE SURE THEY'RE THE SAME
	CAIE A,0		;ARE THEY?
	ERROR <The two copies of the new password weren't the same>
	LDF A,CD%PSW		;SPECIFY WHAT WE'RE CHANGING
	CALL CREDIR		;GO DO THE WORK
	 CALL CJERRE		;PRINT MONITOR'S ERROR MESSAGE IF FAILS
	RET			;SUCCESS

IFN STANSW,<
;MAKE SURE NEW PASSWORD HAS NO SPECIAL CHARS
;RETURNS +1 BAD CHARACTERS
;	 +2 GOOD CHARACTERS, C/ LENGTH

PASCHK:	SETZ C,			;ACCUMULATE PASSWORD LENGTH HERE
PASCH0:	ILDB B,A		;GET A BYTE
	JUMPE B,RSKP		;GOOD PASSWORD IF WE REACHED NUL
	CAIL B,"0"
	CAILE B,"9"
	 SKIPA
	  AOJA C,PASCH0		;ALLOW NUMERIC
	CAIL B,"A"+40
	CAILE B,"Z"+40
	 SKIPA
	  AOJA C,PASCH0		;ALLOW LOWERCASE ALPHABETIC
	CAIL B,"A"
	CAILE B,"Z"
	 SKIPA
	  AOJA C,PASCH0		;ALLOW UPPERCASE ALPHABETIC
	CAIN B,"-"
	 AOJA C,PASCH0		;ALLOW DASHES
	RET			;ILLEGAL CHARACTER, TAKE A SINGLE RETURN
>;IFN STANSW

;SET DIRECTORY ACCOUNT-DEFAULT

.DAD:	CALL INPDIR		;GET NAME
	NOISE (TO)
	LINEX <Default account string for directory>
	 CMERRX
	CALL BUFFF
	MOVEM A,.CDDAC+SEBLK	;SAVE POINTER TO DEFAULT ACCOUNT STRING
	MOVX A,CD%DAC		;BIT FOR SETTING DEFAULT ACCOUNT STRING
	CALLRET DWORK		;DO THE WORK AND RETURN

;SET DIRECTORY PROTECTION

.DPRO:	CALL INPDIR		;INPUT DIRECTORY NAME
	NOISE <TO>
	OCTX <Octal directory protection value>
	 CMERRX
	MOVEM B,.CDDPT+SEBLK	;SAVE DESIRED DIRECTORY PROTECTION
	LDF A,CD%DPT		;BIT FOR CHANGING DIRECTORY PROTECTION
	CALLRET DWORK		;DO THE WORK AND RETURN
;ROUTINE TO CHANGE A SINGLE MODE BIT IN A DIRECTORY

DMODE:	MOVEM A,WBITS		;SAVE THE DESIRED MODE BIT
IFN STANSW,<
	SETZM SEBLK		;ZERO OUT FIRST WORD
	HRLI A,SEBLK		;SET UP FOR BLT
	HRRI A,1+SEBLK		;START OF BLT OUTPUT
	BLT A,<GTDLN-1>+SEBLK	;ZERO OUT THE MEMORY
	MOVEI A,GTDLN		;LENGTH OF THE GTDIR BLOCK
	MOVEM A,.CDLEN+SEBLK	;PUT IT WHERE MONITOR CAN FIND IT
>;IFN STANSW
	MOVX A,RC%EMO		;TAKE AS IS ONLY
	MOVE B,DIRP		;DIRECTORY # IN QUESTION
	SETZ C,
	RCDIR			;GET THE DIRECTORY #
	MOVEI A,.CDMOD		;READ SOME OF THE DIRECTORY
	MOVEM A,.CDLEN+SEBLK
	MOVE A,C		;SET UP DIRECTORY NUMBER
	MOVEI B,SEBLK		;READ WHAT THINGS ARE NOW
	SETZ C,			;DON'T WANT TO KNOW THE PASSWORD
	GTDIR
	 ERJMP [ETYPE <No access to directory>
		RET]
	MOVE A,WBITS		;GET THE BIT WE WANTED TO CHANGE
	IORM A,.CDMOD+SEBLK	;ASSUME WE WANTED TO SET IT
	SKIPE SETNOF		;DID COMMAND HAVE A "NO" IN IT?
	ANDCAM A,.CDMOD+SEBLK	;YES, CLEAR THE BIT
	LDF A,CD%MOD		;TELL DWORK WHAT TO CHANGE
	CALLRET DWORK		;GO DO IT

;THIS ROUTINE INPUTS THE DIRECTORY NAME FOR "SET DIRECTORY"
;COMMANDS.

INPDIR:	NOISE <OF DIRECTORY>
IFE STANSW,<
	TLO Z,F1		;DON'T DEFAULT THE DIRECTORY NAME
>;IFE STANSW
IFN STANSW,<
	TLZ Z,F1		;DEFAULT TO USER'S LOGIN DIRECTORY
>;IFN STANSW
	CALL DIRNAM		;READ THE DIRECTORY NAME
	 ERROR <Invalid directory name or syntax>
	CALL BUFFF		;GET POINTER TO DIRECTORY NAME STRING
	MOVEM A,DIRP		;REMEMBER POINTER TO IT
	RET
;"SET TAPE"

.TAPE::	KEYWD $TAPE
	 0
	 JRST CERR
	JRST (P3)

$TAPE:	TABLE
	T DENSITY,,TDENSI	;"SET TAPE DENSITY (TO)"
	T FORMAT,,TFRMAT	;"SET TAPE FORMAT (TO)"
	T PARITY,,TPARIT	;"SET TAPE PARITY (TO)"
	T RECORD-LENGTH,,TRECLN	;"SET TAPE RECORD-LENGTH (TO)"
	TEND

TDENSI:	NOISE <TO>
	KEYWD $TDENS
	 T SYSTEM-DEFAULT,,.SJDDN
	 JRST CERR
	NOISE <BPI>
	CONFIRM
	MOVEI B,.SJDEN		;SET DENSITY
SETJOB:	MOVEI C,(P3)		;GET VALUE
SETTAP:	MOVNI A,1		;SET FOR OUR JOB
	SETJB
	 ERCAL CJERRE
	RET

;THIS TABLE MUST BE IN ALPHABETIC ORDER

$TDENS::TABLE
	T 1600,,.SJD16
	T 200,,.SJDN2
	T 556,,.SJDN5
	T 6250,,.SJD62
	T 800,,.SJDN8
	T SYSTEM-DEFAULT,,.SJDDN
	TEND

TFRMAT:	NOISE <TO>
	KEYWD $TFRMT
	 T SYSTEM-DEFAULT,,.SJDDM
	 JRST CERR
	CONFIRM
	MOVEI B,.SJDM
	JRST SETJOB

$TFRMT:	TABLE
	T ANSI-ASCII,,.SJDMA
	T CORE-DUMP,,.SJDMC
	T HIGH-DENSITY,,.SJDMH
	T INDUSTRY-COMPATIBLE,,.SJDM8
	T SIXBIT,,.SJDM6
	T SYSTEM-DEFAULT,,.SJDDM
	TEND

TPARIT:	NOISE <TO>
	KEYWD $TPARI
	 T ODD,,.SJPRO
	 JRST CERR
	CONFIRM
	MOVEI B,.SJPAR		;SET PARITY
	JRST SETJOB

$TPARI:	TABLE
	T EVEN,,.SJPRE
	T ODD,,.SJPRO
	TEND

TRECLN:	NOISE <TO>
	DECX <Number of bytes in decimal>
	 CMERRX
	NOISE <BYTES>
	CONFIRM
	TLNE B,777777
	 ERROR<Number of bytes must be 0-262143>
	MOVE C,B
	MOVEI B,.SJRS
	JRST SETTAP
;"SET SPOOLED-OUTPUT"

SPLSET::NOISE <TO>
	KEYWD $SPSET
	 0
	 JRST CERR
	MOVEI B,.SJDFS
	JRST SETJOB

$SPSET:	TABLE
	T DEFERRED,ONEWRD,.SJSPD
	T IMMEDIATE,ONEWRD,.SJSPI
	TEND

;SET [NO] RETRIEVAL-WAIT (FOR OFFLINE FILES)

.OFL::	NOISE	<For offline files>
	SETO A,			;OUR OWN JOB
	MOVEI B,.SJDFR
	MOVEI C,.SJRFA		;NO RETRIEVAL-WAIT
	SKIPN SETNOF
	 MOVEI C,.SJRWA		;YES, RETRIEVAL-WAIT
	SETJB
	CALLRET CONF		;CONFIRM AND RETURN

;SET SESSION-REMARK (TO) TEXT

SETSRM::NOISE (TO)
	CALL GSR		;GET SESSION REMARK
	CALL SSR		;TELL SYSTEM THE REMARK
	CALLRET CONF		;CONFIRM AND RETURN

;ROUTINE TO GET SESSION REMARK
;RETURNS POINTER IN A

GSR::	LINEX <Session remark, one line of text>
	 CMERRX
	CALLRET BUFFF		;ISOLATE SESSION REMARK AND RETURN

;ROUTINE TO SET SESSION REMARK.  GIVE IT POINTER IN A.

SSR::	MOVE C,A		;PUT POINTER TO REMARK IN C
	MOVEI B,.SJSRM		;FUNCTION FOR SETTING SESSION REMARK
	MOVNI A,1		;SPECIFY CURRENT JOB
	SETJB			;SET REMARK
	 ERJMP .+2		;COULDN'T SET SESSION REMARK
	RET			;DONE
	ETYPE <%%Couldn't set session remark
>
	RET
;"SET CARD-READER-INPUT-SET"

CRDSET::NOISE <TO>
	WORDX <Name of input set>
	 CMERRX
	CALL BUFFF		;BUFFER NAME
	MOVEM A,CDRSTR		;SET A CDR INPUT SET NAME
	NOISE <STARTING WITH DECK NUMBER>
	DEFX <1>		;DEFAULT TO DECK #1
	DECX <Deck number in decimal>
	 CMERRX
	SKIPN B
	ERROR <Zero is illegal for deck number>
	MOVEM B,CDRDCK
	CONFIRM
	HRLOI A,.DVDES+.DVCDR	;SET FOR ALL CDR'S
	MOVEM A,CDRDEV
	MOVE A,[3,,.SPLDI]
	MOVEI B,CDRDEV		;ARGUMENT BLOCK
	SPOOL
	 CALL CJERR
	RET
$ESET:	TABLE
	T DATE-AND-TIME,,SETTAD		;^ESET SYSTEM DATE-AND-TIME
	T FAST-LOGINS-ALLOWED,ONEWRD,SETFST ;^ESET FAST-LOGINS-ALLOWED
IFN STANSW,<
	T INTERNET,,.INTRN		;^ESET INTERNET
>;IFN STANSW
	T LEVEL-ONE-MESSAGE,ONEWRD,SETMS1 ;^ESET LEVEL-ONE-MESSAGES
	T LEVEL-ZERO-MESSAGES,ONEWRD,SETMS0 ;^ESET LEVEL-ZERO-MESSAGES
	T LOGINS-ALLOWED,,TTYLOG	;^ESET LOGINS-ALLOWED
	T NO,NOLG,ESETNO		;^ESET NO
	T OPERATOR-IN-ATTENDANCE,ONEWRD,SETOPR	;^ESET OPERATOR
	T PRIVATE-QUASAR,,.GDEBG	;^ESET PRIVATE-QUASAR
IFN STANSW,<
	T PUP,,.PUP			;^ESET PUP
>;IFN STANSW
	T RUN-TIME-GUARANTEE,,.JRUNG	;^ESET JOB RUN-TIME
	T TERMINAL,,ETERMI		;^ESET TERMINAL (NUMBER)
	T WORKING-SET-PRELOADING,ONEWRD,SETWSP ;^ESET WORKING-SET-PRELOADING
	TEND

ESETNO:	SETOM SETNOF		;FLAG NO TYPED
	KEYWD $ESETN
	 0
	 JRST CERR
	TXNE P3,NOLG		;NEED TO BE LOGGED IN?
	SKIPE CUSRNO		;YES, ARE WE?
	CAIA			;OK
	ERROR <LOGIN please>
	JRST (P3)		;DISPATCH TO COMMAND

$ESETN:	TABLE
	T FAST-LOGINS-ALLOWED,ONEWRD,SETFST ;^ESET FAST-LOGINS-ALLOWED
IFN STANSW,<
	T INTERNET,,.INTRN		;^ESET NO INTERNET
>;IFN STANSW
	T LEVEL-ONE-MESSAGE,ONEWRD,SETMS1 ;^ESET NO LEVEL-ONE-MESSAGES
	T LEVEL-ZERO-MESSAGES,ONEWRD,SETMS0 ;^ESET NO LEVEL-ZERO-MESSAGES
	T LOGINS-ALLOWED,,TTYLOG	;^ESET NO LOGINS-ALLOWED
	T OPERATOR-IN-ATTENDANCE,ONEWRD,SETOPR	;^ESET NO OPERATOR
	T PRIVATE-QUASAR,,.GDEBG	;^ESET NO PRIVATE-QUASAR
IFN STANSW,<
	T PUP,,.PUP			;^ESET NO PUP
>;IFN STANSW
	T RUN-TIME-GUARANTEE,,.JRUNG	;^ESET NO RUN-TIME
	T WORKING-SET-PRELOADING,ONEWRD,SETWSP ;^ESET NO WORKING-SET-PRELOADING
	TEND
IFN STANSW,<
;PRIVILEGED COMMANDS FOR MANIPULATING THE INTERNET SOFTWARE

.INTRN:	KEYWD $INTTB		;PARSE THE NEXT KEYWORD
	  0			;NO DEFAULTS
	 JRST CERR		;HANDLE ERRORS
	JRST (P3)		;DISPATCH

$INTTB:	TABLE
	T BY-PASS,,.INBYP
	T GATEWAY-TABLE,,.INGWY
	T HOST-TABLE,,.INHST
	T SERVICE,,.INSRV
	TEND

IFNDEF .IPSIB,<.IPSIB==5>	;REMOVE THIS DEFINITION FOR REL 6

.INBYP:	MOVEI A,.IPSIB		;"^ESET [NO] INTERNET BY-PASS"
	JRST .INGW0

.INHST:	SKIPA A,[.IPINI]	;"^ESET INTERNET HOST-TABLE"
.INGWY:	MOVEI A,.IPGWY		;"^ESET INTERNET GATEWAY-TABLE"
.INGW0:	PUSH P,A		;SAVE FUNCTION CODE
	CONFIRM			;WAIT FOR CONFIRMATION 
	POP P,A			;RESTORE FUNCTION CODE
	SKIPE SETNOF		;WHICH SENSE OF SET?
	TDZA B,B		;TURNING SOMETHING OFF
	MOVEI B,1		;TURNING SOMETHING ON
	IPOPR%			;PERFORM THE FUNCTION
	 ERCAL CJERRE		;SOME ERROR
	RET			;RETURN TO CALLER
	
.INSRV:	NOISE <FOR ADDRESS>	;GIVE USER A HINT
	STKVAR <HSTNUM,HSTPTR,HSTCNT>	;LOCAL STORAGE
	SETZM HSTNUM		;NO HOST NUMBER YET
	MOVX A,<POINT 8,HSTNUM,3>
	MOVEM A,HSTPTR		;SET UP POINTER
	MOVEI A,4
	MOVEM A,HSTCNT		;SET UP BYTE COUNT
INSRV0:	MOVEI B,[FLDDB. .CMNUM,CM%SDH,^D10,<Decimal octet>]
	CALL FLDSKP		;READ A NUMBER
	 CMERRX <Decimal octet required>
	IDPB B,HSTPTR		;DEPOSIT BYTE
	SOSG HSTCNT		;DECREMENT BYTE COUNT
	 JRST INSRV1		;GO FINISH UP
	MOVEI B,[FLDDB. .CMTOK,,<-1,,[ASCIZ/./]>]
	CALL FLDSKP		;READ A PERIOD
	 CMERRX <"." required>
	JRST INSRV0		;GO GET NEXT OCTET

INSRV1:	CONFIRM			;WAIT FOR CONFIRMATION
	MOVEI A,.IPSNT		;FUNCTION IS SET NETWORK STATE
	MOVE B,HSTNUM		;HOST NUMBER
	SKIPE SETNOF		;WHICH SENSE OF SET?
	TDZA C,C		;TURNING SOMETHING OFF
	 SETO C,		;TURNING SOMETHING ON (C = 1 WOULD CYCLE NET)
	IPOPR%			;PERFORM THE FUNCTION
	 ERCAL CJERRE		;SOME ERROR
	RET			;RETURN TO CALLER
	ENDSV.
;PRIVILEGED COMMANDS FOR MANIPULATING THE PUP ETHERNET

.PUP:	KEYWD $PUPTB		;PARSE THE NEXT KEYWORD
	  0			;NO DEFAULTS
	 JRST CERR		;HANDLE ERRORS
	CONFIRM			;WAIT FOR CONFIRMATION
	JRST (P3)		;DISPATCH

$PUPTB:	TABLE
	T BUG-LOGGING,,.PUBUG
	T GATEWAY,,.PUGAT
	T HOST-TABLE,,.PUHST
	T SERVICE,,.PUSRV
	TEND

.PUHST:	SKIPA A,[.SFDIR]	;"^ESET PUP HOST-TABLE"
.PUGAT:	MOVEI A,.SFGAT		;"^ESET [NO] PUP GATEWAY"
	JRST .PUPB0		;JOIN COMMON CODE

.PUSRV:	SKIPA A,[.SFPUP]	;"^ESET [NO] PUP SERVICE"
.PUBUG:	MOVEI A,.SFBUG		;"^ESET [NO] PUP BUG-LOGGING"
.PUPB0:	SKIPE SETNOF		;WHICH SENSE OF SET?
	TDZA B,B		;TURNING SOMETHING OFF
	MOVEI B,1		;TURNING SOMETHING ON
	SMON%			;DO THE FUNCTION
	 ERCAL CJERRE		;SOME ERROR
	RET			;RETURN TO CALLER
>;IFN STANSW
;"^ESET TERMINAL (NUMBER)"

IFE NICSW,<			;[NIC1041]
ETERMI::TRVAR <ETNM,ETRG,ETTN>
	NOISE <NUMBER>
	OCTX <Octal terminal number>
	 CMERRX
	MOVEM B,ETTN		;SAVE TERMINAL NUMBER
	CALL ETSET		;OBTAIN TERMINAL DESIGNATOR
	MOVEM B,ETNM		;SAVE DESIGNATOR
	MOVEM B,ETRG		;ASSUME THIS IS THE HIGHEST
	MOVEI B,$ETRM		;GET FIELDS TO PARSE
	CALL FLDSKP		;PARSE TERMINAL NUMBER OR KEYWORD
	 CMERRX			;PARSING ERROR
	HRRZ C,C		;ISOLATE FIELD PARSED
	HRRZ P3,(B)		;GET TABLE ADDRESS IF KEYWORD
	MOVE P3,(P3)		;ISOLATE ROUTINE
	CAIE C,$ETRM		;JUST TYPED KEYWORD?
	 JRST ETKEY		;YES - SKIP RANGE PROCESSING
	MOVEM B,ETTN		;SAVE TERMINAL NUMBER
	CALL ETSET		;OBTAIN TERMINAL DESIGNATOR
	MOVEM B,ETRG		;SAVE DESIGNATOR
	MOVE A,ETNM		;GET STARTING TERMINAL DESIGNATOR
	CAMGE B,A		;VALID RANGE?
	 ERROR <Invalid terminal range>  ;NO, ERROR
	KEYWD $ETERM
	 T SPEED,,SPEEDA
	 JRST CERR
ETKEY:	MOVE A,ETNM		;GET STARTING TERMINAL DESIGNATOR
	MOVE B,ETRG		;GET HIGHEST RANGE DESIGNATOR
	JRST (P3)		;SET SPEEDS

ETSET:	MOVE A,CSBUFP		;GET SOME SCRATCH SPACE
	MOVEI C,0		;END STRING ON NULL
	HRROI B,[ASCIZ /TTY/]	;MAKE DEVICE NAME
	SOUT
	MOVE B,ETTN		;GET NUMBER HE TYPED
	MOVEI C,8		;OCTAL
	NOUT			;MAKE "TTYnnn"
	 ERCAL JERRE		;SHOULD NEVER FAIL
	MOVE A,CSBUFP		;POINT AT THE NAME
	STDEV			;GET DESIGNATOR FOR IT
	 ERCAL CJERRE		;FAILED, TELL USER TERMINAL DOESN'T EXIST
	RET			;RETURN WITH DESIGNATOR

$ETERM:	TABLE
	T SPEED,,SPEEDA
	TEND

$ETRM:	FLDDB. .CMNUM,CM%SDH,8,<Highest octal terminal number if specifing range>,SPEED,[FLDDB. .CMKEY,CM%DPP,$ETERM]
>;IFE NICSW

IFN NICSW,<			;[NIC1041]
ETERMI::STKVAR <ETNM>		;[NIC1041]
	NOISE <NUMBER>		;[NIC1041]
	OCTX <Octal terminal number>	;[NIC1041]
	 CMERRX			;[NIC1041]
	MOVEM B,ETNM		;[NIC1041]
	MOVE A,CSBUFP		;[NIC1041] GET SOME SCRATCH SPACE
	MOVEI C,0		;[NIC1041] END STRING OUTPUT ON NULL
	HRROI B,[ASCIZ /TTY/]	;[NIC1041] MAKE DEVICE NAME
	SOUT			;[NIC1041]
	MOVE B,ETNM		;[NIC1041] GET NUMBER HE TYPED
	MOVEI C,8		;[NIC1041] OCTAL
	NOUT			;[NIC1041] MAKE "TTYnnn"
	 ERCAL JERRE		;[NIC1041] SHOULD NEVER FAIL
	MOVE A,CSBUFP		;[NIC1041] POINT AT THE NAME
	STDEV			;[NIC1041] GET DESIGNATOR FOR IT
	 ERCAL CJERRE		;[NIC1041] FAILED, TELL USER THAT TERMINAL DOESN'T EXIST
	MOVE Q1,B		;[NIC1041] SAVE TERMINAL TO USE HERE
	JRST .TERM0		;[NIC1041] JOIN CODE IN TEMRINAL COMMAND
>;IFN NICSW
;"^ESET [NO] SYSTEM LOGINS-ALLOWED"

TTYLOG:	NOISE <ON>
	KEYWD $LGTTY
	 T ANY-TERMINAL,ONEWRD,.ANTTY
	 JRST CERR
	JRST (P3)

$LGTTY:	TABLE
	T ANY-TERMINAL,ONEWRD,.ANTTY
	T ARPANET-TERMINALS,ONEWRD,.NVTTY
	T CONSOLE-TERMINAL,ONEWRD,.CNTTY
	T DECNET-TERMINALS,ONEWRD,.MCTTY
IFN STANSW&PUPSW,<
	T ETHERNET-TERMINALS,ONEWRD,.ENTTY
>;IFN STANSW&PUPSW
	T LOCAL-TERMINALS,ONEWRD,.LCTTY
	T PSEUDO-TERMINALS,ONEWRD,.PSTTY
	T REMOTE-TERMINALS,ONEWRD,.RMTTY
	TEND

;DO SET FOR ALL TERMINALS

.ANTTY:	CALL .CNTTY
IFN STANSW&PUPSW,<
	CALL .ENTTY
>;IFN STANSW&PUPSW
	CALL .LCTTY
	CALL .NVTTY
	CALL .PSTTY
	CALL .MCTTY
;	CALLRET .RMTTY

.RMTTY:	MOVEI A,.SFRMT
DOSTTY:	SKIPE SETNOF		;NO?
	TDZA B,B		;DISALLOW LOGINS
	MOVEI B,1		;ALLOW LOGINS
	SMON
	 ERCAL CJERRE
	RET

.CNTTY:	MOVEI A,.SFCTY
	JRST DOSTTY

IFN STANSW&PUPSW,<
.ENTTY:	MOVEI A,.SFPNV
	JRST DOSTTY
>;IFN STANSW&PUPSW

.LCTTY:	MOVEI A,.SFLCL
	JRST DOSTTY

.NVTTY:	MOVEI A,.SFNVT
	JRST DOSTTY

.PSTTY:	MOVEI A,.SFPTY
	JRST DOSTTY

.MCTTY:	MOVEI A,.SFMCB		;GET DECNET CODE
	JRST DOSTTY		;CONTINUE AT LOGIN TEST

;^ESET FAST-LOGINS-ALLOWED

SETFST:	MOVX A,.SFXEC		;GET THE EXEC FLAGS WORD
	TMON
	 ERCAL CJERRE		
	TXO B,XC%FST		;SET THE NO FAST LOGINS FLAG BY DEFAULT
	SKIPN SETNOF		;^ESET NO FAST-LOGINS-ALLOWED ?
	 TXZ B,XC%FST		;NO.  ALLOW IT
	SMON			;SET THE FLAGS WORD
	 ERCAL CJERRE
	RET


;"^ESET SYSTEM OPERATOR-IN-ATTENDANCE"

SETOPR:	MOVEI A,.SFOPR
	JRST SETMSS		;JOIN COMMON CODE

;"^ESET LEVEL-ZERO-MESSAGES"

SETMS0:	MOVEI A,.SFMS0		;GET THE SMON FUNCTION
SETMSS:	SETO B,			;ASSUME WE ARE SETTING
	SKIPE SETNOF		;IS IT A NO COMMAND?
	 SETZ B,		;YES OF COURSE
	SMON			;SET THE WORD FOR THE MONITOR
	 ERCAL CJERRE
	RET			;AND GET ANOTHER COMMAND

;"^ESET LEVEL-ONE-MESSAGES"

SETMS1:	MOVEI A,.SFMS1		;GET THE SMON FUNCTION
	JRST SETMSS		;JOIN COMMON CODE

;"^ESET WORKING-SET-PRELOADING"

SETWSP:	MOVEI A,.SFWSP		;GET THE SMON FUNCTION
	JRST SETMSS		;JOIN COMMON CODE
;^ESET PRIVATE-QUASAR ON OR OFF

GQFDB:	FLDDB. .CMUSR,,,,,[		;USER ID ONE POSSIBILITY
	FLDDB. .CMCFM     ]		;END OF LINE ANOTHER POSSIBILITY

.GDEBG:	NOISE <for private GALAXY>
	SKIPE	SETNOF		;OFF?
	JRST	[CONFIRM	;YES - GET CONFIRMATION
		 SETZM QSRPID	;GET IT, CLEAR QUASAR'S PID
		 RET    ]	;AND RETURN
	MOVEI B,GQFDB		;POINT TO FDB ADDRESS
	CALL FLDSKP		;SEE WHAT THE USER TYPED
	 ERROR	<Invalid userid specified>
	LDB A,[331100,,.CMFNP(C)] ;FIND OUT WHAT GOT TYPED
	CAIN A,.CMCFM		;END OF LINE?
	TDZA B,B		;YES - ZERO AC 2 AND SKIP
	CONFIRM			;NO - GET CONFIRM
	MOVE A,B		;GET THE USERID IN A
	CALL GQSRPD		;GET PRIVATE QUASAR PID
	RET			;RETURN

.JRUNG:	NOISE <FOR JOB>
	DECX <Job number in decimal>
	 CMERRX
	PUSH P,B		;SAVE JOB NUMBER
	SKIPE SETNOF		;NO?
	JRST	[SETZ B,	;YES, 0 PERCENTAGE
		JRST .JRUN1]
	NOISE <TO>
	DECX <Percentage>
	 CMERRX
	NOISE <PERCENT>
	CAIL B,1
	CAILE B,^D100
	ERROR <Run time guarantee percentage must be from 1-100>
.JRUN1:	CONFIRM
	HRLZ B,B		;MAKE LEFT HALF NUMBER
	POP P,A			;GET JOB NUMBER BACK
	SJPRI			;SET IT
	 ERJMP CJERRE
	RET
;SET TIME-LIMIT (TO) N

.STMLM::NOISE <TO>
	DECX <Number of seconds>
	 CMERRX
	NOISE <SECONDS>
	CONFIRM
	JUMPE B,[ERROR <Use "SET NO TIME-LIMIT">]
	JUMPL B,[ERROR <Negative number not allowed>]
	IMULI B,^D1000		;MAKE IT MILLISECONDS
	PUSH P,B
	MOVEI A,.FHJOB
	RUNTM			;GET TIME IN MILLISECONDS
	POP P,B
	ADD B,A			;ADD TO GET FINAL RUNTIME
	CAIGE B,^D1000		;IS IT LESS THAN 1 SECOND?
	MOVEI B,^D1000		;OK, MAKE IT 1 SECOND INSTEAD
	MOVE A,[.FHJOB,,.TIMRT]	;SET TIME LIMIT CODE
	MOVEI C,4		;CHANNEL
	TIMER
	 CALL CJERR
	RET

.NOTIM::CONFIRM
	IFNBATCH NOTIM1
	MOVE A,[.FHJOB,,.TIMRT]	;SET TIME LIMIT CODE
	SETZB B,C		;NO TIME, (HENCE NO CHANNEL)
	TIMER
	 CALL CJERR
	RET

NOTIM1:	ERROR <Attempt to clear time limit during BATCH process>

;^ESET SYSTEM TIME-AND-DATE (TO)

SETTAD::NOISE <TO>
	DTX <Date and time>
	 CMERRX
	CONFIRM			;CHECK TERMINATOR, INPUT CR IF NECESSARY
IFE STANSW,<
	MOVE A,B		;PUT TIME AND DATE INTO AC1
>;IFE STANSW
IFN STANSW,<
	PUSH P,B
	TYPE <If the system clock is wrong, you should reload the system>
	CALL FCONF
	POP P,A
>;IFN STANSW
	STAD			;SET TIME AND DATE
	 CALL CJERR
	RET
IFE STANSW,<
ECEASE::TRVAR <DWNAT>
	NOISE <TIMESHARING AT>
	DTX <Date/time, or NOW for immediately, or null to cancel shutdown>
	 JRST CEASE3
DT1:	MOVEM B,DWNAT		;SAVE CURRENT DOWN TIME
	NOISE <RESUMING AT>
	DTX <Date and time of restart or null if unknown>
	 JRST CEASE4		;NO DATE AND TIME TYPED
CEASE1:	CONFIRM
	SKIPN A,DWNAT
	JRST CEASE2		;SKIP CHECK IF CANCELING
	CALL ECCNFM		;REALLY CONFIRM THE CEASE
	GTAD
	SETO C,			;CHECK FOR IMMEDIATE FLAG
	CAMN C,DWNAT		;MATCH ?
	 JRST [MOVEM A,DWNAT	;YES.  NOW CHECK "DOWN AT" TIME
	       JRST EC1A]	;CHECK "RESUME AT" TIME
	CAML A,DWNAT
	ERROR <Down time has already passed>
EC1A:	JUMPE B,CEASE2
	CAMGE B,DWNAT
	ERROR <Timesharing will resume before it ends!>
CEASE2:	MOVE A,DWNAT		;GET TIME TO GO DOWN
	HSYS			;DO THE SHUTDOWN
	 JRST CJERR
	RET

CEASE3:	KEYWD $ECNOW		;SEE IF USER TYPED A KEYWD
	 0			;NO DEFAULT
	 JRST EC3A     		;NO. NULL RESPONSE
	MOVE B,[-1]		;FLAG THE "NOW"
	JRST DT1		;SEE IF ANY RESUME AT TIME

EC3A:	SETZM DWNAT		;FLAG FOR CANCEL
CEASE4:	SETZ B,			;NO RESUME AT TIME
	JRST CEASE1

$ECNOW:	TABLE			;ARG TABLE FOR "NOW"
	T NOW,,0
	TEND

;Here to re-confirm the ^Ecease. Lots of systems are on networks now,
;and people have more than once ^Ecease'd the wrong system.
ECCNFM:	SAVEAC <B>
	CALL GETNOD		;TRY TO GET THE DECNET 
	 JRST ECARPA		;PROBABLY NO DECNET.  TRY ARPA
	ETYPE < %1M>		;TYPE OUT DECNET NAME
	JRST ECNAMD		;NAME HAS BEEN TYPED. DON'T TRY ARPA.
ECARPA:	ETYPE < >
	MOVEI A,.GTHSZ		;NOW TRY ARPANET 
	GTHST			;GET LOCAL HOST NUMBER
	 ERJMP ECNAMD		;PROBABLY NO ARPA
	MOVEI A,.GTHNS		;RETURN HOST STRING TO THE
	MOVE B,COJFN		; OUTPUT DESIGNATOR
	MOVE C,D		;PICK UP LOCAL HOST NUMBER 
	GTHST			;TYPE THE HOST NUMBER OUT
	 ERJMP .+1		;FAILS IF NO HOST # ON ARPA MONITOR
ECNAMD:	MOVE A,DWNAT		;GET DOWNTIME BACK
	CAME A,[-1]		;IS IT IMMEDIATELY
	 ETYPE < Shut down scheduled for %1D %1E> ;NO
	CAMN A,[-1]
	 ETYPE < Will be shut down IMMEDIATELY > ;YES
	CALL FCONF
	RET
>;IFE STANSW


IFN STANSW,<
;STANFORD'S ^ECEASE COMMAND

ECEASE::NOISE <TIMESHARING>
	DTX <Date and time,
or one of the following:
 CANCEL		NOW>		;WHAT A CROCK!!
	 JRST [	KEYWD $CEASE
		 0		;NO DEFAULT
		 JRST CERR
		JRST (P3)]	;DISPATCH TO COMMAND
	GTAD%
	CAML A,B		;IS SHUTDOWN TIME BEFORE NOW?
	 ERROR <Shutdown time has already passed>
	PUSH P,B		;SAVE THE TIME
	NOISE <RESUMING>
	DTX <Date and time, or return if unknown>
	 JRST [	SETZ B,
		JRST CEASE5]
	CAMG B,(P)		;IS SHUTDOWN AFTER RESTART?
	 ERROR <Shutdown time is after restart time>
CEASE5:	PUSH P,B		;SAVE RESTART TIME
CEASE4:	CONFIRM
	PROMPT <Reason:  >	;PROMPT ON NEXT LINE
	LINEX <Reason for shutdown (less than 80 characters)>
	 CMERRX
	MOVEI C,ATMBUF		;POINTER TO REASON STRING
	POP P,B			;GET BACK RESTART TIME
	POP P,A			;GET BACK SHUTDOWN TIME
CEASE3:	HSYS%			;DO IT!
	 ERCAL CJERR
	RET

$CEASE:	TABLE
	T CANCEL,,CANCEA
	T NOW,,NOWCEA
	TEND

NOWCEA:	CONFIRM
	GTAD%			;GET CURRENT TIME
	ADDI A,3*^D10		;ADD A LITTLE FUZZ TO MAKE IT RIGHT
	SETZB B,C		;MAKE OTHER AC'S RIGHT
	JRST CEASE3

CANCEA:	NOISE <SHUTDOWN>
	CONFIRM
	SETZB A,B		;NO TIME, CANCEL CURRENT
	JRST CEASE3
>;IFN STANSW

;SET TYPEOUT CONTROLS HOW MEMORY ADDRESSES AND CONTENTS ARE DISPLAYED.

.TYPEO::KEYWD TYTAB
	 T MODE
	 CMERRX
	CALLRET (P3)		;EXIT THROUGH SPECIFIED KEYWORD ROUTINE

TYTAB:	TABLE
	T MODE
IFN STANSW,<
	T RADIX
>;IFN STANSW
;	T RADIX		;ETC.
	TEND

.MODE:	NOISE (to)
	KEYWD MODTAB
	 0
	 CMERRX
	CALLRET (P3)

MODTAB:	TABLE
;	T ASCII
	T NUMERIC,ONEWRD
	T SYMBOLIC,ONEWRD
	TEND

.NUMER:	SETZM SYMF		;SAY NOT SYMBOLIC
	RET

.SYMBO:	SETOM SYMF		;SAY SYMBOLIC
	RET

IFN STANSW,<
.RADIX:	NOISE (TO)
	DEFX <8>
	DECX <Radix for numeric output>
	 CMERRX
	CAIL B,2		;BASE MUST BE BETWEEN 2 AND 36
	 CAILE B,^D36
	  ERROR <Base must be between 2 and 36>
	CONFIRM
	MOVEM B,TRADIX		;SET TYPEOUT RADIX
	RET
>;IFN STANSW
IFN STANSW,<
; THE SET PROMPT COMMAND WILL ACCEPT FOUR QUOTED TEXT STRINGS AND USE
; THEM AS THE NONPRIV. PROMPT, NONPRIV. SUBCOMMAND PROMPT, PRIV. PROMPT,
; AND PRIV. SUBCOMMAND PROMPT.

.PROMP::TRVAR <NPMT,NSPMT,PPMT,PSPMT> ;TEMP. POINTERS FOR STRINGS
	SETZM NPMT		;INITIALIZE ALL PTRS
	SETZM NSPMT
	SETZM PPMT
	SETZM PSPMT
	SKIPN PCSFRE		;PCL FREE SPACE INITIALIZED
	 JRST [ MOVSI A,PCSTRL*512 ;NO, SO DO IT
		MOVEM A,PCSTRS
		MOVEI A,PCSTRS
		MOVEM A,PCSFRE
		JRST .+1]
	NOISE (To)
	MOVEI B,[FLDDB. .CMQST,CM%SDH,,<Regular prompt in quotes>,<"@">,[
		 FLDDB. .CMCFM]]
	CALL FLDSKP		;TRY TO PARSE THIS
	 CMERRX			;FORGET IT
	LDB C,[POINT 9,0(C),8]	;GET WHAT WAS PARSED
	CAIN C,.CMCFM		;WAS IT EOL
	 JRST .PROM1		;YES, GO SET THEM
	HRROI A,ATMBUF		;GET PTR TO ATOM BUFFER
	HRROI B,REDPMT		;COMPARE IT TO DEFAULT
	STCMP%
	SKIPN A			;ARE THEY THE SAME
	 SETZM ATMBUF		;THEN ZERO BUFFER
	HRROI A,ATMBUF		;GET PTR TO ATOM BUFFER
	CALL BCOUNT		;COUNT THE CHARACTERS
	MOVEI A,ATMBUF		;GET THE ADDRESS
	HRL A,B			;SLIDE IN THE COUNT
	CALL PCECST		;COPY THE STRING
	MOVEM A,NPMT		;AND SAVE IT
	NOISE <,>
	MOVEI B,[FLDDB. .CMQST,CM%SDH,,<Subcommand prompt in quotes>,<"@@">,[
		 FLDDB. .CMCFM]]
	CALL FLDSKP		;WAS IT PARSABLE
	 CMERRX			;NO
	LDB C,[POINT 9,0(C),8]	;GET CODE OF PARSE
	CAIN C,.CMCFM		;WAS IT CONFIRM
	 JRST .PROM1		;GO SET THEM THEN
	HRROI A,ATMBUF		;GET PTR TO ATOM BUFFER
	HRROI B,REDPMT+3	;COMPARE IT TO DEFAULT
	STCMP%
	SKIPN A			;IF NON-ZERO, THEN STRING DIFFER
	 SETZM ATMBUF		;ZERO BUFFER FOR NO CHANGE
	HRROI A,ATMBUF		;GET PTR TO BUFFER
	CALL BCOUNT		;GET CHARACTER COUNT
	MOVEI A,ATMBUF		;ADDRESS TO ATOM BUFFER
	HRL A,B			;COUNT OF CHARACTERS IN LH
	CALL PCECST		;PCL COPY STRING
	MOVEM A,NSPMT		;AND SAVE PTR
	NOISE <,>
	MOVEI B,[FLDDB. .CMQST,CM%SDH,,<Enabled prompt in quotes>,<"!">,[
		 FLDDB. .CMCFM]]
	CALL FLDSKP		;ITS JUST IMPARSABLE
	 CMERRX			;YES
	LDB C,[POINT 9,0(C),8]	;GET PARSE FUNCTION
	CAIN C,.CMCFM		;WAS IT A CONFIRM
	 JRST .PROM1		;YES, THEN GO SET PROMPTS
	HRROI A,ATMBUF		;GET PTR TO ATOM BUFFER
	HRROI B,REDPMT+1	;COMPARE IT TO DEFAULT
	STCMP%
	SKIPN A			;IF NON-ZERO, THEN STRING DIFFER
	 SETZM ATMBUF		;ZERO BUFFER FOR NO CHANGE
	HRROI A,ATMBUF		;GET PTR TO BUFFER
	CALL BCOUNT		;GET CHARACTER COUNT
	MOVEI A,ATMBUF		;ADDRESS TO ATOM BUFFER
	HRL A,B			;COUNT OF CHARACTERS IN LH
	CALL PCECST		;PCL COPY STRING
	MOVEM A,PPMT		;SAVE IT
	NOISE <AND>		;SOME MORE
	MOVEI B,[FLDDB. .CMQST,CM%SDH,,<Enabled subcommand prompt in quotes>,<"!!">,[
		 FLDDB. .CMCFM]]
	CALL FLDSKP		;PARSE IT
	 CMERRX			;NOPE
	LDB C,[POINT 9,0(C),8]	;GET PARSE FUNCTION CODE
	CAIN C,.CMCFM		;WAS IT CRLF
	 JRST .PROM1		;YES, SET PROMPTS
	HRROI A,ATMBUF		;GET PTR TO ATOM BUFFER
	HRROI B,REDPMT+4	;COMPARE IT TO DEFAULT
	STCMP%
	SKIPN A			;IF NON-ZERO, THEN STRING DIFFER
	 SETZM ATMBUF		;ZERO BUFFER FOR NO CHANGE
	HRROI A,ATMBUF		;GET PTR TO BUFFER
	CALL BCOUNT		;GET CHARACTER COUNT
	MOVEI A,ATMBUF		;ADDRESS TO ATOM BUFFER
	HRL A,B			;COUNT OF CHARACTERS IN LH
	CALL PCECST		;PCL COPY STRING
	MOVEM A,PSPMT		;SAVE THE PTR
	CONFIRM

;HERE TO SET THE PROMPTS
.PROM1:	SKIPE SETLVL		;ARE WE IN "SET LEVEL"
	 JRST [ ETYPE <Can't set prompts with level-indication enabled.%_>
		JRST .PROM2]	;FINISH UP
	CALL PIOFF		;NO ^C THROUGH HERE
	MOVE A,NPMT		;GET NONPRIVED. PROMPT
	MOVEI B,1		;SAY TO SET PROMPT
	CALL DIVPMR
	MOVE A,NSPMT		;GET REG. SUB. PROMPT
	MOVEI B,1		;SET PROMPT
	CALL DIVPMS
	MOVE A,PPMT		;ENABLE PTR PROMPT
	MOVEI B,1		;SET PROMPT
	CALL DIVPME
	MOVE A,PSPMT		;GET PRIV. SUBCOMMAND.
	MOVEI B,1		;SET PROMPT
	CALL DIVPMU
	CALL PION		;ENABLE ^C NOW.
.PROM2:	SETZM PCSFRE		;RESTORE PCL STRING SPACE
	RET			;AND RETURN

; SET [NO] LEVEL-INDICATION
.SLEVL::STKVAR <NPMT,NSPMT,PPMT,PSPMT,LEVEL> ;STORAGE WITH .PROMP
	SETZM NPMT		;INIT. ALL POINTERS
	SETZM NSPMT
	SETZM PPMT
	SETZM PSPMT
	SKIPN PCSFRE		;PCL FREE SPACE INITIALIZED
	 JRST [ MOVSI A,PCSTRL*512 ;NO, SO DO IT
		MOVEM A,PCSTRS
		MOVEI A,PCSTRS
		MOVEM A,PCSFRE
		JRST .+1]
	CALL GSLEV		;RETURN SUB-LEVELS IN B
	JUMPE B,R		;RETURN IF LEVEL 0.
	MOVEM B,LEVEL		;SAVE IT FOR LATER
	SKIPE SETNOF		;WAS "NO" SPECIFIED?
	 JRST .SLEV2		;YES, SO REMOVE NUMBER
	SKIPE SETLVL		;HAVE WE SET LEVEL ONCE?
	 RET			;YES, SO DON'T DO IT AGAIN
	SKIPN A,PCLPMT		;GET PCL NONPRIV. REG. PROMPT
	 MOVEI A,REDPMT		;IF NOT, GET DEFAULT
	HRROS A			;MAKE A STRING PTR
	MOVE B,LEVEL		;GET LEVEL
	CALL .SLEV1		;CALL A ROUTINE TO BUILD STRING
	MOVEM A,NPMT		;SAVE NEW PROMPT
	SKIPN A,PCLPMT+3	;PCL NON-PRIV. SUB. PROMPT
	 MOVEI A,REDPMT+3	;DEFAULT
	HRROS A			;MAKE PTR
	MOVE B,LEVEL		;GET LEVEL
	CALL .SLEV1		;CREATE PROPER PROMPT
	MOVEM A,NSPMT		;AND SAVE IT
	SKIPN A,PCLPMT+1	;PCL PRIV. PROMPT
	 MOVEI A,REDPMT+1	;DEFAULT PRIV. PROMPT
	HRROS A			;FORM PTR
	MOVE B,LEVEL		;GET LEVEL
	CALL .SLEV1		;CREATE PROMPT
	MOVEM A,PPMT		;AND SAVE IT
	SKIPN A,PCLPMT+4	;PCL PRIV. SUB. PROMPT
	 MOVEI A,REDPMT+4	;DEFAULT.
	HRROS A			;MAKE PTR
	MOVE B,LEVEL		;GET LEVEL
	CALL .SLEV1		;ROUTINE TO ADD NUMBER
	MOVEM A,PSPMT		;SAVE IT
	SETOM SETLVL		;REMEMBER WE ARE LEVEL INDICATING
	JRST .SLEV4		;SET THE PROMPTS

;THIS ROUTINE TAKE A STRING PTR TO PROMPT IN A. IT WILL CREATE
; THE PROMPT WITH THE LEVEL IN FRONT. LEVEL NUMBER IS IN B.
; THE PTR TO THE NEW PROMPT WILL RETURN IN A.

.SLEV1:	PUSH P,A		;SAVE ORIGINAL PTR
	PUSH P,B		;SAVE LEVEL COUNT
	CALL BCOUNT		;COUNT CHARACTERS AND WORDS
	ADDI A,2		;MAKE ROOM FOR LEVEL
	CALL GETBUF		;AND GET A BUFFER
	HRLI A,(<POINT 7,>)	;MAKE IT A POINTER
	POP P,D			;GET LEVEL IN D
	POP P,B			;GET ORIGINAL BACK
	PUSH P,A		;AND SAVE NEW PTR FIRST
	PUSH P,B		;THEN SAVE OLD PTR
	MOVE B,D		;GET THE LEVEL BACK
	MOVEI C,^D10		;OUTPUT IT IN DECIMAL
	NOUT%
	 CALL CJERR		;SHOULDN'T HAPPEN
	POP P,B			;RESTORE PTR TO ORIG. PROMPT
	SETZ C,			;COPY TILL NULL
	SOUT%
	 ERJMP CJERR		;SHOULDN'T HAPPEN EITHER
	MOVE A,0(P)		;POP PTR TO STRING WE JUST MADE
	CALL BCOUNT		;COUNT IT UP
	MOVE A,0(P)		;GET PTR BACK
	HRL A,B			;PUT CHAR. COUNT IN LH.
	CALL PCECST		;CALL PCL FREE SPACE ROUTINE
	EXCH A,0(P)		;SAVE NEW AND RESTORE OLD
	CALL STREM		;RESTORE OLD MEMORY
	POP P,A			;RETURN NEW
	RET

;SET NO LEVEL-INDICATION

.SLEV2:	SKIPN SETLVL		;MAKE SURE WE HAVE SET LEVEL
	 RET			;IF NOT, THEN QUIT
	MOVE D,LEVEL		;GET LEVEL NUMBER
	IDIVI D,^D10		;GET NUMBER OF DIGITS
	ADDI D,1		;MAKE IT CORRECT
	MOVEM D,LEVEL		;SAVE IT
	HRRO A,PCLPMT		;GET NON-PRIV PROMPT
	HRLI A,(<POINT 7,>)	;MAKE PTR
	HRROI B,REDPMT		;DEFAULT TO COMPARE AGAINST
	MOVE C,LEVEL		;GET LEVEL
	CALL .SLEV3		;ROUTINE TO FIX PROMPT
	MOVEM A,NPMT		;SAVE NEW PTR
	HRRO A,PCLPMT+3		;GET NON-PRIV SUB. PROMPT
	HRLI A,(<POINT 7,>)	;MAKE PTR
	HRROI B,REDPMT+3	;COMPARE AGAINST THIS
	MOVE C,LEVEL		;GET LEVEL
	CALL .SLEV3		;FIX IT
	MOVEM A,NSPMT		;SAVE IT
	HRRO A,PCLPMT+1		;GET PRIV PROMPT
	HRLI A,(<POINT 7,>)	;MAKE PTR
	HRROI B,REDPMT+1	;COMPARE AGAINST DEFAULT
	MOVE C,LEVEL		;GET LEVEL
	CALL .SLEV3		;FIX IT UP
	MOVEM A,PPMT		;SAVE IT FOR LATER
	HRRO A,PCLPMT+4		;GET PRIV SUB. PROMPT
	HRLI A,(<POINT 7,>)	;MAKE PTR
	HRROI B,REDPMT+4	;USE THIS TO COMPARE AGAINST
	MOVE C,LEVEL		;GET LEVEL
	CALL .SLEV3		;ROUTINE THAT FIXES PROMPT
	MOVEM A,PSPMT		;SAVE IT
	SETZM SETLVL		;MARK AS NO LEVEL
	JRST .SLEV4		;GO SET THE PROMPTS

;THIS ROUTINE WILL STRIP THE NUMBER OF CHARACTERS IN LEVEL
; OFF OF THE GIVEN STRING IN A. PASS STRING TO COMPARE IT TO IN B. LEVEL IN C.
; RETURN THE FIXED UP STRING IN A.

.SLEV3:	ADJBP C,A		;ADJUST STRING PAST NUMBER
	MOVE A,C		;GET CORRECT PTR IN A
	PUSH P,A		;SAVE CURRENT PLACE
	STCMP%			;TO SEE IF SAME
	SKIPN A			;WERE THEY?
	 SETZM 0(P)		;YES, ZERO ORIGINAL
	MOVE A,0(P)		;GET PTR BACK
	CALL BCOUNT		;COUNT THE CHARACTERS AND WORDS
	PUSH P,B		;SAVE CHAR. COUNT
	CALL GETBUF		;GET NUMBER OF WORDS
	HRLI A,(<POINT 7,>)	;MAKE A PTR
	POP P,D			;GET CHAR. COUNT
	POP P,B			;RESTORE ADVANCED PTR
	PUSH P,A		;SAVE NEW PTR
	SETZ C,			;COPY TILL NULL
	SOUT%
	 ERJMP CJERR		;ERROR!
	MOVE A,0(P)		;GET NEW PTR BACK
	HRL A,D			;PUT CHAR. COUNT IN LH
	CALL PCECST		;AND USE PCL FREE SPACE
	EXCH A,0(P)		;SWAP PCL PTR WITH TEMP. PTR
	CALL STREM		;AND RETURN IT TO FREE POOL
	POP P,A			;RESTORE PCL PTR
	RET			;AND BE DONE
	
;HERE TO SET THE PROMPTS
.SLEV4::CALL PIOFF		;NO ^C THROUGH HERE
	MOVE A,NPMT		;GET NONPRIVED. PROMPT
	MOVEI B,1		;SAY TO SET PROMPT
	CALL DIVPMR
	MOVE A,NSPMT		;GET REG. SUB. PROMPT
	MOVEI B,1		;SET PROMPT
	CALL DIVPMS
	MOVE A,PPMT		;ENABLE PTR PROMPT
	MOVEI B,1		;SET PROMPT
	CALL DIVPME
	MOVE A,PSPMT		;GET PRIV. SUBCOMMAND.
	MOVEI B,1		;SET PROMPT
	CALL DIVPMU
	CALL PION		;ENABLE ^C NOW.
	SETZM PCSFRE		;RESTORE PCL STRING SPACE
	RET			;AND RETURN

;SUBROUTINE TO RETURN THE NUMBER OF SUPERIORS IN B.
; LEAVES ALL OTHER AC'S INTACT.

GSLEV:	PUSH P,A		;SAVE AC'S
	PUSH P,C
	MOVX A,.FHTOP		;START AT THE TOP
	SETZ B,			;RETURN NOTHING
	MOVE C,[-300,,BUF0]	;RETURN STRUCTURE HERE
	GFRKS%			;GET FORK STRUCTURE
	 JRST [ CAIE A,GFKSX1	;AREA TOO SMALL?
		 JRST JERR	;SOMETHING ELSE
		JRST .+1]	;THEN IGNORE
	MOVE C,[-277,,BUF0+1]	;POINT TO TOP PROCESS HANDLE
GSLEV1:	HRRZ A,(C)		;GET POSSIBLE HANDLE
	CAIN A,.FHSLF		;US YET?
	 JRST GSLEV2		;YES, GO COUNT SUPERIORS
	AOBJP C,GSLEVE		;SKIP STATUS WORD
	AOBJP C,GSLEVE		;AND POINTERS
	AOBJN C,GSLEV1		;GO BACK FOR ANOTHER LOOK
GSLEVE:	ERROR <Can't find self in fork structure>
GSLEV2:	HLRZ C,(C)		;GET POINTER TO SUPERIOR
	JUMPE C,GSLEV3		;IF NO SUPERIOR, WE'RE DONE
	AOS C			;INCREMENT PTR TO SUPERIOR'S SUPERIOR
	AOJA B,GSLEV2		;COUNT AND TRY AGAIN
GSLEV3:	POP P,C			;RESTORE AC'S
	POP P,A
	RET

>;IFN STANSW

END