Syntax10.Scn.Fnt
ParcElems
Alloc
Syntax24b.Scn.Fnt
Syntax10i.Scn.Fnt
StampElems
Alloc
24 Apr 96
Syntax10b.Scn.Fnt
Syntax12b.Scn.Fnt
(* AMIGA *)
MODULE Kernel;	(* jt/su 90-92, cn/shml 24 May 93, 
(* WARNING: do not use NEW nor SYSTEM.NEW in this module !!
	<< added jt/mh/shml/bh's finalization, shml, 28 Jul 94
	<< added incremental heap block allocation, shml, 21 Sep 94
IMPORT
	SYSTEM,Amiga,Dos:=AmigaDos;
CONST
	ModNameLength*=24;
	nofLists=9; Unit=16;
	MarkBit*=0;
	sysblk=1; freeblk=2;
	nextOff=4; (* next in free block *)
	hOff=Unit; (* NOTE: The implementation assumes hOff MOD Unit=0! *)
	hSizeOff=0; hNextOff=4;
	(*<< offset of first usable word, size of Amiga block, next Amiga block*) 
	Nil=LONG(LONG(0));
	MaxExts=7;
	ptrTabOffset=40+(MaxExts+1)*4;
	maxcand=1000;
	BlockSize=65536 (*2000000*);	(*<<*) 
	TYPE
		ModuleName*=ARRAY ModNameLength OF CHAR;
		Module*=POINTER TO ModuleDescriptor;
		ModuleDescriptor*=RECORD
			link*:Module;
			nofentries*, nofcoms*, nofptrs*, nofimps*:INTEGER;
			refcnt*:INTEGER;
			constSize*, dataSize*, codeSize*, refSize*:LONGINT;
			key*:LONGINT;
			name*:ModuleName;
			entries*, commands*, pointers*, imports*, const*, data*, code*, refs*:LONGINT
		END;
		Finalizer*=PROCEDURE(obj:SYSTEM.PTR);	(*<<*)
		FinObject=POINTER TO FinObjectDesc;	(*<<*)
		FinObjectDesc=RECORD	(*<<*)
			next:FinObject;
			obj:LONGINT;
			finalize:Finalizer
		END;
		(*<<Sweeper=PROCEDURE;*)
		ADDRESS=LONGINT;
		HeapBlock=RECORD	(*<< allocated from Amiga system *) 
			size:LONGINT;	(* size of this heap block *) 
			next:ADDRESS	(* address of next HeapBlock *) 
		END;
		modules*:Module; (* anchor of module list *)
		GCenabled*: BOOLEAN; (*<< enable/disable GC; RD *)
		(* oberon heap management *)
		heap-:LONGINT;
List of memory blocks allocated from the host operating system. This list is somehow unusual, as head doesn't point to the real beginning of a block. Instead it points to an address after the header, where the "Oberon managed portion" of the block starts. The list is sorted so that blocks at a lower memory address preceed blocks with a larger memory address.
		heapSize-:LONGINT; (* Record the total size requested from the host operating system. *)
		allocated-:LONGINT; (* Record the size of all allocations within Oberon. *)
		nofiles*,stackBottom*:LONGINT;
		freeList:ARRAY nofLists+1 OF ADDRESS; (* dummy,16,32,48,64,80,96,112,128,sentinel *)
			This maintains separate free lists for small blocks. Thus for small allocations
			a good fitting block is found easily.
		bigBlocks:ADDRESS;
			This is the list of "Oberon managed blocks".
		heapEnd:ADDRESS;	(*<<*) 
			points to the first address after the last memory block. Thus all heap managed memory
			is contained in the memory area between heap and heapEnd.
		firstTry:BOOLEAN;
		fin:FinObject; (* List of registered objects for finalization *)
		toBeFin:FinObject; (* List of unreferenced objects which have to be finalized *)	(*<<*)
			Procedure vars for F keys 
		FKey*: ARRAY 16 OF PROCEDURE;	(*<RD*)
	PROCEDURE^ GC*(markStack:BOOLEAN);
	PROCEDURE^ AllocHeap(VAR adr:LONGINT; size:LONGINT);
	PROCEDURE New*(tag:ADDRESS):ADDRESS;
	VAR i,i0,di,size,restsize,t:LONGINT; adr,next,prev:ADDRESS;
	BEGIN
		SYSTEM.GET(tag,size);
		i0:=size DIV Unit; i:=i0;
			Try to locate a free block in one of the small block lists, starting
			with the best fitting one and working up to bigger ones, as long
			as no free blocks are found.
		IF i<nofLists THEN
			adr:=freeList[i];
			WHILE adr=Nil DO INC(i); adr:=freeList[i] END; (* This terminates because of sentinel. *)
		END ;
		IF i<nofLists THEN (* unlink *)
			(*
				A small block was found. It is unlinked from the free list.
			*)
			SYSTEM.GET(adr+nextOff,next);
			freeList[i]:=next;
			IF i#i0 THEN (* split *)
				(*
					The block was not the smallest possible. Thus it is split. The 
					first part forms the remaining free block, which is linked into 
					the appropriate free list. The second part forms the block
					which is returned from New. 
				*)
				di:=i - i0; restsize:=di*Unit;
				SYSTEM.PUT(adr,restsize+ASH(1,freeblk));
				SYSTEM.PUT(adr+nextOff,freeList[di]);
				freeList[di]:=adr;
				INC(adr,restsize)
			END;
			SYSTEM.PUT(adr,size+ASH(1,freeblk));
		ELSE
			(*
No free block of the small free blocks could be used, so one of the "big blocks" is taken. Eventually, this means requesting new blocks from the host operating system.
To describe the following code, its best to look at the possible szenarios:
1)	bigBlocks contains a block large enough. This block is found, and the loop terminates at the EXIT statement. After some extra work, New will terminate.
2)	bigBlocks is emtpy and a garbage collection won't change anything. In this case New is recursively called, with the global firstTry set to FALSE. The second invocation will, after traversing the bigBlocks list withou success, enter the ELSE-part of the IF firstTry statement. AllocHeap will allocate a memory block large enough to satisy the request and link it into the bigBlock list. New is invoked a third time. This third invocation will find the just allocated block in the list, and exit the loop through the EXIT statement, do the extra work and return. The RETURN adr is executed, terminating the second invocation. This is followed by a resetting of firstTry to TRUE and a RETURN adr, which terminates the main invocation of New.
3)	bigBlocks is empty, but garbage collection will return some useful space. The invocation of New following the GC call will find this space either in one of the small block free lists, or in the big free list. In none of these cases it will enter the IF adr=Nil statement, but terminate regularly. After this invocation returns, the main New invocation is terminated.
			*)
			adr:=bigBlocks; prev:=Nil;
			LOOP
				IF adr=Nil THEN
					IF firstTry THEN
						GC(TRUE); firstTry:=FALSE; adr:=New(tag); firstTry:=TRUE; RETURN adr
					ELSE
						AllocHeap(adr, size);	(*<<*) 
						IF adr=Nil THEN RETURN Nil	(*<<*)
						ELSE adr:=New(tag); RETURN adr	(*<<*)
						END
					END
				END ;
				SYSTEM.GET(adr,t);
				IF t >=size THEN EXIT END ; (* why not IF t>=size ?? *)
				prev:=adr;
				SYSTEM.GET(adr+nextOff,adr);
			END ;
			(*
A block large enough is located. If the unneeded size is larger than the blocks managed in the freelist, it is simply shortened. Otherwise it is completely unliked, and the initial remaining block linked into the appropriate small block free list. 
			*)
			restsize:=t - size - ASH(1,freeblk);
			SYSTEM.PUT(adr+restsize,size+ASH(1,freeblk));
			IF restsize >= nofLists*Unit THEN (*resize*) (* Shouldn't it be restsize >= nofLists*Unit ??? *)
				SYSTEM.PUT(adr,restsize+ASH(1,freeblk))
			ELSE (*unlink*)
				SYSTEM.GET(adr+nextOff,next);
				IF prev=Nil THEN bigBlocks:=next
				ELSE SYSTEM.PUT(prev+nextOff,next)
				END ;
				IF restsize > 0 THEN (*move*)
					di:=restsize DIV Unit;
					SYSTEM.PUT(adr,restsize+ASH(1,freeblk));
					SYSTEM.PUT(adr+nextOff,freeList[di]);
					freeList[di]:=adr
				END
			END ;
			INC(adr,restsize)
		END ;
			Erase the allocated block, and put the type tag at the beginning of the block.
		i:=4; WHILE i<size DO SYSTEM.PUT(adr+i,Nil); INC(i,4) END ;
		SYSTEM.PUT(adr,tag);
		INC(allocated,size);
		RETURN adr+4;
	END New;
	PROCEDURE SysNew*(size:LONGINT):ADDRESS;
		VAR i,i0,di,restsize,t:LONGINT; adr,next,originalSize,prev:ADDRESS;
	BEGIN
		originalSize:=size;
		INC(size,12); INC(size,(-size) MOD Unit);
		i0:=size DIV Unit; i:=i0;
			Try to locate a free block in one of the small block lists, starting
			with the best fitting one and working up to bigger ones, as long
			as no free blocks are found.
		IF i<nofLists THEN
			adr:=freeList[i];
			WHILE adr=Nil DO INC(i); adr:=freeList[i] END; (* This terminates because of sentinel. *)
		END ;
		IF i<nofLists THEN (* unlink *)
			(*
				A small block was found. It is unlinked from the free list.
			*)
			SYSTEM.GET(adr+nextOff,next);
			freeList[i]:=next;
			IF i#i0 THEN (* split *)
				(*
					The block was not the smallest possible. Thus it is split. The 
					first part forms the remaining free block, which is linked into 
					the appropriate free list. The second part forms the block
					which is returned from SysNew. 
				*)
				di:=i - i0; restsize:=di*Unit;
				SYSTEM.PUT(adr,restsize+ASH(1,freeblk));
				SYSTEM.PUT(adr+nextOff,freeList[di]);
				freeList[di]:=adr;
				INC(adr,restsize)
			END;
			SYSTEM.PUT(adr,size+ASH(1,freeblk))
		ELSE
			(*
				For a description, see the analoguos part in New().
			*)
			adr:=bigBlocks; prev:=Nil;
			LOOP
				IF adr=Nil THEN
					IF firstTry THEN
						GC(TRUE); firstTry:=FALSE; adr:=SysNew(originalSize); firstTry:=TRUE; RETURN adr
					ELSE
						AllocHeap(adr, size);	(*<<*) 
						IF adr=Nil THEN RETURN Nil	(*<<*)
						ELSE adr:=SysNew(originalSize); RETURN adr	(*<<*)
						END
					END
				END ;
				SYSTEM.GET(adr,t);
				IF t >= size THEN EXIT END ; (* why not IF t>=size ?? *)
				prev:=adr; 
				SYSTEM.GET(adr+nextOff,adr)
			END ;
			(*
A block large enough is located. If the unneeded size is larger than the blocks managed in the freelist, it is simply shortened. Otherwise it is completely unliked, and the initial remaining block linked into the appropriate small block free list. 
			*)
			restsize:=t - size - ASH(1,freeblk);
			SYSTEM.PUT(adr+restsize,size+ASH(1,freeblk));
			IF restsize >=nofLists*Unit THEN (*resize*) (* Shouldn't it be restsize >= nofLists*Unit ??? *)
				SYSTEM.PUT(adr,restsize+ASH(1,freeblk))
			ELSE (*unlink*)
				SYSTEM.GET(adr+nextOff,next);
				IF prev=Nil THEN bigBlocks:=next
				ELSE SYSTEM.PUT(prev+nextOff,next)
				END ;
				IF restsize > 0 THEN (*move*)
					di:=restsize DIV Unit;
					SYSTEM.PUT(adr,restsize+ASH(1,freeblk));
					SYSTEM.PUT(adr+nextOff,freeList[di]);
					freeList[di]:=adr
				END
			END ;
			INC(adr,restsize)
		END ;
			The type tag points to the end of the block, where just the size is
			stored (a pseudo type tag?). To distinguish this block from a regular
			one, the sysblock flag is set.
			Note: These blocks are not zeroed.
		i:=adr+size - 8;
		SYSTEM.PUT(i,size);
		SYSTEM.PUT(adr,i+ASH(1,sysblk));
		RETURN adr+4
	END SysNew;
	PROCEDURE RegisterObject*(obj:SYSTEM.PTR; finalize:Finalizer);	(*<<*)
		f:FinObject;
		PROCEDURE new (VAR finObj:SYSTEM.PTR);	(* finObj is initialized with tag, hack! *) 
		BEGIN
			finObj:=SYSTEM.VAL(SYSTEM.PTR,New(SYSTEM.VAL(ADDRESS,finObj)))
		END new;
	BEGIN
		IF obj#NIL THEN
			new(f);
			f.obj:=SYSTEM.VAL(LONGINT,obj);
			f.finalize:=finalize;
			f.next:=fin;
			fin:=f;
		END;
	END RegisterObject;
	PROCEDURE^ Mark(q:ADDRESS);
	PROCEDURE CheckFin;	(*<<*)
		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;
			SYSTEM.GET(f.obj-4, tag);
			IF ~(MarkBit IN tag) THEN	(* garbage object, put it into to-be-finalized list *)
				Mark(SYSTEM.VAL(ADDRESS, 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;	(*<<*)
		f:FinObject;
	BEGIN
		WHILE toBeFin#NIL DO
			f:=toBeFin; 
			toBeFin:=toBeFin.next; f.finalize(SYSTEM.VAL(SYSTEM.PTR, f.obj))
		END;
	END Finalize;
	PROCEDURE FinalizeAll;	(*<<*) 
		f:FinObject;
	BEGIN
		f:=fin;
		WHILE f#NIL DO
			f.finalize(SYSTEM.VAL(SYSTEM.PTR, f.obj));
			f:=f.next;
		END;
	END FinalizeAll;
	PROCEDURE Mark(q:ADDRESS);
		VAR p,tag,fld,n:ADDRESS; offset:LONGINT; tagbits:SET;
	BEGIN
		IF q#Nil THEN
			(* If pointer not NIL then get tagbits. *)
			SYSTEM.GET(q - 4,tagbits);
			IF ~(MarkBit IN tagbits) THEN
				(* If not yet marked, then mark now. *)
				SYSTEM.PUT(q - 4,tagbits+{MarkBit});
				IF ~(sysblk IN tagbits) THEN
					(* If not a block allocate with SysNew() then ... *)
					p:=Nil;
					tag:=SYSTEM.VAL(LONGINT,tagbits)+ptrTabOffset;
					LOOP
						SYSTEM.GET(tag,offset);
						IF offset<0 THEN
							SYSTEM.PUT(q - 4,tag+offset+ASH(1,MarkBit));
							IF p=Nil THEN EXIT END ;
							n:=q; q:=p;
							SYSTEM.GET(q - 4,tag);
							DEC(tag,ASH(1,MarkBit));
							SYSTEM.GET(tag,offset);
							fld:=q+offset;
							SYSTEM.GET(fld,p); SYSTEM.PUT(fld,n)
						ELSE
							fld:=q+offset;
							SYSTEM.GET(fld,n);
							IF n#Nil THEN
								SYSTEM.GET(n - 4,tagbits);
								IF ~(MarkBit IN tagbits) THEN
									SYSTEM.PUT(n - 4,tagbits+{MarkBit});
									IF ~(sysblk IN tagbits) THEN
										SYSTEM.PUT(q - 4,tag+ASH(1,MarkBit));
										SYSTEM.PUT(fld,p);
										p:=q;
										q:=n;
										tag:=SYSTEM.VAL(LONGINT,tagbits)+(ptrTabOffset - 4);
									END
								END
							END
						END ;
						INC(tag,4);
					END
				END
			END
		END;
	END Mark;
	PROCEDURE Sweep;
		VAR heapBlock, prev, this, adr, end, start:ADDRESS; tag:SET; i, size, freesize, tagv:LONGINT; thisBlock:HeapBlock;
	BEGIN
			Clear the free lists and reset the size of allocations.
		i:=1;
		WHILE i<nofLists DO freeList[i]:=Nil; INC(i) END ;
		bigBlocks:=Nil;
		(*<< adr:=heap; end:=adr+heapsize; freesize:=0; *)
		allocated:=0;
			Walk through all blocks and rebuild free list.
			Note:
				heapBlock, this and thisBlock point to the start of the whole block.
				heap points to the start of the Oberon managed part.
				adr points to the current block within the Oberon managed part.
		heapBlock:=heap-hOff; prev:=Nil;	(*<<*) 
		WHILE heapBlock#Nil DO	(*<<*) 
			freesize:=0;
			this:=heapBlock;	(*<<*)
			SYSTEM.MOVE(this, SYSTEM.ADR(thisBlock), SIZE(HeapBlock));	(*<<*) 
			(*
				Go through all Oberon managed blocks within this memory block.
			*)
			adr:=this+hOff;
			end:=this+thisBlock.size;	(*<<*) 
			WHILE adr<end DO
				SYSTEM.GET(adr,tag);
				tagv:=SYSTEM.VAL(LONGINT, tag - {freeblk, sysblk, MarkBit});
				IF freeblk IN tag THEN
					(*
						The tag of a free block contains directly the size. Add it
						to the free size and go to the next block.
					*)
					INC(freesize,tagv); INC(adr,tagv);
				ELSIF MarkBit IN tag THEN
					(*
						A marked block is kept. It is unmarked, to restore the normal
						conditions. All freeblocks encountered before this marked 
						block are combined into one, and according to there size 
						stored into the appropriate free list.
					*)
					SYSTEM.PUT(adr, tag - {MarkBit});
					IF freesize > 0 THEN
						start:=adr - freesize;
						SYSTEM.PUT(start,freesize+ASH(1,freeblk));
						IF freesize<nofLists*Unit THEN
							i:=freesize DIV Unit; 
							SYSTEM.PUT(start+nextOff,freeList[i]); freeList[i]:=start
						ELSE
							SYSTEM.PUT(start+nextOff,bigBlocks); bigBlocks:=start
						END ;
						freesize:=0;
					END ;
					(*
						Increment the size of allocated memory by the size of this 
						marked block and go to the next block.
					*)
					SYSTEM.GET(tagv,size);
					INC(allocated,size); INC(adr,size)
				ELSE (*unmarked*)
					(*
						A block which isn't marked, and thus not used anymore.
						Add its size to the size of free blocks and goto the next one.
					*)
					SYSTEM.GET(tagv,size);
					INC(freesize,size); INC(adr,size);
				END
			END;
			(*
				Go to the next memory block. The current block is unlinked, if no
				marked blocks where in it, i.e. if it consisted of a sequence of free
				or unmarked blocks, which totalized a freesize equal of the blocks
				size.
			*)
			heapBlock:=thisBlock.next;	(*<<*)
			IF freesize=thisBlock.size-hOff THEN	(*<< the whole block is empty, deallocate it*)
				IF this=heap-hOff THEN	(* first heap block becomes empty, still at least one block left *) 
					heap:=heapBlock+hOff	(* thisBlock.next *) 
				ELSE	(* previous.next:=thisBlock.next *)
					SYSTEM.PUT(prev+hNextOff, heapBlock);	(* prev.next:=this.next *) 
					(*
						If there is any following block, then we unlinked the last one of
						the list. Thus we have to adjust heapEnd to point to the first
						byte after the previous block.
					*)
					IF heapBlock=Nil THEN
						SYSTEM.GET(prev+hSizeOff, heapEnd); INC(heapEnd, prev)	(* heapEnd:=prev.size+prev *)
					END
				END;
				(*
					The block is returned to the host operating system, and the size of
					used host storage is reduced.
				*)
				Amiga.Deallocate(this, thisBlock.size); DEC(heapSize, thisBlock.size);
				freesize:=0;
			ELSE
				IF freesize > 0 THEN (*collect last block*)
					start:=adr - freesize;
					SYSTEM.PUT(start,freesize+ASH(1, freeblk));
					IF freesize<nofLists*Unit THEN
						i:=freesize DIV Unit;
						SYSTEM.PUT(start+nextOff, freeList[i]); freeList[i]:=start
					ELSE
						SYSTEM.PUT(start+nextOff, bigBlocks); bigBlocks:=start
					END;
				END;
				prev:=this
			END 
		END;	(*<< WHILE heapBlock#Nil *) 
	END Sweep;
	PROCEDURE Sift (l,r:LONGINT; VAR a:ARRAY OF LONGINT);
		VAR i,j,x:LONGINT;
	BEGIN
		j:=l; x:=a[j];
		LOOP
			i:=j; j:=2*j+1;
			IF (j<r) & (a[j]<a[j+1]) THEN INC(j) END;
			IF (j > r) OR (a[j] <= x) THEN EXIT END;
			a[i]:=a[j]
		END;
		a[i]:=x
	END Sift;
	PROCEDURE HeapSort (n:LONGINT; VAR a:ARRAY OF LONGINT);
		VAR l,r,x:LONGINT;
	BEGIN
		l:=n DIV 2; r:=n - 1;
		WHILE l > 0 DO DEC(l); Sift(l,r,a) END;
		WHILE r > 0 DO x:=a[0]; a[0]:=a[r]; a[r]:=x; DEC(r); Sift(l,r,a) END;
	END HeapSort;
	PROCEDURE MarkCandidates(n:LONGINT; VAR cand:ARRAY OF LONGINT);
		VAR adr,heapBlock,heapBlockEnd,next,lim:ADDRESS; i,ptr,tagv:LONGINT; tag:SET;
	BEGIN
		adr:=heap; i:=0; lim:=cand[n-1];
		IF ODD(lim) THEN DEC(lim); END;
		heapBlock:=heap-hOff;	(*<<*) 
		SYSTEM.GET(heapBlock+hSizeOff, heapBlockEnd); INC(heapBlockEnd, heapBlock);	(*<<*) 
		WHILE adr <= lim DO
			SYSTEM.GET(adr,tag);
			tagv:=SYSTEM.VAL(LONGINT,tag - {freeblk, sysblk, MarkBit}); 
			IF MarkBit IN tag THEN SYSTEM.GET(tagv, tagv); INC(adr, tagv)	(* if marked block, skip *) 
			ELSIF freeblk IN tag THEN INC(adr,tagv)	(* if free block, skip *) 
			ELSE	(* not marked, check if stack pointer bound! *) 
				SYSTEM.GET(tagv,tagv);
				ptr:=adr+4;
				WHILE (cand[i]<ptr) & (i<n) DO INC(i) END ; (* Termination was not guaranteed !!! *)
				IF i=n THEN RETURN END ;
				next:=adr+tagv;
				IF cand[i]<next THEN	(* cand[i] points into this block => mark it! *) 
					IF sysblk IN tag THEN SYSTEM.PUT(adr,tag+{MarkBit}) ELSE Mark(ptr) END
				END ;
				adr:=next
			END;
			IF adr >= heapBlockEnd THEN	(*<<*) 
				SYSTEM.GET(heapBlock+hNextOff, heapBlock);	(* heapBlock:=heapBlock.next *) 
				IF heapBlock#Nil THEN
					adr:=heapBlock+hOff;
					SYSTEM.GET(heapBlock+hSizeOff, heapBlockEnd); INC(heapBlockEnd, heapBlock);
				ELSE RETURN	(* end of Amiga blocks! *) 
				END
			END
		END;
	END MarkCandidates;
	PROCEDURE GC*(markStack:BOOLEAN);
		VAR frame:RECORD END ;
			m:Module; i,ptrOffset,nofcand:LONGINT;
			sp,p,heapstart,heapend,stackbottom,ptr:ADDRESS;
			cand:ARRAY maxcand OF LONGINT;
	BEGIN
		IF GCenabled THEN
			(*
				Go through all modules and call Mark for each pointer in
				each module.
			*)
			m:=modules;
			WHILE m#NIL DO
				(*Amiga.BreakPoint(m.name);*)
				i:=0;
				WHILE i<m^.nofptrs DO
					SYSTEM.GET(m^.pointers+i*4,ptrOffset);
					SYSTEM.GET(m^.data+ptrOffset,ptr);
					Mark(ptr);
					INC(i)
				END ;
				m:=m^.link
			END ;
			IF markStack THEN
				(*
					Traverse the step, 16bit word wise and for every 32bit word
					which  value is within heapstart and heapend use MarkCandidates
					to mark them. Instead of looking at each of them individually,
					a group of upto maxcand pointers are collected, sorted and 
					marked.
				*)
				nofcand:=0;
				sp:=SYSTEM.ADR(frame); 
				stackbottom:=stackBottom;
				heapstart:=heap; (*<<heapend:=heapstart+heapsize;*)
				heapend:=heapEnd;
				WHILE sp<stackbottom DO
					SYSTEM.GET(sp,p);
					IF (heapstart<p) & (p<heapend) THEN
						IF nofcand=maxcand THEN HeapSort(nofcand,cand); MarkCandidates(nofcand,cand); nofcand:=0 END ;
						cand[nofcand]:=p; INC(nofcand)
					END ;
					INC(sp,2)
				END ;
				IF nofcand>0 THEN HeapSort(nofcand,cand); MarkCandidates(nofcand,cand) END
			END ;
			CheckFin;	(*<< put all garbage objects into the to-be-finalized list *)
			(*<< i:=0;
			WHILE (i<nofSweep) & (sweep[i]#NIL) DO sweep[i]; INC(i) END ; *)
			Sweep;
			Finalize;	(*<< call finalize procedure for each garbage object *)
		END;
	END GC;
	PROCEDURE AllocHeap(VAR adr:ADDRESS; size:LONGINT);	(*<<*) 
		(* allocate a new heap chunk from Amiga and insert it into the bigBlocks list of Oberon *) 
		VAR this, prev, next:ADDRESS; alloc:LONGINT;
	BEGIN
			Determine, how much has to be allocated. If the requested size fits in a 
			standard block, then try allocate a standard block but at least Uni*nofLists.
			Otherwise allocate a block which, accounting for the header, is big enough
			to just satisfy the request. The block is adjusted, so that it contains an integral
			number of subblocks of size Unit.
		IF size <= BlockSize-hOff THEN
			alloc:=BlockSize;
			IF size<nofLists*Unit THEN size:=nofLists*Unit END;	(* ensure a chunk of at least nofLists*Unit *) 
			INC(size,hOff); (*<<cn*) (* NOTE: this is correct, because hOff MOD Unit=0! *)
		ELSE
			INC(size, hOff); size:=size+(-size MOD Unit); alloc:=size (* NOTE: this is correct, because hOff MOD Unit=0! *)
		END;
			An allocation is tried. The requested length is reduced from alloc downto no less then size,
			if low memory condition or high fragmentation request for it.
		REPEAT Amiga.Allocate(adr, alloc); alloc:=alloc DIV 2 UNTIL (adr#Nil) OR (alloc<size);
		IF adr#Nil THEN
			(*
				Herein, size takes the total number of allocated bytes.
			*)
			size:=2*alloc;
			INC(heapSize, size);
			IF heap=Nil THEN
				next:=Nil; heap:=adr+hOff	(* new first block *)
			ELSE
				(*
					Note:
						adr, prev and this point to the true start of a block.
						heap points to the start of the Oberon managed part of the block.
				*)
				this:=heap-hOff; prev:=Nil;
				WHILE (this<adr) & (this#Nil) DO	(* find insertion point for this heap block in block list *) 
					prev:=this;
					SYSTEM.GET(this+hNextOff, this)	(* this:=this.next *)
				END;
				IF prev=Nil THEN next:=heap-hOff; heap:=adr+hOff	(* adr is new first block *) 
				ELSE next:=this; SYSTEM.PUT(prev+hNextOff, adr);	(* prev.next:=adr *) 
				END
			END;
			SYSTEM.PUT(adr+hSizeOff, size);	(* adr.size:=size *) 
			SYSTEM.PUT(adr+hNextOff, next);	(* adr.next:=next *) 
			IF next=Nil THEN heapEnd:=adr+size; END;	(* end of list, we just appended the last block *) 
			INC(adr, hOff);	(* points to Oberon part of heap block *) 
			(*
				Each Oberon managed free block starts with a header containing two 32bit words.
				The first contains the size of the Oberon managed block and some flags in the lower 
				three bits. One of them marks the block as free.
				The second word points to the next Oberon managed block. The list of Oberon
				managed blocks is not sorted, thus this new block is simply inserted at the top of the
				list.
			*)
			SYSTEM.PUT(adr, size-hOff+ASH(1, freeblk));
			SYSTEM.PUT(adr+nextOff, bigBlocks);	(* link it into bigBlocks list *) 
			bigBlocks:=adr
		END;
	END AllocHeap;
	PROCEDURE Init;
	(* Initializes the Oberon memory management. *)
		VAR
			adr:LONGINT;
			i:LONGINT;
	BEGIN
		stackBottom:=SYSTEM.ADR(adr);
		Amiga.InstallModuleList(SYSTEM.ADR(modules));
		Amiga.InstallNew(New);
		Amiga.InstallSysNew(SysNew);
		FOR i:=0 TO nofLists-1 DO freeList[i]:=Nil END;
		(*<<FOR i:=0 TO nofSweep-1 DO sweep[i]:=NIL END;*)
		freeList[nofLists]:=1; (* sentinel *)
		heapSize:=0; heap:=Nil;	(*<<*) 
		bigBlocks:=Nil;	(*<<cn*)
		AllocHeap(adr, BlockSize-hOff);	(*<<*) 
		firstTry:=TRUE;
		fin:=NIL; toBeFin:=NIL;	(*<<*)
		Amiga.TermProcedure(FinalizeAll);	(*<<cn*)
		GCenabled:=TRUE;	(*<RD*)	
		FOR i:=0 TO 15 DO FKey[i]:=NIL END;	(*<RD*)
	END Init;
	PROCEDURE GetClock*(VAR t,d:LONGINT);
	CONST
		amigaOffset=28430; (* Days between 1.1.1978 and 1.3.1900 *)
		refYear=1900;
	TYPE
		DatePtr=POINTER TO Dos.Date;
		dt:DatePtr;
		dtl,sec,min,hour,day,mon,year:LONGINT;
		buf:RECORD d:Dos.Date; pad:LONGINT END;
	BEGIN
		dtl:=SYSTEM.ADR(buf);
		WHILE (dtl MOD 4)#0 DO INC(dtl) END;
		dt:=SYSTEM.VAL(DatePtr,dtl);
		Dos.DateStamp(dt^);
		sec:=dt.tick DIV Dos.ticksPerSecond;
		min:=dt.minute MOD 60; hour:=dt.minute DIV 60;
		day:=dt.days+amigaOffset;
		year:=(4*day+3) DIV 1461;
		DEC(day,1461*year DIV 4);
		INC(year,refYear);
		mon:=(5*day+2) DIV 153;
		day:=day-(153*mon+2) DIV 5+1;
		INC(mon,3);
		IF mon>12 THEN INC(year); DEC(mon,12) END;
		t:=sec+ASH(min,6)+ASH(hour,12);
		d:=day+ASH(mon,5)+ASH(year MOD 100,9)
	END GetClock;
	PROCEDURE SetClock*(t,d:LONGINT);
	BEGIN
(* Clock setting from Oberon is not allowed. *)
	END SetClock;
BEGIN Init
END Kernel.