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 S.GETREG(SP, baseStack); (* save base stack *)
1677 res := Libc.sigsetjmp(loopContext, Libc.TRUE);
1678 code()
1679 END Start;
1681 PROCEDURE Quit* (exitCode: INTEGER);
1682 VAR m: Module; term: Command; t: BOOLEAN;
1683 res: INTEGER;
1684 BEGIN
1685 trapViewer := NIL; trapChecker := NIL; restart := NIL;
1686 t := terminating; terminating := TRUE; m := modList;
1687 WHILE m # NIL DO (* call terminators *)
1688 IF ~static OR ~t THEN
1689 term := m.term; m.term := NIL;
1690 IF term # NIL THEN term() END
1691 END;
1692 (*
1693 ReleaseIPtrs(m);
1694 *)
1695 m := m.next
1696 END;
1697 CallFinalizers;
1698 hotFinalizers := finalizers; finalizers := NIL;
1699 CallFinalizers;
1700 (*
1701 IF ~inDll THEN
1702 RemoveExcp(excpPtr^);
1703 WinApi.ExitProcess(exitCode) (* never returns *)
1704 END
1705 *)
1707 res := Libc.fflush(0);
1708 Libc.exit(exitCode)
1709 END Quit;
1711 PROCEDURE FatalError* (id: INTEGER; str: ARRAY OF CHAR);
1712 VAR res: INTEGER; title: ARRAY 16 OF CHAR; text: ARRAY 256 OF SHORTCHAR;
1713 BEGIN
1714 title := "Error xy";
1715 title[6] := CHR(id DIV 10 + ORD("0"));
1716 title[7] := CHR(id MOD 10 + ORD("0"));
1717 (*
1718 res := WinApi.MessageBoxW(0, str, title, {});
1719 *)
1720 text := SHORT(str$);
1721 res := MessageBox(title$, SHORT(str), {mbOk});
1722 (*
1723 IF ~inDll THEN RemoveExcp(excpPtr^) END;
1724 *)
1725 (*
1726 WinApi.ExitProcess(1)
1727 *)
1728 Libc.exit(1)
1729 (* never returns *)
1730 END FatalError;
1732 PROCEDURE DefaultTrapViewer;
1733 VAR len, ref, end, x, a, b, c: INTEGER; mod: Module;
1734 name: Name; out: ARRAY 1024 OF SHORTCHAR;
1736 PROCEDURE WriteString (s: ARRAY OF SHORTCHAR);
1737 VAR i: INTEGER;
1738 BEGIN
1739 i := 0;
1740 WHILE (len < LEN(out) - 1) & (s[i] # 0X) DO out[len] := s[i]; INC(i); INC(len) END
1741 END WriteString;
1743 PROCEDURE WriteHex (x, n: INTEGER);
1744 VAR i, y: INTEGER;
1745 BEGIN
1746 IF len + n < LEN(out) THEN
1747 i := len + n - 1;
1748 WHILE i >= len DO
1749 y := x MOD 16; x := x DIV 16;
1750 IF y > 9 THEN y := y + (ORD("A") - ORD("0") - 10) END;
1751 out[i] := SHORT(CHR(y + ORD("0"))); DEC(i)
1752 END;
1753 INC(len, n)
1754 END
1755 END WriteHex;
1757 PROCEDURE WriteLn;
1758 BEGIN
1759 IF len < LEN(out) - 1 THEN out[len] := 0AX (* 0DX on Windows *); INC(len) END
1760 END WriteLn;
1762 BEGIN
1763 len := 0;
1764 IF err = 129 THEN WriteString("invalid with")
1765 ELSIF err = 130 THEN WriteString("invalid case")
1766 ELSIF err = 131 THEN WriteString("function without return")
1767 ELSIF err = 132 THEN WriteString("type guard")
1768 ELSIF err = 133 THEN WriteString("implied type guard")
1769 ELSIF err = 134 THEN WriteString("value out of range")
1770 ELSIF err = 135 THEN WriteString("index out of range")
1771 ELSIF err = 136 THEN WriteString("string too long")
1772 ELSIF err = 137 THEN WriteString("stack overflow")
1773 ELSIF err = 138 THEN WriteString("integer overflow")
1774 ELSIF err = 139 THEN WriteString("division by zero")
1775 ELSIF err = 140 THEN WriteString("infinite real result")
1776 ELSIF err = 141 THEN WriteString("real underflow")
1777 ELSIF err = 142 THEN WriteString("real overflow")
1778 ELSIF err = 143 THEN WriteString("undefined real result")
1779 ELSIF err = 200 THEN WriteString("keyboard interrupt")
1780 ELSIF err = 202 THEN WriteString("illegal instruction: ");
1781 WriteHex(val, 4)
1782 ELSIF err = 203 THEN WriteString("illegal memory read [ad = ");
1783 WriteHex(val, 8); WriteString("]")
1784 ELSIF err = 204 THEN WriteString("illegal memory write [ad = ");
1785 WriteHex(val, 8); WriteString("]")
1786 ELSIF err = 205 THEN WriteString("illegal execution [ad = ");
1787 WriteHex(val, 8); WriteString("]")
1788 ELSIF err < 0 THEN WriteString("exception #"); WriteHex(-err, 2)
1789 ELSE err := err DIV 100 * 256 + err DIV 10 MOD 10 * 16 + err MOD 10;
1790 WriteString("trap #"); WriteHex(err, 3)
1791 END;
1792 a := pc; b := fp; c := 12;
1793 REPEAT
1794 WriteLn; WriteString("- ");
1795 mod := modList;
1796 WHILE (mod # NIL) & ((a < mod.code) OR (a >= mod.code + mod.csize)) DO mod := mod.next END;
1797 IF mod # NIL THEN
1798 DEC(a, mod.code);
1799 IF mod.refcnt >= 0 THEN
1800 WriteString(mod.name); ref := mod.refs;
1801 REPEAT GetRefProc(ref, end, name) UNTIL (end = 0) OR (a < end);
1802 IF a < end THEN
1803 WriteString("."); WriteString(name)
1804 END
1805 ELSE
1806 WriteString("("); WriteString(mod.name); WriteString(")")
1807 END;
1808 WriteString(" ")
1809 END;
1810 WriteString("(pc="); WriteHex(a, 8);
1811 WriteString(", fp="); WriteHex(b, 8); WriteString(")");
1812 IF (b >= sp) & (b < stack) THEN
1813 S.GET(b+4, a); (* stacked pc *)
1814 S.GET(b, b); (* dynamic link *)
1815 DEC(c)
1816 ELSE c := 0
1817 END
1818 UNTIL c = 0;
1819 out[len] := 0X;
1820 x := MessageBox("BlackBox", out$, {mbOk})
1821 END DefaultTrapViewer;
1823 PROCEDURE TrapCleanup;
1824 VAR t: TrapCleaner;
1825 BEGIN
1826 WHILE trapStack # NIL DO
1827 t := trapStack; trapStack := trapStack.next; t.Cleanup
1828 END;
1829 IF (trapChecker # NIL) & (err # 128) THEN trapChecker END
1830 END TrapCleanup;
1832 PROCEDURE SetTrapGuard* (on: BOOLEAN);
1833 BEGIN
1834 guarded := on
1835 END SetTrapGuard;
1837 PROCEDURE Try* (h: TryHandler; a, b, c: INTEGER);
1838 VAR res: INTEGER; context: Libc.sigjmp_buf; oldContext: POINTER TO Libc.sigjmp_buf;
1839 BEGIN
1840 oldContext := currentTryContext;
1841 res := Libc.sigsetjmp(context, Libc.TRUE);
1842 currentTryContext := S.ADR(context);
1843 IF res = 0 THEN (* first time around *)
1844 h(a, b, c);
1845 ELSIF res = trapReturn THEN (* after a trap *)
1846 ELSE
1847 HALT(100)
1848 END;
1849 currentTryContext := oldContext;
1850 END Try;
1852 (* -------------------- Initialization --------------------- *)
1854 PROCEDURE InitFpu; (* COMPILER DEPENDENT *)
1855 (* could be eliminated, delayed for backward compatibility *)
1856 VAR cw: SET;
1857 BEGIN
1858 FINIT;
1859 FSTCW;
1860 (* denorm, underflow, precision, zero div, overflow masked *)
1861 (* invalid trapped *)
1862 (* round to nearest, temp precision *)
1863 cw := cw - {0..5, 8..11} + {1, 2, 3, 4, 5, 8, 9};
1864 FLDCW
1865 END InitFpu;
1867 (* A. V. Shiryaev: Show extended trap information (OpenBSD) *)
1868 PROCEDURE ShowTrap (sig: INTEGER; siginfo: Libc.Ptrsiginfo_t; context: Libc.Ptrucontext_t);
1870 PROCEDURE WriteChar (c: SHORTCHAR);
1871 VAR s: ARRAY [untagged] 2 OF SHORTCHAR;
1872 BEGIN
1873 s[0] := c; s[1] := 0X;
1874 res := Libc.printf(s)
1875 END WriteChar;
1877 PROCEDURE WriteString (s: ARRAY OF SHORTCHAR);
1878 VAR res: INTEGER;
1879 BEGIN
1880 res := Libc.printf(s)
1881 END WriteString;
1883 PROCEDURE WriteHex (x, n: INTEGER);
1884 VAR i, y: INTEGER;
1885 s: ARRAY 9 OF SHORTCHAR;
1886 BEGIN
1887 s[n] := 0X;
1888 i := 0 + n - 1;
1889 WriteChar("$");
1890 WHILE i >= 0 DO
1891 y := x MOD 16; x := x DIV 16;
1892 IF y > 9 THEN y := y + (ORD("A") - ORD("0") - 10) END;
1893 s[i] := SHORT(CHR(y + ORD("0")));
1894 DEC(i)
1895 END;
1896 WriteString(s)
1897 END WriteHex;
1899 PROCEDURE WriteLn;
1900 BEGIN
1901 WriteChar(0AX)
1902 END WriteLn;
1904 PROCEDURE KV (name: ARRAY OF SHORTCHAR; x: INTEGER);
1905 BEGIN
1906 WriteString(name); WriteString(" = "); WriteHex(x, 8)
1907 END KV;
1909 BEGIN
1910 WriteString("================================"); WriteLn;
1911 WriteString("TRAP:"); WriteLn;
1912 WriteString("--------------------------------"); WriteLn;
1914 KV("sig", sig); WriteString(", ");
1915 KV("baseStack", baseStack); WriteLn;
1917 KV("GS ", context.sc_gs); WriteString(", ");
1918 KV("FS ", context.sc_fs); WriteString(", ");
1919 KV("ES ", context.sc_es); WriteString(", ");
1920 KV("DS ", context.sc_ds); WriteLn;
1922 KV("EDI", context.sc_edi); WriteString(", ");
1923 KV("ESI", context.sc_esi); WriteString(", ");
1924 KV("EBP", context.sc_ebp); WriteString(", ");
1925 KV("EBX", context.sc_ebx); WriteLn;
1927 KV("EDX", context.sc_edx); WriteString(", ");
1928 KV("ECX", context.sc_ecx); WriteString(", ");
1929 KV("EAX", context.sc_eax); WriteString(", ");
1930 KV("EIP", context.sc_eip); WriteLn;
1932 KV("CS", context.sc_cs); WriteString(", ");
1933 KV("EFLAGS", context.sc_eflags); WriteString(", ");
1934 KV("ESP", context.sc_esp); WriteString(", ");
1935 KV("SS", context.sc_ss); WriteLn;
1937 KV("ONSTACK", context.sc_onstack); WriteString(", ");
1938 KV("MASK", context.sc_mask); WriteString(", ");
1939 KV("TRAPNO", context.sc_trapno); WriteString(", ");
1940 KV("ERR", context.sc_err); WriteLn;
1942 WriteString("---- siginfo: ------------------"); WriteLn;
1944 KV("signo", siginfo.si_signo); WriteString(", ");
1945 KV("code", siginfo.si_code); WriteString(", ");
1946 KV("errno", siginfo.si_errno); WriteLn;
1947 KV("fault.addr", siginfo._data._fault._addr); WriteString(", ");
1948 KV("fault.trapno", siginfo._data._fault._trapno); WriteLn;
1950 WriteString("================================"); WriteLn
1951 END ShowTrap;
1953 PROCEDURE [ccall] TrapHandler (sig: INTEGER; siginfo: Libc.Ptrsiginfo_t; context: Libc.Ptrucontext_t);
1954 BEGIN
1955 IF isReadableCheck THEN
1956 isReadableCheck := FALSE;
1957 Msg("~IsReadable");
1958 Libc.siglongjmp(isReadableContext, 1)
1959 END;
1961 (*
1962 S.GETREG(SP, sp);
1963 S.GETREG(FP, fp);
1964 *)
1965 stack := baseStack;
1967 (* A. V. Shiryaev *)
1968 (*
1969 sp := context.uc_mcontext.gregs[7]; (* TODO: is the stack pointer really stored in register 7? *)
1970 fp := context.uc_mcontext.gregs[6]; (* TODO: is the frame pointer really stored in register 6? *)
1971 pc := context.uc_mcontext.gregs[14]; (* TODO: is the pc really stored in register 14? *)
1972 *)
1973 (* val := siginfo.si_addr; *)
1974 (* OpenBSD *)
1975 ShowTrap(sig, siginfo, context);
1976 sp := context.sc_esp; fp := context.sc_ebp; pc := context.sc_eip;
1977 val := siginfo._data._fault._addr;
1979 (*
1980 Int(sig); Int(siginfo.si_signo); Int(siginfo.si_code); Int(siginfo.si_errno);
1981 Int(siginfo.si_status); Int(siginfo.si_value); Int(siginfo.si_int);
1982 *)
1983 err := sig;
1984 IF trapped THEN DefaultTrapViewer END;
1985 CASE sig OF
1986 Libc.SIGINT:
1987 err := 200 (* Interrupt (ANSI). *)
1988 | Libc.SIGILL: (* Illegal instruction (ANSI). *)
1989 err := 202; val := 0;
1990 IF IsReadable(pc, pc + 4) THEN
1991 S.GET(pc, val);
1992 IF val MOD 100H = 8DH THEN (* lea reg,reg *)
1993 IF val DIV 100H MOD 100H = 0F0H THEN
1994 err := val DIV 10000H MOD 100H (* trap *)
1995 ELSIF val DIV 1000H MOD 10H = 0EH THEN
1996 err := 128 + val DIV 100H MOD 10H (* run time error *)
1997 END
1998 END
1999 END
2000 | Libc.SIGFPE:
2001 CASE siginfo.si_code OF
2002 0: (* TODO: ?????? *)
2003 (* A. V. Shiryaev: OpenBSD *)
2004 (*
2005 IF siginfo.si_int = 8 THEN
2006 err := 139
2007 ELSIF siginfo.si_int = 0 THEN
2008 err := 143
2009 END
2010 *)
2011 err := 143;
2012 | Libc.FPE_INTDIV: err := 139 (* Integer divide by zero. *)
2013 | Libc.FPE_INTOVF: err := 138 (* Integer overflow. *)
2014 | Libc.FPE_FLTDIV: err := 140 (* Floating point divide by zero. *)
2015 | Libc.FPE_FLTOVF: err := 142 (* Floating point overflow. *)
2016 | Libc.FPE_FLTUND: err := 141 (* Floating point underflow. *)
2017 | Libc.FPE_FLTRES: err := 143 (* Floating point inexact result. *)
2018 | Libc.FPE_FLTINV: err := 143 (* Floating point invalid operation. *)
2019 | Libc.FPE_FLTSUB: err := 134 (* Subscript out of range. *)
2020 ELSE
2021 END
2022 | Libc.SIGSEGV: (* Segmentation violation (ANSI). *)
2023 err := 203
2024 ELSE
2025 END;
2026 INC(trapCount);
2027 InitFpu;
2028 TrapCleanup;
2029 IF err # 128 THEN
2030 IF (trapViewer = NIL) OR trapped THEN
2031 DefaultTrapViewer
2032 ELSE
2033 trapped := TRUE;
2035 trapViewer();
2037 trapped := FALSE
2038 END
2039 END;
2040 IF currentTryContext # NIL THEN (* Try failed *)
2041 Libc.siglongjmp(currentTryContext, trapReturn)
2042 ELSE
2043 IF restart # NIL THEN (* Start failed *)
2044 Libc.siglongjmp(loopContext, trapReturn)
2045 END;
2046 Quit(1); (* FIXME *)
2047 END;
2048 trapped := FALSE
2049 END TrapHandler;
2051 PROCEDURE InstallSignals*;
2052 VAR sa, old: Libc.sigaction_t; res, i: INTEGER;
2053 (*
2054 sigstk: Libc.sigaltstack_t;
2055 errno: INTEGER;
2056 *)
2057 BEGIN
2058 (*
2059 (* A. V. Shiryaev: Set alternative stack on which signals are to be processed *)
2060 sigstk.ss_sp := sigStack;
2061 sigstk.ss_size := sigStackSize;
2062 sigstk.ss_flags := 0;
2063 res := Libc.sigaltstack(sigstk, NIL);
2064 IF res # 0 THEN Msg("ERROR: Kernel.InstallSignals: sigaltstack failed!");
2065 S.GET( Libc.__errno_location(), errno );
2066 Int(errno);
2067 Libc.exit(1)
2068 END;
2069 *)
2071 sa.sa_sigaction := TrapHandler;
2072 (*
2073 res := LinLibc.sigemptyset(S.ADR(sa.sa_mask));
2074 *)
2075 res := Libc.sigfillset(S.ADR(sa.sa_mask));
2076 sa.sa_flags := (* Libc.SA_ONSTACK + *) Libc.SA_SIGINFO; (* TrapHandler takes three arguments *)
2077 (*
2078 IF LinLibc.sigaction(LinLibc.SIGINT, sa, old) # 0 THEN Msg("failed to install SIGINT") END;
2079 IF LinLibc.sigaction(LinLibc.SIGILL, sa, old) # 0 THEN Msg("failed to install SIGILL") END;
2080 IF LinLibc.sigaction(LinLibc.SIGFPE, sa, old) # 0 THEN Msg("failed to install SIGFPE") END;
2081 IF LinLibc.sigaction(LinLibc.SIGSEGV, sa, old) # 0 THEN Msg("failed to install SIGSEGV") END;
2082 IF LinLibc.sigaction(LinLibc.SIGPIPE, sa, old) # 0 THEN Msg("failed to install SIGPIPE") END;
2083 IF LinLibc.sigaction(LinLibc.SIGTERM, sa, old) # 0 THEN Msg("failed to install SIGTERM") END;
2084 *)
2085 (* respond to all possible signals *)
2086 FOR i := 1 TO Libc._NSIG - 1 DO
2087 IF (i # Libc.SIGKILL)
2088 & (i # Libc.SIGSTOP)
2089 & (i # Libc.SIGWINCH)
2090 & (i # Libc.SIGTHR) (* A. V. Shiryaev: OpenBSD -pthread *)
2091 THEN
2092 IF Libc.sigaction(i, sa, old) # 0 THEN Msg("failed to install signal"); Int(i) END;
2093 END
2094 END
2095 END InstallSignals;
2097 PROCEDURE Init;
2098 VAR i: INTEGER;
2099 BEGIN
2100 (*
2101 (* for sigaltstack *)
2102 sigStack := Libc.calloc(1, sigStackSize);
2103 IF sigStack = Libc.NULL THEN
2104 Msg("ERROR: Kernel.Init: calloc(1, sigStackSize) failed!");
2105 Libc.exit(1)
2106 END;
2107 *)
2109 isReadableCheck := FALSE;
2111 InstallSignals; (* init exception handling *)
2112 currentTryContext := NIL;
2114 allocated := 0; total := 0; used := 0;
2115 sentinelBlock.size := MAX(INTEGER);
2116 sentinel := S.ADR(sentinelBlock);
2118 (*
2119 S.PUTREG(ML, S.ADR(modList));
2120 *)
2122 i := N;
2123 REPEAT DEC(i); free[i] := sentinel UNTIL i = 0;
2125 IF inDll THEN
2126 (*
2127 baseStack := FPageWord(4); (* begin of stack segment *)
2128 *)
2129 END;
2130 InitFpu;
2131 IF ~static THEN
2132 InitModule(modList);
2133 IF ~inDll THEN Quit(1) END
2134 END;
2135 told := 0; shift := 0
2136 END Init;
2138 BEGIN
2139 IF modList = NIL THEN (* only once *)
2140 S.GETREG(SP, baseStack); (* TODO: Check that this is ok. *)
2141 IF bootInfo # NIL THEN
2142 modList := bootInfo.modList (* boot loader initializes the bootInfo struct *)
2143 ELSE
2144 S.GETREG(ML, modList) (* linker loads module list to BX *)
2145 END;
2146 static := init IN modList.opts;
2147 inDll := dll IN modList.opts;
2148 Init
2149 END
2150 CLOSE
2151 IF ~terminating THEN
2152 terminating := TRUE;
2153 Quit(0)
2154 END
2155 END Kernel.