DEADSOFTWARE

GIT / REPO / FRED-BOY
Projects / cpc.git / blob
summary | shortlog | log | commit | commitdiff | tree
history | raw | HEAD
disable stack trace after user interrupt
[cpc.git] / src / native / linux / 486 / System / Mod / Kernel.cp
1 MODULE Kernel;
2
3 IMPORT S := SYSTEM, stdlib := PosixCstdlib, stdio := PosixCstdio,
4 time := PosixCtime, wctype := PosixCwctype, sysmman := PosixCsys_mman,
5 dlfcn := PosixCdlfcn, types := PosixCtypes, fcntl := PosixCfcntl,
6 unistd := PosixCunistd, signal := PosixCsignal, setjmp := PosixCsetjmp;
7
8 (* init fpu? *)
9 (* add signal blocking to avoid race conditions in Try/Trap/TrapHandler *)
10 (* add BeepHook for Beep *)
11 (* implement Call using libffi *)
12
13 CONST
14 nameLen* = 256;
15
16 littleEndian* = TRUE;
17 timeResolution* = 1000; (* ticks per second *)
18
19 processor* = 1; (* generic c *)
20
21 objType* = "ocf"; (* file types *)
22 symType* = "osf";
23 docType* = "odc";
24
25 (* loader constants *)
26 done* = 0;
27 fileNotFound* = 1;
28 syntaxError* = 2;
29 objNotFound* = 3;
30 illegalFPrint* = 4;
31 cyclicImport* = 5;
32 noMem* = 6;
33 commNotFound* = 7;
34 commSyntaxError* = 8;
35 moduleNotFound* = 9;
36
37 any = 1000000;
38
39 CX = 1;
40 SP = 4; (* register number of stack pointer *)
41 FP = 5; (* register number of frame pointer *)
42 ML = 3; (* register which holds the module list at program start *)
43
44 strictStackSweep = FALSE;
45 N = 128 DIV 16; (* free lists *)
46
47 (* kernel flags in module desc *)
48 init = 16; dyn = 17; dll = 24; iptrs = 30;
49
50 (* meta interface consts *)
51 mConst = 1; mTyp = 2; mVar = 3; mProc = 4; mField = 5;
52
53 TYPE
54 Name* = ARRAY nameLen OF CHAR;
55 Utf8Name* = ARRAY nameLen OF SHORTCHAR;
56 Command* = PROCEDURE;
57
58 Module* = POINTER TO RECORD [untagged]
59 next-: Module;
60 opts-: SET; (* 0..15: compiler opts, 16..31: kernel flags *)
61 refcnt-: INTEGER; (* <0: module invalidated *)
62 compTime-, loadTime-: ARRAY 6 OF SHORTINT;
63 ext-: INTEGER; (* currently not used *)
64 term-: Command; (* terminator *)
65 nofimps-, nofptrs-: INTEGER;
66 csize-, dsize-, rsize-: INTEGER;
67 code-, data-, refs-: INTEGER;
68 procBase-, varBase-: INTEGER; (* meta base addresses *)
69 names-: POINTER TO ARRAY [untagged] OF SHORTCHAR; (* names[0] = 0X *)
70 ptrs-: POINTER TO ARRAY [untagged] OF INTEGER;
71 imports-: POINTER TO ARRAY [untagged] OF Module;
72 export-: Directory; (* exported objects (name sorted) *)
73 name-: Utf8Name
74 END;
75
76 Type* = POINTER TO RECORD [untagged]
77 (* record: ptr to method n at offset - 4 * (n+1) *)
78 size-: INTEGER; (* record: size, array: #elem, dyn array: 0, proc: sigfp *)
79 mod-: Module;
80 id-: INTEGER; (* name idx * 256 + lev * 16 + attr * 4 + form *)
81 base-: ARRAY 16 OF Type; (* signature if form = ProcTyp *)
82 fields-: Directory; (* new fields (declaration order) *)
83 ptroffs-: ARRAY any OF INTEGER (* array of any length *)
84 END;
85
86 Object* = POINTER TO ObjDesc;
87
88 ObjDesc* = RECORD [untagged]
89 fprint-: INTEGER;
90 offs-: INTEGER; (* pvfprint for record types *)
91 id-: INTEGER; (* name idx * 256 + vis * 16 + mode *)
92 struct-: Type (* id of basic type or pointer to typedesc/signature *)
93 END;
94
95 Directory* = POINTER TO RECORD [untagged]
96 num-: INTEGER; (* number of entries *)
97 obj-: ARRAY any OF ObjDesc (* array of any length *)
98 END;
99
100 Signature* = POINTER TO RECORD [untagged]
101 retStruct-: Type; (* id of basic type or pointer to typedesc or 0 *)
102 num-: INTEGER; (* number of parameters *)
103 par-: ARRAY any OF RECORD [untagged] (* parameters *)
104 id-: INTEGER; (* name idx * 256 + kind *)
105 struct-: Type (* id of basic type or pointer to typedesc *)
106 END
107 END;
108
109 Handler* = PROCEDURE;
110
111 Reducer* = POINTER TO ABSTRACT RECORD
112 next: Reducer
113 END;
114
115 Identifier* = ABSTRACT RECORD
116 typ*: INTEGER;
117 obj-: ANYPTR
118 END;
119
120 TrapCleaner* = POINTER TO ABSTRACT RECORD
121 next: TrapCleaner
122 END;
123
124 TryHandler* = PROCEDURE (a, b, c: INTEGER);
125
126 (* meta extension suport *)
127
128 ItemExt* = POINTER TO ABSTRACT RECORD END;
129
130 ItemAttr* = RECORD
131 obj*, vis*, typ*, adr*: INTEGER;
132 mod*: Module;
133 desc*: Type;
134 ptr*: S.PTR;
135 ext*: ItemExt
136 END;
137
138 Hook* = POINTER TO ABSTRACT RECORD END;
139
140 LoaderHook* = POINTER TO ABSTRACT RECORD (Hook)
141 res*: INTEGER;
142 importing*, imported*, object*: ARRAY 256 OF CHAR
143 END;
144
145 Block = POINTER TO RECORD [untagged]
146 tag: Type;
147 last: INTEGER; (* arrays: last element *)
148 actual: INTEGER; (* arrays: used during mark phase *)
149 first: INTEGER (* arrays: first element *)
150 END;
151
152 FreeBlock = POINTER TO FreeDesc;
153
154 FreeDesc = RECORD [untagged]
155 tag: Type; (* f.tag = ADR(f.size) *)
156 size: INTEGER;
157 next: FreeBlock
158 END;
159
160 Cluster = POINTER TO RECORD [untagged]
161 size: INTEGER; (* total size *)
162 next: Cluster;
163 max: INTEGER (* exe: reserved size, dll: original address *)
164 (* start of first block *)
165 END;
166
167 FList = POINTER TO RECORD
168 next: FList;
169 blk: Block;
170 iptr, aiptr: BOOLEAN
171 END;
172
173 CList = POINTER TO RECORD
174 next: CList;
175 do: Command;
176 trapped: BOOLEAN
177 END;
178
179
180 PtrType = RECORD v: S.PTR END; (* used for array of pointer *)
181 Char8Type = RECORD v: SHORTCHAR END;
182 Char16Type = RECORD v: CHAR END;
183 Int8Type = RECORD v: BYTE END;
184 Int16Type = RECORD v: SHORTINT END;
185 Int32Type = RECORD v: INTEGER END;
186 Int64Type = RECORD v: LONGINT END;
187 BoolType = RECORD v: BOOLEAN END;
188 SetType = RECORD v: SET END;
189 Real32Type = RECORD v: SHORTREAL END;
190 Real64Type = RECORD v: REAL END;
191 ProcType = RECORD v: PROCEDURE END;
192 UPtrType = RECORD v: INTEGER END;
193 StrPtr = POINTER TO ARRAY [untagged] OF SHORTCHAR;
194
195 ArrStrPtr = POINTER TO ARRAY [untagged] OF StrPtr;
196
197 ADDRESS* = types.Pvoid;
198
199 VAR
200 baseStack: INTEGER;
201 root: Cluster;
202 modList-: Module;
203 trapCount-: INTEGER;
204 err-, pc-, sp-, fp-, stack-, val-: INTEGER;
205
206 isTry, testRead: BOOLEAN;
207 startEnv: setjmp.sigjmp_buf;
208 tryEnv, readEnv: setjmp.jmp_buf;
209
210 argc-: INTEGER;
211 argv-: ArrStrPtr;
212 pagesize: unistd.long;
213
214 free: ARRAY N OF FreeBlock; (* free list *)
215 sentinelBlock: FreeDesc;
216 sentinel: FreeBlock;
217 candidates: ARRAY 1024 OF INTEGER;
218 nofcand: INTEGER;
219 allocated: INTEGER; (* bytes allocated on BlackBox heap *)
220 total: INTEGER; (* current total size of BlackBox heap *)
221 used: INTEGER; (* bytes allocated on system heap *)
222 finalizers: FList;
223 hotFinalizers: FList;
224 cleaners: CList;
225 reducers: Reducer;
226 trapStack: TrapCleaner;
227 actual: Module; (* valid during module initialization *)
228
229 trapViewer, trapChecker: Handler;
230 trapped, guarded, secondTrap: BOOLEAN;
231 interrupted: BOOLEAN;
232 static, inDll, terminating: BOOLEAN;
233 restart: Command;
234
235 loader: LoaderHook;
236 loadres: INTEGER;
237
238 wouldFinalize: BOOLEAN;
239
240 watcher*: PROCEDURE (event: INTEGER); (* for debugging *)
241
242 intTrap*: BOOLEAN;
243
244 PROCEDURE Erase (adr, words: INTEGER);
245 BEGIN
246 ASSERT(words >= 0, 20);
247 WHILE words > 0 DO
248 S.PUT(adr, 0);
249 INC(adr, 4);
250 DEC(words)
251 END
252 END Erase;
253
254
255 PROCEDURE (VAR id: Identifier) Identified* (): BOOLEAN, NEW, ABSTRACT;
256 PROCEDURE (r: Reducer) Reduce* (full: BOOLEAN), NEW, ABSTRACT;
257 PROCEDURE (c: TrapCleaner) Cleanup*, NEW, EMPTY;
258
259 (* meta extension suport *)
260
261 PROCEDURE (e: ItemExt) Lookup* (name: ARRAY OF CHAR; VAR i: ANYREC), NEW, ABSTRACT;
262 PROCEDURE (e: ItemExt) Index* (index: INTEGER; VAR elem: ANYREC), NEW, ABSTRACT;
263 PROCEDURE (e: ItemExt) Deref* (VAR ref: ANYREC), NEW, ABSTRACT;
264
265 PROCEDURE (e: ItemExt) Valid* (): BOOLEAN, NEW, ABSTRACT;
266 PROCEDURE (e: ItemExt) Size* (): INTEGER, NEW, ABSTRACT;
267 PROCEDURE (e: ItemExt) BaseTyp* (): INTEGER, NEW, ABSTRACT;
268 PROCEDURE (e: ItemExt) Len* (): INTEGER, NEW, ABSTRACT;
269
270 PROCEDURE (e: ItemExt) Call* (OUT ok: BOOLEAN), NEW, ABSTRACT;
271 PROCEDURE (e: ItemExt) BoolVal* (): BOOLEAN, NEW, ABSTRACT;
272 PROCEDURE (e: ItemExt) PutBoolVal* (x: BOOLEAN), NEW, ABSTRACT;
273 PROCEDURE (e: ItemExt) CharVal* (): CHAR, NEW, ABSTRACT;
274 PROCEDURE (e: ItemExt) PutCharVal* (x: CHAR), NEW, ABSTRACT;
275 PROCEDURE (e: ItemExt) IntVal* (): INTEGER, NEW, ABSTRACT;
276 PROCEDURE (e: ItemExt) PutIntVal* (x: INTEGER), NEW, ABSTRACT;
277 PROCEDURE (e: ItemExt) LongVal* (): LONGINT, NEW, ABSTRACT;
278 PROCEDURE (e: ItemExt) PutLongVal* (x: LONGINT), NEW, ABSTRACT;
279 PROCEDURE (e: ItemExt) RealVal* (): REAL, NEW, ABSTRACT;
280 PROCEDURE (e: ItemExt) PutRealVal* (x: REAL), NEW, ABSTRACT;
281 PROCEDURE (e: ItemExt) SetVal* (): SET, NEW, ABSTRACT;
282 PROCEDURE (e: ItemExt) PutSetVal* (x: SET), NEW, ABSTRACT;
283 PROCEDURE (e: ItemExt) PtrVal* (): ANYPTR, NEW, ABSTRACT;
284 PROCEDURE (e: ItemExt) PutPtrVal* (x: ANYPTR), NEW, ABSTRACT;
285 PROCEDURE (e: ItemExt) GetSStringVal* (OUT x: ARRAY OF SHORTCHAR;
286 OUT ok: BOOLEAN), NEW, ABSTRACT;
287 PROCEDURE (e: ItemExt) PutSStringVal* (IN x: ARRAY OF SHORTCHAR;
288 OUT ok: BOOLEAN), NEW, ABSTRACT;
289 PROCEDURE (e: ItemExt) GetStringVal* (OUT x: ARRAY OF CHAR; OUT ok: BOOLEAN), NEW, ABSTRACT;
290 PROCEDURE (e: ItemExt) PutStringVal* (IN x: ARRAY OF CHAR; OUT ok: BOOLEAN), NEW, ABSTRACT;
291
292 (* -------------------- miscellaneous tools -------------------- *)
293
294 PROCEDURE IsUpper* (ch: CHAR): BOOLEAN;
295 BEGIN
296 RETURN wctype.iswupper(ORD(ch)) # 0
297 END IsUpper;
298
299 PROCEDURE Upper* (ch: CHAR): CHAR;
300 BEGIN
301 RETURN CHR(wctype.towupper(ORD(ch)))
302 END Upper;
303
304 PROCEDURE IsLower* (ch: CHAR): BOOLEAN;
305 BEGIN
306 RETURN wctype.iswlower(ORD(ch)) # 0
307 END IsLower;
308
309 PROCEDURE Lower* (ch: CHAR): CHAR;
310 BEGIN
311 RETURN CHR(wctype.towlower(ORD(ch)))
312 END Lower;
313
314 PROCEDURE IsAlpha* (ch: CHAR): BOOLEAN;
315 BEGIN
316 RETURN wctype.iswalpha(ORD(ch)) # 0
317 END IsAlpha;
318
319 PROCEDURE Utf8ToString* (IN in: ARRAY OF SHORTCHAR; OUT out: ARRAY OF CHAR; OUT res: INTEGER);
320 VAR i, j, val, max: INTEGER; ch: SHORTCHAR;
321
322 PROCEDURE FormatError();
323 BEGIN out := in$; res := 2 (*format error*)
324 END FormatError;
325
326 BEGIN
327 ch := in[0]; i := 1; j := 0; max := LEN(out) - 1;
328 WHILE (ch # 0X) & (j < max) DO
329 IF ch < 80X THEN
330 out[j] := ch; INC(j)
331 ELSIF ch < 0E0X THEN
332 val := ORD(ch) - 192;
333 IF val < 0 THEN FormatError; RETURN END ;
334 ch := in[i]; INC(i); val := val * 64 + ORD(ch) - 128;
335 IF (ch < 80X) OR (ch >= 0E0X) THEN FormatError; RETURN END ;
336 out[j] := CHR(val); INC(j)
337 ELSIF ch < 0F0X THEN
338 val := ORD(ch) - 224;
339 ch := in[i]; INC(i); val := val * 64 + ORD(ch) - 128;
340 IF (ch < 80X) OR (ch >= 0E0X) THEN FormatError; RETURN END ;
341 ch := in[i]; INC(i); val := val * 64 + ORD(ch) - 128;
342 IF (ch < 80X) OR (ch >= 0E0X) THEN FormatError; RETURN END ;
343 out[j] := CHR(val); INC(j)
344 ELSE
345 FormatError; RETURN
346 END ;
347 ch := in[i]; INC(i)
348 END;
349 out[j] := 0X;
350 IF ch = 0X THEN res := 0 (*ok*) ELSE res := 1 (*truncated*) END
351 END Utf8ToString;
352
353 PROCEDURE StringToUtf8* (IN in: ARRAY OF CHAR; OUT out: ARRAY OF SHORTCHAR; OUT res: INTEGER);
354 VAR i, j, val, max: INTEGER;
355 BEGIN
356 i := 0; j := 0; max := LEN(out) - 3;
357 WHILE (in[i] # 0X) & (j < max) DO
358 val := ORD(in[i]); INC(i);
359 IF val < 128 THEN
360 out[j] := SHORT(CHR(val)); INC(j)
361 ELSIF val < 2048 THEN
362 out[j] := SHORT(CHR(val DIV 64 + 192)); INC(j);
363 out[j] := SHORT(CHR(val MOD 64 + 128)); INC(j)
364 ELSE
365 out[j] := SHORT(CHR(val DIV 4096 + 224)); INC(j);
366 out[j] := SHORT(CHR(val DIV 64 MOD 64 + 128)); INC(j);
367 out[j] := SHORT(CHR(val MOD 64 + 128)); INC(j)
368 END;
369 END;
370 out[j] := 0X;
371 IF in[i] = 0X THEN res := 0 (*ok*) ELSE res := 1 (*truncated*) END
372 END StringToUtf8;
373
374 PROCEDURE SplitName* (name: ARRAY OF CHAR; VAR head, tail: ARRAY OF CHAR);
375 (* portable *)
376 VAR i, j: INTEGER; ch, lch: CHAR;
377 BEGIN
378 i := 0; ch := name[0];
379 IF ch # 0X THEN
380 REPEAT
381 head[i] := ch; lch := ch; INC(i); ch := name[i]
382 UNTIL (ch = 0X) OR (ch = ".") OR IsUpper(ch) & ~IsUpper(lch);
383 IF ch = "." THEN i := 0; ch := name[0] END;
384 head[i] := 0X; j := 0;
385 WHILE ch # 0X DO tail[j] := ch; INC(i); INC(j); ch := name[i] END;
386 tail[j] := 0X;
387 IF tail = "" THEN tail := head$; head := "" END
388 ELSE head := ""; tail := ""
389 END
390 END SplitName;
391
392 PROCEDURE MakeFileName* (VAR name: ARRAY OF CHAR; type: ARRAY OF CHAR);
393 VAR i, j: INTEGER; ext: ARRAY 8 OF CHAR; ch: CHAR;
394 BEGIN
395 i := 0;
396 WHILE (name[i] # 0X) & (name[i] # ".") DO INC(i) END;
397 IF name[i] = "." THEN
398 IF name[i + 1] = 0X THEN name[i] := 0X END
399 ELSE
400 IF type = "" THEN ext := docType ELSE ext := type$ END;
401 IF i < LEN(name) - LEN(ext$) - 1 THEN
402 name[i] := "."; INC(i); j := 0; ch := ext[0];
403 WHILE ch # 0X DO
404 name[i] := Lower(ch); INC(i); INC(j); ch := ext[j]
405 END;
406 name[i] := 0X
407 END
408 END
409 END MakeFileName;
410
411 PROCEDURE Time* (): LONGINT;
412 VAR res: time.int; tp: time.struct_timespec;
413 BEGIN
414 ASSERT(timeResolution >= 1);
415 ASSERT(timeResolution <= 1000000000);
416 res := time.clock_gettime(time.CLOCK_MONOTONIC, tp);
417 ASSERT(res = 0, 100);
418 RETURN tp.tv_sec * LONG(timeResolution) + tp.tv_nsec DIV LONG(1000000000 DIV timeResolution)
419 END Time;
420
421 PROCEDURE Beep*;
422 (* !!! *)
423 END Beep;
424
425 PROCEDURE SearchProcVar* (var: INTEGER; VAR m: Module; VAR adr: INTEGER);
426 BEGIN
427 adr := var; m := NIL;
428 IF var # 0 THEN
429 m := modList;
430 WHILE (m # NIL) & ((var < m.code) OR (var >= m.code + m.csize)) DO m := m.next END;
431 IF m # NIL THEN DEC(adr, m.code) END
432 END
433 END SearchProcVar;
434
435 (* -------------------- system memory management --------------------- *)
436
437 PROCEDURE AllocMem (size: sysmman.size_t; VAR max: sysmman.size_t): ADDRESS;
438 VAR fd, flags, res: fcntl.int; ptr: ADDRESS;
439 BEGIN
440 max := (size + pagesize - 1) DIV pagesize * pagesize;
441 fd := fcntl.open("/dev/zero", fcntl.O_RDWR, 0);
442 IF fd # -1 THEN
443 flags := sysmman.PROT_READ + sysmman.PROT_WRITE;
444 ptr := sysmman.mmap(0, max, flags, sysmman.MAP_PRIVATE, fd, 0);
445 IF ptr = sysmman.MAP_FAILED THEN ptr := 0 END;
446 res := unistd.close(fd);
447 ASSERT(res = 0, 100)
448 ELSE
449 ptr := 0
450 END;
451 RETURN ptr
452 END AllocMem;
453
454 PROCEDURE FreeMem (adr: ADDRESS; size: sysmman.size_t);
455 VAR res: types.int;
456 BEGIN
457 size := (size + pagesize - 1) DIV pagesize * pagesize;
458 res := sysmman.munmap(adr, size);
459 ASSERT(res = 0, 100)
460 END FreeMem;
461
462 PROCEDURE AllocHeapMem (size: INTEGER; VAR c: Cluster);
463 CONST N = 65536; (* cluster size for dll *)
464 VAR adr, allocated, newsize: INTEGER;
465 BEGIN
466 INC(size, 16);
467 ASSERT(size > 0, 100); adr := 0;
468 IF size < N THEN
469 adr := AllocMem(N, newsize);
470 allocated := newsize
471 END;
472 IF adr = 0 THEN
473 adr := AllocMem(size, newsize);
474 allocated := newsize
475 END;
476 IF adr = 0 THEN c := NIL
477 ELSE
478 c := S.VAL(Cluster, (adr + 15) DIV 16 * 16); c.max := adr;
479 c.size := allocated - (S.VAL(INTEGER, c) - adr);
480 INC(used, c.size); INC(total, c.size)
481 END;
482 ASSERT((adr = 0) OR (adr MOD 16 = 0) & (c.size >= size), 101);
483 (* post: (c = NIL) OR (c MOD 16 = 0) & (c.size >= size) *)
484 END AllocHeapMem;
485
486 PROCEDURE FreeHeapMem (c: Cluster);
487 BEGIN
488 DEC(used, c.size); DEC(total, c.size);
489 FreeMem(S.VAL(ADDRESS, c.max), c.size)
490 END FreeHeapMem;
491
492 PROCEDURE HeapFull (size: INTEGER): BOOLEAN;
493 BEGIN
494 RETURN TRUE
495 END HeapFull;
496
497 PROCEDURE AllocModMem* (descSize, modSize: INTEGER; VAR descAdr, modAdr: INTEGER);
498 BEGIN
499 descAdr := 0; modAdr := 0;
500 descAdr := AllocMem(descSize, descSize);
501 IF descAdr # 0 THEN
502 modAdr := AllocMem(modSize, modSize);
503 IF modAdr = 0 THEN
504 FreeMem(descAdr, descSize)
505 ELSE
506 INC(used, descSize + modSize)
507 END
508 END
509 END AllocModMem;
510
511 PROCEDURE DeallocModMem* (descSize, modSize, descAdr, modAdr: INTEGER);
512 BEGIN
513 FreeMem(descAdr, descSize);
514 FreeMem(modAdr, modSize);
515 DEC(used, descSize + modSize)
516 END DeallocModMem;
517
518 PROCEDURE InvalModMem (modSize, modAdr: INTEGER);
519 BEGIN
520 FreeMem(modAdr, modSize)
521 END InvalModMem;
522
523 PROCEDURE IsReadable* (from, to: INTEGER): BOOLEAN;
524 VAR i: INTEGER; x: BYTE; res: setjmp.int;
525 BEGIN
526 testRead := TRUE;
527 res := setjmp.setjmp(readEnv);
528 IF res = 0 THEN
529 IF from <= to THEN
530 FOR i := from TO to - 1 DO
531 S.GET(i, x)
532 END
533 ELSE
534 FOR i := to - 1 TO from BY -1 DO
535 S.GET(i, x)
536 END
537 END;
538 END;
539 testRead := FALSE;
540 RETURN res = 0
541 END IsReadable;
542
543 (* --------------------- NEW implementation (portable) -------------------- *)
544
545 PROCEDURE^ NewBlock (size: INTEGER): Block;
546
547 PROCEDURE NewRec* (typ: INTEGER): INTEGER; (* implementation of NEW(ptr) *)
548 VAR size, adr: INTEGER; b: Block; tag: Type; l: FList;
549 BEGIN
550 IF ~ODD(typ) THEN
551 tag := S.VAL(Type, typ);
552 b := NewBlock(tag.size);
553 IF b # NIL THEN
554 b.tag := tag;
555 S.GET(typ - 4, size);
556 IF size # 0 THEN (* record uses a finalizer *)
557 l := S.VAL(FList, S.ADR(b.last)); (* anchor new object! *)
558 l := S.VAL(FList, NewRec(S.TYP(FList))); (* NEW(l) *)
559 l.blk := b; l.next := finalizers; finalizers := l
560 END;
561 adr := S.ADR(b.last)
562 ELSE
563 adr := 0
564 END
565 ELSE
566 HALT(100) (* COM interface pointers not supported *)
567 END;
568 RETURN adr
569 END NewRec;
570
571 PROCEDURE NewArr* (eltyp, nofelem, nofdim: INTEGER): INTEGER; (* impl. of NEW(ptr, dim0, dim1, ...) *)
572 VAR b: Block; size, headSize: INTEGER; t: Type;
573 BEGIN
574 CASE eltyp OF
575 | -1: HALT(100) (* COM interface pointers not supported *)
576 | 0: eltyp := S.ADR(PtrType)
577 | 1: eltyp := S.ADR(Char8Type)
578 | 2: eltyp := S.ADR(Int16Type)
579 | 3: eltyp := S.ADR(Int8Type)
580 | 4: eltyp := S.ADR(Int32Type)
581 | 5: eltyp := S.ADR(BoolType)
582 | 6: eltyp := S.ADR(SetType)
583 | 7: eltyp := S.ADR(Real32Type)
584 | 8: eltyp := S.ADR(Real64Type)
585 | 9: eltyp := S.ADR(Char16Type)
586 | 10: eltyp := S.ADR(Int64Type)
587 | 11: eltyp := S.ADR(ProcType)
588 | 12: HALT(101) (* COM interface pointers not supported *)
589 ELSE
590 ASSERT(~ODD(eltyp), 102) (* COM interface pointers not supported *)
591 END;
592 t := S.VAL(Type, eltyp);
593 headSize := 4 * nofdim + 12;
594 size := headSize + nofelem * t.size;
595 b := NewBlock(size);
596 IF b # NIL THEN
597 b.tag := S.VAL(Type, eltyp + 2); (* tag + array mark *)
598 b.last := S.ADR(b.last) + size - t.size; (* pointer to last elem *)
599 b.first := S.ADR(b.last) + headSize; (* pointer to first elem *)
600 RETURN S.ADR(b.last)
601 ELSE
602 RETURN 0
603 END;
604 END NewArr;
605
606 (* -------------------- handler installation (portable) --------------------- *)
607
608 PROCEDURE ThisFinObj* (VAR id: Identifier): ANYPTR;
609 VAR l: FList;
610 BEGIN
611 ASSERT(id.typ # 0, 100);
612 l := finalizers;
613 WHILE l # NIL DO
614 IF S.VAL(INTEGER, l.blk.tag) = id.typ THEN
615 id.obj := S.VAL(ANYPTR, S.ADR(l.blk.last));
616 IF id.Identified() THEN RETURN id.obj END
617 END;
618 l := l.next
619 END;
620 RETURN NIL
621 END ThisFinObj;
622
623 PROCEDURE InstallReducer* (r: Reducer);
624 BEGIN
625 r.next := reducers; reducers := r
626 END InstallReducer;
627
628 PROCEDURE InstallTrapViewer* (h: Handler);
629 BEGIN
630 trapViewer := h
631 END InstallTrapViewer;
632
633 PROCEDURE InstallTrapChecker* (h: Handler);
634 BEGIN
635 trapChecker := h
636 END InstallTrapChecker;
637
638 PROCEDURE PushTrapCleaner* (c: TrapCleaner);
639 VAR t: TrapCleaner;
640 BEGIN
641 t := trapStack; WHILE (t # NIL) & (t # c) DO t := t.next END;
642 ASSERT(t = NIL, 20);
643 c.next := trapStack; trapStack := c
644 END PushTrapCleaner;
645
646 PROCEDURE PopTrapCleaner* (c: TrapCleaner);
647 VAR t: TrapCleaner;
648 BEGIN
649 t := NIL;
650 WHILE (trapStack # NIL) & (t # c) DO
651 t := trapStack; trapStack := trapStack.next
652 END
653 END PopTrapCleaner;
654
655 PROCEDURE InstallCleaner* (p: Command);
656 VAR c: CList;
657 BEGIN
658 c := S.VAL(CList, NewRec(S.TYP(CList))); (* NEW(c) *)
659 c.do := p; c.trapped := FALSE; c.next := cleaners; cleaners := c
660 END InstallCleaner;
661
662 PROCEDURE RemoveCleaner* (p: Command);
663 VAR c0, c: CList;
664 BEGIN
665 c := cleaners; c0 := NIL;
666 WHILE (c # NIL) & (c.do # p) DO c0 := c; c := c.next END;
667 IF c # NIL THEN
668 IF c0 = NIL THEN cleaners := cleaners.next ELSE c0.next := c.next END
669 END
670 END RemoveCleaner;
671
672 PROCEDURE Cleanup*;
673 VAR c, c0: CList;
674 BEGIN
675 c := cleaners; c0 := NIL;
676 WHILE c # NIL DO
677 IF ~c.trapped THEN
678 c.trapped := TRUE; c.do; c.trapped := FALSE; c0 := c
679 ELSE
680 IF c0 = NIL THEN cleaners := cleaners.next
681 ELSE c0.next := c.next
682 END
683 END;
684 c := c.next
685 END
686 END Cleanup;
687
688 (* -------------------- meta information (portable) --------------------- *)
689
690 PROCEDURE (h: LoaderHook) ThisMod* (IN name: ARRAY OF CHAR): Module, NEW, ABSTRACT;
691
692 PROCEDURE SetLoaderHook*(h: LoaderHook);
693 BEGIN
694 loader := h
695 END SetLoaderHook;
696
697 PROCEDURE InitModule (mod: Module); (* initialize linked modules *)
698 VAR body: Command;
699 BEGIN
700 IF ~(dyn IN mod.opts) & (mod.next # NIL) & ~(init IN mod.next.opts) THEN InitModule(mod.next) END;
701 IF ~(init IN mod.opts) THEN
702 body := S.VAL(Command, mod.code);
703 INCL(mod.opts, init);
704 actual := mod;
705 body(); actual := NIL
706 END
707 END InitModule;
708
709 PROCEDURE ThisLoadedMod* (IN name: ARRAY OF CHAR): Module; (* loaded modules only *)
710 VAR m: Module; res: INTEGER; n: Utf8Name;
711 BEGIN
712 StringToUtf8(name, n, res); ASSERT(res = 0);
713 loadres := done;
714 m := modList;
715 WHILE (m # NIL) & ((m.name # n) OR (m.refcnt < 0)) DO m := m.next END;
716 IF (m # NIL) & ~(init IN m.opts) THEN InitModule(m) END;
717 IF m = NIL THEN loadres := moduleNotFound END;
718 RETURN m
719 END ThisLoadedMod;
720
721 PROCEDURE ThisMod* (IN name: ARRAY OF CHAR): Module;
722 BEGIN
723 IF loader # NIL THEN
724 loader.res := done;
725 RETURN loader.ThisMod(name)
726 ELSE
727 RETURN ThisLoadedMod(name)
728 END
729 END ThisMod;
730
731 PROCEDURE LoadMod* (IN name: ARRAY OF CHAR);
732 VAR m: Module;
733 BEGIN
734 m := ThisMod(name)
735 END LoadMod;
736
737 PROCEDURE GetLoaderResult* (OUT res: INTEGER; OUT importing, imported, object: ARRAY OF CHAR);
738 BEGIN
739 IF loader # NIL THEN
740 res := loader.res;
741 importing := loader.importing$;
742 imported := loader.imported$;
743 object := loader.object$
744 ELSE
745 res := loadres;
746 importing := "";
747 imported := "";
748 object := ""
749 END
750 END GetLoaderResult;
751
752 PROCEDURE ThisObject* (mod: Module; IN name: ARRAY OF CHAR): Object;
753 VAR l, r, m, res: INTEGER; p: StrPtr; n: Utf8Name;
754 BEGIN
755 StringToUtf8(name, n, res); ASSERT(res = 0);
756 l := 0; r := mod.export.num;
757 WHILE l < r DO (* binary search *)
758 m := (l + r) DIV 2;
759 p := S.VAL(StrPtr, S.ADR(mod.names[mod.export.obj[m].id DIV 256]));
760 IF p^ = n THEN RETURN S.VAL(Object, S.ADR(mod.export.obj[m])) END;
761 IF p^ < n THEN l := m + 1 ELSE r := m END
762 END;
763 RETURN NIL
764 END ThisObject;
765
766 PROCEDURE ThisDesc* (mod: Module; fprint: INTEGER): Object;
767 VAR i, n: INTEGER;
768 BEGIN
769 i := 0; n := mod.export.num;
770 WHILE (i < n) & (mod.export.obj[i].id DIV 256 = 0) DO
771 IF mod.export.obj[i].offs = fprint THEN RETURN S.VAL(Object, S.ADR(mod.export.obj[i])) END;
772 INC(i)
773 END;
774 RETURN NIL
775 END ThisDesc;
776
777 PROCEDURE ThisField* (rec: Type; IN name: ARRAY OF CHAR): Object;
778 VAR n, res: INTEGER; p: StrPtr; obj: Object; m: Module; nn: Utf8Name;
779 BEGIN
780 StringToUtf8(name, nn, res); ASSERT(res = 0);
781 m := rec.mod;
782 obj := S.VAL(Object, S.ADR(rec.fields.obj[0])); n := rec.fields.num;
783 WHILE n > 0 DO
784 p := S.VAL(StrPtr, S.ADR(m.names[obj.id DIV 256]));
785 IF p^ = nn THEN RETURN obj END;
786 DEC(n); INC(S.VAL(INTEGER, obj), 16)
787 END;
788 RETURN NIL
789 END ThisField;
790
791 PROCEDURE ThisCommand* (mod: Module; IN name: ARRAY OF CHAR): Command;
792 VAR x: Object; sig: Signature;
793 BEGIN
794 x := ThisObject(mod, name);
795 IF (x # NIL) & (x.id MOD 16 = mProc) THEN
796 sig := S.VAL(Signature, x.struct);
797 IF (sig.retStruct = NIL) & (sig.num = 0) THEN RETURN S.VAL(Command, mod.procBase + x.offs) END
798 END;
799 RETURN NIL
800 END ThisCommand;
801
802 PROCEDURE ThisType* (mod: Module; IN name: ARRAY OF CHAR): Type;
803 VAR x: Object;
804 BEGIN
805 x := ThisObject(mod, name);
806 IF (x # NIL) & (x.id MOD 16 = mTyp) & (S.VAL(INTEGER, x.struct) DIV 256 # 0) THEN
807 RETURN x.struct
808 ELSE
809 RETURN NIL
810 END
811 END ThisType;
812
813 PROCEDURE TypeOf* (IN rec: ANYREC): Type;
814 BEGIN
815 RETURN S.VAL(Type, S.TYP(rec))
816 END TypeOf;
817
818 PROCEDURE LevelOf* (t: Type): SHORTINT;
819 BEGIN
820 RETURN SHORT(t.id DIV 16 MOD 16)
821 END LevelOf;
822
823 PROCEDURE NewObj* (VAR o: S.PTR; t: Type);
824 VAR i: INTEGER;
825 BEGIN
826 IF t.size = -1 THEN o := NIL
827 ELSE
828 i := 0; WHILE t.ptroffs[i] >= 0 DO INC(i) END;
829 IF t.ptroffs[i+1] >= 0 THEN INC(S.VAL(INTEGER, t)) END; (* with interface pointers *)
830 o := S.VAL(S.PTR, NewRec(S.VAL(INTEGER, t))) (* generic NEW *)
831 END
832 END NewObj;
833
834 PROCEDURE GetModName* (mod: Module; OUT name: Name);
835 VAR res: INTEGER;
836 BEGIN
837 Utf8ToString(mod.name, name, res); ASSERT(res = 0)
838 END GetModName;
839
840 PROCEDURE GetObjName* (mod: Module; obj: Object; OUT name: Name);
841 VAR p: StrPtr; res: INTEGER;
842 BEGIN
843 p := S.VAL(StrPtr, S.ADR(mod.names[obj.id DIV 256]));
844 Utf8ToString(p^$, name, res); ASSERT(res = 0)
845 END GetObjName;
846
847 PROCEDURE GetTypeName* (t: Type; OUT name: Name);
848 VAR p: StrPtr; res: INTEGER;
849 BEGIN
850 p := S.VAL(StrPtr, S.ADR(t.mod.names[t.id DIV 256]));
851 Utf8ToString(p^$, name, res); ASSERT(res = 0)
852 END GetTypeName;
853
854 PROCEDURE RegisterMod* (mod: Module);
855 VAR i: INTEGER; epoch: time.time_t; tm: time.struct_tm; ptm: time.Pstruct_tm;
856 BEGIN
857 mod.next := modList; modList := mod; mod.refcnt := 0; INCL(mod.opts, dyn); i := 0;
858 WHILE i < mod.nofimps DO
859 IF mod.imports[i] # NIL THEN INC(mod.imports[i].refcnt) END;
860 INC(i)
861 END;
862 epoch := time.time(NIL);
863 ptm := time.localtime_r(epoch, tm);
864 IF ptm # NIL THEN
865 mod.loadTime[0] := SHORT(tm.tm_year + 1900);
866 mod.loadTime[1] := SHORT(tm.tm_mon + 1);
867 mod.loadTime[2] := SHORT(tm.tm_mday);
868 mod.loadTime[3] := SHORT(tm.tm_hour);
869 mod.loadTime[4] := SHORT(tm.tm_min);
870 mod.loadTime[5] := SHORT(tm.tm_sec)
871 ELSE
872 mod.loadTime[0] := 0;
873 mod.loadTime[1] := 0;
874 mod.loadTime[2] := 0;
875 mod.loadTime[3] := 0;
876 mod.loadTime[4] := 0;
877 mod.loadTime[5] := 0
878 END;
879 IF ~(init IN mod.opts) THEN InitModule(mod) END
880 END RegisterMod;
881
882 PROCEDURE^ Collect*;
883
884 PROCEDURE UnloadMod* (mod: Module);
885 VAR i: INTEGER; t: Command;
886 BEGIN
887 IF mod.refcnt = 0 THEN
888 t := mod.term; mod.term := NIL;
889 IF t # NIL THEN t() END; (* terminate module *)
890 i := 0;
891 WHILE i < mod.nofptrs DO (* release global pointers *)
892 S.PUT(mod.varBase + mod.ptrs[i], 0); INC(i)
893 END;
894 Collect; (* call finalizers *)
895 i := 0;
896 WHILE i < mod.nofimps DO (* release imported modules *)
897 IF mod.imports[i] # NIL THEN DEC(mod.imports[i].refcnt) END;
898 INC(i)
899 END;
900 mod.refcnt := -1;
901 IF dyn IN mod.opts THEN (* release memory *)
902 InvalModMem(mod.data + mod.dsize - mod.refs, mod.refs)
903 END
904 END
905 END UnloadMod;
906
907 (* -------------------- dynamic procedure call --------------------- *)
908
909 PROCEDURE Call* (adr: INTEGER; sig: Signature; IN par: ARRAY OF INTEGER; n: INTEGER): LONGINT;
910 BEGIN
911 HALT(126); (* !!! *)
912 RETURN 0
913 END Call;
914
915 (* -------------------- reference information (portable) --------------------- *)
916
917 PROCEDURE RefCh (VAR ref: INTEGER; OUT ch: SHORTCHAR);
918 BEGIN
919 S.GET(ref, ch); INC(ref)
920 END RefCh;
921
922 PROCEDURE RefNum (VAR ref: INTEGER; OUT x: INTEGER);
923 VAR s, n: INTEGER; ch: SHORTCHAR;
924 BEGIN
925 s := 0; n := 0; RefCh(ref, ch);
926 WHILE ORD(ch) >= 128 DO INC(n, ASH(ORD(ch) - 128, s) ); INC(s, 7); RefCh(ref, ch) END;
927 x := n + ASH(ORD(ch) MOD 64 - ORD(ch) DIV 64 * 64, s)
928 END RefNum;
929
930 PROCEDURE RefName (VAR ref: INTEGER; OUT n: Utf8Name);
931 VAR i: INTEGER; ch: SHORTCHAR;
932 BEGIN
933 i := 0; RefCh(ref, ch);
934 WHILE ch # 0X DO n[i] := ch; INC(i); RefCh(ref, ch) END;
935 n[i] := 0X
936 END RefName;
937
938 PROCEDURE GetRefProc* (VAR ref: INTEGER; OUT adr: INTEGER; OUT name: Utf8Name);
939 VAR ch: SHORTCHAR;
940 BEGIN
941 S.GET(ref, ch);
942 WHILE ch >= 0FDX DO (* skip variables *)
943 INC(ref); RefCh(ref, ch);
944 IF ch = 10X THEN INC(ref, 4) END;
945 RefNum(ref, adr); RefName(ref, name); S.GET(ref, ch)
946 END;
947 WHILE (ch > 0X) & (ch < 0FCX) DO (* skip source refs *)
948 INC(ref); RefNum(ref, adr); S.GET(ref, ch)
949 END;
950 IF ch = 0FCX THEN INC(ref); RefNum(ref, adr); RefName(ref, name)
951 ELSE adr := 0
952 END
953 END GetRefProc;
954
955 PROCEDURE GetRefVar* (VAR ref: INTEGER; OUT mode, form: SHORTCHAR; OUT desc: Type; OUT adr: INTEGER; OUT name: Utf8Name);
956 BEGIN
957 S.GET(ref, mode); desc := NIL;
958 IF mode >= 0FDX THEN
959 mode := SHORT(CHR(ORD(mode) - 0FCH));
960 INC(ref); RefCh(ref, form);
961 IF form = 10X THEN
962 S.GET(ref, desc); INC(ref, 4); form := SHORT(CHR(16 + desc.id MOD 4))
963 END;
964 RefNum(ref, adr); RefName(ref, name)
965 ELSE
966 mode := 0X; form := 0X; adr := 0
967 END
968 END GetRefVar;
969
970 PROCEDURE SourcePos* (mod: Module; codePos: INTEGER): INTEGER;
971 VAR ref, pos, ad, d: INTEGER; ch: SHORTCHAR; name: Utf8Name;
972 BEGIN
973 IF mod # NIL THEN (* mf, 12.02.04 *)
974 ref := mod.refs; pos := 0; ad := 0; S.GET(ref, ch);
975 WHILE ch # 0X DO
976 WHILE (ch > 0X) & (ch < 0FCX) DO (* srcref: {dAdr,dPos} *)
977 INC(ad, ORD(ch)); INC(ref); RefNum(ref, d);
978 IF ad > codePos THEN RETURN pos END;
979 INC(pos, d); S.GET(ref, ch)
980 END;
981 IF ch = 0FCX THEN (* proc: 0FCX,Adr,Name *)
982 INC(ref); RefNum(ref, d); RefName(ref, name); S.GET(ref, ch);
983 IF (d > codePos) & (pos > 0) THEN RETURN pos END
984 END;
985 WHILE ch >= 0FDX DO (* skip variables: Mode, Form, adr, Name *)
986 INC(ref); RefCh(ref, ch);
987 IF ch = 10X THEN INC(ref, 4) END;
988 RefNum(ref, d); RefName(ref, name); S.GET(ref, ch)
989 END
990 END;
991 END;
992 RETURN -1
993 END SourcePos;
994
995 PROCEDURE LoadDll* (IN name: ARRAY OF CHAR; VAR ok: BOOLEAN);
996 VAR h: ADDRESS; file: Utf8Name; res: INTEGER;
997 BEGIN
998 StringToUtf8(name, file, res);
999 IF res = 0 THEN
1000 h := dlfcn.dlopen(file, dlfcn.RTLD_LAZY + dlfcn.RTLD_GLOBAL);
1001 ok := h # 0
1002 ELSE
1003 ok := FALSE
1004 END
1005 END LoadDll;
1006
1007 PROCEDURE ThisDllObj* (mode, fprint: INTEGER; IN dll, name: ARRAY OF CHAR): INTEGER;
1008 VAR h, p: ADDRESS; file, sym: Utf8Name; res: INTEGER; err: dlfcn.int;
1009 BEGIN
1010 StringToUtf8(dll, file, res);
1011 IF res = 0 THEN
1012 h := dlfcn.dlopen(file, dlfcn.RTLD_LAZY + dlfcn.RTLD_GLOBAL);
1013 IF h # 0 THEN
1014 StringToUtf8(name, sym, res);
1015 IF res = 0 THEN
1016 p := dlfcn.dlsym(h, sym)
1017 ELSE
1018 p := 0
1019 END;
1020 err := dlfcn.dlclose(h);
1021 ASSERT(err = 0, 100)
1022 ELSE
1023 p := 0
1024 END
1025 ELSE
1026 p := 0
1027 END;
1028 RETURN p
1029 END ThisDllObj;
1030
1031 (* -------------------- garbage collector (portable) --------------------- *)
1032
1033 PROCEDURE Mark (this: Block);
1034 VAR father, son: Block; tag: Type; flag, offset, actual: INTEGER;
1035 BEGIN
1036 IF ~ODD(S.VAL(INTEGER, this.tag)) THEN
1037 father := NIL;
1038 LOOP
1039 INC(S.VAL(INTEGER, this.tag));
1040 flag := S.VAL(INTEGER, this.tag) MOD 4;
1041 tag := S.VAL(Type, S.VAL(INTEGER, this.tag) - flag);
1042 IF flag >= 2 THEN actual := this.first; this.actual := actual
1043 ELSE actual := S.ADR(this.last)
1044 END;
1045 LOOP
1046 offset := tag.ptroffs[0];
1047 IF offset < 0 THEN
1048 INC(S.VAL(INTEGER, tag), offset + 4); (* restore tag *)
1049 IF (flag >= 2) & (actual < this.last) & (offset < -4) THEN (* next array element *)
1050 INC(actual, tag.size); this.actual := actual
1051 ELSE (* up *)
1052 this.tag := S.VAL(Type, S.VAL(INTEGER, tag) + flag);
1053 IF father = NIL THEN RETURN END;
1054 son := this; this := father;
1055 flag := S.VAL(INTEGER, this.tag) MOD 4;
1056 tag := S.VAL(Type, S.VAL(INTEGER, this.tag) - flag);
1057 offset := tag.ptroffs[0];
1058 IF flag >= 2 THEN actual := this.actual ELSE actual := S.ADR(this.last) END;
1059 S.GET(actual + offset, father); S.PUT(actual + offset, S.ADR(son.last));
1060 INC(S.VAL(INTEGER, tag), 4)
1061 END
1062 ELSE
1063 S.GET(actual + offset, son);
1064 IF son # NIL THEN
1065 DEC(S.VAL(INTEGER, son), 4);
1066 IF ~ODD(S.VAL(INTEGER, son.tag)) THEN (* down *)
1067 this.tag := S.VAL(Type, S.VAL(INTEGER, tag) + flag);
1068 S.PUT(actual + offset, father); father := this; this := son;
1069 EXIT
1070 END
1071 END;
1072 INC(S.VAL(INTEGER, tag), 4)
1073 END
1074 END
1075 END
1076 END
1077 END Mark;
1078
1079 PROCEDURE MarkGlobals;
1080 VAR m: Module; i, p: INTEGER;
1081 BEGIN
1082 m := modList;
1083 WHILE m # NIL DO
1084 IF m.refcnt >= 0 THEN
1085 i := 0;
1086 WHILE i < m.nofptrs DO
1087 S.GET(m.varBase + m.ptrs[i], p); INC(i);
1088 IF p # 0 THEN Mark(S.VAL(Block, p - 4)) END
1089 END
1090 END;
1091 m := m.next
1092 END
1093 END MarkGlobals;
1094
1095 PROCEDURE Next (b: Block): Block; (* next block in same cluster *)
1096 VAR size: INTEGER;
1097 BEGIN
1098 S.GET(S.VAL(INTEGER, b.tag) DIV 4 * 4, size);
1099 IF ODD(S.VAL(INTEGER, b.tag) DIV 2) THEN INC(size, b.last - S.ADR(b.last)) END;
1100 RETURN S.VAL(Block, S.VAL(INTEGER, b) + (size + 19) DIV 16 * 16)
1101 END Next;
1102
1103 PROCEDURE CheckCandidates;
1104 (* pre: nofcand > 0 *)
1105 VAR i, j, h, p, end: INTEGER; c: Cluster; blk, next: Block;
1106 BEGIN
1107 (* sort candidates (shellsort) *)
1108 h := 1; REPEAT h := h*3 + 1 UNTIL h > nofcand;
1109 REPEAT h := h DIV 3; i := h;
1110 WHILE i < nofcand DO p := candidates[i]; j := i;
1111 WHILE (j >= h) & (candidates[j-h] > p) DO
1112 candidates[j] := candidates[j-h]; j := j-h
1113 END;
1114 candidates[j] := p; INC(i)
1115 END
1116 UNTIL h = 1;
1117 (* sweep *)
1118 c := root; i := 0;
1119 WHILE c # NIL DO
1120 blk := S.VAL(Block, S.VAL(INTEGER, c) + 12);
1121 end := S.VAL(INTEGER, blk) + (c.size - 12) DIV 16 * 16;
1122 WHILE candidates[i] < S.VAL(INTEGER, blk) DO
1123 INC(i);
1124 IF i = nofcand THEN RETURN END
1125 END;
1126 WHILE S.VAL(INTEGER, blk) < end DO
1127 next := Next(blk);
1128 IF candidates[i] < S.VAL(INTEGER, next) THEN
1129 IF (S.VAL(INTEGER, blk.tag) # S.ADR(blk.last)) (* not a free block *)
1130 & (~strictStackSweep OR (candidates[i] = S.ADR(blk.last))) THEN
1131 Mark(blk)
1132 END;
1133 REPEAT
1134 INC(i);
1135 IF i = nofcand THEN RETURN END
1136 UNTIL candidates[i] >= S.VAL(INTEGER, next)
1137 END;
1138 IF (S.VAL(INTEGER, blk.tag) MOD 4 = 0) & (S.VAL(INTEGER, blk.tag) # S.ADR(blk.last))
1139 & (blk.tag.base[0] = NIL) & (blk.actual > 0) THEN (* referenced interface record *)
1140 Mark(blk)
1141 END;
1142 blk := next
1143 END;
1144 c := c.next
1145 END
1146 END CheckCandidates;
1147
1148 PROCEDURE MarkLocals;
1149 VAR sp, p, min, max: INTEGER; c: Cluster;
1150 BEGIN
1151 sp := S.ADR(sp); nofcand := 0; c := root;
1152 WHILE c.next # NIL DO c := c.next END;
1153 min := S.VAL(INTEGER, root); max := S.VAL(INTEGER, c) + c.size;
1154 WHILE sp < baseStack DO
1155 S.GET(sp, p);
1156 IF (p > min) & (p < max) & (~strictStackSweep OR (p MOD 16 = 0)) THEN
1157 candidates[nofcand] := p; INC(nofcand);
1158 IF nofcand = LEN(candidates) - 1 THEN CheckCandidates; nofcand := 0 END
1159 END;
1160 INC(sp, 4)
1161 END;
1162 candidates[nofcand] := max; INC(nofcand); (* ensure complete scan for interface mark*)
1163 IF nofcand > 0 THEN CheckCandidates END
1164 END MarkLocals;
1165
1166 PROCEDURE MarkFinObj;
1167 VAR f: FList;
1168 BEGIN
1169 wouldFinalize := FALSE;
1170 f := finalizers;
1171 WHILE f # NIL DO
1172 IF ~ODD(S.VAL(INTEGER, f.blk.tag)) THEN wouldFinalize := TRUE END;
1173 Mark(f.blk);
1174 f := f.next
1175 END;
1176 f := hotFinalizers;
1177 WHILE f # NIL DO IF ~ODD(S.VAL(INTEGER, f.blk.tag)) THEN wouldFinalize := TRUE END;
1178 Mark(f.blk);
1179 f := f.next
1180 END
1181 END MarkFinObj;
1182
1183 PROCEDURE CheckFinalizers;
1184 VAR f, g, h, k: FList;
1185 BEGIN
1186 f := finalizers; g := NIL;
1187 IF hotFinalizers = NIL THEN k := NIL
1188 ELSE
1189 k := hotFinalizers;
1190 WHILE k.next # NIL DO k := k.next END
1191 END;
1192 WHILE f # NIL DO
1193 h := f; f := f.next;
1194 IF ~ODD(S.VAL(INTEGER, h.blk.tag)) THEN
1195 IF g = NIL THEN finalizers := f ELSE g.next := f END;
1196 IF k = NIL THEN hotFinalizers := h ELSE k.next := h END;
1197 k := h; h.next := NIL
1198 ELSE g := h
1199 END
1200 END;
1201 h := hotFinalizers;
1202 WHILE h # NIL DO Mark(h.blk); h := h.next END
1203 END CheckFinalizers;
1204
1205 PROCEDURE ExecFinalizer (a, b, c: INTEGER);
1206 VAR f: FList; fin: PROCEDURE(this: ANYPTR);
1207 BEGIN
1208 f := S.VAL(FList, a);
1209 S.GET(S.VAL(INTEGER, f.blk.tag) - 4, fin); (* method 0 *)
1210 IF (fin # NIL) & (f.blk.tag.mod.refcnt >= 0) THEN fin(S.VAL(ANYPTR, S.ADR(f.blk.last))) END;
1211 END ExecFinalizer;
1212
1213 PROCEDURE^ Try* (h: TryHandler; a, b, c: INTEGER); (* COMPILER DEPENDENT *)
1214
1215 PROCEDURE CallFinalizers;
1216 VAR f: FList;
1217 BEGIN
1218 WHILE hotFinalizers # NIL DO
1219 f := hotFinalizers; hotFinalizers := hotFinalizers.next;
1220 Try(ExecFinalizer, S.VAL(INTEGER, f), 0, 0)
1221 END;
1222 wouldFinalize := FALSE
1223 END CallFinalizers;
1224
1225 PROCEDURE Insert (blk: FreeBlock; size: INTEGER); (* insert block in free list *)
1226 VAR i: INTEGER;
1227 BEGIN
1228 blk.size := size - 4; blk.tag := S.VAL(Type, S.ADR(blk.size));
1229 i := MIN(N - 1, (blk.size DIV 16));
1230 blk.next := free[i]; free[i] := blk
1231 END Insert;
1232
1233 PROCEDURE Sweep (dealloc: BOOLEAN);
1234 VAR cluster, last, c: Cluster; blk, next: Block; fblk, b, t: FreeBlock; end, i: INTEGER;
1235 BEGIN
1236 cluster := root; last := NIL; allocated := 0;
1237 i := N;
1238 REPEAT DEC(i); free[i] := sentinel UNTIL i = 0;
1239 WHILE cluster # NIL DO
1240 blk := S.VAL(Block, S.VAL(INTEGER, cluster) + 12);
1241 end := S.VAL(INTEGER, blk) + (cluster.size - 12) DIV 16 * 16;
1242 fblk := NIL;
1243 WHILE S.VAL(INTEGER, blk) < end DO
1244 next := Next(blk);
1245 IF ODD(S.VAL(INTEGER, blk.tag)) THEN
1246 IF fblk # NIL THEN
1247 Insert(fblk, S.VAL(INTEGER, blk) - S.VAL(INTEGER, fblk));
1248 fblk := NIL
1249 END;
1250 DEC(S.VAL(INTEGER, blk.tag)); (* unmark *)
1251 INC(allocated, S.VAL(INTEGER, next) - S.VAL(INTEGER, blk))
1252 ELSIF fblk = NIL THEN
1253 fblk := S.VAL(FreeBlock, blk)
1254 END;
1255 blk := next
1256 END;
1257 IF dealloc & (S.VAL(INTEGER, fblk) = S.VAL(INTEGER, cluster) + 12) THEN (* deallocate cluster *)
1258 c := cluster; cluster := cluster.next;
1259 IF last = NIL THEN root := cluster ELSE last.next := cluster END;
1260 FreeHeapMem(c)
1261 ELSE
1262 IF fblk # NIL THEN Insert(fblk, end - S.VAL(INTEGER, fblk)) END;
1263 last := cluster; cluster := cluster.next
1264 END
1265 END;
1266 (* reverse free list *)
1267 i := N;
1268 REPEAT
1269 DEC(i);
1270 b := free[i]; fblk := sentinel;
1271 WHILE b # sentinel DO t := b; b := t.next; t.next := fblk; fblk := t END;
1272 free[i] := fblk
1273 UNTIL i = 0
1274 END Sweep;
1275
1276 PROCEDURE Collect*;
1277 BEGIN
1278 IF root # NIL THEN
1279 CallFinalizers; (* trap cleanup *)
1280 MarkGlobals;
1281 MarkLocals;
1282 CheckFinalizers;
1283 Sweep(TRUE);
1284 CallFinalizers
1285 END
1286 END Collect;
1287
1288 PROCEDURE FastCollect*;
1289 BEGIN
1290 IF root # NIL THEN
1291 MarkGlobals;
1292 MarkLocals;
1293 MarkFinObj;
1294 Sweep(FALSE)
1295 END
1296 END FastCollect;
1297
1298 PROCEDURE WouldFinalize* (): BOOLEAN;
1299 BEGIN
1300 RETURN wouldFinalize
1301 END WouldFinalize;
1302
1303 (* --------------------- memory allocation (portable) -------------------- *)
1304
1305 PROCEDURE OldBlock (size: INTEGER): FreeBlock; (* size MOD 16 = 0 *)
1306 VAR b, l: FreeBlock; s, i: INTEGER;
1307 BEGIN
1308 s := size - 4;
1309 i := MIN(N - 1, s DIV 16);
1310 WHILE (i # N - 1) & (free[i] = sentinel) DO INC(i) END;
1311 b := free[i]; l := NIL;
1312 WHILE b.size < s DO l := b; b := b.next END;
1313 IF b # sentinel THEN
1314 IF l = NIL THEN free[i] := b.next ELSE l.next := b.next END
1315 ELSE b := NIL
1316 END;
1317 RETURN b
1318 END OldBlock;
1319
1320 PROCEDURE LastBlock (limit: INTEGER): FreeBlock; (* size MOD 16 = 0 *)
1321 VAR b, l: FreeBlock; s, i: INTEGER;
1322 BEGIN
1323 s := limit - 4;
1324 i := 0;
1325 REPEAT
1326 b := free[i]; l := NIL;
1327 WHILE (b # sentinel) & (S.VAL(INTEGER, b) + b.size # s) DO l := b; b := b.next END;
1328 IF b # sentinel THEN
1329 IF l = NIL THEN free[i] := b.next ELSE l.next := b.next END
1330 ELSE b := NIL
1331 END;
1332 INC(i)
1333 UNTIL (b # NIL) OR (i = N);
1334 RETURN b
1335 END LastBlock;
1336
1337 PROCEDURE NewBlock (size: INTEGER): Block;
1338 VAR tsize, a, s: INTEGER; b: FreeBlock; new, c: Cluster; r: Reducer;
1339 BEGIN
1340 ASSERT(size >= 0, 20);
1341 IF size > MAX(INTEGER) - 19 THEN RETURN NIL END;
1342 tsize := (size + 19) DIV 16 * 16;
1343 b := OldBlock(tsize); (* 1) search for free block *)
1344 IF b = NIL THEN
1345 FastCollect; b := OldBlock(tsize); (* 2) collect *)
1346 IF b = NIL THEN
1347 Collect; b := OldBlock(tsize); (* 2a) fully collect *)
1348 END;
1349 IF b = NIL THEN
1350 AllocHeapMem(tsize + 12, new); (* 3) allocate new cluster *)
1351 IF new # NIL THEN
1352 IF (root = NIL) OR (S.VAL(INTEGER, new) < S.VAL(INTEGER, root)) THEN
1353 new.next := root; root := new
1354 ELSE
1355 c := root;
1356 WHILE (c.next # NIL) & (S.VAL(INTEGER, new) > S.VAL(INTEGER, c.next)) DO c := c.next END;
1357 new.next := c.next; c.next := new
1358 END;
1359 b := S.VAL(FreeBlock, S.VAL(INTEGER, new) + 12);
1360 b.size := (new.size - 12) DIV 16 * 16 - 4
1361 ELSE
1362 RETURN NIL (* 4) give up *)
1363 END
1364 END
1365 END;
1366 (* b # NIL *)
1367 a := b.size + 4 - tsize;
1368 IF a > 0 THEN Insert(S.VAL(FreeBlock, S.VAL(INTEGER, b) + tsize), a) END;
1369 IF size > 0 THEN Erase(S.ADR(b.size), (size + 3) DIV 4) END;
1370 INC(allocated, tsize);
1371 RETURN S.VAL(Block, b)
1372 END NewBlock;
1373
1374 PROCEDURE Allocated* (): INTEGER;
1375 BEGIN
1376 RETURN allocated
1377 END Allocated;
1378
1379 PROCEDURE Used* (): INTEGER;
1380 BEGIN
1381 RETURN used
1382 END Used;
1383
1384 PROCEDURE Root* (): INTEGER;
1385 BEGIN
1386 RETURN S.VAL(INTEGER, root)
1387 END Root;
1388
1389 (* -------------------- Trap Handling --------------------- *)
1390
1391 PROCEDURE Start* (code: Command);
1392 VAR res: setjmp.int;
1393 BEGIN
1394 restart := code;
1395 S.GETREG(SP, baseStack);
1396 res := setjmp.sigsetjmp(startEnv, 1);
1397 restart
1398 END Start;
1399
1400 PROCEDURE Quit* (exitCode: INTEGER);
1401 VAR m: Module; term: Command; t: BOOLEAN;
1402 BEGIN
1403 trapViewer := NIL; trapChecker := NIL; restart := NIL;
1404 t := terminating; terminating := TRUE; m := modList;
1405 WHILE m # NIL DO (* call terminators *)
1406 IF ~static OR ~t THEN
1407 term := m.term; m.term := NIL;
1408 IF term # NIL THEN term() END
1409 END;
1410 m := m.next
1411 END;
1412 CallFinalizers;
1413 hotFinalizers := finalizers; finalizers := NIL;
1414 CallFinalizers;
1415 stdlib.exit(exitCode)
1416 END Quit;
1417
1418 PROCEDURE FatalError* (id: INTEGER; str: ARRAY OF CHAR);
1419 VAR res: stdio.int; title: ARRAY 16 OF CHAR; text: ARRAY 256 OF SHORTCHAR;
1420 BEGIN
1421 title := "Error xy";
1422 title[6] := CHR(id DIV 10 + ORD("0"));
1423 title[7] := CHR(id MOD 10 + ORD("0"));
1424 res := unistd.write(2, S.ADR(title), 8);
1425 stdlib.abort
1426 END FatalError;
1427
1428 PROCEDURE DefaultTrapViewer;
1429 VAR out: ARRAY 2048 OF SHORTCHAR; a, b, c, len, ref, end: INTEGER; mod: Module;
1430 modName, name: Name; n: Utf8Name; res: unistd.int;
1431
1432 PROCEDURE WriteString (IN s: ARRAY OF SHORTCHAR);
1433 VAR i: INTEGER;
1434 BEGIN
1435 i := 0;
1436 WHILE (len < LEN(out) - 1) & (s[i] # 0X) DO out[len] := s[i]; INC(i); INC(len) END
1437 END WriteString;
1438
1439 PROCEDURE WriteHex (x, n: INTEGER);
1440 VAR i, y: INTEGER;
1441 BEGIN
1442 IF len + n < LEN(out) THEN
1443 i := len + n - 1;
1444 WHILE i >= len DO
1445 y := x MOD 16; x := x DIV 16;
1446 IF y > 9 THEN y := y + (ORD("A") - ORD("0") - 10) END;
1447 out[i] := SHORT(CHR(y + ORD("0"))); DEC(i)
1448 END;
1449 INC(len, n)
1450 END
1451 END WriteHex;
1452
1453 PROCEDURE WriteLn;
1454 BEGIN
1455 IF len < LEN(out) - 1 THEN out[len] := 0AX; INC(len) END
1456 END WriteLn;
1457
1458 BEGIN
1459 len := 0;
1460 WriteString("====== ");
1461 IF err = 129 THEN WriteString("invalid with")
1462 ELSIF err = 130 THEN WriteString("invalid case")
1463 ELSIF err = 131 THEN WriteString("function without return")
1464 ELSIF err = 132 THEN WriteString("type guard")
1465 ELSIF err = 133 THEN WriteString("implied type guard")
1466 ELSIF err = 134 THEN WriteString("value out of range")
1467 ELSIF err = 135 THEN WriteString("index out of range")
1468 ELSIF err = 136 THEN WriteString("string too long")
1469 ELSIF err = 137 THEN WriteString("stack overflow")
1470 ELSIF err = 138 THEN WriteString("integer overflow")
1471 ELSIF err = 139 THEN WriteString("division by zero")
1472 ELSIF err = 140 THEN WriteString("infinite real result")
1473 ELSIF err = 141 THEN WriteString("real underflow")
1474 ELSIF err = 142 THEN WriteString("real overflow")
1475 ELSIF err = 143 THEN WriteString("undefined real result")
1476 ELSIF err = 144 THEN WriteString("not a number")
1477 ELSIF err = 200 THEN WriteString("keyboard interrupt")
1478 ELSIF err = 201 THEN WriteString("NIL dereference")
1479 ELSIF err = 202 THEN WriteString("illegal instruction: ");
1480 WriteHex(val, 4)
1481 ELSIF err = 203 THEN WriteString("illegal memory read [ad = ");
1482 WriteHex(val, 8); WriteString("]")
1483 ELSIF err = 204 THEN WriteString("illegal memory write [ad = ");
1484 WriteHex(val, 8); WriteString("]")
1485 ELSIF err = 205 THEN WriteString("illegal execution [ad = ");
1486 WriteHex(val, 8); WriteString("]")
1487 ELSIF err = 257 THEN WriteString("out of memory")
1488 ELSIF err = 10001H THEN WriteString("bus error")
1489 ELSIF err = 10002H THEN WriteString("address error")
1490 ELSIF err = 10007H THEN WriteString("fpu error")
1491 ELSIF err < 0 THEN WriteString("exception #"); WriteHex(-err, 2)
1492 ELSE err := err DIV 100 * 256 + err DIV 10 MOD 10 * 16 + err MOD 10;
1493 WriteString("trap #"); WriteHex(err, 3)
1494 END;
1495 WriteString(" ======");
1496 a := pc; b := fp; c := 12;
1497 REPEAT
1498 WriteLn; WriteString("- ");
1499 mod := modList;
1500 WHILE (mod # NIL) & ((a < mod.code) OR (a >= mod.code + mod.csize)) DO mod := mod.next END;
1501 IF mod # NIL THEN
1502 DEC(a, mod.code);
1503 IF mod.refcnt >= 0 THEN
1504 GetModName(mod, modName); WriteString(SHORT(modName)); ref := mod.refs;
1505 REPEAT GetRefProc(ref, end, n) UNTIL (end = 0) OR (a < end);
1506 IF a < end THEN
1507 Utf8ToString(n, name, res); WriteString("."); WriteString(SHORT(name))
1508 END
1509 ELSE
1510 GetModName(mod, modName); WriteString("("); WriteString(SHORT(modName)); WriteString(")")
1511 END;
1512 WriteString(" ")
1513 END;
1514 WriteString("(pc="); WriteHex(a, 8);
1515 WriteString(", fp="); WriteHex(b, 8); WriteString(")");
1516 IF (b >= sp) & (b < stack) THEN
1517 S.GET(b+4, a); (* stacked pc *)
1518 S.GET(b, b); (* dynamic link *)
1519 DEC(c)
1520 ELSE c := 0
1521 END
1522 UNTIL c = 0;
1523 out[len] := 0X;
1524 res := unistd.write(2, S.ADR(out), len)
1525 END DefaultTrapViewer;
1526
1527 PROCEDURE TrapCleanup;
1528 VAR t: TrapCleaner;
1529 BEGIN
1530 WHILE trapStack # NIL DO
1531 t := trapStack; trapStack := trapStack.next; t.Cleanup
1532 END;
1533 IF (trapChecker # NIL) & (err # 128) THEN trapChecker END
1534 END TrapCleanup;
1535
1536 PROCEDURE SetTrapGuard* (on: BOOLEAN);
1537 BEGIN
1538 guarded := on
1539 END SetTrapGuard;
1540
1541 PROCEDURE Try* (h: TryHandler; a, b, c: INTEGER);
1542 VAR oldIsTry: BOOLEAN; oldTryEnv: setjmp.jmp_buf; res: setjmp.int;
1543 BEGIN
1544 oldIsTry := isTry; oldTryEnv := tryEnv;
1545 isTry := TRUE;
1546 res := setjmp._setjmp(tryEnv);
1547 IF res = 0 THEN h(a, b, c) END;
1548 isTry := oldIsTry; tryEnv := oldTryEnv
1549 END Try;
1550
1551 PROCEDURE Trap* (n: INTEGER);
1552 BEGIN
1553 IF trapped THEN
1554 DefaultTrapViewer;
1555 IF ~secondTrap THEN trapped := FALSE; secondTrap := TRUE END
1556 END;
1557 IF n >= 0 THEN err := n
1558 ELSE err := -n + 128
1559 END;
1560 pc := 0; sp := 0; fp := 0; stack := 0; val := 0;
1561 S.GETREG(SP, sp); S.GETREG(FP, fp);
1562 INC(trapCount);
1563 (* !!! InitFPU *)
1564 TrapCleanup;
1565 IF isTry THEN
1566 setjmp._longjmp(tryEnv, 1)
1567 END;
1568 IF (err = 128) OR (err = 200) & ~intTrap THEN (* do nothing *)
1569 ELSIF (trapViewer # NIL) & (restart # NIL) & ~trapped & ~guarded THEN
1570 trapped := TRUE; trapViewer()
1571 ELSE DefaultTrapViewer
1572 END;
1573 trapped := FALSE; secondTrap := FALSE;
1574 IF restart # NIL THEN
1575 setjmp.siglongjmp(startEnv, 1)
1576 END;
1577 stdlib.abort
1578 END Trap;
1579
1580 PROCEDURE [ccall] TrapHandler (signo: signal.int; IN info: signal.siginfo_t; context: ADDRESS);
1581 VAR res: signal.int; uc: signal.Pucontext_t;
1582 BEGIN
1583 IF testRead THEN
1584 setjmp.longjmp(readEnv, 1)
1585 END;
1586 IF trapped THEN
1587 DefaultTrapViewer;
1588 IF ~secondTrap THEN trapped := FALSE; secondTrap := TRUE END
1589 END;
1590 err := -signo;
1591 uc := S.VAL(signal.Pucontext_t, context);
1592 pc := uc.uc_mcontext.gregs[14]; (* %eip *)
1593 sp := uc.uc_mcontext.gregs[7]; (* %esp *)
1594 fp := uc.uc_mcontext.gregs[6]; (* %ebp *)
1595 stack := baseStack;
1596 val := info.info.sigsegv.si_addr;
1597 CASE signo OF
1598 | signal.SIGFPE:
1599 val := info.si_code;
1600 pc := info.info.sigfpe.si_addr;
1601 CASE info.si_code OF
1602 | signal.FPE_INTDIV: err := 139 (* division by zero *)
1603 | signal.FPE_INTOVF: err := 138 (* integer overflow *)
1604 | signal.FPE_FLTDIV: err := 140 (* fpu: division by zero *)
1605 | signal.FPE_FLTOVF: err := 142 (* fpu: overflow *)
1606 | signal.FPE_FLTUND: err := 141 (* fpu: underflow *)
1607 (* !!! | signal.FPE_FLTRES: err := ??? (* fpu: *) *)
1608 | signal.FPE_FLTINV: err := 143 (* val := opcode *) (* fpu: invalid op *)
1609 (* !!! | signal.FPE_FLTSUB: err := ??? (* fpu: *) *)
1610 ELSE (* unknown *)
1611 END
1612 | signal.SIGINT:
1613 val := info.si_code;
1614 err := 200 (* keyboard interrupt *)
1615 | signal.SIGSEGV:
1616 val := info.info.sigsegv.si_addr;
1617 err := 203 (* illigal read *)
1618 | signal.SIGBUS:
1619 val := info.info.sigbus.si_addr;
1620 err := 10001H (* bus error *)
1621 | signal.SIGILL:
1622 pc := info.info.sigill.si_addr;
1623 err := 202; (* illigal instruction *)
1624 IF IsReadable(pc, pc + 4) THEN
1625 S.GET(pc, val);
1626 IF val MOD 100H = 8DH THEN (* lea reg,reg *)
1627 IF val DIV 100H MOD 100H = 0F0H THEN
1628 err := val DIV 10000H MOD 100H (* trap *)
1629 ELSIF val DIV 1000H MOD 10H = 0EH THEN
1630 err := 128 + val DIV 100H MOD 10H (* run time error *)
1631 END
1632 END
1633 END
1634 ELSE (* unknown *)
1635 END;
1636 INC(trapCount);
1637 (* !!! InitFPU *)
1638 TrapCleanup;
1639 IF isTry THEN
1640 setjmp._longjmp(tryEnv, 1)
1641 END;
1642 IF (err = 128) OR (err = 200) & ~intTrap THEN (* do nothing *)
1643 ELSIF (trapViewer # NIL) & (restart # NIL) & ~trapped & ~guarded THEN
1644 trapped := TRUE; trapViewer()
1645 ELSE DefaultTrapViewer
1646 END;
1647 trapped := FALSE; secondTrap := FALSE;
1648 IF restart # NIL THEN
1649 setjmp.siglongjmp(startEnv, 1)
1650 END;
1651 stdlib.abort
1652 END TrapHandler;
1653
1654 (* -------------------- Initialization --------------------- *)
1655
1656 PROCEDURE InstallTrap (signo: signal.int);
1657 VAR act: signal.struct_sigaction; res: signal.int;
1658 BEGIN
1659 act.handler.sa_handler := NIL;
1660 res := signal.sigemptyset(act.sa_mask);
1661 act.sa_flags := signal.SA_NODEFER + signal.SA_SIGINFO;
1662 act.handler.sa_sigaction := TrapHandler;
1663 res := signal.sigaction(signo, act, NIL);
1664 END InstallTrap;
1665
1666 PROCEDURE InstallTrapVectors;
1667 BEGIN
1668 InstallTrap(signal.SIGFPE);
1669 InstallTrap(signal.SIGINT);
1670 InstallTrap(signal.SIGSEGV);
1671 InstallTrap(signal.SIGBUS);
1672 InstallTrap(signal.SIGILL)
1673 END InstallTrapVectors;
1674
1675 PROCEDURE RemoveTrapVectors;
1676 END RemoveTrapVectors;
1677
1678 PROCEDURE Init;
1679 VAR i: INTEGER;
1680 BEGIN
1681 intTrap := TRUE;
1682 pagesize := unistd.sysconf(unistd._SC_PAGESIZE);
1683
1684 (* init heap *)
1685 allocated := 0; total := 0; used := 0;
1686 sentinelBlock.size := MAX(INTEGER);
1687 sentinel := S.ADR(sentinelBlock);
1688 i := N;
1689 REPEAT DEC(i); free[i] := sentinel UNTIL i = 0;
1690
1691 IF ~inDll THEN
1692 InstallTrapVectors
1693 END;
1694
1695 (* !!! InitFPU *)
1696 IF ~static THEN
1697 InitModule(modList);
1698 IF ~inDll THEN Quit(1) END
1699 END
1700 END Init;
1701
1702 BEGIN
1703 IF modList = NIL THEN (* only once *)
1704 S.GETREG(SP, baseStack);
1705 S.GET(baseStack + 16, argc);
1706 argv := S.VAL(ArrStrPtr, baseStack + 20);
1707 S.GETREG(ML, modList); (* linker loads module list to BX *)
1708 static := init IN modList.opts;
1709 inDll := dll IN modList.opts;
1710 Init
1711 END
1712 CLOSE
1713 IF ~terminating THEN
1714 terminating := TRUE;
1715 Quit(0)
1716 END
1717 END Kernel.
A command line Component Pascal Compiler
[25/02/2024 19:55:35]
DEADSOFTWARE 2012-2024