;-*- Mode: Midas; Fonts: MEDFNT -*-
SUBTTL Basic symbol defs and insrts
.SYMTAB 5001.,7000.

;; WARNING:	This is the experimental version of COMSAT using the DQ:
;;		resolver device.  Among other things, this code assumes
;;		that RESOLV"HSTADR will -always- return the Chaosnet
;;		address of a machine over the Internet address if there
;;		is a choice (the alternative is to do twice as many resolves
;;		and do string comparisons).  Yukko scuz.  Should be fixed
;;		as soon as somebody has a better method.

TITLE NEW COMSAT
	; System Communications Satellite
	;(analogy pat. pend.-- running job has various actual sat. names)

	F=0	; Flags
	A=1	; A-E consecutive utility regs
	B=2	;	( routines save all not used for value returning,
	C=3	;	  so as to minimize clobberage)
	D=4
	E=5
	;=6	; Someday...
	MF=7	; Message flags (perhaps flush this)
	N=10	; Index to current net host
	L=11	; Base register into index table for LSE addressing

	OC=12	; Output Channel - used by OUT package.
	U1=13	; UU   UU   UU   UU    OOOOO
	U2=14	; UU   UU   UU   UU   OO   OO    HANDLER
	U3=15	; UU   UU   UU   UU   OO   OO	    ACCS
	U4=16	;  UUUUU     UUUUU     OOOOO

	P=17	; PDL ptr

; "Hard" channel assignments
	LOCKCH==0	; LOCK device channel for inbox locking
	NETD==1		; Net data channel for ICP and MLFL
	NETI==2		; Net input (telnet) channel
	NETO==3		; Net output(telnet) channel
	DKIC==4		; Disk input
	DKOC==5		; Disk output
	SC==6		; Stats disk output
	DMPCH==7	; Disk output channel for pdump'ing self.
	CLIC==10	; CORE link channel (output only).
	ERRCHN==11	; ERR device channel.
	USRI==12	; Inferior input.
	USRO==13	; Inferior output.
	DBC==14		; Debugging output channel.
	LSR1C==15	; Channel open to LSR1 file.
	DQCH==16	; Channel to DQ: resolver device

;; UUO "channels"
	 TMPC==17	; Temporary UUO chan for short jobs.
			; Is theoreticly a UUO channel only, but in fact
			; is used as a real channel in a few places, sigh.

	 SAOCH==20	; Another UUO channel for output into String LN's.
			; (That's right, channel 20, so don't use elsewhere!)
			; Perhaps merge the two, or better yet introduce
			; DEFCHN, DEFCHX macros?? (Latter for #'s > 17)
	
	;LH flag vars
;==1
;==2
%QULOS==200	; Set when flushing messages for bad host from queue
%PGMRN==400	; Set while running inferior job.
%INCLI==1000	; Set when inside CLISND (realt flag)
%MSTMD==2000	; Set when MASTER modified.
%LSRIN==4000	; Set when LSR full-name data mapped into core.
%SCOPN==10000	; Set when SC channel open
%MSGMD==20000	; Set when current MSG-LSE modified
%QMLMD==40000	; Set when QML modified.
%SCHED==100000	; Set when scheduler is sleeping; flag for REALT interrupt.
;==200000	;
%RMLMD==400000	; Set when RML modified.

	; RH flag vars
%RBFH==1
%RNOQC==2	; in RSND50, indicates sender doesn't want queue-confirm.
%NETDV==4	; Set by DEVCHK if device name is net-type
%RBHD==10
%NOTEL==20	; Used by NOTEW/NOTEL
;==40
;==100
%NDATO==200	; Used by ntout to tell whether outputting on neto or netd
%DSKDV==400	; Set by DEVCHK if device name is dsk-type
%NOCOM==1000	; RCPPUT statistics output uses to help avoid extra commas
%TMP==2000	; Temp flag for various stuffs.
;==4000
%LMAPN==10000	; Used by WRTMSG for 'append-msg' flag.
%MAPC==20000	; To distinguish MAPCA/MAPCAR.
%BRKT==40000	; LREADR when reading bracketed atom
%LRLIT==100000	;   "    when reading quoted string or bracketed atom.
%IOCER==200000	; Used by XCTIOC uuo
%ILOPR==400000	; Used by XCTILO uuo

	; .OPTION user variable bits that COMSAT needs.
%OPALL==%OPINT+%OPOPC+%OPLOK+%OPLKF
		; %OPINT gets new interrupt scheme, and
		; %OPOPC says set interrupted PC properly.
		; %OPLOK gets switch and lock hacking so that only one COMSAT
		;	is ever active, and
		; %OPLKF says unlock locks if top-level fatal int. happens,
		;	so a new COMSAT can be started to replace previous.

	; First thing is purification macros...
	PURPGB==3	; Start pure on page 3, have lots of impure.
.INSRT KSC;IVORY >

	; Define our own error handling macros for PAGSER library.

DEFINE	PAGSER"PSRERR ERRCOD
	CALL [	PUSH P,U4
		MOVEI U4,ERRCOD
		JSR PAGLUZ ]
TERMIN

DEFINE	PAGSER"CORLUZ
	JSR CORLOS
TERMIN

	; Time manipulating routines
DATIME"$$DSTB==1	; DST bit in time words
DATIME"$$ABS==1		; Absolute days/seconds conversions
DATIME"$$OUTT==1	; Tables for pretty output
DATIME"$$UPTM==1	; Rtns for system time-in-30'ths conversions
;DATIME"$$OUT==0		; Don't need output rtns since OUT pkg has em
.INSRT DSK:SYSENG;DATIME >

	; Routines for hacking hostnames table (formerly NETWRK stuff)
T==:U1	; Alternate names for smashable ACs.
TT==:U2 ; This is mostly for NETWRK/RESOLV.
IFE U2-OC,.ERR RESOLV temp ACs lose!!

$$DQ==1		; Domain interface code in use (mostly for NETRTS)
$$DQRN==1	; Use RENMWO hack to cut down on resolver overhead
;; These are IFNDEFs for now so that I can play with them without
;; editing the sources every time.
IFNDEF $$DQCH,$$DQCH==1	; RESOLV is allowed to find Chaosnet addresses
IFNDEF $$DQIN,$$DQIN==1	; RESOLV is allowed to find Internet addresses
;; $$DQIN should be turned off as soon as the NAMES > files etc can be
;; fixed to use "foo@bar" syntax for everything.
.INSRT SYSNET;RESOLV >

	; UUO Handler and routines

ULISTS==1	; Assemble list hackery UUOS
USCALL==1	; and special .CALL hackery (ugh)
UAREAS==1	; Area-hacking UUOS too.
$$OUT==1	; Ask for winning new OUT package!!
$$OUUO==0	; Turn off old output UUOs!!!
$$OBUF==1	; Ask OUT package for buffered-output option.
$$OERR==1	; and for ERR output type.
$$OHST==1	; and for host-name output frobs.
$$OTIM==1	; and for time output items.
$$PDBG==1	; Include debugging stuff for PAGSER.
$$CHMX==21	; Need at least this many "channels" for OUT, sigh**2.
.INSRT DSK:KSC;NUUOS >

	; LSR1 (INQUIR) database package
$$HSNM==1	; Do assemble HSNAME cruft.
.INSRT DSK:SYSENG;LSRTNS >

IFNDEF $.ARPA,$.ARPA==0 ; No longer use .ARPA kludge by default

CONSTANTS	; Dump out any accumulated literals.

	; Patch area and PDL hackery.
BVAR
PATLEN==100
PAT:
PATCH:	BLOCK PATLEN
PDLLEN==500.
PDL:	BLOCK PDLLEN+1

JUNK:	0	;for infinite-sink random writes, as in POP P,JUNK
EVAR

POPBA1:	POP P,B
POPAJ1:	POP P,A
POPJ1:	AOS (P)
APOPJ:	RET

PPCBAJ:	POP P,C
POPBAJ:	POP P,B
POPAJ:	POP P,A
CPOPJ:	RET

POPDC1:	AOSA -2(P)
POPCJ1:	 AOSA -1(P)
POPDCJ:	POP P,D
POPCJ:	POP P,C
	RET

PPDCBJ:	POP P,D
POPCBJ:	POP P,C
POPBJ:	POP P,B
	RET

POPBJ1:	POP P,B
	AOS (P)
	RET

SUBTTL Main Calling Paths

IFN 0,[

MAIN			;top level loop
  IRQGET		;get and process an input request (e.g. from QMAIL)
    SPCFND		;get all the specifications
      IPATTR		;input one attribute (name plus argument as raw text)
      PARRCP		;hairiest attribute parsing routine - for recipients
	LREADR		;Lispish reader
	APRCPT		;Process list structure after it has been read in
	  EQRCPL	;Recipient parsing routine (used also by NAMES file readin)
      RCPEQV		;look up recipient in EQV list (NAMES file)
			;called here only to hack sender's NOQC option (weird)
      HPARSE		;parse header if mail from foreign host
    MAIL		;takes a message expressed as an LSE and mails it off
      RCPEXP		;Expand recipient list (doing eqvs and so forth)
	RCPPUT		;Process one rcpt and his attribute list
	  RCPE		;See if rcpt with same name already on list
	  RCPOPT	;Get rcpt's options from NAMES file
	    RCPEQV	;look up rcpt in EQV list (NAMES file)
	  RXPNAM	;Expand local name not on EQV list (look in INQUIR and so forth)
	  RXPBUG	;Expand BUG-type rcpt not on EQV list
	  RXPAFL	;Expand @FILE-type rcpt
	  RCPEXT	;Shove expansions into the rcpt-list of the message
	    RCPPUT	;Recursively called here
	RCPSRT		;Once all rcpts have been found, sort and remove duplicates
      HEADER		;Format the necessary headers
      RCPSND		;Send message to all recipients
	SNDMSG		;Send message to one recipient
	  SNDNET	;send over the net
	  SNDFIL	;simply send to a file
	    WRTMSG	;actually writes into mail files
	  SNDBUL	;send to a .MSGS. file
	    WRTMSG	;write it
	  SNDNAM	;send to local user
	    WRTMSG	;actually writes into mail files
	  SNDPGM	;send to a program (run in inferior)
	    MAIL	;calls MAIL recursively to report program lossage
	MAIL		;calls MAIL recursively if permanent error
	QUEUE		;if temporary error, queue the message
  REMSND		;send a reminder
    MAIL		;calls MAIL to actually send the stuff
  QUESND		;try again to send queued messages to a particular host
    QSTSND		;subroutine to send one queued message
      SNDMSG		;as above
      NOTEW		;send positive acknowledge
	MAIL
      NOTEL		;send negative acknowledge
	MAIL
];IFN 0
SUBTTL Attribute Definitions

; Macro to define attributes:
;	ATTRIB <internal #>,<assembly sym>:,<P-name>,<input routine if external>

DEFINE ATTRIB COD,SYMC,*NAME*,IRTN
IF1 [IRPS SYM,,[SYMC]
	SYM==COD
	TERMIN
IFGE COD-ATRLIM,.ERR Attribute code too large!
IRP N,,[102,103,104]	; List of unused codes.
IFE N-COD,.ERR Using "unused" attribute?!
TERMIN
IFE N,.ERR Using attribute 0?!
]
%%S==.
LOC ATTRTB+COD ? ASCNT [NAME]
LOC ATTRIR+COD ? IRTN
LOC %%S
TERMIN


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;			ATTRIBUTE DEFINITIONS
;;;	
;;;	Attributes declared are all "internal" unless an input routine
;;;	exists for them.  Flags can be stored in the LH of ATTRIR if this
;;;	later proves desirable.  See doc file for more info.  To add an
;;;	attribute, first check the list of Unused Codes in the ATTRIB
;;;	macro definition to see if there's one to assign.  If none,
;;;	increment the ATRLIM definition and use its old value.  0 should
;;;	never be used as a code!!
;;;
;;; Some of these attributes have read-in dispatch entries for the NAMES file,
;;;  and others for "ATTRIBUTE:" in IRQ files.

ATRLIM==111	; Current limit for attrib codes. All must be less than this!!

A$==,,-1		; For bit-typeout mode
ATTRTB:	BLOCK ATRLIM	; Table indexed by <code>, holds ASCNT ptr to name.
ATTRIR:	BLOCK ATRLIM	; Table to hold routine addr for xct'ing on input.

	; General Purpose Attributes
ATTRIB 1,A$ATTR:,|ATTRIBUTE|		; S Name of attribute for succeeding A$AVAL (if any)
ATTRIB 2,A$AVAL:,|ATTRIBVAL|		; * Holds value for preceding A$ATTR
ATTRIB 3,A$XATR:,|X-ATTRIBUTE|		; S Like A$ATTR but used for Net-header attribs.
ATTRIB 4,A$XVAL:,|X-ATTRIBVAL|		; * Like A$AVAL.
ATTRIB 5,A$PREQ:,|SPECIAL-REQ|,	APQTL	; L Indicates special (non-mail) processing.
;ATTRIB 6,A$PARG:,|SPECIAL-ARG|,	APLST	; L Holds list of args for A$PREQ.

	; Message Attributes
ATTRIB 10,A$ID:,  |MESSAGE-ID|		; S Message ID for message.
ATTRIB 11,A$SNM:, |SENDER|,	APSTR	; S sender's name
ATTRIB 12,A$CSN:, |SENT-BY|,	APSTR	; S sender's claimed-to-be name.
ATTRIB 107,A$FFM:, |FAKE-FROM|,	APSTR	; S sender's name for "From"
ATTRIB 100,A$SNH:,|SENDER-HOST|		; V sender's host (for net mail)
ATTRIB 105,A$SRTP:,|RETURN-PATH|,APSTR	; S SMTP return path spec
	;; this used to be called MAINT-PATH, hence the odd name
ATTRIB 106,A$SMRP:,|ERRORS-TO|,APSTR	; S sender's error return path
ATTRIB 13,A$MTXT:,|TEXT|,	APSTR	; S input message-text
ATTRIB 7, A$MTXF:,|TEXT-FLAG|		; V flag saying if ^_ or crlf.crlf in message.
ATTRIB 14,A$MHDR:,|HEADER|		; S Header for message.
ATTRIB 15,A$KHDR:,|KLUDGE-HEADER|	; S Kludge to prevent ITS headers from going out
ATTRIB 16,A$NMH:, |NET-MAIL-HOST|	; V Host # origin of network-input.
ATTRIB 17,A$SBJ:, |SUBJECT|,	APSTR	; S Subject if any
ATTRIB 20,A$TIM:, |DATE|		; V Time msg created on dsk
ATTRIB 101,A$UHDR:,|USER-HEADER|,APSTR  ; S User-specified header line.
ATTRIB 21,A$HFRC:,|HEADER-FORCE|,APSTR	; S Type of header force if any
ATTRIB 22,A$RLN:, |RCPT-LIST-NAME|,APSTR; S Rcpt list name for "To":
ATTRIB 23,A$XPIR:,|EXPIRES|,	APNUM	; V # days until this MSG expires
ATTRIB 24,A$MFN1:,|MSG-FN1|,	AP6W	; V Sixbit FN1 for type *MSG.
ATTRIB 25,A$MFN2:,|MSG-FN2|,	AP6W	; V Sixbit FN2 for *MSG.
ATTRIB 26,A$CNF:, |CONFIRMATION|,APSTR	; S Confirmation option (ALL, or FAIL only)
ATTRIB 36,A$IDRM:,|ID-REMINDER|		; S Holds ID of parent, when msg generated from reminder
ATTRIB 30,A$TEXP:,|REM-EXPIRES|,APNUM	; V Time or count for Reminder expiration
ATTRIB 31,A$TNXT:,|REM-NEXT|,	APNUM	; V Abs time for very next sending of this reminder.
ATTRIB 32,A$TLST:,|REM-SPEC-LIST|,APLST ; L Holds list for 1 reminder time specification.

	; Remind-time Attributes, stored under a REM-SPEC-LIST.
ATTRIB 33,A$TBAS:,|REM-TIME-BASE|,APNUM ; V Holds time base to start from (optional)
ATTRIB 34,A$TINC:,|REM-TIME-INC|,APNUM 	; V Holds repeat-increment specifications.
ATTRIB 35,A$TSPC:,|REM-TIME-SPEC|,APNUM ; V Holds date/time repeat specifications.


	; Message Attributes - Recipient nodes
ATTRIB 54,A$RCP:, |RCPT-LIST|		; L Holds active RCPT attribs.
ATTRIB 55,A$RCPF:,|RCPT-LIST-FAIL| 	; L ditto but marks as failed.
ATTRIB 56,A$RSNT:,|RCPT-LIST-SENT| 	; L ditto but marks as sent.
ATTRIB 27,A$RDON:,|RCPT-LIST-DONE|	; L ditto but marks "done", inactive.

	; Recipient Attributes
ATTRIB 40,A$RTYP:,|R-TYPE|,	APSTR	; S Type of recipient (BUG, PGM, etc)
ATTRIB 41,A$RHST:,|R-HOST|,	APHST	; V Destination host # for rcpt
ATTRIB 42,A$RNAM:,|R-NAME|,	APSTR	; S Name of rcpt
ATTRIB 43,A$RPSN:,|R-PSEUDO|		; V Existence indicates rcp name is psuedo.
ATTRIB 37,A$RHDR:,|R-HEADER|		; S Rcpt's very own header.
ATTRIB 57,A$RHFC:,|R-HEADER-FORCE|,APSTR; S Header force, for this rcpt.
ATTRIB 44,A$RRES:,|R-RESULT|		; S Result of SNDMSG (failed, queue, sent)
ATTRIB 45,A$RRMG:,|R-RESULT-MSG| 	; S Err msg if A$RRES==failed.
ATTRIB 74,A$RFCT:,|R-FAILURE-COUNT|	; V Number of times tried to send and lost
ATTRIB 47,A$RMDS:,|R-MODE-SEND|,APNUM	; V Sending mode (see comments for SENDSW, MAILSW)
ATTRIB 50,A$RMDM:,|R-MODE-MAIL|,APNUM	; V Mailing mode
ATTRIB 51,A$RPMR:,|R-PGM-MNTNR|,APRCPT	; L If type = PGM, specifies maintainer to notify.
ATTRIB 67,A$RPGD:,|R-PGM-DISOWN|,APNUM	; V If type = PGM, control bits for job.
ATTRIB 73,A$RPGU:,|R-PGM-USET|,	AP2NUM	; L List holds two values, .USET sym and value.
ATTRIB 52,A$ROPT:,|R-OPTION|,	APSTRS 	; S Recipient Option name
ATTRIB 53,A$RNK:, |R-NOT-KNOWN|		; V Existence means rcpt not known.
ATTRIB 110,A$ROK:,|R-RELAY-OK|		; V Exists when rcpt is ok to relay.
ATTRIB 46,A$RHSN:,|R-HSNAME|		; V Holds 6bit HSNAME of local rcpt without a dir.

 	; Attribs for Scheduler List.
ATTRIB 60,A$S:,   |SCHED-ITEM-LIST|	; L List holding schedule requests
ATTRIB 61,A$STIM:,|SCHED-TIME|		; V System time at which to execute.
ATTRIB 62,A$SRTN:,|SCHED-RTN|		; V Routine to execute.
ATTRIB 63,A$SARG:,|SCHED-ARG|		; V Argument for routine.

 	; Attribs for Master List.
ATTRIB 64,A$I:,   |MASTER-ITEM-LIST|	; L List holding Message-ID/Disk addr correspondence.
ATTRIB 65,A$IDAD:,|DISK-ADDR|		; V Disk addr of LSE for this message.
ATTRIB 66,A$IDBL:,|DISK-LENGTH|		; V Length of its LSE on disk.

 	; Attribs for Queued Message List.
ATTRIB 70,A$Q:,   |QUEUE-SITE-LIST|	; L List holding Site/Message-ID correspondence.
ATTRIB 76,A$QFL:, |QUEUE-FINALIZE-LIST|	; L List holding ID's to finalize.
ATTRIB 71,A$QHST:,|QUEUE-SITE|		; V Site # which following ID's are queued for.
ATTRIB 77,A$QFCT:,|QUEUE-FAILURE-CNT|	; V # times this site failed.

	; Attribs for Reminder Message List.
ATTRIB 75,A$T:,	 |REMINDER-LIST|	; L Entry on the RML.

	; Attribs for EQV list
ATTRIB 72,A$E:,   |EQV-LIST|,	APEQVL	; L Equivalence list for recipient.

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

; IARCOD - Given SLP in A to uppercase string, checks to see if it
;	matches a non-internal attribute name, and if so skips with
;	internal code in RH(B).

IARCOD:	MOVSI B,-ATRLIM
	SKIPE ATTRIR(B)		; Skip if internal name (a no-no)
	 SLNEA A,ATTRTB(B)	; This one is OK, does name match?
	  AOBJN B,.-2
	CAIGE B,0	; Don't skipret if counted out.
	 AOS (P)
	RET

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

	; Table of known recipient types.
RTYPTB:	ASCNT [BUG]
	ASCNT [FILE]
	ASCNT [NAME]
	ASCNT [PGM]
	ASCNT [*MSG]
	ASCNT [@FILE]
NRTYPS==:.-RTYPTB

	; Table of sending routines to dispatch on, corresponding to RTYPTB.
SNDRTB:	SNDBUG
	SNDFIL
	SNDNAM
	SNDPGM
	SNDBUL
	SNDAFL
IFN NRTYPS-<.-SNDRTB>,.ERR SNDRTB loses

	; Message-Result definitions
	; These values are returned by certain routines such as SNDMSG
	; responsible for sending a message.  Note that all temporary
	; errors are even (low bit zero), and permanent errors are odd.
	; When an error message is furnished, it should not begin or
	; end with a CRLF; if a CRLF is embedded, a tab should follow it.
	; This is just for prettiness when string is put into a receipt msg.

MR$WIN==:0 ; Message won, sent to rcpt.  This is the only return
		; which is NOT expected to furnish some sort of err msg.

MR$PER==:1 ; Perm Err for Rcpt.  This rcpt failed forever, but
		; can keep trying site for other rcpts.
		; This is most often the result of a 450 reply from remote
		; host, but might also result from rare local errors.

MR$TER==:2 ; Temp Err for Rcpt, must queue.  Can keep trying site for
		; other rcpts.
		; This return happens for such things as "dir full" (local)
		; or "mailbox busy", "job cap exceeded", etc. (remote)

MR$PEH==:3 ; Perm Err for Host; this host failed forever.
		; Should never happen for local site (!).  Will happen for
		; remote sites which have been getting MR$TEH's for too long.
		; Can also be generated "by hand" to flush a queue.

MR$TEH==:4 ; Temp err for Host; don't bother trying site further at
		; moment.  This return can happen if disk space gronked
		; (local) or remote host dies during sending (IOC error,
		; timeout, failed ICP, etc.)

MR$TEM==:5 ; Temp Err for Msg; implies some temporary error associated with
		; the message itself, rather than with the host or a specific rcpt.
		; This might possibly happen for weirdness in a message such as
		; ^C's or the like, but that is supposed to be circumvented
		; by MLFL or quoting.  May happen for overly long msg text,
		; if a remote site has a very low length tolerance; in this case
		; we won't want to keep re-trying for every rcpt!!
MR$PEM==:6 ; Perm Err for Msg; Ditto, but permanent.
		;Same mumblings as for MR$TEM.

MR$MAX==:6		; Max possible MR$ value
MR$TAB==:MR$MAX+1	; For checking dispatch tables.


SUBTTL Various variables and standard filenames

;; Hostname strings are 63 words (255. bytes) long, per RFC883.

BVAR
DEBUG:	-1	;non-z means (mainly) to stop on errors instantly.
RELAY:	0	;non-z allows relaying of remote mail
XVERS:	-1	; Version type -
		; 0 - Normal operational mailer
		; 1 - "New" mailer, operational but not completely tested.
		;-1 - Experimental mailer, for debugging/development.
OWNHST:	0	;Our own host address on the network we're really connected to.
OWNHS2:	0	;Alternate host address to consider local .SEE TCPGAT
		;With domains, we always need this if we are dual-net.  Foo.
MYUIND:	-1	;COMSAT's user index, used by SUNAME

OWNNAM: BLOCK 63	;holds asciz string which is name of own site
GATNAM: BLOCK 63	;holds asciz string which is name of TCP relay host
TMPNAM:	BLOCK 63	;holds asciz string which is name of random host

PRGNAM:	.FNAM1		; FN1, FN2 of source file assembled from.
VERSHN:	.FNAM2

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

	; Names for mail directory files

; SATF "<norm>",<xper>,<new>	- specifies a SIXBIT filename
;	which varies depending on whether COMSAT is running as
;	the normal, experimental, or new-operational mailer.

NSTFLS==0
DEFINE SATF &NORM&,XPER,NEW
%%SLOC==.
IF1 ?	[SIXBIT |XPER|],,[SIXBIT |NEW|]	; Goddam constants lossage
IF2 [	SIXBIT NORM
	TMPLOC XVARTB+NSTFLS,{%%SLOC,,[SIXBIT |XPER|]}
	TMPLOC NXVRTB+NSTFLS,{%%SLOC,,[SIXBIT |NEW|]}
]
NSTFLS==NSTFLS+1
TERMIN

SATDEV:	SIXBIT /DSK/	; Satellite Device
SATDIR:	SIXBIT /.MAIL./	; Satellite Directory
			; Directory is .BULK. for bulk mailer

MSTFN1:	SATF "  LIST",XLIST,NLIST	; MASTER LSE file
MSTFN2:	SIXBIT /MASTER/
NMSFN1:	SATF "  LIST",XLIST,NLIST	; FNM to use when GC'ing MSGS.
	SIXBIT /NMASTR/

QMLFN1:	SATF "  LIST",XLIST,NLIST	; QML LSE file.
QMLFN2:	SIXBIT / QUEUE/

RMLFN1:	SATF "  LIST",XLIST,NLIST	; RML LSE file.
RMLFN2:	SIXBIT /REMIND/

MSGFN1:	SATF " LISTS",XLIST,NLIST	; File of MSG LSEs.
MSGFN2:	SIXBIT /  MSGS/
NMGFN1:	SATF " LISTS",XLIST,NLIST	; FNM to use when GC'ing MSGS.
	SIXBIT / NMSGS/

EQAFN1:	SATF "NAMES",XNAMES,NNAMES	; ASCII name equivalence/options file
EQAFN2:	SIXBIT />/
EQAFR1:	0		; Used to hold real translated filenames.
EQAFR2:	0

EQRFIL::			; Holds file blk for compilation-report file.
EQRDEV:	0
EQRDIR:	0
EQRFN1:	SATF "NAMED",XNAMED,NNAMED
EQRFN2:	0

EQVFN1:	SATF "  LIST",XLIST,NLIST	; Binary name equivalence/options file.
EQVFN2:	SIXBIT /   EQV/

LSRFN1:	SIXBIT / FROM/	; Indicator file left by INQUIR, fresh
LSRFN2:	SIXBIT /INQUIR/	; file means fresh LSR waiting to be gobbled.

HSTDEV:	SIXBIT /DSK/	; File name of the host tables.
	SIXBIT /SYSBIN/
	SIXBIT /HOSTS3/
	SIXBIT />/

IRQFN1:	SATF "MAIL",XMAIL,NMAIL	; Filename of mail requests.
IRQFN2:	SIXBIT /</		;  note FIFO sequence!
IRIFN1:	SATF "MAILIN",XMAILI,NMAILI	; Filename of recognized mail requests.
IRIFN2:	SIXBIT />/		;  note FILO sequence!
IREFN1:	SATF "BADREQ",XBADRQ,NBADRQ	; Erroneous input reqs renamed to this.
IREFN2:	SIXBIT />/

IRRFIL:	0 ? 0		; Used by RFNAME call to find true input-req FN.
IRRFN1:	0
IRRFN2:	0

IDFN1:	SATF "    ID",XID,NID	; Name used to obtain unique Message-ID number.
IDFN2:	SIXBIT />/

	; Names for statistics files
STFN1:	SATF "STATS",XSTATS,NSTATS	; Name of actual stats file
STFN2:	SIXBIT />/
STOFN1:	SATF "OSTATS",XOSTAT,NOSTAT	; Name for old stats files
STOFN2:	SIXBIT />/

	; Names for locked switch file (to ensure uniqueness)
LCKFN1:	SATF " LOCK",XLOCK,NLOCK
LCKFN2:	SIXBIT /UNIQUE/

UNMPRF:	SIXBIT /COMSAT/		; Preferred UNAME
JNMPRF:	SATF "IV",XPER,NEW	;    "      JNAME (major version #, sort of)
				; JNAME is BULK for bulk mailer
EVAR

	; Table of vars to change when running in experimental mode!
XVARTB:	BLOCK NSTFLS		; To hold sat filenames which change.
	; Can have other vars here in form
	; <addr>,,[<new value>]
NXVARS==:.-XVARTB

	; Vars to change when running in "New operational" mode!
NXVRTB:	BLOCK NSTFLS		; To hold sat filenames which change.
	; Can have other vars here in form
	; <addr>,,[<new value>]
NNXVRS==:.-NXVRTB


XVRSRT:	SKIPN XVERS		; If normal,
	 RET			; don't change anything.
	PUSHAE P,[A,B,C]
	MOVE C,[-NXVARS,,XVARTB]
	SKIPL XVERS		; Use XVARTB if experimental
	 MOVE C,[-NNXVRS,,NXVRTB] ; Else use "new operational" vars.
XVRSR1:	MOVE A,(C)
	HLRZ B,A
	MOVE A,(A)	; Get xper. value to use
	MOVEM A,(B)	; Store in indicated loc
	AOBJN C,XVRSR1
	POPAE P,[C,B,A]
	RET

SUBTTL Initializations for bulk mailer kludge

.scalar	bootxj			; Original XJNAME (for RESET, ugh)

bulkck:	push p,a
	.suset [.rxjname,,bootxj]
	move a,bootxj
	came a,[sixbit /VDNBRG/]
	 jrst popaj
	move a,[sixbit /.BULK./]
	movem a,satdir
	move a,[sixbit /BULK/]
	movem a,jnmprf
	;; need to break local delivery
	jrst popaj

SUBTTL Statistics file routines

	; Macro to write stats with.  (see SCOPN)
	; Generates a <CRLF><time><TAB> before writing given OUT-style list.
	; Saves and restores OC output channel so it can appear anywhere;
	; this isn't usually necessary, but better safe than sorry.
DEFINE STAT (LIST)
	PUSH P,OC
	CALL STTLIN
	OUT!LIST
	CALL STTFIN
TERMIN

	; ditto, but no <CRLF><time><TAB> insertion.
DEFINE CSTAT (LIST)
	PUSH P,OC
	MOVEI OC,SC
	OUT!LIST
	CALL STTFIN
TERMIN

	; Like STAT, but can be skipped over.
DEFINE PSTAT (LIST)
	CALL [	PUSH P,OC
		CALL STTLIN
		OUT!LIST
		CALL STTFIN
		RET ]
TERMIN

; STTLIN - Start stat report with time line
;	Assumes that C/STAT macros are saving/restoring OC.

STTLIN:	OUT(,CH(SC),EOL)	; Set std output chan, and do a CRLF.
	SOS SCLCNT	; Decrement line cnt, but don't put date cruft in yet.
	.RTIME U4,		; Get hhmmss in U4
	OUT(,6F(U4),TAB)	; Output time plus indentation.
	RET

; STTFIN - force stats channel and also restore saved OC
STTFIN:	OUT(,FRC)
	POP P,OC
	EXCH OC,(P)
	RET

SCMAXL:	5*50.*2000	; Max length of stats file before renaming, in chars.
LVAR SCLCNT:	0	; Cntdn of lines - when < 0, put full date in stats.
STTLIM==40.		; # of lines to count down.
STBFLN==50.		; Use 50 wds for SC output buffer.
LVAR STBUF: BLOCK STBFLN	; Need fixed buffer because a dynamically
			; allocated one could be screwed by various lossages.

; SCOPN -  Open SC channel to STATS file

SCOPN:	PUSHAE P,[A,B]
	TLZ F,%SCOPN		; Clear flag

	; Try to open stats file in write-over mode.
	MOVE B,[%DOWOV+.UAO,,SC]
	ECALL SCOBLK,[[4,SCOPN4],[*,23,SCOPN1]]
	 JSR SYSLOS		; If 4 = File not found, create it at SCOPN4
				; If 23= File locked, hack it at SCOPN1
				; Else horrible error!
	SYSCAL FILLEN,[CIMM SC ? CRET A]	; Got it, find current length.
	 JSR SYSLOS		; gasp choke?
	.ACCESS SC,A		; Point to end of file.
	OUT(SC,OPEN(UC$BUF,,[-STBFLN,,STBUF]))	; Open buffered UUO chan.
	TLO F,%SCOPN		; Indicate SC channel now open!
	CAMG A,SCMAXL		; Have length.  Is current file too long?
	 JRST SCOPN5		; It's OK, continue blissfully.
	JRST SCOPN0		; Too long, have to close and rename.

	; Entry point from MAIN loop when file is too long.
SCROPN:	PUSHAE P,[A,B]		; Real programmers don't use co-routines....

	; STATS file too long, time to rename it and start another.
SCOPN0:	STAT (,("Renaming stats file..."),TIM(MDYT))
	OUT(SC,CLS)		; Close channel, making sure all's output.
	TLZ F,%SCOPN		; (must close to let RENAME below win.)

	; Some cretin has the STATS file locked, but let's outsmart the loser.
	; This stuff also done when STATS file too long.
SCOPN1:	SYSCAL RENAME,[['DSK,,] ? STFN1 ? [SIXBIT /</]	; Rename oldest STATS
			SATDIR ? STOFN1 ? STOFN2	; to newest OSTATS
	 		CERR A]
	 JRST [	CAIE A,4	; Didn't rename?  File still there?
		 CAIN A,23	; or file locked (must be for writing)?
		  JRST SCOPN4	; One of these, renaming done.
		JSR SYSLOS]	; Neither 4 nor 23? Argh, horrible error?!
	JRST SCOPN1		; If rename successful, continue til all gone.

	; Here to create new STATS file.  Comes here if none exists, or after
	; all STATS files have been renamed to OSTATS (same thing).
SCOPN4:	MOVE B,[.UAO,,SC]
	ECALL SCOBLK,[[5,SCOPNX]]	; watch out for dir full.
	 JSR SYSLOS		; Foo?
	OUT(SC,OPEN(UC$BUF,,[-STBFLN,,STBUF]))	; Open buffered UUO chan.
	TLO F,%SCOPN		; Say stats file open!
	STAT (,("TELEMETRY FILE CREATED, DATE "),TIM(F1))
	STAT (,("This is version "),6F(PRGNAM),(" "),6F(VERSHN))
	STAT (,(";;; NOTE!!! If you are reading this file with ^R or :PRINT,
please type ^S or ^G to stop at once!
	You are damaging mailer response!"))
	JRST SCOPN8		; Skip writing full date again

SCOPN5:	SKIPLE SCLCNT		; Now have SC open, must we insert full date?
	 JRST SCOPN9		; Nope, that's all.
	OUT(SC,CRLF,EOL)
	STAT (,("Date is now: "),TIM(MDYT))
SCOPN8:	MOVEI A,STTLIM		; This many lines per full-date insertion
	MOVEM A,SCLCNT
SCOPN9:	POPAE P,[B,A]
	RET

	; Come here if get DIR FULL error trying to open stats file.
SCOPNX:	CALL SDFULL	; Attempt to fix, die if can't.
	TLNE F,%SCOPN
	 JRST SCOPN5	; recovered! continue depending on %SCOPN state.
	JRST SCOPN4

SCOBLK:	SETZ ? SIXBIT /OPEN/ ? B ? SATDEV ? STFN1 ? STFN2 ? SETZ SATDIR

CONSTANTS

SUBTTL ERROR system call analyzer macro

; Example:
;	SYSCAL OPEN,[[.UAI,,DKIC] ? [SIXBIT /DSK/] ? [SIXBIT /MICKEY/]
;			[SIXBIT /MOUSE/] ? [SIXBIT /USERS/] ? CERR MMERR]
;	 ERROR [[%ENSFL,FOO20],[ERR,MMERR],[CALL,%ENADV,FOO40]]

; ERROR - Macro to put in non-skip error returns from system calls.
;	The easiest way to explain this is to explain the above
;	example, which is trying to open DSK:USERS;MICKEY MOUSE is
;	unit ascii input mode, and asking for an explicit error
;	code returned in MMERR.   Here is what the ERROR macro following
;	it will do:  first, it will find the error code in MMERR
;	because of the [ERR,MMERR] clause. (Had there been no ERR
;	clause it would have used the STATUS of the .BCHN channel).
;	Then if there were a "File not found" (%ENSFL) it would
;	JRST to FOO20.  If there were a "Device not availible", it
;	would have gone to FOO40 leaving the stack set up to
;	point at the saved ACs D, C, B, and A in that order, and
;	below that the address of the SYSCAL.  In other words,
;	the routine at FOO40 would retry the SYSCAL by doing
;	a "POPAE P,[D,C,B,A] ? RET" .  The routine is passed
;	one argument (in A) which is the error code.

;		The ERR is optional, and there may be an arbitrary
;	number of handlers for error codes, each of which may be
;	a plain JRST (i. e. [%ENSFL,FOO20]) or a CALL (i. e. 
;	[CALL,%ENADV,FOO40]) depending on which the programmer
;	thinks is cleaner for the occasion.
;		The ERROR macro expands into a call to CALERR.

DEFINE ERROR LIST
	%%ERCT==0
	CALL [PUSH P,[[
	IRP ITEM,,[LIST]
	  %%ERCT==%%ERCT+1
	  IRP ERRCOD,VECTOR,[ITEM]
	    IFSE ERRCOD,ERR,{	C$ECL_C%OPSH,,VECTOR
				.ISTOP}
	    IFSE ERRCOD,CALL,{	IRP ERCD,VECT,[VECTOR]
				  C$CAL_C%OPSH+ERCD,,VECT
				  .ISTOP
				  TERMIN
				.ISTOP}
	    ERRCOD,,VECTOR
	    .ISTOP
	    TERMIN
	  TERMIN
	](-%%ERCT)]
	PJRST CALERR]
	TERMIN

; CALERR - Routine called by ERROR (see above).  Figure out how to use
;	ERROR before you read this...
;	ERROR will generate a calling sequence of the form
;	.CALL FOO
;	 CALL [PUSH P,[-n,,[param1 ? param2 ? ... ]]
;		PJRST CALERR]

;	There is one parameter for each clause in the ERROR call.
;	n is the number of parameters.  A parameter is decoded by opcode:
C%OPCD==410300			; Byte spec for the opcode field
C%OPSH==17			; (LH shift amount)

;	Here are the currently defined opcodes:
;OPCODE:			WHAT THE PARAMETER WORD MEANS
;==0				; Bits 3.6-3.1 are an error code, and the
				;   RH is an address to jump to if that
				;   error occurs (the simple ERROR clause).
C$ECL==1			; RH is loc of word containing error code (for ERR)
C$CAL==2			; Like 0, except generates the hairier
				;    calling sequence (CALL)

CALERR:	PUSHAE P,[A,B,C,D]
	SKIPGE C,-4(P)		; Get argument off stack.
	 JSR AUTPSY		; If nothing, die.
	HRLI A,-3(P)		; Now move the three saved ACs up one slot
	HRRI A,-4(P)		;   on the stack.  (if you think THIS is bad,
	BLT A,-1(P)		;   take a look at TRANTR sometime.)
	SUBI P,1		; And adjust the stack pointer.
	MOVE A,C		; Get a copy of the AOBJN pointer.
CALR10:	LDB B,[C%OPCD,,(A)]	; Now search for a parameter with opcode
	CAIE B,C$ECL		;   C$ECL, loc of err code.
	 AOBJN A,CALR10
	JUMPL A,CALR20		; Found it.
	.SUSET [.RBCHN,,A]	; Not found, figure it out.
	SYSCAL STATUS,[MOVEI A ? MOVEM A]
	 JSR AUTPSY
	LDB A,[220600,,A]	; Magic field which holds the error code is 3.6-3.1)
	CAIA
CALR20:	 HRRZ A,@(A)		; Now have err code in A.
CALR30:	LDB B,[220600,,(C)]	; Check each param. for this code.
	CAIE B,(A)
	 AOBJN C,CALR30
	JUMPL C,CALR40		; Found!
	JSR AUTPSY		; Not there, die horribly.
CALR40:	HRRZ B,(C)		; Get the address in B.
	LDB D,[C%OPCD,,(C)]	; Get opcode.
	CAIE D,C$CAL		; Is it a CALL clause?
	 JRST CALR50
	SOS -4(P)		; Fix the saved return address to point
	SOS -4(P)		;    at the .CALL instruction itself.
	JRST (B)		; Dispatch to handler.

CALR50:	MOVEM B,-4(P)		; Slight kludge to restore ACs and
	POPAE P,[D,C,B,A]	;   jump to given location.
	RET

SUBTTL Interrupt handlers - IOC, MPV, PDLOV, ILOPR

%BADPI==%PIIOC+%PIMPV+%PIPDL+%PIILO+%PIWRO	; Bad conditions

;;; Interrupt vector table for new style ITS interrupts.

TMPLOC 42,{-LINTBLK,,INTBLK}	; New mode interrupt vector

%NINTS==400000			; 4.9 bit means push .JPC, .SUUOH, LSPCL also
INTBLK:	%NINTS,,INTPDP		; PDL ptr addr

	; .REALT interrupt vector, defer more RLT's
	%PIRLT ? 0
	%PIRLT ? 0
	INTRLT

	; IOC error interrupt vector. defer all but MPV and PDL OV.
	%PIIOC ? 0
	-1#<%PIMPV\%PIPDL> ? -1
	INTIOC

	; PDL overflow int vec.  Defer all but MPV.
	%PIPDL ? 0
	-1#<%PIMPV> ?	-1
	INTPDL

	; MPV int vec.  defer everything.
	%PIMPV ? 0
	-1 ? -1
	INTMPV

	; WRO int vec.  defer everything.
	%PIWRO ? 0
	-1 ? -1
	INTWRO

	; Illegal Operation int vec, defer more ILOPR's
	%PIILO ? 0
	%PIILO ? 0
	INTILO

	; Inferior Interrupt int vec.  defer more of same.
	0 ? 377,,0
	0 ? 377,,0
	INTUSR

;	; Sys going down int vec.  defer more of same.
;	%PIDWN ? 0 ?	%PIDWN ?	0 ?	INTDWN

LINTBLK==.-INTBLK

BVAR
	LIPDL==50.	; Enough for 6 or so nestings of ints.
INTPDP:	-LIPDL,,IPDL-1	; Interrupt PDL pointer.
IPDL:	BLOCK LIPDL	;     "      "  stack.
EVAR

	; Macro to ease dismissing interrupts.  DISMIS restores with old PC,
	; DISMIS [addr] restores with given new PC.
DEFINE DISMISS (ADDR)
.CALL [SETZ ? 'DISMIS ? CTLI %NINTS
IFB [ADDR] SETZ INTPDP
.ELSE INTPDP ? SETZ ADDR
]
TERMIN

	; Macros to ease saving/restoring stuff for stats output.
	; Basically saves/restores UUO vars.
DEFINE IUSAVE
PUSHAE P,[U40,U1,U2,U3,U4]
IFN OC-U2, PUSH P,OC
IFE $$UCAL,PUSH P,UUORPC
TERMIN

DEFINE IUREST
IFE $$UCAL,POP P,UUORPC
IFN OC-U2, POP P,OC
POPAE P,[U4,U3,U2,U1,U40]
TERMIN

;***********************  IOC INTERRUPT  *********************************
;			I/O Channel Error
BVAR
IOCBCH:	0	; BCHN, # of channel IOC happened on.
IOCIOS:	0	; IOS word for channel, holds error code.
IOCDEV:	0	; Word 1 returned by RFNAME, usually device name.
IOCFN1:	0	; Word 2  "
IOCFN2:	0	; Word 3  "
IOCDIR:	0	; Word 4  " , usually directory name
IOCMOD:	0	; Word 5  " , mode channel open in.
EVAR

INTIOC:	TRNE F,%IOCER		; "Expected" IOC? (i.e. XCTIOC)
	 JRST IOCLUZ		; Yep, whew... let XCTIOC code handle safely.
	PUSHAE P,[A,B,C]
	.SUSET [.RBCHN,,IOCBCH]	; Get # of bad channel
	SYSCAL STATUS,[IOCBCH ? CRET IOCIOS] ; and IOS word for it.
	 JSR SYSLOS
	SYSCAL RFNAME,[IOCBCH ? CRET IOCDEV
		CRET IOCFN1 ? CRET IOCFN2 ? CRET IOCDIR]
	 JSR SYSLOS		; shouldn't happen.
	MOVE A,IOCBCH		; Now getum channel into AC.
	CAIN A,SC		; Before we try any reporting, see if 'twas
	 TLZ F,%SCOPN		; the stats channel itself that's zapped!!!
	LDB B,[330500,,IOCIOS]	; Isolate IOC error #.

	; Check for outright and obvious bugs
	CAIE B,5		; Over-IOPOP,
	 CAIN B,6		; or IOPUSH?
	  JRST IIOC90

	; Passed initial checking, now see if it happened while hacking net;
	; Network IOC errors are facts of life and ok...
	CAIN A,NETD		; Net data channel?
	 JRST IIOC10
	CAIE A,NETO		; Net output channel?
	 CAIN A,NETI		; Net input channel?
	  JRST IIOC10		; Dispatch if hacking net.

	; Ugh, error is very likely fatal... see if it's anything that is
	; a recognized problem.
	CAIE B,11		; Device full?
	 CAIN B,14		; or directory full?
	  JRST IIOC20		; Yep, storage problems.
	CAIN B,15		; (DM only??) Dir alloc exhausted?
	 JRST IIOC20

	; Error is completely unrecognized, scream loudly.
	; Also come here if no way to resolve some known problem.
IIOC90:	JSR PRESRV		; Save stuff, swap PDL, etc.
	CAIN A,SC		; Of course, if SC was at fault,
	 JRST [	JSR BURY	; screaming is unlikely to win.
		JSR UDEATH]
	TLNN F,%SCOPN		; If SC simply not open,
	 JRST AUTPY1		; let AUTPSY do the re-open attempt & reporting
	STAT (,(" ==="),RABR,(" IOC ERR, BCHN="),OCT(A),(", IOS="),H(IOCIOS),("
DEV=|"),6F(IOCDEV),("|
FN1=|"),6F(IOCFN1),("|
FN2=|"),6F(IOCFN2),("|
DIR=|"),6F(IOCDIR),("|
MOD="),H(IOCMOD))
	DISMISS [AUTPY1]	; Get out of int. level.

	; Network IOC.  Dismiss to net ioc handler, if one exists.
IIOC10:	SKIPN NTIOCV	; So does a handler exist?
	 JRST IIOC90	; Foo, a wild IOC has burst loose!  Go faint...
	POPAE P,[C,B,A]
	DISMISS NTIOCV	; Win, leave int level & punt to handler.

	; Storage-exhaustion IOC.  See if it's for COMSAT's own dir.
IIOC20:	MOVE B,IOCDIR
	CAMN B,SATDIR	; Same dir as Comsat?
	 JRST IIOC30	; Yes, there's still a slim hope...

	; Here, problem is essentially an unguarded IOT to some
	; loser's directory.  There is basically nothing to do besides
	; ensuring that the cruft we're writing doesn't contribute
	; to the lossage, and making sure that an XCTIOT is slapped
	; around the guilty instruction in the source.
	MOVE B,IOCFN1
	CAME B,[SIXBIT /_MAIL_/]
	 JRST IIOC90	; Sigh
	MOVE B,IOCFN2
	CAME B,[SIXBIT /OUTPUT/]
	 JRST IIOC90	; also sigh
	SYSCAL DELETE,[IOCDEV ? IOCFN1 ? IOCFN2 ? IOCDIR]
	 JRST IIOC90	; Well, it was worth a try.
	JRST IIOC90

	; Here, ran out of storage on COMSAT's own sacred directory!
IIOC30:	POPAE P,[C,B,A]
	CALL SDFULI	; Attempt desperation measures at interrupt level.
	DISMISS		; If we return at all, we've won!!

; Stuff for handling expected IOC errors

UUODFE XCTIOC,UXCTIO	; skip unless IOCER occurs
UXCTIO:	TRO F,%IOCER
IFE $$UCAL,PUSH P,UUORPC	; Ensure ret addr on stack since may xct UUO.
	PUSH P,U40	; Must also save due to interrupt lossage (40 zapped)
	MOVEM P,XIOCP	; Save PDL pointer...
	XCT @(P)	; Execute instruction...
	 CAIA
	  AOS -1(P)
	AOS -1(P)
IOCRET:	TRZ F,%IOCER
	SUB P,[1,,1]	; Flush saved loc 40
	RET		; Return from UUO.

.SCALAR XIOCP	; Place to save PDL pointer for XCTIOC.

	; Here when IOCERR happens with flag set
IOCLUZ:	SKIPE MAKING	; IOCERR under DEBUG is expected in MAKMST
	 SKIPN DEBUG
	  CAIA
	   .VALUE	; Halt here with expected IOC error in DEBUG mode.
	MOVE P,XIOCP	; Restore PDL pointer...
	DISMISS [IOCRET]


;*************************  RLT INTERRUPT  ******************************
;			Real-Time Clock Interrupt

; The new way to do real time interrupts is to put the address of the handler
; you want to use into RLTVEC; when a real-time interrupt occurs, the
; routine will be jumped to.  If the sign bit is set, the dispatch
; will happen at interrupt level, and the handler is responsible for
; DISMISS'ing!
; Be sure to CLKOFF and SETZM RLTVEC in the handler, and also
; if you decide the timeout is no longer in effect.

LVAR RLTVEC:	0		; (See above)

INTRLT:	SKIPGE RLTVEC		; Does a int-level handler exist?
	 JRST @RLTVEC		; Yes, jump there!  Handler must DISMISS.
	SKIPE RLTVEC		; Does a prog-level handler exist?
	 DISMISS RLTVEC		; Yes, dismiss and dispatch there!

	; Unknown cause of RLT interrupt.
	PUSH P,A
	IUSAVE		; Save UUO vars since doing stats output.
	MOVE A,INTPDP
	MOVE A,-3(A)
	STAT (,(" ==="),RABR,(" BUG: Random REALT int, PC="),RHV(A),(", continuing."))
	IUREST		; Restore UUO vars.
	POP P,A
	DISMISS		; Returns normally


; PDL OV, MPV, and ILOPR Interrupt handlers.

INTPDL:	JSR PRESRV
	TLNN F,%SCOPN
	 JRST AUTPY1
	STAT (,(" ==="),RABR,(" BUG: PDL OVERFLOW!"))
	JRST AUTPY1		; Jump into autopsy routine

INTMPV:	JSR PRESRV
	TLNN F,%SCOPN
	 JRST AUTPY1
	STAT (,(" ==="),RABR,(" BUG: MPV!"))
	JRST AUTPY1		; Jump into autopsy routine

INTWRO:	JSR PRESRV
	TLNN F,%SCOPN
	 JRST AUTPY1
	STAT (,(" ==="),RABR,(" BUG: WRO!"))
	JRST AUTPY1

INTILO:	TRNE F,%ILOPR		; Skip if error not foreseen,
	 DISMISS [ILORET]	; else was predicted, return to special loc!
	JSR PRESRV		; Perform autopsy, unexpected ILOPR.
	TLNN F,%SCOPN
	 JRST AUTPY1
	STAT (,("	==="),RABR,(" BUG: ILOPR!"))
	JRST AUTPY1

UUODFE XCTILO,UXCTIL	; Like XCT but will skip unless ILOPR occurs.
UXCTIL:	TRO F,%ILOPR	; Set flag telling ILOPR handler it's OK.
	XCT @U40	; Do whatever.
	 CAIA		; a non-skipping instr really skips once
	  AOS UUORPC	; a skipping instr really skips twice
	AOS UUORPC
ILORET:	TRZ F,%ILOPR
	UUOXRT		; Return (w/o skipping if ILOPR occurred)


;*******************  USR INTERRUPT  **********************
;		Inferior Job Interrupt

INTUSR:	TLNN F,%PGMRN				; Running a pgm?
	 JRST [	IUSAVE			; Nope, random int.  Save UUO vars
		STAT (,("Note: Spurious USR int")) ; since doing stats output.
		IUREST
		DISMIS]
	PUSHAE P,[A,B]
	MOVE A,INTPDP
	MOVE B,INFBIT
	IORM B,-4(A)	; Set bit in old .DF2 so more inf. ints are deferred.
	POPAE P,[B,A]
	DISMIS [SNDP60]	;and dismiss to non-int-level handler.

;; INTDWN - %PIDWN interrupt handler.
;
;INTDWN:	PUSHAE P,[A,B]
;	SYSCAL SSTATU,[MOVEM A]	; See what's going on.
;	 JSR AUTPSY
;	JUMPGE A,[SETOM GODOWN	; If sys going down, signal main loop.
;		  DISMISS]
;	CAMN A,[-1]		; Sys up normally?
;	 JSR AUTPSY		; (shouldn't happen, not in OPTLIV mode).
;	SKIPE GODOWN		; Was it once going to go down?
	


SUBTTL Error handlers - AUTPSY, SDFULL

; AUTPSY - Called by a one-way JSR AUTPSY for purposes of leaving a trail,
;	saves info about bug and writes out on stat file, dumping job
;	if permissible.  Nearly ALL fatal errors wind up here.
;	really should have some different levels of bugs-- system type,
;	call type, soft type, etc. to replace filbug/corbug and furnish
;	more specificity for other types as well.

LVAR 	AUTPSY:	0 ? JRST AUTPY0	; Jump to pure

AUTPY0:	JSR PRESRV		; Save state of job (hopefully in sufficient detail)
AUTPY1:	TLNE F,%SCOPN		; And now if STATS channel is open,
	 JRST AUTPY2		; Jump to report lossage.
	MOVE B,[%DOWOV+.UAO,,SC]
	.CALL SCOBLK		; Not open??? Try gingerly to open...
	 JRST AUTPY7		; And quit immediately on any error.
	SYSCAL FILLEN,[CIMM SC ? CRET A]
	 JRST AUTPY7		; Also quit if can't find length???
	.ACCESS SC,A		; Set length to EOF
	OUT(SC,OPEN(UC$IOT))	; And open UUO channel so hairy output works.
	TLO F,%SCOPN		; and indicate open!
AUTPY2:	STAT (,(" ==="),RABR,(" BUG: FATAL ERROR "),LABR,("===  Date: "),TIM(MDYT),("
	Autopsy from "),RHV(AUTPSY),(" Preserved from "),RHV(PRESRV),("
	Last UUO = "),H(U40SAV),(" at "),RHV(UUHSAV),EOL)
	; Do this part if interrupt was triggered.
	STAT (,("	INT. FROM "),RHV(IPCSAV),("	.JPC/"),RHV(JPCSAV),("
	Registers:	
"))
	PUSH P,A
	MOVSI A,-20
AUTPY4:	CSTAT (,RHV(A),("/ "),H(ACCSAV(A)),EOL)
	AOBJN A,AUTPY4
	POP P,A

	JSR RNMREQ		; Try to rename current input request!
	 JRST [	STAT (,("No "),6F(IRIFN1),(" "),6F(IRIFN2),(" file present during burnup."))
		JRST AUTPY6]
	STAT (,("Input req file "),6F(IRRFN1),(" "),6F(IRRFN2),(" renamed to "),6F(BRQFN1),(" "),6F(BRQFN2))
AUTPY6:	JSR BURY		; Now try to dump self...
	STAT (,("Job dumped to CRASH;"),6F(DMPFN1),(" "),6F(DMPFN2))
	JSR UDEATH		; And now die.

	; Here after preserving state, if STATS channel can't be opened.
AUTPY7:	JSR RNMREQ		; As above, but without stats.
	 JFCL
	JSR BURY
	JSR UDEATH



; SYSLOS - for use when ITS does something wrong, eg when system
;	call inexplicably fails or returns strange error code.

LVAR	SYSLOS:	0 ? JSR AUTPSY


; CORLOS - Suport routine for PAGSER; JSRd to when a CORBLK fails.
;   CBKERR/ error code from failing .CALL
;   If arg not provided, checks most recent erring channel.

LVAR	CORLOS:	0 ? JRST CORLS0

CORLS0:	PUSH P,A
	SKIPE A,PAGSER"CBKERR	; Error code present?
	 JRST CORLS2		;  Yes, go check it.
	.SUSET [.RBCHN,,A]	; Else ask recent erring channel for error.
	SYSCAL STATUS,[A ? CRET A]
	 JSR SYSLOS
	LDB A,[$ERRCD,,A]	; Get # of error
CORLS2:	CAIE A,37		; Error = no core available?
	 JSR AUTPSY		; Nope, something horrible. die.
	TLNN F,%SCOPN		; Hurray, can re-try! If stats open, say so.
	 JRST CORLS5
	IUSAVE			; Save UUO vars since doing stats output.
	STAT (,(" ==="),RABR,(" CORBLK HUNG, SLEEPING..."))
	IUREST			; Then restore.
CORLS5:	MOVEI A,30.		; Now prepare to
	.SLEEP A,		; sleep for a second.
	POP P,A
	SOS CORLOS		; Then adjust return addr so that
	SOS CORLOS		; it points to call which failed.
	JRST @CORLOS		;and go try again.

;;; PAGLUZ - JSRd to by the PSRERR macro, which is used inside PAGSER.

LVAR 	PAGLUZ:	0 ? JRST PAGLU0	; Jump to pure
LVAR	PAGLCD:	0		; Error code.

PAGLU0:	MOVEM U4,PAGLCD		; Remember the PAGSER lossage code.
	JSR PRESRV		; Preserve COMSAT state.
	CAIN U4,PAGSER"EROOM	; Examine PAGSER error code.
	 JRST PAGLU2
PAGLU1:	POP P,U4		; If random error jump to our death.
	JSR AUTPSY
PAGLU2:	POP P,U4
	TLNE F,%SCOPN		; Else COMSAT ran out of address space.
	 JRST PAGLU3		; Ensure STATS file is open.
	MOVE B,[%DOWOV+.UAO,,SC]
	.CALL SCOBLK		
	 JRST PAGLU7		; And quit immediately on any error.
	SYSCAL FILLEN,[CIMM SC ? CRET A]
	 JRST PAGLU7		; Also quit if can't find length???
	.ACCESS SC,A		; Set length to EOF
	OUT(SC,OPEN(UC$IOT))	; And open UUO channel so hairy output works.
	TLO F,%SCOPN		; and indicate open!

PAGLU3:	STAT (,(" ==="),RABR,(" BUG: FATAL ERROR "),LABR,("===  Date: "),TIM(MDYT),("
	Autopsy from "),RHV(AUTPSY),(" Preserved from "),RHV(PRESRV),("
	Last UUO = "),H(U40SAV),(" at "),RHV(UUHSAV))
	STAT (,("	INT. FROM "),RHV(IPCSAV),("	.JPC/"),RHV(JPCSAV))
	STAT (,(" ==="),RABR,(" Out of address space! "),LABR,("==="),EOL)
PAGLU7:	OUT(SC,CLS)	; Close stats channel, forcing out any buffered stuff.
IFN 0,	JSR DEATH	; Die without leaving any kind of corpse.
	SKIPN DIDONE	;If we haven't won even once yet
	 JSR RNMREQ	; then current input file is probably the troublemaker.
	  NOP
	 JSR RESET	;Flush.



BVAR
OPRSRV:	0		; To prevent clobberage by nested lossage.
PRESRV:	0		; JSR'd to, so accs not disturbed
	JRST PRSRV0	; Jump to pure.
EVAR
PRSRV0:	SKIPE DEBUG
	 JSR DEATHV
	SKIPE OPRSRV
	 JSR UDEATH		; If err within error handling, die instantly.
	MOVEM P,PDLSAV		; Save P (must be ac 17!)
	MOVE P,PRESRV
	MOVEM P,OPRSRV		; Save return loc as clobberage protection.
	MOVE P,[0,,ACCSAV]
	BLT P,PDLSAV-1		; Save all accs
	MOVE P,[-XPDLLN,,XPDLOC]
	PUSHAE P,[A,B]
IFE $$UCAL,MOVE A,UUORPC ? MOVEM A,UUHSAV
	MOVE A,U40
	MOVEM A,U40SAV
	.SUSET [.RBCHN,,BCHSAV]
	MOVSI A,-20
	SYSCAL STATUS,[MOVEI (A) ? CRET STASAV(A)]
	 JFCL
	AOBJN A,.-2
	.SUSET [.RMPVA,,MPVA]
	MOVE B,[SQUOZE 0,USER]
	.EVAL B,
	 .VALUE
	MOVSS B
	HRRI B,B
	.GETLOC B,		; B gets my user index
	IRP SYM,,[LSPCL,LEXFDR]
	 MOVE A,[SQUOZE 0,SYM]
	 .EVAL A,
	  .VALUE
	 ADD A,B
	 MOVSS A
	 HRRI A,SYM
	 .GETLOC A,
	 TERMIN
	SETZM IPCSAV
	SETZM JPCSAV
	MOVE B,INTPDP		; Get interrupt PDL ptr
	CAMN B,[-LIPDL,,IPDL-1]	; Were we interrupted?
	 JRST PRESR2		; Nope, don't try to read interrupt stack.
	MOVE A,-3(B)		; Yes! Get loc interrupted from.
	MOVEM A,IPCSAV
	MOVE A,-2(B)		; and loc of last jump instr.
	MOVEM A,JPCSAV
PRESR2:	POPAE P,[B,A]
	JRST @PRESRV
	
	;;; STUFF SAVED FOR DEBUGGING CRASHES
BVAR
ACCSAV:	BLOCK 17	; All accs including...
PDLSAV:	0		; saved P (17).
UUHSAV:	0		; value at UUOH if using JSR (loc of last UUO)
U40SAV:	0		; value at U40 (last UUO)
JPCSAV:	0		; loc of last jump instr (if interrupted)
IPCSAV:	0		; loc interrupted from if any
BCHSAV:	0		; saved .BCHN
STASAV:	BLOCK 20	; saved STATUS of all channels
MPVA:	0		; Referencing address of last MPV/WRO
LSPCL:	0		; Last two exec PCs pclsred at
LEXFDR:	0		; fault bits,,PC of last error page fault from exec mode

XPDLLN==25
XPDLOC:	BLOCK XPDLLN	; Emergency PDL - avoid clobbering regular.
EVAR

; RNMREQ - Renames input request file (if any) to signify bad request.
;	Called by JSR.

LVAR RNMREQ:	0 ? JRST RNMRQ0
RNMRQ0:	SYSCAL RENAME,[SATDEV ? IRRFN1 ? IRRFN2 ? SATDIR
		IREFN1 ? IREFN2]
	 JRST @RNMREQ		; Assume nothing to rename.
	SYSCAL OPEN,[[.UII,,DMPCH] ? ['DSK,,]
		IREFN1 ? IREFN2 ? SATDIR]
	 JSR UDEATH
	SYSCAL RFNAME,[CIMM DMPCH ? CRET JUNK ? CRET BRQFN1 ? CRET BRQFN2]
	 JSR UDEATH
	AOS RNMREQ
	JRST @RNMREQ
BVAR
BRQFN1:	0
BRQFN2:	0
EVAR

; BURY - PDUMP's self to DSK:CRASH;BURNUP >
;	Called by JSR

.SCALAR BURNSV,BURYF,BURYP

LVAR BURY:	0 ? JRST BURY0	; PDUMP corpse so have something to look at.
BURY0:	SKIPE DEBUG
	 JSR DEATHV
	SYSCAL OPEN,[[.BIO,,DMPCH] ? ['DSK,,0] 
			['BURNUP] ? [SIXBIT />/] ? [SIXBIT /CRASH/]]
	 JSR UDEATH
	MOVEM A,BURNSV		; Save acc
	MOVE A,[DMPCH,,DMPDAT]
	.RCHST A,
	MOVEM F,BURYF
	MOVEM P,BURYP
	MOVSI 17,ACCSAV		; restore ACs so PDUMP can save them
	BLT 17,17
	SETZM DMPDAT
	SYSCAL PDUMP,[CIMM %JSELF ? CIMM DMPCH ? DMPDAT] ;Dump self.
	 JSR UDEATH
	MOVE A,[-8,,[
		JUMPA MAIN	; First start address
		-4,,2		; Indirect symbol table pointer
		SIXBIT/DSK/ ? SIXBIT/COMSAT/ ? SIXBIT/LAUNCH/ ? SIXBIT/.MAIL./
		0		; Hopefully no one cares about the checksum
		JUMPA MAIN ]]	; Second start address
	.IOT DMPCH,A
	.CLOSE DMPCH,
	MOVE A,BURNSV
	MOVE F,BURYF
	MOVE P,BURYP
	JRST @BURY

BVAR
DMPDAT:	0		;returned by .rchst to get true dump file names.
DMPFN1:	0
DMPFN2:	0
	0 ? 0
EVAR

; UDEATH - Kill Unique COMSAT.  Does special hacks to relinquish
;	uniqueness, and decides whether to disappear or stay around.
;	(If not unique, just disappears.)

LVAR UDEATH:	0 ? JRST UDEAT0	; Jump to pure.
UDEAT0:	SKIPE DEBUG	; If debugging, just halt.
	 JSR DEATHV
	OUT(SC,CLS)	; Close stats channel, forcing out any buffered stuff.
	.CLOSE LSR1C,
	.close lockch,
	.CLOSE DKIC,
	.CLOSE DKOC,
	.CLOSE NETD,
	.CLOSE NETI,
	.CLOSE NETO,

	; Decide whether to log out or leave corpse around.
	SKIPN HAVLKS	; Do we have the locks set up?
	 JSR DEATHV	; No, horrors... should always be able to get
			; at locks.  Hang around system for hacker to inspect.
	SKIPN UNIQUE	; If have locks, but job is not unique,
	 JSR DEATH	;  die, period.

	; Job is the one and only system comsat, and we have locks.
	; See if already too many dead comsats around for leaving corpse
	MOVEM A,DIESVA
	MOVE A,LOCK2		; Not really a lock; used as count.
	CAIL A,3		; Less than 3 so far?
	 JSR DEATH		; Too many, disappear.

	; Hang around.  Unlock switch 1 so other comsats can be started.
	MOVEM P,DIESVP
	MOVEI P,PATCH+PATLEN-10	; Set up small PDL to make sure we win.
	MOVEI A,LOCK1
	CALL LKFREE		; Free the lock!  A new COMSAT can now run...
	AOS LOCK2		; Increment count of dead comsats
	JSR DEATHV		; and start swinging in the breeze

.SCALAR DIESVA,DIESVP

BVAR	; JSR here when all ready to pull trigger.
DEATH:	0
	.LOGOUT
	CAIA
	; JSR here if only want to stop, or if trigger is jammed.
DEATHV:	0
	.VALUE		;if not toplevel, this will have to do.
	JRST .-1	;insist.
EVAR



; SDFULL - Satellite Directory Full.  Called when something happens
;	(IOC error, OPEN lossage) that indicates .MAIL. needs
;	to get more room before COMSAT can proceed at all.
;	Note that this routine must distinguish between true directory
;	gronkage, and general system disk shortage.
; SDFULI - same, but called at Interrupt level.

LVAR SDFISW:	0	; -1 if SDFULI, 0 if SDFULL.
LVAR SDFCNT:	-1	; Set -1 if all is well at top-level .HANG,
			; AOS'd each time SDFULL called.  Used to
			; detect SDFULL looping.

SDFULI:	SETOM SDFISW		; Interrupt level.
	IUSAVE			; Save UUO vars.
	CAIA
SDFULL:	 SETZM SDFISW		; Not at interrupt level.
	AOS SDFCNT		; Bump cnt of calls.
	PUSHAE P,[A,B,C]

	; First thing is to determine independently what the problem is.
	.SUSET [.RBCHN,,C]	; Find bad channel #
	SYSCAL STATUS,[C ? CRET B]	; and get IOS word.
	 JSR SYSLOS
	LDB A,[330500,,B]	; Find IOC error code.
	CAIN A,11		; Device full?
	 JRST SDFL20		; Yes, system running out of disk space.
	CAIN A,14		; Directory full?
	 JRST SDFL40		; Yes, satellite directory gronked.
	LDB A,[$ERRCD,,B]	; Hmm, no IOC error matched, try normal err.
	CAIN A,5		; Directory full?
	 JRST SDFL40		; Yes, go handle.

	; Come here when error cannot be recognized as either device full
	; (no disk space) or dir full (no room in comsat's dir).  For now,
	; and probably for ever, die.
	JSR AUTPSY

	; Return!! - jump here if one of the routines below thinks it's
	; succeeded (heh) in resolving the problem.
SDFL90:	POPAE P,[C,B,A]		; Hurray...
	SKIPN SDFISW		; If at interrupt level,
	 RET
	IUREST			; also restore UUO handler stuff.
	RET

	; Device Full - system is running out of disk space, and COMSAT
	; can't get enough disk to write something it needs.  Never die;
	; keep trying, and wait until room opens up.

LVAR QDSKN:	0	; Holds address of QDSKN table in system
LVAR QSFT:	0	; Holds address of QSFT table in system

SDFL20:
	; Try examining actual space left on drive being used by channel.
	LDB A,[000600,,B]
	CAIE A,43	; Is physical device code 43 = DSK?
	 JSR AUTPSY	; If not, something's screwy.
	HRLZ A,C
	ADD A,[.RIOC,,A]	; Cons up appropriate cruft to get IOCHNM+ch
	.SUSET A
	HLRZ A,A	; Get LH = disk channel #.
	SKIPN B,QDSKN	; Get system address of QDSKN table,
	 JRST [	MOVE B,[SQUOZE 0,QDSKN]
		.EVAL B,	; And get from system if haven't already.
		 JSR SYSLOS
		MOVEM B,QDSKN
		JRST .+1]
	ADDI A,(B)	; Get address in system to inspect (index by dsk ch #)
	HRLZ A,A
	HRRI A,A	; Now have <sys addr>,,<result addr>
	.GETLOC A,	; Examine it - now have physical drive # in A.
	SKIPN B,QSFT	; Now do similar kludgery for QSFT (tracks free on drive)
	 JRST [	MOVE B,[SQUOZE 0,QSFT]
		.EVAL B,
		 JSR SYSLOS
		MOVEM B,QSFT
		JRST .+1]
	ADDI A,(B)
	HRLZ A,A
	HRRI A,A
	.GETLOC A,	; Now have # tracks free in A!

	; If very small number free, shout.  Otherwise perhaps there's
	; now enough room...
	CAML A,SDFLIM
	 JRST [	MOVE A,SDFCNT	; Should be enough, but check count of calls
		CAILE A,3	; and be highly suspicious of prognosis
		 JRST SDFL35	; if calls are repetitive - try sleeping.
		JRST SDFL90]	; Else bravely return.

	; Try shouting.
	CALL DATIME"TIMGT	; Find current time,
	CALL DATIME"TIMSEC	; convert to abs # secs,
	MOVE B,A
	SUB B,LSHTIM	; And subtract last shout time.
	CAMGE B,SDFTLM	; Enough time since then to send another?
	 JRST SDFL35	; No, wait.

	; OK, we'll shout...
	MOVEM A,LSHTIM	; Save as new last-shout-time.
	SYSCAL PGWRIT,[CIMM LCKPAG]	; and make sure it's written on disk.
	 JSR SYSLOS
	MOVEI A,3
	MOVEM A,CLITYP	; Specify "TTY message from ..."
	MOVE A,[ASCNT [COMSAT]]
	MOVEM A,CLIANC	; "...COMSAT".
	SETZB A,CLIZSW	; With character limit of
	HLLOM A,CLIZMX	; 0,,-1 (effectively infinite).
	SETZM CLIHDR	; Don't bother with header, and use following
	MOVE A,[ASCNT [EVERYBODY: Disk space very low, please delete unnecessary files!]]
	MOVEM A,CLITXT	; as message text.
	SETZ A,		; Send to all HACTRN's...
	MOVEI B,CLISND	; using standard routine.
	CALL XCTALU	; Do it!
			; Now drop thru to sleep for a while...

SDFL35:	MOVE A,SDFSLP	; Get time to sleep
	.SLEEP A,
	JRST SDFL90	; Return and re-try whatever it was that lost.

LVAR SDFLIM:	50.	; # dsk blocks below which to shout about.
LVAR SDFTLS:	0	; Time (.rdtime) of last SHOUT
LVAR SDFTLM:	15.*60.	; Time to wait between shouts. (15 min)
SDFSLP:	30.*30.		; Half minute naps while waiting.

	; Directory Full - COMSAT's directory has been stuffed to the gills,
	; and nothing can be done (no matter how much disk the system has)
	; until some files are flushed!

;  In no case should COMSAT simply give up and die.  Persevere!
;   If problem is .MAIL. directory itself:
;    o SHOUT at selected people?
;    o Flush a special "buffer" file, giving enough room 
;      to finish and yell for help
;    o Write a MAIL > file directed to mail-maintainers
;    o Examine OSTATS, NAMES, NAMED for possible flush candidates; 
;	   don't flush most recent good NAMES, and don't flush an 
;	   OSTATS if not dumped, etc. nor if down to very last OSTATS.
;    o Can try some sleeping so someone can respond to cry for help.
; If problem persists, very last resort should be to die without freeing locks.

SDFL40:	JSR AUTPSY ;For now, just die!

IFN 0,[	;; Shout out knowledgable people to clean up .MAIL.; directory.
	;; Then go to sleep.
	;; If complete loss after a while, die without freeing locks.
	MOVE A,[ASCNT [MAIL-DIR-MAINT]]
	SETZ B,			; Match to any type.
	CALL RCPEQV		;get ptr to option list if any
	 JRST SDFL49
];IFN 0


SUBTTL *------------------- Entry & Init ---------------------------*
SUBTTL PURIFY$G - Purification

LVAR PURESW:	0	; If -1, program has been purified.

;;; PURIFY$G entry point - use when setting up a just-assembled comsat
;;;	for dumping as appropriate file on .MAIL.

PURIFY:	MOVE A,[<PURPGB-PURPGE>,,PURPGB]	; Get page AOBJN
	SYSCAL CORBLK,[CIMM %CBNDR ? CIMM %JSELF ? A ? CIMM %JSELF]
	 .LOSE 1000
	SETOM PURESW	; Set flag saying pgm is pure.
	MOVEI A,[ASCIZ /:PDUMP DSK:.MAIL.;COMSAT LAUNCH/]
	SKIPGE XVERS	; Experimental mailer?
	 MOVEI A,[ASCIZ /:PDUMP DSK:.MAIL.;COMSAT XPER/]
	SKIPLE XVERS	; New mailer?
	 MOVEI A,[ASCIZ /:PDUMP DSK:.MAIL.;COMSAT NEW/]
	.VALUE (A)	; Valret appropriate string.
	JRST INIT	; and go start up if continued.

; IPURIF - Internal Purify routine.

IPURIF:	PUSH P,A
	MOVE A,[<PURPGB-PURPGE>,,PURPGB]	; Get page AOBJN
	SYSCAL CORBLK,[CIMM %CBNDR ? CIMM %JSELF ? A ? CIMM %JSELF]
	 JSR SYSLOS	; Shouldn't happen.
	SETOM PURESW	; declare pure.
	POP P,A
	RET

	; Network code - must be here because NETRTS uses STAT and DISMISS.
.INSRT DSK:SYSNET;NETRTS >

SUBTTL MFINIT$G - Emergency File Directory Initialization

;	The following code initializes the satellite's data
; directory, and will never be executed unless started here
; manually.  The reasoning is that if a file required by the
; mailer is lost or garbaged, it is far better to halt and
; await human intervention than attempt to fix things automatically.
; If the lossage is impossible to remedy, this code will try
; to create a new set of files.
;	Interrupts are NOT enabled, and return is by .VALUE.
; This will re-create all existing mailer files, (except if ID exists
;   it will increment it instead of creating it.)  So be careful.

MFINIT:	MOVE P,[-PDLLEN,,PDL]	; Set up PDL
	SETZB F,MF		; and clear all flags.
	SETOM DEBUG		; Always indicate debugging.
	SYSCAL USRVAR,[CIMM %JSELF ? CIMM .ROPTION ? CIMM ; Set up options: Locked switch
			[TLO 0,%OPALL]]	; feature and winning new interrupts.
	 .LOSE 1000
	CALL MYADDR		; Set our address(es)
	SKIPE XVERS
	 CALL XVRSRT		; Set up right filenames if not normal!
	SKIPN PURESW		; and make sure
	 CALL IPURIF		; that what can be pure is pure!

	; The following routines need to be in the order given.  Since
	; it is desirable to enable the SC stats channel ASAP, the
	; first order of business is to determine if this incarnation
	; of the mailer is unique, i.e. can it reference & write to
	; the directory?
	CALL DATIME"UPINI
	 CALL MTMHNG		; UPINI lost, do something appropriate.
	CALL MLINIT		; And ensure uniqueness.
	SETZM LSHTIM		; (after grabbing locks, clear last shout time)
	CALL SCOPN		; Now initialize statistics file!
	CALL MCINIT		; Initialize core management.

	; Essential initializations done, now to create new data files.
	SYSCAL DELETE,[SATDEV ? NMGFN1 ? NMGFN1+1
		SATDIR ? CERR A]	; Delete NMSGS if it exists.
	 JRST [	CAIN A,4
		 JRST .+1
		JSR AUTPSY]
	SYSCAL DELETE,[SATDEV ? NMSFN1 ? NMSFN1+1
		SATDIR ? CERR A]	; Ditto NMASTR.
	 JRST [	CAIN A,4
		 JRST .+1
	 	JSR AUTPSY]

	SYSCAL OPEN,[[.BIO,,DKOC] ? SATDEV ? MSGFN1 ? MSGFN2 ? SATDIR]
	 .VALUE [ASCIZ /: Can't create MSGS file! 
/]
	.CLOSE DKOC,		; Close it, now exists with length 0.
	SYSCAL RENAME,[SATDEV ? IDFN1 ? IDFN2 ? SATDIR
		IDFN1 ? IDFN2]	; Attempt to produce new ID file
	 CAIA			; Skip to create if lost.
	  JRST MFINI5		; Jump if won, need not start over.
	SYSCAL OPEN,[[.BIO,,DKOC] ? SATDEV ? IDFN1 ? IDFN2 ? SATDIR]
	 .VALUE [ASCIZ /: Can't create ID file! 
/]
	.CLOSE DKOC,		; Close, now ID file exists...

	; Now create MASTER file.  First set up LSE...
MFINI5:	CALL MSTNIL		; Create nil MASTER.
	CALL MSTPUT		; Now write out, creating file!

	; Now have new MASTER file, must create RML and QML files.
	CALL MAKQFI		; Special routine to generate RML/QML given MASTER.

	; Now compile the EQV file...
	CALL EQVGOB		; Compile it!
	 .VALUE [ASCIZ /: Error(s) during EQV file compilation!  Read STATS or error file.
/]			; Foo?  Error during compilation, STATS should show why.

	; Now all done!
	.VALUE [ASCIZ /: File Directory Initialization successfully completed...
Proceeding will launch Comsat. 
/]
	MOVEI A,LOCK1		; Unlock switch 1 so can re-grab later.
	CALL LKFREE
	JRST INIT		; Go!

$LHMFG==$LHSIZ+0	; Define these to be located at end of LSE HDR area.
$LHMFL==$LHSIZ+1

SUBTTL MAKMST$G, etc - Emergency regeneration of MASTER and/or QML/RML files.

; Note: This is NOT FULLY DEBUGGED!!!
; ********** Cant work without STATS open.  Fix. **********

; MAKMST - Re-creates the MASTER file from the MSGS file.  This code
;	is never executed unless started here manually, and after it is
;	run, it should be killed and a new COMSAT started.  (On the fatal
;	day 7/9/77 the MC MASTER file got clobbered and this code was
;	typed into DDT by hand (by MOON and DLW), and we created MASTER all
;	right but accidentally clobbered MSGS! I don't ever want that to
;	happen again, so...  --dlw)

; Instructions: Save the old LIST MASTER (if it's worth it), and delete LIST
;   MASTER.   Then start at MAKMST.  If anything is wrong, it will tell you.
;   When done, kill this and start another COMSAT.

LVAR MAKING:	0		; Flag that we were started in this code.

MAKMST:	SETOM MAKING		; Flag.
	MOVE P,[-PDLLEN,,PDL]
	SETZ F,
	SETOM DEBUG
	SYSCAL USRVAR,[CIMM %JSELF ? CIMM .ROPTION ? CIMM ; Set up options: Locked switch
			[TLO 0,%OPALL]]	; feature and wining new interrupts.
	 .LOSE 1000
	CALL MYADDR	   	; Set address(es)
	SKIPE XVERS
	 CALL XVRSRT
	CALL DATIME"UPINI	; Get the time for MLINIT.
	 CALL MTMHNG
	CALL MLINIT		; Will go to MAKMNU if we are not unique.
	CALL MCINIT		; We need area hacking, etc.

	CALL MSTNIL		; Initialize MASTER LSE to NIL.
	MOVEI A,MSGFN1		; Open MSGS.
	CALL OPNMFI
	 .VALUE
	.SUSET [.SIMASK,,[%PIIOC]]	; Enable IOC handler for XCTIOC in LSEIN
	.SUSET [.SPICLR,,[-1]]		; And turn on interrupt system.
MAKM10:	MOVEI A,TMPAR		; Read the next message into MSGS.
	SETO B,
	CALL LSEIN
	 JRST MMCONT		; Got an IOC error, we must have hit the end.
	MOVE L,$ARLOC+TMPAR
	FINDA A,[A$ID,,[$LLLST(L)]]	; Get message ID.
	 .VALUE [ASCIZ \: ERROR! The current msg has no ID!!! \]
	MOVE L,$ARLOC+MASTER
	LNCOPY A,[$ARLOC+TMPAR ? A]	; And copy it into MASTER area.
	MAKELN B,[A$IDBL,,0	; Now get the disk length and addresses.  LSEIN handily
		  %LTVAL,,[ULSDBH]]	;   leaves them in these convenient locations.
	MAKELN B,[A$IDAD,,[B]
		  %LTVAL,,[ULSIPT]]
	HRRM B,LISTAR(A)	; NCONC these two onto the ID (order of these LNs is critical.)
	MAKELN A,[A$I,,[$LLLST(L)]	; And put this info onto one big list.
		  %LTLST,,[A]]
	MOVEM A,$LLLST(L)
	JRST MAKM10

	; LSEIN got an IOC error.
MMCONT:	SYSCAL STATUS,[CIMM DKIC ? CRET A]
	 .LOSE 1000
	LDB B,[330500,,A]	; Get the IOC error code.
	CAIE B,2		; Is it EOF?
	 .VALUE [ASCIZ \: ERROR: IOC error not EOF.  STATUS of DKIC in A. \]
	SYSCAL OPEN,[[.BIO,,DKOC] ? SATDEV ? [SIXBIT /_MAKMO/] ? [SIXBIT />/] ? SATDIR]
	 .LOSE %LSFIL
	MOVEI A,MASTER		; Write out MASTER to temporary file name.
	SETO B,
	CALL LSEOUT
	SYSCAL RENMWO,[CIMM DKOC ? MSTFN1 ? MSTFN2]
	 .LOSE %LSFIL
	.CLOSE DKOC,
	.VALUE [ASCIZ \: Super win.  Now kill this job, and start another COMSAT. \]
	JRST .-1		; In case loser proceeds.

MAKMNU:	.VALUE [ASCIZ \: ERROR -- There is ANOTHER COMSAT running! Stop it!!!
(Then start all over.)\]
	JRST .-1

;;; This routine, intended to be called by hand, will delete from
;;; MASTER any entries which aren't in QUEUE.  Ought to know about
;;; REMIND at some point also.
;;; This routine is not recommended for use except in dire emergency,
;;; because almost always MASTER contains valid stuff and the QML list
;;; is missing some messages it should have.  If called, the procedure should
;;; be to first call MAKQFS, to make sure that everything which can
;;; possibly be queued is definitely on the QML (or RML).  Then CLNMST
;;; can be called to flush anything which has no business being there at all.

CLNMST:	MOVE P,[-PDLLEN,,PDL]
	SETZ F,
	SETOM DEBUG
	SYSCAL USRVAR,[CIMM %JSELF ? CIMM .ROPTION ? CIMM ; Set up options: Locked switch
			[TLO 0,%OPALL]]	; feature and wining new interrupts.
	 .LOSE 1000
	CALL MYADDR	   	; Set our address(es)
	SKIPE XVERS
	 CALL XVRSRT
	CALL DATIME"UPINI		; Get the time for MLINIT.
	 CALL MTMHNG
	CALL MLINIT		; Will go to MAKMNU if we are not unique.
	CALL MCINIT		; We need area hacking, etc.
	.OPEN DBC,[.UAO,,'TTY]	; Will type-out about deleted msgs on DBC
	 .VALUE
	OUT(DBC,OPEN(UC$IOT))
	CALL QMLGET		; Get QUEUE into core
	CALL MSTGET		; Get MASTER into core
	;; Go over MASTER, deleting guys not in QUEUE
	MOVE L,$ARLOC+MASTER	; Make it current LSE
	MOVE A,$LLLST(L)	; Point to whole list as arg for MAPC
	MOVEI B,CLNMS1		; Apply this routine to each entry in MASTER.
	CALL MAPC		; Do it!
	 .VALUE			; won't ever happen
	.VALUE [ASCIZ/: Type $P to write it out 
/]
	.VALUE [ASCIZ/: Are you SURE?  Examine your conscience... 
/]
	.VALUE [ASCIZ/: All right, you have this one last chance...
/]
	.VALUE [ASCIZ/: So be it... 
 p/]
	CALL MSTPUT		; Next GC will clean up MSGS
	.VALUE [ASCIZ/: Done 
/]

;A has a MASTER element, B and C may be clobbered
CLNMS1:	PUSHAE P,[L,D,E]
	FINDA C,[A$ID,,[LISTAR(A)+1]]	; Find ID of this MASTER entry
	 .VALUE
	MOVE C,LISTAR(C)+1	; Get SPT
	ADD C,$LSLOC(L)		; Make absolute
	MOVE L,$ARLOC+QMLAR	; Select QUEUE area
	HRRZ D,$LLLST(L)	; Loop over hosts
	JUMPE D,CLNMS9
CLNMS2:	FINDA E,[%HSIGN+A$ID,,[LISTAR(D)+1] ? C]	; See if this ID is on this site
	 JRST CLNMS4		; No, keep looking
CLNMS3:	POPAE P,[E,D,L]		; Yes, this guy is OK, return
	JRST POPJ1		; Success return to MAPC

CLNMS4:	HRRZ D,LISTAR(D)	; CDR to next host
	JUMPN D,CLNMS2
CLNMS9:	EXCH A,C		; A gets ASCNT to message-ID
	CALL MSGGTA		; Get message into core
	 .VALUE			; Should be there
	EXCH A,C
	MOVE L,$ARLOC+MSGAR
	FINDA B,[A$MHDR,,[$LLLST(L)]]	;Get message header
	 .VALUE			; Should be there
	HLRZ D,LISTAR(B)+1	; Get length of header
	JUMPN D,CLNMS8		; Jump if OK
	FINDA B,[A$MTXT,,[$LLLST(L)]]	;Extract network header from message text
	 .VALUE
	MOVE D,LISTAR(B)+1	;Convert to absolute SPT
	ADD D,$LSLOC(L)
	HLRZ E,D
	HRLI D,440700
	PUSHAE P,[A,B]
CLNMS7:	ILDB A,D
	LSH B,7
	IOR B,A
	TLZ B,776000
	CAMN B,[<<<<<15*200>+12>*200>+15>*200>+12]
	 JRST [	POPAE P,[B,A]
		HLRZ D,LISTAR(B)+1	;Make shorter
		SUB D,E
		HRLM D,LISTAR(B)+1
		JRST CLNMS8 ]
	SOJG E,CLNMS7
	POPAE P,[B,A]
CLNMS8:	OUT(DBC,("Deleting message:"),EOL,TLS(B))
	MOVE L,$ARLOC+MASTER	; Delete from MASTER (code copied from IDDELE)
	FINDA B,[A$IDBL,,[LISTAR(A)+1]]	; Get length of LSE-blk on disk.
	 .VALUE
	MOVE B,LISTAR(B)+1	; Get # words used by LSE.
	ADDM B,$LHMFG(L)	; Increment cnt of garbage wds.
	LNDEL A,$LLLST(L)	; Now kill it.
	JRST CLNMS3		; And return to MAPC


;;; Routine to print the QML onto a disk file.
;;; Useful when queue is so bloated that SHOW-Q can't work.

SHOWQ:	MOVE P,[-PDLLEN,,PDL]
	SETZ F,
	SETOM DEBUG
	SYSCAL USRVAR,[CIMM %JSELF ? CIMM .ROPTION ? CIMM
			[TLO 0,%OPALL]]	    ; Locked switch and New Interrupts.
	 .LOSE 1000
	CALL MYADDR		; Set our address(es)
	SKIPE XVERS
	 CALL XVRSRT
	CALL DATIME"UPINI	; Get the time for MLINIT.
	 CALL MTMHNG
	CALL MLINIT		; Will go to MAKMNU if we are not unique.
	CALL MCINIT		; We need area hacking, etc.
	TLNN F,%SCOPN
	 CALL SCOPN		; Make sure stats channel is open!
	STAT (,("Service stopped for SHOWQ - listing QML to disk file."))
	SKIPN $AROPN+QMLAR
	 CALL QMLGET		; Get QUEUE into core
	SKIPN $AROPN+MASTER
	 CALL MSTGET		; Get MASTER into core
	.CALL [SETZ ? SIXBIT/OPEN/ ? [.UAO,,DBC] ? [SIXBIT/DSK/]
		[SIXBIT/GUBBLE/] ? SETZ [SIXBIT/>/] ]
	 .LOSE %LSSYS
	OUT(DBC,OPEN(UC$IOT))	; Open output file as standard-output.
	OUT(,CH(DBC))
	CALL PRTQML		; Try SHOW-Q routine now.
	 JFCL
	TLZ F,%MSTMD		; Get rid of in-core copy of MASTER.
	UARCLS MASTER
	UARCLS TMPAR
	TLZ F,%QMLMD		; Get rid of in-core copy of QUEUE.
	UARCLS QMLAR
	UARCLS TMPAR
	OUT(DBC,CLS)		; Close channels, making sure all's output.
	OUT(SC,CLS)
	.VALUE [ASCIZ /:Done
/]


; Hand-callable routine to GC the QUEUE and MASTER files.

GCQ:	MOVE P,[-PDLLEN,,PDL]
	SETZ F,
	SETOM DEBUG
	;; Set up options: Locked switch feature and wining new interrupts.
	SYSCAL USRVAR,[CIMM %JSELF ? CIMM .ROPTION ? CIMM [TLO 0,%OPALL]]
	 .LOSE 1000
	CALL MYADDR		; Set our address(es)
	SKIPE XVERS
	 CALL XVRSRT
	CALL DATIME"UPINI	; Get the time for MLINIT.
	 CALL MTMHNG
	CALL MLINIT		; Will go to MAKMNU if we are not unique.
	CALL MCINIT		; We need area hacking, etc.
	TLNN F,%SCOPN
	 CALL SCOPN		; Make sure stats channel is open!
	CALL GCQ0
	.VALUE [ASCIZ/: Done! 
/]

GCQ0:	STAT (,("Garbage collecting QUEUE and MASTER"))
	SKIPN $AROPN+QMLAR
	 CALL QMLGET		; Get QUEUE into core
	SKIPN $AROPN+MASTER
	 CALL MSTGET		; Get MASTER into core
	MOVEI A,TMPAR		; Make TMPAR be new MASTER (code from MSTNIL)
	CALL LSEOPN
	MOVEI A,2
	UAREXP A,TMPAR		; Expand HDR area by 2, to make sure
	MOVE L,$ARLOC+TMPAR	; that there's room for storage of
	MOVE A,$ARLOC+MASTER
	MOVE B,$LHMFG(A)	; Copy MSGS garbage data
	MOVEM B,$LHMFG(L)
	MOVE B,$LHMFL(A)
	MOVEM B,$LHMFL(L)
	MOVE B,$LLLST(A)
	LNCOPY A,[MASTER ? SETZ B]
	MOVEM A,$LLLST(L)
	MOVE A,[TMPAR,,MSTFN1]	; Output the results
	CALL DFPUT
	TLZ F,%MSTMD		; And get rid of in-core copy
	UARCLS MASTER
	UARCLS TMPAR
	MOVEI A,TMPAR		; Make TMPAR be new QUEUE 
	CALL LSEOPN
	MOVE L,$ARLOC+TMPAR
	MOVE A,$ARLOC+QMLAR
	MOVE B,$LLLST(A)
	LNCOPY A,[QMLAR ? SETZ B]
	MOVEM A,$LLLST(L)
	MOVE A,[TMPAR,,QMLFN1]	; Output the results
	CALL DFPUT
	TLZ F,%QMLMD		; And get rid of in-core copy
	UARCLS QMLAR
	UARCLS TMPAR
	RET


;;; Routine to convert a MSGS file into ascii (more or less)
;;; Patch MSTFN1 and MSGFN1 to appropriate file names first

ASCMSG:	MOVE P,[-PDLLEN,,PDL]
	SETZ F,
	SETOM DEBUG
	;; Set up options: Locked switch feature and wining new interrupts.
	SYSCAL USRVAR,[CIMM %JSELF ? CIMM .ROPTION ? CIMM [TLO 0,%OPALL]]
	 .LOSE 1000
	CALL MYADDR		; Set our address(es)
	SKIPE XVERS
	 CALL XVRSRT
	CALL DATIME"UPINI	; Get the time for MLINIT.
	 CALL MTMHNG
	CALL MLINIT		; Will go to MAKMNU if we are not unique.
	CALL MCINIT		; We need area hacking, etc.
	CALL MSTGET		; Get master LSE, used to drive this stuff
	;Note that we don't enable interrupts
	.CALL [SETZ ? SIXBIT/OPEN/ ? [.UAO,,DBC] ? [SIXBIT/DSK/]
		[SIXBIT/GUBBLE/] ? SETZ [SIXBIT/>/] ]
	 .LOSE %LSSYS
	OUT(DBC,OPEN(UC$IOT))
	MOVE L,$ARLOC+MASTER
	HRRZ D,$LLLST(L)
ASCMS1:	JUMPE D,ASCMS9
	FINDA A,[A$IDAD,,[LISTAR(D)+1]]
	 .VALUE
	MOVE A,LISTAR(A)+1	;Disk address
	MOVEM D,MASTRP
	PUSH P,D
	CALL MLSGET
	 .VALUE
	MOVE L,$ARLOC+MSGAR
	SETZM DEBLEV
	MOVE A,$LLLST(L)
	CALL DEBPL
	POP P,D
	MOVE L,$ARLOC+MASTER
	HRRZ D,LISTAR(D)
	OUT(,CH(DBC),C(^L),CRLF)	; Separator between messages
	JRST ASCMS1

ASCMS9:	.CLOSE DBC,
	.VALUE

;;;;;;;;;;;;;;;;;;;;
;	Emergency re-initialization of QUEUE and REMIND!!
;	You can run this standalone by starting at the usual place
;	with a breakpoint at WAKEUP, then CALL MAKQFSX

MAKQFI:	PUSH P,A		; Entry point to completely re-initialize
	MOVEI A,QMLAR		; the QML.
	CALL LSEOPN		; Create empty QML
	POP P,A
	CAIA
MAKQFS:	 CALL QMLGET		; Don't initialize QML, use existing.
	TLNE F,%SCOPN
	 CALL SCOPN		; STATS file must be open.
	PUSHAE P,[A,B,L]
	SETOM MKQFLG'		; Flag to decrease file i/o so goes fast
	SKIPN SCHDAR+$AROPN
	 CALL SCHINI		; Need this for QUEUE-ing.
	MOVEI A,RMLAR
	CALL LSEOPN		; Same thing for
	CALL MSTGET		; Ensure MASTER loaded.
	MOVE L,$ARLOC+MASTER	; Make it current LSE
	MOVE A,$LLLST(L)	; Point to whole list as arg for MAPC
	MOVEI B,MAKQMG		; Apply this routine to each entry in MASTER.
	CALL MAPC		; Do it!
	 .VALUE			; won't ever happen, MAKQMG catches own errs.
	CALL QMLPUT		; Done, write stuff out
	CALL RMLPUT
	CALL MSTPUT
	SETZM MKQFLG
	POPAE P,[L,B,A]
	RET

MAKQMG:	PUSH P,D		;not protected by MAPC
	FINDA A,[A$ID,,[LISTAR(A)+1]]	; Find the ID for entry
	 .VALUE [ASCIZ /: MASTER bad?? No message-ID for entry! 
/]
	CALL MSGGET		; Get this message into core
	 .VALUE [ASCIZ /: Can't retrieve message MASTER claims to have!! 
/]
	PUSH P,L
	MOVE L,$ARLOC+MSGAR
	FINDA A,[A$TLST,,[$LLLST(L)]]	; Reminder?
	 JRST [	CALL QUEUE		; No, Queue all live rcpts in it!
		JRST MAKQM7]
	CALL REMIND
MAKQM7:	POP P,L
	POP P,D
	AOS (P)		; MAPC wants win return
	RET

; MSTNIL - Set MASTER LSE to nil.  Used whenever creating new MASTER.
;	Note it doesn't actually write out the LSE, use MSTPUT for that.

MSTNIL:	PUSHAE P,[A,L]
	MOVEI A,MASTER
	CALL LSEOPN		; Open a fresh LSE as new MASTER.
	MOVEI A,2
	UAREXP A,MASTER		; Expand HDR area by 2, to make sure
	MOVE L,$ARLOC+MASTER	; that there's room for storage of
	SETZM $LHMFG(L)		; <# garbage wds in MSGS file>, and
	SETZM $LHMFL(L)		; <length of MSGS file>.
	POPAE P,[L,A]
	RET

SUBTTL	RESET INITIALIZATION

;;; RESET - This can be JSRd to when COMSAT runs out of address space. 
;;; Shuts down everything and starts all over.

;;; About as subtle as a tank, we just close everything down and reload
;;; from well-known filename.  Since this is essentially a controlled
;;; crash, it ought to be safe from just about any point in the code.
;;; If this still doens't work right, we can always just log out and
;;; let Puff reboot us in an hour....

LVAR 	RESET:	0 ? JRST RESET0	; Jump to pure

RESET0:	IFN 0,	JSR DEATH	;Doesn't work yet...
	TLNE F,%SCOPN
	 PSTAT (,("Note: RESET called from "),RHV(RESET),(", reloading."),EOL)
	TLZE F,%SCOPN		; Shutdown stats channel cleanly.
	 OUT(SC,CLS)
	MOVEI A,LOCK1		; Unlock switch 1 so can re-grab later.
	CALL LKFREE
	.IOPDL			; Flush the IOPDL
	REPEAT 20,[ ? .CLOSE .RPCNT, ]	; Close channels with sledgehammer.
	SYSCAL OPEN,[[.UII,,DKIC] ? [SIXBIT 'DSK'] ? [SIXBIT 'COMSAT']
			[SIXBIT 'LAUNCH'] ? [SIXBIT '.MAIL.']]
	 .LOSE %LSFIL		; Well known file, must be present
	.SUSET [.SXJNAME,,BOOTXJ]	; Barf, COMSAT BULK crock
	MOVSI 17,RSTACS		; Set up AC block
	BLT 17,17
	JRST 0			; And dispatch to it, reload or bust.

;; Stuff to load into ACs to reload self from file open on DKIC.
RSTACS:	OFFSET -.
	.CALL RSTLOD		; 0/  Load self
	 .LOSE %LSSYS		; 1/  Huh?
	.IOT DKIC,RSTSTA	; 2/  Get start address
	.CLOSE DKIC,		; 3/  Done with disk channel
	JUMPN RSTSTA,@RSTSTA	; 4/  Dispatch
	.LOSE			; 5/  Oops
RSTSTA:	0			; 6/  Filled in with start address
RSTLOD:	SETZ			; 7/  .CALL block
	SIXBIT 'LOAD'		; 10/
	MOVEI %JSELF		; 11/ Job is self
	MOVEI DKIC		; 12/ Shiny new disk channel
	SETZ .+1		; 13/ Address range to load
	20,,-1			; 14/ Everything but ACs
	REPEAT <17-.>,[ ? 0]	; Fill
	OFFSET 0		; End of AC block.

;; This stuff dates from CStacy, I think, and has never been used.
;; It was a nice try, though....
IFN 0,[
	TLNE F,%SCOPN
	 PSTAT (,(" ==="),RABR,(" RESET FROM "),RHV(RESET),LABR,("==="),EOL)
	SKIPE DEBUG		; If debugging just die.
	 JSR DEATHV
	TLZE F,%SCOPN		; Shutdown stats channel.
	 OUT(SC,CLS)
	.CLOSE LSR1C,		; Shutdown other I/O channels.
	.close lockch,
	.CLOSE DKIC,
	.CLOSE DKOC,
	.CLOSE NETD,
	.CLOSE NETI,
	.CLOSE NETO,
	MOVSI C,-NAREAS		; Shutdown all dynamic areas.
RESET1:	MOVE B,ARPTBL(C)
	UARCLS (B)
	AOBJN C,RESET1
	MOVEI B,SCHDAR		; Even zap the scheduler list!
	UARCLS (B)
	MOVE P,[-PDLLEN,,PDL]	; Reset PDL.
	SETZB F,MF		; Clear all flags
	.CORE LCKPAG+1		; Flush all dynamic and system core.
	 JSR DEATHV		; Leaves the locks intact!
	SETZM LSRTNS"LSRADR
	MOVEI A,400
	MOVEM A,LSYSPG
	SETZM SYSFPG
	SETZM FSYSWD
	SETZM NQMFWR
	SETZM FFPAG
	SETZM MAPPNT
	SETZM ARPAGS
	CALL SCOPN		; Reopen for business.
	OUT(SC,EOL)
	STAT (,("RESTARTING!  THE DATE IS "),TIM(F1),("
	BOOSTER WAS: "),6F(PRGNAM),(" #"),6F(VERSHN),EOL)
	CALL MCINIT		; Map core.
	SETOM GCQFLG		; Say GC when convenient.
	CALL SCHINI		; Init scheduler list.
	CALL SCHREM		; Init reminder list.
	CALL SCHNTA		; Schedule net sites on QML.
	JRST WAKEUP		; Go wakeup!
];0


SUBTTL INIT$G - NORMAL STARTUP INITIALIZATION

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;							;;;;;;;;
;;;;;;;;		STARTUP INITIALIZATION			;;;;;;;;


	; First, enable bad-condition interrupts as fast as possible.
INIT:	MOVE P,[-PDLLEN,,PDL]		; Set up PDL
	SETZB F,MF			; Clear all flags
	MOVE A,[-6,,[
		.ROPTION ? TLO 0,%OPALL	; Use new mode ints & lock hacking.
		.RMASK ? IOR 0,[%BADPI]	; Specify interruptable bad conditions,
		.RPICLR ? MOVE 0,[-1]]]	; and enable them.
	SYSCAL USRVAR,[CIMM %JSELF ? A]
	 JSR SYSLOS		; ??
	CALL MYADDR		; Set our address(es)
	CALL BULKCK		; Figure out if we are the bulk mailer
	SKIPE XVERS		; New or experimental version?
	 CALL XVRSRT		; If so, change various parameters before touching files
	SKIPN PURESW		; And now, make sure
	 CALL IPURIF		; that pages are pure!
	CALL DATIME"UPINI	; Now initialize time routines for MLINIT.
	 CALL MTMHNG		;   If can't get, hang waiting for time!!
	CALL MLINIT		; Now ensure uniqueness!

	; OK, this process is unique -  now committed to coming up!
	; Decide whether need to disown self or not.
	SKIPE DEBUG		; If debugging,
	 JRST INIT10		; don't disown.
	.SUSET [.RINTB,,A]	; See if we are top-level
	JUMPL A,INIT10		; If so, no need to disown!
	.SUSET [.ROPTION,,A]	; If not top-level, see if superior is DDT.
	TLNE A,%OPDDT		; Skip if superior not DDT.
	 .VALUE [ASCIZ /
5: Launched!  T plus 1 msec 
/]				; Disown as top-level demon.

	; Now assume we're disowned... open stats and print
	; startup message.
INIT10:	CALL SCOPN		; Initialize SC statistics channel.
	.SUSET [.RUNAM,,A]	; Get UNAME (here same as uname of creator)
	.SUSET [.RJNAM,,B]	; and JNAME
	OUT(SC,EOL)
	STAT (,("POWERING UP!  THE DATE IS "),TIM(F1),("
	BOOSTED BY "),6F(PRGNAM),(" #"),6F(VERSHN),(" LAUNCHED BY "),6F(A),(" AS "),6F(B),EOL)

	; OK, can now run assured that any lossage from this
	; point on will be recorded in stats file!
	CALL MCINIT		; Initialize core mappage and management.
	CALL MTINIT		; Check out time to ensure correct!
	CALL SUNAME		; Now that core is mapped, set name.

	; Initialize files if necessary, to recover from possible crash
	; during GC'ing of MSGS.
	CALL MGCFIX		; Fix whatever.
	SETOM GCQFLG		; Garbage collect the queues when convenient

	; Must initialize Schedule List.  This implies setting up
	; initial requests for any reminders or network sites which
	; are queued.
	CALL SCHINI		; Create initial schedule list.
	CALL SCHREM		; Find first reminder time due and schedule it.
	CALL SCHNTA		; Find and schedule delivery sites.

	; All done with initialization!  Now proceed as if waking up from
	; sleep...
	JRST WAKEUP

SUBTTL INIT - Time checking

;;; The following performs follow-up checking on system time, after
;;; DATIME"UPINI has been called.  Attempts to perform an error check -
;;; This can be done in 2 ways:
;;;	[1] Compare given time with other network sites.
;;;	[2] Compare given time with last reference date of a file.
;;; First we try [1].  If more agree than disagree, return quietly.
;;; Else if more disagree, attempt to get a human to fix it, and halt.
;;; If there is a tie (which happens when all hosts are down, also)
;;; then use [2] as a tiebreaker.

;;; This code is a bad idea.  ALAN, JTW, & SRA, 21 March 86.

MTINIT:	IFE 0,RET		; Code loses, disable it.
.ELSE {				; For posterity...
	PUSHAE P,[A,B,C,D]
	SETOM MTINIF'		; Set no call for assistance yet flag
MTINI0:	SETZ D,			; Clear match-mismatch counter
	MOVSI B,-NTMSIT		; Loop thru time-site table
MTINI3:	MOVE A,MTMSTB(B)
	CAMN A,OWNHST		; Don't do own site.
	 JRST MTINI5
	CALL NETIM		; Find time at that site.
	 JRST MTINI5		; Site down or can't get.
	MOVE C,A
	CALL DATIME"TIMGTN	; Get net-style time here.
	 JSR AUTPSY
	SUB A,C			; Find difference in time.
	MOVMS A			; Get magnitude
	CAMLE A,MTOKDF		; Compare with allowable difference.
	 AOSA D			; Ugh, bad!  mark 1 mismatch.
	  ADD D,[1,,0]		; Aha, mark 1 match.
MTINI5:	AOBJN B,MTINI3

	; Now compare matches with mismatches.  The majority rules!
	JUMPE D,MTINI9		; If neither match nor mismatch, try a file
	HLRZ A,D		; Get # matches in A
	CAILE A,(D)		; More matches than mismatches?
	 JRST MTINI6		; Yup, all clear!

	; Ugh, network time hacking says our time is wrong!
MTINI7:	PUSH P,A		; Save for ease in debugging
	.SUSET [.RINTB,,A]	; See if toplevel
	 JUMPL A,MTINI8		; Jump if so
	.SUSET [.ROPTION,,A]	; Not toplevel, see if under DDT
	TLNN A,%OPDDT		; Skip if under DDT.
	 JRST MTINI8		; Nope
	POP P,A
	.VALUE [ASCIZ /: System time is wrong or inaccessible!
/]
	JRST MTINI0		; If proceeded, try again.

; Time no good, and we are disowned.
; Call for help!  Maybe someone just brought the system up with
; the time wrong and is near the system console.
; Clobber instruction at MTINI8 to JSR AUTPSY if you think you
; are having problems.
MTINI8:	POP P,A			;Get back debugging info
	.OPEN TMPC,[.UAO,,'T00]
	 JRST MTIN8A
	AOSE MTINIF		;Only call for help once
	 JRST MTIN8A
	OUT(TMPC,OPEN(UC$IOT),("

"),C(7),C(7),("Hey! The time is messed up.  Fix it! (:PDSET?)
	Yr mst obdt svt,"),C(7),("
		"),6F(UNMPRF),SP,6F(JNMPRF),("
"))
MTIN8A:	.CLOSE TMPC,
	MOVEI B,30.*30.		;Wait half a minute then try again
	.SLEEP B,
	JRST MTINI0

MTINI9:	SYSCAL OPEN,[[.UAI,,NETD]	; No info from network, try a local file
		SATDEV ? STFN1 ? STFN2 ? SATDIR]
	 JRST MTINI6		; Oh well
	SYSCAL RFDATE,[CIMM NETD ? CRET A]
	 JSR SYSLOS
	.CLOSE NETD,
	CALL DATIME"TIMSEC	; Abs seconds that file last written
	MOVE C,A
	CALL DATIME"TIMGTN	; Abs seconds current time
	 JSR AUTPSY
	SUB A,C			; Number of seconds elapsed since last wrote
	JUMPL A,MTINI7		; Hmm, time must have run in reverse
	CAML A,[7*24.*60.*60.]
	 JRST MTINI7		; No mail sent for a week? I doubt it
MTINI6:	POPAE P,[D,C,B,A]	; Win.  time is satisfactory.
	RET

MTOKDF:	15.*60.		; # seconds of tolerable difference between site times.

			; Table of sites running TIMSRV's.
MTMSTB:	HN$MC			; MC
;	HN$AI			; AI
;	HN$DM			; DM
;	HN$ML			; ML
;	HN$A67			; AMES-67
;	HN$SAI			; SAIL
NTMSIT==.-MTMSTB

};.ELSE IFE 0


;;; Well known addresses.  This should be removed someday, or at least
;;; replaced with cells initialized at boot time....

DEFINE HNARP IMP,HOST
<RESOLV"NW%ARP>+<IMP>+<HOST_16.>!TERMIN
DEFINE HNCHA NUM
<RESOLV"NW%CHS>+<NUM>!TERMIN

; Arpanet is gone (well, almost gone), most of this is useless.
;HN$AI=<HNARP 6,2>
;HN$MC=<HNARP 54,3>
;HN$SAI==:<HNARP 13,0>
;HN$DM==:<HNARP 6,1>
;HN$ML==:<HNARP 6,3>
;HN$A67==:<HNARP 20,0>
;HN$MX==:<HNARP 6,1>
;HN$XX==:<HNARP 54,0>

; Let's try chaosnet addresses for the moment
HN$AI==:<HNCHA 3130>			; ITS machines
HN$MC==:<HNCHA 3131>
HN$MD==:<HNCHA 3132>
HN$ML==:<HNCHA 3133>
HN$LCS==:<HNCHA 15044>			; LCS.MIT.EDU mail relay machine

; Magic address to drop into TCPGAT if we're a chaos-only machine.
GATHST:	HN$LCS

; MTMHNG - Time Hanger... called immediately after determining that system
;	doesn't know time.  If running under DDT, will .VALUE appropriate
;	string and halt, else will attempt to wait it out.

MTMHNG:	PUSH P,A
	.SUSET [.RINTB,,A]	; See if toplevel
	JUMPL A,MTMHN5
	.SUSET [.ROPTION,,A]	; No, see if under DDT.
	TLNN A,%OPDDT		; Skip if so.
	 JRST MTMHN5
	.VALUE [ASCIZ /: System doesn't know proper time!! 
/]
	JRST .-1

	; Not under DDT, wait til we win.
MTMHN5:	CALL DATIME"UPINI
	 CAIA
	  JRST POPAJ		; Aha, have the time now!
	MOVEI A,30.*15.		; Else sleep 15 sec
	.SLEEP A,
	JRST MTMHN5		; and try again.


;;; MYADDR - Set OWNHST and OWNHS2.

MYADDR:	MOVE A,[RESOLV"NW%ARP]	; Normally use Arpanet
	CALL RESOLV"OWNHST	; Find # of host we're on
	 SETZ A,		; Don't appear to have Arpanet
	MOVEM A,OWNHST		; Store what we got
	MOVE B,GATHST		; Address of the default relay machine
;	CAME A,[HN$MX]		; Make Gumby happy by faking this for MX
	JUMPN A,.+3		; Are we on the Arpanet?
	  SKIPN HDRGAT		; No, if there isn't a patched in value
	   MOVEM B,HDRGAT	; Use the default.
	JUMPN A,.+3		; This doesn't happen for MX though
	  SKIPN TCPGAT		; Unless there's a patched in TCP relay
	   MOVEM B,TCPGAT	; Store the default relay.
	JUMPN A,.+3		; MX doesn't exist anymore anyway
	  SKIPN DOMGAT		; Unless there's a patched in domain relay
	   MOVEM B,DOMGAT	; Store the default relay.
	MOVE A,[RESOLV"NW%CHS]	; Now check Chaosnet
	CALL RESOLV"OWNHST	; Try Chaosnet now
	 SETZ A,		; No chaosnet
	SKIPN OWNHST		; No arpanet?
	 EXCH A,OWNHST		; Well, use Chaos as primary, then
	MOVEM A,OWNHS2		; Store secondary address
	SKIPN OWNHST		; No networks at all???
	 JSR AUTPSY		; Hopeless case, punt
	RET			; On Arpanet, win.


SUBTTL INIT - Memory management (allocation, mapping)

; Core in mailer satellite is arranged as follows:
; Beg of address space
;  PGM Impure
;  PGM Pure	20-some pages
;  LOCKS	1 page for lock switch vars, global impure.
;  NQMFWR	1 page mapped into sys for read access to NQMFWR variable
;  LSR1		Approx 10 pages for mapping the paged LSR1 file.
;  HOSTS3	Approx 60 (!) pages for mapping the entire HOSTS3 file.
;  FFPAG 	Freespace controlled by core manager (for areas, etc.)
;  SYSCOR	Enough core to pure-read-map into all system user-var storage.
; End of address space

BVAR
FFPAG:	0	; Number of the first truly FREE page to be given to CORSER.
MAPPNT:	0	; Argument to MAPIN.  (Core page AOBJN).
ARPAGS:	0	; Core page AOBJN defining free, dynamically useable pages.
SYSFPG:	0	; # of first page mapped into system
FSYSWD:	0	; Address of first word mapped into system (SYSFPG*2000)
LSYSPG:	400	; # of page following last sys-mapped page.
NQMFWR:	0	; Our address to access system NQMFWR at.
EVAR

; MCINIT - initializes core areas with exception of
;	locked-switch mapping.

MCINIT:	PUSHAE P,[A,B]
	CALL MAPSYS	; Get system pages mapped into high core.
	CALL MAPNQM	; Map in single page for system NQMFWR variable.
	MOVEI B,FREEPG	; Now generate a word with -<SYSFPG-FREEPG>,,FREEPG
	SUB B,SYSFPG	; as the initial "argument" to MAPIN.
	HRLZ B,B	; The real value of MAPPNT will get generated
	HRRI B,FREEPG	; later, after we know how much space they want.
	MOVEM B,MAPPNT	; Hopefully LSR1 won't grow too much
	CALL MAPIN	; during the life of the COMSAT.
	MOVEM A,FFPAG	; And this is the first page we will give to CORSER.
	SUBI A,FREEPG+1
	MOVN A,A
	HRLZ A,A
	HRRI A,FREEPG 	; Now have a "page aobjn" to  space for LSR1, HOSTS3.
	MOVEM A,MAPPNT	; Update ptr for MAPIN to use in the future.
	MOVE A,FFPAG
	SUB A,SYSFPG
	ADDI A,1
	HRLZ A,A
	HRR A,FFPAG		; Now we have a "page aobjn" to the dynamically
	MOVEM A,ARPAGS		; allocated space i.e. -<SYSFPG-FFPAG-1>,,FFPAG
	TLNE F,%SCOPN
	 PSTAT (,("Note: Dynamic freespace is: "),LHS(A),(",,"),RHV(A))
	UARINIT ARPAGS		; Initialize area UUOs and CORSER.
	MOVSI A,-NAREAS		; Make sure all ARBLKs declared closed,
	MOVE B,ARPTBL(A)	; by getting ARPT to each
	SETZM $AROPN(B)		; and zapping.
	AOBJN A,.-2
MCINI9:	POPAE P,[B,A]
	RET

	;Kludge to get maximal response to files on .mail. --  ITS has
	;variable "NQMFWR" which is aos'ed each time write files are closed on
	;.MAIL. directory.  The COMSAT maps a page into the proper area of
	;system to access this variable, and .hangs on it, so that satellite
	;is unhung and "started" as soon as something is written.

MAPNQM:	PUSHAE P,[A,B]
	MOVE A,[SQUOZE 0,NQMFWR]
	.EVAL A,		; Find location of NQMFWR in system.
	 JSR SYSLOS
	IDIVI A,2000		; Get page # in A, addr within page in B
	ADDI B,SYSWPG*2000	; Find address within own core to reference.
	SYSCAL CORBLK,[CIMM %CBRED+%CBNDR ; Must get read acc to syscor.
		CIMM %JSELF	;for us
		CIMM SYSWPG	;at spec'd page
		CIMM %JSABS	;from system (absolute),
		A]		;from specified absolute page.
	 JSR SYSLOS
	MOVEM B,NQMFWR		; Store addr to reference for NQMFWR access.
	POPAE P,[B,A]
	RET


; MAPIN - Map in the LSRTNS stuff.
;   MAPPNT/  page aobjn
; Returns in A: the number of the first page NOT used.
; LSR1C channel is left open so we can page that database.
; For historical reasons, we also set up things that used to be related
; to HOSTS3 (OWNNAM et al). 

MAPIN:	PUSHAE P,[B,D]
	MOVE D,FFPAG		; Assume free space isn't changing.
	.IOPUSH DKIC,		; Don't clobber chan.
	;; See if we need a new LSR1 database.
	SKIPN LSRTNS"LSRADR	; If LSR1 database is not mapped in
	 JRST MAPI10		;  we need to get it.
	MOVEI A,LSRFN1		; Already mapped in, but may be out of date.
	CALL OPNMFI		; Check for update notification file.
	 JRST MAPI20		;  None, so current version is fine.
MAPI10:	;; Let's just assume this works right, ok?
;	TLNE F,%SCOPN
;	 PSTAT (,("Note: Gobbling LSR1 database"))
	MOVEI A,LSR1C
	MOVE B,MAPPNT
	CALL LSRTNS"LSRMAP	; Map in LSR1 database, LSR1C remains open!
	 JSR AUTPSY
	HRRZ D,B		; New begining of free space
	ADDI D,3		; Allow some slop into which LSR1 can grow
	;; We have the latest LSR1 data, so delete the update notification.
	SYSCAL DELEWO,[%CLIMM,,DKIC]
	 NOP
MAPI20:	.CLOSE DKIC,
	PUSH P,D		; Stash # of 1st page not used up
	MOVE A,[440700,,OWNNAM]	; Get primary hostname (asciz string)
	MOVE B,OWNHST		; (Chaos and IP names are identical, by fiat)
	CALL RESOLV"HSTSRC	; Get string
	 JSR AUTPSY		;  We don't know about ourselves?
	SKIPN B,HDRGAT		; Same for gateway if present
	 JRST MAPI90		; Guess not
	MOVE A,[440700,,GATNAM]	; Is there, get its name for header munging
	CALL RESOLV"HSTSRC
	 JSR AUTPSY		; Better find it if are using it!
MAPI90:	POP P,A			; Return # of 1st page not used up.
MAPI99:	.IOPOP DKIC,		; Restore chan.
	POPAE P,[D,B]
	RET


; MAPSYS - hair which maps right section of system into our high
;	core, so that can access the user variables for all jobs, without
;	mapping in entire system.

MAPSYS:	PUSHAE P,[A,B,C,D]
	MOVE A,ITSYMC
	CALL EVALER		;evaluate constant syms
	MOVE A,ITSYML
	CALL EVALER		;and random locations
	MOVE A,ITSYMX
	CALL EVALER		;and indexable user var locations.
	.SUSET [.RUIND,,C]	;Set up MYUIND for SUNAME
	IMUL C,LUBLK
	MOVEM C,MYUIND
	MOVE C,MAXJ		;get max # jobs allowable
	IMUL C,LUBLK		;multiply by storage/luser to get # wds total storage
	ADD C,USRSTG		;add addr of first user var blk, to get highest sys addr
	MOVE A,USRHI		;now get addr of only non-user loc we must map.
	TRZ A,1777		;get addr of page containing usrhi.
	SUB C,A			;now get # wds we need mapped
	ADDI C,1777
	LSH C,-10.		;now have total # pages required, starting from (a).
	MOVEI B,400		;get total # pages avail in job
	SUB B,C			;get page # in us to start sys mapping at.
	MOVEM B,SYSFPG		;store as # of first sysmap page (400 is last+1)
	LSH B,10.		;get addr for it
	MOVEM B,FSYSWD		;also store
	SUB B,A			;find difference, <our mapping>-<its mapping>

	ADDM B,USRHI		;get our mapping for usrhi
	MOVE C,ITSYMX		;now get mappings for user vars
	HRLI B,C		;make them indexed by c!
	ADDM B,1(C)		;map
	ADDI C,1		;get next sym
	AOBJN C,.-2
	
	; a has first sys addr we want, lsyspg-sysfpg is # pages to insert at sysfpg.
	LSH A,-10.		;get system page # to start mapping at
	MOVE B,LSYSPG
	SUB B,SYSFPG		;get # pages desired
	IMUL B,[-1,,0]
	HRR B,SYSFPG		;now have -<# pgs>,,<sysfpg>
	SYSCAL CORBLK,[CIMM %CBRED+%CBNDR	;get read access, fail if can't
		CIMM %JSELF	;for us
		B		;starting at sysfpg, for n pages
		CIMM %JSABS	;from system
		A]		;at abs location in a.
	 JSR AUTPSY		;fooey?!? must be bad args.

	POPAE P,[D,C,B,A]	;whew, all done!
	RET


; XSRFND - given xuname in a, skips if hactrn exists with that xuname,
;	and returns actual uname in a.

XSRFND:	PUSHAE P,[B,C,D]
	MOVE D,XUNAME		;addr to indirect thru for xuname user var.
	JRST USRFN1		;jump into finder

; USRFND - given uname in a, skips if <uname> hactrn exists.

USRFND:	PUSHAE P,[B,C,D]
	MOVE D,UNAME		;addr to indirect thru for uname user var.
USRFN1:	MOVE B,[SIXBIT /HACTRN/] ;jname to look for
	MOVE C,@USRHI		;get current first free user-var index
USRFN2:	SUB C,LUBLK
	JUMPLE C,USRFN7		; 0 is sys job... jump if no more jobs to check
	CAME A,@D		;check uname
	 JRST USRFN2		;nope
	CAME B,@JNAME		;right uname, does he have hactrn?
	 JRST USRFN2		;nope
	MOVE A,@UNAME		;ah, won! get real uname in case xuname was checked.
	AOS -3(P)		;skipping return
USRFN7:	POPAE P,[D,C,B]
	RET



	;macro to generate table of its symbols so evaler can munch and
	;syms can then be accessed by name or indirected thru to sys core.
	;first wd of table is aobjn to rest, each sym has 1 wd for squoze repres.
	;and second labelled as that sym.
DEFINE SYMS LIST
%%S==. ? 0
IRPS SYM,,[LIST]
SQUOZE 0,/SYM/
SYM: 0
TERMIN
%%N==<.-%%S-1>/2 ; # syms
TMPLOC %%S,{ -%%N,,%%S+1 }
TERMIN

; EVALER - routine to .eval a table of its symbols
;	A has first entry of table generated by syms macro, which is aobjn ptr.

EVALER:	PUSHAE P,[A,B]
EVALR1:	MOVE B,(A)		;get squoze for symbol
	.EVAL B,		;find value
	 JSR AUTPSY		;any failures are assumed fatal.
	MOVEM B,1(A)		;store
	ADDI A,1		;increment since each sym takes 2 wds
	AOBJN A,EVALR1
	POPAE P,[B,A]
	RET

	; ITS symbols necessary for access to user variables
BVAR
ITSYMC:	SYMS [MAXJ LUBLK USRSTG] ; Constants.  MAXJ is max # jobs,
				; LUBLK length of a user var block,
				; USRSTG address of start of user var blocks.
ITSYML:	SYMS [USRHI]	; Locations.
			; USRHI is first non-existent user var block index.
ITSYMX:	SYMS [UNAME XUNAME JNAME USYSNM SUPPRO] ; User var locs, indexed into.
EVAR

; SUNAME - Come here to try to set UNAME, JNAME, and SNAME.
;	If this job is top-level, try to set UNAME to UNMPRF, and
;	JNAME to JNMPRF; SNAME is set to JNMPRF whether top-level or not.
;	Uses the fact that the user variables are mapped in to avoid doing
;	anything if the name is already OK.

SUNAME:	PUSHAE P,[A,B,C]
	MOVE C,MYUIND
	MOVE A,@USYSNM		; Get own SNAME
	CAME A,JNMPRF		; If not what we want, then
	 XCTILO [.SUSET [.SSNAME,,JNMPRF]]	; Set it.
	JFCL			; Should always win, but who knows.
	MOVE A,@UNAME		;get own UNAME
	MOVE B,@JNAME		;and own JNAME
	CAMN A,UNMPRF
	 CAME B,JNMPRF
	  SKIPL @SUPPRO
	   JRST SUNAM9		;Name OK or not top-level, exit
	.CLOSE DQCH,		;Gross kludge, make sure DQDEV has our UNAME
	.SUSET [.SXUNAME,,UNMPRF]
	.SUSET [.SHSNAME,,SATDIR]	;Make file author kludge happier
	XCTILO [.SUSET [.SUNAME,,UNMPRF]]
	 JRST SUNAM0		;Can't set UNAME
	XCTILO [.SUSET [.SJNAME,,JNMPRF]]
	 JRST SUNAM1		;Set UNAME OK but need different JNAME
SUNAM9:	POPAE P,[C,B,A]		;Set both OK, return
	RET

SUNAM0:	XCTILO [.SUSET [.SJNAME,,JNMPRF]]
	 JRST SUNAM9		;Can't set anything, try again later
	XCTILO [.SUSET [.SUNAME,,UNMPRF]]
	 JRST SUNAM1		;Try a different JNAME
	JRST SUNAM9		;winning now

SUNAM1: MOVE A,JNMPRF
	MOVSI B,770000          ;B mask for appended zero.
SUNAM3: TDNN A,B
         JRST SUNAM4
        LSH B,-6
        JUMPN B,SUNAM3
        MOVEI B,77              ;6 character name, clobber right-most
SUNAM4: ANDCM A,B               ;flush any existing digit in that place
        AND B,[010101010101]    ;multiplier for that place
        PUSH P,B
        IMULI B,'0
        ADD A,B                 ;put in a zero
        POP P,B
	MOVEI C,10.
SUNAM5:	XCTILO [.SUSET [.SJNAME,,A]]	;Try this JNAME
	 JRST [	ADD A,B ? SOJG C,SUNAM5 ? JRST SUNAM9 ] ;and successive ones
	XCTILO [.SUSET [.SUNAME,,UNMPRF]] ;Make sure UNAME is right
	 JRST @.-2		;lose, try another JNAME
	JRST SUNAM9		;win
SUBTTL INIT - Locks (establish uniqueness)

; MLINIT - initializes global-impure map for lock switches.
;  Has special function of checking the switches and dying instantly 
;  if it determines that it is a duplicate.

LVAR HAVLKS:	0	;set when page with locks is initialized and accessible
LVAR UNIQUE:	0	;set when have locked switch 1 = job is unique.
			;(others will die instantly)

MLINIT:	PUSHAE P,[A,B,C]
	SETZM UNIQUE		; Clear flag indicating whether unique
	SETZM HAVLKS		; Ditto for flag saying whether have page and locks
MLINI1:	.CALL LKFOPN		; Try to get dsk chan to lock-sw file
	 CAIA			;  If failed, skip and try to create it.
	  JRST MLINI3		; Have chan to lock-sw file... gobble locks!
	CAIE A,%ENSFL
	 JSR DEATH		; Error other than non-existent file
	.CALL LKFMAK		;  If failed, try to create
	 JSR DEATH		;   If even that fails, die instantly.
	MOVE A,[-2,,[0 ? 0]]	; Output 2 zero wds to clear LSWREQ, LSWDON.
	.IOT DKOC,A
	.CLOSE DKOC,		; Close, creating file
	.CALL LKFOPN		; Now try again to get channel.
	 JSR DEATH		; If failed after writing file....????

MLINI3:	SYSCAL CORBLK,[CIMM %CBNDW+%CBPUB ; Make public with write access.
			CIMM %JSELF	; put into self
			CIMM LCKPAG	; at page reserved for it
			CIMM DKIC]	; map from dsk file.
	 JSR DEATH			;  Ugh?????
	CALL LKINIT		; Initialize switches
	SETOM HAVLKS		; Have the page and locks!
	MOVEI A,LOCK1		; Concentrate on switch 1
	CALL LKGRAB		; Try once to gobble it
	 JRST [	SKIPE MAKING	;   Are we in the MAKMST routine?
		 JRST MAKMNU	;    Yes, if not unique yell at hacker!
		JSR DEATH]	;   Normal failure.  Die.
	SETOM UNIQUE		; Ah, we have locks and are unique, set flag.
	POPAE P,[C,B,A]		; We've gobbled it and won, stay alive and continue.
	RET

LKFOPN:	SETZ ? SIXBIT /OPEN/ ? [.BII,,DKIC] ? ['DSK,,0] ? %CLERR,,A
	LCKFN1 ? LCKFN2 ? SETZ SATDIR
LKFMAK:	SETZ ? SIXBIT /OPEN/ ? [.BIO,,DKOC] ? ['DSK,,0]
	LCKFN1 ? LCKFN2 ? SETZ SATDIR	


TMPLOC 43,{ 0 }			;pointer to locked switch list for lock hacking
TMPLOC 44,{ -LCCBLK,,CCBLK }	;aobjn ptr to critical code table for lock hacking

	; Critical code table pointed to by word 44 !

CCBLK:	LKINI2,,LKINI3		;for crashing in LKINIT
	MOVEM A,LSWREQ
	LKGRB1,,LKGRB2		;for crashing in LKGRAB
	SETOM @A
	LKFRE1,,LKFRE1+1	;for crashing in LKFREE
	SETOM @A
LCCBLK==.-CCBLK


; LKINIT - Initialize Lock Switches  (as per LOCKS documentation)

LKINIT:	PUSHAE P,[A,B]
	SYSCAL RQDATE,[CRET A ? CRET A]
	 JSR SYSLOS
	CAMN A,[-1]
	 JSR AUTPSY		; Foo? System doesn't know time... 
	MOVE B,A		; Save date/time sys started
LKINI1:	EXCH A,LSWREQ		;claim right of initializing (nop if already claimed)
LKINI2:	CAMN A,LSWREQ		;did we get it?
	JRST LKINI5		;no, check 2nd word to see if other guy fulfilled duty

	; Got access, we must initialize! LKINI2 to LKINI3-1 is critical code

	SETOM LOCK1		; Clear the lock(s)
	SETZM LOCK2		; Not really a lock... count of dead comsats.
LKINI3:	MOVEM B,LSWDON		; Indicate init done
LKINI9:	POPAE P,[B,A]
	RET

LKINI5:	CAMN B,LSWDON		;didn't get init rights, see if other finished it.
	 JRST LKINI9		;yes, nothing left to do.
	MOVEI A,30.		;no, he's still at it...hang around, he might die.
	.SLEEP A,
	MOVE A,B
	JRST LKINI1		;try to claim again.

; LKGRAB - takes A as addr of switch to swipe at; skips if
;	successfully grabbed switch for very own, doesn't skip if
;	it was locked.  tries only once!!!

LKGRAB:	AOSE (A)		;try to get it
	 RET		;lost
LKGRB1:	PUSH P,B		;got it! now put it on
	MOVE B,43		;locked switch list
	HRLI B,(SETOM)
	MOVEM B,1(A)
	MOVEM A,43
LKGRB2:	POP P,B			; LKGRB1 to LKGRB2-1 is critical code
	AOS (P)			;skip, we got it
	RET

; LKFREE - takes A as addr of switch to free.
;	(assumes that same switch is first item on locked switch list)

LKFREE:	PUSH P,B
	HRRZ B,1(A)
	MOVEM B,43	;remove from lsw list
LKFRE1:	SETOM (A)	;and unlock (LKFRE1 is critical instr.)
	POP P,B
	RET


SUBTTL EQV - File description (NAMES >)
IFN 0,[
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;;	Format of ASCII EQV file is as follows:
;;;	(see actual file for more general details...)

	A recipient spec or RSPEC in standard form is:
		(<rtyp> <rnam>  X  <attr>  <attr>  ... <attr> )
		If <rspec> is an atom, it is read as (<rspec>), which
		(see below) turns into (NAME <rspec>).
Where:
 <rtyp> - Recipient type, such as NAME, FILE, RUN, BUG.
		If <rtyp> is not a recognized type, it is interpreted
		as being the <rnam>, of type NAME.
 <rnam> - Recipient string, such as KLH, INFO-ITS, [SYS;TS FOO].
 <attr> - Attributes, each of which is parsed as:
		(ATTR AVAL)
		 Where	ATTR - Attribute name.
			AVAL - Attribute value.
		If A is an atom rather than a list, it is read as
		(ATTR).  I.e. it exists but has no value.
  X  -   Also an Attribute, but interpreted crockishly.  If
		X is a list, it is a normal Attribute;
		Otherwise if an atom, 
		1) If "@" is the first character, interpretation is (SITE X)
		2) If a number or site name, interpretation is as above.
		3) Else as for atomic <attr>.

		Equivalence entries are in the format
		(<name> <attr> ... <attr> (EQV-LIST <rspec> ... <rspec>))

 <name> - A recipient name for which the following information applies.
		Only recipients of type NAME will be matched up in
		the EQV file.
 <attr> - Attribute, exactly as described above, which applies for this name.
 <rspec> - Recipient spec to which the message should be sent, in lieu of
		the <name> itself.  To actually send to <name> there should
		either be no (EQV-LIST ... ), or <name> should be one of
		the <rspec>s within it.


THE FOLLOWING IS OUT OF DATE, AND NOT AT ALL CORRECT!!!!
		Current Internal Format:

	Each equivalence is parsed into a LLN and all the LLNs strung
together into the main list, with initial LP in $LLLST(L).  Each LLN
(of attrib A$ELST) points to a list, the first LN of which must have
attrib A$ENAM and which is followed by normal recipient-attribute LN's.
However, within these following LN's can occur those of type A$RCP, which
are LLN's pointing to a recipient list of their own.  These A$RCP's
represent the EQV-LIST for the given A$ENAM.
	Later, there will be no main list nor A$ELST LLN's.  Rather,
a sorted table will exist in the HDR area, each word representing one
equivalence and containing <LP to A$ENAM LN>,,<LP to "following LN's">.
]
SUBTTL EQVCHK - Equivalence file loading

LVAR EQVTIM:	0	;has creation time of last ascii file for which compilation attempted.

;Note that this can close all areas except SCHDAR
EQVCHK:	PUSHAE P,[A,B]
	MOVEI A,EQAFN1		; See if a new ascii file was written.
	CALL OPNMFI		; Try to open it.
	 JRST [	STAT (,("No ascii EQV file exists??"))
		JSR AUTPSY]
	SYSCAL RFDATE,[CIMM DKIC ? CRET A]	; Get creation time.
	 JSR SYSLOS
	CAMN A,EQVTIM		; Compare with time of last file gobbled
	 JRST EQVCH9		; OK, still same
	EXCH A,EQVTIM		; Not same!!! Store new, get old time.
	JUMPN A,EQVCH3		; Jump if cause is new ASCII file.
	;; Initialization, see if really need to re-compile.
	;; Get creation time for existing bin file and compare.
	.IOPUSH DKIC,		; Save chan.
	MOVEI A,EQVFN1
	CALL OPNMFI		; Open eqv bin file
	 JRST [	.IOPOP DKIC,	; If no EQV file, definitely must recompile!
		JRST EQVCH3]
	SYSCAL RFDATE,[CIMM DKIC ? CRET A]	; Get creation time.
	 JSR SYSLOS
	.IOPOP DKIC,
	CAML A,EQVTIM		; Bin created before ascii file?
	 JRST EQVCH9		; Nope, created after, win!  Needn't compile.
	;; New ASCII file has appeared, must try to compile it.
EQVCH3:	CALL EQVGOB		; Attempt compile
	 CAIA			;   Compilation lost?
	  JRST EQVCH7		; Won...
	STAT (,("Note: LOST on compilation of ascii EQV file, trying backup binary..."))
	CALL EQVBIN		; Try to get bin.
	 CAIA			; Binary lost too???
	  JRST [STAT (,("Note: Backup won."))
		JRST EQVCH7]
	STAT (,("Note: Backup failed... dying."))
	JSR AUTPSY		; Refuse to run without beloved EQV file!
EQVCH7:	STAT (,("Note: EQV file compiled."))
EQVCH9:	POPAE P,[B,A]
	.CLOSE DKIC,
	RET

;;; EQVBIN/EQVGET - Slurp binary up into core.

EQVBIN:	PUSH P,A
	MOVE A,[EQVAR,,EQVFN1]
	CALL DFGET		; Get compiled EQV data file.
	 JRST POPAJ		; Not there?
	JRST POPAJ1

EQVGET:	PUSH P,A		; Same but no erret provision
	MOVE A,[EQVAR,,EQVFN1]
	CALL DFGET
	 JSR AUTPSY
	POP P,A
	RET


SUBTTL EQVGOB - Compilation of NAMES > ascii equivalence file

	; Compile ASCII EQV file, produce "binary" LSE file.
	; Note that this can close all areas except SCHDAR
EQVGOB:	PUSHAE P,[A,B,C,D,E,L]
	CALL MAPIN		; Ensure latest HOSTS3 and LSR1 databases.
	STAT (,("Note: Compiling EQV file "))
	MOVSI C,-NAREAS		; Flush any and all areas in core.
EQVGO1:	MOVE B,ARPTBL(C)	; Get ARPT to each area in turn.
	CAIE B,SCHDAR		; Sparing only the Schedule list!
	 UARCLS (B)		;  Closeum!
	AOBJN C,EQVGO1		; Loop for all areas to flush when coring down.
	MOVE A,[IMSAR,,EQAFN1]
	CALL OPNMFI
	 JRST [	CSTAT (,("!! Couldn't open !!"))
		JRST EQVG99]	; Fail.
	SYSCAL RFNAME,[CIMM DKIC ? CRET JUNK ? CRET EQAFR1 ? CRET EQAFR2]
	 JSR SYSLOS
	SYSCAL FILLEN,[CIMM DKIC ? CRET B]
	 JSR AUTPSY
	CSTAT (,6F(EQAFR1),(" "),6F(EQAFR2),(" "),LPAR,N10(B),(" wds"),RPAR,("..."))
	CALL TXFIN		; Get ascii file

	; Do heuristics on file length to set EQV LSE initial size.
	; This minimizes thrashing caused by infinite expansions.
	MOVE C,B
	LSH C,1		; Double file length
	IDIVI C,3	; Div by 3, and
	MOVE D,C	; Use (2*len)/3 as length of SA
	LSH C,1		; and remaining 2/3 as length of LA.
	MOVEI B,[0 ? C ? D]	; Furnish these values to LSE open routine.
	MOVEI A,EQVAR
	CALL LSEOPX		; Open a fresh EQV LSE with given sizes.

	MOVE L,$ARLOC+EQVAR	; Set current LSE to EQV.
	MOVEI A,IMSAR		; Indicate input area.
	CALL RCPGOB		; Gobble them up!

	; Done compiling, now write out report file
	MOVEM A,$LLLST(L)	; store returned LP to list.
	CAIN B,0
	 UAROPN [%ARTCH+%ARTZM,,ETXTAR ? [40]]	; Open very small area for error text collection.

	OUT(TMPC,OPEN(UC$UAR,ETXTAR))
	JUMPE B,EQVG95		; Jump if no errors.
	FWRITE TMPC,[N9,B,[ Errors detected, file ],6F,EQAFR1,[ ],6F,EQAFR2,[ Rejected.
]]
	CSTAT (,N9(B),(" Errors, rejected. "))
	CALL EQRPUT
	JRST EQVG99

	; No errors.
EQVG95:	FWRITE TMPC,[[No errors detected for file ],6F,EQAFR1,[ ],6F,EQAFR2,[
]]
	CSTAT (,(" No errors. "))
	CALL EQRPUT
	MOVE A,[EQVAR,,EQVFN1]
	CALL DFPUT		;write out the LSE
	AOS -6(P)		;won, skip on return

EQVG99:	POPAE P,[L,E,D,C,B,A]	;return
	UARCLS ETXTAR		; Flush report-text area.
	UARCLS IMSAR		; Flush input-text area.
	RET

	; Write out report file.  Main hair is producing elegant FN2.
EQRPUT:	PUSH P,A
	SKIPA A,EQAFR2		; Get true FN2 of input
EQRPT2:	 LSH A,-6
	TRNN A,77		; Anything in last char position?
	 TLNN A,-1		; Or is LH gone?
	  CAIA			; Aha, ready to smash.
	   JRST EQRPT2		; Nope, go shift it.
	HRLI A,'ERR		; Make ERR the first 3 chars.
	MOVEM A,EQRFN2
	CSTAT (,("Writing report file "),6F(EQRFN1),(" "),6F(EQRFN2))
;	MOVE A,[ETXTAR,,EQRFN1]
	MOVE A,SATDEV		; Make sure we use the correct
	MOVEM A,EQRDEV		; device and directory.
	MOVE A,SATDIR
	MOVEM A,EQRDIR
	MOVEI A,EQRFIL
	MOVEI B,ETXTAR
	CALL ARDSKO
	 JSR AUTPSY
	 JSR AUTPSY
	POP P,A
	RET

SUBTTL *------------------- Mainline -----------------------*
SUBTTL Scheduler main loop

	; Come here to execute a request, so that control drops
	; back through to MAIN when done.  A has LP to entry, B has time requested.
MAINX:	MOVE C,A		; Save LP for later deletion.
	MOVE A,LISTAR(A)+1	; Get LP to list for entry.
	MOVE A,LISTAR(A)	; Skip A$STIM LN.
	MOVE B,LISTAR(A)+1	; Get A$SRTN value (addr of rtn to XCT)
	MOVE A,LISTAR(A)	; Get LP to A$SARG, and
	MOVE A,LISTAR(A)+1	; Finally have it in A!
	LNDEL C,$LLLST(L)	; Now have all info, flush request from schedule list!
	CALL (B)		; Execute request!
	TLNE F,%SCOPN		; At end of each request,
	 OUTCAL(SC,FRC)		; make sure that buffered stats are forced out.
				; Fall through when done.

MAIN:	;; First make sure the locks haven't been mysteriously unlocked
	;; so we don't get two Comsats running at the same time
	SKIPGE LOCK1
	 JRST [	STAT (,("*** LOCK1 not locked! ***"))
		JSR AUTPSY ]

	;; Next, truncate the STATS file so that Penny and Alan can
	;; get some sleep.
	TLNE F,%SCOPN		; Is it open?
	 CALL [ SYSCAL FILLEN,[CIMM SC ? CRET A]
		 JSR SYSLOS	; Yeah, get its length
		CAMG A,SCMAXL	; Current file too long?
		 RET		; It's ok, out of here
		JRST SCROPN ]	; Too long, handle it and return from there.

	;; Now see if anything immediately urgent to do.
	CALL SCHGT		; Get first request.
	JUMPL B,MAINX		; Requests with negative time are urgent!

	;; Nothing urgent to do, see if need to GC or update NAMES, etc.
	;; These things are sometimes done now to defeat infinite input
	;; requests that otherwise would never let COMSAT reach idle state.

	SOSGE EQVQCT
	 JRST [	CALL EQVCHK	; Ensure currency of NAMES equivalences.
		MOVE U1,EQVQLM	; Checked for NAMES, reset count.
		MOVEM U1,EQVQCT
		PUSH P,A
		CALL MAPIN
		POP P,A
		JRST .+1 ]

	SOSGE GCRQCT		; Bump count, and
	 JRST MAIN42		; Go directly to GC-test if must.

	;; See if there are any left-over MAILIN files around.
	;; Process these before new input requests to preserve FIFO ordering.
	CALL IRQGOT		; Try getting one, process if found.
	 CAIA			; Nope, nothing.  Just continue.
	  JRST MAIN		; Whoops, hacked one!  Return to sched loop!

	;; Are there any input requests (MAIL files)?
	CALL IRQGET		; Gobble and process if one exists.
	 CAIA			; No request files, continue.
	  JRST MAIN		; Else when done, back to schedule loop!

	;; Nothing urgent and no input requests.  Is first
	;; schedule request semi-immediate?  (Criteria is whether
	;; time specified is present or past)
	.RDTIME C,		; Get current system time
	CAMG B,C		; How does request time compare?
	 JRST MAINX		; Less than or eq to!  Must do!

	;; Nothing that scheduler has to do NOW.
	;; This is a good place to do nebbish little things,
	;; like writing cruft to the STATS file...
	SKIPG SCLCNT		; Have we written enough lines yet?
	 JRST [	MOVEI A,STTLIM			; Yep, reset the counter,
		MOVEM A,SCLCNT
		STAT (,("Date is now: "),TIM(MDYT)) ;  and put out the date.
		JRST .+1]

	;; Here, there's really nothing to do but go to sleep.
	;; B, having time of first schedule request, defines time
	;; of next necessary action.  See how far off it is...
	.RDTIME C,		; Get system time again
	MOVE A,B
	SUB A,C			; Find 30'ths til next necessary action.
	CAMG A,NAPLIM		; Sooner than limit for napping?
	 JRST MAIN60		; Yes, go directly to take short nap.

	;; Next request too far off to take nap.  So, strip down stuff,
	;; free core, close channels, GC and whatnot to prepare for
	;; long hibernation.

	;; Check to see if MSGS ought to be GC'd.
MAIN42:	PUSH P,L
	SKIPN $AROPN+MASTER	; Make sure in core
	 CALL MSTGET
	MOVE L,$ARLOC+MASTER
	MOVE A,$LHMFG(L)	; Get # wds garbage
	MOVE B,$LHMFL(L)	; And length of MSGS thus far.
	CAIG B,2000		; If garbage is 1K or less,
	 JRST MAIN46		; Don't bother.
	CAML A,B		; If garbage is .GE. length,
	 JRST MAIN45		; Then certainly GC!
	IDIV B,A		; Well, see what Length/Garbage ratio is.
	CAIGE B,4		; If smaller than 4:1, then
MAIN45:	 CALL MSGSGC		; GC the MSGS file!
MAIN46:	MOVE A,GCRQLM		; GC check done. Reset count, so that
	MOVEM A,GCRQCT		; another check guaranteed to happen somtime.
	AOSN GCQFLG		; Garbage collect queue?
	 CALL GCQ0
	POP P,L			; SCHDAR

	;; Flush all areas in core.
	MOVSI C,-NAREAS
MAIN51:	MOVE B,ARPTBL(C)	; Get ARPT to each area in turn.
	CAIE B,SCHDAR		; Sparing only the Schedule list!
	 UARCLS (B)		; Closeum!
	AOBJN C,MAIN51

	;; Cleanup done, now should check schedlist again
	;; in case something happened.
	CALL SCHGT		; Get first on list.
	.RDTIME C,
	CAMG B,C		; Compare request time with current,
	 JRST MAINX		; and jump if necessary, else fall through...

	;; Final checks before sleeping.  B has time to wake up.
MAIN60:	MOVE C,@NQMFWR		; Get current NQMFWR var.
	CALL IRQCHK
	 CAIA			; Ah, OK to sleep!
	  JRST MAIN		; Uh-oh.  Must go process input request.
	.RDTIME A,		; OK to .HANG - Now get current time,
	SUB B,A			; find # of 30'ths to sleep, and drop thru
	JUMPLE B,MAIN		; to sleep, unless must execute NOW.

	;; OK, go to sleep.  
	;; No. of 30'ths to sleep is in B, NQMFWR to test in C.
MAIN70:	TLZE F,%SCOPN		; Now close stats channel....
	 JRST [	OUT(SC,CLS)	;  If twas open
		AOJA C,.+1]	;   must AOS C since closing bumps NQMFWR.
	SETZM LSRTNS"LSRADR	; Close down LSR1, which doesn't affect NQMFWR.
	.CLOSE LSR1C,
	CAMLE B,SLPLIM		; Don't sleep longer than maximum allowed.
	 MOVE B,SLPLIM
	LSH B,1			; Turn 30'ths into 60'ths for .REALT
	.SUSET [.SAMASK,,[%PIRLT]]	; Turn off .REALT enable
	.SUSET [.SAPIRQC,,[%PIRLT]]	; And any pending ints.
	MOVE A,[600000,,B]
	.REALT A,			; Start real-time clock interrupt
	MOVEI A,WAKEUP			; Set dispatch vector for
	MOVEM A,RLTVEC			; waking up...
	.SUSET [.SIMASK,,[%PIRLT]]	; and now enable it.
MAIN80:	.SUSET [.SADF1,,[%PIRLT]]	; Clear defer bit.
	.SUSET [.SPICLR,,[-1]]		; I think something zeros this
	CALL SUNAME			; Try to keep name up to date
	CAMN C,@NQMFWR			; Until clock or file-write wakes us,
	 .HANG				; hang!

	;; If here, something was written to .MAIL. - check to see if
	;; it was a request, and if not go back to sleep.
	;; Important that this be doable without opening stats file, since
	;; otherwise parallel comsats can activate each other forever!
	.SUSET [.SIDF1,,[%PIRLT]]	; Defer alarm clock...
	MOVE C,@NQMFWR			; Get new NQMFWR value.
	CALL IRQCHK			; Anything there?
	 JRST MAIN80			; Nope, resume our peaceful snooze.

WAKEUP:	MOVE L,$ARLOC+SCHDAR		; SCHDAR is always MAIN's current LSE.
	.SUSET [.SAMASK,,[%PIRLT]]	; Stop realt's, and for PEEK's sake
	.SUSET [.SAPIRQC,,[%PIRLT]]	; also remove any pending one.
	.SUSET [.SADF1,,[%PIRLT]]	; and clear defer bit in case was set.
	MOVSI A,400000
	.REALT A,			; Clear and release the REALT clock.
	SETZM RLTVEC			; Clear RLT dispatch vector.
	SETZM SDFCNT			; Clear times-called-SDFULL.
	TLNN F,%SCOPN
	 CALL SCOPN			; Ensure sure STATS channel is open,
	CALL MAPIN		   	; Ensure latest LSR1 and HOSTS3.
	CALL EQVCHK			; Get latest NAMES too.
	MOVE U1,EQVQLM			; Checked for NAMES, reset count.
	MOVEM U1,EQVQCT
	JRST MAIN			; and go back to beg of scheduler loop.


NAPLIM:	30.*60.		; Max # of 30'ths allowed to "nap", without cleanup
SLPLIM:	30.*60.*20.	; Max # of 30'ths scheduler allowed to sleep
GCRQLM:	50.		; Max # of sched rqsts allowed between forced GC checks
LVAR	GCRQCT:	0	; Countdown for above, reset with each GC check
EQVQLM:	7.		; <ax # of sched rqsts before checking for new NAMES.
LVAR	EQVQCT:	0
SUBTTL Scheduler routines

IFN 0,[
		Scheduler description

	Entries on the Schedule List are sublists of 3 items:
A$STIM, A$SRTN, and A$SARG.  The first specifies time at which
the request is scheduled, the second specifies routine to
execute at that time, and the third provides an argument for
the routine.  Time is specified in 30'ths of a second since
system startup (what .RDTIME returns), and the routine
is specified by address (called via PUSHJ).  The argument can
be anything that fits into a word.
	Notes:
1) The items must occur on the sublist in the exact
	order specified, eg. A$STIM is always first.  This
	allows better efficiency.
2) The list is always assumed non-empty.  To achieve
	this, initialization inserts a "sink" request that
	claims to desire execution 36 years from now.
];IFN 0

; SCHINI - Initializes Schedule List.  Should be called before
;	any other schedule operations are done.

SCHINI:	PUSHAE P,[A,L]
	MOVEI A,SCHDAR
	CALL LSEOPN		; Open up a fresh LSE.
	MOVE L,$ARLOC+SCHDAR	; Make it current.
	MAKELN A,[A$SARG,,0 ? 0]
	MAKELN A,[A$SRTN,,[A]
		%LTVAL,,[[SCHBUG]]]	; In unlikely event this is ever XCT'd!
	MAKELN A,[A$STIM,,[A]		; Set requested time to max. pos #.
		%LTVAL,,[[SETZ-1]]]
	MAKELN A,[0 ? %LTLST,,[A]]	; Now put all under LLN
	MOVEM A,$LLLST(L)		; And make it first thing on schedule list.
	POPAE P,[L,A]
	RET
SCHBUG:	JSR AUTPSY		; Comes here if initial request ever XCT'd!


; SCHDIT - Takes in A, B, and C the A$STIM, A$SRTN, AND A$SARG of
;	an item to be put on the schedule list.  All 3 are taken
;	to be values.
; SCHDI - Similar but uses time c(A) from now, rather than AT c(A).
;	Schedule time units are 30'ths of sec, and 0 is time system
;	started, just as returned by .RDTIME.

SCHDIT:	PUSH P,A
	JRST SCHDI2
SCHDI:	PUSH P,A
	.RDTIME A,		; Get system time in 30'ths
	ADD A,(P)		; Get time to schedule at.
SCHDI2:	PUSHAE P,[B,C,L]
	MOVE L,$ARLOC+SCHDAR	; Set up current LSE to right one.
	MAKELN C,[A$SARG,,0	; Gobble routine argument to start list.
		%LTVAL,,[C]]
	MAKELN C,[A$SRTN,,[C]	; Push routine onto list
		%LTVAL,,[B]]
	MAKELN C,[A$STIM,,[C]	; and conclude with A$STIM as FIRST thing on list.
		%LTVAL,,[A]]
	MAKELN A,[A$S,,0 ? %LTLST,,[C]] ; And put all under a LLN.
	CALL SRTINS		; And stick entry into sorted schedule list.
	POPAE P,[L,C,B,A]
	RET


; SCHGET - Get highest priority schedule entry.  Simply gets first
;	thing on list, since it's sorted.  Returns in A the LP to entry's
;	LLN, and its A$STIM value in B.
; SCHGT - Similar but assumes current LSE is already SCHDAR.

SCHGET:	PUSH P,L
	MOVE L,$ARLOC+SCHDAR	; Make schedule list current LSE.
	CALL SCHGT
	POP P,L
	RET

SCHGT:	MOVE A,$LLLST(L)	; Get LP to first LLN.
	MOVE B,LISTAR(A)+1	; Get LP to list for entry.
	MOVE B,LISTAR(B)+1	; Get A$STIM (val of first thing on list).
	RET



; SRTINS - Insert entry on sorted list.  Auxiliary for SCHDIT, REMIND.
;	Given an LLP in A and current LSE, assumes that the LSE's list is
;	composed of entries of the format:
;		--> entry LLN --> entry LLN --> ...
;			\		\		
;			Value ->...	Value ->...
;	The LLN pointed to by A is a similar "entry".  The list must
;	be sorted by the value of the first element on the entry sublists;
;	lowest and oldest first.  This is accomplished by inserting
;	the new item immediately in front of the first greater value -
;	those of equal value are skipped over.

SRTINS:	PUSHAE P,[B,C,D]
	SKIPN B,$LLLST(L)	; Get LP to sorted list.  
	 JRST SRTIN7		; If nothing there, do special case.

	PUSH P,A
	MOVE A,LISTAR(A)+1	; Get LP to LN holding value to sort on
	MOVE A,LISTAR(A)+1	; and get value.
	SETZ C,			; Initialize "LP to LLN to insert after"
SRTIN3:	MOVE D,LISTAR(B)+1	; Loop - Get LP to VLN for this entry on list.
	CAMGE A,LISTAR(D)+1	; Compare values.
	 JRST SRTIN5		; Aha, this entry is greater - insert!
	MOVE C,B		; Not yet. Save LP to this LLN.
	HRRZ B,LISTAR(C)	; and get CDR to next.
	JUMPN B,SRTIN3		; Go process unless nothing there.

	; Found place to insert new schedule entry.  C has LP to previous LLN,
	; B has LP to current LLN, which new entry must precede.
SRTIN5:	POP P,A			; Restore LP to new entry.
	HRRM B,LISTAR(A)	; Make its CDR-> current entry.
	JUMPE C,SRTIN7		; If at beg of list, do special store.
	HRRM A,LISTAR(C)	; and make previous entry's CDR-> new entry.
	JRST SRTIN9		; Done!

SRTIN7:	HRRZM A,$LLLST(L)	; Come here if entry must be inserted as 1st item.
SRTIN9:	POPAE P,[D,C,B]
	RET


; SCHREM - Schedule Reminder.  Looks at first (earliest) reminder
;	on RMLAR and generates a schedule request to send that
;	reminder.  Does nothing if no reminders exist.

SCHREM:	PUSHAE P,[A,B,C,L]
	SKIPN $AROPN+RMLAR	; Ensure reminder list exists.
	 CALL RMLGET
	MOVE L,$ARLOC+RMLAR	; Make reminder list current.
	HRRZ A,$LLLST(L)	; Get LP to first entry.
	JUMPE A,SCHRM9		; If none, return.
	MOVE A,LISTAR(A)+1	; Get LP to entry's list.
	MOVE A,LISTAR(A)+1	; Get A$STIM for entry - internal time wd.
	CALL DATIME"UPTIME		; Convert to system time.
	MOVEI B,REMSND		; Execute REMSND rtn then.
	SETZ C,			; No argument at moment.
	CALL SCHDIT		; Schedule the request.
SCHRM9:	POPAE P,[L,C,B,A]
	RET

; SCHNTA - Schedule Network, All of.  Searches through QML list
;	and generates a schedule request for each site found.
;	Since only called on initialization, schedules to run immediately.

SCHNTA:	PUSHAE P,[A,B,L]
	SKIPN $AROPN+QMLAR	; Ensure QML there.
	 CALL QMLGET
	MOVE L,$ARLOC+QMLAR	; Make it current LSE.

	; Pluck each site # off QML and generate schreq for it.
	MOVE A,$LLLST(L)	; Get LP to first thing on QML list.
	MOVEI B,SCHNTX		; Execute this rtn for each site LLN...
	SETZ C,			; Arg for SCHNTX - schedule for NOW.
	CALL MAPC		; Munch list!
	 JSR AUTPSY		; Will never happen.
	POPAE P,[L,B,A]
	RET

; SCHNTX - Given LP in A to a QML LLN, generates schedule request for
;	connecting to that site.  B should contain time in 30'ths from now
;	to execute request.  Always skips.

SCHNTX:	PUSHAE P,[A,B,C]
	MOVE A,LISTAR(A)+1	; Get LP to site-# LN (first thing on list!)
	MOVE C,LISTAR(A)+1	; Get site # as A$SARG to sched.
	MOVE A,B		; Use given time for relative A$STIM
	MOVEI B,QUESND		; And specify standard un-queuer rtn.
	CALL SCHDI		; Schedule, using A as relative time-from-now.
	POPAE P,[C,B,A]
	AOS (P)
	RET

SUBTTL IRQCHK, IRQMRK, IRQGET - Process Input Requests.

LVAR	DIDONE:	0	;-1 iff we have processed first input request.

; IRQCHK - Checks for existence of a MAIL < input request.  If
;	one found, skips on return, otherwise no skip.  No
;	other function...

IRQCHK:	.CALL IRQOPN	; At moment, fail for any reason.
	 RET
	AOS (P)		; Win, skip return.
IRQNOP:	.CLOSE DKIC,	; Tidily flush channel.
	RET

IRQOPN:	SETZ ? SIXBIT /OPEN/ ? [.BII,,DKIC] ? SATDEV
		IRQFN1 ? IRQFN2 ? SETZ SATDIR

; IRQGET - Looks for a MAIL < input request, and processes it if one found.
; IRQGOT - Similar, but looks for an existing MAILIN > request instead.
;   Both skip unless no request existed.
;	The rename of MAIL < to MAILIN > is done for two
;	reasons: to reduce access conflicts and improve robustness.
;	Once renamed to MAILIN, it is COMSAT's property
;	and nobody can touch it;  this indicates pretty obviously
;	what it's working on at the moment.  The use of MAIL < processes
;	messages in reasonably chronological order, since they are
;	written as MAIL >.
;		However, > is used for MAILIN because
;	this helps ensure that if anything was wrong with previous MAILIN
;	(such as causing a crash), it will be processed only
;	after all existing MAIL requests are done.  Thus, a bug so horrible
;	that it doesn't even let COMSAT rename the file to BADREQ will
;	still be bypassed to some extent.

; IRQGET - Tries to gobble and process a request.
;	Tries hard to open input file, but returns if none found or
;	it gives up, without skipping.  If read in, will always
;	skip on return, regardless of processing results.
;	This is the routine that vectors off such requests.

BVAR
IRTLFG:	0		; Length of file if too long, else zero.
SPRQFG:	0		; -1 if hacking special request.
IROFIL:	BLOCK 4		; Filblk for original request filename.
EVAR

	IRQMIN==10.	;Minimum length of messages we handle (6).
IRQMLN:	IRQMIN*PG$SIZ	;This is about 50KB long. (30KB)

IF1,{
ORADIX==10
RADIX 10.
INFORM IRQMIN Input request size = ,\IRQMIN
RADIX ORADIX
};IF1

LVAR	IRQRST:	0	; -1 when this COMSAT reset for a big input request

IRQGET:	.CALL IRQOPN		; Open MAIL <
	 RET
	SYSCAL RFNAME,[CIMM DKIC ? CRET IROFIL ? CRET IROFIL+2
		CRET IROFIL+3 ? CRET IROFIL+1]
	 JRST IRQNOP
	SYSCAL RENMWO,[CIMM DKIC ? IRIFN1 ? IRIFN2]
	 JRST IRQNOP
	SETZM IRQRST		; Not looping on "too big" on a new request
	STAT (,("InReq: "),6F(IROFIL+3),(" "),RABR,(" "))
	PUSH P,A
	JRST IRQG05		; Go process the file.

IRQGOT:	PUSH P,A
	MOVEI A,IRIFN1		; Point to filblk to try opening.
	CALL OPNMFI		; Open, trying hard.
	 JRST POPAJ		; Couldn't open it?  Failure return.
	SETOM IRQRST		; Don't allow "too big" oldreq (don't loop)
	STAT (,("OldReq: "))	; Open!  Drop thru to do rest.

	; Common entry for IRQGET and IRQGOT; DKIC is open for
	; file to be processed.
IRQG05:	AOS -1(P)		; Now committed to skipping...
	PUSHAE P,[B,C,D,L]
	SETZM IRTLFG		; Clear flags
	SETZM SPRQFG
	MOVEI A,IRRFIL		; Point to "real" filename block.
	SYSCAL RFNAME,[CIMM DKIC	; Find true filename.
		CRET (A) ? CRET 2(A)
		CRET 3(A) ? CRET 1(A)]
	 JSR SYSLOS
	CSTAT (,6F(3(A)),("; "))		; Say which MAILIN it is.
	SYSCAL RFDATE,[CIMM DKIC ? CRET C]	; Get creation time of request
	 JSR SYSLOS
	SYSCAL FILLEN,[CIMM DKIC ? CRET B]
	 JSR SYSLOS		; Now check its length...
	SKIPG B			; Zero length file?
	 JRST [	STAT (,("Note: InReq file of zero length - ignoring."))
		JRST IRQG85 ]	; Just flush it quietly.
	MOVEI A,MSGAR		; OK, will need LSE for sure...
	CALL LSEOPN		; Open a fresh one as the current MSG-LSE.
	MOVE L,$ARLOC+MSGAR	; Make it current LSE.
	CAIGE B,PG$SIZ*2.	; Always attempt to process messages
	 JRST IRQG10		; which are around 10K characters long.
	MOVE U1,B		; Let's see if this sucker might fit.
	CALL EQVLEN		; EQV file may be read into core soon.
	ADD U1,U2		; Add it in it's approx len.
	CALL PSRP		; Is this frob going to fit?
	 CAIA
	  JRST IRQG10
	MOVEM B,IRTLFG		;  Nope, indicate too-long request.
	MOVE A,B		;  Get # blocks in A, # remaining wds in B.
	IDIVI A,PG$SIZ
	STAT (,("Note: Inreq file too big! Length="),N9(A),("+"),N9(B))
	MOVE B,IRTLFG
	CAMGE B,IRQMLN		; Is this a reasonable request?
	 JRST [	AOSN IRQRST	;  Yes, but if we already lost once
		 JRST IRQG06	;   don't keep trying forever.
		SETOM IRQRST
		JSR RESET ]	; Try REAL hard for this request!!
	;; Input request seems unreasonable...flush it.
IRQG06:	SETZM IRQRST		; Reset the reset flag.
	HRLZI A,IMSAR		; Specify area to read into.
	MOVEI B,PG$SIZ		; Just a page's worth.
	CALL TXFINL		; Read in the file, using limit in B.
	MOVEI A,IMSAR		; Indicate which area holds input.
	CALL SPCFND		; Parse request into current LSE!
	 NOP			;  Ignore any errors.
	MOVE A,[ASCNT [Request too large.]]
	JRST IRQG49 		; Now go send error receipt.


	;; Message will fit, so let's get it into the database.
IRQG10:	.RYEAR U1,
	TRZ C,DATIME"TM%DST	; Assume Standard Time in effect.
	TLNN U1,100000		; Now if Daylight Savings in effect,
	 TRO C,DATIME"TM%DST	;   set flag.
	MAKELN A,[A$TIM,,0 ? %LTVAL,,[C]]	
	MOVEM A,$LLLST(L)	; Time message file created is first LN!
	HRLZI A,IMSAR		; Specify area to read into.
	CALL TXFIN		; Read in the file, using limit in B.
	MOVEI A,IMSAR		; Indicate which area holds input.
	CALL SPCFND		; Parse request from there into current LSE!
	 JRST IRQG50		; Error in specs?  go handle
	FINDA C,[A$SNM,,[$LLLST(L)]]	; Should have found sender name.
	 CAIA
	  JRST IRQG25
	FINDA C,[A$CSN,,[$LLLST(L)]]	; Else had better be claimed-from.
	 JRST [	STAT (,("Note: No sender for request!"))
		JRST IRQG80 ]		;    Else cant report errors!
	MOVEI A,A$SNM			; Only claimed-from exists.
	DPB A,[$LAFLD,,LISTAR(C)]	; Turn it into A$SNM.

	; Now have msg-attrib list in MSG-LSE.  Check to ensure that
	; it's a message, rather than a special request.
IRQG25:	FINDA A,[A$PREQ,,[$LLLST(L)]]	; Does list have special-req attrib?
	 JRST IRQG30			; Nope, treat as normal message.
	SETOM SPRQFG		; Yes!  Set flag, drop through.

	; Input request is not a MAIL-style message, but rather a special
	; processing request!
	CALL SPRXCT		; Execute the request.
	 JRST [	JUMPN A,IRQG50		; non-skip signals error, save request.
		JRST IRQG80]		; Just rename if no err msg.
	JUMPE A,IRQG85		; Successful return, jump if no message.
	JRST IRQG35		; Message, go process it!
				; Guaranteed to have rcpt, txt, sender.

	; Not a Special Request; just plain vanilla mail.
IRQG30:	FINDA A,[A$RCP,,[$LLLST(L)]]	; Were any rcpts found?
	 JRST [	MOVE A,[ASCNT [At least one recipient must be specified!  None were seen.]]
		JRST IRQG49]
	FINDA A,[A$MTXT,,[$LLLST(L)]]	; Message text?
	 JRST [	MOVE A,[ASCNT [Message text must be specified! None was seen.]]
		JRST IRQG49]

	;; Normal message has been read into MSG-LSE.  Now assign it an ID...
IRQG35:	CALL IDSET		; Cons up an ID and stick onto list.
	;; Now all ready to mail or queue!
	FINDA B,[A$TLST,,[$LLLST(L)]]
	 CAIA			; Is it a reminder?
IFN 0,	  JRST [CALL REMIND	;  Yep! Go queue in RML.
IFN 0,		JRST IRQG85]	;  and flush disk request.
	  JRST [MOVE A,[ASCNT [Reminders do not work, please don't try them.]]
		JRST IRQG49]	; In fact they blow COMSAT away.
	;; Mail it!
	PUSH P,MF
	SETZ MF,		; Completely normal message.
	CALL MAIL		; This does any queueing & updating necessary
	 NOP
	SETOM DIDONE
	POP P,MF
	JRST IRQG85		; Through with request, flush from disk.


	;; Rename bad input file.
IRQG80:	STAT (,("Note: Renaming bad input file to "))
	SYSCAL RENAME,[SATDEV ? IRRFN1 ? IRRFN2 ? SATDIR
		IREFN1 ? IREFN2]
	 JRST [	CSTAT (,("<Couldn't???>"))
		JRST IRQG90]
	MOVEI A,IREFN1
	CALL OPNMFI
	 JRST [	CSTAT (,("<Can't re-open??>"))
		JRST IRQG90]
	SYSCAL RFNAME,[CIMM DKIC ? CRET A ? CRET A ? CRET B]
	 JSR SYSLOS
	CSTAT (,6F(A),(" "),6F(B))
	.CLOSE DKIC,
	JRST IRQG90

	;; Through with input request, delete it from dsk!
IRQG85:	MOVEI A,IRRFIL
	SYSCAL DELETE,[(A) ? 2(A) ? 3(A) ? 1(A) ? CERR B]
	 JRST [	CAIE B,4	; If lost, make sure it's because 
		 JSR AUTPSY	; file was already gone.
		JRST .+1]
	JRST IRQG90		; Return.

IRQG90:	UARCLS IMSAR
	POPAE P,[L,D,C,B,A]
	RET

	; Here when request error discovered.  Try to return msg to sender
	; if any exists, as well as to comsat wizard for inspection.
	; A contains SLP to error string.
	; Unresolved question: when to report BADREQ file name?  How?
	; Should file (esp too-large) be moved to sender's dir?

IRQG49:	MAKELN A,[0 ? %LTSTR,,[A]]	; Entry pt to use ASCNT err string.
IRQG50:	STAT (,("Note: Error during parse of input request."))
	MOVE C,L		; Save current LSE
	MOVE B,A		; and save err-msg SLP.
	MOVEI A,EMSGAR
	CALL LSEOPN		; Open error-message LSE
	MOVE L,$ARLOC+EMSGAR	; Make it current LSE.
	OUT(TMPC,OPEN(UC$SAO),("Error in input request file."),EOL)
	OUT(TMPC,SL(B,C))	; Note SLN is in previous LSE!
	OUT(TMPC,EOL,("Message not sent and not queued;"))
	SKIPN IRTLFG		; Include failed msg in receipt if possible.
	 JRST [	OUT(TMPC,("text of bad file follows:"),EOL,("--------"))
		OUT(TMPC,EOL,TA(IMSAR))
		JRST IRQG56 ]
	PUSHAE P,[D,E]		; Failed msg was too big.
	MOVE D,IRTLFG		; Get msg length in words.
	IMULI D,5		; Cvt to chars.
	IDIVI D,PG$SIZ		; Cvt approximate KB.
	OUT(TMPC,SP,D(D),(" Kbytes is far too large for me."),EOL,("Please use the FTP program to transfer huge files around the network."),EOL)
	POPAE P,[E,D]
IRQG56:	MAKELN B,[A$MTXT,,0 ? %LTSAO,,0] ; Hack up msg-txt LN in B
	EXCH L,C		; Restore previous L
	CALL SNMRCP		; Cons up a rcpt from sender-name, return in A.
	 JRST IRQG59		; Couldn't find sender?  sigh, just rename.
	EXCH L,C
	LNCOPY A,[C ? A]	; Copy it into this LSE.
	HRRM B,LISTAR(A)	; Make existing list the CDR of new LN.
	MOVEM A,$LLLST(L)	; Store ptr to consed-up list.
	STAT (,("	Input-request error, msg sent:"))
	PUSH P,MF
	MOVEI MF,M%CORG+M%EMSG+M%ERR	; Say comsat-originated, EMSGAR, CC.
	CALL MAIL			; Send it!
	 NOP
	POP P,MF
	MOVE L,C		; Restore original LSE.
IRQG59:	UARCLS EMSGAR
	JRST IRQG80		; Return, renaming file.

; IDSET - Obtains an ID string and puts it on list of current LSE.
;	$LLLST(L) will thus contain LP pointing at it.

IDSET:	PUSH P,A
	CALL IDGET
	HRL A,$LLLST(L)		; Get LP to current list
	HLRM A,LISTAR(A)	; Make it CDR of the A$ID LN
	HRRZM A,$LLLST(L)	; and make A$ID LN the start of list.
	POP P,A
	RET

; IDGET - Obtains an ID string for message, guaranteed to be unique
;	for that particular message.  Returns LP to the SLN in A.
;	Expects current message LSE in L.

IDGET:	PUSH P,B
	MOVEI A,IDFN1
	CALL OPNMFI		; Open highest ID file.
	 JSR AUTPSY
	SYSCAL RFNAME,[CIMM DKIC ? CRET IDRFIL ; Find real name of ID file.
		CRET IDRFIL+2 ? CRET IDRFIL+3 ? CRET IDRFIL+1]
	 JSR SYSLOS
	.CLOSE DKIC,
	MOVEI B,IDRFIL		; Rename file B (real) to file A ( > )
	SYSCAL RENAME,[(B) ? 2(B) ? 3(B) ? 1(B) ; Existing file
			(A) ? 1(A)		; To next higher file
			CERR A]		; With provision for non-existence.
	 JRST [	CAIN A,4		; Error, File not found?
		 JRST IDGET		; Yes, repeat process.
		JSR AUTPSY]		; Foo.
	MOVE A,IDRFIL+3			; Aha, rename won.  Get old real FN2.

	; Now have unique ID number for this system.  Add site name string
	; and a few other things to ensure net-wide uniqueness.

	OUT(TMPC,OPEN(UC$SAO))
	OUT(TMPC,LABR,6F(A),("."),TIM(YMD))
	SKIPE XVERS			; If not normal COMSAT, add more junk.
	 OUTCAL(TMPC,("*"),6F(JNMPRF),("*"))
	FINDA B,[A$NMH,,[$LLLST(L)]]	; If message is not from outside
	 JRST [	FINDA B,[A$SNM,,[$LLLST(L)]]	;  Even hairier ID string
		 CAIA				;  since we may output it.
		  OUTCAL(TMPC,("."),TLS(B))	;  ID includes sender name.
		JRST .+1 ]
	OUT(TMPC,C(100),TZ(OWNNAM),RABR)
	MAKELN A,[A$ID,,0 ? %LTSAO,,]
	CSTAT (,(" ID="),TLS(A),(" "))
	POP P,B
	RET	


LVAR	IDRFIL:	BLOCK 4

	CONSTANTS	; Someplace in the middle, to avoid midas gronkage.



SUBTTL *------------ Parsing -------------*
SUBTTL Parser for input request files (MAIL <'s)

; SPCFND - This is the top level parser for input request files.
;	It takes in A the ARPT of an area which contains the text of the
;	file in standard IRQ format, and it conses up the results
;	onto the front of the current LSE.
;		It skips if the parsing worked.  At the moment, no error
;	message is returned; any errors are sent to the STATS file.

BVAR
ATRLEN:	0	;holds length of attrib last found
MXATRL==24.	;max. attribute-name length in chars

ATRBUF:	BLOCK <MXATRL+4>/5	;holds attrib name last found

IPLNPT:	0	;holds ptr (temp) for IPLING
IPLNCH:	0	;holds count of chars left in ims area (also for IPLING)
IPLAST:	0	;holds ptr to start of last line parsed
IPLTCH:	0	;holds char count for ditto
EVAR
.SCALAR	 OFRMFG	; Crock to help track down obsolete FROM's.

SPCFND:	PUSHAE P,[B,C,D,E]
	CSTAT (,(" SPECS:"))
	MOVE E,A		; Set up index to input area
	SETZM OFRMFG		; Crock to help remove other crocks.
	SETZM CNFALL		; Zero crocks to decide which confirm option
	SETZM CNFERR		; (if any) to use.
	SETZM RCPNUM		; Initialize rcp vars
	SETZM RRCPS
	HRLZI A,440700		; Set up initial relative ptr into input area
	MOVEM A,IPLNPT		; Initialize for IPLING.
	HRR A,$ARLOC(E)		; Make abs.
	PTRDIF A,$ARWPT(E)	; Get total chars in IMS area
	MOVEM A,IPLNCH		; and initialize for IPLING.

SPCF10:	CALL IPATTR		; Get an attrib and its argument
	 JRST [	JUMPG A,SPCF60	;  If err message, handle error.
		JRST SPCF20]	;  Else simply EOF...

	; Found attrib;
	; A = # chars in text of argument,
	; B = index to attrib in table,
	; $ARRPT(E) = BP to start of argument text.
	CAIGE B,ATRTAS-ATRTAB	; Remove leading spaces for this item?
	 JRST SPCF15		; No, forget it.
	JUMPE A,SPCF15		; If no chars, all done.
SPCF14:	ILDB C,$ARRPT(E)	; Get character.
	CAIN C,40		; Is it a space?
	 SOJG A,SPCF14		; Yes, count it and loop.
	D7BPT $ARRPT(E)		; Either it isn't or we ran out.  Put it back.
SPCF15:	HRRZ B,ATRTAB(B)
	CALL (B)		; Do attribute's routine.
	 JRST SPCF60		; Ugh, error in attrib routine.
	JUMPE A,SPCF10		; If rtn returned nothing, that's ok.
	LNAPP [A ? $LLLST(L)]	; Add to main list with append,
	MOVEM A,$LLLST(L)	; because rtn may have returned a list!
	JRST SPCF10		; Attrib done, get another.

	; All done, do a few checks before returning.
SPCF20:	SETZ A,			; Stick in appropriate confirm option
	SKIPE CNFERR
	 MOVE A,[LITSTR [FAIL]]
	SKIPE CNFALL		; if any is indicated.
	 MOVE A,[LITSTR [ALL]]
	JUMPE A,SPCF21		; Win return.
	MAKELN A,[A$CNF,,[$LLLST(L)]
		%LTSTR,,A]
	MOVEM A,$LLLST(L)
SPCF21:	CALL SPCF66		;Figure out who it's from
	JRST SPCF80		;Take win return

SPCF60:	CAIN A,
	 MAKELN A,[0 ? %LTSTR,,[LITSTR [Random lossage.]]]
	STAT (,("Parsing aborted: "),C(42),TLS(A),C(42))	; Error in attrib processing.
	MOVE B,IPLAST
	ADD B,$ARLOC+IMSAR	; Get abs. ptr to bad line.
	OUT(TMPC,OPEN(UC$SAO),("Parsing error: "),SL(A),EOL)
	OUT(TMPC,("Line stopped at is:"),EOL,S(IPLTCH,B))
	MAKELN A,[0 ? %LTSAO,,]
	PUSH P,A
	CALL SPCF66		;Try to figure out who it's from, if possible
	POP P,A
	CAIA
SPCF80:	 AOS -4(P)
	POPAE P,[E,D,C,B]
	RET

SPCF66:	FINDA C,[A$NMH,,[$LLLST(L)]]	;Network mail?
	 RET
	CALL HPARSE		;Yes, try to parse header
	 JRST SPCF67		;Can't, pretend came from "NET-ORIGIN"
	FINDA C,[A$SNM,,[$LLLST(L)]]
	 JSR AUTPSY
	FINDA B,[A$SNH,,[$LLLST(L)]]
	 JSR AUTPSY
	CSTAT (,LBRC,("HDR-FROM:"),TLS(C),("@"),HST(LISTAR(B)+1),RBRC)
	RET

SPCF67:	MAKELN A,[A$SNM,,[$LLLST(L)]	;Cannot parse header, fake sender name.
		  %LTSTR,,[LITSTR [NET-ORIGIN]]]
	MOVEM A,$LLLST(L)
	RET

;  IPATID - Input attribute identification... uses ATRLEN and
;	ATRBUF, returns index in B to matching entry in attribute table.

.SCALAR COMPT1,COMPT2

IPATID:	PUSHAE P,[A,C,D]
	MOVEI B,NIATTR-1	;Get index to last entry
IPAID1:	HLRZ C,ATRTAB(B)	;Get addr--> cnt,, [ptr]
	HLRZ D,(C)		;Get char cnt of this entry
	CAMN D,ATRLEN		;If matches length of input attrib
	 JRST IPAID3		; found entry of same length!
IPAID2:	SOJG B,IPAID1		;Serial loop thru table
	STAT (,("UNKNOWN ATTR FOUND="),RABR,LBRC,TZ(ATRBUF),RBRC)
	JRST IPAID9

	;; Found same-length entry, now check text equality
IPAID3:	MOVE A,[440700,,ATRBUF]
	MOVEM A,COMPT1
	MOVE A,(C)		;Addr of text string pointed to by our table.
	HRLI A,440700
	MOVEM A,COMPT2		;Now have two ptrs set up.
IPAID4:	ILDB A,COMPT1
	CAIL A,"a		;Convert to uppercase.
	 CAILE A,"z
	  CAIA
	   SUBI A,40
	ILDB C,COMPT2		;Assume strings in ref table all uppercase.
	CAIE A,(C)		;Match?
	 JRST IPAID2		; Nope.
	SOJG D,IPAID4		;Yes, keep going.
IPAID9:	POPAE P,[D,C,A]
	;; Return # of attrib.  (always returns something, even if nil)
	RET



; LIPNUM - Takes SLP in A, tries to parse as oct or dec # & skips with
;	value in A if successful.

LIPNUM:	PUSH P,B
	MOVE B,LISTAR(A)+1	; Get SPT
	ADD B,$LSLOC(L)		; Make abs
	HLRZ A,B		; Get cnt in A, and
	HRLI B,440700		; make BP in B.
	CALL IPNUM		; Try to parse.
	 JRST POPBJ		; Foo, lost.
	JRST POPBJ1		; Won!

;  IPNUM - takes BP in B, # chars to gobble in A, and
;	tries to parse as a number (oct or dec). returns value in A,
;	doesn't skip if bad parse.  Updates BP.

IPNUM:	PUSHAE P,[C,D,E]
	SETZB C,D		;zero octal and decimal accumulators
	JUMPLE A,IPNU20		;if nothing to parse, return zero
IPNU05:	ILDB E,B		;Now flush leading whitespace.
	CAIE E,40
	 CAIN E,^I
	  CAIA
	JRST [	CAIE E,"-	; Is non-whiespace a minus sign?
		 TRZA F,%TMP	;   No, it's a digit or something.
		  TROA F,%TMP	; Yes, remember to negate.
		   JRST IPNU11	; Either way we're done with whitespace.
		JRST IPNU40]
	SOJG A,IPNU05
	JRST IPNU20		;Return zero if nothing there but whitespace.

IPNU10:	ILDB E,B		;Get ascii digit.
IPNU11:	CAIL E,"0		;Check to be sure it's a digit.
	 CAILE E,"9
	  JRST IPNU30		;Foo! Non-numeric char.
	LSH C,3			; Octal*8
	IMULI D,10.		; Decimal*10
	ADDI C,-"0(E)
	ADDI D,-"0(E)
IPNU40:	SOJG A,IPNU10
IPNU20:	MOVE A,C		;If no decimal pt, number is octal.
	JRST IPNU90		;Return.

IPNU30:	CAIE E,".		;Is non-numeric a decimal pt?
	 SOJA A,IPNU61		; No, go flush blanks/tabs
	MOVE C,D		;Ah yes, use decimal accumulator.
	SOJLE A,IPNU80		;If this was last char, we're done.
IPNU60:	ILDB E,B		;Else flush blanks/tabs.
IPNU61:	CAIE E,40
	 CAIN E,^I
	  CAIA
	   JRST IPNU70		;Foo? Can't do fractions.
	SOJG A,IPNU60
IPNU80:	MOVE A,C		;Put number into A.

IPNU90:	TRNE F,%TMP
	MOVN A,A		;Negate if minus-sign seen.
	AOS -3(P)
IPNU70:	POPAE P,[E,D,C]
	RET


; IPNUMA - Variant of IPNUM that uses $ARRPT(E).

IPNUMA:	PUSH P,B
	MOVE B,$ARRPT(E)
	CALL IPNUM
	 CAIA
	  AOS -1(P)
	MOVEM B,$ARRPT(E)	; Restore updated BP.
	POP P,B
	RET

; NUMCVT - Takes SP in A to a numerical string, returns value in A.

NUMCVT:	PUSH P,B
	MOVE A,LISTAR(A)+1	;get SPT
	HRRZ B,A		; Get SA address, and
	ADD B,$LSLOC(L)		; make absolute
	HRLI B,440700		; BP.
	HLRZ A,A		;cnt
	CALL IPNUM
	 SKIPA		
	  AOS -1(P)
	POP P,B
	RET


;  IPATTR - looks for attribute name and argument, using IPLING for input.
; Win return skips:
;	A = # chars in argument
;	B = index to attribute in table (0 if couldn't identify)
;	$ARRPT(E)= ptr to beg of argument text
; Failure (nonskip):
;	A - if zero, means normal EOF
;	   else SLP to error message.

IPATTR:	PUSHAE P,[C,D]
	CALL IPLING		;get a line... returns in a= # chars in line
	 JRST IPAEOF		;eof, none left

	; Copy attr name into atrbuf...
	MOVEI C,MXATRL		; Max length of attrib name
	MOVE D,[440700,,ATRBUF]
IPATR1:	ILDB B,$ARRPT(E)	; Get char
	CAIE B,":
	 CAIN B,";		; Attrib names are ended by colon or semicolon.
	  JRST IPATR2		; Aha!
	SOJL C,[MOVE A,[ASCNT [Attribute too long.]]
		JRST IPAERR]
	IDPB B,D		;deposit in ATRBUF
	SOJG A,IPATR1
	MOVE A,[ASCNT [EOF before attribute finished.]]
	JRST IPAERR

	; Found an attribute name.
IPATR2:	SUBI C,MXATRL		; Find -#chars in name
	MOVNM C,ATRLEN		; Store #
	PUSH P,B
	SETZ B,
	IDPB B,D		; Make atrbuf name ASCIZ.
	POP P,B
	SOJ A,			; Decrement # chars left on line.
	CAIE B,";		; Was terminator a semicolon?
	 JRST IPATR3		; No, a colon...rest of line is argument.

	; Semicolon arg... rest of line is char cnt, text starts on next line.
	CALL IPNUMA		; Parse number
IPATR4:	 JRST [	MOVE A,[ASCNT [Semicolon arg not numerical or otherwise bad.]]
		JRST IPAERR]
	JUMPL A,[CAME A,[-1]
		  JRST IPATR4
		MOVE A,IPLNCH	; -1 means gobble rest of world...
		JRST .+1]
	MOVE B,IPLNCH
	SUB B,A			; Subtract that many chars from rest of input
	JUMPL B,[MOVE A,[ASCNT [Semicolon arg truncated by EOF.]]
		JRST IPAERR]	; Sigh, ain't that many chars to read!
	MOVEM B,IPLNCH		; Else store decremented count
	MOVE B,IPLNPT		; Find ptr to next line
	ADD B,$ARLOC(E)		; Make abs.
	MOVEM B,$ARRPT(E)	; Stick in.
	PTSKIP A,IPLNPT		; Update ptr to first char after arg.

IPATR3:	CALL IPATID		; Identify the attribute in table.
	POPAE P,[D,C]		; Win even if not really identified.
	AOS (P)
	RET

IPAERR:	MAKELN A,[0 ? %LTSTR,,[A]]	; Error - return err message.
	CAIA
IPAEOF:	 SETZB A,IPLNCH		; EOF - indicate no more chars
	POPAE P,[D,C]
	RET



; IPLING - sets $ARRPT(E) to beg of line, returns in A = # chars in line.
;	sets IPLNPT and IPLNCH for next call; former is ptr to next line, latter is
;	total chars left in input.  to initialize, set IPLNPT=beg of input
;	(relative), IPLNCH= # chars.

IPLING: PUSHAE P,[C,D]
	MOVE C,IPLNPT		;get rel ptr to next start
	MOVE D,IPLNCH		;get # chars left from this point onward
	ADD C,$ARLOC(E)		;make ptr abs.
	MOVEM C,$ARRPT(E)	;set rartab. guaranteed to be on start of line, or end of one.
	JUMPLE D,IPLNG7		;leave here if no more input.

	;see if at end of a line; flush blank lines.
IPLNG1:	ILDB A,$ARRPT(E)	;search for next line
	CAIE A,^M
	 JRST IPLNG2
	SOJLE D,[STAT (,("FOO? NO ^J (EOF) BUT CONTINUING"))
		 JRST IPLNG7]
IPLNG5:	ILDB A,$ARRPT(E)
	CAIE A,^J		;check for next char=lf
	 JRST [STAT (,("FOO? NO ^J AFTER ^M, ASSUMED TO EXIST."))
	       JRST IPLNG2]
	SOJG D,IPLNG1		;search til find non-nil line.
	JRST IPLNG7		;eof, no more.

	;found non-nil line.  find length.
IPLNG2:	D7BPT $ARRPT(E)		;decrement ptr back to beg of line
	MOVE C,$ARRPT(E)	;put in acc.
	MOVE B,D		;save count at beg of line
IPLNG3:	ILDB A,C
	SOJLE D,[STAT (,("FOO? EOF IN MIDDLE OF LINE"))
		 JRST IPLNG7]
	CAIE A,40		;blank character?
	 CAIN A,11
	  JRST IPLNG3
	CAIE A,^M
	 JRST IPLNG4		;non-blank line, proceed
	MOVEM C,$ARRPT(E)	;Turned out to be blank line, skip it
	JRST IPLNG5

IPLNG4:	ILDB A,C
	CAIE A,^M
	 SOJG D,IPLNG4
	JUMPLE D,[STAT (,("FOO? EOF BAD, BUT CONTINUING"))
		  JRST IPLNG8]
	SUB B,D			;found EOL. get # chars in line
	SOJLE D,[STAT (,("FOO? EOF BAD, BUT CONTINUING"))
		 JRST IPLNG8]
	ILDB A,C
	CAIE A,^J
	 JRST [	STAT (,("FOO? NO ^J AFTER ^M, ASSUMED TO EXIST"))
		D7BPT C
		JRST .+2 ]
	  SOJ D,

	SUB C,$ARLOC(E)		;get relative ptr
	MOVEM C,IPLNPT		;store back for next call
IPLNG6:	MOVEM D,IPLNCH		;ditto for char cnt
	MOVE A,B		;return in a= # chars on line
	MOVEM A,IPLTCH		;store for error typeout also
	MOVE C,$ARRPT(E)
	SUB C,$ARLOC(E)
	MOVEM C,IPLAST		;ptr to last line processed, and # chars on it.
	POPAE P,[D,C]
	AOS (P)
	RET

	;graceful exit when eof found before any material.
IPLNG7:	POPAE P,[D,C]
	RET

	;exit when eof found before crlf, but material exists.
IPLNG8:	SETZ D,
	JRST IPLNG6

DEFINE INPATR *NAME*,ROUT
	[ASCNT [NAME]],,ROUT
TERMIN

	; Input attrib dispatch table.  Attrib names must be less than
	; MXATRL chars!
ATRTAB:
	INPATR ||,PARNIL		;default for unknown names. must be 1st entry.
	INPATR |SUBJECT|,PARSBJ
	INPATR |TEXT|,PARTXT
	INPATR |RCPT-LIST-NAME|,PARRLN
	INPATR |FAKE-TO|,PARRLN		; New form of RCPT-LIST-NAME.
	INPATR |FAKE-FROM|,PARFFM
	INPATR |ERRORS-TO|,PARMRP	; Another SMTP hack.
	INPATR |USER-HEADER|,PARUHD
ATRTAS:   ;;; Below here, leading spaces are NOT ignored.
	INPATR |CLAIMED-FROM|,PARCSN	;sender claims to be this instead
	INPATR |FROM|,PARSND		;message sent from this uname
	INPATR |SENT-BY|,PARSBY		; "         "    "  "  "
	INPATR |FROM-JOB|,PARFJB	; Program that sent message.
	INPATR |TO|,PARRTO
	INPATR |AUTHOR|,PARCSN
	INPATR |FROM-UNAME|,PARSBY	; New form of sent-by.
	INPATR |FROM-XUNAME|,PARNIL	; XUNAME of sending process
	INPATR |FROM-PROGRAM|,PARFJB	; Program that sent message.
	INPATR |RCPT|,PARRCP
	INPATR |NET-MAIL-FROM-HOST|,PARNTS
	INPATR |HEADER-FORCE|,PARHDF	;header force
	INPATR |REGISTERED|,PARREG	;confirmation options
	INPATR |EXPIRES|,PAREXP
	INPATR |MSG-FN1|,PARMFN
	INPATR |MSG-FN2|,PARMF2
	INPATR |ATTRIBUTE|,PARATR	; Arbitrary attribute/value pair.
	INPATR |RETURN-PATH|,PARRTP	; SMTP hack.
NIATTR==.-ATRTAB

; PARATR - Implements arbitrary attribute/value input.
;	argument must be a list, (ATTRIB ATTRIBVAL), or in ordered pairs.
PARATR:	SETOM LRDLEV		; Set reading at top-level.
	SETZM LRDLIN		; Initialize LREADR to top line.
	CALL LREADR		; Read in the structure.
	 JRST [	MOVE A,B	; Foo. return error SLN.
		RET]
	JUMPG A,APOPJ		; Later add err msgs for these too.
	JUMPE B,APOPJ
	MOVE A,B
	CALL EVALA		; "Evaluate" it...
	 JRST APOPJ		; Blew up.
	AOS (P)
	RET

; PARSTR - Common subroutine of following rtns.  Pops string into
;	a SLN with attrib type as specified in B, returns SLP in A.
PARSTR:	HRLZ A,A
	HRRI A,$ARRPT(E)	;set up ptr to string
	MAKELN A,[0 ? %LTBPT,,[A]]
	DPB B,[$LAFLD,,LISTAR(A)]
	AOS (P)			; Always wins.
	RET

; PARNIL - This routine gives unknown attribs a home.

PARNIL:	SETZ A,
	PJRST POPJ1	; Make them win for time being


; SUBJECT - parse subject line.

PARSBJ:	MOVEI B,A$SBJ
	PJRST PARSTR

; TEXT - stores text of message.

PARTXT:	CSTAT (,LBRC,("TL="),DEC(A),RBRC)
	MOVEI B,A$MTXT
	PJRST PARSTR

; Recipient List Name - String to use in header of message as substitute for
;	list of recipients.

PARRLN:	MOVEI B,A$RLN
	CALL PARSTR
	 JSR AUTPSY
	CSTAT (,LBRC,("RLN="),TLS(A),RBRC)
	AOS (P)
	RET

; Fake From - String to use in header of message as "From" line.

PARFFM:	MOVEI B,A$FFM
	CALL PARSTR
	 JSR AUTPSY
	CSTAT (,LBRC,("FAKE-FROM="),TLS(A),RBRC)
	AOS (P)
	RET


;PARHDF - parses "HEADER-FORCE:<string>"

PARHDF:	MOVEI B,A$HFRC
	CALL PARSTR
	 JSR AUTPSY
	AOS (P)
	PJRST SLNUPR	; Force to uppercase and return.

; USER-HEADER - parse user-specified header line.

PARUHD:	MOVEI B,A$UHDR
	PJRST PARSTR

; PAREXP - parses expiration date for a MSG

PAREXP:	CALL PARNUM
	JUMPG A,PARNER		; If still chars left, failed.
	CAILE B,365.
	 MOVEI B,365.		;no more than 1 year.
	ADDI B,1		;plus 1 for good measure (consider sending at 11:59 pm)
	MAKELN A,[A$XPIR,,0
		%LTVAL,,[B]]
	AOS (P)
	RET

PARNER:	MAKELN A,[0 ? %LTSTR,,[LITSTR [Bad parse of number.]]]
	RET
PARFER:	MAKELN A,[0 ? %LTSTR,,[LITSTR [Bad format.]]]
	RET

; PARMFN - parses FN1 or FN2 for a MSG

PARMFN:	SKIPA B,[A$MFN1]	; FN1 attrib
PARMF2:	 MOVEI B,A$MFN2		; FN2 attrib
	HRLZ A,A
	HRRI A,$ARRPT(E)	;set up <cnt>,,[<bp>]
	CALL CVT6PC		;cvt to 6bit
	CAIN A,0
	 JRST POPJ1		;bad arg, but will just add default later.
	MAKELN A,[0 ? %LTVAL,,[A]]
	DPB B,[$LAFLD,,LISTAR(A)]	;deposit attrib type.
	AOS (P)
	RET


; NET-MAIL-FROM-HOST - finds where net msg came from.

PARNTS:	CALL IPNUMA			; Crunch host number
	 JRST PARNER			; Blah, go return err msg.
	CALL RESOLV"STDHST		; Standardize the number.
	CSTAT (,LBRC,("NET-MAIL-FROM: "),HST(A),RBRC)
	MAKELN A,[A$NMH,,0		; Form LN to store host # in
		%LTVAL,,[A]]
	SETOM CNFERR		;confirm errors only
	AOS (P)
	RET

; PARREG - parses "REGISTERED:<char>"

PARREG:	JUMPLE A,[SETZ A, ? JRST POPJ1]		;if nothing, win anyway.
	PUSHAE P,[B,C]
PARRG2:	ILDB B,$ARRPT(E)
	CAIL B,141		; This uppercasify will suffice.
	 TRZ B,40
	CAIN B,"A
	 SETOM CNFALL		;set switch indicating "ALL" seen
	CAIN B,"F
	 SETOM CNFERR		;set switch indicating "only errors" seen
	SOJG A,PARRG2
	SETZ A,
	POPAE P,[C,B]
	AOS (P)
	RET
	
BVAR
CNFALL:	0		;when set, means "ALL" seen
CNFERR:	0		;when set, means "only errors" seen
EVAR


; PARFJB - Parses "FROM-JOB:<jname>"
;	Only function at moment is to report in stats.

PARFJB:	SETZ B,
	CALL PARSTR
	 JSR AUTPSY
	CSTAT (,LBRC,("J:"),TLS(A),RBRC)
	LNDEL A,
	SETZ A,
	PJRST POPJ1

; PARSBY - parses "SENT-BY:<uname>"

PARSBY:	MOVEI B,A$SNM
	CALL PARSTR
	 JSR AUTPSY
	CSTAT (,LBRC,TLS(A),RBRC)
	AOS (P)
	RET

; PARMRP, PARRTP - SMTP "Return-Path" values.
; A$SRTPs are real SMTP return paths from foreign hosts.
; A$SMRP is a hack to allow users to specify them for outgoing mail.

PARMRP:	SKIPA B,[A$SMRP]
PARRTP:	 MOVEI B,A$SRTP
	CALL PARSTR
	 JSR AUTPSY
	CSTAT (,LBRC,("RTP:"),TLS(A),RBRC)
	JRST POPJ1

; PARCSN - parses "CLAIMED-FROM:<name>"
; "Claimed-From" - sender claims to really be this name, rather than
;	that which "From" gives.

PARCSN:	MOVEI B,A$CSN
	CALL PARSTR
	 JSR AUTPSY
	CSTAT (,LBRC,("CLAIMS-TO-BE:"),TLS(A),RBRC)
	AOS (P)
	RET


; PARSND - parse FROM:<chars>"<sender-name>  (OBSOLETE)

PARSND:	CAIG A,1		; Must be at least 1 char (quote mark)
	 JRST PARFER		; Bad format, complain.

	CSTAT (,("<Obsolete FROM>"))	; Crock to help track down.
	SETOM OFRMFG		; Indicate obsolete FROM seen.

	PUSHAE P,[B,C,D]
	MOVE B,A		;put count into b
	MOVEM B,PRSNCT		; and save it for quote-less kludge.
	SETZ A,			;clear (holds accum. ptr)

	SETZM CNFQ
	SETZM CNFX
PARSN5:	SOJL B,PARSN3		;If never find quotemark, use whole str as name
	ILDB C,$ARRPT(E)	;get char
	CAIL C,141		; This uppercasify will suffice
	 TRZ C,40
	CAIN C,""		;quote mark=terminates options, begins name
	 JRST PARSN2		;exit option loop
	CAIE C,"N		; Requesting NET-style header?
	 CAIN C,"T		; (old way used T)
	  MAKELN A,[A$HFRC,,[A]
		%LTSTR,,[LITSTR [NET]]]
	CAIN C,"I		;requesting ITS-style header?
	 MAKELN A,[A$HFRC,,[A]
		%LTSTR,,[LITSTR [ITS]]]
	CAIN C,"R		;requesting quote of text (null header)?
	 MAKELN A,[A$HFRC,,[A]
		%LTSTR,,[LITSTR [NULL]]]

	CAIN C,"Q
	 SETOM CNFQ		;indicate Q seen
	CAIN C,"X
	 SETOM CNFX		;indicate X seen
	JRST PARSN5

	; Fond no quote-mark in arg.  Assume whole string intended.
PARSN3:	LNDEL A			; Flush any randomness mistakenly done.
	SETZM CNFQ
	SETZM CNFX
	MOVN B,PRSNCT		; get back original count (negative)
	PTSKIP B,$ARRPT(E)	; and original bp
	MOVMS B			; Now set up psitive cnt & drop thru.

	; Cons up SLN for name string.
PARSN2:	HRLZ B,B		;put char cnt in lh
	HRRI B,$ARRPT(E)	;and addr of ptr in rh
	MAKELN A,[A$SNM,,[A]	;store sender-name string
		%LTBPT,,[B]]	;note arg is byte-ptr type
	CSTAT (,LBRC,TLS(A),RBRC)

	MOVE B,CNFQ
	ADD B,CNFX
	JUMPE B,[SETOM CNFALL	;if neither option seen, confirm all.
		JRST PARSN7]
	SKIPE CNFX		;if it was X that got set,
	 SETOM CNFERR		;confirm errors only.
PARSN7:	POPAE P,[D,C,B]
	AOS (P)
	RET

.SCALAR CNFQ,CNFX,PRSNCT

.SCALAR PARFSW
.SCALAR PRCPH	; # of site
	;PRCPH is also looked at by EQRCPL due to bad modularity
	;PRCPH is also looked at by RCPHST due to bad modularity

; PARRTO - parses "TO" attribute.
; PARRCP - parses "RCPT" attribute.

PARRCP:	SETZM PRCPH
	CAIA
PARRTO:	 SETOM PRCPH
	JUMPLE A,PARFER		; Make sure something there.
	PUSHAE P,[B,C,D]
	SETZ C,
	SKIPN PRCPH		; TO, or RCPT?
	 JRST PARR40		; RCPT attrib.
	SETZM PRCPH		; TO. Clear # of site to send to

	; See what syntax we're crunching.  Can assume that leading
	; spaces already flushed.
	MOVE B,$ARRPT(E)	; Get scratch copy of BP.
	ILDB B,B		; Get 1st char.
	CAIL B,"0
	 CAILE B,"9		; See if numeric char...
	  JRST [CAIE B,"(	; If not, reading structured rcpt?
		 JRST PARR12	; No, use local host and enter mode-switch loop
		SETZ C,		; Yes, indicate no mode-switch LN's, and
		JRST PARR40]	; go hack structured rcpt.

	; Assume old style - get host #
	CALL PARNUM		; Read a number, return # in B.
	EXCH A,B
	CALL RESOLV"STDHST	; Standardize the host #
	EXCH A,B
	CAMN B,OWNHST
PARR12:	 SETZ B,		; Use 0 if local.
	MOVEM B,PRCPH

	; Enter kludgy mode-switch loop.
	SETZ C,
	SETZM PARFSW
PARR20:	ILDB B,$ARRPT(E)
	CAIN B,""
	 SOJA A,PARR3
	CAIN B,"C		;cc?
	 JRST [MAKELN C,[A$ROPT,,[C]
			%LTSTR,,[LITSTR [CC]]]
		JRST PARR25]
	CAIN B,"+
	 JRST [	MOVEI B,1
		MOVEM B,PARFSW
		JRST PARR26]
	CAIN B,"-
	 JRST [	SETOM PARFSW
		JRST PARR26]
	CAIN B,"S
	 JRST [	MAKELN C,[A$RMDS,,[C]
			%LTVAL,,[PARFSW]]
		JRST PARR25]
	CAIN B,"M
	 JRST [	MAKELN C,[A$RMDM,,[C]
			%LTVAL,,[PARFSW]]
		JRST PARR25]
	JRST PARRLS		; Error, report bad format.
PARR25:	SETZM PARFSW
PARR26:	SOJG A,PARR20

PARR3:	JUMPLE A,PARRLS		; Ran out?  Also error, bad format.

	; C must be set up with LP to any mode-switch LN's read.
PARR40:	SETOM LRDLEV		; Read at top level...
	SETZM LRDLIN		; Initialize LREADR to top line.
	CALL LREADR		; Read in a structure.
	 JRST [	MOVE A,B	; Ugh?! Return err-msg SLN.
		JRST PARR90]
	JUMPE B,PARRLS		; Error if no structure was read!
	JUMPG A,[CALL PARR50	; If anything left, look for host
		  JRST PARRLS
		 JRST .+1]
	MOVE A,B
	PUSH P,C
	MOVEI C,A$RCP
	CALL APRCPT		; Process rcpt structure.
	 JRST [POP P,C ? JRST PARR90]		; Bleah.
	POP P,C
	FINDA B,[A$RHST,,[LISTAR(A)+1]]	; Specified a host?
	 JRST [	SKIPN PRCPH		; No, was any old-style site specified?
		 JRST .+1
		MAKELN B,[A$RHST,,[LISTAR(A)+1]
			%LTVAL,,[PRCPH]]
		MOVEM B,LISTAR(A)+1
		JRST .+1]
	LNAPP [LISTAR(A)+1 ? C]
	AOS -3(P)
PARR90:	POPAE P,[D,C,B]
	RET
PARRLS:	POPAE P,[D,C,B]
	PJRST PARFER		; Return "bad format" err msg.

;Read list in B, have number of characters left in A, presuambly
;after a close parenthesis.
;Normally this is an error, but allow "@HOST" here and drop host
;into PRCPH if so.
PARR50:	PUSHAE P,[B,C,D]
	MOVE B,$ARRPT(E)
	ILDB D,B
	CAIE D,"@
	 JRST PARR59
	SUBI A,1		; A has number of chars in SITE name.
				; And B has the BP to the site name.
	CALL HMATC		; Call host-name analyze rtn
	 JRST PARR59		; Foo?  Fail.
	MOVEM A,PRCPH		; Win, save site number
	AOS -3(P)
PARR59:	POPAE P,[D,C,B]
	RET

	; Maybe someday make IPNUM general enough to 
	; flush this routine.  Could simply test for succ/fail by
	; seeing if any chars left, etc.
PARNUM:	PUSHAE P,[C,D]
	SETZB B,C
PARNM0:	JUMPLE A,PARNM9
	ILDB D,$ARRPT(E)
	CAIL D,"0
	 CAILE D,"9
	  JRST PARNM3
	LSH B,3
	IMULI C,10.
	ADDI B,-"0(D)
	ADDI C,-"0(D)
	SOJA A,PARNM0
PARNM3:	CAIN D,".	; Must cvt to decimal?
	 SKIPA B,C	; use other sum if so, and skip BP restoration.
	  D7BPT $ARRPT(E)
PARNM9:	POPAE P,[D,C]
	RET
SUBTTL RCPGOB - Ascii Rcpt-List Parser

; RCPGOB - Takes an ARPT in A, which is taken as an ascii input.
;	The input is as in the NAMES > file or inside "@FILE" files.
;	An LP to a list of A$RCP LNs is returned in A, and the number
;	of errors encountered is returned in B.  If there were any errors,
;	they were written to the ETXTAR area.
;		This calls LREADR to read the ascii, and APRCPT (which calls
;	EQRCPL to make sense out of what LREADR returns.
; RCPGBA - The same, except it takes a byte pointer in B and a character count
;	in A.  (Special entrypoint for RNETAD).

LVAR RPGERR:	0	; The number of errors so far.
LVAR RPGIBP:	0	; BP storage for special non-area reading.

RCPGBA:	PUSHAE P,[C,D,E]
	MOVEM B,RPGIBP
	MOVEI E,RPGIBP-$ARRPT
	JRST RCPGB0
RCPGOB:	PUSHAE P,[C,D,E]
	MOVE E,A		; E = ARPT to input area.
	MOVE A,$ARRPT(E)
	PTRDIF A,$ARWPT(E)	;get # chars in area.
RCPGB0:	SETZ D,			; D = LP to collected rctps
	MOVEM A,IPLNCH
	SETZM LRDLIN		; zero # lines read
	SETZM RPGERR		; and # errors.
	
	; Parse lists.

RCPG10:	SETOM LRDLEV		; Set input level to top-level.
	MOVE A,IPLNCH
	CALL LREADR		; Read in a list-structure or atom.  A has # chs left.
	 JRST RCPG50		; Failed due to some lossage. B has SP to errmsg.
	JUMPE B,RCPG90		; Done when returned LP is 0.
	MOVEM A,IPLNCH		; Save current char cntdown.
	SETZM PRCPH		; Always local host!
	MOVE A,B		; Put LP in A.
	MOVEI C,A$RCP		; Attrib type to use in C.
	CALL APRCPT		; Crunch as if rcpt spec. (returns LP in A)
	 JRST RCPG60		; Foo?
	HRRM D,LISTAR(A)	; Point its CDR at current list of rcpts
	MOVE D,A		; and now current list points to it!
	JRST RCPG10		;loop

	; Error during parse of a list.
RCPG50:	MOVEM A,IPLNCH
	AOS C,RPGERR		; Increment count of errs.
	CAIG C,1		; If first one,
	 UAROPN [%ARTCH+%ARTZM,,ETXTAR ? [40]]	; Open small area for error text collection.
	OUT(TMPC,OPEN(UC$UAR,ETXTAR),("  --L"),D(LRDLIN),(" Parse error: "),SL(B),EOL)
	JRST RCPG10		; Continue gobbling.

	; Error during evaluation of a list
RCPG60:	AOS C,RPGERR		; Bump cnt of errors
	CAIG C,1		; If first one,
	 UAROPN [%ARTCH+%ARTZM,,ETXTAR ? [40]]	; Open very small area for error text collection.
	OUT(TMPC,OPEN(UC$UAR,ETXTAR),("  --L"),D(LRDLIN),(" EVAL error: "),SL(A),("
    In list: "))
	MOVE B,IPLNCH		; Find # chars left
	SUB B,LRDBGL		; Subtract # chars left at time list began
	SUBI B,1		; Plus 1 to include left paren
	MOVE C,$ARRPT(E)	; to get -<length of list read>.  Then get read ptr
	PTSKIP B,C		; And adjust BP to point at beg of string,
	MOVMS B
	OUT(TMPC,S(B,C),EOL)	; Output the bad list text
	JRST RCPG10		; Now continue...

RCPG90:	MOVE A,D		; Return LP to collected list in A
	MOVE B,RPGERR		; and cnt of errors in B
	POPAE P,[E,D,C]
	RET
SUBTTL LREADR - LISP-style reader
; LREADR - LISP-style reader.  A has char count, E has ARPT to
;	area holding input text ($ARRPT is used).  S-exp is
;	read into a list structure of LLN's and SLN's; a String
;	corresponds to an atom, and a LLN IS a list.
;	Returns LP in B to resulting structure, but B = 0 if
;	input terminated and nothing was read.
;		If an error occurs, it will fail to skip, but
;	will try to set up recovery so that the next call will
;	proceed normally.  A failure message will be returned
;	in B as a LP to SLN holding message.

BVAR
LRDLEV:	0		; Holds paren level reading at.  -1 = top level.
LRDLIN:	0		; Holds line # reading at.
LRDBGL:	0		; Holds current char cnt at point list begins.
EVAR

LREADR:	JUMPLE A,LRDRZW
	TRZA F,%BRKT		;clear bracket-literal flg and skip into loop.
LRDR05:	 SOJLE A,LRDRZW		; decrement char cnt and jump if all gone.
	ILDB B,$ARRPT(E)
	CAIE B,40		; Ignore spaces
	 CAIN B,^I		; and tabs.
	  JRST LRDR05
	CAIE B,^J		; Also ignore LF's
	 CAIN B,",		; and commas.
	  JRST LRDR05
	CAIE B,^L	    	; And ignore form feeds
	 CAIN B,^K		; and vertical tabs!
	  JRST LRDR05

	CAIN B,^M		; CR's must be treated specially..
	 JRST LRDR60		; off to hack CR.
	CAIN B,";		; Also hack ";" specially, as comment.
	 JRST LRDR50
	CAIN B,"(
	 SOJA A,LRDR70		; Beginning of list!
	CAIN B,")
	 SOJA A,LRDR80		; End of list!
	CAIE B,^Q
	 CAIN B,"/		; Either ^Q or / quotes next char...
	  JRST [SOJLE A,LRDRZW
		ILDB B,$ARRPT(E)
		TRO B,200	; Quote next char, whatever it is
		JRST LRDR30]

	; Have something substantial - now process atom!  By special
	; hack, brackets will enclose an atom, including themselves!
	TRZ F,%BRKT+%LRLIT	; Clear flags...
	CAIN B,""
	 JRST [	TRO F,%LRLIT	; If beginning a literal string,
		SAOBEG TMPC,	; must start up chan this way
		JRST LRDR32]	; to avoid deposit of the ".
	CAIE B,"{		; See whether to set.
	 CAIN B,"[
	  TRO F,%BRKT+%LRLIT	; Set flag if bracket-literal.


LRDR30:	SAOBEG TMPC,		; Start up SA output channel.
LRDR31:	OUT(TMPC,C((B)))	;store char
LRDR32:	SOJLE A,LRDR38		;ran out?
	ILDB B,$ARRPT(E)	;get another
	TRNN F,%LRLIT		; Collecting literal string?
	 JRST LRDR35		; Nope...
	TRNE F,%BRKT		; Collecting a bracketed literal?
	 JRST [	CAIE B,"]	;end of bracketed literal?
		 CAIN B,"}
		  CAIA
		   JRST LRDR31	;no, gobble til find end.
		OUT(TMPC,C((B)))
		MOVEI B,40
		SOJA A,LRDR38]	;store and break. (pretend broke on 40)
	CAIE B,""
	 JRST LRDR31		; If not terminator, just gobble.
	SOJLE A,LRDR38
	ILDB B,$ARRPT(E)	; Get next char to test for another "
	CAIE B,""		; Well, is it?
	 JRST LRDR37		; Nope.  Break on this.
	JRST LRDR31		; Hmm, so it is!  Gobble that & continue.
	
LRDR35:	CAIE B,^Q
	 CAIN B,"/		;quoter?
	  JRST [MOVEI B,^Q	;yes, quoting. replace with ^Q
		TRNE F,%BRKT	;in case hacking brackets.
		 OUTCAL(TMPC,C((B)))	;since if so, store the ^Q.
		SOJLE A,LRDR38	;get quoted char.
		ILDB B,$ARRPT(E)
		JRST LRDR31]	;store it with no questions
	CAIE B,40
	 CAIN B,^I
	  JRST LRDR37		;string break.
	CAIE B,")
	 CAIN B,";
	  JRST LRDR37		;also break.
	JUMPE B,LRDR37		;Null must be a break for NETAD fields.
	CAIE B,^M
	 CAIN B,^J
	  JRST LRDR37		;and break.
	CAIE B,"(
	 CAIN B,",
	  JRST LRDR37		;and break again.
	JRST LRDR31		; Didn't break, get more chars.

	; Hit break char, atom finished! Break char in B.
LRDR37:	D7BPT $ARRPT(E)		;back up over brk char, so it gets read again
LRDR38:	MAKELN B,[0,,0
		%LTSAO,,0]	;and make string LN for it
	JRST LRDRW		;and win.


	; ";" found, flush to CR.
LRDR50:	SOJLE A,LRDRZW
	ILDB B,$ARRPT(E)
	CAIE B,^M		; Skip and drop through when CR found.
	 JRST LRDR50		; Until then, flush chars.

	; Here when find CR and no atom string yet
LRDR60:	AOS LRDLIN		;increment # lines seen
	SKIPGE LRDLEV		;are we in toplevel?
	 JRST LRDR05		;yes, ignore CR.
LRDR62:	SOJLE A,LRDRZW		;no, must check beginning of next line.
	ILDB B,$ARRPT(E)
	CAIN B,^J
	 JRST LRDR62		;check again for LF with new char
	CAIE B,40		;now check first char on new line.
	 CAIN B,^I
	  JRST LRDR05		;space and tab win.
	CAIN B,";
	 JRST LRDR50		;so does a comment line
	CAIN B,^M
	 JRST LRDR60		;another CR needs another check.
	; If none of above, lose!! Flush up to next line to be safe.
	SAOBEG TMPC,
	FWRITE TMPC,[[Illegal continuation, Line ],N9,LRDLIN,[ - perhaps missing ")"]]
LRDR64:	AOS LRDLIN
LRDR65:	SOJLE A,LRDR95		; Now flush to first line with something on it.
	ILDB B,$ARRPT(E)
	CAIE B,^M
	 JRST LRDR65		; Flush til CR seen.
LRDR66:	SOJLE A,LRDR95
	ILDB B,$ARRPT(E)
	CAIN B,^J		; and if necessary til all LF's gone.
	 JRST LRDR66
	CAIE B,40		;now check first char on new line.
	 CAIN B,^I
	  JRST LRDR65		;space and tab lose.
	CAIN B,";		;so does a comment line,
	 JRST LRDR65
	CAIN B,^M		; and another CR.
	 JRST LRDR64
	D7BPT $ARRPT(E)		; Aha, flush done. Now point to first char of new line,
	FWRITE TMPC,[[
	Resuming at line ],N9,LRDLIN]
	JRST LRDR95		; and bomb out gracefully.

	; Here when "(" seen, must start collecting list.
LRDR70:	PUSHAE P,[C,D]
	AOSG LRDLEV		; Increment level we're at.
	 MOVEM A,LRDBGL		; If reader was at top level, store char cnt at beg.
	SETZB C,D
LRDR71:	CALL LREADR		;get whatever is next in list
	 JRST POPDCJ		; Error. Pass it on.
	JUMPL B,LRDR75		;if ")", end list.
	JUMPE B,[MOVE B,[ASCNT [EOF and no ")"]]
		POPAE P,[D,C]
		JRST LRDR90]	;out of chars?? lose, need ")" to terminate.
	JUMPE C,[HRRZ C,B	; If no LP to whole list yet, store first as such.
		HRRZ D,B
		JRST LRDR71]
	HRRM B,LISTAR(D)	;store ptr to returned LN in CDR of last in list.
	HRRZ D,B		;save ptr to it.
	JRST LRDR71		;get next item.
LRDR75:	MOVE B,C		;ended with ")".  return ptr to start of.
	SOS LRDLEV		; and bump level one up.
	POPAE P,[D,C]
	MAKELN B,[0 ? %LTLST,,[B]] ;make a List-LN for it.
	JRST LRDRW		;and go win.

	; Here when ")" seen - end of list.
LRDR80:	SKIPL LRDLEV		; at top level?
	 JRST [	SETO B,		; No, ")" is legal... set B to -1 and return to self!
		JRST LRDRW]
	SAOBEG TMPC,
	FWRITE TMPC,[[Line ],N9,LRDLIN,[: Stray ")" seen at top level!]]
	JRST LRDR64		; Go flush to first line with something on.

	; Failure return with error message in B.
LRDR90:	SAOBEG TMPC,
	FWRITE TMPC,[[Line ],N9,LRDLIN,[: ],TC,B]
LRDR95:	MAKELN B,[0 ? %LTSAO,,0]
	RET

LRDRZW: SETZ B,			; Return here when A counted out and nothing read yet.
LRDRW:	AOS (P)
	RET

SUBTTL EQRCPL - Single rcpt evaluation

; EQRCPL - Recipient parsing routine.  
; 	   See ASCII EQV file description for syntax it parses.
;
;  The idea here is that EQRCPL is a prelude to EVALA.  EVALA wants to
;  see ((ATTRIB VAL) (ATTRIB VAL) ...).  EQRCPL deals with the special
;  hacks at the front of such a list, to save lots of typeing, and then
;  goes to ERCP40 which calls EVALA on the rest of the list.  Returns
;  result in A, or else an SLP to an error message in A (like EVALA).
;
;  Due to bad modularity this also has to look at PRCPH which if non-zero
;  is an implicit host that has not yet been put into the data structure.

EQRCPL:	PUSHAE P,[B,C,D,E,EQRGUB]
	SETOM EQRGUB'			;No magic for special rcpt type yet
	MOVE C,LISTAR(A)		; Make sure given LLN is chopped
	HLLZS LISTAR(A)			; off from its CDR.
	TLNE C,%LTLST			; Is input a list?
	 JRST ERCP10			; Yup, go handle major case.

	;; We simply have an atom.
	MAKELN D,[0 ? %LTLST,,0]	; Make a recipient list.
	MOVEI B,A$RNAM			; Assume it will be a NAME.
	DPB B,[$LAFLD,,LISTAR(A)]
	CALL RCPHST			; Try parsing as Foo@Site.
	 SETZ B,			;  If fail, just ignore.
	SKIPE B				; Got a host?
	 JRST [	HRLM C,LISTAR(A)+1	; Yes, zap string to given length.
		MAKELN B,[A$RHST,,[LISTAR(D)+1] ? %LTVAL,,[B]]
		MOVEM B,LISTAR(D)+1	; Store rcpt!
		JRST .+1]
	CALL RCPTYP			; Check for magical names.
	JUMPN B,[ HRL B,A		;  Save old node,,new node
		  MOVEM B,EQRGUB	;  for later when we know what host.
		  JRST .+1 ]
	LNAPP [LISTAR(D)+1 ? A]
	JRST ERCP90

	;; We have a list.
ERCP10:	MOVE D,A			; Save LP to LLN in D. 
	HRRZ A,LISTAR(D)+1		; Get LP to its list for munching.
	SETZM LISTAR(D)+1		; And zap the LLN to start anew.
	JUMPE A,[SAOBEG TMPC,		; Make sure something in list
		FWRITE TMPC,[[Nil recipient spec!]]
		JRST ERCP95]
	MOVE C,LISTAR(A)		; Something there. Look at 1st LN
	TLNN C,%LTSTR			; must be atomic.
	 JRST ERCP40			; Else start hacking attribs already!

	; Come here when the first item is atomic - see if it
	; matches any known recipient type.
	MOVSI C,-NRTYPS
	USLNEA A,RTYPTB(C)	; Try matching.
	 AOBJN C,.-1
	JUMPGE C,ERCP14		; Jump if NOT a type...
	CALL SLNUPR		; It's a type! Make it uppercase.
	MOVEI B,A$RTYP
	DPB B,[$LAFLD,,LISTAR(A)]	; and insert proper attribute.
	HRRZ B,LISTAR(A)		; Now get next LN in list.
	HLLZS LISTAR(A)
	LNAPP [LISTAR(D)+1 ? A]
	MOVE A,B
	JUMPE A,[SAOBEG TMPC,
		FWRITE TMPC,[[Type specified without recipient name!]]
		JRST ERCP95]
	MOVE B,LISTAR(A)
	TLNN B,%LTSTR		; Must be atomic also (recipient name).
	 JRST ERCP40		; If not, start attrib collection.

	; Come here if the first item is atomic and not a type, or if the first
	; item was a type and the second item is atomic.
ERCP14:	MOVEI B,A$RNAM			; Item must be interpreted as a NAME,
	DPB B,[$LAFLD,,LISTAR(A)]	;   but we try parsing it too:
	CALL RCPHST			; See if can parse as Foo@Site
	 SETZ B,			; If fail, just ignore.
	JUMPN B,[HRLM C,LISTAR(A)+1	; Can! Zap string to given length.
		MAKELN B,[A$RHST,,[LISTAR(D)+1]
			%LTVAL,,[B]]
		MOVEM B,LISTAR(D)+1
		JRST .+1]
	CALL RCPTYP			; And see if name has type-indicator...
	JUMPN B,[ HRL B,A	;Save old node,,new node
		  MOVEM B,EQRGUB	;for later when we know what host
		  JRST .+1 ]
	MOVE B,A		;Assuming this is R-name put SLP in B
	HRRZ A,LISTAR(B)	; Save CDR
	HLLZS LISTAR(B)		; Zap within LN.
	LNAPP [LISTAR(D)+1 ? B]

	; Here we have finished up with the first atomic item (or first two 
	; if the first was a type and the second was atomic.
	; Are there more atomic special cases?
ERCP25:	JUMPE A,ERCP90		; End of list is OK now.
	MOVE B,LISTAR(A)	; Find type.
	TLNN B,%LTSTR		; Atomic?
	 JRST ERCP40		; No, list... it's an attribute!

	; Yes, more special case stuff.  There are three cases:
	; 1) It is "@", which means the next thing had better be an 
	;    atom parsable as a site name.
	; 2) It starts with an @, so it had better be parsable as a site name.
	; 3) It is an atom parseable as a site name.
	; If it is just a random atom, it is passed to EVALA.
	SLNEA A,[ASCNT [@]]
	 JRST ERCP30		; Not "@", continue.
	HRRZ B,LISTAR(A)	; Save the CDR
	LNDEL A,		; Flush the "@".
	SKIPN A,B		; Get LP into A.  Is it NIL?
	 JRST ERCPBA		; Yes, error
	MOVE B,LISTAR(A)	; If next LN is non-atomic, error.
	TLNN B,%LTSTR
	 JRST ERCPBA
ERCP30:	PUSH P,A		; Save the LP
	MOVE B,LISTAR(A)+1	; Get SPT.
	HRLI B,440700		; set up BP in B.
	ADD B,$LSLOC(L)		; Make absolute.
	ILDB C,B		; Get first char.
	CALL HMATCH		; And go analyze the string.
	 JRST [	POP P,A		; Foo, lost.  Restore LP
		CAIE C,"@	; and see if this was SUPPOSED to win.
		 JRST ERCP40	; No, go parse merrily as atomic attribute.
		SAOBEG TMPC,	; Ugh! definitely an error.
		FWRITE TMPC,[[Bad SITE spec - "],TLS,A,["]]
		JRST ERCP95]
	POP P,B			; Aha, winning site spec.  Restore LP, into B.
	MAKELN A,[A$RHST,,0	; Now create new LN...
		%LTVAL,,[A]]
	LNAPP [LISTAR(D)+1 ? A]
	HRRZ A,LISTAR(B)	; Now get CDR to next thing on input list,
	LNDEL B,		; Before flushing the site-string LN.

	; Here, ready to evaluate rest of list as attributes... A has LP to,
	; D has LLP to a LLN containing sublist collected thus far.
ERCP40:	JUMPE A,ERCP90		; If NIL, all done.
ERCP45:	CALL EVALA		; Evaluate rest!
	 JRST ERCP99		; Bleah, failed.  Err SLP in A.
	CAIE A,0
	 LNAPP [LISTAR(D)+1 ? A]

	; Here, recipient-spec processing all done! LP in D to completed list.
ERCP90:	SKIPGE EQRGUB		; Did RCPTYP find something interesting?
	 JRST ERCP94
	FINDA A,[A$RHST,,[LISTAR(D)+1]]	;Yes, is host an ITS?
	 JRST [	SKIPN A,PRCPH	; Implicit host?
		 JRST ERCP91	; Local host is always ITS
		JRST .+2 ]
	  MOVE A,LISTAR(A)+1
	CALL NHITS
	 JRST [	HRRZ A,EQRGUB	; Not ITS, discard RCPTYP result
		LNDEL A,
		JRST ERCP94 ]
ERCP91:	HLRZ A,EQRGUB		; ITS, discard original name
	LNDEL A,LISTAR(D)+1
	HRRZ B,EQRGUB		; and insert new name and attributes
	LNAPP [LISTAR(D)+1 ? B]
ERCP94:	FINDA A,[A$RNAM,,[LISTAR(D)+1]]	; Make sure name exists!
	 JRST [	MAKELN A,[0 ? %LTSTR,,[LITSTR [No recipient name was specified? ]]]
		JRST ERCP99]
	HRRZ A,D
	AOSA -5(P)		; Skip on return, and skip over nastiness.

	; Returns here when error seen.
ERCP95:	 MAKELN A,[0 ? %LTSAO,,]	; Put error message into SLN.
ERCP99:	POPAE P,[EQRGUB,E,D,C,B]	; Returns here if error message furnished.
	RET

ERCPBA:	SAOBEG TMPC,		; (ERCP-Bad-Atsign) Shared error routine.
	FWRITE TMPC,[["@" not followed by host name!]]
	JRST ERCP95
SUBTTL EVALA - Input Attrib "evaluation" processing routines

; EVALA - Attribute "Evaluation".  Takes LP in A to a list which it
;	crunches and returns result as LP in A.  For syntax of
;	list, see description of NAMES > format (general version,
;	not specifically rcpt type)

EVALA:	PUSHAE P,[B,C,D]
	SETZ D,			; Initialize LP to accumulated result list.
	TLZA A,-1		; Enter loop, clearing LH.
EVAL40:	 HRRZ A,LISTAR(A)	; Get next LN.
EVAL41:	JUMPE A,EVAL90		; done?
EVAL42:	MOVE B,LISTAR(A)	; get type
	TLNN B,%LTSTR
	 JRST EVAL50		; List! must be (ATTR AVAL).

	; Atomic attribute!  Merely a ATTRIB has been seen.  It implicitly
	; has no arguments.
EVAL45:	CALL SLNUPR		; Make uppercase.
	CALL IARCOD		; Try to match attrib name with internal code.
	 JRST [	MOVEI B,A$ATTR		; If failure, just use general-purpose code.
		DPB B,[$LAFLD,,LISTAR(A)] ; Set it up.
		HRRZ B,LISTAR(A)	; Save CDR
		HLLZS LISTAR(A)		; Before zapping it
		LNAPP [D ? A]		; For appending to result list.
		MOVE A,B		; Now the CDR is start of arg list...
		JRST EVAL41]		; Get another!
	PUSH P,A		; Save SLP
	MOVE C,B
	SETZ A,
	CALL @ATTRIR(C)	; Hack coded attribute, with null arg.
	 JRST [	SUB P,[1,,1]	; Error!
		SAOBEG TMPC,
		FWRITE TMPC,[[Error while processing attribute "],TC,ATTRTB(C),["
	],TLS,A]
		JRST EVAL95]
	JRST EVAL70		; Won, go add result to list.


	;;;;;;;;;;;;;;;;;;;;;;;;;
	;	List Attribute!
	; Comes in form of (ATTRIB VAL VAL VAL ... )
	; If attrib name is known, LP to rest of list is passed along to its
	; input routine and crunched thereby.  If not known, control
	; goes to general-purpose hacking (see A$ATTR part)
EVAL50:	PUSH P,A		; Save LP to LLN holding list attrib.
	HRRZ B,LISTAR(A)+1	; Get LP to list pointed to.
	JUMPE B,[ SETZ A,	; If "( )", ignore this LLN.
		  JRST EVAL70]
	SETZM LISTAR(A)+1	; Clear the sublist ptr.
	MOVE A,B		; A is now only trace to sublist.
	MOVE B,LISTAR(A)	; Find type of first thing on sublist.
	TLNN B,%LTSTR		; Must be atomic...
	 JRST [	SUB P,[1,,1]
		SAOBEG TMPC,
		FWRITE TMPC,[[Attrib name not atomic!]]
		JRST EVAL95]
	CALL SLNUPR		; Make uppercase
	CALL IARCOD		; See if code & input routine exists for this attrib.
	 JRST EVAL60		; Doesn't have one, must use A$ATTR construct.

	; Attrib has code & input routine! Dispatch to process list
	; as desired.  A should have LP to rest of list; processing
	; should return LP in A to crunched list.
	MOVE C,A
	HRRZ A,LISTAR(C)	; Get CDR to next LN as argument list for attrib.
	LNDEL C,		; And flush the SLP for attrib name.
	HRRZ C,B		; Get attrib type into C
	CALL @ATTRIR(C)	; Now process it! Should smash list and return LP in A.
	 JRST [	SUB P,[1,,1]		; Error! reset PDL & restore original LLN ptr.
		SAOBEG TMPC,
		FWRITE TMPC,[[Error while processing attribute "],TC,ATTRTB(C),["
	],TLS,A]
		JRST EVAL95]
	JRST EVAL70		; Done, jump to store returned list.

	; Attrib has no internal code! Must use A$ATTR general-purpose
	; construction. (ugh blech).  For each following item in the list,
	; 2 LN's are generated:
	;              A$ATTR --------> A$AVAL
	;        <name string>    <item string>
	; All item couplets are merely strung together, with the resulting LP in A
	; pointing to the whole slew.  The way it works is that a copy of the
	; attrib-name SLN is inserted in front of each item LN.
EVAL60:	MOVEI B,A$ATTR		; Set up general-purpose code.
	DPB B,[$LAFLD,,LISTAR(A)] ; Make it so.
	PUSH P,A		; Save LP to start of list (and to attrib name)
	HRRZ A,LISTAR(A)	; Get CDR
	JUMPE A,EVAL69		; If no more items, done.
	JRST EVAL67		; Else enter loop.

EVAL65:	MOVE B,(P)		; Aha, an item.  Copy original attrib-name.
	LNCOPY B,[0 ? B]	; (UUO shouldn't ref PDL)
	HRRM B,LISTAR(C)	; Plug onto previous LN,
	HRRM A,LISTAR(B)	; And stick item onto new attrib-name LN.
EVAL67:	MOVEI B,A$AVAL
	DPB B,[$LAFLD,,LISTAR(A)] ; Make item general-purpose attrib value.
	MOVE C,A		; Save old LP
	HRRZ A,LISTAR(C)	; Get CDR to next item (value)
	JUMPN A,EVAL65		; If more items, jump and getum.
EVAL69:	POP P,A			; All items gone!  Restore LP to whole slew.
				; And drop thru to store on accumulated list.

	; Finished attrib-list construction, LP in A to result list.  Must
	; append it to accumulated list, and flush the LLN that held the
	; whole attrib specification.
EVAL70:	POP P,B			; Restore LP to original LLN.
	CAIE A,0		; Skip if nothing returned.
	 LNAPP [D ? A]
	HRRZ A,LISTAR(B)	; Get CDR of LLN we just hacked,
	LNDEL B,		; And flush the LLN.  Bye, bye.
	JUMPN A,EVAL42		; Go munch next. (That is, unless nothing there).
				; In which case drop through to end.
EVAL90:	AOS -3(P)
	SKIPA A,D
EVAL95:	 MAKELN A,[0 ? %LTSAO,,0]
EVAL99:	POPAE P,[D,C,B]
	RET

; Routines are given LP in A to a (possibly nil) list of arguments,
; with internal attribute code in C.  B should be regarded as a
; "free" clobberable AC.

	; APNUL - for attribs that take no arguments.  Simply flushes
	; anything given.
APNUL:	JUMPE A,APNILV		; If nothing there, don't bother.
	LNDEL A			; Flush whole list, and drop thru.

APNILV:	MAKELN A,[0 ? %LTVAL,,0]	; Return nil Value
	CAIA
APNILS:	 MAKELN A,[0 ? %LTSTR,,0]	; Return nil String
	DPB C,[$LAFLD,,LISTAR(A)]	; with proper attrib code.
	AOS (P)
	RET

APOVFL:	MAKELN A,[0 ? %LTSTR,,[LITSTR [Too many arguments for attribute!]]]
	RET

	; APSTR - for attribs that take a single string as argument.
	; Sets SPT to 0 if none given.
APSTR:	JUMPE A,APNILS		; If nothing, return nil string.
	HRRZ B,LISTAR(A)	; Check for only 1 arg...
	JUMPN B,APOVFL		; Jump if too many!
	MOVE B,C		; Set up for routine ordinarily MAPC'd.
	PJRST APSTR5		; Hack it and return...

	; APSTRS - for attribs that lend their code to any number of
	; string arguments.
APSTRS:	JUMPE A,APNILS
	MOVEI B,APSTR5		; Set up addr of rtn to apply (arg in C = attrib code)
	PJRST MAPC		; Apply rtn to given list - sets attrib type to given.

	; Routine for MAPC utilization... to slap attrib type onto atoms.
	; Given LP in A and argument (attrib code) in B.
APSTR5:	HLL A,LISTAR(A)		; Get type.
	TLNN A,%LTSTR		; Check - must be atomic.
	 JRST [	MAKELN A,[0 ? %LTSTR,,[LITSTR [Non-atomic argument for attribute!]]]
		RET]	; If not, return immediately as loss.
	DPB B,[$LAFLD,,LISTAR(A)] ; Else force to given attrib type.
	AOS (P)			; And skip on return.
	RET

	; APEQVL - Equivalence list.  Takes any # of arguments,
	; each of which must be a list of recipient attribs.
APEQVL:	MOVEI B,EQRCPL		; apply this routine to each CAR
	PUSH P,C
	MOVEI C,A$RCP		; And insert this attrib type (not A$EQVL!)
	CALL MAPCA		; And return resulting list, with attrib type stuck in!
	 JRST POPCJ
	JRST POPCJ1

	; APLST - Single List.  Takes 1 arg which is a list,
	; evaluates, and puts attrib type onto single LLN returned.
APLST:	JUMPE A,APNONE
	MOVE B,A		; Save LP to LLN
	MOVE A,LISTAR(A)	; Get 1st wd
	TLNN A,%LTLST		; Make sure a list.
	 PJRST APNOTL
	MOVE A,LISTAR(B)+1	; Get 2nd wd, ptr to list.
	CALL EVALA		; Evaluate it...
	 RET		; Disaster...
	MOVEM A,LISTAR(B)+1	; Restore back
	DPB C,[$LAFLD,,LISTAR(B)]	; Won, make it proper type.
	MOVE A,B
	AOS (P)
	RET

	; APQTL - Quote following stuff and make it a list.
APQTL:	JUMPE A,APNONE		; Need an argument.
	MAKELN A,[0 ? %LTLST,,[A]]	; Make a LLN to rest of list.
	DPB C,[$LAFLD,,LISTAR(A)]
	PJRST POPJ1

	; APRCPT - Recipient.  Takes LP to either a string or list of
	; rcpt attribs and returns LP to a rcpt-LLN.
APRCPT:	JUMPE A,APNONE		; Must have an argument!
	HRRZ B,LISTAR(A)	; And must be only one...
	JUMPN B,APOVFL		; If non-Z, bah - too many.
	CALL EQRCPL		; Parse it...
	 RET			;  Blew it.
	DPB C,[$LAFLD,,LISTAR(A)]	; Won. deposit given attrib type.
	AOS (P)
	RET

	; APNUM - for attribs parsing single string as a number (oct or dec)
APNUM:	JUMPE A,APNILV		; If no arg, return 0.
	HRLM A,(P)		; Save arg on stack.
	MOVE B,LISTAR(A)
	TLNN B,%LTSTR
	 JRST APNOTA		; Make sure it's string.
	TRNE B,-1
	 JRST APOVFL		; If more than 1 arg, barf.
	CALL LIPNUM		; Try parsing...
	 JRST APBNUM		; Indicate bad number.
	MAKELN A,[0 ? %LTVAL,,[A]]
	DPB C,[$LAFLD,,LISTAR(A)]
	HLRZ B,(P)
	LNDEL B,
	AOS (P)
	RET

	; AP2NUM - Each item is a list of 2 numbers...
AP2NUM:	MOVEI B,AP2NM		; Routine to apply...
	PJRST MAPCA

AP2NM:	MOVE B,LISTAR(A)	; Make sure arg is list
	TLNN B,%LTLST
	 PJRST APNOTL
	HRLM A,(P)		; Save LP in LH on stack.
	MOVE A,LISTAR(A)+1	; Get LP to first
	MOVE B,LISTAR(A)
	TLNN B,%LTSTR
	 PJRST APNOTA		; Not a string...
	CALL LIPNUM		; Parse as #
	 PJRST APBNUM		; Ugh.
	EXCH B,A
	HRRZS A
	JUMPN A,[CALL LIPNUM		; Parse 2nd too.
		 PJRST APBNUM
		JRST .+1]
	MAKELN A,[0 ? %LTVAL,,[A]]	; LN-ify 2nd.
	MAKELN A,[0,,[A] ? %LTVAL,,[B]]	; and now 1st.
	MAKELN A,[0 ? %LTLST,,[A]]	; And return list.
	HLRZ B,(P)		; Recover original LP,
	LNDEL B,		; And flush the list of strings.
	AOS (P)
	RET

APNOTL:	MAKELN A,[0 ? %LTSTR,,[LITSTR [Argument not list!]]]
	RET
APBNUM:	MAKELN A,[0 ? %LTSTR,,[LITSTR [Bad numerical arg!]]]
	RET
APNOTA:	MAKELN A,[0 ? %LTSTR,,[LITSTR [Argument not atomic!]]]
	RET
APNONE:	MAKELN A,[0 ? %LTSTR,,[LITSTR [No argument furnished!]]]
	RET

	; AP6W - for attribs that want a single string arg converted to
	; one SIXBIT word value.
AP6W:	JUMPE A,APNILV		; Return 0 if no arg
	MOVE B,LISTAR(A)
	TLNN B,%LTSTR		; Make sure it's string.
	 JRST APNOTA		; Foo.
	TRNE B,-1
	 JRST APOVFL		; Make sure only 1 arg.
	MOVE B,A		; Save LP in B
	CALL CVLS6
	LNDEL B,		; Flush old SLN
	MAKELN A,[0 ? %LTVAL,,[A]]
	DPB C,[$LAFLD,,LISTAR(A)]
	AOS (P)
	RET

	; APHST - For attribs (i.e. SITE) that take arg as being
	; a site spec.  (can have "@" in front)
APHST:	JUMPE A,APNONE		; Error if nothing given.
	MOVE B,LISTAR(A)
	TLNN B,%LTSTR		; It must be an atom.
	 JRST APNOTA
	TRNE B,-1		; Only one argument is allowed.
	 JRST APOVFL
	MOVE B,A
	CALL HMATCH		; Try...
	 JRST [	MAKELN A,[0 ? %LTSTR,,[LITSTR [Bad SITE spec!]]]
		RET]
	LNDEL B,		; Win.  The host number is in A.
	MAKELN A,[0 ? %LTVAL,,[A]]
	DPB C,[$LAFLD,,LISTAR(A)]
	AOS (P)
	RET


; RCPTYP - special subroutine that, given SLP in A to
;	a recipient-name, tries to figure out if it should
;	be given a special TYPE.  If so, returns in B a
;	LP to a new R-NAME LN, linked to its proper R-TYPE LN. (ie 2 element list)
;	Does NOT mung original SLN!
;	Must check for these: 1) BUG-xxx 2) *name 3) [file]
RCPTYP:	PUSHAE P,[A,C,D]
	MOVE C,LISTAR(A)+1	; Get SPT
	ADD C,$LSLOC(L)		; Make abs.
	HLRZ D,C		; Get cnt
	HRLI C,440700		; Make BP
	JUMPE D,RCPTY8		; nil string?
	ILDB B,C		; Get 1st char
	CAIE B,"*		; *MSG ?
	 JRST RCPTY3		; Nope

	; Handle *-recipient.
	MAKELN B,[A$RTYP,,0	; Set appropriate type.
		%LTSTR,,[LITSTR [*MSG]]]
	JRST RCPTY7		; And go create LN copy of name.

	; Check for [<filename>] recipient.
RCPTY3:	CAIE B,"[		; A [file] ?
	 CAIN B,"{		; or {file}?
	  CAIA			; yep
	   JRST RCPTY5		; nope
	MAKELN B,[A$RTYP,,0	; Yep, set type to FILE.
		%LTSTR,,[LITSTR [FILE]]]
	JRST RCPTY7		; and finalize.

	; Check for BUG-X recipient.
RCPTY5:	CAIG D,4		; Enough chars to have a "BUG-X" in there?
	 JRST RCPTY8		; Nope, it's a plain regular name after all.
IRPC CH,,[BUG]
	CAIE B,"CH
	 CAIN B,40+"CH		; Add 40 bit for lowercase.
	  CAIA
	   JRST RCPTY8
	ILDB B,C
TERMIN
	CAIE B,"-
	 JRST RCPTY8

	; It's a BUG-X!!
	HRLZI D,-4(D)		; Put updated cnt in LH
	HRRI D,C		; And addr of BP in RH
	;; (Following instructions are in this order to avoid getting 
	;; screwed by area relocation.)
	MAKELN C,[A$RNAM,,0	; Slurp into name SLN
		%LTBPT,,[D]]
	MAKELN B,[A$RTYP,,0	; Now create TYPE for it
		%LTSTR,,[LITSTR [BUG]]]
	HRRM B,LISTAR(C)	; Cons type onto name SLN
	MOVE B,C		; And return LP in B to pair
	JRST RCPTY9

RCPTY7:	LNCOPY C,[0 ? A]	; Copy name
	HRRM B,LISTAR(C)	; Link TYPE to it
	SKIPA B,C		; And return LP in B.
RCPTY8:	 SETZ B,
RCPTY9:	POPAE P,[D,C,A]
	RET

; RCPHST - Parse Recipient and Host
;   A/ SLP to rcpt name 
;
; Tries to parse as "Foo@Site".
; If host turns out to be us, checks the recipient name
; for percent-sign (%) delimiter in case "Foo%Bar@ThisSite".
;
; Returns <# chars in name> in C, <site #> in B, and skips.  
; If it couldn't be parsed, skips but returns 0 in B.  
; Fails to skip if it parsed correctly and there was no such host.
; Garbage in C in latter two cases.
; Also have to strip our own name off the end, can be there sometimes.
;
;  Due to bad modularity this also has to look at PRCPH which if non-zero
;  is an implicit host that has not yet been put into the data structure.

LVAR	RCPHS%:	0		; Nonzero when parsing "local part".

RCPHST:	PUSHAE P,[A,D,E]
	SETZM RCPHS%		; Initially try parsing the "domain part".
RCPH10:	MOVE B,LISTAR(A)+1
	ADD B,$LSLOC(L)		; B has ASCNT to string to parse.
	HLRZ C,B
	JUMPE C,RCPH85		; If zero length, can't parse.
	SKIPE A,PRCPH		; See if host number already known another way
	 JRST RCPH80		; Don't look for % in address at foreign host
	MOVE E,C		; Original length
	HRLI B,440700
	PTSKIP C,B		; B is now a BP to the end of the string.
	CALL RCPH40		; See a host there?
	 JRST [	SKIPE RCPHS%	;  No, so there is only a "local part".
		 JRST RCPH85	;   If already did it, return 0.
		SETOM RCPHS%	;  Else reparse entire string as local part.
		MOVE A,-2(P)	;  Recover SLP and go reparse.
		JRST RCPH10 ]
	CAMN A,OWNHS2		; If this our alternate address
	 MOVE A,OWNHST		;  mutate it into our real address.
	CAME A,OWNHST		; Is this host us?
	 JRST RCPH70		;  No, all done.
	MOVE E,C		; We are the "domain part" host.
	SETOM RCPHS%		; Say we are parsing the "local part" now.
	CALL RCPH30
	 JRST [	MOVE C,E	;  Nothing else in local part, host is just us.
		MOVE A,OWNHST	;  Return our own host.
		JRST RCPH80 ]
RCPH70:	D7BPT B			; Strip possible blanks before host name
	LDB D,B
	CAIN D,40
	 SOJG C,RCPH70
RCPH80:	SKIPA B,A		; Return winning site number in B.
RCPH85:	 SETZ B,		;  Else return 0 as site if no site found.
	AOS -3(P)		; Skip.
	POPAE P,[E,D,A]		; Don't skip if parsed bad host name.
	RET

RCPH30:	D7BPT B			; Search backwards for @.
RCPH40:	LDB D,B
	CAIN D,40		; First skip backwards over spaces.
	 SOJG C,RCPH30
	JUMPLE C,APOPJ		; No non-blanks.
	SKIPA E,C		; Strip trailing blanks.
RCPH50:	 D7BPT B		; Now search for host delimiter.
	LDB D,B
	CAIN D,"@
	 JRST RCPH20
;;	SKIPE RCPHS%		; Parsing the local part yet?
;;	 CAIE D,"%		;  Yes, so can grok "%" here.
;;	  CAIA			; Don't parse them to left of the "@".
;;	   JRST RCPH20		;   Okay, kludgey relay feature.
	SOJG C,RCPH50
	RET			; No host present

RCPH20:	MOVE A,E
	SUBI A,(C)		; A has number of chars in SITE name.
	SUBI C,1		; C has number of chars in NAME.
				; And B has the BP to the site name.
RCPH60:	ILDB D,B		; Strip leading spaces
	CAIN D,40
	 SOJA A,RCPH60
	JUMPLE A,CPOPJ		; Fail if no host name present
	D7BPT B
	CALL HMATC		; Call host-name analyze rtn
	 JRST RPCH65		; Looks like a host name, but not one we know
	AOS (P)			; Success return
	RET

RPCH65:	SKIPN A,DOMGAT		; Send through domain-aware gateway
	 RET			; Just fail if no gateway
	MOVE C,E		; Length includes the host name
	JRST POPJ1		; Success

LVAR DOMGAT:	0		; Non zero to relay on unknown hostnames

SUBTTL HEADER PARSING

.VECTOR HPTOK(2),SVTOK(2)	;Current and previous token in %LTBPT form

;Parse header embedded in message text, if any, into A$SNM, A$SNH, and A$SBJ
;attributes.  This only parses the most common headers, not all headers.
;Skips if it succeeds in finding a sender
HPARSE:	PUSHAE P,[A,B,C,D,E]	;First set up $LSRPT(L) and $LSCHL(L)
	FINDA B,[A$MTXT,,[$LLLST(L)]]	; to the message text, if any.
	 JRST HPARS9		;No text
	MOVE B,LISTAR(B)+1
	HLRZ A,B		;Length
	ADD B,$LSLOC(L)
	HRLI B,440700		;Byte pointer
	MOVEM B,$LSRPT(L)	;Put where will be relocated by UABUMP
	MOVEM A,$LSCHL(L)
HPARS1:	CALL HPTOKN		;Get next token
	CAIN B,15		;Skipping leading blank lines
	 JUMPE A,HPARS1
	CAIN B,":		;Colon => NET or RFC733 header
	 JRST HPARS4
	CAIE B,"@		;Atsign => ITS header
	 JRST HPARS9		;Otherwise not parseable
	CALL SVTOKN		;Save sender name
	CALL HPHOST		;Host should be next
	 JRST HPARS9		;Garbage, cannot parse
	MAKELN B,[A$SNM,,[$LLLST(L)]	;Store sender
		  %LTBPT,,[SVTOK]]
	MAKELN A,[A$SNH,,[B]	;Put sender's host on
		  %LTVAL,,[A]]
	MOVEM A,$LLLST(L)
HPARS2:	CALL HPTOKN		;Look for subject
	CAIN B,15
	 JRST HPARS8		;End of line, no subject
	JUMPL B,HPARS8		;End of message, no subject
	CAMN A,[SIXBIT/RE/]
	 CAIE B,":
	  JRST HPARS2		;Some other token (part of date or sent-by)
	CALL HPARS7		;Gobble subject
HPARS8:	AOS -5(P)		;Success return
HPARS9:	POPAE P,[E,D,C,B,A]
	RET

;Network and RFC733 header processing
HPARS4:	CAMN A,[SIXBIT/SUBJEC/]
	 JRST [	CALL HPARS7	;Swallow subject
		JRST HPRS5A ]	;Check next line
	CAME A,[SIXBIT/FROM/]
	 JRST HPARS5		;Some other attribute, ignore it
	;; This is very simple-minded.  We only recognize token AT host
	;; and don't even look for angle brackets and parentheses.
	;; It works for all the commonly-sent header types other than
	;; screw cases such as people named "At".
	CALL HPTOKN		;Expecting user name
HPARS6:	CAIE B,15		;If end of line reached, die
	 CAIGE B,0		;Or end of message
	  JRST HPRS5B
	CALL SVTOKN		;Save putative sender name
	CALL HPSKSP		;Skip spaces, find real delimiter
	CAIN B,"@		;Some hosts may send @ rather than AT
	 JRST HPRS6B
	CALL HPTOKN		;Look for "at" as next word
	CAME A,[SIXBIT/AT/]
	 JRST HPARS6		;Well, maybe this was a sender name
HPRS6B:	CALL HPHOST		;Is next token a valid host name?
	 JRST HPARS6		;No, perhaps it is a sender name then
	CAMN A,OWNHST		;Is the host me?
	 CALL HPRS6C		;If so, recognize kludgey %
	MAKELN C,[A$SNM,,[$LLLST(L)]	;Store sender
		  %LTBPT,,[SVTOK]]
	MAKELN A,[A$SNH,,[C]	;Put sender's host on
		  %LTVAL,,[A]]
	MOVEM A,$LLLST(L)	;Ho, ho!  Got sender, keep looking for subject
	CAIN B,15
	 JRST HPRS5A
HPARS5:	SOSGE $LSCHL(L)		;Swallow remainder of line
	 JRST HPRS5B		;End of message
	ILDB A,$LSRPT(L)
	CAIE A,15
	 JRST HPARS5
HPRS5A:	CALL HPTOKN		;Get first token on next line
	CAIN B,":
	 JRST HPARS4		;Go analyze it if it is an attribute
HPRS5B:	FINDA A,[A$SNH,,[$LLLST(L)]]	;Done
	 JRST HPARS9		;Failed
	JRST HPARS8		;Succeeded

; Address in header turned out to be on my host.  Probably it is really
; some other host indirecting through me with the goddamn kludgey percent.
; SVTOK has the sender, A has the host (equal to OWNHST), B has delimiter
; This only allows a single level of %.  Tell it to the marines!
HPRS6C:	PUSH P,B
	HLRZ A,SVTOK		;Number of characters
	MOVE B,SVTOK+1		;Byte pointer
	ILDB C,B		;Search for %
	CAIE C,"%
	 SOJG A,.-2
	SOJLE A,HPRS6E		;Jump if not found
	HLRZ C,SVTOK		;Compute number of characters before %
	SUBI C,1(A)
	CALL HMATC		;Rest of string a host name?
HPRS6E:	 SKIPA A,OWNHST		;Nope, host is still me
	  HRLM C,SVTOK		;Yes, shorten token
	POP P,B
	RET

;Remainder of current line is subject
HPARS7:	MOVE B,$LSRPT(L)	;Byte pointer to start of subject
	MOVEI C,0		;Character count
HPRS7A:	SOSGE $LSCHL(L)
	 JRST HPRS7B
	ILDB A,$LSRPT(L)
	CAIE A,15
	 AOJA C,HPRS7A
HPRS7B:	MOVSS C
	HRRI C,B
	MAKELN A,[A$SBJ,,[$LLLST(L)] ? %LTBPT,,[C]]
	MOVEM A,$LLLST(L)
	RET

;Save the current token into SVTOK
SVTOKN:	PUSH P,A
	MOVE A,HPTOK
	HRRI A,SVTOK+1
	MOVEM A,SVTOK
	MOVE A,HPTOK+1
	MOVEM A,SVTOK+1
	JRST POPAJ

;Parse next token, if it is a host skip and return host number in A.
;Return delimiter in B.
HPHOST:	CALL HPTOKN
	PUSH P,B		;Delimiter
	HLRZ A,HPTOK		;Number of characters
	MOVE B,HPTOK+1		;Byte pointer
	CALL HMATC		;Is it a host name?
	 CAIA			;No
	  AOS -1(P)		;Yes, skip
	POP P,B			;Delimiter
	RET

;Parse next token, skipping spaces and line feeds.  Return sixbit in A,
;delimiter character in B (negative at end of text), and %LTBPT pointer
;(which becomes invalid if you cons) in HPTOK.  Valid characters in tokens
;are everything except space, colon, atsign, angle bracket, parenthesis,
;and controls (especially carriage return).
;Doesn't know about quoted strings, for instance.
HPTOKN:	PUSHAE P,[C,D]
	MOVEI A,0		;Blank sixbit
	MOVE C,[440600,,A]
	SETZM HPTOK		;No characters
HPTOK1:	SOSGE B,$LSCHL(L)	;First skip spaces and line feeds
	 JRST HPTOK9		;End of message, no token
	MOVE B,$LSRPT(L)	;In case token starts here
	MOVEM B,HPTOK+1
	ILDB B,$LSRPT(L)	;Next character
	CAIE B,40
	 CAIN B,12
	  JRST HPTOK1
HPTOK2:	CALL HPDELP
	 JRST HPTOK9		;Delimiter ends token
	AOS HPTOK		;Okay, this is part of token
	CAIL B,140		;This loop accumulates a token
	 SUBI B,40		;Upper case
	SUBI B,40		;Sixbit
	TLNE C,770000
	 IDPB B,C
	SOSGE B,$LSCHL(L)
	 JRST HPTOK9		;End of message, end of token
	ILDB B,$LSRPT(L)	;Next character
	JRST HPTOK2

HPTOK9:	HRLZ C,HPTOK		;Length of token
	HRRI C,HPTOK+1
	MOVEM C,HPTOK
	POPAE P,[D,C]
	RET

;Skip if character in B is not a delimiter
HPDELP:	CAIE B,"<
	 CAIN B,">
	  RET
	CAIE B,"(
	 CAIN B,")
	  RET
	CAIE B,"@
	 CAIN B,":
	  RET
	CAILE B,40
	 AOS (P)		;Not a delimiter
	RET

;Delimiter is in B.  If it's space, find real delimiter.
;For hosts that send space-atsign-space.
HPSKSP:	CAIN B,40		;Original delimiter a space?
	 SOSGE $LSCHL(L)	;More characters?
	  RET		;No, stop
	ILDB B,$LSRPT(L)	;Next character
	CAIN B,40
	 JRST HPSKSP		;Space, skip it
	CALL HPDELP		;Other delimiter?
	 RET		;Yes, return him
	AOS $LSCHL(L)		;Delimiter really space, back up
	MOVSI B,070000
	ADDM B,$LSRPT(L)
	MOVEI B,40
	RET

;Skip if this is net-mail-from-host with no discernible sender
;Returns host number sent from in A if it skips
SKPNMH:	FINDA A,[A$SNH,,[$LLLST(L)]]
	 FINDA A,[A$NMH,,[$LLLST(L)]]
	  RET		;Had parsed header or is local mail
	MOVE A,LISTAR(A)+1	;Get host number
	JRST POPJ1

SUBTTL MAPCAR and friends

; MAPCAR - Takes LP in A to a list, address in B of a routine to
;	apply to each CAR in succession, and returns in A an LP to
;	list of the results.  Skips on succesful completion and
;	returns immediately w/o skip if an apply fails.
; MAPCA - Like MAPCAR but C should contain an attrib code, which each
;	LN of the returned list is smashed to.
; MAPC - Like above, but returns nothing; merely executes given
;	routine for each thing on list.  C should contain an "argument"
;	which is given to the called routine in B.
;		Routines called are given LP in A to a single LN of
;	the list, and must return LP in A to resulting LN, and skip
;	on successful return.  B and C can be clobbered, but any
;	other ACs should be saved.  Routines for MAPC need not return anything.

MAPCAR:	TRZA F,%MAPC		; Set flag indicating which variety of MAPCAR.
MAPCA:	 TRO F,%MAPC
	PUSHAE P,[B,C,D,E]	; B and C args saved on stack.
	HRRZS A			; LP to input list given in D.
	JUMPE A,MAPCA8		; If nothing in input, done - return nil ptr.
	HRRZ D,LISTAR(A)	; Get CDR in prep for next pass.
	HLLZS LISTAR(A)		; Isolate arg.
	CALL @-3(P)		; Do first one.
	 JRST MAPCA7		; Error! Pass it on.
	MOVE E,A
	PUSH P,E		; Save as ptr to first LN of result list.
	JRST MAPCA4		; Jump into loop.

MAPCA2:	HRRZ D,LISTAR(D)	; Get CDR in prep for next loop.
	HLLZS LISTAR(A)		; Isolate argument.
	CALL @-4(P)		; Execute routine.
	 JRST MAPCA9		; If error, pass on.
	JUMPE A,MAPCA9		; Make sure something returned.
	HRRM A,LISTAR(E)	; Link result list to new LN.
	HRRZ E,A		; and make new LN last one.
MAPCA4:	TRNE F,%MAPC		; Should the LN's attrib-type get clobbered?
	 JRST [	MOVE B,-3(P)	; Yes, get attrib
		DPB B,[$LAFLD,,LISTAR(E)] ; And set it.
		JRST .+1]
	MOVE A,D		; Now get next LN
	JUMPN A,MAPCA2		; And process if it's there,
	POP P,A			; Else return LP to result and fall thru to end.

MAPCA8:	AOSA -4(P)
MAPCA9:	 SUB P,[1,,1]		; If error, flush LP to result from stack.
MAPCA7:	POPAE P,[E,D,C,B]
	RET

MAPC:	PUSHAE P,[A,B,C,D]
	HRRZ D,A		; LP to input list kept in D.
	JUMPE D,MAPC8		; If nothing in input, done.
MAPC2:	HRRZ D,LISTAR(D)	; Get CDR in preparation for next loop.
	MOVE B,-1(P)		; Set up arg to routine.
	CALL @-2(P)		; Execute routine...
	 JRST MAPC9		; If error, pass it on.
	SKIPE A,D		; Now get LP to next LN, skip if none.
	 JRST MAPC2		; crunch it.
MAPC8:	AOS -4(P)
MAPC9:	POPAE P,[D,C,B,A]
	RET


SUBTTL RLPAS, HMATCH,and RPARNM parsing routines.
IFN 0,[
; These routines are not used now because it turned out possible to use 
; EVALA and EQRCPL.  But the code should be kept around anyway...

; RLPARS - takes a BP in RLPARG, and # of chars in A, and
;	parses it as rcpt list in usual form name@site,name1@site1...
;	Returns in A the LN ptr to resulting rcpt list, and skips.
;	(no skip if parse error)
;	slightly odd in that <item> without a @<site> is interpreted
;	as <site> and not <name>@<local site> as QMAIL would do.
;	B contains LN ptr to name string when called from RCPP80.

RLPCNT:	0			;char cnt for the ptr
RLPARG:	0			;contains addr of ptr; indirected thru this.

RLPARS:	PUSHAE P,[B,C,D]
	SETZ D,			;D maintains ptr to whole list
RLPAR1:	CALL RPARNM		;read name up to "@" or "," or EOF
	 JRST RLPAR9		;error?
	JUMPE A,RLPAR8		;eof?
	MOVE C,A		;save ptr to name LN
	CAIN B,"@		;terminated by @?
	 JRST RLPAR2		;yes, go munch rest as site name
	MOVE C,-2(P)		;no rcpt name specified, use that given in B
	LNCOPY C,[0 ? C]	; (can't make ref to PDL)
	JRST RLPAR3		;and skip further gobbling of text

RLPAR2:	CALL RCOM		;read up to comma or EOF into a SLN (LP in A)
	 JRST RLPAR5		;nothing there, assume local site.
RLPAR3:	MOVE B,A		;save LP to sitename LN
	CALL HMATCH		;try to match it
	 JRST RLPAR9		;lost, couldn't parse as site name/number
	LNDEL B,		; A site! free up sitename SLN.
	CAMN A,OWNHST		; If site is local, jump
	 JRST RLPAR5		; and don't form
	MAKELN A,[A$RHST,,0	; a site-# LN.
		%LTVAL,,[A]]
	CAIA			; Now skip into rest of stuff

RLPAR5:	 SETZ A,		;clear LP to site-# LN if no site specified
	HRRM A,LISTAR(C)	;cons site-# with rcpt name
	JUMPE A,[EXCH A,C	;if local, must force name to uppercase.
		CALL SLNUPR	;smash string.
		EXCH A,C
		JRST .+1]
	MAKELN D,[A$RCP,,[D]
		%LTLST,,[C]]	;and put under a LLN, and cons onto whole list.
	JRST RLPAR1		;now go get another in list if any.

RLPAR8:	MOVE A,D		;return ptr to whole list
	AOS -3(P)
RLPAR9:	POPAE P,[D,C,B]
	RET

; RPARNM - takes and returns char cnt in RLPCNT, BP in RLPARG, reads up
;	to "@" or "," or eof into a SLN.  Flushes any spaces before
;	or after text.  Space within text, or odd chars, is error signaled by non-skip.
;	win return skips with ptr in A to the LN, break char (,@^c) in B.
; RCOM - as above, but doesn't break on @.

.SCALAR RPARNT,RPARSW

RCOM:	SETOM RPARSW	;switch to not break on @
	JRST .+2
RPARNM:	 SETZM RPARSW	;do break on @.
	PUSHAE P,[C,D]
	SKIPG B,RLPCNT
	 JRST RPARN4		;null string
RPARN1:	ILDB C,RLPARG
	CAIE C,40	;flush spaces
	 CAIN C,^I	;or tabs
	  SKIPA
	   JRST RPARN2	;not space or tab
	SOJG B,RPARN1
RPARN4:	SETZM RLPCNT
	SETZ A,
	JRST RPARN7	;null string
RPARN2:	D7BPT RLPARG
	MOVE D,RLPARG
	MOVEM D,RPARNT	;save--ptr to start.
	MOVE D,B	;save cnt
RPARN3:	ILDB C,RLPARG
	CAIN C,",	; break if separator
	 JRST [	SUBI D,(B)
		SOJA B,RPARN5]		;reached terminating char
	SKIPE RPARSW	;skip if checking @ too
	 JRST .+3	;nope
	CAIN C,"@
	 JRST [	SUBI D,(B)
		SOJA B,RPARN5]
	SOJG B,RPARN3
	IBP RLPARG	;so d7bpt will win with both types of endings
RPARN5:	MOVE A,RLPARG	;get for backwards look
	MOVEM B,RLPCNT	;store back cnt
	MOVE B,C	;save char broken on
RPARN6:	D7BPT A		;decrement ptr
	LDB C,A		;get char pted to
	CAIE C,40
	 CAIN C,^I
	  SKIPA
	   JRST RPARN8	;done, finalize.
	SOJG D,RPARN6	;else loop til all terminating blanks flushed
	JRST RPARN9	;null string, lose
RPARN8:	HRLZ C,D	;put cnt in lh
	HRRI C,RPARNT	;addr of ptr in rh
	MAKELN A,[A$RNAM,,0
		%LTBPT,,[C]]
RPARN7:	AOS -2(P)
RPARN9:	POPAE P,[D,C]
	RET
]; end of ifn 0,

; HMATCH - takes ptr to SLN in A, tries to match up as a network
;	host name or number. Skips and returns site # in A if successful,
;	else doesn't skip.  Is OK to have @ preceding name/number.
; HMATC same but takes cnt in A, BP in B directly. and skips @ test.

HMATC:	PUSHAE P,[B,C]
	JRST HMATC0
HMATCH:	PUSHAE P,[B,C]
	MOVE B,LISTAR(A)+1	;get SPT
	HLRZ A,B		; Put cnt in A
	ADD B,$LSLOC(L)		; Make addr absolute,
	HRLI B,440700		; set up BP in B,
	ILDB C,B		; Test first char
	CAIN C,"@
	 SOSA A			; If it's there, decrement cnt.
	  HRLI B,440700		; If not, restore BP.
HMATC0:	JUMPLE A,HMATC9		; Null host name is a loser (:BUG @)
	PUSHAE P,[A,B]		; Save in case IPNUM fails.
	CALL IPNUM
	 JRST HMATC5		; Failed.
	CALL RESOLV"STDHST	; Won, standardize host #.
	SUB P,[2,,2]		; If numerical parse won, flush stack & return.
	JRST HMATC8
HMATC5:	POPAE P,[B,A]
	CALL HANLYZ		; and go analyze.
	 CAIA			; Foo?
HMATC8:	  AOS -2(P)		; Hurray!
HMATC9:	POPAE P,[C,B]
	RET

SUBTTL *--------- Mailing -----------*
SUBTTL Special-Request processing routines

	; All stuff on this page is preliminary!!!
COMMENT |
*** NEW SCHEME ***
	(SPECIAL-PROC CMD ARG1 ARG2 ARG3 ... )
A$PREQ is LLN to a list,
	1st thing on list is a SLN specifying command.
	Succeeding things on list are arguments.

	Arguments to special-processing routines are furnished by
A$PARG.  This attribute may be either a string or a list containing
several arguments, as returned by EVALA - thus a fully parsed
A$RCP may be in this argument list.  Note that if it is desired to
have arguments that correspond to no existing attribute, these
must be distinguished by position in the list and QUOTE used to prevent
"evaluation". 
	For example:

((SPECIAL-PROC DELETE) (SPECIAL-ARG FOO))
			; A$PARG is the string "FOO".
((SPECIAL-PROC DELETE)
 (SPECIAL-ARG ((MESSAGE-ID 123456)
		(QUOTE (THIS IS QUOTED LIST)) )) )
		; A$PARG is a list containing one A$ID string and one A$QUOT
		; list which is the 2nd thing specified.
|

; SPCPRC - Special-Processing execution vector.
;	A - LP to A$PREQ type list
; Returns like routines it invokes.

SPRXCT:	PUSHAE P,[B,C]
	MOVE B,LISTAR(A)	; Get 1st word
	TLNN B,%LTLST		; Confirm that it's a list!
	 JSR AUTPSY		; No, Yeech!
	MOVE A,LISTAR(A)+1	; Okay, get list it points to.
	STAT (,("Note: Special req:"),C(42),TLS(A),C(42))
	MOVSI B,-NSPRQS
SPRXC1:	HLRZ C,SPRQTB(B)	; Get addr to a spec-req name
	USLNEA A,(C)		; Uppercase compare
	 AOBJN B,SPRXC1
	JUMPGE B,[STAT (,("Note: Above request is UNKNOWN; assumed bad."))
		MAKELN A,[0 ? %LTSTR,,[LITSTR [Unknown special request.]]]
		JRST SPRXC9]	; Error if can't identify.
	HRRZ B,SPRQTB(B)	; Aha, found it! Get routine addr
	HRRZ A,LISTAR(A)	; and set up ptr to arg list.
	CALL (B)		; and call it!
	 JRST SPRXC9		; Lossage, return whatever A contains.

	JUMPE A,SPRXC8		; Skip text mung if nothing to use.
	FINDA B,[A$MTXT,,[$LLLST(L)]]	; Any existing msg text?
	 CAIA
	  LNDEL B,$LLLST(L)	; Delete existing msg text.
	MOVEI B,A$MTXT
	DPB B,[$LAFLD,,LISTAR(A)]	; Use request results as new msg text.
	MOVE B,$LLLST(L)
	HRRM B,LISTAR(A)	; Cons it onto list.
	MOVEM A,$LLLST(L)
	FINDA A,[A$SBJ,,[$LLLST(L)]]	; Has any subject?
	 JRST [	MAKELN A,[A$SBJ,,[$LLLST(L)]	; If not, make one.
			%LTSTR,,[LITSTR [Request results]]]
		MOVEM A,$LLLST(L)
		JRST .+1]
	FINDA A,[A$RCP,,[$LLLST(L)]]	; Has any rcpts?
	 JRST [	CALL SNMRCP		; Nope, make rcpt out of sender name.
		 JSR AUTPSY		; Should have checked previously!
		MOVE B,$LLLST(L)	; Cons it onto msg list.
		HRRM B,LISTAR(A)
		MOVEM A,$LLLST(L)
		JRST .+1]

SPRXC8:	AOS -2(P)	; Win return, A non-zero if should send a msg.

SPRXC9:	POPAE P,[C,B]
	RET

	; Dispatch table identifying known special-processing routines
	; and their addresses.
SPRQTB:	[ASCNT [TEST]],,SPRTST
	[ASCNT [SHOW-Q]],,SPRSHQ
	[ASCNT [SHOW-MSG]],,SPRSHM
	[ASCNT [KILL-MSG]],,SPRKMG
NSPRQS==.-SPRQTB

; Special-processing routines.  All are given a single argument in A which is
; a LP to the 1st argument in a list of arguments,
; or zero if none exists.  All must skip if "successful";
; a failure return implies that an error message is waiting to be returned to
; originator of request. (actually, this may turn out not to be right thing)

; Possible outcomes:
; No skip:
;	Return error msg to sender (A if non-zero has LP to text)
; Skip:
;	If A zero, that's all.
;	Else return results to recipients
;		(include sender if no rcpts specified?)

SPRTST:	MAKELN A,[0 ? %LTSTR,,[LITSTR [This is result of A$PREQ "TEST".]]]
	PJRST POPJ1

	; "Show Queue" - Currently ignores arguments.
SPRSHQ:	MAKELN A,[0 ? %LTSAO,,[[OUTCAL(,CALL(PRTQML))]]]
	PJRST POPJ1	; Howja like them super instructions???!!

	; "Show Message" - takes message-ID argument.
SPRSHM:	JUMPLE A,POPJ1	; If no arg, just do nothing.
	OUT(,CH(TMPC),OPEN(UC$SAO))
	UARPUSH MSGAR
	CALL MSGGET
	 JRST [	OUT(,("Can't retrieve message"))
		JRST SPSHM7]
	; Output msg stuff here.
	PUSH P,L
	MOVE L,$ARLOC+MSGAR	;Use new LSE for FINDAs.
SPRKM1:	FINDA A,[A$MHDR,,[$LLLST(L)]]
	 JRST [	OUT(,("No message header for message!!"))
		JRST SPSHM7]
	OUT(,SL(A))
	FINDA A,[A$MTXT,,[$LLLST(L)]]
	 JRST [	OUT(,("No text for message!!"))
		JRST SPSHM7]
	OUT(,SL(A))
	POP P,L

	AOS (P)
SPSHM7:	UARPOP MSGAR
	MAKELN A,[0 ? %LTSAO,,]
	RET

	;Kill Message
SPRKMG:	JUMPLE A,POPJ1	; If no arg, just do nothing.
	OUT(,CH(TMPC),OPEN(UC$SAO))
	UARPUSH MSGAR
	CALL MSGGET
	 JRST [	OUT(,("Can't retrieve message"))
		JRST SPSHM7]
	PUSH P,L
	MOVE L,$ARLOC+MSGAR
	;Change A$RCP to A$RCPF
	MOVE A,$LLLST(L)
	MOVEI B,SPRKM2
	CALL MAPC
	 JSR AUTPSY
	MOVEI A,MF%SNT+MF%QUD+MF%FAI+MF%KIL
	CALL MSGFIN		;Send failure notification
	CALL MSGDEL		;Get rid of message
	CALL MGQDEL		;Remove from queue
	EXCH L,(P)
	OUT(,CH(TMPC),OPEN(UC$SAO))	; when it sees there are no rcpts left
	OUT(,("Message deleted:"),CRLF())
	EXCH L,(P)
	JRST SPRKM1		;Return copy of message

SPRKM2:	LDB B,[$LAFLD,,LISTAR(A)]	; Get attrib
	CAIE B,A$RCP
	 JRST POPJ1
	MOVEI B,A$RCPF
	DPB B,[$LAFLD,,LISTAR(A)]
	TLO F,%MSGMD
	PJRST POPJ1

;Delete current message from all queue entries it may be on
MGQDEL:	PUSHAE P,[A,B,C,D,E,L]
	SKIPN $AROPN+QMLAR		; Check, and
	 CALL QMLGET			; make sure that QML is loaded.
	MOVE L,$ARLOC+MSGAR		; Set to MSG-LSE
	FINDA A,[A$ID,,[$LLLST(L)]]	; Find MSG-ID
	 JSR AUTPSY
	MOVE E,LISTAR(A)+1		; Get SPT (add $LSLOC to make ASCNT ptr)
	MOVE L,$ARLOC+QMLAR		; Select QML, search all site lists
	HRRZ D,$LLLST(L)		; Get LP to first LLN
	JUMPE D,MGQDL9			; List exhausted
MGQDL1:	MOVE C,LISTAR(D)+1		; get LP to site's list.
MGQDL2:	HRRZ C,LISTAR(C)		; List of message IDs
	JUMPE C,MGQDL4			; End of list
MGQDL3:	LDB A,[$LAFLD,,LISTAR(C)]
	CAIE A,A$ID
	 JRST MGQDL2			; Not an ID, try next
	MOVE B,$ARLOC+MSGAR
	MOVE B,$LSLOC(B)
	ADD B,E				; ASCNT to ID of message being killed
	SLNEA C,B
	 JRST MGQDL2			; Not right ID, try next
	HRRZ B,LISTAR(C)
	TLO F,%QMLMD
	LNDEL C,LISTAR(D)+1		; Remove this from list
	MOVE C,B
	JUMPN C,MGQDL3
MGQDL4:	FINDA A,[A$ID,,[LISTAR(D)+1]]	; Any messages left?
	 SKIPA C,LISTAR(D)+1
	  JRST MGQDL6			; Yes
	MOVE A,LISTAR(C)+1		; Host
	HRRZ B,LISTAR(D)
	TLO F,%QMLMD
	LNDEL D,$LLLST(L)		; No, flush LLN from QML!
	STAT (,("All queued msgs gone for "),HST(A))
	SKIPA D,B
MGQDL6:	 HRRZ D,LISTAR(D)		; Get next site LLN.
	JUMPN D,MGQDL1			; Do next host in queue
MGQDL9:	TLNE F,%QMLMD
	 CALL QMLPUT
	POPAE P,[L,E,D,C,B,A]
	RET

; Routine to verify consistency of MASTER and QML/RML.
; For each message in MASTER, makes sure it exists on QML/RML;
; For each message in QML/RML, makes sure it exists on MASTER.
;	(this isn't too important though, since it can legitimately
;	happen that QML/RML contain deleted messages)
; Prints out 1-line summary for each offending message.
; Note carefully that output goes to the standard output!!

; VERLST - Verify Lists.
; VERMST - Verify MASTER
; VERRML - Verify RML

; VERQML - Verify QML

VERQML:	MOVE P,[-PDLLEN,,PDL]
	SETZB F,MF
	SETOM DEBUG
	MOVE A,[-6,,[
		.ROPTION ? TLO 0,%OPALL	; Use new mode ints & lock hacking.
		.RMASK ? IOR 0,[%BADPI]	; Specify interruptable bad conditions,
		.RPICLR ? MOVE 0,[-1]]]	; and enable them.
	SYSCAL USRVAR,[CIMM %JSELF ? A]
	 .LOSE %LSFIL
	CALL MYADDR		; Set our address(es)
	SKIPN PURESW		; And now, make sure
	 CALL IPURIF		; that pages are pure!
	CALL DATIME"UPINI
	 CALL MTMHNG		; What the hell, be consistant...
	CALL MLINIT		; Now ensure uniqueness!
	CALL MCINIT		
	TLNN F,%SCOPN
	 CALL SCOPN		
	.CALL [SETZ ? SIXBIT/OPEN/ ? [.UAO,,DBC] ? [SIXBIT/DSK/]
		[SIXBIT/GUBBLE/] ? SETZ [SIXBIT/>/] ]
	 .LOSE %LSSYS
	OUT(DBC,OPEN(UC$IOT))
	OUT(,CH(DBC))
	SETZ E,				; Count of LNs flushed.
	SKIPN $AROPN+QMLAR
	CALL QMLGET
	MOVE L,$ARLOC+QMLAR		; L points to QML.
	HRRZ B,$LLLST(L)		; B will point to QML nodes.
	CAIA
VERQM3:	 HRRZ B,LISTAR(B)
	JUMPE B,VERQM9
	LDB A,[$LAFLD,,LISTAR(B)]	; Check type of QML node.
	CAIE A,A$Q
	 JRST [	OUT(,("QML node bad??"),EOL)
		JRST VERQM3]
	MOVE A,LISTAR(B)+1		; Host sublist.
	LDB C,[$LAFLD,,LISTAR(A)]
	CAIE C,A$QHST
	 JRST [	OUT(,("Bad QML entry!!"),EOL)
		JRST VERQM3 ]
	OUT(,HST(LISTAR(A)+1),(":"))	; Output host-name for site.
	HRRZ A,LISTAR(A)		; CDR is to failure count.
	LDB C,[$LAFLD,,LISTAR(A)]
	CAIN C,A$QFCT			; Failure-count for host?
	 JRST [	OUT(,(" failure cnt "),D(LISTAR(A)+1))
		HRRZ A,LISTAR(A)
		JRST .+1]
	OUT(,EOL)
	CAIA
VERQE3:	 HRRZ A,LISTAR(A)		; CDR is to msg-ID list.
VERQE4:	SKIPE A
	 JRST [	LDB C,[$LAFLD,,LISTAR(A)]
		CAIN C,A$ID
		 JRST [	MOVE C,LISTAR(A)+1
			ADD C,$LSLOC(L)
			OUT(,("Message: "),TC(C),EOL)
			JRST VERQE3 ]
		OUT(,("Flushing bad LN in list, type is "),D(C))
		HRRZ C,LISTAR(A)	; Get CDR before flushing...
		OUT(,(" ...CDR is: "),O(C),EOL)
		AOS E
		LNDEL A,LISTAR(B)+1	; Flush from list.
		MOVE A,C
		TLO F,%QMLMD		; Indicate QML modified!
		JRST VERQE4 ]
	JRST VERQM3
VERQM9:	TLNE F,%QMLMD		; QML modified?
	 .VALUE [ASCIZ ":QML munged"]
	CALL QMLPUT
	TLZ F,%QMLMD		; And get rid of in-core copy
	UARCLS QMLAR
	OUT(,("Flushed "),D(E),(" nodes."))
	.VALUE [ASCIZ ": Done."]
	OUT(SC,CLS)
	OUT(DBC,CLS)
	MOVEI A,LOCK1
	CALL LKFREE		; First, make damn sure launch lock is free,
	JSR DEATHV		; then start swinging in the breeze


; PRTQML - Output QML, nicely formatted, on std output.

PRTQML:	PUSHAE P,[A,B,L]
	SKIPN $AROPN+QMLAR
	 CALL QMLGET
	MOVE L,$ARLOC+QMLAR
	HRRZ B,$LLLST(L)
	CAIA
PRTQM3:	 HRRZ B,LISTAR(B)
	JUMPE B,PRTQM9
	LDB A,[$LAFLD,,LISTAR(B)]
	CAIE A,A$Q
	 JRST [	OUT(,("QML node bad??"),EOL)
		JRST PRTQM3]
	MOVE A,LISTAR(B)+1
	CALL PRTQME		; Print a QML entry.
	JRST PRTQM3

PRTQM9:	POPAE P,[L,B,A]
	RET

; PRTQME - Output QML Entry, on standard output.
;	A - LP to the start of a site's queue-list.
;	L - QML LSE

PRTQME:	PUSHAE P,[B]
	LDB B,[$LAFLD,,LISTAR(A)]	; Get attrib of 1st LN
	CAIE B,A$QHST			; It better be this.
	 JRST [	OUT(,("Bad QML entry!!"),EOL)
		JRST PRTQE9]
	OUT(,HST(LISTAR(A)+1),(":"))	; Output host-name for site.
	HRRZ A,LISTAR(A)		; Get CDR, move up.
	LDB B,[$LAFLD,,LISTAR(A)]	; Get attrib for next LN.
	CAIN B,A$QFCT			; Failure-count for host?
	 JRST [	OUT(,(" failure cnt "),D(LISTAR(A)+1))
		HRRZ A,LISTAR(A)
		JRST .+1]
	OUT(,EOL)
	UARPUSH MSGAR			; Must save current msg!
	CAIA
PRTQE3:	 HRRZ A,LISTAR(A)
	JUMPE A,[UARPOP MSGAR		; Done, can restore MSGAR.
		JRST PRTQE9]
	LDB B,[$LAFLD,,LISTAR(A)]
	CAIE B,A$ID			; Should be message-ID
	 JRST [	OUT(,(" Bad LN in list!"),EOL)
		JRST PRTQE3]
	CALL MSGGET			; Try to get message, clobbers MSGAR.
	 JRST [	OUT(,(" Can't retrieve message "),TLS(A),EOL)
		JRST PRTQE3]
	PUSH P,L
	MOVE L,$ARLOC+MSGAR
	OUT(,("  "))			; Indent a couple spaces.
	CALL PRTSUM			; Output info about msg.
	POP P,L
	JRST PRTQE3

PRTQE9:	POPAE P,[B]
	RET

; PRTSUM - Show two-line message summary.  Outputs to std output.
;	L - LSE holding message list.

PRTSUM:	PUSHAE P,[A,B,C]
	FINDA A,[A$ID,,[$LLLST(L)]]	; Find message ID
	 JRST [	OUT(,(" <No msg ID!!> "))
		JRST PRTSM1]
	OUT(,TLS(A))		; Output ID
PRTSM1:	FINDA A,[A$TIM,,[$LLLST(L)]]	; Find message time
	 JRST [	OUT(,(" <no time!> "))
		JRST PRTSM2]
	OUT(,(" "),TIM(F1,LISTAR(A)+1),(" "))	; Output time.

	; Now print originator... this one is funny.
PRTSM2:	CALL SKPNMH		; Net-mail-from-host?
	 JRST PRTSM3
	OUT(,("@"),FMT(HST(A),-7.))
	JRST PRTSM4

PRTSM3:	FINDA A,[A$SNM,,[$LLLST(L)]]	; Find sender's name.
	 JRST [	OUT(,("   <>   "))
		JRST PRTSM4]
	OUT(,(" "),FMT(TLS(A),-7.))
	FINDA A,[A$SNH,,[$LLLST(L)]]	;Sender at foreign host?
	 JRST PRTSM4
	OUT(,("@"),FMT(HST(LISTAR(A)+1),-7.))

	; Now hack length.
PRTSM4:	FINDA A,[A$MTXT,,[$LLLST(L)]]
	 TDZA A,A
	  HLRZ A,LISTAR(A)+1	; Get length
	OUT(,(" "),D(A,5),(" "))

	; Now finalize first line by printing subject.
PRTSM5:	FINDA A,[A$SBJ,,[$LLLST(L)]]
	 JRST PRTSM6
	OUT(,("S:"),FMT(TLS(A),,20.))	; Output up to 20 chars.

;List queued recipients, one to a line
PRTSM6:	SKIPA C,$LLLST(L)
PRTSM7:	 HRRZ C,LISTAR(C)
	FINDA C,[A$RCP,,[C]]		; Find next queued rcpt
	 JRST PRTSM9			; No more
	FINDA A,[A$RPSN,,[LISTAR(C)+1]]	; Is it a pseudo?
	 CAIA
	  JRST PRTSM7			; Ignore it if so.
	OUT(,EOL,("    -> "))		; Start line for this rcpt
	FINDA A,[A$RTYP,,[LISTAR(C)+1]]	; Doesn't work to call NSRNAM
	 JRST PRTS7A			; Recursive %LTSAO I guess is bug
	OUT(,SL(A),(" "))
PRTS7A:	FINDA A,[A$RNAM,,[LISTAR(C)+1]]
	 JSR AUTPSY
	FINDA B,[A$RHST,,[LISTAR(C)+1]]
	 TDZA B,B			; Local host
	  MOVE B,LISTAR(B)+1
	OUT(,SL(A),(" at "),HST(B))
	FINDA A,[A$RFCT,,[LISTAR(C)+1]]	;Look for rcpt's failure count
	 JRST PRTSM8
	OUT(,("; Failed "),D(LISTAR(A)+1),(" times"))
PRTSM8:	FINDA A,[A$RRMG,,[LISTAR(C)+1]]	; See if err msg there
	 JRST PRTSM7
	OUT(,("; ERR="),SL(A))
	JRST PRTSM7

PRTSM9:	OUT(,EOL)
	POPAE P,[C,B,A]
	RET
SUBTTL Main mailing routine

;;; MAIL - Main mailing routine. 
;;;   MF/ control flags
;;;   A/ ptr to msg attrib list
;;;   B/ (optional) time of event this message is about
;;;
;;; Composes header, eqv's rcpts, sends msg and any error 
;;; msgs that arise, and queues if temporary error encountered.


M%CORG==1	;rh flag, set when msg originated by comsat.
M%SSBJ==2	;"  set when b has time to generate "msg of" subject about.
M%ERR==4	; Indicates error message, must CC to MAIL-MAINTAINERS.
M%EMSG==10	; Indicates message LSE is in EMSGAR.

.SCALAR MSBJTM	; May hold a time.
.SCALAR NRXPER	; # errors seen during rcpt expansion etc.

MAIL:	PUSHAE P,[A,B,C,D,L,N,LSTSUP,NRXPER]
	PUSHAE P,[NTSITE,NTHOST,NDHOST,NTCCON,NTRTSW,NTTYPE,XRSQQ,XRSQPS,XRSQRS]
	MOVEM B,MSBJTM		; Remember time of subject message.
	TRNN MF,M%EMSG		; Message in EMSGAR?
	  JRST MAIL04

	; Must make EMSGAR the MSGAR, by swapping ARBLKs!
	UARPUSH MSGAR		; Save MSGAR
	UARPUSH EMSGAR		; and transfer EMSGAR -> MSGAR via push/pop.
	UARPOP MSGAR

MAIL04:	MOVE L,$ARLOC+MSGAR	; Make current with right address.
	MOVE A,$LLLST(L)	
	TRNN MF,M%ERR		; Error message that must be CC'd to Comsat?
	 JRST MAIL06
	MAKELN B,[A$RNAM,,0
		%LTSTR,,[LITSTR [MAIL-MAINTAINERS]]]
	MAKELN B,[A$ROPT,,[B]
		%LTSTR,,[LITSTR [CC]]]
	MAKELN A,[A$RCP,,[A]
		%LTLST,,[B]]	; now have at least "MAIL-MAINTAINERS" as dest.

MAIL06:	TRNN MF,M%CORG		; Did COMSAT originate this message?
	 JRST MAIL30
	.IOPUSH NETI,		; Yes, we're recursing.  Save net chans.
	OUT(NETO,PUSH)
	OUT(NETD,PUSH)
	SETZB N,NTHOST			; And clear "current site".
	FINDA B,[A$ID,,[$LLLST(L)]]	; Make sure msg has an ID.
	 JRST [	MOVE B,A
		CALL IDGET		; Get one
		HRRM B,LISTAR(A)	; Tack rest of list onto it.
		JRST .+1]
	TRNE MF,M%SSBJ			; If so, form subject given time?
	 MAKELN A,[A$SBJ,,[A]		; Yes, make it.
		%LTSAO,,[[OUTCAL(,("Msg of "),TIM(DOW,MSBJTM),(", "),TIM(F2,MSBJTM))]]]
	MAKELN A,[A$SRTP,,[A] ? %LTSTR,,0]	; Prevent any SMTP looping.
	MAKELN A,[A$SNM,,[A] ? %LTSTR,,[LITSTR [COMSAT]]]
MAIL30:	MOVE B,A
	CALL DATIME"TIMGET
	MAKELN A,[A$TIM,,[B] ? %LTVAL,,[A]]
	MOVEM A,$LLLST(L)	; Now store ptr to consed-up list.
	SETZM NRXPER		; Zero error count
	CALL SNMEXP		; Hack sender name and options.
	CALL RCPEXP		; Crunch rcpt list into expanded form (can generate err)
	CALL HEADER		; Now form headers for message.
	CALL TXTCHK		; Check out text for ^_'s or CRLF.CRLF
	SKIPE NRXPER		; If any errors,
	 CALL RXPERR		;  generate preliminary err msg.
	CALL RCPSND		; now send!

	; Done, see if must restore MSGAR.
	TRNN MF,M%EMSG		; Was EMSGAR swapped?
	 JRST MAIL90		; Nope, OK.
	UARPOP MSGAR		; Restore old MSGAR.
MAIL90:	TRNN MF,M%CORG		; And now, if twere in recursion,
	 JRST MAIL95
	OUT(NETD,POP)		; Restore net channels.
	OUT(NETO,POP)
	.IOPOP NETI,
MAIL95:	POPAE P,[XRSQRS,XRSQPS,XRSQQ,NTTYPE,NTRTSW,NTCCON,NDHOST,NTHOST,NTSITE]
	POPAE P,[NRXPER,LSTSUP,N,L,D,C,B,A]
	RET
SUBTTL Sender name & option hacking.

SNMEXP:	PUSHAE P,[A,B]
	FINDA A,[A$SNH,,[$LLLST(L)]]
	 CAIA
	  JRST SNXP90		;Don't do if sender at foreign host
	FINDA A,[A$SNM,,[$LLLST(L)]]		; Find sender name
	 JRST [	FINDA A,[A$CSN,,[$LLLST(L)]]
		 JSR AUTPSY
		JRST .+1]
	MOVE A,LISTAR(A)+1
	ADD A,$LSLOC(L)		;make abs ascnt ptr to name
	SETZ B,			; Match to any type.
	CALL RCPEQV		;get ptr to option list if any
	 JRST SNXP90		;none
	PUSH P,L
	MOVE L,$ARLOC+EQVAR	; Temporarily set LSE to EQV for searching.
	FNDSTR A,A,A$ROPT,[NOQC]
	 TDZA B,B
	  SETO B,
	POP P,L
	JUMPE B,SNXP90		; Jump if no "NOQC" option.
	MAKELN A,[A$CNF,,[$LLLST(L)]
		%LTSTR,,[LITSTR [FAIL]]]
	MOVEM A,$LLLST(L)	; Found it, store confirm-option on list.

SNXP90:	POPAE P,[B,A]
	RET


; SNMRCP - Cons up RCPT for sender name.  Called by various things
;	that want to return some message or error to sender.
;	L - current LSE must have message attribs in it.
; Failure return .+1 if can't find sender name.
; Returns .+2
;	A - LP to an A$RCP LLN.
;
; Nowadays prefer an SMTP return path to a parsed FROM field!
;	We add ourselves to the virtual routing path at transmission time;
;	the first host in an SMTP reverse path is the host we received the
;	message from.  This means we can simply hand the entire path back
;	to the most recent relay host as the forward path for an error
;	receipt.  SU-SCORE appears to be trying to parse the path though!

SNMRCP:	PUSHAE P,[B,C]
	FINDA A,[A$SMRP,,[$LLLST(L)]]	; Explicit maintainer specified?
	 CAIA				;  Give them the error receipt.
	  JRST SNMRC6
	FINDA A,[A$CSN,,[$LLLST(L)]]	; Maybe claimed by someone?
	 CAIA				;  Give them the error receipt.
	  JRST SNMRC6
	FINDA A,[A$SRTP,,[$LLLST(L)]]	; Maybe SMTP path available?
	 JRST SNMRC5
	MOVE B,LISTAR(A)+1		; Get spt to return path.
	TLNN B,-1			; See if it's explicitly null
	 JRST SNMRC9			;  Yeah, punt this recipient.
	LNCOPY A,[0 ? A]	   	; Copy the reverse-path.
	MOVEI B,A$RNAM			; Becomes  forward-path.
	DPB B,[$LAFLD,,LISTAR(A)]  	; Mutate into rcpt name.
	FINDA B,[A$NMH,,[$LLLST(L)]]	; Find most recent netmail host.
	 JRST SNMRC5			;  Eh?
	JRST SNMRC7			; Source routed rcpt.

SNMRC5:	FINDA A,[A$SNM,,[$LLLST(L)]]	; Maybe parsed the header?
	 JRST SNMRC9			;   Ugh, no rcpt!
SNMRC6:	LNCOPY A,[0 ? A]		; Begin with copy of name LN.
	MOVEI B,A$RNAM			; Create rcpt name attribute.
	DPB B,[$LAFLD,,LISTAR(A)]	; Munge our copy.
	FINDA B,[A$SNH,,[$LLLST(L)]]	; If sender was at foreign host
	 CAIA				;  use that information too.
SNMRC7:	MAKELN A,[A$RHST,,[A] ? %LTVAL,,[LISTAR(B)+1]]	; Make copy of host LN.
	MAKELN A,[A$RCP,,0 ? %LTLST,,[A]] ; Cons host, recipient.
	AOS -2(P)			; Success!
SNMRC9:	POPAE P,[C,B]			; All done.
	RET


SUBTTL Message header formation

; HEADER -  Using current MSG-LSE, and any argument flags etc,
;	generates headers for each recipient, as well as a standard
;	default A$MHDR for the whole message. (If a rcpt has no
;	A$RHDR, the A$MHDR is used instead.)


HEADER:	PUSHAE P,[A,B,C,D]
	CALL HDRINI			; Initialize header vars...

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; This is a special kludge for net mail; when (if) network headers are
;;; parseable, the new scheme will be to extract the network header
;;; exactly and put it in HDRPN (to preserve comment fields) but 
;;; generate the ITS headers etc. as appropriate.  But since they can't
;;; be parsed, instead we put in the following "header force" which OVERRIDES
;;; R-HEADER-FORCEs, so that people who use R-HEADER-FORCE won't complain.
	FINDA B,[A$NMH,,[$LLLST(L)]]	; Is this net mail?
	 JRST HEAD05			;   No, avoid kludge.
	SETOM HDRNMH			; Make other code do different things
;;; Now, look at the first line of the message text.  If it looks like an
;;; ITS header, make up a network header from it and put it on as A$KHDR.
	FINDA B,[A$MTXT,,[$LLLST(L)]]	; Get message text
	 JRST HEAD05			;  None?
	MOVE B,LISTAR(B)+1
	HLRZ A,B			; Length
	ADD B,$LSLOC(L)
	HRLI B,440700			; Byte pointer
	MOVEM B,$LSRPT(L)		; Put where will be relocated by UABUMP
HDRK1:	ILDB C,$LSRPT(L)		; See if there's an @ before
	CAIN C,"@			; the first : or CR
	 JRST HDRK3
	CAIE C,":
	 CAIN C,^M
	  JRST HEAD05
	SOJG A,HDRK1
	JRST HEAD05

;;; Next space after the @ terminates the from-name, unless there is a parenthesized
;;; thingamajig after that.
HDRK3:	SOJLE A,HEAD05
	ILDB C,$LSRPT(L)
	CAIN C,^M
	 JRST HEAD05
	CAIE C,40
	 JRST HDRK3
	SOJLE A,HEAD05
	MOVE C,$LSRPT(L)		;LOOK AHEAD 1 CHARACTER
	ILDB C,C
	CAIE C,"(
	 JRST HDRK5
HDRK4:	ILDB C,$LSRPT(L)
	CAIN C,^M
	 JRST HEAD05
	SOJLE A,HEAD05
	CAIE C,")
	 JRST HDRK4
	ILDB C,$LSRPT(L)
	SOJLE A,HEAD05			;WE HAVE JUST READ THE SPACE
HDRK5:	SAOBEG TMPC,			;Make network header
	FWRITE TMPC,[[From: ]]		; Do any bumping before ASCNT formed.
	FINDA C,[A$MTXT,,[$LLLST(L)]]
	 JSR AUTPSY
	MOVE C,LISTAR(C)+1
	ADD C,$LSLOC(L)
	HLRZ D,C
	SUBI D,1(A)
	HRL C,D			;ASCNT to from-name not counting trailing sp.
	OUT(TMPC,TC(C),EOL)
	;Next 17. characters are the date
	FWRITE TMPC,[[Date: ]]
	MOVEI D,17.
HDRK6:	ILDB C,$LSRPT(L)
	OUT(TMPC,C((C)))
	SOJG D,HDRK6
	SUBI A,17.
	OUT(TMPC,EOL)
	;The rest of the line, if anything, is the subject.
	;In that case there is a Re: before it.
HDRK7:	SOJLE A,HDRK10
	ILDB C,$LSRPT(L)
	CAIN C,^M
	 JRST HDRK10
	CAIE C,":
	 JRST HDRK7
	FWRITE TMPC,[[Subject]]
HDRK8:	OUT(TMPC,C((C)))
	SOJLE A,HDRK9
	ILDB C,$LSRPT(L)
	CAIE C,^M
	 JRST HDRK8	
HDRK9:	OUT(TMPC,EOL)
HDRK10:	OUT(TMPC,EOL)			;Blank line separates header from text
	MAKELN A,[0 ? %LTSAO,,0]	; Return accumulated stuff.
	MOVEI B,A$KHDR
	DPB B,[$LAFLD,,LISTAR(A)]	; Set up attrib
	MOVE B,$LLLST(L)
	HRRM B,LISTAR(A)
	HRRZM A,$LLLST(L)		; Cons onto message-attrib list.
	;drop into HEAD05
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

	; First, find out what sort of header the sender wants to use.
HEAD05:	MOVEI A,3			;Null header if NET-MAIL-FROM-HOST
	SKIPE HDRNMH
	 JRST HEAD20
	FINDA B,[A$HFRC,,[$LLLST(L)]]	;header force option exists?
	 JRST HEAD10			;no, hack default stuffs.
	MOVSI A,-NHDRFS
	USLNEA B,HDRFTB(A)		; Search thru header force table.
	 AOBJN A,.-1
	JUMPL A,HEAD20			; Jump if found!

	; Default header munching, decide if want ITS or Network style.
	; If completely intra-ITS, use ITS style; else must use Network style.
HEAD10:	SETZM RCSQCT		;initialize
HEAD12:	CALL RCPSEQ		;get one rcpt
IFN 0,[	 JRST [	SETZ A, ? JRST HEAD20]	;none left, ITS-style header is ok.

	FINDA A,[A$RHST,,[A]]	;see if foreign host
	 JRST HEAD12		; None, local...
	MOVE A,LISTAR(A)+1	;yes, get #
	CALL NHITS		; an ITS site?
	 CAIA
	  JRST HEAD12		;yes, continue
];IFN 0
	 NOP
	MOVEI A,4		; Non-ITS site found, default to RFC822 header.

HEAD20:	CALL @HDRTB(A)	; Form whatever style header is desired, return SLP in A
	MOVEM A,HDRPDF		; Store it as default and future A$MHDR.

	SKIPA D,$LLLST(L)	; Begin loop thru rcpts...
HEAD30:	 HRRZ D,LISTAR(D)	; Get next
	FINDA D,[A$RCP,,[D]]	; Find one.
	 JRST HEAD90		; When done, finalize & return.
	MOVE B,LISTAR(D)+1	; Get ptr to list
	FINDA A,[A$RPSN,,[B]]	; Make sure it's not a pseudo.
	 CAIA
	  JRST HEAD30		; It was, ignore it.

	; Here, can hack each rcpt's header separately.
	FINDA A,[A$HFRC,,[$LLLST(L)]]	; Ignore R-header-force if header-force
	 SKIPE HDRNMH		; ...or if NET-MAIL-FROM-HOST
	  JRST HEAD40
	FINDA A,[A$RHFC,,[B]]	; Does rcpt have a R-header-force?
	 JRST HEAD40		; Nope, so skip that.
	MOVSI C,-NHDRFS		; Has a R-header-force!  Find IDX for it.
	USLNEA A,HDRFTB(C)
	 AOBJN C,.-1
	JUMPGE C,HEAD30		; Jump if can't understand it.
	CALL @HDRTB(C)	; Else execute...
	JRST HEAD45		; and go put onto rcpt's list.

HEAD40:	FNDSTR A,B,A$RTYP,[*MSG]	; Is this a *MSG rcpt?
	 JRST HEAD30		; Nope, don't form any special header.
	CALL HDRMSG		; Uh-oh!  Form *MSG-style header!
HEAD45:	MOVEI C,A$RHDR
	DPB C,[$LAFLD,,LISTAR(A)] ; Set attrib
	LNAPP [B ? A]		; Put header on rcpt list.
	JRST HEAD30		; Back for more.

	; Return after header adventures.
HEAD90:	SKIPN A,HDRPDF			; Get default header.
	 JSR AUTPSY			; MUST ALWAYS BE ONE!
	LNCOPY A,[0 ? A]		; Copy it...
	MOVEI B,A$MHDR
	DPB B,[$LAFLD,,LISTAR(A)]	; Set up attrib
	MOVE B,$LLLST(L)
	HRRM B,LISTAR(A)
	HRRZM A,$LLLST(L)		; Cons onto message-attrib list.
HEAD99:	POPAE P,[D,C,B,A]
	RET


	; Header-Force table.
HDRFTB:	ASCNT [ITS]
	ASCNT [NET]
	ASCNT [*MSG]
	ASCNT [NULL]
	ASCNT [RFC733]
NHDRFS==.-HDRFTB

	; Header-routine table, holds rtns corresponding to HDRFTB above.
HDRTB:	HDRITS		; 0 - ITS header.
	HDRNET		; 1 - NET header.
	HDRMSG		; 2 - *-MSG header.
	HDRNUL		; 3 - Null header. (This number is known by HEAD05)
	HDRSTD		; 4 - ARPAnet standard header (RFC822)

BVAR	; Header-routine variables.
HDRTIM:	0		; Time of message
HDRFRM:	0		; SLP to "FROM" name to use.
HDRSBY:	0		; SLP to "SENT-BY" name to use, if any.
HDFFLG:	0		; -1 when "@" exists within FROM name.
HDRPI:	0		; SLP to ITS-style header if one formed yet.
HDRPN:	0		; SLP to NET-style header if one formed yet.
HDRPS:	0		; SLP to RFC733-style header if one formed yet.
HDRPMG:	0		; SLP to *MSG-style header if one formed yet.
HDRPDF:	0		; SLP to default header if one (used for A$MHDR).
HDRLCL:	0		; -1 if all recipients are local (i.e. on OWNHST)
HDRNMH:	0		; non-zero if NET-MAIL-FROM-HOST and header is in text
HDRFNB:	BLOCK 14	; Buffer for storing unscrambled full name.
EVAR

; HDRINI - Initialize Header routine variables.
;	MUST be called before any HDRITS, HDRNET, etc to produce valid
;	results for current message!

HDRINI:	PUSHAE P,[A,B,C]
	SETZM HDRFRM			; Clear various variables
	SETZM HDRSBY
	SETZM HDFFLG
	SETZM HDRPI
	SETZM HDRPN
	SETZM HDRPS
	SETZM HDRPMG
	SETZM HDRLCL
	SETZM HDRNMH
	FINDA A,[A$TIM,,[$LLLST(L)]]	; Find time of msg
	 JRST [	CALL DATIME"TIMGET 	; If doesn't exist, get current time.
		JRST HDRIN0]
	MOVE A,LISTAR(A)+1
HDRIN0:	MOVEM A,HDRTIM			; Save for later ref.

	; Now straighten out which sender name(s) to use
	SETZB B,C			;B holds claimed name ptr, C the sent-from name ptr
	FINDA C,[A$SNM,,[$LLLST(L)]]	;find the sent-from name if any
	 JFCL
	FINDA B,[A$CSN,,[$LLLST(L)]]	;find claimed-from name
	 CAIE C,			;if neither exists, skip and die
	  CAIA				;one exists, skip and live
	   JSR AUTPSY
	USLNE B,C			;compare strings
	 CAIA				;unequal
	  SETZ C,			;equal, so flush sent-from and use claimed-from.
	CAIN B,				;if claimed-from doesn't exist,
	 EXCH B,C			;use sent-from as claimed-from.
	MOVEM B,HDRFRM			; Store who it's from
	MOVEM C,HDRSBY			; And who actually sent it.

	SETZM RCSQCT		; initialize RCPSEQ coroutine
HDRIN1:	CALL RCPSEQ		; get a recipient
	 JRST [	SETOM HDRLCL	; none left, all recipients are local
		JRST HDRIN2
		]	
	FINDA A,[A$RHST,,[A]]	; get recipient's host
	 JRST HDRIN1		; none, i.e. local, go check next
	MOVE A,LISTAR(A)+1	; get host no.
	CAMN A,OWNHST		; is host us?
	 JRST HDRIN1		; yes, keep looking at recipients


	;minor check here ... if "@" exists within claimed-from name,
	;set flag saying not to add "@ <ownsite>" (but always add that to
	;sent-from name! Generate sent-from in this case if it didn't exist?)
	; Later should allow optional host spec for FROM: in input file.

HDRIN2:	SETZM HDFFLG
	JUMPE C,HDRIN5		; meaningless to check if no sent-from.
	MOVE A,LISTAR(B)+1	; get SPT to sender name.
	ADD A,$LSLOC(L)		; Make abs.
	HLRZ B,A
	HRLI A,440700
	JRST HDRIN4
	ILDB C,A
	CAIN C,"@
	 SOSA HDFFLG		;make -1 and skip out of loop
HDRIN4:	SOJGE B,.-3
HDRIN5:	POPAE P,[C,B,A]
	RET


SUBTTL Individual header routines.

; These routines are called to generate a specific type of header.
; They take no explicit arguments: they just assume that the current LSE
; is the message for which the header must be generated.  Also, to
; save time, certain decoding of the LSE which is common to several
; header types is prepared by HDRINI (i.e., HDRTIM, HDRSBY, etc).
; They are expected to return in A an SLN (no attribute) to the header
; text.

	; Form a null header
HDRNUL:	MAKELN A,[0 ? %LTSTR,,0]	; Fast...
	RET

	; Form an ITS-style header.
HDRITS:	SKIPE HDRPI			; If one already formed,
	 JRST [	LNCOPY A,[0 ? HDRPI]	; Copy and return that.
		RET]
	SAOBEG TMPC,
	FWRITE TMPC,[TLS,HDRFRM]		; Write FROM name.
	SKIPN HDFFLG				; If he has own ideas
	 JRST [	FWRITE TMPC,[[@],TZ,OWNNAM]	;  skip "@<localsite>".
		JRST .+1]	; Else (default) add it.
	SKIPN HDRSBY		; And skip to add Sent-by if different.
	 JRST HDRI20
	FWRITE TMPC,[[ (Sent by ],TLS,HDRSBY]	; Different, add "Sent-by"
	SKIPN HDFFLG
	 JRST [	FWRITE TMPC,[[@],TZ,OWNNAM]	; Add local-site if not given in FROM.
		JRST .+1]
	OUT(TMPC,RPAR)
HDRI20:	FWRITE TMPC,[[ ],WA,HDRTIM]		; Now, time of message.
	FINDA A,[A$SBJ,,[$LLLST(L)]]		;find subject if any
	 JRST HDRI30				;nope
	FWRITE TMPC,[[ Re: ],TLS,A]		;add the subject string
HDRI30:	OUT(TMPC,EOL)
	MOVE A,RCPNUM
	SKIPE HDRLCL			; if any recipients are foriegn then force a To: line
	 CAILE A,1			; only one recipient?
	  CALL TOPUT			; if so, skip 'to:' lines...else do.
	CALL UHDPUT			; Output user-specified header lines, if any.
	MAKELN A,[0 ? %LTSAO,,0]	; Return accumulated stuff.
	MOVEM A,HDRPI			; Save SLP in case called again.
	RET

	; NET style header
HDRNET:	SKIPE HDRPN			; If one already formed,
	 JRST [	LNCOPY A,[0 ? HDRPN]	; Copy & return that.
		RET]
	PUSH P,B
	SAOBEG TMPC,
	FWRITE TMPC,[[Date: ],WB,HDRTIM,[
From: ],TLS,HDRFRM]			; SIMPLE!!!
	SKIPE HDFFLG			; If FROM has a "@site" in it,
	 JRST HDRN22			; Skip "at <site>" & fullname.
	FWRITE TMPC,[[ at ],TZ,OWNNAM]

	; Now try to put the full name of the sender, in parentheses.
	MOVE B,HDRFRM
	MOVE A,LISTAR(B)+1
	ADD A,$LSLOC(L)		; Get abs ASCNT to sender's name.
	HLRZ B,A		; Get length of FROM field.
	CAILE B,6		; If longer than 6 letters, loser probably
	 JRST HDRN22		; put his fullname in From: field. 
	CALL CVT76C		; LSRTNS won't get the right thing, so skip it.
	MOVE B,A		; Get SIXBIT UNAME.
	MOVEI A,LSR1C
	CALL LSRTNS"LSRUNM
	 JRST HDRN22		; Not in LSR1, skip full-name hack.
	MOVEI A,LSRTNS"I$NAME
	CALL LSRTNS"LSRITM
	 JRST HDRN22		; No full name given, skip it.

	; A/ BP to the fullname in ASCIZ, last-name-first.
	MOVE B,A
	ILDB B,B		; (Get first char of full name)
	JUMPE B,HDRN22		; Full name is null, skip it.
	MOVE B,[440700,,HDRFNB]
	CALL LSRTNS"LSRNAM	; Unscramble the order.
	 JRST HDRN22		; This should not ever happen.
	MOVE A,[440700,,HDRFNB]
	FWRITE TMPC,[[ (],TPZ,A,[)]]	; SIMPLE!!!
HDRN22:	OUT(TMPC,EOL)
	SKIPE HDRSBY			; Sent-by exists?
	 JRST [	FWRITE TMPC,[[Sent-by: ],TLS,HDRSBY,[ at ],TZ,OWNNAM,[
]]
		JRST .+1]		;add sent-from name if necessary
	FINDA A,[A$SBJ,,[$LLLST(L)]]	;find subject if any
	 JRST HDRN30			;no
	FWRITE TMPC,[[Subject: ],TLS,A,[
]]					;output line
HDRN30:	CALL TOPUT			; Output recipients.
	CALL UHDPUT			; Output any user-specified hdr lines.
	OUT(TMPC,EOL)			; Extra CR separates header from text
	MAKELN A,[0 ? %LTSAO,,0]
	MOVEM A,HDRPN			; Save SLP in case called again.
	POP P,B
	RET

; DARPA Internet standard header (RFC822)

LVAR HDRQUP:	-1	; -1 if want names with periods are to be quoted.
LVAR HDRIDS:	-1	; -1 if want message IDs stuck in headers.
LVAR HDRGAT:	0	; Non-zero: addr of foo%bar@baz relay (headers only)

HDRSTD:	SKIPE HDRPS			; If one already formed
	 JRST [	LNCOPY A,[0 ? HDRPS]	;   then just copy and return it.
		RET]
	PUSHAE P,[B,C]		; Else accumulate header in string.
	OUT(TMPC,OPEN(UC$SAO))	; Begin string.
	OUT(TMPC,("Date: "),TIM(RFC2,HDRTIM),EOL,("From: "))
	FINDA A,[A$FFM,,[$LLLST(L)]]	; Maybe FAKE-FROM spec.
	 CAIA
	  JRST [ OUT(TMPC,TLS(A),EOL)
		 JRST HDRS30 ]
	SKIPE HDFFLG		; If FROM specification has a "@" in it
	 JRST [	OUT(TMPC,TLS(HDRFRM),EOL) ; then put it out verbatim.
		JRST HDRS30 ]
	MOVE B,HDRFRM		; Try to find author's fullname.
	MOVE A,LISTAR(B)+1
	ADD A,$LSLOC(L)		; Get abs ASCNT to sender's name.
	CALL CVT76C		; Convert it to sixbit.
	MOVE B,A
	MOVEI A,LSR1C
	CALL LSRTNS"LSRUNM	; Look up in LSR1 database.
	 JRST HDRS10		;  If missing or no core, don't bother.
	MOVEI A,LSRTNS"I$NAME
	CALL LSRTNS"LSRITM	; Found luser - get fullname.
	 JRST HDRS10		;  Oh, well, no fullname given.
	MOVE B,A		; Bp to last-name-first string.
	ILDB B,B		; Check first char of fullname.
	JUMPE B,HDRS10		; If fullname is null, skip it.
	MOVE B,[440700,,HDRFNB]
	CALL LSRTNS"LSRNAM	; Unscramble the order.
	 CAIA
	  JRST HDRS20
	; Here when fullname is unavailable.
HDRS10:	SKIPE HDRGAT
	 JRST [	OUT(TMPC,TLS(HDRFRM),("%"),TZ(OWNNAM),("@"),TZ(GATNAM),EOL)
		JRST HDRS30 ]
	OUT(TMPC,TLS(HDRFRM),("@"),TZ(OWNNAM),EOL)
	JRST HDRS30

	; Here when we have the fullname.
HDRS20:	MOVE A,[440700,,HDRFNB]	; Bp to fullname.
HDRS21:	ILDB C,A		; Must check to see if it's cool.
	JUMPE C,HDRS24		; If no weirdness, we can output it.
	CAIN C,".		; Periods may be special
	 SKIPN HDRQUP		;   depending on latest RFC (sigh).
	CALL SCHK4		; Is this a special char?
	 CAIA
	  JRST HDRS21		; If not special, get another.
HDRS22:	MOVE A,[440700,,HDRFNB]	; Uh-oh, name contains a losing char.
	OUT(TMPC,C(""))		; Must surround the name with quotes.
HDRS23:	ILDB B,A
	JUMPE B,[ OUT(TMPC,C(""))
		  JRST HDRS29 ]
	CAIE B,""		; If we run into a null
	 CAIN B,"\		;  or a backslash
	  OUTCAL(TMPC,C("\))	;   quote it with a backslash.
	OUT(TMPC,C((B)))	; Output char of name.
	JRST HDRS23		; Go back for more chars.
HDRS24:	OUT(TMPC,TZ(HDRFNB))	; Output luser's full name.
HDRS29:	OUT(TMPC,SP,LABR,TLS(HDRFRM))
	SKIPE HDRGAT
	 JRST [ OUT(TMPC,("%"),TZ(OWNNAM),("@"),TZ(GATNAM),RABR,EOL)
		JRST HDRS30 ]
	OUT(TMPC,("@"),TZ(OWNNAM),RABR,EOL)

HDRS30:	SKIPE HDRSBY		; Do SENDER if there is one.
	 OUTCAL(TMPC,("Sender: "),TLS(HDRSBY),("@"),TZ(OWNNAM),EOL)
HDRS40:	FINDA A,[A$SBJ,,[$LLLST(L)]]
	 CAIA			; Do SUBJECT if there is one.
	  OUTCAL(TMPC,("Subject: "),TLS(A),EOL)
HDRS50:	CALL STOPUT		; Add TO: to header
	CALL SCCPUT		; Add CC: to header
	CALL UHDPUT		; Do user-specified header lines, if any.
	SKIPE HDRIDS		; Maybe put MESSAGE-ID in header.
	 JRST [	FINDA A,[A$ID,,[$LLLST(L)]]
		 JSR AUTPSY
		OUTCAL(TMPC,("Message-ID: "),TLS(A),EOL)
		JRST .+1 ]
	OUT(TMPC,EOL)		; Extra CRLF separates header from text.
	MAKELN A,[0 ? %LTSAO,,0]
	MOVEM A,HDRPS		; Save SLP in case called again.
	POPAE P,[C,B]
	RET


; HDRMSG - forms header line for a MSG of format
;   DISTRIB: *<site1>,*<site2>...
;   EXPIRES: <date>
;   <FROM> <TIME> <SUBJECT>
; tricky part is putting only the right names in DISTRIB.

HDRMSG:	SKIPE HDRPMG			; Already have a *MSG header?
	 JRST [	LNCOPY A,[0 ? HDRPMG]	; Use it if so.
		RET]
	PUSH P,B
	SAOBEG TMPC,
	FWRITE TMPC,[[DISTRIB: ]]
	TRO F,%NOCOM
	SETZM RCSQCT			;initialize RCPSEQ
HDRM10:	CALL RCPSEQ
	 JRST HDRM20			;no more
	FNDSTR B,A,A$RTYP,[*MSG]	; Find all which are of type *MSG.
	 JRST HDRM10			; Not right type, ignore.
	FNDSTR B,A,A$ROPT,[NOTDIST]	; Make sure it's OK to include in DISTRIB.
	 CAIA
	  JRST HDRM10			; Nope, it doesn't want to be in there.
	FINDA B,[A$RNAM,,[A]]		;yep, get the name
	 JSR AUTPSY
	TRZN F,%NOCOM			; Output comma if anything precedes this.
	 OUTCAL(TMPC,(","))
	FWRITE TMPC,[[ ],TLS,B]		; Output name
	JRST HDRM10			; & get another.

HDRM20:	FWRITE TMPC,[[
EXPIRES: ]]
	FINDA A,[A$XPIR,,[$LLLST(L)]]	;get ptr to expiration time
	 SKIPA B,[7]			; Use 7 days if none specified.
	  MOVE B,LISTAR(A)+1		; Get # days since msg creation date.
	IMUL B,[24.*60.*60.]		; Produce # secs
	MOVE A,HDRTIM
	CALL DATIME"TIMSEC			; Convert creation time to # secs,
	ADD A,B				; Add in to get future time,
	CALL DATIME"SECTIM			; And convert back from secs.
	FWRITE TMPC,[WA,A,[
]]
	CALL SKPNMH			; Don't make bogus ITS header
	 CAIA
	  JRST HDRM90
	FWRITE TMPC,[TLS,HDRFRM]
	SKIPE HDFFLG			; If has "@" within name,
	 JRST HDRM29			; leave it.
	FINDA A,[A$SNH,,[$LLLST(L)]]	; Sender have host?
	 JRST [	FWRITE TMPC,[[@],TZ,OWNNAM]	; No, use local host
		JRST HDRM29 ]
	FWRITE TMPC,[[@],HST,LISTAR(A)+1]	; Yes, use sender's host
HDRM29:	FWRITE TMPC,[[ ],WA,HDRTIM]
	FINDA A,[A$SBJ,,[$LLLST(L)]]	; See if subject spec...
	 JRST HDRM30			; Nope
	FWRITE TMPC,[[ Re: ],TLS,A]
	CALL UHDPUT			; Output user-specified header lines, if any.
HDRM30:	OUT(TMPC,EOL)
HDRM90:	MAKELN A,[0 ? %LTSAO,,0]
	MOVEM A,HDRPMG
	POP P,B
	RET

; TOPUT - forms 'to:' lines from existing A$RCP's.
; ignores those rcpts with attribs of OPTION NOSHOW.

.SCALAR TOPASS	; Flag for TO or CC.

TOPUT:	PUSHAE P,[A,B,C,D,E]
	FINDA A,[A$RLN,,[$LLLST(L)]]	;see if rcpt list name exists
	 CAIA
	  JRST TOPUT7

	SETZM TOPASS		; Indicate pass 1 (to's)

TOPUT1:	SETZM RCSQCT		; Initialize rcpseq routine
	SETZ E,			; Zero cnt of chars on line
TOPUT2:	CALL RCPSEQ		; Get ptr to rcp attrib list
	 JRST TOPUT8		; No more rcpts to get

	FNDSTR B,A,A$ROPT,[NOSHOW]
	 CAIA			; Supposed to suppress?
	  JRST TOPUT2		;  Yes, don't do it.

	FNDSTR B,A,A$ROPT,[CC]	; Cc?
	 JRST [	SKIPE TOPASS	;  No, if "to" pass, do it.
		 JRST TOPUT2
		JRST .+2]
	JRST [	SKIPN TOPASS	; Yes, if "to" pass, don't do.
		 JRST TOPUT2
		JRST .+1]
	FINDA B,[A$RHST,,[A]]	; Get dest attrib
	 SKIPA C,OWNHST		; No A$RHST means local
	  MOVE C,LISTAR(B)+1	; Get host #
	EXCH A,B
	PUSH P,B		; HSTSRC clobbers
	MOVE A,[440700,,TMPNAM]	; Buffer in which to stick hostname
	MOVE B,C		; Host#
	CALL RESOLV"HSTSRC	; Get ASCIZ string in A (horribly inefficient
				;  with domains, oh well, fix it later)
	 SKIPA A,[6]		; Unknown, will use number, assume 6 chars long
	  CALL LASCIZ		;  Get length
	POP P,B
	EXCH A,B		; Now have # chars in hostname in B.
	FINDA D,[A$RNAM,,[A]]	; Get rcp name attrib
	 JSR AUTPSY
	MOVEM D,TPTMP1		; Save for printout
	HLRZ D,LISTAR(D)+1	; Get # chars in rcpt name
	ADD B,D			; Add into cnt.
	FINDA D,[A$RTYP,,[A]]	; See if type exists.
	 JRST TOPUT3		; Nope, no need to count that.
	SLNEA D,[ASCNT [NAME]]
	 CAIA
	  JRST TOPUT3
	HLRZ D,LISTAR(D)+1	; Count rcpt type string.  Get # chars
	ADDI B,3(D)		; Plus 3 for parens & separating space.
TOPUT3:	ADDI B,4		; Plus 4 for " at "
	JUMPLE E,TOPUT4		; If nothing on line, jump...
	ADDI E,2(B)		; Add 2 for ", " and add into total for line
	CAIGE E,72.		; Line too big now?
	 JRST TOPUT6		; Nope, is OK... go output.
	OUT(TMPC,EOL)		; Must start new line... give CRLF.
TOPUT4:	MOVEI E,4(B)		; Install new count.
	SKIPE TOPASS
	 OUTCAL(TMPC,("CC: "))
	SKIPN TOPASS
	 OUTCAL(TMPC,("To: "))
	CAIA
TOPUT6:	 OUTCAL(TMPC,(", "))
	CALL RTOS		; Output short form of rcpt.
	JRST TOPUT2		; get another item

	;; Items all gone.
TOPUT8:	CAILE E,0		; If anything was on line,
	 OUTCAL(TMPC,EOL)	;  CRLF it.
	SKIPN TOPASS
	 JRST [SETOM TOPASS ? JRST TOPUT1]
TOPUT9:	POPAE P,[E,D,C,B,A]
	RET

	;; RCPT LIST NAME exists.
TOPUT7:	FWRITE TMPC,[[To: ],TLS,A,[
]]
	SETOM TOPASS
	JRST TOPUT1

; RTOS - Recipient Type-Out, Short.  Takes LP in A to a rcpt's list
;	and outputs on TMPC its short representation:
;	If type NAME, outputs "NAME at SITE."
;	Otherwise, "(TYPE NAME) at SITE".
; RTOSS - RTOS, Shorter.  Similar, but uses "@" instead of " at ".

RTOS:	TRZA F,%TMP		; Use random flag for distinction.
RTOSS:	 TRO F,%TMP
	PUSHAE P,[B,C]
	FINDA C,[A$RNAM,,[A]]
	 JSR AUTPSY
	FINDA B,[A$RTYP,,[A]]
	 JRST RTOS10		; No type, don't need to parenthesize!
	SLNEA B,[ASCNT [NAME]]	; Has one, check it.
	 CAIA
	  JRST RTOS10		; If NAME, also don't need parens.
	FWRITE TMPC,[[(],TLS,B,[ ],TLS,C,[)]]
	JRST RTOS11
RTOS10:	FWRITE TMPC,[TLS,C]
RTOS11:	TRNE F,%TMP
	 OUTCAL(TMPC,C("@))
	TRNN F,%TMP
	 OUTCAL(TMPC,(" at "))
	FINDA B,[A$RHST,,[A]]
	 SKIPA B,OWNHST
	  MOVE B,LISTAR(B)+1
	FWRITE TMPC,[HST,B]
	POPAE P,[C,B]
	RET

; RTOL - Recipient Type-Out, Long form.  Given LP to rcpt's list in A,
;	outputs on TMPC its representation in long form as follows:
;	(TYPE NAME @SITE (ATTRIB X) (ATTRIB Y)...)
;	This may get used in an internal ITS sending scheme, but at the moment
;	it is not called from anywhere.

RTOL:	PUSHAE P,[B,C]
	OUT(TMPC,LPAR)
	FINDA B,[A$RTYP,,[A]]
	 JRST [	OUT(TMPC,("NAME"))
		JRST .+2]
	OUT(TMPC,TLS(B),SP)
	FINDA B,[A$RNAM,,[A]]
	 JSR AUTPSY
	OUT(TMPC,TLS(B),SP)	; Output name...
	FINDA B,[A$RHST,,[A]]
	 SKIPA B,OWNHST
	  MOVE B,LISTAR(B)+1
	FWRITE TMPC,[[@],HST,B,]

	; Now the messy part - must have rtn that slobbers through a list
	; outputting all input-able attributes in right format.  In this
	;case, must use a suppress-list including A$RHST, A$RNAM, and A$RTYP.


	OUT(TMPC,RPAR)		; For time being...
	POPAE P,[C,B]
	RET

; STOPUT - forms 'To:' lines from existing A$RCP's.
; Ignores those recipients with attributes of OPTION NOSHOW.

LVAR  STCC:	0		; nonzero if doing cc:'s

STOPUT:	PUSHAE P,[A,B,C,D,E]
	SETZM STCC		; Do To:'s
	FINDA A,[A$RLN,,[$LLLST(L)]]	;see if recipient list name exists
	 JRST STPUT1
	OUT(TMPC,("To: "),TLS(A),EOL)
	JRST STPUT9

	; SCCPUT - Like STOPUT but for cc:'s.
.SCALAR TPTMP1

SCCPUT:	PUSHAE P,[A,B,C,D,E]	; save ACs
	SETOM STCC		; do cc:'s

STPUT1:	SETZM RCSQCT		; initialize RCPSEQ routine
	MOVEI E,0		; zero count of characters on line
STPUT2:	CALL RCPSEQ		; get ptr to recipient attribute list
	 JRST STPUT8		; no more recipients to get

	FNDSTR B,A,A$ROPT,[NOSHOW]	; supposed to suppress?
	 CAIA
	  JRST STPUT2		; yes, skip this recipient

	FNDSTR B,A,A$ROPT,[CC]	; cc?
	 JRST [	SKIPE STCC	; no, if "To" pass then do it
		 JRST STPUT2
		JRST .+2]
	JRST [	SKIPN STCC	; yes, if "To" pass then ignore it
		 JRST STPUT2
		JRST .+1]
	FINDA B,[A$RHST,,[A]]	; Get destination attribute
	 SKIPA C,OWNHST		; No A$RHST means local
	  MOVE C,LISTAR(B)+1	; Get host no.
	EXCH A,B
	PUSH P,B		; HSTSRC clobbers
	MOVE A,[440700,,TMPNAM]	; Put ASCIZ string here
	MOVE B,C		; Host#
	CALL RESOLV"HSTSRC	; Get addr of ASCIZ string in A (ha, ha)
	 SKIPA A,[6]		; Unknown, will use number, assume 6 chars long
	  CALL LASCIZ		;  Get length
	POP P,B
	EXCH A,B		; Now have # chars in hostname in B.
	FINDA D,[A$RNAM,,[A]]	; Get recipient name attribute
	 JSR AUTPSY
	MOVEM D,TPTMP1		; Save for printout
	HLRZ D,LISTAR(D)+1	; Get no. characters in recipient name
	ADD B,D			; Add into count
	FINDA D,[A$RTYP,,[A]]	; See if type exists
	 JRST STPUT3		; Nope, no need to count that
	SLNEA D,[ASCNT [NAME]]
	 CAIA
	  JRST STPUT3
	SLNEA D,[ASCNT [BUG]]
	 CAIA
	  SKIPA D,[1]		; hacky way of getting BUG- to be length 4
	HLRZ D,LISTAR(D)+1	; Count recipient type string.  Get no. of characters
	ADDI B,3(D)		; Plus 3 for parens and separating space
STPUT3:	ADDI B,3		; Plus 3 for " at "
	JUMPN E,STPUT4		; If nothing on line, jump...
	SKIPN STCC
	 OUTCAL(TMPC,("To: "))
	SKIPE STCC
	 OUTCAL(TMPC,("cc: "))
	MOVEI E,4(B)		; Install new count
	JRST STPUT7
STPUT4:	ADDI E,2(B)		; Add 2 for ", " and add into total for line
	CAIL E,72.		; Line too big now?
	 JRST STPUT5		; Nope, is OK... go output.
	OUT(TMPC,(", "))
	JRST STPUT7
STPUT5:	OUT(TMPC,(",
    "))
	MOVEI E,4(B)		; Install new count
STPUT7:	CALL SRTO		; Output short form of recipient
	JRST STPUT2		; get another item

; Items all gone.
STPUT8:	CAILE E,0		; if anything was on line
	 OUTCAL(TMPC,EOL)	; then CRLF
STPUT9:	POPAE P,[E,D,C,B,A]
	RET


; SRTO - RFC822 recipient Type-Out.  Takes LP in A to a recipient's list
;	and outputs on TMPC its short representation:
;	If type NAME, outputs "NAME@SITE".
;	If type BUG, outputs "BUG-NAME at SITE".
;	Otherwise, "(TYPE NAME) at SITE".

SRTO:	PUSHAE P,[B,C]
	FINDA B,[A$RNAM,,[A]]
	 JSR AUTPSY
	CALL SCHECK
	TRNE F,%TMP		; need to quote string?
	 OUTCAL(TMPC,C(""))	; yes, output openning quote
	FINDA C,[A$RTYP,,[A]]
	 JRST SRTO3		; No type, don't need to parenthesize!
	SLNEA C,[ASCNT [NAME]]	; Has one, check it.
	 CAIA
	  JRST SRTO3		; If NAME, also don't need parens.
	SLNEA C,[ASCNT [BUG]]
	 CAIA
	  JRST SRTO2

;Putting quotes around complex (list form) recipients is a misfeature.
;It makes the syntax more standard but it makes it impossible to
;reply-parse it.  Presumably complex recipients don't normally go to
;random non-ITS hosts anyway.
;	TRON F,%TMP		; already output a quote?
;	 OUTI TMPC,""		; no, output a quote now
	FWRITE TMPC,[[(],TLS,C,[ ],TLS,B,[)]]
	JRST SRTO4

SRTO2:	OUT(TMPC,("BUG-"))
SRTO3:	TRNN F,%TMP
	 JRST [	OUT(TMPC,TLS(B))
		JRST SRTO4 ]
	  CALL STLS
SRTO4:	TRNE F,%TMP		; need to close quote?
	 OUTCAL(TMPC,C(""))	; yes, output closing quote
	FINDA B,[A$RHST,,[A]]
	 SKIPA B,OWNHST
	  MOVE B,LISTAR(B)+1	;Get host address in B.
	CAME B,OWNHST		;If this is some random host
	 JRST SRTO5		; output normally
	SKIPE HDRGAT		;Else may want to do the % hack.
	 JRST [	OUT(TMPC,("%"),HST(B),("@"),TZ(GATNAM))
		JRST SRTO9  ]
SRTO5:	OUT(TMPC,("@"),HST(B))
SRTO9:	POPAE P,[C,B]
	RET

; SCHECK - Set %TMP if the string in B contains special characters.
SCHECK:	PUSHAE P,[A,B,C]	; save ACs
	TRZ F,%TMP
	MOVE A,LISTAR(B)+1
	ADD A,$LSLOC(L)
	HLRZ B,A		; length
	HRLI A,440700		; B.P.
	JUMPE B,SCHK2		; the null string contains no specials
SCHK1:	ILDB C,A		; get next character
	CALL SCHK4		; test character
	 TROA F,%TMP		; character is special
	  SOJG B,SCHK1
	CAIN C,"@		; If the string ends in an atsign
	 TRO F,%TMP		; quote it (for BUG-@ to non-ITS hosts)
SCHK2:	POPAE P,[C,B,A]		; restore ACs
	RET

; SCHK4 - Skips if character in C is not special.
SCHK4:	CAIE C,"<
	 CAIN C,">
	  RET
	CAIE C,"(
	 CAIN C,")
	  RET
	CAIE C,":
	 CAIN C,";
	  RET
	CAIE C,"@
	 CAIN C,",
	  RET
	CAIE C,";
	 CAIN C,":
	  RET
	CAIE C,""
	 CAIN C,"\
	  RET
	CAIE C,"[
	 CAIN C,"]
	  RET
	AOS (P)
	RET


; STLS - Output string in B with quoting for \ and ".
STLS:	PUSHAE P,[A,B,C]	; save ACs
	MOVE A,LISTAR(B)+1
	ADD A,$LSLOC(L)
	HLRZ B,A		; length
	HRLI A,440700		; B.P.
	JUMPE B,STLS2
STLS1:	ILDB C,A
	CAIE C,""
	 CAIN C,"\
	  OUTCAL(TMPC,C("\))
	OUT(TMPC,C((C)))
	SOJG B,STLS1		
STLS2:	POPAE P,[C,B,A]
	RET

; TXTCHK - Routine to quickly munch through text looking for either ^_'s or
;	 CRLF.CRLF's, and set message-text flag (A$MTXF) appropriately. 

TXTCHK:	PUSHAE P,[A,B]
	MOVEM 16,AC16S
	MOVE 16,[1,,ACSAV]
	BLT 16,AC16S-1		;save accs
	FINDA A,[A$MTXT,,[$LLLST(L)]]
	 JSR AUTPSY
	MOVE A,LISTAR(A)+1	;cnt and ptr
	ADD A,$LSLOC(L)		;absolute addr
	HLRZ B,A
	ADDI B,4
	IDIVI B,5
	MOVN B,B
	HRL A,B			;aobjn complete.
	PUSH P,A		; Save it.
	MOVE C,[TXTCKR,,E]
	BLT C,E+TXTCKL-1
	SETZ C,
	JRST E

TXTCH3:	PUSH P,A
	PUSH P,B
	HRRZ A,A	;get addr
	ADD A,TXTCTB(B)	;get ptr to offending period
	MOVEI B,",	;get replacement char
	DPB B,A		;replace it
	POP P,B
	POP P,A
	JRST E+6	;continue

TXTCH2:	MOVE 16,[ACSAV,,1]
	BLT 16,16	;restore accs
	MOVE 16,AC16S
	POP P,A		; Restore AOBJN ptr to text.

	MOVE B,(A)	; Check for a message starting with  ".<CRLF>"
	AND B,[777777,,700000]
	CAME B,[ASCII/.
/]
	 JRST TXTC30
	MOVSI B,(ASCII/./#ASCII/,/)
	XORM B,(A)	; CLOBBER THE "." TO A "," VIA GROSS KLUDGE!


	; Loop to see if any ^_'s exist in text.
TXTC30:	MOVE B,(A)
	XOR B,[.BYTE 7 ? ^_ ? ^_ ? ^_ ? ^_ ? ^_ ]
	TLNN B,774000
	 JRST TXTC35	; Yup, found one.
	TLNN B,3760
	 JRST TXTC35	; etc
	TDNN B,[17,,700000]
	 JRST TXTC35
	TRNN B,77400
	 JRST TXTC35
	TRNN B,376
	 JRST TXTC35
	AOBJN A,TXTC30
	JRST TXTC40		; None found...
TXTC35:	MAKELN A,[A$MTXF,,[$LLLST(L)]
		%LTVAL,,0]
	MOVEM A,$LLLST(L)
TXTC40:	POPAE P,[B,A]
	RET

TXTCKR:
	OFFSET E-.	; Start following code at E.
TXTLUP::MOVEI B,5	;at e, set up char cnt
	MOVE D,(A)	;e+1  get a word from txt
TXTLP2::LSHC C,7	;e+2  shift a char into c
	TLZ C,400000	;e+3  bump off sign bit
	CAMN C,TXTCMS	;e+4  found nasty string yet? (crlf.crlf)
	 JRST TXTCH3	;e+5  arg! yes, go correct it
	SOJG B,TXTLP2	;e+6  no, shift all of new word in (eventually)
	AOBJN A,TXTLUP	;e+7  try all wds of msg txt
	JRST TXTCH2	;e+10 (15)  finally exit
TXTCMS::<ASCII /
.
/>_-1			;e+11 (16) comb. to search for, right adjusted=crlf.crlf
	OFFSET 0	; Restore normal Loc Counter.
TXTCKL==.-TXTCKR


TXTCTB:	0	;add-in ptrs to get ptr to period, period in 3rd char position
	170700,,0	;b=1, period was in 3rd pos. of d
	260700,,0	;b=2, . was in 2nd pos. of d
	350700,,0	;b=3, . in 1st pos. of d
	010677,,-1	;b=4, . in 5th pos. of c (this gives 10700,,.-1)
	100677,,-1	;b=5, . in 4th pos. of c (this gives 100700,,.-1)

BVAR
ACSAV:	BLOCK 15	;saves only acs 1-16
AC16S:	0		;need to save the blt-ptr acc. 'manually'
EVAR
SUBTTL Recipient list crunchers
; RCPSRT - sorts rcpts on a msg list by destination site, so
;	that local are 1st, and rcpts are bunched by site.  bubble sorts...

RCPSRT:	PUSHAE P,[A,B,C,D,E]

RSORT1:	SETZ A,				; Clear exch flag
	FINDA E,[A$RCP,,[$LLLST(L)]]
	 JRST RSORT7			; No rcpts at all?  Tolerate...
	FINDA C,[A$RHST,,[LISTAR(E)+1]]
	 SKIPA C,[0]
	  MOVE C,LISTAR(C)+1
	CAMN C,OWNHST
	 SETZ C,		; Make sure all local site refs are made zero

RSORT2:	MOVE B,C
	MOVE D,E			; Make previous n+1th now nth.
	HRRZ E,LISTAR(D)		; Get ptr to next
	FINDA E,[A$RCP,,[E]]		; And advance to next rcpt
	 JRST RSORT7			; Hmm, none left this pass
	FINDA C,[A$RHST,,[LISTAR(E)+1]]	; Now get ptr for n+1-th rcpt site
	 SKIPA C,[0]
	  MOVE C,LISTAR(C)+1		; Get site #
	CAMN C,OWNHST
	 SETZ C,

	; Now compare!
	CAMG B,C		; Skip to exchange if nth greater than n+1th
	 JRST RSORT2		; Else continue.

	; Aha, exchange.
	MOVE A,LISTAR(D)+1		; Get A$RCP list ptr
	EXCH A,LISTAR(E)+1		; Swap with n+1th
	MOVEM A,LISTAR(D)+1		; Ptrs now swapped!
	EXCH B,C			; And exch site #'s.
	JUMPN A,RSORT2			; Continue, unless
	JSR AUTPSY			; gross error in A$RCP LN!

RSORT7:	JUMPN A,RSORT1		; Do another pass, til nothing exchanged.
	POPAE P,[E,D,C,B,A]
	RET



; RCPSEQ - returns ptr to a rcp attrib list.  successive calls
;	after initializing will return rcps in sequence.  since list is
;	supposed to have been sorted, first are returned all rcpts with
;	lowest dest host numbers, then next lowest, etc.
;	skips on success, fails when none left

BVAR
RCSQCT:	0		; When this (current LP) zeroed, RCPSEQ initializes self.
RCSQLT:	0		;holds ptr to next LN (cdr of rcsqct)
EVAR

RCPSEQ:	SKIPN RCSQCT
	 JRST [	MOVE A,$LLLST(L) ;initialize
		MOVEM A,RCSQLT
		SETOM RCSQCT
		JRST .+1]
	SKIPG A,RCSQLT
	 RET			;0, none left.
	FINDA A,[A$RCP,,[A]]
	 RET			;none left
	PUSH P,B
	HRRZ B,LISTAR(A)	;get cdr for next call
	MOVEM B,RCSQLT
	MOVE A,LISTAR(A)+1	;return ptr to rcpt list
	POP P,B
	AOS (P)
	RET

; UHDPUT - Output user-specified header lines, verbatim. 
;	By including a USER-HEADER: line in the request file, the user program
;	sending the mail can have an arbitrary line inserted into the header.
;	This lets it send mail containing header fields of types that COMSAT
;	does not especially know about, such as In-Reply-To.  There can be any
;	number of USER-HEADER lines in a single mail request. (Here we output
;	them in reverse order so that they appear in the same order as the
;	user specified originally.)

UHDPUT:	PUSHAE P,[B,C]		;Return LP value in A.
	MOVE A,$LLLST(L)	;Get LP to message.
	SETZ B,			;Count of user-headers.
UHDP10:	FINDA A,[A$UHDR,,[A]]	;Look for a user-header SLP.
	 JRST UHDP20		; Not found.
	PUSH P,A		;Stack it up.
	AOS B			;Count it.
	HRRZ A,LISTAR(A)	;CDR ptr to next.
	JRST UHDP10		;Go after it.

UHDP20:	JUMPE B,UHDP90		;If there were any USER-HEADERs
	MOVE C,A		; stash ptr to rest of message.
UHDP21:	POP P,A			; Unwind stack of SLPs, outputting them.
	FWRITE TMPC,[TLS,A,[
]]
	SOJG B,UHDP21		; All the way.
	MOVE A,C		; Recover LP.
UHDP90:	POPAE P,[C,B]
	RET




SUBTTL Recipient Name Equivalencing

;;;   Equivalence-table hackery

; RCPEXP - Routine that attacks current LSE as a list of message attribs
;	and expands all rcpt LN's as specified by such things as EQV
;	and LSR file data.  

RCPEXP:	PUSHAE P,[A,B,C,D]
	MOVE D,$LLLST(L)	;put LP in D to step thru
	CSTAT (,("EXP-"),RABR)
	TRO F,%NOCOM		;set helping flag for stats
RCPXP1:	FINDA D,[A$RCP,,[D]]	;find rcpt from this pt
	 JRST RCPXP9		;no more, done
	MOVE C,D		; Found one.  Put LP in C, and
	HRRZ D,LISTAR(D)	; get CDR for next pass

	; C has LP to a rcpt LLN to be expanded.  Take it off attrib list,
	; and stuff resulting rcpts back on front of attrib list.

	MOVE A,LISTAR(C)+1	;get ptr to attrib list of the rcpt.
	SETZM LISTAR(C)+1	; and flush main list's pointer to it,
	LNDEL C,$LLLST(L)	; So that it's not flushed along with A$RCP LN!
	SETZM LSTSUP		;set flag to deafult to suppress listing of eqvlist
	SETZM RCPSLF		;clear forced-rcpt ptr
	SETZM RCPSLT		;and ptr to its type
	SETZM RCPSLP		;and ptr to its list qb
	SETZM RCPSLA		;and ptr to any list needing copying for descendants
	CALL RCPPUT		;crunch it onto msg attrib list!
	JRST RCPXP1		;continue...

RCPXP9:	CALL RCPSRT		;sort the resulting msg-attrib list.
	POPAE P,[D,C,B,A]
	RET

.SCALAR LSTSUP	; Flag to suppress listing of rcpts


; RCPPUT - Takes rcp attrib list, and stuffs it onto rcp-list
;	   if it checks out via equivalence table.  
;	   Has side effects such as checking for *<site> MSG 
;	   distribution specs and BUG-'s.  
;	   Also, if recipient is on ONWHS2, mutates A$RHST to OWNHST.
;	   Recursive, so must save everything on stack!

RCPPUT:	PUSHAE P,[A,B,C,D,RCPSLF,RCPSLT,RCPSLP,RCPSLA,RCPTRC]
	MOVEI B,(P)		; Saved RCPTRC
	HRL B,A
	MOVEM B,RCPTRC
	FINDA B,[A$RNAM,,[A]]
	 JSR AUTPSY
	FINDA C,[A$RHST,,[A]]	; Get host.
	 SKIPA C,OWNHST		;  If none, use OWNHST.
	  MOVE C,LISTAR(C)+1	; Else get host address.
	CAMN C,OWNHS2		; Identity crisis?
	 MOVE C,OWNHST		;  Yes, change host to connected net.
	EXCH A,B
	CAMN C,OWNHST		; Our own host?
	 CALL SLNUPR		; If rcpt on local host, make name uppercase.
	EXCH A,B
	TRZN F,%NOCOM		
	 OUTCAL(SC,(","))
	FINDA D,[A$RTYP,,[A]]	; If special rcpt type, so indicate in stats.
	 JRST RCPP20
	SLNEA D,[ASCNT [NAME]]
	 CAIA
	  JRST RCPP20
	CSTAT (,LPAR,TLS(D),(" "),TLS(B),RPAR,("@"),HN(C))
	JRST RCPP21

RCPP20:	CSTAT (,TLS(B),("@"),HN(C))	; Record name@host#
	SETZ D,			; Type is ordinary "NAME"
RCPP21:	CALL RCPE		; Rcpblk name already in rcplist?
	 CAIA			;  Yes.
	  JRST RCPP25
	SKIPE RCPSLF		; Found it. Must check parent?
	 CAME C,OWNHST		;  Must check, see if local first.
	  JRST RCPP99		;   No, ignore.
	SLNE B,RCPSLF		; Matching names?
	 JRST RCPP99		;  No, ignore.
	JUMPN D,[SKIPE RCPSLT	; Match types also
		  SLNE D,RCPSLT	;  If not same type,
		   JRST RCPP99	;   ignore.
		 JRST .+1]
	SKIPE RCPSLT		; If matched, force this rcpt into list.
	 JRST RCPP99
RCPP25:	;; From here on D is a flag: -1 => This is pseudo-recipient, expand it.
	SETZ D,			; Zero D as flag
	CAME C,OWNHST		; Local?
	 JRST RCPP10		;  No, store it and return. D=0.
RCPP30:	;; Local rcpt (ptr in A to rcpt's attrib list, in B to name-string LN)
	;; Check options and equivalency.
	PUSH P,A		; Save rcpt. attrib. list
	FINDA B,[A$RTYP,,[A]]	; Find type of rcpt
	 JRST [	SETZ B, ? JRST RCPP31]
	MOVE B,LISTAR(B)+1
	ADD B,$LSLOC(L)		; Get abs SPT or zero for type.
RCPP31:	FINDA A,[A$RNAM,,[A]]	; Now get name.
	 JSR AUTPSY
	MOVE A,LISTAR(A)+1
	ADD A,$LSLOC(L)		; Make abs SPT to that too.	
	CALL RCPEQV		; Find if on EQV list.
	 JRST [	POP P,A		;   Nope...
		JRST RCPP39]
	MOVE B,A		; Save returned pointer in B
	POP P,A			; and restore LP to rcpt's list.
	JRST RCPP60		; Go handle EQV list.

	;; Not found on EQV. (Sometimes, fake up an EQV entry
	;; and continue as if he HAD been found on EQV!)
RCPP39:	FINDA B,[A$RTYP,,[A]]	; Find its type...
	 JRST RCPP72		; None, assume NAME, go check INQUIR.
	SLNEA B,[ASCNT [NAME]]
	 CAIA			; nope.
	  JRST RCPP72		; Type NAME, go check INQUIR.

	SLNEA B,[ASCNT [BUG]]	; BUG?
	 JRST RCPP42
	CALL RXPBUG		;no option or eqv list. try BUG translation
	 JSR AUTPSY		; Should always eqv to something!!
	JRST RCPP60		; Ah so.

RCPP42:	SLNEA B,[ASCNT [@FILE]]	; Indirect through file?
	 JRST RCPP09		; Give up if not this either.
	CALL RXPAFL		; Aha, go to expand file!
	JRST RCPP6		; Make indirect-file spec a pseudo, and
				; go handle returned eqv-list in B if any.

	;; Come here when we have managed to EQV to something.
	;; Original rcpt. attrib. list in A, EQV list in B.
	;; The first order of business is to take random options at the
	;; top level of the list in B, and put them on to A.  
	;; Note: B is not the a$rcp but its car, i.e. a chain of both
	;; options and A$RCP LLN's which are EQV-LISTs.
	;; Note further that if B = 0 it means that the recipient is to
	;; be made pseudo, but not expanded.  (and likewise it has no options).

RCPP60:	JUMPE B,RCPP6		; Check for explicit flushing, jump if so.
	PUSHAE P,[B,D]
	MOVE D,$ARLOC+EQVAR	; Reference EQVAR now...
	EXCH D,L		; Save current area, reference EQVAR.
	CAIA
RCPP61:	 HRRZ B,LISTAR(B)	; Get CDR to next thing on EQV list.
	JUMPE B,RCPP69
	LDB C,[$LAFLD,,LISTAR(B)]
	CAIE C,A$RTYP		; Ignore type attribute.
	 CAIN C,A$RCP		; Ignore EQV-LISTs, they get hacked later.
	  JRST RCPP61		; 
	CAIE C,A$RNAM		; Also ignore recipient-name,
	 CAIN C,A$RHST		; and site spec.
	  JRST RCPP61
	EXCH D,L		; Restore normal LSE
	LNCOPY C,[D ? B]	; Copy from EQVAR to normal LSE.
	HRRM A,LISTAR(C)
	HRRZ A,C
	EXCH D,L		; Restore EQV for reference...
	JRST RCPP61		;continue after consing onto attr list

RCPP69:	EXCH D,L		; When done, restore right LSE reference.
	MAKELN D,[A$ROK,,0
		%LTVAL,,0]
	LNAPP [B ? D]		; Append "relay ok" attrib to rcpt's list.
	POPAE P,[D,B]
	;--------------------

; Now we have the enhanced rcpt attrib list in A, and the original
;   EQV list in B.  Now decide whether to actually do expansion or not.
; Currently this is a half hearted attempt to do "right" thing when
; some loser does :QSEND BUG-FOO.

RCPP05:	FINDA C,[A$RMDS,,[A]]	;does rcpt have send-switch?
	 JRST RCPP04
	SKIPLE LISTAR(C)+1	; has switch... always mailing too?
	 JRST RCPP04		; Yes, so expand list.
	FINDA C,[A$RTYP,,[A]]	; May not ever mail; check type
	 JRST RCPP10		; Default to NAME - don't expand list.
	SLNEA C,[ASCNT [NAME]]
	 JRST RCPP04		; Not type NAME, so DO expand list.
	JRST RCPP10		; NAME - don't expand list further.

	;get both ptr to a name's eqvlist and its options, whichever.
	;first insert options then expand eqvlist;
	;if eqv-list exists, 1)gives it attrib of psuedo-name,
	;2) if showlist attrib exists, gives it no-show.

RCPP04:	PUSH P,L
	MOVE L,$ARLOC+EQVAR	; Temporarily set LSE to EQV for search.
	FINDA C,[A$RCP,,[B]]	;see if it has eqv-list
	 JRST [	POP P,L ? JRST RCPP70]	;no, tis atomic w/options, check INQUIR
	POP P,L
	FINDA C,[A$RNAM,,[A]]	;get name of current rcpt to check with parent
	 JSR AUTPSY
	SLNE C,RCPSLF		;compare with parent
	 JRST RCPP6		;nope, not same, continue.
	FINDA D,[A$RTYP,,[A]]	;also compare the types
	 JRST .+3
	  SLNEA D,[ASCNT [NAME]]
	   JRST [ SKIPE RCPSLT
		   SLNE D,RCPSLT
		    JRST RCPP6	;not same type
		  JRST .+3 ]	;winning, skip FIND-failed case
	 SKIPE RCPSLT
	  JRST RCPP6		;not same type
	SETZM RCPSLF		;ah, same! parent refers to self...clear,
	MOVE D,RCPSLP		;get ptr to parent's A$RCP,
	MOVE D,LISTAR(D)+1	;get its list ptr to attribs,
	MAKELN C,[A$ROPT,,0	;and make a flag LN to add on, such that
		%LTSTR,,[LITSTR [NO-CLI]]] ;it means "no cli" for this name.
	LNAPP [D ? C]		; Append onto its attrib list.
	SETZM RCPSLP		;clear ptr used just in case (like rcpslf)
	SETZ D,			;indicate atomic
		;and go store the rcpt as atomic, with given options.
		;if found again, won't be stored again since rcpslf cleared.

	; Come here for an atomic rcpt which needs to be checked out
	; in the INQUIR database.
RCPP70:	FINDA C,[A$RTYP,,[A]]	; Here when rcpt was seen in EQV; "known".
	 JRST RCPP71		; Must make sure that it's type NAME.
	SLNEA C,[ASCNT [NAME]]
	 JRST RCPP09		; Nope, don't check INQUIR!!
RCPP71:	SKIPA B,[-1]		; Indicate to RXPNAM that name was in EQV.
RCPP72:	 SETZ B,		; Here when rcpt not in EQV - "unknown".
	CALL RXPNAM		; Check it out.
	 JRST RCPP09		; Now truly atomic, store it.
	JRST RCPP60		; Hmm, got eqv'd! Go process returned eqv-list.

RCPP6:	JUMPE B,[CSTAT (,("::={IGNORED}"))	; Pseudo-ing without eqv'ing.
		JRST RCPP6Y]
	CSTAT (,("::="),LPAR)
	TRO F,%NOCOM		;don't output comma in next stat stuff
RCPP6Y:	SETO D,			;set flag to process eqv-list later.
	MAKELN A,[A$RPSN,,[A]	;indicate rcp is psuedo - attach pseudo attrib
		%LTVAL,,[JUNK]]
	FNDSTR C,A,A$ROPT,[SHOWLIST]	;does psuedo have showlist option?
	 JRST RCPP10		;no, means show psuedoname, suppress its list
				;yes, don't show psuedo (but show list)
	JRST RCPP11		;skip any duplicate noshow option

	;; Store attrib list for this rcpt on rcp list
RCPP09:	SETZ B,			; No EQV list.
RCPP10:	SKIPE LSTSUP		; Hack suppression option.
RCPP11:	 MAKELN A,[A$ROPT,,[A] ? %LTSTR,,[LITSTR [NOSHOW]]]
	SKIPE RCPSLA				;anything need copying onto it?
	 JRST [	LNCOPY C,[0 ? SETZ RCPSLA]
		LNAPP [A ? C]			; Copy & append on.
		JRST .+1]
	MOVEM A,RCPTR				;save for later use
	MAKELN A,[A$RCP,,[$LLLST(L)]		;make list LN for it and plug on list
		%LTLST,,[A]]
	MOVEM A,$LLLST(L)			;now officially on list.

	AOS RCPNUM		;increment # of names in area
	JUMPN D,RCPP50		;if d=-1 then psuedo, don't increment rrcps,hack further.
	AOS RRCPS		;increment # of atomic recipients
RCPP99:	POPAE P,[RCPTRC,RCPSLA,RCPSLP,RCPSLT,RCPSLF,D,C,B,A]
	RET

.SCALAR RCPTR	; Temp var

	;here, handle a psuedo-name. b contains ptr to eqv list.
RCPP50:	JUMPE B,RCPP99			; ignore totally if nothing.
	MOVEM A,RCPSLP			;store ptr to pseudo's A$RCP LN.
	MOVE C,RCPTR			;get ptr to attrib-list back.
	FINDA D,[A$RNAM,,[C]]
	 JSR AUTPSY
	MOVEM D,RCPSLF			;store ptr to name of parent of this list.
	SETZM RCPSLT			;also store type (ptr or zero if NAME)
	FINDA D,[A$RTYP,,[C]]
	 CAIA
	  JRST [ SLNEA D,[ASCNT [NAME]]
		  MOVEM D,RCPSLT
		 JRST .+1 ]
	FINDA D,[A$RMDS,,[C]]		;see if A$RMDS attrib exists, if so must
	 JRST RCPP51			;  ensure that it gets copied for descendants.
	LNCOPY D,[0 ? D]
	HRL D,RCPSLA			;push onto RCPSLA list.
	HLRM D,LISTAR(D)
	HRRZ D,RCPSLA
RCPP51:	FINDA D,[A$RMDM,,[C]]		;see if A$RMDM attrib exists, if so must
	 JRST RCPP53			;  ensure that it gets copied for descendants.
	LNCOPY D,[0 ? D]		;just like A$RMDS
	HRL D,RCPSLA			;push onto RCPSLA list etc
	HLRM D,LISTAR(D)
RCPP53:	SKIPE LSTSUP			;under suppression?
	 JRST RCPP52			;yes, don't bother trying to suppress again
	FNDSTR C,C,A$ROPT,[SHOWLIST]	;supposed to show list?
	 JRST [	SETOM LSTSUP
		CALL RCPEXT		;no, hence set 'noshow' for expansion items
		SETZM LSTSUP		;restore
		JRST RCPP55]

RCPP52:	CALL RCPEXT		;takes arg in a, puts the eqv blocks into rcp list.
RCPP55:	CSTAT (,RPAR)
;	SKIPE A,RCPSLA		;if a list was being copied from RCPSLA,
;	 CALL QBFREE		;free it. (but not yet.. this will lose by clobbering
				;parent's version of RCPSLA!)
	JRST RCPP99		;(note rcpext calls rcpput recursively!)

BVAR
RCPSLF:	0	;if non-z holds ptr to name which (if found) is to be forced into list
		;irregardless of previous existence or psuedoness.
RCPTRC:	0	;linked list of A$RCP LN,,thread for rcpt expansion recursion
RCPSLT:	0	;ptr to type of name in RCPSLF (zero if type=NAME)
RCPSLP:	0	;holds ptr to A$RCP LN of above pseudo.
RCPSLA:	0	;holds ptr to list of stuff which needs copying onto attrib list of
EVAR		;descendants for a rcpt. (if it is eqv'd)

; RCPEXT - takes LP to eqvlist in B, inserts all the A$RCP's into the
;	attrib list.  Mainly involves copying.

RCPEXT:	PUSHAE P,[A,B,C]
	MOVE C,$ARLOC+EQVAR	; Set up for swapping LSE's
	EXCH C,L		; L gets EQVAR, C gets ex-current 
	CAIA
RCPXT1:	 HRRZ B,LISTAR(B)	; CDR to next thing on EQV list
	FINDA B,[A$RCP,,[B]]	;pluck one off list
	 JRST RCPXT9		;done when no more
	EXCH C,L		; Get normal LSE back
	LNCOPY A,[C ? SETZ LISTAR(B)+1]	; Copy what EQV-rcpt points to and leave LP in A
	CALL RCPPUT		;and put it in. (yup, corecursive)
	EXCH C,L		; Get EQV back.
	JRST RCPXT1

RCPXT9:	EXCH C,L		; Restore normal LSE.
	POPAE P,[C,B,A]
	RET


; Set SHITSW==1 to use HSNAME hackery.
IFNDEF SHITSW,SHITSW==1

IFE SHITSW,[
; The RXPNAM routine is called when sending to a NAME-type rcpt who is
;   not found in the EQV.  The algorithm is:
; 0) If the name has > 6 characters, goto 3.
; 1) If he is a UNAME in the LSR file,then
;   A)	If he has has a net address field, translate to that,
;   B)  else just send to him.
; 2) If he has a file in (INIT), a file in _MSGS_, or a directory,
;	then send to him.
; 3) Look him up as a lastname in LSR1.  If found,  translate to all
;	entries in LSR1 with that last name.
; 4) Else sender probably mistyped.  Send the mail, but also send a warning
;	to the sender and to "FAILED".
] ;END IFE SHITSW
IFN SHITSW,[
COMMENT |
	The RXPNAM routine is called during equivalence-expansion of
the recipient list of a message, for each NAME-type rcpt
which is not found in the EQV file, so as to determine ultimate
mailbox name.  Algorithm is:

[1] If name has > 6 chars, it can't be a UNAME, so:
	1a. If name exists as a lastname in LSR, return eqv-list for it.
	1b. Recipient unknown, send error message.  Note no attempt to
		send it anywhere.
[2] If UNAME is not in LSR file, then
	2a. If directory exists for that UNAME, return OK.
	2b. If UNAME exists as a lastname in LSR, return eqv-list for it.
	2c. Find default HSNAME, append to rcpt list.
	2d. See if any traces of loser (init files etc), if so return OK.
		Else jump to [8] to send error message.
[3] UNAME is in LSR; if it has valid net-addr entry, return eqv-list for it.
[4] If directory exists for that UNAME, return OK.
[5] If LSR entry has "Fildir" for local machine, set that as HSNAME, return OK.
[6] Determine default HSNAME using tables, append to rcpt list, & return OK.
  ------
[8] Recipient is totally unknown.  Unless msg is send-only, or
	error msg already sent at [1b], send error message then return OK.

|] ;END IFN SHITSW

; If it skips, then B contains the EQV stuff.  Else just send the message.

BVAR
RXPNRL:	0		; LLP to rcpt list.
RXPNSP:	0		; SLP to rcpt name
RXPNSL:	0		; # chars in name
RXPNS6:	0		; SIXBIT name of rcpt, even if > 6 letters in name.
RXPNEA:	0		; LSR entry addr if any.
RXPNEX:	0		; -1 if exists in EQV, 0 otherwise.
EVAR

RXPNAM:	PUSHAE P,[RXPNEX,RXPNEA,RXPNRL,RXPNSP,RXPNSL,RXPNS6,C,D,A]
	MOVEM A,RXPNRL
	MOVEM B,RXPNEX		; Save EQV-existence argument.
	SETZB D,RXPNS6		; Initialize.
	SETZM RXPNEA
	FINDA A,[A$RNAM,,[A]]
	 JSR AUTPSY
	MOVEM A,RXPNSP
	MOVE A,LISTAR(A)+1
	ADD A,$LSLOC(L)
	HLRZM A,RXPNSL		; Save char cnt of name
	CALL CVT76C
	MOVEM A,RXPNS6		; Save SIXBIT UNAME.

	; Setup finished, start the algorithm.
	MOVE B,RXPNSL		; STEP 1: Get # of chars in name.
	CAIG B,6		; If > 6, try lastname check.
	 JRST RXPN20		; else can skip straight to uname check.

	CALL RXPLNM		; Try looking up name as lastname...
	 JRST RXPN90		; Successful, return eqv-list in B.
	SETZM RXPNS6		; Ugh, zap 6bit so RXPNER does right thing.
	CALL RXPNER		; Sigh, send msg saying failed.
	SETZ B,			; And return with B=0 to indicate
	JRST RXPN90		; it's considered pseudo, but doesn't expand.

RXPN20:	MOVE B,RXPNS6		; STEP 2: looks up as UNAME in LSR1.
	MOVEI A,LSR1C
RXPN21:	CALL LSRTNS"LSRUNM
	 CAIA
	  JRST RXPN30		; Found as UNAME, go hack LSR entry.
	JUMPE B,RXPN25		; Not found
	CAIA			; Wait for core to be available
	 JRST RXPN21		; Go CORBLK sleeping...
	JSR CORLOS

RXPN25:	MOVE A,RXPNS6		; STEP 2A: Not in LSR file, does it
	CALL HASDIR		; have a directory?
	 CAIA
	  JRST RXPN99		; Yes, return OK, will write to that dir.
	CALL RXPLNM		; STEP 2B: check to see if lastname.
	 JRST RXPN90		; Yes, return eqv-list in B!
	MOVE A,RXPNS6		; No, so on to
				; STEP 2C: Look for any record of existence.
IFN SHITSW,[
	SETZ B,
	CALL RXPNHS		; Find HSNAME & append to rcpt list.
	 JRST RXPN80		; Failed????
]
	CALL HASREC		; Hunt for clues that user exists.
	 JRST RXPN80		; Failed, send error message.
	JRST RXPN99		; Found loser's grimy tracks, so assume exists.


	; STEP 3: Here when LSRTNS"LSRUNM has just won, i.e. loser exists
	; in LSR file.  Look for a NET ADDRESS.
RXPN30:	MOVEM B,RXPNEA		; Save LSR entry address.
	MOVEI A,LSRTNS"I$NETA
	CALL LSRTNS"LSRITM	; Try to find the net address.
	 JRST RXPN40		; None, so go try fildir.
	MOVE B,A		; Save arg to RNETAD.
	CALL LBPASZ		; Get the length of the ASCIZ string.
	JUMPE A,RXPN40		; If entry is null, ignore it.
	MOVE C,RXPNSP
	MOVE C,LISTAR(C)+1
	ADD C,$LSLOC(L)		; Last arg is ASCNT to rcpt name.
	PUSH P,L
	MOVE L,$ARLOC+EQVAR	; Do any CONSing in EQVAR.
	CALL RNETAD		; Try to parse it.
	 SETZ B,		; If loser has bad field, just ignore it.
	JUMPE B,[POP P,L	; Jump if no net address.
	 	JRST RXPN40]

	;; Copy only 1 rcpt!!  This hack is necessary due to inter-machine
	;; INQUIR which can deliver a netaddr with two sites to BOTH sites
	;; in question, causing infinite loop! 
	;; so, restricted to 1 site per net address.
	HRRZ A,LISTAR(B)	; Is there more than 1 rcpt in list?
	JUMPE A,RXPN36		; Nope, no hair.
	HLLZS LISTAR(B)		; Ugh, yes, disconnect 1st from rest of list
	LNDEL A			; and delete rest of list.
RXPN36:
	;; Must check for netadr exactly same as name, so that can
	;; go check directory etc; if we just handed back to EQV rtns,
	;; duplicate would be suppressed & we'd never come back to RXPNAM.
	FINDA C,[A$RHST,,[LISTAR(B)+1]]
	 SKIPA A,OWNHST		; If no host, using local; OK.
	  MOVE A,LISTAR(C)+1	; Get right host #
	CAMN A,OWNHS2		; Identity crisis?
	 JRST [	MOVE A,OWNHST	;  Yes, change host to connected net.
		MOVEM A,LISTAR(C)+1
		JRST .+1 ]
	CAME A,OWNHST		; If non-local host, return to EQV.
	 JRST RXPN39
	FINDA C,[A$RNAM,,[LISTAR(B)+1]]	; local, so check name.
	 JSR AUTPSY
	MOVE C,LISTAR(C)+1
	ADD C,$LSLOC(L)		; Get abs ascnt ptr to new rcpt name string.
	POP P,L			; now can restore LSE
	MOVE A,RXPNSP		; and can use SLP to old rcpt name
	USLNEA A,C		; and compare strings.
	 JRST RXPN90		; If not equal, off to return EQV list.
	PUSH P,L		; Equal!  Must ignore...
	MOVE L,$ARLOC+EQVAR	; Point back at LSE we consed the list in.
	LNDEL B			; and flush it.
	POP P,L			; And go to check out directory, etc.
	JRST RXPN40

RXPN39:	POP P,L
	JRST RXPN90		; Win return.

	; STEP 4: Check for a file directory.
RXPN40:	MOVE A,RXPNS6		; Get 6bit
	CALL HASDIR		; Has a directory?
	 CAIA
	  JRST RXPN99		; Yes, return OK (will write to this dir).


	; STEP 6: Determine default HSNAME when no netaddr specified, but
	; user exists in INQUIR data.
RXPN60:
IFN SHITSW,[
	MOVE A,RXPNS6
	MOVE B,RXPNEA
	CALL RXPNHS		; Eeny, meeny, miny, mo!
	 JFCL			; Ignore lossage.
	JRST RXPN99		; And return OK.
];SHITSW

	; Here we have lost totally.  We must send a warning message to the
	;    sender, and perhaps also to the dead-letter box. (STEP 4).
	; But first, check some stuff and maybe punt the warning.

RXPN80:	SKIPE RXPNEX		; Perhaps name existed in EQV?
	 JRST RXPN99		; Yes, so technically "known"...
	MOVE A,RXPNRL		; Get back ptr to rcpt's list.
	CALL SETMSM		; Decode MAIL/QSEND modes.
	SKIPE SORMSW
	 SKIPLE SENDSW
	  CAIA
	   JRST RXPN99		; Not really mailing, don't bother.
	TRNE MF,M%CORG		; One other thing...did we originate the msg?
	 JRST [	STAT (,TAB,("COMSAT-originated msg LOST TO "),TLS(RXPNSP),EOL)
		JRST RXPN99]	;  and do nothing if so.
	MOVE A,RXPNSL
	CAILE A,6
	 JRST RXPN82		; (Ignore this check if name > 6 chars.)
	MOVE A,RXPNS6		; Get the SIXBIT name.
	CALL USRFND		; Is he logged in at the moment?
	 CAIA			; No, continue.
	  JRST RXPN99		; Do common-sense thing, just send...

	; Here we are fully committed to sending warning, etc.
RXPN82:	CALL RXPNER		; Send error message.
	CAIA
RXPN90:	 AOS -11(P)
RXPN99:	POPAE P,[A,D,C,RXPNS6,RXPNSL,RXPNSP,RXPNRL,RXPNEA,RXPNEX]
	RET

; RXPNER - Auxiliary for RXPNAM that sends error message
;	warning sender that recipient name is unknown.

.SCALAR RCHKTM,RXPNH6	; Temp stuffs

RXPNER:	MAKELN B,[A$RNK,,0
		%LTVAL,,0]
	LNAPP [RXPNRL ? B]	; Append "not known" attrib to rcpt's list.
	FINDA B,[A$RHSN,,[RXPNRL]]	; See if HSNAME carried along.
	 SKIPA B,[SIXBIT /COMMON/]	; If not, use default.
	  MOVE B,LISTAR(B)+1		; Uh huh, get it.
	MOVEM B,RXPNH6			; Save in temp variable.
	OUT(TMPC,OPEN(UC$SAO),(|"|),SL(RXPNSP),(|" at |),TZ(OWNNAM),(" is an unknown recipient."))
	SKIPE B,RCPTRC			; Backtrace of rcpt expansion available?
	 SKIPN B,(B)			; Skip the innermost (self)
	  JRST RXPNR1
	OUT(TMPC,EOL,("    This name came from the expansion of
    "))
RXPNR0:	HLRZ A,B
	OUT(TMPC,CALL(NSRNMO))		; Output rcpt name
	SKIPN B,(B)			; Get next
	 JRST RXPNR1
	OUT(TMPC,(", from "))
	JRST RXPNR0

RXPNR1:	SKIPE RXPNS6			; If name not too long, will try anyway
	 OUTCAL(TMPC,EOL,TAB,(|Will try sending to the file "|),6F(RXPNH6),(";"),6F(RXPNS6),(| MAIL".|))
	MAKELN B,[A$RRMG,,0 ? %LTSAO,,]	; Pack up output into a LN
	LNAPP [RXPNRL ? B]		; Append onto list of rcpt.
	AOS NRXPER			; Increment cnt of errors.
	RET


; RXPLNM - Auxiliary to RXPNAM, sees if rcpt name is a lastname and
;	if so conses up an eqv-list for it.  References RXPNSP,
;	clobbers A,B,C,D.  Returns eqv-list ptr in B and DOESN'T skip if
;	successful.

RXPLNM:	SAOBEG TMPC,
	OUT(TMPC,TLS(RXPNSP))	; Copy name,
	OUT(TMPC,TC([5,,[0]]))	; followed by 5 nulls to ensure fully asciz'd.
	MAKELN C,[0 ? %LTSAO,,]	; Make SLN of it.
	MOVE A,LISTAR(C)+1
	ADD A,$LSLOC(L)		; get abs ascnt to string,
	CALL UPPRZ		; uppercasify it,
	HRRZ B,A		; and give location as arg to LSRLNM.
	MOVEI A,LSR1C
	CALL LSRTNS"LSRLNM
	 JRST [	LNDEL C,	; Too bad.  Make sure temp SLN flushed.
		AOS (P)		; and take failure (skipping!) return.
		RET]
	LNDEL C,

	; Now B/ AOBJN to words with file addresses of LSR1 entries.
	PUSH P,L		; CONS up fake EQV in EQVAR!
	MOVE L,$ARLOC+EQVAR
	MOVE C,B
RXPLN3:	MOVEI A,LSR1C
	HRRZ B,(C)		; Get address in file of this entry.
	CALL LSRTNS"LSRGET	; Returns core address in B.
	 JSR AUTPSY
	MOVEI A,LSRTNS"I$UNAM		; We want the UNAME.
	CALL LSRTNS"LSRITM	; Gets B.P. in A to string.
	 JSR AUTPSY
	MOVE B,A		; Save the BP in B.
	CALL LBPASZ		; Get length of ASCIZ string in A.
	HRLZ A,A
	HRRI A,B		; A / <# chars>,,[BP to string]
	MAKELN A,[A$RNAM,,0	; Make an SLP of the name,
		%LTBPT,,[A]]
	MAKELN D,[A$RCP,,[D]	;    and CONS it onto the list.
		%LTLST,,[A]]
	AOBJN C,RXPLN3
	MOVE B,D		; And return the EQV stuff in B.
	POP P,L
	RET		; Win return doesn't skip!

IFN SHITSW,[
; RXPNHS - RXPNAM utility; Append HSNAME attrib onto rcpt list.
;	A/ UNAME
;	B/ <LSR entry addr>	; if 0 assumes tourist.
; Skips on success, with HSNAME in B.

RXPNHS:	PUSHAE P,[C,D]
	SETZ C,
	MOVEI D,DKIC		; Use this as temp chan if need to.
	CALL LSRTNS"LSRHSN	; Look up HSNAME, hacking fildir etc.
	 JRST RXPNH9
	MAKELN C,[A$RHSN,,0	; Got it in D, store in a LN.
		%LTVAL,,[D]]
	LNAPP [RXPNRL ? C]	; Append "Hsname" attrib to rcpt's list.
	AOS -2(P)
RXPNH9:	POPAE P,[D,C]
	RET
]

SUBTTL Auxiliary routines for RXPNAM: RNETAD, HASREC, etc.

; RNETAD - Routine given ASCNT ptr in C to a rcpt name, with
;	count in A, BP in B to a string
;	which is to be parsed as an INQUIR NETADR field,
;	i.e. a standard rcpt list with exception that
;	names without @'s are taken to be site names!
; Skip returns in B a LP to list of whatever rcpts result,
;	consed in the current LSE.  If B/ 0, no rcpts.

RNETAD:	PUSHAE P,[A,C,D,E]
	CALL RCPGBA		; Enter RCPGOB at special place.
	CAIE B,0
	 JRST RNTD95		; Return unsuccessfully - error.
	JUMPE A,[SETZ B,
		JRST RNTD90]	; Nothing there?  Succeed anyway.
	MOVE B,A		; Aha, save stuff
	MOVE D,A		; Keep current in D
	CAIA
RNTD10:	 HRRZ D,LISTAR(D)
	JUMPE D,RNTD90
	MOVE A,LISTAR(D)+1	; Get LP to rcpt's list
	MOVE E,LISTAR(A)	; Get 1st wd of 1st LP pointed to
	TRNE E,-1		; Is there a CDR, i.e. more than one LN?
	 JRST RNTD10		; Yes, it must be OK.
	LDB E,[$LAFLD,,E]	; Only one!  Make sure it's an RNAM...
	CAIE E,A$RNAM
	 JSR AUTPSY		; Glub? EQRCPL returned no-name rcpt??
	CALL HMATCH		; Try to get site #.
	 JRST RNTD95		; Uh-oh, error!
	PUSH P,B
	CAMN A,OWNHST
	 JRST [	HRRZ B,LISTAR(B)+1	;Just points to self,
		JUMPE B,.+1		;don't count (makes JPG happy)
		POP P,B
		JRST RNTD95 ]
	POP P,B
	LNDEL LISTAR(D)+1	; Flush the list for this rcpt
	MAKELN A,[A$RHST,,0 ? %LTVAL,,[A]]	; Make a RHST LN and
	MAKELN A,[A$RNAM,,[A]	; plug onto a new RNAM LN, using name given.
		%LTSTR,,[C]]
	MOVEM A,LISTAR(D)+1	; And make THAT the rcpt list!
	JRST RNTD10		; Back for another.

RNTD90:	AOS -4(P)
RNTD95:	POPAE P,[E,D,C,A]
	RET


; HASREC - Takes 6bit name in A, tries to find evidence of presence
;	on system by looking for file dir, INIT file, _MSGS_ file.
;	B/ HSNAME (only if SHITSW on)
;	Skips if found something.
;	Note: err codes 23 (File locked), 27 (Link depth exceeded)
;	and 47 (Link to non-ex file) all imply some kind of existence,
;	but no others.

HASREC:	PUSH P,C
IFE SHITSW,	MOVE C,[-3,,[FILINI ? FILDIN ? FILMSG]]
IFN SHITSW,	MOVE C,[-1,,[FILHSN]]
HASRC2:	ECALL @(C),[[23,HASRC7],[27,HASRC7],[47,HASRC7]]
	 CAIA
	  JRST HASRC7
	AOBJN C,HASRC2
	PJRST POPCJ	; Lose, none worked.

HASRC7:	.CLOSE DKIC,	; Win, found something.
	PJRST POPCJ1

IFN SHITSW,[
FILHSN:	SETZ ? SIXBIT/OPEN/ ? [DKIC] ? ['DSK,,0]
	A ? [SIXBIT />/] ? SETZ B
]
FILINI:	SETZ ? SIXBIT/OPEN/ ? [DKIC] ? ['DSK,,0]
	A ? [SIXBIT />/] ? SETZ [SIXBIT /(INIT)/]
FILDIN:	SETZ ? SIXBIT/OPEN/ ? [DKIC] ? ['DSK,,0]
	A ? [SIXBIT />/] ? SETZ [SIXBIT /DDTINI/]
FILMSG:	SETZ ? SIXBIT/OPEN/ ? [DKIC] ? ['DSK,,0]
	[SIXBIT /_MSGS_/] ? A ? SETZ [SIXBIT /_MSGS_/]

; HASDIR - Takes sixbit name in A, skips if has a file dir.

HASDIR: .CALL FILDIR
	 RET	; Any error means nope.
	.CLOSE DKIC,
	AOS (P)
	RET

FILDIR:	SETZ ? SIXBIT/OPEN/ ? [DKIC] ? ['DSK,,0]
	[SIXBIT /.FILE./] ? [SIXBIT/(DIR)/] ? SETZ A

; RXPAFL - Routine to hack a name of type @FILE, which reads
;	specified file and interprets as a distribution list.
;	Errors are put into an A$RRMG SLN for the indirect-file rcpt spec.
;	Shares routines with EQVGOB!!
;	A/ LLP to rcpt attrib list
; Returns
;	B/ LLP to list of rcpt LLNs (an EQV list), or 0 if none.

RXPAFL:	PUSHAE P,[A,C,D]
	MOVE C,A		; Save ptr
	FINDA A,[A$RNAM,,[C]]
	 JSR AUTPSY
	MOVE A,LISTAR(A)+1
	ADD A,$LSLOC(L)
	MOVE B,[LMFDEF,,LMFDEV]
	CALL FILPAR
	MOVEI A,LMFDEV
	CALL OPNFLI
	 JRST [OUT(TMPC,OPEN(UC$SAO),("Could not open the file "),6F(LMFDEV),(":"),6F(LMFDIR),(";"),6F(LMFFN1),(" "),6F(LMFFN2),( "because "),ERR)
		SETZ A,		; Say no list to return.
		JRST RXPA70]

	MOVSI A,IMSAR
	CALL TXFIN		; Read the file into IMSAR
	MOVEI A,IMSAR
	PUSH P,L
	MOVE L,$ARLOC+EQVAR	; Parse the file contents into EQV list area
				; (this eventually causes gronkage, so
				; maybe change someday to use temp list area?)
	CALL RCPGOB		; Gobble up the rcpts!
	POP P,L			; Restore list area for rcpt attribs
	JUMPE B,RXPA90		; If no errors, can just return!

	; If any errors, preserve them.
	OUT(TMPC,OPEN(UC$SAO),("------ "),D(B),(" error"))
	CAILE B,1
	 OUTCAL(TMPC,("s"))
	OUT(TMPC,(" trying to parse the file "),6F(LMFDEV),(":"),6F(LMFDIR),(";"),6F(LMFFN1),(" "),6F(LMFFN2),EOL,TA(ETXTAR),("  ------"))

	; There was an error processing this @FILE.
RXPA70:	MAKELN B,[A$RRMG,,0 ? %LTSAO,,]	; Pack up output into a LN.
	LNAPP [C ? B]			; Append onto rcpt's attrib list.
	AOS NRXPER			; Increment count of errors.

RXPA90:	MOVE B,A			; Return parsed list if any.
	POPAE P,[D,C,A]
	RET

; RCPE - Find recipient on EQV.
;    A/ ptr to rcpt attrib list
; Doesn't skip if it finds another rcpt attrib list with same A$RNAM,
; A$RTYP, and A$RHST.  (A$RNAM forced to uppercase unless A$RHST is Multics)
; Skips if unique, i.e. didn't find.

.SCALAR RCPECT	; Flag for type of compare

RCPE:	PUSHAE P,[A,B,C,D,E]
	MOVE B,A		;save ptr in b
	FINDA C,[A$RHST,,[B]]	;ptr to site #
	 SKIPA A,OWNHST
	  MOVE A,LISTAR(C)+1	;get host #
	MOVE D,A		;save host number for compare later
	SETOM RCPECT		;If Host is Multics, compare type -1=no uc force
	CALL NHMLTX		;Skip if host is Multics
	 SETZM RCPECT		;set compare type 0=uc force
	MOVE A,B		;restore A in case used below
	FINDA C,[A$RNAM,,[B]]	;ptr to name
	 JSR AUTPSY
	FINDA E,[A$RTYP,,[B]]	;ptr to type
	 TDZA E,E		;zero if type is missing
	  JRST [ SLNEA E,[ASCNT [NAME]]	;or NAME
		  JRST .+1
		SETZ E,
		JRST .+1 ]
	SETZM RCSQCT		;initialize rcpseq
RCPE1:	CALL RCPSEQ		;get ptr to a rcpt attr-list
	 JRST RCPE8		;won, didn't find
	FINDA B,[A$RHST,,[A]]	;get ptr to host
	 SKIPA B,OWNHST
	  MOVE B,LISTAR(B)+1	;get #
	CAME B,D		;compare
	 JRST RCPE1		;diff.
	FINDA B,[A$RTYP,,[A]]	;compare types
	 JRST [	JUMPE E,RCPE2	;both missing (default to NAME)
		JRST RCPE1 ]	;unequal
	JUMPE E,[ SLNEA B,[ASCNT [NAME]]
		   JRST RCPE1	;unequal
		  JRST RCPE2 ]	;equal
	SLNE B,E
	 JRST RCPE1		;unequal
RCPE2:	FINDA B,[A$RNAM,,[A]]	;ptr to name
	 JRST RCPE1
	SKIPE RCPECT		;skip if uc force.
	 JRST [	SLNE B,C	;no, avoid uppercase force
		 JRST RCPE1	;unequal
		JRST RCPE9]	;equal
	USLNE B,C		;compare strings, with uppercase force
	 JRST RCPE1		;no match, keep looking
	JRST RCPE9		;match, return w/o skipping (not unique)

RCPE8:	AOS -5(P)		;unique
RCPE9:	POPAE P,[E,D,C,B,A]	;not unique
	RET

; RCPEQV - takes ASCNT ptr in A to rcpt name, ASCNT ptr in B to rcpt type
;	(or 0 for default normal) and searches EQV-list for match.
;	If finds entry, skips with LP in A to its list.

RCPEQV:	PUSHAE P,[B,C,D,E,L]
	SKIPN $AROPN+EQVAR	; Ensure open.
	 CALL EQVGET
	MOVE L,$ARLOC+EQVAR	; Make it current LSE
	JUMPE B,[SETZ D,
		MOVE B,[ASCNT [NAME]]
		JRST RCPEQ0]
	HLRZ D,B		; See if type is NAME.
	CAIN D,4
	 JRST [	MOVE D,(B)
		TRZ D,377
		CAME D,[ASCII/NAME/]
		 JRST .+1	; nope.
		SETZ D,
		JRST RCPEQ0]	; Yep...
	SETO D,
RCPEQ0:	HRRZ E,$LLLST(L)	;get ptr to eqv list
	CAIA
RCPEQ1:	 HRRZ E,LISTAR(E)	; Get CDR to next to try.
	JUMPE E,RCPEQ9		; None left? Fail.
	FINDA C,[A$RNAM,,[LISTAR(E)+1]]	;find ptr to name
	 JRST RCPEQ1		; No name? Oh well
	USLNEA C,A		; Compare strings
	 JRST RCPEQ1		; No match, try another.
	FINDA C,[A$RTYP,,[LISTAR(E)+1]]	; Else find type
	 JRST [JUMPE D,RCPEQ7	; If no type, win if desired is NAME.
		JRST RCPEQ1]
	USLNEA C,B		; Compare types.
 	 JRST RCPEQ1		; Uh-oh, not same type.
RCPEQ7:	MOVE A,LISTAR(E)+1	; Match! get ptr to all of eqv list
	AOS -5(P)
RCPEQ9:	POPAE P,[L,E,D,C,B]
	RET

; RXPBUG - kludge routine, called when BUG type rcpt has no entry in eqv table.
;	Conses up an extra rcpt that points to (BUG RANDOM-PROGRAM).
;	This ensures all BUG's wind up someplace...

RXPBUG:	PUSHAE P,[C,D,L]
	MOVE B,L		; Save LSE pointer in B for LNCOPY later.
	FINDA C,[A$RNAM,,[A]]	; First make sure we aren't recursing.
	 JSR AUTPSY
	SLNEA C,[ASCNT [RANDOM-PROGRAM]]
	 CAIA
	  JRST [SETZ B, ? JRST RXPB90]	; Yikes, recursing!  Just ignore...
	MOVE L,$ARLOC+EQVAR	; All stuff must be CONSed in EQVAR.
	MOVE D,BUGHST		; Are we the magic host on which most program
	CAME D,OWNHS2
	CAMN D,OWNHST		;   maintainers reside?
	 JRST RXPB50		; Yes, send to (BUG RANDOM-PROGRAM)
	LNCOPY C,[B ? C]	; No, forward the mail to that host.
	MAKELN C,[A$RHST,,[C]
		  %LTVAL,,[BUGHST]]
	MAKELN C,[A$RTYP,,[C]
		  %LTSTR,,[LITSTR [BUG]]]
	JRST RXPB60		; Cons up A$RCP and return.

RXPB50:	MAKELN C,[A$RTYP,,0	; This is the host.  Forward to various people.
		  %LTSTR,,[LITSTR [BUG]]]
	MAKELN C,[A$RNAM,,[C]
		  %LTSTR,,[LITSTR [RANDOM-PROGRAM]]]
RXPB60:	MAKELN B,[A$RCP,,0
		  %LTLST,,[C]]
RXPB90:	AOS -3(P)
	POPAE P,[L,D,C]
	RET

;; Kludge -- magic host address which can deal with BUG-RANDOM-PROGRAM
BUGHST:	HN$MC				; MC.LCS.MIT.EDU this week...

SUBTTL RXPERR - send error message after expansion/header.

; RXPERR - Scans through MSG LSE and generates an error message
;	addressed to sender, incorporating all errors encountered
;	during rcpt expansion and header generation.  Should
;	only be called if NRXPER (# errs seen) is positive.
;	Errors are stored in A$RRMG attribs of rcpts.
;	The way to express an error, but not send anything, is to
;	make the rcpt pseudo; such rcpts will be converted to A$RDON.

RXPERR:	PUSHAE P,[A,B,C,D,E]
	UARPUSH EMSGAR		; Might as well be robust.
	SKIPA E,$LLLST(L)
RXPE10:	 HRRZ E,LISTAR(E)
	FINDA E,[A$RCP,,[E]]	; Find a rcpt.
	 JRST RXPE70		; No more?  Go hack rest of msg.
	FINDA A,[A$RRMG,,[LISTAR(E)+1]]	; Has err msg?
	 JRST RXPE10		; Nope, get another rcpt.

	; Have rcpt with err msg...
	SKIPN $ARLOC+EMSGAR	; If nec, open EMSGAR LSE and chan thereto.
	 OUTCAL(TMPC,CALL(EMSOPN),("============ A copy of your message is being returned, because: ============"),EOL)
	OUT(TMPC,SL(A),EOL)	; Simply output the text.
	FINDA A,[A$RPSN,,[LISTAR(E)+1]]	; Is this "rcpt" a pseudo?
	 JRST RXPE10		; No, just leave alone.  Get another...
	MOVEI A,A$RDON		; Yes, so smash it right here...
	DPB A,[$LAFLD,,LISTAR(E)]	; Smash!
	JRST RXPE10		; Now go get another.

RXPE70:	SKIPN $ARLOC+EMSGAR
	 JRST RXPE90		; No message at all, just return.
	FINDA A,[A$MTXT,,[$LLLST(L)]]	; Find ptr to msg-txt LN
	 JSR AUTPSY
	FINDA B,[A$MHDR,,[$LLLST(L)]]	; and ptr to default header
	 SETZ B,
	OUT(TMPC,("============ Failed message follows: ============
"),SL(B),SL(A))
	CALL EMSSND		; Now go send the message!

RXPE90:	UARPOP EMSGAR
	POPAE P,[E,D,C,B,A]
	RET

SUBTTL RCPSND - send message to all rcpts on list
;;; Takes ptr in L to a msg attrib list and sends to all rcpts listed,
;;; with no equivalencing nor header.  Will queue unless otherwise
;;; specified if temporarily unable to send.  After each result, adds the
;;; feature of "failed" or "sent" or "queued" to that rcpt.

.SCALAR RSNDQD,RSNDFL,NDLAST

RCPSND:	PUSHAE P,[A,B,C,D,E,RSNDQD,RSNDFL]
	TRZ F,%RBHD
	SETZM RSNDQD		; Clear 'a msg queued' flag
	SETZM RSNDFL		; Clear 'a msg failed' flag.
	SETZ N,
	SETOM NDLAST
	SKIPA E,$LLLST(L)
RSND01:	 HRRZ E,LISTAR(E)	; Get CDR to next msg attrib
	FINDA E,[A$RCP,,[E]]	; Get recipient list there.
	 JRST RSND50		;  No more, all done.
	MOVE D,LISTAR(E)+1	; Get ptr to rcpt's list.
	FINDA A,[A$RPSN,,[D]]	; Is this a psuedo?
	 JRST RSND05		;  No, OK to send.

	;; Here we have a psuedo recipient. (Probably going to CLI to it.)
	FNDSTR B,A,A$ROPT,[NO-CLI] ; First, look for "no CLI" flag.
	 CAIA
	  JRST RSND01
	FINDA A,[A$RNAM,,[D]]	; Get LN to recipient name.
	 JSR AUTPSY
	HLRZ B,LISTAR(A)+1	; How long is the name?
	CAILE B,6		; If it is longer than six chars
	 JRST RSND01		;  it can't possibly be a UNAME.
	FINDA B,[A$RTYP,,[D]]	; Get recipient type.
	 JRST RSND02
	USLNEA B,[ASCNT [NAME]]	; It should be NAME.
	 JRST RSND01
RSND02:	FINDA B,[A$SNM,,[$LLLST(L)]] ; Get the sender's name.
	 JSR AUTPSY
	USLNE A,B		; Check for sending to sender...
	 CAIA
	  JRST RSND01		; Names equal, don't send. KLH mailing to KLH.
	FINDA B,[A$CSN,,[$LLLST(L)]]	; Another check for sending to sender!
	 JRST RSND04		; If no CLAIMED-FROM, go ahead.
	USLNE A,B		;   Else must check it too.
	 CAIA			; Don't send. KLH0 is mailing to KLH.
	  JRST RSND01
RSND04:	CALL CVLS6		; Cvt list string into 6bit in A.
	MOVE B,D		; B holds LP to rcpt's list.
	CALL CLIOPT		; Now send to all matching x/unames
	 NOP
	JRST RSND01		; Done.

	;; Here we have an active recipient!
RSND05:	MOVE A,D		; Get recipient list in A.
	CALL SETMSM		; Find service required (mail or send).
	FINDA N,[A$RHST,,[D]]	; Find recipient's host.
	 SKIPA N,[0]		; Zero = local.
	  MOVE N,LISTAR(N)+1	; Get host #.
	CAMN N,OWNHS2		; Last chance for schizophrenia.
	 MOVE N,OWNHST
	CAMN N,OWNHST		; If this host is ourselves
	 SETZ N,		;   force to special "local" # of zero.
	CALL NETPTH		; Find path to host.
	 JRST [	SKIPN N		;  Already connected!
		 PSTAT (,("  Local-"),RABR,HST(OWNHST))
		JRST RSND20 ]
	CAMN N,NDLAST		; Need reconnection.
	 JRST RSND01		;  But don't try same site twice in a row.
RSND10:	CALL NTDISC		; Disconnect.
	MOVEM N,NDLAST		; Remember most recent host tried.
	CALL NETICP		; Attempt connection to host N.
	 JRST [	AOS RSNDQD	;   Net failure, bah.  Ensure stuff queued.
		JRST RSND01]	;   and go round again.
RSND20:	CALL NETSND		; Send to all rcpts this host and say byebye.
	 NOP			; Net failure doesn't matter here.
	MOVE A,NSCTQ		; Get # queued
	ADDM A,RSNDQD		; Add into sum.
	MOVE A,NSCTF		; Get # failed
	ADDM A,RSNDFL		; Likewise.
	JRST RSND01		; Then go back for another round.

	;; All done with sending. See if anything needs to be queued, etc.
RSND50:	CALL NTDISC		; Close any open net conns
	; This little instruction is VERY IMPORTANT - it limits
	; recursion to one level only, thus allowing the hack of MSGAR and
	; EMSGAR to win!  Since MAIL sends all its stuff with RCPSND,
	; this will catch all such recursive attempts.  (e.g. if a failure
	; message itself gets an error)  Any attempt to enable more
	; levels must use a more flexible "current message LSE" scheme.
	MOVEI A,MF%SNT+MF%QUD+MF%FAI
	TRNN MF,M%CORG		; If comsat originated, don't
	 CALL MSGFIN		; "finalize" message by sending receipts.

	SKIPLE RSNDQD		; If any msgs were queued,
	 CALL QUEUE		; then queue the MSG-LSE.

RSND95:	POPAE P,[RSNDFL,RSNDQD,E,D,C,B,A]
	RET
-
SUBTTL	Message Finalization (receipt generation/sending)

; MSGFIN - Scan msg rcpts and compose a confirmation msg if
;	necessary, according to flags.
;	A - flags.  Ask for maximum; sender options may limit what
;		actually can be used.
MF%SNT==:1	; Sent.
MF%QSNT==:2	; Queued-sent.
MF%QUD==:4	; Queued.
MF%FAI==:10	; Failed.
MF%KIL==:20	; Manually killed

MSGFIN:	PUSHAE P,[A,B,C,D,NSCTS,NSCTQ,NSCTF]

	; First see what flags need censoring.
	FNDSTR B,$LLLST(L),A$CNF,[ALL]	
	 JRST [	FNDSTR B,$LLLST(L),A$CNF,[FAIL]	; ALL not allowed.  FAIL only?
		 TRZA A,MF%SNT	; Neither ALL nor FAIL, only QUD/FAI allowed.
		  ANDI A,MF%FAI+MF%KIL	; Only FAIL allowed.
		JRST .+1]
	MOVE C,A		; Get flags out of way.
	UARPUSH EMSGAR		; Crock, ensure closed since will check later.

IRP FLG,,[SNT,QSNT,QUD,FAI]ATTR,,[A$RSNT,A$RSNT,A$RCP,A$RCPF]MSG,,[Sent to,Queued msg sent to,Queued,FAILED]
TRNE C,MF%!FLG		; Flag set?
 CALL [	MOVEI A,ATTR
	MOVE B,[ASCNT [MSG: ]]
	CALRET RSNREP]
TERMIN

	TRNN C,MF%KIL
	 JRST MSGF40
	SKIPN $AROPN+EMSGAR
	 OUTCAL(TMPC,CALL(EMSOPN))	; Open EMSGAR LSE & setup channel.
	OUT(TMPC,("This message was manually killed by Comsat maintainers."),CRLF())
MSGF40:	TRNE C,MF%FAI		; If hacked failed rcpts
	 CAIG A,		; and at least one DID fail, include msg text.
	  JRST MSGF50		; Nope, needn't include text.
	FINDA A,[A$MTXT,,[$LLLST(L)]]	; Find ptr to msg-txt LN
	 JSR AUTPSY
	FINDA B,[A$MHDR,,[$LLLST(L)]]	; and ptr to default header
	 SETZ B,
	OUT(TMPC,(" Failed message follows:
-------
"),SL(B),SL(A))

MSGF50:	SKIPN $AROPN+EMSGAR	; Now send the confirmation msg if any
	 JRST MSGF90		; Not there, nothing to send.

	CALL EMSSND		; Send EMSGAR, with stuff from current LSE.

MSGF90:	UARPOP EMSGAR
	CALL MSGFDN		; Change appropriate stuff to "done".
	POPAE P,[NSCTF,NSCTQ,NSCTS,D,C,B,A]
	RET

; MSGFDN - Mark all A$RCPF's and A$RSNT's "done"; ditto pseudos.
;	L - message LSE.

MSGFDN:	PUSHAE P,[A,B]
	MOVE A,$LLLST(L)
	MOVEI B,MSGFD2
	CALL MAPC
	 JSR AUTPSY
	POPAE P,[B,A]
	RET
MSGFD2:	LDB B,[$LAFLD,,LISTAR(A)]	; Get attrib
	CAIE B,A$RSNT
	 CAIN B,A$RCPF
	  JRST MSGFD5
	CAIE B,A$RCP
	 PJRST POPJ1
	FINDA B,[A$RPSN,,[LISTAR(A)+1]]	; See if pseudo; hack it too!
	 PJRST POPJ1
MSGFD5: MOVEI B,A$RDON
	DPB B,[$LAFLD,,LISTAR(A)]
	TLO F,%MSGMD
	PJRST POPJ1
	

; RSNREP - Subroutine for MSGFIN.  Given an attribute, output a header string
;	followed by the names of all rcpts with that attribute, plus each
;	rcpt's A$RRMG if any.
;	A - Attrib code
;	B - ASCNT ptr to heading string
; Returns
;	A - # rcpts that matched.

.SCALAR RSNTY	; Save ASCNT heading string.
.SCALAR RSNCMP	; Used to compose FINDA arg.
.SCALAR RSNCNT	; # rcpts found.
.SCALAR RSNSW	; switch for prettification (comma etc)
		; -1 nothing on line, 0 header only, +n header & rcpts.

RSNREP:	PUSHAE P,[B,C,D,E,L]
	SETOM RSNSW
	SETZM RSNCNT
	MOVEM B,RSNTY	; Save heading string
	HRLZS A		; put attrib in LH
	HRRI A,[D]	; and addr of addr of LP in RH.
	MOVEM A,RSNCMP
	SKIPA D,$LLLST(L)
RSNRP1:	 HRRZ D,LISTAR(D)
	FINDA D,RSNCMP
	 JRST RSNRP2			; No more...
	FINDA A,[A$RPSN,,[LISTAR(D)+1]]	; Is it a pseudo?
	 CAIA
	  JRST RSNRP1			; Ignore it if so.

	; Have a rcpt, make sure set up for output.
	SKIPN $AROPN+EMSGAR
	 OUTCAL(TMPC,CALL(EMSOPN))	; Open EMSGAR LSE & setup channel.

	AOS RSNCNT			; Bump cnt of # rcpts hit.
	FINDA B,[A$RRMG,,[LISTAR(D)+1]]	; See if err msg there
	 TDZA B,B
	  JRST [SKIPLE RSNSW		; If something already on line,
		 OUTCAL(TMPC,EOL)	; must get new one.
		SETOM RSNSW
		JRST .+1]
	SKIPGE RSNSW
	 OUTCAL(TMPC,TC(RSNTY))		; First time, show heading.
	AOSLE RSNSW			; Say heading there; if already a rcpt,
	 OUTCAL(TMPC,(", "))		; split off from it.

	MOVE A,LISTAR(D)+1
	CALL NSRNAM		; This will do for now.
	FINDA C,[A$RHST,,[LISTAR(D)+1]]
	 SKIPA C,[0]
	  MOVE C,LISTAR(C)+1
	OUT(TMPC,SL(A),(" at "),HST(C))
	CAIGE A,		; Must flush the SLN if NSRNAM says temporary.
	 LNDEL A,
	JUMPE B,RSNRP1
	OUTCAL(TMPC,("; "),SL(B),EOL)
	SETOM RSNSW		; Moved to new line.
	JRST RSNRP1

RSNRP2:	SKIPL RSNSW
	 OUTCAL(TMPC,EOL)
	MOVE A,RSNCNT		; Return # rcpts output.
	POPAE P,[L,E,D,C,B]
	RET

; EMSOPN - Auxiliary to open EMSGAR LSE and string-area output channel.
;	Uses standard output chan for generality.

EMSOPN:	PUSHAE P,[A,L]
	MOVEI A,EMSGAR
	CALL LSEOPN
	MOVE L,$ARLOC+EMSGAR
	OUT(,OPEN(UC$SAO))	; Open std output for string-area output.
	POPAE P,[L,A]
	RET

; EMSSND - Assumes EMSGAR contains a LSE which has been accumulating SAO
;	type output.  Finalizes and sends text to "sender" as determined
;	by attribs of current LSE.

;;; (Should DEAD-MAIL-RECEIPTS be an optional list? Could check RCPEQV...)

EMSSND:	PUSHAE P,[A,B,C,D]
	FINDA D,[A$TIM,,[$LLLST(L)]]
	 JSR AUTPSY
	MOVE D,LISTAR(D)+1	; Save time of msg in question
	CALL SNMRCP		; Find someone to give error receipt to.
	 CAIA
	  JRST EMSS10
	;; Final sink used when nobody to give the receipt to.
	MAKELN B,[A$RNAM,,0 ? %LTSTR,,[LITSTR [DEAD-MAIL-RECEIPTS]]]
	MAKELN A,[A$RCP,,[A] ? %LTLST,,[B]]
EMSS10:	MOVE B,A		; Save LP to A$RCP in B.
	PUSH P,L
	MOVE C,L		; Also save L in C
	MOVE L,$ARLOC+EMSGAR
	MAKELN A,[A$MTXT,,0	; Create message text.  make text LN
		%LTSAO,,]	; of output thus far.
	
	LNCOPY B,[C ? SETZ B]	; Copy A$RCP(s) to use from old LSE.
	HRRM B,LISTAR(A)	; Append onto 1st LN (text).
	MAKELN A,[A$CNF,,[A]	; Inhibit sent-confirmations if it gets queued
		  %LTSTR,,[LITSTR [FAIL]]]
	MOVEM A,$LLLST(L)	; All set now... finalize list.
	STAT (,("  CMSG "))
	MOVE B,D			; Set up time
	;; Save state of RCPEXP.
	PUSHAE P,[MF,RCPSLF,RCPSLT,RCPSLP,RCPSLA,RCPTRC,LSTSUP] 
	SETZM RCPTRC
	MOVEI MF,M%CORG\M%SSBJ+M%EMSG
	CALL MAIL
	 JFCL
	POPAE P,[LSTSUP,RCPTRC,RCPSLA,RCPSLP,RCPSLT,RCPSLF,MF]
	POP P,L
EMSS99:	POPAE P,[D,C,B,A]
	RET

; QUEUE - Queues message in MSGAR.
;	What this does is to call QUEHST once for every host for which
;	some rcpt got a temporary error.
;		This is only called from RCPSND.  So at this point all
;	expansion has been done, and some RCPT-LISTs have been changed to
;	RCPT-LIST-FAILED and RCPT-LIST-SENT. 

LVAR QUEUEN:	-1		; Last host for which we called QUEHST

QUEUE:	PUSHAE P,[A,B,C,L]
	MOVE L,$ARLOC+MSGAR
	CALL RCPSRT		; (KLH is paranoid) (so am I -- dlw)
	SETOM QUEUEN		; Presumably there is not host "-1"...

	SKIPA C,$LLLST(L)
QUEUE2:	 HRRZ C,LISTAR(C)
	FINDA C,[A$RCP,,[C]]
	 JRST QUEUE6		; No more rcpt's
	FINDA A,[A$RPSN,,[LISTAR(C)+1]]	; Make sure it's a "live" one,
	 CAIA				;   not pseudo.
	  JRST QUEUE2			; Bleah, a pseudo.  Ignore.
	FINDA A,[A$RHST,,[LISTAR(C)+1]]
	 TDCA A,A
	  MOVE A,LISTAR(A)+1
	CAMN A,OWNHST		;If local host, send locally.
	 SETZ A,		;This is important to avoid looping with server.
	CAMN A,QUEUEN		; Same host as last time?
	 JRST QUEUE2		; Yes, don't do it twice!! (Depends on RCPSRT working)
	MOVEM A,QUEUEN		; (Remember for next time).
	FINDA B,[A$ID,,[$LLLST(L)]]
	 JSR AUTPSY
	CALL QUEHST		; Make QML entry for this site.
	JRST QUEUE2

QUEUE6:	TLNE F,%QMLMD		; QML modified?
	 SKIPE MKQFLG		; And in normal mode?
	  JRST QUEUE9		; No, no writing necessary
	CALL MSGPUT
	CALL QMLPUT
QUEUE9:	POPAE P,[L,C,B,A]
	RET

	
; QUEHST - Given site # in A, SLP in B to MSG ID in current LSE,
;	makes entry on QML for specified site and MSG.

QUEHST:	PUSHAE P,[A,B,C,D,L]
	MOVE B,LISTAR(B)+1	; Get SPT
	ADD B,$LSLOC(L)		; Make abs.
	SKIPN $AROPN+QMLAR	; Ensure that
	 CALL QMLGET		; QML is in core.
	MOVE L,$ARLOC+QMLAR	; Make it current LSE
	MAKELN B,[A$ID,,0 ? %LTSTR,,[B]]	; Cons up LN for ID.
	STAT (,("Queued: "),TLS(B),(" for "),HST(A))
	HRRZ D,$LLLST(L)	; Get LP to start of QML
	JUMPN D,QUEHS3
	JRST QUEHS7
QUEHS2:	HRRZ D,LISTAR(D)	; Get CDR to next
	JUMPE D,QUEHS7		; Not found?
QUEHS3:	MOVE C,LISTAR(D)+1	; Get LP to sitelist.
	MOVE C,LISTAR(C)+1	; Get site #
	CAME A,C		; Check...
	 JRST QUEHS2		; Nope, try another site.

	; Found existing sitelist for host. Append to that...
	LNAPP [LISTAR(D)+1 ? B]
	JRST QUEHS9		; No need to schedule since request msut already exist.

	; No existing sitelist, must make one.
QUEHS7:	MOVE C,A		; Save site # in C
	MAKELN A,[A$QHST,,[B]	; Cons up LN for site # as first thing in sitelist.
		%LTVAL,,[C]]
	MAKELN A,[A$Q,,[$LLLST(L)]	; And now a LLN for whole thing.
		%LTLST,,[A]]
	MOVEM A,$LLLST(L)	; Store LP back, new sitelist is now consed onto front.
	MOVE A,QTMLEN		; Now must generate schedule request for unqueueing.
	MOVEI B,QUESND		; And routine addr to XCT in B.  Arg already in C.
	CALL SCHDI		; Schedule for c(QTMLEN) 30'ths from now.

QUEHS9:	TLO F,%QMLMD		; Indicate QML modified.
	POPAE P,[L,D,C,B,A]
	RET

SUBTTL Sending of queued messages
; QUESND - Routine to send queued messages.  
;	Given in A the site # to try un-queueing for, tries to send
;	all messages queued for that site.  Checks after each for
;	existence of any input request, and aborts recoverably if one exists.

QTMLEN:	30.*60.*15.	; Length of time to wait between unqueue attempts.

QUESND:	PUSHAE P,[A,B,C,D,E,L]
	TLZ F,%QULOS
	SKIPN $AROPN+QMLAR	; Check, and
	 CALL QMLGET		; make sure that QML is loaded.
	MOVE L,$ARLOC+QMLAR	; Make it current LSE.
	;; Now must find list for specified site.
	HRRZ D,$LLLST(L)	; Get LP to first LLN
	CAIA
QSND10:	 HRRZ D,LISTAR(D)	; Get next site LLN.
	JUMPE D,QSND90		; If exhaust list, ignore unqueue request.
	MOVE C,LISTAR(D)+1	; Get LP to its list.
	MOVE B,LISTAR(C)+1	; Get site # this list is for.
	CAME A,B		; If this is not the site we are unqueing for
	 JRST QSND10		;  get next site LLN.
	HRRZ C,LISTAR(C)	; Else see if any queued msgs here.
	JUMPE C,QSND65		; Jump to flush the LLN if not.
	;; Found site list!  D has LP to its LLN, C the LP to start of list
	;; which is either A$QFCT or A$ID; rest of list is A$ID.  There is
	;; one A$ID for each queued message.  A$QFCT is present if there
	;; have been failures to connect to the host, it holds the count.
	;; B holds this start of list so we can find the A$QFCT later.
	MOVE B,C		; Remember head of list.
	MOVE N,A		; Get host in N.
	CALL HFLS		; See if site is on losers list.
	 JRST [	STAT (,("Flushing messages queued to host "),HST(A))
		TLO F,%QULOS	; Make all message fail.
		JRST QSND20 ]
	STAT (,("Unqueueing to host "),HST(A))
	TLZ F,%MSGMD		; Say no messages in core yet.
	;; Begin loop thru list of queued msgs for this host.
QSND20:	LDB A,[$LAFLD,,LISTAR(C)]
	CAIE A,A$ID		; CDR down list until find an ID.
	 JRST [	HRRZ C,LISTAR(C)
		JUMPE C,QSND60
		JRST QSND20 ]
	MOVE A,C		; Set up SLP to message ID.
	CALL MSGGET		; Pull in that message.
	 JRST [	STAT (,("Note: Qmsg "),C(42),TLS(C),C(42),(" not found in MASTER, flushing."))
		JRST QSND50]	;  Couldn't find it, ignore and flush from QML.
	TLNE F,%QULOS		; If flushing these messages
	 JRST QSND22		;  don't bother connecting to the host.
	CALL SETMSM		; Find out if mailing or sending.
	CALL NETPTH		; Find path to host.
	 JRST QSND22		;   Maybe already connected.
	CALL NETICP		; Try to connect.
	 JRST QSND80		;  If lost, reschedule a request for this site.
	;; Site is alive; update the site list's failure count.
	LDB A,[$LAFLD,,LISTAR(B)]
	CAIN A,A$ID		; If are we at looking at msg-id list
	 JRST QSND22		;   there was no failure count yet.
	CAIE A,A$QFCT		; Is there a failure count?
	 JSR AUTPSY		;    Else random cruft - QML trashed?
	SETZM LISTAR(B)+1	; Zap failure count.
	TLO F,%QMLMD		; QML modified.
QSND22: ;; Now send to all rcpts queued for this site.
	CALL QSTSND		; Tries all.  Skips if still connected.
	 JRST QSND40		; Connections gone!
	SKIPN QSFCNT		; Check for any valid remaining rcpts
	 JRST QSND49		; Nope, flush current msg.
	JUMPL N,QSND40		; If net was zapped, always requeue!!
	TLNE F,%MSGMD		; Was MSG modified?
	 CALL MSGPUT		; Yes, write back out.
	JUMPN A,QSND55		; Some left - jump if that includes this site.
	JRST QSND50		; If not, go flush from this part of QML.

	; Network lossage while sending.  Re-queue, but first rotate the
	; message so another one gets its chance at first shot.  This
	; prevents a wedged msg from blocking all mail to that host.
QSND40:	LNCOPY B,[0 ? C]	; Copy SLN for this msg
	LNAPP [C ? B]		; Append copy to list for site.
	LNDEL C,LISTAR(D)+1	; Flush original from list.
	TLO F,%QMLMD
	JRST QSND70		; And now re-schedule for unqueueing.

	; Here when message is to be flushed from QML.
QSND49:	CALL MSGDEL		; Here to flush whole msg also.
QSND50:	HRRZ B,LISTAR(C)	; Get CDR before flushing...
	LNDEL C,LISTAR(D)+1	; Flush from list.
	TLO F,%QMLMD		; Indicate QML modified!
	MOVE C,B		; Next message after the flushed one
	MOVE B,LISTAR(D)+1	; Recover head of list (LNDEL may have changed)
	HRRZ B,LISTAR(B)
	JRST QSND56

	; Here when done with one message... check to see if OK to do another.
QSND55:	HRRZ C,LISTAR(C)	; Get CDR to next.
QSND56:	JUMPE C,QSND60		; If none left, exit.
	TLNN F,%QULOS		; If flushing, do them all at once
	 CALL IRQCHK		; Else, check for input requests first.
	  JRST QSND20		;  None, OK to continue!
	JRST QSND75		; Foo, must interrupt. Reschedule unqueueing...

	; Here when all (?) messages have been sent to site; see if
	; anything left, and flush site LLN if not.
QSND60:	FINDA B,[A$ID,,[LISTAR(D)+1]] ;See if any messages on list.
	 JRST QSND65		; None, flush list
	JRST QSND70		; Some, reschedule

QSND65:	LNDEL D,$LLLST(L)	; Else flush LLN from QML!
	CALL QMLPUT
	STAT (,("All qmsgs gone for "),HST(N))
	JRST QSND90		; Write out new QML and return.

	;Lost trying to ICP to site.  Keep count of failures.  If lost
	;700 times in a row, give up on the site. (i.e. down for a week)

QSND80:	FINDA B,[A$QFCT,,[B]]
	 CAIA
	  JRST QSND81		; Found failure count.
	HRRZ C,LISTAR(D)+1	; List for host.
	MAKELN B,[A$QFCT,,[LISTAR(C)]
		  %LTVAL,,0]	; Patch in failure count after host number.
	HRRM B,LISTAR(C)
QSND81:	TLO F,%QMLMD
	AOS A,LISTAR(B)+1	; Increase failure count.
	CAMGE A,HDOWN		; If not too many
	 JRST QSND70		;  try again in a while
	CSTAT (,("...Site down for a week, abandoning..."))
	HRRZ C,LISTAR(B)	; Get list of message IDs
	TLO F,%QULOS		; Flag to cause errors on all messages
	JRST QSND20

	; Must reschedule unqueue request for this site.  Entry at QSND75
	; reschedules for as soon as conveniently possible.
QSND70:	MOVE A,QTMLEN		; Try again in 15 min.  (later, be smarter)
	CAIA
QSND75:	 SETZ A,
	TLNE F,%MSGMD		; Make SURE that everything's safe!
	 CALL MSGPUT
	TLNE F,%QMLMD
	 CALL QMLPUT
	MOVEI B,QUESND		; Rtn to xct.
	MOVE C,-5(P)		; Site to crunch. (original arg in A)
	CALL SCHDI		; schedule at c(A) from now.

QSND90: CALL NTDISC		; Close net connections if any.
	POPAE P,[L,E,D,C,B,A]
	TLZ F,%QULOS
	RET

	; Kludge routine to flush messages for hosts in the HFLUSH table.
	; Skip return if site in N is not on losers list, else return.
HFLS:	PUSHAE P,[A,N]
	MOVSI A,-HFLUSN		; Get table of losing sites.
HFLS1:	CAMN N,HFLUSH(A)	; Is this site a loser?
	 JRST HFLS2		;  Yes, failure return.
	AOBJN A,HFLS1
	AOS -2 (P)
HFLS2:	POPAE P,[N,A]
	RET



; QSTSND - Takes current MSG-LSE, sends to all of its recipients at site
;	specified by N.  Skips on return if still connected to site.
;	Sets A 0 if no rcpts are left for this site, -1 if some are.

.SCALAR QSFREQ,QSFCNT

QSTSND:	PUSHAE P,[B,C,L]
	MOVE L,$ARLOC+MSGAR	; use MSG-LSE as current.
	FINDA A,[A$ID,,[$LLLST(L)]]
	 JSR AUTPSY
	STAT (,("QID="),TLS(A))
	CALL NETSND		; Do it.
	 CAIA			; Net broken, no skip on return.
	  AOS -3(P)		; Still there, skip.
	SKIPN NSCTF		; Anything failed?
	 SKIPE NSCTS		; or anything sent?
	  CAIA
	   JRST QSTS95		; Nope, just count # rcpts left and return.
	MOVEI A,MF%QSNT+MF%FAI	; Yes, go finalize message
	TLZE F,%QULOS
	 JRST [	CALL MSGFIN	; Stupid crock.
		TLO F,%QULOS	; To simulate push/pop of flag.
		JRST QSTS95]
	CALL MSGFIN		; for sents/fails only.
QSTS95:	CALL MSGRCK		; Get # of active rcpt's.
	MOVEM A,QSFCNT
	MOVE A,NSCTQ		; Return in A the # of rcpts queued for site.
	POPAE P,[L,C,B]
	RET

; MSGRCK - Counts # of active rcpts for LSE in MSGAR.
;	MSGAR - LSE holding message
; Returns .+1
;	A - # of active rcpts seen (non-pseudo A$RCP's).

MSGRCK:	PUSHAE P,[B,C,L]
	MOVE L,$ARLOC+MSGAR
	SETZ A,
	SKIPA B,$LLLST(L)
MSGRC2:	 HRRZ B,LISTAR(B)
	FINDA B,[A$RCP,,[B]]
	 JRST MSGRC4
	FINDA C,[A$RPSN,,[LISTAR(B)+1]]
	 AOJA A,MSGRC2
	  JRST MSGRC2
MSGRC4:	POPAE P,[L,C,B]
	RET


	; New XRCP-hacking routines.
.INSRT SYSNET;NETSND >

SUBTTL Reminder Queueing

;;; REMIND - Queue a (new) reminder.  Given current MSG-LSE that has reminder
;	specs, puts it into appropriate place on RML list.  Does not generate
;	a schedule request unless nothing was previously on the RML, since
;	one is always pending for the first thing on RML.

REMIND:	PUSHAE P,[A,B,L]
	SKIPN $AROPN+MSGAR	; Make sure there's a current MSG-LSE
	 JSR AUTPSY
	MOVE L,$ARLOC+MSGAR	; Make it current
	CALL RTMFND		; Find next (actually, first) time to send it 
	 SETZ A,		; If no next time, send right away - either not
				; a reminder, or time's already past!
	FINDA B,[A$TNXT,,[$LLLST(L)]]		; Find A$TNXT LN to save in.
	 JRST [	MAKELN B,[A$TNXT,,[$LLLST(L)]	; make it if necessary.
			%LTVAL,,0]
		MOVEM B,$LLLST(L)
		TLO F,%MSGMD	; If added LN, msg obviously modified.
		JRST .+1]
	CAME A,LISTAR(B)+1	; If about to change value in LN,
	 TLO F,%MSGMD		; indicate msg modified, must be written out.
	MOVEM A,LISTAR(B)+1	; Save next-time-to-send.

	; Now create a RML entry for this message.  LP to next-time-to-send
	; is in B.
	FINDA A,[A$ID,,[$LLLST(L)]]	; Get LP to msg-ID
	 JSR AUTPSY
	SKIPN $AROPN+RMLAR		; Make sure RML loaded.
	 CALL RMLGET
	MOVE L,$ARLOC+RMLAR		; Make RML current...
	LNCOPY B,[$ARLOC+MSGAR ? B]	; And create copy of msg-ID in RML LSE
	LNCOPY A,[$ARLOC+MSGAR ? A]	; Likewise for A$TNXT.
	HRRM B,LISTAR(A)		; Make A$TNXT first, pointing to msg-ID.
	MAKELN A,[A$T,,0		; And finally stick under a LLN.
		%LTLST,,[A]]

	; Have created RML entry (LLP in A) ready for insertion into
	; RML... now stick it in the right place.
	HRRZ B,$LLLST(L)	; Save RML pointer for checking after insert.
	CALL SRTINS		; Takes LLN in A, inserts into sorted RML list
	SKIPE MKQFLG
	 JRST REMIN0
	CALL RMLPUT		; Now write out new RML.
	TLNE F,%MSGMD		; And MSG-LSE if necessary. (see notes below)
	 CALL MSGPUT
REMIN0:	CAIN B,0		; If RML was empty before adding entry,
	 CALL SCHREM		; Then go schedule the remind-list!
	POPAE P,[L,B,A]
	RET

;;; NOTE about sequence of file updates:
;	The basic philosophy is that anything entered in MASTER must
; reflect the complete current state of the message, so that
; reconstruction of both RML, QML, etc can be done from MASTER and
; its messages alone.  Beyond that, some efficiency considerations:
;	Were the MSG-LSE (and MASTER) written out first and the system
; crashed before the RML was updated as well, then
; MASTER's info would be correct, but RML's would be incomplete as no
; entry for that message would exist, and no reminder-sending processing
; would be initiated for it.  The solution is to completely recreate the
; RML from MASTER after each COMSAT startup... ugh.
;	However, if the RML is written out before MASTER, then if a crash
; intervenes between writing RML and MASTER, the message will not have
; been stored although the RML contains an entry pointing to that
; message ID.  This is easily solvable by the strategy of ignoring any
; RML reference to a message not on the MASTER list, and requires no
; computational overhead.
;	Hence, RML is put out before the MSG-LSE is.

SUBTTL Reminder Sending
; REMSND - Send a reminder, invoked by scheduler when it thinks time has come
;	for first reminder on list.  Must check truth of this, then:
;	Must first pull into current MSG-LSE, find next time to send
;	and include this information in message if desired, then do a
;	normal-priority sending (all local, but queue if anything for net)
;	Then pop it off RML list and put new time back on in right place,
;	and write out new RML, etc... Then re-schedule self for next
;	due reminder.

	; Throughout this routine,
	;	E holds LLP to LLN for activated RML entry, and
	;	D holds LP to first LN on the entry's sublist, ie LISTAR(E)+1.
	;	C holds next-time-to-send, or 0 if no more.
REMSND:	PUSHAE P,[A,B,C,D,E,L]
	SKIPN RMLAR		; Ensure RML in core.
	 CALL RMLGET
	MOVE L,$ARLOC+RMLAR
	HRRZ E,$LLLST(L)	; Get LP to first LLN
	JUMPE E,REMS90		; If nothing on RML, ignore activation completely.
	MOVE D,LISTAR(E)+1	; Get LP to first LN of first RML node.

	CALL DATIME"TIMGT	; Get current time for use by remind rtns
	MOVEM A,RTMCUR		; Save.  See note at RTMCUR.
	MOVE A,LISTAR(D)+1	; And now get time for earliest reminder!
	CAMLE A,RTMCUR		; Less than or eq to current time??
	 JRST REMS80		; No, still in future?  Must re-schedule,
				; somehow got triggered too soon.

	; Time to process a RML entry - take it off RML, and
	; get msg it points to.
	HRRZ A,LISTAR(E)	; Get CDR to next entry, and make it
	HRRM A,$LLLST(L)	; new head of RML - current entry now off.
	FINDA A,[A$ID,,[D]]	; Find ID SLN in entry's list.
	 JSR AUTPSY		; Bleah??
	CALL MSGGET		; Now snarf up message.
	 JRST REMS75	; Ugh, not found. Flush RML entry, assuming MASTER is right.

	; Message read in, first check that it really wants to be sent.
	MOVE L,$ARLOC+MSGAR		; Make MSG-LSE current
	FINDA A,[A$IDRM,,[$LLLST(L)]]	; Is this message actually offspring of a reminder?
	 JRST REMS75			; If so, ignore this RML entry and flush it.
	FINDA A,[A$TNXT,,[$LLLST(L)]]	; Get next-time-to-send accding to message
	 JRST REMS75		; Foo, it has none?? ignore & flush RML entry.
	MOVE A,LISTAR(A)+1	; Get value of next-time-to-send
	CAMLE A,RTMCUR		; Less or eq to current time?
	 JRST [	MOVE L,$ARLOC+RMLAR	; In future! must reset RML entry.
		MOVEM A,LISTAR(D)+1	; by storing updated time-to-send
		JRST REMS50]		; and re-inserting on RML, and scheduling.

	; Yes, definitely sending message.  Before doing so, determine
	; next time this reminder will be sent.
	CALL RTMFND		; Now find next time to send.
	 JRST REMS30		; None - go inform that this is last reminder.
	MOVE C,A		; Save next-time in C.
	FINDA A,[A$TEXP,,[$LLLST(L)]]	; Find expiration spec.
	 JRST REMS40		; None? then don't bother with any status report.
	MOVE B,LISTAR(A)+1	; Get it
	TLNE B,-1		; If anything in LH, it's an expiration time.
	 JRST [	CAMGE B,C	; Compare with next time
		 JRST REMS30	; Ugh, next time is greater than expiration. No more.
		JRST REMS40]	; Is OK...
	SOSLE LISTAR(A)+1	; Expiration count.  Decrement count
	 JRST REMS40		; And jump if still OK.

	; No more reminders after this one.  Generate note to add onto
	; front of message.
REMS30:	SETZ C,			; First indicate no next-time.
	FINDA B,[A$MTXT,,[$LLLST(L)]]
	 JSR AUTPSY
	SAOBEG TMPC,
	FWRITE TMPC,[[Note: this is the final message for this reminder.

],TLS,B]
	LNDEL B,$LLLST(L)	; Flush old message-text
	MAKELN A,[A$MTXT,,[$LLLST(L)]	; make SLN of new text
		%LTSAO,,0]
	HRRM A,$LLLST(L)	; Store on msg list.
	

	; Must rename A$ID to A$IDRM and generate new unique A$ID for
	; message before sending.
REMS40:	FINDA A,[A$ID,,[$LLLST(L)]]
	 JSR AUTPSY
	MOVEI B,A$IDRM		; Turn ID into parent-reminder ID.
	DPB B,[$LAFLD,,LISTAR(A)]
	CALL IDSET		; Now create a new ID, tack onto list.
	TLO F,%MSGMD		; And indicate it's modified.
	SETZ MF,
	CALL MAIL		; Send it!  This will queue if necessary.
	 JFCL


	; Reminder sent, now see what time if any to resend.
	JUMPE C,REMS60		; If no more, flush from master & RML.

	MOVE L,$ARLOC+RMLAR		; Else must fix up next time.
	FINDA A,[A$ID,,[D]]		; Get back ID to reminder
	 JSR AUTPSY
	CALL MSGGET			; recover message.
	 JSR AUTPSY			; Huh? we did this OK before!

	FINDA B,[A$TNXT,,[$LLLST(L)]]	; Find LN to hold time-of-next-sending
	 JSR AUTPSY
	MOVEM C,LISTAR(B)+1		; Store time to send next.
	FINDA B,[A$TEXP,,[$LLLST(L)]]	; see if have expiration count
	 CAIA
	  JRST [MOVE A,LISTAR(B)+1	; have expiration spec,
		TLNN A,-1		; skip unless it's a count
		 SOS LISTAR(B)+1	; in which case decrement it!
		JRST .+1]
	CALL MSGPUT		; Now write back reminder.

	; Now pop RML entry off RML list, and put back in right place.
	MOVE L,$ARLOC+RMLAR		; Make RML current
	HRRZ A,LISTAR(E)		; Get CDR to next entry, and make it
	HRRM A,$LLLST(D)		; first thing on list.
	MOVEM C,LISTAR(D)+1		; Now store new time to hack this rmdr!

	; Now re-insert entry onto RML, and write list back.
	; RML must be current.
REMS50:	MOVE A,E		; arg - LLP to entry.
	CALL SRTINS		; In it goes.
	CALL RMLPUT
	JRST REMS80		; Now schedule next reminder.

	; Here when reminder isn't to be sent any more.  Flush.
	; Assumes MSG-LSE current.
REMS60:	FINDA B,[A$ID,,[$LLLST(L)]]
	 JSR AUTPSY
	MOVE A,LISTAR(A)+1		; Get SPT for MSG ID.
	ADD A,$LSLOC(L)			; Abs.
	CALL MSGDEL			; Glurgle! Down it goes. (see note below)
REMS75:	MOVE L,$ARLOC+RMLAR		; Here to flush current entry from RML.
	LNDEL E,$LLLST(L)
	CALL RMLPUT			; Out with RML, and that's it.

REMS80:	CALL SCHREM			; Schedule next reminder.
REMS90:	POPAE P,[L,E,D,C,B,A]
	RET

; NOTE about sequencing of file writes:
;	As opposed to REMIND, REMSND writes out the MSG/MASTER before the
; updated RML.  This is optimal because at worst an old RML will initiate
; a reminder-send request immediately for the message in question, which may
; even be deleted - if deleted, the rule about "ignore it" wins here, and if
; not then the information in the MSG-LSE itself (specifically A$TNXT) will
; serve to correct RML's backwardness quite satisfactorily, and the message will
; not be sent again until it is actually time to do so.

IFN 0,[
Algorithm for finding next time to send is simply to calculate the earliest
possible time for each time-spec, and use the earliest one found.  To actually
find the earliest time for an individual time spec:

1) Get current time (or base time if given)
2) Plug given time into all wild slots.
3) Later than current time?  If so, go to 7!
4) not late enough.  If using a base time, use current time instead and go to 2.
5) using current time.  Increment, using LOWEST wild item or given abs increment.
	(Must check to ensure that eventual winnage is actually possible.
	obviously if year is '65, we'll never get anywhere)
6) Go back to 3 and so forth, until get a time in the future.
7) Check: is obtained time past specified expiration date if any?
8) If not, found it... stop and rest.
]

DATIME"TM%DOW==700000		; 2.9-2.7	0-7	1-7
DATIME"TM%HR==  76000		; 2.6-2.2	0-31	0-23
DATIME"TM%MIN==  1760		; 2.1-1.5	0-63	0-59

DATIME"TM$DOW==(.BP DATIME"TM%DOW,)
DATIME"TM$HR== (.BP DATIME"TM%HR,)
DATIME"TM$MIN==(.BP DATIME"TM%MIN,)
DATIME"TM$YR2==(.BP <DATIME"TM%YR&<DATIME"TM%YR#DATIME"TM%YR_2>>,)	; Byte ptr to bottom 2 bits of DATIME"TM%YR.

; Wildness is indicated by an 0 value for all of YEAR, MONTH, DAY.
; DOW is special; the following cases exist.
; DAY	DOW
;  *	 *	DAY is wild and message is sent every day.
;  *	 n	Message sent only on given DOW.
;  n	 *	Message sent only on given DOM.
;  n	 n	Message is sent only when both DOM and DOW agree.  This
;		is great for things like "Friday the 13th"!


; RTMFND - Given current MSG-LSE, finds next (future) time to send.
;	Hacks all time-specs, returns time in A and skips.
;	non-skip indicates no more reminders to be sent.
;	Does NOT hack any of: Expiration count/date or Next-send time.

RTMFND:	PUSH P,B
	SETZM RTMNXT		; Clear "best-so-far" variable.
	CALL DATIME"TIMGT	; Get current time
	MOVEM A,RTMCUR
	SKIPA B,$LLLST(L)	; Get LP to MSG-LSE list.
RTMFN2:	 HRRZ B,LISTAR(B)	; on loop, get CDR to next.
	FINDA A,[A$TLST,,[B]]	; Try to find spec list
	 JRST RTMFN5		; No more.
	CALL RTMFN		; Get next-time for this spec.
	 JRST RTMFN2		; None available.
	SKIPE RTMNXT		; If no spec stored yet, always store it.
	 CAMG A,RTMNXT		; Aha, compare with currently best (earliest)
	  MOVEM A,RTMNXT	; New time is less, use that!
	JRST RTMFN2		; Try the rest.

RTMFN5:	SKIPE A,RTMNXT		; Return this...
	 AOS -1(P)		; And skip if returning a real time.
	POP P,B
	RET

; RTMFN - Given LP in A to a reminder-time-spec LLN, figures out next
;	time to send according to that spec.  RTMCUR must have been set up.
;	Returns time in A and skips if found.

RTMFN:	PUSH P,B
	FINDA B,[A$TBAS,,[LISTAR(A)+1]]	; See if base time specified.
	 TDCA B,B
	  MOVE B,LISTAR(B)+1		; Get it if so, else set 0.
	MOVEM B,RTMBAS
	FINDA B,[A$TINC,,[LISTAR(A)+1]]	; See if time increment specified.
	 TDCA B,B
	  MOVE B,LISTAR(B)+1		; Same as above.
	MOVEM B,RTMINC
	FINDA B,[A$TSPC,,[LISTAR(A)+1]]	; Now find the time spec!
	 JSR AUTPSY			; Foo! must always have!!
	MOVE A,LISTAR(B)+1		; Get it, and
	POP P,B
	PJRST RTMF			; Now figure out next time!

BVAR
RTMNXT:	0	; Holds computed time for next reminder.
RTMCUR:	0	; Holds current time in standard format. (only Y/M/D used)
RTMBAS:	0	; Holds base time to use, also standard format. ( " )
RTMINC:	0	; Holds desired incr, if no wild specs.  Val in minutes.
EVAR

; RTMF - Messy monster to figure out next time to send a reminder,
;	given a reminder-time spec and the assumption a reminder has
;	just been sent (so no need to worry about sending one in the past)
;	RTMCUR must be set up with current time, RTMBAS with base time
;	to use, RTMINC with increment if any, A with time-spec.

RTMF:	PUSHAE P,[B,C,D,E]
	SKIPN B,RTMBAS		; If base time given, use it initially.
	 MOVE B,RTMCUR		; Else use current time.
RTMF05:	AND B,[DATIME"TM%YR+DATIME"TM%MON+DATIME"TM%DAY]
	TLNE A,(DATIME"TM%YR)		; Has year specification?
	 TLZ B,(DATIME"TM%YR)		; Yes, wipe from base time.
	TLNE A,(DATIME"TM%MON)		; Has month?
	 TLZ B,(DATIME"TM%MON)		; Yes, wipe from base.
	TLNE A,(DATIME"TM%DAY)		; This is getting
	 TLZ B,(DATIME"TM%DAY)		; monotonous.
	IOR B,A			; Now IOR them together to produce complete spec!
	LDB C,[DATIME"TM$HR,,B]	; Start getting time
	LDB D,[DATIME"TM$MIN,,B]	; into
	IMULI C,60.
	ADDI C,(D)
	IMULI C,60.*2.		; Standard halfsec form.
	HRR B,C			; Now have specified time in standard format!
RTMF10:	CAMG B,RTMCUR		; Is resultant greater than current time?
	 JRST [	SKIPN RTMBAS	; No.  Were we using a base time?
		 JRST RTMF30	; If not, just go increment since time is already past.
		SETZM RTMBAS	; If using base time, zap it and don't use any more.
		MOVE B,RTMCUR
		JRST RTMF05]

	; Time is greater than current!  Now must check esoteric stuff
	; like DOW, unless using RTMINC.
	SKIPE RTMINC		; Using RTMINC?
	 JRST RTMF70		; Yeah, ignore all else and return.
	TRNN A,DATIME"TM%DOW		; Is DOW specified?
	 JRST RTMF70		; No, all's well.
	LDB C,[DATIME"TM$DOW,,A]	; Bleah. Get DOW to check for.
	PUSHAE P,[A,B]
	MOVE A,B		; Set up current stuff for munching.
	CALL DATIME"TIMADY		; Get time in abs # days
	IDIVI A,7		; Get DOW-1 in B
	MOVEI D,1(B)		; Get DOW in D
	POPAE P,[B,A]		; Restore stuffs.
	CAIN C,(D)		; Compare with desired DOW.
	 JRST RTMF70		; Hurray!
	SUBI D,(C)		; Foo. Find difference in days.
	CAIL D,0
	 SUBI D,7		; If pos, adjust, to get # days in future for DOW.
	MOVMS D			; It really works...
	JRST RTMF32		; and jump into increment-day rtn.

	; Day increment!  Any attempt to find a more future date must start here!
	; If RTMINC is specified, it is applied without question.
RTMF30:	MOVEI D,1		; Before testing wildness, set up increment.
RTMF32:	SKIPE RTMINC
	 JRST RTMF60		; Uh-oh. RTMINC non-Z means simply add increment.
	TLNE A,(DATIME"TM%DAY)		; Wild day?
	 JRST RTMF40		; Nope, try incrementing month.
	LDB C,[DATIME"TM$DAY,,B]	; Get current day
	ADDI C,(D)		; Increment
	CAIG C,28.		; If less than final DOM for smallest month,
	 JRST [	DPB C,[DATIME"TM$DAY,,B] ; Win! put back into time
		JRST RTMF10]	; and continue.
	; Ugh, must check out day increment.
	LDB D,[DATIME"TM$MON,,B]	; Find what month it is.
	CAIN D,2		; February?
	 JRST [	LDB E,[DATIME"TM$YR2,,B] ; Pouah! Why can't the world be simple?
		CAMG C,(E)[29. ? 28. ? 28. ? 28.]
		 JRST RTMF10	; Is OK...
		JRST RTMF37]	; NOT OK!
	CAMG C,DATIME"TMONLN(D)	; Check max month length.
	 JRST RTMF10		; OK...

	; Day-increment went into next month!
RTMF37:	MOVEI C,1
	DPB C,[DATIME"TM$DAY,,B]	; Reset to 1, and drop thru to try incrementing month!

	; Increment month!
RTMF40:	TLNE A,(DATIME"TM%MON)		; Wild month?
	 JRST RTMF50		; Nope, try incrementing year.
	LDB C,[DATIME"TM$MON,,B]	; Get current month
	ADDI C,1
	CAIG C,12.		; Within year bounds?
	 JRST [	DPB C,[DATIME"TM$MON,,B] ; Yep, success.
		JRST RTMF10]	; Go back & try again.
	MOVEI C,1		; Oops, overstepped!  Must reset to 1 and increment year
	DPB C,[DATIME"TM$MON,,B]	; Drop through...

	; Increment year!
RTMF50:	TLNE A,(DATIME"TM%YR)		; Last chance! wild year?
	 JRST RTMF90		; No, no hope... can't find any more times to send.

	; Wild year - Increment year.  This loses only if going past 2027.
	LDB C,[DATIME"TM$YR,,B]	; Get year of current spec
	ADDI C,1
	CAILE C,177		; Overflow?
	 JRST RTMF90		; Yeah, this reminder is a goner.
	DPB C,[DATIME"TM$YR,,A]	; Put back.
	JRST RTMF10		; Back to check...

	; Increment via RTMINC.
RTMF60:	PUSH P,A
	MOVE A,B
	CALL DATIME"TIMSEC		; Convert current spec to abs # secs
	MOVE C,RTMINC
	IMULI C,60.		; Get # of secs to add as increment.
	ADD A,C			; Not ADDI, may be very large.
	CALL DATIME"SECTIM		; Convert back now.
	MOVE B,A
	POP P,A
	JRST RTMF10		; Now try again.

RTMF70:	MOVE A,B		; Return in A the time obtained.
	AOSA -4(P)
RTMF90:	 SETZ A,		; Return here when failed to find another time.
	POPAE P,[E,D,C,B]
	RET

SUBTTL SNDMSG - General Message Sending


; SNDMSG - Given LP to an A$RCP in A,  (assumes current LSE is MSG)
;	site # in N (0 for local), sends locally or over net.  If
;	net connections not yet open, tries to ICP.
;	Never skips.  A has return code; 0=win, 1=temp loss, 2=perm loss,
;	3= temp loss but keep sending to this host (e.g. disk full).
;	Whether successful or not, B if nonzero will contain a SLP to
;	an informational message, which should be passed along to sender.

SNDMSG:	PUSHAE P,[C,D]
	MOVE A,LISTAR(A)+1	; Replace LLP by LP to list in A.
	FINDA B,[A$RNAM,,[A]]	; Find name, and
	 JSR AUTPSY
	STAT (,("	TO-"),RABR,TLS(B)) ; Announce we're sending to it.
	CALL SETMSM		; Set Mail/Send modes.
	JUMPN N,[MOVEI B,SNDNET	; Check site #, jump if sending over net.
		JRST SNDMS4]

	FINDA B,[A$RTYP,,[A]]	; Not net, find rcpt type.
	 JRST [	MOVEI B,SNDNAM	; If no type, assume NAME.
		JRST SNDMS4]
	MOVSI C,-NRTYPS		; Some type, loop to find idx.
	SLNEA B,RTYPTB(C)
	 AOBJN C,.-1
	JUMPGE C,[MOVEI B,SNDNAM	; If no match, use NAME.
		JRST SNDMS4]
	MOVE B,SNDRTB(C)		; Get appropriate rtn for this type.

SNDMS4:	POPAE P,[D,C]
	PJRST (B)		; Execute - try to send.

BVAR
SENDSW:	0	; If sending,  -1 don't mail. 0 mail if failed.  1 always mail.
MAILSW:	0	; If mailing,  -1 don't notify. 0 notify if rcpt wants. 1 always notify.
SORMSW:	0	; 0 mail, -1 send.  Existence of A$RMDS sets SORMSW to -1, else 0.
EVAR

	; Given LP in A to rcpt list, sets mail/send modes.
SETMSM:	SETZM MAILSW
	SETZM SENDSW
	SETZM SORMSW
	PUSH P,B
	FINDA B,[A$RMDS,,[A]]
	 JRST SETMS3
	MOVE B,LISTAR(B)+1
	MOVEM B,SENDSW
	SETOM SORMSW
SETMS3:	FINDA B,[A$RMDM,,[A]]
	 JRST SETMS7
	MOVE B,LISTAR(B)+1
	MOVEM B,MAILSW
SETMS7:	POP P,B
	RET

SUBTTL SNDNET - Send message out over net.

	; Send message over net.  Hack ICP later if necessary.
SNDNET:	PUSHAE P,[C]
	MOVE C,A		; Save LP in C
	FINDA B,[A$RHST,,[C]]	; Find site
	 JSR AUTPSY		; If not sending over net, what are we doing here?
	MOVE B,LISTAR(B)+1
	CAME B,N		; Make sure we're sending to current site!
	 JRST [	MOVEI A,MR$TEH	; Hmm, site we want isn't current!
		JRST SNDN95]	; Don't ret err msg but do fail temporarily.

	SKIPN RELAY		; If we don't allow relaying
	 SKIPN HDRNMH		;  and sender is non-local
	  JRST SNDN88
	FINDA B,[A$ROK,,[C]]	;   and recipient is not ok to relay
	 JRST [	MOVEI A,MR$PEM	;    Sorry, relaying not allowed
		MAKELN B,[0 ? %LTSTR,,[LITSTR [Sorry, no relaying]]]
		JRST POPCJ]	;

SNDN88:	CALL NTSBEG		; Initiate message
	 JRST SNDN90		; Failed, investigate.

	; Rcpt accepted! send message.
	MOVEI A,(C)		; Get back ptr to rcpt's list.
	CALL NTSMID		; Send message text.
	 JRST SNDN90		; Error?
	CALL NTMEND		; Terminate msg (but don't disconnect)
	 JRST SNDN95		; Foo, temp error

	SETZB A,B	; Success return
	JRST POPCJ

SNDN90:	TRNN A,1	; Investigate failure return.
SNDN95:	 MOVEI B,0	; Temporary return.
	JRST POPCJ	; SLP to message in B.
SUBTTL SNDPGM - Send to Program, running as inferior.

;;; Send to Program.  Arrgh!  In default mode, routine
;;; only has responsibility for loading and starting, after
;;; which it returns successfully.  Failure return happens when
;;; the program cannot be found; temporary return when program
;;; is inaccessible for temp reasons.

; Routine given A$RCP of type PGM (LP in A to rcpt list) holding filename spec
; of program to load up and run, using message text as JCL.
; Default actions are to stick with the job, serving any JCL requests
; and handling interrupts, until either it has used 2 sec of run time
; or 1 minute of real time, whereupon it is disowned with BUMRTL set and
; left to its own devices.  These actions can be altered with the
; following attribute:

; The A$RPGD (R-PGM-DISOWN) value is interpreted as follows:
; RH -  corresponds to the ctl bits for the DISOWN symbolic call, which
; will be used when and if the job is disowned.  These bits are all
; passed on directly, with the following special actions:
;    Bit 1.4 is ALWAYS complemented - i.e. you must specify it to avoid the
;	"default" of setting BUMRTL (system guns job if it does nothing for 1/2 hr)
;    Bit 1.3 will cause immediate disowning.  Obviously no JCL can be supplied
;	for this case, and the LH bits are ignored.
; LH - bits specify mailer actions.
;    Bit 3.1 Says job never wants JCL.  This allows the mailer to proceed
;	asynchronously, handling interrupts as they occur.
;    Bit 3.2 Says job will want JCL again even after it manages to read
;	it all successfully.  This forces mailer to "stick with" job
;	until it gets disowned.
;    Bit 3.3 Says if disowning is attempted, job should instead be KILLED
;	and an error reported.  
;    Bit 3.4 Says that bits 4.9-4.1 contain the # secs of runtime job should
;	be allowed - real time is ignored.  Dangerous!!
;    Bit 3.5 Says job should not be run if another already exists with
;	identical UNAME/JNAME.  Note that this is checked BEFORE any
;	USET's are done (so setting JNAME that way will lose).  JNAME is
;	FN1 unless that is "TS", in which case it's the FN2.
; Future options?  - disown after n secs runtime, never disown?
; Use a special Batch-job to actually run a given program??
; Disown on lossage instead of killing (for debugging)?
P%NVRJ==1	
P%KEPJ==2
P%KILL==4
P%RTIM==10
P%UNIQ==20

BVAR
PGMQPS:	0	; Holds LP to rcpt's list.
PGMDSN:	0	; Holds value of R-PGM-DISOWN attrib
PGMJOB:	0	; -1 when inferior exists.
PGMJCL:	0	; -1 if have JCL for inferior.
PGMTXL:	0	; Holds # words of JCL we have in PGMAR.
PGMRTM:	0	; Runtime countdown
PGMSLP:	0	; Time to sleep
PGMSTA:	0	; Starting address of pgm.
EVAR

SNDPGM:	PUSHAE P,[C,D,E,L]	; Routine requires L be last pushed.
	MOVEM A,PGMQPS		;save LP pointing to rcpt's list.
	FINDA B,[A$RPGD,,[PGMQPS]]
	 TDCA B,B
	  MOVE B,LISTAR(B)+1		; Get value for PGM-DISOWN.
	MOVEM B,PGMDSN
	FINDA A,[A$RNAM,,[A]]
	 JSR AUTPSY
	STAT (,("Running program-"),RABR,TLS(A))
	SETZM PGMJOB			;not yet created inferior
	MOVE A,LISTAR(A)+1		;get the ascnt ptr
	ADD A,$LSLOC(L)			;make abs
	MOVE B,[PGFDEF,,PGFDEV]		; set up default block
	CALL FILPAR			;parse it
	MOVE A,[SIXBIT /DSK/]
	MOVEM A,PGFDEV			; Force device to DSK, so LOAD will win.

	; Hack JCL...
	SETZM PGMJCL			;Assume will be no JCL
	MOVE A,PGMDSN
	TLNN A,P%NVRJ			; Can we ignore JCL?
	 TRNE A,4			; Bit 1.3 means we certainly won't need any JCL.
	  JRST SNDP04			; Ah, yes!  Skip it...
	FINDA A,[A$MTXT,,[$LLLST(L)]]	; Must furnis JCL. Get msg text
	 JSR AUTPSY
	HLRZ B,LISTAR(A)+1		; Get char cnt
	ADDI B,4
	IDIVI B,5			; and # words
	CAIN B,0			; If nothing there,
	 JRST SNDP04			; Say we don't have any JCL.
	UAROPN [%ARTZM+%ARTCH,,PGMAR ? B]	; Open area for it.
	OUT(TMPC,OPEN(UC$UAR,PGMAR))
	OUT(TMPC,TLS(A))		; Stuff message text into it...
	MOVEM B,PGMTXL			; Save # wds of jcl
	SETOM PGMJCL			;indicate JCL available!
SNDP04:	ECALL OPNPGM,[[4,SNDP05],[11,SNDP05],[20,SNDP05],[27,SNDP05],[46,SNDP05]]
	 JRST SNDP95		; Any error not known perm. is assumed temp...
	JRST SNDP10		; Opened!

SNDP05:	MOVE A,[ASCNT [Couldn't open pgm file]]
	JRST SNDP79

	; Now try to create inferior...
SNDP10:	MOVE A,PGFFN1		;use FN1 as jname, unless it
	CAMN A,[SIXBIT /TS/]	; is "TS", in which case use FN2 as jname
	 MOVE A,PGFFN2

SNDP11:	ECALL OPNJB0,[[4,SNDP30]]
	 JRST SNDP95		;unknown type error, assume temporary.
	.UCLOSE USRI,		;hmph, it already exists. flush it if direct inferior.
	MOVE B,PGMDSN		; Check bit to see if OK to AOS
	TLNE B,P%UNIQ		; This bit set if wants unique job.
	 JRST SNDP90		; Already exists, doesn't want AOS'd, win return.
	AOS A			;"AOS" the jname in A (for now, really do AOS!)
	JRST SNDP11		;try again

SNDP30:	SYSCAL OPEN,[[.UIO,,USRO] ? ['USR,,0] ? [0] ? A ? CERR C]
	 JRST [	CAIN C,12	;was specified job somehow created meanwhile?
	 	 JRST SNDP11	; Try again.
		CAIE C,37	; No core available?
		 CAIN C,6	; or no slots available?
		  JRST SNDP95	; temp error, queue.
		JSR SYSLOS]	; ?? none of these, fail.
	SETOM PGMJOB		;indicate inferior created.
	SYSCAL OPEN,[[.UII,,USRI] ? ['USR,,0] ? [0] ? A ? CERR C]
	 JSR SYSLOS
	.USET USRI,[.RUNAME,,B]
	CSTAT (,(" Job-"),RABR,6F(B),(" "),6F(A))

	; Load the program from file
	SYSCAL LOAD,[CIMM USRI ? CIMM DKIC]
	 JRST [	MOVE A,[ASCNT [Couldn't load pgm file]]
		CSTAT (,(", couldn't load program file, killed."))
		JRST SNDP79]
	.IOT DKIC,PGMSTA		;get starting address
	HRRZS PGMSTA			;flush random PC flags, esp. FPD!
	.CLOSE DKIC,			;no further need for dsk chan
	.USET USRI,[.SUPC,,PGMSTA]	;set inferior's starting address
	.USET USRI,[.RINTB,,INFBIT]	;find interrupt bit for this inferior
	FINDA A,[A$CSN,,[$LLLST(L)]]	; Find sender's name
	 JRST [	FINDA A,[A$SNM,,[$LLLST(L)]]
		 JSR AUTPSY
		JRST .+1]
	CALL CVLS6		; Convert to 6bit
	XCTILO [.USET USRI,[.SXUNAME,,A]]	; and set job's XUNAME to that.
	 JFCL
	SKIPE PGMJCL			;If program has JCL, tell it
	 .USET USRI,[.SOPTION,,[%OPCMD,,]]

	; Now hack optional USETs if any.
	SKIPA D,PGMQPS
SNDP36:	 HRRZ D,LISTAR(D)
	FINDA D,[A$RPGU,,[D]]	; Look for R-PGM-USET
	 JRST SNDP38			; None or none left, let's go!
	SKIPN C,LISTAR(D)+1		; Get LP to list
	 JRST SNDP36			; Ignore if nothing.
	MOVE A,LISTAR(C)+1		; Get LH/Symbol to .USET.
	HRRZ C,LISTAR(C)
	CAIE C,0
	 MOVE C,LISTAR(C)+1		; Get value to .USET to.
	HRLZS A
	JUMPGE A,SNDP36			; Ignore if reading!!
	HRRI A,C			; Get USET word in A
	XCTILO [.USET USRI,A]		; Do it, carefully...
	 JRST [	CALL PGMBGE		; Ugh!
		FWRITE TMPC,[[ILOPR while XCT'ing a USET for job!
USET type ],LHV,A,[, attempted setting to ],HV,C]
		JRST SNDP76]
	JRST SNDP36

	; Ready to start program....
SNDP38:	MOVE A,PGMDSN
	TRNE A,4			; Is bit 1.3 set - immediate disown?
	 JRST SNDP70			; Yep, go off & do it.
	MOVEI B,2			; Get default # secs runtime.
	TLNE A,P%RTIM			; But if explicitly specified,
	 LDB B,[331100,,A]		; Pluck it out.
	IMUL B,[1000000./4]		; & get # of 4-usec ticks.
	MOVEM B,PGMRTM			; Store run-time countdown.
	TLNE A,P%RTIM			; Another test of same bit.
	 SKIPA A,[SETZ-1]		; If set, stick with job forever.
	  MOVEI A,12.			; Else only for 12*5 seconds.
	MOVEM A,PGMSLP
	TLO F,%PGMRN			;tell int. handler to handle the ints, and
	.SUSET [.SIMSK2,,INFBIT] 	;enable ints from inferior
	
SNDP40:	.USET USRI,[.SUSTP,,[0]]	;start it!
SNDP41:	SOSGE PGMSLP
	 JRST SNDP70			;disown after just so long
	.SUSET [.SADF2,,INFBIT]		;clear defer bit
	MOVEI C,30.*5			;sleep for 5 sec
	.SLEEP C,
	.SUSET [.SIDF2,,INFBIT]		;defer... don't let it interrupt.
	.USET USRI,[.RRUNT,,C]		;read run-time so far
	CAML C,PGMRTM			; Greater than allowed?
	 JRST SNDP70			;indeed. disown it.
	JRST SNDP41			;not yet, keep waiting

	; Dismiss to here upon inferior interrupt!
SNDP60:	.USET USRI,[.RPIRQC,,C]	; (Used below)
	.USET USRI,[.RSV40,,A]	;get .BREAK inst or whatever it is...
	LDB B,[$OPCOD,,A]	;What instruction caused it 
	CAIN B,<.BREAK_-33>
	 JRST SNDP62		;Go handle a .BREAK .
	CAIE B,<.LOGOUT_-33>
	 JRST SNDP75		;Not a .LOGOUT either, kill noisily.
	LDB B,[$ACFLD,,A]
	 JUMPE B,SNDP75		;.LOGOUT 0, is an error, kill noisily.
	JRST SNDP77		;Else it wants to die, kill quietly.

; Come here if the job did some .BREAK .
SNDP62:	LDB B,[$ACFLD,,A]
	CAIE B,12		;request-info type .BREAK?
	 JRST [	CAIN B,16	;type asking for death?
		 JRST SNDP77	;yes, die quietly
		JRST SNDP75]	;nope, die noisily.
	.ACCESS USRI,A		;point to effective address of .BREAK
	.IOT USRI,A		;get the command word [*** Should protect from MPV ***]
	LDB B,[221100,,A]	;see what type
	CAIE B,5		;JCL related?
	 JRST SNDP75		;nope, ugh
	.USET USRI,[.SAPIRQC,,[%PIBRK]] ;turn off the interrupt for inferior
	JUMPL A,[SETZM PGMJCL	;if type=write, indicate JCL no longer avail.
		.USET USRI,[.ROPTION,,A]
		TLZ A,%OPCMD
		.USET USRI,[.SOPTION,,A]
		JRST SNDP40]
	SKIPN PGMJCL		;if JCL not avail, ignore request to read.
	 JRST SNDP40

	;now write JCL into place specified by RH of A.
	MOVN B,PGMTXL		;make aobjn pntr to jcl
	HRLZ B,B
	HRR B,$ARLOC+PGMAR	; Get RH = loc of text.
	.ACCESS USRI,A
	.ACCESS USRO,A
SNDP64:	.IOT USRI,C		;read to ensure zero
	JUMPN C,SNDP40
	MOVE C,(B)		;if zero, get string word
	.IOT USRO,C		;and write into inf.
	AOBJN B,SNDP64
	;that's all-- no need to write terminating zero wd since wd is already
	;zero if such writing is possible!
	STAT (,("Program gobbled all JCL..."))
	JRST SNDP40
	
	;come here to disown job and let it run by itself.
SNDP70:	MOVE A,PGMDSN
	TRC A,10		; Complement 1.4 ...
	TRNE A,4		; Is 1.3 (start after disown) set?
	 JRST SNDP72		; Yup, go do that.
	TLNN A,P%KILL		; Well, is bit set to kill on disown attempt?
	 JRST SNDP72		; Nope, go ahead.
	CALL PGMBGE		; Ugh!  Must kill it.
	FWRITE TMPC,[[Program timed out, killing instead of disowning!]]
	CSTAT (,("Timed out, killing."))
	JRST SNDP76

SNDP72:	SYSCAL DISOWN,[CTLI (A) ? CIMM USRI]
	 JSR SYSLOS			;glub?
	.SUSET [.SAMSK2,,INFBIT]	;disable inferior ints.
	CSTAT (,(" Disowned."))
	JRST SNDP90			;done...

	;come here to kill job for some reason, noisily.  send message back
	;detailing circumstances.
SNDP75:	CALL PGMBGE		; Init for err processing.
	FWRITE TMPC,[[RUN-invoked job hit fatal interrupt.  File run was
],TI,133,6F,PGFDEV,[:],6F,PGFDIR,[;],6F,PGFFN1,[ ],6F,PGFFN2,TI,135,[  Relevant info follows:
]]
	MOVSI B,-20			;Dump ACs
	.ACCESS USRI,[0]
SNDP74:	.IOT USRI,A
	FWRITE TMPC,[RHV,B,[/ ],HV,A,[
]]
	AOBJN B,SNDP74
IRP VAR,,[UPC,JPC,MPVA,PIRQC,IFPIR,DF1,DF2,PICLR,RUNT,UUOH]
	.USET USRI,[.R!VAR,,A]
	FWRITE TMPC,[[.!VAR!/ ],HV,A,[
]]
TERMIN
	.USET USRI,[.RBCHN,,B]
	HRLZ A,B
	ADD A,[.RIOS,,A]
	.USET USRI,A
	FWRITE TMPC,[[.BCHN/ ],OCT,B,[
.IOS (of above)/ ],HV,A,[
]]
	TRNN C,%PIIOC			; If stopped on an IOC,
	 JRST SNDP76
	SYSCAL RFNAME,[CIMM USRI ? B	; find filenames for channel.
		CRET A ? CRET C ? CRET D ? CRET B]
	 JSR SYSLOS
	FWRITE TMPC,[[LOSING FILE: ],6F,A,[:],6F,B,[;],6F,C,[ ],6F,D,[
]]	
SNDP76:
	;now kill it
	AOSN PGMJOB
	 .UCLOSE USRI,
	CSTAT (,(" Killed."))
	.SUSET [.SAIFPIR,,INFBIT]
	JRST SNDP85		;go send text

	;here, kill job quietly.
SNDP77:	AOSN PGMJOB
	 .UCLOSE USRI,		;die.
	CSTAT (,(" Qilled."))
	.SUSET [.SAIFPIR,,INFBIT]
	JRST SNDP90		; we won!

SNDP79:	MOVE B,A
	CALL PGMBGE		; Initialize for error processing.
	FWRITE TMPC,[TC,B,[ - ],ERR,,]	; Get err msg
	JRST SNDP85

	;Bad condition of some sort during startup.  try to complain by
	;sending message.  ASCNT ptr in A to text.
SNDP80:	CSTAT (,(" Lost somehow"))
	CALL PGMBGE		; Init for err stuff.
	FWRITE TMPC,[TC,A,[
]]

	;send message to specified recipient detailing circumstances of
	;lossage. Create subject, sender name, etc.
SNDP85:	.CLOSE DKIC,		;program file may still be open
	AOSN PGMJOB		;skip if no job.
	 .UCLOSE USRI,		;else flush it.
	SKIPN $AROPN+PGMAR
	 JRST SNDP86
	FWRITE TMPC,[[Message follows:
-------
],TA,PGMAR]
SNDP86:	MAKELN A,[A$MTXT,,0 ? %LTSAO,,]
	PUSH P,L
	MOVE L,$ARLOC+MSGAR
	FINDA D,[A$TIM,,[$LLLST(L)]]
	 JSR AUTPSY
	MOVE D,LISTAR(D)+1		; Set up time
	FINDA C,[A$RPMR,,[PGMQPS]]	; Find name of maintainer if any.
	 SETZ C,			; None...
	POP P,L
	JUMPN C,[LNCOPY C,[$ARLOC+MSGAR ? C]
		MOVEI B,A$RCP
		DPB B,[$LAFLD,,LISTAR(C)]	; Copy into an A$RCP LN.
		JRST .+1]
	HRRM C,LISTAR(A)		; Cons onto message text.
	MOVEM A,$LLLST(L)
	MOVE B,D
	PUSH P,MF
	MOVEI MF,M%CORG+M%SSBJ+M%EMSG+M%ERR
	CALL MAIL
	 JFCL
	POP P,MF
	JRST SNDP99

			; For time being, loss return is actually win, since
			; err msg has already been sent and we don't need helpful
			; calling routine sending another one for us!

SNDP95:	MOVEI A,MR$TER		; Temp. error return.
	SETZ B,			; Indicate no message.
	JRST SNDPRT
SNDP90:	SNDP99:
	SETZB A,B			; No return of messages.
SNDPRT:	TLZ F,%PGMRN
	UARCLS PGMAR	;Flush copy of message made for JCL, if it's still around
	POPAE P,[L,E,D,C]
	RET
	

REMMSK:	0
	3777,,-1 ; 1 char in wd, mask out last 4
	17,,-1	; 2, zap last 3
	77777	; last 2
	377	; last 1

	;default file blk for pgm running
PGFDEF:	SIXBIT /DSK/
	SIXBIT /SYS/
	SIXBIT /TS/
	SIXBIT /FOO/

BVAR
PGFDEV:	0
PGFDIR:	0
PGFFN1:	0
PGFFN2:	0
INFBIT:	0		;holds interrupt bit for inferior
EVAR

OPNPGM:	SETZ ? SIXBIT /OPEN/ ? [.UII,,DKIC] ? PGFDEV
	PGFFN1 ? PGFFN2 ? SETZ PGFDIR

UBPFJ==10	;fail with 4 if no such job exists anywhere.
OPNJB0:	SETZ ? SIXBIT /OPEN/ ? [UBPFJ+.UII,,USRI] ? ['USR,,0]
	[0] ? A ? SETZ CERR C

	; Initialize for error when hit one in pgm.
PGMBGE:	PUSH P,A
	MOVEI A,EMSGAR
	CALL LSEOPN		; Open LSE for err message.
	MOVE L,$ARLOC+EMSGAR
	SAOBEG TMPC,		; Open chan for outputting on.
	POP P,A
	RET


SUBTTL SNDBUG, SNDBUL, SNDFIL, SNDAFL - various msg senders

	; For rcpts of type BUG.
SNDBUG:	PJRST SNDNAM		; For time being.

	; For rcpts of type @FILE.
SNDAFL:	JSR AUTPSY		; Shouldn't try to send.

	; For rcpts of type FILE.
SNDFIL:	PUSH P,C
	MOVE C,A
	FINDA A,[A$RNAM,,[C]]
	 JSR AUTPSY
	MOVE A,LISTAR(A)+1
	ADD A,$LSLOC(L)
	MOVE B,[LMFDEF,,LMFDEV]
	CALL FILPAR
	MOVEI A,LMFDEV
	MOVE B,C
	POP P,C
	PJRST WRTMSG

	; Rcpt type *MSG - Send Bulletin-board *MSG.
SNDBUL:	CALL BBDDFS		; Set up defaults for filename into LMFDEV.
	MOVEI B,LMFDEV
	EXCH A,B		; FILPT in A, LP to rcpt list in B.
	PJRST WRTMSG

BBDDFS:	PUSH P,B
	MOVE B,[LMBDEF,,LMFDEV]		; Set up defaults for filename.
	BLT B,LMFDEV+3
	FINDA B,[A$MFN1,,[$LLLST(L)]]	; First FN1 specified?
	 CAIA
	  JRST [MOVE B,LISTAR(B)+1	; If so, plug in.
		MOVEM B,LMFDEV+2
		JRST .+1]
	FINDA B,[A$MFN2,,[$LLLST(L)]]	; Second FN2 specified?
	 CAIA
	  JRST [MOVE B,LISTAR(B)+1
		MOVEM B,LMFDEV+3
		JRST .+1]
	POP P,B
	RET

LMBDEF:	SIXBIT /DSK/
	SIXBIT /.MSGS./
	SIXBIT /*MSG/
	SIXBIT />/

SUBTTL SNDNAM - Local Message sending

; SNDNAM - Sends normal NAME-type local message.
;	A has LP to rcpt's list.
;	returns in A, B like SNDMSG

LVAR LMPRCP:	0	; Holds LP to rcpt's list.

SNDNAM:	PUSHAE P,[C,D,E,LMPRCP]
	MOVEM A,LMPRCP		; Save LP to rcpt list
	FINDA A,[A$RNAM,,[LMPRCP]]
	 JSR AUTPSY
	MOVE E,LISTAR(A)+1
	ADD E,$LSLOC(L)		; Get ASCNT name in E.
	HLRZ D,E		; Check length of name.
	JUMPN D,SNDN10		; Null recipient?

	;; Hmmm, this message does not appear to be addressed to anyone.
	;; (Possibly this is a COMSAT error receipt failing.)  
	;; We will generate an error receipt with no recipients, so that
	;; this will be routed to DEAD-MAIL-RECEIPTS.

	STAT (,("	Null UNAME for local recipient!"))
	FINDA B,[A$RHDR,,[LMPRCP]]
	 JRST [	FINDA B,[A$MHDR,,[$LLLST(L)]]
		 JSR AUTPSY
		JRST .+1]
	MOVE B,LISTAR(B)+1		; B gets ASCNT to message header.
	ADD B,$LSLOC(L)
	FINDA C,[A$MTXT,,[$LLLST(L)]]
	 JSR AUTPSY
	MOVE C,LISTAR(C)+1		; C gets ASCNT to message text.
	ADD C,$LSLOC(L)
	UARPUSH EMSGAR			; Let's cons up an error receipt.
	OUTCAL(TMPC,CALL(EMSOPN))	; Open 
	PUSH P,L			; Stash LSE ptr.
	MOVE E,L			; Make copy for UUO rtns.
	MOVE L,$ARLOC+EMSGAR		; Switch to error message LSE.
	CALL IDSET			; Create ID for error receipt.
	CALL DATIME"TIMGET		; CDR holds message time.
	MAKELN A,[A$TIM,,0 ? %LTVAL,,[A]]
	HRRM A,$LLLST(L)		; Receipt will have no recipient!
	OUT(TMPC,("Message apparently addressed to local nobody??"),EOL)
	OUT(TMPC,("Text of bad message follows:"),EOL,("--------"),EOL)
	OUT(TMPC,TC(B),EOL,TC(C),EOL)	; Simply output the text.
	CALL EMSSND			; Now go send the message!
	UARPOP EMSGAR			; Recover LSE.
	POP P,L				; Recover ptr to it.
	JRST LMSN90			; Make like we delivered the message.

	;; Okay, apparently we actually have some kind of local recipient.

SNDN10:	MOVE D,[LMFDEF,,LMFDEV]
	BLT D,LMFDEV+4-1	; Set up defaults
	MOVE A,E		; Recipient name.
	CALL CVT76C		; Get SIXBIT name in A.
	HLRZ D,E		;get char cnt of name
	CAILE D,6
	 JRST [	STAT (,("	Name too long-- "),C(42),,TC(E),C(42),("."))
		FINDA D,[A$RNK,,[LMPRCP]]	;is recipient known?
		 JRST [	CSTAT (,(" Rcpt known, message not sent."))
			JRST LMSN90]		;return as "win" if known.
		CSTAT (,(" Rcpt not known, converted to "),C(42),6F(A),C(42))
		JRST .+1]	;not known, so send to truncation.
	MOVEM A,LMFFN1		;store into file block
	FINDA D,[A$RHSN,,[LMPRCP]]	; Must rcpt use a special dir?
	 CAIA				; Nope, assume <name>;<name> MAIL.
	  MOVE A,LISTAR(D)+1		; Yes, get 6bit dir name to use.
	CALL HASDIR		; Make sure dir really exists...
	 MOVE A,['COMMON]	; No, must use COMMON;<name> MAIL.
	MOVEM A,LMFDIR		; Store final choice in file block,
	CAME A,LMFFN1		; and if different from FN1 (usual case),
	 JRST [	CSTAT (,LPAR,6F(A),(";"),RPAR)	; document it in STATS.
		MOVE A,LMFFN1		; and ensure A has rcpt uname.
		JRST .+1]

	;now send as specified (push, append, cli-only, etc)
LMSN20:	SKIPN SORMSW
	 JRST LMSN50		;just mailing.

	; Sending. UNAME in A, LP to rcpt's list in B.
	MOVE B,LMPRCP
	CALL CLIMSG
	 CAIA
	  JRST [SKIPLE SENDSW	; Won. if > 0 then
		 JRST LMSN50	; also mail,
		JRST LMSN90]	; else done.
	SKIPGE SENDSW	; Failed. If  < 0, then
	 JRST LMSN90	; nothing else to do.

	; Here, a mail-if-failed SEND just failed, and we have to mail it!
	; Ugh, bletch, puke, phooey.
	; Must cons up new rcpt, sender, and message text.
	PUSH P,L
	MOVEI A,EMSGAR
	CALL LSEOPN		; Create new LSE for new message
	MOVE L,$ARLOC+EMSGAR	; Point at it

	EXCH L,(P)
	FINDA A,[A$RNAM,,[LMPRCP]]	; Find rcpt name
	 JSR AUTPSY
	FINDA B,[A$RNAM,,[LMPRCP]]	; and type
	 SETZ B,
	FINDA C,[A$SNM,,[$LLLST(L)]]	; and sender's name
	 JRST [	FINDA C,[A$CSN,,[$LLLST(L)]]
		 JSR AUTPSY
		JRST .+1]
	EXCH L,(P)

	MOVE D,(P)		; Set up ptr to LSE (UUO's shouldn't ref PDL)
	LNCOPY A,[D ? A]		; Copy rcpt name
	LNCOPY B,[D ? B]		; and type.
	LNCOPY C,[D ? C]		; and sender's name.
	HRRM B,LISTAR(A)		; Link type to name,
	MAKELN A,[A$RCP,,[C]		; and put under A$RCP, linking to 
		%LTLST,,[A]]		;   sender's name all at once.
	MOVEI B,A$CSN
	DPB B,[$LAFLD,,LISTAR(C)]	; Force sender name to claimed-from
	EXCH L,(P)
	FINDA B,[A$RHDR,,[LMPRCP]]	; Now find rcpt's header
	 JRST [	FINDA B,[A$MHDR,,[$LLLST(L)]]
		 JSR AUTPSY
		JRST .+1]
	MOVE B,LISTAR(B)+1		; Get absolute ascnt ptr
	ADD B,$LSLOC(L)
	FINDA C,[A$MTXT,,[$LLLST(L)]]	; and message text.
	 JSR AUTPSY
	MOVE C,LISTAR(C)+1		; Get absolute ascnt ptr
	ADD C,$LSLOC(L)
	EXCH L,(P)

	; Now form message text, and send the message.  What happens
	; here is that we just include the old header as part of the
	; message text, because we hve no way of knowing what sort
	; of header the rcpt(s) may want, and still have to show who
	; the original QSEND was addressed to!
	SAOBEG TMPC,			; Now form text of message.
	FWRITE TMPC,[TI,133,[COMSAT: This was a failing QSEND.],TI,135,[
],TC,B,TC,C]
	MAKELN A,[A$MTXT,,[A]
		%LTSAO,,]
	MOVEM A,$LLLST(L)		; Finalize.

	PUSH P,MF
	MOVEI MF,M%CORG+M%EMSG
	CALL MAIL		; Mail it!!
	 JFCL
	POP P,MF
	POP P,L
	JRST LMSN90		; Gasp wheeze pant, finally finished.

	; Mail.
LMSN50:	MOVEI A,LMFDEV
	MOVE B,LMPRCP		; Set up LP to rcpt list.
	CALL WRTMSG		;mail message!
	CAIE A,0
	 JRST LMSNRT		; If failed, return.

; Now decide whether or not to CLI to the rcpt.

	SKIPE SORMSW		; If we were intended to SEND,
	 JRST LMSN90		;    then all's done.
	SKIPGE MAILSW		; If suppressing notification,
	 JRST LMSN90		;    also done.
	
	TRNE MF,M%CORG		; If the message is from COMSAT, then skip the check
	 JRST LMSN85		;    (this is kind of random, but I found it here...)

	FINDA A,[A$SNM,,[$LLLST(L)]]	;find sender's name
	 JSR AUTPSY
	CALL CVLS6		; Convert to 6bit
	CAMN A,LMFFN1		;compare unames
	 JRST LMSN90		;equal, don't send!

LMSN85:	MOVE A,LMFFN1		; Get uname
	MOVE B,LMPRCP		; Get LP to rcpt's list.
	CALL CLIOPT		; Notification is up to rcpt...
	 JFCL

LMSN90:	SETZB A,B
LMSNRT:	POPAE P,[LMPRCP,E,D,C]
	RET
	

	;file to write message to.
BVAR
LMFDEV:	0	;default of "dsk"
LMFDIR:	0	;default of "common"
LMFFN1:	0	;default of "failed"
LMFFN2:	0	;default of "mail"
EVAR

LMFDEF:	SIXBIT /DSK/	;defaults
	SIXBIT /COMMON/
	SIXBIT /FAILED/
	SIXBIT /MAIL/

BCHPTB:	350700,,B
	260700,,B
	170700,,B
	100700,,B
	010700,,B

SUBTTL Actual local mailing

; WRTMSG - A has FILPT, B has LP to rcpt's list.  Writes msg to given file.
;	  This returns the same kind of error code as all the SNDxxx routines.
;	  See the dispatch table at RSND09.

.SCALAR WRFFAP	; -1 when FAST-APPEND; means DKOC open in write-over mode.

WRTMSG:	PUSHAE P,[C,D]
	MOVEM A,WFILPT		; Save FILPT.
	MOVEM P,WRTLEV'
	MOVEI C,WRTRLT		; Set up addr to return to if we time out.
	MOVEM C,RLTVEC
	CLKSET [5*60.*60.]	; Set up the clock for 5 minutes
	CLKON			; And enable interrupts
	call mbxlok		; Try for inbox lock
	 jrst wrtlkd		; Lost: temporary error
	CALL DEVCHK		; Set flags as to type of device.
	OUT(DKOC,OPEN(UC$BUF))	; And set up UUO chan for buffered output.

	; Check for FAST-APPEND option.
	TRZ F,%LMAPN		; Say not appending
	SETZM WRFFAP		; and not doing it fast-append way either.
	FNDSTR C,B,A$ROPT,[FAST-APPEND]	; Rcpt has the option?
	 JRST WRTM20		; Nope, do regular append or push.
	TRO F,%LMAPN		; Has it!  Proclaim append-mode.
	TRNN F,%DSKDV		; Device a DSK-type frob?
	 JRST WRTM20		; Nope, must hack regular way.

	; OK to try write-over mode!
	MOVE C,B		; Save rcpt-list ptr (B gets err code)
	CALL OPNAPP		; Attempt opening in append mode.
	 JRST [	EXCH B,C
		JUMPGE C,WRTM95	; Jump if temporary error
		JRST WRTM99]	; Else permanent...
	MOVE B,C
	SETOM WRFFAP		; WIN! Definitely doing fast-append.  Set flag
	SKIPLE EOFREC		; to avoid rename, and if not at beg
	 OUTCAL(DKOC,EOL)	; then prefix with CRLF,
	JRST WRTM50		; and go output message.

	; Regular mode (push or append) comes here to open output file.
WRTM20:	MOVEI D,WRTMO		; Default .CALL blk for DSK devs (for RENMWO).
	TRNN F,%DSKDV
	 MOVEI D,WRTMVO		; Else use this blk for true filespec.
				; Open output, to WRTM95 if temporary error
	ECALL (D),[[5,WRTM95],[6,WRTM95],[7,WRTM95],[10,WRTM95]]
	 JRST WRTM99		; Permanent errors - return with no skip.

	; Output file opened, now see if need to read input (existing) file.
	; Sometimes can skip completely.
	MOVE C,3(A)		; Get FN2
	CAME C,[SIXBIT /</]
	 CAMN C,[SIXBIT />/]	; FN2 special?
	  JRST WRTM49		; Yes, no need to read existing file.
	FNDSTR C,B,A$ROPT,[NEW-FILE]	; Does rcpt have make-new-file option?
	 CAIA
	  JRST WRTM49			; If so, ignore any input, etc.
				; Open input, to WRTM95 if temporary error
				; to WRTM49 if file does not exist
	ECALL WRTMI,[[4,WRTM49],[6,WRTM95],[7,WRTM95],[10,WRTM95],[16,WRTM95],[23,WRTM95]]
	 JRST WRTM99		; Some other error: permanent error

	; Have both input and output open!  See if must append or push...
	TRNE F,%LMAPN		; Already decided to append?
	 JRST WRTM30		; Yup, go do it.
	FNDSTR C,B,A$ROPT,[APPEND]	; See if rcpt has APPEND option.
	 JRST WRTM50		; Nope, go "push" the msg by writing first.
	TRO F,%LMAPN		; Appending, set flag.

	; Appending...
WRTM30:	CALL DKIOUT		; Copy text from DKIC to current output chan!
	 JRST WRTM95		; IOC error or something, assume temp.
	JRST WRTM50		; Then go write message.

	; Write message!
WRTM49:	TRO F,%LMAPN		; Entry pt for things that ignore input file.
WRTM50:	FNDSTR C,B,A$ROPT,[SUPER-QUOTE]	; Is message being super-quoted
	 CAIA				; for this rcpt?
	  JRST [FINDA C,[A$MTXT,,[$LLLST(L)]] ; Yes, output msg txt directly.
		 JSR AUTPSY
		XCTIOC [OUTCAL(DKOC,TLS(C))]
		 JRST WRTM95		; IOC? temporary.
		JRST WRTM70]		; Done with message!
	FINDA C,[A$RHDR,,[B]]	; Normal processing. Find rcpt's header if any.
	 JRST [	FINDA C,[A$MHDR,,[$LLLST(L)]]
		 JSR AUTPSY
		JRST .+1]
	XCTIOC [OUTCAL(DKOC,TLS(C))]		; Output if there.
	 JRST WRTM95			; IOC? temporary.
	FINDA C,[A$MTXT,,[$LLLST(L)]]	; Get SLP to message text.
	 JSR AUTPSY
	FINDA D,[A$MTXF,,[$LLLST(L)]]	; Is there a flag for msg?
	 JRST WRTM56			; NO
	SKIPE LISTAR(D)+1	; Check flag
	 JRST WRTM56		; Flag not 0, OK.
	MOVE A,C		; UGH!
	XCTIOC [CALL QBKAO]	; Output quoted-type ^_'s.
	 JRST WRTM95		; IOC - temp err.
	JRST WRTM60

WRTM56:	XCTIOC [OUTCAL(DKOC,TLS(C))]	; Output whichever msg text is necessary.
	 JRST WRTM95

	; Now add the "^_^M^J".  Insert CRLF in front if seems necessary.
WRTM60:	MOVE C,LISTAR(C)+1	; Examine last char
	ADD C,$LSLOC(L)
	HLRZ D,C		; Cnt into D,
	HRLI C,440700		; BP in C.
	PTSKIP D,C		; Get pointer to last+1 char!
	LDB C,C			; Snarf last char.
	MOVE A,[ASCNT [
]]
	CAIE C,^J		; Unless it's a LF,
	 MOVE A,[ASCNT [

]]				; add a crlf.
	XCTIOC [OUTCAL(DKOC,TC(A))]
	 JRST WRTM95

	; Message writing done, now see if "pushing".
	; Must add previous file if so.
WRTM70:	TRNE F,%LMAPN		; Skip if pushing.
	 JRST WRTM90		; Nope, all done.
	CALL DKIOUT		; Output stuff from DKIC over std output chan.
	 JRST WRTM95		; IOC, take temp-err return.

WRTM90:	XCTIOC [OUTCAL(DKOC,FRC)]	; Ensure output forced out.
	 JRST WRTM95		; Sigh, so close...
	TRNE F,%DSKDV		; Was output to a DSK device?
	 SKIPE WRFFAP		; Yes, was fast-append specified?
	  CAIA			; Not disk, or using fast-append, skip rename.
	   JRST [MOVE A,WFILPT	; Must rename output file!
		SYSCAL RENMWO,[CIMM DKOC
			2(A) ? 3(A)]	; Rename to proper names if so.
		 JRST WRTM99		; Glub, failed for some reason?
		JRST .+1]
	OUT(DKOC,CLS)	; Close the channel (both UUO and actual)
	SETZB A,B
	JRST WRTMRT		; Win return.

WRTRLT:	MOVE P,WRTLEV		; Timed out trying to write local message
	CSTAT (,("...TIMEOUT"))
	JRST WRTM96

	; Temporary errors come here.  Message will be queued,
	; and re-tried later.
WRTM95:	CSTAT (,("...TEMP ERR="),LBRC,ERR,RBRC)	; Return here for temp err.
WRTM96:	OUT(DKOC,RST,CLS)	; Reset and close the buffered chan.
	MOVEI A,MR$TER	; Code for temp error but don't give up on this host!
	SETZ B,		; Not returning any err message.
	TRNN F,%DSKDV	; Was output to dsk-type dev, hence to fake fnm?
	 JRST WRTMRT	; No, leave things as they are.
	MOVE C,WFILPT	; It was!  Must be public-spirited and
	SYSCAL DELETE,[(C) ? [SIXBIT /_MAIL_/] ? [SIXBIT /OUTPUT/] ? 1(C)]
	 JFCL
	JRST WRTMRT		; Flush the abortive output file.

	; Failure to lock inbox is a temporary error too:
wrtlkd:	cstat (,("... Inbox locked."))
	MOVEI A,MR$TER	; Code for temp error but don't give up on this host!
	SETZ B,		; Not returning any err message.
	jrst wrtmrt

	; Permanent errors come here.  The message will not be queued, and
	; COMSAT will try to return it to the sender, along with an
	; appropriate error string (given by SLP in B)
WRTM99:	CSTAT (,("...LOST, ERR="),LBRC,ERR,RBRC) ; Return here for perm err.
	MOVE A,WFILPT
	SAOBEG TMPC,
	FWRITE TMPC,[[Couldn't write message to file;
	"],6F,(A),[:],6F,1(A),[;],6F,2(A),[ ],6F,3(A),[" - ],ERR,,]
	MAKELN B,[0 ? %LTSAO,,]	; Make output into a SLN, with SLP in B.
	OUT(DKOC,RST,CLS)	; Reset and close the buffered chan.
	MOVEI A,MR$PER		; Code for perm error
WRTMRT:	CLKOFF
	SETZM RLTVEC
	.close lockch,		; Release inbox lock
	POPAE P,[D,C]	; Losing return.
	RET

.SCALAR WFILPT		; For holding argument FILPT while hacking stuff.

WRTMVO:	SETZ ? SIXBIT/OPEN/ ? [.UAO,,DKOC]
	(A) ? 2(A) ? 3(A) ? SETZ 1(A)

WRTMO:	SETZ ? SIXBIT /OPEN/ ? [.UAO,,DKOC]	; Unit Ascii out (for SIOT)
	(A) ? [SIXBIT /_MAIL_/] ? ['OUTPUT] ? SETZ 1(A)

WRTMI:	SETZ ? SIXBIT /OPEN/ ? [.BII,,DKIC]
	(A) ? 2(A) ? 3(A) ? SETZ 1(A)

; MBXLOK - Seize lock for inbox from FILPT in A.  Skips on success.
mbxlok:	pushae p,[b,c]
	move b,2(a)
	rot b,1
	add b,3(a)
	rot b,1
	add b,1(a)
	idivi b,777773
	hrli c,(sixbit /MBX/)
	syscal open,[moves b ? movsi .uao ? movei lockch
			[sixbit /LOCK/] ? move c]
	 jrst [	caie b,%enafl
		 jsr autpsy	; %ENSDV or %EFLDV ?
		jrst .+2 ]
	  aos -2(p)
	popae p,[c,b]
	ret

; QBKAO - Takes an SLP in A, and outputs the string to DKOC, converting ^_'s to
;	^ followed by _.

QBKAO:	PUSHAE P,[B,C]
	MOVE A,LISTAR(A)+1
	ADD A,$LSLOC(L)
	HLRZ B,A
	HRLI A,440700	; BP in A, char count in B
	JRST QBKAO6
QBKAO4:	ILDB C,A
	CAIN C,^_
	 JRST [	OUT(DKOC,C("^),C("_))
		JRST QBKAO6]
	OUT(DKOC,C((C)))
QBKAO6:	SOJGE B,QBKAO4
	POPAE P,[C,B]
	RET

; ARDSKO - takes ptr to filblk in A, area # to output in B.
;	skips if written, fails if unable to open file.  outputs
;	text in area.  Returns error string (SLP in A) if open fails.
;	This routine differs from WRTMSG primarily in that it simply
;	writes a file, wheras WRTMSG appends to an existing file.
;	This is used to procude the "NAMED ERRxxx" files.

ARDSKO:	PUSHAE P,[C,D]
	CALL DEVCHK		;set flags for device name (addr in A)
	MOVEI D,ARDVPN
	TRNE F,%DSKDV		;use ardopn if dsk dev,(renmwo hack)
	 MOVEI D,ARDOPN
	.CALL (D)		;try opening file with that dev, dir
	 JRST ARDKO6		;failure, hack error code/string
	OUT(DKOC,OPEN(UC$IOT),TA((B)))	; Set up chan as UUO chan, and output.
	TRNE F,%DSKDV		;done unless dsk dev, if so then
	 JRST [	.CALL ARDRNM	;rename while still open
		 JRST ARDKO7	;failed for some reason; any failure here is permanent.
		JRST .+1]
	.CLOSE DKOC,		;and close to complete write.
	POPAE P,[D,C]
	AOS (P)
	AOS (P)
	RET
	
; check out err code, decide if temporary or not and return error
;string if permanent.
; Temporary errors for writing on DSK devices are:
;	5 - DIR FULL, 10 - DEV NOT AVAIL, 23 - FILE LOCKED (For W-O mode only)
;perhaps also 17 - DIR NOT AVAIL?

ARDKO5:	TRNN F,%DSKDV		;skip if dsk dev, for checking known codes
	 JRST ARDKO8		;ugh lossage
ARDKO6:	CAIE C,5
	 CAIN C,10
	  JRST POPDC1		; Aha, temporary lossage only.
	CAIN C,17		; Test for this too, I guess.
	 JRST POPDC1

	;not dsk dev, or perm. disk error.
ARDKO7:	.CLOSE DKOC,
ARDKO8:	MOVE D,A
	SAOBEG TMPC,
	FWRITE TMPC,[6F,(D),[:],6F,1(D),[;],6F,2(D),[ ],6F,3(D),[ - ],ERR,]
	MAKELN A,[0 ? %LTSAO,,0]
	POPAE P,[D,C]
	RET

ARDVPN:	SETZ ? SIXBIT/OPEN/ ? [.UAO,,DKOC]
	CERR C
	(A) ? 2(A) ? 3(A) ? SETZ 1(A)

ARDOPN:	SETZ ? SIXBIT /OPEN/ ? [.UAO,,DKOC]	; Unit Ascii out (for SIOT)
	CERR C		;get error code if any into acc c
	(A) ? [SIXBIT /_MAIL_/] ? ['OUTPUT] ? SETZ 1(A)

ARDRNM:	SETZ ? 'RENMWO ? CIMM DKOC ? 2(A) ? SETZ 3(A)


; DEVCHK - Device Name checker 
;	Addr in A to 6bit device name,
;	sets %DSKDV if it is dsk-type device,
;	also %NETDV if it is dsk-type and actually a net site (e.g. ML:)

DEVCHK:	PUSH P,A
	TRZ F,%DSKDV+%NETDV
	CAMN A,[SIXBIT /SECOND/]
	 JRST DVCHK5
	HLRZ A,(A)	;get 3 chars 6bit device name, right justified
	CAIE A,'DSK
	 CAIN A,'COM
	  JRST DVCHK5
	CAIE A,'AI_6
	 CAIN A,'ML_6
	  JRST DVCHK6
	CAIE A,'MC_6
	 CAIN A,'MD_6
	  JRST DVCHK6
	CAIN A,'MX_6
	 JRST DVCHK6
	CAIN A,'SYS
	 JRST DVCHK5
	TRZ A,77
	CAIE A,'AR_6
	 JRST POPAJ
DVCHK5:	TROA F,%DSKDV		;come here when dsk device only
DVCHK6:	 TRO F,%DSKDV+%NETDV	;come here when also net device
	POP P,A
	RET


SUBTTL CLI sending routines

;   CLIOPT - This is for telling a person that he has mail; it is used
; both for notifying real and pseudo recipients.  Errors in CLIing
; are not reported.
; Option-dependent TTY message sender.  A has 6bit of rcpt name (to make
; things easier); B has LP to rcpt's list.

.SCALAR CLIRPT

CLIOPT:	PUSHAE P,[B,C,D]
	MOVEM B,CLIRPT
	FNDSTR C,B,A$ROPT,[NO-CLI]	; First things first... absolutely
	 CAIA				; no notification?
	  JRST CLIOP9			; Nope, just return.
	FINDA C,[A$NMH,,[$LLLST(L)]]
	 JRST CLIOP3
	MOVE C,LISTAR(C)+1	;get foreign originating site if any.
	MOVEM C,CLIANC
	MOVEI C,2
	MOVEM C,CLITYP
	JRST CLIOP4

	; Local-originated message.
CLIOP3:	FNDSTR D,CLIRPT,A$ROPT,[NO-LOCAL-CLI]
	 SKIPA
	  JRST CLIOP9		;don't cli if he doesn't want local
	FINDA C,[A$SNM,,[$LLLST(L)]]	; Find sender name
	 JSR AUTPSY
	MOVE C,LISTAR(C)+1
	ADD C,$LSLOC(L)
	MOVEM C,CLIANC		; And store ASCNT ptr as arg.
	MOVEI D,1		; Say "You have mail from <sender>"
	MOVEM D,CLITYP

	; Find how big rcpt wants it.
CLIOP4:	FNDSTR D,CLIRPT,A$ROPT,[SMALL-CLI]
	 SKIPA
	  JRST [SETZM CLIZMX ? JRST CLIOP6]	;give tiny msg if that's what he wants.
	FNDSTR D,CLIRPT,A$ROPT,[INFINITE-CLI]
	 JRST [	MOVEI D,10.		; Default - use smarts.
		MOVEM D,CLIZMX
		MOVEI D,4
		MOVEM D,CLIZMD
		JRST CLIOP6]
	HRLOI D,377777		; Wants everything in msg...
	MOVEM D,CLIZMX

CLIOP6:	SETOM CLIZSW		; For now, always use lines.
	MOVE B,CLIRPT
	CALL CLIMS
CLIOP9:	POPAE P,[D,C,B]
	RET

; CLIMSG - Send a "TTY message" type message to all users with a given
;	UNAME/XUNAME (in A).  B has the rcpt's attrib list.

CLIMSG:	PUSH P,C
	MOVEI C,3	; Use type 3, and
	MOVEM C,CLITYP
	FINDA C,[A$SNM,,[$LLLST(L)]]	; Find sender name
	 JSR AUTPSY
	MOVE C,LISTAR(C)+1
	ADD C,$LSLOC(L)
	MOVEM C,CLIANC		; And store ASCNT ptr as arg.
	SETZM CLIZSW		; Indicate char limit (faster)
	HRLOI C,377777		; Very big # to send all of msg.
	MOVEM C,CLIZMX
	SETZM CLIWIN
	POP P,C
	CALL CLIMS		; Send it...
	SKIPE CLIWIN
	 AOS (P)
	RET

; CLIMS - Sends a CLI message to all users with a given UNAME/XUNAME (in A).
;	Each user gets the kind of header he wants.
;	This is used when CLIing a piece of mail (which at the moment is
;	all we ever CLI).  It sets up the CLIHDR and CLITXT from the mail.

CLIMS:	PUSH P,C
	FINDA C,[A$RHDR,,[B]]
	 JRST [	FINDA C,[A$MHDR,,[$LLLST(L)]]
		 JSR AUTPSY
		JRST .+1]
	MOVE C,LISTAR(C)+1
	ADD C,$LSLOC(L)
	MOVEM C,CLIHDR
	FINDA C,[A$MTXT,,[$LLLST(L)]]
	 JSR AUTPSY
	MOVE C,LISTAR(C)+1
	ADD C,$LSLOC(L)
	MOVEM C,CLITXT
	MOVEI B,CLISND
	CALL XCTALU		; Call routine for all matching (X)UNAMEs.
	POP P,C
	RET

; takes ascnt ptr in a, returns in a the # lines in string.

NLINES:	PUSHAE P,[B,C,D]
	HLRZ D,A
	JUMPE D,[SETZ A, ? JRST NLINS9]
	HRLI A,440700
	MOVE C,A
	MOVEI A,1
NLINS1:	ILDB B,C
	CAIN B,^J
	 JRST [SOJLE D,NLINS9
		AOJA A,NLINS1]	;only add to cnt if something after a lf.
	SOJG D,NLINS1
NLINS9:	POPAE P,[D,C,B]
	RET


; XCTALU - Execute for All Users/Unames. (I know, delete the "for")
;	Given a UNAME in A, and a routine address in B,  executes
;	the routine once for each HACTRN on the system with a UNAME
;	or XUNAME matching the given one.  Furnishes the routine
;	with specific UNAME in A, but nothing else.  Does not touch
;	regs D or E, so these can be used for arguments.
; Note - if A is zero, it will match every X/UNAME!

XCTALU:	PUSHAE P,[A,B,C]
	MOVE B,['HACTRN]
	MOVE C,@USRHI
XCTAL1:	SUB C,LUBLK
	JUMPLE C,XCTAL7
	CAME B,@JNAME		; Is Jname = HACTRN?
	 JRST XCTAL1		; If not, don't even test uname.
	JUMPE A,XCTAL5		; If arg = 0, match any HACTRN.
	CAME A,@UNAME
	 CAMN A,@XUNAME
	  CAIA
	   JRST XCTAL1		;neither uname nor xuname matches.
XCTAL5:	MOVE A,@UNAME		;get real uname
	CALL @-1(P)		; Execute given routine.
	MOVE A,-2(P)		; Restore uname to look for...
	JRST XCTAL1

XCTAL7:	POPAE P,[C,B,A]
	RET

SUBTTL CLI Sending Primitive Routine.

; CLISND - Hairy primitive for sending CLI messages.  Args are given in the following
; block of variables.  CLITYP & CLIANC determine what will be in the beginning of
; the message.  Then the header (ASCNT in CLIHDR) is sent, andthen the message
; (ASCNT in CLITXT).  CLIZSW, CLIZMX and CLIZMD determine how much of the
; message is cut off; the actual number left unsent (in either characters or lines
; depending on CLIZSW) is returned in A.  The other "returned value" is in CLIWIN, which
; is AOSed every time a successful CLI message gets through.

; Types (in CLITYP)		Arg wanted (in CLIANC)
;  0 (no prelude)			(no arg)
;  1 (You have mail from)		(ASCNT name of "from")
;  2 (You have net mail from)		(host number)
;  3 (TTY message from)			(ASCNT name of "from")

BVAR
CLITYP:	0	; Specify type of CLI-message.  Determines announcement given.
CLIANC:	0	; Argument if any needed for announcement.
CLIHDR:	0	; Give ASCNT string as "header"
CLITXT:	0	; Give ASCNT string as text of message.
CLIZSW:	0	; Switch indicating type of limiting values.  (0 chars, -1 lines)
CLIZMX:	0	; Maximum limiting value
CLIZMD:	0	; Modulus if maximum exceeded.
CLIWIN:	0	; AOS'd whenever CLISND succeeds.
CLILEV:	0	; Value of P when CLISND was entered. 
EVAR
CLIDEV:	SIXBIT /CLI/	; For laziness.

CLITMO:	180.*60.		; 3 minute timeout (sounds good...)

	; Send CLI message using params above.  Takes UNAME in A to send to.
CLISND:	PUSHAE P,[B,C,D,E,CLILEV]
	MOVEM P,CLILEV
	MOVEI B,CLIRLT		; Set up addr to return to if we time out.
	MOVEM B,RLTVEC
	CLKSET CLITMO		; Set up the clock.
	CLKON			; And enable interrputs
	SYSCAL OPEN,[[.UAO,,CLIC] ? CLIDEV ? A ? ['HACTRN]]
	 JRST CLISN9		; If failed, just return.
	OUT(CLIC,OPEN(UC$IOT))	; Aha! Onward!
	OUT(CLIC,C(177))	; Initial rubout tells DDT not to print "Message from"
	SKIPN B,CLITYP		; Get type of msg
	 JRST CLISN2		; Skip announcements if type = 0
	CAIN B,1
	 JRST [	OUT(CLIC,("You have mail from "),TC(CLIANC))
		JRST CLISN2]
	CAIN B,2
	 JRST [	OUT(CLIC,("You have net mail from "),HST(CLIANC))
		JRST CLISN2]
	CAIN B,3
	 JRST [	OUT(CLIC,("TTY message from "),TC(CLIANC),("@"),HST(OWNHST))
		JRST CLISN2]
CLISN2:	SETZ D,
	SKIPE CLIZSW		; Now see whether to hack chars or lines.
	 MOVEI D,1		; Do it this way to be SURE of index.
	MOVE A,CLIHDR		; First count header
	XCT (D)[HLRZS A ? CALL NLINES]
	MOVE B,A		; Save result, and then
	MOVE A,CLITXT		; count text.
	XCT (D)[HLRZS A ? CALL NLINES]
	ADD A,B			; Now have total in A!
	SKIPG CLIZMX		; If Max limit is LE 0,
	 JRST [	OUT(CLIC,SP,LPAR,D(A))		; Just furnish length on single line.
		MOVE C,(D)[	ASCNT [ Chars)]
				ASCNT [ Lines)]]
		OUT(CLIC,TC(C))
		JRST CLISN8]
	OUT(CLIC,(":"),EOL)
	CAMG A,CLIZMX		; Well, now compare our count with maximum...
	 JRST [	OUT(CLIC,TC(CLIHDR),TC(CLITXT))	; Win, just output all.
		JRST CLISN8]
	MOVE C,CLIZMD
	CAMG B,C		; Foo, too much.  See if HDR fits within limit...
	 JRST [	OUT(CLIC,TC(CLIHDR))	; HDR fits, output it
		SUB C,B		; And get limited count for Text.
		MOVE B,CLITXT
		JRST CLISN4]
	MOVE B,CLIHDR		; Not enough for HDR even...

	; Output up to c(C) units from string in B, saying there are c(A) left.
CLISN4:	SUB A,C			; Find # units that will be left over.
	JUMPE D,[HRL B,C	; If units are chars, it's easy.
		OUT(CLIC,TC(B),SP,LPAR,D(A),(" more chars"),RPAR)
		JRST CLISN8]
	SETZ D,			; Clear cnt of chars (don't need type-of-limit now)
	PUSHAE P,[A,B]
	HRLI B,440700
CLISN5:	ILDB A,B		; Get char
	CAIN A,^J		; Each ^J is one line.
	 SOJLE C,.+2		; For each line, decr cnt and jump if done.
	AOJA D,CLISN5		; Else incr cnt of chars seen.
	POPAE P,[B,A]
	HRLI B,1(D)		; Put right count into LH of ASCNT ptr
	OUT(CLIC,TC(B),SP,LPAR,D(A),(" more lines"),RPAR)

CLISN8:	OUT(CLIC,EOL)
	.CLOSE CLIC,
	AOS CLIWIN		; Increment cnt of wins!
CLISN9:
CLIRLT:	SKIPL B,CLILEV
	 JSR AUTPSY		; That was no pdl pointer
	CLKOFF
	SETZM RLTVEC
	MOVE P,B
	POPAE P,[CLILEV,E,D,C,B]
	RET
SUBTTL MASTER Manipulation routines

; IDFIND - Given ASCNT ptr in A to a Message ID, looks up on MASTER
;	and skips if found, else doesn't skip.  Returns LP to LLN in A.

IDFIND:	PUSHAE P,[B,C,L]
	SKIPN $AROPN+MASTER	; Make sure
	 CALL MSTGET		; MASTER is in core!
	MOVE L,$ARLOC+MASTER	; Make MASTER the current LSE
	HRRZ B,$LLLST(L)	; Initialize B = current node
	CAIA
IDFND2:	 HRRZ B,LISTAR(B)	; Get next LN to check.
	JUMPE B,IDFND9		; If LP = 0, search failed.
	FINDA C,[A$ID,,[LISTAR(B)+1]]	; Search list of this node.
	 JSR AUTPSY		; Huh? All should have this.
	SLNEA C,A		; Compare strings
	 JRST IDFND2		; No match, get next.
	MOVE A,B		; Aha, match. return LP to it.
	AOS -3(P)
IDFND9:	POPAE P,[L,C,B]
	RET

; IDDELE - Takes current MASTRP and deletes the message
;	pointed to.  Writes out MASTER file so as to finalize the
;	deletion.

IDDELE:	PUSHAE P,[A,L]
	MOVE L,$ARLOC+MASTER
	MOVE A,MASTRP			; Get LP to doomed LN.
	FINDA A,[A$IDBL,,[LISTAR(A)+1]]	; Get length of LSE-blk on disk.
	 JSR AUTPSY
	MOVE A,LISTAR(A)+1		; Get # words used by LSE.
	ADDM A,$LHMFG(L)		; Increment cnt of garbage wds.
	MOVE A,MASTRP
	LNDEL A,$LLLST(L)		; Now kill it.
	CALL MSTPUT			; Write out MASTER file.
	POPAE P,[L,A]
	RET

SUBTTL MASTER and MSG-LSE Readin/Writeout

; MSGGET - Given SLP in A to a Message-ID string, brings that
;	MSG-LSE into core provided it exists; doesn't skip if not.
;	Checks to avoid reading in a MSG-LSE already in core.
; MSGGTA - Same, but A has ASCNT ptr instead of SLP.

MSGGTA:	PUSH P,A
	JRST MSGGT0
MSGGET:	PUSH P,A
	MOVE A,LISTAR(A)+1
	ADD A,$LSLOC(L)
MSGGT0:	PUSHAE P,[B,L]
	SKIPN $AROPN+MSGAR	; Is MSG-LSE open or not?
	 JRST MSGGT5		; Nope, obviously not in core!
	MOVE L,$ARLOC+MSGAR	; Set current LSE to MSG.
	
	FINDA B,[A$ID,,[$LLLST(L)]]
	 JRST MSGGT5		; If not ID, clearly also not in core.
	SLNEA B,A		; Compare requested ID with current, if any.
	 CAIA
	  JRST MSGGT8		; Already in!  Trivial return.

	; Not currently in core, must look up on MASTER.
MSGGT5:	MOVE B,A		; Save ID string.
	CALL IDFIND		; Look up... Leaves MASTER-ptr in A.
	 JRST MSGGT9		; But if couldn't find, tough.  Don't skip.
	MOVEM A,MASTRP
	MOVE L,$ARLOC+MASTER	; Found! Make MASTER the current LSE.
	FINDA A,[A$IDAD,,[LISTAR(A)+1]]	; Get the disk-address LN.
	 JSR AUTPSY		; none??
	MOVE A,LISTAR(A)+1	; Now get the disk address itself!
	CALL MLSGET		; and now slurp up the LSE.
	 JRST MSGGT7		; lost

MSGGT8:	AOS -3(P)		; Won, skip on return.
MSGGT9:	POPAE P,[L,B,A]
	RET

MSGGT7:	STAT (,(" =="),RABR,(" CAN'T READ IN MSG "),LBRC,TC(B),RBRC,(" BECAUSE "),LBRC,ERR,RBRC,(", FLUSHING "),LABR,("=="))
	CALL IDDELE
	JRST MSGGT9

; MSGDEL - Message Deletion.  Deletes current message from MASTER
;	and writes MASTER out, effectively flushing all traces of message.

MSGDEL:	PUSHAE P,[A,B,L]
	MOVE L,$ARLOC+MSGAR		; Set to MSG-LSE
	FINDA A,[A$ID,,[$LLLST(L)]]	; Find MSG-ID
	 JSR AUTPSY
	MOVE A,LISTAR(A)+1		; Get SPT
	ADD A,$LSLOC(L)			; Abs ASCNT ptr
	CALL IDFIND			; Look up in MASTER
	 JRST MSGDL9			; Not there, nothing to do.
	MOVEM A,MASTRP			; Found it, store LP.
	CALL IDDELE			; and go flush it.
MSGDL9:	POPAE P,[L,B,A]
	TLZ F,%MSGMD			; Certainly no modified message
	RET

; MSGPUT - Writes out current MSG-LSE and MASTER, to effect either a
;	new or changed MSG-LSE.  Inserts proper disk address into
;	MASTER entry and leaves LP to it in MASTRP.

MSGPUT:	PUSHAE P,[A,B,C,L]
	SKIPN $AROPN+MASTER	; Ensure that MASTER
	 CALL MSTGET		; is in core.
	MOVE L,$ARLOC+MSGAR
	SKIPN $AROPN+MSGAR
	 JSR AUTPSY		; Called with no message around (%MSGMD randomly on?)
	FINDA A,[A$ID,,[$LLLST(L)]]
	 JSR AUTPSY
	MOVE A,LISTAR(A)+1
	ADD A,$LSLOC(L)
	MOVE B,A		; Save ascnt ptr
	CALL IDFIND		; Find LP to MSG-ID node, leaves in A.
	 CAIA
	  JRST MSGPT5
	MOVE L,$ARLOC+MASTER		; Doesn't have one, must create one!
	MAKELN A,[A$IDBL,,0 ? 0]
	MAKELN A,[A$IDAD,,[A] ? 0]
	MAKELN A,[A$ID,,[A] ? %LTSTR,,[B]]
	MAKELN A,[A$I,,[$LLLST(L)] ? %LTLST,,[A]]
	MOVEM A,$LLLST(L)

MSGPT5:	MOVEM A,MASTRP
	MOVE C,A		; Save in C
	CALL MLSPUT		; Write out MSG-LSE; disk addr returned in A, len in B.
	PUSH P,B		; Save length.
	MOVE B,A
	MOVE L,$ARLOC+MASTER	; Set MASTER as current LSE
	FINDA A,[A$IDAD,,[LISTAR(C)+1]]	; Find LP to the disk-addr LN.
	 JSR AUTPSY
	MOVEM B,LISTAR(A)+1	; Store the disk address.
	POP P,B			; Recover length
	FINDA A,[A$IDBL,,[LISTAR(C)+1]]
	 JSR AUTPSY
	ADDM B,$LHMFL(L)	; Add into length of MSGS (as seen by MASTER).
	EXCH B,LISTAR(A)+1	; Store disk-block length.
	ADDM B,$LHMFG(L)	; Add previous length to garbage
	SKIPN MKQFLG
	 CALL MSTPUT		; Now output the MASTER LSE.
	POPAE P,[L,C,B,A]
	RET


; MLSGET - Message LSE Readin.  Given .ACCESS ptr in A to use, reads
;	LSE from there into MSG-LSE, clears %MSGMD.
; Skip return if win.

MLSGET:	PUSHAE P,[A,B,L]
	MOVE B,A			; Put .ACCESS ptr in B.
	MOVE A,[MSGAR,,MSGFN1]
	CALL DFGETA			; Get the LSE, using .ACCESS hack.
	 CAIA				; Hmm, investigate.
	  AOS -3(P)			; won, skip
MLSGT9:	TLZ F,%MSGMD			; Clear modify flag.
	POPAE P,[L,B,A]
	RET

; MLSPUT - Message LSE writeout.  Writes current MSG-LSE onto top
;	of MSGS file and returns in A its disk address, in B its length.

MLSPUT:	MOVEI A,MSGFN1
	CALL OPNMFW		; Open in write-over mode, trying hard.
MLSPT:	SYSCAL FILLEN,[CIMM DKOC ? CRET B]
	 JSR AUTPSY
	MOVEI A,MSGAR		; Now have args for LSEOUT...
	CALL LSEOUT		; Put out the LSE!  Returns addr in A,length in B.
	TLZ F,%MSGMD		; Clear modification flag.
	RET
	
; MSGSGC - GC's the MSGS file...  both MSGAR and MASTER should have been
;	written out before this is called.
; Sequence of file operations goes as follows:
; 1) Open <output> for writing, MSGS for reading.
; 2) copy from MSGS to <output>, updating MASTER internally.
; 3) When done, write out new MASTER as NMASTR.
; 4) RENMWO <output> -> NMSGS, and close to finalize.
; 5) Delete MASTER and MSGS in any order.
; 6) Rename NMASTR -> MASTER and NMSGS -> MSGS, also any order.

; If, on initialization, one of MASTER or MSGS is missing, it should be
; replaced by NMASTR or NMSGS as appropriate; error if new version doesn't exist!
; If one wants to be picky, it is possible to recover from crash between
; steps 4 and 5 by checking for existence of both NMASTR and NMSGS even when
; MASTER and MSGS both exist, but why bother?

BVAR
MGCNPT:	0	; To hold new disk address while copying.
MGCECT:	0	; Expected length of new file, should = MGCNPT at end.
EVAR

MSGSGC:	PUSHAE P,[A,B,C,D,L]
	SKIPN $AROPN+MASTER
	 CALL MSTGET		; Ensure MASTER in core
	MOVE L,$ARLOC+MASTER
	MOVE A,$LHMFL(L)	; Get length of MSGS
	SUB A,$LHMFG(L)		; Sub # garbage wds...
	MOVEM A,MGCECT		; Save as expected length of new file.
	STAT (,("Note: GC'ing MSGS, "),OCT($LHMFL(L)),("-"),OCT($LHMFG(L)),("="),OCT(A))
	SETZ A,
	CALL OPNMFO		; Open NMSGS for writing, (standard output fnm)
	SETZM MGCNPT		; Set write pointer to 0.
	MOVEI A,MSGFN1
	CALL OPNMFI		; And MSGS for reading.
	 JSR AUTPSY
	UAROPN [TMPAR ? [2000]]	; Allocate a 1K buffer.
	HRRZ D,$LLLST(L)	; D contains LP for stepping through MASTER.
	CAIA
MSGC10:	 HRRZ D,LISTAR(D)
	JUMPE D,MSGC50		; Jump when finished.
	FINDA A,[A$IDAD,,[LISTAR(D)+1]]	; Get LP to disk address
	 JSR AUTPSY
	FINDA B,[A$IDBL,,[LISTAR(D)+1]]	; & length.
	 JSR AUTPSY

	; Simply copy block specified from MSGS on top of current NMSGS.
	.ACCESS DKIC,LISTAR(A)+1	; Read from given address
	MOVE B,LISTAR(B)+1		; Get cnt

MSGC20:	SUBI B,2000		; Sub 1K from cnt
	MOVNI C,2000		; and use -2000 for IOT
	CAIGE B,0		; unless we subtracted too much,
	 MOVNI C,2000(B)	; in which case add back and use -cnt.
	HRLZS C
	HRR C,$ARLOC+TMPAR		; AOBJN set up.
	PUSH P,C
	.IOT DKIC,C		; Read in.
	POP P,C
	.IOT DKOC,C		; Write out.
	JUMPG B,MSGC20

	; Fall through when done.
	MOVE C,MGCNPT		; Get back new address, within NMSGS.
	MOVEM C,LISTAR(A)+1	; Store it in A$IDAD (Disk-addr) LN.
	SYSCAL RFPNTR,[CIMM DKOC	; Find next address within NMSGS
		CRET MGCNPT]	; I know I can keep a count, this makes SURE.
	 JSR AUTPSY
	JRST MSGC10		; Get another msg.

	; All done with copying, now for file shell game.
MSGC50:	SETZM $LHMFG(L)		; Zero cnt of garbage wds
	MOVE A,MGCNPT
	MOVEM A,$LHMFL(L)	; And set new length of MSGS.
	CAME A,MGCECT		; Same as that expected?
	 JRST [	CSTAT (,(", *Err?* NL="),OCT(A))
		JRST .+1]
	MOVE A,[MASTER,,NMSFN1]	; Now write out NMASTR.
	.IOPUSH DKOC,
	CALL DFPUT
	.IOPOP DKOC,
	TLZ F,%MSTMD
	SYSCAL RENMWO,[CIMM DKOC ? NMGFN1 ? NMGFN1+1]	; Actually rename to NMSGS.
	 JSR AUTPSY		; Bleah?
	.CLOSE DKOC,		; And finalize.  Now have NMASTR, NMSGS.

	; Begin Step # 5.
	SYSCAL DELETE,[SATDEV ? MSTFN1 ? MSTFN1+1 ? SATDIR ? CERR A]
	 JRST [	CAIN A,4	; If already vanished, that's odd...
		 JRST .+1	; but OK anyway.
		JSR AUTPSY]
	SYSCAL DELETE,[SATDEV ? MSGFN1 ? MSGFN1+1 ? SATDIR ? CERR A]
	 JRST [	CAIN A,4	; If already vanished, that's odd...
		 JRST .+1	; but OK anyway.
		JSR AUTPSY]

	; Now do Step # 6
	SYSCAL RENAME,[SATDEV ? NMSFN1 ? NMSFN1+1 ? SATDIR
		MSTFN1 ? MSTFN1+1]
	 JSR AUTPSY
	SYSCAL RENAME,[SATDEV ? NMGFN1 ? NMGFN1+1 ? SATDIR
		MSGFN1 ? MSGFN1+1]
	 JSR AUTPSY

	CSTAT (,(", Done!"))
	POPAE P,[L,D,C,B,A]	; Done.....
	RET

LVAR	GCQFLG:	0	; Flag for when to GC queues.

; MGCFIX - Called at startup to check for crashing during MSGS GC'ing,
;	& thereby fix it.

MGCFIX:	PUSH P,A
	SYSCAL OPEN,[[.UII,,DKIC] ? SATDEV
		MSGFN1 ? MSGFN1+1 ? SATDIR ? CERR A]
	 JRST [	CAIN A,4
		 JRST .+2
		JSR AUTPSY]	; Random file error?
	JRST MGCFX5
	STAT (,("Note: No MSGS file, using NMSGS"))
	SYSCAL RENAME,[SATDEV ? NMGFN1 ? NMGFN1+1 ? SATDIR
		MSGFN1 ? MSGFN1+1]
	 JSR AUTPSY
MGCFX5:	SYSCAL OPEN,[[.UII,,DKIC] ? SATDEV
		MSTFN1 ? MSTFN1+1 ? SATDIR ? CERR A]
	 JRST [	CAIN A,4
		 JRST .+2
		JSR AUTPSY]
	JRST MGCFX8
	STAT (,("Note: No MASTER file, using NMASTR"))
	SYSCAL RENAME,[SATDEV ? NMSFN1 ? NMSFN1+1 ? SATDIR
		MSTFN1 ? MSTFN1+1]
	 JSR AUTPSY

MGCFX8:	.CLOSE DKIC,		; All's well...
	SYSCAL DELETE,[SATDEV ? NMGFN1 ? NMGFN1+1 ? SATDIR]
	 JFCL
	SYSCAL DELETE,[SATDEV ? NMSFN1 ? NMSFN1+1 ? SATDIR]
	 JFCL
MGCFX9:	POP P,A
	RET

; MSTGET - Reads in MASTER.

MSTGET:	PUSH P,A
	MOVE A,[MASTER,,MSTFN1]
	CALL DFGET
	 JSR AUTPSY
	TLZ F,%MSTMD
	POP P,A
	RET

; MSTPUT - Writes out MASTER.

MSTPUT:	PUSH P,A
	MOVE A,[MASTER,,MSTFN1]
	CALL DFPUT
	TLZ F,%MSTMD
	POP P,A
	RET

; QMLGET - Reads in QML.

QMLGET:	PUSH P,A
	MOVE A,[QMLAR,,QMLFN1]
	CALL DFGET
	 JSR AUTPSY
	TLZ F,%QMLMD
	POP P,A
	RET

; QMLPUT - Writes out QML.

QMLPUT:	PUSH P,A
	MOVE A,[QMLAR,,QMLFN1]
	CALL DFPUT
	TLZ F,%QMLMD
	POP P,A
	RET

; RMLGET - Reads in RML.

RMLGET:	PUSH P,A
	MOVE A,[RMLAR,,RMLFN1]
	CALL DFGET
	 JSR AUTPSY
	TLZ F,%RMLMD
	POP P,A
	RET

; RMLPUT - Writes out RML.

RMLPUT:	PUSH P,A
	MOVE A,[RMLAR,,RMLFN1]
	CALL DFPUT
	TLZ F,%RMLMD
	POP P,A
	RET



SUBTTL Data File primitives

; DFGET - Data File Readin.  A = <ARPT>,,<filblk addr>
;	Opens specified file, and reads it into a LSE, using given ARPT.
;	Skips unless file not found.

DFGET:	PUSH P,B
	SETO B,			; Indicate not interested in .ACCESS hacking.
	CALL DFGETA		; Get it.
	 JRST POPBJ		; No such file?
	POP P,B
	AOS (P)
	RET

; DFGETA - Data File Readin, with .ACCESS.  A = <ARPT>,,<filblk addr>
;	and B = .ACCESS ptr.
;	Opens specified file, and reads from specified location into
;	a LSE, using given ARPT.  Skips unless file not found,
;	or IOC error while trying to read (e.g. access pointer off end of file)

DFGETA:	CALL OPNMFI		; Open it, trying hard.
	 RET		; there isn't any such file?
	MOVSS A			; Get ARPT into RH.
	CALL LSEIN		; Read in LSE, using .ACCESS ptr in B.
	 SOSA (P)		; lost, non-skip return
	  .CLOSE DKIC,		; If lost, don't close so as to leave error code around
				; in STASAV if it burns up because of this IOC error
	MOVSS A			; restore A.
	AOS (P)
	RET

; DFPUT - Data File writeout.  A = <ARPT>,,<FN1/2 addr>
;	Writes LSE specified by ARPT to specified file.

DFPUT:	PUSHAE P,[A,B,C]
	MOVE C,A		; Save for later.
	SETZ A,			; Actually open temporary file.
	CALL OPNMFO		; Open for output, trying hard.
	HLRZ A,C		; Put ARPT in RH of A.
	SETO B,			; Indicate not interested in .ACCESS hacking.
	CALL LSEOUT		; Write out the LSE.
	HRRZ A,C		; Restore addr to FN's
	.CALL RNMMFO		; and rename output file to right thing.
	 JSR AUTPSY
	.CLOSE DKOC,
	POPAE P,[C,B,A]
	RET

RNMMFO:	SETZ ? 'RENMWO ? CIMM DKOC ? (A) ? SETZ 1(A)

; OPNMFO - Given addr of FN1/2 in RH of A, tries hard to open
;	for Block Image Output, and skips.  Assumption is that it
;	MUST be possible to write the file.
;	Only error should be 5 = DIR FULL, which is handled.
;	If A = 0, uses a standard temporary output FN.
; OPNMFW - Similar, but in write-over mode without A=0 hack.

OPNMFO:	CAIN A,0
	 MOVEI A,TMPFN1
	SYSCAL OPEN,[[.BIO,,DKOC] ? SATDEV ? (A) ? 1(A) ? SATDIR ? CERR OMFERR]
	 CAIA		; Error?? Must skip to inspect.
	  RET	; Normally win - return.
	PUSH P,[OPNMFO]	; Hack - set up like PUSHJ and drop in.
OPNMLS:	PUSH P,B
	MOVE B,OMFERR
	CAIN B,%ENAFL	; 23 = File locked?
	 JRST [	MOVEI B,30.	; Some loser has file open!  Wait it out...
		.SLEEP B,	; Maybe later take more active action.
		PJRST POPBJ]	; Re-try.
	CAIE B,5	; 5 = DIR FULL is only other reasonable error.
	 JSR AUTPSY	; all others barf instantly.
	POP P,B
	CALL SDFULL	; Call on magic routine... if it returns at all,
	RET		; we can win!  Return to routines to try again.
		; Don't replace by PJRST, for easier debug tracing.

	CALL OPNMLS
OPNMFW:	SYSCAL OPEN,[[%DOWOV+%DORWT+.BIO,,DKOC] ? SATDEV ? (A) ? 1(A) ? SATDIR ? CERR OMFERR]
	 JRST OPNMFW-1
	RET

LVAR OMFERR:	0	; If error happens, code gets stuck here.
TMPFN1:	SIXBIT /_SATEL/
	SIXBIT /OUTPUT/

; OPNMFI - Similar, but opens for .BII instead and skips.

OPNMFI:	SYSCAL OPEN,[[.BII,,DKIC] ? SATDEV ? (A) ? 1(A) ? SATDIR]
	 CAIA
	  AOS (P)
	RET

	; General purpose opener
OPNFLI:	SYSCAL OPEN,[[.BII,,DKIC] ? (A) ? 2(A) ? 3(A) ? 1(A)]
	 CAIA
	  AOS (P)
	RET

SUBTTL File getters -- FILGET, FILIN, TXFGET, TXFIN

; FILGET -  File Getter.  A has <ARPT>,,<FILPT>; specified file
;	is opened and read into specified area; if <ARPT>=0 then
;	an area is created.  In either case the ARPT is returned in A,
;	and routine skips.  If the OPEN fails, its error code is
;	returned instead with no skip.
; FILIN - similar, but assumes DKIC already open on channel, and never skips,
;	since no lossage is possible. (!)
; FILINL - Like FILIN but takes a limit in B of max # wds to read.

FILINL:	PUSH P,B
	JRST FILIN0

FILGET:	.CALL OPNBII		; Try to open FILBLK specified.
	 JRST [	MOVE A,OPNERR	; For failure, return error code.
		RET]
	AOS (P)
FILIN:	PUSH P,B
	HRLOI B,377777		; Read up to maximum!
FILIN0:	PUSH P,C
	MOVE C,B
	MOVE B,[DKIC,,FGTDEV]
	.RCHST B,		; Get channel status for possible later ref.
	SYSCAL FILLEN,[CIMM DKIC ? CRET B ? CERR OPNERR]
	 JRST [	MOVE B,OPNERR	;  Failed?  Should only happen if
		CAIE B,34	;  error = wrong type dev.
		 JSR SYSLOS	;    No. this shouldn't happen.
		MOVEI B,400	;  If no length available, use 1/4 page.
		JRST .+1]
	ADDI B,1		; Add 1 so .IOT ptr won't count out completely
	CAMLE B,C		; If length greater than limit,
	 MOVE B,C		; Force to limit!!
	HLRZS A			; Put ARPT into RH.
	UAROPN A,[(A) ? B]	; Open area, with length at least that of file/
	MOVN B,B		; Negate.
	HRLZ B,B		; For .IOT ptr.
	HRR B,$ARLOC(A)		; Get addr to store it...starting addr of area.
FILGT5:	PUSH P,B
	HLRE B,B
	ADD C,B
	POP P,B
	JUMPL C,FILGT8		; Stop if past limit.
	.IOT DKIC,B		; grab
	HRRZM B,$ARWPT(A)	; set write ptr for area.
	JUMPGE B,[MOVEI B,400	; If counted completely out,
		UAREXP B,(A)	; expand and get more.
		HRRZ B,$ARWPT(A)
		HRLI B,-400
		JRST FILGT5]
FILGT8:	.CLOSE DKIC,
	POP P,C
	POP P,B
	RET

OPNBII:	SETZ ? SIXBIT /OPEN/ ? [.BII,,DKIC] ? CERR OPNERR
	(A) ? 2(A) ? 3(A) ? SETZ 1(A)
BVAR
OPNERR:	0
FGTDEV:	BLOCK 10	;channel status info
EVAR

; TXFGET - Text File Getter.  Like FILGET, but assumes file is text
;	and converts area to text, adjusting EOF properly.
; TXFIN - similar conversion but like FILIN assumes DKIC is open and
;	never skips.

TXFGET:	CALL FILGET		; Open and get file into area.
	 RET			;  Failed.
	AOSA (P)		; Won, skip into conversion & skip on return.
TXFIN:	 CALL FILIN
	UARTYP [%ARTCH,,(A)]	; Convert area to text, 
	RET			; adjusting EOF automatically.

TXFINL:	 CALL FILINL		; Like TXFIN but takes limit in B.
	UARTYP [%ARTCH,,(A)]	; Convert area to text, 
	RET			; adjusting EOF automatically.


;;; EQVLEN - Return in U2 the length of the equivalences binary file.
;;;   This is used by IRQGET to estimate how much space is available.

EQVLEN:	PUSH P,A
	.IOPUSH DKIC,		; Save chan.
	SETZ U2,		; Return size in U2.
	SKIPE $AROPN+EQVAR	; If already in core
	 JRST EQVLE9		;  don't count it.
	MOVEI A,EQVFN1		; EQV binary file.
	CALL OPNMFI		; Try to open it up.
	 JRST EQVLE9		;  Lost!
	SYSCAL FILLEN,[CIMM DKIC ? CRET U2]
	 NOP
	ADDI U2,22.*PG$SIZ	; Measurements seem to be off by this much?
EQVLE9:	.IOPOP DKIC,
	POP P,A
	RET



SUBTTL Disk Input copy

; DKIOUT - Copies from DKIC to DKOC until reaches EOF on DKIC.
;	Tries to be clever about finding "true" EOF, by using only
;	the byte-count length if the input file has byte-size 7, 
;	and if not examines the last input word to flush trailing
;	padding chars (^C, ^L, ^@).

DKIOUT:	PUSHAE P,[A,B,C,D]
	MOVE B,[DKIC,,FGTDEV]	; Arg to RCHST
	.RCHST B,		; Get chan status for possible later ref.
	UAROPN A,[OMFAR ? [PG$SIZ+1]]	; Open buffer area.
	SYSCAL FILLEN,[CIMM DKIC ? CERR OPNERR
		CRET JUNK ? CRET B ? CRET C ? CRET D]
	 JRST [	MOVE B,OPNERR	; Failed?  Should only happen if
		CAIE B,34	; error = wrong type dev.
		 JSR SYSLOS	; Shouldn't ever be anything else.
		JRST DKIOU4]	; Hmm, just proceed as for word-mode files.
	JUMPE C,DKIOU8	; Optimize for zero-length pathological case...
	CAIE D,7	; If file wasn't written with byte-size 7 (text),
	 JRST DKIOU4	; go handle word-mode.
	IDIVI C,5	; Text! Find how many words, and get only that many.
	CAIN D,		; If exact multiple of 5,
	 SKIPA D,[5]	; then say 5 chars in last word.
	  ADDI C,1	; else leave D correct, and make sure we read last wd.
DKIOU2:	SKIPG B,C
	 JRST DKIOU9
	CAILE B,PG$SIZ		; If # words to go is too large,
	 MOVEI B,PG$SIZ		; stick to limit.
	SUBI C,(B)		; Update count
	MOVNI B,(B)
	MOVSI B,(B)
	HRR B,$ARLOC(A)		; Set up IOT aobjn-type ptr.
	XCTIOC [.IOT DKIC,B]	; Slurp up.
	 JRST DKIOU9		; Probably a data error if get here.
	JUMPL B,DKIOU6		; If didn't complete, length was wrong!!
	JUMPLE C,DKIOU3		; Jump if this was the last slurp.
	MOVE B,$ARLOC(A)	; Not last,  output full buffer
	HRLI B,PG$SIZ*5
	XCTIOC [OUTCAL(DKOC,TC(B))]	; Output it,
	 JRST DKIOU9		; Failure of some sort.
	JRST DKIOU2		; and go slurp some more.

	; Have last slurp in buffer, B has addr+1 of last wd.
	; D has # chars in the last wd.
DKIOU3:	MOVEI B,-1(B)		; Get addr of last word
	SUB B,$ARLOC(A)		; Find # words
	IMULI B,5		; Get # chars
	ADDI B,(D)		; and include last partial word.
	MOVSI B,(B)
	HRR B,$ARLOC(A)
	XCTIOC [OUTCAL(DKOC,TC(B))]	; Output it!
	 JRST DKIOU9		; Failure of some sort.
	JRST DKIOU8		; Done...

	; Here, file is of indeterminate length.  Read it in
	; and always keep the last word of previous input
	; around for reference; it only gets output if there
	; is in fact more stuff following it.
DKIOU4:	MOVE B,$ARLOC(A)
	HRLI B,-<PG$SIZ+1>	; Get stuff plus one extra wd.
DKIOU5:	XCTIOC [.IOT DKIC,B]	; Gobble gobble
	 JRST DKIOU9
	JUMPL B,DKIOU6		; Snarfed last stuff?
	MOVE C,-1(B)		; Nope, recover last word input
	MOVE B,$ARLOC(A)	; and output all but that last word.
	HRLI B,PG$SIZ*5
	XCTIOC [OUTCAL(DKOC,TC(B))]
	 JRST DKIOU9
	MOVE B,$ARLOC(A)
	MOVEM C,(B)		; Store the remaining word as 1st in buffer
	HRLI B,-PG$SIZ		; and set new count accordingly
	AOJA B,DKIOU5		; so as to IOT above that word.

	; Read in last stuff.  B has addr+1 of last word read.
DKIOU6:	HRLI B,350700		; Make ptr to 1st non-ex char
	MOVE D,$ARLOC(A)	; And get fence for backing up.
DKIOU7:	DBP7 B			; Decrement it, point at previous char.
	CAILE D,(B)		; Continue as long as still in buffer.
	 JRST DKIOU8		; Backed too far, none to output! win.
	LDB C,B			; Get it
	CAIE C,^L		; Test for any of several garbage chars.
	 CAIN C,^C
	  JRST DKIOU7
	JUMPLE C,DKIOU7

	HRLI D,440700
	PTRDIF D,B		; Find # chars, B-D
	MOVSI D,(D)
	HRR D,$ARLOC(A)		; Make ASCNT ptr to string
	XCTIOC [OUTCAL(DKOC,TC(D))]	; and output forthwith.
	 JRST DKIOU9
				; Fall through when done.

DKIOU8:	AOS -4(P)		; Win return.
DKIOU9:	.CLOSE DKIC,		; Don't need any more.
	UARCLS (A)		; Likewise flush area buffer.
	POPAE P,[D,C,B,A]
	RET

SUBTTL	Open DKOC in Append Mode

	; Unfortunately ITS has no way to set file length nor to
	; keep length at original setting until channel closed.
; OPNAPP - Open DKOC in Append mode.
;	A - addr of filblk
; Skips on success,
; else	B - RH has error code for last sys call (or 0 for general lossage)
;		Sign bit set for "permanent" errors.

.SCALAR EOFFIL	; True file EOF, in 7-bit bytes
.SCALAR EOFREC	; "Record" EOF, in ditto.
EOFMRK:	037	; ctl underscore, normal MAIL file record separator.

OPNAPP:	PUSH P,C
	SETZM EOFFIL		; Clear file EOF
	SETZM EOFREC		; and record EOF
OPNAP0:	SYSCAL OPEN,[[.UAI,,DKIC]	; First, try opening for read...
		(A) ? 2(A) ? 3(A) ? 1(A)	; Use true filespec.
	 	CERR B]
	 CAIA
	  JRST OPNAP3
	CAIE B,%ENSFL	; No such file?
	 JRST OPNAP7	; Any other error, fail with check.
	MOVE C,3(A)	; See if AOS'd version exists...
	AOS C
	SYSCAL RENAME,[(A) ? 2(A) ? C ? 1(A)
			2(A) ? 3(A) ? CERR B]
	 CAIA
	  JRST OPNAP0	; Success, try reading with original name!
	CAIN B,%ENSFL	; No such file here either?
	 JRST OPNAP6	; Yup, just create file.
	CAIN B,%EEXFL	; Or File already exists?
	 JRST OPNAP0	; Well, well, try again.
	JRST OPNAP7	; Anything else means just fail, with temp/perm chk.

	; File opened for reading, now find EOF's.
OPNAP3:	SYSCAL FILLEN,[CIMM DKIC ? CRET C ? CERR B]
	 JRST OPNAP9	; Any error is permanent, since should only happen for
			; non-disk devices.

	; We know that bytesize of chan will be 7.  Perhaps later
	; some hair could depend on whether file was written in byte
	; or word mode, but current brutalgorithm works either way.
	MOVEM C,EOFFIL	; Store file's true EOF
	MOVEM C,EOFREC

	; Now read backwards thru file until hit record-EOF mark.
OPNAP4:	SOSG C,EOFREC
	 JRST OPNAP6		; Backed to start, re-create.
	.ACCESS DKIC,C
	.IOT DKIC,B
	CAME B,EOFMRK		; Char = to EOF mark?
	 JRST OPNAP4		; Nope, keep backing up.
	AOS EOFREC		; Win! Set final record-EOF value.

OPNAP6:	.CLOSE DKIC,
	MOVE C,[.UAO,,DKOC]
	SKIPLE EOFREC		; If record EOF is for real,
	 TLO C,%DOWOV+%DORWT	; use write-over mode.
	SYSCAL OPEN,[C		; OK, try opening!
		(A) ? 2(A) ? 3(A) ? 1(A)	; Use true filespec.
	 	CERR B]
	 JRST OPNAP7		; Error now?  Sigh...
	SKIPLE EOFREC		; Successful open!  Need to adjust write ptr?
	 .ACCESS DKOC,EOFREC	; Yep, just do it.
	AOS -1(P)		; Win return!
	JRST OPNAP9		; Value of B doesn't matter.

	; Check out err code to see if should advise temp or perm
	; (i.e. try again later, or give up.)
OPNAP7:	CAIE B,%EFLDR	; Dir full?
	 CAIN B,%ENADV	; or dev not avail?
	  JRST OPNAP8	; either is temp err.
	CAIE B,%ENAFL	; File locked?
	 CAIN B,%ERODV	; Device write-locked?  (This one maybe perm)
	  JRST OPNAP8
	CAIE B,%EFLDV	; Device full? (This one maybe impossible)
	 JRST OPNAP9	; Anything else is PERMANENT error.

OPNAP8:	TLZA B,-1	; Temp err, return positive B.
OPNAP9:	 TLO B,(SETZ)	; Perm err, return negative B.
	POP P,C
	RET

SUBTTL Filename Parsing

; Given ASCNT ptr in A to string, assumes it is bracketed filename and parses
;into block using defaults as specified by <defblk>,,<filblk> in B.

FILPAR:	PUSHAE P,[A,B,C,D,E]
	MOVE E,B
	BLT B,3(E)		;fill block with defaults before parsing
	CALL PARFNM		;parse it
	CAIE A,
	 MOVEM A,(E)		;store dev
	CAIE B,
	 MOVEM B,1(E)
	CAIE C,
	 MOVEM C,2(E)
	CAIE D,
	 MOVEM D,3(E)
	POPAE P,[E,D,C,B,A]
	RET

; given ascnt ptr in a to bracketed filename, returns in a,b,c,d the
;dev/dir/fn1/fn2 with zeros where none found.  parses like ddt, i.e.
;single name treated like fn1, not teco-style fn2.
; Flushes first "[" and last "]" if latter exists... ^Q quotes.

BVAR
PRFC:	0	; cnt for string
PRFP:	0	; bp to string
PRFDEV:	0	; DEV if any
PRFDIR:	0	; DIR  "
EVAR

PRCGT:	SOSGE PRFC	; Read a char
	RET
	ILDB A,PRFP
	AOS (P)
	RET

PARFNM:	HLRZM A,PRFC	;store cnt
	HRLI A,440700
	MOVEM A,PRFP	;and ptr
	SETZB C,D	; Clear FNM's
PARFN0:	CALL PRCGT
	 JRST [SETZB A,B ? RET]	;nothing there? Ensure nothing returned.
	CAIE A,"{
	 CAIN A,"[
	  JRST PARFN1
	CAIN A,40	;flush spaces
	 JRST PARFN0
	AOS PRFC	;else char is beg of filename; back up.
	D7BPT PRFP
	
PARFN1:	SETZM PRFDEV
	SETZM PRFDIR
PARFN2:	SKIPG PRFC
	 JRST PARFN9		;done
	CALL PRCGET		;get token
	CAIN B,":
	 JRST [MOVEM A,PRFDEV ? JRST PARFN2]
	CAIN B,";
	 JRST [MOVEM A,PRFDIR ? JRST PARFN2]
	CAIN B,40
	 JRST [CALL PRFNPT ? JRST PARFN2]
	; Any other terminator = EOF.  Falls thru...

PARFN8:	JUMPE A,PARFN9
	CALL PRFNPT
PARFN9:	MOVE A,PRFDEV
	MOVE B,PRFDIR
	RET

PRFNPT:	JUMPE C,[MOVE C,A ? RET]
	JUMPE D,[MOVE D,A ? RET]
	SKIPN PRFDEV
	 JRST [MOVEM A,PRFDEV ? RET]
	MOVEM A,PRFDIR
	RET

.SCALAR PRC6WD	; Holds accumulated 6bit

PRCGET:	MOVE B,[440600,,PRC6WD]
	SETZM PRC6WD
PRCGT1:	CALL PRCGT
	 JRST PRCGT6
	CAIE A,";
	 CAIN A,":
	  JRST PRCGT7
	CAIE A,40
	 CAIN A,"]
	  JRST PRCGT7
	CAIN A,"}
	 JRST PRCGT7
	CAIN A,^Q		;quoting?
	 JRST [	CALL PRCGT	;insert next char whatever it is.
		 JRST PRCGT6
		JRST .+1]
	CAIL A,141
	 CAILE A,172
	  SKIPA
	   SUBI A,40
	SUBI A,40
	TLNE B,770000
	 IDPB A,B	;don't deposit if already done 6 chars.
	JRST PRCGT1
PRCGT6:	TDCA B,B		;clear B and skip.
PRCGT7:	 MOVE B,A
	MOVE A,PRC6WD
	RET

SUBTTL Random little routines

; LASCIZ - Addr in A to asciz string, returns in A the # chars in string.
;	String must obviously start on word boundary.
;	Faster than LBPASZ (8 instrs/loop and no ILDB'ing).

LASCIZ:	PUSHAE P,[B,C]
	MOVE C,A
	TDCA A,A		;clear A and skip
LASCZ1:	 ADDI A,5
	SKIPE B,(C)
	 TLNN B,774000		; Test 1st char
	  JRST LASCZ7		; Null, done.
	TLNN B,3760		; Test 2nd char
	 AOJA A,LASCZ7		; Null, add 1 and done.
	TDNN B,[17,,700000]
	 JRST LASCZ6		; Go add 2, done.
	TRNN B,77400
	 AOJA A,LASCZ6		; Add 3
	TRNE B,376
	 AOJA C,LASCZ1		; Not ended yet; increment address and add 5.
	ADDI A,4
	JRST LASCZ7
LASCZ6:	ADDI A,2
LASCZ7:	POP P,C
	POP P,B
	RET

; LBPASZ - Takes a BP to an ASCIZ string in A, and returns the number of chars
;	in A.  (Like LASCIZ, but allows any BP).
LBPASZ:	PUSHAE P,[B,C]
	SETZ B,
	ILDB C,A
	CAIE C,0
	 AOJA B,.-2
	MOVE A,B
	POPAE P,[C,B]
	RET

; ASZCNT - Takes address of an ASCIZ string (in A), returns ASCNT
;	 to that string (in A).

ASZCNT:	PUSH P,A	; Save addr
	CALL LASCIZ	; Get length of asciz string.
	HRLM A,(P)	; Store cnt in LH of saved addr.
	POP P,A		; restore as ASCNT ptr.
	RET

; AZMCNT - Takes addr in A of string which stops on either ^@ or ^M
;	and returns ASCNT ptr in A.
AZMCNT:	PUSHAE P,[B,C]
	HRLI A,440700
	HRLZ B,A
	ILDB C,A
	JUMPE C,.+3
	CAIE C,^M
	 AOJA B,.-3
	MOVS A,B
	POPAE P,[C,B]
	RET

; CVT6PC - Takes <cnt>,,[<bp>] in A, returns SIXBIT in A.
CVT6PC:	PUSHAE P,[B,C]
	HLRZ B,A
	MOVE C,(A)
	PJRST CVT6

; CVLS6 - Takes SLP in A, returns SIXBIT in A.
CVLS6:	MOVE A,LISTAR(A)+1	;get SPT
	ADD A,$LSLOC(L)		;make abs and drop thru into CVT76C

; CVT76C - Takes an ASCNT in A, returns SIXBIT in A.
CVT76C:	PUSHAE P,[B,C]
	HLRZ B,A		;cnt in B
	MOVE C,A		;bp in C
	HRLI C,440700
CVT6:	PUSHAE P,[D,E]
	JUMPE B,[SETZ A,
		JRST CVT762]	;if cnt = 0
	CAILE B,6
	 MOVEI B,6		;force to 6 if greater than
	JRST CVT760

; CVT76 - Takes a BP to an ASCIZ string in A, returns SIXBIT in A.
;	Stops when reach 0 or get 6 chars, or hit blank and previous
;	chars were nonblank.

CVT76:	PUSHAE P,[B,C,D,E]
	MOVE C,A
	MOVEI B,6
CVT760:	SETZ A,
	MOVE D,[440600,,A]
CVT761:	ILDB E,C
	CAIN E,40
	 JUMPN A,CVT762	;if hit blank, stop only if something already accumulated
	JUMPE E,CVT762
	CAIL E,141	;convert to uppercase
	 CAILE E,172
	  CAIA
	   SUBI E,40
	SUBI E,40	;convert to 6bit
	IDPB E,D
	SOJG B,CVT761
CVT762:	POPAE P,[E,D,C,B]
	RET

;;;	Various uppercasifiers, all smash the string given in A as argument,
;;;	and clobber no ACs.

; SLNUPR - A/ SLP (LP to string)
; UPPRZ  - A/ ASCNT pointer
; UPPRZB - A/ <char cnt>,,[<byte ptr>]

SLNUPR:	PUSHAE P,[A,B,C]
	MOVE B,LISTAR(A)+1	; Get the SPT for it.
	HLRZ C,B		; Get count
	ADD B,$LSLOC(L)		; Make absolute addr
	HRLI B,440700		; And BP
	PJRST UPRCS7

UPPRZ:	PUSHAE P,[A,B,C]
	HLRZ C,A		; get count in C
	MOVE B,A
	HRLI B,440700		; and BP in B
	PJRST UPRCS7

UPPRZB:	PUSHAE P,[A,B,C]
	MOVE B,(A)		;get byte ptr
	HLRZ C,A		;get cnt
	JRST UPRCS7

UPRCS4:	ILDB A,B
	CAIL A,141		;lower a
	 CAILE A,172		;lower z
UPRCS7:	  SOJGE C,UPRCS4	; Not lowercase, continue.
	JUMPL C,PPCBAJ
	SUBI A,40		;lower, cvt to upper
	DPB A,B			;deposit back
	SOJGE C,UPRCS4
	POPAE P,[C,B,A]
	RET

SUBTTL Random variables, data areas.

;;; Table of ARPT's to all standard ARBLK's to be flushed when coring down.
ARPTBL:	MASTER
	MSGAR
	;SCHDAR		;keep this in core
	QMLAR
	RMLAR
	EQVAR
	TMPAR
	ETXTAR
	EMSGAR
	PGMAR
	OMFAR
	IMSAR
NAREAS==.-ARPTBL

BVAR
MASTER:	BLOCK $ARSIZ	; Master message-ID list area.
MSGAR:	BLOCK $ARSIZ	; Message list area.
SCHDAR:	BLOCK $ARSIZ	; Scheduler list area.
QMLAR:	BLOCK $ARSIZ	; Queued Message list area.
RMLAR:	BLOCK $ARSIZ	; Reminders list area.
EQVAR:	BLOCK $ARSIZ	; Equivalence list area.
ETXTAR:	BLOCK $ARSIZ	; Error-message text collection area.
EMSGAR:	BLOCK $ARSIZ	; Error-message attrib collection area.
OMFAR:	BLOCK $ARSIZ	; Area used for forming mail-file output.
PGMAR:	BLOCK $ARSIZ	; Area for holding composition of SNDPGM error message.
TMPAR:	BLOCK $ARSIZ	; Temporary area for various things.

MASTRP:	0		; Holds LP to "current" LLN of MASTER list.

IMSAR:	BLOCK $ARSIZ	;area containing input from file
IMSTIM:	0		;creation date of file

RCPNUM:	0		;# of Rcpts seen.
RRCPS:	0		;# of real (not psuedo-name) recipients.

HFLUSN==10.		;(How many sites in the following losers list.)
HFLUSH:			;List of sites whose queued mail should be flushed.
REPEAT HFLUSN,-1	;Use zero to indicate the local host.

HDOWN:	250.		; Number of tries before host permanently down.
			; 500. = 1 week
EVAR

LITTER:	CONSTANTS	; Now dump out all literals/constants here

	VARCHK		; Now dump out all variables, and find
			; how big impure and pure really are.

	; Memory management definitions (now that we know how big pgm is!)

LCKPAG==<.+2000-1>/2000
SYSWPG==LCKPAG+1	; Page # to use for mapping into system (for NQMFWR)
FREEPG==SYSWPG+1

LSWLOC=:LCKPAG*2000	;loc where switch page starts
LSWREQ=:LSWLOC		;init request flag
LSWDON=:LSWLOC+1	;init done flag
LOCK1=: LSWLOC+<1*2>	;switch 1 (2 wd block)
LOCK2=: LSWLOC+<2*2>	;switch 2  "  "  "   (Note: LOCK2 is not used at present.)
NLCKSW==2		; # of lock switches.
LSHTIM=:LOCK2+3

END INIT