<> <> <> <> <> <<>> <> <<>> <> <<>> <> 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 <> 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]; <> 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 <> <> <> 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 <> <> <> 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? <> 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] = <> 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] = <> 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; <> 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]; <> 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 <> Commander.Register[key:"PasMesa", proc:DoIt, doc:"Pascal to Mesa translation"]; END. -- of PasBlock --