TITLE MAPSER TOPS-20 Interactive Mail Access Protocol server
       SUBTTL Written by Mark Crispin

; Version components

MAPWHO==0                       ; who last edited MAPSER (0=developers)
MAPMAJ==7                       ; MAPSER's release version (matches monitor's)
MAPMIN==0                       ; MAPSER's minor version
MAPEDT==^D352                   ; MAPSER's edit version

       SEARCH MACSYM,MONSYM    ; system definitions
IFNDEF OT%822,OT%822==:1B35     ; in case old monitor
       SALL                    ; suppress macro expansions
       .DIRECTIVE FLBLST       ; sane listings for ASCIZ, etc.
       .TEXT "/NOINITIAL"      ; suppress loading of JOBDAT
       .TEXT "MAPSER/SAVE"     ; save as MAPSER.EXE
       .TEXT "/SYMSEG:PSECT:CODE" ; put symbol table and patch area in CODE
       .TEXT "/REDIRECT:CODE"  ; put MACREL in CODE
       .TEXT "/PVBLOCK:PSECT:PDV" ; put PDV's in PDV
       .REQUIRE SYS:MACREL     ; MACSYM support routines
       .REQUIRE SYS:HSTNAM     ; host name support routines

;  MAPSER is the server to access electronic mail from another system via
; a network.  It implements the server half of IMAP2 (Interactive Mail Access
; Protocol 2), the electronic mail access protocol defined by Mark Crispin in
; RFC 1064, and documented online on the Internet as:
;       [NIC.DDN.MIL]RFC:RFC1064.TXT
;
;  MAPSER also implements the read-only/read-write notification, FIND, BBOARD,
; and VERSION extensions.
;
;  While nominally MAPSER will be used layered on top of the DoD transport
; protocols (TCP/IP) in the Internet environment, it has been designed so
; that this is not necessary.  All I/O is done via primary I/O, and the
; Internet system call dependencies have been kept to a minimum so that the
; server can essentially support any network.
;
;  MAPSER runs on TOPS-20 release 6.1 and later monitors on model B CPU's
; only.
      SUBTTL Definitions

IFNDEF PDVORG,<PDVORG==1,,1000> ; PDV's on page 1001
IFNDEF CODORG,<CODORG==1,,2000> ; code on page 1002
IFNDEF DATORG,<DATORG==1,,30000> ; data on page 1030
IFNDEF PRVSEC,<PRVSEC==2>       ; first of two private data sections
IFNDEF MBXSEC,<MBXSEC==PRVSEC+2> ; mailbox section
IFNDEF MBXSCN,<MBXSCN==37-MBXSEC> ; number of mailbox buffer sections
IFNDEF TIMOCT,<TIMOCT==^D<12*60>> ; number of 5-second ticks before autologout
IFNDEF LOGMAX,<LOGMAX==5>       ; maximum number of login tries
IFNDEF TXTLEN,<TXTLEN==^D10000> ; length of a text line
IFNDEF ARGLEN,<ARGLEN==^D39>    ; length of a string argument
IFNDEF HSTNML,<HSTNML==^D64>    ; length of a host name
IFNDEF UXPAG,<UXPAG==20>        ; page number of date vector in index file
       UXADR==UXPAG*1000       ; address of date vector

MAPVER==<FLD MAPWHO,VI%WHO>!<FLD MAPMAJ,VI%MAJ>!<FLD MAPMIN,VI%MIN>!VI%DEC!<FLD MAPEDT,VI%EDN>

; Routines invoked externally

       EXTERN $GTLCL,$RMREL

; AC definitions

F==:0                           ; flags
A=:1                            ; JSYS, temporary ACs
B=:2
C=:3
D=:4
CX=:16                          ; scratch
P=:17                           ; stack pointer

; Flags

       MSKSTR F%LOG,F,1B0      ; logged in
       MSKSTR F%REE,F,1B1      ; reenter
       MSKSTR F%NVT,F,1B2      ; on a network terminal, must log out when done
       MSKSTR F%EOL,F,1B3      ; EOL seen
       MSKSTR F%ELP,F,1B4      ; buffer began with EOL
       MSKSTR F%RON,F,1B5      ; read-only file
       MSKSTR F%NCL,F,1B6      ; suppress close parenthesis
       MSKSTR F%BBD,F,1B7      ; BBOARD vs. SELECT comand

; Substitute TMSG

DEFINE TMSG (STRING) <
       HRROI A,[ASCIZ ~STRING~]
       PSOUT%
>;DEFINE TMSG

DEFINE TAGMSG (STRING) <
       CALL DMPTAG
       TMSG <STRING>
>;DEFINE TAGMSG

; Here's a macro that really should be in MACSYM!

DEFINE ANNJE. <..TAGF (ERJMP,)>

; Fatal assembly error macro

DEFINE .FATAL (MESSAGE) <
PASS2
PRINTX ?'MESSAGE
END
>;DEFINE .FATAL

CHLPR==:"("                     ; work around various macro lossages
CHRPR==:")"
CHLAB==:"<"
CHRAB==:">"
      SUBTTL Impure storage

       .PSECT DATA,DATORG      ; enter data area

WINDOW: BLOCK 2000              ; 2 page window for mapping flags
       WINPAG==WINDOW/1000     ; first window page
INDEX:  BLOCK 1000              ; window for mapping index file
       IDXPAG==INDEX/1000
       SEQLSN==1000
SEQLST: BLOCK SEQLSN            ; message sequence list
       MAXMGS==<.-SEQLST>*^D36 ; maximum number of messages
FATACS: BLOCK 20                ; save of fatal AC's
PDL:    BLOCK <PDLLEN==:600>    ; stack
FRKS:   BLOCK <FKSLEN==4>       ; readin area for GFRKS%
CMDBUF: BLOCK <TXTLEN/5>+1      ; command buffer
CMDCNT: BLOCK 1                 ; free characters in command buffer
TAGCNT: BLOCK 1                 ; count of tag character in command
IN2ACS: BLOCK 3                 ; save area for ACs A-C, level 2
LEV1PC: BLOCK 2                 ; PSI level 1 PC
LEV2PC: BLOCK 2                 ; PSI level 2 PC
LEV3PC: BLOCK 2                 ; PSI level 3 PC
TIMOUT: BLOCK 1                 ; timeout count
LOGCNT: BLOCK 1                 ; login failure count
ATOM:   BLOCK 1                 ; atomic argument for search
FSFREE: BLOCK 1                 ; first free storage free location

INICBG==.                       ; first location cleared at once-only init
MBXJFN: BLOCK 1                 ; JFN on currently SELECTed mailbox
MBXBSZ: BLOCK 1                 ; size of mailbox in bytes
MBXMGS: BLOCK 1                 ; number of messages in mailbox
MBXNMS: BLOCK 1                 ; number of new messages in mailbox
MBXRDT: BLOCK 1                 ; last reference of mailbox
IDXJFN: BLOCK 1                 ; index JFN on currently SELECTed mailbox
IDXADR: BLOCK 1                 ; address within index
LGUSRN: BLOCK 1                 ; login user number
LGDIRN: BLOCK 1                 ; login user directory
LGUSRS: BLOCK 10                ; login user string
MYUSRN: BLOCK 1                 ; my user number
       ; Following two lines must be in this order
MYJOBN: BLOCK 1                 ; my job number
MYTTYN: BLOCK 1                 ; my TTY number
       ; end of critical order data

REQID=='MM'                     ; request ID for ENQ%'ing
ENQBLS==1                       ; number of ENQ% blocks
ENQBLL==ENQBLS*<.ENQMS+1>       ; length of ENQ% block
ENQBLK: BLOCK ENQBLL            ; block for ENQ%'ing
LCLHST: BLOCK <HSTNML/5>+1      ; local host name

NFLAGS==^D36                   ; number of flags
NFLINI==^D6                    ; number of initial flags
NKYFLG==NFLAGS-NFLINI          ; number of keyword flags
FLGTAB: BLOCK NFLAGS            ; table of flag strings indexed by flag number
FLGBUF: BLOCK <TXTLEN/5>+1      ; buffer for keyword flags

INICEN==.-1                     ; last location cleared at once-only init

; Following data block must be the last in this PSECT

MSG1:!
MSGIPT: BLOCK 1                 ; pointer to internal header for message #1
MSGPTR: BLOCK 1                 ; pointer for message #1
MSGTAD: BLOCK 1                 ; date/time for message #1
MSGSIZ: BLOCK 1                 ; length in bytes of message #1
MSGHSZ: BLOCK 1                 ; length in bytes of header of message #1
MSGFLG: BLOCK 1                 ; flags for message #1
MSGENV: BLOCK 1                 ; pointer to envelope for message
MSGLEN==.-MSG1                  ; length of a message data block
       BLOCK <MAXMGS*MSGLEN>   ; space for many many messages

       .ENDPS

       .PSECT BUFSEC,<PRVSEC,,0>
ARGBUF: BLOCK <ARGBSZ==300000>  ; argument buffer
WRKBUF: BLOCK <AR2BSZ==100000>  ; work buffer
OUTBFR: BLOCK <1000000-<ARGBSZ+AR2BSZ>> ; output buffer
       .ENDPS

       .PSECT FREE,<<PRVSEC+1>,,0>
       BLOCK 777777            ; free storage
       .ENDPS

       .PSECT MBXBUF,<MBXSEC,,0>
       BLOCK 1                 ; mailbox buffer
       .ENDPS
      SUBTTL Start of program

       .PSECT CODE,CODORG      ; pure code

MAPSER: TDZA F,F                ; clear flags
MAPREE:  MOVX F,F%REE
       RESET%                  ; flush all I/O
       MOVE P,[IOWD PDLLEN,PDL] ; init stack context
       SETZM INICBG            ; clear once-only area
       MOVE A,[INICBG,,INICBG+1]
       BLT A,INICEN
       MOVE A,[FREE]           ; initialize free storage pointer
       MOVEM A,FSFREE
       MOVNI A,TIMOCT          ; reset timeout count
       MOVEM A,TIMOUT
       MOVNI A,LOGMAX          ; reset logout count
       MOVEM A,LOGCNT
       MOVE A,[FLGINI,,FLGTAB+NKYFLG] ; copy initial flags
       BLT A,FLGTAB+NKYFLG+NFLINI-1
       SETZ A,                 ; create private section
       MOVE B,[.FHSLF,,PRVSEC] ; this process,,our private sections
       MOVX C,SM%RD!SM%WR!2    ; read/write access
       SMAP%
        ERCAL FATAL
       CALL SETPSI             ; set up PSIs

; Get host info

       HRROI A,LCLHST          ; get local host name
       CALL $GTLCL
       IFNSK.
         TMSG <* BYE Unable to get local host name>
         JRST IMPERR
       ENDIF.
       HRROI A,LCLHST          ; remove relative domain from name we got
       CALL $RMREL

;  See if top-level fork, and if so assume we're a network server on an NVT.
; Note that all I/O is done via primary I/O.  This allows several ways we can
; be set up, e.g.:
; . traditional CRJOB% style running as a job on an NVT
; . on a physical terminal, as in a "TTY network" environment
; . with primary I/O remapped to the network JFN's

       GJINF%                  ; get job info
       MOVEM A,MYUSRN          ; save my user number
       DMOVEM C,MYJOBN         ; save job number/TTY number for later use
       IFGE. D                 ; can be NVT server only if attached
         MOVX A,.FHSLF         ; see what my primary I/O looks like.  If
         GPJFN%                ;  AC2 isn't -1 (.CTTRM,,.CTTRM), then we
         ..TAGF (<AOJN B,>,)   ;  can assume setup process init'd TTY
         MOVX A,.FHTOP         ; top fork
         SETZ B,               ; no handles or status
         MOVE C,[-FKSLEN,,FRKS] ; fork structure area
         GFRKS%                ; look at fork structure
          ERJMP .+1            ; ignore error (probably GFKSX1)
         HRRZ A,FRKS+1         ; get the top fork's handle
         CAIE A,.FHSLF         ; same as me?
         IFSKP.
           MOVX A,.PRIIN       ; set terminal type to ideal
           MOVX B,.TTIDL
           STTYP%
           MOVE B,[TT%MFF!TT%TAB!TT%LCA!TT%WKF!TT%WKN!TT%WKP!TT%WKA!<FLD .TTASC,TT%DAM>!<FLD .TTLDX,TT%DUM>]
           SFMOD%              ; has formfeed, tab, lowercase, all wakeup,
           STPAR%              ;  no translate ASCII, line half-duplex
           DMOVE B,[BYTE (2)2,2,2,0,2,2,2,2,2,2,2,2,2,2,2,2,2,2
                    BYTE (2)2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2]
           SFCOC%              ; disable all echoing on controls
           MOVX A,TL%CRO!TL%COR!TL%SAB!.RHALF ; break and refuse links
           MOVX B,.RHALF
           TLINK%
            ERCAL FATAL
           MOVX A,.PRIIN       ; refuse system messages
           MOVX B,.MOSNT
           MOVX C,.MOSMN
           MTOPR%
            ERCAL FATAL
           MOVE A,[SIXBIT/MAPSER/] ; set our name
           SETNM%
           MOVX A,.PRIIN       ; clear possible crud in our input buffer
           CFIBF%              ;  from an earlier connection
            ERJMP .+1
           TQO F%NVT           ; flag an NVT server
         ENDIF.
       ENDIF.

; Output banner

       TMSG <* OK >            ; start banner
       HRROI A,LCLHST          ; output host name
       PSOUT%
       TMSG < Interactive Mail Access Protocol server >
       MOVX A,.PRIOU           ; set up for primary output
       LOAD B,VI%MAJ,EVEC+2    ; get major version
       MOVX C,^D8              ; octal output for all version components
       NOUT%
        ERCAL FATAL
       LOAD B,VI%MIN,EVEC+2    ; get minor version
       IFN. B                  ; ignore if no minor version
         MOVX A,"."            ; output delimiting dot
         PBOUT%
         MOVX A,.PRIOU         ; now output the minor version
         NOUT%
          ERCAL FATAL
       ENDIF.
       LOAD B,VI%EDN,EVEC+2    ; get edit version
       IFN. B                  ; ignore if no edit version
         MOVX A,.CHLPR         ; edit delimiter
         PBOUT%
         TMNE VI%DEC,EVEC+2    ; decimal version?
          MOVX C,^D10          ; yes, use decimal radix
         MOVX A,.PRIOU         ; now output the edit version
         NOUT%
          ERCAL FATAL
         MOVX A,.CHRPR         ; edit close delimiter
         PBOUT%
       ENDIF.
       LOAD B,VI%WHO,EVEC+2    ; get who last edited
       IFN. B                  ; ignore if last edited at DEC
         MOVX A,"-"            ; output delimiting hyphen
         PBOUT%
         MOVX A,.PRIOU         ; now output the who version
         NOUT%
          ERCAL FATAL
       ENDIF.
       TMSG < at >
       MOVX A,.PRIOU           ; output date/time
       SETO B,                 ; time now
       MOVX C,OT%DAY!OT%SPA!OT%TMZ!OT%SCL!OT%822 ; standard date/time
       ODTIM%
        ERCAL FATAL
      SUBTTL Command loop

       DO.
         MOVE P,[IOWD PDLLEN,PDL] ; re-init stack context
         CALL CRLF             ; terminate reply with CRLF
         MOVNI A,TIMOCT        ; reset timeout count
         MOVEM A,TIMOUT
         CALL QCHECK           ; do a quick check
          NOP
         SETZM CMDBUF          ; clear out old crud in CMDBUF
         MOVE A,[CMDBUF,,CMDBUF+1]
         BLT A,CMDBUF+<TXTLEN/5>
         HRROI B,CMDBUF        ; pointer to command buffer
         MOVX C,TXTLEN-1       ; up to this many characters
         CALL GETCMD           ; get command
          LOOP.                ; error
         MOVE D,[POINT 7,CMDBUF]
         SETZM TAGCNT          ; init tag count
         DO.                   ; search for end of tag
           AOS TAGCNT          ; bump tag count
           ILDB A,D
           CAIE A,.CHSPC
            JUMPN A,TOP.
         ENDDO.
         IFE. A
           TMSG <* BAD Missing tag: >
           CALL DMPCOM
           LOOP.
         ENDIF.
         MOVSI C,-CMDTBL       ; length of command table
         DO.
           HLRO A,CMDTAB(C)    ; point to command string
           MOVE B,D            ; point to start of command
           STCMP%              ; compare strings
           IFN. A              ; found it?
             IFXN. A,SC%SUB    ; if subset
               ILDB A,B        ; get delimiting byte
               CAIN A,.CHSPC   ; was it a space?
                EXIT.          ; won, argument forthcoming
             ENDIF.
             AOBJN C,TOP.      ; try next command
           ENDIF.
         ENDDO.
         HRRO C,CMDTAB(C)      ; get routine address
         CALL (C)              ; dispatch to it
         LOOP.                 ; do next command
       ENDDO.

; Get command (or command continuation)
; Accepts: B/ pointer to buffer
;          C/ number of available bytes
;       CALL GETCMD
; Returns: +1 Error
;          +2 Success

GETCMD: SAVEAC <A,B,C,D>
       MOVX A,.PRIIN           ; from primary input
       MOVX D,.CHCRT           ; terminate on carriage return
       SIN%                    ; read a command
        ERJMP INPEOF           ; finish up on error
       IFE. C                  ; if count unsatisfied, must have seen CR
         LDB A,B               ; get last byte
         CAIN A,.CHCRT         ; was it a CR?
       ANSKP.
         TMSG <* BAD Line too long: >
         CALLRET DMPCOM
       ENDIF.
       PBIN%                   ; get expected LF
        ERJMP INPEOF           ; finish up on error
       CAIN A,.CHLFD           ; was it a line feed?
       IFSKP.
         MOVE B,A              ; copy loser
         TMSG <* BAD Line does not end with CRLF: >
         MOVX A,.PRIOU         ; output the loser
         MOVX C,^D8            ; in octal
         NOUT%
          ERCAL FATAL
         TMSG < >
         CALLRET DMPCOM
       ENDIF.
       SETZ A,                 ; make command null-terminated
       DPB A,B
       MOVEM C,CMDCNT          ; save number of free characters
       RETSKP
      SUBTTL Command table and dispatch

DEFINE COMMANDS <
       CMD NOOP
       CMD LOGIN
       CMD LOGOUT
       CMD FIND
       CMD SELECT
       CMD BBOARD
       CMD CHECK
       CMD EXPUNGE
       CMD COPY
       CMD FETCH
       CMD STORE
       CMD SEARCH
       CMD VERSION
>;DEFINE COMMANDS

DEFINE CMD (CM) <[ASCIZ/'CM'/],,.'CM>

CMDTAB: COMMANDS                ; command names
CMDTBL==.-CMDTAB
       BADCOM
      SUBTTL Command service routines

; NOOP - no-operation

NOOP:   TAGMSG <OK No-op accepted>
       RET


; VERSION - set protocol version

VERSI:  STKVAR <<VERSIO,<<ARGLEN/5>+1>>>
       HRROI A,VERSIO          ; copy version
       MOVX C,ARGLEN+1         ; bounded by this many characters
       CALL ARGCPY
        RET
       JUMPN B,BADARG          ; no arguments after this
       HRROI A,VERSIO          ; parse version
       MOVX C,^D10             ; in decimal
       NIN%
        ERJMP SYNERR
       LDB A,A                 ; sniff at terminator
       CAIE A,"."              ; in case this is given
        JUMPN A,SYNERR         ; barf if non-null
       JUMPLE B,SYNERR         ; versions .LE. 0 are bad
       CAIGE B,4               ; versions .GE. 4 are unimplemented
       IFSKP.
         TAGMSG <NO Unsupported version>
         RET
       ENDIF.
       TAGMSG <OK Version accepted>
       RET

; LOGIN - log in to mail service

LOGIN:  STKVAR <<ACCBLK,.ACJOB+1>,<USRNAM,<<ARGLEN/5>+1>>,<PASSWD,<<ARGLEN/5>+1>>>
       IFQN. F%LOG             ; make sure not doing this twice
         TAGMSG <NO Already logged in>
         RET
       ENDIF.
       JUMPE A,MISARG          ; error if no username
       HRROI A,USRNAM          ; copy user name string
       MOVX C,ARGLEN+1         ; bounded by this many characters
       CALL ARGCPY
        RET
       JUMPE B,MISARG          ; error if no password
       HRROI A,PASSWD          ; copy password string
       MOVX C,ARGLEN+1         ; bounded by this many characters
       CALL ARGCPY
        RET
       JUMPN B,BADARG          ; error if subsequent argument
       MOVX A,RC%EMO           ; require exact match
       HRROI B,USRNAM
       RCUSR%                  ; parse user name string
       IFJER.
         TAGMSG <NO Error in user name>
         CALLRET ERROUT
       ENDIF.
       IFXN. A,RC%NOM!RC%AMB   ; bogus name?
         TAGMSG <NO Invalid user name>
         RET
       ENDIF.
       MOVEM C,LGUSRN          ; save login user number
       SETZ A,                 ; get PS: directory of user in C
       MOVE B,LGUSRN
       RCDIR%
        ERCAL FATAL            ; can't fail
       MOVEM C,LGDIRN          ; save login directory

; Now try to log in

       SKIPN MYUSRN            ; is job already logged in?
       IFSKP.
         MOVEM C,.ACDIR+ACCBLK ; directory number to check
         HRROI C,PASSWD        ; password
         MOVEM C,.ACPSW+ACCBLK
         SETOM .ACJOB+ACCBLK   ; this job
         MOVX A,AC%PWD!.ACJOB+1 ; validate password
         XMOVEI B,ACCBLK
         ACCES%
         IFJER.
           AOSGE LOGCNT        ; count up another failing login attempt
           IFSKP.
             TAGMSG <NO Too many login failures, go away>
             JRST IMPERR
           ENDIF.
           TAGMSG <NO Login failed>
           CALLRET ERROUT
         ENDIF.
       ELSE.
         MOVE A,LGUSRN         ; user number to log in as
         HRROI B,PASSWD        ; password
         SETZ C,               ; account
         LOGIN%                ; do the login
         IFJER.
           AOSGE LOGCNT        ; count up another failing login attempt
           IFSKP.
             TAGMSG <NO Too many login failures, go away>
             JRST IMPERR
           ENDIF.
           TAGMSG <NO Login failed>
           CALLRET ERROUT
         ENDIF.
         MOVX A,.FHSLF         ; get my capabilities
         RPCAP%
         IOR C,B               ; enable as many capabilities as we can
         EPCAP%
          ERJMP .+1            ; ignore possible ACJ ITRAP
         MOVE A,LGUSRN         ; we're now logged in
         MOVEM A,MYUSRN        ; so note that fact
       ENDIF.

; Job logged in, report success

       TQO F%LOG               ; flag logged in
       TAGMSG <OK User >
       HRROI A,LGUSRS          ; make login user string
       MOVE B,LGUSRN
       DIRST%
        ERCAL FATAL
       HRROI A,LGUSRS          ; output user name
       PSOUT%
       TMSG < logged in at >
       MOVX A,.PRIOU           ; output date/time
       SETO B,                 ; time now
       MOVX C,OT%DAY!OT%SPA!OT%TMZ!OT%SCL!OT%822 ; standard date/time
       ODTIM%
        ERCAL FATAL
       TMSG <, job >
       MOVX A,.PRIOU           ; output job number
       MOVE B,MYJOBN
       MOVX C,^D10             ; in decimal
       NOUT%
        ERCAL FATAL
       RET

       ENDSV.

; LOGOUT - log out of mail service

LOGOU:  JUMPN A,BADARG          ; must not have an argument
       TMSG <* BYE DEC-20 IMAP server terminating connection
>
       TAGMSG <OK >            ; start acknowledgement
       HRROI A,LCLHST          ; output our host name
       PSOUT%
       TMSG < Interactive Mail Access Protocol server logout>
IMPERR: CALL CRLF
INPEOF: CALL CLSMBX             ; close off mailbox
       CALL HANGUP             ; hang up the connection
       JRST MAPSER             ; restart program

HANGUP: MOVX A,.PRIOU           ; wait until the output happens
       DOBE%
        ERJMP .+1
       IFQN. F%NVT             ; NVT server?
         DTACH%                ; detach the job to prevent "Killed..." message
          ERJMP .+1
         SETO A,               ; now log myself out
         LGOUT%
          ERJMP .+1
       ENDIF.
       HALTF%                  ; stop
       RET

; FIND - file mailbox/bulletin board names

FIND:   JE F%LOG,,NOTLOG        ; must log in first
       JUMPE A,MISARG          ; must have an argument
       STKVAR <FNDJFN,TMPPTR,<CHKBLK,.CKAUD+1>,<GTJBLK,.GJJFN+1>,<MBXNAM,<<ARGLEN/5>+1>>,<FILBUF,^D60>>
       HRROI A,MBXNAM          ; copy argument type
       MOVX C,ARGLEN+1         ; bounded by this many characters
       CALL ARGCPY
        RET
       JUMPE B,MISARG          ; must have another argument
       MOVEM B,TMPPTR
       HRROI A,MBXNAM          ; see what type it is
       HRROI B,[ASCIZ/MAILBOXES/] ; try mailboxes first
       STCMP%
       IFN. A                  ; if no match
         HRROI A,MBXNAM        ; try BBoards
         HRROI B,[ASCIZ/BBOARDS/]
         STCMP%                ; well?
         JUMPN A,BADCOM        ; sorry
         TQO F%BBD             ; hunt through BBoards
       ELSE.
         TQZ F%BBD             ; mailbox
       ENDIF.
       HRROI A,MBXNAM          ; copy mailbox
       MOVE B,TMPPTR
       MOVX C,ARGLEN+1         ; bounded by this many characters
       CALL ARGCPY
        RET
       JUMPN B,BADARG          ; no arguments after this

;  Get file, using POBOX:<loginuser>.TXT as default to user's argument for
; FIND MAILBOXES command and POBOX:<BBOARD>{arg}.TXT for FIND BBOARDS command

       IFQN. F%BBD             ; BBOARD command?
         HRROI A,FILBUF        ; yes, only allow name
         HRROI B,POBOX         ; fill in device name
         SETZ C,
         SOUT%
         HRROI B,[ASCIZ/:</]   ; delimit
         SOUT%
         HRROI B,BBOARD        ; fill in directory name
         SOUT%
         MOVX B,.CHRAB         ; delimit
         IDPB B,A
         HRROI B,MBXNAM        ; fill in filename
         SOUT%
         MOVX B,"."            ; delimit
         IDPB B,A
         HRROI B,TXT           ; fill in extension
         SOUT%
         HRROI B,[ASCIZ/.1/]   ; and generation
         SOUT%
         MOVX A,GJ%OLD!GJ%IFG!GJ%SHT ; require extant file, wildcards, short
         HRROI B,FILBUF
       ELSE.
         MOVX A,GJ%OLD!GJ%IFG!1 ; require extant file, wildcards, gen 1
         MOVEM A,.GJGEN+GTJBLK
         MOVE A,[.NULIO,,.NULIO] ; only use the string
         MOVEM A,.GJSRC+GTJBLK
         HRROI A,POBOX         ; default device
         MOVEM A,.GJDEV+GTJBLK
         HRROI A,LGUSRS        ; will fill this in
         MOVEM A,.GJDIR+GTJBLK
         SETZM .GJNAM+GTJBLK   ; no default filename
         HRROI A,TXT           ; default extension
         MOVEM A,.GJEXT+GTJBLK
         SETZM .GJPRO+GTJBLK   ; no special default protection
         SETZM .GJACT+GTJBLK   ; no special default account
         SETZM .GJJFN+GTJBLK   ; no special JFN
         MOVEI A,GTJBLK        ; long form GTJFN%
         HRROI B,MBXNAM        ; user's argument
       ENDIF.
       GTJFN%
       IFJER.
         TAGMSG <NO Can't FIND anything>
         CALLRET ERROUT
       ENDIF.

; Have JFN, validate access and report it if OK

       IFXN. A,GJ%DEV!GJ%UNT!GJ%DIR ; check for possible crackers...
         HRRZ A,FNDJFN         ; flush the JFN
         RLJFN%
          ERJMP .+1
         TAGMSG <NO Can't FIND such a mailbox>
         RET
       ENDIF.
       MOVEM A,FNDJFN
       MOVE B,[OWGP. 7,OUTBFR] ; initialize buffer pointer
       MOVEM B,TMPPTR
       DO.
         HRRZS A               ; only want JFN
         MOVX B,.CKADL         ; check list access
         MOVEM B,.CKAAC+CHKBLK
         MOVE B,LGUSRN         ; our user number
         MOVEM B,.CKALD+CHKBLK
         MOVE B,LGDIRN         ; login directory is connected
         MOVEM B,.CKACD+CHKBLK
         SETZM .CKAEC+CHKBLK   ; no capabilities enabled
         MOVEM A,.CKAUD+CHKBLK ; JFN of file to check
         MOVX A,CK%JFN!.CKAUD+1 ; validate access to file given JFN
         XMOVEI B,CHKBLK
         CHKAC%                ; validate access
          ERCAL FATAL
         IFN. A                ; access ok?
           MOVE A,TMPPTR       ; yes, get buffer pointer
           IFQN. F%BBD         ; which sort of FIND?
             HRROI B,[ASCIZ/* BBOARD /]
             CALL BFSOUT
             MOVX C,<FLD .JSAOF,JS%NAM> ; only output filename
           ELSE.
             HRROI B,[ASCIZ/* MAILBOX /]
             CALL BFSOUT
             SETZ C,           ; output full path name
           ENDIF.
           HRRZ B,FNDJFN       ; this file
           JFNS%               ; output name
           HRROI B,[ASCIZ/
/]
           CALL BFSOUT
           MOVEM A,TMPPTR      ; save updated pointer
         ENDIF.
         MOVE A,FNDJFN         ; try for next match
         GNJFN%
         IFNJE. <LOOP.>        ; found one, go do it
       ENDDO.

; Return the results to the user

       SETZ C,                 ; tie off buffer
       IDPB C,TMPPTR
       MOVX A,.PRIOU           ; now blat the buffer
       MOVE B,[OWGP. 7,OUTBFR]
       SOUT%
        ERJMP .+1
       HRRZ A,FNDJFN           ; flush the JFN
       RLJFN%
        ERJMP .+1
       TAGMSG <OK FIND completed>
       RET

       ENDSV.

; SELECT - select a mailbox

SELEC:  TQZA F%BBD              ; not BBOARD command
BBOAR:   TQO F%BBD              ; BBOARD command
       JE F%LOG,,NOTLOG        ; must log in first
       JUMPE A,MISARG          ; must have an argument
       STKVAR <<CHKBLK,.CKAUD+1>,INIJFN,<GTJBLK,.GJJFN+1>,<MBXNAM,<<ARGLEN/5>+1>>,<FILBUF,^D60>>
       HRROI A,MBXNAM          ; copy mailbox
       MOVX C,ARGLEN+1         ; bounded by this many characters
       CALL ARGCPY
        RET
       JUMPN B,BADARG          ; no arguments after this
       IFQE. F%BBD             ; BBOARD command?
         HRROI A,MBXNAM        ; compare user's argument
         HRROI B,INBOX         ;  with special name INBOX
         STCMP%
       ANDE. A                 ; if user wants the INBOX
         MOVE A,MAIL           ; he really wants MAIL.TXT
         MOVEM A,MBXNAM
       ENDIF.
       SKIPE MBXJFN            ; have a mailbox JFN open already?
        CALL CLSMBX            ; yes, close it

;  Get file, using POBOX:<loginuser>.TXT as default to user's argument for
; SELECT command and POBOX:<BBOARD>.TXT for BBOARD command

       MOVX A,GJ%OLD!1         ; require extant file, default gen 1
       MOVEM A,.GJGEN+GTJBLK
       MOVE A,[.NULIO,,.NULIO] ; only use the string
       MOVEM A,.GJSRC+GTJBLK
       HRROI A,POBOX           ; default device
       MOVEM A,.GJDEV+GTJBLK
       TQNE F%BBD              ; BBOARD command?
        SKIPA A,[-1,,BBOARD]
         HRROI A,LGUSRS        ; will fill this in
       MOVEM A,.GJDIR+GTJBLK
       SETZM .GJNAM+GTJBLK     ; no default filename
       HRROI A,TXT             ; default extension
       MOVEM A,.GJEXT+GTJBLK
       SETZM .GJPRO+GTJBLK     ; no special default protection
       SETZM .GJACT+GTJBLK     ; no special default account
       SETZM .GJJFN+GTJBLK     ; no special JFN
       MOVEI A,GTJBLK          ; long form GTJFN%
       HRROI B,MBXNAM          ; user's argument
       GTJFN%
       IFJER.
         SETZRO .RHALF,.GJGEN+GTJBLK ; try any generation
         MOVEI A,GTJBLK        ; and try the GTJFN again
         HRROI B,MBXNAM
         GTJFN%
         IFJER.
           TAGMSG <NO Can't get mailbox>
           CALLRET ERROUT
         ENDIF.
       ENDIF.

; Have file, validate access

       MOVEM A,MBXJFN
       MOVX B,.CKARD           ; first check read access
       MOVEM B,.CKAAC+CHKBLK
       MOVE B,LGUSRN           ; our user number
       MOVEM B,.CKALD+CHKBLK
       MOVE B,LGDIRN           ; login directory is connected
       MOVEM B,.CKACD+CHKBLK
       SETZM .CKAEC+CHKBLK     ; no capabilities enabled
       MOVEM A,.CKAUD+CHKBLK   ; JFN of file to check
       MOVX A,CK%JFN!.CKAUD+1  ; validate access to file given JFN
       XMOVEI B,CHKBLK
       CHKAC%                  ; validate access
        ERCAL FATAL
       IFE. A                  ; access ok?
         TAGMSG <NO Can't access mailbox>
         MOVE A,MBXJFN         ; flush the JFN
         RLJFN%
          ERJMP .+1
         SETZM MBXJFN          ; and note no file open
         RET
       ENDIF.
       MOVX A,.CKAWR           ; now see if write access
       MOVEM A,.CKAAC+CHKBLK
       MOVX A,CK%JFN!.CKAUD+1  ; validate access to file given JFN
       XMOVEI B,CHKBLK
       CHKAC%                  ; validate access
        ERCAL FATAL
       SKIPN A
        TQOA F%RON             ; read-only file
         TQZ F%RON             ; read/write file

; Access OK, open file and seize the lock

       MOVE A,MBXJFN
       MOVX B,<1,,.FBREF>      ; get last file read TAD
       XMOVEI C,MBXRDT         ; into this location
       GTFDB%
        ERCAL FATAL
       MOVX B,<<FLD 7,OF%BSZ>!OF%RD> ; now open for read
       OPENF%
       IFJER.
         TAGMSG <NO Can't open mailbox>
         CALL ERROUT
         MOVE A,MBXJFN         ; flush the JFN
         RLJFN%
          ERJMP .+1
         SETZM MBXJFN          ; and note no file open
         RET
       ENDIF.
       MOVX A,<ENQBLS,,ENQBLL> ; number of locks,,block length
       MOVEM A,ENQBLK+.ENQLN
       MOVX A,REQID            ; PSI channel,,request ID
       MOVEM A,ENQBLK+.ENQID
       MOVX A,EN%SHR!EN%BLN    ; shared access, no level #'s
       HRR A,MBXJFN            ; this file
       MOVEM A,ENQBLK+.ENQLV
       HRROI A,[ASCIZ/Mail expunge interlock/] ; starting pointer
       MOVEM A,ENQBLK+.ENQUC   ; ENQ% lock string
       SETZM ENQBLK+.ENQRS     ; resources/group
       SETZM ENQBLK+.ENQMS     ; resource mask block
       MOVX A,.ENQBL           ; try and get lock, but don't wait
       XMOVEI B,ENQBLK
       ENQ%
        ERCAL FATAL

; If file has an index, grab it and get its date

       HRROI A,FILBUF          ; create POBOX:<user>file-name.IDX
       MOVE B,MBXJFN
       MOVX C,<<FLD .JSAOF,JS%DEV>!<FLD .JSAOF,JS%DIR>!<FLD .JSAOF,JS%NAM>!JS%PAF>
       JFNS%                   ; dump it
       HRROI B,[ASCIZ/.IDX/]   ; output index's extension
       SETZ C,
       SOUT%                   ; copy the .IDX
       MOVX A,GJ%OLD!GJ%SHT    ; see if there's an index file
       HRROI B,FILBUF
       GTJFN%
       IFNJE.
         MOVEM A,IDXJFN
         MOVX B,OF%RD!OF%WR!OF%THW ; now open it, thawed
         OPENF%
         IFJER.
           MOVE A,IDXJFN       ; can't open init, flush JFN
           RLJFN%
            ERJMP .+1
         ELSE.
           HRRZ A,LGUSRN       ; get RH of user number
           ADDI A,UXADR        ; plus well-known offset of BBoard poop
           IDIVI A,1000        ; A/ page number, B/ address in page
           MOVEM B,IDXADR      ; save index address for later
           HRL A,IDXJFN        ; A/ JFN,,page #
           MOVE B,LODIPG       ; B/ process,,page #
           MOVX C,PM%RD!PM%WR  ; want read/write access
           PMAP%               ; seize access
            ERCAL FATAL
           XMOVEI A,INDEX      ; make address pointer absolute
           ADDM A,IDXADR
           MOVE A,@IDXADR      ; get index last read TAD
           IFNJE.
             MOVEM A,MBXRDT    ; use as last file read TAD
           ELSE.
             SETZM IDXADR      ; ugh
           ENDIF.
         ENDIF.
       ENDIF.

; File opened, now attempt to find init file for it

       HRROI A,MBXNAM          ; get actual filename
       MOVE B,MBXJFN           ; from JFN
       MOVX C,<FLD .JSAOF,JS%NAM>
       JFNS%
        ERCAL FATAL
       HRROI A,MBXNAM          ; are we reading our MAIL.TXT?
       HRROI B,[ASCIZ/MAIL/]
       STCMP%
       IFN. A                  ; if user doesn't wants the INBOX
         HRROI A,FILBUF        ; create POBOX:<directory>file-name.MM-INIT
         MOVE B,MBXJFN
         MOVX C,<<FLD .JSAOF,JS%DEV>!<FLD .JSAOF,JS%DIR>!<FLD .JSAOF,JS%NAM>!JS%PAF>
         JFNS%                 ; dump it
         HRROI B,[ASCIZ/.MM-INIT/] ; output init's extension
         SETZ C,
         SOUT%                 ; copy the .INIT
         IDPB C,A              ; tie off name with null
         MOVX A,GJ%OLD!GJ%SHT  ; see if there's an init file
         HRROI B,FILBUF
         GTJFN%
       ANNJE.                  ; this mailbox has a special init
       ELSE.
         HRROI A,FILBUF        ; MAIL.TXT or special init fails
         MOVE B,MBXJFN         ; create POBOX:<directory>MM.INIT
         MOVX C,<<FLD .JSAOF,JS%DEV>!<FLD .JSAOF,JS%DIR>!JS%PAF>
         JFNS%                 ; dump it
         HRROI B,[ASCIZ/MM.INIT/] ; output init's name and extension
         SETZ C,
         SOUT%
         IDPB C,A              ; tie off name with null
         MOVX A,GJ%OLD!GJ%SHT  ; see if there's an init file
         HRROI B,FILBUF
         GTJFN%
          SETZ A,              ; no INIT file at all
       ENDIF.
       IFN. A                  ; got an INIT file?
         MOVEM A,INIJFN
         MOVX B,<<FLD 7,OF%BSZ>!OF%RD> ; now open it
         OPENF%
         IFJER.
           MOVE A,INIJFN       ; can't open init, flush JFN
           RLJFN%
            ERJMP .+1
         ELSE.

; Have an init file to parse, do so

           DO.
             MOVE A,INIJFN     ; reload JFN
             HRROI B,FLGBUF    ; read in an init file line
             MOVX C,TXTLEN-1   ; up to this many bytes
             MOVX D,.CHCRT     ; terminate on linefeed
             SIN%              ; read a line
              ERJMP ENDLP.     ; finish up
             IFE. C
               LDB C,B         ; get last byte
               CAIE C,.CHCRT   ; was it a CR?
                EXIT.          ; no, line too long, punt this init
             ENDIF.
             SETZ C,           ; null-terminate line
             DPB C,B
             BIN%              ; get expected LF
              ERJMP ENDLP.
             CAIE B,.CHLFD     ; validate it
              EXIT.            ; init file bogus
             HRROI A,[ASCIZ/KEYWORDS/] ; see if KEYWORDS line found
             HRROI B,FLGBUF
             STCMP%
             JXN A,SC%LSS!SC%GTR,TOP. ; line not found
             ILDB A,B          ; get delimiting byte
             CAIE A,.CHSPC     ; expected space?
              EXIT.            ; no -- lose
             SETZ C,           ; start with flag 0
             DO.
               MOVEM B,FLGTAB(C) ; save pointer to flag 0
               DO.
                 ILDB A,B      ; get next byte
                 CAIE A,","    ; if not comma or null then uninteresting
                  JUMPN A,TOP.
               ENDDO.
               JUMPE A,ENDLP.  ; if a null then we're done
               SETZ A,         ; else tie off previous flag
               DPB A,B
               SKIPN FLGTAB+1(C) ; make sure not overwriting system flags
                AOJA C,TOP.    ; and record start of new flag
             ENDDO.
           ENDDO.
           MOVE A,INIJFN       ; now close init JFN
           CLOSF%
            ERJMP .+1
         ENDIF.
       ENDIF.

; Output list of flags

       TMSG <* FLAGS (>
       MOVSI B,-^D36           ; maximum number of flags
       DO.
         SKIPN A,FLGTAB(B)     ; get name of this flag if any
          AOBJN B,TOP.         ; none here, try next (note can't fail here)
         PSOUT%                ; have one, output it
         AOBJP B,ENDLP.        ; done if last flag
         MOVX A,.CHSPC         ; delimit
         PBOUT%
         LOOP.                 ; do next flag
       ENDDO.
       TMSG <)
>

; Map the file in and parse it

       MOVE A,MBXJFN           ; get JFN
       CALL FILSIZ             ; return file size
       MOVEM A,MBXBSZ          ; save number of characters
       CALL GETMBX             ; finally get the mailbox
       IFSKP.
         TAGMSG <OK >
         IFQN. F%RON           ; read-only file?
           TMSG <[READ-ONLY] for >
         ELSE.
           TMSG <[READ-WRITE] for >
         ENDIF.
         MOVX A,.PRIOU         ; output filename
         MOVE B,MBXJFN
         MOVX C,JS%SPC         ; entire spec please
         JFNS%
          ERCAL FATAL
         SKIPN IDXJFN          ; indexed file?
       ANSKP.
         TMSG <, mailbox is indexed>
       ENDIF.
       RET

       ENDSV.

; Message flags

DEFINE FLAG (STRING) <
M%'STRING==:1B<NKYFLG+<.-FLGINI>>
-1,,[ASCIZ/\'STRING'/]
>;DEFINE FLAG

FLGINI: FLAG XXXX
       FLAG YYYY
       FLAG Answered
       FLAG Flagged
       FLAG Deleted
       FLAG Seen
IFN <NFLINI-<.-FLGINI>>,<.FATAL Wrong number of initial flags>

; CHECK - check for new messages in mailbox

CHECK:  JE F%LOG,,NOTLOG        ; must log in first
       JUMPN A,BADARG          ; must not have an argument
       SKIPN MBXJFN            ; must have a mailbox open
        JRST NOMBX
       CALL FCHECK             ; do a full check
       IFSKP. <TAGMSG <OK Check completed>>
       RET

; FCHECK is called when the entire mail file should be reparsed
; QCHECK is called when nothing should be done if the file size is the same

FCHECK: TDZA A,A                ; want a full check
QCHECK:  SETO A,                ; want a quick check
       STKVAR <FSTCHK>
       MOVEM A,FSTCHK          ; save fast check flag
       SKIPN A,MBXJFN          ; get JFN
        RETSKP                 ; return immediately if none
       CALL FILSIZ             ; return file size
       SKIPE FSTCHK            ; want a fast check?
        CAME A,MBXBSZ          ; yes, return now if size unchanged
       IFSKP. <RETSKP>
       CAML A,MBXBSZ           ; did it shrink?
       IFSKP.
         TAGMSG <BYE Message file byte size appears to have shrunk>
         CALL CLSMBX           ; close file off
         JRST IMPERR
       ENDIF.
       MOVEM A,MBXBSZ          ; save number of characters
       CALLRET GETMBX

       ENDSV.

; EXPUNGE - remove deleted messages from mailbox

EXPUN:  JE F%LOG,,NOTLOG        ; must log in first
       JUMPN A,BADARG          ; must not have an argument
       SKIPN MBXJFN            ; must have a mailbox open
        JRST NOMBX
       IFQN. F%RON             ; read-only?
         TAGMSG <OK EXPUNGE ignored for read-only file>
         RET
       ENDIF.
       ACVAR <M,Q0,Q1,Q2,Q3,Q4,Q5>
       TRVAR <MBXJF2,EXPMSG>

; See if there are any deleted messages to expunge

       SKIPE A,MBXMGS          ; get number of messages
       IFSKP.
         TAGMSG <OK Mail file empty> ; tell user and go away
         RET
       ENDIF.
       SETZ M,                 ; start check with first message
       DO.
         JN M%DELE,MSGFLG(M),ENDLP. ; if found deleted message, must expunge
         ADDI M,MSGLEN         ; else bump to next index
         SOJG A,TOP.           ; and count down another message
         TAGMSG <OK No messages deleted, so no update needed>
         RET                   ; nothing to do then
       ENDDO.

; Some deleted messages exist, get the file for write and exclusive access

       CALL MBXWRT             ; open mailbox for write
        RET                    ; can't get it for write
       MOVEM A,MBXJF2          ; save JFN we got
       SETZM EXPMSG            ; number of messages expunged
       MOVX A,EN%SHR           ; turn off share bit
       ANDCAM A,ENQBLK+.ENQLV
       MOVX A,.ENQMA           ; change our lock to be exclusive
       XMOVEI B,ENQBLK
       ENQ%
       IFJER.
         TAGMSG <NO Mailbox in use by another process, try again later>
         RET
       ENDIF.
       CALL FCHECK             ; do a full check first
        RET
       HRRZ A,MBXJFN           ; page 0,,JFN
       FFFFP%                  ; find size of contiguous file pages
        ERCAL FATAL
       LDB C,[POINT 9,A,26]    ; get number of sections of file
       TRNE A,777              ; any fractional section?
        ADDI C,1               ; plus 1 for fractional section
       HRLZ A,MBXJF2           ; source JFN,,start at section 0
       MOVE B,[.FHSLF,,MBXSEC] ; our process,,mailbox section
       TXO C,SM%RD!SM%WR       ; read/write access,,this many sections
       SMAP%
        ERCAL FATAL

; Go through mail file, blatting subsequent messages on top of deleted ones

       MOVE A,[OWGP. 7,OUTBFR] ; initialize buffer pointer
       HRLO D,MBXMGS           ; get number of messages,,-1
       SETCA D,                ; -<msgs+1>,,0
       AOBJP D,.+1             ; -msgs,,1
       SETZ M,                 ; start check with first message
       MOVE Q4,MSGIPT(M)       ; initial destination pointer is first message
       SETZ Q5,                ; with no GBP stuff
       DO.
         IFQN. M%DELE,MSGFLG(M) ; this message deleted?
           HRROI B,[ASCIZ/* /] ; mark unsolicited
           CALL BFSOUT
           MOVEI B,(D)         ; output expunged message #
           SUB B,EXPMSG        ; offset by the number already done
           CALL BFNOUT
           HRROI B,[ASCIZ/ EXPUNGE
/]
           CALL BFSOUT
           AOS EXPMSG          ; bump the expunged messages count
           SOS MBXMGS          ; and decrement the current messages count
         ELSE.
           SKIPE EXPMSG        ; anything expunged yet?
           IFSKP.
             MOVE Q4,MSGIPT+MSGLEN(M) ; no, destination pointer is next message
             SETZ Q5,          ; with no GBP stuff
           ELSE.
             MOVE Q1,MSGIPT(M) ; init source with internal header of this message
             SETZ Q2,          ; clear any previous GBP stuff
             DO.
               ILDB C,Q1       ; copy the internal header
               IDPB C,Q4
               CAIE C,.CHLFD   ; got to the LF yet?
                LOOP.          ; no, continue copy
             ENDDO.
             MOVE Q0,MSGSIZ(M) ; source copy of bytes to copy
             MOVE Q3,Q0        ; destination count of byte to copy
             EXTEND Q0,[MOVSLJ ; blat the string
                        0]     ; with a zero fill
              CALL MOVBOG      ; this cannot happen
           ENDIF.
         ENDIF.
         ADDI M,MSGLEN         ; bump to next index
         AOBJN D,TOP.          ; and count down another message
       ENDDO.
       SETZ C,                 ; tie off status buffer
       IDPB C,A
       MOVX A,.PRIOU           ; now send status buffer to client
       MOVE B,[OWGP. 7,OUTBFR]
       SOUTR%
        ERJMP .+1

; Compute new byte count for mail file

       IFN. Q5                 ; got a GBP address?
         TLC Q4,000740         ; clear bits for "global POINT 7,0,35"
         TXNE Q4,<MASKB 6,35>  ; make sure no bozo bits set
          CALL MOVBOG
         LDB A,[POINT 6,Q4,5]  ; get position
         IDIVI A,7             ; divide by bytesize
         CAIG A,OWG7SZ
          CAIE B,1             ; is remainder correct?
           CALL MOVBOG         ; foo
         MOVE Q4,OWG7TB(A)     ; get correct pointer
         DPB Q5,[POINT 30,Q4,35] ; fill in GBP address
       ENDIF.
       LDB C,[POINT 30,Q4,35]  ; get final destination address
       LDB D,[POINT 30,MSGIPT,35] ; get initial destination address
       SUB C,D                 ; get number of words difference
       IMULI C,5               ; convert to characters
       LDB D,[POINT 3,MSGIPT,5] ; subtract initial position from count
       SUB C,D
       LDB D,[POINT 3,Q4,5]    ; add final position to count
       ADD C,D
       MOVEM C,MBXBSZ          ; save new file size

; Set new file byte count and byte size

       MOVE A,MBXJF2           ; get the write JFN
       HRLI A,.FBBYV           ; want to change file I/O poop
       TXO A,CF%NUD            ; don't update the disk yet
       MOVX B,FB%BSZ           ; now change bytesize
       MOVX C,<FLD 7,FB%BSZ>   ; to 7-bit bytes
       CHFDB%
        ERCAL FATAL
       HRLI A,.FBSIZ           ; want to change file size
       TXO A,CF%NUD            ; don't update the disk yet
       SETO B,                 ; change all bits
       MOVE C,MBXBSZ           ; get new file size
       CHFDB%                  ; set the new size
        ERCAL FATAL

;  Check for and delete extraneous mail file pages.  Note that since page
; numbers are zero-origin, the size of the file in pages is the first page
; number to delete.

       IDIVI C,^D<5*512>       ; get number of pages in mailbox
       SKIPE D                 ; is there a fractional page?
        ADDI C,1               ; yes, add that in
       HRRZ A,MBXJF2           ; see where the guy ends
       FFFFP%
        ERCAL FATAL
       HRRZS A                 ; first page that doesn't exist
       CAMG A,C                ; file has more pages than we need?
       IFSKP.
         HRL B,MBXJF2          ; yes, need to flush pages
         HRR B,C               ; JFN,,first page to flush
         SUBM A,C              ; # of pages to flush
         TXO C,PM%CNT          ; let monitor know we're giving it a count
         SETO A,               ; want to delete pages
         PMAP%                 ; zap!
         IFJER.
           TMSG <* BAD Unable to delete extra file pages>
           CALL ERROUT
         ENDIF.
       ENDIF.

; Report final results of expunge to client

       SKIPE MBXMGS            ; any messages left?
       IFSKP.
         MOVE A,MBXJF2         ; no, prepare to flush the file
         TXO A,DF%NRJ          ; don't flush the JFN though
         DELF%                 ; sayonara
          ERCAL FATAL
         TAGMSG <OK All messages expunged, file deleted>
       ELSE.
         CALL FCHECK           ; now do a full check
          RET
         TAGMSG <OK Expunged > ; and output confirmation
         MOVX A,.PRIOU
         MOVE B,EXPMSG
         MOVX C,^D10
         NOUT%
          ERCAL FATAL
         TMSG < messages>
       ENDIF.
       MOVX A,EN%SHR           ; turn on share bit
       IORM A,ENQBLK+.ENQLV
       MOVX A,.ENQMA           ; change the access back to shared
       XMOVEI B,ENQBLK
       ENQ%
        ERJMP .+1
       RET

       ENDTV.
       ENDAV.

; COPY - copy messages to another mailbox

COPY:   JE F%LOG,,NOTLOG        ; must log in first
       JUMPE A,MISARG          ; must have an argument
       SKIPN MBXJFN            ; must have a mailbox open
        JRST NOMBX
       TRVAR <<CHKBLK,.CKAUD+1>,CPYJFN,<GTJBLK,.GJJFN+1>,<MBXNAM,<<ARGLEN/5>+1>>>
       CALL GETSEQ             ; get message sequence
        RET                    ; failed
       JUMPE A,MISARG          ; must have a mailbox name following
       HRROI A,MBXNAM          ; copy mailbox
       MOVX C,ARGLEN+1         ; bounded by this many characters
       CALL ARGCPY
        RET
       JUMPN B,BADARG          ; no arguments after this
       HRROI A,MBXNAM          ; compare user's argument
       HRROI B,INBOX           ;  with special name INBOX
       STCMP%
       IFE. A                  ; if user wants the INBOX
         MOVE A,MAIL           ; he really wants MAIL.TXT
         MOVEM A,MBXNAM
       ENDIF.
       MOVX A,1                ; default gen 1
       MOVEM A,.GJGEN+GTJBLK
       MOVE A,[.NULIO,,.NULIO] ; only use the string
       MOVEM A,.GJSRC+GTJBLK
       HRROI A,POBOX           ; default device
       MOVEM A,.GJDEV+GTJBLK
       HRROI A,LGUSRS          ; will fill this in
       MOVEM A,.GJDIR+GTJBLK
       SETZM .GJNAM+GTJBLK     ; no default filename
       HRROI A,TXT             ; default extension
       MOVEM A,.GJEXT+GTJBLK
       SETZM .GJPRO+GTJBLK     ; no special default protection
       SETZM .GJACT+GTJBLK     ; no special default account
       SETZM .GJJFN+GTJBLK     ; no special JFN
       MOVEI A,GTJBLK          ; long form GTJFN%
       HRROI B,MBXNAM          ; user's argument
       GTJFN%
       IFJER.
         SETZRO .RHALF,.GJGEN+GTJBLK ; try any generation
         MOVEI A,GTJBLK        ; and try the GTJFN again
         HRROI B,MBXNAM
         GTJFN%
         IFJER.
           TAGMSG <NO Can't get destination mailbox>
           CALLRET ERROUT
         ENDIF.
       ENDIF.

; Verify access and open for write

       MOVEM A,CPYJFN
       MOVEM A,.CKAUD+CHKBLK   ; JFN of file to check
       MOVX B,OF%RD            ; see if file exists
       OPENF%
       IFJER.
         MOVX B,.CKACF         ; no, we need to see if we can create it
       ELSE.
         TXO A,CO%NRJ          ; close but don't release...
         CLOSF%
          ERJMP +1
         MOVX B,.CKAAP         ; see if we have append access
       ENDIF.
       MOVEM B,.CKAAC+CHKBLK
       MOVE B,LGUSRN           ; our user number
       MOVEM B,.CKALD+CHKBLK
       MOVE B,LGDIRN           ; login directory is connected
       MOVEM B,.CKACD+CHKBLK
       SETZM .CKAEC+CHKBLK     ; no capabilities enabled
       MOVX A,CK%JFN!.CKAUD+1  ; validate access to file given JFN
       XMOVEI B,CHKBLK
       CHKAC%                  ; validate access
        ERCAL FATAL
       IFE. A                  ; access ok?
         TAGMSG <NO Can't access destination mailbox>
         MOVE A,CPYJFN         ; flush the JFN
         RLJFN%
          ERJMP .+1
         SETZM CPYJFN          ; and note no file open
         RET
       ENDIF.
       MOVE A,CPYJFN
       MOVX B,<<FLD 7,OF%BSZ>!OF%APP> ; now open for append
       OPENF%
       IFJER.
         TAGMSG <NO Can't open mailbox>
         CALL ERROUT
         MOVE A,CPYJFN         ; flush the JFN
         RLJFN%
          ERJMP .+1
         RET
       ENDIF.

; Now do the copy

       HRROI A,[ASCIZ/ Copy
/]
       XMOVEI B,CPYMSG         ; set up message copy routine
       CALL SEQDSP             ; do for each sequence
       IFSKP. <TAGMSG <OK Copy completed>>
       MOVE A,CPYJFN           ; now close off the file
       CLOSF%
        ERCAL FATAL
       RET                     ; all done

; Routine to copy a single message

CPYMSG: SAVEAC <A,B,C>
       ACVAR <M>
       STKVAR <MSG>
       MOVEM B,MSG             ; save message number in case error
       MOVEI M,-1(B)           ; determine index into data structure
       IMULI M,MSGLEN
       MOVE A,CPYJFN           ; set up JFN for output
       MOVE B,MSGTAD(M)        ; now output date/time
       MOVX C,OT%TMZ
       ODTIM%
       IFNJE.
         MOVX B,","            ; output delimiter
         BOUT%
       ANNJE.
         MOVE B,MSGSIZ(M)      ; output size
         MOVX C,^D10           ; in decimal
         NOUT%
       ANNJE.
         MOVX B,";"            ; output delimiter
         BOUT%
       ANNJE.
         MOVE B,MSGFLG(M)      ; output flags
         MOVX C,<NO%LFL!NO%ZRO!NO%MAG!<FLD ^D12,NO%COL>!<FLD ^D8,NO%RDX>>
         NOUT%
       ANNJE.
         HRROI B,[ASCIZ/
/]                              ; output CRLF before message
         SETZ C,
         SOUT%
       ANNJE.
         MOVE B,MSGPTR(M)      ; from this byte
         MOVN C,MSGSIZ(M)      ; and this many bytes
         SOUT%
         RET                   ; all done
       ENDIF.
       TAGMSG <NO Unable to copy message >
       MOVX A,.PRIOU           ; output message number
       MOVE B,MSG
       MOVX C,^D10
       NOUT%
        ERCAL FATAL
       CALL ERROUT             ; output last error string
       RETSKP                  ; abort the sequence

       ENDSV.
       ENDAV.
       ENDTV.

; FETCH - fetch attributes

MAXATT==^D100                   ; lots of attributes

FETCH:  JE F%LOG,,NOTLOG        ; must log in first
       JUMPE A,MISARG          ; must have an argument
       SKIPN MBXJFN            ; must have a mailbox open
        JRST NOMBX
       STKVAR <ATTPTR,<ATTLST,MAXATT+2>>
       CALL GETSEQ             ; get message sequence
        RET                    ; failed
       JUMPE A,MISARG          ; must have an attribute following
       MOVE A,B                ; sniff at attribute
       ILDB A,A

; Parse attribute list

       CAIE A,"("              ; attribute list?
       IFSKP.
         IBP B                 ; yes, skip the open paren
         MOVE A,[TQO <F%NCL>]  ; we have a list of attributes
         MOVEM A,ATTLST
         MOVSI D,-MAXATT       ; set up pointer to attribute list
         HRRI D,1+ATTLST
         DO.
           CALL GETATT         ; get attribute
            RET                ; failed
           HLR C,(C)           ; get dispatch address
           CAIE A,.CHSPC       ; more attributes coming?
            EXIT.              ; no
           HRLI C,<(CALL)>     ; yes, make into a CALL <address> instruction
           MOVEM C,(D)         ; store the instruction
           AOBJN D,TOP.        ; get next attribute
           TAGMSG <NO Too many attributes for FETCH>
           RET
         ENDDO.
         CAIE A,")"            ; saw a close paren?
          JRST SYNERR
         MOVE A,[TQZ <F%NCL>]  ; this attribute is the last one
         MOVEM A,(D)           ; store the instruction
         HRLI C,<(CALLRET)>    ; make a CALLRET <address> instruction
         MOVEM C,1(D)          ; store as final instruction
         ILDB A,B              ; sniff past the close paren
         XMOVEI B,ATTLST       ; set up dispatch to routine we compiled

; Atomic attribute

       ELSE.
         MOVEM B,ATTPTR        ; save pointer
         HRROI A,[ASCIZ/ALL/]  ; user want all?
         STCMP%
         IFE. A                ; must be exact
           XMOVEI B,.FTALL     ; win
         ELSE.
           HRROI A,[ASCIZ/FAST/] ; no, then try for fast
           MOVE B,ATTPTR
           STCMP%
           IFE. A
             XMOVEI B,.FTFST   ; win
           ELSE.
             MOVE B,ATTPTR
             CALL GETATT       ; user probably wants a single attribute
              RET              ; failed
             HLRZ B,(C)        ; get dispatch address
             XHLLI B,
           ENDIF.
         ENDIF.
         TQZ <F%NCL>           ; make sure this is initialized
       ENDIF.
       JUMPN A,BADARG          ; must be end of arguments

; Now, do the fetching

       HRROI A,[ASCIZ/ Fetch (/]
       CALL SEQDSP             ; do per-sequence dispatch
       IFSKP. <TAGMSG <OK Fetch completed>>
       RET

       ENDSV.

; Fetch all for message in B

FTALL:  TQO <F%NCL>
       CALL .FTFLG
       CALL .FTDAT
       CALL .FTSIZ
       TQZ <F%NCL>
       CALLRET .FTENV

; Fetch all fast attributes for message in B

FTFST:  TQO <F%NCL>
       CALL .FTFLG
       CALL .FTDAT
       TQZ <F%NCL>
       CALLRET .FTSIZ

; Fetch envelope for message indexed in B

FTENV:  SAVEAC <B,C,D>
       ACVAR <M>
       MOVEI M,-1(B)           ; determine index into data structure
       IMULI M,MSGLEN
       SKIPN D,MSGENV(M)       ; get envelope block pointer
        CALL GETENV
       HRROI B,[ASCIZ/Envelope (/]
       CALL BFSOUT
       SKIPE B,ENVDAT(D)       ; get envelope date
       IFSKP.
         MOVE B,MSGTAD(M)      ; default Date
         MOVX C,""""           ; quote the string
         IDPB C,A
         MOVX C,OT%DAY!OT%SPA!OT%TMZ!OT%SCL!OT%822 ; standard date/time
         ODTIM%
          ERCAL FATAL
         HRROI B,[ASCIZ/" /]
         CALL BFSOUT
       ELSE.
         CALL BFSTR
       ENDIF.
       MOVE B,ENVSUB(D)        ; get envelope Subject
       CALL BFSTR
       MOVE B,ENVFRM(D)        ; get envelope From
       CALL BFADR
       MOVE B,ENVSDR(D)        ; get envelope Sender
       CALL BFADR
       MOVE B,ENVREP(D)        ; get envelope Reply-To
       CALL BFADR
       MOVE B,ENVTO(D)         ; get envelope To
       CALL BFADR
       MOVE B,ENVCC(D)         ; get envelope cc
       CALL BFADR
       MOVE B,ENVBCC(D)        ; get envelope bcc
       CALL BFADR
       MOVE B,ENVIRT(D)        ; get envelope In-Reply-To
       CALL BFSTR
       MOVE B,ENVMID(D)        ; get envelope Message-ID
       CALL BFSTR
       MOVEI B,")"             ; close off the envelope
       DPB B,A
       CALLRET BFCRLF

       ENDAV.

; Fetch flags for message in B

FTFLG:  SAVEAC <B,C,D>
       ACVAR <M,FLG,FLGX>      ; FLGX must be FLG+1
       MOVEI M,-1(B)           ; determine index into data structure
       IMULI M,MSGLEN
       HRROI B,[ASCIZ/Flags (/]
       CALL BFSOUT
       MOVE FLG,MSGFLG(M)      ; get message flags
       MOVE B,MSGTAD(M)        ; get date of this message
       CAMG B,MBXRDT           ; is this a recent message?
       IFSKP.
         HRROI B,[ASCIZ/\Recent/] ; yes, indicate it as such
         CALL BFSOUT
       ANDN. FLG               ; any flags set?
         MOVX B,.CHSPC         ; yes, output delimiter
         IDPB B,A
       ENDIF.
       IFN. FLG                ; any flags set?
         DO.
           JFFO FLG,.+2        ; get bit position
            EXIT.              ; last bit in this word
           SKIPE B,FLGTAB(FLGX) ; is this flag defined?
           IFSKP.
             HRROI B,[ASCIZ/\UndefinedFlag#/]
             CALL BFSOUT
             MOVE B,FLGX       ; bit to output
             CALL BFNOUT
           ELSE.
             CALL BFSOUT       ; defined flag, output it
           ENDIF.
           ANDCM FLG,BITS(FLGX) ; clear this flag
           IFN. FLG
             MOVX B,.CHSPC     ; delimit with space
             IDPB B,A
             LOOP.
           ENDIF.
         ENDDO.
       ENDIF.
       MOVEI B,")"
       IDPB B,A
       CALLRET BFCRLF

       ENDAV.

; Fetch internal date in B

FTDAT:  SAVEAC <B,C,D>
       ACVAR <M>
       MOVEI M,-1(B)           ; determine index into data structure
       IMULI M,MSGLEN
       HRROI B,[ASCIZ/InternalDate "/]
       CALL BFSOUT
       MOVE B,MSGIPT(M)        ; output date directly from the file
       DO.
         ILDB D,B
         JUMPE D,TOP.          ; ignore leading nulls
         CAIE D,.CHSPC         ; and leading whitespace
          CAIN D,.CHTAB
           LOOP.
       ENDDO.
       CAIL D,"0"              ; numeric?
        CAILE D,"9"
       IFSKP.
         ILDB C,B              ; sniff at next character too
         CAIL C,"0"            ; numeric?
          CAILE C,"9"
         IFNSK.
           MOVX M,.CHSPC       ; no, start with leading space
           IDPB M,A
         ENDIF.
         IDPB D,A              ; ship first character (second in C)
         DO.
           IDPB C,A            ; ship this character
           ILDB C,B            ; get next character
           CAIE C,","          ; start of next field?
            LOOP.              ; no, output remainder of field
         ENDDO.
       ELSE.
         MOVE B,MSGTAD(M)      ; strange, better use the slow way then...
         MOVX C,OT%TMZ
         ODTIM%
          ERCAL FATAL
       ENDIF.
       MOVX B,""""
       IDPB B,A
       CALLRET BFCRLF

       ENDAV.

; Fetch RFC 822 size in B

FTSIZ:  SAVEAC <B,C>
       ACVAR <M>
       MOVEI M,-1(B)           ; determine index into data structure
       IMULI M,MSGLEN
       HRROI B,[ASCIZ/RFC822.Size /]
       CALL BFSOUT
       MOVE B,MSGSIZ(M)        ; now output size
       CALL BFNOUT
       CALLRET BFCRLF

       ENDAV.

; Fetch RFC 822 format message in B

FT822:  SAVEAC <B,C,D>
       ACVAR <M>
       MOVEI M,-1(B)           ; determine index into data structure
       IMULI M,MSGLEN
       CALL MRKMSG             ; mark this message as having been seen
       MOVE B,MSGPTR(M)        ; output message from this byte
       MOVE C,MSGSIZ(M)        ; and this many bytes
       HRROI D,[ASCIZ/RFC822/]
       CALL BFBLAT
       CALLRET BFCRLF

       ENDAV.

; Fetch RFC 822 format header in B

FTHDR:  SAVEAC <B,C,D>
       ACVAR <M>
       MOVEI M,-1(B)           ; determine index into data structure
       IMULI M,MSGLEN
       SKIPE C,MSGHSZ(M)       ; get header size
       IFSKP.
         MOVE B,M              ; not known yet, set up index
         CALL FNDHSZ           ; find the header
       ENDIF.
       MOVE B,MSGPTR(M)        ; output body of message from this byte
       HRROI D,[ASCIZ/RFC822.Header/]
       CALL BFBLAT
       CALLRET BFCRLF

       ENDAV.

; Fetch text from RFC 822 format message in B

FTTXT:  SAVEAC <B,C,D>
       ACVAR <M>
       MOVEI M,-1(B)           ; determine index into data structure
       IMULI M,MSGLEN
       CALL MRKMSG             ; mark message as having been seen
       SKIPE C,MSGHSZ(M)       ; get header size
       IFSKP.
         MOVE B,M              ; not known yet, set up index
         CALL FNDHSZ           ; find the header
       ENDIF.
       MOVE B,MSGSIZ(M)        ; get full message size
       SUBB B,C                ; save message size
       MOVE B,MSGHSZ(M)        ; output body of message
       ADJBP B,MSGPTR(M)       ; from this byte
       HRROI D,[ASCIZ/RFC822.Text/]
       CALL BFBLAT
       CALLRET BFCRLF

       ENDAV.

; STORE - store attributes

STORE:  JE F%LOG,,NOTLOG        ; must log in first
       JUMPE A,MISARG          ; must have an argument
       SKIPN MBXJFN            ; must have a mailbox open
        JRST NOMBX
       IFQN. F%RON             ; read-only?
         TAGMSG <OK STORE ignored for read-only file>
         RET
       ENDIF.
       STKVAR <ARGDSP>
       CALL GETSEQ             ; get message sequence
        RET                    ; failed
       JUMPE A,MISARG          ; must have an attribute following
       CALL GETATT             ; get attribute
        RET                    ; failed
       CAIN A,")"              ; make sure delimiter is right
        JRST SYNERR
       HRRZ C,(C)              ; get dispatch address
       MOVEM C,ARGDSP          ; save dispatch
       IFN. A
         MOVE A,[OWGP. 7,ARGBUF] ; starting pointer
         MOVX C,-<<5*ARGBSZ>-1> ; wholeline argument is very large
         CALL ARGCPY           ; copy the argument
          RET
         JUMPN B,BADARG        ; must be last argument
       ELSE.
         SETZM @[ARGBUF]       ; make argument empty
       ENDIF.
       HRROI A,[ASCIZ/ Store (/]
       HRRZ B,ARGDSP           ; get dispatch address
       XHLLI B,
       CALL SEQDSP             ; do attribute dispatch
       IFSKP. <TAGMSG <OK Store completed>>
       RET

       ENDSV.

STBAD:  TAGMSG <BAD Not valid to store this attribute>
       RETSKP

STNIM:  TAGMSG <NO Store not implemented yet for this attribute>
       RETSKP

; Store flags for message in B

STFLG:  SAVEAC <C>
       CALL GETFLG             ; parse user's flag list
        RETSKP                 ; failed
       CALL STOFLG             ; store these flags
        RETSKP
       CALLRET .FTFLG          ; and do a fetch of the new flags

; Store additional flags for message in B

STPFL:  SAVEAC <C>
       ACVAR <M>
       MOVEI M,-1(B)           ; determine index into data structure
       IMULI M,MSGLEN
       CALL GETFLG             ; parse user's flag list
        RETSKP                 ; failed
       IOR C,MSGFLG(M)         ; new flags are the OR function
       CALL STOFLG             ; store these flags
        RETSKP
       CALLRET .FTFLG          ; and do a fetch of the new flags

       ENDAV.

; Store cleared flags for message in B

STMFL:  SAVEAC <C>
       ACVAR <M>
       MOVEI M,-1(B)           ; determine index into data structure
       IMULI M,MSGLEN
       CALL GETFLG             ; parse user's flag list
        RETSKP                 ; failed
       ANDCA C,MSGFLG(M)       ; new flags are the AND of complement function
       CALL STOFLG             ; store these flags
        RETSKP
       CALLRET .FTFLG          ; and do a fetch of the new flags

       ENDAV.

; SEARCH - search for message with attributes

SEARC:  JE F%LOG,,NOTLOG        ; must log in first
       JUMPE A,MISARG          ; must have an argument
       SKIPN MBXJFN            ; must have a mailbox open
        JRST NOMBX
       SKIPE MBXMGS            ; is there at least one message?
       IFSKP.
         TAGMSG <NO Mailbox is empty>
         RET
       ENDIF.
       ACVAR <<VEC,2>,SEQ,PTR>
       STKVAR <CURPTR>
       MOVEM B,CURPTR          ; save pointer to current search command
       SETOM SEQLST            ; initialize sequence list to ALL
       MOVE A,[SEQLST,,SEQLST+1]
       BLT A,SEQLST+SEQLSN-1

; Pass 1: parse each criterion, and deselect messages which fail it

       DO.
         MOVSI C,-SRCTBL       ; length of command table
         DO.
           HLRO A,SRCTAB(C)    ; point to command string
           MOVE B,CURPTR       ; point to base
           STCMP%              ; compare
           JUMPE A,ENDLP.      ; done if match
           IFXN. A,SC%SUB      ; subset?
             ILDB A,B          ; yes, get delimiting byte
             CAIN A,.CHSPC     ; OK if something follows
              EXIT.
           ENDIF.
           AOBJN C,TOP.
           JRST BADCOM
         ENDDO.
         SKIPN A               ; possibility of an argument?
          SETZ B,              ; no, end of string
         HRRZ D,SRCTAB(C)      ; get pointer to argument,,command dispatch
         MOVE D,(D)            ; get argument,,command dispatch
         IFXN. D,.LHALF        ; command takes an argument?
           SETZM @[ARGBUF]     ; initialize argument
           SETZM ATOM
         ANDN. A               ; yes, is there one in the buffer
           MOVE A,[OWGP. 7,ARGBUF] ; starting pointer
           MOVX C,<5*ARGBSZ>-1 ; buffer is very large
           CALL ARGCPY         ; copy the argument
            RET
           HLRO C,D            ; get routine that will process the argument
           CALL (C)            ; go process it
            RET                ; argument processor was unhappy with it
         ENDIF.
         HRRO C,D              ; get routine to handle command
         MOVEM B,CURPTR        ; save pointer to current search command
         MOVX D,1              ; start at first message
         DO.
           MOVEI A,-1(D)       ; copy sequence
           IDIVI A,^D36        ; split into vector index and bit number
           MOVE B,BITS(B)      ; get the desired bit
           TDNE B,SEQLST(A)    ; is this message eligible to be checked?
            CALL (C)           ; yes, check it
             ANDCAM B,SEQLST(A) ; bit is now ineligible
           CAMGE D,MBXMGS      ; at the last message?
            AOJA D,TOP.        ; no, try next message
         ENDDO.
         SKIPE B,CURPTR        ; restore pointer
          LOOP.                ; do next search spec if there is one
       ENDDO.

; Pass 2: output the messages which match the search

       MOVE A,[OWGP. 7,OUTBFR] ; initialize buffer pointer
       HRROI B,[ASCIZ/* SEARCH/] ; start search reply
       CALL BFSOUT
       SETZ PTR,               ; and sequence pointer
       MOVE VEC,SEQLST         ; get first word from bit vector
       DO.
         JFFO VEC,.+2          ; find a bit out of it
         IFSKP.
           MOVE SEQ,PTR        ; get vector index
           IMULI SEQ,^D36      ; times number of bits in vector element
           ADDI SEQ,1(VEC+1)   ; plus bit position gives this sequence
           CAMLE SEQ,MBXMGS    ; off the end?
            EXIT.              ; yes, all done
           ANDCM VEC,BITS(VEC+1) ; flush this bit for next time
           MOVX B,.CHSPC       ; delimit
           IDPB B,A
           MOVE B,SEQ          ; get sequence again
           CALL BFNOUT         ; output sequence
           LOOP.
         ENDIF.
         CAIN PTR,SEQLSN       ; at end?
          EXIT.                ; yes, done with sequence
         MOVE VEC,SEQLST+1(PTR) ; get next word from bit vector
         AOJA PTR,TOP.         ; charge on
       ENDDO.
       HRROI B,[ASCIZ/
/]
       CALL BFSOUT
       SETZ C,                 ; tie off buffer
       IDPB C,A
       MOVX A,.PRIOU           ; now blat the buffer
       MOVE B,[OWGP. 7,OUTBFR]
       SOUT%
        ERJMP .+1
       TAGMSG <OK SEARCH completed>
       RET

       ENDSV.
       ENDAV.

DEFINE SRC (NAME,DSP,ARG) <[ASCIZ/'NAME'/],,[ARG,,DSP]>

SRCTAB: SRC All,RSKP
       SRC Answered,.SEANS
       SRC Bcc,.SEBCC,RSKP
       SRC Before,.SEBEF,.SEDAT
       SRC Body,.SEBOD,RSKP
       SRC Cc,.SECC,RSKP
       SRC Deleted,.SEDEL
       SRC Flagged,.SEFLG
       SRC From,.SEFRM,RSKP
       SRC Keyword,.SEKEY,.SEFLA
       SRC New,.SENEW
       SRC Old,.SEOLD
       SRC On,.SEON,.SEDAT
       SRC Recent,.SEREC
       SRC Seen,.SESEE
       SRC Since,.SESIN,.SEDAT
       SRC Subject,.SESUB,RSKP
       SRC Text,.SETEX,RSKP
       SRC To,.SETO,RSKP
       SRC Unanswered,.SEUAN
       SRC Undeleted,.SEUDE
       SRC Unflagged,.SEUFL
       SRC Unkeyword,.SEUKE,.SEFLA
       SRC Unseen,.SEUSE
SRCTBL==.-SRCTAB

; Parse a date

SEDAT:  SAVEAC <A,B,C,D>
       MOVE A,[OWGP. 7,ARGBUF] ; pointer to the thing
       MOVX B,IT%NTI           ; don't bother with the time
       IDTNC%
        ERJMP SYNERR
       IDCNV%
        ERJMP SYNERR
       LDB A,A                 ; better be the end
       JUMPN A,SYNERR          ; it wasn't
       MOVEM B,ATOM            ; time is OK
       RETSKP

; Parse a keyword flag

SEFLA:  SAVEAC <A,B,C>
       MOVSI C,-^D30
       DO.
         MOVE A,FLGTAB(C)      ; flag to consider
         MOVE B,[OWGP. 7,ARGBUF] ; point to the thing
         STCMP%
         IFN. A                ; exact match?
           AOBJN C,TOP.        ; no, try next flag
           TAGMSG <NO Undefined flag>
           RET
         ENDIF.
       ENDDO.
       MOVE A,BITS(C)          ; get the flag
       MOVEM A,ATOM
       RETSKP

; Skip if text matches

SETEX:  SAVEAC <A,B>
       MOVEI B,-1(D)           ; determine index into data structure
       IMULI B,MSGLEN
       MOVE A,MSGPTR(B)        ; text of message
       MOVE B,MSGSIZ(B)        ; size of message
       CALLRET SEARCH          ; search for it!

; Skip if text in body of message matches

SEBOD:  SAVEAC <A,B,C>
       MOVEI B,-1(D)           ; determine index into data structure
       IMULI B,MSGLEN
       SKIPN C,MSGHSZ(B)       ; get header size
        CALL FNDHSZ            ; find the header's size
       MOVE A,C                ; get pointer to start of text
       ADJBP A,MSGPTR(B)
       MOVE B,MSGSIZ(B)        ; size of entire message
       SUB B,C                 ; size of text only
       CALLRET SEARCH          ; search for it!

; Skip if text in subject of message matches

SESUB:  SAVEAC <A,B,C,D>
       MOVEI B,-1(D)           ; determine index into data structure
       IMULI B,MSGLEN
       EXCH B,D                ; B has message number for GETENV
       SKIPN D,MSGENV(D)       ; get envelope
        CALL GETENV
       MOVE A,ENVSUB(D)        ; get pointer to subject
       SETZ B,                 ; count characters in subject
       DO.
         ILDB C,A
         JUMPE C,ENDLP.
         AOJA B,TOP.
       ENDDO.
       MOVE A,ENVSUB(D)        ; get pointer to subject
       CALLRET SEARCH

; Skip if From matches

SEFRM:  SAVEAC <B,D>
       MOVEI B,-1(D)           ; determine index into data structure
       IMULI B,MSGLEN
       EXCH B,D                ; B has message number for GETENV
       SKIPN D,MSGENV(D)       ; get envelope
        CALL GETENV
       MOVE D,ENVFRM(D)        ; get From
       CALLRET .SEADR

; Skip if To matches

SETO:   SAVEAC <B,D>
       MOVEI B,-1(D)           ; determine index into data structure
       IMULI B,MSGLEN
       EXCH B,D                ; B has message number for GETENV
       SKIPN D,MSGENV(D)       ; get envelope
        CALL GETENV
       MOVE D,ENVTO(D)         ; get To
       CALLRET .SEADR

; Skip if cc matches

SECC:   SAVEAC <B,D>
       MOVEI B,-1(D)           ; determine index into data structure
       IMULI B,MSGLEN
       EXCH B,D                ; B has message number for GETENV
       SKIPN D,MSGENV(D)       ; get envelope
        CALL GETENV
       MOVE D,ENVCC(D)         ; get cc
       CALLRET .SEADR

; Skip if bcc matches

SEBCC:  SAVEAC <B,D>
       MOVEI B,-1(D)           ; determine index into data structure
       IMULI B,MSGLEN
       EXCH B,D                ; B has message number for GETENV
       SKIPN D,MSGENV(D)       ; get envelope
        CALL GETENV
       MOVE D,ENVBCC(D)        ; get bcc
       CALLRET .SEADR

; Skip on match for address list in D

SEADR:  ACVAR <ADR>
       SKIPN ADR,D             ; get address list
        RET                    ; if empty address always fails
       SAVEAC <A,B,C,D>
       MOVE A,[OWGP. 7,WRKBUF] ; destination buffer
       SETZ B,                 ; init byte count
       DO.
         SKIPN D,ADRNAM(ADR)   ; output personal name
         IFSKP.
           DO.
             ILDB C,D
             IFN. C
               IDPB C,A
               AOJA B,TOP.
             ENDIF.
           ENDDO.
           MOVX C,.CHSPC       ; and space as delimiter
           IDPB C,A
           ADDI B,1
         ENDIF.

         SKIPN D,ADRMBX(ADR)   ; output mailbox
         IFSKP.
           MOVX C,.CHLAB       ; output left broket
           IDPB C,A
           ADDI B,1
           DO.
             ILDB C,D
             IFN. C
               IDPB C,A
               AOJA B,TOP.
             ENDIF.
           ENDDO.
           SKIPN D,ADRHST(ADR) ; output host
           IFSKP.
             MOVX C,"@"        ; delimiter
             IDPB C,A
             ADDI B,1
             DO.
               ILDB C,D
               IFN. C
                 IDPB C,A
                 AOJA B,TOP.
               ENDIF.
             ENDDO.
           ENDIF.
           MOVX C,.CHRAB       ; close broket
           IDPB C,A
           MOVX C,.CHSPC       ; and space
           IDPB C,A
           ADDI B,2
         ENDIF.
         MOVE ADR,ADRCDR(ADR)  ; try next address
         JUMPN ADR,TOP.        ; do it if there is one
       ENDDO.
       IDPB ADR,A              ; tie off the string
       JUMPE B,R               ; one last paranoia check
       MOVE A,[OWGP. 7,WRKBUF] ; destination buffer
       CALLRET SEARCH          ; now do the search

       ENDAV.

; Skip on flag set for message in D

SEANS:  SAVEAC <A>
       MOVEI A,-1(D)           ; determine index into data structure
       IMULI A,MSGLEN
       MOVE A,MSGFLG(A)        ; get flags
       JXN A,M%ANSW,RSKP       ; skip if answered
       RET

SEDEL:  SAVEAC <A>
       MOVEI A,-1(D)           ; determine index into data structure
       IMULI A,MSGLEN
       MOVE A,MSGFLG(A)        ; get flags
       JXN A,M%DELE,RSKP       ; skip if deleted
       RET

SEFLG:  SAVEAC <A>
       MOVEI A,-1(D)           ; determine index into data structure
       IMULI A,MSGLEN
       MOVE A,MSGFLG(A)        ; get flags
       JXN A,M%FLAG,RSKP       ; skip if flagged
       RET

SEKEY:  SAVEAC <A>
       MOVEI A,-1(D)           ; determine index into data structure
       IMULI A,MSGLEN
       MOVE A,MSGFLG(A)        ; get flags
       TDNE A,ATOM             ; is the keyword set?
        RETSKP
       RET

SESEE:  SAVEAC <A>
       MOVEI A,-1(D)           ; determine index into data structure
       IMULI A,MSGLEN
       MOVE A,MSGFLG(A)        ; get flags
       JXN A,M%SEEN,RSKP       ; skip if seen
       RET

; Skip if flag not set for message in D

SEUAN:  SAVEAC <A>
       MOVEI A,-1(D)           ; determine index into data structure
       IMULI A,MSGLEN
       MOVE A,MSGFLG(A)        ; get flags
       JXE A,M%ANSW,RSKP       ; skip if unanswered
       RET

SEUDE:  SAVEAC <A>
       MOVEI A,-1(D)           ; determine index into data structure
       IMULI A,MSGLEN
       MOVE A,MSGFLG(A)        ; get flags
       JXE A,M%DELE,RSKP       ; skip if undeleted
       RET

SEUFL:  SAVEAC <A>
       MOVEI A,-1(D)           ; determine index into data structure
       IMULI A,MSGLEN
       MOVE A,MSGFLG(A)        ; get flags
       JXE A,M%FLAG,RSKP       ; skip if unflagged
       RET

SEUKE:  SAVEAC <A>
       MOVEI A,-1(D)           ; determine index into data structure
       IMULI A,MSGLEN
       MOVE A,MSGFLG(A)        ; get flags
       TDNN A,ATOM             ; is the keyword clear?
        RETSKP
       RET

SEUSE:  SAVEAC <A>
       MOVEI A,-1(D)           ; determine index into data structure
       IMULI A,MSGLEN
       MOVE A,MSGFLG(A)        ; get flags
       JXE A,M%SEEN,RSKP       ; skip if unseen
       RET

; Skip based on date of message

SENEW:  CALL .SEREC             ; is it recent?
        RET                    ; no
       CALLRET .SEUSE          ; yes, then it's new if unseen

SEREC:  SAVEAC <A>
       MOVEI A,-1(D)           ; determine index into data structure
       IMULI A,MSGLEN
       MOVE A,MSGTAD(A)        ; get date of this message
       CAMG A,MBXRDT           ; is this a recent message?
        RET
       RETSKP                  ; yes, message is new

SEOLD:  SAVEAC <A>
       MOVEI A,-1(D)           ; determine index into data structure
       IMULI A,MSGLEN
       MOVE A,MSGTAD(A)        ; get date of this message
       CAMLE A,MBXRDT          ; is this a recent message?
        RET
       RETSKP                  ; yes, message is new

; Skip if message suits a particular date/time range

SEBEF:  SAVEAC <A>
       MOVEI A,-1(D)           ; determine index into data structure
       IMULI A,MSGLEN
       MOVE A,MSGTAD(A)        ; get TAD
       CAML A,ATOM             ; before the date?
        RET
       RETSKP

SEON:   SAVEAC <A>
       MOVEI A,-1(D)           ; determine index into data structure
       IMULI A,MSGLEN
       MOVE A,MSGTAD(A)        ; get TAD
       CAMGE A,ATOM            ; since the date?
        RET
       SUB A,[1B17]            ; yes, back the TAD off by 1 day
       CAML A,ATOM             ; if it's now before the date then it's that day
        RET
       RETSKP

SESIN:  SAVEAC <A>
       MOVEI A,-1(D)           ; determine index into data structure
       IMULI A,MSGLEN
       MOVE A,MSGTAD(A)        ; get TAD
       CAMGE A,ATOM            ; since the date?
        RET
       RETSKP
      SUBTTL RFC 822 => Envelope handling routines

; Format of an envelope block

ENVDAT==0                       ; envelope Date
ENVSUB==1                       ; address of envelope Subject
ENVFRM==2                       ; address of envelope From
ENVSDR==3                       ; address of envelope Sender
ENVREP==4                       ; address of envelope Reply-To
ENVTO==5                        ; address of envelope To
ENVCC==7                        ; address of envelope cc
ENVBCC==10                      ; address of envelope bcc
ENVIRT==11                      ; address of envelope In-Reply-To
ENVMID==12                      ; address of envelope Message-ID
ENVLEN==13                      ; length of envelope block

; Format of an address block

ADRNAM==0                       ; address personal name
ADRADL==1                       ; address route list (a-d-l)
ADRMBX==2                       ; address mailbox
ADRHST==3                       ; address host
ADRCDR==4                       ; pointer to next address
ADRLEN==5                       ; length of an address block

; Get an envelope for a message
; Accepts: B/ message number
;       CALL GETENV
; Returns +1: Always, envelope pointer in D

GETENV: SAVEAC <A,B,C>
       ACVAR <M,PTR,CTR>
       TRVAR <<HDRPTR,2>,<HEADER,3>>
       MOVEI M,-1(B)           ; determine index into data structure
       IMULI M,MSGLEN
       MOVX D,ENVLEN           ; length of envelope block
       CALL FSGET
       MOVEM D,MSGENV(M)       ; save envelope pointer
       SKIPE CTR,MSGHSZ(M)     ; get header size
       IFSKP.
         MOVE B,M              ; not known yet, set up index
         CALL FNDHSZ           ; find the header
         MOVE CTR,MSGHSZ(M)
       ENDIF.
       MOVE PTR,MSGPTR(M)      ; pointer to header
       DO.
         CALL GETLIN           ; get an RFC 822 text line
          EXIT.                ; didn't get one
         DMOVE A,[OWGP. 7,WRKBUF ; point to header line
                  POINT 7,HEADER] ; and to where we store the item
         DMOVEM A,HDRPTR
         SETZM HEADER          ; init item
         SETZM 1+HEADER
         SETZM 2+HEADER
         MOVEI A,^D15          ; maximum header item length
         DO.
           ILDB C,HDRPTR       ; copy string, converting to uppercase
           JUMPE C,ENDLP.      ; with appropriate terminating cases...
           CAIE C,.CHSPC
            CAIN C,.CHTAB
             EXIT.
           CAIN C,":"
            EXIT.
           CAIL C,"a"
            CAILE C,"z"
             TRNA
              SUBI C,"a"-"A"
           IDPB C,1+HDRPTR
           SOJG A,TOP.
         ENDDO.
         JUMPLE A,TOP.         ; can't possibly win if ran out
         CAIN C,":"            ; saw the delimiter
         IFSKP.
           CALL SKIPWS
           ILDB C,HDRPTR       ; get delimiter
           CAIE C,":"          ; saw appropriate delimiter?
            LOOP.              ; no, this line can't possibly win then
         ENDIF.

; Do appropriate processing for this header line

         CALL SKIPWS
         DMOVE A,HEADER        ; now, get the header item
         MOVE C,2+HEADER
         CAME A,[ASCII/DATE/]
         IFSKP.
           MOVE A,HDRPTR       ; text to copy
           CALL CPYSTR
           MOVEM A,ENVDAT(D)   ; store the date we parsed
           LOOP.
         ENDIF.
         CAMN A,[ASCII/SUBJE/]
          CAME B,[ASCII/CT/]
         IFSKP.
           MOVE A,HDRPTR       ; text to copy
           CALL CPYSTR
           MOVEM A,ENVSUB(D)   ; save pointer to subject in envelope
           LOOP.
         ENDIF.
         CAME A,[ASCII/FROM/]
         IFSKP.
           MOVE A,HDRPTR       ; string to parse
           XMOVEI B,ENVFRM(D)  ; location to store address list
           CALL GETADR         ; parse address
           LOOP.
         ENDIF.
         CAMN A,[ASCII/SENDE/]
          CAME B,[ASCII/R/]
         IFSKP.
           MOVE A,HDRPTR       ; string to parse
           XMOVEI B,ENVSDR(D)  ; location to store address list
           CALL GETADR         ; parse address
           LOOP.
         ENDIF.
         CAMN A,[ASCII/REPLY/]
          CAME B,[ASCII/-TO/]
         IFSKP.
           MOVE A,HDRPTR       ; string to parse
           XMOVEI B,ENVREP(D)  ; location to store address list
           CALL GETADR         ; parse address
           LOOP.
         ENDIF.

         CAME A,[ASCII/TO/]
         IFSKP.
           MOVE A,HDRPTR       ; string to parse
           XMOVEI B,ENVTO(D)   ; location to store address list
           CALL GETADR         ; parse address
           LOOP.
         ENDIF.
         CAME A,[ASCII/CC/]
         IFSKP.
           MOVE A,HDRPTR       ; string to parse
           XMOVEI B,ENVCC(D)   ; location to store address list
           CALL GETADR         ; parse address
           LOOP.
         ENDIF.
         CAME A,[ASCII/BCC/]
         IFSKP.
           MOVE A,HDRPTR       ; string to parse
           XMOVEI B,ENVBCC(D)  ; location to store address list
           CALL GETADR         ; parse address
           LOOP.
         ENDIF.
         CAMN A,[ASCII/IN-RE/]
          CAME B,[ASCII/PLY-T/]
         IFSKP.
           CAME C,[ASCII/O/]
         ANSKP.
           MOVE A,HDRPTR       ; treat as text for now
           CALL CPYSTR
           MOVEM A,ENVIRT(D)   ; save pointer in envelope
           LOOP.
         ENDIF.
         CAMN A,[ASCII/MESSA/]
          CAME B,[ASCII/GE-ID/]
         IFSKP.
         ANDE. C
           MOVE A,HDRPTR       ; treat as text for now
           CALL CPYSTR
           MOVEM A,ENVMID(D)   ; save pointer in envelope
           LOOP.
         ENDIF.
         LOOP.
       ENDDO.

; Default parts of the envelope

       MOVE B,ENVFRM(D)        ; default Sender and Reply-to
       SKIPN ENVSDR(D)         ; set default Sender if none in header
        MOVEM B,ENVSDR(D)
       SKIPN ENVREP(D)         ; set default Reply-to if none in header
        MOVEM B,ENVREP(D)
       RET

SKIPWS: SAVEAC <A>
       DO.
         MOVE A,HDRPTR         ; skip whitespace
         ILDB A,A
         CAIE A,.CHSPC
          CAIN A,.CHTAB
         IFNSK.
           IBP HDRPTR
           LOOP.
         ENDIF.
       ENDDO.
       RET

       ENDTV.

; Get an RFC822 line, called only from GETENV
; Accepts: PTR/ current RFC822 header pointer
;          CTR/ number of bytes left in header
;       CALL GETLIN
; Returns +1: Didn't get a line
;         +2: Got a line in WRKBUF

GETLIN: SAVEAC <A,B,C,D>        ; D used as a flag for unparsed text
       MOVE A,[OWGP. 7,WRKBUF] ; stash line in here
       SETZB D,@[WRKBUF]       ; empty line

;  Flush any leading whitespace or otherwise strange things.  This is
; paranoia code and none of these conditions should ever happen with a
; well-formed RFC822 header.

       DO.
         MOVE C,PTR            ; guard against perverse start of line
         CAIE C,.CHSPC         ; LWSP
          CAIN C,.CHTAB
         IFSKP.
           CAIE C,.CHCRT       ; CR
            CAIN C,"("         ; start of comment
         ANSKP.                ; looks OK
         ELSE.
           SOJL CTR,R          ; ugh, skip over this crap
           ILDB C,PTR
           LOOP.               ; let's hope the next one is nicer...
         ENDIF.
       ENDDO.

; Copy line

       DO.
         SOJL CTR,R            ; quit if out of header
         ILDB C,PTR            ; get character from header
         IFE. D                ; if we don't know whether text or not
           CAIE C,":"          ; have delimiting colon?
         ANSKP.
           IDPB C,A            ; yes, stash it in the string
           LDB B,[OWGP. 7,WRKBUF+1,<^D20>] ; sniff at delimiting character
           CAIN B,":"          ; is it expected ":"
           IFSKP.
             CAIE B,.CHTAB     ; no, then it had better be whitespace!
              CAIN B,.CHSPC
           ANSKP.
             AOJA D,TOP.       ; it isn't, so assume we must parse it!
           ENDIF.
           DMOVE B,@[WRKBUF]   ; get first two words of line
           AND B,[BYTE (7) 137,137,137,137,137] ; make sure uppercase
           AND C,[BYTE (7) 137,137,0,0,0]
           CAMN B,[ASCII/SUBJE/] ; look like a Subject: line?
            CAME C,[ASCII/CT/]
             AOJA D,TOP.       ; no, flag that we must parse it
           SOJA D,TOP.         ; yes, flag that it's non-parsed text
         ENDIF.
         IFGE. D               ; needs pre-parsing?
           CAIE C,"\"          ; yes, quoted-pair?
           IFSKP.
             IDPB C,A          ; yes, store it in string
             SOJL CTR,R        ; get next character
             ILDB C,PTR
             IDPB C,A
            LOOP.
           ENDIF.

; Handle quoted string

           CAIE C,""""         ; quoted-string?
           IFSKP.
             IDPB C,A          ; store open quote
             DO.
               SOJL CTR,R
               ILDB C,PTR
               CAIE C,.CHCRT   ; end of line?
               IFSKP.
                 SOJL CTR,R    ; get expected LF
                 ILDB C,PTR
                 CAIE C,.CHLFD
               ANSKP.
                 SOJL CTR,R    ; get expected LWSP-char
                 ILDB C,PTR
               ENDIF.
               IDPB C,A        ; store character in the string
               CAIE C,"\"      ; quoted-pair?
               IFSKP.
                 SOJL CTR,R    ; get next character
                 ILDB C,PTR
                 IDPB C,A
                 LOOP.
               ENDIF.
               CAIE C,""""     ; end of quote?
                LOOP.          ; no, get next character
             ENDDO.
             LOOP.
           ENDIF.

; Handle comment

           CAIE C,"("          ; comment?
           IFSKP.
             SETZ B,           ; initialize nesting count
             DO.
               SOJL CTR,R
               ILDB C,PTR      ; get next character
               CAIE C,.CHCRT   ; end of line?
               IFSKP.
                 SOJL CTR,R    ; get expected LF
                 ILDB C,PTR
                 CAIE C,.CHLFD
               ANSKP.
                 SOJL CTR,R    ; get expected LWSP-char
                 ILDB C,PTR
               ENDIF.
               CAIE C,"\"      ; quoted-pair?
               IFSKP.
                 SOJL CTR,R    ; yes, skip next character
                 ILDB C,PTR
                 LOOP.
               ENDIF.
               CAIN C,"("      ; nested comment?
                AOJA B,TOP.    ; yes, increment nest count
               CAIE C,")"      ; end of comment?
                LOOP.          ; no
               SOJGE B,TOP.    ; yes, decrement nest count and maybe finish
             ENDDO.
             MOVX C,.CHSPC     ; make it into LWSP
           ENDIF.

; Whitespace

           CAIE C,.CHTAB       ; LWSP-char?
            CAIN C,.CHSPC
         ANNSK.
           DO.
             MOVE C,PTR        ; sniff at next character
             ILDB C,C
             CAIE C,.CHTAB     ; LWSP-char?
              CAIN C,.CHSPC
             IFNSK.
               SOJL CTR,R      ; yes, skip this character
               IBP PTR
               LOOP.
             ENDIF.
           ENDDO.
           LDB B,A             ; see if LWSP already stored
           CAIN B,.CHSPC
           IFSKP.
             MOVX B,.CHSPC     ; no, store a single LWSP
             IDPB B,A
           ENDIF.
           LOOP.               ; try next character
         ENDIF.


; End of line (always come here whether or not parsable)

         CAIE C,.CHCRT         ; end of line?
         IFSKP.
           MOVE B,PTR          ; could be, sniff at next character
           ILDB B,B
           CAIE B,.CHLFD       ; so, is it really EOL?
         ANSKP.
           SETZ C,             ; yes, tie off line here
           MOVE B,A            ; but be prepared for continuation so don't
           IDPB C,B            ;  step on A
           IBP PTR             ; skip past the LF
           SOJLE CTR,ENDLP.    ; guard against the header ending
           MOVE C,PTR          ; sniff at next line
           ILDB C,C
           CAIE C,.CHTAB       ; LWSP-char?
            CAIN C,.CHSPC
             LOOP.             ; yes, continue eating text
         ELSE.
           IDPB C,A            ; no, store this character
           LOOP.               ; and get more text
         ENDIF.
       ENDDO.
       SKIPN @[WRKBUF]         ; did we get any line at all?
        RET                    ; no, probably end of header
       RETSKP

       ENDAV.

; Get an RFC 822 address list
; Accepts: A/ pointer to address list string
;          B/ address of location to store list pointer
;       CALL GETADR
; Returns +1: Always
;  This routine is quite a bit more generous than RFC 822 in what it will
; swallow, since there are still all sorts of gross address composers out
; there that generate flagrantly illegal addresses.

GETADR: SAVEAC <C,D>
       TRVAR <CURPTR,NWSPTR,GRPCNT>
       CALL CPYSTR             ; copy string to free storage
       SETZM GRPCNT            ; init group count
       DO.
         SKIPN D,(B)           ; run down this address list until at the
         IFSKP.                ;  end, since something may already be there.
           XMOVEI B,ADRCDR(D)  ;  B will have the address of the slot to put
           LOOP.               ;  in any new addresses
         ENDIF.
       ENDDO.

; Loop for each address

       DO.
         DO.
           MOVE C,A            ; skip leading whitespace
           ILDB C,C
           CAIE C,.CHSPC
            CAIN C,.CHTAB
           IFNSK.
             IBP A
             LOOP.
           ENDIF.
         ENDDO.
         MOVEM A,CURPTR        ; init "current pointer"
         SETZM NWSPTR          ; init "non-whitespace pointer"

; Handle a possible personal name

         DO.                   ; slurp up a phrase
           ILDB C,A
           JUMPE C,ENDLP.      ; end of string
           CAIE C,"\"          ; quoted character?
           IFSKP.
             IBP A             ; yes, skip next character
             MOVEM A,NWSPTR
             LOOP.
           ENDIF.
           CAIE C,""""         ; quoted string?
           IFSKP.
             DO.
               ILDB C,A        ; yes, search for unquote
               CAIN C,"\"      ; in case quoted quote
                IBP A
               CAIE C,""""     ; found unquote yet?
                JUMPN C,TOP.   ; nope
             ENDDO.
             MOVEM A,NWSPTR    ; new end of whitespace
           ENDIF.

; Deal with the possibility of <group>: <stuff> ;

           CAIE C,":"          ; definite group phrase?
           IFSKP.
             DO.
               MOVE C,A        ; yes, skip any whitespace
               ILDB C,C
               CAIE C,.CHSPC
                CAIN C,.CHTAB
               IFNSK.
                 IBP A         ; another bit of whitespace to skip
                 LOOP.
               ENDIF.
             ENDDO.
             AOS GRPCNT        ; bump number of groups
             SETZM NWSPTR      ; toss out this entire phrase!
             MOVEM A,CURPTR
             EXIT.
           ENDIF.
           SKIPE GRPCNT        ; group in effect?
            CAIE C,";"         ; yes, end of group?
           IFSKP.
             SOS GRPCNT        ; yes, decrement number of groups
             MOVX C,","        ; and treat like comma
           ENDIF.
           CAIE C,.CHLAB       ; saw a definite route-addr?
            CAIN C,","         ; or definite end of this address?
           IFSKP.
             CAIE C,.CHSPC     ; not yet, is it whitespace?
              CAIN C,.CHTAB
             IFSKP. <MOVEM A,NWSPTR> ; no, save non-whitespace pointer
             LOOP.             ; continue scan
           ENDIF.
         ENDDO.

; End of a phrase.  If NWSPTR is zero then there's nothing to look at

         SKIPN C               ; end of line?
          SETZ A,              ; yes, note that
         SKIPN NWSPTR          ; parsed anything at all?
          CAIN C,.CHLAB        ; no, but do we see an address now?
         IFNSK.
           MOVX D,ADRLEN       ; yes to either, get an address block
           CALL FSGET
           MOVEM D,(B)         ; cons it to the end of the old list

; See if need to handle route-addr

           CAIE C,.CHLAB       ; route-addr following?
           IFSKP.
             SETZ C,           ; tie off string we parsed
             SKIPN NWSPTR      ; only do this if we saw a phrase
             IFSKP.
               IDPB C,NWSPTR
               MOVE C,CURPTR   ; save phrase as personal name
             ENDIF.
             MOVEM C,ADRNAM(D)
             DO.
               MOVE C,A        ; skip whitespace
               ILDB C,C
               CAIE C,.CHSPC
                CAIN C,.CHTAB
               IFNSK.
                 IBP A
                 LOOP.
               ENDIF.
             ENDDO.

; Handle A-D-L

             MOVE C,A          ; see if there's an A-D-L
             ILDB C,C
             CAIE C,"@"        ; is there?
             IFSKP.
               MOVEM A,ADRADL(D) ; yes, save that pointer
               DO.
                 ILDB C,A      ; look for end of A-D-L
                 CAIN C,"\"    ; handle quotes
                  IBP A
                 CAIE C,""""   ; and this form too
                 IFSKP.
                   DO.
                     ILDB C,A
                     CAIE C,"\"
                      IBP A
                     CAIE C,""""
                      JUMPN C,TOP.
                   ENDDO.
                 ENDIF.
                 CAIE C,":"    ; end of A-D-L?
                 IFSKP.
                   SETZ C,
                   DPB C,A
                 ENDIF.
                 JUMPN C,TOP.
               ENDDO.
             ENDIF.
             MOVEM A,CURPTR    ; note current pointer
             MOVEM A,NWSPTR

; Look for end of route-addr

             DO.
               ILDB C,A        ; look for closing broket
               CAIN C,"\"      ; handle quotes
                IBP A
               CAIE C,""""     ; and this form too
               IFSKP.
                 DO.
                   ILDB C,A
                   CAIE C,"\"
                    IBP A
                   CAIE C,""""
                    JUMPN C,TOP.
                 ENDDO.
               ENDIF.
               CAIN C,.CHRAB
                EXIT.
               CAIE C,.CHSPC   ; so we can skip over whitespace
                CAIN C,.CHTAB
               IFSKP. <MOVEM A,NWSPTR>
               JUMPN C,TOP.
               SETZ A,         ; note line ended
             ENDDO.
             CAIE C,.CHRAB     ; this terminated it?
           ANSKP.
             DO.
               ILDB C,A        ; flush until a comma
               CAIE C,","
                JUMPN C,TOP.
             ENDDO.
             SKIPN C           ; end of line?
              SETZ A,          ; yes, note that
           ENDIF.

; Found end of route-addr or there wasn't a route-addr.  Now know mailbox

           SETZ C,             ; tie off string we parsed
           IDPB C,NWSPTR
           MOVE C,CURPTR       ; get pointer to mailbox name
           MOVEM C,NWSPTR
           MOVEM C,ADRMBX(D)   ; save it

; Locate host

           DO.
             ILDB C,CURPTR     ; search for host delimiter
             JUMPE C,ENDLP.
             CAIN C,"\"        ; quoted character?
              IBP CURPTR       ; yes, skip next character
             CAIE C,""""       ; quoted string?
             IFSKP.
               DO.
                 ILDB C,CURPTR ; yes, look for unquote
                 CAIN C,"\"
                 IBP CURPTR
                 CAIE C,""""
                 JUMPN C,TOP.
               ENDDO.
             ENDIF.
             CAIE C,"@"        ; saw host?
             IFSKP.
               SETZ C,         ; tie off string
               IDPB C,NWSPTR
               DO.
                 MOVE C,CURPTR ; flush leading whitespace
                 ILDB C,C
                 CAIE C,.CHSPC
                  CAIN C,.CHTAB
                 IFNSK.
                   IBP CURPTR
                   LOOP.
                 ENDIF.
               ENDDO.
               MOVE C,CURPTR   ; store host
               MOVEM C,ADRHST(D)
             ENDIF.
             CAIE C,.CHSPC     ; not yet, is it whitespace?
              CAIN C,.CHTAB
             IFSKP.
               MOVE C,CURPTR   ; no, save as non-whitespace pointer
               MOVEM C,NWSPTR
             ENDIF.
             LOOP.             ; continue scan
           ENDDO.
         ENDIF.

; Have all the envelope fields, now get rid of RFC 822 quoting conventions

         SKIPE B,ADRNAM(D)     ; remove RFC 822 quotes from the fields
          CALL FLSQOT
         SKIPE B,ADRADL(D)
          CALL FLSQOT
         SKIPE B,ADRMBX(D)
          CALL FLSQOT
         SKIPE B,ADRHST(D)
          CALL FLSQOT
         XMOVEI B,ADRCDR(D)    ; set up new end of list pointer
         JUMPN A,TOP.          ; parse remainder of string
       ENDDO.
       RET

       ENDTV.

; Flush RFC 822 quotes from string
; Accepts: B/ source/destination string pointer
;       CALL FLSQOT
; Returns +1: Always

FLSQOT: SAVEAC <A,C>
       MOVE A,B                ; destination will overwrite source
       DO.
         ILDB C,A              ; copy from source
         CAIE C,""""           ; quoted string
         IFSKP.
           DO.
             ILDB C,A
             CAIN C,""""       ; end of string?
              EXIT.            ; yes
             CAIE C,"\"        ; quoted character?
             IFSKP.
               ILDB C,A        ; yes, copy next character without checking
               IDPB C,B
             ELSE.
               IDPB C,B        ; else copy this one and quit if end of string
               JUMPE C,R
             ENDIF.
             LOOP.             ; do next character in quoted string
           ENDDO.
           LOOP.               ; do next character in primary string
         ENDIF.
         CAIE C,"\"            ; quoted character?
         IFSKP.
           ILDB C,A            ; yes, get next character literally
           IDPB C,B            ; copy to destination
         ELSE.
           IDPB C,B            ; copy to destination
           JUMPE C,R
         ENDIF.
         LOOP.
       ENDDO.
      SUBTTL Output buffer routines

; Output address to buffer
; Accepts: A/ destination buffer poitner
;          B/ address
;       CALL BFADR
; Returns +1: Always

BFADR:  ACVAR <ADR>
       SKIPN ADR,B             ; get address in ADR
        JRST BFNIL             ; if NIL then punt now
       MOVEI B,"("             ; open the address list
       IDPB B,A
       DO.
         MOVEI B,"("           ; open the address
         IDPB B,A
         MOVE B,ADRNAM(ADR)    ; get personal name
         CALL BFSTR
         MOVE B,ADRADL(ADR)    ; get route list
         CALL BFSTR
         MOVE B,ADRMBX(ADR)    ; get mailbox
         CALL BFSTR
         MOVE B,ADRHST(ADR)    ; get host
         CALL BFSTR
         MOVEI B,")"           ; terminate address
         DPB B,A
         MOVE ADR,ADRCDR(ADR)  ; see if any more addresses
         JUMPN ADR,TOP.
       ENDDO.
       MOVEI B,")"             ; terminate address list
       IDPB B,A
       MOVX B,.CHSPC
       IDPB B,A
       RET

       ENDAV.

; Output NIL to buffer
; Accepts: A/ destination buffer poitner
;       CALL BFNIL
; Returns +1: Always

BFNIL:  SAVEAC <B>
       HRROI B,[ASCIZ/NIL /]   ; dump a NIL to the buffer
       CALLRET BFSOUT

; Output string to buffer, using IMAP literal form if necessary
; Accepts: A/ destination buffer poitner
;          B/ string
;       CALL BFSTR
; Returns +1: Always

BFSTR:  SAVEAC <C,D>
       ACVAR <PTR,FLG>
       JUMPE B,BFNIL           ; NIL if empty
       MOVE PTR,B              ; copy pointer
       SETZB C,FLG             ; initialize count
       DO.
         ILDB D,PTR            ; sniff at string
         JUMPE D,ENDLP.
         CAIE D,""""           ; have a special?
          CAIN D,"{"
         IFSKP.
           CAIE D,.CHCRT       ; this makes it special too
            CAIN D,.CHLFD      ; paranoia
         ANSKP.
           CAIE D,"%"          ; coddle Interlisp
            CAIN D,"\"         ; coddle Commonlisp
         ANSKP.
         ELSE.
           SETO FLG,           ; mark as special
         ENDIF.
         AOJA C,TOP.           ; count character and continue
       ENDDO.
       IFN. FLG
         CALL BFBLAT           ; blat the string if there are specials
       ELSE.
         MOVX C,""""           ; quote the string
         IDPB C,A
         CALL BFSOUT           ; output the string
         MOVX C,""""           ; quote the string
         IDPB C,A
       ENDIF.
       MOVX C,.CHSPC           ; output a trailing space
       IDPB C,A
       RET

       ENDAV.

; Output decimal number to buffer
; Accepts: A/ destination buffer poitner
;          B/ number
;       CALL BFNOUT
; Returns +1: Always

BFNOUT: SAVEAC <B,C>
       DO.
         IDIVI B,^D10          ; get low-order digit
         PUSH P,C              ; save for later
         SKIPE B               ; any more?
          CALL TOP.            ; yes, recurse
       ENDDO.
       POP P,B                 ; get digit back
       ADDI B,"0"              ; make decimal
       IDPB B,A                ; output it
       RET                     ; decurse

; Output CRLF to buffer, with parenthesis closing if necessary
; Accepts: A/ destination buffer poitner
;       CALL BFCRLF
; Returns +1: Always

BFCRLF: IFQE. <F%NCL>
         HRROI B,[ASCIZ/)
/]
       ELSE.
         HRROI B,[ASCIZ/ /]
       ENDIF.
;       CALLRET BFSOUT

; Output string to buffer
; Accepts: A/ destination buffer poitner
;          B/ source string pointer
;       CALL BFSOUT
; Returns +1: Always

BFSOUT: SAVEAC <C>
       TXC B,.LHALF            ; check for -1 type pointer
       TXCN B,.LHALF
        HRLI B,<(POINT 7,)>
       DO.                     ; boring string copy...
         ILDB C,B
         IFN. C
           IDPB C,A
           LOOP.
         ENDIF.
       ENDDO.
       RET

; Blat a literal from string to buffer
; Accepts: A/ destination buffer pointer
;          B/ pointer to string
;          C/ length of string
;          D/ leading string to output
;       CALL BFBLAT
; Returns: +1 Always

BFBLAT: ACVAR <Q0,Q1,Q2,Q3,Q4,Q5> ; get a bunch of AC's
       MOVE Q0,C               ; source count
       MOVE Q1,B               ; source byte pointer
       SKIPN B,D               ; output property name
       IFSKP.
         CALL BFSOUT
         MOVX B,.CHSPC
         IDPB B,A
       ENDIF.
       MOVX B,"{"              ; start literal
       IDPB B,A
       MOVE B,Q0               ; output count
       CALL BFNOUT
       HRROI B,[ASCIZ/}
/]
       CALL BFSOUT
       SETZB Q2,Q5             ; we're using 1-word byte pointers
       MOVE Q3,C               ; destination count
       MOVE Q4,A               ; destination byte pointer
       EXTEND Q0,[MOVSLJ       ; blat the string
                  0]           ; with a zero fill
        CALL MOVBOG            ; this absolutely cannot happen
       IFE. Q5                 ; got a OWGBP or a GBP?
         MOVE A,Q4             ; this microcode gives us a OWGBP back
       ELSE.
         TLC Q4,000740         ; clear bits for "global POINT 7,0,35"
         TXNE Q4,<MASKB 6,35>  ; make sure no bozo bits set
          CALL MOVBOG
         LDB Q0,[POINT 6,Q4,5] ; get position
         IDIVI Q0,7            ; divide by bytesize
         CAIG Q0,OWG7SZ
          CAIE Q1,1            ; is remainder correct?
           CALL MOVBOG         ; foo
         MOVE A,OWG7TB(Q0)     ; get correct pointer
         DPB Q5,[POINT 30,A,35] ; fill in GBP address
       ENDIF.
       RET

       ENDAV.

       RADIX 10

OWG7TB: OWGP. 7,0,34
       OWGP. 7,0,27
       OWGP. 7,0,20
       OWGP. 7,0,13
       OWGP. 7,0,6
       OWGP. 7,0               ; I don't think this can happen
OWG7SZ==.-OWG7TB

       RADIX 8

MOVBOG: TAGMSG <NO Impossible MOVSLJ error -- please report this!!>
       JRST IMPERR
      SUBTTL Free storage routines

; Carve out a piece of free storage
; Accepts: D/ length of desired block
;       CALL FSGET
; Returns +1: Always, with address of block in D

FSGET:  SAVEAC <A>
       EXCH D,FSFREE           ; get current free address
       ADDM D,FSFREE           ; claim the block
       SETZM (D)               ; clear first word of the block
       HRL A,D                 ; set up BLT pointer
       HRRI A,1(D)
       BLT A,@FSFREE           ; zap the block
       RET

; Copy text to free storage string
; Accepts: A/ pointer to source string
;       CALL CPYSTR
; Returns +1: Always, address of string in A

CPYSTR: TRVAR <SRC>
       MOVEM A,SRC
       MOVE A,[OWGP. 7,0]      ; copy remainder of line to free storage
       ADD A,FSFREE
       SAVEAC <A,C>            ; return address to caller
       DO.
         ILDB C,SRC
         IDPB C,A
         JUMPN C,TOP.
       ENDDO.
       ADDI A,1                ; move to next word of free space
       DPB A,[POINT 30,FSFREE,35] ; claim this free block
       RET

       ENDTV.
      SUBTTL Flag manipulation routines

; Mark message as having been seen
; Accepts: A/ buffer pointer
;          B/ message number
;       CALL MRKMSG
; Returns +1: Always

MRKMSG: SAVEAC <C,D>
       ACVAR <M>
       MOVEI M,-1(B)           ; determine index into data structure
       IMULI M,MSGLEN
       SKIPN IDXADR            ; have an index file?
       IFSKP.
         MOVE C,@IDXADR        ; get index last read TAD
         IFNJE.
           CAML C,MSGTAD(M)    ; is it earlier than this message?
         ANSKP.
           MOVE C,MSGTAD(M)    ; yes, update index
           MOVEM C,@IDXADR
         ENDIF.
       ELSE.
         MOVX C,M%SEEN         ; no, mark the message as having been seen
         IOR C,MSGFLG(M)
         CAMN C,MSGFLG(M)      ; was it already so marked?
       ANSKP.
         CALL STOFLG
          NOP
         XMOVEI D,[TQZ F%NCL   ; clear the flag
                   RET]
         TQON F%NCL            ; temporarily say don't close the fetch
          PUSH P,D
         CALL .FTFLG           ; do a fetch of the new flags
       ENDIF.
       RET

       ENDAV.

; Parse a list of flags
; Accepts: ARGBUF/ output buffer
;       CALL GETFLG
; Returns +1: Failure, reason output
;         +2: Success, flags in C

GETFLG: SAVEAC <A,B,D>
       ACVAR <PTR,LST>
       SETZ C,                 ; initially 0 flags
       MOVE PTR,[OWGP. 7,ARGBUF] ; starting pointer
       MOVE A,PTR
       ILDB A,A                ; get starting byte of flags argument
       IFN. A
         CAIN A,"("            ; start of a list?
          SKIPA LST,[-1]       ; yes, note that in list format
           TDZA LST,LST        ; no, not a list
            IBP PTR            ; skip over start of list
         DO.
           MOVSI D,-^D36       ; initialize iteration counter
           DO.
             MOVE A,FLGTAB(D)  ; flag to consider
             MOVE B,PTR        ; current flags argument
             STCMP%            ; test this flag
             IFN. A            ; exact match?
               IFXN. A,SC%SUB  ; no, see if subset
                 ILDB A,B      ; it was a subset, get delimiting byte
                 CAIE A,")"    ; end of list?
                  CAIN A,.CHSPC ; was it a space?
                   EXIT.       ; yes, found flag
               ENDIF.
               AOBJN D,TOP.    ; no win, see if matches next flag
               TAGMSG <NO Undefined flag>
               RET
             ELSE.             ; here if found flag at end of line
             ANDN. LST         ; was end of list required?
               TAGMSG <BAD Unterminated flag list>
               RET
             ENDIF.
           ENDDO.
           MOVEM B,PTR         ; update pointer
           IOR C,BITS(D)       ; update flag
           CAIE A,")"          ; end of list?
            JUMPN A,TOP.       ; no, if more flags to do go to them
         ENDDO.
       ENDIF.
       RETSKP

       ENDAV.

; Store flags in mailbox
; Accepts: B/ message number
;          C/ new flags
;       CALL STOFLG
; Returns +1: Failure
;         +2: Success

STOFLG: JN F%RON,,RSKP          ; always fail if read-only
       SAVEAC <A,B,C,D>
       ACVAR <M,FLG>
       MOVEI M,-1(B)           ; determine index into data structure
       IMULI M,MSGLEN
       TRVAR <JFN>
       MOVE FLG,C
       CAMN FLG,MSGFLG(M)      ; same value as flags had before?
        RETSKP                 ; yes, just return
       CALL MBXWRT             ; want to write into mailbox now
        RET                    ; can't get it for write
       MOVEM A,JFN             ; save the JFN we got
       MOVE D,MSGIPT(M)        ; point to start of internal header
       DO.
         ILDB C,D              ; get header byte
         CAIE C,.CHCRT         ; at end of line??
         IFSKP.
           TAGMSG <NO Can't locate flags for this message>
           RET                 ; sick mail file
         ENDIF.
         CAIE C,";"            ; at start of bits?
          LOOP.                ; not yet
       ENDDO.
       MOVE A,D                ; sniff ahead to see that they're flags
       MOVX C,^D12
       DO.
         ILDB B,A              ; sniff at a byte
         CAIL B,"0"            ; see if numeric
          CAILE B,"9"          ; well?
         IFNSK.
           TAGMSG <NO Improperly formatted flags for this message>
           RET                 ; sick sick sick
         ENDIF.
         SOJG C,TOP.
       ENDDO.

; Now change the flags

       LDB B,[POINT 21,D,26]   ; get page number of core address
       SUBI B,<MBXBUF/1000>    ; make disk page number
       HRL A,JFN               ; A/ JFN,,disk page
       HRR A,B                 ;  . . .
LODWPG:!MOVE B,[.FHSLF,,WINPAG] ; into our window page
       MOVX C,PM%CNT!PM%WR!PM%RD!2 ; map two pages with write access
       PMAP%
        ERCAL FATAL            ; blew it
       MOVEI B,WINPAG          ; get core address of window
       DPB B,[POINT 21,D,26]   ; set that in our pointer
       MOVE A,FLG              ; get flags to write
       MOVX C,^D12             ; there are twelve chars..
       DO.
         SETZ B,               ; compose next "digit"
         ROTC A,3
         ADDI B,"0"
         IDPB B,D              ; update this triplet
         SOJG C,TOP.
       ENDDO.
       SETO A,                 ; now unmap the window pages
;;;  On 21 October, 1986, I wasted over 4 hours in tracking down the cause of
;;; phase errors due to the LIT area being 1 location bigger in pass 2 than in
;;; pass 1.  I finally narrowed it down to this instruction.
;;;     MOVE B,[.FHSLF,,WINPAG]
       XCT LODWPG              ; take that, you goddamned bagbiting assembler!
       MOVX C,PM%CNT!2
       PMAP%
        ERCAL FATAL
       MOVEM FLG,MSGFLG(M)     ; update core copy of flags
       RETSKP

       ENDTV.
       ENDAV.
      SUBTTL String search routine

; Bounded search for pattern within string
; Accepts: A/ OWGBP pointer to string to search in
;          B/ string length
;          ATOM/ pattern length
;          ARGBUF/ pattern to search for
;       CALL SEARCH
; Returns +1: pattern not found
;         +2: pattern found, A/ position of pattern within string

SEARCH: SAVEAC <B,D>
       ACVAR <Q1,Q2,Q3,Q4,Q5,Q6>
       SKIPLE ATOM
       IFSKP.
         JUMPLE B,RSKP         ; win if there's no pattern
         RET                   ; otherwise return failure
       ENDIF.
       SUB B,ATOM              ; difference between text and pattern
       JUMPL B,R               ;  lengths is the maximum # of tries
       LDB Q1,[POINT 6,A,5]    ; get byte position
       CAIE Q1,66              ; aligned on previous word boundary?
       IFSKP.
         TXC A,7B5             ; yes, normalize to 61 form
         ADDI A,1              ; by complementing 61#66 and adding 1
       ELSE.
         CAIE Q1,61            ; aligned to word boundary?
          JSP D,SEARQ          ; no, pattern may begin within this word
       ENDIF.
       LDB Q5,[OWGP. 7,ARGBUF,6] ; first character
       IMUL Q5,[BYTE (1)0 (7)1,1,1,1,1]
       MOVE Q6,Q5
       XOR Q6,[BYTE (1)0 (7)40,40,40,40,40]
       JSP D,.+1               ; come back to top if pattern not found
       DO.
         MOVE Q1,Q5            ; pattern to match
         MOVE Q2,Q6            ; case independent one
         LDB Q3,[POINT 30,A,35]
         MOVE Q3,(Q3)          ; word to try
         LSH Q3,-1             ; right justify text word
         MOVE Q4,Q3
         EQVB Q3,Q1            ; if the first pattern char is present
         EQVB Q4,Q2            ;  this results in '177' at that char
         ADD Q3,[BYTE (1)1 (7)1,1,1,1,1] ; add 1 to each char complementing LSB,
         ADD Q4,[BYTE (1)1 (7)1,1,1,1,1] ;  but note that any carry from '177'
         EQV Q3,Q1             ;  un-complements LSB of left char!
         EQV Q4,Q2             ; check sameness of each char LSB
         TDNN Q3,[BYTE (1)1 (7)1,1,1,1,1] ; if any char LSB remains the same
          TDNE Q4,[BYTE (1)1 (7)1,1,1,1,1] ;  then there is at least one match!
           JRST SEARQ          ; yes, go see!
         SUBI B,5              ; we just tested five chars
         JUMPL B,R             ; not found
         AOJA A,TOP.           ; try some more
       ENDDO.

SEARQ:  MOVE Q4,A               ; remember where we begin
       DO.
         MOVE Q1,[OWGP. 7,ARGBUF]
         DO.
           ILDB Q2,Q1          ; get next character
           JUMPE Q2,RSKP       ; null, we found a match
           ILDB Q3,A           ; get next char
           TRC Q3,(Q2)         ; XOR text and pattern chars
           SKIPE Q3            ; exact match?
            CAIN Q3,40         ; no, other case match?
             LOOP.             ; yes to either, try some more
         ENDDO.
         SOJL B,R              ; no, quit if we've run out of text
         IBP Q4                ; increment pointer to next char in word
         MOVE A,Q4             ; get back pointer
         LDB Q1,[POINT 6,A,5]  ; get position
         CAIE Q1,66            ; at end of word?
          LOOP.                ; no, keep on looking
       ENDDO.
       LDB A,[POINT 30,Q4,35]  ; address of this word
       ADD A,[OWGP. 7,1]       ; point to start of next word
       JRST (D)                ; not found this word, try some more

       ENDAV.
      SUBTTL Argument parsing routine

; Copy an argument
; Accepts: A/ destination pointer
;          B/ current argument pointer
;          C/ maximum length (negative if wholeline)
;       CALL ARGCPY
; Returns: +1 Failed
;          +2 Success, A, B/ updated pointer or 0 if end of line,
;               C/ argument length (also stored in ATOM)

ARGCPY: SAVEAC <D>
       STKVAR <DEST,PTR>
       TLC A,-1                ; is LH -1?
       TLCN A,-1
        HRLI A,(<POINT 7,>)    ; make byte pointer
       ILDB D,B                ; sniff at first byte
       CAIE D,"{"              ; extended argument?
       IFSKP.
         MOVEM A,DEST          ; save destination pointer
         MOVMM C,ATOM          ; save maximum size
         MOVE A,B              ; source string for size string
         MOVX C,^D10           ; decimal radix
         NIN%
          ERJMP SYNERR         ; syntax error if bad
         SKIPLE B              ; value must be .GE. 0
          CAMLE B,ATOM         ; and not too large
         IFNSK.
           TAGMSG <BAD Literal argument too long>
           RET
         ENDIF.
         MOVEM B,ATOM          ; save argument length
         LDB C,A               ; check for termination
         CAIE C,"}"
          JRST SYNERR
         MOVEM A,PTR           ; save pointer
         ILDB C,A              ; get next command byte
         JUMPN C,SYNERR        ; better be end of line
         TMSG <+ Ready for argument>
         CALL CRLF

; Get argument

         MOVX A,.PRIIN         ; from primary input
         MOVE B,DEST           ; where to put the string
         MOVN C,ATOM           ; size of string to read
         SIN%                  ; read it in
          ERJMP INPEOF
         IDPB C,B              ; tie off string with null
         MOVE B,PTR            ; get return pointer
         MOVE C,CMDCNT         ; and free characters
         CALL GETCMD           ; get more of command
          RET                  ; failed
         ILDB C,B              ; see what that character was
         CAIN C,.CHSPC         ; more arguments to come?
         IFSKP.
           JUMPN C,SYNERR      ; no, better be end of line then
           SETZ B,             ; flag that the line ends here
         ENDIF.

; Parse atomic argument

       ELSE.
         SETZM ATOM            ; zap argument length
         CAIE D,""""           ; argument quoted this way?
         IFSKP.
           MOVMS C             ; if so then always atomic
           DO.
             ILDB D,B          ; get next byte
             JUMPE D,SYNERR    ; if buffer ends then command is sick
             CAIN D,""""       ; end of string?
             IFSKP.
               IDPB D,A        ; no, stuff the buffer
               AOS ATOM        ; bump argument length
               SOJG C,TOP.     ; get more bytes if we can
               TAGMSG <BAD Quoted argument too long>
               RET
             ELSE.
               SETZ D,         ; yes, tie off string
               IDPB D,A        ; stuff the buffer
             ENDIF.
             ILDB D,B          ; see if an argument follows
             CAIN D,.CHSPC     ; argument delimiter?
             IFSKP.
               JUMPN D,SYNERR  ; no, error if not end of buffer
               SETZ B,         ; no more arguments
             ENDIF.
           ENDDO.

; Atomic unquoted argument

         ELSE.
           DO.
             SKIPN D           ; end of string?
              SETZ B,          ; yes, clear argument pointer
             IFG. C            ; atomic argument?
               CAIN D,.CHSPC   ; yes, have argument delimiter?
                SETZ D,        ; yes, end of string
             ENDIF.
             IDPB D,A
             JUMPE D,ENDLP.    ; done if end of string
             AOS ATOM          ; bump argument length
             ILDB D,B          ; get next byte
             IFG. C            ; what kind of argument?
               SOJG C,TOP.     ; otherwise get more bytes
               TAGMSG <BAD Atomic argument too long>
             ELSE.
               AOJL C,TOP.     ; otherwise get more bytes
               TAGMSG <BAD Wholeline argument too long>
             ENDIF.
             RET
           ENDDO.
         ENDIF.
       ENDIF.
       MOVE C,ATOM             ; return argument length
       RETSKP

       ENDSV.
      SUBTTL Sequence handling routines

; Store sequence
; Accepts: B/ sequence
;          C/ sequence bit vector
;       CALL STOSEQ
; Returns: +1: Failure
;          +2: Success

STOSEQ: SAVEAC <A,B>
       IFG. B                  ; must be .GE. 1
         CAMLE B,MBXMGS        ;  and .LE. number of messages
       ANSKP.                  ; was it?
       ELSE.                   ; clearly not!
         TAGMSG <NO Message sequence not in range>
         RET
       ENDIF.
       MOVEI A,-1(B)           ; copy sequence
       IDIVI A,^D36            ; split into vector index and bit number
       ADD A,C                 ; get vector address
       MOVE B,BITS(B)          ; get the bit
       IORM B,(A)              ; set the bit
       RETSKP

; Dispatch to command service routines based on a sequence
; Accepts: A/ pointer to type string
;          B/ dispatch address
;          SEQLST/ message sequence bit vector
;       CALL SEQDSP
; Returns +1: Failure
;         +2: Success, must output OK message

SEQDSP: SAVEAC <A,B,C>
       ACVAR <<VEC,2>,SEQ,PTR>
       STKVAR <TYPE,DSP>
       MOVEM A,TYPE            ; save type
       MOVEM B,DSP
       MOVE A,[OWGP. 7,OUTBFR] ; initialize buffer pointer
       SETZ PTR,               ; and sequence pointer
       MOVE VEC,SEQLST         ; get first word from bit vector
       DO.
         JFFO VEC,.+2          ; find a bit out of it
         IFSKP.
           MOVE SEQ,PTR        ; get vector index
           IMULI SEQ,^D36      ; times number of bits in vector element
           ADDI SEQ,1(VEC+1)   ; plus bit position gives this sequence
           ANDCM VEC,BITS(VEC+1) ; flush this bit for next time
           HRROI B,[ASCIZ/* /] ; mark unsolicited
           CALL BFSOUT
           MOVE B,SEQ          ; get sequence again
           CALL BFNOUT         ; output sequence
           MOVE B,TYPE         ; output type
           CALL BFSOUT
           MOVE B,SEQ          ; get sequence again
           CALL @DSP           ; dispatch to it
            LOOP.              ; ok, get next in list
           RET                 ; sequence aborted prematurely
         ELSE.
           CAIN PTR,SEQLSN     ; at end?
            EXIT.              ; yes, done with sequence
           MOVE VEC,SEQLST+1(PTR) ; get next word from bit vector
           AOJA PTR,TOP.       ; charge on
         ENDIF.
       ENDDO.
       LDB C,[POINT 30,A,35]   ; get trailing address
       SUB C,[OUTBFR]          ; compute number of fullwords comsumed
       IMULI C,5               ; number of characters in word
       LDB A,[POINT 6,A,5]     ; get position of final byte
       ADDI C,-61(A)           ; add residual byte count
       MOVX A,.PRIOU           ; now blat the buffer
       MOVE B,[OWGP. 7,OUTBFR]
       SOUTR%
        ERJMP .+1
       RETSKP                  ; done

       ENDSV.
       ENDAV.

; Get a message sequence list
; Accepts: B/ pointer to string
;       CALL GETSEQ
; Returns: +1: Failed
;          +2: Success, A/ delimiter, B/ updated string pointer

GETSEQ: SAVEAC <C>
       STKVAR <SEQTMP>
       SETZM SEQLST            ; initialize sequence list
       MOVE A,[SEQLST,,SEQLST+1]
       BLT A,SEQLST+SEQLSN-1
       MOVE A,B                ; copy string pointer
       DO.
         MOVX C,^D10           ; get a sequence
         NIN%
          ERJMP SYNERR         ; barf if bad
         LDB C,A               ; get delimiter
         CAIE C,":"            ; multiple sequence?
         IFSKP.
           MOVEM B,SEQTMP      ; yes, save starting sequence temporarily
           MOVX C,^D10         ; get trailing sequence
           NIN%
            ERJMP SYNERR
           EXCH B,SEQTMP       ; get starting sequence
           DO.
             XMOVEI C,SEQLST
             CALL STOSEQ       ; store the sequence
              RET
             CAMN B,SEQTMP     ; end of sequence?
              EXIT.            ; yes, done
             CAMG B,SEQTMP     ; sequence going up?
              AOJA B,TOP.      ; yes, increment sequence
             SOJA B,TOP.       ; no, decrement sequence
           ENDDO.
         ELSE.
           XMOVEI C,SEQLST
           CALL STOSEQ         ; store this sequence
            RET
         ENDIF.
         LDB C,A               ; get delimiter
         IFN. C
           CAIN C,.CHSPC       ; end of list?
         ANSKP.
           CAIN C,","          ; another sequence coming?
            LOOP.              ; yes, get it!
           JRST SYNERR
         ENDIF.
       ENDDO.
       MOVE B,A                ; return updated pointer
       MOVE A,C                ; and delimiter
       RETSKP

       ENDSV.
      SUBTTL Attribute parsing

; Get a message attribute name
; Accepts: B/ pointer to string
;       CALL GETATT
; Returns +1: Failed
;         +2: Success, A/ delimiter, B/ updated string pointer,
;               C/ dispatch vector

GETATT: STKVAR <ATTPTR>
       MOVEM B,ATTPTR          ; save attribute pointer
       MOVSI C,-ATTTBL         ; length of command table
       DO.
         HLRO A,ATTTAB(C)      ; point to command string
         MOVE B,ATTPTR         ; point to base
         STCMP%                ; compare strings
         JUMPE A,ENDLP.        ; match?
         IFXN. A,SC%SUB        ; if subset
           ILDB A,B            ; get delimiting byte
           CAIE A,")"          ; is it the end of a list?
            CAIN A,.CHSPC      ; was it a space?
             EXIT.             ; yes, win with another argument coming
         ENDIF.
         AOBJN C,TOP.          ; try next command
         TAGMSG <BAD Invalid attribute requested>
         RET
       ENDDO.
       HRRZ C,ATTTAB(C)        ; get address of dispatch pair
       RETSKP

       ENDSV.

; Attribute names

DEFINE ATT (NAME,FETCH,STORE) <[ASCIZ/'NAME'/],,[FETCH,,STORE]>

ATTTAB: ATT Envelope,.FTENV,.STBAD
       ATT +Flags,.FTFLG,.STPFL
       ATT -Flags,.FTFLG,.STMFL
       ATT Flags,.FTFLG,.STFLG
       ATT InternalDate,.FTDAT,.STBAD
       ATT RFC822,.FT822,.STNIM
       ATT RFC822.Header,.FTHDR,.STNIM
       ATT RFC822.Size,.FTSIZ,.STBAD
       ATT RFC822.Text,.FTTXT,.STNIM
ATTTBL==.-ATTTAB
      SUBTTL File management routines

; Return size of file
; Accepts: A/ JFN of file
;       CALL FILSIZ
; Returns: +1 Always, A/ file size

FILSIZ: SAVEAC <B,C>
       STKVAR <<MBXSIZ,<.FBSIZ+1-.FBBYV>>>
       MOVE B,[<.FBSIZ+1-.FBBYV>,,.FBBYV] ; file size
       MOVEI C,MBXSIZ          ; into MBXSIZ
       GTFDB%
       LOAD B,FB%BSZ,MBXSIZ    ; get file byte size
       CAIE B,7                ; already the right byte size?
       IFSKP.
         MOVE A,<.FBSIZ-.FBBYV>+MBXSIZ ; yes, use exact byte count
       ELSE.
         MOVEI A,^D36          ; compute total bytes per word
         IDIVI A,(B)
         EXCH A,<.FBSIZ-.FBBYV>+MBXSIZ
         IDIV A,<.FBSIZ-.FBBYV>+MBXSIZ ; compute number of words
         IMULI A,5             ; compute # of characters
       ENDIF.
       RET

       ENDSV.

; Load mailbox, output number of messages
;       CALL GETMBX
; Returns +1: Failure
;         +2: Success

GETMBX: CALL MAPMBX             ; map in mailbox
        RET                    ; percolate error
       SETZM MBXMGS            ; initially no messages
       SETZM MBXNMS
       MOVE A,[OWGP. 7,MBXBUF] ; starting pointer
       MOVE B,MBXBSZ           ; number of bytes to parse
       CALL MBXPRS             ; parse mailbox
       IFNSK.
         TAGMSG <NO Message file is not in TOPS-20 mail format>
         CALLRET CLSMBX
       ENDIF.
       TMSG <* >
       MOVEI A,.PRIOU          ; output number of messages we have now
       MOVE B,MBXMGS
       MOVX C,^D10
       NOUT%
        ERCAL FATAL
       TMSG < EXISTS
* >
       MOVEI A,.PRIOU          ; output number of messages we have now
       MOVE B,MBXNMS
       MOVX C,^D10
       NOUT%
        ERCAL FATAL
       TMSG < RECENT
>
       RETSKP

; Map mailbox
;       CALL MAPMBX
; Returns +1: Failure
;         +2: Success

MAPMBX: SAVEAC <A,B,C>
       STKVAR <MBXPGS>
       HRRZ A,MBXJFN           ; page 0,,JFN
       FFFFP%                  ; find size of contiguous file pages
        ERCAL FATAL
       HRRZM A,MBXPGS          ; save # of mailbox pages
       MOVE A,MBXBSZ
       IDIVI A,5000            ; make into pages
       SKIPE B                 ; if a remainder
        ADDI A,1               ; count one more page
       CAMG A,MBXPGS           ; is byte size reasonable?
       IFSKP.
         TAGMSG <NO Message file doesn't have valid size>
         CALLRET CLSMBX        ; close file off
       ENDIF.
       HRLZ A,MBXJFN           ; source JFN,,start at section 0
       MOVE B,[.FHSLF,,MBXSEC] ; our process,,mailbox section
       LDB C,[POINT 9,MBXPGS,26] ; get number of sections of file
       ADDI C,1                ; plus 1 for fractional section
       CAIG C,MBXSCN           ; too many sections?
       IFSKP.
         TAGMSG <NO Message file too large>
         CALLRET CLSMBX
       ENDIF.
       TXO C,SM%RD             ; read access,,this many sections
       SMAP%
        ERCAL FATAL
       RETSKP

       ENDSV.

; Parse a mailbox
; Accepts: A/ pointer to mailbox to parse
;          B/ number of bytes to parse
;       CALL MBXPRS
; Returns: +1 Bad format file
;          +2 Success, MBXMGS incremented appropriately

HDRBFL==^D20                    ; length of header buffer

MBXPRS: SAVEAC <A,B,C,D>
       ACVAR <M>               ; holds current message
       STKVAR <TPTR,<HDRBUF,HDRBFL>>
       JUMPLE B,RSKP           ; sanity check
       ADJBP B,A               ; determine trailing pointer in B
       MOVEM B,TPTR
       DO.
         MOVE M,MBXMGS         ; current message number
         IMULI M,MSGLEN        ;  times length of block
         DO.
           CAMN A,TPTR         ; gotten to end of file yet?
            RETSKP             ; yes, all done
           MOVEM A,MSGIPT(M)   ; save start of internal pointer
           ILDB C,A            ; sniff past any nulls
           JUMPE C,TOP.
         ENDDO.
         MOVE B,[POINT 7,HDRBUF] ; set up header copy buffer
         IDPB C,B              ; store this first byte there
         MOVX D,<5*HDRBFL>-2   ; number of bytes left in header buffer
         DO.
           CAMN A,TPTR         ; gotten to end of file?
            RET                ; yes, garbage at end of file!
           ILDB C,A            ; get next byte
           JUMPE C,TOP.        ; ignore nulls
           CAIN C,.CHCRT       ; saw terminating CR yet?
           IFSKP.
             IDPB C,B          ; no, copy this byte to buffer
             SOJG D,TOP.       ; continue if more to go
             RET               ; totally bogus line
           ENDIF.
           SETZ C,             ; tie off string
           IDPB C,B
         ENDDO.
         CAMN A,TPTR           ; end of file?
          RET                  ; yes, bad format
         ILDB C,A              ; get expected LF
         CAIE C,.CHLFD         ; well?
          RET                  ; bad format mail file
         MOVEM A,MSGPTR(M)     ; save current pointer

; Parse time

         HRROI A,HDRBUF        ; parse header
         SETZ B,               ; parse date/time in normal format
         IDTIM%
          ERJMP R              ; bad date/time
         MOVEM B,MSGTAD(M)     ; save date/time
         CAMLE B,MBXRDT        ; later than the file read time?
          AOS MBXNMS           ; yes, bump number of recent messages
         LDB B,A               ; get delimiter
         CAIE B,","            ; was it what we expected?
          RET                  ; bad delimiter

; Parse size

         SETZB B,MSGHSZ(M)     ; start sizes at 0
         DO.
           ILDB C,A            ; get possible size byte
           CAIN C,";"          ; saw terminator?
           IFSKP.
             CAIL C,"0"        ; no, is it numeric?
              CAILE C,"9"
               RET             ; bad size character
             IMULI B,^D10      ; numeric, bump size a decade
             ADDI B,-"0"(C)    ; add in new byte
             LOOP.             ; get next byte
           ENDIF.
         ENDDO.
         MOVEM B,MSGSIZ(M)     ; save size

; Parse flags

         SETZ B,               ; start flags at 0
         DO.
           ILDB C,A            ; get possible flags byte
           CAIL C,"0"          ; no, is it numeric?
            CAILE C,"7"
           IFSKP.
             LSH B,3           ; numeric, bump flags a octade
             ADDI B,-"0"(C)    ; add in new byte
             LOOP.             ; get next byte
           ENDIF.
         ENDDO.
         MOVEM B,MSGFLG(M)     ; save flags
         IFN. C                ; if non-null after flags
           DO.
             CAIE C,.CHSPC     ; ignore spaces inserted by Hermes
              RET              ; else it is a bogon
             ILDB C,A          ; get next byte
             JUMPN C,TOP.      ; continue if non-null
           ENDDO.
         ENDIF.
         MOVE A,MSGSIZ(M)      ; get length of message
         ADJBP A,MSGPTR(M)     ; get pointer after end of this message
         LDB B,[POINT 30,A,35] ; get address of this pointer
         LDB C,[POINT 30,TPTR,35] ; and of trailing pointer
         CAMLE B,C             ; message extends past end of file?
          RET                  ; sorry, this file is bogus
         CAME B,C              ; at same address as end of file?
         IFSKP.
           LDB B,[POINT 6,A,5] ; yes, get position of this pointer
           LDB C,[POINT 6,TPTR,5] ; and of trailing pointer
           CAMLE B,C           ; if .LE. trailing still could be ok
            RET                ; extends beyond end of file
         ENDIF.
         SETZM MSGENV(M)       ; don't have any envelope yet
         AOS B,MBXMGS          ; count up another message
         CAIG B,MAXMGS         ; more than we support?
          LOOP.
         RET                   ; too many messages!
       ENDDO.

       ENDSV.
       ENDAV.

; Find header size for message indexed in B

FNDHSZ: SAVEAC <A,B>
       ACVAR <M>
       MOVE M,B                ; set up index
       MOVE A,MSGPTR(M)        ; get pointer for header
       SETZM MSGHSZ(M)
       MOVE B,MSGSIZ(M)        ; get size of message
       DO.                     ; look for end of header
REPEAT 2,<
         AOS MSGHSZ(M)         ; bump header size
         ILDB C,A              ; sniff at next byte
         CAIE C,.CHCRT         ; found CR?
          SOJG B,TOP.          ; no, sniff further
         SOJLE B,ENDLP.        ; yes or end of message, continue or exit
         AOS MSGHSZ(M)         ; bump header size
         ILDB C,A              ; sniff at next byte
         CAIE C,.CHLFD         ; found LF?
          SOJG B,TOP.          ; no, sniff further
         SOJLE B,ENDLP.        ; yes or end of message, continue or exit
>;REPEAT 2
       ENDDO.
       MOVE C,MSGHSZ(M)        ; return header size
       RET

       ENDAV.

; Open current mailbox for write
;       CALL MBXWRT
; Returns +1: Failed
;         +2: Success, A/ write JFN
;  Note: This routine inserts its own unwind mechanism on the stack;
; consequently, any prior STKVAR context is invalidated.  TRVAR's are
; okay though.

MBXWRT: IFQN. F%RON             ; always fail if read-only
         TAGMSG <NO Can't get read-only mailbox for write>
         RET
       ENDIF.
       POP P,A                 ; get return PC of caller
       SAVEAC <B,C>            ; silly
       STKVAR <RETADR,MBXJF2,<FILBUF,^D60>>
       MOVEM A,RETADR          ; save return address
       HRROI A,FILBUF          ; get copy of mailbox file name
       MOVE B,MBXJFN
       MOVX C,JS%SPC           ; entire spec please
       JFNS%
        ERCAL FATAL
       MOVX A,GJ%OLD!GJ%SHT    ; now get a write JFN on it
       HRROI B,FILBUF
       GTJFN%
       IFJER.
         TAGMSG <NO Can't get mailbox for write>
         CALL ERROUT
         JRST @RETADR
       ENDIF.
       MOVEM A,MBXJF2          ; save JFN

; Now open the file

       DO.
         MOVX B,<<FLD 7,OF%BSZ>!OF%RD!OF%WR!OF%DUD> ; now open for write
         OPENF%
         IFJER.
           CAIE A,OPNX9        ; file busy is probably okay
           IFSKP.
             MOVX A,^D2000     ; wait two seconds and try again
             DISMS%
             MOVE A,MBXJF2     ; get back JFN
             LOOP.
           ENDIF.
           TAGMSG <NO Can't open mailbox for write>
           CALL ERROUT
           MOVE A,MBXJF2       ; flush the JFN
           RLJFN%
            ERJMP .+1
           JRST @RETADR
         ENDIF.
       ENDDO.
       AOS CX,RETADR           ; file open, set up for "skip" return
       CALL (CX)               ; "return" to caller as coroutine
        TRNA                   ; caller wants non-skip
         AOS (P)               ; caller wants skip

; Here to force any file data or FDB updates that were done before

       HRLZ A,MBXJF2           ; write JFN,,page 0
       MOVX B,MBXSCN*^D512     ; all possible file pages
       UFPGS%                  ; write the pages
        ERCAL FATAL
       GTAD%                   ; get the time now
       MOVE C,A                ; put it in C for CHFDB% below
       MOVE A,MBXJF2           ; get back our JFN
       HRLI A,.FBREF           ; prepare to step on read time
       SETO B,                 ; change all bits
       CHFDB%                  ; set the new read time and update FDB
        ERCAL FATAL
       CLOSF%                  ; close the file
        ERJMP .+1              ; error shouldn't happen
       SETZ A,                 ; trash this AC
       RET                     ; return

       ENDSV.

; Close current mailbox

CLSMBX: SAVEAC <A,B,C>
       SETO A,                 ; unmap the file
       MOVE B,[.FHSLF,,MBXSEC] ; from mailbox section
       MOVX C,MBXSCN           ; this many sections
       SMAP%
        ERCAL FATAL
       MOVX A,.DEQID           ; get rid of any locks we got
       MOVX B,REQID
       DEQ%
        ERJMP .+1
       SKIPE A,MBXJFN          ; close file off
        CLOSF%
         ERJMP .+1
       SETZM MBXJFN            ; no mailbox selected any more
       SETO A,                 ; delete the index page
       SKIPA B,.+1             ; MACRO is a noisome pile of reptile dung
LODIPG:! .FHSLF,,IDXPAG
       MOVX C,PM%CNT!1         ; 1 page
       PMAP%                   ; pffft
        ERJMP .+1
       SKIPE A,IDXJFN          ; close index off
        CLOSF%
         ERJMP .+1
       SETZM IDXJFN            ; no index any more
       SETZM IDXADR
       SETZM FLGTAB            ; clear old keywords
       MOVE A,[FLGTAB,,FLGTAB+1]
       BLT A,FLGTAB+NKYFLG-1
       MOVE A,[FREE]           ; re-initialize free storage pointer
       MOVEM A,FSFREE
       RET
      SUBTTL Miscellaneous subroutines

; Outputs a CRLF

CRLF:   SAVEAC <A,B,C>
       MOVX A,.PRIOU           ; use SOUTR% for non-TTY primary I/O
       HRROI B,[ASCIZ/
/]
       SETZ C,
       SOUTR%                  ; this pushes the text on networks
        ERJMP .+1
       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
      SUBTTL Error handling

; Common routine called to output last error code's message

ERROUT: TMSG < - >
       MOVX A,.PRIOU
       HRLOI B,.FHSLF          ; dumb ERSTR%
       SETZ C,
       ERSTR%
        JRST ERRUND            ; undefined error number
        NOP                    ; can't happen
       RET

ERRUND: TMSG <Undefined error >
       MOVX A,.FHSLF           ; get error number
       GETER%
       MOVX A,.PRIOU           ; output it
       HRRZS B                 ; only right half where error code is
       MOVX C,^D8              ; in octal
       NOUT%
        ERJMP R                ; ignore error here
       RET

; Various error messages

DMPTAG: MOVX A,.PRIOU           ; dump current command's tag
       HRROI B,CMDBUF
       MOVN C,TAGCNT
       SOUT%
       RET

BADCOM: TAGMSG <BAD Command unrecognized: >
DMPCOM: HRROI A,CMDBUF
       PSOUT%
       RET

BADARG: TAGMSG <BAD Argument given when none expected: >
       CALLRET DMPCOM

MISARG: TAGMSG <BAD Missing required argument: >
       CALLRET DMPCOM

NOMBX:  TAGMSG <NO No mailbox selected>
       RET

NOTLOG: TAGMSG <NO Not logged in yet>
       RET

SYNERR: TAGMSG <BAD Syntax error in command: >
       CALLRET DMPCOM

; Fatal errors arrive here

FATAL:  MOVEM 17,FATACS+17      ; save ACs in FATACS for debugging
       MOVEI 17,FATACS         ; save from 0 => FATACS
       BLT 17,FATACS+16        ; ...to 16 => FATACS+16
       MOVE 17,FATACS+17       ; restore AC17
       MOVX A,.PRIIN           ; flush TTY input
       CFIBF%
        ERJMP .+1
       CALL CRLF               ; new line first
       TMSG <* BYE Fatal system error>
       CALL ERROUT             ; output last JSYS error
       TMSG <, >
       MOVE A,(P)              ; get PC
       MOVE A,-2(A)            ; get instruction which lost
       CALL SYMOUT             ; output symbolic instruction if possible
       TMSG < at PC >
       POP P,A
       SUBI A,2                ; point PC at actual location of the JSYS
       CALL SYMOUT             ; output symbolic name of the PC
       JRST IMPERR

;  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 value in A.

SYMOUT: ACVAR <SYM,VAL>
       MOVEM A,VAL             ; save value
       SETZB C,SYM             ; no current program name or best symbol
       MOVE D,PDV+.PVSYM       ; symbol table vector pointer
       MOVE A,(D)              ; get length of vector
       DO.
         CAIGE A,4             ; another block?
          EXIT.                ; no - can't find symbol table
         LDB B,[POINT 6,1(D),5] ; get type of this table
         CAIN B,1              ; Radix-50 defined symbols?
         IFSKP.
           SUBI A,3            ; no, try next block
           ADDI D,3
           LOOP.
         ENDIF.
         LDB C,[POINT 30,1(D),35] ; found it, get table length
         MOVE D,2(D)           ; and table address
         DO.
           LDB A,[POINT 4,(D),3] ; symbol type
           IFN. A              ; 0=prog name (uninteresting)
             CAILE A,2         ; 1=global, 2=local
           ANSKP.
             MOVE A,1(D)       ; value of the symbol
             CAME A,VAL        ; exact match?
             IFSKP.
               MOVE SYM,D      ; yes, select it as best symbol
               EXIT.
             ENDIF.
             CAML A,VAL        ; smaller than value sought?
           ANSKP.
             SKIPE B,SYM       ; get best one so far if there is one
              CAML A,1(B)      ; compare to previous best
               MOVE SYM,D      ; current symbol is best match so far
           ENDIF.
           ADDI D,2            ; point to next symbol
           SUBI C,2            ; and count another symbol
           JUMPG C,TOP.        ; loop unless control count is exhausted
         ENDDO.

         IFN. SYM              ; if a best symbol found
           MOVE A,VAL          ; desired value
           SUB A,1(SYM)        ; less symbol's value = offset
           CAIL A,200          ; is offset small enough?
         ANSKP.
           MOVE A,(SYM)        ; symbol name
           TXZ A,<MASKB 0,3>   ; clear flags
           CALL SQZTYO         ; print symbol name
           SUB VAL,1(SYM)      ; difference between this and symbol's value
           JUMPE VAL,R         ; if no offset then done
           MOVX A,"+"          ; add + to the output line
           PBOUT%
         ENDIF.
       ENDDO.
       MOVX A,.PRIOU           ; and copy numeric offset to output
       MOVE B,VAL              ; value to output
       MOVX C,^D8
       NOUT%
        ERJMP R
       RET

       ENDAV.
      SUBTTL Interrupt stuff

; PSI blocks

PSITAB: PSIBLN                  ; length of block
       1,,LEVTAB               ; level table
       1,,CHNTAB               ; channel table
PSIBLN==.-PSITAB

LEVTAB: LEV1PC                  ; priority level table
       LEV2PC
       LEV3PC

CHNTAB: PHASE 0                 ; channel table
COFCHN:!1B5+<1,,COFINT>         ; carrier off channel
TIMCHN:!2B5+<1,,TIMINT>         ; timer channel
       REPEAT ^D36-.,<0>
       DEPHASE

; Set up PSIs

SETPSI: MOVX A,.FHSLF           ; set level/channel tables
       XMOVEI B,PSITAB
       XSIR%
        ERCAL FATAL
       EIR%                    ; enable PSIs
        ERCAL FATAL
       MOVX B,<1B<TIMCHN>!1B<COFCHN>> ; on these channels
       AIC%
        ERCAL FATAL
       MOVE A,[.TICRF,,COFCHN] ; arm for carrier off interrupts
       ATI%
;       CALLRET SETTIM

; Initialize the timer

SETTIM: MOVE A,[.FHSLF,,.TIMEL] ; tick the timer every 5 seconds
       MOVX B,^D5*^D1000
       MOVX C,TIMCHN
       TIMER%
        ERCAL FATAL
       RET

; Timer interrupt

TIMINT: DMOVEM A,IN2ACS         ; save ACs
       MOVEM C,IN2ACS+2
       AOSGE TIMOUT            ; has timer run out yet?
       IFSKP.
         MOVX A,.PRIIN         ; flush TTY input
         CFIBF%
          ERJMP .+1
         CALL CRLF             ; output CRLF
         TMSG <* BYE Autologout; idle for too long>
         XMOVEI A,IMPERR       ; dismiss to quit code
         TXO A,PC%USR
         MOVEM A,LEV2PC+1
       ELSE.
         CALL SETTIM           ; reinitialize the timer
       ENDIF.
       DMOVE A,IN2ACS          ; restore ACs
       MOVE C,IN2ACS+2
       DEBRK%

; Carrier-off interrupt

COFINT: CALL HANGUP             ; hang up the connection
       DEBRK%                  ; back out if continued
      SUBTTL Other randomness

; File defaults

POBOX:  ASCIZ/POBOX/            ; post office box device
BBOARD: ASCIZ/BBOARD/           ; bulletin board directory
INBOX:  ASCIZ/INBOX/            ; operating-system independent INBOX
MAIL:   ASCIZ/MAIL/             ; mail file filename
TXT:    ASCIZ/TXT/              ; mail file extension

; Bits, indexed by their bit position

..BIT==-1                       ; init mechanism
BITS:   REPEAT ^D36,<1B<...BIT==...BIT+1>>

; Literals

..LIT:  XLIST                   ; save trees during LIT
       LIT                     ; generate literals
..VAR:!VAR                      ; generate variables (there shouldn't be any)
IFN .-...VAR,<.FATAL Variables illegal in this program>
       LIST

; Entry vector

EVEC:   JRST MAPSER             ; START address
       JRST MAPREE             ; REENTER address
       MAPVER                  ; version
EVECL==.-EVEC

       .ENDPS

; Program Data Vector - filled in by LINK

       .PSECT PDV,PDVORG       ; define PDV psect
       .ENDPS

; Define start address and version in PDV

DEFINE DEFPDV (NAME,DATA) <
       .TEXT "/PVDATA:'NAME':#'DATA"
>;DEFINE DEFPDV

       DEFPDV START,\CODORG    ; define start address
       DEFPDV VERSION,\MAPVER  ; define version

       END EVECL,,EVEC         ; establish entry vector