MODULE Kernel;
(**
	project	= "BlackBox 2.0"
	organization	= "www.oberon.ch, blackbox.oberon.org"
	contributors	= "Oberon microsystems, A. Shiryaev, A. Dmitriev"
	version	= "System/Rsrc/About"
	copyright	= "System/Rsrc/About"
	license	= "The 2-Clause BSD License"
	changes	= "
	- 20070123, bh, Beep using MessageBeep
	- 20070125, bh, Support for procedure signatures added
	- 20070130, bh, KERNEL32 & USER32 eliminated
	- 20070220, bh, comSig eliminated
	- 20070307, bh, improved Ctrl-Break handling
	- 20070308, bh, check for unloaded module in ExecFinalizer
	- 20080107, bh, full GC included in NewBlock
	- 20080107, bh, pointer anchoring bug corrected in NewRec & NewArr
	- 20181123, center #192, Kernel.Call does not work with ANYREC-parameters
	- 20181213, center #194, Meta.PutParam and Kernel.Call for open arrays are mismatched
	- 20210722, adimetrius, Make Kernel a collection of hooks for platform-specific iimplementations. Based on Kernel for linux. 
	- 20211109, dia, remove MessageBox
	"
	issues	= "
	- Get rid of MessageBox and all accompanying things
	"

**)

	(*
		A. V. Shiryaev, 2012.11, 2013.10, 2016.11, 2018.06, 2019.06
		Linux Kernel
		Based on 1.7.1-a1 (build number 710) Windows Kernel
		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,/FreeBSD)-specific code marked green

		TODO:
			handle stack overflow exceptions
			Quit from TrapHandler
		
		A. Dmitriev  2021.07
		Make Kernel a collection of hooks for platform-specific
		implementations. Based on Kernel for linux.
		
	*)

	IMPORT S := SYSTEM, COM;

	CONST
		strictStackSweep = TRUE;

		nameLen* = 256;

		littleEndian* = TRUE;
		timeResolution* = 1000;	(* ticks per second *)

		processor* = 10;	(* i386 *)

		(* loader constants *)
		done* = 0;
		fileNotFound* = 1;
		syntaxError* = 2;
		objNotFound* = 3;
		illegalFPrint* = 4;
		cyclicImport* = 5;
		noMem* = 6;
		commNotFound* = 7;
		commSyntaxError* = 8;
		moduleNotFound* = 9;
		
		trapMessage* = 10;

		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; 
		monoCluster = 25; (* memory model with only one huge heap cluster; used for .exe, not used for .dll *)

		(* meta interface consts *)
		mConst = 1; mTyp = 2; mVar = 3; mProc = 4; mField = 5;

		unloaded = -2; undefined = -1;	(** values for parameter pos of GetRefFrame *)
		logInc = 512;	(* log buffer initial size and increment step *)
		silentTrap = 128;	(* no message is shown to the user for this trap number, only a console dump *)
		keyboardInterrupt = 200;	(* trap number for Ctrl-C = SIGINT, used to interrupt endless loops *)

		sigStackSize = MAX(Libc.SIGSTKSZ, 65536);

		trapReturn = 1; (* Return value for sigsetjmp given from siglongjmp *)

	CONST 
		other = 0; defLogger = 1; gc = 2; cleanup = 3; viewer = 4;	(* recovery module ids; elements of dirty *)
		heap = TRUE;	(* memory allocation kind, cf. HeapAlloc *)

	TYPE
		Name* = ARRAY nameLen OF CHAR;
		Utf8Name* = ARRAY nameLen OF SHORTCHAR;
		Command* = PROCEDURE;

		Module* = POINTER TO RECORD [untagged]
			next-: Module;
			opts-: SET;	(* 0..15: compiler opts, 16..31: kernel flags *)
			refcnt-: INTEGER;	(* <0: module invalidated *)
			compTime-, loadTime-: ARRAY 6 OF SHORTINT;
			ext-: INTEGER;	(* currently not used *)
			term-: Command;	(* terminator *)
			nofimps-, nofptrs-: INTEGER;
			csize-, dsize-, rsize-: INTEGER;
			code-, data-, refs-: INTEGER;
			procBase-, varBase-: INTEGER;	(* meta base addresses *)
			names-: POINTER TO ARRAY [untagged] OF SHORTCHAR;	(* names[0] = 0X *)
			ptrs-: POINTER TO ARRAY [untagged] OF INTEGER;
			imports-: POINTER TO ARRAY [untagged] OF Module;
			export-: Directory;	(* exported objects (name sorted) *)
			name-: Utf8Name
		END;

		Type* = POINTER TO RECORD [untagged]
			(* record: ptr to method n at offset - 4 * (n+1) *)
			size-: INTEGER;	(* record: size, array: #elem, dyn array: 0, proc: sigfp *)
			mod-: Module;
			id-: INTEGER;	(* name idx * 256 + lev * 16 + attr * 4 + form *)
			base-: ARRAY 16 OF Type;	(* signature if form = ProcTyp *)
			fields-: Directory;	(* new fields (declaration order) *)
			ptroffs-: ARRAY any OF INTEGER	(* array of any length *)
		END;

		Object* = POINTER TO ObjDesc;

		ObjDesc* = RECORD [untagged]
			fprint-: INTEGER;
			offs-: INTEGER;	(* pvfprint for record types *)
			id-: INTEGER;	(* name idx * 256 + vis * 16 + mode *)
			struct-: Type	(* id of basic type or pointer to typedesc/signature *)
		END;

		Directory* = POINTER TO RECORD [untagged]
			num-: INTEGER;	(* number of entries *)
			obj-: ARRAY any OF ObjDesc	(* array of any length *)
		END;
		
		Signature* = POINTER TO RECORD [untagged]
			retStruct-: Type;	(* id of basic type or pointer to typedesc or 0 *)
			num-: INTEGER;	(* number of parameters *)
			par-: ARRAY any OF RECORD [untagged]	(* parameters *)
				id-: INTEGER;	(* name idx * 256 + kind *)
				struct-: Type	(* id of basic type or pointer to typedesc *)
			END
		END;

		Handler* = PROCEDURE;

		Reducer* = POINTER TO ABSTRACT RECORD
			next: Reducer
		END;

		Identifier* = ABSTRACT RECORD
			typ*: INTEGER;
			obj-: ANYPTR
		END;

		TrapCleaner* = POINTER TO ABSTRACT RECORD
			next: TrapCleaner
		END;

		TryHandler* = PROCEDURE (a, b, c: INTEGER);


		(* meta extension suport *)

		ItemExt* = POINTER TO ABSTRACT RECORD END;

		ItemAttr* = RECORD
			obj*, vis*, typ*, adr*: INTEGER;
			mod*: Module;
			desc*: Type;
			ptr*: S.PTR;
			ext*: ItemExt
		END;

		ADDRESS = INTEGER;
		FrameDesc = RECORD 	(** Record for iterating over call stack, cf. GetRefFrame *)
			sentry: Sentry;	(* FrameDesc may be created in the stack, thus .sentinel = NIL is the only way to detect that FrameDesc hasn't been initialized (because a pointer field is the only one that the Language Report guarantees a preset value). *)
			lo: ADDRESS;	(* the lower boundary of the scanned stack *)
			m*: Name;	(** m and p identify the procedure that the frame belongs to *)
			p*: Name; 	
			depth*: INTEGER; 	(** depth of this frame: it's distance, in frames, from top of stack *)
			pos*: INTEGER;	(** position in source text of the call of m.p that created this frame, if available; -1 => pc outside of BB; -2: module unloaded *)
			pc-: ADDRESS;	(** address within the instruction that called m.p *)
			modpc-: ADDRESS;	(** = .pc WRT .m's code block *)
			fp-: ADDRESS;	(** m.p's frame pointer, i.e. address of the frame *)
			eos-: BOOLEAN	(** end of stack *)
		END;
		Sentry = POINTER TO ARRAY [untagged] OF CHAR;	(* used in implementation of GetRefFrame *)
	
		LoaderHook* = POINTER TO ABSTRACT RECORD 
			res*: INTEGER;
			importing*, imported*, object*: ARRAY 256 OF CHAR
		END;

		Block = POINTER TO RECORD [untagged]
			tag: Type;
			last: INTEGER;		(* arrays: last element *)
			actual: INTEGER;	(* arrays: used during mark phase *)
			first: INTEGER		(* arrays: first element *)
		END;

		FreeBlock = POINTER TO FreeDesc;

		FreeDesc = RECORD [untagged]
			tag: Type;		(* f.tag = ADR(f.size) *)
			size: INTEGER;
			next: FreeBlock
		END;

		Cluster = POINTER TO RECORD [untagged]
			size: INTEGER;	(* total size *)
			next: Cluster;
			max: INTEGER	(* exe: reserved size, dll: original address *)
			(* start of first block *)
		END;

		FList = POINTER TO RECORD
			next: FList;
			blk: Block;
			iptr, aiptr: BOOLEAN
		END;

		CList = POINTER TO RECORD
			next: CList;
			do: Command;
			trapped: BOOLEAN
		END;


		PtrType = RECORD v: S.PTR END;	(* used for array of pointer *)
		Char8Type = RECORD v: SHORTCHAR END;
		Char16Type = RECORD v: CHAR END;
		Int8Type = RECORD v: BYTE END;
		Int16Type = RECORD v: SHORTINT END;
		Int32Type = RECORD v: INTEGER END;
		Int64Type = RECORD v: LONGINT END;
		BoolType = RECORD v: BOOLEAN END;
		SetType = RECORD v: SET END;
		Real32Type = RECORD v: SHORTREAL END;
		Real64Type = RECORD v: REAL END;
		ProcType = RECORD v: PROCEDURE END;
		UPtrType = RECORD v: INTEGER END;
		IntPtrType = RECORD p: COM.IUnknown END;	(* used for array of interface pointer *)

		StrPtr = POINTER TO ARRAY [untagged] OF SHORTCHAR;

		IntPtr = POINTER TO RECORD [untagged] p: COM.IUnknown END;

		Interface = POINTER TO RECORD	(* COMPILER DEPENDENT *)
			vtab: INTEGER;
			ref: INTEGER;	(* must correspond to Block.actual *)
			unk: COM.IUnknown
		END;

		Eoln* = ARRAY 3 OF CHAR;
		Platform* = ABSTRACT RECORD
			initialized: BOOLEAN;
			id: INTEGER;	(* platform ID constant, cf. Dialog *)
			eoln: Eoln;	(* end of line string: 0D0A00X or 0D0X or whatever, used in buffered logging *)
			physicalMemory: INTEGER;	(** size of physical (hardware) memory; only meaningful in monocluster mode *)
			interfaceTrapHandler*:
				PROCEDURE (excpRec, estFrame, context, dispCont: INTEGER): INTEGER;
			(* Most primitive console output *)
			String*: PROCEDURE (IN msg: ARRAY OF CHAR);
			Ln*: PROCEDURE;
			gradualCommit: BOOLEAN;
			(* TRUE => a cluster's virtual memory is committed gradually on demand rather than at once upon reserving address space (MEM_COMMIT and MEM_RESERVE are separate). If TRUE, .Commit should be implemented. *)
			Try*: PROCEDURE (h: TryHandler; a, b, c: INTEGER);	(* hook for implementation of PROCEDURE Try *)
	(*		AllocateMem*: PROCEDURE ((*adr: ADDRESS; *)VAR size: INTEGER; forHeap: BOOLEAN; OUT addr: ADDRESS);
			(** Allocate at least size bytes of memory (address space); forHeap => for heap use, otherwise module memory. If ~forHeap, then the platform may allocate a greater size, 'cause it will be used as a heap cluster. The base address addr and size of allocated bytes are returned; addr = 0, allocation failed, and size is unchanged *)
			(* ? rename to AllocAddressSpace? *)
			DeallocateMem*: PROCEDURE (adr: ADDRESS; size: INTEGER; release: BOOLEAN);
			Commit*: PROCEDURE (base, size, capacity: ADDRESS; VAR newSize: ADDRESS);
			(** Given that a cluster [base..base + capacity) has been reserved, and [base..base + size) bytes have been committed, change the committed bytes to [base..base + newSize), size <= newSize. Th
			This procedure is optional (should be NIL in Linux, where committing is not distinguished from reserving *)
			AllocateClusterMem*: PROCEDURE (VAR size: ADDRESS; OUT base, capacity: ADDRESS);
			(** Allocate at least size bytes of memory for a heap cluster; return base and actually allocated capacity. Post: base MOD 16 = 0, 60 *)
			(* Trap handling *)
			InActivationStack*: PROCEDURE (pc: ADDRESS): BOOLEAN;
			IsReadable*: PROCEDURE (from, to: ADDRESS): BOOLEAN;
			PrintHeaderInfo*: PROCEDURE;	(* EMPTY *)
			GetTrapInfo*: PROCEDURE (VAR pc, sp, fp: ADDRESS; VAR err, val: INTEGER; OUT recursive: BOOLEAN);
			(** Provides information about the trap to the Kernel. pc = 0 means no trap info available. This can be used to prevent Kernel.HandleTrap from being called arbitrarily. *)
			(* Various *)
			InitModule*: PROCEDURE (mod: Module);	(* EMPTY (optional); called from InitModule to allow mprotect in LinKernel *)
			GetLoadTime*: PROCEDURE (OUT loadTime: ARRAY OF SHORTINT);
			LoadDll*: PROCEDURE (IN name: ARRAY OF CHAR; VAR ok: BOOLEAN);
			ThisDllObj*: PROCEDURE (mode, fprint: INTEGER; IN dll, name: ARRAY OF CHAR): INTEGER;
			Start*: PROCEDURE (cmd: Command);	(* EMPTY; called from Start to allow setlongjump in LinKernel *)
			Terminate*: PROCEDURE (exitCode: INTEGER); (* immediately terminates BB platform process *)
			FatalError*: PROCEDURE (id: INTEGER; IN str: ARRAY OF CHAR);	(** report the error and terminate - never returns *)
			Time*: PROCEDURE (): LONGINT;
			SetupModListAccess*:  PROCEDURE;
	*)	END;
		
		ErrLog = EXTENSIBLE RECORD
			string: PROCEDURE (IN string: ARRAY OF CHAR);
			ln: PROCEDURE
		END;
		
		BufLog = RECORD (ErrLog)
			buf: POINTER TO ARRAY OF CHAR;	(* buffer for logging *)
			pos: INTEGER;	(* .buf[.pos] = 0X: end of string; .max = LEN(.buf) *)
		END;


	VAR
		platform: POINTER [untagged] TO Platform;
		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;
		
		(* required for FreeBSD executable for Libc when ElfLinker used *)
		__progname*: INTEGER;
		environ*: 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 *)
		ttotal: INTEGER;	(* current total size of BlackBox heap *)	(* committed heap size *)
		(* total is used only in monocluster mode; it stands for the committed heap size; in monocluster mode, all of heap is in root. The committed size of root is root.size. So, total is not needed? *)
		used: INTEGER;	(* bytes allocated on system heap *)
		(* allocated <= used <= total. used = total when ~gradualCommit *)
		finalizers: FList;
		hotFinalizers: FList;
		cleaners: CList;
		reducers: Reducer;
		trapStack: TrapCleaner;
		actual: Module;	(* valid during module initialization *)

		trapViewer, trapChecker: Handler;
		guarded: BOOLEAN; (** guarded => trap viewer (reporter) should not be called; this suppresses trap reporting *)
		static, inDll, terminating: BOOLEAN;
		monoClusterMem: BOOLEAN;	(* mono cluster memory model: only one huge cluster is allocated for heap during kernel initialization; ~monoClusterMem: multiple clusters may be allocated of small size; cluster size in both cases is decided by the platform kernel *)

		loader: LoaderHook;
		loadres: INTEGER;

		wouldFinalize: BOOLEAN;

		watcher*: PROCEDURE (event: INTEGER);	(* for debugging *)
		
		debug*: BOOLEAN;
		blockCollect*: BOOLEAN;
		
		sentry: Sentry;	(* used in GetRefFrame *)
		
	VAR
		dirty: SET;	(** dirty recovery modules *)
		unit: INTEGER;	(** currently active unit; used to identify which unit becomes dirty after a trap *)
		tryCount: INTEGER;	(* counter of nested Try calls *)
		dontCollect: BOOLEAN;
		log: ErrLog;
		blog: BufLog;
		
	PROCEDURE (VAR p: Platform) AllocateModMem* (size: INTEGER; OUT addr: ADDRESS), NEW, ABSTRACT;
	(** Allocate at least size bytes of memory that will be used by module blocks (descriptor or meta+code+vars) and returt the base address of the allocated block; addr = 0, allocation failed *)
	PROCEDURE (VAR p: Platform) DeallocateModMem* (adr: ADDRESS; size: INTEGER; release: BOOLEAN), NEW, ABSTRACT;
	(** Deallocate virtual memory [adr..adr+size); if release, address range is also released and may be used again; otherwise, address range is not released and may never be used again *)
	PROCEDURE (VAR p: Platform) Commit* (base, committed, capacity, request: ADDRESS; OUT granted: ADDRESS), NEW, ABSTRACT;
	(** Given that memory region [base..base + capacity) is reserved, and [base..base + committed) is committed, request to change the committed region to [base..base + request), committed <= request. After the call, the actually committed region is [base..base + granted).
	Pre:
		monoClusterMem & platform.gradualCommit, 20
			=> no need to implement in non-gradual-commit or multicluster-only platforms, i.e. Linux
		committed <= request, 21
	Post:
		committed <= granted
		[base..base + granted) is committed *)
	PROCEDURE (VAR p: Platform) AllocateClusterMem* (VAR size: ADDRESS; OUT base, capacity: ADDRESS), NEW, ABSTRACT;
	(** Allocate at least size bytes of memory for a heap cluster; return base, actually allocated capacity and committed size. 
	Post: 
		base = 0 allocation failed altogether, size` = size
		base # 0
			base MOD 16 = 0, 60
			size` >= size
			bytes [base..base+capacity) have been allocated, bytes [base..base+size) have been committed. It may be that capacity = size (when .gradualCommit = FALSE) *)
	PROCEDURE (VAR p: Platform) DeallocateClusterMem* (base: ADDRESS; size: INTEGER), NEW, ABSTRACT;
	(** Deallocate cluster memory [base..base+size); base has to be the same as returned by AllocateClusterMem.
	Pre:
		monoClusterMem, 20
		base was earlier returned by AllocateClusterMem, 21 *)
	(* Trap handling *)
	(*PROCEDURE (VAR p: Platform) Try* (h: TryHandler; a, b, c: INTEGER), NEW, ABSTRACT;
	(* hook for implementation of PROCEDURE Try *)*)
	PROCEDURE (VAR p: Platform) InActivationStack* (pc: ADDRESS): BOOLEAN, NEW, ABSTRACT;
	PROCEDURE (VAR p: Platform) IsReadable* (from, to: ADDRESS): BOOLEAN, NEW, ABSTRACT;
	PROCEDURE (VAR p: Platform) PrintHeaderInfo*, NEW, EMPTY;	(* EMPTY *)
	PROCEDURE (VAR p: Platform) GetTrapInfo* (VAR pc, sp, fp: ADDRESS; VAR err, val: INTEGER; OUT recursive: BOOLEAN), NEW, ABSTRACT;
	(** Provides information about the trap to the Kernel. pc = 0 means no trap info available. This can be used to prevent Kernel.HandleTrap from being called arbitrarily. *)
	(* Various *)
	PROCEDURE (VAR p: Platform) InitModule* (mod: Module), NEW, EMPTY;
	(* EMPTY (optional); called from InitModule to allow mprotect in LinKernel *)
	PROCEDURE (VAR p: Platform) GetLoadTime* (OUT loadTime: ARRAY OF SHORTINT), NEW, ABSTRACT;
	PROCEDURE (VAR p: Platform) LoadDll* (IN name: ARRAY OF CHAR; VAR ok: BOOLEAN), NEW, ABSTRACT;
	PROCEDURE (VAR p: Platform) ThisDllObj* (mode, fprint: INTEGER; IN dll, name: ARRAY OF CHAR): INTEGER, NEW, ABSTRACT;
	PROCEDURE (VAR p: Platform) Start* (cmd: Command), NEW, EMPTY;
	(* EMPTY; called from Start to allow setlongjump in LinKernel *)
	PROCEDURE (VAR p: Platform) Terminate* (exitCode: INTEGER), NEW, ABSTRACT; 
	(* immediately terminates BB platform process *)
	PROCEDURE (VAR p: Platform) FatalError* (id: INTEGER; IN str: ARRAY OF CHAR), NEW, ABSTRACT;
	(** report the error and terminate - never returns *)
	PROCEDURE (VAR p: Platform) Time* (): LONGINT, NEW, ABSTRACT;
	(* Most primitive console output *)
	PROCEDURE (VAR p: Platform) SetupModListAccess*, NEW, EMPTY;
	
	PROCEDURE (VAR p: Platform) Debug* (): BOOLEAN, NEW;
	BEGIN RETURN debug
	END Debug;

	(* code procedures for fpu *)

	PROCEDURE [code] FINIT 0DBH, 0E3H;
	PROCEDURE [code] FLDCW 0D9H, 06DH, 0FCH;	(* -4, FP *)
	PROCEDURE [code] 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
	*);

	(* code procedures for COM support *)

	PROCEDURE [code] ADDREF
	(*
		MOV	ECX,[ESP,4]
		INC	[ECX,4]
		MOV	EAX,[ECX,8]
		OR	EAX,EAX
		JE	L1
		PUSH	EAX
		MOV	EAX,[EAX]
		CALL	[EAX,4]
		MOV	ECX,[ESP,4]
	L1: MOV	EAX,[ECX,4]
		RET	4
	*)
		08BH, 04CH, 024H, 004H,
		0FFH, 041H, 004H,
		08BH, 041H, 008H,
		009H, 0C0H,
		074H, 00AH,
		050H,
		08BH, 000H,
		0FFH, 050H, 004H,
		08BH, 04CH, 024H, 004H,
		08BH, 041H, 004H,
		0C2H, 004H, 000H;

	PROCEDURE [code] RELEASE
	(*
		MOV	ECX,[ESP,4]
		MOV	EAX,[ECX,8]
		OR	EAX,EAX
		JE	L1
		PUSH	EAX
		MOV	EAX,[EAX]
		CALL	[EAX,8]
		MOV	ECX,[ESP,4]
	L1: DEC	[ECX,4]
		MOV	EAX,[ECX,4]
		RET	4
	*)
		08BH, 04CH, 024H, 004H,
		08BH, 041H, 008H,
		009H, 0C0H,
		074H, 00AH,
		050H,
		08BH, 000H,
		0FFH, 050H, 008H,
		08BH, 04CH, 024H, 004H,
		0FFH, 049H, 004H,
		08BH, 041H, 004H,
		0C2H, 004H, 000H;

	PROCEDURE [code] CALLREL
	(*
		MOV	EAX,[ESP,4]
		CMP	[EAX,4],1
		JNE	L1
		PUSH	ESI
		PUSH	EDI
		PUSH	EAX
		MOV	EAX,[EAX,-4]
		CALL	[EAX,-8]
		POP	EDI
		POP	ESI
	L1:
	*)
		08BH, 044H, 024H, 004H,
		083H, 078H, 004H, 001H,
		075H, 00BH,
		056H,
		057H,
		050H,
		08BH, 040H, 0FCH,
		0FFH, 050H, 0F8H,
		05FH,
		05EH;

	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;


	(* ----------------- direct logger ----------------- *)
	
	PROCEDURE (VAR e: ErrLog) String (IN str: ARRAY OF CHAR), NEW, EXTENSIBLE;
	BEGIN e.string(str)
	END String;
	
	PROCEDURE (VAR e: ErrLog) Ln, NEW, EXTENSIBLE; BEGIN e.ln END Ln;
	
	PROCEDURE (VAR e: ErrLog) Int (x: LONGINT), NEW;
		VAR a: ARRAY 25 OF CHAR;
		CONST max = 25;
		VAR b: ARRAY max OF CHAR; i, j: INTEGER; y: LONGINT;
	BEGIN
		IF x < 0 THEN x := -x; a[0] := '-'; j := 1 ELSIF x > 0 THEN j := 0 ELSE j := 1; a[0] := '0' END;
		i := 0;
		WHILE x # 0 DO y := x MOD 10; b[i] := SHORT(CHR(y + ORD('0'))); x := x DIV 10; INC(i) END;
		DEC(i); WHILE (i >= 0) & (j < max) DO a[j] := b[i]; INC(j); DEC(i) END;
		ASSERT(j < max, 20);
		a[j] := 0X; 
		e.String(a)
	END Int;
	
	PROCEDURE (VAR e: ErrLog) Hex (x: LONGINT), NEW;
		VAR i, xx, yy: INTEGER; y: LONGINT; buf: ARRAY 17 OF CHAR;
	BEGIN 
		IF (MIN(INTEGER) < x) & (x < MAX(INTEGER)) THEN 
			i := 7; xx := SHORT(x); WHILE i >= 0 DO
				yy := xx MOD 16; xx := xx DIV 16;
				IF yy > 9 THEN yy := yy + (ORD("A") - ORD("0") - 10) END;
				buf[i] := CHR(yy + ORD("0")); DEC(i)
			END;
			buf[8] := 0X
		ELSE 
			i := 15; WHILE i >= 0 DO
				y := x MOD 16; x := x DIV 16;
				IF y > 9 THEN y := y + (ORD("A") - ORD("0") - 10) END;
				buf[i] := CHR(y + ORD("0")); DEC(i)
			END;
			buf[16] := 0X
		END;
		e.String(buf)
	END Hex;
	
	(* ----------------- buffered logger ----------------- *)
	
	PROCEDURE ^ NewArr* (eltyp, nofelem, nofdim: INTEGER): INTEGER;	(* impl. of NEW(ptr, dim0, dim1, ...) *)

	PROCEDURE GrowBuf (by: INTEGER);
		VAR a: ADDRESS; copy: POINTER TO ARRAY OF CHAR; max, u, len: INTEGER;
	BEGIN
		u := unit; dontCollect := unit = defLogger; unit := gc; 
		IF blog.buf = NIL THEN max := 0 ELSE max := LEN(blog.buf) END;
		IF max <= blog.pos + by THEN
			(* allocate copy *)
			len := (blog.pos + by) + (logInc - 1) DIV logInc * logInc;
			a := NewArr(9 (* CHAR *), len, 1); S.PUT(a + 12, len); S.PUT(S.ADR(copy), a);
			(* copy := blog.buf$ *)
			IF blog.buf # NIL THEN S.MOVE(S.ADR(blog.buf[0]), S.ADR(copy[0]), 2 * max) END;
			blog.buf := copy
		ELSE (* fatalerror *)
		END;
		unit := u; dontCollect := FALSE
	END GrowBuf;
	
	PROCEDURE (VAR log: BufLog) Append (IN str: ARRAY OF CHAR), NEW;
		VAR len, i: INTEGER;
	BEGIN
		IF ~(gc IN dirty) THEN
			len := LEN(str$);
			GrowBuf(len + 1);
			i := len; INC(log.pos, len); len := log.pos;
			WHILE i >= 0 DO log.buf[len] := str[i]; DEC(i); DEC(len) END
		END
	END Append;
	
	PROCEDURE (VAR log: BufLog) String (IN str: ARRAY OF CHAR);
	BEGIN
		IF debug THEN log.string(str) END;	(* could cause a fatal error with a specific number, huh? *)
		log.Append(str)
	END String;
	
	PROCEDURE (VAR log: BufLog) Ln; 
	BEGIN
		IF debug THEN log.ln; END;
		log.Append(platform.eoln)
	END Ln;
	
	PROCEDURE (VAR log: BufLog) Reset, NEW; BEGIN log.pos := 0 END Reset;
	
	(* -------------------- miscellaneous tools -------------------- *)

	PROCEDURE Utf8ToString (IN in: ARRAY OF SHORTCHAR; OUT out: ARRAY OF CHAR; 
											OUT res: INTEGER);
		VAR i, j, val, max: INTEGER; ch: SHORTCHAR;
		
		PROCEDURE FormatError();
		BEGIN out := in$; res := 2 (*format error*)
		END FormatError;
		
	BEGIN
		ch := in[0]; i := 1; j := 0; max := LEN(out) - 1;
		WHILE (ch # 0X) & (j < max) DO
			IF ch < 80X THEN
				out[j] := ch; INC(j)
			ELSIF ch < 0E0X THEN
				val := ORD(ch) - 192;
				IF val < 0 THEN FormatError; RETURN END ;
				ch := in[i]; INC(i); val := val * 64 + ORD(ch) - 128;
				IF (ch < 80X) OR (ch >= 0E0X) THEN FormatError; RETURN END ;
				out[j] := CHR(val); INC(j)
			ELSIF ch < 0F0X THEN 
				val := ORD(ch) - 224;
				ch := in[i]; INC(i); val := val * 64 + ORD(ch) - 128;
				IF (ch < 80X) OR (ch >= 0E0X) THEN FormatError; RETURN END ;
				ch := in[i]; INC(i); val := val * 64 + ORD(ch) - 128;
				IF (ch < 80X) OR (ch >= 0E0X) THEN FormatError; RETURN END ;
				out[j] := CHR(val); INC(j)
			ELSE
				FormatError; RETURN
			END ;
			ch := in[i]; INC(i)
		END;
		out[j] := 0X;
		IF ch = 0X THEN res := 0 (*ok*) ELSE res := 1 (*truncated*) END
	END Utf8ToString;

	PROCEDURE StringToUtf8 (IN in: ARRAY OF CHAR; OUT out: ARRAY OF SHORTCHAR; 
											OUT res: INTEGER);
		VAR i, j, val, max: INTEGER;
	BEGIN
		i := 0; j := 0; max := LEN(out) - 3;
		WHILE (in[i] # 0X) & (j < max) DO
			val := ORD(in[i]); INC(i);
			IF val < 128 THEN
				out[j] := SHORT(CHR(val)); INC(j)
			ELSIF val < 2048 THEN
				out[j] := SHORT(CHR(val DIV 64 + 192)); INC(j);
				out[j] := SHORT(CHR(val MOD 64 + 128)); INC(j)
			ELSE
				out[j] := SHORT(CHR(val DIV 4096 + 224)); INC(j); 
				out[j] := SHORT(CHR(val DIV 64 MOD 64 + 128)); INC(j);
				out[j] := SHORT(CHR(val MOD 64 + 128)); INC(j)
			END;
		END;
		out[j] := 0X;
		IF in[i] = 0X THEN res := 0 (*ok*) ELSE res :=  1 (*truncated*) END
	END StringToUtf8;
	

	PROCEDURE ^ Quit* (exitCode: INTEGER);
	
	PROCEDURE Assert (cond: BOOLEAN; IN msg: ARRAY OF CHAR);
	BEGIN
		IF ~cond THEN log.String(msg); log.Ln; IF platform.initialized THEN Quit(1) END END
	END Assert;
	
	PROCEDURE Time* (): LONGINT;
	BEGIN
		RETURN platform.Time()
	END Time;

	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 AllocateCluster (size: INTEGER; VAR c: Cluster); 
	(** Allocate cluster c of at least size bytes in either mono- or multi-cluster heap layout *)
		VAR a, base, capacity: ADDRESS;
	BEGIN
		ASSERT(platform.initialized, 99);
		platform.AllocateClusterMem(size, base, capacity);
		IF base = 0 THEN c := NIL
		ELSE
			IF monoClusterMem THEN 
				ASSERT(base MOD 16 = 0, 60);
				c := S.VAL(Cluster, base); c.size := size; c.max := capacity
				(*INC(total, capacitysize)*)
				(* ;IF debug THEN log.String("monoClusterMem: c.max = "); log.Hex(c.max); log.Ln END; *)
			ELSE 
				a := (base + 15) DIV 16 * 16; c := S.VAL(Cluster, a); 
				c.max := base; 
				c.size := capacity - (a - base);
				(*INC(total, size)*) 
				(* ;IF debug THEN log.String("~monoClusterMem: c.max = "); log.Hex(c.max); log.Ln END; *)
			END;
			INC(used, size); 
		END
		(* post: (c = NIL) OR (c MOD 16 = 0) & (c.size >= size) *)
	END AllocateCluster;

	(*PROCEDURE FreeHeapMem (c: Cluster);
	BEGIN
		DEC(used, c.size); (*DEC(total, c.size);*)
		(* FreeHeapMem is only called in multicluster mode; in multicluster mode, total is not used *)
		platform.DeallocateMem(c.max, (S.VAL(INTEGER, c) - c.max) + c.size, TRUE)
	END FreeHeapMem;*)

	PROCEDURE DeallocateCluster (c: Cluster);
		VAR base: ADDRESS;
	BEGIN
		ASSERT(~monoClusterMem, 20);
		DEC(used, c.size); (*DEC(total, c.size);*)
		(* FreeHeapMem is only called in multicluster mode; in multicluster mode, total is not used *)
		base := c.max;
		platform.DeallocateClusterMem(base, (S.VAL(INTEGER, c) - base) + c.size)
	END DeallocateCluster;
	
	(*PROCEDURE HeapFull (size: INTEGER): BOOLEAN;
	(** Returns TRUE if committing size more bytes would exceed hardware memory capacity *)
		VAR ms: WinApi.MEMORYSTATUS;
	BEGIN
		ms.dwLength := SIZE(WinApi.MEMORYSTATUS);
		ms.dwMemoryLoad := -1;
		WinApi.GlobalMemoryStatus(ms);
		RETURN used + size > ms.dwTotalPhys
	END HeapFull;*)

	PROCEDURE AllocModMem* (descSize, modSize: INTEGER; VAR descAdr, modAdr: INTEGER);
	BEGIN
		platform.AllocateModMem(descSize, descAdr);
		IF descAdr # 0 THEN
			platform.AllocateModMem(modSize, modAdr);
			IF modAdr # 0 THEN
				INC(used, descSize + modSize) 
			ELSE platform.DeallocateModMem(descAdr, descSize, TRUE); descAdr := 0
			END
		ELSE modAdr := 0
		END
	END AllocModMem;

	PROCEDURE DeallocModMem* (descSize, modSize, descAdr, modAdr: INTEGER);
	(** Deallocate virtual memory and address space previousely allocated for module blocks. The address space may later be used again. For use by the module loader if module loading fails for some reason *)
	BEGIN
		DEC(used, descSize + modSize);
		platform.DeallocateModMem(descAdr, descSize, TRUE);
		platform.DeallocateModMem(modAdr, modSize, TRUE)
	END DeallocModMem;

	PROCEDURE InvalModMem (modSize, modAdr: INTEGER);
	BEGIN
		DEC(used, modSize);
		platform.DeallocateModMem(modAdr, modSize, FALSE)
	END InvalModMem;

	PROCEDURE IsReadable* (from, to: INTEGER): BOOLEAN;
	(** check wether memory  [from..to) may be read *)
	BEGIN 
		RETURN platform.IsReadable(from, to)
	END IsReadable;
	
	(* --------------------- COM reference counting -------------------- *)

	PROCEDURE [noframe] AddRef* (p: INTEGER): INTEGER;	(* COMPILER DEPENDENT *)
	BEGIN
		ADDREF
		(*
		INC(p.ref);
		IF p.unk # NIL THEN p.unk.AddRef() END;
		RETURN p.ref
		*)
	END AddRef;

	PROCEDURE [noframe] Release* (p: INTEGER): INTEGER;	(* COMPILER DEPENDENT *)
	BEGIN
		RELEASE
		(*
		IF p.unk # NIL THEN p.unk.Release() END;
		DEC(p.ref);
		RETURN p.ref
		*)
	END Release;

	PROCEDURE [noframe] Release2* (p: INTEGER): INTEGER;	(* COMPILER DEPENDENT *)
	BEGIN
		CALLREL;
		RELEASE
		(*
		IF p.ref = 1 THEN p.RELEASE END;
		IF p.unk # NIL THEN p.unk.Release() END;
		DEC(p.ref);
		RETURN p.ref
		*)
	END Release2;

	PROCEDURE RecFinalizer (obj: ANYPTR);
		VAR i: INTEGER; type: Type; p: IntPtr;
	BEGIN
		S.GET(S.VAL(INTEGER, obj) - 4, type);
		i := 0;
		WHILE type.ptroffs[i] >= 0 DO INC(i) END;
		INC(i);
		WHILE type.ptroffs[i] >= 0 DO
			p := S.VAL(IntPtr, S.VAL(INTEGER, obj) + type.ptroffs[i]); INC(i);
			p.p := NIL	(* calls p.p.Release *)
		END
	END RecFinalizer;

	PROCEDURE ArrFinalizer (obj: S.PTR);
		VAR last, adr, i, j: INTEGER; type: Type; p: IntPtr;
	BEGIN
		S.GET(S.VAL(INTEGER, obj) - 4, type);
		type := S.VAL(Type, S.VAL(INTEGER, type) - 2);	(* remove array flag *)
		S.GET(S.VAL(INTEGER, obj), last);
		S.GET(S.VAL(INTEGER, obj) + 8, adr);
		j := 0;
		WHILE type.ptroffs[j] >= 0 DO INC(j) END;
		INC(j);
		WHILE adr <= last DO
			i := j;
			WHILE type.ptroffs[i] >= 0 DO
				p := S.VAL(IntPtr, adr + type.ptroffs[i]); INC(i);
				p.p := NIL	(* calls p.p.Release *)
			END;
			INC(adr, type.size)
		END
	END ArrFinalizer;

	PROCEDURE ReleaseIPtrs (mod: Module);
		VAR i: INTEGER; p: IntPtr;
	BEGIN
		IF iptrs IN mod.opts THEN
			EXCL(mod.opts, iptrs);
			i := mod.nofptrs;
			WHILE mod.ptrs[i] # -1 DO
				p := S.VAL(IntPtr, mod.varBase + mod.ptrs[i]); INC(i);
				p.p := NIL	(* calls p.p.Release *)
			END
		END
	END ReleaseIPtrs;


	(* --------------------- 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 > (MAX(INTEGER) - 12) DIV 4) THEN RETURN 0 END;
		headSize := 4 * nofdim + 12; 
		fin := FALSE;
		CASE eltyp OF
		| -1: eltyp := S.ADR(IntPtrType); fin := TRUE
		| 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 (nofelem > (MAX(INTEGER) - headSize) DIV t.size) THEN 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 CHAR): Module, NEW, ABSTRACT;

	PROCEDURE SetLoaderHook*(h: LoaderHook);
	BEGIN
		loader := h
	END SetLoaderHook;
	
	PROCEDURE^ Try* (h: TryHandler; a, b, c: INTEGER);	(* COMPILER DEPENDENT *)

	PROCEDURE InitModule (mod: Module);	(* initialize linked modules *)
		VAR body: Command; 
	BEGIN
		IF ~(dyn IN mod.opts) & (mod.next # NIL) & ~(init IN mod.next.opts) THEN InitModule(mod.next) END;
		IF ~(init IN mod.opts) THEN
			body := S.VAL(Command, mod.code);
			INCL(mod.opts, init);
			actual := mod;
			IF platform # NIL THEN platform.InitModule(mod) END;
			(*
			IF debug THEN
				log.String("BEGIN "); log.String(LONG(mod.name)); log.String(' ')
			END;
			*)
			body(); actual := NIL;
		ELSIF debug THEN
			log.String("Noinit"); log.Ln
		END
	END InitModule;

	PROCEDURE ThisLoadedMod* (IN name: ARRAY OF CHAR): Module;
	(** loaded modules only *)
		VAR res: INTEGER; n: Utf8Name; m: Module;
	BEGIN
		m := modList;
		StringToUtf8(name, n, res); ASSERT(res = 0);
		loadres := done;
		WHILE (m # NIL) & ((m.name # n) OR (m.refcnt < 0)) DO m := m.next END;
		IF (m # NIL) & ~(init IN m.opts) THEN InitModule(m) END;
		IF m = NIL THEN loadres := moduleNotFound END;
		(*
		IF debug THEN
			log.String('Module '); log.String(SHORT(name)); 
			IF m = NIL THEN log.String(' NOT yet') ELSE log.String(' already') END;
			log.String(' loaded'); log.String(0AX);
		END;
		*)
		RETURN m
	END ThisLoadedMod;

	PROCEDURE ThisMod* (IN name: ARRAY OF CHAR): Module;
	BEGIN
		IF loader # NIL THEN
			loader.res := done;
			(*
			IF debug THEN log.String('Loading '); log.String(SHORT(name)); log.String(0AX); END;
			*)
			RETURN loader.ThisMod(name)
		ELSE
			RETURN ThisLoadedMod(name)
		END
	END ThisMod;

	PROCEDURE LoadMod* (IN name: ARRAY OF CHAR);
		VAR _: Module;
	BEGIN
		_ := ThisMod(name)
	END LoadMod;

	PROCEDURE GetLoaderResult* (OUT res: INTEGER; OUT importing, imported, object: ARRAY OF CHAR);
	BEGIN
		IF loader # NIL THEN
			res := loader.res;
			importing := loader.importing$;
			imported := loader.imported$;
			object := loader.object$
		ELSE
			res := loadres;
			importing := "";
			imported := "";
			object := ""
		END
	END GetLoaderResult;

	PROCEDURE ThisObject* (mod: Module; IN name: ARRAY OF CHAR): Object;
		VAR l, r, m, res: INTEGER; p: StrPtr; n: Utf8Name;
	BEGIN
		StringToUtf8(name, n, res); ASSERT(res = 0);
		l := 0; r := mod.export.num;
		WHILE l < r DO	(* binary search *)
			m := (l + r) DIV 2;
			p := S.VAL(StrPtr, S.ADR(mod.names[mod.export.obj[m].id DIV 256]));
			IF p^ = n THEN RETURN S.VAL(Object, S.ADR(mod.export.obj[m])) END;
			IF p^ < n THEN l := m + 1 ELSE r := m END
		END;
		RETURN NIL
	END ThisObject;

	PROCEDURE ThisDesc* (mod: Module; fprint: INTEGER): Object;
		VAR i, n: INTEGER;
	BEGIN
		i := 0; n := mod.export.num;
		WHILE (i < n) & (mod.export.obj[i].id DIV 256 = 0) DO 
			IF mod.export.obj[i].offs = fprint THEN RETURN S.VAL(Object, S.ADR(mod.export.obj[i])) END;
			INC(i)
		END;
		RETURN NIL
	END ThisDesc;

	PROCEDURE ThisField* (rec: Type; IN name: ARRAY OF CHAR): Object;
		VAR n, res: INTEGER; p: StrPtr; obj: Object; m: Module; nn: Utf8Name;
	BEGIN
		StringToUtf8(name, nn, res); ASSERT(res = 0);
		m := rec.mod;
		obj := S.VAL(Object, S.ADR(rec.fields.obj[0])); n := rec.fields.num;
		WHILE n > 0 DO
			p := S.VAL(StrPtr, S.ADR(m.names[obj.id DIV 256]));
			IF p^ = nn THEN RETURN obj END;
			DEC(n); INC(S.VAL(INTEGER, obj), 16)
		END;
		RETURN NIL
	END ThisField;

	PROCEDURE ThisCommand* (mod: Module; IN name: ARRAY OF CHAR): Command;
		VAR x: Object; sig: Signature;
	BEGIN
		x := ThisObject(mod, name);
		IF (x # NIL) & (x.id MOD 16 = mProc) THEN
			sig := S.VAL(Signature, x.struct);
			IF (sig.retStruct = NIL) & (sig.num = 0) THEN RETURN S.VAL(Command, mod.procBase + x.offs) END
		END;
		RETURN NIL
	END ThisCommand;

	PROCEDURE ThisType* (mod: Module; IN name: ARRAY OF CHAR): Type;
		VAR x: Object;
	BEGIN
		x := ThisObject(mod, name);
		IF (x # NIL) & (x.id MOD 16 = mTyp) & (S.VAL(INTEGER, x.struct) DIV 256 # 0) THEN
			RETURN x.struct
		ELSE
			RETURN NIL
		END
	END ThisType;

	PROCEDURE TypeOf* (IN rec: ANYREC): Type;
	BEGIN
		RETURN S.VAL(Type, S.TYP(rec))
	END TypeOf;

	PROCEDURE LevelOf* (t: Type): SHORTINT;
	BEGIN
		RETURN SHORT(t.id DIV 16 MOD 16)
	END LevelOf;

	PROCEDURE NewObj* (VAR o: S.PTR; t: Type);
		VAR i: INTEGER;
	BEGIN
		IF t.size = -1 THEN o := NIL
		ELSE
			i := 0; WHILE t.ptroffs[i] >= 0 DO INC(i) END;
			IF t.ptroffs[i+1] >= 0 THEN INC(S.VAL(INTEGER, t)) END;	(* with interface pointers *)
			o := S.VAL(S.PTR, NewRec(S.VAL(INTEGER, t)))	(* generic NEW *)
		END
	END NewObj;

	PROCEDURE GetModName* (mod: Module; OUT name: Name);
		VAR res: INTEGER;
	BEGIN
		Utf8ToString(mod.name, name, res); ASSERT(res = 0)
	END GetModName;

	PROCEDURE GetObjName* (mod: Module; obj: Object; OUT name: Name);
		VAR p: StrPtr; res: INTEGER;
	BEGIN
		p := S.VAL(StrPtr, S.ADR(mod.names[obj.id DIV 256]));
		Utf8ToString(p^$, name, res); ASSERT(res = 0)
	END GetObjName;

	PROCEDURE GetTypeName* (t: Type; OUT name: Name);
		VAR p: StrPtr; res: INTEGER;
	BEGIN
		p := S.VAL(StrPtr, S.ADR(t.mod.names[t.id DIV 256]));
		Utf8ToString(p^$, name, res); ASSERT(res = 0)
	END GetTypeName;

	PROCEDURE RegisterMod* (mod: Module);
		VAR i: INTEGER;
	BEGIN
		mod.next := modList; modList := mod; 
		(*
		IF debug THEN
			log.String('Registering '); log.String(LONG(mod.name)); log.String(0AX)
		END;
		*)
		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;
		platform.GetLoadTime(mod.loadTime);
		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 [code] PUSH (p: INTEGER) 050H;	(* push AX *)
	PROCEDURE [code] CALL (a: INTEGER) 0FFH, 0D0H;	(* call AX *)
	PROCEDURE [code] RETI (): LONGINT;
	PROCEDURE [code] RETR (): REAL;
	
	(*
		type				par
		32 bit scalar	value
		64 bit scalar	low hi
		var scalar		address
		record			address tag
		array			  address size
		open array	   length_N-1 .. length_0
	*)
	
	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, ANYREC *)
				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 *)
				ELSIF S.VAL(INTEGER, typ) = 11 THEN   (* ANYREC *)
					ASSERT(kind # 10); (* not a value par, also checked by compiler *)
					DEC(n); PUSH(par[n]) (* push tag *)
				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; OUT ch: SHORTCHAR);
	BEGIN
		S.GET(ref, ch); INC(ref)
	END RefCh;

	PROCEDURE RefNum (VAR ref: INTEGER; OUT x: INTEGER);
		VAR s, n: INTEGER; ch: SHORTCHAR;
	BEGIN
		s := 0; n := 0; RefCh(ref, ch);
		WHILE ORD(ch) >= 128 DO INC(n, ASH(ORD(ch) - 128, s) ); INC(s, 7); RefCh(ref, ch) END;
		x := n + ASH(ORD(ch) MOD 64 - ORD(ch) DIV 64 * 64, s)
	END RefNum;

	PROCEDURE RefName (VAR ref: INTEGER; OUT n: Utf8Name);
		VAR i: INTEGER; ch: SHORTCHAR;
	BEGIN
		i := 0; RefCh(ref, ch);
		WHILE ch # 0X DO n[i] := ch; INC(i); RefCh(ref, ch) END;
		n[i] := 0X
	END RefName;

	PROCEDURE GetRefProc* (VAR ref: INTEGER; OUT adr: INTEGER; OUT name: Utf8Name);
		VAR ch: SHORTCHAR;
	BEGIN
		S.GET(ref, ch);
		WHILE ch >= 0FDX DO	(* skip variables *)
			INC(ref); RefCh(ref, ch);
			IF ch = 10X THEN INC(ref, 4) END;
			RefNum(ref, adr); RefName(ref, name); S.GET(ref, ch)
		END;
		WHILE (ch > 0X) & (ch < 0FCX) DO	(* skip source refs *)
			INC(ref); RefNum(ref, adr); S.GET(ref, ch)
		END;
		IF ch = 0FCX THEN INC(ref); RefNum(ref, adr); RefName(ref, name)
		ELSE adr := 0
		END
	END GetRefProc;
	
	(* 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; OUT mode, form: SHORTCHAR; OUT desc: Type;
																OUT adr: INTEGER; OUT name: Utf8Name);
	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
			log.String("Kernel.GetRefVar failed! "); log.Hex(ref); log.String('H'); log.Ln;
			mode := 0X; form := 0X; adr := 0
		END
	END GetRefVar;

	PROCEDURE SourcePos* (mod: Module; codePos: INTEGER): INTEGER;
		VAR ref, pos, ad, d: INTEGER; ch: SHORTCHAR; name: Utf8Name;
	BEGIN
		IF mod # NIL THEN	(* mf, 12.02.04 *)
			ref := mod.refs; pos := 0; ad := 0; S.GET(ref, ch);
			WHILE ch # 0X DO
				WHILE (ch > 0X) & (ch < 0FCX) DO	(* srcref: {dAdr,dPos} *)
					INC(ad, ORD(ch)); INC(ref); RefNum(ref, d);
					IF ad > codePos THEN RETURN pos END;
					INC(pos, d); S.GET(ref, ch)
				END;
				IF ch = 0FCX THEN	(* proc: 0FCX,Adr,Name *)
					INC(ref); RefNum(ref, d); RefName(ref, name); S.GET(ref, ch);
					IF (d > codePos) & (pos > 0) THEN RETURN pos END 
				END;
				WHILE ch >= 0FDX DO	(* skip variables: Mode, Form, adr, Name *)
					INC(ref); RefCh(ref, ch);
					IF ch = 10X THEN INC(ref, 4) END;
					RefNum(ref, d); RefName(ref, name); S.GET(ref, ch)
				END
			END;
		END;
		RETURN -1
	END SourcePos;
	
	(* adimetrius, 2020.01, 2021.05 *)

	PROCEDURE GetRefFrameDo (VAR fr: FrameDesc);				(* based on DefaultTrapView *)
		VAR res, end, refs: INTEGER; name: Utf8Name; m: Module;
	BEGIN 
		hi := baseStack;
		inMainStack := (lo <= fr.fp)AD: i think this is a tautology - always TRUE & (fr.fp < hi)((trap.top = fr.fp) OR Below(trap.top, fr.fp)) & Below(fr.fp, hi);
		inSignalStack := ((sigStack = fr.fp) OR Below(sigStack, fr.fp)) & Below(fr.fp, sigStack + sigStackSize);
		fr.eos := ~inMainStack & ~inSignalStack;
		fr.eos := ~platform.InActivationStack(fr.fp);
		IF fr.eos THEN fr.m := ''; fr.p := ''; fr.pos := undefined; fr.sentry := NIL
		ELSE
			m := modList; fr.modpc := fr.pc;
			WHILE (m # NIL) & ((fr.modpc < m.code) OR (fr.modpc >= m.code + m.csize)) DO m := m.next END;
			IF m # NIL THEN
				DEC(fr.modpc, m.code);
				IF m.refcnt >= 0 THEN refs := m.refs;
					REPEAT GetRefProc(refs, end, name) UNTIL (end = 0) OR (fr.modpc < end);
					IF fr.modpc < end THEN Utf8ToString(name, fr.p, res); fr.pos := SourcePos(m, fr.modpc)
					END 
				ELSE fr.pos := unloaded; fr.p := '<unloaded>'
				END;
				Utf8ToString(m.name, fr.m, res)
			ELSE fr.m := ''; fr.p := ''; fr.pos := undefined
			END;
			INC(fr.depth)
		END
	END GetRefFrameDo;
	
	
	(** Initialize fr to hold data for the activation stack determined by pc and fp: fp is the base address of the activation frame, and pc is an address within the instruction that caused activation frame to be created (it can be a CALL instruction, or an arbitrary instruction that caused a signal/trap).
	Attention! pc and fp are not validated! Use at your own risk! *)
	
	PROCEDURE GetThisRefFrame (VAR fr: FrameDesc; pc, fp: ADDRESS);
	BEGIN
		fr.sentry := sentry;
		fr.depth := -1;
		fr.pos := undefined;
		fr.pc := pc;
		fr.lo := fp;
		fr.fp := fp;
		GetRefFrameDo(fr)
	END GetThisRefFrame;
	

	(** Used to iterate call stack frames. If P calls Q, and fr holds frame data for Q's activation, then after GetRefFrame(fr) fr will hold data for P's activation frame. If fr is uninitialized, and P calls GetRefFrame(fr), then fr will hold data for P's activation frame. Use GetThisRefFrame to initialize fr with an arbitrary frame. *)
	
	PROCEDURE GetRefFrame (VAR fr: FrameDesc); 	
	BEGIN 
		IF fr.sentry = NIL THEN 
			fr.sentry := sentry; fr.depth := -1; fr.pos := undefined; fr.eos := FALSE;
			S.GETREG(FP, fr.fp); fr.lo := fr.fp;
			S.GET(fr.fp + SIZE(ADDRESS), fr.pc); DEC(fr.pc); S.GET(fr.fp, fr.fp)
		ELSIF ~fr.eos THEN
			S.GET(fr.fp + SIZE(ADDRESS), fr.pc); DEC(fr.pc); S.GET(fr.fp, fr.fp)
		END;
		GetRefFrameDo(fr)
	END GetRefFrame;
	
	
	(* -------------------- dynamic link libraries --------------------- *)

	PROCEDURE LoadDll* (IN name: ARRAY OF CHAR; VAR ok: BOOLEAN);
	BEGIN 
		platform.LoadDll(name, ok)
	END LoadDll;

	PROCEDURE ThisDllObj* (mode, fprint: INTEGER; IN dll, name: ARRAY OF CHAR): INTEGER;
	BEGIN
		RETURN platform.ThisDllObj(mode, fprint, dll, name)
	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, _, __: 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 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 & ~monoClusterMem & (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;
				DeallocateCluster(c)	(*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) & ~blockCollect 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) & ~blockCollect 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 DumpClusters;
		VAR c: Cluster;
	BEGIN
		c := root;
		log.String('Clusters:'); log.Ln;
		WHILE c # NIL DO
			log.Hex(S.VAL(ADDRESS, c)); log.String(' '); log.Hex(c.size); log.String(' '); log.Hex(c.max); log.Ln; c := c.next
		END;
	END DumpClusters;
	
	PROCEDURE DumpFree;
		VAR i: INTEGER; f: FreeBlock;
	BEGIN
		i := 0;
		REPEAT
			log.Hex(i); log.String(": ");
			IF free[i] = sentinel THEN log.String('!')
			ELSE 
				f := free[i];
				REPEAT log.Hex(f.size); log.String(' '); f := f.next UNTIL (f = sentinel) OR (f = NIL)
			END;
			log.Ln;
			INC(i)
		UNTIL i = N
	END DumpFree;
	
	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 GetOldFreeBlock (size: INTEGER; OUT fb: 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;
		fb := b
	END GetOldFreeBlock;

	PROCEDURE LastBlock (limit: INTEGER): FreeBlock;	(* size MOD 16 = 0 *)
	(* Extract from the free list and return the FreeBlock b that ends at limit - 4.
	This procedure is ONLY called in monocluster mode!
	The returned block is EXCLUDED from the free list!! *)
		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 MakeFreeMonocluster (tsize: INTEGER; OUT fb: FreeBlock);
	(** Assuming there's no free block of at least tsize, make a new free block of at least tsize bytes in monocluster heap mode *)
		VAR b: FreeBlock; r, next: Reducer; 
			a, 	(* address of potential free block *)
			old, new: INTEGER;	(* old and new committed portion size *)
	BEGIN														(* LONG prevents integer overflow on address arithmetic *)
		IF ~dontCollect & HeapFull(tsize)(used + LONG(tsize) > platform.physicalMemory) & (reducers # NIL) THEN	(* 3) little space => reduce once *)
			r := reducers; reducers := NIL;
			WHILE r # NIL DO next := r.next; r.next := NIL; r.Reduce(FALSE); r := (*r.*)next END;
			Collect;
			GetOldFreeBlock(tsize, b)
		END;
		IF (b = NIL) & platform.gradualCommit THEN	
			(* this branch is actually win-specific, and should only be invoked if the platform provides a Commit *)
			IF tsize <= MAX(INTEGER) DIV 3 * 2 - allocated THEN	(*??? ~1.5G - allocated *)
				s := (tsize + allocated) DIV 2 * 3	(* euristic? required heap size *1.5? *)
			ELSIF tsize <= root.max - allocated THEN
				s := root.max
			ELSE
				RETURN NIL
			END;new := SHORT(MIN(root.max, (tsize + LONG(allocated)) DIV 2 * 3));
			a := 12 + (root.size - 12) DIV 16 * 16;	(* a is always 4 bytes short of a 16-rounded address (or 12 bytes after another 16-rounded address *)
			(* a is the offset WRT root of a potential free block that would apper at the newly committed region *)
			IF s <= totalroot.size THEN
				b := OldBlock(tsize);	(* this has been tried before, hasn't it? // No, not after calling reducers *)
				IF b = NIL THEN s := a + tsize END
			ELSIF s < a + tsize THEN
				s := a + tsize
			END; (* weird... since OldBlock(tsize) = NIL, both branches end up in s := a + tsize - same result.  *)IF (new <= root.size) OR (new < a + tsize) THEN new := a + tsize END;
			ASSERT(root.size < new, 78);
			IF totalroot.size < new THEN	(* 4) enlarge cluster'new committed portion *)
				(*GrowHeapMem(new, root);*)
				old := root.size; 
				platform.Commit(S.VAL(ADDRESS, root), old, root.max, new, root.size);
				IF root.size >=< sroot.size # old THEN	(* successfull commit *)
					INC(used, root.size - old); (*INC(total, new - root.size);*) root.size := new;
					b := LastBlock(S.VAL(INTEGER, root) + a);	(* last block of root cluster that ends at a - 4 *)
					IF b # NIL THEN
						b.size := (root.size - a + b.size + 4) DIV 16 * 16 - 4
					ELSE
						b := S.VAL(FreeBlock, S.VAL(INTEGER, root) + a);
						b.size := (root.size - a) DIV 16 * 16 - 4
					END 
				(*ELSIF reducers # NIL THEN	(* 5) no space => fully reduce *)
					r := reducers; reducers := NIL;
					WHILE r # NIL DO r.Reduce(TRUE); r := r.next END;
					Collect*)
				END
			END
		END;
		IF (b = NIL) & ~dontCollect & (reducers # NIL) THEN	(* 5) no space => fully reduce *)
			r := reducers; reducers := NIL;
			WHILE r # NIL DO next := r.next; r.next := NIL; r.Reduce(TRUE); r := (*r.*)next END;
			Collect;
			GetOldFreeBlock(tsize, b)
		END; 
		(*IF b = NIL THEN
			b := OldBlock(tsize);
			(*IF b = NIL THEN RETURN NIL END	(* 6) give up *)*)
		END;*)
		fb := b
	END MakeFreeMonocluster;
	
	PROCEDURE MakeFreeMulticluster (tsize: INTEGER; OUT fb: FreeBlock);
	(** Assuming there's no free block of at least tsize, make a new free block of at least tsize bytes in multicluster heap mode *)
		VAR a, s: INTEGER; b: FreeBlock; new, c: Cluster; r: Reducer;
	BEGIN
		AllocateCluster(tsize + 12, new);	(* 3) allocate a 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
			b := NIL	(* 4) give up *)
		END;
		fb := b
	END MakeFreeMulticluster;

	PROCEDURE NewBlock (size: INTEGER): Block;
		VAR tsize, a, s: INTEGER; b: FreeBlock; new, c: Cluster; r: Reducer; 
	BEGIN
		ASSERT(size >= 0, 20);
		IF size > MAX(INTEGER) - 19 THEN RETURN NIL END;
		tsize := (size + 19) DIV 16 * 16;	(* tsize is at least 4 bytes greater than size, and always a quotient of 16. 19 = 16 - 1 + 4 *)
		GetOldFreeBlock(tsize, b);	(* 1) search for free block *)
		IF (b = NIL) & ~dontCollect THEN
			FastCollect; GetOldFreeBlock(tsize, b);	(* 2) collect *)
			IF b = NIL THEN
				Collect; GetOldFreeBlock(tsize, b);	(* 2a) fully collect *)
			END
		END;
		IF b = NIL THEN 
			IF monoClusterMem THEN
				MakeFreeMonocluster(tsize, b)
			ELSE
				MakeFreeMulticluster(tsize, b)
			END
		END;
		IF b # NIL THEN (* 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)
		END;
		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* (cmd: Command);
	BEGIN
		ASSERT(cmd # NIL, 20); 
		S.GETREG(SP, baseStack);	(* save base stack *)
		platform.Start(cmd)
	END Start;

	PROCEDURE Quit* (exitCode: INTEGER);
		VAR m: Module; term: Command; t: BOOLEAN;
	BEGIN
		trapViewer := NIL; trapChecker := 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;
		platform.Terminate(exitCode)
	END Quit;

	PROCEDURE FatalError* (id: INTEGER; IN str: ARRAY OF CHAR);
	BEGIN
		platform.FatalError(id, str)	 (* never returns *)
	END FatalError;
	
	PROCEDURE InterfaceTrapHandler* (excpRec, estFrame, context, dispCont: INTEGER): INTEGER;
	(* known to compiler *)
	BEGIN
		Assert(platform.interfaceTrapHandler # NIL, "InterfaceTrapHandler not installed. Running Windows/COM on Linux?");
		RETURN platform.interfaceTrapHandler(excpRec, estFrame, context, dispCont)
	END InterfaceTrapHandler;



	(* -------------------- Console Trap Viewer -------------------- *)
	
	(* adimetrius, 2020.01, 2021.05 *)
		
	PROCEDURE ShowOffendingCodes (pc: INTEGER);
	(** With pc pointing to the instruction FOLLOWING the offending instruction, show 15 bytes of preceeding machine codes. (15 is the maximal instruction length in i386) *)
		VAR b, i: INTEGER; chars: ARRAY 4 OF CHAR;
		PROCEDURE HexDig (x: INTEGER): CHAR; 
		BEGIN IF x > 9 THEN INC(x, ORD('A') - 10) ELSE INC(x, ORD('0')) END; RETURN CHR(x) 
		END HexDig;
	BEGIN chars[2] := ' '; chars[3] := 0X; b := 0; 
		i := pc - 15; WHILE i < pc DO
			IF ~platform.IsReadable(i, i) THEN chars := "?? "
			ELSE S.MOVE(i, S.ADR(b), 1); chars[0] := HexDig(b DIV 10H); chars[1] := HexDig(b MOD 10H)
			END;
			blog.String(chars); INC(i) 
		END
	END ShowOffendingCodes;
	
	PROCEDURE LogThisStack (pc, fp: ADDRESS);
		VAR frame: FrameDesc; u: INTEGER;
	BEGIN 
		(*INCL(dirty, defLogger);*)
		u := unit; unit := defLogger;
		GetThisRefFrame(frame, pc, fp);
		WHILE ~frame.eos DO
			blog.Int(frame.depth); blog.String(': ');
			IF frame.m = '' THEN blog.String('<caller outside BB>') 
			ELSE blog.String(frame.m); blog.String('.'); blog.String(frame.p)
			END;
			IF frame.pos >= 0 THEN blog.String(" [@="); blog.Int(frame.pos); blog.String('] ' ) 
			ELSIF frame.pos = unloaded THEN blog.String("[unloaded] ")
			END;
			blog.String(" <PC="); blog.Hex(frame.modpcpc); blog.String(' FP='); blog.Hex(frame.fp); blog.String('>'); 
			(* improve? show PC WRT module's code rather than absolute address 
				ShowOffendingCodes(frame.pc + 1);
			*)
			blog.Ln;
			GetRefFrame(frame)
		END;
		unit := u
		(*EXCL(dirty, defLogger)*)
	END LogThisStack;
	
	PROCEDURE TrapCleanup (_, __, ___: INTEGER);
		VAR t: TrapCleaner; u: INTEGER;
	BEGIN
		(*INCL(dirty, cleanup);*)
		u := unit; unit := cleanup;
		WHILE trapStack # NIL DO
			t := trapStack; trapStack := trapStack.next; t.Cleanup
		END;
		IF (trapChecker # NIL) & (err # silentTrap) THEN trapChecker END;
		unit := u
		(*EXCL(dirty, cleanup)*)
	END TrapCleanup;

	PROCEDURE SetTrapGuard* (on: BOOLEAN);
	BEGIN
		guarded := on
	END SetTrapGuard;

	PROCEDURE Try* (h: TryHandler; a, b, c: INTEGER);
	BEGIN
		IF ~platform.initialized THEN
			log.String('Fatal: No Platform hook installed into Kernel'); log.Ln; Quit(1)
		ELSE
			INC(tryCount); platform.Try(h, a, b, c); DEC(tryCount)
		END
	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 TrapTitle (err, val: INTEGER);
	BEGIN
		IF err = 129 THEN blog.String("129 invalid with")
		ELSIF err = 130 THEN blog.String("130 invalid case")
		ELSIF err = 131 THEN blog.String("131 function without return")
		ELSIF err = 132 THEN blog.String("132 type guard")
		ELSIF err = 133 THEN blog.String("133 implied type guard")
		ELSIF err = 134 THEN blog.String("134 value out of range")
		ELSIF err = 135 THEN blog.String("135 index out of range")
		ELSIF err = 136 THEN blog.String("136 string too long")
		ELSIF err = 137 THEN blog.String("137 stack overflow")
		ELSIF err = 138 THEN blog.String("138 integer overflow")
		ELSIF err = 139 THEN blog.String("139 division by zero")
		ELSIF err = 140 THEN blog.String("140 infinite real result")
		ELSIF err = 141 THEN blog.String("141 real underflow")
		ELSIF err = 142 THEN blog.String("142 real overflow")
		ELSIF err = 143 THEN blog.String("143 undefined real result")
		ELSIF err = 200 THEN blog.String("200 keyboard interrupt")
		ELSIF err = 202 THEN blog.String("202 illegal instruction:  "); blog.Int(val)
		ELSIF err = 203 THEN blog.String("203 illegal memory read [ad = "); blog.Hex(val); blog.String("]")
		ELSIF err = 204 THEN blog.String("204 illegal memory write [ad = "); blog.Hex(val); blog.String("]")
		ELSIF err = 205 THEN blog.String("205 illegal execution [ad = "); blog.Hex(val); blog.String("]")
		ELSIF err < 0 THEN blog.String("exception #"); blog.Int(-err) 
		ELSE blog.Int(err);
			IF err = 126 THEN blog.String(" (not yet implemented)")
			ELSIF err = 125 THEN blog.String(" (call of obsolete procedure)")
			ELSIF err >= 100 THEN blog.String(" (invariant violated)")
			ELSIF err >= 60 THEN blog.String(" (postcondition violated)")
			ELSIF err >= 20 THEN blog.String(" (precondition violated)")
			END
		END; blog.Ln
	END TrapTitle;
	
	PROCEDURE SigRepHeader (pc, fp, sp: ADDRESS; err: INTEGER; recursive: BOOLEAN);
	BEGIN
		blog.Reset;
		blog.String("********* TRAP REPORT - BEGIN *********"); blog.Ln;
		platform.PrintHeaderInfo;
		IF recursive THEN blog.String("RECURSIVE! ") END;
		blog.String(" <PC="); blog.Hex(pc); blog.String(", FP="); blog.Hex(fp); 
		blog.String(", SP="); blog.Hex(sp); blog.String(">"); blog.Ln;
		IF debug THEN
			blog.String("dirty = {");
			IF defLogger IN dirty THEN blog.String(" defLogger") END;
			IF gc IN dirty THEN blog.String(" gc") END;
			IF cleanup IN dirty THEN blog.String(" cleanup") END;
			IF viewer IN dirty THEN blog.String(" viewer") END;
			blog.String(" }"); blog.Ln;
		END;
		TrapTitle(err, val)
	END SigRepHeader;

	PROCEDURE SigRepFooter;
	BEGIN
		blog.String("********* TRAP REPORT - END *********"); blog.Ln;
	END SigRepFooter;

	PROCEDURE Report (_, __, ___: INTEGER);
		VAR u: INTEGER;
	BEGIN
		(*INCL(dirty, viewer);*)
		u := unit; unit := viewer;
		IF (trapViewer # NIL) & (err # silentTrap) & ~guarded THEN trapViewer() END;
		unit := u
		(*EXCL(dirty, viewer)*)
	END Report;
	
	
	PROCEDURE HandleTrap*;
	(* Trap handling scheme is as follows:
	1. A platform signal is received by platform-dependent module T that implements trap-related Platform procedures.
	2. Module T converts platform information into BlackBox trap information and calls Kernel.HandleTrap.
	3. Kernel.HandleTrap calls Platform.GetTrapInfo to get trap information from the platform.
	Thus, if HandleTrap is called arbitrarily by some client, .GetTrapInfo should return pc = 0, and Kernel will not process a fake HandleTrap call. *)
		VAR recursive: BOOLEAN;
	BEGIN
		stack := baseStack;
		INCL(dirty, unit); unit := other;
		IF ~platform.initialized THEN log.String("Fatal: No Platform hook installed into Kernel"); log.Ln; Quit(1)
		ELSE
			platform.GetTrapInfo(pc, sp, fp, err, val, recursive);
			IF pc = 0 THEN log.String('No actual trap when Kernel.HandleTrap called'); log.Ln; HALT(20)
			ELSE
				INC(trapCount);
				InitFpu;
				
				SigRepHeader(pc, fp, sp, err, recursive);
				IF ~(defLogger IN dirty) THEN DefaultTrapViewer(trap.depth > 1, sig, trapViewer = NIL)LogThisStack(pc, fp) END;
				SigRepFooter();
				
				IF (err # silentTrap) & (trapViewer = NIL) THEN
					platform.FatalError(trapMessage, blog.buf)
				END;
				
				IF (err = keyboardInterrupt) & (currentTryContext = NILtryCount = 0) THEN 
					log.String("SIGINT received, preparing to quit"); log.Ln; Quit(1) 
				ELSE 
					IF ~(cleanup IN dirty) THEN Try(TrapCleanup, -1, -1, -1) END;
					IF ~(viewer IN dirty) THEN Try(Report, -1, -1, -1) END
				END
				
			END
		END
	END HandleTrap;
	
	PROCEDURE InitHeap;
		VAR i: INTEGER;
	BEGIN
		
		(* monoClusterMem := FALSE; *)
		allocated := 0; (*total := 0;*) used := 0;
		sentinelBlock.size := MAX(INTEGER);
		sentinel := S.ADR(sentinelBlock); 
		i := N;
		
		REPEAT DEC(i); free[i] := sentinel UNTIL i = 0;
		(* debug := TRUE; *)
		IF monoClusterMem THEN
			AllocateCluster(1, root);
			ASSERT(root # NIL, 60);
			i := MIN(N - 1, (root.size - 12) DIV 16 - 1);
			free[i] := S.VAL(FreeBlock, S.VAL(INTEGER, root) + 12);
			free[i].next := sentinel;
			free[i].size := (root.size - 12) DIV 16 * 16 - 4;
			free[i].tag:=S.VAL(Type, S.ADR(free[i].size));
			(* IF debug THEN ;DumpFree; END *)
		END;
		(*
		IF debug THEN
			IF monoClusterMem THEN
				log.String("MonoCluster Heap Layout; ");
				log.Int(root.size); log.String(" committed, "); log.Int(root.max); log.String(" reserved"); log.Ln;
				DumpClusters	
			ELSE
				log.String("MultiCluster Heap Layout; no cluster allocated yet "); log.ln
			END
		END
		*)
		(* ;debug := FALSE *)
	END InitHeap;
	
	PROCEDURE (VAR p: Platform) Setup* (baseStack: ADDRESS; opts: SET; OUT id: INTEGER; OUT eoln: Eoln; VAR monoClusterMem: BOOLEAN; OUT gradualCommit: BOOLEAN; VAR physicalMemory: INTEGER; OUT try: PROCEDURE (h: TryHandler; a, b, c: INTEGER)), NEW, ABSTRACT;
	
	PROCEDURE SetPlatform* (p: POINTER TO Platform);
		VAR opts: SET;
	BEGIN
		ASSERT(platform = NIL, 20);
		ASSERT(p # NIL, 21);
		platform := p;
		opts := {};
		IF inDll THEN INCL(opts, dll) END;
		IF monoClusterMem THEN INCL(opts, monoCluster) END; 
		IF static THEN INCL(opts, init) END;
		platform.id := -1;
		platform.physicalMemory := MAX(INTEGER);
		platform.Setup(baseStack, opts, platform.id, platform.eoln, monoClusterMem, platform.gradualCommit, platform.physicalMemory, platform.Try);
		ASSERT(platform.id # -1, 22);
		ASSERT(platform.eoln # '', 23);
		ASSERT(platform.Try # NIL, 24);
		platform.SetupModListAccess; (* A. V. Shiryaev, 2012.11: OpenBSD *)
		log.string := platform.String; log.ln := platform.Ln;
		blog.string := platform.String; blog.ln := platform.Ln;
		platform.initialized := TRUE;
		(* After platform has been initialized, heap may be initialized *)
		InitHeap
	END SetPlatform;
	
	
	PROCEDURE Init;
		VAR i: INTEGER;
	BEGIN
		blockCollect := FALSE;
		(*allocated := 0; total := 0; used := 0;
		sentinelBlock.size := MAX(INTEGER);
		sentinel := S.ADR(sentinelBlock); 
		i := N;
		REPEAT DEC(i); free[i] := sentinel UNTIL i = 0;*)
		IF inDll THEN 
(*
			baseStack := FPageWord(4);	(* begin of stack segment *)
*)
		 END;
		InitFpu;
		IF ~static THEN
			InitModule(modList);
			IF ~inDll THEN Quit(1) END
		END
	END Init;
	
BEGIN
	IF modList = NIL THEN	(* only once *)
		S.GETREG(ML, modList);	(* linker loads module list to BX *)
		S.GETREG(SP, baseStack);
		stack := baseStack;	(* stack bottom, used by DevDebug and other possible trap analyzers *)
		sentry := "Initialized";	(* adimetrius, 2020.01 *) 
		static := init IN modList.opts;
		inDll := dll IN modList.opts;
		monoClusterMem := ~(dll IN modList.opts);
		Init;
	END;
	debug := FALSE
CLOSE
	IF ~terminating THEN
		terminating := TRUE;
		Quit(0)
	END
END Kernel.

