System/Mod/Meta.odc

MODULE Meta; (* SP410 *)
(**
	project	= "BlackBox"
	organization	= "www.oberon.ch"
	contributors	= "Oberon microsystems"
	version	= "System/Rsrc/About"
	copyright	= "System/Rsrc/About"
	license	= "Docu/BB-License"
	changes	= "
	- 20111211, Fyodor Tkachov, switched from National to i21sysCharacters
	- 20080215, Fyodor Tkachov, reviewed
	- 20050626, Fyodor Tkachov, russification edited
	- 20050430, Ivan Goryachev, russification
	- YYYYMMDD, nn, ...
	"
	issues	= "
	- ...
	"

**)

	IMPORT SYSTEM, Kernel, i21sysCharacters;

	CONST
		(** result codes for object classes, type classes, visibility classes **)
		undef* = 0;

		(** object classes **)
		typObj* = 2; varObj* = 3; procObj* = 4; fieldObj* = 5; modObj* = 6; 

		(** type classes **)
		boolTyp* = 1; sCharTyp* = 2; charTyp* = 3;
		byteTyp* = 4; sIntTyp* = 5; intTyp* = 6;
		sRealTyp* = 7; realTyp* = 8; setTyp* = 9;
		longTyp* = 10; anyRecTyp* = 11; anyPtrTyp* = 12;
		sysPtrTyp = 13; 
		procTyp* = 16; recTyp* = 17; arrTyp* = 18; ptrTyp* = 19;
		
		(** record attributes **)
		final* = 0; extensible* = 1; limited* = 2; abstract* = 3;
		
		(** visibility **)
		hidden* = 1; readOnly* = 2; private = 3; exported* = 4;

		(* scanner modes *)
		modScan = 1; globScan = 2; recVarScan = 3; recTypeScan = 4;

	TYPE
		Name* = ARRAY 256 OF CHAR;

		Value* = ABSTRACT RECORD END;	(* to be extended once with a single field of any type *)
		
		ArrayPtr = POINTER TO Array;

		Item* = RECORD (Value)
			obj-: INTEGER;		(* typObj, varObj, procObj, fieldObj, modObj *)
			typ-: INTEGER;		(* typObj, varObj, fieldObj: type;	procObj, modObj: 0 *)
			vis-: INTEGER;		(* varObj, procObj, fieldObj: vis;	typObj, modObj: 0 *)
			adr-: INTEGER;		(* varObj, procObj: adr;	fieldObj: offs;	typObj, modObj: 0 *)
			mod: Kernel.Module;	(* stat varObj, procObj, modObj: mod;	dyn varObj, typObj, fieldObj: NIL *)
			desc: Kernel.Type;		(* typObj, varObj, fieldObj: struct;	procObj: signature;	modObj: NIL *)
			ptr: ArrayPtr;			(* # NIL => item valid;	dyn varObj: ptr;	else: dummy *)
			ext: Kernel.ItemExt		(* all method calls forwarded if # NIL *)
		END;

		Scanner* = RECORD
			this-: Item;
			eos-: BOOLEAN;	(* end of scan *)
			mode: INTEGER;	(* modScan, globScan, recVarScan, recTypeScan *)
			base: INTEGER;	(* recVarScan, recTypeScan: base level index *)
			vis: INTEGER;		(* recVarScan: record vis *)
			adr: INTEGER;		(* recVarScan: record adr *)
			idx: INTEGER;		(* globScan, recVarScan, recTypeScan: object index *)
			desc: Kernel.Type;	(* recVarScan, recTypeScan: record desc *)
			mod: Kernel.Module;	(* modScan: next mod;	globScan, recVarScan: source mod *)
			obj: Kernel.Object	(* globScan, recVarScan, recTypeScan: actual object *)
		END;
		
		LookupFilter* = PROCEDURE (IN path: ARRAY OF CHAR; OUT i: Item; OUT done: BOOLEAN);
	
		FilterHook = POINTER TO RECORD
			next: FilterHook;
			filter: LookupFilter
		END;

		Array = EXTENSIBLE RECORD
			w0, w1, w2: INTEGER;	(* gc header *)
			len: ARRAY 16 OF INTEGER	(* dynamic array length table *)
		END;
		
		SStringPtr = POINTER TO ARRAY [1] OF SHORTCHAR;
		StringPtr = POINTER TO ARRAY [1] OF CHAR;
	
	VAR
		dummy: ArrayPtr;	(* dummy object for item.ptr *)
		filterHook: FilterHook;


	(* preconditions:
		ASSERT(i.ptr # NIL, 20);	(* invalid item *)
		ASSERT(i.typ >= recTyp, 21);	(* wrong type *)
		ASSERT(i.obj = varObj, 22);	(* wrong object class *)
		ASSERT((i.mod = NIL) OR (i.mod.refcnt >= 0), 23);	(* unloaded object module *)
		ASSERT(i.desc.mod.refcnt >= 0, 24);	(* unloaded type module *)
		ASSERT(d.id DIV 16 MOD 16 = 1, 25);	(* value not extended once *)
		ASSERT(d.fields.num = 1, 26);	(* not a single value field *)
		ASSERT(i.vis = exported, 27);	(* write protected destination *)
		ASSERT(type.desc.base[t.id DIV 16 MOD 16] = t, 28);	(* wrong pointer type *)
		ASSERT((i < n) & (d.obj[i].id DIV 16 MOD 16 = exported), 29);	(* unexported type *)
		ASSERT(type.desc.id DIV 4 MOD 4 < limited, 30);	(* limited or abstract type *)
		ASSERT(i.ext = NIL, 31);	(* unsupported extension *)
	*)


	PROCEDURE DescOf (IN x: ANYREC): Kernel.Type;
	BEGIN
		RETURN SYSTEM.VAL(Kernel.Type, SYSTEM.TYP(x))
	END DescOf;

	PROCEDURE TypOf (struct: Kernel.Type): INTEGER;
	BEGIN
		IF SYSTEM.VAL(INTEGER, struct) DIV 256 = 0 THEN
			RETURN SHORT(SHORT(SYSTEM.VAL(INTEGER, struct)))
		ELSE
			RETURN SHORT(SHORT(16 + struct.id MOD 4))
		END
	END TypOf;
	
	PROCEDURE LenOf (IN i: Item): INTEGER;
	BEGIN
		IF i.desc.size # 0 THEN RETURN i.desc.size
		ELSIF i.ptr = dummy THEN RETURN 0
		ELSE RETURN i.ptr.len[i.desc.id DIV 16 MOD 16 - 1]
		END
	END LenOf;
	
	PROCEDURE SizeOf (IN i: Item): INTEGER;
		VAR el: Item;
	BEGIN
		CASE i.typ OF
		| anyRecTyp: RETURN 0
		| boolTyp, sCharTyp, byteTyp: RETURN 1
		| charTyp, sIntTyp: RETURN 2
		| longTyp, realTyp: RETURN 8
		| recTyp: RETURN i.desc.size
		| arrTyp:
			el.desc := i.desc.base[0]; el.typ := TypOf(el.desc); el.ptr := i.ptr; 
			RETURN LenOf(i) * SizeOf(el)
		ELSE RETURN 4
		END
	END SizeOf;
	
	PROCEDURE GetName (IN path: ARRAY OF CHAR; OUT name: ARRAY OF CHAR; VAR i: INTEGER);
		VAR j: INTEGER; ch: CHAR;
	BEGIN
		j := 0; ch := path[i];
		WHILE (j < LEN(name) - 1) & i21sysCharacters.IsIdentChar(ch) DO
			name[j] := ch; INC(i); INC(j); ch := path[i]
		END;
		IF (ch = 0X) OR (ch = ".") OR (ch = "[") OR (ch = "^") THEN name[j] := 0X
		ELSE name[0] := 0X
		END
	END GetName;
	
	PROCEDURE LegalName (IN name: ARRAY OF CHAR): BOOLEAN;
		VAR i: INTEGER; ch: CHAR;
	BEGIN
		i := 0; ch := name[0];
		WHILE (i < LEN(name) - 1) & i21sysCharacters.IsIdentChar(ch) DO
			INC(i); ch := name[i]
		END;
		RETURN (i > 0) & (ch = 0X)
	END LegalName;
	

	(* ---------- Item properties ---------- *)
	
	PROCEDURE (VAR i: Item) Valid* (): BOOLEAN, NEW;
	BEGIN
		IF i.ext # NIL THEN RETURN i.ext.Valid() END;
		RETURN (i.ptr # NIL) & ((i.mod = NIL) OR (i.mod.refcnt >= 0)) & ((i.typ < recTyp) OR (i.desc.mod.refcnt >= 0))
	END Valid;

	PROCEDURE (VAR i: Item) GetTypeName* (OUT mod, type: Name), NEW;
		VAR n: Kernel.Name;
	BEGIN
		ASSERT(i.ext = NIL, 31);
		ASSERT(i.ptr # NIL, 20);
		ASSERT(i.typ >= recTyp, 21);
		ASSERT(i.desc.mod.refcnt >= 0, 24);
		mod := i.desc.mod.name$;
		Kernel.GetTypeName(i.desc, n);
		type := n$
	END GetTypeName;

	PROCEDURE (VAR i: Item) BaseTyp* (): INTEGER, NEW;
	BEGIN
		IF i.ext # NIL THEN RETURN i.ext.BaseTyp() END;
		ASSERT(i.ptr # NIL, 20);
		ASSERT(i.typ IN {arrTyp, recTyp, ptrTyp}, 21);
		RETURN TypOf(i.desc.base[0])
	END BaseTyp;

	PROCEDURE (VAR i: Item) Level* (): INTEGER, NEW;
	BEGIN
		ASSERT(i.ext = NIL, 31);
		ASSERT(i.ptr # NIL, 20);
		ASSERT(i.typ IN {recTyp, arrTyp}, 21);
		RETURN SHORT(SHORT(i.desc.id DIV 16 MOD 16))
	END Level;

	PROCEDURE (VAR i: Item) Attribute* (): INTEGER, NEW;
	BEGIN
		ASSERT(i.ext = NIL, 31);
		ASSERT(i.ptr # NIL, 20);
		ASSERT(i.typ = recTyp, 21);
		RETURN SHORT(SHORT(i.desc.id DIV 4 MOD 4))
	END Attribute;

	PROCEDURE (VAR i: Item) Size* (): INTEGER, NEW;
	BEGIN
		IF i.ext # NIL THEN RETURN i.ext.Size() END;
		ASSERT(i.ptr # NIL, 20);
		ASSERT(i.typ # undef, 21);
		RETURN SizeOf(i)
	END Size;
	
	PROCEDURE (VAR arr: Item) Len* (): INTEGER, NEW;
	BEGIN
		IF arr.ext # NIL THEN RETURN arr.ext.Len() END;
		ASSERT(arr.ptr # NIL, 20);
		ASSERT(arr.typ = arrTyp, 21);
		RETURN LenOf(arr)
	END Len;
	
	(* ---------- Item generation ---------- *)

	PROCEDURE SetUndef (VAR i: Item);
	BEGIN
		i.typ := undef; i.obj := undef; i.vis := undef;
		i.adr := undef; i.mod := NIL; i.desc := NIL; i.ptr := NIL; i.ext := NIL
	END SetUndef;
	
	PROCEDURE SetItem (VAR i: Item; obj: Kernel.Object; mod: Kernel.Module);
		VAR t: Kernel.Type;
	BEGIN
		i.obj := SHORT(SHORT(obj.id MOD 16));
		i.vis := SHORT(SHORT(obj.id DIV 16 MOD 16));
		IF i.obj = procObj THEN
			i.typ := undef; i.desc := SYSTEM.VAL(Kernel.Type, obj.fprint);
			i.adr := mod.procBase + obj.offs; i.mod := mod
		ELSE
			i.typ := TypOf(obj.struct); i.desc := obj.struct;
			IF i.obj = varObj THEN i.adr := mod.varBase + obj.offs; i.mod := mod
			ELSIF i.obj = fieldObj THEN i.adr := obj.offs; i.mod := NIL
			ELSE i.adr := undef; i.mod := NIL
			END
		END;
		i.ext := NIL
	END SetItem;
	
	PROCEDURE SetMod (VAR i: Item; mod: Kernel.Module);
	BEGIN
		i.obj := modObj; i.typ := undef; i.vis := undef;
		i.adr := undef; i.mod := mod; i.desc := NIL; i.ptr := dummy; i.ext := NIL
	END SetMod;


	PROCEDURE GetItem* (obj: ANYPTR; OUT i: Item);
	BEGIN
		ASSERT(obj # NIL, 28);
		i.obj := varObj; i.typ := recTyp; i.vis := exported;
		i.adr := SYSTEM.ADR(obj^); i.ptr := SYSTEM.VAL(ArrayPtr, obj);
		i.mod := NIL; i.desc := Kernel.TypeOf(obj); i.ext := NIL
	END GetItem;

	PROCEDURE Lookup* (IN name: ARRAY OF CHAR; OUT mod: Item);
		VAR m: Kernel.Module; done: BOOLEAN; filter: FilterHook;
	BEGIN
		done := FALSE; filter := filterHook;
		WHILE ~done & (filter # NIL) DO filter.filter(name, mod, done); filter := filter.next END;
		IF ~done & LegalName(name) THEN
			m := Kernel.ThisMod(name);
			IF m # NIL THEN SetMod(mod, m)
			ELSE SetUndef(mod)
			END
		ELSE SetUndef(mod)
		END
	END Lookup;

	PROCEDURE (VAR in: Item) Lookup* (IN name: ARRAY OF CHAR; VAR i: Item), NEW;
		VAR obj: Kernel.Object; o, v, lev, j, a: INTEGER; m: Kernel.Module; n: Kernel.Name;
	BEGIN
		IF in.ext # NIL THEN in.ext.Lookup(name, i); RETURN END;
		ASSERT(in.ptr # NIL, 20);
		IF LegalName(name) THEN
			IF in.obj = modObj THEN
				n := SHORT(name$);
				obj := Kernel.ThisObject(in.mod, n);
				IF obj # NIL THEN
					SetItem(i, obj, in.mod); i.ptr := dummy;
					IF (i.vis = hidden) OR (i.obj < typObj) THEN SetUndef(i) END
				ELSE SetUndef(i)
				END	
			ELSIF in.typ = recTyp THEN
				ASSERT(in.desc.mod.refcnt >= 0, 24);
				lev := in.desc.id DIV 16 MOD 16; j := 0;
				n := SHORT(name$);
				REPEAT
					obj := Kernel.ThisField(in.desc.base[j], n); INC(j)
				UNTIL (obj # NIL) OR (j > lev);
				IF obj # NIL THEN
					o := in.obj; a := in.adr; v := in.vis; m := in.mod;
					SetItem(i, obj, m); i.ptr := in.ptr;
					IF i.vis # hidden THEN
						IF o = varObj THEN
							i.obj := varObj; INC(i.adr, a); i.mod := m;
							IF v < i.vis THEN i.vis := v END
						END
					ELSE SetUndef(i)
					END
				ELSE SetUndef(i)
				END
			ELSE HALT(21)
			END
		ELSE SetUndef(i)
		END
	END Lookup;
	
	PROCEDURE (VAR i: Item) GetBaseType* (VAR base: Item), NEW;
		VAR n: INTEGER;
	BEGIN
		ASSERT(i.ext = NIL, 31);
		ASSERT(i.ptr # NIL, 20);
		ASSERT(i.typ IN {arrTyp, recTyp, ptrTyp}, 21); n := 0;
		IF i.typ = recTyp THEN n := i.desc.id DIV 16 MOD 16 - 1 END;
		IF n >= 0 THEN
			base.obj := typObj; base.vis := undef; base.adr := undef;
			base.mod := NIL; base.ptr := dummy; base.ext := NIL;
			base.desc := i.desc.base[n];
			base.typ := TypOf(base.desc)
		ELSE
			SetUndef(base)
		END
	END GetBaseType;

	PROCEDURE (VAR rec: Item) GetThisBaseType* (level: INTEGER; VAR base: Item), NEW;
	BEGIN
		ASSERT(rec.ext = NIL, 31);
		ASSERT(rec.ptr # NIL, 20);
		ASSERT(rec.typ = recTyp, 21);
		ASSERT((level >= 0) & (level < 16), 28);
		IF level <= rec.desc.id DIV 16 MOD 16 THEN
			base.obj := typObj; base.vis := undef; base.adr := undef;
			base.mod := NIL; base.ptr := dummy; base.ext := NIL;
			base.desc := rec.desc.base[level];
			base.typ := TypOf(base.desc)
		ELSE
			SetUndef(base)
		END
	END GetThisBaseType;
	
	PROCEDURE (VAR rec: Item) Is* (IN type: Value): BOOLEAN, NEW;
		VAR d: Kernel.Type;
	BEGIN
		ASSERT(rec.ext = NIL, 31);
		ASSERT(rec.ptr # NIL, 20);
		ASSERT(rec.typ = recTyp, 21);
		WITH type: Item DO
			ASSERT(type.ptr # NIL, 20);
			ASSERT(type.typ = recTyp, 21);
			d := type.desc
		ELSE
			d := DescOf(type);	(* type of value rec *)
			ASSERT(d.id DIV 16 MOD 16 = 1, 25);	(* level of type = 1*)
			ASSERT(d.fields.num = 1, 26);	(* one field in type *)
			d := d.fields.obj[0].struct;	(* type of field *)
			ASSERT(SYSTEM.VAL(INTEGER, d) DIV 256 # 0, 21);	(* type is structured *)
			IF d.id MOD 4 = 3 THEN d := d.base[0] END	(* deref ptr *)
		END;
		RETURN rec.desc.base[d.id DIV 16 MOD 16] = d	(* rec IS d *)
	END Is;

	PROCEDURE (VAR ptr: Item) Deref* (VAR ref: Item), NEW;
	BEGIN
		IF ptr.ext # NIL THEN ptr.ext.Deref(ref); RETURN END;
		ASSERT(ptr.ptr # NIL, 20);
		ASSERT(ptr.typ IN {sysPtrTyp, anyPtrTyp, ptrTyp}, 21);
		ASSERT(ptr.obj = varObj, 22);
		ASSERT((ptr.mod = NIL) OR (ptr.mod.refcnt >= 0), 23);
		SYSTEM.GET(ptr.adr, ref.adr);
		IF ref.adr # 0 THEN
			IF ptr.typ # ptrTyp THEN ref.typ := recTyp
			ELSE ref.desc := ptr.desc.base[0]; ref.typ := TypOf(ref.desc)
			END;
			ref.obj := varObj; ref.mod := NIL; ref.vis := exported;	(* !!! *)
			ref.ptr := SYSTEM.VAL(ArrayPtr, ref.adr);
			IF ref.typ = recTyp THEN
				ref.desc := DescOf(ref.ptr^);	(* dynamic type *)
			ELSIF ref.typ = arrTyp THEN
				ref.adr := SYSTEM.ADR(ref.ptr.len[ref.desc.id DIV 16 MOD 16]);	(* descriptor offset *)
			ELSE HALT(100)
			END
		ELSE SetUndef(ref)
		END
	END Deref;
	
	PROCEDURE (VAR arr: Item) Index* (index: INTEGER; VAR elem: Item), NEW;
	BEGIN
		IF arr.ext # NIL THEN arr.ext.Index(index, elem); RETURN END;
		ASSERT(arr.ptr # NIL, 20);
		ASSERT(arr.typ = arrTyp, 21);
		ASSERT(arr.obj = varObj, 22);
		IF (index >= 0) & (index < LenOf(arr)) THEN
			elem.obj := varObj; elem.vis := arr.vis;
			elem.mod := arr.mod; elem.ptr := arr.ptr; elem.ext := NIL;
			elem.desc := arr.desc.base[0]; elem.typ := TypOf(elem.desc);
			elem.adr := arr.adr + index * SizeOf(elem)
		ELSE
			SetUndef(elem)
		END
	END Index;
	
	PROCEDURE LookupPath* (IN path: ARRAY OF CHAR; OUT i: Item);
		VAR j, n: INTEGER; name: Name; ch: CHAR; done: BOOLEAN; filter: FilterHook;
	BEGIN
		done := FALSE; filter := filterHook;
		WHILE ~done & (filter # NIL) DO filter.filter(path, i, done); filter := filter.next END;
		IF ~done THEN
			j := 0;
			GetName(path, name, j);
			Lookup(name, i);
			IF (i.obj = modObj) & (path[j] = ".") THEN
				INC(j); GetName(path, name, j);
				i.Lookup(name, i); ch := path[j]; INC(j);
				WHILE (i.obj = varObj) & (ch # 0X) DO
					IF i.typ = ptrTyp THEN i.Deref(i) END;
					IF ch = "." THEN
						GetName(path, name, j);
						IF i.typ = recTyp THEN i.Lookup(name, i) ELSE SetUndef(i) END
					ELSIF ch = "[" THEN
						n := 0; ch := path[j]; INC(j);
						WHILE (ch >= "0") & (ch <= "9") DO n := 10 * n + ORD(ch) - ORD("0"); ch := path[j]; INC(j) END;
						IF (ch = "]") & (i.typ = arrTyp) THEN i.Index(n, i) ELSE SetUndef(i) END
					END;
					ch := path[j]; INC(j)
				END
			END
		END
	END LookupPath;

	(* ---------- Scanner ---------- *)

	PROCEDURE (VAR s: Scanner) ConnectToMods*, NEW;
	BEGIN
		SetUndef(s.this);
		s.this.ptr := dummy;
		s.mod := Kernel.modList;
		s.mode := modScan;
		s.eos := FALSE
	END ConnectToMods;

	PROCEDURE (VAR s: Scanner) ConnectTo* (IN obj: Item), NEW;
	BEGIN
		ASSERT(obj.ptr # NIL, 20);
		SetUndef(s.this); s.vis := obj.vis;
		s.this.ptr := obj.ptr; s.mod := obj.mod; s.idx := 0;
		IF obj.obj = modObj THEN
			ASSERT(s.mod.refcnt >= 0, 23);
			s.mode := globScan
		ELSIF obj.typ = recTyp THEN
			ASSERT(obj.desc.mod.refcnt >= 0, 24);
			s.desc := obj.desc; s.base := 0;
			IF obj.obj = varObj THEN s.mode := recVarScan; s.adr := obj.adr
			ELSE s.mode := recTypeScan
			END
		ELSE HALT(21)
		END;
		s.eos := FALSE
	END ConnectTo;

	PROCEDURE (VAR s: Scanner) Scan*, NEW;
		VAR desc: Kernel.Type;
	BEGIN
		ASSERT(s.this.ptr # NIL, 20);
		IF s.mode = modScan THEN
			IF s.mod # NIL THEN 
				SetMod(s.this, s.mod); s.mod := s.mod.next;
			ELSE SetUndef(s.this); s.eos := TRUE
			END
		ELSIF s.mode = globScan THEN
			ASSERT(s.mod.refcnt >= 0, 23);
			REPEAT
				IF s.idx >= s.mod.export.num THEN SetUndef(s.this); s.eos := TRUE; RETURN END;
				s.obj := SYSTEM.VAL(Kernel.Object, SYSTEM.ADR(s.mod.export.obj[s.idx]));
				SetItem(s.this, s.obj, s.mod); INC(s.idx)
			UNTIL (s.this.obj IN {procObj, varObj, typObj}) & (s.this.vis # hidden)
		ELSE
			ASSERT(s.desc.mod.refcnt >= 0, 24);
			desc := s.desc.base[s.base];
			REPEAT
				WHILE s.idx >= desc.fields.num DO
					IF desc = s.desc THEN SetUndef(s.this); s.eos := TRUE; RETURN END;
					INC(s.base); desc := s.desc.base[s.base]; s.idx := 0
				END;
				s.obj := SYSTEM.VAL(Kernel.Object, SYSTEM.ADR(desc.fields.obj[s.idx]));
				SetItem(s.this, s.obj, s.mod); INC(s.idx)
			UNTIL s.this.vis # hidden;
			IF s.mode = recVarScan THEN
				s.this.obj := varObj; INC(s.this.adr, s.adr); s.this.mod := s.mod; 
				IF s.vis < s.this.vis THEN s.this.vis := s.vis END
			END
		END
	END Scan;

	PROCEDURE (VAR s: Scanner) GetObjName* (OUT name: Name), NEW;
		VAR mod: Kernel.Module; n: Kernel.Name;
	BEGIN
		ASSERT(s.this.ptr # NIL, 20);
		IF s.mode = modScan THEN
			name := s.this.mod.name$	(* mf 24.08.2004 *)
		ELSE
			IF s.mode = globScan THEN mod := s.mod
			ELSE mod := s.desc.base[s.base].mod
			END;
			ASSERT(mod.refcnt >= 0, 23);
			Kernel.GetObjName(mod, s.obj, n);
			name := n$;
		END
	END GetObjName;
	
	PROCEDURE (VAR s: Scanner) Level* (): INTEGER, NEW;
	BEGIN
		ASSERT(s.this.ptr # NIL, 20);
		ASSERT(s.mode >= recVarScan, 22);
		RETURN s.base
	END Level;

	(* ---------- access to item values ---------- *)

	PROCEDURE (VAR proc: Item) Call* (OUT ok: BOOLEAN), NEW;
		VAR p: Kernel.Command; sig: INTEGER;
	BEGIN
		IF proc.ext # NIL THEN proc.ext.Call(ok); RETURN END;
		ASSERT(proc.ptr # NIL, 20);
		IF proc.obj = procObj THEN
			p := SYSTEM.VAL(Kernel.Command, proc.adr); sig := SYSTEM.VAL(INTEGER, proc.desc)
		ELSE ASSERT((proc.obj = varObj) & (proc.typ = procTyp), 22);
			SYSTEM.GET(proc.adr, p); sig := proc.desc.size
		END;
		IF (sig = Kernel.comSig) & (p # NIL) THEN p(); ok := TRUE
		ELSE ok := FALSE
		END
	END Call;
	
	PROCEDURE ValToItem (IN x: Value; VAR i: Item);
		VAR desc: Kernel.Type;
	BEGIN
		desc := DescOf(x);
		ASSERT(desc.id DIV 16 MOD 16 = 1, 25);	(* level of x = 1*)
		ASSERT(desc.fields.num = 1, 26);	(* one field in x *)
		i.desc := desc.fields.obj[0].struct;
		i.typ := TypOf(i.desc); i.obj := varObj; i.ext := NIL;
		i.ptr := dummy; i.adr := SYSTEM.ADR(x)
	END ValToItem;
	
	PROCEDURE Copy (IN a, b: Item; OUT ok: BOOLEAN);	(* b := a *)
		VAR n: INTEGER; at, bt: Item;
	BEGIN
		ok := FALSE;
		IF a.obj = procObj THEN
			IF (b.typ # procTyp) OR (b.desc.size # SYSTEM.VAL(INTEGER, a.desc)) THEN RETURN END;
			SYSTEM.PUT(b.adr, a.adr);
		ELSE	(* a.obj = varObj *)
			IF a.typ # b.typ THEN RETURN END;
			IF a.typ >= recTyp THEN
				IF a.typ = ptrTyp THEN
					at.desc := a.desc.base[0]; at.typ := TypOf(at.desc); at.ptr := dummy; at.ext := NIL;
					bt.desc := b.desc.base[0]; bt.typ := TypOf(bt.desc); bt.ptr := dummy; bt.ext := NIL;
					SYSTEM.GET(a.adr, n);
					IF (at.typ = recTyp) & (n # 0) THEN
						SYSTEM.GET(SYSTEM.VAL(INTEGER, n) - 4, at.desc);	(* dynamic type *)
						at.desc :=  at.desc.base[bt.desc.id DIV 16 MOD 16]	(* projection to b *)
					END
				ELSE at := a; bt := b
				END;
				WHILE (at.typ = arrTyp) & (bt.typ = arrTyp) DO
					IF LenOf(at) # LenOf(bt) THEN RETURN END;
					at.desc := at.desc.base[0]; at.typ := TypOf(at.desc);
					bt.desc := bt.desc.base[0]; bt.typ := TypOf(bt.desc)
				END;
				IF (at.desc # bt.desc) &
					~((at.typ = procTyp) & (bt.typ = procTyp) & (at.desc.size = bt.desc.size)) THEN RETURN END
			END;
			SYSTEM.MOVE(a.adr, b.adr, SizeOf(b))
		END;
		ok := TRUE
	END Copy;
	
	PROCEDURE (VAR var: Item) GetVal* (VAR x: Value; OUT ok: BOOLEAN), NEW;
		VAR xi: Item;
	BEGIN
		ASSERT(var.ext = NIL, 31);
		ASSERT(var.ptr # NIL, 20);
		ASSERT(var.obj IN {varObj, procObj}, 22);
		ASSERT((var.mod = NIL) OR (var.mod.refcnt >= 0), 23);
		WITH x: Item DO
			ASSERT(x.ptr # NIL, 20);
			ASSERT(x.obj = varObj, 22);
			ASSERT((x.mod = NIL) OR (x.mod.refcnt >= 0), 23);
			ASSERT(x.vis = exported, 27);
			Copy(var, x, ok)
		ELSE
			ValToItem(x, xi); Copy(var, xi, ok)
		END
	END GetVal;

	PROCEDURE (VAR var: Item) PutVal* (IN x: Value; OUT ok: BOOLEAN), NEW;
		VAR xi: Item;
	BEGIN
		ASSERT(var.ext = NIL, 31);
		ASSERT(var.ptr # NIL, 20);
		ASSERT(var.obj = varObj, 22);
		ASSERT((var.mod = NIL) OR (var.mod.refcnt >= 0), 23);
		ASSERT(var.vis = exported, 27);
		WITH x: Item DO
			ASSERT(x.ptr # NIL, 20);
			ASSERT(x.obj IN {varObj, procObj}, 22);
			ASSERT((x.mod = NIL) OR (x.mod.refcnt >= 0), 23);
			Copy(x, var, ok)
		ELSE
			ValToItem(x, xi); Copy(xi, var, ok)
		END
	END PutVal;

	PROCEDURE (VAR var: Item) GetStringVal* (OUT x: ARRAY OF CHAR; OUT ok: BOOLEAN), NEW;
		VAR i, n: INTEGER; p: StringPtr;
	BEGIN
		IF var.ext # NIL THEN var.ext.GetStringVal(x, ok); RETURN END;
		ASSERT(var.ptr # NIL, 20);
		ASSERT((var.typ = arrTyp) & (SYSTEM.VAL(INTEGER, var.desc.base[0]) = charTyp), 21);
		ASSERT(var.obj = varObj, 22);
		ASSERT((var.mod = NIL) OR (var.mod.refcnt >= 0), 23);
		p := SYSTEM.VAL(StringPtr, var.adr); i := 0; n := LenOf(var);
		WHILE (i < n) & (p[i] # 0X) DO INC(i) END;
		IF (i < n) & (i < LEN(x)) THEN x := p^$; ok := TRUE
		ELSE x := ""; ok := FALSE
		END
	END GetStringVal;

	PROCEDURE (VAR var: Item) GetSStringVal* (OUT x: ARRAY OF SHORTCHAR; OUT ok: BOOLEAN), NEW;
		VAR i, n: INTEGER; p: SStringPtr;
	BEGIN
		IF var.ext # NIL THEN var.ext.GetSStringVal(x, ok); RETURN END;
		ASSERT(var.ptr # NIL, 20);
		ASSERT((var.typ = arrTyp) & (SYSTEM.VAL(INTEGER, var.desc.base[0]) = sCharTyp), 21);
		ASSERT(var.obj = varObj, 22);
		ASSERT((var.mod = NIL) OR (var.mod.refcnt >= 0), 23);
		p := SYSTEM.VAL(SStringPtr, var.adr); i := 0; n := LenOf(var);
		WHILE (i < n) & (p[i] # 0X) DO INC(i) END;
		IF (i < n) & (i < LEN(x)) THEN x := p^$; ok := TRUE
		ELSE x := ""; ok := FALSE
		END
	END GetSStringVal;

	PROCEDURE (VAR var: Item) PutStringVal* (IN x: ARRAY OF CHAR; OUT ok: BOOLEAN), NEW;
		VAR i: INTEGER; p: StringPtr;
	BEGIN
		IF var.ext # NIL THEN var.ext.PutStringVal(x, ok); RETURN END;
		ASSERT(var.ptr # NIL, 20);
		ASSERT((var.typ = arrTyp) & (SYSTEM.VAL(INTEGER, var.desc.base[0]) = charTyp), 21);
		ASSERT(var.obj = varObj, 22);
		ASSERT((var.mod = NIL) OR (var.mod.refcnt >= 0), 23);
		ASSERT(var.vis = exported, 27);
		p := SYSTEM.VAL(StringPtr, var.adr); i := 0;
		WHILE (i < LEN(x)) & (x[i] # 0X) DO INC(i) END;
		IF (i < LEN(x)) & (i < LenOf(var)) THEN p^ := x$; ok := TRUE
		ELSE ok := FALSE
		END
	END PutStringVal;

	PROCEDURE (VAR var: Item) PutSStringVal* (IN x: ARRAY OF SHORTCHAR; OUT ok: BOOLEAN), NEW;
		VAR i: INTEGER; p: SStringPtr;
	BEGIN
		IF var.ext # NIL THEN var.ext.PutSStringVal(x, ok); RETURN END;
		ASSERT(var.ptr # NIL, 20);
		ASSERT((var.typ = arrTyp) & (SYSTEM.VAL(INTEGER, var.desc.base[0]) = sCharTyp), 21);
		ASSERT(var.obj = varObj, 22);
		ASSERT((var.mod = NIL) OR (var.mod.refcnt >= 0), 23);
		ASSERT(var.vis = exported, 27);
		p := SYSTEM.VAL(SStringPtr, var.adr); i := 0;
		WHILE (i < LEN(x)) & (x[i] # 0X) DO INC(i) END;
		IF (i < LEN(x)) & (i < LenOf(var)) THEN p^ := x$; ok := TRUE
		ELSE ok := FALSE
		END
	END PutSStringVal;

	PROCEDURE  (VAR var: Item) PtrVal* (): ANYPTR, NEW;
		VAR p: ANYPTR;
	BEGIN
		IF var.ext # NIL THEN RETURN var.ext.PtrVal() END;
		ASSERT(var.ptr # NIL, 20);
		ASSERT(var.typ IN {anyPtrTyp, ptrTyp}, 21);
		ASSERT(var.obj = varObj, 22);
		ASSERT((var.mod = NIL) OR (var.mod.refcnt >= 0), 23);
		SYSTEM.GET(var.adr, p);
		RETURN p
	END PtrVal;

	PROCEDURE (VAR var: Item) PutPtrVal* (x: ANYPTR), NEW;
		VAR vt, xt: Kernel.Type;
	BEGIN
		IF var.ext # NIL THEN var.ext.PutPtrVal(x); RETURN END;
		ASSERT(var.ptr # NIL, 20);
		ASSERT(var.typ IN {anyPtrTyp, ptrTyp}, 21);
		ASSERT(var.obj = varObj, 22);
		ASSERT((var.mod = NIL) OR (var.mod.refcnt >= 0), 23);
		ASSERT(var.vis = exported, 27);
		IF (x # NIL) & (var.typ = ptrTyp) THEN
			vt := var.desc.base[0]; xt := Kernel.TypeOf(x);
			ASSERT(xt.base[vt.id DIV 16 MOD 16] = vt, 28);	(* xt IS vt *)
		END;
		SYSTEM.PUT(var.adr, x)
	END PutPtrVal;

	PROCEDURE (VAR var: Item) IntVal* (): INTEGER, NEW;
		VAR sc: SHORTCHAR; ch: CHAR; s: BYTE; i: SHORTINT; x: INTEGER;
	BEGIN
		IF var.ext # NIL THEN RETURN var.ext.IntVal() END;
		ASSERT(var.ptr # NIL, 20);
		ASSERT(var.obj = varObj, 22);
		ASSERT((var.mod = NIL) OR (var.mod.refcnt >= 0), 23);
		IF var.typ = sCharTyp THEN SYSTEM.GET(var.adr, sc); x := ORD(sc)
		ELSIF var.typ = charTyp THEN SYSTEM.GET(var.adr, ch); x := ORD(ch)
		ELSIF var.typ = byteTyp THEN SYSTEM.GET(var.adr, s); x := s
		ELSIF var.typ = sIntTyp THEN SYSTEM.GET(var.adr, i); x := i
		ELSIF var.typ = intTyp THEN SYSTEM.GET(var.adr, x)
		ELSE HALT(21)
		END;
		RETURN x
	END IntVal;

	PROCEDURE (VAR var: Item) PutIntVal* (x: INTEGER), NEW;
	BEGIN
		IF var.ext # NIL THEN var.ext.PutIntVal(x); RETURN END;
		ASSERT(var.ptr # NIL, 20);
		ASSERT(var.obj = varObj, 22);
		ASSERT((var.mod = NIL) OR (var.mod.refcnt >= 0), 23);
		ASSERT(var.vis = exported, 27);
		IF var.typ = sCharTyp THEN SYSTEM.PUT(var.adr, SHORT(CHR(x)))
		ELSIF var.typ = charTyp THEN SYSTEM.PUT(var.adr, CHR(x))
		ELSIF var.typ = byteTyp THEN SYSTEM.PUT(var.adr, SHORT(SHORT(x)))
		ELSIF var.typ = sIntTyp THEN SYSTEM.PUT(var.adr, SHORT(x))
		ELSIF var.typ = intTyp THEN SYSTEM.PUT(var.adr, x)
		ELSE HALT(21)
		END
	END PutIntVal;

	PROCEDURE (VAR var: Item) RealVal* (): REAL, NEW;
		VAR r: SHORTREAL; x: REAL;
	BEGIN
		IF var.ext # NIL THEN RETURN var.ext.RealVal() END;
		ASSERT(var.ptr # NIL, 20);
		ASSERT(var.obj = varObj, 22);
		ASSERT((var.mod = NIL) OR (var.mod.refcnt >= 0), 23);
		IF var.typ = sRealTyp THEN SYSTEM.GET(var.adr, r); x := r
		ELSIF var.typ = realTyp THEN SYSTEM.GET(var.adr, x)
		ELSE HALT(21)
		END;
		RETURN x
	END RealVal;

	PROCEDURE (VAR var: Item) PutRealVal* (x: REAL), NEW;
	BEGIN
		IF var.ext # NIL THEN var.ext.PutRealVal(x); RETURN END;
		ASSERT(var.ptr # NIL, 20);
		ASSERT(var.obj = varObj, 22);
		ASSERT((var.mod = NIL) OR (var.mod.refcnt >= 0), 23);
		ASSERT(var.vis = exported, 27);
		IF var.typ = sRealTyp THEN SYSTEM.PUT(var.adr, SHORT(x))
		ELSIF var.typ = realTyp THEN SYSTEM.PUT(var.adr, x)
		ELSE HALT(21)
		END
	END PutRealVal;

	PROCEDURE (VAR var: Item) LongVal* (): LONGINT, NEW;
		VAR x: LONGINT;
	BEGIN
		IF var.ext # NIL THEN RETURN var.ext.LongVal() END;
		ASSERT(var.ptr # NIL, 20);
		ASSERT(var.typ = longTyp, 21);
		ASSERT(var.obj = varObj, 22);
		ASSERT((var.mod = NIL) OR (var.mod.refcnt >= 0), 23);
		SYSTEM.GET(var.adr, x);
		RETURN x
	END LongVal;

	PROCEDURE (VAR var: Item) PutLongVal* (x: LONGINT), NEW;
	BEGIN
		IF var.ext # NIL THEN var.ext.PutLongVal(x); RETURN END;
		ASSERT(var.ptr # NIL, 20);
		ASSERT(var.typ = longTyp, 21);
		ASSERT(var.obj = varObj, 22);
		ASSERT((var.mod = NIL) OR (var.mod.refcnt >= 0), 23);
		ASSERT(var.vis = exported, 27);
		SYSTEM.PUT(var.adr, x)
	END PutLongVal;

	PROCEDURE (VAR var: Item) CharVal* (): CHAR, NEW;
		VAR x: CHAR; s: SHORTCHAR;
	BEGIN
		IF var.ext # NIL THEN RETURN var.ext.CharVal() END;
		ASSERT(var.ptr # NIL, 20);
		ASSERT(var.obj = varObj, 22);
		ASSERT((var.mod = NIL) OR (var.mod.refcnt >= 0), 23);
		IF var.typ = sCharTyp THEN SYSTEM.GET(var.adr, s); x := s
		ELSIF var.typ = charTyp THEN SYSTEM.GET(var.adr, x)
		ELSE HALT(21)
		END;
		RETURN x
	END CharVal;

	PROCEDURE (VAR var: Item) PutCharVal* (x: CHAR), NEW;
	BEGIN
		IF var.ext # NIL THEN var.ext.PutCharVal(x); RETURN END;
		ASSERT(var.ptr # NIL, 20);
		ASSERT(var.obj = varObj, 22);
		ASSERT((var.mod = NIL) OR (var.mod.refcnt >= 0), 23);
		ASSERT(var.vis = exported, 27);
		IF var.typ = sCharTyp THEN SYSTEM.PUT(var.adr, SHORT(x))
		ELSIF var.typ = charTyp THEN SYSTEM.PUT(var.adr, x)
		ELSE HALT(21)
		END
	END PutCharVal;

	PROCEDURE (VAR var: Item) BoolVal* (): BOOLEAN, NEW;
		VAR x: BOOLEAN;
	BEGIN
		IF var.ext # NIL THEN RETURN var.ext.BoolVal() END;
		ASSERT(var.ptr # NIL, 20);
		ASSERT(var.typ = boolTyp, 21);
		ASSERT(var.obj = varObj, 22);
		ASSERT((var.mod = NIL) OR (var.mod.refcnt >= 0), 23);
		SYSTEM.GET(var.adr, x);
		RETURN x
	END BoolVal;

	PROCEDURE (VAR var: Item) PutBoolVal* (x: BOOLEAN), NEW;
	BEGIN
		IF var.ext # NIL THEN var.ext.PutBoolVal(x); RETURN END;
		ASSERT(var.ptr # NIL, 20);
		ASSERT(var.typ = boolTyp, 21);
		ASSERT(var.obj = varObj, 22);
		ASSERT((var.mod = NIL) OR (var.mod.refcnt >= 0), 23);
		ASSERT(var.vis = exported, 27);
		SYSTEM.PUT(var.adr, x)
	END PutBoolVal;

	PROCEDURE (VAR var: Item) SetVal* (): SET, NEW;
		VAR x: SET;
	BEGIN
		IF var.ext # NIL THEN RETURN var.ext.SetVal() END;
		ASSERT(var.ptr # NIL, 20);
		ASSERT(var.typ = setTyp, 21);
		ASSERT(var.obj = varObj, 22);
		ASSERT((var.mod = NIL) OR (var.mod.refcnt >= 0), 23);
		SYSTEM.GET(var.adr, x);
		RETURN x
	END SetVal;

	PROCEDURE (VAR var: Item) PutSetVal* (x: SET), NEW;
	BEGIN
		IF var.ext # NIL THEN var.ext.PutSetVal(x); RETURN END;
		ASSERT(var.ptr # NIL, 20);
		ASSERT(var.typ = setTyp, 21);
		ASSERT(var.obj = varObj, 22);
		ASSERT((var.mod = NIL) OR (var.mod.refcnt >= 0), 23);
		ASSERT(var.vis = exported, 27);
		SYSTEM.PUT(var.adr, x)
	END PutSetVal;

	PROCEDURE (VAR  type: Item) New* (): ANYPTR, NEW;
		VAR p: ANYPTR; i, n, id: INTEGER; d: Kernel.Directory; desc: Kernel.Type;
	BEGIN
		ASSERT(type.ext = NIL, 31);
		ASSERT(type.ptr # NIL, 20);
		desc := type.desc;
		IF type.typ = ptrTyp THEN desc := desc.base[0] END;
		ASSERT(TypOf(desc) = recTyp, 21);
		ASSERT(desc.mod.refcnt >= 0, 24);
		i := 0; d := type.desc.mod.export; n := d.num; id := type.desc.id DIV 256;
		WHILE (i < n) & (d.obj[i].id DIV 256 # id) DO INC(i) END;
		ASSERT((i < n) & (d.obj[i].id DIV 16 MOD 16 = exported), 29);
		ASSERT(desc.id DIV 4 MOD 4 < limited, 30);
		Kernel.NewObj(p, desc);
		RETURN p
	END New;

	PROCEDURE (VAR  val: Item) Copy* (): ANYPTR, NEW;
		VAR p: ANYPTR; i, n, id: INTEGER; d: Kernel.Directory;
	BEGIN
		ASSERT(val.ext = NIL, 31);
		ASSERT(val.ptr # NIL, 20);
		ASSERT(val.typ = recTyp, 21);
		ASSERT(val.obj = varObj, 22);
		ASSERT(val.desc.mod.refcnt >= 0, 24);
		i := 0; d := val.desc.mod.export; n := d.num; id := val.desc.id DIV 256;
		WHILE (i < n) & (d.obj[i].id DIV 256 # id) DO INC(i) END;
		ASSERT((i < n) & (d.obj[i].id DIV 16 MOD 16 = exported), 29);
		ASSERT(val.desc.id DIV 4 MOD 4 < limited, 30);
		Kernel.NewObj(p, val.desc);
		SYSTEM.MOVE(val.adr, p, val.desc.size);
		RETURN p
	END Copy;

	PROCEDURE (VAR rec: Item) CallWith* (proc: PROCEDURE(VAR rec, par: ANYREC); VAR par: ANYREC), NEW;
	BEGIN
		ASSERT(rec.ext = NIL, 31);
		ASSERT(rec.ptr # NIL, 20);
		ASSERT(rec.typ = recTyp, 21);
		ASSERT(rec.obj = varObj, 22);
		ASSERT((rec.mod = NIL) OR (rec.mod.refcnt >= 0), 23);
		proc(SYSTEM.THISRECORD(rec.adr, SYSTEM.VAL(INTEGER, rec.desc)), par)
	END CallWith;


	PROCEDURE InstallFilter* (filter: LookupFilter);
		VAR h: FilterHook;
	BEGIN
		ASSERT(filter # NIL, 20);
		NEW(h); h.filter := filter; h.next := filterHook; filterHook := h
	END InstallFilter;

	PROCEDURE UninstallFilter* (filter: LookupFilter);
		VAR h, a: FilterHook;
	BEGIN
		ASSERT(filter # NIL, 20);
		h := filterHook; a := NIL;
		WHILE (h # NIL) & (h.filter # filter) DO a := h; h := h.next END;
		IF h # NIL THEN
			IF a = NIL THEN filterHook := h.next ELSE a.next := h.next END
		END
	END UninstallFilter;

	PROCEDURE GetThisItem* (IN attr: ANYREC; OUT i: Item);
	BEGIN
		WITH attr: Kernel.ItemAttr DO
			i.obj := attr.obj; i.vis := attr.vis; i.typ := attr.typ; i.adr := attr.adr;
			i.mod := attr.mod; i.desc := attr.desc; i.ptr := attr.ptr; i.ext := attr.ext;
			IF i.ptr = NIL THEN i.ptr := dummy END
		END
	END GetThisItem;

BEGIN
	NEW(dummy)
END Meta.