DEADSOFTWARE

GIT / REPO / FRED-BOY
Projects / cpc.git / blob


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