File [ivy]<Satterthwaite>SML>CtoSTreeBuildImpl.pgs!11

    -- 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]]};

      }.