MODULE FoxIntermediateCodeAssembler;
IMPORT
Strings, Diagnostics, D := Debugging, SyntaxTree := FoxSyntaxTree, Scanner := FoxScanner, Sections := FoxSections,
IntermediateCode := FoxIntermediateCode, Basic := FoxBasic, Streams, Files, Backend := FoxBackend,
Global := FoxGlobal, Formats := FoxFormats, SemanticChecker := FoxSemanticChecker, ActiveCells := FoxActiveCells,
ObjectFile, BinaryCode := FoxBinaryCode;
CONST
IntermediateCodeExtension = "Fil";
TYPE
FileName = ARRAY 256 OF CHAR;
MessageString= ARRAY 256 OF CHAR;
ModuleLoader= PROCEDURE {DELEGATE} (CONST moduleFileName: ARRAY OF CHAR): BOOLEAN;
IntermediateCodeParser* = OBJECT
CONST
Trace = FALSE;
Strict = TRUE;
VAR
diagnostics: Diagnostics.Diagnostics;
error: BOOLEAN;
symbol: Scanner.Symbol;
scanner: Scanner.AssemblerScanner;
system: Global.System;
PROCEDURE &Init*(diagnostics: Diagnostics.Diagnostics; defaultSystem: Global.System);
BEGIN
ASSERT(defaultSystem # NIL);
SELF.diagnostics := diagnostics;
system := defaultSystem;
error := FALSE
END Init;
PROCEDURE Error(pos: LONGINT; CONST msg: ARRAY OF CHAR);
BEGIN
error := TRUE;
IF diagnostics # NIL THEN
diagnostics.Error(scanner.source^,pos,Diagnostics.Invalid,msg);
END;
D.Update;
IF Trace THEN D.TraceBack END
END Error;
PROCEDURE NextSymbol;
BEGIN error := error OR ~scanner.GetNextSymbol(symbol)
END NextSymbol;
PROCEDURE ThisToken(x: LONGINT): BOOLEAN;
BEGIN
IF ~error & (symbol.token = x) THEN NextSymbol; RETURN TRUE ELSE RETURN FALSE END;
END ThisToken;
PROCEDURE GetIdentifier(VAR pos: LONGINT; VAR identifier: ARRAY OF CHAR): BOOLEAN;
BEGIN
pos := symbol.start;
IF symbol.token # Scanner.Identifier THEN RETURN FALSE
ELSE COPY(symbol.identifierString,identifier); NextSymbol; RETURN TRUE
END;
END GetIdentifier;
PROCEDURE ExpectToken(x: LONGINT): BOOLEAN;
VAR
s: MessageString;
BEGIN
IF ThisToken(x) THEN RETURN TRUE
ELSE
s := "expected token "; Strings.Append(s,Scanner.tokens[x]); Strings.Append(s," but got "); Strings.Append(s,Scanner.tokens[symbol.token]);
Error(symbol.start, s);RETURN FALSE
END;
END ExpectToken;
PROCEDURE ThisIdentifier(CONST this: ARRAY OF CHAR): BOOLEAN;
BEGIN
IF ~error & (symbol.token = Scanner.Identifier) & (this = symbol.identifierString) THEN NextSymbol; RETURN TRUE ELSE RETURN FALSE END;
END ThisIdentifier;
PROCEDURE ExpectAnyIdentifier(VAR pos: LONGINT; VAR identifier: ARRAY OF CHAR): BOOLEAN;
BEGIN
IF ~GetIdentifier(pos,identifier)THEN Error(pos,"identifier expected"); RETURN FALSE
ELSE RETURN TRUE
END;
END ExpectAnyIdentifier;
PROCEDURE ExpectIntegerWithSign(VAR integer: LONGINT): BOOLEAN;
VAR
result, isNegated: BOOLEAN;
BEGIN
isNegated := ThisToken(Scanner.Minus);
IF ExpectToken(Scanner.Number) & (symbol.numberType = Scanner.Integer) THEN
IF isNegated THEN
integer := -symbol.integer
ELSE
integer := symbol.integer
END;
result := TRUE
ELSE
result := FALSE
END;
RETURN result
END ExpectIntegerWithSign;
PROCEDURE ExpectIntegerWithoutSign(VAR integer: LONGINT): BOOLEAN;
VAR
result: BOOLEAN;
BEGIN
IF ExpectToken(Scanner.Number) & (symbol.numberType = Scanner.Integer) THEN
integer := symbol.integer;
result := TRUE
ELSE
result := FALSE
END;
RETURN result
END ExpectIntegerWithoutSign;
PROCEDURE IgnoreNewLines;
BEGIN
WHILE ThisToken(Scanner.Ln) DO END;
END IgnoreNewLines;
PROCEDURE ExpectLineDelimiter(): BOOLEAN;
BEGIN
IF ~error & ((symbol.token = Scanner.Ln) OR (symbol.token = Scanner.EndOfText)) THEN
NextSymbol;
RETURN TRUE
ELSE
Error(symbol.start, "end of line/text expected");
RETURN FALSE
END;
END ExpectLineDelimiter;
PROCEDURE ParseLineNumber(expectedLineNumber: LONGINT);
VAR
positionOfLine, specifiedLineNumber: LONGINT;
message, tempString: MessageString;
BEGIN
IF Trace THEN D.String(">>> ParseLineNumber"); D.Ln END;
positionOfLine := symbol.start;
IF ThisToken(Scanner.Number) THEN
specifiedLineNumber := symbol.integer;
IF ExpectToken(Scanner.Colon) THEN
IF Strict & (specifiedLineNumber # expectedLineNumber) THEN
message := "invalid code line number (";
Strings.IntToStr(specifiedLineNumber, tempString); Strings.Append(message, tempString);
Strings.Append(message, " instead of ");
Strings.IntToStr(expectedLineNumber, tempString); Strings.Append(message, tempString);
Strings.Append(message, ")");
Error(positionOfLine, message)
END
END
END
END ParseLineNumber;
PROCEDURE ParseOperand(VAR operand: IntermediateCode.Operand; sectionList: Sections.SectionList);
VAR
positionOfOperand, pos, registerNumber, symbolOffset, someLongint, integer: LONGINT;
someHugeint: HUGEINT;
hasTypeDescriptor, isMemoryOperand, lastWasIdentifier, isNegated: BOOLEAN;
someLongreal: LONGREAL;
identifier: SyntaxTree.IdentifierString;
type: IntermediateCode.Type;
sectionOfSymbol: Sections.Section;
name: Basic.PooledName;
registerClass: IntermediateCode.RegisterClass;
BEGIN
IF Trace THEN D.String(">>> ParseOperand"); D.Ln END;
positionOfOperand := symbol.start;
hasTypeDescriptor := FALSE;
isMemoryOperand := FALSE;
lastWasIdentifier := GetIdentifier(pos, identifier);
IF lastWasIdentifier & IntermediateCode.DenotesType(identifier, type) THEN
hasTypeDescriptor := TRUE;
lastWasIdentifier := GetIdentifier(pos, identifier)
END;
IF ~lastWasIdentifier THEN
isMemoryOperand := ThisToken(Scanner.LeftBracket);
lastWasIdentifier := GetIdentifier(pos, identifier)
END;
IF lastWasIdentifier THEN
IF IntermediateCode.DenotesRegister(identifier, registerClass, registerNumber) THEN
IntermediateCode.InitRegister(operand, type, registerClass, registerNumber);
ELSE
symbolOffset := 0;
IF ThisToken(Scanner.Colon) THEN
IF ExpectIntegerWithSign(integer) THEN
symbolOffset := integer
ELSE
Error(symbol.start, "invalid symbol offset")
END
END;
IF Trace THEN D.String(">>> symbol detected"); D.Ln END;
Basic.ToPooledName(identifier, name);
sectionOfSymbol := IntermediateCode.NewSection(sectionList, Sections.UnknownKind, Sections.UnknownSectionType, FALSE, name, NIL, TRUE);
IntermediateCode.InitAddress(operand, IntermediateCode.UnsignedIntegerType(system.addressSize), sectionOfSymbol, symbolOffset)
END
ELSIF symbol.token = Scanner.String THEN
IntermediateCode.InitString(operand, symbol.string);
NextSymbol
ELSE
isNegated := ThisToken(Scanner.Minus);
IF ThisToken(Scanner.Number) THEN
CASE symbol.numberType OF
| Scanner.Integer:
IF isNegated THEN someLongint := -symbol.integer ELSE someLongint := symbol.integer END;
IF ~hasTypeDescriptor THEN
IntermediateCode.InitNumber(operand, someLongint);
ELSIF type.form = IntermediateCode.Float THEN
ASSERT(hasTypeDescriptor);
IntermediateCode.InitFloatImmediate(operand, type, REAL(someLongint))
ELSE
ASSERT(hasTypeDescriptor & (type.form IN IntermediateCode.Integer));
IntermediateCode.InitImmediate(operand, type, someLongint)
END
| Scanner.Hugeint:
IF isNegated THEN someHugeint := - symbol.hugeint ELSE someHugeint := symbol.hugeint END;
IF ~hasTypeDescriptor THEN
IntermediateCode.InitNumber(operand, someHugeint)
ELSIF type.form = IntermediateCode.Float THEN
ASSERT(hasTypeDescriptor);
IntermediateCode.InitFloatImmediate(operand, type, REAL(someHugeint))
ELSE
ASSERT(hasTypeDescriptor & (type.form IN IntermediateCode.Integer));
IntermediateCode.InitImmediate(operand, type, someHugeint)
END
| Scanner.Real, Scanner.Longreal:
IF isNegated THEN someLongreal := -symbol.real ELSE someLongreal := symbol.real END;
IF ~hasTypeDescriptor THEN
IntermediateCode.InitType(type, IntermediateCode.Float, INTEGER(system.addressSize))
END;
IF type.form IN IntermediateCode.Integer THEN
Error(positionOfOperand, "floating point immediate value not applicable")
ELSE
IntermediateCode.InitFloatImmediate(operand, type, someLongreal)
END
ELSE HALT(100)
END
ELSE
Error(positionOfOperand, "invalid operand")
END
END;
IF ThisToken(Scanner.Plus) THEN
IF ExpectIntegerWithoutSign(integer) THEN
IntermediateCode.SetOffset(operand, integer)
ELSE
Error(symbol.start, "invalid offset")
END
ELSIF ThisToken(Scanner.Minus) THEN
IF ExpectIntegerWithoutSign(integer) THEN
IntermediateCode.SetOffset(operand, -integer)
ELSE
Error(symbol.start, "invalid offset")
END
END;
IF isMemoryOperand & ExpectToken(Scanner.RightBracket) THEN
IntermediateCode.SetType(operand, IntermediateCode.UnsignedIntegerType(system.addressSize));
IF ~hasTypeDescriptor THEN
IntermediateCode.InitType(type, IntermediateCode.SignedInteger, INTEGER(system.addressSize))
END;
IntermediateCode.InitMemory(operand, type, operand, 0)
END
END ParseOperand;
PROCEDURE ParseInstruction(VAR instruction: IntermediateCode.Instruction; sectionList: Sections.SectionList);
VAR
opCode: SHORTINT;
positionOfInstruction, positionOfOperand, operandNumber: LONGINT;
operand: IntermediateCode.Operand;
operands: ARRAY 3 OF IntermediateCode.Operand;
operandType: IntermediateCode.Type;
identifier, message, tempString: SyntaxTree.IdentifierString;
BEGIN
IF Trace THEN D.String(">>> ParseInstruction"); D.Ln END;
positionOfInstruction := symbol.start;
IF ExpectAnyIdentifier(positionOfInstruction, identifier) THEN
opCode := IntermediateCode.FindMnemonic(identifier);
IF opCode = IntermediateCode.None THEN
Error(positionOfInstruction, "unknown mnemonic")
ELSE
IntermediateCode.InitType(operandType, IntermediateCode.SignedInteger, 32);
IntermediateCode.InitOperand(operands[0]);
IntermediateCode.InitOperand(operands[1]);
IntermediateCode.InitOperand(operands[2]);
operandNumber := 0;
IF ~ThisToken(Scanner.Ln) & ~ThisToken(Scanner.EndOfText) THEN
REPEAT
positionOfOperand := symbol.start;
IF operandNumber > 2 THEN
Error(positionOfInstruction, "instruction has too many operands")
ELSE
ParseOperand(operand, sectionList);
IF ~error THEN
IF Strict & ~IntermediateCode.CheckOperand(operand, opCode, operandNumber, message) THEN
Strings.Append(message, " @ operand ");
Strings.IntToStr(operandNumber + 1, tempString); Strings.Append(message, tempString);
Error(positionOfOperand, message)
END;
operands[operandNumber] := operand;
INC(operandNumber)
END
END
UNTIL error OR ~ThisToken(Scanner.Comma);
IF ~error & ExpectLineDelimiter() THEN END
END;
IF ~error THEN
IntermediateCode.InitInstruction(instruction, positionOfInstruction, opCode, operands[0], operands[1], operands[2]);
IF Strict & ~IntermediateCode.CheckInstruction(instruction, message) THEN
Error(positionOfInstruction, message)
END
END
END;
END
END ParseInstruction;
PROCEDURE ParseSectionContent*(scanner: Scanner.AssemblerScanner; section: IntermediateCode.Section; sectionList: Sections.SectionList);
VAR
instruction: IntermediateCode.Instruction;
lineNumber: LONGINT;
BEGIN
IF Trace THEN D.Ln; D.String(">>> ParseSectionContent"); D.Ln END;
SELF.scanner := scanner;
IgnoreNewLines;
lineNumber := 0;
WHILE ~error & (symbol.token # Scanner.Period) & (symbol.token # Scanner.EndOfText) DO
ParseLineNumber(lineNumber);
IF ~error THEN
ParseInstruction(instruction, sectionList);
IF ~error THEN
IF Trace THEN IntermediateCode.DumpInstruction(D.Log, instruction); D.Ln; END;
section.Emit(instruction);
INC(lineNumber)
END;
END;
IgnoreNewLines
END
END ParseSectionContent;
PROCEDURE ParseSectionProperties(VAR section: IntermediateCode.Section);
VAR
positionOfProperty, integer: LONGINT;
BEGIN
IF Trace THEN D.Ln; D.String(">>> ParseSectionProperties"); D.Ln END;
WHILE ~error & (symbol.token # Scanner.EndOfText) & (symbol.token # Scanner.Ln) DO
positionOfProperty := symbol.start;
IF ThisIdentifier("fingerprint") & ExpectToken(Scanner.Equal) THEN
IF ExpectIntegerWithSign(integer) THEN
IF (section.fingerprint # 0) & (section.fingerprint # integer) THEN
Error(positionOfProperty, "incompatible fingerprint");
ELSE
section.SetFingerprint(integer);
END
ELSE
Error(positionOfProperty, "invalid fingerprint")
END
ELSIF ThisIdentifier("aligned") & ExpectToken(Scanner.Equal) THEN
IF ExpectIntegerWithSign(integer) THEN
section.SetPositionOrAlignment(FALSE, integer)
ELSE
Error(positionOfProperty, "invalid alignment")
END
ELSIF ThisIdentifier("fixed") & ExpectToken(Scanner.Equal) THEN
IF ExpectIntegerWithSign(integer) THEN
section.SetPositionOrAlignment(TRUE, integer)
ELSE
Error(positionOfProperty, "invalid fixed postion")
END
ELSIF ThisIdentifier("unit") & ExpectToken(Scanner.Equal) THEN
IF ExpectIntegerWithSign(integer) THEN
section.SetBitsPerUnit(integer)
ELSE
Error(positionOfProperty, "invalid unit size")
END
ELSIF ThisIdentifier("size") & ExpectToken(Scanner.Equal) THEN
IF ExpectIntegerWithSign(integer) THEN
ELSE
Error(positionOfProperty, "invalid size")
END
ELSE
Error(positionOfProperty, "invalid property")
END
END
END ParseSectionProperties;
PROCEDURE ParseModuleContent*(scanner: Scanner.AssemblerScanner; sectionList: Sections.SectionList; VAR moduleName: SyntaxTree.IdentifierString; VAR backend: Backend.Backend; loader: ModuleLoader): BOOLEAN;
VAR
pos, positionOfDirective: LONGINT;
identifier: Scanner.IdentifierString;
afterModuleDirective, afterImportsDirective, afterFirstSection, isExternalSection: BOOLEAN;
sectionType: SHORTINT;
section: IntermediateCode.Section;
name: Basic.PooledName;
BEGIN
IF Trace THEN D.Ln; D.String(">>> ParseModuleContent"); D.Ln END;
moduleName := "";
ASSERT(scanner # NIL);
SELF.scanner := scanner;
NextSymbol;
afterModuleDirective := FALSE;
afterImportsDirective := FALSE;
afterFirstSection := FALSE;
WHILE ~error & (symbol.token # Scanner.EndOfText) DO
IgnoreNewLines;
positionOfDirective := symbol.start;
IF ExpectToken(Scanner.Period) & ExpectAnyIdentifier(pos, identifier) THEN
IF identifier = "module" THEN
IF afterModuleDirective THEN
Error(positionOfDirective, "multiple module directives");
ELSIF ExpectAnyIdentifier(pos, identifier) & ExpectLineDelimiter() THEN
moduleName := identifier;
afterModuleDirective := TRUE;
END
ELSIF identifier = "platform" THEN
IF ~afterModuleDirective THEN
Error(positionOfDirective, "platform directive must be preceeded by module directive")
ELSIF ExpectAnyIdentifier(pos, identifier) & ExpectLineDelimiter() THEN
backend := Backend.GetBackendByName(identifier);
IF backend = NIL THEN
Error(positionOfDirective, "unknown platform")
ELSE
system := backend.GetSystem()
END;
ELSIF afterFirstSection THEN
Error(positionOfDirective, "platform directive not before all sections")
END
ELSIF identifier = "imports" THEN
IF ~afterModuleDirective THEN
Error(positionOfDirective, "import directive must be preceeded by module directive")
ELSIF afterImportsDirective THEN
Error(positionOfDirective, "multiple import directives")
ELSIF afterFirstSection THEN
Error(positionOfDirective, "import directive not before all sections")
ELSE
REPEAT
IF ExpectAnyIdentifier(positionOfDirective, identifier) THEN
IF ~loader(identifier) THEN Error(positionOfDirective, "could not import") END;
END
UNTIL error OR ~ThisToken(Scanner.Comma);
IF ExpectLineDelimiter() THEN
afterImportsDirective := TRUE
END
END
ELSE
IF identifier = "external" THEN
positionOfDirective := symbol.start;
IF ExpectToken(Scanner.Period) & ExpectAnyIdentifier(pos, identifier) THEN END;
isExternalSection := TRUE
ELSE
isExternalSection := FALSE
END;
IF ~error THEN
IF identifier = "code" THEN sectionType := Sections.CodeSection
ELSIF identifier = "const" THEN sectionType := Sections.ConstSection
ELSIF identifier = "var" THEN sectionType := Sections.VarSection
ELSIF identifier = "bodycode" THEN sectionType := Sections.BodyCodeSection
ELSIF identifier = "inlinecode" THEN sectionType := Sections.InlineCodeSection
ELSIF identifier = "initcode" THEN sectionType := Sections.InitCodeSection
ELSIF identifier = "initcode2" THEN sectionType := Sections.InitCode2Section
ELSE Error(positionOfDirective, "invalid directive or section type")
END;
IF ~error & ~afterModuleDirective THEN
Error(positionOfDirective, "module directive expected first")
END;
IF ~error THEN
IF ExpectAnyIdentifier(pos, identifier) THEN
Basic.ToPooledName(identifier, name);
section := IntermediateCode.NewSection(sectionList, Sections.UnknownKind, sectionType, ~isExternalSection, name, NIL, TRUE);
IF (sectionType = Sections.VarSection) OR (sectionType = Sections.ConstSection) THEN
section.SetBitsPerUnit(system.dataUnit)
ELSE
section.SetBitsPerUnit(system.codeUnit)
END;
ASSERT(section.bitsPerUnit # Sections.UnknownSize);
ParseSectionProperties(section);
IF ~error & ExpectLineDelimiter() THEN
ParseSectionContent(scanner, section, sectionList);
afterFirstSection := TRUE
END
END
END
END
END
END
END;
RETURN ~error
END ParseModuleContent;
PROCEDURE ParseModule*(scanner: Scanner.AssemblerScanner; loader: ModuleLoader): Sections.Module;
VAR
result: Sections.Module;
moduleName, platformName: SyntaxTree.IdentifierString;
backend: Backend.Backend;
imports: Sections.NameList;
BEGIN
NEW(result, NIL, NIL);
IF ParseModuleContent(scanner, result.allSections, moduleName, backend, loader) THEN
backend.GetDescription(platformName);
result.SetModuleName(moduleName);
result.SetSystem(backend.GetSystem());
result.SetPlatformName(platformName);
result.SetImports(imports);
IF Trace THEN
D.String("++++++++++ PARSED MODULE '"); D.String(result.moduleName); D.String("' ++++++++++"); D.Ln;
result.Dump(D.Log)
END
ELSE
result := NIL
END
END ParseModule;
END IntermediateCodeParser;
Assemblinker* = OBJECT
CONST
Trace = FALSE;
RequireSortedSections = FALSE;
TYPE
ArrangementRestriction = RECORD
fixed: BOOLEAN;
positionOrAlignment: LONGINT;
END;
VAR
backend-: Backend.Backend;
diagnostics: Diagnostics.Diagnostics;
rootModuleName, platformName, irFilePath: SyntaxTree.IdentifierString;
importList, loadedModules: Sections.NameList;
allSections: Sections.SectionList;
isSorted, alreadyPrearrangedSinceLastSort: BOOLEAN;
originalRestrictions: POINTER TO ARRAY OF ArrangementRestriction;
PROCEDURE & Init*(diagnostics: Diagnostics.Diagnostics; defaultBackend: Backend.Backend; irFilePath: SyntaxTree.IdentifierString);
BEGIN
SELF.diagnostics := diagnostics;
SELF.irFilePath := irFilePath;
backend := defaultBackend;
defaultBackend.GetDescription(platformName);
rootModuleName := "Unnamed";
NEW(allSections);
NEW(importList, 128);
NEW(loadedModules, 128);
isSorted := FALSE
END Init;
PROCEDURE RemoveFileExtension(CONST filename: ARRAY OF CHAR; VAR moduleName: ARRAY OF CHAR);
VAR extension: FileName;
BEGIN
Files.SplitExtension(filename, moduleName, extension);
END RemoveFileExtension;
PROCEDURE LoadModuleInternal(CONST moduleFileName: ARRAY OF CHAR): BOOLEAN;
BEGIN
RETURN LoadModule2(moduleFileName, LoadModuleInternal, FALSE)
END LoadModuleInternal;
PROCEDURE LoadModuleEmpty(CONST moduleFileName: ARRAY OF CHAR): BOOLEAN;
BEGIN RETURN TRUE
END LoadModuleEmpty;
PROCEDURE LoadModule*(CONST moduleFileName: ARRAY OF CHAR; isRecursive: BOOLEAN): BOOLEAN;
VAR loadModule: ModuleLoader;
BEGIN
IF isRecursive THEN loadModule := LoadModuleInternal ELSE loadModule := LoadModuleEmpty END;
RETURN LoadModule2(moduleFileName, loadModule, TRUE)
END LoadModule;
PROCEDURE LoadModule2(CONST moduleFileName: ARRAY OF CHAR; loadModule: ModuleLoader; isRoot: BOOLEAN): BOOLEAN;
VAR
filename, parsedModuleName, moduleName: SyntaxTree.IdentifierString;
parsedImportList: Sections.NameList;
assemblerScanner: Scanner.AssemblerScanner;
intermediateCodeParser: IntermediateCodeParser;
reader: Streams.Reader;
parsedBackend: Backend.Backend;
i: LONGINT;
BEGIN
IF Trace THEN D.String(">>> LoadModule "); D.String(moduleName); D.Ln END;
RemoveFileExtension(moduleFileName, moduleName);
IF loadedModules.ContainsName(moduleName) THEN
IF Trace THEN D.String(">>> module "); D.String(moduleName); D.String(" has already been loaded"); D.Ln END;
RETURN TRUE
ELSE
IF moduleName = "SYSTEM" THEN
ELSE
filename := moduleName; Files.JoinExtension(filename, IntermediateCodeExtension, filename);
IF irFilePath # "" THEN Files.JoinPath(irFilePath, filename, filename) END;
reader := Basic.GetFileReader(filename);
loadedModules.AddName(moduleName);
IF reader = NIL THEN
diagnostics.Error(filename, Diagnostics.Invalid, Diagnostics.Invalid, "failed to open");
RETURN FALSE
ELSE
IF Trace THEN D.String(">>> IR file successfully opened: "); D.String(filename); D.Ln END;
NEW(assemblerScanner, filename, reader, 0, diagnostics);
NEW(intermediateCodeParser, diagnostics, backend.GetSystem());
IF intermediateCodeParser.ParseModuleContent(assemblerScanner, allSections, parsedModuleName, parsedBackend, loadModule) THEN
IF Trace THEN
D.String(">>> IR file successfully parsed: "); D.String(filename); D.Ln;
DumpAllSections(D.Log);
END;
isSorted := FALSE;
IF isRoot THEN
SELF.rootModuleName := moduleName;
IF (backend = NIL) & (parsedBackend # NIL) THEN
backend := parsedBackend;
backend.GetDescription(platformName)
END
END;
RETURN TRUE
ELSE
diagnostics.Error(filename, Diagnostics.Invalid, Diagnostics.Invalid, "IR file could not be parsed");
RETURN FALSE
END
END
END;
RETURN TRUE
END
END LoadModule2;
PROCEDURE MarkAsReachableByName*(CONST name: ARRAY OF CHAR);
VAR
section: Sections.Section;
pooledName: Basic.PooledName;
BEGIN
Basic.ToPooledName(name, pooledName);
section:= allSections.FindByName(pooledName);
ASSERT(section # NIL);
MarkAsReachable(section)
END MarkAsReachableByName;
PROCEDURE MarkAsReachableStartingWith(CONST prefix: Basic.PooledName; allowedSections: SET);
VAR
section: Sections.Section; name: Basic.PooledName;
i: LONGINT;
BEGIN
FOR i := 0 TO allSections.Length() - 1 DO
section := allSections.GetSection(i);
IF section.type IN allowedSections THEN
IF Basic.IsPrefix(prefix, section.name) THEN
name := section.name;
Basic.RemoveSuffix(name);
IF prefix = name THEN
MarkAsReachable(section)
END
END
END;
END
END MarkAsReachableStartingWith;
PROCEDURE ModuleIsReachable*(CONST name: Basic.String): BOOLEAN;
VAR i: LONGINT; section: Sections.Section;
BEGIN
FOR i := 0 TO allSections.Length()-1 DO
section := allSections.GetSection(i);
IF (section.name[0] = name) & section.isReachable THEN
RETURN TRUE
END;
END;
RETURN FALSE
END ModuleIsReachable;
PROCEDURE MarkAsReachable(section: Sections.Section);
VAR
intermediateCodeSection: IntermediateCode.Section;
i: LONGINT;
procedureName, moduleName: SyntaxTree.IdentifierString;
prefix: Basic.PooledName;
BEGIN
IF ~section.isReachable THEN
IF Trace THEN D.String(">>> MarkAsReachable "); Basic.WritePooledName(D.Log, section.name); D.Ln END;
section.SetReachability(TRUE);
prefix := section.name; Basic.RemoveSuffix(prefix);
MarkAsReachableStartingWith(prefix, {Sections.InitCodeSection, Sections.InitCode2Section});
ASSERT(section IS IntermediateCode.Section);
intermediateCodeSection := section(IntermediateCode.Section);
FOR i := 0 TO intermediateCodeSection.pc - 1 DO
IF ~backend(IntermediateCode.IntermediateBackend).SupportedInstruction2(intermediateCodeSection.instructions[i], moduleName, procedureName) THEN
Strings.Append(moduleName,".");
Strings.Append(moduleName, procedureName);
MarkAsReachableByName(moduleName);
END;
IF intermediateCodeSection.instructions[i].op1.symbol # NIL THEN MarkAsReachable(intermediateCodeSection.instructions[i].op1.symbol) END;
IF intermediateCodeSection.instructions[i].op2.symbol # NIL THEN MarkAsReachable(intermediateCodeSection.instructions[i].op2.symbol) END;
IF intermediateCodeSection.instructions[i].op3.symbol # NIL THEN MarkAsReachable(intermediateCodeSection.instructions[i].op3.symbol) END
END
END
END MarkAsReachable;
PROCEDURE MarkReachabilityOfAll*(isReachable: BOOLEAN);
VAR
section: Sections.Section;
i: LONGINT;
BEGIN
IF Trace THEN D.String(">>> MarkReachabilityOfAll "); IF isReachable THEN D.String("TRUE") ELSE D.String("FALSE") END; D.Ln END;
FOR i := 0 TO allSections.Length() - 1 DO
section := allSections.GetSection(i);
section.SetReachability(isReachable)
END
END MarkReachabilityOfAll;
PROCEDURE DumpAllSections*(writer: Streams.Writer);
VAR
section: Sections.Section;
i: LONGINT;
BEGIN
FOR i := 0 TO allSections.Length() - 1 DO
section := allSections.GetSection(i);
IF section.isReachable THEN
writer.String("REACHABLE ")
ELSE
writer.String("unreachable ")
END;
section.Dump(writer)
END;
writer.Update
END DumpAllSections;
PROCEDURE StoreOriginalRestrictions;
VAR
section: Sections.Section;
i: LONGINT;
BEGIN
NEW(originalRestrictions, allSections.Length());
FOR i := 0 TO allSections.Length() - 1 DO
section := allSections.GetSection(i);
originalRestrictions[i].fixed := section.fixed;
originalRestrictions[i].positionOrAlignment := section.positionOrAlignment
END
END StoreOriginalRestrictions;
PROCEDURE RestoreOriginalRestrictions;
VAR
section: Sections.Section;
i: LONGINT;
BEGIN
ASSERT(LEN(originalRestrictions) = allSections.Length());
FOR i := 0 TO allSections.Length() - 1 DO
section := allSections.GetSection(i);
section.SetPositionOrAlignment(originalRestrictions[i].fixed, originalRestrictions[i].positionOrAlignment)
END
END RestoreOriginalRestrictions;
PROCEDURE PrearrangeReachableDataSections*();
VAR
fixedDataSections, flexibleDataSections: Sections.SectionList;
section, fixedDataSection, flexibleDataSection: Sections.Section;
i, currentAddress, nextOccupiedAddress, flexibleDataSectionIndex, fixedDataSectionIndex, startAddress, endAddress: LONGINT;
done: BOOLEAN;
BEGIN
IF ~isSorted THEN
IF Trace THEN D.String("++++++++++ before sorting ++++++++++"); DumpAllSections(D.Log) END;
FOR i:= 0 TO allSections.Length() - 1 DO
allSections.GetSection(i).SetOffset(i)
END;
allSections.Sort(SectionPositionAndSizeComparison);
IF Trace THEN D.String("++++++++++ after sorting ++++++++++"); DumpAllSections(D.Log) END;
isSorted := TRUE;
alreadyPrearrangedSinceLastSort := FALSE
END;
ASSERT(isSorted);
IF alreadyPrearrangedSinceLastSort THEN RestoreOriginalRestrictions ELSE StoreOriginalRestrictions END;
IF Trace THEN D.String("before prearrangement"); D.Ln; DumpAllSections(D.Log); D.Ln END;
NEW(fixedDataSections);
NEW(flexibleDataSections);
FOR i:= 0 TO allSections.Length() - 1 DO
section := allSections.GetSection(i);
IF section.isReachable & ((section.type = Sections.ConstSection) OR (section.type = Sections.VarSection)) THEN
IF section.fixed THEN
fixedDataSections.AddSection(section)
ELSE
flexibleDataSections.AddSection(section)
END
END
END;
IF Trace THEN
D.String("++++++++++ reachable fixed data sections ++++++++++"); fixedDataSections.Dump(D.Log); D.Ln;
D.String("++++++++++ reachable flexible data sections ++++++++++"); flexibleDataSections.Dump(D.Log); D.Ln;
END;
currentAddress := 0;
flexibleDataSectionIndex := 0;
FOR fixedDataSectionIndex := 0 TO fixedDataSections.Length() DO
IF fixedDataSectionIndex < fixedDataSections.Length() THEN
fixedDataSection := fixedDataSections.GetSection(fixedDataSectionIndex);
ASSERT(fixedDataSection.fixed);
nextOccupiedAddress := fixedDataSection.positionOrAlignment
ELSE
nextOccupiedAddress := MAX(LONGINT)
END;
done := FALSE;
WHILE ~done DO
IF flexibleDataSectionIndex < flexibleDataSections.Length() THEN
flexibleDataSection := flexibleDataSections.GetSection(flexibleDataSectionIndex);
IF flexibleDataSection.IsAligned() & ((currentAddress MOD flexibleDataSection.positionOrAlignment) # 0) THEN
startAddress := currentAddress + flexibleDataSection.positionOrAlignment - (currentAddress MOD flexibleDataSection.positionOrAlignment)
ELSE
startAddress := currentAddress
END;
endAddress := startAddress + flexibleDataSection.GetSize();
IF endAddress <= nextOccupiedAddress THEN
flexibleDataSection.SetPositionOrAlignment(TRUE, startAddress);
INC(flexibleDataSectionIndex);
currentAddress := endAddress
ELSE
done := TRUE
END
ELSE
done := TRUE
END
END;
IF fixedDataSectionIndex < fixedDataSections.Length() THEN
ASSERT(fixedDataSection.GetSize() # Sections.UnknownSize);
currentAddress := fixedDataSection.positionOrAlignment + fixedDataSection.GetSize()
END
END;
alreadyPrearrangedSinceLastSort := TRUE;
IF Trace THEN D.String("after prearrangement"); D.Ln; DumpAllSections(D.Log); D.Ln END;
END PrearrangeReachableDataSections;
PROCEDURE PatchValueInSection*(CONST sectionName: Basic.PooledName; syntaxTreeValue: SyntaxTree.Value);
VAR
section: Sections.Section;
emptyOperand, dataOperand: IntermediateCode.Operand;
dataInstruction: IntermediateCode.Instruction;
hugeintValue: HUGEINT;
BEGIN
section := allSections.FindByName(sectionName);
ASSERT(section # NIL);
IF syntaxTreeValue IS SyntaxTree.BooleanValue THEN
IF syntaxTreeValue(SyntaxTree.BooleanValue).value THEN hugeintValue := 1 ELSE hugeintValue := 0 END
ELSIF syntaxTreeValue IS SyntaxTree.IntegerValue THEN
hugeintValue := syntaxTreeValue(SyntaxTree.IntegerValue).hvalue;
ELSE
HALT(100)
END;
IntermediateCode.InitImmediate(dataOperand, IntermediateCode.GetType(backend.GetSystem(), syntaxTreeValue.type.resolved), hugeintValue);
IntermediateCode.InitOperand(emptyOperand);
IntermediateCode.InitInstruction(dataInstruction, -1, IntermediateCode.data, dataOperand, emptyOperand, emptyOperand);
ASSERT(section IS IntermediateCode.Section);
section(IntermediateCode.Section).EmitAt(0, dataInstruction)
END PatchValueInSection;
PROCEDURE ExtractModule*(): Sections.Module;
BEGIN RETURN ExtractModuleWithName(rootModuleName)
END ExtractModule;
PROCEDURE ExtractModuleWithName*(CONST desiredName: ARRAY OF CHAR): Sections.Module;
VAR
result: Sections.Module;
section: Sections.Section;
i: LONGINT;
BEGIN
NEW(result, NIL, backend.GetSystem());
result.SetModuleName(desiredName);
result.SetPlatformName(platformName);
result.SetImports(importList);
FOR i := 0 TO allSections.Length() - 1 DO
section := allSections.GetSection(i);
ASSERT(section IS IntermediateCode.Section);
section(IntermediateCode.Section).SetResolved(NIL);
IF section.isReachable THEN result.allSections.AddSection(section) END
END;
IF RequireSortedSections THEN result.allSections.Sort(SectionPositionComparison) END;
IF Trace THEN D.String("+++++++++ intermediate code module ++++++++++"); D.Ln; result.Dump(D.Log); D.Ln; END;
RETURN result
END ExtractModuleWithName;
PROCEDURE SectionPositionComparison(leftObject, rightObject: ANY): BOOLEAN;
VAR
leftSection, rightSection: Sections.Section;
leftPosition, rightPosition: LONGINT;
BEGIN
ASSERT((leftObject IS Sections.Section) & (rightObject IS Sections.Section));
leftSection := leftObject(Sections.Section);
rightSection := rightObject(Sections.Section);
IF leftSection.fixed THEN
leftPosition := leftSection.positionOrAlignment
ELSE
leftPosition := MAX(LONGINT)
END;
IF rightSection.fixed THEN
rightPosition := rightSection.positionOrAlignment
ELSE
rightPosition := MAX(LONGINT)
END;
IF leftSection.IsCode() & rightSection.IsCode() THEN RETURN FALSE END;
RETURN leftPosition < rightPosition
END SectionPositionComparison;
PROCEDURE SectionPositionAndSizeComparison(leftObject, rightObject: ANY): BOOLEAN;
VAR
leftSection, rightSection: Sections.Section;
leftPosition, rightPosition, leftSize, rightSize: LONGINT;
BEGIN
ASSERT((leftObject IS Sections.Section) & (rightObject IS Sections.Section));
leftSection := leftObject(Sections.Section);
rightSection := rightObject(Sections.Section);
IF leftSection.fixed THEN
leftPosition := leftSection.positionOrAlignment
ELSE
leftPosition := MAX(LONGINT)
END;
IF rightSection.fixed THEN
rightPosition := rightSection.positionOrAlignment
ELSE
rightPosition := MAX(LONGINT)
END;
IF ~leftSection.IsCode() & rightSection.IsCode() THEN
RETURN TRUE
ELSIF leftSection.IsCode() & ~rightSection.IsCode() THEN
RETURN FALSE
ELSIF leftSection.IsCode() & rightSection.IsCode() THEN
IF GetPriority(leftSection) < GetPriority(rightSection) THEN
RETURN TRUE
ELSIF GetPriority(leftSection) = GetPriority(rightSection) THEN
RETURN leftSection.offset < rightSection.offset
ELSE
RETURN FALSE
END
ELSIF leftPosition < rightPosition THEN
RETURN TRUE
ELSIF leftPosition > rightPosition THEN
RETURN FALSE
ELSE
ASSERT(leftPosition = rightPosition);
leftSize := leftSection.GetSize();
rightSize := rightSection.GetSize();
IF (leftSize = Sections.UnknownSize) OR (leftSize = 0) THEN leftSize := MAX(LONGINT) END;
IF (rightSize = Sections.UnknownSize) OR (rightSize = 0) THEN rightSize := MAX(LONGINT) END;
IF leftSize = rightSize THEN
RETURN leftSection.offset < rightSection.offset
ELSE
RETURN leftSize < rightSize
END
END
END SectionPositionAndSizeComparison;
PROCEDURE GenerateObjectFile*(objectFileFormat: Formats.ObjectFileFormat; log: Streams.Writer; flags: SET; checker: SemanticChecker.Checker; activeCellsSpecification: ActiveCells.Specification): BOOLEAN;
BEGIN RETURN GenerateObjectFileWithName(objectFileFormat, log, flags, checker, activeCellsSpecification, rootModuleName)
END GenerateObjectFile;
PROCEDURE FixSections(binaryModule: Sections.Module; VAR sizes: ARRAY OF LONGINT);
VAR adr,i: LONGINT; section: Sections.Section; is: BinaryCode.Section;
BEGIN
adr := 0;
FOR i := 0 TO binaryModule.allSections.Length()-1 DO
section := binaryModule.allSections.GetSection(i);
is := section(IntermediateCode.Section).resolved;
IF (is # NIL) & section.IsCode() THEN
is.SetAlignment(TRUE, adr);
IF is.pc > sizes[i] THEN sizes[i] := is.pc END;
adr := adr + sizes[i];
END;
is.Reset;
END;
END FixSections;
PROCEDURE Conflict(binaryModule: Sections.Module; VAR sizes: ARRAY OF LONGINT): BOOLEAN;
VAR adr,i: LONGINT; section: Sections.Section;is: BinaryCode.Section;
BEGIN
adr := 0;
FOR i := 0 TO binaryModule.allSections.Length()-1 DO
section := binaryModule.allSections.GetSection(i);
IF (is # NIL) & section.IsCode() THEN
is := section(IntermediateCode.Section).resolved;
IF is.pc > sizes[i] THEN RETURN TRUE
END;
END;
END;
RETURN FALSE
END Conflict;
PROCEDURE GenerateObjectFileWithName*(objectFileFormat: Formats.ObjectFileFormat; log: Streams.Writer; flags: SET; checker: SemanticChecker.Checker; activeCellsSpecification: ActiveCells.Specification; CONST desiredName: ARRAY OF CHAR): BOOLEAN;
VAR
count: LONGINT;
intermediateCodeModule: Sections.Module;
binaryModule: Formats.GeneratedModule;
result: BOOLEAN;
sizes: POINTER TO ARRAY OF LONGINT; i: LONGINT;
BEGIN
intermediateCodeModule := ExtractModuleWithName(desiredName);
result := TRUE;
backend.Initialize(diagnostics, log, flags, checker, backend.GetSystem(), activeCellsSpecification);
binaryModule := backend.ProcessIntermediateCodeModule(intermediateCodeModule); count := 0;
NEW(sizes, binaryModule(Sections.Module).allSections.Length());
FOR i := 0 TO LEN(sizes)-1 DO sizes[i] := 0 END;
REPEAT
INC(count);
FixSections(binaryModule(Sections.Module),sizes^);
binaryModule := backend.ProcessIntermediateCodeModule(intermediateCodeModule);
UNTIL ~Conflict(binaryModule(Sections.Module),sizes^) OR (count > 10) ;
ASSERT(count <=10);
IF binaryModule = NIL THEN
diagnostics.Error(desiredName, Diagnostics.Invalid, Diagnostics.Invalid, "the specified backend cannot process intermediate code");
result := FALSE
ELSIF backend.error THEN
diagnostics.Error(desiredName, Diagnostics.Invalid, Diagnostics.Invalid, "binary code could not be generated (backend error)");
result := FALSE
ELSE
IF Trace THEN D.String(">>> binary code successfully generated"); D.Ln END;
IF objectFileFormat = NIL THEN
diagnostics.Error(desiredName, Diagnostics.Invalid, Diagnostics.Invalid, "no object file format specified");
result := FALSE
ELSE
objectFileFormat.Initialize(diagnostics);
IF objectFileFormat.Export(binaryModule, NIL) THEN
IF Trace THEN D.String(">>> object file successfully written"); D.Ln END;
ELSE
diagnostics.Error(desiredName, Diagnostics.Invalid, Diagnostics.Invalid, "object file could not be written");
result := FALSE
END
END
END;
RETURN result
END GenerateObjectFileWithName;
END Assemblinker;
PROCEDURE GetPriority (block: Sections.Section): LONGINT;
BEGIN
IF block.fixed THEN RETURN 0 END;
IF block.type = ObjectFile.InitCode2 THEN RETURN 1 END;
IF block.type = ObjectFile.InitCode THEN RETURN 2 END;
IF block.type = ObjectFile.BodyCode THEN RETURN 3 END;
IF block.type = ObjectFile.Code THEN RETURN 4 END;
IF block.GetSize () = 0 THEN RETURN 6 END;
RETURN 5;
END GetPriority;
END FoxIntermediateCodeAssembler.