MODULE Dev0Linker; (* THIS IS TEXT COPY OF Linker.odc *) (* DO NOT EDIT *) IMPORT Kernel, Files, (* Dates, Dialog, *) Strings, (* TextModels, TextViews, TextMappers, Log := StdLog, DevCommanders *) Console; CONST NewRecFP = 4E27A847H; NewArrFP = 76068C78H; ImageBase = 00400000H; ObjAlign = 1000H; FileAlign = 200H; HeaderSize = 400H; FixLen = 30000; OFdir = "Code"; SYSdir = "System"; RsrcDir = "Rsrc"; WinDir = "Win"; (* meta interface consts *) mConst = 1; mTyp = 2; mVar = 3; mProc = 4; mField = 5; mInternal = 1; mReadonly = 2; mExported = 4; (* fixup types *) absolute = 100; relative = 101; copy = 102; table = 103; tableend = 104; (* mod desc fields *) modOpts = 4; modRefcnt = 8; modTerm = 40; modNames = 84; modImports = 92; modExports = 96; (* A. V. Shiryaev: Scanner *) TMChar = 0; TMString = 1; TMInt = 2; TMEOT = 3; TYPE Name = ARRAY 40 OF SHORTCHAR; Export = POINTER TO RECORD next: Export; name: Name; adr: INTEGER END; Resource = POINTER TO RECORD next, local: Resource; typ, id, lid, size, pos, x, y: INTEGER; opts: SET; file: Files.File; name: Files.Name END; Module = POINTER TO RECORD next: Module; name: Files.Name; file: Files.File; hs, ms, ds, cs, vs, ni, ma, ca, va: INTEGER; dll, intf: BOOLEAN; exp: Export; imp: POINTER TO ARRAY OF Module; data: POINTER TO ARRAY OF BYTE; END; (* A. V. Shiryaev: Scanner *) ScanRider = RECORD s: POINTER TO ARRAY OF CHAR; i: INTEGER END; Scanner = RECORD rider: ScanRider; start, type: INTEGER; string: ARRAY 100 OF CHAR; char: CHAR; int: INTEGER END; VAR (* W: TextMappers.Formatter; *) Out: Files.File; R: Files.Reader; Ro: Files.Writer; error, isDll, isStatic, comLine: BOOLEAN; modList, kernel, main, last, impg, impd: Module; numMod, lastTerm: INTEGER; resList: Resource; numType, resHSize: INTEGER; numId: ARRAY 32 OF INTEGER; rsrcName: ARRAY 16 OF CHAR; (* name of resource file *) firstExp, lastExp: Export; entryPos, isPos, fixPos, himpPos, hexpPos, hrsrcPos, termPos: INTEGER; codePos, dataPos, conPos, rsrcPos, impPos, expPos, relPos: INTEGER; CodeSize, DataSize, ConSize, RsrcSize, ImpSize, ImpHSize, ExpSize, RelocSize, DllSize: INTEGER; CodeRva, DataRva, ConRva, RsrcRva, ImpRva, ExpRva, RelocRva, ImagesSize: INTEGER; CodeBase, DataBase, ConBase, maxCode, numImp, numExp, noffixup, timeStamp: INTEGER; newRec, newArr: Name; fixups: POINTER TO ARRAY OF INTEGER; code: POINTER TO ARRAY OF BYTE; atab: POINTER TO ARRAY OF INTEGER; ntab: POINTER TO ARRAY OF SHORTCHAR; (* A. V. Shiryaev: Console *) PROCEDURE WriteString (s: ARRAY OF CHAR); BEGIN Console.WriteStr(s) END WriteString; PROCEDURE WriteChar (c: CHAR); VAR s: ARRAY 2 OF CHAR; BEGIN s[0] := c; s[1] := 0X; Console.WriteStr(s) END WriteChar; PROCEDURE WriteSString (ss: ARRAY OF SHORTCHAR); BEGIN Console.WriteStr(ss$) END WriteSString; PROCEDURE WriteInt (x: INTEGER); VAR s: ARRAY 16 OF CHAR; BEGIN Strings.IntToString(x, s); Console.WriteStr(s) END WriteInt; PROCEDURE WriteLn; BEGIN Console.WriteLn END WriteLn; PROCEDURE FlushW; BEGIN END FlushW; (* PROCEDURE TimeStamp (): INTEGER; (* seconds since 1.1.1970 00:00:00 *) VAR a: INTEGER; t: Dates.Time; d: Dates.Date; BEGIN Dates.GetTime(t); Dates.GetDate(d); a := 12 * (d.year - 70) + d.month - 3; a := a DIV 12 * 1461 DIV 4 + (a MOD 12 * 153 + 2) DIV 5 + d.day + 59; RETURN ((a * 24 + t.hour) * 60 + t.minute) * 60 + t.second; END TimeStamp; *) PROCEDURE ThisFile (modname: ARRAY OF CHAR): Files.File; VAR dir, name: Files.Name; loc: Files.Locator; f: Files.File; BEGIN Kernel.SplitName(modname, dir, name); Kernel.MakeFileName(name, Kernel.objType); loc := Files.dir.This(dir); loc := loc.This(OFdir); f := Files.dir.Old(loc, name, TRUE); IF (f = NIL) & (dir = "") THEN loc := Files.dir.This(SYSdir); loc := loc.This(OFdir); f := Files.dir.Old(loc, name, TRUE) END; RETURN f END ThisFile; PROCEDURE ThisResFile (VAR name: Files.Name): Files.File; VAR loc: Files.Locator; f: Files.File; BEGIN f := Files.dir.Old(Files.dir.This(RsrcDir), name, TRUE); IF f = NIL THEN loc := Files.dir.This(WinDir); loc := loc.This(RsrcDir); f := Files.dir.Old(loc, name, TRUE); IF f = NIL THEN f := Files.dir.Old(Files.dir.This(""), name, TRUE) END END; RETURN f END ThisResFile; PROCEDURE Read2 (VAR x: INTEGER); VAR b: BYTE; BEGIN R.ReadByte(b); x := b MOD 256; R.ReadByte(b); x := x + 100H * (b MOD 256) END Read2; PROCEDURE Read4 (VAR x: INTEGER); VAR b: BYTE; BEGIN R.ReadByte(b); x := b MOD 256; R.ReadByte(b); x := x + 100H * (b MOD 256); R.ReadByte(b); x := x + 10000H * (b MOD 256); R.ReadByte(b); x := x + 1000000H * b END Read4; PROCEDURE ReadName (VAR name: ARRAY OF SHORTCHAR); VAR i: INTEGER; b: BYTE; BEGIN i := 0; REPEAT R.ReadByte(b); name[i] := SHORT(CHR(b)); INC(i) UNTIL b = 0 END ReadName; PROCEDURE RNum (VAR i: INTEGER); VAR b: BYTE; s, y: INTEGER; BEGIN s := 0; y := 0; R.ReadByte(b); WHILE b < 0 DO INC(y, ASH(b + 128, s)); INC(s, 7); R.ReadByte(b) END; i := ASH((b + 64) MOD 128 - 64, s) + y END RNum; PROCEDURE WriteCh (ch: SHORTCHAR); BEGIN Ro.WriteByte(SHORT(ORD(ch))) END WriteCh; PROCEDURE Write2 (x: INTEGER); BEGIN Ro.WriteByte(SHORT(SHORT(x MOD 256))); x := x DIV 256; Ro.WriteByte(SHORT(SHORT(x MOD 256))) END Write2; PROCEDURE Write4 (x: INTEGER); BEGIN Ro.WriteByte(SHORT(SHORT(x MOD 256))); x := x DIV 256; Ro.WriteByte(SHORT(SHORT(x MOD 256))); x := x DIV 256; Ro.WriteByte(SHORT(SHORT(x MOD 256))); x := x DIV 256; Ro.WriteByte(SHORT(SHORT(x MOD 256))) END Write4; PROCEDURE WriteName (s: ARRAY OF SHORTCHAR; len: SHORTINT); VAR i: SHORTINT; BEGIN i := 0; WHILE s[i] # 0X DO Ro.WriteByte(SHORT(ORD(s[i]))); INC(i) END; WHILE i < len DO Ro.WriteByte(0); INC(i) END END WriteName; PROCEDURE Reloc (a: INTEGER); VAR p: POINTER TO ARRAY OF INTEGER; i: INTEGER; BEGIN IF noffixup >= LEN(fixups) THEN NEW(p, 2 * LEN(fixups)); i := 0; WHILE i < LEN(fixups) DO p[i] := fixups[i]; INC(i) END; fixups := p END; fixups[noffixup] := a; INC(noffixup) (* ELSE IF ~error THEN W.WriteSString(" too many fixups") END; error := TRUE END *) END Reloc; PROCEDURE Put (mod: Module; a, x: INTEGER); BEGIN mod.data[a] := SHORT(SHORT(x)); INC(a); x := x DIV 256; mod.data[a] := SHORT(SHORT(x)); INC(a); x := x DIV 256; mod.data[a] := SHORT(SHORT(x)); INC(a); x := x DIV 256; mod.data[a] := SHORT(SHORT(x)) END Put; PROCEDURE Get (mod: Module; a: INTEGER; VAR x: INTEGER); BEGIN x := ((mod.data[a + 3] * 256 + (mod.data[a + 2] MOD 256)) * 256 + (mod.data[a + 1] MOD 256)) * 256 + (mod.data[a] MOD 256) END Get; PROCEDURE GenName (VAR from, to: ARRAY OF SHORTCHAR; ext: ARRAY OF SHORTCHAR); VAR i, j: INTEGER; BEGIN i := 0; WHILE from[i] # 0X DO to[i] := from[i]; INC(i) END; IF ext # "" THEN to[i] := "."; INC(i); j := 0; WHILE ext[j] # 0X DO to[i] := ext[j]; INC(i); INC(j) END END; to[i] := 0X END GenName; PROCEDURE Fixup0 (link, adr: INTEGER); VAR offset, linkadr, t, n, x: INTEGER; BEGIN WHILE link # 0 DO RNum(offset); WHILE link # 0 DO IF link > 0 THEN n := (code[link] MOD 256) + (code[link+1] MOD 256) * 256 + code[link+2] * 65536; t := code[link+3]; linkadr := CodeBase + impg.ca + link ELSE n := (impg.data[-link] MOD 256) + (impg.data[-link+1] MOD 256) * 256 + impg.data[-link+2] * 65536; t := impg.data[-link+3]; linkadr := ConBase + impg.ma - link END; IF t = absolute THEN x := adr + offset ELSIF t = relative THEN x := adr + offset - linkadr - 4 ELSIF t = copy THEN Get(impd, adr + offset - ConBase - impd.ma, x) ELSIF t = table THEN x := adr + n; n := link + 4 ELSIF t = tableend THEN x := adr + n; n := 0 ELSE HALT(99) END; IF link > 0 THEN code[link] := SHORT(SHORT(x)); code[link+1] := SHORT(SHORT(x DIV 100H)); code[link+2] := SHORT(SHORT(x DIV 10000H)); code[link+3] := SHORT(SHORT(x DIV 1000000H)) ELSE link := -link; impg.data[link] := SHORT(SHORT(x)); impg.data[link+1] := SHORT(SHORT(x DIV 100H)); impg.data[link+2] := SHORT(SHORT(x DIV 10000H)); impg.data[link+3] := SHORT(SHORT(x DIV 1000000H)) END; IF (t # relative) & ((t # copy) OR (x DIV 65536 # 0)) THEN Reloc(linkadr) END; link := n END; RNum(link) END END Fixup0; PROCEDURE Fixup (adr: INTEGER); VAR link: INTEGER; BEGIN RNum(link); Fixup0(link, adr) END Fixup; PROCEDURE CheckDllImports (mod: Module); VAR i, x, y: INTEGER; name: Name; imp: Module; exp: Export; PROCEDURE SkipLink; VAR a: INTEGER; BEGIN RNum(a); WHILE a # 0 DO RNum(a); RNum(a) END END SkipLink; BEGIN R := mod.file.NewReader(R); R.SetPos(mod.hs + mod.ms + mod.ds + mod.cs); SkipLink; SkipLink; SkipLink; SkipLink; SkipLink; SkipLink; i := 0; WHILE i < mod.ni DO imp := mod.imp[i]; IF imp # NIL THEN RNum(x); WHILE x # 0 DO ReadName(name); RNum(y); IF x = mVar THEN SkipLink; IF imp.dll THEN WriteString("variable ("); WriteString(imp.name); WriteChar("."); WriteSString(name); WriteString(") imported from DLL in "); WriteString(mod.name); WriteLn; FlushW; error := TRUE; RETURN END ELSIF x = mTyp THEN RNum(y); IF imp.dll THEN RNum(y); IF y # 0 THEN WriteString("type descriptor ("); WriteString(imp.name); WriteChar("."); WriteSString(name); WriteString(") imported from DLL in "); WriteString(mod.name); WriteLn; FlushW; error := TRUE; RETURN END ELSE SkipLink END ELSIF x = mProc THEN IF imp.dll THEN SkipLink; exp := imp.exp; WHILE (exp # NIL) & (exp.name # name) DO exp := exp.next END; IF exp = NIL THEN NEW(exp); exp.name := name$; exp.next := imp.exp; imp.exp := exp; INC(DllSize, 6) END END END; RNum(x) END END; INC(i) END END CheckDllImports; PROCEDURE ReadHeaders; VAR mod, im, t: Module; x, i: INTEGER; impdll: BOOLEAN; exp: Export; name: Name; BEGIN mod := modList; modList := NIL; numMod := 0; WHILE mod # NIL DO (* reverse mod list & count modules *) IF ~mod.dll THEN INC(numMod) END; t := mod; mod := t.next; t.next := modList; modList := t END; IF isStatic THEN IF isDll THEN (* push ebx; cmp [12, esp], 1; jne L1; mov ebx, modlist; { call body; } jp L2 *) (* L1: cmp [12, esp], 0; jne L2; { call term; } *) (* L2: pop ebx; mov aex,1; ret 12 *) CodeSize := 42 + 10 * numMod ELSE (* push ebx; push ebx; push ebx; mov ebx, modlist; { call body; } { call term; } *) (* pop ebx; pop ebx; pop ebx; ret *) CodeSize := 12 + 10 * numMod END ELSE IF isDll THEN (* push ebx; cmp [12, esp], 1; jne L1; mov ebx, modlist; call main; jp L2 *) (* L1: cmp [12, esp], 0; jne L2; call mainTerm; *) (* L2: pop ebx; mov aex,1; ret 12 *) CodeSize := 41 ELSE (* mov ebx, modlist; jmp main *) CodeSize := 10 END END; (* IF isDll THEN CodeSize := 24 (* push ebx, esi, edi; mov bx, modlist; call main; pop edi, esi, ebx; mov aex,1; ret 12 *) ELSE CodeSize := 10 (* mov bx, modlist; jmp main *) END *) DataSize := 0; ConSize := 0; ImpSize := 0; ImpHSize := 0; ExpSize := 0; RelocSize := 0; DllSize := 0; noffixup := 0; maxCode := 0; numImp := 0; numExp := 0; mod := modList; WHILE mod # NIL DO IF ~mod.dll THEN mod.file := ThisFile(mod.name); IF mod.file # NIL THEN R := mod.file.NewReader(R); R.SetPos(0); Read4(x); IF x = 6F4F4346H THEN Read4(x); Read4(mod.hs); Read4(mod.ms); Read4(mod.ds); Read4(mod.cs); Read4(mod.vs); RNum(mod.ni); ReadName(name); impdll := FALSE; IF mod.ni > 0 THEN NEW(mod.imp, mod.ni); x := 0; WHILE x < mod.ni DO ReadName(name); IF name = "$$" THEN IF (mod # kernel) & (kernel # NIL) THEN mod.imp[x] := kernel ELSE WriteSString("no kernel"); WriteLn; FlushW; error := TRUE END ELSIF name[0] = "$" THEN i := 1; WHILE name[i] # 0X DO name[i-1] := name[i]; INC(i) END; name[i-1] := 0X; impdll := TRUE; im := modList; WHILE (im # mod) & (im.name # name) DO im := im.next END; IF (im = NIL) OR ~im.dll THEN NEW(im); im.next := modList; modList := im; im.name := name$; im.dll := TRUE END; mod.imp[x] := im; ELSE im := modList; WHILE (im # mod) & (im.name # name) DO im := im.next END; IF im # mod THEN mod.imp[x] := im; ELSE WriteSString(name); WriteString(" not present (imported in "); WriteString(mod.name); WriteChar(")"); WriteLn; FlushW; error := TRUE END END; INC(x) END END; IF impdll & ~error THEN CheckDllImports(mod) END; mod.ma := ConSize; INC(ConSize, mod.ms + mod.ds); mod.va := DataSize; INC(DataSize, mod.vs); mod.ca := CodeSize; INC(CodeSize, mod.cs); IF mod.cs > maxCode THEN maxCode := mod.cs END ELSE WriteString(mod.name); WriteString(": wrong file type"); WriteLn; FlushW; error := TRUE END; mod.file.Close; mod.file := NIL ELSE WriteString(mod.name); WriteString(" not found"); WriteLn; FlushW; error := TRUE END; last := mod END; mod := mod.next END; IF ~isStatic & (main = NIL) THEN WriteSString("no main module specified"); WriteLn; FlushW; error := TRUE END; (* calculate rva's *) IF DataSize = 0 THEN DataSize := 1 END; CodeRva := ObjAlign; DataRva := CodeRva + (CodeSize + DllSize + (ObjAlign - 1)) DIV ObjAlign * ObjAlign; ConRva := DataRva + (DataSize + (ObjAlign - 1)) DIV ObjAlign * ObjAlign; RsrcRva := ConRva + (ConSize + (ObjAlign - 1)) DIV ObjAlign * ObjAlign; CodeBase := ImageBase + CodeRva; DataBase := ImageBase + DataRva; ConBase := ImageBase + ConRva; (* write dll export adresses *) mod := modList; x := 0; WHILE mod # NIL DO IF mod.dll THEN exp := mod.exp; INC(ImpSize, 20); WHILE exp # NIL DO exp.adr := x; INC(x, 6); exp := exp.next END END; mod := mod.next END; ASSERT(x = DllSize); INC(ImpSize, 20); (* sentinel *) END ReadHeaders; PROCEDURE MenuSize (r: Resource): INTEGER; VAR s, i: INTEGER; BEGIN s := 0; WHILE r # NIL DO INC(s, 2); IF r.local = NIL THEN INC(s, 2) END; i := 0; WHILE r.name[i] # 0X DO INC(s, 2); INC(i) END; INC(s, 2); s := s + MenuSize(r.local); r := r.next END; RETURN s END MenuSize; PROCEDURE PrepResources; VAR res, r, s: Resource; n, i, j, t, x: INTEGER; loc: Files.Locator; BEGIN r := resList; WHILE r # NIL DO IF r.lid = 0 THEN r.lid := 1033 END; IF r.name = "MENU" THEN r.typ := 4; r.size := 4 + MenuSize(r.local); ELSIF r.name = "ACCELERATOR" THEN r.typ := 9; r.size := 0; s := r.local; WHILE s # NIL DO INC(r.size, 8); s := s.next END; ELSE r.file := ThisResFile(r.name); IF r.file # NIL THEN IF r.typ = -1 THEN (* typelib *) r.typ := 0; r.size := r.file.Length(); r.pos := 0; rsrcName := "TYPELIB" ELSE R := r.file.NewReader(R); R.SetPos(0); Read2(n); IF n = 4D42H THEN (* bitmap *) Read4(n); r.typ := 2; r.size := n - 14; r.pos := 14; ELSE Read2(x); IF x = 1 THEN (* icon *) Read2(n); r.typ := 14; r.size := 6 + 14 * n; r.pos := 0; i := 0; WHILE i < n DO NEW(s); s.typ := 3; s.id := 10 * r.id + i; s.lid := r.lid; s.name := r.name$; Read4(x); Read4(x); Read4(s.size); Read2(s.pos); Read2(x); s.next := resList; resList := s; INC(i) END ELSIF x = 2 THEN (* cursor *) Read2(n); r.typ := 12; r.size := 6 + 14 * n; r.pos := 0; i := 0; WHILE i < n DO NEW(s); s.typ := 1; s.id := 10 * r.id + i; s.lid := r.lid; s.name := r.name$; Read4(x); Read2(s.x); Read2(s.y); Read4(s.size); INC(s.size, 4); Read2(s.pos); Read2(x); s.next := resList; resList := s; INC(i) END ELSE Read4(n); IF (x = 0) & (n = 20H) THEN (* resource file *) Read4(n); Read4(n); Read4(n); Read4(n); Read4(n); Read4(n); (* 32 bit marker *) Read4(r.size); Read4(n); Read2(i); IF i = 0FFFFH THEN Read2(j); IF (j >= 4) & ((j <= 11) OR (j = 16)) THEN r.typ := j; r.pos := n + 32; ELSE WriteString(r.name); WriteString(": invalid type"); WriteLn; FlushW; error := TRUE END ELSE j := 0; WHILE i # 0 DO rsrcName[j] := CHR(i); INC(j); Read2(i) END; rsrcName[j] := 0X; r.typ := 0; r.pos := n + 32 END ELSE WriteString(r.name); WriteString(": unknown type"); WriteLn; FlushW; error := TRUE END END END END; r.file.Close; r.file := NIL ELSE WriteString(r.name); WriteString(" not found"); WriteLn; FlushW; error := TRUE END END; r := r.next END; res := resList; resList := NIL; (* sort resources *) WHILE res # NIL DO r := res; res := res.next; IF (resList = NIL) OR (r.typ < resList.typ) OR (r.typ = resList.typ) & ((r.id < resList.id) OR (r.id = resList.id) & (r.lid < resList.lid)) THEN r.next := resList; resList := r ELSE s := resList; WHILE (s.next # NIL) & (r.typ >= s.next.typ) & ((r.typ # s.next.typ) OR (r.id >= s.next.id) & ((r.id # s.next.id) OR (r.lid >= s.next.lid))) DO s := s.next END; r.next := s.next; s.next := r END END; r := resList; numType := 0; resHSize := 16; t := 0; n := 0; (* get resource size *) WHILE t < LEN(numId) DO numId[t] := 0; INC(t) END; WHILE r # NIL DO INC(numType); INC(resHSize, 24); t := r.typ; WHILE (r # NIL) & (r.typ = t) DO INC(numId[t]); INC(resHSize, 24); i := r.id; WHILE (r # NIL) & (r.typ = t) & (r.id = i) DO INC(resHSize, 24); INC(n, (r.size + 3) DIV 4 * 4); r := r.next END END END; IF numId[0] > 0 THEN INC(n, (LEN(rsrcName$) + 1) * 2) END; RsrcSize := resHSize + n; ImpRva := RsrcRva + (RsrcSize + (ObjAlign - 1)) DIV ObjAlign * ObjAlign END PrepResources; PROCEDURE WriteHeader(VAR name: Files.Name); BEGIN Out := Files.dir.New(Files.dir.This(""), Files.ask); Ro := Out.NewWriter(Ro); Ro.SetPos(0); (* DOS header *) Write4(905A4DH); Write4(3); Write4(4); Write4(0FFFFH); Write4(0B8H); Write4(0); Write4(40H); Write4(0); Write4(0); Write4(0); Write4(0); Write4(0); Write4(0); Write4(0); Write4(0); Write4(80H); Write4(0EBA1F0EH); Write4(0CD09B400H); Write4(4C01B821H); Write2(21CDH); WriteName("This program cannot be run in DOS mode.", 39); WriteCh(0DX); WriteCh(0DX); WriteCh(0AX); Write4(24H); Write4(0); (* Win32 header *) WriteName("PE", 4); (* signature bytes *) Write2(014CH); (* cpu type (386) *) IF isDll THEN Write2(7); (* 7 objects *) ELSE Write2(6); (* 6 objects *) END; Write4(timeStamp); (* time/date *) Write4(0); Write4(0); Write2(0E0H); (* NT header size *) IF isDll THEN Write2(0A38EH); (* library image flags *) ELSE Write2(838EH); (* program image flags *) END; Write2(10BH); (* magic (normal ececutable file) *) Write2(0301H); (* linker version !!! *) Write4(CodeSize); (* code size *) Write4(ConSize); (* initialized data size *) Write4(DataSize); (* uninitialized data size *) entryPos := Ro.Pos(); Write4(0); (* entry point *) (* !!! *) Write4(CodeRva); (* base of code *) Write4(ConRva); (* base of data *) Write4(400000H); (* image base *) Write4(ObjAlign); (* object align *) Write4(FileAlign); (* file align *) Write4(3); (* OS version *) Write4(4); (* user version *) Write4(4); (* subsys version *) (* mf 14.3.04: value changed from 0A0003H to 4. Corrects menubar pixel bug on Windows XP *) Write4(0); isPos := Ro.Pos(); Write4(0); (* image size *) (* !!! *) Write4(HeaderSize); (* header size !!! *) Write4(0); (* checksum *) IF comLine THEN Write2(3) (* dos subsystem *) ELSE Write2(2) (* gui subsystem *) END; Write2(0); (* dll flags *) Write4(200000H); (* stack reserve size *) Write4(10000H); (* stack commit size *) IF isDll THEN Write4(00100000H); (* heap reserve size *) ELSE Write4(00400000H); (* heap reserve size *) END; Write4(10000H); (* heap commit size *) Write4(0); Write4(16); (* num of rva/sizes *) hexpPos := Ro.Pos(); Write4(0); Write4(0); (* export table *) himpPos := Ro.Pos(); Write4(0); Write4(0); (* import table *) (* !!! *) hrsrcPos := Ro.Pos(); Write4(0); Write4(0); (* resource table *) (* !!! *) Write4(0); Write4(0); (* exception table *) Write4(0); Write4(0); (* security table *) fixPos := Ro.Pos(); Write4(0); Write4(0); (* fixup table *) (* !!! *) Write4(0); Write4(0); (* debug table *) Write4(0); Write4(0); (* image description *) Write4(0); Write4(0); (* machine specific *) Write4(0); Write4(0); (* thread local storage *) Write4(0); Write4(0); (* ??? *) Write4(0); Write4(0); (* ??? *) Write4(0); Write4(0); (* ??? *) Write4(0); Write4(0); (* ??? *) Write4(0); Write4(0); (* ??? *) Write4(0); Write4(0); (* ??? *) (* object directory *) WriteName(".text", 8); (* code object *) Write4(0); (* object size (always 0) *) codePos := Ro.Pos(); Write4(0); (* object rva *) Write4(0); (* physical size *) Write4(0); (* physical offset *) Write4(0); Write4(0); Write4(0); Write4(60000020H); (* flags: code, exec, read *) WriteName(".var", 8); (* variable object *) Write4(0); (* object size (always 0) *) dataPos := Ro.Pos(); Write4(0); (* object rva *) Write4(0); (* physical size *) Write4(0); (* physical offset *) (* zero! (noinit) *) Write4(0); Write4(0); Write4(0); Write4(0C0000080H); (* flags: noinit, read, write *) WriteName(".data", 8); (* constant object *) Write4(0); (* object size (always 0) *) conPos := Ro.Pos(); Write4(0); (* object rva *) Write4(0); (* physical size *) Write4(0); (* physical offset *) Write4(0); Write4(0); Write4(0); Write4(0C0000040H); (* flags: data, read, write *) WriteName(".rsrc", 8); (* resource object *) Write4(0); (* object size (always 0) *) rsrcPos := Ro.Pos(); Write4(0); (* object rva *) Write4(0); (* physical size *) Write4(0); (* physical offset *) Write4(0); Write4(0); Write4(0); Write4(0C0000040H); (* flags: data, read, write *) WriteName(".idata", 8); (* import object *) Write4(0); (* object size (always 0) *) impPos := Ro.Pos(); Write4(0); (* object rva *) Write4(0); (* physical size *) Write4(0); (* physical offset *) Write4(0); Write4(0); Write4(0); Write4(0C0000040H); (* flags: data, read, write *) IF isDll THEN WriteName(".edata", 8); (* export object *) Write4(0); (* object size (always 0) *) expPos := Ro.Pos(); Write4(0); (* object rva *) Write4(0); (* physical size *) Write4(0); (* physical offset *) Write4(0); Write4(0); Write4(0); Write4(0C0000040H); (* flags: data, read, write *) END; WriteName(".reloc", 8); (* relocation object *) Write4(0); (* object size (always 0) *) relPos := Ro.Pos(); Write4(0); (* object rva *) Write4(0); (* physical size *) Write4(0); (* physical offset *) Write4(0); Write4(0); Write4(0); Write4(42000040H); (* flags: data, read, ? *) END WriteHeader; PROCEDURE SearchObj (mod: Module; VAR name: ARRAY OF SHORTCHAR; m, fp, opt: INTEGER; VAR adr: INTEGER); VAR dir, len, ntab, f, id, l, r, p, n, i, j: INTEGER; nch, och: SHORTCHAR; BEGIN Get(mod, mod.ms + modExports, dir); DEC(dir, ConBase + mod.ma); Get(mod, dir, len); INC(dir, 4); Get(mod, mod.ms + modNames, ntab); DEC(ntab, ConBase + mod.ma); IF name # "" THEN l := 0; r := len; WHILE l < r DO (* binary search *) n := (l + r) DIV 2; p := dir + n * 16; Get(mod, p + 8, id); i := 0; j := ntab + id DIV 256; nch := name[0]; och := SHORT(CHR(mod.data[j])); WHILE (nch = och) & (nch # 0X) DO INC(i); INC(j); nch := name[i]; och := SHORT(CHR(mod.data[j])) END; IF och = nch THEN IF id MOD 16 = m THEN Get(mod, p, f); IF m = mTyp THEN IF ODD(opt) THEN Get(mod, p + 4, f) END; IF (opt > 1) & (id DIV 16 MOD 16 # mExported) THEN WriteString(mod.name); WriteChar("."); WriteSString(name); WriteString(" imported from "); WriteString(impg.name); WriteString(" has wrong visibility"); WriteLn; error := TRUE END; Get(mod, p + 12, adr) ELSIF m = mVar THEN Get(mod, p + 4, adr); INC(adr, DataBase + mod.va) ELSIF m = mProc THEN Get(mod, p + 4, adr); INC(adr, CodeBase + mod.ca) END; IF f # fp THEN WriteString(mod.name); WriteChar("."); WriteSString(name); WriteString(" imported from "); WriteString(impg.name); WriteString(" has wrong fprint"); WriteLn; error := TRUE END ELSE WriteString(mod.name); WriteChar("."); WriteSString(name); WriteString(" imported from "); WriteString(impg.name); WriteString(" has wrong class"); WriteLn; error := TRUE END; RETURN END; IF och < nch THEN l := n + 1 ELSE r := n END END; WriteString(mod.name); WriteChar("."); WriteSString(name); WriteString(" not found (imported from "); WriteString(impg.name); WriteChar(")"); WriteLn; error := TRUE ELSE (* anonymous type *) WHILE len > 0 DO Get(mod, dir + 4, f); Get(mod, dir + 8, id); IF (f = fp) & (id MOD 16 = mTyp) & (id DIV 256 = 0) THEN Get(mod, dir + 12, adr); RETURN END; DEC(len); INC(dir, 16) END; WriteString("anonymous type in "); WriteString(mod.name); WriteString(" not found"); WriteLn; error := TRUE END END SearchObj; PROCEDURE CollectExports (mod: Module); VAR dir, len, ntab, id, i, j, n: INTEGER; e, exp: Export; BEGIN Get(mod, mod.ms + modExports, dir); DEC(dir, ConBase + mod.ma); Get(mod, dir, len); INC(dir, 4); Get(mod, mod.ms + modNames, ntab); DEC(ntab, ConBase + mod.ma); n := 0; WHILE n < len DO Get(mod, dir + 8, id); IF (id DIV 16 MOD 16 # mInternal) & ((id MOD 16 = mProc) OR (id MOD 16 = mVar))THEN (* exported procedure & var *) NEW(exp); i := 0; j := ntab + id DIV 256; WHILE mod.data[j] # 0 DO exp.name[i] := SHORT(CHR(mod.data[j])); INC(i); INC(j) END; exp.name[i] := 0X; Get(mod, dir + 4, exp.adr); IF id MOD 16 = mProc THEN INC(exp.adr, CodeRva + mod.ca) ELSE ASSERT(id MOD 16 = mVar); INC(exp.adr, DataRva + mod.va) END; IF (firstExp = NIL) OR (exp.name < firstExp.name) THEN exp.next := firstExp; firstExp := exp; IF lastExp = NIL THEN lastExp := exp END ELSE e := firstExp; WHILE (e.next # NIL) & (exp.name > e.next.name) DO e := e.next END; exp.next := e.next; e.next := exp; IF lastExp = e THEN lastExp := exp END END; INC(numExp); END; INC(n); INC(dir, 16) END END CollectExports; PROCEDURE WriteTermCode (m: Module; i: INTEGER); VAR x: INTEGER; BEGIN IF m # NIL THEN IF m.dll THEN WriteTermCode(m.next, i) ELSE IF isStatic THEN WriteTermCode(m.next, i + 1) END; Get(m, m.ms + modTerm, x); (* terminator address in mod desc*) IF x = 0 THEN WriteCh(005X); Write4(0) (* add EAX, 0 (nop) *) ELSE WriteCh(0E8X); Write4(x - lastTerm + 5 * i - CodeBase) (* call term *) END END END END WriteTermCode; PROCEDURE WriteCode; VAR mod, m: Module; i, x, a, fp, opt: INTEGER; exp: Export; name: Name; BEGIN IF isStatic THEN WriteCh(053X); (* push ebx *) a := 1; IF isDll THEN WriteCh(083X); WriteCh(07CX); WriteCh(024X); WriteCh(00CX); WriteCh(001X); (* cmp [12, esp], 1 *) WriteCh(00FX); WriteCh(085X); Write4(10 + 5 * numMod); (* jne L1 *) INC(a, 11) ELSE WriteCh(053X); WriteCh(053X); (* push ebx; push ebx *) INC(a, 2) END; WriteCh(0BBX); Write4(ConBase + last.ma + last.ms); Reloc(CodeBase + a + 1); (* mov bx, modlist *) INC(a, 5); m := modList; WHILE m # NIL DO IF ~m.dll THEN WriteCh(0E8X); INC(a, 5); Write4(m.ca - a) (* call body *) END; m := m.next END; IF isDll THEN WriteCh(0E9X); Write4(11 + 5 * numMod); (* jp L2 *) WriteCh(083X); WriteCh(07CX); WriteCh(024X); WriteCh(00CX); WriteCh(000X); (* L1: cmp [12, esp], 0 *) WriteCh(00FX); WriteCh(085X); Write4(5 * numMod); (* jne L2 *) INC(a, 16) END; termPos := Ro.Pos(); i := 0; WHILE i < numMod DO (* nop for call terminator *) WriteCh(02DX); Write4(0); (* sub EAX, 0 *) INC(i); INC(a, 5) END; lastTerm := a; WriteCh(05BX); (* L2: pop ebx *) IF isDll THEN WriteCh(0B8X); Write4(1); (* mov eax,1 *) WriteCh(0C2X); Write2(12) (* ret 12 *) ELSE WriteCh(05BX); WriteCh(05BX); (* pop ebx; pop ebx *) WriteCh(0C3X) (* ret *) END ELSIF isDll THEN WriteCh(053X); (* push ebx *) WriteCh(083X); WriteCh(07CX); WriteCh(024X); WriteCh(00CX); WriteCh(001X); (* cmp [12, esp], 1 *) WriteCh(075X); WriteCh(SHORT(CHR(12))); (* jne L1 *) WriteCh(0BBX); Write4(ConBase + last.ma + last.ms); Reloc(CodeBase + 9); (* mov bx, modlist *) WriteCh(0E8X); Write4(main.ca - 18); (* call main *) WriteCh(0EBX); WriteCh(SHORT(CHR(12))); (* jp L2 *) WriteCh(083X); WriteCh(07CX); WriteCh(024X); WriteCh(00CX); WriteCh(000X); (* L1: cmp [12, esp], 0 *) WriteCh(075X); WriteCh(SHORT(CHR(5))); (* jne L2 *) termPos := Ro.Pos(); WriteCh(02DX); Write4(0); (* sub EAX, 0 *) (* nop for call terminator *) lastTerm := 32; WriteCh(05BX); (* L2: pop ebx *) WriteCh(0B8X); Write4(1); (* mov eax,1 *) WriteCh(0C2X); Write2(12) (* ret 12 *) ELSE WriteCh(0BBX); Write4(ConBase + last.ma + last.ms); Reloc(CodeBase + 1); (* mov bx, modlist *) WriteCh(0E9X); Write4(main.ca - 10); (* jmp main *) END; NEW(code, maxCode); mod := modList; WHILE mod # NIL DO impg := mod; impd := mod; IF ~mod.dll THEN mod.file := ThisFile(mod.name); R := mod.file.NewReader(R); R.SetPos(mod.hs); NEW(mod.data, mod.ms + mod.ds); R.ReadBytes(mod.data^, 0, mod.ms + mod.ds); R.ReadBytes(code^, 0, mod.cs); RNum(x); IF x # 0 THEN IF (mod # kernel) & (kernel # NIL) THEN SearchObj(kernel, newRec, mProc, NewRecFP, -1, a); Fixup0(x, a) ELSE WriteSString("no kernel"); WriteLn; FlushW; error := TRUE; RETURN END END; RNum(x); IF x # 0 THEN IF (mod # kernel) & (kernel # NIL) THEN SearchObj(kernel, newArr, mProc, NewArrFP, -1, a); Fixup0(x, a) ELSE WriteSString("no kernel"); WriteLn; FlushW; error := TRUE; RETURN END END; Fixup(ConBase + mod.ma); Fixup(ConBase + mod.ma + mod.ms); Fixup(CodeBase + mod.ca); Fixup(DataBase + mod.va); i := 0; WHILE i < mod.ni DO m := mod.imp[i]; impd := m; RNum(x); WHILE x # 0 DO ReadName(name); RNum(fp); opt := 0; IF x = mTyp THEN RNum(opt) END; IF m.dll THEN IF x = mProc THEN exp := m.exp; WHILE exp.name # name DO exp := exp.next END; a := exp.adr + CodeBase + CodeSize END ELSE SearchObj(m, name, x, fp, opt, a) END; IF x # mConst THEN Fixup(a) END; RNum(x) END; IF ~m.dll THEN Get(mod, mod.ms + modImports, x); DEC(x, ConBase + mod.ma); INC(x, 4 * i); Put(mod, x, ConBase + m.ma + m.ms); (* imp ref *) Reloc(ConBase + mod.ma + x); Get(m, m.ms + modRefcnt, x); Put(m, m.ms + modRefcnt, x + 1) (* inc ref count *) END; INC(i) END; Ro.WriteBytes(code^, 0, mod.cs); IF mod.intf THEN CollectExports(mod) END; mod.file.Close; mod.file := NIL END; mod := mod.next END; (* dll links *) mod := modList; ImpHSize := ImpSize; WHILE mod # NIL DO IF mod.dll THEN exp := mod.exp; WHILE exp # NIL DO WriteCh(0FFX); WriteCh(25X); Write4(ImageBase + ImpRva + ImpSize); (* JMP indirect *) Reloc(CodeBase + CodeSize + exp.adr + 2); INC(ImpSize, 4); INC(numImp); exp := exp.next END; INC(ImpSize, 4); INC(numImp) (* sentinel *) END; mod := mod.next END END WriteCode; PROCEDURE WriteConst; VAR mod, last: Module; x: INTEGER; BEGIN mod := modList; last := NIL; WHILE mod # NIL DO IF ~mod.dll THEN IF last # NIL THEN Put(mod, mod.ms, ConBase + last.ma + last.ms); (* mod list *) Reloc(ConBase + mod.ma + mod.ms); END; Get(mod, mod.ms + modOpts, x); IF isStatic THEN INC(x, 10000H) END; (* set init bit (16) *) IF isDll THEN INC(x, 1000000H) END; (* set dll bit (24) *) Put(mod, mod.ms + modOpts, x); Ro.WriteBytes(mod.data^, 0, mod.ms + mod.ds); last := mod END; mod := mod.next END END WriteConst; PROCEDURE WriteResDir (n, i: INTEGER); BEGIN Write4(0); (* flags *) Write4(timeStamp); Write4(0); (* version *) Write2(n); (* name entries *) Write2(i); (* id entries *) END WriteResDir; PROCEDURE WriteResDirEntry (id, adr: INTEGER; dir: BOOLEAN); BEGIN IF id = 0 THEN id := resHSize + 80000000H END; (* name Rva *) Write4(id); IF dir THEN Write4(adr + 80000000H) ELSE Write4(adr) END END WriteResDirEntry; PROCEDURE WriteMenu (res: Resource); VAR f, i: INTEGER; BEGIN WHILE res # NIL DO IF res.next = NIL THEN f := 80H ELSE f := 0 END; IF 29 IN res.opts THEN INC(f, 1) END; (* = grayed *) IF 13 IN res.opts THEN INC(f, 2) END; (* - inctive *) IF 3 IN res.opts THEN INC(f, 4) END; (* # bitmap *) IF 10 IN res.opts THEN INC(f, 8) END; (* * checked *) IF 1 IN res.opts THEN INC(f, 20H) END; (* ! menubarbreak *) IF 15 IN res.opts THEN INC(f, 40H) END; (* / menubreak *) IF 31 IN res.opts THEN INC(f, 100H) END; (* ? ownerdraw *) IF res.local # NIL THEN Write2(f + 10H) ELSE Write2(f); Write2(res.id) END; i := 0; WHILE res.name[i] # 0X DO Write2(ORD(res.name[i])); INC(i) END; Write2(0); WriteMenu(res.local); res := res.next END END WriteMenu; PROCEDURE WriteResource; VAR r, s: Resource; i, t, a, x, n, nlen, nsize: INTEGER; BEGIN IF numId[0] > 0 THEN WriteResDir(1, numType - 1); nlen := LEN(rsrcName$); nsize := (nlen + 1) * 2; ELSE WriteResDir(0, numType) END; a := 16 + 8 * numType; t := 0; WHILE t < LEN(numId) DO IF numId[t] > 0 THEN WriteResDirEntry(t, a, TRUE); INC(a, 16 + 8 * numId[t]) END; INC(t) END; r := resList; t := -1; WHILE r # NIL DO IF t # r.typ THEN t := r.typ; WriteResDir(0, numId[t]) END; WriteResDirEntry(r.id, a, TRUE); INC(a, 16); i := r.id; WHILE (r # NIL) & (r.typ = t) & (r.id = i) DO INC(a, 8); r := r.next END END; r := resList; WHILE r # NIL DO n := 0; s := r; WHILE (s # NIL) & (s.typ = r.typ) & (s.id = r.id) DO INC(n); s := s.next END; WriteResDir(0, n); WHILE r # s DO WriteResDirEntry(r.lid, a, FALSE); INC(a, 16); r := r.next END END; ASSERT(a = resHSize); IF numId[0] > 0 THEN INC(a, nsize) END; (* TYPELIB string *) r := resList; WHILE r # NIL DO Write4(a + RsrcRva); INC(a, (r.size + 3) DIV 4 * 4); Write4(r.size); Write4(0); Write4(0); r := r.next END; ASSERT(a = RsrcSize); IF numId[0] > 0 THEN Write2(nlen); i := 0; WHILE rsrcName[i] # 0X DO Write2(ORD(rsrcName[i])); INC(i) END END; r := resList; WHILE r # NIL DO IF r.typ = 4 THEN (* menu *) Write2(0); Write2(0); WriteMenu(r.local); WHILE Ro.Pos() MOD 4 # 0 DO WriteCh(0X) END ELSIF r.typ = 9 THEN (* accelerator *) s := r.local; WHILE s # NIL DO i := 0; a := 0; IF 10 IN s.opts THEN INC(a, 4) END; (* * shift *) IF 16 IN s.opts THEN INC(a, 8) END; (* ^ ctrl *) IF 0 IN s.opts THEN INC(a, 16) END; (* @ alt *) IF 13 IN s.opts THEN INC(a, 2) END; (* - noinv *) IF s.next = NIL THEN INC(a, 80H) END; IF (s.name[0] = "v") & (s.name[1] # 0X) THEN s.name[0] := " "; Strings.StringToInt(s.name, x, n); INC(a, 1) ELSE x := ORD(s.name[0]) END; Write2(a); Write2(x); Write2(s.id); Write2(0); s := s.next END ELSE r.file := ThisResFile(r.name); IF r.file # NIL THEN R := r.file.NewReader(R); R.SetPos(r.pos); i := 0; IF r.typ = 12 THEN (* cursor group *) Read4(x); Write4(x); Read2(n); Write2(n); WHILE i < n DO Read4(x); Write2(x MOD 256); Write2(x DIV 256 MOD 256 * 2); Write2(1); Write2(1); Read4(x); (* ??? *) Read4(x); Write4(x + 4); Read4(x); Write2(r.id * 10 + i); INC(i) END; IF ~ODD(n) THEN Write2(0) END ELSIF r.typ = 14 THEN (* icon group *) Read4(x); Write4(x); Read2(n); Write2(n); WHILE i < n DO Read2(x); Write2(x); Read2(x); IF (13 IN r.opts) & (x = 16) THEN x := 4 END; Write2(x); a := x MOD 256; Read4(x); Write2(1); IF a <= 2 THEN Write2(1) ELSIF a <= 4 THEN Write2(2) ELSIF a <= 16 THEN Write2(4) ELSE Write2(8) END; Read4(x); IF (13 IN r.opts) & (x = 744) THEN x := 440 END; IF (13 IN r.opts) & (x = 296) THEN x := 184 END; Write4(x); Read4(x); Write2(r.id * 10 + i); INC(i) END; IF ~ODD(n) THEN Write2(0) END ELSE IF r.typ = 1 THEN Write2(r.x); Write2(r.y); i := 4 END; (* cursor hot spot *) WHILE i < r.size DO Read4(x); Write4(x); INC(i, 4) END END; r.file.Close; r.file := NIL END END; r := r.next END END WriteResource; PROCEDURE Insert(VAR name: ARRAY OF SHORTCHAR; VAR idx: INTEGER; hint: INTEGER); VAR i: INTEGER; BEGIN IF hint >= 0 THEN ntab[idx] := SHORT(CHR(hint)); INC(idx); ntab[idx] := SHORT(CHR(hint DIV 256)); INC(idx); END; i := 0; WHILE name[i] # 0X DO ntab[idx] := name[i]; INC(idx); INC(i) END; IF (hint = -1) & ((ntab[idx-4] # ".") OR (CAP(ntab[idx-3]) # "D") OR (CAP(ntab[idx-2]) # "L") OR (CAP(ntab[idx-1]) # "L")) THEN ntab[idx] := "."; INC(idx); ntab[idx] := "d"; INC(idx); ntab[idx] := "l"; INC(idx); ntab[idx] := "l"; INC(idx); END; ntab[idx] := 0X; INC(idx); IF ODD(idx) THEN ntab[idx] := 0X; INC(idx) END END Insert; PROCEDURE WriteImport; VAR i, lt, at, nt, ai, ni: INTEGER; mod: Module; exp: Export; ss: ARRAY 256 OF SHORTCHAR; BEGIN IF numImp > 0 THEN NEW(atab, numImp) END; IF numExp > numImp THEN i := numExp ELSE i := numImp END; IF i > 0 THEN NEW(ntab, 40 * i) END; at := ImpRva + ImpHSize; ai := 0; ni := 0; lt := ImpRva + ImpSize; nt := lt + ImpSize - ImpHSize; mod := modList; WHILE mod # NIL DO IF mod.dll THEN Write4(lt); (* lookup table rva *) Write4(0); (* time/data (always 0) *) Write4(0); (* version (always 0) *) Write4(nt + ni); (* name rva *) ss := SHORT(mod.name$); Insert(ss, ni, -1); Write4(at); (* addr table rva *) exp := mod.exp; WHILE exp # NIL DO atab[ai] := nt + ni; (* hint/name rva *) Insert(exp.name, ni, 0); INC(lt, 4); INC(at, 4); INC(ai); exp := exp.next END; atab[ai] := 0; INC(lt, 4); INC(at, 4); INC(ai) END; mod := mod.next END; Write4(0); Write4(0); Write4(0); Write4(0); Write4(0); i := 0; WHILE i < ai DO Write4(atab[i]); INC(i) END; (* address table *) i := 0; WHILE i < ai DO Write4(atab[i]); INC(i) END; (* lookup table *) i := 0; WHILE i < ni DO WriteCh(ntab[i]); INC(i) END; ASSERT(ai * 4 = ImpSize - ImpHSize); INC(ImpSize, ai * 4 + ni); ExpRva := ImpRva + (ImpSize + (ObjAlign - 1)) DIV ObjAlign * ObjAlign; RelocRva := ExpRva; END WriteImport; PROCEDURE WriteExport (VAR name: ARRAY OF CHAR); VAR i, ni: INTEGER; e: Export; ss: ARRAY 256 OF SHORTCHAR; BEGIN Write4(0); (* flags *) Write4(timeStamp); (* time stamp *) Write4(0); (* version *) Write4(ExpRva + 40 + 10 * numExp); (* name rva *) Write4(1); (* ordinal base *) Write4(numExp); (* # entries *) Write4(numExp); (* # name ptrs *) Write4(ExpRva + 40); (* address table rva *) Write4(ExpRva + 40 + 4 * numExp); (* name ptr table rva *) Write4(ExpRva + 40 + 8 * numExp); (* ordinal table rva *) ExpSize := 40 + 10 * numExp; (* adress table *) e := firstExp; WHILE e # NIL DO Write4(e.adr); e := e.next END; (* name ptr table *) ni := 0; e := firstExp; ss := SHORT(name$); Insert(ss, ni, -2); WHILE e # NIL DO Write4(ExpRva + ExpSize + ni); Insert(e.name, ni, -2); e := e.next END; (* ordinal table *) i := 0; WHILE i < numExp DO Write2(i); INC(i) END; (* name table *) i := 0; WHILE i < ni DO WriteCh(ntab[i]); INC(i) END; ExpSize := (ExpSize + ni + 15) DIV 16 * 16; RelocRva := ExpRva + (ExpSize + (ObjAlign - 1)) DIV ObjAlign * ObjAlign; END WriteExport; PROCEDURE Sort (l, r: INTEGER); VAR i, j, x, t: INTEGER; BEGIN i := l; j := r; x := fixups[(l + r) DIV 2]; REPEAT WHILE fixups[i] < x DO INC(i) END; WHILE fixups[j] > x DO DEC(j) END; IF i <= j THEN t := fixups[i]; fixups[i] := fixups[j]; fixups[j] := t; INC(i); DEC(j) END UNTIL i > j; IF l < j THEN Sort(l, j) END; IF i < r THEN Sort(i, r) END END Sort; PROCEDURE WriteReloc; VAR i, j, h, a, p: INTEGER; BEGIN Sort(0, noffixup - 1); i := 0; WHILE i < noffixup DO p := fixups[i] DIV 4096 * 4096; j := i; a := p + 4096; WHILE (j < noffixup) & (fixups[j] < a) DO INC(j) END; Write4(p - ImageBase); (* page rva *) h := 8 + 2 * (j - i); Write4(h + h MOD 4); (* block size *) INC(RelocSize, h); WHILE i < j DO Write2(fixups[i] - p + 3 * 4096); INC(i) END; (* long fix *) IF h MOD 4 # 0 THEN Write2(0); INC(RelocSize, 2) END END; Write4(0); Write4(0); INC(RelocSize, 8); ImagesSize := RelocRva + (RelocSize + (ObjAlign - 1)) DIV ObjAlign * ObjAlign; END WriteReloc; PROCEDURE Align(VAR pos: INTEGER); BEGIN WHILE Ro.Pos() MOD FileAlign # 0 DO WriteCh(0X) END; pos := Ro.Pos() END Align; PROCEDURE WriteOut (VAR name: Files.Name); VAR res, codepos, conpos, rsrcpos, imppos, exppos, relpos, relend, end: INTEGER; BEGIN IF ~error THEN Align(codepos); WriteCode END; IF ~error THEN Align(conpos); WriteConst END; IF ~error THEN Align(rsrcpos); WriteResource END; IF ~error THEN Align(imppos); WriteImport END; IF ~error & isDll THEN Align(exppos); WriteExport(name) END; IF ~error THEN Align(relpos); WriteReloc END; relend := Ro.Pos() - 8; Align(end); IF ~error THEN Ro.SetPos(entryPos); Write4(CodeRva); Ro.SetPos(isPos); Write4(ImagesSize); IF isDll THEN Ro.SetPos(hexpPos); Write4(ExpRva); Write4(ExpSize); END; Ro.SetPos(himpPos); Write4(ImpRva); Write4(ImpHSize); Ro.SetPos(hrsrcPos); Write4(RsrcRva); Write4(RsrcSize); Ro.SetPos(fixPos); Write4(RelocRva); Write4(relend - relpos); Ro.SetPos(codePos); Write4(CodeRva); Write4(conpos - HeaderSize); Write4(HeaderSize); Ro.SetPos(dataPos); Write4(DataRva); Write4((DataSize + (FileAlign-1)) DIV FileAlign * FileAlign); Ro.SetPos(conPos); Write4(ConRva); Write4(rsrcpos - conpos); Write4(conpos); Ro.SetPos(rsrcPos); Write4(RsrcRva); Write4(imppos - rsrcpos); Write4(rsrcpos); IF isDll THEN Ro.SetPos(impPos); Write4(ImpRva); Write4(exppos - imppos); Write4(imppos); Ro.SetPos(expPos); Write4(ExpRva); Write4(relpos - exppos); Write4(exppos) ELSE Ro.SetPos(impPos); Write4(ImpRva); Write4(relpos - imppos); Write4(imppos); END; Ro.SetPos(relPos); Write4(RelocRva); Write4(end - relpos); Write4(relpos); IF isStatic THEN Ro.SetPos(termPos); WriteTermCode(modList, 0) ELSIF isDll THEN Ro.SetPos(termPos); WriteTermCode(main, 0) END END; IF ~error THEN Out.Register(name, "exe", Files.ask, res); IF res # 0 THEN error := TRUE END END END WriteOut; (* A. V. Shiryaev: Scanner *) PROCEDURE (VAR S: Scanner) SetPos (x: INTEGER), NEW; BEGIN S.rider.i := x END SetPos; PROCEDURE (VAR S: Scanner) ConnectTo (IN src: ARRAY OF CHAR), NEW; BEGIN NEW(S.rider.s, LEN(src$) + 1); S.rider.s^ := src$; S.rider.i := 0; S.start := 0; S.type := TMEOT END ConnectTo; PROCEDURE (VAR R: ScanRider) ReadPrevChar (VAR ch: CHAR), NEW; BEGIN ch := R.s[R.i] END ReadPrevChar; PROCEDURE (VAR R: ScanRider) ReadChar (VAR ch: CHAR), NEW; BEGIN ch := R.s[R.i]; INC(R.i) END ReadChar; PROCEDURE (VAR R: ScanRider) Pos (): INTEGER, NEW; BEGIN RETURN R.i END Pos; PROCEDURE (VAR S: Scanner) Scan, NEW; VAR j, res: INTEGER; PROCEDURE IsLetter (c: CHAR): BOOLEAN; BEGIN RETURN ((c >= 'A') & (c <= 'Z')) OR ((c >= 'a') & (c <= 'z')) OR (c = '_') END IsLetter; PROCEDURE IsDigit (c: CHAR): BOOLEAN; BEGIN RETURN (c >= '0') & (c <= '9') END IsDigit; BEGIN WHILE (S.rider.i < LEN(S.rider.s$)) & (S.rider.s[S.rider.i] = ' ') DO INC(S.rider.i) END; IF S.rider.i < LEN(S.rider.s$) THEN S.start := S.rider.i; IF IsDigit(S.rider.s[S.rider.i]) THEN j := 0; WHILE (S.rider.i < LEN(S.rider.s$)) & IsDigit(S.rider.s[S.rider.i]) DO S.string[j] := S.rider.s[S.rider.i]; INC(j); INC(S.rider.i) END; S.string[j] := 0X; Strings.StringToInt(S.string, S.int, res); IF res # 0 THEN S.type := TMEOT ELSE S.type := TMInt END ELSIF IsLetter(S.rider.s[S.rider.i]) THEN S.type := TMString; j := 0; WHILE (S.rider.i < LEN(S.rider.s$)) & (IsLetter(S.rider.s[S.rider.i]) OR IsDigit(S.rider.s[S.rider.i])) DO S.string[j] := S.rider.s[S.rider.i]; INC(j); INC(S.rider.i) END; S.string[j] := 0X ELSE S.type := TMChar; S.char := S.rider.s[S.rider.i]; INC(S.rider.i) END ELSE S.type := TMEOT END END Scan; PROCEDURE ScanRes (VAR S: Scanner; end: INTEGER; VAR list: Resource); VAR res, tail: Resource; n: INTEGER; BEGIN tail := NIL; WHILE (S.start < end) & (S.type = TMInt) DO NEW(res); res.id := S.int; S.Scan; IF (S.type = TMChar) & (S.char = "[") THEN S.Scan; IF S.type = TMInt THEN res.lid := S.int; S.Scan END; IF (S.type = TMChar) & (S.char = "]") THEN S.Scan ELSE WriteSString("missing ']'"); error := TRUE END END; WHILE S.type = TMChar DO IF S.char = "@" THEN n := 0 ELSIF S.char = "^" THEN n := 16 ELSIF S.char = "~" THEN n := 17 ELSIF S.char <= "?" THEN n := ORD(S.char) - ORD(" ") END; INCL(res.opts, n); S.Scan END; IF S.type = TMString THEN res.name := S.string$; S.Scan; IF (S.type = TMChar) & (S.char = ".") THEN S.Scan; IF S.type = TMString THEN IF (S.string = "tlb") OR (S.string = "TLB") THEN res.typ := -1 END; Kernel.MakeFileName(res.name, S.string); S.Scan END END; IF (S.type = TMChar) & (S.char = "(") THEN S.Scan; ScanRes(S, end, res.local); IF (S.type = TMChar) & (S.char = ")") THEN S.Scan ELSE WriteSString("missing ')'"); error := TRUE END END; IF tail = NIL THEN list := res ELSE tail.next := res END; tail := res ELSE WriteSString("wrong resource name"); error := TRUE END END; END ScanRes; PROCEDURE LinkIt (IN txt: ARRAY OF CHAR); VAR S: Scanner; name: Files.Name; mod: Module; end: INTEGER; BEGIN comLine := FALSE; modList := NIL; kernel := NIL; main := NIL; last := NIL; impg := NIL; impd := NIL; resList := NIL; firstExp := NIL; lastExp := NIL; NEW(fixups, FixLen); (* Dialog.ShowStatus("linking"); *) Console.WriteStr("linking"); Console.WriteLn; (* timeStamp := TimeStamp(); *) timeStamp := 0; error := FALSE; modList := NIL; resList := NIL; (* IF DevCommanders.par = NIL THEN RETURN END; S.ConnectTo(DevCommanders.par.text); S.SetPos(DevCommanders.par.beg); end := DevCommanders.par.end; DevCommanders.par := NIL; W.ConnectTo(Log.buf); *) S.ConnectTo(txt); S.SetPos(0); end := LEN(txt$); S.Scan; IF S.type = TMString THEN IF S.string = "dos" THEN comLine := TRUE; S.Scan END; name := S.string$; S.Scan; IF (S.type = TMChar) & (S.char = ".") THEN S.Scan; IF S.type = TMString THEN Kernel.MakeFileName(name, S.string); S.Scan END ELSE Kernel.MakeFileName(name, "EXE"); END; IF (S.type = TMChar) & (S.char = ":") THEN S.Scan; IF (S.type = TMChar) & (S.char = "=") THEN S.Scan; WHILE (S.start < end) & (S.type = TMString) DO NEW(mod); mod.name := S.string$; mod.next := modList; modList := mod; S.Scan; WHILE (S.start < end) & (S.type = TMChar) & ((S.char = "*") OR (S.char = "+") OR (S.char = "$") OR (S.char = "#")) DO IF S.char = "*" THEN mod.dll := TRUE ELSIF S.char = "+" THEN kernel := mod ELSIF S.char = "$" THEN main := mod ELSE mod.intf := TRUE; IF ~isDll THEN WriteSString("Exports from Exe not possible. Use LinkDll or LinkDynDll."); WriteLn; FlushW; error := TRUE END END; S.Scan END END; ScanRes(S, end, resList); ReadHeaders; PrepResources; IF ~error THEN WriteHeader(name) END; IF ~error THEN WriteOut(name) END; IF ~error THEN WriteString(name); WriteString(" written "); WriteInt(Out.Length()); WriteString(" "); WriteInt(CodeSize) END ELSE WriteString(" := missing") END ELSE WriteString(" := missing") END; WriteLn; FlushW END; (* IF error THEN Dialog.ShowStatus("failed") ELSE Dialog.ShowStatus("ok") END; W.ConnectTo(NIL); S.ConnectTo(NIL); *) IF error THEN Console.WriteStr("failed") ELSE Console.WriteStr("ok") END; Console.WriteLn; S.ConnectTo(""); modList := NIL; kernel := NIL; main := NIL; firstExp := NIL; lastExp := NIL; last := NIL; impg := NIL; impd := NIL; resList := NIL; code := NIL; atab := NIL; ntab := NIL; fixups := NIL END LinkIt; PROCEDURE Link* (IN txt: ARRAY OF CHAR); BEGIN isDll := FALSE; isStatic := FALSE; LinkIt(txt) END Link; PROCEDURE LinkExe* (IN txt: ARRAY OF CHAR); BEGIN isDll := FALSE; isStatic := TRUE; LinkIt(txt) END LinkExe; PROCEDURE LinkDll* (IN txt: ARRAY OF CHAR); BEGIN isDll := TRUE; isStatic := TRUE; LinkIt(txt) END LinkDll; PROCEDURE LinkDynDll* (IN txt: ARRAY OF CHAR); BEGIN isDll := TRUE; isStatic := FALSE; LinkIt(txt) END LinkDynDll; (* PROCEDURE Show*; VAR S: TextMappers.Scanner; name: Name; mod: Module; t: TextModels.Model; BEGIN t := TextViews.FocusText(); IF t = NIL THEN RETURN END; W.ConnectTo(Log.buf); S.ConnectTo(t); S.Scan; IF S.type = TextMappers.string THEN mod := modList; WHILE (mod # NIL) & (mod.name # S.string) DO mod := mod.next END; IF mod # NIL THEN W.WriteString(S.string); W.WriteString(" ca = "); W.WriteIntForm(CodeBase + mod.ca, TextMappers.hexadecimal, 8, "0", TRUE); W.WriteLn; Log.text.Append(Log.buf) END END; W.ConnectTo(NIL); S.ConnectTo(NIL) END Show; *) BEGIN newRec := "NewRec"; newArr := "NewArr" END Dev0Linker. (!)DevLinker.Link Usekrnl.exe := TestKernel$+ Usekrnl ~ (!)"DevDecExe.Decode('', 'Usekrnl.exe')" (!)DevLinker.LinkDynDll MYDLL.dll := TestKernel+ MYDLL$# ~ (!)"DevDecExe.Decode('', 'MYDLL.dll')" (!)DevLinker.LinkExe Usekrnl.exe := TestKernel+ Usekrnl ~ (!)"DevDecExe.Decode('', 'Usekrnl.exe')" (!)DevLinker.LinkDll MYDLL.dll := TestKernel+ MYDLL# ~ (!)"DevDecExe.Decode('', 'MYDLL.dll')" MODULE TestKernel; IMPORT KERNEL32; PROCEDURE Beep*; BEGIN KERNEL32.Beep(500, 200) END Beep; BEGIN CLOSE KERNEL32.ExitProcess(0) END TestKernel. MODULE Usekrnl; (* empty windows application using BlackBox Kernel *) (* Ominc (!) *) IMPORT KERNEL32, USER32, GDI32, S := SYSTEM, Kernel := TestKernel; VAR Instance, MainWnd: USER32.Handle; PROCEDURE WndHandler (wnd, message, wParam, lParam: INTEGER): INTEGER; VAR res: INTEGER; ps: USER32.PaintStruct; dc: GDI32.Handle; BEGIN IF message = USER32.WMDestroy THEN USER32.PostQuitMessage(0) ELSIF message = USER32.WMPaint THEN dc := USER32.BeginPaint(wnd, ps); res := GDI32.TextOutA(dc, 50, 50, "Hello World", 11); res := USER32.EndPaint(wnd, ps) ELSIF message = USER32.WMChar THEN Kernel.Beep ELSE RETURN USER32.DefWindowProcA(wnd, message, wParam, lParam) END; RETURN 0 END WndHandler; PROCEDURE OpenWindow; VAR class: USER32.WndClass; res: INTEGER; BEGIN class.cursor := USER32.LoadCursorA(0, USER32.MakeIntRsrc(USER32.IDCArrow)); class.icon := USER32.LoadIconA(Instance, USER32.MakeIntRsrc(1)); class.menuName := NIL; class.className := "Simple"; class.backgnd := GDI32.GetStockObject(GDI32.WhiteBrush); class.style := {0, 1, 5, 7}; class.instance := Instance; class.wndProc := WndHandler; class.clsExtra := 0; class.wndExtra := 0; USER32.RegisterClassA(class); MainWnd := USER32.CreateWindowExA({}, "Simple", "Empty Windows Application", {16..19, 22, 23, 25}, USER32.CWUseDefault, USER32.CWUseDefault, USER32.CWUseDefault, USER32.CWUseDefault, 0, 0, Instance, 0); res := USER32.ShowWindow(MainWnd, 10); res := USER32.UpdateWindow(MainWnd); END OpenWindow; PROCEDURE MainLoop; VAR msg: USER32.Message; res: INTEGER; BEGIN WHILE USER32.GetMessageA(msg, 0, 0, 0) # 0 DO res := USER32.TranslateMessage(msg); res := USER32.DispatchMessageA(msg); END; (* KERNEL32.ExitProcess(msg.wParam) *) END MainLoop; BEGIN Instance := KERNEL32.GetModuleHandleA(NIL); OpenWindow; MainLoop CLOSE Kernel.Beep END Usekrnl. MODULE MYDLL; (* sample module to be linked into a dll *) (* Ominc (!) *) IMPORT SYSTEM, KERNEL32; VAR expVar*: INTEGER; PROCEDURE GCD* (a, b: INTEGER): INTEGER; BEGIN WHILE a # b DO IF a < b THEN b := b - a ELSE a := a - b END END; expVar := a; RETURN a END GCD; PROCEDURE Beep*; BEGIN KERNEL32.Beep(500, 200) END Beep; CLOSE Beep END MYDLL. Resource = Id [ "[" Language "]" ] Options name [ "." ext ] [ "(" { Resource } ")" ] Id = number Language = number Options = { "@" | "!" .. "?" | "^" | "~" } names MENU 1 MENU (0 File (11 New 12 Open 13 Save 0 "" 14 Exit) 0 Edit (21 Cut 22 Copy 23 Paste)) = grayed - inctive # bitmap * checked ! menuBarBreak / menuBreak ? ownerDraw ACCELERATOR 1 ACCELERATOR (11 ^N 12 ^O 13 ^S 21 ^X 22 ^C 23 ^V) * shift ^ ctrl @ alt - noInvert filename.ico filename.cur filname.bmp filename.res filename.tlb