Dev/Mod/Linker.odc

MODULE DevLinker;
(**
	project	= "BlackBox"
	organization	= "www.oberon.ch"
	contributors	= "Oberon microsystems"
	version	= "System/Rsrc/About"
	copyright	= "System/Rsrc/About"
	license	= "Docu/BB-License"
	changes	= "
	- YYYYMMDD, nn, ...
	"
	issues	= "
	- ...
	"

**)
	
	IMPORT
		Kernel, Files, Dates, Dialog, Strings,
		TextModels, TextViews, TextMappers,
		Log := StdLog, DevCommanders;
	
	CONST
		NewRecFP = 00000048H;
		NewArrFP = 000004A8H;

		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;
		
	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;
		
	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;
		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;
	
	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
							W.WriteString("variable (");
							W.WriteString(imp.name); W.WriteChar(".");
							W.WriteSString(name);
							W.WriteString(") imported from DLL in ");
							W.WriteString(mod.name);
							W.WriteLn; Log.text.Append(Log.buf); error := TRUE;
							RETURN
						END
					ELSIF x = mTyp THEN RNum(y);
						IF imp.dll THEN
							RNum(y);
							IF y # 0 THEN
								W.WriteString("type descriptor (");
								W.WriteString(imp.name); W.WriteChar(".");
								W.WriteSString(name);
								W.WriteString(") imported from DLL in ");
								W.WriteString(mod.name);
								W.WriteLn; Log.text.Append(Log.buf); 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
										W.WriteSString("no kernel"); W.WriteLn;
										Log.text.Append(Log.buf); 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
										W.WriteSString(name);
										W.WriteString(" not present (imported in ");
										W.WriteString(mod.name); W.WriteChar(")");
										W.WriteLn; Log.text.Append(Log.buf); 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
						W.WriteString(mod.name); W.WriteString(": wrong file type"); 
						W.WriteLn; Log.text.Append(Log.buf); error := TRUE
					END;
					mod.file.Close; mod.file := NIL
				ELSE
					W.WriteString(mod.name); W.WriteString(" not found"); 
					W.WriteLn; Log.text.Append(Log.buf); error := TRUE
				END;
				last := mod
			END;
			mod := mod.next
		END;
		IF ~isStatic & (main = NIL) THEN
			W.WriteSString("no main module specified"); W.WriteLn;
			Log.text.Append(Log.buf); 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;
	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
					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); Read2(j);
									IF (i = 0FFFFH) & (j >= 4) & ((j <= 11) OR (j = 16)) THEN
										r.typ := j; r.pos := n + 32;
									ELSE
										W.WriteString(r.name); W.WriteString(": invalid type"); W.WriteLn;
										Log.text.Append(Log.buf); error := TRUE
									END
								ELSE
									W.WriteString(r.name); W.WriteString(": unknown type"); W.WriteLn;
									Log.text.Append(Log.buf); error := TRUE
								END
							END
						END
					END;
					r.file.Close; r.file := NIL
				ELSE
					W.WriteString(r.name); W.WriteString(" not found"); W.WriteLn;
					Log.text.Append(Log.buf); 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, 16) 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
								W.WriteString(mod.name); W.WriteChar("."); W.WriteSString(name);
								W.WriteString(" imported from "); W.WriteString(impg.name);
								W.WriteString(" has wrong visibility"); W.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
							IF opt = -1 THEN adr := -1
							ELSE
								W.WriteString(mod.name); W.WriteChar("."); W.WriteSString(name);
								W.WriteString(" imported from "); W.WriteString(impg.name);
								W.WriteString(" has wrong fprint"); W.WriteLn; error := TRUE
							END
						END
					ELSE
						IF opt = -1 THEN adr := -1
						ELSE
							W.WriteString(mod.name); W.WriteChar("."); W.WriteSString(name);
							W.WriteString(" imported from "); W.WriteString(impg.name);
							W.WriteString(" has wrong class"); W.WriteLn; error := TRUE
						END
					END;
					RETURN
				END;
				IF och < nch THEN l := n + 1 ELSE r := n END
			END;
			IF opt = -1 THEN adr := -1
			ELSE
				W.WriteString(mod.name); W.WriteChar("."); W.WriteSString(name);
				W.WriteString(" not found (imported from "); W.WriteString(impg.name);
				W.WriteChar(")"); W.WriteLn; error := TRUE
			END
		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;
			W.WriteString("anonymous type in "); W.WriteString(mod.name);
			W.WriteString(" not found"); W.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;
				SearchObj(m, terminator, mProc, terminatorFP, -1, x);
				IF x = -1 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 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, 0, a); Fixup0(x, a)
					ELSE
						W.WriteSString("no kernel"); W.WriteLn;
						Log.text.Append(Log.buf); error := TRUE; RETURN
					END
				END;
				RNum(x);
				IF x # 0 THEN
					IF (mod # kernel) & (kernel # NIL) THEN
						SearchObj(kernel, newArr, mProc, NewArrFP, 0, a); Fixup0(x, a)
					ELSE
						W.WriteSString("no kernel"); W.WriteLn;
						Log.text.Append(Log.buf); 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: INTEGER;
	BEGIN
		IF numId[0] > 0 THEN WriteResDir(1, numType - 1)
		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, 16) 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(7); Write2(ORD("T")); Write2(ORD("Y")); Write2(ORD("P"));
			Write2(ORD("E")); Write2(ORD("L")); Write2(ORD("I")); Write2(ORD("B"))
		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;
	
	PROCEDURE ScanRes (VAR S: TextMappers.Scanner; end: INTEGER; VAR list: Resource);
		VAR res, tail: Resource; n: INTEGER;
	BEGIN
		tail := NIL;
		WHILE (S.start < end) & (S.type = TextMappers.int) DO
			NEW(res); res.id := S.int; S.Scan;
			IF (S.type = TextMappers.char) & (S.char = "[") THEN
				S.Scan;
				IF S.type = TextMappers.int THEN res.lid := S.int; S.Scan END;
				IF (S.type = TextMappers.char) & (S.char = "]") THEN S.Scan
				ELSE W.WriteSString("missing ']'"); error := TRUE
				END
			END;
			WHILE S.type = TextMappers.char 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 = TextMappers.string THEN
				res.name := S.string$; S.Scan;
				IF (S.type = TextMappers.char) & (S.char = ".") THEN S.Scan;
					IF S.type = TextMappers.string 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 = TextMappers.char) & (S.char = "(") THEN S.Scan;
					ScanRes(S, end, res.local);
					IF (S.type = TextMappers.char) & (S.char = ")") THEN S.Scan
					ELSE W.WriteSString("missing ')'"); error := TRUE
					END
				END;
				IF tail = NIL THEN list := res ELSE tail.next := res END;
				tail := res
			ELSE
				W.WriteSString("wrong resource name"); error := TRUE
			END
		END;
	END ScanRes;

	PROCEDURE LinkIt;
		VAR S: TextMappers.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");
		timeStamp := TimeStamp();
		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.Scan;
		IF S.type = TextMappers.string THEN
			IF S.string = "dos" THEN comLine := TRUE; S.Scan END;
			name := S.string$; S.Scan;
			IF (S.type = TextMappers.char) & (S.char = ".") THEN S.Scan;
				IF S.type = TextMappers.string THEN
					Kernel.MakeFileName(name, S.string); S.Scan
				END
			ELSE Kernel.MakeFileName(name, "EXE");
			END;
			IF (S.type = TextMappers.char) & (S.char = ":") THEN S.Scan;
				IF (S.type = TextMappers.char) & (S.char = "=") THEN S.Scan;
					WHILE (S.start < end) & (S.type = TextMappers.string) DO
						NEW(mod); mod.name := S.string$;
						mod.next := modList; modList := mod;
						S.Scan;
						WHILE (S.start < end) & (S.type = TextMappers.char) &
							((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
									W.WriteSString("Exports from Exe not possible. Use LinkDll or LinkDynDll.");
									W.WriteLn; Log.text.Append(Log.buf); 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	
						W.WriteString(name); W.WriteString(" written  ");
						W.WriteInt(Out.Length()); W.WriteString("  "); W.WriteInt(CodeSize)
					END
				ELSE W.WriteString(" := missing")
				END
			ELSE W.WriteString(" := missing")
			END;
			W.WriteLn; Log.text.Append(Log.buf)
		END;
		IF error THEN Dialog.ShowStatus("failed") ELSE Dialog.ShowStatus("ok") END;
		W.ConnectTo(NIL); S.ConnectTo(NIL);
		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*;
	BEGIN
		isDll := FALSE; isStatic := FALSE;
		LinkIt
	END Link;
	
	PROCEDURE LinkExe*;
	BEGIN
		isDll := FALSE; isStatic := TRUE;
		LinkIt
	END LinkExe;
	
	PROCEDURE LinkDll*;
	BEGIN
		isDll := TRUE; isStatic := TRUE;
		LinkIt
	END LinkDll;
	
	PROCEDURE LinkDynDll*;
	BEGIN
		isDll := TRUE; isStatic := FALSE;
		LinkIt
	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 DevLinker.


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