From: Alexander Shiryaev Date: Fri, 16 Nov 2012 20:05:23 +0000 (+0400) Subject: old file removed X-Git-Url: http://deadsoftware.ru/gitweb?a=commitdiff_plain;h=28e353ba7fb78beef31a1baf58edb235ce52cb44;p=bbcp.git old file removed --- diff --git a/new/_Linux_/System/Mod/Kernel.txt b/new/_Linux_/System/Mod/Kernel.txt deleted file mode 100644 index 07f982c..0000000 --- a/new/_Linux_/System/Mod/Kernel.txt +++ /dev/null @@ -1,2072 +0,0 @@ -MODULE Kernel; - - (* THIS IS TEXT COPY OF Kernel.odc *) - (* DO NOT EDIT *) - - (* A. V. Shiryaev, 2012.11 - Linux Kernel - Based on 1.6-rc6 Windows Kernel - + 20120822 Marc changes - Some parts taken from OpenBUGS linKernel - - Most Windows-specific code removed - Some Windows-specific code commented and marked red - Windows COM-specific code re-marked from green to gray - Linux(/OpenBSD)-specific code marked green - - TODO: - handle stack overflow exceptions - Quit from TrapHandler - *) - - IMPORT S := SYSTEM, Libc := LinLibc, Dl := LinDl; - - CONST - strictStackSweep = TRUE; - - nameLen* = 256; - - littleEndian* = TRUE; - timeResolution* = 1000; (* ticks per second *) - - processor* = 10; (* i386 *) - - 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; - - CX = 1; - SP = 4; (* register number of stack pointer *) - FP = 5; (* register number of frame pointer *) - ML = 3; (* register which holds the module list at program start *) - - 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; - - debug = FALSE; - - -(* - sigStackSize = MAX(Libc.SIGSTKSZ, 65536); -*) - - trapReturn = 1; (* Return value for sigsetjmp given from siglongjmp *) - - (* constants for the message boxes *) - mbClose* = -1; mbOk* = 0; mbCancel* =1; mbRetry* = 2; mbIgnore* = 3; mbYes* = 4; mbNo* = 5; - - TYPE - Name* = 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-: Name - 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; - - GuiHook* = POINTER TO ABSTRACT RECORD (Hook) END; (* Implemented by HostGnome *) - - 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 - (* 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; - - (* Linux specific boot loader info. Record must be identical to struct in the loader. *) - BootInfo* = POINTER TO RECORD [untagged] - modList: Module; - argc-: INTEGER; - argv-: Libc.StrArray - END; - - VAR - baseStack: INTEGER; (* modList, root, and baseStack must be together for remote debugging *) - root: Cluster; (* cluster list *) - modList-: Module; (* root of module list *) - trapCount-: INTEGER; - err-, pc-, sp-, fp-, stack-, val-: INTEGER; - - 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 *) - - res: INTEGER; (* auxiliary global variables used for trap handling *) - old: INTEGER; - - trapViewer, trapChecker: Handler; - trapped, guarded, secondTrap: BOOLEAN; - interrupted: BOOLEAN; - static, inDll, terminating: BOOLEAN; - restart: Command; - - told, shift: INTEGER; (* used in Time() *) - - loader: LoaderHook; - loadres: INTEGER; - - wouldFinalize: BOOLEAN; - - watcher*: PROCEDURE (event: INTEGER); (* for debugging *) - - -(* - sigStack: Libc.PtrVoid; -*) - - zerofd: INTEGER; - pageSize: INTEGER; - - loopContext: Libc.sigjmp_buf; (* trap return context, if no Kernel.Try has been used. *) - currentTryContext: POINTER TO Libc.sigjmp_buf; (* trap return context, if Kernel.Try has been used. *) - isReadableContext: Libc.sigjmp_buf; (* for IsReadable *) - isReadableCheck: BOOLEAN; - - guiHook: GuiHook; - - (* !!! This variable has to be the last variable in the list. !!! *) - bootInfo-: BootInfo; - - (* code procedures for fpu *) - - PROCEDURE [1] FINIT 0DBH, 0E3H; - PROCEDURE [1] FLDCW 0D9H, 06DH, 0FCH; (* -4, FP *) - PROCEDURE [1] FSTCW 0D9H, 07DH, 0FCH; (* -4, FP *) - - (* code procedure for memory erase *) - - PROCEDURE [code] Erase (adr, words: INTEGER) - 089H, 0C7H, (* MOV EDI, EAX *) - 031H, 0C0H, (* XOR EAX, EAX *) - 059H, (* POP ECX *) - 0F2H, 0ABH; (* REP STOS *) - - (* code procedure for stack allocate *) - - PROCEDURE [code] ALLOC (* argument in CX *) - (* - PUSH EAX - ADD ECX,-5 - JNS L0 - XOR ECX,ECX - L0: AND ECX,-4 (n-8+3)/4*4 - MOV EAX,ECX - AND EAX,4095 - SUB ESP,EAX - MOV EAX,ECX - SHR EAX,12 - JEQ L2 - L1: PUSH 0 - SUB ESP,4092 - DEC EAX - JNE L1 - L2: ADD ECX,8 - MOV EAX,[ESP,ECX,-4] - PUSH EAX - MOV EAX,[ESP,ECX,-4] - SHR ECX,2 - RET - *); - - 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 Msg (IN str: ARRAY OF CHAR); - VAR ss: ARRAY 1024 OF SHORTCHAR; res, l: INTEGER; - BEGIN - ss := SHORT(str); - l := LEN(ss$); - ss[l] := 0AX; ss[l + 1] := 0X; - res := Libc.printf(ss) - END Msg; - - PROCEDURE Int (x: LONGINT); - VAR j, k: INTEGER; ch: CHAR; a, s: ARRAY 32 OF CHAR; - BEGIN - IF x # MIN(LONGINT) THEN - IF x < 0 THEN s[0] := "-"; k := 1; x := -x ELSE k := 0 END; - j := 0; REPEAT a[j] := CHR(x MOD 10 + ORD("0")); x := x DIV 10; INC(j) UNTIL x = 0 - ELSE - a := "8085774586302733229"; s[0] := "-"; k := 1; - j := 0; WHILE a[j] # 0X DO INC(j) END - END; - ASSERT(k + j < LEN(s), 20); - REPEAT DEC(j); ch := a[j]; s[k] := ch; INC(k) UNTIL j = 0; - s[k] := 0X; - Msg(s); - END Int; - - PROCEDURE (h: GuiHook) MessageBox* ( - title, msg: ARRAY OF CHAR; buttons: SET): INTEGER, NEW, ABSTRACT; - PROCEDURE (h: GuiHook) Beep*, NEW, ABSTRACT; - - (* Is extended by HostGnome to show dialogs. If no dialog is present or - if the dialog is not closed by using one button, then "mbClose" is returned *) - PROCEDURE MessageBox* (title, msg: ARRAY OF CHAR; buttons: SET): INTEGER; - VAR res: INTEGER; - BEGIN - IF guiHook # NIL THEN - res := guiHook.MessageBox(title, msg, buttons) - ELSE - Msg(" "); - Msg("****"); - Msg("* " + title); - Msg("* " + msg); - Msg("****"); - res := mbClose; - END; - RETURN res - END MessageBox; - - PROCEDURE SetGuiHook* (hook: GuiHook); - BEGIN - guiHook := hook - END SetGuiHook; - - 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 >= "A") & (ch <= "Z") OR (ch >= "À") & (ch # "×") & (ch <= "Þ")) - & ((lch < "A") OR (lch > "Z") & (lch < "À") OR (lch = "×") OR (lch > "Þ")); - 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 - ELSIF i < LEN(name) - 4 THEN - IF type = "" THEN ext := docType ELSE ext := type$ END; - name[i] := "."; INC(i); j := 0; ch := ext[0]; - WHILE ch # 0X DO - IF (ch >= "A") & (ch <= "Z") THEN - ch := CHR(ORD(ch) + ORD("a") - ORD("A")) - END; - name[i] := ch; INC(i); INC(j); ch := ext[j] - END; - name[i] := 0X - END - END MakeFileName; - - PROCEDURE Time* (): LONGINT; - VAR t: INTEGER; - BEGIN - (* t := WinApi.GetTickCount(); *) - - (* Linux *) - t := Libc.clock() DIV (Libc.CLOCKS_PER_SECOND DIV 1000); (* processor time to milliseconds *) - - IF t < told THEN INC(shift) END; - told := t; - RETURN shift * 100000000L + t - END Time; - - PROCEDURE Beep* (); - VAR ss: ARRAY 2 OF SHORTCHAR; - BEGIN - IF guiHook # NIL THEN - guiHook.Beep - ELSE - ss[0] := 007X; ss[1] := 0X; - res := Libc.printf(ss); res := Libc.fflush(Libc.NULL) - END - 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 --------------------- *) - - (* A. V. Shiryaev, 2012.10: NOTE: it seems that GC works correctly with positive addesses only *) - -(* - PROCEDURE HeapAlloc (adr: INTEGER; size: INTEGER; prot: SET): Libc.PtrVoid; - VAR - x: Libc.PtrVoid; - res: INTEGER; - BEGIN - x := Libc.calloc(1, size); (* calloc initialize allocated space to zero *) - IF x # Libc.NULL THEN - res := Libc.mprotect(x, size, prot); - IF res # 0 THEN - Libc.free(x); - x := Libc.NULL; - Msg("Kernel.HeapAlloc: mprotect failed!"); - HALT(100) - END - END; - RETURN x - END HeapAlloc; -*) - PROCEDURE HeapAlloc (adr: Libc.PtrVoid; size: INTEGER; prot: SET): Libc.PtrVoid; - VAR x: Libc.PtrVoid; - BEGIN - x := Libc.mmap(adr, size, prot, Libc.MAP_PRIVATE + Libc.MAP_ANON, zerofd, 0); - IF x = Libc.MAP_FAILED THEN - x := Libc.NULL - ELSE - ASSERT(size MOD 4 = 0, 100); - Erase(x, size DIV 4) - END; - RETURN x - END HeapAlloc; - -(* - PROCEDURE HeapFree (adr: Libc.PtrVoid; size: INTEGER); - VAR res: INTEGER; - BEGIN -(* - ASSERT(size MOD 4 = 0, 100); - Erase(adr, size DIV 4); - res := Libc.mprotect(adr, size, Libc.PROT_NONE); - ASSERT(res = 0, 101); -*) - Libc.free(adr) - END HeapFree; -*) - PROCEDURE HeapFree (adr: Libc.PtrVoid; size: INTEGER); - VAR res: INTEGER; - BEGIN -(* - ASSERT(size MOD 4 = 0, 100); - Erase(adr, size DIV 4); - res := Libc.mprotect(adr, size, Libc.PROT_NONE); - ASSERT(res = 0, 101); -*) - res := Libc.munmap(adr, size); - ASSERT(res = 0, 102) - END HeapFree; - - PROCEDURE AllocHeapMem (size: INTEGER; VAR c: Cluster); - (* allocate at least size bytes, typically at least 256 kbytes are allocated *) - CONST N = 65536; (* cluster size for dll *) - prot = Libc.PROT_READ + Libc.PROT_WRITE (* + Libc.PROT_EXEC *); - VAR adr: INTEGER; - allocated: INTEGER; - BEGIN - INC(size, 16); - ASSERT(size > 0, 100); adr := 0; - IF size < N THEN adr := HeapAlloc(65536, N, prot) END; - IF adr = 0 THEN adr := HeapAlloc(65536, size, prot); allocated := size ELSE allocated := N 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 - (* 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); - HeapFree(c.max, (S.VAL(INTEGER, c) - c.max) + c.size) - END FreeHeapMem; - - PROCEDURE AllocModMem* (descSize, modSize: INTEGER; VAR descAdr, modAdr: INTEGER); - CONST - prot = Libc.PROT_READ + Libc.PROT_WRITE (* + Libc.PROT_EXEC *); - BEGIN - descAdr := HeapAlloc(0, descSize, prot); - IF descAdr # 0 THEN - modAdr := HeapAlloc(0, modSize, prot); - IF modAdr # 0 THEN INC(used, descSize + modSize) - ELSE HeapFree(descAdr, descSize); descAdr := 0 - END - ELSE modAdr := 0 - END - END AllocModMem; - - PROCEDURE DeallocModMem* (descSize, modSize, descAdr, modAdr: INTEGER); - BEGIN - DEC(used, descSize + modSize); - HeapFree(descAdr, descSize); - HeapFree(modAdr, modSize) - END DeallocModMem; - - PROCEDURE InvalModMem (modSize, modAdr: INTEGER); - BEGIN - DEC(used, modSize); - HeapFree(modAdr, modSize) - END InvalModMem; - -(* - PROCEDURE IsReadable* (from, to: INTEGER): BOOLEAN; - (* check wether memory between from (incl.) and to (excl.) may be read *) - BEGIN - RETURN WinApi.IsBadReadPtr(from, to - from) = 0 - END IsReadable; -*) - - (* Alexander Shiryaev, 2012.10: Linux: can be implemented through mincore/madvise *) - (* This procedure can be called from TrapHandler also *) - PROCEDURE IsReadable* (from, to: INTEGER): BOOLEAN; - (* check wether memory between from (incl.) and to (excl.) may be read *) - VAR res: BOOLEAN; res1: INTEGER; - x: SHORTCHAR; - mask, omask: Libc.sigset_t; - BEGIN - (* save old sigmask and unblock SIGSEGV *) - res1 := Libc.sigemptyset(S.ADR(mask)); - ASSERT(res1 = 0, 100); - res1 := Libc.sigaddset(S.ADR(mask), Libc.SIGSEGV); - ASSERT(res1 = 0, 101); - res1 := Libc.sigprocmask(Libc.SIG_UNBLOCK, S.ADR(mask), S.ADR(omask)); - ASSERT(res1 = 0, 102); - - res := FALSE; - res1 := Libc.sigsetjmp(isReadableContext, Libc.TRUE); - IF res1 = 0 THEN - isReadableCheck := TRUE; - (* read memory *) - REPEAT - S.GET(from, x); - INC(from) - UNTIL from = to; - res := TRUE - ELSE - ASSERT(res1 = 1, 103) - END; - isReadableCheck := FALSE; - - (* restore saved sigmask *) - res1 := Libc.sigprocmask(Libc.SIG_SETMASK, S.ADR(omask), Libc.NULL); - ASSERT(res1 = 0, 104); - - RETURN res - END IsReadable; - - (* --------------------- NEW implementation (portable) -------------------- *) - - PROCEDURE^ NewBlock (size: INTEGER): Block; - - PROCEDURE NewRec* (typ: INTEGER): INTEGER; (* implementation of NEW(ptr) *) - VAR size: INTEGER; b: Block; tag: Type; l: FList; - BEGIN - IF ODD(typ) THEN (* record contains interface pointers *) - tag := S.VAL(Type, typ - 1); - b := NewBlock(tag.size); - IF b = NIL THEN RETURN 0 END; - b.tag := tag; - 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.iptr := TRUE; l.next := finalizers; finalizers := l; - RETURN S.ADR(b.last) - ELSE - tag := S.VAL(Type, typ); - b := NewBlock(tag.size); - IF b = NIL THEN RETURN 0 END; - 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; - RETURN S.ADR(b.last) - END - END NewRec; - - PROCEDURE NewArr* (eltyp, nofelem, nofdim: INTEGER): INTEGER; (* impl. of NEW(ptr, dim0, dim1, ...) *) - VAR b: Block; size, headSize: INTEGER; t: Type; fin: BOOLEAN; l: FList; - BEGIN - IF (nofdim < 0)OR(nofdim>1FFFFFFCH) THEN RETURN 0 END;(*20120822 Marc*) - headSize := 4 * nofdim + 12; fin := FALSE; - CASE eltyp OF -(* - | -1: eltyp := S.ADR(IntPtrType); fin := TRUE -*) - | -1: HALT(100) - | 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 (* eltyp is desc *) - IF ODD(eltyp) THEN DEC(eltyp); fin := TRUE END - END; - t := S.VAL(Type, eltyp); - ASSERT(t .size> 0,100); - IF (nofelem < 0) OR( (7FFFFFFFH-headSize) DIV t.size < nofelem) THEN (* 20120822 Marc*) - RETURN 0 - END; - size := headSize + nofelem * t.size; - b := NewBlock(size); - IF b = NIL THEN RETURN 0 END; - 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 *) - IF fin THEN - 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.aiptr := TRUE; l.next := finalizers; finalizers := l - END; - RETURN S.ADR(b.last) - 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 SHORTCHAR): Module, NEW, ABSTRACT; - - PROCEDURE SetLoaderHook*(h: LoaderHook); - BEGIN - loader := h - END SetLoaderHook; - - PROCEDURE InitModule (mod: Module); (* initialize linked modules *) - VAR body: Command; - res: INTEGER; errno: INTEGER; - 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; - - (* A. V. Shiryaev: Allow execution on code pages *) - (* Linux: must be page-aligned *) - res := Libc.mprotect( - (mod.code DIV pageSize) * pageSize, - ((mod.csize + mod.code MOD pageSize - 1) DIV pageSize) * pageSize + pageSize, - Libc.PROT_READ + Libc.PROT_WRITE + Libc.PROT_EXEC); - IF res = -1 THEN - S.GET( Libc.__errno_location(), errno ); - Msg("ERROR: Kernel.InitModule: mprotect failed!"); - Msg(mod.name$); Int(mod.code); Int(mod.csize); Int(errno); - HALT(100) - ELSE ASSERT(res = 0) - END; - - body(); actual := NIL - END - END InitModule; - - PROCEDURE ThisLoadedMod* (IN name: ARRAY OF SHORTCHAR): Module; (* loaded modules only *) - VAR m: Module; - BEGIN - loadres := done; - m := modList; - WHILE (m # NIL) & ((m.name # name) 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; - VAR n : Name; - BEGIN - n := SHORT(name$); - IF loader # NIL THEN - loader.res := done; - RETURN loader.ThisMod(n) - ELSE - RETURN ThisLoadedMod(n) - 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; name: ARRAY OF SHORTCHAR): Object; - VAR l, r, m: INTEGER; p: StrPtr; - BEGIN - 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^ = name THEN RETURN S.VAL(Object, S.ADR(mod.export.obj[m])) END; - IF p^ < name 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; name: ARRAY OF SHORTCHAR): Object; - VAR n: INTEGER; p: StrPtr; obj: Object; m: Module; - BEGIN - 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^ = name THEN RETURN obj END; - DEC(n); INC(S.VAL(INTEGER, obj), 16) - END; - RETURN NIL - END ThisField; - - PROCEDURE ThisCommand* (mod: Module; name: ARRAY OF SHORTCHAR): 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; name: ARRAY OF SHORTCHAR): 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 GetObjName* (mod: Module; obj: Object; VAR name: Name); - VAR p: StrPtr; - BEGIN - p := S.VAL(StrPtr, S.ADR(mod.names[obj.id DIV 256])); - name := p^$ - END GetObjName; - - PROCEDURE GetTypeName* (t: Type; VAR name: Name); - VAR p: StrPtr; - BEGIN - p := S.VAL(StrPtr, S.ADR(t.mod.names[t.id DIV 256])); - name := p^$ - END GetTypeName; - - PROCEDURE RegisterMod* (mod: Module); - VAR i: INTEGER; - t: Libc.time_t; tm: Libc.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; - - t := Libc.time(NIL); - tm := Libc.localtime(t); - mod.loadTime[0] := SHORT(tm.tm_year + 1900); (* Linux counts years from 1900 but BlackBox from 0000 *) - mod.loadTime[1] := SHORT(tm.tm_mon + 1) (* Linux month range 0-11 but BB month range 1-12 *); - 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); - tm := NIL; - - 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; -(* - ReleaseIPtrs(mod); (* release global interface pointers *) -*) - 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 --------------------- *) (* COMPILER DEPENDENT *) - - PROCEDURE [1] PUSH (p: INTEGER) 050H; (* push AX *) - PROCEDURE [1] CALL (a: INTEGER) 0FFH, 0D0H; (* call AX *) - PROCEDURE [1] RETI (): LONGINT; - PROCEDURE [1] RETR (): REAL; - - (* - 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: INTEGER; sig: Signature; IN par: ARRAY OF INTEGER; n: INTEGER): LONGINT; - VAR p, kind, sp, size: INTEGER; typ: Type; r: REAL; - BEGIN - p := sig.num; - WHILE p > 0 DO (* push parameters from right to left *) - DEC(p); - typ := sig.par[p].struct; - kind := sig.par[p].id MOD 16; - IF (S.VAL(INTEGER, typ) DIV 256 = 0) OR (typ.id MOD 4 IN {0, 3}) THEN (* scalar *) - IF (kind = 10) & ((S.VAL(INTEGER, typ) = 8) OR (S.VAL(INTEGER, typ) = 10)) THEN (* 64 bit *) - DEC(n); PUSH(par[n]) (* push hi word *) - END; - DEC(n); PUSH(par[n]) (* push value/address *) - ELSIF typ.id MOD 4 = 1 THEN (* record *) - IF kind # 10 THEN (* var par *) - DEC(n); PUSH(par[n]); (* push tag *) - DEC(n); PUSH(par[n]) (* push address *) - ELSE - DEC(n, 2); (* skip tag *) - S.GETREG(SP, sp); sp := (sp - typ.size) DIV 4 * 4; S.PUTREG(SP, sp); (* allocate space *) - S.MOVE(par[n], sp, typ.size) (* copy to stack *) - END - ELSIF typ.size = 0 THEN (* open array *) - size := typ.id DIV 16 MOD 16; (* number of open dimensions *) - WHILE size > 0 DO - DEC(size); DEC(n); PUSH(par[n]) (* push length *) - END; - DEC(n); PUSH(par[n]) (* push address *) - ELSE (* fix array *) - IF kind # 10 THEN (* var par *) - DEC(n, 2); PUSH(par[n]) (* push address *) - ELSE - DEC(n); size := par[n]; DEC(n); - S.GETREG(SP, sp); sp := (sp - size) DIV 4 * 4; S.PUTREG(SP, sp); (* allocate space *) - S.MOVE(par[n], sp, size) (* copy to stack *) - END - END - END; - ASSERT(n = 0); - IF S.VAL(INTEGER, sig.retStruct) = 7 THEN (* shortreal *) - CALL(adr); - RETURN S.VAL(INTEGER, SHORT(RETR())) (* return value in fpu register *) - ELSIF S.VAL(INTEGER, sig.retStruct) = 8 THEN (* real *) - CALL(adr); r := RETR(); - RETURN S.VAL(LONGINT, r) (* return value in fpu register *) - ELSE - CALL(adr); - RETURN RETI() (* return value in integer registers *) - END - END Call; - - (* -------------------- reference information (portable) --------------------- *) - - PROCEDURE RefCh (VAR ref: INTEGER; VAR ch: SHORTCHAR); - BEGIN - S.GET(ref, ch); INC(ref) - END RefCh; - - PROCEDURE RefNum (VAR ref: INTEGER; VAR 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; VAR n: Name); - 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; VAR adr: INTEGER; VAR name: Name); - 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; - - (* A. V. Shiryaev, 2012.11 *) - PROCEDURE CheckRefVarReadable (ref: INTEGER): BOOLEAN; - VAR ok: BOOLEAN; ch: SHORTCHAR; - p: INTEGER; (* address *) - - PROCEDURE Get; - BEGIN - IF ok THEN - IF IsReadable(ref, ref+1) THEN (* S.GET(ref, ch); INC(ref) *) RefCh(ref, ch) - ELSE ok := FALSE - END - END - END Get; - - PROCEDURE Num; - BEGIN - Get; WHILE ok & (ORD(ch) >= 128) DO Get END - END Num; - - PROCEDURE Name; - BEGIN - Get; WHILE ok & (ch # 0X) DO Get END - END Name; - - BEGIN - ok := TRUE; - Get; (* mode *) - IF ok & (ch >= 0FDX) THEN - Get; (* form *) - IF ok & (ch = 10X) THEN - IF IsReadable(ref, ref + 4) THEN (* desc *) - S.GET(ref, p); INC(ref, 4); - ok := IsReadable(p + 2 * 4, p + 3 * 4) (* desc.id *) - ELSE ok := FALSE - END - END; - Num; Name - END; - RETURN ok - END CheckRefVarReadable; - - PROCEDURE GetRefVar* (VAR ref: INTEGER; VAR mode, form: SHORTCHAR; VAR desc: Type; - VAR adr: INTEGER; VAR name: Name); - BEGIN - IF CheckRefVarReadable(ref) THEN - 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 - ELSE - Msg("Kernel.GetRefVar failed!"); Int(ref); - 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: Name; - BEGIN - ref := mod.refs; pos := 0; ad := 0; S.GET(ref, ch); - WHILE ch # 0X DO - WHILE (ch > 0X) & (ch < 0FCX) DO - 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 INC(ref); RefNum(ref, d); RefName(ref, name); S.GET(ref, ch) END; - WHILE ch >= 0FDX DO (* skip variables *) - 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; - RETURN -1 - END SourcePos; - - (* -------------------- dynamic link libraries --------------------- *) - -(* - PROCEDURE DlOpen (name: ARRAY OF SHORTCHAR): Dl.HANDLE; - CONST flags = Dl.RTLD_LAZY + Dl.RTLD_GLOBAL; - VAR h: Dl.HANDLE; - i: INTEGER; - BEGIN - h := Dl.NULL; - i := 0; WHILE (i < LEN(name)) & (name[i] # 0X) DO INC(i) END; - IF i < LEN(name) THEN - h := Dl.dlopen(name, flags); - WHILE (h = Dl.NULL) & (i > 0) DO - DEC(i); - WHILE (i > 0) & (name[i] # '.') DO DEC(i) END; - IF i > 0 THEN - name[i] := 0X; - h := Dl.dlopen(name, flags); - (* IF h # Dl.NULL THEN Msg(name$) END *) - END - END - END; - RETURN h - END DlOpen; -*) - - PROCEDURE LoadDll* (IN name: ARRAY OF SHORTCHAR; VAR ok: BOOLEAN); - VAR h: Dl.HANDLE; - BEGIN - ok := FALSE; - h := Dl.dlopen(name, Dl.RTLD_LAZY + Dl.RTLD_GLOBAL); - IF h # Dl.NULL THEN ok := TRUE END - END LoadDll; - - PROCEDURE ThisDllObj* (mode, fprint: INTEGER; IN dll, name: ARRAY OF SHORTCHAR): INTEGER; - VAR ad: INTEGER; h: Dl.HANDLE; - BEGIN - ad := 0; - IF mode IN {mVar, mProc} THEN - h := Dl.dlopen(dll, Dl.RTLD_LAZY+ Dl.RTLD_GLOBAL); - IF h # Dl.NULL THEN - ad := Dl.dlsym(h, name); - END - END; - RETURN ad - 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; - -(* This is the specification for the code procedure following below: - - 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 [code] Next (b: Block): Block (* next block in same cluster *) - (* - MOV ECX,[EAX] b.tag - AND CL,0FCH b.tag DIV * 4 - MOV ECX,[ECX] size - TESTB [EAX],02H ODD(b.tag DIV 2) - JE L1 - ADD ECX,[EAX,4] size + b.last - SUB ECX,EAX - SUB ECX,4 size + b.last - ADR(b.last) - L1: - ADD ECX,19 size + 19 - AND CL,0F0H (size + 19) DIV 16 * 16 - ADD EAX,ECX b + size - *) - 08BH, 008H, - 080H, 0E1H, 0FCH, - 08BH, 009H, - 0F6H, 000H, 002H, - 074H, 008H, - 003H, 048H, 004H, - 029H, 0C1H, - 083H, 0E9H, 004H, - 083H, 0C1H, 013H, - 080H, 0E1H, 0F0H, - 001H, 0C8H; - - 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 - S.GETREG(FP, 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); - IF f.aiptr THEN (* ArrFinalizer(S.VAL(ANYPTR, S.ADR(f.blk.last))) *) - ELSE - 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; -(* - IF f.iptr THEN RecFinalizer(S.VAL(ANYPTR, S.ADR(f.blk.last))) END -*) - 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 *) - IF debug & (watcher # NIL) THEN watcher(1) END; - MarkGlobals; - MarkLocals; - CheckFinalizers; - Sweep(TRUE); - CallFinalizers - END - END Collect; - - PROCEDURE FastCollect*; - BEGIN - IF root # NIL THEN - IF debug & (watcher # NIL) THEN watcher(2) END; - 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 - IF debug & (watcher # NIL) THEN watcher(3) END; - 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 >7FFFFFECH THEN RETURN NIL END; (*20120822 Marc*) - 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^ InitFpu; - - PROCEDURE Start* (code: Command); - BEGIN - restart := code; - S.GETREG(SP, baseStack); (* save base stack *) - res := Libc.sigsetjmp(loopContext, Libc.TRUE); - code() - END Start; - - PROCEDURE Quit* (exitCode: INTEGER); - VAR m: Module; term: Command; t: BOOLEAN; - res: INTEGER; - 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; -(* - ReleaseIPtrs(m); -*) - m := m.next - END; - CallFinalizers; - hotFinalizers := finalizers; finalizers := NIL; - CallFinalizers; -(* - IF ~inDll THEN - RemoveExcp(excpPtr^); - WinApi.ExitProcess(exitCode) (* never returns *) - END -*) - - res := Libc.fflush(0); - Libc.exit(exitCode) - END Quit; - - PROCEDURE FatalError* (id: INTEGER; str: ARRAY OF CHAR); - VAR res: INTEGER; 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 := WinApi.MessageBoxW(0, str, title, {}); -*) - text := SHORT(str$); - res := MessageBox(title$, SHORT(str), {mbOk}); -(* - IF ~inDll THEN RemoveExcp(excpPtr^) END; -*) -(* - WinApi.ExitProcess(1) -*) - Libc.exit(1) - (* never returns *) - END FatalError; - - PROCEDURE DefaultTrapViewer; - VAR len, ref, end, x, a, b, c: INTEGER; mod: Module; - name: Name; out: ARRAY 1024 OF SHORTCHAR; - - PROCEDURE WriteString (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 (* 0DX on Windows *); INC(len) END - END WriteLn; - - BEGIN - len := 0; - 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 = 200 THEN WriteString("keyboard interrupt") - 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 < 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; - a := pc; b := fp; c := 12; - REPEAT - WriteLn; WriteString("- "); - mod := modList; - WHILE (mod # NIL) & ((a < mod.code) OR (a >= mod.code + mod.csize)) DO mod := mod.next END; - IF mod # NIL THEN - DEC(a, mod.code); - IF mod.refcnt >= 0 THEN - WriteString(mod.name); ref := mod.refs; - REPEAT GetRefProc(ref, end, name) UNTIL (end = 0) OR (a < end); - IF a < end THEN - WriteString("."); WriteString(name) - END - ELSE - WriteString("("); WriteString(mod.name); WriteString(")") - END; - WriteString(" ") - END; - WriteString("(pc="); WriteHex(a, 8); - WriteString(", fp="); WriteHex(b, 8); WriteString(")"); - IF (b >= sp) & (b < stack) THEN - S.GET(b+4, a); (* stacked pc *) - S.GET(b, b); (* dynamic link *) - DEC(c) - ELSE c := 0 - END - UNTIL c = 0; - out[len] := 0X; - x := MessageBox("BlackBox", out$, {mbOk}) - 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 res: INTEGER; context: Libc.sigjmp_buf; oldContext: POINTER TO Libc.sigjmp_buf; - BEGIN - oldContext := currentTryContext; - res := Libc.sigsetjmp(context, Libc.TRUE); - currentTryContext := S.ADR(context); - IF res = 0 THEN (* first time around *) - h(a, b, c); - ELSIF res = trapReturn THEN (* after a trap *) - ELSE - HALT(100) - END; - currentTryContext := oldContext; - END Try; - - (* -------------------- Initialization --------------------- *) - - PROCEDURE InitFpu; (* COMPILER DEPENDENT *) - (* could be eliminated, delayed for backward compatibility *) - VAR cw: SET; - BEGIN - FINIT; - FSTCW; - (* denorm, underflow, precision, zero div, overflow masked *) - (* invalid trapped *) - (* round to nearest, temp precision *) - cw := cw - {0..5, 8..11} + {1, 2, 3, 4, 5, 8, 9}; - FLDCW - END InitFpu; - - PROCEDURE [ccall] TrapHandler (sig: INTEGER; siginfo: Libc.Ptrsiginfo_t; context: Libc.Ptrucontext_t); - BEGIN - IF isReadableCheck THEN - isReadableCheck := FALSE; - Msg("~IsReadable"); - Libc.siglongjmp(isReadableContext, 1) - END; - - (* - S.GETREG(SP, sp); - S.GETREG(FP, fp); - *) - stack := baseStack; - - sp := context.uc_mcontext.gregs[7]; (* TODO: is the stack pointer really stored in register 7? *) - fp := context.uc_mcontext.gregs[6]; (* TODO: is the frame pointer really stored in register 6? *) - pc := context.uc_mcontext.gregs[14]; (* TODO: is the pc really stored in register 14? *) - val := siginfo.si_addr; - - (* - Int(sig); Int(siginfo.si_signo); Int(siginfo.si_code); Int(siginfo.si_errno); - Int(siginfo.si_status); Int(siginfo.si_value); Int(siginfo.si_int); - *) - err := sig; - IF trapped THEN DefaultTrapViewer END; - CASE sig OF - Libc.SIGINT: - err := 200 (* Interrupt (ANSI). *) - | Libc.SIGILL: (* Illegal instruction (ANSI). *) - err := 202; val := 0; - IF IsReadable(pc, pc + 4) THEN - S.GET(pc, val); - IF val MOD 100H = 8DH THEN (* lea reg,reg *) - IF val DIV 100H MOD 100H = 0F0H THEN - err := val DIV 10000H MOD 100H (* trap *) - ELSIF val DIV 1000H MOD 10H = 0EH THEN - err := 128 + val DIV 100H MOD 10H (* run time error *) - END - END - END - | Libc.SIGFPE: - CASE siginfo.si_code OF - 0: (* TODO: ?????? *) - IF siginfo.si_int = 8 THEN - err := 139 - ELSIF siginfo.si_int = 0 THEN - err := 143 - END - | Libc.FPE_INTDIV: err := 139 (* Integer divide by zero. *) - | Libc.FPE_INTOVF: err := 138 (* Integer overflow. *) - | Libc.FPE_FLTDIV: err := 140 (* Floating point divide by zero. *) - | Libc.FPE_FLTOVF: err := 142 (* Floating point overflow. *) - | Libc.FPE_FLTUND: err := 141 (* Floating point underflow. *) - | Libc.FPE_FLTRES: err := 143 (* Floating point inexact result. *) - | Libc.FPE_FLTINV: err := 143 (* Floating point invalid operation. *) - | Libc.FPE_FLTSUB: err := 134 (* Subscript out of range. *) - ELSE - END - | Libc.SIGSEGV: (* Segmentation violation (ANSI). *) - err := 203 - ELSE - END; - INC(trapCount); - InitFpu; - TrapCleanup; - IF err # 128 THEN - IF (trapViewer = NIL) OR trapped THEN - DefaultTrapViewer - ELSE - trapped := TRUE; - trapViewer(); - trapped := FALSE - END - END; - IF currentTryContext # NIL THEN (* Try failed *) - Libc.siglongjmp(currentTryContext, trapReturn) - ELSE - IF restart # NIL THEN (* Start failed *) - Libc.siglongjmp(loopContext, trapReturn) - END; - Quit(1); (* FIXME *) - END; - trapped := FALSE - END TrapHandler; - - PROCEDURE InstallSignals*; - VAR sa, old: Libc.sigaction_t; res, i: INTEGER; -(* - sigstk: Libc.stack_t; - errno: INTEGER; -*) - BEGIN -(* - (* A. V. Shiryaev: Set alternative stack on which signals are to be processed *) - sigstk.ss_sp := sigStack; - sigstk.ss_size := sigStackSize; - sigstk.ss_flags := 0; - res := Libc.sigaltstack(sigstk, NIL); - IF res # 0 THEN Msg("ERROR: Kernel.InstallSignals: sigaltstack failed!"); - S.GET( Libc.__errno_location(), errno ); - Int(errno); - Libc.exit(1) - END; -*) - - sa.sa_sigaction := TrapHandler; -(* - res := LinLibc.sigemptyset(S.ADR(sa.sa_mask)); -*) - res := Libc.sigfillset(S.ADR(sa.sa_mask)); - sa.sa_flags := (* Libc.SA_ONSTACK + *) Libc.SA_SIGINFO; (* TrapHandler takes three arguments *) - (* - IF LinLibc.sigaction(LinLibc.SIGINT, sa, old) # 0 THEN Msg("failed to install SIGINT") END; - IF LinLibc.sigaction(LinLibc.SIGILL, sa, old) # 0 THEN Msg("failed to install SIGILL") END; - IF LinLibc.sigaction(LinLibc.SIGFPE, sa, old) # 0 THEN Msg("failed to install SIGFPE") END; - IF LinLibc.sigaction(LinLibc.SIGSEGV, sa, old) # 0 THEN Msg("failed to install SIGSEGV") END; - IF LinLibc.sigaction(LinLibc.SIGPIPE, sa, old) # 0 THEN Msg("failed to install SIGPIPE") END; - IF LinLibc.sigaction(LinLibc.SIGTERM, sa, old) # 0 THEN Msg("failed to install SIGTERM") END; - *) - (* respond to all possible signals *) - FOR i := 1 TO Libc._NSIG - 1 DO - IF (i # Libc.SIGKILL) - & (i # Libc.SIGSTOP) - & (i # Libc.SIGWINCH) - THEN - IF Libc.sigaction(i, sa, old) # 0 THEN (* Msg("failed to install signal"); Int(i) *) END; - END - END - END InstallSignals; - - PROCEDURE Init; - VAR i: INTEGER; - BEGIN -(* - (* for sigaltstack *) - sigStack := Libc.calloc(1, sigStackSize); - IF sigStack = Libc.NULL THEN - Msg("ERROR: Kernel.Init: calloc(1, sigStackSize) failed!"); - Libc.exit(1) - END; -*) - (* for mmap *) - zerofd := Libc.open("/dev/zero", Libc.O_RDWR, {0..8}); - IF zerofd < 0 THEN - Msg("ERROR: Kernel.Init: can not open /dev/zero!"); - Libc.exit(1) - END; - (* for mprotect *) - pageSize := Libc.sysconf(Libc._SC_PAGESIZE); - IF pageSize < 0 THEN - Msg("ERROR: Kernel.Init: pageSize < 0!"); - Libc.exit(1) - END; - - isReadableCheck := FALSE; - - InstallSignals; (* init exception handling *) - currentTryContext := NIL; - - allocated := 0; total := 0; used := 0; - sentinelBlock.size := MAX(INTEGER); - sentinel := S.ADR(sentinelBlock); - -(* - S.PUTREG(ML, S.ADR(modList)); -*) - - i := N; - REPEAT DEC(i); free[i] := sentinel UNTIL i = 0; - - IF inDll THEN -(* - baseStack := FPageWord(4); (* begin of stack segment *) -*) - END; - InitFpu; - IF ~static THEN - InitModule(modList); - IF ~inDll THEN Quit(1) END - END; - told := 0; shift := 0 - END Init; - -BEGIN - IF modList = NIL THEN (* only once *) - S.GETREG(SP, baseStack); (* TODO: Check that this is ok. *) - IF bootInfo # NIL THEN - modList := bootInfo.modList (* boot loader initializes the bootInfo struct *) - ELSE - S.GETREG(ML, modList) (* linker loads module list to BX *) - END; - static := init IN modList.opts; - inDll := dll IN modList.opts; - Init - END -CLOSE - IF ~terminating THEN - terminating := TRUE; - Quit(0) - END -END Kernel.