RoseTranslateRead.Mesa
Last Edited by: Spreitzer, July 26, 1983 9:43 am
Last Edited by: Barth, March 8, 1983 10:43 am
DIRECTORY
IO, OpPrecParse, OrderedSymbolTableRef, Rope, RoseTranslateTypes, RoseTranslateInsides, TiogaStreams, UserExec;
RoseTranslateRead:
CEDAR
PROGRAM
IMPORTS IO, OPP: OpPrecParse, OSTR: OrderedSymbolTableRef, Rope, TS: TiogaStreams, RoseTranslateTypes, RoseTranslateInsides, UserExec
EXPORTS RoseTranslateTypes, RoseTranslateInsides =
BEGIN OPEN RoseTranslateTypes, RoseTranslateInsides;
viewerLog: PUBLIC IO.STREAM ← IO.CreateViewerStreams["RoseTranslate.Log"].out;
omitted: PUBLIC REF ANY ← NEW [INT ← 99];
defaultST: PUBLIC SignalType ← NIL;
arglikeError, oplikeError: OPP.Token;
ops: SymbolTable ← OSTR.CreateTable[CompareOps];
colonClass, twiddleClass, ltClass, gtClass, eqClass, commaClass, squareClass, applClass, rsClass, semiClass, cellClass, initClass, defaultInitExprClass, defaultInitDataClass, initDataClass, stateClass, initStateClass, initializerClass, expandClass, cedarClass, evalClass, testClass, endClass, errorClass, directoryClass, importsClass, openClass, libClass, noisyErrClass, myArgClass: TokenClass;
Setup:
PROC =
BEGIN
noisyErrClass ← NEW[TokenClassRep ← [2000, 3000, ReduceNoisily]];
myArgClass ← NEW[TokenClassRep ← [0, 0, NIL, [noisyErrClass, NIL]]];
twiddleClass ← NEW[TokenClassRep ← [610, 600, ReduceTwiddle]];
ltClass ← NEW[TokenClassRep ← [510, 500, ReduceIntElt]];
gtClass ← NEW[TokenClassRep ← [510, 500, ReduceIntElt]];
eqClass ← NEW[TokenClassRep ← [510, 500, ReduceIntElt]];
initClass ← NEW[TokenClassRep ← [450, 1500, ReduceInit]];
colonClass ← NEW[TokenClassRep ← [410, 400, ReduceBinding]];
commaClass ← NEW[TokenClassRep ← [310, 300, ReduceComma, [OPP.argClass, omitted]]];
cedarClass ← NEW[TokenClassRep ← [0, 10000, SimplerReduce]];
directoryClass ← NEW[TokenClassRep ← [0, 275, ReduceDirectory]];
importsClass ← NEW[TokenClassRep ← [0, 275, ReduceImports]];
openClass ← NEW[TokenClassRep ← [0, 275, ReduceOpen]];
libClass ← NEW[TokenClassRep ← [0, 275, ReduceLibrary]];
errorClass ← NEW[TokenClassRep ← [250, 250, ReduceError]];
squareClass ← NEW[TokenClassRep ← [0, 200, ReduceSquare]];
applClass ← NEW[TokenClassRep ← [1000, 200, ReduceAppl]];
rsClass ← NEW[TokenClassRep ← [200, 0, NIL, [OPP.argClass, omitted]]];
semiClass ← NEW[TokenClassRep ← [110, 100, ReduceSemi]];
defaultInitExprClass ← NEW[TokenClassRep ← [80, 1500, ReduceDefaultInitExpr]];
defaultInitDataClass ← NEW[TokenClassRep ← [80, 90, ReduceDefaultInitData]];
initDataClass ← NEW[TokenClassRep ← [80, 90, ReduceInitData]];
stateClass ← NEW[TokenClassRep ← [80, 90, ReduceState]];
initStateClass ← NEW[TokenClassRep ← [80, 90, ReduceInitState]];
initializerClass ← NEW[TokenClassRep ← [80, 90, ReduceInitializer]];
evalClass ← NEW[TokenClassRep ← [80, 90, ReduceEval]];
testClass ← NEW[TokenClassRep ← [80, 90, ReduceTest]];
expandClass ← NEW[TokenClassRep ← [80, 90, ReduceExpand]];
cellClass ← NEW[TokenClassRep ← [0, 10, ReduceCell]];
endClass ← NEW[TokenClassRep ← [10, 0]];
ops.Insert[NEW[OpRep ← [":", [colonClass, NIL]]]];
ops.Insert[NEW[OpRep ← ["~", [twiddleClass, NIL]]]];
ops.Insert[NEW[OpRep ← ["<", [ltClass, NIL]]]];
ops.Insert[NEW[OpRep ← [">", [gtClass, NIL]]]];
ops.Insert[NEW[OpRep ← ["=", [eqClass, NIL]]]];
ops.Insert[NEW[OpRep ← [",", [commaClass, commaClass]]]];
ops.Insert[NEW[OpRep ← ["[", [applClass, squareClass]]]];
ops.Insert[NEW[OpRep ← ["]", [rsClass, rsClass]]]];
ops.Insert[NEW[OpRep ← [";", [semiClass, NIL]]]];
ops.Insert[NEW[OpRep ← ["CELL", [NIL, cellClass]]]];
ops.Insert[NEW[OpRep ← ["NULL", [NIL, myArgClass]]]];
ops.Insert[NEW[OpRep ← ["init", [initClass, NIL], TRUE, FALSE, FALSE]]];
ops.Insert[NEW[OpRep ← ["DefaultInitExpr", [defaultInitExprClass, NIL], TRUE, FALSE, FALSE]]];
ops.Insert[NEW[OpRep ← ["DefaultInitData", [defaultInitDataClass, NIL], TRUE]]];
ops.Insert[NEW[OpRep ← ["InitData", [initDataClass, NIL], TRUE]]];
ops.Insert[NEW[OpRep ← ["State", [stateClass, NIL], TRUE]]];
ops.Insert[NEW[OpRep ← ["InitState", [initStateClass, NIL], TRUE]]];
ops.Insert[NEW[OpRep ← ["Initializer", [initializerClass, NIL], TRUE]]];
ops.Insert[NEW[OpRep ← ["Expand", [expandClass, NIL]]]];
ops.Insert[NEW[OpRep ← ["CEDAR", [NIL, cedarClass], TRUE]]];
ops.Insert[NEW[OpRep ← ["Eval", [evalClass, NIL], TRUE]]];
ops.Insert[NEW[OpRep ← ["Test", [testClass, NIL], TRUE]]];
ops.Insert[NEW[OpRep ← ["EndCell", [endClass, NIL]]]];
ops.Insert[NEW[OpRep ← ["Directory", [NIL, directoryClass]]]];
ops.Insert[NEW[OpRep ← ["Imports", [NIL, importsClass]]]];
ops.Insert[NEW[OpRep ← ["Open", [NIL, openClass]]]];
ops.Insert[NEW[OpRep ← ["Library", [NIL, libClass]]]];
ops.Insert[NEW[OpRep ← ["!!", [OPP.end.class, NIL], FALSE, TRUE]]];
arglikeError ← [OPP.argClass, error];
oplikeError ← [errorClass, NIL];
END;
SetDefaultSignalType: PUBLIC PROC [st: SignalType] = {defaultST ← st};
AddOpen:
PUBLIC
PROC [job: Job, name:
ROPE] =
BEGIN
IF job.opened.Lookup[name] # NIL THEN RETURN;
job.opened.Insert[name];
IF NOT job.emptyOpen THEN job.openStream.PutRope[", "];
job.openStream.PutRope[name]; job.emptyOpen ← FALSE;
AddDirectory[job, name];
END;
AddImport:
PUBLIC
PROC [job: Job, name:
ROPE] =
BEGIN
IF job.imports.Lookup[name] # NIL THEN RETURN;
job.imports.Insert[name];
IF NOT job.emptyImports THEN job.importsStream.PutRope[", "];
job.importsStream.PutRope[name]; job.emptyImports ← FALSE;
AddDirectory[job, name];
END;
AddDirectory:
PUBLIC
PROC [job: Job, name:
ROPE] =
BEGIN
IF job.directory.Lookup[name] # NIL THEN RETURN;
job.directory.Insert[name];
IF NOT job.emptyDirectory THEN job.directoryStream.PutRope[", "];
job.directoryStream.PutRope[name]; job.emptyDirectory ← FALSE;
END;
MyBreak:
PUBLIC
IO.BreakProc =
{
RETURN [
SELECT char
FROM
IN ['a..'z], IN ['A .. 'Z], IN ['0 .. '9] => other,
IO.SP, IO.CR, IO.TAB, IO.LF => sepr,
ENDCASE => break]};
ParseExpression:
PUBLIC
PROC [job: Job, stoppable:
BOOLEAN]
RETURNS [expr:
REF
ANY, next:
ROPE] =
BEGIN
GetToken:
OPP.TokenProc =
BEGIN
asRope: ROPE;
op: Op;
peek: CHAR;
WHILE
TRUE
DO
IF job.exec.UserAbort[] THEN UserExec.UserAborted[job.exec];
IF useOld THEN {useOld ← FALSE; RETURN [[myArgClass, old]]};
job.from.SkipOver[IO.WhiteSpace];
IF railed THEN asRope ← "!!"
ELSE IF job.from.EndOf[] THEN asRope ← "!!"
ELSE
BEGIN
job.tokenCount ← job.tokenCount + 1;
peek ← job.from.PeekChar[];
IF peek = '"
THEN
BEGIN
asAny: REF ANY ← IO.GetRefAny[job.from];
asRope: ROPE ← NARROW[asAny];
RETURN [[myArgClass, NEW [QuotedRep ← [asRope]] ]];
END;
IF peek
IN ['0..'9]
THEN
BEGIN
i: INT ← job.from.GetInt[];
RETURN [[myArgClass, NEW[INT ← i] ]];
END;
IF peek = '-
THEN
BEGIN
IF job.from.GetChar[] # '- THEN ERROR;
IF (peek ← job.from.PeekChar[]) = '-
THEN
BEGIN
IF job.from.GetChar[] # '- THEN ERROR;
WHILE
NOT job.from.EndOf[]
DO
char: CHAR ← job.from.GetChar[];
IF char = '\n THEN EXIT;
IF char = '-
THEN
BEGIN
char ← job.from.GetChar[];
IF char = '- OR char = '\n THEN EXIT;
END;
ENDLOOP;
LOOP;
END
ELSE asRope ← "-";
END
ELSE
IF peek = '!
AND stoppable
THEN
BEGIN
IF job.from.GetChar[] # '! THEN ERROR;
IF job.from.PeekChar[] = '! THEN {[] ← job.from.GetChar[]; asRope ← "!!"}
ELSE asRope ← "!";
END
ELSE asRope ← job.from.GetToken[MyBreak];
END;
op ← NARROW[ops.Lookup[asRope]];
IF op = NIL THEN RETURN [[myArgClass, asRope]];
IF op.terminal THEN {railed ← TRUE; next ← asRope};
IF op.eatsCedar
THEN
BEGIN
IF op.childish
THEN
BEGIN
char: CHAR ← job.from.GetChar[]; --counter Backup in GetToken
--to allow comments there, don't test: IF char # '\n THEN ERROR;
old ← NEW [CedarSourceRep ← [TS.CurInNode[job.from] ]];
TS.SkipChildren[job.from];
END
ELSE
BEGIN
cedar: ROPE ← NIL;
job.from.SkipOver[IO.WhiteSpace];
WHILE
NOT job.from.EndOf[]
DO
char: CHAR ← job.from.GetChar[];
IF char = '|
THEN
BEGIN
IF job.from.PeekChar[] # '| THEN EXIT ELSE [] ← job.from.GetChar[];
END;
cedar ← cedar.Concat[Rope.FromChar[char]];
ENDLOOP;
old ← NEW [CedarLiteralRep ← [cedar]];
END;
useOld ← TRUE;
END;
IF op.class[expectingArg] =
NIL
THEN
BEGIN
job.log.PutF["Syntax error at %g: %g not allowed\n", IO.int[job.from.GetIndex[]], IO.rope[asRope]];
job.errCount ← job.errCount + 1;
RETURN [IF expectingArg THEN arglikeError ELSE oplikeError];
END;
RETURN [[op.class[expectingArg], op.asArg[expectingArg]]];
ENDLOOP;
END;
railed: BOOLEAN ← FALSE;
useOld: BOOLEAN ← FALSE;
old: REF ANY ← NIL;
next ← NIL;
expr ←
OPP.Parse[job, GetToken !
OPP.CantReduce,
OPP.CantFix,
OPP.DoesntFix,
OPP.TerminateErr,
OPP.LastReduceErr,
OPP.InvalidToken =>
BEGIN
job.log.PutF["Congratulations! You trashed the parser (somewhere before %g)... You lose!\n", IO.int[job.from.GetIndex[]]];
job.errCount ← job.errCount + 1;
expr ← NIL;
CONTINUE;
END];
END;
ErrCheck:
PROC [args:
LORA]
RETURNS [errFound:
BOOLEAN] =
BEGIN
WHILE args #
NIL
DO
IF args.first = error THEN RETURN [TRUE];
args ← args.rest;
ENDLOOP;
errFound ← FALSE;
END;
ReduceNoisily:
OPP.Reducer =
BEGIN
reduced ← Complain[context, "Missing op before %g", IO.refAny[args.rest.first]];
END;
SimplerReduce: OPP.Reducer = {reduced ← args.first};
ReduceError: OPP.Reducer = {reduced ← error};
ReduceSquare:
OPP.Reducer =
BEGIN
IF ErrCheck[args] THEN RETURN [error];
IF args.first = omitted THEN reduced ← NEW [SquareBracketedRep ← [NIL]]
ELSE
WITH args.first
SELECT
FROM
iel: InterfaceEltList => reduced ← NEW [SquareBracketedRep ← [iel]];
ie: InterfaceElt => reduced ← NEW[SquareBracketedRep ← [LIST[ie]]];
ENDCASE => reduced ← Complain[context, "Surroundfix square brackets are used only to construct Interfaces... applying them to %g is garbage", IO.refAny[args.first]];
END;
ReduceBinding:
OPP.Reducer =
BEGIN
b: Binding ← NEW [BindingRep];
IF ErrCheck[args] THEN RETURN [error];
WITH args.first
SELECT
FROM
r: ROPE => b.name ← r;
ENDCASE => RETURN [Complain[context, "Can't Bind %g", IO.refAny[args.first]]];
WITH args.rest.first
SELECT
FROM
r: ROPE => NULL;
x: SignalTypeInvocation => NULL;
x: Application => NULL;
x: CellDef => NULL;
ENDCASE => RETURN [Complain[context, "Can't Bind %g to %g", IO.refAny[b.name], IO.refAny[args.rest.first]]];
b.value ← args.rest.first;
reduced ← b;
END;
ReduceComma:
OPP.Reducer =
BEGIN
rest: REF ANY;
IF ErrCheck[args] THEN RETURN [error];
WITH args.rest.first
SELECT
FROM
b: Binding => {bl: BindingList ← LIST[b]; rest ← bl};
ie: InterfaceElt => {i: InterfaceEltList ← LIST[ie]; rest ← i};
r: ROPE => rest ← NEW[ArgsRep ← [LIST[r]]];
q: Quoted => rest ← NEW[ArgsRep ← [LIST[q]]];
ri: REF INT => rest ← NEW [ArgsRep ← [LIST[ri]]];
x: BindingList => rest ← args.rest.first;
x: InterfaceEltList => rest ← args.rest.first;
x: Args => rest ← args.rest.first;
ENDCASE => RETURN [Complain[context, "Can't catenate %g to %g", IO.refAny[args.first], IO.refAny[args.rest.first]]];
WITH rest
SELECT
FROM
bl: BindingList =>
WITH args.first
SELECT
FROM
b: Binding => {bl ← CONS[b, bl]; reduced ← bl};
r: ROPE => {bl ← CONS[NEW[BindingRep ← [name: r, value: bl.first.value]], bl]; reduced ← bl};
ENDCASE => reduced ← Complain[context, "Cant prepend %g to BindingList %g", IO.refAny[args.first], IO.refAny[args.rest.first]];
i: InterfaceEltList =>
WITH args.first
SELECT
FROM
ie: InterfaceElt => {i ← CONS[ie, i]; reduced ← i};
r: ROPE => {i ← CONS[NEW[InterfaceEltRep ← i.first^], i]; i.first.name ← r; reduced ← i};
ENDCASE => reduced ← Complain[context, "Can't prepend %g to Interface %g", IO.refAny[args.first], IO.refAny[args.rest.first]];
as: Args =>
WITH args.first
SELECT
FROM
r: ROPE => {as.args ← CONS[r, as.args]; reduced ← as};
q: Quoted => {as.args ← CONS[q, as.args]; reduced ← as};
ri: REF INT => {as.args ← CONS[ri, as.args]; reduced ← as};
ENDCASE => reduced ← Complain[context, "Can't prepend %g to Args %g", IO.refAny[args.first], IO.refAny[args.rest]];
ENDCASE => ERROR;
END;
ReduceTwiddle:
OPP.Reducer =
BEGIN
left: SignalTypeInvocation;
IF ErrCheck[args] THEN RETURN [error];
WITH args.first
SELECT
FROM
r: ROPE => IF (left ← InstantiateSignalType[context, r, NIL]) = NIL THEN RETURN [error];
sti: SignalTypeInvocation => left ← sti;
ENDCASE => RETURN [Complain[context, "Cant force %g on %g", IO.refAny[args.rest.first], IO.refAny[args.first]]];
WITH args.rest.first
SELECT
FROM
q: Quoted => {left.st ← ForceMesaType[q.rope, left.st]; reduced ← left};
ENDCASE => reduced ← Complain[context, "Can't force %g on %g", IO.refAny[args.rest.first], IO.refAny[args.first]];
END;
ReduceSemi:
OPP.Reducer =
BEGIN
IF ErrCheck[args] THEN RETURN [error];
IF args.first = ignoreMe THEN RETURN [args.rest.first];
IF args.rest.first = ignoreMe THEN RETURN [args.first];
WITH args.first
SELECT
FROM
x: Binding => NULL;
y: BindingList => NULL;
cs: CedarSource => NULL;
ENDCASE => RETURN [Complain[context, "%g not a valid statement", IO.refAny[args.first]]];
WITH args.rest.first
SELECT
FROM
stmts: Statements => {stmts.statements ← CONS[args.first, stmts.statements]; reduced ← stmts};
x: Binding => reduced ← NEW [StatementsRep ← [args]];
y: BindingList => reduced ← NEW [StatementsRep ← [args]];
cs: CedarSource => reduced ← NEW [StatementsRep ← [args]];
ENDCASE => RETURN [Complain[context, "%g not a valid statement", IO.refAny[args.rest.first]]];
END;
ReduceDirectory:
OPP.Reducer =
BEGIN
job: Job ← NARROW[context];
reduced ← ignoreMe;
WITH args.first
SELECT
FROM
a: Args =>
FOR l:
LIST
OF Arg ← a.args, l.rest
WHILE l #
NIL
DO
WITH l.first
SELECT
FROM
r: ROPE => AddDirectory[job, r];
ENDCASE => RETURN [Complain[context, "DIRECTORY only takes IDs, not %g", IO.refAny[l.first]]];
ENDLOOP;
r: ROPE => AddDirectory[job, r];
ENDCASE => reduced ← Complain[context, "DIRECTORY must be given an ID or IDList, not %g", IO.refAny[args.first]];
END;
ReduceImports:
OPP.Reducer =
BEGIN
job: Job ← NARROW[context];
reduced ← ignoreMe;
WITH args.first
SELECT
FROM
a: Args =>
FOR l:
LIST
OF Arg ← a.args, l.rest
WHILE l #
NIL
DO
WITH l.first
SELECT
FROM
r: ROPE => AddImport[job, r];
ENDCASE => RETURN [Complain[context, "IMPORTS only takes IDs, not %g", IO.refAny[l.first]]];
ENDLOOP;
r: ROPE => AddImport[job, r];
ENDCASE => reduced ← Complain[context, "IMPORTS must be given an ID or IDList, not %g", IO.refAny[args.first]];
END;
ReduceOpen:
OPP.Reducer =
BEGIN
job: Job ← NARROW[context];
reduced ← ignoreMe;
WITH args.first
SELECT
FROM
a: Args =>
FOR l:
LIST
OF Arg ← a.args, l.rest
WHILE l #
NIL
DO
WITH l.first
SELECT
FROM
r: ROPE => AddOpen[job, r];
ENDCASE => RETURN [Complain[context, "OPEN only takes IDs, not %g", IO.refAny[l.first]]];
ENDLOOP;
r: ROPE => AddOpen[job, r];
ENDCASE => reduced ← Complain[context, "OPEN must be given an ID or IDList, not %g", IO.refAny[args.first]];
END;
ReduceLibrary:
OPP.Reducer =
BEGIN
job: Job ← NARROW[context];
reduced ← ignoreMe;
WITH args.first
SELECT
FROM
a: Args =>
FOR l:
LIST
OF Arg ← a.args, l.rest
WHILE l #
NIL
DO
WITH l.first
SELECT
FROM
r: ROPE => AddSymbols[job, r];
ENDCASE => RETURN [Complain[context, "LIBRARY only takes IDs, not %g", IO.refAny[l.first]]];
ENDLOOP;
r: ROPE => AddSymbols[job, r];
ENDCASE => reduced ← Complain[context, "LIBRARY must be given an ID or IDList, not %g", IO.refAny[args.first]];
END;
ReduceIntElt:
OPP.Reducer =
BEGIN
ie: InterfaceElt ← NEW [InterfaceEltRep ← []];
IF ErrCheck[args] THEN RETURN [error];
SELECT ops.first.class
FROM
ltClass => ie.input ← NOT (ie.output ← FALSE);
gtClass => ie.input ← NOT (ie.output ← TRUE);
eqClass => ie.input ← ie.output ← TRUE;
ENDCASE => ERROR;
WITH args.first
SELECT
FROM
r: ROPE => ie.name ← r;
ENDCASE => RETURN [Complain[context, "An Interface Element must be identified by an ID, not %g", IO.refAny[args.first]]];
IF args.rest.first = omitted THEN ie.sti ← NEW [SignalTypeInvocationRep ← [defaultST, [NIL, NIL]]]
ELSE
WITH args.rest.first
SELECT
FROM
sti: SignalTypeInvocation => ie.sti ← sti;
r: ROPE => IF (ie.sti ← InstantiateSignalType[context, r, NIL]) = NIL THEN RETURN [error];
ENDCASE => RETURN [Complain[context, "An Interface Element must use a Signal Type, not %g", IO.refAny[args.rest.first]]];
reduced ← ie;
END;
ReduceAppl:
OPP.Reducer =
BEGIN --making either signal type invocation or cell instance
fn: ROPE;
asAny: REF ANY;
job: Job ← NARROW[context];
parms: REF ANY;
IF ErrCheck[args] THEN RETURN [error];
WITH args.first
SELECT
FROM
r: ROPE => fn ← r;
ENDCASE => RETURN [Complain[context, "Must Apply %g to a simple ID, not %g", IO.refAny[args.rest.first], IO.refAny[args.first]]];
IF args.rest.first = omitted THEN parms ← NEW [ArgsRep ← [NIL]]
ELSE
WITH args.rest.first
SELECT
FROM
ri: REF INT => parms ← NEW [ArgsRep ← [LIST[ri]]];
q: Quoted => parms ← NEW [ArgsRep ← [LIST[q]]];
r: ROPE => parms ← NEW [ArgsRep ← [LIST[r]]];
a: Args => parms ← a;
b: Binding => {bl: BindingList ← LIST[b]; parms ← bl};
bl: BindingList => parms ← bl;
ENDCASE => RETURN [Complain[context, "Must apply to %g a BindingList or ArgList, not %g", IO.rope[fn], IO.refAny[args.rest.first]]];
IF (asAny ← signalTypes.Lookup[fn]) #
NIL
THEN
BEGIN
reduced ← InstantiateSignalType[context, fn, parms];
END
ELSE reduced ← NEW [ApplicationRep ← [fn, parms]];
END;
ReduceInit:
OPP.Reducer =
BEGIN
id: ROPE;
IF ErrCheck[args] THEN RETURN [error];
WITH args.rest.first
SELECT
FROM
cl: CedarLiteral => id ← cl.cedar;
ENDCASE => RETURN [Complain[context, "Must init with a CEDAR literal, not %g", IO.refAny[args.rest.first]]];
WITH args.first
SELECT
FROM
a: Application => a.initData ← id;
ENDCASE => RETURN [Complain[context, "Must init an application, not %g", IO.refAny[args.first]]];
reduced ← args.first;
END;
InstantiateSignalType:
PUBLIC
PROC [context:
REF
ANY, name:
ROPE, parms:
REF
ANY]
RETURNS [sti: SignalTypeInvocation] =
BEGIN
job: Job ← NARROW[context];
stce: stcEntry ← NARROW[signalTypes.Lookup[name]];
IF stce = NIL THEN {[] ← Complain[context, "Signal Type %g Undefined", IO.rope[name]]; RETURN [NIL]};
sti ← NEW [SignalTypeInvocationRep ← [NIL, [name, parms]]];
sti.st ← stce.stc[parms !TypeConstructionError =>
BEGIN
[] ← Complain[context, msg];
sti ← NIL;
CONTINUE;
END];
END;
Sofar:
PROC [context, org:
REF
ANY]
RETURNS [cd: CellDef] =
BEGIN
IF org = NIL THEN RETURN [NEW [CellDefRep ← [interface: DigestInterface[context, NIL]]]];
WITH org
SELECT
FROM
cellDef: CellDef => RETURN [cellDef];
sb: SquareBracketed => {cd ← NEW [CellDefRep ← [interface: DigestInterface[context, sb.iel]]]; IF cd.interface = NIL THEN cd ← NIL};
ENDCASE => {[] ← Complain[context, "Bad Cell header: %g", IO.refAny[org]]; cd ← NIL};
END;
InsistOnCedarSource:
PROC [context:
REF
ANY, sofar: CellDef, args:
LORA]
RETURNS [cs: CedarSource, reduced:
REF
ANY] =
BEGIN
WITH args.rest.first
SELECT
FROM
cedar: CedarSource => {cs ← cedar; reduced ← sofar};
ENDCASE => {cs ← NIL; reduced ← Complain[context, "Internal Error"]};
END;
ReduceCell:
OPP.Reducer =
BEGIN
IF ErrCheck[args] THEN RETURN [error];
IF (reduced ← Sofar[context, args.first]) = NIL THEN RETURN [error];
END;
ReduceDefaultInitData:
OPP.Reducer =
BEGIN
sofar: CellDef;
IF ErrCheck[args] THEN RETURN [error];
IF (sofar ← Sofar[context, args.first]) = NIL THEN RETURN [error];
IF sofar.defaultInitDataGiven THEN Whimper[context, "Redefining default Init Data"];
sofar.defaultInitDataGiven ← TRUE;
[sofar.defaultInitDataSource, reduced] ← InsistOnCedarSource[context, sofar, args];
END;
ReduceDefaultInitExpr:
OPP.Reducer =
BEGIN
sofar: CellDef;
IF ErrCheck[args] THEN RETURN [error];
IF (sofar ← Sofar[context, args.first]) = NIL THEN RETURN [error];
WITH args.rest.first
SELECT
FROM
cl: CedarLiteral => sofar.defaultInitExpr ← cl.cedar;
ENDCASE => RETURN [Complain[context, "Found %g when expecting a CEDAR literal", IO.refAny[args.rest.first]]];
IF sofar.defaultInitExprGiven THEN Whimper[context, "Redefining default Init Expression"];
sofar.defaultInitExprGiven ← TRUE;
reduced ← sofar;
END;
ReduceInitData:
OPP.Reducer =
BEGIN
sofar: CellDef;
IF ErrCheck[args] THEN RETURN [error];
IF (sofar ← Sofar[context, args.first]) = NIL THEN RETURN [error];
IF sofar.initDataGiven THEN Whimper[context, "Redefining Init Data"];
sofar.initDataGiven ← TRUE;
[sofar.initDataSource, reduced] ← InsistOnCedarSource[context, sofar, args];
END;
ReduceState:
OPP.Reducer =
BEGIN
sofar: CellDef;
IF ErrCheck[args] THEN RETURN [error];
IF (sofar ← Sofar[context, args.first]) = NIL THEN RETURN [error];
IF sofar.stateGiven THEN Whimper[context, "Redefining State Vector"];
sofar.stateGiven ← TRUE;
[sofar.stateSource, reduced] ← InsistOnCedarSource[context, sofar, args];
sofar.stateInittable ← FALSE;
END;
ReduceInitState:
OPP.Reducer =
BEGIN
sofar: CellDef;
IF ErrCheck[args] THEN RETURN [error];
IF (sofar ← Sofar[context, args.first]) = NIL THEN RETURN [error];
IF sofar.stateGiven THEN Whimper[context, "Redefining State Vector"];
sofar.stateGiven ← TRUE;
[sofar.stateSource, reduced] ← InsistOnCedarSource[context, sofar, args];
sofar.stateInittable ← TRUE;
END;
ReduceExpand:
OPP.Reducer =
BEGIN
sofar: CellDef;
IF ErrCheck[args] THEN RETURN [error];
IF (sofar ← Sofar[context, args.first]) = NIL THEN RETURN [error];
IF sofar.expandGiven THEN Whimper[context, "Redefining Expand Proc"];
sofar.expandGiven ← TRUE;
reduced ← sofar;
WITH args.rest.first
SELECT
FROM
s: Statements => sofar.expandCode ← s;
cs: CedarSource => sofar.expandCode ← NEW [StatementsRep ← [LIST[cs]]];
bl: BindingList => sofar.expandCode ← NEW [StatementsRep ← [LIST[bl]]];
b: Binding => sofar.expandCode ← NEW [StatementsRep ← [LIST[b]]];
ENDCASE => reduced ← Complain[context, "EXPAND must be given a statement or statement list, not %g", IO.refAny[args.rest.first]];
END;
ReduceInitializer:
OPP.Reducer =
BEGIN
sofar: CellDef;
IF ErrCheck[args] THEN RETURN [error];
IF (sofar ← Sofar[context, args.first]) = NIL THEN RETURN [error];
IF sofar.initializerGiven THEN Whimper[context, "Redefining Initializer"];
sofar.initializerGiven ← TRUE;
[sofar.initializerSource, reduced] ← InsistOnCedarSource[context, sofar, args];
END;
ReduceEval:
OPP.Reducer =
BEGIN
sofar: CellDef;
IF ErrCheck[args] THEN RETURN [error];
IF (sofar ← Sofar[context, args.first]) = NIL THEN RETURN [error];
IF sofar.evalGiven THEN Whimper[context, "Redefining Eval Proc"];
sofar.evalGiven ← TRUE;
[sofar.evalSource, reduced] ← InsistOnCedarSource[context, sofar, args];
END;
ReduceTest:
OPP.Reducer =
BEGIN
sofar: CellDef;
IF ErrCheck[args] THEN RETURN [error];
IF (sofar ← Sofar[context, args.first]) = NIL THEN RETURN [error];
IF sofar.testGiven THEN Whimper[context, "Redefining Test Proc"];
sofar.testGiven ← TRUE;
[sofar.testSource, reduced] ← InsistOnCedarSource[context, sofar, args];
END;
CompareOps:
PUBLIC
OSTR.CompareProc =
BEGIN
s1, s2: ROPE;
s1 ←
WITH r1
SELECT
FROM
r: ROPE => r,
op: Op => op.name,
ENDCASE => ERROR;
s2 ←
WITH r2
SELECT
FROM
r: ROPE => r,
op: Op => op.name,
ENDCASE => ERROR;
RETURN [s1.Compare[s2, FALSE]];
END;
Setup[];
END.