DIRECTORY AMTypes, Basics, Convert, IO, OperatorPrecedenceParse, Process, RedBlackTree, Rope, RoseTranslateTypes, RoseTranslateInsides, SignalTypeRegistration, TextNode, TiogaStreams;

RoseTranslateRead: CEDAR PROGRAM
IMPORTS Convert, IO, OPP: OperatorPrecedenceParse, Process, RedBlackTree, Rope, RoseTranslateTypes, RoseTranslateInsides, SignalTypeRegistration, TS: TiogaStreams
EXPORTS RoseTranslateInsides =

BEGIN OPEN RoseTranslateTypes, RoseTranslateInsides;

wasRef: PUBLIC WasRef _ NEW [WasRefRep _ ["was module reference"]];

arglikeError, oplikeError: OPP.Token;

ops: PUBLIC SymbolTable _ RedBlackTree.Create[GetOpKey, CompareOps];

ltClass, gtClass, eqClass, lambdaClass, returnClass, cellClass, cellEndClass, nameClass, portsProcClass, applyClass, sfClass, isfClass, initializerClass, refClass, recClass, ivClass, testClass, bbClass, stClass, expandClass, portsClass, cedarClass, intfCedarClass, initCTPropsClass, errorClass, noisyErrClass, myArgClass: TokenClass;

evalClasses: ARRAY EvalType OF TokenClass;
auxClasses: ARRAY AuxClass OF TokenClass;

autoName: Op _ NIL;

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, IO.FF => sepr,
ENDCASE => break]};

ErrCheck: PUBLIC PROC [args: OPP.ArgList] RETURNS [errFound: BOOLEAN] =
BEGIN
WHILE args # NIL DO
IF args.first.arg = error THEN RETURN [TRUE];
args _ args.rest;
ENDLOOP;
errFound _ FALSE;
END;

OpsCheck: PUBLIC PROC [context: REF ANY, sr: SourceRange, ops: OPP.TokenList, classes: TokenClassList] RETURNS [err: BOOL] =
BEGIN
err _ FALSE;
WHILE (ops # NIL) AND (classes # NIL) AND NOT err DO
IF ops.first.class # classes.first THEN {err _ TRUE; EXIT};
ops _ ops.rest;
classes _ classes.rest;
ENDLOOP;
IF (ops # NIL) # (classes # NIL) THEN err _ TRUE;
IF (ops = NIL) AND (classes # NIL) THEN {
Whimper[sr, context, SELECT classes.first FROM
returnClass => "missing RETURN",
rsClass => "missing right square-bracket",
cellEndClass => "missing EndCellType",
ENDCASE => "mismatched LAMBDA - RETURN, [ - ], or CellType - EndCellType"];
RETURN};
IF err THEN Whimper[sr, context, "mismatched LAMBDA - RETURN, [ - ], or CellType - EndCellType"];
END;

ReduceNoisily: PUBLIC OPP.Reducer =
BEGIN
reduced _ Complain[sr, context, "Missing op before %g", IO.refAny[args.rest.first.arg]];
END;

SimplerReduce: PUBLIC OPP.Reducer = {reduced _ args.first.arg};

ReduceError: PUBLIC OPP.Reducer = {reduced _ error};

ReduceIntfCedar: PUBLIC OPP.Reducer = {
IF ErrCheck[args] THEN RETURN [error];
reduced _ NEW [InterfaceCedarRep _ [NARROW[args.first.arg]]];
};

ReduceIntElt: PUBLIC OPP.Reducer =
BEGIN
ie: InterfaceElt _ NEW [InterfaceEltRep _ []];
nodeType: REF ANY;
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.arg SELECT FROM
id: ID => ie.name _ id.rope;
ENDCASE => RETURN [Complain[sr, context, "An Interface Element must be identified by an ID, not %g", IO.refAny[args.first.arg]]];
IF (nodeType _ args.rest.first.arg) = omitted THEN {
IF SignalTypeRegistration.defaultNodeType = NIL THEN RETURN [Complain[sr, context, "No default NodeType"]];
nodeType _ NEW [IDRep _ [sr, SignalTypeRegistration.defaultNodeType]]};
WITH nodeType SELECT FROM
sti: SignalTypeInvocation => ie.sti _ sti;
id: ID => IF (ie.sti _ InstantiateSignalType[context, id.rope, NIL]) = NIL THEN RETURN [error];
ENDCASE => RETURN [Complain[sr, context, "An Interface Element must use a Signal Type, not %g", IO.refAny[nodeType]]];
ie.sr _ sr;
reduced _ ie;
END;

ReduceLambda: PUBLIC OPP.Reducer =
BEGIN
cf: CellFn _ NEW [CellFnRep _ []];
ok: BOOL _ TRUE;
IF ErrCheck[args] THEN RETURN [error];
IF OpsCheck[context, sr, ops, LIST[lambdaClass, returnClass]] THEN RETURN [error];
WITH args.first.arg SELECT FROM
sb: SquareBracketed => WITH sb.subject SELECT FROM
bl: BindingList => cf.args _ bl;
ENDCASE => ok _ FALSE;
ENDCASE => ok _ FALSE;
IF NOT ok THEN RETURN [Complain[sr, context, "LAMBDA must be given parameters, not %g", IO.refAny[args.first.arg]]];
WITH args.rest.first.arg SELECT FROM
cd: CellDef => cf.cd _ cd;
ENDCASE => ok _ FALSE;
IF NOT ok THEN RETURN [Complain[sr, context, "I can only construct functions that return cell types, not %g", IO.refAny[args.rest.first.arg]]];
cf.cd.forFn _ cf;
cf.sr _ sr;
reduced _ cf;
END;

CedarExpressionRope: PUBLIC PROC [fc: CedarExpression] RETURNS [r: ROPE] =
{r _ fc.rope};

CedarFromRope: PUBLIC PROC [r: ROPE, sr: SourceRange _ nullSR] RETURNS [fc: CedarExpression] = {
fc _ NEW [CedarExpressionRep _ [sr, internal, r]];
};

CedarFromID: PUBLIC PROC [id: ID] RETURNS [fc: CedarExpression] =
{fc _ NEW [CedarExpressionRep _ [sr: id.sr, kind: id, rope: id.rope]]};

CedarFromQuoted: PUBLIC PROC [q: Quoted] RETURNS [fc: CedarExpression] =
{fc _ NEW [CedarExpressionRep _ [sr: q.sr, kind: ropeLiteral, rope: Convert.RopeFromRope[q.rope]]]};

Sofar: PUBLIC PROC [sr: SourceRange, context, org: REF ANY] RETURNS [cd: CellDef] =
BEGIN
IF org = autoName THEN cd _ NEW [CellDefRep _ [sr: sr, nameIsLiteral: FALSE, nameSource: NIL]]
ELSE WITH org SELECT FROM
q: Quoted => {
cd _ NEW [CellDefRep _ [sr: sr, literalName: q.rope, nameIsLiteral: TRUE]];
};
cellDef: CellDef => {cd _ cellDef; cd.sr _ sr};
ENDCASE => {
[] _ Complain[sr, context, "Bad Cell header: %g", IO.refAny[org]];
cd _ NIL;
};
END;

InsistOnCedarChildren: PUBLIC PROC [context: REF ANY, sofar: REF ANY, args: OPP.ArgList] RETURNS [cs: CedarChildren, reduced: REF ANY] =
BEGIN
WITH args.rest.first.arg SELECT FROM
cedar: CedarChildren => {cs _ cedar; reduced _ sofar};
ENDCASE => {cs _ NIL; reduced _ Complain[nullSR, context, "Internal Error"]};
END;

AuxKnown: PUBLIC PROC [name: ROPE, cellDef: CellDef, auxClass: AuxClass, auxVal: AuxVal] RETURNS [known: BOOL] =
{known _ GetAux[name, cellDef, auxClass, auxVal] # NIL};

AuxSpecd: PUBLIC PROC [name: ROPE, cellDef: CellDef, auxClass: AuxClass, auxVal: AuxVal] RETURNS [given: BOOL] = {
SELECT auxClass FROM
State => IF cellDef.sfSource # NIL THEN RETURN [TRUE];
SwitchIO, SimpleIO, Drive => IF cellDef.interfaceLiteral # NIL AND cellDef.interfaceLiteral.asList # NIL THEN RETURN [TRUE];
ENDCASE => ERROR;
given _ cellDef.auxes[auxClass][auxVal] # NIL;
};

GetAux: PUBLIC PROC [name: ROPE, cellDef: CellDef, auxClass: AuxClass, auxVal: AuxVal] RETURNS [aux: ROPE] = {
SELECT auxClass FROM
State => IF cellDef.sfSource # NIL THEN RETURN [SELECT auxVal FROM
Ref => IO.PutFR["%gStateRef", IO.rope[name]],
Rec => IO.PutFR["%gStateRec", IO.rope[name]],
Val => IO.PutFR["NEW[%gStateRec%g]", IO.rope[name], IO.rope[IF cellDef.stateInittable THEN " _ []" ELSE ""]],
ENDCASE => ERROR];
SwitchIO, SimpleIO, Drive => IF cellDef.interfaceLiteral # NIL AND cellDef.interfaceLiteral.asList # NIL THEN RETURN [SELECT auxVal FROM
Ref => IO.PutFR["%g%gRef", IO.rope[name], IO.rope[auxClassNames[auxClass]]],
Rec => IO.PutFR["%g%gRec", IO.rope[name], IO.rope[auxClassNames[auxClass]]],
Val => IO.PutFR["NEW[%g%gRec]", IO.rope[name], IO.rope[auxClassNames[auxClass]]],
ENDCASE => ERROR];
ENDCASE => ERROR;
RETURN [SELECT auxVal FROM
Val =>
IF cellDef.auxes[auxClass][Val] # NIL THEN CedarExpressionRope[cellDef.auxes[auxClass][Val]]
ELSE IF cellDef.auxes[auxClass][Rec] # NIL THEN Rope.Cat["NEW[", CedarExpressionRope[cellDef.auxes[auxClass][Rec]], "]"]
ELSE NIL,
Rec => IF cellDef.auxes[auxClass][Rec] # NIL THEN CedarExpressionRope[cellDef.auxes[auxClass][Rec]] ELSE NIL,
Ref =>
IF cellDef.auxes[auxClass][Ref] # NIL THEN CedarExpressionRope[cellDef.auxes[auxClass][Ref]]
ELSE IF cellDef.auxes[auxClass][Rec] # NIL THEN Rope.Cat["REF ", CedarExpressionRope[cellDef.auxes[auxClass][Rec]] ]
ELSE NIL,
ENDCASE => ERROR];
};

ReduceName: PUBLIC OPP.Reducer =
BEGIN
IF ErrCheck[args] THEN RETURN [error];
WITH args.first.arg SELECT FROM
cs: CedarChildren => reduced _ NEW [CellDefRep _ [sr: sr, nameIsLiteral: FALSE, nameSource: cs ]];
ENDCASE => RETURN [Complain[sr, context, "Internal Error"]];
END;

ReduceCell: PUBLIC OPP.Reducer =
BEGIN
sofar: CellDef;
IF ErrCheck[args] THEN RETURN [error];
IF OpsCheck[context, sr, ops, LIST[cellClass, cellEndClass]] THEN RETURN [error];
IF (reduced _ sofar _ Sofar[sr, context, args.first.arg]) = NIL THEN RETURN [error];
IF sofar.interfaceLiteral = NIL AND sofar.interfaceSource = NIL THEN sofar.interfaceLiteral _ DigestInterface[context, NIL];
END;

ReducePortsProc: PUBLIC OPP.Reducer =
BEGIN
sofar: CellDef;
IF ErrCheck[args] THEN RETURN [error];
IF (sofar _ Sofar[sr, context, args.first.arg]) = NIL THEN RETURN [error];
IF sofar.interfaceSource # NIL THEN Whimper[sr, context, "Redefining PortsProc"];
[sofar.interfaceSource, reduced] _ InsistOnCedarChildren[context, sofar, args];
END;

ReduceApply: PUBLIC OPP.Reducer =
BEGIN
cf: CellFn;
IF ErrCheck[args] THEN RETURN [error];
WITH args.first.arg SELECT FROM
cellFn: CellFn => cf _ cellFn;
ENDCASE => RETURN [Complain[sr, context, "HowToApply tacked onto %g, should have been a Cell Type Function", IO.refAny[args.first.arg]]];
IF cf.howToApply # NIL THEN Whimper[sr, context, "Redefining how to Apply"];
cf.sr _ sr;
[cf.howToApply, reduced] _ InsistOnCedarChildren[context, cf, args];
END;

ReduceStateFields: PUBLIC OPP.Reducer =
BEGIN
sofar: CellDef;
IF ErrCheck[args] THEN RETURN [error];
IF (sofar _ Sofar[sr, context, args.first.arg]) = NIL THEN RETURN [error];
IF AuxSpecd[NIL, sofar, State, Rec] THEN Whimper[sr, context, "Redefining State Record Type"];
[sofar.sfSource, reduced] _ InsistOnCedarChildren[context, sofar, args];
sofar.stateInittable _ FALSE;
END;

ReduceInitStateFields: PUBLIC OPP.Reducer =
BEGIN
sofar: CellDef;
IF ErrCheck[args] THEN RETURN [error];
IF (sofar _ Sofar[sr, context, args.first.arg]) = NIL THEN RETURN [error];
IF AuxSpecd[NIL, sofar, State, Rec] THEN Whimper[sr, context, "Redefining State Record Type"];
[sofar.sfSource, reduced] _ InsistOnCedarChildren[context, sofar, args];
sofar.stateInittable _ TRUE;
END;

ReducePorts: PUBLIC OPP.Reducer =
BEGIN
sofar: CellDef;
IF ErrCheck[args] THEN RETURN [error];
IF (sofar _ Sofar[sr, context, args.first.arg]) = NIL THEN RETURN [error];
WITH args.rest.first.arg SELECT FROM
sb: SquareBracketed => {
IF NOT ISTYPE[sb.subject, InterfaceEltList] THEN RETURN [Complain[sr, context, "PORTS must be given a square bracketed interface element list, not %g", IO.refAny[args.rest.first.arg]]];
sofar.interfaceLiteral _ DigestInterface[context, NARROW[sb.subject]]
}
ENDCASE => reduced _ Complain[sr, context, "PORTS must be given a square bracketed interface element list, not %g", IO.refAny[args.rest.first.arg]];
reduced _ sofar;
END;

ReduceExpand: PUBLIC OPP.Reducer =
BEGIN
sofar: CellDef;
IF ErrCheck[args] THEN RETURN [error];
IF (sofar _ Sofar[sr, context, args.first.arg]) = NIL THEN RETURN [error];
IF sofar.expandCode # NIL THEN Whimper[sr, context, "Redefining Expand Proc"];
reduced _ sofar;
WITH args.rest.first.arg SELECT FROM
s: Statements => sofar.expandCode _ s;
cs: CedarChildren => sofar.expandCode _ NEW [StatementsRep _ [sr, LIST[cs]]];
bl: BindingList => sofar.expandCode _ NEW [StatementsRep _ [sr, LIST[bl]]];
b: Binding => sofar.expandCode _ NEW [StatementsRep _ [sr, LIST[b]]];
ENDCASE => reduced _ Complain[sr, context, "EXPAND must be given a statement or statement list, not %g", IO.refAny[args.rest.first.arg]];
END;

ReduceInitializer: PUBLIC OPP.Reducer =
BEGIN
sofar: CellDef;
IF ErrCheck[args] THEN RETURN [error];
IF (sofar _ Sofar[sr, context, args.first.arg]) = NIL THEN RETURN [error];
IF sofar.initializerSource # NIL THEN Whimper[sr, context, "Redefining Initializer"];
[sofar.initializerSource, reduced] _ InsistOnCedarChildren[context, sofar, args];
END;

ReduceEval: PUBLIC OPP.Reducer =
BEGIN
sofar: CellDef;
type: EvalType _ ToEvalType[ops.first.class];
IF ErrCheck[args] THEN RETURN [error];
IF (sofar _ Sofar[sr, context, args.first.arg]) = NIL THEN RETURN [error];
IF sofar.evals[type] # NIL THEN Whimper[sr, context, "Redefining %g Proc", IO.rope[etNames[type]]];
[sofar.evals[type], reduced] _ InsistOnCedarChildren[context, sofar, args];
END;

ToEvalType: PROC [class: TokenClass] RETURNS [et: EvalType] =
BEGIN
FOR et IN EvalType DO IF evalClasses[et] = class THEN RETURN ENDLOOP;
ERROR;
END;

ReduceTest: PUBLIC OPP.Reducer =
BEGIN
sofar: CellDef;
IF ErrCheck[args] THEN RETURN [error];
IF (sofar _ Sofar[sr, context, args.first.arg]) = NIL THEN RETURN [error];
reduced _ sofar;
WITH args.rest.first.arg SELECT FROM
tn: TestNote => sofar.tests _ CONS[tn, sofar.tests];
ENDCASE => reduced _ Complain[sr, context, "Confusion after Test (got %g)", IO.refAny[args.rest.first.arg]];
END;

ReduceTestClass: PUBLIC OPP.Reducer =
BEGIN
tn: TestNote _ NEW [TestNoteRep _ [sr: sr, name: NIL, code: NIL, stateToo: FALSE]];
IF ErrCheck[args] THEN RETURN [error];
reduced _ tn;
WITH args.first.arg SELECT FROM
id: ID => tn.name _ id.rope;
ENDCASE => RETURN [Complain[sr, context, "BLACKBOX or STATETOO should be proceeded with an ID, not %g", IO.refAny[args.first.arg]]];
WITH args.rest.first.arg SELECT FROM
cs: CedarChildren => tn.code _ cs;
ENDCASE => RETURN [Complain[sr, context, "BLACKBOX or STATETOO should be followed by cedar children, not %g", IO.refAny[args.rest.first.arg]]];
SELECT ops.first.class FROM
bbClass => tn.stateToo _ FALSE;
stClass => tn.stateToo _ TRUE;
ENDCASE => ERROR;
END;

ReduceAuxClass: PUBLIC OPP.Reducer =
BEGIN
sofar: CellDef;
auxClass: AuxClass;
auxed: Auxed;
IF ErrCheck[args] THEN RETURN [error];
IF (sofar _ Sofar[sr, context, args.first.arg]) = NIL THEN RETURN [error];
FOR ac: AuxClass IN AuxClass DO
IF ops.first.class = auxClasses[ac] THEN {auxClass _ ac; EXIT};
REPEAT
FINISHED => ERROR;
ENDLOOP;
WITH args.rest.first.arg SELECT FROM
a: Auxed => auxed _ a;
ENDCASE => RETURN[Complain[sr, context, "Confusion after SwitchAux or SimpleAux or StateAux or DriveAux (got %g)", IO.refAny[args.rest.first.arg]]];
IF AuxSpecd[NIL, sofar, auxClass, auxed.val] THEN Whimper[sr, context, "Redefining %g %g", IO.rope[auxClassNames[auxClass]], IO.rope[auxValNames[auxed.val]]];
sofar.auxes[auxClass][auxed.val] _ auxed.subject;
reduced _ sofar;
END;

ReduceAuxVal: PUBLIC OPP.Reducer =
BEGIN
auxed: Auxed _ NEW [AuxedRep _ [sr: sr, val: , subject: NIL]];
IF ErrCheck[args] THEN RETURN [error];
WITH args.first.arg SELECT FROM
id: ID => auxed.subject _ CedarFromID[id];
q: Quoted => auxed.subject _ CedarFromQuoted[q];
fc: CedarExpression => auxed.subject _ fc;
ENDCASE => RETURN[Complain[sr, context, "REFTYPE or RECTYPE or INITIALVALUE given %g, instead of an ID or CedarLiteral", IO.refAny[args.first.arg]]];
SELECT ops.first.class FROM
refClass => auxed.val _ Ref;
recClass => auxed.val _ Rec;
ivClass => auxed.val _ Val;
ENDCASE => ERROR;
reduced _ auxed;
END;

ReduceInitCTProps: PUBLIC OPP.Reducer =
BEGIN
sofar: CellDef;
IF ErrCheck[args] THEN RETURN [error];
IF (sofar _ Sofar[sr, context, args.first.arg]) = NIL THEN RETURN [error];
IF sofar.initCTPropsSource # NIL THEN Whimper[args.rest.first.sr, context, "Redefining Initial Props Proc"];
[sofar.initCTPropsSource, reduced] _ InsistOnCedarChildren[context, sofar, args];
END;

GetOpKey: PUBLIC PROC [data: REF ANY] RETURNS [key: ROPE] --RedBlackTree.GetKey-- =
{op: Op _ NARROW[data]; key _ op.name};

CompareOps: PUBLIC PROC [k, data: REF ANY] RETURNS [c: Basics.Comparison] --RedBlackTree.Compare-- =
BEGIN
s1: ROPE _ NARROW[k];
s2: ROPE _ GetOpKey[data];
c _ s1.Compare[s2, FALSE];
END;

ParseExpression: PUBLIC PROC [job: Job] RETURNS [expr: REF ANY] =
BEGIN

GetToken: PROC [context: REF ANY, expectingArg: BOOLEAN] RETURNS [token: OPP.Token] --OPP.TokenProc-- =
BEGIN
asRope: ROPE;
op: Op;
peek: CHAR;
startIdx: INT;
GetSR: PROC RETURNS [sr: SourceRange] = {
next: INT _ job.from.GetIndex[];
sr _ [startIdx, next-1]};
HandleNumber: PROC [sgn: INT] RETURNS [OPP.Token] =
BEGIN
tokenKind: IO.TokenKind;
token: ROPE;
[tokenKind, token, ] _ job.from.GetCedarTokenRope[];
SELECT tokenKind FROM
tokenREAL => RETURN [[GetSR[], myArgClass, NEW [ReelRep _ [GetSR[], Convert.RealFromLiteral[token]*sgn]]]];
tokenDECIMAL, tokenOCTAL, tokenHEX => RETURN [[
GetSR[],
myArgClass,
NEW [IntRep _ [
GetSR[],
sgn*Convert.CardFromWholeNumberLiteral[token]]]]];
ENDCASE => ERROR;
END;
WHILE TRUE DO
Process.CheckForAbort[];
IF useOld THEN {useOld _ FALSE; RETURN [[oldSR, myArgClass, old]]};
[] _ job.from.SkipWhitespace[flushComments: FALSE];
startIdx _ job.from.GetIndex[];
IF job.from.EndOf[] THEN RETURN [OPP.end];
job.tokenCount _ job.tokenCount + 1;
peek _ job.from.PeekChar[];
IF peek = '" THEN
BEGIN
asAny: REF ANY;
asRope: ROPE;
asAny _ IO.GetRefAny[job.from !IO.Error, IO.EndOfStream => {
Whimper[GetSR[], job, "Syntax error in quoted string"];
asAny _ error;
CONTINUE}];
IF asAny = error THEN RETURN [IF expectingArg THEN arglikeError ELSE oplikeError];
asRope _ NARROW[asAny];
RETURN [[GetSR[], myArgClass, NEW [QuotedRep _ [GetSR[], asRope]] ]];
END;
IF peek = '| THEN
BEGIN
cedar: ROPE _ NIL;
IF job.from.GetChar[] # '| THEN ERROR;
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;
RETURN [[GetSR[], myArgClass, NEW [CedarExpressionRep _ [GetSR[], cedarLiteral, cedar]] ]];
END;
IF peek = '( THEN
BEGIN
asAny: REF ANY;
asAny _ IO.GetRefAny[job.from !IO.Error, IO.EndOfStream => {
Whimper[GetSR[], job, "Syntax error in list"];
asAny _ error;
CONTINUE}];
IF asAny = error THEN RETURN [IF expectingArg THEN arglikeError ELSE oplikeError];
RETURN [[GetSR[], myArgClass, NEW [RefAnyListRep _ [GetSR[], NARROW[asAny]]] ]];
END;
IF peek IN ['0 .. '9] THEN RETURN [HandleNumber[1]];
IF peek = '$ THEN {
err: BOOL _ FALSE;
IF job.from.GetChar[] # '$ THEN ERROR;
asRope _ job.from.GetRopeLiteral[ !IO.Error, IO.EndOfStream => {
Whimper[GetSR[], job, "should have quoted string following dollar sign"];
err _ TRUE;
CONTINUE}];
IF err THEN RETURN [IF expectingArg THEN arglikeError ELSE oplikeError];
RETURN [[GetSR[], myArgClass, NEW [IDRep _ [GetSR[], asRope]] ]];
};
IF peek = '_ THEN {
IF job.from.GetChar[] # '_ THEN ERROR;
asRope _ "_";
SELECT job.from.PeekChar[] FROM
IN ['a .. 'z], IN ['A .. 'Z] => asRope _ asRope.Cat[Rope.FromChar[job.from.GetChar[]]];
ENDCASE;
}
ELSE 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 IF peek IN ['0 .. '9] THEN RETURN [HandleNumber[-1]]
ELSE asRope _ "-";
END
ELSE IF peek = '. THEN {
IF job.from.GetChar[] # '. THEN ERROR;
IF (peek _ job.from.PeekChar[]) = '. THEN {
IF job.from.GetChar[] # '. THEN ERROR;
asRope _ "..";
}
ELSE asRope _ ".";
}
ELSE asRope _ job.from.GetTokenRope[MyBreak].token;
op _ NARROW[ops.Lookup[asRope]];
IF op = NIL THEN RETURN [[GetSR[], myArgClass, NEW [IDRep _ [GetSR[], asRope]] ]];
IF op.eatsCedar THEN
BEGIN
parent: TextNode.Ref _ TS.CurInNode[job.from];
TS.SkipChildren[job.from];
useOld _ TRUE;
oldSR _ GetSR[];
old _ NEW [CedarChildrenRep _ [GetSR[], parent]];
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 [[GetSR[], op.class[expectingArg], op]];
ENDLOOP;
END;

useOld: BOOLEAN _ FALSE;
oldSR: SourceRange;
old: REF ANY _ NIL;

[] _ job.from.GetIndex[];
[[, 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;

Setup: PROC =
BEGIN
Add: PROC [op: Op] = {ops.Insert[op, op.name]};

noisyErrClass _ NEW[TokenClassRep	_ [2000, 3000, ReduceNoisily]];
myArgClass	_ NEW[TokenClassRep	_ [000, 000,	NIL,	[nullSR, noisyErrClass, NIL]]];

ltClass	_ NEW[TokenClassRep	_ [510, 500,	ReduceIntElt]];
gtClass	_ NEW[TokenClassRep	_ [510, 500,	ReduceIntElt]];
eqClass	_ NEW[TokenClassRep	_ [510, 500,	ReduceIntElt]];


cedarClass	_ NEW[TokenClassRep	_ [000, 10000, SimplerReduce]];
intfCedarClass _ NEW[TokenClassRep	_ [000, 10000, ReduceIntfCedar]];
nameClass	_ NEW[TokenClassRep	_ [000, 10000, ReduceName]];

errorClass	_ NEW[TokenClassRep	_ [250, 250,	ReduceError]];

lambdaClass	_ NEW[TokenClassRep	_ [000, 150,	ReduceLambda]];
returnClass	_ NEW[TokenClassRep	_ [150, 1000, NIL]];

portsProcClass_ NEW[TokenClassRep	_ [080, 090,	ReducePortsProc]];
applyClass	_ NEW[TokenClassRep	_ [810, 090,	ReduceApply]];
sfClass	_ NEW[TokenClassRep	_ [080, 090,	ReduceStateFields]];
isfClass	_ NEW[TokenClassRep	_ [080, 090,	ReduceInitStateFields]];
initializerClass _ NEW[TokenClassRep	_ [080, 090,	ReduceInitializer]];
testClass	_ NEW[TokenClassRep	_ [080, 090,	ReduceTest]];
bbClass	_ NEW[TokenClassRep	_ [110, 100,	ReduceTestClass]];
stClass	_ NEW[TokenClassRep	_ [110, 100,	ReduceTestClass]];
refClass	_ NEW[TokenClassRep	_ [000, 100,	ReduceAuxVal]];
recClass	_ NEW[TokenClassRep	_ [000, 100,	ReduceAuxVal]];
ivClass	_ NEW[TokenClassRep	_ [000, 100,	ReduceAuxVal]];
initCTPropsClass_ NEW[TokenClassRep_ [080, 090,	ReduceInitCTProps]];
expandClass	_ NEW[TokenClassRep	_ [080, 090,	ReduceExpand]];
portsClass	_ NEW[TokenClassRep	_ [080, 090,	ReducePorts]];

cellClass	_ NEW[TokenClassRep	_ [000, 010,	ReduceCell]];
cellEndClass_ NEW[TokenClassRep	_ [010, 000]];

FOR et: EvalType IN EvalType DO
evalClasses[et] _ NEW[TokenClassRep _ [80, 90, ReduceEval]];
Add[NEW[OpRep _ [etNames[et], [evalClasses[et], NIL], TRUE]]];
ENDLOOP;
FOR ac: AuxClass IN AuxClass DO
auxClasses[ac] _ NEW [TokenClassRep _ [80, 90, ReduceAuxClass]];
Add[NEW[OpRep _ [auxClassNames[ac].Cat["Aux"], [auxClasses[ac], NIL]]]];
ENDLOOP;

Add[NEW[OpRep _ ["<",	[ltClass, NIL]]]];
Add[NEW[OpRep _ [">",	[gtClass, NIL]]]];
Add[NEW[OpRep _ ["=",	[eqClass, NIL]]]];
Add[NEW[OpRep _ ["LAMBDA",	[NIL, lambdaClass]]]];
Add[NEW[OpRep _ ["RETURN",	[returnClass, NIL]]]];
Add[NEW[OpRep _ ["CELLTYPE", [NIL, cellClass]]]];
Add[NEW[OpRep _ ["EndCellType", [cellEndClass, NIL]]]];
Add[NEW[OpRep _ ["PORTS",	[portsClass,	NIL]]]];
Add[NEW[OpRep _ ["PortsProc",	[portsProcClass, NIL],	TRUE]]];
Add[NEW[OpRep _ ["ApplyCode",[applyClass, NIL],	TRUE]]];
Add[NEW[OpRep _ ["State",	[sfClass, NIL],	TRUE]]];
Add[NEW[OpRep _ ["InittableState", [isfClass, NIL],	TRUE]]];
Add[NEW[OpRep _ ["Initializer",	[initializerClass, NIL],	TRUE]]];
Add[NEW[OpRep _ ["Expand",	[expandClass, NIL]]]];
Add[NEW[OpRep _ ["CEDAR",	[NIL, cedarClass],	TRUE]]];
Add[NEW[OpRep _ ["InterfaceCedar",	[NIL, intfCedarClass],	TRUE]]];
Add[NEW[OpRep _ ["NameMaker",[NIL, nameClass],	TRUE]]];
Add[autoName_NEW[OpRep _ ["AutoName",[NIL, myArgClass]]]];
Add[NEW[OpRep _ ["Test",	[testClass, NIL]]]];
Add[NEW[OpRep _ ["StateToo",	[stClass, NIL],	TRUE]]];
Add[NEW[OpRep _ ["BlackBox",	[bbClass, NIL],	TRUE]]];
Add[NEW[OpRep _ ["InitCTProps", [initCTPropsClass, NIL], TRUE]]];
Add[NEW[OpRep _ ["RefType",	[NIL, refClass]]]];
Add[NEW[OpRep _ ["RecType",	[NIL, recClass]]]];
Add[NEW[OpRep _ ["InitialValue", [NIL, ivClass]]]];

arglikeError _ [nullSR, OPP.argClass, error];
oplikeError _ [nullSR, errorClass, NIL];

END;

Setup[];

END.
ΒRoseTranslateRead.Mesa
Last Edited by: Spreitzer, September 18, 1985 9:45:05 pm PDT
Last Edited by: Barth, March 8, 1983 10:43 am
Last Edited by: Gasbarro, August 16, 1984 3:42:16 pm PDT
Κ˜J™Jš
œ<™<J™-J™8Icode˜KšΟk	œœ‘
˜·
K˜šΠbxœœ
˜ Kšœ
œœzœ˜’
Kšœ˜—K˜Kšœ
œ*˜4K˜Kšœœ
œ(˜CK˜Kšœœ˜%K˜Kšœœ9˜DK˜Kš
œΝ˜ΝK˜Kšœ
œ
œ˜*Kšœœ
œ˜)K˜Kšœœ
˜K˜šΟnœœ
œ˜šœ
œœ˜Kšœœ
œ˜3Kšœ
œœ
œœ
œœ
œœ
œ	˜+Kšœ˜——K˜šŸœœ
œœ
œœ˜GKš
˜šœœ
˜Kšœœ
œœ˜-K˜Kšœ
˜—Kšœœ
˜Kšœ
˜—K˜šŸœœ
œœ
œœ%œœ˜|Kš
˜Kšœœ
˜š
œœœœœ
œ˜4Kšœ!œœœ˜;Kš
œ˜Kš
œ˜Kšœ
˜—Kš
œœœœœ
˜1š
œœœœœ˜)šœœ˜.Kš
œ ˜ Kš
œ*˜*Kš
œ&˜&KšœD˜K—Kšœ˜—KšœœV˜aKšœ
˜—K˜šŸ
œœ
œ
˜#Kš
˜Kšœ8œ˜XKšœ
˜—K˜KšŸ
œœ
œ&˜?K˜KšŸœœ
œ˜4K˜šŸœœ
œ˜'Kšœœ
œ	˜&Kšœ
œœ˜=K˜—K˜šŸœœ
œ
˜"Kš
˜Kšœœ˜.Kšœ
œ
œ
˜Kšœœ
œ	˜&šœ˜Kšœœœ˜.Kšœœœ˜-Kšœ"œ
˜'Kšœœ
˜—šœœ
˜Kšœœ˜KšœœTœ˜
—šœ,œ˜4Kšœ*œ
œ
œ0˜kKšœœ9˜G—šœ
œ
˜K˜*Kš
œœœ3œœ
œ
œ	˜_KšœœOœ˜v—K˜K˜
Kšœ
˜—K˜šŸœœ
œ
˜"Kš
˜Kšœ
œ˜"Kšœœœ
˜Kšœœ
œ	˜&Kšœœœ
œ	˜Ršœœ
˜šœœœ
˜2K˜ Kšœ	œ
˜—Kšœ	œ
˜—Kš
œ
œœ
œCœ˜tšœœ
˜$K˜Kšœ	œ
˜—Kš
œ
œœ
œYœ˜
K˜K˜K˜
Kšœ
˜—K˜š
Ÿœœ
œœœ˜JK˜—K˜š
Ÿ
œœ
œœœ˜`Kšœœ*˜2K˜—K˜š
Ÿœœ
œœœ˜AKšœœ>˜G—K˜šŸœœ
œ
œ˜HKšœœ[˜d—K˜šŸœœ
œ!œ
œœ˜SKš
˜Kš
œœœ'œœ˜^šœ
œœ
˜š
œ˜Kšœœ<œ˜KK˜—K˜/šœ˜Kšœ2œ˜BKšœœ
˜	K˜——Kšœ
˜—K˜šŸœœ
œœ
œ	œ
œœ
œœ
œ˜ˆ
Kš
˜šœœ
˜$Kš
œ6˜6Kšœ
œ9˜M—Kšœ
˜—K˜šŸœœ
œœ8œ	œ˜pKšœ3œ˜8—K˜šŸœœ
œœ8œ	œ˜ršœ
˜Kšœ	œœ
œ
œœ˜6Kšœœœ
œ#œ
œ
œœ˜|Kšœœ
˜—Kšœ*œ
˜.K˜—K˜šŸœœ
œœ8œœ˜nšœ
˜šœ	œœ
œ
œœ˜BKšœœœ
˜-Kšœœœ
˜-Kš
œœœ
œœœ	œ˜mKšœœ˜—šœœœ
œ#œ
œ
œœ˜ˆ
Kšœœœ
œ ˜LKšœœœ
œ ˜LKšœœœ
œ ˜QKšœœ˜—Kšœœ
˜—šœœ˜š
œ˜Kšœ œ
œ2˜\Kšœ
œ œ
œI˜xKšœ
œ
˜	—Kšœœ œ
œ3œ
œ
˜m˜Kšœ œ
œ2˜\Kšœ
œ œ
œE˜tKšœ
œ
˜	—Kšœœ˜—K˜—K˜šŸ
œœ
œ
˜ Kš
˜Kšœœ
œ	˜&šœœ
˜Kšœœ'œ˜bKšœœ+˜<—Kšœ
˜—K˜šŸ
œœ
œ
˜ Kš
˜K˜Kšœœ
œ	˜&Kšœœœ
œ	˜QKšœ:œ
œ
œ	˜TKšœœ
œœ
œ3œ˜|Kšœ
˜—K˜šŸœœ
œ
˜%Kš
˜K˜Kšœœ
œ	˜&Kšœ0œ
œ
œ	˜JKšœœ
œ.˜QKš
œO˜OKšœ
˜—K˜šŸœœ
œ
˜!Kš
˜K˜Kšœœ
œ	˜&šœœ
˜K˜Kšœœ\œ˜‰
—Kšœœ
œ1˜LK˜Kš
œD˜DKšœ
˜—K˜šŸœœ
œ
˜'Kš
˜K˜Kšœœ
œ	˜&Kšœ0œ
œ
œ	˜JKšœ
œœ6˜^Kš
œH˜HKšœœ
˜Kšœ
˜—K˜šŸœœ
œ
˜+Kš
˜K˜Kšœœ
œ	˜&Kšœ0œ
œ
œ	˜JKšœ
œœ6˜^Kš
œH˜HKšœœ
˜Kšœ
˜—K˜šŸœœ
œ
˜!Kš
˜K˜Kšœœ
œ	˜&Kšœ0œ
œ
œ	˜Jšœœ
˜$š
œ˜Kšœ
œ
œœ
œaœ˜Ή
Kšœ2œ
˜EK˜
—Kšœmœ˜”
—K˜Kšœ
˜—K˜šŸœœ
œ
˜"Kš
˜K˜Kšœœ
œ	˜&Kšœ0œ
œ
œ	˜JKšœœ
œ0˜NK˜šœœ
˜$K˜&Kšœ(œœ˜MKšœ&œœ˜KKšœ!œœ˜EKšœbœ˜‰
—Kšœ
˜—K˜šŸœœ
œ
˜'Kš
˜K˜Kšœœ
œ	˜&Kšœ0œ
œ
œ	˜JKšœœ
œ0˜UKš
œQ˜QKšœ
˜—K˜šŸ
œœ
œ
˜ Kš
˜K˜K˜-Kšœœ
œ	˜&Kšœ0œ
œ
œ	˜JKšœœ
œ,œ˜cKš
œK˜KKšœ
˜—K˜šŸ
œœœ˜=Kš
˜Kšœœ
œ
œœ
œ
œ
˜EKšœ
˜Kšœ
˜—K˜šŸ
œœ
œ
˜ Kš
˜K˜Kšœœ
œ	˜&Kšœ0œ
œ
œ	˜JK˜šœœ
˜$Kšœœ˜4KšœEœ˜l—Kšœ
˜—K˜šŸœœ
œ
˜%Kš
˜Kš	œœœœœ˜SKšœœ
œ	˜&K˜
šœœ
˜Kšœœ˜KšœœWœ˜„
—šœœ
˜$Kš
œ"˜"Kšœœ]œ˜
—šœ˜Kšœœ
˜Kšœœ
˜Kšœœ
˜—Kšœ
˜—K˜šŸœœ
œ
˜$Kš
˜K˜K˜K˜
Kšœœ
œ	˜&Kšœ0œ
œ
œ	˜Jšœœ
˜Kšœ"œœ˜?š
˜Kšœœ
˜—Kšœ
˜—šœœ
˜$Kš
œ˜Kšœœbœ˜”
—Kš
œ
œœ*œ œ˜ž
K˜1K˜Kšœ
˜—K˜šŸœœ
œ
˜"Kš
˜Kšœœ&œ˜>Kšœœ
œ	˜&šœœ
˜Kšœœ$˜*K˜0K˜*Kšœœhœ˜•
—šœ˜Kš
œ˜Kš
œ˜Kš
œ˜Kšœœ
˜—K˜Kšœ
˜—K˜šŸœœ
œ
˜'Kš
˜K˜Kšœœ
œ	˜&Kšœ0œ
œ
œ	˜JKšœœ
œG˜lKš
œQ˜QKšœ
˜—K˜šŸœœ
œœ
œœœΟcœ˜SKšœ
œ˜'—K˜šŸ
œœ
œœ
œœ œ˜dKš
˜Kšœœœ˜Kšœœ˜Kšœœ˜Kšœ
˜—K˜šŸœœ
œœœ
œ˜AKš
˜K˜šŸœœœ
œœœ	œ œ˜gKš
˜Kšœœ
˜
K˜Kšœœ
˜Kšœ
œ
˜šŸœœ
œ˜)Kšœœ˜ Kš
œ˜—š
Ÿœœœœœ	˜3Kš
˜Kšœœ˜Kšœœ
˜Kš
œ4˜4šœ˜Kšœ
œœ=˜kšœ&œ˜/Kš
œ˜Kš
œ˜šœ˜Kš
œ˜Kš
œ2˜2——Kšœœ
˜—Kšœ
˜—šœ
œ
˜
K˜Kšœœœœ˜CKšœ,œ˜3K˜Kšœœ
œœ˜*K˜$K˜šœ˜Kš
˜Kšœœ
œ
˜Kšœœ
˜
šœœœœ˜<Kš
œ7˜7Kš
œ˜Kšœ˜—Kšœœ
œœœœ˜RKšœ	œ˜Kšœœ$˜EKšœ
˜—šœ˜Kš
˜Kšœœœ
˜Kšœœ
œ
˜&šœ
œ˜Kšœœ˜ šœ˜Kš
˜Kšœœ
œ
œ˜CKšœ
˜—K˜*Kšœ
˜—Kšœœ:˜[Kšœ
˜—šœ˜Kš
˜Kšœœ
œ
˜šœœœœ˜<Kš
œ.˜.Kš
œ˜Kšœ˜—Kšœœ
œœœœ˜RKšœœœ
˜PKšœ
˜—Kšœœœ
œ˜4šœœ˜Kšœœœ
˜Kšœœ
œ
˜&šœ#œœ˜@Kš
œI˜IKšœœ
˜Kšœ˜—Kšœœ
œœœœ˜HKšœœ ˜AK˜—šœœ˜Kšœœ
œ
˜&K˜
šœ˜Kšœ
œF˜WKšœ
˜—K˜
—šœ
œ˜Kš
˜Kšœœ
œ
˜&šœ#˜)Kš
˜Kšœœ
œ
˜&šœ
œ˜Kšœœ˜ Kšœœ
œ
˜šœ˜Kš
˜Kš
œ˜Kšœœœ
œ
˜%Kšœ
˜—Kšœ
˜—Kšœ
˜Kš
˜—Kš
œ
œœœ
œ˜9Kšœ˜Kš
˜—šœ
œœ˜Kšœœ
œ
˜&šœ#œ˜+Kšœœ
œ
˜&K˜K˜
—Kšœ˜K˜
—Kšœ/˜3Kšœœ˜ Kš
œœ
œ
œœ ˜Ršœ˜Kš
˜Kšœœ˜.Kšœ˜Kšœ	œ
˜K˜Kšœœ(˜1Kšœ
˜—šœœ
˜$Kš
˜Kšœ5œœ˜cK˜ Kšœœœœ˜<Kšœ
˜—Kšœ)˜/Kšœ
˜—Kšœ
˜K˜—Kšœœœ
˜K˜Kšœœ
œœ
˜K˜K˜šœ
œœ
œ
œœœœ˜Š
Kš
˜Kšœ]œ˜zK˜ Kšœœ
˜Kšœ
˜	Kšœ˜—Kšœ
˜—K˜šŸœœ˜
Kš
˜KšŸœœ&˜/K˜Kšœœ.˜AKšœ
œœœ˜PK˜Kšœ
œ+˜8Kšœ
œ+˜8Kšœ
œ+˜8K˜K˜Kšœ
œ.˜>Kšœœ0˜DKšœœ+˜:K˜Kšœ
œ*˜:K˜Kšœœ+˜<Kšœœœ˜4K˜Kšœœ.˜AKšœ
œ*˜:Kšœ
œ0˜=Kšœœ4˜BKšœœ0˜FKšœœ)˜8K˜;Kšœ
œ.˜;Kšœœ+˜9Kšœœ+˜9Kšœ
œ+˜8Kšœœ/˜DKšœœ+˜<Kšœ
œ*˜:K˜Kšœœ)˜8Kšœœ˜.K˜šœœ
˜Kšœœ'˜<Kšœœ)œœ˜>Kšœ
˜—šœœ
˜Kšœœ,˜@Kšœœ9œ˜HKšœ
˜—K˜Kšœœœ˜(Kšœœœ˜(Kšœœœ˜(Kšœœœ˜1Kšœœ"œ˜1Kšœœœ˜1Kšœœ(œ˜7Kšœœ œ˜/Kšœœ(œœ˜=Kšœœ#œœ˜8Kšœœœœ˜2Kšœœ'œœ˜<Kšœœ,œœ˜AKšœœ"œ˜1Kšœœœœ˜5Kšœœœœ˜BKšœœœœ˜7Kšœ
œœ˜:Kšœœœ˜-Kšœœ œœ˜5Kšœœ œœ˜5Kšœœ,œœ˜AKšœœœ˜/Kšœœœ˜/Kšœœœ˜3K˜Kšœœ˜-Kšœ#œ˜(K˜Kšœ
˜—K˜K˜K˜Kšœ
˜—…—[Ψy«