
<<SMTypeConsImpl.mesa>>
<<Copyright  1985 by Xerox Corporation.  All rights reserved.>>
<<last edit by Satterthwaite, May 28, 1986 11:27:16 am PDT>>
<<>>
<<type tree building for Cedar (.mesa) units>>

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

SMTypeConsImpl: CEDAR PROGRAM
IMPORTS Rope, SMTreeOps
EXPORTS SMTypeCons ~ {
OPEN Tree~~SMTree, TreeOps~~SMTreeOps;

TM: TYPE~SMTypeCons.TM;

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

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

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

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

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

MkUnitDecl: PUBLIC PROC[tm: TM, elem: Tree.Link] RETURNS[Tree.Link] ~ {
tm.PushTree[elem];
tm.PushNode[$decl, 1];  tm.SetAttr[1, TRUE];
RETURN[tm.PopTree]};

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

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

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

}.


