Kernel: fix memory allocation on target powerpc-cpfront-osx

diff --git a/make.sh b/make.sh
index f7dab7da7822f842c5088647d1f7a00c78d487f9..f25d28af9dd5f538c90024ac17b2ceb97757a661 100755 (executable)
--- a/make.sh
+++ b/make.sh
@@ -305,7 +305,11 @@ link_all() {
     DswDocuments DswOpts DswProcs DswHostProcs DswMakeMain
 
   if $_dolink; then
     DswDocuments DswOpts DswProcs DswHostProcs DswMakeMain
 
   if $_dolink; then

-    chmod a+x cpc486 cpl486 cpfront
+    if [ "$_system" = "osx" ]; then
+      chmod a+x cpc486.out cpl486.out cpfront.out
+    else
+      chmod a+x cpc486 cpl486 cpfront
+    fi

   fi
 }
 
   fi
 }
 

diff --git a/src/cpfront/osx/powerpc/Posix/Mod/Csys_wait.cp b/src/cpfront/osx/powerpc/Posix/Mod/Csys_wait.cp
new file mode 100644 (file)
index 0000000..ec95d80
--- /dev/null
+++ b/src/cpfront/osx/powerpc/Posix/Mod/Csys_wait.cp
@@ -0,0 +1,66 @@
+(* !!! just copied from linux, not generated from osx-ppc host *)
+MODULE PosixCsys_wait ['sys/wait.h'];
+
+  IMPORT SYSTEM, PosixCtypes, PosixCsys_types, PosixCsignal;
+
+  TYPE
+    char* = PosixCtypes.char;
+    signed_char* = PosixCtypes.signed_char;
+    unsigned_char* = PosixCtypes.unsigned_char;
+    short* = PosixCtypes.short;
+    short_int* = PosixCtypes.short_int;
+    signed_short* = PosixCtypes.signed_short;
+    signed_short_int* = PosixCtypes.signed_short_int;
+    unsigned_short* = PosixCtypes.unsigned_short;
+    unsigned_short_int* = PosixCtypes.unsigned_short_int;
+    int* = PosixCtypes.int;
+    signed* = PosixCtypes.signed;
+    signed_int* = PosixCtypes.signed_int;
+    unsigned* = PosixCtypes.unsigned;
+    unsigned_int* = PosixCtypes.unsigned_int;
+    long* = PosixCtypes.long;
+    long_int* = PosixCtypes.long_int;
+    signed_long* = PosixCtypes.signed_long;
+    signed_long_int* = PosixCtypes.signed_long_int;
+    unsigned_long* = PosixCtypes.unsigned_long;
+    unsigned_long_int* = PosixCtypes.unsigned_long_int;
+    long_long* = PosixCtypes.long_long;
+    long_long_int* = PosixCtypes.long_long_int;
+    signed_long_long* = PosixCtypes.signed_long_long;
+    signed_long_long_int* = PosixCtypes.signed_long_long_int;
+    unsigned_long_long* = PosixCtypes.unsigned_long_long;
+    unsigned_long_long_int* = PosixCtypes.unsigned_long_long_int;
+    float* = PosixCtypes.float;
+    double* = PosixCtypes.double;
+    long_double* = PosixCtypes.long_double;
+
+  CONST
+    WCONTINUED* = 8;
+    WNOHANG* = 1;
+    WUNTRACED* = 2;
+
+  CONST
+    WEXITED* = 4;
+    WNOWAIT* = 16777216;
+    WSTOPPED* = 2;
+
+  TYPE
+    idtype_t* = INTEGER;
+
+  CONST
+    P_ALL* = 0;
+    P_PGID* = 2;
+    P_PID* = 1;
+
+  TYPE
+    id_t* = PosixCsys_types.id_t;
+    pid_t* = PosixCsys_types.pid_t;
+
+  TYPE
+    siginfo_t* = PosixCsignal.siginfo_t;
+
+  PROCEDURE [ccall] wait* (VAR [nil] wstatus: int): pid_t;
+  PROCEDURE [ccall] waitid* (idtype: idtype_t; id: id_t; VAR [nil] infop: siginfo_t; options: int): int;
+  PROCEDURE [ccall] waitpid* (pid: pid_t; VAR [nil] wstatus: int; options: int): pid_t;
+
+END PosixCsys_wait.

diff --git a/src/cpfront/osx/powerpc/System/Mod/Kernel.cp b/src/cpfront/osx/powerpc/System/Mod/Kernel.cp
new file mode 100644 (file)
index 0000000..019365c
--- /dev/null
+++ b/src/cpfront/osx/powerpc/System/Mod/Kernel.cp
@@ -0,0 +1,1897 @@
+MODULE Kernel;
+
+  IMPORT S := SYSTEM, stdlib := PosixCstdlib, stdio := PosixCstdio,
+    time := PosixCtime, wctype := PosixCwctype, sysmman := PosixCsys_mman,
+    dlfcn := PosixCdlfcn, fcntl := PosixCfcntl, types := PosixCtypes,
+    unistd := PosixCunistd, signal := PosixCsignal, setjmp := PosixCsetjmp,
+    macro := PosixCmacro,
+    LibFFI;
+
+  (* init fpu? *)
+  (* add signal blocking to avoid race conditions in Try/Trap/TrapHandler *)
+  (* add BeepHook for Beep *)
+
+  CONST
+    nameLen* = 256;
+
+    littleEndian* = FALSE;
+    timeResolution* = 1000; (* ticks per second *)
+
+    processor* = 1;  (* generic c *)
+
+    objType* = "ocf"; (* file types *)
+    symType* = "osf";
+    docType* = "odc";
+
+    (* loader constants *)
+    done* = 0;
+    fileNotFound* = 1;
+    syntaxError* = 2;
+    objNotFound* = 3;
+    illegalFPrint* = 4;
+    cyclicImport* = 5;
+    noMem* = 6;
+    commNotFound* = 7;
+    commSyntaxError* = 8;
+    moduleNotFound* = 9;
+
+    any = 1000000;
+
+    strictStackSweep = FALSE;
+    N = 128 DIV 16; (* free lists *)
+
+    (* kernel flags in module desc *)
+    init = 16; dyn = 17; dll = 24; iptrs = 30;
+
+    (* meta interface consts *)
+    mConst = 1; mTyp = 2; mVar = 3; mProc = 4; mField = 5;
+
+  TYPE
+    Name* = ARRAY nameLen OF CHAR;
+    Utf8Name* = ARRAY nameLen OF SHORTCHAR;
+    Command* = PROCEDURE;
+
+    Module* = POINTER TO RECORD [untagged]
+      next-: Module;
+      opts-: SET; (* 0..15: compiler opts, 16..31: kernel flags *)
+      refcnt-: INTEGER; (* <0: module invalidated *)
+      compTime-, loadTime-: ARRAY 6 OF SHORTINT;
+      ext-: INTEGER;  (* currently not used *)
+      term-: Command; (* terminator *)
+      nofimps-, nofptrs-: INTEGER;
+      csize-, dsize-, rsize-: INTEGER;
+      code-, data-, refs-: INTEGER;
+      procBase-, varBase-: INTEGER; (* meta base addresses *)
+      names-: POINTER TO ARRAY [untagged] OF SHORTCHAR; (* names[0] = 0X *)
+      ptrs-: POINTER TO ARRAY [untagged] OF INTEGER;
+      imports-: POINTER TO ARRAY [untagged] OF Module;
+      export-: Directory; (* exported objects (name sorted) *)
+      name-: Utf8Name
+    END;
+
+    Type* = POINTER TO RECORD [untagged]
+      (* record: ptr to method n at offset - 4 * (n+1) *)
+      size-: INTEGER; (* record: size, array: #elem, dyn array: 0, proc: sigfp *)
+      mod-: Module;
+      id-: INTEGER; (* name idx * 256 + lev * 16 + attr * 4 + form *)
+      base-: ARRAY 16 OF Type;  (* signature if form = ProcTyp *)
+      fields-: Directory; (* new fields (declaration order) *)
+      ptroffs-: ARRAY any OF INTEGER  (* array of any length *)
+    END;
+
+    Object* = POINTER TO ObjDesc;
+
+    ObjDesc* = RECORD [untagged]
+      fprint-: INTEGER;
+      offs-: INTEGER; (* pvfprint for record types *)
+      id-: INTEGER; (* name idx * 256 + vis * 16 + mode *)
+      struct-: Type (* id of basic type or pointer to typedesc/signature *)
+    END;
+
+    Directory* = POINTER TO RECORD [untagged]
+      num-: INTEGER;  (* number of entries *)
+      obj-: ARRAY any OF ObjDesc  (* array of any length *)
+    END;
+    
+    Signature* = POINTER TO RECORD [untagged]
+      retStruct-: Type; (* id of basic type or pointer to typedesc or 0 *)
+      num-: INTEGER;  (* number of parameters *)
+      par-: ARRAY any OF RECORD [untagged]  (* parameters *)
+        id-: INTEGER; (* name idx * 256 + kind *)
+        struct-: Type (* id of basic type or pointer to typedesc *)
+      END
+    END;
+
+    Handler* = PROCEDURE;
+
+    Reducer* = POINTER TO ABSTRACT RECORD
+      next: Reducer
+    END;
+
+    Identifier* = ABSTRACT RECORD
+      typ*: INTEGER;
+      obj-: ANYPTR
+    END;
+
+    TrapCleaner* = POINTER TO ABSTRACT RECORD
+      next: TrapCleaner
+    END;
+
+    TryHandler* = PROCEDURE (a, b, c: INTEGER);
+
+    (* meta extension suport *)
+
+    ItemExt* = POINTER TO ABSTRACT RECORD END;
+
+    ItemAttr* = RECORD
+      obj*, vis*, typ*, adr*: INTEGER;
+      mod*: Module;
+      desc*: Type;
+      ptr*: S.PTR;
+      ext*: ItemExt
+    END;
+
+    Hook* = POINTER TO ABSTRACT RECORD END;
+
+    LoaderHook* = POINTER TO ABSTRACT RECORD (Hook) 
+      res*: INTEGER;
+      importing*, imported*, object*: ARRAY 256 OF CHAR
+    END;
+
+    Block = POINTER TO RECORD [untagged]
+      tag: Type;
+      last: INTEGER;    (* arrays: last element *)
+      actual: INTEGER;  (* arrays: used during mark phase *)
+      first: INTEGER    (* arrays: first element *)
+    END;
+
+    FreeBlock = POINTER TO FreeDesc;
+
+    FreeDesc = RECORD [untagged]
+      tag: Type;    (* f.tag = ADR(f.size) *)
+      size: INTEGER;
+      next: FreeBlock
+    END;
+
+    Cluster = POINTER TO RECORD [untagged]
+      size: INTEGER;  (* total size *)
+      next: Cluster;
+      max: INTEGER  (* exe: reserved size, dll: original address *)
+      (* start of first block *)
+    END;
+
+    FList = POINTER TO RECORD
+      next: FList;
+      blk: Block;
+      iptr, aiptr: BOOLEAN
+    END;
+
+    CList = POINTER TO RECORD
+      next: CList;
+      do: Command;
+      trapped: BOOLEAN
+    END;
+
+
+    PtrType = RECORD v: S.PTR END;  (* used for array of pointer *)
+    Char8Type = RECORD v: SHORTCHAR END;
+    Char16Type = RECORD v: CHAR END;
+    Int8Type = RECORD v: BYTE END;
+    Int16Type = RECORD v: SHORTINT END;
+    Int32Type = RECORD v: INTEGER END;
+    Int64Type = RECORD v: LONGINT END;
+    BoolType = RECORD v: BOOLEAN END;
+    SetType = RECORD v: SET END;
+    Real32Type = RECORD v: SHORTREAL END;
+    Real64Type = RECORD v: REAL END;
+    ProcType = RECORD v: PROCEDURE END;
+    UPtrType = RECORD v: INTEGER END;
+    StrPtr = POINTER TO ARRAY [untagged] OF SHORTCHAR;
+
+    (* SYSTEM.h -> SYSTEM_DLINK *)
+    DLink = POINTER TO RECORD [untagged]
+      next: DLink;
+      name: StrPtr
+    END;
+    ArrStrPtr = POINTER TO ARRAY [untagged] OF StrPtr;
+
+    ADDRESS* = types.Pvoid;
+
+  VAR
+    baseStack: INTEGER;
+    root: Cluster;
+    modList-: Module;
+    trapCount-: INTEGER;
+    err-, pc-, sp-, fp-, stack-, val-: INTEGER;
+
+    isTry, checkReadable: BOOLEAN;
+    startEnv, checkReadableEnv: setjmp.sigjmp_buf;
+    tryEnv: setjmp.jmp_buf;
+    startDLink, tryDLink: DLink;
+
+    argc-: INTEGER;
+    argv-: ArrStrPtr;
+    pagesize: unistd.long;
+
+    free: ARRAY N OF FreeBlock; (* free list *)
+    sentinelBlock: FreeDesc;
+    sentinel: FreeBlock;
+    candidates: ARRAY 1024 OF INTEGER;
+    nofcand: INTEGER;
+    allocated: INTEGER; (* bytes allocated on BlackBox heap *)
+    total: INTEGER; (* current total size of BlackBox heap *)
+    used: INTEGER;  (* bytes allocated on system heap *)
+    finalizers: FList;
+    hotFinalizers: FList;
+    cleaners: CList;
+    reducers: Reducer;
+    trapStack: TrapCleaner;
+    actual: Module; (* valid during module initialization *)
+
+    trapViewer, trapChecker: Handler;
+    trapped, guarded, secondTrap: BOOLEAN;
+    interrupted: BOOLEAN;
+    static, inDll, terminating: BOOLEAN;
+    restart: Command;
+
+    loader: LoaderHook;
+    loadres: INTEGER;
+
+    wouldFinalize: BOOLEAN;
+
+    watcher*: PROCEDURE (event: INTEGER); (* for debugging *)
+
+    intTrap*: BOOLEAN;
+
+  PROCEDURE Erase (adr, words: INTEGER);
+  BEGIN
+    ASSERT(words >= 0, 20);
+    WHILE words > 0 DO
+      S.PUT(adr, 0);
+      INC(adr, 4);
+      DEC(words)
+    END
+  END Erase;
+
+
+  PROCEDURE (VAR id: Identifier) Identified* (): BOOLEAN, NEW, ABSTRACT;
+  PROCEDURE (r: Reducer) Reduce* (full: BOOLEAN), NEW, ABSTRACT;
+  PROCEDURE (c: TrapCleaner) Cleanup*,  NEW, EMPTY;
+
+  (* meta extension suport *)
+
+  PROCEDURE (e: ItemExt) Lookup* (name: ARRAY OF CHAR; VAR i: ANYREC), NEW, ABSTRACT;
+  PROCEDURE (e: ItemExt) Index* (index: INTEGER; VAR elem: ANYREC), NEW, ABSTRACT;
+  PROCEDURE (e: ItemExt) Deref* (VAR ref: ANYREC), NEW, ABSTRACT;
+
+  PROCEDURE (e: ItemExt) Valid* (): BOOLEAN, NEW, ABSTRACT;
+  PROCEDURE (e: ItemExt) Size* (): INTEGER, NEW, ABSTRACT;
+  PROCEDURE (e: ItemExt) BaseTyp* (): INTEGER, NEW, ABSTRACT;
+  PROCEDURE (e: ItemExt) Len* (): INTEGER, NEW, ABSTRACT;
+
+  PROCEDURE (e: ItemExt) Call* (OUT ok: BOOLEAN), NEW, ABSTRACT;
+  PROCEDURE (e: ItemExt) BoolVal* (): BOOLEAN, NEW, ABSTRACT;
+  PROCEDURE (e: ItemExt) PutBoolVal* (x: BOOLEAN), NEW, ABSTRACT;
+  PROCEDURE (e: ItemExt) CharVal* (): CHAR, NEW, ABSTRACT;
+  PROCEDURE (e: ItemExt) PutCharVal* (x: CHAR), NEW, ABSTRACT;
+  PROCEDURE (e: ItemExt) IntVal* (): INTEGER, NEW, ABSTRACT;
+  PROCEDURE (e: ItemExt) PutIntVal* (x: INTEGER), NEW, ABSTRACT;
+  PROCEDURE (e: ItemExt) LongVal* (): LONGINT, NEW, ABSTRACT;
+  PROCEDURE (e: ItemExt) PutLongVal* (x: LONGINT), NEW, ABSTRACT;
+  PROCEDURE (e: ItemExt) RealVal* (): REAL, NEW, ABSTRACT;
+  PROCEDURE (e: ItemExt) PutRealVal* (x: REAL), NEW, ABSTRACT;
+  PROCEDURE (e: ItemExt) SetVal* (): SET, NEW, ABSTRACT;
+  PROCEDURE (e: ItemExt) PutSetVal* (x: SET), NEW, ABSTRACT;
+  PROCEDURE (e: ItemExt) PtrVal* (): ANYPTR, NEW, ABSTRACT;
+  PROCEDURE (e: ItemExt) PutPtrVal* (x: ANYPTR), NEW, ABSTRACT;
+  PROCEDURE (e: ItemExt) GetSStringVal* (OUT x: ARRAY OF SHORTCHAR;
+                                  OUT ok: BOOLEAN), NEW, ABSTRACT;
+  PROCEDURE (e: ItemExt) PutSStringVal* (IN x: ARRAY OF SHORTCHAR;
+                                  OUT ok: BOOLEAN), NEW, ABSTRACT;
+  PROCEDURE (e: ItemExt) GetStringVal* (OUT x: ARRAY OF CHAR; OUT ok: BOOLEAN), NEW, ABSTRACT;
+  PROCEDURE (e: ItemExt) PutStringVal* (IN x: ARRAY OF CHAR; OUT ok: BOOLEAN), NEW, ABSTRACT;
+
+  (* -------------------- miscellaneous tools -------------------- *)
+
+  PROCEDURE IsUpper* (ch: CHAR): BOOLEAN;
+  BEGIN
+    RETURN wctype.iswupper(ORD(ch)) # 0
+  END IsUpper;
+
+  PROCEDURE Upper* (ch: CHAR): CHAR;
+  BEGIN
+    RETURN CHR(wctype.towupper(ORD(ch)))
+  END Upper;
+
+  PROCEDURE IsLower* (ch: CHAR): BOOLEAN;
+  BEGIN
+    RETURN wctype.iswlower(ORD(ch)) # 0
+  END IsLower;
+
+  PROCEDURE Lower* (ch: CHAR): CHAR;
+  BEGIN
+    RETURN CHR(wctype.towlower(ORD(ch)))
+  END Lower;
+
+  PROCEDURE IsAlpha* (ch: CHAR): BOOLEAN;
+  BEGIN
+    RETURN wctype.iswalpha(ORD(ch)) # 0
+  END IsAlpha;
+
+  PROCEDURE Utf8ToString* (IN in: ARRAY OF SHORTCHAR; OUT out: ARRAY OF CHAR;  OUT res: INTEGER);
+    VAR i, j, val, max: INTEGER; ch: SHORTCHAR;
+    
+    PROCEDURE FormatError();
+    BEGIN out := in$; res := 2 (*format error*)
+    END FormatError;
+    
+  BEGIN
+    ch := in[0]; i := 1; j := 0; max := LEN(out) - 1;
+    WHILE (ch # 0X) & (j < max) DO
+      IF ch < 80X THEN
+        out[j] := ch; INC(j)
+      ELSIF ch < 0E0X THEN
+        val := ORD(ch) - 192;
+        IF val < 0 THEN FormatError; RETURN END ;
+        ch := in[i]; INC(i); val := val * 64 + ORD(ch) - 128;
+        IF (ch < 80X) OR (ch >= 0E0X) THEN FormatError; RETURN END ;
+        out[j] := CHR(val); INC(j)
+      ELSIF ch < 0F0X THEN 
+        val := ORD(ch) - 224;
+        ch := in[i]; INC(i); val := val * 64 + ORD(ch) - 128;
+        IF (ch < 80X) OR (ch >= 0E0X) THEN FormatError; RETURN END ;
+        ch := in[i]; INC(i); val := val * 64 + ORD(ch) - 128;
+        IF (ch < 80X) OR (ch >= 0E0X) THEN FormatError; RETURN END ;
+        out[j] := CHR(val); INC(j)
+      ELSE
+        FormatError; RETURN
+      END ;
+      ch := in[i]; INC(i)
+    END;
+    out[j] := 0X;
+    IF ch = 0X THEN res := 0 (*ok*) ELSE res := 1 (*truncated*) END
+  END Utf8ToString;
+
+  PROCEDURE StringToUtf8* (IN in: ARRAY OF CHAR; OUT out: ARRAY OF SHORTCHAR; OUT res: INTEGER);
+    VAR i, j, val, max: INTEGER;
+  BEGIN
+    i := 0; j := 0; max := LEN(out) - 3;
+    WHILE (in[i] # 0X) & (j < max) DO
+      val := ORD(in[i]); INC(i);
+      IF val < 128 THEN
+        out[j] := SHORT(CHR(val)); INC(j)
+      ELSIF val < 2048 THEN
+        out[j] := SHORT(CHR(val DIV 64 + 192)); INC(j);
+        out[j] := SHORT(CHR(val MOD 64 + 128)); INC(j)
+      ELSE
+        out[j] := SHORT(CHR(val DIV 4096 + 224)); INC(j); 
+        out[j] := SHORT(CHR(val DIV 64 MOD 64 + 128)); INC(j);
+        out[j] := SHORT(CHR(val MOD 64 + 128)); INC(j)
+      END;
+    END;
+    out[j] := 0X;
+    IF in[i] = 0X THEN res := 0 (*ok*) ELSE res :=  1 (*truncated*) END
+  END StringToUtf8;
+
+  PROCEDURE SplitName* (name: ARRAY OF CHAR; VAR head, tail: ARRAY OF CHAR);
+    (* portable *)
+    VAR i, j: INTEGER; ch, lch: CHAR;
+  BEGIN
+    i := 0; ch := name[0];
+    IF ch # 0X THEN
+      REPEAT
+        head[i] := ch; lch := ch; INC(i); ch := name[i]
+      UNTIL (ch = 0X) OR (ch = ".") OR IsUpper(ch) & ~IsUpper(lch);
+      IF ch = "." THEN i := 0; ch := name[0] END;
+      head[i] := 0X; j := 0;
+      WHILE ch # 0X DO tail[j] := ch; INC(i); INC(j); ch := name[i] END;
+      tail[j] := 0X;
+      IF tail = "" THEN tail := head$; head := "" END
+    ELSE head := ""; tail := ""
+    END
+  END SplitName;
+
+  PROCEDURE MakeFileName* (VAR name: ARRAY OF CHAR; type: ARRAY OF CHAR);
+    VAR i, j: INTEGER; ext: ARRAY 8 OF CHAR; ch: CHAR;
+  BEGIN
+    i := 0;
+    WHILE (name[i] # 0X) & (name[i] # ".") DO INC(i) END;
+    IF name[i] = "." THEN
+      IF name[i + 1] = 0X THEN name[i] := 0X END
+    ELSE
+      IF type = "" THEN ext := docType ELSE ext := type$ END;
+      IF i < LEN(name) - LEN(ext$) - 1 THEN
+        name[i] := "."; INC(i); j := 0; ch := ext[0];
+        WHILE ch # 0X DO
+          name[i] := Lower(ch); INC(i); INC(j); ch := ext[j]
+        END;
+        name[i] := 0X
+      END
+    END
+  END MakeFileName;
+
+(*
+  PROCEDURE Time* (): LONGINT;
+    VAR res: time.int; tp: time.struct_timespec;
+  BEGIN
+    ASSERT(timeResolution >= 1);
+    ASSERT(timeResolution <= 1000000000);
+    res := time.clock_gettime(time.CLOCK_MONOTONIC, tp);
+    ASSERT(res = 0, 100);
+    RETURN tp.tv_sec * LONG(timeResolution) + tp.tv_nsec DIV LONG(1000000000 DIV timeResolution)
+  END Time;
+*)
+
+  PROCEDURE Time* (): LONGINT;
+  BEGIN
+    RETURN 0 (* !!! *)
+  END Time;
+
+  PROCEDURE Beep*;
+    (* !!! *)
+  END Beep;
+
+  PROCEDURE SearchProcVar* (var: INTEGER; VAR m: Module; VAR adr: INTEGER);
+  BEGIN
+    adr := var; m := NIL;
+    IF var # 0 THEN
+      m := modList;
+      WHILE (m # NIL) & ((var < m.code) OR (var >= m.code + m.csize)) DO m := m.next END;
+      IF m # NIL THEN DEC(adr, m.code) END
+    END
+  END SearchProcVar;
+
+  (* -------------------- system memory management --------------------- *)
+
+  PROCEDURE [code] MAP_ANON (): INTEGER "MAP_ANON";
+
+  PROCEDURE AllocMem (size: sysmman.size_t; VAR max: sysmman.size_t): ADDRESS;
+    CONST msgstr = "mmap failed errno "; idx = LEN(msgstr);
+    VAR res: fcntl.int; ptr: ADDRESS; msg: ARRAY idx + 5 OF SHORTCHAR;
+  BEGIN
+    max := (size + pagesize - 1) DIV pagesize * pagesize;
+    ptr := sysmman.mmap(0, max, sysmman.PROT_READ + sysmman.PROT_WRITE, sysmman.MAP_PRIVATE + MAP_ANON(), -1, 0);
+    IF ptr = sysmman.MAP_FAILED THEN
+      res := macro.errno();
+      msg := msgstr;
+      msg[idx + 0] := SHORT(CHR(ORD("0") + res DIV 100 MOD 10));
+      msg[idx + 1] := SHORT(CHR(ORD("0") + res DIV 10 MOD 10));
+      msg[idx + 2] := SHORT(CHR(ORD("0") + res MOD 10));
+      msg[idx + 3] := 0AX;
+      msg[idx + 4] := 0X;
+      res := unistd.write(2, S.ADR(msg), LEN(msg$));
+      ptr := 0
+    END;
+    RETURN ptr
+  END AllocMem;
+
+  PROCEDURE FreeMem (adr: ADDRESS; size: sysmman.size_t);
+    VAR res: sysmman.int;
+  BEGIN
+    size := (size + pagesize - 1) DIV pagesize * pagesize;
+    res := sysmman.munmap(adr, size);
+    ASSERT(res = 0, 100)
+  END FreeMem;
+
+  PROCEDURE AllocHeapMem (size: INTEGER; VAR c: Cluster);
+    CONST N = 65536;  (* cluster size for dll *)
+    VAR adr, allocated, newsize: INTEGER;
+  BEGIN
+    INC(size, 16);
+    ASSERT(size > 0, 100); adr := 0;
+    IF size < N THEN
+      adr := AllocMem(N, newsize);
+      allocated := newsize
+    END;
+    IF adr = 0 THEN
+      adr := AllocMem(size, newsize);
+      allocated := newsize
+    END;
+    IF adr = 0 THEN c := NIL
+    ELSE
+      c := S.VAL(Cluster, (adr + 15) DIV 16 * 16); c.max := adr;
+      c.size := allocated - (S.VAL(INTEGER, c) - adr);
+      INC(used, c.size); INC(total, c.size)
+    END;
+    ASSERT((adr = 0) OR (adr MOD 16 = 0) & (c.size >= size), 101);
+    (* post: (c = NIL) OR (c MOD 16 = 0) & (c.size >= size) *)
+  END AllocHeapMem;
+
+  PROCEDURE FreeHeapMem (c: Cluster);
+  BEGIN
+    DEC(used, c.size); DEC(total, c.size);
+    FreeMem(S.VAL(ADDRESS, c.max), c.size)
+  END FreeHeapMem;
+
+  PROCEDURE HeapFull (size: INTEGER): BOOLEAN;
+  BEGIN
+    RETURN TRUE
+  END HeapFull;
+
+  PROCEDURE AllocModMem* (descSize, modSize: INTEGER; VAR descAdr, modAdr: INTEGER);
+  BEGIN
+    descAdr := 0; modAdr := 0;
+    descAdr := AllocMem(descSize, descSize);
+    IF descAdr # 0 THEN
+      modAdr := AllocMem(modSize, modSize);
+      IF modAdr = 0 THEN
+        FreeMem(descAdr, descSize)
+      ELSE
+        INC(used, descSize + modSize)
+      END
+    END
+  END AllocModMem;
+
+  PROCEDURE DeallocModMem* (descSize, modSize, descAdr, modAdr: INTEGER);
+  BEGIN
+    FreeMem(descAdr, descSize);
+    FreeMem(modAdr, modSize);
+    DEC(used, descSize + modSize)
+  END DeallocModMem;
+
+  PROCEDURE InvalModMem (modSize, modAdr: INTEGER);
+  BEGIN
+    FreeMem(modAdr, modSize)
+  END InvalModMem;
+
+  PROCEDURE IsReadable* (from, to: INTEGER): BOOLEAN;
+    VAR r: BOOLEAN; jmp: setjmp.sigjmp_buf; res: setjmp.int; i: INTEGER; x: BYTE;
+  BEGIN
+    r := checkReadable;
+    jmp := checkReadableEnv;
+    checkReadable := TRUE;
+    res := setjmp.sigsetjmp(checkReadableEnv, 1);
+    IF res = 0 THEN
+      IF from <= to THEN
+        FOR i := from TO to DO
+          S.GET(i, x)
+        END
+      ELSE
+        FOR i := to TO from BY -1 DO
+          S.GET(i, x)
+        END
+      END
+    END;
+    checkReadableEnv := jmp;
+    checkReadable := r;
+    RETURN res = 0
+  END IsReadable;
+
+  (* --------------------- NEW implementation (portable) -------------------- *)
+
+  PROCEDURE^ NewBlock (size: INTEGER): Block;
+
+  PROCEDURE NewRec* (typ: INTEGER): INTEGER;  (* implementation of NEW(ptr) *)
+    VAR size, adr: INTEGER; b: Block; tag: Type; l: FList;
+  BEGIN
+    IF ~ODD(typ) THEN
+      tag := S.VAL(Type, typ);
+      b := NewBlock(tag.size);
+      IF b # NIL THEN
+        b.tag := tag;
+        S.GET(typ - 4, size);
+        IF size # 0 THEN (* record uses a finalizer *)
+          l := S.VAL(FList, S.ADR(b.last)); (* anchor new object! *)
+          l := S.VAL(FList, NewRec(S.TYP(FList)));  (* NEW(l) *)
+          l.blk := b; l.next := finalizers; finalizers := l
+        END;
+        adr := S.ADR(b.last)
+      ELSE
+        adr := 0
+      END
+    ELSE
+      HALT(100)  (* COM interface pointers not supported *)
+    END;
+    RETURN adr
+  END NewRec;
+
+  PROCEDURE NewArr* (eltyp, nofelem, nofdim: INTEGER): INTEGER; (* impl. of NEW(ptr, dim0, dim1, ...) *)
+    VAR b: Block; size, headSize: INTEGER; t: Type;
+  BEGIN
+    CASE eltyp OF
+    | -1: HALT(100)  (* COM interface pointers not supported *)
+    | 0: eltyp := S.ADR(PtrType)
+    | 1: eltyp := S.ADR(Char8Type)
+    | 2: eltyp := S.ADR(Int16Type)
+    | 3: eltyp := S.ADR(Int8Type)
+    | 4: eltyp := S.ADR(Int32Type)
+    | 5: eltyp := S.ADR(BoolType)
+    | 6: eltyp := S.ADR(SetType)
+    | 7: eltyp := S.ADR(Real32Type)
+    | 8: eltyp := S.ADR(Real64Type)
+    | 9: eltyp := S.ADR(Char16Type)
+    | 10: eltyp := S.ADR(Int64Type)
+    | 11: eltyp := S.ADR(ProcType)
+    | 12: eltyp := S.ADR(UPtrType)
+    ELSE
+      ASSERT(~ODD(eltyp), 101)  (* COM interface pointers not supported *)
+    END;
+    t := S.VAL(Type, eltyp);
+    headSize := 4 * nofdim + 12;
+    size := headSize + nofelem * t.size;
+    b := NewBlock(size);
+    IF b # NIL THEN
+      b.tag := S.VAL(Type, eltyp + 2);  (* tag + array mark *)
+      b.last := S.ADR(b.last) + size - t.size;  (* pointer to last elem *)
+      b.first := S.ADR(b.last) + headSize;  (* pointer to first elem *)
+      RETURN S.ADR(b.last)
+    ELSE
+      RETURN 0
+    END;
+  END NewArr;
+
+  (* -------------------- handler installation (portable) --------------------- *)
+
+  PROCEDURE ThisFinObj* (VAR id: Identifier): ANYPTR;
+    VAR l: FList;
+  BEGIN
+    ASSERT(id.typ # 0, 100);
+    l := finalizers;
+    WHILE l # NIL DO
+      IF S.VAL(INTEGER, l.blk.tag) = id.typ THEN
+        id.obj := S.VAL(ANYPTR, S.ADR(l.blk.last));
+        IF id.Identified() THEN RETURN id.obj END
+      END;
+      l := l.next
+    END;
+    RETURN NIL
+  END ThisFinObj;
+
+  PROCEDURE InstallReducer* (r: Reducer);
+  BEGIN
+    r.next := reducers; reducers := r
+  END InstallReducer;
+
+  PROCEDURE InstallTrapViewer* (h: Handler);
+  BEGIN
+    trapViewer := h
+  END InstallTrapViewer;
+
+  PROCEDURE InstallTrapChecker* (h: Handler);
+  BEGIN
+    trapChecker := h
+  END InstallTrapChecker;
+
+  PROCEDURE PushTrapCleaner* (c: TrapCleaner);
+    VAR t: TrapCleaner;
+  BEGIN
+    t := trapStack; WHILE (t # NIL) & (t # c) DO t := t.next END;
+    ASSERT(t = NIL, 20);
+    c.next := trapStack; trapStack := c
+  END PushTrapCleaner;
+
+  PROCEDURE PopTrapCleaner* (c: TrapCleaner);
+    VAR t: TrapCleaner;
+  BEGIN
+    t := NIL;
+    WHILE (trapStack # NIL) & (t # c) DO
+      t := trapStack; trapStack := trapStack.next
+    END
+  END PopTrapCleaner;
+
+  PROCEDURE InstallCleaner* (p: Command);
+    VAR c: CList;
+  BEGIN
+    c := S.VAL(CList, NewRec(S.TYP(CList)));  (* NEW(c) *)
+    c.do := p; c.trapped := FALSE; c.next := cleaners; cleaners := c
+  END InstallCleaner;
+
+  PROCEDURE RemoveCleaner* (p: Command);
+    VAR c0, c: CList;
+  BEGIN
+    c := cleaners; c0 := NIL;
+    WHILE (c # NIL) & (c.do # p) DO c0 := c; c := c.next END;
+    IF c # NIL THEN
+      IF c0 = NIL THEN cleaners := cleaners.next ELSE c0.next := c.next END
+    END
+  END RemoveCleaner;
+
+  PROCEDURE Cleanup*;
+    VAR c, c0: CList;
+  BEGIN
+    c := cleaners; c0 := NIL;
+    WHILE c # NIL DO
+      IF ~c.trapped THEN
+        c.trapped := TRUE; c.do; c.trapped := FALSE; c0 := c
+      ELSE
+        IF c0 = NIL THEN cleaners := cleaners.next
+        ELSE c0.next := c.next
+        END
+      END;
+      c := c.next
+    END
+  END Cleanup;
+
+  (* -------------------- meta information (portable) --------------------- *)
+
+  PROCEDURE (h: LoaderHook) ThisMod* (IN name: ARRAY OF CHAR): Module, NEW, ABSTRACT;
+
+  PROCEDURE SetLoaderHook*(h: LoaderHook);
+  BEGIN
+    loader := h
+  END SetLoaderHook;
+
+  PROCEDURE InitModule (mod: Module); (* initialize linked modules *)
+    VAR body: Command;
+  BEGIN
+    IF ~(dyn IN mod.opts) & (mod.next # NIL) & ~(init IN mod.next.opts) THEN InitModule(mod.next) END;
+    IF ~(init IN mod.opts) THEN
+      body := S.VAL(Command, mod.code);
+      INCL(mod.opts, init);
+      actual := mod;
+      body(); actual := NIL
+    END
+  END InitModule;
+
+  PROCEDURE ThisLoadedMod* (IN name: ARRAY OF CHAR): Module;  (* loaded modules only *)
+    VAR m: Module; res: INTEGER; n: Utf8Name;
+  BEGIN
+    StringToUtf8(name, n, res); ASSERT(res = 0);
+    loadres := done;
+    m := modList;
+    WHILE (m # NIL) & ((m.name # n) OR (m.refcnt < 0)) DO m := m.next END;
+    IF (m # NIL) & ~(init IN m.opts) THEN InitModule(m) END;
+    IF m = NIL THEN loadres := moduleNotFound END;
+    RETURN m
+  END ThisLoadedMod;
+
+  PROCEDURE ThisMod* (IN name: ARRAY OF CHAR): Module;
+  BEGIN
+    IF loader # NIL THEN
+      loader.res := done;
+      RETURN loader.ThisMod(name)
+    ELSE
+      RETURN ThisLoadedMod(name)
+    END
+  END ThisMod;
+
+  PROCEDURE LoadMod* (IN name: ARRAY OF CHAR);
+    VAR m: Module;
+  BEGIN
+    m := ThisMod(name)
+  END LoadMod;
+
+  PROCEDURE GetLoaderResult* (OUT res: INTEGER; OUT importing, imported, object: ARRAY OF CHAR);
+  BEGIN
+    IF loader # NIL THEN
+      res := loader.res;
+      importing := loader.importing$;
+      imported := loader.imported$;
+      object := loader.object$
+    ELSE
+      res := loadres;
+      importing := "";
+      imported := "";
+      object := ""
+    END
+  END GetLoaderResult;
+
+  PROCEDURE ThisObject* (mod: Module; IN name: ARRAY OF CHAR): Object;
+    VAR l, r, m, res: INTEGER; p: StrPtr; n: Utf8Name;
+  BEGIN
+    StringToUtf8(name, n, res); ASSERT(res = 0);
+    l := 0; r := mod.export.num;
+    WHILE l < r DO  (* binary search *)
+      m := (l + r) DIV 2;
+      p := S.VAL(StrPtr, S.ADR(mod.names[mod.export.obj[m].id DIV 256]));
+      IF p^ = n THEN RETURN S.VAL(Object, S.ADR(mod.export.obj[m])) END;
+      IF p^ < n THEN l := m + 1 ELSE r := m END
+    END;
+    RETURN NIL
+  END ThisObject;
+
+  PROCEDURE ThisDesc* (mod: Module; fprint: INTEGER): Object;
+    VAR i, n: INTEGER;
+  BEGIN
+    i := 0; n := mod.export.num;
+    WHILE (i < n) & (mod.export.obj[i].id DIV 256 = 0) DO 
+      IF mod.export.obj[i].offs = fprint THEN RETURN S.VAL(Object, S.ADR(mod.export.obj[i])) END;
+      INC(i)
+    END;
+    RETURN NIL
+  END ThisDesc;
+
+  PROCEDURE ThisField* (rec: Type; IN name: ARRAY OF CHAR): Object;
+    VAR n, res: INTEGER; p: StrPtr; obj: Object; m: Module; nn: Utf8Name;
+  BEGIN
+    StringToUtf8(name, nn, res); ASSERT(res = 0);
+    m := rec.mod;
+    obj := S.VAL(Object, S.ADR(rec.fields.obj[0])); n := rec.fields.num;
+    WHILE n > 0 DO
+      p := S.VAL(StrPtr, S.ADR(m.names[obj.id DIV 256]));
+      IF p^ = nn THEN RETURN obj END;
+      DEC(n); INC(S.VAL(INTEGER, obj), 16)
+    END;
+    RETURN NIL
+  END ThisField;
+
+  PROCEDURE ThisCommand* (mod: Module; IN name: ARRAY OF CHAR): Command;
+    VAR x: Object; sig: Signature;
+  BEGIN
+    x := ThisObject(mod, name);
+    IF (x # NIL) & (x.id MOD 16 = mProc) THEN
+      sig := S.VAL(Signature, x.struct);
+      IF (sig.retStruct = NIL) & (sig.num = 0) THEN RETURN S.VAL(Command, mod.procBase + x.offs) END
+    END;
+    RETURN NIL
+  END ThisCommand;
+
+  PROCEDURE ThisType* (mod: Module; IN name: ARRAY OF CHAR): Type;
+    VAR x: Object;
+  BEGIN
+    x := ThisObject(mod, name);
+    IF (x # NIL) & (x.id MOD 16 = mTyp) & (S.VAL(INTEGER, x.struct) DIV 256 # 0) THEN
+      RETURN x.struct
+    ELSE
+      RETURN NIL
+    END
+  END ThisType;
+
+  PROCEDURE TypeOf* (IN rec: ANYREC): Type;
+  BEGIN
+    RETURN S.VAL(Type, S.TYP(rec))
+  END TypeOf;
+
+  PROCEDURE LevelOf* (t: Type): SHORTINT;
+  BEGIN
+    RETURN SHORT(t.id DIV 16 MOD 16)
+  END LevelOf;
+
+  PROCEDURE NewObj* (VAR o: S.PTR; t: Type);
+    VAR i: INTEGER;
+  BEGIN
+    IF t.size = -1 THEN o := NIL
+    ELSE
+      i := 0; WHILE t.ptroffs[i] >= 0 DO INC(i) END;
+      IF t.ptroffs[i+1] >= 0 THEN INC(S.VAL(INTEGER, t)) END; (* with interface pointers *)
+      o := S.VAL(S.PTR, NewRec(S.VAL(INTEGER, t)))  (* generic NEW *)
+    END
+  END NewObj;
+
+  PROCEDURE GetModName* (mod: Module; OUT name: Name);
+    VAR res: INTEGER;
+  BEGIN
+    Utf8ToString(mod.name, name, res); ASSERT(res = 0)
+  END GetModName;
+
+  PROCEDURE GetObjName* (mod: Module; obj: Object; OUT name: Name);
+    VAR p: StrPtr; res: INTEGER;
+  BEGIN
+    p := S.VAL(StrPtr, S.ADR(mod.names[obj.id DIV 256]));
+    Utf8ToString(p^$, name, res); ASSERT(res = 0)
+  END GetObjName;
+
+  PROCEDURE GetTypeName* (t: Type; OUT name: Name);
+    VAR p: StrPtr; res: INTEGER;
+  BEGIN
+    p := S.VAL(StrPtr, S.ADR(t.mod.names[t.id DIV 256]));
+    Utf8ToString(p^$, name, res); ASSERT(res = 0)
+  END GetTypeName;
+
+  PROCEDURE RegisterMod* (mod: Module);
+    VAR i: INTEGER; epoch: time.time_t; tm: time.struct_tm; ptm: time.Pstruct_tm;
+  BEGIN
+    mod.next := modList; modList := mod; mod.refcnt := 0; INCL(mod.opts, dyn); i := 0;
+    WHILE i < mod.nofimps DO
+      IF mod.imports[i] # NIL THEN INC(mod.imports[i].refcnt) END;
+      INC(i)
+    END;
+    epoch := time.time(NIL);
+    ptm := time.localtime_r(epoch, tm);
+    IF ptm # NIL THEN
+      mod.loadTime[0] := SHORT(tm.tm_year + 1900);
+      mod.loadTime[1] := SHORT(tm.tm_mon + 1);
+      mod.loadTime[2] := SHORT(tm.tm_mday);
+      mod.loadTime[3] := SHORT(tm.tm_hour);
+      mod.loadTime[4] := SHORT(tm.tm_min);
+      mod.loadTime[5] := SHORT(tm.tm_sec)
+    ELSE
+      mod.loadTime[0] := 0;
+      mod.loadTime[1] := 0;
+      mod.loadTime[2] := 0;
+      mod.loadTime[3] := 0;
+      mod.loadTime[4] := 0;
+      mod.loadTime[5] := 0
+    END;
+    IF ~(init IN mod.opts) THEN InitModule(mod) END
+  END RegisterMod;
+
+  PROCEDURE^ Collect*;
+
+  PROCEDURE UnloadMod* (mod: Module);
+    VAR i: INTEGER; t: Command;
+  BEGIN
+    IF mod.refcnt = 0 THEN
+      t := mod.term; mod.term := NIL;
+      IF t # NIL THEN t() END;  (* terminate module *)
+      i := 0;
+      WHILE i < mod.nofptrs DO  (* release global pointers *)
+        S.PUT(mod.varBase + mod.ptrs[i], 0); INC(i)
+      END;
+      Collect;  (* call finalizers *)
+      i := 0;
+      WHILE i < mod.nofimps DO  (* release imported modules *)
+        IF mod.imports[i] # NIL THEN DEC(mod.imports[i].refcnt) END;
+        INC(i)
+      END;
+      mod.refcnt := -1;
+      IF dyn IN mod.opts THEN (* release memory *)
+        InvalModMem(mod.data + mod.dsize - mod.refs, mod.refs)
+      END
+    END
+  END UnloadMod;
+
+  (* -------------------- dynamic procedure call  --------------------- *)
+
+  (*
+    type           par
+    32 bit scalar  value
+    64 bit scalar  low hi
+    var scalar     address
+    record         address tag
+    array          address size
+    open array     address length .. length
+  *)
+
+  PROCEDURE Call* (adr: ADDRESS; sig: Signature; IN par: ARRAY OF INTEGER; n: INTEGER): LONGINT;
+    CONST
+      (* obj.id MOD 16 *)
+      mConst = 1; mTyp = 2; mVar = 3; mProc = 4; mField = 5;
+      (* typ *)
+      mBool = 1; mChar8 = 2; mChar16 = 3; mInt8 = 4; mInt16 = 5; mInt32 = 6;
+      mReal32 = 7; mReal64 = 8; mSet = 9; mInt64 = 10; mAnyRec = 11; mAnyPtr = 12; mSysPtr = 13;
+      (* typ.id MOD 4 *)
+      mProctyp = 0; mRecord = 1; mArray = 2; mPointer = 3;
+      (* ??? obj.id DIV 16 MOD 16 *)
+      mInternal = 1; mReadonly = 2; mPrivate = 3; mExported = 4;
+      (* sig.par[].id MOD 16 *)
+      mValue = 10; mInPar = 11; mOutPar = 12; mVarPar = 13;
+      mInterface = 32; mGuid = 33; mResult = 34;
+      (* implementation restrictions *)
+      maxPars = 127;
+      maxStrs = 127;
+      maxElms = 256;
+    TYPE
+      Ptype = POINTER TO LibFFI.type;
+      PPtype = POINTER TO ARRAY [untagged] OF Ptype;
+    VAR
+      status: LibFFI.status;
+      kind, form, size: INTEGER;
+      i, p, d, cn, ut, ue: INTEGER;
+      fret: Ptype;
+      vret: LONGINT;
+      earg: ARRAY maxElms OF Ptype;
+      targ: ARRAY maxStrs OF LibFFI.type;
+      farg: ARRAY maxPars OF Ptype;
+      varg: ARRAY maxPars OF ADDRESS;
+      typ: Type;
+      cif: LibFFI.cif;
+
+    PROCEDURE SetType (IN typ: LibFFI.type);
+    BEGIN
+      farg[cn] := S.VAL(Ptype, S.ADR(typ));
+    END SetType;
+
+    PROCEDURE PushAdr (size: INTEGER);
+    BEGIN
+      ASSERT(size IN {1, 2, 4, 8}, 20);
+      ASSERT(littleEndian OR (size <= 4), 100); (* !!! swap 64bit value *)
+      varg[cn] := S.ADR(par[d]);
+      INC(cn); INC(d, MAX(1, size DIV 4))
+    END PushAdr;
+
+    PROCEDURE PushVal (size: INTEGER);
+    BEGIN
+      ASSERT(size IN {1, 2, 4, 8}, 20);
+      ASSERT(littleEndian OR (size <= 4), 100); (* !!! swap 64bit value *)
+      varg[cn] := par[d];
+      INC(cn); INC(d, MAX(1, size DIV 4))
+    END PushVal;
+
+    PROCEDURE Push (IN typ: LibFFI.type);
+    BEGIN
+      SetType(typ); PushAdr(typ.size)
+    END Push;
+
+  BEGIN
+    p := 0; cn := 0; d := 0; ut := 0; ue := 0;
+    WHILE p < sig.num DO
+      typ := sig.par[p].struct;
+      kind := sig.par[p].id MOD 16;
+      IF S.VAL(ADDRESS, typ) DIV 256 = 0 THEN (* basic types *)
+        form := S.VAL(ADDRESS, typ) MOD 256;
+        IF kind = mValue THEN
+          CASE form OF
+          | mBool, mChar8: Push(LibFFI.type_uint8)
+          | mChar16: Push(LibFFI.type_uint16)
+          | mInt8: Push(LibFFI.type_sint8)
+          | mInt16: Push(LibFFI.type_sint16)
+          | mInt32: Push(LibFFI.type_sint32)
+          | mReal32: Push(LibFFI.type_float)
+          | mReal64: Push(LibFFI.type_double)
+          | mSet: Push(LibFFI.type_uint32)
+          | mInt64: Push(LibFFI.type_sint64)
+          | mAnyPtr, mSysPtr: Push(LibFFI.type_pointer)
+          ELSE HALT(100) (* unsupported type *)
+          END;
+        ELSIF kind IN {mInPar..mVarPar} THEN
+          CASE form OF
+          | mBool..mInt64, mAnyPtr, mSysPtr: Push(LibFFI.type_pointer)
+          | mAnyRec: Push(LibFFI.type_pointer); Push(LibFFI.type_pointer) (* address + tag *)
+          ELSE HALT(101) (* unsupported type *)
+          END
+        ELSE
+          HALT(102) (* unsupported parameter kind *)
+        END
+      ELSE
+        CASE typ.id MOD 4 OF
+        | mProctyp, mPointer:
+           Push(LibFFI.type_pointer)
+        | mRecord:
+           IF kind = mValue THEN
+             targ[ut].size := 0;
+             targ[ut].alignment := 0;
+             targ[ut].type := LibFFI.TYPE_STRUCT;
+             targ[ut].elements := S.VAL(PPtype, S.ADR(earg[ue]));
+             SetType(targ[ut]); INC(ut);
+             size := MAX(1, typ.size);
+             (* !!! better to pass original layout *)
+             WHILE size >= 8 DO
+               earg[ue] := S.VAL(Ptype, S.ADR(LibFFI.type_uint64));
+               INC(ue); DEC(size, 8)
+             END;
+             IF size >= 4 THEN
+               earg[ue] := S.VAL(Ptype, S.ADR(LibFFI.type_uint32));
+               INC(ue); DEC(size, 4)
+             END;
+             IF size >= 2 THEN
+               earg[ue] := S.VAL(Ptype, S.ADR(LibFFI.type_uint16));
+               INC(ue); DEC(size, 2)
+             END;
+             IF size >= 1 THEN
+               earg[ue] := S.VAL(Ptype, S.ADR(LibFFI.type_uint32));
+               INC(ue); DEC(size)
+             END;
+             earg[ue] := NIL;
+             INC(ue);
+             PushVal(LibFFI.type_pointer.size);
+             INC(d) (* skip tag *)
+           ELSIF kind IN {mInPar..mVarPar} THEN
+             Push(LibFFI.type_pointer); (* address *)
+             Push(LibFFI.type_pointer); (* tag *)
+           ELSE HALT(103) (* unsupported parameter kind *)
+           END
+        | mArray:
+           Push(LibFFI.type_pointer);
+           ASSERT(kind IN {mValue..mVarPar}, 104); (* unsupported parameter kind *)
+           (* array copying generated by CPfront, so we can just pass address *)
+           IF typ.size = 0 THEN (* open array *)
+             FOR i := 0 TO typ.id DIV 16 - 1 DO
+               Push(LibFFI.type_sint32) (* dim size *)
+             END
+           ELSE (* fix array *)
+             INC(d) (* skip size *)
+           END
+        END
+      END;
+      INC(p)
+    END;
+    ASSERT(d = n, 105);
+    typ := sig.retStruct;
+    IF typ = NIL THEN fret := S.VAL(Ptype, S.ADR(LibFFI.type_void))
+    ELSIF S.VAL(ADDRESS, typ) DIV 256 = 0 THEN
+      form := S.VAL(ADDRESS, typ) MOD 256;
+      CASE form OF
+      | mBool, mChar8: fret := S.VAL(Ptype, S.ADR(LibFFI.type_uint8))
+      | mChar16: fret := S.VAL(Ptype, S.ADR(LibFFI.type_uint16))
+      | mInt8: fret := S.VAL(Ptype, S.ADR(LibFFI.type_sint8))
+      | mInt16: fret := S.VAL(Ptype, S.ADR(LibFFI.type_sint16))
+      | mInt32: fret := S.VAL(Ptype, S.ADR(LibFFI.type_sint32))
+      | mReal32: fret := S.VAL(Ptype, S.ADR(LibFFI.type_float))
+      | mReal64: fret := S.VAL(Ptype, S.ADR(LibFFI.type_double))
+      | mSet: fret := S.VAL(Ptype, S.ADR(LibFFI.type_uint32))
+      | mInt64: fret := S.VAL(Ptype, S.ADR(LibFFI.type_sint64))
+      | mAnyPtr, mSysPtr: fret := S.VAL(Ptype, S.ADR(LibFFI.type_pointer))
+      ELSE HALT(106) (* unsupported type *)
+      END
+    ELSE
+      CASE typ.id MOD 4 OF
+      | mProctyp, mPointer: fret := S.VAL(Ptype, S.ADR(LibFFI.type_pointer))
+      ELSE HALT(107) (* unsupported type *)
+      END
+    END;
+    status := LibFFI.prep_cif(cif, LibFFI.DEFAULT_ABI, cn, fret, farg);
+    ASSERT(status = LibFFI.OK, 108);
+    vret := 0;
+    IF littleEndian THEN LibFFI.call(cif, adr, S.ADR(vret), S.ADR(varg))
+    ELSE LibFFI.call(cif, adr, S.ADR(vret) + (8 - fret.size), S.ADR(varg))
+    END;
+    RETURN vret
+  END Call;
+
+  (* -------------------- reference information (portable) --------------------- *)
+
+  PROCEDURE RefCh (VAR ref: INTEGER; OUT ch: SHORTCHAR);
+  BEGIN
+    S.GET(ref, ch); INC(ref)
+  END RefCh;
+
+  PROCEDURE RefNum (VAR ref: INTEGER; OUT x: INTEGER);
+    VAR s, n: INTEGER; ch: SHORTCHAR;
+  BEGIN
+    s := 0; n := 0; RefCh(ref, ch);
+    WHILE ORD(ch) >= 128 DO INC(n, ASH(ORD(ch) - 128, s) ); INC(s, 7); RefCh(ref, ch) END;
+    x := n + ASH(ORD(ch) MOD 64 - ORD(ch) DIV 64 * 64, s)
+  END RefNum;
+
+  PROCEDURE RefName (VAR ref: INTEGER; OUT n: Utf8Name);
+    VAR i: INTEGER; ch: SHORTCHAR;
+  BEGIN
+    i := 0; RefCh(ref, ch);
+    WHILE ch # 0X DO n[i] := ch; INC(i); RefCh(ref, ch) END;
+    n[i] := 0X
+  END RefName;
+
+  PROCEDURE GetRefProc* (VAR ref: INTEGER; OUT adr: INTEGER; OUT name: Utf8Name);
+    VAR ch: SHORTCHAR;
+  BEGIN
+    S.GET(ref, ch);
+    WHILE ch >= 0FDX DO (* skip variables *)
+      INC(ref); RefCh(ref, ch);
+      IF ch = 10X THEN INC(ref, 4) END;
+      RefNum(ref, adr); RefName(ref, name); S.GET(ref, ch)
+    END;
+    WHILE (ch > 0X) & (ch < 0FCX) DO  (* skip source refs *)
+      INC(ref); RefNum(ref, adr); S.GET(ref, ch)
+    END;
+    IF ch = 0FCX THEN INC(ref); RefNum(ref, adr); RefName(ref, name)
+    ELSE adr := 0
+    END
+  END GetRefProc;
+
+  PROCEDURE GetRefVar* (VAR ref: INTEGER; OUT mode, form: SHORTCHAR; OUT desc: Type; OUT adr: INTEGER; OUT name: Utf8Name);
+  BEGIN
+    S.GET(ref, mode); desc := NIL;
+    IF mode >= 0FDX THEN
+      mode := SHORT(CHR(ORD(mode) - 0FCH));
+      INC(ref); RefCh(ref, form);
+      IF form = 10X THEN
+        S.GET(ref, desc); INC(ref, 4); form := SHORT(CHR(16 + desc.id MOD 4))
+      END;
+      RefNum(ref, adr); RefName(ref, name)
+    ELSE
+      mode := 0X; form := 0X; adr := 0
+    END
+  END GetRefVar;
+
+  PROCEDURE SourcePos* (mod: Module; codePos: INTEGER): INTEGER;
+    VAR ref, pos, ad, d: INTEGER; ch: SHORTCHAR; name: Utf8Name;
+  BEGIN
+    IF mod # NIL THEN (* mf, 12.02.04 *)
+      ref := mod.refs; pos := 0; ad := 0; S.GET(ref, ch);
+      WHILE ch # 0X DO
+        WHILE (ch > 0X) & (ch < 0FCX) DO  (* srcref: {dAdr,dPos} *)
+          INC(ad, ORD(ch)); INC(ref); RefNum(ref, d);
+          IF ad > codePos THEN RETURN pos END;
+          INC(pos, d); S.GET(ref, ch)
+        END;
+        IF ch = 0FCX THEN (* proc: 0FCX,Adr,Name *)
+          INC(ref); RefNum(ref, d); RefName(ref, name); S.GET(ref, ch);
+          IF (d > codePos) & (pos > 0) THEN RETURN pos END 
+        END;
+        WHILE ch >= 0FDX DO (* skip variables: Mode, Form, adr, Name *)
+          INC(ref); RefCh(ref, ch);
+          IF ch = 10X THEN INC(ref, 4) END;
+          RefNum(ref, d); RefName(ref, name); S.GET(ref, ch)
+        END
+      END;
+    END;
+    RETURN -1
+  END SourcePos;
+
+  PROCEDURE LoadDll* (IN name: ARRAY OF CHAR; VAR ok: BOOLEAN);
+    VAR h: ADDRESS; file: Utf8Name; res: INTEGER;
+  BEGIN
+    StringToUtf8(name, file, res);
+    IF res = 0 THEN
+      h := dlfcn.dlopen(file, dlfcn.RTLD_LAZY + dlfcn.RTLD_GLOBAL);
+      ok := h # 0
+    ELSE
+      ok := FALSE
+    END
+  END LoadDll;
+
+  PROCEDURE ThisDllObj* (mode, fprint: INTEGER; IN dll, name: ARRAY OF CHAR): INTEGER;
+    VAR h, p: ADDRESS; file, sym: Utf8Name; res: INTEGER; err: dlfcn.int;
+  BEGIN
+    StringToUtf8(dll, file, res);
+    IF res = 0 THEN
+      h := dlfcn.dlopen(file, dlfcn.RTLD_LAZY + dlfcn.RTLD_GLOBAL);
+      IF h # 0 THEN
+        StringToUtf8(name, sym, res);
+        IF res = 0 THEN
+          p := dlfcn.dlsym(h, sym)
+        ELSE
+          p := 0
+        END;
+        err := dlfcn.dlclose(h);
+        ASSERT(err = 0, 100)
+      ELSE
+        p := 0
+      END
+    ELSE
+      p := 0
+    END;
+    RETURN p
+  END ThisDllObj;
+
+  (* -------------------- garbage collector (portable) --------------------- *)
+
+  PROCEDURE Mark (this: Block);
+    VAR father, son: Block; tag: Type; flag, offset, actual: INTEGER;
+  BEGIN
+    IF ~ODD(S.VAL(INTEGER, this.tag)) THEN
+      father := NIL;
+      LOOP
+        INC(S.VAL(INTEGER, this.tag));
+        flag := S.VAL(INTEGER, this.tag) MOD 4;
+        tag := S.VAL(Type, S.VAL(INTEGER, this.tag) - flag);
+        IF flag >= 2 THEN actual := this.first; this.actual := actual
+        ELSE actual := S.ADR(this.last)
+        END;
+        LOOP
+          offset := tag.ptroffs[0];
+          IF offset < 0 THEN
+            INC(S.VAL(INTEGER, tag), offset + 4); (* restore tag *)
+            IF (flag >= 2) & (actual < this.last) & (offset < -4) THEN  (* next array element *)
+              INC(actual, tag.size); this.actual := actual
+            ELSE  (* up *)
+              this.tag := S.VAL(Type, S.VAL(INTEGER, tag) + flag);
+              IF father = NIL THEN RETURN END;
+              son := this; this := father;
+              flag := S.VAL(INTEGER, this.tag) MOD 4;
+              tag := S.VAL(Type, S.VAL(INTEGER, this.tag) - flag);
+              offset := tag.ptroffs[0];
+              IF flag >= 2 THEN actual := this.actual ELSE actual := S.ADR(this.last) END;
+              S.GET(actual + offset, father); S.PUT(actual + offset, S.ADR(son.last));
+              INC(S.VAL(INTEGER, tag), 4)
+            END
+          ELSE
+            S.GET(actual + offset, son);
+            IF son # NIL THEN
+              DEC(S.VAL(INTEGER, son), 4);
+              IF ~ODD(S.VAL(INTEGER, son.tag)) THEN (* down *)
+                this.tag := S.VAL(Type, S.VAL(INTEGER, tag) + flag);
+                S.PUT(actual + offset, father); father := this; this := son;
+                EXIT
+              END
+            END;
+            INC(S.VAL(INTEGER, tag), 4)
+          END
+        END
+      END
+    END
+  END Mark;
+
+  PROCEDURE MarkGlobals;
+    VAR m: Module; i, p: INTEGER;
+  BEGIN
+    m := modList;
+    WHILE m # NIL DO
+      IF m.refcnt >= 0 THEN
+        i := 0;
+        WHILE i < m.nofptrs DO
+          S.GET(m.varBase + m.ptrs[i], p); INC(i);
+          IF p # 0 THEN Mark(S.VAL(Block, p - 4)) END
+        END
+      END;
+      m := m.next
+    END
+  END MarkGlobals;
+
+  PROCEDURE Next (b: Block): Block; (* next block in same cluster *)
+    VAR size: INTEGER;
+  BEGIN
+    S.GET(S.VAL(INTEGER, b.tag) DIV 4 * 4, size);
+    IF ODD(S.VAL(INTEGER, b.tag) DIV 2) THEN INC(size, b.last - S.ADR(b.last)) END;
+    RETURN S.VAL(Block, S.VAL(INTEGER, b) + (size + 19) DIV 16 * 16)
+  END Next;
+
+  PROCEDURE CheckCandidates;
+  (* pre: nofcand > 0 *)
+    VAR i, j, h, p, end: INTEGER; c: Cluster; blk, next: Block;
+  BEGIN
+    (* sort candidates (shellsort) *)
+    h := 1; REPEAT h := h*3 + 1 UNTIL h > nofcand;
+    REPEAT h := h DIV 3; i := h;
+      WHILE i < nofcand DO p := candidates[i]; j := i;
+        WHILE (j >= h) & (candidates[j-h] > p) DO
+          candidates[j] := candidates[j-h]; j := j-h
+        END;
+        candidates[j] := p; INC(i)
+      END
+    UNTIL h = 1;
+    (* sweep *)
+    c := root; i := 0;
+    WHILE c # NIL DO
+      blk := S.VAL(Block, S.VAL(INTEGER, c) + 12);
+      end := S.VAL(INTEGER, blk) + (c.size - 12) DIV 16 * 16;
+      WHILE candidates[i] < S.VAL(INTEGER, blk) DO
+        INC(i);
+        IF i = nofcand THEN RETURN END
+      END;
+      WHILE S.VAL(INTEGER, blk) < end DO
+        next := Next(blk);
+        IF candidates[i] < S.VAL(INTEGER, next) THEN
+          IF (S.VAL(INTEGER, blk.tag) # S.ADR(blk.last))  (* not a free block *)
+              & (~strictStackSweep OR (candidates[i] = S.ADR(blk.last))) THEN
+            Mark(blk)
+          END;
+          REPEAT
+            INC(i);
+            IF i = nofcand THEN RETURN END
+          UNTIL candidates[i] >= S.VAL(INTEGER, next)
+        END;
+        IF (S.VAL(INTEGER, blk.tag) MOD 4 = 0) & (S.VAL(INTEGER, blk.tag) # S.ADR(blk.last))
+            & (blk.tag.base[0] = NIL) & (blk.actual > 0) THEN (* referenced interface record *)
+          Mark(blk)
+        END;
+        blk := next
+      END;
+      c := c.next
+    END
+  END CheckCandidates;
+
+  PROCEDURE MarkLocals;
+    VAR sp, p, min, max: INTEGER; c: Cluster;
+  BEGIN
+    sp := S.ADR(sp); nofcand := 0; c := root;
+    WHILE c.next # NIL DO c := c.next END;
+    min := S.VAL(INTEGER, root); max := S.VAL(INTEGER, c) + c.size;
+    WHILE sp < baseStack DO
+      S.GET(sp, p);
+      IF (p > min) & (p < max) & (~strictStackSweep OR (p MOD 16 = 0)) THEN
+        candidates[nofcand] := p; INC(nofcand);
+        IF nofcand = LEN(candidates) - 1 THEN CheckCandidates; nofcand := 0 END
+      END;
+      INC(sp, 4)
+    END;
+    candidates[nofcand] := max; INC(nofcand); (* ensure complete scan for interface mark*)
+    IF nofcand > 0 THEN CheckCandidates END
+  END MarkLocals;
+
+  PROCEDURE MarkFinObj;
+    VAR f: FList;
+  BEGIN
+    wouldFinalize := FALSE;
+    f := finalizers;
+    WHILE f # NIL DO
+      IF ~ODD(S.VAL(INTEGER, f.blk.tag)) THEN wouldFinalize := TRUE END;
+      Mark(f.blk);
+      f := f.next
+    END;
+    f := hotFinalizers;
+    WHILE f # NIL DO IF ~ODD(S.VAL(INTEGER, f.blk.tag)) THEN wouldFinalize := TRUE END;
+      Mark(f.blk);
+      f := f.next
+    END
+  END MarkFinObj;
+
+  PROCEDURE CheckFinalizers;
+    VAR f, g, h, k: FList;
+  BEGIN
+    f := finalizers; g := NIL;
+    IF hotFinalizers = NIL THEN k := NIL
+    ELSE
+      k := hotFinalizers;
+      WHILE k.next # NIL DO k := k.next END
+    END;
+    WHILE f # NIL DO
+      h := f; f := f.next;
+      IF ~ODD(S.VAL(INTEGER, h.blk.tag)) THEN
+        IF g = NIL THEN finalizers := f ELSE g.next := f END;
+        IF k = NIL THEN hotFinalizers := h ELSE k.next := h END;
+        k := h; h.next := NIL
+      ELSE g := h
+      END
+    END;
+    h := hotFinalizers;
+    WHILE h # NIL DO Mark(h.blk); h := h.next END
+  END CheckFinalizers;
+
+  PROCEDURE ExecFinalizer (a, b, c: INTEGER);
+    VAR f: FList; fin: PROCEDURE(this: ANYPTR);
+  BEGIN
+    f := S.VAL(FList, a);
+    S.GET(S.VAL(INTEGER, f.blk.tag) - 4, fin);  (* method 0 *)
+    IF (fin # NIL) & (f.blk.tag.mod.refcnt >= 0) THEN fin(S.VAL(ANYPTR, S.ADR(f.blk.last))) END;
+  END ExecFinalizer;
+
+  PROCEDURE^ Try* (h: TryHandler; a, b, c: INTEGER);  (* COMPILER DEPENDENT *)
+
+  PROCEDURE CallFinalizers;
+    VAR f: FList;
+  BEGIN
+    WHILE hotFinalizers # NIL DO
+      f := hotFinalizers; hotFinalizers := hotFinalizers.next;
+      Try(ExecFinalizer, S.VAL(INTEGER, f), 0, 0)
+    END;
+    wouldFinalize := FALSE
+  END CallFinalizers;
+
+  PROCEDURE Insert (blk: FreeBlock; size: INTEGER); (* insert block in free list *)
+    VAR i: INTEGER;
+  BEGIN
+    blk.size := size - 4; blk.tag := S.VAL(Type, S.ADR(blk.size));
+    i := MIN(N - 1, (blk.size DIV 16));
+    blk.next := free[i]; free[i] := blk
+  END Insert;
+
+  PROCEDURE Sweep (dealloc: BOOLEAN);
+    VAR cluster, last, c: Cluster; blk, next: Block; fblk, b, t: FreeBlock; end, i: INTEGER;
+  BEGIN
+    cluster := root; last := NIL; allocated := 0;
+    i := N;
+    REPEAT DEC(i); free[i] := sentinel UNTIL i = 0;
+    WHILE cluster # NIL DO
+      blk := S.VAL(Block, S.VAL(INTEGER, cluster) + 12);
+      end := S.VAL(INTEGER, blk) + (cluster.size - 12) DIV 16 * 16;
+      fblk := NIL;
+      WHILE S.VAL(INTEGER, blk) < end DO
+        next := Next(blk);
+        IF ODD(S.VAL(INTEGER, blk.tag)) THEN
+          IF fblk # NIL THEN
+            Insert(fblk, S.VAL(INTEGER, blk) - S.VAL(INTEGER, fblk));
+            fblk := NIL
+          END;
+          DEC(S.VAL(INTEGER, blk.tag)); (* unmark *)
+          INC(allocated, S.VAL(INTEGER, next) - S.VAL(INTEGER, blk))
+        ELSIF fblk = NIL THEN
+          fblk := S.VAL(FreeBlock, blk)
+        END;
+        blk := next
+      END;
+      IF dealloc & (S.VAL(INTEGER, fblk) = S.VAL(INTEGER, cluster) + 12) THEN (* deallocate cluster *)
+        c := cluster; cluster := cluster.next;
+        IF last = NIL THEN root := cluster ELSE last.next := cluster END;
+        FreeHeapMem(c)
+      ELSE
+        IF fblk # NIL THEN Insert(fblk, end - S.VAL(INTEGER, fblk)) END;
+        last := cluster; cluster := cluster.next
+      END
+    END;
+    (* reverse free list *)
+    i := N;
+    REPEAT
+      DEC(i);
+      b := free[i]; fblk := sentinel;
+      WHILE b # sentinel DO t := b; b := t.next; t.next := fblk; fblk := t END;
+      free[i] := fblk
+    UNTIL i = 0
+  END Sweep;
+
+  PROCEDURE Collect*;
+  BEGIN
+    IF root # NIL THEN
+      CallFinalizers; (* trap cleanup *)
+      MarkGlobals;
+      MarkLocals;
+      CheckFinalizers;
+      Sweep(TRUE);
+      CallFinalizers
+    END
+  END Collect;
+  
+  PROCEDURE FastCollect*;
+  BEGIN
+    IF root # NIL THEN
+      MarkGlobals;
+      MarkLocals;
+      MarkFinObj;
+      Sweep(FALSE)
+    END
+  END FastCollect;
+
+  PROCEDURE WouldFinalize* (): BOOLEAN;
+  BEGIN
+    RETURN wouldFinalize
+  END WouldFinalize;
+
+  (* --------------------- memory allocation (portable) -------------------- *)
+
+  PROCEDURE OldBlock (size: INTEGER): FreeBlock;  (* size MOD 16 = 0 *)
+    VAR b, l: FreeBlock; s, i: INTEGER;
+  BEGIN
+    s := size - 4;
+    i := MIN(N - 1, s DIV 16);
+    WHILE (i # N - 1) & (free[i] = sentinel) DO INC(i) END;
+    b := free[i]; l := NIL;
+    WHILE b.size < s DO l := b; b := b.next END;
+    IF b # sentinel THEN
+      IF l = NIL THEN free[i] := b.next ELSE l.next := b.next END
+    ELSE b := NIL
+    END;
+    RETURN b
+  END OldBlock;
+
+  PROCEDURE LastBlock (limit: INTEGER): FreeBlock;  (* size MOD 16 = 0 *)
+    VAR b, l: FreeBlock; s, i: INTEGER;
+  BEGIN
+    s := limit - 4;
+    i := 0;
+    REPEAT
+      b := free[i]; l := NIL;
+      WHILE (b # sentinel) & (S.VAL(INTEGER, b) + b.size # s) DO l := b; b := b.next END;
+      IF b # sentinel THEN
+        IF l = NIL THEN free[i] := b.next ELSE l.next := b.next END
+      ELSE b := NIL
+      END;
+      INC(i)
+    UNTIL (b # NIL) OR (i = N);
+    RETURN b
+  END LastBlock;
+
+  PROCEDURE NewBlock (size: INTEGER): Block;
+    VAR tsize, a, s: INTEGER; b: FreeBlock; new, c: Cluster; r: Reducer;
+  BEGIN
+    ASSERT(size >= 0, 20);
+    IF size > MAX(INTEGER) - 19 THEN RETURN NIL END;
+    tsize := (size + 19) DIV 16 * 16;
+    b := OldBlock(tsize); (* 1) search for free block *)
+    IF b = NIL THEN
+      FastCollect; b := OldBlock(tsize);  (* 2) collect *)
+      IF b = NIL THEN
+        Collect; b := OldBlock(tsize);  (* 2a) fully collect *)
+      END;
+      IF b = NIL THEN
+        AllocHeapMem(tsize + 12, new);  (* 3) allocate new cluster *)
+        IF new # NIL THEN
+          IF (root = NIL) OR (S.VAL(INTEGER, new) < S.VAL(INTEGER, root)) THEN
+            new.next := root; root := new
+          ELSE
+            c := root;
+            WHILE (c.next # NIL) & (S.VAL(INTEGER, new) > S.VAL(INTEGER, c.next)) DO c := c.next END;
+            new.next := c.next; c.next := new
+          END;
+          b := S.VAL(FreeBlock, S.VAL(INTEGER, new) + 12);
+          b.size := (new.size - 12) DIV 16 * 16 - 4
+        ELSE
+          RETURN NIL  (* 4) give up *)
+        END
+      END
+    END;
+    (* b # NIL *)
+    a := b.size + 4 - tsize;
+    IF a > 0 THEN Insert(S.VAL(FreeBlock, S.VAL(INTEGER, b) + tsize), a) END;
+    IF size > 0 THEN Erase(S.ADR(b.size), (size + 3) DIV 4) END;
+    INC(allocated, tsize);
+    RETURN S.VAL(Block, b)
+  END NewBlock;
+
+  PROCEDURE Allocated* (): INTEGER;
+  BEGIN
+    RETURN allocated
+  END Allocated;
+
+  PROCEDURE Used* (): INTEGER;
+  BEGIN
+    RETURN used
+  END Used;
+
+  PROCEDURE Root* (): INTEGER;
+  BEGIN
+    RETURN S.VAL(INTEGER, root)
+  END Root;
+
+  (* -------------------- Trap Handling --------------------- *)
+
+  PROCEDURE [code] GetDLink (): DLink "(Kernel_DLink)SYSTEM_dlink";
+  PROCEDURE [code] SetDLink (dl: DLink) "SYSTEM_dlink = (SYSTEM_DLINK*)dl";
+
+  PROCEDURE Start* (code: Command);
+    VAR res: setjmp.int; dl: DLink;
+  BEGIN
+    restart := code;
+    baseStack := S.ADR(code); (* XXX: expected that target uses one stack *)
+    startDLink := GetDLink();
+    res := setjmp.sigsetjmp(startEnv, 1);
+    restart
+  END Start;
+
+  PROCEDURE Quit* (exitCode: INTEGER);
+    VAR m: Module; term: Command; t: BOOLEAN;
+  BEGIN
+    trapViewer := NIL; trapChecker := NIL; restart := NIL;
+    t := terminating; terminating := TRUE; m := modList;
+    WHILE m # NIL DO  (* call terminators *)
+      IF ~static OR ~t THEN
+        term := m.term; m.term := NIL;
+        IF term # NIL THEN term() END
+      END;
+      m := m.next
+    END;
+    CallFinalizers;
+    hotFinalizers := finalizers; finalizers := NIL;
+    CallFinalizers;
+    stdlib.exit(exitCode)
+  END Quit;
+
+  PROCEDURE FatalError* (id: INTEGER; str: ARRAY OF CHAR);
+    VAR res: stdio.int; title: ARRAY 16 OF CHAR; text: ARRAY 256 OF SHORTCHAR;
+  BEGIN
+    title := "Error xy";
+    title[6] := CHR(id DIV 10 + ORD("0"));
+    title[7] := CHR(id MOD 10 + ORD("0"));
+    res := unistd.write(2, S.ADR(title), 8);
+    stdlib.abort
+  END FatalError;
+
+  PROCEDURE DefaultTrapViewer;
+    VAR out: ARRAY 256 OF SHORTCHAR; c, len: INTEGER; res: unistd.int; dl: DLink;
+
+    PROCEDURE WriteString (IN s: ARRAY OF SHORTCHAR);
+      VAR i: INTEGER;
+    BEGIN
+      i := 0;
+      WHILE (len < LEN(out) - 1) & (s[i] # 0X) DO out[len] := s[i]; INC(i); INC(len) END
+    END WriteString;
+
+    PROCEDURE WriteHex (x, n: INTEGER);
+      VAR i, y: INTEGER;
+    BEGIN
+      IF len + n < LEN(out) THEN
+        i := len + n - 1;
+        WHILE i >= len DO
+          y := x MOD 16; x := x DIV 16;
+          IF y > 9 THEN y := y + (ORD("A") - ORD("0") - 10) END;
+          out[i] := SHORT(CHR(y + ORD("0"))); DEC(i)
+        END;
+        INC(len, n)
+      END
+    END WriteHex;
+
+    PROCEDURE WriteLn;
+    BEGIN
+      IF len < LEN(out) - 1 THEN out[len] := 0AX; INC(len) END
+    END WriteLn;
+
+  BEGIN
+    len := 0;
+    WriteString("====== ");
+    IF err = 129 THEN WriteString("invalid with")
+    ELSIF err = 130 THEN WriteString("invalid case")
+    ELSIF err = 131 THEN WriteString("function without return")
+    ELSIF err = 132 THEN WriteString("type guard")
+    ELSIF err = 133 THEN WriteString("implied type guard")
+    ELSIF err = 134 THEN WriteString("value out of range")
+    ELSIF err = 135 THEN WriteString("index out of range")
+    ELSIF err = 136 THEN WriteString("string too long")
+    ELSIF err = 137 THEN WriteString("stack overflow")
+    ELSIF err = 138 THEN WriteString("integer overflow")
+    ELSIF err = 139 THEN WriteString("division by zero")
+    ELSIF err = 140 THEN WriteString("infinite real result")
+    ELSIF err = 141 THEN WriteString("real underflow")
+    ELSIF err = 142 THEN WriteString("real overflow")
+    ELSIF err = 143 THEN WriteString("undefined real result")
+    ELSIF err = 144 THEN WriteString("not a number")
+    ELSIF err = 200 THEN WriteString("keyboard interrupt")
+    ELSIF err = 201 THEN WriteString("NIL dereference")
+    ELSIF err = 202 THEN WriteString("illegal instruction:  ");
+      WriteHex(val, 4)
+    ELSIF err = 203 THEN WriteString("illegal memory read [ad = ");
+      WriteHex(val, 8); WriteString("]")
+    ELSIF err = 204 THEN WriteString("illegal memory write [ad = ");
+      WriteHex(val, 8); WriteString("]")
+    ELSIF err = 205 THEN WriteString("illegal execution [ad = ");
+      WriteHex(val, 8); WriteString("]")
+    ELSIF err = 257 THEN WriteString("out of memory")
+    ELSIF err = 10001H THEN WriteString("bus error")
+    ELSIF err = 10002H THEN WriteString("address error")
+    ELSIF err = 10007H THEN WriteString("fpu error")
+    ELSIF err < 0 THEN WriteString("exception #"); WriteHex(-err, 2)
+    ELSE err := err DIV 100 * 256 + err DIV 10 MOD 10 * 16 + err MOD 10;
+      WriteString("trap #"); WriteHex(err, 3)
+    END;
+    WriteString(" ======");
+    WriteLn;
+    dl := GetDLink();
+    (* skip Kernel.DefaultTrapViewer & Kernel.Trap/Kernel.TrapHandler *)
+    c := 2;
+    WHILE (c > 0) & (dl # NIL) DO
+      dl := dl.next;
+      DEC(c)
+    END;
+    (* stack trace *)
+    c := 16;
+    WHILE (c > 0) & (dl # NIL) DO
+      WriteString("- "); WriteString(dl.name$); WriteLn;
+      dl := dl.next;
+      DEC(c)
+    END;
+    out[len] := 0X;
+    res := unistd.write(2, S.ADR(out), len)
+  END DefaultTrapViewer;
+
+  PROCEDURE TrapCleanup;
+    VAR t: TrapCleaner;
+  BEGIN
+    WHILE trapStack # NIL DO
+      t := trapStack; trapStack := trapStack.next; t.Cleanup
+    END;
+    IF (trapChecker # NIL) & (err # 128) THEN trapChecker END
+  END TrapCleanup;
+
+  PROCEDURE SetTrapGuard* (on: BOOLEAN);
+  BEGIN
+    guarded := on
+  END SetTrapGuard;
+
+  PROCEDURE Try* (h: TryHandler; a, b, c: INTEGER);
+    VAR oldIsTry: BOOLEAN; oldTryEnv: setjmp.jmp_buf; oldTryDLink: DLink; res: setjmp.int;
+  BEGIN
+    oldIsTry := isTry; oldTryEnv := tryEnv; oldTryDLink := tryDLink;
+    isTry := TRUE; tryDLink := GetDLink();
+    res := setjmp._setjmp(tryEnv);
+    IF res = 0 THEN h(a, b, c) END;
+    isTry := oldIsTry; tryEnv := oldTryEnv; tryDLink := oldTryDLink
+  END Try;
+
+  PROCEDURE Trap* (n: INTEGER);
+  BEGIN
+    IF trapped THEN
+      DefaultTrapViewer;
+      IF ~secondTrap THEN trapped := FALSE; secondTrap := TRUE END
+    END;
+    IF n >= 0 THEN err := n
+    ELSE err := -n + 128
+    END;
+    pc := 0; sp := 0; fp := 0; stack := 0; val := 0;
+    INC(trapCount);
+    (* !!! InitFPU *)
+    TrapCleanup;
+    IF isTry THEN
+      SetDLink(tryDLink);
+      setjmp._longjmp(tryEnv, 1)
+    END;
+    IF (err = 128) OR (err = 200) & ~intTrap THEN (* do nothing *)
+    ELSIF (trapViewer # NIL) & (restart # NIL) & ~trapped & ~guarded THEN
+      trapped := TRUE; trapViewer()
+    ELSE DefaultTrapViewer
+    END;
+    trapped := FALSE; secondTrap := FALSE;
+    IF restart # NIL THEN
+      SetDLink(startDLink);
+      setjmp.siglongjmp(startEnv, 1)
+    END;
+    stdlib.abort
+  END Trap;
+
+  PROCEDURE [ccall] TrapHandler (signo: signal.int; IN info: signal.siginfo_t; context: ADDRESS);
+    VAR res: signal.int;
+  BEGIN
+    IF checkReadable THEN
+      setjmp.siglongjmp(checkReadableEnv, 1)
+    END;
+    IF trapped THEN
+      DefaultTrapViewer;
+      IF ~secondTrap THEN trapped := FALSE; secondTrap := TRUE END
+    END;
+    err := -signo; pc := 0; sp := 0; fp := 0; stack := baseStack; val := 0;
+    CASE signo OF
+    | signal.SIGFPE:
+        val := info.si_code;
+        pc := info.info.sigfpe.si_addr;
+        CASE info.si_code OF
+        | signal.FPE_INTDIV: err := 139 (* division by zero *)
+        | signal.FPE_INTOVF: err := 138 (* integer overflow *)
+        | signal.FPE_FLTDIV: err := 140 (* fpu: division by zero *)
+        | signal.FPE_FLTOVF: err := 142 (* fpu: overflow *)
+        | signal.FPE_FLTUND: err := 141 (* fpu: underflow *)
+        (* !!! | signal.FPE_FLTRES: err := ??? (* fpu: *) *)
+        | signal.FPE_FLTINV: err := 143 (* val := opcode *) (* fpu: invalid op *)
+        (* !!! | signal.FPE_FLTSUB: err := ??? (* fpu: *) *)
+        ELSE (* unknown *)
+        END
+    | signal.SIGINT:
+        val := info.si_code;
+        err := 200 (* keyboard interrupt *)
+    | signal.SIGSEGV:
+        val := info.info.sigsegv.si_addr;
+        err := 203 (* illigal read *)
+    | signal.SIGBUS:
+        val := info.info.sigbus.si_addr;
+        err := 10001H (* bus error *)
+    | signal.SIGILL:
+        pc := info.info.sigill.si_addr;
+        err := 202; (* illigal instruction *)
+        IF IsReadable(pc, pc + 4) THEN
+          S.GET(pc, val)
+        END;
+    ELSE (* unknown *)
+    END;
+    INC(trapCount);
+    (* !!! InitFPU *)
+    TrapCleanup;
+    IF isTry THEN
+      setjmp._longjmp(tryEnv, 1)
+    END;
+    IF (err = 128) OR (err = 200) & ~intTrap THEN (* do nothing *)
+    ELSIF (trapViewer # NIL) & (restart # NIL) & ~trapped & ~guarded THEN
+      trapped := TRUE; trapViewer()
+    ELSE DefaultTrapViewer
+    END;
+    trapped := FALSE; secondTrap := FALSE;
+    IF restart # NIL THEN
+      setjmp.siglongjmp(startEnv, 1)
+    END;
+    stdlib.abort
+  END TrapHandler;
+
+  (* -------------------- Initialization --------------------- *)
+
+  PROCEDURE InstallTrap (signo: signal.int);
+    VAR act: signal._struct_sigaction; (* !!! CPfront hack *)  res: signal.int;
+  BEGIN
+    act.sa_handler := NIL;
+    res := signal.sigemptyset(act.sa_mask);
+    act.sa_flags := signal.SA_NODEFER + signal.SA_SIGINFO;
+    act.sa_sigaction := TrapHandler;
+    res := signal.sigaction(signo, S.VAL(signal.struct_sigaction, act), NIL);
+  END InstallTrap;
+
+  PROCEDURE InstallTrapVectors;
+  BEGIN
+    InstallTrap(signal.SIGFPE);
+    InstallTrap(signal.SIGINT);
+    InstallTrap(signal.SIGSEGV);
+    InstallTrap(signal.SIGBUS);
+    InstallTrap(signal.SIGILL)
+  END InstallTrapVectors;
+
+  PROCEDURE RemoveTrapVectors;
+  END RemoveTrapVectors;
+
+  PROCEDURE Init;
+    VAR i: INTEGER;
+  BEGIN
+    intTrap := TRUE;
+    baseStack := S.ADR(i); (* XXX *)
+    pagesize := unistd.sysconf(unistd._SC_PAGESIZE);
+
+    (* init heap *)
+    allocated := 0; total := 0; used := 0;
+    sentinelBlock.size := MAX(INTEGER);
+    sentinel := S.ADR(sentinelBlock);
+    i := N;
+    REPEAT DEC(i); free[i] := sentinel UNTIL i = 0;
+
+    IF ~inDll THEN
+      InstallTrapVectors
+    END;
+
+    (* !!! InitFPU *)
+    IF ~static THEN
+      InitModule(modList);
+      IF ~inDll THEN Quit(1) END
+    END
+  END Init;
+
+  PROCEDURE [code] SYSTEM_argCount (): INTEGER "SYSTEM_argCount";
+  PROCEDURE [code] SYSTEM_argVector (): ArrStrPtr "(Kernel_ArrStrPtr)SYSTEM_argVector";
+  PROCEDURE [code] SYSTEM_modlist (): Module "(Kernel_Module)SYSTEM_modlist";
+
+BEGIN
+  IF modList = NIL THEN (* only once *)
+    argc := SYSTEM_argCount();
+    argv := SYSTEM_argVector();
+    modList := SYSTEM_modlist();
+    static := init IN modList.opts;
+    inDll := dll IN modList.opts;
+    Init
+  END
+CLOSE
+  IF ~terminating THEN
+    terminating := TRUE;
+    Quit(0)
+  END
+END Kernel.