DEADSOFTWARE

GIT / REPO / FRED-BOY
Projects / cpc.git / blob
summary | shortlog | log | commit | commitdiff | tree
history | raw | HEAD
Kernel: fix memory allocation on target powerpc-cpfront-osx
[cpc.git] / src / cpfront / osx / 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 [code] MAP_ANON (): INTEGER "MAP_ANON";
447
448 PROCEDURE AllocMem (size: sysmman.size_t; VAR max: sysmman.size_t): ADDRESS;
449 CONST msgstr = "mmap failed errno "; idx = LEN(msgstr);
450 VAR res: fcntl.int; ptr: ADDRESS; msg: ARRAY idx + 5 OF SHORTCHAR;
451 BEGIN
452 max := (size + pagesize - 1) DIV pagesize * pagesize;
453 ptr := sysmman.mmap(0, max, sysmman.PROT_READ + sysmman.PROT_WRITE, sysmman.MAP_PRIVATE + MAP_ANON(), -1, 0);
454 IF ptr = sysmman.MAP_FAILED THEN
455 res := macro.errno();
456 msg := msgstr;
457 msg[idx + 0] := SHORT(CHR(ORD("0") + res DIV 100 MOD 10));
458 msg[idx + 1] := SHORT(CHR(ORD("0") + res DIV 10 MOD 10));
459 msg[idx + 2] := SHORT(CHR(ORD("0") + res MOD 10));
460 msg[idx + 3] := 0AX;
461 msg[idx + 4] := 0X;
462 res := unistd.write(2, S.ADR(msg), LEN(msg$));
463 ptr := 0
464 END;
465 RETURN ptr
466 END AllocMem;
467
468 PROCEDURE FreeMem (adr: ADDRESS; size: sysmman.size_t);
469 VAR res: sysmman.int;
470 BEGIN
471 size := (size + pagesize - 1) DIV pagesize * pagesize;
472 res := sysmman.munmap(adr, size);
473 ASSERT(res = 0, 100)
474 END FreeMem;
475
476 PROCEDURE AllocHeapMem (size: INTEGER; VAR c: Cluster);
477 CONST N = 65536; (* cluster size for dll *)
478 VAR adr, allocated, newsize: INTEGER;
479 BEGIN
480 INC(size, 16);
481 ASSERT(size > 0, 100); adr := 0;
482 IF size < N THEN
483 adr := AllocMem(N, newsize);
484 allocated := newsize
485 END;
486 IF adr = 0 THEN
487 adr := AllocMem(size, newsize);
488 allocated := newsize
489 END;
490 IF adr = 0 THEN c := NIL
491 ELSE
492 c := S.VAL(Cluster, (adr + 15) DIV 16 * 16); c.max := adr;
493 c.size := allocated - (S.VAL(INTEGER, c) - adr);
494 INC(used, c.size); INC(total, c.size)
495 END;
496 ASSERT((adr = 0) OR (adr MOD 16 = 0) & (c.size >= size), 101);
497 (* post: (c = NIL) OR (c MOD 16 = 0) & (c.size >= size) *)
498 END AllocHeapMem;
499
500 PROCEDURE FreeHeapMem (c: Cluster);
501 BEGIN
502 DEC(used, c.size); DEC(total, c.size);
503 FreeMem(S.VAL(ADDRESS, c.max), c.size)
504 END FreeHeapMem;
505
506 PROCEDURE HeapFull (size: INTEGER): BOOLEAN;
507 BEGIN
508 RETURN TRUE
509 END HeapFull;
510
511 PROCEDURE AllocModMem* (descSize, modSize: INTEGER; VAR descAdr, modAdr: INTEGER);
512 BEGIN
513 descAdr := 0; modAdr := 0;
514 descAdr := AllocMem(descSize, descSize);
515 IF descAdr # 0 THEN
516 modAdr := AllocMem(modSize, modSize);
517 IF modAdr = 0 THEN
518 FreeMem(descAdr, descSize)
519 ELSE
520 INC(used, descSize + modSize)
521 END
522 END
523 END AllocModMem;
524
525 PROCEDURE DeallocModMem* (descSize, modSize, descAdr, modAdr: INTEGER);
526 BEGIN
527 FreeMem(descAdr, descSize);
528 FreeMem(modAdr, modSize);
529 DEC(used, descSize + modSize)
530 END DeallocModMem;
531
532 PROCEDURE InvalModMem (modSize, modAdr: INTEGER);
533 BEGIN
534 FreeMem(modAdr, modSize)
535 END InvalModMem;
536
537 PROCEDURE IsReadable* (from, to: INTEGER): BOOLEAN;
538 VAR r: BOOLEAN; jmp: setjmp.sigjmp_buf; res: setjmp.int; i: INTEGER; x: BYTE;
539 BEGIN
540 r := checkReadable;
541 jmp := checkReadableEnv;
542 checkReadable := TRUE;
543 res := setjmp.sigsetjmp(checkReadableEnv, 1);
544 IF res = 0 THEN
545 IF from <= to THEN
546 FOR i := from TO to DO
547 S.GET(i, x)
548 END
549 ELSE
550 FOR i := to TO from BY -1 DO
551 S.GET(i, x)
552 END
553 END
554 END;
555 checkReadableEnv := jmp;
556 checkReadable := r;
557 RETURN res = 0
558 END IsReadable;
559
560 (* --------------------- NEW implementation (portable) -------------------- *)
561
562 PROCEDURE^ NewBlock (size: INTEGER): Block;
563
564 PROCEDURE NewRec* (typ: INTEGER): INTEGER; (* implementation of NEW(ptr) *)
565 VAR size, adr: INTEGER; b: Block; tag: Type; l: FList;
566 BEGIN
567 IF ~ODD(typ) THEN
568 tag := S.VAL(Type, typ);
569 b := NewBlock(tag.size);
570 IF b # NIL THEN
571 b.tag := tag;
572 S.GET(typ - 4, size);
573 IF size # 0 THEN (* record uses a finalizer *)
574 l := S.VAL(FList, S.ADR(b.last)); (* anchor new object! *)
575 l := S.VAL(FList, NewRec(S.TYP(FList))); (* NEW(l) *)
576 l.blk := b; l.next := finalizers; finalizers := l
577 END;
578 adr := S.ADR(b.last)
579 ELSE
580 adr := 0
581 END
582 ELSE
583 HALT(100) (* COM interface pointers not supported *)
584 END;
585 RETURN adr
586 END NewRec;
587
588 PROCEDURE NewArr* (eltyp, nofelem, nofdim: INTEGER): INTEGER; (* impl. of NEW(ptr, dim0, dim1, ...) *)
589 VAR b: Block; size, headSize: INTEGER; t: Type;
590 BEGIN
591 CASE eltyp OF
592 | -1: HALT(100) (* COM interface pointers not supported *)
593 | 0: eltyp := S.ADR(PtrType)
594 | 1: eltyp := S.ADR(Char8Type)
595 | 2: eltyp := S.ADR(Int16Type)
596 | 3: eltyp := S.ADR(Int8Type)
597 | 4: eltyp := S.ADR(Int32Type)
598 | 5: eltyp := S.ADR(BoolType)
599 | 6: eltyp := S.ADR(SetType)
600 | 7: eltyp := S.ADR(Real32Type)
601 | 8: eltyp := S.ADR(Real64Type)
602 | 9: eltyp := S.ADR(Char16Type)
603 | 10: eltyp := S.ADR(Int64Type)
604 | 11: eltyp := S.ADR(ProcType)
605 | 12: eltyp := S.ADR(UPtrType)
606 ELSE
607 ASSERT(~ODD(eltyp), 101) (* COM interface pointers not supported *)
608 END;
609 t := S.VAL(Type, eltyp);
610 headSize := 4 * nofdim + 12;
611 size := headSize + nofelem * t.size;
612 b := NewBlock(size);
613 IF b # NIL THEN
614 b.tag := S.VAL(Type, eltyp + 2); (* tag + array mark *)
615 b.last := S.ADR(b.last) + size - t.size; (* pointer to last elem *)
616 b.first := S.ADR(b.last) + headSize; (* pointer to first elem *)
617 RETURN S.ADR(b.last)
618 ELSE
619 RETURN 0
620 END;
621 END NewArr;
622
623 (* -------------------- handler installation (portable) --------------------- *)
624
625 PROCEDURE ThisFinObj* (VAR id: Identifier): ANYPTR;
626 VAR l: FList;
627 BEGIN
628 ASSERT(id.typ # 0, 100);
629 l := finalizers;
630 WHILE l # NIL DO
631 IF S.VAL(INTEGER, l.blk.tag) = id.typ THEN
632 id.obj := S.VAL(ANYPTR, S.ADR(l.blk.last));
633 IF id.Identified() THEN RETURN id.obj END
634 END;
635 l := l.next
636 END;
637 RETURN NIL
638 END ThisFinObj;
639
640 PROCEDURE InstallReducer* (r: Reducer);
641 BEGIN
642 r.next := reducers; reducers := r
643 END InstallReducer;
644
645 PROCEDURE InstallTrapViewer* (h: Handler);
646 BEGIN
647 trapViewer := h
648 END InstallTrapViewer;
649
650 PROCEDURE InstallTrapChecker* (h: Handler);
651 BEGIN
652 trapChecker := h
653 END InstallTrapChecker;
654
655 PROCEDURE PushTrapCleaner* (c: TrapCleaner);
656 VAR t: TrapCleaner;
657 BEGIN
658 t := trapStack; WHILE (t # NIL) & (t # c) DO t := t.next END;
659 ASSERT(t = NIL, 20);
660 c.next := trapStack; trapStack := c
661 END PushTrapCleaner;
662
663 PROCEDURE PopTrapCleaner* (c: TrapCleaner);
664 VAR t: TrapCleaner;
665 BEGIN
666 t := NIL;
667 WHILE (trapStack # NIL) & (t # c) DO
668 t := trapStack; trapStack := trapStack.next
669 END
670 END PopTrapCleaner;
671
672 PROCEDURE InstallCleaner* (p: Command);
673 VAR c: CList;
674 BEGIN
675 c := S.VAL(CList, NewRec(S.TYP(CList))); (* NEW(c) *)
676 c.do := p; c.trapped := FALSE; c.next := cleaners; cleaners := c
677 END InstallCleaner;
678
679 PROCEDURE RemoveCleaner* (p: Command);
680 VAR c0, c: CList;
681 BEGIN
682 c := cleaners; c0 := NIL;
683 WHILE (c # NIL) & (c.do # p) DO c0 := c; c := c.next END;
684 IF c # NIL THEN
685 IF c0 = NIL THEN cleaners := cleaners.next ELSE c0.next := c.next END
686 END
687 END RemoveCleaner;
688
689 PROCEDURE Cleanup*;
690 VAR c, c0: CList;
691 BEGIN
692 c := cleaners; c0 := NIL;
693 WHILE c # NIL DO
694 IF ~c.trapped THEN
695 c.trapped := TRUE; c.do; c.trapped := FALSE; c0 := c
696 ELSE
697 IF c0 = NIL THEN cleaners := cleaners.next
698 ELSE c0.next := c.next
699 END
700 END;
701 c := c.next
702 END
703 END Cleanup;
704
705 (* -------------------- meta information (portable) --------------------- *)
706
707 PROCEDURE (h: LoaderHook) ThisMod* (IN name: ARRAY OF CHAR): Module, NEW, ABSTRACT;
708
709 PROCEDURE SetLoaderHook*(h: LoaderHook);
710 BEGIN
711 loader := h
712 END SetLoaderHook;
713
714 PROCEDURE InitModule (mod: Module); (* initialize linked modules *)
715 VAR body: Command;
716 BEGIN
717 IF ~(dyn IN mod.opts) & (mod.next # NIL) & ~(init IN mod.next.opts) THEN InitModule(mod.next) END;
718 IF ~(init IN mod.opts) THEN
719 body := S.VAL(Command, mod.code);
720 INCL(mod.opts, init);
721 actual := mod;
722 body(); actual := NIL
723 END
724 END InitModule;
725
726 PROCEDURE ThisLoadedMod* (IN name: ARRAY OF CHAR): Module; (* loaded modules only *)
727 VAR m: Module; res: INTEGER; n: Utf8Name;
728 BEGIN
729 StringToUtf8(name, n, res); ASSERT(res = 0);
730 loadres := done;
731 m := modList;
732 WHILE (m # NIL) & ((m.name # n) OR (m.refcnt < 0)) DO m := m.next END;
733 IF (m # NIL) & ~(init IN m.opts) THEN InitModule(m) END;
734 IF m = NIL THEN loadres := moduleNotFound END;
735 RETURN m
736 END ThisLoadedMod;
737
738 PROCEDURE ThisMod* (IN name: ARRAY OF CHAR): Module;
739 BEGIN
740 IF loader # NIL THEN
741 loader.res := done;
742 RETURN loader.ThisMod(name)
743 ELSE
744 RETURN ThisLoadedMod(name)
745 END
746 END ThisMod;
747
748 PROCEDURE LoadMod* (IN name: ARRAY OF CHAR);
749 VAR m: Module;
750 BEGIN
751 m := ThisMod(name)
752 END LoadMod;
753
754 PROCEDURE GetLoaderResult* (OUT res: INTEGER; OUT importing, imported, object: ARRAY OF CHAR);
755 BEGIN
756 IF loader # NIL THEN
757 res := loader.res;
758 importing := loader.importing$;
759 imported := loader.imported$;
760 object := loader.object$
761 ELSE
762 res := loadres;
763 importing := "";
764 imported := "";
765 object := ""
766 END
767 END GetLoaderResult;
768
769 PROCEDURE ThisObject* (mod: Module; IN name: ARRAY OF CHAR): Object;
770 VAR l, r, m, res: INTEGER; p: StrPtr; n: Utf8Name;
771 BEGIN
772 StringToUtf8(name, n, res); ASSERT(res = 0);
773 l := 0; r := mod.export.num;
774 WHILE l < r DO (* binary search *)
775 m := (l + r) DIV 2;
776 p := S.VAL(StrPtr, S.ADR(mod.names[mod.export.obj[m].id DIV 256]));
777 IF p^ = n THEN RETURN S.VAL(Object, S.ADR(mod.export.obj[m])) END;
778 IF p^ < n THEN l := m + 1 ELSE r := m END
779 END;
780 RETURN NIL
781 END ThisObject;
782
783 PROCEDURE ThisDesc* (mod: Module; fprint: INTEGER): Object;
784 VAR i, n: INTEGER;
785 BEGIN
786 i := 0; n := mod.export.num;
787 WHILE (i < n) & (mod.export.obj[i].id DIV 256 = 0) DO
788 IF mod.export.obj[i].offs = fprint THEN RETURN S.VAL(Object, S.ADR(mod.export.obj[i])) END;
789 INC(i)
790 END;
791 RETURN NIL
792 END ThisDesc;
793
794 PROCEDURE ThisField* (rec: Type; IN name: ARRAY OF CHAR): Object;
795 VAR n, res: INTEGER; p: StrPtr; obj: Object; m: Module; nn: Utf8Name;
796 BEGIN
797 StringToUtf8(name, nn, res); ASSERT(res = 0);
798 m := rec.mod;
799 obj := S.VAL(Object, S.ADR(rec.fields.obj[0])); n := rec.fields.num;
800 WHILE n > 0 DO
801 p := S.VAL(StrPtr, S.ADR(m.names[obj.id DIV 256]));
802 IF p^ = nn THEN RETURN obj END;
803 DEC(n); INC(S.VAL(INTEGER, obj), 16)
804 END;
805 RETURN NIL
806 END ThisField;
807
808 PROCEDURE ThisCommand* (mod: Module; IN name: ARRAY OF CHAR): Command;
809 VAR x: Object; sig: Signature;
810 BEGIN
811 x := ThisObject(mod, name);
812 IF (x # NIL) & (x.id MOD 16 = mProc) THEN
813 sig := S.VAL(Signature, x.struct);
814 IF (sig.retStruct = NIL) & (sig.num = 0) THEN RETURN S.VAL(Command, mod.procBase + x.offs) END
815 END;
816 RETURN NIL
817 END ThisCommand;
818
819 PROCEDURE ThisType* (mod: Module; IN name: ARRAY OF CHAR): Type;
820 VAR x: Object;
821 BEGIN
822 x := ThisObject(mod, name);
823 IF (x # NIL) & (x.id MOD 16 = mTyp) & (S.VAL(INTEGER, x.struct) DIV 256 # 0) THEN
824 RETURN x.struct
825 ELSE
826 RETURN NIL
827 END
828 END ThisType;
829
830 PROCEDURE TypeOf* (IN rec: ANYREC): Type;
831 BEGIN
832 RETURN S.VAL(Type, S.TYP(rec))
833 END TypeOf;
834
835 PROCEDURE LevelOf* (t: Type): SHORTINT;
836 BEGIN
837 RETURN SHORT(t.id DIV 16 MOD 16)
838 END LevelOf;
839
840 PROCEDURE NewObj* (VAR o: S.PTR; t: Type);
841 VAR i: INTEGER;
842 BEGIN
843 IF t.size = -1 THEN o := NIL
844 ELSE
845 i := 0; WHILE t.ptroffs[i] >= 0 DO INC(i) END;
846 IF t.ptroffs[i+1] >= 0 THEN INC(S.VAL(INTEGER, t)) END; (* with interface pointers *)
847 o := S.VAL(S.PTR, NewRec(S.VAL(INTEGER, t))) (* generic NEW *)
848 END
849 END NewObj;
850
851 PROCEDURE GetModName* (mod: Module; OUT name: Name);
852 VAR res: INTEGER;
853 BEGIN
854 Utf8ToString(mod.name, name, res); ASSERT(res = 0)
855 END GetModName;
856
857 PROCEDURE GetObjName* (mod: Module; obj: Object; OUT name: Name);
858 VAR p: StrPtr; res: INTEGER;
859 BEGIN
860 p := S.VAL(StrPtr, S.ADR(mod.names[obj.id DIV 256]));
861 Utf8ToString(p^$, name, res); ASSERT(res = 0)
862 END GetObjName;
863
864 PROCEDURE GetTypeName* (t: Type; OUT name: Name);
865 VAR p: StrPtr; res: INTEGER;
866 BEGIN
867 p := S.VAL(StrPtr, S.ADR(t.mod.names[t.id DIV 256]));
868 Utf8ToString(p^$, name, res); ASSERT(res = 0)
869 END GetTypeName;
870
871 PROCEDURE RegisterMod* (mod: Module);
872 VAR i: INTEGER; epoch: time.time_t; tm: time.struct_tm; ptm: time.Pstruct_tm;
873 BEGIN
874 mod.next := modList; modList := mod; mod.refcnt := 0; INCL(mod.opts, dyn); i := 0;
875 WHILE i < mod.nofimps DO
876 IF mod.imports[i] # NIL THEN INC(mod.imports[i].refcnt) END;
877 INC(i)
878 END;
879 epoch := time.time(NIL);
880 ptm := time.localtime_r(epoch, tm);
881 IF ptm # NIL THEN
882 mod.loadTime[0] := SHORT(tm.tm_year + 1900);
883 mod.loadTime[1] := SHORT(tm.tm_mon + 1);
884 mod.loadTime[2] := SHORT(tm.tm_mday);
885 mod.loadTime[3] := SHORT(tm.tm_hour);
886 mod.loadTime[4] := SHORT(tm.tm_min);
887 mod.loadTime[5] := SHORT(tm.tm_sec)
888 ELSE
889 mod.loadTime[0] := 0;
890 mod.loadTime[1] := 0;
891 mod.loadTime[2] := 0;
892 mod.loadTime[3] := 0;
893 mod.loadTime[4] := 0;
894 mod.loadTime[5] := 0
895 END;
896 IF ~(init IN mod.opts) THEN InitModule(mod) END
897 END RegisterMod;
898
899 PROCEDURE^ Collect*;
900
901 PROCEDURE UnloadMod* (mod: Module);
902 VAR i: INTEGER; t: Command;
903 BEGIN
904 IF mod.refcnt = 0 THEN
905 t := mod.term; mod.term := NIL;
906 IF t # NIL THEN t() END; (* terminate module *)
907 i := 0;
908 WHILE i < mod.nofptrs DO (* release global pointers *)
909 S.PUT(mod.varBase + mod.ptrs[i], 0); INC(i)
910 END;
911 Collect; (* call finalizers *)
912 i := 0;
913 WHILE i < mod.nofimps DO (* release imported modules *)
914 IF mod.imports[i] # NIL THEN DEC(mod.imports[i].refcnt) END;
915 INC(i)
916 END;
917 mod.refcnt := -1;
918 IF dyn IN mod.opts THEN (* release memory *)
919 InvalModMem(mod.data + mod.dsize - mod.refs, mod.refs)
920 END
921 END
922 END UnloadMod;
923
924 (* -------------------- dynamic procedure call --------------------- *)
925
926 (*
927 type par
928 32 bit scalar value
929 64 bit scalar low hi
930 var scalar address
931 record address tag
932 array address size
933 open array address length .. length
934 *)
935
936 PROCEDURE Call* (adr: ADDRESS; sig: Signature; IN par: ARRAY OF INTEGER; n: INTEGER): LONGINT;
937 CONST
938 (* obj.id MOD 16 *)
939 mConst = 1; mTyp = 2; mVar = 3; mProc = 4; mField = 5;
940 (* typ *)
941 mBool = 1; mChar8 = 2; mChar16 = 3; mInt8 = 4; mInt16 = 5; mInt32 = 6;
942 mReal32 = 7; mReal64 = 8; mSet = 9; mInt64 = 10; mAnyRec = 11; mAnyPtr = 12; mSysPtr = 13;
943 (* typ.id MOD 4 *)
944 mProctyp = 0; mRecord = 1; mArray = 2; mPointer = 3;
945 (* ??? obj.id DIV 16 MOD 16 *)
946 mInternal = 1; mReadonly = 2; mPrivate = 3; mExported = 4;
947 (* sig.par[].id MOD 16 *)
948 mValue = 10; mInPar = 11; mOutPar = 12; mVarPar = 13;
949 mInterface = 32; mGuid = 33; mResult = 34;
950 (* implementation restrictions *)
951 maxPars = 127;
952 maxStrs = 127;
953 maxElms = 256;
954 TYPE
955 Ptype = POINTER TO LibFFI.type;
956 PPtype = POINTER TO ARRAY [untagged] OF Ptype;
957 VAR
958 status: LibFFI.status;
959 kind, form, size: INTEGER;
960 i, p, d, cn, ut, ue: INTEGER;
961 fret: Ptype;
962 vret: LONGINT;
963 earg: ARRAY maxElms OF Ptype;
964 targ: ARRAY maxStrs OF LibFFI.type;
965 farg: ARRAY maxPars OF Ptype;
966 varg: ARRAY maxPars OF ADDRESS;
967 typ: Type;
968 cif: LibFFI.cif;
969
970 PROCEDURE SetType (IN typ: LibFFI.type);
971 BEGIN
972 farg[cn] := S.VAL(Ptype, S.ADR(typ));
973 END SetType;
974
975 PROCEDURE PushAdr (size: INTEGER);
976 BEGIN
977 ASSERT(size IN {1, 2, 4, 8}, 20);
978 ASSERT(littleEndian OR (size <= 4), 100); (* !!! swap 64bit value *)
979 varg[cn] := S.ADR(par[d]);
980 INC(cn); INC(d, MAX(1, size DIV 4))
981 END PushAdr;
982
983 PROCEDURE PushVal (size: INTEGER);
984 BEGIN
985 ASSERT(size IN {1, 2, 4, 8}, 20);
986 ASSERT(littleEndian OR (size <= 4), 100); (* !!! swap 64bit value *)
987 varg[cn] := par[d];
988 INC(cn); INC(d, MAX(1, size DIV 4))
989 END PushVal;
990
991 PROCEDURE Push (IN typ: LibFFI.type);
992 BEGIN
993 SetType(typ); PushAdr(typ.size)
994 END Push;
995
996 BEGIN
997 p := 0; cn := 0; d := 0; ut := 0; ue := 0;
998 WHILE p < sig.num DO
999 typ := sig.par[p].struct;
1000 kind := sig.par[p].id MOD 16;
1001 IF S.VAL(ADDRESS, typ) DIV 256 = 0 THEN (* basic types *)
1002 form := S.VAL(ADDRESS, typ) MOD 256;
1003 IF kind = mValue THEN
1004 CASE form OF
1005 | mBool, mChar8: Push(LibFFI.type_uint8)
1006 | mChar16: Push(LibFFI.type_uint16)
1007 | mInt8: Push(LibFFI.type_sint8)
1008 | mInt16: Push(LibFFI.type_sint16)
1009 | mInt32: Push(LibFFI.type_sint32)
1010 | mReal32: Push(LibFFI.type_float)
1011 | mReal64: Push(LibFFI.type_double)
1012 | mSet: Push(LibFFI.type_uint32)
1013 | mInt64: Push(LibFFI.type_sint64)
1014 | mAnyPtr, mSysPtr: Push(LibFFI.type_pointer)
1015 ELSE HALT(100) (* unsupported type *)
1016 END;
1017 ELSIF kind IN {mInPar..mVarPar} THEN
1018 CASE form OF
1019 | mBool..mInt64, mAnyPtr, mSysPtr: Push(LibFFI.type_pointer)
1020 | mAnyRec: Push(LibFFI.type_pointer); Push(LibFFI.type_pointer) (* address + tag *)
1021 ELSE HALT(101) (* unsupported type *)
1022 END
1023 ELSE
1024 HALT(102) (* unsupported parameter kind *)
1025 END
1026 ELSE
1027 CASE typ.id MOD 4 OF
1028 | mProctyp, mPointer:
1029 Push(LibFFI.type_pointer)
1030 | mRecord:
1031 IF kind = mValue THEN
1032 targ[ut].size := 0;
1033 targ[ut].alignment := 0;
1034 targ[ut].type := LibFFI.TYPE_STRUCT;
1035 targ[ut].elements := S.VAL(PPtype, S.ADR(earg[ue]));
1036 SetType(targ[ut]); INC(ut);
1037 size := MAX(1, typ.size);
1038 (* !!! better to pass original layout *)
1039 WHILE size >= 8 DO
1040 earg[ue] := S.VAL(Ptype, S.ADR(LibFFI.type_uint64));
1041 INC(ue); DEC(size, 8)
1042 END;
1043 IF size >= 4 THEN
1044 earg[ue] := S.VAL(Ptype, S.ADR(LibFFI.type_uint32));
1045 INC(ue); DEC(size, 4)
1046 END;
1047 IF size >= 2 THEN
1048 earg[ue] := S.VAL(Ptype, S.ADR(LibFFI.type_uint16));
1049 INC(ue); DEC(size, 2)
1050 END;
1051 IF size >= 1 THEN
1052 earg[ue] := S.VAL(Ptype, S.ADR(LibFFI.type_uint32));
1053 INC(ue); DEC(size)
1054 END;
1055 earg[ue] := NIL;
1056 INC(ue);
1057 PushVal(LibFFI.type_pointer.size);
1058 INC(d) (* skip tag *)
1059 ELSIF kind IN {mInPar..mVarPar} THEN
1060 Push(LibFFI.type_pointer); (* address *)
1061 Push(LibFFI.type_pointer); (* tag *)
1062 ELSE HALT(103) (* unsupported parameter kind *)
1063 END
1064 | mArray:
1065 Push(LibFFI.type_pointer);
1066 ASSERT(kind IN {mValue..mVarPar}, 104); (* unsupported parameter kind *)
1067 (* array copying generated by CPfront, so we can just pass address *)
1068 IF typ.size = 0 THEN (* open array *)
1069 FOR i := 0 TO typ.id DIV 16 - 1 DO
1070 Push(LibFFI.type_sint32) (* dim size *)
1071 END
1072 ELSE (* fix array *)
1073 INC(d) (* skip size *)
1074 END
1075 END
1076 END;
1077 INC(p)
1078 END;
1079 ASSERT(d = n, 105);
1080 typ := sig.retStruct;
1081 IF typ = NIL THEN fret := S.VAL(Ptype, S.ADR(LibFFI.type_void))
1082 ELSIF S.VAL(ADDRESS, typ) DIV 256 = 0 THEN
1083 form := S.VAL(ADDRESS, typ) MOD 256;
1084 CASE form OF
1085 | mBool, mChar8: fret := S.VAL(Ptype, S.ADR(LibFFI.type_uint8))
1086 | mChar16: fret := S.VAL(Ptype, S.ADR(LibFFI.type_uint16))
1087 | mInt8: fret := S.VAL(Ptype, S.ADR(LibFFI.type_sint8))
1088 | mInt16: fret := S.VAL(Ptype, S.ADR(LibFFI.type_sint16))
1089 | mInt32: fret := S.VAL(Ptype, S.ADR(LibFFI.type_sint32))
1090 | mReal32: fret := S.VAL(Ptype, S.ADR(LibFFI.type_float))
1091 | mReal64: fret := S.VAL(Ptype, S.ADR(LibFFI.type_double))
1092 | mSet: fret := S.VAL(Ptype, S.ADR(LibFFI.type_uint32))
1093 | mInt64: fret := S.VAL(Ptype, S.ADR(LibFFI.type_sint64))
1094 | mAnyPtr, mSysPtr: fret := S.VAL(Ptype, S.ADR(LibFFI.type_pointer))
1095 ELSE HALT(106) (* unsupported type *)
1096 END
1097 ELSE
1098 CASE typ.id MOD 4 OF
1099 | mProctyp, mPointer: fret := S.VAL(Ptype, S.ADR(LibFFI.type_pointer))
1100 ELSE HALT(107) (* unsupported type *)
1101 END
1102 END;
1103 status := LibFFI.prep_cif(cif, LibFFI.DEFAULT_ABI, cn, fret, farg);
1104 ASSERT(status = LibFFI.OK, 108);
1105 vret := 0;
1106 IF littleEndian THEN LibFFI.call(cif, adr, S.ADR(vret), S.ADR(varg))
1107 ELSE LibFFI.call(cif, adr, S.ADR(vret) + (8 - fret.size), S.ADR(varg))
1108 END;
1109 RETURN vret
1110 END Call;
1111
1112 (* -------------------- reference information (portable) --------------------- *)
1113
1114 PROCEDURE RefCh (VAR ref: INTEGER; OUT ch: SHORTCHAR);
1115 BEGIN
1116 S.GET(ref, ch); INC(ref)
1117 END RefCh;
1118
1119 PROCEDURE RefNum (VAR ref: INTEGER; OUT x: INTEGER);
1120 VAR s, n: INTEGER; ch: SHORTCHAR;
1121 BEGIN
1122 s := 0; n := 0; RefCh(ref, ch);
1123 WHILE ORD(ch) >= 128 DO INC(n, ASH(ORD(ch) - 128, s) ); INC(s, 7); RefCh(ref, ch) END;
1124 x := n + ASH(ORD(ch) MOD 64 - ORD(ch) DIV 64 * 64, s)
1125 END RefNum;
1126
1127 PROCEDURE RefName (VAR ref: INTEGER; OUT n: Utf8Name);
1128 VAR i: INTEGER; ch: SHORTCHAR;
1129 BEGIN
1130 i := 0; RefCh(ref, ch);
1131 WHILE ch # 0X DO n[i] := ch; INC(i); RefCh(ref, ch) END;
1132 n[i] := 0X
1133 END RefName;
1134
1135 PROCEDURE GetRefProc* (VAR ref: INTEGER; OUT adr: INTEGER; OUT name: Utf8Name);
1136 VAR ch: SHORTCHAR;
1137 BEGIN
1138 S.GET(ref, ch);
1139 WHILE ch >= 0FDX DO (* skip variables *)
1140 INC(ref); RefCh(ref, ch);
1141 IF ch = 10X THEN INC(ref, 4) END;
1142 RefNum(ref, adr); RefName(ref, name); S.GET(ref, ch)
1143 END;
1144 WHILE (ch > 0X) & (ch < 0FCX) DO (* skip source refs *)
1145 INC(ref); RefNum(ref, adr); S.GET(ref, ch)
1146 END;
1147 IF ch = 0FCX THEN INC(ref); RefNum(ref, adr); RefName(ref, name)
1148 ELSE adr := 0
1149 END
1150 END GetRefProc;
1151
1152 PROCEDURE GetRefVar* (VAR ref: INTEGER; OUT mode, form: SHORTCHAR; OUT desc: Type; OUT adr: INTEGER; OUT name: Utf8Name);
1153 BEGIN
1154 S.GET(ref, mode); desc := NIL;
1155 IF mode >= 0FDX THEN
1156 mode := SHORT(CHR(ORD(mode) - 0FCH));
1157 INC(ref); RefCh(ref, form);
1158 IF form = 10X THEN
1159 S.GET(ref, desc); INC(ref, 4); form := SHORT(CHR(16 + desc.id MOD 4))
1160 END;
1161 RefNum(ref, adr); RefName(ref, name)
1162 ELSE
1163 mode := 0X; form := 0X; adr := 0
1164 END
1165 END GetRefVar;
1166
1167 PROCEDURE SourcePos* (mod: Module; codePos: INTEGER): INTEGER;
1168 VAR ref, pos, ad, d: INTEGER; ch: SHORTCHAR; name: Utf8Name;
1169 BEGIN
1170 IF mod # NIL THEN (* mf, 12.02.04 *)
1171 ref := mod.refs; pos := 0; ad := 0; S.GET(ref, ch);
1172 WHILE ch # 0X DO
1173 WHILE (ch > 0X) & (ch < 0FCX) DO (* srcref: {dAdr,dPos} *)
1174 INC(ad, ORD(ch)); INC(ref); RefNum(ref, d);
1175 IF ad > codePos THEN RETURN pos END;
1176 INC(pos, d); S.GET(ref, ch)
1177 END;
1178 IF ch = 0FCX THEN (* proc: 0FCX,Adr,Name *)
1179 INC(ref); RefNum(ref, d); RefName(ref, name); S.GET(ref, ch);
1180 IF (d > codePos) & (pos > 0) THEN RETURN pos END
1181 END;
1182 WHILE ch >= 0FDX DO (* skip variables: Mode, Form, adr, Name *)
1183 INC(ref); RefCh(ref, ch);
1184 IF ch = 10X THEN INC(ref, 4) END;
1185 RefNum(ref, d); RefName(ref, name); S.GET(ref, ch)
1186 END
1187 END;
1188 END;
1189 RETURN -1
1190 END SourcePos;
1191
1192 PROCEDURE LoadDll* (IN name: ARRAY OF CHAR; VAR ok: BOOLEAN);
1193 VAR h: ADDRESS; file: Utf8Name; res: INTEGER;
1194 BEGIN
1195 StringToUtf8(name, file, res);
1196 IF res = 0 THEN
1197 h := dlfcn.dlopen(file, dlfcn.RTLD_LAZY + dlfcn.RTLD_GLOBAL);
1198 ok := h # 0
1199 ELSE
1200 ok := FALSE
1201 END
1202 END LoadDll;
1203
1204 PROCEDURE ThisDllObj* (mode, fprint: INTEGER; IN dll, name: ARRAY OF CHAR): INTEGER;
1205 VAR h, p: ADDRESS; file, sym: Utf8Name; res: INTEGER; err: dlfcn.int;
1206 BEGIN
1207 StringToUtf8(dll, file, res);
1208 IF res = 0 THEN
1209 h := dlfcn.dlopen(file, dlfcn.RTLD_LAZY + dlfcn.RTLD_GLOBAL);
1210 IF h # 0 THEN
1211 StringToUtf8(name, sym, res);
1212 IF res = 0 THEN
1213 p := dlfcn.dlsym(h, sym)
1214 ELSE
1215 p := 0
1216 END;
1217 err := dlfcn.dlclose(h);
1218 ASSERT(err = 0, 100)
1219 ELSE
1220 p := 0
1221 END
1222 ELSE
1223 p := 0
1224 END;
1225 RETURN p
1226 END ThisDllObj;
1227
1228 (* -------------------- garbage collector (portable) --------------------- *)
1229
1230 PROCEDURE Mark (this: Block);
1231 VAR father, son: Block; tag: Type; flag, offset, actual: INTEGER;
1232 BEGIN
1233 IF ~ODD(S.VAL(INTEGER, this.tag)) THEN
1234 father := NIL;
1235 LOOP
1236 INC(S.VAL(INTEGER, this.tag));
1237 flag := S.VAL(INTEGER, this.tag) MOD 4;
1238 tag := S.VAL(Type, S.VAL(INTEGER, this.tag) - flag);
1239 IF flag >= 2 THEN actual := this.first; this.actual := actual
1240 ELSE actual := S.ADR(this.last)
1241 END;
1242 LOOP
1243 offset := tag.ptroffs[0];
1244 IF offset < 0 THEN
1245 INC(S.VAL(INTEGER, tag), offset + 4); (* restore tag *)
1246 IF (flag >= 2) & (actual < this.last) & (offset < -4) THEN (* next array element *)
1247 INC(actual, tag.size); this.actual := actual
1248 ELSE (* up *)
1249 this.tag := S.VAL(Type, S.VAL(INTEGER, tag) + flag);
1250 IF father = NIL THEN RETURN END;
1251 son := this; this := father;
1252 flag := S.VAL(INTEGER, this.tag) MOD 4;
1253 tag := S.VAL(Type, S.VAL(INTEGER, this.tag) - flag);
1254 offset := tag.ptroffs[0];
1255 IF flag >= 2 THEN actual := this.actual ELSE actual := S.ADR(this.last) END;
1256 S.GET(actual + offset, father); S.PUT(actual + offset, S.ADR(son.last));
1257 INC(S.VAL(INTEGER, tag), 4)
1258 END
1259 ELSE
1260 S.GET(actual + offset, son);
1261 IF son # NIL THEN
1262 DEC(S.VAL(INTEGER, son), 4);
1263 IF ~ODD(S.VAL(INTEGER, son.tag)) THEN (* down *)
1264 this.tag := S.VAL(Type, S.VAL(INTEGER, tag) + flag);
1265 S.PUT(actual + offset, father); father := this; this := son;
1266 EXIT
1267 END
1268 END;
1269 INC(S.VAL(INTEGER, tag), 4)
1270 END
1271 END
1272 END
1273 END
1274 END Mark;
1275
1276 PROCEDURE MarkGlobals;
1277 VAR m: Module; i, p: INTEGER;
1278 BEGIN
1279 m := modList;
1280 WHILE m # NIL DO
1281 IF m.refcnt >= 0 THEN
1282 i := 0;
1283 WHILE i < m.nofptrs DO
1284 S.GET(m.varBase + m.ptrs[i], p); INC(i);
1285 IF p # 0 THEN Mark(S.VAL(Block, p - 4)) END
1286 END
1287 END;
1288 m := m.next
1289 END
1290 END MarkGlobals;
1291
1292 PROCEDURE Next (b: Block): Block; (* next block in same cluster *)
1293 VAR size: INTEGER;
1294 BEGIN
1295 S.GET(S.VAL(INTEGER, b.tag) DIV 4 * 4, size);
1296 IF ODD(S.VAL(INTEGER, b.tag) DIV 2) THEN INC(size, b.last - S.ADR(b.last)) END;
1297 RETURN S.VAL(Block, S.VAL(INTEGER, b) + (size + 19) DIV 16 * 16)
1298 END Next;
1299
1300 PROCEDURE CheckCandidates;
1301 (* pre: nofcand > 0 *)
1302 VAR i, j, h, p, end: INTEGER; c: Cluster; blk, next: Block;
1303 BEGIN
1304 (* sort candidates (shellsort) *)
1305 h := 1; REPEAT h := h*3 + 1 UNTIL h > nofcand;
1306 REPEAT h := h DIV 3; i := h;
1307 WHILE i < nofcand DO p := candidates[i]; j := i;
1308 WHILE (j >= h) & (candidates[j-h] > p) DO
1309 candidates[j] := candidates[j-h]; j := j-h
1310 END;
1311 candidates[j] := p; INC(i)
1312 END
1313 UNTIL h = 1;
1314 (* sweep *)
1315 c := root; i := 0;
1316 WHILE c # NIL DO
1317 blk := S.VAL(Block, S.VAL(INTEGER, c) + 12);
1318 end := S.VAL(INTEGER, blk) + (c.size - 12) DIV 16 * 16;
1319 WHILE candidates[i] < S.VAL(INTEGER, blk) DO
1320 INC(i);
1321 IF i = nofcand THEN RETURN END
1322 END;
1323 WHILE S.VAL(INTEGER, blk) < end DO
1324 next := Next(blk);
1325 IF candidates[i] < S.VAL(INTEGER, next) THEN
1326 IF (S.VAL(INTEGER, blk.tag) # S.ADR(blk.last)) (* not a free block *)
1327 & (~strictStackSweep OR (candidates[i] = S.ADR(blk.last))) THEN
1328 Mark(blk)
1329 END;
1330 REPEAT
1331 INC(i);
1332 IF i = nofcand THEN RETURN END
1333 UNTIL candidates[i] >= S.VAL(INTEGER, next)
1334 END;
1335 IF (S.VAL(INTEGER, blk.tag) MOD 4 = 0) & (S.VAL(INTEGER, blk.tag) # S.ADR(blk.last))
1336 & (blk.tag.base[0] = NIL) & (blk.actual > 0) THEN (* referenced interface record *)
1337 Mark(blk)
1338 END;
1339 blk := next
1340 END;
1341 c := c.next
1342 END
1343 END CheckCandidates;
1344
1345 PROCEDURE MarkLocals;
1346 VAR sp, p, min, max: INTEGER; c: Cluster;
1347 BEGIN
1348 sp := S.ADR(sp); nofcand := 0; c := root;
1349 WHILE c.next # NIL DO c := c.next END;
1350 min := S.VAL(INTEGER, root); max := S.VAL(INTEGER, c) + c.size;
1351 WHILE sp < baseStack DO
1352 S.GET(sp, p);
1353 IF (p > min) & (p < max) & (~strictStackSweep OR (p MOD 16 = 0)) THEN
1354 candidates[nofcand] := p; INC(nofcand);
1355 IF nofcand = LEN(candidates) - 1 THEN CheckCandidates; nofcand := 0 END
1356 END;
1357 INC(sp, 4)
1358 END;
1359 candidates[nofcand] := max; INC(nofcand); (* ensure complete scan for interface mark*)
1360 IF nofcand > 0 THEN CheckCandidates END
1361 END MarkLocals;
1362
1363 PROCEDURE MarkFinObj;
1364 VAR f: FList;
1365 BEGIN
1366 wouldFinalize := FALSE;
1367 f := finalizers;
1368 WHILE f # NIL DO
1369 IF ~ODD(S.VAL(INTEGER, f.blk.tag)) THEN wouldFinalize := TRUE END;
1370 Mark(f.blk);
1371 f := f.next
1372 END;
1373 f := hotFinalizers;
1374 WHILE f # NIL DO IF ~ODD(S.VAL(INTEGER, f.blk.tag)) THEN wouldFinalize := TRUE END;
1375 Mark(f.blk);
1376 f := f.next
1377 END
1378 END MarkFinObj;
1379
1380 PROCEDURE CheckFinalizers;
1381 VAR f, g, h, k: FList;
1382 BEGIN
1383 f := finalizers; g := NIL;
1384 IF hotFinalizers = NIL THEN k := NIL
1385 ELSE
1386 k := hotFinalizers;
1387 WHILE k.next # NIL DO k := k.next END
1388 END;
1389 WHILE f # NIL DO
1390 h := f; f := f.next;
1391 IF ~ODD(S.VAL(INTEGER, h.blk.tag)) THEN
1392 IF g = NIL THEN finalizers := f ELSE g.next := f END;
1393 IF k = NIL THEN hotFinalizers := h ELSE k.next := h END;
1394 k := h; h.next := NIL
1395 ELSE g := h
1396 END
1397 END;
1398 h := hotFinalizers;
1399 WHILE h # NIL DO Mark(h.blk); h := h.next END
1400 END CheckFinalizers;
1401
1402 PROCEDURE ExecFinalizer (a, b, c: INTEGER);
1403 VAR f: FList; fin: PROCEDURE(this: ANYPTR);
1404 BEGIN
1405 f := S.VAL(FList, a);
1406 S.GET(S.VAL(INTEGER, f.blk.tag) - 4, fin); (* method 0 *)
1407 IF (fin # NIL) & (f.blk.tag.mod.refcnt >= 0) THEN fin(S.VAL(ANYPTR, S.ADR(f.blk.last))) END;
1408 END ExecFinalizer;
1409
1410 PROCEDURE^ Try* (h: TryHandler; a, b, c: INTEGER); (* COMPILER DEPENDENT *)
1411
1412 PROCEDURE CallFinalizers;
1413 VAR f: FList;
1414 BEGIN
1415 WHILE hotFinalizers # NIL DO
1416 f := hotFinalizers; hotFinalizers := hotFinalizers.next;
1417 Try(ExecFinalizer, S.VAL(INTEGER, f), 0, 0)
1418 END;
1419 wouldFinalize := FALSE
1420 END CallFinalizers;
1421
1422 PROCEDURE Insert (blk: FreeBlock; size: INTEGER); (* insert block in free list *)
1423 VAR i: INTEGER;
1424 BEGIN
1425 blk.size := size - 4; blk.tag := S.VAL(Type, S.ADR(blk.size));
1426 i := MIN(N - 1, (blk.size DIV 16));
1427 blk.next := free[i]; free[i] := blk
1428 END Insert;
1429
1430 PROCEDURE Sweep (dealloc: BOOLEAN);
1431 VAR cluster, last, c: Cluster; blk, next: Block; fblk, b, t: FreeBlock; end, i: INTEGER;
1432 BEGIN
1433 cluster := root; last := NIL; allocated := 0;
1434 i := N;
1435 REPEAT DEC(i); free[i] := sentinel UNTIL i = 0;
1436 WHILE cluster # NIL DO
1437 blk := S.VAL(Block, S.VAL(INTEGER, cluster) + 12);
1438 end := S.VAL(INTEGER, blk) + (cluster.size - 12) DIV 16 * 16;
1439 fblk := NIL;
1440 WHILE S.VAL(INTEGER, blk) < end DO
1441 next := Next(blk);
1442 IF ODD(S.VAL(INTEGER, blk.tag)) THEN
1443 IF fblk # NIL THEN
1444 Insert(fblk, S.VAL(INTEGER, blk) - S.VAL(INTEGER, fblk));
1445 fblk := NIL
1446 END;
1447 DEC(S.VAL(INTEGER, blk.tag)); (* unmark *)
1448 INC(allocated, S.VAL(INTEGER, next) - S.VAL(INTEGER, blk))
1449 ELSIF fblk = NIL THEN
1450 fblk := S.VAL(FreeBlock, blk)
1451 END;
1452 blk := next
1453 END;
1454 IF dealloc & (S.VAL(INTEGER, fblk) = S.VAL(INTEGER, cluster) + 12) THEN (* deallocate cluster *)
1455 c := cluster; cluster := cluster.next;
1456 IF last = NIL THEN root := cluster ELSE last.next := cluster END;
1457 FreeHeapMem(c)
1458 ELSE
1459 IF fblk # NIL THEN Insert(fblk, end - S.VAL(INTEGER, fblk)) END;
1460 last := cluster; cluster := cluster.next
1461 END
1462 END;
1463 (* reverse free list *)
1464 i := N;
1465 REPEAT
1466 DEC(i);
1467 b := free[i]; fblk := sentinel;
1468 WHILE b # sentinel DO t := b; b := t.next; t.next := fblk; fblk := t END;
1469 free[i] := fblk
1470 UNTIL i = 0
1471 END Sweep;
1472
1473 PROCEDURE Collect*;
1474 BEGIN
1475 IF root # NIL THEN
1476 CallFinalizers; (* trap cleanup *)
1477 MarkGlobals;
1478 MarkLocals;
1479 CheckFinalizers;
1480 Sweep(TRUE);
1481 CallFinalizers
1482 END
1483 END Collect;
1484
1485 PROCEDURE FastCollect*;
1486 BEGIN
1487 IF root # NIL THEN
1488 MarkGlobals;
1489 MarkLocals;
1490 MarkFinObj;
1491 Sweep(FALSE)
1492 END
1493 END FastCollect;
1494
1495 PROCEDURE WouldFinalize* (): BOOLEAN;
1496 BEGIN
1497 RETURN wouldFinalize
1498 END WouldFinalize;
1499
1500 (* --------------------- memory allocation (portable) -------------------- *)
1501
1502 PROCEDURE OldBlock (size: INTEGER): FreeBlock; (* size MOD 16 = 0 *)
1503 VAR b, l: FreeBlock; s, i: INTEGER;
1504 BEGIN
1505 s := size - 4;
1506 i := MIN(N - 1, s DIV 16);
1507 WHILE (i # N - 1) & (free[i] = sentinel) DO INC(i) END;
1508 b := free[i]; l := NIL;
1509 WHILE b.size < s DO l := b; b := b.next END;
1510 IF b # sentinel THEN
1511 IF l = NIL THEN free[i] := b.next ELSE l.next := b.next END
1512 ELSE b := NIL
1513 END;
1514 RETURN b
1515 END OldBlock;
1516
1517 PROCEDURE LastBlock (limit: INTEGER): FreeBlock; (* size MOD 16 = 0 *)
1518 VAR b, l: FreeBlock; s, i: INTEGER;
1519 BEGIN
1520 s := limit - 4;
1521 i := 0;
1522 REPEAT
1523 b := free[i]; l := NIL;
1524 WHILE (b # sentinel) & (S.VAL(INTEGER, b) + b.size # s) DO l := b; b := b.next END;
1525 IF b # sentinel THEN
1526 IF l = NIL THEN free[i] := b.next ELSE l.next := b.next END
1527 ELSE b := NIL
1528 END;
1529 INC(i)
1530 UNTIL (b # NIL) OR (i = N);
1531 RETURN b
1532 END LastBlock;
1533
1534 PROCEDURE NewBlock (size: INTEGER): Block;
1535 VAR tsize, a, s: INTEGER; b: FreeBlock; new, c: Cluster; r: Reducer;
1536 BEGIN
1537 ASSERT(size >= 0, 20);
1538 IF size > MAX(INTEGER) - 19 THEN RETURN NIL END;
1539 tsize := (size + 19) DIV 16 * 16;
1540 b := OldBlock(tsize); (* 1) search for free block *)
1541 IF b = NIL THEN
1542 FastCollect; b := OldBlock(tsize); (* 2) collect *)
1543 IF b = NIL THEN
1544 Collect; b := OldBlock(tsize); (* 2a) fully collect *)
1545 END;
1546 IF b = NIL THEN
1547 AllocHeapMem(tsize + 12, new); (* 3) allocate new cluster *)
1548 IF new # NIL THEN
1549 IF (root = NIL) OR (S.VAL(INTEGER, new) < S.VAL(INTEGER, root)) THEN
1550 new.next := root; root := new
1551 ELSE
1552 c := root;
1553 WHILE (c.next # NIL) & (S.VAL(INTEGER, new) > S.VAL(INTEGER, c.next)) DO c := c.next END;
1554 new.next := c.next; c.next := new
1555 END;
1556 b := S.VAL(FreeBlock, S.VAL(INTEGER, new) + 12);
1557 b.size := (new.size - 12) DIV 16 * 16 - 4
1558 ELSE
1559 RETURN NIL (* 4) give up *)
1560 END
1561 END
1562 END;
1563 (* b # NIL *)
1564 a := b.size + 4 - tsize;
1565 IF a > 0 THEN Insert(S.VAL(FreeBlock, S.VAL(INTEGER, b) + tsize), a) END;
1566 IF size > 0 THEN Erase(S.ADR(b.size), (size + 3) DIV 4) END;
1567 INC(allocated, tsize);
1568 RETURN S.VAL(Block, b)
1569 END NewBlock;
1570
1571 PROCEDURE Allocated* (): INTEGER;
1572 BEGIN
1573 RETURN allocated
1574 END Allocated;
1575
1576 PROCEDURE Used* (): INTEGER;
1577 BEGIN
1578 RETURN used
1579 END Used;
1580
1581 PROCEDURE Root* (): INTEGER;
1582 BEGIN
1583 RETURN S.VAL(INTEGER, root)
1584 END Root;
1585
1586 (* -------------------- Trap Handling --------------------- *)
1587
1588 PROCEDURE [code] GetDLink (): DLink "(Kernel_DLink)SYSTEM_dlink";
1589 PROCEDURE [code] SetDLink (dl: DLink) "SYSTEM_dlink = (SYSTEM_DLINK*)dl";
1590
1591 PROCEDURE Start* (code: Command);
1592 VAR res: setjmp.int; dl: DLink;
1593 BEGIN
1594 restart := code;
1595 baseStack := S.ADR(code); (* XXX: expected that target uses one stack *)
1596 startDLink := GetDLink();
1597 res := setjmp.sigsetjmp(startEnv, 1);
1598 restart
1599 END Start;
1600
1601 PROCEDURE Quit* (exitCode: INTEGER);
1602 VAR m: Module; term: Command; t: BOOLEAN;
1603 BEGIN
1604 trapViewer := NIL; trapChecker := NIL; restart := NIL;
1605 t := terminating; terminating := TRUE; m := modList;
1606 WHILE m # NIL DO (* call terminators *)
1607 IF ~static OR ~t THEN
1608 term := m.term; m.term := NIL;
1609 IF term # NIL THEN term() END
1610 END;
1611 m := m.next
1612 END;
1613 CallFinalizers;
1614 hotFinalizers := finalizers; finalizers := NIL;
1615 CallFinalizers;
1616 stdlib.exit(exitCode)
1617 END Quit;
1618
1619 PROCEDURE FatalError* (id: INTEGER; str: ARRAY OF CHAR);
1620 VAR res: stdio.int; title: ARRAY 16 OF CHAR; text: ARRAY 256 OF SHORTCHAR;
1621 BEGIN
1622 title := "Error xy";
1623 title[6] := CHR(id DIV 10 + ORD("0"));
1624 title[7] := CHR(id MOD 10 + ORD("0"));
1625 res := unistd.write(2, S.ADR(title), 8);
1626 stdlib.abort
1627 END FatalError;
1628
1629 PROCEDURE DefaultTrapViewer;
1630 VAR out: ARRAY 256 OF SHORTCHAR; c, len: INTEGER; res: unistd.int; dl: DLink;
1631
1632 PROCEDURE WriteString (IN s: ARRAY OF SHORTCHAR);
1633 VAR i: INTEGER;
1634 BEGIN
1635 i := 0;
1636 WHILE (len < LEN(out) - 1) & (s[i] # 0X) DO out[len] := s[i]; INC(i); INC(len) END
1637 END WriteString;
1638
1639 PROCEDURE WriteHex (x, n: INTEGER);
1640 VAR i, y: INTEGER;
1641 BEGIN
1642 IF len + n < LEN(out) THEN
1643 i := len + n - 1;
1644 WHILE i >= len DO
1645 y := x MOD 16; x := x DIV 16;
1646 IF y > 9 THEN y := y + (ORD("A") - ORD("0") - 10) END;
1647 out[i] := SHORT(CHR(y + ORD("0"))); DEC(i)
1648 END;
1649 INC(len, n)
1650 END
1651 END WriteHex;
1652
1653 PROCEDURE WriteLn;
1654 BEGIN
1655 IF len < LEN(out) - 1 THEN out[len] := 0AX; INC(len) END
1656 END WriteLn;
1657
1658 BEGIN
1659 len := 0;
1660 WriteString("====== ");
1661 IF err = 129 THEN WriteString("invalid with")
1662 ELSIF err = 130 THEN WriteString("invalid case")
1663 ELSIF err = 131 THEN WriteString("function without return")
1664 ELSIF err = 132 THEN WriteString("type guard")
1665 ELSIF err = 133 THEN WriteString("implied type guard")
1666 ELSIF err = 134 THEN WriteString("value out of range")
1667 ELSIF err = 135 THEN WriteString("index out of range")
1668 ELSIF err = 136 THEN WriteString("string too long")
1669 ELSIF err = 137 THEN WriteString("stack overflow")
1670 ELSIF err = 138 THEN WriteString("integer overflow")
1671 ELSIF err = 139 THEN WriteString("division by zero")
1672 ELSIF err = 140 THEN WriteString("infinite real result")
1673 ELSIF err = 141 THEN WriteString("real underflow")
1674 ELSIF err = 142 THEN WriteString("real overflow")
1675 ELSIF err = 143 THEN WriteString("undefined real result")
1676 ELSIF err = 144 THEN WriteString("not a number")
1677 ELSIF err = 200 THEN WriteString("keyboard interrupt")
1678 ELSIF err = 201 THEN WriteString("NIL dereference")
1679 ELSIF err = 202 THEN WriteString("illegal instruction: ");
1680 WriteHex(val, 4)
1681 ELSIF err = 203 THEN WriteString("illegal memory read [ad = ");
1682 WriteHex(val, 8); WriteString("]")
1683 ELSIF err = 204 THEN WriteString("illegal memory write [ad = ");
1684 WriteHex(val, 8); WriteString("]")
1685 ELSIF err = 205 THEN WriteString("illegal execution [ad = ");
1686 WriteHex(val, 8); WriteString("]")
1687 ELSIF err = 257 THEN WriteString("out of memory")
1688 ELSIF err = 10001H THEN WriteString("bus error")
1689 ELSIF err = 10002H THEN WriteString("address error")
1690 ELSIF err = 10007H THEN WriteString("fpu error")
1691 ELSIF err < 0 THEN WriteString("exception #"); WriteHex(-err, 2)
1692 ELSE err := err DIV 100 * 256 + err DIV 10 MOD 10 * 16 + err MOD 10;
1693 WriteString("trap #"); WriteHex(err, 3)
1694 END;
1695 WriteString(" ======");
1696 WriteLn;
1697 dl := GetDLink();
1698 (* skip Kernel.DefaultTrapViewer & Kernel.Trap/Kernel.TrapHandler *)
1699 c := 2;
1700 WHILE (c > 0) & (dl # NIL) DO
1701 dl := dl.next;
1702 DEC(c)
1703 END;
1704 (* stack trace *)
1705 c := 16;
1706 WHILE (c > 0) & (dl # NIL) DO
1707 WriteString("- "); WriteString(dl.name$); WriteLn;
1708 dl := dl.next;
1709 DEC(c)
1710 END;
1711 out[len] := 0X;
1712 res := unistd.write(2, S.ADR(out), len)
1713 END DefaultTrapViewer;
1714
1715 PROCEDURE TrapCleanup;
1716 VAR t: TrapCleaner;
1717 BEGIN
1718 WHILE trapStack # NIL DO
1719 t := trapStack; trapStack := trapStack.next; t.Cleanup
1720 END;
1721 IF (trapChecker # NIL) & (err # 128) THEN trapChecker END
1722 END TrapCleanup;
1723
1724 PROCEDURE SetTrapGuard* (on: BOOLEAN);
1725 BEGIN
1726 guarded := on
1727 END SetTrapGuard;
1728
1729 PROCEDURE Try* (h: TryHandler; a, b, c: INTEGER);
1730 VAR oldIsTry: BOOLEAN; oldTryEnv: setjmp.jmp_buf; oldTryDLink: DLink; res: setjmp.int;
1731 BEGIN
1732 oldIsTry := isTry; oldTryEnv := tryEnv; oldTryDLink := tryDLink;
1733 isTry := TRUE; tryDLink := GetDLink();
1734 res := setjmp._setjmp(tryEnv);
1735 IF res = 0 THEN h(a, b, c) END;
1736 isTry := oldIsTry; tryEnv := oldTryEnv; tryDLink := oldTryDLink
1737 END Try;
1738
1739 PROCEDURE Trap* (n: INTEGER);
1740 BEGIN
1741 IF trapped THEN
1742 DefaultTrapViewer;
1743 IF ~secondTrap THEN trapped := FALSE; secondTrap := TRUE END
1744 END;
1745 IF n >= 0 THEN err := n
1746 ELSE err := -n + 128
1747 END;
1748 pc := 0; sp := 0; fp := 0; stack := 0; val := 0;
1749 INC(trapCount);
1750 (* !!! InitFPU *)
1751 TrapCleanup;
1752 IF isTry THEN
1753 SetDLink(tryDLink);
1754 setjmp._longjmp(tryEnv, 1)
1755 END;
1756 IF (err = 128) OR (err = 200) & ~intTrap THEN (* do nothing *)
1757 ELSIF (trapViewer # NIL) & (restart # NIL) & ~trapped & ~guarded THEN
1758 trapped := TRUE; trapViewer()
1759 ELSE DefaultTrapViewer
1760 END;
1761 trapped := FALSE; secondTrap := FALSE;
1762 IF restart # NIL THEN
1763 SetDLink(startDLink);
1764 setjmp.siglongjmp(startEnv, 1)
1765 END;
1766 stdlib.abort
1767 END Trap;
1768
1769 PROCEDURE [ccall] TrapHandler (signo: signal.int; IN info: signal.siginfo_t; context: ADDRESS);
1770 VAR res: signal.int;
1771 BEGIN
1772 IF checkReadable THEN
1773 setjmp.siglongjmp(checkReadableEnv, 1)
1774 END;
1775 IF trapped THEN
1776 DefaultTrapViewer;
1777 IF ~secondTrap THEN trapped := FALSE; secondTrap := TRUE END
1778 END;
1779 err := -signo; pc := 0; sp := 0; fp := 0; stack := baseStack; val := 0;
1780 CASE signo OF
1781 | signal.SIGFPE:
1782 val := info.si_code;
1783 pc := info.info.sigfpe.si_addr;
1784 CASE info.si_code OF
1785 | signal.FPE_INTDIV: err := 139 (* division by zero *)
1786 | signal.FPE_INTOVF: err := 138 (* integer overflow *)
1787 | signal.FPE_FLTDIV: err := 140 (* fpu: division by zero *)
1788 | signal.FPE_FLTOVF: err := 142 (* fpu: overflow *)
1789 | signal.FPE_FLTUND: err := 141 (* fpu: underflow *)
1790 (* !!! | signal.FPE_FLTRES: err := ??? (* fpu: *) *)
1791 | signal.FPE_FLTINV: err := 143 (* val := opcode *) (* fpu: invalid op *)
1792 (* !!! | signal.FPE_FLTSUB: err := ??? (* fpu: *) *)
1793 ELSE (* unknown *)
1794 END
1795 | signal.SIGINT:
1796 val := info.si_code;
1797 err := 200 (* keyboard interrupt *)
1798 | signal.SIGSEGV:
1799 val := info.info.sigsegv.si_addr;
1800 err := 203 (* illigal read *)
1801 | signal.SIGBUS:
1802 val := info.info.sigbus.si_addr;
1803 err := 10001H (* bus error *)
1804 | signal.SIGILL:
1805 pc := info.info.sigill.si_addr;
1806 err := 202; (* illigal instruction *)
1807 IF IsReadable(pc, pc + 4) THEN
1808 S.GET(pc, val)
1809 END;
1810 ELSE (* unknown *)
1811 END;
1812 INC(trapCount);
1813 (* !!! InitFPU *)
1814 TrapCleanup;
1815 IF isTry THEN
1816 setjmp._longjmp(tryEnv, 1)
1817 END;
1818 IF (err = 128) OR (err = 200) & ~intTrap THEN (* do nothing *)
1819 ELSIF (trapViewer # NIL) & (restart # NIL) & ~trapped & ~guarded THEN
1820 trapped := TRUE; trapViewer()
1821 ELSE DefaultTrapViewer
1822 END;
1823 trapped := FALSE; secondTrap := FALSE;
1824 IF restart # NIL THEN
1825 setjmp.siglongjmp(startEnv, 1)
1826 END;
1827 stdlib.abort
1828 END TrapHandler;
1829
1830 (* -------------------- Initialization --------------------- *)
1831
1832 PROCEDURE InstallTrap (signo: signal.int);
1833 VAR act: signal._struct_sigaction; (* !!! CPfront hack *) res: signal.int;
1834 BEGIN
1835 act.sa_handler := NIL;
1836 res := signal.sigemptyset(act.sa_mask);
1837 act.sa_flags := signal.SA_NODEFER + signal.SA_SIGINFO;
1838 act.sa_sigaction := TrapHandler;
1839 res := signal.sigaction(signo, S.VAL(signal.struct_sigaction, act), NIL);
1840 END InstallTrap;
1841
1842 PROCEDURE InstallTrapVectors;
1843 BEGIN
1844 InstallTrap(signal.SIGFPE);
1845 InstallTrap(signal.SIGINT);
1846 InstallTrap(signal.SIGSEGV);
1847 InstallTrap(signal.SIGBUS);
1848 InstallTrap(signal.SIGILL)
1849 END InstallTrapVectors;
1850
1851 PROCEDURE RemoveTrapVectors;
1852 END RemoveTrapVectors;
1853
1854 PROCEDURE Init;
1855 VAR i: INTEGER;
1856 BEGIN
1857 intTrap := TRUE;
1858 baseStack := S.ADR(i); (* XXX *)
1859 pagesize := unistd.sysconf(unistd._SC_PAGESIZE);
1860
1861 (* init heap *)
1862 allocated := 0; total := 0; used := 0;
1863 sentinelBlock.size := MAX(INTEGER);
1864 sentinel := S.ADR(sentinelBlock);
1865 i := N;
1866 REPEAT DEC(i); free[i] := sentinel UNTIL i = 0;
1867
1868 IF ~inDll THEN
1869 InstallTrapVectors
1870 END;
1871
1872 (* !!! InitFPU *)
1873 IF ~static THEN
1874 InitModule(modList);
1875 IF ~inDll THEN Quit(1) END
1876 END
1877 END Init;
1878
1879 PROCEDURE [code] SYSTEM_argCount (): INTEGER "SYSTEM_argCount";
1880 PROCEDURE [code] SYSTEM_argVector (): ArrStrPtr "(Kernel_ArrStrPtr)SYSTEM_argVector";
1881 PROCEDURE [code] SYSTEM_modlist (): Module "(Kernel_Module)SYSTEM_modlist";
1882
1883 BEGIN
1884 IF modList = NIL THEN (* only once *)
1885 argc := SYSTEM_argCount();
1886 argv := SYSTEM_argVector();
1887 modList := SYSTEM_modlist();
1888 static := init IN modList.opts;
1889 inDll := dll IN modList.opts;
1890 Init
1891 END
1892 CLOSE
1893 IF ~terminating THEN
1894 terminating := TRUE;
1895 Quit(0)
1896 END
1897 END Kernel.
A command line Component Pascal Compiler
[25/02/2024 19:55:35]
DEADSOFTWARE 2012-2024