DEADSOFTWARE

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


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