874bf1a0bb9e4f0bd7b36b5c3c44d85ada99064e
1 MODULE Dev0Linker;
3 (* THIS IS TEXT COPY OF Linker.odc *)
4 (* DO NOT EDIT *)
6 IMPORT
7 Kernel, Files, (* Dates, Dialog, *) Strings,
8 (* TextModels, TextViews, TextMappers,
9 Log := StdLog, DevCommanders *) Console;
11 CONST
12 NewRecFP = 4E27A847H;
13 NewArrFP = 76068C78H;
15 ImageBase = 00400000H;
16 ObjAlign = 1000H;
17 FileAlign = 200H;
18 HeaderSize = 400H;
20 FixLen = 30000;
22 OFdir = "Code";
23 SYSdir = "System";
24 RsrcDir = "Rsrc";
25 WinDir = "Win";
27 (* meta interface consts *)
28 mConst = 1; mTyp = 2; mVar = 3; mProc = 4; mField = 5;
29 mInternal = 1; mReadonly = 2; mExported = 4;
31 (* fixup types *)
32 absolute = 100; relative = 101; copy = 102; table = 103; tableend = 104;
34 (* mod desc fields *)
35 modOpts = 4; modRefcnt = 8; modTerm = 40; modNames = 84; modImports = 92; modExports = 96;
38 (* A. V. Shiryaev: Scanner *)
39 TMChar = 0; TMString = 1; TMInt = 2; TMEOT = 3;
41 TYPE
42 Name = ARRAY 40 OF SHORTCHAR;
43 Export = POINTER TO RECORD
44 next: Export;
45 name: Name;
46 adr: INTEGER
47 END;
48 Resource = POINTER TO RECORD
49 next, local: Resource;
50 typ, id, lid, size, pos, x, y: INTEGER;
51 opts: SET;
52 file: Files.File;
53 name: Files.Name
54 END;
55 Module = POINTER TO RECORD
56 next: Module;
57 name: Files.Name;
58 file: Files.File;
59 hs, ms, ds, cs, vs, ni, ma, ca, va: INTEGER;
60 dll, intf: BOOLEAN;
61 exp: Export;
62 imp: POINTER TO ARRAY OF Module;
63 data: POINTER TO ARRAY OF BYTE;
64 END;
66 (* A. V. Shiryaev: Scanner *)
67 ScanRider = RECORD
68 s: POINTER TO ARRAY OF CHAR;
69 i: INTEGER
70 END;
71 Scanner = RECORD
72 rider: ScanRider;
73 start, type: INTEGER;
75 string: ARRAY 100 OF CHAR;
76 char: CHAR;
77 int: INTEGER
78 END;
80 VAR
81 (*
82 W: TextMappers.Formatter;
83 *)
84 Out: Files.File;
85 R: Files.Reader;
86 Ro: Files.Writer;
87 error, isDll, isStatic, comLine: BOOLEAN;
88 modList, kernel, main, last, impg, impd: Module;
89 numMod, lastTerm: INTEGER;
90 resList: Resource;
91 numType, resHSize: INTEGER;
92 numId: ARRAY 32 OF INTEGER;
93 rsrcName: ARRAY 16 OF CHAR; (* name of resource file *)
94 firstExp, lastExp: Export;
95 entryPos, isPos, fixPos, himpPos, hexpPos, hrsrcPos, termPos: INTEGER;
96 codePos, dataPos, conPos, rsrcPos, impPos, expPos, relPos: INTEGER;
97 CodeSize, DataSize, ConSize, RsrcSize, ImpSize, ImpHSize, ExpSize, RelocSize, DllSize: INTEGER;
98 CodeRva, DataRva, ConRva, RsrcRva, ImpRva, ExpRva, RelocRva, ImagesSize: INTEGER;
99 CodeBase, DataBase, ConBase, maxCode, numImp, numExp, noffixup, timeStamp: INTEGER;
100 newRec, newArr: Name;
101 fixups: POINTER TO ARRAY OF INTEGER;
102 code: POINTER TO ARRAY OF BYTE;
103 atab: POINTER TO ARRAY OF INTEGER;
104 ntab: POINTER TO ARRAY OF SHORTCHAR;
106 (* A. V. Shiryaev: Console *)
108 PROCEDURE WriteString (s: ARRAY OF CHAR);
109 BEGIN
110 Console.WriteStr(s)
111 END WriteString;
113 PROCEDURE WriteChar (c: CHAR);
114 VAR s: ARRAY 2 OF CHAR;
115 BEGIN
116 s[0] := c; s[1] := 0X;
117 Console.WriteStr(s)
118 END WriteChar;
120 PROCEDURE WriteSString (ss: ARRAY OF SHORTCHAR);
121 BEGIN
122 Console.WriteStr(ss$)
123 END WriteSString;
125 PROCEDURE WriteInt (x: INTEGER);
126 VAR s: ARRAY 16 OF CHAR;
127 BEGIN
128 Strings.IntToString(x, s);
129 Console.WriteStr(s)
130 END WriteInt;
132 PROCEDURE WriteLn;
133 BEGIN
134 Console.WriteLn
135 END WriteLn;
137 PROCEDURE FlushW;
138 BEGIN
139 END FlushW;
141 (*
142 PROCEDURE TimeStamp (): INTEGER; (* seconds since 1.1.1970 00:00:00 *)
143 VAR a: INTEGER; t: Dates.Time; d: Dates.Date;
144 BEGIN
145 Dates.GetTime(t); Dates.GetDate(d);
146 a := 12 * (d.year - 70) + d.month - 3;
147 a := a DIV 12 * 1461 DIV 4 + (a MOD 12 * 153 + 2) DIV 5 + d.day + 59;
148 RETURN ((a * 24 + t.hour) * 60 + t.minute) * 60 + t.second;
149 END TimeStamp;
150 *)
152 PROCEDURE ThisFile (modname: ARRAY OF CHAR): Files.File;
153 VAR dir, name: Files.Name; loc: Files.Locator; f: Files.File;
154 BEGIN
155 Kernel.SplitName(modname, dir, name);
156 Kernel.MakeFileName(name, Kernel.objType);
157 loc := Files.dir.This(dir); loc := loc.This(OFdir);
158 f := Files.dir.Old(loc, name, TRUE);
159 IF (f = NIL) & (dir = "") THEN
160 loc := Files.dir.This(SYSdir); loc := loc.This(OFdir);
161 f := Files.dir.Old(loc, name, TRUE)
162 END;
163 RETURN f
164 END ThisFile;
166 PROCEDURE ThisResFile (VAR name: Files.Name): Files.File;
167 VAR loc: Files.Locator; f: Files.File;
168 BEGIN
169 f := Files.dir.Old(Files.dir.This(RsrcDir), name, TRUE);
170 IF f = NIL THEN
171 loc := Files.dir.This(WinDir); loc := loc.This(RsrcDir);
172 f := Files.dir.Old(loc, name, TRUE);
173 IF f = NIL THEN
174 f := Files.dir.Old(Files.dir.This(""), name, TRUE)
175 END
176 END;
177 RETURN f
178 END ThisResFile;
180 PROCEDURE Read2 (VAR x: INTEGER);
181 VAR b: BYTE;
182 BEGIN
183 R.ReadByte(b); x := b MOD 256;
184 R.ReadByte(b); x := x + 100H * (b MOD 256)
185 END Read2;
187 PROCEDURE Read4 (VAR x: INTEGER);
188 VAR b: BYTE;
189 BEGIN
190 R.ReadByte(b); x := b MOD 256;
191 R.ReadByte(b); x := x + 100H * (b MOD 256);
192 R.ReadByte(b); x := x + 10000H * (b MOD 256);
193 R.ReadByte(b); x := x + 1000000H * b
194 END Read4;
196 PROCEDURE ReadName (VAR name: ARRAY OF SHORTCHAR);
197 VAR i: INTEGER; b: BYTE;
198 BEGIN i := 0;
199 REPEAT
200 R.ReadByte(b); name[i] := SHORT(CHR(b)); INC(i)
201 UNTIL b = 0
202 END ReadName;
204 PROCEDURE RNum (VAR i: INTEGER);
205 VAR b: BYTE; s, y: INTEGER;
206 BEGIN
207 s := 0; y := 0; R.ReadByte(b);
208 WHILE b < 0 DO INC(y, ASH(b + 128, s)); INC(s, 7); R.ReadByte(b) END;
209 i := ASH((b + 64) MOD 128 - 64, s) + y
210 END RNum;
212 PROCEDURE WriteCh (ch: SHORTCHAR);
213 BEGIN
214 Ro.WriteByte(SHORT(ORD(ch)))
215 END WriteCh;
217 PROCEDURE Write2 (x: INTEGER);
218 BEGIN
219 Ro.WriteByte(SHORT(SHORT(x MOD 256))); x := x DIV 256;
220 Ro.WriteByte(SHORT(SHORT(x MOD 256)))
221 END Write2;
223 PROCEDURE Write4 (x: INTEGER);
224 BEGIN
225 Ro.WriteByte(SHORT(SHORT(x MOD 256))); x := x DIV 256;
226 Ro.WriteByte(SHORT(SHORT(x MOD 256))); x := x DIV 256;
227 Ro.WriteByte(SHORT(SHORT(x MOD 256))); x := x DIV 256;
228 Ro.WriteByte(SHORT(SHORT(x MOD 256)))
229 END Write4;
231 PROCEDURE WriteName (s: ARRAY OF SHORTCHAR; len: SHORTINT);
232 VAR i: SHORTINT;
233 BEGIN i := 0;
234 WHILE s[i] # 0X DO Ro.WriteByte(SHORT(ORD(s[i]))); INC(i) END;
235 WHILE i < len DO Ro.WriteByte(0); INC(i) END
236 END WriteName;
238 PROCEDURE Reloc (a: INTEGER);
239 VAR p: POINTER TO ARRAY OF INTEGER; i: INTEGER;
240 BEGIN
241 IF noffixup >= LEN(fixups) THEN
242 NEW(p, 2 * LEN(fixups));
243 i := 0; WHILE i < LEN(fixups) DO p[i] := fixups[i]; INC(i) END;
244 fixups := p
245 END;
246 fixups[noffixup] := a; INC(noffixup)
247 (*
248 ELSE
249 IF ~error THEN W.WriteSString(" too many fixups") END;
250 error := TRUE
251 END
252 *)
253 END Reloc;
255 PROCEDURE Put (mod: Module; a, x: INTEGER);
256 BEGIN
257 mod.data[a] := SHORT(SHORT(x)); INC(a); x := x DIV 256;
258 mod.data[a] := SHORT(SHORT(x)); INC(a); x := x DIV 256;
259 mod.data[a] := SHORT(SHORT(x)); INC(a); x := x DIV 256;
260 mod.data[a] := SHORT(SHORT(x))
261 END Put;
263 PROCEDURE Get (mod: Module; a: INTEGER; VAR x: INTEGER);
264 BEGIN
265 x := ((mod.data[a + 3] * 256 +
266 (mod.data[a + 2] MOD 256)) * 256 +
267 (mod.data[a + 1] MOD 256)) * 256 +
268 (mod.data[a] MOD 256)
269 END Get;
271 PROCEDURE GenName (VAR from, to: ARRAY OF SHORTCHAR; ext: ARRAY OF SHORTCHAR);
272 VAR i, j: INTEGER;
273 BEGIN
274 i := 0;
275 WHILE from[i] # 0X DO to[i] := from[i]; INC(i) END;
276 IF ext # "" THEN
277 to[i] := "."; INC(i); j := 0;
278 WHILE ext[j] # 0X DO to[i] := ext[j]; INC(i); INC(j) END
279 END;
280 to[i] := 0X
281 END GenName;
283 PROCEDURE Fixup0 (link, adr: INTEGER);
284 VAR offset, linkadr, t, n, x: INTEGER;
285 BEGIN
286 WHILE link # 0 DO
287 RNum(offset);
288 WHILE link # 0 DO
289 IF link > 0 THEN
290 n := (code[link] MOD 256) + (code[link+1] MOD 256) * 256 + code[link+2] * 65536;
291 t := code[link+3]; linkadr := CodeBase + impg.ca + link
292 ELSE
293 n := (impg.data[-link] MOD 256) + (impg.data[-link+1] MOD 256) * 256 + impg.data[-link+2] * 65536;
294 t := impg.data[-link+3]; linkadr := ConBase + impg.ma - link
295 END;
296 IF t = absolute THEN x := adr + offset
297 ELSIF t = relative THEN x := adr + offset - linkadr - 4
298 ELSIF t = copy THEN Get(impd, adr + offset - ConBase - impd.ma, x)
299 ELSIF t = table THEN x := adr + n; n := link + 4
300 ELSIF t = tableend THEN x := adr + n; n := 0
301 ELSE HALT(99)
302 END;
303 IF link > 0 THEN
304 code[link] := SHORT(SHORT(x));
305 code[link+1] := SHORT(SHORT(x DIV 100H));
306 code[link+2] := SHORT(SHORT(x DIV 10000H));
307 code[link+3] := SHORT(SHORT(x DIV 1000000H))
308 ELSE
309 link := -link;
310 impg.data[link] := SHORT(SHORT(x));
311 impg.data[link+1] := SHORT(SHORT(x DIV 100H));
312 impg.data[link+2] := SHORT(SHORT(x DIV 10000H));
313 impg.data[link+3] := SHORT(SHORT(x DIV 1000000H))
314 END;
315 IF (t # relative) & ((t # copy) OR (x DIV 65536 # 0)) THEN Reloc(linkadr) END;
316 link := n
317 END;
318 RNum(link)
319 END
320 END Fixup0;
322 PROCEDURE Fixup (adr: INTEGER);
323 VAR link: INTEGER;
324 BEGIN
325 RNum(link); Fixup0(link, adr)
326 END Fixup;
328 PROCEDURE CheckDllImports (mod: Module);
329 VAR i, x, y: INTEGER; name: Name; imp: Module; exp: Export;
331 PROCEDURE SkipLink;
332 VAR a: INTEGER;
333 BEGIN
334 RNum(a);
335 WHILE a # 0 DO RNum(a); RNum(a) END
336 END SkipLink;
338 BEGIN
339 R := mod.file.NewReader(R);
340 R.SetPos(mod.hs + mod.ms + mod.ds + mod.cs);
341 SkipLink; SkipLink; SkipLink; SkipLink; SkipLink; SkipLink; i := 0;
342 WHILE i < mod.ni DO
343 imp := mod.imp[i];
344 IF imp # NIL THEN
345 RNum(x);
346 WHILE x # 0 DO
347 ReadName(name); RNum(y);
348 IF x = mVar THEN SkipLink;
349 IF imp.dll THEN
350 WriteString("variable (");
351 WriteString(imp.name); WriteChar(".");
352 WriteSString(name);
353 WriteString(") imported from DLL in ");
354 WriteString(mod.name);
355 WriteLn; FlushW; error := TRUE;
356 RETURN
357 END
358 ELSIF x = mTyp THEN RNum(y);
359 IF imp.dll THEN
360 RNum(y);
361 IF y # 0 THEN
362 WriteString("type descriptor (");
363 WriteString(imp.name); WriteChar(".");
364 WriteSString(name);
365 WriteString(") imported from DLL in ");
366 WriteString(mod.name);
367 WriteLn; FlushW; error := TRUE;
368 RETURN
369 END
370 ELSE SkipLink
371 END
372 ELSIF x = mProc THEN
373 IF imp.dll THEN
374 SkipLink; exp := imp.exp;
375 WHILE (exp # NIL) & (exp.name # name) DO exp := exp.next END;
376 IF exp = NIL THEN
377 NEW(exp); exp.name := name$;
378 exp.next := imp.exp; imp.exp := exp; INC(DllSize, 6)
379 END
380 END
381 END;
382 RNum(x)
383 END
384 END;
385 INC(i)
386 END
387 END CheckDllImports;
389 PROCEDURE ReadHeaders;
390 VAR mod, im, t: Module; x, i: INTEGER; impdll: BOOLEAN; exp: Export; name: Name;
391 BEGIN
392 mod := modList; modList := NIL; numMod := 0;
393 WHILE mod # NIL DO (* reverse mod list & count modules *)
394 IF ~mod.dll THEN INC(numMod) END;
395 t := mod; mod := t.next; t.next := modList; modList := t
396 END;
397 IF isStatic THEN
398 IF isDll THEN
399 (* push ebx; cmp [12, esp], 1; jne L1; mov ebx, modlist; { call body; } jp L2 *)
400 (* L1: cmp [12, esp], 0; jne L2; { call term; } *)
401 (* L2: pop ebx; mov aex,1; ret 12 *)
402 CodeSize := 42 + 10 * numMod
403 ELSE
404 (* push ebx; push ebx; push ebx; mov ebx, modlist; { call body; } { call term; } *)
405 (* pop ebx; pop ebx; pop ebx; ret *)
406 CodeSize := 12 + 10 * numMod
407 END
408 ELSE
409 IF isDll THEN
410 (* push ebx; cmp [12, esp], 1; jne L1; mov ebx, modlist; call main; jp L2 *)
411 (* L1: cmp [12, esp], 0; jne L2; call mainTerm; *)
412 (* L2: pop ebx; mov aex,1; ret 12 *)
413 CodeSize := 41
414 ELSE
415 (* mov ebx, modlist; jmp main *)
416 CodeSize := 10
417 END
418 END;
419 (*
420 IF isDll THEN
421 CodeSize := 24 (* push ebx, esi, edi; mov bx, modlist; call main; pop edi, esi, ebx; mov aex,1; ret 12 *)
422 ELSE
423 CodeSize := 10 (* mov bx, modlist; jmp main *)
424 END
425 *)
426 DataSize := 0; ConSize := 0;
427 ImpSize := 0; ImpHSize := 0; ExpSize := 0;
428 RelocSize := 0; DllSize := 0; noffixup := 0; maxCode := 0; numImp := 0; numExp := 0;
429 mod := modList;
430 WHILE mod # NIL DO
431 IF ~mod.dll THEN
432 mod.file := ThisFile(mod.name);
433 IF mod.file # NIL THEN
434 R := mod.file.NewReader(R); R.SetPos(0); Read4(x);
435 IF x = 6F4F4346H THEN
436 Read4(x);
437 Read4(mod.hs); Read4(mod.ms); Read4(mod.ds); Read4(mod.cs);
438 Read4(mod.vs); RNum(mod.ni); ReadName(name); impdll := FALSE;
439 IF mod.ni > 0 THEN
440 NEW(mod.imp, mod.ni); x := 0;
441 WHILE x < mod.ni DO
442 ReadName(name);
443 IF name = "$$" THEN
444 IF (mod # kernel) & (kernel # NIL) THEN
445 mod.imp[x] := kernel
446 ELSE
447 WriteSString("no kernel"); WriteLn;
448 FlushW; error := TRUE
449 END
450 ELSIF name[0] = "$" THEN
451 i := 1;
452 WHILE name[i] # 0X DO name[i-1] := name[i]; INC(i) END;
453 name[i-1] := 0X; impdll := TRUE; im := modList;
454 WHILE (im # mod) & (im.name # name) DO im := im.next END;
455 IF (im = NIL) OR ~im.dll THEN
456 NEW(im); im.next := modList; modList := im;
457 im.name := name$;
458 im.dll := TRUE
459 END;
460 mod.imp[x] := im;
461 ELSE
462 im := modList;
463 WHILE (im # mod) & (im.name # name) DO im := im.next END;
464 IF im # mod THEN
465 mod.imp[x] := im;
466 ELSE
467 WriteSString(name);
468 WriteString(" not present (imported in ");
469 WriteString(mod.name); WriteChar(")");
470 WriteLn; FlushW; error := TRUE
471 END
472 END;
473 INC(x)
474 END
475 END;
476 IF impdll & ~error THEN CheckDllImports(mod) END;
477 mod.ma := ConSize; INC(ConSize, mod.ms + mod.ds);
478 mod.va := DataSize; INC(DataSize, mod.vs);
479 mod.ca := CodeSize; INC(CodeSize, mod.cs);
480 IF mod.cs > maxCode THEN maxCode := mod.cs END
481 ELSE
482 WriteString(mod.name); WriteString(": wrong file type");
483 WriteLn; FlushW; error := TRUE
484 END;
485 mod.file.Close; mod.file := NIL
486 ELSE
487 WriteString(mod.name); WriteString(" not found");
488 WriteLn; FlushW; error := TRUE
489 END;
490 last := mod
491 END;
492 mod := mod.next
493 END;
494 IF ~isStatic & (main = NIL) THEN
495 WriteSString("no main module specified"); WriteLn;
496 FlushW; error := TRUE
497 END;
498 (* calculate rva's *)
499 IF DataSize = 0 THEN DataSize := 1 END;
500 CodeRva := ObjAlign;
501 DataRva := CodeRva + (CodeSize + DllSize + (ObjAlign - 1)) DIV ObjAlign * ObjAlign;
502 ConRva := DataRva + (DataSize + (ObjAlign - 1)) DIV ObjAlign * ObjAlign;
503 RsrcRva := ConRva + (ConSize + (ObjAlign - 1)) DIV ObjAlign * ObjAlign;
504 CodeBase := ImageBase + CodeRva;
505 DataBase := ImageBase + DataRva;
506 ConBase := ImageBase + ConRva;
507 (* write dll export adresses *)
508 mod := modList; x := 0;
509 WHILE mod # NIL DO
510 IF mod.dll THEN
511 exp := mod.exp; INC(ImpSize, 20);
512 WHILE exp # NIL DO exp.adr := x; INC(x, 6); exp := exp.next END
513 END;
514 mod := mod.next
515 END;
516 ASSERT(x = DllSize); INC(ImpSize, 20); (* sentinel *)
517 END ReadHeaders;
519 PROCEDURE MenuSize (r: Resource): INTEGER;
520 VAR s, i: INTEGER;
521 BEGIN
522 s := 0;
523 WHILE r # NIL DO
524 INC(s, 2);
525 IF r.local = NIL THEN INC(s, 2) END;
526 i := 0; WHILE r.name[i] # 0X DO INC(s, 2); INC(i) END;
527 INC(s, 2);
528 s := s + MenuSize(r.local);
529 r := r.next
530 END;
531 RETURN s
532 END MenuSize;
534 PROCEDURE PrepResources;
535 VAR res, r, s: Resource; n, i, j, t, x: INTEGER; loc: Files.Locator;
536 BEGIN
537 r := resList;
538 WHILE r # NIL DO
539 IF r.lid = 0 THEN r.lid := 1033 END;
540 IF r.name = "MENU" THEN
541 r.typ := 4; r.size := 4 + MenuSize(r.local);
542 ELSIF r.name = "ACCELERATOR" THEN
543 r.typ := 9; r.size := 0; s := r.local;
544 WHILE s # NIL DO INC(r.size, 8); s := s.next END;
545 ELSE
546 r.file := ThisResFile(r.name);
547 IF r.file # NIL THEN
548 IF r.typ = -1 THEN (* typelib *)
549 r.typ := 0; r.size := r.file.Length(); r.pos := 0; rsrcName := "TYPELIB"
550 ELSE
551 R := r.file.NewReader(R); R.SetPos(0); Read2(n);
552 IF n = 4D42H THEN (* bitmap *)
553 Read4(n); r.typ := 2; r.size := n - 14; r.pos := 14;
554 ELSE
555 Read2(x);
556 IF x = 1 THEN (* icon *)
557 Read2(n); r.typ := 14; r.size := 6 + 14 * n; r.pos := 0; i := 0;
558 WHILE i < n DO
559 NEW(s); s.typ := 3; s.id := 10 * r.id + i; s.lid := r.lid; s.name := r.name$;
560 Read4(x); Read4(x); Read4(s.size); Read2(s.pos); Read2(x);
561 s.next := resList; resList := s;
562 INC(i)
563 END
564 ELSIF x = 2 THEN (* cursor *)
565 Read2(n); r.typ := 12; r.size := 6 + 14 * n; r.pos := 0; i := 0;
566 WHILE i < n DO
567 NEW(s); s.typ := 1; s.id := 10 * r.id + i; s.lid := r.lid; s.name := r.name$;
568 Read4(x); Read2(s.x); Read2(s.y); Read4(s.size); INC(s.size, 4); Read2(s.pos); Read2(x);
569 s.next := resList; resList := s;
570 INC(i)
571 END
572 ELSE
573 Read4(n);
574 IF (x = 0) & (n = 20H) THEN (* resource file *)
575 Read4(n); Read4(n); Read4(n); Read4(n); Read4(n); Read4(n); (* 32 bit marker *)
576 Read4(r.size); Read4(n); Read2(i);
577 IF i = 0FFFFH THEN
578 Read2(j);
579 IF (j >= 4) & ((j <= 11) OR (j = 16)) THEN
580 r.typ := j; r.pos := n + 32;
581 ELSE
582 WriteString(r.name); WriteString(": invalid type"); WriteLn;
583 FlushW; error := TRUE
584 END
585 ELSE
586 j := 0;
587 WHILE i # 0 DO rsrcName[j] := CHR(i); INC(j); Read2(i) END;
588 rsrcName[j] := 0X;
589 r.typ := 0; r.pos := n + 32
590 END
591 ELSE
592 WriteString(r.name); WriteString(": unknown type"); WriteLn;
593 FlushW; error := TRUE
594 END
595 END
596 END
597 END;
598 r.file.Close; r.file := NIL
599 ELSE
600 WriteString(r.name); WriteString(" not found"); WriteLn;
601 FlushW; error := TRUE
602 END
603 END;
604 r := r.next
605 END;
606 res := resList; resList := NIL; (* sort resources *)
607 WHILE res # NIL DO
608 r := res; res := res.next;
609 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))
610 THEN
611 r.next := resList; resList := r
612 ELSE
613 s := resList;
614 WHILE (s.next # NIL) & (r.typ >= s.next.typ)
615 & ((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;
616 r.next := s.next; s.next := r
617 END
618 END;
619 r := resList; numType := 0; resHSize := 16; t := 0; n := 0; (* get resource size *)
620 WHILE t < LEN(numId) DO numId[t] := 0; INC(t) END;
621 WHILE r # NIL DO
622 INC(numType); INC(resHSize, 24); t := r.typ;
623 WHILE (r # NIL) & (r.typ = t) DO
624 INC(numId[t]); INC(resHSize, 24); i := r.id;
625 WHILE (r # NIL) & (r.typ = t) & (r.id = i) DO
626 INC(resHSize, 24); INC(n, (r.size + 3) DIV 4 * 4); r := r.next
627 END
628 END
629 END;
630 IF numId[0] > 0 THEN INC(n, (LEN(rsrcName$) + 1) * 2) END;
631 RsrcSize := resHSize + n;
632 ImpRva := RsrcRva + (RsrcSize + (ObjAlign - 1)) DIV ObjAlign * ObjAlign
633 END PrepResources;
635 PROCEDURE WriteHeader(VAR name: Files.Name);
636 BEGIN
637 Out := Files.dir.New(Files.dir.This(""), Files.ask); Ro := Out.NewWriter(Ro); Ro.SetPos(0);
639 (* DOS header *)
640 Write4(905A4DH); Write4(3); Write4(4); Write4(0FFFFH);
641 Write4(0B8H); Write4(0); Write4(40H); Write4(0);
642 Write4(0); Write4(0); Write4(0); Write4(0);
643 Write4(0); Write4(0); Write4(0); Write4(80H);
644 Write4(0EBA1F0EH); Write4(0CD09B400H); Write4(4C01B821H); Write2(21CDH);
645 WriteName("This program cannot be run in DOS mode.", 39);
646 WriteCh(0DX); WriteCh(0DX); WriteCh(0AX);
647 Write4(24H); Write4(0);
649 (* Win32 header *)
650 WriteName("PE", 4); (* signature bytes *)
651 Write2(014CH); (* cpu type (386) *)
652 IF isDll THEN
653 Write2(7); (* 7 objects *)
654 ELSE
655 Write2(6); (* 6 objects *)
656 END;
657 Write4(timeStamp); (* time/date *)
658 Write4(0); Write4(0);
659 Write2(0E0H); (* NT header size *)
660 IF isDll THEN
661 Write2(0A38EH); (* library image flags *)
662 ELSE
663 Write2(838EH); (* program image flags *)
664 END;
665 Write2(10BH); (* magic (normal ececutable file) *)
666 Write2(0301H); (* linker version !!! *)
667 Write4(CodeSize); (* code size *)
668 Write4(ConSize); (* initialized data size *)
669 Write4(DataSize); (* uninitialized data size *)
670 entryPos := Ro.Pos();
671 Write4(0); (* entry point *) (* !!! *)
672 Write4(CodeRva); (* base of code *)
673 Write4(ConRva); (* base of data *)
674 Write4(400000H); (* image base *)
675 Write4(ObjAlign); (* object align *)
676 Write4(FileAlign); (* file align *)
677 Write4(3); (* OS version *)
678 Write4(4); (* user version *)
679 Write4(4); (* subsys version *) (* mf 14.3.04: value changed from 0A0003H to 4. Corrects menubar pixel bug on Windows XP *)
680 Write4(0);
681 isPos := Ro.Pos();
682 Write4(0); (* image size *) (* !!! *)
683 Write4(HeaderSize); (* header size !!! *)
684 Write4(0); (* checksum *)
685 IF comLine THEN
686 Write2(3) (* dos subsystem *)
687 ELSE
688 Write2(2) (* gui subsystem *)
689 END;
690 Write2(0); (* dll flags *)
691 Write4(200000H); (* stack reserve size *)
692 Write4(10000H); (* stack commit size *)
693 IF isDll THEN
694 Write4(00100000H); (* heap reserve size *)
695 ELSE
696 Write4(00400000H); (* heap reserve size *)
697 END;
698 Write4(10000H); (* heap commit size *)
699 Write4(0);
700 Write4(16); (* num of rva/sizes *)
701 hexpPos := Ro.Pos();
702 Write4(0); Write4(0); (* export table *)
703 himpPos := Ro.Pos();
704 Write4(0); Write4(0); (* import table *) (* !!! *)
705 hrsrcPos := Ro.Pos();
706 Write4(0); Write4(0); (* resource table *) (* !!! *)
707 Write4(0); Write4(0); (* exception table *)
708 Write4(0); Write4(0); (* security table *)
709 fixPos := Ro.Pos();
710 Write4(0); Write4(0); (* fixup table *) (* !!! *)
711 Write4(0); Write4(0); (* debug table *)
712 Write4(0); Write4(0); (* image description *)
713 Write4(0); Write4(0); (* machine specific *)
714 Write4(0); Write4(0); (* thread local storage *)
715 Write4(0); Write4(0); (* ??? *)
716 Write4(0); Write4(0); (* ??? *)
717 Write4(0); Write4(0); (* ??? *)
718 Write4(0); Write4(0); (* ??? *)
719 Write4(0); Write4(0); (* ??? *)
720 Write4(0); Write4(0); (* ??? *)
722 (* object directory *)
723 WriteName(".text", 8); (* code object *)
724 Write4(0); (* object size (always 0) *)
725 codePos := Ro.Pos();
726 Write4(0); (* object rva *)
727 Write4(0); (* physical size *)
728 Write4(0); (* physical offset *)
729 Write4(0); Write4(0); Write4(0);
730 Write4(60000020H); (* flags: code, exec, read *)
732 WriteName(".var", 8); (* variable object *)
733 Write4(0); (* object size (always 0) *)
734 dataPos := Ro.Pos();
735 Write4(0); (* object rva *)
736 Write4(0); (* physical size *)
737 Write4(0); (* physical offset *) (* zero! (noinit) *)
738 Write4(0); Write4(0); Write4(0);
739 Write4(0C0000080H); (* flags: noinit, read, write *)
741 WriteName(".data", 8); (* constant object *)
742 Write4(0); (* object size (always 0) *)
743 conPos := Ro.Pos();
744 Write4(0); (* object rva *)
745 Write4(0); (* physical size *)
746 Write4(0); (* physical offset *)
747 Write4(0); Write4(0); Write4(0);
748 Write4(0C0000040H); (* flags: data, read, write *)
750 WriteName(".rsrc", 8); (* resource object *)
751 Write4(0); (* object size (always 0) *)
752 rsrcPos := Ro.Pos();
753 Write4(0); (* object rva *)
754 Write4(0); (* physical size *)
755 Write4(0); (* physical offset *)
756 Write4(0); Write4(0); Write4(0);
757 Write4(0C0000040H); (* flags: data, read, write *)
759 WriteName(".idata", 8); (* import object *)
760 Write4(0); (* object size (always 0) *)
761 impPos := Ro.Pos();
762 Write4(0); (* object rva *)
763 Write4(0); (* physical size *)
764 Write4(0); (* physical offset *)
765 Write4(0); Write4(0); Write4(0);
766 Write4(0C0000040H); (* flags: data, read, write *)
768 IF isDll THEN
769 WriteName(".edata", 8); (* export object *)
770 Write4(0); (* object size (always 0) *)
771 expPos := Ro.Pos();
772 Write4(0); (* object rva *)
773 Write4(0); (* physical size *)
774 Write4(0); (* physical offset *)
775 Write4(0); Write4(0); Write4(0);
776 Write4(0C0000040H); (* flags: data, read, write *)
777 END;
779 WriteName(".reloc", 8); (* relocation object *)
780 Write4(0); (* object size (always 0) *)
781 relPos := Ro.Pos();
782 Write4(0); (* object rva *)
783 Write4(0); (* physical size *)
784 Write4(0); (* physical offset *)
785 Write4(0); Write4(0); Write4(0);
786 Write4(42000040H); (* flags: data, read, ? *)
787 END WriteHeader;
789 PROCEDURE SearchObj (mod: Module; VAR name: ARRAY OF SHORTCHAR; m, fp, opt: INTEGER; VAR adr: INTEGER);
790 VAR dir, len, ntab, f, id, l, r, p, n, i, j: INTEGER; nch, och: SHORTCHAR;
791 BEGIN
792 Get(mod, mod.ms + modExports, dir); DEC(dir, ConBase + mod.ma); Get(mod, dir, len); INC(dir, 4);
793 Get(mod, mod.ms + modNames, ntab); DEC(ntab, ConBase + mod.ma);
794 IF name # "" THEN
795 l := 0; r := len;
796 WHILE l < r DO (* binary search *)
797 n := (l + r) DIV 2; p := dir + n * 16;
798 Get(mod, p + 8, id);
799 i := 0; j := ntab + id DIV 256; nch := name[0]; och := SHORT(CHR(mod.data[j]));
800 WHILE (nch = och) & (nch # 0X) DO INC(i); INC(j); nch := name[i]; och := SHORT(CHR(mod.data[j])) END;
801 IF och = nch THEN
802 IF id MOD 16 = m THEN Get(mod, p, f);
803 IF m = mTyp THEN
804 IF ODD(opt) THEN Get(mod, p + 4, f) END;
805 IF (opt > 1) & (id DIV 16 MOD 16 # mExported) THEN
806 WriteString(mod.name); WriteChar("."); WriteSString(name);
807 WriteString(" imported from "); WriteString(impg.name);
808 WriteString(" has wrong visibility"); WriteLn; error := TRUE
809 END;
810 Get(mod, p + 12, adr)
811 ELSIF m = mVar THEN
812 Get(mod, p + 4, adr); INC(adr, DataBase + mod.va)
813 ELSIF m = mProc THEN
814 Get(mod, p + 4, adr); INC(adr, CodeBase + mod.ca)
815 END;
816 IF f # fp THEN
817 WriteString(mod.name); WriteChar("."); WriteSString(name);
818 WriteString(" imported from "); WriteString(impg.name);
819 WriteString(" has wrong fprint"); WriteLn; error := TRUE
820 END
821 ELSE
822 WriteString(mod.name); WriteChar("."); WriteSString(name);
823 WriteString(" imported from "); WriteString(impg.name);
824 WriteString(" has wrong class"); WriteLn; error := TRUE
825 END;
826 RETURN
827 END;
828 IF och < nch THEN l := n + 1 ELSE r := n END
829 END;
830 WriteString(mod.name); WriteChar("."); WriteSString(name);
831 WriteString(" not found (imported from "); WriteString(impg.name);
832 WriteChar(")"); WriteLn; error := TRUE
833 ELSE (* anonymous type *)
834 WHILE len > 0 DO
835 Get(mod, dir + 4, f); Get(mod, dir + 8, id);
836 IF (f = fp) & (id MOD 16 = mTyp) & (id DIV 256 = 0) THEN
837 Get(mod, dir + 12, adr); RETURN
838 END;
839 DEC(len); INC(dir, 16)
840 END;
841 WriteString("anonymous type in "); WriteString(mod.name);
842 WriteString(" not found"); WriteLn; error := TRUE
843 END
844 END SearchObj;
846 PROCEDURE CollectExports (mod: Module);
847 VAR dir, len, ntab, id, i, j, n: INTEGER; e, exp: Export;
848 BEGIN
849 Get(mod, mod.ms + modExports, dir); DEC(dir, ConBase + mod.ma); Get(mod, dir, len); INC(dir, 4);
850 Get(mod, mod.ms + modNames, ntab); DEC(ntab, ConBase + mod.ma); n := 0;
851 WHILE n < len DO
852 Get(mod, dir + 8, id);
853 IF (id DIV 16 MOD 16 # mInternal) & ((id MOD 16 = mProc) OR (id MOD 16 = mVar))THEN (* exported procedure & var *)
854 NEW(exp);
855 i := 0; j := ntab + id DIV 256;
856 WHILE mod.data[j] # 0 DO exp.name[i] := SHORT(CHR(mod.data[j])); INC(i); INC(j) END;
857 exp.name[i] := 0X;
858 Get(mod, dir + 4, exp.adr);
859 IF id MOD 16 = mProc THEN INC(exp.adr, CodeRva + mod.ca)
860 ELSE ASSERT(id MOD 16 = mVar); INC(exp.adr, DataRva + mod.va)
861 END;
862 IF (firstExp = NIL) OR (exp.name < firstExp.name) THEN
863 exp.next := firstExp; firstExp := exp;
864 IF lastExp = NIL THEN lastExp := exp END
865 ELSE
866 e := firstExp;
867 WHILE (e.next # NIL) & (exp.name > e.next.name) DO e := e.next END;
868 exp.next := e.next; e.next := exp;
869 IF lastExp = e THEN lastExp := exp END
870 END;
871 INC(numExp);
872 END;
873 INC(n); INC(dir, 16)
874 END
875 END CollectExports;
877 PROCEDURE WriteTermCode (m: Module; i: INTEGER);
878 VAR x: INTEGER;
879 BEGIN
880 IF m # NIL THEN
881 IF m.dll THEN WriteTermCode(m.next, i)
882 ELSE
883 IF isStatic THEN WriteTermCode(m.next, i + 1) END;
884 Get(m, m.ms + modTerm, x); (* terminator address in mod desc*)
885 IF x = 0 THEN
886 WriteCh(005X); Write4(0) (* add EAX, 0 (nop) *)
887 ELSE
888 WriteCh(0E8X); Write4(x - lastTerm + 5 * i - CodeBase) (* call term *)
889 END
890 END
891 END
892 END WriteTermCode;
894 PROCEDURE WriteCode;
895 VAR mod, m: Module; i, x, a, fp, opt: INTEGER; exp: Export; name: Name;
896 BEGIN
897 IF isStatic THEN
898 WriteCh(053X); (* push ebx *)
899 a := 1;
900 IF isDll THEN
901 WriteCh(083X); WriteCh(07CX); WriteCh(024X); WriteCh(00CX); WriteCh(001X); (* cmp [12, esp], 1 *)
902 WriteCh(00FX); WriteCh(085X); Write4(10 + 5 * numMod); (* jne L1 *)
903 INC(a, 11)
904 ELSE
905 WriteCh(053X); WriteCh(053X); (* push ebx; push ebx *)
906 INC(a, 2)
907 END;
908 WriteCh(0BBX); Write4(ConBase + last.ma + last.ms); Reloc(CodeBase + a + 1); (* mov bx, modlist *)
909 INC(a, 5); m := modList;
910 WHILE m # NIL DO
911 IF ~m.dll THEN
912 WriteCh(0E8X); INC(a, 5); Write4(m.ca - a) (* call body *)
913 END;
914 m := m.next
915 END;
916 IF isDll THEN
917 WriteCh(0E9X); Write4(11 + 5 * numMod); (* jp L2 *)
918 WriteCh(083X); WriteCh(07CX); WriteCh(024X); WriteCh(00CX); WriteCh(000X); (* L1: cmp [12, esp], 0 *)
919 WriteCh(00FX); WriteCh(085X); Write4(5 * numMod); (* jne L2 *)
920 INC(a, 16)
921 END;
922 termPos := Ro.Pos(); i := 0;
923 WHILE i < numMod DO (* nop for call terminator *)
924 WriteCh(02DX); Write4(0); (* sub EAX, 0 *)
925 INC(i); INC(a, 5)
926 END;
927 lastTerm := a;
928 WriteCh(05BX); (* L2: pop ebx *)
929 IF isDll THEN
930 WriteCh(0B8X); Write4(1); (* mov eax,1 *)
931 WriteCh(0C2X); Write2(12) (* ret 12 *)
932 ELSE
933 WriteCh(05BX); WriteCh(05BX); (* pop ebx; pop ebx *)
934 WriteCh(0C3X) (* ret *)
935 END
936 ELSIF isDll THEN
937 WriteCh(053X); (* push ebx *)
938 WriteCh(083X); WriteCh(07CX); WriteCh(024X); WriteCh(00CX); WriteCh(001X); (* cmp [12, esp], 1 *)
939 WriteCh(075X); WriteCh(SHORT(CHR(12))); (* jne L1 *)
940 WriteCh(0BBX); Write4(ConBase + last.ma + last.ms); Reloc(CodeBase + 9); (* mov bx, modlist *)
941 WriteCh(0E8X); Write4(main.ca - 18); (* call main *)
942 WriteCh(0EBX); WriteCh(SHORT(CHR(12))); (* jp L2 *)
943 WriteCh(083X); WriteCh(07CX); WriteCh(024X); WriteCh(00CX); WriteCh(000X); (* L1: cmp [12, esp], 0 *)
944 WriteCh(075X); WriteCh(SHORT(CHR(5))); (* jne L2 *)
945 termPos := Ro.Pos();
946 WriteCh(02DX); Write4(0); (* sub EAX, 0 *) (* nop for call terminator *)
947 lastTerm := 32;
948 WriteCh(05BX); (* L2: pop ebx *)
949 WriteCh(0B8X); Write4(1); (* mov eax,1 *)
950 WriteCh(0C2X); Write2(12) (* ret 12 *)
951 ELSE
952 WriteCh(0BBX); Write4(ConBase + last.ma + last.ms); Reloc(CodeBase + 1); (* mov bx, modlist *)
953 WriteCh(0E9X); Write4(main.ca - 10); (* jmp main *)
954 END;
955 NEW(code, maxCode);
956 mod := modList;
957 WHILE mod # NIL DO impg := mod; impd := mod;
958 IF ~mod.dll THEN
959 mod.file := ThisFile(mod.name);
960 R := mod.file.NewReader(R); R.SetPos(mod.hs);
961 NEW(mod.data, mod.ms + mod.ds);
962 R.ReadBytes(mod.data^, 0, mod.ms + mod.ds);
963 R.ReadBytes(code^, 0, mod.cs);
964 RNum(x);
965 IF x # 0 THEN
966 IF (mod # kernel) & (kernel # NIL) THEN
967 SearchObj(kernel, newRec, mProc, NewRecFP, -1, a); Fixup0(x, a)
968 ELSE
969 WriteSString("no kernel"); WriteLn;
970 FlushW; error := TRUE; RETURN
971 END
972 END;
973 RNum(x);
974 IF x # 0 THEN
975 IF (mod # kernel) & (kernel # NIL) THEN
976 SearchObj(kernel, newArr, mProc, NewArrFP, -1, a); Fixup0(x, a)
977 ELSE
978 WriteSString("no kernel"); WriteLn;
979 FlushW; error := TRUE; RETURN
980 END
981 END;
982 Fixup(ConBase + mod.ma);
983 Fixup(ConBase + mod.ma + mod.ms);
984 Fixup(CodeBase + mod.ca);
985 Fixup(DataBase + mod.va); i := 0;
986 WHILE i < mod.ni DO
987 m := mod.imp[i]; impd := m; RNum(x);
988 WHILE x # 0 DO
989 ReadName(name); RNum(fp); opt := 0;
990 IF x = mTyp THEN RNum(opt) END;
991 IF m.dll THEN
992 IF x = mProc THEN exp := m.exp;
993 WHILE exp.name # name DO exp := exp.next END;
994 a := exp.adr + CodeBase + CodeSize
995 END
996 ELSE
997 SearchObj(m, name, x, fp, opt, a)
998 END;
999 IF x # mConst THEN Fixup(a) END;
1000 RNum(x)
1001 END;
1002 IF ~m.dll THEN
1003 Get(mod, mod.ms + modImports, x); DEC(x, ConBase + mod.ma); INC(x, 4 * i);
1004 Put(mod, x, ConBase + m.ma + m.ms); (* imp ref *)
1005 Reloc(ConBase + mod.ma + x);
1006 Get(m, m.ms + modRefcnt, x); Put(m, m.ms + modRefcnt, x + 1) (* inc ref count *)
1007 END;
1008 INC(i)
1009 END;
1010 Ro.WriteBytes(code^, 0, mod.cs);
1011 IF mod.intf THEN CollectExports(mod) END;
1012 mod.file.Close; mod.file := NIL
1013 END;
1014 mod := mod.next
1015 END;
1016 (* dll links *)
1017 mod := modList; ImpHSize := ImpSize;
1018 WHILE mod # NIL DO
1019 IF mod.dll THEN
1020 exp := mod.exp;
1021 WHILE exp # NIL DO
1022 WriteCh(0FFX); WriteCh(25X); Write4(ImageBase + ImpRva + ImpSize); (* JMP indirect *)
1023 Reloc(CodeBase + CodeSize + exp.adr + 2);
1024 INC(ImpSize, 4); INC(numImp); exp := exp.next
1025 END;
1026 INC(ImpSize, 4); INC(numImp) (* sentinel *)
1027 END;
1028 mod := mod.next
1029 END
1030 END WriteCode;
1032 PROCEDURE WriteConst;
1033 VAR mod, last: Module; x: INTEGER;
1034 BEGIN
1035 mod := modList; last := NIL;
1036 WHILE mod # NIL DO
1037 IF ~mod.dll THEN
1038 IF last # NIL THEN
1039 Put(mod, mod.ms, ConBase + last.ma + last.ms); (* mod list *)
1040 Reloc(ConBase + mod.ma + mod.ms);
1041 END;
1042 Get(mod, mod.ms + modOpts, x);
1043 IF isStatic THEN INC(x, 10000H) END; (* set init bit (16) *)
1044 IF isDll THEN INC(x, 1000000H) END; (* set dll bit (24) *)
1045 Put(mod, mod.ms + modOpts, x);
1046 Ro.WriteBytes(mod.data^, 0, mod.ms + mod.ds);
1047 last := mod
1048 END;
1049 mod := mod.next
1050 END
1051 END WriteConst;
1053 PROCEDURE WriteResDir (n, i: INTEGER);
1054 BEGIN
1055 Write4(0); (* flags *)
1056 Write4(timeStamp);
1057 Write4(0); (* version *)
1058 Write2(n); (* name entries *)
1059 Write2(i); (* id entries *)
1060 END WriteResDir;
1062 PROCEDURE WriteResDirEntry (id, adr: INTEGER; dir: BOOLEAN);
1063 BEGIN
1064 IF id = 0 THEN id := resHSize + 80000000H END; (* name Rva *)
1065 Write4(id);
1066 IF dir THEN Write4(adr + 80000000H) ELSE Write4(adr) END
1067 END WriteResDirEntry;
1069 PROCEDURE WriteMenu (res: Resource);
1070 VAR f, i: INTEGER;
1071 BEGIN
1072 WHILE res # NIL DO
1073 IF res.next = NIL THEN f := 80H ELSE f := 0 END;
1074 IF 29 IN res.opts THEN INC(f, 1) END; (* = grayed *)
1075 IF 13 IN res.opts THEN INC(f, 2) END; (* - inctive *)
1076 IF 3 IN res.opts THEN INC(f, 4) END; (* # bitmap *)
1077 IF 10 IN res.opts THEN INC(f, 8) END; (* * checked *)
1078 IF 1 IN res.opts THEN INC(f, 20H) END; (* ! menubarbreak *)
1079 IF 15 IN res.opts THEN INC(f, 40H) END; (* / menubreak *)
1080 IF 31 IN res.opts THEN INC(f, 100H) END; (* ? ownerdraw *)
1081 IF res.local # NIL THEN Write2(f + 10H) ELSE Write2(f); Write2(res.id) END;
1082 i := 0; WHILE res.name[i] # 0X DO Write2(ORD(res.name[i])); INC(i) END;
1083 Write2(0);
1084 WriteMenu(res.local);
1085 res := res.next
1086 END
1087 END WriteMenu;
1089 PROCEDURE WriteResource;
1090 VAR r, s: Resource; i, t, a, x, n, nlen, nsize: INTEGER;
1091 BEGIN
1092 IF numId[0] > 0 THEN WriteResDir(1, numType - 1); nlen := LEN(rsrcName$); nsize := (nlen + 1) * 2;
1093 ELSE WriteResDir(0, numType)
1094 END;
1095 a := 16 + 8 * numType; t := 0;
1096 WHILE t < LEN(numId) DO
1097 IF numId[t] > 0 THEN WriteResDirEntry(t, a, TRUE); INC(a, 16 + 8 * numId[t]) END;
1098 INC(t)
1099 END;
1100 r := resList; t := -1;
1101 WHILE r # NIL DO
1102 IF t # r.typ THEN t := r.typ; WriteResDir(0, numId[t]) END;
1103 WriteResDirEntry(r.id, a, TRUE); INC(a, 16); i := r.id;
1104 WHILE (r # NIL) & (r.typ = t) & (r.id = i) DO INC(a, 8); r := r.next END
1105 END;
1106 r := resList;
1107 WHILE r # NIL DO
1108 n := 0; s := r;
1109 WHILE (s # NIL) & (s.typ = r.typ) & (s.id = r.id) DO INC(n); s := s.next END;
1110 WriteResDir(0, n);
1111 WHILE r # s DO WriteResDirEntry(r.lid, a, FALSE); INC(a, 16); r := r.next END
1112 END;
1113 ASSERT(a = resHSize);
1114 IF numId[0] > 0 THEN INC(a, nsize) END; (* TYPELIB string *)
1115 r := resList;
1116 WHILE r # NIL DO
1117 Write4(a + RsrcRva); INC(a, (r.size + 3) DIV 4 * 4);
1118 Write4(r.size);
1119 Write4(0); Write4(0);
1120 r := r.next
1121 END;
1122 ASSERT(a = RsrcSize);
1123 IF numId[0] > 0 THEN
1124 Write2(nlen); i := 0;
1125 WHILE rsrcName[i] # 0X DO Write2(ORD(rsrcName[i])); INC(i) END
1126 END;
1127 r := resList;
1128 WHILE r # NIL DO
1129 IF r.typ = 4 THEN (* menu *)
1130 Write2(0); Write2(0);
1131 WriteMenu(r.local);
1132 WHILE Ro.Pos() MOD 4 # 0 DO WriteCh(0X) END
1133 ELSIF r.typ = 9 THEN (* accelerator *)
1134 s := r.local;
1135 WHILE s # NIL DO
1136 i := 0; a := 0;
1137 IF 10 IN s.opts THEN INC(a, 4) END; (* * shift *)
1138 IF 16 IN s.opts THEN INC(a, 8) END; (* ^ ctrl *)
1139 IF 0 IN s.opts THEN INC(a, 16) END; (* @ alt *)
1140 IF 13 IN s.opts THEN INC(a, 2) END; (* - noinv *)
1141 IF s.next = NIL THEN INC(a, 80H) END;
1142 IF (s.name[0] = "v") & (s.name[1] # 0X) THEN
1143 s.name[0] := " "; Strings.StringToInt(s.name, x, n); INC(a, 1)
1144 ELSE x := ORD(s.name[0])
1145 END;
1146 Write2(a); Write2(x); Write2(s.id); Write2(0); s := s.next
1147 END
1148 ELSE
1149 r.file := ThisResFile(r.name);
1150 IF r.file # NIL THEN
1151 R := r.file.NewReader(R); R.SetPos(r.pos); i := 0;
1152 IF r.typ = 12 THEN (* cursor group *)
1153 Read4(x); Write4(x); Read2(n); Write2(n);
1154 WHILE i < n DO
1155 Read4(x); Write2(x MOD 256); Write2(x DIV 256 MOD 256 * 2);
1156 Write2(1); Write2(1); Read4(x); (* ??? *)
1157 Read4(x); Write4(x + 4); Read4(x); Write2(r.id * 10 + i); INC(i)
1158 END;
1159 IF ~ODD(n) THEN Write2(0) END
1160 ELSIF r.typ = 14 THEN (* icon group *)
1161 Read4(x); Write4(x); Read2(n); Write2(n);
1162 WHILE i < n DO
1163 Read2(x); Write2(x); Read2(x);
1164 IF (13 IN r.opts) & (x = 16) THEN x := 4 END;
1165 Write2(x);
1166 a := x MOD 256; Read4(x); Write2(1);
1167 IF a <= 2 THEN Write2(1)
1168 ELSIF a <= 4 THEN Write2(2)
1169 ELSIF a <= 16 THEN Write2(4)
1170 ELSE Write2(8)
1171 END;
1172 Read4(x);
1173 IF (13 IN r.opts) & (x = 744) THEN x := 440 END;
1174 IF (13 IN r.opts) & (x = 296) THEN x := 184 END;
1175 Write4(x); Read4(x); Write2(r.id * 10 + i); INC(i)
1176 END;
1177 IF ~ODD(n) THEN Write2(0) END
1178 ELSE
1179 IF r.typ = 1 THEN Write2(r.x); Write2(r.y); i := 4 END; (* cursor hot spot *)
1180 WHILE i < r.size DO Read4(x); Write4(x); INC(i, 4) END
1181 END;
1182 r.file.Close; r.file := NIL
1183 END
1184 END;
1185 r := r.next
1186 END
1187 END WriteResource;
1189 PROCEDURE Insert(VAR name: ARRAY OF SHORTCHAR; VAR idx: INTEGER; hint: INTEGER);
1190 VAR i: INTEGER;
1191 BEGIN
1192 IF hint >= 0 THEN
1193 ntab[idx] := SHORT(CHR(hint)); INC(idx);
1194 ntab[idx] := SHORT(CHR(hint DIV 256)); INC(idx);
1195 END;
1196 i := 0;
1197 WHILE name[i] # 0X DO ntab[idx] := name[i]; INC(idx); INC(i) END;
1198 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
1199 ntab[idx] := "."; INC(idx);
1200 ntab[idx] := "d"; INC(idx);
1201 ntab[idx] := "l"; INC(idx);
1202 ntab[idx] := "l"; INC(idx);
1203 END;
1204 ntab[idx] := 0X; INC(idx);
1205 IF ODD(idx) THEN ntab[idx] := 0X; INC(idx) END
1206 END Insert;
1208 PROCEDURE WriteImport;
1209 VAR i, lt, at, nt, ai, ni: INTEGER; mod: Module; exp: Export; ss: ARRAY 256 OF SHORTCHAR;
1210 BEGIN
1211 IF numImp > 0 THEN NEW(atab, numImp) END;
1212 IF numExp > numImp THEN i := numExp ELSE i := numImp END;
1213 IF i > 0 THEN NEW(ntab, 40 * i) END;
1214 at := ImpRva + ImpHSize; ai := 0; ni := 0;
1215 lt := ImpRva + ImpSize; nt := lt + ImpSize - ImpHSize;
1216 mod := modList;
1217 WHILE mod # NIL DO
1218 IF mod.dll THEN
1219 Write4(lt); (* lookup table rva *)
1220 Write4(0); (* time/data (always 0) *)
1221 Write4(0); (* version (always 0) *)
1222 Write4(nt + ni); (* name rva *)
1223 ss := SHORT(mod.name$); Insert(ss, ni, -1);
1224 Write4(at); (* addr table rva *)
1225 exp := mod.exp;
1226 WHILE exp # NIL DO
1227 atab[ai] := nt + ni; (* hint/name rva *)
1228 Insert(exp.name, ni, 0);
1229 INC(lt, 4); INC(at, 4); INC(ai); exp := exp.next
1230 END;
1231 atab[ai] := 0; INC(lt, 4); INC(at, 4); INC(ai)
1232 END;
1233 mod := mod.next
1234 END;
1235 Write4(0); Write4(0); Write4(0); Write4(0); Write4(0);
1236 i := 0;
1237 WHILE i < ai DO Write4(atab[i]); INC(i) END; (* address table *)
1238 i := 0;
1239 WHILE i < ai DO Write4(atab[i]); INC(i) END; (* lookup table *)
1240 i := 0;
1241 WHILE i < ni DO WriteCh(ntab[i]); INC(i) END;
1242 ASSERT(ai * 4 = ImpSize - ImpHSize);
1243 INC(ImpSize, ai * 4 + ni);
1244 ExpRva := ImpRva + (ImpSize + (ObjAlign - 1)) DIV ObjAlign * ObjAlign;
1245 RelocRva := ExpRva;
1246 END WriteImport;
1248 PROCEDURE WriteExport (VAR name: ARRAY OF CHAR);
1249 VAR i, ni: INTEGER; e: Export; ss: ARRAY 256 OF SHORTCHAR;
1250 BEGIN
1251 Write4(0); (* flags *)
1252 Write4(timeStamp); (* time stamp *)
1253 Write4(0); (* version *)
1254 Write4(ExpRva + 40 + 10 * numExp); (* name rva *)
1255 Write4(1); (* ordinal base *)
1256 Write4(numExp); (* # entries *)
1257 Write4(numExp); (* # name ptrs *)
1258 Write4(ExpRva + 40); (* address table rva *)
1259 Write4(ExpRva + 40 + 4 * numExp); (* name ptr table rva *)
1260 Write4(ExpRva + 40 + 8 * numExp); (* ordinal table rva *)
1261 ExpSize := 40 + 10 * numExp;
1262 (* adress table *)
1263 e := firstExp;
1264 WHILE e # NIL DO Write4(e.adr); e := e.next END;
1265 (* name ptr table *)
1266 ni := 0; e := firstExp;
1267 ss := SHORT(name$); Insert(ss, ni, -2);
1268 WHILE e # NIL DO
1269 Write4(ExpRva + ExpSize + ni); Insert(e.name, ni, -2); e := e.next
1270 END;
1271 (* ordinal table *)
1272 i := 0;
1273 WHILE i < numExp DO Write2(i); INC(i) END;
1274 (* name table *)
1275 i := 0;
1276 WHILE i < ni DO WriteCh(ntab[i]); INC(i) END;
1277 ExpSize := (ExpSize + ni + 15) DIV 16 * 16;
1278 RelocRva := ExpRva + (ExpSize + (ObjAlign - 1)) DIV ObjAlign * ObjAlign;
1279 END WriteExport;
1281 PROCEDURE Sort (l, r: INTEGER);
1282 VAR i, j, x, t: INTEGER;
1283 BEGIN
1284 i := l; j := r; x := fixups[(l + r) DIV 2];
1285 REPEAT
1286 WHILE fixups[i] < x DO INC(i) END;
1287 WHILE fixups[j] > x DO DEC(j) END;
1288 IF i <= j THEN t := fixups[i]; fixups[i] := fixups[j]; fixups[j] := t; INC(i); DEC(j) END
1289 UNTIL i > j;
1290 IF l < j THEN Sort(l, j) END;
1291 IF i < r THEN Sort(i, r) END
1292 END Sort;
1294 PROCEDURE WriteReloc;
1295 VAR i, j, h, a, p: INTEGER;
1296 BEGIN
1297 Sort(0, noffixup - 1); i := 0;
1298 WHILE i < noffixup DO
1299 p := fixups[i] DIV 4096 * 4096; j := i; a := p + 4096;
1300 WHILE (j < noffixup) & (fixups[j] < a) DO INC(j) END;
1301 Write4(p - ImageBase); (* page rva *)
1302 h := 8 + 2 * (j - i);
1303 Write4(h + h MOD 4); (* block size *)
1304 INC(RelocSize, h);
1305 WHILE i < j DO Write2(fixups[i] - p + 3 * 4096); INC(i) END; (* long fix *)
1306 IF h MOD 4 # 0 THEN Write2(0); INC(RelocSize, 2) END
1307 END;
1308 Write4(0); Write4(0); INC(RelocSize, 8);
1309 ImagesSize := RelocRva + (RelocSize + (ObjAlign - 1)) DIV ObjAlign * ObjAlign;
1310 END WriteReloc;
1312 PROCEDURE Align(VAR pos: INTEGER);
1313 BEGIN
1314 WHILE Ro.Pos() MOD FileAlign # 0 DO WriteCh(0X) END;
1315 pos := Ro.Pos()
1316 END Align;
1318 PROCEDURE WriteOut (VAR name: Files.Name);
1319 VAR res, codepos, conpos, rsrcpos, imppos, exppos, relpos, relend, end: INTEGER;
1320 BEGIN
1321 IF ~error THEN Align(codepos); WriteCode END;
1322 IF ~error THEN Align(conpos); WriteConst END;
1323 IF ~error THEN Align(rsrcpos); WriteResource END;
1324 IF ~error THEN Align(imppos); WriteImport END;
1325 IF ~error & isDll THEN Align(exppos); WriteExport(name) END;
1326 IF ~error THEN Align(relpos); WriteReloc END;
1327 relend := Ro.Pos() - 8; Align(end);
1329 IF ~error THEN
1330 Ro.SetPos(entryPos); Write4(CodeRva);
1331 Ro.SetPos(isPos); Write4(ImagesSize);
1332 IF isDll THEN
1333 Ro.SetPos(hexpPos); Write4(ExpRva); Write4(ExpSize);
1334 END;
1335 Ro.SetPos(himpPos); Write4(ImpRva); Write4(ImpHSize);
1336 Ro.SetPos(hrsrcPos); Write4(RsrcRva); Write4(RsrcSize);
1337 Ro.SetPos(fixPos); Write4(RelocRva); Write4(relend - relpos);
1339 Ro.SetPos(codePos); Write4(CodeRva); Write4(conpos - HeaderSize); Write4(HeaderSize);
1340 Ro.SetPos(dataPos); Write4(DataRva); Write4((DataSize + (FileAlign-1)) DIV FileAlign * FileAlign);
1341 Ro.SetPos(conPos); Write4(ConRva); Write4(rsrcpos - conpos); Write4(conpos);
1342 Ro.SetPos(rsrcPos); Write4(RsrcRva); Write4(imppos - rsrcpos); Write4(rsrcpos);
1343 IF isDll THEN
1344 Ro.SetPos(impPos); Write4(ImpRva); Write4(exppos - imppos); Write4(imppos);
1345 Ro.SetPos(expPos); Write4(ExpRva); Write4(relpos - exppos); Write4(exppos)
1346 ELSE
1347 Ro.SetPos(impPos); Write4(ImpRva); Write4(relpos - imppos); Write4(imppos);
1348 END;
1349 Ro.SetPos(relPos); Write4(RelocRva); Write4(end - relpos); Write4(relpos);
1350 IF isStatic THEN
1351 Ro.SetPos(termPos); WriteTermCode(modList, 0)
1352 ELSIF isDll THEN
1353 Ro.SetPos(termPos); WriteTermCode(main, 0)
1354 END
1355 END;
1357 IF ~error THEN
1358 Out.Register(name, "exe", Files.ask, res);
1359 IF res # 0 THEN error := TRUE END
1360 END
1361 END WriteOut;
1363 (* A. V. Shiryaev: Scanner *)
1365 PROCEDURE (VAR S: Scanner) SetPos (x: INTEGER), NEW;
1366 BEGIN
1367 S.rider.i := x
1368 END SetPos;
1370 PROCEDURE (VAR S: Scanner) ConnectTo (IN src: ARRAY OF CHAR), NEW;
1371 BEGIN
1372 NEW(S.rider.s, LEN(src$) + 1);
1373 S.rider.s^ := src$;
1374 S.rider.i := 0;
1375 S.start := 0;
1376 S.type := TMEOT
1377 END ConnectTo;
1379 PROCEDURE (VAR R: ScanRider) ReadPrevChar (VAR ch: CHAR), NEW;
1380 BEGIN
1381 ch := R.s[R.i]
1382 END ReadPrevChar;
1384 PROCEDURE (VAR R: ScanRider) ReadChar (VAR ch: CHAR), NEW;
1385 BEGIN
1386 ch := R.s[R.i];
1387 INC(R.i)
1388 END ReadChar;
1390 PROCEDURE (VAR R: ScanRider) Pos (): INTEGER, NEW;
1391 BEGIN
1392 RETURN R.i
1393 END Pos;
1395 PROCEDURE (VAR S: Scanner) Scan, NEW;
1396 VAR j, res: INTEGER;
1398 PROCEDURE IsLetter (c: CHAR): BOOLEAN;
1399 BEGIN
1400 RETURN ((c >= 'A') & (c <= 'Z')) OR ((c >= 'a') & (c <= 'z')) OR (c = '_')
1401 END IsLetter;
1403 PROCEDURE IsDigit (c: CHAR): BOOLEAN;
1404 BEGIN
1405 RETURN (c >= '0') & (c <= '9')
1406 END IsDigit;
1408 BEGIN
1409 WHILE (S.rider.i < LEN(S.rider.s$)) & (S.rider.s[S.rider.i] = ' ') DO
1410 INC(S.rider.i)
1411 END;
1412 IF S.rider.i < LEN(S.rider.s$) THEN
1413 S.start := S.rider.i;
1414 IF IsDigit(S.rider.s[S.rider.i]) THEN
1415 j := 0;
1416 WHILE (S.rider.i < LEN(S.rider.s$)) & IsDigit(S.rider.s[S.rider.i]) DO
1417 S.string[j] := S.rider.s[S.rider.i];
1418 INC(j);
1419 INC(S.rider.i)
1420 END;
1421 S.string[j] := 0X;
1422 Strings.StringToInt(S.string, S.int, res);
1423 IF res # 0 THEN S.type := TMEOT
1424 ELSE S.type := TMInt
1425 END
1426 ELSIF IsLetter(S.rider.s[S.rider.i]) THEN
1427 S.type := TMString;
1428 j := 0;
1429 WHILE (S.rider.i < LEN(S.rider.s$)) & (IsLetter(S.rider.s[S.rider.i]) OR IsDigit(S.rider.s[S.rider.i])) DO
1430 S.string[j] := S.rider.s[S.rider.i];
1431 INC(j);
1432 INC(S.rider.i)
1433 END;
1434 S.string[j] := 0X
1435 ELSE
1436 S.type := TMChar;
1437 S.char := S.rider.s[S.rider.i];
1438 INC(S.rider.i)
1439 END
1440 ELSE
1441 S.type := TMEOT
1442 END
1443 END Scan;
1445 PROCEDURE ScanRes (VAR S: Scanner; end: INTEGER; VAR list: Resource);
1446 VAR res, tail: Resource; n: INTEGER;
1447 BEGIN
1448 tail := NIL;
1449 WHILE (S.start < end) & (S.type = TMInt) DO
1450 NEW(res); res.id := S.int; S.Scan;
1451 IF (S.type = TMChar) & (S.char = "[") THEN
1452 S.Scan;
1453 IF S.type = TMInt THEN res.lid := S.int; S.Scan END;
1454 IF (S.type = TMChar) & (S.char = "]") THEN S.Scan
1455 ELSE WriteSString("missing ']'"); error := TRUE
1456 END
1457 END;
1458 WHILE S.type = TMChar DO
1459 IF S.char = "@" THEN n := 0
1460 ELSIF S.char = "^" THEN n := 16
1461 ELSIF S.char = "~" THEN n := 17
1462 ELSIF S.char <= "?" THEN n := ORD(S.char) - ORD(" ")
1463 END;
1464 INCL(res.opts, n); S.Scan
1465 END;
1466 IF S.type = TMString THEN
1467 res.name := S.string$; S.Scan;
1468 IF (S.type = TMChar) & (S.char = ".") THEN S.Scan;
1469 IF S.type = TMString THEN
1470 IF (S.string = "tlb") OR (S.string = "TLB") THEN res.typ := -1 END;
1471 Kernel.MakeFileName(res.name, S.string); S.Scan
1472 END
1473 END;
1474 IF (S.type = TMChar) & (S.char = "(") THEN S.Scan;
1475 ScanRes(S, end, res.local);
1476 IF (S.type = TMChar) & (S.char = ")") THEN S.Scan
1477 ELSE WriteSString("missing ')'"); error := TRUE
1478 END
1479 END;
1480 IF tail = NIL THEN list := res ELSE tail.next := res END;
1481 tail := res
1482 ELSE
1483 WriteSString("wrong resource name"); error := TRUE
1484 END
1485 END;
1486 END ScanRes;
1488 PROCEDURE LinkIt (IN txt: ARRAY OF CHAR);
1489 VAR S: Scanner; name: Files.Name; mod: Module; end: INTEGER;
1490 BEGIN
1491 comLine := FALSE;
1492 modList := NIL; kernel := NIL; main := NIL;
1493 last := NIL; impg := NIL; impd := NIL; resList := NIL;
1494 firstExp := NIL; lastExp := NIL;
1495 NEW(fixups, FixLen);
1497 (*
1498 Dialog.ShowStatus("linking");
1499 *)
1500 Console.WriteStr("linking"); Console.WriteLn;
1502 (*
1503 timeStamp := TimeStamp();
1504 *)
1505 timeStamp := 0;
1507 error := FALSE; modList := NIL; resList := NIL;
1509 (*
1510 IF DevCommanders.par = NIL THEN RETURN END;
1511 S.ConnectTo(DevCommanders.par.text);
1512 S.SetPos(DevCommanders.par.beg);
1513 end := DevCommanders.par.end;
1514 DevCommanders.par := NIL;
1515 W.ConnectTo(Log.buf);
1516 *)
1518 S.ConnectTo(txt);
1519 S.SetPos(0);
1520 end := LEN(txt$);
1522 S.Scan;
1523 IF S.type = TMString THEN
1524 IF S.string = "dos" THEN comLine := TRUE; S.Scan END;
1525 name := S.string$; S.Scan;
1526 IF (S.type = TMChar) & (S.char = ".") THEN S.Scan;
1527 IF S.type = TMString THEN
1528 Kernel.MakeFileName(name, S.string); S.Scan
1529 END
1530 ELSE Kernel.MakeFileName(name, "EXE");
1531 END;
1532 IF (S.type = TMChar) & (S.char = ":") THEN S.Scan;
1533 IF (S.type = TMChar) & (S.char = "=") THEN S.Scan;
1534 WHILE (S.start < end) & (S.type = TMString) DO
1535 NEW(mod); mod.name := S.string$;
1536 mod.next := modList; modList := mod;
1537 S.Scan;
1538 WHILE (S.start < end) & (S.type = TMChar) &
1539 ((S.char = "*") OR (S.char = "+") OR (S.char = "$") OR (S.char = "#")) DO
1540 IF S.char = "*" THEN mod.dll := TRUE
1541 ELSIF S.char = "+" THEN kernel := mod
1542 ELSIF S.char = "$" THEN main := mod
1543 ELSE mod.intf := TRUE;
1544 IF ~isDll THEN
1545 WriteSString("Exports from Exe not possible. Use LinkDll or LinkDynDll.");
1546 WriteLn; FlushW; error := TRUE
1547 END
1548 END;
1549 S.Scan
1550 END
1551 END;
1552 ScanRes(S, end, resList);
1553 ReadHeaders;
1554 PrepResources;
1555 IF ~error THEN WriteHeader(name) END;
1556 IF ~error THEN WriteOut(name) END;
1557 IF ~error THEN
1558 WriteString(name); WriteString(" written ");
1559 WriteInt(Out.Length()); WriteString(" "); WriteInt(CodeSize)
1560 END
1561 ELSE WriteString(" := missing")
1562 END
1563 ELSE WriteString(" := missing")
1564 END;
1565 WriteLn; FlushW
1566 END;
1567 (*
1568 IF error THEN Dialog.ShowStatus("failed") ELSE Dialog.ShowStatus("ok") END;
1569 W.ConnectTo(NIL); S.ConnectTo(NIL);
1570 *)
1571 IF error THEN Console.WriteStr("failed") ELSE Console.WriteStr("ok") END; Console.WriteLn;
1572 S.ConnectTo("");
1574 modList := NIL; kernel := NIL; main := NIL; firstExp := NIL; lastExp := NIL;
1575 last := NIL; impg := NIL; impd := NIL; resList := NIL; code := NIL; atab := NIL; ntab := NIL;
1576 fixups := NIL
1577 END LinkIt;
1579 PROCEDURE Link* (IN txt: ARRAY OF CHAR);
1580 BEGIN
1581 isDll := FALSE; isStatic := FALSE;
1582 LinkIt(txt)
1583 END Link;
1585 PROCEDURE LinkExe* (IN txt: ARRAY OF CHAR);
1586 BEGIN
1587 isDll := FALSE; isStatic := TRUE;
1588 LinkIt(txt)
1589 END LinkExe;
1591 PROCEDURE LinkDll* (IN txt: ARRAY OF CHAR);
1592 BEGIN
1593 isDll := TRUE; isStatic := TRUE;
1594 LinkIt(txt)
1595 END LinkDll;
1597 PROCEDURE LinkDynDll* (IN txt: ARRAY OF CHAR);
1598 BEGIN
1599 isDll := TRUE; isStatic := FALSE;
1600 LinkIt(txt)
1601 END LinkDynDll;
1603 (*
1604 PROCEDURE Show*;
1605 VAR S: TextMappers.Scanner; name: Name; mod: Module; t: TextModels.Model;
1606 BEGIN
1607 t := TextViews.FocusText(); IF t = NIL THEN RETURN END;
1608 W.ConnectTo(Log.buf); S.ConnectTo(t); S.Scan;
1609 IF S.type = TextMappers.string THEN
1610 mod := modList;
1611 WHILE (mod # NIL) & (mod.name # S.string) DO mod := mod.next END;
1612 IF mod # NIL THEN
1613 W.WriteString(S.string);
1614 W.WriteString(" ca = ");
1615 W.WriteIntForm(CodeBase + mod.ca, TextMappers.hexadecimal, 8, "0", TRUE);
1616 W.WriteLn; Log.text.Append(Log.buf)
1617 END
1618 END;
1619 W.ConnectTo(NIL); S.ConnectTo(NIL)
1620 END Show;
1621 *)
1623 BEGIN
1624 newRec := "NewRec"; newArr := "NewArr"
1625 END Dev0Linker.
1628 (!)DevLinker.Link Usekrnl.exe := TestKernel$+ Usekrnl ~ (!)"DevDecExe.Decode('', 'Usekrnl.exe')"
1630 (!)DevLinker.LinkDynDll MYDLL.dll := TestKernel+ MYDLL$# ~ (!)"DevDecExe.Decode('', 'MYDLL.dll')"
1632 (!)DevLinker.LinkExe Usekrnl.exe := TestKernel+ Usekrnl ~ (!)"DevDecExe.Decode('', 'Usekrnl.exe')"
1634 (!)DevLinker.LinkDll MYDLL.dll := TestKernel+ MYDLL# ~ (!)"DevDecExe.Decode('', 'MYDLL.dll')"
1637 MODULE TestKernel;
1638 IMPORT KERNEL32;
1640 PROCEDURE Beep*;
1641 BEGIN
1642 KERNEL32.Beep(500, 200)
1643 END Beep;
1645 BEGIN
1646 CLOSE
1647 KERNEL32.ExitProcess(0)
1648 END TestKernel.
1650 MODULE Usekrnl;
1651 (* empty windows application using BlackBox Kernel *)
1652 (* Ominc (!) *)
1654 IMPORT KERNEL32, USER32, GDI32, S := SYSTEM, Kernel := TestKernel;
1656 VAR Instance, MainWnd: USER32.Handle;
1658 PROCEDURE WndHandler (wnd, message, wParam, lParam: INTEGER): INTEGER;
1659 VAR res: INTEGER; ps: USER32.PaintStruct; dc: GDI32.Handle;
1660 BEGIN
1661 IF message = USER32.WMDestroy THEN
1662 USER32.PostQuitMessage(0)
1663 ELSIF message = USER32.WMPaint THEN
1664 dc := USER32.BeginPaint(wnd, ps);
1665 res := GDI32.TextOutA(dc, 50, 50, "Hello World", 11);
1666 res := USER32.EndPaint(wnd, ps)
1667 ELSIF message = USER32.WMChar THEN
1668 Kernel.Beep
1669 ELSE
1670 RETURN USER32.DefWindowProcA(wnd, message, wParam, lParam)
1671 END;
1672 RETURN 0
1673 END WndHandler;
1675 PROCEDURE OpenWindow;
1676 VAR class: USER32.WndClass; res: INTEGER;
1677 BEGIN
1678 class.cursor := USER32.LoadCursorA(0, USER32.MakeIntRsrc(USER32.IDCArrow));
1679 class.icon := USER32.LoadIconA(Instance, USER32.MakeIntRsrc(1));
1680 class.menuName := NIL;
1681 class.className := "Simple";
1682 class.backgnd := GDI32.GetStockObject(GDI32.WhiteBrush);
1683 class.style := {0, 1, 5, 7};
1684 class.instance := Instance;
1685 class.wndProc := WndHandler;
1686 class.clsExtra := 0;
1687 class.wndExtra := 0;
1688 USER32.RegisterClassA(class);
1689 MainWnd := USER32.CreateWindowExA({}, "Simple", "Empty Windows Application",
1690 {16..19, 22, 23, 25},
1691 USER32.CWUseDefault, USER32.CWUseDefault,
1692 USER32.CWUseDefault, USER32.CWUseDefault,
1693 0, 0, Instance, 0);
1694 res := USER32.ShowWindow(MainWnd, 10);
1695 res := USER32.UpdateWindow(MainWnd);
1696 END OpenWindow;
1698 PROCEDURE MainLoop;
1699 VAR msg: USER32.Message; res: INTEGER;
1700 BEGIN
1701 WHILE USER32.GetMessageA(msg, 0, 0, 0) # 0 DO
1702 res := USER32.TranslateMessage(msg);
1703 res := USER32.DispatchMessageA(msg);
1704 END;
1705 (*
1706 KERNEL32.ExitProcess(msg.wParam)
1707 *)
1708 END MainLoop;
1710 BEGIN
1711 Instance := KERNEL32.GetModuleHandleA(NIL);
1712 OpenWindow;
1713 MainLoop
1714 CLOSE
1715 Kernel.Beep
1716 END Usekrnl.
1719 MODULE MYDLL;
1720 (* sample module to be linked into a dll *)
1721 (* Ominc (!) *)
1723 IMPORT SYSTEM, KERNEL32;
1725 VAR expVar*: INTEGER;
1727 PROCEDURE GCD* (a, b: INTEGER): INTEGER;
1728 BEGIN
1729 WHILE a # b DO
1730 IF a < b THEN b := b - a ELSE a := a - b END
1731 END;
1732 expVar := a;
1733 RETURN a
1734 END GCD;
1736 PROCEDURE Beep*;
1737 BEGIN
1738 KERNEL32.Beep(500, 200)
1739 END Beep;
1741 CLOSE
1742 Beep
1743 END MYDLL.
1747 Resource = Id [ "[" Language "]" ] Options name [ "." ext ] [ "(" { Resource } ")" ]
1748 Id = number
1749 Language = number
1750 Options = { "@" | "!" .. "?" | "^" | "~" }
1752 names
1754 MENU
1755 1 MENU (0 File (11 New 12 Open 13 Save 0 "" 14 Exit) 0 Edit (21 Cut 22 Copy 23 Paste))
1756 = grayed
1757 - inctive
1758 # bitmap
1759 * checked
1760 ! menuBarBreak
1761 / menuBreak
1762 ? ownerDraw
1764 ACCELERATOR
1765 1 ACCELERATOR (11 ^N 12 ^O 13 ^S 21 ^X 22 ^C 23 ^V)
1766 * shift
1767 ^ ctrl
1768 @ alt
1769 - noInvert
1771 filename.ico
1773 filename.cur
1775 filname.bmp
1777 filename.res
1779 filename.tlb