-- file SMTypeConsImpl.mesa
-- last modified by Satterthwaite, August 11, 1983 1:52 pm

DIRECTORY
  Rope: TYPE USING [ROPE, Flatten],
  SMTree: TYPE Tree USING [Link],
  SMTreeOps: TYPE --TreeOps-- USING [
    TM, MakeNode, NthSon, OpName, PopTree, PushNode, PushTree, PushName,
    PushText, SetAttr, Zone],
  SMTypeCons: TYPE --TypeCons-- USING [],
  TimeStamp: TYPE USING [Stamp];

SMTypeConsImpl: CEDAR PROGRAM
    IMPORTS Rope, SMTreeOps
    EXPORTS SMTypeCons ~ {
  -- type tree building (for Cedar units)
  OPEN Tree~~SMTree, TreeOps~~SMTreeOps;

  TM: TYPE ~ TreeOps.TM;

  MkString: PUBLIC PROC[tm: TM, text: Rope.ROPE] RETURNS[Tree.Link] ~ {
    tm.PushText[text.Flatten[]];
    RETURN [tm.PopTree]};


 -- type construction
 
  MkStringType: PUBLIC PROC[tm: TM] RETURNS[Tree.Link] ~ {
    RETURN [tm.MakeNode[$typeSTRING, 0]]};

  MkControlType: PUBLIC PROC[tm: TM] RETURNS[Tree.Link] ~ {
    RETURN [tm.MakeNode[$control, 0]]};

  MkInterfaceType: PUBLIC PROC[tm: TM, id: ATOM] RETURNS[Tree.Link] ~ {
    tm.PushName[id];
    RETURN [tm.MakeNode[$type, 1]]};

  MkStampType: PUBLIC PROC[tm: TM, stamp: TimeStamp.Stamp] RETURNS[Tree.Link] ~ {
    tm.PushTree[(tm.Zone).NEW[TimeStamp.Stamp ← stamp]];
    RETURN [tm.MakeNode[$stamp, 1]]};


  MkPair: PUBLIC PROC[tm: TM, type1, type2: Tree.Link] RETURNS[Tree.Link] ~ {
    tm.PushTree[type1];  tm.PushTree[type2];
    RETURN [tm.MakeNode[$cross, 2]]};

  MkCross: PUBLIC PROC[tm: TM, typeList: LIST OF Tree.Link] RETURNS[Tree.Link] ~ {
    IF typeList = NIL THEN tm.PushNode[$nil, 0]
    ELSE {
      tm.PushTree[typeList.first]; tm.PushTree[MkCross[tm, typeList.rest]];
      tm.PushNode[$cross, 2]};
    RETURN [tm.PopTree]};

  MkCrossReverse: PUBLIC PROC[tm: TM, typeList: LIST OF Tree.Link] RETURNS[Tree.Link] ~ {
    tm.PushNode[$nil, 0];
    FOR l: LIST OF Tree.Link ← typeList, l.rest UNTIL l = NIL DO
      tm.PushTree[l.first];  tm.PushNode[$cross, -2];
      ENDLOOP;
    RETURN [tm.PopTree]};

  MkCross2: PUBLIC PROC[tm: TM, decl, type: Tree.Link] RETURNS[Tree.Link] ~ {
    tm.PushTree[decl];  tm.SetAttr[1, TRUE];
    tm.PushTree[type];
    RETURN [tm.MakeNode[$cross2, 2]]};


  MkDeclElem: PUBLIC PROC[tm: TM, id: ATOM, type: Tree.Link] RETURNS[Tree.Link] ~ {
    tm.PushName[id];  tm.PushTree[type];
    RETURN [tm.MakeNode[$declElem, 2]]};

  MkDecl: PUBLIC PROC[tm: TM, elemList: LIST OF Tree.Link] RETURNS[Tree.Link] ~ {
    n: NAT←0;
    FOR l: LIST OF Tree.Link ← elemList, l.rest UNTIL l = NIL DO
      tm.PushTree[l.first];  n ← n+1;
      ENDLOOP;
    tm.PushNode[$decl, n];  tm.SetAttr[1, TRUE];
    RETURN [tm.PopTree]};

  MkDeclReverse: PUBLIC PROC[tm: TM, elemList: LIST OF Tree.Link] RETURNS[Tree.Link] ~ {
    n: NAT←0;
    FOR l: LIST OF Tree.Link ← elemList, l.rest UNTIL l = NIL DO
      tm.PushTree[l.first];  n ← n+1;
      ENDLOOP;
    tm.PushNode[$decl, -n];  tm.SetAttr[1, TRUE];
    RETURN [tm.PopTree]};


  MkArrow: PUBLIC PROC[tm: TM, domain, range: Tree.Link] RETURNS[Tree.Link] ~ {
    tm.PushTree[domain];  tm.PushTree[range];
    RETURN [tm.MakeNode[$arrow, 2]]};
    

 -- type decomposition
 
  Domain: PUBLIC PROC[tm: TM, arrow: Tree.Link] RETURNS[Tree.Link] ~ {
    IF TreeOps.OpName[arrow] # $arrow THEN ERROR;
    RETURN [TreeOps.NthSon[arrow, 1]]};

  Range: PUBLIC PROC[tm: TM, arrow: Tree.Link] RETURNS[Tree.Link] ~ {
    IF TreeOps.OpName[arrow] # $arrow THEN ERROR;
    RETURN [TreeOps.NthSon[arrow, 2]]};
   
 -- utilities
 
  PushLink: PUBLIC PROC[tm: TM, link: Tree.Link] ~ {tm.PushTree[link]};
  
  PopLink: PUBLIC PROC[tm: TM] RETURNS[Tree.Link] ~ {RETURN [tm.PopTree]};
  
  }.