DEADSOFTWARE

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