-- file SMTreeBuildImpl.mesa rewritten by PGS, 11-Aug-83 14:19
-- last modified by Satterthwaite, August 11, 1983 2:18 pm
-- last edit by Schmidt, June 11, 1982 3:12 pm

-- pgs [defs: SMParseTable, bcd: SMParseData, grammar: SML] _ SMTreeBuildImpl.mesa;

-- 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],
  SMP1: TYPE --P1-- USING [ActionStack, LinkStack, Value, ValueStack],
  SMParseTable: TYPE ParseTable USING [ProdDataRef],
  Rope: TYPE USING [Fetch, Flatten, FromChar, Length, ROPE, Substr, Text],
  SMTree: TYPE Tree USING [AttrId, Link, Name, NodeName, null],
  SMTreeOps: TYPE --TreeOps-- USING [
    TM,
    NSons, PopTree, PushTree, PushName, PushNode, PushText, SetAttr, SetInfo, UpdateSons],
  SMCommentTable: TYPE USING [Index],
  SMOps: TYPE USING [MS];

-- this program is monitored by the ML in SMReaderImpl

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

  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: ProdDataRef;


 -- initialization/termination

  AssignDescriptors: PUBLIC PROC[
	qd: P1.ActionStack,
	vd: P1.ValueStack, ld: P1.LinkStack,
	pp: 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: CARDINAL] ~ {tm.SetInfo[l[index]]};

 -- propagated attributes

  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  	
	    --  endfile  	
	    
	    -- ALIASES:
	    --  name     tokenID
	    --  string   tokenSTR
	    --  filename  tokenFILENAME
	    --  .        initialSymbol
	    --  endfile tokenEOF

	    -- PRODUCTIONS:


             	-- goal           ::= . source 
	    NULL;
        1  =>	-- source	::= exp endfile  
	    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	
	    NULL;
        7  => -- term ::= term + factor	
	    {
	    tm.PushNode[$union, 2];
	    LinkToSource[top];
	    };
        8  => -- term ::= term THEN factor	
	    {
	    tm.PushNode[$then, 2];
	    LinkToSource[top];
	    };
        9  => -- term ::= term - factor	
	    {
	    tm.PushNode[$exclusion, 2];
	    LinkToSource[top];
	    };
        10  => -- term ::= term ^ factor	
	    {
	    tm.PushNode[$restriction, 2];
	    LinkToSource[top];
	    };
        11  => -- term ::= term \ factor	
	    {
	    tm.PushNode[$splitUpper, 2];
	    LinkToSource[top];
	    };
        12  => -- term ::= term / factor	
	    {
	    tm.PushNode[$splitLower, 2];
	    LinkToSource[top];
	    };
        13  => -- term ::= factor	
	    NULL;
        14  => -- factor ::= appl CROSS factor	
	    {
	    tm.PushNode[$cross, 2];
	    LinkToSource[top];
	    };
        15  => -- factor ::= appl CROSS CROSS factor	
	    {
	    tm.PushNode[$cross2, 2];
	    LinkToSource[top];
	    };
        16  => -- factor ::= appl	
	    NULL;
        17  => -- appl ::= appl bracket	
	    {
	    tm.PushNode[$apply, 2];
	    LinkToSource[top];
	    };
        18  => -- appl ::= appl * bracket	
	    {
	    tm.PushNode[$applyDefault, 2];
	    LinkToSource[top];
	    };
        19  => -- appl ::= primary	
	    NULL;
        20  => -- primary ::= name	
	    PushHashV[top];
        21  => -- primary ::= string	
	    PushStringLitV[top];
        22  => -- primary ::= TYPE	
	    {
	    tm.PushTree[Tree.null];
	    tm.PushNode[$type, 1];
	    LinkToSource[top];
	    };
        23  => -- primary ::= TYPE name	
	    {
	    PushHashV[top+1];
	    tm.PushNode[$type, 1];
	    };
        24  => -- primary ::= STRING	
	    tm.PushNode[$typeSTRING, 0];
        25  => -- term ::= CONTROL	
	    tm.PushNode[$control, 0];
        26  => -- primary ::= ENV	
	    {
	    tm.PushNode[$env, 0];
	    LinkToSource[top];
	    };
        27  => -- primary ::= NIL	
	    {
	    tm.PushNode[$nil, 0];
	    LinkToSource[top];
	    };
        28  => -- primary ::= filename	
	    ProcessFileName[NARROW[v[top].t]];
        29  => -- primary ::= bracket	
	    NULL;
        30  => -- primary ::= primary . name	
	    {
	    PushHashV[top+2];
	    tm.PushNode[$subscript, 2];
	    LinkToSource[top];
	    };
        31  => -- bracket ::= group	
	    NULL;
        32  => -- bracket ::= [ decl ]	
	    {
	    tm.PushNode[$decl, v[top+1].n];
	    tm.SetAttr[1, TRUE];
	    LinkToSource[top];
	    };
        33  => -- bracket ::= [ binding ]	
	    {
	    tm.PushNode[$bind, v[top+1].n];
	    LinkToSource[top];
	    };
        34  => -- bracket ::= REC [ binding ]	
	    {
	    tm.PushNode[$bindRec, v[top+2].n];
	    LinkToSource[top];
	    };
        35  => -- bracket ::= ( exp )	
	    NULL;
        36  => -- group ::= [ expList ]	
	    tm.PushNode[$group, v[top+1].n];
        37  => -- group ::= [ ]	
	    tm.PushNode[$group, 0];
        38  =>	-- expList ::= exp
              	-- expListC ::= exp ,	
              	-- expListS ::= exp ;	
	    v[top].n _ 1;
        39  =>	-- expList ::= expListC exp	
              	-- expList ::= expListS exp	
              	-- expListC ::= expListC exp ,	
              	-- expListS ::= expListS exp ;	
	    v[top].n _ v[top].n + 1;
        40  =>	-- decl ::= declElem
              	-- declC ::= declElem ,
              	-- declS ::= declElem ;	
	    v[top].n _ 1;
        41  =>	-- decl ::= declC declElem
              	-- decl ::= declS declElem	
              	-- declC ::= declC declElem ,	
              	-- declS ::= declS declElem ;	
	    v[top].n _ v[top].n + 1;
        42  => -- declElem ::= name : exp	
	    {
	    PushHashV[top];
	    tm.PushNode[$declElem, -2];
	    };
        43  =>	-- binding ::= bindElem
              	-- bindingC ::= bindElem ,
              	-- bindingS ::= bindElem ;	
	    v[top].n _ 1;
        44  =>	-- binding ::= bindingC bindElem
              	-- binding ::= bindingS bindElem
              	-- bindingC ::= bindingC bindElem ,
              	-- bindingS ::= bindingS bindElem ;	
	    v[top].n _ v[top].n + 1;
        45  => -- 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];
	    };
        46  => -- bindElem ::= declElem ~ exp	
	    {
	    exp: Tree.Link = tm.PopTree;
	    tm.PushNode[$decl, 1];  tm.SetAttr[1, FALSE];
	    tm.PushTree[exp];
	    tm.PushNode[$bindElem, 2];
	    };
        47  => -- 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];
	    };
        48  => -- 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] ~ {
    t, sep: Rope.Text _ NIL;
    index: CARDINAL _ 0;
    n: CARDINAL;
    max: INT ~ name.Length[];

    GetNext: PROC RETURNS[pat: Rope.Text] ~ {
      ch: CHAR;
      start: INT;
      IF index >= max THEN RETURN[NIL];
      ch _ name.Fetch[index];
      SELECT ch FROM
        '[, '], '<, '>, '^, '@, '., '! => {
	  pat _ Rope.FromChar[ch];
	  index _ index + 1;
	  RETURN};
	ENDCASE;
      pat _ NIL;
      start _ index;
      WHILE index < max DO
	ch _ name.Fetch[index];
	SELECT ch FROM
	  '[, '], '<, '>, '*, '^, '@, '., '! => EXIT;
	  ENDCASE;
	index _ index + 1;
	ENDLOOP;
      IF index > start THEN pat _ Rope.Flatten[name, start, index-start]};
	
    CheckNext: PROC[ch: CHAR] RETURNS[BOOL] ~ {
      t: Rope.Text ~ GetNext[];
      RETURN[t.Fetch[0] = ch]};
      
    PushPart: PROC[part: Rope.Text] ~ {
      IF (part.Fetch[part.Length[]-1] = '^) THEN {
        tm.PushName[MakeName[part.Substr[0, part.Length[]-1]]];
        tm.PushNode[$unQuote, 1]}
      ELSE tm.PushText[part]};
	
    IF ~CheckNext['@] THEN ERROR;
    t _ GetNext[];
    IF t.Fetch[0] = '[ THEN {
      t _ GetNext[];
      PushPart[t];
      IF ~CheckNext[']] THEN {
	-- ["Error - missing ']' in '%s'.\n"L, savefn];
	ERROR};
      t _ GetNext[]}
    ELSE tm.PushTree[Tree.null];
    IF t.Fetch[0] = '< THEN {
      t _ GetNext[];  sep _ GetNext[];
      n _ 0;
      WHILE sep.Length[] > 0 AND sep.Fetch[0] = '> DO 
	PushPart[t];
	n _ n + 1;
	t _ GetNext[];  sep _ GetNext[];
	ENDLOOP;
      tm.PushNode[$uiList, n]}
    ELSE tm.PushTree[Tree.null];
    -- now is just a name.ext.ext
    -- get name
    n _ 1;
    PushPart[t];
    IF index < name.Length[] OR sep.Length[] > 0 THEN {
      IF sep.Length = 0 THEN sep _ GetNext[];
      IF sep.Fetch[0] ~= '. THEN {
	-- CWF.WF1["Error - missing '.' in '%s'.\n"L, savefn];
	ERROR};
      DO
	PushPart[GetNext[]];
	n _ n + 1;
	sep _ GetNext[];
	IF sep = NIL OR sep.Length = 0 THEN EXIT;
	IF sep.Fetch[0] = '! THEN EXIT;
	IF sep.Fetch[0] ~= '. THEN {
	  -- CWF.WF1["Error - missing '.' in '%s'.\n"L, savefn];
	  ERROR};
	ENDLOOP};
    tm.PushNode[$uiList, n];
    IF sep ~= NIL AND sep.Fetch[0] = '! THEN {
      hex, highest: BOOL _ FALSE;
      t _ GetNext[];
      FOR n: INT IN [0 .. t.Length[]) DO
	ch: CHAR ~ t.Fetch[n];
	SELECT t.Fetch[n] FROM
	  IN ['0 .. '9] => NULL;
	  IN ['a .. 'f], IN ['A..'F] => hex _ TRUE;
	  'h, 'H => highest _ TRUE;
	  ENDCASE => {
	    -- CWF.WF1["Error - invalid version id: %s\n"L, t];
	    ERROR}
	ENDLOOP;
      IF (hex AND t.Length # 12) OR (highest AND t.Length # 1) THEN {
        -- CWF.WF1["Error - invalid version id: %s\n"L, t];
        ERROR};
      tm.PushText[t]}
    ELSE tm.PushTree[Tree.null];
    -- host directory namelist number
    tm.PushNode[$unitId, 4]};

  }.



        xx => -- declElem ::= group : exp	
	    tm.PushNode[$declElem, 2];