DEADSOFTWARE

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


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