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