MODULE FoxBinaryObjectFile;
IMPORT
Scanner := FoxScanner, Basic := FoxBasic, SyntaxTree := FoxSyntaxTree, Global := FoxGlobal, SemanticChecker := FoxSemanticChecker, FingerPrinter := FoxFingerPrinter, Sections := FoxSections,
Streams, D := Debugging, Files, SYSTEM,Strings, BinaryCode := FoxBinaryCode, KernelLog, Diagnostics, SymbolFileFormat := FoxBinarySymbolFile, Options,
Formats := FoxFormats, IntermediateCode := FoxIntermediateCode, Machine
;
CONST
ofFileTag = 0BBX;
ofNoZeroCompress = 0ADX;
ofFileVersion = SymbolFileFormat.FileVersionCurrent;
ofEUEnd = 0X;
ofEURecord = 1X;
ofEUProcFlag = SHORT(080000000H);
DefaultNofSysCalls = 12;
NewRec = 0; NewArr = 1; NewSys = 2; CaseTable = 3; ProcAddr = 4;
Lock = 5; Unlock = 6; Start = 7; Await = 8; InterfaceLookup = 9;
RegisterInterface = 10; GetProcedure = 11;
Trace = FALSE;
TYPE Name=ARRAY 256 OF CHAR;
ByteArray = POINTER TO ARRAY OF CHAR;
TYPE
ObjectFileFormat*= OBJECT (Formats.ObjectFileFormat)
VAR extension: Basic.FileName;
PROCEDURE Export*(module: Formats.GeneratedModule; symbolFileFormat: Formats.SymbolFileFormat): BOOLEAN;
VAR symbolFile: Files.File; moduleName: SyntaxTree.IdentifierString; fileName: Files.FileName; f: Files.File; w: Files.Writer;
VAR constSize, varSize, codeSize, caseTableSize: LONGINT; VAR const, code: ByteArray;
BEGIN
Global.ModuleFileName(module.module.name,module.module.context,moduleName);
Basic.Concat(fileName,path,moduleName,extension);
IF Trace THEN D.Str("FoxBinaryObjectFile.ObjectFileFormat.Export "); D.Str(moduleName); D.Ln; END;
IF ~(module IS Sections.Module) THEN
diagnostics.Error(module.module.sourceName,Diagnostics.Invalid,Diagnostics.Invalid,"generated module format does not match object file format");
RETURN FALSE;
ELSIF module.findPC # MAX(LONGINT) THEN
MakeSectionOffsets(module(Sections.Module),constSize, varSize, codeSize, caseTableSize,const,code);
RETURN FindPC(module.findPC,module(Sections.Module),diagnostics);
ELSE
WITH module: Sections.Module DO
IF (symbolFileFormat # NIL) & (symbolFileFormat IS SymbolFileFormat.BinarySymbolFile) THEN
symbolFile := symbolFileFormat(SymbolFileFormat.BinarySymbolFile).file;
ELSE
symbolFile := NIL
END;
f := Files.New(fileName);
ASSERT(f # NIL);
NEW(w,f,0);
WriteObjectFile(w,module,symbolFile);
w.Update;
Files.Register(f);
RETURN TRUE
END;
END;
END Export;
PROCEDURE DefineOptions*(options: Options.Options);
BEGIN
options.Add(0X,"objectFileExtension",Options.String);
END DefineOptions;
PROCEDURE GetOptions*(options: Options.Options);
BEGIN
IF ~options.GetString("objectFileExtension",extension) THEN
extension := Machine.DefaultObjectFileExtension
END;
END GetOptions;
PROCEDURE DefaultSymbolFileFormat(): Formats.SymbolFileFormat;
BEGIN RETURN SymbolFileFormat.Get();
END DefaultSymbolFileFormat;
PROCEDURE ForceModuleBodies(): BOOLEAN;
BEGIN RETURN TRUE
END ForceModuleBodies;
PROCEDURE GetExtension(VAR ext: ARRAY OF CHAR);
BEGIN COPY(extension, ext)
END GetExtension;
END ObjectFileFormat;
Fixup = OBJECT
VAR
nextFixup: Fixup;
fixup: BinaryCode.Fixup;
fixupSection: Sections.Section;
END Fixup;
Section=OBJECT
VAR
name: Basic.SegmentedName;
symbol: SyntaxTree.Symbol;
entryNumber: LONGINT;
offset: LONGINT;
fixups: Fixup;
numberFixups: LONGINT;
type: LONGINT;
resolved: BinaryCode.Section;
isCaseTable: BOOLEAN;
referenced: BOOLEAN;
PROCEDURE SetEntryNumber(num: LONGINT);
BEGIN
entryNumber := num
END SetEntryNumber;
PROCEDURE SetSymbol(s: SyntaxTree.Symbol);
BEGIN
symbol := s;
END SetSymbol;
PROCEDURE &Init(CONST name: Basic.SegmentedName);
BEGIN SELF.name := name; fixups := NIL; symbol := NIL; entryNumber := 0; numberFixups := 0;
END Init;
PROCEDURE AddFixup(fixup: BinaryCode.Fixup; fixupSection: Sections.Section);
VAR next: Fixup;
BEGIN
NEW(next);
next.fixup := fixup;
next.fixupSection := fixupSection;
next.nextFixup := fixups;
fixups := next;
INC(numberFixups);
END AddFixup;
PROCEDURE Dump(w: Streams.Writer);
VAR fixup: Fixup; n: Basic.SegmentedName;
BEGIN
Basic.WriteSegmentedName(w,name);
w.String(" : ");
IF symbol = NIL THEN w.String("NIL")
ELSE Global.GetSymbolSegmentedName(symbol, n); Basic.WriteSegmentedName(w,n);
END;
IF referenced THEN w.String("(referenced)") END;
w.Ln;
w.String("no fixups:"); w.Int(numberFixups,1); w.Ln;
fixup := fixups;
WHILE fixup # NIL DO
w.String("fixup in "); Basic.WriteSegmentedName(w,fixups.fixupSection.name); w.String(" "); fixup.fixup.Dump(w); w.Ln;
fixup := fixup.nextFixup;
END;
END Dump;
END Section;
SectionNameLookup = OBJECT(Basic.HashTableSegmentedName);
PROCEDURE GetSection(CONST name: Basic.SegmentedName):Section;
VAR p: ANY;
BEGIN
p := Get(name);
IF p # NIL THEN RETURN p(Section) ELSE RETURN NIL END;
END GetSection;
PROCEDURE PutSection(CONST name:Basic.SegmentedName; section: Section);
BEGIN
Put(name, section);
END PutSection;
END SectionNameLookup;
SymbolLookup = OBJECT(Basic.HashTable);
PROCEDURE GetSection(s: SyntaxTree.Symbol):Section;
VAR p: ANY;
BEGIN
p := Get(s);
IF p # NIL THEN RETURN p(Section) ELSE RETURN NIL END;
END GetSection;
PROCEDURE PutSection(symbol: SyntaxTree.Symbol; section: Section);
BEGIN
Put(symbol, section);
END PutSection;
END SymbolLookup;
SectionList= OBJECT (Basic.List)
VAR
lookup: SectionNameLookup;
symbolLookup: SymbolLookup;
PROCEDURE &Init;
BEGIN
InitList(16);
NEW(lookup,16);
NEW(symbolLookup, 16);
END Init;
PROCEDURE AddSection(name: Basic.SegmentedName): Section;
VAR section: Section;
BEGIN
section := lookup.GetSection(name);
IF section = NIL THEN
NEW(section, name);
lookup.Put(name, section);
Add(section);
END;
RETURN section
END AddSection;
PROCEDURE BySymbol(symbol: SyntaxTree.Symbol): Section;
VAR name: Basic.SegmentedName;
BEGIN
RETURN symbolLookup.GetSection(symbol);
END BySymbol;
PROCEDURE GetSection(i: LONGINT): Section;
VAR any: ANY;
BEGIN
any := Get(i);
RETURN any(Section)
END GetSection;
PROCEDURE Dump(w: Streams.Writer);
VAR section: Section; i: LONGINT;
BEGIN
FOR i := 0 TO Length()-1 DO
section := GetSection(i); section.Dump(w);
END;
END Dump;
END SectionList;
VAR SysCallMap : ARRAY DefaultNofSysCalls OF CHAR;
PROCEDURE FindPC(pc: LONGINT; module: Sections.Module; diagnostics: Diagnostics.Diagnostics): BOOLEAN;
VAR
section:Sections.Section; binarySection: BinaryCode.Section; label: BinaryCode.LabelList;
i: LONGINT;
BEGIN
FOR i := 0 TO module.allSections.Length() - 1 DO
section := module.allSections.GetSection(i);
binarySection := section(IntermediateCode.Section).resolved;
IF ((section.offset ) <= pc) & (pc < (section.offset +binarySection.pc )) THEN
label := binarySection.labels;
WHILE (label # NIL) & ((label.offset + section.offset ) > pc) DO
label := label.prev;
END;
IF label # NIL THEN
diagnostics.Information(module.module.sourceName,label.position,Diagnostics.Invalid," pc position");
RETURN TRUE
END;
END
END;
diagnostics.Error(module.module.sourceName,Diagnostics.Invalid,Diagnostics.Invalid," could not locate pc");
RETURN FALSE
END FindPC;
PROCEDURE MakeSectionOffsets(module: Sections.Module; VAR constSize, varSize, codeSize, caseTableSize: LONGINT; VAR const, code: ByteArray);
VAR symbolName: SyntaxTree.IdentifierString; symbol: SyntaxTree.Symbol; binarySection: BinaryCode.Section;
pc: LONGINT;
PROCEDURE FixupSections;
VAR
section: Sections.Section; dest, i: LONGINT; fixup,next: BinaryCode.Fixup; symbol: Sections.Section;
BEGIN
FOR i := 0 TO module.allSections.Length() - 1 DO
section := module.allSections.GetSection(i);
binarySection := section(IntermediateCode.Section).resolved;
fixup := binarySection.fixupList.firstFixup;
binarySection.fixupList.InitFixupList;
WHILE fixup # NIL DO
next := fixup.nextFixup;
symbol := module.allSections.FindByName(fixup.symbol.name);
IF symbol # NIL THEN
symbol.SetReferenced(TRUE);
ELSIF Trace THEN
D.String("fixup symbol not found: "); Basic.WriteSegmentedName(D.Log, fixup.symbol.name); D.Ln;
END;
IF (fixup.mode = BinaryCode.Relative) & (symbol # NIL) THEN
dest := (symbol.offset + fixup.displacement) - (section.offset + fixup.offset);
ASSERT(fixup.symbolOffset = 0);
binarySection.PutDWordAt(fixup.offset, dest);
ELSIF (fixup.mode = BinaryCode.Absolute) & (symbol # NIL) THEN
dest := symbol.offset + fixup.displacement;
binarySection.PutDWordAt(fixup.offset, dest);
binarySection.fixupList.AddFixup(fixup);
ELSIF (fixup.mode = BinaryCode.Absolute) THEN
dest := fixup.displacement;
binarySection.PutDWordAt(fixup.offset, dest);
binarySection.fixupList.AddFixup(fixup);
ELSE binarySection.fixupList.AddFixup(fixup);
END;
fixup := next;
END
END;
END FixupSections;
PROCEDURE Copy(section: BinaryCode.Section; to: ByteArray; offset: LONGINT);
VAR i,ofs: LONGINT;
BEGIN
ofs := (offset );
FOR i := 0 TO ((section.pc-1) ) DO
to[i+ofs] := CHR(section.bits.GetBits(i*8,8));
END;
END Copy;
PROCEDURE FirstOffsets(sectionList: Sections.SectionList);
VAR
section: Sections.Section;
i: LONGINT;
BEGIN
FOR i := 0 TO sectionList.Length() - 1 DO
section := sectionList.GetSection(i);
binarySection := section(IntermediateCode.Section).resolved;
symbol := section.symbol;
IF symbol # NIL THEN
symbol.GetName(symbolName);
IF section.symbol = module.module.moduleScope.bodyProcedure THEN
section.SetOffset(0); INC(codeSize,binarySection.pc);
ELSIF symbolName = "@moduleSelf" THEN
section.SetOffset(0); INC(constSize,binarySection.pc);
END;
END
END;
END FirstOffsets;
PROCEDURE SetOffsets(sectionList: Sections.SectionList; caseTables: BOOLEAN);
VAR
section: Sections.Section;
i: LONGINT;
BEGIN
FOR i := 0 TO sectionList.Length() - 1 DO
section := sectionList.GetSection(i);
IF section.isCaseTable = caseTables THEN
binarySection := section(IntermediateCode.Section).resolved;
symbol := section.symbol;
IF symbol # NIL THEN
symbol.GetName(symbolName);
ELSE symbolName := "";
END;
IF section.symbol = module.module.moduleScope.bodyProcedure THEN
ELSIF symbolName = "@moduleSelf" THEN
ELSIF section.type = Sections.ConstSection THEN
IF binarySection.alignment # 0 THEN
INC(constSize,(-constSize) MOD binarySection.alignment);
END;
section.SetOffset(constSize); INC(constSize,binarySection.pc);
ELSIF (section.type = Sections.CodeSection) OR (section.type = Sections.BodyCodeSection) THEN
section.SetOffset(codeSize); INC(codeSize, binarySection.pc);
ELSIF section.type = Sections.VarSection THEN
INC(varSize, binarySection.pc);
IF binarySection.alignment # 0 THEN
INC(varSize,(-varSize) MOD binarySection.alignment);
END;
section.SetOffset(-varSize);
END
END;
END;
END SetOffsets;
PROCEDURE CopySections(sectionList: Sections.SectionList);
VAR
section: Sections.Section;
i: LONGINT;
BEGIN
FOR i := 0 TO sectionList.Length() - 1 DO
section := sectionList.GetSection(i);
binarySection := section(IntermediateCode.Section).resolved;
IF section.type = Sections.ConstSection THEN
Copy(binarySection,const,section.offset);
ELSIF (section.type = Sections.CodeSection) OR (section.type = Sections.BodyCodeSection) THEN
Copy(binarySection,code,section.offset);
END
END;
END CopySections;
BEGIN
FirstOffsets(module.allSections);
SetOffsets(module.allSections,FALSE);
pc := constSize;
SetOffsets(module.allSections, TRUE);
caseTableSize := (constSize -pc) DIV 4 ;
FixupSections;
NEW(const,constSize ); NEW(code,codeSize );
CopySections(module.allSections);
END MakeSectionOffsets;
PROCEDURE WriteObjectFile*(w:Streams.Writer; module: Sections.Module; symbolFile: Files.File);
VAR moduleName: Name; refSize, numberEntries,numberCommands,numberPointers,numberTypes,numberImports,
numberVarConstLinks,numberLinks: LONGINT;
dataSize,constSize,codeSize,caseTableSize: LONGINT;
exTableLen,numberProcs,maxPtrs,typeDescSize: LONGINT; headerPos,endPos: LONGINT;
moduleScope: SyntaxTree.ModuleScope; fingerprinter: FingerPrinter.FingerPrinter;
const, code: ByteArray; procedureFixupOffset : LONGINT;
crc: LONGINT; crc32: Basic.CRC32Stream;
symbols, importedSymbols: SectionList;
PROCEDURE RawLIntAt(at: LONGINT; val: LONGINT);
VAR pos: LONGINT;
BEGIN
pos := w.Pos(); w.SetPos(at); w.RawLInt(val); w.SetPos(pos);
END RawLIntAt;
PROCEDURE AppendFile(f: Files.File; to: Streams.Writer);
VAR buffer: ARRAY 1024 OF CHAR; r: Files.Reader; read: LONGINT;
BEGIN
Files.OpenReader(r, f, 0);
REPEAT
r.Bytes(buffer, 0, 1024, read);
to.Bytes(buffer, 0, read)
UNTIL read # 1024
END AppendFile;
PROCEDURE SymbolFile;
BEGIN
IF Trace THEN D.Str("FoxObjectFile.SymbolFile Length at pos "); D.Int(w.Pos(),1); D.Ln END;
IF symbolFile # NIL THEN
w.RawLInt(symbolFile.Length());
IF Trace THEN D.Str("FoxObjectFile.SymbolFile at pos "); D.Int(w.Pos(),1); D.Ln END;
AppendFile(symbolFile,w);
ELSE
IF Trace THEN D.Str("FoxObjectFile.SymbolFile: no symbol file!"); D.Ln END;
w.RawLInt(0);
END;
END SymbolFile;
PROCEDURE Header;
BEGIN
headerPos := w.Pos();
w.RawLInt(refSize);
w.RawLInt(numberEntries);
w.RawLInt(numberCommands);
w.RawLInt(numberPointers);
w.RawLInt(numberTypes);
w.RawLInt(numberImports);
w.RawLInt(numberVarConstLinks);
w.RawLInt(numberLinks);
w.RawLInt((dataSize )); ASSERT(dataSize >= 0);
w.RawLInt((constSize ));
w.RawLInt((codeSize ));
w.RawLInt(exTableLen);
w.RawLInt(numberProcs);
w.RawLInt(maxPtrs);
w.RawLInt(typeDescSize);
w.RawLInt(crc);
IF Trace THEN D.Str("moduleName:"); D.Str(moduleName); D.Ln; END;
w.RawString(moduleName);
END Header;
PROCEDURE Entries;
VAR
p: Section; procedure: SyntaxTree.Procedure; procedureType : SyntaxTree.ProcedureType;
prev,tail: Fixup; firstOffset: LONGINT; name: SyntaxTree.IdentifierString; fixups, i: LONGINT; fixup: Fixup;
CONST
FixupSentinel = SHORT(0FFFFFFFFH);
PROCEDURE FixupList(l,prev: Fixup; VAR tail: Fixup);
VAR offset: LONGINT;
PROCEDURE Put32(offset: LONGINT; number: LONGINT);
BEGIN
code[offset] := CHR(number MOD 256);
INC(offset); number := number DIV 256;
code[offset] := CHR(number MOD 256);
INC(offset); number := number DIV 256;
code[offset] := CHR(number MOD 256);
INC(offset); number := number DIV 256;
code[offset] := CHR(number MOD 256);
END Put32;
BEGIN
tail := NIL;
IF l # NIL THEN
IF prev # NIL THEN
Put32((prev.fixupSection.offset +prev.fixup.offset ),(l.fixupSection.offset + l.fixup.offset ));
END;
offset := (l.fixupSection.offset + l.fixup.offset );
tail := l;
l := l.nextFixup;
WHILE (l# NIL) DO
Put32(offset,(l.fixupSection.offset + l.fixup.offset ));
offset := (l.fixupSection.offset + l.fixup.offset );
tail := l;
l := l.nextFixup;
END;
Put32(offset,FixupSentinel);
END;
END FixupList;
BEGIN
w.Char(82X);
numberEntries := 0; tail := NIL; prev := NIL; firstOffset := -1;
FOR i := 0 TO symbols.Length() - 1 DO
p := symbols.GetSection(i);
IF (p.symbol # NIL) & (p.symbol IS SyntaxTree.Procedure) & ~p.symbol(SyntaxTree.Procedure).isInline THEN
fixup := p.fixups;
p.symbol.GetName(name);
procedure := p.symbol(SyntaxTree.Procedure);
procedureType := procedure.type(SyntaxTree.ProcedureType);
IF (procedure.access*SyntaxTree.Public # {}) OR (procedureType.isDelegate) OR (fixup # NIL) THEN
p.SetEntryNumber(numberEntries);
w.RawNum((p.offset )); INC(numberEntries);
FixupList(fixup, prev, tail);
IF tail # NIL THEN
prev := tail
END;
IF (fixup # NIL) & (firstOffset = -1) THEN
firstOffset := (fixup.fixupSection.offset + fixup.fixup.offset );
END
END
END
END;
procedureFixupOffset := firstOffset;
END Entries;
PROCEDURE Commands;
VAR
procedure : SyntaxTree.Procedure; procedureType: SyntaxTree.ProcedureType;
p: Section; name: Name; numberParameters, i: LONGINT;
PROCEDURE GetProcedureAllowed() : BOOLEAN;
PROCEDURE TypeAllowed(type : SyntaxTree.Type) : BOOLEAN;
BEGIN
RETURN
(type = NIL) OR
(type.resolved IS SyntaxTree.RecordType) OR
(type.resolved IS SyntaxTree.PointerType) & (type.resolved(SyntaxTree.PointerType).pointerBase.resolved IS SyntaxTree.RecordType);
END TypeAllowed;
BEGIN
numberParameters := procedureType.numberParameters;
RETURN
(numberParameters = 0) & TypeAllowed(procedureType.returnType) OR
(numberParameters = 1) & TypeAllowed(procedureType.firstParameter.type) & TypeAllowed(procedureType.returnType) OR
(numberParameters = 1) & (procedureType.firstParameter.type.resolved IS SyntaxTree.AnyType) & (procedureType.returnType # NIL) & (procedureType.returnType.resolved IS SyntaxTree.AnyType);
END GetProcedureAllowed;
PROCEDURE WriteType(type : SyntaxTree.Type);
VAR typeDeclaration: SyntaxTree.TypeDeclaration; section: Section;
name: SyntaxTree.IdentifierString;
BEGIN
IF type = NIL THEN
w.RawNum(0);
IF Trace THEN
D.String(", t="); D.Int(0,1);
END;
ELSIF (type.resolved IS SyntaxTree.AnyType) OR (type.resolved IS SyntaxTree.ObjectType) THEN
w.RawNum(1);
IF Trace THEN
D.String(", t="); D.Int(1,1);
END;
ELSE
type := type.resolved;
IF type IS SyntaxTree.PointerType THEN
type := type(SyntaxTree.PointerType).pointerBase.resolved;
END;
typeDeclaration := type.typeDeclaration;
typeDeclaration.GetName(name);
section := symbols.BySymbol(type.typeDeclaration);
ASSERT(section # NIL);
w.RawNum((section.offset ));
IF Trace THEN
D.String(", t="); D.Int(section.offset ,1);
END;
END;
END WriteType;
BEGIN
w.Char(83X);
FOR i := 0 TO symbols.Length() - 1 DO
p := symbols.GetSection(i);
IF (p.symbol # NIL) & (p.symbol IS SyntaxTree.Procedure) THEN
procedure := p.symbol(SyntaxTree.Procedure);
procedureType := procedure.type(SyntaxTree.ProcedureType);
IF (SyntaxTree.PublicRead IN procedure.access) & ~(procedure.isInline) & ~(procedureType.isDelegate) & GetProcedureAllowed() THEN
procedure.GetName(name);
IF Trace THEN
D.Str("Command : "); D.Str(name); D.Str(" @ "); D.Int(p.offset ,1);
END;
numberParameters := procedureType.numberParameters;
IF (numberParameters = 0 ) THEN WriteType(NIL)
ELSE WriteType(procedureType.firstParameter.type)
END;
WriteType(procedureType.returnType);
w.RawString(name);
w.RawNum((p.offset ));
INC(numberCommands);
IF Trace THEN
D.Ln
END
END
END
END
END Commands;
PROCEDURE OutPointers(offset: LONGINT; type: SyntaxTree.Type; VAR numberPointers: LONGINT);
VAR variable: SyntaxTree.Variable; i,n,size: LONGINT; base: SyntaxTree.Type;
BEGIN
type := type.resolved;
IF type IS SyntaxTree.AnyType THEN
ASSERT(offset MOD 4 = 0);
w.RawNum((offset )); INC(numberPointers);
IF Trace THEN D.Str("ptr at offset="); D.Int(offset,1); D.Ln; END;
ELSIF type IS SyntaxTree.PointerType THEN
ASSERT(offset MOD 4 = 0);
w.RawNum((offset )); INC(numberPointers);
IF Trace THEN D.Str("ptr at offset="); D.Int(offset,1);D.Ln; END;
ELSIF (type IS SyntaxTree.ProcedureType) & (type(SyntaxTree.ProcedureType).isDelegate) THEN
ASSERT(offset MOD 4 = 0);
w.RawNum((offset )+module.system.addressSize DIV 8 ); INC(numberPointers);
IF Trace THEN D.Str("ptr at offset="); D.Int(offset+module.system.addressSize DIV 8,1); END;
ELSIF (type IS SyntaxTree.RecordType) THEN
WITH type: SyntaxTree.RecordType DO
base := type.GetBaseRecord();
IF base # NIL THEN
OutPointers(offset,base,numberPointers);
END;
variable := type.recordScope.firstVariable;
WHILE(variable # NIL) DO
IF ~(variable.untraced) THEN
OutPointers(offset+variable.offsetInBits DIV 8,variable.type,numberPointers);
END;
variable := variable.nextVariable;
END;
END;
ELSIF (type IS SyntaxTree.ArrayType) THEN
WITH type: SyntaxTree.ArrayType DO
IF type.form= SyntaxTree.Static THEN
n := type.staticLength;
base := type.arrayBase.resolved;
WHILE(base IS SyntaxTree.ArrayType) DO
type := base(SyntaxTree.ArrayType);
n := n* type.staticLength;
base := type.arrayBase.resolved;
END;
size := module.system.AlignedSizeOf(base) DIV 8;
IF SemanticChecker.ContainsPointer(base) THEN
ASSERT(n<1000000);
FOR i := 0 TO n-1 DO
OutPointers(offset+i*size,base,numberPointers);
END;
END;
ELSE
ASSERT(offset MOD 4 = 0);
w.RawNum((offset )); INC(numberPointers);
IF Trace THEN D.Str("ptr at offset="); D.Int(offset,1); D.Ln; END;
END;
END;
ELSIF (type IS SyntaxTree.MathArrayType) THEN
WITH type: SyntaxTree.MathArrayType DO
IF type.form = SyntaxTree.Static THEN
n := type.staticLength;
base := type.arrayBase.resolved;
WHILE(base IS SyntaxTree.MathArrayType) DO
type := base(SyntaxTree.MathArrayType);
n := n* type.staticLength;
base := type.arrayBase.resolved;
END;
size := module.system.AlignedSizeOf(base) DIV 8;
IF SemanticChecker.ContainsPointer(base) THEN
ASSERT(n<1000000);
FOR i := 0 TO n-1 DO
OutPointers(offset+i*size,base,numberPointers);
END;
END;
ELSE
ASSERT(offset MOD 4 = 0);
w.RawNum((offset )); INC(numberPointers);
IF Trace THEN D.Str("ptr at offset="); D.Int(offset,1); D.Ln; END;
END
END;
END;
END OutPointers;
PROCEDURE Pointers;
VAR
s: Section; variable: SyntaxTree.Variable;
i: LONGINT;
BEGIN
w.Char(84X);
numberPointers := 0;
IF Trace THEN D.Str("Global Pointers: "); D.Ln; END;
FOR i := 0 TO symbols.Length() - 1 DO
s := symbols.GetSection(i);
IF (s.symbol # NIL) & (s.symbol IS SyntaxTree.Variable) THEN
variable := s.symbol(SyntaxTree.Variable);
IF ~(variable.untraced) THEN
OutPointers(s.offset, variable.type, numberPointers);
END
END
END
END Pointers;
PROCEDURE IsFirstOccurence(import: SyntaxTree.Import): BOOLEAN;
VAR i: SyntaxTree.Import;
BEGIN
i := moduleScope.firstImport;
WHILE (i # NIL) & (i.module # import.module) DO
i := i.nextImport;
END;
RETURN i = import
END IsFirstOccurence;
PROCEDURE Imports;
VAR name: Name; import: SyntaxTree.Import;
BEGIN
w.Char(85X);
numberImports := 0;
import := moduleScope.firstImport;
WHILE(import # NIL) DO
IF ~Global.IsSystemModule(import.module) & IsFirstOccurence(import) THEN
Global.ModuleFileName(import.module.name,import.module.context,name);
w.RawString(name); INC(numberImports);
IF Trace THEN
D.Str("Import module : "); D.Str(name); D.Ln;
END;
END;
import := import.nextImport;
END;
END Imports;
PROCEDURE ModuleNumber(m: SyntaxTree.Module): LONGINT;
VAR number: LONGINT; import: SyntaxTree.Import;
BEGIN
number := 1;
import := moduleScope.firstImport;
WHILE(import # NIL) & (import.module # m) DO
IF ~Global.IsSystemModule(import.module) & IsFirstOccurence(import) THEN
INC(number);
END;
import := import.nextImport;
END;
RETURN number;
END ModuleNumber;
PROCEDURE VarConstLinks;
VAR
fixups: LONGINT; fixupsPosition: LONGINT;
s: Section; fixup: Fixup; temp, i: LONGINT;
sym: Section;
PROCEDURE Fixups(f: Fixup);
BEGIN
WHILE f # NIL DO
IF Trace THEN
D.String("fixup "); D.Int(f.fixupSection.offset +f.fixup.offset ,1); D.Ln;
END;
w.RawNum((f.fixupSection.offset + f.fixup.offset )); INC(fixups);
f := f.nextFixup;
END;
END Fixups;
BEGIN
w.Char(8DX);
numberVarConstLinks := 0;
w.Char(0X);
w.RawNum(-1);
fixupsPosition := w.Pos(); fixups := 0;
w.RawLInt(fixups);
IF Trace THEN D.Str("VarConstLinks:Procedures"); D.Ln; END;
FOR i := 0 TO symbols.Length() - 1 DO
s := symbols.GetSection(i);
IF ~s.isCaseTable THEN
IF (s.symbol=NIL) OR (s.symbol # NIL) & ~(s.symbol IS SyntaxTree.Procedure) THEN
IF Trace THEN D.String("varconstlink, procedure "); Basic.WriteSegmentedName(D.Log, s.name); D.Ln END;
Fixups(s.fixups);
END
END;
END;
FOR i := 0 TO symbols.Length() - 1 DO
s := symbols.GetSection(i);
IF s.isCaseTable THEN
ASSERT(s.symbol # NIL);
IF (s.symbol # NIL) & ~(s.symbol IS SyntaxTree.Procedure) THEN
Fixups(s.fixups);
END
END;
END;
RawLIntAt(fixupsPosition,fixups);
INC(numberVarConstLinks);
IF Trace THEN D.Str("VarConstLinks:ImportedSymbols"); D.Ln; END;
FOR i := 0 TO importedSymbols.Length()-1 DO
sym := importedSymbols.GetSection(i);
IF (sym.symbol=NIL) OR (sym.symbol # NIL) & ~(sym.symbol IS SyntaxTree.Procedure) THEN
ASSERT(sym.numberFixups > 0);
sym.entryNumber := numberVarConstLinks;
INC(numberVarConstLinks);
w.Char(CHR(ModuleNumber(sym.symbol.scope.ownerModule)));
w.RawNum(0);
w.RawLInt(sym.numberFixups);
Fixups(sym.fixups);
END;
END;
END VarConstLinks;
PROCEDURE Links;
VAR
p: Section; procedure: SyntaxTree.Procedure; procedureType: SyntaxTree.ProcedureType; i, counter: LONGINT; temp: LONGINT; fixup: Fixup; fixups: LONGINT;
CONST
FixupSentinel = SHORT(0FFFFFFFFH);
PROCEDURE FixupList(l: Fixup): LONGINT;
VAR
offset,first: LONGINT;
PROCEDURE Put32(offset: LONGINT; number: LONGINT);
BEGIN
code[offset] := CHR(number MOD 256);
INC(offset); number := number DIV 256;
code[offset] := CHR(number MOD 256);
INC(offset); number := number DIV 256;
code[offset] := CHR(number MOD 256);
INC(offset); number := number DIV 256;
code[offset] := CHR(number MOD 256);
END Put32;
BEGIN
offset := (l.fixupSection.offset +l.fixup.offset );first := offset;
l := l.nextFixup;
WHILE l # NIL DO
Put32(offset,(l.fixupSection.offset +l.fixup.offset ));
offset := (l.fixupSection.offset +l.fixup.offset );
l := l.nextFixup;
END;
Put32(offset,FixupSentinel);
RETURN first;
END FixupList;
BEGIN
w.Char(86X);
numberLinks := 0;
IF procedureFixupOffset #-1 THEN
w.Char(0X); w.Char(SysCallMap[ProcAddr]); w.RawNum(procedureFixupOffset);
INC(numberLinks);
END;
IF caseTableSize > 0 THEN
w.Char(0X); w.Char(SysCallMap[CaseTable]); w.RawNum((constSize -caseTableSize *4));
INC(numberLinks);
END;
counter := 0;
FOR i := 0 TO symbols.Length() - 1 DO
p := symbols.GetSection(i);
IF (p.symbol # NIL) & (p.symbol IS SyntaxTree.Procedure) & ~p.symbol(SyntaxTree.Procedure).isInline THEN
fixup := p.fixups;
procedure := p.symbol(SyntaxTree.Procedure);
procedureType := procedure.type(SyntaxTree.ProcedureType);
IF (procedure.access * SyntaxTree.Public # {}) OR (procedureType.isDelegate) OR (fixup # NIL) THEN
w.RawNum(p.numberFixups);
INC(counter);
END
END
END;
ASSERT(counter = numberEntries);
w.RawNum((caseTableSize ));
END Links;
PROCEDURE Constants;
VAR i: LONGINT;
BEGIN
w.Char(87X);
FOR i := 0 TO ((constSize-1) ) DO
w.Char(const[i]);
crc32.Char(const[i]);
END;
END Constants;
PROCEDURE Exports;
VAR numberExports,numberExportsPosition: LONGINT; constant: SyntaxTree.Constant;
variable: SyntaxTree.Variable; procedure : SyntaxTree.Procedure; typeDeclaration : SyntaxTree.TypeDeclaration;
typeNumber: LONGINT; name: ARRAY 256 OF CHAR;
PROCEDURE ExportType(type: SyntaxTree.Type);
VAR destination: Section; ref: LONGINT; count: LONGINT; countPos: LONGINT;
variable: SyntaxTree.Variable; procedure: SyntaxTree.Procedure; fingerPrint: SyntaxTree.FingerPrint;
initialType: SyntaxTree.Type;
BEGIN
IF type = NIL THEN RETURN END;
type := type.resolved;
initialType := type;
WHILE (type IS SyntaxTree.PointerType) OR (type IS SyntaxTree.ArrayType) OR (type IS SyntaxTree.MathArrayType) DO
IF type IS SyntaxTree.PointerType THEN
type := type(SyntaxTree.PointerType).pointerBase.resolved;
ELSIF type IS SyntaxTree.ArrayType THEN
type := type(SyntaxTree.ArrayType).arrayBase.resolved;
ELSE
type := type(SyntaxTree.MathArrayType).arrayBase.resolved;
END;
IF type = initialType THEN RETURN END;
END;
IF (type IS SyntaxTree.RecordType) & (type(SyntaxTree.RecordType).recordScope.ownerModule = module.module) THEN
w.Char(ofEURecord);
destination := symbols.BySymbol(type.typeDeclaration);
ASSERT(destination # NIL);
ref := destination.entryNumber;
IF ref # 0 THEN
w.RawNum(-ref);
IF Trace THEN D.Str("already referenced as "); D.Int(ref,1); D.Ln END;
ELSE
count := 0;
INC(typeNumber);
destination.SetEntryNumber(typeNumber);
IF Trace THEN D.Str("register as "); D.Int(typeNumber,1); D.Ln END;
w.RawNum((destination.offset ));
countPos := w.Pos();
w.RawLInt(2);
ExportType(type(SyntaxTree.RecordType).baseType);
fingerPrint := fingerprinter.TypeFP(type);
IF Trace THEN D.Str("export type fp "); D.Int(fingerPrint.private,1); D.Str(","); D.Int(fingerPrint.public,1); D.Ln END;
w.RawNum(fingerPrint.private); w.RawNum(fingerPrint.public);
variable := type(SyntaxTree.RecordType).recordScope.firstVariable;
WHILE variable # NIL DO
IF variable.access * SyntaxTree.Public # {} THEN
fingerPrint := fingerprinter.SymbolFP(variable);
w.RawNum(fingerPrint.shallow);
ExportType(variable.type);
INC(count);
END;
variable := variable.nextVariable;
END;
procedure := type(SyntaxTree.RecordType).recordScope.firstProcedure;
WHILE procedure # NIL DO
IF (procedure.access * SyntaxTree.Public # {}) & ~(procedure.isInline) THEN
fingerPrint := fingerprinter.SymbolFP(procedure);
w.RawNum(fingerPrint.shallow);
INC(count);
END;
procedure := procedure.nextProcedure;
END;
IF count # 0 THEN RawLIntAt(countPos,count+2) END;
w.Char(ofEUEnd);
END;
END;
END ExportType;
PROCEDURE SymbolOffset(symbol: SyntaxTree.Symbol): LONGINT;
VAR s: Section; name: SyntaxTree.IdentifierString;
BEGIN
IF (symbol IS SyntaxTree.Procedure) & (symbol(SyntaxTree.Procedure).isInline) THEN
RETURN 0
END;
symbol.GetName(name);
s := symbols.BySymbol(symbol);
ASSERT(s#NIL);
RETURN (s.offset);
END SymbolOffset;
PROCEDURE ExportSymbol(symbol: SyntaxTree.Symbol; offset: LONGINT;CONST prefix: ARRAY OF CHAR);
VAR fingerPrint: SyntaxTree.FingerPrint; fp: LONGINT;
BEGIN
fingerPrint := fingerprinter.SymbolFP(symbol);
fp := fingerPrint.shallow;
w.RawNum(fp);
w.RawNum(offset );
IF Trace THEN
symbol.GetName(name);
D.Str("FoxObjectFile.Exports.ExportSymbol ");
IF prefix # "" THEN D.Str(prefix); D.Str(".") END;
D.Str(name);
D.Str(" : ");
D.Hex(fp,-8); D.Ln;
END;
END ExportSymbol;
PROCEDURE ExportMethods(typeDeclaration: SyntaxTree.TypeDeclaration);
VAR name: SyntaxTree.IdentifierString; type: SyntaxTree.Type; fingerPrint: SyntaxTree.FingerPrint; initialType: SyntaxTree.Type;
BEGIN
type := typeDeclaration.declaredType;
typeDeclaration.GetName(name);
type := type.resolved; initialType := type;
WHILE (type IS SyntaxTree.PointerType) OR (type IS SyntaxTree.ArrayType) OR (type IS SyntaxTree.MathArrayType) DO
IF type IS SyntaxTree.PointerType THEN
type := type(SyntaxTree.PointerType).pointerBase.resolved;
ELSIF type IS SyntaxTree.ArrayType THEN
type := type(SyntaxTree.ArrayType).arrayBase.resolved;
ELSE
type := type(SyntaxTree.MathArrayType).arrayBase.resolved;
END;
IF type = initialType THEN RETURN END;
END;
IF (type IS SyntaxTree.RecordType) & (type(SyntaxTree.RecordType).recordScope.ownerModule = module.module) THEN
fingerPrint := fingerprinter.TypeFP(type);
procedure := type(SyntaxTree.RecordType).recordScope.firstProcedure;
WHILE procedure # NIL DO
IF (procedure.access * SyntaxTree.Public # {}) THEN
ExportSymbol(procedure,SymbolOffset(procedure),name);
INC(numberExports);
END;
procedure := procedure.nextProcedure;
END;
END;
END ExportMethods;
BEGIN
w.Char(88X);
numberExports := 0; typeNumber := 0;
numberExportsPosition := w.Pos();
w.RawLInt(numberExports);
constant := moduleScope.firstConstant;
WHILE constant # NIL DO
IF (constant.access * SyntaxTree.Public # {}) THEN
IF Trace THEN
constant.GetName(name);
D.String("Constant:"); D.String(name); D.Ln;
END;
IF (~(constant.type IS SyntaxTree.BasicType)) THEN
ExportSymbol(constant,SymbolOffset(constant),"");
ELSE
ExportSymbol(constant,0,"")
END;
INC(numberExports);
END;
constant := constant.nextConstant;
END;
variable := moduleScope.firstVariable;
WHILE variable # NIL DO
IF variable.access * SyntaxTree.Public # {} THEN
IF Trace THEN
variable.GetName(name);
D.String("Variable:"); D.String(name); D.Ln;
END;
ExportSymbol(variable,SymbolOffset(variable),"");
ExportType(variable.type);
INC(numberExports);
END;
variable := variable.nextVariable;
END;
typeDeclaration := moduleScope.firstTypeDeclaration;
WHILE typeDeclaration # NIL DO
IF TRUE THEN
IF Trace THEN
typeDeclaration.GetName(name);
D.String("TypeDeclaration:"); D.String(name); D.Ln;
END;
ExportSymbol(typeDeclaration,0,"");
ExportType(typeDeclaration.declaredType);
INC(numberExports);
END;
typeDeclaration := typeDeclaration.nextTypeDeclaration
END;
procedure := moduleScope.firstProcedure;
WHILE procedure # NIL DO
IF (procedure.access* SyntaxTree.Public # {}) THEN
IF Trace THEN
procedure.GetName(name);
D.String("Procedure:"); D.String(name); D.Ln;
END;
ExportSymbol(procedure,SymbolOffset(procedure),"");
INC(numberExports);
END;
procedure := procedure.nextProcedure;
END;
typeDeclaration := moduleScope.firstTypeDeclaration;
WHILE typeDeclaration # NIL DO
IF typeDeclaration.access * SyntaxTree.Public # {} THEN
ExportMethods(typeDeclaration);
END;
typeDeclaration := typeDeclaration.nextTypeDeclaration
END;
RawLIntAt(numberExportsPosition,numberExports);
w.Char(0X);
END Exports;
PROCEDURE Code;
VAR i: LONGINT;
BEGIN
w.Char(89X);
FOR i := 0 TO ((codeSize-1) ) DO
w.Char(code[i]);
crc32.Char(code[i]);
END;
END Code;
PROCEDURE Use;
VAR import: SyntaxTree.Import; name: SyntaxTree.IdentifierString; importedModule: SyntaxTree.Module; s: Section;
constant: SyntaxTree.Constant; variable: SyntaxTree.Variable; typeDeclaration: SyntaxTree.TypeDeclaration; procedure: SyntaxTree.Procedure;
type: SyntaxTree.Type;fixup: Fixup; fixups: LONGINT; sym: Section;
PROCEDURE UseEntry(module: SyntaxTree.Module; symbol: SyntaxTree.Symbol; offsetInBytes: LONGINT; CONST prefix: ARRAY OF CHAR);
VAR name,suffix: Basic.SectionName; fingerPrint: SyntaxTree.FingerPrint; fp: LONGINT;
BEGIN
symbol.GetName(suffix);
IF prefix # "" THEN
COPY(prefix,name); Strings.Append(name,"."); Strings.Append(name,suffix);
ELSE
name := suffix;
END;
fingerPrint := fingerprinter.SymbolFP(symbol);
fp := fingerPrint.shallow;
w.RawNum(fp);
IF Trace THEN
D.Str("FoxObjectFile.Use ");
D.Str(suffix);
D.Str(" : "); D.Hex(SYSTEM.VAL(LONGINT,symbol),-8); D.Str(" : ");
D.Hex(fp,-8);
D.String(" @ ");
D.Int(offsetInBytes-ofEUProcFlag,1);
D.Ln;
END;
w.RawString(name);
w.RawNum(offsetInBytes);
END UseEntry;
PROCEDURE UseType(type: SyntaxTree.Type);
VAR t: Section; fingerPrint: SyntaxTree.FingerPrint; name: SyntaxTree.IdentifierString;
BEGIN
type := type.resolved;
LOOP
IF type IS SyntaxTree.PointerType THEN type := type(SyntaxTree.PointerType).pointerBase.resolved;
ELSIF type IS SyntaxTree.ArrayType THEN type := type(SyntaxTree.ArrayType).arrayBase.resolved;
ELSIF type IS SyntaxTree.MathArrayType THEN type := type(SyntaxTree.MathArrayType).arrayBase.resolved;
ELSE EXIT
END;
END;
IF type IS SyntaxTree.RecordType THEN
WITH type: SyntaxTree.RecordType DO
type.typeDeclaration.GetName(name);
IF type.recordScope.ownerModule = importedModule THEN
IF Trace THEN D.Str("UseTypeFP:"); D.Str(name); D.Str("?"); D.Ln END;
t := symbols.BySymbol(type.typeDeclaration);
IF (t # NIL) & (t.referenced) THEN
fingerPrint := fingerprinter.TypeFP(type);
w.Char(ofEURecord);
w.RawNum(-(t.offset ));
IF Trace THEN D.Str("UseTypeFP:"); D.Str(name); D.Str(":"); D.Int(fingerPrint.public,1); D.Ln END;
w.RawNum(fingerPrint.public);
w.RawString("@");
w.Char(ofEUEnd);
END;
ELSE
END
END
END
END UseType;
PROCEDURE UseMethods(typeDeclaration: SyntaxTree.TypeDeclaration);
VAR procedure: SyntaxTree.Procedure; sym: Section; prefix: SyntaxTree.IdentifierString; fingerPrint: SyntaxTree.FingerPrint; type: SyntaxTree.Type;
fixup: Fixup; fixups: LONGINT;
BEGIN
typeDeclaration.GetName(prefix);
type := typeDeclaration.declaredType.resolved;
LOOP
IF type IS SyntaxTree.PointerType THEN type := type(SyntaxTree.PointerType).pointerBase.resolved;
ELSE EXIT
END;
END;
IF (type IS SyntaxTree.RecordType) & (type.scope.ownerModule = importedModule) THEN
fingerPrint := fingerprinter.TypeFP(type);
procedure := type(SyntaxTree.RecordType).recordScope.firstProcedure;
WHILE procedure # NIL DO
sym := importedSymbols.BySymbol(procedure);
IF sym # NIL THEN
fixup := sym.fixups;
UseEntry(importedModule,procedure,(fixup.fixupSection.offset + fixup.fixup.offset )+ofEUProcFlag,prefix);
END;
procedure := procedure.nextProcedure
END
END
END UseMethods;
BEGIN
w.Char(08AX);
import := moduleScope.firstImport;
WHILE(import # NIL) DO
IF (import.module # module.system.systemModule[import.module.case]) & IsFirstOccurence(import) THEN
importedModule := import.module;
ASSERT(importedModule # NIL);
ASSERT(importedModule # module.system.systemModule[0]);
ASSERT(importedModule # module.system.systemModule[1]);
Global.ModuleFileName(import.module.name,import.module.context,name);
w.RawString(name);
IF Trace THEN
D.Str("Use module : "); D.Str(name); D.Ln;
END;
constant := importedModule.moduleScope.firstConstant;
WHILE constant # NIL DO
sym := importedSymbols.BySymbol(constant);
IF sym # NIL THEN UseEntry(importedModule,constant,0,"") END;
constant := constant.nextConstant
END;
variable := importedModule.moduleScope.firstVariable;
WHILE variable # NIL DO
sym := importedSymbols.BySymbol(variable);
IF sym # NIL THEN
UseEntry(importedModule,variable,sym.entryNumber,"");
UseType(variable.type);
END;
variable := variable.nextVariable
END;
typeDeclaration := importedModule.moduleScope.firstTypeDeclaration;
WHILE typeDeclaration # NIL DO
type := typeDeclaration.declaredType;
IF type IS SyntaxTree.PointerType THEN type := type(SyntaxTree.PointerType).pointerBase END;
sym := symbols.BySymbol(typeDeclaration);
IF (sym # NIL) & (sym.referenced) THEN
UseEntry(importedModule,typeDeclaration,0,"");
UseType(typeDeclaration.declaredType);
END;
typeDeclaration := typeDeclaration.nextTypeDeclaration
END;
procedure := importedModule.moduleScope.firstProcedure;
WHILE procedure # NIL DO
IF ~procedure.isInline THEN
sym := importedSymbols.BySymbol(procedure);
IF sym # NIL THEN
fixup := sym.fixups;
UseEntry(importedModule,procedure,(fixup.fixupSection.offset + fixup.fixup.offset )+ofEUProcFlag,"");
END;
END;
procedure := procedure.nextProcedure
END;
typeDeclaration := importedModule.moduleScope.firstTypeDeclaration;
WHILE typeDeclaration # NIL DO
IF ~(typeDeclaration.declaredType IS SyntaxTree.QualifiedType) THEN
UseMethods(typeDeclaration);
END;
typeDeclaration := typeDeclaration.nextTypeDeclaration
END;
w.Char(0X);
END;
import := import.nextImport;
END;
w.Char(0X);
END Use;
PROCEDURE WriteType(d:Section; type: SyntaxTree.RecordType; VAR tdSize: LONGINT );
CONST MaxTags = 16;
VAR
tdSizePos, oldmth,newmeth: LONGINT; base: SyntaxTree.RecordType;
name: SyntaxTree.IdentifierString;
baseModule: LONGINT; baseEntry: LONGINT;
upperPartTdSize, lowerPartTdSize: LONGINT;
size: LONGINT;
numberPointersPosition: LONGINT;
numberPointers: LONGINT;
destination: Section;
procedure: Section;
fp: SyntaxTree.FingerPrint;
m: SyntaxTree.Procedure;
i: LONGINT;
typeDeclaration: SyntaxTree.TypeDeclaration;
BEGIN
name := "@@";
ASSERT(type.typeDeclaration # NIL);
type.typeDeclaration.GetName(name);
size := module.system.AlignedSizeOf(type) DIV 8;
w.RawNum(size );
w.RawNum((d.offset ));
base := type.GetBaseRecord();
IF (base = NIL) THEN
oldmth := 0;
baseModule := -1;
baseEntry := -1
ELSE
baseModule := 0;
IF (base.typeDeclaration # NIL) & (base.typeDeclaration.scope # NIL) & (base.typeDeclaration.scope.ownerModule # moduleScope.ownerModule) THEN
baseModule := ModuleNumber(base.typeDeclaration.scope.ownerModule);
typeDeclaration := base.typeDeclaration;
ASSERT(baseModule # 0);
ELSE
typeDeclaration := NIL;
END;
IF baseModule = 0 THEN
destination := symbols.BySymbol(base.typeDeclaration);
ASSERT(destination # NIL);
baseEntry := (destination.offset );
ELSIF (typeDeclaration # NIL) THEN
fp := fingerprinter.SymbolFP(typeDeclaration);
baseEntry := fp.shallow;
ELSE
HALT(100);
END;
oldmth := base.recordScope.numberMethods;
END;
w.RawNum(baseModule);
w.RawNum(baseEntry);
newmeth := 0;
m := type.recordScope.firstProcedure;
WHILE (m# NIL) DO
INC(newmeth);
m := m.nextProcedure;
END;
IF type.IsProtected() THEN
w.RawNum(-type.recordScope.numberMethods);
ELSE
w.RawNum(type.recordScope.numberMethods);
END;
w.RawNum(oldmth);
w.RawNum(newmeth);
numberPointersPosition:= w.Pos();
w.RawLInt(0);
w.RawString(name);
tdSizePos := w.Pos();
w.RawLInt(0);
i := 0;
m := type.recordScope.firstProcedure;
WHILE (m#NIL) DO
IF ~(m.isInline) THEN
procedure := symbols.BySymbol(m);
ASSERT(procedure # NIL);
m.GetName(name);
w.RawNum(procedure.symbol(SyntaxTree.Procedure).methodNumber);
w.RawNum(procedure.entryNumber);
INC(i);
END;
m := m.nextProcedure;
END;
numberPointers := 0;
IF Trace THEN D.Str("pointers of type: "); D.Ln; END;
OutPointers(0, type, numberPointers);
IF numberPointers # 0 THEN RawLIntAt(numberPointersPosition,numberPointers) END;
upperPartTdSize := module.system.addressSize DIV 8 * (MaxTags + type.recordScope.numberMethods + 1 + 1);
lowerPartTdSize := module.system.addressSize DIV 8 * (2 + (4 + numberPointers) + 1);
tdSize := upperPartTdSize + lowerPartTdSize;
RawLIntAt(tdSizePos, tdSize) ;
END WriteType;
PROCEDURE Types;
VAR
t: Section; tdSize, i: LONGINT;
typeDeclaration: SyntaxTree.TypeDeclaration; type: SyntaxTree.Type;
name: ARRAY 256 OF CHAR;
BEGIN
w.Char(08BX);
numberTypes := 0; typeDescSize := 0;
FOR i := 0 TO symbols.Length() - 1 DO
t := symbols.GetSection(i);
IF (t.symbol # NIL) & (t.symbol IS SyntaxTree.TypeDeclaration) THEN
typeDeclaration := t.symbol(SyntaxTree.TypeDeclaration);
type := typeDeclaration.declaredType;
typeDeclaration.GetName(name);
IF type IS SyntaxTree.PointerType THEN
IF type(SyntaxTree.PointerType).pointerBase.resolved.typeDeclaration = typeDeclaration THEN
type := type(SyntaxTree.PointerType).pointerBase.resolved;
END;
END;
IF Trace THEN D.Str("FoxObjectFile.Types: "); D.String(name); D.Ln; END;
IF (type IS SyntaxTree.RecordType) & (type(SyntaxTree.RecordType).recordScope.ownerModule = moduleScope.ownerModule) OR (type(SyntaxTree.RecordType).recordScope.ownerModule = NIL) THEN
t := symbols.BySymbol(type.typeDeclaration);
ASSERT(t # NIL);
WriteType(t,type(SyntaxTree.RecordType),tdSize);
INC(typeDescSize,tdSize);
INC(numberTypes);
END;
END
END
END Types;
PROCEDURE ExceptionTable;
VAR
p: Section; pcFrom, pcTo, pcHandler, i: LONGINT;
binarySection: BinaryCode.Section;
BEGIN
exTableLen := 0;
w.Char(08EX);
FOR i := 0 TO symbols.Length() - 1 DO
p := symbols.GetSection(i);
IF (p.type = Sections.CodeSection) OR (p.type= Sections.BodyCodeSection) THEN
binarySection := p.resolved;
IF binarySection.finally >= 0 THEN
pcFrom := p.offset;
pcTo := binarySection.finally+pcFrom;
pcHandler := binarySection.finally+pcFrom;
w.Char(0FEX);
w.RawNum(pcFrom);
w.RawNum(pcTo);
w.RawNum(pcHandler);
INC(exTableLen);
END;
END
END;
END ExceptionTable;
PROCEDURE PtrsInProcBlock;
VAR
i, counter: LONGINT; destination: Section;
PROCEDURE PointerOffsets(destination : Section);
VAR
numberPointers,numberPointersPos: LONGINT; procedure: SyntaxTree.Procedure; procedureType: SyntaxTree.ProcedureType;
variable: SyntaxTree.Variable; parameter: SyntaxTree.Parameter;
BEGIN
w.RawNum((destination.offset ));
w.RawNum(destination.offset+destination.resolved.validPAFEnter);
w.RawNum(destination.offset+destination.resolved.validPAFExit);
numberPointers := 0;
numberPointersPos := w.Pos();
w.RawLInt(0);
procedure := destination.symbol(SyntaxTree.Procedure);
procedureType := procedure.type(SyntaxTree.ProcedureType);
variable := procedure.procedureScope.firstVariable;
WHILE(variable # NIL) DO
OutPointers(variable.offsetInBits DIV 8,variable.type,numberPointers);
variable := variable.nextVariable
END;
parameter := procedureType.firstParameter;
WHILE(parameter # NIL) DO
OutPointers(parameter.offsetInBits DIV 8,parameter.type,numberPointers);
parameter := parameter.nextParameter;
END;
RawLIntAt(numberPointersPos,numberPointers);
IF numberPointers > maxPtrs THEN
maxPtrs := numberPointers
END;
END PointerOffsets;
BEGIN
w.Char(08FX);
IF Trace THEN D.Str("FoxObjectFile.PtrsInProcBlock"); D.Ln; END;
maxPtrs := 0;
counter := 0;
FOR i := 0 TO symbols.Length() - 1 DO
destination := symbols.GetSection(i);
IF (destination.type # Sections.InitCodeSection) & (destination.symbol # NIL) & (destination.symbol IS SyntaxTree.Procedure) & ~destination.symbol(SyntaxTree.Procedure).isInline THEN
IF Trace THEN D.Str("pointers in "); Basic.WriteSegmentedName(D.Log,destination.name); D.Ln END;
PointerOffsets(destination);
INC(counter);
END
END;
numberProcs := counter;
END PtrsInProcBlock;
PROCEDURE References;
CONST
rfDirect = 1X; rfIndirect = 3X;
rfStaticArray= 12X; rfDynamicArray=14X; rfOpenArray=15X;
rfByte = 1X; rfBoolean = 2X; rfChar8=3X; rfShortint=04X; rfInteger = 05X; rfLongint = 06X;
rfReal = 07X; rfLongreal = 08X; rfSet = 09X; rfDelegate = 0EX; rfString = 0FH; rfPointer = 0DX; rfHugeint = 10X;
rfChar16=11X; rfChar32=12X; rfAll=13X; rfSame=14X; rfRange=15X; rfRecord=16X; rfComplex = 17X; rfLongcomplex = 18X;
rfRecordPointer=1DX;
rfArrayFlag = 80X;
VAR
start, i: LONGINT; s: Section;
PROCEDURE BaseType(type: SyntaxTree.Type): CHAR;
VAR char: CHAR;
BEGIN
IF type = NIL THEN char := rfLongint
ELSIF type IS SyntaxTree.ByteType THEN char := rfByte
ELSIF type IS SyntaxTree.BooleanType THEN char := rfBoolean
ELSIF type IS SyntaxTree.CharacterType THEN
IF type.sizeInBits = 8 THEN char := rfChar8
ELSIF type.sizeInBits = 16 THEN char := rfChar16
ELSIF type.sizeInBits = 32 THEN char := rfChar32
END;
ELSIF (type IS SyntaxTree.IntegerType) OR (type IS SyntaxTree.AddressType) OR (type IS SyntaxTree.SizeType) THEN
IF type.sizeInBits = 8 THEN char := rfShortint
ELSIF type.sizeInBits = 16 THEN char := rfInteger
ELSIF type.sizeInBits = 32 THEN char := rfLongint
ELSIF type.sizeInBits =64 THEN char := rfHugeint
END;
ELSIF type IS SyntaxTree.SizeType THEN char := rfLongint
ELSIF type IS SyntaxTree.FloatType THEN
IF type.sizeInBits = 32 THEN char := rfReal
ELSIF type.sizeInBits = 64 THEN char := rfLongreal
END;
ELSIF type IS SyntaxTree.ComplexType THEN
IF type.sizeInBits = 64 THEN char := rfComplex
ELSIF type.sizeInBits = 128 THEN char := rfLongcomplex
END;
ELSIF type IS SyntaxTree.SetType THEN char := rfSet
ELSIF type IS SyntaxTree.AnyType THEN char := rfPointer
ELSIF type IS SyntaxTree.ObjectType THEN char := rfPointer
ELSIF type IS SyntaxTree.PointerType THEN char := rfPointer
ELSIF type IS SyntaxTree.ProcedureType THEN char := rfDelegate
ELSIF type IS SyntaxTree.RangeType THEN char := rfRange
ELSE char := rfShortint;
END;
RETURN char
END BaseType;
PROCEDURE RecordType(type: SyntaxTree.RecordType);
VAR destination: Section; name: SyntaxTree.IdentifierString;
BEGIN
destination := symbols.BySymbol(type.typeDeclaration);
IF destination = NIL THEN destination := importedSymbols.BySymbol(type.typeDeclaration) END;
IF destination = NIL THEN
w.Char(0X);
type.typeDeclaration.GetName(name);
ELSE
IF type.pointerType # NIL THEN
w.Char(rfRecordPointer)
ELSE
w.Char(rfRecord);
END;
w.RawNum((destination.offset ));
END;
END RecordType;
PROCEDURE StaticArrayLength(type: SyntaxTree.ArrayType; VAR baseType: SyntaxTree.Type): LONGINT;
BEGIN
baseType := type.arrayBase.resolved;
IF type.form = SyntaxTree.Static THEN
IF baseType IS SyntaxTree.ArrayType THEN
RETURN type.staticLength * StaticArrayLength(baseType(SyntaxTree.ArrayType),baseType)
ELSE
RETURN type.staticLength
END
ELSE
RETURN 0
END;
END StaticArrayLength;
PROCEDURE ArrayType(type: SyntaxTree.ArrayType);
VAR length: LONGINT; baseType: SyntaxTree.Type; char: CHAR;
BEGIN
length := StaticArrayLength(type, baseType);
char := BaseType(baseType);
IF type.form # SyntaxTree.Open THEN
w.Char(CHR(ORD(char)+ORD(rfArrayFlag)));
w.RawNum(length)
ELSE
length :=0;
w.Char(CHR(ORD(char)+ORD(rfArrayFlag)));
w.RawNum(length)
END;
END ArrayType;
PROCEDURE StaticMathArrayLength(type: SyntaxTree.MathArrayType; VAR baseType: SyntaxTree.Type): LONGINT;
BEGIN
baseType := type.arrayBase;
IF baseType # NIL THEN
baseType := baseType.resolved;
END;
IF type.form = SyntaxTree.Static THEN
IF (baseType # NIL) & (baseType IS SyntaxTree.MathArrayType) THEN
RETURN type.staticLength * StaticMathArrayLength(baseType(SyntaxTree.MathArrayType),baseType)
ELSE
RETURN type.staticLength
END
ELSE
RETURN 0
END;
END StaticMathArrayLength;
PROCEDURE MathArrayType(type: SyntaxTree.MathArrayType);
VAR length: LONGINT; baseType: SyntaxTree.Type; char: CHAR;
BEGIN
length := StaticMathArrayLength(type, baseType);
char := BaseType(baseType);
IF type.form = SyntaxTree.Open THEN
char := BaseType(module.system.addressType);
length := 5+2*SemanticChecker.Dimension(type,{SyntaxTree.Open});
w.Char(CHR(ORD(char)+ORD(rfArrayFlag)));
w.RawNum(length)
ELSIF type.form=SyntaxTree.Tensor THEN
char := BaseType(module.system.addressType);
w.Char(CHR(ORD(char)));
ELSE
w.Char(CHR(ORD(char)+ORD(rfArrayFlag)));
w.RawNum(length)
END;
END MathArrayType;
PROCEDURE Type(type: SyntaxTree.Type);
BEGIN
IF type = NIL THEN w.Char(0X); RETURN ELSE type := type.resolved END;
IF type IS SyntaxTree.BasicType THEN
w.Char(BaseType(type))
ELSIF type IS SyntaxTree.RecordType THEN
RecordType(type(SyntaxTree.RecordType));
ELSIF type IS SyntaxTree.ArrayType THEN
ArrayType(type(SyntaxTree.ArrayType))
ELSIF type IS SyntaxTree.EnumerationType THEN
w.Char(BaseType(module.system.longintType))
ELSIF type IS SyntaxTree.PointerType THEN
IF type(SyntaxTree.PointerType).pointerBase IS SyntaxTree.RecordType THEN
RecordType(type(SyntaxTree.PointerType).pointerBase(SyntaxTree.RecordType));
ELSE
w.Char(BaseType(type))
END;
ELSIF type IS SyntaxTree.ProcedureType THEN
w.Char(BaseType(type));
ELSIF type IS SyntaxTree.MathArrayType THEN
MathArrayType(type(SyntaxTree.MathArrayType));
ELSE HALT(200)
END;
END Type;
PROCEDURE WriteVariable(variable: SyntaxTree.Variable; indirect: BOOLEAN);
VAR name: ARRAY 256 OF CHAR;
BEGIN
IF indirect THEN w.Char(rfIndirect) ELSE w.Char(rfDirect) END;
variable.GetName(name);
Type(variable.type);
w.RawNum((variable.offsetInBits DIV 8));
w.RawString(name);
END WriteVariable;
PROCEDURE WriteParameter(variable: SyntaxTree.Parameter; indirect: BOOLEAN);
VAR name: ARRAY 256 OF CHAR;
BEGIN
IF indirect THEN w.Char(rfIndirect) ELSE w.Char(rfDirect) END;
variable.GetName(name);
Type(variable.type);
w.RawNum((variable.offsetInBits DIV 8));
variable.GetName(name);
w.RawString(name);
END WriteParameter;
PROCEDURE ReturnType(type: SyntaxTree.Type);
BEGIN
IF type = NIL THEN w.Char(0X); RETURN ELSE type := type.resolved END;
IF type IS SyntaxTree.ArrayType THEN
WITH type: SyntaxTree.ArrayType DO
IF type.form = SyntaxTree.Static THEN w.Char(rfStaticArray)
ELSE w.Char(rfOpenArray)
END
END
ELSIF type IS SyntaxTree.MathArrayType THEN
WITH type: SyntaxTree.MathArrayType DO
IF type.form = SyntaxTree.Static THEN w.Char(rfStaticArray)
ELSE w.Char(rfOpenArray)
END
END
ELSIF type IS SyntaxTree.RecordType THEN
w.Char(rfRecord);
ELSE
w.Char(BaseType(type));
END;
END ReturnType;
PROCEDURE DeclarationName(typeDeclaration: SyntaxTree.TypeDeclaration; VAR name: ARRAY OF CHAR);
BEGIN
IF typeDeclaration = NIL THEN COPY("@ANONYMOUS",name)
ELSE typeDeclaration.GetName(name)
END;
END DeclarationName;
PROCEDURE Procedure(s: Section);
VAR procedure: SyntaxTree.Procedure; procedureType: SyntaxTree.ProcedureType;
parameter: SyntaxTree.Parameter; variable: SyntaxTree.Variable;
name,recordName: ARRAY 256 OF CHAR;
record: SyntaxTree.RecordType; i: LONGINT;
BEGIN
procedure := s.symbol(SyntaxTree.Procedure);
Global.GetSymbolNameInScope(procedure,moduleScope,name);
procedureType := procedure.type(SyntaxTree.ProcedureType);
w.Char(0F9X);
w.RawNum((s.offset ));
w.RawNum(procedureType.numberParameters);
ReturnType(procedureType.returnType);
w.RawNum(0);
w.RawNum(0);
w.RawString(name);
parameter := procedureType.firstParameter;
WHILE(parameter # NIL) DO
WriteParameter(parameter,parameter.kind # SyntaxTree.ValueParameter);
parameter := parameter.nextParameter;
END;
variable := procedure.procedureScope.firstVariable;
WHILE(variable # NIL) DO
WriteVariable(variable,FALSE);
variable := variable.nextVariable;
END;
END Procedure;
PROCEDURE Scope(s: Section);
VAR variable: SyntaxTree.Variable;
BEGIN
w.Char(0F8X);
w.RawNum((s.offset ));
w.RawString("$$");
variable := moduleScope.firstVariable;
WHILE(variable # NIL) DO
WriteVariable(variable,FALSE);
variable := variable.nextVariable;
END;
END Scope;
BEGIN
start := w.Pos();
w.Char(08CX);
FOR i := 0 TO symbols.Length() - 1 DO
s := symbols.GetSection(i);
IF (s.symbol = moduleScope.bodyProcedure) THEN
Scope(s)
END
END;
FOR i := 0 TO symbols.Length() - 1 DO
s := symbols.GetSection(i);
IF (s.symbol = moduleScope.bodyProcedure) THEN
ELSIF(s.symbol # NIL) & (s.symbol IS SyntaxTree.Procedure) & ~s.symbol(SyntaxTree.Procedure).isInline THEN
Procedure(s)
END
END;
refSize := w.Pos()-start;
END References;
PROCEDURE LinkFixups;
VAR
section: Section; symbol: SyntaxTree.Symbol; fixups, i: LONGINT; fixup: Fixup; bfixup: BinaryCode.Fixup;
PROCEDURE Put32(code: ByteArray; offset: LONGINT; number: LONGINT);
BEGIN
code[offset] := CHR(number MOD 256);
INC(offset); number := number DIV 256;
code[offset] := CHR(number MOD 256);
INC(offset); number := number DIV 256;
code[offset] := CHR(number MOD 256);
INC(offset); number := number DIV 256;
code[offset] := CHR(number MOD 256);
END Put32;
PROCEDURE Link(first: Fixup);
VAR this,prev: LONGINT;fixup: Fixup;
CONST Sentinel = SHORT(0FFFFFFFFH);
BEGIN
fixup := first;
prev := -1;
WHILE fixup # NIL DO
this := (fixup.fixupSection.offset +fixup.fixup.offset );
IF prev # -1 THEN
Put32(code,prev,this);
IF Trace THEN
D.String("link: "); D.Int(prev,1); D.String(":"); D.Int(this,1); D.Ln;
END;
END;
prev := this;
fixup := fixup.nextFixup;
END;
IF prev # -1 THEN
Put32(code,prev,Sentinel);
IF Trace THEN
D.String("link: "); D.Int(prev,1); D.String(":"); D.Int(Sentinel,1); D.Ln;
END;
END;
END Link;
BEGIN
IF Trace THEN D.Str("LinkFixups"); D.Ln; END;
FOR i := 0 TO importedSymbols.Length()-1 DO
section := importedSymbols.GetSection(i);
symbol := section.symbol;
IF (symbol # NIL) & (symbol IS SyntaxTree.Procedure) THEN
Link(section.fixups);
END;
END;
END LinkFixups;
PROCEDURE MakeSections;
VAR i: LONGINT; fixup: BinaryCode.Fixup; section: Sections.Section; symbol: Section;
imported: BOOLEAN;
PROCEDURE Enter(section: Sections.Section; symbols: SectionList; VAR symbol: Section): BOOLEAN;
BEGIN
IF section # NIL THEN
symbol := symbols.AddSection(section.name);
symbol.isCaseTable := section.isCaseTable;
symbol.referenced := section.referenced;
symbol.offset := section.offset;
symbol.type := section.type;
symbol.resolved := section(IntermediateCode.Section).resolved;
IF (section.symbol # NIL) & (symbol.symbol = NIL) THEN
symbol.symbol := section.symbol;
symbols.symbolLookup.Put(symbol.symbol, symbol)
END;
RETURN TRUE
ELSE
RETURN FALSE
END;
END Enter;
BEGIN
NEW(symbols); NEW(importedSymbols);
FOR i := 0 TO module.allSections.Length() - 1 DO
section := module.allSections.GetSection(i);
IF (section.type # Sections.InlineCodeSection) & (section.type # Sections.InitCodeSection) & ~section.isCaseTable THEN
IF Enter(section, symbols,symbol) THEN END;
END;
END;
FOR i := 0 TO module.allSections.Length() - 1 DO
section := module.allSections.GetSection(i);
IF (section.type # Sections.InlineCodeSection) & (section.type # Sections.InitCodeSection) & ~section.isCaseTable THEN
fixup := section(IntermediateCode.Section).resolved.fixupList.firstFixup;
WHILE (fixup # NIL) DO
IF Enter(module.allSections.FindByName(fixup.symbol.name), symbols,symbol) THEN
symbol.AddFixup(fixup, section);
END;
IF Enter(module.importedSections.FindByName(fixup.symbol.name), importedSymbols,symbol) THEN
symbol.AddFixup(fixup, section)
END;
fixup := fixup.nextFixup;
END
END
END;
IF Trace THEN
D.String("imported sections(module) "); D.Ln;
module.importedSections.Dump(D.Log); D.Ln;
D.String("sections(module) "); D.Ln;
module.allSections.Dump(D.Log); D.Ln;
D.String("imported: "); D.Ln; importedSymbols.Dump(D.Log);
D.String("not imported: "); D.Ln; symbols.Dump(D.Log);
D.Ln;
END;
END MakeSections;
BEGIN
MakeSectionOffsets(module,constSize,dataSize,codeSize,caseTableSize,const,code);
MakeSections;
LinkFixups;
IF Trace THEN module.Dump(D.Log);D.Ln; D.Update; END;
NEW(fingerprinter,module.system);
Global.ModuleFileName(module.module.name,module.module.context,moduleName);
NEW(crc32);
IF Trace THEN D.Str("module: "); D.Str(moduleName); D.Ln END;
moduleScope := module.module.moduleScope;
w.Char(ofFileTag);
w.Char(ofNoZeroCompress);
w.Char(ofFileVersion);
SymbolFile;
Header; Entries; Commands; Pointers; Imports; VarConstLinks; Links;
Constants; Exports; Code; Use; Types; ExceptionTable; PtrsInProcBlock; References;
endPos := w.Pos();
w.SetPos(headerPos);
crc := crc32.GetCRC();
Header;
w.SetPos(endPos);
w.Update;
END WriteObjectFile;
PROCEDURE Get*(): Formats.ObjectFileFormat;
VAR objectFileFormat: ObjectFileFormat;
BEGIN NEW(objectFileFormat); RETURN objectFileFormat
END Get;
BEGIN
SysCallMap[CaseTable] := 0FFX;
SysCallMap[ProcAddr] := 0FEX;
SysCallMap[NewRec] := 0FDX;
SysCallMap[NewSys] := 0FCX;
SysCallMap[NewArr] := 0FBX;
SysCallMap[Start] := CHR(250);
SysCallMap[Await] := CHR(249);
SysCallMap[Lock] := CHR(247);
SysCallMap[Unlock] := CHR(246);
SysCallMap[InterfaceLookup] := CHR(245);
SysCallMap[RegisterInterface] := CHR(244);
SysCallMap[GetProcedure] := CHR(243);
END FoxBinaryObjectFile.