SSyntax10.Scn.Fnt'vp_VersionElemsAllocBeg#Syntax10.Scn.FntWindowsNT Windows31WindowsNTWindowsNT Windows31#Syntax10.Scn.Fnt Windows 3.1 p_VersionElemsAllocEnd/Syntax10b.Scn.Fnt/3 Syntax10i.Scn.FntE@       /IW& z@ p_#Syntax10.Scn.FntWindowsNT Windows31WindowsNTWindowsNT Windows31 -l#f(e*et"% p_Syntax8.Scn.Fnt MarkElemsAlloc]b# ]bT"O>wP>Q>R>t p_#Syntax10.Scn.FntWindowsNT Windows31WindowsNTWindowsNT Windows31 |p_| p_#Syntax10.Scn.FntWindowsNT Windows31WindowsNTWindowsNT Windows31 p_T>V>W> X>>r +YNIY> "Z>u/v#2Syntax12.Scn.Fntxu 0 a 5 3 5 3=5w##o\>~Syntax8i.Scn.Fnt_*0B ` zRv   85%TFO/%0]bP]{  60^>KY_>  `>3*  u     Ka>7 < '$a>AJb>jTV9p#Syntax10.Scn.FntWindowsNT Windows31WindowsNTWindowsNT Windows31Syntax10.Scn.Fnt MarkElemsAlloc]bSyntax10b.Scn.FntSyntax10i.Scn.Fnt APROCEDURE SuspendThreads*; (* dummy *) BEGIN END SuspendThreads; ]b8pp#Syntax10.Scn.FntWindowsNT Windows31WindowsNTWindowsNT Windows31Syntax10.Scn.Fnt MarkElemsAlloc]bSyntax10b.Scn.Fnt Syntax10i.Scn.Fnt ?PROCEDURE ResumeThreads*; (* dummy *) BEGIN END ResumeThreads; ]b 0p ]b( d>]bYp#Syntax10.Scn.FntWindowsNT Windows31WindowsNTWindowsNT Windows31  "]b-]bpZ p#Syntax10.Scn.FntWindowsNT Windows31WindowsNTWindowsNT Windows31 C8FoldElemsNew#Syntax10.Scn.Fntth := threads; self := GetCurrentThreadId(); WHILE th # NIL DO IF th.id # loopThreadId THEN CheckThreadStack(th.handle) END ; th := th.next END ;V8pe>f>I]bwh>#o>i>j>k>>M!%l>m>n> eo> Hp>q> r>  W3-  k!p_#Syntax10.Scn.FntWindowsNT Windows31WindowsNTWindowsNT Windows31 p_MODULE Kernel; (* RC 23.7.92 / MH 3.2.1994 / 5.1.95 / CS 21.08.96 *) (* WARNING: do not use NEW nor SYSTEM.NEW in this module !! use NewRec, NewArr or NewSys instead *) (* Finalization due to J. Templ *) (* There are two different versions! Windows 3.1 and Windows NT Use the VersionElem => Windows NT *) IMPORT S := SYSTEM, C := Console; CONST MarkBit* = 0; TYPE Name* = ARRAY 32 OF CHAR; Tag* = POINTER TO TypeDesc; ADDRESS = LONGINT; Cmd* = RECORD name*: Name; adr*: ADDRESS END ; TerminationHandler* = PROCEDURE; Module* = POINTER TO ModuleDesc; ModuleDesc* = RECORD next*: Module; name*: Name; init*: BOOLEAN; key*, refcnt*, sb*: LONGINT; varEntries*: POINTER TO ARRAY OF ADDRESS; entries*: POINTER TO ARRAY OF ADDRESS; cmds*: POINTER TO ARRAY OF Cmd; ptrTab*: POINTER TO ARRAY OF ADDRESS; tdescs*: POINTER TO ARRAY OF (* Tag *) ADDRESS; imports*: POINTER TO ARRAY OF (* Module *) ADDRESS; data*, code*: POINTER TO ARRAY OF CHAR; refs*: POINTER TO ARRAY OF CHAR; term*: TerminationHandler END ; Notifier* = PROCEDURE; Queue* = RECORD notify: ARRAY 8 OF Notifier END ; Stack = POINTER TO StackDesc; StackDesc = RECORD beg, end: LONGINT; next: Stack END ; Thread = POINTER TO ThreadDesc; ThreadDesc = RECORD handle, id: LONGINT; next: Thread END ; VAR (* the first variable is initialized by the boot loader in Windows *) getadr-: PROCEDURE (adr: ADDRESS; symbol: ADDRESS; handle: LONGINT); modules*: Module; heapAdr-, heapSize-: LONGINT; GCenabled*: BOOLEAN; stackBottom*: LONGINT; (* pointer to dynamic link of Oberon.Loop *) EventLoop*: PROCEDURE ; prepQ*, quitQ*, gcQ*, afterQ*: Queue; (* prep queue called before GC, gc queue during GC *) exit: PROCEDURE (code: LONGINT); loadLibrary: PROCEDURE (name: LONGINT): LONGINT; freeLibrary: PROCEDURE(lib: LONGINT); GetLocalTime: PROCEDURE (systime: LONGINT); SetLocalTime: PROCEDURE (systime: LONGINT); GetVersion: PROCEDURE(): LONGINT; mod: LONGINT; initialised: BOOLEAN; WinNT: BOOLEAN; TYPE TypeDesc = RECORD size: LONGINT; ptroff: LONGINT END ; FreeBlockPtr = POINTER TO FreeBlock; FreeBlock = RECORD (* off-4 *) tag: Tag; (* off0 *) size: LONGINT; (* field size aligned to 8-byte boundary, size MOD B = B-4 *) (* off4 *) next: ADDRESS END ; Block* = POINTER TO BlockDesc; BlockDesc = RECORD lastElemToMark, currElem, firstElem: Block END ; Blockm4Ptr = POINTER TO Blockm4; Blockm4 = RECORD tag: Tag; lastElemToMark, currElem, firstElem: LONGINT END ; InitPtr = POINTER TO RECORD tag: Tag; z0, z1, z2, z3, z4, z5, z6, z7: LONGINT END ; PtrElemDesc = RECORD a: S.PTR END ; (* has same type descriptor as element of ARRAY OF POINTER *) Finalizer* = PROCEDURE (obj: S.PTR); FinObj = POINTER TO FinObjNode; FinObjNode = RECORD next: FinObj; obj: LONGINT; marked: BOOLEAN; fin: Finalizer END ; CONST B = 32; (* must be a mutiple of 32 *) N = 9; nil = 0; SubObjBit = 3; subobj = {SubObjBit}; mark = {MarkBit}; array = {1}; ReserveSize = 65536-8; VAR TrapHandlingLevel*: LONGINT; firstBlock, endBlock: (*FreeBlockPtr*) ADDRESS; (* free blocks must be collected !! *) A: ARRAY N+1 OF (*FreeBlockPtr*) ADDRESS; reserve: Block; ptrElemTag: Tag; firstStack, curStack: Stack; firstTry, checkStack: BOOLEAN; nofcand: INTEGER; finObjs: FinObj; threads: Thread; ShowMsg: PROCEDURE (msg: LONGINT); TYPE FloatingSaveArea = RECORD ControlWord, StatusWord, TagWord, ErrorOffset, ErrorSelector, DataOffset, DataSelector: LONGINT; RegisterArea: ARRAY 80 OF S.BYTE; Cr0NpxState: LONGINT END ; ContextDesc = RECORD (* The flags values within this flag control the contents of a CONTEXT record. If the context record is used as an input parameter, then for each portion of the context record controlled by a flag whose value is set, it is assumed that that portion of the context record contains valid context. If the context record is being used to modify a thread's context, then only that portion of the thread's context will be modified. If the context record is used as an IN OUT parameter to capture the context of a thread, then only those portions of the thread's context corresponding to set flags will be returned. The context record is never used as an OUT only parameter. *) ContextFlags: LONGINT; (* This section is specified/returned if CONTEXT_DEBUG_REGISTERS is set in ContextFlags. Note that CONTEXT_DEBUG_REGISTERS is NOT included in CONTEXT_FULL. *) Dr0, Dr1, Dr2, Dr3, Dr6, Dr7: LONGINT; (* This section is specified/returned if the ContextFlags word contains the flag CONTEXT_FLOATING_POINT. *) FloatSave: FloatingSaveArea; (* This section is specified/returned if the ContextFlags word contains the flag CONTEXT_SEGMENTS. *) SegGs, SegFs, SegEs, SegDs: LONGINT; (* This section is specified/returned if the ContextFlags word contains the flag CONTEXT_INTEGER. *) Edi, Esi, Ebx, Edx, Ecx, Eax: LONGINT; (* This section is specified/returned if the ContextFlags word contians the flag CONTEXT_CONTROL. *) Ebp, Eip, SegCs, EFlags, Esp, SegSs: LONGINT; END ; MemoryBasicInformation = RECORD baseAddress: LONGINT; (* base address of region *) allocationBase: LONGINT; (* allocation base address *) allocationProtect: LONGINT; (* nitial access protection *) regionSize: LONGINT; (* size, in bytes, of region *) state: LONGINT; (* committed, reserved, free *) protect: LONGINT; (* current access protection *) type: LONGINT (* type of pages *) END ; VAR GetThreadContext: PROCEDURE (handle: LONGINT; context: LONGINT): BOOLEAN; SuspendThread: PROCEDURE (handle: LONGINT): LONGINT; ResumeThread: PROCEDURE (handle: LONGINT): LONGINT; ReadProcessMemory: PROCEDURE (handle, baseAdr, bufAdr, size: LONGINT; VAR nofRead: LONGINT): BOOLEAN; GetCurrentThread: PROCEDURE (): LONGINT; GetCurrentThreadId: PROCEDURE (): LONGINT; GetCurrentProcess: PROCEDURE (): LONGINT; GetLastError: PROCEDURE (): LONGINT; DuplicateHandle: PROCEDURE (srcProcess, srcHandle, destProcess: LONGINT; VAR destHandle: LONGINT; access: LONGINT; inheritHandle: BOOLEAN; options: LONGINT): BOOLEAN; context: ContextDesc; loopThreadId: LONGINT; VirtualQueryEx: PROCEDURE (process: LONGINT; adr: LONGINT; buffer, bufSize: LONGINT): LONGINT; (* HANDLE hProcess, // handle of process LPCVOID lpAddress, // address of region PMEMORY_BASIC_INFORMATION lpBuffer, // address of information buffer DWORD dwLength // size of buffer *)  PROCEDURE ^ NewRec* (tag: Tag; VAR p: ADDRESS); PROCEDURE New (VAR o: S.PTR); BEGIN NewRec(S.VAL(Tag, o), S.VAL(LONGINT, o)) END New; (* --- queues --- *) PROCEDURE (VAR q: Queue) Init*; VAR i: INTEGER; BEGIN FOR i := 0 TO LEN(q.notify)-1 DO q.notify[i] := NIL END END Init; PROCEDURE (VAR q: Queue) Add* (notify: Notifier); VAR i: INTEGER; BEGIN FOR i := 0 TO LEN(q.notify)-1 DO IF q.notify[i] = NIL THEN q.notify[i] := notify; RETURN END END END Add; PROCEDURE (VAR q: Queue) Remove* (notify: Notifier); VAR i: INTEGER; BEGIN FOR i := 0 TO LEN(q.notify)-1 DO IF q.notify[i] = notify THEN q.notify[i] := NIL; RETURN END END END Remove; PROCEDURE (VAR q: Queue) Handle*; VAR i: INTEGER; BEGIN FOR i := LEN(q.notify)-1 TO 0 BY - 1 DO IF q.notify[i] # NIL THEN q.notify[i] END END END Handle; PROCEDURE AddThread* (handle, id: LONGINT);  VAR thread: Thread; BEGIN New(thread); thread.next := threads; thread.handle := handle; thread.id := id; threads := thread END AddThread; PROCEDURE RemoveThread* (id: LONGINT);  VAR thread, prev: Thread; BEGIN thread := threads; WHILE (thread # NIL) & (thread.id # id) DO prev := thread; thread := thread.next END ; IF (thread # NIL) & (thread.id # loopThreadId) THEN IF thread = threads THEN threads := thread.next ELSE prev.next := thread.next END END END RemoveThread; PROCEDURE RegisterObject* (obj: S.PTR; fin: Finalizer); VAR n: FinObj; BEGIN IF obj = NIL THEN RETURN END ; New(n); n.next := finObjs; n.obj := S.VAL(LONGINT, obj); n.marked := FALSE; n.fin := fin; finObjs := n END RegisterObject; PROCEDURE InstallTermHandler* (h: TerminationHandler); VAR codebase, handlerAdr: LONGINT; m: Module; found: BOOLEAN; BEGIN m := modules; handlerAdr := S.VAL(LONGINT, h); found := FALSE; WHILE (m # NIL) & ~found DO codebase := S.ADR(m.code^); IF (codebase <= handlerAdr) & (handlerAdr <= codebase + LEN(m.code^)) THEN found := TRUE ELSE m := m.next END END ; IF found THEN m.term := h END END InstallTermHandler; PROCEDURE Available*(): LONGINT; VAR i, avail: LONGINT; ptr: FreeBlockPtr; BEGIN avail := 0; i := 0; WHILE i <= N DO ptr := S.VAL(FreeBlockPtr, A[i]); WHILE ptr # NIL DO INC(avail, ptr^.size); ptr := S.VAL(FreeBlockPtr, ptr^.next) END ; INC(i) END ; RETURN avail END Available; PROCEDURE LargestAvailable*(): LONGINT; VAR i, max: LONGINT; ptr: FreeBlockPtr; BEGIN i := N; max := 0; WHILE (i >= 0) & (max = 0) DO ptr := S.VAL(FreeBlockPtr, A[i]); WHILE ptr # NIL DO IF ptr^.size > max THEN max := ptr^.size END ; ptr := S.VAL(FreeBlockPtr, ptr^.next) END ; DEC(i) END ; RETURN max END LargestAvailable; (* ------------------------- garbage collector ----------------------- *) PROCEDURE MarkState*; (*called at the very beginning of Oberon.Loop*) VAR SP: LONGINT; BEGIN S.GETREG(4, SP); New(curStack); curStack.beg := SP + 4 * 3; (* skip EIP (pushed on call MarkState), EBP (prolog of MarkState), and SP *) curStack.next := NIL; firstStack := curStack END MarkState; PROCEDURE RemoveStack* (pos: LONGINT); VAR s, last: Stack; BEGIN s := firstStack; WHILE (s # NIL) & ((pos < s.beg) OR (pos > s.end)) DO last := s; s := s.next END; IF (s # NIL) & (s # curStack) THEN IF s = firstStack THEN firstStack := s.next ELSE last.next := s.next END END END RemoveStack; PROCEDURE AddStack* (beg, end: LONGINT); VAR s: Stack; BEGIN RemoveStack(beg); New(s); s.beg := beg; s.end := end; s.next := firstStack; firstStack := s END AddStack; (* PROCEDURE ReadNum (VAR pos: LONGINT; VAR i: LONGINT); VAR n: LONGINT; s: SHORTINT; x: CHAR; BEGIN s := 0; n := 0; S.GET(pos, x); INC(pos); WHILE ORD(x) >= 128 DO INC(n, ASH(ORD(x) - 128, s)); INC(s, 7); S.GET(pos, x); INC(pos) END ; i := n + ASH(ORD(x) MOD 64 - ORD(x) DIV 64 * 64, s) END ReadNum; PROCEDURE ReadString (VAR pos: LONGINT; VAR s: ARRAY OF CHAR); VAR i: LONGINT; ch: CHAR; BEGIN i := 0; REPEAT S.GET(pos, ch); s[i] := ch; INC(i); INC(pos) UNTIL ch = 0X; END ReadString; PROCEDURE OverReadTypes (VAR pos: LONGINT; VAR ch: CHAR); (* MK *) VAR n: LONGINT; ch2: CHAR; BEGIN S.GET (pos, ch); INC (pos); IF ch = CHR (14) THEN ReadNum (pos, n) ELSIF ch = 0FX THEN ReadNum (pos, n); ReadNum (pos, n); OverReadTypes (pos, ch2) ELSIF ch = 10X THEN INC (pos); ReadNum (pos, n) ELSIF ch = 11X THEN ReadNum (pos, n); OverReadTypes (pos, ch2) ELSIF ch = CHR (13) THEN OverReadTypes (pos, ch2) END END OverReadTypes; PROCEDURE DumpVars (VAR pos: LONGINT; base: LONGINT); CONST VarTag = 1X; VarParTag = 2X; VAR ch, form: CHAR; sintval: SHORTINT; intval: INTEGER; lintval: LONGINT; realval: REAL; lrealval: LONGREAL; adr, offs: LONGINT; name: ARRAY 32 OF CHAR; BEGIN S.GET(pos, ch); INC(pos); WHILE (ch = VarTag) OR (ch = VarParTag) DO ReadString(pos, name); ReadNum (pos, offs); OverReadTypes (pos, form); adr := base + offs; IF ch = VarParTag THEN S.GET(adr, adr) END ; IF (ORD(form) <= 0FH) & (ORD(form) IN {1H, 2H, 3H, 4H, 5H, 6H, 7H, 8H, 9H, 0DH, 0FH}) THEN C.Str(" "); C.Str(name); C.Str(" = "); CASE ORD(form) OF | 1H: (* Byte *) S.GET(adr, ch); C.Int(ORD(ch)); | 2H: (* Boolean *) S.GET(adr, ch); IF ORD(ch) = 0 THEN C.Str("FALSE") ELSE C.Str("TRUE") END ; | 3H: (* Char *) S.GET(adr, ch); IF (" " <= ch) & (ch <= "~") THEN C.Ch(22X); C.Ch(ch); C.Ch(22X); ELSE C.Str("CHR("); C.Int(ORD(ch)); C.Ch(")"); END ; | 4H: (* Shortint *) S.GET(adr, sintval); C.Int(sintval); | 5H: (* Integer *) S.GET(adr, intval); C.Int(intval); | 6H: (* Longint *) S.GET(adr, lintval); C.Int(lintval); | 7H: (* Real *) S.GET(adr, realval); C.Str("REAL") | 8H: (* Longreal *) S.GET(adr, lrealval); C.Str("LONGREAL") | 9H, 0DH: (* Set, Pointer*) S.GET(adr, lintval); C.Int(lintval) | 0FH: (* Array of char *) C.Ch(22X); S.GET(adr, ch); INC(adr); WHILE (" " <= ch) & (ch <= "~") DO C.Ch(ch); S.GET(adr, ch); INC(adr) END ; C.Ch(22X); ELSE (* MK up to now a not viewable type*) END ; C.Ln END ; S.GET(pos, ch); INC(pos); END END DumpVars; PROCEDURE FindProc (pc: LONGINT; VAR mod: Module; VAR refpos, refend: LONGINT); CONST ProcRefTag = 0F8X; VarTag = 1X; VarParTag = 3X; VAR m: Module; codebase, pos, beg, offs: LONGINT; ch, ch2: CHAR; name: ARRAY 32 OF CHAR; BEGIN m := modules; mod := NIL; refpos := -1; codebase := S.ADR(m.code[0]); WHILE (m # NIL) & ((pc < codebase) OR ((codebase + LEN(m.code^)) < pc)) DO m := m.next; IF m # NIL THEN codebase := S.ADR(m.code[0]) END ; END ; IF m # NIL THEN mod := m; pc := pc - codebase; pos := S.ADR(m.refs[0]); refend := pos + LEN(mod.refs^); S.GET(pos, ch); INC(pos); beg := pos; refpos := -1; WHILE (pos <= refend) & (ch = ProcRefTag) DO refpos := beg; beg := pos; ReadNum(pos, offs); IF offs >= pc THEN RETURN END ; ReadString(pos, name); S.GET(pos, ch); INC(pos); WHILE (pos <= refend) & (ch # ProcRefTag) DO ReadString(pos, name); ReadNum(pos, offs); OverReadTypes (pos, ch2); S.GET(pos, ch); INC(pos); END END ; refpos := beg; END END FindProc; PROCEDURE CallStack (showVars: BOOLEAN); VAR pc, bp, sp, ref, refend, offs: LONGINT; mod: Module; name: ARRAY 32 OF CHAR; BEGIN S.GETREG(5, bp); S.GETREG(4, sp); REPEAT S.GET(bp + 4, pc); S.GET(bp, bp); FindProc(pc, mod, ref, refend); IF mod # NIL THEN C.Ln; C.Str(mod.name); C.Ch("."); ReadNum(ref, offs); ReadString(ref, name); C.Str(name); IF showVars THEN C.Ln; IF name = "$$" THEN DumpVars(ref, mod.sb) ELSE DumpVars(ref, bp) END END END UNTIL mod = NIL END CallStack; PROCEDURE CheckPtr (s: ARRAY OF CHAR; p: LONGINT); VAR pval, tag: LONGINT; BEGIN p := p DIV 4 * 4; IF (p < heapAdr) OR (p > heapAdr + heapSize) THEN C.Ln; C.Str(s); C.Str("Pointer not in heap: "); C.Int(p); CallStack(TRUE) ELSE S.GET(p - 4, tag); tag := tag DIV 4 * 4; IF (tag < heapAdr) OR (tag > heapAdr + heapSize) THEN C.Ln; C.Str(s); C.Str("Tag of pointer "); C.Int(p); C.Str(" not in heap "); C.Int(global); C.Str("; "); C.Int(tag); CallStack(TRUE) ELSE S.GET(p, tag); IF p + 4 = tag THEN C.Ln; C.Str(s); C.Str("Freeblock"); CallStack(TRUE) END END END END CheckPtr; *) PROCEDURE Mark* (block: Block); TYPE Tag = POINTER TO RECORD (*size,*) ptroff: LONGINT END ; (* size skipped, because accessed via tag = actual tag + 4 *) VAR father, field, currElem: Block; offset: LONGINT; tag, downtag, marked: Tag; arraybit: SET; BEGIN (* CheckPtr("Mark ", S.VAL(LONGINT, block)); *) S.GET(S.VAL(ADDRESS, block) - 4, tag); IF ~(SubObjBit IN S.VAL(SET, block)) THEN (* not a subobject *) marked := S.VAL(Tag, S.VAL(SET, tag) + mark); IF tag # marked THEN S.PUT(S.VAL(ADDRESS, block) - 4, marked); S.GET(S.VAL(ADDRESS, S.VAL(SET, tag) - array) - 4, marked); (* marked = super tag *) (* CheckPtr("super tag: ", S.VAL(LONGINT, marked)); *) (* unnecessary to mask mark bit *) S.GET(S.VAL(ADDRESS, marked) - 4, arraybit); INCL(arraybit, MarkBit); S.PUT(S.VAL(ADDRESS, marked) - 4, arraybit); (* mark type desc for tdescs of unloaded modules *) arraybit := S.VAL(SET, tag) * array; IF arraybit # {} THEN currElem := block^.firstElem; (* block is ArrayBlk *) tag := S.VAL(Tag, S.VAL(SET, tag) - arraybit) (* clear arraybit *) ELSE currElem := block END ; (* currElem is legal Block, tag = tdesc of currElem *) father := NIL; LOOP INC(S.VAL(ADDRESS, tag), 4); (* skip rec size *) offset := tag^.ptroff; IF offset < 0 THEN INC(S.VAL(ADDRESS, tag), offset); (* tag restored *) IF (arraybit # {}) & (currElem # block^.lastElemToMark) THEN INC(S.VAL(ADDRESS, currElem), tag^.ptroff) (* currElem := next array elem *) ELSE (* up *) S.PUT(S.VAL(ADDRESS, block) - 4, S.VAL(SET, tag) + arraybit + mark); (* save restored tag *) IF father = NIL THEN EXIT END ; S.GET(S.VAL(ADDRESS, father) - 4, tag); arraybit := S.VAL(SET, tag) * array; tag := S.VAL(Tag, S.VAL(SET, tag) - (array + mark)); (* tag pointing in ptroffs *) IF arraybit # {} THEN currElem := father^.currElem ELSE currElem := father END ; offset (* field address *) := S.VAL(ADDRESS, currElem) + tag^.ptroff; S.GET(offset, field); S.PUT(offset, block); block := father; father := field END ELSE offset (* field address *) := S.VAL(ADDRESS, currElem) + offset; S.GET(offset, field); (* IF field # NIL THEN CheckPtr("field: ", S.VAL(LONGINT, field)) END ; *) IF (S.VAL(LONGINT, field) >= heapAdr) & (S.VAL(LONGINT, field) <= heapAdr + heapSize) THEN (* field # NIL *) S.GET(S.VAL(ADDRESS, field) - 4, downtag); (* tag of pointer in field *) IF subobj * S.VAL(SET, field) = {} THEN (* not a subobject, i.e. record or array *) marked := S.VAL(Tag, S.VAL(SET, downtag) + mark); IF downtag # marked THEN (* down *) S.PUT(S.VAL(ADDRESS, field) - 4, marked); (* mark block referenced by field *) S.PUT(S.VAL(ADDRESS, block) - 4, S.VAL(SET, tag) + arraybit + mark); (* save pointer to ptroffs *) IF arraybit # {} THEN block^.currElem:= currElem END ; (* save current array element *) S.GET(S.VAL(ADDRESS, S.VAL(SET, downtag) - array) - 4, marked); (* suptertag of field^ *) (* unnecessary to mask mark bit *) S.GET(S.VAL(ADDRESS, marked) - 4, arraybit); INCL(arraybit, MarkBit); S.PUT(S.VAL(ADDRESS, marked) - 4, arraybit); (* mark tdesc of field^ *) arraybit := S.VAL(SET, downtag) * array; IF arraybit # {} THEN currElem := field^.firstElem ELSE currElem := field END ; S.PUT(offset, father); father := block; block := field; tag := S.VAL(Tag, S.VAL(SET, downtag) - arraybit) END ELSE (* i.e. sysblock; do not mark subobject *) S.GET(S.VAL(ADDRESS, downtag) - 4, marked); INCL(S.VAL(SET, marked), MarkBit); S.PUT(S.VAL(ADDRESS, downtag) - 4, marked) END END END END END ELSE (* do not mark subobject, subobjects are not traced *) (* CheckPtr("subobj: ", S.VAL(LONGINT, tag)); *) S.GET(S.VAL(ADDRESS, tag) - 4, arraybit); INCL(arraybit, MarkBit); S.PUT(S.VAL(ADDRESS, tag) - 4, arraybit); END END Mark; (*PROCEDURE Mark (block: Block); TYPE Tag = POINTER TO RECORD (*size,*) ptroff: LONGINT END ; (* size skipped, because accessed via tag = actual tag + 4 *) VAR father, field, currElem: Block; offset: LONGINT; tag, downtag, marked: Tag; arraybit: SET; BEGIN S.GET(S.VAL(ADDRESS, block) - 4, tag); IF ~(SubObjBit IN S.VAL(SET, block)) THEN (* not a subobject *) marked := S.VAL(Tag, S.VAL(SET, tag) + mark); IF tag # marked THEN S.PUT(S.VAL(ADDRESS, block) - 4, marked); S.GET(S.VAL(ADDRESS, S.VAL(SET, tag) - array) - 4, marked); (* marked = super tag *) (* unnecessary to mask mark bit *) S.GET(S.VAL(ADDRESS, marked) - 4, arraybit); INCL(arraybit, MarkBit); S.PUT(S.VAL(ADDRESS, marked) - 4, arraybit); (* mark type desc *) arraybit := S.VAL(SET, tag) * array; IF arraybit # {} THEN currElem := block^.firstElem; tag := S.VAL(Tag, S.VAL(SET, tag) - arraybit) ELSE currElem := block END ; father := NIL; LOOP INC(S.VAL(ADDRESS, tag), 4); offset := tag^.ptroff; IF offset < 0 THEN INC(S.VAL(ADDRESS, tag), offset); IF (arraybit # {}) & (currElem # block^.lastElemToMark) THEN INC(S.VAL(ADDRESS, currElem), tag^.ptroff) ELSE (* up *) S.PUT(S.VAL(ADDRESS, block) - 4, S.VAL(SET, tag) + arraybit + mark); IF father = NIL THEN EXIT END ; S.GET(S.VAL(ADDRESS, father) - 4, tag); arraybit := S.VAL(SET, tag) * array; tag := S.VAL(Tag, S.VAL(SET, tag) - (array + mark)); IF arraybit # {} THEN currElem := father^.currElem ELSE currElem := father END ; offset (*field address*) := S.VAL(ADDRESS, currElem) + tag^.ptroff; S.GET(offset, field); S.PUT(offset, block); block := father; father := field END ELSE offset (*field address*) := S.VAL(ADDRESS, currElem) + offset; S.GET(offset, field); IF field # NIL THEN S.GET(S.VAL(ADDRESS, field) - 4, downtag); IF subobj * S.VAL(SET, field) = {} THEN (* not a subobject *) marked := S.VAL(Tag, S.VAL(SET, downtag) + mark); IF downtag # marked THEN (* down *) S.PUT(S.VAL(ADDRESS, field) - 4, marked); S.PUT(S.VAL(ADDRESS, block) - 4, S.VAL(SET, tag) + arraybit + mark); IF arraybit # {} THEN block^.currElem:= currElem END ; S.GET(S.VAL(ADDRESS, S.VAL(SET, downtag) - array) - 4, marked); (* unnecessary to mask mark bit *) S.GET(S.VAL(ADDRESS, marked) - 4, arraybit); INCL(arraybit, MarkBit); S.PUT(S.VAL(ADDRESS, marked) - 4, arraybit); arraybit := S.VAL(SET, downtag) * array; IF arraybit # {} THEN currElem := field^.firstElem ELSE currElem := field END ; S.PUT(offset, father); father := block; block := field; tag := S.VAL(Tag, S.VAL(SET, downtag) - arraybit) END ELSE (* do not mark subobject *) S.GET(S.VAL(ADDRESS, S.VAL(SET, downtag) - array) - 4, marked); EXCL(S.VAL(SET, marked), MarkBit); S.GET(S.VAL(ADDRESS, marked) - 4, downtag); INCL(S.VAL(SET, downtag), MarkBit); S.PUT(S.VAL(ADDRESS, marked) - 4, downtag) END END END END END ELSE (* do not mark subobject, subobjects are not traced *) S.GET(S.VAL(ADDRESS, S.VAL(SET, tag) - array) - 4, tag); EXCL(S.VAL(SET, tag), MarkBit); S.GET(S.VAL(ADDRESS, tag) - 4, arraybit); INCL(arraybit, MarkBit); S.PUT(S.VAL(ADDRESS, tag) - 4, arraybit) END END Mark;*) PROCEDURE CheckFinObjs; VAR n: FinObj; tag: LONGINT; BEGIN n := finObjs; WHILE n # NIL DO S.GET(n.obj - 4, tag); IF MarkBit IN S.VAL(SET, tag) THEN n.marked := TRUE ELSE n.marked := FALSE; (* mark all objects accessible from n.obj to prevent them from being collected *) Mark(S.VAL(Block, n.obj)) END ; n := n.next END END CheckFinObjs; PROCEDURE Sweep; VAR p, end: Blockm4Ptr; lastp: FreeBlockPtr; tag, notmarked, tdesc: Tag; size, lastsize, i: LONGINT; lastA: ARRAY N+1 OF ADDRESS; BEGIN i := 0; WHILE i <= N DO A[i] := nil; lastA[i] := S.ADR(A[i]); INC(i) END ; p := S.VAL(Blockm4Ptr, firstBlock); end := S.VAL(Blockm4Ptr, endBlock); lastsize := 0; WHILE p # end DO tag := p^.tag; notmarked := S.VAL(Tag, S.VAL(SET, tag) - mark); tdesc := S.VAL(Tag, S.VAL(SET, notmarked) - array); IF notmarked # tdesc THEN (* array block *) size := p^.lastElemToMark + tdesc^.size - S.VAL(ADDRESS, p); ELSE size := tdesc^.size + 4; END ; size := S.VAL(LONGINT, S.VAL(SET, size + B-1)-S.VAL(SET, B-1)); IF tag = notmarked THEN (* collect *) IF lastsize = 0 THEN lastp := S.VAL(FreeBlockPtr, p) END ; INC(lastsize, size) ELSE p^.tag := notmarked; IF lastsize > 0 THEN lastp^.size := lastsize - 4; lastp^.tag := S.VAL(Tag, S.ADR(lastp^.size)); i := lastsize DIV B; IF i > N THEN i := N END ; lastp^.next := nil; S.PUT(lastA[i], lastp); lastA[i] := S.ADR(lastp^.next); lastsize := 0 END END ; INC(S.VAL(ADDRESS, p), size) END ; (* last collected block: *) IF lastsize > 0 THEN lastp^.size := lastsize - 4; lastp^.tag := S.VAL(Tag, S.ADR(lastp^.size)); i := lastsize DIV B; IF i > N THEN i := N END ; lastp^.next := nil; S.PUT(lastA[i], lastp); lastA[i] := S.ADR(lastp^.next) END END Sweep; PROCEDURE CheckCandidates (VAR candidates: ARRAY OF LONGINT); (* nofcand > 0 *) VAR i, j, h, cand: LONGINT; block, prevBlock: Blockm4Ptr; tag, notmarked, tdesc: Tag; BEGIN (* first sort them in increasing order using shellsort *) h := 1; REPEAT h := h*3 + 1 UNTIL h > nofcand; REPEAT h := h DIV 3; i := h; WHILE i < nofcand DO cand := candidates[i]; j := i; WHILE (j >= h) & (candidates[j-h] > cand) DO candidates[j] := candidates[j-h]; j := j-h; END ; candidates[j] := cand; INC(i) END UNTIL h = 1; (* sweep phase *) block := S.VAL(Blockm4Ptr, firstBlock); i := 0; cand := candidates[i]; prevBlock := block; LOOP IF cand <= S.VAL(ADDRESS, block) + 4 THEN IF cand = S.VAL(ADDRESS, block) + 4 THEN S.GET(S.VAL(ADDRESS, block), h); IF h # cand THEN Mark(S.VAL(Block, cand)) ELSE (* FreeBlk, SysBlk, or TDesc *) (* CS, 21.08.96 *) S.GET(S.VAL(ADDRESS, block) + 8, h); IF h = -4 THEN Mark(S.VAL(Block, cand)) END (* ELSE FreeBlk *) END ELSE (* cand < S.VAL(ADDRESS, block) + 4 => ptr into a block (e.g. VAR-Par p.x) *) S.GET(S.VAL(ADDRESS, prevBlock), h); IF h # S.VAL(ADDRESS, prevBlock) + 4 THEN Mark(S.VAL(Block, S.VAL(ADDRESS, prevBlock) + 4)) ELSE (* FreeBlk, SysBlk, or TDesc *) S.GET(S.VAL(ADDRESS, prevBlock) + 8, h); IF h = -4 THEN Mark(S.VAL(Block, S.VAL(ADDRESS, prevBlock) + 4)) END (* ELSE FreeBlk *) END END ; INC(i); IF i = nofcand THEN EXIT END ; cand := candidates[i] ELSE tag := block^.tag; notmarked := S.VAL(Tag, S.VAL(SET, tag) - mark); tdesc := S.VAL(Tag, S.VAL(SET, notmarked) - array); IF notmarked # tdesc THEN (* array block *) h := block^.lastElemToMark + tdesc^.size - S.VAL(ADDRESS, block) ELSE h := tdesc^.size + 4 END ; prevBlock := block; INC(S.VAL(ADDRESS, block), S.VAL(LONGINT, S.VAL(SET, h + B-1)-S.VAL(SET, B-1))); IF block = S.VAL(Blockm4Ptr, endBlock) THEN EXIT END END END ; nofcand := 0 END CheckCandidates; PROCEDURE Candidate (VAR candidates: ARRAY OF LONGINT; p: LONGINT); VAR tag: LONGINT; BEGIN (* IF ((p MOD B = 0) OR (p MOD 16 = 8)) & (p > firstBlock) & (p < endBlock) THEN S.GET(p - 4, tag); IF tag MOD 8 IN {0, 2} (* tag = 000 or tag = 010, array or record, not yet marked *) THEN IF p MOD 16 = 8 THEN (* potentially a SysBlk or a TDesc *) (* CS, 21.08.96 *) candidates[nofcand] := p ELSE candidates[nofcand] := p END ; INC(nofcand); IF nofcand = LEN(candidates) THEN CheckCandidates(candidates) END END END *) IF (p > firstBlock) & (p < endBlock) THEN (* allow pointers into block as candidates *) candidates[nofcand] := p; INC(nofcand); IF nofcand = LEN(candidates) THEN CheckCandidates(candidates) END END END Candidate; (* PROCEDURE CheckCandidates (VAR candidates: ARRAY OF LONGINT); (* nofcand > 0 *) VAR i, j, h, cand: LONGINT; block, prevBlock: Blockm4Ptr; tag, notmarked, tdesc: Tag; BEGIN (* first sort them in increasing order using shellsort *) h := 1; REPEAT h := h*3 + 1 UNTIL h > nofcand; REPEAT h := h DIV 3; i := h; WHILE i < nofcand DO cand := candidates[i]; j := i; WHILE (j >= h) & (candidates[j-h] > cand) DO candidates[j] := candidates[j-h]; j := j-h; END ; candidates[j] := cand; INC(i) END UNTIL h = 1; (* sweep phase *) block := S.VAL(Blockm4Ptr, firstBlock); i := 0; cand := candidates[i]; prevBlock := block; LOOP IF cand <= S.VAL(ADDRESS, block) + 4 THEN IF cand = S.VAL(ADDRESS, block) + 4 THEN S.GET(S.VAL(ADDRESS, block), h); IF h # cand THEN Mark(S.VAL(Block, cand)) END (* else it is a free block *) ELSE (* cand < S.VAL(ADDRESS, block) + 4 => ptr into a block (e.g. VAR-Par p.x) *) S.GET(S.VAL(ADDRESS, prevBlock), h); IF h # S.VAL(ADDRESS, prevBlock) + 4 THEN Mark(S.VAL(Block, S.VAL(ADDRESS, prevBlock) + 4)) END (* else it is a free block *) END ; INC(i); IF i = nofcand THEN EXIT END ; cand := candidates[i] ELSE tag := block^.tag; notmarked := S.VAL(Tag, S.VAL(SET, tag) - mark); tdesc := S.VAL(Tag, S.VAL(SET, notmarked) - array); IF notmarked # tdesc THEN (* array block *) h := block^.lastElemToMark + tdesc^.size - S.VAL(ADDRESS, block) ELSE h := tdesc^.size + 4 END ; prevBlock := block; INC(S.VAL(ADDRESS, block), S.VAL(LONGINT, S.VAL(SET, h + B-1)-S.VAL(SET, B-1))); IF block = S.VAL(Blockm4Ptr, endBlock) THEN EXIT END END END ; nofcand := 0 END CheckCandidates; PROCEDURE Candidate (VAR candidates: ARRAY OF LONGINT; p: LONGINT); VAR tag, tag0: LONGINT; BEGIN IF (p > firstBlock) & (p < endBlock) THEN IF p MOD B = 0 THEN S.GET(p - 4, tag); IF tag MOD 8 IN {0, 2} THEN (* tag = 000 or tag = 010, array or record, not yet marked, not free *) candidates[nofcand] := p; INC(nofcand); IF nofcand = LEN(candidates) THEN CheckCandidates(candidates) END END ELSIF p MOD 16 = 8 THEN (* potentially a SysBlk or a TDesc *) S.GET(p - 4, tag); IF (tag MOD B = 0) & (tag > firstBlock) & (tag < endBlock) THEN S.GET(tag - 4, tag0); IF tag0 = tag THEN candidates[nofcand] := p; INC(nofcand); IF nofcand = LEN(candidates) THEN CheckCandidates(candidates) END END END ELSE (* skip *) END END END Candidate; *) PROCEDURE FinalizeObjs; VAR n, prev: FinObj; BEGIN n := finObjs; prev := NIL; WHILE n # NIL DO IF ~n.marked THEN IF n = finObjs THEN (* advance finObjs, finalize n, restart at beginning (n.fin may have registered new objects for finalization *) finObjs := finObjs.next; n.fin(S.VAL(S.PTR, n.obj)); n := finObjs ELSE (* remove from queue, finalize n, advance n to next (disregarding that n.fin may have registered new objects for finalization), prev is last object that has not yet been finalized *) prev.next := n.next; n.fin(S.VAL(S.PTR, n.obj)); n := n.next END ELSE (* advance to next *) prev := n; n := n.next END END END FinalizeObjs; PROCEDURE SuspendThreads*; (* suspend all threads other than the active thread *) VAR th: Thread; self, dummy: LONGINT; BEGIN th := threads; self := GetCurrentThreadId(); WHILE th # NIL DO IF th.id # self THEN dummy := SuspendThread(th.handle) END ; th := th.next END END SuspendThreads; PROCEDURE ResumeThreads*; (* resumes all previously suspended threads *) VAR th: Thread; self, dummy: LONGINT; BEGIN th := threads; self := GetCurrentThreadId(); WHILE th # NIL DO IF th.id # self THEN dummy := ResumeThread(th.handle) END ; th := th.next END END ResumeThreads; (* PROCEDURE DumpFreeList; VAR adr, start, i, size: LONGINT; m: Module; BEGIN m := modules; WHILE (m # NIL) & (m.name # "Kernel") DO m := m.next END ; IF m # NIL THEN start := m.sb - 240; FOR i := 0 TO 9 DO C.Ln; C.Int(i); C.Str(": "); S.GET(start, adr); WHILE adr # 0 DO S.GET(adr + 4, size); C.Int(adr); C.Ch("-"); C.Int(adr + size + 4); C.Ch(" "); IF (td >= adr) & (td < adr + size + 4) THEN C.Str("tdesc in freelist") END ; S.GET(adr + 8, adr) END ; INC(start, 4) END END END DumpFreeList; *) PROCEDURE ^ NewSys* (size: LONGINT; VAR p: ADDRESS); PROCEDURE GC*; VAR m: Module; i, p, sp, ptradr: LONGINT; ptr: Block; candidates: ARRAY 1024 OF LONGINT; s: Stack; beg: LONGINT; th: Thread; self: LONGINT; PROCEDURE Min (x, y: LONGINT): LONGINT; BEGIN IF x < y THEN RETURN x ELSE RETURN y END END Min; PROCEDURE CheckThreadStack (thread: LONGINT); VAR buf: ARRAY 256 OF LONGINT; i: LONGINT; mbi: MemoryBasicInformation; (* PROCEDURE Check (bp, sp: LONGINT); VAR i, size, nofRead: LONGINT; done: BOOLEAN; BEGIN REPEAT size := bp - sp + 4; REPEAT C.Ln; C.Str("Checking thread stack from "); C.Int(sp); C.Str(" to "); C.Int(bp); done := ReadProcessMemory(GetCurrentProcess(), sp, S.ADR(buf), Min(size, 1024), nofRead); IF done THEN FOR i := 0 TO nofRead DIV 4 - 1 DO Candidate(candidates, buf[i]) END ELSE C.Ln; C.Str("Could not read process memory from "); C.Hex(sp); C.Str(", nofBytes: "); C.Int(Min(size, 1024)); i := GetLastError(); C.Str(", error code: "); C.Int(i); END ; DEC(size, nofRead); INC(sp, nofRead) UNTIL (size <= 0) OR ~done; bp := buf[nofRead DIV 4 - 1] UNTIL (sp = 0) OR (bp < sp) OR ~done (* plausibility checks: bp >= sp, sp # 0 *) END Check; *) PROCEDURE Check (to, from: LONGINT); VAR i, size, nofRead: LONGINT; done: BOOLEAN; BEGIN C.Ln; C.Str("Checking thread stack from "); C.Int(from); C.Str(" to "); C.Int(to); size := to - from; REPEAT done := ReadProcessMemory(GetCurrentProcess(), from, S.ADR(buf), Min(size, 1024), nofRead); IF done THEN FOR i := 0 TO nofRead DIV 4 - 1 DO Candidate(candidates, buf[i]) END ELSE C.Ln; C.Str("Could not read process memory from "); C.Int(from); C.Str(", nofBytes: "); C.Int(Min(size, 1024)); i := GetLastError(); C.Str(", error code: "); C.Int(i); END ; DEC(size, nofRead); INC(from, nofRead) UNTIL (size <= 0) OR ~done; END Check; BEGIN context.ContextFlags := 10003H; (* control and integer registers *) IF GetThreadContext(thread, S.ADR(context)) THEN i := VirtualQueryEx(GetCurrentProcess(), context.Esp, S.ADR(mbi), SIZE(MemoryBasicInformation)); Check(mbi.baseAddress + mbi.regionSize, mbi.baseAddress); (* Check(context.Ebp, context.Esp) *) ELSE C.Ln; C.Str("Could not check thread stack, thread-handle: "); C.Int(thread); i := GetLastError(); C.Str(", error code: "); C.Int(i) END END CheckThreadStack;  BEGIN IF GCenabled THEN SuspendThreads; prepQ.Handle; m := modules; (* ModuleDesc and ModuleBlock are marked via Kernel.modules *) WHILE m # NIL DO i := LEN(m.ptrTab^); ptradr := S.ADR(m.ptrTab^); WHILE i > 0 DO S.GET(ptradr, p); S.GET(p, ptr); IF (S.VAL(LONGINT, ptr) >= heapAdr) & (S.VAL(LONGINT, ptr) <= heapAdr + heapSize) THEN Mark(ptr) END ; (* ptr # NIL *) DEC(i); INC(ptradr, 4); END ; i := LEN(m.tdescs^); ptradr := S.ADR(m.tdescs^); WHILE i > 0 DO S.GET(ptradr, ptr); Mark(ptr); DEC(i); INC(ptradr, 4); END ; m := m^.next; END ; (* check stack *) S.GETREG(4, sp); curStack.end := sp; s := firstStack; nofcand := 0; WHILE s # NIL DO i := s.end; beg := s.beg; WHILE i < beg DO S.GET(i, p); Candidate(candidates, p); INC(i, 4) END ; s := s.next END ; (* CallStack(TRUE); *) check stacks of all threads (except Oberon.Loop thread which has already been checked) (* WHILE sp < stackBottom DO S.GET(sp, p); Candidate(candidates, p); INC(sp, 4) END ;*) IF nofcand > 0 THEN CheckCandidates(candidates) END ; CheckFinObjs; gcQ.Handle; (* DumpFreeList *) Sweep; IF (reserve = NIL) & firstTry THEN IF LargestAvailable() >= ReserveSize THEN NewSys(ReserveSize, p); reserve := S.VAL(Block, p) END END ; (* DumpFreeList *) FinalizeObjs; afterQ.Handle; ResumeThreads END END GC; (* ---------------------------------------------------------------- *) PROCEDURE FinalizeAll; VAR n: FinObj; BEGIN n := finObjs; WHILE n # NIL DO n.fin(S.VAL(S.PTR, n.obj)); n := n.next END ; END FinalizeAll; PROCEDURE Exit* (err: LONGINT); VAR m: Module; h: TerminationHandler; BEGIN IF err = 0 THEN FinalizeAll; m := modules; WHILE m # NIL DO IF m.term # NIL THEN h := m.term; m.term := NIL; h END ; m := m.next; END END ; exit(err); END Exit; (* -------------------------- memory allocation ----------------------- *) PROCEDURE - HALT1 0B8H, 01H, 0H, 0H, 0H, (* mov eax,1 *) 08DH, 0C9H; (* lea ecx, ecx; generate illegal instruction *) PROCEDURE NewBlock (size: LONGINT): InitPtr; (* size MOD B = 0 *) VAR i, rest: LONGINT; adr, AN: ADDRESS; ptr: InitPtr; restptr: FreeBlockPtr; BEGIN IF size < 0 (* NEW(p, MAX(LONGINT)) *) THEN HALT1 END ; i := size DIV B; IF i > N THEN i := N END ; adr := S.ADR(A[0]) + 4*i; AN := S.ADR(A[N]); (* constant register *) LOOP S.GET(adr, ptr); IF adr = AN THEN LOOP IF ptr = NIL THEN IF (TrapHandlingLevel = 0) & firstTry THEN GC; firstTry := FALSE; ptr := NewBlock(size); firstTry := TRUE; RETURN ptr ELSE reserve := NIL; GC; firstTry := TRUE; HALT1; END END ; IF ptr^.z0 + 4 >= size THEN EXIT END ; adr := S.ADR(ptr^.z1); S.GET(adr, ptr) END ; EXIT END ; IF ptr # NIL THEN EXIT END ; INC(adr, 4) END ; (* ptr # NIL, adr = S.ADR(A[i..N]) or S.ADR(ptr) *) S.PUT(adr, ptr^.z1); rest := ptr^.z0 + 4 - size; restptr := S.VAL(FreeBlockPtr, S.VAL(ADDRESS, ptr) + size); IF rest > 0 THEN (* >= B >= 16 *) i := rest DIV B; IF i > N THEN i := N END ; restptr^.tag := S.VAL(Tag, S.ADR(restptr^.size)); restptr^.size := rest - 4; restptr^.next := A[i]; A[i] := S.VAL(ADDRESS, restptr) END ; RETURN ptr END NewBlock; PROCEDURE NewRec* (tag: Tag; VAR p: ADDRESS); (* implementation of NEW(ptr) *) VAR size: LONGINT; ptr, init: InitPtr; BEGIN (* tag^.size = rectyp^.size *) size := S.VAL(LONGINT, S.VAL(SET, tag^.size + 4 (*tag*) + (B-1))-S.VAL(SET, B-1)); ptr := NewBlock(size); init := S.VAL(InitPtr, S.VAL(ADDRESS, ptr) + size - 32); init^.z0 := 0; init^.z1 := 0; init^.z2 := 0; init^.z3 := 0; init^.z4 := 0; init^.z5 := 0; init^.z6 := 0; WHILE init # ptr DO DEC(S.VAL(ADDRESS, init), 32); init^.z0 := 0; init^.z1 := 0; init^.z2 := 0; init^.z3 := 0; init^.z4 := 0; init^.z5 := 0; init^.z6 := 0; init^.z7 := 0 END ; ptr^.tag := tag; p := S.VAL(ADDRESS, ptr) + 4 END NewRec; PROCEDURE NewSys* (size: LONGINT; VAR p: ADDRESS); (* implementation of S.NEW(ptr, size) *) VAR ptr, init: InitPtr; BEGIN size := S.VAL(LONGINT, S.VAL(SET, size + 28 + (B-1))-S.VAL(SET, B-1)); ptr := NewBlock(size); init := S.VAL(InitPtr, S.VAL(ADDRESS, ptr) + size - 32); WHILE init # ptr DO init^.tag := NIL; init^.z0 := 0; init^.z1 := 0; init^.z2 := 0; init^.z3 := 0; init^.z4 := 0; init^.z5 := 0; init^.z6 := 0; DEC(S.VAL(ADDRESS, init), 32); END ; ptr^.tag := S.VAL(Tag, S.ADR(ptr^.z0)); ptr^.z0 := size - 4; ptr^.z1 := -4; init^.z2 := 0; init^.z3 := 0; init^.z4 := 0; ptr^.z5 := S.ADR(ptr^.z0); init^.z6 := 0; p := S.VAL(ADDRESS, ptr) + 28 END NewSys; PROCEDURE NewArr* (nofdim, nofelem: LONGINT; eltag: Tag; VAR p: ADDRESS); (* implementation of NEW(ptr, dim0, dim1, ...) *) VAR size, firstElem, elSize, arrSize, vectSize: LONGINT; ptr, init: InitPtr; BEGIN IF eltag = NIL THEN (* ARRAY OF POINTER *) eltag := ptrElemTag END ; elSize := eltag^.size; arrSize := nofelem*elSize; vectSize := 8*(nofdim DIV 2) + 4; (* -> ADR(firstElem) MOD 8 = 0 *) IF eltag^.ptroff = -4 THEN (* no pointers in element type *) NewSys(arrSize + vectSize + 12, p); RETURN END ; size := S.VAL(LONGINT, S.VAL(SET, arrSize + vectSize + 16 + (B-1))-S.VAL(SET, B-1)); ptr := NewBlock(size); init := S.VAL(InitPtr, S.VAL(ADDRESS, ptr) + size - 32); WHILE init # ptr DO init^.tag := NIL; init^.z0 := 0; init^.z1 := 0; init^.z2 := 0; init^.z3 := 0; init^.z4 := 0; init^.z5 := 0; init^.z6 := 0; DEC(S.VAL(ADDRESS, init), 32); END ; ptr^.tag := S.VAL(Tag, S.VAL(SET, eltag) + array); firstElem := S.ADR(ptr^.z3) + vectSize; ptr^.z0 := firstElem + arrSize - elSize; (* ptr^.z1 is reserved for mark phase *) ptr^.z2 := firstElem; ptr^.z3 := 0; ptr^.z4 := 0; ptr^.z5 := 0; ptr^.z6 := 0; p := S.VAL(ADDRESS, ptr) + 4 END NewArr; (* --------------------------------------------------------------------- *) PROCEDURE GetClock* (VAR time, date: LONGINT); TYPE SysTime = RECORD year, month, weekday, day: INTEGER; hour, min, sec, millisec : INTEGER; END ; VAR t: SysTime; BEGIN time := 0; date := 0; GetLocalTime(S.ADR(t)); date := t.year - 1900; date := ASH(date, 4); date := date + t.month; date := ASH(date, 5); date := date + t.day; time := t.hour; time := ASH(time, 6); time := time + t.min; time := ASH(time, 6); time := time + t.sec; END GetClock; PROCEDURE SetClock* (time, date: LONGINT); TYPE SysTime = RECORD year, month, weekday, day: INTEGER; hour, min, sec, millisec: INTEGER; END ; VAR t: SysTime; BEGIN t.day := SHORT(date MOD 20H); date := ASH(date, -5); t.month := SHORT(date MOD 10H); date := ASH(date, -4); t.year := SHORT(date MOD 80H) + 1900; t.millisec := 0; t.sec := SHORT(time MOD 40H); time := ASH(time, -6); t.min := SHORT(time MOD 40H); time := ASH(time, -6); t.hour := SHORT(time MOD 20H); SetLocalTime(S.ADR(t)); END SetClock; PROCEDURE LoadLibrary* (file: ARRAY OF CHAR): LONGINT; BEGIN RETURN loadLibrary(S.ADR(file)); END LoadLibrary; PROCEDURE FreeLibrary* (this: LONGINT); BEGIN freeLibrary(this); END FreeLibrary; PROCEDURE GetAdr* (lib: LONGINT; symbol: ARRAY OF CHAR; VAR adr: LONGINT); BEGIN getadr(S.ADR(adr), S.ADR(symbol), lib) END GetAdr; PROCEDURE InitKernel; (* heapAdr, heapSize, firstBlock and modules already initialized *) VAR size, i: LONGINT; p: Blockm4Ptr; rest: FreeBlockPtr; tag, tdesc: Tag; m: Module; td: POINTER TO RECORD filler: ARRAY 4 OF LONGINT; name: Name END ; BEGIN finObjs := NIL; threads := NIL; quitQ.Init; gcQ.Init; prepQ.Init; afterQ.Init; size := heapAdr + heapSize - firstBlock; DEC(size, size MOD B); endBlock := firstBlock + size; m := modules; WHILE m.name # "Kernel" DO m := m.next END ; (* initialise ptrElemTag *) i := LEN(m.tdescs^); REPEAT DEC(i); ptrElemTag := S.VAL(Tag, m.tdescs[i]); S.GET(m.tdescs[i] - 4, td) UNTIL td.name = "PtrElemDesc"; p := S.VAL(Blockm4Ptr, firstBlock); WHILE p^.tag # NIL DO tag := p^.tag; tdesc := S.VAL(Tag, S.VAL(SET, tag) - array - mark); IF array * S.VAL(SET, tag) # {} THEN (* array block *) size := p^.lastElemToMark + tdesc^.size - S.VAL(ADDRESS, p) ELSE size := tdesc^.size + 4 END ; size := S.VAL(LONGINT, S.VAL(SET, size + B-1)-S.VAL(SET, B-1)); INC(S.VAL(ADDRESS, p), size) END ; rest := S.VAL(FreeBlockPtr, p); rest^.tag := S.VAL(Tag, S.ADR(rest^.size)); rest^.size := S.VAL(LONGINT, endBlock) - S.VAL(LONGINT, rest) - 4; rest^.next := 0; i := 0; reserve := NIL; firstTry := TRUE; stackBottom := 0; i := 0; WHILE i < N DO A[i] := nil; INC(i) END ; A[N] := S.VAL(LONGINT, rest); GCenabled := TRUE; checkStack := TRUE; END InitKernel; PROCEDURE CallBodies; (* modules already initialized *) TYPE Body = PROCEDURE; VAR m, last: Module; body: Body; msg: ARRAY 128 OF CHAR; i, j: INTEGER; BEGIN last := modules; WHILE last.next # NIL DO last := last.next; END ; m := modules; LOOP IF m.name = "Kernel" THEN InitKernel ELSE body := S.VAL(Body, S.ADR(m.code[0])); msg := "Calling body of module "; i := 23; j := 0; WHILE m.name[j] # 0X DO msg[i] := m.name[j]; INC(i); INC(j) END ; msg[i] := 0X; ShowMsg(S.ADR(msg)); body; END ; IF m = last THEN EXIT END ; (* initialize modules belonging to bootfile only *) m := m.next; END END CallBodies; BEGIN (* rely on initialisation of initialised and EventLoop to FALSE and NIL, resp. *) IF initialised THEN IF EventLoop # NIL THEN EventLoop ELSE Exit(1) END ; END ; initialised := TRUE; (* getadr initialized by the boot loader *) GetAdr(0, "LoadLibrary", S.VAL(LONGINT, loadLibrary)); GetAdr(0, "FreeLibrary", S.VAL(LONGINT, freeLibrary)); GetAdr(0, "heapAdr", S.VAL(LONGINT, heapAdr)); GetAdr(0, "heapSize", S.VAL(LONGINT, heapSize)); GetAdr(0, "exit", S.VAL(LONGINT, exit)); mod := LoadLibrary("Kernel32"); GetAdr(mod, "GetLocalTime", S.VAL(LONGINT, GetLocalTime)); GetAdr(mod, "SetLocalTime", S.VAL(LONGINT, SetLocalTime)); GetAdr(mod, "GetVersion", S.VAL(LONGINT, GetVersion));  GetAdr(mod, "GetThreadContext", S.VAL(LONGINT, GetThreadContext)); GetAdr(mod, "SuspendThread", S.VAL(LONGINT, SuspendThread)); GetAdr(mod, "ResumeThread", S.VAL(LONGINT, ResumeThread)); GetAdr(mod, "ReadProcessMemory", S.VAL(LONGINT, ReadProcessMemory)); GetAdr(mod, "GetCurrentThread", S.VAL(LONGINT, GetCurrentThread)); GetAdr(mod, "GetCurrentThreadId", S.VAL(LONGINT, GetCurrentThreadId)); GetAdr(mod, "GetCurrentProcess", S.VAL(LONGINT, GetCurrentProcess)); GetAdr(mod, "GetLastError", S.VAL(LONGINT, GetLastError)); GetAdr(mod, "DuplicateHandle", S.VAL(LONGINT, DuplicateHandle)); loopThreadId := GetCurrentThreadId(); GetAdr(mod, "VirtualQueryEx", S.VAL(LONGINT, VirtualQueryEx));  GetAdr(0, "ShowMsg", S.VAL(LONGINT, ShowMsg)); IF (GetVersion() > 0) OR (S.VAL(SHORTINT, S.VAL(SET, GetVersion()) * {0..7}) > 3) THEN GetAdr(0, "printf", S.VAL(LONGINT, C.OutputDebugString)); ELSE GetAdr(0, "OutputDebugStringA", S.VAL(LONGINT, C.OutputDebugString)) END ; GetAdr(0, "debugOn", mod); IF mod = 1 THEN C.Enable ELSE C.Disable END ; TrapHandlingLevel := 0; firstBlock := heapAdr + ((-heapAdr - 4) MOD B); modules := S.VAL(Module, firstBlock + 4); ShowMsg(S.ADR("Module body of Kernel")); CallBodies END Kernel.