WalkCedarParseTreesImpl.mesa
Copyright Ó 1990, 1992, 1993 by Xerox Corporation. All rights reserved.
Sturgis: March 5, 1989 4:07:45 pm PST
Last changed by Theimer on August 9, 1989 11:58:43 pm PDT
Hopcroft July 26, 1989 10:21:00 am PDT
Spreitze, May 27, 1991 7:16 pm PDT
Willie-s, January 22, 1993 4:19 pm PST
DIRECTORY
CCTypes USING[CCError, CCErrorCase, GetAnyTargetType, GetCharType, GetIndirectType, GetRopeType, GetTargetTypeOfIndirect, Operator],
CedarCode,
CedarNumericTypes USING[CreateNumericNode, CreateNumericType],
CedarOtherPureTypes USING[CreateCharNode, CreateRopeNode],
CirioSyntacticOperations USING[CompileForRHS, CreateParseTree, ParseTree, ParseTreeFunctions, LHSapply, LHSDot, LHSFieldIdentifier, LHSIdentifier, LHSuparrow, NameArgPair, RHSApply, RHSCons, RHSAssignment, RHSBinaryOp, RHSConstructor, RHSDot, RHSFieldIdentifier, RHSIdentifier, RHSLiteral, RHSnAryOp, RHSNil, RHSPairConstructor, RHSUnaryOp],
CirioTypes USING[CompilerContext, Node, Type, TypedCode],
IO,
MPLeaves USING[HTIndex, LTIndex],
MPTree USING[Link, Node, NodeName],
Procedures USING [ProcLiteral, CreateProcLiteralType, CreateProcLiteralNode],
Rope USING[Equal, ROPE, Cat, Concat],
TypeOps,
WalkCedarParseTrees USING[];
WalkCedarParseTreesImpl:
CEDAR
PROGRAM
IMPORTS CCTypes, CedarCode, CedarNumericTypes, CedarOtherPureTypes, CirioSyntacticOperations, IO, Procedures, Rope, TypeOps
EXPORTS WalkCedarParseTrees
= BEGIN OPEN CSO: CirioSyntacticOperations;
Type: TYPE = CirioTypes.Type;
TypedCode: TYPE = CirioTypes.TypedCode;
CompilerContext: TYPE = CirioTypes.CompilerContext;
Operator: TYPE = CCTypes.Operator;
CC: TYPE = CirioTypes.CompilerContext;
CCError: ERROR[case: CCTypes.CCErrorCase ¬ syntax, msg: Rope.ROPE ¬ NIL] ¬ CCTypes.CCError;
CreateMPTreeParseTree:
PUBLIC
PROC[tree: MPTree.Link, cc: CompilerContext]
RETURNS[
CSO.ParseTree] =
{RETURN[CSO.CreateParseTree[PTF, tree]]};
PTF:
REF
CSO.ParseTreeFunctions ¬
NEW[
CSO.ParseTreeFunctions¬[
CompileCedarPTExpForRHS,
CompileCedarPTExpForLHS,
CompileCedarPTExpAsFieldExtraction,
CompileCedarPTExpAsFieldSelection,
CompileCedarPTExpShowParseTree]];
CompileCedarPTExpForLHS:
PROC[tree:
CSO.ParseTree, cc: CompilerContext, data:
REF
ANY]
RETURNS[TypedCode] =
BEGIN
pptree: MPTree.Link ¬ NARROW[data];
WITH pptree
SELECT
FROM
hti: MPLeaves.HTIndex =>
RETURN[
CSO.LHSIdentifier[hti.name, cc]];
we have an identifier in hand
node:
REF MPTree.Node =>
BEGIN
kind: MPTree.NodeName = node.name;
nSons: CARDINAL ¬ node.sonLimit - 1;
son1: MPTree.Link ¬ IF nSons > 0 THEN node.son[1] ELSE NIL;
son2: MPTree.Link ¬ IF nSons > 1 THEN node.son[2] ELSE NIL;
left: CSO.ParseTree ¬ CreateMPTreeParseTree[son1, cc];
SELECT node.name
FROM
dot =>
BEGIN
WITH son2
SELECT
FROM
hti: MPLeaves.HTIndex => RETURN[CSO.LHSDot[left, hti.name, cc]];
ENDCASE => CCError[]; -- bad syntax?
END;
uparrow =>
RETURN[CSO.LHSuparrow[left, cc]];
apply => RETURN CompileApply[son1, son2, cc, left];
ENDCASE => CCError[unimplemented]; -- we havn't implemented all the possibilities
END;
ENDCASE => CCError[unimplemented];
END;
firstInt: INT32 ~ INT32.FIRST;
lastInt: INT32 ~ INT32.LAST;
lastCard:
CARD32 ~
CARD32.
LAST;
CompileCedarPTExpForRHS:
PROC[tree:
CSO.ParseTree, nominalTarget: Type, cc: CompilerContext, data:
REF
ANY]
RETURNS[TypedCode] =
BEGIN
pptree: MPTree.Link ¬ NARROW[data];
WITH pptree
SELECT
FROM
node: REF MPTree.Node => RETURN [EvalNode[node, nominalTarget, cc]];
hti: MPLeaves.HTIndex => RETURN[CSO.RHSIdentifier[hti.name, nominalTarget, cc]];
lti: MPLeaves.LTIndex =>
-- we have a literal in hand
BEGIN
WITH lti.value
SELECT
FROM
dint:
REF
DINT =>
SELECT dint
FROM
IN [firstInt .. lastInt] => RETURN[CSO.RHSLiteral[CreateNodeFromLiteral[NEW[INT ¬ dint], cc], cc]];
IN [0 .. lastCard] => RETURN[CSO.RHSLiteral[CreateNodeFromLiteral[NEW[CARD ¬ dint], cc], cc]];
ENDCASE => CCError[unimplemented, "unimplemented literal encountered"];
card: REF CARD => RETURN [CSO.RHSLiteral[CreateNodeFromLiteral[card, cc], cc]];
real: REF REAL => RETURN[CSO.RHSLiteral[CreateNodeFromLiteral[real, cc], cc]];
rope: REF Rope.ROPE => RETURN[CSO.RHSLiteral[CreateNodeFromLiteral[rope, cc], cc]];
proc: REF Procedures.ProcLiteral => RETURN [CSO.RHSLiteral[CreateNodeFromLiteral[proc, cc], cc]];
ENDCASE => CCError[unimplemented, "unimplemented literal encountered"];
END;
ENDCASE => CCError[unimplemented, "unimplemented type encountered"];
END;
EvalNode:
PROC[node:
REF MPTree.Node, nominalTarget: Type, cc: CompilerContext]
RETURNS[TypedCode] =
BEGIN
kind: MPTree.NodeName = node.name;
nSons: CARDINAL ¬ node.sonLimit - 1;
son1: MPTree.Link ¬ IF nSons > 0 THEN node.son[1] ELSE NIL;
son2: MPTree.Link ¬ IF nSons > 1 THEN node.son[2] ELSE NIL;
SELECT kind
FROM
-- only expression types, extremly few of them
or, and, not, relE, relN, relL, relGE, relG, relLE,
plus, uminus, minus, times, div, mod, uparrow =>
-- unary or binary operator
BEGIN
SELECT nSons
FROM
1 =>
-- unary operator
BEGIN
op: Operator ¬
SELECT kind
FROM
not => $not,
uminus => $minus,
plus => $plus,
uparrow => $uparrow,
ENDCASE => CCError[unimplemented];
arg: CSO.ParseTree ¬ CreateMPTreeParseTree[son1, cc];
RETURN[CSO.RHSUnaryOp[op, arg, cc]];
END;
2 =>
-- binary operator
BEGIN
op: Operator ¬
SELECT kind
FROM
-- IS THIS LIST COMPLETE?
or => $or,
and => $and,
relE => $eq,
relN => $ne,
relL => $lt,
relG => $gt,
relGE => $ge,
relLE => $le,
plus => $plus,
minus => $minus,
times => $mult,
div => $div,
mod => $mod,
ENDCASE => CCError[cirioError];
left: CSO.ParseTree ¬ CreateMPTreeParseTree[son1, cc];
right: CSO.ParseTree ¬ CreateMPTreeParseTree[son2, cc];
RETURN[CSO.RHSBinaryOp[op, left, right, cc]];
END;
ENDCASE => CCError[cirioError]; -- shouldn't happen
mwconst =>
BEGIN
IF nSons # 1 THEN CCError[cirioError]; -- shouldn't happen
RETURN[CompileCedarPTExpForRHS[NIL, nominalTarget, cc, son1]];
END;
max, min =>
BEGIN
list: REF MPTree.Node ¬ NARROW[son1];
argList: LIST OF CSO.ParseTree ¬ BuildArgList[list, cc];
op: Operator ¬
SELECT kind
FROM
max => $max,
min => $min,
ENDCASE => CCError[cirioError]; -- shouldn't happen
IF nSons # 1 THEN CCError[cirioError]; -- shouldn't happen
IF list.name # list THEN CCError[cirioError]; -- shouldn't happen
RETURN[CSO.RHSnAryOp[op, argList, cc]];
END;
assignx, dot =>
BEGIN
left: CSO.ParseTree ¬ CreateMPTreeParseTree[son1, cc];
right: CSO.ParseTree ¬ CreateMPTreeParseTree[son2, cc];
IF nSons # 2 THEN CCError[cirioError];
SELECT kind
FROM
assignx => RETURN[CSO.RHSAssignment[left, right, cc]];
dot => RETURN[CSO.RHSDot[left, right, cc]];
ENDCASE => CCError[cirioError];
END;
apply =>
BEGIN
IF nSons # 2 THEN CCError[cirioError];
IF son1 =
NIL
THEN
BEGIN -- simply a record constructor (or array constructor?)
list: REF MPTree.Node ¬ NARROW[son2];
nItems: INT ¬ list.sonLimit-1;
IF nItems = 0
THEN
RETURN[CSO.RHSConstructor[NIL, nominalTarget, cc]];
At this point we must decide whether we are dealing with a name:arg pair list, or simply a list of args
WITH list.son[1]
SELECT
FROM
node:
REF MPTree.Node =>
BEGIN
SELECT
NARROW[list.son[1],
REF MPTree.Node].name
FROM
item => RETURN[CSO.RHSPairConstructor[BuildNameArgPairList[list, cc], nominalTarget, cc]];
ENDCASE => RETURN[CSO.RHSConstructor[BuildArgList[list, cc], nominalTarget, cc]];
END;
ENDCASE => RETURN[CSO.RHSConstructor[BuildArgList[list, cc], nominalTarget, cc]];
END
ELSE RETURN CompileApply[son1, son2, cc, right];
END;
list =>
BEGIN -- presumably a list of arguments to a procedure or an index to an array
we must decide whether we are dealing with a name:arg pair list, or simply a list of args
this code matches that in apply where son1 = nil, perhaps there is a way to combine them?
IF node.sonLimit = 1
THEN
-- the list is empty
RETURN[CSO.RHSConstructor[BuildArgList[node, cc], nominalTarget, cc]];
WITH node.son[1]
SELECT
FROM
son1Node:
REF MPTree.Node =>
BEGIN
SELECT
NARROW[node.son[1],
REF MPTree.Node].name
FROM
item => RETURN[CSO.RHSPairConstructor[BuildNameArgPairList[node, cc], nominalTarget, cc]];
ENDCASE => RETURN[CSO.RHSConstructor[BuildArgList[node, cc], nominalTarget, cc]];
END;
ENDCASE => RETURN[CSO.RHSConstructor[BuildArgList[node, cc], nominalTarget, cc]];
END;
clit =>
BEGIN
WITH son1
SELECT
FROM
lti: MPLeaves.LTIndex =>
-- we have a literal in hand
WITH lti.value
SELECT
FROM
char: REF CHAR => RETURN[CSO.RHSLiteral[CreateNodeFromLiteral[char, cc], cc]];
ENDCASE => CCError[cirioError];
ENDCASE => CCError[cirioError];
END;
nil => RETURN[CSO.RHSNil[nominalTarget, cc]];
cons =>
BEGIN
IF (nSons # 2) OR (son1 # NIL) THEN CCError[cirioError];
WITH son2
SELECT
FROM
node:
REF MPTree.Node =>
BEGIN
list: CSO.ParseTree ¬ CreateMPTreeParseTree[node, cc];
RETURN[CSO.RHSCons[list, nominalTarget, cc]];
END;
ENDCASE => CCError[cirioError];
END;
addr =>
BEGIN
arg: CSO.ParseTree ¬ CreateMPTreeParseTree[son1, cc];
IF nSons # 1 THEN CCError[cirioError]; -- shouldn't happen
RETURN[CSO.RHSUnaryOp[$address, arg, cc]];
END;
float => {
-- this used to be a MPLeaves.LTIndex
lti: MPLeaves.LTIndex ¬ NARROW[son1];
WITH lti.value
SELECT
FROM
real: REF REAL => RETURN[CSO.RHSLiteral[CreateNodeFromLiteral[real, cc], cc]];
dreal:
REF
DREAL => {
real: REF REAL ¬ NEW[REAL ¬ dreal];
RETURN[CSO.RHSLiteral[CreateNodeFromLiteral[real, cc], cc]];
};
ENDCASE => CCError[unimplemented, "float not REAL or DREAL"];
};
ENDCASE => CCError[unimplemented, "unimplemented mptree node encountered"];
END;
CompileApply:
PROC [son1, son2: MPTree.Link, cc:
CC, side: {left, right}]
RETURNS [TypedCode] ~ {
WITH son1
SELECT
FROM
hti: MPLeaves.HTIndex =>
IF hti.name.Equal["GLOBALVARS"]
THEN {
name: Rope.ROPE ¬ NIL;
nToSkip: INT ¬ 0;
gf: CirioTypes.Node ¬ NIL;
gft: CirioTypes.Type;
litTc: TypedCode;
IF son2#
NIL
THEN
WITH son2
SELECT
FROM
node:
REF MPTree.Node =>
SELECT node.name
FROM
list => {
IF node.sonLimit < 2 OR node.sonLimit > 3 THEN CCError[operation, "GLOBALVARS[] must be given a program name, maybe a number to skip, and no more"];
WITH node.son[1]
SELECT
FROM
hti2: MPLeaves.HTIndex => name ¬ hti2.name;
ENDCASE => ERROR CCError[operation, "The first argument to GLOBALVARS[] must be a literal program name"];
IF node.sonLimit>2
THEN
WITH node.son[2]
SELECT
FROM
lti: MPLeaves.LTIndex =>
WITH lti.value
SELECT
FROM
ri: REF INT => nToSkip ¬ ri;
rc: REF CARD => IF rc < INT.LAST THEN nToSkip ¬ rc ELSE ERROR CCError[operation, "The second argument to GLOBALVARS[] must be a literal integer (in [0..INT.LAST])"];
ENDCASE => ERROR CCError[operation, "The second, literal, argument to GLOBALVARS[] must be a literal number"];
ENDCASE => ERROR CCError[operation, "The second argument to GLOBALVARS[] must be a literal integer"];
};
ENDCASE => ERROR CCError[operation, "The arguments to GLOBALVARS must be a list or identifier"];
hti2: MPLeaves.HTIndex => name ¬ hti2.name;
ENDCASE => ERROR CCError[operation, "GLOBALVARS[] must be given a literal program name"]
ELSE ERROR CCError[operation, "GLOBALVARS[] must be given a literal program name (and maybe a number to skip)"];
IF cc.moduleScope=NIL THEN CCError[operation, "current compiler context cannot fetch global frames"];
gf ¬ cc.moduleScope.GetModule[cc.moduleScope, name, nToSkip];
IF gf=NIL THEN CCError[operation, IO.PutFR["can't get global vars for module %g skip %g", [rope[name]], [integer[nToSkip]] ]];
gft ¬ CedarCode.GetTypeOfNode[gf];
litTc ¬ CSO.RHSLiteral[gf, cc];
SELECT side
FROM
left => RETURN [litTc];
right => RETURN[[code: CedarCode.ConcatCode[litTc.code, CedarCode.CodeToLoadThroughIndirect[gft]], type: CCTypes.GetTargetTypeOfIndirect[gft]]];
ENDCASE => ERROR;
}
ELSE
IF hti.name.Equal["EXPRTYPE"]
THEN {
tt: CirioTypes.Type ~ TypeOps.CreateTypeType[cc];
tit: CirioTypes.Type ~ CCTypes.GetIndirectType[tt];
subjPT: CSO.ParseTree;
subjTC: TypedCode;
tni: TypeOps.TypeIndirectNodeInfo;
tn: CirioTypes.Node;
SELECT side
FROM
left => CCError[operation, "EXPRTYPE expressions do not yield left-hand sides"];
right => NULL;
ENDCASE => ERROR;
IF son2=NIL THEN CCError[operation, "EXPRTYPE must be given an argument"];
subjPT ¬ CreateMPTreeParseTree[son2, cc];
subjTC ¬ CSO.CompileForRHS[subjPT, CCTypes.GetAnyTargetType[cc], cc];
tni ¬ NEW [TypeOps.TypeIndirectNodeInfoBody ¬ [GetDefType, subjTC.type]];
tn ¬ TypeOps.CreateTypeIndirectNode[tit, tni];
RETURN[CSO.RHSLiteral[tn, cc]];
};
ENDCASE => NULL;
{left: CSO.ParseTree;
left ¬ CreateMPTreeParseTree[son1, cc];
SELECT side
FROM
left => RETURN[CSO.LHSapply[left, AlwaysLookLikeList[son2, cc], cc]];
right => RETURN[CSO.RHSApply[left, AlwaysLookLikeList[son2, cc], cc]];
ENDCASE => ERROR;
}};
GetDefType:
PROC [data:
REF
ANY]
RETURNS [CirioTypes.Type]
~ {RETURN [NARROW[data]]};
AlwaysLookLikeList:
PROC[presumedList: MPTree.Link, cc:
CC]
RETURNS[
CSO.ParseTree] =
BEGIN
IF presumedList #
NIL
THEN
WITH presumedList
SELECT
FROM
node:
REF MPTree.Node =>
SELECT node.name
FROM
list => RETURN[CreateMPTreeParseTree[presumedList, cc]];
ENDCASE => NULL;
ENDCASE => NULL;
ok, we have to encase it in a list
BEGIN
listSize: INT ¬ IF presumedList = NIL THEN 0 ELSE 1;
listNode: REF MPTree.Node ¬ NEW[MPTree.Node[listSize]];
listNode.name ¬ list;
IF listSize = 1 THEN listNode.son[1] ¬ presumedList;
RETURN[CreateMPTreeParseTree[listNode, cc]];
END;
END;
CompileCedarPTExpAsFieldExtraction:
PROC[tree:
CSO.ParseTree, fieldContext: CirioTypes.Type, cc: CompilerContext, data:
REF
ANY]
RETURNS[TypedCode] =
BEGIN
pptree: MPTree.Link ¬ NARROW[data];
WITH pptree
SELECT
FROM
hti: MPLeaves.HTIndex =>
RETURN[
CSO.RHSFieldIdentifier[hti.name, fieldContext, cc]];
we have an identifier in hand
ENDCASE => CCError[cirioError];
END;
CompileCedarPTExpAsFieldSelection:
PROC[tree:
CSO.ParseTree, fieldIndirectContext: CirioTypes.Type, cc: CompilerContext, data:
REF
ANY]
RETURNS[TypedCode] =
BEGIN
pptree: MPTree.Link ¬ NARROW[data];
WITH pptree
SELECT
FROM
hti: MPLeaves.HTIndex =>
RETURN[
CSO.LHSFieldIdentifier[hti.name, fieldIndirectContext, cc]];
we have an identifier in hand
ENDCASE => CCError[cirioError];
END;
CompileCedarPTExpShowParseTree:
PROC [tree:
CSO.ParseTree, cc: CompilerContext, data:
REF
ANY]
RETURNS [Rope.
ROPE] =
BEGIN
pptree: MPTree.Link ¬ NARROW[data];
innerShowParseTree:
PROC [pptree: MPTree.Link, nestingLevel:
CARDINAL]
RETURNS [Rope.
ROPE] =
BEGIN
blanks: Rope.ROPE ¬ NIL;
ptNode: Rope.ROPE;
THROUGH [1..nestingLevel]
DO
blanks ¬ Rope.Concat[blanks, " "];
ENDLOOP;
IF pptree =
NIL THEN
ptNode ¬ "NIL"
ELSE
WITH pptree
SELECT
FROM
node:
REF MPTree.Node =>
BEGIN
nameRef: REF ANY ← NEW [MPTree.NodeName ← node.name];
name: Rope.ROPE ← IO.PutFR["%g", IO.refAny[nameRef]];
name: Rope.ROPE ¬ NodeNameRopes[node.name];
info: Rope.ROPE ¬ IO.PutFR1[", info: %g\n", IO.card[node.info]];
sons: Rope.ROPE ¬ NIL;
name ¬ Rope.Concat[name, " attr: ["];
name ¬ Rope.Concat[name, IF node.attr[1] THEN "TRUE" ELSE "FALSE"];
name ¬ Rope.Concat[name, IF node.attr[2] THEN ", TRUE" ELSE ", FALSE"];
name ¬ Rope.Concat[name, IF node.attr[3] THEN ", TRUE]" ELSE ", FALSE]"];
name ¬ Rope.Concat[name, info];
FOR i:
CARDINAL
IN [1..node.sonLimit-1]
DO
sons ¬ Rope.Concat[sons, innerShowParseTree[node.son[i], nestingLevel+1]];
ENDLOOP;
ptNode ¬ Rope.Concat[name, sons];
END;
hti: MPLeaves.HTIndex =>
BEGIN
index: Rope.ROPE ¬ IO.PutFR1[" index: %g", IO.int[hti.index]];
ptNode ¬ Rope.Concat[hti.name, index];
END;
lti: MPLeaves.LTIndex =>
BEGIN
index: Rope.ROPE ¬ IO.PutFR1[" index: %g", IO.int[lti.index]];
WITH lti.value
SELECT
FROM
dint:
REF
DINT => {
int: INT ¬ dint;
ptNode ¬ IO.PutFR1["%g", IO.int[int]];
};
int: REF INT => ptNode ¬ IO.PutFR1["%g", IO.int[int]];
real: REF REAL => ptNode ¬ IO.PutFR1["%g", IO.real[real]];
char: REF CHAR => ptNode ¬ IO.PutFR1["%g", IO.char[char]];
rope: REF Rope.ROPE => ptNode ¬ rope;
proc: REF Procedures.ProcLiteral => ptNode ¬ "PROC. LITERAL";
ENDCASE => CCError[unimplemented, "unimplemented literal encountered"];
ptNode ¬ Rope.Cat[ptNode, index, ", literal: ", lti.literal];
END;
ENDCASE => CCError[unimplemented, "unimplemented type encountered"];
RETURN [Rope.Cat[blanks, ptNode, "\n"]];
END;
RETURN [innerShowParseTree[pptree, 0]];
END;
BuildArgList:
PROC[list:
REF MPTree.Node, cc: CompilerContext]
RETURNS[
LIST
OF
CSO.ParseTree] =
BEGIN
nElements: CARDINAL ¬ list.sonLimit - 1;
argList: LIST OF CSO.ParseTree ¬ NIL;
IF list.name # list THEN CCError[cirioError]; -- shouldn't happen
FOR
I:
INT
DECREASING
IN [1..nElements]
DO
pt: CSO.ParseTree ¬ CreateMPTreeParseTree[list.son[I], cc];
argList ¬ CONS[pt, argList];
ENDLOOP;
RETURN[argList];
END;
BuildNameArgPairList:
PROC[list:
REF MPTree.Node, cc: CompilerContext]
RETURNS[
LIST
OF
CSO.NameArgPair] =
BEGIN
nPairs: CARDINAL ¬ list.sonLimit - 1;
pairList: LIST OF CSO.NameArgPair ¬ NIL;
IF list.name # list THEN CCError[cirioError]; -- shouldn't happen
FOR
I:
INT
DECREASING
IN [1..nPairs]
DO
pair: REF MPTree.Node ¬ NARROW[list.son[I]];
id: Rope.ROPE ¬ MPTreeAsId[pair.son[1]];
arg: MPTree.Link ¬ pair.son[2];
argt: CSO.ParseTree ¬ CreateMPTreeParseTree[arg, cc];
IF pair.name # item THEN CCError[cirioError]; -- shouldn't happen
pairList ¬ CONS[[id, argt], pairList];
ENDLOOP;
RETURN[pairList];
END;
MPTreeAsId:
PROC[pptree: MPTree.Link]
RETURNS[Rope.
ROPE] =
BEGIN
WITH pptree
SELECT
FROM
hti: MPLeaves.HTIndex => RETURN[hti.name];
ENDCASE => CCError[cirioError]; -- shouldn't happen
END;
in MPTrees a literal is represented as a REF to the value. (So we can avoid interpreting the textual value of the literal.)
CreateNodeFromLiteral:
PROC[literal:
REF
ANY, cc:
CC]
RETURNS[CirioTypes.Node] =
BEGIN
type: Type ¬ CreateCedarLiteralType[literal, cc];
WITH literal
SELECT
FROM
lit: REF REAL => RETURN[CedarNumericTypes.CreateNumericNode[type, literal]];
lit: REF INT => RETURN[CedarNumericTypes.CreateNumericNode[type, literal]];
lit: REF CARD => RETURN[CedarNumericTypes.CreateNumericNode[type, literal]];
lit: REF CHAR => RETURN[CedarOtherPureTypes.CreateCharNode[lit, cc]];
lit: REF Rope.ROPE => RETURN[CedarOtherPureTypes.CreateRopeNode[lit, cc]];
lit: REF Procedures.ProcLiteral => RETURN [Procedures.CreateProcLiteralNode[lit, cc]];
ENDCASE => CCError[unimplemented] -- we havn't implemented many as yet
END;
CreateCedarLiteralType:
PROC[literal:
REF
ANY, cc:
CC]
RETURNS[CirioTypes.Type] =
BEGIN
WITH literal
SELECT
FROM
real:
REF
REAL =>
RETURN[CedarNumericTypes.CreateNumericType[[32, real[]], cc, NIL]];
int:
REF
INT =>
IF (int <
FIRST[
INT16])
OR (int >
LAST[
INT16])
THEN
RETURN[CedarNumericTypes.CreateNumericType[[32, signed[full[]]], cc, NIL]]
ELSE
RETURN[CedarNumericTypes.CreateNumericType[[16, signed[full[]]], cc, NIL]];
card:
REF
CARD =>
BEGIN
IF card <=
CARD32[
LAST[
INT32]]
THEN
RETURN [CedarNumericTypes.CreateNumericType[[16, unsigned[full[]]], cc, NIL]]
ELSE
RETURN[CedarNumericTypes.CreateNumericType[[32, unsigned[full[]]], cc, NIL]];
END;
char:
REF
CHAR => {
t: CirioTypes.Type ~ CCTypes.GetCharType[cc];
IF cc=NIL THEN CCError[cirioError, "CHAR type not defined yet"];
RETURN[t]};
rope:
REF Rope.
ROPE => {
t: CirioTypes.Type ~ CCTypes.GetRopeType[cc];
IF t=NIL THEN CCError[cirioError, "ROPE type not defined yet"];
RETURN[t]};
proc:
REF Procedures.ProcLiteral =>
RETURN [Procedures.CreateProcLiteralType[proc, cc]];
ENDCASE => CCError[unimplemented]; -- we havn't implemented many as yet
END;
NodeNameRopes:
ARRAY MPTree.NodeName
OF Rope.
ROPE ~ [ list: "list", item: "item", decl: "decl", typedecl: "typedecl",
basicTC: "basicTC", enumeratedTC: "enumeratedTC", recordTC: "recordTC", monitoredTC: "monitoredTC", variantTC: "variantTC",
refTC: "refTC", pointerTC: "pointerTC", listTC: "listTC", arrayTC: "arrayTC", arraydescTC: "arraydescTC", sequenceTC: "sequenceTC",
procTC: "procTC", processTC: "processTC", portTC: "portTC", signalTC: "signalTC", errorTC: "errorTC", programTC: "programTC",
anyTC: "anyTC", definitionTC: "definitionTC", unionTC: "unionTC", relativeTC: "relativeTC",
subrangeTC: "subrangeTC", longTC: "longTC", opaqueTC: "opaqueTC", zoneTC: "zoneTC", linkTC: "linkTC", spareTC: "spareTC",
implicitTC: "implicitTC", frameTC: "frameTC", discrimTC: "discrimTC",
entry: "entry", internal: "internal",
unit: "unit", diritem: "diritem", module: "module", body: "body", inline: "inline", lambda: "lambda", block: "block", assign: "assign", extract: "extract",
if: "if",
case: "case", casetest: "casetest", caseswitch: "caseswitch",
bind: "bind",
do: "do", forseq: "forseq", upthru: "upthru", downthru: "downthru",
return: "return", result: "result",
goto: "goto", exit: "exit", loop: "loop",
free: "free",
resume: "resume", reject: "reject", continue: "continue", retry: "retry", catchmark: "catchmark",
restart: "restart", stop: "stop",
lock: "lock", wait: "wait", notify: "notify", broadcast: "broadcast", unlock: "unlock",
null: "null",
label: "label",
open: "open",
enable: "enable", catch: "catch",
dst: "dst", lst: "lst", lstf: "lstf",
syscall: "syscall", checked: "checked", spareS3: "spareS3",
subst: "subst", call: "call", portcall: "portcall", signal: "signal", error: "error", syserror: "syserror", xerror: "xerror",
start: "start", join: "join", apply: "apply",
callx: "callx", portcallx: "portcallx", signalx: "signalx", errorx: "errorx", syserrorx: "syserrorx", startx: "startx", fork: "fork", joinx: "joinx",
index: "index", dindex: "dindex", seqindex: "seqindex", reloc: "reloc",
construct: "construct", union: "union", rowcons: "rowcons", sequence: "sequence", listcons: "listcons",
substx: "substx",
ifx: "ifx", casex: "casex", bindx: "bindx",
assignx: "assignx", extractx: "extractx",
or: "or", and: "and",
relE: "relE", relN: "relN", relL: "relL", relGE: "relGE", relG: "relG", relLE: "relLE", in: "in", notin: "notin",
plus: "plus", minus: "minus", times: "times", div: "div", mod: "mod",
dot: "dot", cdot: "cdot", dollar: "dollar",
create: "create",
not: "not",
uminus: "uminus",
addr: "addr",
uparrow: "uparrow",
min: "min", max: "max", lengthen: "lengthen", abs: "abs", all: "all",
size: "size", first: "first", last: "last", pred: "pred", succ: "succ",
arraydesc: "arraydesc", length: "length", base: "base",
loophole: "loophole",
nil: "nil",
new: "new",
void: "void",
clit: "clit", llit: "llit",
cast: "cast", check: "check", float: "float", pad: "pad", chop: "chop", safen: "safen",
syscallx: "syscallx", narrow: "narrow", istype: "istype",
openx: "openx",
mwconst: "mwconst", cons: "cons",
atom: "atom", typecode: "typecode",
stringinit: "stringinit", textlit: "textlit", signalinit: "signalinit", procinit: "procinit",
intOO: "intOO", intOC: "intOC", intCO: "intCO", intCC: "intCC",
thread: "thread",
none: "none",
exlist: "exlist",
initlist: "initlist",
ditem: "ditem",
self: "self",
gcrt: "gcrt", proccheck: "proccheck",
invalid: "invalid"];
END..