f691ecc43674eb3818a2e6ac8102f16492f81862
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
,
11 (* add signal blocking to avoid race conditions in Try/Trap/TrapHandler *)
12 (* add BeepHook for Beep *)
17 littleEndian
* = FALSE
;
18 timeResolution
* = 1000; (* ticks per second *)
20 processor
* = 1; (* generic c *)
22 objType
* = "ocf"; (* file types *)
26 (* loader constants *)
40 strictStackSweep
= FALSE
;
41 N
= 128 DIV 16; (* free lists *)
43 (* kernel flags in module desc *)
44 init
= 16; dyn
= 17; dll
= 24; iptrs
= 30;
46 (* meta interface consts *)
47 mConst
= 1; mTyp
= 2; mVar
= 3; mProc
= 4; mField
= 5;
50 Name
* = ARRAY nameLen
OF CHAR;
51 Utf8Name
* = ARRAY nameLen
OF SHORTCHAR
;
54 Module
* = POINTER TO RECORD [untagged
]
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) *)
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 *)
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 *)
82 Object
* = POINTER TO ObjDesc
;
84 ObjDesc
* = RECORD [untagged
]
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 *)
91 Directory
* = POINTER TO RECORD [untagged
]
92 num
-: INTEGER; (* number of entries *)
93 obj
-: ARRAY any
OF ObjDesc (* array of any length *)
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 *)
105 Handler
* = PROCEDURE;
107 Reducer
* = POINTER TO ABSTRACT
RECORD
111 Identifier
* = ABSTRACT
RECORD
116 TrapCleaner
* = POINTER TO ABSTRACT
RECORD
120 TryHandler
* = PROCEDURE (a
, b
, c
: INTEGER);
122 (* meta extension suport *)
124 ItemExt
* = POINTER TO ABSTRACT
RECORD END;
127 obj
*, vis
*, typ
*, adr
*: INTEGER;
134 Hook
* = POINTER TO ABSTRACT
RECORD END;
136 LoaderHook
* = POINTER TO ABSTRACT
RECORD (Hook
)
138 importing
*, imported
*, object
*: ARRAY 256 OF CHAR
141 Block
= POINTER TO RECORD [untagged
]
143 last
: INTEGER; (* arrays: last element *)
144 actual
: INTEGER; (* arrays: used during mark phase *)
145 first
: INTEGER (* arrays: first element *)
148 FreeBlock
= POINTER TO FreeDesc
;
150 FreeDesc
= RECORD [untagged
]
151 tag
: Type
; (* f.tag = ADR(f.size) *)
156 Cluster
= POINTER TO RECORD [untagged
]
157 size
: INTEGER; (* total size *)
159 max
: INTEGER (* exe: reserved size, dll: original address *)
160 (* start of first block *)
163 FList
= POINTER TO RECORD
169 CList
= POINTER TO RECORD
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
;
191 (* SYSTEM.h -> SYSTEM_DLINK *)
192 DLink
= POINTER TO RECORD [untagged
]
196 ArrStrPtr
= POINTER TO ARRAY [untagged
] OF StrPtr
;
198 ADDRESS
* = types
.Pvoid
;
205 err
-, pc
-, sp
-, fp
-, stack
-, val
-: INTEGER;
207 isTry
, checkReadable
: BOOLEAN;
208 startEnv
, checkReadableEnv
: setjmp
.sigjmp_buf
;
209 tryEnv
: setjmp
.jmp_buf
;
210 startDLink
, tryDLink
: DLink
;
214 pagesize
: unistd
.long
;
216 free
: ARRAY N
OF FreeBlock
; (* free list *)
217 sentinelBlock
: FreeDesc
;
219 candidates
: ARRAY 1024 OF 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 *)
225 hotFinalizers
: FList
;
228 trapStack
: TrapCleaner
;
229 actual
: Module
; (* valid during module initialization *)
231 trapViewer
, trapChecker
: Handler
;
232 trapped
, guarded
, secondTrap
: BOOLEAN;
233 interrupted
: BOOLEAN;
234 static
, inDll
, terminating
: BOOLEAN;
240 wouldFinalize
: BOOLEAN;
242 watcher
*: PROCEDURE (event
: INTEGER); (* for debugging *)
246 PROCEDURE Erase (adr
, words
: INTEGER);
248 ASSERT(words
>= 0, 20);
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
;
261 (* meta extension suport *)
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
;
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
;
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
;
294 (* -------------------- miscellaneous tools -------------------- *)
296 PROCEDURE IsUpper
* (ch
: CHAR): BOOLEAN;
298 RETURN wctype
.iswupper(ORD(ch
)) # 0
301 PROCEDURE Upper
* (ch
: CHAR): CHAR;
303 RETURN CHR(wctype
.towupper(ORD(ch
)))
306 PROCEDURE IsLower
* (ch
: CHAR): BOOLEAN;
308 RETURN wctype
.iswlower(ORD(ch
)) # 0
311 PROCEDURE Lower
* (ch
: CHAR): CHAR;
313 RETURN CHR(wctype
.towlower(ORD(ch
)))
316 PROCEDURE IsAlpha
* (ch
: CHAR): BOOLEAN;
318 RETURN wctype
.iswalpha(ORD(ch
)) # 0
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
;
324 PROCEDURE FormatError();
325 BEGIN out
:= in$
; res
:= 2 (*format error*)
329 ch
:= in
[0]; i
:= 1; j
:= 0; max
:= LEN(out
) - 1;
330 WHILE (ch
# 0X
) & (j
< max
) DO
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
)
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
)
352 IF ch
= 0X
THEN res
:= 0 (*ok*) ELSE res
:= 1 (*truncated*) END
355 PROCEDURE StringToUtf8
* (IN in
: ARRAY OF CHAR; OUT out
: ARRAY OF SHORTCHAR
; OUT res
: INTEGER);
356 VAR i
, j
, val
, max
: INTEGER;
358 i
:= 0; j
:= 0; max
:= LEN(out
) - 3;
359 WHILE (in
[i
] # 0X
) & (j
< max
) DO
360 val
:= ORD(in
[i
]); INC(i
);
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
)
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
)
373 IF in
[i
] = 0X
THEN res
:= 0 (*ok*) ELSE res
:= 1 (*truncated*) END
376 PROCEDURE SplitName
* (name
: ARRAY OF CHAR; VAR head
, tail
: ARRAY OF CHAR);
378 VAR i
, j
: INTEGER; ch
, lch
: CHAR;
380 i
:= 0; ch
:= name
[0];
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;
389 IF tail
= "" THEN tail
:= head$
; head
:= "" END
390 ELSE head
:= ""; tail
:= ""
394 PROCEDURE MakeFileName
* (VAR name
: ARRAY OF CHAR; type
: ARRAY OF CHAR);
395 VAR i
, j
: INTEGER; ext
: ARRAY 8 OF CHAR; ch
: CHAR;
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
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];
406 name
[i
] := Lower(ch
); INC(i
); INC(j
); ch
:= ext
[j
]
414 PROCEDURE Time* (): LONGINT;
415 VAR res: time.int; tp: time.struct_timespec;
417 ASSERT(timeResolution >= 1);
418 ASSERT(timeResolution <= 1000000000);
419 res := time.clock_gettime(time.CLOCK_MONOTONIC, tp);
420 ASSERT(res = 0, 100);
421 RETURN tp.tv_sec * LONG(timeResolution) + tp.tv_nsec DIV LONG(1000000000 DIV timeResolution)
425 PROCEDURE Time
* (): LONGINT;
434 PROCEDURE SearchProcVar
* (var
: INTEGER; VAR m
: Module
; VAR adr
: INTEGER);
436 adr
:= var
; m
:= NIL;
439 WHILE (m
# NIL) & ((var
< m
.code
) OR (var
>= m
.code
+ m
.csize
)) DO m
:= m
.next
END;
440 IF m
# NIL THEN DEC(adr
, m
.code
) END
444 (* -------------------- system memory management --------------------- *)
446 PROCEDURE AllocMem (size
: sysmman
.size_t
; VAR max
: sysmman
.size_t
): ADDRESS
;
447 CONST msgstr
= "mmap failed errno "; idx
= LEN(msgstr
);
448 VAR fd
, flags
, res
: fcntl
.int
; ptr
: ADDRESS
; msg
: ARRAY idx
+ 5 OF SHORTCHAR
;
450 max
:= (size
+ pagesize
- 1) DIV pagesize
* pagesize
;
451 fd
:= fcntl
.open("/dev/zero", fcntl
.O_RDWR
, 0);
453 flags
:= sysmman
.PROT_READ
+ sysmman
.PROT_WRITE
;
454 ptr
:= sysmman
.mmap(0, max
, flags
, sysmman
.MAP_PRIVATE
, fd
, 0);
455 IF ptr
= sysmman
.MAP_FAILED
THEN
456 res
:= macro
.errno();
458 msg
[idx
+ 0] := SHORT(CHR(ORD("0") + res
DIV 100 MOD 10));
459 msg
[idx
+ 1] := SHORT(CHR(ORD("0") + res
DIV 10 MOD 10));
460 msg
[idx
+ 2] := SHORT(CHR(ORD("0") + res
MOD 10));
463 res
:= unistd
.write(2, S
.ADR(msg
), LEN(msg$
));
466 res
:= unistd
.close(fd
);
474 PROCEDURE FreeMem (adr
: ADDRESS
; size
: sysmman
.size_t
);
475 VAR res
: sysmman
.int
;
477 size
:= (size
+ pagesize
- 1) DIV pagesize
* pagesize
;
478 res
:= sysmman
.munmap(adr
, size
);
482 PROCEDURE AllocHeapMem (size
: INTEGER; VAR c
: Cluster
);
483 CONST N
= 65536; (* cluster size for dll *)
484 VAR adr
, allocated
, newsize
: INTEGER;
487 ASSERT(size
> 0, 100); adr
:= 0;
489 adr
:= AllocMem(N
, newsize
);
493 adr
:= AllocMem(size
, newsize
);
496 IF adr
= 0 THEN c
:= NIL
498 c
:= S
.VAL(Cluster
, (adr
+ 15) DIV 16 * 16); c
.max
:= adr
;
499 c
.size
:= allocated
- (S
.VAL(INTEGER, c
) - adr
);
500 INC(used
, c
.size
); INC(total
, c
.size
)
502 ASSERT((adr
= 0) OR (adr
MOD 16 = 0) & (c
.size
>= size
), 101);
503 (* post: (c = NIL) OR (c MOD 16 = 0) & (c.size >= size) *)
506 PROCEDURE FreeHeapMem (c
: Cluster
);
508 DEC(used
, c
.size
); DEC(total
, c
.size
);
509 FreeMem(S
.VAL(ADDRESS
, c
.max
), c
.size
)
512 PROCEDURE HeapFull (size
: INTEGER): BOOLEAN;
517 PROCEDURE AllocModMem
* (descSize
, modSize
: INTEGER; VAR descAdr
, modAdr
: INTEGER);
519 descAdr
:= 0; modAdr
:= 0;
520 descAdr
:= AllocMem(descSize
, descSize
);
522 modAdr
:= AllocMem(modSize
, modSize
);
524 FreeMem(descAdr
, descSize
)
526 INC(used
, descSize
+ modSize
)
531 PROCEDURE DeallocModMem
* (descSize
, modSize
, descAdr
, modAdr
: INTEGER);
533 FreeMem(descAdr
, descSize
);
534 FreeMem(modAdr
, modSize
);
535 DEC(used
, descSize
+ modSize
)
538 PROCEDURE InvalModMem (modSize
, modAdr
: INTEGER);
540 FreeMem(modAdr
, modSize
)
543 PROCEDURE IsReadable
* (from
, to
: INTEGER): BOOLEAN;
544 VAR r
: BOOLEAN; jmp
: setjmp
.sigjmp_buf
; res
: setjmp
.int
; i
: INTEGER; x
: BYTE;
547 jmp
:= checkReadableEnv
;
548 checkReadable
:= TRUE
;
549 res
:= setjmp
.sigsetjmp(checkReadableEnv
, 1);
552 FOR i
:= from
TO to
DO
556 FOR i
:= to
TO from BY
-1 DO
561 checkReadableEnv
:= jmp
;
566 (* --------------------- NEW implementation (portable) -------------------- *)
568 PROCEDURE^
NewBlock (size
: INTEGER): Block
;
570 PROCEDURE NewRec
* (typ
: INTEGER): INTEGER; (* implementation of NEW(ptr) *)
571 VAR size
, adr
: INTEGER; b
: Block
; tag
: Type
; l
: FList
;
574 tag
:= S
.VAL(Type
, typ
);
575 b
:= NewBlock(tag
.size
);
578 S
.GET(typ
- 4, size
);
579 IF size
# 0 THEN (* record uses a finalizer *)
580 l
:= S
.VAL(FList
, S
.ADR(b
.last
)); (* anchor new object! *)
581 l
:= S
.VAL(FList
, NewRec(S
.TYP(FList
))); (* NEW(l) *)
582 l
.blk
:= b
; l
.next
:= finalizers
; finalizers
:= l
589 HALT(100) (* COM interface pointers not supported *)
594 PROCEDURE NewArr
* (eltyp
, nofelem
, nofdim
: INTEGER): INTEGER; (* impl. of NEW(ptr, dim0, dim1, ...) *)
595 VAR b
: Block
; size
, headSize
: INTEGER; t
: Type
;
598 |
-1: HALT(100) (* COM interface pointers not supported *)
599 |
0: eltyp
:= S
.ADR(PtrType
)
600 |
1: eltyp
:= S
.ADR(Char8Type
)
601 |
2: eltyp
:= S
.ADR(Int16Type
)
602 |
3: eltyp
:= S
.ADR(Int8Type
)
603 |
4: eltyp
:= S
.ADR(Int32Type
)
604 |
5: eltyp
:= S
.ADR(BoolType
)
605 |
6: eltyp
:= S
.ADR(SetType
)
606 |
7: eltyp
:= S
.ADR(Real32Type
)
607 |
8: eltyp
:= S
.ADR(Real64Type
)
608 |
9: eltyp
:= S
.ADR(Char16Type
)
609 |
10: eltyp
:= S
.ADR(Int64Type
)
610 |
11: eltyp
:= S
.ADR(ProcType
)
611 |
12: eltype
:= S
.ADR(UPtrType
)
613 ASSERT(~
ODD(eltyp
), 101) (* COM interface pointers not supported *)
615 t
:= S
.VAL(Type
, eltyp
);
616 headSize
:= 4 * nofdim
+ 12;
617 size
:= headSize
+ nofelem
* t
.size
;
620 b
.tag
:= S
.VAL(Type
, eltyp
+ 2); (* tag + array mark *)
621 b
.last
:= S
.ADR(b
.last
) + size
- t
.size
; (* pointer to last elem *)
622 b
.first
:= S
.ADR(b
.last
) + headSize
; (* pointer to first elem *)
629 (* -------------------- handler installation (portable) --------------------- *)
631 PROCEDURE ThisFinObj
* (VAR id
: Identifier
): ANYPTR
;
634 ASSERT(id
.typ
# 0, 100);
637 IF S
.VAL(INTEGER, l
.blk
.tag
) = id
.typ
THEN
638 id
.obj
:= S
.VAL(ANYPTR
, S
.ADR(l
.blk
.last
));
639 IF id
.Identified() THEN RETURN id
.obj
END
646 PROCEDURE InstallReducer
* (r
: Reducer
);
648 r
.next
:= reducers
; reducers
:= r
651 PROCEDURE InstallTrapViewer
* (h
: Handler
);
654 END InstallTrapViewer
;
656 PROCEDURE InstallTrapChecker
* (h
: Handler
);
659 END InstallTrapChecker
;
661 PROCEDURE PushTrapCleaner
* (c
: TrapCleaner
);
664 t
:= trapStack
; WHILE (t
# NIL) & (t
# c
) DO t
:= t
.next
END;
666 c
.next
:= trapStack
; trapStack
:= c
669 PROCEDURE PopTrapCleaner
* (c
: TrapCleaner
);
673 WHILE (trapStack
# NIL) & (t
# c
) DO
674 t
:= trapStack
; trapStack
:= trapStack
.next
678 PROCEDURE InstallCleaner
* (p
: Command
);
681 c
:= S
.VAL(CList
, NewRec(S
.TYP(CList
))); (* NEW(c) *)
682 c
.do
:= p
; c
.trapped
:= FALSE
; c
.next
:= cleaners
; cleaners
:= c
685 PROCEDURE RemoveCleaner
* (p
: Command
);
688 c
:= cleaners
; c0
:= NIL;
689 WHILE (c
# NIL) & (c
.do
# p
) DO c0
:= c
; c
:= c
.next
END;
691 IF c0
= NIL THEN cleaners
:= cleaners
.next
ELSE c0
.next
:= c
.next
END
698 c
:= cleaners
; c0
:= NIL;
701 c
.trapped
:= TRUE
; c
.do
; c
.trapped
:= FALSE
; c0
:= c
703 IF c0
= NIL THEN cleaners
:= cleaners
.next
704 ELSE c0
.next
:= c
.next
711 (* -------------------- meta information (portable) --------------------- *)
713 PROCEDURE (h
: LoaderHook
) ThisMod
* (IN name
: ARRAY OF CHAR): Module
, NEW, ABSTRACT
;
715 PROCEDURE SetLoaderHook
*(h
: LoaderHook
);
720 PROCEDURE InitModule (mod
: Module
); (* initialize linked modules *)
723 IF ~
(dyn
IN mod
.opts
) & (mod
.next
# NIL) & ~
(init
IN mod
.next
.opts
) THEN InitModule(mod
.next
) END;
724 IF ~
(init
IN mod
.opts
) THEN
725 body
:= S
.VAL(Command
, mod
.code
);
726 INCL(mod
.opts
, init
);
728 body(); actual
:= NIL
732 PROCEDURE ThisLoadedMod
* (IN name
: ARRAY OF CHAR): Module
; (* loaded modules only *)
733 VAR m
: Module
; res
: INTEGER; n
: Utf8Name
;
735 StringToUtf8(name
, n
, res
); ASSERT(res
= 0);
738 WHILE (m
# NIL) & ((m
.name
# n
) OR (m
.refcnt
< 0)) DO m
:= m
.next
END;
739 IF (m
# NIL) & ~
(init
IN m
.opts
) THEN InitModule(m
) END;
740 IF m
= NIL THEN loadres
:= moduleNotFound
END;
744 PROCEDURE ThisMod
* (IN name
: ARRAY OF CHAR): Module
;
748 RETURN loader
.ThisMod(name
)
750 RETURN ThisLoadedMod(name
)
754 PROCEDURE LoadMod
* (IN name
: ARRAY OF CHAR);
760 PROCEDURE GetLoaderResult
* (OUT res
: INTEGER; OUT importing
, imported
, object
: ARRAY OF CHAR);
764 importing
:= loader
.importing$
;
765 imported
:= loader
.imported$
;
766 object
:= loader
.object$
775 PROCEDURE ThisObject
* (mod
: Module
; IN name
: ARRAY OF CHAR): Object
;
776 VAR l
, r
, m
, res
: INTEGER; p
: StrPtr
; n
: Utf8Name
;
778 StringToUtf8(name
, n
, res
); ASSERT(res
= 0);
779 l
:= 0; r
:= mod
.export
.num
;
780 WHILE l
< r
DO (* binary search *)
782 p
:= S
.VAL(StrPtr
, S
.ADR(mod
.names
[mod
.export
.obj
[m
].id
DIV 256]));
783 IF p^
= n
THEN RETURN S
.VAL(Object
, S
.ADR(mod
.export
.obj
[m
])) END;
784 IF p^
< n
THEN l
:= m
+ 1 ELSE r
:= m
END
789 PROCEDURE ThisDesc
* (mod
: Module
; fprint
: INTEGER): Object
;
792 i
:= 0; n
:= mod
.export
.num
;
793 WHILE (i
< n
) & (mod
.export
.obj
[i
].id
DIV 256 = 0) DO
794 IF mod
.export
.obj
[i
].offs
= fprint
THEN RETURN S
.VAL(Object
, S
.ADR(mod
.export
.obj
[i
])) END;
800 PROCEDURE ThisField
* (rec
: Type
; IN name
: ARRAY OF CHAR): Object
;
801 VAR n
, res
: INTEGER; p
: StrPtr
; obj
: Object
; m
: Module
; nn
: Utf8Name
;
803 StringToUtf8(name
, nn
, res
); ASSERT(res
= 0);
805 obj
:= S
.VAL(Object
, S
.ADR(rec
.fields
.obj
[0])); n
:= rec
.fields
.num
;
807 p
:= S
.VAL(StrPtr
, S
.ADR(m
.names
[obj
.id
DIV 256]));
808 IF p^
= nn
THEN RETURN obj
END;
809 DEC(n
); INC(S
.VAL(INTEGER, obj
), 16)
814 PROCEDURE ThisCommand
* (mod
: Module
; IN name
: ARRAY OF CHAR): Command
;
815 VAR x
: Object
; sig
: Signature
;
817 x
:= ThisObject(mod
, name
);
818 IF (x
# NIL) & (x
.id
MOD 16 = mProc
) THEN
819 sig
:= S
.VAL(Signature
, x
.struct
);
820 IF (sig
.retStruct
= NIL) & (sig
.num
= 0) THEN RETURN S
.VAL(Command
, mod
.procBase
+ x
.offs
) END
825 PROCEDURE ThisType
* (mod
: Module
; IN name
: ARRAY OF CHAR): Type
;
828 x
:= ThisObject(mod
, name
);
829 IF (x
# NIL) & (x
.id
MOD 16 = mTyp
) & (S
.VAL(INTEGER, x
.struct
) DIV 256 # 0) THEN
836 PROCEDURE TypeOf
* (IN rec
: ANYREC
): Type
;
838 RETURN S
.VAL(Type
, S
.TYP(rec
))
841 PROCEDURE LevelOf
* (t
: Type
): SHORTINT;
843 RETURN SHORT(t
.id
DIV 16 MOD 16)
846 PROCEDURE NewObj
* (VAR o
: S
.PTR
; t
: Type
);
849 IF t
.size
= -1 THEN o
:= NIL
851 i
:= 0; WHILE t
.ptroffs
[i
] >= 0 DO INC(i
) END;
852 IF t
.ptroffs
[i
+1] >= 0 THEN INC(S
.VAL(INTEGER, t
)) END; (* with interface pointers *)
853 o
:= S
.VAL(S
.PTR
, NewRec(S
.VAL(INTEGER, t
))) (* generic NEW *)
857 PROCEDURE GetModName
* (mod
: Module
; OUT name
: Name
);
860 Utf8ToString(mod
.name
, name
, res
); ASSERT(res
= 0)
863 PROCEDURE GetObjName
* (mod
: Module
; obj
: Object
; OUT name
: Name
);
864 VAR p
: StrPtr
; res
: INTEGER;
866 p
:= S
.VAL(StrPtr
, S
.ADR(mod
.names
[obj
.id
DIV 256]));
867 Utf8ToString(p^$
, name
, res
); ASSERT(res
= 0)
870 PROCEDURE GetTypeName
* (t
: Type
; OUT name
: Name
);
871 VAR p
: StrPtr
; res
: INTEGER;
873 p
:= S
.VAL(StrPtr
, S
.ADR(t
.mod
.names
[t
.id
DIV 256]));
874 Utf8ToString(p^$
, name
, res
); ASSERT(res
= 0)
877 PROCEDURE RegisterMod
* (mod
: Module
);
878 VAR i
: INTEGER; epoch
: time
.time_t
; tm
: time
.struct_tm
; ptm
: time
.Pstruct_tm
;
880 mod
.next
:= modList
; modList
:= mod
; mod
.refcnt
:= 0; INCL(mod
.opts
, dyn
); i
:= 0;
881 WHILE i
< mod
.nofimps
DO
882 IF mod
.imports
[i
] # NIL THEN INC(mod
.imports
[i
].refcnt
) END;
885 epoch
:= time
.time(NIL);
886 ptm
:= time
.localtime_r(epoch
, tm
);
888 mod
.loadTime
[0] := SHORT(tm
.tm_year
+ 1900);
889 mod
.loadTime
[1] := SHORT(tm
.tm_mon
+ 1);
890 mod
.loadTime
[2] := SHORT(tm
.tm_mday
);
891 mod
.loadTime
[3] := SHORT(tm
.tm_hour
);
892 mod
.loadTime
[4] := SHORT(tm
.tm_min
);
893 mod
.loadTime
[5] := SHORT(tm
.tm_sec
)
895 mod
.loadTime
[0] := 0;
896 mod
.loadTime
[1] := 0;
897 mod
.loadTime
[2] := 0;
898 mod
.loadTime
[3] := 0;
899 mod
.loadTime
[4] := 0;
902 IF ~
(init
IN mod
.opts
) THEN InitModule(mod
) END
907 PROCEDURE UnloadMod
* (mod
: Module
);
908 VAR i
: INTEGER; t
: Command
;
910 IF mod
.refcnt
= 0 THEN
911 t
:= mod
.term
; mod
.term
:= NIL;
912 IF t
# NIL THEN t() END; (* terminate module *)
914 WHILE i
< mod
.nofptrs
DO (* release global pointers *)
915 S
.PUT(mod
.varBase
+ mod
.ptrs
[i
], 0); INC(i
)
917 Collect
; (* call finalizers *)
919 WHILE i
< mod
.nofimps
DO (* release imported modules *)
920 IF mod
.imports
[i
] # NIL THEN DEC(mod
.imports
[i
].refcnt
) END;
924 IF dyn
IN mod
.opts
THEN (* release memory *)
925 InvalModMem(mod
.data
+ mod
.dsize
- mod
.refs
, mod
.refs
)
930 (* -------------------- dynamic procedure call --------------------- *)
939 open array address length .. length
942 PROCEDURE Call
* (adr
: ADDRESS
; sig
: Signature
; IN par
: ARRAY OF INTEGER; n
: INTEGER): LONGINT;
945 mConst
= 1; mTyp
= 2; mVar
= 3; mProc
= 4; mField
= 5;
947 mBool
= 1; mChar8
= 2; mChar16
= 3; mInt8
= 4; mInt16
= 5; mInt32
= 6;
948 mReal32
= 7; mReal64
= 8; mSet
= 9; mInt64
= 10; mAnyRec
= 11; mAnyPtr
= 12; mSysPtr
= 13;
950 mProctyp
= 0; mRecord
= 1; mArray
= 2; mPointer
= 3;
951 (* ??? obj.id DIV 16 MOD 16 *)
952 mInternal
= 1; mReadonly
= 2; mPrivate
= 3; mExported
= 4;
953 (* sig.par[].id MOD 16 *)
954 mValue
= 10; mInPar
= 11; mOutPar
= 12; mVarPar
= 13;
955 mInterface
= 32; mGuid
= 33; mResult
= 34;
956 (* implementation restrictions *)
961 Ptype
= POINTER TO LibFFI
.type
;
962 PPtype
= POINTER TO ARRAY [untagged
] OF Ptype
;
964 status
: LibFFI
.status
;
965 kind
, form
, size
: INTEGER;
966 i
, p
, d
, cn
, ut
, ue
: INTEGER;
969 earg
: ARRAY maxElms
OF Ptype
;
970 targ
: ARRAY maxStrs
OF LibFFI
.type
;
971 farg
: ARRAY maxPars
OF Ptype
;
972 varg
: ARRAY maxPars
OF ADDRESS
;
976 PROCEDURE SetType (IN typ
: LibFFI
.type
);
978 farg
[cn
] := S
.VAL(Ptype
, S
.ADR(typ
));
981 PROCEDURE PushAdr (size
: INTEGER);
983 ASSERT(size
IN {1, 2, 4, 8}, 20);
984 ASSERT(littleEndian
OR (size
<= 4), 100); (* !!! swap 64bit value *)
985 varg
[cn
] := S
.ADR(par
[d
]);
986 INC(cn
); INC(d
, MAX(1, size
DIV 4))
989 PROCEDURE PushVal (size
: INTEGER);
991 ASSERT(size
IN {1, 2, 4, 8}, 20);
992 ASSERT(littleEndian
OR (size
<= 4), 100); (* !!! swap 64bit value *)
994 INC(cn
); INC(d
, MAX(1, size
DIV 4))
997 PROCEDURE Push (IN typ
: LibFFI
.type
);
999 SetType(typ
); PushAdr(typ
.size
)
1003 p
:= 0; cn
:= 0; d
:= 0; ut
:= 0; ue
:= 0;
1004 WHILE p
< sig
.num
DO
1005 typ
:= sig
.par
[p
].struct
;
1006 kind
:= sig
.par
[p
].id
MOD 16;
1007 IF S
.VAL(ADDRESS
, typ
) DIV 256 = 0 THEN (* basic types *)
1008 form
:= S
.VAL(ADDRESS
, typ
) MOD 256;
1009 IF kind
= mValue
THEN
1011 | mBool
, mChar8
: Push(LibFFI
.type_uint8
)
1012 | mChar16
: Push(LibFFI
.type_uint16
)
1013 | mInt8
: Push(LibFFI
.type_sint8
)
1014 | mInt16
: Push(LibFFI
.type_sint16
)
1015 | mInt32
: Push(LibFFI
.type_sint32
)
1016 | mReal32
: Push(LibFFI
.type_float
)
1017 | mReal64
: Push(LibFFI
.type_double
)
1018 | mSet
: Push(LibFFI
.type_uint32
)
1019 | mInt64
: Push(LibFFI
.type_sint64
)
1020 | mAnyPtr
, mSysPtr
: Push(LibFFI
.type_pointer
)
1021 ELSE HALT(100) (* unsupported type *)
1023 ELSIF kind
IN {mInPar
..mVarPar
} THEN
1025 | mBool
..mInt64
, mAnyPtr
, mSysPtr
: Push(LibFFI
.type_pointer
)
1026 | mAnyRec
: Push(LibFFI
.type_pointer
); Push(LibFFI
.type_pointer
) (* address + tag *)
1027 ELSE HALT(101) (* unsupported type *)
1030 HALT(102) (* unsupported parameter kind *)
1033 CASE typ
.id
MOD 4 OF
1034 | mProctyp
, mPointer
:
1035 Push(LibFFI
.type_pointer
)
1037 IF kind
= mValue
THEN
1039 targ
[ut
].alignment
:= 0;
1040 targ
[ut
].type
:= LibFFI
.TYPE_STRUCT
;
1041 targ
[ut
].elements
:= S
.VAL(PPtype
, S
.ADR(earg
[ue
]));
1042 SetType(targ
[ut
]); INC(ut
);
1043 size
:= MAX(1, typ
.size
);
1044 (* !!! better to pass original layout *)
1046 earg
[ue
] := S
.VAL(Ptype
, S
.ADR(LibFFI
.type_uint64
));
1047 INC(ue
); DEC(size
, 8)
1050 earg
[ue
] := S
.VAL(Ptype
, S
.ADR(LibFFI
.type_uint32
));
1051 INC(ue
); DEC(size
, 4)
1054 earg
[ue
] := S
.VAL(Ptype
, S
.ADR(LibFFI
.type_uint16
));
1055 INC(ue
); DEC(size
, 2)
1058 earg
[ue
] := S
.VAL(Ptype
, S
.ADR(LibFFI
.type_uint32
));
1063 PushVal(LibFFI
.type_pointer
.size
);
1064 INC(d
) (* skip tag *)
1065 ELSIF kind
IN {mInPar
..mVarPar
} THEN
1066 Push(LibFFI
.type_pointer
); (* address *)
1067 Push(LibFFI
.type_pointer
); (* tag *)
1068 ELSE HALT(103) (* unsupported parameter kind *)
1071 Push(LibFFI
.type_pointer
);
1072 ASSERT(kind
IN {mValue
..mVarPar
}, 104); (* unsupported parameter kind *)
1073 (* array copying generated by CPfront, so we can just pass address *)
1074 IF typ
.size
= 0 THEN (* open array *)
1075 FOR i
:= 0 TO typ
.id
DIV 16 - 1 DO
1076 Push(LibFFI
.type_sint32
) (* dim size *)
1078 ELSE (* fix array *)
1079 INC(d
) (* skip size *)
1086 typ
:= sig
.retStruct
;
1087 IF typ
= NIL THEN fret
:= S
.VAL(Ptype
, S
.ADR(LibFFI
.type_void
))
1088 ELSIF S
.VAL(ADDRESS
, typ
) DIV 256 = 0 THEN
1089 form
:= S
.VAL(ADDRESS
, typ
) MOD 256;
1091 | mBool
, mChar8
: fret
:= S
.VAL(Ptype
, S
.ADR(LibFFI
.type_uint8
))
1092 | mChar16
: fret
:= S
.VAL(Ptype
, S
.ADR(LibFFI
.type_uint16
))
1093 | mInt8
: fret
:= S
.VAL(Ptype
, S
.ADR(LibFFI
.type_sint8
))
1094 | mInt16
: fret
:= S
.VAL(Ptype
, S
.ADR(LibFFI
.type_sint16
))
1095 | mInt32
: fret
:= S
.VAL(Ptype
, S
.ADR(LibFFI
.type_sint32
))
1096 | mReal32
: fret
:= S
.VAL(Ptype
, S
.ADR(LibFFI
.type_float
))
1097 | mReal64
: fret
:= S
.VAL(Ptype
, S
.ADR(LibFFI
.type_double
))
1098 | mSet
: fret
:= S
.VAL(Ptype
, S
.ADR(LibFFI
.type_uint32
))
1099 | mInt64
: fret
:= S
.VAL(Ptype
, S
.ADR(LibFFI
.type_sint64
))
1100 | mAnyPtr
, mSysPtr
: fret
:= S
.VAL(Ptype
, S
.ADR(LibFFI
.type_pointer
))
1101 ELSE HALT(106) (* unsupported type *)
1104 CASE typ
.id
MOD 4 OF
1105 | mProctyp
, mPointer
: fret
:= S
.VAL(Ptype
, S
.ADR(LibFFI
.type_pointer
))
1106 ELSE HALT(107) (* unsupported type *)
1109 status
:= LibFFI
.prep_cif(cif
, LibFFI
.DEFAULT_ABI
, cn
, fret
, farg
);
1110 ASSERT(status
= LibFFI
.OK
, 108);
1112 IF littleEndian
THEN LibFFI
.call(cif
, adr
, S
.ADR(vret
), S
.ADR(varg
))
1113 ELSE LibFFI
.call(cif
, adr
, S
.ADR(vret
) + (8 - fret
.size
), S
.ADR(varg
))
1118 (* -------------------- reference information (portable) --------------------- *)
1120 PROCEDURE RefCh (VAR ref
: INTEGER; OUT ch
: SHORTCHAR
);
1122 S
.GET(ref
, ch
); INC(ref
)
1125 PROCEDURE RefNum (VAR ref
: INTEGER; OUT x
: INTEGER);
1126 VAR s
, n
: INTEGER; ch
: SHORTCHAR
;
1128 s
:= 0; n
:= 0; RefCh(ref
, ch
);
1129 WHILE ORD(ch
) >= 128 DO INC(n
, ASH(ORD(ch
) - 128, s
) ); INC(s
, 7); RefCh(ref
, ch
) END;
1130 x
:= n
+ ASH(ORD(ch
) MOD 64 - ORD(ch
) DIV 64 * 64, s
)
1133 PROCEDURE RefName (VAR ref
: INTEGER; OUT n
: Utf8Name
);
1134 VAR i
: INTEGER; ch
: SHORTCHAR
;
1136 i
:= 0; RefCh(ref
, ch
);
1137 WHILE ch
# 0X
DO n
[i
] := ch
; INC(i
); RefCh(ref
, ch
) END;
1141 PROCEDURE GetRefProc
* (VAR ref
: INTEGER; OUT adr
: INTEGER; OUT name
: Utf8Name
);
1145 WHILE ch
>= 0FDX
DO (* skip variables *)
1146 INC(ref
); RefCh(ref
, ch
);
1147 IF ch
= 10X
THEN INC(ref
, 4) END;
1148 RefNum(ref
, adr
); RefName(ref
, name
); S
.GET(ref
, ch
)
1150 WHILE (ch
> 0X
) & (ch
< 0FCX
) DO (* skip source refs *)
1151 INC(ref
); RefNum(ref
, adr
); S
.GET(ref
, ch
)
1153 IF ch
= 0FCX
THEN INC(ref
); RefNum(ref
, adr
); RefName(ref
, name
)
1158 PROCEDURE GetRefVar
* (VAR ref
: INTEGER; OUT mode
, form
: SHORTCHAR
; OUT desc
: Type
; OUT adr
: INTEGER; OUT name
: Utf8Name
);
1160 S
.GET(ref
, mode
); desc
:= NIL;
1161 IF mode
>= 0FDX
THEN
1162 mode
:= SHORT(CHR(ORD(mode
) - 0FCH
));
1163 INC(ref
); RefCh(ref
, form
);
1165 S
.GET(ref
, desc
); INC(ref
, 4); form
:= SHORT(CHR(16 + desc
.id
MOD 4))
1167 RefNum(ref
, adr
); RefName(ref
, name
)
1169 mode
:= 0X
; form
:= 0X
; adr
:= 0
1173 PROCEDURE SourcePos
* (mod
: Module
; codePos
: INTEGER): INTEGER;
1174 VAR ref
, pos
, ad
, d
: INTEGER; ch
: SHORTCHAR
; name
: Utf8Name
;
1176 IF mod
# NIL THEN (* mf, 12.02.04 *)
1177 ref
:= mod
.refs
; pos
:= 0; ad
:= 0; S
.GET(ref
, ch
);
1179 WHILE (ch
> 0X
) & (ch
< 0FCX
) DO (* srcref: {dAdr,dPos} *)
1180 INC(ad
, ORD(ch
)); INC(ref
); RefNum(ref
, d
);
1181 IF ad
> codePos
THEN RETURN pos
END;
1182 INC(pos
, d
); S
.GET(ref
, ch
)
1184 IF ch
= 0FCX
THEN (* proc: 0FCX,Adr,Name *)
1185 INC(ref
); RefNum(ref
, d
); RefName(ref
, name
); S
.GET(ref
, ch
);
1186 IF (d
> codePos
) & (pos
> 0) THEN RETURN pos
END
1188 WHILE ch
>= 0FDX
DO (* skip variables: Mode, Form, adr, Name *)
1189 INC(ref
); RefCh(ref
, ch
);
1190 IF ch
= 10X
THEN INC(ref
, 4) END;
1191 RefNum(ref
, d
); RefName(ref
, name
); S
.GET(ref
, ch
)
1198 PROCEDURE LoadDll
* (IN name
: ARRAY OF CHAR; VAR ok
: BOOLEAN);
1199 VAR h
: ADDRESS
; file
: Utf8Name
; res
: INTEGER;
1201 StringToUtf8(name
, file
, res
);
1203 h
:= dlfcn
.dlopen(file
, dlfcn
.RTLD_LAZY
+ dlfcn
.RTLD_GLOBAL
);
1210 PROCEDURE ThisDllObj
* (mode
, fprint
: INTEGER; IN dll
, name
: ARRAY OF CHAR): INTEGER;
1211 VAR h
, p
: ADDRESS
; file
, sym
: Utf8Name
; res
: INTEGER; err
: dlfcn
.int
;
1213 StringToUtf8(dll
, file
, res
);
1215 h
:= dlfcn
.dlopen(file
, dlfcn
.RTLD_LAZY
+ dlfcn
.RTLD_GLOBAL
);
1217 StringToUtf8(name
, sym
, res
);
1219 p
:= dlfcn
.dlsym(h
, sym
)
1223 err
:= dlfcn
.dlclose(h
);
1224 ASSERT(err
= 0, 100)
1234 (* -------------------- garbage collector (portable) --------------------- *)
1236 PROCEDURE Mark (this
: Block
);
1237 VAR father
, son
: Block
; tag
: Type
; flag
, offset
, actual
: INTEGER;
1239 IF ~
ODD(S
.VAL(INTEGER, this
.tag
)) THEN
1242 INC(S
.VAL(INTEGER, this
.tag
));
1243 flag
:= S
.VAL(INTEGER, this
.tag
) MOD 4;
1244 tag
:= S
.VAL(Type
, S
.VAL(INTEGER, this
.tag
) - flag
);
1245 IF flag
>= 2 THEN actual
:= this
.first
; this
.actual
:= actual
1246 ELSE actual
:= S
.ADR(this
.last
)
1249 offset
:= tag
.ptroffs
[0];
1251 INC(S
.VAL(INTEGER, tag
), offset
+ 4); (* restore tag *)
1252 IF (flag
>= 2) & (actual
< this
.last
) & (offset
< -4) THEN (* next array element *)
1253 INC(actual
, tag
.size
); this
.actual
:= actual
1255 this
.tag
:= S
.VAL(Type
, S
.VAL(INTEGER, tag
) + flag
);
1256 IF father
= NIL THEN RETURN END;
1257 son
:= this
; this
:= father
;
1258 flag
:= S
.VAL(INTEGER, this
.tag
) MOD 4;
1259 tag
:= S
.VAL(Type
, S
.VAL(INTEGER, this
.tag
) - flag
);
1260 offset
:= tag
.ptroffs
[0];
1261 IF flag
>= 2 THEN actual
:= this
.actual
ELSE actual
:= S
.ADR(this
.last
) END;
1262 S
.GET(actual
+ offset
, father
); S
.PUT(actual
+ offset
, S
.ADR(son
.last
));
1263 INC(S
.VAL(INTEGER, tag
), 4)
1266 S
.GET(actual
+ offset
, son
);
1268 DEC(S
.VAL(INTEGER, son
), 4);
1269 IF ~
ODD(S
.VAL(INTEGER, son
.tag
)) THEN (* down *)
1270 this
.tag
:= S
.VAL(Type
, S
.VAL(INTEGER, tag
) + flag
);
1271 S
.PUT(actual
+ offset
, father
); father
:= this
; this
:= son
;
1275 INC(S
.VAL(INTEGER, tag
), 4)
1282 PROCEDURE MarkGlobals
;
1283 VAR m
: Module
; i
, p
: INTEGER;
1287 IF m
.refcnt
>= 0 THEN
1289 WHILE i
< m
.nofptrs
DO
1290 S
.GET(m
.varBase
+ m
.ptrs
[i
], p
); INC(i
);
1291 IF p
# 0 THEN Mark(S
.VAL(Block
, p
- 4)) END
1298 PROCEDURE Next (b
: Block
): Block
; (* next block in same cluster *)
1301 S
.GET(S
.VAL(INTEGER, b
.tag
) DIV 4 * 4, size
);
1302 IF ODD(S
.VAL(INTEGER, b
.tag
) DIV 2) THEN INC(size
, b
.last
- S
.ADR(b
.last
)) END;
1303 RETURN S
.VAL(Block
, S
.VAL(INTEGER, b
) + (size
+ 19) DIV 16 * 16)
1306 PROCEDURE CheckCandidates
;
1307 (* pre: nofcand > 0 *)
1308 VAR i
, j
, h
, p
, end
: INTEGER; c
: Cluster
; blk
, next
: Block
;
1310 (* sort candidates (shellsort) *)
1311 h
:= 1; REPEAT h
:= h
*3 + 1 UNTIL h
> nofcand
;
1312 REPEAT h
:= h
DIV 3; i
:= h
;
1313 WHILE i
< nofcand
DO p
:= candidates
[i
]; j
:= i
;
1314 WHILE (j
>= h
) & (candidates
[j
-h
] > p
) DO
1315 candidates
[j
] := candidates
[j
-h
]; j
:= j
-h
1317 candidates
[j
] := p
; INC(i
)
1323 blk
:= S
.VAL(Block
, S
.VAL(INTEGER, c
) + 12);
1324 end
:= S
.VAL(INTEGER, blk
) + (c
.size
- 12) DIV 16 * 16;
1325 WHILE candidates
[i
] < S
.VAL(INTEGER, blk
) DO
1327 IF i
= nofcand
THEN RETURN END
1329 WHILE S
.VAL(INTEGER, blk
) < end
DO
1331 IF candidates
[i
] < S
.VAL(INTEGER, next
) THEN
1332 IF (S
.VAL(INTEGER, blk
.tag
) # S
.ADR(blk
.last
)) (* not a free block *)
1333 & (~strictStackSweep
OR (candidates
[i
] = S
.ADR(blk
.last
))) THEN
1338 IF i
= nofcand
THEN RETURN END
1339 UNTIL candidates
[i
] >= S
.VAL(INTEGER, next
)
1341 IF (S
.VAL(INTEGER, blk
.tag
) MOD 4 = 0) & (S
.VAL(INTEGER, blk
.tag
) # S
.ADR(blk
.last
))
1342 & (blk
.tag
.base
[0] = NIL) & (blk
.actual
> 0) THEN (* referenced interface record *)
1349 END CheckCandidates
;
1351 PROCEDURE MarkLocals
;
1352 VAR sp
, p
, min
, max
: INTEGER; c
: Cluster
;
1354 sp
:= S
.ADR(sp
); nofcand
:= 0; c
:= root
;
1355 WHILE c
.next
# NIL DO c
:= c
.next
END;
1356 min
:= S
.VAL(INTEGER, root
); max
:= S
.VAL(INTEGER, c
) + c
.size
;
1357 WHILE sp
< baseStack
DO
1359 IF (p
> min
) & (p
< max
) & (~strictStackSweep
OR (p
MOD 16 = 0)) THEN
1360 candidates
[nofcand
] := p
; INC(nofcand
);
1361 IF nofcand
= LEN(candidates
) - 1 THEN CheckCandidates
; nofcand
:= 0 END
1365 candidates
[nofcand
] := max
; INC(nofcand
); (* ensure complete scan for interface mark*)
1366 IF nofcand
> 0 THEN CheckCandidates
END
1369 PROCEDURE MarkFinObj
;
1372 wouldFinalize
:= FALSE
;
1375 IF ~
ODD(S
.VAL(INTEGER, f
.blk
.tag
)) THEN wouldFinalize
:= TRUE
END;
1380 WHILE f
# NIL DO IF ~
ODD(S
.VAL(INTEGER, f
.blk
.tag
)) THEN wouldFinalize
:= TRUE
END;
1386 PROCEDURE CheckFinalizers
;
1387 VAR f
, g
, h
, k
: FList
;
1389 f
:= finalizers
; g
:= NIL;
1390 IF hotFinalizers
= NIL THEN k
:= NIL
1393 WHILE k
.next
# NIL DO k
:= k
.next
END
1396 h
:= f
; f
:= f
.next
;
1397 IF ~
ODD(S
.VAL(INTEGER, h
.blk
.tag
)) THEN
1398 IF g
= NIL THEN finalizers
:= f
ELSE g
.next
:= f
END;
1399 IF k
= NIL THEN hotFinalizers
:= h
ELSE k
.next
:= h
END;
1400 k
:= h
; h
.next
:= NIL
1405 WHILE h
# NIL DO Mark(h
.blk
); h
:= h
.next
END
1406 END CheckFinalizers
;
1408 PROCEDURE ExecFinalizer (a
, b
, c
: INTEGER);
1409 VAR f
: FList
; fin
: PROCEDURE(this
: ANYPTR
);
1411 f
:= S
.VAL(FList
, a
);
1412 S
.GET(S
.VAL(INTEGER, f
.blk
.tag
) - 4, fin
); (* method 0 *)
1413 IF (fin
# NIL) & (f
.blk
.tag
.mod
.refcnt
>= 0) THEN fin(S
.VAL(ANYPTR
, S
.ADR(f
.blk
.last
))) END;
1416 PROCEDURE^ Try
* (h
: TryHandler
; a
, b
, c
: INTEGER); (* COMPILER DEPENDENT *)
1418 PROCEDURE CallFinalizers
;
1421 WHILE hotFinalizers
# NIL DO
1422 f
:= hotFinalizers
; hotFinalizers
:= hotFinalizers
.next
;
1423 Try(ExecFinalizer
, S
.VAL(INTEGER, f
), 0, 0)
1425 wouldFinalize
:= FALSE
1428 PROCEDURE Insert (blk
: FreeBlock
; size
: INTEGER); (* insert block in free list *)
1431 blk
.size
:= size
- 4; blk
.tag
:= S
.VAL(Type
, S
.ADR(blk
.size
));
1432 i
:= MIN(N
- 1, (blk
.size
DIV 16));
1433 blk
.next
:= free
[i
]; free
[i
] := blk
1436 PROCEDURE Sweep (dealloc
: BOOLEAN);
1437 VAR cluster
, last
, c
: Cluster
; blk
, next
: Block
; fblk
, b
, t
: FreeBlock
; end
, i
: INTEGER;
1439 cluster
:= root
; last
:= NIL; allocated
:= 0;
1441 REPEAT DEC(i
); free
[i
] := sentinel
UNTIL i
= 0;
1442 WHILE cluster
# NIL DO
1443 blk
:= S
.VAL(Block
, S
.VAL(INTEGER, cluster
) + 12);
1444 end
:= S
.VAL(INTEGER, blk
) + (cluster
.size
- 12) DIV 16 * 16;
1446 WHILE S
.VAL(INTEGER, blk
) < end
DO
1448 IF ODD(S
.VAL(INTEGER, blk
.tag
)) THEN
1450 Insert(fblk
, S
.VAL(INTEGER, blk
) - S
.VAL(INTEGER, fblk
));
1453 DEC(S
.VAL(INTEGER, blk
.tag
)); (* unmark *)
1454 INC(allocated
, S
.VAL(INTEGER, next
) - S
.VAL(INTEGER, blk
))
1455 ELSIF fblk
= NIL THEN
1456 fblk
:= S
.VAL(FreeBlock
, blk
)
1460 IF dealloc
& (S
.VAL(INTEGER, fblk
) = S
.VAL(INTEGER, cluster
) + 12) THEN (* deallocate cluster *)
1461 c
:= cluster
; cluster
:= cluster
.next
;
1462 IF last
= NIL THEN root
:= cluster
ELSE last
.next
:= cluster
END;
1465 IF fblk
# NIL THEN Insert(fblk
, end
- S
.VAL(INTEGER, fblk
)) END;
1466 last
:= cluster
; cluster
:= cluster
.next
1469 (* reverse free list *)
1473 b
:= free
[i
]; fblk
:= sentinel
;
1474 WHILE b
# sentinel
DO t
:= b
; b
:= t
.next
; t
.next
:= fblk
; fblk
:= t
END;
1482 CallFinalizers
; (* trap cleanup *)
1491 PROCEDURE FastCollect
*;
1501 PROCEDURE WouldFinalize
* (): BOOLEAN;
1503 RETURN wouldFinalize
1506 (* --------------------- memory allocation (portable) -------------------- *)
1508 PROCEDURE OldBlock (size
: INTEGER): FreeBlock
; (* size MOD 16 = 0 *)
1509 VAR b
, l
: FreeBlock
; s
, i
: INTEGER;
1512 i
:= MIN(N
- 1, s
DIV 16);
1513 WHILE (i
# N
- 1) & (free
[i
] = sentinel
) DO INC(i
) END;
1514 b
:= free
[i
]; l
:= NIL;
1515 WHILE b
.size
< s
DO l
:= b
; b
:= b
.next
END;
1516 IF b
# sentinel
THEN
1517 IF l
= NIL THEN free
[i
] := b
.next
ELSE l
.next
:= b
.next
END
1523 PROCEDURE LastBlock (limit
: INTEGER): FreeBlock
; (* size MOD 16 = 0 *)
1524 VAR b
, l
: FreeBlock
; s
, i
: INTEGER;
1529 b
:= free
[i
]; l
:= NIL;
1530 WHILE (b
# sentinel
) & (S
.VAL(INTEGER, b
) + b
.size
# s
) DO l
:= b
; b
:= b
.next
END;
1531 IF b
# sentinel
THEN
1532 IF l
= NIL THEN free
[i
] := b
.next
ELSE l
.next
:= b
.next
END
1536 UNTIL (b
# NIL) OR (i
= N
);
1540 PROCEDURE NewBlock (size
: INTEGER): Block
;
1541 VAR tsize
, a
, s
: INTEGER; b
: FreeBlock
; new
, c
: Cluster
; r
: Reducer
;
1543 ASSERT(size
>= 0, 20);
1544 IF size
> MAX(INTEGER) - 19 THEN RETURN NIL END;
1545 tsize
:= (size
+ 19) DIV 16 * 16;
1546 b
:= OldBlock(tsize
); (* 1) search for free block *)
1548 FastCollect
; b
:= OldBlock(tsize
); (* 2) collect *)
1550 Collect
; b
:= OldBlock(tsize
); (* 2a) fully collect *)
1553 AllocHeapMem(tsize
+ 12, new
); (* 3) allocate new cluster *)
1555 IF (root
= NIL) OR (S
.VAL(INTEGER, new
) < S
.VAL(INTEGER, root
)) THEN
1556 new
.next
:= root
; root
:= new
1559 WHILE (c
.next
# NIL) & (S
.VAL(INTEGER, new
) > S
.VAL(INTEGER, c
.next
)) DO c
:= c
.next
END;
1560 new
.next
:= c
.next
; c
.next
:= new
1562 b
:= S
.VAL(FreeBlock
, S
.VAL(INTEGER, new
) + 12);
1563 b
.size
:= (new
.size
- 12) DIV 16 * 16 - 4
1565 RETURN NIL (* 4) give up *)
1570 a
:= b
.size
+ 4 - tsize
;
1571 IF a
> 0 THEN Insert(S
.VAL(FreeBlock
, S
.VAL(INTEGER, b
) + tsize
), a
) END;
1572 IF size
> 0 THEN Erase(S
.ADR(b
.size
), (size
+ 3) DIV 4) END;
1573 INC(allocated
, tsize
);
1574 RETURN S
.VAL(Block
, b
)
1577 PROCEDURE Allocated
* (): INTEGER;
1582 PROCEDURE Used
* (): INTEGER;
1587 PROCEDURE Root
* (): INTEGER;
1589 RETURN S
.VAL(INTEGER, root
)
1592 (* -------------------- Trap Handling --------------------- *)
1594 PROCEDURE [code
] GetDLink (): DLink
"(Kernel_DLink)SYSTEM_dlink";
1595 PROCEDURE [code
] SetDLink (dl
: DLink
) "SYSTEM_dlink = (SYSTEM_DLINK*)dl";
1597 PROCEDURE Start
* (code
: Command
);
1598 VAR res
: setjmp
.int
; dl
: DLink
;
1601 baseStack
:= S
.ADR(code
); (* XXX: expected that target uses one stack *)
1602 startDLink
:= GetDLink();
1603 res
:= setjmp
.sigsetjmp(startEnv
, 1);
1607 PROCEDURE Quit
* (exitCode
: INTEGER);
1608 VAR m
: Module
; term
: Command
; t
: BOOLEAN;
1610 trapViewer
:= NIL; trapChecker
:= NIL; restart
:= NIL;
1611 t
:= terminating
; terminating
:= TRUE
; m
:= modList
;
1612 WHILE m
# NIL DO (* call terminators *)
1613 IF ~static
OR ~t
THEN
1614 term
:= m
.term
; m
.term
:= NIL;
1615 IF term
# NIL THEN term() END
1620 hotFinalizers
:= finalizers
; finalizers
:= NIL;
1622 stdlib
.exit(exitCode
)
1625 PROCEDURE FatalError
* (id
: INTEGER; str
: ARRAY OF CHAR);
1626 VAR res
: stdio
.int
; title
: ARRAY 16 OF CHAR; text
: ARRAY 256 OF SHORTCHAR
;
1628 title
:= "Error xy";
1629 title
[6] := CHR(id
DIV 10 + ORD("0"));
1630 title
[7] := CHR(id
MOD 10 + ORD("0"));
1631 res
:= unistd
.write(2, S
.ADR(title
), 8);
1635 PROCEDURE DefaultTrapViewer
;
1636 VAR out
: ARRAY 256 OF SHORTCHAR
; c
, len
: INTEGER; res
: unistd
.int
; dl
: DLink
;
1638 PROCEDURE WriteString (IN s
: ARRAY OF SHORTCHAR
);
1642 WHILE (len
< LEN(out
) - 1) & (s
[i
] # 0X
) DO out
[len
] := s
[i
]; INC(i
); INC(len
) END
1645 PROCEDURE WriteHex (x
, n
: INTEGER);
1648 IF len
+ n
< LEN(out
) THEN
1651 y
:= x
MOD 16; x
:= x
DIV 16;
1652 IF y
> 9 THEN y
:= y
+ (ORD("A") - ORD("0") - 10) END;
1653 out
[i
] := SHORT(CHR(y
+ ORD("0"))); DEC(i
)
1661 IF len
< LEN(out
) - 1 THEN out
[len
] := 0AX
; INC(len
) END
1666 WriteString("====== ");
1667 IF err
= 129 THEN WriteString("invalid with")
1668 ELSIF err
= 130 THEN WriteString("invalid case")
1669 ELSIF err
= 131 THEN WriteString("function without return")
1670 ELSIF err
= 132 THEN WriteString("type guard")
1671 ELSIF err
= 133 THEN WriteString("implied type guard")
1672 ELSIF err
= 134 THEN WriteString("value out of range")
1673 ELSIF err
= 135 THEN WriteString("index out of range")
1674 ELSIF err
= 136 THEN WriteString("string too long")
1675 ELSIF err
= 137 THEN WriteString("stack overflow")
1676 ELSIF err
= 138 THEN WriteString("integer overflow")
1677 ELSIF err
= 139 THEN WriteString("division by zero")
1678 ELSIF err
= 140 THEN WriteString("infinite real result")
1679 ELSIF err
= 141 THEN WriteString("real underflow")
1680 ELSIF err
= 142 THEN WriteString("real overflow")
1681 ELSIF err
= 143 THEN WriteString("undefined real result")
1682 ELSIF err
= 144 THEN WriteString("not a number")
1683 ELSIF err
= 200 THEN WriteString("keyboard interrupt")
1684 ELSIF err
= 201 THEN WriteString("NIL dereference")
1685 ELSIF err
= 202 THEN WriteString("illegal instruction: ");
1687 ELSIF err
= 203 THEN WriteString("illegal memory read [ad = ");
1688 WriteHex(val
, 8); WriteString("]")
1689 ELSIF err
= 204 THEN WriteString("illegal memory write [ad = ");
1690 WriteHex(val
, 8); WriteString("]")
1691 ELSIF err
= 205 THEN WriteString("illegal execution [ad = ");
1692 WriteHex(val
, 8); WriteString("]")
1693 ELSIF err
= 257 THEN WriteString("out of memory")
1694 ELSIF err
= 10001H
THEN WriteString("bus error")
1695 ELSIF err
= 10002H
THEN WriteString("address error")
1696 ELSIF err
= 10007H
THEN WriteString("fpu error")
1697 ELSIF err
< 0 THEN WriteString("exception #"); WriteHex(-err
, 2)
1698 ELSE err
:= err
DIV 100 * 256 + err
DIV 10 MOD 10 * 16 + err
MOD 10;
1699 WriteString("trap #"); WriteHex(err
, 3)
1701 WriteString(" ======");
1704 (* skip Kernel.DefaultTrapViewer & Kernel.Trap/Kernel.TrapHandler *)
1706 WHILE (c
> 0) & (dl
# NIL) DO
1712 WHILE (c
> 0) & (dl
# NIL) DO
1713 WriteString("- "); WriteString(dl
.name$
); WriteLn
;
1718 res
:= unistd
.write(2, S
.ADR(out
), len
)
1719 END DefaultTrapViewer
;
1721 PROCEDURE TrapCleanup
;
1724 WHILE trapStack
# NIL DO
1725 t
:= trapStack
; trapStack
:= trapStack
.next
; t
.Cleanup
1727 IF (trapChecker
# NIL) & (err
# 128) THEN trapChecker
END
1730 PROCEDURE SetTrapGuard
* (on
: BOOLEAN);
1735 PROCEDURE Try
* (h
: TryHandler
; a
, b
, c
: INTEGER);
1736 VAR oldIsTry
: BOOLEAN; oldTryEnv
: setjmp
.jmp_buf
; oldTryDLink
: DLink
; res
: setjmp
.int
;
1738 oldIsTry
:= isTry
; oldTryEnv
:= tryEnv
; oldTryDLink
:= tryDLink
;
1739 isTry
:= TRUE
; tryDLink
:= GetDLink();
1740 res
:= setjmp
._setjmp(tryEnv
);
1741 IF res
= 0 THEN h(a
, b
, c
) END;
1742 isTry
:= oldIsTry
; tryEnv
:= oldTryEnv
; tryDLink
:= oldTryDLink
1745 PROCEDURE Trap
* (n
: INTEGER);
1749 IF ~secondTrap
THEN trapped
:= FALSE
; secondTrap
:= TRUE
END
1751 IF n
>= 0 THEN err
:= n
1752 ELSE err
:= -n
+ 128
1754 pc
:= 0; sp
:= 0; fp
:= 0; stack
:= 0; val
:= 0;
1760 setjmp
._longjmp(tryEnv
, 1)
1762 IF (err
= 128) OR (err
= 200) & ~intTrap
THEN (* do nothing *)
1763 ELSIF (trapViewer
# NIL) & (restart
# NIL) & ~trapped
& ~guarded
THEN
1764 trapped
:= TRUE
; trapViewer()
1765 ELSE DefaultTrapViewer
1767 trapped
:= FALSE
; secondTrap
:= FALSE
;
1768 IF restart
# NIL THEN
1769 SetDLink(startDLink
);
1770 setjmp
.siglongjmp(startEnv
, 1)
1775 PROCEDURE [ccall
] TrapHandler (signo
: signal
.int
; IN info
: signal
.siginfo_t
; context
: ADDRESS
);
1776 VAR res
: signal
.int
;
1778 IF checkReadable
THEN
1779 setjmp
.siglongjmp(checkReadableEnv
, 1)
1783 IF ~secondTrap
THEN trapped
:= FALSE
; secondTrap
:= TRUE
END
1785 err
:= -signo
; pc
:= 0; sp
:= 0; fp
:= 0; stack
:= baseStack
; val
:= 0;
1788 val
:= info
.si_code
;
1789 pc
:= info
.info
.sigfpe
.si_addr
;
1790 CASE info
.si_code
OF
1791 | signal
.FPE_INTDIV
: err
:= 139 (* division by zero *)
1792 | signal
.FPE_INTOVF
: err
:= 138 (* integer overflow *)
1793 | signal
.FPE_FLTDIV
: err
:= 140 (* fpu: division by zero *)
1794 | signal
.FPE_FLTOVF
: err
:= 142 (* fpu: overflow *)
1795 | signal
.FPE_FLTUND
: err
:= 141 (* fpu: underflow *)
1796 (* !!! | signal.FPE_FLTRES: err := ??? (* fpu: *) *)
1797 | signal
.FPE_FLTINV
: err
:= 143 (* val := opcode *) (* fpu: invalid op *)
1798 (* !!! | signal.FPE_FLTSUB: err := ??? (* fpu: *) *)
1802 val
:= info
.si_code
;
1803 err
:= 200 (* keyboard interrupt *)
1805 val
:= info
.info
.sigsegv
.si_addr
;
1806 err
:= 203 (* illigal read *)
1808 val
:= info
.info
.sigbus
.si_addr
;
1809 err
:= 10001H (* bus error *)
1811 pc
:= info
.info
.sigill
.si_addr
;
1812 err
:= 202; (* illigal instruction *)
1813 IF IsReadable(pc
, pc
+ 4) THEN
1822 setjmp
._longjmp(tryEnv
, 1)
1824 IF (err
= 128) OR (err
= 200) & ~intTrap
THEN (* do nothing *)
1825 ELSIF (trapViewer
# NIL) & (restart
# NIL) & ~trapped
& ~guarded
THEN
1826 trapped
:= TRUE
; trapViewer()
1827 ELSE DefaultTrapViewer
1829 trapped
:= FALSE
; secondTrap
:= FALSE
;
1830 IF restart
# NIL THEN
1831 setjmp
.siglongjmp(startEnv
, 1)
1836 (* -------------------- Initialization --------------------- *)
1838 PROCEDURE InstallTrap (signo
: signal
.int
);
1839 VAR act
: signal
._struct_sigaction
; (* !!! CPfront hack *) res
: signal
.int
;
1841 act
.sa_handler
:= NIL;
1842 res
:= signal
.sigemptyset(act
.sa_mask
);
1843 act
.sa_flags
:= signal
.SA_NODEFER
+ signal
.SA_SIGINFO
;
1844 act
.sa_sigaction
:= TrapHandler
;
1845 res
:= signal
.sigaction(signo
, S
.VAL(signal
.struct_sigaction
, act
), NIL);
1848 PROCEDURE InstallTrapVectors
;
1850 InstallTrap(signal
.SIGFPE
);
1851 InstallTrap(signal
.SIGINT
);
1852 InstallTrap(signal
.SIGSEGV
);
1853 InstallTrap(signal
.SIGBUS
);
1854 InstallTrap(signal
.SIGILL
)
1855 END InstallTrapVectors
;
1857 PROCEDURE RemoveTrapVectors
;
1858 END RemoveTrapVectors
;
1864 baseStack
:= S
.ADR(i
); (* XXX *)
1865 pagesize
:= unistd
.sysconf(unistd
._SC_PAGESIZE
);
1868 allocated
:= 0; total
:= 0; used
:= 0;
1869 sentinelBlock
.size
:= MAX(INTEGER);
1870 sentinel
:= S
.ADR(sentinelBlock
);
1872 REPEAT DEC(i
); free
[i
] := sentinel
UNTIL i
= 0;
1880 InitModule(modList
);
1881 IF ~inDll
THEN Quit(1) END
1885 PROCEDURE [code
] SYSTEM_argCount (): INTEGER "SYSTEM_argCount";
1886 PROCEDURE [code
] SYSTEM_argVector (): ArrStrPtr
"(Kernel_ArrStrPtr)SYSTEM_argVector";
1887 PROCEDURE [code
] SYSTEM_modlist (): Module
"(Kernel_Module)SYSTEM_modlist";
1890 IF modList
= NIL THEN (* only once *)
1891 argc
:= SYSTEM_argCount();
1892 argv
:= SYSTEM_argVector();
1893 modList
:= SYSTEM_modlist();
1894 static
:= init
IN modList
.opts
;
1895 inDll
:= dll
IN modList
.opts
;
1899 IF ~terminating
THEN
1900 terminating
:= TRUE
;