-- ArpaMTEvalImpl.pgs

-- file ArpaMTEvalImpl.mesa rewritten by PGS, 14-Jun-83 15:33

-- last edit by Schmidt, June 11, 1982 3:12 pm
-- last modified by Satterthwaite, June 2, 1983 12:45 pm

-- Last Edited by: Nichols, July 15, 1983 5:35 pm

-- Last Edited by: HGM, March 3, 1984 10:46:50 pm PST
-- John Larson, October 10, 1987 5:12:05 pm PDT

-- pgs [defs: ArpaMTParseTable, bcd: ArpaMTParseData, grammar: ArpaMT] ← ArpaMTEvalImpl.mesa;

-- output: new version of ArpaMTEvalImpl.mesa, tables in ArpaMTParseData.bcd
-- interface on ArpaMTParseTable.mesa
-- log on PGS.Log, grammar on ArpaMT.Grammar,
-- errors on ArpaMTParseData.errlog

DIRECTORY
 List: TYPE USING [Nconc1, NthElement],
 ArpaMTMiscOps: TYPE USING [AToI, IToA, Substitute],
 ArpaMTP1: TYPE --P1-- USING [ActionStack, AddrSpecNode, DomainNode, DotWordsNode,
  InternalNode, LinkStack, MailboxNode, RouteAddrNode, RouteNode, TerminalNode, TValue,
  ValueStack],
 ArpaMTParseTable: TYPE ParseTable USING [ProdDataRef],
 Rope: TYPE USING [Cat, Equal, IsEmpty, Length, ROPE, SkipOver, Substr];
 
ArpaMTEvalImpl: CEDAR PROGRAM
  IMPORTS List, ArpaMTMiscOps, Rope
  EXPORTS ArpaMTP1 ~ {
 -- parse tree building
 OPEN P1~~ArpaMTP1, ArpaMTParseTable;

-- stores parse tree when done with parse

parseTree: REF ANY;

-- Set if the reduction routines had trouble and we should declare an invalid parse.

badSemantics: BOOLEAN;

-- local data base (supplied by parser)

v: P1.ValueStack;
l: P1.LinkStack;
q: P1.ActionStack;

prodData: ProdDataRef;

-- initialization/termination

AssignDescriptors: PUBLIC PROC[
 qd: P1.ActionStack,
 vd: P1.ValueStack, ld: P1.LinkStack,
 pp: ProdDataRef] ~ {
 q ← qd; v ← vd; l ← ld; prodData ← pp;};

EvalInit: PUBLIC PROC ~ {
 -- This routine should be called before a parse begins. The parser will do this for you.
 parseTree ← NIL;
 badSemantics ← FALSE;
 };
 
-- Random

digits: Rope.ROPE ~ "0123456789";

-- Tree manipulation

CollectInternals: PROC [top, number: NAT] ~ {
 kids: P1.InternalNode;  -- LIST OF REF ANY
 
 kids ← LIST[v[top+number-1].t];
 FOR i: NAT DECREASING IN [top..top+number-1) DO
  kids ← CONS[v[i].t, kids];
  ENDLOOP;
 v[top].t ← kids;
 };



-- This procedure builds the parse tree. It is called by the parser for each reduction to be
-- made. In addition to building the tree, it does a few minor corrections for the extra
-- productions in the grammar. In particular, a missing ";" is added to a group list, and extra
-- commas are removed from mailbox and address lists.

-- For dates, it does something else (more later).

-- The grammar here is really a pair of grammars, one for name lists and one for dates.
-- We put them together like this because it is pretty inconvenient to have two grammars
-- with pgs. The name-dummy and date-dummy tokens are the first tokens returned by
-- the lexer in each case and are used to force the parser to parse a name list or a date.

ProcessQueue: PUBLIC PROC[qI, top: CARDINAL] ~ {
 FOR i: CARDINAL IN [0..qI) DO

  GetRule: PROC[n: CARDINAL] RETURNS [CARDINAL] ~ TRUSTED {
   RETURN [prodData[n].rule]};

  UnixProc1: PROC ~ {
   -- date-time ::= day month atom hour atom
   -- Unix date format. Rearrange everything and fix up the year.
   time, date: LIST OF REF ANY;
   year: REF P1.TerminalNode ← NARROW[v[top+4].t];
   year.text ← year.text.Substr[year.text.Length[]-2, 2];
   time ← LIST[v[top+3].t];
   date ← LIST[v[top+2].t, v[top+1].t, year];
   v[top].t ← LIST[v[top].t, NEW[P1.TerminalNode ← [text~","]], date, time];
   };
   
  UnixProc2: PROC ~ {
   -- date-time ::= day month atom hour zone atom
   -- Unix date format. Rearrange everything and fix up the year.
   time, date: LIST OF REF ANY;
   year: REF P1.TerminalNode ← NARROW[v[top+5].t];
   year.text ← year.text.Substr[year.text.Length[]-2, 2];
   time ← LIST[v[top+3].t, v[top+4].t];
   date ← LIST[v[top+2].t, v[top+1].t, year];
   v[top].t ← LIST[v[top].t, NEW[P1.TerminalNode ← [text~","]], date, time];
   };
   
  top ← top-q[i].tag.pLength+1;
  SELECT GetRule[q[i].transition] FROM

0 => -- TABLE: ArpaMTParseData TYPE: ParseTable EXPORTS: SELF
    -- GOAL: goal
    -- TERMINALS:
    -- name-dummy
    -- atom
    -- quoted-string
    -- domain-lit
    -- . , : ;
    -- @ < >
    -- eol
    -- error

    -- date-dummy
    -- ampm day month zone

    -- ALIASES:
    -- name-dummy nameDummy
    -- atom atomTok
    -- quoted-string qStringTok
    -- domain-lit dLitTok
    -- . dotTok
    -- , commaTok
    -- : colonTok
    -- ; semiTok
    -- @ atSignTok
    -- < lBracketTok
    -- > rBracketTok
    -- error errorTok
    -- eol EOLTok

    -- date-dummy dateDummy
    -- ampm ampmTok
    -- day dayTok
    -- month monthTok
    -- zone zoneTok

    -- PRODUCTIONS:
    -- goal ::= name-dummy addr-list eol
     BEGIN
     CollectInternals[top+1, 2];  -- save the EOL, too.
     parseTree ← v[top+1].t;
     END;
1 => -- goal ::= date-dummy date-time eol
     BEGIN
     CollectInternals[top+1, 2];  -- save the EOL, too.
     parseTree ← v[top+1].t;
     END;
2 => -- address ::=
     v[top].t ← NIL;
3 => -- address ::= mailbox
     NULL;
4 => -- address ::= group
     NULL;
5 => -- addr-list ::= address
     NULL;
6 => -- addr-list ::= addr-list , address
     IF v[top+2].t # NIL THEN -- only collect new address if non-empty
      CollectInternals[top, 3];
7 => -- addr-spec ::= dot-words
     v[top].t ← NEW[P1.AddrSpecNode ← [localPart~v[top].t]];
8 => -- addr-spec ::= addr-spec @ domain
     BEGIN
     t: REF P1.TerminalNode ← NARROW[v[top+1].t];
     d: REF P1.DomainNode ← NARROW[v[top+2].t];
     t.text ← "@";  -- make sure that we don't have "at"
     -- also zap white space from around the @
     t.whiteSpace ← NIL;
     WHILE d.domain # NIL DO
      d ← d.domain;
      ENDLOOP;
     d.subDomain.whiteSpace ← NIL;
     v[top].t ← NEW[P1.AddrSpecNode ← [localPart~v[top].t,
      atSign~t, domain~NARROW[v[top+2].t]]];
     END;
9 => -- domain ::= sub-domain
     v[top].t ← NEW[P1.DomainNode ← [subDomain~NARROW[v[top].t]]];
10 => -- domain ::= domain . sub-domain
     v[top].t ← NEW[P1.DomainNode ← [domain~NARROW[v[top].t],
      dot~NARROW[v[top+1].t], subDomain~NARROW[v[top+2].t]]];
11 => -- dot-words ::= word
     v[top].t ← NEW[P1.DotWordsNode ← [word~NARROW[v[top].t]]];
12 => -- dot-words ::= dot-words . word
     v[top].t ← NEW[P1.DotWordsNode ← [dotWords~NARROW[v[top].t],
      dot~NARROW[v[top+1].t], word~NARROW[v[top+2].t]]];
13 => -- group ::= phrase : mailbox-list ;
     CollectInternals[top, 4];
14 => -- group ::= phrase : mailbox-list
     BEGIN
     CollectInternals[top, 3];
     -- Add semicolon.
     v[top].t ← List.Nconc1[NARROW[v[top].t, LIST OF REF ANY],
      NEW[P1.TerminalNode ← [text~";"]]];
     END;
15 => -- mailbox ::= addr-spec
     v[top].t ← NEW[P1.MailboxNode ← [address~v[top].t]];
16 => -- mailbox ::= route-addr
     v[top].t ← NEW[P1.MailboxNode ← [address~v[top].t]];
17 => -- mailbox ::= phrase route-addr
     v[top].t ← NEW[P1.MailboxNode ← [phrase~v[top].t, address~v[top+1].t]];
18 => -- mailbox ::= @ dot-words
     BEGIN
     CollectInternals[top, 2];
     v[top].t ← NEW[P1.MailboxNode ← [address~v[top].t]];
     -- TODO: should hide structure of dl somehow.
     END;
19 => -- mailbox-list ::=
     v[top].t ← NIL;
20 => -- mailbox-list ::= mailbox
     NULL;
21 => -- mailbox-list ::= mailbox-list ,
     NULL;  -- discard comma
22 => -- mailbox-list ::= mailbox-list , mailbox
     IF v[top+2].t # NIL THEN -- only collect new mailbox if non-empty
      CollectInternals[top, 3];
23 => -- phrase ::= dot-words
     NULL;
24 => -- phrase ::= phrase dot-words
     CollectInternals[top, 2];
25 => -- route ::= @ domain
     v[top].t ← NEW[P1.RouteNode ← [atSign~NARROW[v[top].t],
      domain~NARROW[v[top+1].t]]];
26 => -- route ::= route , @ domain
     v[top].t ← NEW[P1.RouteNode ← [route~NARROW[v[top].t],
      comma~NARROW[v[top+1].t], atSign~NARROW[v[top+2].t],
      domain~NARROW[v[top+3].t]]];
27 => -- route-addr ::= < addr-spec >
     v[top].t ← NEW[P1.RouteAddrNode ← [lBrack~NARROW[v[top].t],
      addrSpec~NARROW[v[top+1].t], rBrack~NARROW[v[top+2].t]]];
28 => -- route-addr ::= < route : addr-spec >
     v[top].t ← NEW[P1.RouteAddrNode ← [lBrack~NARROW[v[top].t],
      route~NARROW[v[top+1].t], colon~NARROW[v[top+2].t],
      addrSpec~NARROW[v[top+3].t], rBrack~NARROW[v[top+4].t]]];
29 => -- sub-domain ::= atom
     NULL;
30 => -- sub-domain ::= domain-lit
     NULL;
31 => -- word ::= atom
     NULL;
32 => -- word ::= quoted-string
     NULL;

33 => -- date-time ::= date time
     CollectInternals[top, 2];
34 => -- date-time ::= day date time
     BEGIN
     -- Add comma after day and treat like date-time ::= day , date time
     t: REF P1.TerminalNode ← NARROW[v[top].t];
     t.text ← t.text.Substr[0, 3];
     v[top].t ← LIST[v[top].t, NEW[P1.TerminalNode ← [text~","]], v[top+1].t,
      v[top+2].t];
     END;
35 => -- date-time ::= day , date time
     BEGIN
     -- Day is supposed to be in 3-letter abbreviated form, so truncate it.
     t: REF P1.TerminalNode ← NARROW[v[top].t];
     t.text ← t.text.Substr[0, 3];
     CollectInternals[top, 4];
     END;
36 => -- date-time ::= day , date , time
     BEGIN
     -- Remove comma after date and treat like date-time ::= day , date time
     t: REF P1.TerminalNode ← NARROW[v[top].t];
     t.text ← t.text.Substr[0, 3];
     -- Cheat! Rather than chase down the tree to tack on the white space, we just
     -- leave the comma node in.
     t ← NARROW[v[top+3].t];
     t.whiteSpace ← " ";
     t.text ← NIL;
     CollectInternals[top, 5];
     END;
37 => -- date-time ::= day month atom hour atom
     UnixProc1[];  --COMPILER--
38 => -- date-time ::= day month atom hour zone atom
     UnixProc2[];  --COMPILER--
39 => -- date ::= atom month atom
     BEGIN
     -- Month should be truncated to three letters. Atom at end should be year
     -- in two digit form.
     t: REF P1.TerminalNode ← NARROW[v[top+1].t];
     t.text ← t.text.Substr[0, 3];
     t ← NARROW[v[top+2].t];
     IF t.text.Length[] < 2 OR t.text.SkipOver[skip: digits] # t.text.Length[] THEN
      badSemantics ← TRUE
     ELSE
      t.text ← t.text.Substr[t.text.Length[]-2, 2];
     CollectInternals[top, 3];
     END;
40 => -- date ::= atom month . atom
     BEGIN
     -- Discard dot and handle as above.
     t: REF P1.TerminalNode ← NARROW[v[top+1].t];
     t.text ← t.text.Substr[0, 3];
     t ← NARROW[v[top+3].t];
     IF t.whiteSpace.IsEmpty THEN t.whiteSpace ← " ";
     IF t.text.Length[] < 2 OR t.text.SkipOver[skip: digits] # t.text.Length[] THEN
      badSemantics ← TRUE
     ELSE
      t.text ← t.text.Substr[t.text.Length[]-2, 2];
     v[top].t ← LIST[v[top].t, v[top+1].t, v[top+3].t];
     END;
41 => -- date ::= atom
     BEGIN
     -- Most likely, we have a date of the form dd-mmm-yy, so replace the hyphens
     -- with spaces.
     t: REF P1.TerminalNode ← NARROW[v[top].t];
     t.text ← ArpaMTMiscOps.Substitute[t.text, '-, ' ];
     END;
42 => -- time ::= hour zone
     CollectInternals[top, 2];
43 => -- time ::= hour ampm zone
     BEGIN
     -- Flush ampm and adjust hour.
     t: REF P1.TerminalNode ←
      NARROW[NARROW[v[top].t, LIST OF REF ANY].first];
     ampm: REF P1.TerminalNode ← NARROW[v[top+1].t];
     hour: INT ← ArpaMTMiscOps.AToI[t.text];
     -- To quote Taft: "If hour is not 12 then AM leaves it alone and PM adds 12.
     -- But if hour is 12 then AM sets it to zero and PM leaves it alone. The
     -- following code actually sets it to zero and then adds 12 in the 12 PM case."
     IF hour = 12 THEN
      hour ← 0;
     IF ampm.text.Equal["pm", FALSE] THEN
      hour ← hour + 12;
     t.text ← ArpaMTMiscOps.IToA[hour];
     IF t.text.Length < 2 THEN
      -- pad it
      t.text ← Rope.Cat["0", t.text];
     v[top].t ← LIST[v[top].t, v[top+2].t];
     END;
44 => -- time ::= hour
     BEGIN
     -- This comes from Tenex/Twenex format times, in which the zone is separated
     -- from the hour by a hyphen. Replace hyphens with spaces.
     t: REF P1.TerminalNode ← NARROW[List.NthElement[NARROW[v[top].t], -1]];

     t.text ← ArpaMTMiscOps.Substitute[t.text, '-, ' ];
     END;
45 => -- hour ::= atom : atom
     BEGIN
     -- Make sure we have numbers, but don't force last atom to, as it may have
     -- zone mixed in.
     t: REF P1.TerminalNode ← NARROW[v[top].t];
     t2: REF P1.TerminalNode ← NARROW[v[top+2].t];

     IF t.text.SkipOver[skip: digits] # t.text.Length[] THEN
      badSemantics ← TRUE;
     CollectInternals[top, 3];
     END;
46 => -- hour ::= atom : atom : atom
     BEGIN
     -- Make sure we have numbers.
     t: REF P1.TerminalNode ← NARROW[v[top].t];
     t2: REF P1.TerminalNode ← NARROW[v[top+2].t];
     t3: REF P1.TerminalNode ← NARROW[v[top+4].t];

     IF t.text.SkipOver[skip: digits] # t.text.Length[] OR
       t2.text.SkipOver[skip: digits] # t2.text.Length[] THEN
      badSemantics ← TRUE;
     CollectInternals[top, 5];
     END;
47 => -- hour ::= atom
     BEGIN
     -- Time is in 4-digit form: hhmm. Convert to hh:mm. There may be junk
     -- after the 4 digits (e.g. -zone) which is preserved.
     t: REF P1.TerminalNode ← NARROW[v[top].t];
     r: Rope.ROPE ← t.text;
     
     IF r.SkipOver[skip: digits] = 4 AND ArpaMTMiscOps.AToI[r.Substr[0,2]] <= 23 AND
       ArpaMTMiscOps.AToI[r.Substr[2,2]] <= 59 THEN
      v[top].t ← LIST[NEW[P1.TerminalNode ← [whiteSpace~t.whiteSpace,
        text~r.Substr[0, 2]]],
       NEW[P1.TerminalNode ← [text~ ":"]],
       NEW[P1.TerminalNode ← [text~ r.Substr[start: 2]]]]
     ELSE {
      badSemantics ← TRUE;
      v[top].t ← LIST[v[top].t];
      };
     END;
   ENDCASE => ERROR;

  ENDLOOP};



ProcessError: PUBLIC PROC [top: CARDINAL, inputValue: P1.TValue] = {
 CollectInternals[1, top];
 parseTree ← LIST[v[1].t, inputValue];
 };

GetEvalResult: PUBLIC PROC RETURNS [tree: REF ANY, badSemantics: BOOL] = {
 RETURN [parseTree, ArpaMTEvalImpl.badSemantics];
 };

}.