DEADSOFTWARE

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