Oberon10.Scn.FntOberon10i.Scn.Fnt`2Oberon10b.Scn.Fnt   "      5-99m  u/* u/*^' #)Vs2"/09; $i`592 R5'  E +i  $b71dw@   582$.36-q`5"$W2    ##!72L qUMODULE Kernel; (* rc, js 4.7.96 *) (*---------------------------------------------------------* * Copyright (c) 1990-1996 ETH Zrich. All Rights Reserved. * Oberon is a trademark of Institut fr Computersysteme, ETH Zrich. *---------------------------------------------------------*) (* WARNING: do not use NEW nor SYSTEM.NEW in this module !! use NewRec, NewArr or NewSys instead *) IMPORT S := SYSTEM, Unix, Console; CONST MarkBit* = 31; TYPE Tag* = POINTER TO TypeDesc; Ptr* = POINTER TO Block; Sweeper* = PROCEDURE; KeyCmd* = PROCEDURE; Finalizer*=PROCEDURE(obj:S.PTR); FinObject=POINTER TO FinObjectDesc; FinObjectDesc=RECORD next:FinObject; obj:LONGINT; finalize:Finalizer END; VAR FKey*: ARRAY 16 OF KeyCmd; ptrElemTag*: LONGINT; heapAdr-, heapSize-, GCstart-: LONGINT; firstBlock-, endBlock-: (*FreePtr*) LONGINT; (* free blocks must be collected !! *) TrapHandlingLevel*: LONGINT; GCenabled*: BOOLEAN; FindRoots*, FindAmbRoots*: PROCEDURE; nofiles*: INTEGER; (* number of open files *) curSigCtxt*: LONGINT; (* for GC during trap handling *) jmpBuf*: Unix.JmpBuf; sysStackTop-, sysStackBot-: LONGINT; readSet*, readySet*: Unix.FdSet; (* input event handling *) userStackLimit*: LONGINT; SystemStack: ARRAY 2048 OF LONGREAL; (* 16KB *) fin: FinObject; (* List of registered objects for finalization *) toBeFin: FinObject; (* List of unreferenced objects which have to be finalized *) TYPE ADDRESS = LONGINT; TypeDesc = RECORD size: LONGINT; ptroff: LONGINT END ; FreePtr = 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 = RECORD lastElemToMark, currElem, firstElem: Ptr 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 ; CONST B = 32; (* must be a mutiple of 32 *) N = 9; nil = 0; ArrayBit = 30; FreeBit = 29; SubObjBit = 28; mark = {MarkBit}; array = {ArrayBit}; free = {FreeBit}; ReserveSize = 65536-28; VAR A: ARRAY N+1 OF (*FreePtr*) ADDRESS; reserve: Ptr; firstTry, booted: BOOLEAN; Sweepers: ARRAY 16 OF Sweeper; candidates: ARRAY 1024 OF LONGINT; nofcand: INTEGER; PROCEDURE -HALT1 (* machine dependent, PA-RISC 1.1 *) 000H, 000H, 020H, 000H; (* BREAK 0,1 : heap full *) PROCEDURE InstallSweep*(sweeper: Sweeper); VAR i: SHORTINT; BEGIN i := 0; LOOP IF Sweepers[i] = NIL THEN Sweepers[i] := sweeper; EXIT END ; INC(i); IF i = LEN(Sweepers) THEN EXIT END END END InstallSweep; PROCEDURE RemoveSweep*(sweeper: Sweeper); VAR i: SHORTINT; BEGIN i := 0; LOOP IF Sweepers[i] = sweeper THEN Sweepers[i] := NIL; EXIT END ; INC(i); IF i = LEN(Sweepers) THEN EXIT END END END RemoveSweep; PROCEDURE ^NewRec*(tag: Tag): ADDRESS; (* implementation of NEW(ptr) *) PROCEDURE RegisterObject*(obj:S.PTR; finalize:Finalizer); VAR f: FinObject; PROCEDURE new (VAR finObj: S.PTR); (* finObj is initialized with tag, hack! *) BEGIN finObj := S.VAL(S.PTR, NewRec(S.VAL(Tag, finObj))) END new; BEGIN IF obj # NIL THEN new(f); f.obj := S.VAL(LONGINT, obj); f.finalize := finalize; f.next:= fin; fin := f END END RegisterObject; PROCEDURE UnregisterObject*(obj:S.PTR); VAR p, f: FinObject; BEGIN IF obj # NIL THEN p := NIL; f := fin; WHILE (f # NIL) & (f.obj # S.VAL(LONGINT, obj)) DO p := f; f := f.next END; IF f # NIL THEN IF p = NIL THEN fin := f.next ELSE p.next := f.next END END; p := NIL; f := toBeFin; WHILE (f # NIL) & (f.obj # S.VAL(LONGINT, obj)) DO p := f; f := f.next END; IF f # NIL THEN IF p = NIL THEN toBeFin := f.next ELSE p.next := f.next END END; END; END UnregisterObject; PROCEDURE UnregisterAllObjects*(adrMin, adrMax: LONGINT); (***** * Unregisters objects having their finalize code between adrMax & adrMin * This should be done before freeing a module from the memory *) VAR f, prev, next: FinObject; tag: SET; adr, handle: LONGINT; BEGIN f := fin; prev := NIL; WHILE f # NIL DO next := f.next; S.GET(S.ADR(f.finalize), handle); adr := (handle DIV 4) * 4; IF (adr >= adrMin) & (adr <= adrMax) THEN IF prev = NIL THEN fin := next ELSE prev.next := next END; ELSE prev := f END; f := next END END UnregisterAllObjects; PROCEDURE Available*(): LONGINT; VAR i, avail: LONGINT; ptr: FreePtr; BEGIN avail := 0; i := 0; WHILE i <= N DO ptr := S.VAL(FreePtr, A[i]); WHILE ptr # NIL DO INC(avail, ptr^.size); ptr := S.VAL(FreePtr, ptr^.next) END ; INC(i) END ; RETURN avail END Available; PROCEDURE LargestAvailable*(): LONGINT; VAR i, max: LONGINT; ptr: FreePtr; BEGIN i := N; max := 0; WHILE (i >= 0) & (max = 0) DO ptr := S.VAL(FreePtr, A[i]); WHILE ptr # NIL DO IF ptr^.size > max THEN max := ptr^.size END ; ptr := S.VAL(FreePtr, ptr^.next) END ; DEC(i) END ; RETURN max END LargestAvailable; PROCEDURE ^Mark*(block: Ptr); PROCEDURE CheckFin; VAR f, prev, next: FinObject; tag: SET; BEGIN (* For each object in the finalization list, check if it is marked. If not, mark it to prevent Sweep() from freeing it, and move the finalization object to the list of finalizations which have to be performed. *) f := fin; prev := NIL; WHILE f # NIL DO next := f.next; S.GET(f.obj-4, tag); IF ~(MarkBit IN tag) THEN (* garbage object, put it into to-be-finalized list *) Mark(S.VAL(Ptr, f.obj)); (* mark f.obj and all objects accessible from it *) IF prev = NIL THEN fin := next ELSE prev.next := next END; f.next := toBeFin; toBeFin := f ELSE prev := f END; f := next END END CheckFin; PROCEDURE Finalize; VAR f: FinObject; BEGIN WHILE toBeFin # NIL DO f := toBeFin; toBeFin := toBeFin.next; f.finalize(S.VAL(S.PTR, f.obj)) END; END Finalize; PROCEDURE +FinalizeAll; VAR f: FinObject; BEGIN f := fin; WHILE f # NIL DO f.finalize(S.VAL(S.PTR, f.obj)); f := f.next END; END FinalizeAll; PROCEDURE Mark*(block: Ptr); TYPE Tag = POINTER TO RECORD (*size,*) ptroff: LONGINT END ; (* size skipped, because accessed via tag = actual tag + 4 *) VAR father, field, currElem: Ptr; 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); EXCL(S.VAL(SET, marked), MarkBit); (* necessary 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, 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^.size*) tag^.ptroff) (* tag is correct, not actual tag + 4 *) 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 ~(SubObjBit IN 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); EXCL(S.VAL(SET, marked), MarkBit); (* necessary 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 CheckCandidates; (* nofcand > 0 *) VAR i, j, h, p: LONGINT; block: Blockm4Ptr; 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 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 phase *) block := S.VAL(Blockm4Ptr, firstBlock); i := 0; p := candidates[i]; LOOP IF p <= S.VAL(ADDRESS, block) + 4 THEN IF p = S.VAL(ADDRESS, block) + 4 THEN Mark(S.VAL(Ptr, p)) END ; INC(i); IF i = nofcand THEN EXIT END ; p := candidates[i] ELSE notmarked := S.VAL(Tag, S.VAL(SET, block^.tag) - (mark + free)); 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 ; 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*(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} (* array or record, not yet marked, not free *) THEN candidates[nofcand] := p; INC(nofcand); IF nofcand = LEN(candidates) THEN CheckCandidates END END END END Candidate; PROCEDURE Sweep; VAR p, end: Blockm4Ptr; lastp: FreePtr; tag, notmarked, tdesc: Tag; size, lastsize, i: LONGINT; lastA: ARRAY N+1 OF ADDRESS; sweeper: Sweeper; BEGIN i := 0; WHILE i < LEN(Sweepers) DO IF Sweepers[i] # NIL THEN sweeper := Sweepers[i]; Sweepers[i] := NIL; sweeper; Sweepers[i] := sweeper END; INC(i) END ; 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 := S.VAL(Tag, S.VAL(SET, p^.tag) - free); 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(FreePtr, p) END ; INC(lastsize, size) ELSE p^.tag := notmarked; IF lastsize > 0 THEN lastp^.size := lastsize - 4; lastp^.tag := S.VAL(Tag, S.VAL(SET, S.ADR(lastp^.size)) + free); 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.VAL(SET, S.ADR(lastp^.size)) + free); i := lastsize DIV B; IF i > N THEN i := N END ; lastp^.next := nil; S.PUT(lastA[i], lastp) END END Sweep; PROCEDURE ^NewSys*(size: LONGINT): ADDRESS; (* implementation of S.NEW(ptr, size) *) PROCEDURE CheckMem*; VAR i: INTEGER; ok: BOOLEAN; fb: FreePtr; BEGIN Console.Str ("CheckMem : "); i := 0; ok := TRUE; WHILE i < N DO fb := S.VAL(FreePtr, A[i]); WHILE fb # NIL DO Console.Str ("["); Console.Int (i); Console.Str ("]"); IF fb.size # (i * 32 - 4) THEN Console.Str ("! MEM ERROR : "); Console.Int (fb.size); Console.Str (" at "); Console.Int (i); Console.Ln; ok := FALSE END; fb := S.VAL(FreePtr, fb.next) END; INC (i) END; IF ok THEN Console.Str ("< Mem Ok >"); Console.Ln ELSE Console.Str ("< Mem Bad >"); Console.Ln END END CheckMem; PROCEDURE GC*(ambiguous: BOOLEAN); VAR oldmask: LONGINT; BEGIN IF GCenabled THEN oldmask := Unix.Sigsetmask(0004H); FindRoots; nofcand := 0; IF ambiguous THEN FindAmbRoots END ; IF nofcand > 0 THEN CheckCandidates END ; CheckFin; (* put all garbage objects into the to-be-finalized list *) Sweep; Finalize; (* call finalize procedure for each garbage object *) IF (reserve = NIL) & firstTry THEN IF LargestAvailable() >= ReserveSize+24 THEN reserve := S.VAL(Ptr, NewSys(ReserveSize)) END END; oldmask := Unix.Sigsetmask(oldmask) END END GC; PROCEDURE NewBlock(size: LONGINT): InitPtr; (* size MOD B = 0 *) VAR i, rest: LONGINT; adr, AN: ADDRESS; ptr: InitPtr; restptr: FreePtr; 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(TRUE); firstTry := FALSE; ptr := NewBlock(size); firstTry := TRUE; RETURN ptr ELSE reserve := NIL; GC(TRUE); 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 *) S.PUT(adr, ptr^.z1); rest := ptr^.z0 + 4 - size; restptr := S.VAL(FreePtr, 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.VAL(SET, S.ADR(restptr^.size)) + free); restptr^.size := rest - 4; restptr^.next := A[i]; A[i] := S.VAL(ADDRESS, restptr) END; RETURN ptr END NewBlock; PROCEDURE RecName (tag: Tag); VAR adr: LONGINT; ch: CHAR; BEGIN adr := S.ADR(tag.size)-4; S.GET (adr, adr); INC (adr, 16); S.GET (adr, ch); WHILE ch # 0X DO Console.Ch (ch); INC (adr); S.GET (adr, ch) END END RecName; PROCEDURE NewRec*(tag: Tag): 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; RETURN S.VAL(ADDRESS, ptr) + 4 END NewRec; PROCEDURE NewSys*(size: LONGINT): 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; RETURN S.VAL(ADDRESS, ptr) + 28 END NewSys; PROCEDURE NewArr*(eltag: Tag; nofelem, nofdim: LONGINT): 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 := S.VAL(Tag, ptrElemTag) END; elSize := eltag^.size; arrSize := nofelem*elSize; ASSERT(arrSize > 0); vectSize := 8*(nofdim DIV 2) + 4; (* -> ADR(firstElem) MOD 8 = 0 *) IF eltag^.ptroff = -4 THEN (* no pointers in element type *) RETURN NewSys(arrSize + vectSize + 12) 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; RETURN S.VAL(ADDRESS, ptr) + 4 END NewArr; PROCEDURE InitFdSet*; VAR i: INTEGER; BEGIN i := 0; WHILE i < Unix.fdSetSize DIV 32 DO readSet.w[i] := 0; INC(i) END END InitFdSet; PROCEDURE RegisterFd* (fd: LONGINT); BEGIN readSet.w[fd DIV 32] := S.VAL(LONGINT, S.VAL(SET,readSet.w[fd DIV 32]) + S.VAL(SET,S.LSH (1,fd MOD 32))) END RegisterFd; PROCEDURE UnregisterFd* (fd: LONGINT); BEGIN readSet.w[fd DIV 32] := S.VAL(LONGINT, S.VAL(SET,readSet.w[fd DIV 32]) - S.VAL(SET,S.LSH (1,fd MOD 32))) END UnregisterFd; PROCEDURE FdRegistred* (fd: LONGINT): BOOLEAN; BEGIN RETURN readSet.w[fd DIV 32] = S.VAL(LONGINT, S.VAL(SET,readSet.w[fd DIV 32]) + S.VAL(SET,S.LSH (1,fd MOD 32))) END FdRegistred; PROCEDURE FdReady* (fd: LONGINT): BOOLEAN; BEGIN RETURN readySet.w[fd DIV 32] = S.VAL(LONGINT, S.VAL(SET,readySet.w[fd DIV 32]) + S.VAL(SET,S.LSH (1,fd MOD 32))) END FdReady; PROCEDURE Select*(delay: LONGINT); VAR rs, ws, xs: Unix.FdSet; n: LONGINT; tv: Unix.Timeval; BEGIN rs := readSet; n := 0; WHILE n < Unix.fdSetSize DIV 32 DO ws.w[n] := 0; xs.w[n] := 0; readySet.w[n] := 0; INC(n) END; IF delay < 0 THEN delay := 0 END ; tv.sec := delay DIV 1000; tv.usec := delay MOD 1000 * 1000; n := Unix.Select(Unix.fdSetSize, S.ADR(rs), S.ADR(ws), S.ADR(xs), S.ADR(tv)); IF n >= 0 THEN readySet := rs END END Select; PROCEDURE GetClock*(VAR time, date: LONGINT); VAR t: Unix.TmPtr; clock: LONGINT; BEGIN clock := Unix.Time(S.ADR(clock)); t := Unix.Localtime(S.ADR(clock)); time := t.sec + ASH(t.min, 6) + ASH(t.hour, 12); date := t.mday + ASH(t.mon+1, 5) + ASH(t.year MOD 100, 9) END GetClock; PROCEDURE SetClock*(time, date: LONGINT); END SetClock; PROCEDURE Boot*; (* is called from Modules immediately after booting *) VAR size, i: LONGINT; p: Blockm4Ptr; rest: FreePtr; tag, tdesc: Tag; BEGIN Unix.Init; IF ~booted THEN booted := TRUE; (* avoid user call *) Unix.dlsym(0, "heapAdr", S.VAL(LONGINT, heapAdr)); Unix.dlsym(0, "heapSize", S.VAL(LONGINT, heapSize)); Unix.dlsym(0, "GCstart", S.VAL(LONGINT, GCstart)); firstBlock := GCstart + ((-GCstart-4) MOD B); size := heapAdr + heapSize - firstBlock; DEC(size, size MOD B); endBlock := firstBlock + size; p := S.VAL(Blockm4Ptr, firstBlock); tag := p^.tag; WHILE tag # NIL DO IF ~(FreeBit IN S.VAL(SET, tag)) THEN INCL(S.VAL(SET, p^.tag), MarkBit) END; tdesc := S.VAL(Tag, S.VAL(SET, tag) - (mark + array + free)); IF ArrayBit IN 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); tag := p^.tag END; rest := S.VAL(FreePtr, p); rest^.tag := S.VAL(Tag, S.VAL(SET, S.ADR(rest^.size)) + free); rest^.size := S.VAL(LONGINT, endBlock) - S.VAL(LONGINT, rest) - 4; firstTry := TRUE; sysStackTop := S.ADR(SystemStack); sysStackBot := sysStackTop + 4*LEN(SystemStack) - 32 (* args *); Sweep; ASSERT (A[N] # nil); GCenabled := FALSE; reserve := S.VAL(Ptr, NewSys(ReserveSize)) END END Boot; PROCEDURE Init; VAR i, handle, res: LONGINT; p: PROCEDURE; BEGIN i := 0; WHILE i < Unix.fdSetSize DIV 32 DO readSet.w[i] := 0; INC(i) END; p := FinalizeAll; S.GET(S.ADR(p), handle); res := Unix.Atexit((handle DIV 4) * 4) END Init; BEGIN Init END Kernel.