DEADSOFTWARE

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