RoseTranslateReduce.Mesa
Last Edited by: Spreitzer, April 29, 1985 8:40:37 pm PDT
DIRECTORY AMTypes, Asserting, IO, OpPrecParse, OrderedSymbolTableRef, Rope, RoseTranslateTypes, RoseTranslateInsides, SignalTypeRegistration, TextNode, TiogaStreams;
RoseTranslateReduce:
CEDAR
PROGRAM
IMPORTS Asserting, IO, RoseTranslateTypes, RoseTranslateInsides, SignalTypeRegistration, OpPrecParse, OrderedSymbolTableRef
EXPORTS RoseTranslateInsides =
BEGIN OPEN RoseTranslateTypes, RoseTranslateInsides;
squareClass, applClass, rsClass, colonClass, arrowDClass, arrowVClass, fmtClass, dashClass, assertClass, commaClass, dotdotClass, catClass, equivClass, semiClass, directoryClass, importsClass, exportsClass, openClass, libClass: PUBLIC TokenClass;
ReduceSquare:
PUBLIC OpPrecParse.Reducer =
BEGIN
IF ErrCheck[args] THEN RETURN [error];
IF OpsCheck[context, sr, ops, LIST[squareClass, rsClass]] THEN RETURN [error];
IF args.first.arg = omitted THEN reduced ← NEW [SquareBracketedRep ← [sr, NIL]]
ELSE
WITH args.first.arg
SELECT
FROM
iel: InterfaceEltList => reduced ← NEW [SquareBracketedRep ← [sr, iel]];
ie: InterfaceElt => {iel: InterfaceEltList ← LIST[ie]; reduced ← NEW[SquareBracketedRep ← [sr, iel]]};
bl: BindingList => reduced ← NEW [SquareBracketedRep ← [sr, bl]];
b: Binding => {bl: BindingList ← LIST[b]; reduced ← NEW[SquareBracketedRep ← [sr, bl]]};
as: Args => {
FOR al: ArgList ← as.args, al.rest
WHILE al #
NIL
DO
IF NOT ValidNodeExpression[al.first] THEN RETURN [Complain[sr, context, "Not a valid NodeExpression: %g", IO.refAny[al.first]]];
ENDLOOP;
reduced ← NEW [SquareBracketedRep ← [sr, as]];
};
ENDCASE => reduced ← Complain[sr, context, "Surroundfix square brackets are used only to construct Interfaces, Parameter lists, or Node Arrays... applying them to %g is garbage", IO.refAny[args.first.arg]];
END;
ReduceAppl: OpPrecParse.Reducer =
BEGIN --making either signal type or cellFn invocation, cell instance, or subscription
subject: REF ANY;
subjectIsID: BOOL ← FALSE;
subjectAsID: ID;
asAny: REF ANY;
job: Job ← NARROW[context];
parms: REF ANY;
IF ErrCheck[args] THEN RETURN [error];
subject ← args.first.arg;
WITH subject
SELECT
FROM
id: ID => subjectIsID ← TRUE;
a: Application => NULL;
ENDCASE => RETURN [Complain[sr, context, "Must Apply %g to an Application or a simple ID, not %g", IO.refAny[args.rest.first.arg], IO.refAny[args.first.arg]]];
IF args.rest.first.arg = omitted THEN parms ← NEW [ArgsRep ← [sr, NIL]]
ELSE
WITH args.rest.first.arg
SELECT
FROM
ri: Int => parms ← NEW [ArgsRep ← [sr, LIST[ri]]];
rr: Reel => parms ← NEW [ArgsRep ← [sr, LIST[rr]]];
dd: Dotdot => parms ← NEW [ArgsRep ← [sr, LIST[dd]]];
a: Application => parms ← NEW [ArgsRep ← [sr, LIST[a]]];
q: Quoted => parms ← NEW [ArgsRep ← [sr, LIST[q]]];
id: ID => parms ← NEW [ArgsRep ← [sr, LIST[id]]];
a: Args => parms ← a;
b: Binding => {bl: BindingList ← LIST[b]; parms ← bl};
bl: BindingList => parms ← bl;
ENDCASE => RETURN [Complain[sr, context, "Must apply to %g a BindingList or ArgList, not %g", IO.refAny[subject], IO.refAny[args.rest.first.arg]]];
IF subjectIsID
THEN {
subjectAsID ← NARROW[subject];
asAny ← SignalTypeRegistration.signalTypes.Lookup[subjectAsID.rope];
IF asAny # NIL THEN RETURN [InstantiateSignalType[context, subjectAsID.rope, parms]];
};
reduced ← NEW [ApplicationRep ← [sr, subject, parms]];
END;
ReduceBinding:
PUBLIC OpPrecParse.Reducer =
BEGIN
b: Binding ← NEW [BindingRep ← [sr]];
IF ErrCheck[args] THEN RETURN [error];
WITH args.first.arg
SELECT
FROM
x: ID => b.name ← x.rope;
ENDCASE => RETURN [Complain[sr, context, "Can't Bind %g", IO.refAny[args.first.arg]]];
WITH args.rest.first.arg
SELECT
FROM
r: ID => NULL;
x: SignalTypeInvocation => NULL;
x: Application => NULL;
x: CellFn => NULL;
x: Int => NULL;
x: Reel => NULL;
x: Quoted => NULL;
x: CedarExpression => NULL;
ENDCASE => RETURN [Complain[sr, context, "Can't Bind %g to %g", IO.refAny[b.name], IO.refAny[args.rest.first.arg]]];
b.value ← args.rest.first.arg;
reduced ← b;
END;
ReduceArrowD:
PUBLIC OpPrecParse.Reducer =
BEGIN
b: Binding;
IF ErrCheck[args] THEN RETURN [error];
WITH args.first.arg
SELECT
FROM
x: Binding => b ← x;
ENDCASE => RETURN [Complain[sr, context, "Can't Initialize something (%g) other than a Binding", IO.refAny[args.first.arg]]];
WITH args.rest.first.arg
SELECT
FROM
fc: CedarExpression => b.initialData ← fc;
ENDCASE => RETURN [Complain[sr, context, "Must initialize with a Cedar literal, not %g", IO.refAny[args.rest.first.arg]]];
b.sr ← sr;
reduced ← b;
END;
ReduceArrowV:
PUBLIC OpPrecParse.Reducer =
BEGIN
b: Binding;
IF ErrCheck[args] THEN RETURN [error];
WITH args.first.arg
SELECT
FROM
x: Binding => b ← x;
ENDCASE => RETURN [Complain[sr, context, "Can't Initialize something (%g) other than a Binding", IO.refAny[args.first.arg]]];
WITH args.rest.first.arg
SELECT
FROM
q: Quoted => b.initialValue ← CedarFromQuoted[q];
ce: CedarExpression => b.initialValue ← ce;
f: Formatted => b.initialValue ← f;
ENDCASE => RETURN [Complain[sr, context, "Can not initialize with %g", IO.refAny[args.rest.first.arg]]];
b.sr ← sr;
reduced ← b;
END;
ReduceFmt:
PUBLIC OpPrecParse.Reducer =
BEGIN
f: Formatted ← NEW [FormattedRep ← [sr: sr, value: NIL, format: NIL]];
IF ErrCheck[args] THEN RETURN [error];
WITH args.first.arg
SELECT
FROM
q: Quoted => f.value ← CedarFromQuoted[q];
fc: CedarExpression => f.value ← fc;
ENDCASE => RETURN [Complain[sr, context, "Can't format something (%g) other than a rope literal or cedar literal", IO.refAny[args.first.arg]]];
WITH args.rest.first.arg
SELECT
FROM
q: Quoted => f.format ← q;
ENDCASE => RETURN [Complain[sr, context, "Format must be a rope literal, not %g", IO.refAny[args.rest.first.arg]]];
reduced ← f;
END;
ReduceDash:
PUBLIC OpPrecParse.Reducer =
BEGIN
assertion: Asserting.Assertion;
IF ErrCheck[args] THEN RETURN [error];
WITH args.rest.first.arg
SELECT
FROM
ral: RefAnyList => assertion ← Asserting.Cons[ral.l.first, ral.l.rest];
ENDCASE => RETURN [Complain[sr, context, "Must assert a list, not %g", IO.refAny[args.rest.first.arg]]];
WITH args.first.arg
SELECT
FROM
ie: InterfaceElt => {ie.assertions ← CONS[assertion, ie.assertions]; ie.sr ← sr};
b: Binding => {b.assertions ← CONS[assertion, b.assertions]; b.sr ← sr};
ENDCASE => RETURN [Complain[sr, context, "Can't assert on something (%g) other than an Interface Element or Binding", IO.refAny[args.first.arg]]];
reduced ← args.first.arg;
END;
ReduceAssert:
PUBLIC OpPrecParse.Reducer =
BEGIN
sofar: CellDef;
IF ErrCheck[args] THEN RETURN [error];
IF (reduced ← sofar ← Sofar[sr, context, args.first.arg]) = NIL THEN RETURN [error];
WITH args.rest.first.arg
SELECT
FROM
ral: RefAnyList => {
FOR ll:
LORA ← ral.l, ll.rest
WHILE ll #
NIL
DO
IF ll.first #
NIL
THEN
WITH ll.first
SELECT
FROM
l: LORA => {sofar.assertions ← CONS[Asserting.Cons[l.first, l.rest], sofar.assertions]; LOOP};
ENDCASE;
Whimper[ral.sr, context, "Assertion list element must be an assertion, not %g", IO.refAny[ll.first]];
ENDLOOP;
};
ENDCASE => RETURN [Complain[args.rest.first.sr, context, "Must assert a list of assertions, not %g", IO.refAny[args.rest.first.arg]]];
END;
ReduceComma:
PUBLIC OpPrecParse.Reducer =
BEGIN
rest: REF ANY;
IF ErrCheck[args] THEN RETURN [error];
WITH args.rest.first.arg
SELECT
FROM
b: Binding => {bl: BindingList ← LIST[b]; rest ← bl};
ie: InterfaceElt => {i: InterfaceEltList ← LIST[ie]; rest ← i};
id: ID => rest ← NEW[ArgsRep ← [sr, LIST[id]]];
q: Quoted => rest ← NEW[ArgsRep ← [sr, LIST[q]]];
ri: Int => rest ← NEW [ArgsRep ← [sr, LIST[ri]]];
rr: Reel => rest ← NEW [ArgsRep ← [sr, LIST[rr]]];
a: Application => rest ← NEW [ArgsRep ← [sr, LIST[a]]];
cat: Cat => rest ← NEW [ArgsRep ← [sr, LIST[cat]]];
sb: SquareBracketed => rest ← NEW [ArgsRep ← [sr, LIST[sb]]];
x: BindingList => rest ← x;
x: InterfaceEltList => rest ← x;
x: Args => rest ← x;
ENDCASE => RETURN [Complain[sr, context, "Can't catenate %g to %g", IO.refAny[args.first.arg], IO.refAny[args.rest.first.arg]]];
WITH rest
SELECT
FROM
bl: BindingList =>
WITH args.first.arg
SELECT
FROM
b: Binding => {bl ← CONS[b, bl]; reduced ← bl};
id: ID => {bl ← CONS[NEW[BindingRep ← bl.first^], bl]; bl.first.sr ← sr; bl.first.name ← id.rope; reduced ← bl};
ENDCASE => reduced ← Complain[sr, context, "Cant prepend %g to BindingList %g", IO.refAny[args.first.arg], IO.refAny[args.rest.first.arg]];
i: InterfaceEltList =>
WITH args.first.arg
SELECT
FROM
ie: InterfaceElt => {i ← CONS[ie, i]; reduced ← i};
id: ID => {i ← CONS[NEW[InterfaceEltRep ← i.first^], i]; i.first.sr ← sr; i.first.name ← id.rope; reduced ← i};
ENDCASE => reduced ← Complain[sr, context, "Can't prepend %g to Interface %g", IO.refAny[args.first.arg], IO.refAny[args.rest.first.arg]];
as: Args => {
as.sr ← sr;
WITH args.first.arg
SELECT
FROM
id: ID => {as.args ← CONS[id, as.args]; reduced ← as};
q: Quoted => {as.args ← CONS[q, as.args]; reduced ← as};
ri: Int => {as.args ← CONS[ri, as.args]; reduced ← as};
rr: Reel => {as.args ← CONS[rr, as.args]; reduced ← as};
a: Application => {as.args ← CONS[a, as.args]; reduced ← as};
cat: Cat => {as.args ← CONS[cat, as.args]; reduced ← as};
sb: SquareBracketed => {as.args ← CONS[sb, as.args]; reduced ← as};
ENDCASE => reduced ← Complain[sr, context, "Can't prepend %g to Args %g", IO.refAny[args.first.arg], IO.refAny[args.rest]];
};
ENDCASE => ERROR;
END;
ReduceDotdot:
PUBLIC OpPrecParse.Reducer =
BEGIN
first, last: INT;
IF ErrCheck[args] THEN RETURN [error];
WITH args.first.arg
SELECT
FROM
i: Int => first ← i.i;
ENDCASE => RETURN [Complain[sr, context, "Can't make range %g .. %g", IO.refAny[args.first.arg], IO.refAny[args.rest.first.arg]]];
WITH args.rest.first.arg
SELECT
FROM
i: Int => last ← i.i;
ENDCASE => RETURN [Complain[sr, context, "Can't make range %g .. %g", IO.refAny[args.first.arg], IO.refAny[args.rest.first.arg]]];
reduced ← NEW [DotdotRep ← [sr, first, last]];
END;
ReduceCat:
PUBLIC OpPrecParse.Reducer =
BEGIN
head, tail: ArgList ← NIL;
IF ErrCheck[args] THEN RETURN [error];
FOR al: OpPrecParse.ArgList ← args, al.rest
WHILE al #
NIL
DO
this: ArgList ← LIST[al.first.arg];
IF NOT ValidNodeExpression[al.first.arg] THEN RETURN [Complain[sr, context, "%g not a valid NodeExpression", IO.refAny[al.first.arg]]];
IF head = NIL THEN head ← this ELSE tail.rest ← this;
tail ← this;
ENDLOOP;
reduced ← NEW [CatRep ← [sr, head]];
END;
ValidNodeExpression:
PROC [ra:
REF
ANY]
RETURNS [valid:
BOOL] = {
valid ← TRUE;
WITH ra
SELECT
FROM
id: ID => NULL;
a: Application => {
WITH a.subject
SELECT
FROM
id: ID => NULL;
ENDCASE => valid ← FALSE;
WITH a.args
SELECT
FROM
as: Args => {
IF as.args = NIL OR as.args.rest # NIL THEN valid ← FALSE
ELSE
WITH as.args.first
SELECT
FROM
dd: Dotdot => NULL;
i: Int => NULL;
ENDCASE => valid ← FALSE;
};
ENDCASE => valid ← FALSE;
};
sb: SquareBracketed => {
WITH sb.subject
SELECT
FROM
as: Args => NULL --valid by construction--;
ENDCASE => valid ← FALSE;
};
cat: Cat => NULL --valid by construction--;
ENDCASE => valid ← FALSE;
};
ReduceEquiv: OpPrecParse.Reducer =
BEGIN
a, b: Arg ← NIL;
ok: BOOL ← TRUE;
IF ErrCheck[args] THEN RETURN [error];
WITH args.first.arg
SELECT
FROM
as: Args => {
ok ← as.args # NIL AND as.args.rest # NIL AND as.args.rest.rest = NIL AND ValidNodeExpression[a ← as.args.first] AND ValidNodeExpression[b ← as.args.rest.first];
};
ENDCASE => ok ← FALSE;
IF NOT ok THEN RETURN [Complain[sr, context, "Must Equivalence a pair of NodeExpressions, not", IO.refAny[args.first.arg]]];
reduced ← NEW [EquivalenceRep ← [sr, a, b]];
END;
ReduceSemi: OpPrecParse.Reducer =
BEGIN
firstRef, secondRef: BOOLEAN ← FALSE;
a: LORA ← LIST[args.first.arg, args.rest.first.arg];
IF ErrCheck[args] THEN RETURN [error];
WITH args.first.arg
SELECT
FROM
x: Binding => NULL;
y: BindingList => NULL;
cs: CedarChildren => NULL;
cd: CellDef => NULL;
wr: WasRef => {firstRef ← TRUE; a ← a.rest};
e: Equivalence => NULL;
ENDCASE => RETURN [Complain[sr, context, "%g not a valid statement", IO.refAny[args.first.arg]]];
WITH args.rest.first.arg
SELECT
FROM
stmts: Statements => {
IF NOT firstRef THEN stmts.statements ← CONS[args.first.arg, stmts.statements];
secondRef ← stmts.hasRefs;
stmts.hasRefs ← stmts.hasRefs OR firstRef;
stmts.sr ← sr;
reduced ← stmts};
x: Binding => reduced ← NEW [StatementsRep ← [sr, a]];
y: BindingList => reduced ← NEW [StatementsRep ← [sr, a]];
fc: CedarChildren => reduced ← NEW [StatementsRep ← [sr, a]];
cd: CellDef => reduced ← NEW [StatementsRep ← [sr, a]];
wr: WasRef => reduced ←
NEW [StatementsRep ← [
sr: sr,
statements: (IF firstRef THEN NIL ELSE LIST[args.first.arg]),
hasRefs: secondRef ← TRUE]];
e: Equivalence => reduced ← NEW [StatementsRep ← [sr, a]];
ENDCASE => RETURN [Complain[sr, context, "%g not a valid statement", IO.refAny[args.rest.first.arg]]];
IF secondRef AND NOT firstRef THEN Whimper[sr, context, "Should have module reference statements before others"];
END;
ReduceDirectory: OpPrecParse.Reducer =
BEGIN
job: Job ← NARROW[context];
reduced ← wasRef;
WITH args.first.arg
SELECT
FROM
a: Args =>
FOR l: ArgList ← a.args, l.rest
WHILE l #
NIL
DO
WITH l.first
SELECT
FROM
id: ID => AddDirectory[job, id.rope];
ENDCASE => RETURN [Complain[sr, context, "DIRECTORY only takes IDs, not %g", IO.refAny[l.first]]];
ENDLOOP;
id: ID => AddDirectory[job, id.rope];
ENDCASE => reduced ← Complain[sr, context, "DIRECTORY must be given an ID or IDList, not %g", IO.refAny[args.first.arg]];
END;
ReduceImports: OpPrecParse.Reducer =
BEGIN
job: Job ← NARROW[context];
reduced ← wasRef;
WITH args.first.arg
SELECT
FROM
a: Args =>
FOR l: ArgList ← a.args, l.rest
WHILE l #
NIL
DO
WITH l.first
SELECT
FROM
id: ID => AddImport[job, id.rope];
ENDCASE => RETURN [Complain[sr, context, "IMPORTS only takes IDs, not %g", IO.refAny[l.first]]];
ENDLOOP;
id: ID => AddImport[job, id.rope];
ENDCASE => reduced ← Complain[sr, context, "IMPORTS must be given an ID or IDList, not %g", IO.refAny[args.first.arg]];
END;
ReduceExports: OpPrecParse.Reducer =
BEGIN
job: Job ← NARROW[context];
reduced ← wasRef;
WITH args.first.arg
SELECT
FROM
a: Args =>
FOR l: ArgList ← a.args, l.rest
WHILE l #
NIL
DO
WITH l.first
SELECT
FROM
id: ID => AddExport[job, id.rope];
ENDCASE => RETURN [Complain[sr, context, "EXPORTS only takes IDs, not %g", IO.refAny[l.first]]];
ENDLOOP;
id: ID => AddExport[job, id.rope];
ENDCASE => reduced ← Complain[sr, context, "EXPORTS must be given an ID or IDList, not %g", IO.refAny[args.first.arg]];
END;
ReduceOpen: OpPrecParse.Reducer =
BEGIN
job: Job ← NARROW[context];
reduced ← wasRef;
WITH args.first.arg
SELECT
FROM
a: Args =>
FOR l: ArgList ← a.args, l.rest
WHILE l #
NIL
DO
WITH l.first
SELECT
FROM
id: ID => AddOpen[job, id.rope];
ENDCASE => RETURN [Complain[sr, context, "OPEN only takes IDs, not %g", IO.refAny[l.first]]];
ENDLOOP;
id: ID => AddOpen[job, id.rope];
ENDCASE => reduced ← Complain[sr, context, "OPEN must be given an ID or IDList, not %g", IO.refAny[args.first.arg]];
END;
ReduceLibrary: OpPrecParse.Reducer =
BEGIN
job: Job ← NARROW[context];
reduced ← wasRef;
WITH args.first.arg
SELECT
FROM
a: Args =>
FOR l: ArgList ← a.args, l.rest
WHILE l #
NIL
DO
WITH l.first
SELECT
FROM
id: ID => AddSymbols[job, id.rope];
ENDCASE => RETURN [Complain[sr, context, "LIBRARY only takes IDs, not %g", IO.refAny[l.first]]];
ENDLOOP;
id: ID => AddSymbols[job, id.rope];
ENDCASE => reduced ← Complain[sr, context, "LIBRARY must be given an ID or IDList, not %g", IO.refAny[args.first.arg]];
END;
Start:
PROC =
BEGIN
argClass: OpPrecParse.TokenClass = OpPrecParse.argClass;
squareClass ← NEW[TokenClassRep ← [000, 200, ReduceSquare]];
applClass ← NEW[TokenClassRep ← [1000, 200, ReduceAppl]];
rsClass ← NEW[TokenClassRep ← [200, 000, NIL, [nullSR, argClass, omitted]]];
colonClass ← NEW[TokenClassRep ← [410, 400, ReduceBinding]];
arrowDClass ← NEW[TokenClassRep ← [350, 360, ReduceArrowD]];
arrowVClass ← NEW[TokenClassRep ← [350, 360, ReduceArrowV]];
fmtClass ← NEW[TokenClassRep ← [410, 400, ReduceFmt]];
dashClass ← NEW[TokenClassRep ← [350, 360, ReduceDash]];
assertClass ← NEW[TokenClassRep ← [080, 090, ReduceAssert]];
commaClass ← NEW[TokenClassRep ← [310, 300, ReduceComma, [nullSR, argClass, omitted]]];
dotdotClass ← NEW[TokenClassRep ← [910, 900, ReduceDotdot]];
catClass ← NEW[TokenClassRep ← [450, 450, ReduceCat]];
equivClass ← NEW[TokenClassRep ← [000, 250, ReduceEquiv]];
semiClass ← NEW[TokenClassRep ← [110, 100, ReduceSemi]];
directoryClass ← NEW[TokenClassRep ← [000, 275, ReduceDirectory]];
importsClass ← NEW[TokenClassRep ← [000, 275, ReduceImports]];
exportsClass ← NEW[TokenClassRep ← [000, 275, ReduceExports]];
openClass ← NEW[TokenClassRep ← [000, 275, ReduceOpen]];
libClass ← NEW[TokenClassRep ← [000, 275, ReduceLibrary]];
ops.Insert[NEW[OpRep ← ["[", [applClass, squareClass]]]];
ops.Insert[NEW[OpRep ← ["]", [rsClass, rsClass]]]];
ops.Insert[NEW[OpRep ← [":", [colonClass, NIL]]]];
ops.Insert[NEW[OpRep ← ["𡤍", [arrowDClass, NIL]]]];
ops.Insert[NEW[OpRep ← ["←v", [arrowVClass, NIL]]]];
ops.Insert[NEW[OpRep ← ["fmt", [fmtClass, NIL]]]];
ops.Insert[NEW[OpRep ← ["-", [dashClass, NIL]]]];
ops.Insert[NEW[OpRep ← ["Assert", [assertClass, NIL]]]];
ops.Insert[NEW[OpRep ← [",", [commaClass, commaClass]]]];
ops.Insert[NEW[OpRep ← ["..", [dotdotClass, NIL]]]];
ops.Insert[NEW[OpRep ← ["cat", [catClass, NIL]]]];
ops.Insert[NEW[OpRep ← ["Equivalence", [NIL, equivClass]]]];
ops.Insert[NEW[OpRep ← [";", [semiClass, NIL]]]];
ops.Insert[NEW[OpRep ← ["Directory", [NIL, directoryClass]]]];
ops.Insert[NEW[OpRep ← ["Imports", [NIL, importsClass]]]];
ops.Insert[NEW[OpRep ← ["Exports", [NIL, exportsClass]]]];
ops.Insert[NEW[OpRep ← ["Open", [NIL, openClass]]]];
ops.Insert[NEW[OpRep ← ["Library", [NIL, libClass]]]];
END;
Start[];
END.