MODULE FoxBinaryObjectFile; (** AUTHOR "fof"; PURPOSE "Oberon Compiler Object File Writer"; *) IMPORT Scanner := FoxScanner, Basic := FoxBasic, SyntaxTree := FoxSyntaxTree, Global := FoxGlobal, SemanticChecker := FoxSemanticChecker, FingerPrinter := FoxFingerPrinter, Sections := FoxSections, Streams, D := Debugging, Files, SYSTEM,Strings, BinaryCode := FoxBinaryCode, Log := KernelLog, Diagnostics, SymbolFileFormat := FoxBinarySymbolFile, Options, Formats := FoxFormats, IntermediateCode := FoxIntermediateCode, Machine ; (** Object File Format ObjectFile = ofFileTag ofNoZeroCompression ofFileVersion symbolFileSize:RawLInt SymbolFile Header Entries Commands Pointers Imports VarConstLinks Links Constants Exports Code Use Types ExceptionTable PtrsInProcBlock References. SymbolFile = {Char}:symbolFileSize Header = refSize:RawLInt numberEntries:RawLInt numberCommands:RawLInt numberPointers:RawLInt numberTypes:RawLInt numberImports:RawLInt numberVarConstLinks:RawLInt numberLinks:RawLInt dataSize:RawLInt constSize:RawLInt codeSize:RawLInt exTableLen:RawLInt numberProcs:RawLInt maxPtrs:RawLInt typeDescSize:RawLInt crc:RawLInt moduleName:RawString Entries = 82X:Char { entryOffset:RawNum }:numberEntries Commands = 83X:Char { firstParTypeOfs:RawNum returnTypeOfs:RawNum commandName:RawString cmdOffset:RawNum }:numberCommands Pointers = 84X {pointerOffset:RawNum}:numberPointers Imports = 85X { moduleName:String }:numberImports VarConstLinks = 8DX { VarConstLinkEntry }:numberVarConstLinks VarConstLinkEntry = modNumber:Char entry:RawNum fixupCount:RawLInt { offset:RawNum }:fixupCount Links = 86X {LinkEntry}:numberLinks {fixupCount:RawNum}:numberEntries caseTableSize:RawNum LinkEntry = moduleNumber:Char entryNumber:Char offset:RawNum Constants = 87X {character:Char}:constSize Exports = 88X numberExports:RawLInt {ExportEntry}:numberExpor ExportEntry = fingerPrint:RawNum offset:RawNum [1X ExportType] ExportType = reference<0:RawNum | typeDescriptorOffset:RawNum numberEntries:RawLInt [1X ExportType] {fingerPrint:RawNum [1X ExportType]}:numberEntries 0X Code = 89X {character:Char}:codeSize Use = 08AX {UsedModules} 0X UsedModules = moduleName:RawString {UsedEntry} 0X UsedEntry = fingerPrint:RawNum name:RawString number:RawNum [1X UsedType] UsedType = typeDescOfs:RawNum [fingerPrint:RawNum "@"] 0X Types = 08BX {TypeEntry}:numberTypes TypeEntry = recordSize:RawNum entry:RawNum baseModule:RawNum baseEntry:RawNum methods:RawNum inheritedMethods:RawNum newMethods:RawNum pointers:RawNum name:RawString typeDescriptorSize:RawLInt {method:RawNum entry:RawNum}:newMethods {offset:RawNum}:pointers ExceptionTable = 08EX { ExTableEntry }:exTableLength ExTableEntry = 0FEX pcFrom:RawNum pcTo:RawNum pcHandler:RawNum PtrsInProcs = 08FX {ProcEntry}:numberProcs ProcEntry = codeOfs:RawNum beginOfs:RawNum endOfs:RawNum numberPointers:RawLInt {pointer:RawNum}:numberPointers References = 08CX RSScope { RSProcedure } Scope = 0F8X codeOffset:RawNum "$$" {Variable} Procedure = 0F9X codeOffset:RawNum numberParameters:RawNum ReturnType level:RawNum 0X name:RawString {Parameter} {Variable} ReturnType = 0X | BaseType | rfStaticArray | rfDynamicArray | rfOpenArray | rfRecord Parameter = Variable Variable = VariableMode Type variableOffset:RawNum variableName:RawString VariableMode = rfIndirect | rfDirect Type = BaseType | ArrayType | RecordType BaseType = rfByte | rfSet | rfAny | rfBoolean | rfChar8 | rfChar16 | rfChar32 | rfShortint | rfInteger | rfLongint | rfHugeint | rfReal | rfLongreal | | rfString | rfPointer | rfAll | rfSame | rfRange | rfComplex | rfLongcomplex ArrayType = 80H+BaseType:RawNum dim:RawNum RecordType = (rfRecord | rfRecordPointer) tdAdr:RawNum **) CONST ofFileTag = 0BBX; (* same constants are defined in Linker and Loader *) ofNoZeroCompress = 0ADX; (* do. *) ofFileVersion = SymbolFileFormat.FileVersionCurrent; (* do. *) ofEUEnd = 0X; ofEURecord = 1X; ofEUProcFlag = LONGINT(080000000H); (** system calls *) 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) PROCEDURE & InitObjectFileFormat; BEGIN Init; SetExtension(Machine.DefaultObjectFileExtension); END InitObjectFileFormat; 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); (* IF dump # NIL THEN dump.String("generated file "); dump.String(fileName); dump.Ln; dump.Update; END; *) 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); VAR extension: Files.FileName; BEGIN IF options.GetString("objectFileExtension",extension) THEN SetExtension(extension); END; END GetOptions; PROCEDURE DefaultSymbolFileFormat(): Formats.SymbolFileFormat; BEGIN RETURN SymbolFileFormat.Get(); END DefaultSymbolFileFormat; PROCEDURE ForceModuleBodies(): BOOLEAN; (* necessary in binary object file format as bodies not recognizable later on *) BEGIN RETURN TRUE END ForceModuleBodies; END ObjectFileFormat; Fixup = OBJECT VAR nextFixup: Fixup; fixup: BinaryCode.Fixup; fixupSection: Sections.Section; END Fixup; Section=OBJECT (* proprietary format for this object file format *) VAR name: Basic.SegmentedName; symbol: SyntaxTree.Symbol; entryNumber: LONGINT; offset: LONGINT; fixups: Fixup; (* fixups other way round: who references to this section *) 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); (* SyntaxTree.Symbol _> Symbol *) 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); (* SyntaxTree.Symbol _> Symbol *) 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 GetFixups(module: Sections.Module; symbol: Sections.Section; VAR first: Fixup): LONGINT; VAR temp: Fixup; fixup: BinaryCode.Fixup; nr :LONGINT; (* only regular sections *) PROCEDURE DoSections(sectionList: Sections.SectionList); VAR i: LONGINT; section: Sections.Section; BEGIN FOR i := 0 TO sectionList.Length() - 1 DO section := sectionList.GetSection(i); IF (section.type # Sections.InlineCodeSection) & (section.type # Sections.InitCodeSection) THEN fixup := section(IntermediateCode.Section).resolved.fixupList.firstFixup; WHILE (fixup # NIL) DO IF (fixup.symbol = symbol.name) THEN INC(nr); NEW(temp); temp.fixup := fixup; temp.fixupSection := section; temp.nextFixup := first; first := temp; END; fixup := fixup.nextFixup; END END END; END DoSections; BEGIN first := NIL; nr := 0; DoSections(module.allSections); (* only regular sections *) (* Sections(module.caseTables.first); *) RETURN nr END GetFixups; *) 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; addrSize: LONGINT; (* size of ADDRESS in bytes *) (* PROCEDURE InModule(s: Sections.Section):BOOLEAN; VAR section: Sections.Section; i: LONGINT; BEGIN FOR i := 0 TO module.allSections.Length() - 1 DO section := module.allSections.GetSection(i); IF section = s THEN RETURN TRUE END END; RETURN FALSE END InModule; *) 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; (* remove all fixups from list *) 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 (* relative offset within module *) dest := (symbol.offset + fixup.displacement) - (section.offset + fixup.offset); ASSERT(fixup.symbolOffset = 0); binarySection.PutDWordAt(fixup.offset, dest); (* fixup done, does not need to be put back to list *) ELSIF (fixup.mode = BinaryCode.Absolute) & (symbol # NIL) THEN (* absolute offset within module *) dest := symbol.offset + fixup.displacement; binarySection.PutDWordAt(fixup.offset, dest); binarySection.fixupList.AddFixup(fixup); (* (re-)insert fixup into fixup list *) ELSIF (fixup.mode = BinaryCode.Absolute) THEN (* absolute fixup on imported symbol *) dest := fixup.displacement; binarySection.PutDWordAt(fixup.offset, dest); binarySection.fixupList.AddFixup(fixup); (* (re-)insert fixup into fixup list *) ELSE binarySection.fixupList.AddFixup(fixup); (* keep fixup as is: relative fixup on imported symbol *) 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.os.bits.GetBits(i*8,8)); END; END Copy; (* only regular sections *) 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; (* note: if 'caseSections' is TRUE, only case table sections are processed, otherwise only regular sections (imported symbol/system call sections are never processed) *) 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.os.alignment # 0 THEN INC(constSize,(-constSize) MOD binarySection.os.alignment); END; section.SetOffset(constSize); INC(constSize,binarySection.pc); (* global constants: positive offset *) 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.os.alignment # 0 THEN INC(varSize,(-varSize) MOD binarySection.os.alignment); END; section.SetOffset(-varSize); (* global variables: negative offset *) END END; END; END SetOffsets; (* note: if 'caseSections' is TRUE, only case table sections are processed, otherwise only regular sections (imported symbol/system call sections are never processed) *) 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 addrSize := module.system.addressSize DIV 8; FirstOffsets(module.allSections); (* regular sections *) SetOffsets(module.allSections,FALSE); (* regular sections *) pc := constSize; SetOffsets(module.allSections, TRUE); (* case table sections *) caseTableSize := (constSize -pc) DIV addrSize; FixupSections; NEW(const,constSize ); NEW(code,codeSize ); CopySections(module.allSections); (* regular sections *) 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; addrSize: LONGINT; (* size of ADDRESS in bytes *) symbols, importedSymbols: SectionList; (* list of sections with fixups in the other direction, needed for this particular object file format *) 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; (* write symbol file *) 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()); (* could also be patched later, if length was not known here *) 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; (* Header = refSize:4 numberEntries:4 numberCommands:4 numberPointers:4 numberTypes:4 numberImports:4 numberVarConstLinks:4 numberLinks:4 dataSize:4 constSize:4 codeSize:4 exTableLen:4 numberProcs:4 maxPtrs:4 typeDescSize:4 crc:4 moduleName:String *) 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; (* Entries = 82X {entryOffset}:numberEntries *) 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 = LONGINT(0FFFFFFFFH); PROCEDURE FixupList(l,prev: Fixup; VAR tail: Fixup); (* Insert fixup list into code *) 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); (*debugging*) procedure := p.symbol(SyntaxTree.Procedure); procedureType := procedure.type(SyntaxTree.ProcedureType); (* entry for public procedures and all methods *) 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); (* absolute fixups, relative procedure fixups have already been done during code generation *) 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; (* Commands = 83X {firstParTypeOffset:Num returnParTypeOffset:Num cmdName:String cmdOffset:Num}:numberCommands *) PROCEDURE Commands; VAR procedure : SyntaxTree.Procedure; procedureType: SyntaxTree.ProcedureType; p: Section; name: Name; numberParameters, i: LONGINT; (* Returns TRUE if the built-in function GETPROCEDURE can be used with this procedure type *) 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; (* must be non-nil *) typeDeclaration.GetName(name); section := symbols.BySymbol(type.typeDeclaration); ASSERT(section # NIL); w.RawNum((section.offset )); (* type descriptor 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.PublicWrite 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; (* offset of type of first parameter *) IF (numberParameters = 0 ) THEN WriteType(NIL) ELSE WriteType(procedureType.firstParameter.type) END; (* offset of type of return parameter *) WriteType(procedureType.returnType); (* command name *) w.RawString(name); (* command code offset *) w.RawNum((p.offset )); INC(numberCommands); IF Trace THEN D.Ln END END END END END Commands; (* OutPointers delivers {pointerOffset} *) 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 (* never treat a record like a pointer, even if the pointer field is set! *) 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); (* not more than one million pointers on the stack ... *) 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); (* not more than one million pointers on the stack ... *) 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); (* GC relevant pointer is at offset 0 *) IF Trace THEN D.Str("ptr at offset="); D.Int(offset,1); D.Ln; END; END END; (* ELSE no pointers in type *) END; END OutPointers; (* Pointers = 84X { pointerOffset:Num}:numberPointers *) 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; (*! inefficient *) 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; (* Imports = 85X { moduleName:String }:numberImports *) 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; (*? should this be coded fix in a separate module list ? *) (* Module Number returns the position of a module in the written import list *) 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; (* VarConstLinks = 8DX {VarConstLinkEntry}: numberVarConstLinks VarConstLinkEntry = modNumber:1 entry:Number fixupCount:4 {offset:Number}:fixupCount} *) 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; (* global variables and constants of this module *) w.Char(0X); (* module Number = 0 => this module *) w.RawNum(-1); (* entry = -1 => this module *) fixupsPosition := w.Pos(); fixups := 0; w.RawLInt(fixups); (* number of fixups, to be patche *) 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; (*! can be merged with previous -- for testing consistency *) 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; (* IF Trace THEN D.Str("VarConstLinks:CaseTables"); D.Ln; END; FOR i := 0 TO module.allSections.Length() - 1 DO s := module.allSections.GetSection(i); IF s.kind = Sections.CaseTableKind THEN IF (s.symbol # NIL) & ~(s.symbol IS SyntaxTree.Procedure) THEN (* includes case symbol! *) temp := GetFixups(module,s,fixup); Fixups(fixup); END END END; *) RawLIntAt(fixupsPosition,fixups); (* fixups count patched *) INC(numberVarConstLinks); IF Trace THEN D.Str("VarConstLinks:ImportedSymbols"); D.Ln; END; (* imported global variables and constants *) 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); (* entry = 0 => importing module *) w.RawLInt(sym.numberFixups); (* number of fixups, to be patched *) Fixups(sym.fixups); END; END; END VarConstLinks; (* Links = 86X {LinkEntry:Number}:numberLinks {FixupCount:Number}:numberEntries caseTableSize:Number LinkEntry = moduleNumber:1 entryNumber:1 offset:Number *) PROCEDURE Links; VAR p: Section; procedure: SyntaxTree.Procedure; procedureType: SyntaxTree.ProcedureType; i, counter: LONGINT; temp: LONGINT; fixup: Fixup; fixups: LONGINT; CONST FixupSentinel = LONGINT(0FFFFFFFFH); (* Insert fixup list into code *) 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; (* system call sections removed: replaced by procedure calls *) 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*addrSize) ); INC(numberLinks); (* case table is fixuped by the loader using offset of case table in constant section it is impossible to have disjoint case tables here *) END; counter := 0; (* cf. Entries *) 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; (* Constants = 87X {character:1} *) 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; (* Exports *) 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; (* no type *) type := type.resolved; (* fof: thjs can cause a repetitive entry of the same type *) 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; (* avoid cycles *) 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; (* number of exported entries *) INC(typeNumber); (* reference number to this type *) 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); (* ASSERT(fingerPrint.privateFP # 0); (* may not be zero by object file format: would be interpreted as end of section *) ASSERT(fingerPrint.publicFP # 0); (* ^ ^ *) *) 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); (* debugging *) s := symbols.BySymbol(symbol); (* TODO *) 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; (* IF prefix # "" THEN (* make unique by object name prefix *) FingerPrint.FPString(fp,prefix) END; *) w.RawNum(fp); (*! check for duplicate fingerprint *) 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; (* avoid circles *) END; IF (type IS SyntaxTree.RecordType) & (type(SyntaxTree.RecordType).recordScope.ownerModule = module.module) THEN fingerPrint := fingerprinter.TypeFP(type); (* make sure that fingerprint has traversed all methods ... *) 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); (*! in the end anything that has an offset should be present in the BackendStructures.Module, therefore the list can also be traverse from the respective Backend structure *) (* constants *) 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; (* global variables *) 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; (* type declarations *) typeDeclaration := moduleScope.firstTypeDeclaration; WHILE typeDeclaration # NIL DO IF TRUE (* typeDeclaration.access * SyntaxTree.Public # {} *) 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; (* exported procedures *) 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; (* exported methods *) 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; (* Code = 89X {character:1} *) 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; (* Use = 08AX {UsedModules} 0X UsedModules = moduleName:String {UsedConstant | UsedVariable | UsedProcedure | UsedType } 0X UsedConstant = FP:Number constName:String 0X UsedVariable = FP:Number varName:String fixlist:Number [1X UsedRecord] UsedProcedure = FP:Number procName:String offset:Number UsedType = FP:Number typeName:String 0X [1X UsedRecord] UsedRecord = tdentry:Number [FP "@"] 0X *) 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; (* IF prefix # "" THEN FingerPrint.FPString(fp,prefix) END; *) 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); (* debugging *) IF type.recordScope.ownerModule = importedModule THEN (* type belongs to currently processed module *) IF Trace THEN D.Str("UseTypeFP:"); D.Str(name); D.Str("?"); D.Ln END; t := symbols.BySymbol(type.typeDeclaration); (* TODO *) IF (t # NIL) & (t.referenced) (*(t.fixups # NIL)*) THEN t.referenced := FALSE; fingerPrint := fingerprinter.TypeFP(type); w.Char(ofEURecord); w.RawNum(-(t.offset )); (* privateFP never set in old compiler *) 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 (* nothing to be done? => module must be added to import section, this must be done by the semantic checker *) 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; (*!???? => problems with name prefix. Necessary to treat arrays here? 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) & (type.scope.ownerModule = importedModule) (* do not take alias *) THEN fingerPrint := fingerprinter.TypeFP(type); (* make sure that type is fingerprinted including all methods *) 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 (*! in a new object file this would not necessarily be ordered by imports (?) *) 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); (* only if has been used -- contained in module sections: alias *) 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) (* alias *) 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 (* ug *)); CONST MaxTags = 16; (* ug: temporary solution, Modules.MaxTags *) 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 )); (* type descriptor pointer address, patched by loader to type desciptor address *) base := type.GetBaseRecord(); IF (base = NIL) THEN (* no base type *) oldmth := 0; baseModule := -1; baseEntry := -1 ELSE baseModule := 0; (* base type in local module *) IF (base.typeDeclaration # NIL) & (base.typeDeclaration.scope # NIL) & (base.typeDeclaration.scope.ownerModule # moduleScope.ownerModule) THEN (* base type in other module *) 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); (*TODO*) ASSERT(destination # NIL); baseEntry := (destination.offset ); (* destination must be non-nil *) ELSIF (typeDeclaration # NIL) THEN fp := fingerprinter.SymbolFP(typeDeclaration); baseEntry := fp.shallow; ELSE HALT(100); (* ELSE base := base(SyntaxTree.PointerType).pointerBase; fp := fingerprinter.SymbolFP(base.typeDeclaration); baseEntry := fp.FP; *) END; oldmth := base.recordScope.numberMethods; END; w.RawNum(baseModule); w.RawNum(baseEntry); newmeth := 0; m := type.recordScope.firstProcedure; WHILE (m# NIL) DO INC(newmeth); (*! check that this is not an inline procedure *) m := m.nextProcedure; END; IF type.IsProtected() THEN w.RawNum(-type.recordScope.numberMethods); (* number methods total *) ELSE w.RawNum(type.recordScope.numberMethods); (* number methods total *) END; w.RawNum(oldmth); (* inherited methods total *) w.RawNum(newmeth); (* new methods (overridden or new) *) 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); (*TODO*) ASSERT(procedure # NIL); m.GetName(name); w.RawNum(procedure.symbol(SyntaxTree.Procedure).methodNumber); w.RawNum(procedure.entryNumber); INC(i); END; m := m.nextProcedure; END; (* Ptrs in Record *) numberPointers := 0; IF Trace THEN D.Str("pointers of type: "); D.Ln; END; OutPointers(0, type, numberPointers); (* debug = FALSE *) IF numberPointers # 0 THEN RawLIntAt(numberPointersPosition,numberPointers) END; (* ug *) upperPartTdSize := module.system.addressSize DIV 8 * (MaxTags + type.recordScope.numberMethods + 1 + 1); (* tags, methods, methods end marker (sentinel), address of TypeInfo *) (* ug *) lowerPartTdSize := module.system.addressSize DIV 8 * (2 + (4 + numberPointers) + 1); (* ug *) tdSize := upperPartTdSize + lowerPartTdSize; (* ug *) 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 (* avoid duplicate declarations *) 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; (* Stores the exception handle table in the following format ExceptionHandlerTable ::= 8EX {ExceptionTableEntry} ExceptionTableEntry ::= 0FFX pcFrom(4 bytes) pcTo(4 bytes) pcHandler(4 bytes) Since there is only one FINALLY in every procedure, method, body, ... we don't need to obtain an order for nesting. *) 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 (*! ASSERT(destination.offset <= destination.beginOffset); ASSERT(destination.beginOffset <= destination.endOffset); *) w.RawNum((destination.offset )); (* the metadata GC is screwed -- validPAF does not work -- removed from compiler *) w.RawNum(0); w.RawNum(0); (*! w.RawNum(destination.beginOffset); w.RawNum(destination.endOffset); *) 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 IF ~(variable.untraced) THEN OutPointers(variable.offsetInBits DIV 8,variable.type,numberPointers); END; variable := variable.nextVariable END; parameter := procedureType.firstParameter; WHILE(parameter # NIL) DO IF ~(parameter.untraced) THEN OutPointers(parameter.offsetInBits DIV 8,parameter.type,numberPointers); END; parameter := parameter.nextParameter; END; (* parameter := procedureType.selfParameter; IF parameter # NIL THEN OutPointers(parameter.offsetInBits DIV 8,parameter.type,numberPointers); 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; (*RETURN (* ARRAY OF unknown (record): do not write anything *)*) 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 (* imported unused record type *) w.Char(0X); (* nil type *) type.typeDeclaration.GetName(name); (* this happens when a symbol from a different module is used but the type desciptor is not necessary to be present in the current module D.Str("Warning: Unreferenced record type encountered: "); D.String(name); D.String(" unused? "); D.Ln; *) 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; (*length := 1+SemanticChecker.Dimension(type,{SyntaxTree.Open});*) 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; s: Section; BEGIN IF variable.externalName # NIL THEN RETURN END; IF indirect THEN w.Char(rfIndirect) ELSE w.Char(rfDirect) END; variable.GetName(name); Type(variable.type); s := symbols.BySymbol(variable); IF s # NIL THEN (* global variable *) w.RawNum( s.offset ); ELSE w.RawNum( variable.offsetInBits DIV 8 ); END; 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); (*! check for variable or type symbol for object body *) (*procedure.name,name);*) 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); (*! level *) w.RawNum(0); (* IF procedure.scope IS SyntaxTree.RecordScope THEN (* add object name *) record := procedure.scope(SyntaxTree.RecordScope).ownerRecord; recordName := ""; IF record.pointerType # NIL THEN DeclarationName(record.pointerType.typeDeclaration,recordName); ELSE DeclarationName(record.typeDeclaration,recordName); END; i := 0; WHILE recordName[i] # 0X DO w.Char(recordName[i]); INC(i); END; w.Char("."); END; *) w.RawString(name); parameter := procedureType.firstParameter; WHILE(parameter # NIL) DO WriteParameter(parameter,parameter.kind # SyntaxTree.ValueParameter); (*!treat exceptions !*) parameter := parameter.nextParameter; END; (* parameter := procedureType.selfParameter; IF parameter # NIL THEN WriteParameter(parameter,parameter.kind # SyntaxTree.ValueParameter); (*!treat exceptions !*) 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) (*! must be first procedure in ref section *) END END; FOR i := 0 TO symbols.Length() - 1 DO s := symbols.GetSection(i); IF (s.symbol = moduleScope.bodyProcedure) THEN (* already done, see above *) 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 = LONGINT(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); (* enter all sections first to keep ordering *) 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 (* IF Enter(section, symbols,symbol) THEN END;*) 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; (* ObjectFile = ofFileTag ofNoZeroCompression ofFileVersion SymbolFile Header Entries Commands Pointers Imports VarConstLinks Links Constants Exports Code Use Types ExceptionTable PtrsInProcBlock References *) BEGIN addrSize := module.system.addressSize DIV 8; MakeSectionOffsets(module,constSize,dataSize,codeSize,caseTableSize,const,code); MakeSections; (* from here on we do not need IntermediateCode.Sections any more *) LinkFixups; IF Trace THEN module.Dump(D.Log);D.Ln; D.Update; END; NEW(fingerprinter,module.system); (* module.module.name,moduleName);*) 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.