-- Copyright (C) 1985, 1986 by Xerox Corporation.  All rights reserved.
-- DO NOT CONVERT TO TIOGA FORMAT!  (PSG requires the mesa-style comments)
-- last edit by Satterthwaite, May 30, 1986 11:10:35 am PDT

-- pgs [defs: CtoSParseTable, bcd: CtoSParseData, grammar: CtoS] _ CtoSTreeBuildImpl.pgs

-- output: new version of CtoSTreeBuildImpl.mesa, tables in CtoSParseData.bcd
--      interface on ParseTable.mesa
--      log on PGS.log, grammar on CtoS.grammar
--      errors on CtoSParseData.errlog

DIRECTORY
  Atom: TYPE USING [GetPName, MakeAtom],
  CtoSParseTable: TYPE ParseTable USING [ActionEntry, ProdDataRef, TSymbol],
  CtoSP1: TYPE P1 USING [
    ActionStack, LinkStack, TValue, ValueStack, nullTValue, nullValue, Substr],
  Rope: TYPE USING [Concat],
  SMTree: TYPE Tree USING [Link, null],
  SMTypeCons: TYPE USING [
    TM, Domain, MkArrow, MkArrow2, MkCrossReverse, MkCross2, MkDeclElem,
    MkDeclReverse, MkInterfaceType, MkPair, MkStringType, MkUnitDecl, PushLink, Range],
  SMOps: TYPE USING [MS];

CtoSTreeBuildImpl: CEDAR PROGRAM
    IMPORTS Atom, CtoSP1, Rope, SMTypeCons
    EXPORTS CtoSP1 ~ {
  -- parse tree building
  OPEN ParseTable~~CtoSParseTable, P1~~CtoSP1, Tree~~SMTree, TypeCons~~SMTypeCons;

 -- local data base (supplied by parser)

  v: P1.ValueStack;
  l: P1.LinkStack;
  q: P1.ActionStack;
  prodData: ParseTable.ProdDataRef;
  
  tm: TypeCons.TM;

 -- initialization/termination

  AssignDescriptors: PUBLIC PROC[
      qd: P1.ActionStack, vd: P1.ValueStack, ld: P1.LinkStack,
      pp: ParseTable.ProdDataRef,
      model: SMOps.MS] ~ {
    q _ qd; v _ vd; l _ ld; prodData _ pp;
    tm _ [model.tm]};


 -- error recovery (only)

  TokenValue: PUBLIC PROC[s: ParseTable.TSymbol] RETURNS[P1.TValue] ~ {
    RETURN[P1.nullTValue]};

 -- interpretation routines
 
  definitions: BOOL;
  
  AtomList: TYPE ~ LIST OF ATOM;
  
  AtomV: PROC[i: CARDINAL] RETURNS[ATOM] ~ {
    RETURN[Atom.MakeAtom[P1.Substr[l[i], v[i].t]]]};
    
  ConsAtom: PROC[i: CARDINAL, rest: AtomList] RETURNS[AtomList] ~ {
    RETURN[CONS[AtomV[i], rest]]};
    
  InstName: PROC[type: ATOM] RETURNS[ATOM] ~ {
    RETURN[Atom.MakeAtom[(Atom.GetPName[type]).Concat["Impl"]]]};
      
               
  ProcessQueue: PUBLIC PROC[qI, top: CARDINAL] ~ {
    FOR i: CARDINAL IN [0..qI) DO
      
      GetRule: PROC[n: CARDINAL] RETURNS[CARDINAL] ~ TRUSTED INLINE {
        RETURN [prodData[n].rule]};
        
      top _ top-q[i].tag.pLength+1;
      SELECT GetRule[q[i].transition] FROM

       -- basic tree building
        0  => -- TABLE: CtoSParseData  TYPE: ParseTable  EXPORTS: SELF
              -- GOAL:  goal

              --TERMINALS:
              --  id  num  lnum  flnum  string  lstring  char  atom
              --  bracketed
              --  ,  ;  :  =>  _
              --  =  #  <  >  <=  >=  ~
              --  +  -  *  /  ^  .  @
              --  RECORD  POINTER  REF  VAR
              --  LIST  ARRAY  DESCRIPTOR
              --  PROCEDURE  PROC  PORT  SIGNAL  ERROR  PROCESS
              --  PROGRAM  MONITOR  DEFINITIONS  ZONE  RELATIVE  LONG
              --  TYPE  FRAME  TO  ORDERED  UNCOUNTED
              --  BASE  OF  PACKED  RETURNS  SAFE  UNSAFE
              --  MONITORED  MACHINE  DEPENDENT
              --  DIRECTORY  IMPORTS  EXPORTS  SHARES  LOCKS  USING
              --  PUBLIC  PRIVATE  CEDAR  CHECKED  TRUSTED  UNCHECKED
              --  READONLY  CODE
              --  ABS  ALL  AND  APPLY  CONS  MAX  MIN  MOD
              --  NOT  OR  ORD  PRED  LENGTH  NEW  START  SUCC  VAL
              --  FORK  JOIN  LOOPHOLE  NARROW  ISTYPE   SIZE
              --  FIRST  LAST  NIL  TRASH  NULL  IF  THEN  ELSE
              --  WITH  FROM  FOR  IN
              --  ANY
              --  }   ENDCASE 
              --  {  BEGIN  SELECT

              --ALIASES:
              --  id       tokenID
              --  num      tokenNUM
              --  lnum     tokenLNUM
              --  flnum    tokenFLNUM
              --  string   tokenSTR
              --  lstring  tokenLSTR
              --  char     tokenCHAR
              --  atom     tokenATOM
              --  bracketed  tokenBRACKET
              --  -        tokenMINUS
              --  .        tokenDOT
              --  =        tokenEQUAL
              --  =>       tokenARROW
              --  <        tokenLESS
              --  <=       tokenLE
              --  >        tokenGREATER
              --  >=       tokenGE
              --  #        tokenNE
              --  ~        tokenTILDE
              --  .        initialSymbol

              --PRODUCTIONS:

              -- goal           ::= . module 
          NULL;
        1  => -- module         ::= directory identlist cedar proghead trusted checked begin
          {
          d: Tree.Link ~ tm.Domain[v[top+3].n];
          r: Tree.Link _ tm.Range[v[top+3].n];
          IF v[top+1].t = 1 THEN {
            name: ATOM ~ NARROW[v[top+1].n];
            t : Tree.Link ~
                tm.MkCross2[
                    tm.MkUnitDecl[tm.MkDeclElem[name, tm.MkInterfaceType[name]]],
                    name];
            r _ (IF r # Tree.null THEN tm.MkPair[r, t] ELSE t)}
          ELSE
            FOR ids: AtomList _ NARROW[v[top+1].n], ids.rest UNTIL ids = NIL DO
              name: ATOM ~ ids.first;
              t : Tree.Link ~
                tm.MkCross2[
                    tm.MkUnitDecl[tm.MkDeclElem[name, tm.MkInterfaceType[name]]],
                    name];
              r _ (IF r # Tree.null THEN tm.MkPair[r, t] ELSE t)
              ENDLOOP;
          tm.PushLink[tm.MkArrow2[v[top].n, tm.MkArrow[d, r]]];
          v[top].n _ v[top+1].n _ v[top+3].n _ NIL;
          };
        2  => -- module         ::= directory identlist cedar defhead begin 
          {
          range: Tree.Link;
          IF v[top+1].t # 1 THEN {
            typeList: LIST OF Tree.Link _ NIL;
            FOR ids: AtomList _ NARROW[v[top+1].n], ids.rest UNTIL ids = NIL DO
              typeList _ CONS[tm.MkInterfaceType[ids.first], typeList];
              ENDLOOP;
            range _ tm.MkCrossReverse[typeList]}
          ELSE range _ tm.MkInterfaceType[NARROW[v[top+1].n]];
          tm.PushLink[tm.MkArrow[v[top].n, range]];
          v[top].n _ v[top+1].n _ NIL
          };
        3  => -- begin          ::= {
              -- begin          ::= BEGIN
          NULL;
        4  => -- includeitem    ::= id : FROM string using
              -- includeitem    ::= id : TYPE using
              -- includeitem    ::= id using
          {
          name: ATOM ~ AtomV[top];
          v[top].n _ tm.MkDeclElem[name, tm.MkInterfaceType[name]];
          };
        5  => -- includeitem    ::= id : TYPE id using
          v[top].n _ tm.MkDeclElem[AtomV[top], tm.MkInterfaceType[AtomV[top+3]]];
        6  => -- cedar          ::= CEDAR
              -- cedar          ::=
          NULL;
        7  => -- proghead       ::= resident safe class arguments locks interface tilde public 
          {v[top].n _ v[top+5].n;  v[top+5].n _ NIL};
        8  => -- resident       ::= 
          NULL;
        9  => -- defhead        ::= definitions locks imports shares tilde public 
          NULL;
       10  => -- definitions    ::= DEFINITIONS 
          definitions _ TRUE;
       11  => -- locks          ::= LOCKS primary lambda
              -- lambda         ::= USING ident typeexp
          NULL;
       12  => -- importitem     ::= id 
          IF ~definitions THEN {
            name: ATOM ~AtomV[top];
            v[top].n _ tm.MkDeclElem[InstName[name], name]};
       13  => -- importitem     ::= id : id 
          IF ~definitions THEN v[top].n _ tm.MkDeclElem[AtomV[top], AtomV[top+2]];
       14  => -- exportitem     ::= id 
          IF ~definitions THEN v[top].n _ AtomV[top];
       15  => -- public         ::= PUBLIC
              -- public         ::= PRIVATE
              -- public         ::=
              -- idlist'        ::= id 
          NULL;
       16  => -- identlist'     ::= id : 
              -- identlist'     ::= id position : 
          {v[top].n _ AtomV[top];  v[top].t _ 1};
       17  => -- idlist'        ::= id , idlist'  
          NULL;
       18  => -- identlist'     ::= id , identlist' 
          {
          v[top].n _ ConsAtom[top,
              (IF v[top+2].t = 1
                THEN CONS[NARROW[v[top+2].n], NIL]
                ELSE NARROW[v[top+2].n])];
          v[top].t _ v[top+2].t + 1;  v[top+2].n _ NIL;
          };
       19  => -- identlist'     ::= id position , identlist' 
          {
          v[top].n _ ConsAtom[top,
              (IF v[top+3].t = 1
                THEN CONS[NARROW[v[top+3].n], NIL]
                ELSE NARROW[v[top+3].n])];
          v[top].t _ v[top+3].t + 1;  v[top+3].n _ NIL;
          };
       20  => -- position       ::= bracketed 
              -- interval       ::= bracketed 
              -- typeexp        ::= id 
              -- range          ::= id
              -- typeid'        ::= id . id 
              -- typeid'        ::= typeid' . id 
              -- typeappl       ::= typeappl . id 
              -- typeid         ::= id id 
              -- typeid         ::= id typeid 
              -- typeappl       ::= id bracketed 
              -- typeappl       ::= typeid bracketed 
              -- typeappl       ::= typeappl bracketed 
              -- typecons       ::= interval 
              -- range          ::= id interval
              -- range          ::= typeid interval
              -- typecons       ::= dependent { elementlist }
              -- ident             ::= id position :
              -- element        ::= id bracketed
              -- element        ::= bracketed
              -- typecons       ::= dependent monitored RECORD reclist
              -- typecons       ::= ordered base pointertype
              -- typecons       ::= VAR typeexp
              -- typecons       ::= REF readonly typeexp
              -- typecons       ::= REF readonly ANY
              -- typecons       ::= REF
              -- typecons       ::= LIST OF readonly typeexp
              -- typecons       ::= packed ARRAY indextype OF typeexp
              -- typecons       ::= DESCRIPTOR FOR readonly typeexp
              -- typecons       ::= safe transfermode arguments
              -- safe           ::=
              -- arglist        ::= ANY
              -- returnlist     ::= RETURNS ANY
              -- typecons       ::= id RELATIVE typeexp
              -- typecons       ::= typeid RELATIVE typeexp
              -- typecons       ::= heap ZONE
              -- typecons       ::= LONG typeexp
              -- typecons       ::= FRAME bracketed
              -- monitored      ::= MONITORED
              -- dependent      ::= MACHINE DEPENDENT
              -- dependent      ::=
              -- reclist        ::= bracketed
              -- reclist        ::= NULL
              -- pointertype    ::= pointerprefix
              -- pointertype    ::= pointerprefix TO readonly typeexp
              -- transfermode   ::= PROCEDURE
              -- transfermode   ::= PROC
              -- transfermode   ::= PORT
              -- transfermode   ::= SIGNAL
              -- transfermode   ::= ERROR
              -- transfermode   ::= PROCESS
              -- transfermode   ::= PROGRAM
              -- trusted        ::=
              -- binditem       ::= exp
              -- binditem       ::= id : exp
              -- binditem       ::= id ~ ~ exp
              -- caseexpitem    ::= caselabel => exp
              -- casetest       ::= optrelation 
              -- casetest       ::= exp 
              -- caselabel      ::= ident typeexp
              -- optexp         ::= trash
              -- exp            ::= IF exp THEN exp ELSE exp 
              -- exp            ::= casehead caseexplist ENDCASE => exp 
              -- exp            ::= lhs _ exp 
              -- exp            ::= ERROR 
              -- disjunct       ::= disjunct OR conjunct 
              -- conjunct       ::= conjunct AND negation 
              -- negation       ::= ~ relation 
              -- negation       ::= NOT relation 
              -- relation       ::= sum optrelation 
              -- sum            ::= sum addop product 
              -- product        ::= product multop factor 
              -- optrelation    ::= NOT relationtail 
              -- relationtail   ::= IN range 
              -- relop          ::= = 
              -- relop          ::= # 
              -- relop          ::= < 
              -- relop          ::= <= 
              -- relop          ::= > 
              -- relop          ::= >= 
              -- addop          ::= + 
              -- addop          ::= - 
              -- multop         ::= * 
              -- multop         ::= / 
              -- multop         ::= MOD 
              -- factor         ::= addop primary 
              -- primary        ::= prefixop bracketed
              -- primary        ::= VAL bracketed
              -- primary        ::= ALL bracketed
              -- primary        ::= new bracketed
              -- primary        ::= cons bracketed
              -- primary        ::= listcons bracketed
              -- primary        ::= NIL 
              -- primary        ::= typeop bracketed
              -- exp            ::= transferop lhs 
              -- qualifier      ::= . prefixop 
              -- qualifier      ::= . typeop
              -- primary        ::= SIZE bracketed
              -- qualifier      ::= . SIZE
              -- primary        ::= ISTYPE bracketed 
              -- primary        ::= @ lhs
              -- primary        ::= DESCRIPTOR bracketed
          NULL;
       21  => -- lhs            ::= id 
              -- element        ::= id
              -- ident          ::= id : 
              -- lhs            ::= num 
              -- lhs            ::= string 
              -- lhs            ::= lnum 
              -- lhs            ::= flnum 
              -- lhs            ::= char 
              -- lhs            ::= lstring 
              -- lhs            ::= atom 
              -- lhs            ::= NARROW bracketed
              -- lhs            ::= LOOPHOLE bracketed
              -- lhs            ::= APPLY bracketed
              -- qualifier      ::= bracketed
              -- qualifier      ::= . id
              -- qualifier      ::= ^
              -- transferop     ::= SIGNAL
              -- transferop     ::= ERROR
              -- transferop     ::= START
              -- transferop     ::= JOIN
              -- transferop     ::= NEW 
              -- transferop     ::= FORK
              -- prefixop       ::= LONG 
              -- prefixop       ::= ABS 
              -- prefixop       ::= PRED 
              -- prefixop       ::= SUCC 
              -- prefixop       ::= ORD 
              -- prefixop       ::= MIN 
              -- prefixop       ::= MAX 
              -- prefixop       ::= BASE
              -- prefixop       ::= LENGTH
              -- typeop         ::= CODE
              -- typeop         ::= FIRST
              -- typeop         ::= LAST
              -- typeop         ::= NIL
          NULL;
       22  => -- directory      ::= DIRECTORY ;
          v[top].n _ tm.MkUnitDecl[OptionDecl[tm]];
       23  => -- imports        ::= IMPORTS
          v[top].n _ (IF ~definitions THEN tm.MkDeclReverse[NIL] ELSE Tree.null);
       24  => -- exports        ::= EXPORTS 
          v[top].n _ Tree.null;
       25  => -- new            ::= NEW
              -- cons           ::= CONS
              -- listcons       ::= LIST
              -- pointerprefix  ::= POINTER
              -- using          ::= USING bracketed
              -- elementlist    ::=
              -- caseexplist    ::=
          NULL;
       26  => -- includelist    ::= includeitem
          v[top] _ [n~CONS[v[top].n, NIL], t~1];
       27  => -- importlist     ::= importitem
          IF ~definitions THEN v[top].t _ 1;
       28  => -- exportlist     ::= exportitem
              -- elementlist'   ::= element
              -- bindlist       ::= binditem
              -- caselabel'     ::= casetest 
              -- caseexplist'   ::= caseexpitem
          NULL;
       29  => -- includelist    ::= includelist , includeitem
          {v[top] _ [n~CONS[v[top+2].n, NARROW[v[top].n]], t~v[top].t+1];  v[top+2].n _ NIL};
       30  => -- importlist     ::= importlist , importitem
          IF ~definitions THEN {
            v[top].n _ CONS[
                v[top+2].n,
                IF v[top].t = 1 THEN CONS[v[top].n, NIL] ELSE NARROW[v[top].n]];
            v[top].t _ v[top].t+1;
            v[top+2].n _ NIL};
       31  => -- exportlist     ::= exportlist , exportitem
          {v[top].n _ tm.MkPair[v[top].n, v[top+2].n];  v[top+2].n _ NIL};
       32  => -- elementlist'   ::= elementlist' , element
              -- bindlist       ::= bindlist , binditem
              -- caselabel'     ::= caselabel' , casetest 
              -- caseexplist'   ::= caseexplist' , caseexpitem
              -- idlist         ::= idlist'
              -- identlist      ::= identlist'
              -- caselabel      ::= caselabel' 
          NULL;
       33  => -- directory      ::= DIRECTORY includelist ;
          {
          decls: LIST OF Tree.Link ~ CONS[OptionDecl[tm], NARROW[v[top+1].n]];
          v[top].n _ tm.MkDeclReverse[decls];
          v[top+1].n _ NIL;
          };
       34  => -- imports        ::= IMPORTS importlist
          IF ~definitions THEN {
            v[top].n _ (IF v[top+1].t =1
                THEN tm.MkUnitDecl[v[top+1].n]
                ELSE tm.MkDeclReverse[NARROW[v[top+1].n]]);
            v[top+1].n _ NIL}
          ELSE v[top] _ P1.nullValue;
       35  => -- exports        ::= EXPORTS exportlist
          {v[top].n _ v[top+1].n;  v[top+1].n _ NIL};
       36  => -- class          ::= PROGRAM 
          definitions _ FALSE;
       37  => -- safe           ::= UNSAFE
              -- casehead       ::= SELECT exp FROM
          NULL;
       38  => -- class          ::= MONITOR
          definitions _ FALSE; 
       39  => -- packed                ::= PACKED
              -- safe           ::= SAFE
              -- readonly       ::= READONLY
              -- ordered        ::= ORDERED
              -- base           ::= BASE
              -- heap           ::= UNCOUNTED
              -- casehead       ::= WITH binditem SELECT optexp FROM
              -- packed                ::=
              -- readonly       ::=
              -- monitored      ::=
              -- ordered        ::=
              -- base           ::=
              -- heap           ::=
          NULL;
       40  => -- interface      ::= imports exports shares
          {v[top].n _ tm.MkArrow[v[top].n, v[top+1].n];  v[top+1].n _ NIL};
       41  => -- shares         ::= SHARES idlist 
              -- tilde          ::= ~ 
              -- tilde          ::= = 
              -- typeid         ::= typeid'
              -- typeexp        ::= typeid 
              -- typeexp        ::= typecons 
              -- typecons       ::= typeappl 
              -- elementlist    ::= elementlist' 
              -- pointerprefix  ::= POINTER interval 
              -- indextype      ::= typeexp 
              -- arguments      ::= arglist returnlist 
              -- arglist        ::= bracketed 
              -- returnlist     ::= RETURNS bracketed 
              -- caseexplist    ::= caseexplist' 
              -- caseexplist    ::= caseexplist' , 
              -- trash          ::= TRASH 
              -- trash          ::= NULL 
              -- optexp         ::= exp 
              -- exp            ::= disjunct 
              -- disjunct       ::=C conjunct 
              -- conjunct       ::=C negation 
              -- negation       ::=C relation 
              -- relation       ::= sum 
              -- optrelation    ::= relationtail 
              -- relationtail   ::= relop sum 
              -- range          ::= interval 
              -- range          ::= typeid 
              -- sum            ::=C product 
              -- product        ::=C factor 
              -- factor         ::=C primary 
              -- primary        ::= lhs 
              -- lhs            ::= bracketed 
              -- lhs            ::= lhs qualifier 
              -- new            ::= lhs . NEW
              -- cons           ::= lhs . CONS
              -- listcons       ::= lhs . LIST
          NULL;
       42  => -- directory      ::=
          v[top].n _ tm.MkUnitDecl[OptionDecl[tm]];
       43  => -- using          ::= 
              -- locks          ::= 
              -- lambda         ::=
          NULL;
       44  => -- imports        ::=
          v[top].n _ (IF ~definitions THEN tm.MkDeclReverse[NIL] ELSE NIL);
       45  => -- exports        ::=
          v[top].n _ NIL;
       46  => -- shares         ::= 
              -- arglist        ::= 
              -- returnlist     ::= 
              -- indextype      ::=
              -- optexp         ::=
              -- checked         ::=
              -- checked         ::= CHECKED
              -- checked         ::= TRUSTED
              -- checked         ::= UNCHECKED
          NULL;

       -- error or unimplemented
        ENDCASE =>  ERROR;

      ENDLOOP};

  OptionDecl: PROC[tm: TypeCons.TM] RETURNS[Tree.Link] ~ {
    name: ATOM ~ Atom.MakeAtom["&options"];
    RETURN [tm.MkDeclElem[name, tm.MkStringType]]};
    
  }.
