0732d5c06fd0265ff29279c1a16eb82d4b92d489
1 MODULE Kernel;
3 (* THIS IS TEXT COPY OF Kernel.odc *)
4 (* DO NOT EDIT *)
6 (* A. V. Shiryaev, 2012.11
7 OpenBSD Kernel
8 Based on 1.6-rc6 Windows Kernel
9 + 20120822 Marc changes
10 Some parts taken from OpenBUGS linKernel
12 Most Windows-specific code removed
13 Some Windows-specific code commented and marked red
14 Windows COM-specific code re-marked from green to gray
15 OpenBSD(/Linux)-specific code marked green
17 TODO:
18 handle stack overflow exceptions
19 Quit from TrapHandler
20 *)
22 IMPORT S := SYSTEM, Libc := LinLibc, Dl := LinDl;
24 CONST
25 strictStackSweep = TRUE;
27 nameLen* = 256;
29 littleEndian* = TRUE;
30 timeResolution* = 1000; (* ticks per second *)
32 processor* = 10; (* i386 *)
34 objType* = "ocf"; (* file types *)
35 symType* = "osf";
36 docType* = "odc";
38 (* loader constants *)
39 done* = 0;
40 fileNotFound* = 1;
41 syntaxError* = 2;
42 objNotFound* = 3;
43 illegalFPrint* = 4;
44 cyclicImport* = 5;
45 noMem* = 6;
46 commNotFound* = 7;
47 commSyntaxError* = 8;
48 moduleNotFound* = 9;
50 any = 1000000;
52 CX = 1;
53 SP = 4; (* register number of stack pointer *)
54 FP = 5; (* register number of frame pointer *)
55 ML = 3; (* register which holds the module list at program start *)
57 N = 128 DIV 16; (* free lists *)
59 (* kernel flags in module desc *)
60 init = 16; dyn = 17; dll = 24; iptrs = 30;
62 (* meta interface consts *)
63 mConst = 1; mTyp = 2; mVar = 3; mProc = 4; mField = 5;
65 debug = FALSE;
68 (*
69 sigStackSize = MAX(Libc.SIGSTKSZ, 65536);
70 *)
72 trapReturn = 1; (* Return value for sigsetjmp given from siglongjmp *)
74 (* constants for the message boxes *)
75 mbClose* = -1; mbOk* = 0; mbCancel* =1; mbRetry* = 2; mbIgnore* = 3; mbYes* = 4; mbNo* = 5;
77 TYPE
78 Name* = ARRAY nameLen OF SHORTCHAR;
79 Command* = PROCEDURE;
81 Module* = POINTER TO RECORD [untagged]
82 next-: Module;
83 opts-: SET; (* 0..15: compiler opts, 16..31: kernel flags *)
84 refcnt-: INTEGER; (* <0: module invalidated *)
85 compTime-, loadTime-: ARRAY 6 OF SHORTINT;
86 ext-: INTEGER; (* currently not used *)
87 term-: Command; (* terminator *)
88 nofimps-, nofptrs-: INTEGER;
89 csize-, dsize-, rsize-: INTEGER;
90 code-, data-, refs-: INTEGER;
91 procBase-, varBase-: INTEGER; (* meta base addresses *)
92 names-: POINTER TO ARRAY [untagged] OF SHORTCHAR; (* names[0] = 0X *)
93 ptrs-: POINTER TO ARRAY [untagged] OF INTEGER;
94 imports-: POINTER TO ARRAY [untagged] OF Module;
95 export-: Directory; (* exported objects (name sorted) *)
96 name-: Name
97 END;
99 Type* = POINTER TO RECORD [untagged]
100 (* record: ptr to method n at offset - 4 * (n+1) *)
101 size-: INTEGER; (* record: size, array: #elem, dyn array: 0, proc: sigfp *)
102 mod-: Module;
103 id-: INTEGER; (* name idx * 256 + lev * 16 + attr * 4 + form *)
104 base-: ARRAY 16 OF Type; (* signature if form = ProcTyp *)
105 fields-: Directory; (* new fields (declaration order) *)
106 ptroffs-: ARRAY any OF INTEGER (* array of any length *)
107 END;
109 Object* = POINTER TO ObjDesc;
111 ObjDesc* = RECORD [untagged]
112 fprint-: INTEGER;
113 offs-: INTEGER; (* pvfprint for record types *)
114 id-: INTEGER; (* name idx * 256 + vis * 16 + mode *)
115 struct-: Type (* id of basic type or pointer to typedesc/signature *)
116 END;
118 Directory* = POINTER TO RECORD [untagged]
119 num-: INTEGER; (* number of entries *)
120 obj-: ARRAY any OF ObjDesc (* array of any length *)
121 END;
123 Signature* = POINTER TO RECORD [untagged]
124 retStruct-: Type; (* id of basic type or pointer to typedesc or 0 *)
125 num-: INTEGER; (* number of parameters *)
126 par-: ARRAY any OF RECORD [untagged] (* parameters *)
127 id-: INTEGER; (* name idx * 256 + kind *)
128 struct-: Type (* id of basic type or pointer to typedesc *)
129 END
130 END;
132 Handler* = PROCEDURE;
134 Reducer* = POINTER TO ABSTRACT RECORD
135 next: Reducer
136 END;
138 Identifier* = ABSTRACT RECORD
139 typ*: INTEGER;
140 obj-: ANYPTR
141 END;
143 TrapCleaner* = POINTER TO ABSTRACT RECORD
144 next: TrapCleaner
145 END;
147 TryHandler* = PROCEDURE (a, b, c: INTEGER);
150 (* meta extension suport *)
152 ItemExt* = POINTER TO ABSTRACT RECORD END;
154 ItemAttr* = RECORD
155 obj*, vis*, typ*, adr*: INTEGER;
156 mod*: Module;
157 desc*: Type;
158 ptr*: S.PTR;
159 ext*: ItemExt
160 END;
162 Hook* = POINTER TO ABSTRACT RECORD END;
164 LoaderHook* = POINTER TO ABSTRACT RECORD (Hook)
165 res*: INTEGER;
166 importing*, imported*, object*: ARRAY 256 OF CHAR
167 END;
169 GuiHook* = POINTER TO ABSTRACT RECORD (Hook) END; (* Implemented by HostGnome *)
171 Block = POINTER TO RECORD [untagged]
172 tag: Type;
173 last: INTEGER; (* arrays: last element *)
174 actual: INTEGER; (* arrays: used during mark phase *)
175 first: INTEGER (* arrays: first element *)
176 END;
178 FreeBlock = POINTER TO FreeDesc;
180 FreeDesc = RECORD [untagged]
181 tag: Type; (* f.tag = ADR(f.size) *)
182 size: INTEGER;
183 next: FreeBlock
184 END;
186 Cluster = POINTER TO RECORD [untagged]
187 size: INTEGER; (* total size *)
188 next: Cluster;
189 max: INTEGER
190 (* start of first block *)
191 END;
193 FList = POINTER TO RECORD
194 next: FList;
195 blk: Block;
196 iptr, aiptr: BOOLEAN
197 END;
199 CList = POINTER TO RECORD
200 next: CList;
201 do: Command;
202 trapped: BOOLEAN
203 END;
206 PtrType = RECORD v: S.PTR END; (* used for array of pointer *)
207 Char8Type = RECORD v: SHORTCHAR END;
208 Char16Type = RECORD v: CHAR END;
209 Int8Type = RECORD v: BYTE END;
210 Int16Type = RECORD v: SHORTINT END;
211 Int32Type = RECORD v: INTEGER END;
212 Int64Type = RECORD v: LONGINT END;
213 BoolType = RECORD v: BOOLEAN END;
214 SetType = RECORD v: SET END;
215 Real32Type = RECORD v: SHORTREAL END;
216 Real64Type = RECORD v: REAL END;
217 ProcType = RECORD v: PROCEDURE END;
218 UPtrType = RECORD v: INTEGER END;
219 StrPtr = POINTER TO ARRAY [untagged] OF SHORTCHAR;
221 (* Linux specific boot loader info. Record must be identical to struct in the loader. *)
222 BootInfo* = POINTER TO RECORD [untagged]
223 modList: Module;
224 argc-: INTEGER;
225 argv-: Libc.StrArray
226 END;
228 VAR
229 baseStack: INTEGER; (* modList, root, and baseStack must be together for remote debugging *)
230 root: Cluster; (* cluster list *)
231 modList-: Module; (* root of module list *)
232 trapCount-: INTEGER;
233 err-, pc-, sp-, fp-, stack-, val-: INTEGER;
235 free: ARRAY N OF FreeBlock; (* free list *)
236 sentinelBlock: FreeDesc;
237 sentinel: FreeBlock;
238 candidates: ARRAY 1024 OF INTEGER;
239 nofcand: INTEGER;
240 allocated: INTEGER; (* bytes allocated on BlackBox heap *)
241 total: INTEGER; (* current total size of BlackBox heap *)
242 used: INTEGER; (* bytes allocated on system heap *)
243 finalizers: FList;
244 hotFinalizers: FList;
245 cleaners: CList;
246 reducers: Reducer;
247 trapStack: TrapCleaner;
248 actual: Module; (* valid during module initialization *)
250 res: INTEGER; (* auxiliary global variables used for trap handling *)
251 old: INTEGER;
253 trapViewer, trapChecker: Handler;
254 trapped, guarded, secondTrap: BOOLEAN;
255 interrupted: BOOLEAN;
256 static, inDll, terminating: BOOLEAN;
257 restart: Command;
259 told, shift: INTEGER; (* used in Time() *)
261 loader: LoaderHook;
262 loadres: INTEGER;
264 wouldFinalize: BOOLEAN;
266 watcher*: PROCEDURE (event: INTEGER); (* for debugging *)
269 (*
270 sigStack: Libc.PtrVoid;
271 *)
273 loopContext: Libc.sigjmp_buf; (* trap return context, if no Kernel.Try has been used. *)
274 currentTryContext: POINTER TO Libc.sigjmp_buf; (* trap return context, if Kernel.Try has been used. *)
275 isReadableContext: Libc.sigjmp_buf; (* for IsReadable *)
276 isReadableCheck: BOOLEAN;
278 guiHook: GuiHook;
280 (* !!! This variable has to be the last variable in the list. !!! *)
281 bootInfo-: BootInfo;
283 (* code procedures for fpu *)
285 PROCEDURE [1] FINIT 0DBH, 0E3H;
286 PROCEDURE [1] FLDCW 0D9H, 06DH, 0FCH; (* -4, FP *)
287 PROCEDURE [1] FSTCW 0D9H, 07DH, 0FCH; (* -4, FP *)
289 (* code procedure for memory erase *)
291 PROCEDURE [code] Erase (adr, words: INTEGER)
292 089H, 0C7H, (* MOV EDI, EAX *)
293 031H, 0C0H, (* XOR EAX, EAX *)
294 059H, (* POP ECX *)
295 0F2H, 0ABH; (* REP STOS *)
297 (* code procedure for stack allocate *)
299 PROCEDURE [code] ALLOC (* argument in CX *)
300 (*
301 PUSH EAX
302 ADD ECX,-5
303 JNS L0
304 XOR ECX,ECX
305 L0: AND ECX,-4 (n-8+3)/4*4
306 MOV EAX,ECX
307 AND EAX,4095
308 SUB ESP,EAX
309 MOV EAX,ECX
310 SHR EAX,12
311 JEQ L2
312 L1: PUSH 0
313 SUB ESP,4092
314 DEC EAX
315 JNE L1
316 L2: ADD ECX,8
317 MOV EAX,[ESP,ECX,-4]
318 PUSH EAX
319 MOV EAX,[ESP,ECX,-4]
320 SHR ECX,2
321 RET
322 *);
324 PROCEDURE (VAR id: Identifier) Identified* (): BOOLEAN, NEW, ABSTRACT;
325 PROCEDURE (r: Reducer) Reduce* (full: BOOLEAN), NEW, ABSTRACT;
326 PROCEDURE (c: TrapCleaner) Cleanup*, NEW, EMPTY;
329 (* meta extension suport *)
331 PROCEDURE (e: ItemExt) Lookup* (name: ARRAY OF CHAR; VAR i: ANYREC), NEW, ABSTRACT;
332 PROCEDURE (e: ItemExt) Index* (index: INTEGER; VAR elem: ANYREC), NEW, ABSTRACT;
333 PROCEDURE (e: ItemExt) Deref* (VAR ref: ANYREC), NEW, ABSTRACT;
335 PROCEDURE (e: ItemExt) Valid* (): BOOLEAN, NEW, ABSTRACT;
336 PROCEDURE (e: ItemExt) Size* (): INTEGER, NEW, ABSTRACT;
337 PROCEDURE (e: ItemExt) BaseTyp* (): INTEGER, NEW, ABSTRACT;
338 PROCEDURE (e: ItemExt) Len* (): INTEGER, NEW, ABSTRACT;
340 PROCEDURE (e: ItemExt) Call* (OUT ok: BOOLEAN), NEW, ABSTRACT;
341 PROCEDURE (e: ItemExt) BoolVal* (): BOOLEAN, NEW, ABSTRACT;
342 PROCEDURE (e: ItemExt) PutBoolVal* (x: BOOLEAN), NEW, ABSTRACT;
343 PROCEDURE (e: ItemExt) CharVal* (): CHAR, NEW, ABSTRACT;
344 PROCEDURE (e: ItemExt) PutCharVal* (x: CHAR), NEW, ABSTRACT;
345 PROCEDURE (e: ItemExt) IntVal* (): INTEGER, NEW, ABSTRACT;
346 PROCEDURE (e: ItemExt) PutIntVal* (x: INTEGER), NEW, ABSTRACT;
347 PROCEDURE (e: ItemExt) LongVal* (): LONGINT, NEW, ABSTRACT;
348 PROCEDURE (e: ItemExt) PutLongVal* (x: LONGINT), NEW, ABSTRACT;
349 PROCEDURE (e: ItemExt) RealVal* (): REAL, NEW, ABSTRACT;
350 PROCEDURE (e: ItemExt) PutRealVal* (x: REAL), NEW, ABSTRACT;
351 PROCEDURE (e: ItemExt) SetVal* (): SET, NEW, ABSTRACT;
352 PROCEDURE (e: ItemExt) PutSetVal* (x: SET), NEW, ABSTRACT;
353 PROCEDURE (e: ItemExt) PtrVal* (): ANYPTR, NEW, ABSTRACT;
354 PROCEDURE (e: ItemExt) PutPtrVal* (x: ANYPTR), NEW, ABSTRACT;
355 PROCEDURE (e: ItemExt) GetSStringVal* (OUT x: ARRAY OF SHORTCHAR;
356 OUT ok: BOOLEAN), NEW, ABSTRACT;
357 PROCEDURE (e: ItemExt) PutSStringVal* (IN x: ARRAY OF SHORTCHAR;
358 OUT ok: BOOLEAN), NEW, ABSTRACT;
359 PROCEDURE (e: ItemExt) GetStringVal* (OUT x: ARRAY OF CHAR; OUT ok: BOOLEAN), NEW, ABSTRACT;
360 PROCEDURE (e: ItemExt) PutStringVal* (IN x: ARRAY OF CHAR; OUT ok: BOOLEAN), NEW, ABSTRACT;
363 (* -------------------- miscellaneous tools -------------------- *)
365 PROCEDURE Msg (IN str: ARRAY OF CHAR);
366 VAR ss: ARRAY 1024 OF SHORTCHAR; res, l: INTEGER;
367 BEGIN
368 ss := SHORT(str);
369 l := LEN(ss$);
370 ss[l] := 0AX; ss[l + 1] := 0X;
371 res := Libc.printf(ss)
372 END Msg;
374 PROCEDURE Int (x: LONGINT);
375 VAR j, k: INTEGER; ch: CHAR; a, s: ARRAY 32 OF CHAR;
376 BEGIN
377 IF x # MIN(LONGINT) THEN
378 IF x < 0 THEN s[0] := "-"; k := 1; x := -x ELSE k := 0 END;
379 j := 0; REPEAT a[j] := CHR(x MOD 10 + ORD("0")); x := x DIV 10; INC(j) UNTIL x = 0
380 ELSE
381 a := "8085774586302733229"; s[0] := "-"; k := 1;
382 j := 0; WHILE a[j] # 0X DO INC(j) END
383 END;
384 ASSERT(k + j < LEN(s), 20);
385 REPEAT DEC(j); ch := a[j]; s[k] := ch; INC(k) UNTIL j = 0;
386 s[k] := 0X;
387 Msg(s);
388 END Int;
390 PROCEDURE (h: GuiHook) MessageBox* (
391 title, msg: ARRAY OF CHAR; buttons: SET): INTEGER, NEW, ABSTRACT;
392 PROCEDURE (h: GuiHook) Beep*, NEW, ABSTRACT;
394 (* Is extended by HostGnome to show dialogs. If no dialog is present or
395 if the dialog is not closed by using one button, then "mbClose" is returned *)
396 PROCEDURE MessageBox* (title, msg: ARRAY OF CHAR; buttons: SET): INTEGER;
397 VAR res: INTEGER;
398 BEGIN
399 IF guiHook # NIL THEN
400 res := guiHook.MessageBox(title, msg, buttons)
401 ELSE
402 Msg(" ");
403 Msg("****");
404 Msg("* " + title);
405 Msg("* " + msg);
406 Msg("****");
407 res := mbClose;
408 END;
409 RETURN res
410 END MessageBox;
412 PROCEDURE SetGuiHook* (hook: GuiHook);
413 BEGIN
414 guiHook := hook
415 END SetGuiHook;
417 PROCEDURE SplitName* (name: ARRAY OF CHAR; VAR head, tail: ARRAY OF CHAR);
418 (* portable *)
419 VAR i, j: INTEGER; ch, lch: CHAR;
420 BEGIN
421 i := 0; ch := name[0];
422 IF ch # 0X THEN
423 REPEAT
424 head[i] := ch; lch := ch; INC(i); ch := name[i]
425 UNTIL (ch = 0X)
426 OR ((ch >= "A") & (ch <= "Z") OR (ch >= "À") & (ch # "×") & (ch <= "Þ"))
427 & ((lch < "A") OR (lch > "Z") & (lch < "À") OR (lch = "×") OR (lch > "Þ"));
428 head[i] := 0X; j := 0;
429 WHILE ch # 0X DO tail[j] := ch; INC(i); INC(j); ch := name[i] END;
430 tail[j] := 0X;
431 IF tail = "" THEN tail := head$; head := "" END
432 ELSE head := ""; tail := ""
433 END
434 END SplitName;
436 PROCEDURE MakeFileName* (VAR name: ARRAY OF CHAR; type: ARRAY OF CHAR);
437 VAR i, j: INTEGER; ext: ARRAY 8 OF CHAR; ch: CHAR;
438 BEGIN
439 i := 0;
440 WHILE (name[i] # 0X) & (name[i] # ".") DO INC(i) END;
441 IF name[i] = "." THEN
442 IF name[i + 1] = 0X THEN name[i] := 0X END
443 ELSIF i < LEN(name) - 4 THEN
444 IF type = "" THEN ext := docType ELSE ext := type$ END;
445 name[i] := "."; INC(i); j := 0; ch := ext[0];
446 WHILE ch # 0X DO
447 IF (ch >= "A") & (ch <= "Z") THEN
448 ch := CHR(ORD(ch) + ORD("a") - ORD("A"))
449 END;
450 name[i] := ch; INC(i); INC(j); ch := ext[j]
451 END;
452 name[i] := 0X
453 END
454 END MakeFileName;
456 PROCEDURE Time* (): LONGINT;
457 VAR t: INTEGER;
458 BEGIN
459 (* t := WinApi.GetTickCount(); *)
461 (* A. V. Shiryaev: OpenBSD *)
462 ASSERT(Libc.CLOCKS_PER_SEC = 100);
463 t := 10 * Libc.clock();
465 IF t < told THEN INC(shift) END;
466 told := t;
467 RETURN shift * 100000000L + t
468 END Time;
470 PROCEDURE Beep* ();
471 VAR ss: ARRAY 2 OF SHORTCHAR;
472 BEGIN
473 IF guiHook # NIL THEN
474 guiHook.Beep
475 ELSE
476 ss[0] := 007X; ss[1] := 0X;
477 res := Libc.printf(ss); res := Libc.fflush(Libc.NULL)
478 END
479 END Beep;
481 PROCEDURE SearchProcVar* (var: INTEGER; VAR m: Module; VAR adr: INTEGER);
482 BEGIN
483 adr := var; m := NIL;
484 IF var # 0 THEN
485 m := modList;
486 WHILE (m # NIL) & ((var < m.code) OR (var >= m.code + m.csize)) DO m := m.next END;
487 IF m # NIL THEN DEC(adr, m.code) END
488 END
489 END SearchProcVar;
492 (* -------------------- system memory management --------------------- *)
494 (* A. V. Shiryaev, 2012.10: NOTE: it seems that GC works correctly with positive addesses only *)
496 (*
497 PROCEDURE HeapAlloc (adr: INTEGER; size: INTEGER; prot: SET): Libc.PtrVoid;
498 VAR
499 x: Libc.PtrVoid;
500 res: INTEGER;
501 BEGIN
502 x := Libc.calloc(1, size); (* calloc initialize allocated space to zero *)
503 IF x # Libc.NULL THEN
504 res := Libc.mprotect(x, size, prot);
505 IF res # 0 THEN
506 Libc.free(x);
507 x := Libc.NULL;
508 Msg("Kernel.HeapAlloc: mprotect failed!");
509 HALT(100)
510 END
511 END;
512 RETURN x
513 END HeapAlloc;
514 *)
515 PROCEDURE HeapAlloc (adr: Libc.PtrVoid; size: INTEGER; prot: SET): Libc.PtrVoid;
516 VAR x: Libc.PtrVoid;
517 BEGIN
518 x := Libc.mmap(adr, size, prot, Libc.MAP_PRIVATE + Libc.MAP_ANON, -1, 0);
519 IF x = Libc.MAP_FAILED THEN
520 x := Libc.NULL
521 ELSE
522 ASSERT(size MOD 4 = 0, 100);
523 Erase(x, size DIV 4)
524 END;
525 RETURN x
526 END HeapAlloc;
528 (*
529 PROCEDURE HeapFree (adr: Libc.PtrVoid; size: INTEGER);
530 VAR res: INTEGER;
531 BEGIN
532 (*
533 ASSERT(size MOD 4 = 0, 100);
534 Erase(adr, size DIV 4);
535 res := Libc.mprotect(adr, size, Libc.PROT_NONE);
536 ASSERT(res = 0, 101);
537 *)
538 Libc.free(adr)
539 END HeapFree;
540 *)
541 PROCEDURE HeapFree (adr: Libc.PtrVoid; size: INTEGER);
542 VAR res: INTEGER;
543 BEGIN
544 (*
545 ASSERT(size MOD 4 = 0, 100);
546 Erase(adr, size DIV 4);
547 res := Libc.mprotect(adr, size, Libc.PROT_NONE);
548 ASSERT(res = 0, 101);
549 *)
550 res := Libc.munmap(adr, size);
551 ASSERT(res = 0, 102)
552 END HeapFree;
554 PROCEDURE AllocHeapMem (size: INTEGER; VAR c: Cluster);
555 (* allocate at least size bytes, typically at least 256 kbytes are allocated *)
556 CONST N = 65536; (* cluster size for dll *)
557 prot = Libc.PROT_READ + Libc.PROT_WRITE (* + Libc.PROT_EXEC *);
558 VAR adr: INTEGER;
559 allocated: INTEGER;
560 BEGIN
561 INC(size, 16);
562 ASSERT(size > 0, 100); adr := 0;
563 IF size < N THEN adr := HeapAlloc(65536, N, prot) END;
564 IF adr = 0 THEN adr := HeapAlloc(65536, size, prot); allocated := size ELSE allocated := N END;
565 IF adr = 0 THEN c := NIL
566 ELSE
567 c := S.VAL(Cluster, (adr + 15) DIV 16 * 16); c.max := adr;
568 c.size := allocated - (S.VAL(INTEGER, c) - adr);
569 INC(used, c.size); INC(total, c.size)
570 END
571 (* post: (c = NIL) OR (c MOD 16 = 0) & (c.size >= size) *)
572 END AllocHeapMem;
574 PROCEDURE FreeHeapMem (c: Cluster);
575 BEGIN
576 DEC(used, c.size); DEC(total, c.size);
577 HeapFree(c.max, (S.VAL(INTEGER, c) - c.max) + c.size)
578 END FreeHeapMem;
580 PROCEDURE AllocModMem* (descSize, modSize: INTEGER; VAR descAdr, modAdr: INTEGER);
581 CONST
582 prot = Libc.PROT_READ + Libc.PROT_WRITE (* + Libc.PROT_EXEC *);
583 BEGIN
584 descAdr := HeapAlloc(0, descSize, prot);
585 IF descAdr # 0 THEN
586 modAdr := HeapAlloc(0, modSize, prot);
587 IF modAdr # 0 THEN INC(used, descSize + modSize)
588 ELSE HeapFree(descAdr, descSize); descAdr := 0
589 END
590 ELSE modAdr := 0
591 END
592 END AllocModMem;
594 PROCEDURE DeallocModMem* (descSize, modSize, descAdr, modAdr: INTEGER);
595 BEGIN
596 DEC(used, descSize + modSize);
597 HeapFree(descAdr, descSize);
598 HeapFree(modAdr, modSize)
599 END DeallocModMem;
601 PROCEDURE InvalModMem (modSize, modAdr: INTEGER);
602 BEGIN
603 DEC(used, modSize);
604 HeapFree(modAdr, modSize)
605 END InvalModMem;
607 (*
608 PROCEDURE IsReadable* (from, to: INTEGER): BOOLEAN;
609 (* check wether memory between from (incl.) and to (excl.) may be read *)
610 BEGIN
611 RETURN WinApi.IsBadReadPtr(from, to - from) = 0
612 END IsReadable;
613 *)
615 (* Alexander Shiryaev, 2012.10: I do not know other way that works in OpenBSD *)
616 (* This procedure can be called from TrapHandler also *)
617 PROCEDURE IsReadable* (from, to: INTEGER): BOOLEAN;
618 (* check wether memory between from (incl.) and to (excl.) may be read *)
619 VAR res: BOOLEAN; res1: INTEGER;
620 x: SHORTCHAR;
621 mask, omask: Libc.sigset_t;
622 BEGIN
623 (* save old sigmask and unblock SIGSEGV *)
624 res1 := Libc.sigemptyset(S.ADR(mask));
625 ASSERT(res1 = 0, 100);
626 res1 := Libc.sigaddset(S.ADR(mask), Libc.SIGSEGV);
627 ASSERT(res1 = 0, 101);
628 res1 := Libc.sigprocmask(Libc.SIG_UNBLOCK, mask, omask);
629 ASSERT(res1 = 0, 102);
631 res := FALSE;
632 res1 := Libc.sigsetjmp(isReadableContext, Libc.TRUE);
633 IF res1 = 0 THEN
634 isReadableCheck := TRUE;
635 (* read memory *)
636 REPEAT
637 S.GET(from, x);
638 INC(from)
639 UNTIL from = to;
640 res := TRUE
641 ELSE
642 ASSERT(res1 = 1, 103)
643 END;
644 isReadableCheck := FALSE;
646 (* restore saved sigmask *)
647 res1 := Libc.sigprocmask(Libc.SIG_SETMASK, omask, NIL);
648 ASSERT(res1 = 0, 104);
650 RETURN res
651 END IsReadable;
653 (* --------------------- NEW implementation (portable) -------------------- *)
655 PROCEDURE^ NewBlock (size: INTEGER): Block;
657 PROCEDURE NewRec* (typ: INTEGER): INTEGER; (* implementation of NEW(ptr) *)
658 VAR size: INTEGER; b: Block; tag: Type; l: FList;
659 BEGIN
660 IF ODD(typ) THEN (* record contains interface pointers *)
661 tag := S.VAL(Type, typ - 1);
662 b := NewBlock(tag.size);
663 IF b = NIL THEN RETURN 0 END;
664 b.tag := tag;
665 l := S.VAL(FList, S.ADR(b.last)); (* anchor new object! *)
666 l := S.VAL(FList, NewRec(S.TYP(FList))); (* NEW(l) *)
667 l.blk := b; l.iptr := TRUE; l.next := finalizers; finalizers := l;
668 RETURN S.ADR(b.last)
669 ELSE
670 tag := S.VAL(Type, typ);
671 b := NewBlock(tag.size);
672 IF b = NIL THEN RETURN 0 END;
673 b.tag := tag; S.GET(typ - 4, size);
674 IF size # 0 THEN (* record uses a finalizer *)
675 l := S.VAL(FList, S.ADR(b.last)); (* anchor new object! *)
676 l := S.VAL(FList, NewRec(S.TYP(FList))); (* NEW(l) *)
677 l.blk := b; l.next := finalizers; finalizers := l
678 END;
679 RETURN S.ADR(b.last)
680 END
681 END NewRec;
683 PROCEDURE NewArr* (eltyp, nofelem, nofdim: INTEGER): INTEGER; (* impl. of NEW(ptr, dim0, dim1, ...) *)
684 VAR b: Block; size, headSize: INTEGER; t: Type; fin: BOOLEAN; l: FList;
685 BEGIN
686 IF (nofdim < 0)OR(nofdim>1FFFFFFCH) THEN RETURN 0 END;(*20120822 Marc*)
687 headSize := 4 * nofdim + 12; fin := FALSE;
688 CASE eltyp OF
689 (*
690 | -1: eltyp := S.ADR(IntPtrType); fin := TRUE
691 *)
692 | -1: HALT(100)
693 | 0: eltyp := S.ADR(PtrType)
694 | 1: eltyp := S.ADR(Char8Type)
695 | 2: eltyp := S.ADR(Int16Type)
696 | 3: eltyp := S.ADR(Int8Type)
697 | 4: eltyp := S.ADR(Int32Type)
698 | 5: eltyp := S.ADR(BoolType)
699 | 6: eltyp := S.ADR(SetType)
700 | 7: eltyp := S.ADR(Real32Type)
701 | 8: eltyp := S.ADR(Real64Type)
702 | 9: eltyp := S.ADR(Char16Type)
703 | 10: eltyp := S.ADR(Int64Type)
704 | 11: eltyp := S.ADR(ProcType)
705 | 12: eltyp := S.ADR(UPtrType)
706 ELSE (* eltyp is desc *)
707 IF ODD(eltyp) THEN DEC(eltyp); fin := TRUE END
708 END;
709 t := S.VAL(Type, eltyp);
710 ASSERT(t .size> 0,100);
711 IF (nofelem < 0) OR( (7FFFFFFFH-headSize) DIV t.size < nofelem) THEN (* 20120822 Marc*)
712 RETURN 0
713 END;
714 size := headSize + nofelem * t.size;
715 b := NewBlock(size);
716 IF b = NIL THEN RETURN 0 END;
717 b.tag := S.VAL(Type, eltyp + 2); (* tag + array mark *)
718 b.last := S.ADR(b.last) + size - t.size; (* pointer to last elem *)
719 b.first := S.ADR(b.last) + headSize; (* pointer to first elem *)
720 IF fin THEN
721 l := S.VAL(FList, S.ADR(b.last)); (* anchor new object! *)
722 l := S.VAL(FList, NewRec(S.TYP(FList))); (* NEW(l) *)
723 l.blk := b; l.aiptr := TRUE; l.next := finalizers; finalizers := l
724 END;
725 RETURN S.ADR(b.last)
726 END NewArr;
729 (* -------------------- handler installation (portable) --------------------- *)
731 PROCEDURE ThisFinObj* (VAR id: Identifier): ANYPTR;
732 VAR l: FList;
733 BEGIN
734 ASSERT(id.typ # 0, 100);
735 l := finalizers;
736 WHILE l # NIL DO
737 IF S.VAL(INTEGER, l.blk.tag) = id.typ THEN
738 id.obj := S.VAL(ANYPTR, S.ADR(l.blk.last));
739 IF id.Identified() THEN RETURN id.obj END
740 END;
741 l := l.next
742 END;
743 RETURN NIL
744 END ThisFinObj;
746 PROCEDURE InstallReducer* (r: Reducer);
747 BEGIN
748 r.next := reducers; reducers := r
749 END InstallReducer;
751 PROCEDURE InstallTrapViewer* (h: Handler);
752 BEGIN
753 trapViewer := h
754 END InstallTrapViewer;
756 PROCEDURE InstallTrapChecker* (h: Handler);
757 BEGIN
758 trapChecker := h
759 END InstallTrapChecker;
761 PROCEDURE PushTrapCleaner* (c: TrapCleaner);
762 VAR t: TrapCleaner;
763 BEGIN
764 t := trapStack; WHILE (t # NIL) & (t # c) DO t := t.next END;
765 ASSERT(t = NIL, 20);
766 c.next := trapStack; trapStack := c
767 END PushTrapCleaner;
769 PROCEDURE PopTrapCleaner* (c: TrapCleaner);
770 VAR t: TrapCleaner;
771 BEGIN
772 t := NIL;
773 WHILE (trapStack # NIL) & (t # c) DO
774 t := trapStack; trapStack := trapStack.next
775 END
776 END PopTrapCleaner;
778 PROCEDURE InstallCleaner* (p: Command);
779 VAR c: CList;
780 BEGIN
781 c := S.VAL(CList, NewRec(S.TYP(CList))); (* NEW(c) *)
782 c.do := p; c.trapped := FALSE; c.next := cleaners; cleaners := c
783 END InstallCleaner;
785 PROCEDURE RemoveCleaner* (p: Command);
786 VAR c0, c: CList;
787 BEGIN
788 c := cleaners; c0 := NIL;
789 WHILE (c # NIL) & (c.do # p) DO c0 := c; c := c.next END;
790 IF c # NIL THEN
791 IF c0 = NIL THEN cleaners := cleaners.next ELSE c0.next := c.next END
792 END
793 END RemoveCleaner;
795 PROCEDURE Cleanup*;
796 VAR c, c0: CList;
797 BEGIN
798 c := cleaners; c0 := NIL;
799 WHILE c # NIL DO
800 IF ~c.trapped THEN
801 c.trapped := TRUE; c.do; c.trapped := FALSE; c0 := c
802 ELSE
803 IF c0 = NIL THEN cleaners := cleaners.next
804 ELSE c0.next := c.next
805 END
806 END;
807 c := c.next
808 END
809 END Cleanup;
811 (* -------------------- meta information (portable) --------------------- *)
813 PROCEDURE (h: LoaderHook) ThisMod* (IN name: ARRAY OF SHORTCHAR): Module, NEW, ABSTRACT;
815 PROCEDURE SetLoaderHook*(h: LoaderHook);
816 BEGIN
817 loader := h
818 END SetLoaderHook;
820 PROCEDURE InitModule (mod: Module); (* initialize linked modules *)
821 VAR body: Command;
822 res: INTEGER; errno: INTEGER;
823 BEGIN
824 IF ~(dyn IN mod.opts) & (mod.next # NIL) & ~(init IN mod.next.opts) THEN InitModule(mod.next) END;
825 IF ~(init IN mod.opts) THEN
826 body := S.VAL(Command, mod.code);
827 INCL(mod.opts, init);
828 actual := mod;
830 (* A. V. Shiryaev: Allow execution on code pages *)
831 res := Libc.mprotect(mod.code, mod.csize,
832 Libc.PROT_READ + Libc.PROT_WRITE + Libc.PROT_EXEC);
833 IF res = -1 THEN
834 S.GET( Libc.__errno_location(), errno );
835 Msg("ERROR: Kernel.InitModule: mprotect failed!");
836 Msg(mod.name$); Int(mod.code); Int(mod.csize); Int(errno);
837 HALT(100)
838 ELSE ASSERT(res = 0)
839 END;
841 body(); actual := NIL
842 END
843 END InitModule;
845 PROCEDURE ThisLoadedMod* (IN name: ARRAY OF SHORTCHAR): Module; (* loaded modules only *)
846 VAR m: Module;
847 BEGIN
848 loadres := done;
849 m := modList;
850 WHILE (m # NIL) & ((m.name # name) OR (m.refcnt < 0)) DO m := m.next END;
851 IF (m # NIL) & ~(init IN m.opts) THEN InitModule(m) END;
852 IF m = NIL THEN loadres := moduleNotFound END;
853 RETURN m
854 END ThisLoadedMod;
856 PROCEDURE ThisMod* (IN name: ARRAY OF CHAR): Module;
857 VAR n : Name;
858 BEGIN
859 n := SHORT(name$);
860 IF loader # NIL THEN
861 loader.res := done;
862 RETURN loader.ThisMod(n)
863 ELSE
864 RETURN ThisLoadedMod(n)
865 END
866 END ThisMod;
868 PROCEDURE LoadMod* (IN name: ARRAY OF CHAR);
869 VAR m: Module;
870 BEGIN
871 m := ThisMod(name)
872 END LoadMod;
874 PROCEDURE GetLoaderResult* (OUT res: INTEGER; OUT importing, imported, object: ARRAY OF CHAR);
875 BEGIN
876 IF loader # NIL THEN
877 res := loader.res;
878 importing := loader.importing$;
879 imported := loader.imported$;
880 object := loader.object$
881 ELSE
882 res := loadres;
883 importing := "";
884 imported := "";
885 object := ""
886 END
887 END GetLoaderResult;
889 PROCEDURE ThisObject* (mod: Module; name: ARRAY OF SHORTCHAR): Object;
890 VAR l, r, m: INTEGER; p: StrPtr;
891 BEGIN
892 l := 0; r := mod.export.num;
893 WHILE l < r DO (* binary search *)
894 m := (l + r) DIV 2;
895 p := S.VAL(StrPtr, S.ADR(mod.names[mod.export.obj[m].id DIV 256]));
896 IF p^ = name THEN RETURN S.VAL(Object, S.ADR(mod.export.obj[m])) END;
897 IF p^ < name THEN l := m + 1 ELSE r := m END
898 END;
899 RETURN NIL
900 END ThisObject;
902 PROCEDURE ThisDesc* (mod: Module; fprint: INTEGER): Object;
903 VAR i, n: INTEGER;
904 BEGIN
905 i := 0; n := mod.export.num;
906 WHILE (i < n) & (mod.export.obj[i].id DIV 256 = 0) DO
907 IF mod.export.obj[i].offs = fprint THEN RETURN S.VAL(Object, S.ADR(mod.export.obj[i])) END;
908 INC(i)
909 END;
910 RETURN NIL
911 END ThisDesc;
913 PROCEDURE ThisField* (rec: Type; name: ARRAY OF SHORTCHAR): Object;
914 VAR n: INTEGER; p: StrPtr; obj: Object; m: Module;
915 BEGIN
916 m := rec.mod;
917 obj := S.VAL(Object, S.ADR(rec.fields.obj[0])); n := rec.fields.num;
918 WHILE n > 0 DO
919 p := S.VAL(StrPtr, S.ADR(m.names[obj.id DIV 256]));
920 IF p^ = name THEN RETURN obj END;
921 DEC(n); INC(S.VAL(INTEGER, obj), 16)
922 END;
923 RETURN NIL
924 END ThisField;
926 PROCEDURE ThisCommand* (mod: Module; name: ARRAY OF SHORTCHAR): Command;
927 VAR x: Object; sig: Signature;
928 BEGIN
929 x := ThisObject(mod, name);
930 IF (x # NIL) & (x.id MOD 16 = mProc) THEN
931 sig := S.VAL(Signature, x.struct);
932 IF (sig.retStruct = NIL) & (sig.num = 0) THEN RETURN S.VAL(Command, mod.procBase + x.offs) END
933 END;
934 RETURN NIL
935 END ThisCommand;
937 PROCEDURE ThisType* (mod: Module; name: ARRAY OF SHORTCHAR): Type;
938 VAR x: Object;
939 BEGIN
940 x := ThisObject(mod, name);
941 IF (x # NIL) & (x.id MOD 16 = mTyp) & (S.VAL(INTEGER, x.struct) DIV 256 # 0) THEN
942 RETURN x.struct
943 ELSE
944 RETURN NIL
945 END
946 END ThisType;
948 PROCEDURE TypeOf* (IN rec: ANYREC): Type;
949 BEGIN
950 RETURN S.VAL(Type, S.TYP(rec))
951 END TypeOf;
953 PROCEDURE LevelOf* (t: Type): SHORTINT;
954 BEGIN
955 RETURN SHORT(t.id DIV 16 MOD 16)
956 END LevelOf;
958 PROCEDURE NewObj* (VAR o: S.PTR; t: Type);
959 VAR i: INTEGER;
960 BEGIN
961 IF t.size = -1 THEN o := NIL
962 ELSE
963 i := 0; WHILE t.ptroffs[i] >= 0 DO INC(i) END;
964 IF t.ptroffs[i+1] >= 0 THEN INC(S.VAL(INTEGER, t)) END; (* with interface pointers *)
965 o := S.VAL(S.PTR, NewRec(S.VAL(INTEGER, t))) (* generic NEW *)
966 END
967 END NewObj;
969 PROCEDURE GetObjName* (mod: Module; obj: Object; VAR name: Name);
970 VAR p: StrPtr;
971 BEGIN
972 p := S.VAL(StrPtr, S.ADR(mod.names[obj.id DIV 256]));
973 name := p^$
974 END GetObjName;
976 PROCEDURE GetTypeName* (t: Type; VAR name: Name);
977 VAR p: StrPtr;
978 BEGIN
979 p := S.VAL(StrPtr, S.ADR(t.mod.names[t.id DIV 256]));
980 name := p^$
981 END GetTypeName;
983 PROCEDURE RegisterMod* (mod: Module);
984 VAR i: INTEGER;
985 t: Libc.time_t; tm: Libc.tm;
986 BEGIN
987 mod.next := modList; modList := mod; mod.refcnt := 0; INCL(mod.opts, dyn); i := 0;
988 WHILE i < mod.nofimps DO
989 IF mod.imports[i] # NIL THEN INC(mod.imports[i].refcnt) END;
990 INC(i)
991 END;
993 t := Libc.time(NIL);
994 tm := Libc.localtime(t);
995 mod.loadTime[0] := SHORT(tm.tm_year + 1900); (* Linux counts years from 1900 but BlackBox from 0000 *)
996 mod.loadTime[1] := SHORT(tm.tm_mon + 1) (* Linux month range 0-11 but BB month range 1-12 *);
997 mod.loadTime[2] := SHORT(tm.tm_mday);
998 mod.loadTime[3] := SHORT(tm.tm_hour);
999 mod.loadTime[4] := SHORT(tm.tm_min);
1000 mod.loadTime[5] := SHORT(tm.tm_sec);
1001 tm := NIL;
1003 IF ~(init IN mod.opts) THEN InitModule(mod) END
1004 END RegisterMod;
1006 PROCEDURE^ Collect*;
1008 PROCEDURE UnloadMod* (mod: Module);
1009 VAR i: INTEGER; t: Command;
1010 BEGIN
1011 IF mod.refcnt = 0 THEN
1012 t := mod.term; mod.term := NIL;
1013 IF t # NIL THEN t() END; (* terminate module *)
1014 i := 0;
1015 WHILE i < mod.nofptrs DO (* release global pointers *)
1016 S.PUT(mod.varBase + mod.ptrs[i], 0); INC(i)
1017 END;
1018 (*
1019 ReleaseIPtrs(mod); (* release global interface pointers *)
1020 *)
1021 Collect; (* call finalizers *)
1022 i := 0;
1023 WHILE i < mod.nofimps DO (* release imported modules *)
1024 IF mod.imports[i] # NIL THEN DEC(mod.imports[i].refcnt) END;
1025 INC(i)
1026 END;
1027 mod.refcnt := -1;
1028 IF dyn IN mod.opts THEN (* release memory *)
1029 InvalModMem(mod.data + mod.dsize - mod.refs, mod.refs)
1030 END
1031 END
1032 END UnloadMod;
1034 (* -------------------- dynamic procedure call --------------------- *) (* COMPILER DEPENDENT *)
1036 PROCEDURE [1] PUSH (p: INTEGER) 050H; (* push AX *)
1037 PROCEDURE [1] CALL (a: INTEGER) 0FFH, 0D0H; (* call AX *)
1038 PROCEDURE [1] RETI (): LONGINT;
1039 PROCEDURE [1] RETR (): REAL;
1041 (*
1042 type par
1043 32 bit scalar value
1044 64 bit scalar low hi
1045 var scalar address
1046 record address tag
1047 array address size
1048 open array address length .. length
1049 *)
1051 PROCEDURE Call* (adr: INTEGER; sig: Signature; IN par: ARRAY OF INTEGER; n: INTEGER): LONGINT;
1052 VAR p, kind, sp, size: INTEGER; typ: Type; r: REAL;
1053 BEGIN
1054 p := sig.num;
1055 WHILE p > 0 DO (* push parameters from right to left *)
1056 DEC(p);
1057 typ := sig.par[p].struct;
1058 kind := sig.par[p].id MOD 16;
1059 IF (S.VAL(INTEGER, typ) DIV 256 = 0) OR (typ.id MOD 4 IN {0, 3}) THEN (* scalar *)
1060 IF (kind = 10) & ((S.VAL(INTEGER, typ) = 8) OR (S.VAL(INTEGER, typ) = 10)) THEN (* 64 bit *)
1061 DEC(n); PUSH(par[n]) (* push hi word *)
1062 END;
1063 DEC(n); PUSH(par[n]) (* push value/address *)
1064 ELSIF typ.id MOD 4 = 1 THEN (* record *)
1065 IF kind # 10 THEN (* var par *)
1066 DEC(n); PUSH(par[n]); (* push tag *)
1067 DEC(n); PUSH(par[n]) (* push address *)
1068 ELSE
1069 DEC(n, 2); (* skip tag *)
1070 S.GETREG(SP, sp); sp := (sp - typ.size) DIV 4 * 4; S.PUTREG(SP, sp); (* allocate space *)
1071 S.MOVE(par[n], sp, typ.size) (* copy to stack *)
1072 END
1073 ELSIF typ.size = 0 THEN (* open array *)
1074 size := typ.id DIV 16 MOD 16; (* number of open dimensions *)
1075 WHILE size > 0 DO
1076 DEC(size); DEC(n); PUSH(par[n]) (* push length *)
1077 END;
1078 DEC(n); PUSH(par[n]) (* push address *)
1079 ELSE (* fix array *)
1080 IF kind # 10 THEN (* var par *)
1081 DEC(n, 2); PUSH(par[n]) (* push address *)
1082 ELSE
1083 DEC(n); size := par[n]; DEC(n);
1084 S.GETREG(SP, sp); sp := (sp - size) DIV 4 * 4; S.PUTREG(SP, sp); (* allocate space *)
1085 S.MOVE(par[n], sp, size) (* copy to stack *)
1086 END
1087 END
1088 END;
1089 ASSERT(n = 0);
1090 IF S.VAL(INTEGER, sig.retStruct) = 7 THEN (* shortreal *)
1091 CALL(adr);
1092 RETURN S.VAL(INTEGER, SHORT(RETR())) (* return value in fpu register *)
1093 ELSIF S.VAL(INTEGER, sig.retStruct) = 8 THEN (* real *)
1094 CALL(adr); r := RETR();
1095 RETURN S.VAL(LONGINT, r) (* return value in fpu register *)
1096 ELSE
1097 CALL(adr);
1098 RETURN RETI() (* return value in integer registers *)
1099 END
1100 END Call;
1102 (* -------------------- reference information (portable) --------------------- *)
1104 PROCEDURE RefCh (VAR ref: INTEGER; VAR ch: SHORTCHAR);
1105 BEGIN
1106 S.GET(ref, ch); INC(ref)
1107 END RefCh;
1109 PROCEDURE RefNum (VAR ref: INTEGER; VAR x: INTEGER);
1110 VAR s, n: INTEGER; ch: SHORTCHAR;
1111 BEGIN
1112 s := 0; n := 0; RefCh(ref, ch);
1113 WHILE ORD(ch) >= 128 DO INC(n, ASH(ORD(ch) - 128, s) ); INC(s, 7); RefCh(ref, ch) END;
1114 x := n + ASH(ORD(ch) MOD 64 - ORD(ch) DIV 64 * 64, s)
1115 END RefNum;
1117 PROCEDURE RefName (VAR ref: INTEGER; VAR n: Name);
1118 VAR i: INTEGER; ch: SHORTCHAR;
1119 BEGIN
1120 i := 0; RefCh(ref, ch);
1121 WHILE ch # 0X DO n[i] := ch; INC(i); RefCh(ref, ch) END;
1122 n[i] := 0X
1123 END RefName;
1125 PROCEDURE GetRefProc* (VAR ref: INTEGER; VAR adr: INTEGER; VAR name: Name);
1126 VAR ch: SHORTCHAR;
1127 BEGIN
1128 S.GET(ref, ch);
1129 WHILE ch >= 0FDX DO (* skip variables *)
1130 INC(ref); RefCh(ref, ch);
1131 IF ch = 10X THEN INC(ref, 4) END;
1132 RefNum(ref, adr); RefName(ref, name); S.GET(ref, ch)
1133 END;
1134 WHILE (ch > 0X) & (ch < 0FCX) DO (* skip source refs *)
1135 INC(ref); RefNum(ref, adr); S.GET(ref, ch)
1136 END;
1137 IF ch = 0FCX THEN INC(ref); RefNum(ref, adr); RefName(ref, name)
1138 ELSE adr := 0
1139 END
1140 END GetRefProc;
1142 (* A. V. Shiryaev, 2012.11 *)
1143 PROCEDURE CheckRefVarReadable (ref: INTEGER): BOOLEAN;
1144 VAR ok: BOOLEAN; ch: SHORTCHAR;
1145 p: INTEGER; (* address *)
1147 PROCEDURE Get;
1148 BEGIN
1149 IF ok THEN
1150 IF IsReadable(ref, ref+1) THEN (* S.GET(ref, ch); INC(ref) *) RefCh(ref, ch)
1151 ELSE ok := FALSE
1152 END
1153 END
1154 END Get;
1156 PROCEDURE Num;
1157 BEGIN
1158 Get; WHILE ok & (ORD(ch) >= 128) DO Get END
1159 END Num;
1161 PROCEDURE Name;
1162 BEGIN
1163 Get; WHILE ok & (ch # 0X) DO Get END
1164 END Name;
1166 BEGIN
1167 ok := TRUE;
1168 Get; (* mode *)
1169 IF ok & (ch >= 0FDX) THEN
1170 Get; (* form *)
1171 IF ok & (ch = 10X) THEN
1172 IF IsReadable(ref, ref + 4) THEN (* desc *)
1173 S.GET(ref, p); INC(ref, 4);
1174 ok := IsReadable(p + 2 * 4, p + 3 * 4) (* desc.id *)
1175 ELSE ok := FALSE
1176 END
1177 END;
1178 Num; Name
1179 END;
1180 RETURN ok
1181 END CheckRefVarReadable;
1183 PROCEDURE GetRefVar* (VAR ref: INTEGER; VAR mode, form: SHORTCHAR; VAR desc: Type;
1184 VAR adr: INTEGER; VAR name: Name);
1185 BEGIN
1186 IF CheckRefVarReadable(ref) THEN
1187 S.GET(ref, mode); desc := NIL;
1188 IF mode >= 0FDX THEN
1189 mode := SHORT(CHR(ORD(mode) - 0FCH));
1190 INC(ref); RefCh(ref, form);
1191 IF form = 10X THEN
1192 S.GET(ref, desc); INC(ref, 4); form := SHORT(CHR(16 + desc.id MOD 4))
1193 END;
1194 RefNum(ref, adr); RefName(ref, name)
1195 ELSE
1196 mode := 0X; form := 0X; adr := 0
1197 END
1198 ELSE
1199 Msg("Kernel.GetRefVar failed!"); Int(ref);
1200 mode := 0X; form := 0X; adr := 0
1201 END
1202 END GetRefVar;
1204 PROCEDURE SourcePos* (mod: Module; codePos: INTEGER): INTEGER;
1205 VAR ref, pos, ad, d: INTEGER; ch: SHORTCHAR; name: Name;
1206 BEGIN
1207 ref := mod.refs; pos := 0; ad := 0; S.GET(ref, ch);
1208 WHILE ch # 0X DO
1209 WHILE (ch > 0X) & (ch < 0FCX) DO
1210 INC(ad, ORD(ch)); INC(ref); RefNum(ref, d);
1211 IF ad > codePos THEN RETURN pos END;
1212 INC(pos, d); S.GET(ref, ch)
1213 END;
1214 IF ch = 0FCX THEN INC(ref); RefNum(ref, d); RefName(ref, name); S.GET(ref, ch) END;
1215 WHILE ch >= 0FDX DO (* skip variables *)
1216 INC(ref); RefCh(ref, ch);
1217 IF ch = 10X THEN INC(ref, 4) END;
1218 RefNum(ref, d); RefName(ref, name); S.GET(ref, ch)
1219 END
1220 END;
1221 RETURN -1
1222 END SourcePos;
1224 (* -------------------- dynamic link libraries --------------------- *)
1226 (*
1227 PROCEDURE DlOpen (name: ARRAY OF SHORTCHAR): Dl.HANDLE;
1228 CONST flags = Dl.RTLD_LAZY + Dl.RTLD_GLOBAL;
1229 VAR h: Dl.HANDLE;
1230 i: INTEGER;
1231 BEGIN
1232 h := Dl.NULL;
1233 i := 0; WHILE (i < LEN(name)) & (name[i] # 0X) DO INC(i) END;
1234 IF i < LEN(name) THEN
1235 h := Dl.dlopen(name, flags);
1236 WHILE (h = Dl.NULL) & (i > 0) DO
1237 DEC(i);
1238 WHILE (i > 0) & (name[i] # '.') DO DEC(i) END;
1239 IF i > 0 THEN
1240 name[i] := 0X;
1241 h := Dl.dlopen(name, flags);
1242 (* IF h # Dl.NULL THEN Msg(name$) END *)
1243 END
1244 END
1245 END;
1246 RETURN h
1247 END DlOpen;
1248 *)
1250 PROCEDURE LoadDll* (IN name: ARRAY OF SHORTCHAR; VAR ok: BOOLEAN);
1251 VAR h: Dl.HANDLE;
1252 BEGIN
1253 ok := FALSE;
1254 h := Dl.dlopen(name, Dl.RTLD_LAZY + Dl.RTLD_GLOBAL);
1255 IF h # Dl.NULL THEN ok := TRUE END
1256 END LoadDll;
1258 PROCEDURE ThisDllObj* (mode, fprint: INTEGER; IN dll, name: ARRAY OF SHORTCHAR): INTEGER;
1259 VAR ad: INTEGER; h: Dl.HANDLE;
1260 BEGIN
1261 ad := 0;
1262 IF mode IN {mVar, mProc} THEN
1263 h := Dl.dlopen(dll, Dl.RTLD_LAZY+ Dl.RTLD_GLOBAL);
1264 IF h # Dl.NULL THEN
1265 ad := Dl.dlsym(h, name);
1266 END
1267 END;
1268 RETURN ad
1269 END ThisDllObj;
1271 (* -------------------- garbage collector (portable) --------------------- *)
1273 PROCEDURE Mark (this: Block);
1274 VAR father, son: Block; tag: Type; flag, offset, actual: INTEGER;
1275 BEGIN
1276 IF ~ODD(S.VAL(INTEGER, this.tag)) THEN
1277 father := NIL;
1278 LOOP
1279 INC(S.VAL(INTEGER, this.tag));
1280 flag := S.VAL(INTEGER, this.tag) MOD 4;
1281 tag := S.VAL(Type, S.VAL(INTEGER, this.tag) - flag);
1282 IF flag >= 2 THEN actual := this.first; this.actual := actual
1283 ELSE actual := S.ADR(this.last)
1284 END;
1285 LOOP
1286 offset := tag.ptroffs[0];
1287 IF offset < 0 THEN
1288 INC(S.VAL(INTEGER, tag), offset + 4); (* restore tag *)
1289 IF (flag >= 2) & (actual < this.last) & (offset < -4) THEN (* next array element *)
1290 INC(actual, tag.size); this.actual := actual
1291 ELSE (* up *)
1292 this.tag := S.VAL(Type, S.VAL(INTEGER, tag) + flag);
1293 IF father = NIL THEN RETURN END;
1294 son := this; this := father;
1295 flag := S.VAL(INTEGER, this.tag) MOD 4;
1296 tag := S.VAL(Type, S.VAL(INTEGER, this.tag) - flag);
1297 offset := tag.ptroffs[0];
1298 IF flag >= 2 THEN actual := this.actual ELSE actual := S.ADR(this.last) END;
1299 S.GET(actual + offset, father); S.PUT(actual + offset, S.ADR(son.last));
1300 INC(S.VAL(INTEGER, tag), 4)
1301 END
1302 ELSE
1303 S.GET(actual + offset, son);
1304 IF son # NIL THEN
1305 DEC(S.VAL(INTEGER, son), 4);
1306 IF ~ODD(S.VAL(INTEGER, son.tag)) THEN (* down *)
1307 this.tag := S.VAL(Type, S.VAL(INTEGER, tag) + flag);
1308 S.PUT(actual + offset, father); father := this; this := son;
1309 EXIT
1310 END
1311 END;
1312 INC(S.VAL(INTEGER, tag), 4)
1313 END
1314 END
1315 END
1316 END
1317 END Mark;
1319 PROCEDURE MarkGlobals;
1320 VAR m: Module; i, p: INTEGER;
1321 BEGIN
1322 m := modList;
1323 WHILE m # NIL DO
1324 IF m.refcnt >= 0 THEN
1325 i := 0;
1326 WHILE i < m.nofptrs DO
1327 S.GET(m.varBase + m.ptrs[i], p); INC(i);
1328 IF p # 0 THEN Mark(S.VAL(Block, p - 4)) END
1329 END
1330 END;
1331 m := m.next
1332 END
1333 END MarkGlobals;
1335 (* This is the specification for the code procedure following below:
1337 PROCEDURE Next (b: Block): Block; (* next block in same cluster *)
1338 VAR size: INTEGER;
1339 BEGIN
1340 S.GET(S.VAL(INTEGER, b.tag) DIV 4 * 4, size);
1341 IF ODD(S.VAL(INTEGER, b.tag) DIV 2) THEN INC(size, b.last - S.ADR(b.last)) END;
1342 RETURN S.VAL(Block, S.VAL(INTEGER, b) + (size + 19) DIV 16 * 16)
1343 END Next;
1345 *)
1346 PROCEDURE [code] Next (b: Block): Block (* next block in same cluster *)
1347 (*
1348 MOV ECX,[EAX] b.tag
1349 AND CL,0FCH b.tag DIV * 4
1350 MOV ECX,[ECX] size
1351 TESTB [EAX],02H ODD(b.tag DIV 2)
1352 JE L1
1353 ADD ECX,[EAX,4] size + b.last
1354 SUB ECX,EAX
1355 SUB ECX,4 size + b.last - ADR(b.last)
1356 L1:
1357 ADD ECX,19 size + 19
1358 AND CL,0F0H (size + 19) DIV 16 * 16
1359 ADD EAX,ECX b + size
1360 *)
1361 08BH, 008H,
1362 080H, 0E1H, 0FCH,
1363 08BH, 009H,
1364 0F6H, 000H, 002H,
1365 074H, 008H,
1366 003H, 048H, 004H,
1367 029H, 0C1H,
1368 083H, 0E9H, 004H,
1369 083H, 0C1H, 013H,
1370 080H, 0E1H, 0F0H,
1371 001H, 0C8H;
1373 PROCEDURE CheckCandidates;
1374 (* pre: nofcand > 0 *)
1375 VAR i, j, h, p, end: INTEGER; c: Cluster; blk, next: Block;
1376 BEGIN
1377 (* sort candidates (shellsort) *)
1378 h := 1; REPEAT h := h*3 + 1 UNTIL h > nofcand;
1379 REPEAT h := h DIV 3; i := h;
1380 WHILE i < nofcand DO p := candidates[i]; j := i;
1381 WHILE (j >= h) & (candidates[j-h] > p) DO
1382 candidates[j] := candidates[j-h]; j := j-h
1383 END;
1384 candidates[j] := p; INC(i)
1385 END
1386 UNTIL h = 1;
1387 (* sweep *)
1388 c := root; i := 0;
1389 WHILE c # NIL DO
1390 blk := S.VAL(Block, S.VAL(INTEGER, c) + 12);
1391 end := S.VAL(INTEGER, blk) + (c.size - 12) DIV 16 * 16;
1392 WHILE candidates[i] < S.VAL(INTEGER, blk) DO
1393 INC(i);
1394 IF i = nofcand THEN RETURN END
1395 END;
1396 WHILE S.VAL(INTEGER, blk) < end DO
1397 next := Next(blk);
1398 IF candidates[i] < S.VAL(INTEGER, next) THEN
1399 IF (S.VAL(INTEGER, blk.tag) # S.ADR(blk.last)) (* not a free block *)
1400 & (~strictStackSweep OR (candidates[i] = S.ADR(blk.last))) THEN
1401 Mark(blk)
1402 END;
1403 REPEAT
1404 INC(i);
1405 IF i = nofcand THEN RETURN END
1406 UNTIL candidates[i] >= S.VAL(INTEGER, next)
1407 END;
1408 IF (S.VAL(INTEGER, blk.tag) MOD 4 = 0) & (S.VAL(INTEGER, blk.tag) # S.ADR(blk.last))
1409 & (blk.tag.base[0] = NIL) & (blk.actual > 0) THEN (* referenced interface record *)
1410 Mark(blk)
1411 END;
1412 blk := next
1413 END;
1414 c := c.next
1415 END
1416 END CheckCandidates;
1418 PROCEDURE MarkLocals;
1419 VAR sp, p, min, max: INTEGER; c: Cluster;
1420 BEGIN
1421 S.GETREG(FP, sp); nofcand := 0; c := root;
1422 WHILE c.next # NIL DO c := c.next END;
1423 min := S.VAL(INTEGER, root); max := S.VAL(INTEGER, c) + c.size;
1424 WHILE sp < baseStack DO
1425 S.GET(sp, p);
1426 IF (p > min) & (p < max) & (~strictStackSweep OR (p MOD 16 = 0)) THEN
1427 candidates[nofcand] := p; INC(nofcand);
1428 IF nofcand = LEN(candidates) - 1 THEN CheckCandidates; nofcand := 0 END
1429 END;
1430 INC(sp, 4)
1431 END;
1432 candidates[nofcand] := max; INC(nofcand); (* ensure complete scan for interface mark*)
1433 IF nofcand > 0 THEN CheckCandidates END
1434 END MarkLocals;
1436 PROCEDURE MarkFinObj;
1437 VAR f: FList;
1438 BEGIN
1439 wouldFinalize := FALSE;
1440 f := finalizers;
1441 WHILE f # NIL DO
1442 IF ~ODD(S.VAL(INTEGER, f.blk.tag)) THEN wouldFinalize := TRUE END;
1443 Mark(f.blk);
1444 f := f.next
1445 END;
1446 f := hotFinalizers;
1447 WHILE f # NIL DO IF ~ODD(S.VAL(INTEGER, f.blk.tag)) THEN wouldFinalize := TRUE END;
1448 Mark(f.blk);
1449 f := f.next
1450 END
1451 END MarkFinObj;
1453 PROCEDURE CheckFinalizers;
1454 VAR f, g, h, k: FList;
1455 BEGIN
1456 f := finalizers; g := NIL;
1457 IF hotFinalizers = NIL THEN k := NIL
1458 ELSE
1459 k := hotFinalizers;
1460 WHILE k.next # NIL DO k := k.next END
1461 END;
1462 WHILE f # NIL DO
1463 h := f; f := f.next;
1464 IF ~ODD(S.VAL(INTEGER, h.blk.tag)) THEN
1465 IF g = NIL THEN finalizers := f ELSE g.next := f END;
1466 IF k = NIL THEN hotFinalizers := h ELSE k.next := h END;
1467 k := h; h.next := NIL
1468 ELSE g := h
1469 END
1470 END;
1471 h := hotFinalizers;
1472 WHILE h # NIL DO Mark(h.blk); h := h.next END
1473 END CheckFinalizers;
1475 PROCEDURE ExecFinalizer (a, b, c: INTEGER);
1476 VAR f: FList; fin: PROCEDURE(this: ANYPTR);
1477 BEGIN
1478 f := S.VAL(FList, a);
1479 IF f.aiptr THEN (* ArrFinalizer(S.VAL(ANYPTR, S.ADR(f.blk.last))) *)
1480 ELSE
1481 S.GET(S.VAL(INTEGER, f.blk.tag) - 4, fin); (* method 0 *)
1482 IF (fin # NIL) & (f.blk.tag.mod.refcnt >= 0) THEN fin(S.VAL(ANYPTR, S.ADR(f.blk.last))) END;
1483 (*
1484 IF f.iptr THEN RecFinalizer(S.VAL(ANYPTR, S.ADR(f.blk.last))) END
1485 *)
1486 END
1487 END ExecFinalizer;
1489 PROCEDURE^ Try* (h: TryHandler; a, b, c: INTEGER); (* COMPILER DEPENDENT *)
1491 PROCEDURE CallFinalizers;
1492 VAR f: FList;
1493 BEGIN
1494 WHILE hotFinalizers # NIL DO
1495 f := hotFinalizers; hotFinalizers := hotFinalizers.next;
1496 Try(ExecFinalizer, S.VAL(INTEGER, f), 0, 0)
1497 END;
1498 wouldFinalize := FALSE
1499 END CallFinalizers;
1501 PROCEDURE Insert (blk: FreeBlock; size: INTEGER); (* insert block in free list *)
1502 VAR i: INTEGER;
1503 BEGIN
1504 blk.size := size - 4; blk.tag := S.VAL(Type, S.ADR(blk.size));
1505 i := MIN(N - 1, (blk.size DIV 16));
1506 blk.next := free[i]; free[i] := blk
1507 END Insert;
1509 PROCEDURE Sweep (dealloc: BOOLEAN);
1510 VAR cluster, last, c: Cluster; blk, next: Block; fblk, b, t: FreeBlock; end, i: INTEGER;
1511 BEGIN
1512 cluster := root; last := NIL; allocated := 0;
1513 i := N;
1514 REPEAT DEC(i); free[i] := sentinel UNTIL i = 0;
1515 WHILE cluster # NIL DO
1516 blk := S.VAL(Block, S.VAL(INTEGER, cluster) + 12);
1517 end := S.VAL(INTEGER, blk) + (cluster.size - 12) DIV 16 * 16;
1518 fblk := NIL;
1519 WHILE S.VAL(INTEGER, blk) < end DO
1520 next := Next(blk);
1521 IF ODD(S.VAL(INTEGER, blk.tag)) THEN
1522 IF fblk # NIL THEN
1523 Insert(fblk, S.VAL(INTEGER, blk) - S.VAL(INTEGER, fblk));
1524 fblk := NIL
1525 END;
1526 DEC(S.VAL(INTEGER, blk.tag)); (* unmark *)
1527 INC(allocated, S.VAL(INTEGER, next) - S.VAL(INTEGER, blk))
1528 ELSIF fblk = NIL THEN
1529 fblk := S.VAL(FreeBlock, blk)
1530 END;
1531 blk := next
1532 END;
1533 IF dealloc & (S.VAL(INTEGER, fblk) = S.VAL(INTEGER, cluster) + 12) THEN (* deallocate cluster *)
1534 c := cluster; cluster := cluster.next;
1535 IF last = NIL THEN root := cluster ELSE last.next := cluster END;
1536 FreeHeapMem(c)
1537 ELSE
1538 IF fblk # NIL THEN Insert(fblk, end - S.VAL(INTEGER, fblk)) END;
1539 last := cluster; cluster := cluster.next
1540 END
1541 END;
1542 (* reverse free list *)
1543 i := N;
1544 REPEAT
1545 DEC(i);
1546 b := free[i]; fblk := sentinel;
1547 WHILE b # sentinel DO t := b; b := t.next; t.next := fblk; fblk := t END;
1548 free[i] := fblk
1549 UNTIL i = 0
1550 END Sweep;
1552 PROCEDURE Collect*;
1553 BEGIN
1554 IF root # NIL THEN
1555 CallFinalizers; (* trap cleanup *)
1556 IF debug & (watcher # NIL) THEN watcher(1) END;
1557 MarkGlobals;
1558 MarkLocals;
1559 CheckFinalizers;
1560 Sweep(TRUE);
1561 CallFinalizers
1562 END
1563 END Collect;
1565 PROCEDURE FastCollect*;
1566 BEGIN
1567 IF root # NIL THEN
1568 IF debug & (watcher # NIL) THEN watcher(2) END;
1569 MarkGlobals;
1570 MarkLocals;
1571 MarkFinObj;
1572 Sweep(FALSE)
1573 END
1574 END FastCollect;
1576 PROCEDURE WouldFinalize* (): BOOLEAN;
1577 BEGIN
1578 RETURN wouldFinalize
1579 END WouldFinalize;
1581 (* --------------------- memory allocation (portable) -------------------- *)
1583 PROCEDURE OldBlock (size: INTEGER): FreeBlock; (* size MOD 16 = 0 *)
1584 VAR b, l: FreeBlock; s, i: INTEGER;
1585 BEGIN
1586 IF debug & (watcher # NIL) THEN watcher(3) END;
1587 s := size - 4;
1588 i := MIN(N - 1, s DIV 16);
1589 WHILE (i # N - 1) & (free[i] = sentinel) DO INC(i) END;
1590 b := free[i]; l := NIL;
1591 WHILE b.size < s DO l := b; b := b.next END;
1592 IF b # sentinel THEN
1593 IF l = NIL THEN free[i] := b.next ELSE l.next := b.next END
1594 ELSE b := NIL
1595 END;
1596 RETURN b
1597 END OldBlock;
1599 PROCEDURE LastBlock (limit: INTEGER): FreeBlock; (* size MOD 16 = 0 *)
1600 VAR b, l: FreeBlock; s, i: INTEGER;
1601 BEGIN
1602 s := limit - 4;
1603 i := 0;
1604 REPEAT
1605 b := free[i]; l := NIL;
1606 WHILE (b # sentinel) & (S.VAL(INTEGER, b) + b.size # s) DO l := b; b := b.next END;
1607 IF b # sentinel THEN
1608 IF l = NIL THEN free[i] := b.next ELSE l.next := b.next END
1609 ELSE b := NIL
1610 END;
1611 INC(i)
1612 UNTIL (b # NIL) OR (i = N);
1613 RETURN b
1614 END LastBlock;
1616 PROCEDURE NewBlock (size: INTEGER): Block;
1617 VAR tsize, a, s: INTEGER; b: FreeBlock; new, c: Cluster; r: Reducer;
1618 BEGIN
1619 ASSERT(size>=0,20);
1620 IF size >7FFFFFECH THEN RETURN NIL END; (*20120822 Marc*)
1621 tsize := (size + 19) DIV 16 * 16;
1622 b := OldBlock(tsize); (* 1) search for free block *)
1623 IF b = NIL THEN
1624 FastCollect; b := OldBlock(tsize); (* 2) collect *)
1625 IF b = NIL THEN
1626 Collect; b := OldBlock(tsize); (* 2a) fully collect *)
1627 END;
1628 IF b = NIL THEN
1629 AllocHeapMem(tsize + 12, new); (* 3) allocate new cluster *)
1630 IF new # NIL THEN
1631 IF (root = NIL) OR (S.VAL(INTEGER, new) < S.VAL(INTEGER, root)) THEN
1632 new.next := root; root := new
1633 ELSE
1634 c := root;
1635 WHILE (c.next # NIL) & (S.VAL(INTEGER, new) > S.VAL(INTEGER, c.next)) DO c := c.next END;
1636 new.next := c.next; c.next := new
1637 END;
1638 b := S.VAL(FreeBlock, S.VAL(INTEGER, new) + 12);
1639 b.size := (new.size - 12) DIV 16 * 16 - 4
1640 ELSE
1641 RETURN NIL (* 4) give up *)
1642 END
1643 END
1644 END;
1645 (* b # NIL *)
1646 a := b.size + 4 - tsize;
1647 IF a > 0 THEN Insert(S.VAL(FreeBlock, S.VAL(INTEGER, b) + tsize), a) END;
1648 IF size > 0 THEN Erase(S.ADR(b.size), (size + 3) DIV 4) END;
1649 INC(allocated, tsize);
1650 RETURN S.VAL(Block, b)
1651 END NewBlock;
1653 PROCEDURE Allocated* (): INTEGER;
1654 BEGIN
1655 RETURN allocated
1656 END Allocated;
1658 PROCEDURE Used* (): INTEGER;
1659 BEGIN
1660 RETURN used
1661 END Used;
1663 PROCEDURE Root* (): INTEGER;
1664 BEGIN
1665 RETURN S.VAL(INTEGER, root)
1666 END Root;
1669 (* -------------------- Trap Handling --------------------- *)
1671 PROCEDURE^ InitFpu;
1673 PROCEDURE Start* (code: Command);
1674 BEGIN
1675 restart := code;
1676 (*
1677 S.GETREG(SP, baseStack); (* save base stack *)
1678 *)
1679 res := Libc.sigsetjmp(loopContext, Libc.TRUE);
1680 code()
1681 END Start;
1683 PROCEDURE Quit* (exitCode: INTEGER);
1684 VAR m: Module; term: Command; t: BOOLEAN;
1685 res: INTEGER;
1686 BEGIN
1687 trapViewer := NIL; trapChecker := NIL; restart := NIL;
1688 t := terminating; terminating := TRUE; m := modList;
1689 WHILE m # NIL DO (* call terminators *)
1690 IF ~static OR ~t THEN
1691 term := m.term; m.term := NIL;
1692 IF term # NIL THEN term() END
1693 END;
1694 (*
1695 ReleaseIPtrs(m);
1696 *)
1697 m := m.next
1698 END;
1699 CallFinalizers;
1700 hotFinalizers := finalizers; finalizers := NIL;
1701 CallFinalizers;
1702 (*
1703 IF ~inDll THEN
1704 RemoveExcp(excpPtr^);
1705 WinApi.ExitProcess(exitCode) (* never returns *)
1706 END
1707 *)
1709 res := Libc.fflush(0);
1710 Libc.exit(exitCode)
1711 END Quit;
1713 PROCEDURE FatalError* (id: INTEGER; str: ARRAY OF CHAR);
1714 VAR res: INTEGER; title: ARRAY 16 OF CHAR; text: ARRAY 256 OF SHORTCHAR;
1715 BEGIN
1716 title := "Error xy";
1717 title[6] := CHR(id DIV 10 + ORD("0"));
1718 title[7] := CHR(id MOD 10 + ORD("0"));
1719 (*
1720 res := WinApi.MessageBoxW(0, str, title, {});
1721 *)
1722 text := SHORT(str$);
1723 res := MessageBox(title$, SHORT(str), {mbOk});
1724 (*
1725 IF ~inDll THEN RemoveExcp(excpPtr^) END;
1726 *)
1727 (*
1728 WinApi.ExitProcess(1)
1729 *)
1730 Libc.exit(1)
1731 (* never returns *)
1732 END FatalError;
1734 PROCEDURE DefaultTrapViewer;
1735 VAR len, ref, end, x, a, b, c: INTEGER; mod: Module;
1736 name: Name; out: ARRAY 1024 OF SHORTCHAR;
1738 PROCEDURE WriteString (s: ARRAY OF SHORTCHAR);
1739 VAR i: INTEGER;
1740 BEGIN
1741 i := 0;
1742 WHILE (len < LEN(out) - 1) & (s[i] # 0X) DO out[len] := s[i]; INC(i); INC(len) END
1743 END WriteString;
1745 PROCEDURE WriteHex (x, n: INTEGER);
1746 VAR i, y: INTEGER;
1747 BEGIN
1748 IF len + n < LEN(out) THEN
1749 i := len + n - 1;
1750 WHILE i >= len DO
1751 y := x MOD 16; x := x DIV 16;
1752 IF y > 9 THEN y := y + (ORD("A") - ORD("0") - 10) END;
1753 out[i] := SHORT(CHR(y + ORD("0"))); DEC(i)
1754 END;
1755 INC(len, n)
1756 END
1757 END WriteHex;
1759 PROCEDURE WriteLn;
1760 BEGIN
1761 IF len < LEN(out) - 1 THEN out[len] := 0AX (* 0DX on Windows *); INC(len) END
1762 END WriteLn;
1764 BEGIN
1765 len := 0;
1766 IF err = 129 THEN WriteString("invalid with")
1767 ELSIF err = 130 THEN WriteString("invalid case")
1768 ELSIF err = 131 THEN WriteString("function without return")
1769 ELSIF err = 132 THEN WriteString("type guard")
1770 ELSIF err = 133 THEN WriteString("implied type guard")
1771 ELSIF err = 134 THEN WriteString("value out of range")
1772 ELSIF err = 135 THEN WriteString("index out of range")
1773 ELSIF err = 136 THEN WriteString("string too long")
1774 ELSIF err = 137 THEN WriteString("stack overflow")
1775 ELSIF err = 138 THEN WriteString("integer overflow")
1776 ELSIF err = 139 THEN WriteString("division by zero")
1777 ELSIF err = 140 THEN WriteString("infinite real result")
1778 ELSIF err = 141 THEN WriteString("real underflow")
1779 ELSIF err = 142 THEN WriteString("real overflow")
1780 ELSIF err = 143 THEN WriteString("undefined real result")
1781 ELSIF err = 200 THEN WriteString("keyboard interrupt")
1782 ELSIF err = 202 THEN WriteString("illegal instruction: ");
1783 WriteHex(val, 4)
1784 ELSIF err = 203 THEN WriteString("illegal memory read [ad = ");
1785 WriteHex(val, 8); WriteString("]")
1786 ELSIF err = 204 THEN WriteString("illegal memory write [ad = ");
1787 WriteHex(val, 8); WriteString("]")
1788 ELSIF err = 205 THEN WriteString("illegal execution [ad = ");
1789 WriteHex(val, 8); WriteString("]")
1790 ELSIF err < 0 THEN WriteString("exception #"); WriteHex(-err, 2)
1791 ELSE err := err DIV 100 * 256 + err DIV 10 MOD 10 * 16 + err MOD 10;
1792 WriteString("trap #"); WriteHex(err, 3)
1793 END;
1794 a := pc; b := fp; c := 12;
1795 REPEAT
1796 WriteLn; WriteString("- ");
1797 mod := modList;
1798 WHILE (mod # NIL) & ((a < mod.code) OR (a >= mod.code + mod.csize)) DO mod := mod.next END;
1799 IF mod # NIL THEN
1800 DEC(a, mod.code);
1801 IF mod.refcnt >= 0 THEN
1802 WriteString(mod.name); ref := mod.refs;
1803 REPEAT GetRefProc(ref, end, name) UNTIL (end = 0) OR (a < end);
1804 IF a < end THEN
1805 WriteString("."); WriteString(name)
1806 END
1807 ELSE
1808 WriteString("("); WriteString(mod.name); WriteString(")")
1809 END;
1810 WriteString(" ")
1811 END;
1812 WriteString("(pc="); WriteHex(a, 8);
1813 WriteString(", fp="); WriteHex(b, 8); WriteString(")");
1814 IF (b >= sp) & (b < stack) THEN
1815 S.GET(b+4, a); (* stacked pc *)
1816 S.GET(b, b); (* dynamic link *)
1817 DEC(c)
1818 ELSE c := 0
1819 END
1820 UNTIL c = 0;
1821 out[len] := 0X;
1822 x := MessageBox("BlackBox", out$, {mbOk})
1823 END DefaultTrapViewer;
1825 PROCEDURE TrapCleanup;
1826 VAR t: TrapCleaner;
1827 BEGIN
1828 WHILE trapStack # NIL DO
1829 t := trapStack; trapStack := trapStack.next; t.Cleanup
1830 END;
1831 IF (trapChecker # NIL) & (err # 128) THEN trapChecker END
1832 END TrapCleanup;
1834 PROCEDURE SetTrapGuard* (on: BOOLEAN);
1835 BEGIN
1836 guarded := on
1837 END SetTrapGuard;
1839 PROCEDURE Try* (h: TryHandler; a, b, c: INTEGER);
1840 VAR res: INTEGER; context: Libc.sigjmp_buf; oldContext: POINTER TO Libc.sigjmp_buf;
1841 BEGIN
1842 oldContext := currentTryContext;
1843 res := Libc.sigsetjmp(context, Libc.TRUE);
1844 currentTryContext := S.ADR(context);
1845 IF res = 0 THEN (* first time around *)
1846 h(a, b, c);
1847 ELSIF res = trapReturn THEN (* after a trap *)
1848 ELSE
1849 HALT(100)
1850 END;
1851 currentTryContext := oldContext;
1852 END Try;
1854 (* -------------------- Initialization --------------------- *)
1856 PROCEDURE InitFpu; (* COMPILER DEPENDENT *)
1857 (* could be eliminated, delayed for backward compatibility *)
1858 VAR cw: SET;
1859 BEGIN
1860 FINIT;
1861 FSTCW;
1862 (* denorm, underflow, precision, zero div, overflow masked *)
1863 (* invalid trapped *)
1864 (* round to nearest, temp precision *)
1865 cw := cw - {0..5, 8..11} + {1, 2, 3, 4, 5, 8, 9};
1866 FLDCW
1867 END InitFpu;
1869 (* A. V. Shiryaev: Show extended trap information (OpenBSD) *)
1870 PROCEDURE ShowTrap (sig: INTEGER; siginfo: Libc.Ptrsiginfo_t; context: Libc.Ptrucontext_t);
1872 PROCEDURE WriteChar (c: SHORTCHAR);
1873 VAR s: ARRAY [untagged] 2 OF SHORTCHAR;
1874 BEGIN
1875 s[0] := c; s[1] := 0X;
1876 res := Libc.printf(s)
1877 END WriteChar;
1879 PROCEDURE WriteString (s: ARRAY OF SHORTCHAR);
1880 VAR res: INTEGER;
1881 BEGIN
1882 res := Libc.printf(s)
1883 END WriteString;
1885 PROCEDURE WriteHex (x, n: INTEGER);
1886 VAR i, y: INTEGER;
1887 s: ARRAY 9 OF SHORTCHAR;
1888 BEGIN
1889 s[n] := 0X;
1890 i := 0 + n - 1;
1891 WriteChar("$");
1892 WHILE i >= 0 DO
1893 y := x MOD 16; x := x DIV 16;
1894 IF y > 9 THEN y := y + (ORD("A") - ORD("0") - 10) END;
1895 s[i] := SHORT(CHR(y + ORD("0")));
1896 DEC(i)
1897 END;
1898 WriteString(s)
1899 END WriteHex;
1901 PROCEDURE WriteLn;
1902 BEGIN
1903 WriteChar(0AX)
1904 END WriteLn;
1906 PROCEDURE KV (name: ARRAY OF SHORTCHAR; x: INTEGER);
1907 BEGIN
1908 WriteString(name); WriteString(" = "); WriteHex(x, 8)
1909 END KV;
1911 BEGIN
1912 WriteString("================================"); WriteLn;
1913 WriteString("TRAP:"); WriteLn;
1914 WriteString("--------------------------------"); WriteLn;
1916 KV("sig", sig); WriteString(", ");
1917 KV("baseStack", baseStack); WriteLn;
1919 KV("GS ", context.sc_gs); WriteString(", ");
1920 KV("FS ", context.sc_fs); WriteString(", ");
1921 KV("ES ", context.sc_es); WriteString(", ");
1922 KV("DS ", context.sc_ds); WriteLn;
1924 KV("EDI", context.sc_edi); WriteString(", ");
1925 KV("ESI", context.sc_esi); WriteString(", ");
1926 KV("EBP", context.sc_ebp); WriteString(", ");
1927 KV("EBX", context.sc_ebx); WriteLn;
1929 KV("EDX", context.sc_edx); WriteString(", ");
1930 KV("ECX", context.sc_ecx); WriteString(", ");
1931 KV("EAX", context.sc_eax); WriteString(", ");
1932 KV("EIP", context.sc_eip); WriteLn;
1934 KV("CS", context.sc_cs); WriteString(", ");
1935 KV("EFLAGS", context.sc_eflags); WriteString(", ");
1936 KV("ESP", context.sc_esp); WriteString(", ");
1937 KV("SS", context.sc_ss); WriteLn;
1939 KV("ONSTACK", context.sc_onstack); WriteString(", ");
1940 KV("MASK", context.sc_mask); WriteString(", ");
1941 KV("TRAPNO", context.sc_trapno); WriteString(", ");
1942 KV("ERR", context.sc_err); WriteLn;
1944 WriteString("---- siginfo: ------------------"); WriteLn;
1946 KV("signo", siginfo.si_signo); WriteString(", ");
1947 KV("code", siginfo.si_code); WriteString(", ");
1948 KV("errno", siginfo.si_errno); WriteLn;
1949 KV("fault.addr", siginfo._data._fault._addr); WriteString(", ");
1950 KV("fault.trapno", siginfo._data._fault._trapno); WriteLn;
1952 WriteString("================================"); WriteLn
1953 END ShowTrap;
1955 PROCEDURE [ccall] TrapHandler (sig: INTEGER; siginfo: Libc.Ptrsiginfo_t; context: Libc.Ptrucontext_t);
1956 BEGIN
1957 IF isReadableCheck THEN
1958 isReadableCheck := FALSE;
1959 Msg("~IsReadable");
1960 Libc.siglongjmp(isReadableContext, 1)
1961 END;
1963 (*
1964 S.GETREG(SP, sp);
1965 S.GETREG(FP, fp);
1966 *)
1967 stack := baseStack;
1969 (* A. V. Shiryaev *)
1970 (*
1971 sp := context.uc_mcontext.gregs[7]; (* TODO: is the stack pointer really stored in register 7? *)
1972 fp := context.uc_mcontext.gregs[6]; (* TODO: is the frame pointer really stored in register 6? *)
1973 pc := context.uc_mcontext.gregs[14]; (* TODO: is the pc really stored in register 14? *)
1974 *)
1975 (* val := siginfo.si_addr; *)
1976 (* OpenBSD *)
1977 ShowTrap(sig, siginfo, context);
1978 sp := context.sc_esp; fp := context.sc_ebp; pc := context.sc_eip;
1979 val := siginfo._data._fault._addr;
1981 (*
1982 Int(sig); Int(siginfo.si_signo); Int(siginfo.si_code); Int(siginfo.si_errno);
1983 Int(siginfo.si_status); Int(siginfo.si_value); Int(siginfo.si_int);
1984 *)
1985 err := sig;
1986 IF trapped THEN DefaultTrapViewer END;
1987 CASE sig OF
1988 Libc.SIGINT:
1989 err := 200 (* Interrupt (ANSI). *)
1990 | Libc.SIGILL: (* Illegal instruction (ANSI). *)
1991 err := 202; val := 0;
1992 IF IsReadable(pc, pc + 4) THEN
1993 S.GET(pc, val);
1994 IF val MOD 100H = 8DH THEN (* lea reg,reg *)
1995 IF val DIV 100H MOD 100H = 0F0H THEN
1996 err := val DIV 10000H MOD 100H (* trap *)
1997 ELSIF val DIV 1000H MOD 10H = 0EH THEN
1998 err := 128 + val DIV 100H MOD 10H (* run time error *)
1999 END
2000 END
2001 END
2002 | Libc.SIGFPE:
2003 CASE siginfo.si_code OF
2004 0: (* TODO: ?????? *)
2005 (* A. V. Shiryaev: OpenBSD *)
2006 (*
2007 IF siginfo.si_int = 8 THEN
2008 err := 139
2009 ELSIF siginfo.si_int = 0 THEN
2010 err := 143
2011 END
2012 *)
2013 err := 143;
2014 | Libc.FPE_INTDIV: err := 139 (* Integer divide by zero. *)
2015 | Libc.FPE_INTOVF: err := 138 (* Integer overflow. *)
2016 | Libc.FPE_FLTDIV: err := 140 (* Floating point divide by zero. *)
2017 | Libc.FPE_FLTOVF: err := 142 (* Floating point overflow. *)
2018 | Libc.FPE_FLTUND: err := 141 (* Floating point underflow. *)
2019 | Libc.FPE_FLTRES: err := 143 (* Floating point inexact result. *)
2020 | Libc.FPE_FLTINV: err := 143 (* Floating point invalid operation. *)
2021 | Libc.FPE_FLTSUB: err := 134 (* Subscript out of range. *)
2022 ELSE
2023 END
2024 | Libc.SIGSEGV: (* Segmentation violation (ANSI). *)
2025 err := 203
2026 ELSE
2027 END;
2028 INC(trapCount);
2029 InitFpu;
2030 TrapCleanup;
2031 IF err # 128 THEN
2032 IF (trapViewer = NIL) OR trapped THEN
2033 DefaultTrapViewer
2034 ELSE
2035 trapped := TRUE;
2037 trapViewer();
2039 trapped := FALSE
2040 END
2041 END;
2042 IF currentTryContext # NIL THEN (* Try failed *)
2043 Libc.siglongjmp(currentTryContext, trapReturn)
2044 ELSE
2045 IF restart # NIL THEN (* Start failed *)
2046 Libc.siglongjmp(loopContext, trapReturn)
2047 END;
2048 Quit(1); (* FIXME *)
2049 END;
2050 trapped := FALSE
2051 END TrapHandler;
2053 PROCEDURE InstallSignals*;
2054 VAR sa, old: Libc.sigaction_t; res, i: INTEGER;
2055 (*
2056 sigstk: Libc.sigaltstack_t;
2057 errno: INTEGER;
2058 *)
2059 BEGIN
2060 (*
2061 (* A. V. Shiryaev: Set alternative stack on which signals are to be processed *)
2062 sigstk.ss_sp := sigStack;
2063 sigstk.ss_size := sigStackSize;
2064 sigstk.ss_flags := 0;
2065 res := Libc.sigaltstack(sigstk, NIL);
2066 IF res # 0 THEN Msg("ERROR: Kernel.InstallSignals: sigaltstack failed!");
2067 S.GET( Libc.__errno_location(), errno );
2068 Int(errno);
2069 Libc.exit(1)
2070 END;
2071 *)
2073 sa.sa_sigaction := TrapHandler;
2074 (*
2075 res := LinLibc.sigemptyset(S.ADR(sa.sa_mask));
2076 *)
2077 res := Libc.sigfillset(S.ADR(sa.sa_mask));
2078 sa.sa_flags := (* Libc.SA_ONSTACK + *) Libc.SA_SIGINFO; (* TrapHandler takes three arguments *)
2079 (*
2080 IF LinLibc.sigaction(LinLibc.SIGINT, sa, old) # 0 THEN Msg("failed to install SIGINT") END;
2081 IF LinLibc.sigaction(LinLibc.SIGILL, sa, old) # 0 THEN Msg("failed to install SIGILL") END;
2082 IF LinLibc.sigaction(LinLibc.SIGFPE, sa, old) # 0 THEN Msg("failed to install SIGFPE") END;
2083 IF LinLibc.sigaction(LinLibc.SIGSEGV, sa, old) # 0 THEN Msg("failed to install SIGSEGV") END;
2084 IF LinLibc.sigaction(LinLibc.SIGPIPE, sa, old) # 0 THEN Msg("failed to install SIGPIPE") END;
2085 IF LinLibc.sigaction(LinLibc.SIGTERM, sa, old) # 0 THEN Msg("failed to install SIGTERM") END;
2086 *)
2087 (* respond to all possible signals *)
2088 FOR i := 1 TO Libc._NSIG - 1 DO
2089 IF (i # Libc.SIGKILL)
2090 & (i # Libc.SIGSTOP)
2091 & (i # Libc.SIGWINCH)
2092 & (i # Libc.SIGTHR) (* A. V. Shiryaev: OpenBSD -pthread *)
2093 THEN
2094 IF Libc.sigaction(i, sa, old) # 0 THEN Msg("failed to install signal"); Int(i) END;
2095 END
2096 END
2097 END InstallSignals;
2099 PROCEDURE Init;
2100 VAR i: INTEGER;
2101 BEGIN
2102 (*
2103 (* for sigaltstack *)
2104 sigStack := Libc.calloc(1, sigStackSize);
2105 IF sigStack = Libc.NULL THEN
2106 Msg("ERROR: Kernel.Init: calloc(1, sigStackSize) failed!");
2107 Libc.exit(1)
2108 END;
2109 *)
2111 isReadableCheck := FALSE;
2113 InstallSignals; (* init exception handling *)
2114 currentTryContext := NIL;
2116 allocated := 0; total := 0; used := 0;
2117 sentinelBlock.size := MAX(INTEGER);
2118 sentinel := S.ADR(sentinelBlock);
2120 (*
2121 S.PUTREG(ML, S.ADR(modList));
2122 *)
2124 i := N;
2125 REPEAT DEC(i); free[i] := sentinel UNTIL i = 0;
2127 IF inDll THEN
2128 (*
2129 baseStack := FPageWord(4); (* begin of stack segment *)
2130 *)
2131 END;
2132 InitFpu;
2133 IF ~static THEN
2134 InitModule(modList);
2135 IF ~inDll THEN Quit(1) END
2136 END;
2137 told := 0; shift := 0
2138 END Init;
2140 BEGIN
2141 IF modList = NIL THEN (* only once *)
2142 S.GETREG(SP, baseStack); (* TODO: Check that this is ok. *)
2143 IF bootInfo # NIL THEN
2144 modList := bootInfo.modList (* boot loader initializes the bootInfo struct *)
2145 ELSE
2146 S.GETREG(ML, modList) (* linker loads module list to BX *)
2147 END;
2148 static := init IN modList.opts;
2149 inDll := dll IN modList.opts;
2150 Init
2151 END
2152 CLOSE
2153 IF ~terminating THEN
2154 terminating := TRUE;
2155 Quit(0)
2156 END
2157 END Kernel.