Google
 

Trailing-Edge - PDP-10 Archives - SRI_NIC_PERM_SRC_3_19910112 - mm-dom/mailst.mac
There are 2 other files named mailst.mac in the archive. Click here to see a list.
	TITLE MAILST List queued mail files from MAILQ: and user's directory
	SUBTTL Written by Tom Miles from QDMAIL

	SEARCH MACSYM,MONSYM	;System definitions
	SALL			;Suppress macro expansions
	.DIRECTIVE FLBLST	;Sane listings for ASCIZ, etc.
	.REQUIRE HSTNAM		;Host name routines
	.REQUIRE SYS:MACREL	;MACSYM support routines
	.TEXT "MAILST/SAVE"	;Save as MAILST.EXE
	.TEXT "/SYMSEG:PSECT:CODE" ;Put symbol table and patch area in CODE

VWHO==0
VMAJOR==6			;TOPS-20 release 6.1
VMINOR==1
VMLST==^D11			;MAILST's version number

; *******************************************************************
; *								    *
; * QDMAIL is a program to scan the connected directory for various *
; * queued mail files and to print out the file type and            *
; * destination host.  It is adapted from MMAILR.              	    *
; *								    *
; * MAILST is the server portion of the mail status program and runs*
; * in conjunction with MSTAT. See MSTAT.MAC for further description*
; * of mail status operating modes. MAILST is a modified version of *
; * QDMAIL.                    					    *
; *								    *
; *******************************************************************

; Routines invoked externally

	EXTERN $GTLCL
	SUBTTL Conditional Assembly

IFNDEF FTOMLR,<FTOMLR==1>	; Non-zero to process old queue files
IFNDEF DATORG,<DATORG==1000>	;Data on page 1
IFNDEF CODORG,<CODORG==10000>	;Code on page 10
IFNDEF PAGORG,<PAGORG==30000>	;Paged data on page 30
IFNDEF FREORG,<FREORG==40000>	;Free storage starts at page 40
	SUBTTL Definitions

F==0
A=1
B=2
C=3
D=4
E=5
T=6
TT=7
M=10
N=11
O=12
X=14
Y=15
Z=16
P=17

; Character definitions

.CHDEL==177			;Delete
EOL=.CHCUN			;End of line for PRINT UUO

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

; 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)
	   <	IFIDN <Z>,<>,<UERR Y,0>
		IFDIF <Z>,<>,<UERR Y,[ASCIZ /Z/]>
	   >
   >

DEFERR WARN,3
DEFERR JWARN,7
DEFERR FATAL,12
DEFERR JFATAL,16
	SUBTTL Impure storage

	LOC 41
	JSR UUOH

	.PSECT PAGDAT,PAGORG	;Declare PAGDAT PSECT
	.ENDPS

	.PSECT FRESTG,FREORG	;Declare FRESTG PSECT
FSPAG==FREORG/1000
	.ENDPS

	.PSECT DATA,DATORG	;Enter data area

CORBEG==.			;Start of core initialized at startup
PRINTP:	BLOCK 1			;If messages should print out
NPDL==177			;Size of stack
PDL:	BLOCK NPDL		;Pushdown list
MPP:	BLOCK 1			;Saved stack ptr for SAVACS/RSTACS
SAVEP:	BLOCK 1			;Place to save stack ptr in local rtns
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

;;; Structure of a mail file set up block
DEFINE DFMBLK(SYM)<
	SYM==MSGLEN
	MSGLEN==MSGLEN+1
>;End DEFINE

MSGLEN==0	;Initialize length of block
DFMBLK(MSGPAG)			;Starting -# pgs,,starting core page
DFMBLK(MSGJFN)			;File JFN
DFMBLK(MSGWRT)			;Time msg was queued
DFMBLK(MSGAFT)			;Time to attempt delivery
DFMBLK(MSGNTF)			;Time to tell sender of delivery status
DFMBLK(MSGDEQ)			;Time to dequeue the msg -- dead letter
MSGBLK:	BLOCK MSGLEN

DIRNUM:	BLOCK 1			;Directory being hacked
FILIDX:	BLOCK 1			;File tbl index for queued file type
IFN FTOMLR,<
   OMLRBF: BLOCK 20		;Buffer for address strings (old MAILER)
>;IFN FTOMLR
INUUO:	BLOCK 1			;Safety check to prevent recursive UUO's
TEMPAC:	BLOCK 1			;Temp ac storage
 NUPDL==20			;Size of UUO PDL
UUOPDL:	BLOCK NUPDL		;Pushdown list for processing UUO's
UUOACS: BLOCK 20		;ACs saved over UUO
INTPC:	BLOCK 1			;Interrupt PC
INTACS:	BLOCK 4			;ACs saved over interrupt
LHOST:	BLOCK 1			;Address of site entry for local host
NCKNMF:	BLOCK 1			;Non-zero if host name was a nickname
 HSTBFL==30
HSTBUF:	BLOCK HSTBFL		;Put string of a host here
STRBUF:	BLOCK 1000		;String buffer, used globally
STRBF1:	BLOCK 1000		;Alternative string buffer, used locally
USRMCH:	BLOCK 1			;User name match flag (0=no match, -1=match)
FNDFLG:	BLOCK 1			;File found flag (0=none found, -1=found)
MQDIR:	BLOCK 1			;MAILQ: directory number
SPECBF:	BLOCK 1000		;Buffer for creating a dummy header for
				; Special network queue-file
MSDIR:	BLOCK 1			;MAILS: directory number
RCVFLG:	0			;IPCF receive PDB - flags word
SNDPID:	0			;Sender's PID
RCVPID:	0			;Receiver's PID
RCVBF:	0			;Buffer length,,Address
USRDIR:	BLOCK 1			;User's login user number
PRVFLG:	BLOCK 1			;User has WHL!OPR priv's if -1
USRSTR:	BLOCK 8			;User's name string
TTYNUM:	BLOCK 1			;User's controlling TTY number
	BLOCK 2			;Dummy
COREND==.-1			;End of core initialized at startup

; Storage for IPCF communications with User portion

PIDGET:	IP%CPD			;Create a PID to use as sender's PID
PIDNUM:	0			;PID of sender
	0			;PID of receiver (0 for INFO)
	END1-.,,.+1		;length,,addr of message
	1,,.IPCII		;assign name to PID
	0			;no duplicates to receive INFO response
PIDNAM:	ASCIZ/[SYSTEM]MAILST/	;name to assign
END1==.-1
RCVACK:	ASCIZ/ACK/		;Response to User portion


DEBUG:	0			;If debugging

;; Routine to save AC's
SAVACS:	0			;JSR here to save all ACs on stack
	JRST [	PUSH P,MPP
		ADJSP P,17
		MOVEM P,MPP
		MOVEM 16,(P)
		MOVEI 16,-16(P)
		BLT 16,-1(P)
		JRST @SAVACS]

;; Routine to restore AC's
RSTACS:	0			;JSR here to restore ACs
	JRST [	MOVSI 16,-16(P)
		BLT 16,16
		ADJSP P,-17
		POP P,MPP
		JRST @RSTACS]

	.ENDPS
	SUBTTL Pure storage

	.PSECT CODE,CODORG

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

; Following are definitions and a table of file names/processing
; functions to handle delivery of various queued mail formats:

DEFINE FILXX(GSTR,PSTR,PRCHDR,PRCTXT,FLGS)<
   FL%STR==0
	[ASCIZ `GSTR`],,[ASCIZ `PSTR`] 	; File group name string and
					; printing descriptor
   FL%PRC==1
	PRCHDR,,PRCTXT			; Setup routines for processing
					; header/text
   FL%FLG==2
	FLGS
   FL%LEN==3
>;DEFINE FILXX

; Control flags for processing names
FF%OML==1B0		;Old style queue file (adr in extension)

FILTBL:
	FILXX(<[--QUEUED-MAIL--].NEW*>,<[New Queued Mail]>,GQUEKY,GQUEH1,0)
	FILXX(<[--QUEUED-MAIL--].NETWORK>,<[Network Queued Mail]>,GQUEKY,GQUEH1,0)
	FILXX(<[--QUEUED-MAIL--].RETRANSMIT>,<[Retransmit Queued Mail]>,GQUEKY,GQUEH1,0)
	FILXX(<[--RETURNED-MAIL--].>,<[Nondelivery Reply]>,GQUEKY,GQUEH1,0)
	FILXX(<[--RETURNED-MAIL--].NETWORK>,<[Network Nondelivery Reply]>,GQUEKY,GQUEH1,0)
	FILXX(<[--RETURNED-MAIL--].RETRANSMIT>,<[Retransmit Nondelivery Reply]>,GQUEKY,GQUEH1,0)
	FILXX(<[--BAD-QUEUED-MAIL--].>,<[Bad Mail]>,GQUEKY,GQUEH1,0)
	FILXX(<[--BAD-QUEUED-MAIL--].RETRANSMIT>,<[Retransmit Bad Mail]>,GQUEKY,GQUEH1,0)
	FILXX(<[--BAD-RETURNED-MAIL--].>,<[Bad Nondelivery Reply]>,GQUEKY,GQUEH1,0)
	FILXX(<[--BAD-RETURNED-MAIL--].RETRANSMIT>,<[Retransmit Bad Nondelivery Reply]>,GQUEKY,GQUEH1,0)
IFN FTOMLR,<
	FILXX(<[--UNSENT-MAIL--].*>,<[Old Style Queued Mail]>,GQUEUN,GQUEH0,FF%OML)
	FILXX(<]--UNSENT-NEGATIVE-ACKNOWLEDGEMENT--[.*>,<[Old Style Nondelivery Reply]>,GQUEUN,GQUEH0,FF%OML)
	FILXX(</UNDELIVERABLE-MAIL/.>,<[Old Style Dead Mail]>,GQUEUN,GQUEH0,FF%OML)
>;IFN FTOMLR
	FILXX(<-MAIL.*>,<[Special Domain Queued Mail]>,GQUEUS,GQUEH0,0)
NFTBL==<.-FILTBL>/FL%LEN

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

; Definition of program entry vector
ENTVEC:	JRST GO			; Normal entry
	JRST GO			; REENTER
	BYTE(3)VWHO(9)VMAJOR(6)VMINOR(18)VMLST ;QDMAIL version
ENTVCL==.-ENTVEC

GO:	RESET
	MOVE F,[A,,B]		;Clear out ACs (paranoia)
	SETZ A,
	BLT A,P
	MOVE P,[IOWD NPDL,PDL]	;Set up stack
	SETZB F,CORBEG		;Clear out impure storage
	MOVE A,[CORBEG,,CORBEG+1]
	BLT A,COREND
	SETOM INUUO		;Init recursive UUO flag
	MOVX A,.PRIOU		;Use our terminal for any I/O
	MOVEM A,TTYNUM		; until we detach
	MOVEI A,.FHSLF
	RPCAP%			;Get our capabilities
	IOR C,B			;Enable everything we've got
	EPCAP%
	HRROI A,LCLNAM		;Try to get local host name
	CALL $GTLCL
	 WARN <No local hostname information>
	MOVEI A,4		;Get a PID from INFO and assign name
	MOVEI B,PIDGET
	MSEND%
	 JFATAL <Couldn't get a PID from INFO>
	SETOM PRINTP		;Print all messages
	MOVX A,RC%EMO		;Get MAILQ: name string
	HRROI B,[ASCIZ/MAILQ:/]
	RCDIR
	TXNE A,RC%NOM!RC%AMB	;MAILQ: not there?
	  JFATAL <Couldn't find MAILQ:>
	MOVEM C,MQDIR		;Save dir number for DODIR
	MOVX A,RC%EMO
	HRROI B,[ASCIZ/MAILS:/]
	RCDIR%
	TXNE A,RC%NOM!RC%AMB
	 SETZ C,		;Don't blow up if no special domain
	MOVEM C,MSDIR
	JRST GETMES		;Go wait for a message

INIT:	MOVE A,[USRSTR,,USRSTR+1]
	SETZM USRSTR		;Clear out User name string,
	BLT A,PRVFLG		; TTY number and priv's flag
	SETZM USRMCH		;Init user name match flag

; Loop waiting for messages from User portion

GETMES:	SETZM RCVFLG		;Set up receive message PDB
	SETZM SNDPID
	MOVE A,PIDNUM
	MOVEM A,RCVPID
	MOVE B,[^D11,,USRSTR]
	MOVEM B,RCVBF
	MOVEI A,6
	MOVEI B,RCVFLG
	MRECV%			;Wait for a message
	 ERJMP %FATAL		;Something went wrong...
	HLRZ B,RCVBF		;Check the message length
	CAIE B,^D11		;Ignore it if wrong length
         JRST GETMES
	MOVX A,SC%WHL!SC%OPR
	TDNE A,PRVFLG
	IFNSK.
	  SETOM PRVFLG
	ELSE.
	  SETZM PRVFLG
	ENDIF.
	MOVX A,3
	MOVX B,3
	MOVX 3,.MUFOJ
	MOVE 4,SNDPID
	MUTIL%
	 ERJMP GETMES
	MOVE A,5
	HRROI B,TTYNUM
	MOVX C,.JITNO
	GETJI%
	 ERJMP GETMES
	HRROI A,USRSTR
	MOVE B,USRDIR
	DIRST%
	 ERJMP GETMES
	SETZ A,
	RCDIR%			;Get directory number
	MOVEM C,USRDIR		;And store for check below

; Process a user's request

	MOVX A,.TTDES		;Set up TTYNUM as device
	IORM A,TTYNUM		; designator for SOUT, BOUT, etc.
	MOVE B,MQDIR		;Set up for DODIR
       	CALL DODIR		;Go scan MAILQ:
	CALL CHKFND		;Tell user if no files found
	SKIPE B,MSDIR
	IFNSK.
	  CALL DODIR
	  CALL CHKFND
	ENDIF.
	MOVE B,USRDIR		;Set up for user's directory
	CALL DODIR		;Go scan user's directory
	CALL CHKFND		;Tell user if no files found
	CALL CLRPTB		;Unmap all remaining pages
	MOVEI A,.FHSLF
	CLZFF			;Close all files
TELUSR:	MOVE A,SNDPID		;Send acknowledgment to User
	MOVEM A,RCVPID
	MOVE A,PIDNUM
	MOVEM A,SNDPID
	SETZM RCVFLG
	MOVE B,[1,,RCVACK]
	MOVEM B,RCVBF
	MOVEI A,4
	MOVEI B,RCVFLG
	MSEND%
	 ERJMP TELUSR		;This shouldn't happen if IPCF is working

	JRST INIT		;Set up for new message
; Here to scan files in a directory
DODIR:	CIETYP <Trying %2U...>
	MOVEM B,DIRNUM		;Save directory number
	MOVE A,[-NFTBL,,FILTBL]	;Init file type index
	CAMN B,MSDIR
	 MOVE A,[-1,,FILTBL+<<NFTBL-1>*FL%LEN>] ;KLUDGE!!! But it's faster...
TFLUP:	MOVEM A,FILIDX
	HRROI A,STRBUF		;Set up name string for file sought
	MOVE B,DIRNUM
	DIRST%
	 ERJMP FILUPX		;No go, try next file type
	CAME B,MSDIR
	IFSKP.
	  MOVEI B,"."		;Smash delimiter
	  DPB B,A
	  MOVEI B,"*"		;Make wild
	  IDPB B,A		;<
	  MOVEI B,">"		;and make a new
	  IDPB B,A
	ENDIF.
	MOVE B,FILIDX		;b =: ptr to current file type string
	HLRZ B,FL%STR(B)
	CALL MOVST0
	MOVE A,[GJ%IFG!GJ%OLD!GJ%SHT+<0,,-3>]
	HRROI B,STRBUF
	GTJFN%
	 ERJMP FILUPX		;No go, try next file type
	MOVE X,A		;Save JFN
	SKIPN PRVFLG		;Skip next output if not priv'd
	JRST FILUP
	MOVE A,FILIDX
	HRRZ A,FL%STR(A)	;Pointer to file descriptor string
	CETYPE <%1W>
FILUP:	MOVE A,PRVFLG		;Set USRMCH depending on priv's
	MOVEM A,USRMCH		; if -1 will list all files
	MOVEI A,(X)
	CALL DQFIL		;Scan the file
	 CIETYP <  %1J ...can't map file> ;+1, can't map file
	 NOP				  ;+2, error processing file
	MOVE A,X		;Step to next file in this group
	GNJFN%
	 ERJMP FILUPX		;No more, try next type
	JRST FILUP

;; Here to step to the next file type
FILUPX:	MOVE A,FILIDX		;No, a =: current file type index
	ADDI A,FL%LEN-1		;Step to next one
	AOBJN A,TFLUP
	RET
SUBTTL Queued Mail File Handling

;;; Scan a queued mail file and print out relevant information
;;; about its queue status and destination.
; Entry:   a = wild card jfn for file
; Call:    CALL DQFIL
; Return:  +1, error mapping file
;	   +2, error processing file
;	   +3, success
DQFIL:	JSR SAVACS		;Save all ACs
	MOVEI B,(A)		;Make copy of the name
	HRROI A,STRBUF
	SETZ C,
	JFNS%
	HRROI B,STRBUF		;Must get another JFN
	CALL MAPQFL
	 JRST RSTRET		;Failed, return
	MOVEI M,MSGBLK		;m := pointer to msg block
	MOVEM A,MSGJFN(M)	;Save JFN
	MOVEM D,MSGPAG(M)	;Save starting copy
	CALL PARINI		;Initialize parser (ptr to msg text)
	SETZM MSGAFT(M)		;Clear default retransmission time
	SETZM MSGNTF(M)		;Clear delivery status notification time
	SETZM MSGDEQ(M)		;Clear default dequeue time for msg
	HRRZ A,MSGJFN(M)	;Get file write date
	CALL .GFWDT
	MOVEM B,MSGWRT(M)
	MOVE A,MPP		;Return at least +2 from here
	AOS -20(A)
	MOVE A,FILIDX		;a := current file type index
	HLRZ A,FL%PRC(A)	;a := processing dispatch for header
	JRST 0(A)		;Do it
GQUEUS:	PUSH P,X
	PUSH P,Y
	MOVE A,X
	HRROI B,STRBUF		;Read sender line
	MOVX C,^D120
	MOVX D,.CHCRT
	SIN%
	SETZ D,
	DPB D,B			;Smash CR
	MOVEM A,T		;Save new ptr
	HRROI A,STRBF1
	HRRZ B,MSGJFN(M)	;Get directory of file
	MOVX C,FLD(.JSAOF,JS%DIR)
	JFNS%
	MOVE A,[POINT 7,STRBF1]
	MOVEM A,C
GQUES1:	ILDB B,A		;Find last dot
	JUMPE B,GQUES0
	CAIN B,"."
	 MOVEM A,C
	JRST GQUES1
GQUES0:	MOVE A,[POINT 7,STRBF1]
	MOVE B,C		;Ptr to <to-host>
	MOVX C,^D120
	SETZ D,
	SOUT%
	MOVX D,^D120
	SUB D,C
	MOVEM D,Y		;Save length
	MOVE A,[POINT 7,STRBUF]	;Ptr to sender
	MOVE B,A
	SETZ X,			; Init host ptr
	DO.
	  ILDB C,B		;Get next char
	  JUMPE C,ENDLP.	;Quit on null
	  IDPB C,A		;Store char
	  CAIN C,"@"		;Atsign seen?
	   MOVE X,A		;Yes, save ptr to host
	  AOJA Y,TOP.		;Count char and loop
	ENDDO.
	SKIPE X			;"@" seen?
	 CAMN A,X		;Yes, host null?
	IFSKP.
	  DPB C,X		;No, clobber @ with null
	  SUBI Y,1		;Fix up count
	ELSE.
	  MOVE B,[POINT 7,LCLNAM] ;No, get local name
	  MOVE X,A		;Update host ptr (in case no "@")
	  DO.
	    ILDB C,B		;Get next char
	    JUMPE C,ENDLP.	;Quit on null
	    IDPB C,A		;Store char
	    AOJA Y,TOP.		;Count char and loop
	  ENDDO.
	ENDIF.
	MOVE B,A		;Ok, terminate edited string
	IDPB C,B
;Now fake a header
	MOVE A,[POINT 7,SPECBF]	;Write here
	MOVX B,.CHFFD		;FF
	IDPB B,A
	MOVEI B,"_"		;Sender spec follows
	IDPB B,A
	MOVE B,X		;<Host>
	SETZ C,
	SOUT
	MOVEI B,CRLF0		;CRLF
	CALL MOVSTR
	MOVEI B,STRBUF		;<User>
	CALL MOVSTR
	MOVEI B,CRLF0		;CRLF
	CALL MOVSTR
	MOVEI B,.CHFFD		;FF
	IDPB B,A
	MOVE C,[POINT 7,STRBF1]	;<To-host>
GQUES4:	ILDB B,C
	IFN. B
	  IDPB B,A
	  AOJA Y,GQUES4
	ENDIF.
;	MOVEI B,CRLF0		;CRLF
;	CALL MOVSTR
	MOVX B,.CHCRT
	IDPB B,A
	MOVE B,T		;Get next line of file (addresse)
	MOVX C,^D120
	MOVX D,.CHFFD		;End on FF
	SOUT%
	MOVEI B,CRLF0
	CALL MOVST0
	MOVX D,^D120
	SUB D,C
	ADD Y,D
	ADDI Y,^D<2+4+1+2>+1
	MOVE X,[POINT 7,SPECBF]
	JRST GQUEKY
IFN FTOMLR,<
;; 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
GQUEN0:	ILDB C,B		;c := next char
	JUMPE C,GQUEN1		;Quit on null
	CAIN C,.CHCNV		;^V?
	 JRST GQUEN0		;Yes, ignore it
	CAIN C,"@"		;Start of host?
	 JRST [ SETZ C,		;Yes, clobber the "@" with a null
		IDPB C,A
		MOVE X,A	;Save start of host string
		JRST GQUEN0 ]
	IDPB C,A		;Store the char
	AOJA Y,GQUEN0		;Count the char and do the next

; Here we have the end of the addressee string
GQUEN1:	SKIPE X			;"@" seen?
	 CAMN A,X		;Yes, host null?
	  JRST [MOVE B,[POINT 7,LCLNAM]	;No, use local name
		MOVE X,A	;Update host ptr (in case no "@")
		JRST GQUEN0 ]
	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 GQUEKY		;Make like it's [--QUEUED-MAIL--]
>;IFN FTOMLR

;; Parse the head of the file
GQUEKY:	CALL PARLIN		;Get a line from the file
	 JRST QUEEOF		;Premature eof
	TRNN F,FP%FF		;Was a formfeed seen?
	 JRST [	CETYPE <   ?Invalid queued mail file format in line ">
		JRST QUEBK0]	;Toss the losing file out

;; Now parse the message recipients
GQUERC:	TRNE F,FP%EOL		;Empty line?
	 JRST [	TRNE F,FP%EQU	;Control parameter specification?
		 JRST QUEBPM	;Yes, must be error
		TRNN F,FP%BKA	;Sender specification?
		 JRST GQUEHD	;No, must be start of actual message
		MOVE A,[POINT 7,HSTBUF] ;Yes, substitute local name
		MOVEI B,LCLNAM
		CALL MOVST0
		JRST GQURC0]	;Process it
	TRNE F,FP%EQU		;Control parameter specification?
	 JRST [	MOVEI A,QUEPTB	;Yes, lookup in parameter keyword table
		CALL PARKEY
		 JRST QUEBPM	;Bad luck...
		JRST GQURC1]	;Got it, continue processing
	CALL PARSTR		;Get pointers for this line
	MOVE B,[POINT 7,HSTBUF]
	DO.
	  ILDB A,C		;Make uppercase
	  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
	  TLNE B,760000
	   LOOP.
	ENDDO.
GQURC0:	TRNN F,FP%BKA		;Sender spec?
	 JRST GQURC1		;No - get another line
	CALL PARLIN		;Get sender name
	 JRST QUEEOF		;Premature EOF
	SKIPN PRVFLG		;Priv'd user?
	IFSKP.
	  MOVE A,PLINBP		;Yes, get string pointer
	  CETYPE <    From: %1W>
	  MOVEI A,HSTBUF	;Get host portion
	  ETYPE <@%1W>
	ELSE.
	  HRRZI A,USRSTR	;Set up for name match test
	  HRLI A,(<POINT 7,0>)
	  MOVE B,PLINBP
	  CALL STRCMP		;Compare the strings
	  IFNSK.
	    CALL RELQUE		;No match - free this storage
	    JRST RSTSKP		;Skip to next file
	  ENDIF.
	  SETOM USRMCH		;Set user name match flag
	  SKIPE FNDFLG		;Have we found a file already?
	ANSKP.
	  CTYPE <You have mail in the queue:> ;No, output this
	  CTYPE < >
	  SETOM FNDFLG
	ENDIF.

;; Here to process the next input line...

GQURC1:	CALL PARLIN		;Get a line
	 JRST QUEEOF		;Premature eof
	TRNE F,FP%FF		;Started with form?
	 JRST GQUERC		;Yes, next host then
	SKIPN USRMCH		;We should never get here without
	 JRST GQURC1		; a match, but just in case...
	MOVE A,PLINBP		;Get string pointer to sender's name
	CETYPE <      To: %1W>
	MOVEI A,HSTBUF		;Get host portion
	ETYPE <@%1W>
	JRST GQURC1		;Go get next line


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

IFN FTOMLR,<
GQUEH0:	POP P,Y			;Recover ptr info for msg text itself
	POP P,X
>;IFN FTOMLR
GQUEH1:	CALL PARLIN		;Process msg text headers
	 JRST GQUEH9		;EOF before Subject: field found
	TRNN F,FP%CLN		;Colon seen?
	 JRST GQUEH1		;No - get next line
	MOVEI A,QUEPTB		;Yes - scan keyword table
	CALL PARKEY
	 JRST GQUEH1		;No match - keep looking

; Successful return after Subject: found falls through to finish processing
; This will have to be changed if more than one message header keyword is
;  used

GQUEH9:	MOVE A,MSGWRT(M)	;Print date/time msg queued
	CETYPE <  Queued: %1T>
	SKIPE A,MSGAFT(M)	;Print date/time of delivery
	 CETYPE <  Delivery after: %1T>
	SKIPE A,MSGNTF(M)	;When to notify
	 CETYPE <  Notify after: %1T>
	SKIPE A,MSGDEQ(M)	;Print date/time to de-queue
	 CETYPE <  Message expires after: %1T>
	CALL CRIF
	CALL RELQUE		;Release the file
	JRST RSTSKP		;Skip return from it all

;;; Table of parameter keywords and processing routines
QUEPTB:	-NQPRMS,,.+1
	[ASCIZ/AFTER/],,QUEAFT	;Formerly RETRANSMIT
	[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
	[ASCIZ/SUBJECT/],,SUBTXT
NQPRMS=.-QUEPTB-1

;;; Here to process (no-op) "NET-MAIL-FROM-HOST" line
QUEHST:	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 fetch return path
QUERPT:	RETSKP

;;; Here to fetch return delivery options
QUEDEL:	RETSKP

;;; Here to set flag for discarding msg without notifying sender if
;;; failed or dequeued (no-op)
QUEDER:	RETSKP			;Success return

;;; Here to fetch error log file name
QUEERR:	RETSKP

;;; 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," "		;Skip starting spaces and tabs
	 CAIN B,.CHTAB
	  JRST [SOJG D,GQUTI0	;Look some more
		RET]		;Unless string exhausted
	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
;; Premature EOF
QUEEOF:	CETYPE <   ?Premature end of file>
QUEBRT:	CALL RELQUE		;Free entry
	JRST RSTRET		;Single return

;; Bad keyword
QUEBKY:	CETYPE <   ?Unrecognized keyword in line ">
QUEBK0:	MOVE A,TTYNUM		;User's TTY device designator
	CALL PARSTR		;Set up line ptr/length
	MOVE B,C
	MOVN C,D
	SOUT
	 ERJMP QUEBRT
	SETZ C,
QUEBK1:	HRROI B,[ASCIZ /"
/]
	SOUT
	 ERJMP .+1
	JRST QUEBRT

;; Bad control parameter specification
QUEBPM:	CETYPE <   ?Bad control parameter in line ">
	JRST QUEBK0

;; Subject: field in message text output
SUBTXT:	MOVE A,PLINBP
	CETYPE < %1W>
	RETSKP

;;; Release storage from queue entry in M
RELQUE:	HLRZ A,MSGPAG(M)	;a := # pages mapped
	JUMPE A,RELQUR		;Quit if none touched
	HRRZ B,MSGPAG(M)	;b := starting page
	CALL PAGDAL		;Unmap the msg file pages
RELQUR:	HRRZ A,MSGJFN(M)	;Close the file
	CLOSF
	 JFATAL <RELQUE: >
	RET
;;; Map in a file
; Entry:   b = ptr to name
; Call:    CALL MAPQFL
; Return:  +1, error
;	   +2, success
;   a = fresh file jfn
;   b = starting core address
;   c = # of bytes
;   d = # pages,,starting core page
MAPQFL:	PUSH P,[OF%RD!OF%PDT]	;Open read and leave access dates
	MOVSI A,(GJ%OLD!GJ%SHT)
	GTJFN
	IFJER.
	  POP P,B
	  RET
	ENDIF.
	PUSH P,A		;Save the jfn
	MOVE B,-1(P)		;Get OPENF flags and open the file
	OPENF
	 JRST MPFLOE		;No go
	SIZEF			;Fetch its size information
	 JRST MPFLSE		;No go
	PUSH P,B		;Save number of bytes
	MOVEI A,(C)		;Number of pages needed for whole file
	CALL PAGALC		;Allocate them
	 JRST MPFLPE		;No go???
	HRLZ A,-1(P)		;Start with page 0 of file
	HRLI B,.FHSLF
	HRLI C,(PM%CNT!PM%RD!PM%CPY)
	PMAP
	 ERJMP MPFLPE		;???
MAPFI1:	HRLI C,(B)
	MOVS D,C		;d := # pgs,,starting pg
	LSH B,9			;b := core address of first page
	POP P,C			;c := # of bytes
	POP P,-1(P)		;Move the jfn down on the stack
POPA1J:	POP P,A
	RETSKP

;; Here on error preparing file map
MPFLPF:	ADJSP P,-1		;Clear page count from stack
MPFLPE:	ADJSP P,-1		;Clear byte count from stack
MPFLSE:	POP P,A			;Close the file
	CLOSF
	 ERJMP .+1
MPFLSR:	ADJSP P,-1		;Clear OPENF bits
	RET

;; Here if OPENF fails for file
MPFLOE:	POP P,A			;Release the jfn
	RLJFN
	 ERJMP .+1
	JRST MPFLSR		;Fail return
	SUBTTL Parser

;;; Parser flags
FP%FF==1			;Formfeed seen at start of line
FP%CLN==2			;Colon seen
FP%EOL==4			;Blank line (after any formfeed, that is)
FP%DEL==10			;Rubout on line
FP%EQU==20			;Equal sign seen (control parameter)
FP%BKA==40			;Backarrow seen (sender spec)
FP%WSP==100			;Whitespace at start

;;; 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:	TRZ F,FP%FF!FP%CLN!FP%EOL!FP%DEL!FP%WSP
	SETZM PDELB2		;Filter for malformed <del> pairs
PARLN0:	DMOVEM X,PLINBP		;Save start of line
PARLN1:	DMOVEM X,PWSPBP
	SOJL Y,CPOPJ
	ILDB D,X		;Get first character
	CAIN D,.CHFFD		;Formfeed?
	 JRST [	TRO F,FP%FF
		TRZ F,FP%BKA!FP%EQU  ;Clear special flags
		JRST PARLN0]
	CAIN D,"="		;Equal sign?
	 JRST [ TRO F,FP%EQU	;Yes
		JRST PARLN0 ]
	CAIN D,"_"		;Backarrow?
	 JRST [ TRO F,FP%BKA	;Yes
		JRST PARLN0 ]
	CAIE D,.CHTAB
	 CAIN D,.CHSPC
	  JRST [TRO F,FP%WSP
		JRST PARLN1]
	CAIE D,.CHCRT		;End of line?
	 JRST PARLN3		;No, normal character
	TRO F,FP%EOL
	JRST PARLN4

PARLN2:	SOJL Y,CPOPJ
	ILDB D,X
	CAIN D,.CHCRT
	 JRST PARLN4
PARLN3:	CAIN D,.CHDEL
	 JRST PARLN5
	CAIN D,":"
	 TROE F,FP%CLN
	  JRST PARLN2
	DMOVEM X,PCLNBP		;Save pointers when got to colon
	JRST PARLN2

PARLN4:	SETZ A,			;Put null in CR byte so string
	DPB A,X			; prints will work right
	SOJL Y,CPOPJ
	ILDB D,X		;Skip lf too
	SKIPG PDELB2		;Matching <del> set?
	 TRZ F,FP%DEL		;No, ignore any seen
	RETSKP

PARLN5:	TROE F,FP%DEL		;Rubout within line is start of host
	 JRST [	SKIPE PDELB2	;Matching pair?
		 JRST [	SETOM PDELB2  ;No, flag error
			JRST PARLN2]
		DMOVEM X,PDELB2
		JRST PARLN2]
	DMOVEM X,PDELBP
	JRST PARLN2
PARLNE=.			;Bound for interrupt handling

;;; Parse a keyword from table in A
;;; Returns +1 failure, else calls routine pointed to by table
PARKEY:	TRNE F,FP%CLN		;Line had a colon in it?
	 JRST [	MOVE D,PCLNBP	;Yes, use byte pointer of colon then
		JRST PARKY1]
	SETO D,
	ADJBP D,X
PARKY1:	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,CPOPJ		;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
RSTSKP:	MOVE P,MPP		;Be sure stack is reset
	AOSA -20(P)		;Skip return
RSTRET:	 MOVE P,MPP		;Be sure stack is reset
	JSR RSTACS
	RET

CPOP2J:	AOS (P)
CPOP1J:	AOS (P)
CPOPJ:	RET
SUBTTL Core 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?
	 JRST [	MOVEI B,1(A)	;Try for next free page
		JRST PAGALB]
	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
	MOVE C,-2(P)		;Count
	HRLI C,(PM%CNT)
	PMAP			;Flush those pages
POPCBA:	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 core 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,
	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 =: core 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
SUBTTL UUO Handler

; UUO enters here via JSR UUOH
UUOH:	0			;Ret adr for JSR entry
	AOSE INUUO		;Recursive call?
	 JRST [	MOVEM A,TEMPAC	;Yes???
		HRROI A,[ASCIZ/Recursive UUO call illegal!/]
		CALL PSOUT
		MOVE A,TEMPAC
		JRST %FATAL]
	MOVEM A,UUOACS+A	;Save an ac
	MOVEM P,UUOACS+P	;And the stack
	MOVE P,[IOWD NUPDL,UUOPDL]  ;Set up local stack
	PUSH P,UUOH		;Save the calling pc
	PUSH P,[UUORTP]		;Put stack restore entry on
	LDB A,[POINT 9,40,8]	;a := opcode field
	JRST @UUOS(A)		;Dispatch to handler routine

; Here to save whole ac block and set up for RET to restore acs and
; return.  Entered by JSR UUOSV
UUOSV:	0
	MOVE A,UUOACS+A		;Restore entry a
	MOVEM 16,UUOACS+16	;Save all ACs (P done on entry)
	MOVEI 16,UUOACS
	BLT 16,UUOACS+15
	PUSH P,[UUORT]		;Put ac restore entry on stack
	JRST @UUOSV

; Here to restore ac block and return +1 to user.
UUORT:	MOVSI 16,UUOACS		;Restore ACs
	BLT 16,16
	RET

; Here to restore single ac and return +1 to user.
UUOFRT:	MOVE A,UUOACS+A		;Recover ac
	RET

; Here to restore return adr and caller's stack ptr
UUORTP:	POP P,UUOH		;UUOH := return adr
	MOVE P,UUOACS+P		;p := caller's stack
	SOS INUUO		;Reset the entry flag
	JRST @UUOH

; UUO handler dispatch table
UUOS:	0
	%PRINT
	%TYPE
	%ETYPE
	%ERROR

;; Print a character
%PRINT:	HRRZ A,40		;Get byte
	CAIN A,EOL		;PRINT EOL means do CRLF
	 JRST [	CALL CRLF	;Do it
		JRST UUOFRT ]
	CALL PBOUT
	JRST UUOFRT		;Take fast return

;; Type a string after crlf if needed
%TYPE:	SKIPN PRINTP
	 JRST UUOFRT
	CALL TYCRIF		;Check if we should do a CRLF
%TYPE0:	HRRO A,40		;Get string
	CALL PSOUT
	JRST UUOFRT

;; Do a conditional crlf
TYCRIF:	MOVE A,40		;Get instruction
	TLNE A,(<10,0>)		;Wants CRLF all the time?
	 JRST CRLF		;Yes
	TLNE A,(<1,0>)		;Wants fresh line?
	 JRST CRIF		;Yes
	RET

;; Do crlf if not at start of line currently
CRIF:	PUSH P,A
	PUSH P,B
	CALL CRIF1		;Do it
	JRST POPBAJ

CRIF1:	MOVE A,TTYNUM
	RFPOS
	 ERJMP R		;Return now if error
	TRNE B,-1		;If not at start of line,
	 CALL CRLF1		;Type CRLF
	RET

;; Do crlf unconditionally
CRLF:	PUSH P,A
	CALL CRLF1
	JRST CPOPAJ

CRLF1:	HRROI A,CRLF0
	CALL PSOUT
	RET

CRLF0:	ASCIZ/
/
;; Print error messages
%ERROR:	JSR UUOSV		;Save the ac context
	CALL CRIF		;Get a fresh line
	MOVE B,40		;Get instruction
	TLNE B,(<10,0>)		;Wants %?
	 SKIPA A,["?"]		;No
	  MOVEI A,"%"
	CALL PBOUT
%ERR1:	TRNN B,-1		;Any message to print?
	 JRST %ERR2		;No
	CALL %ETYE0		;Yes, print it out
	MOVE B,40		;And recover instruction
%ERR2:	TLNN B,(<4, 0>)		;Wants JSYS error message?
	 JRST %ERR3
	HRROI A,[ASCIZ / - /]
	TRNE B,-1		;If a previous message, type delimiter
	 CALL PSOUT
	MOVE A,TTYNUM
	HRLOI B,.FHSLF		;This fork
	SETZ C,
	ERSTR
	 ERJMP .+1
	 ERJMP .+1
%ERR3:	CALL CRLF
	LDB A,[POINT 2,40,12]	;Get low order bits of ac field
	JRST %ERRS(A)

%ERRS:	JRST %FATAL		;0 - not used
%ERRET:	JRST %FATAL		;1 - not used
	JRST %FATAL		;2 - return to EXEC
	RET			;3 - return to user

;; Here on fatal error
%FATAL:	HALTF
	HRROI A,[ASCIZ /?Can't continue
/]
	CALL PSOUT
	JRST %FATAL
;; Here to print a string, filling in escape sequences
%ETYPE:	JSR UUOSV		;Save the ac context
	SKIPN PRINTP
	 RET
	CALL TYCRIF		;Type a CRLF maybe
%ETYE0:	HRRZ N,40
%ETYS0:	HRLI N,(<POINT 7,0>)	;Get byte pointer to string
%ETYP1:	ILDB A,N		;Get char
	JUMPE A,CPOPJ		;Done
	CAIE A,"%"		;Escape code?
	 JRST %ETYP0		;No, just print it out
	SETZ O,			;Reset AC
%ETYP2:	ILDB A,N
	CAIL A,"0"		;Is it part of addr spec?
	 CAILE A,"7"
	  JRST %ETYP3		;No
	IMULI O,^D8		;Yes, increment address
	ADDI O,-"0"(A)
	JRST %ETYP2
%ETYP3:	CAIG A,"Z"
	 CAIGE A,"A"
	  JRST %ETYP0
	CALL @%ETYTB-"A"(A)	;Do dep't thing
	JRST %ETYP1

%ETYP0:	CALL PBOUT
	JRST %ETYP1

%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 with escape sequences
	%ETYPT			;T - date and time
	%ETYPU			;U - user name
	%ETYP0			;V
	%ETYPW			;W - string with no escapes
	REPEAT 3,<%ETYP0>	;X, Y, Z
;; Print time only
%ETYPA:	MOVSI C,(OT%NDA)	;No day, just time
	JRST %ETYB0

;; Options for printing just day or date/time
%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
	MOVE A,TTYNUM
	ODTIM%
	 ERJMP .+1
	RET

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

;; Print string for specified error code
%ETYER:	MOVE A,TTYNUM
	MOVSI B,.FHSLF		;This fork
	HRR B,UUOACS(O)		;Get error code
	SETZ C,
	ERSTR%
	 ERJMP .+1
	 ERJMP .+1
	RET

;; Print floating point number
%ETYPF:	MOVE A,TTYNUM
	MOVE B,UUOACS(O)
	SETZ C,
	FLOUT%
	 ERJMP .+1
	RET

;; Print RH of number in octal
%ETYPH:	MOVEI C,^D8
	HRRZ B,UUOACS(O)
	JRST %ETYO0

;; Print file name from jfn
%ETYPJ:	MOVE A,TTYNUM
	HRRZ B,UUOACS(O)
	MOVE C,[001110,,1]
	JFNS%
	 ERJMP .+1 
	RET

;; Add "S" depending on the value of a number
%ETYPP:	MOVEI A,"s"
	MOVE B,UUOACS(O)
	CAIE B,1
	 CALL PBOUT			;Make plural unless just one
	RET

;; Recursive string output with escape sequence handling
%ETYPS:	PUSH P,N
	SKIPE N,UUOACS(O)
	 CALL %ETYS0		;Recursive call
CPOPNJ:	POP P,N
	RET

;; Print directory or user name
%ETYPU:	MOVE A,TTYNUM
	MOVE B,UUOACS(O)
	DIRST%
	 ERJMP .+1
	RET

;; String output without further escape sequence handling
%ETYPW:	MOVE A,UUOACS(O)
	TLNN A,-1
	 HRLI A,(<POINT 7,0>)
	CALL PSOUT
	RET
SUBTTL Utility Routines

; Routine to do PSOUT simulation - outputs to device designated
;  in TTYNUM
; Entry:   a = string pointer (HRROI A,[...] form)
; Call:    CALL PSOUT
; Return:  +1, AC1 trashed
PSOUT:	SAVEAC <B,C>
	MOVE B,A		;String pointer in AC2
	MOVE A,TTYNUM		;Device Designator in AC1
	SETZ C,
	SOUT%
	 ERJMP .+1		;Ignore failure
	RET

; Routine to do PBOUT simulation - outputs to device designated
;  in TTYNUM
; Entry:   a = byte
; Call:    CALL PBOUT
; Return:  +1, AC1 trashed
PBOUT:	SAVEAC <B>
	MOVE B,A		;Byte to AC2
	MOVE A,TTYNUM		;Device Designator in AC1
	BOUT%
	 ERJMP .+1
	RET

; Routine to tell user if no files were found in directory scanned
; Entry:   <none>
; Call:    CALL CHKFND
; Return:  +1, b trashed
CHKFND: MOVE B,DIRNUM		;Set up for CTYPE
	SKIPN PRVFLG
	 SKIPE FNDFLG		;Tell user if there were no files
	  SKIPA
	CIETYP <You have no outgoing mail in %2U>
	TYPE <
>
	SETZM FNDFLG
	RET

; 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:	PUSH P,C		;Save an ac
	MOVEI B,B		;Answer into b
	MOVEI C,1		;Only the write date/time
	RFTAD
	POP P,C			;Recover ac
	RET
;;;Move a string from B to A
MOVSTR:	HRLI B,(<POINT 7,0>)
MOVST1:	ILDB D,B
	JUMPE D,MOVST3
	IDPB D,A
	JRST MOVST1

;;;Move string and terminating null
MOVST0:	HRLI B,(<POINT 7,0>)
MOVST2:	ILDB D,B
	IDPB D,A
	JUMPN D,MOVST2
MOVST3:	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:	PUSH P,C		; Save some ac's
	PUSH P,D
STRCM0:	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"
	CAIN D,15		;<CR> in D?
	 SETZ D,		;Yes, mark end of string
	CAME C,D		; Same?
	 JRST STRCM1		; No
	JUMPN C,STRCM0		; If not end of strings, continue
	AOS -2(P)		; Match, return +2
STRCM1:	POP P,D			; Recover ac's
	POP P,C
	RET
...LIT:	XLIST
	LIT
	LIST

	END <ENTVCL,,ENTVEC>	; Set up entry vector
; Local Modes:
; Mode: MACRO
; Comment Start:;
; Comment Begin:;
; End: