program mail (input, output, mailbox, users, message);

  {**************************************************************}
  {                                                              }
  { Copyright (c) 1988            Bob Schor                      }
  {                               Eye and Ear Hospital           }
  {                               230 Lothrop Street             }
  {                               Pittsburgh, PA   15213         }
  {                                                              }
  { All rights reserved.  May not be copied without this notice. }
  {                                                              }
  {**************************************************************}

  {**************************************************************}
  {                                                              }
  { Copyright (c) 1989            Bob Schor                      }
  {                               Eye and Ear Institute          }
  {                               203 Lothrop Street             }
  {                               Pittsburgh, PA   15213         }
  {                                                              }
  { All rights reserved.  May not be copied without this notice. }
  {                                                              }
  {**************************************************************}

  { Program to implement sending mail messages to any valid user }

  { Device BOX: will point to the mail-box areas.  It will hold an address
   . file (MAIL.ADR) of possible users, a mailbox directory (MAIL.BOX)
   . with pointers to actual mail files, and the mail files themselves
   . (MAIL.nnn) }

  { Current files and structures --

   MAIL.ADR : List of possible user names (with %, * wild-cards),
   .          size "namesize", followed by PPN number (unique identifier).
   .          Tabs can be used to format this file; they will be treated as
   .          spaces.  Multiple aliases can be present.  The first-encountered
   .          name will be used as the "formal" address.

   MAIL.BOX : Text list of users (PPN) and file ids.  Format is
   .          recipient PPN, sender PPN -- two integers each,
   .          Box # -- 0 .. 999, box number (extension) of message
   .          Flag (character, N, O), for New or Old messages

   MAIL.nnn : Text files of messages.  One message file can go to multiple
   .          recipients; it will be deleted when the last person has read
   .          it.  The file numbers nnn will cycle from 000 to 999.
   }

  { Version 8.10 -- first incarnation }
  { Version 8.10 -- external ppn added }
  { Version 8.10 -- external filsta added, time-stamping of delivered mail }
  { Version 8.10 -- Read, Send, Check, Unsend options added }
  { Version 8.10 -- added file lock of mailbox }
  { Version 8.10 -- added ^C lockout, scca; terminalflag < 0 --> ^C^C }
  { Version 8.10 -- handle missing mail.box lock correctly }
  { Version 9.5 -- can send to multiple recipients (e.g. bob, alan & v* ) }
  { Version 9.5 -- each recipient can be query-flagged }
  { Version 9.5 -- external routine SCCA renamed CTRLC, SYSLIB conflict }
  { Version 9.5 -- cancelmail commands changed slightly (P, R interchanged) }
  { Version 9.6 -- minor subrange bug fixed in "showlist" }
  { Version 9.6 -- switch logic improved }

CONST
  version = 'MAIL      Version 9.6';

  tab = 11B;
  switchflag = '/';
  queryswitch = 'Q';
  namesize = 20;
  tempmsgname = 'box:temp.msg        ';
  addressname = 'box:mail.adr        ';
  mailboxname = 'box:mail.box        ';
  messagename = 'box:mail.           ';
  defaultname = 'DK:MAIL.MSG         ';
  maxboxnumber = 999;
TYPE
  nameindextype = 1 .. namesize;
  enameindextype = 0 .. namesize;
  nametype = PACKED ARRAY [nameindextype] OF char;
  unsigned = 0 .. 177777B;
  cardinal = 0 .. maxint;
  idtype = RECORD
	     proj : unsigned;
	     prog : unsigned
	   END;
  boxnumbertype = 0 .. maxboxnumber;
  mailboxstatustype = (newmail, justread, oldmail, deleted, saved);
  mailboxlink = ^mailboxentry;
  mailboxentry = RECORD
		   nextbox : mailboxlink;
		   recipid : idtype;
		   senderid : idtype;
		   boxnumber : boxnumbertype;
		   status : mailboxstatustype
		 END;
  aliaslink = ^aliasentry;
  aliasentry = RECORD
		 nextalias : aliaslink;
		 aliasname : nametype
	       END;
  userlistlink = ^userlistentry;
  userlistentry = RECORD
		    next : userlistlink;
		    uppn : idtype;
		    alias : aliaslink
		  END;
  mailflagtype = (mailtoread, somemailread, nomailtoread, allfinished);
  answerset = SET OF char;
VAR
  userid : idtype;
  boxname : nametype;
  mailbox, users, message : text;
  mailboxlist : mailboxlink;
  nextboxnumber : boxnumbertype;
  legalusers : userlistlink;
  newmessages, oldmessages : cardinal;
  mailflag : mailflagtype;

  FUNCTION flock (VAR name : nametype) : boolean; EXTERNAL;  { locks file }

  PROCEDURE ctrlc (VAR termflag : integer); EXTERNAL;  { catches ^C }

  PROCEDURE ppn (VAR project, programmer : unsigned); EXTERNAL;

  PROCEDURE filsta (VAR name : nametype;    { returns size, creation date }
		    VAR filesize : integer; { and time of files (name) }
		    VAR day, month, year,
		    hour, minute, second : cardinal); EXTERNAL;

  FUNCTION exists (VAR filevariable : text; filename : nametype) : boolean;

    { see if file exists -- does not leave file open }

  VAR
    filelength : integer;

   BEGIN   { exists }
     reset (filevariable, filename, , filelength);
     exists := filelength <> -1;
     close (filevariable)
   END;

  FUNCTION defexists (VAR filevariable : text; filename : nametype) : boolean;

    { see if file exists, with defaults -- does not leave file open }

  VAR
    filelength : integer;

   BEGIN   { defexists }
     reset (filevariable, filename, defaultname, filelength);
     defexists := filelength <> -1;
     close (filevariable)
   END;

  FUNCTION namelength (name : nametype) : enameindextype;

    { returns length of non-blank string (used for formatting) }

    FUNCTION nl (index : enameindextype) : enameindextype;

     BEGIN   { namelength }
       IF index = 0
	THEN nl := index
	ELSE
	IF name[index] <> ' '
	 THEN nl := index
	 ELSE nl := nl (pred(index))
     END;

   BEGIN   { namelength }
     namelength := nl (namesize)
   END;

  FUNCTION sameid (firstid, secondid : idtype) : boolean;

   BEGIN   { sameid }
     sameid := ((firstid.proj = secondid.proj) AND
		(firstid.prog = secondid.prog))
   END;

  PROCEDURE initialize;

  VAR
    terminalflag : integer;

    PROCEDURE buildmailboxlist;

      { builds list of mail from MAIL.BOX file,
       decides on "next" box to fill }

      FUNCTION listfrommailbox : mailboxlink;

      VAR
	newbox : mailboxlink;

	FUNCTION boxstatus : mailboxstatustype;

	 BEGIN   { boxstatus }
	   IF eoln (mailbox)
	    THEN boxstatus := newmail
	    ELSE
	    IF mailbox^ IN ['N', 'n']
	     THEN boxstatus := newmail
	     ELSE
	     IF mailbox^ IN ['O', 'o']
	      THEN boxstatus := oldmail
	      ELSE
	       BEGIN
		 get (mailbox);
		 boxstatus := boxstatus
	       END
	 END;

       BEGIN   { listfrommailbox }
	 IF eof (mailbox)
	  THEN listfrommailbox := NIL
	  ELSE
	   BEGIN
	     new (newbox);
	     WITH newbox^ DO
	      BEGIN
		WITH recipid DO read (mailbox, proj, prog);
		WITH senderid DO read (mailbox, proj, prog);
		read (mailbox, boxnumber);
		status := boxstatus;
		readln (mailbox);
		nextbox := listfrommailbox
	      END;
	     listfrommailbox := newbox
	   END
       END;

     BEGIN   { buildmailboxlist }
       IF exists (mailbox, mailboxname)
	THEN
	 BEGIN
	   reset (mailbox, mailboxname);
	   mailboxlist := listfrommailbox;
	   close (mailbox)
	 END
	ELSE mailboxlist := NIL
     END;

    PROCEDURE builduserlist;

      { builds a list of registered "users" from MAIL.ADR.  When multiple
       names are associated with a single PPN, they are considered aliases
       of the same person; the first name encountered is considered the
       "official" name. }

      PROCEDURE addnametolist;

      VAR
	thisname : nametype;
	thisid : idtype;

	PROCEDURE getthisname (index : nameindextype);

	VAR
	  letter : char;

	  PROCEDURE fillwithspaces (index : nameindextype);

	  VAR
	    idx : nameindextype;

	   BEGIN   { fillwithspaces }
	     FOR idx := index TO namesize DO thisname[idx] := ' '
	   END;

	 BEGIN   { getthisname }
	   read (users, letter);
	   IF letter = chr(tab)
	    THEN fillwithspaces (index)
	    ELSE
	    IF eoln (users)
	     THEN fillwithspaces (index)
	     ELSE
	      BEGIN
		thisname[index] := letter;
		IF index < namesize
		 THEN getthisname (succ(index))
	      END
	 END;

	FUNCTION updatedlist (remaininglist : userlistlink) :
	  userlistlink;

	  FUNCTION newlist (nextlist : userlistlink; id : idtype;
			    aliaslist : aliaslink) : userlistlink;

	  VAR
	    thislist : userlistlink;

	   BEGIN   { newlist }
	     new (thislist);
	     WITH thislist^ DO
	      BEGIN
		next := nextlist;
		uppn := id;
		alias := aliaslist
	      END;
	     newlist := thislist
	   END;

	  FUNCTION updatedalias (aliaslist : aliaslink) : aliaslink;

	   BEGIN   { updatedalias }
	     IF aliaslist = NIL
	      THEN
	       BEGIN
		 new (aliaslist);
		 WITH aliaslist^ DO
		  BEGIN
		    nextalias := NIL;
		    aliasname := thisname
		  END
	       END
	      ELSE WITH aliaslist^ DO  nextalias := updatedalias (nextalias);
	     updatedalias := aliaslist
	   END;

	  FUNCTION precedes (firstid, secondid : idtype) : boolean;

	   BEGIN   { precedes }
	     IF firstid.proj = secondid.proj
	      THEN precedes := firstid.prog < secondid.prog
	      ELSE precedes := firstid.proj < secondid.proj
	   END;

	 BEGIN   { updatedlist }
	   IF remaininglist = NIL
	    THEN updatedlist := newlist (NIL, thisid, updatedalias(NIL))
	    ELSE WITH remaininglist^ DO
	     BEGIN
	       IF precedes (thisid, uppn)
		THEN
		 BEGIN
		   next := newlist (next, uppn, alias);
		   uppn := thisid;
		   alias := updatedalias (NIL)
		 END
		ELSE
		IF sameid (thisid, uppn)
		 THEN alias := updatedalias (alias)
		 ELSE next := updatedlist (next);
	       updatedlist := remaininglist
	     END
	 END;

       BEGIN   { addnametolist }
	 getthisname (1);
	 WITH thisid DO readln (users, proj, prog);
	 legalusers := updatedlist (legalusers)
       END;

     BEGIN   { builduserlist }
       legalusers := NIL;
       reset (users, addressname);
       WHILE NOT eof (users) DO addnametolist;
       close (users)
     END;

    FUNCTION messagecount (mailstatus : mailboxstatustype) : cardinal;

      FUNCTION checkeachbox (remainingboxes : mailboxlink) : cardinal;

       BEGIN   { checkeachbox }
	 IF remainingboxes = NIL
	  THEN checkeachbox := 0
	  ELSE WITH remainingboxes^ DO
	  IF sameid (userid, recipid) AND (mailstatus = status)
	   THEN checkeachbox := succ(checkeachbox (nextbox))
	   ELSE checkeachbox := checkeachbox (nextbox)
       END;

     BEGIN   { messagecount }
       messagecount := checkeachbox (mailboxlist)
     END;

   BEGIN   { initialize }
     writeln;
     writeln (version);
     writeln;
     boxname := mailboxname;
     IF NOT exists (mailbox, boxname)
      THEN
       BEGIN
	 rewrite (mailbox, boxname);
	 close (mailbox)
       END;
     IF flock (boxname)
      THEN
       BEGIN
	 IF exists (users, addressname)
	  THEN
	   BEGIN
	     ctrlc (terminalflag);   { catch ^C }
	     WITH userid DO ppn (proj, prog);
	     buildmailboxlist;
	     builduserlist;
	     mailflag := mailtoread;
	     newmessages := messagecount (newmail);
	     oldmessages := messagecount (oldmail);
	     IF newmessages > 0
	      THEN writeln ('You have unread mail')
	      ELSE
	      IF oldmessages > 0
	       THEN writeln ('You still have previously-read mail')
	       ELSE
		BEGIN
		  writeln ('You have no mail waiting');
		  mailflag := nomailtoread
		END
	   END
	  ELSE
	   BEGIN
	     writeln ('MAIL - F - Address file ',
		      addressname:namelength(addressname), ' missing');
	     mailflag := allfinished
	   END
       END
      ELSE
       BEGIN
	 writeln ('MAIL - W - Busy with another user, try again later');
	 mailflag := allfinished
       END
   END;

  FUNCTION uppercase (letter : char) : char;

   BEGIN   { uppercase }
     IF letter IN ['a' .. 'z']
      THEN uppercase := chr(ord(letter) - ord('a') + ord('A'))
      ELSE uppercase := letter
   END;

  FUNCTION legalanswer (possibleanswers : answerset) : char;

  VAR
    answer : char;

    PROCEDURE informoferror;

    VAR
      answer : char;
      commabelongshere : boolean;

     BEGIN   { informoferror }
       write ('Error -- legal answers are ');
       IF ' ' IN possibleanswers
	THEN
	 BEGIN
	   write ('[space]');
	   commabelongshere := true
	 END
	ELSE commabelongshere := false;
       FOR answer := succ(' ') TO 'Z' DO
       IF answer IN possibleanswers
	THEN
	 BEGIN
	   IF commabelongshere
	    THEN write (', ');
	   commabelongshere := true;
	   write (answer:1)
	 END;
       write (' :  ')
     END;

   BEGIN  { legalanswer }
      REPEAT
       IF eoln
	THEN
	 BEGIN
	   readln;
	   answer := ' '
	 END
	ELSE readln (answer);
       answer := uppercase(answer);
       IF NOT (answer IN possibleanswers)
	THEN informoferror
      UNTIL answer IN possibleanswers;
     legalanswer := answer
   END;

  FUNCTION answerisyes : boolean;

   BEGIN   { answerisyes }
     answerisyes := legalanswer (['Y', 'N', ' ']) = 'Y'
   END;

  PROCEDURE createboxname (boxnumber : boxnumbertype);

    { creates the file name of mailbox, BOX:MAIL.nnn, given the box number }

    FUNCTION digit (number : cardinal) : char;

     BEGIN   { digit }
       digit := chr(ord('0') + number)
     END;

    PROCEDURE cmn (index : nameindextype; number : boxnumbertype;
		   count : cardinal);

     BEGIN   { cmn }
       boxname[index] := digit (number MOD 10);
       IF count < 3
	THEN cmn (pred(index), number DIV 10, succ(count))
     END;

   BEGIN   { createboxname }
     boxname := messagename;
     cmn (namelength(messagename)+3, boxnumber, 1)
   END;

  PROCEDURE showdeliverytime (boxnumber : boxnumbertype);

    { utilize file creation date and time }

  VAR
    size : integer;
    day, month, year, hour, minute, second : cardinal;

    PROCEDURE write2 (number : cardinal);

     BEGIN   { write2 }
       IF number < 10
	THEN write ('0', number:1)
	ELSE write (number:2)
     END;

    PROCEDURE writemon (number : cardinal);

    TYPE
      monthtype = 1 .. 12;
    VAR
      month : monthtype;

     BEGIN   { writemon }
       IF (1 <= number) AND (number <= 12)
	THEN
	 BEGIN
	   month := number;
	   CASE month OF
	     1  : write ('Jan');
	     2  : write ('Feb');
	     3  : write ('Mar');
	     4  : write ('Apr');
	     5  : write ('May');
	     6  : write ('Jun');
	     7  : write ('Jul');
	     8  : write ('Aug');
	     9  : write ('Sep');
	     10 : write ('Oct');
	     11 : write ('Nov');
	     12 : write ('Dec')
	    END
	 END
     END;

   BEGIN   { showdeliverytime }
     createboxname (boxnumber);
     filsta (boxname, size, day, month, year, hour, minute, second);
     write ('delivered ');
     write (day:2);
     write ('-');
     writemon (month);
     write ('-');
     write2 (year);
     write (', ');
     write2 (hour);
     write (':');
     write2 (minute);
     write (':');
     write2 (second);
   END;

  PROCEDURE readmailinbox;

  CONST
    linesonscreen = 24;
  VAR
    linesout : cardinal;
    letter : char;

    FUNCTION endofmessage : boolean;

    VAR
      flag : char;

      PROCEDURE eraseyourself;

      CONST
	escape = 33B;

       BEGIN   { eraseyourself }
	 write (chr(escape), 'M', chr(escape), '[K')
       END;

     BEGIN   { endofmessage }
       IF eof (message)
	THEN endofmessage := true
	ELSE
	IF linesout >= pred(linesonscreen)
	 THEN
	  BEGIN
	    write ('[More ... Q to quit] ');
	    linesout := 0;
	    IF eoln
	     THEN
	      BEGIN
		readln;
		endofmessage := false
	      END
	     ELSE
	      BEGIN
		readln (flag);
		endofmessage := flag IN ['Q', 'q']
	      END;
	    eraseyourself
	  END
	 ELSE endofmessage := false
     END;

   BEGIN   { readmailinbox }
     reset (message, boxname);
     writeln;
     linesout := 0;
     WHILE NOT endofmessage DO
      BEGIN
	WHILE NOT eoln(message) DO
	 BEGIN
	   read (message, letter);
	   write (letter)
	 END;
	readln (message);
	writeln;
	linesout := succ(linesout)
      END;
     close (message)
   END;

  PROCEDURE writenewmailbox;

    { rewrites MAIL.BOX, reflecting changes in mailbox list }

    PROCEDURE output (list : mailboxlink);

     BEGIN   { output }
       WHILE list <> NIL DO
       WITH list^ DO
	BEGIN
	  WITH recipid DO write (mailbox, proj:1, ', ', prog:1, ' ':3);
	  WITH senderid DO write (mailbox, proj:1, ', ', prog:1, ' ':3);
	  write (mailbox, boxnumber:1, ' ':2);
	  CASE status OF
	    newmail : write (mailbox, 'N');
	    oldmail : write (mailbox, 'O')
	   END;
	  writeln (mailbox);
	  list := nextbox
	END;
       close (mailbox)
     END;

   BEGIN   { writenewmailbox }
     rewrite (mailbox, mailboxname);
     output (mailboxlist)
   END;

  PROCEDURE getcurrentmail;

    { read and dispose of mail sent to user }

    PROCEDURE readthemail (mailstatus : mailboxstatustype;
			   remainingboxes : mailboxlink);

      FUNCTION shouldreadmessage (boxnumber: boxnumbertype;
				  fromwhom : idtype;
				  mailstatus : mailboxstatustype) : boolean;

	FUNCTION shouldread (remainingpeople : userlistlink) : boolean;

	 BEGIN   { shouldread }
	   IF remainingpeople = NIL
	    THEN
	     BEGIN
	       CASE mailstatus OF
		 newmail : write ('New mail from unknown sender, ');
		 oldmail : write ('Old mail from unknown sender, ')
		END;
	       showdeliverytime (boxnumber);
	       write (' -- ');
	       CASE legalanswer (['R', 'S', 'Y', 'N', ' ']) OF
		 'R', 'Y', ' ' : shouldread := true;
		 'S', 'N'      : shouldread := false
		END
	     END
	    ELSE WITH remainingpeople^, alias^ DO
	    IF sameid (fromwhom, uppn)
	     THEN
	      BEGIN
		CASE mailstatus OF
		  newmail : write ('New mail from ');
		  oldmail : write ('Old mail from ')
		 END;
		write (aliasname:namelength(aliasname), ', ');
		showdeliverytime (boxnumber);
		write (' -- ');
		CASE legalanswer (['R', 'S', 'Y', 'N', ' ']) OF
		  'R', 'Y', ' ' : shouldread := true;
		  'S', 'N'      : shouldread := false
		 END
	      END
	     ELSE shouldread := shouldread (next)
	 END;

       BEGIN   { shouldreadmessage }
	 shouldreadmessage := shouldread (legalusers)
       END;

      PROCEDURE readthismessage (box : mailboxlink);

	PROCEDURE decideondisposition (box : mailboxlink);

	VAR
	  disposition : char;

	  PROCEDURE discardmail (box : mailboxlink);

	   BEGIN   { discardmail }
	     WITH box^ DO
	      BEGIN
		CASE status OF
		  newmail : newmessages := pred(newmessages);
		  oldmail : oldmessages := pred(oldmessages)
		 END;
		status := deleted
	      END
	   END;

	  PROCEDURE rereadmail (box : mailboxlink);

	   BEGIN   { rereadmail }
	     WITH box^ DO
	     IF status = newmail
	      THEN
	       BEGIN
		 newmessages := pred(newmessages);
		 oldmessages := succ(oldmessages);
		 status := justread
	       END
	   END;

	  PROCEDURE savemail (box : mailboxlink);

	  VAR
	    msgfilename : nametype;

	    PROCEDURE movemessage (box : mailboxlink);

	    VAR
	      letter : char;

	     BEGIN   { movemessage }
	       WITH box^ DO
		BEGIN
		  createboxname (boxnumber);
		  reset (message, boxname);
		  rewrite (output, msgfilename, defaultname);
		  WHILE NOT eof(message) DO
		   BEGIN
		     WHILE NOT eoln(message) DO
		      BEGIN
			read (message, letter);
			write (output, letter)
		      END;
		     readln (message);
		     writeln (output);
		   END;
		  close (message);
		  close (output);
		  CASE status OF
		    newmail : newmessages := pred(newmessages);
		    oldmail : oldmessages := pred(oldmessages)
		   END;
		  status := saved
		END
	     END;

	   BEGIN   { savemail }
	     write ('As what should this message be saved [',
		    defaultname:namelength(defaultname), '] -- ');
	     readln (msgfilename);
	     IF defexists (message, msgfilename)
	      THEN
	       BEGIN
		 write ('File ', msgfilename:namelength(msgfilename),
			' already exists.  ');
		 write ('Overwrite?  ');
		 IF answerisyes
		  THEN movemessage (box)
		  ELSE decideondisposition (box)
	       END
	      ELSE movemessage (box)
	   END;

	 BEGIN   { decideondisposition }
	   write ('D(iscard mail), R(eread mail), S(ave mail)  ',
		  '[Reread] ?  ');
	   CASE legalanswer (['D', 'R', 'S', ' ']) OF
	     'D' : discardmail (box);
	     'R',
	     ' ' : rereadmail (box);
	     'S' : savemail (box)
	    END
	 END;

       BEGIN   { readthismessage }
	 WITH box^ DO createboxname (boxnumber);
	 IF exists (message, boxname)
	  THEN
	   BEGIN
	     readmailinbox;
	     writeln;
	     decideondisposition (box);
	     writeln
	   END
	  ELSE
	   BEGIN
	     writeln;
	     WITH box^ DO writeln ('MAIL - W - Message ', boxnumber:1,
				   ' unexpectedly missing!');
	     writeln
	   END
       END;

     BEGIN   { readthemail }
       WHILE remainingboxes <> NIL DO
       WITH remainingboxes^ DO
	BEGIN
	  IF sameid (userid, recipid) AND (mailstatus = status)
	   THEN
	   IF shouldreadmessage (boxnumber, senderid, mailstatus)
	    THEN readthismessage (remainingboxes)
	    ELSE writeln;
	  remainingboxes := nextbox
	END
     END;

    FUNCTION updated (remainingboxes : mailboxlink) : mailboxlink;

      FUNCTION messagefree (box : boxnumbertype) : boolean;

	FUNCTION nobodyisreading (remainingboxes : mailboxlink) : boolean;

	 BEGIN   { nobodyisreading }
	   IF remainingboxes = NIL
	    THEN nobodyisreading := true
	    ELSE WITH remainingboxes^ DO
	    IF box <> boxnumber
	     THEN nobodyisreading := nobodyisreading (nextbox)
	     ELSE
	     IF status IN [newmail, oldmail, justread]
	      THEN nobodyisreading := false
	      ELSE nobodyisreading := nobodyisreading (nextbox)
	 END;

       BEGIN   { messagefree }
	 messagefree := nobodyisreading (mailboxlist)
       END;

      PROCEDURE discardmessage (box : boxnumbertype);

       BEGIN   { discardmessage }
	 createboxname (box);
	 IF exists (message, boxname)
	  THEN
	   BEGIN
	     reset (message, boxname);
	     delete (message);
	     close (message)
	   END
       END;

     BEGIN   { updated }
       IF remainingboxes = NIL
	THEN updated := NIL
	ELSE
	WITH remainingboxes^ DO
	CASE status OF
	  newmail,
	  oldmail :
	   BEGIN
	     nextbox := updated (nextbox);
	     updated := remainingboxes
	   END;
	  justread :
	   BEGIN
	     status := oldmail;
	     nextbox := updated (nextbox);
	     updated := remainingboxes
	   END;
	  deleted,
	  saved :
	   BEGIN
	     updated := updated (nextbox);
	     IF messagefree (boxnumber)
	      THEN discardmessage (boxnumber);
	     dispose (remainingboxes)
	   END
	 END
     END;

   BEGIN   { getcurrentmail }
     writeln ('For each letter, answer R(ead) or S(kip) -- default [Read]');
     writeln;
     readthemail (newmail, mailboxlist);
     readthemail (oldmail, mailboxlist);
     mailboxlist := updated (mailboxlist);
     writenewmailbox;
     IF (newmessages + oldmessages) = 0
      THEN mailflag := nomailtoread
      ELSE mailflag := somemailread
   END;

  PROCEDURE sendnewmail;

  VAR
    sender : nametype;
    receiver : userlistlink;

    PROCEDURE getsender;

      PROCEDURE findmatchingid (remaininglist : userlistlink);

       BEGIN   { findmatchingid }
	 IF remaininglist = NIL
	  THEN sender := '                    '
	  ELSE WITH remaininglist^ DO
	  IF sameid (uppn, userid)
	   THEN sender := alias^.aliasname
	   ELSE findmatchingid (next)
       END;

     BEGIN   { getsender }
       findmatchingid (legalusers);
       writeln ('From: ', sender:namelength(sender));
       writeln
     END;

    FUNCTION recipients (reciplist : userlistlink) : userlistlink;

    CONST
      textlinesize = 80;
    TYPE
      textindextype = 1 .. textlinesize;
      textlinetype = PACKED ARRAY [textindextype] OF char;
    VAR
      inputline : textlinetype;
      index : textindextype;
      tokenname : nametype;
      tokenlist : userlistlink;
      query : boolean;

      FUNCTION listof (person : nametype) : userlistlink;

	FUNCTION samename (remaininglist : userlistlink) : userlistlink;

	VAR
	  listmatch : userlistlink;

	  FUNCTION aliasmatches (aliaslist : aliaslink) : boolean;

	    FUNCTION namematches (name : nametype) : boolean;

	      FUNCTION matches (index : nameindextype) : boolean;

		FUNCTION restmatches (index : nameindextype) : boolean;

		 BEGIN   { restmatches }
		   IF index = namesize
		    THEN restmatches := true
		    ELSE restmatches := matches (succ(index))
		 END;

	       BEGIN   { matches }
		 IF (name[index] = '*') OR (person[index] = '*')
		  THEN matches := true
		  ELSE
		  IF ( name[index] = '%') OR (person[index] = '%')
		   THEN matches := restmatches (index)
		   ELSE
		   IF uppercase(name[index]) = uppercase(person[index])
		    THEN matches := restmatches (index)
		    ELSE matches := false
	       END;

	     BEGIN   { namematches }
	       namematches := matches (1)
	     END;

	   BEGIN   { aliasmatches }
	     IF aliaslist = NIL
	      THEN aliasmatches := false
	      ELSE WITH aliaslist^ DO
	      IF NOT namematches (aliasname)
	       THEN aliasmatches := aliasmatches (nextalias)
	       ELSE
	       IF NOT query
		THEN aliasmatches := true
		ELSE
		 BEGIN
		   write (aliasname:namelength(aliasname), '?  ');
		   aliasmatches := answerisyes
		 END
	   END;

	  FUNCTION newlist (nextlist : userlistlink; id : idtype;
			    aliaslist : aliaslink) : userlistlink;

	  VAR
	    thislist : userlistlink;

	   BEGIN   { newlist }
	     new (thislist);
	     WITH thislist^ DO
	      BEGIN
		next := nextlist;
		uppn := id;
		alias := aliaslist
	      END;
	     newlist := thislist
	   END;

	 BEGIN   { samename }
	   IF remaininglist = NIL
	    THEN samename := NIL
	    ELSE WITH remaininglist^ DO
	    IF aliasmatches (alias)
	     THEN samename := newlist (samename (next), uppn, alias)
	     ELSE samename := samename (next)
	 END;

       BEGIN   { listof }
	 listof := samename (legalusers)
       END;

      PROCEDURE showusers (list : userlistlink);

	PROCEDURE showpeople (aliaslist : aliaslink);

	 BEGIN   { showpeople }
	   IF aliaslist = NIL
	    THEN writeln
	    ELSE
	    WITH aliaslist^ DO
	     BEGIN
	       write (aliasname : namelength(aliasname));
	       IF nextalias <> NIL
		THEN write (', ');
	       showpeople (nextalias)
	     END
	 END;

       BEGIN   { showusers }
	 IF list <> NIL
	  THEN WITH list^ DO
	   BEGIN
	     showpeople (alias);
	     showusers (next)
	   END
       END;

      FUNCTION tokenavailable (VAR tokenname : nametype; VAR query : boolean;
			       VAR inputline : textlinetype) : boolean;

      VAR
	delimiterset : SET OF char;
	switchchar : char;

	FUNCTION firstnonblank (VAR inputline : textlinetype) : textindextype;

	  FUNCTION fnb (index : textindextype) : textindextype;

	   BEGIN   { fnb }
	     IF inputline[index] <> ' '
	      THEN fnb := index
	      ELSE
	      IF index = textlinesize
	       THEN fnb := index
	       ELSE fnb := fnb (succ(index))
	   END;

	 BEGIN   { firstnonblank }
	   firstnonblank := fnb (1)
	 END;

	PROCEDURE bumpindex (VAR index : textindextype;
			     VAR inputline : textlinetype);

	 BEGIN   { bumpindex }
	   inputline[index] := ' ';
	   IF index < textlinesize
	    THEN index := succ(index)
	 END;

	PROCEDURE gettoken (VAR tokenname : nametype;
			    VAR index : textindextype;
			    VAR inputline : textlinetype);

	  PROCEDURE filltoken (tokenindex : textindextype);

	   BEGIN   { filltoken }
	     IF inputline[index] IN delimiterset
	      THEN tokenname[tokenindex] := ' '
	      ELSE
	       BEGIN
		 tokenname[tokenindex] := inputline[index];
		 bumpindex (index, inputline)
	       END;
	     IF tokenindex < namesize
	      THEN filltoken (succ(tokenindex))
	   END;

	 BEGIN   { gettoken }
	   filltoken (1);
	   tokenname[1] := uppercase (tokenname[1])
	 END;

	FUNCTION switch (VAR switchchar : char;
			 VAR index : textindextype;
			 VAR inputline : textlinetype) : boolean;

	  FUNCTION atdelimiter (index : textindextype;
				VAR inputline : textlinetype) : textindextype;

	   BEGIN   { atdelimiter }
	     IF inputline[index] IN delimiterset
	      THEN atdelimiter := index
	      ELSE
	      IF index = namesize
	       THEN
		BEGIN
		  bumpindex (index, inputline);
		  atdelimiter := index
		END
	       ELSE
		BEGIN
		  bumpindex (index, inputline);
		  atdelimiter := atdelimiter (index, inputline)
		END
	   END;

	 BEGIN   { switch }
	   IF inputline[index] = switchflag
	    THEN
	     BEGIN
	       bumpindex (index, inputline);
	       switchchar := uppercase(inputline[index]);
	       index := atdelimiter (index, inputline)
	     END
	    ELSE switch := false
	 END;

	PROCEDURE skipdelimiter (VAR index : textindextype;
				 VAR inputline : textlinetype);

	 BEGIN   { skipdelimiter }
	   IF inputline[index] IN delimiterset
	    THEN bumpindex (index, inputline)
	 END;

       BEGIN   { tokenavailable }
	 index := firstnonblank (inputline);
	 delimiterset := [',', '/', '&'];
	 IF inputline[index] = ' '
	  THEN tokenavailable := false
	  ELSE
	   BEGIN
	     gettoken (tokenname, index, inputline);
	     WHILE switch (switchchar, index, inputline) DO
	      BEGIN
		query := switchchar = queryswitch
	      END;
	     skipdelimiter (index, inputline);
	     tokenavailable := true
	   END
       END;

      FUNCTION concat (list1, list2 : userlistlink) : userlistlink;

	FUNCTION conc (list : userlistlink) : userlistlink;

	 BEGIN   { conc }
	   IF list = NIL
	    THEN conc := list2
	    ELSE WITH list^ DO
	     BEGIN
	       next := conc (next);
	       conc := list
	     END
	 END;

       BEGIN   { concat }
	 concat := conc (list1)
       END;

     BEGIN   { recipients }
       write ('To : ');
       readln (inputline);
       WHILE tokenavailable (tokenname, query, inputline) DO
	BEGIN
	  tokenlist := listof (tokenname);
	  writeln;
	  IF tokenlist = NIL
	   THEN
	    BEGIN
	      writeln ('No one matches ', tokenname:namelength(tokenname));
	      write ('Replace this one?  ');
	      IF answerisyes
	       THEN
		BEGIN
		  writeln;
		  writeln ('The current list of users (and aliases) is -- ');
		  showusers (legalusers);
		  writeln;
		  reciplist := recipients (reciplist)
		END
	    END;
	  reciplist := concat (reciplist, tokenlist)
	END;
       recipients := reciplist
     END;

    PROCEDURE getmessage (sender : nametype; receiver : userlistlink);

    VAR
      msgfilename : nametype;

      FUNCTION circularend (mailboxlist : mailboxlink) : boxnumbertype;

        { computes "next" box to fill.  Boxes are considered as a
         circular list, with 000 following 999.  This function finds
	 the start of the largest "gap" in this list. }


      VAR
	firstbox : boxnumbertype;

	FUNCTION following (boxnumber : boxnumbertype) : boxnumbertype;

	 BEGIN   { following }
	   IF boxnumber = maxboxnumber
	    THEN following := 0
	    ELSE following := succ(boxnumber)
	 END;

	FUNCTION nextbeforegap (list: mailboxlink; maxgap : cardinal;
				candidate : boxnumbertype) : boxnumbertype;

	 BEGIN   { nextbeforegap }
	   WITH list^ DO
	   IF nextbox = NIL
	    THEN
	     BEGIN
	       IF (succ(maxboxnumber) + firstbox - boxnumber) > maxgap
		THEN nextbeforegap := following (boxnumber)
		ELSE nextbeforegap := candidate
	     END
	    ELSE
	     BEGIN
	       IF (nextbox^.boxnumber - boxnumber) > maxgap
		THEN nextbeforegap := nextbeforegap (nextbox,
						     nextbox^.boxnumber -
						     boxnumber,
						     following (boxnumber))
		ELSE nextbeforegap := nextbeforegap (nextbox, maxgap,
						     candidate)
	     END
	 END;

       BEGIN   { circularend }
	 IF mailboxlist = NIL
	  THEN circularend := 0
	  ELSE WITH mailboxlist^ DO
	  IF nextbox = NIL
	   THEN circularend := following (boxnumber)
	   ELSE
	    BEGIN
	      firstbox := boxnumber;
	      circularend := nextbeforegap (nextbox, 0, following (boxnumber))
	    END
       END;

      PROCEDURE writeheader (receiver : userlistlink; sender : nametype);

	PROCEDURE towhom (receiver : userlistlink);

	  PROCEDURE showlist (list : userlistlink; space : cardinal);

	   BEGIN   { showlist }
	     WITH list^, alias^ DO
	      BEGIN
		IF (namelength (aliasname) + 2) > space
		 THEN writeln (message, 'et al.')
		 ELSE
		  BEGIN
		    write (message, aliasname:namelength(aliasname));
		    IF next = NIL
		     THEN writeln (message)
		     ELSE
		      BEGIN
			write (message, ', ');
			showlist (next, space - (namelength(aliasname) + 2))
		      END
		  END
	      END
	   END;

	 BEGIN   { towhom }
	   write (message, 'To  : ');
	   showlist (receiver, 60)
	 END;

	PROCEDURE fromwhom (sender : nametype);

	 BEGIN   { fromwhom }
	   writeln (message, 'From: ', sender:namelength(sender))
	 END;

       BEGIN   { writeheader }
	 towhom (receiver);
	 fromwhom (sender);
	 writeln (message)
       END;

      PROCEDURE inputmessage;

      VAR
	letter : char;

	FUNCTION endofmessage : boolean;

	 BEGIN   { endofmessage }
	   IF eoln
	    THEN
	     BEGIN
	       readln;
	       writeln (message);
	       endofmessage := endofmessage
	     END
	    ELSE
	    IF input^ = '.'
	     THEN
	      BEGIN
		read (letter);
		IF eoln
		 THEN
		  BEGIN
		    readln;
		    endofmessage := true
		  END
		 ELSE
		  BEGIN
		    write (message, letter);
		    endofmessage := false
		  END
	      END
	     ELSE endofmessage := false
	 END;

       BEGIN   { inputmessage }
	 writeln;
	 writeln ('Enter text of message.  End by entering a line');
	 writeln ('consisting of a single period (".").');
	 writeln;
	 rewrite (message, boxname);
	 writeheader (receiver, sender);
	 WHILE NOT endofmessage DO
	  BEGIN
	    WHILE NOT eoln DO
	     BEGIN
	       read (letter);
	       write (message, letter)
	     END;
	    readln;
	    writeln (message)
	  END;
	 close (message)
       END;

      PROCEDURE copymessage;

      VAR
	letter : char;

       BEGIN   { copymessage }
	 write ('Enter message file name -- ');
	 readln (msgfilename);
	 IF defexists (message, msgfilename)
	  THEN
	   BEGIN
	     reset (input, msgfilename);
	     rewrite (message, boxname);
	     writeheader (receiver, sender);
	     WHILE NOT eof DO
	      BEGIN
		WHILE NOT eoln DO
		 BEGIN
		   read (letter);
		   write (message, letter)
		 END;
		readln;
		writeln (message)
	      END;
	     close (input);
	     close (message)
	   END
	  ELSE
	   BEGIN
	     writeln ('Message file ', msgfilename:namelength(msgfilename),
		      ' not found.');
	     getmessage (sender, receiver)
	   END
       END;

     BEGIN   { getmessage }
       nextboxnumber := circularend (mailboxlist);
       createboxname (nextboxnumber);
       write ('Message from F(ile) or T(erminal)  [Terminal] ?  ');
       CASE legalanswer (['F', 'T', ' ']) OF
	 'F' : copymessage;
	 'T',
	 ' ' : inputmessage
	END
     END;

    PROCEDURE sendto (recipient : userlistlink);

      PROCEDURE addtomailbox (towhom : idtype);

	FUNCTION updated (remaininglist : mailboxlink) : mailboxlink;

	  FUNCTION newlist (nextlist : mailboxlink; recip, sender : idtype;
			    box : boxnumbertype;
			    stat : mailboxstatustype) : mailboxlink;

	  VAR
	    thislist : mailboxlink;

	   BEGIN   { newlist }
	     new (thislist);
	     WITH thislist^ DO
	      BEGIN
		nextbox := nextlist;
		recipid := recip;
		senderid := sender;
		boxnumber := box;
		status := stat
	      END;
	     newlist := thislist
	   END;

	 BEGIN   { updated }
	   IF remaininglist = NIL
	    THEN updated := newlist (NIL, towhom, userid,
				     nextboxnumber, newmail)
	    ELSE WITH remaininglist^ DO
	     BEGIN
	       IF nextboxnumber < boxnumber
		THEN
		 BEGIN
		   nextbox := newlist (nextbox, recipid, senderid,
				       boxnumber, status);
		   recipid := towhom;
		   senderid := userid;
		   boxnumber := nextboxnumber;
		   status := newmail
		 END
		ELSE nextbox := updated (nextbox);
	       updated := remaininglist
	     END
	 END;

       BEGIN   { addtomailbox }
	 mailboxlist := updated (mailboxlist)
       END;

     BEGIN   { sendto }
       IF recipient = NIL
	THEN writeln
	ELSE WITH recipient^, alias^ DO
	 BEGIN
	   writeln ('Sending to ', aliasname:namelength(aliasname), ' ... ');
	   addtomailbox (uppn);
	   IF sameid (uppn, userid)
	    THEN
	     BEGIN
	       newmessages := succ(newmessages);
	       IF mailflag = nomailtoread
		THEN mailflag := somemailread
	     END;
	   sendto (next)
	 END
     END;

   BEGIN   { sendnewmail }
     writeln;
     getsender;
     receiver := recipients (NIL);
     IF receiver <> NIL
      THEN
       BEGIN
	 getmessage (sender, receiver);
	 sendto (receiver);
	 writenewmailbox
       END
   END;

  PROCEDURE showmainalias (aliasid : idtype);

    PROCEDURE showalias (remainingpeople : userlistlink);

     BEGIN   { showalias }
       IF remainingpeople = NIL
	THEN write ('unknown person ')
	ELSE
	WITH remainingpeople^, alias^ DO
	IF sameid (aliasid, uppn)
	 THEN write (aliasname:namelength(aliasname))
	 ELSE showalias (next)
     END;

   BEGIN   { showmainalias }
     showalias (legalusers)
   END;

  PROCEDURE checkunreadmail;

  VAR
    nounreadmessages : boolean;

    PROCEDURE checkunread (remainingboxes : mailboxlink);

      PROCEDURE showunread (unreadbox: boxnumbertype;
			    remainingboxes : mailboxlink);

	FUNCTION nextmatch (remainingboxes : mailboxlink) : mailboxlink;

	 BEGIN   { nextmatch }
	   IF remainingboxes = NIL
	    THEN nextmatch := NIL
	    ELSE
	    WITH remainingboxes^ DO
	    IF sameid (userid, senderid) AND (status = newmail)
	     THEN
	      BEGIN
		IF unreadbox = boxnumber
		 THEN nextmatch := remainingboxes
		 ELSE nextmatch := NIL
	      END
	     ELSE nextmatch := nextmatch (nextbox)
	 END;

       BEGIN   { showunread }
	 write ('Message ', unreadbox:1, ' unread, ');
	 showdeliverytime (unreadbox);
	 write (' to ');
	 WITH remainingboxes^ DO
	  BEGIN
	    showmainalias (recipid);
	    remainingboxes := nextmatch (nextbox)
	  END;
	 IF remainingboxes <> NIL
	  THEN writeln (' and others')
	  ELSE writeln
       END;

      FUNCTION nextunique (unreadbox : boxnumbertype;
			   remainingboxes : mailboxlink) : mailboxlink;

       BEGIN   { nextunique }
	 IF remainingboxes = NIL
	  THEN nextunique := NIL
	  ELSE
	  WITH remainingboxes^ DO
	  IF unreadbox = boxnumber
	   THEN nextunique := nextunique (unreadbox, nextbox)
	   ELSE nextunique := remainingboxes
       END;

     BEGIN   { checkunread }
       WHILE remainingboxes <> NIL DO
       WITH remainingboxes^ DO
	BEGIN
	  IF sameid (userid, senderid) AND (status = newmail)
	   THEN
	    BEGIN
	      showunread (boxnumber, remainingboxes);
	      nounreadmessages := false;
	      remainingboxes := nextunique (boxnumber, remainingboxes)
	    END
	   ELSE remainingboxes := nextbox
	END
     END;

   BEGIN   { checkunreadmail }
     writeln;
     nounreadmessages := true;
     checkunread (mailboxlist);
     IF nounreadmessages
      THEN writeln ('You have sent no unread messages');
     writeln
   END;

  PROCEDURE cancelunreadmail;

  VAR
    pullbox : boxnumbertype;
    pullablemail : mailboxlink;

    FUNCTION realbox (VAR boxnumber : boxnumbertype) : boolean;

      { if valid box # entered, returns true;
       if carriage return entered, returns false;
       if illegal number entered, allows retry }

    VAR
      number : cardinal;

      PROCEDURE skipleadingblanks;

       BEGIN   { skipleadingblanks }
	 WHILE (NOT (eoln OR eof)) AND (input^ = ' ') DO get (input)
       END;

      FUNCTION validdigit (letter : char) : boolean;

       BEGIN   { validdigit }
	 validdigit := letter IN ['0' .. '9']
       END;

      FUNCTION numeric (letter : char) : integer;

       BEGIN   { numeric }
	 IF letter = ' '
	  THEN numeric := 0
	  ELSE numeric := ord(letter) - ord('0')
       END;

      FUNCTION numberin (sumsofar : cardinal) : cardinal;

      VAR
	letter : char;

       BEGIN   { numberin }
	 IF eoln
	  THEN
	   BEGIN
	     numberin := sumsofar;
	     readln
	   END
	  ELSE
	   BEGIN
	     read (letter);
	     IF validdigit (letter)
	      THEN numberin := numberin (10*sumsofar + numeric (letter))
	      ELSE
	       BEGIN
		 numberin := sumsofar;
		 readln
	       END
	   END
       END;

     BEGIN   { realbox }
       IF eoln
	THEN
	 BEGIN
	   readln;
	   realbox := false;
	   boxnumber := 0
	 END
	ELSE
	 BEGIN
	   skipleadingblanks;
	   number := numberin (0);
	   IF (0 <= number) AND (number <= maxboxnumber)
	    THEN
	     BEGIN
	       realbox := true;
	       boxnumber := number
	     END
	    ELSE
	     BEGIN
	       write ('Error: enter number [0 .. ', maxboxnumber:1, '] -- ');
	       realbox := realbox (boxnumber)
	     END
	 END
     END;

    FUNCTION pullable (mailbox : mailboxlink) : mailboxlink;

     BEGIN   { pullable }
       IF mailbox = NIL
	THEN pullable := NIL
	ELSE WITH mailbox^ DO
	IF boxnumber = pullbox
	 THEN pullable := mailbox
	 ELSE pullable := pullable (nextbox)
     END;

    FUNCTION nosuchmessage (mailbox : mailboxlink) : boolean;

     BEGIN   { nosuchmessage }
       nosuchmessage := mailbox = NIL
     END;

    FUNCTION notyourmessage (mailbox : mailboxlink) : boolean;

     BEGIN   { notyourmessage }
       IF mailbox = NIL
	THEN notyourmessage := true
	ELSE WITH mailbox^ DO notyourmessage := NOT sameid (userid,
							    senderid)
     END;

    FUNCTION nounreadmessage (mailbox : mailboxlink) : boolean;

      { assume non-nil mailbox has correct box number and from user }

     BEGIN   { nounreadmessage }
       IF mailbox = NIL
	THEN nounreadmessage := true
	ELSE WITH mailbox^ DO
	IF status = newmail
	 THEN nounreadmessage := false
	 ELSE nounreadmessage := nounreadmessage (pullable (nextbox))
     END;

    PROCEDURE pull (mailbox : mailboxlink);

      { assume non-nil mailbox has correct box number and from user }

      PROCEDURE allowdeletion (pullfrombox : mailboxlink);

       BEGIN   { allowdeletion }
	 WITH pullfrombox^ DO
	  BEGIN
	    write ('Pull mail from ');
	    showmainalias (recipid);
	    write ('?  ');
	    IF answerisyes
	     THEN
	      BEGIN
		IF sameid (recipid, userid)
		 THEN
		 CASE status OF
		   newmail : newmessages := pred(newmessages);
		   oldmail : oldmessages := pred(oldmessages)
		  END;
		status := deleted
	      END
	  END
       END;

     BEGIN   { pull }
       WHILE mailbox <> NIL DO
       WITH mailbox^ DO
	BEGIN
	  IF status = newmail
	   THEN allowdeletion (mailbox);
	  mailbox := pullable (nextbox)
	END
     END;

    FUNCTION updated (remainingboxes : mailboxlink) : mailboxlink;

      FUNCTION messagefree (box : boxnumbertype) : boolean;

	FUNCTION nobodyisreading (remainingboxes : mailboxlink) : boolean;

	 BEGIN   { nobodyisreading }
	   IF remainingboxes = NIL
	    THEN nobodyisreading := true
	    ELSE WITH remainingboxes^ DO
	    IF box <> boxnumber
	     THEN nobodyisreading := nobodyisreading (nextbox)
	     ELSE
	     IF status IN [newmail, oldmail, justread]
	      THEN nobodyisreading := false
	      ELSE nobodyisreading := nobodyisreading (nextbox)
	 END;

       BEGIN   { messagefree }
	 messagefree := nobodyisreading (mailboxlist)
       END;

      PROCEDURE discardmessage (box : boxnumbertype);

       BEGIN   { discardmessage }
	 createboxname (box);
	 IF exists (message, boxname)
	  THEN
	   BEGIN
	     reset (message, boxname);
	     delete (message);
	     close (message)
	   END
       END;

     BEGIN   { updated }
       IF remainingboxes = NIL
	THEN updated := NIL
	ELSE
	WITH remainingboxes^ DO
	IF status = deleted
	 THEN
	  BEGIN
	    updated := updated (nextbox);
	    IF messagefree (boxnumber)
	     THEN discardmessage (boxnumber);
	    dispose (remainingboxes)
	  END
	 ELSE
	  BEGIN
	    nextbox := updated (nextbox);
	    updated := remainingboxes
	  END
     END;

    PROCEDURE cancelmail;

     BEGIN   { cancelmail }
       writeln;
       write ('R(ead message), P(ull unread message), or Q(uit)  ',
	      '[Pull] ?  ');
       CASE legalanswer (['R', 'P', 'Q', ' ']) OF
	 'R' :
	  BEGIN
	    WITH pullablemail^ DO createboxname (boxnumber);
	    IF exists (message, boxname)
	     THEN readmailinbox
	     ELSE WITH pullablemail^ DO writeln ('MAIL - W - Message ',
						 boxnumber:1,
						 ' unexpectedly missing!');
	    cancelmail
	  END;
	 'P',
	 ' ' :
	  BEGIN
	    pull (pullablemail);
	    mailboxlist := updated (mailboxlist);
	    writenewmailbox
	  END;
	 'Q' : { do nothing }
	END
     END;

   BEGIN   { cancelunreadmail }
     writeln;
     write ('Which message do you wish to pull?  ');
     IF realbox (pullbox)
      THEN
       BEGIN
	 pullablemail := pullable (mailboxlist);
	 IF nosuchmessage (pullablemail)
	  THEN writeln ('There is no such message')
	  ELSE
	  IF notyourmessage (pullablemail)
	   THEN writeln ('You did not send this message')
	   ELSE
	   IF nounreadmessage (pullablemail)
	    THEN writeln ('Everyone has already read this message')
	    ELSE cancelmail
       END;
     writeln
   END;

  PROCEDURE finishprogram;

   BEGIN   { finishprogram }
     mailflag := allfinished;
     writeln
   END;

 BEGIN   { mail }
   initialize;
   writeln;
   WHILE mailflag <> allfinished DO
    BEGIN
      CASE mailflag OF
	mailtoread : write ('R(ead), S(end), C(heck), U(nmail), Q(uit)  ',
			    '[Read] ?  ');
	somemailread : write ('R(ead), S(end), C(heck), U(nmail), Q(uit)  ',
			      '[Quit] ?  ');
	nomailtoread : write ('S(end), C(heck), U(nmail), Q(uit)  ',
			      '[Quit] ?  ')
       END;
      CASE legalanswer (['R', 'S', 'C', 'U', 'Q', ' ']) OF
	'R' : getcurrentmail;
	'S' : sendnewmail;
	'C' : checkunreadmail;
	'U' : cancelunreadmail;
	'Q' : finishprogram;
	' ' :
	CASE mailflag OF
	  mailtoread : getcurrentmail;
	  somemailread,
	  nomailtoread : finishprogram
	 END
       END
    END
 END.