DEADSOFTWARE

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