Google
 

Trailing-Edge - PDP-10 Archives - bb-ev83b-bm_longer - tcpip-sources/mmailr.mac
There are 3 other files named mmailr.mac in the archive. Click here to see a list.
	TITLE MMailr -- System Mailer Daemon for MM Mailsystem
	SUBTTL Mike McMahon & Mark Crispin/TCR/DT/DE/CLH/yduJ/GZ/SRA/WD/LeL

;Version components

MMLWHO==0			;Who last edited MMAILR (0=developers)
MMLVER==6			;MMAILR's release version (matches monitor's)
MMLMIN==1			;MMAILR's minor version
MMLEDT==^D522			;MMAILR's edit version

	SEARCH MACSYM,MONSYM	;System definitions
	SEARCH SNDDEF		;Definitions for terminal messages
	SALL			;Suppress macro expansions
	.DIRECTIVE FLBLST	;Sane listings for ASCIZ, etc.
	.TEXT "/NOINITIAL"	;Suppress loading of JOBDAT
	.TEXT "MMAILR/SAVE"	;Save as MMAILR.EXE
	.TEXT "/SYMSEG:PSECT:CODE" ;Put symbol table and patch area in CODE
	.REQUIRE HSTNAM		;Host name routines
	.REQUIRE WAKEUP		;MMailr wakeup routines - make LINK happy
	.REQUIRE SNDMSG		;Terminal message support
	.REQUIRE SYS:MACREL	;MACSYM support routines
	.REQUIRE RELAY		;RELAY code

; *******************************************************************
; *								    *
; *  MMailr is a multiple network mailer program for TOPS-20.  Like *
; * most fine software, it is the result of several individuals'    *
; * work.							    *
; *  It was originally conceived as XMAILR about January 1980 by    *
; * Mike McMahon (MIT Artificial Intelligence Lab) and jointly	    *
; * developed for TOPS-20 with Mark Crispin (Stanford Computer	    *
; * Science Dept.).						    *
; *  The TENEX version of XMAILR was developed by Tom Rindfleisch   *
; * (Stanford SUMEX Project) and Mike McMahon in January 1981.	    *
; *  MMailr was developed from XMAILR version 524 for TCP/IP and    *
; * SMTP by Mark Crispin in September 1982.  Dan Tappan (BBN)	    *
; * assisted in the development and debugging of the new host name  *
; * lookup technology, including eliminating the need for HOSTS2.   *
; * David Eppstein (Stanford) wrote the interface into the send     *
; * system, which in turn was written by Kirk Lougheed (Stanford)   *
; * et. al.  Charles Hedrick (Rutgers) wrote the new relaying code. *
; * Ken Rossman (Columbia) wrote the first DECnet support code.	    *
; * Willis Dair (Santa Clara Univ) wrote the new multi-hop	    *
; * Mark Crispin wrote the HSTNAM module and SMTP support, lots of  *
; * miscellaneous code, specified the other modules noted above,    *
; * and generally guided MMailr through its long evolution.	    *
; *								    *
; *******************************************************************

; Routines invoked externally

	EXTERN $GTPRO,$GTNAM,$GTCAN,$GTLCL,$GTHST
	EXTERN $ADDOM,$RMREL,$RRDOM,$UKHST
	EXTERN $GTHNS,$PUPNS,$CHSNS,$DECNS,$SPCNS
	EXTERN $PUPSN
	EXTERN $SEND,$WTRCP,$SSTAT
	EXTERN $GTRLY,$INRLY,DM%TRN,DM%RLY
	SUBTTL Conditional Assembly

; Following are assembly switches and functions

IFNDEF DATORG,<DATORG==1000>	;Data on page 1
IFNDEF CODORG,<CODORG==10000>	;Code on page 10
IFNDEF PAGORG,<PAGORG==50000>	;Paged data on page 50
IFNDEF FREORG,<FREORG==100000>	;Free storage starts at page 100
IFNDEF NTDAYS,<NTDAYS==1>	;Default sender status period, 1 day
IFNDEF DEDAYS,<DEDAYS==3>	;Default dead letter period, 3 days
IFNDEF MAXTMT,<MAXTMT==^D15*60> ;Max time for Daemon to transmit whole message
IFNDEF MAXTMC,<MAXTMC==^D15*60> ;Max time for Daemon to transmit one copy
IFNDEF MAXTMB,<MAXTMB==^D2*60>	;Max time to transmit 1000 chars
IFNDEF INTRXM,<INTRXM==^D30>	;Number of minutes between retransmit scans
IFNDEF INTSCN,<INTSCN==^D5>	;Number of minutes between file scans
	SUBTTL Definitions

F==:0				;Flags
A=:1				;JSYS/argument passing
B=:2				;...
C=:3				;...
D=:4				;...
E=:5
T=:6				;Scratch
TT=:7				;Ditto
M=:10				;Holds current message
N=:11				;Current host block when sending
O=:12				;Current recipient block ""
X=:14
Y=:15
CX=:16				;Used by MACREL
;P=:17				;Stack pointer

; Character definitions

.CHDQT==""""			;Double quote

; Local UUO's
OPDEF UTYPE [1B8]
OPDEF UETYPE [2B8]
OPDEF UERR [3B8]

; Macros for initializing and disabling timer
TMRTCK==^D5			;Timer tick interval in seconds

; intvl = time-out interval in seconds
; retad = time-out error return address
DEFINE TMOSET (INTVL,RETAD) <
	SETZM INTOK		;An interrupt here could be embarrassing
	MOVEM P,TIMRTP		;Save the stack ptr for return
	PUSH P,[PC%USR+RETAD]	;Set the return address
	POP P,TIMLOC
	PUSH P,[-<INTVL/TMRTCK>] ;Set the time-out interval in ticks
	POP P,INTOK
>;DEFINE TMOSET

DEFINE TMOCLR <
	SETZM INTOK		;Turn off time-out counter
	SETZM TIMLOC		;And the return adr
>;DEFINE TMOCLR

; The following print macros do output only if PRINTP is set
DEFINE TYPE (X)
   <	UTYPE [ASCIZ/X/]	;Just type string
   >
DEFINE CTYPE (X)
   <	UTYPE 10,[ASCIZ/X/]	;Do crlf and type string
   >
DEFINE CITYPE (X)
   <	UTYPE 1,[ASCIZ/X/]	;Conditional crlf and type string
   >

DEFINE ETYPE (X)
   <	UETYPE [ASCIZ/X/]	;Type string (fmt codes)
   >
DEFINE CETYPE (X)
   <	UETYPE 10,[ASCIZ/X/]	;Do crlf and type string (fmt codes)
   >
DEFINE CIETYP (X)
   <	UETYPE 1,[ASCIZ/X/]	;Conditional crlf and type str (fmt codes)
   >

DEFINE DEFERR (X,Y) <
 DEFINE X (Z) <
  IFB <Z>,<UERR Y,0>
  IFNB <Z>,<UERR Y,[ASCIZ/Z/]>>
 OPDEF %'X [UERR Y,]>

DEFERR WARN,0
DEFERR JWARN,4
DEFERR FATAL,10
DEFERR JFATAL,14
IFNDEF OT%822,OT%822==:1

IFNDEF GTDOM%,<
	OPDEF GTDOM% [JSYS 765]

GD%LDO==:1B0			; local data only (no resolve)
GD%MBA==:1B1			; must be authoritative (don't use cache)
GD%RBK==:1B6			; resolve in background
GD%EMO==:1B12			; exact match only
GD%RAI==:1B13			; uppercase output name
GD%QCL==:1B14			; query class specified
GD%STA==:1B16			; want status code in AC1 for marginal success
  .GTDX0==:0			; total success
  .GTDXN==:1			; data not found in namespace (authoritative)
  .GTDXT==:2			; timeout, any flavor
  .GTDXF==:3			; namespace is corrupt

.GTDWT==:12			; resolver wait function
.GTDPN==:14			; get primary name and IP address
.GTDMX==:15			; get MX (mail relay) data
  .GTDLN==:0			; length of argblk (inclusive)
  .GTDTC==:1			; QTYPE (ignored for .GTDMX),,QCLASS
  .GTDBC==:2			; length of output string buffer
  .GTDNM==:3			; canonicalized name on return
  .GTDRD==:4			; returned data begins here
  .GTDML==:5			; minimum length of argblock (words)
.GTDAA==:16			; authenticate address
.GTDRR==:17			; get arbitrary RR (MIT formatted RRs)
>;IFNDEF GTDOM%
	SUBTTL Flags

; Beware!  Flags are local, not global.  Consequently, they shouldn't be
;referenced outside of their defined context.  Each return from a SAVACS
;context will restore the flags to their prior context.
;
; There are a number of other flags in various location, this page is only
;for the flags in F.

;;; Parser flags
FP%FF== 1B0			;Formfeed seen at start of line
FP%CLN==1B1			;Colon seen
FP%EOL==1B2			;Blank line (after any formfeed, that is)
FP%DEL==1B3			;Rubout on line
FP%EQU==1B4			;Equal sign seen (control parameter)
FP%BKA==1B5			;Backarrow seen (sender spec)
FP%WSP==1B6			;Whitespace at start
	;;; Following used in parsing sender addresses from msg headers
FP%LBK==1B7			;Left angle bracket seen
FP%RBK==1B8			;Right angle bracket seen
FP%HST==1B9			;Collecting host
FP%SEP==1B10			;"Separator" at end of sender adr field
FP%DQT==1B11			;" seen to start quoted field

;;; Delivery flags
FM%FAI==1B18			;Failing message
FM%RLY==1B19			;Current transaction is being relayed
FM%HDR==1B20			;Headers already generated
FM%FLO==1B21			;Addressee is a file
FM%VRC==1B22			;Valid recipient seen
FM%QOT==1B23			;Must quote this address in protocol

;;; Requeue flags
FQ%DON==1B26			;"Host done" set on entry
FQ%XER==1B27			;Discard msg on failure
FQ%XNT==1B28			;Don't send non-delivery notifications
FQ%RNM==1B29			;Rename file to have RETRANSMIT ext
FQ%SXX==1B30			;Failure notice rerouted to mail agent
FQ%SDR==1B31			;Mail failed to sender
FQ%MLA==1B32			;Mail failed to mail agent
FQ%OMF==1B33			;Old style mail queue file
FQ%ALL==1B34			;Output all of this host
FQ%HST==1B35			;Host already output
	SUBTTL Paged storage

	.PSECT DATPAG,PAGORG	;Enter paged data

DEFINE DEFPAG (ADDR,LENGTH) <
ADDR:	IFB <LENGTH>,<BLOCK 1000>
	IFNB <LENGTH>,<BLOCK 1000*LENGTH>
>;DEFINE DEFPAG

DEFPAG IPCPAG,1			;Junk page for IPCF
DEFPAG HSTTBL,4			;Internal table of hosts
 HTBLSZ==<4*1000>-1		;Length of table in TBLUK% format
DEFPAG FLGPAG			;For MAILER.FLAGS if needed
DEFPAG TMPBUF,2			;Temporary storage
DEFPAG FWDWIN,2			;Forwarding string window

	.ENDPS

	.PSECT FRESTG,FREORG

FSPAG==<FREORG/1000>		;First free storage page

	.ENDPS
	SUBTTL Impure storage

	LOC 20			;Low memory
FATACS:	BLOCK 20		;AC's saved on crash
UUOLOC:	BLOCK 1			;LUUO saved here
	JSR UUOH		;Set up UUO handler
FHTAB:	BLOCK 3			;Start of daughter fork handle table
FORKX:	BLOCK 1			;Logical fork number
NEWF:	BLOCK 1			;Non-zero to scan new mail
NETF:	BLOCK 1			;Non-zero to deliver to network recipients
RXMF:	BLOCK 1			;Non-zero to scan retransmit mail
FSTF:	BLOCK 1			;Non-zero to cache dead hosts
DAEMNP:	BLOCK 1			;If running as system job
WOPRP:	BLOCK 1			;If WHEEL or OPERATOR
MYUSRN:	BLOCK 1			;User number
MYDIRN:	BLOCK 1			;Connected directory number
MYJOBN:	BLOCK 1			;Job number
MYLDIR:	BLOCK 1			;Logged-in directory

	RELOC

	.PSECT DATA,DATORG	;Enter data area

NPDL==500			;Size of stack
PDL:	BLOCK NPDL		;Pushdown list

MEMBEG==.			;Start of memory initialized at startup
IPCFON:	BLOCK 1			;Non-zero if IPCF is set up
LOGJFN:	BLOCK 1			;Log file when Daemon
STAJFN:	BLOCK 1			;Statistics file when Daemon
SEGSIZ:	BLOCK 1			;Size of segments we'll send
MPP:	BLOCK 1			;Saved stack ptr for SAVACS/RSTACS
SAVEN:	BLOCK 1			;Place to save recipient host ptr
SAVEP:	BLOCK 1			;For Pup abort returns
DODJFN:	BLOCK 1			;DODIR's current JFN
FRNHST:	BLOCK 1			;Address of foreign host string
FRNADR:	BLOCK 1			;Foreign host address
PGTBLL==<1000-FSPAG+^D35>/^D36
PAGTBL:	BLOCK PGTBLL		;Bit table
FREPTR:	BLOCK 1			;Tail,,head for free block list
PLINBP:	BLOCK 2			;Start of line in parser
PWSPBP:	BLOCK 2			;Byte pointer of start of line after whitespace
PCLNBP:	BLOCK 2			;Where there was a colon
PDELBP:	BLOCK 2			;Where there was a rubout
PDELB2:	BLOCK 2			;Where it ends
SDRHST:	BLOCK 1			;Sender host site
SDRNAM:	BLOCK 2			;Ptr/cnt to sender name
NXTSEQ:	BLOCK 1			;Ascending number in sequence for uniqueness
NETJFN:	BLOCK 1			;Network JFN
REQJFN:	BLOCK 1			;Requeue output JFN
FAIJFN:	BLOCK 1			;Failure message JFN
NTFJFN:	BLOCK 1			;Sender notify message JFN
HSHPAG:	BLOCK 1			;Page it is mapped into
HSHSIZ:	BLOCK 1			;Size of hash file
SITHSH:	BLOCK 1			;Hash for this site
TXTJFN:	BLOCK 1			;JFN for text file
CURDTM:	BLOCK 1			;Date/time when MMailr scan started
SCNTIM:	BLOCK 1			;Time to do file scan
SYSDIR:	BLOCK 1			;SYSTEM: directory
MLQDIR:	BLOCK 1			;MAILQ: directory
DIRNUM:	BLOCK 1			;Directory being hacked
MFLAGP:	BLOCK 1			;Are mailer flags mapped in?
TIMKIL:	BLOCK 1			;-1 if clock should be killed
TIMLOC:	BLOCK 1			;PC to go to on time-out
TIMRTP:	BLOCK 1			;Stack ptr for time-out return
INTOK:	BLOCK 1			;Neg if time-out interrupt active
INTPC:	BLOCK 1			;Interrupt PC
CTGCNT:	BLOCK 1			;# of ^G's typed
ICPTIM:	BLOCK 1			;ICP time-out countdown
HDRLEN:	BLOCK 1			;Number of characters in current header block
FILIDX:	BLOCK 1			;File tbl index for queued file type
OMLRBF:	BLOCK 20		;Buffer for address strings (old MAILER)
MBXFK:	BLOCK 1			;MMAILBOX.EXE fork handle
INUUO:	BLOCK 1			;Safety check to prevent recursive UUO's
 NUPDL==100			;Size of UUO PDL
UUOPDL:	BLOCK NUPDL		;Pushdown list for processing UUO's
UUOACS: BLOCK 20		;ACs saved over UUO
INTACS:	BLOCK 20		;ACs saved over level 1 interrupt
 HSTBFL==^D30
HSTBUF:	BLOCK HSTBFL		;Put string of a host here
 AUTLEN==20			;Length of author strings
FILAUT:	BLOCK AUTLEN		;Place for msg file's author string
ORGAUT:	BLOCK AUTLEN		;Vanilla author string
GTINF:	BLOCK <.JIBAT-.JITNO+1>	;GETJI% stores data here
	GTDLEN==.GTDML+10
GTDBLK:	BLOCK GTDLEN+1		;GTDOM% argument block
	RLYBFL==5*HSTBFL
RLYBUF:	BLOCK RLYBFL		;MX relays buffer
USRNUM: BLOCK 1

NTDEQF:	BLOCK 1			;Pos  -- Notify sender if undeliverable
				;Zero -- No action
				;Neg  -- Dequeue msg if undeliverable
IPCNT:	BLOCK 1			;Count of times we've MSEND%'d
IPCFOK:	BLOCK 1			;Non-zero if okay to bump interrupted PC
NOSLEP:	BLOCK 1			;Non-zero if we should skip DISMS
DOMTBL:	BLOCK 1			;Table of domains created by relay code
SNRLYS:	BLOCK 1
SRLYTB:	BLOCK 20		;Table of domain block pointers
DNRLYS:	BLOCK 1			;In TRNMGR a call is used to build a path
DRLYTB:	BLOCK 20		; back to the host given a domain
				;The destination domain is at offest 0
				; will all the domain blocks back to our
				; neighbor
PTHEND:	BLOCK 1			;The offset off of PTHLST containing the
				; last host in the path
PTHLST:	BLOCK 40		;List of host relays that are in the path
STRBSZ==1000			;Length of string buffers
STRBUF:	BLOCK STRBSZ		;String buffer, used globally
STRBF1:	BLOCK STRBSZ		;Alternative string buffer, used locally
STRBF2:	BLOCK STRBSZ		;Another alternate buffer used locally
FRMMSG=STRBF2+<STRBSZ/2>
MEMEND==.-1			;End of memory initialized at startup

PIDGET:	IP%CPD			;Create a PID
	0			;Where the PID goes
	0			;For <SYSTEM>INFO
	ENDPID-.,,.+1		;Length,,address of message block
	1,,.IPCII		;Ask to associate a name
	0			;No PID for copy
	ASCIZ/[SYSTEM]MMAILR/	;The name
ENDPID==.

IPCFMS:	0			;Flags
	0			;Sender
	0			;Receiver
	IPCFBL,,IPCFBF		;Length,,address of message block

	IPCFBL==10		;Size of IPCF buffer
IPCFBF:	BLOCK IPCFBL		;Place for MRECV%/MUTIL% to write to

SDBLOK:	0			;.SDPID - PID for local sends
	T%RSYS!T%HDR		;.SDFLG - We build the header, obey REF SYS

; Site-selectable runtime flags

TRALLP:	0			;-1 if transmogrification should always be done
				;   when crossing network registries even if the
				;   name is a domain name.  However, Internet
				;   names are never transmogrified.
				; 0 if transmogrification is suppressed if the
				;   name is a domain name.

PRINTP:	0			;-1 to print activity messages
DEBUGP:	0			;-1 if debugging network protocol

LOGP:	0			;-1 if should make logs

STATP:	0			;-1 if should keep statistics
;;;Non-zero pure data

UUOH:	0			;UUO handler
	JRST UUOH0

SAVACS:	0			;AC save routine
	JRST SAVAC0

LCLNAM:	ASCIZ/TOPS-20/		;Gets clobbered at initialization time
	BLOCK LCLNAM+20-.
LCLNME==.			;End of local name (for padding purposes)

LCLNCN:	BLOCK 20		;Local name for current network

CHNTAB::PHASE 0
	1,,TIMINT		;Time-out
	1,,CTGINT		;^G typed
IPCHAN::!1,,IPCINT		;Handle IPCF interrupt
WAKCHN::!1,,WAKINT		;Process interrupt wakeup channel
	REPEAT <^D36-.>,<0>
	DEPHASE
; Sending protocol information
;
; SNDRT0 contains all the routines that MMailr might use.
;
; SNDRTS is a table (built from SNTRT0) of the routines
; it can use (because the monitor knows about them)
;
DEFINE	DEFNT(PROT,NTDEV,SNDRTN)<
	[[ASCIZ/PROT/],,SNDRTN],,[ASCIZ/NTDEV/]
>;DEFINE DEFNT

; These should be ordered by prefered priority of use
SNDRT0:	DEFNT(Special,MAILS,SPCSND) ;Special (non-MMailr) network
	DEFNT(TCP,TCP,INTSND)	;Internet
	DEFNT(Chaos,CHA,CHASND) ;Chaosnet
	DEFNT(Pup,PUP,PUPSND)	;Pup Ethernet
	DEFNT(DECnet,DCN,DCNSND) ;DECnet
NSNDRS==.-SNDRT0

; Format of a SNDRTS table entry is <Protocol name>,,<routine>
;
SNDRTS:	BLOCK NSNDRS		;Where we build the table
	0			;End of table marker

	.ENDPS
	SUBTTL Pure storage

	.PSECT CODE,CODORG	;Enter code

LEVTAB::INTPC			;Priority level table
	0
	0

BITS:
...BIT==0
REPEAT <^D36>,<
	1B<...BIT>
	...BIT==...BIT+1
>;REPEAT <^D36>

;;; Various timer value definitions
RXMINT:	INTRXM*^D<60*1000>	;RETRANSMIT file scan interval
SCNINT:	INTSCN*^D<60*1000>	;File scan interval
NTFINT:	NTDAYS,,0		;Sender notify interval (internal fmt)
MAXQUE:	DEDAYS,,0		;Maximum time in the queue (internal fmt)
TMTINT:	MAXTMT*^D1000		;Max total transmission time (msec)
TMCINT:	MAXTMC*^D1000		;Max transmission time/copy (msec)

DAEDIR:	ASCIZ/OPERATOR/		;Directory DAEMON runs out of
MLAGNT:	ASCIZ/Mailer/		;Person handling mail problems
; Following are definitions and a table of file names/processing
; functions to handle delivery of various queued mail formats:

DEFINE FILXX(GSTR,BSTR,PRCHDR,PRCTXT,FLGS)<
   %FLSTR==0
	[ASCIZ `GSTR`],,[ASCIZ `BSTR`] 	;File group name string
   %FLPRC==1
	PRCHDR,,PRCTXT			;Setup routines for processing
					;header/text
   %FLFLG==2
	FLGS
   %FLLEN==3
>;DEFINE FILXX

; Control flags for processing names
FF%OML==1B0		;Old style queue file (adr in extension)
FF%RNM==1B1		;Rename file with RETRANSMIT ext if requeued
FF%RXM==1B2		;Only scan this file type every RXMINT minutes
FF%XNT==1B3		;Don't notify sender of failures
FF%NEW==1B4		;This is a new file with possible local recipients
FF%NET==1B5		;This file is requeued from NEW

FILTBL:	FILXX(<[--QUEUED-MAIL--].NEW*>,<[--BAD-QUEUED-MAIL--].>,GQUEQM,GQUEH1,FF%RNM!FF%NEW)
	FILXX(<[--QUEUED-MAIL--].NETWORK>,<[--BAD-QUEUED-MAIL--].NETWORK>,GQUEQM,GQUEH1,FF%RNM!FF%NET)
	FILXX(<[--QUEUED-MAIL--].RETRANSMIT>,<[--BAD-QUEUED-MAIL--].RETRANSMIT>,GQUEQM,GQUEH1,FF%RXM)
	FILXX(<[--RETURNED-MAIL--].NEW*>,<[--BAD-RETURNED-MAIL--].>,GQUEQM,GQUEH1,FF%RNM!FF%XNT!FF%NEW)
	FILXX(<[--RETURNED-MAIL--].NETWORK>,<[--BAD-RETURNED-MAIL--].>,GQUEQM,GQUEH1,FF%RNM!FF%XNT!FF%NET)
	FILXX(<[--RETURNED-MAIL--].RETRANSMIT>,<[--BAD-RETURNED-MAIL--].RETRANSMIT>,GQUEQM,GQUEH1,FF%XNT!FF%RXM)
	FILXX(<[--UNSENT-MAIL--].*>,</UNDELIVERABLE-MAIL/.>,GQUEUN,GQUEH0,FF%OML!FF%NEW)
	FILXX(<]--UNSENT-NEGATIVE-ACKNOWLEDGEMENT--[.*>,</UNDELIVERABLE-MAIL/.>,GQUEUN,GQUEH0,FF%OML!FF%XNT)
NFTBL==<.-FILTBL>/%FLLEN
	SUBTTL Main program

IFNDEF VI%DEC,<			;In case MACSYM is prior to release 6
 VI%DEC==1B18
>;IFNDEC VI%DEC

; Program entry vector

ENTVEC:	JRST MMAILR		;START
	JRST MMAILR		;REENTER
	VI%DEC!<FLD MMLWHO,VI%WHO>!<FLD MMLVER,VI%MAJ>!<FLD MMLMIN,VI%MIN>!<FLD MMLEDT,VI%EDN>
FRKTAB:	PHASE 1
NEWFRK:!JRST MMLNLF		;Fork 1: First time deliver to local recipients
NETFRK:!JRST MMLNNF		;Fork 2: New network mail, fast scan
RXMFRK:!JRST MMLRXM		;Fork 3: Retransmitted mail, slow scan
	DEPHASE
NFRKS==.-FRKTAB			;Number of forks
ENTVCL==.-ENTVEC		;Length of entry vector

;;;Fork 1: First time delivery to local recipients
MMLNLF:	MOVEI A,NEWFRK		;Set logical fork number
	MOVEM A,FORKX
	SETOM NEWF		;Scan new mail
	SETZM NETF		;Don't deliver to network recipients
	SETZM RXMF		;Don't scan retransmit mail
	SETOM FSTF		;Cache dead hosts (doesn't matter here)
	SETOM DAEMNP		;We are the daemon
	SETOM WOPRP		;Also, we must have been WHEEL or OPERATOR
	JRST MAILR1		;Enter main program

;;;Fork 2: First time delivery to network recipients
MMLNNF:	MOVEI A,NETFRK		;Set logical fork number
	MOVEM A,FORKX
	SETZM NEWF		;Don't scan new mail
	SETOM NETF		;Deliver to network recipients
	SETZM RXMF		;Don't scan retransmit mail
	SETOM FSTF		;Cache dead hosts
	SETOM DAEMNP		;We are the daemon
	SETOM WOPRP		;Also, we must have been WHEEL or OPERATOR
	JRST MAILR1		;Enter main program

;;;Fork 3: Slow scan through the RETRANSMIT queue
MMLRXM:	MOVEI A,RXMFRK		;Set logical fork number
	MOVEM A,FORKX
	SETZM NEWF		;Don't scan new mail
	SETOM NETF		;Deliver to network recipients
	SETOM RXMF		;Scan retransmit mail
	SETZM FSTF		;Don't cache dead hosts
	SETOM DAEMNP		;We are the daemon
	SETOM WOPRP		;Also, we must have been WHEEL or OPERATOR
	JRST MAILR1		;Enter main program
;;;Mother fork start
MMAILR:	DO.
	  GTAD%			;a =: date/time
	  AOSE A		;Set yet?
	  IFSKP.
	    MOVEI A,^D5000	;No, wait 5 sec
	    DISMS%
	    LOOP.		;And try again
	  ENDIF.
	ENDDO.
	SETZM FORKX		;This is top fork
	SETOM NEWF		;Assume scan new mail
	SETOM NETF		;Assume deliver to network recipients
	SETOM RXMF		;Assume scan retransmit mail
	SETOM FSTF		;Assume cache dead hosts
	SETZM DAEMNP		;Assume not the Daemon
	SETOM PRINTP		;Assume print all messages
	JSP CX,INIT		;Init the world
	MOVX A,.FHSLF
	RPCAP%			;Get our capabilities
	IFXN. B,SC%WHL!SC%OPR	;WHEEL or OPERATOR?
	  SETOM WOPRP		;Yes, flag so
	  IOR C,B		;Enable everything we've got
	  EPCAP%
	  MOVX A,RC%EMO		;Now see if we're the Daemon (must be priv'd)
	  HRROI B,DAEDIR	;b =: dir Daemon runs out of
	  RCUSR%
	  MOVE T,C
	  GJINF%
DAEPAT:!	;;;Patch this location to NOP to force Daemon
	  CAMN A,T		;Are we logged in as the Daemon user?
	   SETOM DAEMNP		;Yes, we're the Daemon
	ENDIF.
	SKIPN DAEMNP		;Are we the daemon?
	 JRST MAILR2		;No - run main program

;;; Mother fork
	CALL WAKTOP		;Set up for passing on wakeup interrupts
	MOVSI X,-NFRKS		;Set up fork count
	DO.
	  MOVX A,CR%CAP		;Make an inferior fork, pass down capabilities
	  CFORK%
	  IFJER.
	    JFATAL <?Can't create MMailr daughter fork>
	    HALTF%		;Punt
	    JRST MMAILR		;Restart on CONTINUE
	  ENDIF.
	  MOVEM A,FHTAB(X)	;Save daughter's fork handle
	  SETZ T,		;Reset page index
	  DO.
	    MOVE A,T		;Get the page number
	    HRLI A,.FHSLF	;This fork
	    RMAP%		;Read page access
	    IFXN. B,RM%PEX	;Does page exist?
	      MOVE C,B		;Yes, get its access bits
	      ANDX C,RM%RD!RM%WR!RM%EX!RM%CPY ;Turn off unwanted bits
	      TXZE C,RM%WR	;Does this page have write access?
	       TXO C,RM%CPY	;Yes, set copy-on-write for daughters
	      MOVE A,T		;Get page number
	      HRLI A,.FHSLF	;This fork
	      MOVE B,T		;For destination also
	      HRL B,FHTAB(X)	;New fork handle
	      PMAP%		;Map the page
	    ENDIF.
	    CAIGE T,777		;At last page?
	     AOJA T,TOP.	;No so keep going
	  ENDDO.
	  MOVE A,FHTAB(X)	;Start daughter fork
	  MOVEI B,FRKTAB(X)	;At specified address
	  SFORK%
	  AOBJN X,TOP.		;Start next fork
	ENDDO.
	DO.
	  MOVSI X,-NFRKS	;Set up
	  DO.
	    MOVE A,FHTAB(X)	;Get fork handle
	    RFSTS%		;Check its status
	    LOAD A,RF%STS,A	;Not interested in PSI or frozen flag
	    CAIE A,.RFHLT	;If HALTF%, treat like blew up
	     CAIN A,.RFFPT	;Forced process termination?
	    IFNSK.
	      MOVEI A,1(X)	;Get fork index
	      CETYPE <Fork %1O halted at >
	      MOVEI T,-1(B)	;Get PC
	      CALL SYMOUT	;Output symbolically
	      MOVE A,FHTAB(X)	;Get fork handle
	      GETER%		;Get last error of this process
	      ETYPE <, last error: %2E, ...restarting
>
	      MOVE A,FHTAB(X)	;Get fork handle again
	      MOVEI B,CRASH	;Get it to dump and reboot
	      SFORK%
	    ENDIF.
	    AOBJN X,TOP.	;Otherwise looks good, try next
	  ENDDO.
	  MOVX A,^D<5*60*1000>	;Wait five minutes between checks
	  DISMS%
	  LOOP.
	ENDDO.
MAILR1:	JSP CX,INIT		;Initialize the world
	MOVX A,^D<2*60*1000>	;Wait two minutes for the network to stabilize
	DISMS%
MAILR2:	MOVEI A,.FHSLF		;Set up PSI
	MOVE B,[LEVTAB,,CHNTAB]
	SIR%
	EIR%
	MOVX B,1B0		;Set up for channel 0 to interrupt
	AIC%
	TMOCLR			;No time-out interrupts, please
;
; Place initial entries in our host table
;
	MOVEI A,HTBLSZ		;Maximum number of hosts we can handle at once
	MOVEM A,HSTTBL		;Init the table
	CALL INICNX		;Figure out the protocols we speak
	HRROI A,LCLNAM		;Try to get local host name for Internet
	CALL $GTLCL		;Get local host name
	 FATAL <Can't get local host name>
	MOVEI A,HSTTBL		;Add it to our host table
	MOVSI B,LCLNAM
	TBADD%
	MOVX B,HF%PRM		;Mark it permanent
	IORM B,(A)
	MOVEI A,ALCBLK		;Set up routines for use by relay code
	MOVEI B,PRMHST	
	CALL $INRLY		;Init relay tables
	MOVEM A,DOMTBL		;Save table of domains it made
	JSP CX,SETTIM		;Set the timer up
	SKIPE DAEMNP		;Are we the Daemon?
	IFSKP.
	  MOVEI A,.FHSLF	;No, set up ^G interrupt
	  MOVX B,1B1
	  AIC%
	  MOVE A,[.TICCG,,1]
	  ATI%
	  SETOM PRINTP		;Print all messages
	  GTAD%			;Log current date/time
	  MOVEM A,CURDTM
	  MOVE B,MYDIRN		;Get connected directory
	  CAMN B,MYLDIR		;Login same as connected?
	  IFSKP.
	    CALL DODIR		;Do connected first
	    CALL CRIF
	    MOVE B,MYLDIR	;Get login directory
	  ENDIF.
	  CALL DODIR		;Do login
	  HALTF%
	  JRST MMAILR		;Restart totally if continue
	ENDIF.

; falls through
	SUBTTL Background operator task

; drops in

	SETZM PRINTP		;Don't print detailed logs
	SKIPE DEBUGP		;Unless debugging
	 SETOM PRINTP		;Want detailed logs
	MOVX A,RC%EMO		;No MAILQ:, use SYSTEM:
	HRROI B,[ASCIZ/SYSTEM:/]
	RCDIR%
	TXNE A,RC%NOM!RC%AMB	;Anything go wrong?
	 SETZ C,		;This shouldn't happen
	MOVEM C,SYSDIR		;Save SYSTEM: directory
	MOVX A,RC%EMO		;Look up MAILQ:
	HRROI B,[ASCIZ/MAILQ:/]
	RCDIR%
	TXNE A,RC%NOM!RC%AMB	;Anything go wrong?
	 MOVE C,SYSDIR		;Yes, use SYSTEM: directory instead
	MOVEM C,MLQDIR		;Set directory to check every time
	MOVEI A,.FHSLF
	SETOB C,B
	EPCAP%
	CALL MAPFLG		;Map in the mailer flags
	 JWARN <Failed to map MAILER flags>

; falls through
; drops in

;;;This is the main daemon loop

	DO.
	  SKIPN LOGP		;Should make logs?
	  IFSKP.		;Yes
	    SETOM PRINTP	;Want details
	    DO.
	      MOVE A,[POINT 7,STRBUF]
	      MOVEI B,[ASCIZ/MAIL:/]
	      CALL MOVSTR
	      MOVE B,FORKX	;Fork handle
	      MOVX C,^D8
	      NOUT%
	       JFATAL
	      MOVEI B,[ASCIZ/-MMAILR.LOG/]
	      CALL MOVST0
	      HRROI B,STRBUF
	      MOVX A,GJ%SHT
	      GTJFN%
	      IFJER.
		CAIE A,GJFX24	;Work around monitor bug
		 JWARN <Cannot get LOG file>
		MOVX A,^D5000	;Wait 5 seconds
		DISMS%
		LOOP.
	      ENDIF.
	      MOVEM A,LOGJFN
	      MOVX B,<<FLD ^D7,OF%BSZ>!OF%APP>
	      OPENF%
	      IFJER.
		PUSH P,A	;Save error code
		MOVE A,LOGJFN	;Recover JFN
		RLJFN%		;Release it
		 JWARN
		SETZM LOGJFN	;Clear log JFN
		MOVX A,^D5000	;Wait a few seconds
		DISMS%
		POP P,A		;Recover error code
		CAIN A,OPNX9	;No error if file just busy
		 LOOP.
		CAIE A,OPNX2	;File disappeared?
		 WARN <Cannot open log file - %1E>
		LOOP.
	      ENDIF.
	    ENDDO.
	    MOVEI B,(A)		;B := Nul,,log
	    HRLI B,.NULIO
	    MOVX A,.FHSLF	;Set primary JFNs for this fork
	    SPJFN%
	  ENDIF.
	  SKIPN STATP		;Taking statistics?
	  IFSKP.
	    DO.
	      MOVE A,[POINT 7,STRBUF]
	      MOVEI B,[ASCIZ/MAIL:/]
	      CALL MOVSTR
	      MOVE B,FORKX	;Fork handle
	      MOVX C,^D8
	      NOUT%
	       JFATAL
	      MOVEI B,[ASCIZ/-MMAILR.STAT/]
	      CALL MOVST0
	      HRROI B,STRBUF
	      MOVX A,GJ%SHT
	      GTJFN%
	      IFJER.
		CAIE A,GJFX24	;Work around monitor bug
		 JWARN <Cannot get STAT file>
		MOVX A,^D5000	;Wait 5 seconds
		DISMS%
		LOOP.
	      ENDIF.
	      MOVEM A,STAJFN
	      MOVX B,<<FLD ^D7,OF%BSZ>!OF%APP>
	      OPENF%
	      IFJER.
		PUSH P,A	;Save error code
		MOVE A,STAJFN	;Recover JFN
		RLJFN%		;Release it
		 JWARN
		SETZM STAJFN	;Clear STAT JFN
		MOVEI A,^D5000	;Wait a few seconds
		DISMS%
		POP P,A		;Recover error code
		CAIN A,OPNX9	;No error if file just busy
		 LOOP.
		CAIE A,OPNX2	;File disappeared?
		 WARN <Cannot open STAT file - %1E>
		LOOP.
	      ENDIF.
	    ENDDO.
	  ENDIF.

; falls through
; drops in

	  CITYPE <Daemon wakeup>
	  CALL NDHOST		;Clear dead host list
	  AOSE TIMKIL		;If clock got killed restart it
	   JSP CX,SETTIM
	  CALL WAKINI		;Set up wakeup interrupt
	  SKIPE A,FORKX		;Initialize IPCF if fork 0 (single fork) or
	   CAIN A,1		; fork 1 (first time requests).  This is here
	    CALL IPCINI		; so we retry every scan if failed
	  SKIPN IPCFON		;IPCF on?
	  IFSKP.
	    JSP C,IPCHEK	;Yes, check the queue
	    IFSKP.
	      CIETYP <Clearing IPCF queue...> ;Log this
	      MOVEI A,.FHSLF	;Now fake an IPCF delivery
	      MOVX B,1B<IPCHAN>
	      IIC%
	    ENDIF.
	  ENDIF.
	  GTAD%			;Log current date/time
	  MOVEM A,CURDTM
	  TIME%			;Get time
	  SKIPN RXMF		;Scanning retransmit files?
	  IFSKP.
	    ADD A,RXMINT	;Yes, wait longer between wakeups
	  ELSE.
	    ADD A,SCNINT	;Normal scan interval
	  ENDIF.
	  MOVEM A,SCNTIM	;Set time to scan again

; falls through
; drops in

	  SKIPL MFLAGP		;Have mailer flags to do?
	  IFSKP.
	    MOVSI A,-1000
	    DO.
	      SKIPN B,FLGPAG(A)	;Find a word with bit set
	      IFSKP.
		DO.
		  JFFO B,.+2	;Get bit position
		   EXIT.	;Last bit in this word
		  PUSH P,A	;Found a directory, do it
		  PUSH P,B
		  MOVNI D,(C)	;Negative bit number
		  MOVX B,1B0
		  LSH B,(D)	;Make bit to clear
		  ANDCAM B,FLGPAG(A) ;Clear it in flag page
		  ANDCAM B,(P)	;And in saved word
		  MOVEI B,(A)
		  IMULI B,^D36
		  ADDI B,(C)	;Compute directory to do
		  HLL B,MYLDIR
		  CAME B,MLQDIR	;We'll do MAILQ: below
		   CAMN B,SYSDIR ;Ditto SYSTEM:
		    CAIA
		     CALL DODIR
		  POP P,B
		  POP P,A
		  LOOP.
		ENDDO.
	      ENDIF.
	      AOBJN A,TOP.
	    ENDDO.
	  ENDIF.

; falls through
; drops in

	  SKIPN B,MLQDIR	;Scan the MAILQ: directory
	  IFSKP.
	    CALL DODIRX
	    MOVX A,DD%DTF+DD%DNF ;Deleting ;T and non-existent files
	    MOVE B,MLQDIR	;Now, expunge the directory
	    DELDF%
	    IFJER.
	      JWARN <Expunging MAILQ: failed>
	    ENDIF.
	  ENDIF.
	  SKIPE B,SYSDIR	;Scan the SYSTEM: directory
	   CAMN B,MLQDIR	;Only if it is different from MAILQ:
	   IFSKP.
	     CALL DODIRX	;It is, scan it
	     MOVX A,DD%DTF+DD%DNF ;Deleting ;T and non-existent files
	     MOVE B,SYSDIR	;Now, expunge the directory
	     DELDF%
	     IFJER.
	       JWARN <Expunging SYSTEM: failed>
	     ENDIF.
	   ENDIF.
	  MOVX A,.FHSLF		;Restore primaries
	  SETO B,
	  SPJFN%
	  SKIPN A,LOGJFN	;Close log file
	  IFSKP.
	    CLOSF%
	     JFATAL <Unable to close log file>
	    SETZM LOGJFN
	  ENDIF.
	  SKIPN A,STAJFN	;Close statistics file
	  IFSKP.
	    CLOSF%
	     JFATAL <Unable to close STAT file>
	    SETZM STAJFN
	  ENDIF.
	  TIME%			;Current time
	  EXCH A,SCNTIM		;Time to do scan
	  SUB A,SCNTIM
	  IFG. A		;Sleep only if time left in this interval
	    SKIPN RXMF		;Scanning retransmit files?
	    IFSKP.
	      CAMLE A,RXMINT	;Paranoia
	       MOVE A,RXMINT
	    ELSE.
	      CAMLE A,SCNINT	;Paranoia
	       MOVE A,SCNINT
	    ENDIF.
	    SETOM TIMKIL	;Kill the clock
	    SETOM IPCFOK	;Indicate IPCF interrupts are OK to grant
	    SKIPN NOSLEP	;Okay to sleep?
	     DISMS%
	      NOP		;In case of interrupts
	    SETZM IPCFOK	;Indicate IPCF interrupts not allowed
	    SETZM NOSLEP	;Allowed to DISMS% now
	  ENDIF.
	  LOOP.
	ENDDO.
; Here to process files in a directory
DODIR:	CIETYP <Trying %2U...>
DODIRX:	MOVEM B,DIRNUM		;Save directory number
	MOVE A,[-NFTBL,,FILTBL]	;Init file type index
	SETZM DODJFN		;Initially no current group JFN
	DO.			;For each group
	  SKIPE DODJFN		;Have a current JFN defined?
	  IFSKP.		;No current JFN defined
	    MOVEM A,FILIDX	;Save file flags index
	    HRROI A,STRBUF	;Build filename here
	    MOVE B,DIRNUM	;Start with desired directory
	    DIRST%
	     ERJMP ENDLP.	;No such directory, can't do anything
	    MOVE B,FILIDX	;b =: ptr to current file type string
	    HLRZ B,%FLSTR(B)
	    CALL MOVST0
	    MOVE A,[GJ%IFG!GJ%OLD!GJ%SHT+.GJALL]
	    HRROI B,STRBUF
	    GTJFN%		;See if file group found
	    IFNJE.
	      MOVEM A,DODJFN	;Save JFN
	      DO.
		MOVE A,FILIDX	;Get pointer to file type string
		MOVE A,%FLFLG(A) ;Get flags for this group
		IFXN. A,FF%NEW	;Is this a new file?
		  SKIPE NEWF	;Allowed to do new files?
		   EXIT.	;Yes, do it
		ELSE.		;Not new file
		  SKIPN NETF	;Allowed to do network I/O?
		  IFSKP.	;Network I/O ok
		    IFXN. A,FF%RXM ;Is this a retransmit file?
		      SKIPE RXMF ;Allowed to do retransmit files?
		       EXIT.	;Yes, do it
		    ELSE.	;Not retransmit file, assume 1st time net file
		      SKIPE FSTF ;Doing fast 1st time net mail delivery?
		       EXIT.	;Yes, do it
		    ENDIF.	;End retransmit file test
		  ENDIF.	;End network I/O okay
		ENDIF.		;End test of group type
		CALL MAIFLG	;Not allowed to do it, make sure mailer knows
		HRRZ A,DODJFN	;Now flush this JFN
		RLJFN%
		 NOP
		SETZM DODJFN	;Don't try to do this group
	      ENDDO.		;End validate need to do this group
	    ENDIF.		;End found files matching this group
	  ENDIF.		;End no current JFN defined
	  SKIPN A,DODJFN	;Current JFN defined
	  IFSKP.		;Process current file for this JFN
	    DO.
	      HRRZS A
	      CALL GETQUE
	       JRST [TYPE <...queue map failed...requeued>
		     CALL MAIFLG ;Make sure mailer knows
		     EXIT.]
	       JRST [TYPE <...bad file format>
		     CALL MAIFLG ;Make sure mailer knows
		     EXIT.]
	      SETZM NTDEQF	;Clear dequeue flag
	      MOVE B,FILIDX	;Notify sender about this file type?
	      MOVE B,%FLFLG(B)
	      IFXE. B,FF%XNT
		SKIPN A,MSGNTF(M) ;Sender notify time given?
		IFSKP.
		  CAMGE A,CURDTM ;Yes, time to squawk if undeliverable?
		   AOS NTDEQF	;Yes, flag to send notification
		ENDIF.
	      ENDIF.
	      SKIPN A,MSGDEQ(M)	;Dequeue time given?
	      IFSKP.
		CAML A,MSGAFT(M) ;Yes, dequeue time before after time?
		IFSKP.
		  MOVE A,MSGAFT(M) ;Yes, don't be absurd!  Use after time
		  CAMG A,CURDTM	;Unless it's before now
		   MOVE A,CURDTM ;In which case we'll use the time now
		  ADD A,MAXQUE	;Plus interval
		  MOVEM A,MSGDEQ(M) ;Set corrected dequeue time
		ENDIF.
		CAMGE A,CURDTM	;Time to dequeue this file?
		 SETOM NTDEQF	;One more try, then dequeue failures
	      ENDIF.
	      CALL FWDLCL
	      MOVE A,MSGAFT(M)	;Get after parameter, if any
	      CAMLE A,CURDTM	;Time to do this message yet?
	      IFSKP.
		PUSH P,MSGTMT(M) ;Yes, no overall time limits on locals
		SETZM MSGTMT(M)
		CALL SNDLCL	;Always try local recipients
		IFNSK.
		  ADJSP P,-1	;Reset stack
		  TYPE <...bad file format>
		  CALL MAIFLG	;Make sure mailer knows
		  EXIT.
		ENDIF.
		POP P,MSGTMT(M)	;Restore global delivery timeout
		CALL SNDMSG	;Deliver the message
		IFNSK.
		  TYPE <...bad file format>
		  CALL MAIFLG	;Make sure mailer knows
		  EXIT.
		ENDIF.
		SKIPE NETF	;If no net sends hold off on this
		 SETZM MSGDOP(M) ;Next time use MAIL to deliver this message
	      ELSE.
		CIETYP < Processing of recipients deferred until %1T>
		MOVEI A,MSGLCL(M) ;Pointer to local mail
		DO.		;Flag "temporary" failure to fake out REMAIL
		  HRRZ B,(A)
		  IFN. B
		    MOVX C,FR%TMP
		    IORM C,RCPFLG(B)
		    MOVEI A,(B)
		    LOOP.
		  ENDIF.
		ENDDO.
	      ENDIF.
	      CALL REMAIL	;Requeue or send failure
	      CALL RELQUE
	      CITYPE < Done, >
	      SKIPN REQJFN	;Was something requeued?
	      IFSKP.
		TYPE <requeued>
		CALL MAIFLG	;Make sure mailer knows
		MOVE A,FILIDX	;Was the file renamed too?
		MOVE A,%FLFLG(A)
		IFXN. A,FF%RNM!FF%OML
		  HRRZ A,DODJFN	;Yes.  GNJFN% fails if current file renamed
		  RLJFN%	;Release this jfn
		   JWARN
		  SETZM DODJFN
		  MOVE A,FILIDX	;Get current group
		  ADJSP A,-1	;Back up group so iteration redos this one
		  SUBI A,%FLLEN-1
		  MOVEM A,FILIDX ;Now store it
		ENDIF.
	      ELSE.
		TYPE <deleting>
		HRRZ A,DODJFN
		TXO A,DF%NRJ
		DELF%
		 JWARN <DELETE failed>
	      ENDIF.
	      CALL HSTCLR	;Clean up the host table
	    ENDDO.
	  ENDIF.		;End processing for this file
	  SKIPN A,DODJFN	;Get JFN back
	  IFSKP.
	    GNJFN%		;See if another file in this group
	    IFNJE.
	      LOOP.		;Another file, do it
	    ENDIF.
	    SETZM DODJFN	;No more JFNs in this group
	  ENDIF.
	  MOVE A,FILIDX		;a =: current file type index
	  ADDI A,%FLLEN-1	;Step to next one
	  AOBJN A,TOP.		;And do next group if more to do
	  ENDDO.		;End of per-group processing
	RET
INIT:	RESET%			;Flush all I/O
	MOVE P,[IOWD NPDL,PDL]	;Establish stack
	SETZB F,MEMBEG		;Clear out impure storage
	MOVE A,[MEMBEG,,MEMBEG+1]
	BLT A,MEMEND
	SETOM INUUO		;Init recursive UUO flag
	GJINF%
	MOVEM A,MYUSRN		;Save user number
	MOVEM B,MYDIRN		;Save connected directory number
	MOVEM C,MYJOBN		;Save job number
	SETZ A,			;Get login directory
	MOVE B,MYUSRN		;My user number
	RCDIR%
	MOVEM C,MYLDIR		;My logged-in directory
	HRROI A,[ASCIZ/POBOX:/]	;Get post office box structure
	STDEV%
	IFJER.
	  HRROI A,STRBUF	;Failed, get logged-in directory string
	  MOVE B,MYLDIR		;From logged-in directory
	  DIRST%
	   JFATAL
	  HRROI A,STRBUF	;Now get its device designator
	  STDEV%
	   JFATAL
	  DEVST%		;Now get just its device name
	   JFATAL
	  MOVX B,":"		;Append the device delimiter
	  IDPB B,A
	  SETZ B,		;Now null-terminate it
	  IDPB B,A
	  MOVX A,.CLNSY		;Create systemwide logical name
	  HRROI B,[ASCIZ/POBOX/] ; for POBOX:
	  HRROI C,STRBUF	;From login structure
	  CIETYP <[POBOX: not found, defining as %3W]
>
	  CRLNM%
	   JFATAL
	ENDIF.
	JRST (CX)
	SUBTTL Get atom from file routine

;;; Read atom into string buffer in C, from open JFN in A.
;;; Always pads to word boundaries, uppercasing.
FILATM:	BIN%
	 ERJMP FILAT1		;Done on EOF
	JUMPE B,FILAT1		; or on NUL
	CAIE B,.CHLFD		; or LF
	 CAIN B,.CHSPC		; or space
	  JRST FILAT1
	CAIN B,.CHCRT		; or CR
	 JRST FILAT3
	CAIL B,"a"
	 CAILE B,"z"
	  CAIA
	   SUBI B,"a"-"A"
	IDPB B,C		;Else, add it
	JRST FILATM

FILAT3:	BIN%			;CR, flush LF too
FILAT1:	SETZ B,			;Tie off local name
FILAT2:	IDPB B,C
	TXNE C,76B4
	 JRST FILAT2
	RET
; Routine to scan the possible sending routines, and remove
; those that the monitor doesn't know about.
; Create a protocol table for later use in mail sending
;
; Return:  +1

INICNX:	MOVX T,<-NSNDRS,,SNDRT0> ;Number of possible sending routines
	MOVEI TT,SNDRTS		;Table of allowed sending routines
	DO.
	  HRRO A,(T)		;a := ptr to dev name for this net
	  STDEV%		;Local system know about it?
	  IFNJE.
	    HLRZ A,(T)		;Get the data address
	    MOVE A,(A)		;And the data
	    MOVEM A,(TT)	;Save
	    AOS TT		;Increment table
	  ENDIF.
	  AOBJN T,TOP.
	ENDDO.
	SETZM (TT)		;End of table marker
	RET			;Yes
	SUBTTL Memory allocation

;;; Bit table hacking, page number in A for all
PAGSBT:	PUSH P,[IORM B,(A)]	;Set bit
	JRST PAGHBT

PAGCBT:	PUSH P,[ANDCAM B,(A)]	;Clear bit
	JRST PAGHBT

PAGTBT:	PUSH P,[TDNE B,(A)]	;Skip if bit clear
PAGHBT:	PUSH P,A
	PUSH P,B
	SUBI A,FSPAG		;Make relative to start of bit table
	IDIVI A,^D36
	MOVEI A,PAGTBL(A)	;Point to right word
	MOVE B,BITS(B)		;Get right bit
	XCT -2(P)
	 SKIPA
	  AOS -3(P)
	POP P,B
	POP P,A
	ADJSP P,-1
	RET

;;; Allocate number of pages in A, returns +1 failure, +2 page number in B
PAGAL1:	MOVEI A,1		;Allocate one page
PAGALC:	PUSH P,C
	PUSH P,A		;Save number of pages we need
	MOVEI B,FSPAG		;Starting free page
PAGALB:	CALL PAGFFP		;Fast search for first free page
	 JRST POPACJ		;Failure, just return
	MOVEI A,1(B)
	MOVE C,(P)		;Get number of pages to hack again
PAGALL:	SOJLE C,PAGALW		;Got enough, return address from b
	CAIL A,1000		;Page number too big?
	 JRST POPACJ		;Yes, fail
	CALL PAGTBT		;Is this bit set?
	IFNSK.
	  MOVEI B,1(A)		;Try for next free page
	  JRST PAGALB
	ENDIF.
	AOJA A,PAGALL		;Try for next match
PAGALW:	MOVE C,(P)
	MOVEI A,(B)
PAGAW1:	CALL PAGSBT		;Allocate one page
	SOJLE C,POPAC1
	AOJA A,PAGAW1
POPAC1:	AOS -2(P)		;Winning return
POPACJ:	POP P,A
	POP P,C
	RET
;;; Deallocate pages, number in A, starting page in B
PAGDA1:	MOVEI A,1		;Deallocate one page
PAGDAL:	PUSH P,A
	PUSH P,B
	PUSH P,C
	EXCH A,B		;Setup for page number in A
PAGDA2:	SOJL B,PAGDA3
	CALL PAGCBT		;Clear one bit
	AOJA A,PAGDA2
PAGDA3:	SETO A,
	MOVE B,-1(P)		;Starting page
	HRLI B,.FHSLF
	HRRZ C,-2(P)		;Count
	TXO C,PM%CNT
	PMAP%			;Flush those pages
	POP P,C
POPBAJ:	POP P,B
CPOPAJ:	POP P,A
	RET

;;; Fast search for the first free bit, starting page in B
;;; Returns +1 failure, +2 with page number in B
PAGFFP:	SUBI B,FSPAG		;Make relative to start of bit table
	IDIVI B,^D36
	SETCM A,PAGTBL(B)	;Get first word to check
	LSH A,(C)
	MOVNI C,(C)
	LSH A,(C)		;Clear out random bits to left
	SKIPA C,B		;Starting word index
PAGFF1:	 SETCM A,PAGTBL(C)	;Get word to check
	JFFO A,PAGFF2		;Got any ones?
	CAIL C,PGTBLL		;No - beyond last word?
	 RET			;Failed
	AOJA C,PAGFF1		;No, search for next word
PAGFF2:	IMULI C,^D36		;Number of bits passed
	ADDI B,FSPAG(C)		;Final winning page number
	CAIL B,1000		;Was page valid?
	 RET			;No
	RETSKP
; Routine to unmap memory buffer pages currently in use
; Entry:   pagtbl = bitmap for pages in use
; Call:    CALL CLRPTB
; Return:  +1
CLRPTB:	SETO A,			;Unmap special prebuffer pages
	MOVSI B,.FHSLF
	SETZ C,
	HRRI B,<FLGPAG/1000>	;Do FLAGS page
	PMAP%
	HRRI B,<TMPBUF/1000>	;Do MMAILBOX buffer page
	MOVX C,PM%CNT!2		;Unmap both temp pages
	PMAP%
	HRRI B,<FWDWIN/1000>
	PMAP%
	MOVSI T,-PGTBLL		;t =: aobjn ptr to PAGTBL
CLRPT0:	SKIPE A,PAGTBL(T)	;Any bits in this entry?
	 JFFO A,CLRPT1		;Yes, scan for 1st one
	AOBJN T,CLRPT0		;No more, try next word
	RET			;Done

; Here to unmap a page flagged in PAGTBL
; Entry:   t = ptr to PAGTBL word for page
;	   b = count of flag bit position for page
CLRPT1:	MOVEI C,0(T)		;c =: PAGTBL word index
	IMULI C,^D36		;c =: page count for prior wds in table
	ADDI B,FSPAG(C)		;b =: memory page number
	CAIL B,1000		;Legal page?
	 FATAL <CLRPTB: Invalid page table bit set>
	CALL PAGDA1		;Deallocate this page
	JRST CLRPT0		;Look for more to do
;;; Map in a file, given name in B,
;;; Returns +1 failure, +2 success, starting address in B,
;;; number of bytes in C, start,,count in D
MAPQFL:	PUSH P,[OF%RD!OF%WR!OF%PDT]
	SKIPA			;Try for write too first, save dates for queue
MAPFIL:	 PUSH P,[OF%RD]		;Normally try just read
	MOVX A,GJ%OLD!GJ%SHT
	GTJFN%
	IFJER.
	  ADJSP P,-1
	  RET
	ENDIF.
	CIETYP < File %1J:>
	MOVE B,(P)		;Get OPENF% flags
	PUSH P,A		;Save the jfn
	OPENF%
	 ERJMP MPFLOE
MAPFL1:	SIZEF%
	 ERJMP MPFLE1
	PUSH P,B		;Save number of bytes
	MOVEI A,(C)		;Number of pages needed for whole file
	CALL PAGALC		;Allocate them
	IFNSK.
	  MOVE B,-2(P)		;Get starting OPENF% bits
	  TXNN B,OF%PDT		;From MAPQFL call?
	   JRST MAPFLE		;No, just fail return
	  JRST MAPQFE		;Make "Bad Mail" file
	ENDIF.
	HRLZ A,-1(P)		;Start with page 0 of file
	HRLI B,.FHSLF
	HRLI C,(PM%CNT!PM%RD!PM%CPY)
	PMAP%
	 ERJMP MAPFLE
	HRLI C,(B)
	MOVS D,C		;Count,,start
	LSH B,9			;Make page number into address
	POP P,C			;Count of bytes
	POP P,-1(P)		;Move the jfn down on the stack
POPA1J:	POP P,A
	RETSKP

;; Here on error mapping file
MAPFLE:	ADJSP P,-1		;Clear byte count
MPFLE1:	POP P,A			;Recover JFN
	CLOSF%
	 JWARN
	ADJSP P,-1		;Clear OPENF% bits
	RET

;; Here when mail file is too big.  C = # of pages
MAPQFE:	ADJSP P,-1		;Clear byte count
	POP P,A			;Recover JFN
	ADJSP P,-1		;Clear OPENF% bits
	MOVE B,DIRNUM		;Directory number
	WARN <MAPQFL: %2U%1J too big - %4D pgs.>
	TXO A,CO%NRJ		;Close it but keep the JFN
	CLOSF%
	 JFATAL
	HRRZS A			;Just JFN again
	CALL RENBAX		;Rename to bad mail file
	MOVEI B,STRBUF		;Ptr to name of new file
	WARN <	Renamed to %2W>
	RET

;; Here if OPENF% fails for file
MPFLOE:	CAIE A,OPNX9		;If not invalid simultaneous access
	 TXNN B,OF%WR		;And asking for write
	  JRST MPFOE1
	MOVE A,(P)		;Try once more
	MOVEI B,OF%RD		;With just read
	OPENF%
	 ERJMP MPFOE1
	JRST MAPFL1		;Succeeded this way, use it

MPFOE1:	POP P,A
	RLJFN%
	 JWARN
	ADJSP P,-1		;Clear OPENF% bits
	RET
;;; Free storage
;;; Format of free list is FREHDR,,forward-link ? size,,backward-link ...
;;;  ... FRETAI,,0
;;; format of allocated entry is ALCHDR,,size ? ... ? ALCTAI,,0
FREHDR==<SIXBIT /   FRE/>
FRETAI==<SIXBIT /   ERF/>
ALCHDR==<SIXBIT /   ALC/>
ALCTAI==<SIXBIT /   CLA/>

;;; Routine to check the integrity of a free space block.  Requires the
;;; header and tail to match and the tail to point to the header
; Entry:   b = adr of block to check
; Call:    CALL CHKBLK
; Return:  +1, block format is bad
;	   +2, format OK - allocated block
;	   +3, format OK - free block
CHKBLK:	HLRZ T,(B)		;t =: block header type
	CAIN T,FREHDR		;Free block?
	 JRST CHKBLF		;Yes, check the rest
	CAIE T,ALCHDR		;Allocated block?
	 RET			;No???
	HRRZ T,0(B)		;t =: size of allocated block
	ADDI T,1(B)		;t =: adr of tail word
	HLRZ TT,0(T)		;tt =: block tail type
	HRRZ T,0(T)		;t =: ptr to head
	CAIN TT,ALCTAI		;Allocated block tail?
	 CAIE T,0(B)		;And ptr really to head of block?
	  RET			;No???
	RETSKP			;Good allocated block, return +2

;;; Here to check out a free block tail
CHKBLF:	HLRZ T,1(B)		;t =: size of free block
	ADDI T,1(B)		;t =: adr of tail word
	HLRZ TT,0(T)		;tt =: block tail type
	HRRZ T,0(T)		;t =: ptr to head
	CAIN TT,FRETAI		;Free block tail?
	 CAIE T,0(B)		;And ptr really to head of block?
	  RET			;No???
R2SKP:	AOS (P)			;Do one skip
	JRST RSKP		;and then a normal skip return
;;; Allocate a block, given size in A,
;;; Returns +1 failure, +2 address of block in B, real size in A
ALCBLK:	JSR SAVACS		;Save all ACs
	CAIGE A,5		;Minimum size
	 MOVEI A,5
	MOVEI C,FREPTR		;Start by pointing to free list
ALCBLL:	HRRZ B,(C)		;Get link word
	JUMPE B,ALCBPG		;End of list, need a whole new page
	HLRZ D,1(B)		;Size of free block
	CAIL D,(A)		;Large enough?
	 JRST ALCBLF		;Yes, found winner
	MOVEI C,(B)		;Too small, setup to try next one
	JRST ALCBLL

;; Now have block in B, previous in C, size in D, user's size still in A
ALCBLF:	CALL CHKBLK		;Check block integrity
	 NOP					;+1, block type bad
	 FATAL <ALCBLK: Free list screwed up>	;+2, allocated block
	CAIG D,5(A)		;Size close enough to desired?
	 JRST ALCBLR		;Yes, no need to split
	MOVEI E,(B)		;Get copy of address of block
	HRLM A,1(B)		;Store new size of block to be returned
	ADDI E,2(A)		;Address of start of other block
	HRRZ T,(B)		;Old forward link
	HRRM E,(B)		;Second is forward link for first one
	IFE. T
	  HRLM E,FREPTR
	ELSE.
	  HRRM E,1(T)
	ENDIF.
	HRLI T,FREHDR
	MOVEM T,(E)		;Old forward is forward link of second block
	MOVSI T,FRETAI
	HRRI T,(B)
	MOVEM T,-1(E)		;Store end of first block
	SUBI D,2(A)		;New size of rest of block
	EXCH D,A		;D should have size of block we are returning
	HRLI A,(B)
	MOVSM A,1(E)		;Backward link of second block is first block
	ADDI A,1(E)
	HRRM E,(A)		;Update pointer to start of block
ALCBLR:	HRRZ T,(B)		;Forward link of this block
	HRRM T,(C)		;Becomes forward link of our backward link
	IFE. T
	  HRLM C,FREPTR
	ELSE.
	  HRRM C,1(T)		;Its backward link is our former backward link
	ENDIF.
	MOVEM D,A-ACBASE(P)	;Return real size in A
	MOVSI T,ALCHDR
	HRRI T,(D)
	MOVEM T,(B)
	ADDI B,1		;User should see block, not header
	MOVEM B,B-ACBASE(P)	;Return address in B
	MOVSI A,0(B)		;Compose BLT pointer to clear block
	HRRI A,1(B)
	SETZM 0(B)		;Clear first word
	ADDI B,(D)		;Address of end
	CAIL D,2		;If multiple words,
	 BLT A,-1(B)		; clear rest of block
	MOVEI T,ALCTAI
	HRLM T,(B)		;Mark end as used too
	RETSKP			;Skip return

;; Need to allocate a whole other page
ALCBPG:	PUSH P,A		;Save desired size
	ADDI A,1003		;Round to page and have room for headers
	LSH A,-9		;Get number of pages needed
	CALL PAGALC		;Get that many
	 JRST CPOPAJ		;Failed, return failure to whole thing
	LSH B,9			;Make address out of it
	HRRM B,(C)		;Link onto end of list
	HRLM B,FREPTR		;And save end of free list
	MOVSI T,FREHDR		;Setup header of block and forward link
	MOVEM T,(B)
	LSH A,9			;Number of words we asked for
	MOVEI D,-2(A)		;This is the created size
	HRLM D,1(B)		;Store it
	HRRM C,1(B)		;Store backward link
	ADDI A,-1(B)		;End of page
	MOVSI T,FRETAI
	HRRI T,(B)
	MOVEM T,(A)		;Mark end of block
	POP P,A			;Get back size user requested
	JRST ALCBLF		;Go return this one
;;; Deallocate a block, address in B
FREBLK:	JSR SAVACS		;Save all ACs
	SETO X,			;Flag if link into list someway
	SUBI B,1		;Point to real block
	CALL CHKBLK		;Check block integrity
	 SKIPA			;+1, block type bad
	  SKIPA			;+2, good allocated block
	   FATAL <FREBLK: Attempt to deallocate bad block>  ;+3, free blk
	HRRZ A,(B)		;Get size of block
	HLRZ T,-1(B)		;End of previous block, maybe
	CAIE T,FRETAI		;Check for free entry
	IFSKP.
	  MOVE C,-1(B)		;Yes, get start of block then
	  PUSH P,B		;Save input block adr
	  HRRZ B,C		;b =: ptr to preceding free block
	  CALL CHKBLK		;Check its integrity
	   NOP				     	      ;+1, Bad block
	   FATAL <FREBLK: Prior free blk screwed up>  ;+2, Allocated block
	  POP P,B
	  HLRZ D,1(C)		;Get size of previous block
	  ADDI A,2		;Freeing headers
	  ADDB D,A		;Get new total size
	  HRLM D,1(C)		;Store that
	  ADDI D,1(C)		;End of new big block
	  MOVEM C,(D)		;Store tail there
	  MOVEI B,(C)		;This is the block to use now
	  ADDI X,1
	ENDIF.
	MOVEI C,(A)
	ADDI C,2(B)		;Address of start of next block, maybe
	HLRZ T,(C)
	CAIE T,FREHDR		;Is it?
	 JRST FREBL3		;No
	PUSH P,B		;Save input block adr
	HRRZ B,C		;b =: ptr to preceding free block
	CALL CHKBLK		;Check its integrity
	 NOP				     	     ;+1, Bad block
	 FATAL <FREBLK: Next free blk screwed up>  ;+2, Allocated block
	POP P,B
	AOJE X,FREBL2		;Was it linked to previous?
	HRRZ D,(C)		;Forward link of block
	HRRZ E,1(C)		;Backward link
	IFE. E
	  HRRM D,FREPTR
	ELSE.
	  HRRM D,(E)		;Splice out this entry since already there
	ENDIF.
	IFE. D
	  HRLM E,FREPTR
	ELSE.
	  HRRM E,1(D)		;Backward link
	ENDIF.
	HLRZ D,1(C)		;Get size of block
	ADDI A,2
	ADDB D,A
	HRLM D,1(B)		;Update size
	ADDI D,1(B)		;End of new big block
	HRRM B,(D)		;Store correct starting address
	JRST FREBLR		;That's all there is to it

FREBL2:	DMOVE T,(C)		;Start of second block
	HLRZ D,TT		;Size of block
	ADDI A,2(D)
	HRL TT,A		;Update total size
	DMOVEM T,(B)		;Store as start of this entry
	TXNN TT,.RHALF
	 HRRI TT,FREPTR
	HRRM B,(TT)		;Update forward link of backward link
	IFXE. T,.RHALF
	  HRLM B,FREPTR
	ELSE.
	  HRRM B,1(T)		;And vice versa
	ENDIF.
	ADDI C,1(D)		;End of large block
	HRRM B,(C)		;Store pointer to start
FREBL3:	IFL. X			;Already linked in?
	  HRLZM A,1(B)		;Clear backward link, store size
	  HRRZ T,FREPTR		;Old beginning of free list
	  HRRM T,(B)
	  IFE. T
	    HRLM B,FREPTR
	  ELSE.
	    HRRM B,1(T)		;Update backward link of old beginning
	  ENDIF.
	  HRRM B,FREPTR		;New beginning
	ENDIF.
FREBLR:	MOVEI T,FREHDR		;Free header
	HRLM T,(B)
	ADDI A,1(B)		;End of block
	MOVEI B,FRETAI
	HRLM B,(A)		;Free tail
	RET			;Return
;;; Make a block bigger, address of block in B, length in A
;;; Returns with new address and length
GROBLK:	JSR SAVACS
	HLRZ T,-1(B)		;t =: old block header
	CAILE A,0		;New length reasonable?
	 CAIE T,ALCHDR		;Old block type right?
	  FATAL <Attempt to grow bad block>
;;;*** This should try to steal from next block ***
	CALL ALCBLK		;Get a new block
	 RET
	DMOVE T,A		;Save new results
	EXCH A,A-ACBASE(P)	;This is what we return
	EXCH B,B-ACBASE(P)
	HRLI TT,(B)		;Old,,new
	ADDI T,(TT)		;End of new block
	BLT TT,-1(T)		;Transfer data into new block
	CALL FREBLK		;Release the old block now
	RETSKP
;;; Set the bit for a particular directory
MAIFLG:	HLLZ A,DIRNUM		;Get str #
	HLLZ B,MYLDIR		;Compare with login str #
	CAMN A,B		;Same?
	 CALL MAPFLG		;No, map flags if not mapped
	  RET			;Non-login str or can't map flags
	HRRZ A,DIRNUM		;Get directory number
	IDIVI A,^D36
	MOVNI B,(B)
	MOVX C,1B0
	LSH C,(B)
	IORM C,FLGPAG(A)
	RET

;;; Map in the mailer flags
MAPFLG:	SKIPGE A,MFLAGP		;Have the mailer flags already?
	 RETSKP			;Yes, don't bother
	JUMPG A,R		;Cannot get them
	MOVX A,GJ%OLD!GJ%SHT
	HRROI B,[ASCIZ/MAIL:MAILER.FLAGS.1/]
	GTJFN%
	IFJER.
	  MOVX A,GJ%OLD!GJ%SHT	;Failed, try on SYSTEM:
	  HRROI B,[ASCIZ/SYSTEM:MAILER.FLAGS.1/]
	  GTJFN%
	  IFJER.
	    AOS MFLAGP		;Flag that we can't get the flags
	    RET
	  ENDIF.
	ENDIF.
	MOVEI B,OF%RD!OF%WR!OF%THW
	MOVE C,A		;Save JFN away in case OPENF% loses
	OPENF%
	IFJER.
	  AOS MFLAGP
	  MOVE A,C		;Get rid of the JFN we got
	  RLJFN%
	   JWARN
	  RET
	ENDIF.
	HRLZ A,A
	MOVE B,[.FHSLF,,FLGPAG/1000]
	MOVX C,PM%RD!PM%WR
	PMAP%
	SETOM MFLAGP		;Flag that we have the flags in
	RETSKP
	SUBTTL Host name routines

; The host table is a TBLUK% format table, with the left half of
;each entry pointing to the host name string (in fully expanded
;format) and the right half holding flags
;
; Currently defined flags are
HF%PRM==1			;Permanent table entry
HF%DED==2			;Host was dead recently

; Parse a host name
; Call:	CALL HSTNAM
;	B/ Pointer to host name
; Returns:
;	+1 Host not known
;	+2 Success
;	B/ Host pointer

HSTNAM:	SAVEAC <A,C,D>
	STKVAR <HSTPTR,<HSTTMP,HSTBFL>,<HSTCAN,HSTBFL>>
	HRROI A,HSTTMP		;Make a copy of the host name
	MOVX C,5*<HSTBFL-1>	;Up to this many characters
	SETZ D,			;Terminate on null
	SOUT%
	JUMPE C,R		;If ran out of space just die
	MOVEI A,HSTTBL		;Point to our table
	HRROI B,HSTTMP
	TBLUK%			;Look it up in the cache
	IFXN. B,TL%EXM		;Found it?
	  HLRZ B,(A)		;Great, get the string address
	  RETSKP		;Return success
	ENDIF.
	HRROI A,HSTTMP		;Name to canonicalize
	HRROI B,HSTCAN		;Where to put the name
	CALL MXNAME		;Do the canonicalization
	IFSKP.
	  IFLE. A		;Did we get a relay list?
	    IFE. A		;No, was it indeterminate?
	      HRROI A,HSTTMP	;If so, see if protocols can help
	      HRROI B,HSTCAN	;Canonical name from MXNAME was just a copy
	    ELSE.		;Otherwise we are the relay for this host
	      HRROI A,HSTCAN	;So sniff at that name
	      HRROI B,HSTTMP	;We don't care what protocols say is canonical
	    ENDIF.
	    CALL HSNAME		;Look up the name through protocols
	  ANSKP.
	    JUMPE A,RSKP	;Handle the local name case
	  ENDIF.
	  MOVEI A,HSTCAN	;Make pointer to canonical name
	  HRLI A,(<POINT 7,>)
	ELSE.
	  HRROI A,HSTTMP	;Get the string pointer
	  HRROI B,HSTCAN	;Where to put canonical name
	  CALL HSNAME
	  IFSKP.
	    JUMPE A,RSKP	;Handle the local name case
	    MOVEI A,HSTCAN	;Make pointer to canonical name
	    HRLI A,(<POINT 7,>)
	  ELSE.
	    HRROI A,HSTTMP	;Try for a relay, return canonical name in A
	    CALL $GTRLY
	     RET
	  ENDIF.
	ENDIF.
	MOVEM A,HSTPTR		;Save pointer to canonical name
	MOVEI A,HSTTBL		;Cache header
	MOVE B,HSTPTR		;Pointer to possible name to add
	TBLUK%
	IFXE. B,TL%EXM		;Found it?
	  MOVE A,HSTPTR
	  CALL CPYSTR		;Copy the string
	  HRLZS B		;RH 0 means temporary table entry
	  MOVEI A,HSTTBL	;Point to the table
	  TBADD%		;Add it to table
	ENDIF.
	HLRZ B,(A)		;Get the string address
	RETSKP			;Return success

	ENDSV.
; GETPRO - Get host address and find protocol supported by host
; Accepts:
;	A/ host name string
;	C/ pointer to protocol list or -1 to try all supported protocols
;	CALL GETPRO
; Returns +1: Failed
;	  +2: Success, updated pointer in A, host address in B,
;			protocol address in C

GETPRO:	STKVAR <HSTPTR,HSTPT1,<HSTTMP,HSTBFL>>
	MOVEM A,HSTPTR		;Save host pointer
	HRROI B,HSTTMP		;See if an MX entry for this guy
	CALL MXNAME		;Well, is there?
	IFSKP.
	ANDG. A			;Must have a relay list
	  MOVE A,(A)		;Get CAR of relay list
	  MOVEM A,HSTPT1	;Get name of first relay
	  MOVE B,HSTPTR		;Compare with name user wants
	  STCMP%
	  IFXN. A,SC%SUB	;Is relay name a subset name user wants?
	    ILDB A,B		;Yes, see what follows
	    CAIE A,"."		;Relative domain delimiter?
	  ANSKP.
	    ILDB A,B		;If we have a relative domain, it means the
	    CAIN A,"#"		; relay is really the host itself, so we must
	     SETZ A,		; skip all the MX games
	  ENDIF.
	ANDN. A			;Relay must be different from host
	  MOVE A,HSTPT1		;Get back relay name
	ELSE.
	  MOVE A,HSTPTR		;Get back host pointer
	  SETZM GTDBLK+.GTDRD	;Note no MX in progress in case optional %<host>
	ENDIF.
	CALLRET $GTPRO		;Now do the normal $GTPRO

	ENDSV.
; HSNAME - Get canonical name and relays for physical host
; Accepts:
;	A/ host name string
;	B/ destination host name string
;	CALL HSNAME
; Returns +1: Failed
;	  +2: Success, A/ 0 and B/ LCLNAM if local host, A/ non-zero otherwise

HSNAME:	SAVEAC <C>
	STKVAR <HSTADR,<HSTTMP,HSTBFL>>
	MOVEI C,SNDRTS		;Check all protocols known at this point
	CALL $GTCAN		;Get canonical name, address, and registry
	 RET			;Fails
	MOVEM B,HSTADR		;Success, save host address
	HRROI A,HSTTMP		;Where to store name
	SETO B,			;Local host address for this protocol
	CALL $GTNAM		;Canonicalize the name
	IFSKP.			;Can't fail most places
	  CAME B,HSTADR		;Is this our local host?
	ANSKP.
	  SETZ A,		;Yes, flag as such
	  MOVEI B,LCLNAM	;Return the local name pointer here
	ENDIF.
	RETSKP

	ENDSV.
; MXNAME - Get canonical name and relays for MX host
; Accepts:
;	A/ host name string
;	B/ destination host name string
;	CALL MXNAME
; Returns +1: Failed
;	  +2: Success, A/ pointer to relay list
;			  0 if indeterminate, -1 if we are the relay

MXNAME:	SAVEAC <B,C,D>
	STKVAR <DSTPTR,<HSTTMP,HSTBFL>>
	MOVEM B,DSTPTR		;Save destination pointer
	MOVE B,A		;Copy string so we can muck with it
	HRROI A,HSTTMP		;Into HSTTMP
	MOVX C,5*<HSTBFL-1>	;Up to this many characters
	SETZ D,			;Terminate on null
	SOUT%
	 ERJMP R		;Percolate failure up to caller
	JUMPE C,R		;String too long if exhausted
	HRROI A,HSTTMP		;Now remove Internet domain
	HRROI B,[ASCIZ/Internet/]
	CALL $RRDOM
	 RET
	ILDB A,A		;Sniff at first character
	CAIE A,"#"		;Looks like a literal?
	 CAIN A,"["
	  RET			;Yes, can't possibly be MX then!!
	MOVX A,GTDLEN		;Set up length of argument block
	MOVEM A,GTDBLK+.GTDLN
	SETZM GTDBLK+.GTDTC	;No special query type/class
	MOVX A,<RLYBFL*5>-1	;Length of relay buffer
	MOVEM A,GTDBLK+.GTDBC	;Save relay buffer length
	SETZM GTDBLK+.GTDNM	;This gets returned
	SETZM GTDBLK+.GTDRD	;So does this
	MOVX A,.GTDMX		;Want MX poop
	HRROI B,HSTTMP		;Source pointer
	HRROI C,RLYBUF		;Destination string buffer
	MOVEI D,GTDBLK		;Argument block
	CALL $GTHST
	 RET
	IFN. A			;Have determinate information?
	  MOVE A,DSTPTR		;Indeterminate, just copy the argument
	  HRROI B,HSTTMP	;As the canonical name
	  SETZ C,
	  SOUT%
	  SETZ A,		;No relay pointer
	ELSE.
	  MOVE A,DSTPTR		;Copy to canonical name
	  MOVE B,GTDBLK+.GTDNM	;Get pointer to canonical string
	  MOVX C,5*<HSTBFL-1>	;Up to this many characters
	  SETZ D,		;Terminate on null
	  SOUT%
	   ERJMP R		;Percolate failure up to caller
	  JUMPE C,R		;String too long if exhausted
	  MOVEI D,GTDBLK+.GTDRD	;Scan relay list
	  DO.
	    SKIPN A,(D)		;Get item from relay list
	     EXIT.
	    HRROI B,LCLNAM	;Compare with local name
	    STCMP%
	    IFE. A		;Handle even the unlikely case
	      SETO A,		;So flag that
	      RETSKP		;And return success
	    ENDIF.
	    IFXN. A,SC%SUB	;Is relay name a subset of our name?
	      ILDB A,B		;Yes, see what follows
	      CAIE A,"."	;Relative domain delimiter?
	    ANSKP.
	      ILDB A,B
	      CAIE A,"#"
	    ANSKP.		;We are the relay to this MX!
	      SETO A,		;So flag that
	      RETSKP		;And return success
	    ENDIF.
	    AOJA D,TOP.		;Else consider next relay
	  ENDDO.
	  MOVEI A,GTDBLK+.GTDRD	;Return pointer to relay list
	ENDIF.
	RETSKP

	ENDSV.
; Make a host a permanent table entry
; Call:	CALL HSTPRM
;	B/	Host pointer
; Returns: +1 always.
HSTPRM:	SAVEAC <A,B>
	MOVEI A,HSTTBL
	TBLUK%
	TXNE B,TL%NOM!TL%AMB
	 FATAL <HSTPRM - Impossible TBLUK failure>
	MOVX B,HF%PRM
	IORM B,(A)		;Set the right flag
	RET

; Combination of HSTNAM and HSTPRM.
; Call: CALL PRMHST
;	B/  Host string
; returns +1 or +2, like HSTNAM, but also marks host perm if
; it works.  

PRMHST:	CALL HSTNAM
	 RET			;Fail if HSTNAM does
	SAVEAC <B>
	HRRO B,B
	CALL HSTPRM		;Mark it permanent
	RETSKP

; Clear the table of all temporary entries.
; Call: CALL HSTCLR
; Returns: +1 always
HSTCLR:	SAVEAC <A,B,C>
	HLRZ C,HSTTBL		;number of entries
	MOVNS C
	MOVSS C
	HRRI C,HSTTBL+1		;Make an AOBJN pointer
	MOVEI A,HSTTBL
	DO.
	  HRRZ B,(C)		;get entries flag
	  IFE. B		;0 = temp entry
	    HLRZ B,(C)		;Get name string block
	    CALL FREBLK		;release the storage
	    MOVEI B,(C)
	    TBDEL%
	    SOS C		;correct pointer for deleted entry
	  ENDIF.
	  AOBJN C,TOP.
	ENDDO.
	RET
; Routine to check if a host is known to be dead
; Entry:   b = host pointer
; Call:    CALL HSTDED
; Return:  +1, host dead
;	   +2, host is alive
HSTDED:	SKIPN NETF		;Allowed to scan network mail?
	 RET			;No, pretend host is dead
	SKIPN FSTF		;Slow scan fork?
	 RETSKP			;Yes, no need to scan dead host table
	SAVEAC <A,B,C>
	MOVEI A,HSTTBL		;Look this one up
	HRROS B			;Make sure byte pointer
	TBLUK%
	TXNE B,TL%NOM!TL%AMB	;Paranoia
	 FATAL <HSTDED - Impossible TBLUK failure>
	HRRZ A,(A)		;Get flags
	JXN A,HF%DED,R		;Dead?
	RETSKP			;Else return success

; Routine to add a host to the dead list.
; Entry:   FRNHST = host pointer
; Call:    CALL ADEADH
; Return:  +1 always
ADEADH:	SKIPN FSTF		;Slow scan?
	 RET			;Yes, no need to do this
	SAVEAC <A,B>
	MOVEI A,HSTTBL
	HRRO B,FRNHST
	TBLUK%			;Look it up
	TXNE B,TL%NOM!TL%AMB
	 FATAL <ADEADH - Impossible TBLUK failure>
	MOVX B,HF%DED
	IORM B,(A)		;Set the right flag
	RET

; Routine to remove all dead host flags from the list
; Call:	CALL  NDHOST
; Return: +1 always
NDHOST:	HLRZ A,HSTTBL		;Get length
	MOVNS A			;(Better be at least one)
	MOVSS A
	HRRI A,HSTTBL+1		;Make an AOBJN pointer
	MOVX B,HF%DED
	DO.
	  ANDCAM B,(A)		;Clear the flag
	  AOBJN A,TOP.	;and loop
	ENDDO.
	RET
	SUBTTL Parser

;;; Initialize parser, called with starting address in B, byte count in C
PARINI:	HRLI B,(<POINT 7,0>)
	DMOVE X,B
	RET

;;; Parse a single line
PARLIN:	TXZ F,FP%FF!FP%CLN!FP%EOL!FP%DEL!FP%WSP
	SETZM PDELB2		;Filter for malformed <del> pairs
	DO.
	  DMOVEM X,PLINBP	;Save start of line
	  DO.
	    DMOVEM X,PWSPBP
	    SOJL Y,R
	    ILDB D,X		;Get first character
	    CAIE D,.CHTAB	;Leading whitespace?
	     CAIN D,.CHSPC
	     IFNSK.
	       TXO F,FP%WSP	;Yes, note it
	       LOOP.		;And continue
	     ENDIF.
	  ENDDO.
	  IFXE. F,FP%FF		;Seen formfeed yet?
	    CAIE D,.CHFFD	;No, is there one now?
	    IFSKP.
	      TXO F,FP%FF
	      TXZ F,FP%BKA!FP%EQU ;Clear special flags
	      LOOP.
	    ENDIF.
	  ELSE.
	    IFXE. F,FP%EQU!FP%BKA ; Seen one of these yet?
	      CAIE D,"="	;Equal sign?
	      IFSKP.
		TXO F,FP%EQU	;Yes
		LOOP.
	      ENDIF.
	      CAIE D,"_"	;Backarrow?
	      IFSKP.
		TXO F,FP%BKA	;Yes
		LOOP.
	      ENDIF.
	    ENDIF.
	  ENDIF.
	ENDDO.
	CAIN D,.CHCRT		;End of line?
	IFSKP.
	  DO.
	    CAIE D,.CHDEL
	    IFSKP.
	      TXON F,FP%DEL	;Rubout within line is start of host
	      IFSKP.
		SKIPN PDELB2	;Matching pair?
		IFSKP.
		  SETOM PDELB2	;No, flag error
		ELSE.
		  DMOVEM X,PDELB2
		ENDIF.
	      ELSE.
		DMOVEM X,PDELBP
	      ENDIF.
	    ELSE.
	      CAIN D,":"
	       TXOE F,FP%CLN
	       IFSKP.
		 DMOVEM X,PCLNBP ;Save pointers when got to colon
	       ENDIF.
	    ENDIF.
	    SOJL Y,R
	    ILDB D,X
	    CAIE D,.CHCRT
	     LOOP.
	  ENDDO.
	ELSE.
	  TXO F,FP%EOL
	ENDIF.
	SOJL Y,R
	ILDB D,X		;Skip lf too
	SKIPG PDELB2		;Matching <del> set?
	 TXZ F,FP%DEL		;No, ignore any seen
	RETSKP

;;; Parse a keyword from table in A
;;; Returns +1 failure, else calls routine pointed to by table
PARKEY:	IFXN. F,FP%CLN		;Line had a colon in it?
	  MOVE D,PCLNBP		;Yes, use byte pointer of colon then
	ELSE.
	  SETO D,
	  ADJBP D,X
	ENDIF.
	LDB TT,D		;Get character that terminates atom
	SETZ T,
	DPB T,D			;Replace it with null
	MOVE T,0(A)		;t := aobjn ptr to lookup table
PARKY2:	HLRZ A,0(T)		;a := ptr to next table entry
	HRLI A,(<POINT 7,0>)
	MOVE B,PLINBP		;Start of line
	CALL STRCMP		;Match?
	 AOBJN T,PARKY2		;No, try the next
	DPB TT,D		;Replace character
	JUMPGE T,R		;If no match, return
	HRRZ A,(T)		;Get entry
	JRST (A)		;Go call that routine

;;; Get pointers for this line
PARSTR:	DMOVE C,PLINBP
PARST1:	SUB D,Y
	SUBI D,2		;Number of chars less CRLF
	RET

;;; Make lengths of fields in line with rubout relative
PARDEL:	MOVE T,PLINBP+1		;Start of line
	MOVE TT,PDELBP+1
	SUB T,TT
	SUBI T,1		;Less rubout itself
	MOVEM T,PLINBP+1
	MOVE T,PWSPBP+1
	SUB T,TT
	SUBI T,1
	MOVEM T,PWSPBP+1
	MOVE T,PDELB2+1
	SUB TT,T
	SUBI TT,1
	MOVEM TT,PDELBP+1
	SUB T,Y
	SUBI T,2		;Less CRLF
	MOVEM T,PDELB2+1
	RET

;;; Return a host index for string in C and D, returns as HSTNAM
PARHLN:	CALL PARSTR		;Get pointers for this line
PARHST:	MOVE B,[POINT 7,HSTBUF]
	DO.
	  ILDB A,C		;Copy string
	  IDPB A,B
	  CAIE A,.CHNUL		;Quit on null
	   SOJG D,TOP.		;Or count
	ENDDO.
	SETZ A,			;Fill out with nulls
	DO.
	  IDPB A,B
	  TXNE B,76B4
	   LOOP.
	ENDDO.
	MOVE B,[POINT 7,HSTBUF]
	CALLRET HSTNAM		;Go try to parse host name
	SUBTTL Queue file handling

;;; Structure of a queue file entry:
MSGPAG==0			;Count,,starting page mapped into
MSGJFN==1			;Flags,,JFN for it
MSGFHS==2			;Foreign host
MSGHDR==3			;Byte pointer of start of headers
MSGHCN==4			;Count of bytes in that
MSGTXT==5			;Byte pointer of start of text
MSGTCN==6			;Count of bytes in that
MSGNHD==7			;Count,,addr of headers for this network
MSGRCP==10			;Network recipients
MSGLCL==11			;Local recipients
MSGSDR==12			;Sender of msg
MSGWRT==13			;Time msg was queued
MSGAFT==14			;Time to start attempting message delivery
MSGNTF==15			;Time to tell sender of delivery status
MSGDEQ==16			;Time to dequeue the msg -- dead letter
MSGTMT==17			;Time limit for sending whole msg (msec)
MSGTMC==20			;Time limit for sending one copy (msec)
MSGDOP==21			;Delivery options
MSGRPT==22			;Return path
MSGLEN==23			;Length of entry

;;; Global flags for msg handling (lh of MSGJFN)
FG%XER==1B0			;Discard file on error (hard failure or
				;dequeue time-out)

;;; Structure of host entry:
HSTFLG==0			;Flags,,link to next
 FH%DON==1B0			;Host done
 FH%DN1==1B1			;Host about to be done
 ;;; Flags for "sender" specification (used in sender host block)
 FS%BKA==1B2			;Sender specified in mail file preamble
 FS%RMF==1B3			;Sender from "ReSent-From:" line
 FS%SDR==1B4			;Sender from "Sender:" line
 FS%FRM==1B5			;Sender from "From:" line
 FS%RPL==1B6			;Sender from "Reply-to:" line
 FS%NTM==1B7			;"Mail-from:" net host line seen
 FS%MLA==1B8			;"Mail Agent" is the default sender
HSTHST==1			;Host pointer
HSTRCP==2			;Recipients
HSTLEN==3			;Length of entry

;;; Structure of recipient entry:
RCPFLG==0			;Flags,,link to next
 FR%FAI==1B0			;Hard failure
 FR%TMP==1B1			;Temporary failure
 FR%ERM==1B2			;There is a consed up error
 FR%STR==1B3			;Name is consed locally
 FR%MLA==1B4			;Recip = mail agent and failed
 FR%SDR==1B5			;Recip = sender and failed
RCPBPT==1			;Byte pointer to name
RCPCNT==2			;Byte count
RCPERR==3			;Error message
RCPLEN==4			;Length of entry

;;; Get a queue file JFN in A, returns +1 if failure, +2 with file entry in M
GETQUE:	JSR SAVACS		;Save all ACs
	MOVEI B,(A)
	HRROI A,STRBUF
	SETZ C,
	JFNS%
	HRROI B,STRBUF		;Must get another JFN
	CALL MAPQFL
	 RET			;Failed, return
	CALL PARINI		;Initialize parser
	PUSH P,A		;Save JFN
	MOVEI A,MSGLEN
	CALL ALCBLK		;Allocate a block for message
	IFNSK.
	  POP P,A		;Restore JFN
	  CALL UNMQU0		;Unmap file and return
	   NOP
	  RET
	ENDIF.
	MOVEI M,(B)		;Pointer to block
	POP P,MSGJFN(M)		;Save JFN
	MOVEM M,M-ACBASE(P)	;Return that too
	MOVEM D,MSGPAG(M)	;Page info
	SETZM MSGFHS(M)
	SETZM MSGNHD(M)
	SETZM MSGRCP(M)		;Initialize recipient pointers
	SETZM MSGLCL(M)
	SETZM MSGSDR(M)
	SETZM MSGAFT(M)		;Clear default after interval
	SETZM MSGNTF(M)		;Clear delivery status notification time
	SETZM MSGDEQ(M)		;Clear default dequeue time for msg
	SETZM MSGDOP(M)		;Clear delivery options
	SETZM MSGRPT(M)		;Clear return path
	SKIPN A,DAEMNP		;Running as daemon?
	IFSKP.
	  SKIPE RXMF		;Doing a retransmission?
	  IFSKP.
	    TIME%		;No, log xmit time limit for whole msg
	    ADD A,TMTINT
	  ELSE.
	    SETZ A,		;No overall time limit for retransmissions
	  ENDIF.
	ENDIF.
	MOVEM A,MSGTMT(M)	;Record it
	SETZM MSGTMC(M)		;Clear xmit time limit/msg copy
	HRRZ A,MSGJFN(M)	;Get file write date
	CALL .GFWDT
	MOVEM B,MSGWRT(M)
	CALL GDFSDR		;Set up the default sender
	 FATAL <GETQUE: Error setting up default sender>
	MOVE A,MPP		;From here on, return +2 on error
	AOS (A)
	MOVE A,FILIDX		;a := current file type index
	HLRZ A,%FLPRC(A)	;a := processing dispatch for header
	JRST 0(A)		;Do it
;; Here to fake a header for xxx.<addressee> files
GQUEUN: PUSH P,X		;Save the current msg string info
	PUSH P,Y
	HRROI A,STRBUF		;a := buffer for the extension info
	HRRZ B,MSGJFN(M)	;b := msg file JFN
	MOVSI C,000100		;Print extension only
	JFNS%
	MOVE A,[POINT 7,STRBUF]	;Now scan the string for the host name
	MOVE B,A
	SETZB X,Y		;Init host ptr and string length
	DO.
	  ILDB C,B		;c := next char
	  IFN. C		;While non-null
	    CAIN C,.CHCNV	;^V?
	     LOOP.		;Yes, ignore it
	    CAIE C,"@"		;Start of host?
	    IFSKP.
	      SETZ C,		;Yes, clobber the "@" with a null
	      IDPB C,A
	      MOVE X,A		;Save start of string
	      LOOP.
	    ENDIF.
	    IDPB C,A		;Store the char
	    AOJA Y,TOP.		;Count the char and do the next
	  ENDIF.
	  SKIPN X		;"@" seen?
	   MOVE X,A		;No, update host ptr
	  CAME A,X		;Is host null?
	  IFSKP.
	    MOVE B,[POINT 7,LCLNAM] ;No, use local name
	    LOOP.
	  ENDIF.
	ENDDO.
	MOVE B,A		;OK, terminate edited string
	IDPB C,B
;;;Now we create a fake header (as if [--QUEUED-MAIL--])
	MOVE A,[POINT 7,OMLRBF]	;a := place to build it
	MOVEI B,.CHFFD		;Start with ^L<host><crlf>
	IDPB B,A
	MOVE B,X		;b := ptr to host string
	SETZ C,
	SOUT%			;(Have to SOUT% - not word boundary)
	MOVEI B,CRLF0
	CALL MOVSTR
	MOVEI B,STRBUF		;Add <addressee><crlf>
	CALL MOVSTR
	MOVEI B,CRLF0
	CALL MOVSTR
	MOVEI B,.CHFFD		;And finish with ^L<CRLF>
	IDPB B,A
	MOVEI B,CRLF0
	CALL MOVST0
	MOVE X,[POINT 7,OMLRBF]	;Now set to scan the string
	ADDI Y,^D8+1		;Account ^L's and <crlf>'s in length
				;(and 1 so PARLIN thinks a msg follows)
;	JRST GQUEQM		;Drop into common code

;; Parse the head of the file
GQUEQM:	CALL PARLIN		;Get a line from the file
	 JRST QUEEOF		;Premature eof
	IFXE. F,FP%FF		;Was a formfeed seem?
	  CALL QUEBAD		;No, bad format file
	  HRROI B,[ASCIZ/Invalid queued mail file format in line "/]
	  JRST QUEBP0		;Toss the losing file out
	ENDIF.

;; Now parse the message recipients
GQUERC:	IFXN. F,FP%EOL		;Empty line?
	  JXN F,FP%EQU,QUEBPM	;Error if control parameter specification
	  JXE F,FP%BKA,GQUEHD	;If not sender, must be start of actual msg
	  MOVEI B,LCLNAM	;Default sender host to us
	  JRST GQUSDR		;Set up new sender spec
	ENDIF.
	TXNE F,FP%EQU		;Control parameter specification?
	 JRST GQUPRM		;Yes, decode it
	CALL PARHLN		;Get host from name
	IFNSK.
	  JXE F,FP%BKA,QUEBHS	;If not sender spec, can't win...
	  DO.			;Yes, ignore it
	    CALL PARLIN		;Eat line
	     JRST QUEEOF	;Premature EOF
	    TXNE F,FP%FF	;Started with form?
	     JRST GQUERC	;Yes, done with this
	    LOOP.		;Otherwise eat remainder of specification
	  ENDDO.
	ENDIF.
	JXN F,FP%BKA,GQUSDR	;Set up if sender spec
	SKIPN WOPRP		;WHEEL or OPERATOR?
	IFSKP.
	  CAIE B,LCLNAM		;Yes, deliver directly if local host
	  IFSKP.
	    MOVEI O,MSGLCL(M)	;Point to local entry
	    JRST GQURC5
	  ENDIF.
	ENDIF.
	PUSH P,B		;Save site entry
	HRROS B			;Set to check if this host already seen
	MOVEI N,MSGRCP(M)	;Starting pointer for linked host list
GQURC2:	HRRZ A,(N)		;a := next host entry on list
	JUMPE A,GQURC3		;Quit at end of list
	MOVEI N,(A)		;n := adr of this host block
	CAME B,HSTHST(N)	;Host already on list?
	 JRST GQURC2		;No, check next block
	POP P,B			;Yes, recover site entry
	JRST GQURC4		;Append these users

;; Here when the new host is not already on the recipient list
GQURC3:	MOVEI A,HSTLEN		;Get a host entry
	CALL ALCBLK
	 JRST QUEBRT		;Failed, free what we used and return
	HRRM B,(N)		;Link it in
	MOVEI N,(B)		;Now the end of the list
	SETZM HSTFLG(N)
	POP P,HSTHST(N)		;Save host pointer
	SETZM HSTRCP(N)		;Init recipient list
GQURC4:	MOVEI O,HSTRCP(N)	;This is the start of the recipients
GQURC5:	HRRZ A,(O)		;a := next recipient entry on list
	JUMPE A,GQURC1		;Quit at end of the list
	MOVEI O,(A)		;o := adr of this recipient block
	JRST GQURC5		;Try another

;; Here to process the next input line...
GQURC1:	CALL PARLIN		;Get a line
	 JRST QUEEOF		;Premature eof
	TXNE F,FP%FF		;Started with form?
	 JRST GQUERC		;Yes, next host then
	TXNE F,FP%EOL		;End of line?
	 JRST GQURC1		;Yes, ignore it and try another
	MOVEI A,RCPLEN		;Get block for this recipient
	CALL ALCBLK
	 JRST QUEBRT		;Failed, return
	HRRM B,(O)		;Link it in
	MOVEI O,(B)		;Now the end of the list
	SETZM RCPFLG(O)		;Clear flags
	CALL PARSTR		;Limits of string
	DMOVEM C,RCPBPT(O)	;Save them
	JRST GQURC1

;; Here when sender spec encountered.  b = host site tbl adr
GQUSDR:	PUSH P,[0]		;Save place for user ptr
	PUSH P,[0]
	PUSH P,B		;Save host adr (until we have a user)
GQUSD0:	CALL PARLIN		;Get a line
	IFNSK.
	  ADJSP P,-3		;Premature eof
	  JRST QUEEOF
	ENDIF.
	TXNE F,FP%FF		;Started with form?
	 JRST GQUSD1		;Yes, record what we have
	TXNE F,FP%EOL		;End of line?
	 JRST GQUSD0		;Yes, ignore it and try another
	CALL PARSTR		;OK, get limits of string
	DMOVEM C,-2(P)		;Save them
	TXZE F,FP%BKA		;First user entry?
	 JRST GQUSD0		;Yes, see if there are anymore
	JRST GQUSDB		;Too many, bad sender spec

;; Here when new line starting with FF
GQUSD1:	JXN F,FP%BKA,GQUSDB	;Exactly one sender?
REPEAT 0,<	;; This needs more thought for Cafard, etc.
	DMOVE A,[POINT 7,ORGAUT	;File's last writer
		 POINT 7,DAEDIR] ;Daemon directory
	CALL STRCMP		;Match?
	IFNSK.
	  ADJSP P,-3		;Reset stack
	  JRST GQUERC		;See about next host
	ENDIF.
>;REPEAT 0
	HRRZ B,MSGSDR(M)	;OK, b := adr of host entry block
	MOVX A,FS%MLA		;Clear "mlagnt" bit if on
	ANDCAM A,HSTFLG(B)
	MOVX A,FS%BKA		;Set "_sender" bit
	IORM A,HSTFLG(B)
	POP P,HSTHST(B)		;Install new sender host
	HRRZ B,HSTRCP(B)	;b := adr of recipient entry block
	POP P,RCPCNT(B)		;Install new byte count
	POP P,RCPBPT(B)		;and byte ptr
	SETZM RCPERR(B)		;Clear error
	JRST GQUERC		;Now see about the next host

;; Now finish up, remembering where the headers start
GQUEHD:	MOVE A,FILIDX		;a := index to current file type
	HRRZ A,%FLPRC(A)	;a := processing dispatch for msg
	JRST 0(A)		;Do it

GQUEH0:	POP P,Y			;Recover ptr info for msg text itself
	POP P,X
GQUEH1:	DMOVEM X,MSGHDR(M)
	CALL FNDSDR		;Find sender by parsing msg headers
	MOVE P,MPP		;Undo extra pushes
	RETSKP			;Skip return from it all

;;; Here to process file processing parameter specifications.  These are
;;; of the form <ff>=<keyword>:<value>
GQUPRM:	MOVEI A,QUEPTB		;Lookup in parameter keyword table
	CALL PARKEY
	 JRST QUEBPM		;Bad luck...
	JRST GQURC1		;Got it, continue processing

;;; Here to fetch return path
QUERPT:	DMOVE C,PCLNBP		;Rest of line after colon
	CALL PARST1
	SKIPN A,D		;Length of string
	 RETSKP			;Return path null?  Ignore it I guess
	IDIVI A,5		;Size in words
	ADDI A,1		;Add an extra word for remainder and null pad
	CALL ALCBLK
	 RETSKP			;Don't care all that much
	MOVEM B,MSGRPT(M)	;Save pointer to block
	HRLI B,(<POINT 7,>)	;Make byte pointer
QUERP1:	ILDB A,C		;Copy string
	IDPB A,B
	SOJG D,QUERP1		;Continue until count exhausted
	IDPB D,B		;Tie off string with null
	RETSKP

;;; Here to fetch delivery options
QUEDEL:	DMOVE C,PCLNBP		;Rest of line after colon
	CALL PARST1
	CAIE D,4		;Is string 4 characters precisely?
	 RET			;No, can't be valid
	ADJBP D,C		;Pointer to delimeter byte
	ILDB TT,D		;Get delimiter byte
	SETZ T,			;Make it null-terminated
	DPB T,D
	MOVEI A,QUEDOP		;Lookup in parameter keyword table
	MOVE B,C
	TBLUK%
	DPB TT,D		;Put delimiter back
	TXNE B,TL%NOM!TL%AMB	;Bad delivery option?
	 RET
	HRRZ B,(A)		;Get delivery options table code
	MOVEM B,MSGDOP(M)
	RETSKP

QUEDOP:	NQDOPS,,NQDOPS
DOPTAB:	PHASE 0
	[ASCIZ/MAIL/],,.	;Mail (MUST BE FIRST IN TABLE!!!!!!!!)
D%SAML:![ASCIZ/SAML/],,.	;Send and mail
D%SEND:![ASCIZ/SEND/],,.	;Send
D%SOML:![ASCIZ/SOML/],,.	;Send or mail
	DEPHASE
NQDOPS=.-DOPTAB

;;; Here to fetch physical host that connected to us
QUEHST:	DMOVE C,PCLNBP		;Rest of line after colon
	CALL PARST1
	CALL PARHST		;Parse the host name
	 SETZ B,		;Failed, ignore it (shouldn't happen)
	MOVEM B,MSGFHS(M)
	RETSKP

;;; Here to fetch time to attempt network retransmissions
QUEAFT:	CALL GQUTIM		;Decode the time value
	 RET			;No go
	MOVEM B,MSGAFT(M)	;Save it
	RETSKP			;And success return

;;; Here to fetch time to notify sender of transmission status
QUENTF:	CALL GQUTIM		;Decode the time value
	 RET			;No go
	MOVEM B,MSGNTF(M)	;Save it
	RETSKP			;And success return

;;; Here to fetch time to notify sender of transmission status
QUEDEQ:	CALL GQUTIM		;Decode the time value
	 RET			;No go
	MOVEM B,MSGDEQ(M)	;Save it
	RETSKP			;And success return

;;; Here to set flag for discarding msg without notifying sender if
;;; failed or dequeued.
QUEDER:	MOVX A,FG%XER		;Set flag
	IORM A,MSGJFN(M)
	RETSKP			;And success return

;;; Routine to decode a time value for a control parameter
;;; Return:  +1, error
;;;	     +2, success - value in b
GQUTIM:	DMOVE C,PCLNBP		;Rest of line after colon
	CALL PARST1
	MOVE A,[POINT 7,STRBF1]	;Temp buffer for time string
GQUTI0:	ILDB B,C
	CAIE B,.CHSPC		;Skip starting spaces and tabs
	 CAIN B,.CHTAB
	 IFNSK.
	   SOJG D,GQUTI0	;Look some more
	   RET			;Unless string exhausted
	 ENDIF.
	SKIPA
GQUTI1:	 ILDB B,C		;Next char
	IDPB B,A		;Copy it
	CAIN B,.CHNUL		;Quit on null
	 JRST GQUTI2
	SOJG D,GQUTI1		;If not end of string, continue
	MOVEI B,0		;Else end with null
	IDPB B,A
GQUTI2:	HRROI A,STRBF1		;Now convert the time string
	IDTIM%
	 RET
	RETSKP

;;; Table of parameter keywords and processing routines
QUEPTB:	-NQPRMS,,.+1
	[ASCIZ/AFTER/],,QUEAFT	;Formerly RETRANSMIT
;	[ASCIZ/DATA/],,QUEDAT
	[ASCIZ/DELIVERY-OPTIONS/],,QUEDEL
	[ASCIZ/DEQUEUE/],,QUEDEQ
	[ASCIZ/DISCARD-ON-ERROR/],,QUEDER
;	[ASCIZ/ERROR/],,QUEERR
	[ASCIZ/NET-MAIL-FROM-HOST/],,QUEHST
	[ASCIZ/NOTIFY/],,QUENTF
	[ASCIZ/RETURN-PATH/],,QUERPT
NQPRMS=.-QUEPTB-1
; Routine to set up the default sender for a msg
; Entry:   queue file mapped
; Call:    CALL GDFSDR
; Return:  +1, failure
;	   +2, OK
GDFSDR:	HRRZ A,MSGJFN(M)	;a := queue file JFN
	HRLI A,.GFLWR		;Get its author string
	HRROI B,FILAUT		;Into filaut buffer
	GFUST%
	MOVE A,[FILAUT,,ORGAUT]	;Save original in ORGAUT
	BLT A,ORGAUT+AUTLEN-1
	MOVE N,[POINT 7,MLAGNT]	;Set up mail agent as default author
	DMOVE A,[POINT 7,FILAUT ;See if it was written by system server
		 POINT 7,DAEDIR]
	CALL STRCMP		;Was it?
	IFNSK.
	  MOVX A,RC%EMO		;No, see if looks like a local user name
	  HRROI B,FILAUT
	  RCUSR%		;Parse user name
	  IFNJE.
	    TXNN A,RC%NOM!RC%AMB ;Parsed, does it exist?
	     MOVE N,[POINT 7,FILAUT] ;Yes, set local user as default author
	  ENDIF.
	ENDIF.
	PUSH P,N		;Save author on stack
	MOVEI N,MSGSDR(M)	;n := root for sender host entry blk
	MOVEI A,HSTLEN		;Get a host entry
	CALL ALCBLK
	 JRST GDFSDX		;Failed, return +1
	HRRM B,0(N)		;Link it in
	MOVEI N,(B)		;Now the end of the list
	SETZM B,HSTFLG(N)
	MOVX A,FS%MLA		;Check if dflt sender = mail agent
	HRRZ B,(P)
	CAIN B,MLAGNT		;Is it?
	 IORM A,HSTFLG(N)	;Yes, set the flag
	MOVEI B,LCLNAM		;b := host site tbl adr
	MOVEM B,HSTHST(N)	;Save site entry
	MOVEI O,HSTRCP(N)	;o := start of the sender recipient
	MOVEI A,RCPLEN		;Get block for this recipient
	CALL ALCBLK
	 JRST GDFSDX		;Failed, return +1
	HRRZM B,(O)		;Link it in
	MOVEI O,(B)		;Now the end of the list
	SETZM RCPFLG(O)		;Clear flags
	MOVE A,(P)		;a := ptr to dflt sender string
	SETZ B,			;b := str length
	ILDB C,A		;c := next char
	CAIE C,.CHNUL		;Quit on null
	 AOJA B,.-2		;Otherwise count it
	POP P,A			;a := fresh ptr to sender string
	DMOVEM A,RCPBPT(O)	;Install the sender name
	RETSKP			;Return +2

; Here if error allocating blocks
GDFSDX:	ADJSP P,-1		;Reset the stack
	RET			;Fail return +1
;;; The following code is to parse the msg headers to find the msg
;;; sender if none was specified by "_sender" in the msg preamble and
;;; the msg file author was DAEDIR.

; Keyword table for locating msg header lines possible containing a
; sender address.
FSDRTB:	-NFSDR,,.+1
	[ASCIZ/RESENT-FROM/],,SDRRMF
	[ASCIZ/REMAILED-FROM/],,SDRRMF
	[ASCIZ/REDISTRIBUTED-FROM/],,SDRRMF
	[ASCIZ/SENDER/],,SDRSDR
	[ASCIZ/FROM/],,SDRFRM
	[ASCIZ/REPLY-TO/],,SDRRPL
	[ASCIZ/MAIL-FROM/],,SDRNTM
NFSDR==.-FSDRTB-1


; Find sender name by parsing message header.  Message file mapped
; Entry:   m = adr of message block
;	   x,y = ptr/cnt to start of msg headers
; Call:    CALL FNDSDR
; Returns +1 always
FNDSDR:	HRRZ N,MSGSDR(M)	;n := adr of "sender" recip host block
	MOVX A,FS%BKA
	MOVX B,FS%MLA
	TDNN A,HSTFLG(N)	;Sender from file preamble?
	 TDNN B,HSTFLG(N)	;No, sender = non-DAEDIR file author?
	  RET			;Yes, don't supersede that
	HRRZ O,HSTRCP(N)	;o := adr of "sender" recipient block
	SETZM SDRHST		;Init sender temp locs
	SETZM SDRNAM
FNDSD0:	CALL PARLIN		;Get a line from the msg text
	 JRST FNDSD1		;EOF, check out sender
	TXNE F,FP%EOL		;Empty line?
	 JRST FNDSD1		;No more header lines, check out sender
	MOVEI A,FSDRTB		;a := sender spec line keywords
	TXNE F,FP%CLN		;Colon seen?
	 CALL PARKEY		;Yes, look up this line's keyword
	  JRST FNDSD0		;+1, no go, move on to next line
	HRRM B,SDRHST		;Save the new host
	DMOVEM C,SDRNAM		;Install the new recipient name ptr
	JRST FNDSD0		;Loop through rest of headers

; Here when finished with msg headers
FNDSD1:	DMOVE C,SDRNAM		;c/d := new recipient name ptr/cnt
	JUMPE C,R		;If highest priority spec failed, quit
	DMOVEM C,RCPBPT(O)	;Install the new recipient name ptr
	SKIPN B,SDRHST		;b := sender host site
	 MOVEI B,LCLNAM		;Yes
	HRRZM B,HSTHST(N)	;Install it
	RET			;Done
; Following are the routines to check out various "sender"
; specification lines.
; Return:  +1, No sender found
;	   +2, Sender address found
;    b = host site tbl entry adr
;    c = ptr to sender name string
;    d = byte count for sender name

; Here to process "ReSent-From:" line
SDRRMF:	MOVX A,FS%RMF		;a := flag for this line type
	IORM A,SDRHST		;Show we've seen one
SDRRM0:	CALL GTSNDR		;Go scan for the sender
	 JRST SDRXXX		;Error
	RETSKP			;Success, return +2

; Here to process "Sender:" line
SDRSDR:	MOVX A,FS%SDR		;a := flag for this line type
	IORM A,SDRHST		;Show we've seen one
	MOVX A,FS%RMF		;Already have higher priority spec?
	TDNE A,SDRHST
	 RET			;Yes
	CALLRET SDRRM0		;Go scan for the sender

; Here to process "From:" line
SDRFRM:	MOVX A,FS%FRM		;a := flag for this line type
	IORM A,SDRHST		;Show we've seen one
	MOVX A,FS%RMF!FS%SDR	;Already have higher priority spec?
	TDNE A,SDRHST
	 RET			;Yes
	CALLRET SDRRM0		;No, go scan for the sender

; Here to process "Reply-to:" line
SDRRPL:	MOVX A,FS%RPL		;a := flag for this line type
	IORM A,SDRHST		;Show we've seen one
	MOVX A,FS%RMF!FS%SDR!FS%FRM ;Already have higher priority spec?
	TDNE A,SDRHST
	 RET			;Yes
	CALLRET SDRRM0		;No, go scan for the sender

; Here to process "Mail-from:" line
SDRNTM:	MOVX A,FS%NTM		;a := flag for this line type
	IORM A,SDRHST		;Show we've seen one
	RET

; Here on error in parsing sender address line
SDRXXX:	HLLZS SDRHST		;Clear the sender address stuff
	SETZM SDRNAM
	RET
; Parse a line for sender's name and host
; Entry:   Input line set up to parse
; Call:    CALL GTSNDR
; Return:  +1, error, no valid address
;	   +2, success, b = host site, c/d = sender name ptr/cnt
GTSNDR:	STKVAR <SDRHSP,SDRNPT,SDRNCT,SAVEB,SAVEC,SAVED>
	TXZ F,FP%LBK!FP%RBK!FP%DQT ;Clear flags
	DMOVE C,PCLNBP		;Set to scan from ":"
	CALL PARST1		;Adjust counts
GTSND0:	SETZM SDRHSP		;Reset host/name
	SETZM SDRNPT
	TXZ F,FP%HST		;Not collecting host yet
	CALL GTSFLD		;Scan a field of the input string
	JUMPL B,R		;If questionable char, do error return
	MOVEM T,SDRNPT		;Save the name ptr/cnt
	MOVEM TT,SDRNCT
	TXNN F,FP%SEP		;Special char term?
	 JRST GTSND3		;Yes

; Here to check for "at" field signalling host name
GTSND1:	CALL GTSFLD		;Get the next field
	JUMPL B,R		;Quit on questionable char
	IFXE. F,FP%SEP		;This field end with separator?
	  SETZM SDRNPT		;No, bad syntax
	  JRST GTSND4		;Try to make sense of spec char
	ENDIF.
	TXZ A,10040		;Capitalize last two small letters
	CAIN A,"AT"		;Is it "at"?
	 JRST GTSND5		;Yes, process host name
	SETZM SDRNPT		;Random string format, flush ptr
GTSND2:	CALL GTSFLD		;Look for field ending with a spec char
	JUMPL B,R		;Quit on error
	TXNN F,FP%SEP		;This field term with separator?
	 JRST GTSND4		;No, better be eol or bracket
	JRST GTSND2		;Scan further

; Here when hit special char
GTSND3:	CAIN B,"@"		;At-sign?
	 JRST GTSND5		;Yes, end name and start host
GTSND4:	CAIN B,.CHCRT		;End of line?
	 JRST GTSND6		;Yes
	CAIE B,.CHDQT		;Start of quoted string?
	IFSKP.
	  TXOE F,FP%DQT		;Yes, set flag and check for error
	   RET			;Shouldn't be here then
	  JRST GTSND0		;Start collection over
	ENDIF.
	CAIE B,"<"		;Left angle-bracket?
	IFSKP.
	  TXOE F,FP%LBK		;Yes, mark it and check for earlier one
	   RET			;Can't have more than one
	  JRST GTSND0		;OK, start over
	ENDIF.
	CAIE B,">"		;Right angle-bracket?
	IFSKP.
	  TXO F,FP%RBK		;Yes, set flag
	  JRST GTSND6		;Check it out
	ENDIF.
	RET			;No, can't make sense of it, bomb!

; Here when saw "@" or "at".  Should get host name next
GTSND5:	CALL GTSFLD		;Get the next field
	JUMPL B,R		;Quit on weird char
	JUMPE TT,GTSND4		;If null string, check terminator
	MOVEM B,SAVEB		;Save current field info
	MOVEM C,SAVEC
	MOVEM D,SAVED
	DMOVE C,T		;Get ptr to this field
	CALL PARHST		;Lookup the host name
	 RET			;No go, punt
	TXON F,FP%HST		;Good host, already have one?
	 MOVEM B,SDRHSP		;No, save this host site entry
	MOVE D,SAVED		;Restore field scanning information
	MOVE C,SAVEC
	MOVE B,SAVEB
	TXNN F,FP%SEP		;Last field end with separator?
	 JRST GTSND3		;No, check out special char
	JRST GTSND1		;Better be more host stuff!

; Here when done processing line
GTSND6:	SKIPN SDRNPT		;Find a name?
	 RET			;No
	TXCE F,FP%LBK!FP%RBK	;Either no <>
	 TXCN F,FP%LBK!FP%RBK	;Or matching set?
	  TRNA			;OK
	   RET			;Bad news
	MOVE D,SDRNCT		;b,c,d := host site and ptr/cnt
	MOVE C,SDRNPT
	MOVE B,SDRHSP
	RETSKP			;Return +2 - sender found

	ENDSV.
; Routine to scan for next field in sender address
; Entry:   c/d = ptr/cnt to remainder of line
; Call:    CALL GTSFLD
; Return:  +1, always
;   t = starting ptr, tt = char count for field
;   a = last 5 chars of field
;   b = terminating char
;   fp%sep set if terminated by special char
GTSFLD:	SETZB T,TT		;Clear field string ptr/cnt
	SETZ A,			;Clear shift reg for last chars in field
	TXZ F,FP%SEP		;Reset separator flag
GTSFL0:	CALL GTSCHR		;Get a char
	 JRST GTSFL0		;+1, ignore leading separators
	 RET			;+2, special char - return
	MOVE T,C		;+3, regular char - save starting ptr
	ADD T,[7B5]
GTSFL1:	ADDI TT,1		;Bump char counter
	LSH A,7			;Accumulate last chars of field
	IORI A,0(B)
	CALL GTSCHR		;Get next character
	 TXO F,FP%SEP		;+1, separator - set flag
	 RET			;+2, special char - return
	JRST GTSFL1		;+3, regular char - continue collecting

; Get next input character in scanning for sender address.  Skips over
; multiple blanks, tabs, and comments (...), checks for allowed special
; chars: "@" "<", ">", or <crlf>.  Other special chars abort the parsing
; and require human intervention to decode the address: ",", ";", or ":".
; Entry:   c/d = source byte ptr/cnt
; Call:    CALL GTSCHR
; Return:  +1, separator seen, b = space
;	   +2, special character, b = character
;	   +3, normal character, b = character
; Updates c/d appropriately
GTSCHR:	CALL GTSLDB		;Fetch a byte
	 JRST GTSCH4		;eol
	IFXN. F,FP%DQT		;Quoted string?
	  CAIE B,.CHDQT		;Yes, ending now?
	   JRST R2SKP		;No, take char as is
	  TXZ F,FP%DQT		;Turn off quote flag
	  JRST GTSCH1		;And make like it is a separator
	ENDIF.
	CAIE B,.CHSPC		;Space?
	 CAIN B,.CHTAB		;Tab?
	  JRST GTSCH1		;Yes
	CAIN B,"("		;Start of comment?
	 JRST GTSCH2		;Yes
	CALL CHKSPC		;Address punctuation?
	 RETSKP			;Yes, return +2
	JRST R2SKP		;No, treat as regular char, return +3

; Here to process separators
GTSCH1:	CALL GTSLDB		;Fetch a byte
	 JRST GTSCH4		;EOL
	CAIE B,.CHSPC		;Space or tab?
	 CAIN B,.CHTAB
	  JRST GTSCH1		;Yes, skip over it
	CAIE B,"("		;Start of comment?
	 JRST GTSCH3		;No, end of separator

; Here to skip over a comment (...)
GTSCH2:	CALL GTSLDB		;Fetch a byte
	IFNSK.
	  SETO B,		;eol before matching ")", fail
	  RETSKP		;Return +2 (special char)
	ENDIF.
	CAIN B,")"		;End of comment?
	 JRST GTSCH1		;Yes, back to skipping separtors
	JRST GTSCH2		;Find end of comment

; Here on end of a separator
GTSCH3:	CALL CHKSPC		;Special char after the separator?
	 RETSKP			;Yes, return it +2
	MOVEI B,.CHSPC		;Return " " for separator
	ADD C,[7B5]		;Back up input ptr/cnt
	AOJA D,R

; Here on end of line
GTSCH4:	MOVEI B,.CHCRT		;b := <cr>
	RETSKP			;Return +2 (special char)
; Routine to fetch a byte from a sender line.  Ignores null's and del's.
; Entry:   c/d = ptr/cnt to input line
; Call:    CALL GTSLDB
; Return:  +1, eol encountered
;	   +2, b = next char
GTSLDB:	SOJL D,R		;EOL if count exhausted
	ILDB B,C		;b := next char
	TXNE F,FP%DQT		;Quoted string?
	 RETSKP			;Yes, return whatever it is
	CAIE B,.CHNUL		;Null?
	 CAIN B,.CHDEL		;Or DEL
	  JRST GTSLDB		;Yes, ignore it
	RETSKP			;Got a char, return +2

; Routine to categorize special chars
; Entry:   b = char
; Call:    CALL CHKSPC
; Return:  +1, char part of address punctuation
;	   +2, char not part of punctuation
CHKSPC:	TXNE F,FP%DQT		;Quoted string?
	 RETSKP			;Yes, char can't be special
	CAIN B,.CHDQT		;Start of quoted string?
	 RET			;Yes
	CAIE B,"<"		;Part of <> address subfield?
	 CAIN B,">"
	  RET			;Yes
	CAIN B,"@"		;Start of host field?
	 RET			;Yes
	CAIE B,","		;Human intervention required?
	 CAIN B,";"
	  JRST CHKSP0		;Yes
	CAIN B,":"		;Human intervention required?
	 JRST CHKSP0		;Yes
	RETSKP

; Here char is not a recognized punctuation char but is not part of
; regular name either..
CHKSP0:	SETO B,
	RET
;; Premature EOF
QUEEOF:	CALL QUEBAD		;Setup message back to luser
	HRROI B,[ASCIZ/Premature end of file, /]
	SOUT%
	JRST QUEBDR		;Finish up

;; Bad control parameter specification
QUEBPM:	CALL QUEBAD
	HRROI B,[ASCIZ/Bad control parameter in line "/]
QUEBP0:	SOUT%
	CALL PARSTR
	MOVE B,C
	MOVN C,D
	SOUT%
	SETZ C,
	JRST QUEBH1

;; Here on invalid sender spec

GQUSDB:	CALL QUEBAD		;Too many, set up neg ack file
	HRROI B,[ASCIZ/Invalid sender specification.
/]
	SETZ C,			;Print the bad news
	SOUT%
	JRST QUEBDF		;Abort

;; Bad host
QUEBHS:	CALL QUEBAD
	HRROI B,[ASCIZ/No such host as "/]
	SOUT%
	HRROI B,HSTBUF
	SOUT%
QUEBH1:	HRROI B,[ASCIZ/",
/]
	SOUT%
QUEBDR:	SKIPE MSGJFN(M)
	 SKIPN MSGPAG(M)
	IFSKP.
	  HRROI B,[ASCIZ/bad queue file follows:
-------
/]
	  SETZ C,
	  SOUT%
	  PUSH P,A
	  HRRZ A,MSGJFN(M)
	  SIZEF%
	  IFNSK.
	    HLRZ B,MSGPAG(M)
	    IMULI B,5000
	  ENDIF.
	  POP P,A
	  MOVN C,B
	  HRRZ B,MSGPAG(M)
	  IMULI B,1000
	  HRLI B,(<POINT 7,0>)
	  SKIPGE C
	   SOUT%
	  HRROI B,[ASCIZ/
-------
/]
	  SETZ C,
	  SOUT%
	  CLOSF%
	   JFATAL <Could not close queue file>
	  HRRZ A,MSGJFN(M)	;Get back file jfn
	  PUSH P,A		;Save it
	  TXO A,CO%NRJ
	  CALL UNMQUF		;Unmap
	   NOP
	  POP P,A		;And get rid of it
	  DELF%
	   JWARN <Could not delete bad queue file>
	  JRST QUEBRT
	ENDIF.
	HRROI B,[ASCIZ/ file renamed to /]
	SOUT%
QUEBDF:	CALL RENBAD		;Rename file as bad
	HRROI B,STRBUF
	SETZ C,
	SOUT%
	HRROI B,[ASCIZ/
-------
/]
	SOUT%
	CLOSF%
	 JFATAL <Could not close queue file>

;; Bad return
QUEBRT:	CALL RELQUE		;Free entry
	MOVE P,MPP		;Undo excess pushes
	RET			;Single return
;;; Release storage from queue entry in M
RELQUE:	PUSH P,A
	PUSH P,B
	PUSH P,N
	PUSH P,O
	HRRZ B,MSGNHD(M)	;Are there any headers allocated?
	SKIPE B
	 CALL FREBLK
	HRRZ A,MSGJFN(M)
	CALL UNMQUF		;Unmap queue
	 NOP			;Can't happen
	SKIPE N,MSGRCP(M)	;Any network recipients?
	 CALL RELQHS		;Yes, release the list buffers
	SKIPE O,MSGLCL(M)	;Local recipients?
	 CALL RELQLS		;Yes, release them
	SKIPE N,MSGSDR(M)	;Any "sender" specification?
	 CALL RELQHS		;Yes, release it
	SKIPE B,MSGRPT(M)	;Any return path specification?
	 CALL FREBLK		;Free the return path
	MOVEI B,(M)		;Release the message block itself
	CALL FREBLK
	POP P,O
	POP P,N
	JRST POPBAJ
; Routine to chase down a list of hosts/recipients, releasing the
; free space blocks in use.
; Entry:   n = adr of first host entry
; Call:    CALL RELQHS
; Return:  +1

RELQHS:	DO.
	  SKIPE O,HSTRCP(N)	;Any recipients for this host?
	   CALL RELQLS		;Yes, release them
	  MOVEI B,(N)
	  HRRZ N,HSTFLG(N)	;Link to next
	  CALL FREBLK		;Free this host block
	  JUMPN N,TOP.		;Do them all
	ENDDO.
	RET

; Routine to chase down a list of recipients, releasing the free space
; blocks in use for names and error msgs
; Entry:   o = adr of first recipient entry
; Call:    CALL RELQLS
; Return:  +1

RELQLS:	DO.
	  MOVX B,FR%ERM		;Consed error message
	  TDNN B,RCPFLG(O)
	  IFSKP.
	    MOVE B,RCPERR(O)	;b := error message block adr
	    CALL FREBLK		;Free it up
	  ENDIF.
	  MOVX B,FR%STR		;Locally generated string for name?
	  TDNN B,RCPFLG(O)
	  IFSKP.
	    HRRZ B,RCPBPT(O)	;Yes, can free it then
	    CALL FREBLK
	  ENDIF.
	  MOVEI B,(O)
	  HRRZ O,RCPFLG(O)	;Link to next one
	  CALL FREBLK		;Free this recipient block
	  JUMPN O,TOP.		;Do them all
	ENDDO.
	RET
; Routine to reset the error flags for a recipient
; Entry:   o = adr of recipient block
; Call:    CALL RSTRCP
; Return:  +1, flags cleared and error msg block freed
; No AC's clobbered

RSTRCP:	SAVEAC <B>
	MOVX B,FR%ERM		;Consed error message?
	TDNN B,RCPFLG(O)
	IFSKP.
	  MOVE B,RCPERR(O)	;b := error message?
	  CALL FREBLK		;Free it up
	ENDIF.
	MOVX B,FR%FAI!FR%TMP!FR%ERM ;Clear the error flags
	ANDCAM B,RCPFLG(O)
	RET
; Routine to update error information for all recipients at a given
; host.  If error message is already present, it is left as is unless
; the severity of the error increases from TMP to FAI.
; Entry:   b = error flags
;	   strbuf = error msg
;	   saven = ptr to host block
; Call:    CALL STUMSG
; Return:  +1 always
STUMSG:	SKIPG N,SAVEN		;n := ptr to starting recipient host
	 RET			;None
	MOVEI O,HSTRCP(N)	;o := recipient list adr for this host
STUMS0:	DO.
	  CALL NXTRCP		;Get the next recipient
	   RET			;No more, quit
	  JN FR%FAI,RCPFLG(O),TOP. ;Leave alone if recipient already lost hard
	  TXNE B,FR%FAI		;Increasing soft to hard?
	   CALL RSTRCP		;Yes, clear out the old stuff
	  CALL STEMSG		;Install new failure flags and msg
	  LOOP.			;Do next recipient
	ENDDO.

; Routine to install failure information for addressee
; Entry:   b = error flags
;	   strbuf = error msg (attached to user if FR%ERM on in b)
;	   o = adr of recipient block
; Call:    CALL STEMSG
; Return:  +1 always
STEMSG:	SAVEAC <A>
	JN FR%FAI,RCPFLG(O),R	;Leave alone if recipient already lost hard
	IFXN. B,FR%ERM		;Append error msg now?
	ANDQE. FR%ERM,RCPFLG(O)	;Yes, but not if a message installed already
	  MOVEI A,STRBUF	;a := ptr to last response
	  PUSH P,B		;Save flags
	  CALL CPYSTR		;Get a copy
	  MOVEM B,RCPERR(O)	;Install it
	  POP P,B
	ENDIF.
	IORM B,RCPFLG(O)	;Flag failure type
	RET
; Routine to set up an appropriate failure msg for all hosts/recipients
; using the information already collected for hosts that were processed.
; If this is to dequeue the msg file, all errors become hard.  If it is
; just to notify the sender, temporary errors are conjured up.  Default
; errors are used when none came out of the processing.
; Entry:   m = adr of message block
; Call:    CALL SERRCP
; Return:  +1

SERRCP:	JSR SAVACS		;Save the ac's
	MOVE A,[POINT 7,STRBUF]	;Set up default error msg
	MOVEI B,[ASCIZ/Cannot append to mailbox/]
	CALL MOVST0
	MOVEI O,MSGLCL(M)	;Do locals first
	TXO F,FQ%DON		;We must have done the locals
	CALL SERRLS		;Hack this list
	MOVE A,[POINT 7,STRBUF]	;Set up default error msg
	MOVEI B,[ASCIZ/Cannot connect to host/]
	CALL MOVST0
	MOVEI N,MSGRCP(M)	;Now scan net recipients
	DO.
	  HRRZ N,(N)		;n := next host block adr
	  JUMPE N,R		;Quit on 0
	  MOVX B,FH%DON		;"Host done" set?
	  TDNN B,HSTFLG(N)
	   TXZA F,FQ%DON	;No, clear flag
	    TXO F,FQ%DON	;Yes, record fact
	  SKIPG NTDEQF		;Dequeueing msg?
	   IORM B,HSTFLG(N)	;Yes, always show host done
	  MOVEI O,HSTRCP(N)	;Do recipients for this host
	  CALL SERRLS
	  LOOP.			;Do all hosts
	ENDDO.
; Routine to scan a list of recipients and install failure/error
; Entry:   o = adr of recipient list
;	   strbuf = default error string if none already given
; Call:    CALL SERRLS
; Return:  +1

SERRLS:	DO.
	  HRRZ O,(O)		;o := adr of next recipient
	  JUMPE O,R		;Done with list
	  MOVE A,RCPFLG(O)	;Fetch recipient flags
	  JXN A,FR%FAI,TOP.	;Ignore if hard error already seen
	  IFXE. A,FR%TMP	;Any temporary error seen?
	    JXN F,FQ%DON,TOP.	;No, if host processed, assume recipients ok
	  ENDIF.
	  MOVX B,FR%ERM!FR%TMP	;If notifying sender, leave error temporary
	  SKIPL NTDEQF		;Dequeueing msg?
	  IFSKP.
	    ANDCAM B,RCPFLG(O)	;Yes, clear "temporary" error indicators
	    MOVX B,FR%ERM!FR%FAI ;And make error hard
	  ENDIF.
	  CALL STEMSG		;Set the error message
	  LOOP.			;Do all recipients at this host
	ENDDO.
; Here to unmap a queued msg file
UNMQUF:	MOVE D,MSGPAG(M)
	CALL UNMQU0
	 SKIPA
	  AOS (P)
	SETZM MSGJFN(M)
	SETZM MSGPAG(M)
	RET

UNMQU0:	JUMPE D,UNMQU1
	PUSH P,A
	HLRZ A,D
	HRRZ B,D
	CALL PAGDAL
	POP P,A
UNMQU1:	JUMPE A,R
	TXZN A,CO%NRJ		;Don't release JFNs?
	IFSKP.
	  PUSH P,A		;Yes, save JFN
	  HRROI A,STRBF1	;Buffer to put filename string into
	  HRRZ B,(P)		;JFN to release
	  MOVE C,[111110,,JS%PAF] ;Dev/dir/nam/ext/gen, punctuate
	  JFNS%			;Get string for this file
	  IFJER.
	    ADJSP P,-1
	    RET			;In case JFN already released somehow
	  ENDIF.
	  MOVX A,GJ%SHT!GJ%OLD!GJ%DEL ;Now get another JFN
	  HRROI B,STRBF1	;On the same filename
	  GTJFN%		;Get virgin JFN in A
	  IFJER.
	    POP P,A		;Get back JFN
	    CLOSF%		;Flush it
	     NOP		;Don't care if it failed
	    RET
	  ENDIF.
	  POP P,B		;Old JFN in B
	  SWJFN%		;Make old JFN caller know about virgin JFN
	ENDIF.
	CLOSF%			;Flush the JFN
	 JWARN <Error closing queue file in UNMQUF>
	RETSKP
;;; Create a response queue file for a bad one
QUEBAD:	CALL RESPQF		;Initialize the file
	CALL SDRADR		;Addressee = sender
	CALL RESPQB		;Finish up the file
	HRRZ B,MSGJFN(M)
	MOVE C,[111110,,1]
	JFNS%
	HRROI B,[ASCIZ/

/]
	SETZ C,
	SOUT%
	RET

;;; Rename a bad file
RENBAX:	PUSH P,A		;Save a
	PUSH P,A		;Save the JFN
	JRST RENBA0

RENBAD:	PUSH P,A		;Save present JFN
	HRRZ A,MSGJFN(M)
	PUSH P,A
	TXO A,CO%NRJ
	CALL UNMQUF		;Unmap, leave JFN
	IFNSK.
	  ADJSP P,-1
	  JRST CPOPAJ
	ENDIF.
RENBA0:	HRROI A,STRBUF
	HRRZ B,(P)
	MOVE C,[110000,,1]
	JFNS%
	MOVE B,FILIDX		;b := index to current file type
	HRRZ B,%FLSTR(B)	;b := ptr to "bad file" name
	CALL MOVSTR
	HRROI B,[ASCIZ/;P770000/]
	SETZ C,
	SOUT%
	DO.
	  MOVX A,GJ%NEW!GJ%FOU!GJ%SHT
	  HRROI B,STRBUF
	  GTJFN%
	  IFJER.
	    CAIE A,GJFX24	;Work around monitor bug
	     JWARN <Cannot get BAD file>
	    MOVEI A,^D5000	;Wait 5 seconds
	    DISMS%
	    LOOP.
	  ENDIF.
	ENDDO.
	MOVE B,A
	POP P,A
	CALL RNMFIL		;Rename the file
	IFNSK.
	  JWARN <Cannot rename BAD file>
	  EXCH A,B		;A:=existing JFN, B:=JFN we failed to rename to
	  RLJFN%		;Flush the failing JFN
	   NOP
	ENDIF.
	HRROI A,STRBUF
	MOVE C,[111110,,1]
	JFNS%
	MOVE A,B
	RLJFN%
	 JWARN
	JRST CPOPAJ
;;; Create a response queue file

RESPQN:	SKIPA A,[[ASCIZ/[--RETURNED-MAIL--].NEW-NOTIFY-/]]
RESPQF:	 MOVEI A,[ASCIZ/[--RETURNED-MAIL--].NEW-FAILURE-/]
	STKVAR <<GTJARG,2>,TMPJFN,RESPQT>
	MOVEM A,RESPQT		;Save queue type
	HRROI A,STRBUF		;Put this file where msg file came from
	HRRZ B,MSGJFN(M)
	MOVE C,[110000,,1]
	JFNS%
	MOVE B,RESPQT
	CALL MOVSTR
	MOVE B,FORKX
	MOVX C,^D8
	NOUT%
	 JFATAL
	MOVEI B,[ASCIZ/;P770000/]
	CALL MOVST0
	MOVX A,GJ%NEW!GJ%FOU!GJ%SHT
	HRROI B,STRBUF
	SETZ C,
	DMOVEM A,GTJARG		;Save the args
	DO.
	  DMOVE A,GTJARG	;Install args
	  GTJFN%
	  IFJER.
	    CAIE A,GJFX24	;Work around monitor bug
	     JWARN <Cannot get queue file>
	    MOVEI A,^D5000	;Wait 5 seconds
	    DISMS%
	    LOOP.
	  ENDIF.
	  MOVEM A,TMPJFN	;Save the JFN
	  MOVX B,<<FLD ^D7,OF%BSZ>!OF%WR>
	  OPENF%
	  IFJER.
	    EXCH A,TMPJFN	;Recover JFN, save error code
	    RLJFN%		;Release it
	     JWARN
	    MOVEI A,^D5000	;Wait a few seconds
	    DISMS%
	    MOVE A,TMPJFN	;Recover error code
	    CAIE A,OPNX9	;No error if file just busy
	     CAIN A,OPNX2	;File disappeared?
	      LOOP.		;Yes, try again
	    WARN <Cannot open queue file - %1E>
	    LOOP.
	  ENDIF.
	ENDDO.
	HRLI A,.FBBYV		;Set to retain infinite versions
	MOVX B,FB%RET
	SETZ C,
	CHFDB%
	HRRZS A			;a := output JFN
	CALLRET SDRMLA		;Write the sender header = mail agent

	ENDSV.
;; Here to set up "DISCARD-ON-ERROR" parameter
; Entry:   a = output jfn
DSCRDE:	MOVEI B,.CHFFD		;Signal parameter start
	BOUT%
	HRROI B,[ASCIZ/=DISCARD-ON-ERROR
/]
	SETZ C,
	SOUT%
	RET

; Here to finish up reply file header
RESPQB:	MOVEI B,.CHFFD		;Terminate addressee headers
	BOUT%
	HRROI B,[ASCIZ/
Date: /]
	SOUT%
	SETO B,			;Now
	MOVX C,OT%DAY!OT%SPA!OT%TMZ!OT%SCL!OT%822 ;RFC 822 standard date/time
	ODTIM%
	HRROI B,[ASCIZ/
From: The Mailer Daemon </]	;> -- so MACRO doesn't fail
	SETZ C,
	SOUT%
	HRROI B,MLAGNT		;Use MLAGNT so user can reply
	SOUT%
	MOVEI B,"@"
	BOUT%
	MOVEI B,.CHDEL
	BOUT%
	HRROI B,LCLNAM		;Get local host name string
	SOUT%
	MOVEI B,.CHDEL
	BOUT%
	HRROI B,[ASCIZ/>
To: /]
	SOUT%
	MOVE D,MSGSDR(M)	;d := entry adr for sender
	HRRZ C,HSTRCP(D)
	MOVE B,RCPBPT(C)	;b,c := ptr,-cnt to sender name string
	MOVN C,RCPCNT(C)
	SOUT%			;write the sender's address
	MOVEI B,"@"
	BOUT%
	MOVEI B,.CHDEL
	BOUT%
	HRRO B,HSTHST(D)	;Get the host pointer
	SOUT%
	MOVEI B,.CHDEL
	BOUT%
	HRROI B,[ASCIZ/
Subject: /]
	SOUT%
	RET

; Routine to output the sender as "sender" or "addressee" in mail file
; header
; Entry:   a = output JFN
;	   m = ptr to queued msg block
; Call:    CALL SDRHDR ("sender" = sender)
;	  CALL SDRADR ("addressee" = sender)
; Return:  +1, b = ptr to sender host string
SDRHDR:	MOVEI B,.CHFFD		;Do ff to signal host
	BOUT%
	MOVX B,"_"		;Flag "sender" header
	SKIPA
SDRADR:	 MOVX B,.CHFFD		;Do ff to signal host
	BOUT%
	PUSH P,C		;Save ac's
	PUSH P,D
	MOVE D,MSGSDR(M)	;d := hst entry adr for sender
	HRRO B,HSTHST(D)	;b := file site tbl adr for host
	SETZ C,
	SOUT%
	HRROI B,CRLF0		;Terminate line
	SOUT%
	HRRZ C,HSTRCP(D)	;d := adr of sender recipient list
	MOVE B,RCPBPT(C)	;b,c := ptr,-cnt to sender name string
	MOVN C,RCPCNT(C)
	SOUT%
	HRROI B,CRLF0		;Terminate line
	SOUT%
	POP P,D			;Recover working ac's
	POP P,C
	RET

; Routine to output a "sender" = mail agent header
; Entry:   a = output JFN
; Call:    CALL SDRMLA ("sender" = mail agent)
; 	   CALL MLAADR ("addressee" = mail agent)
; Return:  +1
SDRMLA:	MOVEI B,.CHFFD		;Do ff to signal host
	BOUT%
	MOVX B,"_"		;Flag "sender" header
	SKIPA
MLAADR:	 MOVX B,.CHFFD		;Do ff to signal host
	BOUT%
	HRROI B,LCLNAM		;Get local name string
	SETZ C,
	SOUT%
	HRROI B,CRLF0
	SOUT%
	HRROI B,MLAGNT		;Now the mail agent's name
	SOUT%
	HRROI B,CRLF0
	SOUT%
	RET
;;; Generate headers for message in M to host in A
;  B has the ultimate host pointer while A has the "neighbor" host
;     host pointer

GENHDL:	SETZ A,			;Local host; no special transmogrification
	SKIPA E,[LCLNAM]	;Don't convert LCLNAM to LCLNCN
GENHDR:	 MOVEI E,LCLNCN		;Convert LCLNAM to LCLNCN
	JSR SAVACS		;Save all AC's
	STKVAR <LCLHPT,DSTHPT,<HSTTMP,^D52>,LINCNT,ULTHPT>
	MOVEM B,ULTHPT		;Save ultimate destination host pointer
	MOVEM A,DSTHPT		;Save destination host pointer
	MOVEM E,LCLHPT		;Save local name pointer
	DMOVE X,MSGHDR(M)	;Start of headers of message
	SKIPN O,MSGNHD(M)	;Was there a block from last time?
	IFSKP.
	  HRRZ A,-1(O)		;Get size of block
	ELSE.
	  MOVEI A,100		;Nominal block to allocate
	  CALL ALCBLK
	   FATAL <Memory exhausted>
	  MOVEI O,(B)
	  MOVEM O,MSGNHD(M)
	ENDIF.
	HRLI O,(<POINT 7,0>)
	MOVEI N,(A)
	IMULI N,5		;Number of bytes available
	MOVEM N,HDRLEN		;Save it in case we grow
	DO.			;Output BP in O, free byte count in N
	  DMOVEM X,MSGTXT(M)
	  CALL PARLIN		;Read a line
	  IFNSK.
	    MOVE C,[POINT 7,CRLF0] ;Failed, just write CRLF
	    MOVEI D,2
	    EXIT.
	  ENDIF.
	  IFXN. F,FP%EOL	;Blank line?
	    DMOVEM X,MSGTXT(M)	;Update start of actual message text
	    MOVE C,[POINT 7,[BYTE (7) .CHCRT,.CHLFD,.CHCRT,.CHLFD,.CHNUL]]
	    MOVEI D,4
	    EXIT.		;Yes, finish up then
	  ENDIF.
	  IFXE. F,FP%CLN!FP%WSP	;Looks like a valid line?
	    MOVE C,[POINT 7,CRLF0] ;No, just write CRLF
	    MOVEI D,2
	    EXIT.
	  ENDIF.
	  IFXE. F,FP%DEL	;Is this a special line?
	    CALL OUHNWL		;New line
	    CALL PARSTR		;Get whole line
	    CALL OUHSTR		;Finish
	    LOOP.		;And go hack next line
	  ENDIF.
	  MOVE T,PLINBP+1	;Save line context (may get host error)
	  MOVEM T,LINCNT
	  CALL PARDEL		;Canonicalize lengths
	  DMOVE C,PDELBP	;Start of host
	  CALL PARHST		;Parse it
	  IFNSK.
	    MOVE T,LINCNT	;Bad host!  Restore line context
	    MOVEM T,PLINBP+1
	    CALL OUHNWL		;Make like never saw <del>'s
	    CALL PARSTR		;Get whole line
	    CALL OUHSTR		;Output it
	    LOOP.		;And go hack next line
	  ENDIF.
	  MOVEI A,HSTTMP	;Copy returned string so we can muck it
	  HRLI A,(<POINT 7,>)	;Make string pointer
	  MOVEM A,PDELBP	;Save pointer
	  CAIN B,LCLNAM		;Local host name returned?
	   MOVE B,LCLHPT	;Yes, use local name for this network
	  MOVE C,ULTHPT		;Ultimate destination host pointer
	  MOVE D,DSTHPT		;Destination host pointer
	  CALL TRNMGR		;Transmogrify host
	  IFSKP.
	    SOS PLINBP+1	;Flush "@" preceeding
	    SOS PWSPBP+1
	  ENDIF.
	  SETZ C,		;Now count its length
	  DO.
	    ILDB B,A		;Get byte
	    CAIE B,.CHNUL	;Null?
	     AOJA C,TOP.	;No, count it and do another
	  ENDDO.
	  MOVEM C,PDELBP+1	;Save length too
	  IFXN. F,FP%WSP	;Is this a continuation line?
	    MOVEI T,1(E)	;Length of line so far, plus a new space
	    ADD T,PWSPBP+1	;Plus line without whitespace
	    ADD T,PDELBP+1	;Plus start of host
	    ADD T,PDELB2+1	;Plus end of host
	    CAIL T,^D79		;Is that a reasonable length line?
	    IFSKP.
	      MOVEI T,.CHSPC	;Yes, put in a space
	      CALL OUHCHR
	      DMOVE C,PWSPBP	;And use start of stuff after whitespace
	    ELSE.
	      CALL OUHNWL	;New line
	      DMOVE C,PLINBP	;Use start of line
	    ENDIF.
	  ELSE.
	    CALL OUHNWL		;New line
	    DMOVE C,PLINBP	;Use start of line
	  ENDIF.
	  CALL OUHSTR		;Output it
	  DMOVE C,PDELBP	;First part of host
	  CALL OUHSTR		;Output that
	  DMOVE C,PDELB2	;Rest of line
	  CALL OUHSTR		;Finish
	  LOOP.			;And go hack next line
	ENDDO.
	CALL OUHSTR
	MOVE T,MSGNHD(M)
	HRRZ T,-1(T)		;Length of block
	IMULI T,5		;Total bytes
	SUB T,N			;Less bytes left is bytes used
	HRLM T,MSGNHD(M)
	RET

	ENDSV.
;TRNMGR - transmogrify host name for destination host
; A/ output byte pointer
; B/ host pointer
; C/ ultimate destination host pointer
; D/ destination host pointer
;   Returns +1 if no transmogrification is needed
;	   +2 if transmogrified so preceeding "@" should be flushed.
;
TRNMGR:	SAVEAC <A,B,C,D>	;Don't clobber invoker's context
	STKVAR <BUFPTR,SRCPTR,DSTPTR,DOMPTR,ULTPTR,UPPLIM,INTDOM,ATPTR>
	MOVEM A,BUFPTR		;Save the output buffer pointer
	HRRZM B,SRCPTR		;Save source pointer
	MOVEM C,ULTPTR		;Ultimate destination pointer
	HRRZM D,DSTPTR		;Save destination pointer
	CALL MOVST0		;Make copy of src to output buffer
	MOVE A,BUFPTR		;Remove relative domains
	CALL $RMREL

;  Don't transmogrify if the source and destination are on the same network
; providing that network is a full-connectivity net.  At the present time,
; only Special is not (or rather is not guaranteed to be such).  This tries
; to avoid unnecessary transmogrification.
	MOVE A,SRCPTR		;Check source
	HRLI A,(<POINT 7,>)
	SETZM DOMPTR		;Look for relative domain
	DO.
	  ILDB B,A
	  IFN. B
	    CAIN B,"."
	     MOVEM A,DOMPTR
	    LOOP.
	  ENDIF.
	ENDDO.
	ILDB A,DOMPTR		;Now see if it's really relative
	CAIE A,"#"
	IFSKP.
	  MOVE A,DOMPTR		;It is, see if it's a full-connectivity net
	  HRROI B,[ASCIZ/Special/] ;"Special" is the only one that isn't
	  STCMP%
	ANDN. A			;Full-connectivity net?
	  MOVE A,ULTPTR		;Check destination
	  HRLI A,(<POINT 7,>)
	  SETZM ATPTR		;Look for relative domain in destination
	  DO.
	    ILDB B,A
	    IFN. B
	      CAIN B,"."
	       MOVEM A,ATPTR
	      LOOP.
	    ENDIF.
	  ENDDO.
	  ILDB A,ATPTR		;Now see if it's really relative
	  CAIE A,"#"
	ANSKP.
	  MOVE A,DOMPTR		;It is, see if it's the same net
	  MOVE B,ATPTR
	  STCMP%
	  JUMPE A,R		;If the same, then no transmogrification
	ENDIF.

	SETZM DOMPTR		;See if there is a real domain
	MOVE A,BUFPTR
	DO.
	  ILDB B,A
	  IFN. B
	    CAIN B,"."		;Domain separator?
	     MOVEM A,DOMPTR	;Save the pointer for later
	    LOOP.
	  ENDIF.
	ENDDO.
	SKIPN B,DOMPTR		;Is there a domain?
	IFSKP.
	  MOVE A,DOMTBL		;Yes, it one of the pseudo-domains?
	  TBLUK%
	  IFXE. B,TL%EXM	;Found it?
	    SKIPN TRALLP	;No, do we always transmogrify?
	     RET		;No, no transmogrification needed then
	  ELSE.
	    SETZ C,
	    DPB C,DOMPTR	;Remove pseudo-domain
	    MOVE A,DOMPTR	;Pointer to pseudo-domain
	    HRROI B,[ASCIZ/$Internet/]
	    STCMP%		;See if going to Internet
	    JUMPE A,R		;Yes, so don't bother transmogrifying
	  ENDIF.
	ENDIF.

;Try to transmogrify the source so that the destination will know about it
	SKIPN DSTPTR		;Local delivery?
	 RET			;Yes, return
	MOVE A,SRCPTR		;The source host
	MOVE B,ULTPTR		;This destination host
	CALL TRNBLD		;Build relay tables, SRLYTB, DRLYTB
	SETZM PTHLST		;Set the first element of the path 0 to start

;Find the Internet domain block address; save it in INTDOM
	MOVE A,DOMTBL		;Yes, is the domain relayed to?
	HRROI B,[ASCIZ/$Internet/]
	TBLUK%
	TXNE B,TL%NOM		;Find it?
	 TDZA B,B		;Didn't find it, Internet not defined here
	  HRRZ B,(A)		;Yes, get domain block address in B
	MOVEM B,INTDOM		;Internet domain block address

;Add the source host to our path first
	SKIPN A,INTDOM		;A/ domain block; is it in the Internet domain?
	IFSKP.
	  HRRZ B,DM%RLY(A)	;Get the relay pointer
	  CAME B,SRCPTR		;Is source host in Internet?
	ANSKP.
	  MOVEI B,DM%TRN	;Yes, it is Internet use transmog. string
	  CALL PTHADD		;Put it in the path
	  JRST BLDPTH		;Since Internet, jump directly to build path
	ENDIF.
	MOVE D,DOMTBL		;Set up aobjn pointer to domain table
	HLL D,(D)
	TXC D,.LHALF
	DO.			;Look for destination host
	  AOBJP D,ENDLP.	;Next domain
	  HRRZ A,(D)		;Get domain block
	  HRRZ C,DM%RLY(A)	;Get the host pointer
	  CAME C,SRCPTR		;Is it the same as the source host?
	   LOOP.		;No, go for more
	ENDDO.
	IFGE. D			;Is host a relay?
	  MOVE A,SRCPTR		;No
	  SETZ B,
	ELSE.			;Yes it is host relay
	  MOVEI B,DM%RLY	;Not Internet, use relay string
	ENDIF.
	CALL PTHADD		;Add this host

;One last chance to check if we really need to transmogrify
	MOVE A,SRCPTR
	CAMN A,ULTPTR		;If source and destinations are the same
	 RET			;Then no need to do anything!

;Ascend the source table
	SKIPN SNRLYS		;Any relays in source?
	IFSKP.			;Yes, let's process
	  SETZ D,		;Start at the bottom
	  DO.
	    MOVE A,SRLYTB(D)	;Get the domain block pointer
	    MOVEI B,DM%RLY	;Which transmogrification string to use
	    CALL PTHADD		;Add this relay to the path construct
	    CAMN A,INTDOM	;Is it magic Internet domain?
	     JRST BLDPTH	;Yes, jump out
	    ADDI D,1		;Increment index
	    CAMGE D,SNRLYS	;Less than the number of relays?
	     LOOP.		;Yes, loop around
	  ENDDO.
	ENDIF.

;Add our local host here
	MOVEI A,LCLNCN		;Our local name
	SETZ B,			;Only a string
	CALL PTHADD		;Add it to path

;now descend destination table

	SKIPN D,DNRLYS		;Any relays in destination?
	IFSKP.			;Yes, let's process
	  SUBI D,1		;Index to start with
	  DO.
	    MOVE A,DRLYTB(D)	;Get the domain block pointer
	    MOVEI B,DM%TRN	;Which transmogrification string to use
	    CALL PTHADD		;Add this relay to the path construct
	    CAMN A,INTDOM	;Is it magic Internet domain?
	     JRST BLDPTH	;Yes, jump out
	    SOJGE D,TOP.	;If not bottom of the table, loop.
	  ENDDO.
	ENDIF.

;Build the transmogified path using PTHLST

BLDPTH:	SKIPN DNRLYS		;From destination to source?
	 SKIPN PTHEND		;More than one in the path?
	IFSKP.
	  MOVE D,PTHEND		;Yes, get the offet of the last entry
	  DO.
	    HLRZ C,PTHLST(D)	;Get the domain flags
	    IFE. C		;Is it a plain string?
	      HRRZ A,PTHLST(D)	;Yes, get the string address
	    ELSE.		;Not a string, it is a domain block
	      HRRZ B,PTHLST(D)	;Get the domain block
	      HRRZ A,DM%RLY(B)	;Get a string pointer
	    ENDIF.
	    CAME A,DSTPTR	;Is it the same as the destination
	    IFSKP.
	      SETZM PTHLST(D)	;Yes, zap it from the list
	      EXIT.		;And done
	    ENDIF.
	    SOJG D,TOP.		;Otherwise loop until done
	  ENDDO.
	ENDIF.
	MOVE B,BUFPTR
	SETZ A,
	IDPB A,B		;Re-init output string by putting a zero
	MOVEI D,PTHLST		;Start at the beginning of the path list
	DO.
	  HLRZ C,(D)		;Get the flag of the entry
	  IFE. C		;Is it a string pointer?
	    HRRZ B,(D)		;Yes, get the address
	    MOVE A,[POINT 7,STRBF2]
	    CALL MOVST0		;Make a copy of the string
	    MOVEI A,STRBF2
	    CALL RMDOM1		;Remove the pseudo-domain
	    MOVE B,[POINT 7,STRBF2]
	    MOVEI C,"%"		;Use a % for relaying
	  ELSE.			;Not a string pointer, but a domain pointer
	    HRRZ B,(D)		;Get the domain block pointer
	    CAIE C,DM%TRN	;Use transmog. string as host name relay?
	    IFSKP.		;Yes, no need to fool around with domains
	      MOVE B,DM%TRN(B)
	      HRLI B,(<POINT 7,>) ;Point to the transmog. string
	      ILDB C,B		;Get the relay character
	    ELSE.		;Use relay string as host name relay
	      PUSH P,B		;Save the domain pointer
	      MOVE B,DM%TRN(B)
	      HRLI B,(<POINT 7,>) ;Point to the transmogrification string
	      ILDB C,B		;And get the relay character
	      POP P,B		;Now get the domain block pointer back
	      MOVE B,DM%RLY(B)
	      HRLI B,(<POINT 7,>) ;Point to the relay string instead
	      MOVE A,[POINT 7,STRBF2]
	      CALL MOVST0	;Make a copy of the relay string
	      MOVEI A,STRBF2
	      CALL RMDOM1	;Get rid of the pseudo-domain
	      MOVE B,[POINT 7,STRBF2]
	    ENDIF.
	  ENDIF.

;A/ output buffer B/ string to append C/ prepend character
	  MOVE A,BUFPTR
	  CALL HSTAPP		;Append this host to path
	  MOVEM B,ATPTR		;Save the byte pointer to the last @ sign
	  ADDI D,1		;Look at next element in path list
	  SKIPE (D)		;End of list?
	   LOOP.		;No, loop
	ENDDO.
	MOVEI A,"@"		;The last relay character must be @ sign
	DPB A,ATPTR		;Put it there
	RETSKP			;Say we did a transmogrification

	ENDSV.

;A/ byte pointer to host string to tweak
;
;Returns +1 always
;	 no change to ACS; string should be tweaked
;
RMDOM1:	SAVEAC <A,B,C>
	STKVAR <DOMPTR>
	HRLI A,(<POINT 7,>)
	CALL $RMREL
	SETZM DOMPTR		;See if there is a real domain
	DO.
	  ILDB B,A		;Get a character from the string
	  IFN. B		;Null (end of string)?
	    CAIN B,"."		;Nope, check if domain separator
	     MOVEM A,DOMPTR	;Yes, save the pointer for later
	    LOOP.		;Back for more
	  ENDIF.
	ENDDO.
	SKIPN B,DOMPTR		;See a domain?
	IFSKP.
	  MOVE A,DOMTBL		;Look at know domains
	  TBLUK%		;Is it one of ours?
	  JXE B,TL%EXM,R	;No, don't do anything
	  SETZ A,		;Yes, remove pseudo-domain
	  DPB A,DOMPTR
	ENDIF.
	RET

	ENDSV.

;A/ output byte pointer
;B/ string pointer
;C/ prepend character
;
; Returns +1 always
;       B has byte pointer where prepend character was put
;
HSTAPP:	SAVEAC <A,C,D>
	STKVAR <STRPTR>
	MOVEM B,STRPTR		;Save string pointer
	DO.			;Look for null at end of string
	  ILDB B,A		;Get a character
	  JUMPN B,TOP.		;If not null step through string
	ENDDO.
	MOVE D,A		;Save the atsign pointer
	DPB C,A			;Put the prepend character into string
	MOVE B,STRPTR		;Get the string pointer again
	CALL MOVST2		;Append the string
	MOVE B,D		;Here is the atsign pointer
	RET

	ENDSV.

;A/ byte pointer to the source host
;B/ byte pointer to the ultimate destination host
;
;   Returns +1 always
; This routine builds the relay tables SRLYTB and DRLYTB.
; SNRLYS and DNRLYS are updated to reflect the number of relay entries
; in the respective tables.
;
TRNBLD:	SAVEAC <A,B>
	STKVAR <DSTPTR>
	MOVEM B,DSTPTR		;Save destination pointer
	CALL SRCPTH		;Build source table
	MOVE A,DSTPTR		;Get the destination pointer back
	CALLRET DSTPTH		;Build destination table

	ENDSV.

;A/ host pointer to source host
;   Returns +1 always
SRCPTH:	SAVEAC <A,B,C,D>
	STKVAR <SRCPTR>
	MOVEM A,SRCPTR
	SETZM SNRLYS		;No relays yet
;Test for local host here if source is local return
	HRRZ A,SRCPTR		;Get source pointer
	CAIN A,LCLNCN		;Local host
	 RET

;First do source.  Find a path from the source host to us
	DO.
	  HRRO A,SRCPTR		;Get name of host to check
	  MOVEI C,SNDRTS	;Try direct protocols first
	  CALL GETPRO		;Is it directly connected to us?
	  IFSKP.
	    CAME B,$UKHST	;Do the relay thing if we really don't know
	     RET		;Looks good, return
	  ENDIF.
	  HRRO A,SRCPTR		;Get the host to find relay for
	  CALL $GTRLY		;Get the relay
	   RET
	  MOVE A,DM%RLY(B)	;Get the pointer
	  MOVEM A,SRCPTR	;Save it as the next host pointer
	  MOVE A,SNRLYS		;Get the number of relays
	  MOVEM B,SRLYTB(A)	;Save the domain block pointer
	  AOS SNRLYS		;Increment number of relays we saw
	  LOOP.			;Go up and try again
	ENDDO.

	ENDSV.

;A/ pointer to destination host pointer
;  Returns +1 always
;Now do destination.  Find a path from the destination host to us
DSTPTH:	SAVEAC <A,B,C,D>
	STKVAR <DSTPTR>
	MOVEM A,DSTPTR
	SETZM DNRLYS
	HRRZ A,DSTPTR		;Get destination pointer
	CAIN A,LCLNCN		;Is it local?
	 RET			;Yes, return
	DO.
	  HRRO A,DSTPTR		;Get name of host to check
	  MOVEI C,SNDRTS	;Try direct protocols first
	  CALL GETPRO		;Is it directly connected to us?
	  IFSKP.
	    CAME B,$UKHST	;Do the relay thing if we really don't know
	     RET		;Looks good, return
	  ENDIF.
	  HRRO A,DSTPTR		;Get the host to find relay for
	  CALL $GTRLY		;Get the relay
	   RET			;Probably local host
	  MOVE A,DM%RLY(B)	;Get the pointer
	  MOVEM A,DSTPTR	;Save it as the next host pointer
	  MOVE A,DNRLYS		;Get the number of relays
	  MOVEM B,DRLYTB(A)	;Save the domain block pointer
	  AOS DNRLYS		;Increment number of relays we saw
	  LOOP.			;Go up and try again
	ENDDO.

	ENDSV.

;A/ domain block pointer or string pointer
;B/ if 0, A is string pointer
;   if non-zero, A is a domain block pointer and the value of B
;   is the offset into the domain block for transmogrification string
PTHADD: SAVEAC <A,B,C,D>
	SETZ D,
	HRRZ A,A		;Only address, just in case
	DO.			;Step through list looking for duplicates
	  SKIPN C,PTHLST(D)	;Get element from path list
	  IFSKP.
	    HRRZ C,C		;Only the address
	    CAMN C,A		;Are the 2 domains the same?
	     EXIT.		;Yes, out of loop
	    ADDI D,1		;No, incr. index
	    LOOP.
	  ENDIF.
	ENDDO.
;D/ where to put the domain or string pointer
	HRL A,B			;Move the flag bits to LH of A
	MOVEM A,PTHLST(D)	;Save the next path
	MOVEM D,PTHEND		;Save the end of the list
	ADDI D,1		;Next location
	SETZM PTHLST(D)		;Zero the next location to end list
	RET
;;; Header string output routines, byte pointer is in O,
;;; count of bytes left is in N, length of line is in E
OUHNWL:	DMOVE C,[POINT 7,CRLF0
		 2]
	TDZA E,E		;Init to 0
OUHSTR:	 ADDI E,(D)		;Update length of line
	JUMPE D,R		;Nothing if empty string
	SAVEAC <C,D>
	DO.
	  ILDB T,C
	  CALL OUHCHR
	  SOJG D,TOP.
	ENDDO.
	RET

OUHCHG:	MOVE B,MSGNHD(M)
	HRRZ A,-1(B)		;Length of block now
	ADDI A,100		;Increment by this much
	SUBI O,(B)		;Make pointer relative in case relocated
	CALL GROBLK
	 FATAL <Memory exhausted>
	MOVEM B,MSGNHD(M)
	ADDI O,(B)		;Make pointer absolute again
	IMULI A,5		;Number of bytes total available
	MOVE N,HDRLEN		;Get previous size of block
	SUBM A,N		;Update now available
	MOVEM A,HDRLEN		;Update for current size
OUHCHR:	SOJL N,OUHCHG		;Room left in buffer?
	IDPB T,O		;Yes, just stick it in
	RET
	SUBTTL Sending routines

;;; Send the message in M
SNDMSG:	JSR SAVACS		;I don't know why, but it's necessary
	STKVAR <RLYLST>
	SETZM RLYLST
	TXZ F,FM%RLY		;Not relaying here
	MOVEI N,MSGRCP(M)	;Start of recipient list
	DO.
	  SKIPN MSGTMT(M)	;Total timeout for msg?
	  IFSKP.
	    TIME%		;Yes, elapsed yet?
	    CAML A,MSGTMT(M)
	     RETSKP		;Yes, quit on this round
	  ENDIF.
;The following loop looks for the next physical host.  If we are in the
;middle of relaying, it will try the next host in the list of possible
;relays.  Otherwise, it will try the next host in the list of recipient
;hosts.  The only exit from this loop is the success return from GETPTH.
;So after this loop, the AC's will be set as in GETPTH, for some
;physical host (i.e. if we have to relay, the relay host).
	  DO.			;Look for a host to send to
	    IFXE. F,FM%RLY	;Have we been relaying?
	      HRRZ N,(N)	;No, get next host
	      JUMPE N,RSKP	;None, done for now
	      MOVX TT,FH%DON	;Already done this one?
	      TDNE TT,HSTFLG(N)
	       LOOP.		;Yes, look at the next
	      HRRZ B,HSTHST(N)	;Get host pointer
	      CALL GETPTH	;Do we have a direct path?
	      IFSKP. <EXIT.>	;Yes, do it then
	      HRRO A,HSTHST(N)	;Get back the host
	      CALL $GTRLY	;See if we can relay to it
	       LOOP.		;No, so much for that host...
	      SKIPN B,DM%RLY(B)	;Get list of relays
	       LOOP.		;None
	      MOVEM B,RLYLST	;Initial current list pointer
	      TXO F,FM%RLY	;Note that we are relaying
	    ENDIF.
; Try to find physical host to send to.  This will recurse as necessary.
;Someday this routine needs to be rewritten to be somewhat more general and
;allow more flexibility in MAILER-RELAY-INFO.TXT.
	    DO.
	      MOVE B,RLYLST	;Get current relay list pointer
	      CALL GETPTH	;Have a path to this relay?
	      IFSKP. <EXIT.>
	      HRRO A,RLYLST	;Let's see if we can relay to it
	      CALL $GTRLY	;Well?
	      IFSKP.
		MOVE B,DM%RLY(B) ;Yes, get host we can relay to
	      ELSE.
		HLRZ B,RLYLST	;Get pointer to more
		SKIPE B		;Is there?
		 MOVE B,(B)	;Yes, go get it
	      ENDIF.
	      MOVEM B,RLYLST	;Save current pointer
	      JUMPN B,TOP.	;Try again if any more to go
	    ENDDO.
	    IFE. B		;Found a host to send this to?
	      TXZ F,FM%RLY	;No, fail utterly
	      LOOP.		;Do next host
	    ENDIF.
	  ENDDO.
	  MOVX TT,FH%DN1	;Mark that we are trying to do this one
	  IORM TT,HSTFLG(N)
	  MOVEI O,HSTRCP(N)	;Point to start of recipients
	  MOVEM C,FRNADR	;Save returned host address
	  MOVEM B,FRNHST	;Remember the host we're connecting to
	  HRRO B,HSTHST(N)	;Get final destination
	  CIETYPE < Queued mail for %2W>
	  HLRZ T,E		;Get protocol name
	  IFXN. F,FM%RLY	;If relaying
	    HRRO B,FRNHST	;Get back immediate destination
	    ETYPE < routing via %2W using %6W>
	  ELSE.
	    ETYPE < using %6W>
	  ENDIF.
	  TXZ F,FM%FAI		;Haven't failed
	  MOVEM N,SAVEN		;Save the position in the host list
	  HRRZ A,HSTHST(N)	;Get final destination
	  MOVE B,FRNHST		;Get back host pointer
	  MOVE C,FRNADR		;Get the address back
	  CALL (E)		;Call the routine
	  IFNSK.
	    TXO F,FM%FAI	;Failed
	    TYPE < failed.>
	    IFXN. F,FM%RLY	;If relaying
	      HLRZ T,RLYLST	;Then go to next possible host
	      SKIPE T		;If zero, no more relays
	       SKIPN T,(T)	;Else get next relay
		TXZ F,FM%RLY	;Note we're no longer relaying
	      MOVEM T,RLYLST
	    ENDIF.
	  ELSE.			;If it succeeded
	    SETZM RLYLST	;Forget any further possible relay hosts
	    TXZ F,FM%RLY	;Note we're no longer relaying
	    SKIPN A,STAJFN	;Doing statistics?
	  ANSKP.
	    HRRO B,FRNHST	;Get back host pointer
	    SETZ C,		;Null-terminated
	    SOUT%
	     ERJMP .+1
	    MOVX B,","		;Delimiter
	    BOUT%
	     ERJMP .+1
	    HLRZ B,MSGNHD(M)	;Length of headers generated
	    ADD B,MSGTCN(M)
	    MOVX C,^D10		;In decimal
	    NOUT%
	     ERJMP .+1
	    HRROI B,CRLF0	;Finally output CRLF
	    SETZ C,
	    SOUT%
	     ERJMP .+1
	  ENDIF.
	  MOVE T,SAVEN		;Recover starting recipient host
	  DO.
	    MOVX TT,FH%DN1	;Check if "about to be done"
	    TDNN TT,HSTFLG(T)
	    IFSKP.
	      ANDCAM TT,HSTFLG(T) ;If so, clear that
	      MOVX TT,FH%DON
	      TXNN F,FM%FAI	;Unless it failed
	       IORM TT,HSTFLG(T)
	    ENDIF.
	    CAIN T,(N)		;Reached host we just processed?
	     EXIT.		;Yes
	    HRRZ T,(T)		;May have sent more, check them out
	    JUMPN T,TOP.
	  ENDDO.
	  MOVE N,SAVEN		;Recover starting host
	  LOOP.			;Loop
	ENDDO.

	ENDSV.
; Get the next recipient for this route, skip if success
; Call:	CALL NXTRCP
;	N/	Current host block
;	O/	Current recipient block
;	FRNHST:	The current host we have a connection to
; Returns:
;	+1 if no more possible recipients
;	+2 new recipient
;	N/	Host block (possibly changed if relaying)
;	O/	Recipient block (definitely changed)
;
NXTRCP:	SAVEAC <A,B,C>
	HRRZ O,(O)		;Next recipient
	JUMPN O,RSKP		;Found one
	RET			;Don't - old optimization code is history since
				; often the headers were wrong
; Find the path to a given host
; Call:	CALL GETPTH
;	B/	Host pointer
; Returns:
;	+1 No path to host
;	+2 path found
;	E/	Protocol name,,routine
;	B/	Host pointer
;	C/	Numeric address to use for this protocol
;
GETPTH:	STKVAR <HSTPTR>
	MOVEM B,HSTPTR		;Set up pointer
	CALL HSTDED		;Is host up?
	 RET			;No, no path
	MOVEI C,SNDRTS		;Try direct protocols first
	HRRO A,HSTPTR		;Get name
	CALL GETPRO		;Try to find a protocol
	 RET			;None
	MOVE E,(C)		;Get protocol data
	MOVE C,B		;Get foreign host address for this protocol
	MOVE B,HSTPTR		;Get foreign host pointer
	RETSKP

	ENDSV.
;;; Output host in B in absolute form to the output designator in A
	HSTTSZ==^D40
OUTAHS:	SAVEAC <C,D>
	STKVAR <HSTPTR,<HSTTMP,HSTTSZ>>
	MOVEM A,HSTPTR		;Save output designator
	MOVEI A,HSTTMP		;Get copy of host name in HSTTMP
	HRLI A,(<POINT 7,>)
	HRLI B,(<POINT 7,>)
	MOVX D,<5*HSTTSZ>-1	;Up to this many bytes
	DO.
	  ILDB C,B
	  JUMPE C,ENDLP.
	  IDPB C,A
	  SOJG D,TOP.
	  SETZ C,		;Tie off string
	ENDDO.
	IDPB C,A
	HRROI A,HSTTMP		;Remove relative domains
	CALL $RMREL
	MOVE A,HSTPTR		;Restore output designator
	HRROI B,HSTTMP		;B := host in absolute form
	SETZ C,
	SOUT%
	RET

	ENDSV.

;;; Output host in B in absolute form to the pointer in A with quoting
OUTAHQ:	STKVAR <HSTPTR,<HSTTMP,^D13>>
	MOVEM A,HSTPTR		;Save output designator
	MOVEI A,HSTTMP		;Get copy of host name in HSTTMP
	HRLI A,(<POINT 7,>)
	CALL MOVST0
	HRROI A,HSTTMP		;Remove relative domains
	CALL $RMREL
	MOVEI A,HSTTMP		;B := host in absolute form
	HRLI A,(<POINT 7,>)
	MOVX C,.CHCNV
	DO.
	  ILDB B,A		;Get next byte
	  JUMPE B,ENDLP.	;Punt if null
	  CAIN B,"."		;Period that needs quoting?
	   IDPB C,HSTPTR	;Yes, quote it
	  IDPB B,HSTPTR		;Store the byte
	  LOOP.			;Loop for more
	ENDDO.
	MOVE A,HSTPTR		;Return updated pointer
	IDPB B,HSTPTR		;Terminate with null
	RET

	ENDSV.
;;; Output this recipient to designator in A, also to terminal if appropriate
OUTRCP:	STKVAR <OTRJFN,OTRHPT,OTRHCT,<HSTTMP,^D13>,UPPLIM,BUFPTR>
	MOVEM A,OTRJFN		;Save JFN
	MOVE C,[POINT 8,STRBF1]
	DMOVE T,RCPBPT(O)
	MOVEM TT,OTRHCT		;Save count before relaying
	DO.
	  ILDB D,T
	  IDPB D,C		;Copy recipient to STRBF1
	  SOJG TT,TOP.
	ENDDO.
	IFXN. F,FM%RLY		;Are we relaying?
	  MOVEM C,BUFPTR	;Save the pointer to add transmogification
	  SETZM STRBF2		;Clear the buffer
	  MOVEI A,HSTTMP
	  HRLI A,(<POINT 7,0>)	;Point to the temporary host buffer
	  MOVEM A,OTRHPT	;Save the pointer for later
	  HRRZ B,HSTHST(N)	;Get the destination host
	  CALL MOVST0		;Make a copy of it
	  MOVE A,OTRHPT
	  CALL RMDOM1		;Rip out the domain
	  MOVE A,[POINT 7,STRBF2] ;A/ is output buffer
	  MOVE B,OTRHPT		;B/ host string to add
	  MOVEI C,"%"		;C/ prepend char
	  CALL HSTAPP		;Append this host to the path
	  HRRZ A,HSTHST(N)	;From site entry
	  CALL SRCPTH		;Build a destination path
	  MOVE D,SNRLYS		;Get number of relays
	  SUBI D,2		;Don't include our neighbor in the list
	  MOVEM D,UPPLIM	;Save the upper limit
	  IFGE. D		;Less than 0?
	    SETZ D,		;No, start at the bottom
	    DO.
	      MOVE B,SRLYTB(D)	;Get the domain block pointer
	      PUSH P,B		;Save the pointer
	      MOVE B,DM%TRN(B)	;Point to the relay character
	      HRLI B,(<POINT 7,>)
	      ILDB C,B		;Get the relay character
	      POP P,B		;Get domain block back again
	      MOVE B,DM%RLY(B)	;Get the relay host's name
	      HRLI B,(<POINT 7,>)
	      MOVE A,OTRHPT	
	      CALL MOVST0	;Make a copy of the host name
	      MOVE A,OTRHPT
	      CALL RMDOM1	;Rip out the domain
	      MOVE A,[POINT 7,STRBF2] ;A/ is output buffer
	      MOVE B,OTRHPT	;B/ host string to add, C/ prepend char
	      CALL HSTAPP	;Append this host to the path
	      ADDI D,1		;Increment index
	      CAMG D,UPPLIM	;Less than the upper limit?
	       LOOP.		;Yes, loop around
	    ENDDO.
	  ENDIF.

;Now to build the whole thing together
	
	  MOVE A,BUFPTR		;Where to add the host path
	  MOVE B,[POINT 7,STRBF2] ;Where to get the host path
	  DO.
	    ILDB D,B		;Get a character
	    IFN. D		;Is it null (end of string)?
	      IDPB D,A		;No, put the char in the output buffer
	      AOS OTRHCT	;Inc. the character count
	      LOOP.
	    ENDIF.
	  ENDDO.
	ENDIF.
	CITYPE <  >
	MOVX A,.PRIOU
	MOVE B,[POINT 8,STRBF1]
	MOVN C,OTRHCT		;Updated count
	SKIPE PRINTP
	 SOUT%
	TYPE <: >
	MOVE A,OTRJFN		;Restore JFN
	MOVE B,[POINT 8,STRBF1]
	MOVN C,OTRHCT		;Updated count
	SOUT%
	 ERJMP .+1
	RET

	ENDSV.
;;; Output only message headers to JFN in A
;;; Returns: +1, transmission error
;;; 	     +2, successful
OUTMSH:	STKVAR <OUTMSD>
	MOVEM A,OUTMSD		;Save designator
	MOVEI A,^D1000		;Transmit 1000 bytes at a time
	MOVEM A,SEGSIZ		;Set segment size
	SKIPN A,MSGTMT(M)	;Overall delivery timeout in effect?
	IFSKP.
	  TIME%			;Yes, compute time limit for this copy
	  ADD A,TMCINT
	  CAMLE A,MSGTMT(M)	;Beyond total delivery timeout?
	   MOVE A,MSGTMT(M)	;Yes, use that
	ENDIF.
	MOVEM A,MSGTMC(M)	;Record copy timeout
	MOVE A,OUTMSD		;Restore designator
	MOVE B,MSGNHD(M)	;Headers we generated
	HLRZ C,B		;Length
	HRLI B,(<POINT 7,0>)	;Build byte pointer to message
	MOVNI C,(C)		;And byte count
	ADDI C,2		;Skip over the CRLF at the start
	IBP B
	IBP B
	CALL OUTMST		;Check copy timer
	 JRST OUTMSF
	CALL $SOUT		;If no timeout, output the headers
	 JRST OUTMSF
OUTMDN:	AOS (P)			;Set success (+2)
OUTMSF:	TMOCLR			;Disallow timer interrupts now
	RET

	ENDSV.
;;; Output whole text of message and headers to JFN in A
;;; Returns: +1, transmission error
;;; 	     +2, successful
OUTMSG:	CALL OUTMSH		;Output headers
	 RET			;+1 Transmission error
	SKIPE D,MSGTCN(M)	;+3 Success.  Is message body empty?
	IFSKP.
	  HRROI B,CRLF0		;Yes, must output at least a CRLF
	  SETZ C,
	  CALL $SOUT
	   JRST OUTMSF
	ELSE.
	  MOVE B,MSGTXT(M)	;Message non-empty, get pointer to message text
	  DO.			;No, here with message pointer in B, count in D
	    TMOCLR		;Disallow timer interrupts now
	    CAIG D,^D1000	;Do 1000 characters at a time
	     SKIPA C,D
	      MOVEI C,^D1000
	    SUBI D,(C)		;Account for this many characters output
	    MOVNS C		;Negative byte count for SOUT%
	    CALL OUTMST		;Check copy timer
	     JRST OUTMSF	;Timed out
	    CALL $SOUT		;Output the string
	     JRST OUTMSF
	    JUMPG D,TOP.	;Continue output if more bytes to go
	  ENDDO.
	ENDIF.
	JRST OUTMDN		;Message output done
;;; Output whole text of message and headers to JFN in A with period checking
;;; Returns: +1, transmission error
;;; 	     +2, successful
MSGOUT:	STKVAR <BUFPTR>
	CALL OUTMSH		;Output headers
	 RET			;+1 Transmission error
	SKIPN D,MSGTCN(M)	;Get text count or flag text empty
	IFSKP.			;Message non-empty with count in D
	  MOVE B,MSGTXT(M)	;Get pointer to message text
	  ILDB B,B		;Get first byte of message
	  CAIE B,"."		;Is it a period?
	  IFSKP.
	    CALL $BOUT		;Yes, double it in transmission
	     JRST OUTMSF
	  ENDIF.
	  MOVE B,MSGTXT(M)	;Get pointer to message body again
	  DO.			;Do 1000-bytes at a time with period checking
	    TMOCLR		;Disallow timer interrupts
	    MOVEM B,BUFPTR	;Save pointer to start of buffer
	    SETZB C,TT		;Character count zero, no doubled dot
	    DO.			;Search for "<CRLF>." sequence within buffer
	      CAILE D,2(C)	;Possible at all for "<CRLF>." sequence?
	      IFSKP.		;No, too near end of message
		MOVE C,D	;Set to output rest of message
		EXIT.		;And be done with this
	      ENDIF.
	      CAMLE C,SEGSIZ	;Buffer filled?
	       EXIT.		;Yes, output it
	      ILDB T,B		;Get byte from buffer
	      ADDI C,1		;Count this character
	      CAIE T,.CHCRT	;Is it a CR?
	       LOOP.		;No, continue scan
	      ILDB T,B		;Saw CR, get possible LF
	      ADDI C,1		;Count this character
	      CAIE T,.CHLFD	;Have we gotten a <CRLF>?
	       LOOP.		;No, continue scan
	      MOVE T,B		;Saw <CRLF>, get pointer to peek at next byte
	      ILDB T,T		;Peek at next byte
	      CAIE T,"."	;Have we gotten a line starting with period?
	       LOOP.		;No, continue scan
	      SETO TT,		;Yes, end buffer here, flag must double dot
	      IBP B		;Advance pointer beyond the dot
	      ADDI C,1		;And count it
	    ENDDO.		;End scan through message for <CRLF>.
	    MOVE B,BUFPTR	;Get back pointer to start of buffer
	    SUBI D,(C)		;Account for this many characters output
	    MOVNS C		;Negative byte count for SOUT%
	    CALL OUTMST		;Check copy timer
	     JRST OUTMSF	;Timed out
	    CALL $SOUT		;Output the string
	     JRST OUTMSF
	    IFN. TT		;Do we have to double dot?
	      MOVEM B,BUFPTR	;Yes, save pointer to buffer
	      MOVEI B,"."	;Output the extra period
	      CALL $BOUT
	       JRST OUTMSF
	      MOVE B,BUFPTR	;Retrieve pointer
	    ENDIF.
	    JUMPG D,TOP.	;Continue output if more bytes to go
	  ENDDO.
	  SETO T,		;Back up pointer to last two bytes in buffer
	  ADJBP T,B
	  LDB D,T		;Get next to last byte
	  CAIE D,.CHCRT		;Was it a CR?
	   TDZA D,D		;No, can't be a CRLF sequence
	    ILDB D,T		;Yes, possible CRLF, get last byte
	ENDIF.
	CAIN D,.CHLFD		;Here D has either: the last byte output from
	IFSKP.			; the message, or zero.  D can be zero if the
	  HRROI B,CRLF0		; message body is empty or if the next to the
	  SETZ C,		; last byte wasn't a CR.  We can suppress
	  CALL $SOUT		; outputting the CRLF before the EOM only if
	   JRST OUTMSF		; D has a "last byte" of line feed
	ENDIF.
	HRROI B,[ASCIZ/.
/]				;Send End-Of-Message signal
	SETZ C,
	CALL $SOUTR
	 JRST OUTMSF
	JRST OUTMDN

	ENDSV.
;;; Routine to check timer for this msg copy
; Entry:   MSGTMC(M) = time limit for transmitting this copy
; Call:    CALL OUTMST
; Return:  +1, timeout expired
;	   +2, ready to send next block of text

OUTMST:	SKIPN MSGTMC(M)		;Copy timeout in effect?
	IFSKP.
	  SAVEAC <A,B>		;Save ACs
	  TIME%			;Time limit up?
	  CAML A,MSGTMC(M)
	   CALL TIMOUT		;Timer expired
	ENDIF.
	RETSKP
	SUBTTL Process local mail

SNDLCL:	SKIPN MSGLCL(M)		;Any local mail?
	 RETSKP			;No
	JSR SAVACS		;Yes, save all ACs
	MOVEI X,MSGLCL(M)	;Pointer to local mail
	SKIPE MSGDOP(M)		;If sending, do this another way
	 JRST SNDLCT
	CITYPE < Processing local mail>
	CALL GENHDL		;Build local headers
	DO.
	  HRRZ O,(X)		;Get next recipient
	  JUMPE O,RSKP		;All done
	  MOVE B,RCPFLG(O)	;Get address flags
	  IFXE. B,FR%FAI!FR%TMP	;Forwarding errors on this address?
	    CALL SNDLCF		;No, try to send to file
	    IFSKP.
	      TYPE <OK>		;Success, log it
	    ELSE.
	      CALL CHKSFT	;Failed, was it a soft error?
	      IFSKP.
		SKIPE NTDEQF	;Soft error, has message expired?
	      ANSKP.
		MOVX B,FR%TMP	;No, just record soft failure
		IORM B,RCPFLG(O)
		CIETYP <	%1E> ;JSYS error message
	      ELSE.
		MOVE B,A	;Dequeueing, get a copy of the JSYS error text
		HRROI A,STRBF1
		HRLI B,.FHSLF
		SETZ C,
		ERSTR%
		 ERJMP .+1
		 ERJMP .+1
		MOVEI A,STRBF1
		MOVX B,FR%ERM!FR%TMP ;Assume sender notify and requeue
		SKIPG NTDEQF
		 MOVX B,FR%ERM!FR%FAI ;No, dequeueing
		CALL RCPLCX	;Save the error string
	      ENDIF.
	    ENDIF.
	  ENDIF.
	  MOVEI X,(O)
	  LOOP.
	ENDDO.

;;;Skip if error code in A is soft

CHKSFT:	CAIE A,OPNX6		;Append access required means no WOPR or file
	 CAIN A,OPNX23		;Quota exceeded (all cases -- see OVRQTA)
	  RETSKP
	CAIE A,GJFX16		;If POBOX: went away consider it temporary too
	 CAIN A,OPNX9		;Let invalid simultaneous access through too
	  RETSKP		; OVRQTA and this is soft
;;;Maybe some others need adding here?
	RET
; Here when address forwards to bad host, it is HSTBUF
RCPLXH:	MOVE A,[POINT 7,STRBF1]	;a := buffer to construct msg
	MOVEI B,[ASCIZ/Can't forward - unknown host "/]
	CALL MOVSTR
	MOVEI B,HSTBUF
	CALL MOVSTR
	MOVEI B,.CHDQT
	IDPB B,A
	SETZ B,
	IDPB B,A
	MOVEI A,STRBF1		;Now give him the bad news
	MOVX B,FR%ERM!FR%FAI	;Hard failure
;;;	JRST RCPLCX

; Set error message for a recipient
; a = address of error string
; b = error bits for user block
RCPLCX:	CALL RSTRCP		;Clear error msgs for this recipient
	IORM B,RCPFLG(O)
	CALL CPYSTR
	MOVEM B,RCPERR(O)
	UTYPE (B)		;Print the reason
	RET
; Here to do SNDLCL processing for terminal messages
; returns +2/always
; messages to be sent as mail requeued with temporary error flag
; failed messages that can't be remailed flagged as permanent errors

SNDLCT:	MOVE A,MSGDOP(M)	;Point to delivery-options
	HLRO A,DOPTAB(A)	;Get delivery option string
	CIETYP < Processing %1S terminal message>

;; Build message text to send
	HRROI A,STRBF1		;We build the message into STRBUF
	SKIPN D,MSGSDR(M)	;d := adr of sender host entry block
	 FATAL <No sender block set up>
	HRRZ C,HSTRCP(D)	;Get pointer to recipient entry block
	MOVE B,RCPBPT(C)	;Point to sender user name
	MOVN C,RCPCNT(C)	;And sender count
	SOUT%			;Add it in
	FMSG <@>		;Add atsign
	HRRO B,HSTHST(D)	;Now get name for host
	CALL OUTAHS		;Add host name
	FMSG <, >		;Comma
	SETO B,			;Current time
	MOVX C,OT%NSC!OT%12H!OT%SCL ;C/Format flags: no seconds, 12 hour time
	ODTIM%			;Write it
	HRROI A,STRBUF		;Into normal place to make send
	HRROI B,STRBF1		;From header we just made
	MOVEI C,STRBSZ*5-1	;With number of chars allowed in buffer
	SETZ D,			;To a null
	SOUT%			;String-to-string copy
	MOVEI B,.CHCRT		;Now another CR
	DPB B,A			;Write over null with it
	MOVEI B,.CHLFD		;And a linefeed
	IDPB B,A		;To finish the header line
	CAML C,MSGHCN(M)	;See how much space we have
	IFSKP.
	  HRROI TT,[ASCIZ/Message text much too long/]
	  CIETYP <   All sends failed: %7S>
	  DO.
	    HRRZ O,(X)		;Get next recipient
	    JUMPE O,ENDLP.	;If zero, done flagging them
	    CALL SERMRK		;Set error flags and message
	    MOVEI X,(O)		;Move on to next recipient
	    LOOP.
	  ENDDO.
	ELSE.
	  MOVE B,MSGHDR(M)	;Point to message header start
	  MOVN C,MSGHCN(M)	;And get count of letters
	  SOUT%			;Copy message text across to finish message

;; Message built.  Now make a list of recipients.
	  SETZB T,TT		;No first block, no latest block
	  DO.
	    HRRZ O,(X)		;Get next recipient
	    JUMPE O,ENDLP.
	    MOVE A,[POINT 7,STRBF1] ;Get pointer to random string buffer
	    DMOVE B,RCPBPT(O)	;Point to recipient name, byte count
	    DO.
	      ILDB D,B		;Get a byte
	      IDPB D,A		;And drop it in
	      SOJG C,TOP.	;Until there are no more bytes left
	    ENDDO.
	    IDPB C,A		;Drop in a null to terminate

;; Have name for recipient.  Try looking up as a local user
	    MOVX A,RC%EMO	;Forcing exact match
	    HRROI B,STRBF1	;With string we made
	    RCUSR%		;Read user name
	    IFNJE.		;If we succeeded
	    ANDXE. A,RC%NOM	;And got a match
	      PUSH P,C		;Save user number
	      CALL GSRCPT	;Get recipient block in TT
	      MOVSI A,RC.USR	;This is a user number
	      MOVEM A,(TT)	;Save as block header
	      POP P,1(TT)	;Save user number as data
	    ELSE.
	      HRROI A,STRBF1	;That failed, point to buffer again
	      MOVEI C,^D8	;Terminal numbers are octal
	      NIN%		;Try to read one in
	      IFNJE.
		LDB C,A		;Read terminator byte
	      ANDE. C		;Must be null
		PUSH P,B	;Is, save terminal number
		CALL GSRCPT	;Get recipient block for it
		MOVSI A,RC.TTY	;This is a terminal number
		MOVEM A,(TT)	;Save as block header
		POP P,1(TT)	;Save terminal number as data
	      ELSE.
		MOVX A,FR%TMP	;Couldn't translate, want to send as mail
		IORM A,RCPFLG(O) ;So requeue with a "temporary error"
	      ENDIF.
	    ENDIF.
	    MOVEI X,(O)		;Move on to next recipient
	    LOOP.
	  ENDDO.
	ANDN. T			;If nobody left, give up in disgust
;; Here to attempt to send to rcpt list pointed to by T
	  DO.
	    HRROI A,STRBUF	;From string buffer where we built message
	    MOVE B,T		;Starting at the first send
	    MOVEI C,SDBLOK	;With send state block
	    CALL $SEND		;Send it off
	     NOP		;We can tell if it succeeded by looking at B

;; Message has been sent.  Loop through rcpts until we find one
;; that failed, logging and freeing blocks as we go.
	    EXCH B,T		;Get starting recipient block in a useful place
	    MOVE TT,A		;Save error pointer if we have any
	    DO.
	      HRROI A,STRBF1	;Into alternate buffer
	      CALL $WTRCP	;Write recipient name for strings
	      CAMN B,T		;Are we where we left off yet?
	      IFSKP.
		HRROI A,STRBF1	;No, rcpt succeeded, get recipient name string
		CIETYP <  %1S: Sent> ;Say we delivered it
		MOVE A,MSGDOP(M) ;Get delivery options
		CAIE A,D%SAML	;Send and mail?
		IFSKP.
		  MOVX A,FR%TMP	;Yes, we need to send it as mail too
		  MOVE O,2(B)	;Point back to recipient block
		  IORM A,RCPFLG(O) ;Requeue with a "temporary error"
		ENDIF.
		LOAD O,RC%NXT,(B) ;Point to next recipient
		CALL FREBLK	;Free this one
		MOVE B,O	;Get next block pointer back
		JUMPN B,TOP.	;Got someone, go on
		SETZ T,		;Break out of outer loop
	      ELSE.
		HRROI A,STRBF1	;Point to recipient name
		CIETYP <  %1S: %7S>
		MOVE O,2(T)	;Point back to recipient block
		CALL SERMRK	;Set error flags for that recipient
		MOVE B,T	;Get pointer to this block
		LOAD T,RC%NXT,(T) ;And move on to the next
		CALL FREBLK	;Free this one
	      ENDIF.
	    ENDDO.
	    JUMPN T,TOP.	;If we have more to do, go do it
	  ENDDO.
	ENDIF.
	RETSKP
; Here with a bad recipient, error string in TT.
SERMRK:	MOVE A,MSGDOP(M)	;Get message delivery options
	CAIE A,D%SOML		;If SOML, just set temporary failure
	 CAIN A,D%SAML		;Ditto for SAML
	IFSKP.
	  HRROI A,STRBF1	;Into random string buffer
	  MOVE B,TT		;From error string
	  SETZ C,		;No limit (short string, don't worry about it)
	  SOUT%			;String-to-string copy
	  HRROI A,STRBF1	;Now point to start of string again
	  CALL CPYSTR		;Copy into safer string space
	  MOVEM B,RCPERR(O)	;Save error message with recipient
	  MOVX A,FR%ERM!FR%FAI	;Hard failure
	ELSE.
	  MOVX A,FR%TMP		;Get flag for temporary error
	ENDIF.
	IORM A,RCPFLG(O)	;Set error flags in recipient block
	RET

; Here to make a recipient block
GSRCPT:	MOVEI A,3		;Need: recipient type and data, copy of O
	CALL ALCBLK		;Allocate block
	 FATAL <Memory exhausted>
	MOVEM O,2(B)		;Save recipient pointer for flagging
	SKIPN T			;If we don't have a first block yet
	 MOVEM B,T		;This is it
	SKIPE TT		;If we had a previous block
	 STOR B,RC%NXT,(TT)	;Link through for $SEND
	MOVEM B,TT		;In any case save this as the previous block
	RET
; Mail failed.  Check to see if the addressee is the mail agent.
; If so set the FR%MLA bit in RCPFLG(O).
; Entry:   n = adr of host block
;	   o = adr of recipient block
;	   mlagnt = mail agent name string
; Call:    CALL MMLGTL (check addressee assuming local host)
;	  CALL MMLGT  (check addressee on network host)
; Return:  +1, always
MMLGT:	MOVE A,HSTHST(N)	;a := host site
	CAIE A,LCLNAM		;Local?
	 RET			;No, can't be mail agent
MMLGTL:	MOVE A,[POINT 7,MLAGNT]	;a := ptr to mail agent name
	DMOVE B,RCPBPT(O)	;b,c := ptr/ctr to recipient name
	CALL STRCAL		;Compare the strings
	 RET			;Not same
	MOVX A,FR%MLA		;Same, flag mail agent failure
	IORM A,RCPFLG(O)
	RET
; Mail failed.  Check to see if the addressee is the sender.
; If so set the FR%SDR bit in RCPFLG(O).
; Entry:   n = adr of host block
;	   o = adr of recipient block
;	   msgsdr = message sender
; Call:    CALL MSNDRL (check addressee on local host)
;	   CALL MSNDR  (check addressee on network host)
; Return:  +1, always
MSNDR:	SKIPA C,HSTHST(N)	;c := addressee host
MSNDRL:	 MOVEI C,LCLNAM		;c := addressee host = local host
	MOVE A,MSGSDR(M)	;a := adr of sender host block
	MOVE B,HSTHST(A)	;b := sender host
	CAME B,C		;Same host?
	 RET			;No, addressee neq sender
	HRRZ B,HSTRCP(A)	;a/b := ptr/len of sender name
	DMOVE A,RCPBPT(B)
	DMOVE C,RCPBPT(O)	;c/d := ptr/len of recipient name
	CALL STRCLL		;Compare the strings
	 RET			;Not same
	MOVX A,FR%SDR		;Same, flag sender failure
	IORM A,RCPFLG(O)
	RET
; Routine to check forwarding address.
; Entry:   strbuf = new addressee name
;	   hstbuf = new host
; Call:    CALL CKFWDL
; Return:  +1, host not recognized
;	   +2, new addressee = old one
;	   +3, forwarding OK, b = host site address
CKFWDL:	MOVE B,[POINT 7,HSTBUF]	;b := ptr to host name
	CALL HSTNAM		;Look it up
	 RET			;No go, return +1
	CAIE B,LCLNAM		;Still to local host?
	 JRST R2SKP		;No, return +3
	AOS 0(P)		;Return at least +2 from here
	SAVEAC <B>
	MOVE A,[POINT 7,STRBUF]	;a := ptr to new user name
	DMOVE B,RCPBPT(O)	;b/c := ptr/len of old name
	CALL STRCAL		;Compare them (upper case)
	 RETSKP			;No match, return +3
	RET

;;; Add a forwarding address
;;; O/ ptr to recipient block
;;; B/ host index
ADDRCP:	MOVEI N,MSGRCP(M)
ADDRC7:	HRRZ T,HSTFLG(N)	;n := adr of next host block
	JUMPE T,ADDR11		;This host not on list
	MOVE TT,HSTHST(T)
	CAME TT,B		;Same host
	 JRST [	MOVEI N,(T)
		JRST ADDRC7]
	MOVEI N,(T)
ADDRC8:	MOVEI T,HSTRCP(N)
ADDRC9:	HRRZ TT,RCPFLG(T)	;Reached end?
	JUMPE TT,ADDR10
	MOVEI T,(TT)
	JRST ADDRC9
ADDR10:	HRRM O,(T)		;Link onto end
	HRRZ T,(O)		;Get old end
	HRRM T,(X)		;Link to previous
	HLLZS (O)		;This is the new end of its list
	MOVEI O,(T)
	RET

ADDR11:	PUSH P,B		;Save host
	MOVEI A,HSTLEN		;Make a new host block
	CALL ALCBLK
	 FATAL <Memory exhausted>
	HRRM B,(N)
	MOVEI N,(B)
	POP P,HSTHST(N)
	SETZM HSTFLG(N)
	SETZM HSTRCP(N)
	JRST ADDRC8
; Try to send local mail to addressee
; Returns: +1:	Failure, JSYS error in A
;	   +2:	Success, message delivered

SNDLCF:	STKVAR <LCFJFN,<FILSIZ,2>,SDRPTR,FILPTR>
	SKIPE WOPRP		;Must be WOPR to run here (checked earlier)
	IFSKP.
	  MOVEI A,OPNX6		;Pick a convincing error code
	  RET			;And return
	ENDIF.
	TXZ F,FM%FLO		;Assume addressee is not a file
	MOVE A,RCPBPT(O)	;a := ptr to recipient name
	ILDB B,A		;b := 1st char
	CAIE B,"*"		;File address designator?
	IFSKP.
	  TXO F,FM%FLO		;Yes
	  CALL SNLFAD		;Prepare file name string
	  IFNSK.
	    MOVEI A,GJFX33	;Failed, pick a convincing error code
	    RET			;And return
	  ENDIF.
	ELSE.
	  MOVE A,[POINT 7,STRBUF] ;Start filename string
	  MOVEI B,[ASCIZ/POBOX:</]
	  CALL MOVSTR
	  MOVEM A,FILPTR	;Save pointer for typing out
	  DMOVE B,RCPBPT(O)
	  ILDB D,B		;Get first byte of user string
	  CAIE D,"&"		;Was it the special local user hack?
	   SKIPA B,RCPBPT(O)	;No, use existing pointer/counter
	    SUBI C,1		;Otherwise skip over and decrement count
	  DO.
	    ILDB D,B
	    IDPB D,A
	    SOJG C,TOP.
	  ENDDO.
	  MOVE B,A
	  IDPB C,B		;Terminate it for now
	  EXCH A,FILPTR
	  CIETYPE <  %1W: >
	  MOVE B,[POINT 7,[ASCIZ/SYSTEM/]] ;Check if SYSTEM mail
	  CALL STRCMP
	   SKIPA
	    TXO F,FM%FLO	;SYSTEM mail, treat as output to file
	  MOVE A,FILPTR
	  MOVEI B,[ASCIZ/>MAIL.TXT.1/]
	  CALL MOVST0
	ENDIF.
;;; The need for two GTJFN% calls is to work around a long-standing monitor
;;;bug in DIRECT -- GT%FOU!GJ%OLD will cause an empty mail file to go away.
;;;This bug is fixed at Stanford, but not in DEC TOPS-20 as of 5.1.
	MOVX A,GJ%OLD!GJ%DEL!GJ%SHT ;Verify there is a mail file there
	HRROI B,STRBUF
	GTJFN%
	 ERJMP R		;Return JSYS error
	IFXN. F,FM%FLO		;OK, output to file?
	  MOVEM A,LCFJFN	;Special-case NUL: device
;;;Actually, need some general tests for non-disk devices.  For now, only disk
;;;and NUL: can possibly work.
	  DVCHR%		;Get characteristics
	  IFNJE.
	    LOAD B,DV%TYP,B	;Get device type
	    CAIE B,.DVNUL	;NUL:?
	  ANSKP.
	    MOVE A,LCFJFN	;Yes, all done here
	    RLJFN%
	     JWARN
	    RETSKP
	  ENDIF.
	  MOVE A,LCFJFN
	  CALL SNLFCK		;Yes, check for append access
	ANNSK.
	  RLJFN%		;No go, release the JFN
	   JWARN
	  MOVEI A,OPNX6		;Convincing error code
	  RET			;And fail return
	ENDIF.
	MOVE B,[1,,.FBDRN]
	MOVEI C,C
	GTFDB%
	 ERJMP .+1
	RLJFN%			;Now get rid of this JFN
	 JWARN
	MOVX A,GJ%FOU!GJ%DEL!GJ%SHT ;Get the JFN again (note: no GJ%OLD!!)
	HLR A,C			;Default version number from old
	HRROI B,STRBUF
	GTJFN%			;Try to get guys mail file
	 ERJMP R		;This shouldn't have happened, oh well
	MOVEM A,LCFJFN		;Save JFN
	MOVX B,<<FLD ^D7,OF%BSZ>!OF%RD!OF%WR> ;Open for read/write
	OPENF%
	IFJER.
	  EXCH A,LCFJFN		;JSYS error, save error code
	  RLJFN%		;Flush the JFN
	   JWARN
	  MOVE A,LCFJFN		;Now return error to caller
	  RET
	ENDIF.
	SKIPN DAEMNP		;Allow enabled wheel to circumvent quota check
	IFSKP.
	  MOVX A,.FHSLF		;Get our capabilities
	  RPCAP%
	  TXZ C,SC%WHL!SC%OPR	;Disable them
	  EPCAP%
	ENDIF.
	MOVE A,LCFJFN		;Get JFN
	MOVE B,[2,,.FBBYV]	;Get two words of file size
	MOVEI C,FILSIZ		;Into FILSIZ
	GTFDB%
	LDB C,[POINT 6,FILSIZ,11] ;Get file byte size
	CAIN C,7		;Already the right byte size?
	IFSKP.
	  MOVEI B,^D36		;Ugh, compute total bytes per word
	  IDIVI B,(C)
	  EXCH B,1+FILSIZ
	  IDIV B,1+FILSIZ	;Compute number of words
	  IMULI B,5		;Compute # of characters
	ELSE.
	  MOVE B,1+FILSIZ	;Use exact byte count if 7 bit bytes
	ENDIF.
	MOVEM B,FILSIZ		;Save prior file size
	SFPTR%			;Set this as the place to write to
	 JFATAL
	SETO B,			;Now
	MOVX C,OT%TMZ
	ODTIM%
	IFNJE.
	  MOVEI B,","
	  BOUT%
	..TAGF (ERJMP,)		;I sure wish ANNJE. existed!
	  SETZM STRBUF		;Assume nothing needed
	  DMOVE A,[POINT 7,ORGAUT ;See if it was written by system server
		   POINT 7,DAEDIR]
	  CALL STRCMP		;Strings match?
	  IFNSK.
	    HRROI A,STRBUF
	    HRROI B,[ASCIZ/Mail-From: /]
	    SETZ C,
	    SOUT%
	    HRROI B,ORGAUT
	    SOUT%		;Give him the author
	    HRROI B,[ASCIZ/ created at /]
	    SOUT%
	    HRRZ B,MSGJFN(M)	;Date of queue file
	    MOVEI C,JS%LWR	;Last write
	    JFNS%
	    HRROI B,CRLF0
	    SETZ C,
	    SOUT%		;And crlf
	  ELSE.
	    HRROI A,STRBUF
	  ENDIF.
	  SKIPN MSGRPT(M)	;Return path specified?
	  IFSKP.
	    HRROI B,[ASCIZ/Return-Path: </] ;Yes, output it
	    SETZ C,
	    SOUT%
	    HRRO B,MSGRPT(M)	;Now output the path
	    SOUT%
	    MOVEI B,">"
	    BOUT%
	    HRROI B,CRLF0	;Terminating CRLF
	    SOUT%
	  ENDIF.
	  SKIPN STRBUF
	  IFSKP.
	    LDB B,[POINT 6,A,5]	;High order 2 octal digits
	    ADDI B,3		;High order digit is now 4,3,2,1,or 0
	    LSH B,-3		;Get 4 - 0
	    TXZ A,.LHALF	;Clear left half of ptr
	    SUBI A,STRBUF-1	;Number of words
	    IMULI A,5		;Number of chars
	    SUB A,B		;Adjust by number not used in last word
	  ELSE.
	    SETZ A,		;Nothing to be done
	  ENDIF.
;;;Note that B is off by 2, since it includes a CRLF in front of the message.
;;; In most cases, we compensate by subtracting 2.  If the message is null,
;;; however, we will generate a free CRLF so we don't compensate
	  HLRZ B,MSGNHD(M)	;Length of headers
	  ADD B,A		;Add the MAIL-FROM/RETURN-PATH headers
	  SKIPE C,MSGTCN(M)	;Is there a message body?
	   SUBI B,2		;Yes, adjust count
	  MOVE A,LCFJFN		;Get back JFN
	  ADD B,MSGTCN(M)	;Plus text
	  MOVEI C,^D10		;Decimal
	  NOUT%
	..TAGF (ERJMP,)		;I sure wish ANNJE. existed!
	  HRROI B,[ASCIZ/;000000000000
/]
	  SETZ C,
	  SOUT%
	..TAGF (ERJMP,)		;I sure wish ANNJE. existed!
	  HRROI B,STRBUF	;Output the Mail-From: line
	  SOUT%
	..TAGF (ERJMP,)		;I sure wish ANNJE. existed!
	  CALL OUTMSG		;Now output message for real
	ANSKP.
	  MOVX A,.FHSLF		;Get our capabilities
	  RPCAP%
	  IOR C,B		;Re-enable them
	  EPCAP%
	ELSE.
;;; Here when destination directory appears to be over quota.  Back out of
;;;sending the message.
	  MOVX A,.FHSLF		;Get our capabilities
	  RPCAP%
	  IOR C,B		;Re-enable them
	  EPCAP%
	  MOVE A,LCFJFN
	  RFBSZ%		;Get current byte size
	   ERJMP .+1
	  MOVEI C,^D36
	  IDIVI C,(B)		;Compute bytes per word
	  MOVE D,C		;Save this for later
	  RFPTR%		;Get current EOF pointer
	   ERJMP .+1
	  IDIVI B,(D)		;Compute words
	  LSH B,-11		;Make it a page number
	  MOVE C,FILSIZ		;Get original EOF pointer
	  IDIVI C,(D)		;Compute word #
	  LSH C,-11		;Get page number
	  SUB B,C		;Compute # of pages added
	  IFN. B
	    EXCH B,C		;Get args in proper regs
	    TXO C,PM%CNT
	    SETO A,		;Delete pages
	    HRL B,LCFJFN	;JFN
	    ADDI B,1		;Starting page
	    PMAP%		;Zap the extra file pages
	    MOVE A,LCFJFN	;JFN again
	  ENDIF.
	  HRLI A,.FBBYV		;Make sure byte size is correct
	  MOVX B,FB%BSZ		;Set byte size
	  MOVX C,<FLD 7,FB%BSZ>	;Set it to 7-bit bytes
	  CHFDB%		;Do it
	  IFNJE.
	    HRLI A,.FBSIZ	;Now set the size
	    SETO B,		;Set entire word
	    MOVE C,FILSIZ	;And back to original count
	    CHFDB%		;Do it
	     ERJMP .+1
	  ENDIF.
	  MOVE A,LCFJFN		;Get JFN again
	  HRROI B,[ASCIZ/somebody pending because of disk quota/] ;39 chrs max!
	  CALL .SFUST		;Set as writer
	  MOVE A,LCFJFN		;Get JFN one last time
	  CLOSF%		;Close the file
	   JWARN
	  MOVX A,OPNX23		;Disk quota exceeded
	  RET			;JSYS error return
	ENDIF.
;;;Make sure the message just delivered has made it to the disk, otherwise
;;;if the system crashes before DDMP runs it will be lost.
	MOVE A,LCFJFN		;Get back JFN
	RFPTR%			;Get pointer to last byte we wrote
	 JFATAL <Can't get local mail file size>
	MOVEM B,FILSIZ
	IDIVI B,5*^D512		;Convert to number of pages
	SKIPE C			;Was there a remainder?
	 ADDI B,1		;Yes, a partially written page exists
	HRL A,LCFJFN		;JFN in LH
	HRRI A,1		;Start with page 1
	UFPGS%			;Drop the pages and wait until it happens
	 JWARN <Can't update local mail file>
	MOVE A,LCFJFN
	HRLI A,.FBBYV		;Make sure byte size is correct
	MOVX B,FB%BSZ		;Set byte size
	MOVX C,<FLD 7,FB%BSZ>	;Set it to 7-bit bytes
	CHFDB%			;Do it
	IFNJE.
	  HRLI A,.FBSIZ		;Now set the size
	  SETO B,		;Set entire word
	  MOVE C,FILSIZ		;Make damn sure FDB is updated
	  CHFDB%		;Do it
	   ERJMP .+1
	ENDIF.
	MOVE A,LCFJFN		;Get back JFN
	TXO A,CO%NRJ		;Close file w/o releasing JFN
	CLOSF%
	 JFATAL <Can't close local mail file>
	MOVE D,MSGSDR(M)	;d := sender host block adr
	HRRZ C,HSTRCP(D)	;c := sender recipient block adr
	HRRZ B,RCPBPT(C)	;b := ptr to sender name
	CAIN B,MLAGNT		;Our mail agent?
	 SKIPN B,MSGFHS(M)	;Yes, any "Net-mail-from-host" spec?
	IFNSK.
	  HRROI A,STRBUF	;a := ptr to temp buffer for author name
	  MOVE B,RCPBPT(C)	;b/c := ptr/-cnt to name field
	  MOVN C,RCPCNT(C)
	  SOUT%
	  MOVE D,HSTHST(D)	;d := sender host site tbl entry
	  CAIN D,LCLNAM		;Local host?
	  IFSKP.
	    MOVEI B,"@"		;Add on host name
	    BOUT%
	    HRRO B,D		;Pointer to host name
	    SETZ C,
	    SOUT%
	  ENDIF.
	  HRROI B,STRBUF	;b := author string ptr
	ENDIF.
	MOVEM B,SDRPTR		;And string pointer
	MOVE C,RCPCNT(O)	;Length of receiver's name
	ADJBP C,RCPBPT(O)	;Pointer to receiver's name
	SETZ D,			;Tie off name string
	IDPB D,C
	MOVE B,RCPBPT(O)	;Pointer to receiver's name
	ILDB A,B		;Get first byte
	CAIE A,"&"		;Was it special force local user hack?
	 MOVE B,RCPBPT(O)	;No, use it as is
	MOVX A,RC%EMO		;Match string exactly
	RCUSR%			;Get user number
	IFNJE.
	ANDN. C
	  MOVEM C,USRNUM	;Save user number
	  HRROI A,FRMMSG	;Create output msg in FRMMSG
	  HRROI B,[ASCIZ/
[You have a message from /]
	  SETZ C,
	  SOUT%
	  HRRO B,SDRPTR		;Get back sender name string pointer
	  CALL OUTAHS		;Output absolute host
	  HRROI B,[ASCIZ/ on /]	;Tell him where he has new mail
	  SOUT%			; since he may have TELNETed somewhere else
	  HRROI B,LCLNAM
	  CALL OUTAHS
	  HRROI B,[ASCIZ/]
/]
	  SOUT%
	  IDPB C,A		;Tie off with null
	  SETZ D,		;Init job number for scan
	  DO.
	    MOVEI A,(D)		;Job number
	    MOVE B,[-<.JIBAT-.JITNO+1>,,GTINF] ;Get values from monitor
	    MOVX C,.JITNO	;Get term # and logged in dir
	    GETJI%		;Get them
	    IFNJE.
	      SKIPE GTINF+<.JIBAT-.JITNO> ;Is this a batch job?
	    ANSKP.
	      DMOVE A,GTINF	;No, get GETJI% data in regs
	    ANDGE. A		;Detached?
	      CAME B,USRNUM	;Logged into the user number we want?
	    ANSKP.
	      IORX A,.TTDES	;Make it a device designator
	      MOVX B,.MORNT	;Does user want system messages?
	      MTOPR%
	    ..TAGF (ERJMP,)	;I sure wish ANNJE. existed!
	    ANDE. C		;Ignore if refusing system messages
	      HRROI B,FRMMSG	;Get message block
	      TTMSG%		;Send to this user
	       ERJMP ENDLP.	;Ignore failure
	    ELSE.
	      CAIN A,GTJIX3	;"Invalid job number"?
	       EXIT.		;Yes, all done
	    ENDIF.
	    AOJA D,TOP.		;Do all jobs
	  ENDDO.
	ENDIF.
	MOVE A,LCFJFN		;Get back JFN
	MOVE B,SDRPTR		;Restore string pointer
	SKIPE DAEMNP		;Daemon running?
	 CALL .SFUST		;Yes, set the author
	ANDX A,.RHALF		;Isolate file JFN
	RLJFN%			;Release it
	 JWARN
	RETSKP			;Return success

	ENDSV.
; Here to set up for sending mail to a file specification, defaulting the
;  device and directory from the msg file JFN.
; Entry:   o = adr of recipient buffer
; Call:    CALL SNLFAD
; Return:  +1, failure (bad string)
;	   +2, OK, name string set up in STRBUF
SNLFAD:	STKVAR <FILPTR,<RCPPTR,2>>
	MOVE A,[POINT 7,STRBUF]	;a := buffer for name string
	DMOVE B,RCPBPT(O)	;b,c := ptr/ctr to file name string
	IBP B			;Step over "*"
	SOJLE C,R		;And decrement count (if null str, quit)
	MOVEM A,FILPTR		;Save buffer pointer
	DMOVEM B,RCPPTR		;Save recipient pointer and counter
	DO.
	  ILDB D,B		;Look for device delimiter
	  IDPB D,A		;Stick character in buffer in case
	  CAIE D,.CHCNV		;CTRL-V?
	  IFSKP.
	    SOJLE C,R		;Yes, next character doesn't count
	    ILDB D,B
	    IDPB D,A
	  ELSE.
	    CAIN D,":"		;Found one?
	     SOJA C,ENDLP.	;Yes, no need to default device
	  ENDIF.
	  SOJG C,TOP.		;Look for device delimiter until exhausted
	  MOVE A,FILPTR		;Device not specified, must default it
	  HRRZ B,MSGJFN(M)	;b := JFN for this queued file
	  MOVE C,[100000,,1]	;Print the device part (assumed)
	  JFNS%
	  DMOVE B,RCPPTR	;Retrieve pointer/count to start over
	ENDDO.
	MOVEM A,FILPTR		;Update buffer pointer
	DMOVEM B,RCPPTR		;Update saved pointer/count
	JUMPE C,R		;In case no more text
	DO.
	  ILDB D,B		;Search for directory delimiter
	  IDPB D,A		;Stick character in buffer in case
	  CAIE D,.CHCNV		;CTRL-V?
	  IFSKP.
	    SOJLE C,R		;Yes, next character doesn't count
	    ILDB D,B
	    IDPB D,A
	  ELSE.
	    CAIE D,"["		;This is a directory delimiter too
	     CAIN D,"<"		;Found it?
	      SOJA C,ENDLP.	;Yes, no need to default directory
	  ENDIF.
	  SOJG C,TOP.		;Look for directory delimiter until exhausted
	  MOVE A,FILPTR		;Directory not specified, must default it
	  HRRZ B,MSGJFN(M)	;b := JFN for this queued file
	  MOVE C,[010000,,1]	;Print the directory part (assumed)
	  JFNS%
	  DMOVE B,RCPPTR	;Retrieve pointer/count to start over
	ENDDO.
	JUMPE C,R		;In case no more text
	DO.
	  ILDB D,B		;d := next char
	  IDPB D,A
	  SOJG C,TOP.		;Do the whole string
	ENDDO.
	IDPB C,A		;Terminate the string
	MOVE A,[POINT 7,STRBUF]	;a := ptr to start of buffer
	CIETYP <  %1W: >	;Print it if needed
	RETSKP			;Return +2

	ENDSV.
; Routine to check for append access to a file
; Entry:   a = JFN to file
;	   strbuf = file name string (must not clobber it)
; Call:    CALL SNLFCK
; Return:  +1, access not allowed
;	   +2, append access OK
SNLFCK:	SKIPL DAEMNP		;Running as daemon?
	 RETSKP			;No, system will take care of access chk
	PUSH P,A		;Save the JFN
	DMOVE A,[POINT 7,ORGAUT	;See if it was written by system server
		 POINT 7,DAEDIR]
	CALL STRCMP		;Strings match?
	 JRST SNLFC1		;No, do CHKAC% to validate access
SNLFC0:	POP P,A			;Random source, check for world append access
	MOVE B,[1,,.FBPRT]	;Want protection code for file
	MOVEI C,C		;Into C
	GTFDB%
	 ERJMP R		;Can't get protection, deny
	TXNE C,FP%APP		;Append access for the world?
	 RETSKP			;Yes, allow access
	RET			;No, deny access

CKABLK==<STRBF1+20>		;CHKAC% argument

SNLFC1:	HRROI A,STRBF1		;a := ptr for file directory string
	HRRZ B,MSGJFN(M)	;b := queue file JFN
	MOVE C,[010000,,1]	;Set STRBF1 to "connected directory", or some
	JFNS%			;suitable approximation
	MOVEI A,CKABLK-1	;Area to store CHKAC% argument block
	PUSH A,[.CKAAP]		;Tbl wd 0: append access
	PUSH A,[POINT 7,ORGAUT]	;Tbl wd 1: user name string
	PUSH A,[POINT 7,STRBF1]	;Tbl wd 2: conn dir string
	PUSH A,[0]		;Tbl wd 3: enabled privileges
	PUSH A,(P)		;Tbl wd 4: JFN for file to be accessed
	MOVE A,[CK%JFN+5]	;a := JFN flag,,tbl length
	MOVEI B,CKABLK		;b := adr of table on stack
	CHKAC%			;Check for access rights
	 ERJMP SNLFC0		;JSYS failed, check for world access
	MOVE B,A		;Get CHKAC% result in B
	POP P,A			;a := file JFN
	JUMPN B,RSKP		;Skip return if access allowed
	RET			;Else fail return
; Routine to run MMailbox program to lookup forwarding address or mailing list
; Entry:   a = ptr to user name
; Call:	   CALL MLFWRD
; Return:  +1, No forwarding
;	   +2, forwarding found

MLFWRD:	SAVEAC <A,B>		;Save calling args
	STKVAR <MBXJFN,MBXPTR>
	MOVEM A,MBXPTR		;Save mailbox pointer
	SKIPE MBXFK		;Fork already existing?
	IFSKP.
	  MOVX A,GJ%OLD!GJ%SHT	;No, get JFN of forwarder
	  HRROI B,[ASCIZ/SYS:MMAILBOX.EXE/]
	  GTJFN%
	   ERJMP R		;Not there.
	  MOVEM A,MBXJFN	;Save JFN
	  MOVX A,CR%CAP		;Create an inferior fork
	  CFORK%
	  IFJER.
	    MOVEI A,^D5000	;Failed get fork, wait 5 sec
	    DISMS%
	    MOVX A,CR%CAP
	    CFORK%
	    IFJER.
	      MOVE A,MBXJFN	;Failed again, quit
	      RLJFN%		;Punt the JFN
	       JWARN		;Don't care
	      RET		;Return to caller
	    ENDIF.
	  ENDIF.
	  MOVEM A,MBXFK		;Save fork handle
	  RPCAP%		;TOPS-20 will not let you do anything
	  TXO B,SC%SUP		; to a superior (ie IIC it) unless you
	  TXO C,SC%SUP		; have the cap to map it.
	  EPCAP%		;So enable that capability
	  MOVE A,MBXJFN		;Get back JFN
	  HRL A,MBXFK		;a := fork handle,,JFN
	  GET%			;Get pgm into fork
	   ERJMP CLRMLF
	ENDIF.
	HRLZ A,MBXFK		;a := inferior fork,,page 0
	DMOVE B,[.FHSLF,,<TMPBUF/1000> ;b := our fork,,shared page
		 PM%RD!PM%WR!PM%CNT+2]
	PMAP%
	 ERJMP CLRMLF
	MOVE A,[POINT 7,TMPBUF+200]	;a := ptr to shared page (200)
	MOVE B,MBXPTR		;b := ptr to address user name
	CALL MOVST0		;Copy string and terminating null
	MOVX A,.FHSLF		;Get our primary JFN's
	GPJFN%
	 ERJMP CLRMLF
	MOVE A,MBXFK		;Set MMailbox's to match
	SPJFN%
	 ERJMP CLRMLF
	MOVE A,MBXFK		;a := fork handle again
	MOVX B,3		;MMailr entry
	SFRKV%
	 ERJMP CLRMLF
	WFORK%			;Wait for it to halt
	 ERJMP CLRMLF
	RFSTS%			;Read status
	 ERJMP CLRMLF
	HLRZS A			;a := termination code
	CAIN A,.RFHLT		;Normal HALTF%?
	IFSKP.
	  CALL CLRMLF		;No, better clean it up
	  MOVEI A,[ASCIZ/Forwarding program error/]
	  MOVX B,FR%ERM!FR%TMP	;Temporary failure
	  CALLRET RCPLCX	;Set recipient error message
	ENDIF.
	SKIPL A,TMPBUF+177	;Check success flag
	IFSKP.
	  MOVE A,[POINT 7,STRBUF]
	  MOVEI B,[ASCIZ/Forwarding error: /]
	  CALL MOVSTR
	  HRRZ B,TMPBUF+177	;Get from inferior
	  CALL FWDCPY		;Copy here
	  SETZ B,		;Tie off string
	  DPB B,A		;Not IDPB!  FWDCPY uses MOVST0
	  MOVE A,[POINT 7,STRBUF] ;Point to error string
	  SKIPE TMPBUF+176	;Auxillary value returned?
	   SKIPA B,[FR%ERM!FR%FAI] ;Yes, failure is hard then
	    MOVX B,FR%ERM!FR%TMP ;Otherwise temporary failure
	  CALLRET RCPLCX	;Set recipient error message
	ENDIF.
	IFE. A
	  MOVEI A,[ASCIZ/No such mailbox/]
	  MOVX B,FR%ERM!FR%FAI	;Failure is hard here
	  CALLRET RCPLCX	;Set recipient error message
	ENDIF.
	CAIL A,3		;Valid local entry?
	IFSKP.
	  HRRZ B,(O)		;Temporarily link it out of the list
	  HRRM B,(X)
	  CALL UNQRCP		;Is it unique?
 	  IFSKP.
	    HRRM O,(X)		;Yes, put it back
	  ELSE.
	    CALL FREDUP
	    MOVEI O,(X)
	  ENDIF.
	  RET
	ENDIF.
	RETSKP

	ENDSV.
; Routine to clear up the MMAILBOX.EXE fork
; Entry:   MBXFK = frk handle
;	   frk pg 0 possibly mapped to TMPBUF in our space
CLRMLF:	SKIPN MBXFK		;a := fork handle
	 RET			;If none, nothing to do
	SETO A,			;Unmap shared page
	DMOVE B,[.FHSLF,,<TMPBUF/1000>
		 PM%CNT+2]
	PMAP%
	 ERJMP .+1
	HRRI B,<FWDWIN/1000>
	MOVE C,[PM%CNT+2]
	PMAP%
	 ERJMP .+1
	MOVE A,MBXFK		;a := fork handle
	KFORK%			;Get rid of fork
	 ERJMP .+1
	SETZM MBXFK		;Show fork gone
	RET			;Return
;;; Forward local mail
;;; CALL FWDLCL
;;; Returns +1 always
FWDLCL:	SKIPN MSGDOP(M)		;Delivering as mail?
	 SKIPN MSGLCL(M)	;Any local mail?
	  RET			;Terminal message or nothing local, stop now
	JSR SAVACS		;Got something to do, save all ACs
	CITYPE < Checking local mail for mailing lists>
	MOVEI X,MSGLCL(M)	;Pointer to local mail
	DO.
	  HRRZ O,(X)		;Current message pointer in O, previous in X
	  JUMPE O,R		;If done, just return
	  CALL FWDLCF		;Try to forward it
	  MOVEI X,(O)		;Set current as previous
	  LOOP.			;Try next message
	ENDDO.

;;; Try to forward a single local recipient
;;; O/ Current recipient
;;; X/ Previous recipient (in case of relinking)
FWDLCF:	MOVE A,[POINT 7,STRBUF]	;a := ptr for copy of the addressee name
	DMOVE B,RCPBPT(O)	;b,c := ptr/ctr to name
	DO.
	  ILDB D,B		;d := next char
	  IDPB D,A
	  SOJG C,TOP.		;Copy all chars in name
	ENDDO.
	IDPB C,A		;Terminate with null
	MOVE A,[POINT 7,STRBUF]	;a := ptr to user name
	CIETYPE < %1W: >
	CALL MLFWRD		;Look up forwarding address
	 RET			;No forwarding, all done

;; A valid forwarding has been found, get it out of the inferior
	MOVX T,FR%STR
	HRRZ B,RCPBPT(O)
	TDNE T,RCPFLG(O)	;Generated recipient string?
	 CALL FREBLK		;Yes, deallocate
	HRRZ B,O		;Get pointer to old block
	HRRZ O,(O)		;Get forward pointer for relinking
	CALL FREBLK		;Deallocate recipient block
	HRRM O,(X)		;Link out current block
	MOVEI Y,TMPBUF+300	;Where the expansion was put
	DO.
	  SKIPE T,(Y)		;End of addresses?
	  IFSKP.
	    MOVEI O,(X)		;Get current pointer again (O had forward ptr)
	    RET			;Go back and do next local address
	  ENDIF.
	  PUSH P,O		;Save next address
	  CALL FWDRCP		;Make recipient block
	  CAIN B,LCLNAM		;Local host?
	  IFSKP.
	    CALL ADDRCP		;No, add another recipient
	  ELSE.
	    CALL UNQRCP		;Yes, unique local recipient?
	    IFNSK.
	      CALL FREDUP	;No
	      POP P,O		;Leave O and X the same
	      AOJA Y,TOP.
	    ENDIF.
	    HRRM O,(X)		;Yes, link to previous address
	    HRRZ X,O		;Make it be previous address
	  ENDIF.
	  POP P,O		;Get back next address
	  HRRM O,(X)		;Set as next on list
	  AOJA Y,TOP.		;And try for rest of recipient
	ENDDO.

;Free duplicate recipient
FREDUP:	CIETYP <FREDUP: Duplicate recipient deleted: >
	MOVX A,.PRIOU
	MOVE B,RCPBPT(O)
	MOVN C,RCPCNT(O)
	SKIPN PRINTP
	IFSKP.
	  SOUT%
	  CALL CRLF
	ENDIF.
	MOVX T,FR%STR
	HRRZ B,RCPBPT(O)
	TDNE T,RCPFLG(O)	;Generated recipient string?
	 CALL FREBLK		;Yes, deallocate
	HRRZ B,O
	CALLRET FREBLK
;;; Skip if this recipient (O) is unique among local recipients
UNQRCP:	PUSH P,X		;Preserve caller's X
	CALL UNQRCX		;Call worker routine
	 SKIPA			;Non-skip return from worker
	  AOS -1(P)		;Skip return from worker
	POP P,X			;Restore caller's X
	RET

UNQRCX:	MOVEI X,MSGLCL(M)	;Head of local recipient list
	DO.
	  HRRZ X,(X)		;Next local rcpt
	  JUMPE X,RSKP		;It's unique
	  DMOVE A,RCPBPT(O)	;Compare them
	  DMOVE C,RCPBPT(X)
	  CALL STRCLL
	  LOOP.			;Different, try next
	ENDDO.
	RET			;Identical, string not unique
;;; Copy a string from the forwarding inferior
;;; A/ output string
;;; B/ address in inferior
FWDCPY:	STKVAR <FWDSTR,FWDADR>
	MOVEM A,FWDSTR		;Save parameters
	MOVEM B,FWDADR
	LSH B,-<^D9>		;Get inferior page number
	HRL A,MBXFK
	HRR A,B
	MOVX C,PM%CNT!PM%RD!PM%CPY!2
	CAIN B,777		;Is inferior page page 777?
	 SUBI C,1		;Yes, only map 1 page then
	MOVE B,[.FHSLF,,FWDWIN/1000]
	PMAP%
	MOVE A,FWDSTR
	LDB B,[POINT 9,FWDADR,35]
	ADDI B,FWDWIN
	CALLRET MOVST0

	ENDSV.
;;; Make a new recipient block from forwarded address
;;; T/ host,,name
;;; Returns O/ standard recipient block
FWDRCP:	PUSH P,T
	MOVEI A,RCPLEN		;Get block for this recipient
	CALL ALCBLK
	 FATAL (Memory exhausted)
	MOVEI O,(B)
	MOVX B,FR%STR
	MOVEM B,RCPFLG(O)	;Initialize flags
	MOVE A,[POINT 7,STRBUF]
	HRRZ B,(P)
	CALL FWDCPY		;Copy string from inferior
	HRROI A,STRBUF
	CIETYP <  %1W>
	CALL CPYSTR		;Get byte pointer and count
	HRLI B,(<POINT 7,0>)
	DMOVEM B,RCPBPT(O)	;Save them
	POP P,T
	HLRZ B,T		;Get host address
	JUMPE B,FWDRC1		;Local
	MOVE A,[POINT 7,HSTBUF]
	CALL FWDCPY		;Copy host name from inferior
	DO.
	  TXNN A,76B4		;Filled to word boundary?
	   EXIT.
	  IDPB D,A		;No, do another null
	  LOOP.
	ENDDO.
	HRROI B,HSTBUF
	ETYPE <@%2W>
	CALL HSTNAM
	 SKIPA
	  RET
	CALL RCPLXH		;Put in error for no such host
FWDRC1:	MOVEI B,LCLNAM		;And store as local
	RET
	SUBTTL Requeue or send failure message for message in M

REMAIL:	JSR SAVACS		;Save all ACs
	STKVAR <RMLJFN>
	TXZ F,FQ%SXX		;Clear flags
	SETZM MSGTMT(M)		;No more timeouts when requeueing
	SKIPE NTDEQF		;Dequeueing file or notifying sender?
	 CALL SERRCP		;Yes, finalize errors
REMAI0:	SETZM FAIJFN		;Reset output jfn's
	SETZM NTFJFN
	SETZB N,REQJFN		;Do local mail
	TXZ F,FQ%OMF!FQ%MLA!FQ%SDR!FQ%RNM!FQ%XNT!FQ%XER  ;Clear flags
	MOVE A,FILIDX		;a := flags for current queue file type
	MOVE A,%FLFLG(A)
	TXNE A,FF%OML		;Old style?
	 TXO F,FQ%OMF		;Yes
	TXNE A,FF%RNM		;Rename to add RETRANSMIT extension?
	 TXO F,FQ%RNM		;Yes
	TXNE A,FF%XNT		;Suppress non-delivery notifications?
	 TXO F,FQ%XNT		;Yes
	MOVX A,FG%XER		;Discard on error?
	TDNE A,MSGJFN(M)
	 TXO F,FQ%XER		;Yes

;;; I think it's probably all right to allow local mail here, even if not WOPR
	MOVEI O,MSGLCL(M)
	TXZ F,FQ%ALL
	CALL REMALS		;Hack this list
	MOVEI N,MSGRCP(M)
	DO.
	  HRRZ N,(N)
	  JUMPE N,ENDLP.
	  MOVX T,FH%DON		;This host got done?
	  TDNN T,HSTFLG(N)
	   TXOA F,FQ%ALL	;No, output it all
	    TXZ F,FQ%ALL
	  MOVEI O,HSTRCP(N)
	  CALL REMALS
	  LOOP.
	ENDDO.
	SKIPN NTFJFN		;Sender notification?
	 SKIPE FAIJFN		;Or failure file?
	IFNSK.
	  CALL GENHDL		;Build local headers
	  SKIPN A,FAIJFN	;Failure file?
	  IFSKP.
	    MOVEI B,OUTMSG	;Routine to output headers/text
	    CALL REMHTX		;Do it with punctuation
	    TXNN F,FQ%SXX	;Processing rerouted failure msg?
	     TXNN F,FQ%SDR	;No, fail on sender?
	    IFSKP.
	      IFXE. F,FQ%MLA	;Also fail on mail agent?
		TXO F,FQ%SXX	;Divert failure msg to mail agent
		DELF%		;Delete current reply file
		 JFATAL
		CLOSF%		;Close it
		 JFATAL
		SKIPN A,REQJFN	;Also requeue file?
		IFSKP.
		  CLOSF%	;Yes, close it
		   JFATAL
		  SETZM REQJFN
		ENDIF.
		SKIPN A,NTFJFN	;Also notification file?
		IFSKP.
		  DELF%		;Delete it
		   JFATAL
		  CLOSF%	;And close it
		   JFATAL
		  SETZM NTFJFN
		ENDIF.
		JRST REMAI0
	      ENDIF.
	      TXO A,CO%NRJ	;Close fail msg file and keep JFN
	      CLOSF%
	       JFATAL
	      MOVEI A,0(A)	;Now rename the file to "bad mail"
	      CALL RENBAX
	    ELSE.
	      CLOSF%		;Close out failure file
	       JFATAL
	      SKIPN NTFJFN	;Only set flags once
	       SKIPE REQJFN
		SKIPA
		 CALL MAIFLG
	    ENDIF.
	  ENDIF.
	  SKIPN A,NTFJFN	;Notification file pending?
	  IFSKP.
	    MOVEI B,OUTMSH	;Routine to output headers and no text
	    CALL REMHTX		;Do it with punctuation
	    CLOSF%		;Close out notification file
	     JFATAL
	    SKIPN REQJFN	;Only set flags once
	     CALL MAIFLG
	  ENDIF.
	ENDIF.
	SKIPN A,REQJFN		;Have a requeue file?
	 RET			;No, all done
	MOVEI B,.CHFFD		;No, must end addressee specs
	BOUT%
	HRROI B,CRLF0
	SETZ C,
	SOUT%
	DMOVE B,MSGHDR(M)	;Finish off file
	MOVNI C,(C)
	SOUT%
	TXO A,CO%NRJ		;Close file, preserve JFN
	CLOSF%
	 JFATAL
	HRRZ A,MSGJFN(M)	;Get back JFN of original file
	MOVEM A,RMLJFN
	TXO A,CO%NRJ
	CALL UNMQUF		;Unmap, leave JFN
	 RET			;Percolate error up
	MOVE A,RMLJFN
	HRLI A,.GFLWR		;Save file writer
	HRROI B,STRBUF
	GFUST%
	 ERJMP .+1
	IFXN. F,FQ%RNM!FQ%OMF	;Rename file extension or old mail first?
	  HRROI A,STRBF1	;Yes, construct new name
	  MOVE B,RMLJFN		;From original file's JFN
	  IFXN. F,FQ%OMF
	    MOVX C,JS%DEV!JS%DIR!JS%PAF
	    JFNS%
	    TXNN F,FQ%XNT	;Notify about errors?
	     SKIPA B,[[ASCIZ/[--QUEUED-MAIL--]/]]
	      MOVEI B,[ASCIZ/[--RETURNED-MAIL--]/]
	  CALL MOVSTR
	  ELSE.
	    MOVX C,JS%DEV!JS%DIR!JS%NAM!JS%PAF
	    JFNS%
	  ENDIF.
	  SKIPN NETF		;Were we allowed to deliver network mail?
	   SKIPA B,[[ASCIZ/.NETWORK;P770000/]] ;No, use alternate name
	    MOVEI B,[ASCIZ/.RETRANSMIT;P770000/] ;Yes, use standard name
	  CALL MOVST0
	  DO.
	    MOVX A,GJ%NEW!GJ%FOU!GJ%ACC!GJ%SHT ;And rename the file
	    HRROI B,STRBF1
	    GTJFN%
	    IFJER.
	      CAIE A,GJFX24	;Work around monitor bug
	       JWARN <Cannot get RETRANSMIT file>
	      MOVEI A,^D5000	;Wait 5 seconds
	      DISMS%
	      LOOP.
	    ENDIF.
	    MOVE B,A		;JFN of name we will rename to
	  ENDDO.
	  EXCH A,RMLJFN		;Set original file JFN, get former one
	  CALL RNMFIL
	  IFNSK.
	    JWARN <Unable to rename to RETRANSMIT extension>
	    MOVEM A,RMLJFN	;Rename failed, restore former name
	    MOVE A,B		;JFN we tried to use
	    RLJFN%		;Flush this useless JFN
	     ERJMP .+1		;Don't care if it fails
	  ENDIF.
	ENDIF.
	MOVE A,REQJFN		;Requeue file we just made
	MOVE B,RMLJFN		;Original file JFN
	CALL RNMFIL
	IFNSK.
	  JWARN <Cannot rename requeue file>
	  EXCH A,RMLJFN		;A:=existing JFN, RMLJFN:=JFN failed to rename
	  RLJFN%		;Flush the failing JFN
	   NOP
	ENDIF.
	MOVE A,RMLJFN		;JFN we ended up with
	MOVEI B,MSGWRT(M)	;Set its write date
	MOVEI C,1
	SFTAD%
	 ERJMP .+1
	HRROI B,STRBUF
	CALL .SFUST		;Set its writer
	MOVE B,RMLJFN
	RLJFN%
	 JWARN
	CALL MAIFLG		;Set flags unless already did
	IFXN. F,FQ%RNM!FQ%OMF	;Rename file extension or old mail first?
	  SKIPN NETF		;Did we queue something for the network fork?
	   CALL WAKNET		;Yes, go wake it up
	ENDIF.
	RET

	ENDSV.
;; Routine to output msg headers and text with punctuation to a
;; notification or error file
; Entry:   a = output jfn
;	   b = message output routine
REMHTX:	PUSH P,B		;Save output routine
	HRROI B,[ASCIZ/	    ------------
/]
	SETZ C,
	SOUT%			;Do starting punctuation
	POP P,B			;Execute output routine
	CALL (B)
	 JFATAL <Local message output lost> ;+1, error???
	HRROI B,[ASCIZ/-------
/]
	SETZ C,
	SOUT%			;Add trailing punctuation
	RET
;; Check one list of recipients
REMALS:	TXZ F,FQ%HST		;Host not yet output
REMLS1:	HRRZ O,(O)
	JUMPE O,R		;Done with list
	DO.
	  IFXE. F,FQ%ALL	;Output all of this host?
	    MOVE A,RCPFLG(O)	;a := recipient flags,,link to next
	    TXNN A,FR%FAI	;Permanent failure?
	     TXNN A,FR%TMP	; or no errors?
	      EXIT.		;Then don't requeue this one
	  ENDIF.
	  TXON F,FQ%HST		;Already got host?
	   CALL REMLHS		;No, output it
	  HRRZ A,REQJFN		;a := requeue file JFN
	  MOVE B,RCPBPT(O)
	  MOVN C,RCPCNT(O)
	  SOUT%
	  HRROI B,CRLF0
	  SETZ C,
	  SOUT%
	  SKIPG NTDEQF		;Notifying sender of status?
	  IFSKP.
	    SKIPN A,NTFJFN	;Yes, JFN already set up?
	     CALL REMNTF	;No, do it
	    CALL APPERM		;Now append error msg
	  ENDIF.
	ENDDO.
	MOVX T,FR%FAI
	TXNN F,FQ%ALL		;Outputing all of this host?
	 TDNN T,RCPFLG(O)	;Or not permanent failure?
	IFSKP.
	  IFN. N		;If not local mail,
	    CALL MMLGT		;Check for mail agent failure
	    CALL MSNDR		;And sender failure
	  ENDIF.
	  MOVE A,RCPFLG(O)	;a := recip flags,,link to next recip
	  IFXN. A,FR%MLA	;Is this a failure for mail agent?
	    TXON F,FQ%MLA	;Yes
	     WARN <Failed sending msg to Mail Agent>
	  ENDIF.
	  TXNE A,FR%SDR		;Is this a failure for the sender?
	   TXO F,FQ%SDR		;Yes
	  IFXN. F,FQ%XER	;Discard this file on error?
	    MOVEI A,[ASCIZ/ Message queued too long, file purged/]
	    SKIPL NTDEQF	;Dequeueing file?
	     MOVEI A,[ASCIZ/ Message file purged/] ;No, must be error
	    UTYPE 1,(A)		;Type appropriate msg
	  ELSE.
	    SKIPE A,FAIJFN
	    IFSKP.
	      SKIPGE NTDEQF	;Dequeue this file?
	       CITYPE < Message queued too long, sender notified>
	      CALL REMLFA	;Init failure file
	    ENDIF.
	    CALL APPERM		;Append the name and error msg
	  ENDIF.
	ENDIF.
	JRST REMLS1
;; Routine to append recipient name and error msg to a sender
;; notification or error file.
;  a = output jfn
;  o = adr of recipient block

APPERM:	MOVE B,RCPBPT(O)	;b/c := recipient name ptr
	MOVN C,RCPCNT(O)
	SOUT%
	MOVEI B,"@"
	BOUT%
	IFE. N			;Output host
	  HRROI B,LCLNAM
	ELSE.
	  HRRO B,HSTHST(N)
	ENDIF.
	SOUT%
	HRROI B,[ASCIZ/: /]
	SOUT%
	HRRO B,RCPERR(O)	;And the error msg
	TXNN B,.RHALF		;Given?
	 HRROI B,[ASCIZ/No error msg given./]
	SOUT%
	HRROI B,CRLF0		;Append a CRLF
	SOUT%
	RET

;; Output host first time
REMLHS:	SKIPN A,REQJFN
	 CALL REMLRQ
	MOVEI B,.CHFFD
	BOUT%
	IFE. N
	  HRROI B,LCLNAM
	ELSE.
	  HRRO B,HSTHST(N)
	ENDIF.
	SETZ C,
	SOUT%
	HRROI B,CRLF0
	SOUT%
	RET
;; Start of requeue file
REMLRQ:	HRROI A,STRBF1		;As good a place as any I guess
	HRRZ B,MSGJFN(M)	;JFN for queued file
	MOVE C,[110000,,1]	;Print device and directory
	JFNS%
	HRROI B,[ASCIZ/-REQUEUED-MAIL/]
	SETZ C,
	SOUT%			;Append our filename to it
	MOVEI B,"-"
	IDPB B,A
	MOVE B,MYJOBN		;Set up job number
	MOVEI C,^D10		;Output in decimal
	NOUT%
	 JFATAL
	MOVEI B,"-"
	IDPB B,A
	MOVE B,FORKX		;Tack in fork number
	NOUT%
	 JFATAL
	HRROI B,[ASCIZ/.TMP.-1/]
	SETZ C,
	SOUT%			;Append our filename to it
	MOVX A,GJ%FOU!GJ%NEW!GJ%SHT
	HRROI B,STRBF1
	GTJFN%
	IFJER.
	  CAIN A,GJFX24		;Somebody's DELDF% screwed us? (monitor bug)
	  IFSKP.
	    MOVEI A,STRBF1	;No, set up name for warning
	    JWARN <Can't get %1W in REMLRQ>
	  ENDIF.
	  MOVEI A,^D5000	;Wait 5 seconds
	  DISMS%
	  JRST REMLRQ		;Try again
	ENDIF.
	MOVEM A,REQJFN		;Save the JFN
	MOVX B,<<FLD ^D7,OF%BSZ>!OF%WR>
	OPENF%
	IFJER.
	  CAIN A,OPNX2		;Somebody's DELDF% screwed us? (monitor bug)
	  IFSKP.
	    MOVE B,REQJFN	;Get JFN for message
	    JWARN <Can't open %2J in REMLRQ>
	  ENDIF.
	  MOVE A,REQJFN		;Flush JFN
	  RLJFN%
	   JWARN
	  MOVEI A,^D5000	;Wait 5 seconds
	  DISMS%
	  JRST REMLRQ		;Try again
	ENDIF.
	MOVX B,.CHFFD		;Output delivery option
	BOUT%
	HRROI B,[ASCIZ/=DELIVERY-OPTIONS:/]
	SOUT%
	MOVE B,MSGDOP(M)
	HLRO B,DOPTAB(B)	;Get delivery option string
	SOUT%
	HRROI B,CRLF0
	SOUT%
	SKIPN D,MSGFHS(M)	;Net host spec?
	IFSKP.
	  MOVEI B,.CHFFD	;Output keyword part
	  BOUT%
	  HRROI B,[ASCIZ/=NET-MAIL-FROM-HOST:/]
	  SOUT%
	  HRRO B,D
	  SOUT%
	  HRROI B,CRLF0
	  SOUT%
	ENDIF.
	SKIPN MSGRPT(M)		;Return path specified?
	IFSKP.
	  MOVEI B,.CHFFD	;Yes, copy it to output
	  BOUT%
	  HRROI B,[ASCIZ/=RETURN-PATH:/] ;Yes, output it
	  SETZ C,
	  SOUT%
	  HRRO B,MSGRPT(M)	;Now output the path
	  SOUT%
	  HRROI B,CRLF0		;Terminating CRLF
	  SOUT%
	ENDIF.
	SKIPN C,MSGAFT(M)	;After specified?
	IFSKP.
	  CAMG C,CURDTM		;Yes, before current time?
	  IFSKP.
	    HRROI B,[ASCIZ/=AFTER: /] ;No, write new after period
	    CALL OUDTIM		;Output after parameter
	  ELSE.
	    SETZM MSGAFT(M)	;Set no after parameter
	  ENDIF.
	ENDIF.
	IFXE. F,FQ%XNT		;Suppress non-delivery notifications?
	  SKIPE C,MSGNTF(M)	;No, sender notification time set?
	  IFSKP.
	    SKIPN C,MSGAFT(M)	;Must compute it, have an After time?
	     SKIPA C,CURDTM	;No, start with current time then
	      ADD C,NTFINT	;Otherwise use After time plus notify interval
	  ENDIF.
	  DO.
	    CAMLE C,CURDTM	;Past current time?
	    IFSKP.
	      ADD C,NTFINT	;No, bump an interval
	      LOOP.		;And try again
	    ENDIF.
	  ENDDO.
	  HRROI B,[ASCIZ/=NOTIFY: /]
	  CALL OUDTIM		;Use previous notification time
	ENDIF.
	SKIPE C,MSGDEQ(M)	;Dequeue time set?
	IFSKP.
	  MOVE C,MSGWRT(M)	;No, get write time
	  CAMG C,MSGAFT(M)	;Is an after time specified that's greater?
	   MOVE C,MSGAFT(M)	;Yes, use after time as base
	  ADD C,MAXQUE		;Plus interval
	ENDIF.
	HRROI B,[ASCIZ/=DEQUEUE: /]
	CALL OUDTIM		;Use previous dequeue time
	TXNE F,FQ%XER		;Discard on error?
	 CALL DSCRDE		;Yes, retain that property
	CALLRET SDRHDR		;Write the sender spec
;; Routine to output a time difference (t1 - t2) in days.
; Entry:   a = output jfn
;	   b = t1 (internal date/time format)
;	   c = t2 (internal date/time format)

OTMDIF:	SUB B,C			;Compute time difference
	CAIGE B,0		;Set neg value to 0
	 SETZ B,
	ADDI B,400000		;Round to nearest day
	HLRZS B
	MOVEI C,^D10		;Print it in decimal
	NOUT%
	 JFATAL
	MOVE C,B		;Save the value
	HRROI B,[ASCIZ/ days/]
	CAIN C,1		;Exactly one?
	 HRROI B,[ASCIZ/ day/]
	SETZ C,
	SOUT%
	RET

;;; Routine to compute internal date/time after given delay
; Entry:   b = delay in seconds
;	   curdtm = current date/time
; Call:    CALL DLYTIM
; Return:  +1, c = new date/time
DLYTIM:	HRLZ C,B		;Normalize delay to internal std
	IDIVI C,^D<24*60*60>
	ADD C,CURDTM		;Add on current time
	RET

;;; Routine to output a date/time control parameter
; Entry:   b = ptr to parameter keyword
; 	   c = internal time value
; Call:    CALL OUDTIM
; Return:  +1
OUDTIM:	PUSH P,C		;Save the time
	PUSH P,B		;And the text ptr
	MOVEI B,.CHFFD		;Output keyword part
	BOUT%
	POP P,B
	SETZ C,
	SOUT%
	POP P,B			;Now the time
	MOVX C,OT%NSC!OT%SCL
	ODTIM%
	HRROI B,CRLF0		;End line
	SETZ C,
	SOUT%
	RET
;; Init failure file
REMLFA:	CALL RESPQF		;Initialize the file
	IFXE. F,FQ%SXX		;Divert reply to mail agent?
	  CALL SDRADR		;Addressee = sender
	ELSE.
	  CALL MLAADR		;Addressee = mail agent
	ENDIF.
	CALL RESPQB		;Finish up the file
	MOVEM A,FAIJFN
	HRROI B,[ASCIZ/Message of /]
	SETZ C,
	SOUT%
	MOVE B,MSGWRT(M)	;b := file write date/time
	MOVX C,OT%SCL
	ODTIM%
	SKIPGE NTDEQF		;Last try?
	IFSKP.
	  HRROI B,[ASCIZ/

Message failed for the following:
/]
	  SETZ C,
	ELSE.
	  HRROI B,[ASCIZ/

Message undeliverable and dequeued after /]
	  SETZ C,
	  SOUT%
	  MOVE B,CURDTM		;Compute time in queue so far
	  MOVE C,MSGWRT(M)
	  CALL OTMDIF		;And output it
	  HRROI B,[ASCIZ/:
/]				;Finish punctuation
	ENDIF.
	SOUT%
	RET
;; Routine to initialize a response file to notify sender that msg has
;; not been sent.
REMNTF:	CALL RESPQN		;Initialize the file
	CALL SDRADR		;Addressee = sender
	CALL DSCRDE		;Set discard parameter
	CALL RESPQB		;Finish up the file
	MOVEM A,NTFJFN
	HRROI B,[ASCIZ/Message of /]
	SETZ C,
	SOUT%
	MOVE B,MSGWRT(M)	;b := file write date/time
	MOVX C,OT%SCL
	ODTIM%
	HRROI B,[ASCIZ/

Message undelivered after /]
	SETZ C,
	SOUT%
	MOVE B,CURDTM		;Output time in queue
	MOVE C,MSGWRT(M)
	CALL OTMDIF
	HRROI B,[ASCIZ/ -- will try for another /]
	SOUT%
	MOVE B,MSGDEQ(M)	;Output remaining time in queue
	MOVE C,CURDTM
	CALL OTMDIF
	HRROI B,[ASCIZ/:
/]				;Finish punctuation
	SOUT%
	RET
;;; Routine to rename a file
; Entry:   a = source file jfn
;	   b = destination file JFN
; Call:    CALL RNMFIL
; Return:  +1, error
;	   +2, success
RNMFIL:	SAVEAC <A,B>
	STKVAR <SRC,DST>
	MOVEM A,SRC		;Save source/destination JFNs
	MOVEM B,DST
	DO.
	  RNAMF%		;Rename, superceding
	  IFJER.
	    CAIE A,RNAMX5	;File busy?
	     RET
	    MOVEI A,^D5000	;Yes, wait 5 seconds and try again
	    DISMS%
	    MOVE A,SRC		;Get back source
	    LOOP.
	  ENDIF.
	ENDDO.
	MOVE A,DST		;Get destination JFN
	HRLI A,.FBBYV		;Set to retain infinite versions
	MOVX B,FB%RET
	SETZ C,
	CHFDB%
	 ERJMP .+1		;Ignore failure
	RETSKP

	ENDSV.
	SUBTTL Internet routines

; B/	Host name to connect to
; C/	Host number to connect to

INTSND:	CAMN C,$UKHST		;Unknown host address?
	 JRST ADEADH		;Yes, fail right away
	STKVAR <INTDST,INTADR,INTTRY,INTERR,DSTHPT>
	MOVEM A,DSTHPT		;Save the ultimate destination
	MOVEM B,INTDST		;Save destination
	MOVEM C,INTADR		;Save destination address
	MOVX A,^D10		;Don't loop more than 10 times
	MOVEM A,INTTRY
	HRROI A,LCLNCN		;Local name for this network
	SETO B,			;Output local host
	CALL $GTHNS
	 FATAL (Can't get Internet local host name)
	MOVE A,INTDST		;Get immediate destination
	MOVE B,DSTHPT		;Ultimate destination host
	CALL GENHDR		;Generate headers
	MOVE N,SAVEN		;n := starting recipient host
	MOVEI O,HSTRCP(N)	;o := start of recipient list
	MOVE A,[POINT 7,STRBUF]	;a := ptr to net file name str
	DO.
	  MOVEI B,[ASCIZ/TCP:/]	;Build device
	  CALL MOVSTR
;;; By default, DEC uses a port number of 100000+<job#>_6+<JFN#>
;;;For most applications, this is alright.  It is not good enough
;;;for us, however.  We open lots of connections, and are quite
;;;likely to get the same JFN each time.  Because of this, any time
;;;we open to the same host in succession we're in danger of getting
;;;the same TCB before it's been fully flushed.  What we'll do is use
;;;a slightly smarter version of DEC's algorithm, keeping within the
;;;reserved port number space if possible.
	  PUSH P,A
	  GJINF%		;Get our job number for local port
	  POP P,A
	  SKIPN C		;Job 0?
	   MOVEI C,377		;Yes, do not use a small port number!
	  LSH C,6		;Put job # where DEC expects it
	  AOS B,NXTSEQ		;Get next number in sequence
	  ANDI B,37		;Cycle through 5 bits
	  IOR B,C		;Merge in job number
	  MOVE C,FORKX		;Get our fork ID
	  CAIN C,NETFRK		;Net fork?
	   TXO B,40		;Yes, distinguish between it and rxmfrk
	  SKIPN WOPRP		;Privileged?
	   TXZA B,100000	;Yes, make sure an unprivileged port
	    TXO B,100000	;Yes, make like we're using a DEC port!
	  MOVX C,^D10		;Ports are decimal
	  NOUT%
	   ERJMP R		;Failed
	  MOVEI B,[ASCIZ/#./] ;Privileged use of absolute local port
	  SKIPN WOPRP		;Privileged?
	   MOVEI B,[ASCIZ/./]	;No, just delimit to foreign port
	  CALL MOVSTR
	  MOVE B,INTADR		;Destination host number
	  MOVX C,^D8		;TCP: hosts are in octal
	  NOUT%			;Output to file string
	   ERJMP R		;Shouldn't fail
	  MOVEI B,[ASCIZ/-25;CONNECTION:ACTIVE/] ;Port 25
	  CALL MOVST0
	  SETOM INTERR		;No default "OPENF% error code"
	  MOVX A,GJ%SHT		;Short form
	  HRROI B,STRBUF	;Pointer to file string we made
	  GTJFN%		;Make a JFN on it
	   ERJMP ADEADH		;Failed so mark dead
	  MOVEM A,NETJFN	;Save JFN
	  MOVX B,<<FLD ^D8,OF%BSZ>!<FLD .TCMWH,OF%MOD>!OF%RD!OF%WR>
	  DO.			;Begin timed control block
	    TMOSET (^D30,ENDLP.) ;Quit after 30 seconds
	    OPENF%		;Open 8 read/write buffered and wait
	    IFNJE.
	      TMOCLR		;Got it, clear timer
	      CALL SMTSND	;Call SMTP worker routine
	      DO.
		TMOSET (^D60,ENDLP.) ;Don't wait too long for the FIN to happen
		MOVE A,NETJFN	;Send a FIN to the other end
		MOVX B,.TCSFN
		TCOPR%		;Send the FIN
		IFNJE.
		  DO.		;Now go into a loop slurping bytes from
		    BIN%	; the other end
		     ERJMP ENDLP. ;Closed, JFN close okay now
		    LOOP.	;Keep going until slurped up last byte
		  ENDDO.
		ENDIF.
	      ENDDO.
	      TMOCLR
	      CALL $CLOSF	;Close the connection
	      RETSKP		;Success return
	    ELSE.
	      MOVEM A,INTERR	;Save last error code if OPENF% failed
	    ENDIF.
	  ENDDO.		;End of timed control block
	  TMOCLR		;Clear timer
	  MOVE A,NETJFN		;Get Internet JFN back
	  RLJFN%		;Release it
	   JWARN
	  SETZM NETJFN
	  MOVE A,INTERR		;Get back last error
	  CAIN A,TCPX19		;Connection already exists?
	   SOSLE INTTRY		;Yes, have any more retries?
	    JRST ADEADH		;Other error or out of retries
	  LOOP.			;Yes to both, try next port up
	ENDDO.

	ENDSV.
;;; SMTP routines, independent of Internet

; SMTP command reply summary
; ^D220			;Server greeting
; ^D250			;OK
; ^D251			;OK, but will forward
; ^D354			;Ready for message
; ^D4xx			;Soft failure
; ^D5xx			;Hard failure
; ^D500			;Unrecognized command
; ^D501			;Unimplemented command
; ^D550			;No such mailbox

SMTSND:	STKVAR <SMTDOP,SMTHPT,DOMPTR,<HSTTMP,^D13>,<HSTLCL,^D13>>
	HRROI A,HSTLCL		;Make absolute copy of local name string
	HRROI B,LCLNCN
	CALL OUTAHS
	MOVE A,MSGDOP(M)	;Get message's delivery option
	MOVEM A,SMTDOP		;And save as a temporary here
	CALL SMRPLY		;Get greeting message
	 JRST SMTJER
	CAIE B,^D220		;Success reply is 220
	 JRST SMTSMF
	MOVE A,NETJFN		;Negotiate HELO command
	HRROI B,[ASCIZ/HELO /]
	SETZ C,
	CALL $SOUT
	 JRST SMTJER
	HRROI B,HSTLCL		;Absolute form of local host
	CALL SMMESG
	 JRST SMTJER
	CAIE B,^D250		;Success reply is 250
	 JRST SMTSMF
	MOVE A,NETJFN		;Negotiate MAIL FROM command
	MOVE B,SMTDOP		;Get delivery option index
	HLRO B,DOPTAB(B)	;Get delivery option string
	SETZ C,
	CALL $SOUT
	 JRST SMTJER
	HRROI B,[ASCIZ/ FROM:</]
	DO.
	  CALL $SOUT
	   JRST SMTJER
	  SKIPN D,MSGRPT(M)	;Have a return path?
	  IFSKP.
	    MOVEI B,"@"		;Yes, must prepend local host as part
	    CALL $BOUT		;of source route.  Output an at
	     JRST SMTJER
	    HRROI B,HSTLCL	;Local host name
	    CALL $SOUT
	     JRST SMTJER
	    MOVE B,MSGRPT(M)	;Make pointer to return path
	    HRLI B,(<POINT 7,>)
	    ILDB B,B		;Get first character of return path
	    CAIE B,"@"		;Additional source routing specification seen?
	     SKIPA B,[":"]	;No, use colon to terminate source routing
	      MOVEI B,","	;Else must use comma for continuation
	    CALL $BOUT		;Output the character
	     JRST SMTJER
	    MOVE D,B		;Last delimiter
	    MOVE B,MSGRPT(M)	;Now output return path
	    HRLI B,(<POINT 7,>)
	    SETZ C,		;Terminate on null
	    CALL $SOUT
	     JRST SMTJER
	  ELSE.			;Return path not known, create one using sender
	  ANDQE. FG%XER,MSGJFN(N) ;But not if discarding errors!
	    MOVE D,MSGSDR(M)	;D := addr of sender host entry block
	    HRRZ C,HSTRCP(D)	;C := adr of recipient entry block
	    HRRZ B,RCPBPT(C)	;B := ptr to sender name
	    CAIN B,MLAGNT	;Only do this if not mail agent
	  ANSKP.
	    HRROI A,STRBUF	;Output to recipient buffer
	    MOVE B,RCPBPT(C)	;B,C := sender name ptr/byte count
	    MOVN C,RCPCNT(C)	;C := neg byte count
	    SOUT%
	    HRRZ B,HSTHST(D)	;B := sender host pointer
	    CAIN B,LCLNAM	;Is it our host?
	     MOVEI B,HSTLCL	;Yes, use canonical form
	    MOVEM B,SMTHPT	;Save host pointer
	    CAIN B,HSTLCL	;Is it me?
	    IFSKP.
	      MOVEI B,"%"	;Punctuate
	      IDPB B,A
	      MOVEI B,HSTLCL	;Set up local name
	      EXCH B,SMTHPT	;Restore host
	      HRROS B
	      SOUT%
	    ENDIF.
	    MOVE C,A		;Save termination
	    MOVE A,NETJFN	;Restore JFN
	    MOVE B,[POINT 7,STRBUF]
	    CALL QOTSTR		;Output it quoted
	     JRST SMTJER
	    MOVEI B,"@"		;Punctuate
	    CALL $BOUT
	     JRST SMTJER
	    HRRO B,SMTHPT	;Restore host
	    CALL $SOUT		;Output host name
	     JRST SMTJER
	  ENDIF.		;End of return-path output conditional
	  HRROI B,[ASCIZ/>/]
	  CALL SMMESG
	   JRST SMTJER
	  CAIN B,^D250		;Success reply is 250
	  IFSKP.
	    MOVE A,NETJFN	;Failed, restore JFN
	    MOVE B,SMTDOP	;Get delivery option index
	    HLRO B,DOPTAB(B)	;Get delivery option string
	    SETZ C,
	    CALL $SOUT		;Output delivery option
	     JRST SMTJER
	    HRROI B,[ASCIZ/ FROM:<>/] ;Output null return path in case the SMTP
	    CALL SMMESG		; server didn't like its syntax...
	     JRST SMTJER
	    CAIN B,^D250	;Did it win this time?
	    IFSKP.
	      SKIPN SMTDOP	;No, non-MAIL delivery option?
	      IFSKP.
		SETZM SMTDOP	;Yes, convert to MAIL delivery option
		MOVE A,NETJFN	;Restore JFN
		LOOP.		;and try again
	      ENDIF.
	      JRST SMTSMF	;Treat as failure of entire message
	    ENDIF.
	  ENDIF.
	ENDDO.
	TXZ F,FM%VRC		;Initially no valid recipient seen
	DO.
	  CALL NXTRCP		;Get next recipient
	  IFSKP.
	    CALL RSTRCP		;Reset error flags from other tries
	    MOVE A,NETJFN	;Start transaction
	    HRROI B,[ASCIZ/RCPT TO:</]
	    SETZ C,
	    CALL $SOUT
	     JRST SMTJER
	    MOVE A,[POINT 7,STRBUF]
	    CALL OUTRCP		;Output recipient name to STRBUF
	    MOVE C,A		;End of string pointer
	    MOVE A,NETJFN
	    MOVE B,[POINT 7,STRBUF] ;Recipient name to output
	    CALL QOTSTR		;Output it, quoted
	     JRST SMTJER	;Output failed
	    MOVE A,[POINT 7,STRBUF]
	    MOVX B,"@"
	    IDPB B,A
	    HRRO B,FRNHST	;Get site we are talking to
	    CALL OUTAHS		;Output it
	    MOVEI B,">"
	    IDPB B,A
	    SETZ B,
	    IDPB B,A
	    HRROI B,STRBUF
	    CALL SMMESG
	     JRST SMTJER
	    ETYPE <%1W>		;Type reply for user
	    CAILE B,^D299	;Valid recipient?
	    IFSKP.
	      TXO F,FM%VRC	;Flag a valid recipient seen
	    ELSE.
	      CAIGE B,^D500	;Hard fail code?
	       SKIPA B,[FR%TMP!FR%ERM] ;No, temporary error
		MOVX B,FR%FAI!FR%ERM ;Yes, permanent
	      CALL STEMSG	;Flag the user failure
	    ENDIF.
	    LOOP.
	  ELSE.
	    ANDXN. F,FM%VRC	;A valid recipient seen?
	    CITYPE < >		;Yes, indicate sending the message text
	    HRROI B,[ASCIZ/DATA/]
	    CALL SMMESG		;Get reply
	     JRST SMTJER
	    CAIE B,^D354	;Good reply?
	     JRST SMTSMF	;No, whole message fails
	    MOVE A,NETJFN	;Get output designator
	    CALL MSGOUT		;Output message, checking for periods
	     JRST SMTJER	;+1 Network error
	    CALL SMRPLY		;Get a reply
	     JRST SMTJER
	    ETYPE <%1W>		;Type reply
	    CAIE B,^D250	;250 is success reply
	     JRST SMTSMF	;Whole message fails
	  ENDIF.
	ENDDO.
SMTQIT:	HRROI B,[ASCIZ/QUIT/]	;Negotiate QUIT command
	CALL SMMESG
	 NOP			;Don't care
	RET

	ENDSV.
;;;JSYS error in SMTP dialog
SMTJER:	TMOCLR			;No more interrupts
;	CALLRET NETJER

NETJER:	HRROI A,STRBUF		;Create error string
	HRLOI B,.FHSLF		;This fork,,last error
	SETZ C,
	ERSTR%
	 ERJMP .+1
	 ERJMP .+1
	HRROI A,STRBUF		;Set up string for SMTSMF
	CETYPE <%1W>		;Type error msg for user
	MOVX B,FR%TMP!FR%ERM	;Yes, save error info for dequeue
	CALLRET STUMSG		;Update user errors

;;;Entire message fails due to SMTP error reply
SMTSMF:	CETYPE <%1W>		;Type error msg for user
	CAIGE B,^D500		;Hard fail code?
	 SKIPA B,[FR%TMP!FR%ERM] ;No, mark as soft
	  MOVX B,FR%ERM!FR%FAI	;Otherwise hard
	CALL STUMSG		;Update user errors
	JRST SMTQIT
;;; SMTP quoting

;Accepts:
; A/ Destination designator
; B/ Source pointer - may not be to STRBF1!!!!!!!
; C/ End of source string pointer or 0 to terminate on null
;	CALL QOTSTR
;Returns +1: JSYS error
;	 +2: success
; Clobbers STRBUF, STRBF1

QOTSTR:	SAVEAC <A,D,T,TT>
	STKVAR <QOTDES,QOTSRC,QOTTMP,QOTCNT>
	MOVEM A,QOTDES		;Save output designator
	MOVEM B,QOTSRC		;Save source pointer
	MOVE A,[POINT 7,STRBF1] ;Pointer to temporary buffer
	MOVEM A,QOTTMP		;Save temporary buffer pointer
	MOVE A,C		;End of string pointer
	SETZM QOTCNT		;Initial number of copied bytes count
	TXZ F,FM%QOT		;Initially require no quoting
	MOVX B,"\"		;Quote for wierd characters
	DO.			;Copy to STRBF1 with \ insert and " need check
	  IFN. A		;If end of string pointer exists
	    CAMN A,QOTSRC	;Reached end of buffer?
	     EXIT.		;Yes, leave now
	  ENDIF.
	  ILDB C,QOTSRC		;Get character in buffer
	  IFE. A		;If terminate on null
	    JUMPE C,ENDLP.	;Terminate on null
	  ENDIF.
	  MOVEI T,(C)		;Make a copy of it to hack
	  IDIVI T,^D32		;T := word to check, TT := bit to check
	  MOVNS TT
	  MOVX D,1B0		;D := bit to check
	  LSH D,(TT)
	  TDNE D,QOTMSK(T)	;Is it a special character?
	   TXO F,FM%QOT		;Yes, note
	  TDNN D,QT1MSK(T)	;Is it an wierd character?
	  IFSKP.
	    IDPB B,QOTTMP	;Yes, put in wierd character quote
	    SOS QOTCNT		;Count the quoting character
	  ENDIF.
	  IDPB C,QOTTMP		;Now copy character
	  SOS QOTCNT
	  LOOP.			;Count and continue
	ENDDO.
	MOVE A,[POINT 8,STRBUF]
	MOVX T,.CHDQT
	TXNE F,FM%QOT		;Need to do atomic quoting?
	 IDPB T,A		;Yes, insert it
	MOVE B,[POINT 7,STRBF1]
	MOVE D,QOTCNT		;Count of bytes in recipient string
	DO.
	  ILDB C,B		;Copy recipient string to command buffer
	  IDPB C,A
	  AOJL D,TOP.
	ENDDO.
	TXNE F,FM%QOT		;Need to do atomic quoting?
	 IDPB T,A		;Yes, insert it
	HRRZ T,A		;Last word written
	SUBI T,STRBUF-1		;Number of words written
	LSH T,2			;Number of bytes in those words
	LDB TT,[POINT 3,A,2]	;Number of padding bytes
	SUBI T,(TT)		;Number of bytes in string
	MOVE A,QOTDES
	MOVE B,[POINT 8,STRBUF]
	MOVN C,T
	CALL $SOUT		;Output buffer
	 RET
	RETSKP

	ENDSV.

;;;If any of these characters are seen, the entire string must be
;;;quoted within double quotes

	BRINI.			;Initialize break mask

	BRKCH. (.CHNUL,.CHTAB)	;CTRL/@ through CTRL/I
	BRKCH. (.CHVTB,.CHFFD)	;CTRL/K, CTRL/L
	BRKCH. (.CHCNN,.CHSPC)	;CTRL/N through space
	BRKCH. (050,051)	;"(", ")"
	BRKCH. (054)		;","
	BRKCH. (072,074)	;":", ";", "<"
	BRKCH. (076)		;">"
	BRKCH. (100)		;"@"
	BRKCH. (133)		;"["
	BRKCH. (135)		;"]"

QOTMSK:	EXP W0.,W1.,W2.,W3.	;Form table

;;;If any of these characters are seen, they must be quoted with backslash

	BRINI.			;Initialize break mask

	BRKCH. (.CHLFD)		;Line feed
	BRKCH. (.CHCRT)		;Carriage return
	BRKCH. (.CHDQT)		;"
	BRKCH. (134)		;"\"

QT1MSK:	EXP W0.,W1.,W2.,W3.	;Form table
;;; Send a line and get response
SMMESG:	MOVE A,NETJFN
	SETZ C,
	CALL $SOUT
	 RET
	HRROI B,CRLF0
	SETZ C,
	CALL $SOUTR		;Output buffer
	 RET
;;;	CALLRET SMRPLY		;Get a reply and return

;;; Get a reply, return text starting pointer in A, number in B
SMRPLY:	STKVAR <TXTPTR>
	DO.
	  TMOSET(^D300,TIMOUT)	;Wait 5 minutes before giving up
	  MOVE A,NETJFN
	  MOVE B,[POINT 7,STRBUF]
	  MOVEM B,TXTPTR
	  MOVX C,<5*STRBSZ>-1
	  MOVEI D,.CHLFD	;Terminate on line feed
	  SIN%			;Read a line
	  IFJER.
	    TMOCLR
	    RET
	  ENDIF.
	  TMOCLR		;No more interrupts...
	  LDB C,B		;Sniff at last byte of text
	  CAIN C,.CHLFD		;Ended in LF?  (should have)
	  IFSKP.
	    WARN <SMRPLY didn't get full text of SMTP reply>
	  ELSE.
	    MOVNI C,2		;Yes, back up over CRLF
	    ADJBP C,B		;C := backed over byte pointer
	    MOVE B,C		;Update copy in B for tie-off below
	    ILDB C,C		;Get expected CR
	    CAIN C,.CHCRT	;Was it?
	  ANSKP.
	    WARN <SMRPLY got an SMTP reply that ended with LF, not CRLF>
	    IBP B		;No, don't wipe the whatever it was out
	  ENDIF.
	  SETZ C,		;Make sure string is properly tied off
	  IDPB C,B
	  SKIPN DEBUGP		;Debugging SMTP replies?
	  IFSKP.
	    MOVEI A,STRBUF	;Print the whole buffer
	    CIETYP <  SMTP: %1W
>				;CRLF and text
	  ENDIF.
	  SETZ B,		;Accumulate number here
	  DO.
	    ILDB C,TXTPTR	;Get byte
	    CAIE C,177		;IAC?  (Some cretin sending TELNET protocol!)
	    IFSKP.
	      ILDB C,TXTPTR	;Sigh, get command byte
	      CAIL C,173	;WILL/WONT/DO/DONT?
	       ILDB C,TXTPTR
	      LOOP.		;Having ignored this IAC, try again
	    ENDIF.
	    CAIL C,"0"		;Is this character a digit?
	     CAILE C,"9"
	      EXIT.		;End of number
	    IMULI B,^D10	;Else add in the new digit
	    ADDI B,-"0"(C)
	    LOOP.		;Get another digit
	  ENDDO.
	  CAIE C,"-"		;Continuation line?
	   CAIGE B,^D100	;Some silly message we don't care about?
	    LOOP.		;Yes to either, get a new line
	ENDDO.
	MOVE A,TXTPTR
	RETSKP

	ENDSV.
	SUBTTL DECnet Routines
;
;	Try to connect and deliver a message to a remote DECnet host.
;	Deliver using SMTP (object #125) if possible.  If nobody answers,
;	try using Mail-11 (object #27) instead.  If this fails too,
;	we're out of luck (it's a tough life).
;
;	Entry:	A/ Name of ultimate destination host
;		B/ Name of DECnet host to connect to
;	Call:	CALL DCNSND
;	Return:	+1 -- Failure, error message printed using SMTJER
;		+2 -- Success, connection JFN in NETJFN

DCNSND:	STKVAR <DCNNAM,DSTHST,OBJIX>
	MOVEM A,DSTHST		;Save ultimate destination host
	MOVEM B,DCNNAM		;Save remote DECnet host name
	HRROI A,LCLNCN		;Storage for local name for this network
	SETO B,			;Output local host
	CALL $DECNS
	 FATAL (Can't get DECnet local host name)
	MOVE A,DCNNAM		;Immediate destination host
	MOVE B,DSTHST		;Ultimate destination host
	CALL GENHDR		;Generate headers
	MOVEI A,DCNTBL		;Set up pointer to object table
	MOVEM A,OBJIX
	DO.
	  HLRZ A,@OBJIX		;Get object spec
	  JUMPE A,ADEADH	;Mark host as dead if no more specs
	  MOVE B,DCNNAM		;Name of remote host
	  CALL DCNCON		;Try to connect
	  IFSKP.
	    HRRZ A,@OBJIX	;Call transport routine
	    MOVE B,DCNNAM	;Get remote name agatin
	    MOVE N,SAVEN	;N := starting recipient host
	    MOVEI O,HSTRCP(N)	;O := start of recipient list
	    CALL (A)		;Call the proper worker routine
	    CALL $CLOSF		;Close the connection
	    RETSKP		;Success return
	  ENDIF.
	  AOS OBJIX
	  LOOP.
	ENDDO.
	ENDSV.

DCNTBL:	[ASCIZ/-125/],,SMTSND
	[ASCIZ/-TASK-MX-LISTENER/],,SMTSND
	[ASCIZ/-27/],,VAXSND
	0
;	Connect to a DECnet host
;
;	Entry:	A/ Remote object name
;		B/ Remote host name
;	Call:	CALL DCNCON
;	Return:	+1 -- Failure, couldn't connect
;		+2 -- Success, connection JFN in NETJFN

DCNTIM==^D30000			;DECnet user time-out interval (msec)
DCNDTM==^D60000			;DECnet daemon time-out interval (msec)

DCNCON:	STKVAR <DCNNAM,DCNOBJ>
	MOVEM A,DCNOBJ		;Save DECnet object and
	MOVEM B,DCNNAM		;Save DECnet host name for later
	MOVE A,[POINT 7,STRBUF]	;a := ptr to net file name str
	MOVEI B,[ASCIZ/DCN:/]	;Build device spec
	CALL MOVSTR
	HRRO B,DCNNAM		;Pick up our remote host name again
	CALL OUTAHS		;Drop it in without the relative domain
	MOVE B,DCNOBJ		;Add DECnet object spec
	CALL MOVST0
	MOVX A,GJ%OLD!GJ%SHT	;Old, short form, name from string
	HRROI B,STRBUF
	GTJFN%			;Get a JFN for our connection
	 ERJMP R		;Failed, so fail-return
	MOVEM A,NETJFN		;Else, save our network JFN
	MOVX B,<FLD(^D8,OF%BSZ)!FLD(1,OF%MOD)!OF%RD!OF%WR>
	OPENF%			;Open the connection
	IFJER.
	  MOVE A,NETJFN		;Get our DECnet JFN back
	  RLJFN%		;Release it
	   JWARN
	  SETZM NETJFN
	  RET			;Return lossage
	ENDIF.
	MOVX B,DCNTIM		;Set timeout interval (assume user)
	SKIPE DAEMNP		;Are we the daemon?
	 MOVX B,DCNDTM		;Yes, so get different timeout interval
	MOVEM B,ICPTIM
	DO.
	  MOVE A,NETJFN
	  MOVX B,.MORLS		;Read link status
	  SETZ C,		;No addresses returned
	  MTOPR%		;Check our status
	  IFNJE.
	    JXN C,MO%CON,RSKP	;Exit if connected
	    TXNN C,MO%ABT	;Did the other end abort the connection?
	     SKIPE CTGCNT	;Or, did we see a ^G abort?
	  ANSKP.
	    MOVX A,^D100	;No, still looking for connect confirm
	    MOVNI B,(A)
	    ADDB B,ICPTIM	;Have we timed out?
	  ANDG. B
	    DISMS%		;No, wait another 100 msec
	    LOOP.		;Go check again
	  ENDIF.
	ENDDO.
	CALLRET $CLOSF		;Lossage, close connection

	ENDSV.
;;; Mail-11 DECnet Routines

;	Send the message to a Mail-11 listener.
;
;	Entry:	NETJFN/ connection JFN
;	Call:	CALL VAXSND
;	Return: +1 -- Always, via VAXJER if an error occurred

VAXSND:	STKVAR <SMTDOP,SMTHPT,DOMPTR,<HSTTMP,^D13>,<HSTLCL,^D13>>
	HRROI A,HSTLCL		;Make absolute copy of local name string
	HRROI B,LCLNCN
	CALL OUTAHS
	MOVE A,MSGDOP(M)	;Get message's delivery option
	MOVEM A,SMTDOP		;And save as a temporary here
	MOVE A,[POINT 7,STRBUF]	;We'll put the sender's name here
	SKIPN D,MSGRPT(M)	;Have a return path?
	IFSKP.
	  MOVEI B,.CHDQT	;Quote it
	  IDPB B,A
	  HRRO B,MSGRPT(M)	;Now output return path
	  SETZ C,		;Terminate on null
	  SOUT%
	  MOVEI B,.CHDQT	;And add an ending quote
	  IDPB B,A
	  SETZ B,
	  IDPB B,A
	ELSE.			;Return path not known, create one using sender
	  MOVE D,MSGSDR(M)	;D := addr of sender host entry block
	  HRRZ C,HSTRCP(D)	;C := adr of recipient entry block
	  HRRZ B,RCPBPT(C)	;B := ptr to sender name
	  CAIN B,MLAGNT		;Only do this if not mail agent
	  IFSKP.
	    HRRZ B,HSTHST(D)	;B := sender host pointer
	    CAIN B,LCLNAM	;Is it our host? (Local user)
	    IFSKP.
	      MOVEM B,SMTHPT	;No, add host and quote all of it
	      MOVEI B,.CHDQT	;Start with a quote
	      IDPB B,A
	      MOVE B,RCPBPT(C)	;B,C := sender name ptr/byte count
	      MOVN C,RCPCNT(C)	;C := neg byte count
	      SOUT%
	      MOVEI B,"@"	;Separate user/host with an atsign
	      IDPB B,A
	      HRRO B,SMTHPT	;Add host
	      SOUT%
	      MOVEI B,.CHDQT	;Finish with an ending quote
	      IDPB B,A
	      SETZ B,		;And a null, of course
	      IDPB B, A
	    ELSE.		;It's a local sender -- just name is sufficient
	      MOVE B,RCPBPT(C)	;B,C := sender name ptr/byte count
	      MOVN C,RCPCNT(C)	;C := neg byte count
	      SOUT%
	    ENDIF.		;End of local sender conditional
	  ENDIF.		;End of origin not mail agent conditional
	ENDIF.			;End of return-path output conditional
	HRROI B,STRBUF		;Send sender to the vax
	CALL VAXLIN
	 JRST VAXJER
	TXZ F,FM%VRC		;Initially no valid recipient seen
	DO.
	  CALL NXTRCP		;Get next recipient
	   EXIT.
	  CALL RSTRCP		;Reset error flags from other tries
	  MOVE A,[POINT 7,STRBUF]
	  CALL OUTRCP		;Output recipient name to STRBUF
	  SKIPN GTDBLK+.GTDRD	;Doing MX?
	  IFSKP.
	    MOVX B,"%"		;Yes, shove in relay poop
	    BOUT%		;Probably this should have been done better
	    HRRO B,FRNHST
	    CALL OUTAHS
	  ENDIF.
	  SETZ B,		;Mark EOS
	  IDPB B,A
	  HRROI A,STRBUF	;Get recepient
	  CALL UCASE		;And turn it to upper case
	  HRROI A,STRBUF	;Double colonize address
	  CALL VAXTRN
	  HRROI B,STRBUF	;Send receiver to the VAX
	  CALL VAXLIN
	   JRST VAXJER
	  CALL VAXVRF		;Valid recipient?
	  IFSKP.
	  ANDE. B		;Single losers make whole message fail
	  ELSE.
	    MOVX B,FR%TMP	;Whole message lost, mark as soft error
	    CALLRET STUMSG	;Update user errors
	  ENDIF.
	  TYPE <Recepient accepted> ;Yes, tell user
	  TXO F,FM%VRC		;Flag a valid recipient seen
	  LOOP.
	ENDDO.
	JXE F,FM%VRC,R		;Punt now if no valid recipients
	CITYPE < >		;Yes, indicate sending the message text
	CALL VAXNIL		;Mark end of recepient list
	 JRST VAXJER
	MOVEI A,[ASCIZ "TO"]
	CALL FNDHEA		;Find recepients
	 HRROI B,[ASCIZ ""]	;Null string in case of none
	CALL VAXLIN		;Send it
	 JRST VAXJER
	MOVEI A,[ASCIZ "SUBJECT"]
	CALL FNDHEA		;Find subject
	 HRROI B,[ASCIZ ""]	;In case of none
	CALL VAXLIN		;And send it
	 JRST VAXJER
	MOVE A,NETJFN		;Get output designator
	CALL VAXMSG		;Output message, checking for CRLFs
	 JRST VAXJER		;+1 Network error
	CALL VAXNIL		;Indicate end of message
	 JRST VAXJER

;;;Go through each recepient and verify that he/she really got the message
	MOVE N,SAVEN		;N := starting recipient host
	MOVEI O,HSTRCP(N)	;O := start of recipient list
	DO.			;DO for each recepient
	  CALL NXTRCP		;  Get next recipient
	  IFSKP.		;  IF got another?
	    JN FR%FAI!FR%TMP,RCPFLG(O),TOP. ;Leave alone if already failed
	    CALL VAXVRF		;    Verify this one
	     RET		;    Whole message lost
	    LOOP.		;    LOOP for each recepient
	  ENDIF.		;  ENDIF got another
	ENDDO.			;ENDDO for each recepient
	RET

	ENDSV.
;;; Transmogrify address to VMS double colon format (A/ address string)
;;; eg. a%b@c => c::b::a  a%b.dom@c => c::dom%b::a (using VMS Foreign Protocol)

VAXTRN:	TXC A,.LHALF		;Is str pnt LH -1?
	 TXCN A,.LHALF
	  HRLI A,(<POINT 7,>)	;Set up byte pointer
	MOVE T,A		;T := start of string
	SETZ TT,		;TT: = non-zero if quote seen
	PUSH P,A		;Push pnt of beg of string
	DO.			;Now find all %-routes
	  ILDB C,A
	  JUMPE C,ENDLP.	;End if null
	  CAIN C,.CHDQT		;Start/end of quoted material?
	   SETCA TT,		;Toggle quote flag
	  JUMPN TT,TOP.		;Don't check for %'s inside quoted text
	  CAIN C,"%"		;Is it percent kludge?
	   PUSH P,A	   	;Yes, push pointer
	  LOOP.			;Go for next char
	ENDDO.
	MOVE D,[POINT 7,TMPBUF]	;Temporary storage
	DO.			;Next change them into :: route
	  POP P,B		;Check what we've found
	  CAMN B,T		;Back to user part (beg of string)?
	   EXIT.		;Yes, don't process, just copy
	  PUSH P,B		;No, save pointer again
	  SETZ TT,		;Outside of quoted material
	  DO.			;Search for .pseudoDomain (*%*.x*)
	    ILDB C,B
	    JUMPE C,ENDLP.
	    CAIN C,.CHDQT	;Start/end of quoted material?
	     SETCA TT,		;Toggle quote flag
	    JUMPN TT,TOP.	;Don't check for %'s or .'s inside quoted text
	    CAIN C,"%"		;End on %
	     EXIT.
	    CAIE C,"."		;Found domain?
	     LOOP.		;No, check next char
	    DO.			;Yes, move it + % sign	
	      ILDB C,B
	      JUMPE C,ENDLP.
	      CAIN C,.CHDQT	;Start/end of quoted material?
	       SETCA TT,	;Toggle quote flag
	      IFE. TT		;Inside quoted text?
		CAIN C,"%"	;No, end on %
		 EXIT.
	      ENDIF.
	      IDPB C,D		;Copy char
	      LOOP.
	    ENDDO.
	    MOVEI C,"%"		;Add % sign (VMS Foreign Protocol)
	    IDPB C,D
	  ENDDO.
	  POP P,B		;Get string pointer again
	  SETZ TT,		;Outside quoted text again
	  DO.			;Now move host name (*%x.*)
	    ILDB C,B
	    JUMPE C,ENDLP.
	    CAIN C,.CHDQT	;Start/end of quoted material?
	     SETCA TT,		;Toggle quote flag
	    IFE. TT		;Inside quoted text?
	      CAIE C,"%"	;No, end on %
	       CAIN C,"."	;..or "."
		EXIT.
	    ENDIF.
	    IDPB C,D		;Move it
	    LOOP.
	  ENDDO.
	  MOVEI C,":"		;Append double colon
	  IDPB C,D
	  IDPB C,D
	  LOOP.
	ENDDO.
	SETZ TT,		;Clear quote flag
	DO.			;Move user part (x*)
	  ILDB C,B
	  JUMPE C,ENDLP.
	  CAIN C,.CHDQT		;Start/end of quoted material?
	   SETCA TT,		;Toggle quote flag
	  IFE. TT		;Inside quoted text?
	    CAIN C,"%"		;No, end on %
	     EXIT.
	  ENDIF.
	  IDPB C,D		;Move it
	  LOOP.
	ENDDO.
	SETZ C,			;Mark null
	IDPB C,D
	MOVE A,T		;Move string back again
	HRROI B,TMPBUF
	SETZ C,
	SOUT%
	RET
;;; Send a line in B to VAX but don't wait for response
VAXLIN:	MOVE A,NETJFN
	SETZ C,
	CALLRET $SOUTR

;;;JSYS error in MAIL-11 dialog
VAXJER:	CALLRET SMTJER

;;; Mark end of recepeint list by sending a NULL
VAXNIL:	MOVE A,NETJFN
	HRROI B,[0]
	MOVEI C,1
	SETZ D,
	CALLRET $SOUTR

;;; Verify a recepient by an acknowledge from the VAX.
;;; Returns +1 if whole message lost, +2 if message either succeded
;;; (with B/ 0) or only lost for this user (with B/ error flags)

VAXVRF:	TMOSET(^D120,TIMOUT)	;Wait 2 minutes before giving up
	SETZM STRBUF		;Clear STRBUF
	MOVE A,NETJFN		;Get network JFN
	HRROI B,STRBUF		;Set destination to STRBUF
	MOVX C,-4		;Want 4 bytes
	SINR%
	 ERJMP VAXJER		;Couldn't get it -- report total soft error
	HLRZ A,STRBUF		;What did the VAX say?
	SETZ B,			;Reset error flags in B
	CAIN A,4000		;Good acknowledgement?
	IFSKP.
	  HRROI B,STRBUF	;No, put error message in STRBUF
	  DO.
	    MOVE A,B		;Destination in A (STRBUF)
	    HRROI B,CRLF0	;Start it with a CRLF
	    SETZ C,		;(Including the NULL)
	    SOUT%
	    MOVE B,A		;Destination in B (STRBUF)
	    MOVE A,NETJFN	;What went wrong?
	    SINR%		;Go get it
	     ERJMP VAXJER	;Couldn't get it -- report total soft error
	    LDB D,B		;Got a null string (= end of error msg)?
	    CAIE D,.CHLFD	;Then, we're still pointing on the last LF
	     LOOP.		;Otherwise get next line
	  ENDDO.
	  MOVX D,-2		;Backup before last CRLF
	  ADJBP D,B
	  SETZ C,
	  IDPB C,D		;Smash last CR with NULL
	  HRROI A,STRBUF	;Point to the string
	  ETYPE <%1W>		;Type message for user
	  MOVX B,FR%ERM!FR%FAI	;Mark as hard error
	  CALL STEMSG		;Record error for user
	ENDIF.
	RETSKP
;	Find the value of a certain header
;
;	Entry:	A/ mem addrs of asciz header key string
;	Call:	CALL FNDHEA
;	Return: +1 for Failure
;		+2 for Success with B/ asciz pnt to header value string

FNDHEA:	HRLM A,HEATAB+1		;Save header key
	MOVE X,MSGNHD(M)	;Count,,byte-> to headers for this net
	HLRZ Y,X		;Put count in Y
	SUBI Y,2		;Subtrace first CRLF
	HRLI X,220700		;And fill LR of X with a byte-> to 3rd byte
FNDSB0:	CALL PARLIN		;Parse another line
	 RET			;End of file
	JXN F,FP%EOL,R		;Empty line?
	MOVEI A,HEATAB		;Point to header table
	TXNE F,FP%CLN		;Ended by a colon?
	 CALL PARKEY		;Yes, check if subject
	  JRST FNDSB0		;Either not colon or not subject -- try next
	MOVE B,PCLNBP		;Got one!
	IBP B			;Skip colon
	CALL CPYHEA		;Copy the header
	RETSKP

HEATAB:	-1,,.+1
	0,,[RETSKP]
;	Copy a header value into STRBUF
;
;	Entry:	B -- Byte pointer to header value
;	Call:	CALL CPYHEA
;	Return:	+1 with B/ byte pnt asciz string in STRBUF
;
CPYHEA:	MOVE A,[POINT 7,STRBUF]
	DO.
	  ILDB C,B		;Copy a byte
	  IDPB C,A
	  CAIE C,.CHCRT		;Found CR?
	   LOOP.		;No, move next
	  SETZ C,		;Mark possible EOS
	  DPB C,A
	  ILDB C,B		;1st char on next line
	  CAIN C,.CHLFD		;(Skip LF)
	   ILDB C,B		;(Get real 1st char)
	  CAIE C,.CHTAB		;Tab?  Then continue
	   CAIN C," "		;Space?  Also continue
	  IFSKP. <EXIT.>	;Neither, done
	  IDPB C,A		;Copy this byte
	  LOOP.
	ENDDO.
	MOVE B,[POINT 7,STRBUF] ;Done copying, exit with B byte-> STRBUF
	RET
	
;	Turn a string into upper case
;
;       Entry:	A/ Pnt to asciz string
;	Call:	CALL UCASE
;	Return: +1 always with string changed to uc and updated byte pnt in a

UCASE:	SAVEAC <B>
	TXC A,.LHALF		;Is str pnt LH -1?
	 TXCN A,.LHALF
	  HRLI A,(<POINT 7,>)	;Set up byte pointer
	DO.
	  ILDB B,A		;Get next char
	  JUMPE B,R		;Return if done
	  CAIL B,"a"		;Turn into UC if >= "a" and <= "z"
	   CAILE B,"z"
	    CAIA
	     SUBI B,"a"-"A"
	  DPB B,A		;Put char back again
	  LOOP.
	ENDDO.
;;; Output only message headers to JFN in A
;;; Returns: +1, transmission error
;;; 	     +2, successful

VAXHEA:	STKVAR <OUTMSD,BUFPTR>
	MOVEM A,OUTMSD		;Save designator
;;;	MOVEI A,^D256		;Transmit 256 bytes at a time
	MOVEI A,^D199		;VMAIL can't handle more than 199 bytes, sigh!
	MOVEM A,SEGSIZ		;Set segment size
	SKIPN A,MSGTMT(M)	;Overall delivery timeout in effect?
	IFSKP.
	  TIME%			;Yes, compute time limit for this copy
	  ADD A,TMCINT
	  CAMLE A,MSGTMT(M)	;Beyond total delivery timeout?
	   MOVE A,MSGTMT(M)	;Yes, use that
	ENDIF.
	MOVEM A,MSGTMC(M)	;Record copy timeout
	MOVE A,OUTMSD		;Restore designator
	MOVE B,MSGNHD(M)	;Headers we generated
	HLRZ D,B		;Length
	HRLI B,(<POINT 7,0>)	;Build byte pointer to message
	SUBI D,2		;Skip over the CRLF at the start
	IBP B
	IBP B
	IFN. D			;Message non-empty with count in D
	  DO.			;Do 256-bytes at a time with CRLF checking
	    TMOCLR		;Disallow timer interrupts
	    MOVEM B,BUFPTR	;Save pointer to start of buffer
	    SETZB C,TT		;Character count zero, no doubled dot
	    DO.			;Search for "<CRLF>" sequence within buffer
	      CAMLE C,SEGSIZ	;Buffer filled?
	       EXIT.		;Yes, output it
	      ILDB T,B		;Get byte from buffer
	      ADDI C,1		;Count this character
	      CAIE T,.CHCRT	;Is it a CR?
	       LOOP.		;No, continue scan
	      ILDB T,B		;Saw CR, get possible LF
	      ADDI C,1		;Count this character
	      CAIE T,.CHLFD	;Have we gotten a <CRLF>?
	       LOOP.		;No, continue scan
	    ENDDO.		;End scan through message for <CRLF>.
	    MOVE B,BUFPTR	;Get back pointer to start of buffer
	    SUBI D,(C)		;Account for this many characters output
	    MOVNS C		;Negative byte count for SOUT%
	    ADDI C,2		;Don't send CRLF
	    CALL OUTMST		;Check copy timer
	     JRST OUTMSF	;Timed out
	    IFE. C		;A null line?
	      HRROI B,[ASCIZ ""] ;Yes, send a NULL terminated null string
	      CALL $SOUTR
	       JRST OUTMSF
	      MOVE B,BUFPTR	;Then restore text pointer
	    ELSE.
	      CALL $SOUTR	;No, output the string as usual
	       JRST OUTMSF
	    ENDIF.
	    ILDB T,B		;Skip CRLF we didn't send
	    ILDB T,B
	    JUMPG D,TOP.	;Continue output if more bytes to go
	  ENDDO.
	ENDIF.
	AOS (P)			;Set success (+2)
	TMOCLR			;Disallow timer interrupts now
	RET

	ENDSV.
;;; Output whole text of message and headers to JFN in A with CRLF checking
;;; Returns: +1, transmission error
;;; 	     +2, successful

VAXMSG:	STKVAR <BUFPTR>
	CALL VAXHEA		;Output headers
	 RET			;+1 Transmission error
	MOVEI B,^D256		;Transmit 256 bytes at a time
	MOVEM B,SEGSIZ		;Set segment size
	MOVE B,MSGTXT(M)	;Get pointer to message text
	MOVE D,MSGTCN(M)	;Get text count
	DO.			;Do 256-bytes at a time with CRLF checking
	  JUMPLE D,OUTMDN	;Quit if no more bytes to do
	  TMOCLR		;Disallow timer interrupts
	  MOVEM B,BUFPTR	;Save pointer to start of buffer
	  SETZ C,		;Character count zero
	  DO.			;Search for "<CRLF>" sequence within buffer
	    CAMLE C,SEGSIZ	;Buffer filled?
	     EXIT.		;Yes, output it
	    ILDB T,B		;Get byte from buffer
	    ADDI C,1		;Count this character
	    CAIE T,.CHCRT	;Is it a CR?
	     LOOP.		;No, continue scan
	    ILDB T,B		;Saw CR, get possible LF
	    ADDI C,1		;Count this character
	    CAIE T,.CHLFD	;Have we gotten a <CRLF>?
	     LOOP.		;No, continue scan
	  ENDDO.		;End scan through message for <CRLF>
	  MOVE B,BUFPTR		;Get back pointer to start of buffer
	  SUBI D,(C)		;Account for this many characters output
	  MOVNS C		;Negative byte count for SOUT%
	  ADDI C,2		;Don't send <CRLF> itself
	  CALL OUTMST		;Check copy timer
	   JRST OUTMSF		;Timed out
	  IFE. C		;A null line?
	    HRROI B,[ASCIZ ""]	;Yes, send a NULL terminated null string
	    CALL $SOUTR
	     JRST OUTMSF
	    MOVE B,BUFPTR	;Then restore text pointer
	  ELSE.
	    CALL $SOUTR		;No, output the string as usual
	     JRST OUTMSF
	  ENDIF.
	  ILDB T,B		;Skip CRLF we didn't send
	  ILDB T,B
	  LOOP.
	ENDDO.

	ENDSV.
	SUBTTL Chaosnet routines

;;; Chaos specific symbols, etc

;Timeouts
CHATIM==^D7000			;User time-out
CHADTM==^D20000			;Daemon time-out

;Connection states
;IFNDEF .CSCLS,<.CSCLS==0>	;Closed
;IFNDEF .CSLSN,<.CSLSN==1>	;Listening
;IFNDEF .CSRFC,<.CSRFC==2>	;RFC received
 IFNDEF .CSRFS,<.CSRFS==3>	;RFC sent
 IFNDEF .CSOPN,<.CSOPN==4>	;Opened
;IFNDEF .CSLOS,<.CSLOS==5>	;LOS-ing
 IFNDEF .CSINC,<.CSINC==6>	;Incomplete transmission (no response to SNS)

IFNDEF .MOPKR,<.MOPKR==27>	;MTOPR% code to read a packet

;Packet description
$CPKOP==<POINT 8,Z,7>		;Opcode
$CPKNB==<POINT 12,Z,31>		;Number of bytes
CHPKDT==4			;First word of data
CHPMXC==^D488			;Maximum number of characters of data

;Packet opcodes
;IFNDEF .CORFC,<.CORFC==1>	;Request for connect
;IFNDEF .COOPN,<.COOPN==2>	;Open
 IFNDEF .COCLS,<.COCLS==3>	;Close
;IFNDEF .COFWD,<.COFWD==4>	;Forward
;IFNDEF .COANS,<.COANS==5>	;Answer
;IFNDEF .COSNS,<.COSNS==6>	;Sense status
;IFNDEF .COSTS,<.COSTS==7>	;Report status
;IFNDEF .CORUT,<.CORUT==10>	;Routing info (not used)
 IFNDEF .COLOS,<.COLOS==11>	;You are losing
;IFNDEF .COLSN,<.COLSN==12>	;Listen (never used)
;IFNDEF .COMNT,<.COMNT==13>	;Maintenance
;IFNDEF .COEOF,<.COEOF==14>	;EOF connection stream
;IFNDEF .COMAX,<.COMAX==15>	;Maximum opcode+1
;IFNDEF .CODAT,<.CODAT==200>	;Random data opcode


;;; Send message in M to Chaosnet host in E

; B/	Host name to connect to
; C/	Host number to use

CHASND:	STKVAR <HSTPTR,DSTHPT>
	MOVEM A,DSTHPT		;Save ultimate host
	MOVEM B,HSTPTR		;Save host pointer
	HRROI A,LCLNCN		;Local name for this network
	SETO B,			;Output local host
	CALL $CHSNS
	 FATAL (Can't get Chaosnet local host name)
	MOVE A,HSTPTR		;Get immediate destination
	MOVE B,DSTHPT		;Get ultimate destination
	CALL GENHDR		;Generate headers
	SETZM NETJFN		;No MAIL connection yet
	DO.
	  CALL NXTRCP		;Get next recipient
	   EXIT.		;No, done with recipients
	  CALL RSTRCP		;Reset error flags from other tries
	  SKIPN MSGDOP(M)	;Want some kind of send?
	  IFSKP.		;Guess so...
	    MOVE C,HSTPTR	;Need name back
	    PUSH P,NETJFN	;Save jfn we're using for MAIL
	    CALL CHSEND		;Try a chaos SEND
	    IFSKP.		;Did it win?
	      POP P,NETJFN	;This MUST happen on all paths through here!!
	      MOVE B,MSGDOP(M)	;Yup, it won, see what we were doing
	      CAIE B,D%SAML	;Want mail even when send won?
	       LOOP.		;Nope, done with this recipient
	    ELSE.		;Send lost
	      POP P,NETJFN	;This MUST happen on all paths through here!!
	      MOVE B,MSGDOP(M)	;See what we were doing
	      CAIN B,D%SEND	;Send only?
	       LOOP.		;Yup, really lost, next recipient
	    ENDIF.		;Going on to do MAIL if we get here
	  ENDIF.		;Or here
	  CALL RSTRCP		;Reset error flags again
	  SETZM TMPBUF		;Clear reply string buffer
	  SKIPE A,NETJFN	;Net mail jfn
	  IFSKP.		;Don't have one yet
	    MOVE A,[POINT 7,STRBUF]	;Construct contact name
	    MOVEI B,[ASCIZ/CHA:/]	;Chaos
	    CALL MOVSTR
	    MOVE B,HSTPTR	;Host name
	    CALL OUTAHQ		;Add it, in absolute form
	    MOVEI B,[ASCIZ/.MAIL/]	;Contact name is MAIL
	    CALL MOVST0		;Tack it on, end with null
	    HRROI B,STRBUF	;Point at filename
	    SETZ C,		;No third arg for OPENF%
	    CALL CHAOPN		;Go open the connection
	     CALLRET $CLOSF	;Couldn't, host is dead, out of here
	    MOVE A,NETJFN	;Get jfn we just opened
	  ENDIF.		;Have a net jfn in A
	  CALL CHARCP		;Output this name
	  TYPE <(MAIL) >	;Say we are trying MAIL
	  MOVEI B,<200+.CHCRT>	;Newline
	  BOUT%
	  IFNJE.
	    MOVEI B,.MOSND
	    MTOPR%
	  ..TAGF (ERJMP,)	;I sure wish ANNJE. existed!
	    CALL CHAREP		;Get reply
	  ANSKP.
	    CAIN D,"+"		;Address ok?
	     LOOP.		;Yes, flag as such
	    CAIN D,"%"		;Temporary error?
	  ANSKP.
	    CALL CHAECP		;No, hard error, copy error string
	    MOVX B,FR%FAI!FR%ERM ;Record failure
	    CALL STEMSG
	    LOOP.		;Try next recipient
	  ELSE.
	    CALL CHAECP		;Set up error string
	    MOVX B,FR%TMP!FR%ERM
	    CALL STEMSG		;Set error information
	    LOOP.
	  ENDIF.
	ENDDO.
	CITYPE < >		;Indicate sending message text
	SETZM TMPBUF		;Clear network reply buffer
	SKIPN A,NETJFN		;Are we doing mail at all?
	 RETSKP			;No, bye
	MOVE C,MSGNHD(M)
	HLRZ D,C
	HRLI C,(<POINT 7,0>)
	CALL CHOSTR		;Dump out headers
	IFSKP.
	  DMOVE C,MSGTXT(M)	;Okay, now the message
	  CALL CHOSTR
	ANSKP.
	  MOVEI B,.MOEOF
	  MTOPR%
	..TAGF (ERJMP,)		;I sure wish ANNJE. existed!
	  CALL CHAREP		;Get reply
	ANSKP.
	  CAIE D,"+"		;Ok?
	ANSKP.
	ELSE.
	  CALL CHAECP		;Yes, copy error string
	  MOVX B,FR%TMP!FR%ERM	;Save error info for dequeue
	  CALL STUMSG		;Update user errors
	ENDIF.
	CALL $CLOSF		;Close it - take care of data error
	RETSKP

	ENDSV.

;Open a chaos connection, returns +1 on failure, +2 on success
;NETJFN might be open even if connection didn't, so you can get the error msg.

;B/ Filespec for connection
;C/ Zero or contact name word for OPENF%

CHAOPN:	MOVX A,GJ%SHT		;Generic
	GTJFN%			;B already points to filespec
	 ERJMP R		;Failed completely, host dead or something
	MOVEM A,NETJFN		;Save the jfn
	MOVEI A,CHATIM		;Set timer
	SKIPE DAEMNP
	 MOVEI A,CHADTM
	MOVEM A,ICPTIM
	SETZM CTGCNT
	MOVE A,NETJFN		;Open 8-bit, mode 6 (don't wait for OPN)
	MOVX B,<<FLD ^D8,OF%BSZ>!<FLD 6,OF%MOD>!OF%RD!OF%WR>
	OPENF%			;There may be a contact name in C
	IFJER.			;Lost completely
	  MOVE A,NETJFN
	  RLJFN%
	   JWARN
	  SETZM NETJFN		;Be paranoid
	  RET			;It's dead, give up
	ENDIF.
	DO.			;Wait for the OPN
	  MOVE A,NETJFN
	  GDSTS%		;Get connection status
	   ERJMP R		;Give up
	  ANDI B,17		;Just the state bits
	  CAIN B,.CSOPN		;OPN ?
	   RETSKP		;Yup, we won
	  CAIN B,.CSRFS		;RFS ?
	   SKIPE CTGCNT		;User requested abort?
	    EXIT.		;Out of here
	  MOVX A,-^D100		;Still RFS and no abort, wait a while
	  ADDB A,ICPTIM		;Count off time to wait
	  JUMPLE A,ENDLP.	;Timeout, B has state
	  MOVX A,^D100
	  DISMS%		;Time left, dally on it
	  LOOP.			;Go try again
	ENDDO.			;We've lost if we get here
	CAIE B,.CSINC		;Not responding?
	 CAIN B,.CSRFS		;or timeout on RFS?
	  CALL ADEADH		;If either, mark as dead
	RET			;Return failure


; Do a chaos SEND, return +1 on failure, +2 on sucess

;C/ Host name

CHSEND:	MOVE A,[POINT 7,TMPBUF+1000] ;Build filename for connection
	MOVEI B,[ASCIZ/CHA:/]	;Chaos
	CALL MOVSTR
	MOVE B,C		;Host name
	CALL OUTAHQ		;Add it, in absolute form
	MOVEI B,[ASCIZ/./]	;No contact name yet, easier to do in OPENF%
	CALL MOVST0		;Tack it on with a null
	MOVE A,[POINT 8,TMPBUF]	;Cons up RFC packet
	MOVEI B,[ASCIZ/SEND /]	;Contact name
	CALL MOVSTR
	CALL CHARCP		;The recipient
	TYPE <(SEND) >		;Log that we are sending
	IFXN. F,FM%RLY		;Are we relaying?
	  MOVEI B," "		;Yes, add space
	  IDPB B,A
	  SKIPN D,MSGSDR(M)	;and the sender
	   FATAL <No sender block set up>
	  HRRZ C,HSTRCP(D)	;Get pointer to sender's recipient entry block
	  MOVE B,RCPBPT(C)	;Point to sender user name
	  SKIPN C,RCPCNT(C)	;Have a recipient?
	    HRROI B,[ASCIZ/Unknown user/] ;No, make pretty name
	  SOUT%			;Write it
	  MOVEI B,"@"		;Add atsign
	  IDPB B,A
	  HRRO B,HSTHST(D)	;Now get name for host
	  CALL OUTAHS		;Add host name
	ENDIF.
	MOVEI C,-TMPBUF+1(A)	;Find length
	IMULI C,4
	LSH A,-41
	SUB C,A
	CAILE C,CHPMXC
	 MOVEI C,CHPMXC
	HRLI C,TMPBUF
	MOVSS C			;C/ length,,buffer (contact name)
	HRROI B,TMPBUF+1000	;B/ filespec (no contact name)
	CALL CHAOPN		;Open the connection
	IFSKP.			;Won, user available
	  MOVE A,NETJFN		;Output reply-parsable header:user<sp>date<nl>
	  SKIPN D,MSGSDR(M)	;d := adr of sender host entry block
	   FATAL <No sender block set up>
	  HRRZ C,HSTRCP(D)	;Get pointer to recipient entry block
	  MOVE B,RCPBPT(C)	;Point to sender user name
	  SKIPN C,RCPCNT(C)	;Have a recipient?
	   HRROI B,[ASCIZ/Unknown user/] ;No, make pretty name
	  SOUT%			;Write it
	  IFNJE.
	    MOVEI B,"@"		;Add atsign
	    BOUT%
	  ..TAGF (ERJMP,)	;ANNJE.
	    HRRO B,HSTHST(D)	;Now get name for host
	    CALL OUTAHS		;Add host name
	    MOVEI B,.CHSPC	;Space
	    BOUT%
	  ..TAGF (ERJMP,)	;ANNJE.
	    SETO B,		;Current time
	    MOVX C,OT%NSC!OT%12H!OT%SCL
	    ODTIM%
	  ..TAGF (ERJMP,)	;ANNJE.
	    MOVE C,MSGNHD(M)	;Dump out headers (start with a newline)
	    HLRZ D,C
	    HRLI C,(<POINT 7,0>)
	    CALL CHOSTR
	  ANSKP.
	    DMOVE C,MSGTXT(M)	;And now the message
 	    CALL CHOSTR
	  ANSKP.
	    MOVEI B,.MOEOF	;Send EOF
	    MTOPR%
	  ..TAGF (ERJMP,)	;ANNJE.
	    MOVEI B,.MONOP	;Wait til it is ack'd
	    MTOPR%
	  ..TAGF (ERJMP,)	;ANNJE.
	    TXO A,CO%WCL
	    CLOSF%
	  ..TAGF (ERJMP,)	;ANNJE.
	    TYPE <OK>
	    SETZM NETJFN	;Be paranoid
	    RETSKP		;Won, return success
	  ENDIF.
	  ;here if jsys error sending message, could get the emsg but most
	  ;likely it's just 'data error' or something equally uninformative
	  MOVE TT,[POINT 7,[ASCIZ/SEND connection not completed/]]
	ELSE.			;Here if couldn't even open a connection
	  MOVE TT,[POINT 7,[ASCIZ/Couldn't get a SEND connection to host/]]
	  SKIPN NETJFN
	ANSKP.
	  DO.
	    MOVE A,NETJFN
	    GDSTS%
	     ERJMP ENDLP.
	    JXE C,.RHALF,ENDLP. ;No more packets, punt
	    MOVEI B,.MOPKR	;Else get a packet
	    MOVEI C,TMPBUF
	    MTOPR%
	     ERJMP ENDLP.
	    LDB C,[$CPKOP+TMPBUF]
	    CAIE C,.COLOS	;LOS packet?
	     CAIN C,.COCLS	;CLS packet?
	      IFSKP. <LOOP.>	;Neither, get another one
	    LDB C,[$CPKNB+TMPBUF]
	    IFG. C		;Ok, have a reply
	      MOVE TT,[POINT 8,TMPBUF+CHPKDT]
	      ADJBP C,TT	;Tie it off
	      SETZ A,
	      IDPB A,C
	    ENDIF.
	  ENDDO.
	ENDIF.
	ETYPE <failed - %7W>
	CALL SERMRK		;Mark the error
	CALLRET $CLOSF		;Done
;;Output recipient name for chaos with quoting, sigh.  Apparently Unix servers
;;can't handle "user%host", they want "user"%host....  Everybody else seems to
;;be able to handle either, so we do it the Unix way.
CHARCP:	MOVE A,[POINT 8,STRBUF]
	DMOVE B,RCPBPT(O)	;Recipient
	ADJBP C,B		;C=end pointer
	CALL QOTSTR		;Output the user name string
	 FATAL (Impossible QUOSTR failure in CHARCP)
	MOVE A,B		;Foo, QOTSTR preserves A...
	IFXN. F,FM%RLY
	  MOVEI C,"@"		;Use @ to decrease chance of servers choking on
	  IDPB C,A		;quotes.  Ok since no other @ follows.
	  MOVE C,A		;Save pointer
	  HRRZ B,HSTHST(N)	;Add host name
	  CALL MOVST0
	  EXCH A,C		;Flush the domain if any
	  CALL GETDOM
	   MOVE B,C
	  SETO A,
	  ADJBP A,B
	ENDIF.
	MOVEI D,-STRBUF+1(A)	;Find length
	IMULI D,4
	LSH A,-41
	SUB D,A
	CITYPE <  >
	MOVX A,.PRIOU
	MOVE B,[POINT 8,STRBUF]
	MOVN C,D
	SKIPE PRINTP
	 SOUT%
	TYPE <: >
	MOVE A,NETJFN
	MOVE B,[POINT 8,STRBUF]
	MOVN C,D
	SOUT%
	 ERJMP .+1
	RET

;;Find (pseudo)domain in host name if any.  If successful, A has domain block
;;and B pointer to the domain name.
GETDOM:	STKVAR <DOMPTR>
	TXCE A,.LHALF
	 TXCN A,.LHALF
	  HRLI A,(POINT 7,)
	SETZM DOMPTR
	DO.
	  ILDB B,A
	  CAIN B,"."
	   MOVEM A,DOMPTR
	  JUMPN B,TOP.
	ENDDO.
	MOVE A,DOMTBL
	SKIPN B,DOMPTR
	 RET
	PUSH P,C
	TBLUK%
	POP P,C
	JXE B,TL%EXM,R		;Oops, not really a domain
	MOVE B,DOMPTR
	RETSKP

	ENDSV.
;; Get chaos reply into TMPBUF, with timeout
;;  A/ output JFN
;; On successful return, D has reply code

CHAREP:	DO.
	  TMOSET(^D60,ENDLP.)	;Don't hang
	  SETZM TMPBUF		;Init empty buffer
	  MOVE B,[POINT 8,TMPBUF]
	  MOVX C,4000
	  MOVX D,<200!.CHCRT>
	  SIN%			;Read response line
	   ERJMP ENDLP.
	  TMOCLR
	  SETZ D,
	  DPB D,B		;Replace newline with null
	  MOVE A,[POINT 8,TMPBUF] ;Pointer to message (including status since
	  ETYPE <%1W>		; Unix doesn't send any text with status)
	  LDB D,[POINT 8,TMPBUF,7] ;Return status byte
	  RETSKP
	ENDDO.
	TMOCLR			;No more timeout
	SETZM TMPBUF		;Flush any partial reply
	RET
;; Here to copy error string to STRBUF with ending crlf
;; b = ptr to string source
CHAECP:	DMOVE A,[POINT 7,STRBUF	;a := output buffer
		 POINT 8,TMPBUF] ;Error reply from network?
	SKIPN TMPBUF
	 MOVE B,[POINT 7,[ASCIZ/Chaosnet error/]]  ;No
	CALLRET MOVST2

;;;Output string to Chaosnet, non-skip if failure
;;; A/ destination JFN
;;; C/ pointer
;;; D/ byte count
;;;This routine will never win an award for efficiency.

CHOSTR:	DO.
	  SOJL D,RSKP
	  ILDB B,C		;Get next char
	  CAIN B,.CHLFD		;Lfs don't go
	   LOOP.
	  CAIL B,.CHBSP
	   CAILE B,.CHCRT
	    CAIA
	     TXO B,200
	  BOUT%
	   ERJMP R		;Failed: give error return
	  LOOP.
	ENDDO.
	SUBTTL Pup routines

PUPTIM==^D12000			;Ethernet user time-out (msec)
PUPDTM==^D20000			;Ethernet Daemon time-out (msec)
PUPSTM==^D60000			;Ethernet Send reply time-out (msec)

; Packet level input/output
	OPDEF PUPI% [JSYS 441]
	OPDEF PUPO% [JSYS 442]

; Flags for PUPI%/PUPO%
PU%CHK==:1B1			;Compute/check checksum
PU%TIM==:1B4			;No input timeout in MS in AC3

; Packet structure definitions (from PUPSYM)
MNPLEN==:^D22			;Minimum Pup Length in bytes
MXPLEN==:^D554			;Maximum Pup Length in bytes
MXPBLN==:<MXPLEN+3>/4		;Maximum size of PB, in words
DEFSTR PUPLEN,TMPBUF,15,16	;Pup Length
DEFSTR PUPTYP,TMPBUF,31,8	;Pup Type
PBCONT==5			;Word data starts at

; Marks for mail transport
YESMRK==3			;Yes
NOMRK==4			;No
EOCMRK==6			;End of command
HEREFL==5			;Here is the file
STMAIL==20			;Store mail
MBXEXC==23			;Mailbox exception

; OF%MOD file open modes
.PUORW==16			;Open port in raw packet mode

; MTOPR% functions
.MORMK==23			;Read the most recently received mark
.MOSAB==25			;Generate abort and close connection
.MORAB==26			;Read abort code and string (abort state only)

; BSP port states
P%RFCO==1			;RFC out
P%OPEN==3			;Open
P%ABRT==7			;Abort
; B/	Name to connect to
; C/	Address to use

PUPSND:	STKVAR <PUPNAM,PUPADR,DSTHPT>
	MOVEM A,DSTHPT		;Save ultimate host pointer
	MOVEM P,SAVEP		;Save the starting P
	MOVEM B,PUPNAM		;Save pointer
	MOVEM C,PUPADR		;Save address
	HRROI A,LCLNCN		;Local name for this network
	SETO B,			;Output local host
	CALL $PUPNS
	 FATAL (Can't get Pup local host name)
	MOVE A,PUPNAM		;Get immediate destination
	MOVE B,DSTHPT		;Get ultimate destination
	CALL GENHDR		;Generate headers
	SKIPN MSGDOP(M)		;Want to send message?
	IFSKP.
	  MOVE A,[POINT 7,STRBUF] ;a := ptr to net file name str
	  MOVEI B,[ASCIZ/PUP:!J./] ;Output device and local host part
	  CALL MOVSTR
	  MOVE B,PUPNAM		;Host name
	  CALL OUTAHQ		;Add it, in absolute form
	  MOVEI B,[ASCIZ/+Misc-Services/] ;Misc-Services well-known socket
	  CALL MOVST0		;Finish up the string as ASCIZ
	  MOVX A,GJ%OLD!GJ%SHT	;Old, short form, name from string
	  HRROI B,STRBUF
	  GTJFN%		;Get a JFN for the port
	   ERJMP ADEADH		;Fail
	  MOVEM A,NETJFN	;Save JFN
	  MOVX B,FLD(8,OF%BSZ)!FLD(.PUORW,OF%MOD)!OF%RD!OF%WR
	  OPENF%		;Open in raw packet mode
	  IFJER.
	    MOVE A,NETJFN	;Release output JFN
	    RLJFN%
	     JWARN
	    SETZM NETJFN
	    CALLRET ADEADH	;Fail
	  ENDIF.
	  ;; Set up recipient blocks for loop
	  MOVE N,SAVEN		;n := starting recipient host
	  MOVEI O,HSTRCP(N)	;o := start of recipient list
	  CALL NXTRCP		;Next recipient
	  IFNSK.
	    CALL $CLOSF
	    RETSKP		;No recipients???
	  ENDIF.
	  DO.
	    CALL RSTRCP		;Reset error flags from other tries
	    SETZM TMPBUF	;Clear start of buffer
	    MOVE A,[TMPBUF,,TMPBUF+1]
	    BLT A,TMPBUF+MXPBLN-1 ;Clear it out for the length of a packet
	    MOVX A,300		;Get packet type for ether send
	    STOR A,PUPTYP	;Save it
	    MOVE A,[POINT 8,PBCONT+TMPBUF] ;Get dest ptr
	    CALL PUPSDR		;Say who this send is from
	    MOVEI B,":"		;Colon
	    IDPB B,A		;Drop it in
	    CALL OUTRCP		;Copy string for net recipient
	    SKIPN GTDBLK+.GTDRD	;Doing MX?
	    IFSKP.
	      MOVX B,"%"	;Yes, shove in relay poop
	      BOUT%		;Probably this should have been done better
	      HRRO B,FRNHST
	      CALL OUTAHS
	    ENDIF.
	    MOVEI B,":"		;Colon
	    IDPB B,A		;Drop it in
	    CALL OUTMSG		;Add message text
	     FATAL <Unexpected +1 return from OUTMSG>
	    MOVEI B,(A)		;Compute address of last word
	    SUBI B,TMPBUF-1	;Compute # 36-bit words used
	    LSH B,2		;Convert to bytes
	    LSH A,-^D33		;Get bytes not used in last word
	    SUBI B,(A)		;Compute Pup length
	    ADDI B,2		;Include checksum
	    STOR B,PUPLEN	;Save length
	    HRRZ A,NETJFN	;Get JFN back
	    TXO A,PU%CHK	;Compute checksum
	    MOVE B,[MXPBLN,,TMPBUF] ;Max length, from buffer
	    PUPO%		;Send it out
	    IFJER.
	      CALL $CLOSF	;Close output JFN
	      CALLRET ADEADH	;Random lossage
	    ENDIF.
	    HRRZ A,NETJFN	;Get JFN again
	    TXO A,PU%CHK!PU%TIM	;Checksum, with timeout
	    MOVX C,PUPSTM	;Waiting for up to a minute
	    PUPI%		;Read it back in
	    IFJER.
	      CALL $CLOSF	;Close JFN
	      CALLRET ADEADH	;Random lossage
	    ENDIF.
	    LOAD A,PUPTYP	;Get type
	    CAIN A,301		;Success?
	    IFSKP.
	      LOAD B,PUPLEN	;Get length of Pup
	      SUBI B,MNPLEN	;Minus minimum number is length of error string
	      IFE. B		;If we have nothing
		HRROI B,[ASCIZ/Unknown network error/] ;Make up a string
	      ELSE.
		MOVE B,[POINT 8,PBCONT+TMPBUF] ;Get pointer to error
		ADJBP A,B	;Point to end of error message
		SETZ C,		;Get a null
		IDPB C,A	;Drop it in at end of string
	      ENDIF.
	      HRROI A,STRBUF	;Into string buffer
	      SETZ C,		;Ending on null
	      SOUT%		;Copy reason for failure
	      MOVX B,FR%FAI!FR%ERM ;Permanent failure with text message
	      CALL STEMSG	;Remember lossage for recipient
	    ENDIF.
	    CALL NXTRCP		;Find another recipient
	     EXIT.		;No more
	    LOOP.		;Do next
	  ENDDO.
	  CALL $CLOSF		;Flush the JFN
	  MOVE A,MSGDOP(M)	;Get back delivery options
	  CAIE A,D%SAML		;Send and mail?
	   RETSKP		;No, done sending
	  MOVE N,SAVEN		;n := starting recipient host
	  MOVEI O,HSTRCP(N)	;o := start of recipient list
	ENDIF.
	MOVE A,[POINT 7,STRBUF]	;a := ptr to net file name str
	MOVEI B,[ASCIZ/PUP:!J./] ;Output device and local host part
	CALL MOVSTR
	HLRZ B,PUPADR		;b := dest subnet #
	MOVX C,^D8		;Octal output
	NOUT%
	 ERJMP R
	MOVEI B,[ASCIZ/#/]	;Add a #
	CALL MOVSTR
	HRRZ B,PUPADR		;b := dest host #
	NOUT%
	 ERJMP R
	MOVEI B,[ASCIZ/#/]	;Add another #
	CALL MOVSTR
	MOVEI B,[ASCIZ/0+Mail/] ;And finish with the "mail" socket
	CALL MOVST0		;(ASCIZ)
	MOVX A,GJ%OLD!GJ%SHT	;Old, short form, name from string
	HRROI B,STRBUF
	GTJFN%			;Get a JFN for the port
	 ERJMP ADEADH		;Fail
	MOVEM A,NETJFN		;Ok, save JFN
	MOVX B,<<FLD ^D8,OF%BSZ>!<FLD 1,OF%MOD>!OF%RD!OF%WR>
	OPENF%			;Initiate rendezvous
	IFJER.
	  MOVE A,NETJFN		;a := output JFN
	  RLJFN%		;Release it
	   JWARN
	  SETZM NETJFN
	  CALLRET ADEADH
	ENDIF.
	MOVEI A,PUPTIM		;Set time-out count (user/daemon)
	SKIPE DAEMNP
	 MOVEI A,PUPDTM
	MOVEM A,ICPTIM
	DO.
	  MOVE A,NETJFN		;a := net JFN
	  SETZ C,		;No addresses returned
	  GDSTS%
	  IFNJE.
	    ANDI B,17		;Isolate port state in b
	    CAIN B,P%OPEN	;State = OPN ?
	     EXIT.		;Yes, have connection
	    CAIN B,P%RFCO	;State = RFC out ?
	     SKIPE CTGCNT	;Yes, ^G abort?
	  ANSKP.
	    MOVX A,^D100	;No, RFC pending, a := 100 msec
	    MOVNI B,(A)		;Time-out expired?
	    ADDB B,ICPTIM
	  ANDG. B
	    DISMS%		;No, wait 100 msec
	    LOOP.
	  ENDIF.
	  CALL $CLOSF		;Close it
	  CALLRET ADEADH	;Add to dead host list
	ENDDO.
	SETZM CTGCNT		;Clear ^G abort flag
	MOVE A,NETJFN		;a := transmit JFN
	MOVX B,.MOEOF		;b := "mark" MTOPR% fct
	MOVX C,STMAIL		;Start property list transfer
	MTOPR%
	 ERJMP PUPJER		;Just in case
	TXO F,FP%BKA		;Show sender property not sent
	DO.
	  CALL NXTRCP		;Get the next recipient
	   EXIT.		;No more
	  CALL RSTRCP		;Reset error flags from other tries
	  MOVE A,[POINT 7,STRBUF] ;a := place for temp string
	  MOVEI B,[ASCIZ/((/]	;Start property punctuation
	  CALL MOVSTR
	  TXZN F,FP%BKA		;Sender property already sent?
	  IFSKP.
	    MOVEI B,[ASCIZ/End-of-Line-Convention CRLF)(Sender /]
	    CALL MOVSTR
	    CALL PUPSDR		;Output string for sender
	    MOVEI B,[ASCIZ/)(/]	;Finish this property entry and start another
	    CALL MOVSTR
	  ENDIF.
	  MOVEI B,[ASCIZ/Mailbox /] ;Start mailbox property entry
	  CALL MOVSTR
	  CALL OUTRCP		;Output this recipient's name
	  SKIPN GTDBLK+.GTDRD	;Doing MX?
	  IFSKP.
	    MOVX B,"%"		;Yes, shove in relay poop
	    BOUT%		;Probably this should have been done better
	    HRRO B,FRNHST
	    CALL OUTAHS
	  ENDIF.
	  MOVEI B,[ASCIZ/))/]	;End this property entry
	  CALL MOVST0
	  HRRZ A,NETJFN		;a := output JFN
	  HRROI B,STRBUF	;b := string just built
	  SETZ C,
	  SOUT%			;Send it off
	   ERJMP PUPJER
	  LOOP.			;Do all the recipients
	ENDDO.
	MOVE A,NETJFN		;a := transmit JFN
	MOVX B,.MOEOF		;b := "mark" MTOPR% fct
	MOVX C,EOCMRK		;End our transmission
	MTOPR%
	 ERJMP PUPJER		;Just in case
	CALL RPLYP		;Get the remote reply
	IFSKP.
	  MOVE A,NETJFN		;a := transmit JFN
	  MOVX B,.MOEOF		;b := "mark" MTOPR% fct
	  MOVX C,HEREFL		;Good, so here comes the mail file...
	  MTOPR%
	   ERJMP PUPJER		;Just in case
	  CALL OUTMSG		;Output the mail text
	   JRST PUPJER		;+1, error, close up shop
	  MOVE A,NETJFN		;a := transmit JFN
	  MOVX B,.MOEOF		;b := "mark" MTOPR% fct
	  MOVX C,YESMRK		;End our transmission
	  MTOPR%
	   ERJMP PUPJER		;Just in case
	  SETZB B,C		;Yes code
	  BOUT%
	   ERJMP PUPJER
	  HRROI B,[ASCIZ/End of mail text./]
	  SOUT%
	   ERJMP PUPJER
	  MOVX B,.MOEOF		;b := "mark" MTOPR% fct
	  MOVX C,EOCMRK		;End our transmission
	  MTOPR%
	   ERJMP PUPJER		;Just in case
	  CALL RPLYP		;Get the remote response
	ANSKP.
	  CALL $CLOSF		;Close it - take care of data error
	  HRROI A,STRBUF	;Print reply text
	  CIETYP < %1W>
	  HRRZS B		;b := starting mark
	  CAIN B,YESMRK		;Mail OK?
	  IFSKP.
	    MOVX B,FR%TMP!FR%ERM ;Treat as temp, save error text
	    CALL STUMSG		;Update user errors
	  ENDIF.
	ELSE.
	  CALL PUPBRT		;Server barfed, abort connection
	ENDIF.
	RETSKP			;Return success

	ENDSV.
;;;Say who this is from
PUPSDR:	SKIPN D,MSGSDR(M)	;d := adr of sender host entry block
	 FATAL <No sender block set up>
	HRRZ C,HSTRCP(D)	;c := adr of sender "recipient" entry block
	MOVE B,RCPBPT(C)	;b,c := sender name ptr/-byte count
	MOVN C,RCPCNT(C)
	SOUT%
	PUSH P,A		;Save destination
	HRRO A,HSTHST(D)	;Pointer to sender host
	CALL $PUPSN		;Recognized to Pup world?
	IFSKP.
	  POP P,A		;Restore destination BP
	  MOVEI B,"@"		;Success, punctuate
	  IDPB B,A
	  HRRO B,HSTHST(D)	;Output name in absolute form
	  CALLRET OUTAHS	;That's all for this sender
	ENDIF.
	POP P,A			;Restore destination BP
	MOVE B,HSTHST(D)	;Get host pointer
	CAIN B,LCLNAM		;If local name, don't need extra path
	IFSKP.
	  MOVEI B,"%"		;Use kludgy routing to make sure destination
	  IDPB B,A		; doesn't choke on unknown sender host
	  HRRO B,HSTHST(D)	;b := local host
	  SOUT%			;Output it in relative form
	ENDIF.			;Fall out to addition of local name

	;; Sender not given, on local host, or routed with "%".
	;; Add at-sign and Pup name for local host.
	MOVEI B,"@"		;Punctuate
	IDPB B,A
	HRROI B,LCLNCN		;Output absolute local host name
	CALLRET OUTAHS		;Return after adding host name
;;;JSYS error while sending mail
PUPJER:	CALL NETJER		;Get JSYS error string
	JRST PUPBRT		;Abort connection

;;;JSYS error in a subroutine
PUPJEX:	TMOCLR			;This may be needed
	CALL NETJER		;Get last JSYS error
	MOVE P,SAVEP		;Reset the stack
	JRST PUPBRT

;;;Error in a subroutine, text of error in B
PUPERX:	TMOCLR			;This may be needed
	MOVE A,[POINT 7,STRBUF]
	CALL MOVST0		;Create error string
PUPERY:	MOVE A,[POINT 7,STRBUF]	;Here when STRBUF set up
	CIETYP <  %1W
>				;CRLF and text
	MOVX B,FR%TMP!FR%ERM	;Save error info for dequeue
	CALL STUMSG		;Update user errors
	MOVE P,SAVEP		;Reset the stack
;	JRST PUPBRT

;;;Here to abort connection
PUPBRT:	HRRZ A,NETJFN		;a := output JFN
	MOVEI B,.MOSAB		;Abort function
	SETZ C,			;No code assigned
	HRROI D,[ASCIZ/Mail transfer aborted/]  ;Abort text
	MTOPR%			;Abort the connection
	 ERJMP .+1		;Just in case
	CALLRET $CLOSF		;Close the connection
; Routine to handle remote replies
; Entry:   Remote response expected
; Call:    CALL RPLYP
; Return: +1 if hard failure blocking us from continuing
;	  +2 if all ok to proceed

RPLYP:	STKVAR <RPLMRK,RPLREP>
	DO.
	  CALL RSPPUP		;Wait for his reply
	  IFNSK.
	    MOVEM B,RPLMRK	;Error reply, save end mark,,start mark
	    MOVEM C,RPLREP	;And the reply code
	    HRRZ A,RPLMRK	;Get start mark
	    CAIE A,NOMRK	;"No" mark?
	    IFSKP.
	      HRROI A,STRBUF	;Output error string
	      CIETYP < %1W>
	      MOVX B,FR%TMP!FR%ERM ;Assume temporary problem
	      CAIE C,41		;Bad "mailbox" property syntax?
	       CAIN C,42	;Or "sender" property syntax?
		MOVX B,FR%FAI!FR%ERM ;Yes, permanent error
	      CAIE C,40		;All mailboxes bad?
	       CAIN C,110	;Permanent file system problem?
		MOVX B,FR%FAI!FR%ERM ;Yes, permanent error
	      CALLRET STUMSG	;Update user msgs
	    ENDIF.
	    CAIE A,-1		;"Timeout mark"?
	    IFSKP.
	      HRROI A,STRBUF	;Yes, output error string
	      CIETYP < %1W>
	      MOVX B,FR%TMP!FR%ERM ;Assume temporary problem
	      CALLRET STUMSG	;Update user msgs
	    ENDIF.
	    CAIN A,MBXEXC	;"Mailbox exception" mark?
	    IFSKP.
	      HRROI A,STRBUF	;No, some strange lossage
	      CIETYP < %1W>
	      MOVX B,FR%FAI!FR%ERM ;Permanent error
	      CALLRET STUMSG	;Update user msgs
	    ENDIF.
	    MOVE A,[POINT 7,STRBUF] ;a := ptr into reply string
	    SETZ B,		;b := start of "index" code
	    DO.
	      ILDB D,A		;d := char
	      CAIL D,"0"	;Digit?
	       CAILE D,"9"
		EXIT.		;No, analyze what we have
	      IMULI B,^D10	;Form decimal value
	      ADDI B,-"0"(D)
	      LOOP.
	    ENDDO.
	    CIETYP <   %1W>	;Type msg for user
	    MOVE N,SAVEN	;n := starting recipient host
	    MOVEI O,HSTRCP(N)	;o := start of recipient list
	    IFLE. B
	      HRROI A,[ASCIZ/Server bug: Impossible mailbox exception index/]
	      CIETYP < %1W>
	      MOVX B,FR%FAI!FR%ERM ;Assume temporary problem
	      CALLRET STUMSG
	    ENDIF.
	    DO.
	      CALL NXTRCP	;No, get the next one
	      IFNSK.
		HRROI A,[ASCIZ/Server bug: Mailbox exception index out of range/]
		CIETYP < %1W>
		MOVX B,FR%FAI!FR%ERM ;Assume temporary problem
		CALLRET STUMSG
	      ENDIF.
	      SOJG B,TOP.	;Index down to our man
	    ENDDO.
	    MOVX B,FR%TMP!FR%ERM ;Assume temporary failure
	    SKIPN C,RPLREP	;c := reply code
	    IFSKP.
	      CAIE C,3		;No, transient error?
	       MOVX B,FR%FAI!FR%ERM ;No, assume permanent error
	    ENDIF.
	    CALL STEMSG		;Install the error flags and message
	  ENDIF.
	  HLRZ A,B		;a := ending mark type
	  CAIE A,EOCMRK		;EOC?
	   LOOP.		;No, get the rest
	ENDDO.
	RETSKP

	ENDSV.
; Routine to wait for a response from the Ethernet
; Entry:   connection opened
; Call:    CALL RSPPUP
; Return:  +1, negative reply or timeout
;	   +2, positive reply
;  b = end mark,,start mark, c = reply code, strbuf = text
;  If the expected mark/code/text sequence is violated, a mark type of
;  0 is returned.  The terminating mark is left set.

RSPPUP:	STKVAR <MRKTYP,MRKCOD>
	SETZM STRBUF		;Clear reply text
	TMOSET(^D120,PUPTMO)	;Max 2 mins for a reply
	CALL RCVCH		;Better have a mark now...
	 CALL CLMARK		;OK, clear the mark
	  JSP B,RSPPER		;No mark, sequence error
	MOVEM B,MRKTYP		;Save the starting mark
	CALL RCVCH		;Now read the code value
	 JSP B,RSPPER		;Mark - sequence error
	MOVEM B,MRKCOD		;Save the code
	HRROI B,STRBUF		;b := ptr to receive the text
	MOVX C,<5*STRBSZ>-1	;c := max byte count
	SETZ D,			;Or terminate on null
	SIN%
	 ERJMP .+1
	IFE. C
	  MOVEI B,[ASCIZ/Pup too long/]
	  JRST PUPERX
	ENDIF.
	CALL RCVCH0		;Check the termination
	 TRNA			;Mark ends the text
	  JSP B,RSPPER		;No mark, fail
	HRLM B,MRKTYP		;Save it
	TMOCLR			;No more time out
	CAIE B,EOCMRK		;Last one EOC?
	IFSKP.
	  CALL CLMARK		;Yes, clear the last mark
	   JSP B,RSPPER		;None, bomb out
	  CAIE B,EOCMRK		;Got one, better be EOC
	   JSP B,RSPPER		;No, bomb out
	ENDIF.
	MOVE C,MRKCOD		;c := reply code
	MOVE B,MRKTYP		;b := end mark,,start mark
	HRRZ A,B		;a := start mark
	CALL PUPDBG		;Print text if debugging
	CAIE A,YESMRK		;Yes mark?
	 RET			;No, fail return
	RETSKP			;Success return

	ENDSV.
; Here when time-out on reply wait.  Returns error msg in STRBUF and
; dummy ending marks.
PUPTMO:	DMOVE A,[POINT 7,STRBUF
		 [ASCIZ/Connection timed-out/]]
	CALL MOVST0		;Set up an error string
	TMOCLR			;No more time out
	SETOB B,C		;Set timeout code in return AC's
	CALLRET PUPDBG		;Print text if debugging and return

; Here on random Pup protocol error
;	JSP B,RSPPER

RSPPER:	STKVAR <RSPEPC>
	MOVEM B,RSPEPC		;Save error PC
	DMOVE A,[POINT 7,STRBUF
		 [ASCIZ/Pup protocol error, PC=/]]
	CALL MOVSTR		;Set up an error string
	HRRZ B,RSPEPC		;Retrieve PC
	MOVX C,^D8		;Octal output
	NOUT%			;Put PC in error reply
	 JFATAL
	TMOCLR			;No more time out
	SETZB B,C		;Response error, clear return ac's
;	CALLRET PUPDBG		;Print text if debugging and return

; Routine to print Ethernet reply text in debug mode
; Entry:   strbuf = adr of reply text
;	   b = end mark,,start mark
;	   c = reply code
; Call:    CALL PUPDBG
; Return:  +1 always, prints only if DEBUGP non-zero
PUPDBG:	SKIPN DEBUGP		;Debugging network protocol?
	 RET			;No
	SAVEAC <A,B,D>
	HRROI A,STRBUF		;a := reply text
	HLRZ D,B		;d := end mark
	HRRZS B			;b := start mark
	CETYPE <  PUP: [%2O] %3O %1W [%4O]> ;CRLF and text
	RET
; Fetch a character from the remote host.
; Entry:   NETJFN = receive JFN
; Call:    CALL RCVCH
; Return:  +1, mark encountered.  b = mark type
;	   +2, b = char received

RCVCH:	HRRZ A,NETJFN		;a := receive JFN
	BIN%			;b := next input char
	IFNJE.
	  CAIE B,.CHNUL		;Null byte?
	   RETSKP		;No, got a char - return +2
	ENDIF.
RCVCH0:	CALL CHKMRK		;Check for mark state
	IFSKP.
	  MOVEI B,.MORMK	;Read mark type
	  MTOPR%
	   ERJMP PUPJEX		;Can't do much with this
	  MOVE B,C		;b := mark type
	  RET			;Return +1
	ENDIF.
	ANDI B,17		;Isolate port state
	CAIE B,P%ABRT		;Abort?
	IFSKP.
	  MOVEI B,.MORAB	;Yes, get the abort reason
	  HRROI D,STRBUF
	  MTOPR%
	   ERJMP PUPJEX		;Just in case
	  JRST PUPERY		;And close things out
	ENDIF.
	MOVX B,.CHNUL		;Just null char -- return it
	RETSKP
; Routine to clear a mark state
; Entry:   NETJFN = receive JFN
; Call:    CALL CLMARK
; Return:  +1, no mark set
;	   +2, mark cleared, b = type
CLMARK:	CALL CHKMRK		;Check for mark state
	 RET			;None
	TXZ B,1B4		;Mark present, clear it
	SDSTS%			;A Mark, clear it
	MOVEI B,.MORMK		;Read mark type
	MTOPR%
	 ERJMP PUPJEX		;Just in case
	MOVE B,C		;b := mark type
	RETSKP			;Return +2

; Routine to check for mark input state
; Entry:   NETJFN = receive JFN
; Call:    CALL CHKMRK
; Return:  +1, no mark
;	   +2, mark present, b = status
CHKMRK:	MOVE A,NETJFN		;a := receive JFN
	SETZ C,
	GDSTS%			;Check state of connection
	IFXN. B,1B5		;EOF?
	  MOVEI B,[ASCIZ/Pup connection EOF/]
	  CALLRET PUPERX	;Abort and close the connection
	ENDIF.
	TXNN B,1B4		;Mark?
	 RET
	RETSKP			;Yes, skip return
	SUBTTL Special routines

;;; Send message in M to Special host in E

; B/	Host name to connect to
; C/	Host number to use

SPCSND:	STKVAR <SPCPTR,SPCADR,<SPCLCL,^D13>,SPCHPT,DSTHPT>
	MOVEM A,DSTHPT		;Save ultimate host pointer
	MOVEM B,SPCPTR		;Save host pointer
	MOVEM C,SPCADR		;And address
	HRROI A,LCLNCN		;Local name for this network
	SETO B,			;Output local host
	CALL $SPCNS
	 FATAL (Can't get Special local host name)
	HRROI A,SPCLCL		;Make absolute copy of local name string
	HRROI B,LCLNCN
	CALL OUTAHS
	MOVE A,SPCPTR		;Get immediate destination
	MOVE B,DSTHPT		;Get ultimate destination host pointer
	CALL GENHDR		;Generate headers
	HRROI A,STRBUF		;Output directory name
	MOVE B,SPCADR		;From Special host (a.k.a. directory) number
	DIRST%
	 ERJMP ADEADH		;Failed
	MOVEI B,[ASCIZ/-MAIL./]	;Filename of outgoing mail
	CALL MOVSTR
	PUSH P,A		;Save string poiter
	GTAD%			;Get system date/time
	MOVE B,A		;Output it in octal
	POP P,A
	MOVX C,^D8
	NOUT%
	 JFATAL
	AOS B,NXTSEQ		;Get next unique number
	MOVNS B			;With hyphen...output it too
	NOUT%
	 JFATAL
	HRROI B,[ASCIZ/.-1;P777700/] ;Next generation, protection 777700
	CALL MOVST0
	MOVX A,GJ%SHT		;Get a JFN on it...
	HRROI B,STRBUF
	GTJFN%
	 ERJMP ADEADH		;Failed completely
	MOVEM A,NETJFN
	MOVX B,<<FLD ^D7,OF%BSZ>!OF%WR>
	OPENF%
	IFJER.
	  MOVE A,NETJFN
	  RLJFN%
	   JWARN
	  CALLRET ADEADH
	ENDIF.
	SKIPN MSGRPT(M)		;Have a return path?
	IFSKP.
	  MOVEI B,"@"		;Yes, must prepend local host as part
	  BOUT%			; of source route.  Output an at
	  HRROI B,SPCLCL	;Local host name
	  SETZ C,
	  SOUT%
	  MOVE B,MSGRPT(M)	;Make pointer to return path
	  HRLI B,(<POINT 7,>)
	  ILDB B,B		;Get first character of return path
	  CAIE B,"@"		;Additional source routing specification seen?
	   SKIPA B,[":"]	;No, use colon to terminate source routing
	    MOVEI B,","		;Else must use comma for continuation
	  BOUT%			;Output the character
	  MOVE B,MSGRPT(M)	;Now output return path
	  HRLI B,(<POINT 7,>)
	  SOUT%
	ELSE.
	  HRROI A,STRBUF	;Output to recipient buffer
	  MOVE D,MSGSDR(M)	;D := addr of sender host entry block
	  HRRZ C,HSTRCP(D)	;C := adr of recipient entry block
	  MOVE B,RCPBPT(C)	;B,C := sender name ptr/-byte count
	  MOVN C,RCPCNT(C)
	  SOUT%
	  HRRZ B,HSTHST(D)	;B := sender host pointer
	  CAIN B,LCLNAM		;Is it our host?
	   MOVEI B,SPCLCL	;Yes, use canonical form
	  MOVEM B,SPCHPT	;Save host pointer
	  CAIN B,SPCLCL		;Is it me?
	  IFSKP.
	    MOVEI B,"%"		;Punctuate
	    IDPB B,A
	    MOVEI B,SPCLCL	;Set up local name
	    EXCH B,SPCHPT	;Restore host
	    HRROS B
	    SOUT%
	  ENDIF.
	  MOVE C,A		;Save termination
	  MOVE A,NETJFN		;Restore JFN
	  MOVE B,[POINT 7,STRBUF]
	  CALL QOTSTR		;Output it quoted
	   FATAL (Special net QOTSTR failed)
	  MOVEI B,"@"		;Punctuate
	  BOUT%
	  HRRO B,SPCHPT		;Restore host
	  SOUT%			;Output host name
	ENDIF.
	HRROI B,CRLF0		;Now start recipient list
	SOUT%			;Delimiting with first CRLF
	DO.
	  CALL NXTRCP		;Get next recipient
	   EXIT.		;No, done with recipients
	  CALL RSTRCP		;Reset error flags from other tries
	  SETZM TMPBUF		;Clear reply string buffer
	  MOVE A,NETJFN		;Get back JFN
	  CALL OUTRCP		;Output recipient
	  SKIPN GTDBLK+.GTDRD	;Doing MX?
	  IFSKP.
	    MOVX B,"%"		;Yes, shove in relay poop
	    BOUT%		;Probably this should have been done better
	    HRRO B,FRNHST
	    CALL OUTAHS
	  ENDIF.
	  HRROI B,CRLF0		;Newline
	  SETZ C,
	  SOUT%
	  LOOP.
	ENDDO.
	MOVX B,.CHFFD		;End of recipients
	BOUT%
	HRRO B,MSGNHD(M)	;Pointer to headers
	HLRZ C,MSGNHD(M)	;Size of headers
	MOVNS C
	SOUT%			;Output headers
	MOVE B,MSGTXT(M)	;Pointer/size of message body
	MOVN C,MSGTCN(M)
	SOUT%			;Output message body
	CLOSF%			;Close queue file
	 JWARN <Error closing Special queue file>
	RETSKP

	ENDSV.
	SUBTTL JSYS jacket routines

; Routine to close a net connection.  If the connection has a data
; error, a second CLOSF% is done to abort the JFN.
; Entry:   NETJFN/ net JFN
; Call:    CALL $CLOSF
; Return:  +1 always
$CLOSF:	SAVEAC <A,B>		;Preserve these guys
	STKVAR <CLZJFN>		;JFN to close
	SKIPN A,NETJFN		;Have JFN?
	 RET			;No, just return
	MOVEM A,CLZJFN		;Save the JFN to close
	SETZM NETJFN		;And clear the cell
	GTSTS%			;Get its status
	 ERJMP .+1		;Ignore error
	JXE B,GS%NAM,R		;This shouldn't happen, but check anyway
	IFXE. B,GS%OPN		;JFN open?
	  RLJFN%		;This is easy - just flush the JFN
	   JWARN <Error releasing network JFN> ;Lost??
	  RET
	ENDIF.
	DO.
	  TMOSET(^D60,ENDLP.)	;Prevent hanging
	  CLOSF%
	  IFNJE.
	    TMOCLR		;Succeeded, clear timer and return
	    RET
	  ENDIF.
	ENDDO.
	TMOCLR
	MOVE A,CLZJFN		;Try again
	TXO A,CZ%ABT		;Abort it without waiting for anything
	CLOSF%
	 JWARN <Error closing net connection>
	RET

	ENDSV.
; Versions of BOUT%, SOUT%, and SOUTR% which output to primary output if
;DEBUGP is set, to allow protocol debugging.

$BOUT:	SKIPE DEBUGP		;If debugging, output to primary output too
	 CALL DBGBOU
	JSP CX,$TIMER		;Put a timer on this if necessary
	BOUT%
	 ERJMP R
	RETSKP

$SOUT:	SKIPE DEBUGP		;If debugging, output to primary output too
	 CALL DBGSOU
	JSP CX,$TIMER		;Put a timer on this if necessary
	SOUT%
	 ERJMP R
	RETSKP

$SOUTR:	SKIPE DEBUGP		;If debugging, output to primary output too
	 CALL DBGSOU
	JSP CX,$TIMER		;Put a timer on this if necessary
	SOUTR%
	 ERJMP R
	RETSKP

$TIMER:	SKIPGE INTOK		;Is there a timer set up already?
	 JRST (CX)		;Yes, use it then
	TMOSET(MAXTMB,TIMOUT)	;Wait 5 minutes before giving up
	CALL (CX)		;Do the code
	 TRNA			;+1 Return
	  AOS (P)		;+2 Return
	TMOCLR			;Clear the timer
	RET			;Return +1/+2

TIMOUT:	TMOCLR			;Clear timeout
	SAVEAC <A,B>
	MOVX A,.FHSLF		;Set last error
	MOVX B,TTMSX1		;"Unable to send within timeout interval"
	SETER%
	 ERJMP .+1
	RET

DBGBOU:	SAVEAC <A>
	MOVX A,.PRIOU
	BOUT%
	RET

DBGSOU:	SAVEAC <A,B,C,D>
	MOVX A,.PRIOU
	SOUT%
	RET
	SUBTTL General-purpose subroutines

;;;Move a string from B to A
MOVSTR:	HRLI B,(<POINT 7,0>)
MOVST1::DO.
	  ILDB D,B
	  IFN. D
	    IDPB D,A
	    LOOP.
	  ENDIF.
	ENDDO.
	RET

;;;Move string and terminating null
MOVST0:	HRLI B,(<POINT 7,0>)
MOVST2:	SAVEAC <D>
	DO.
	  ILDB D,B
	  IDPB D,A
	  JUMPN D,TOP.
	ENDDO.
	RET

;;; Make a copy of string in A, return address in B, count in C
CPYSTR::PUSH P,A		;Save address
	HRLI A,(<POINT 7,0>)
	SETZ C,
	DO.
	  ILDB D,A
	  JUMPE D,ENDLP.
	  AOJA C,TOP.
	ENDDO.
	MOVEI A,5(C)		;Account for null and round wd cnt up
	IDIVI A,5
	CALL ALCBLK
	 FATAL <Memory exhausted>
	HRL B,(P)
	HRRZM B,(P)
	ADDI A,(B)
	BLT B,-1(A)
	POP P,B
	RET
	SUBTTL Interrupt stuff

;;;Here to initialize the timer, called via JSP CX,SETTIM.  Note that A,B,C
;;;are clobbered!

SETTIM:	MOVE A,[.FHSLF,,.TIMEL]	;Tick the timer
	MOVX B,<TMRTCK*^D1000>	;Every TMRTCK seconds
	SETZ C,			;On channel 0
	TIMER%
	 ERJMP .+1
	JRST (CX)

;;;Here on timer interrupt
TIMINT:	MOVEM 17,INTACS+17	;Save ACs
	MOVEI 17,INTACS
	BLT 17,INTACS+16
	AOSE TIMKIL		;If we weren't asked to kill the clock
	 JSP CX,SETTIM		;Reinitialize the timer
	AOSE INTOK		;Should time out now?
	IFSKP.
	  SKIPN A,TIMLOC	;Get time-out routine
	   FATAL <No time-out PC set>
	  MOVEM A,INTPC		;Set it
	  MOVE P,TIMRTP		;Reset stack ptr
	ENDIF.
	MOVSI 17,INTACS		;Restore ACs
	BLT 17,17
	DEBRK%

;;; Here on ^G interrupt
CTGINT:	AOS CTGCNT
	DEBRK%
	SUBTTL IPCF handling

;Here to initialize for IPCF - we want to be known as [SYSTEM]MMAILR

IPCINI:	SKIPE IPCFON		;Has IPCF been set up yet?
	 RET			;Yes, don't do it again
	SETZM IPCNT		;Zero count of MSEND%s we've done
	SETZM PIDGET+.IPCFS	;Indicate we want a fresh PID
	DO.
	  MOVE A,IPCNT		;Get the count
	  CAIG A,5		;Too many?
	  IFSKP.
	    WARN <Unable to send to <SYSTEM>INFO>
	    RET
	  ENDIF.
	  SETZ A,		;Assume we have a PID
	  SKIPN PIDGET+.IPCFS	;Do we?
	   MOVX A,IP%CPD	;No
	  MOVEM A,PIDGET+.IPCFL
	  SETZM PIDGET+.IPCFR	;Send to INFO
	  MOVEI A,.IPCFP+1	;Length of packet
	  MOVEI B,PIDGET	;Packet address
	  MSEND%
	  IFJER.
	    AOS B,IPCNT		;Failed!
	    TXNN B,1		;Warn only every other try
	     JWARN <Trying to send to INFO...>
	    SETZM PIDGET+.IPCFS	;Clear possible bad PID
	    MOVEI A,^D1000	;Wait a while for things to settle
	    DISMS%
	    LOOP.
	  ENDIF.
	  AOS IPCNT		;Increment count
	  DO.
	    SETZB C+.IPCFL,C+.IPCFS ;No flags, any sender
	    MOVE C+.IPCFR,PIDGET+.IPCFS ;Get our PID
	    MOVE C+.IPCFP,[IPCFBL,,IPCFBF] ;Where to read into
	    MOVEI A,.IPCFP-.IPCFL+1 ;Get response from <SYSTEM>INFO
	    MOVEI B,C
	    MRECV%
	    IFJER.
	      JWARN <MRECV% from <SYSTEM>INFO failed>
	      RET
	    ENDIF.
	    LOAD D,IP%CFC,C+.IPCFL
	    CAIE D,.IPCCC	;From SYSTEM?
	     CAIN D,.IPCCF	;Or INFO?
	      CAIA
	       LOOP.		;No, toss it
	  ENDDO.
	  TXNE C+.IPCFL,IP%CFM	;Delivered?
	   LOOP.		;No, try again
	ENDDO.
	IFXN. C+.IPCFL,IP%CFE	;See if any errors
	  WARN <Error in message from <SYSTEM>INFO>
	  RET
	ENDIF.
	SETZM IPCFOK		;Disable IPCF interrupts
	SETZM NOSLEP		;And sleeps
	MOVEI A,.FHSLF		;Enable the channel
	MOVX B,1B<IPCHAN>
	AIC%
	MOVEI C,.MUPIC		;Enable for IPCF interrupts
	MOVE D,PIDGET+.IPCFS	;For our new PID
	MOVEI E,IPCHAN		;On this channel
	MOVEI A,E-C+1		;Length of arg block
	MOVEI B,C		;Location
	MUTIL%
	 JFATAL <Could not enable IPCF interrupts>
	SETOM IPCFON		;Note IPCF set up
	RET
; Here when an IPCF packet is received
; Note that since we only get interrupted when the queue goes from empty
; to non-empty, we must ensure that the queue is empty before dismissing
; the interrupt!  No JWARNs may be done here as we may be in a UUO when this
; happens

IPCINT:	MOVEM 17,INTACS+17	;Save ACs
	MOVEI 17,INTACS
	BLT 17,INTACS+16
	DO.
	  JSP C,IPCHEK		;Check the queue
	   EXIT.		;Done, depart
	  MOVE A,IPCFBF+.IPCFL+1 ;Check flags
	  IFXN. A,IP%CFV	;Page request?
	    MOVX A,IP%CFB!IP%CFV ;Don't block and read a page
	    MOVEM A,IPCFBF+.IPCFL
	    SETZM IPCFBF+.IPCFS	;Any sender
	    MOVE A,PIDGET+.IPCFS ;Set up our PID
	    MOVEM A,IPCFBF+.IPCFR
	    MOVE A,[1000,,IPCPAG/1000] ;Read a page worth
	    MOVEM A,IPCFBF+.IPCFP
	    MOVX A,.IPCFP+1	;Read the data
	    MOVEI B,IPCFBF
	    MRECV%
	     ERJMP .+1		;MRECV% to read data page failed
	    LOOP.
	  ENDIF.
	  MOVX A,IP%CFB!IP%TTL	;Don't block and truncate
	  MOVEM A,IPCFMS+.IPCFL
	  SETZM IPCFMS+.IPCFS	;Any sender
	  MOVE A,PIDGET+.IPCFS	;Set up our PID
	  MOVEM A,IPCFMS+.IPCFR
	  MOVX A,.IPCFP+1	;Now read the emssaage
	  MOVEI B,IPCFMS
	  MRECV%
	   ERJMP TOP.		;MRECV% to read IPCF message failed?
	  MOVE A,IPCFBF+.IPCI0	;Get word 0 of user's request
	  CAME A,[SIXBIT/PICKUP/] ;Wakeup and reply?
	  IFSKP.
	    MOVX A,IP%CFO	;Yes, allow us to exceed send quota
	    MOVEM A,IPCFMS+.IPCFL
	    MOVE A,PIDGET+.IPCFS ;Get our PID
	    EXCH A,IPCFMS+.IPCFS ;From us
	    MOVEM A,IPCFMS+.IPCFR ;To him
	    SKIPL IPCFOK	;Were we sleeping?
	     SKIPA A,[SIXBIT/BUSY/] ;No, so say so
	      MOVE A,[SIXBIT/GOING/] ;Yes, tell him we're continuing
	    MOVEM A,IPCFBF+.IPCI0 ;Set the reply
	    MOVX A,.IPCFP+1	;Send reply
	    MOVEI B,IPCFMS
	    MSEND%
	     ERJMP .+1		;MSEND% to send reply failed
	    MOVE A,[SIXBIT/WAKEUP/] ;Fake a WAKEUP request
	  ENDIF.
	  CAME A,[SIXBIT/WAKEUP/] ;Just wakeup?
	  IFSKP.
	    SETOM NOSLEP	;Do not sleep next time around
	    AOSN IPCFOK		;Ok to interrupt?
	     AOS INTPC		;Yes, bump PC from DISMS%
	  ENDIF.
	  LOOP.			;And see if any more in queue
	ENDDO.
	MOVSI 17,INTACS		;Restore ACs
	BLT 17,17
	DEBRK%			;Dismiss interrupt
; Here to check for a packet, called by JSP C,IPCHEK

IPCHEK:	MOVX A,.MUQRY		;Query function for MUTIL%
	MOVEM A,IPCFBF
	MOVE A,PIDGET+.IPCFS	;Query packets for our PID
	MOVEM A,IPCFBF+1
	MOVX A,.IPCFP+2		;Get length
	MOVEI B,IPCFBF		;Address
	MUTIL%
	 ERJMP (C)		;MUTIL% failed -- no JWARN, may be interrupt
	JRST 1(C)		;Got it, so win
; Here for wakeup interrupt to net fork

WAKTOP:	MOVEI A,.FHSLF		;On self
	MOVE B,[LEVTAB,,CHNTAB]	;With interrupt table
	SIR%			;Set up interrupt system
	EIR%
WAKINI:	MOVEI A,.FHSLF		;If multiforking,
	MOVX B,1B<WAKCHN>	;Need channel to wake up other forks
	AIC%			;So activate it
	RET

; Here for fork 1 to set up so fork 2 will be interrupted
WAKNET:	SAVEAC <A,B>		;Don't mung registers
	MOVX A,.FHSUP		;On the mother fork
	MOVX B,1B<WAKCHN>	;With wakeup interrupt
	IIC%			;Initiate interrupt condition
	RET

WAKINT:	MOVEM 17,INTACS+17	;Save ACs
	MOVEI 17,INTACS
	BLT 17,INTACS+16
	SKIPE FORKX		;Are we the top fork?
	IFSKP.
	  MOVE A,FHTAB+NETFRK-1	;Yes, get network daughter fork
	  MOVX B,1B<WAKCHN>	;And wakeup interrupt channel
	  IIC%			;Wake up the fork
	ELSE.
	  SETOM NOSLEP		;Do not sleep next time around
	  AOSN IPCFOK		;Ok to interrupt?
	   AOS INTPC		;Yes, bump PC from DISMS%
	ENDIF.
	MOVSI 17,INTACS		;Restore ACs
	BLT 17,17
	DEBRK%			;Return from interrupt
	SUBTTL UUO handler

; UUO enters here via JSR UUOH
UUOH0:	AOSE INUUO		;Recursive call?
	 CALL CRASH		;No, crash
	MOVEM 17,UUOACS+17	;Save AC 17
	MOVEI 17,UUOACS		;Save AC's 0-16
	BLT 17,UUOACS+16
	MOVE P,[IOWD NUPDL,UUOPDL]  ;Set up local stack
	PUSH P,UUOH		;Save the UUO PC for debugging
	LDB A,[POINT 9,UUOLOC,8] ;a := opcode field
	CAIL A,MXUUO		;UUO valid?
	 CALL CRASH		;No, die
	CALL @UUOS(A)		;Dispatch to handler routine
	SOS INUUO		;Reset the entry flag
	POP P,UUOH		;Restore the UUO PC
	MOVSI 17,UUOACS		;Restore ACs
	BLT 17,17
	JRSTF @UUOH		;Dismiss UUO

; UUO handler dispatch table
UUOS:	CRASH			;UUO 0 is impossible
	%TYPE
	%ETYPE
	%ERROR
MXUUO==.-UUOS			;Maximum UUO

%TYPE:	SKIPN PRINTP
	 RET
	CALL TYCRIF		;Check if we should do a CRLF
	HRRO A,UUOLOC		;Get string
	PSOUT%
	RET
TYCRIF:	SKIPE DAEMNP		;Daemon?
	 JRST DTYCRF		;Yes, different routine
	MOVE A,UUOLOC		;Get instruction
	TXNE A,<10,0>		;Wants CRLF all the time?
	 JRST CRLF		;Yes
	TXNE A,<1,0>		;Wants fresh line?
	 JRST CRIF		;Yes
	RET

DTYCRF:	MOVE A,UUOLOC		;Get instruction
	TXNN A,<11,0>		;Want a CRLF at any time?
	 RET			;No, continuation of previous message probably
TIMSMP:	SAVEAC <A,B,C>
	CALL CRLF1		;Always CRLF to log file, RFPOS% unreliable
	MOVEI A,.PRIOU		;Now timestamp output
	SETO B,
	SETZ C,
	ODTIM%
	 ERJMP .+1
	MOVX A,.CHSPC		;Space before text
	PBOUT%
	MOVX A,.FHSLF		;Get my primary JFN's
	GPJFN%
	AOJN B,R		;Don't write "MMailr (n)" if output to file
	TMSG <MMailr (>
	MOVE A,FORKX		;Output fork number
	ADDI A,"0"
	PBOUT%
	TMSG <): >
	RET

CRIF:	SAVEAC <A,B>
	MOVEI A,.PRIOU
	RFPOS%
	TXNE B,.RHALF		;If not at start of line,
	 CALL CRLF1		;Type CRLF
	RET

CRLF:	SAVEAC <A>
CRLF1:	HRROI A,CRLF0
	PSOUT%
	RET

CRLF0:	ASCIZ/
/
%ERROR:	SKIPN DAEMNP		;Different code if daemon
	IFSKP.
	  MOVE B,UUOLOC		;Get instruction
	  IFXN. B,<<10,0>>	;Fatal error?
	    MOVX A,.FHSLF	;Be sure this gets printed
	    SETO B,
	    SPJFN%
	    SKIPN A,LOGJFN	;And close off log file if we can
	    IFSKP.
	      TXO A,CO%NRJ
	      CLOSF%
	       NOP
	    ENDIF.
	    SKIPN A,STAJFN	;Also nuke statistics file
	  ANSKP.
	    TXO A,CO%NRJ
	    CLOSF%
	     NOP
	  ENDIF.
	  CALL TIMSMP		;Timestamp output
	ELSE.
	  CALL CRIF		;Get a fresh line
	  MOVE B,UUOLOC		;Get instruction
	  TXNE B,<10,0>		;Wants %?
	   SKIPA A,["?"]	;No
	    MOVEI A,"%"
	  PBOUT%
	ENDIF.
	MOVE B,UUOLOC
	IFXN. B,.RHALF		;Any message to print?
	  CALL %ETYE0		;Yes, print it out
	  MOVE B,UUOLOC		;And recover instruction
	ENDIF.
	IFXN. B,<<4,0>>		;Wants JSYS error message?
	  IFXN. B,.RHALF	;If a previous message, type delimiter
	    TMSG < - >
	  ENDIF.
	  MOVX A,.PRIOU
	  HRLOI B,.FHSLF	;This fork
	  SETZ C,
	  ERSTR%
	   ERJMP .+1
	   ERJMP .+1
	  MOVE B,UUOLOC		;See if primary message was given
	  IFXE. B,.RHALF
	    TMSG <, at >	;None, should give PC...
	    HRRZ T,UUOH		;Get PC of UUO caller
	    SUBI T,1
	    CALL SYMOUT
	  ENDIF.
	ENDIF.
	CALL CRLF		;Output CRLF
	MOVE B,UUOLOC		;Get instruction
	TXNE B,<10,0>		;Fatal error?
	 CALL CRASH
	RET			;No, return to user
;;; Fatal errors

CRASH:	MOVEM 17,FATACS+17	;Save ACs at time of crash
	MOVEI 17,FATACS
	BLT 17,FATACS+16
	MOVE 17,FATACS+17
	SKIPE DAEMNP		;If not running as a daemon
	IFSKP.
	  DO.
	    TMSG <?Fatal error - can't continue
>
	    HALTF%		;Just die
	    LOOP.
	  ENDDO.
	ENDIF.
	MOVX A,.FHSLF		;Be sure this gets printed
	SETO B,
	SPJFN%
	SKIPN A,LOGJFN		;And close off log file if we can
	IFSKP.
	  TXO A,CO%NRJ		;Don't flush yet to allow debug
	  CLOSF%		;Don't SETZM yet so dump has JFN
	   NOP
	ENDIF.
	SKIPN A,STAJFN		;Close statistics file
	IFSKP.
	  TXO A,CO%NRJ		;Don't flush yet to allow debug
	  CLOSF%		;Don't SETZM yet so dump has JFN
	   NOP
	ENDIF.
	MOVX A,GJ%FOU!GJ%NEW!GJ%SHT
	HRROI B,[ASCIZ/MAIL:MMAILR-CRASH-DUMP.EXE;P770000/]
	GTJFN%
	IFJER.
	  DO.
	    HALTF%		;Just die
	    TMSG <?Can't get crash dump file
>
	    LOOP.
	  ENDDO.
	ENDIF.
	MOVE B,A
	CALL TIMSMP
	TMSG <Fatal error - taking crash dump onto >
	MOVX A,.PRIOU
	SETZ C,
	JFNS%			;Output name of the file
	MOVE A,B
	HRLI A,.FHSLF		;This fork
	MOVE B,[777760,,20]	;Save all assigned nonzero memory
	SAVE%			;Take the crash dump
	IFJER.
	  TMSG < (failed)>	;Don't blow up if out of disk space
	ENDIF.
	RESET%			;Flush everything we were doing
	TMSG < ...reloading in 5 minutes
>
	SETOM TIMKIL		;Kill the clock
	MOVE A,[5*^D60*^D1000]	;5 minutes
	DISMS%
	MOVX A,GJ%SHT!GJ%OLD
	HRROI B,[ASCIZ/SYS:MMAILR.EXE/]
	GTJFN%
	IFJER.
	  MOVX A,GJ%SHT!GJ%OLD
	  HRROI B,[ASCIZ/SYSTEM:MMAILR.EXE/]
	  GTJFN%
	  IFJER.
	    DO.
	      TMSG <?Can't get MMAILR.EXE
>
	      HALTF%		;Just die
	      LOOP.
	    ENDDO.
	  ENDIF.
	ENDIF.
	HRRM A,RLDSLF		;Save JFN in reload routine
	MOVSI P,RLDSLF		;Blt the reload rtn into acs
	BLT P,P
	SKIPN FORKX		;Top fork?
	IFSKP.
	  HRRI %RLDFX,<FRKTAB-ENTVEC>-1 ;No, entry vector offset for daughter
	  ADD %RLDFX,FORKX	;Get fork index
	ENDIF.
	JRST %RLDSL

; Following is the ac routine used to reload ourselves
RLDSLF:
   PHASE 0		;Loc cntr := 0
	.FHSLF,,0		;0  GET arg
	-1			;1  PMAP% arg to clear memory
	.FHSLF,,0		;2  PMAP% arg to clear memory
	0			;3  PMAP% dummy access arg
	1000			;4  PMAP% cntr for all memory
%RLDSL:!PMAP%			;5  Entry to clear memory
	ADDI B,1		;6  Bump page ptr
	SOJG D,%RLDSL		;7  PMAP% loop
	MOVE A,F		;10 a := GET arg
	GET%			;11
	MOVEI A,.FHSLF		;12 a := our frk handle
	CLZFF%			;13 Cleanup outstanding files
%RLDFX:!MOVEI B,0		;14 Start at entry vec
	SFRKV%			;15
	HALTF%			;16 ???
	0			;17
   DEPHASE

%FATL1:	HALTF%
	TMSG <?Can't continue
>
	CALL CRASH
; Clever symbol table lookup routine.  For details, read "Introduction to
;DECSYSTEM-20 Assembly Language Programming", by Ralph Gorin, published by
;Digital Press, 1981.  Called with desired symbol in T.

SYMOUT:	SETZB C,E		;No current program name or best symbol
	MOVE D,116		;Symbol table pointer
	HLRO A,D
	SUB D,A			;-Count,,ending address +1
SYMLUP:	LDB A,[POINT 4,-2(D),3]	;Symbol type
	JUMPE A,NXTSYM		;Program names are uninteresting
	CAILE A,2		;0=prog name, 1=global, 2=local
	IFSKP.
	  MOVE A,-1(D)		;Value of the symbol
	  CAME A,T		;Exact match?
	  IFSKP.
	    MOVE E,D		;Yes, select it
	    JRST FNDSYM
	  ENDIF.
	  CAML A,T		;Smaller than value sought?
	  IFSKP.
	    SKIPE B,E		;Get best one so far if there is one
	     CAML A,-1(B)	;Compare to previous best
	      MOVE E,D		;Current symbol is best match so far
	  ENDIF.
	ENDIF.
NXTSYM:	ADD D,[2000000-2]	;Add 2 in the left, sub 2 in the right
	JUMPL D,SYMLUP		;Loop unless control count is exhausted
	SKIPN D,E		;Did we find anything helpful?
	 JRST OCTSYM

;Found an entry that looks close.  See if it really is and if so use it

FNDSYM:	MOVE A,T		;Desired value
	SUB A,-1(D)		;Less symbol's value = offset
	CAIL A,200		;Is offset small enough?
	IFSKP.
	  MOVE D,E		;Yes, get the symbol's address
	  MOVE A,-2(D)		;Symbol name
	  TXZ A,<MASKB 0,3>	;Clear flags
	  CALL SQZTYO		;Print symbol name
	  MOVE B,T		;Get desired value
	  SUB B,-1(D)		;Less this symbol's value
	  JUMPE B,R		;If no offset, don't print "+0"
	  MOVEI A,"+"		;Add + to the output line
	  PBOUT%
	ELSE.
OCTSYM:	  MOVE B,T		;Here if PC must be in octal
	ENDIF.
	MOVX A,.PRIOU		;And copy numeric offset to output
	MOVEI C,^D8
	NOUT%
	 ERJMP R
	RET

; Convert a 32-bit quantity in A from squoze to ASCII

SQZTYO:	IDIVI A,50		;divide by 50
	PUSH P,B		;save remainder, a character
	SKIPE A			;if A is now zero, unwind the stack
	 CALL SQZTYO		;call self again, reduce A
	POP P,A			;get character
	ADJBP A,[POINT 7,[ASCII/ 0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ.$%/],6]
	LDB A,A			;convert squoze code to ASCII
	PBOUT%
	RET
%ETYPE:	SKIPN PRINTP
	 RET
	CALL TYCRIF		;Type a CRLF maybe
%ETYE0:	HRRZ N,UUOLOC
%ETYS0:	HRLI N,(<POINT 7,0>)	;Get byte pointer to string
	DO.
	  ILDB A,N		;Get char
	  IFN. A
	    CAIN A,"%"		;Escape code?
	    IFSKP.
	      PBOUT%		;No, just print it out
	      LOOP.
	    ENDIF.
	    SETZ O,		;Reset AC
	    DO.
	      ILDB A,N
	      CAIL A,"0"	;Is it part of addr spec?
	       CAILE A,"7"
	       IFSKP.
		 IMULI O,^D8	;Yes, increment address
		 ADDI O,-"0"(A)
		 LOOP.
	       ENDIF.
	    ENDDO.
	    CAIG A,"Z"		;If within range of special codes
	     CAIGE A,"A"
	     IFSKP.
	       CALL @%ETYTB-"A"(A) ;Do code-dependent thing
	     ELSE.
	       CALL %ETYP0	;Else output character as is
	       JUMPE A,ENDLP.	;If string terminated with "%" exit now
	     ENDIF.
	    LOOP.
	  ENDIF.
	ENDDO.
	RET

%ETYP0:	PUSH P,A		;Here if function not defined, save character
	MOVEI A,"%"		;Output leading %
	PBOUT%
	POP P,A			;Now output the losing character
	PBOUT%
	RET

%ETYTB:	%ETYPA			;A - print time
	%ETYPB			;B - print date
	%ETYP0			;C
	%ETYPD			;D - print decimal
	%ETYER			;E - error code
	%ETYPF			;F - floating
	%ETYP0			;G
	%ETYPH			;H - RH as octal
	%ETYP0			;I
	%ETYPJ			;J - filename
	REPEAT 4,<%ETYP0>	;K, L, M, N
	%ETYPO			;O - octal
	%ETYPP			;P - pluralizer
	REPEAT 2,<%ETYP0>	;Q, R
	%ETYPS			;S - string
	%ETYPT			;T - date and time
	%ETYPU			;U - user name
	%ETYP0			;V
	%ETYPW			;W - string without "%" processing
	REPEAT 3,<%ETYP0>	;X, Y, Z
%ETYPA:	MOVX C,OT%NDA		;No day, just time
	JRST %ETYB0

%ETYPT:	TDZA C,C		;Both date and time
%ETYPB:	 MOVX C,OT%NTM		;No time, just day
%ETYB0:	JUMPE O,.+2		;If AC field spec'd
	 SKIPA B,UUOACS(O)	;Use it
	  SETO B,		;Else use now
	MOVEI A,.PRIOU
	ODTIM%
	RET

%ETYPD:	SKIPA C,[^D10]		;Decimal
%ETYPO:	 MOVEI C,^D8		;Octal
	MOVE B,UUOACS(O)	;Get data
%ETYO0:	MOVEI A,.PRIOU
	NOUT%
	 ERJMP .+1
	RET

%ETYER:	MOVEI A,.PRIOU
	MOVSI B,.FHSLF		;This fork
	HRR B,UUOACS(O)		;Get error code
	SETZ C,
	ERSTR%
	 ERJMP .+1
	 ERJMP .+1
	RET

%ETYPF:	MOVEI A,.PRIOU
	MOVE B,UUOACS(O)
	SETZ C,
	FLOUT%
	 ERJMP .+1
	RET
%ETYPH:	MOVEI C,^D8
	HRRZ B,UUOACS(O)
	JRST %ETYO0

%ETYPJ:	MOVEI A,.PRIOU
	HRRZ B,UUOACS(O)
	MOVE C,[001110,,1]
	JFNS%
	RET

%ETYPP:	MOVEI A,"s"
	MOVE B,UUOACS(O)
	CAIE B,1
	 PBOUT%			;Make plural unless just one
	RET

%ETYPS:	PUSH P,N
	SKIPE N,UUOACS(O)
	 CALL %ETYS0		;Recursive call
CPOPNJ:	POP P,N
	RET

%ETYPU:	MOVEI A,.PRIOU
	MOVE B,UUOACS(O)
	DIRST%
	 ERJMP .+1
	RET

%ETYPW:	MOVE A,UUOACS(O)
	TXNN A,.LHALF
	 HRLI A,(<POINT 7,0>)
	PSOUT%
	RET
	SUBTTL Utility Routines

;;;Helper routine for JSR SAVACS.  MPP is necessary because some of the
;;;routines which use SAVACS are less than careful about making sure the
;;;stack context is the same as it was right after the JSR SAVACS call (e.g.
;;;some error returns fail to pop saved stuff on the stack).  These should
;;;eventually be identified and fixed, then MPP can be flushed.

ACBASE==17			;Base where AC0 resides on stack
				;Reference saved AC's with AC-ACBASE(P)

SAVAC0:	PUSH P,MPP		;Save former stack context save
	ADJSP P,ACBASE		;Create room on the stack for our ACs
	MOVEM ACBASE-1,(P)	;Save AC16 on stack
	MOVEI ACBASE-1,-<ACBASE-1>(P) ;AC0 to lowest save area location
	BLT ACBASE-1,-1(P)	;Save AC0-AC15
	MOVE ACBASE-1,(P)	;Retrieve AC16
	CALL [	MOVEM P,MPP	;Save current stack context
		JRST @SAVACS]	;Call invoking routine
	 JRST SAVAR0		;+0
	 JRST SAVAR1		;+1
	 JRST SAVAR2		;+2
	 JRST SAVAR3		;+3
	 JRST SAVAR4		;+4
	 JRST SAVAR5		;+5
SAVAR6:	AOS -<ACBASE+1>(P)	;+6, hopefully as hairy as we'll ever get!
SAVAR5:	AOS -<ACBASE+1>(P)	;+5
SAVAR4:	AOS -<ACBASE+1>(P)	;+4
SAVAR3:	AOS -<ACBASE+1>(P)	;+3
SAVAR2:	AOS -<ACBASE+1>(P)	;+2
SAVAR1:	AOS -<ACBASE+1>(P)	;+1
SAVAR0:	MOVSI ACBASE-1,-<ACBASE-1>(P) ;AC0 from lowest save area location
	BLT ACBASE-1,ACBASE-1	;Restore AC0-AC15
	ADJSP P,-ACBASE		;Garbage collect stack location
	POP P,MPP		;Restore former stack context save
	RET			;Return to caller
; "Super" SFUST emulation.
; Entry:   a = JFN
;	   b = ptr to author string
; Call:    CALL .SFUST
; Return:  +1, always

.SFUST:	STKVAR <AUTJFN>
	MOVEM A,AUTJFN		;Save JFN
	MOVX A,.CHCNV		;Quote character
	TXC B,.LHALF		;See if LH = -1
	TXCN B,.LHALF
	 HRLI B,(<POINT 7,0>)	;Yes, set up as byte pointer
	MOVE D,[POINT 7,FRMMSG]	;A convenient place to write it into
	DO.
	  ILDB C,B
	  CAIE C,.CHCNV		;Quote?
	  IFSKP.
	    IDPB C,D		;Yes, next character is quoted already
	    ILDB C,B
	    IDPB C,D
	    LOOP.
	  ENDIF.
	  CAIL C,"a"		;Character lowercase?
	   CAILE C,"z"
	    CAIA
	     IDPB A,D		;Yes, quote it
	  IDPB C,D
	  JUMPN C,TOP.
	ENDDO.
	HRROI A,FRMMSG		;Remove relative domain
	CALL $RMREL
	MOVE A,AUTJFN		;Restore JFN
	HRLI A,.SFLWR		;Set its writer
	HRROI B,FRMMSG
	SFUST%
	 ERJMP .+1
	RET

	ENDSV.

; Routine to fetch the write date/time of a file
; Entry:   a = file JFN
; Call:    CALL .GFWDT
; Return:  +1, b = file write date/time

.GFWDT:	SAVEAC <C>
	MOVEI B,B		;Answer into b
	MOVX C,<.RSWRT+1>	;Only the write date/time
	RFTAD%
	RET
; Routine to compare two strings ignoring case differences
; Entry:   a,b = ptrs to strings
; Call:    CALL STRCMP
; Return:  +1, match failed
;	   +2, strings match
STRCMP:	SAVEAC <C,D>
	DO.
	  ILDB C,A		;c := next char from a
	  CAIL C,"a"		;Raise it if necessary
	   CAILE C,"z"
	    CAIA
	     SUBI C,"a"-"A"
	  ILDB D,B		;d := next char from b
	  CAIL D,"a"		;Raise it if necessary
	   CAILE D,"z"
	    CAIA
	     SUBI D,"a"-"A"
	  CAME C,D		;Same?
	  IFSKP.
	    JUMPN C,TOP.	;If not end of strings, continue
	    RETSKP		;Match, return +2
	  ENDIF.
	ENDDO.
	RET

; Routine to compare two strings ignoring case differences
; Entry:   a = ptr to ASCIZ string
;	   b/c = ptr/len of string
; Call:    CALL STRCAL
; Return:  +1, match failed
;	   +2, strings match
STRCAL:	ILDB T,A		;t,tt := next chars raised
	JUMPE T,R		;If ended here, no match
	CAIL T,"a"
	 CAILE T,"z"
	  CAIA
	   SUBI T,"a"-"A"
	ILDB TT,B
	CAIL TT,"a"
	 CAILE TT,"z"
	  CAIA
	   SUBI TT,"a"-"A"
	CAME T,TT		;Match?
	 RET			;No
	SOJG C,STRCAL		;Check if more input
	ILDB T,A		;No more in string 2, 1st ended?
	JUMPE T,RSKP		;If so, have a match
	RET			;Otherwise, no match
; Routine to compare two strings ignoring case differences
; Entry:   a/b = ptr/len of string 1
;	   c/d = ptr/len of string 2
; Call:    CALL STRCLL
; Return:  +1, match failed
;	   +2, strings match
STRCLL:	CAME B,D		;Strings same length?
	 RET			;No, can't match
	JUMPE B,RSKP		;Same length, if null, match already
	DO.
	  ILDB T,A		;t,tt := next chars raised
	  CAIL T,"a"
	   CAILE T,"z"
	    CAIA
	     SUBI T,"a"-"A"
	  ILDB TT,C
	  CAIL TT,"a"
	   CAILE TT,"z"
	    CAIA
	     SUBI TT,"a"-"A"
	  CAME T,TT		;Match?
	   RET			;No
	  SOJG B,TOP.		;Check if more input
	ENDDO.
	RETSKP			;Good match
...LIT:	XLIST
	LIT
	LIST

	END <ENTVCL,,ENTVEC>	;Set up entry vector