DEADSOFTWARE

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