DIRECTORY
Commander USING [CommandProc, Handle, Register],
IO USING [GetChar, PutChar, PutRope],
List USING [DRemove, Memb, Nconc],
PasPrivate,
PasPrivateVars;
PasBlock:
CEDAR
MONITOR
IMPORTS Commander,
IO, List, PasPrivate, PasPrivateVars
EXPORTS PasPrivate =
BEGIN
OPEN PasPrivate, PasPrivateVars;
LORA: TYPE = LIST OF REF ANY;
TranslateProgram:
PUBLIC
PROCEDURE =
BEGIN
ParseIdentOptStar:
PROCEDURE =
BEGIN
MustBe[identSy, "", MalformedProgram];
IF sy = mulOpSy AND op = mulOp THEN InSymbol[];
END;
mainId: IdentifierPtr ← defaultDest[main].implModule;
mainTail: REF implModule IdentifierTail ← NARROW[mainId.class];
PushOut[mainTail.q]; -- from now on the main module queue will
live on the output queue stack
InSymbol[];
MustBe[programSy, "", MalformedProgram];
IF sy # identSy THEN Error[MalformedProgram];
InSymbol[];
IF CouldBe[lParentSy, ""]
THEN {
SequenceOf[ParseIdentOptStar, commaSy, ""];
MustBe[rParentSy, "", MalformedProgram]};
MustBe[semiColonSy, "", MalformedProgram];
TranslateBlock[IF modularize THEN outer ELSE inner];
MustBe[periodSy, "", MalformedProgram];
IF sy # eofSy THEN Error[MalformedProgram];
mainTail.q ← CopyAndPopOut[];
END; -- of TranslateProgram
TranslateBlock:
PUBLIC
PROCEDURE [position: Position] =
BEGIN
preambleQ: OutputQueuePtr;
TranslateLabelDeclaration:
PROCEDURE =
BEGIN
id: IdentifierPtr;
IF sy # intConstSy THEN Error[MalformedStatement];
id ← NewIdent[];
id.class ← Z.NEW[IdentifierTail ← [label[]]];
InSymbol[];
END;
EmitSignalDefinition:
PROCEDURE [id: IdentifierPtr] =
BEGIN
WITH id.class
SELECT
FROM
lid:
REF label IdentifierTail =>
IF lid.nonLocal
THEN
BEGIN
IF position = outer
THEN
BEGIN
defsId: IdentifierPtr ← defaultDest[globalLabel].defsModule;
implId: IdentifierPtr ← defaultDest[globalLabel].implModule;
defsTail: REF defsModule IdentifierTail ← NARROW[defsId.class];
implTail: REF implModule IdentifierTail ← NARROW[implId.class];
PushOut[defsTail.q];
SayLine[""];
Say["Error"];
Say[id.name];
SayLine[": ERROR;"];
defsTail.q ← CopyAndPopOut[];
PushOut[implTail.q];
SayLine[""];
Say["Error"];
Say[id.name];
SayLine[": ERROR = CODE;"];
implTail.q ← CopyAndPopOut[];
END
ELSE {Say["Error"]; Say[id.name]; SayLine[": ERROR = CODE;"]};
END;
ENDCASE;
END;
PreambleOf:
PROCEDURE [p:
PROCEDURE [position: Position]
RETURNS [saySemiColon: BOOL]] =
BEGIN
InSymbol[];
DO
IF p[position]
THEN MustBe[semiColonSy, ";", MalformedStatement]
ELSE MustBe[semiColonSy, "", MalformedStatement];
SELECT sy
FROM
labelSy, constSy, typeSy, varSy, procedureSy, functionSy, beginSy => EXIT;
ENDCASE => NULL;
ENDLOOP;
END; -- of PreambleOf
PushOut[]; -- extra queue on stack during preamble
DO
SELECT sy
FROM
labelSy =>
BEGIN
InSymbol[];
SequenceOf[TranslateLabelDeclaration, commaSy, ""];
IF sy # semiColonSy THEN Error[MalformedStatement];
InSymbol[stopAtCR: TRUE];
preambleQ ← CopyAndPopOut[];
MergeQueue[from: preambleQ];
dump it into lower queue
PushOut[];
END;
constSy => PreambleOf[TranslateConstantDeclaration];
typeSy => PreambleOf[TranslateTypeDeclaration];
varSy => PreambleOf[TranslateVariableDeclaration];
procedureSy, functionSy =>
TranslateProcedureDeclaration[
position: position, isFunction: sy = functionSy];
ENDCASE => EXIT;
IF sy = CRSy THEN InSymbol[];
ENDLOOP;
preambleQ ← CopyAndPopOut[];
MergeQueue[from: preambleQ]; -- dump it into lower queue
EnumerateIdentifierSet[display[lexLevel].locals, EmitSignalDefinition];
MustBe[beginSy, "", MalformedBlock];
IF lexLevel=2 THEN MergeQueue[from: initCodeQPtr];
[] ← TranslateStatementSequence[];
MustBe[endSy, "", MalformedBlock];
BalanceQueue[]; -- keep ropes in reasonably good shape
commandHandle.out.PutChar['.];
END; -- of TranslateBlock
TranslateStatementSequence:
PROCEDURE
RETURNS [newLabels:
LORA ←
NIL] =
BEGIN
A statement sequence is a list of statements and labels. We translate them
in turn, putting each statement into a separate output queue, and chaining
these queues together.
BlockEntry:
TYPE =
RECORD[
prev: BlockEntryPtr, --pointer to previous entry in this block
me:
SELECT type: *
FROM
label => [ q: OutputQueuePtr,
--a comment associated with this label, if any
l: IdentifierPtr ], --the label itself
statement => [ q: OutputQueuePtr,
--the translation of the statement
labs: LORA], --a list of labels that are first gone forward to from here
ENDCASE];
BlockEntryPtr: TYPE = REF BlockEntry;
CollapseThrough:
PROC [id: IdentifierPtr ←
NIL]=
BEGIN
Collapse prior statements in this block into a single clump whose first member is
the first statement in the block that goes to the label id; if id=NIL, collapse the
whole block so far into a clump.
combinedQ: OutputQueuePtr ← Z.NEW[OutputQueue];
outLabels: LORA ← NIL;
DO
IF soFar = NIL THEN GOTO NotFound;
WITH soFar
SELECT
FROM
lbe:
REF label BlockEntry =>
BEGIN
targTail: REF label IdentifierTail ← NARROW[lbe.l.class];
MergeQueueStart[to: combinedQ, from: lbe.q]; --don't forget the comment, if any
IF targTail.backwardTarget
THEN
BEGIN
leaderQ: OutputQueuePtr ← Z.NEW[OutputQueue];
StringToQueue["DO {--Label", leaderQ];
StringToQueue[lbe.l.name, leaderQ];
StringToQueue[":--", leaderQ];
MergeQueueStart[from: leaderQ, to: combinedQ];
StringToQueue["EXIT; EXITS Label", combinedQ];
StringToQueue[lbe.l.name, combinedQ];
StringToQueue[" => NULL} ENDLOOP;", combinedQ];
END;
soFar ← soFar.prev;
END;
sbe:
REF statement BlockEntry =>
BEGIN
IF List.Memb[id, sbe.labs]
THEN
BEGIN
outLabels ← List.Nconc[outLabels, List.DRemove[id, sbe.labs]];
MergeQueueStart[to: combinedQ, from: sbe.q];
StringToQueueStart["{", combinedQ];
StringToQueue["EXITS Label", combinedQ];
StringToQueue[id.name, combinedQ];
StringToQueue[" => NULL};", combinedQ];
soFar ← soFar.prev;
GOTO Found;
END
ELSE
BEGIN
outLabels ← List.Nconc[outLabels, sbe.labs];
MergeQueueStart[to: combinedQ, from: sbe.q];
soFar ← soFar.prev;
END;
END;
ENDCASE;
REPEAT
NotFound =>
IF id #
NIL
THEN
BEGIN -- Why didn't we find the first statement that went to this label?
Better be that id is a nonLocal label.
idTail: REF label IdentifierTail ← NARROW[id.class];
enableQ: OutputQueuePtr ← Z.NEW[OutputQueue];
IF NOT idTail.nonLocal THEN Error[Confusion];
StringToQueue["{ENABLE Error", enableQ];
StringToQueue[id.name, enableQ];
StringToQueue[" => GOTO Label", enableQ];
StringToQueue[id.name, enableQ];
StringToQueue[";", enableQ];
MergeQueueStart[from: enableQ, to: combinedQ];
StringToQueue["EXITS Label", combinedQ];
StringToQueue[id.name, combinedQ];
StringToQueue[" => NULL};", combinedQ];
END;
Found => NULL;
ENDLOOP;
soFar ← Z.NEW[BlockEntry ← [prev: soFar, me: statement[q: combinedQ, labs: outLabels]]];
END; -- of CollapseThrough
soFar: BlockEntryPtr ← NIL;
DO
SELECT sy
FROM
endSy, untilSy => GOTO endOfBlock;
semiColonSy => { InSymbol[]; Say[" "]; LOOP }; --flush empty statement
intConstSy =>
BEGIN --the definition of a label
label: Name ← ident;
id: IdentifierPtr ← IdentLookup[];
idTail: REF label IdentifierTail ← NARROW[id.class];
IF idTail.alreadyDefined
THEN Error[MultiplyDefinedLabel]
ELSE idTail.alreadyDefined ← TRUE;
SELECT
TRUE
FROM
idTail.nonLocal => CollapseThrough[id];
idTail.forwardTarget => CollapseThrough[id];
ENDCASE => NULL;
PushOut[];
InSymbol[];
MustBe[colonSy, "", MalformedStatement];
soFar ← Z.NEW[BlockEntry ← [prev: soFar, me: label[l:id, q:CopyAndPopOut[]]]];
END;
ENDCASE =>
BEGIN --just a statement
thisStmt: OutputQueuePtr ← NIL;
nl: LORA ← NIL;
PushOut[];
nl ← TranslateUnlabeledStatement[];
SELECT sy
FROM
endSy, untilSy, semiColonSy =>
IF
NOT CouldBe[semiColonSy, ";"]
THEN
Say[";"];
ENDCASE =>
Error[MalformedStatement];
thisStmt ← CopyAndPopOut[];
soFar ← Z.NEW[BlockEntry ← [prev: soFar, me: statement[q: thisStmt, labs: nl]]];
END;
REPEAT
endOfBlock => CollapseThrough[NIL];
ENDLOOP;
IF soFar = NIL OR soFar.prev # NIL THEN Error[Confusion];
WITH soFar
SELECT
FROM
qsf: REF statement BlockEntry => {MergeQueue[from: qsf.q]; RETURN[qsf.labs]};
ENDCASE => Error[Confusion];
END; -- of TranslateStatementSequence
TranslateCompoundStatement:
PROCEDURE
RETURNS [newLabels:
LORA ←
NIL] =
BEGIN
MustBe[beginSy, "BEGIN", MalformedBlock];
newLabels ← TranslateStatementSequence[];
MustBe[endSy, " END", MalformedBlock];
RETURN[newLabels];
END; -- of TranslateCompoundStatement
TranslateStatement: PROCEDURE RETURNS [newLabels: LORA ← NIL] =
result is a list of local label identifiers that are first gone to from this statement
BEGIN
IF sy = intConstSy
THEN
BEGIN -- Weird! This is singleton statement that is labeled!
label: Name ← ident;
id: IdentifierPtr ← IdentLookup[];
idTail: REF label IdentifierTail ← NARROW[id.class];
IF idTail.nonLocal THEN Error[MalformedNonLocalGoTo];
IF idTail.alreadyDefined THEN Error[MultiplyDefinedLabel];
idTail.alreadyDefined ← TRUE;
InSymbol;
MustBe[colonSy, "", MalformedStatement];
PushOut[];
newLabels ← TranslateUnlabeledStatement[];
IF idTail.backwardTarget
THEN
BEGIN
statementBody: OutputQueuePtr ← CopyAndPopOut[];
StringToQueueStart["DO {", statementBody];
StringToQueue["; EXIT; EXITS Label", statementBody];
StringToQueue[label, statementBody];
StringToQueue[" => NULL} ENDLOOP", statementBody];
MergeQueue[from: statementBody];
END
ELSE MergeQueue[from: CopyAndPopOut[]];
END
ELSE RETURN[TranslateUnlabeledStatement[]];
END;
TranslateUnlabeledStatement: PROCEDURE RETURNS [newLabels: LORA ← NIL] =
result is a list of local label identifiers that are first gone to from this statement
BEGIN
SELECT sy FROM
beginSy => newLabels ← TranslateCompoundStatement[];
loopSy =>
BEGIN
Respond["DO"];
newLabels ← TranslateStatementSequence[];
MustBe[endSy, " ENDLOOP", MalformedStatement];
END;
exitSy =>
BEGIN
InSymbol[];
IF CouldBe[ifSy, "IF"]
THEN
BEGIN
[] ← TranslateExpression[booleanId];
Say[" THEN EXIT"];
END
ELSE
BEGIN
MustBe[lParentSy, "", MalformedStatement];
MustBe[identSy, "", MalformedStatement]; -- Should check that this is local but I don't know how. DN
MustBe[rParentSy, "", MalformedStatement];
Say["RETURN"];
END;
END;
ifSy =>
BEGIN
Respond["IF"];
[] ← TranslateExpression[booleanId];
MustBe[thenSy, " THEN", MalformedStatement];
newLabels ← TranslateStatement[];
IF CouldBe[elseSy, " ELSE"]
THEN
newLabels ← List.Nconc[newLabels, TranslateStatement[]];
END;
caseSy =>
BEGIN
TranslateCase:
PROCEDURE =
BEGIN
TranslateCaseLabel:
PROCEDURE =
BEGIN v: ValuePtr ← ParseCountableConstant[]; SayTranslation[v]; END;
of TranslateCaseLabel
IF sy = semiColonSy THEN RETURN; -- empty case branches are OK
SequenceOf[TranslateCaseLabel, commaSy, ","];
MustBe[colonSy, " =>", MalformedStatement];
newLabels ← List.Nconc[newLabels, TranslateStatement[]];
Say[";"];
END; -- of TranslateCase
Respond["SELECT"];
[] ← TranslateExpression[];
MustBe[ofSy, "FROM", MalformedStatement];
SequenceOf[TranslateCase, semiColonSy, ""];
IF CouldBe[othersSy, " ENDCASE"]
THEN
BEGIN
MustBe[colonSy, " =>", MalformedStatement];
newLabels ← List.Nconc[newLabels, TranslateStatement[]];
WHILE CouldBe[semiColonSy, ""] DO ENDLOOP;
MustBe[endSy, "", MalformedStatement]
END
ELSE MustBe[endSy, " ENDCASE", MalformedStatement];
END;
whileSy =>
BEGIN
Respond["WHILE"];
[] ← TranslateExpression[booleanId];
MustBe[doSy, "DO", MalformedStatement];
newLabels ← TranslateStatement[];
Say[" ENDLOOP "]
END;
repeatSy =>
BEGIN
Respond["DO"];
newLabels ← TranslateStatementSequence[];
MustBe[untilSy, " IF", MalformedStatement];
[] ← TranslateExpression[booleanId];
Say[" THEN EXIT; ENDLOOP"]
END;
forSy =>
BEGIN
upward: BOOLEAN;
vControl, v1, v2: ValuePtr;
SELECT targetLanguage
FROM
cedar => Respond["FOR i:INT "];
mesa, longMesa => Respond["FOR i:INTEGER "];
ENDCASE => ERROR;
vControl ← ParseVariable[isLHS: TRUE];
MustBe[becomesSy, , MalformedStatement];
v1 ← ParseExpression[];
upward ← CouldBe[toSy];
IF NOT upward THEN MustBe[downToSy, , MalformedStatement];
Say[IF upward THEN " IN [" ELSE " DECREASING IN ["];
v2 ← ParseExpression[];
CoerceToLong[v1];
CoerceToLong[v2];
IF upward THEN {SayTranslation[v1]; Say[".."]; SayTranslation[v2]}
ELSE {SayTranslation[v2]; Say[".."]; SayTranslation[v1]};
MustBe[doSy, "] DO ", MalformedStatement];
SayTranslation[vControl];
Say[" ← i; "];
IF CouldBe[beginSy, ""]
THEN
-- remove redundant BEGIN-END
{
newLabels ← TranslateStatementSequence[];
MustBe[endSy, "", MalformedBlock]}
ELSE newLabels ← TranslateStatement[];
Say[" ENDLOOP"];
END;
withSy =>
BEGIN
withDepth: CARDINAL ← 0;
LocalizeRecord:
PROCEDURE =
BEGIN
t: TypePtr ← GetConcreteTypeOfValue[TranslateVariable[isLHS: TRUE]];
WITH t
SELECT
FROM
rt: RecordTypePtr =>
BEGIN
withDepth ← withDepth + 1;
lexLevel ← lexLevel + 1;
display[lexLevel] ←
Z.
NEW[DisplayEntry←[formals: with[flp: rt.fieldList],
locals: CreateIdentifierSet[]]];
END;
ENDCASE => Error[ShouldBeRecord];
END; -- of LocalizeRecord
Respond["BEGIN OPEN"];
SequenceOf[LocalizeRecord, commaSy, ","];
MustBe[doSy, ";", MalformedStatement];
newLabels ← TranslateStatement[];
WHILE withDepth > 0
DO
lexLevel ← lexLevel - 1; withDepth ← withDepth - 1; ENDLOOP;
Say[" END"];
END;
gotoSy =>
BEGIN
id: IdentifierPtr;
idTail: REF label IdentifierTail;
tLexLevel: LexLevel;
iAmNonLocal: BOOL ← FALSE;
InSymbol[];
IF sy # intConstSy THEN Error[MalformedStatement];
FOR tLexLevel
DECREASING
IN [
FIRST[LexLevel]..lexLevel]
DO
WITH display[tLexLevel]
SELECT
FROM
cde: REF call DisplayEntry => EXIT;
wde: REF with DisplayEntry => NULL;
ENDCASE;
ENDLOOP;
id ← IdentLookup[pset: display[tLexLevel].locals, couldFail: TRUE];
IF id =
NIL
THEN
BEGIN -- Aha! The corresponding label is gone to nonlocally.
id ← IdentLookup[];
iAmNonLocal ← TRUE;
END;
idTail ← NARROW[id.class];
IF iAmNonLocal
THEN
BEGIN -- We GOTO a nonlocal label by raising an ERROR
idTail.nonLocal ← TRUE;
Say["ERROR Error"];
Say[id.name];
END
ELSE
BEGIN -- But if the label is local, we can just use mesa GOTO.
Say["GOTO Label"];
Say[id.name];
We must warn this label that it has been gone to.
SELECT
TRUE
FROM
idTail.alreadyDefined => idTail.backwardTarget ← TRUE;
idTail.nonLocal => NULL;
idTail.forwardTarget => NULL;
ENDCASE =>
BEGIN -- We are inside the first statement that goes to the label id.
idTail.forwardTarget ← TRUE;
newLabels ← CONS[id, NIL];
END;
END;
InSymbol[];
END;
identSy =>
BEGIN
TranslateExprOfProperType:
PROCEDURE [t: GeneralTypePtr] =
BEGIN -- Mesa doesn't coerce reals to integers
v: ValuePtr ← ParseExpression[t];
IF GetConcreteType[v.type] = real
AND IsCountableType[t]
THEN {
Say["PascalROUND["]; SayTranslation[v]; SayCh[']]}
ELSE SayTranslation[v, t];
END; -- of TranslateExprOfProperType
id: IdentifierPtr ← IdentLookup[];
IF id = NIL THEN Error[MalformedStatement];
WITH id.class
SELECT
FROM
pidt: ProcedureIdentifierTailPtr =>
IF pidt.declKind = standard THEN [] ← TranslateProcedureCall[id]
ELSE
BEGIN
resultType: GeneralTypePtr ← ExtractResultType[id];
IF resultType = nilGeneralTypePtr
THEN
[] ← TranslateProcedureCall[id]
ELSE
BEGIN -- it's a function result assignment
SayIdent[ident];
Say["Result"];
InSymbol;
MustBe[becomesSy, "←", MalformedAssignment];
[] ← TranslateExprOfProperType[resultType];
END;
END;
vidt: VariableIdentifierTailPtr =>
BEGIN
vVar: ValuePtr ← TranslateVariable[isLHS: TRUE];
MustBe[becomesSy, "←", MalformedAssignment];
[] ← TranslateExprOfProperType[vVar.type];
END;
ENDCASE => Error[MalformedStatement];
END;
ENDCASE => Say[" NULL"];
RETURN[newLabels];
END; -- of TranslateStatement
DoIt:
ENTRY Commander.CommandProc =
BEGIN
ENABLE
{PasMesaError =>
{commandHandle.out.PutRope["\nDo you want to examine PasMesa's internal state? "];
SELECT commandHandle.in.GetChar[]
FROM
'Y, 'y => REJECT; -- Pop up the debugger on this process.
ENDCASE => GOTO EndItAll};
UNWIND => GOTO EndItAll};
commandHandle ← cmd; --make the commandObject globally known
commandHandle.out.PutRope["TranslatingBlocks"];
lexLevel ← outLevel ← 0;
display[lexLevel] ←
Z.
NEW[DisplayEntry←[formals: call[isp: CreateIdentifierSet[]],
locals: CreateIdentifierSet[]]];
InitializeStandards[];
lexLevel ← 1;
display[lexLevel] ←
Z.
NEW[DisplayEntry←[formals: call[isp: CreateIdentifierSet[]],
locals: CreateIdentifierSet[]]];
InitializeModules[];
lexLevel ← 2;
display[lexLevel] ←
Z.
NEW[DisplayEntry←[formals: call[programSegment: segments, isp: CreateIdentifierSet[]],
locals: CreateIdentifierSet[]]];
TranslateProgram[];
commandHandle.out.PutRope["WritingFiles"];
FinishModules[];
commandHandle.out.PutRope["Done.\n"];
RETURN[result: $Success]
EXITS
EndItAll =>
RETURN[result: $Failure];
END; -- of DoIt
The main event
Commander.Register[key:"PasMesa", proc:DoIt, doc:"Pascal to Mesa translation"];
END. -- of PasBlock --