From f4916c269c72899fbbf1878ccd4e2eeef0084ff3 Mon Sep 17 00:00:00 2001 From: DeaDDooMER Date: Mon, 29 Jun 2020 10:13:15 +0400 Subject: [PATCH] Kernel: fix memory allocation on target powerpc-cpfront-osx --- make.sh | 6 +- .../osx/powerpc/Posix/Mod/Csys_wait.cp | 66 + src/cpfront/osx/powerpc/System/Mod/Kernel.cp | 1897 +++++++++++++++++ 3 files changed, 1968 insertions(+), 1 deletion(-) create mode 100644 src/cpfront/osx/powerpc/Posix/Mod/Csys_wait.cp create mode 100644 src/cpfront/osx/powerpc/System/Mod/Kernel.cp diff --git a/make.sh b/make.sh index f7dab7d..f25d28a 100755 --- a/make.sh +++ b/make.sh @@ -305,7 +305,11 @@ link_all() { 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 } 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 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 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. -- 2.29.2