DEADSOFTWARE

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