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