File [ivy]<Satterthwaite>SML>SMTreeBuildImpl.pgs!10

    -- Copyright (C) 1985 by Xerox Corporation.  All rights reserved.
    -- DO NOT CONVERT TO TIOGA FORMAT!  (PGS requires the mesa-style comments)
    -- last edit by Satterthwaite, December 12, 1985 1:37:14 pm PST

    -- pgs [defs: SMParseTable, bcd: SMParseData, grammar: SML] ← SMTreeBuildImpl.pgs

    -- output: new version of SMTreeBuildImpl.mesa, tables in SMParseData.bcd
    --      interface on SMParseTable.mesa
    --      log on PGS.log, grammar on SML.grammar
    --      errors on SMParseData.errlog

    DIRECTORY
      Atom: TYPE USING [MakeAtom],
      SMParseTable: TYPE ParseTable USING [ProdDataRef],
      SMP1: TYPE P1 USING [
        ActionStack, LinkStack, Value, ValueStack],
      Rope: TYPE USING [Fetch, Flatten, Length, ROPE, Substr, Text],
      SMOps: TYPE USING [MS],
      SMTree: TYPE Tree USING [AttrId, Link, Name, NodeName, null],
      SMTreeOps: TYPE TreeOps USING [
        TM, NSons, PopTree, PushTree, PushName, PushNode, PushText,
        SetAttr, SetExt, SetInfo, UpdateSons];

    -- this program is monitored by the ML in SMReaderImpl

    SMTreeBuildImpl: CEDAR PROGRAM
        IMPORTS Atom, Rope, SMTreeOps
        EXPORTS SMP1 = {
      -- parse tree building
      OPEN ParseTable~~SMParseTable, P1~~SMP1, Tree~~SMTree, TreeOps~~SMTreeOps;

      Op: TYPE ~ Tree.NodeName;

     -- local data base (supplied by parser)

      cm: SMOps.MS;
      tm: TreeOps.TM;

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

      prodData: ParseTable.ProdDataRef;

     -- 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;
        cm ← model;  tm ← cm.tm};

     -- stack manipulation
     -- note that r and s may be overlaid in some parameterizations

      PushHashV: PROC[k: NAT] ~ {
        tm.PushName[NARROW[v[k].t]];
        tm.PushNode[$locator,1];  LinkToSource[k]};

      PushStringLitV: PROC[k: NAT] ~ {
        tm.PushText[NARROW[v[k].t]];
        tm.PushNode[$locator,1];  LinkToSource[k]};

     -- the interpretation rules

      LinkToSource: PROC[index: NAT] = {tm.SetInfo[l[index]]};

      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: SMParseData  TYPE: ParseTable  EXPORTS: SELF
    	      -- GOAL:  goal
    	      --TERMINALS:
    	      --  name	string	,		:		;
    	      --  ]		filename
    	      --  [		.		~		=		>
    	      --  +		-		*		/		\		↑
    	      --  (		)
    	      --  LAMBDA	LET	REC	IN
    	      --  TYPE		STRING	ENV	NIL	CONTROL
    	      --  THEN		CROSS

    	      --ALIASES:
    	      --  name		tokenID
    	      --  string		tokenSTR
    	      --  filename	tokenFILENAME
    	      --  .				initialSymbol

    	      --PRODUCTIONS:

    	      -- goal           ::= . source
    			NULL;
             1  => -- source         ::= exp
    			NULL;
             2  => -- exp         ::= LAMBDA term = > exp IN exp
    			{
    			tm.PushNode[$lambda, 3];
    			LinkToSource[top];
    			};
             3  => -- exp         ::= LAMBDA term IN exp
    			{
    			node: Tree.Link ~ tm.PopTree;
    			tm.PushTree[Tree.null];
    			tm.PushTree[node];
    			tm.PushNode[$lambda, 3];
    			LinkToSource[top];
    			};
             4  => -- exp         ::= LET term IN exp
    			{
    			tm.PushNode[$let, 2];
    			LinkToSource[top];
    			};
             5  => -- exp         ::= term - > exp
    			{
    			tm.PushNode[$arrow, 2];
    			LinkToSource[top];
    			};
             6  => -- exp         ::= term - > > exp
    			{
    			tm.PushNode[$arrow2, 2];
    			LinkToSource[top];
    			};
             7  => -- exp         ::= term
    			NULL;
             8  => -- term        ::= term + factor
    			{
    			tm.PushNode[$union, 2];
    			LinkToSource[top];
    			};
             9  => -- term        ::= term THEN factor
    			{
    			tm.PushNode[$then, 2];
    			LinkToSource[top];
    			};
            10  => -- term        ::= term - factor
    			{
    			tm.PushNode[$exclusion, 2];
    			LinkToSource[top];
    			};
            11  => -- term        ::= term ↑ factor
    			{
    			tm.PushNode[$restriction, 2];
    			LinkToSource[top];
    			};
            12  => -- term        ::= term \ factor
    			{
    			tm.PushNode[$splitUpper, 2];
    			LinkToSource[top];
    			};
            13  => -- term        ::= term / factor
    			{
    			tm.PushNode[$splitLower, 2];
    			LinkToSource[top];
    			};
            14  => -- term        ::= factor
    			NULL;
            15  => -- factor       ::= appl CROSS factor
    			{
    			tm.PushNode[$cross, 2];
    			LinkToSource[top];
    			};
            16  => -- factor       ::= appl CROSS CROSS factor
    			{
    			tm.PushNode[$cross2, 2];
    			LinkToSource[top];
    			};
            17  => -- factor       ::= appl
    			NULL;
            18  => -- appl        ::= appl bracket
    			{
    			tm.PushNode[$apply, 2];
    			LinkToSource[top];
    			};
            19  => -- appl        ::= appl * bracket
    			{
    			tm.PushNode[$applyDefault, 2];
    			LinkToSource[top];
    			};
            20  => -- appl        ::= primary
    			NULL;
            21  => -- primary     ::= name
    			PushHashV[top];
            22  => -- primary     ::= string
    			PushStringLitV[top];
            23  => -- primary     ::= TYPE
    			{
    			tm.PushTree[Tree.null];
    			tm.PushNode[$type, 1];
    			LinkToSource[top];
    			};
            24  => -- primary     ::= TYPE name
    			{
    			PushHashV[top+1];
    			tm.PushNode[$type, 1];
    			LinkToSource[top];
    			};
            25  => -- primary     ::= STRING
    			{
    			tm.PushNode[$typeSTRING, 0];
    			LinkToSource[top];
    			};
            26  => -- term        ::= CONTROL
    			{
    			tm.PushNode[$control, 0];
    			LinkToSource[top];
    			};
            27  => -- primary     ::= ENV
    			{
    			tm.PushNode[$env, 0];
    			LinkToSource[top];
    			};
            28  => -- primary     ::= NIL
    			{
    			tm.PushNode[$nil, 0];
    			LinkToSource[top];
    			};
            29  => -- primary     ::= filename
    			ProcessFileName[NARROW[v[top].t]];
            30  => -- primary     ::= bracket
    			NULL;
            31  => -- primary     ::= primary . name
    			{
    			PushHashV[top+2];
    			tm.PushNode[$subscript, 2];
    			LinkToSource[top];
    			};
            32  => -- bracket     ::= group
    			NULL;
            33  => -- bracket     ::= [ decl ]
    			{
    			tm.PushNode[$decl, v[top+1].n];
    			tm.SetAttr[1, TRUE];
    			LinkToSource[top];
    			};
            34  => -- bracket     ::= [ binding ]
    			{
    			tm.PushNode[$bind, v[top+1].n];
    			LinkToSource[top];
    			};
            35  => -- bracket     ::= REC [ binding ]
    			{
    			tm.PushNode[$bindRec, v[top+2].n];
    			LinkToSource[top];
    			};
            36  => -- bracket     ::= ( exp )
    			NULL;
            37  => -- group       ::= [ expList ]
    			tm.PushNode[$group, v[top+1].n];
            38  => -- group       ::= [ ]
    			tm.PushNode[$group, 0];
            39  => -- expList     ::= 	exp
            		-- expListC    ::= 	exp ,
            		-- expListS    ::= 	exp ;
    			v[top].n ← 1;
            40  => -- expList     ::= 	expListC exp
            		-- expList     ::= 	expListS exp
            		-- expListC    ::= 	expListC exp ,
            		-- expListS    ::= 	expListS exp ;
    			v[top].n ← v[top].n + 1;
            41  => -- decl        ::= declElem
            		-- declC       ::= declElem ,
            		-- declS       ::= declElem ;
    			v[top].n ← 1;
            42  => -- decl        ::= declC declElem
            		-- decl        ::= declS declElem
            		-- declC       ::= declC declElem ,
            		-- declS       ::= declS declElem ;
    			v[top].n ← v[top].n + 1;
            43  => -- declElem    ::= name : exp
    			{
    			PushHashV[top];
    			tm.PushNode[$declElem, -2];
    			};
            44  => -- binding     ::= bindElem
            		-- bindingC    ::= bindElem ,
            		-- bindingS    ::= bindElem ;
    			v[top].n ← 1;
            45  => -- binding     ::= bindingC bindElem
            		-- binding     ::= bindingS bindElem
            		-- bindingC    ::= bindingC bindElem ,
            		-- bindingS    ::= bindingS bindElem ;
    			v[top].n ← v[top].n + 1;
            46  => -- bindElem    ::= [ decl ] ~ exp
    			{
    			exp: Tree.Link ~ tm.PopTree;
    			tm.PushNode[$decl, v[top+1].n];
    			tm.SetAttr[1, FALSE];
    			LinkToSource[top];
    			tm.PushTree[exp];
    			tm.PushNode[$bindElem, 2];
    			};
            47  => -- bindElem    ::= declElem ~ exp
    			{
    			exp: Tree.Link ~ tm.PopTree;
    			tm.PushNode[$decl, 1]; tm.SetAttr[1, FALSE];
    			tm.PushTree[exp];
    			tm.PushNode[$bindElem, 2];
    			};
            48  => -- bindElem    ::= name : ~ exp
    			{
    			exp: Tree.Link ~ tm.PopTree;
    			v[top].t ← PushImplicitDecl[tm, v[top].t];
    			tm.PushNode[$decl, 1]; tm.SetAttr[1, FALSE];
    			tm.PushTree[exp];
    			tm.PushNode[$bindElem, 2];
    			};
            49  => -- bindElem    ::= group : ~ exp
    			{
    			exp: Tree.Link ~ tm.PopTree;
    			group: Tree.Link ~ tm.PopTree;
    			tm.UpdateSons[group, PushImplicitDecl];
    			tm.PushNode[$decl, TreeOps.NSons[group]]; tm.SetAttr[1, FALSE];
    			tm.PushTree[exp];
    			tm.PushNode[$bindElem, 2];
    			};

    	        -- error or unimplemented
            ENDCASE =>  ERROR;

          ENDLOOP};

      PushImplicitDecl: PROC[tm: TreeOps.TM, t: Tree.Link] RETURNS[Tree.Link] ~ {
        tm.PushTree[t];
        tm.PushTree[Tree.null];  tm.PushNode[$declElem, 2];
        RETURN [Tree.null]};

      MakeName: PROC[r: Rope.ROPE] RETURNS[Tree.Name] ~ {
        RETURN [Atom.MakeAtom[r]]};

      ProcessFileName: PROC[name: Rope.Text] ~ {
        -- note: the scanner has guaranteed a well-formed file name
        index: CARDINAL ← 1;
        max: INT ~ name.Length;
        s, t, n: INT;

        GetNext: PROC RETURNS[start: INT] ~ {
          ch: CHAR;
          start ← index;
          IF index >= max THEN RETURN;
          index ← index + 1;	-- always include next character
          WHILE index < max DO
            ch ← name.Fetch[index];
            SELECT ch FROM
              '/, '@, '! => EXIT;
              '↑ => {index ← index + 1;  EXIT};
              ENDCASE => index ← index + 1;
            ENDLOOP;
          RETURN};

        Empty: PROC[first, next: INT] RETURNS[BOOL] ~ INLINE {
          RETURN[first >= next]};

        PushPart: PROC[first, next: INT, strip: BOOL←TRUE] ~ {
          start: INT ~ (IF strip THEN first+1 ELSE first);
          part: Rope.ROPE ~ name.Substr[start, next-start];
          IF (part.Length # 0 AND part.Fetch[part.Length-1] = '↑) THEN {	-- disabled
            tm.PushName[MakeName[part.Substr[0, part.Length-1]]];
            tm.PushNode[$unQuote, 1]}
          ELSE tm.PushText[part.Flatten[]]};

        s ← GetNext[];
        IF ~Empty[s, index] AND name.Fetch[s] = '/ THEN {	-- host
          PushPart[s, index, FALSE];  s ← GetNext[]}
        ELSE tm.PushTree[Tree.null];
        n ← s;
        DO
          t ← GetNext[];
          IF Empty[t, index] OR name.Fetch[t] # '/ THEN EXIT;
          n ← t;
          ENDLOOP;
        IF ~Empty[s, n] THEN PushPart[s, n, FALSE]			-- directory(s)
        ELSE tm.PushTree[Tree.null];
        -- now is just a name.ext, name at n
        PushPart[n, t, (name.Fetch[n]='/)];							-- short name
        IF ~Empty[t, index] AND name.Fetch[t] = '! THEN PushPart[t, index]	-- version
        ELSE tm.PushTree[Tree.null];
        -- host directory(s) name(s) version
        tm.PushNode[$unitId, 4];  tm.SetExt[Tree.null]};

      }.