dev0 now based on PackedFiles instead of Dev0

BlackBox/Cons/Mod/Interp.txt

@@ -115,7 +115,7 @@ MODULE ConsInterp;
 	END Call;
 
 	PROCEDURE Run*;
-		VAR s: ARRAY 1024 OF CHAR;
+		VAR s: ARRAY 2048 OF CHAR;
 	BEGIN
 		Console.ReadLn(s);
 		WHILE Call(s) DO

BlackBox/Dev/Mod/CPB.txt

@@ -1,2238 +0,0 @@
-MODULE DevCPB;
-
-	(* THIS IS TEXT COPY OF BlackBox 1.6-rc6 Dev/Mod/CPB.odc *)
-	(* DO NOT EDIT *)
-
-	IMPORT DevCPT, DevCPM;
-
-	CONST
-		(* symbol values or ops *)
-		times = 1; slash = 2; div = 3; mod = 4;
-		and = 5; plus = 6; minus = 7; or = 8; eql = 9;
-		neq = 10; lss = 11; leq = 12; gtr = 13; geq = 14;
-		in = 15; is = 16; ash = 17; msk = 18; len = 19;
-		conv = 20; abs = 21; cap = 22; odd = 23; not = 33;
-		(*SYSTEM*)
-		adr = 24; cc = 25; bit = 26; lsh = 27; rot = 28; val = 29;
-		min = 34; max = 35; typfn = 36; size = 37;
-		
-		(* object modes *)
-		Var = 1; VarPar = 2; Con = 3; Fld = 4; Typ = 5; LProc = 6; XProc = 7;
-		SProc = 8; CProc = 9; IProc = 10; Mod = 11; Head = 12; TProc = 13;
-
-		(* Structure forms *)
-		Undef = 0; Byte = 1; Bool = 2; Char8 = 3; Int8 = 4; Int16 = 5; Int32 = 6;
-		Real32 = 7; Real64 = 8; Set = 9; String8 = 10; NilTyp = 11; NoTyp = 12;
-		Pointer = 13; ProcTyp = 14; Comp = 15;
-		Char16 = 16; String16 = 17; Int64 = 18;
-		intSet = {Int8..Int32, Int64}; realSet = {Real32, Real64}; charSet = {Char8, Char16};
-
-		(* composite structure forms *)
-		Basic = 1; Array = 2; DynArr = 3; Record = 4;
-
-		(* nodes classes *)
-		Nvar = 0; Nvarpar = 1; Nfield = 2; Nderef = 3; Nindex = 4; Nguard = 5; Neguard = 6;
-		Nconst = 7; Ntype = 8; Nproc = 9; Nupto = 10; Nmop = 11; Ndop = 12; Ncall = 13;
-		Ninittd = 14; Nif = 15; Ncaselse = 16; Ncasedo = 17; Nenter = 18; Nassign = 19;
-		Nifelse = 20; Ncase = 21; Nwhile = 22; Nrepeat = 23; Nloop = 24; Nexit = 25;
-		Nreturn = 26; Nwith = 27; Ntrap = 28;
-
-		(*function number*)
-		assign = 0;
-		haltfn = 0; newfn = 1; absfn = 2; capfn = 3; ordfn = 4;
-		entierfn = 5; oddfn = 6; minfn = 7; maxfn = 8; chrfn = 9;
-		shortfn = 10; longfn = 11; sizefn = 12; incfn = 13; decfn = 14;
-		inclfn = 15; exclfn = 16; lenfn = 17; copyfn = 18; ashfn = 19; assertfn = 32;
-		lchrfn = 33; lentierfcn = 34; bitsfn = 37; bytesfn = 38;
-		
-		(*SYSTEM function number*)
-		adrfn = 20; ccfn = 21; lshfn = 22; rotfn = 23;
-		getfn = 24; putfn = 25; getrfn = 26; putrfn = 27;
-		bitfn = 28; valfn = 29; sysnewfn = 30; movefn = 31;
-		thisrecfn = 45; thisarrfn = 46;
-
-		(* COM function number *)
-		validfn = 40; iidfn = 41; queryfn = 42;
-		
-		(* module visibility of objects *)
-		internal = 0; external = 1; externalR = 2; inPar = 3; outPar = 4;
-
-		(* procedure flags (conval.setval) *)
-		hasBody = 1; isRedef = 2; slNeeded = 3; imVar = 4;
-		
-		(* attribute flags (attr.adr, struct.attribute, proc.conval.setval)*)
-		newAttr = 16; absAttr = 17; limAttr = 18; empAttr = 19; extAttr = 20;
-		
-		(* case statement flags (conval.setval) *)
-		useTable = 1; useTree = 2;
-		
-		(* sysflags *)
-		nilBit = 1; inBit = 2; outBit = 4; newBit = 8; iidBit = 16; interface = 10; jint = -11; jstr = -13;
-
-		AssertTrap = 0;	(* default trap number *)
-
-		covarOut = FALSE;
-		
-		
-	VAR
-		typSize*: PROCEDURE(typ: DevCPT.Struct);
-		zero, one, two, dummy, quot: DevCPT.Const;
-
-	PROCEDURE err(n: SHORTINT);
-	BEGIN DevCPM.err(n)
-	END err;
-	
-	PROCEDURE NewLeaf*(obj: DevCPT.Object): DevCPT.Node;
-		VAR node: DevCPT.Node; typ: DevCPT.Struct;
-	BEGIN
-		typ := obj.typ;
-		CASE obj.mode OF
-		  Var:
-				node := DevCPT.NewNode(Nvar); node.readonly := (obj.vis = externalR) & (obj.mnolev < 0)
-		| VarPar:
-				node := DevCPT.NewNode(Nvarpar); node.readonly := obj.vis = inPar;
-		| Con:
-				node := DevCPT.NewNode(Nconst); node.conval := DevCPT.NewConst();
-				node.conval^ := obj.conval^	(* string is not copied, only its ref *)
-		| Typ:
-				node := DevCPT.NewNode(Ntype)
-		| LProc..IProc, TProc:
-				node := DevCPT.NewNode(Nproc)
-		ELSE err(127); node := DevCPT.NewNode(Nvar); typ := DevCPT.notyp
-		END ;
-		node.obj := obj; node.typ := typ;
-		RETURN node
-	END NewLeaf;
-	
-	PROCEDURE Construct*(class: BYTE; VAR x: DevCPT.Node;  y: DevCPT.Node);
-		VAR node: DevCPT.Node;
-	BEGIN
-		node := DevCPT.NewNode(class); node.typ := DevCPT.notyp;
-		node.left := x; node.right := y; x := node
-	END Construct;
-	
-	PROCEDURE Link*(VAR x, last: DevCPT.Node; y: DevCPT.Node);
-	BEGIN
-		IF x = NIL THEN x := y ELSE last.link := y END ;
-		WHILE y.link # NIL DO y := y.link END ;
-		last := y
-	END Link;
-	
-	PROCEDURE BoolToInt(b: BOOLEAN): INTEGER;
-	BEGIN
-		IF b THEN RETURN 1 ELSE RETURN 0 END
-	END BoolToInt;
-	
-	PROCEDURE IntToBool(i: INTEGER): BOOLEAN;
-	BEGIN
-		IF i = 0 THEN RETURN FALSE ELSE RETURN TRUE END
-	END IntToBool;
-	
-	PROCEDURE NewBoolConst*(boolval: BOOLEAN): DevCPT.Node;
-		VAR x: DevCPT.Node;
-	BEGIN
-		x := DevCPT.NewNode(Nconst); x.typ := DevCPT.booltyp;
-		x.conval := DevCPT.NewConst(); x.conval.intval := BoolToInt(boolval); RETURN x
-	END NewBoolConst;
-	
-	PROCEDURE OptIf*(VAR x: DevCPT.Node);	(* x.link = NIL *)
-		VAR if, pred: DevCPT.Node;
-	BEGIN
-		if := x.left;
-		WHILE if.left.class = Nconst DO
-			IF IntToBool(if.left.conval.intval) THEN x := if.right; RETURN
-			ELSIF if.link = NIL THEN x := x.right; RETURN
-			ELSE if := if.link; x.left := if
-			END
-		END ;
-		pred := if; if := if.link;
-		WHILE if # NIL DO
-			IF if.left.class = Nconst THEN
-				IF IntToBool(if.left.conval.intval) THEN
-					pred.link := NIL; x.right := if.right; RETURN
-				ELSE if := if.link; pred.link := if
-				END
-			ELSE pred := if; if := if.link
-			END
-		END
-	END OptIf;
-
-	PROCEDURE Nil*(): DevCPT.Node;
-		VAR x: DevCPT.Node;
-	BEGIN
-		x := DevCPT.NewNode(Nconst); x.typ := DevCPT.niltyp;
-		x.conval := DevCPT.NewConst(); x.conval.intval := 0; RETURN x
-	END Nil;
-
-	PROCEDURE EmptySet*(): DevCPT.Node;
-		VAR x: DevCPT.Node;
-	BEGIN
-		x := DevCPT.NewNode(Nconst); x.typ := DevCPT.settyp;
-		x.conval := DevCPT.NewConst(); x.conval.setval := {}; RETURN x
-	END EmptySet;
-	
-	PROCEDURE MarkAsUsed (node: DevCPT.Node);
-		VAR c: BYTE;
-	BEGIN
-		c := node.class;
-		WHILE (c = Nfield) OR (c = Nindex) OR (c = Nguard) OR (c = Neguard) DO node := node.left; c := node.class END;
-		IF (c = Nvar) & (node.obj.mnolev > 0) THEN node.obj.used := TRUE END
-	END MarkAsUsed;
-	
-	
-	PROCEDURE GetTempVar* (name: ARRAY OF SHORTCHAR; typ: DevCPT.Struct; VAR obj: DevCPT.Object);
-		VAR n: DevCPT.Name; o: DevCPT.Object;
-	BEGIN
-		n := "@@  "; DevCPT.Insert(n, obj); obj.name^ := name$;	(* avoid err 1 *)
-		obj.mode := Var; obj.typ := typ;
-		o := DevCPT.topScope.scope;
-		IF o = NIL THEN DevCPT.topScope.scope := obj
-		ELSE
-			WHILE o.link # NIL DO o := o.link END;
-			o.link := obj
-		END
-	END GetTempVar;
-
-
-	(* ---------- constant operations ---------- *)
-	
-	PROCEDURE Log (x: DevCPT.Node): INTEGER;
-		VAR val, exp: INTEGER;
-	BEGIN
-		exp := 0;
-		IF x.typ.form = Int64 THEN
-			RETURN -1
-		ELSE
-			val := x.conval.intval;
-			IF val > 0 THEN
-				WHILE ~ODD(val) DO val := val DIV 2; INC(exp) END
-			END;
-			IF val # 1 THEN exp := -1 END
-		END;
-		RETURN exp
-	END Log;
-
-	PROCEDURE Floor (x: REAL): REAL;
-		VAR y: REAL;
-	BEGIN
-		IF ABS(x) > 9007199254740992.0 (* 2^53 *) THEN RETURN x
-		ELSIF (x >= MAX(INTEGER) + 1.0) OR (x < MIN(INTEGER)) THEN
-			y := Floor(x / (MAX(INTEGER) + 1.0)) * (MAX(INTEGER) + 1.0);
-			RETURN SHORT(ENTIER(x - y)) + y
-		ELSE RETURN SHORT(ENTIER(x))
-		END
-	END Floor;
-
-	PROCEDURE SetToInt (s: SET): INTEGER;
-		VAR x, i: INTEGER;
-	BEGIN
-		i := 31; x := 0;
-		IF 31 IN s THEN x := -1 END;
-		WHILE i > 0 DO
-			x := x * 2; DEC(i);
-			IF i IN s THEN INC(x) END
-		END;
-		RETURN x
-	END SetToInt;
-
-	PROCEDURE IntToSet (x: INTEGER): SET;
-		VAR i: INTEGER; s: SET;
-	BEGIN
-		i := 0; s := {};
-		WHILE i < 32 DO
-			IF ODD(x) THEN INCL(s, i) END;
-			x := x DIV 2; INC(i)
-		END;
-		RETURN s
-	END IntToSet;
-
-	PROCEDURE GetConstType (x: DevCPT.Const; form: INTEGER; errno: SHORTINT; VAR typ: DevCPT.Struct);
-		CONST MAXL = 9223372036854775808.0; (* 2^63 *)
-	BEGIN
-		IF (form IN intSet + charSet) & (x.realval + x.intval >= MIN(INTEGER))
-				& (x.realval + x.intval <= MAX(INTEGER)) THEN
-			x.intval := SHORT(ENTIER(x.realval + x.intval)); x.realval := 0
-		END;
-		IF form IN intSet THEN
-			IF x.realval = 0 THEN typ := DevCPT.int32typ
-			ELSIF (x.intval >= -MAXL - x.realval) & (x.intval < MAXL - x.realval) THEN typ := DevCPT.int64typ
-			ELSE err(errno); x.intval := 1; x.realval := 0; typ := DevCPT.int32typ
-			END
-		ELSIF form IN realSet THEN	(* SR *)
-			typ := DevCPT.real64typ
-		ELSIF form IN charSet THEN
-			IF x.intval <= 255 THEN typ := DevCPT.char8typ
-			ELSE typ := DevCPT.char16typ
-			END
-		ELSE typ := DevCPT.undftyp
-		END
-	END GetConstType;
-	
-	PROCEDURE CheckConstType (x: DevCPT.Const; form: INTEGER; errno: SHORTINT);
-		VAR type: DevCPT.Struct;
-	BEGIN
-		GetConstType(x, form, errno, type);
-		IF  ~DevCPT.Includes(form, type.form)
-		& ((form # Int8) OR (x.realval # 0) OR (x.intval < -128) OR (x.intval > 127))
-		& ((form # Int16) OR (x.realval # 0) OR (x.intval < -32768) OR (x.intval > 32767)) 
-		& ((form # Real32) OR (ABS(x.realval) > DevCPM.MaxReal32) & (ABS(x.realval) # DevCPM.InfReal)) THEN
-			err(errno); x.intval := 1; x.realval := 0
-		END
-(*
-		IF (form IN intSet + charSet) & (x.realval + x.intval >= MIN(INTEGER))
-				& (x.realval + x.intval <= MAX(INTEGER)) THEN
-			x.intval := SHORT(ENTIER(x.realval + x.intval)); x.realval := 0
-		END;
-		IF (form = Int64) & ((x.intval < -MAXL - x.realval) OR (x.intval >= MAXL - x.realval))
-		OR (form = Int32) & (x.realval # 0)
-		OR (form = Int16) & ((x.realval # 0) OR (x.intval < -32768) OR (x.intval > 32767))
-		OR (form = Int8) & ((x.realval # 0) OR (x.intval < -128) OR (x.intval > 127))
-		OR (form = Char16) & ((x.realval # 0) OR (x.intval < 0) OR (x.intval > 65535))
-		OR (form = Char8) & ((x.realval # 0) OR (x.intval < 0) OR (x.intval > 255))
-		OR (form = Real32) & (ABS(x.realval) > DevCPM.MaxReal32) & (ABS(x.realval) # DevCPM.InfReal) THEN
-			err(errno); x.intval := 1; x.realval := 0
-		END
-*)
-	END CheckConstType;
-	
-	PROCEDURE ConvConst (x: DevCPT.Const; from, to: INTEGER);
-		VAR sr: SHORTREAL;
-	BEGIN
-		IF from = Set THEN
-			x.intval := SetToInt(x.setval); x.realval := 0; x.setval := {};
-		ELSIF from IN intSet + charSet THEN
-			IF to = Set THEN CheckConstType(x, Int32, 203); x.setval := IntToSet(x.intval)
-			ELSIF to IN intSet THEN CheckConstType(x, to, 203)
-			ELSIF to IN realSet THEN x.realval := x.realval + x.intval; x.intval := DevCPM.ConstNotAlloc
-			ELSE (*to IN charSet*) CheckConstType(x, to, 220)
-			END
-		ELSIF from IN realSet THEN
-			IF to IN realSet THEN CheckConstType(x, to, 203);
-				IF to = Real32 THEN sr := SHORT(x.realval); x.realval := sr END	(* reduce precision *)
-			ELSE x.realval := Floor(x.realval); x.intval := 0; CheckConstType(x, to, 203)
-			END
-		END
-	END ConvConst;
-	
-	PROCEDURE Prepare (x: DevCPT.Const);
-		VAR r: REAL;
-	BEGIN
-		x.realval := x.realval + x.intval DIV 32768 * 32768;
-		x.intval := x.intval MOD 32768;
-		r := Floor(x.realval / 4096) * 4096;
-		x.intval := x.intval + SHORT(ENTIER(x.realval - r));
-		x.realval := r
-		(* ABS(x.intval) < 2^15  &  ABS(x.realval) MOD 2^12 = 0 *)
-	END Prepare;
-	
-	PROCEDURE AddConst (x, y, z: DevCPT.Const; VAR type: DevCPT.Struct);	(* z := x + y *)
-	BEGIN
-		IF type.form IN intSet THEN
-			Prepare(x); Prepare(y);
-			z.intval := x.intval + y.intval; z.realval := x.realval + y.realval
-		ELSIF type.form IN realSet THEN
-			IF (ABS(x.realval) = DevCPM.InfReal) & (x.realval = - y.realval) THEN err(212)
-			ELSE z.realval := x.realval + y.realval
-			END
-		ELSE HALT(100)
-		END;
-		GetConstType(z, type.form, 206, type)
-	END AddConst;
-	
-	PROCEDURE NegateConst (y, z: DevCPT.Const; VAR type: DevCPT.Struct);	(* z := - y *)
-	BEGIN
-		IF type.form IN intSet THEN Prepare(y); z.intval :=  -y.intval; z.realval := -y.realval
-		ELSIF type.form IN realSet THEN z.realval := -y.realval
-		ELSE HALT(100)
-		END;
-		GetConstType(z, type.form, 207, type)
-	END NegateConst;
-	
-	PROCEDURE SubConst (x, y, z: DevCPT.Const; VAR type: DevCPT.Struct);	(* z := x - y *)
-	BEGIN
-		IF type.form IN intSet THEN
-			Prepare(x); Prepare(y);
-			z.intval := x.intval - y.intval; z.realval := x.realval - y.realval
-		ELSIF type.form IN realSet THEN
-			IF (ABS(x.realval) = DevCPM.InfReal) & (x.realval =  y.realval) THEN err(212)
-			ELSE z.realval := x.realval - y.realval
-			END
-		ELSE HALT(100)
-		END;
-		GetConstType(z, type.form, 207, type)
-	END SubConst;
-	
-	PROCEDURE MulConst (x, y, z: DevCPT.Const; VAR type: DevCPT.Struct);	(* z := x * y *)
-	BEGIN
-		IF type.form IN intSet THEN
-			Prepare(x); Prepare(y);
-			z.realval := x.realval * y.realval + x.intval * y.realval + x.realval * y.intval;
-			z.intval := x.intval * y.intval
-		ELSIF type.form IN realSet THEN
-			IF (ABS(x.realval) = DevCPM.InfReal) & ( y.realval = 0.0) THEN err(212)
-			ELSIF (ABS(y.realval) = DevCPM.InfReal) & (x.realval = 0.0) THEN err(212)
-			ELSE z.realval := x.realval * y.realval
-			END
-		ELSE HALT(100)
-		END;
-		GetConstType(z, type.form, 204, type)
-	END MulConst;
-	
-	PROCEDURE DivConst (x, y, z: DevCPT.Const; VAR type: DevCPT.Struct);	(* z := x / y *)
-	BEGIN
-		IF type.form IN realSet THEN
-			IF (x.realval = 0.0) & (y.realval = 0.0) THEN err(212)
-			ELSIF (ABS(x.realval) =  DevCPM.InfReal) & (ABS(y.realval) =  DevCPM.InfReal) THEN err(212)
-			ELSE z.realval := x.realval / y.realval
-			END
-		ELSE HALT(100)
-		END;
-		GetConstType(z, type.form, 204, type)
-	END DivConst;
-	
-	PROCEDURE DivModConst (x, y: DevCPT.Const; div: BOOLEAN; VAR type: DevCPT.Struct);
-	(* x := x DIV y | x MOD y *)
-	BEGIN
-		IF type.form IN intSet THEN
-			IF y.realval + y.intval # 0 THEN
-				Prepare(x); Prepare(y);
-				quot.realval := Floor((x.realval + x.intval) / (y.realval + y.intval));
-				quot.intval := 0; Prepare(quot);
-				x.realval := x.realval - quot.realval * y.realval - quot.realval * y.intval - quot.intval * y.realval;
-				x.intval := x.intval - quot.intval * y.intval;
-				IF y.realval + y.intval > 0 THEN
-					WHILE x.realval + x.intval > 0 DO SubConst(x, y, x, type); INC(quot.intval) END;
-					WHILE x.realval + x.intval < 0 DO AddConst(x, y, x, type); DEC(quot.intval) END
-				ELSE
-					WHILE x.realval + x.intval < 0 DO SubConst(x, y, x, type); INC(quot.intval) END;
-					WHILE x.realval + x.intval > 0 DO AddConst(x, y, x, type); DEC(quot.intval) END
-				END;
-				IF div THEN x.realval := quot.realval; x.intval := quot.intval END;
-				GetConstType(x, type.form, 204, type)
-			ELSE err(205)
-			END
-		ELSE HALT(100)
-		END
-	END DivModConst;
-	
-	PROCEDURE EqualConst (x, y: DevCPT.Const; form: INTEGER): BOOLEAN;	(* x = y *)
-		VAR res: BOOLEAN;
-	BEGIN
-		CASE form OF
-		| Undef: res := TRUE
-		| Bool, Byte, Char8..Int32, Char16: res := x.intval = y.intval
-		| Int64: Prepare(x); Prepare(y); res := (x.realval - y.realval) + (x.intval - y.intval) = 0
-		| Real32, Real64: res := x.realval = y.realval
-		| Set: res := x.setval = y.setval
-		| String8, String16, Comp (* guid *): res := x.ext^ = y.ext^
-		| NilTyp, Pointer, ProcTyp: res := x.intval = y.intval
-		END;
-		RETURN res
-	END EqualConst;
-	
-	PROCEDURE LessConst (x, y: DevCPT.Const; form: INTEGER): BOOLEAN;	(* x < y *)
-		VAR res: BOOLEAN;
-	BEGIN
-		CASE form OF
-		| Undef: res := TRUE
-		| Byte, Char8..Int32, Char16: res := x.intval < y.intval
-		| Int64: Prepare(x); Prepare(y); res := (x.realval - y.realval) + (x.intval - y.intval) < 0
-		| Real32, Real64: res := x.realval < y.realval
-		| String8, String16: res := x.ext^ < y.ext^
-		| Bool, Set, NilTyp, Pointer, ProcTyp, Comp: err(108)
-		END;
-		RETURN res
-	END LessConst;
-	
-	PROCEDURE IsNegConst (x: DevCPT.Const; form: INTEGER): BOOLEAN;	(* x < 0  OR x = (-0.0) *)
-		VAR res: BOOLEAN;
-	BEGIN
-		CASE form OF
-		| Int8..Int32: res := x.intval < 0
-		| Int64: Prepare(x); res := x.realval + x.intval < 0
-		| Real32, Real64: res := (x.realval <= 0.) & (1. / x.realval <= 0.)
-		END;
-		RETURN res
-	END IsNegConst;
-
-
-	PROCEDURE NewIntConst*(intval: INTEGER): DevCPT.Node;
-		VAR x: DevCPT.Node;
-	BEGIN
-		x := DevCPT.NewNode(Nconst); x.conval := DevCPT.NewConst();
-		x.conval.intval := intval; x.conval.realval := 0; x.typ := DevCPT.int32typ; RETURN x
-	END NewIntConst;
-	
-	PROCEDURE NewLargeIntConst* (intval: INTEGER; realval: REAL): DevCPT.Node;
-		VAR x: DevCPT.Node;
-	BEGIN
-		x := DevCPT.NewNode(Nconst); x.conval := DevCPT.NewConst();
-		x.conval.intval := intval; x.conval.realval := realval; x.typ := DevCPT.int64typ; RETURN x
-	END NewLargeIntConst;
-	
-	PROCEDURE NewRealConst*(realval: REAL; typ: DevCPT.Struct): DevCPT.Node;
-		VAR x: DevCPT.Node;
-	BEGIN
-		x := DevCPT.NewNode(Nconst); x.conval := DevCPT.NewConst();
-		x.conval.realval := realval; x.conval.intval := DevCPM.ConstNotAlloc;
-		IF typ = NIL THEN typ := DevCPT.real64typ END;
-		x.typ := typ;
-		RETURN x
-	END NewRealConst;
-	
-	PROCEDURE NewString*(str: DevCPT.String; lstr: POINTER TO ARRAY OF CHAR; len: INTEGER): DevCPT.Node;
-		VAR i, j, c: INTEGER; x: DevCPT.Node; ext: DevCPT.ConstExt;
-	BEGIN
-		x := DevCPT.NewNode(Nconst); x.conval := DevCPT.NewConst();
-		IF lstr # NIL THEN
-			x.typ := DevCPT.string16typ;
-			NEW(ext, 3 * len); i := 0; j := 0;
-			REPEAT c := ORD(lstr[i]); INC(i); DevCPM.PutUtf8(ext^, c, j) UNTIL c = 0;
-			x.conval.ext := ext
-		ELSE
-			x.typ := DevCPT.string8typ; x.conval.ext := str
-		END;
-		x.conval.intval := DevCPM.ConstNotAlloc; x.conval.intval2 := len;
-		RETURN x
-	END NewString;
-	
-	PROCEDURE CharToString8(n: DevCPT.Node);
-		VAR ch: SHORTCHAR;
-	BEGIN
-		n.typ := DevCPT.string8typ; ch := SHORT(CHR(n.conval.intval)); NEW(n.conval.ext, 2);
-		IF ch = 0X THEN n.conval.intval2 := 1 ELSE n.conval.intval2 := 2; n.conval.ext[1] := 0X END ;
-		n.conval.ext[0] := ch; n.conval.intval := DevCPM.ConstNotAlloc; n.obj := NIL
-	END CharToString8;
-	
-	PROCEDURE CharToString16 (n: DevCPT.Node);
-		VAR ch, ch1: SHORTCHAR; i: INTEGER;
-	BEGIN
-		n.typ := DevCPT.string16typ; NEW(n.conval.ext, 4);
-		IF n.conval.intval = 0 THEN
-			n.conval.ext[0] := 0X; n.conval.intval2 := 1
-		ELSE
-			i := 0; DevCPM.PutUtf8(n.conval.ext^, n.conval.intval, i);
-			n.conval.ext[i] := 0X; n.conval.intval2 := 2
-		END;
-		n.conval.intval := DevCPM.ConstNotAlloc; n.obj := NIL
-	END CharToString16;
-	
-	PROCEDURE String8ToString16 (n: DevCPT.Node);
-		VAR i, j, x: INTEGER; ext, new: DevCPT.ConstExt;
-	BEGIN
-		n.typ := DevCPT.string16typ; ext := n.conval.ext;
-		NEW(new, 2 * n.conval.intval2); i := 0; j := 0; 
-		REPEAT x := ORD(ext[i]); INC(i); DevCPM.PutUtf8(new^, x, j) UNTIL x = 0;
-		n.conval.ext := new; n.obj := NIL
-	END String8ToString16;
-	
-	PROCEDURE String16ToString8 (n: DevCPT.Node);
-		VAR i, j, x: INTEGER; ext, new: DevCPT.ConstExt;
-	BEGIN
-		n.typ := DevCPT.string8typ; ext := n.conval.ext;
-		NEW(new, n.conval.intval2); i := 0; j := 0;
-		REPEAT DevCPM.GetUtf8(ext^, x, i); new[j] := SHORT(CHR(x MOD 256)); INC(j) UNTIL x = 0;
-		n.conval.ext := new; n.obj := NIL
-	END String16ToString8;
-	
-	PROCEDURE StringToGuid (VAR n: DevCPT.Node);
-	BEGIN
-		ASSERT((n.class = Nconst) & (n.typ.form = String8));
-		IF ~DevCPM.ValidGuid(n.conval.ext^) THEN err(165) END;
-		n.typ := DevCPT.guidtyp
-	END StringToGuid;
-	
-	PROCEDURE CheckString (n: DevCPT.Node; typ: DevCPT.Struct; e: SHORTINT);
-		VAR ntyp: DevCPT.Struct;
-	BEGIN
-		ntyp := n.typ;
-		IF (typ = DevCPT.guidtyp) & (n.class = Nconst) & (ntyp.form = String8) THEN StringToGuid(n)
-		ELSIF (typ.comp IN {Array, DynArr}) & (typ.BaseTyp.form = Char8) OR (typ.form = String8) THEN
-			IF (n.class = Nconst) & (ntyp.form = Char8) THEN CharToString8(n)
-			ELSIF (ntyp.comp IN {Array, DynArr}) & (ntyp.BaseTyp.form = Char8) OR (ntyp.form = String8) THEN (* ok *)
-			ELSE err(e)
-			END
-		ELSIF (typ.comp IN {Array, DynArr}) & (typ.BaseTyp.form = Char16) OR (typ.form = String16) THEN
-			IF (n.class = Nconst) & (ntyp.form IN charSet) THEN CharToString16(n)
-			ELSIF (n.class = Nconst) & (ntyp.form = String8) THEN String8ToString16(n)
-			ELSIF (ntyp.comp IN {Array, DynArr}) & (ntyp.BaseTyp.form = Char16) OR (ntyp.form = String16) THEN
-				(* ok *)
-			ELSE err(e)
-			END
-		ELSE err(e)
-		END
-	END CheckString;
-	
-	
-	PROCEDURE BindNodes(class: BYTE; typ: DevCPT.Struct; VAR x: DevCPT.Node; y: DevCPT.Node);
-		VAR node: DevCPT.Node;
-	BEGIN
-		node := DevCPT.NewNode(class); node.typ := typ;
-		node.left := x; node.right := y; x := node
-	END BindNodes;
-
-	PROCEDURE NotVar(x: DevCPT.Node): BOOLEAN;
-	BEGIN
-		RETURN (x.class >= Nconst) & ((x.class # Nmop) OR (x.subcl # val) OR (x.left.class >= Nconst))
-			OR (x.typ.form IN {String8, String16})
-	END NotVar;
-
-
-	PROCEDURE Convert(VAR x: DevCPT.Node; typ: DevCPT.Struct);
-		VAR node: DevCPT.Node; f, g: SHORTINT; k: INTEGER; r: REAL;
-	BEGIN f := x.typ.form; g := typ.form;
-		IF x.class = Nconst THEN
-			IF g = String8 THEN
-				IF f = String16 THEN String16ToString8(x)
-				ELSIF f IN charSet THEN CharToString8(x)
-				ELSE typ := DevCPT.undftyp
-				END
-			ELSIF g = String16 THEN
-				IF f = String8 THEN String8ToString16(x)
-				ELSIF f IN charSet THEN CharToString16(x)
-				ELSE typ := DevCPT.undftyp
-				END
-			ELSE ConvConst(x.conval, f, g)
-			END;
-			x.obj := NIL
-		ELSIF (x.class = Nmop) & (x.subcl = conv) & (DevCPT.Includes(f, x.left.typ.form) OR DevCPT.Includes(f, g))
-		THEN
-			(* don't create new node *)
-			IF x.left.typ.form = typ.form THEN (* and suppress existing node *) x := x.left END
-		ELSE
-			IF (x.class = Ndop) & (x.typ.form IN {String8, String16}) THEN	(* propagate to leaf nodes *)
-				Convert(x.left, typ); Convert(x.right, typ)
-			ELSE
-				node := DevCPT.NewNode(Nmop); node.subcl := conv; node.left := x; x := node;
-			END
-		END;
-		x.typ := typ
-	END Convert;
-
-	PROCEDURE Promote (VAR left, right: DevCPT.Node; op: INTEGER);	(* check expression compatibility *)
-		VAR f, g: INTEGER; new: DevCPT.Struct;
-	BEGIN
-		f := left.typ.form; g := right.typ.form; new := left.typ;
-		IF f IN intSet + realSet THEN
-			IF g IN intSet + realSet THEN
-				IF (f = Real32) & (right.class = Nconst) & (g IN realSet) & (left.class # Nconst)
-					(* & ((ABS(right.conval.realval) <= DevCPM.MaxReal32)
-							OR (ABS(right.conval.realval) = DevCPM.InfReal)) *)
-				OR (g = Real32) & (left.class = Nconst) & (f IN realSet) & (right.class # Nconst)
-					(* & ((ABS(left.conval.realval) <= DevCPM.MaxReal32)
-							OR (ABS(left.conval.realval) = DevCPM.InfReal)) *) THEN
-						new := DevCPT.real32typ	(* SR *)
-				ELSIF (f = Real64) OR (g = Real64) THEN new := DevCPT.real64typ
-				ELSIF (f = Real32) OR (g = Real32) THEN new := DevCPT.real32typ	(* SR *)
-				ELSIF op = slash THEN new := DevCPT.real64typ
-				ELSIF (f = Int64) OR (g = Int64) THEN new := DevCPT.int64typ
-				ELSE new := DevCPT.int32typ
-				END
-			ELSE err(100)
-			END
-		ELSIF (left.typ = DevCPT.guidtyp) OR (right.typ = DevCPT.guidtyp) THEN
-			IF f = String8 THEN StringToGuid(left) END;
-			IF g = String8 THEN StringToGuid(right) END;
-			IF left.typ # right.typ THEN err(100) END;
-			f := Comp
-		ELSIF f IN charSet + {String8, String16} THEN
-			IF g IN charSet + {String8, String16} THEN
-				IF (f = String16) OR (g = String16) OR (f = Char16) & (g = String8) OR (f = String8) & (g = Char16) THEN
-					new := DevCPT.string16typ
-				ELSIF (f = Char16) OR (g = Char16) THEN new := DevCPT.char16typ
-				ELSIF (f = String8) OR (g = String8) THEN new := DevCPT.string8typ
-				ELSIF op = plus THEN
-					IF (f = Char16) OR (g = Char16) THEN new := DevCPT.string16typ
-					ELSE new := DevCPT.string8typ
-					END
-				END;
-				IF (new.form IN {String8, String16})
-					& ((f IN charSet) & (left.class # Nconst) OR (g IN charSet) & (right.class # Nconst))
-				THEN
-					err(100)
-				END
-			ELSE err(100)
-			END
-		ELSIF (f IN {NilTyp, Pointer, ProcTyp}) & (g IN {NilTyp, Pointer, ProcTyp}) THEN
-			IF ~DevCPT.SameType(left.typ, right.typ) & (f # NilTyp) & (g # NilTyp)
-				& ~((f = Pointer) & (g = Pointer)
-					& (DevCPT.Extends(left.typ, right.typ) OR DevCPT.Extends(right.typ, left.typ))) THEN err(100) END
-		ELSIF f # g THEN err(100)
-		END;
-		IF ~(f IN {NilTyp, Pointer, ProcTyp, Comp}) THEN
-			IF g # new.form THEN Convert(right, new) END;
-			IF f # new.form THEN Convert(left, new) END
-		END
-	END Promote;
-
-	PROCEDURE CheckParameters* (fp, ap: DevCPT.Object; checkNames: BOOLEAN); (* checks par list match *)
-		VAR ft, at: DevCPT.Struct;
-	BEGIN
-		WHILE fp # NIL DO
-			IF ap # NIL THEN
-				ft := fp.typ; at := ap.typ;
-				IF fp.ptyp # NIL THEN ft := fp.ptyp END;	(* get original formal type *)
-				IF ap.ptyp # NIL THEN at := ap.ptyp END;	(* get original formal type *)
-				IF ~DevCPT.EqualType(ft, at)
-					OR (fp.mode # ap.mode) OR (fp.sysflag # ap.sysflag) OR (fp.vis # ap.vis)
-					OR checkNames & (fp.name^ # ap.name^) THEN err(115) END ;
-				ap := ap.link
-			ELSE err(116)
-			END;
-			fp := fp.link
-		END;
-		IF ap # NIL THEN err(116) END
-	END CheckParameters;
-
-	PROCEDURE CheckNewParamPair* (newPar, iidPar: DevCPT.Node);
-		VAR ityp, ntyp: DevCPT.Struct;
-	BEGIN
-		ntyp := newPar.typ.BaseTyp;
-		IF (newPar.class = Nvarpar) & ODD(newPar.obj.sysflag DIV newBit) THEN
-			IF (iidPar.class = Nvarpar) & ODD(iidPar.obj.sysflag DIV iidBit) & (iidPar.obj.mnolev = newPar.obj.mnolev)
-			THEN (* ok *)
-			ELSE err(168)
-			END
-		ELSIF ntyp.extlev = 0 THEN	(* ok *)
-		ELSIF (iidPar.class = Nconst) & (iidPar.obj # NIL) & (iidPar.obj.mode = Typ) THEN
-			IF ~DevCPT.Extends(iidPar.obj.typ, ntyp) THEN err(168) END
-		ELSE err(168)
-		END
-	END CheckNewParamPair;
-
-	
-	PROCEDURE DeRef*(VAR x: DevCPT.Node);
-		VAR strobj, bstrobj: DevCPT.Object; typ, btyp: DevCPT.Struct;
-	BEGIN
-		typ := x.typ;
-		IF (x.class = Nconst) OR (x.class = Ntype) OR (x.class = Nproc) THEN err(78)
-		ELSIF typ.form = Pointer THEN
-			btyp := typ.BaseTyp; strobj := typ.strobj; bstrobj := btyp.strobj;
-			IF (strobj # NIL) & (strobj.name # DevCPT.null) & (bstrobj # NIL) & (bstrobj.name # DevCPT.null) THEN
-				btyp.pbused := TRUE
-			END ;
-			BindNodes(Nderef, btyp, x, NIL); x.subcl := 0
-		ELSE err(84)
-		END
-	END DeRef;
-
-	PROCEDURE StrDeref*(VAR x: DevCPT.Node);
-		VAR typ, btyp: DevCPT.Struct;
-	BEGIN
-		typ := x.typ;
-		IF (x.class = Nconst) OR (x.class = Ntype) OR (x.class = Nproc) THEN err(78)
-		ELSIF ((typ.comp IN {Array, DynArr}) & (typ.BaseTyp.form IN charSet)) OR (typ.sysflag = jstr) THEN
-			IF (typ.BaseTyp # NIL) & (typ.BaseTyp.form = Char8) THEN btyp := DevCPT.string8typ
-			ELSE btyp := DevCPT.string16typ
-			END;
-			BindNodes(Nderef, btyp, x, NIL); x.subcl := 1
-		ELSE err(90)
-		END
-	END StrDeref;
-
-	PROCEDURE Index*(VAR x: DevCPT.Node; y: DevCPT.Node);
-		VAR f: SHORTINT; typ: DevCPT.Struct;
-	BEGIN
-		f := y.typ.form;
-		IF (x.class = Nconst) OR (x.class = Ntype) OR (x.class = Nproc) THEN err(79)
-		ELSIF ~(f IN intSet) OR (y.class IN {Nproc, Ntype}) THEN err(80); y.typ := DevCPT.int32typ END ;
-		IF f = Int64 THEN Convert(y, DevCPT.int32typ) END;
-		IF x.typ.comp = Array THEN typ := x.typ.BaseTyp;
-			IF (y.class = Nconst) & ((y.conval.intval < 0) OR (y.conval.intval >= x.typ.n)) THEN err(81) END
-		ELSIF x.typ.comp = DynArr THEN typ := x.typ.BaseTyp;
-			IF (y.class = Nconst) & (y.conval.intval < 0) THEN err(81) END
-		ELSE err(82); typ := DevCPT.undftyp
-		END ;
-		BindNodes(Nindex, typ, x, y); x.readonly := x.left.readonly
-	END Index;
-	
-	PROCEDURE Field*(VAR x: DevCPT.Node; y: DevCPT.Object);
-	BEGIN (*x.typ.comp = Record*)
-		IF (x.class = Nconst) OR (x.class = Ntype) OR (x.class = Nproc) THEN err(77) END ;
-		IF (y # NIL) & (y.mode IN {Fld, TProc}) THEN
-			BindNodes(Nfield, y.typ, x, NIL); x.obj := y;
-			x.readonly := x.left.readonly OR ((y.vis = externalR) & (y.mnolev < 0))
-		ELSE err(83); x.typ := DevCPT.undftyp
-		END
-	END Field;
-	
-	PROCEDURE TypTest*(VAR x: DevCPT.Node; obj: DevCPT.Object; guard: BOOLEAN);
-
-		PROCEDURE GTT(t0, t1: DevCPT.Struct);
-			VAR node: DevCPT.Node;
-		BEGIN
-			IF (t0 # NIL) & DevCPT.SameType(t0, t1) & (guard OR (x.class # Nguard)) THEN
-				IF ~guard THEN x := NewBoolConst(TRUE) END
-			ELSIF (t0 = NIL) OR DevCPT.Extends(t1, t0) OR (t0.sysflag = jint) OR (t1.sysflag = jint)
-					OR (t1.comp = DynArr) & (DevCPM.java IN DevCPM.options) THEN
-				IF guard THEN BindNodes(Nguard, NIL, x, NIL); x.readonly := x.left.readonly
-				ELSE node := DevCPT.NewNode(Nmop); node.subcl := is; node.left := x; node.obj := obj; x := node
-				END
-			ELSE err(85)
-			END
-		END GTT;
-
-	BEGIN
-		IF (x.class = Nconst) OR (x.class = Ntype) OR (x.class = Nproc) THEN err(112)
-		ELSIF x.typ.form = Pointer THEN
-			IF x.typ = DevCPT.sysptrtyp THEN
-				IF obj.typ.form = Pointer THEN GTT(NIL, obj.typ.BaseTyp)
-				ELSE err(86)
-				END
-			ELSIF x.typ.BaseTyp.comp # Record THEN err(85)
-			ELSIF obj.typ.form = Pointer THEN GTT(x.typ.BaseTyp, obj.typ.BaseTyp)
-			ELSE err(86)
-			END
-		ELSIF (x.typ.comp = Record) & (x.class = Nvarpar) & (x.obj.vis # outPar) & (obj.typ.comp = Record) THEN
-			GTT(x.typ, obj.typ)
-		ELSE err(87)
-		END ;
-		IF guard THEN x.typ := obj.typ ELSE x.typ := DevCPT.booltyp END
-	END TypTest;
-	
-	PROCEDURE In*(VAR x: DevCPT.Node; y: DevCPT.Node);
-		VAR f: SHORTINT; k: INTEGER;
-	BEGIN f := x.typ.form;
-		IF (x.class = Ntype) OR (x.class = Nproc) OR (y.class = Ntype) OR (y.class = Nproc) THEN err(126)
-		ELSIF (f IN intSet) & (y.typ.form = Set) THEN
-			IF f = Int64 THEN Convert(x, DevCPT.int32typ) END;
-			IF x.class = Nconst THEN
-				k := x.conval.intval;
-				IF (k < 0) OR (k > DevCPM.MaxSet) THEN err(202)
-				ELSIF y.class = Nconst THEN x.conval.intval := BoolToInt(k IN y.conval.setval); x.obj := NIL
-				ELSE BindNodes(Ndop, DevCPT.booltyp, x, y); x.subcl := in
-				END
-			ELSE BindNodes(Ndop, DevCPT.booltyp, x, y); x.subcl := in
-			END
-		ELSE err(92)
-		END ;
-		x.typ := DevCPT.booltyp
-	END In;
-
-	PROCEDURE MOp*(op: BYTE; VAR x: DevCPT.Node);
-		VAR f: SHORTINT; typ: DevCPT.Struct; z: DevCPT.Node;
-		
-		PROCEDURE NewOp(op: BYTE; typ: DevCPT.Struct; z: DevCPT.Node): DevCPT.Node;
-			VAR node: DevCPT.Node;
-		BEGIN
-			node := DevCPT.NewNode(Nmop); node.subcl := op; node.typ := typ;
-			node.left := z; RETURN node
-		END NewOp;
-
-	BEGIN z := x;
-		IF ((z.class = Ntype) OR (z.class = Nproc)) & (op # adr) & (op # typfn) & (op # size) THEN err(126)	(* !!! *)
-		ELSE
-			typ := z.typ; f := typ.form;
-			CASE op OF
-			| not:
-				IF f = Bool THEN
-					IF z.class = Nconst THEN
-						z.conval.intval := BoolToInt(~IntToBool(z.conval.intval)); z.obj := NIL
-					ELSE z := NewOp(op, typ, z)
-					END
-				ELSE err(98)
-				END
-			| plus:
-				IF ~(f IN intSet + realSet) THEN err(96) END
-			| minus:
-				IF f IN intSet + realSet + {Set} THEN
-					IF z.class = Nconst THEN
-						IF f = Set THEN z.conval.setval := -z.conval.setval
-						ELSE NegateConst(z.conval, z.conval, z.typ)
-						END;
-						z.obj := NIL
-					ELSE
-						IF f < Int32 THEN Convert(z, DevCPT.int32typ) END;
-						z := NewOp(op, z.typ, z)
-					END
-				ELSE err(97)
-				END
-			| abs:
-				IF f IN intSet + realSet THEN
-					IF z.class = Nconst THEN
-						IF IsNegConst(z.conval, f) THEN NegateConst(z.conval, z.conval, z.typ) END;
-						z.obj := NIL
-					ELSE
-						IF f < Int32 THEN Convert(z, DevCPT.int32typ) END;
-						z := NewOp(op, z.typ, z)
-					END
-				ELSE err(111)
-				END
-			| cap:
-				IF f IN charSet THEN
-					IF z.class = Nconst THEN
-						IF ODD(z.conval.intval DIV 32) THEN DEC(z.conval.intval, 32) END;
-						z.obj := NIL
-					ELSE z := NewOp(op, typ, z)
-					END
-				ELSE err(111); z.typ := DevCPT.char8typ
-				END
-			| odd:
-				IF f IN intSet THEN
-					IF z.class = Nconst THEN
-						DivModConst(z.conval, two, FALSE, z.typ);	(* z MOD 2 *)
-						z.obj := NIL
-					ELSE z := NewOp(op, typ, z)
-					END
-				ELSE err(111)
-				END ;
-				z.typ := DevCPT.booltyp
-			| adr: (*ADR*)
-				IF z.class = Nproc THEN
-					IF z.obj.mnolev > 0 THEN err(73)
-					ELSIF z.obj.mode = LProc THEN z.obj.mode := XProc
-					END;
-					z := NewOp(op, typ, z)
-				ELSIF z.class = Ntype THEN
-					IF z.obj.typ.untagged THEN err(111) END;
-					z := NewOp(op, typ, z)
-				ELSIF (z.class < Nconst) OR (z.class = Nconst) & (f IN {String8, String16}) THEN
-					z := NewOp(op, typ, z)
-				ELSE err(127)
-				END ;
-				z.typ := DevCPT.int32typ
-			| typfn, size: (*TYP, SIZE*)
-				z := NewOp(op, typ, z);
-				z.typ := DevCPT.int32typ
-			| cc: (*SYSTEM.CC*)
-				IF (f IN intSet) & (z.class = Nconst) THEN
-					IF (0 <= z.conval.intval) & (z.conval.intval <= DevCPM.MaxCC) & (z.conval.realval = 0) THEN
-						z := NewOp(op, typ, z)
-					ELSE err(219)
-					END
-				ELSE err(69)
-				END;
-				z.typ := DevCPT.booltyp
-			END
-		END;
-		x := z
-	END MOp;
-	
-	PROCEDURE ConstOp(op: SHORTINT; x, y: DevCPT.Node);
-		VAR f: SHORTINT; i, j: INTEGER; xval, yval: DevCPT.Const; ext: DevCPT.ConstExt; t: DevCPT.Struct;
-	BEGIN
-		f := x.typ.form;
-		IF f = y.typ.form THEN
-			xval := x.conval; yval := y.conval;
-			CASE op OF
-			| times:
-				IF f IN intSet + realSet THEN MulConst(xval, yval, xval, x.typ)
-				ELSIF f = Set THEN xval.setval := xval.setval * yval.setval
-				ELSIF f # Undef THEN err(101)
-				END
-			| slash:
-				IF f IN realSet THEN DivConst(xval, yval, xval, x.typ)
-				ELSIF f = Set THEN xval.setval := xval.setval / yval.setval
-				ELSIF f # Undef THEN err(102)
-				END
-			| div:
-				IF f IN intSet THEN DivModConst(xval, yval, TRUE, x.typ)
-				ELSIF f # Undef THEN err(103)
-				END
-			| mod:
-				IF f IN intSet THEN DivModConst(xval, yval, FALSE, x.typ)
-				ELSIF f # Undef THEN err(104)
-				END
-			| and:
-				IF f = Bool THEN xval.intval := BoolToInt(IntToBool(xval.intval) & IntToBool(yval.intval))
-				ELSE err(94)
-				END
-			| plus:
-				IF f IN intSet + realSet THEN AddConst(xval, yval, xval, x.typ)
-				ELSIF f = Set THEN xval.setval := xval.setval + yval.setval
-				ELSIF (f IN {String8, String16}) & (xval.ext # NIL) & (yval.ext # NIL) THEN
-					NEW(ext, LEN(xval.ext^) + LEN(yval.ext^));
-					i := 0; WHILE xval.ext[i] # 0X DO ext[i] := xval.ext[i]; INC(i) END;
-					j := 0; WHILE yval.ext[j] # 0X DO ext[i] := yval.ext[j]; INC(i); INC(j) END;
-					ext[i] := 0X; xval.ext := ext; INC(xval.intval2, yval.intval2 - 1)
-				ELSIF f # Undef THEN err(105)
-				END
-			| minus:
-				IF f IN intSet + realSet THEN SubConst(xval, yval, xval, x.typ)
-				ELSIF f = Set THEN xval.setval := xval.setval - yval.setval
-				ELSIF f # Undef THEN err(106)
-				END
-			| min:
-				IF f IN intSet + realSet THEN
-					IF LessConst(yval, xval, f) THEN xval^ := yval^ END
-				ELSIF f # Undef THEN err(111)
-				END
-			| max:
-				IF f IN intSet + realSet THEN
-					IF LessConst(xval, yval, f) THEN xval^ := yval^ END
-				ELSIF f # Undef THEN err(111)
-				END
-			| or:
-				IF f = Bool THEN xval.intval := BoolToInt(IntToBool(xval.intval) OR IntToBool(yval.intval))
-				ELSE err(95)
-				END
-			| eql: xval.intval := BoolToInt(EqualConst(xval, yval, f)); x.typ := DevCPT.booltyp
-			| neq: xval.intval := BoolToInt(~EqualConst(xval, yval, f)); x.typ := DevCPT.booltyp
-			| lss: xval.intval := BoolToInt(LessConst(xval, yval, f)); x.typ := DevCPT.booltyp
-			| leq: xval.intval := BoolToInt(~LessConst(yval, xval, f)); x.typ := DevCPT.booltyp
-			| gtr: xval.intval := BoolToInt(LessConst(yval, xval, f)); x.typ := DevCPT.booltyp
-			| geq: xval.intval := BoolToInt(~LessConst(xval, yval, f)); x.typ := DevCPT.booltyp
-			END
-		ELSE err(100)
-		END;
-		x.obj := NIL
-	END ConstOp;
-	
-	PROCEDURE Op*(op: BYTE; VAR x: DevCPT.Node; y: DevCPT.Node);
-		VAR f, g: SHORTINT; t, z: DevCPT.Node; typ: DevCPT.Struct; do: BOOLEAN; val: INTEGER;
-
-		PROCEDURE NewOp(op: BYTE; typ: DevCPT.Struct; VAR x: DevCPT.Node; y: DevCPT.Node);
-			VAR node: DevCPT.Node;
-		BEGIN
-			node := DevCPT.NewNode(Ndop); node.subcl := op; node.typ := typ;
-			node.left := x; node.right := y; x := node
-		END NewOp;
-
-	BEGIN z := x;
-		IF (z.class = Ntype) OR (z.class = Nproc) OR (y.class = Ntype) OR (y.class = Nproc) THEN err(126)
-		ELSE
-			Promote(z, y, op);
-			IF (z.class = Nconst) & (y.class = Nconst) THEN ConstOp(op, z, y)
-			ELSE
-				typ := z.typ; f := typ.form; g := y.typ.form;
-				CASE op OF
-				| times:
-					do := TRUE;
-					IF f IN intSet THEN
-						IF z.class = Nconst THEN
-							IF EqualConst(z.conval, one, f) THEN do := FALSE; z := y
-							ELSIF EqualConst(z.conval, zero, f) THEN do := FALSE
-							ELSE val := Log(z);
-								IF val >= 0 THEN
-									t := y; y := z; z := t;
-									op := ash; y.typ := DevCPT.int32typ; y.conval.intval := val; y.obj := NIL
-								END
-							END
-						ELSIF y.class = Nconst THEN
-							IF EqualConst(y.conval, one, f) THEN do := FALSE
-							ELSIF EqualConst(y.conval, zero, f) THEN do := FALSE; z := y
-							ELSE val := Log(y);
-								IF val >= 0 THEN
-									op := ash; y.typ := DevCPT.int32typ; y.conval.intval := val; y.obj := NIL
-								END
-							END
-						END
-					ELSIF ~(f IN {Undef, Real32..Set}) THEN err(105); typ := DevCPT.undftyp
-					END ;
-					IF do THEN NewOp(op, typ, z, y) END;
-				| slash:
-					IF f IN realSet THEN (* OK *)
-					ELSIF (f # Set) & (f # Undef) THEN err(102); typ := DevCPT.undftyp
-					END ;
-					NewOp(op, typ, z, y)
-				| div:
-					do := TRUE;
-					IF f IN intSet THEN
-						IF y.class = Nconst THEN
-							IF EqualConst(y.conval, zero, f) THEN err(205)
-							ELSIF EqualConst(y.conval, one, f) THEN do := FALSE
-							ELSE val := Log(y);
-								IF val >= 0 THEN
-									op := ash; y.typ := DevCPT.int32typ; y.conval.intval := -val; y.obj := NIL
-								END
-							END
-						END
-					ELSIF f # Undef THEN err(103); typ := DevCPT.undftyp
-					END ;
-					IF do THEN NewOp(op, typ, z, y) END;
-				| mod:
-					IF f IN intSet THEN
-						IF y.class = Nconst THEN
-							IF EqualConst(y.conval, zero, f) THEN err(205)
-							ELSE val := Log(y);
-								IF val >= 0 THEN
-									op := msk; y.conval.intval := ASH(-1, val); y.obj := NIL
-								END
-							END
-						END
-					ELSIF f # Undef THEN err(104); typ := DevCPT.undftyp
-					END ;
-					NewOp(op, typ, z, y);
-				| and:
-					IF f = Bool THEN
-						IF z.class = Nconst THEN
-							IF IntToBool(z.conval.intval) THEN z := y END
-						ELSIF (y.class = Nconst) & IntToBool(y.conval.intval) THEN (* optimize z & TRUE -> z *)
-						ELSE NewOp(op, typ, z, y)
-						END
-					ELSIF f # Undef THEN err(94); z.typ := DevCPT.undftyp
-					END
-				| plus:
-					IF ~(f IN {Undef, Int8..Set, Int64, String8, String16}) THEN err(105); typ := DevCPT.undftyp END;
-					do := TRUE;
-					IF f IN intSet THEN
-						IF (z.class = Nconst) & EqualConst(z.conval, zero, f) THEN do := FALSE; z := y END ;
-						IF (y.class = Nconst) & EqualConst(y.conval, zero, f) THEN do := FALSE END
-					ELSIF f IN {String8, String16} THEN
-						IF (z.class = Nconst) & (z.conval.intval2 = 1) THEN do := FALSE; z := y END ;
-						IF (y.class = Nconst) & (y.conval.intval2 = 1) THEN do := FALSE END;
-						IF do THEN
-							IF z.class = Ndop THEN
-								t := z; WHILE t.right.class = Ndop DO t := t.right END;
-								IF (t.right.class = Nconst) & (y.class = Nconst) THEN
-									ConstOp(op, t.right, y); do := FALSE
-								ELSIF (t.right.class = Nconst) & (y.class = Ndop) & (y.left.class = Nconst) THEN
-									ConstOp(op, t.right, y.left); y.left := t.right; t.right := y; do := FALSE
-								ELSE
-									NewOp(op, typ, t.right, y); do := FALSE
-								END
-							ELSE
-								IF (z.class = Nconst) & (y.class = Ndop) & (y.left.class = Nconst) THEN
-									ConstOp(op, z, y.left); y.left := z; z := y; do := FALSE
-								END
-							END
-						END
-					END ;
-					IF do THEN NewOp(op, typ, z, y) END;
-				| minus:
-					IF ~(f IN {Undef, Int8..Set, Int64}) THEN err(106); typ := DevCPT.undftyp END;
-					IF ~(f IN intSet) OR (y.class # Nconst) OR ~EqualConst(y.conval, zero, f) THEN NewOp(op, typ, z, y)
-					END;
-				| min, max:
-					IF ~(f IN {Undef} + intSet + realSet + charSet) THEN err(111); typ := DevCPT.undftyp END;
-					NewOp(op, typ, z, y);
-				| or:
-					IF f = Bool THEN
-						IF z.class = Nconst THEN
-							IF ~IntToBool(z.conval.intval) THEN z := y END
-						ELSIF (y.class = Nconst) & ~IntToBool(y.conval.intval) THEN (* optimize z OR FALSE -> z *)
-						ELSE NewOp(op, typ, z, y)
-						END
-					ELSIF f # Undef THEN err(95); z.typ := DevCPT.undftyp
-					END
-				| eql, neq, lss, leq, gtr, geq:
-					IF f IN {String8, String16} THEN
-						IF (f = String16) & (z.class = Nmop) & (z.subcl = conv) & (y.class = Nmop) & (y.subcl = conv) THEN
-							z := z.left; y := y.left	(* remove LONG on both sides *)
-						ELSIF (z.class = Nconst) & (z.conval.intval2 = 1) & (y.class = Nderef) THEN (* y$ = "" -> y[0] = 0X *)
-							y := y.left; Index(y, NewIntConst(0)); z.typ := y.typ; z.conval.intval := 0
-						ELSIF (y.class = Nconst) & (y.conval.intval2 = 1) & (z.class = Nderef) THEN (* z$ = "" -> z[0] = 0X *)
-							z := z.left; Index(z, NewIntConst(0)); y.typ := z.typ; y.conval.intval := 0
-						END;
-						typ := DevCPT.booltyp
-					ELSIF (f IN {Undef, Char8..Real64, Char16, Int64})
-							OR (op <= neq) & ((f IN {Bool, Set, NilTyp, Pointer, ProcTyp}) OR (typ = DevCPT.guidtyp)) THEN
-						typ := DevCPT.booltyp
-					ELSE err(107); typ := DevCPT.undftyp
-					END;
-					NewOp(op, typ, z, y)
-				END
-			END
-		END;
-		x := z
-	END Op;
-
-	PROCEDURE SetRange*(VAR x: DevCPT.Node; y: DevCPT.Node);
-		VAR k, l: INTEGER;
-	BEGIN
-		IF (x.class = Ntype) OR (x.class = Nproc) OR (y.class = Ntype) OR (y.class = Nproc) THEN err(126)	
-		ELSIF (x.typ.form IN intSet) & (y.typ.form IN intSet) THEN
-			IF x.typ.form = Int64 THEN Convert(x, DevCPT.int32typ) END;
-			IF y.typ.form = Int64 THEN Convert(y, DevCPT.int32typ) END;
-			IF x.class = Nconst THEN
-				k := x.conval.intval;
-				IF (0 > k) OR (k > DevCPM.MaxSet) OR (x.conval.realval # 0) THEN err(202) END
-			END ;
-			IF y.class = Nconst THEN
-				l := y.conval.intval;
-				IF (0 > l) OR (l > DevCPM.MaxSet) OR (y.conval.realval # 0) THEN err(202) END
-			END ;
-			IF (x.class = Nconst) & (y.class = Nconst) THEN
-				IF k <= l THEN
-					x.conval.setval := {k..l}
-				ELSE err(201); x.conval.setval := {l..k}
-				END ;
-				x.obj := NIL
-			ELSE BindNodes(Nupto, DevCPT.settyp, x, y)
-			END
-		ELSE err(93)
-		END ;
-		x.typ := DevCPT.settyp
-	END SetRange;
-
-	PROCEDURE SetElem*(VAR x: DevCPT.Node);
-		VAR k: INTEGER;
-	BEGIN
-		IF (x.class = Ntype) OR (x.class = Nproc) THEN err(126) END;
-		IF x.typ.form IN intSet THEN
-			IF x.typ.form = Int64 THEN Convert(x, DevCPT.int32typ) END;
-			IF x.class = Nconst THEN
-				k := x.conval.intval;
-				IF (0 <= k) & (k <= DevCPM.MaxSet) & (x.conval.realval = 0) THEN x.conval.setval := {k}
-				ELSE err(202)
-				END ;
-				x.obj := NIL
-			ELSE BindNodes(Nmop, DevCPT.settyp, x, NIL); x.subcl := bit
-			END ;
-		ELSE err(93)
-		END;
-		x.typ := DevCPT.settyp
-	END SetElem;
-	
-	PROCEDURE CheckAssign* (x: DevCPT.Struct; VAR ynode: DevCPT.Node);
-	(* x := y, checks assignment compatibility *)
-		VAR f, g: SHORTINT; y, b: DevCPT.Struct;
-	BEGIN
-		y := ynode.typ; f := x.form; g := y.form;
-		IF (ynode.class = Ntype) OR (ynode.class = Nproc) & (f # ProcTyp) THEN err(126) END ;
-		CASE f OF
-		| Undef, String8, String16, Byte:
-		| Bool, Set:
-			IF g # f THEN err(113) END
-		| Int8, Int16, Int32, Int64, Real32, Real64:	(* SR *)
-			IF (g IN intSet) OR (g IN realSet) & (f IN realSet) THEN
-				IF ynode.class = Nconst THEN Convert(ynode, x)
-				ELSIF ~DevCPT.Includes(f, g) THEN err(113)
-				END
-			ELSE err(113)
-			END
-(*			
-			IF ~(g IN intSet + realSet) OR ~DevCPT.Includes(f, g) & (~(g IN intSet) OR (ynode.class # Nconst)) THEN
-				err(113)
-			ELSIF ynode.class = Nconst THEN Convert(ynode, x)
-			END
-*)
-		| Char8, Char16:
-			IF ~(g IN charSet) OR ~DevCPT.Includes(f, g) THEN err(113)
-			ELSIF ynode.class = Nconst THEN Convert(ynode, x)
-			END
-		| Pointer:
-			b := x.BaseTyp;
-			IF DevCPT.Extends(y, x)
-				OR (g = NilTyp)
-				OR (g = Pointer)
-					& ((x = DevCPT.sysptrtyp) OR (DevCPM.java IN DevCPM.options) & (x = DevCPT.anyptrtyp))
-			THEN (* ok *)
-			ELSIF (b.comp = DynArr) & b.untagged THEN	(* pointer to untagged open array *)
-				IF ynode.class = Nconst THEN CheckString(ynode, b, 113)
-				ELSIF ~(y.comp IN {Array, DynArr}) OR ~DevCPT.EqualType(b.BaseTyp, y.BaseTyp) THEN err(113)
-				END
-			ELSIF b.untagged & (ynode.class = Nmop) & (ynode.subcl = adr) THEN	(* p := ADR(r) *)
-				IF (b.comp = DynArr) & (ynode.left.class = Nconst) THEN CheckString(ynode.left, b, 113)
-				ELSIF ~DevCPT.Extends(ynode.left.typ, b) THEN err(113)
-				END
-			ELSIF (b.sysflag = jstr) & ((g = String16) OR (ynode.class = Nconst) & (g IN {Char8, Char16, String8}))
-			THEN
-				IF g # String16 THEN Convert(ynode, DevCPT.string16typ) END
-			ELSE err(113)
-			END
-		| ProcTyp:
-			IF DevCPT.EqualType(x, y) OR (g = NilTyp) THEN (* ok *)
-			ELSIF (ynode.class = Nproc) & (ynode.obj.mode IN {XProc, IProc, LProc}) THEN
-				IF ynode.obj.mode = LProc THEN
-					IF ynode.obj.mnolev = 0 THEN ynode.obj.mode := XProc ELSE err(73) END
-				END;
-				IF (x.sysflag = 0) & (ynode.obj.sysflag >= 0) OR (x.sysflag = ynode.obj.sysflag) THEN
-					IF DevCPT.EqualType(x.BaseTyp, ynode.obj.typ) THEN CheckParameters(x.link, ynode.obj.link, FALSE)
-					ELSE err(117)
-					END
-				ELSE err(113)
-				END
-			ELSE err(113)
-			END
-		| NoTyp, NilTyp: err(113)
-		| Comp:
-			x.pvused := TRUE;	(* idfp of y guarantees assignment compatibility with x *)
-			IF x.comp = Record THEN
-				IF ~DevCPT.EqualType(x, y) OR (x.attribute # 0) THEN err(113) END
-			ELSIF g IN {Char8, Char16, String8, String16} THEN
-				IF (x.BaseTyp.form = Char16) & (g = String8) THEN Convert(ynode, DevCPT.string16typ)
-				ELSE CheckString(ynode, x, 113);
-				END;
-				IF (x # DevCPT.guidtyp) & (x.comp = Array) & (ynode.class = Nconst) & (ynode.conval.intval2 > x.n) THEN
-					err(114)
-				END
-			ELSIF (x.comp = Array) & DevCPT.EqualType(x, y) THEN (* ok *)
-			ELSE err(113)
-			END
-		END
-	END CheckAssign;
-	
-	PROCEDURE AssignString (VAR x: DevCPT.Node; str: DevCPT.Node);	(* x := str or x[0] := 0X *)
-	BEGIN
-		ASSERT((str.class = Nconst) & (str.typ.form IN {String8, String16}));
-		IF (x.typ.comp IN {Array, DynArr}) & (str.conval.intval2 = 1) THEN	(* x := "" -> x[0] := 0X *)
-			Index(x, NewIntConst(0));
-			str.typ := x.typ; str.conval.intval := 0;
-		END;
-		BindNodes(Nassign, DevCPT.notyp, x, str); x.subcl := assign
-	END AssignString;
-	
-	PROCEDURE CheckLeaf(x: DevCPT.Node; dynArrToo: BOOLEAN);
-	BEGIN
-		IF (x.class = Nmop) & (x.subcl = val) THEN x := x.left END ;
-		IF x.class = Nguard THEN x := x.left END ;	(* skip last (and unique) guard *)
-		IF (x.class = Nvar) & (dynArrToo OR (x.typ.comp # DynArr)) THEN x.obj.leaf := FALSE END
-	END CheckLeaf;
-	
-	PROCEDURE CheckOldType (x: DevCPT.Node);
-	BEGIN
-		IF ~(DevCPM.oberon IN DevCPM.options)
-			& ((x.typ = DevCPT.lreal64typ) OR (x.typ = DevCPT.lint64typ) OR (x.typ = DevCPT.lchar16typ)) THEN
-			err(198)
-		END
-	END CheckOldType;
-	
-	PROCEDURE StPar0*(VAR par0: DevCPT.Node; fctno: SHORTINT);	(* par0: first param of standard proc *)
-		VAR f: SHORTINT; typ: DevCPT.Struct; x, t: DevCPT.Node;
-	BEGIN x := par0; f := x.typ.form;
-		CASE fctno OF
-		  haltfn: (*HALT*)
-				IF (f IN intSet - {Int64}) & (x.class = Nconst) THEN
-					IF (DevCPM.MinHaltNr <= x.conval.intval) & (x.conval.intval <= DevCPM.MaxHaltNr) THEN
-						BindNodes(Ntrap, DevCPT.notyp, x, x)
-					ELSE err(218)
-					END
-				ELSIF (DevCPM.java IN DevCPM.options)
-					& ((x.class = Ntype) OR (x.class = Nvar))
-					& (x.typ.form = Pointer)
-				THEN
-					BindNodes(Ntrap, DevCPT.notyp, x, x)
-				ELSE err(69)
-				END ;
-				x.typ := DevCPT.notyp
-		| newfn: (*NEW*)
-				typ := DevCPT.notyp;
-				IF NotVar(x) THEN err(112)
-				ELSIF f = Pointer THEN
-					IF DevCPM.NEWusingAdr THEN CheckLeaf(x, TRUE) END ;
-					IF x.readonly THEN err(76)
-					ELSIF (x.typ.BaseTyp.attribute = absAttr)
-						OR (x.typ.BaseTyp.attribute = limAttr) & (x.typ.BaseTyp.mno # 0) THEN err(193)
-					ELSIF (x.obj # NIL) & ODD(x.obj.sysflag DIV newBit) THEN err(167)
-					END ;
-					MarkAsUsed(x);
-					f := x.typ.BaseTyp.comp;
-					IF f IN {Record, DynArr, Array} THEN
-						IF f = DynArr THEN typ := x.typ.BaseTyp END ;
-						BindNodes(Nassign, DevCPT.notyp, x, NIL); x.subcl := newfn
-					ELSE err(111)
-					END
-				ELSE err(111)
-				END ;
-				x.typ := typ
-		| absfn: (*ABS*)
-				MOp(abs, x)
-		| capfn: (*CAP*)
-				MOp(cap, x)
-		| ordfn: (*ORD*) 
-				IF (x.class = Ntype) OR (x.class = Nproc) THEN err(126)
-				ELSIF f = Char8 THEN Convert(x, DevCPT.int16typ)
-				ELSIF f = Char16 THEN Convert(x, DevCPT.int32typ)
-				ELSIF f = Set THEN Convert(x, DevCPT.int32typ)
-				ELSE err(111)
-				END
-		| bitsfn: (*BITS*)
-				IF (x.class = Ntype) OR (x.class = Nproc) THEN err(126)
-				ELSIF f IN {Int8, Int16, Int32} THEN Convert(x, DevCPT.settyp)
-				ELSE err(111)
-				END
-		| entierfn: (*ENTIER*)
-				IF (x.class = Ntype) OR (x.class = Nproc) THEN err(126)
-				ELSIF f IN realSet THEN Convert(x, DevCPT.int64typ)
-				ELSE err(111)
-				END ;
-				x.typ := DevCPT.int64typ
-		| lentierfcn: (* LENTIER *)
-				IF ~(DevCPM.oberon IN DevCPM.options) THEN err(199) END;
-				IF (x.class = Ntype) OR (x.class = Nproc) THEN err(126)
-				ELSIF f IN realSet THEN Convert(x, DevCPT.int64typ)
-				ELSE err(111)
-				END ;
-				x.typ := DevCPT.int64typ
-		| oddfn: (*ODD*)
-				MOp(odd, x)
-		| minfn: (*MIN*)
-				IF x.class = Ntype THEN
-					CheckOldType(x);
-					CASE f OF
-					  Bool:  x := NewBoolConst(FALSE)
-					| Char8:  x := NewIntConst(0); x.typ := DevCPT.char8typ
-					| Char16:  x := NewIntConst(0); x.typ := DevCPT.char8typ
-					| Int8:  x := NewIntConst(-128)
-					| Int16:   x := NewIntConst(-32768)
-					| Int32:  x := NewIntConst(-2147483648)
-					| Int64:  x := NewLargeIntConst(0, -9223372036854775808.0E0)	(* -2^63 *)
-					| Set:   x := NewIntConst(0) (*; x.typ := DevCPT.int16typ *)
-					| Real32:  x := NewRealConst(DevCPM.MinReal32, DevCPT.real64typ)
-					| Real64: x := NewRealConst(DevCPM.MinReal64, DevCPT.real64typ)
-					ELSE err(111)
-					END;
-					x.hint := 1
-				ELSIF ~(f IN intSet + realSet + charSet) THEN err(111)
-				END
-		| maxfn: (*MAX*)
-				IF x.class = Ntype THEN
-					CheckOldType(x);
-					CASE f OF
-					  Bool:  x := NewBoolConst(TRUE)
-					| Char8:  x := NewIntConst(0FFH); x.typ := DevCPT.char8typ
-					| Char16:  x := NewIntConst(0FFFFH); x.typ := DevCPT.char16typ
-					| Int8:  x := NewIntConst(127)
-					| Int16:   x := NewIntConst(32767)
-					| Int32:  x := NewIntConst(2147483647)
-					| Int64:  x := NewLargeIntConst(-1, 9223372036854775808.0E0)	(* 2^63 - 1 *)
-					| Set:   x := NewIntConst(31) (*; x.typ := DevCPT.int16typ *)
-					| Real32:  x := NewRealConst(DevCPM.MaxReal32, DevCPT.real64typ)
-					| Real64: x := NewRealConst(DevCPM.MaxReal64, DevCPT.real64typ)
-					ELSE err(111)
-					END;
-					x.hint := 1
-				ELSIF ~(f IN intSet + realSet + charSet) THEN err(111)
-				END
-		| chrfn: (*CHR*) 
-				IF (x.class = Ntype) OR (x.class = Nproc) THEN err(126)
-				ELSIF f IN {Undef, Int8..Int32, Int64} THEN Convert(x, DevCPT.char16typ)
-				ELSE err(111); x.typ := DevCPT.char16typ
-				END
-		| lchrfn: (* LCHR *)
-				IF ~(DevCPM.oberon IN DevCPM.options) THEN err(199) END;
-				IF (x.class = Ntype) OR (x.class = Nproc) THEN err(126)
-				ELSIF f IN {Undef, Int8..Int32, Int64} THEN Convert(x, DevCPT.char16typ)
-				ELSE err(111); x.typ := DevCPT.char16typ
-				END
-		| shortfn: (*SHORT*)
-				IF (x.class = Ntype) OR (x.class = Nproc) THEN err(126)
-				ELSE
-					IF (x.typ.comp IN {Array, DynArr}) & (x.typ.BaseTyp.form IN charSet) THEN StrDeref(x); f := x.typ.form
-					END;
-					IF f = Int16 THEN Convert(x, DevCPT.int8typ)
-					ELSIF f = Int32 THEN Convert(x, DevCPT.int16typ)
-					ELSIF f = Int64 THEN Convert(x, DevCPT.int32typ)
-					ELSIF f = Real64 THEN Convert(x, DevCPT.real32typ)
-					ELSIF f = Char16 THEN Convert(x, DevCPT.char8typ)
-					ELSIF f = String16 THEN Convert(x, DevCPT.string8typ)
-					ELSE err(111)
-					END
-				END
-		| longfn: (*LONG*)
-				IF (x.class = Ntype) OR (x.class = Nproc) THEN err(126)
-				ELSE
-					IF (x.typ.comp IN {Array, DynArr}) & (x.typ.BaseTyp.form IN charSet) THEN StrDeref(x); f := x.typ.form
-					END;
-					IF f = Int8 THEN Convert(x, DevCPT.int16typ)
-					ELSIF f = Int16 THEN Convert(x, DevCPT.int32typ)
-					ELSIF f = Int32 THEN Convert(x, DevCPT.int64typ)
-					ELSIF f = Real32 THEN Convert(x, DevCPT.real64typ)
-					ELSIF f = Char8 THEN Convert(x, DevCPT.char16typ)
-					ELSIF f = String8 THEN Convert(x, DevCPT.string16typ)
-					ELSE err(111)
-					END
-				END
-		| incfn, decfn: (*INC, DEC*) 
-				IF NotVar(x) THEN err(112)
-				ELSIF ~(f IN intSet) THEN err(111)
-				ELSIF x.readonly THEN err(76)
-				END;
-				MarkAsUsed(x)
-		| inclfn, exclfn: (*INCL, EXCL*)
-				IF NotVar(x) THEN err(112)
-				ELSIF f # Set THEN err(111); x.typ := DevCPT.settyp
-				ELSIF x.readonly THEN err(76)
-				END;
-				MarkAsUsed(x)
-		| lenfn: (*LEN*)
-				IF (* (x.class = Ntype) OR *) (x.class = Nproc) THEN err(126)	(* !!! *)
-				(* ELSIF x.typ.sysflag = jstr THEN StrDeref(x) *)
-				ELSE
-					IF x.typ.form = Pointer THEN DeRef(x) END;
-					IF x.class = Nconst THEN
-						IF x.typ.form = Char8 THEN CharToString8(x)
-						ELSIF x.typ.form = Char16 THEN CharToString16(x)
-						END
-					END;
-					IF ~(x.typ.comp IN {DynArr, Array}) & ~(x.typ.form IN {String8, String16}) THEN err(131) END
-				END
-		| copyfn: (*COPY*)
-				IF ~(DevCPM.oberon IN DevCPM.options) THEN err(199) END;
-				IF (x.class = Ntype) OR (x.class = Nproc) THEN err(126) END
-		| ashfn: (*ASH*)
-				IF (x.class = Ntype) OR (x.class = Nproc) THEN err(126)
-				ELSIF f IN intSet THEN
-					IF f < Int32 THEN Convert(x, DevCPT.int32typ) END
-				ELSE err(111); x.typ := DevCPT.int32typ
-				END
-		| adrfn: (*ADR*)
-				IF x.class = Ntype THEN CheckOldType(x) END;
-				CheckLeaf(x, FALSE); MOp(adr, x)
-		| typfn: (*TYP*)
-				CheckLeaf(x, FALSE);
-				IF x.class = Ntype THEN
-					CheckOldType(x);
-					IF x.typ.form = Pointer THEN x := NewLeaf(x.typ.BaseTyp.strobj) END;
-					IF x.typ.comp # Record THEN err(111) END;
-					MOp(adr, x)
-				ELSE
-					IF x.typ.form = Pointer THEN DeRef(x) END;
-					IF x.typ.comp # Record THEN err(111) END;
-					MOp(typfn, x)
-				END
-		| sizefn: (*SIZE*)
-				IF x.class # Ntype THEN err(110); x := NewIntConst(1)
-				ELSIF (f IN {Byte..Set, Pointer, ProcTyp, Char16, Int64}) OR (x.typ.comp IN {Array, Record}) THEN
-					CheckOldType(x); x.typ.pvused := TRUE;
-					IF typSize # NIL THEN
-						typSize(x.typ); x := NewIntConst(x.typ.size)
-					ELSE
-						MOp(size, x)
-					END
-				ELSE err(111); x := NewIntConst(1)
-				END
-		| thisrecfn, (*THISRECORD*)
-		  thisarrfn: (*THISARRAY*)
-				IF (x.class = Ntype) OR (x.class = Nproc) THEN err(126)
-				ELSIF f IN {Int8, Int16} THEN Convert(x, DevCPT.int32typ)
-				ELSIF f # Int32 THEN err(111)
-				END
-		| ccfn: (*SYSTEM.CC*)
-				MOp(cc, x)
-		| lshfn, rotfn: (*SYSTEM.LSH, SYSTEM.ROT*)
-				IF (x.class = Ntype) OR (x.class = Nproc) THEN err(126)
-				ELSIF ~(f IN intSet + charSet + {Byte, Set}) THEN err(111)
-				END
-		| getfn, putfn, bitfn, movefn: (*SYSTEM.GET, SYSTEM.PUT, SYSTEM.BIT, SYSTEM.MOVE*)
-				IF (x.class = Ntype) OR (x.class = Nproc) THEN err(126)
-				ELSIF (x.class = Nconst) & (f IN {Int8, Int16}) THEN Convert(x, DevCPT.int32typ)
-				ELSIF ~(f IN {Int32, Pointer}) THEN err(111); x.typ := DevCPT.int32typ
-				END
-		| getrfn, putrfn: (*SYSTEM.GETREG, SYSTEM.PUTREG*)
-				IF (f IN intSet) & (x.class = Nconst) THEN
-					IF (x.conval.intval < DevCPM.MinRegNr) OR (x.conval.intval > DevCPM.MaxRegNr) THEN err(220)
-					END
-				ELSE err(69)
-				END
-		| valfn: (*SYSTEM.VAL*)
-				IF x.class # Ntype THEN err(110)
-				ELSIF (f IN {Undef, String8, String16, NoTyp, NilTyp}) (* OR (x.typ.comp = DynArr) *) THEN err(111)
-				ELSE CheckOldType(x)
-				END
-		| assertfn: (*ASSERT*)
-				IF (x.class = Ntype) OR (x.class = Nproc) THEN err(126); x := NewBoolConst(FALSE)
-				ELSIF f # Bool THEN err(120); x := NewBoolConst(FALSE)
-				ELSE MOp(not, x)
-				END
-		| validfn: (* VALID *)
-				IF (x.class = Nvarpar) & ODD(x.obj.sysflag DIV nilBit) THEN
-					MOp(adr, x); x.typ := DevCPT.sysptrtyp; Op(neq, x, Nil())
-				ELSE err(111)
-				END;
-				x.typ := DevCPT.booltyp
-		| iidfn: (* COM.IID *)
-				IF (x.class = Nconst) & (f = String8) THEN StringToGuid(x)
-				ELSE
-					typ := x.typ;
-					IF typ.form = Pointer THEN typ := typ.BaseTyp END;
-					IF (typ.sysflag = interface) & (typ.ext # NIL) & (typ.strobj # NIL) THEN
-						IF x.obj # typ.strobj THEN x := NewLeaf(typ.strobj) END
-					ELSE err(111)
-					END;
-					x.class := Nconst; x.typ := DevCPT.guidtyp
-				END
-		| queryfn: (* COM.QUERY *)
-				IF (x.class = Ntype) OR (x.class = Nproc) THEN err(126)
-				ELSIF f # Pointer THEN err(111)
-				END
-		END ;
-		par0 := x
-	END StPar0;
-
-	PROCEDURE StPar1*(VAR par0: DevCPT.Node; x: DevCPT.Node; fctno: BYTE);
-	(* x: second parameter of standard proc *)
-		VAR f, n, L, i: INTEGER; typ, tp1: DevCPT.Struct; p, t: DevCPT.Node;
-		
-		PROCEDURE NewOp(class, subcl: BYTE; left, right: DevCPT.Node): DevCPT.Node;
-			VAR node: DevCPT.Node;
-		BEGIN
-			node := DevCPT.NewNode(class); node.subcl := subcl;
-			node.left := left; node.right := right; RETURN node
-		END NewOp;
-		
-	BEGIN p := par0; f := x.typ.form;
-		CASE fctno OF
-		  incfn, decfn: (*INC DEC*)
-				IF (x.class = Ntype) OR (x.class = Nproc) THEN err(126); p.typ := DevCPT.notyp
-				ELSE
-					IF f # p.typ.form THEN
-						IF f IN intSet THEN Convert(x, p.typ)
-						ELSE err(111)
-						END
-					END ;
-					p := NewOp(Nassign, fctno, p, x);
-					p.typ := DevCPT.notyp
-				END
-		| inclfn, exclfn: (*INCL, EXCL*)
-				IF (x.class = Ntype) OR (x.class = Nproc) THEN err(126)
-				ELSIF f IN intSet THEN
-					IF f = Int64 THEN Convert(x, DevCPT.int32typ) END;
-					IF (x.class = Nconst) & ((0 > x.conval.intval) OR (x.conval.intval > DevCPM.MaxSet)) THEN err(202)
-					END ;
-					p := NewOp(Nassign, fctno, p, x)
-				ELSE err(111)
-				END ;
-				p.typ := DevCPT.notyp
-		| lenfn: (*LEN*)
-				IF ~(f IN intSet) OR (x.class # Nconst) THEN err(69)
-				ELSE
-					IF f = Int64 THEN Convert(x, DevCPT.int32typ) END;
-					L := SHORT(x.conval.intval); typ := p.typ;
-					WHILE (L > 0) & (typ.comp IN {DynArr, Array}) DO typ := typ.BaseTyp; DEC(L) END ;
-					IF (L # 0) OR ~(typ.comp IN {DynArr, Array}) THEN err(132)
-					ELSE x.obj := NIL;
-						IF typ.comp = DynArr THEN
-							WHILE p.class = Nindex DO
-								p := p.left; INC(x.conval.intval) (* possible side effect ignored *)
-							END;
-							p := NewOp(Ndop, len, p, x); p.typ := DevCPT.int32typ
-						ELSE p := x; p.conval.intval := typ.n; p.typ := DevCPT.int32typ
-						END
-					END
-				END
-		| copyfn: (*COPY*)
-				IF NotVar(x) THEN err(112)
-				ELSIF x.readonly THEN err(76)
-				ELSE
-					CheckString(p, x.typ, 111); t := x; x := p; p := t;
-					IF (x.class = Nconst) & (x.typ.form IN {String8, String16}) THEN AssignString(p, x)
-					ELSE p := NewOp(Nassign, copyfn, p, x)
-					END
-				END ;
-				p.typ := DevCPT.notyp; MarkAsUsed(x)
-		| ashfn: (*ASH*)
-				IF (x.class = Ntype) OR (x.class = Nproc) THEN err(126)
-				ELSIF f IN intSet THEN
-					IF (x.class = Nconst) & ((x.conval.intval > 64) OR (x.conval.intval < -64)) THEN err(208)
-					ELSIF (p.class = Nconst) & (x.class = Nconst) THEN
-						n := x.conval.intval;
-						IF n > 0 THEN
-							WHILE n > 0 DO MulConst(p.conval, two, p.conval, p.typ); DEC(n) END
-						ELSE
-							WHILE n < 0 DO DivModConst(p.conval, two, TRUE, p.typ); INC(n) END
-						END;
-						p.obj := NIL
-					ELSE
-						IF f = Int64 THEN Convert(x, DevCPT.int32typ) END;
-						typ := p.typ; p := NewOp(Ndop, ash, p, x); p.typ := typ
-					END
-				ELSE err(111)
-				END
-		| minfn: (*MIN*)
-				IF p.class # Ntype THEN Op(min, p, x) ELSE err(64) END
-		| maxfn: (*MAX*)
-				IF p.class # Ntype THEN Op(max, p, x) ELSE err(64) END
-		| newfn: (*NEW(p, x...)*)
-				IF (x.class = Ntype) OR (x.class = Nproc) THEN err(126)
-				ELSIF p.typ.comp = DynArr THEN
-					IF f IN intSet THEN
-						IF f = Int64 THEN Convert(x, DevCPT.int32typ) END;
-						IF (x.class = Nconst) & (x.conval.intval <= 0)
-							& (~(DevCPM.java IN DevCPM.options) OR (x.conval.intval < 0))THEN err(63) END
-					ELSE err(111)
-					END ;
-					p.right := x; p.typ := p.typ.BaseTyp
-				ELSIF (p.left # NIL) & (p.left.typ.form = Pointer) THEN
-					typ := p.left.typ;
-					WHILE (typ # DevCPT.undftyp) & (typ.BaseTyp # NIL) DO typ := typ.BaseTyp END;
-					IF typ.sysflag = interface THEN
-						typ := x.typ;
-						WHILE (typ # DevCPT.undftyp) & (typ.BaseTyp # NIL) DO typ := typ.BaseTyp END;
-						IF (f = Pointer) & (typ.sysflag = interface) THEN
-							p.right := x
-						ELSE err(169)
-						END
-					ELSE err(64)
-					END
-				ELSE err(111)
-				END
-		| thisrecfn, (*THISRECORD*)
-		  thisarrfn: (*THISARRAY*)
-				IF (x.class = Ntype) OR (x.class = Nproc) THEN err(126)
-				ELSIF f IN {Int8, Int16, Int32} THEN
-					IF f < Int32 THEN Convert(x, DevCPT.int32typ) END;
-					p := NewOp(Ndop, fctno, p, x); p.typ := DevCPT.undftyp
-				ELSE err(111)
-				END
-		| lshfn, rotfn: (*SYSTEM.LSH, SYSTEM.ROT*)
-				IF (x.class = Ntype) OR (x.class = Nproc) THEN err(126)
-				ELSIF ~(f IN intSet) THEN err(111)
-				ELSE
-					IF fctno = lshfn THEN p := NewOp(Ndop, lsh, p, x) ELSE p := NewOp(Ndop, rot, p, x) END ;
-					p.typ := p.left.typ
-				END
-		| getfn, putfn, getrfn, putrfn: (*SYSTEM.GET, SYSTEM.PUT, SYSTEM.GETREG, SYSTEM.PUTREG*)
-				IF (x.class = Ntype) OR (x.class = Nproc) THEN err(126)
-				ELSIF f IN {Undef..Set, NilTyp, Pointer, ProcTyp, Char16, Int64} THEN
-					IF (fctno = getfn) OR (fctno = getrfn) THEN
-						IF NotVar(x) THEN err(112) END ;
-						t := x; x := p; p := t
-					END ;
-					p := NewOp(Nassign, fctno, p, x)
-				ELSE err(111)
-				END ;
-				p.typ := DevCPT.notyp
-		| bitfn: (*SYSTEM.BIT*)
-				IF (x.class = Ntype) OR (x.class = Nproc) THEN err(126)
-				ELSIF f IN intSet THEN
-					p := NewOp(Ndop, bit, p, x)
-				ELSE err(111)
-				END ;
-				p.typ := DevCPT.booltyp
-		| valfn: (*SYSTEM.VAL*)	(* type is changed without considering the byte ordering on the target machine *)
-				IF (x.class = Ntype) OR (x.class = Nproc) THEN err(126)
-				ELSIF x.typ.comp = DynArr THEN
-					IF x.typ.untagged & ((p.typ.comp # DynArr) OR p.typ.untagged) THEN	(* ok *)
-					ELSIF (p.typ.comp = DynArr) & (x.typ.n = p.typ.n) THEN
-						typ := x.typ;
-						WHILE typ.comp = DynArr DO typ := typ.BaseTyp END;
-						tp1 := p.typ;
-						WHILE tp1.comp = DynArr DO tp1 := tp1.BaseTyp END;
-						IF typ.size # tp1.size THEN err(115) END
-					ELSE err(115)
-					END
-				ELSIF p.typ.comp = DynArr THEN err(115)
-				ELSIF (x.class = Nconst) & (f = String8) & (p.typ.form = Int32) & (x.conval.intval2 <= 5) THEN
-					i := 0; n := 0;
-					WHILE i < x.conval.intval2 - 1 DO n := 256 * n + ORD(x.conval.ext[i]); INC(i) END;
-					x := NewIntConst(n)
-				ELSIF (f IN {Undef, NoTyp, NilTyp}) OR (f IN {String8, String16}) & ~(DevCPM.java IN DevCPM.options) THEN err(111)
-				END ;
-				IF (x.class = Nconst) & (x.typ = p.typ) THEN	(* ok *)
-				ELSIF (x.class >= Nconst) OR ((f IN realSet) # (p.typ.form IN realSet))
-						OR (DevCPM.options * {DevCPM.java, DevCPM.allSysVal} # {}) THEN
-					t := DevCPT.NewNode(Nmop); t.subcl := val; t.left := x; x := t
-				ELSE x.readonly := FALSE
-				END ;
-				x.typ := p.typ; p := x
-		| movefn: (*SYSTEM.MOVE*)
-				IF (x.class = Ntype) OR (x.class = Nproc) THEN err(126)
-				ELSIF (x.class = Nconst) & (f IN {Int8, Int16}) THEN Convert(x, DevCPT.int32typ)
-				ELSIF ~(f IN {Int32, Pointer}) THEN err(111); x.typ := DevCPT.int32typ
-				END ;
-				p.link := x
-		| assertfn: (*ASSERT*)
-				IF (f IN intSet - {Int64}) & (x.class = Nconst) THEN
-					IF (DevCPM.MinHaltNr <= x.conval.intval) & (x.conval.intval <= DevCPM.MaxHaltNr) THEN
-						BindNodes(Ntrap, DevCPT.notyp, x, x);
-						Construct(Nif, p, x); Construct(Nifelse, p, NIL); OptIf(p);
-					ELSE err(218)
-					END
-				ELSIF
-					(DevCPM.java IN DevCPM.options) & ((x.class = Ntype) OR (x.class = Nvar)) & (x.typ.form = Pointer)
-				THEN
-					BindNodes(Ntrap, DevCPT.notyp, x, x);
-					Construct(Nif, p, x); Construct(Nifelse, p, NIL); OptIf(p);
-				ELSE err(69)
-				END;
-				IF p = NIL THEN	(* ASSERT(TRUE) *)
-				ELSIF p.class = Ntrap THEN err(99)
-				ELSE p.subcl := assertfn
-				END
-		| queryfn: (* COM.QUERY *)
-				IF (x.class = Ntype) OR (x.class = Nproc) THEN err(126)
-				ELSIF x.typ # DevCPT.guidtyp THEN err(111); x.typ := DevCPT.guidtyp
-				END;
-				p.link := x
-		ELSE err(64)
-		END ;
-		par0 := p
-	END StPar1;
-
-	PROCEDURE StParN*(VAR par0: DevCPT.Node; x: DevCPT.Node; fctno, n: SHORTINT);
-	(* x: n+1-th param of standard proc *)
-		VAR node: DevCPT.Node; f: SHORTINT; p: DevCPT.Node; typ: DevCPT.Struct;
-	BEGIN p := par0; f := x.typ.form;
-		IF fctno = newfn THEN (*NEW(p, ..., x...*)
-			IF (x.class = Ntype) OR (x.class = Nproc) THEN err(126)
-			ELSIF p.typ.comp # DynArr THEN err(64)
-			ELSIF f IN intSet THEN
-				IF f = Int64 THEN Convert(x, DevCPT.int32typ) END;
-				IF (x.class = Nconst) & (x.conval.intval <= 0) THEN err(63) END;
-				node := p.right; WHILE node.link # NIL DO node := node.link END;
-				node.link := x; p.typ := p.typ.BaseTyp
-			ELSE err(111)
-			END
-		ELSIF (fctno = movefn) & (n = 2) THEN (*SYSTEM.MOVE*)
-			IF (x.class = Ntype) OR (x.class = Nproc) THEN err(126)
-			ELSIF f IN intSet THEN
-				node := DevCPT.NewNode(Nassign); node.subcl := movefn; node.right := p;
-				node.left := p.link; p.link := x; p := node
-			ELSE err(111)
-			END ;
-			p.typ := DevCPT.notyp
-		ELSIF (fctno = queryfn) & (n = 2) THEN (* COM.QUERY *)
-			IF (x.class = Ntype) OR (x.class = Nproc) THEN err(126)
-			ELSIF (x.class < Nconst) & (f = Pointer) & (x.typ.sysflag = interface) THEN
-				IF ~DevCPT.Extends(p.typ, x.typ) THEN err(164) END;
-				IF x.readonly THEN err(76) END;
-				CheckNewParamPair(x, p.link);
-				MarkAsUsed(x);
-				node := DevCPT.NewNode(Ndop); node.subcl := queryfn;
-				node.left := p; node.right := p.link; p.link := NIL; node.right.link := x; p := node
-			ELSE err(111)
-			END;
-			p.typ := DevCPT.booltyp
-		ELSE err(64)
-		END ;
-		par0 := p
-	END StParN;
-
-	PROCEDURE StFct*(VAR par0: DevCPT.Node; fctno: BYTE; parno: SHORTINT);
-		VAR dim: SHORTINT; x, p: DevCPT.Node;
-	BEGIN p := par0;
-		IF fctno <= ashfn THEN
-			IF (fctno = newfn) & (p.typ # DevCPT.notyp) THEN
-				IF p.typ.comp = DynArr THEN err(65) END ;
-				p.typ := DevCPT.notyp
-			ELSIF (fctno = minfn) OR (fctno = maxfn) THEN
-				IF (parno < 1) OR (parno = 1) & (p.hint # 1) THEN err(65) END;
-				p.hint := 0
-			ELSIF fctno <= sizefn THEN (* 1 param *)
-				IF parno < 1 THEN err(65) END
-			ELSE (* more than 1 param *)
-				IF ((fctno = incfn) OR (fctno = decfn)) & (parno = 1) THEN (*INC, DEC*)
-					BindNodes(Nassign, DevCPT.notyp, p, NewIntConst(1)); p.subcl := fctno; p.right.typ := p.left.typ
-				ELSIF (fctno = lenfn) & (parno = 1) THEN (*LEN*)
-					IF p.typ.form IN {String8, String16} THEN
-						IF p.class = Nconst THEN p := NewIntConst(p.conval.intval2 - 1)
-						ELSIF (p.class = Ndop) & (p.subcl = plus) THEN	(* propagate to leaf nodes *)
-							StFct(p.left, lenfn, 1); StFct(p.right, lenfn, 1); p.typ := DevCPT.int32typ
-						ELSE
-							WHILE (p.class = Nmop) & (p.subcl = conv) DO p := p.left END;
-							IF DevCPM.errors = 0 THEN ASSERT(p.class = Nderef) END;
-							BindNodes(Ndop, DevCPT.int32typ, p, NewIntConst(0)); p.subcl := len
-						END
-					ELSIF p.typ.comp = DynArr THEN dim := 0;
-						WHILE p.class = Nindex DO p := p.left; INC(dim) END ;	(* possible side effect ignored *)
-						BindNodes(Ndop, DevCPT.int32typ, p, NewIntConst(dim)); p.subcl := len
-					ELSE
-						p := NewIntConst(p.typ.n)
-					END
-				ELSIF parno < 2 THEN err(65)
-				END
-			END
-		ELSIF fctno = assertfn THEN
-			IF parno = 1 THEN x := NIL;
-				BindNodes(Ntrap, DevCPT.notyp, x, NewIntConst(AssertTrap));
-				Construct(Nif, p, x); Construct(Nifelse, p, NIL); OptIf(p);
-				IF p = NIL THEN	(* ASSERT(TRUE) *)
-				ELSIF p.class = Ntrap THEN err(99)
-				ELSE p.subcl := assertfn
-				END
-			ELSIF parno < 1 THEN err(65)
-			END
-		ELSIF (fctno >= lchrfn) & (fctno <= bytesfn) THEN
-			IF parno < 1 THEN err(65) END
-		ELSIF fctno < validfn THEN (*SYSTEM*)
-			IF (parno < 1) OR
-				(fctno > ccfn) & (parno < 2) OR
-				(fctno = movefn) & (parno < 3) THEN err(65)
-			END
-		ELSIF (fctno = thisrecfn) OR (fctno = thisarrfn) THEN
-			IF parno < 2 THEN err(65) END
-		ELSE (* COM *)
-			IF fctno = queryfn THEN
-				IF parno < 3 THEN err(65) END
-			ELSE
-				IF parno < 1 THEN err(65) END
-			END
-		END ;
-		par0 := p
-	END StFct;
-	
-	PROCEDURE DynArrParCheck (ftyp: DevCPT.Struct; VAR ap: DevCPT.Node; fvarpar: BOOLEAN);
-	(* check array compatibility *)
-		VAR atyp: DevCPT.Struct;
-	BEGIN (* ftyp.comp = DynArr *)
-		atyp := ap.typ;
-		IF atyp.form IN {Char8, Char16, String8, String16} THEN
-			IF ~fvarpar & (ftyp.BaseTyp.form = Char16) & (atyp.form = String8) THEN Convert(ap, DevCPT.string16typ)
-			ELSE CheckString(ap, ftyp, 67)
-			END
-		ELSE		
-			WHILE (ftyp.comp = DynArr) & ((atyp.comp IN {Array, DynArr}) OR (atyp.form IN {String8, String16})) DO
-				ftyp := ftyp.BaseTyp; atyp := atyp.BaseTyp
-			END;
-			IF ftyp.comp = DynArr THEN err(67)
-			ELSIF ~fvarpar & (ftyp.form = Pointer) & DevCPT.Extends(atyp, ftyp) THEN (* ok *)
-			ELSIF ~DevCPT.EqualType(ftyp, atyp) THEN err(66)
-			END
-		END
-	END DynArrParCheck;
-
-	PROCEDURE PrepCall*(VAR x: DevCPT.Node; VAR fpar: DevCPT.Object);
-	BEGIN
-		IF (x.obj # NIL) & (x.obj.mode IN {LProc, XProc, TProc, CProc}) THEN
-			fpar := x.obj.link;
-			IF x.obj.mode = TProc THEN
-				IF fpar.typ.form = Pointer THEN
-					IF x.left.class = Nderef THEN x.left := x.left.left (*undo DeRef*) ELSE err(71) END
-				END;
-				fpar := fpar.link
-			END
-		ELSIF (x.class # Ntype) & (x.typ # NIL) & (x.typ.form = ProcTyp) THEN
-			fpar := x.typ.link
-		ELSE err(121); fpar := NIL; x.typ := DevCPT.undftyp
-		END
-	END PrepCall;
-
-	PROCEDURE Param* (VAR ap: DevCPT.Node; fp: DevCPT.Object);	(* checks parameter compatibilty *)
-		VAR at, ft: DevCPT.Struct;
-	BEGIN
-		at := ap.typ; ft := fp.typ;
-		IF fp.ptyp # NIL THEN ft := fp.ptyp END;	(* get original formal type *)
-		IF ft.form # Undef THEN
-			IF (ap.class = Ntype) OR (ap.class = Nproc) & (ft.form # ProcTyp) THEN err(126) END;
-			IF fp.mode = VarPar THEN
-				IF ODD(fp.sysflag DIV nilBit) & (at = DevCPT.niltyp) THEN (* ok *)
-				ELSIF (ft.comp = Record) & ~ft.untagged & (ap.class = Ndop) & (ap.subcl = thisrecfn) THEN (* ok *)
-				ELSIF (ft.comp = DynArr) & ~ft.untagged & (ft.n = 0) & (ap.class = Ndop) & (ap.subcl = thisarrfn) THEN
-					(* ok *)
-				ELSE
-					IF fp.vis = inPar THEN
-						IF (ft = DevCPT.guidtyp) & (ap.class = Nconst) & (at.form = String8) THEN
-							StringToGuid(ap); at := ap.typ
-(*
-						ELSIF ((at.form IN charSet + {String8, String16}) OR (at = DevCPT.guidtyp))
-								& ((ap.class = Nderef) OR (ap.class = Nconst)) THEN (* ok *)
-						ELSIF NotVar(ap) THEN err(122)
-*)
-						END;
-						IF ~NotVar(ap) THEN CheckLeaf(ap, FALSE) END
-					ELSE
-						IF NotVar(ap) THEN err(122)
-						ELSIF ap.readonly THEN err(76)
-						ELSIF (ap.obj # NIL) & ODD(ap.obj.sysflag DIV newBit) & ~ODD(fp.sysflag DIV newBit) THEN		
-							err(167)
-						ELSE MarkAsUsed(ap); CheckLeaf(ap, FALSE)
-						END
-					END;
-					IF ft.comp = DynArr THEN DynArrParCheck(ft, ap, fp.vis # inPar)
-					ELSIF ODD(fp.sysflag DIV newBit) THEN
-						IF ~DevCPT.Extends(at, ft) THEN err(123) END
-					ELSIF (ft = DevCPT.sysptrtyp) & (at.form = Pointer) THEN (* ok *)
-					ELSIF (fp.vis # outPar) & (ft.comp = Record) & DevCPT.Extends(at, ft) THEN (* ok *)
-					ELSIF covarOut & (fp.vis = outPar) & (ft.form = Pointer) & DevCPT.Extends(ft, at) THEN (* ok *)
-					ELSIF fp.vis = inPar THEN CheckAssign(ft, ap)
-					ELSIF ~DevCPT.EqualType(ft, at) THEN err(123)
-					END
-				END
-			ELSIF ft.comp = DynArr THEN DynArrParCheck(ft, ap, FALSE)
-			ELSE CheckAssign(ft, ap)
-			END
-		END
-	END Param;
-	
-	PROCEDURE StaticLink*(dlev: BYTE; var: BOOLEAN);
-		VAR scope: DevCPT.Object;
-	BEGIN
-		scope := DevCPT.topScope;
-		WHILE dlev > 0 DO DEC(dlev);
-			INCL(scope.link.conval.setval, slNeeded);
-			scope := scope.left
-		END;
-		IF var THEN INCL(scope.link.conval.setval, imVar) END	(* !!! *)
-	END StaticLink;
-
-	PROCEDURE Call*(VAR x: DevCPT.Node; apar: DevCPT.Node; fp: DevCPT.Object);
-		VAR typ: DevCPT.Struct; p: DevCPT.Node; lev: BYTE;
-	BEGIN
-		IF x.class = Nproc THEN typ := x.typ;
-			lev := x.obj.mnolev;
-			IF lev > 0 THEN StaticLink(SHORT(SHORT(DevCPT.topScope.mnolev-lev)), FALSE) END ;	(* !!! *)
-			IF x.obj.mode = IProc THEN err(121) END
-		ELSIF (x.class = Nfield) & (x.obj.mode = TProc) THEN typ := x.typ;
-			x.class := Nproc; p := x.left; x.left := NIL; p.link := apar; apar := p; fp := x.obj.link
-		ELSE typ := x.typ.BaseTyp
-		END ;
-		BindNodes(Ncall, typ, x, apar); x.obj := fp
-	END Call;
-
-	PROCEDURE Enter*(VAR procdec: DevCPT.Node; stat: DevCPT.Node; proc: DevCPT.Object);
-		VAR x: DevCPT.Node;
-	BEGIN
-		x := DevCPT.NewNode(Nenter); x.typ := DevCPT.notyp; x.obj := proc;
-		x.left := procdec; x.right := stat; procdec := x
-	END Enter;
-	
-	PROCEDURE Return*(VAR x: DevCPT.Node; proc: DevCPT.Object);
-		VAR node: DevCPT.Node;
-	BEGIN
-		IF proc = NIL THEN (* return from module *)
-			IF x # NIL THEN err(124) END
-		ELSE
-			IF x # NIL THEN CheckAssign(proc.typ, x)
-			ELSIF proc.typ # DevCPT.notyp THEN err(124)
-			END
-		END ;
-		node := DevCPT.NewNode(Nreturn); node.typ := DevCPT.notyp; node.obj := proc; node.left := x; x := node
-	END Return;
-
-	PROCEDURE Assign*(VAR x: DevCPT.Node; y: DevCPT.Node);
-		VAR z: DevCPT.Node;
-	BEGIN
-		IF (x.class >= Nconst) OR (x.typ.form IN {String8, String16}) THEN err(56) END ;
-		CheckAssign(x.typ, y);
-		IF x.readonly THEN err(76)
-		ELSIF (x.obj # NIL) & ODD(x.obj.sysflag DIV newBit) THEN err(167)
-		END ;
-		MarkAsUsed(x);
-		IF (y.class = Nconst) & (y.typ.form IN {String8, String16}) & (x.typ.form # Pointer) THEN AssignString(x, y)
-		ELSE BindNodes(Nassign, DevCPT.notyp, x, y); x.subcl := assign
-		END
-	END Assign;
-	
-	PROCEDURE Inittd*(VAR inittd, last: DevCPT.Node; typ: DevCPT.Struct);
-		VAR node: DevCPT.Node;
-	BEGIN
-		node := DevCPT.NewNode(Ninittd); node.typ := typ;
-		node.conval := DevCPT.NewConst(); node.conval.intval := typ.txtpos;
-		IF inittd = NIL THEN inittd := node ELSE last.link := node END ;
-		last := node
-	END Inittd;
-	
-	(* handling of temporary variables for string operations *)
-	
-	PROCEDURE Overlap (left, right: DevCPT.Node): BOOLEAN;
-	BEGIN
-		IF right.class = Nconst THEN
-			RETURN FALSE
-		ELSIF (right.class = Ndop) & (right.subcl = plus) THEN
-			RETURN Overlap(left, right.left) OR Overlap(left, right.right)
-		ELSE
-			WHILE right.class = Nmop DO right := right.left END;
-			IF right.class = Nderef THEN right := right.left END;
-			IF left.typ.BaseTyp # right.typ.BaseTyp THEN RETURN FALSE END;
-			LOOP
-				IF left.class = Nvarpar THEN
-					WHILE (right.class = Nindex) OR (right.class = Nfield) OR (right.class = Nguard) DO
-						right := right.left
-					END;
-					RETURN (right.class # Nvar) OR (right.obj.mnolev < left.obj.mnolev)
-				ELSIF right.class = Nvarpar THEN
-					WHILE (left.class = Nindex) OR (left.class = Nfield) OR (left.class = Nguard) DO left := left.left END;
-					RETURN (left.class # Nvar) OR (left.obj.mnolev < right.obj.mnolev)
-				ELSIF (left.class = Nvar) & (right.class = Nvar) THEN
-					RETURN left.obj = right.obj
-				ELSIF (left.class = Nderef) & (right.class = Nderef) THEN
-					RETURN TRUE
-				ELSIF (left.class = Nindex) & (right.class = Nindex) THEN
-					IF (left.right.class = Nconst) & (right.right.class = Nconst)
-						& (left.right.conval.intval # right.right.conval.intval) THEN RETURN FALSE END;
-					left := left.left; right := right.left
-				ELSIF (left.class = Nfield) & (right.class = Nfield) THEN
-					IF left.obj # right.obj THEN RETURN FALSE END;
-					left := left.left; right := right.left;
-					WHILE left.class = Nguard DO left := left.left END;
-					WHILE right.class = Nguard DO right := right.left END
-				ELSE
-					RETURN FALSE
-				END
-			END
-		END
-	END Overlap;
-
-	PROCEDURE GetStaticLength (n: DevCPT.Node; OUT length: INTEGER);
-		VAR x: INTEGER;
-	BEGIN
-		IF n.class = Nconst THEN
-			length := n.conval.intval2 - 1
-		ELSIF (n.class = Ndop) & (n.subcl = plus) THEN
-			GetStaticLength(n.left, length); GetStaticLength(n.right, x);
-			IF (length >= 0) & (x >= 0) THEN length := length + x ELSE length := -1 END
-		ELSE
-			WHILE (n.class = Nmop) & (n.subcl = conv) DO n := n.left END;
-			IF (n.class = Nderef) & (n.subcl = 1) THEN n := n.left END;
-			IF n.typ.comp = Array THEN
-				length := n.typ.n - 1
-			ELSIF n.typ.comp = DynArr THEN
-				length := -1
-			ELSE	(* error case *)
-				length := 4
-			END
-		END
-	END GetStaticLength;
-
-	PROCEDURE GetMaxLength (n: DevCPT.Node; VAR stat, last: DevCPT.Node; OUT length: DevCPT.Node);
-		VAR x: DevCPT.Node; d: INTEGER; obj: DevCPT.Object;
-	BEGIN
-		IF n.class = Nconst THEN
-			length := NewIntConst(n.conval.intval2 - 1)
-		ELSIF (n.class = Ndop) & (n.subcl = plus) THEN
-			GetMaxLength(n.left, stat, last, length); GetMaxLength(n.right, stat, last, x);
-			IF (length.class = Nconst) & (x.class = Nconst) THEN ConstOp(plus, length, x)
-			ELSE BindNodes(Ndop, length.typ, length, x); length.subcl := plus
-			END
-		ELSE
-			WHILE (n.class = Nmop) & (n.subcl = conv) DO n := n.left END;
-			IF (n.class = Nderef) & (n.subcl = 1) THEN n := n.left END;
-			IF n.typ.comp = Array THEN
-				length := NewIntConst(n.typ.n - 1)
-			ELSIF n.typ.comp = DynArr THEN
-				d := 0;
-				WHILE n.class = Nindex DO n := n.left; INC(d) END;
-				ASSERT((n.class = Nderef) OR (n.class = Nvar) OR (n.class = Nvarpar));
-				IF (n.class = Nderef) & (n.left.class # Nvar) & (n.left.class # Nvarpar) THEN
-					GetTempVar("@tmp", n.left.typ, obj);
-					x := NewLeaf(obj); Assign(x, n.left); Link(stat, last, x);
-					n.left := NewLeaf(obj);	(* tree is manipulated here *)
-					n := NewLeaf(obj); DeRef(n)
-				END;
-				IF n.typ.untagged & (n.typ.comp = DynArr) & (n.typ.BaseTyp.form IN {Char8, Char16}) THEN
-					StrDeref(n);
-					BindNodes(Ndop, DevCPT.int32typ, n, NewIntConst(d)); n.subcl := len;
-					BindNodes(Ndop, DevCPT.int32typ, n, NewIntConst(1)); n.subcl := plus
-				ELSE
-					BindNodes(Ndop, DevCPT.int32typ, n, NewIntConst(d)); n.subcl := len;
-				END;
-				length := n
-			ELSE	(* error case *)
-				length := NewIntConst(4)
-			END
-		END
-	END GetMaxLength;
-
-	PROCEDURE CheckBuffering* (
-		VAR n: DevCPT.Node; left: DevCPT.Node; par: DevCPT.Object; VAR stat, last: DevCPT.Node
-	);
-		VAR length, x: DevCPT.Node; obj: DevCPT.Object; typ: DevCPT.Struct; len, xlen: INTEGER;
-	BEGIN
-		IF (n.typ.form IN {String8, String16}) & ~(DevCPM.java IN DevCPM.options)
-			& ((n.class = Ndop) & (n.subcl = plus) & ((left = NIL) OR Overlap(left, n.right))
-				OR (n.class = Nmop) & (n.subcl = conv) & (left = NIL)
-				OR (par # NIL) & (par.vis = inPar) & (par.typ.comp = Array)) THEN
-			IF (par # NIL) & (par.typ.comp = Array) THEN
-				len := par.typ.n - 1
-			ELSE
-				IF left # NIL THEN GetStaticLength(left, len) ELSE len := -1 END;
-				GetStaticLength(n, xlen);
-				IF (len = -1) OR (xlen # -1) & (xlen < len) THEN len := xlen END
-			END;
-			IF len # -1 THEN
-				typ := DevCPT.NewStr(Comp, Array); typ.n := len + 1; typ.BaseTyp := n.typ.BaseTyp;
-				GetTempVar("@str", typ, obj);
-				x := NewLeaf(obj); Assign(x, n); Link(stat, last, x);
-				n := NewLeaf(obj)
-			ELSE
-				IF left # NIL THEN GetMaxLength(left, stat, last, length)
-				ELSE GetMaxLength(n, stat, last, length)
-				END;
-				typ := DevCPT.NewStr(Pointer, Basic);
-				typ.BaseTyp := DevCPT.NewStr(Comp, DynArr); typ.BaseTyp.BaseTyp := n.typ.BaseTyp;
-				GetTempVar("@ptr", typ, obj);
-				x := NewLeaf(obj); Construct(Nassign, x, length); x.subcl := newfn; Link(stat, last, x);
-				x := NewLeaf(obj); DeRef(x); Assign(x, n); Link(stat, last, x);
-				n := NewLeaf(obj); DeRef(n)
-			END;
-			StrDeref(n)
-		ELSIF (n.typ.form = Pointer) & (n.typ.sysflag = interface) & (left = NIL)
-				& ((par # NIL) OR (n.class = Ncall))
-				& ((n.class # Nvar) OR (n.obj.mnolev <= 0)) THEN
-			GetTempVar("@cip", DevCPT.punktyp, obj);
-			x := NewLeaf(obj); Assign(x, n); Link(stat, last, x);
-			n := NewLeaf(obj)
-		END
-	END CheckBuffering;
-	
-	PROCEDURE CheckVarParBuffering* (VAR n: DevCPT.Node; VAR stat, last: DevCPT.Node);
-		VAR x: DevCPT.Node; obj: DevCPT.Object;
-	BEGIN
-		IF (n.class # Nvar) OR (n.obj.mnolev <= 0) THEN
-			GetTempVar("@ptr", n.typ, obj);
-			x := NewLeaf(obj); Assign(x, n); Link(stat, last, x);
-			n := NewLeaf(obj)
-		END
-	END CheckVarParBuffering;
-
-	
-	(* case optimization *)
-
-	PROCEDURE Evaluate (n: DevCPT.Node; VAR min, max, num, dist: INTEGER; VAR head: DevCPT.Node);
-		VAR a: INTEGER;
-	BEGIN
-		IF n.left # NIL THEN
-			a := MIN(INTEGER); Evaluate(n.left, min, a, num, dist, head);
-			IF n.conval.intval - a > dist THEN dist := n.conval.intval - a; head := n END
-		ELSIF n.conval.intval < min THEN
-			min := n.conval.intval
-		END;
-		IF n.right # NIL THEN
-			a := MAX(INTEGER); Evaluate(n.right, a, max, num, dist, head);
-			IF a - n.conval.intval2 > dist THEN dist := a - n.conval.intval2; head := n END
-		ELSIF n.conval.intval2 > max THEN
-			max := n.conval.intval2
-		END;
-		INC(num);
-		IF n.conval.intval < n.conval.intval2 THEN
-			INC(num);
-			IF n.conval.intval2 - n.conval.intval > dist THEN dist := n.conval.intval2 - n.conval.intval; head := n END
-		END
-	END Evaluate;
-	
-	PROCEDURE Rebuild (VAR root: DevCPT.Node; head: DevCPT.Node);
-		VAR n: DevCPT.Node;
-	BEGIN
-		IF root # head THEN
-			IF head.conval.intval2 < root.conval.intval THEN
-				Rebuild(root.left, head);
-				root.left := head.right; head.right := root; root := head
-			ELSE
-				Rebuild(root.right, head);
-				root.right := head.left; head.left := root; root := head
-			END
-		END
-	END Rebuild;
-	
-	PROCEDURE OptimizeCase* (VAR n: DevCPT.Node);
-		VAR min, max, num, dist, limit: INTEGER; head: DevCPT.Node;
-	BEGIN
-		IF n # NIL THEN
-			min := MAX(INTEGER); max := MIN(INTEGER); num := 0; dist := 0; head := n;
-			Evaluate(n, min, max, num, dist, head);
-			limit := 6 * num;
-			IF limit < 100 THEN limit := 100 END;
-			IF (num > 4) & ((min > MAX(INTEGER) - limit) OR (max < min + limit)) THEN
-				INCL(n.conval.setval, useTable)
-			ELSE
-				IF num > 4 THEN Rebuild(n, head) END;
-				INCL(n.conval.setval, useTree);
-				OptimizeCase(n.left);
-				OptimizeCase(n.right)
-			END
-		END
-	END OptimizeCase;
-(*	
-	PROCEDURE ShowTree (n: DevCPT.Node; opts: SET);
-	BEGIN
-		IF n # NIL THEN
-			IF opts = {} THEN opts := n.conval.setval END;
-			IF useTable IN opts THEN
-				IF n.left # NIL THEN ShowTree(n.left, opts); DevCPM.LogW(",") END;
-				DevCPM.LogWNum(n.conval.intval, 1);
-				IF n.conval.intval2 > n.conval.intval THEN DevCPM.LogW("-"); DevCPM.LogWNum(n.conval.intval2, 1)
-				END;
-				IF n.right # NIL THEN DevCPM.LogW(","); ShowTree(n.right, opts) END
-			ELSIF useTree IN opts THEN
-				DevCPM.LogW("("); ShowTree(n.left, {}); DevCPM.LogW("|"); DevCPM.LogWNum(n.conval.intval, 1);
-				IF n.conval.intval2 > n.conval.intval THEN DevCPM.LogW("-"); DevCPM.LogWNum(n.conval.intval2, 1)
-				END;
-				DevCPM.LogW("|"); ShowTree(n.right, {}); DevCPM.LogW(")")
-			ELSE
-				ShowTree(n.left, opts); DevCPM.LogW(" "); DevCPM.LogWNum(n.conval.intval, 1);
-				IF n.conval.intval2 > n.conval.intval THEN DevCPM.LogW("-"); DevCPM.LogWNum(n.conval.intval2, 1)
-				END;
-				DevCPM.LogW(" "); ShowTree(n.right, opts)
-			END
-		END
-	END ShowTree;
-*)
-BEGIN
-	zero := DevCPT.NewConst(); zero.intval := 0; zero.realval := 0;
-	one := DevCPT.NewConst(); one.intval := 1; one.realval := 0;
-	two := DevCPT.NewConst(); two.intval := 2; two.realval := 0;
-	dummy := DevCPT.NewConst();
-	quot := DevCPT.NewConst()
-END DevCPB.

BlackBox/Dev/Mod/CPC486.txt

@@ -1,2333 +0,0 @@
-MODULE DevCPC486;
-
-	(* THIS IS TEXT COPY OF BlackBox 1.6-rc6 Dev/Mod/CPC486.odc *)
-	(* DO NOT EDIT *)
-
-	IMPORT SYSTEM, DevCPM, DevCPT, DevCPE, DevCPL486;
-
-	CONST
-		initializeAll = FALSE;	(* initialize all local variable to zero *)
-		initializeOut = FALSE;	(* initialize all OUT parameters to zero *)
-		initializeDyn = FALSE;	(* initialize all open array OUT parameters to zero *)
-		initializeStr = FALSE;	(* initialize rest of string value parameters to zero *)
-		
-		FpuControlRegister = 33EH;	(* value for fpu control register initialization *)
-		
-		(* structure forms *)
-		Undef = 0; Byte = 1; Bool = 2; Char8 = 3; Int8 = 4; Int16 = 5; Int32 = 6;
-		Real32 = 7; Real64 = 8; Set = 9; String8 = 10; NilTyp = 11; NoTyp = 12;
-		Pointer = 13; ProcTyp = 14; Comp = 15;
-		Char16 = 16; String16 = 17; Int64 = 18; Guid = 23;
-		VString16to8 = 29; VString8 = 30; VString16 = 31;
-		intSet = {Int8..Int32, Int64}; realSet = {Real32, Real64};
-
-		(* composite structure forms *)
-		Basic = 1; Array = 2; DynArr = 3; Record = 4;
-
-		(* item base modes (=object modes) *)
-		Var = 1; VarPar = 2; Con = 3; Fld = 4; Typ = 5; LProc = 6; XProc = 7; CProc = 9; IProc = 10; TProc = 13;
-
-		(* item modes for i386 *)
-		Ind = 14; Abs = 15; Stk = 16; Cond = 17; Reg = 18; DInd = 19;
-		
-		(* symbol values and ops *)
-		times = 1; slash = 2; div = 3; mod = 4;
-		and = 5; plus = 6; minus = 7; or = 8; eql = 9;
-		neq = 10; lss = 11; leq = 12; gtr = 13; geq = 14;
-		in = 15; is = 16; ash = 17; msk = 18; len = 19;
-		conv = 20; abs = 21; cap = 22; odd = 23; not = 33;
-		adr = 24; cc = 25; bit = 26; lsh = 27; rot = 28; val = 29;
-		getrfn = 26; putrfn = 27;
-		min = 34; max = 35; typ = 36;
-
-		(* procedure flags (conval.setval) *)
-		hasBody = 1; isRedef = 2; slNeeded = 3; imVar = 4; isGuarded = 30; isCallback = 31;
-
-		(* attribute flags (attr.adr, struct.attribute, proc.conval.setval) *)
-		newAttr = 16; absAttr = 17; limAttr = 18; empAttr = 19; extAttr = 20;
-		
-		false = 0; true = 1; nil = 0;
-
-		(* registers *)
-		AX = 0; CX = 1; DX = 2; BX = 3; SP = 4; BP = 5; SI = 6; DI = 7; AH = 4; CH = 5; DH = 6; BH = 7;
-		stk = 31; mem = 30; con = 29; float = 28; high = 27; short = 26; deref = 25; wreg = {AX, BX, CX, DX, SI, DI};
-	
-		(* GenShiftOp *)
-		ROL = 0; ROR = 8H; SHL = 20H; SHR = 28H; SAR = 38H;
-
-		(* GenBitOp *)
-		BT = 20H; BTS = 28H; BTR = 30H;
-		
-		(* GenFDOp *)
-		FADD = 0; FMUL = 8H; FCOM = 10H; FCOMP = 18H; FSUB = 20H; FSUBR = 28H; FDIV = 30H; FDIVR = 38H; 
-		
-		(* GenFMOp *)
-		FABS = 1E1H; FCHS = 1E0H; FTST = 1E4H; FSTSW = 7E0H; FUCOM = 2E9H;
-
-		(* GenCode *)
-		SAHF = 9EH; WAIT = 9BH;
-
-		(* condition codes *)
-		ccB = 2; ccAE = 3; ccBE = 6; ccA = 7; (* unsigned *)
-		ccL = 12; ccGE = 13; ccLE = 14; ccG = 15; (* signed *)
-		ccE = 4; ccNE = 5; ccS = 8; ccNS = 9; ccO = 0; ccNO = 1;
-		ccAlways = -1; ccNever = -2; ccCall = -3;
-
-		(* sysflag *)
-		untagged = 1; callback = 2; noAlign = 3; union = 7;
-		interface = 10; ccall = -10; guarded = 10; noframe = 16;
-		nilBit = 1; enumBits = 8; new = 1; iid = 2;
-		stackArray = 120;
-		
-		(* system trap numbers *)
-		withTrap = -1; caseTrap = -2; funcTrap = -3; typTrap = -4;
-		recTrap = -5; ranTrap = -6; inxTrap = -7; copyTrap = -8;
-		
-		(* module visibility of objects *)
-		internal = 0; external = 1; externalR = 2; inPar = 3; outPar = 4;
-
-		(* pointer init limits *)
-		MaxPtrs = 10; MaxPush = 4;
-		
-		Tag0Offset = 12;
-		Mth0Offset = -4;
-		ArrDOffs = 8;
-		numPreIntProc = 2;
-		
-		stackAllocLimit = 2048;
-
-		
-	VAR
-		imLevel*: ARRAY 64 OF BYTE;
-		intHandler*: DevCPT.Object;
-		inxchk, ovflchk, ranchk, typchk, ptrinit, hints: BOOLEAN;
-		WReg, BReg, AllReg: SET; FReg: INTEGER;
-		ptrTab: ARRAY MaxPtrs OF INTEGER;
-		stkAllocLbl: DevCPL486.Label;
-		procedureUsesFpu: BOOLEAN;
-
-	
-	PROCEDURE Init* (opt: SET);
-		CONST chk = 0; achk = 1; hint = 29;
-	BEGIN
-		inxchk := chk IN opt; ovflchk := achk IN opt; ranchk := achk IN opt; typchk := chk IN opt; ptrinit := chk IN opt;
-		hints := hint IN opt;
-		stkAllocLbl := DevCPL486.NewLbl
-	END Init;
-
-	PROCEDURE Reversed (cond: BYTE): BYTE;	(* reversed condition *)
-	BEGIN
-		IF cond = lss THEN RETURN gtr
-		ELSIF cond = gtr THEN RETURN lss
-		ELSIF cond = leq THEN RETURN geq
-		ELSIF cond = geq THEN RETURN leq
-		ELSE RETURN cond
-		END
-	END Reversed;
-	
-	PROCEDURE Inverted (cc: INTEGER): INTEGER;	(* inverted sense of condition code *)
-	BEGIN
-		IF ODD(cc) THEN RETURN cc-1 ELSE RETURN cc+1 END
-	END Inverted;
-
-	PROCEDURE setCC* (VAR x: DevCPL486.Item; rel: BYTE; reversed, signed: BOOLEAN);
-	BEGIN
-		IF reversed THEN rel := Reversed(rel) END;
-		CASE rel OF
-		   false: x.offset := ccNever
-		| true: x.offset := ccAlways
-		| eql: x.offset := ccE
-		| neq: x.offset := ccNE
-		| lss: IF signed THEN x.offset := ccL ELSE x.offset := ccB END
-		| leq: IF signed THEN x.offset := ccLE ELSE x.offset := ccBE END
-		| gtr: IF signed THEN x.offset := ccG ELSE x.offset := ccA END
-		| geq: IF signed THEN x.offset := ccGE ELSE x.offset := ccAE END
-		END;
-		x.mode := Cond; x.form := Bool; x.reg := 0;
-		IF reversed THEN x.reg := 1 END;
-		IF signed THEN INC(x.reg, 2) END
-	END setCC;
-
-	PROCEDURE StackAlloc*;	(* pre: len = CX bytes; post: len = CX words *)
-	BEGIN
-		DevCPL486.GenJump(ccCall, stkAllocLbl, FALSE)
-	END StackAlloc;
-	
-	PROCEDURE^ CheckAv* (reg: INTEGER);
-
-	PROCEDURE AdjustStack (val: INTEGER);
-		VAR c, sp: DevCPL486.Item;
-	BEGIN
-		IF val < -stackAllocLimit THEN
-			CheckAv(CX);
-			DevCPL486.MakeConst(c, -val, Int32); DevCPL486.MakeReg(sp, CX, Int32); DevCPL486.GenMove(c, sp);
-			StackAlloc
-		ELSIF val # 0 THEN
-			DevCPL486.MakeConst(c, val, Int32); DevCPL486.MakeReg(sp, SP, Int32); DevCPL486.GenAdd(c, sp, FALSE)
-		END
-	END AdjustStack;
-	
-	PROCEDURE DecStack (form: INTEGER);
-	BEGIN
-		IF form IN {Real64, Int64} THEN AdjustStack(-8) ELSE AdjustStack(-4) END
-	END DecStack;
-	
-	PROCEDURE IncStack (form: INTEGER);
-	BEGIN
-		IF form IN {Real64, Int64} THEN AdjustStack(8) ELSE AdjustStack(4) END
-	END IncStack;
-	
-	(*-----------------register handling------------------*)
-	
-	PROCEDURE SetReg* (reg: SET);
-	BEGIN
-		AllReg := reg; WReg := reg; BReg := reg * {0..3} + SYSTEM.LSH(reg * {0..3}, 4); FReg := 8
-	END SetReg;
-	
-	PROCEDURE CheckReg*;
-		VAR reg: SET;
-	BEGIN
-		reg := AllReg - WReg;
-		IF reg # {} THEN
-			DevCPM.err(-777); (* register not released *)
-			IF AX IN reg THEN DevCPM.LogWStr(" AX") END;
-			IF BX IN reg THEN DevCPM.LogWStr(" BX") END;
-			IF CX IN reg THEN DevCPM.LogWStr(" CX") END;
-			IF DX IN reg THEN DevCPM.LogWStr(" DX") END;
-			IF SI IN reg THEN DevCPM.LogWStr(" SI") END;
-			IF DI IN reg THEN DevCPM.LogWStr(" DI") END;
-			WReg := AllReg; BReg := AllReg * {0..3} + SYSTEM.LSH(AllReg * {0..3}, 4)
-		END;
-		IF FReg < 8 THEN DevCPM.err(-778); FReg := 8	 (* float register not released *)
-		ELSIF FReg > 8 THEN DevCPM.err(-779); FReg := 8
-		END
-	END CheckReg;
-	
-	PROCEDURE CheckAv* (reg: INTEGER);
-	BEGIN
-		ASSERT(reg IN WReg)
-	END CheckAv; 
-	
-	PROCEDURE GetReg (VAR x: DevCPL486.Item; f: BYTE; hint, stop: SET);
-		VAR n: INTEGER; s, s1: SET;
-	BEGIN
-		CASE f OF
-		| Byte, Bool, Char8, Int8:
-			s := BReg * {0..3} - stop;
-			IF (high IN stop) OR (high IN hint) & (s - hint  # {}) THEN n := 0;
-				IF s = {} THEN DevCPM.err(215); WReg := wreg; BReg := {0..7}; s := {0..7} END;
-				IF s - hint # {} THEN s := s - hint END;
-				WHILE ~(n IN s) DO INC(n) END
-			ELSE
-				s := BReg - (stop * {0..3}) - SYSTEM.LSH(stop * {0..3}, 4); n := 0;
-				IF s = {} THEN DevCPM.err(215); WReg := wreg; BReg := {0..7}; s := {0..7} END;
-				s1 := s - (hint * {0..3}) - SYSTEM.LSH(hint * {0..3}, 4);
-				IF s1 # {} THEN s := s1 END;
-				WHILE ~(n IN s) & ~(n + 4 IN s) DO INC(n) END;
-				IF ~(n IN s) THEN n := n + 4 END
-			END;
-			EXCL(BReg, n); EXCL(WReg, n MOD 4)
-		| Int16, Int32, Set, String8, NilTyp, Pointer, ProcTyp, Comp, Char16, String16: 
-			s := WReg - stop;
-			IF high IN stop THEN s := s * {0..3} END;
-			IF s = {} THEN DevCPM.err(215); WReg := wreg; BReg := {0..7}; s := wreg END;
-			s1 := s - hint;
-			IF high IN hint THEN s1 := s1 * {0..3} END;
-			IF s1 # {} THEN s := s1 END;
-			IF 0 IN s THEN n := 0
-			ELSIF 2 IN s THEN n := 2
-			ELSIF 6 IN s THEN n := 6
-			ELSIF 7 IN s THEN n := 7
-			ELSIF 1 IN s THEN n := 1
-			ELSE n := 3
-			END;
-			EXCL(WReg, n);
-			IF n < 4 THEN EXCL(BReg, n); EXCL(BReg, n + 4) END
-		| Real32, Real64:
-			IF (FReg = 0) OR (float IN stop) THEN DevCPM.err(216); FReg := 99 END;
-			DEC(FReg); n := 0
-		END;
-		DevCPL486.MakeReg(x, n, f);
-	END GetReg;
-	
-	PROCEDURE FreeReg (n, f: INTEGER);
-	BEGIN
-		IF f <= Int8 THEN
-			INCL(BReg, n);
-			IF (n + 4) MOD 8 IN BReg THEN INCL(WReg, n MOD 4) END
-		ELSIF f IN realSet THEN
-			INC(FReg)
-		ELSIF n IN AllReg THEN
-			INCL(WReg, n);
-			IF n < 4 THEN INCL(BReg, n); INCL(BReg, n + 4) END
-		END
-	END FreeReg;
-	
-	PROCEDURE FreeWReg (n: INTEGER);
-	BEGIN
-		IF n IN AllReg THEN
-			INCL(WReg, n);
-			IF n < 4 THEN INCL(BReg, n); INCL(BReg, n + 4) END
-		END
-	END FreeWReg;
-	
-	PROCEDURE Free* (VAR x: DevCPL486.Item);
-	BEGIN
-		CASE x.mode OF
-		| Var, VarPar, Abs: IF x.scale # 0 THEN FreeWReg(x.index) END
-		| Ind: FreeWReg(x.reg);
-			IF x.scale # 0 THEN FreeWReg(x.index) END
-		| Reg: FreeReg(x.reg, x.form);
-			IF x.form = Int64 THEN FreeWReg(x.index) END
-		ELSE
-		END
-	END Free;
-	
-	PROCEDURE FreeHi (VAR x: DevCPL486.Item);	(* free hi byte of word reg *)
-	BEGIN
-		IF x.mode = Reg THEN
-			IF x.form = Int64 THEN FreeWReg(x.index)
-			ELSIF x.reg < 4 THEN INCL(BReg, x.reg + 4)
-			END
-		END
-	END FreeHi;
-
-	PROCEDURE Fits* (VAR x: DevCPL486.Item; stop: SET): BOOLEAN;	(* x.mode = Reg *)
-	BEGIN
-		IF (short IN stop) & (x.form <= Int8) THEN RETURN FALSE END;
-		IF x.form <= Int8 THEN RETURN ~(x.reg MOD 4 IN stop) & ((x.reg < 4) OR ~(high IN stop))
-		ELSIF x.form IN realSet THEN RETURN ~(float IN stop)
-		ELSIF x.form = Int64 THEN RETURN ~(x.reg IN stop) & ~(x.index IN stop)
-		ELSE RETURN ~(x.reg IN stop) & ((x.reg < 4) OR ~(high IN stop))
-		END
-	END Fits;
-	
-	PROCEDURE Pop* (VAR r: DevCPL486.Item; f: BYTE; hint, stop: SET);
-		VAR rh: DevCPL486.Item;
-	BEGIN
-		IF f = Int64 THEN
-			GetReg(r, Int32, hint, stop); DevCPL486.GenPop(r);
-			GetReg(rh, Int32, hint, stop); DevCPL486.GenPop(rh);
-			r.form := Int64; r.index := rh.reg
-		ELSE
-			IF f < Int16 THEN INCL(stop, high) END;
-			GetReg(r, f, hint, stop); DevCPL486.GenPop(r)
-		END
-	END Pop;
-	
-	PROCEDURE^ LoadLong (VAR x: DevCPL486.Item; hint, stop: SET);
-	
-	PROCEDURE Load* (VAR x: DevCPL486.Item; hint, stop: SET);	(* = Assert(x, hint, stop + {mem, stk}) *)
-		VAR r: DevCPL486.Item; f: BYTE;
-	BEGIN
-		f := x.typ.form;
-		IF x.mode = Con THEN
-			IF (short IN stop) & (x.form IN {Int8, Int16, Bool, Char8, Char16}) THEN f := Int32; x.form := Int32 END;
-			IF con IN stop THEN
-				IF f = Int64 THEN LoadLong(x, hint, stop)
-				ELSE
-					GetReg(r, f, hint, stop); DevCPL486.GenMove(x, r);
-					x.mode := Reg; x.reg := r.reg; x.form := f
-				END
-			END
-		ELSIF x.mode = Stk THEN
-			IF f IN realSet THEN
-				GetReg(r, f, hint, stop); DevCPL486.GenFLoad(x); IncStack(x.form)
-			ELSE
-				Pop(r, f, hint, stop)
-			END;
-			x.mode := Reg; x.reg := r.reg; x.index := r.index; x.form := f
-		ELSIF (short IN stop) & (x.form IN {Int8, Int16, Bool, Char8, Char16}) THEN
-			Free(x); GetReg(r, Int32, hint, stop); DevCPL486.GenExtMove(x, r);
-			x.mode := Reg; x.reg := r.reg; x.form := Int32
-		ELSIF (x.mode # Reg) OR ~Fits(x, stop) THEN
-			IF f = Int64 THEN LoadLong(x, hint, stop)
-			ELSE
-				Free(x); GetReg(r, f, hint, stop);
-				IF f IN realSet THEN DevCPL486.GenFLoad(x) ELSE DevCPL486.GenMove(x, r) END;
-				x.mode := Reg; x.reg := r.reg; x.form := f
-			END
-		END
-	END Load;
-	
-	PROCEDURE Push* (VAR x: DevCPL486.Item);
-		VAR y: DevCPL486.Item;
-	BEGIN
-		IF x.form IN realSet THEN
-			Load(x, {}, {}); DecStack(x.form);
-			Free(x); x.mode := Stk;
-			IF x.typ = DevCPT.intrealtyp THEN x.form := Int64 END;
-			DevCPL486.GenFStore(x, TRUE)
-		ELSIF x.form = Int64 THEN
-			Free(x); x.form := Int32; y := x;
-			IF x.mode = Reg THEN y.reg := x.index ELSE INC(y.offset, 4) END;
-			DevCPL486.GenPush(y); DevCPL486.GenPush(x);
-			x.mode := Stk; x.form := Int64
-		ELSE
-			IF x.form < Int16 THEN Load(x, {}, {high})
-			ELSIF x.form = Int16 THEN Load(x, {}, {})
-			END;
-			Free(x); DevCPL486.GenPush(x); x.mode := Stk
-		END
-	END Push;
-	
-	PROCEDURE Assert* (VAR x: DevCPL486.Item; hint, stop: SET);
-		VAR r: DevCPL486.Item;
-	BEGIN
-		IF (short IN stop) & (x.form IN {Int8, Int16, Bool, Char8, Char16}) & (x.mode # Con) THEN
-			IF (wreg - stop = {}) & ~(stk IN stop) THEN Load(x, {}, {short}); Push(x)
-			ELSE Load(x, hint, stop);
-			END
-		ELSE
-			CASE x.mode OF
-			| Var, VarPar: IF ~(mem IN stop) THEN RETURN END
-			| Con: IF ~(con IN stop) THEN RETURN END
-			| Ind: IF ~(mem IN stop) & ~(x.reg IN stop) & ((x.scale = 0) OR ~(x.index IN stop)) THEN RETURN END
-			| Abs: IF ~(mem IN stop) & ((x.scale = 0) OR ~(x.index IN stop)) THEN RETURN END
-			| Stk: IF ~(stk IN stop) THEN RETURN END
-			| Reg: IF Fits(x, stop) THEN RETURN END
-			ELSE RETURN
-			END;
-			IF ((float IN stop) OR ~(x.typ.form IN realSet) & (wreg - stop = {})) & ~(stk IN stop) THEN Push(x)
-			ELSE Load(x, hint, stop)
-			END
-		END
-	END Assert;
-	
-	(*------------------------------------------------*)
-
-	PROCEDURE LoadR (VAR x: DevCPL486.Item);
-	BEGIN
-		IF x.mode # Reg THEN
-			Free(x); DevCPL486.GenFLoad(x);
-			IF x.mode = Stk THEN IncStack(x.form) END;
-			GetReg(x, Real32, {}, {})
-		END
-	END LoadR;
-
-	PROCEDURE PushR (VAR x: DevCPL486.Item);
-	BEGIN
-		IF x.mode # Reg THEN LoadR(x) END;
-		DecStack(x.form);
-		Free(x); x.mode := Stk; DevCPL486.GenFStore(x, TRUE)
-	END PushR;
-	
-	PROCEDURE LoadW (VAR x: DevCPL486.Item; hint, stop: SET);
-		VAR r: DevCPL486.Item;
-	BEGIN
-		IF x.mode = Stk THEN
-			Pop(x, x.form, hint, stop)
-		ELSE
-			Free(x); GetReg(r, x.form, hint, stop);
-			DevCPL486.GenMove(x, r);
-			x.mode := Reg; x.reg := r.reg
-		END
-	END LoadW;
-
-	PROCEDURE LoadL (VAR x: DevCPL486.Item; hint, stop: SET);
-		VAR r: DevCPL486.Item;
-	BEGIN
-		IF x.mode = Stk THEN
-			Pop(x, x.form, hint, stop);
-			IF (x.form < Int32) OR (x.form = Char16) THEN
-				r := x; x.form := Int32; DevCPL486.GenExtMove(r, x)
-			END
-		ELSE
-			Free(x);
-			IF (x.form < Int32) OR (x.form = Char16) THEN GetReg(r, Int32, hint, stop) ELSE GetReg(r, x.form, hint, stop) END;
-			IF x.mode = Con THEN x.form := r.form END;
-			IF x.form # r.form THEN DevCPL486.GenExtMove(x, r) ELSE DevCPL486.GenMove(x, r) END;
-			x.mode := Reg; x.reg := r.reg; x.form := r.form
-		END
-	END LoadL;
-	
-	PROCEDURE LoadLong (VAR x: DevCPL486.Item; hint, stop: SET);
-		VAR r, rh, c: DevCPL486.Item; offs: INTEGER;
-	BEGIN
-		IF x.form = Int64 THEN
-			IF  x.mode = Stk THEN
-				Pop(x, x.form, hint, stop)
-			ELSIF x.mode = Reg THEN
-				FreeReg(x.reg, Int32); GetReg(r, Int32, hint, stop);
-				FreeReg(x.index, Int32); GetReg(rh, Int32, hint, stop);
-				x.form := Int32; DevCPL486.GenMove(x, r);
-				x.reg := x.index; DevCPL486.GenMove(x, rh);
-				x.reg := r.reg; x.index := rh.reg
-			ELSE
-				GetReg(rh, Int32, hint, stop + {AX});
-				Free(x);
-				GetReg(r, Int32, hint, stop); 
-				x.form := Int32; offs := x.offset;
-				IF x.mode = Con THEN x.offset := x.scale ELSE INC(x.offset, 4) END;
-				DevCPL486.GenMove(x, rh);
-				x.offset := offs;
-				DevCPL486.GenMove(x, r);
-				x.mode := Reg; x.reg := r.reg; x.index := rh.reg
-			END
-		ELSE
-			LoadL(x, hint, stop); GetReg(rh, Int32, hint, stop); DevCPL486.GenSignExt(x, rh);
-			x.index := rh.reg
-		END;
-		x.form := Int64
-	END LoadLong;
-	
-	(*------------------------------------------------*)
-	
-	PROCEDURE CopyReg* (VAR x, y: DevCPL486.Item; hint, stop: SET);
-	BEGIN
-		ASSERT(x.mode = Reg);
-		GetReg(y, x.form, hint, stop);
-		DevCPL486.GenMove(x, y)
-	END CopyReg;
-
-	PROCEDURE GetAdr* (VAR x: DevCPL486.Item; hint, stop: SET);
-		VAR r: DevCPL486.Item;
-	BEGIN
-		IF x.mode = DInd THEN
-			x.mode := Ind
-		ELSIF (x.mode = Ind) & (x.offset = 0) & (x.scale = 0) & (x.reg IN wreg) THEN
-			x.mode := Reg
-		ELSE
-			Free(x); GetReg(r, Pointer, hint, stop);
-			IF x.mode = Con THEN DevCPL486.GenMove(x, r) ELSE DevCPL486.GenLoadAdr(x, r) END;
-			x.mode := Reg; x.reg := r.reg; x.form := Pointer
-		END;
-		x.form := Pointer; x.typ := DevCPT.anyptrtyp;
-		Assert(x, hint, stop)
-	END GetAdr;
-	
-	PROCEDURE PushAdr (VAR x: DevCPL486.Item; niltest: BOOLEAN);
-		VAR r, v: DevCPL486.Item;
-	BEGIN
-		IF (x.mode = Abs) & (x.scale = 0) THEN x.mode := Con; x.form := Pointer
-		ELSIF niltest THEN
-			GetAdr(x, {}, {mem, stk});
-			DevCPL486.MakeReg(r, AX, Int32);
-			v.mode := Ind; v.form := Int32; v.offset := 0; v.scale := 0; v.reg := x.reg;
-			DevCPL486.GenTest(r, v)
-		ELSIF x.mode = DInd THEN x.mode := Ind; x.form := Pointer
-		ELSE GetAdr(x, {}, {})
-		END;
-		Free(x); DevCPL486.GenPush(x)
-	END PushAdr;
-
-	PROCEDURE LevelBase (VAR a: DevCPL486.Item; lev: INTEGER; hint, stop: SET);
-		VAR n: BYTE;
-	BEGIN
-		a.mode := Ind; a.scale := 0; a.form := Int32; a.typ := DevCPT.int32typ;
-		IF lev = DevCPL486.level THEN a.reg := BP
-		ELSE
-			a.reg := BX; n := SHORT(SHORT(imLevel[DevCPL486.level] - imLevel[lev]));
-			WHILE n > 0 DO
-				a.offset := -4; LoadL(a, hint, stop); a.mode := Ind; DEC(n)
-			END
-		END
-	END LevelBase;
-	
-	PROCEDURE LenDesc (VAR x, len: DevCPL486.Item; typ: DevCPT.Struct); (* set len to LEN(x, -typ.n) *)
-	BEGIN
-		IF x.tmode = VarPar THEN
-			LevelBase(len, x.obj.mnolev, {}, {}); len.offset := x.obj.adr;
-		ELSE ASSERT((x.tmode = Ind) & (x.mode = Ind));
-			len := x; len.offset := ArrDOffs; len.scale := 0; len.form := Int32
-		END;
-		INC(len.offset, typ.n * 4 + 4);
-		IF typ.sysflag = stackArray THEN len.offset := -4 END
-	END LenDesc;
-	
-	PROCEDURE Tag* (VAR x, tag: DevCPL486.Item);
-		VAR typ: DevCPT.Struct;
-	BEGIN
-		typ := x.typ;
-		IF typ.form = Pointer THEN typ := typ.BaseTyp END;
-		IF (x.typ # DevCPT.sysptrtyp) & (typ.attribute = 0) & ~(DevCPM.oberon IN DevCPM.options) THEN	(* final type *)
-			DevCPL486.MakeConst(tag, 0, Pointer); tag.obj := DevCPE.TypeObj(typ)
-		ELSIF x.typ.form = Pointer THEN
-			ASSERT(x.mode = Reg);
-			tag.mode := Ind; tag.reg := x.reg; tag.offset := -4;
-			IF x.typ.sysflag = interface THEN tag.offset := 0 END
-		ELSIF x.tmode = VarPar THEN
-			LevelBase(tag, x.obj.mnolev, {}, {}); tag.offset := x.obj.adr + 4;
-			Free(tag)	(* ??? *)
-		ELSIF x.tmode = Ind THEN
-			ASSERT(x.mode = Ind);
-			tag := x; tag.offset := -4
-		ELSE
-			DevCPL486.MakeConst(tag, 0, Pointer); tag.obj := DevCPE.TypeObj(x.typ)
-		END;
-		tag.scale := 0; tag.form := Pointer; tag.typ := DevCPT.sysptrtyp
-	END Tag;
-	
-	PROCEDURE NumOfIntProc (typ: DevCPT.Struct): INTEGER;
-	BEGIN
-		WHILE (typ # NIL) & (typ.sysflag # interface) DO typ := typ.BaseTyp END;
-		IF typ # NIL THEN RETURN typ.n
-		ELSE RETURN 0
-		END
-	END NumOfIntProc;
-	
-	PROCEDURE ContainsIPtrs* (typ: DevCPT.Struct): BOOLEAN;
-		VAR fld: DevCPT.Object;
-	BEGIN
-		WHILE typ.comp IN {DynArr, Array} DO typ := typ.BaseTyp END;
-		IF (typ.form = Pointer) & (typ.sysflag = interface) THEN RETURN TRUE
-		ELSIF (typ.comp = Record) & (typ.sysflag # union) THEN
-			REPEAT
-				fld := typ.link;
-				WHILE (fld # NIL) & (fld.mode = Fld) DO
-					IF (fld.sysflag = interface) & (fld.name^ = DevCPM.HdUtPtrName) 
-						OR ContainsIPtrs(fld.typ) THEN RETURN TRUE END;
-					fld := fld.link
-				END;
-				typ := typ.BaseTyp
-			UNTIL typ = NIL
-		END;
-		RETURN FALSE
-	END ContainsIPtrs;
-	
-	PROCEDURE GuidFromString* (str: DevCPT.ConstExt; VAR x: DevCPL486.Item);
-		VAR cv: DevCPT.Const;
-	BEGIN
-		IF ~DevCPM.ValidGuid(str^) THEN DevCPM.err(165) END;
-		cv := DevCPT.NewConst();
-		cv.intval := DevCPM.ConstNotAlloc; cv.intval2 := 16; cv.ext := str;
-		DevCPL486.AllocConst(x, cv, Guid); x.typ := DevCPT.guidtyp
-	END GuidFromString;
-	
-	PROCEDURE IPAddRef* (VAR x: DevCPL486.Item; offset: INTEGER; nilTest: BOOLEAN);
-		VAR r, p, c: DevCPL486.Item; lbl: DevCPL486.Label;
-	BEGIN
-		ASSERT(x.mode IN {Reg, Ind, Abs});
-		ASSERT({AX, CX, DX} - WReg = {});
-		IF hints THEN
-			IF nilTest THEN DevCPM.err(-701) ELSE DevCPM.err(-700) END
-		END;
-		IF x.mode # Reg THEN 
-			GetReg(r, Pointer, {}, {});
-			p := x; INC(p.offset, offset); p.form := Pointer; DevCPL486.GenMove(p, r);
-		ELSE r := x
-		END;
-		IF nilTest THEN
-			DevCPL486.MakeConst(c, 0, Pointer); DevCPL486.GenComp(c, r);
-			lbl := DevCPL486.NewLbl; DevCPL486.GenJump(ccE, lbl, TRUE)
-		END;
-		DevCPL486.GenPush(r); p := r;
-		IF x.mode # Reg THEN Free(r) END;
-		GetReg(r, Pointer, {}, {});
-		p.mode := Ind; p.offset := 0; p.scale := 0; p.form := Pointer; DevCPL486.GenMove(p, r);
-		p.offset := 4; p.reg := r.reg; Free(r); DevCPL486.GenCall(p);
-		IF nilTest THEN DevCPL486.SetLabel(lbl) END;
-	END IPAddRef;
-	
-	PROCEDURE IPRelease* (VAR x: DevCPL486.Item; offset: INTEGER; nilTest, nilSet: BOOLEAN);
-		VAR r, p, c: DevCPL486.Item; lbl: DevCPL486.Label;
-	BEGIN
-		ASSERT(x.mode IN {Ind, Abs});
-		ASSERT({AX, CX, DX} - WReg = {});
-		IF hints THEN
-			IF nilTest THEN DevCPM.err(-703) ELSE DevCPM.err(-702) END
-		END;
-		GetReg(r, Pointer, {}, {});
-		p := x; INC(p.offset, offset); p.form := Pointer; DevCPL486.GenMove(p, r);
-		DevCPL486.MakeConst(c, 0, Pointer);
-		IF nilTest THEN
-			DevCPL486.GenComp(c, r);
-			lbl := DevCPL486.NewLbl; DevCPL486.GenJump(ccE, lbl, TRUE)
-		END;
-		IF nilSet THEN DevCPL486.GenMove(c, p) END;
-		DevCPL486.GenPush(r);
-		p.mode := Ind; p.reg := r.reg; p.offset := 0; p.scale := 0; DevCPL486.GenMove(p, r);
-		p.offset := 8; Free(r); DevCPL486.GenCall(p);
-		IF nilTest THEN DevCPL486.SetLabel(lbl) END;
-	END IPRelease;
-	
-	PROCEDURE Prepare* (VAR x: DevCPL486.Item; hint, stop: SET);
-		VAR n, i, lev: INTEGER; len, y: DevCPL486.Item; typ: DevCPT.Struct;
-	BEGIN
-		IF (x.mode IN {Var, VarPar, Ind, Abs}) & (x.scale # 0) THEN
-			DevCPL486.MakeReg(y, x.index, Int32); typ := x.typ;
-			WHILE typ.comp = DynArr DO (* complete dynamic array iterations *)
-				LenDesc(x, len, typ); DevCPL486.GenMul(len, y, FALSE); typ := typ.BaseTyp;
-				IF x.tmode = VarPar THEN Free(len) END;	(* ??? *)
-			END;
-			n := x.scale; i := 0;
-			WHILE (n MOD 2 = 0) & (i < 3) DO n := n DIV 2; INC(i) END;
-			IF n > 1 THEN (* assure scale factor in {1, 2, 4, 8} *)
-				DevCPL486.MakeConst(len, n, Int32); DevCPL486.GenMul(len, y, FALSE); x.scale := x.scale DIV n 
-			END
-		END;
-		CASE x.mode OF
-		   Var, VarPar:
-				lev := x.obj.mnolev;
-				IF lev <= 0 THEN
-					x.mode := Abs
-				ELSE
-					LevelBase(y, lev, hint, stop);
-					IF x.mode # VarPar THEN
-						x.mode := Ind
-					ELSIF (deref IN hint) & (x.offset = 0) & (x.scale = 0) THEN
-						x.mode := DInd; x.offset := x.obj.adr
-					ELSE
-						y.offset := x.obj.adr; Load(y, hint, stop); x.mode := Ind
-					END;
-					x.reg := y.reg
-				END;
-				x.form := x.typ.form
-		| LProc, XProc, IProc:
-				x.mode := Con; x.offset := 0; x.form := ProcTyp
-		| TProc, CProc:
-				x.form := ProcTyp
-		| Ind, Abs, Stk, Reg:
-				IF ~(x.typ.form IN {String8, String16}) THEN x.form := x.typ.form END
-		END
-	END Prepare;
-	
-	PROCEDURE Field* (VAR x: DevCPL486.Item; field: DevCPT.Object);
-	BEGIN
-		INC(x.offset, field.adr); x.tmode := Con
-	END Field;
-	
-	PROCEDURE DeRef* (VAR x: DevCPL486.Item);
-		VAR btyp: DevCPT.Struct;
-	BEGIN
-		x.mode := Ind; x.tmode := Ind; x.scale := 0;
-		btyp := x.typ.BaseTyp;
-		IF btyp.untagged OR (btyp.sysflag = stackArray) THEN x.offset := 0
-		ELSIF btyp.comp = DynArr THEN x.offset := ArrDOffs + btyp.size
-		ELSIF btyp.comp = Array THEN x.offset := ArrDOffs + 4 
-		ELSE x.offset := 0
-		END
-	END DeRef;
-	
-	PROCEDURE Index* (VAR x, y: DevCPL486.Item; hint, stop: SET);	(* x[y] *)
-		VAR idx, len: DevCPL486.Item; btyp: DevCPT.Struct; elsize: INTEGER;
-	BEGIN
-		btyp := x.typ.BaseTyp; elsize := btyp.size;
-		IF elsize = 0 THEN Free(y)
-		ELSIF x.typ.comp = Array THEN
-			len.mode := Con; len.obj := NIL;
-			IF y.mode = Con THEN
-				INC(x.offset, y.offset * elsize)
-			ELSE
-				Load(y, hint, stop + {mem, stk, short});
-				IF inxchk THEN
-					DevCPL486.MakeConst(len, x.typ.n, Int32);
-					DevCPL486.GenComp(len, y); DevCPL486.GenAssert(ccB, inxTrap)
-				END;
-				IF x.scale = 0 THEN x.index := y.reg
-				ELSE
-					IF x.scale MOD elsize # 0 THEN
-						IF (x.scale MOD 4 = 0) & (elsize MOD 4 = 0) THEN elsize := 4
-						ELSIF (x.scale MOD 2 = 0) & (elsize MOD 2 = 0) THEN elsize := 2
-						ELSE elsize := 1
-						END;
-						DevCPL486.MakeConst(len, btyp.size DIV elsize, Int32);
-						DevCPL486.GenMul(len, y, FALSE)
-					END;
-					DevCPL486.MakeConst(len, x.scale DIV elsize, Int32);
-					DevCPL486.MakeReg(idx, x.index, Int32);
-					DevCPL486.GenMul(len, idx, FALSE); DevCPL486.GenAdd(y, idx, FALSE); Free(y)
-				END;
-				x.scale := elsize
-			END;
-			x.tmode := Con
-		ELSE (* x.typ.comp = DynArr *)
-			IF (btyp.comp = DynArr) & x.typ.untagged THEN DevCPM.err(137) END;
-			LenDesc(x, len, x.typ);
-			IF x.scale # 0 THEN
-				DevCPL486.MakeReg(idx, x.index, Int32); 
-				DevCPL486.GenMul(len, idx, FALSE)
-			END;
-			IF (y.mode # Con) OR (y.offset # 0) THEN
-				IF (y.mode # Con) OR (btyp.comp = DynArr) & (x.scale = 0) THEN
-					Load(y, hint, stop + {mem, stk, con, short})
-				ELSE y.form := Int32
-				END;
-				IF inxchk & ~x.typ.untagged THEN
-					DevCPL486.GenComp(y, len); DevCPL486.GenAssert(ccA, inxTrap)
-				END;
-				IF (y.mode = Con) & (btyp.comp # DynArr) THEN
-					INC(x.offset, y.offset * elsize)
-				ELSIF x.scale = 0 THEN
-					WHILE btyp.comp = DynArr DO btyp := btyp.BaseTyp END;
-					x.index := y.reg; x.scale := btyp.size
-				ELSE
-					DevCPL486.GenAdd(y, idx, FALSE); Free(y)
-				END
-			END;
-			IF x.tmode = VarPar THEN Free(len) END;	(* ??? *)
-			IF x.typ.BaseTyp.comp # DynArr THEN x.tmode := Con END
-		END
-	END Index;
-	
-	PROCEDURE TypTest* (VAR x: DevCPL486.Item; testtyp: DevCPT.Struct; guard, equal: BOOLEAN);
-		VAR tag, tdes, r: DevCPL486.Item; typ: DevCPT.Struct;
-	BEGIN
-		typ := x.typ;
-		IF typ.form = Pointer THEN testtyp := testtyp.BaseTyp; typ := typ.BaseTyp END;
-		IF ~guard & typ.untagged THEN DevCPM.err(139)
-		ELSIF ~guard OR typchk & ~typ.untagged THEN
-			IF testtyp.untagged THEN DevCPM.err(139)
-			ELSE
-				IF (x.typ.form = Pointer) & (x.mode # Reg) THEN
-					GetReg(r, Pointer, {}, {}); DevCPL486.GenMove(x, r); Free(r); r.typ := x.typ; Tag(r, tag)
-				ELSE Tag(x, tag)
-				END;
-				IF ~guard THEN Free(x) END;
-				IF ~equal THEN
-					GetReg(r, Pointer, {}, {}); DevCPL486.GenMove(tag, r); Free(r);
-					tag.mode := Ind; tag.reg := r.reg; tag.scale := 0; tag.offset := Tag0Offset + 4 * testtyp.extlev
-				END;
-				DevCPL486.MakeConst(tdes, 0, Pointer); tdes.obj := DevCPE.TypeObj(testtyp);
-				DevCPL486.GenComp(tdes, tag);
-				IF guard THEN
-					IF equal THEN DevCPL486.GenAssert(ccE, recTrap) ELSE DevCPL486.GenAssert(ccE, typTrap) END
-				ELSE setCC(x, eql, FALSE, FALSE)
-				END
-			END
-		END
-	END TypTest;
-	
-	PROCEDURE ShortTypTest* (VAR x: DevCPL486.Item; testtyp: DevCPT.Struct);
-		VAR tag, tdes: DevCPL486.Item;
-	BEGIN
-		(* tag must be in AX ! *)
-		IF testtyp.form = Pointer THEN testtyp := testtyp.BaseTyp END;
-		IF testtyp.untagged THEN DevCPM.err(139)
-		ELSE
-			tag.mode := Ind; tag.reg := AX; tag.scale := 0; tag.offset := Tag0Offset + 4 * testtyp.extlev; tag.form := Pointer;
-			DevCPL486.MakeConst(tdes, 0, Pointer); tdes.obj := DevCPE.TypeObj(testtyp);
-			DevCPL486.GenComp(tdes, tag);
-			setCC(x, eql, FALSE, FALSE)
-		END
-	END ShortTypTest;
-
-	PROCEDURE Check (VAR x: DevCPL486.Item; min, max: INTEGER);
-		VAR c: DevCPL486.Item;
-	BEGIN
-		ASSERT((x.mode # Reg) OR (max > 255) OR (max = 31) OR (x.reg < 4));
-		IF ranchk & (x.mode # Con) THEN
-			DevCPL486.MakeConst(c, max, x.form); DevCPL486.GenComp(c, x);
-			IF min # 0 THEN
-				DevCPL486.GenAssert(ccLE, ranTrap);
-				c.offset := min; DevCPL486.GenComp(c, x);
-				DevCPL486.GenAssert(ccGE, ranTrap)
-			ELSIF max # 0 THEN
-				DevCPL486.GenAssert(ccBE, ranTrap)
-			ELSE
-				DevCPL486.GenAssert(ccNS, ranTrap)
-			END
-		END
-	END Check;
-
-	PROCEDURE Floor (VAR x: DevCPL486.Item; useSt1: BOOLEAN);
-		VAR c: DevCPL486.Item; local: DevCPL486.Label;
-	BEGIN
-		IF useSt1 THEN DevCPL486.GenFMOp(5D1H);	(* FST ST1 *)
-		ELSE DevCPL486.GenFMOp(1C0H);	(* FLD ST0 *)
-		END;
-		DevCPL486.GenFMOp(1FCH);	(* FRNDINT *)
-		DevCPL486.GenFMOp(0D1H);	(* FCOM *)
-		CheckAv(AX);
-		DevCPL486.GenFMOp(FSTSW);
-		DevCPL486.GenFMOp(5D9H);	(* FSTP ST1 *)
-		(* DevCPL486.GenCode(WAIT); *) DevCPL486.GenCode(SAHF);
-		local := DevCPL486.NewLbl; DevCPL486.GenJump(ccBE, local, TRUE);
-		DevCPL486.AllocConst(c, DevCPL486.one, Real32);
-		DevCPL486.GenFDOp(FSUB, c);
-		DevCPL486.SetLabel(local);
-	END Floor;
-	
-	PROCEDURE Entier(VAR x: DevCPL486.Item; typ: DevCPT.Struct; hint, stop: SET);
-	BEGIN
-		IF typ # DevCPT.intrealtyp THEN Floor(x, FALSE) END;
-		DevCPL486.GenFStore(x, TRUE);
-		IF (x.mode = Stk) & (stk IN stop) THEN Pop(x, x.form, hint, stop) END
-	END Entier;
-
-	PROCEDURE ConvMove (VAR x, y: DevCPL486.Item; sysval: BOOLEAN; hint, stop: SET);	(* x := y *)
-		(* scalar values only, y.mode # Con, all kinds of conversions, x.mode = Undef => convert y only *)
-		VAR f, m: BYTE; s: INTEGER; z: DevCPL486.Item;
-	BEGIN
-		f := x.form; m := x.mode; ASSERT(m IN {Undef, Reg, Abs, Ind, Stk});
-		IF y.form IN {Real32, Real64} THEN
-			IF f IN {Real32, Real64} THEN
-				IF m = Undef THEN
-					IF (y.form = Real64) & (f = Real32) THEN
-						IF y.mode # Reg THEN LoadR(y) END;
-						Free(y); DecStack(Real32); y.mode := Stk; y.form := Real32; DevCPL486.GenFStore(y, TRUE)
-					END
-				ELSE
-					IF y.mode # Reg THEN LoadR(y) END;
-					IF m = Stk THEN DecStack(f) END;
-					IF m # Reg THEN Free(y); DevCPL486.GenFStore(x, TRUE) END;
-				END
-			ELSE (* x not real *)
-				IF sysval THEN
-					IF y.mode = Reg THEN Free(y);
-						IF (m # Stk) & (m # Undef) & (m # Reg) & (f >= Int32) THEN
-							x.form := y.form; DevCPL486.GenFStore(x, TRUE); x.form := f
-						ELSE
-							ASSERT(y.form # Real64);
-							DecStack(y.form); y.mode := Stk; DevCPL486.GenFStore(y, TRUE); y.form := Int32;
-							IF m # Stk THEN
-								Pop(y, y.form, hint, stop);
-								IF f < Int16 THEN ASSERT(y.reg < 4) END;
-								y.form := f;
-								IF m # Undef THEN Free(y); DevCPL486.GenMove(y, x) END
-							END
-						END
-					ELSE (* y.mode # Reg *)
-						y.form := f;
-						IF m # Undef THEN LoadW(y, hint, stop); Free(y);
-							IF m = Stk THEN DevCPL486.GenPush(y) ELSE DevCPL486.GenMove(y, x) END
-						END
-					END
-				ELSE (* not sysval *)
-					IF y.mode # Reg THEN LoadR(y) END;
-					Free(y);
-					IF (m # Stk) & (m # Undef) & (m # Reg) & (f >= Int16) & (f # Char16) THEN
-						Entier(x, y.typ, hint, stop);
-					ELSE
-						DecStack(f); y.mode := Stk;
-						IF (f < Int16) OR (f = Char16) THEN y.form := Int32 ELSE y.form := f END;
-						IF m = Stk THEN Entier(y, y.typ, {}, {})
-						ELSIF m = Undef THEN Entier(y, y.typ, hint, stop)
-						ELSE Entier(y, y.typ, hint, stop + {stk})
-						END;
-						IF f = Int8 THEN Check(y, -128, 127); FreeHi(y)
-						ELSIF f = Char8 THEN Check(y, 0, 255); FreeHi(y)
-						ELSIF f = Char16 THEN Check(y, 0, 65536); FreeHi(y)
-						END;
-						y.form := f;
-						IF (m # Undef) & (m # Stk) THEN
-							IF f = Int64 THEN
-								Free(y); y.form := Int32; z := x; z.form := Int32; DevCPL486.GenMove(y, z);
-								IF z.mode = Reg THEN z.reg := z.index ELSE INC(z.offset, 4) END;
-								y.reg := y.index; DevCPL486.GenMove(y, z);
-							ELSE
-								Free(y); DevCPL486.GenMove(y, x);
-							END
-						END
-					END
-				END
-			END
-		ELSE (* y not real *)
-			IF sysval THEN
-				IF (y.form < Int16) & (f >= Int16) OR (y.form IN {Int16, Char16}) & (f >= Int32) & (f < Char16) THEN LoadL(y, hint, stop) END;
-				IF (y.form >= Int16) & (f < Int16) THEN FreeHi(y) END
-			ELSE
-				CASE y.form OF
-				| Byte, Bool:
-						IF f = Int64 THEN LoadLong(y, hint, stop)
-						ELSIF f >= Int16 THEN LoadL(y, hint, stop)
-						END
-				| Char8:
-						IF f = Int8 THEN Check(y, 0, 0)
-						ELSIF f = Int64 THEN LoadLong(y, hint, stop)
-						ELSIF f >= Int16 THEN LoadL(y, hint, stop)
-						END
-				| Char16:
-						IF f = Char8 THEN Check(y, 0, 255); FreeHi(y)
-						ELSIF f = Int8 THEN Check(y, -128, 127); FreeHi(y)
-						ELSIF f = Int16 THEN Check(y, 0, 0)
-						ELSIF f = Char16 THEN (* ok *)
-						ELSIF f = Int64 THEN LoadLong(y, hint, stop)
-						ELSIF f >= Int32 THEN LoadL(y, hint, stop)
-						END
-				| Int8:
-						IF f = Char8 THEN Check(y, 0, 0)
-						ELSIF f = Int64 THEN LoadLong(y, hint, stop)
-						ELSIF f >= Int16 THEN LoadL(y, hint, stop)
-						END
-				| Int16:
-						IF f = Char8 THEN Check(y, 0, 255); FreeHi(y)
-						ELSIF f = Char16 THEN Check(y, 0, 0)
-						ELSIF f = Int8 THEN Check(y, -128, 127); FreeHi(y)
-						ELSIF f = Int64 THEN LoadLong(y, hint, stop)
-						ELSIF (f = Int32) OR (f = Set) THEN LoadL(y, hint, stop)
-						END
-				| Int32, Set, Pointer, ProcTyp:
-						IF f = Char8 THEN Check(y, 0, 255); FreeHi(y)
-						ELSIF f = Char16 THEN Check(y, 0, 65536)
-						ELSIF f = Int8 THEN Check(y, -128, 127); FreeHi(y)
-						ELSIF f = Int16 THEN Check(y, -32768, 32767)
-						ELSIF f = Int64 THEN LoadLong(y, hint, stop)
-						END
-				| Int64:
-						IF f IN {Bool..Int32, Char16} THEN
-							(* make range checks !!! *)
-							FreeHi(y)
-						END
-				END
-			END;
-			IF f IN {Real32, Real64} THEN
-				IF sysval THEN
-					IF (m # Undef) & (m # Reg) THEN
-						IF y.mode # Reg THEN LoadW(y, hint, stop) END;
-						Free(y);
-						IF m = Stk THEN DevCPL486.GenPush(y)
-						ELSE x.form := Int32; DevCPL486.GenMove(y, x); x.form := f
-						END
-					ELSE
-						IF y.mode = Reg THEN Push(y) END;
-						y.form := f;
-						IF m = Reg THEN LoadR(y) END
-					END
-				ELSE (* not sysval *) (* int -> float *)
-					IF y.mode = Reg THEN Push(y) END;
-					IF m = Stk THEN
-						Free(y); DevCPL486.GenFLoad(y); s := -4;
-						IF f = Real64 THEN DEC(s, 4) END;
-						IF y.mode = Stk THEN
-							IF y.form = Int64 THEN INC(s, 8) ELSE INC(s, 4) END
-						END;
-						IF s # 0 THEN AdjustStack(s) END;
-						GetReg(y, Real32, {}, {});
-						Free(y); DevCPL486.GenFStore(x, TRUE)
-					ELSIF m = Reg THEN
-						LoadR(y)
-					ELSIF m # Undef THEN
-						LoadR(y); Free(y); DevCPL486.GenFStore(x, TRUE) 
-					END
-				END
-			ELSE
-				y.form := f;
-				IF m = Stk THEN
-					IF ((f < Int32) OR (f = Char16)) & (y.mode # Reg) THEN LoadW(y, hint, stop) END;
-					Push(y)
-				ELSIF m # Undef THEN
-					IF f = Int64 THEN
-						IF y.mode # Reg THEN LoadLong(y, hint, stop) END;
-						Free(y); y.form := Int32; z := x; z.form := Int32; DevCPL486.GenMove(y, z);
-						IF z.mode = Reg THEN ASSERT(z.reg # y.index); z.reg := z.index ELSE INC(z.offset, 4) END;
-						y.reg := y.index; DevCPL486.GenMove(y, z);
-					ELSE
-						IF y.mode # Reg THEN LoadW(y, hint, stop) END;
-						Free(y); DevCPL486.GenMove(y, x)
-					END
-				END
-			END
-		END	
-	END ConvMove;
-
-	PROCEDURE Convert* (VAR x: DevCPL486.Item; f: BYTE; size: INTEGER; hint, stop: SET);	(* size >= 0: sysval *)
-		VAR y: DevCPL486.Item;
-	BEGIN
-		ASSERT(x.mode # Con);
-		IF (size >= 0)
-			& ((size # x.typ.size) & ((size > 4) OR (x.typ.size > 4))
-				OR (f IN {Comp, Real64, Int64}) & (x.mode IN {Reg, Stk})) THEN DevCPM.err(220) END;
-(*
-		IF sysval & ((x.form = Real64) & ~(f IN {Comp, Int64}) OR (f = Real64) & ~(x.form  IN {Comp, Int64})) THEN DevCPM.err(220) END;
-*)
-		y.mode := Undef; y.form := f; ConvMove(y, x, size >= 0, hint, stop)
-	END Convert;
-
-	PROCEDURE LoadCond* (VAR x, y: DevCPL486.Item; F, T: DevCPL486.Label; hint, stop: SET);
-		VAR end, T1: DevCPL486.Label; c, r: DevCPL486.Item;
-	BEGIN
-		IF mem IN stop THEN GetReg(x, Bool, hint, stop) END;
-		IF (F = DevCPL486.NewLbl) & (T = DevCPL486.NewLbl) THEN (* no label used *)
-			DevCPL486.GenSetCC(y.offset, x)
-		ELSE
-			end := DevCPL486.NewLbl; T1 := DevCPL486.NewLbl;
-			DevCPL486.GenJump(y.offset, T1, TRUE);	(* T1 to enable short jump *)
-			DevCPL486.SetLabel(F);
-			DevCPL486.MakeConst(c, 0, Bool); DevCPL486.GenMove(c, x);
-			DevCPL486.GenJump(ccAlways, end, TRUE);
-			DevCPL486.SetLabel(T); DevCPL486.SetLabel(T1); 
-			DevCPL486.MakeConst(c, 1, Bool); DevCPL486.GenMove(c, x);
-			DevCPL486.SetLabel(end)
-		END;
-		IF x.mode # Reg THEN Free(x) END
-	END LoadCond;
-	
-	PROCEDURE IntDOp* (VAR x, y: DevCPL486.Item; subcl: BYTE; rev: BOOLEAN);
-		VAR local: DevCPL486.Label;
-	BEGIN
-		ASSERT((x.mode = Reg) OR (y.mode = Reg) OR (y.mode = Con));
-		CASE subcl OF
-		| eql..geq:
-				DevCPL486.GenComp(y, x); Free(x);
-				setCC(x, subcl, rev, x.typ.form IN {Int8..Int32})
-		| times: 
-				IF x.form = Set THEN DevCPL486.GenAnd(y, x) ELSE DevCPL486.GenMul(y, x, ovflchk) END
-		| slash:
-				DevCPL486.GenXor(y, x)
-		| plus:
-				IF x.form = Set THEN DevCPL486.GenOr(y, x) ELSE DevCPL486.GenAdd(y, x, ovflchk) END
-		| minus, msk:
-				IF (x.form = Set) OR (subcl = msk) THEN (* and not *)
-					IF rev THEN DevCPL486.GenNot(x); DevCPL486.GenAnd(y, x)								(* y and not x *)
-					ELSIF y.mode = Con THEN y.offset := -1 - y.offset; DevCPL486.GenAnd(y, x)	(* x and y' *)
-					ELSIF y.mode = Reg THEN DevCPL486.GenNot(y); DevCPL486.GenAnd(y, x)			(* x and not y *)
-					ELSE DevCPL486.GenNot(x); DevCPL486.GenOr(y, x); DevCPL486.GenNot(x)					(* not (not x or y) *)
-					END
-				ELSE	(* minus *)
-					IF rev THEN	(* y - x *)
-						IF (y.mode = Con) & (y.offset = -1) THEN DevCPL486.GenNot(x)
-						ELSE DevCPL486.GenNeg(x, ovflchk); DevCPL486.GenAdd(y, x, ovflchk)	(* ??? *)
-						END
-					ELSE	(* x - y *)
-						DevCPL486.GenSub(y, x, ovflchk)
-					END
-				END
-		| min, max:
-				local := DevCPL486.NewLbl;
-				DevCPL486.GenComp(y, x);
-				IF subcl = min THEN 
-					IF x.typ.form IN {Char8, Char16} THEN DevCPL486.GenJump(ccBE, local, TRUE)
-					ELSE DevCPL486.GenJump(ccLE, local, TRUE)
-					END
-				ELSE
-					IF x.typ.form IN {Char8, Char16} THEN DevCPL486.GenJump(ccAE, local, TRUE)
-					ELSE DevCPL486.GenJump(ccGE, local, TRUE)
-					END
-				END;
-				DevCPL486.GenMove(y, x);
-				DevCPL486.SetLabel(local)
-		END;
-		Free(y);
-		IF x.mode # Reg THEN Free(x) END
-	END IntDOp;
-	
-	PROCEDURE LargeInc* (VAR x, y: DevCPL486.Item; dec: BOOLEAN);	(* INC(x, y) or DEC(x, y) *)
-	BEGIN
-		ASSERT(x.form = Int64);
-		IF ~(y.mode IN {Reg, Con}) THEN LoadLong(y, {}, {}) END;
-		Free(x); Free(y); x.form := Int32; y.form := Int32;
-		IF dec THEN DevCPL486.GenSubC(y, x, TRUE, FALSE) ELSE DevCPL486.GenAddC(y, x, TRUE, FALSE) END;
-		INC(x.offset, 4);
-		IF y.mode = Reg THEN y.reg := y.index ELSE y.offset := y.scale END;
-		IF dec THEN DevCPL486.GenSubC(y, x, FALSE, ovflchk) ELSE DevCPL486.GenAddC(y, x, FALSE, ovflchk) END;
-	END LargeInc;
-	
-	PROCEDURE FloatDOp* (VAR x, y: DevCPL486.Item; subcl: BYTE; rev: BOOLEAN);
-		VAR local: DevCPL486.Label; a, b: DevCPL486.Item;
-	BEGIN
-		ASSERT(x.mode = Reg);
-		IF y.form = Int64 THEN LoadR(y) END;
-		IF y.mode = Reg THEN rev := ~rev END;
-		CASE subcl OF
-		| eql..geq: DevCPL486.GenFDOp(FCOMP, y)
-		| times: DevCPL486.GenFDOp(FMUL, y)
-		| slash: IF rev THEN DevCPL486.GenFDOp(FDIVR, y) ELSE DevCPL486.GenFDOp(FDIV, y) END
-		| plus: DevCPL486.GenFDOp(FADD, y)
-		| minus: IF rev THEN DevCPL486.GenFDOp(FSUBR, y) ELSE DevCPL486.GenFDOp(FSUB, y) END
-		| min, max:
-			IF y.mode = Reg THEN
-				DevCPL486.GenFMOp(0D1H);	(* FCOM ST1 *)
-				CheckAv(AX); DevCPL486.GenFMOp(FSTSW); (* DevCPL486.GenCode(WAIT); *) DevCPL486.GenCode(SAHF);
-				local := DevCPL486.NewLbl;
-				IF subcl = min THEN DevCPL486.GenJump(ccAE, local, TRUE) ELSE DevCPL486.GenJump(ccBE, local, TRUE) END;
-				DevCPL486.GenFMOp(5D1H);	(* FST ST1 *)
-				DevCPL486.SetLabel(local);
-				DevCPL486.GenFMOp(5D8H)	(* FSTP ST0 *)
-			ELSE
-				DevCPL486.GenFDOp(FCOM, y);
-				CheckAv(AX); DevCPL486.GenFMOp(FSTSW); (* DevCPL486.GenCode(WAIT); *) DevCPL486.GenCode(SAHF);
-				local := DevCPL486.NewLbl;
-				IF subcl = min THEN DevCPL486.GenJump(ccBE, local, TRUE) ELSE DevCPL486.GenJump(ccAE, local, TRUE) END;
-				DevCPL486.GenFMOp(5D8H);	(* FSTP ST0 *)
-				DevCPL486.GenFLoad(y);
-				DevCPL486.SetLabel(local)
-			END
-		(* largeint support *)
-		| div:
-			IF rev THEN DevCPL486.GenFDOp(FDIVR, y) ELSE DevCPL486.GenFDOp(FDIV, y) END;
-			Floor(y, FALSE)
-		| mod:
-			IF y.mode # Reg THEN LoadR(y); rev := ~rev END;
-			IF rev THEN DevCPL486.GenFMOp(1C9H); (* FXCH ST1 *) END;
-			DevCPL486.GenFMOp(1F8H);	(* FPREM *)
-			DevCPL486.GenFMOp(1E4H);	(* FTST *)
-			CheckAv(AX);
-			DevCPL486.GenFMOp(FSTSW);
-			DevCPL486.MakeReg(a, AX, Int32); GetReg(b, Int32, {}, {AX});
-			DevCPL486.GenMove(a, b);
-			DevCPL486.GenFMOp(0D1H);	(* FCOM *)
-			DevCPL486.GenFMOp(FSTSW);
-			DevCPL486.GenXor(b, a); Free(b);
-			(* DevCPL486.GenCode(WAIT); *) DevCPL486.GenCode(SAHF);
-			local := DevCPL486.NewLbl; DevCPL486.GenJump(ccBE, local, TRUE);
-			DevCPL486.GenFMOp(0C1H);	(* FADD ST1 *)
-			DevCPL486.SetLabel(local);
-			DevCPL486.GenFMOp(5D9H);	(* FSTP ST1 *)
-		| ash:
-			IF y.mode # Reg THEN LoadR(y); rev := ~rev END;
-			IF rev THEN DevCPL486.GenFMOp(1C9H); (* FXCH ST1 *) END;
-			DevCPL486.GenFMOp(1FDH);	(* FSCALE *)
-			Floor(y, TRUE)
-		END;
-		IF y.mode = Stk THEN IncStack(y.form) END;
-		Free(y);
-		IF (subcl >= eql) & (subcl <= geq) THEN
-			Free(x); CheckAv(AX);
-			DevCPL486.GenFMOp(FSTSW);
-			(* DevCPL486.GenCode(WAIT); *) DevCPL486.GenCode(SAHF);
-			setCC(x, subcl, rev, FALSE)
-		END
-	END FloatDOp;
-	
-	PROCEDURE IntMOp* (VAR x: DevCPL486.Item; subcl: BYTE);
-		VAR L: DevCPL486.Label; c: DevCPL486.Item;
-	BEGIN
-		CASE subcl OF
-		| minus:
-				IF x.form = Set THEN DevCPL486.GenNot(x) ELSE DevCPL486.GenNeg(x, ovflchk) END
-		| abs:
-				L := DevCPL486.NewLbl; DevCPL486.MakeConst(c, 0, x.form);
-				DevCPL486.GenComp(c, x);
-				DevCPL486.GenJump(ccNS, L, TRUE);
-				DevCPL486.GenNeg(x, ovflchk);
-				DevCPL486.SetLabel(L)
-		| cap:
-				DevCPL486.MakeConst(c, -1 - 20H, x.form);
-				DevCPL486.GenAnd(c, x)
-		| not:
-				DevCPL486.MakeConst(c, 1, x.form);
-				DevCPL486.GenXor(c, x)
-		END;
-		IF x.mode # Reg THEN Free(x) END
-	END IntMOp;
-	
-	PROCEDURE FloatMOp* (VAR x: DevCPL486.Item; subcl: BYTE);
-	BEGIN
-		ASSERT(x.mode = Reg);
-		IF subcl = minus THEN DevCPL486.GenFMOp(FCHS)
-		ELSE ASSERT(subcl = abs); DevCPL486.GenFMOp(FABS)
-		END
-	END FloatMOp;
-
-	PROCEDURE MakeSet* (VAR x: DevCPL486.Item; range, neg: BOOLEAN; hint, stop: SET);
-		(* range neg	result
-				F	F		{x}
-				F	T		-{x}
-				T	F		{x..31}
-				T	T		-{0..x}	*)
-		VAR c, r: DevCPL486.Item; val: INTEGER;
-	BEGIN
-		IF x.mode = Con THEN
-			IF range THEN
-				IF neg THEN val := -2 ELSE val := -1 END;
-				x.offset := SYSTEM.LSH(val, x.offset)
-			ELSE
-				val := 1; x.offset := SYSTEM.LSH(val, x.offset);
-				IF neg THEN x.offset := -1 - x.offset END
-			END
-		ELSE
-			Check(x, 0, 31);
-			IF neg THEN val := -2
-			ELSIF range THEN val := -1
-			ELSE val := 1
-			END;
-			DevCPL486.MakeConst(c, val, Set); GetReg(r, Set, hint, stop); DevCPL486.GenMove(c, r);
-			IF range THEN DevCPL486.GenShiftOp(SHL, x, r) ELSE DevCPL486.GenShiftOp(ROL, x, r) END;
-			Free(x); x.reg := r.reg
-		END;
-		x.typ := DevCPT.settyp; x.form := Set
-	END MakeSet;
-	
-	PROCEDURE MakeCond* (VAR x: DevCPL486.Item);
-		VAR c: DevCPL486.Item;
-	BEGIN
-		IF x.mode = Con THEN
-			setCC(x, SHORT(SHORT(x.offset)), FALSE, FALSE)
-		ELSE
-			DevCPL486.MakeConst(c, 0, x.form);
-			DevCPL486.GenComp(c, x); Free(x);
-			setCC(x, neq, FALSE, FALSE)
-		END
-	END MakeCond;
-	
-	PROCEDURE Not* (VAR x: DevCPL486.Item);
-		VAR a: INTEGER;
-	BEGIN
-		x.offset := Inverted(x.offset); (* invert cc *)
-	END Not;
-	
-	PROCEDURE Odd* (VAR x: DevCPL486.Item);
-		VAR c: DevCPL486.Item;
-	BEGIN
-		IF x.mode = Stk THEN Pop(x, x.form, {}, {}) END;
-		Free(x); DevCPL486.MakeConst(c, 1, x.form);
-		IF x.mode = Reg THEN
-			IF x.form IN {Int16, Int64} THEN x.form := Int32; c.form := Int32 END;
-			DevCPL486.GenAnd(c, x)
-		ELSE
-			c.form := Int8; x.form := Int8; DevCPL486.GenTest(c, x)
-		END;
-		setCC(x, neq, FALSE, FALSE)
-	END Odd;
-	
-	PROCEDURE In* (VAR x, y: DevCPL486.Item);
-	BEGIN
-		IF y.form = Set THEN Check(x, 0, 31) END;
-		DevCPL486.GenBitOp(BT, x, y); Free(x); Free(y);
-		setCC(x, lss, FALSE, FALSE); (* carry set *)
-	END In;
-	
-	PROCEDURE Shift* (VAR x, y: DevCPL486.Item; subcl: BYTE);	(* ASH, LSH, ROT *)
-		VAR L1, L2: DevCPL486.Label; c: DevCPL486.Item; opl, opr: INTEGER;
-	BEGIN
-		IF subcl = ash THEN opl := SHL; opr := SAR
-		ELSIF subcl = lsh THEN opl := SHL; opr := SHR
-		ELSE opl := ROL; opr := ROR
-		END;
-		IF y.mode = Con THEN
-			IF y.offset > 0 THEN
-				DevCPL486.GenShiftOp(opl, y, x)
-			ELSIF y.offset < 0 THEN
-				y.offset := -y.offset;
-				DevCPL486.GenShiftOp(opr, y, x)
-			END
-		ELSE
-			ASSERT(y.mode = Reg);
-			Check(y, -31, 31);
-			L1 := DevCPL486.NewLbl; L2 := DevCPL486.NewLbl; 
-			DevCPL486.MakeConst(c, 0, y.form); DevCPL486.GenComp(c, y);
-			DevCPL486.GenJump(ccNS, L1, TRUE);
-			DevCPL486.GenNeg(y, FALSE);
-			DevCPL486.GenShiftOp(opr, y, x);
-			DevCPL486.GenJump(ccAlways, L2, TRUE);
-			DevCPL486.SetLabel(L1);
-			DevCPL486.GenShiftOp(opl, y, x);
-			DevCPL486.SetLabel(L2);
-			Free(y)
-		END;
-		IF x.mode # Reg THEN Free(x) END
-	END Shift;
-
-	PROCEDURE DivMod* (VAR x, y: DevCPL486.Item; mod: BOOLEAN);
-		VAR s: SET; r: DevCPL486.Item; pos: BOOLEAN;
-	BEGIN
-		ASSERT((x.mode = Reg) & (x.reg = AX)); pos := FALSE;
-		IF y.mode = Con THEN pos := (y.offset > 0) & (y.obj = NIL); Load(y, {}, {AX, DX, con}) END;
-		DevCPL486.GenDiv(y, mod, pos); Free(y);
-		IF mod THEN
-			r := x; GetReg(x, x.form, {}, wreg - {AX, DX}); Free(r) (* ax -> dx; al -> ah *)	(* ??? *)
-		END
-	END DivMod;
-
-	PROCEDURE Mem* (VAR x: DevCPL486.Item; offset: INTEGER; typ: DevCPT.Struct);	(* x := Mem[x+offset] *)
-	BEGIN
-		IF x.mode = Con THEN x.mode := Abs; x.obj := NIL; INC(x.offset, offset)
-		ELSE ASSERT(x.mode = Reg); x.mode := Ind; x.offset := offset
-		END;
-		x.scale := 0; x.typ := typ; x.form := typ.form
-	END Mem;
-	
-	PROCEDURE SysMove* (VAR len: DevCPL486.Item);	(* implementation of SYSTEM.MOVE *)
-	BEGIN
-		IF len.mode = Con THEN
-			IF len.offset > 0 THEN DevCPL486.GenBlockMove(1, len.offset) END
-		ELSE
-			Load(len, {}, wreg - {CX} + {short, mem, stk}); DevCPL486.GenBlockMove(1, 0); Free(len)
-		END;
-		FreeWReg(SI); FreeWReg(DI)
-	END SysMove;
-	
-	PROCEDURE Len* (VAR x, y: DevCPL486.Item);
-		VAR typ: DevCPT.Struct; dim: INTEGER;
-	BEGIN
-		dim := y.offset; typ := x.typ;
-		IF typ.untagged THEN DevCPM.err(136) END;
-		WHILE dim > 0 DO typ := typ.BaseTyp; DEC(dim) END;
-		LenDesc(x, x, typ);
-	END Len;
-	
-	PROCEDURE StringWSize (VAR x: DevCPL486.Item): INTEGER;
-	BEGIN
-		CASE x.form OF
-		| String8, VString8: RETURN 1
-		| String16, VString16: RETURN 2
-		| VString16to8: RETURN 0
-		| Comp: RETURN x.typ.BaseTyp.size
-		END
-	END StringWSize;
-
-	PROCEDURE CmpString* (VAR x, y: DevCPL486.Item; rel: BYTE; rev: BOOLEAN);
-		VAR sw, dw: INTEGER;
-	BEGIN
-		CheckAv(CX);
-		IF (x.typ = DevCPT.guidtyp) OR (y.typ = DevCPT.guidtyp) THEN
-			DevCPL486.GenBlockComp(4, 4)
-		ELSIF x.form = String8 THEN DevCPL486.GenBlockComp(1, x.index)
-		ELSIF y.form = String8 THEN DevCPL486.GenBlockComp(1, y.index)
-		ELSIF x.form = String16 THEN DevCPL486.GenBlockComp(2, x.index)
-		ELSIF y.form = String16 THEN DevCPL486.GenBlockComp(2, y.index)
-		ELSE DevCPL486.GenStringComp(StringWSize(y), StringWSize(x))
-		END;
-		FreeWReg(SI); FreeWReg(DI); setCC(x, rel, ~rev, FALSE);
-	END CmpString;
-
-	PROCEDURE VarParDynArr (ftyp: DevCPT.Struct; VAR y: DevCPL486.Item);
-		VAR len, z: DevCPL486.Item; atyp: DevCPT.Struct;
-	BEGIN
-		atyp := y.typ;
-		WHILE ftyp.comp = DynArr DO
-			IF ftyp.BaseTyp = DevCPT.bytetyp THEN
-				IF atyp.comp = DynArr THEN
-					IF atyp.untagged THEN DevCPM.err(137) END;
-					LenDesc(y, len, atyp);
-					IF y.tmode = VarPar THEN Free(len) END;	(* ??? *)
-					GetReg(z, Int32, {}, {}); DevCPL486.GenMove(len, z);
-					len.mode := Reg; len.reg := z.reg; atyp := atyp.BaseTyp;
-					WHILE atyp.comp = DynArr DO
-						LenDesc(y, z, atyp); DevCPL486.GenMul(z, len, FALSE);
-						IF y.tmode = VarPar THEN Free(z) END;	(* ??? *)
-						atyp := atyp.BaseTyp
-					END;
-					DevCPL486.MakeConst(z, atyp.size, Int32); DevCPL486.GenMul(z, len, FALSE);
-					Free(len)
-				ELSE
-					DevCPL486.MakeConst(len, atyp.size, Int32)
-				END
-			ELSE
-				IF atyp.comp = DynArr THEN LenDesc(y, len, atyp);
-					IF atyp.untagged THEN DevCPM.err(137) END;
-					IF y.tmode = VarPar THEN Free(len) END;	(* ??? *)
-				ELSE DevCPL486.MakeConst(len, atyp.n, Int32)
-				END
-			END;
-			DevCPL486.GenPush(len);
-			ftyp := ftyp.BaseTyp; atyp := atyp.BaseTyp
-		END
-	END VarParDynArr;
-
-	PROCEDURE Assign* (VAR x, y: DevCPL486.Item); (* x := y *)
-	BEGIN
-		IF y.mode = Con THEN
-			IF y.form IN {Real32, Real64} THEN
-				DevCPL486.GenFLoad(y); GetReg(y, Real32, {}, {});
-				IF x.mode # Reg THEN Free(y); DevCPL486.GenFStore(x, TRUE) END	(* ??? move const *)
-			ELSIF x.form = Int64 THEN
-				ASSERT(x.mode IN {Ind, Abs});
-				y.form := Int32; x.form := Int32; DevCPL486.GenMove(y, x);
-				y.offset := y.scale; INC(x.offset, 4); DevCPL486.GenMove(y, x);
-				DEC(x.offset, 4); x.form := Int64
-			ELSE
-				DevCPL486.GenMove(y, x)
-			END
-		ELSE
-			IF y.form IN {Comp, String8, String16, VString8, VString16} THEN	(* convert to pointer *)
-				ASSERT(x.form = Pointer);
-				GetAdr(y, {}, {}); y.typ := x.typ; y.form := Pointer
-			END;
-			IF ~(x.form IN realSet) OR ~(y.form IN intSet) THEN Assert(y, {}, {stk}) END;
-			ConvMove(x, y, FALSE, {}, {})
-		END;
-		Free(x)
-	END Assign;
-	
-	PROCEDURE ArrayLen* (VAR x, len: DevCPL486.Item; hint, stop: SET);
-		VAR c: DevCPL486.Item;
-	BEGIN
-		IF x.typ.comp = Array THEN DevCPL486.MakeConst(c, x.typ.n, Int32); GetReg(len, Int32, hint, stop); DevCPL486.GenMove(c, len)
-		ELSIF ~x.typ.untagged THEN LenDesc(x, c, x.typ); GetReg(len, Int32, hint, stop); DevCPL486.GenMove(c, len)
-		ELSE len.mode := Con
-		END;
-		len.typ := DevCPT.int32typ
-	END ArrayLen;
-
-(*
-(!)		src		dest	zero
-sx	= sy	x b		y b
-SHORT(lx)	= sy	x b+	x w	y b
-SHORT(lx)	= SHORT(ly)	x b+	x w	y b+
-
-lx	= ly	x w		y w
-LONG(sx)	= ly	x b		y w	*
-LONG(SHORT(lx))	= ly	x b+	x w*	y w	*
-
-sx	:= sy	y b		x b
-sx	:= SHORT(ly)	y b+	y w	x b
-
-lx	:= ly	y w		x w
-lx	:= LONG(sy)	y b		x w	*
-lx	:= LONG(SHORT(ly))	y b+	y w*	x w	*
-(!)*)
-	
-	PROCEDURE AddCopy* (VAR x, y: DevCPL486.Item; last: BOOLEAN); (* x := .. + y + .. *)
-	BEGIN
-		IF (x.typ.comp = DynArr) & x.typ.untagged THEN
-			DevCPL486.GenStringMove(~last, StringWSize(y), StringWSize(x), -1)
-		ELSE
-			DevCPL486.GenStringMove(~last, StringWSize(y), StringWSize(x), 0)
-		END;
-		FreeWReg(SI); FreeWReg(DI)
-	END AddCopy;
-	
-	PROCEDURE Copy* (VAR x, y: DevCPL486.Item; short: BOOLEAN); (* x := y *)
-		VAR sx, sy, sy2, sy4: INTEGER; c, r: DevCPL486.Item;
-	BEGIN
-		sx := x.typ.size; CheckAv(CX);
-		IF y.form IN {String8, String16} THEN
-			sy := y.index * y.typ.BaseTyp.size;
-			IF x.typ.comp = Array THEN	(* adjust size for optimal performance *)
-				sy2 := sy + sy MOD 2; sy4 := sy2 + sy2 MOD 4;
-				IF sy4 <= sx THEN sy := sy4
-				ELSIF sy2 <= sx THEN sy := sy2
-				ELSIF sy > sx THEN DevCPM.err(114); sy := 1
-				END
-			ELSIF inxchk & ~x.typ.untagged THEN	(* check array length *)
-				Free(x); LenDesc(x, c, x.typ);
-				DevCPL486.MakeConst(y, y.index, Int32);
-				DevCPL486.GenComp(y, c); DevCPL486.GenAssert(ccAE, copyTrap);
-				Free(c)
-			END;
-			DevCPL486.GenBlockMove(1, sy)
-		ELSIF x.typ.comp = DynArr THEN
-			IF x.typ.untagged THEN
-				DevCPL486.GenStringMove(FALSE, StringWSize(y), StringWSize(x), -1)
-			ELSE
-				Free(x); LenDesc(x, c, x.typ); DevCPL486.MakeReg(r, CX, Int32); DevCPL486.GenMove(c, r); Free(c);
-				DevCPL486.GenStringMove(FALSE, StringWSize(y), StringWSize(x), 0)
-			END
-		ELSIF y.form IN {VString16to8, VString8, VString16} THEN
-			DevCPL486.GenStringMove(FALSE, StringWSize(y), StringWSize(x), x.typ.n);
-			ASSERT(y.mode # Stk)
-		ELSIF short THEN	(* COPY *)
-			sy := y.typ.size;
-			IF (y.typ.comp # DynArr) & (sy < sx) THEN sx := sy END;
-			DevCPL486.GenStringMove(FALSE, StringWSize(y), StringWSize(x), x.typ.n);
-			IF y.mode = Stk THEN AdjustStack(sy) END
-		ELSE	(* := *)
-			IF sx > 0 THEN DevCPL486.GenBlockMove(1, sx) END;
-			IF y.mode = Stk THEN AdjustStack(sy) END
-		END;
-		FreeWReg(SI); FreeWReg(DI)
-	END Copy;
-	
-	PROCEDURE StrLen* (VAR x: DevCPL486.Item; typ: DevCPT.Struct; incl0x: BOOLEAN);
-		VAR c: DevCPL486.Item;
-	BEGIN
-		CheckAv(AX); CheckAv(CX);
-		DevCPL486.GenStringLength(typ.BaseTyp.size, -1);
-		Free(x); GetReg(x, Int32, {}, wreg - {CX});
-		DevCPL486.GenNot(x);
-		IF ~incl0x THEN DevCPL486.MakeConst(c, 1, Int32); DevCPL486.GenSub(c, x, FALSE) END;
-		FreeWReg(DI)
-	END StrLen;
-
-	PROCEDURE MulDim* (VAR y, z: DevCPL486.Item; VAR fact: INTEGER; dimtyp: DevCPT.Struct);	(* z := z * y *)
-		VAR c: DevCPL486.Item;
-	BEGIN
-		IF y.mode = Con THEN fact := fact * y.offset
-		ELSE
-			IF ranchk OR inxchk THEN
-				DevCPL486.MakeConst(c, 0, Int32); DevCPL486.GenComp(c, y); DevCPL486.GenAssert(ccG, ranTrap)
-			END;
-			DevCPL486.GenPush(y);
-			IF z.mode = Con THEN z := y
-			ELSE DevCPL486.GenMul(y, z, ovflchk OR inxchk); Free(y)
-			END
-		END
-	END MulDim;
-	
-	PROCEDURE SetDim* (VAR x, y: DevCPL486.Item; dimtyp: DevCPT.Struct); (* set LEN(x^, -dimtyp.n) *)
-		(* y const or on stack *) 
-		VAR z: DevCPL486.Item; end: DevCPL486.Label;
-	BEGIN
-		ASSERT((x.mode = Reg) & (x.form = Pointer));
-		z.mode := Ind; z.reg := x.reg; z.offset := ArrDOffs + 4 + dimtyp.n * 4; z.scale := 0; z.form := Int32;
-		IF y.mode = Con THEN y.form := Int32
-		ELSE Pop(y, Int32, {}, {})
-		END;
-		end := DevCPL486.NewLbl; DevCPL486.GenJump(ccE, end, TRUE);	(* flags set in New *)
-		DevCPL486.GenMove(y, z);
-		DevCPL486.SetLabel(end);
-		IF y.mode = Reg THEN Free(y) END
-	END SetDim;
-
-	PROCEDURE SysNew* (VAR x: DevCPL486.Item);
-	BEGIN
-		DevCPM.err(141)
-	END SysNew;
-
-	PROCEDURE New* (VAR x, nofel: DevCPL486.Item; fact: INTEGER);
-		(* x.typ.BaseTyp.comp IN {Record, Array, DynArr} *)
-		VAR p, tag, c: DevCPL486.Item; nofdim, dlen, n: INTEGER; typ, eltyp: DevCPT.Struct; lbl: DevCPL486.Label;
-	BEGIN
-		typ := x.typ.BaseTyp;
-		IF typ.untagged THEN DevCPM.err(138) END;
-		IF typ.comp = Record THEN	(* call to Kernel.NewRec(tag: Tag): ADDRESS *)
-			DevCPL486.MakeConst(tag, 0, Pointer); tag.obj := DevCPE.TypeObj(typ);
-			IF ContainsIPtrs(typ) THEN INC(tag.offset) END;
-			DevCPL486.GenPush(tag);
-			p.mode := XProc; p.obj := DevCPE.KNewRec;
-		ELSE eltyp := typ.BaseTyp;
-			IF typ.comp = Array THEN
-				nofdim := 0; nofel.mode := Con; nofel.form := Int32; fact := typ.n
-			ELSE (* DynArr *)
-				nofdim := typ.n+1;
-				WHILE eltyp.comp = DynArr DO eltyp := eltyp.BaseTyp END
-			END ;
-			WHILE eltyp.comp = Array DO fact := fact * eltyp.n; eltyp := eltyp.BaseTyp END;
-			IF eltyp.comp = Record THEN
-				IF eltyp.untagged THEN DevCPM.err(138) END;
-				DevCPL486.MakeConst(tag, 0, Pointer); tag.obj := DevCPE.TypeObj(eltyp);
-				IF ContainsIPtrs(eltyp) THEN INC(tag.offset) END;
-			ELSIF eltyp.form = Pointer THEN
-				IF ~eltyp.untagged THEN
-					DevCPL486.MakeConst(tag, 0, Pointer)	(* special TDesc in Kernel for ARRAY OF pointer *)
-				ELSIF eltyp.sysflag = interface THEN
-					DevCPL486.MakeConst(tag, -1, Pointer)	(* special TDesc in Kernel for ARRAY OF interface pointer *)
-				ELSE
-					DevCPL486.MakeConst(tag, 12, Pointer)
-				END
-			ELSE	(* eltyp is pointerless basic type *)
-				CASE eltyp.form OF
-				| Undef, Byte, Char8: n := 1;
-				| Int16: n := 2;
-				| Int8: n := 3;
-				| Int32: n := 4;
-				| Bool: n := 5;
-				| Set: n := 6;
-				| Real32: n := 7;
-				| Real64: n := 8;
-				| Char16: n := 9;
-				| Int64: n := 10;
-				| ProcTyp: n := 11;
-				END;
-				DevCPL486.MakeConst(tag, n, Pointer)
-(*
-				DevCPL486.MakeConst(tag, eltyp.size, Pointer)
-*)
-			END;
-			IF nofel.mode = Con THEN nofel.offset := fact; nofel.obj := NIL
-			ELSE DevCPL486.MakeConst(p, fact, Int32); DevCPL486.GenMul(p, nofel, ovflchk OR inxchk)
-			END;
-			DevCPL486.MakeConst(p, nofdim, Int32); DevCPL486.GenPush(p);
-			DevCPL486.GenPush(nofel); Free(nofel); DevCPL486.GenPush(tag);
-			p.mode := XProc; p.obj := DevCPE.KNewArr;
-		END;
-		DevCPL486.GenCall(p); GetReg(x, Pointer, {}, wreg - {AX});
-		IF typ.comp = DynArr THEN	(* set flags for nil test *)
-			DevCPL486.MakeConst(c, 0, Pointer); DevCPL486.GenComp(c, x)
-		ELSIF typ.comp = Record THEN
-			n := NumOfIntProc(typ);
-			IF n > 0 THEN	(* interface method table pointer setup *)
-				DevCPL486.MakeConst(c, 0, Pointer); DevCPL486.GenComp(c, x);
-				lbl := DevCPL486.NewLbl; DevCPL486.GenJump(ccE, lbl, TRUE);
-				tag.offset := - 4 * (n + numPreIntProc);
-				p.mode := Ind; p.reg := AX; p.offset := 0; p.scale := 0; p.form := Pointer;
-				DevCPL486.GenMove(tag, p);
-				IF nofel.mode # Con THEN	(* unk pointer setup *)
-					p.offset := 8;
-					DevCPL486.GenMove(nofel, p);
-					Free(nofel)
-				END;
-				DevCPL486.SetLabel(lbl);
-			END
-		END
-	END New;
-
-	PROCEDURE Param* (fp: DevCPT.Object; rec, niltest: BOOLEAN; VAR ap, tag: DevCPL486.Item);	(* returns tag if rec *)
-		VAR f: BYTE; s, ss: INTEGER; par, a, c: DevCPL486.Item; recTyp: DevCPT.Struct;
-	BEGIN
-		par.mode := Stk; par.typ := fp.typ; par.form := par.typ.form;
-		IF ODD(fp.sysflag DIV nilBit) THEN niltest := FALSE END;
-		IF ap.typ = DevCPT.niltyp THEN
-			IF ((par.typ.comp = Record) OR (par.typ.comp = DynArr)) & ~par.typ.untagged THEN
-				DevCPM.err(142)
-			END;
-			DevCPL486.GenPush(ap)
-		ELSIF par.typ.comp = DynArr THEN
-			IF ap.form IN {String8, String16} THEN
-				IF ~par.typ.untagged THEN
-					DevCPL486.MakeConst(c, ap.index (* * ap.typ.BaseTyp.size *), Int32); DevCPL486.GenPush(c)
-				END;
-				ap.mode := Con; DevCPL486.GenPush(ap);
-			ELSIF ap.form IN {VString8, VString16} THEN
-				DevCPL486.MakeReg(a, DX, Pointer); DevCPL486.GenLoadAdr(ap, a);
-				IF ~par.typ.untagged THEN
-					DevCPL486.MakeReg(c, DI, Pointer); DevCPL486.GenMove(a, c);
-					Free(ap); StrLen(c, ap.typ, TRUE);
-					DevCPL486.GenPush(c); Free(c)
-				END;
-				DevCPL486.GenPush(a)
-			ELSE
-				IF ~par.typ.untagged THEN
-					IF ap.typ.comp = DynArr THEN niltest := FALSE END;	(* ap dereferenced for length descriptor *)
-					VarParDynArr(par.typ, ap)
-				END;
-				PushAdr(ap, niltest)
-			END
-		ELSIF fp.mode = VarPar THEN
-			recTyp := ap.typ;
-			IF recTyp.form = Pointer THEN recTyp := recTyp.BaseTyp END;
-			IF (par.typ.comp = Record) & (~fp.typ.untagged) THEN
-				Tag(ap, tag);
-				IF rec & (tag.mode # Con) THEN
-					GetReg(c, Pointer, {}, {}); DevCPL486.GenMove(tag, c); tag := c
-				END;
-				DevCPL486.GenPush(tag);
-				IF tag.mode # Con THEN niltest := FALSE END;
-				PushAdr(ap, niltest);
-				IF rec THEN Free(tag) END
-			ELSE PushAdr(ap, niltest)
-			END;
-			tag.typ := recTyp
-		ELSIF par.form = Comp THEN
-			s := par.typ.size;
-			IF initializeStr & (ap.form IN {String8, String16, VString8, VString16, VString16to8}) THEN
-				s := (s + 3) DIV 4 * 4; AdjustStack(-s);
-				IF ap.form IN {String8, String16} THEN
-					IF ap.index > 1 THEN	(* nonempty string *)
-						ss := (ap.index * ap.typ.BaseTyp.size + 3) DIV 4 * 4;
-						DevCPL486.MakeReg(c, SI, Pointer); DevCPL486.GenLoadAdr(ap, c); Free(ap);
-						DevCPL486.MakeReg(c, DI, Pointer); DevCPL486.GenLoadAdr(par, c);
-						DevCPL486.GenBlockMove(1, ss);
-					ELSE
-						ss := 0;
-						DevCPL486.MakeReg(c, DI, Pointer); DevCPL486.GenLoadAdr(par, c)
-					END;
-					IF s > ss THEN
-						DevCPL486.MakeReg(a, AX, Int32); DevCPL486.MakeConst(c, 0, Int32); DevCPL486.GenMove(c, a);
-						DevCPL486.GenBlockStore(1, s - ss)
-					END;
-				ELSE
-					DevCPL486.MakeReg(c, SI, Pointer); DevCPL486.GenLoadAdr(ap, c); Free(ap);
-					DevCPL486.MakeReg(c, DI, Pointer); DevCPL486.GenLoadAdr(par, c);
-					DevCPL486.GenStringMove(TRUE, StringWSize(ap), StringWSize(par), par.typ.n);
-					DevCPL486.MakeReg(a, AX, Int32); DevCPL486.MakeConst(c, 0, Int32); DevCPL486.GenMove(c, a);
-					DevCPL486.GenBlockStore(StringWSize(par), 0)
-				END
-			ELSE
-				IF (ap.form IN {String8, String16}) & (ap.index = 1) THEN	(* empty string *)
-					AdjustStack((4 - s) DIV 4 * 4);
-					DevCPL486.MakeConst(c, 0, Int32); DevCPL486.GenPush(c)
-				ELSE
-					AdjustStack((-s) DIV 4 * 4);
-					DevCPL486.MakeReg(c, SI, Pointer); DevCPL486.GenLoadAdr(ap, c); Free(ap);
-					DevCPL486.MakeReg(c, DI, Pointer); DevCPL486.GenLoadAdr(par, c);
-					IF ap.form IN {String8, String16} THEN
-						DevCPL486.GenBlockMove(1, (ap.index * ap.typ.BaseTyp.size + 3) DIV 4 * 4)
-					ELSIF ap.form IN {VString8, VString16, VString16to8} THEN
-						DevCPL486.GenStringMove(FALSE, StringWSize(ap), StringWSize(par), par.typ.n)
-					ELSE
-						DevCPL486.GenBlockMove(1, (s + 3) DIV 4 * 4)
-					END
-				END
-			END
-		ELSIF ap.mode = Con THEN
-			IF ap.form IN {Real32, Real64} THEN	(* ??? push const *)
-				DevCPL486.GenFLoad(ap); DecStack(par.typ.form); DevCPL486.GenFStore(par, TRUE)
-			ELSE
-				ap.form := Int32;
-				IF par.form = Int64 THEN DevCPL486.MakeConst(c, ap.scale, Int32); DevCPL486.GenPush(c) END;
-				DevCPL486.GenPush(ap)
-			END
-		ELSIF ap.typ.form = Pointer THEN
-			recTyp := ap.typ.BaseTyp;
-			IF rec THEN
-				Load(ap, {}, {}); Tag(ap, tag);
-				IF tag.mode = Con THEN	(* explicit nil test needed *)
-					DevCPL486.MakeReg(a, AX, Int32);
-					c.mode := Ind; c.form := Int32; c.offset := 0; c.scale := 0; c.reg := ap.reg;
-					DevCPL486.GenTest(a, c)
-				END
-			END;
-			DevCPL486.GenPush(ap); Free(ap);
-			tag.typ := recTyp
-		ELSIF ap.form IN {Comp, String8, String16, VString8, VString16} THEN	(* convert to pointer *)
-			ASSERT(par.form = Pointer);
-			PushAdr(ap, FALSE)
-		ELSE
-			ConvMove(par, ap, FALSE, {}, {high});
-		END
-	END Param;
-	
-	PROCEDURE Result* (proc: DevCPT.Object; VAR res: DevCPL486.Item);
-		VAR r: DevCPL486.Item;
-	BEGIN
-		DevCPL486.MakeReg(r, AX, proc.typ.form);	(* don't allocate AX ! *)
-		IF res.mode = Con THEN
-			IF r.form IN {Real32, Real64} THEN DevCPL486.GenFLoad(res);
-			ELSIF r.form = Int64 THEN
-				r.form := Int32; res.form := Int32; DevCPL486.GenMove(res, r);
-				r.reg := DX; res.offset := res.scale; DevCPL486.GenMove(res, r)
-			ELSE DevCPL486.GenMove(res, r);
-			END
-		ELSIF res.form IN {Comp, String8, String16, VString8, VString16} THEN	(* convert to pointer *)
-			ASSERT(r.form = Pointer);
-			GetAdr(res, {}, wreg - {AX})
-		ELSE
-			r.index := DX;	(* for int64 *)
-			ConvMove(r, res, FALSE, wreg - {AX} + {high}, {});
-		END;
-		Free(res)
-	END Result;
-	
-	PROCEDURE InitFpu;
-		VAR x: DevCPL486.Item;
-	BEGIN
-		DevCPL486.MakeConst(x, FpuControlRegister, Int32); DevCPL486.GenPush(x);
-		DevCPL486.GenFMOp(12CH); DevCPL486.GenCode(24H);	(* FLDCW 0(SP) *)
-		DevCPL486.MakeReg(x, CX, Int32); DevCPL486.GenPop(x);	(* reset stack *)
-	END InitFpu;
-	
-	PROCEDURE PrepCall* (proc: DevCPT.Object);
-		VAR lev: BYTE; r: DevCPL486.Item;
-	BEGIN
-		lev := proc.mnolev;
-		IF (slNeeded IN proc.conval.setval) & (imLevel[lev] > 0) & (imLevel[DevCPL486.level] > imLevel[lev]) THEN
-			DevCPL486.MakeReg(r, BX, Pointer); DevCPL486.GenPush(r)
-		END
-	END PrepCall;
-	
-	PROCEDURE Call* (VAR x, tag: DevCPL486.Item);	(* TProc: tag.typ = actual receiver type *)
-		VAR i, n: INTEGER; r, y: DevCPL486.Item; typ: DevCPT.Struct; lev: BYTE; saved: BOOLEAN; p: DevCPT.Object;
-	BEGIN
-		IF x.mode IN {LProc, XProc, IProc} THEN
-			lev := x.obj.mnolev; saved := FALSE;
-			IF (slNeeded IN x.obj.conval.setval) & (imLevel[lev] > 0) THEN	(* pass static link *)
-				n := imLevel[DevCPL486.level] - imLevel[lev];
-				IF n > 0 THEN
-					saved := TRUE;
-					y.mode := Ind; y.scale := 0; y.form := Pointer; y.reg := BX; y.offset := -4;
-					DevCPL486.MakeReg(r, BX, Pointer);
-					WHILE n > 0 DO DevCPL486.GenMove(y, r); DEC(n) END
-				END
-			END;
-			DevCPL486.GenCall(x);
-			IF x.obj.sysflag = ccall THEN	(* remove parameters *)
-				p := x.obj.link; n := 0;
-				WHILE p # NIL DO
-					IF p.mode = VarPar THEN INC(n, 4)
-					ELSE INC(n, (p.typ.size + 3) DIV 4 * 4)
-					END;
-					p := p.link
-				END;
-				AdjustStack(n)
-			END;
-			IF saved THEN DevCPL486.GenPop(r) END;
-		ELSIF x.mode = TProc THEN
-			IF x.scale = 1 THEN (* super *)
-				DevCPL486.MakeConst(tag, 0, Pointer); tag.obj := DevCPE.TypeObj(tag.typ.BaseTyp)
-			ELSIF x.scale = 2 THEN (* static call *)
-				DevCPL486.MakeConst(tag, 0, Pointer); typ := x.obj.link.typ;
-				IF typ.form = Pointer THEN typ := typ.BaseTyp END;
-				tag.obj := DevCPE.TypeObj(typ)
-			ELSIF x.scale = 3 THEN (* interface method call *)
-				DevCPM.err(200)
-			END;
-			IF tag.mode = Con THEN
-				y.mode := Abs; y.offset := tag.offset; y.obj := tag.obj; y.scale := 0
-			ELSIF (x.obj.conval.setval * {absAttr, empAttr, extAttr} = {}) & ~(DevCPM.oberon IN DevCPM.options) THEN	(* final method *)
-				y.mode := Abs; y.offset := 0; y.obj := DevCPE.TypeObj(tag.typ); y.scale := 0;
-				IF tag.mode = Ind THEN	(* nil test *)
-					DevCPL486.MakeReg(r, AX, Int32); tag.offset := 0; DevCPL486.GenTest(r, tag)
-				END
-			ELSE
-				IF tag.mode = Reg THEN y.reg := tag.reg
-				ELSE GetReg(y, Pointer, {}, {}); DevCPL486.GenMove(tag, y)
-				END;
-				y.mode := Ind; y.offset := 0; y.scale := 0
-			END;
-			IF (tag.typ.sysflag = interface) & (y.mode = Ind) THEN y.offset := 4 * x.offset
-			ELSIF tag.typ.untagged THEN DevCPM.err(140)
-			ELSE
-				IF x.obj.link.typ.sysflag = interface THEN	(* correct method number *)
-					x.offset := numPreIntProc + NumOfIntProc(tag.typ) - 1 - x.offset
-				END;
-				INC(y.offset, Mth0Offset - 4 * x.offset)
-			END;
-			DevCPL486.GenCall(y); Free(y)
-		ELSIF x.mode = CProc THEN
-			IF x.obj.link # NIL THEN	(* tag = first param *)
-				IF x.obj.link.mode = VarPar THEN
-					GetAdr(tag, {}, wreg - {AX} + {stk, mem, con}); Free(tag)
-				ELSE 
-					(* Load(tag, {}, wreg - {AX} + {con}); Free(tag) *)
-					Result(x.obj.link, tag)	(* use result load for first parameter *)
-				END
-			END;
-			i := 1; n := ORD(x.obj.conval.ext^[0]);
-			WHILE i <= n DO DevCPL486.GenCode(ORD(x.obj.conval.ext^[i])); INC(i) END
-		ELSE	(* proc var *)
-			DevCPL486.GenCall(x); Free(x);
-			IF x.typ.sysflag = ccall THEN	(* remove parameters *)
-				p := x.typ.link; n := 0;
-				WHILE p # NIL DO
-					IF p.mode = VarPar THEN INC(n, 4)
-					ELSE INC(n, (p.typ.size + 3) DIV 4 * 4)
-					END;
-					p := p.link
-				END;
-				AdjustStack(n)
-			END;
-			x.typ := x.typ.BaseTyp
-		END;
-		IF procedureUsesFpu & (x.mode = XProc) & (x.obj.mnolev < 0) & (x.obj.mnolev > -128)
-				& ((x.obj.library # NIL) OR (DevCPT.GlbMod[-x.obj.mnolev].library # NIL)) THEN	(* restore fpu *)
-			InitFpu
-		END;
-		CheckReg;
-		IF x.typ.form = Int64 THEN
-			GetReg(x, Int32, {}, wreg - {AX}); GetReg(y, Int32, {}, wreg - {DX});
-			x.index := y.reg; x.form := Int64
-		ELSIF x.typ.form # NoTyp THEN GetReg(x, x.typ.form, {}, wreg - {AX} + {high})
-		END
-	END Call;
-	
-	PROCEDURE CopyDynArray* (adr: INTEGER; typ: DevCPT.Struct);	(* needs CX, SI, DI *)
-		VAR len, ptr, c, sp, src, dst: DevCPL486.Item; bt: DevCPT.Struct;
-	BEGIN
-		IF typ.untagged THEN DevCPM.err(-137) END;
-		ptr.mode := Ind; ptr.reg := BP; ptr.offset := adr+4; ptr.scale := 0; ptr.form := Pointer;
-		DevCPL486.MakeReg(len, CX, Int32); DevCPL486.MakeReg(sp, SP, Int32);
-		DevCPL486.MakeReg(src, SI, Int32); DevCPL486.MakeReg(dst, DI, Int32);
-		DevCPL486.GenMove(ptr, len); bt := typ.BaseTyp;
-		WHILE bt.comp = DynArr DO
-			INC(ptr.offset, 4); DevCPL486.GenMul(ptr, len, FALSE); bt := bt.BaseTyp
-		END;
-		ptr.offset := adr; DevCPL486.GenMove(ptr, src);
-		DevCPL486.MakeConst(c, bt.size, Int32); DevCPL486.GenMul(c, len, FALSE);
-		(* CX = length in bytes *)
-		StackAlloc; 
-		(* CX = length in 32bit words *)
-		DevCPL486.GenMove(sp, dst); DevCPL486.GenMove(dst, ptr);
-		DevCPL486.GenBlockMove(4, 0)  (* 32bit moves *)
-	END CopyDynArray;
-	
-	PROCEDURE Sort (VAR tab: ARRAY OF INTEGER; VAR n: INTEGER);
-		VAR i, j, x: INTEGER;
-	BEGIN
-		(* align *)
-		i := 1;
-		WHILE i < n DO
-			x := tab[i]; j := i-1;
-			WHILE (j >= 0) & (tab[j] < x) DO tab[j+1] := tab[j]; DEC(j) END;
-			tab[j+1] := x; INC(i)
-		END;
-		(* eliminate equals *)
-		i := 1; j := 1;
-		WHILE i < n DO
-			IF tab[i] # tab[i-1] THEN tab[j] := tab[i]; INC(j) END;
-			INC(i)
-		END;
-		n := j
-	END Sort;
-	
-	PROCEDURE FindPtrs (typ: DevCPT.Struct; adr: INTEGER; VAR num: INTEGER);
-		VAR fld: DevCPT.Object; btyp: DevCPT.Struct; i, n: INTEGER;
-	BEGIN
-		IF typ.form IN {Pointer, ProcTyp} THEN
-			IF num < MaxPtrs THEN ptrTab[num] := adr DIV 4 * 4 END;
-			INC(num);
-			IF adr MOD 4 # 0 THEN
-				IF num < MaxPtrs THEN ptrTab[num] := adr DIV 4 * 4 + 4 END;
-				INC(num)
-			END
-		ELSIF typ.comp = Record THEN
-			btyp := typ.BaseTyp;
-			IF btyp # NIL THEN FindPtrs(btyp, adr, num) END ;
-			fld := typ.link;
-			WHILE (fld # NIL) & (fld.mode = Fld) DO
-				IF (fld.name^ = DevCPM.HdPtrName) OR
-					(fld.name^ = DevCPM.HdUtPtrName) OR
-					(fld.name^ = DevCPM.HdProcName) THEN
-					FindPtrs(DevCPT.sysptrtyp, fld.adr + adr, num)
-				ELSE FindPtrs(fld.typ, fld.adr + adr, num)
-				END;
-				fld := fld.link
-			END
-		ELSIF typ.comp = Array THEN
-			btyp := typ.BaseTyp; n := typ.n;
-			WHILE btyp.comp = Array DO n := btyp.n * n; btyp := btyp.BaseTyp END ;
-			IF (btyp.form = Pointer) OR (btyp.comp = Record) THEN
-				i := num; FindPtrs(btyp, adr, num);
-				IF num # i THEN i := 1;
-					WHILE (i < n) & (num <= MaxPtrs) DO
-						INC(adr, btyp.size); FindPtrs(btyp, adr, num); INC(i)
-					END
-				END
-			END
-		END
-	END FindPtrs;
-
-	PROCEDURE InitOutPar (par: DevCPT.Object; VAR zreg: DevCPL486.Item);
-		VAR x, y, c, len: DevCPL486.Item; lbl: DevCPL486.Label; size, s: INTEGER; bt: DevCPT.Struct;
-	BEGIN
-		x.mode := Ind; x.reg := BP; x.scale := 0; x.form := Pointer; x.offset := par.adr;
-		DevCPL486.MakeReg(y, DI, Int32);
-		IF par.typ.comp # DynArr THEN
-			DevCPL486.GenMove(x, y);
-			lbl := DevCPL486.NewLbl;
-			IF ODD(par.sysflag DIV nilBit) THEN
-				DevCPL486.GenComp(zreg, y);
-				DevCPL486.GenJump(ccE, lbl, TRUE)
-			END;
-			size := par.typ.size;
-			IF size <= 16 THEN
-				x.mode := Ind; x.reg := DI; x.form := Int32; x.offset := 0;
-				WHILE size > 0 DO
-					IF size = 1 THEN x.form := Int8; s := 1
-					ELSIF size = 2 THEN x.form := Int16; s := 2
-					ELSE x.form := Int32; s := 4
-					END;
-					zreg.form := x.form; DevCPL486.GenMove(zreg, x); INC(x.offset, s); DEC(size, s)
-				END;
-				zreg.form := Int32
-			ELSE
-				DevCPL486.GenBlockStore(1, size)
-			END;
-			DevCPL486.SetLabel(lbl)
-		ELSIF initializeDyn & ~par.typ.untagged THEN	(* untagged open arrays not initialized !!! *)
-			DevCPL486.GenMove(x, y);
-			DevCPL486.MakeReg(len, CX, Int32);
-			INC(x.offset, 4); DevCPL486.GenMove(x, len); (* first len *)
-			bt := par.typ.BaseTyp;
-			WHILE bt.comp = DynArr DO
-				INC(x.offset, 4); DevCPL486.GenMul(x, len, FALSE); bt := bt.BaseTyp
-			END;
-			size := bt.size;
-			IF size MOD 4 = 0 THEN size := size DIV 4; s := 4
-			ELSIF size MOD 2 = 0 THEN size := size DIV 2; s := 2
-			ELSE s := 1
-			END;
-			DevCPL486.MakeConst(c, size, Int32); DevCPL486.GenMul(c, len, FALSE);
-			DevCPL486.GenBlockStore(s, 0)
-		END
-	END InitOutPar;
-
-	PROCEDURE AllocAndInitAll (proc: DevCPT.Object; adr, size: INTEGER; VAR nofptrs: INTEGER);
-		VAR x, y, z, zero: DevCPL486.Item; par: DevCPT.Object; op: INTEGER;
-	BEGIN
-		op := 0; par := proc.link;
-		WHILE par # NIL DO	(* count out parameters [with COM pointers] *)
-			IF (par.mode = VarPar) & (par.vis = outPar) & (initializeOut OR ContainsIPtrs(par.typ)) THEN INC(op) END;
-			par := par.link
-		END;
-		DevCPL486.MakeConst(zero, 0, Int32);
-		IF (op = 0) & (size <= 8) THEN	(* use PUSH 0 *)
-			WHILE size > 0 DO DevCPL486.GenPush(zero); DEC(size, 4) END
-		ELSE
-			DevCPL486.MakeReg(z, AX, Int32); DevCPL486.GenMove(zero, z);
-			IF size <= 32 THEN	(* use PUSH reg *)
-				WHILE size > 0 DO DevCPL486.GenPush(z); DEC(size, 4) END
-			ELSE	(* use string store *)
-				AdjustStack(-size);
-				DevCPL486.MakeReg(x, SP, Int32); DevCPL486.MakeReg(y, DI, Int32); DevCPL486.GenMove(x, y);
-				DevCPL486.GenBlockStore(1, size)
-			END;
-			IF op > 0 THEN
-				par := proc.link;
-				WHILE par # NIL DO	(* init out parameters [with COM pointers] *)
-					IF (par.mode = VarPar) & (par.vis = outPar) & (initializeOut OR ContainsIPtrs(par.typ)) THEN InitOutPar(par, z) END;
-					par := par.link
-				END
-			END
-		END
-	END AllocAndInitAll;
-	
-	PROCEDURE AllocAndInitPtrs1 (proc: DevCPT.Object; adr, size: INTEGER; VAR nofptrs: INTEGER);	(* needs AX *)
-		VAR i, base, a, gaps: INTEGER; x, z: DevCPL486.Item; obj: DevCPT.Object;
-	BEGIN
-		IF ptrinit & (proc.scope # NIL) THEN
-			nofptrs := 0; obj := proc.scope.scope;	(* local variables *)
-			WHILE (obj # NIL) & (nofptrs <= MaxPtrs) DO
-				FindPtrs(obj.typ, obj.adr, nofptrs);
-				obj := obj.link
-			END;
-			IF (nofptrs > 0) & (nofptrs <= MaxPtrs) THEN
-				base := proc.conval.intval2;
-				Sort(ptrTab, nofptrs); i := 0; a := size + base; gaps := 0;
-				WHILE i < nofptrs DO
-					DEC(a, 4);
-					IF a # ptrTab[i] THEN a := ptrTab[i]; INC(gaps) END;
-					INC(i)
-				END;
-				IF a # base THEN INC(gaps) END;
-				IF (gaps <= (nofptrs + 1) DIV 2) & (size < stackAllocLimit) THEN
-					DevCPL486.MakeConst(z, 0, Pointer);
-					IF (nofptrs > 4) THEN x := z; DevCPL486.MakeReg(z, AX, Int32); DevCPL486.GenMove(x, z) END;
-					i := 0; a := size + base;
-					WHILE i < nofptrs DO
-						DEC(a, 4);
-						IF a # ptrTab[i] THEN AdjustStack(ptrTab[i] - a); a := ptrTab[i] END;
-						DevCPL486.GenPush(z); INC(i)
-					END;
-					IF a # base THEN AdjustStack(base - a) END
-				ELSE
-					AdjustStack(-size);
-					DevCPL486.MakeConst(x, 0, Pointer); DevCPL486.MakeReg(z, AX, Int32); DevCPL486.GenMove(x, z);
-					x.mode := Ind; x.reg := BP; x.scale := 0; x.form := Pointer; i := 0; 
-					WHILE i < nofptrs DO
-						x.offset := ptrTab[i]; DevCPL486.GenMove(z, x); INC(i)
-					END
-				END
-			ELSE
-				AdjustStack(-size)
-			END
-		ELSE
-			nofptrs := 0;
-			AdjustStack(-size)
-		END
-	END AllocAndInitPtrs1;
-
-	PROCEDURE InitPtrs2 (proc: DevCPT.Object; adr, size, nofptrs: INTEGER);	(* needs AX, CX, DI *)
-		VAR x, y, z, zero: DevCPL486.Item; obj: DevCPT.Object; zeroed: BOOLEAN; i: INTEGER; lbl: DevCPL486.Label;
-	BEGIN
-		IF ptrinit THEN
-			zeroed := FALSE; DevCPL486.MakeConst(zero, 0, Pointer);
-			IF nofptrs > MaxPtrs THEN
-				DevCPL486.MakeReg(z, AX, Int32); DevCPL486.GenMove(zero, z); zeroed := TRUE;
-				x.mode := Ind; x.reg := BP; x.scale := 0; x.form := Pointer; x.offset := adr;
-				DevCPL486.MakeReg(y, DI, Int32); DevCPL486.GenLoadAdr(x, y);
-				DevCPL486.GenStrStore(size)
-			END;
-			obj := proc.link;	(* parameters *)
-			WHILE obj # NIL DO
-				IF (obj.mode = VarPar) & (obj.vis = outPar) THEN
-					nofptrs := 0;
-					IF obj.typ.comp = DynArr THEN	(* currently not initialized *)
-					ELSE FindPtrs(obj.typ, 0, nofptrs)
-					END;
-					IF nofptrs > 0 THEN
-						IF ~zeroed THEN
-							DevCPL486.MakeReg(z, AX, Int32); DevCPL486.GenMove(zero, z); zeroed := TRUE
-						END;
-						x.mode := Ind; x.reg := BP; x.scale := 0; x.form := Pointer; x.offset := obj.adr;
-						DevCPL486.MakeReg(y, DI, Int32); DevCPL486.GenMove(x, y);
-						IF ODD(obj.sysflag DIV nilBit) THEN
-							DevCPL486.GenComp(zero, y);
-							lbl := DevCPL486.NewLbl; DevCPL486.GenJump(ccE, lbl, TRUE)
-						END;
-						IF nofptrs > MaxPtrs THEN
-							DevCPL486.GenStrStore(obj.typ.size)
-						ELSE
-							Sort(ptrTab, nofptrs);
-							x.reg := DI; i := 0;
-							WHILE i < nofptrs DO
-								x.offset := ptrTab[i]; DevCPL486.GenMove(z, x); INC(i)
-							END
-						END;
-						IF ODD(obj.sysflag DIV nilBit) THEN DevCPL486.SetLabel(lbl) END
-					END
-				END;
-				obj := obj.link
-			END
-		END
-	END InitPtrs2;
-	
-	PROCEDURE NeedOutPtrInit (proc: DevCPT.Object): BOOLEAN;
-		VAR obj: DevCPT.Object; nofptrs: INTEGER;
-	BEGIN
-		IF ptrinit THEN
-			obj := proc.link;
-			WHILE obj # NIL DO
-				IF (obj.mode = VarPar) & (obj.vis = outPar) THEN
-					nofptrs := 0;
-					IF obj.typ.comp = DynArr THEN	(* currently not initialized *)
-					ELSE FindPtrs(obj.typ, 0, nofptrs)
-					END;
-					IF nofptrs > 0 THEN RETURN TRUE END
-				END;
-				obj := obj.link
-			END
-		END;
-		RETURN FALSE
-	END NeedOutPtrInit;
-	
-	PROCEDURE Enter* (proc: DevCPT.Object; empty, useFpu: BOOLEAN);
-		VAR sp, fp, r, r1: DevCPL486.Item; par: DevCPT.Object; adr, size, np: INTEGER;
-	BEGIN
-		procedureUsesFpu := useFpu;
-		SetReg({AX, CX, DX, SI, DI});
-		DevCPL486.MakeReg(fp, BP, Pointer); DevCPL486.MakeReg(sp, SP, Pointer);
-		IF proc # NIL THEN (* enter proc *)
-			DevCPL486.SetLabel(proc.adr);
-			IF (~empty OR NeedOutPtrInit(proc)) & (proc.sysflag # noframe) THEN
-				DevCPL486.GenPush(fp);
-				DevCPL486.GenMove(sp, fp);
-				adr := proc.conval.intval2; size := -adr;
-				IF isGuarded IN proc.conval.setval THEN
-					DevCPL486.MakeReg(r, BX, Pointer); DevCPL486.GenPush(r);
-					DevCPL486.MakeReg(r, DI, Pointer); DevCPL486.GenPush(r);
-					DevCPL486.MakeReg(r, SI, Pointer); DevCPL486.GenPush(r);
-					r1.mode := Con; r1.form := Int32; r1.offset := proc.conval.intval - 8; r1.obj := NIL;
-					DevCPL486.GenPush(r1);
-					intHandler.used := TRUE;
-					r1.mode := Con; r1.form := Int32; r1.offset := 0; r1.obj := intHandler;
-					DevCPL486.GenPush(r1);
-					r1.mode := Abs; r1.form := Int32; r1.offset := 0; r1.scale := 0; r1.obj := NIL;
-					DevCPL486.GenCode(64H); DevCPL486.GenPush(r1);
-					DevCPL486.GenCode(64H); DevCPL486.GenMove(sp, r1);
-					DEC(size, 24)
-				ELSE
-					IF imVar IN proc.conval.setval THEN	(* set down pointer *)
-						DevCPL486.MakeReg(r, BX, Pointer); DevCPL486.GenPush(r); DEC(size, 4)
-					END;
-					IF isCallback IN proc.conval.setval THEN
-						DevCPL486.MakeReg(r, DI, Pointer); DevCPL486.GenPush(r);
-						DevCPL486.MakeReg(r, SI, Pointer); DevCPL486.GenPush(r); DEC(size, 8)
-					END
-				END;
-				ASSERT(size >= 0);
-				IF initializeAll THEN
-					AllocAndInitAll(proc, adr, size, np)
-				ELSE
-					AllocAndInitPtrs1(proc, adr, size, np);	(* needs AX *)
-					InitPtrs2(proc, adr, size, np);	(* needs AX, CX, DI *)
-				END;
-				par := proc.link;	(* parameters *)
-				WHILE par # NIL DO
-					IF (par.mode = Var) & (par.typ.comp = DynArr) THEN 
-						CopyDynArray(par.adr, par.typ)
-					END;
-					par := par.link
-				END;
-				IF imVar IN proc.conval.setval THEN
-					DevCPL486.MakeReg(r, BX, Pointer); DevCPL486.GenMove(fp, r)
-				END
-			END
-		ELSIF ~empty THEN (* enter module *)
-			DevCPL486.GenPush(fp);
-			DevCPL486.GenMove(sp, fp);
-			DevCPL486.MakeReg(r, DI, Int32); DevCPL486.GenPush(r);
-			DevCPL486.MakeReg(r, SI, Int32); DevCPL486.GenPush(r)
-		END;
-		IF useFpu THEN InitFpu END
-	END Enter;
-	
-	PROCEDURE Exit* (proc: DevCPT.Object; empty: BOOLEAN);
-		VAR sp, fp, r, x: DevCPL486.Item; mode: SHORTINT; size: INTEGER;
-	BEGIN
-		DevCPL486.MakeReg(sp, SP, Pointer); DevCPL486.MakeReg(fp, BP, Pointer);
-		IF proc # NIL THEN (* exit proc *)
-			IF proc.sysflag # noframe THEN
-				IF ~empty OR NeedOutPtrInit(proc) THEN
-					IF isGuarded IN proc.conval.setval THEN	(* remove exception frame *)
-						x.mode := Ind; x.reg := BP; x.offset := -24; x.scale := 0; x.form := Int32;
-						DevCPL486.MakeReg(r, CX, Int32); DevCPL486.GenMove(x, r);
-						x.mode := Abs; x.offset := 0; x.scale := 0; x.form := Int32; x.obj := NIL;
-						DevCPL486.GenCode(64H); DevCPL486.GenMove(r, x);
-						size := 12
-					ELSE
-						size := 0;
-						IF imVar IN proc.conval.setval THEN INC(size, 4) END;
-						IF isCallback IN proc.conval.setval THEN INC(size, 8) END
-					END;
-					IF size > 0 THEN
-						x.mode := Ind; x.reg := BP; x.offset := -size; x.scale := 0; x.form := Int32;
-						DevCPL486.GenLoadAdr(x, sp);
-						IF size > 4 THEN
-							DevCPL486.MakeReg(r, SI, Int32); DevCPL486.GenPop(r);
-							DevCPL486.MakeReg(r, DI, Int32); DevCPL486.GenPop(r)
-						END;
-						IF size # 8 THEN
-							DevCPL486.MakeReg(r, BX, Int32); DevCPL486.GenPop(r)
-						END
-					ELSE
-						DevCPL486.GenMove(fp, sp)
-					END;
-					DevCPL486.GenPop(fp)
-				END;
-				IF proc.sysflag = ccall THEN DevCPL486.GenReturn(0)
-				ELSE DevCPL486.GenReturn(proc.conval.intval - 8)
-				END
-			END
-		ELSE (* exit module *)
-			IF ~empty THEN
-				DevCPL486.MakeReg(r, SI, Int32); DevCPL486.GenPop(r);
-				DevCPL486.MakeReg(r, DI, Int32); DevCPL486.GenPop(r);
-				DevCPL486.GenMove(fp, sp); DevCPL486.GenPop(fp)
-			END;
-			DevCPL486.GenReturn(0)
-		END
-	END Exit;
-	
-	PROCEDURE InstallStackAlloc*;
-		VAR name: ARRAY 32 OF SHORTCHAR; ax, cx, sp, c, x: DevCPL486.Item; l1, l2: DevCPL486.Label;
-	BEGIN
-		IF stkAllocLbl # DevCPL486.NewLbl THEN
-			DevCPL486.SetLabel(stkAllocLbl);
-			DevCPL486.MakeReg(ax, AX, Int32);
-			DevCPL486.MakeReg(cx, CX, Int32);
-			DevCPL486.MakeReg(sp, SP, Int32);
-			DevCPL486.GenPush(ax);
-			DevCPL486.MakeConst(c, -5, Int32); DevCPL486.GenAdd(c, cx, FALSE);
-			l1 := DevCPL486.NewLbl; DevCPL486.GenJump(ccNS, l1, TRUE);
-			DevCPL486.MakeConst(c, 0, Int32); DevCPL486.GenMove(c, cx);
-			DevCPL486.SetLabel(l1);
-			DevCPL486.MakeConst(c, -4, Int32); DevCPL486.GenAnd(c, cx);
-			DevCPL486.GenMove(cx, ax);
-			DevCPL486.MakeConst(c, 4095, Int32); DevCPL486.GenAnd(c, ax);
-			DevCPL486.GenSub(ax, sp, FALSE);
-			DevCPL486.GenMove(cx, ax);
-			DevCPL486.MakeConst(c, 12, Int32); DevCPL486.GenShiftOp(SHR, c, ax);
-			l2 := DevCPL486.NewLbl; DevCPL486.GenJump(ccE, l2, TRUE);
-			l1 := DevCPL486.NewLbl; DevCPL486.SetLabel(l1);
-			DevCPL486.MakeConst(c, 0, Int32); DevCPL486.GenPush(c);
-			DevCPL486.MakeConst(c, 4092, Int32); DevCPL486.GenSub(c, sp, FALSE);
-			DevCPL486.MakeConst(c, -1, Int32); DevCPL486.GenAdd(c, ax, FALSE);
-			DevCPL486.GenJump(ccNE, l1, TRUE);
-			DevCPL486.SetLabel(l2);
-			DevCPL486.MakeConst(c, 8, Int32); DevCPL486.GenAdd(c, cx, FALSE);
-			x.mode := Ind; x.form := Int32; x.offset := -4; x.index := CX; x.reg := SP; x.scale := 1;
-			DevCPL486.GenMove(x, ax);
-			DevCPL486.GenPush(ax);
-			DevCPL486.GenMove(x, ax);
-			DevCPL486.MakeConst(c, 2, Int32); DevCPL486.GenShiftOp(SHR, c, cx);
-			DevCPL486.GenReturn(0);
-			name := "$StackAlloc"; DevCPE.OutRefName(name);
-		END
-	END InstallStackAlloc;
-
-	PROCEDURE Trap* (n: INTEGER);
-	BEGIN
-		DevCPL486.GenAssert(ccNever, n)
-	END Trap;
-	
-	PROCEDURE Jump* (VAR L: DevCPL486.Label);
-	BEGIN
-		DevCPL486.GenJump(ccAlways, L, FALSE)
-	END Jump;
-
-	PROCEDURE JumpT* (VAR x: DevCPL486.Item; VAR L: DevCPL486.Label);
-	BEGIN
-		DevCPL486.GenJump(x.offset, L, FALSE);
-	END JumpT; 
-	
-	PROCEDURE JumpF* (VAR x: DevCPL486.Item; VAR L: DevCPL486.Label);
-	BEGIN
-		DevCPL486.GenJump(Inverted(x.offset), L, FALSE);
-	END JumpF;
-	
-	PROCEDURE CaseTableJump* (VAR x: DevCPL486.Item; low, high: INTEGER; VAR else: DevCPL486.Label);
-		VAR c: DevCPL486.Item; n: INTEGER;
-	BEGIN
-		n := high - low + 1;
-		DevCPL486.MakeConst(c, low, Int32); DevCPL486.GenSub(c, x, FALSE);
-		DevCPL486.MakeConst(c, n, Int32); DevCPL486.GenComp(c, x);
-		DevCPL486.GenJump(ccAE, else, FALSE);
-		DevCPL486.GenCaseJump(x)
-	END CaseTableJump;
-	
-	PROCEDURE CaseJump* (VAR x: DevCPL486.Item; low, high: INTEGER; VAR this, else: DevCPL486.Label; tree, first: BOOLEAN);
-		VAR c: DevCPL486.Item;
-	BEGIN
-		IF high = low THEN
-			DevCPL486.MakeConst(c, low, Int32); DevCPL486.GenComp(c, x);
-			IF tree THEN DevCPL486.GenJump(ccG, else, FALSE) END;
-			DevCPL486.GenJump(ccE, this, FALSE)
-		ELSIF first THEN
-			DevCPL486.MakeConst(c, low, Int32); DevCPL486.GenComp(c, x);
-			DevCPL486.GenJump(ccL, else, FALSE);
-			DevCPL486.MakeConst(c, high, Int32); DevCPL486.GenComp(c, x);
-			DevCPL486.GenJump(ccLE, this, FALSE);
-		ELSE
-			DevCPL486.MakeConst(c, high, Int32); DevCPL486.GenComp(c, x);
-			DevCPL486.GenJump(ccG, else, FALSE);
-			DevCPL486.MakeConst(c, low, Int32); DevCPL486.GenComp(c, x);
-			DevCPL486.GenJump(ccGE, this, FALSE);
-		END
-	END CaseJump;
-
-BEGIN
-	imLevel[0] := 0
-END DevCPC486.

BlackBox/Dev/Mod/CPE.txt

@@ -1,1105 +0,0 @@
-MODULE DevCPE;
-
-	(* THIS IS TEXT COPY OF BlackBox 1.6-rc6 Dev/Mod/CPE.odc *)
-	(* DO NOT EDIT *)
-
-	IMPORT SYSTEM, Dates, DevCPM, DevCPT;
-
-
-	CONST
-		(* item base modes (=object modes) *)
-		Var = 1; VarPar = 2; Con = 3; LProc = 6; XProc = 7; CProc = 9; IProc = 10; TProc = 13;
-	
-		(* structure forms *)
-		Undef = 0; Byte = 1; Bool = 2; Char8 = 3; Int8 = 4; Int16 = 5; Int32 = 6;
-		Real32 = 7; Real64 = 8; Set = 9; String8 = 10; NilTyp = 11; NoTyp = 12;
-		Pointer = 13; ProcTyp = 14; Comp = 15;
-		Char16 = 16; String16 = 17; Int64 = 18; Guid = 23;
-		
-		(* composite structure forms *)
-		Basic = 1; Array = 2; DynArr = 3; Record = 4;
-		
-		(* object modes *)
-		Fld = 4; Typ = 5; Head = 12;
-		
-		(* module visibility of objects *)
-		internal = 0; external = 1; externalR = 2; inPar = 3; outPar = 4;
-
-		(* history of imported objects *)
-		inserted = 0; same = 1; pbmodified = 2; pvmodified = 3; removed = 4; inconsistent = 5;
-		
-		(* attribute flags (attr.adr, struct.attribute, proc.conval.setval)*)
-		newAttr = 16; absAttr = 17; limAttr = 18; empAttr = 19; extAttr = 20;
-		
-		(* meta interface consts *)
-		mConst = 1; mTyp = 2; mVar = 3; mProc = 4; mField = 5;
-		mBool = 1; mChar8 = 2; mChar16 = 3; mInt8 = 4; mInt16 = 5; mInt32 = 6;
-		mReal32 = 7; mReal64 = 8; mSet = 9; mInt64 = 10; mAnyRec = 11; mAnyPtr = 12; mSysPtr = 13;
-		mProctyp = 0; mRecord = 1; mArray = 2; mPointer = 3;
-		mInternal = 1; mReadonly = 2; mPrivate = 3; mExported = 4;
-		mValue = 10; mInPar = 11; mOutPar = 12; mVarPar = 13;
-		mInterface = 32; mGuid = 33; mResult = 34;
-
-		(* sysflag *)
-		untagged = 1; noAlign = 3; union = 7; interface = 10;
-		
-		(* fixup types *)
-		absolute = 100; relative = 101; copy = 102; table = 103; tableend = 104; short = 105;
-		
-		(* kernel flags *)
-		iptrs = 30;
-		
-		expAllFields = TRUE;
-		
-		(* implementation restrictions *)
-		CodeBlocks = 512;
-		CodeLength = 16384;
-		MaxNameTab = 800000H;
-		
-		useAllRef = FALSE;
-		outSignatures = TRUE;
-	
-	TYPE
-		CodeBlock = POINTER TO ARRAY CodeLength OF SHORTCHAR;
-	
-	VAR
-		pc*: INTEGER;
-		dsize*: INTEGER;	(* global data size *)
-		KNewRec*, KNewArr*: DevCPT.Object;
-		closeLbl*: INTEGER;
-		CaseLinks*: DevCPT.LinkList;
-		
-		processor: INTEGER;
-		bigEndian: BOOLEAN;
-		procVarIndirect: BOOLEAN;
-		idx8, idx16, idx32, idx64, namex, nofptrs, headSize: INTEGER;
-		Const8, Const16, Const32, Const64, Code, Data, Meta, Mod, Proc, nameList, descList, untgd: DevCPT.Object;
-		outRef, outAllRef, outURef, outSrc, outObj: BOOLEAN;
-		codePos, srcPos: INTEGER;
-		options: SET;
-		code: ARRAY CodeBlocks OF CodeBlock;
-		actual: CodeBlock;
-		actIdx, blkIdx: INTEGER;
-		CodeOvF: BOOLEAN;
-		zero: ARRAY 16 OF SHORTCHAR;	(* all 0X *)
-		imports: INTEGER;
-		dllList, dllLast: DevCPT.Object;
-		
-		
-	PROCEDURE GetLongWords* (con: DevCPT.Const; OUT hi, low: INTEGER);
-		CONST N = 4294967296.0; (* 2^32 *)
-		VAR rh, rl: REAL;
-	BEGIN
-		rl := con.intval; rh := con.realval / N;
-		IF rh >= MAX(INTEGER) + 1.0 THEN rh := rh - 1; rl := rl + N
-		ELSIF rh < MIN(INTEGER) THEN rh := rh + 1; rl := rl - N
-		END;
-		hi := SHORT(ENTIER(rh));
-		rl := rl + (rh - hi) * N;
-		IF rl < 0 THEN hi := hi - 1; rl := rl + N
-		ELSIF rl >= N THEN hi := hi + 1; rl := rl - N
-		END;
-		IF rl >= MAX(INTEGER) + 1.0 THEN rl := rl - N END;
-		low := SHORT(ENTIER(rl))
-(*
-		hi := SHORT(ENTIER((con.realval + con.intval) / 4294967296.0));
-		r := con.realval + con.intval - hi * 4294967296.0;
-		IF r > MAX(INTEGER) THEN r := r - 4294967296.0 END;
-		low := SHORT(ENTIER(r))
-*)
-	END GetLongWords;
-	
-	PROCEDURE GetRealWord* (con: DevCPT.Const; OUT x: INTEGER);
-		VAR r: SHORTREAL;
-	BEGIN
-		r := SHORT(con.realval); x := SYSTEM.VAL(INTEGER, r)
-	END GetRealWord;
-		
-	PROCEDURE GetRealWords* (con: DevCPT.Const; OUT hi, low: INTEGER);
-		TYPE A = ARRAY 2 OF INTEGER;
-		VAR a: A;
-	BEGIN
-		a := SYSTEM.VAL(A, con.realval);
-		IF DevCPM.LEHost THEN hi := a[1]; low := a[0] ELSE hi := a[0]; low := a[1] END
-	END GetRealWords;
-		
-	PROCEDURE IsSame (x, y: REAL): BOOLEAN;
-	BEGIN
-		RETURN  (x = y) & ((x #  0.) OR (1. / x = 1. / y))
-	END IsSame;
-	
-	PROCEDURE AllocConst* (con: DevCPT.Const; form: BYTE; VAR obj: DevCPT.Object; VAR adr: INTEGER);
-		VAR c: DevCPT.Const;
-	BEGIN
-		INCL(con.setval, form);
-		CASE form OF
-		| String8:
-			obj := Const8; c := obj.conval;
-			WHILE (c # NIL) & ((con.setval # c.setval) OR (con.intval2 # c.intval2) OR (con.ext^ # c.ext^)) DO c := c.link END;
-			IF c = NIL THEN adr := idx8; INC(idx8, (con.intval2 + 3) DIV 4 * 4) END
-		| String16:
-			obj := Const16; c := obj.conval;
-			WHILE (c # NIL) & ((con.setval # c.setval) OR (con.intval2 # c.intval2) OR (con.ext^ # c.ext^)) DO c := c.link END;
-			IF c = NIL THEN adr := idx16; INC(idx16, (con.intval2 + 1) DIV 2 * 4) END
-		| Int64:
-			obj := Const64; c := obj.conval;
-			WHILE (c # NIL) & ((con.setval # c.setval) OR (con.intval # c.intval2) OR (con.realval # c.realval)) DO
-				c := c.link
-			END;
-			IF c = NIL THEN con.intval2 := con.intval; adr := idx64; INC(idx64, 8) END
-		| Real32:
-			obj := Const32; c := obj.conval;
-			WHILE (c # NIL) & ((con.setval # c.setval) OR ~IsSame(con.realval, c.realval)) DO c := c.link END;
-			IF c = NIL THEN adr := idx32; INC(idx32, 4) END
-		| Real64:
-			obj := Const64; c := obj.conval;
-			WHILE (c # NIL) & ((con.setval # c.setval) OR ~IsSame(con.realval, c.realval)) DO c := c.link END;
-			IF c = NIL THEN adr := idx64; INC(idx64, 8) END
-		| Guid:
-			obj := Const32; c := obj.conval;
-			WHILE (c # NIL) & ((con.setval # c.setval) OR (con.intval2 # c.intval2) OR (con.ext^ # c.ext^)) DO c := c.link END;
-			IF c = NIL THEN adr := idx32; INC(idx32, 16) END
-		END;
-		IF c = NIL THEN con.link := obj.conval; obj.conval := con ELSE adr := c.intval END;
-		con.intval := adr
-	END AllocConst;
-
-
-	PROCEDURE AllocTypDesc* (typ: DevCPT.Struct);	 (* typ.comp = Record *)
-		VAR obj: DevCPT.Object; name: DevCPT.Name;
-	BEGIN
-		IF typ.strobj = NIL THEN
-			name := "@"; DevCPT.Insert(name, obj); obj.name := DevCPT.null;	(* avoid err 1 *)
-			obj.mode := Typ; obj.typ := typ; typ.strobj := obj
-		END
-	END AllocTypDesc; 
-
-
-	PROCEDURE PutByte* (a, x: INTEGER);
-	BEGIN
-		code[a DIV CodeLength]^[a MOD CodeLength] := SHORT(CHR(x MOD 256))
-	END PutByte;
-	
-	PROCEDURE PutShort* (a, x: INTEGER);
-	BEGIN
-		IF bigEndian THEN
-			PutByte(a, x DIV 256); PutByte(a + 1, x)
-		ELSE
-			PutByte(a, x); PutByte(a + 1, x DIV 256)
-		END
-	END PutShort;
-	
-	PROCEDURE PutWord* (a, x: INTEGER);
-	BEGIN
-		IF bigEndian THEN
-			PutByte(a, x DIV 1000000H); PutByte(a + 1, x DIV 10000H);
-			PutByte(a + 2, x DIV 256); PutByte(a + 3, x)
-		ELSE
-			PutByte(a, x); PutByte(a + 1, x DIV 256);
-			PutByte(a + 2, x DIV 10000H); PutByte(a + 3, x DIV 1000000H)
-		END
-	END PutWord;
-	
-	PROCEDURE ThisByte* (a: INTEGER): INTEGER;
-	BEGIN
-		RETURN ORD(code[a DIV CodeLength]^[a MOD CodeLength])
-	END ThisByte;
-	
-	PROCEDURE ThisShort* (a: INTEGER): INTEGER;
-	BEGIN
-		IF bigEndian THEN
-			RETURN ThisByte(a) * 256 + ThisByte(a+1)
-		ELSE
-			RETURN ThisByte(a+1) * 256 + ThisByte(a)
-		END
-	END ThisShort;
-	
-	PROCEDURE ThisWord* (a: INTEGER): INTEGER;
-	BEGIN
-		IF bigEndian THEN
-			RETURN ((ThisByte(a) * 256 + ThisByte(a+1)) * 256 + ThisByte(a+2)) * 256 + ThisByte(a+3)
-		ELSE
-			RETURN ((ThisByte(a+3) * 256 + ThisByte(a+2)) * 256 + ThisByte(a+1)) * 256 + ThisByte(a)
-		END
-	END ThisWord;
-	
-	PROCEDURE GenByte* (x: INTEGER);
-	BEGIN
-		IF actIdx >= CodeLength THEN
-			IF blkIdx < CodeBlocks THEN
-				NEW(actual); code[blkIdx] := actual; INC(blkIdx); actIdx := 0
-			ELSE
-				IF ~CodeOvF THEN DevCPM.err(210); CodeOvF := TRUE END;
-				actIdx := 0; pc := 0
-			END
-		END;
-		actual^[actIdx] := SHORT(CHR(x MOD 256)); INC(actIdx); INC(pc)
-	END GenByte;
-	
-	PROCEDURE GenShort* (x: INTEGER);
-	BEGIN
-		IF bigEndian THEN
-			GenByte(x DIV 256); GenByte(x)
-		ELSE
-			GenByte(x); GenByte(x DIV 256)
-		END
-	END GenShort;
-	
-	PROCEDURE GenWord* (x: INTEGER);
-	BEGIN
-		IF bigEndian THEN
-			GenByte(x DIV 1000000H); GenByte(x DIV 10000H); GenByte(x DIV 256); GenByte(x)
-		ELSE
-			GenByte(x); GenByte(x DIV 256); GenByte(x DIV 10000H); GenByte(x DIV 1000000H)
-		END
-	END GenWord;
-	
-	PROCEDURE WriteCode;
-		VAR i, j, k, n: INTEGER; b: CodeBlock;
-	BEGIN
-		j := 0; k := 0;
-		WHILE j < pc DO
-			n := pc - j; i := 0; b := code[k];
-			IF n > CodeLength THEN n := CodeLength END;
-			WHILE i < n DO DevCPM.ObjW(b^[i]); INC(i) END;
-			INC(j, n); INC(k)
-		END
-	END WriteCode;
-
-
-	PROCEDURE OffsetLink* (obj: DevCPT.Object; offs: INTEGER): DevCPT.LinkList;
-		VAR link: DevCPT.LinkList; m: DevCPT.Object;
-	BEGIN
-		ASSERT((obj.mode # Typ) OR (obj.typ # DevCPT.int32typ));
-		ASSERT((obj.mode # Typ) OR (obj.typ # DevCPT.iunktyp) & (obj.typ # DevCPT.guidtyp));
-		IF obj.mnolev >= 0 THEN	(* not imported *)
-			CASE obj.mode OF
-			| Typ: IF obj.links = NIL THEN obj.link := descList; descList := obj END
-			| TProc: IF obj.adr = -1 THEN obj := obj.nlink ELSE offs := offs + obj.adr; obj := Code END
-			| Var: offs := offs + dsize; obj := Data
-			| Con, IProc, XProc, LProc:
-			END
-		ELSIF obj.mode = Typ THEN
-			IF obj.typ.untagged THEN	(* add desc for imported untagged types *)
-				IF obj.links = NIL THEN obj.link := descList; descList := obj END
-			ELSE
-				m := DevCPT.GlbMod[-obj.mnolev];
-				IF m.library # NIL THEN RETURN NIL END	(* type import from dll *)
-			END
-		END;
-		link := obj.links;
-		WHILE (link # NIL) & (link.offset # offs) DO link := link.next END;
-		IF link = NIL THEN
-			NEW(link); link.offset := offs; link.linkadr := 0;
-			link.next := obj.links; obj.links := link
-		END;
-		RETURN link
-	END OffsetLink;
-
-
-	PROCEDURE TypeObj* (typ: DevCPT.Struct): DevCPT.Object;
-		VAR obj: DevCPT.Object;
-	BEGIN
-		obj := typ.strobj;
-		IF obj = NIL THEN
-			obj := DevCPT.NewObj(); obj.leaf := TRUE; obj.mnolev := 0;
-			obj.name := DevCPT.null; obj.mode := Typ; obj.typ := typ; typ.strobj := obj
-		END;
-		RETURN obj
-	END TypeObj;
-
-
-	PROCEDURE Align (n: INTEGER);
-		VAR p: INTEGER;
-	BEGIN
-		p := DevCPM.ObjLen();
-		DevCPM.ObjWBytes(zero, (-p) MOD n)
-	END Align;
-	
-	PROCEDURE OutName (VAR name: ARRAY OF SHORTCHAR);
-		VAR ch: SHORTCHAR; i: SHORTINT;
-	BEGIN i := 0;
-		REPEAT ch := name[i]; DevCPM.ObjW(ch); INC(i) UNTIL ch = 0X
-	END OutName;
-	
-	PROCEDURE Out2 (x: INTEGER);	(* byte ordering must correspond to target machine *)
-	BEGIN
-		IF bigEndian THEN
-			DevCPM.ObjW(SHORT(CHR(x DIV 256))); DevCPM.ObjW(SHORT(CHR(x)))
-		ELSE
-			DevCPM.ObjW(SHORT(CHR(x))); DevCPM.ObjW(SHORT(CHR(x DIV 256)))
-		END
-	END Out2;
-	
-	PROCEDURE Out4 (x: INTEGER);	(* byte ordering must correspond to target machine *)
-	BEGIN
-		IF bigEndian THEN
-			DevCPM.ObjW(SHORT(CHR(x DIV 1000000H))); DevCPM.ObjW(SHORT(CHR(x DIV 10000H)));
-			DevCPM.ObjW(SHORT(CHR(x DIV 256))); DevCPM.ObjW(SHORT(CHR(x)))
-		ELSE
-			DevCPM.ObjWLInt(x)
-		END
-	END Out4;
-
-	PROCEDURE OutReference (obj: DevCPT.Object; offs, typ: INTEGER);
-		VAR link: DevCPT.LinkList;
-	BEGIN
-		link := OffsetLink(obj, offs);
-		IF link # NIL THEN
-			Out4(typ * 1000000H + link.linkadr MOD 1000000H);
-			link.linkadr := -(DevCPM.ObjLen() - headSize - 4)
-		ELSE Out4(0)
-		END
-	END OutReference;
-	
-	PROCEDURE FindPtrs (typ: DevCPT.Struct; adr: INTEGER; ip: BOOLEAN; VAR num: INTEGER);
-		VAR fld: DevCPT.Object; btyp: DevCPT.Struct; i, n: INTEGER;
-	BEGIN
-		IF typ.form = Pointer THEN
-			IF ip & (typ.sysflag = interface)
-				OR ~ip & ~typ.untagged THEN Out4(adr); INC(num) END
-		ELSIF (typ.comp = Record) & (typ.sysflag # union) THEN
-			btyp := typ.BaseTyp;
-			IF btyp # NIL THEN FindPtrs(btyp, adr, ip, num) END ;
-			fld := typ.link;
-			WHILE (fld # NIL) & (fld.mode = Fld) DO
-				IF ip & (fld.name^ = DevCPM.HdUtPtrName) & (fld.sysflag = interface)
-					OR ~ip & (fld.name^ = DevCPM.HdPtrName) THEN Out4(fld.adr + adr); INC(num)
-				ELSE FindPtrs(fld.typ, fld.adr + adr, ip, num)
-				END;
-				fld := fld.link
-			END
-		ELSIF typ.comp = Array THEN
-			btyp := typ.BaseTyp; n := typ.n;
-			WHILE btyp.comp = Array DO n := btyp.n * n; btyp := btyp.BaseTyp END ;
-			IF (btyp.form = Pointer) OR (btyp.comp = Record) THEN
-				i := num; FindPtrs(btyp, adr, ip, num);
-				IF num # i THEN i := 1;
-					WHILE i < n DO
-						INC(adr, btyp.size); FindPtrs(btyp, adr, ip, num); INC(i)
-					END
-				END
-			END
-		END
-	END FindPtrs;
-	
-
-	PROCEDURE OutRefName* (VAR name: ARRAY OF SHORTCHAR);
-	BEGIN
-		DevCPM.ObjW(0FCX); DevCPM.ObjWNum(pc); OutName(name)
-	END OutRefName;
-
-	PROCEDURE OutRefs* (obj: DevCPT.Object);
-		VAR f: BYTE;
-	BEGIN
-		IF outRef & (obj # NIL) THEN
-			OutRefs(obj.left);
-			IF ((obj.mode = Var) OR (obj.mode = VarPar)) & (obj.history # removed) & (obj.name[0] # "@") THEN
-				f := obj.typ.form;
-				IF (f IN {Byte .. Set, Pointer, ProcTyp, Char16, Int64}) 
-						OR outURef & (obj.typ.comp # DynArr)
-						OR outAllRef & ~obj.typ.untagged
-						OR (obj.typ.comp = Array) & (obj.typ.BaseTyp.form = Char8) THEN
-					IF obj.mode = Var THEN DevCPM.ObjW(0FDX) ELSE DevCPM.ObjW(0FFX) END;
-					IF obj.typ = DevCPT.anyptrtyp THEN DevCPM.ObjW(SHORT(CHR(mAnyPtr)))
-					ELSIF obj.typ = DevCPT.anytyp THEN DevCPM.ObjW(SHORT(CHR(mAnyRec)))
-					ELSIF obj.typ = DevCPT.sysptrtyp THEN DevCPM.ObjW(SHORT(CHR(mSysPtr)))
-					ELSIF f = Char16 THEN DevCPM.ObjW(SHORT(CHR(mChar16)))
-					ELSIF f = Int64 THEN DevCPM.ObjW(SHORT(CHR(mInt64)))
-					ELSIF obj.typ = DevCPT.guidtyp THEN DevCPM.ObjW(SHORT(CHR(mGuid)))
-					ELSIF obj.typ = DevCPT.restyp THEN DevCPM.ObjW(SHORT(CHR(mResult)))
-					ELSIF f = Pointer THEN
-						IF obj.typ.sysflag = interface THEN DevCPM.ObjW(SHORT(CHR(mInterface)))
-						ELSIF obj.typ.untagged THEN DevCPM.ObjW(SHORT(CHR(mSysPtr)))
-						ELSE DevCPM.ObjW(10X); OutReference(TypeObj(obj.typ), 0, absolute)
-						END
-					ELSIF (f = Comp) & outAllRef & (~obj.typ.untagged OR outURef & (obj.typ.comp # DynArr)) THEN
-						DevCPM.ObjW(10X); OutReference(TypeObj(obj.typ), 0, absolute)
-					ELSIF f < Int8 THEN DevCPM.ObjW(SHORT(CHR(f - 1)))
-					ELSE DevCPM.ObjW(SHORT(CHR(f)))
-					END;
-					IF obj.mnolev = 0 THEN DevCPM.ObjWNum(obj.adr + dsize) ELSE DevCPM.ObjWNum(obj.adr) END;
-					OutName(obj.name^)
-				END
-			END ;
-			OutRefs(obj.right)
-		END
-	END OutRefs;
-	
-	PROCEDURE OutSourceRef* (pos: INTEGER);
-	BEGIN
-		IF outSrc & (pos # 0) & (pos # srcPos) & (pc > codePos) THEN
-			WHILE pc > codePos + 250 DO
-				DevCPM.ObjW(SHORT(CHR(250)));
-				INC(codePos, 250);
-				DevCPM.ObjWNum(0)
-			END;
-			DevCPM.ObjW(SHORT(CHR(pc - codePos)));
-			codePos := pc;
-			DevCPM.ObjWNum(pos - srcPos);
-			srcPos := pos
-		END
-	END OutSourceRef;
-
-	
-	PROCEDURE OutPLink (link: DevCPT.LinkList; adr: INTEGER);
-	BEGIN
-		WHILE link # NIL DO
-			ASSERT(link.linkadr # 0);
-			DevCPM.ObjWNum(link.linkadr);
-			DevCPM.ObjWNum(adr + link.offset);
-			link := link.next
-		END
-	END OutPLink;
-
-	PROCEDURE OutLink (link: DevCPT.LinkList);
-	BEGIN
-		OutPLink(link, 0); DevCPM.ObjW(0X)
-	END OutLink;
-	
-	PROCEDURE OutNames;
-		VAR a, b, c: DevCPT.Object;
-	BEGIN
-		a := nameList; b := NIL;
-		WHILE a # NIL DO c := a; a := c.nlink; c.nlink := b; b := c END;
-		DevCPM.ObjW(0X);	(* names[0] = 0X *)
-		WHILE b # NIL DO
-			OutName(b.name^);
-			b := b.nlink
-		END;
-	END OutNames;
-	
-	PROCEDURE OutGuid* (VAR str: ARRAY OF SHORTCHAR);
-		
-		PROCEDURE Copy (n: INTEGER);
-			VAR x, y: INTEGER;
-		BEGIN
-			x := ORD(str[n]); y := ORD(str[n + 1]);
-			IF x >= ORD("a") THEN DEC(x, ORD("a") - 10)
-			ELSIF x >= ORD("A") THEN DEC(x, ORD("A") - 10)
-			ELSE DEC(x, ORD("0"))
-			END;
-			IF y >= ORD("a") THEN DEC(y, ORD("a") - 10)
-			ELSIF y >= ORD("A") THEN DEC(y, ORD("A") - 10)
-			ELSE DEC(y, ORD("0"))
-			END;
-			DevCPM.ObjW(SHORT(CHR(x * 16 + y)))
-		END Copy;
-		
-	BEGIN
-		IF bigEndian THEN
-			Copy(1); Copy(3); Copy(5); Copy(7); Copy(10); Copy(12); Copy(15); Copy(17)
-		ELSE
-			Copy(7); Copy(5); Copy(3); Copy(1); Copy(12); Copy(10); Copy(17); Copy(15)
-		END;
-		Copy(20); Copy(22); Copy(25); Copy(27); Copy(29); Copy(31); Copy(33); Copy(35)
-	END OutGuid;
-
-	PROCEDURE OutConst (obj: DevCPT.Object);
-		TYPE A4 = ARRAY 4 OF SHORTCHAR; A8 = ARRAY 8 OF SHORTCHAR;
-		VAR a, b, c: DevCPT.Const; r: SHORTREAL; lr: REAL; a4: A4; a8: A8; ch: SHORTCHAR; i, x, hi, low: INTEGER;
-	BEGIN
-		a := obj.conval; b := NIL;
-		WHILE a # NIL DO c := a; a := c.link; c.link := b; b := c END;
-		WHILE b # NIL DO
-			IF String8 IN b.setval THEN
-				DevCPM.ObjWBytes(b.ext^, b.intval2);
-				Align(4)
-			ELSIF String16 IN b.setval THEN
-				i := 0; REPEAT DevCPM.GetUtf8(b.ext^, x, i); Out2(x) UNTIL x = 0;
-				Align(4)
-			ELSIF Real32 IN b.setval THEN
-				r := SHORT(b.realval); a4 := SYSTEM.VAL(A4, r);
-				IF DevCPM.LEHost = bigEndian THEN
-					ch := a4[0]; a4[0] := a4[3]; a4[3] := ch;
-					ch := a4[1]; a4[1] := a4[2]; a4[2] := ch
-				END;
-				DevCPM.ObjWBytes(a4, 4)
-			ELSIF Real64 IN b.setval THEN
-				a8 := SYSTEM.VAL(A8, b.realval);
-				IF DevCPM.LEHost = bigEndian THEN
-					ch := a8[0]; a8[0] := a8[7]; a8[7] := ch;
-					ch := a8[1]; a8[1] := a8[6]; a8[6] := ch;
-					ch := a8[2]; a8[2] := a8[5]; a8[5] := ch;
-					ch := a8[3]; a8[3] := a8[4]; a8[4] := ch
-				END;
-				DevCPM.ObjWBytes(a8, 8)
-			ELSIF Int64 IN b.setval THEN
-				(* intval moved to intval2 by AllocConst *)
-				x := b.intval; b.intval := b.intval2; GetLongWords(b, hi, low); b.intval := x;
-				IF bigEndian THEN Out4(hi); Out4(low) ELSE Out4(low); Out4(hi) END
-			ELSIF Guid IN b.setval THEN
-				OutGuid(b.ext^)
-			END;
-			b := b.link
-		END
-	END OutConst;
-	
-	PROCEDURE OutStruct (typ: DevCPT.Struct; unt: BOOLEAN);
-	BEGIN
-		IF typ = NIL THEN Out4(0)
-		ELSIF typ = DevCPT.sysptrtyp THEN Out4(mSysPtr)
-		ELSIF typ = DevCPT.anytyp THEN Out4(mAnyRec)
-		ELSIF typ = DevCPT.anyptrtyp THEN Out4(mAnyPtr)
-		ELSIF typ = DevCPT.guidtyp THEN Out4(mGuid)
-		ELSIF typ = DevCPT.restyp THEN Out4(mResult)
-		ELSE
-			CASE typ.form OF
-			| Undef, Byte, String8, NilTyp, NoTyp, String16: Out4(0)
-			| Bool, Char8: Out4(typ.form - 1)
-			| Int8..Set: Out4(typ.form)
-			| Char16: Out4(mChar16)
-			| Int64: Out4(mInt64)
-			| ProcTyp: OutReference(TypeObj(typ), 0, absolute)
-			| Pointer:
-				IF typ.sysflag = interface THEN Out4(mInterface)
-				ELSIF typ.untagged THEN Out4(mSysPtr)
-				ELSE OutReference(TypeObj(typ), 0, absolute)
-				END
-			| Comp:
-				IF ~typ.untagged OR (outURef & unt) THEN OutReference(TypeObj(typ), 0, absolute)
-				ELSE Out4(0)
-				END
-			END
-		END
-	END OutStruct;
-	
-	PROCEDURE NameIdx (obj: DevCPT.Object): INTEGER;
-		VAR n: INTEGER;
-	BEGIN
-		n := 0;
-		IF obj.name # DevCPT.null THEN
-			IF obj.num = 0 THEN
-				obj.num := namex;
-				WHILE obj.name[n] # 0X DO INC(n) END;
-				INC(namex, n + 1);
-				obj.nlink := nameList; nameList := obj
-			END;
-			n := obj.num;
-		END;
-		RETURN n
-	END NameIdx;
-	
-	PROCEDURE OutSignature (par: DevCPT.Object; retTyp: DevCPT.Struct; OUT pos: INTEGER);
-		VAR p: DevCPT.Object; n, m: INTEGER;
-	BEGIN
-		pos := DevCPM.ObjLen() - headSize;
-		OutStruct(retTyp, TRUE);
-		p := par; n := 0;
-		WHILE p # NIL DO INC(n); p := p.link END;
-		Out4(n); p := par;
-		WHILE p # NIL DO
-			IF p.mode # VarPar THEN m := mValue
-			ELSIF p.vis = inPar THEN m := mInPar
-			ELSIF p.vis = outPar THEN m := mOutPar
-			ELSE m := mVarPar
-			END;
-			Out4(NameIdx(p) * 256 + m);
-			OutStruct(p.typ, TRUE);
-			p := p.link
-		END
-	END OutSignature;
-	
-	PROCEDURE PrepObject (obj: DevCPT.Object);
-	BEGIN
-		IF (obj.mode IN {LProc, XProc, IProc}) & outSignatures THEN	(* write param list *)
-			OutSignature(obj.link, obj.typ, obj.conval.intval)
-		END
-	END PrepObject;
-	
-	PROCEDURE OutObject (mode, fprint, offs: INTEGER; typ: DevCPT.Struct; obj: DevCPT.Object);
-		VAR vis: INTEGER;
-	BEGIN
-		Out4(fprint);
-		Out4(offs);
-		IF obj.vis = internal THEN vis := mInternal
-		ELSIF obj.vis = externalR THEN vis := mReadonly
-		ELSIF obj.vis = external THEN vis := mExported
-		END;
-		Out4(mode + vis * 16 + NameIdx(obj) * 256);
-		IF (mode = mProc) & outSignatures THEN OutReference(Meta, obj.conval.intval, absolute)	(* ref to par list *)
-		ELSE OutStruct(typ, mode = mField)
-		END
-	END OutObject;
-	
-	PROCEDURE PrepDesc (desc: DevCPT.Struct);
-		VAR fld: DevCPT.Object; n: INTEGER; l: DevCPT.LinkList; b: DevCPT.Struct;
-	BEGIN
-		IF desc.comp = Record THEN	(* write field list *)
-			desc.strobj.adr := DevCPM.ObjLen() - headSize;
-			n := 0; fld := desc.link;
-			WHILE (fld # NIL) & (fld.mode = Fld) DO
-				IF expAllFields OR (fld.vis # internal) THEN INC(n) END;
-				fld := fld.link
-			END;
-			Out4(n); fld := desc.link;
-			WHILE (fld # NIL) & (fld.mode = Fld) DO
-				IF expAllFields OR (fld.vis # internal) THEN
-					OutObject(mField, 0, fld.adr, fld.typ, fld)
-				END;
-				fld := fld.link
-			END
-		ELSIF (desc.form = ProcTyp) & outSignatures THEN	(* write param list *)
-			OutSignature(desc.link, desc.BaseTyp, desc.n)
-		END;
-		(* assert name and base type are included *)
-		IF desc.untagged THEN n := NameIdx(untgd)
-		ELSE n := NameIdx(desc.strobj)
-		END;
-		IF desc.form # ProcTyp THEN b := desc.BaseTyp;
-			IF (b # NIL) & (b # DevCPT.anytyp) & (b # DevCPT.anyptrtyp) & (b.form IN {Pointer, Comp, ProcTyp})
-					& (b.sysflag # interface) & (b # DevCPT.guidtyp)
-					& (~b.untagged OR outURef & (b.form = Comp)) THEN
-				l := OffsetLink(TypeObj(b), 0)
-			END
-		END
-	END PrepDesc;
-	
-	PROCEDURE NumMeth (root: DevCPT.Object; num: INTEGER): DevCPT.Object;
-		VAR obj: DevCPT.Object;
-	BEGIN
-		IF (root = NIL) OR (root.mode = TProc) & (root.num = num) THEN RETURN root END;
-		obj := NumMeth(root.left, num);
-		IF obj = NIL THEN obj := NumMeth(root.right, num) END;
-		RETURN obj
-	END NumMeth;
-	
-	PROCEDURE OutDesc (desc: DevCPT.Struct);
-		VAR m: DevCPT.Object; i, nofptr, flddir, size: INTEGER; t, xb: DevCPT.Struct; form, lev, attr: BYTE;
-			name: DevCPT.Name;
-	BEGIN
-		ASSERT(~desc.untagged);
-		IF desc.comp = Record THEN
-			xb := desc; flddir := desc.strobj.adr;
-			REPEAT xb := xb.BaseTyp UNTIL (xb = NIL) OR (xb.mno # 0) OR xb.untagged;
-			Out4(-1); i := desc.n;
-			WHILE i > 0 DO DEC(i); t := desc;
-				REPEAT
-					m := NumMeth(t.link, i); t := t.BaseTyp
-				UNTIL (m # NIL) OR (t = xb);
-				IF m # NIL THEN 
-					IF absAttr IN m.conval.setval THEN Out4(0)
-					ELSE OutReference(m, 0, absolute)
-					END
-				ELSIF (xb = NIL) OR xb.untagged THEN Out4(0)	(* unimplemented ANYREC method *)
-				ELSE OutReference(xb.strobj, -4 - 4 * i, copy)
-				END
-			END;
-			desc.strobj.adr := DevCPM.ObjLen() - headSize;	(* desc adr *)
-			Out4(desc.size);
-			OutReference(Mod, 0, absolute);
-			IF desc.untagged THEN m := untgd ELSE m := desc.strobj END;
-			IF desc.attribute = extAttr THEN attr := 1
-			ELSIF desc.attribute = limAttr THEN attr := 2
-			ELSIF desc.attribute = absAttr THEN attr := 3
-			ELSE attr := 0
-			END;
-			Out4(mRecord + attr * 4 + desc.extlev * 16 + NameIdx(m) * 256); i := 0;
-			WHILE i <= desc.extlev DO
-				t := desc;
-				WHILE t.extlev > i DO t := t.BaseTyp END;
-				IF t.sysflag = interface THEN Out4(0)
-				ELSIF t.untagged THEN OutReference(TypeObj(t), 0, absolute)
-				ELSIF (t.mno = 0) THEN OutReference(t.strobj, 0, absolute)
-				ELSIF t = xb THEN OutReference(xb.strobj, 0, absolute)
-				ELSE OutReference(xb.strobj, 12 + 4 * i, copy)
-				END;
-				INC(i)
-			END;
-			WHILE i <= DevCPM.MaxExts DO Out4(0); INC(i) END;
-			OutReference(Meta, flddir, absolute);	(* ref to field list *)
-			nofptr := 0; FindPtrs(desc, 0, FALSE, nofptr);
-			Out4(-(4 * nofptr + 4));
-			nofptr := 0; FindPtrs(desc, 0, TRUE, nofptr);
-			Out4(-1)
-		ELSE
-			desc.strobj.adr := DevCPM.ObjLen() - headSize;
-			lev := 0; size := 0;
-			IF desc.comp = Array THEN
-				size := desc.n; form := mArray
-			ELSIF desc.comp = DynArr THEN
-				form := mArray; lev := SHORT(SHORT(desc.n + 1))
-			ELSIF desc.form = Pointer THEN
-				form := mPointer
-			ELSE ASSERT(desc.form = ProcTyp);
-				DevCPM.FPrint(size, XProc); DevCPT.FPrintSign(size, desc.BaseTyp, desc.link); form := mProctyp;
-			END;
-			Out4(size);
-			OutReference(Mod, 0, absolute);
-			IF desc.untagged THEN m := untgd ELSE m := desc.strobj END;
-			Out4(form + lev * 16 + NameIdx(m) * 256);
-			IF desc.form # ProcTyp THEN OutStruct(desc.BaseTyp, TRUE)
-			ELSIF outSignatures THEN OutReference(Meta, desc.n, absolute)	(* ref to par list *)
-			END
-		END
-	END OutDesc;
-
-	PROCEDURE OutModDesc (nofptr, refSize, namePos, ptrPos, expPos, impPos: INTEGER);
-		VAR i: INTEGER; t: Dates.Time; d: Dates.Date;
-	BEGIN
-		Out4(0);	(* link *)
-		Out4(ORD(options));	(* opts *)
-		Out4(0);	(* refcnt *)
-		Dates.GetDate(d); Dates.GetTime(t); 	(* compile time *)
-		Out2(d.year); Out2(d.month); Out2(d.day);
-		Out2(t.hour); Out2(t.minute); Out2(t.second);
-		Out4(0); Out4(0); Out4(0); 	(* load time *)
-		Out4(0);	(* ext *)
-		IF closeLbl # 0 THEN OutReference(Code, closeLbl, absolute);	(* terminator *)
-		ELSE Out4(0)
-		END;
-		Out4(imports);	(* nofimps *)
-		Out4(nofptr);	(* nofptrs *)
-		Out4(pc);	(* csize *)
-		Out4(dsize);	(* dsize *)
-		Out4(refSize);	(* rsize *)
-		OutReference(Code, 0, absolute);	(* code *)
-		OutReference(Data, 0, absolute);	(* data *)
-		OutReference(Meta, 0, absolute);	(* refs *)
-		IF procVarIndirect THEN
-			OutReference(Proc, 0, absolute);	(* procBase *)
-		ELSE
-			OutReference(Code, 0, absolute);	(* procBase *)
-		END;
-		OutReference(Data, 0, absolute);	(* varBase *)
-		OutReference(Meta, namePos, absolute);	(* names *)
-		OutReference(Meta, ptrPos, absolute);	(* ptrs *)
-		OutReference(Meta, impPos, absolute);	(* imports *)
-		OutReference(Meta, expPos, absolute);	(* export *)
-		i := 0;	(* name *)
-		WHILE DevCPT.SelfName[i] # 0X DO DevCPM.ObjW(DevCPT.SelfName[i]); INC(i) END;
-		DevCPM.ObjW(0X);
-		Align(4)
-	END OutModDesc;
-
-	PROCEDURE OutProcTable (obj: DevCPT.Object);	(* 68000 *)
-	BEGIN
-		IF obj # NIL THEN
-			OutProcTable(obj.left);
-			IF obj.mode IN {XProc, IProc} THEN
-				Out2(4EF9H); OutReference(Code, obj.adr, absolute); Out2(0);
-			END;
-			OutProcTable(obj.right);
-		END;
-	END OutProcTable;
-
-	PROCEDURE PrepExport (obj: DevCPT.Object);
-	BEGIN
-		IF obj # NIL THEN
-			PrepExport(obj.left);
-			IF (obj.mode IN {LProc, XProc, IProc}) & (obj.history # removed) & (obj.vis # internal) THEN
-				PrepObject(obj)
-			END;
-			PrepExport(obj.right)
-		END
-	END PrepExport;
-	
-	PROCEDURE OutExport (obj: DevCPT.Object);
-		VAR num: INTEGER;
-	BEGIN
-		IF obj # NIL THEN
-			OutExport(obj.left);
-			IF (obj.history # removed) & ((obj.vis # internal) OR
-						(obj.mode = Typ) & (obj.typ.strobj = obj) & (obj.typ.form = Comp)) THEN
-				DevCPT.FPrintObj(obj);
-				IF obj.mode IN {LProc, XProc, IProc} THEN
-					IF procVarIndirect THEN
-						ASSERT(obj.nlink = NIL);
-						num := obj.num; obj.num := 0;
-						OutObject(mProc, obj.fprint, num, NIL, obj);
-						obj.num := num
-					ELSE
-						OutObject(mProc, obj.fprint, obj.adr, NIL, obj)
-					END
-				ELSIF obj.mode = Var THEN
-					OutObject(mVar, obj.fprint, dsize + obj.adr, obj.typ, obj)
-				ELSIF obj.mode = Typ THEN
-					OutObject(mTyp, obj.typ.pbfp, obj.typ.pvfp, obj.typ, obj)
-				ELSE ASSERT(obj.mode IN {Con, CProc});
-					OutObject(mConst, obj.fprint, 0, NIL, obj)
-				END
-			END;
-			OutExport(obj.right)
-		END
-	END OutExport;
-	
-	PROCEDURE OutCLinks (obj: DevCPT.Object);
-	BEGIN
-		IF obj # NIL THEN
-			OutCLinks(obj.left);
-			IF obj.mode IN {LProc, XProc, IProc} THEN OutPLink(obj.links, obj.adr) END;
-			OutCLinks(obj.right)
-		END
-	END OutCLinks;
-
-	PROCEDURE OutCPLinks (obj: DevCPT.Object; base: INTEGER);
-	BEGIN
-		IF obj # NIL THEN
-			OutCPLinks(obj.left, base);
-			IF obj.mode IN {LProc, XProc, IProc} THEN OutPLink(obj.links, obj.num + base) END;
-			OutCPLinks(obj.right, base)
-		END
-	END OutCPLinks;
-
-	PROCEDURE OutImport (obj: DevCPT.Object);
-		VAR typ: DevCPT.Struct; strobj: DevCPT.Object; opt: INTEGER;
-	BEGIN
-		IF obj # NIL THEN
-			OutImport(obj.left);
-			IF obj.mode = Typ THEN typ := obj.typ;
-				IF obj.used OR
-					(typ.form IN {Pointer, Comp}) & (typ.strobj = obj) &
-						((obj.links # NIL) OR (obj.name # DevCPT.null) & (typ.pvused OR typ.pbused)) THEN
-					DevCPT.FPrintStr(typ);
-					DevCPM.ObjW(SHORT(CHR(mTyp))); OutName(obj.name^);
-					IF obj.used THEN opt := 2 ELSE opt := 0 END;
-					IF (typ.form = Comp) & ((typ.pvused) OR (obj.name = DevCPT.null)) THEN
-						DevCPM.ObjWNum(typ.pvfp); DevCPM.ObjW(SHORT(CHR(opt + 1)));
-						IF obj.history = inconsistent THEN DevCPT.FPrintErr(obj, 249) END
-					ELSE DevCPM.ObjWNum(typ.pbfp); DevCPM.ObjW(SHORT(CHR(opt)))
-					END;
-					OutLink(obj.links)
-				END
-			ELSIF obj.used THEN
-				DevCPT.FPrintObj(obj);
-				IF obj.mode = Var THEN
-					DevCPM.ObjW(SHORT(CHR(mVar))); OutName(obj.name^);
-					DevCPM.ObjWNum(obj.fprint); OutLink(obj.links)
-				ELSIF obj.mode IN {XProc, IProc} THEN
-					DevCPM.ObjW(SHORT(CHR(mProc))); OutName(obj.name^);
-					DevCPM.ObjWNum(obj.fprint); OutLink(obj.links)
-				ELSE ASSERT(obj.mode IN {Con, CProc});
-					DevCPM.ObjW(SHORT(CHR(mConst))); OutName(obj.name^); DevCPM.ObjWNum(obj.fprint)
-				END
-			END;
-			OutImport(obj.right)
-		END
-	END OutImport;
-	
-	PROCEDURE OutUseBlock;
-		VAR m, obj: DevCPT.Object; i: INTEGER;
-	BEGIN
-		m := dllList;
-		WHILE m # NIL DO
-			obj := m.nlink;
-			WHILE obj # NIL DO
-				IF obj.mode = Var THEN DevCPM.ObjW(SHORT(CHR(mVar)))
-				ELSE DevCPM.ObjW(SHORT(CHR(mProc)))
-				END;
-				IF obj.entry # NIL THEN OutName(obj.entry^)
-				ELSE OutName(obj.name^);
-				END;
-				DevCPT.FPrintObj(obj); DevCPM.ObjWNum(obj.fprint); OutLink(obj.links);
-				obj := obj.nlink
-			END;
-			DevCPM.ObjW(0X); m := m.link
-		END;
-		i := 1;
-		WHILE i < DevCPT.nofGmod DO
-			obj := DevCPT.GlbMod[i];
-			IF obj.library = NIL THEN OutImport(obj.right); DevCPM.ObjW(0X) END;
-			INC(i)
-		END;
-	END OutUseBlock;
-
-	PROCEDURE CollectDll (obj: DevCPT.Object; mod: DevCPT.String);
-		VAR name: DevCPT.String; dll: DevCPT.Object;
-	BEGIN
-		IF obj # NIL THEN
-			CollectDll(obj.left, mod);
-			IF obj.used & (obj.mode IN {Var, XProc, IProc}) THEN
-				IF obj.library # NIL THEN name := obj.library
-				ELSE name := mod
-				END;
-				dll := dllList;
-				WHILE (dll # NIL) & (dll.library^ # name^) DO dll := dll.link END;
-				IF dll = NIL THEN
-					NEW(dll); dll.library := name; INC(imports);
-					IF dllList = NIL THEN dllList := dll ELSE dllLast.link := dll END;
-					dllLast := dll; dll.left := dll;
-				END;
-				dll.left.nlink := obj; dll.left := obj
-			END;
-			CollectDll(obj.right, mod)
-		END
-	END CollectDll;
-	
-	PROCEDURE EnumXProc(obj: DevCPT.Object; VAR num: INTEGER);
-	BEGIN
-		IF obj # NIL THEN
-			EnumXProc(obj.left, num);
-			IF obj.mode IN {XProc, IProc} THEN
-				obj.num := num; INC(num, 8);
-			END;
-			EnumXProc(obj.right, num)
-		END;
-	END EnumXProc;
-	
-	PROCEDURE OutHeader*;
-		VAR i: INTEGER; m: DevCPT.Object;
-	BEGIN
-		DevCPM.ObjWLInt(processor);	(* processor type *)
-		DevCPM.ObjWLInt(0); DevCPM.ObjWLInt(0); DevCPM.ObjWLInt(0);
-		DevCPM.ObjWLInt(0); DevCPM.ObjWLInt(0);	(* sizes *)
-		imports := 0; i := 1;
-		WHILE i < DevCPT.nofGmod DO
-			m := DevCPT.GlbMod[i];
-			IF m.library # NIL THEN	(* dll import *)
-				CollectDll(m.right, m.library);
-			ELSE INC(imports)	(* module import *)
-			END;
-			INC(i)
-		END;
-		DevCPM.ObjWNum(imports);	(* num of import *)
-		OutName(DevCPT.SelfName); 
-		m := dllList;
-		WHILE m # NIL DO DevCPM.ObjW("$"); OutName(m.library^); m := m.link END;
-		i := 1;
-		WHILE i < DevCPT.nofGmod DO
-			m := DevCPT.GlbMod[i];
-			IF m.library = NIL THEN OutName(m.name^) END;
-			INC(i)
-		END;
-		Align(16); headSize := DevCPM.ObjLen();
-		IF procVarIndirect THEN
-			i := 0; EnumXProc(DevCPT.topScope.right, i)
-		END
-	END OutHeader;
-
-	PROCEDURE OutCode*;
-		VAR i, j, refSize, expPos, ptrPos, impPos, namePos, procPos,
-			con8Pos, con16Pos, con32Pos, con64Pos, modPos, codePos: INTEGER;
-			m, obj, dlist: DevCPT.Object;
-	BEGIN
-	(* Ref *)
-		DevCPM.ObjW(0X); (* end mark *)
-		refSize := DevCPM.ObjLen() - headSize;
-	(* Export *)
-		Align(4);
-		IF outSignatures THEN PrepExport(DevCPT.topScope.right) END;	(* procedure signatures *)
-		Align(8); expPos := DevCPM.ObjLen(); 
-		Out4(0);
-		OutExport(DevCPT.topScope.right);	(* export objects *)
-		i := DevCPM.ObjLen(); DevCPM.ObjSet(expPos); Out4((i - expPos - 4) DIV 16); DevCPM.ObjSet(i);
-	(* Pointers *)
-		ptrPos := DevCPM.ObjLen();
-		obj := DevCPT.topScope.scope; nofptrs := 0;
-		WHILE obj # NIL DO FindPtrs(obj.typ, dsize + obj.adr, FALSE, nofptrs); obj := obj.link END;
-		obj := DevCPT.topScope.scope; i := 0;
-		WHILE obj # NIL DO FindPtrs(obj.typ, dsize + obj.adr, TRUE, i); obj := obj.link END;
-		IF i > 0 THEN Out4(-1); INCL(options, iptrs) END;
-	(* Prepare Type Descriptors *)
-		dlist := NIL;
-		WHILE descList # NIL DO
-			obj := descList; descList := descList.link;
-			PrepDesc(obj.typ);
-			obj.link := dlist; dlist := obj
-		END;
-	(* Import List *)
-		impPos := DevCPM.ObjLen(); i := 0;
-		WHILE i < imports DO Out4(0); INC(i) END;
-	(* Names *)
-		namePos := DevCPM.ObjLen(); OutNames;
-	(* Const *)
-		Align(4); con8Pos := DevCPM.ObjLen();
-		OutConst(Const8); con16Pos := DevCPM.ObjLen();
-		ASSERT(con16Pos MOD 4 = 0); ASSERT(con16Pos - con8Pos = idx8);
-		OutConst(Const16); con32Pos := DevCPM.ObjLen();
-		ASSERT(con32Pos MOD 4 = 0); ASSERT(con32Pos - con16Pos = idx16);
-		OutConst(Const32); con64Pos := DevCPM.ObjLen();
-		ASSERT(con64Pos MOD 4 = 0); ASSERT(con64Pos - con32Pos = idx32);
-		IF ODD(con64Pos DIV 4) THEN Out4(0); INC(con64Pos, 4) END;
-		OutConst(Const64); ASSERT(DevCPM.ObjLen() - con64Pos = idx64);
-	(* Module Descriptor *)
-		Align(16); modPos := DevCPM.ObjLen();
-		OutModDesc(nofptrs, refSize, namePos - headSize, ptrPos - headSize, expPos - headSize, impPos - headSize);
-	(* Procedure Table *)
-		procPos := DevCPM.ObjLen();
-		OutProcTable(DevCPT.topScope.right);
-		Out4(0); Out4(0); (* at least one entry in ProcTable *)
-		Out4(0); (* sentinel *)
-	(* Type Descriptors *)
-		obj := dlist;
-		WHILE obj # NIL DO OutDesc(obj.typ); obj := obj.link END;
-	(* Code *)
-		codePos := DevCPM.ObjLen(); WriteCode;
-		WHILE pc MOD 4 # 0 DO DevCPM.ObjW(90X); INC(pc) END;
-	(* Fixups *)
-		OutLink(KNewRec.links); OutLink(KNewArr.links);
-		(* metalink *)
-		OutPLink(Const8.links, con8Pos - headSize);
-		OutPLink(Const16.links, con16Pos - headSize);
-		OutPLink(Const32.links, con32Pos - headSize);
-		OutPLink(Const64.links, con64Pos - headSize);
-		OutLink(Meta.links);
-		(* desclink *)
-		obj := dlist; i := modPos - headSize;
-		WHILE obj # NIL DO OutPLink(obj.links, obj.adr - i); obj.links := NIL; obj := obj.link END;
-		IF procVarIndirect THEN
-			OutPLink(Proc.links, procPos - modPos);
-			OutCPLinks(DevCPT.topScope.right, procPos - modPos)
-		END;
-		OutLink(Mod.links);
-		(* codelink *)
-		IF ~procVarIndirect THEN OutCLinks(DevCPT.topScope.right) END;
-		OutPLink(CaseLinks, 0); OutLink(Code.links);
-		(* datalink *)
-		OutLink(Data.links);
-	(* Use *)
-		OutUseBlock;
-	(* Header Fixups *)
-		DevCPM.ObjSet(8);
-		DevCPM.ObjWLInt(headSize);
-		DevCPM.ObjWLInt(modPos - headSize);
-		DevCPM.ObjWLInt(codePos - modPos);
-		DevCPM.ObjWLInt(pc);
-		DevCPM.ObjWLInt(dsize);
-		IF namex > MaxNameTab THEN DevCPM.err(242) END;
-		IF DevCPM.noerr & outObj THEN DevCPM.RegisterObj END
-	END OutCode;
-
-	PROCEDURE Init* (proc: INTEGER; opt: SET);
-		CONST obj = 3; ref = 4; allref = 5; srcpos = 6; bigEnd = 15; pVarInd = 14;
-	BEGIN
-		processor := proc;
-		bigEndian := bigEnd IN opt; procVarIndirect := pVarInd IN opt;
-		outRef := ref IN opt; outAllRef := allref IN opt; outObj := obj IN opt;
-		outURef := useAllRef & outAllRef & (DevCPM.comAware IN DevCPM.options);
-		outSrc := srcpos IN opt;
-		pc := 0; actIdx := CodeLength; blkIdx := 0; 
-		idx8 := 0; idx16 := 0; idx32 := 0; idx64 := 0; namex := 1;
-		options := opt * {0..15}; CodeOvF := FALSE;
-		KNewRec.links := NIL; KNewArr.links := NIL; CaseLinks := NIL;
-		Const8.links := NIL; Const8.conval := NIL; Const16.links := NIL; Const16.conval := NIL;
-		Const32.links := NIL; Const32.conval := NIL; Const64.links := NIL; Const64.conval := NIL;
-		Code.links := NIL; Data.links := NIL; Mod.links := NIL; Proc.links := NIL; Meta.links := NIL;
-		nameList := NIL; descList := NIL; dllList := NIL; dllLast := NIL;
-		codePos := 0; srcPos := 0;
-		NEW(untgd); untgd.name := DevCPT.NewName("!");
-		closeLbl := 0
-	END Init;
-
-	PROCEDURE Close*;
-	BEGIN
-		KNewRec.links := NIL; KNewArr.links := NIL; CaseLinks := NIL;
-		Const8.links := NIL; Const8.conval := NIL; Const16.links := NIL; Const16.conval := NIL;
-		Const32.links := NIL; Const32.conval := NIL; Const64.links := NIL; Const64.conval := NIL;
-		Code.links := NIL; Data.links := NIL; Mod.links := NIL; Proc.links := NIL; Meta.links := NIL;
-		nameList := NIL; descList := NIL; dllList := NIL; dllLast := NIL;
-		WHILE blkIdx > 0 DO DEC(blkIdx); code[blkIdx] := NIL END;
-		actual := NIL; untgd := NIL;
-	END Close;
-
-BEGIN
-	NEW(KNewRec); KNewRec.mnolev := -128;
-	NEW(KNewArr); KNewArr.mnolev := -128;
-	NEW(Const8); Const8.mode := Con; Const8.mnolev := 0;
-	NEW(Const16); Const16.mode := Con; Const16.mnolev := 0;
-	NEW(Const32); Const32.mode := Con; Const32.mnolev := 0;
-	NEW(Const64); Const64.mode := Con; Const64.mnolev := 0;
-	NEW(Code); Code.mode := Con; Code.mnolev := 0;
-	NEW(Data); Data.mode := Con; Data.mnolev := 0;
-	NEW(Mod); Mod.mode := Con; Mod.mnolev := 0;
-	NEW(Proc); Proc.mode := Con; Proc.mnolev := 0;
-	NEW(Meta); Meta.mode := Con; Mod.mnolev := 0;
-END DevCPE.

BlackBox/Dev/Mod/CPH.txt

@@ -1,291 +0,0 @@
-MODULE DevCPH;
-
-	(* THIS IS TEXT COPY OF BlackBox 1.6-rc6 Dev/Mod/CPH.odc *)
-	(* DO NOT EDIT *)
-
-	IMPORT DevCPT;
-	
-	CONST
-		(* UseCalls options *)
-		longMop* = 0; longDop* = 1; longConv* = 2; longOdd* = 3;
-		realMop* = 8; realDop* = 9; realConv* = 10;
-		intMulDiv* = 11;
-		force = 16; hide = 17;
-	
-		(* nodes classes *)
-		Nvar = 0; Nvarpar = 1; Nfield = 2; Nderef = 3; Nindex = 4; Nguard = 5; Neguard = 6;
-		Nconst = 7; Ntype = 8; Nproc = 9; Nupto = 10; Nmop = 11; Ndop = 12; Ncall = 13;
-		Ninittd = 14; Nif = 15; Ncaselse = 16; Ncasedo = 17; Nenter = 18; Nassign = 19;
-		Nifelse =20; Ncase = 21; Nwhile = 22; Nrepeat = 23; Nloop = 24; Nexit = 25;
-		Nreturn = 26; Nwith = 27; Ntrap = 28; Ncomp = 30;
-		Ndrop = 50; Nlabel = 51; Ngoto = 52; Njsr = 53; Nret = 54; Ncmp = 55;
-		
-		(*function number*)
-		assign = 0; newfn = 1; incfn = 13; decfn = 14;
-		inclfn = 15; exclfn = 16; copyfn = 18; assertfn = 32;
-		getfn = 24; putfn = 25; getrfn = 26; putrfn = 27; sysnewfn = 30; movefn = 31;
-		
-		(* symbol values and ops *)
-		times = 1; slash = 2; div = 3; mod = 4;
-		and = 5; plus = 6; minus = 7; or = 8; eql = 9;
-		neq = 10; lss = 11; leq = 12; gtr = 13; geq = 14;
-		in = 15; is = 16; ash = 17; msk = 18; len = 19;
-		conv = 20; abs = 21; cap = 22; odd = 23; not = 33;
-		adr = 24; cc = 25; bit = 26; lsh = 27; rot = 28; val = 29;
-		min = 34; max = 35; typfn = 36;
-		thisrecfn = 45; thisarrfn = 46;
-		shl = 50; shr = 51; lshr = 52; xor = 53;
-
-		(* structure forms *)
-		Undef = 0; Byte = 1; Bool = 2; Char8 = 3; Int8 = 4; Int16 = 5; Int32 = 6;
-		Real32 = 7; Real64 = 8; Set = 9; String8 = 10; NilTyp = 11; NoTyp = 12;
-		Pointer = 13; ProcTyp = 14; Comp = 15;
-		Char16 = 16; String16 = 17; Int64 = 18;
-		VString16to8 = 29; VString8 = 30; VString16 = 31;
-		realSet = {Real32, Real64};
-		Basic = 1; Array = 2; DynArr = 3; Record = 4;
-
-		
-
-	PROCEDURE UseThisCall (n: DevCPT.Node; IN name: ARRAY OF SHORTCHAR);
-		VAR mod, nm, moda: DevCPT.Name; mobj, obj: DevCPT.Object; done: BOOLEAN;
-	BEGIN
-		IF (n.typ.form = Real64) OR (n.left.typ.form = Real64) THEN mod := "Real"
-		ELSIF (n.typ.form = Real32) OR (n.left.typ.form = Real32) THEN mod := "SReal"
-		ELSIF (n.typ.form = Int64) OR (n.left.typ.form = Int64) THEN mod := "Long"
-		ELSE mod := "Int"
-		END;
-		moda := mod + "%";
-		DevCPT.Find(moda, mobj);
-		IF mobj = NIL THEN
-			DevCPT.Import(moda, mod, done);
-			IF done THEN DevCPT.Find(moda, mobj) END
-		END;
-		nm := name$; DevCPT.FindImport(nm, mobj, obj);
-		n.class := Ncall; n.subcl := 0; n.obj := obj.link;
-		n.left.link := n.right; n.right := n.left;
-		n.left := DevCPT.NewNode(Nproc);
-		n.left.obj := obj; n.left.typ := obj.typ;
-		ASSERT(n.typ.form = obj.typ.form)
-	END UseThisCall;
-	
-	PROCEDURE Convert (n: DevCPT.Node; typ: DevCPT.Struct);
-		VAR new: DevCPT.Node; r: REAL;
-	BEGIN
-		IF n.class = Nconst THEN
-			ASSERT((n.typ.form IN {Int32, Int64}) & (typ = DevCPT.intrealtyp));
-			r := n.conval.realval + n.conval.intval;
-			IF r = n.conval.realval + n.conval.intval THEN
-				n.conval.realval := r; n.conval.intval := -1; n.typ := typ; n.obj := NIL
-			END
-		END;
-		IF (n.typ # typ)
-			& ((n.class # Nmop) OR (n.subcl # conv)
-				OR ~DevCPT.Includes(n.typ.form, n.left.typ.form) & ~DevCPT.Includes(n.typ.form, typ.form)) THEN
-			new := DevCPT.NewNode(0); new^ := n^;
-			n.class := Nmop; n.subcl := conv; n.left := new; n.right := NIL; n.obj := NIL
-		END;
-		n.typ := typ
-	END Convert;
-	
-	PROCEDURE UseCallForComp (n: DevCPT.Node);
-		VAR new: DevCPT.Node;
-	BEGIN
-		new := DevCPT.NewNode(0);
-		new.left := n.left; new.right := n.right;
-		new.typ := DevCPT.int32typ;
-		UseThisCall(new, "Comp");
-		n.left := new;
-		n.right := DevCPT.NewNode(Nconst); n.right.conval := DevCPT.NewConst();
-		n.right.conval.intval := 0; n.right.conval.realval := 0; n.right.typ := DevCPT.int32typ;
-	END UseCallForComp;
-	
-	PROCEDURE UseCallForConv (n: DevCPT.Node; opts: SET);
-		VAR f, g: INTEGER; typ: DevCPT.Struct;
-	BEGIN
-		typ := n.typ; f := typ.form; g := n.left.typ.form;
-		IF realConv IN opts THEN
-			IF f IN realSet THEN
-				IF g = Real32 THEN UseThisCall(n, "Long")
-				ELSIF g = Real64 THEN UseThisCall(n, "Short")
-				ELSIF g = Int64 THEN UseThisCall(n, "LFloat")
-				ELSIF g = Int32 THEN UseThisCall(n, "Float")
-				ELSE Convert(n.left, DevCPT.int32typ); UseThisCall(n, "Float")
-				END
-			ELSIF g IN realSet THEN
-				IF f = Int64 THEN UseThisCall(n, "LFloor")
-				ELSIF f = Int32 THEN UseThisCall(n, "Floor")
-				ELSE n.typ := DevCPT.int32typ; UseThisCall(n, "Floor"); Convert(n, typ)
-				END
-			END
-		END;
-		IF longConv IN opts THEN
-			IF f = Int64 THEN
-				IF g = Int32 THEN UseThisCall(n, "Long")
-				ELSIF ~(g IN realSet) THEN Convert(n.left, DevCPT.int32typ); UseThisCall(n, "IntToLong")
-				END
-			ELSIF g = Int64 THEN
-				IF f = Int32 THEN UseThisCall(n, "Short")
-				ELSIF ~(f IN realSet) THEN n.typ := DevCPT.int32typ; UseThisCall(n, "LongToInt"); Convert(n, typ)
-				END
-			END
-		END
-	END UseCallForConv;
-		
-	PROCEDURE UseCallForMop (n: DevCPT.Node; opts: SET);
-	BEGIN
-		CASE n.subcl OF
-		| minus:
-			IF (realMop IN opts) & (n.typ.form IN realSet) OR (longMop IN opts) & (n.typ.form = Int64) THEN
-				UseThisCall(n, "Neg")
-			END
-		| abs:
-			IF (realMop IN opts) & (n.typ.form IN realSet) OR (longMop IN opts) & (n.typ.form = Int64) THEN
-				UseThisCall(n, "Abs")
-			END
-		| odd:
-			IF (longOdd IN opts) & (n.left.typ.form = Int64) THEN UseThisCall(n, "Odd") END
-		| conv:
-			UseCallForConv(n, opts)
-		ELSE
-		END
-	END UseCallForMop;
-		
-	PROCEDURE UseCallForDop (n: DevCPT.Node; opts: SET);
-	BEGIN
-		IF (realDop IN opts) & (n.left.typ.form IN realSet)
-				OR (longDop IN opts) & (n.left.typ.form = Int64)
-				OR (intMulDiv IN opts) & (n.subcl IN {times, div, mod}) & (n.typ.form = Int32) THEN
-			CASE n.subcl OF
-			| times: UseThisCall(n, "Mul")
-			| slash: UseThisCall(n, "Div")
-			| div: UseThisCall(n, "Div")
-			| mod: UseThisCall(n, "Mod")
-			| plus: UseThisCall(n, "Add")
-			| minus: UseThisCall(n, "Sub")
-			| ash: UseThisCall(n, "Ash")
-			| min: UseThisCall(n, "Min")
-			| max: UseThisCall(n, "Max")
-			| eql..geq: UseCallForComp(n)
-			ELSE
-			END
-		END
-	END UseCallForDop;
-	
-	PROCEDURE UseCallForMove (n: DevCPT.Node; typ: DevCPT.Struct; opts: SET);
-		VAR f, g: INTEGER;
-	BEGIN
-		f := n.typ.form; g := typ.form;
-		IF f # g THEN
-			IF (realConv IN opts) & ((f IN realSet) OR (g IN realSet))
-					OR (longConv IN opts) & ((f = Int64) OR (g = Int64)) THEN
-				Convert(n, typ);
-				UseCallForConv(n, opts)
-			END
-		END
-	END UseCallForMove;
-		
-	PROCEDURE UseCallForAssign (n: DevCPT.Node; opts: SET);
-	BEGIN
-		IF n.subcl = assign THEN UseCallForMove(n.right, n.left.typ, opts) END
-	END UseCallForAssign;
-	
-	PROCEDURE UseCallForReturn (n: DevCPT.Node; opts: SET);
-	BEGIN
-		IF (n.left # NIL) & (n.obj # NIL) THEN UseCallForMove(n.left, n.obj.typ, opts) END
-	END UseCallForReturn;
-	
-	PROCEDURE UseCallForParam (n: DevCPT.Node; fp: DevCPT.Object; opts: SET);
-	BEGIN
-		WHILE n # NIL DO
-			UseCallForMove(n, fp.typ, opts);
-			n := n.link; fp := fp.link
-		END
-	END UseCallForParam;
-	
-	PROCEDURE UseCalls* (n: DevCPT.Node; opts: SET);
-	BEGIN
-		WHILE n # NIL DO
-			CASE n.class OF
-			| Nmop:
-				UseCalls(n.left, opts); UseCallForMop(n, opts)
-			| Ndop:
-				UseCalls(n.left, opts); UseCalls(n.right, opts); UseCallForDop(n, opts)
-			| Ncase:
-				UseCalls(n.left, opts); UseCalls(n.right.left, opts); UseCalls(n.right.right, opts)
-			| Nassign:
-				UseCalls(n.left, opts); UseCalls(n.right, opts); UseCallForAssign(n, opts)
-			| Ncall:
-				UseCalls(n.left, opts); UseCalls(n.right, opts); UseCallForParam(n.right, n.obj, opts)
-			| Nreturn:
-				UseCalls(n.left, opts); UseCallForReturn(n, opts)
-			| Ncasedo:
-				UseCalls(n.right, opts)
-			| Ngoto, Ndrop, Nloop, Nfield, Nderef, Nguard:
-				UseCalls(n.left, opts)
-			| Nenter, Nifelse, Nif, Nwhile, Nrepeat, Nwith, Ncomp, Nupto, Nindex:
-				UseCalls(n.left, opts); UseCalls(n.right, opts)
-			| Njsr, Nret, Nlabel, Ntrap, Nexit, Ninittd, Ntype, Nproc, Nconst, Nvar, Nvarpar:
-			END;
-			n := n.link
-		END
-	END UseCalls;
-	
-		
-	PROCEDURE UseReals* (n: DevCPT.Node; opts: SET);
-	BEGIN
-		WHILE n # NIL DO
-			CASE n.class OF
-			| Nmop:
-				IF (longMop IN opts) & (n.typ.form = Int64) & ((n.subcl = abs) OR (n.subcl = minus)) THEN
-					UseReals(n.left, opts - {hide} + {force}); n.typ := DevCPT.intrealtyp
-				ELSIF n.subcl = conv THEN UseReals(n.left, opts - {force} + {hide})
-				ELSE UseReals(n.left, opts - {force, hide})
-				END
-			| Ndop:
-				IF (longDop IN opts) & (n.left.typ.form = Int64) THEN
-					UseReals(n.left, opts - {hide} + {force}); UseReals(n.right, opts - {hide} + {force});
-					IF n.typ.form = Int64 THEN n.typ := DevCPT.intrealtyp END
-				ELSE UseReals(n.left, opts - {force, hide}); UseReals(n.right, opts - {force, hide})
-				END
-			| Ncase:
-				UseReals(n.left, opts - {force, hide}); UseReals(n.right.left, opts - {force, hide});
-				UseReals(n.right.right, opts - {force, hide})
-			| Ncasedo:
-				UseReals(n.right, opts - {force, hide})
-			| Ngoto, Ndrop, Nloop, Nreturn, Nfield, Nderef, Nguard:
-				UseReals(n.left, opts - {force, hide})
-			| Nenter, Nassign, Ncall, Nifelse, Nif, Nwhile, Nrepeat, Nwith, Ncomp, Nupto, Nindex:
-				UseReals(n.left, opts - {force, hide}); UseReals(n.right, opts - {force, hide})
-			| Njsr, Nret, Nlabel, Ntrap, Nexit, Ninittd, Ntype, Nproc, Nconst, Nvar, Nvarpar:
-			END;
-			IF force IN opts THEN Convert(n, DevCPT.intrealtyp)
-			ELSIF ~(hide IN opts) & (n.typ = DevCPT.intrealtyp) THEN Convert(n, DevCPT.int64typ)
-			END;
-			n := n.link
-		END
-	END UseReals;
-		
-END DevCPH.
-
-
-
-
-	PROCEDURE Traverse (n: DevCPT.Node; opts: SET);
-	BEGIN
-		WHILE n # NIL DO
-			CASE n.class OF
-			| Ncase:
-				Traverse(n.left, opts); Traverse(n.right.left, opts); Traverse(n.right.right, opts)
-			| Ncasedo:
-				Traverse(n.right, opts)
-			| Ngoto, Ndrop, Nloop, Nreturn, Nmop, Nfield, Nderef, Nguard:
-				Traverse(n.left, opts)
-			| Nenter, Nassign, Ncall, Nifelse, Nif, Nwhile, Nrepeat, Nwith, Ncomp, Ndop, Nupto, Nindex:
-				Traverse(n.left, opts); Traverse(n.right, opts)
-			| Njsr, Nret, Nlabel, Ntrap, Nexit, Ninittd, Ntype, Nproc, Nconst, Nvar, Nvarpar:
-			END;
-			n := n.link
-		END
-	END Traverse;
-		

BlackBox/Dev/Mod/CPL486.txt

@@ -1,1057 +0,0 @@
-MODULE DevCPL486;
-
-	(* THIS IS TEXT COPY OF BlackBox 1.6-rc6 Dev/Mod/CPL486.odc *)
-	(* DO NOT EDIT *)
-
-	IMPORT DevCPM, DevCPT, DevCPE;
-	
-	TYPE
-		Item* = RECORD
-			mode*,  tmode*, form*: BYTE;
-			offset*, index*, reg*, scale*: INTEGER; (* adr = offset + index * scale *)
-			typ*: DevCPT.Struct;
-			obj*: DevCPT.Object
-		END ;
-		
-(* Items:
-
-	 mode	| offset	index		scale		reg     obj
-------------------------------------------------
- 1 Var	 | adr		 xreg		 scale					  obj  (ea = FP + adr + xreg * scale)
- 2 VarPar| off     xreg     scale            obj  (ea = [FP + obj.adr] + off + xreg * scale)
- 3 Con	 | val              (val2)           NIL
-   Con   | off                               obj  (val = adr(obj) + off)
-	 Con	 | id														    NIL  (for predefined reals)
- 6 LProc |                                   obj
- 7 XProc |                                   obj
- 9 CProc |                                   obj						
-10 IProc |                                   obj
-13 TProc | mthno						0/1		          obj	(0 = normal / 1 = super call)
-14 Ind	 | off		 xreg		 scale		Reg	      	(ea = Reg + off + xreg * scale)
-15 Abs	 | adr		 xreg		 scale				    NIL  (ea = adr + xreg * scale) 
-   Abs	 | off		 xreg		 scale				    obj  (ea = adr(obj) + off + xreg * scale)
-   Abs   | off     len      0                obj  (for constant strings and reals)
-16 Stk	 |																      	(ea = ESP)
-17 Cond	| CC
-18 Reg	 |				(Reg2)						 Reg
-19 DInd	| off		 xreg		 scale		Reg	      	(ea = [Reg + off + xreg * scale])
-
-	tmode	| record tag     array desc
--------------------------------------
-  VarPar | [FP + obj.adr + 4]  [FP + obj.adr]
-  Ind    | [Reg - 4]         [Reg + 8]
-  Con    | Adr(typ.strobj)
-
-*)
-
-	CONST
-		processor* = 10; (* for i386 *)
-		NewLbl* = 0;
-
-	TYPE
-		Label* = INTEGER; (* 0: unassigned, > 0: address, < 0: - (linkadr + linktype * 2^24) *)
-		
-	VAR
-		level*: BYTE;
-		one*: DevCPT.Const;
-
-	CONST
-		(* item base modes (=object modes) *)
-		Var = 1; VarPar = 2; Con = 3; LProc = 6; XProc = 7; CProc = 9; IProc = 10; TProc = 13;
-	
-		(* item modes for i386 (must not overlap item basemodes,	> 13) *)
-		Ind = 14; Abs = 15; Stk = 16; Cond = 17; Reg = 18; DInd = 19;
-	
-		(* structure forms *)
-		Undef = 0; Byte = 1; Bool = 2; Char8 = 3; Int8 = 4; Int16 = 5; Int32 = 6;
-		Real32 = 7; Real64 = 8; Set = 9; String8 = 10; NilTyp = 11; NoTyp = 12;
-		Pointer = 13; ProcTyp = 14; Comp = 15;
-		Char16 = 16; String16 = 17; Int64 = 18; Guid = 23;
-		
-		(* composite structure forms *)
-		Basic = 1; Array = 2; DynArr = 3; Record = 4;
-		
-		(* condition codes *)
-		ccB = 2; ccAE = 3; ccBE = 6; ccA = 7; (* unsigned *)
-		ccL = 12; ccGE = 13; ccLE = 14; ccG = 15; (* signed *)
-		ccE = 4; ccNE = 5; ccS = 8; ccNS = 9; ccO = 0; ccNO = 1;
-		ccAlways = -1; ccNever = -2; ccCall = -3;
-		
-		(* registers *)
-		AX = 0; CX = 1; DX = 2; BX = 3; SP = 4; BP = 5; SI = 6; DI = 7; AH = 4; CH = 5; DH = 6; BH = 7;
-		
-		(* fixup types *)
-		absolute = 100; relative = 101; copy = 102; table = 103; tableend = 104; short = 105;
-		
-		(* system trap numbers *)
-		withTrap = -1; caseTrap = -2; funcTrap = -3; typTrap = -4;
-		recTrap = -5; ranTrap = -6; inxTrap = -7; copyTrap = -8;
-		
-
-	VAR
-		Size: ARRAY 32 OF INTEGER;	(* Size[typ.form] == +/- typ.size *)
-		a1, a2: Item;
-
-
-	PROCEDURE MakeReg* (VAR x: Item; reg: INTEGER; form: BYTE);
-	BEGIN
-		ASSERT((reg >= 0) & (reg < 8));
-		x.mode := Reg; x.reg := reg; x.form := form
-	END MakeReg;
-	
-	PROCEDURE MakeConst* (VAR x: Item; val: INTEGER; form: BYTE);
-	BEGIN
-		x.mode := Con; x.offset := val; x.form := form; x.obj := NIL;
-	END MakeConst;
-
-	PROCEDURE AllocConst* (VAR x: Item; con: DevCPT.Const; form: BYTE);
-		VAR r: REAL; short: SHORTREAL; c: DevCPT.Const; i: INTEGER;
-	BEGIN
-		IF form IN {Real32, Real64} THEN
-			r := con.realval;
-			IF ABS(r) <= MAX(SHORTREAL) THEN
-				short := SHORT(r);
-				IF short = r THEN form := Real32	(* a shortreal can represent the exact value *)
-				ELSE form := Real64	(* use a real *)
-				END
-			ELSE form := Real64	(* use a real *)
-			END
-		ELSIF form IN {String8, String16, Guid} THEN
-			x.index := con.intval2	(* string length *)
-		END;
-		DevCPE.AllocConst(con, form, x.obj, x.offset);
-		x.form := form; x.mode := Abs; x.scale := 0
-	END AllocConst;
-
-	(*******************************************************)
-	
-	PROCEDURE BegStat*; (* general-purpose procedure which is called before each statement *)
-	BEGIN
-	END BegStat;
-
-	PROCEDURE EndStat*; (* general-purpose procedure which is called after each statement *)
-	BEGIN
-	END EndStat;
-
-	(*******************************************************)
-	
-	PROCEDURE SetLabel* (VAR L: Label);
-		VAR link, typ, disp, x: INTEGER; c: SHORTCHAR;
-	BEGIN
-		ASSERT(L <= 0); link := -L;
-		WHILE link # 0 DO
-			typ := link DIV 1000000H; link := link MOD 1000000H;
-			IF typ = short THEN
-				disp := DevCPE.pc - link - 1; ASSERT(disp < 128);
-				DevCPE.PutByte(link, disp); link := 0
-			ELSIF typ = relative THEN
-				x := DevCPE.ThisWord(link); DevCPE.PutWord(link, DevCPE.pc - link - 4); link := x
-			ELSE
-				x := DevCPE.ThisWord(link); DevCPE.PutWord(link, DevCPE.pc + typ * 1000000H); link := x
-			END
-		END;		
-		L := DevCPE.pc;
-		a1.mode := 0; a2.mode := 0
-	END SetLabel;
-	
-
-	(*******************************************************)
-	
-	PROCEDURE GenWord (x: INTEGER);
-	BEGIN
-		DevCPE.GenByte(x); DevCPE.GenByte(x DIV 256)
-	END GenWord;
-
-	PROCEDURE GenDbl (x: INTEGER);
-	BEGIN
-		DevCPE.GenByte(x); DevCPE.GenByte(x DIV 256); DevCPE.GenByte(x DIV 10000H); DevCPE.GenByte(x DIV 1000000H)
-	END GenDbl;
-	
-	PROCEDURE CaseEntry* (tab, from, to: INTEGER);
-		VAR a, e: INTEGER;
-	BEGIN
-		a := tab + 4 * from; e := tab + 4 * to;
-		WHILE a <= e DO
-			DevCPE.PutByte(a, DevCPE.pc);
-			DevCPE.PutByte(a + 1, DevCPE.pc DIV 256);
-			DevCPE.PutByte(a + 2, DevCPE.pc DIV 65536);
-			INC(a, 4)
-		END;
-		a1.mode := 0; a2.mode := 0
-	END CaseEntry;
-
-	PROCEDURE GenLinked (VAR x: Item; type: BYTE);
-		VAR link: DevCPT.LinkList;
-	BEGIN
-		IF x.obj = NIL THEN GenDbl(x.offset)
-		ELSE
-			link := DevCPE.OffsetLink(x.obj, x.offset);
-			IF link # NIL THEN
-				GenDbl(type * 1000000H + link.linkadr MOD 1000000H);
-				link.linkadr := DevCPE.pc - 4
-			ELSE GenDbl(0)
-			END
-		END
-	END GenLinked;
-	
-	PROCEDURE CheckSize (form: BYTE; VAR w: INTEGER);
-	BEGIN
-		IF form IN {Int16, Char16} THEN DevCPE.GenByte(66H); w := 1
-		ELSIF form >= Int32 THEN ASSERT(form IN {Int32, Set, NilTyp, Pointer, ProcTyp}); w := 1
-		ELSE w := 0
-		END
-	END CheckSize;
-	
-	PROCEDURE CheckForm (form: BYTE; VAR mf: INTEGER);
-	BEGIN
-		IF form = Real32 THEN mf := 0
-		ELSIF form = Real64 THEN mf := 4
-		ELSIF form = Int32 THEN mf := 2
-		ELSE ASSERT(form = Int16); mf := 6
-		END
-	END CheckForm;
-	
-	PROCEDURE CheckConst (VAR x: Item; VAR s: INTEGER);
-	BEGIN
-		IF (x.form > Int8) & (x.offset >= -128) & (x.offset < 128) & (x.obj = NIL) THEN s := 2
-		ELSE s := 0
-		END 
-	END CheckConst;
-	
-	PROCEDURE GenConst (VAR x: Item; short: BOOLEAN);
-	BEGIN
-		IF x.obj # NIL THEN GenLinked(x, absolute)
-		ELSIF x.form <= Int8 THEN DevCPE.GenByte(x.offset)
-		ELSIF short & (x.offset >= -128) & (x.offset < 128) THEN DevCPE.GenByte(x.offset)
-		ELSIF x.form IN {Int16, Char16} THEN GenWord(x.offset)
-		ELSE GenDbl(x.offset)
-		END
-	END GenConst;
-	
-	PROCEDURE GenCExt (code: INTEGER; VAR x: Item);
-		VAR disp, mod, base, scale: INTEGER;
-	BEGIN
-		ASSERT(x.mode IN {Reg, Ind, Abs, Stk});
-		ASSERT((code MOD 8 = 0) & (code < 64));
-		disp := x.offset; base := x.reg; scale := x.scale;
-		IF x.mode = Reg THEN mod := 0C0H; scale := 0
-		ELSIF x.mode = Stk THEN base := SP; mod := 0; disp := 0; scale := 0
-		ELSIF x.mode = Abs THEN
-			IF scale = 1 THEN base := x.index; mod := 80H; scale := 0
-			ELSE base := BP; mod := 0
-			END
-		ELSIF (disp = 0) & (base # BP) THEN mod := 0
-		ELSIF (disp >= -128) & (disp < 128) THEN mod := 40H
-		ELSE mod := 80H
-		END;
-		IF scale # 0 THEN
-			DevCPE.GenByte(mod + code + 4); base := base + x.index * 8;
-			IF scale = 8 THEN DevCPE.GenByte(0C0H + base);
-			ELSIF scale = 4 THEN DevCPE.GenByte(80H + base);
-			ELSIF scale = 2 THEN DevCPE.GenByte(40H + base);
-			ELSE ASSERT(scale = 1); DevCPE.GenByte(base);
-			END;
-		ELSE
-			DevCPE.GenByte(mod + code + base);
-			IF (base = SP) & (mod <= 80H) THEN DevCPE.GenByte(24H) END
-		END;
-		IF x.mode = Abs THEN GenLinked(x, absolute)
-		ELSIF mod = 80H THEN GenDbl(disp)
-		ELSIF mod = 40H THEN DevCPE.GenByte(disp)
-		END
-	END GenCExt;
-	
-	PROCEDURE GenDExt (VAR r, x: Item);
-	BEGIN
-		ASSERT(r.mode = Reg);
-		GenCExt(r.reg * 8, x)
-	END GenDExt;
-	
-	(*******************************************************)
-	
-	PROCEDURE GenMove* (VAR from, to: Item);
-		VAR w: INTEGER;
-	BEGIN
-		ASSERT(Size[from.form] = Size[to.form]);
-		IF to.mode = Reg THEN
-			IF from.mode = Con THEN
-				IF to.reg = AX THEN
-
-					IF (a1.mode = Con) & (from.offset = a1.offset) & (from.obj = a1.obj) & (from.form = a1.form) THEN
-						RETURN
-					END;
-
-					a1 := from; a2.mode := 0
-				END;
-				CheckSize(from.form, w);
-				IF (from.offset = 0) & (from.obj = NIL) THEN
-					DevCPE.GenByte(30H + w); DevCPE.GenByte(0C0H + 9 * to.reg) (* XOR r,r *)
-				ELSE
-					DevCPE.GenByte(0B0H + w * 8 + to.reg); GenConst(from, FALSE)
-				END;
-			ELSIF (to.reg = AX) & (from.mode = Abs) & (from.scale = 0) THEN
-
-				IF (a1.mode = Abs) & (from.offset = a1.offset) & (from.obj = a1.obj) & (from.form = a1.form)
-					OR (a2.mode = Abs) & (from.offset = a2.offset) & (from.obj = a2.obj) & (from.form = a2.form) THEN
-					RETURN
-				END;
-
-				a1 := from; a2.mode := 0;
-				CheckSize(from.form, w);
-				DevCPE.GenByte(0A0H + w); GenLinked(from, absolute);
-			ELSIF (from.mode # Reg) OR (from.reg # to.reg) THEN
-				IF to.reg = AX THEN
-					IF (from.mode = Ind) & (from.scale = 0) & ((from.reg = BP) OR (from.reg = BX)) THEN
-
-						IF (a1.mode = Ind) & (from.offset = a1.offset) & (from.reg = a1.reg) & (from.form = a1.form)
-							OR (a2.mode = Ind) & (from.offset = a2.offset) & (from.reg = a2.reg) & (from.form = a2.form) THEN
-							RETURN
-						END;
-
-						a1 := from
-					ELSE a1.mode := 0
-					END;
-					a2.mode := 0
-				END;
-				CheckSize(from.form, w);
-				DevCPE.GenByte(8AH + w); GenDExt(to, from)
-			END 
-		ELSE
-			CheckSize(from.form, w);
-			IF from.mode = Con THEN
-				DevCPE.GenByte(0C6H + w); GenCExt(0, to); GenConst(from, FALSE);
-				a1.mode := 0; a2.mode := 0
-			ELSIF (from.reg = AX) & (to.mode = Abs) & (to.scale = 0) THEN
-				DevCPE.GenByte(0A2H + w); GenLinked(to, absolute);
-				a2 := to
-			ELSE
-				DevCPE.GenByte(88H + w); GenDExt(from, to);
-				IF from.reg = AX THEN
-					IF (to.mode = Ind) & (to.scale = 0) & ((to.reg = BP) OR (to.reg = BX)) THEN a2 := to END
-				ELSE a1.mode := 0; a2.mode := 0
-				END
-			END
-		END
-	END GenMove;
-	
-	PROCEDURE GenExtMove* (VAR from, to: Item);
-		VAR w, op: INTEGER;
-	BEGIN
-		ASSERT(from.mode # Con);
-		IF from.form IN {Byte, Char8, Char16} THEN op := 0B6H (* MOVZX *)
-		ELSE op := 0BEH (* MOVSX *)
-		END;
-		IF from.form IN {Int16, Char16} THEN INC(op) END;
-		DevCPE.GenByte(0FH); DevCPE.GenByte(op); GenDExt(to, from);
-		IF to.reg = AX THEN a1.mode := 0; a2.mode := 0 END
-	END GenExtMove;
-	
-	PROCEDURE GenSignExt* (VAR from, to: Item);
-	BEGIN
-		ASSERT(to.mode = Reg);
-		IF (from.mode = Reg) & (from.reg = AX) & (to.reg = DX) THEN
-			DevCPE.GenByte(99H)	(* cdq *)
-		ELSE
-			GenMove(from, to);	(* mov to, from *)
-			DevCPE.GenByte(0C1H); GenCExt(38H, to); DevCPE.GenByte(31)	(* sar to, 31 *)
-		END
-	END GenSignExt;
-	
-	PROCEDURE GenLoadAdr* (VAR from, to: Item);
-	BEGIN
-		ASSERT(to.form IN {Int32, Pointer, ProcTyp});
-		IF (from.mode = Abs) & (from.scale = 0) THEN
-			DevCPE.GenByte(0B8H + to.reg); GenLinked(from, absolute)
-		ELSIF from.mode = Stk THEN
-			DevCPE.GenByte(89H); GenCExt(SP * 8, to)
-		ELSIF (from.mode # Ind) OR (from.offset # 0) OR (from.scale # 0) THEN
-			DevCPE.GenByte(8DH); GenDExt(to, from)
-		ELSIF from.reg # to.reg THEN
-			DevCPE.GenByte(89H); GenCExt(from.reg * 8, to)
-		ELSE RETURN
-		END;
-		IF to.reg = AX THEN a1.mode := 0; a2.mode := 0 END
-	END GenLoadAdr;
-
-	PROCEDURE GenPush* (VAR src: Item);
-		VAR s: INTEGER;
-	BEGIN
-		IF src.mode = Con THEN
-			ASSERT(src.form >= Int32);
-			CheckConst(src, s); DevCPE.GenByte(68H + s); GenConst(src, TRUE)
-		ELSIF src.mode = Reg THEN
-			ASSERT((src.form >= Int16) OR (src.reg < 4));
-			DevCPE.GenByte(50H + src.reg)
-		ELSE
-			ASSERT(src.form >= Int32);
-			DevCPE.GenByte(0FFH); GenCExt(30H, src)
-		END
-	END GenPush;
-	
-	PROCEDURE GenPop* (VAR dst: Item);
-	BEGIN
-		IF dst.mode = Reg THEN
-			ASSERT((dst.form >= Int16) OR (dst.reg < 4));
-			DevCPE.GenByte(58H + dst.reg);
-			IF dst.reg = AX THEN a1.mode := 0; a2.mode := 0 END
-		ELSE
-			DevCPE.GenByte(08FH); GenCExt(0, dst) 
-		END
-	END GenPop;
-	
-	PROCEDURE GenConOp (op: INTEGER; VAR src, dst: Item);
-		VAR w, s: INTEGER;
-	BEGIN
-		ASSERT(Size[src.form] = Size[dst.form]);
-		CheckSize(src.form, w);
-		CheckConst(src, s);
-		IF (dst.mode = Reg) & (dst.reg = AX) & (s = 0) THEN
-			DevCPE.GenByte(op + 4 + w); GenConst(src, FALSE)
-		ELSE
-			DevCPE.GenByte(80H + s + w); GenCExt(op, dst); GenConst(src, TRUE)
-		END
-	END GenConOp;
-	
-	PROCEDURE GenDirOp (op: INTEGER; VAR src, dst: Item);
-		VAR w: INTEGER;
-	BEGIN
-		ASSERT(Size[src.form] = Size[dst.form]);
-		CheckSize(src.form, w);
-		IF dst.mode = Reg THEN
-			DevCPE.GenByte(op + 2 + w); GenDExt(dst, src)
-		ELSE
-			DevCPE.GenByte(op + w); GenDExt(src, dst)
-		END
-	END GenDirOp;
-
-	PROCEDURE GenAdd* (VAR src, dst: Item; ovflchk: BOOLEAN);
-		VAR w: INTEGER;
-	BEGIN
-		ASSERT(Size[src.form] = Size[dst.form]);
-		IF src.mode = Con THEN
-			IF src.obj = NIL THEN
-				IF src.offset = 1 THEN
-					IF (dst.mode = Reg) & (dst.form >= Int32) THEN DevCPE.GenByte(40H + dst.reg) (* inc *)
-					ELSE CheckSize(dst.form, w); DevCPE.GenByte(0FEH + w); GenCExt(0, dst)
-					END
-				ELSIF src.offset = -1 THEN
-					IF (dst.mode = Reg) & (dst.form >= Int32) THEN DevCPE.GenByte(48H + dst.reg) (* dec *)
-					ELSE CheckSize(dst.form, w); DevCPE.GenByte(0FEH + w); GenCExt(8, dst)
-					END
-				ELSIF src.offset # 0 THEN
-					GenConOp(0, src, dst)
-				ELSE RETURN
-				END
-			ELSE
-				GenConOp(0, src, dst)
-			END
-		ELSE
-			GenDirOp(0, src, dst)
-		END;
-		IF ovflchk THEN DevCPE.GenByte(0CEH) END;
-		IF (dst.mode # Reg) OR (dst.reg = AX) THEN a1.mode := 0; a2.mode := 0 END
-	END GenAdd;
-	
-	PROCEDURE GenAddC* (VAR src, dst: Item; first, ovflchk: BOOLEAN);
-		VAR op: INTEGER;
-	BEGIN
-		ASSERT(Size[src.form] = Size[dst.form]);
-		IF first THEN op := 0 ELSE op := 10H END;
-		IF src.mode = Con THEN GenConOp(op, src, dst)
-		ELSE GenDirOp(op, src, dst)
-		END;
-		IF ovflchk THEN DevCPE.GenByte(0CEH) END;
-		IF (dst.mode # Reg) OR (dst.reg = AX) THEN a1.mode := 0; a2.mode := 0 END
-	END GenAddC;
-	
-	PROCEDURE GenSub* (VAR src, dst: Item; ovflchk: BOOLEAN);
-		VAR w: INTEGER;
-	BEGIN
-		ASSERT(Size[src.form] = Size[dst.form]);
-		IF src.mode = Con THEN
-			IF src.obj = NIL THEN
-				IF src.offset = 1 THEN
-					IF (dst.mode = Reg) & (dst.form >= Int32) THEN DevCPE.GenByte(48H + dst.reg) (* dec *)
-					ELSE CheckSize(dst.form, w); DevCPE.GenByte(0FEH + w); GenCExt(8, dst)
-					END
-				ELSIF src.offset = -1 THEN
-					IF (dst.mode = Reg) & (dst.form >= Int32) THEN DevCPE.GenByte(40H + dst.reg) (* inc *)
-					ELSE CheckSize(dst.form, w); DevCPE.GenByte(0FEH + w); GenCExt(0, dst)
-					END
-				ELSIF src.offset # 0 THEN
-					GenConOp(28H, src, dst)
-				ELSE RETURN
-				END
-			ELSE
-				GenConOp(28H, src, dst)
-			END
-		ELSE
-			GenDirOp(28H, src, dst)
-		END;
-		IF ovflchk THEN DevCPE.GenByte(0CEH) END;
-		IF (dst.mode # Reg) OR (dst.reg = AX) THEN a1.mode := 0; a2.mode := 0 END
-	END GenSub;
-
-	PROCEDURE GenSubC* (VAR src, dst: Item; first, ovflchk: BOOLEAN);
-		VAR op: INTEGER;
-	BEGIN
-		ASSERT(Size[src.form] = Size[dst.form]);
-		IF first THEN op := 28H ELSE op := 18H END;
-		IF src.mode = Con THEN GenConOp(op, src, dst)
-		ELSE GenDirOp(op, src, dst)
-		END;
-		IF ovflchk THEN DevCPE.GenByte(0CEH) END;
-		IF (dst.mode # Reg) OR (dst.reg = AX) THEN a1.mode := 0; a2.mode := 0 END
-	END GenSubC;
-
-	PROCEDURE GenComp* (VAR src, dst: Item);
-		VAR w: INTEGER;
-	BEGIN
-		IF src.mode = Con THEN
-			IF (src.offset = 0) & (src.obj = NIL) & (dst.mode = Reg) THEN 
-				CheckSize(dst.form, w); DevCPE.GenByte(8 + w); DevCPE.GenByte(0C0H + 9 * dst.reg) (* or r,r *)
-			ELSE GenConOp(38H, src, dst)
-			END
-		ELSE
-			GenDirOp(38H, src, dst)
-		END
-	END GenComp;
-	
-	PROCEDURE GenAnd* (VAR src, dst: Item);
-	BEGIN
-		IF src.mode = Con THEN
-			IF (src.obj # NIL) OR (src.offset # -1) THEN GenConOp(20H, src, dst) END
-		ELSE GenDirOp(20H, src, dst)
-		END;
-		IF (dst.mode # Reg) OR (dst.reg = AX) THEN a1.mode := 0; a2.mode := 0 END
-	END GenAnd;
-	
-	PROCEDURE GenOr* (VAR src, dst: Item);
-	BEGIN
-		IF src.mode = Con THEN
-			IF (src.obj # NIL) OR (src.offset # 0) THEN GenConOp(8H, src, dst) END
-		ELSE GenDirOp(8H, src, dst)
-		END;
-		IF (dst.mode # Reg) OR (dst.reg = AX) THEN a1.mode := 0; a2.mode := 0 END
-	END GenOr;
-	
-	PROCEDURE GenXor* (VAR src, dst: Item);
-	BEGIN
-		IF src.mode = Con THEN
-			IF (src.obj # NIL) OR (src.offset # 0) THEN GenConOp(30H, src, dst) END
-		ELSE GenDirOp(30H, src, dst)
-		END;
-		IF (dst.mode # Reg) OR (dst.reg = AX) THEN a1.mode := 0; a2.mode := 0 END
-	END GenXor;
-	
-	PROCEDURE GenTest* (VAR x, y: Item);
-		VAR w: INTEGER;
-	BEGIN
-		ASSERT(Size[x.form] = Size[y.form]);
-		CheckSize(x.form, w);
-		IF x.mode = Con THEN
-			IF (x.mode = Reg) & (x.reg = AX) THEN
-				DevCPE.GenByte(0A8H + w); GenConst(x, FALSE)
-			ELSE
-				DevCPE.GenByte(0F6H + w); GenCExt(0, y); GenConst(x, FALSE)
-			END
-		ELSE
-			DevCPE.GenByte(84H + w);
-			IF y.mode = Reg THEN GenDExt(y, x) ELSE GenDExt(x, y) END
-		END
-	END GenTest;
-	
-	PROCEDURE GenNeg* (VAR dst: Item; ovflchk: BOOLEAN);
-		VAR w: INTEGER;
-	BEGIN
-		CheckSize(dst.form, w); DevCPE.GenByte(0F6H + w); GenCExt(18H, dst);
-		IF ovflchk THEN DevCPE.GenByte(0CEH) END;
-		IF (dst.mode # Reg) OR (dst.reg = AX) THEN a1.mode := 0; a2.mode := 0 END
-	END GenNeg;
-	
-	PROCEDURE GenNot* (VAR dst: Item);
-		VAR w: INTEGER;
-	BEGIN
-		CheckSize(dst.form, w); DevCPE.GenByte(0F6H + w); GenCExt(10H, dst);
-		IF (dst.mode # Reg) OR (dst.reg = AX) THEN a1.mode := 0; a2.mode := 0 END
-	END GenNot;
-	
-	PROCEDURE GenMul* (VAR src, dst: Item; ovflchk: BOOLEAN);
-		VAR w, s, val, f2, f5, f9: INTEGER;
-	BEGIN
-		ASSERT((dst.mode = Reg) & (Size[src.form] = Size[dst.form]));
-		IF (src.mode = Con) & (src.offset = 1) THEN RETURN END;
-		IF src.form <= Int8 THEN
-			ASSERT(dst.reg = 0);
-			DevCPE.GenByte(0F6H); GenCExt(28H, src)
-		ELSIF src.mode = Con THEN
-			val := src.offset;
-			IF (src.obj = NIL) & (val # 0) & ~ovflchk THEN
-				f2 := 0; f5 := 0; f9 := 0;
-				WHILE ~ODD(val) DO val := val DIV 2; INC(f2) END;
-				WHILE val MOD 9 = 0 DO val := val DIV 9; INC(f9) END;
-				WHILE val MOD 5 = 0 DO val := val DIV 5; INC(f5) END;
-				IF ABS(val) <= 3 THEN
-					WHILE f9 > 0 DO
-						DevCPE.GenByte(8DH);
-						DevCPE.GenByte(dst.reg * 8 + 4);
-						DevCPE.GenByte(0C0H + dst.reg * 9);
-						DEC(f9)
-					END;
-					WHILE f5 > 0 DO
-						DevCPE.GenByte(8DH);
-						DevCPE.GenByte(dst.reg * 8 + 4);
-						DevCPE.GenByte(80H + dst.reg * 9);
-						DEC(f5)
-					END;
-					IF ABS(val) = 3 THEN
-						DevCPE.GenByte(8DH); DevCPE.GenByte(dst.reg * 8 + 4); DevCPE.GenByte(40H + dst.reg * 9)
-					END;
-					IF f2 > 1 THEN DevCPE.GenByte(0C1H); DevCPE.GenByte(0E0H + dst.reg); DevCPE.GenByte(f2)
-					ELSIF f2 = 1 THEN DevCPE.GenByte(1); DevCPE.GenByte(0C0H + dst.reg * 9)
-					END;
-					IF val < 0 THEN DevCPE.GenByte(0F7H); GenCExt(18H, dst) END;
-					IF dst.reg = AX THEN a1.mode := 0; a2.mode := 0 END;
-					RETURN
-				END
-			END;
-			CheckSize(src.form, w); CheckConst(src, s);
-			DevCPE.GenByte(69H + s); GenDExt(dst, dst); GenConst(src, TRUE)
-		ELSE
-			CheckSize(src.form, w);
-			DevCPE.GenByte(0FH); DevCPE.GenByte(0AFH); GenDExt(dst, src)
-		END;
-		IF ovflchk THEN DevCPE.GenByte(0CEH) END;
-		IF dst.reg = AX THEN a1.mode := 0; a2.mode := 0 END
-	END GenMul;
-	
-	PROCEDURE GenDiv* (VAR src: Item; mod, pos: BOOLEAN);
-		VAR w, rem: INTEGER;
-	BEGIN
-		ASSERT(src.mode = Reg);
-		IF src.form >= Int32 THEN DevCPE.GenByte(99H) (* cdq *)
-		ELSIF src.form = Int16 THEN DevCPE.GenByte(66H); DevCPE.GenByte(99H) (* cwd *)
-		ELSE DevCPE.GenByte(66H); DevCPE.GenByte(98H) (* cbw *)
-		END;
-		CheckSize(src.form, w); DevCPE.GenByte(0F6H + w); GenCExt(38H, src); (* idiv src *)
-		IF src.form > Int8 THEN rem := 2 (* edx *) ELSE rem := 4 (* ah *) END;
-		IF pos THEN (* src > 0 *)
-			CheckSize(src.form, w); DevCPE.GenByte(8 + w); DevCPE.GenByte(0C0H + 9 * rem); (* or rem,rem *)
-			IF mod THEN
-				DevCPE.GenByte(79H); DevCPE.GenByte(2);	(* jns end *)
-				DevCPE.GenByte(2 + w); GenCExt(8 * rem, src); (* add rem,src *)
-			ELSE
-				DevCPE.GenByte(79H); DevCPE.GenByte(1);	(* jns end *)
-				DevCPE.GenByte(48H);					(* dec eax *)
-			END
-		ELSE
-			CheckSize(src.form, w); DevCPE.GenByte(30H + w); GenCExt(8 * rem, src); (* xor src,rem *)
-			IF mod THEN
-				DevCPE.GenByte(79H);	(* jns end *)
-				IF src.form = Int16 THEN DevCPE.GenByte(9); DevCPE.GenByte(66H) ELSE DevCPE.GenByte(8) END;
-				DevCPE.GenByte(8 + w); DevCPE.GenByte(0C0H + 9 * rem); (* or rem,rem *)
-				DevCPE.GenByte(74H); DevCPE.GenByte(4);	(* je end *)
-				DevCPE.GenByte(30H + w); GenCExt(8 * rem, src); (* xor src,rem *)
-				DevCPE.GenByte(2 + w); GenCExt(8 * rem, src); (* add rem,src *)
-			ELSE
-				DevCPE.GenByte(79H);	(* jns end *)
-				IF src.form = Int16 THEN DevCPE.GenByte(6); DevCPE.GenByte(66H) ELSE DevCPE.GenByte(5) END;
-				DevCPE.GenByte(8 + w); DevCPE.GenByte(0C0H + 9 * rem); (* or rem,rem *)
-				DevCPE.GenByte(74H); DevCPE.GenByte(1);	(* je end *)
-				DevCPE.GenByte(48H);					(* dec eax *)
-			END
-(*
-			CheckSize(src.form, w); DevCPE.GenByte(3AH + w); GenCExt(8 * rem, src); (* cmp rem,src *)
-			IF mod THEN
-				DevCPE.GenByte(72H); DevCPE.GenByte(4);	(* jb end *)
-				DevCPE.GenByte(7FH); DevCPE.GenByte(2);	(* jg end *)
-				DevCPE.GenByte(2 + w); GenCExt(8 * rem, src); (* add rem,src *)
-			ELSE
-				DevCPE.GenByte(72H); DevCPE.GenByte(3);	(* jb end *)
-				DevCPE.GenByte(7FH); DevCPE.GenByte(1);	(* jg end *)
-				DevCPE.GenByte(48H);					(* dec eax *)
-			END
-*)
-		END;
-		a1.mode := 0; a2.mode := 0
-	END GenDiv;
-
-	PROCEDURE GenShiftOp* (op: INTEGER; VAR cnt, dst: Item);
-		VAR w: INTEGER;
-	BEGIN
-		CheckSize(dst.form, w);
-		IF cnt.mode = Con THEN
-			ASSERT(cnt.offset >= 0); ASSERT(cnt.obj = NIL);
-			IF cnt.offset = 1 THEN
-				IF (op = 10H) & (dst.mode = Reg) THEN (* shl r *)
-					DevCPE.GenByte(w); GenDExt(dst, dst) (* add r, r *)
-				ELSE
-					DevCPE.GenByte(0D0H + w); GenCExt(op, dst)
-				END
-			ELSIF cnt.offset > 1 THEN
-				DevCPE.GenByte(0C0H + w); GenCExt(op, dst); DevCPE.GenByte(cnt.offset)
-			END
-		ELSE
-			ASSERT((cnt.mode = Reg) & (cnt.reg = CX));
-			DevCPE.GenByte(0D2H + w); GenCExt(op, dst)
-		END;
-		IF (dst.mode # Reg) OR (dst.reg = AX) THEN a1.mode := 0; a2.mode := 0 END
-	END GenShiftOp;
-	
-	PROCEDURE GenBitOp* (op: INTEGER; VAR num, dst: Item);
-	BEGIN
-		DevCPE.GenByte(0FH);
-		IF num.mode = Con THEN
-			ASSERT(num.obj = NIL);
-			DevCPE.GenByte(0BAH); GenCExt(op, dst); DevCPE.GenByte(num.offset)
-		ELSE
-			ASSERT((num.mode = Reg) & (num.form = Int32));
-			DevCPE.GenByte(83H + op); GenDExt(num, dst)
-		END;
-		IF (dst.mode # Reg) OR (dst.reg = AX) THEN a1.mode := 0; a2.mode := 0 END
-	END GenBitOp;
-	
-	PROCEDURE GenSetCC* (cc: INTEGER; VAR dst: Item);
-	BEGIN
-		ASSERT((dst.form = Bool) & (cc >= 0));
-		DevCPE.GenByte(0FH); DevCPE.GenByte(90H + cc); GenCExt(0, dst);
-		IF (dst.mode # Reg) OR (dst.reg = AX) THEN a1.mode := 0; a2.mode := 0 END
-	END GenSetCC;
-	
-	PROCEDURE GenFLoad* (VAR src: Item);
-		VAR mf: INTEGER;
-	BEGIN
-		IF src.mode = Con THEN (* predefined constants *)
-			DevCPE.GenByte(0D9H); DevCPE.GenByte(0E8H + src.offset)
-		ELSIF src.form = Int64 THEN
-			DevCPE.GenByte(0DFH); GenCExt(28H, src)
-		ELSE
-			CheckForm(src.form, mf);
-			DevCPE.GenByte(0D9H + mf); GenCExt(0, src)
-		END
-	END GenFLoad;
-	
-	PROCEDURE GenFStore* (VAR dst: Item; pop: BOOLEAN);
-		VAR mf: INTEGER;
-	BEGIN
-		IF dst.form = Int64 THEN ASSERT(pop);
-			DevCPE.GenByte(0DFH); GenCExt(38H, dst); DevCPE.GenByte(9BH)	(* wait *)
-		ELSE
-			CheckForm(dst.form, mf); DevCPE.GenByte(0D9H + mf);
-			IF pop THEN GenCExt(18H, dst); DevCPE.GenByte(9BH)	(* wait *)
-			ELSE GenCExt(10H, dst)
-			END
-		END;
-		a1.mode := 0; a2.mode := 0
-	END GenFStore;
-	
-	PROCEDURE GenFDOp* (op: INTEGER; VAR src: Item);
-		VAR mf: INTEGER;
-	BEGIN
-		IF src.mode = Reg THEN
-			DevCPE.GenByte(0DEH); DevCPE.GenByte(0C1H + op)
-		ELSE
-			CheckForm(src.form, mf);
-			DevCPE.GenByte(0D8H + mf); GenCExt(op, src)
-		END
-	END GenFDOp;
-	
-	PROCEDURE GenFMOp* (op: INTEGER);
-	BEGIN
-		DevCPE.GenByte(0D8H + op DIV 256);
-		DevCPE.GenByte(op MOD 256);
-		IF op = 07E0H THEN a1.mode := 0; a2.mode := 0 END	(* FSTSW AX *)
-	END GenFMOp;
-	
-	PROCEDURE GenJump* (cc: INTEGER; VAR L: Label; shortjmp: BOOLEAN);
-	BEGIN
-		IF cc # ccNever THEN
-			IF shortjmp OR (L > 0) & (DevCPE.pc + 2 - L <= 128) & (cc # ccCall) THEN
-				IF cc = ccAlways THEN DevCPE.GenByte(0EBH)
-				ELSE DevCPE.GenByte(70H + cc)
-				END;
-				IF L > 0 THEN DevCPE.GenByte(L - DevCPE.pc - 1)
-				ELSE ASSERT(L = 0); L := -(DevCPE.pc + short * 1000000H); DevCPE.GenByte(0)
-				END
-			ELSE
-				IF cc = ccAlways THEN DevCPE.GenByte(0E9H)
-				ELSIF cc = ccCall THEN DevCPE.GenByte(0E8H)
-				ELSE DevCPE.GenByte(0FH); DevCPE.GenByte(80H + cc)
-				END;
-				IF L > 0 THEN GenDbl(L - DevCPE.pc - 4)
-				ELSE GenDbl(-L); L := -(DevCPE.pc - 4 + relative * 1000000H)
-				END
-			END
-		END
-	END GenJump;
-	
-	PROCEDURE GenExtJump* (cc: INTEGER; VAR dst: Item);
-	BEGIN
-		IF cc = ccAlways THEN DevCPE.GenByte(0E9H)
-		ELSE DevCPE.GenByte(0FH); DevCPE.GenByte(80H + cc)
-		END;
-		dst.offset := 0; GenLinked(dst, relative)
-	END GenExtJump;
-	
-	PROCEDURE GenIndJump* (VAR dst: Item);
-	BEGIN
-		DevCPE.GenByte(0FFH); GenCExt(20H, dst)
-	END GenIndJump;
-	
-	PROCEDURE GenCaseJump* (VAR src: Item);
-		VAR link: DevCPT.LinkList; tab: INTEGER;
-	BEGIN
-		ASSERT((src.form = Int32) & (src.mode = Reg));
-		DevCPE.GenByte(0FFH); DevCPE.GenByte(24H); DevCPE.GenByte(85H + 8 * src.reg);
-		tab := (DevCPE.pc + 7) DIV 4 * 4;
-		NEW(link); link.offset := tab; link.linkadr := DevCPE.pc;
-		link.next := DevCPE.CaseLinks; DevCPE.CaseLinks := link;
-		GenDbl(absolute * 1000000H + tab);
-		WHILE DevCPE.pc < tab DO DevCPE.GenByte(90H) END;
-	END GenCaseJump;
-(*	
-	PROCEDURE GenCaseJump* (VAR src: Item; num: LONGINT; VAR tab: LONGINT);
-		VAR link: DevCPT.LinkList; else, last: LONGINT;
-	BEGIN
-		ASSERT((src.form = Int32) & (src.mode = Reg));
-		DevCPE.GenByte(0FFH); DevCPE.GenByte(24H); DevCPE.GenByte(85H + 8 * src.reg);
-		tab := (DevCPE.pc + 7) DIV 4 * 4;
-		else := tab + num * 4; last := else - 4;
-		NEW(link); link.offset := tab; link.linkadr := DevCPE.pc;
-		link.next := CaseLinks; CaseLinks := link;
-		GenDbl(absolute * 1000000H + tab);
-		WHILE DevCPE.pc < tab DO DevCPE.GenByte(90H) END;
-		WHILE DevCPE.pc < last DO GenDbl(table * 1000000H + else) END;
-		GenDbl(tableend * 1000000H + else)
-	END GenCaseJump;
-*)	
-	PROCEDURE GenCaseEntry* (VAR L: Label; last: BOOLEAN);
-		VAR typ: INTEGER;
-	BEGIN
-		IF last THEN typ := tableend * 1000000H ELSE typ := table * 1000000H END;
-		IF L > 0 THEN GenDbl(L + typ) ELSE GenDbl(-L); L := -(DevCPE.pc - 4 + typ) END
-	END GenCaseEntry;
-	
-	PROCEDURE GenCall* (VAR dst: Item);
-	BEGIN
-		IF dst.mode IN {LProc, XProc, IProc} THEN
-			DevCPE.GenByte(0E8H);
-			IF dst.obj.mnolev >= 0 THEN (* local *)
-				IF dst.obj.adr > 0 THEN GenDbl(dst.obj.adr - DevCPE.pc - 4)
-				ELSE GenDbl(-dst.obj.adr); dst.obj.adr := -(DevCPE.pc - 4 + relative * 1000000H)
-				END
-			ELSE (* imported *)
-				dst.offset := 0; GenLinked(dst, relative)
-			END
-		ELSE DevCPE.GenByte(0FFH); GenCExt(10H, dst)
-		END;
-		a1.mode := 0; a2.mode := 0
-	END GenCall;
-	
-	PROCEDURE GenAssert* (cc, no: INTEGER);
-	BEGIN
-		IF cc # ccAlways THEN
-			IF cc >= 0 THEN
-				DevCPE.GenByte(70H + cc); (* jcc end *)
-				IF no < 0 THEN DevCPE.GenByte(2) ELSE DevCPE.GenByte(3) END
-			END;
-			IF no < 0 THEN
-				DevCPE.GenByte(8DH); DevCPE.GenByte(0E0H - no)
-			ELSE
-				DevCPE.GenByte(8DH); DevCPE.GenByte(0F0H); DevCPE.GenByte(no)
-			END
-		END
-	END GenAssert;
-	
-	PROCEDURE GenReturn* (val: INTEGER);
-	BEGIN
-		IF val = 0 THEN DevCPE.GenByte(0C3H)
-		ELSE DevCPE.GenByte(0C2H); GenWord(val)
-		END;
-		a1.mode := 0; a2.mode := 0
-	END GenReturn;
-	
-	PROCEDURE LoadStr (size: INTEGER);
-	BEGIN
-		IF size = 2 THEN DevCPE.GenByte(66H) END;
-		IF size <= 1 THEN DevCPE.GenByte(0ACH) ELSE DevCPE.GenByte(0ADH) END (* lods *)
-	END LoadStr;
-	
-	PROCEDURE StoreStr (size: INTEGER);
-	BEGIN
-		IF size = 2 THEN DevCPE.GenByte(66H) END;
-		IF size <= 1 THEN DevCPE.GenByte(0AAH) ELSE DevCPE.GenByte(0ABH) END (* stos *)
-	END StoreStr;
-	
-	PROCEDURE ScanStr (size: INTEGER; rep: BOOLEAN);
-	BEGIN
-		IF size = 2 THEN DevCPE.GenByte(66H) END;
-		IF rep THEN DevCPE.GenByte(0F2H) END;
-		IF size <= 1 THEN DevCPE.GenByte(0AEH) ELSE DevCPE.GenByte(0AFH) END (* scas *)
-	END ScanStr;
-	
-	PROCEDURE TestNull (size: INTEGER);
-	BEGIN
-		IF size = 2 THEN DevCPE.GenByte(66H) END;
-		IF size <= 1 THEN DevCPE.GenByte(8); DevCPE.GenByte(0C0H); (* or al,al *)
-		ELSE DevCPE.GenByte(9); DevCPE.GenByte(0C0H); (* or ax,ax *)
-		END
-	END TestNull;
-	
-	PROCEDURE GenBlockMove* (wsize, len: INTEGER);	(* len = 0: len in ECX *)
-		VAR w: INTEGER;
-	BEGIN
-		IF len = 0 THEN (* variable size move *)
-			IF wsize = 4 THEN w := 1 ELSIF wsize = 2 THEN w := 1; DevCPE.GenByte(66H) ELSE w := 0 END;
-			DevCPE.GenByte(0F3H); DevCPE.GenByte(0A4H + w); (* rep:movs *)
-		ELSE (* fixed size move *)
-			len := len * wsize;
-			IF len >= 16 THEN
-				DevCPE.GenByte(0B9H); GenDbl(len DIV 4); (* ld ecx,len/4 *)
-				DevCPE.GenByte(0F3H); DevCPE.GenByte(0A5H); (* rep:movs long*)
-				len := len MOD 4
-			END;
-			WHILE len >= 4 DO DevCPE.GenByte(0A5H); DEC(len, 4) END; (* movs long *);
-			IF len >= 2 THEN DevCPE.GenByte(66H); DevCPE.GenByte(0A5H) END; (* movs word *);
-			IF ODD(len) THEN DevCPE.GenByte(0A4H) END; (* movs byte *)
-		END
-	END GenBlockMove;
-	
-	PROCEDURE GenBlockStore* (wsize, len: INTEGER);	(* len = 0: len in ECX *)
-		VAR w: INTEGER;
-	BEGIN
-		IF len = 0 THEN (* variable size move *)
-			IF wsize = 4 THEN w := 1 ELSIF wsize = 2 THEN w := 1; DevCPE.GenByte(66H) ELSE w := 0 END;
-			DevCPE.GenByte(0F3H); DevCPE.GenByte(0AAH + w); (* rep:stos *)
-		ELSE (* fixed size move *)
-			len := len * wsize;
-			IF len >= 16 THEN
-				DevCPE.GenByte(0B9H); GenDbl(len DIV 4); (* ld ecx,len/4 *)
-				DevCPE.GenByte(0F3H); DevCPE.GenByte(0ABH); (* rep:stos long*)
-				len := len MOD 4
-			END;
-			WHILE len >= 4 DO DevCPE.GenByte(0ABH); DEC(len, 4) END; (* stos long *);
-			IF len >= 2 THEN DevCPE.GenByte(66H); DevCPE.GenByte(0ABH) END; (* stos word *);
-			IF ODD(len) THEN DevCPE.GenByte(0ABH) END; (* stos byte *)
-		END
-	END GenBlockStore;
-	
-	PROCEDURE GenBlockComp* (wsize, len: INTEGER);	(* len = 0: len in ECX *)
-		VAR w: INTEGER;
-	BEGIN
-		ASSERT(len >= 0);
-		IF len > 0 THEN DevCPE.GenByte(0B9H); GenDbl(len) END; (* ld ecx,len *)
-		IF wsize = 4 THEN w := 1 ELSIF wsize = 2 THEN w := 1; DevCPE.GenByte(66H) ELSE w := 0 END;
-		DevCPE.GenByte(0F3H); DevCPE.GenByte(0A6H + w) (* repe:cmps *)
-	END GenBlockComp;
-	
-	PROCEDURE GenStringMove* (excl: BOOLEAN; wsize, dsize, len: INTEGER);
-	(*
-	len = 0: len in ECX, len = -1: len undefined; wsize # dsize -> convert; size = 0: opsize = 1, incsize = 2; excl: don't move 0X
-	*)
-		VAR loop, end: Label;
-	BEGIN
-		IF len > 0 THEN DevCPE.GenByte(0B9H); GenDbl(len) END; (* ld ecx,len *)
-		(* len >= 0: len IN ECX *)
-		IF (dsize = 2) & (wsize < 2) THEN DevCPE.GenByte(31H); DevCPE.GenByte(0C0H) END; (* xor eax,eax *)
-		loop := NewLbl; end := NewLbl;
-		SetLabel(loop); LoadStr(wsize);
-		IF wsize = 0 THEN DevCPE.GenByte(46H) END; (* inc esi *)
-		IF len < 0 THEN (* no limit *)
-			StoreStr(dsize); TestNull(wsize); GenJump(ccNE, loop, TRUE);
-			IF excl THEN (* dec edi *)
-				DevCPE.GenByte(4FH);
-				IF dsize # 1 THEN DevCPE.GenByte(4FH) END
-			END;
-		ELSE	(* cx limit *)
-			IF excl THEN TestNull(wsize); GenJump(ccE, end, TRUE); StoreStr(dsize)
-			ELSE StoreStr(dsize); TestNull(wsize); GenJump(ccE, end, TRUE)
-			END;
-			DevCPE.GenByte(49H); (* dec ecx *)
-			GenJump(ccNE, loop, TRUE);
-			GenAssert(ccNever, copyTrap); (* trap *)
-			SetLabel(end)
-		END;
-		a1.mode := 0; a2.mode := 0
-	END GenStringMove;
-	
-	PROCEDURE GenStringComp* (wsize, dsize: INTEGER);
-	(* wsize # dsize -> convert; size = 0: opsize = 1, incsize = 2; *)
-		VAR loop, end: Label;
-	BEGIN
-		IF (dsize = 2) & (wsize < 2) THEN DevCPE.GenByte(31H); DevCPE.GenByte(0C0H); (* xor eax,eax *) END;
-		loop := NewLbl; end := NewLbl;
-		SetLabel(loop); LoadStr(wsize);
-		IF wsize = 0 THEN DevCPE.GenByte(46H) END; (* inc esi *)
-		ScanStr(dsize, FALSE); GenJump(ccNE, end, TRUE);
-		IF dsize = 0 THEN DevCPE.GenByte(47H) END; (* inc edi *)
-		TestNull(wsize); GenJump(ccNE, loop, TRUE);
-		SetLabel(end);
-		a1.mode := 0; a2.mode := 0
-	END GenStringComp;
-
-	PROCEDURE GenStringLength* (wsize, len: INTEGER);	(* len = 0: len in ECX, len = -1: len undefined *)
-	BEGIN
-		DevCPE.GenByte(31H); DevCPE.GenByte(0C0H); (* xor eax,eax *)
-		IF len # 0 THEN DevCPE.GenByte(0B9H); GenDbl(len) END; (* ld ecx,len *)
-		ScanStr(wsize, TRUE);
-		a1.mode := 0; a2.mode := 0
-	END GenStringLength;
-	
-	PROCEDURE GenStrStore* (size: INTEGER);
-		VAR w: INTEGER;
-	BEGIN
-		IF size # 0 THEN
-			IF size MOD 4 = 0 THEN w := 1; size := size DIV 4
-			ELSIF size MOD 2 = 0 THEN w := 2; size := size DIV 2
-			ELSE w := 0
-			END;
-			DevCPE.GenByte(0B9H); GenDbl(size); (* ld ecx,size *)
-			IF w = 2 THEN DevCPE.GenByte(66H); w := 1 END
-		ELSE w := 0
-		END;
-		DevCPE.GenByte(0F3H); DevCPE.GenByte(0AAH + w); (* rep:stos *)
-		a1.mode := 0; a2.mode := 0
-	END GenStrStore;
-
-	PROCEDURE GenCode* (op: INTEGER);
-	BEGIN
-		DevCPE.GenByte(op);
-		a1.mode := 0; a2.mode := 0
-	END GenCode;
-
-
-	PROCEDURE Init*(opt: SET);
-	BEGIN
-		DevCPE.Init(processor, opt);
-		level := 0;
-		NEW(one); one.realval := 1.0; one.intval := DevCPM.ConstNotAlloc;
-	END Init;
-
-	PROCEDURE Close*;
-	BEGIN
-		a1.obj := NIL; a1.typ := NIL; a2.obj := NIL; a2.typ := NIL; one := NIL;
-		DevCPE.Close
-	END Close;
-
-BEGIN
-	Size[Undef] := 0;
-	Size[Byte] := 1;
-	Size[Bool] := 1;
-	Size[Char8] := 1;
-	Size[Int8] := 1;
-	Size[Int16] := 2;
-	Size[Int32] := 4;
-	Size[Real32] := -4;
-	Size[Real64] := -8;
-	Size[Set] := 4;
-	Size[String8] := 0;
-	Size[NilTyp] := 4;
-	Size[NoTyp] := 0;
-	Size[Pointer] := 4;
-	Size[ProcTyp] := 4;
-	Size[Comp] := 0;
-	Size[Char16] := 2;
-	Size[Int64] := 8;
-	Size[String16] := 0
-END DevCPL486.

BlackBox/Dev/Mod/CPM.txt

@@ -1,853 +0,0 @@
-MODULE DevCPM;
-
-	(* THIS IS TEXT COPY OF BlackBox 1.6-rc6 Dev/Mod/CPM.odc *)
-	(* DO NOT EDIT *)
-
-	IMPORT SYSTEM, Kernel, Files, Stores, Models, Views, TextModels, TextMappers, StdLog, DevMarkers;
-
-	CONST
-		ProcSize* = 4;	(* PROCEDURE type *)
-		PointerSize* = 4;	(* POINTER type *)
-		DArrSizeA* = 8;	(* dyn array descriptor *)
-		DArrSizeB* = 4;	(* size = A + B * typ.n *)
-
-		MaxSet* = 31;
-		MaxIndex* = 7FFFFFFFH;	(* maximal index value for array declaration *)
-
-		MinReal32Pat = 0FF7FFFFFH;	(* most positive, 32-bit pattern *)
-		MinReal64PatL = 0FFFFFFFFH;	(* most  negative, lower 32-bit pattern *)
-		MinReal64PatH = 0FFEFFFFFH;	(* most  negative, higher 32-bit pattern *)
-		MaxReal32Pat = 07F7FFFFFH;	(* most positive, 32-bit pattern *)
-		MaxReal64PatL = 0FFFFFFFFH;	(* most positive, lower 32-bit pattern *)
-		MaxReal64PatH = 07FEFFFFFH;	(* most positive, higher 32-bit pattern *)
-		InfRealPat = 07F800000H;	(* real infinity pattern *)
-
-
-		(* inclusive range of parameter of standard procedure HALT *)
-		MinHaltNr* = 0;
-		MaxHaltNr* = 128;
-
-		(* inclusive range of register number of procedures SYSTEM.GETREG and SYSTEM.PUTREG *)
-		MinRegNr* = 0;
-		MaxRegNr* = 31;
-
-		(* maximal value of flag used to mark interface structures *)
-		MaxSysFlag* = 127;	(* shortint *)
-		CProcFlag* = 1;	(* code procedures *)
-
-		(* maximal condition value of parameter of SYSTEM.CC *)
-		MaxCC* = 15;
-
-		(* initialization of constant address, must be different from any valid constant address *)
-		ConstNotAlloc* = -1;
-
-		(* whether hidden pointer fields have to be nevertheless exported *)
-		ExpHdPtrFld* = TRUE;
-		HdPtrName* = "@ptr";
-
-		(* whether hidden untagged pointer fields have to be nevertheless exported *)
-		ExpHdUtPtrFld* = TRUE;
-		HdUtPtrName* = "@utptr";
-
-		(* whether hidden procedure fields have to be nevertheless exported (may be used for System.Free) *)
-		ExpHdProcFld* = TRUE;
-		HdProcName* = "@proc";
-
-		(* whether hidden bound procedures have to be nevertheless exported *)
-		ExpHdTProc* = FALSE;
-		HdTProcName* = "@tproc";
-
-		(* maximal number of exported stuctures: *)
-		MaxStruct* = 16000;	(* must be < MAX(INTEGER) DIV 2 in object model *)
-		
-		(* maximal number of record extensions: *)
-		MaxExts* = 15;	(* defined by type descriptor layout *)
-		
-		(* whether field leaf of pointer variable p has to be set to FALSE, when NEW(p) or SYSTEM.NEW(p, n) is used *)
-		NEWusingAdr* = FALSE;
-
-		(* special character (< " ") returned by procedure Get, if end of text reached *)
-		Eot* = 0X;
-		
-		(* warnings *)
-		longreal* = 0; largeint* = 1; realConst* = 2; copy* = 3; lchr* = 4; lentier* = 5; invar* = 6; outvar* = 7;
-		
-		(* language options *)
-		interface* = 1;
-		com* = 2; comAware* = 3;
-		som* = 4; somAware* = 5;
-		oberon* = 6;
-		java* = 7; javaAware* = 8;
-		noCode* = 9;
-		allSysVal* = 14;
-		sysImp* = 15;
-		trap* = 31;
-		sys386 = 10; sys68k = 20;	(* processor type in options if system imported *)
-		
-	CONST
-		SFdir = "Sym";
-		OFdir = "Code";
-		SYSdir = "System";
-		SFtag = 6F4F5346H;	(* symbol file tag *)
-		OFtag = 6F4F4346H;	(* object file tag *)
-		maxErrors = 64;
-		
-TYPE
-	File = POINTER TO RECORD next: File; f: Files.File END;
-
-	VAR
-		LEHost*: BOOLEAN;	(* little or big endian host *)
-		MinReal32*, MaxReal32*, InfReal*,
-		MinReal64*, MaxReal64*: REAL;
-		noerr*: BOOLEAN;	(* no error found until now *)
-		curpos*, startpos*, errpos*: INTEGER;	(* character, start, and error position in source file *)
-		searchpos*: INTEGER;	(* search position in source file *)
-		errors*: INTEGER;
-		breakpc*: INTEGER;	(* set by OPV.Init *)
-		options*: SET;	(* language options *)
-		file*: Files.File;	(* used for sym file import *)
-		codeDir*: ARRAY 16 OF CHAR;
-		symDir*: ARRAY 16 OF CHAR;
-		checksum*: INTEGER;	(* symbol file checksum *)
-		
-		lastpos: INTEGER;
-		realpat: INTEGER;
-		lrealpat: RECORD H, L: INTEGER END;
-		fpi, fpj: SHORTINT; fp: ARRAY 4 OF SHORTCHAR;
-		ObjFName: Files.Name;
-
-		in: TextModels.Reader;
-		oldSymFile, symFile, objFile: Files.File;
-		inSym: Files.Reader;
-		outSym, outObj: Files.Writer;
-		
-		errNo, errPos: ARRAY maxErrors OF INTEGER;
-		
-		lineReader: TextModels.Reader;
-		lineNum: INTEGER;
-		
-		crc32tab: ARRAY 256 OF INTEGER;
-
-
-	PROCEDURE^ err* (n: INTEGER);
-
-	PROCEDURE Init* (source: TextModels.Reader; logtext: TextModels.Model);
-	BEGIN
-		in := source;
-		DevMarkers.Unmark(in.Base());
-		noerr := TRUE; options := {};
-		curpos := in.Pos(); errpos := curpos; lastpos := curpos - 11; errors := 0;
-		codeDir := OFdir; symDir := SFdir
-	END Init;
-	
-	PROCEDURE Close*;
-	BEGIN
-		oldSymFile := NIL; inSym := NIL;
-		symFile := NIL; outSym := NIL;
-		objFile := NIL; outObj := NIL;
-		in := NIL; lineReader := NIL
-	END Close;
-
-	PROCEDURE Get* (VAR ch: SHORTCHAR);
-		VAR ch1: CHAR;
-	BEGIN
-		REPEAT in.ReadChar(ch1); INC(curpos) UNTIL (ch1 < 100X) & (ch1 # TextModels.viewcode);
-		ch := SHORT(ch1)
-	END Get;
-	
-	PROCEDURE GetL* (VAR ch: CHAR);
-	BEGIN
-		REPEAT in.ReadChar(ch); INC(curpos) UNTIL ch # TextModels.viewcode;
-	END GetL;
-	
-	PROCEDURE LineOf* (pos: INTEGER): INTEGER;
-		VAR ch: CHAR;
-	BEGIN
-		IF lineReader = NIL THEN lineReader := in.Base().NewReader(NIL); lineReader.SetPos(0); lineNum := 0 END;
-		IF lineReader.Pos() > pos THEN lineReader.SetPos(0); lineNum := 0 END;
-		WHILE lineReader.Pos() < pos DO
-			lineReader.ReadChar(ch);
-			IF ch = 0DX THEN INC(lineNum) END
-		END;
-		RETURN lineNum
-	END LineOf;
-
-	PROCEDURE LoWord (r: REAL): INTEGER;
-		VAR x: INTEGER;
-	BEGIN
-		x := SYSTEM.ADR(r);
-		IF ~LEHost THEN INC(x, 4) END;
-		SYSTEM.GET(x, x);
-		RETURN x
-	END LoWord;
-
-	PROCEDURE HiWord (r: REAL): INTEGER;
-		VAR x: INTEGER;
-	BEGIN
-		x := SYSTEM.ADR(r);
-		IF LEHost THEN INC(x, 4) END;
-		SYSTEM.GET(x, x);
-		RETURN x
-	END HiWord;
-	
-	PROCEDURE Compound (lo, hi: INTEGER): REAL;
-		VAR r: REAL;
-	BEGIN
-		IF LEHost THEN
-			SYSTEM.PUT(SYSTEM.ADR(r), lo); SYSTEM.PUT(SYSTEM.ADR(r) + 4, hi)
-		ELSE
-			SYSTEM.PUT(SYSTEM.ADR(r) + 4, lo); SYSTEM.PUT(SYSTEM.ADR(r), hi)
-		END;
-		RETURN r
-	END Compound;
-
-
-	(* sysflag control *)
-	
-	PROCEDURE ValidGuid* (VAR str: ARRAY OF SHORTCHAR): BOOLEAN;
-		VAR i: SHORTINT; ch: SHORTCHAR;
-	BEGIN
-		IF (LEN(str$) # 38) OR (str[0] # "{") & (str[37] # "}") THEN RETURN FALSE END;
-		i := 1;
-		WHILE i < 37 DO
-			ch := str[i];
-			IF (i = 9) OR (i = 14) OR (i = 19) OR (i = 24) THEN
-				IF ch # "-" THEN RETURN FALSE END
-			ELSE
-				IF (ch < "0") OR (ch > "9") & (CAP(ch) < "A") OR (CAP(ch) > "Z") THEN RETURN FALSE END
-			END;
-			INC(i)
-		END;
-		RETURN TRUE
-	END ValidGuid;
-	
-	PROCEDURE GetProcSysFlag* (id: ARRAY OF SHORTCHAR; num: SHORTINT; VAR flag: SHORTINT);
-	BEGIN
-		IF id # "" THEN
-			IF id = "code" THEN num := 1
-			ELSIF id = "callback" THEN num := 2
-			ELSIF id = "nostkchk" THEN num := 4
-			ELSIF id = "ccall" THEN num := -10
-			ELSIF id = "guarded" THEN num := 8
-			ELSIF id = "noframe" THEN num := 16
-			ELSIF id = "native" THEN num := -33
-			ELSIF id = "bytecode" THEN num := -35
-			END
-		END;
-		IF (options * {sysImp, sys386, sys68k} # {}) & ((num = 1) OR (num = 2)) THEN INC(flag, num)
-		ELSIF (sys68k IN options) & (num = 4) THEN INC(flag, num)
-		ELSIF (options * {sys386, interface} # {}) & (num = -10) & (flag = 0) THEN flag := -10
-		ELSIF (options * {sys386, com} # {}) & (num = 8) & (flag = 0) THEN flag := 8
-		ELSIF (options * {sysImp, sys386} # {}) & (num = 16) & (flag = 0) THEN flag := 16
-		ELSIF ({sysImp, java} - options = {}) & ((num= -33) OR (num = -35)) & (flag = 0) THEN flag := num
-		ELSE err(225); flag := 0
-		END
-	END GetProcSysFlag;
-	
-	PROCEDURE GetVarParSysFlag* (id: ARRAY OF SHORTCHAR; num: SHORTINT; VAR flag: SHORTINT);
-		VAR old: SHORTINT;
-	BEGIN
-		old := flag; flag := 0;
-		IF (options * {sys386, sys68k, interface, com} # {}) THEN
-			IF (num = 1) OR (id = "nil") THEN
-				IF ~ODD(old) THEN flag := SHORT(old + 1) END
-			ELSIF ((num = 2) OR (id = "in")) & (oberon IN options) THEN
-				IF old <= 1 THEN flag := SHORT(old + 2) END
-			ELSIF ((num = 4) OR (id = "out")) & (oberon IN options) THEN
-				IF old <= 1 THEN flag := SHORT(old + 4) END
-			ELSIF ((num = 8) OR (id = "new")) & (options * {com, interface} # {}) THEN
-				IF old <= 1 THEN flag := SHORT(old + 8) END
-			ELSIF ((num = 16) OR (id = "iid")) & (com IN options) THEN
-				IF old <= 1 THEN flag := SHORT(old + 16) END
-			END
-		END;
-		IF flag = 0 THEN err(225) END
-	END GetVarParSysFlag;
-	
-	PROCEDURE GetRecordSysFlag* (id: ARRAY OF SHORTCHAR; num: SHORTINT; VAR flag: SHORTINT);
-		VAR old: SHORTINT;
-	BEGIN
-		old := flag; flag := 0;
-		IF (num = 1) OR (id = "untagged") THEN
-			IF (options * {sysImp, sys386, sys68k, interface, com, som} # {}) & (old = 0) THEN flag := 1 END
-		ELSIF (num = 3) OR (id = "noalign") THEN
-			IF (options * {sys386, sys68k, interface, com, som} # {}) & (old = 0) THEN flag := 3 END
-		ELSIF (num = 4) OR (id = "align2") THEN
-			IF (options * {sys386, interface, com} # {}) & (old = 0) THEN flag := 4 END
-		ELSIF (num = 5) OR (id = "align4") THEN
-			IF (options * {sys386, interface, com} # {}) & (old = 0) THEN flag := 5 END
-		ELSIF (num = 6) OR (id = "align8") THEN
-			IF (options * {sys386, interface, com} # {}) & (old = 0) THEN flag := 6 END
-		ELSIF (num = 7) OR (id = "union") THEN
-			IF (options * {sys386, sys68k, interface, com} # {}) & (old = 0) THEN flag := 7 END
-		ELSIF (num = 10) OR (id = "interface") OR ValidGuid(id) THEN
-			IF (com IN options) & (old = 0) THEN flag := 10 END
-		ELSIF (num = -11) OR (id = "jint") THEN
-			IF (java IN options) & (old = 0) THEN flag := -11 END
-		ELSIF (num = -13) OR (id = "jstr") THEN
-			IF (java IN options) & (old = 0) THEN flag := -13 END
-		ELSIF (num = 20) OR (id = "som") THEN
-			IF (som IN options) & (old = 0) THEN flag := 20 END
-		END;
-		IF flag = 0 THEN err(225) END
-	END GetRecordSysFlag;
-	
-	PROCEDURE GetArraySysFlag* (id: ARRAY OF SHORTCHAR; num: SHORTINT; VAR flag: SHORTINT);
-		VAR old: SHORTINT;
-	BEGIN
-		old := flag; flag := 0;
-		IF (num = 1) OR (id = "untagged") THEN
-			IF (options * {sysImp, sys386, sys68k, interface, com, som} # {}) & (old = 0) THEN flag := 1 END
-		ELSIF (num = -12) OR (id = "jarr") THEN
-			IF (java IN options) & (old = 0) THEN flag := -12 END
-		ELSIF (num = -13) OR (id = "jstr") THEN
-			IF (java IN options) & (old = 0) THEN flag := -13 END
-		END;
-		IF flag = 0 THEN err(225) END
-	END GetArraySysFlag;
-	
-	PROCEDURE GetPointerSysFlag* (id: ARRAY OF SHORTCHAR; num: SHORTINT; VAR flag: SHORTINT);
-		VAR old: SHORTINT;
-	BEGIN
-		old := flag; flag := 0;
-		IF (num = 1) OR (id = "untagged") THEN
-			IF (options * {sys386, sys68k, interface, com, som} # {}) & (old = 0) THEN flag := 1 END
-		ELSIF (num = 2) OR (id = "handle") THEN
-			IF (sys68k IN options) & (old = 0) THEN flag := 2 END
-		ELSIF (num = 10) OR (id = "interface") THEN
-			IF (com IN options) & (old = 0) THEN flag := 10 END
-		ELSIF (num = 20) OR (id = "som") THEN
-			IF (som IN options) & (old = 0) THEN flag := 20 END
-		END;
-		IF flag = 0 THEN err(225) END
-	END GetPointerSysFlag;
-	
-	PROCEDURE GetProcTypSysFlag* (id: ARRAY OF SHORTCHAR; num: SHORTINT; VAR flag: SHORTINT);
-	BEGIN
-		IF ((num = -10) OR (id = "ccall")) & (options * {sys386, interface} # {}) THEN flag := -10
-		ELSE err(225); flag := 0
-		END
-	END GetProcTypSysFlag;
-	
-	PROCEDURE PropagateRecordSysFlag* (baseFlag: SHORTINT; VAR flag: SHORTINT);
-	BEGIN
-		IF (baseFlag = 1) OR (baseFlag >= 3) & (baseFlag <= 7) THEN	(* propagate untagged .. union *)
-			IF flag = 0 THEN flag := baseFlag
-			ELSIF (flag = 6) & (baseFlag < 6) THEN (* OK *)	(* special case for 8 byte aligned records *)
-			ELSIF flag # baseFlag THEN err(225); flag := 0
-			END
-		ELSIF (baseFlag # 10) & (flag = 10) THEN err(225)
-		END
-	END PropagateRecordSysFlag;
-	
-	PROCEDURE PropagateRecPtrSysFlag* (baseFlag: SHORTINT; VAR flag: SHORTINT);
-	BEGIN
-		IF (baseFlag = 1) OR (baseFlag >= 3) & (baseFlag <= 7) THEN	(* pointer to untagged .. union is untagged *)
-			IF flag = 0 THEN flag := 1
-			ELSIF (flag # 1) & (flag # 2) THEN err(225); flag := 0
-			END
-		ELSIF baseFlag = 10 THEN	(* pointer to interface is interface *)
-			IF flag = 0 THEN flag := 10
-			ELSIF flag # 10 THEN err(225); flag := 0
-			END
-		ELSIF baseFlag = -11 THEN	(* pointer to java interface is java interface *)
-			IF flag # 0 THEN err(225) END;
-			flag := -11
-		ELSIF baseFlag = -13 THEN	(* pointer to java string is java string *)
-			IF flag # 0 THEN err(225) END;
-			flag := -13
-		END
-	END PropagateRecPtrSysFlag;
-	
-	PROCEDURE PropagateArrPtrSysFlag* (baseFlag: SHORTINT; VAR flag: SHORTINT);
-	BEGIN
-		IF baseFlag = 1 THEN	(* pointer to untagged or guid is untagged *)
-			IF flag = 0 THEN flag := 1
-			ELSIF (flag # 1) & (flag # 2) THEN err(225); flag := 0
-			END
-		ELSIF baseFlag = -12 THEN	(* pointer to java array is java array *)
-			IF flag # 0 THEN err(225) END;
-			flag := -12
-		ELSIF baseFlag = -13 THEN	(* pointer to java string is java string *)
-			IF flag # 0 THEN err(225) END;
-			flag := -13
-		END
-	END PropagateArrPtrSysFlag;
-	
-	
-	(* utf8 strings *)
-	
-	PROCEDURE PutUtf8* (VAR str: ARRAY OF SHORTCHAR; val: INTEGER; VAR idx: INTEGER);
-	BEGIN
-		ASSERT((val >= 0) & (val < 65536));
-		IF val < 128 THEN
-			str[idx] := SHORT(CHR(val)); INC(idx)
-		ELSIF val < 2048 THEN
-			str[idx] := SHORT(CHR(val DIV 64 + 192)); INC(idx);
-			str[idx] := SHORT(CHR(val MOD 64 + 128)); INC(idx)
-		ELSE
-			str[idx] := SHORT(CHR(val DIV 4096 + 224)); INC(idx); 
-			str[idx] := SHORT(CHR(val DIV 64 MOD 64 + 128)); INC(idx);
-			str[idx] := SHORT(CHR(val MOD 64 + 128)); INC(idx)
-		END
-	END PutUtf8;
-	
-	PROCEDURE GetUtf8* (VAR str: ARRAY OF SHORTCHAR; VAR val, idx: INTEGER);
-		VAR ch: SHORTCHAR;
-	BEGIN
-		ch := str[idx]; INC(idx);
-		IF ch < 80X THEN
-			val := ORD(ch)
-		ELSIF ch < 0E0X THEN
-			val := ORD(ch) - 192;
-			ch := str[idx]; INC(idx); val := val * 64 + ORD(ch) - 128
-		ELSE
-			val := ORD(ch) - 224;
-			ch := str[idx]; INC(idx); val := val * 64 + ORD(ch) - 128;
-			ch := str[idx]; INC(idx); val := val * 64 + ORD(ch) - 128
-		END
-	END GetUtf8;
-	
-	
-	(* log output *)
-
-	PROCEDURE LogW* (ch: SHORTCHAR);
-	BEGIN
-		StdLog.Char(ch)
-	END LogW;
-	
-	PROCEDURE LogWStr* (s: ARRAY OF SHORTCHAR);
-		VAR str: ARRAY 256 OF CHAR;
-	BEGIN
-		str := s$; StdLog.String(str)
-	END LogWStr;
-	
-	PROCEDURE LogWNum* (i, len: INTEGER);
-	BEGIN
-		StdLog.Int(i)
-	END LogWNum;
-
-	PROCEDURE LogWLn*;
-	BEGIN
-		StdLog.Ln
-	END LogWLn;
-(*	
-	PROCEDURE LogW* (ch: CHAR);
-	BEGIN
-		out.WriteChar(ch);
-	END LogW;
-	
-	PROCEDURE LogWStr* (s: ARRAY OF CHAR);
-	BEGIN
-		out.WriteString(s);
-	END LogWStr;
-	
-	PROCEDURE LogWNum* (i, len: LONGINT);
-	BEGIN
-		out.WriteChar(" "); out.WriteInt(i);
-	END LogWNum;
-
-	PROCEDURE LogWLn*;
-	BEGIN
-		out.WriteLn;
-		Views.RestoreDomain(logbuf.Domain())
-	END LogWLn;
-*)
-	PROCEDURE Mark* (n, pos: INTEGER);
-	BEGIN
-		IF (n >= 0) & ~((oberon IN options) & (n >= 181) & (n <= 190)) THEN
-			noerr := FALSE;
-			IF pos < 0 THEN pos := 0 END;
-			IF (pos < lastpos) OR (lastpos + 9 < pos) THEN
-				lastpos := pos;
-				IF errors < maxErrors THEN
-					errNo[errors] := n; errPos[errors] := pos
-				END;
-				INC(errors)
-			END;
-			IF trap IN options THEN HALT(100) END;
-		ELSIF (n <= -700) & (errors < maxErrors) THEN
-			errNo[errors] := -n; errPos[errors] := pos; INC(errors)
-		END
-	END Mark;
-	
-	PROCEDURE err* (n: INTEGER);
-	BEGIN
-		Mark(n, errpos)
-	END err;
-	
-	PROCEDURE InsertMarks* (text: TextModels.Model);
-		VAR i, j, x, y, n: INTEGER; script: Stores.Operation;
-	BEGIN
-		n := errors;
-		IF n > maxErrors THEN n := maxErrors END;
-		(* sort *)
-		i := 1;
-		WHILE i < n DO
-			x := errPos[i]; y := errNo[i]; j := i-1;
-			WHILE (j >= 0) & (errPos[j] > x) DO errPos[j+1] := errPos[j]; errNo[j+1] := errNo[j]; DEC(j) END;
-			errPos[j+1] := x; errNo[j+1] := y; INC(i)
-		END;
-		(* insert *)
-		Models.BeginModification(Models.clean, text);
-		Models.BeginScript(text, "#Dev:InsertMarkers", script);
-		WHILE n > 0 DO DEC(n);
-			DevMarkers.Insert(text, errPos[n], DevMarkers.dir.New(errNo[n]))
-		END;
-		Models.EndScript(text, script);
-		Models.EndModification(Models.clean, text);
-	END InsertMarks;
-
-
-	(* fingerprinting *)
-
-	PROCEDURE InitCrcTab;
-		(* CRC32, high bit first, pre & post inverted *)
-		CONST poly = {0, 1, 2, 4, 5, 7, 8, 10, 11, 12, 16, 22, 23, 26};	(* CRC32 polynom *)
-		VAR x, c, i: INTEGER;
-	BEGIN
-		x := 0;
-		WHILE x < 256 DO
-			c := x * 1000000H; i := 0;
-			WHILE i < 8 DO
-				IF c < 0 THEN c := ORD(BITS(c * 2) / poly)
-				ELSE c := c * 2
-				END;
-				INC(i)
-			END;
-			crc32tab[ORD(BITS(x) / BITS(255))] := ORD(BITS(c) / BITS(255));
-			INC(x)
-		END
-	END InitCrcTab;
-	
-	PROCEDURE FPrint* (VAR fp: INTEGER; val: INTEGER);
-		VAR c: INTEGER;
-	BEGIN
-(*
-		fp := SYSTEM.ROT(ORD(BITS(fp) / BITS(val)), 1)	(* bad collision detection *)
-*)
-		(* CRC32, high bit first, pre & post inverted *)
-		c := ORD(BITS(fp * 256) / BITS(crc32tab[ORD(BITS(fp DIV 1000000H) / BITS(val DIV 1000000H)) MOD 256]));
-		c := ORD(BITS(c * 256) / BITS(crc32tab[ORD(BITS(c DIV 1000000H) / BITS(val DIV 10000H)) MOD 256]));
-		c := ORD(BITS(c * 256) / BITS(crc32tab[ORD(BITS(c DIV 1000000H) / BITS(val DIV 100H)) MOD 256]));
-		fp := ORD(BITS(c * 256) / BITS(crc32tab[ORD(BITS(c DIV 1000000H) / BITS(val)) MOD 256]));
-	END FPrint;
-
-	PROCEDURE FPrintSet* (VAR fp: INTEGER; set: SET);
-	BEGIN FPrint(fp, ORD(set))
-	END FPrintSet;
-
-	PROCEDURE FPrintReal* (VAR fp: INTEGER; real: SHORTREAL);
-	BEGIN FPrint(fp, SYSTEM.VAL(INTEGER, real))
-	END FPrintReal;
-
-	PROCEDURE FPrintLReal* (VAR fp: INTEGER; lr: REAL);
-		VAR l, h: INTEGER;
-	BEGIN
-		FPrint(fp, LoWord(lr)); FPrint(fp, HiWord(lr))
-	END FPrintLReal;
-
-	PROCEDURE ChkSum (VAR fp: INTEGER; val: INTEGER);	(* symbolfile checksum *)
-	BEGIN
-		(* same as FPrint, 8 bit only *)
-		fp := ORD(BITS(fp * 256) / BITS(crc32tab[ORD(BITS(fp DIV 1000000H) / BITS(val)) MOD 256]))
-	END ChkSum;
-
-
-
-	(* compact format *)
-	
-	PROCEDURE WriteLInt (w: Files.Writer; i: INTEGER);
-	BEGIN
-		ChkSum(checksum, i);
-		w.WriteByte(SHORT(SHORT(i MOD 256))); i := i DIV 256;
-		ChkSum(checksum, i);
-		w.WriteByte(SHORT(SHORT(i MOD 256))); i := i DIV 256;
-		ChkSum(checksum, i);
-		w.WriteByte(SHORT(SHORT(i MOD 256))); i := i DIV 256;
-		ChkSum(checksum, i);
-		w.WriteByte(SHORT(SHORT(i MOD 256)))
-	END WriteLInt;
-
-	PROCEDURE ReadLInt (r: Files.Reader; VAR i: INTEGER);
-		VAR b: BYTE; x: INTEGER;
-	BEGIN
-		r.ReadByte(b); x := b MOD 256;
-		ChkSum(checksum, b);
-		r.ReadByte(b); x := x + 100H * (b MOD 256);
-		ChkSum(checksum, b);
-		r.ReadByte(b); x := x + 10000H * (b MOD 256);
-		ChkSum(checksum, b);
-		r.ReadByte(b); i := x + 1000000H * b;
-		ChkSum(checksum, b)
-	END ReadLInt;
-
-	PROCEDURE WriteNum (w: Files.Writer; i: INTEGER);
-	BEGIN	(* old format of Oberon *)
-		WHILE (i < -64) OR (i > 63) DO ChkSum(checksum, i MOD 128 - 128); w.WriteByte(SHORT(SHORT(i MOD 128 - 128))); i := i DIV 128 END;
-		ChkSum(checksum, i MOD 128);
-		w.WriteByte(SHORT(SHORT(i MOD 128)))
-	END WriteNum;
-
-	PROCEDURE ReadNum (r: Files.Reader; VAR i: INTEGER);
-		VAR b: BYTE; s, y: INTEGER;
-	BEGIN
-		s := 0; y := 0; r.ReadByte(b);
-		IF ~r.eof THEN ChkSum(checksum, b) END;
-		WHILE b < 0 DO INC(y, ASH(b + 128, s)); INC(s, 7); r.ReadByte(b); ChkSum(checksum, b) END;
-		i := ASH((b + 64) MOD 128 - 64, s) + y;
-	END ReadNum;
-	
-	PROCEDURE WriteNumSet (w: Files.Writer; x: SET);
-	BEGIN
-		WriteNum(w, ORD(x))
-	END WriteNumSet;
-
-	PROCEDURE ReadNumSet (r: Files.Reader; VAR x: SET);
-		VAR i: INTEGER;
-	BEGIN
-		ReadNum(r, i); x := BITS(i)
-	END ReadNumSet;
-
-	PROCEDURE WriteReal (w: Files.Writer; x: SHORTREAL);
-	BEGIN
-		WriteLInt(w, SYSTEM.VAL(INTEGER, x))
-	END WriteReal;
-
-	PROCEDURE ReadReal (r: Files.Reader; VAR x: SHORTREAL);
-		VAR i: INTEGER;
-	BEGIN
-		ReadLInt(r, i); x := SYSTEM.VAL(SHORTREAL, i)
-	END ReadReal;
-
-	PROCEDURE WriteLReal (w: Files.Writer; x: REAL);
-	BEGIN
-		WriteLInt(w, LoWord(x)); WriteLInt(w, HiWord(x))
-	END WriteLReal;
-
-	PROCEDURE ReadLReal (r: Files.Reader; VAR x: REAL);
-		VAR h, l: INTEGER;
-	BEGIN
-		ReadLInt(r, l); ReadLInt(r, h); x := Compound(l, h)
-	END ReadLReal;
-
-
-	(* read symbol file *)
-
-	PROCEDURE SymRCh* (VAR ch: SHORTCHAR);
-		VAR b: BYTE;
-	BEGIN
-		inSym.ReadByte(b); ch := SHORT(CHR(b));
-		ChkSum(checksum, b)
-	END SymRCh;
-	
-	PROCEDURE SymRInt* (): INTEGER;
-		VAR k: INTEGER;
-	BEGIN
-		ReadNum(inSym, k); RETURN k
-	END SymRInt;
-		
-	PROCEDURE SymRSet* (VAR s: SET);
-	BEGIN
-		ReadNumSet(inSym, s)
-	END SymRSet;
-
-	PROCEDURE SymRReal* (VAR r: SHORTREAL);
-	BEGIN
-		ReadReal(inSym, r)
-	END SymRReal;
-	
-	PROCEDURE SymRLReal* (VAR lr: REAL);
-	BEGIN
-		ReadLReal(inSym, lr)
-	END SymRLReal;
-	
-	PROCEDURE eofSF* (): BOOLEAN;
-	BEGIN
-		RETURN inSym.eof
-	END eofSF;
-	
-	PROCEDURE OldSym* (VAR modName: ARRAY OF SHORTCHAR; VAR done: BOOLEAN);
-		VAR tag: INTEGER; loc: Files.Locator; dir, name: Files.Name;
-	BEGIN
-		done := FALSE;
-		IF modName = "@file" THEN
-			oldSymFile := file
-		ELSE
-			name := modName$; Kernel.SplitName(name, dir, name);
-			Kernel.MakeFileName(name, Kernel.symType); 
-			loc := Files.dir.This(dir); loc := loc.This(symDir);
-			oldSymFile := Files.dir.Old(loc, name, Files.shared);
-			IF (oldSymFile = NIL) & (dir = "") THEN
-				loc := Files.dir.This(SYSdir); loc := loc.This(symDir);
-				oldSymFile := Files.dir.Old(loc, name, Files.shared)
-			END
-		END;
-		IF oldSymFile # NIL THEN
-			inSym := oldSymFile.NewReader(inSym);
-			IF inSym # NIL THEN
-				ReadLInt(inSym, tag);
-				IF tag = SFtag THEN done := TRUE ELSE err(151) END
-			END
-		END
-	END OldSym;
-
-	PROCEDURE CloseOldSym*;
-	BEGIN
-		IF oldSymFile # NIL THEN oldSymFile.Close; oldSymFile := NIL END
-	END CloseOldSym;
-
-
-	(* write symbol file *)
-
-	PROCEDURE SymWCh* (ch: SHORTCHAR);
-	BEGIN
-		ChkSum(checksum, ORD(ch));
-		outSym.WriteByte(SHORT(ORD(ch)))
-	END SymWCh;
-
-	PROCEDURE SymWInt* (i: INTEGER);
-	BEGIN
-		WriteNum(outSym, i)
-	END SymWInt;
-
-	PROCEDURE SymWSet* (s: SET);
-	BEGIN
-		WriteNumSet(outSym, s)
-	END SymWSet;
-
-	PROCEDURE SymWReal* (VAR r: SHORTREAL);
-	BEGIN
-		WriteReal(outSym, r)
-	END SymWReal;
-
-	PROCEDURE SymWLReal* (VAR r: REAL);
-	BEGIN
-		WriteLReal(outSym, r)
-	END SymWLReal;
-
-	PROCEDURE SymReset*;
-	BEGIN
-		outSym.SetPos(4)
-	END SymReset;
-
-	PROCEDURE NewSym* (VAR modName: ARRAY OF SHORTCHAR);
-		VAR loc: Files.Locator; dir: Files.Name;
-	BEGIN
-		ObjFName := modName$; Kernel.SplitName(ObjFName, dir, ObjFName);
-		loc := Files.dir.This(dir); loc := loc.This(symDir);
-		symFile := Files.dir.New(loc, Files.ask);
-		IF symFile # NIL THEN
-			outSym := symFile.NewWriter(NIL);
-			WriteLInt(outSym, SFtag)
-		ELSE
-			err(153)
-		END
-	END NewSym;
-	
-	PROCEDURE RegisterNewSym*;
-		VAR res: INTEGER; name: Files.Name;
-	BEGIN
-		IF symFile # NIL THEN
-			name := ObjFName$;
-			Kernel.MakeFileName(name, Kernel.symType);
-			symFile.Register(name, Kernel.symType, Files.ask, res);
-			symFile := NIL
-		END
-	END RegisterNewSym;
-	
-	PROCEDURE DeleteNewSym*;
-	BEGIN
-		IF symFile # NIL THEN symFile.Close; symFile := NIL END
-	END DeleteNewSym;
-
-
-	(* write object file *)
-
-	PROCEDURE ObjW* (ch: SHORTCHAR);
-	BEGIN
-		outObj.WriteByte(SHORT(ORD(ch)))
-	END ObjW;
-
-	PROCEDURE ObjWNum* (i: INTEGER);
-	BEGIN
-		WriteNum(outObj, i)
-	END ObjWNum;
-
-	PROCEDURE ObjWInt (i: SHORTINT);
-	BEGIN
-		outObj.WriteByte(SHORT(SHORT(i MOD 256)));
-		outObj.WriteByte(SHORT(SHORT(i DIV 256)))
-	END ObjWInt;
-
-	PROCEDURE ObjWLInt* (i: INTEGER);
-	BEGIN
-		ObjWInt(SHORT(i MOD 65536));
-		ObjWInt(SHORT(i DIV 65536))
-	END ObjWLInt;
-
-	PROCEDURE ObjWBytes* (VAR bytes: ARRAY OF SHORTCHAR; n: INTEGER);
-		TYPE P = POINTER TO ARRAY [untagged] 100000H OF BYTE;
-		VAR p: P;
-	BEGIN
-		p := SYSTEM.VAL(P, SYSTEM.ADR(bytes));
-		outObj.WriteBytes(p^, 0, n)
-	END ObjWBytes;
-	
-	PROCEDURE ObjLen* (): INTEGER;
-	BEGIN
-		RETURN outObj.Pos()
-	END ObjLen;
-	
-	PROCEDURE ObjSet* (pos: INTEGER);
-	BEGIN
-		outObj.SetPos(pos)
-	END ObjSet;
-
-	PROCEDURE NewObj* (VAR modName: ARRAY OF SHORTCHAR);
-		VAR loc: Files.Locator; dir: Files.Name;
-	BEGIN
-		errpos := 0;
-		ObjFName := modName$; Kernel.SplitName(ObjFName, dir, ObjFName);
-		loc := Files.dir.This(dir); loc := loc.This(codeDir);
-		objFile := Files.dir.New(loc, Files.ask);
-		IF objFile # NIL THEN
-			outObj := objFile.NewWriter(NIL);
-			WriteLInt(outObj, OFtag)
-		ELSE
-			err(153)
-		END
-	END NewObj;
-
-	PROCEDURE RegisterObj*;
-		VAR res: INTEGER; name: Files.Name;
-	BEGIN
-		IF objFile # NIL THEN
-			name := ObjFName$;
-			Kernel.MakeFileName(name, Kernel.objType);
-			objFile.Register(name, Kernel.objType, Files.ask, res);
-			objFile := NIL; outObj := NIL
-		END
-	END RegisterObj;
-
-	PROCEDURE DeleteObj*;
-	BEGIN
-		IF objFile # NIL THEN objFile.Close; objFile := NIL END
-	END DeleteObj;
-
-
-	PROCEDURE InitHost;
-		VAR test: SHORTINT; lo: SHORTCHAR;
-	BEGIN
-		test := 1; SYSTEM.GET(SYSTEM.ADR(test), lo); LEHost := lo = 1X;
-		InfReal := SYSTEM.VAL(SHORTREAL, InfRealPat);
-		MinReal32 := SYSTEM.VAL(SHORTREAL, MinReal32Pat);
-		MaxReal32 := SYSTEM.VAL(SHORTREAL, MaxReal32Pat);
-		MinReal64 := Compound(MinReal64PatL, MinReal64PatH);
-		MaxReal64 := Compound(MaxReal64PatL, MaxReal64PatH)
-	END InitHost;
-
-BEGIN
-	InitCrcTab;
-	InitHost
-END DevCPM.

BlackBox/Dev/Mod/CPP.txt

@@ -1,1650 +0,0 @@
-MODULE DevCPP;
-
-	(* THIS IS TEXT COPY OF BlackBox 1.6-rc6 Dev/Mod/CPP.odc *)
-	(* DO NOT EDIT *)
-
-	IMPORT
-		DevCPM, DevCPT, DevCPB, DevCPS;
-		
-	CONST
-		anchorVarPar = TRUE;
-	
-		(* numtyp values *)
-		char = 1; integer = 2; real = 4; int64 = 5; real32 = 6; real64 = 7;
-
-		(*symbol values*)
-		null = 0; times = 1; slash = 2; div = 3; mod = 4;
-		and = 5; plus = 6; minus = 7; or = 8; eql = 9;
-		neq = 10; lss = 11; leq = 12; gtr = 13; geq = 14;
-		in = 15; is = 16; arrow = 17; dollar = 18; period = 19;
-		comma = 20; colon = 21; upto = 22; rparen = 23; rbrak = 24;
-		rbrace = 25; of = 26; then = 27; do = 28; to = 29;
-		by = 30; not = 33;
-		lparen = 40; lbrak = 41; lbrace = 42; becomes = 44;
-		number = 45; nil = 46; string = 47; ident = 48; semicolon = 49;
-		bar = 50; end = 51; else = 52; elsif = 53; until = 54;
-		if = 55; case = 56; while = 57; repeat = 58; for = 59;
-		loop = 60; with = 61; exit = 62; return = 63; array = 64;
-		record = 65; pointer = 66; begin = 67; const = 68; type = 69;
-		var = 70; out = 71; procedure = 72; close = 73; import = 74;
-		module = 75; eof = 76;
-
-		(* object modes *)
-		Var = 1; VarPar = 2; Con = 3; Fld = 4; Typ = 5; LProc = 6; XProc = 7;
-		SProc = 8; CProc = 9; IProc = 10; Mod = 11; Head = 12; TProc = 13; Attr = 20;
-
-		(* Structure forms *)
-		Undef = 0; Byte = 1; Bool = 2; Char8 = 3; Int8 = 4; Int16 = 5; Int32 = 6;
-		Real32 = 7; Real64 = 8; Set = 9; String8 = 10; NilTyp = 11; NoTyp = 12;
-		Pointer = 13; ProcTyp = 14; Comp = 15;
-		Char16 = 16; String16 = 17; Int64 = 18;
-		intSet = {Int8..Int32, Int64}; charSet = {Char8, Char16};
-		
-		(* composite structure forms *)
-		Basic = 1; Array = 2; DynArr = 3; Record = 4;
-
-		(*function number*)
-		haltfn = 0; newfn = 1; incfn = 13; sysnewfn = 30;
-
-		(* nodes classes *)
-		Nvar = 0; Nvarpar = 1; Nfield = 2; Nderef = 3; Nindex = 4; Nguard = 5; Neguard = 6;
-		Nconst = 7; Ntype = 8; Nproc = 9; Nupto = 10; Nmop = 11; Ndop = 12; Ncall = 13;
-		Ninittd = 14; Nif = 15; Ncaselse = 16; Ncasedo = 17; Nenter = 18; Nassign = 19;
-		Nifelse = 20; Ncase = 21; Nwhile = 22; Nrepeat = 23; Nloop = 24; Nexit = 25;
-		Nreturn = 26; Nwith = 27; Ntrap = 28; Ncomp = 30;
-
-		(* node subclasses *)
-		super = 1;
-		
-		(* module visibility of objects *)
-		internal = 0; external = 1; externalR = 2; inPar = 3; outPar = 4;
-
-		(* procedure flags (conval.setval) *)
-		hasBody = 1; isRedef = 2; slNeeded = 3; imVar = 4;
-		
-		(* attribute flags (attr.adr, struct.attribute, proc.conval.setval)*)
-		newAttr = 16; absAttr = 17; limAttr = 18; empAttr = 19; extAttr = 20;
-		
-		(* case statement flags (conval.setval) *)
-		useTable = 1; useTree = 2;
-		
-		(* sysflags *)
-		nilBit = 1; inBit = 2; outBit = 4; newBit = 8; iidBit = 16; interface = 10; som = 20; jstr = -13;
-		
-		
-	TYPE
-		Elem = POINTER TO RECORD
-			next: Elem;
-			struct: DevCPT.Struct;
-			obj, base: DevCPT.Object;
-			pos: INTEGER;
-			name: DevCPT.String
-		END;
-		
-		
-	VAR
-		sym, level: BYTE;
-		LoopLevel: SHORTINT;
-		TDinit, lastTDinit: DevCPT.Node;
-		userList: Elem;
-		recList: Elem;
-		hasReturn: BOOLEAN;
-		numUsafeVarPar, numFuncVarPar: INTEGER;
-		
-
-	PROCEDURE^ Type(VAR typ: DevCPT.Struct; VAR name: DevCPT.String);
-	PROCEDURE^ Expression(VAR x: DevCPT.Node);
-	PROCEDURE^ Block(VAR procdec, statseq: DevCPT.Node);
-	
-	(* forward type handling *)
-	
-	PROCEDURE IncompleteType (typ: DevCPT.Struct): BOOLEAN;
-	BEGIN
-		IF typ.form = Pointer THEN typ := typ.BaseTyp END;
-		RETURN (typ = DevCPT.undftyp) OR (typ.comp = Record) & (typ.BaseTyp = DevCPT.undftyp)
-	END IncompleteType;
-	
-	PROCEDURE SetType (struct: DevCPT.Struct; obj: DevCPT.Object; typ: DevCPT.Struct; name: DevCPT.String);
-		VAR u: Elem;
-	BEGIN
-		IF obj # NIL THEN obj.typ := typ ELSE struct.BaseTyp := typ END;
-		IF name # NIL THEN
-			NEW(u); u.struct := struct; u.obj := obj; u.pos := DevCPM.errpos; u.name := name;
-			u.next := userList; userList := u
-		END
-	END SetType;
-
-	PROCEDURE CheckAlloc (VAR typ: DevCPT.Struct; dynAllowed: BOOLEAN; pos: INTEGER);
-	BEGIN
-		typ.pvused := TRUE;
-		IF typ.comp = DynArr THEN
-			IF ~dynAllowed THEN DevCPM.Mark(88, pos); typ := DevCPT.undftyp END
-		ELSIF typ.comp = Record THEN
-			IF (typ.attribute = absAttr) OR (typ.attribute = limAttr) & (typ.mno # 0) THEN
-				DevCPM.Mark(193, pos); typ := DevCPT.undftyp
-			END
-		END
-	END CheckAlloc;
-
-	PROCEDURE CheckRecursiveType (outer, inner: DevCPT.Struct; pos: INTEGER);
-		VAR fld: DevCPT.Object;
-	BEGIN
-		IF outer = inner THEN DevCPM.Mark(58, pos)
-		ELSIF inner.comp IN {Array, DynArr} THEN CheckRecursiveType(outer, inner.BaseTyp, pos)
-		ELSIF inner.comp = Record THEN
-			fld := inner.link;
-			WHILE (fld # NIL) & (fld.mode = Fld) DO
-				CheckRecursiveType(outer, fld.typ, pos);
-				fld := fld.link
-			END;
-			IF inner.BaseTyp # NIL THEN CheckRecursiveType(outer, inner.BaseTyp, pos) END
-		END
-	END CheckRecursiveType;
-	
-	PROCEDURE FixType (struct: DevCPT.Struct; obj: DevCPT.Object; typ: DevCPT.Struct; pos: INTEGER);
-	(* fix forward reference *)
-		VAR t: DevCPT.Struct; f, bf: DevCPT.Object; i: SHORTINT;
-	BEGIN
-		IF obj # NIL THEN
-			IF obj.mode = Var THEN	(* variable type *)
-				IF struct # NIL THEN	(* receiver type *)
-					IF (typ.form # Pointer) OR (typ.BaseTyp # struct) THEN DevCPM.Mark(180, pos) END;
-				ELSE CheckAlloc(typ, obj.mnolev > level, pos)	(* TRUE for parameters *)
-				END
-			ELSIF obj.mode = VarPar THEN	(* varpar type *)
-				IF struct # NIL THEN	(* varpar receiver type *)
-					IF typ # struct THEN DevCPM.Mark(180, pos) END
-				END
-			ELSIF obj.mode = Fld THEN	(* field type *)
-				CheckAlloc(typ, FALSE, pos);
-				CheckRecursiveType(struct, typ, pos)
-			ELSIF obj.mode = TProc THEN	(* proc return type *)
-				IF typ.form = Comp THEN typ := DevCPT.undftyp; DevCPM.Mark(54, pos) END
-			ELSIF obj.mode = Typ THEN	(* alias type *)
-				IF typ.form IN {Byte..Set, Char16, Int64} THEN	(* make alias structure *)
-					t := DevCPT.NewStr(typ.form, Basic); i := t.ref;
-					t^ := typ^; t.ref := i; t.strobj := obj; t.mno := 0;
-					t.BaseTyp := typ; typ := t
-				END;
-				IF obj.vis # internal THEN
-					IF typ.comp = Record THEN typ.exp := TRUE
-					ELSIF typ.form = Pointer THEN typ.BaseTyp.exp := TRUE
-					END
-				END
-			ELSE HALT(100)
-			END;
-			obj.typ := typ
-		ELSE
-			IF struct.form = Pointer THEN	(* pointer base type *)
-				IF typ.comp = Record THEN DevCPM.PropagateRecPtrSysFlag(typ.sysflag, struct.sysflag)
-				ELSIF typ.comp IN {Array, DynArr} THEN DevCPM.PropagateArrPtrSysFlag(typ.sysflag, struct.sysflag)
-				ELSE typ := DevCPT.undftyp; DevCPM.Mark(57, pos)
-				END;
-				struct.untagged := struct.sysflag > 0;
-				IF (struct.strobj # NIL) & (struct.strobj.vis # internal) THEN typ.exp := TRUE END;
-			ELSIF struct.comp = Array THEN	(* array base type *)
-				CheckAlloc(typ, FALSE, pos);
-				CheckRecursiveType(struct, typ, pos)
-			ELSIF struct.comp = DynArr THEN	(* array base type *)
-				CheckAlloc(typ, TRUE, pos);
-				CheckRecursiveType(struct, typ, pos)
-			ELSIF struct.comp = Record THEN	(* record base type *)
-				IF typ.form = Pointer THEN typ := typ.BaseTyp END;
-				typ.pvused := TRUE; struct.extlev := SHORT(SHORT(typ.extlev + 1));
-				DevCPM.PropagateRecordSysFlag(typ.sysflag, struct.sysflag);
-				IF (typ.attribute = 0) OR (typ.attribute = limAttr) & (typ.mno # 0) THEN DevCPM.Mark(181, pos)
-				ELSIF (struct.attribute = absAttr) & (typ.attribute # absAttr) THEN DevCPM.Mark(191, pos)
-				ELSIF (typ.attribute = limAttr) & (struct.attribute # limAttr) THEN DevCPM.Mark(197, pos)
-				END;
-				f := struct.link;
-				WHILE f # NIL DO	(* check for field name conflicts *)
-					DevCPT.FindField(f.name, typ, bf);
-					IF bf # NIL THEN DevCPM.Mark(1, pos) END;
-					f := f.link
-				END;
-				CheckRecursiveType(struct, typ, pos);
-				struct.untagged := struct.sysflag > 0;
-			ELSIF struct.form = ProcTyp THEN	(* proc type return type *)
-				IF typ.form = Comp THEN typ := DevCPT.undftyp; DevCPM.Mark(54, pos) END;
-			ELSE HALT(100)
-			END;
-			struct.BaseTyp := typ
-		END
-	END FixType;
-
-	PROCEDURE CheckForwardTypes;
-		VAR u, next: Elem; progress: BOOLEAN;
-	BEGIN
-		u := userList; userList := NIL;
-		WHILE u # NIL DO
-			next := u.next; DevCPS.name := u.name^$; DevCPT.Find(DevCPS.name, u.base);
-			IF u.base = NIL THEN DevCPM.Mark(0, u.pos)
-			ELSIF u.base.mode # Typ THEN DevCPM.Mark(72, u.pos)
-			ELSE u.next := userList; userList := u	(* reinsert *)
-			END;
-			u := next
-		END;
-		REPEAT	(* iteration for multy level alias *)
-			u := userList; userList := NIL; progress := FALSE;
-			WHILE u # NIL DO
-				next := u.next;
-				IF IncompleteType(u.base.typ) THEN
-					u.next := userList; userList := u	(* reinsert *)
-				ELSE
-					progress := TRUE;
-					FixType(u.struct, u.obj, u.base.typ, u.pos)
-				END;
-				u := next
-			END
-		UNTIL (userList = NIL) OR ~progress;
-		u := userList;	(* remaining type relations are cyclic *)
-		WHILE u # NIL DO
-			IF (u.obj = NIL) OR (u.obj.mode = Typ) THEN DevCPM.Mark(58, u.pos) END;
-			u := u.next
-		END;
-	END CheckForwardTypes;
-	
-	PROCEDURE CheckUnimpl (m: DevCPT.Object; typ: DevCPT.Struct; pos: INTEGER);
-		VAR obj: DevCPT.Object;
-	BEGIN
-		IF m # NIL THEN
-			IF (m.mode = TProc) & (absAttr IN m.conval.setval) THEN
-				DevCPT.FindField(m.name^, typ, obj);
-				IF (obj = NIL) OR (obj.mode # TProc) OR (absAttr IN obj.conval.setval) THEN
-					DevCPM.Mark(192, pos);
-					DevCPM.LogWLn; DevCPM.LogWStr("  "); DevCPM.LogWStr(m.name^);
-					DevCPM.LogWStr(" not implemented");
-					IF typ.strobj # NIL THEN
-						DevCPM.LogWStr(" in "); DevCPM.LogWStr(typ.strobj.name^)
-					END
-				END
-			END;
-			CheckUnimpl(m.left, typ, pos);
-			CheckUnimpl(m.right, typ, pos)
-		END
-	END CheckUnimpl;
-	
-	PROCEDURE CheckRecords (rec: Elem);
-		VAR b: DevCPT.Struct;
-	BEGIN
-		WHILE rec # NIL DO	(* check for unimplemented methods in base type *)
-			b := rec.struct.BaseTyp;
-			WHILE (b # NIL) & (b # DevCPT.undftyp) DO
-				CheckUnimpl(b.link, rec.struct, rec.pos);
-				b := b.BaseTyp
-			END;
-			rec := rec.next
-		END
-	END CheckRecords;
-
-
-	PROCEDURE err(n: SHORTINT);
-	BEGIN DevCPM.err(n)
-	END err;
-
-	PROCEDURE CheckSym(s: SHORTINT);
-	BEGIN
-		IF sym = s THEN DevCPS.Get(sym) ELSE DevCPM.err(s) END
-	END CheckSym;
-
-	PROCEDURE qualident(VAR id: DevCPT.Object);
-		VAR obj: DevCPT.Object; lev: BYTE;
-	BEGIN (*sym = ident*)
-		DevCPT.Find(DevCPS.name, obj); DevCPS.Get(sym);
-		IF (sym = period) & (obj # NIL) & (obj.mode = Mod) THEN
-			DevCPS.Get(sym);
-			IF sym = ident THEN
-				DevCPT.FindImport(DevCPS.name, obj, obj); DevCPS.Get(sym)
-			ELSE err(ident); obj := NIL
-			END
-		END ;
-		IF obj = NIL THEN err(0);
-			obj := DevCPT.NewObj(); obj.mode := Var; obj.typ := DevCPT.undftyp; obj.adr := 0
-		ELSE lev := obj.mnolev;
-			IF (obj.mode IN {Var, VarPar}) & (lev # level) THEN
-				obj.leaf := FALSE;
-				IF lev > 0 THEN DevCPB.StaticLink(SHORT(SHORT(level-lev)), TRUE) END	(* !!! *)
-			END
-		END ;
-		id := obj
-	END qualident;
-
-	PROCEDURE ConstExpression(VAR x: DevCPT.Node);
-	BEGIN Expression(x);
-		IF x.class # Nconst THEN
-			err(50); x := DevCPB.NewIntConst(1) 
-		END
-	END ConstExpression;
-
-	PROCEDURE CheckMark(obj: DevCPT.Object);	(* !!! *)
-		VAR n: INTEGER; mod: ARRAY 256 OF DevCPT.String;
-	BEGIN DevCPS.Get(sym);
-		IF (sym = times) OR (sym = minus) THEN
-			IF (level > 0) OR ~(obj.mode IN {Var, Fld, TProc}) & (sym = minus) THEN err(41) END ;
-			IF sym = times THEN obj.vis := external ELSE obj.vis := externalR END ;
-			DevCPS.Get(sym)
-		ELSE obj.vis := internal
-		END;
-		IF (obj.mode IN {TProc, LProc, XProc, CProc, Var, Typ, Con, Fld}) & (sym = lbrak) THEN
-			DevCPS.Get(sym);
-			IF (sym = number) & (DevCPS.numtyp = char) THEN
-				NEW(DevCPS.str, 2); DevCPS.str[0] := SHORT(CHR(DevCPS.intval)); DevCPS.str[1] := 0X; sym := string
-			END;
-			IF sym = string THEN
-				IF DevCPS.str^ # "" THEN obj.entry := DevCPS.str END;
-				DevCPS.Get(sym); n := 0;
-				IF (sym = comma) & (obj.mode IN {LProc, XProc, CProc, Var, Con}) THEN
-					DevCPS.Get(sym);
-					IF (sym = number) & (DevCPS.numtyp = char) THEN
-						NEW(DevCPS.str, 2); DevCPS.str[0] := SHORT(CHR(DevCPS.intval)); DevCPS.str[1] := 0X; sym := string
-					END;
-					IF sym = string THEN
-						obj.library := obj.entry; obj.entry := NIL;
-						IF DevCPS.str^ # "" THEN obj.entry := DevCPS.str END;
-						DevCPS.Get(sym);
-					ELSE err(string)
-					END
-				END;
-				WHILE sym = comma DO
-					DevCPS.Get(sym);
-					IF (sym = number) & (DevCPS.numtyp = char) THEN
-						NEW(DevCPS.str, 2); DevCPS.str[0] := SHORT(CHR(DevCPS.intval)); DevCPS.str[1] := 0X; sym := string
-					END;
-					IF sym = string THEN
-						IF n < LEN(mod) THEN mod[n] := DevCPS.str; INC(n)
-						ELSE err(235)
-						END;
-						DevCPS.Get(sym)
-					ELSE err(string)
-					END
-				END;
-				IF n > 0 THEN
-					NEW(obj.modifiers, n);
-					WHILE n > 0 DO DEC(n); obj.modifiers[n] := mod[n] END
-				END
-			ELSE err(string)
-			END;
-			CheckSym(rbrak);
-			IF DevCPM.options * {DevCPM.interface, DevCPM.java} = {} THEN err(225) END
-		END
-	END CheckMark;
-
-	PROCEDURE CheckSysFlag (VAR sysflag: SHORTINT;
-										GetSF: PROCEDURE(id: ARRAY OF SHORTCHAR; num: SHORTINT; VAR flag: SHORTINT));
-		VAR x: DevCPT.Object; i: SHORTINT;
-	BEGIN
-		sysflag := 0;
-		IF sym = lbrak THEN
-			DevCPS.Get(sym);
-			WHILE (sym = number) OR (sym = ident) OR (sym = string) DO
-				IF sym = number THEN
-					IF DevCPS.numtyp = integer THEN
-						i := SHORT(DevCPS.intval); GetSF("", i, sysflag)
-					ELSE err(225)
-					END
-				ELSIF sym = ident THEN
-					DevCPT.Find(DevCPS.name, x);
-					IF (x # NIL) & (x.mode = Con) & (x.typ.form IN {Int8, Int16, Int32}) THEN 
-						i := SHORT(x.conval.intval); GetSF("", i, sysflag)
-					ELSE
-						GetSF(DevCPS.name, 0, sysflag)
-					END
-				ELSE
-					GetSF(DevCPS.str^, 0, sysflag)
-				END;
-				DevCPS.Get(sym);
-				IF (sym = comma) OR (sym = plus) THEN DevCPS.Get(sym) END
-			END;
-			CheckSym(rbrak)
-		END
-	END CheckSysFlag;
-	
-	PROCEDURE Receiver(VAR mode, vis: BYTE; VAR name: DevCPT.Name; VAR typ, rec: DevCPT.Struct);
-		VAR obj: DevCPT.Object; tname: DevCPT.String;
-	BEGIN typ := DevCPT.undftyp; rec := NIL; vis := 0;
-		IF sym = var THEN DevCPS.Get(sym); mode := VarPar;
-		ELSIF sym = in THEN DevCPS.Get(sym); mode := VarPar; vis := inPar	(* ??? *)
-		ELSE mode := Var
-		END ;
-		name := DevCPS.name; CheckSym(ident); CheckSym(colon);
-		IF sym # ident THEN err(ident) END;
-		Type(typ, tname);
-		IF tname = NIL THEN
-			IF typ.form = Pointer THEN  rec := typ.BaseTyp ELSE rec := typ END;
-			IF ~((mode = Var) & (typ.form = Pointer) & (rec.comp = Record) OR
-				(mode = VarPar) & (typ.comp = Record)) THEN err(70); rec := NIL END;
-			IF (rec # NIL) & (rec.mno # level) THEN err(72); rec := NIL END
-		ELSE err(0)
-		END;
-		CheckSym(rparen);
-		IF rec = NIL THEN rec := DevCPT.NewStr(Comp, Record); rec.BaseTyp := NIL END
-	END Receiver;
-	
-	PROCEDURE FormalParameters(
-		VAR firstPar: DevCPT.Object; VAR resTyp: DevCPT.Struct; VAR name: DevCPT.String
-	);
-		VAR mode, vis: BYTE; sys: SHORTINT;
-				par, first, last, res, newPar, iidPar: DevCPT.Object; typ: DevCPT.Struct;
-	BEGIN
-		first := NIL; last := firstPar;
-		newPar := NIL; iidPar := NIL;
-		IF (sym = ident) OR (sym = var) OR (sym = in) OR (sym = out) THEN
-			LOOP
-				sys := 0; vis := 0;
-				IF sym = var THEN DevCPS.Get(sym); mode := VarPar
-				ELSIF sym = in THEN DevCPS.Get(sym); mode := VarPar; vis := inPar
-				ELSIF sym = out THEN DevCPS.Get(sym); mode := VarPar; vis := outPar
-				ELSE mode := Var
-				END ;
-				IF mode = VarPar THEN CheckSysFlag(sys, DevCPM.GetVarParSysFlag) END;
-				IF ODD(sys DIV inBit) THEN vis := inPar
-				ELSIF ODD(sys DIV outBit) THEN vis := outPar
-				END;
-				IF ODD(sys DIV newBit) & (vis # outPar) THEN err(225)
-				ELSIF ODD(sys DIV iidBit) & (vis # inPar) THEN err(225)
-				END;
-				LOOP
-					IF sym = ident THEN
-						DevCPT.Insert(DevCPS.name, par); DevCPS.Get(sym);
-						par.mode := mode; par.link := NIL; par.vis := vis; par.sysflag := SHORT(sys);
-						IF first = NIL THEN first := par END ;
-						IF firstPar = NIL THEN firstPar := par ELSE last.link := par END ;
-						last := par
-					ELSE err(ident)
-					END;
-					IF sym = comma THEN DevCPS.Get(sym)
-					ELSIF sym = ident THEN err(comma)
-					ELSIF sym = var THEN err(comma); DevCPS.Get(sym)
-					ELSE EXIT
-					END
-				END ;
-				CheckSym(colon); Type(typ, name);
-				IF mode # VarPar THEN CheckAlloc(typ, TRUE, DevCPM.errpos) END;
-				IF (mode = VarPar) & (vis = inPar) & (typ.form # Undef) & (typ.form # Comp) & (typ.sysflag = 0) THEN err(177)
-				END;
-				(* typ.pbused is set when parameter type name is parsed *)
-				WHILE first # NIL DO
-					SetType (NIL, first, typ, name);
-					IF DevCPM.com IN DevCPM.options THEN
-						IF ODD(sys DIV newBit) THEN
-							IF (newPar # NIL) OR (typ.form # Pointer) OR (typ.sysflag # interface) THEN err(168) END;
-							newPar := first
-						ELSIF ODD(sys DIV iidBit) THEN
-							IF (iidPar # NIL) OR (typ # DevCPT.guidtyp) THEN err(168) END;
-							iidPar := first
-						END
-					END;
-					first := first.link
-				END;
-				IF sym = semicolon THEN DevCPS.Get(sym)
-				ELSIF sym = ident THEN err(semicolon)
-				ELSE EXIT
-				END
-			END
-		END;
-		CheckSym(rparen);
-		IF (newPar = NIL) # (iidPar = NIL) THEN err(168) END;
-		name := NIL;
-		IF sym = colon THEN
-			DevCPS.Get(sym);
-			Type(resTyp, name);
-			IF resTyp.form = Comp THEN resTyp := DevCPT.undftyp; err(54) END
-		ELSE resTyp := DevCPT.notyp
-		END
-	END FormalParameters;
-	
-	PROCEDURE CheckOverwrite (proc, base: DevCPT.Object; rec: DevCPT.Struct);
-		VAR o, bo: DevCPT.Object;
-	BEGIN
-		IF base # NIL THEN
-			IF base.conval.setval * {absAttr, empAttr, extAttr} = {} THEN err(182) END;
-			IF (proc.link.mode # base.link.mode) OR (proc.link.vis # base.link.vis)
-				OR ~DevCPT.Extends(proc.link.typ, base.link.typ) THEN err(115) END;
-			o := proc.link; bo := base.link;
-			WHILE (o # NIL) & (bo # NIL) DO
-				IF (bo.sysflag # 0) & (o.sysflag = 0) THEN	(* propagate sysflags *)
-					o.sysflag := bo.sysflag
-				END;
-				o := o.link; bo := bo.link
-			END;
-			DevCPB.CheckParameters(proc.link.link, base.link.link, FALSE);
-			IF ~DevCPT.Extends(proc.typ, base.typ) THEN err(117) END;
-			IF (base.vis # proc.vis) & ((proc.vis # internal) OR rec.exp) THEN err(183) END;
-			INCL(proc.conval.setval, isRedef)
-		END;
-	END CheckOverwrite;
-
-	PROCEDURE GetAttributes (proc, base: DevCPT.Object; owner: DevCPT.Struct);	(* read method attributes *)
-		VAR attr, battr: SET; o: DevCPT.Object;
-	BEGIN
-		attr := {};
-		IF sym = comma THEN	(* read attributes *)
-			DevCPS.Get(sym);
-			IF sym = ident THEN
-				DevCPT.Find(DevCPS.name, o);
-				IF (o # NIL) & (o.mode = SProc) & (o.adr = newfn) THEN
-					IF ~(DevCPM.oberon IN DevCPM.options) THEN INCL(attr, newAttr) ELSE err(178) END;
-					DevCPS.Get(sym);
-					IF sym = comma THEN
-						DevCPS.Get(sym);
-						IF sym = ident THEN DevCPT.Find(DevCPS.name, o) ELSE o := NIL; err(ident) END
-					ELSE o := NIL
-					END
-				END;
-				IF o # NIL THEN
-					IF (o.mode # Attr) OR (o.adr = limAttr) OR (DevCPM.oberon IN DevCPM.options) THEN err(178)
-					ELSE INCL(attr, o.adr)
-					END;
-					DevCPS.Get(sym)
-				END
-			ELSE err(ident)
-			END
-		END;
-		IF (base = NIL) & ~(newAttr IN attr) THEN err(185); INCL(attr, newAttr)
-		ELSIF (base # NIL) & (newAttr IN attr) THEN err(186)
-		END;
-		IF absAttr IN attr THEN
-			IF owner.attribute # absAttr THEN err(190) END;
-			IF (proc.vis = internal) & owner.exp THEN err(179) END
-		END;
-		IF (owner.attribute = 0) OR (owner.attribute = limAttr) THEN
-			IF (empAttr IN attr) & (newAttr IN attr) THEN err(187)
-(*
-			ELSIF extAttr IN attr THEN err(188)
-*)
-			END
-		END;
-		IF base # NIL THEN
-			battr := base.conval.setval;
-			IF empAttr IN battr THEN
-				IF absAttr IN attr THEN err(189) END
-			ELSIF ~(absAttr IN battr) THEN
-				IF (absAttr IN attr) OR (empAttr IN attr) THEN err(189) END
-			END
-		END;
-		IF empAttr IN attr THEN
-			IF proc.typ # DevCPT.notyp THEN err(195)
-			ELSE
-				o := proc.link; WHILE (o # NIL) & (o.vis # outPar) DO o := o.link END;
-				IF o # NIL THEN err(195) END
-			END
-		END;
-		IF (owner.sysflag = interface) & ~(absAttr IN attr) THEN err(162) END;
-		proc.conval.setval := attr
-	END GetAttributes;
-	
-	PROCEDURE RecordType(VAR typ: DevCPT.Struct; attr: DevCPT.Object);
-		VAR fld, first, last, base: DevCPT.Object; r: Elem; ftyp: DevCPT.Struct; name: DevCPT.String;
-	BEGIN typ := DevCPT.NewStr(Comp, Record); typ.BaseTyp := NIL;
-		CheckSysFlag(typ.sysflag, DevCPM.GetRecordSysFlag);
-		IF attr # NIL THEN
-			IF ~(DevCPM.oberon IN DevCPM.options) & (attr.adr # empAttr) THEN typ.attribute := SHORT(SHORT(attr.adr))
-			ELSE err(178)
-			END
-		END;
-		IF typ.sysflag = interface THEN
-			IF (DevCPS.str # NIL) & (DevCPS.str[0] = "{") THEN typ.ext := DevCPS.str END;
-			IF typ.attribute # absAttr THEN err(163) END;
-			IF sym # lparen THEN err(160) END
-		END;
-		IF sym = lparen THEN
-			DevCPS.Get(sym); (*record extension*)
-			IF sym = ident THEN
-				Type(ftyp, name);
-				IF ftyp.form = Pointer THEN ftyp := ftyp.BaseTyp END;
-				SetType(typ, NIL, ftyp, name);
-				IF (ftyp.comp = Record) & (ftyp # DevCPT.anytyp) THEN
-					ftyp.pvused := TRUE; typ.extlev := SHORT(SHORT(ftyp.extlev + 1));
-					DevCPM.PropagateRecordSysFlag(ftyp.sysflag, typ.sysflag);
-					IF (ftyp.attribute = 0) OR (ftyp.attribute = limAttr) & (ftyp.mno # 0) THEN err(181)
-					ELSIF (typ.attribute = absAttr) & (ftyp.attribute # absAttr) & ~(DevCPM.java IN DevCPM.options) THEN err(191)
-					ELSIF (ftyp.attribute = limAttr) & (typ.attribute # limAttr) THEN err(197)
-					END
-				ELSIF ftyp # DevCPT.undftyp THEN err(53)
-				END
-			ELSE err(ident)
-			END ;
-			IF typ.attribute # absAttr THEN	(* save typ for unimplemented method check *)
-				NEW(r); r.struct := typ; r.pos := DevCPM.errpos; r.next := recList; recList := r
-			END;
-			CheckSym(rparen)
-		END;
-(*
-		DevCPT.OpenScope(0, NIL);
-*)
-		first := NIL; last := NIL;
-		LOOP
-			IF sym = ident THEN
-				LOOP
-					IF sym = ident THEN
-						IF (typ.BaseTyp # NIL) & (typ.BaseTyp # DevCPT.undftyp) THEN
-							DevCPT.FindBaseField(DevCPS.name, typ, fld);
-							IF fld # NIL THEN err(1) END
-						END ;
-						DevCPT.InsertField(DevCPS.name, typ, fld);
-						fld.mode := Fld; fld.link := NIL; fld.typ := DevCPT.undftyp;
-						CheckMark(fld);
-						IF first = NIL THEN first := fld END ;
-						IF last = NIL THEN typ.link := fld ELSE last.link := fld END ;
-						last := fld
-					ELSE err(ident)
-					END ;
-					IF sym = comma THEN DevCPS.Get(sym)
-					ELSIF sym = ident THEN err(comma)
-					ELSE EXIT
-					END
-				END ;
-				CheckSym(colon); Type(ftyp, name);
-				CheckAlloc(ftyp, FALSE, DevCPM.errpos);
-				WHILE first # NIL DO
-					SetType(typ, first, ftyp, name); first := first.link
-				END;
-				IF typ.sysflag = interface THEN err(161) END
-			END;
-			IF sym = semicolon THEN DevCPS.Get(sym)
-			ELSIF sym = ident THEN err(semicolon)
-			ELSE EXIT
-			END
-		END;
-(*
-		IF typ.link # NIL THEN ASSERT(typ.link = DevCPT.topScope.right) END;
-		typ.link := DevCPT.topScope.right; DevCPT.CloseScope;
-*)
-		typ.untagged := typ.sysflag > 0;
-		DevCPB.Inittd(TDinit, lastTDinit, typ); CheckSym(end)
-	END RecordType;
-
-	PROCEDURE ArrayType(VAR typ: DevCPT.Struct);
-		VAR x: DevCPT.Node; n: INTEGER; sysflag: SHORTINT; name: DevCPT.String;
-	BEGIN CheckSysFlag(sysflag, DevCPM.GetArraySysFlag);
-		IF sym = of THEN	(*dynamic array*)
-			typ := DevCPT.NewStr(Comp, DynArr); typ.mno := 0; typ.sysflag := sysflag;
-			DevCPS.Get(sym); Type(typ.BaseTyp, name); SetType(typ, NIL, typ.BaseTyp, name);
-			CheckAlloc(typ.BaseTyp, TRUE, DevCPM.errpos);
-			IF typ.BaseTyp.comp = DynArr THEN typ.n := typ.BaseTyp.n + 1 ELSE typ.n := 0 END
-		ELSE
-			typ := DevCPT.NewStr(Comp, Array); typ.sysflag := sysflag; ConstExpression(x);
-			IF x.typ.form IN {Int8, Int16, Int32} THEN n := x.conval.intval;
-				IF (n <= 0) OR (n > DevCPM.MaxIndex) THEN err(63); n := 1 END
-			ELSE err(42); n := 1
-			END ;
-			typ.n := n;
-			IF sym = of THEN
-				DevCPS.Get(sym); Type(typ.BaseTyp, name); SetType(typ, NIL, typ.BaseTyp, name);
-				CheckAlloc(typ.BaseTyp, FALSE, DevCPM.errpos)
-			ELSIF sym = comma THEN
-				DevCPS.Get(sym);
-				IF sym # of THEN ArrayType(typ.BaseTyp) END
-			ELSE err(35)
-			END
-		END;
-		typ.untagged := typ.sysflag > 0
-	END ArrayType;
-
-	PROCEDURE PointerType(VAR typ: DevCPT.Struct);
-		VAR id: DevCPT.Object; name: DevCPT.String;
-	BEGIN typ := DevCPT.NewStr(Pointer, Basic); CheckSysFlag(typ.sysflag, DevCPM.GetPointerSysFlag);
-		CheckSym(to);
-		Type(typ.BaseTyp, name);
-		SetType(typ, NIL, typ.BaseTyp, name);
-		IF (typ.BaseTyp # DevCPT.undftyp) & (typ.BaseTyp.comp = Basic) THEN
-			typ.BaseTyp := DevCPT.undftyp; err(57)
-		END;
-		IF typ.BaseTyp.comp = Record THEN DevCPM.PropagateRecPtrSysFlag(typ.BaseTyp.sysflag, typ.sysflag)
-		ELSIF typ.BaseTyp.comp IN {Array, DynArr} THEN DevCPM.PropagateArrPtrSysFlag(typ.BaseTyp.sysflag, typ.sysflag)
-		END;
-		typ.untagged := typ.sysflag > 0
-	END PointerType;
-	
-	PROCEDURE Type (VAR typ: DevCPT.Struct; VAR name: DevCPT.String);	(* name # NIL => forward reference *)
-		VAR id: DevCPT.Object; tname: DevCPT.String;
-	BEGIN
-		typ := DevCPT.undftyp; name := NIL;
-		IF sym < lparen THEN err(12);
-			REPEAT DevCPS.Get(sym) UNTIL sym >= lparen
-		END ;
-		IF sym = ident THEN
-			DevCPT.Find(DevCPS.name, id);
-			IF (id = NIL) OR (id.mode = -1) OR (id.mode = Typ) & IncompleteType(id.typ) THEN	(* forward type definition *)
-				name := DevCPT.NewName(DevCPS.name); DevCPS.Get(sym);
-				IF (id = NIL) & (sym = period) THEN	(* missing module *)
-					err(0); DevCPS.Get(sym); name := NIL;
-					IF sym = ident THEN DevCPS.Get(sym) END
-				ELSIF sym = record THEN	(* wrong attribute *)
-					err(178); DevCPS.Get(sym); name := NIL; RecordType(typ, NIL)
-				END
-			ELSE
-				qualident(id);
-				IF id.mode = Typ THEN
-					IF ~(DevCPM.oberon IN DevCPM.options)
-						& ((id.typ = DevCPT.lreal64typ) OR (id.typ = DevCPT.lint64typ) OR (id.typ = DevCPT.lchar16typ)) THEN
-						err(198)
-					END;
-					typ := id.typ
-				ELSIF id.mode = Attr THEN
-					IF sym = record THEN
-						DevCPS.Get(sym); RecordType(typ, id)
-					ELSE err(12)
-					END
-				ELSE err(52)
-				END
-			END
-		ELSIF sym = array THEN
-			DevCPS.Get(sym); ArrayType(typ)
-		ELSIF sym = record THEN
-			DevCPS.Get(sym); RecordType(typ, NIL)
-		ELSIF sym = pointer THEN
-			DevCPS.Get(sym); PointerType(typ)
-		ELSIF sym = procedure THEN
-			DevCPS.Get(sym); typ := DevCPT.NewStr(ProcTyp, Basic);
-			CheckSysFlag(typ.sysflag, DevCPM.GetProcTypSysFlag);
-			typ.untagged := typ.sysflag > 0;
-			IF sym = lparen THEN
-				DevCPS.Get(sym); DevCPT.OpenScope(level, NIL);
-				FormalParameters(typ.link, typ.BaseTyp, tname); SetType(typ, NIL, typ.BaseTyp, tname); DevCPT.CloseScope
-			ELSE typ.BaseTyp := DevCPT.notyp; typ.link := NIL
-			END
-		ELSE err(12)
-		END ;
-		LOOP
-			IF (sym >= semicolon) & (sym <= else) OR (sym = rparen) OR (sym = eof)
-				OR (sym = number) OR (sym = comma) OR (sym = string) THEN EXIT END;
-			err(15); IF sym = ident THEN EXIT END;
-			DevCPS.Get(sym)
-		END
-	END Type;
-	
-	PROCEDURE ActualParameters(VAR aparlist: DevCPT.Node; fpar: DevCPT.Object; VAR pre, lastp: DevCPT.Node);
-		VAR apar, last, newPar, iidPar, n: DevCPT.Node;
-	BEGIN
-		aparlist := NIL; last := NIL;
-		IF sym # rparen THEN
-			newPar := NIL; iidPar := NIL;
-			LOOP Expression(apar);
-				IF fpar # NIL THEN
-					IF (apar.typ.form = Pointer) & (fpar.typ.form = Comp) THEN DevCPB.DeRef(apar) END;
-					DevCPB.Param(apar, fpar);
-					IF (fpar.mode = Var) OR (fpar.vis = inPar) THEN DevCPB.CheckBuffering(apar, NIL, fpar, pre, lastp) END;
-					DevCPB.Link(aparlist, last, apar);
-					IF ODD(fpar.sysflag DIV newBit) THEN newPar := apar
-					ELSIF ODD(fpar.sysflag DIV iidBit) THEN iidPar := apar
-					END;
-					IF (newPar # NIL) & (iidPar # NIL) THEN DevCPB.CheckNewParamPair(newPar, iidPar) END;
-					IF anchorVarPar & (fpar.mode = VarPar) & ~(DevCPM.java IN DevCPM.options)
-						OR (DevCPM.allSysVal IN DevCPM.options)	(* source output: avoid double evaluation *)
-							 & ((fpar.mode = VarPar) & (fpar.typ.comp = Record) & ~fpar.typ.untagged
-								OR (fpar.typ.comp = DynArr) & ~fpar.typ.untagged) THEN
-						n := apar;
-						WHILE n.class IN {Nfield, Nindex, Nguard} DO n := n.left END;
-						IF (n.class = Nderef) & (n.subcl = 0) THEN
-							IF n.left.class = Nguard THEN n := n.left END;
-							DevCPB.CheckVarParBuffering(n.left, pre, lastp)
-						END
-					END;
-					fpar := fpar.link
-				ELSE err(64)
-				END;
-				IF sym = comma THEN DevCPS.Get(sym)
-				ELSIF (lparen <= sym) & (sym <= ident) THEN err(comma)
-				ELSE EXIT
-				END
-			END
-		END;
-		IF fpar # NIL THEN err(65) END
-	END ActualParameters;
-
-	PROCEDURE selector(VAR x: DevCPT.Node);
-		VAR obj, proc, p, fpar: DevCPT.Object; y, apar, pre, lastp: DevCPT.Node; typ: DevCPT.Struct; name: DevCPT.Name;
-	BEGIN
-		LOOP
-			IF sym = lbrak THEN DevCPS.Get(sym);
-				LOOP
-					IF (x.typ # NIL) & (x.typ.form = Pointer) THEN DevCPB.DeRef(x) END ;
-					Expression(y); DevCPB.Index(x, y);
-					IF sym = comma THEN DevCPS.Get(sym) ELSE EXIT END
-				END ;
-				CheckSym(rbrak)
-			ELSIF sym = period THEN DevCPS.Get(sym);
-				IF sym = ident THEN name := DevCPS.name; DevCPS.Get(sym);
-					IF x.typ # NIL THEN
-						IF x.typ.form = Pointer THEN DevCPB.DeRef(x) END ;
-						IF x.typ.comp = Record THEN
-							typ := x.typ; DevCPT.FindField(name, typ, obj); DevCPB.Field(x, obj);
-							IF (obj # NIL) & (obj.mode = TProc) THEN
-								IF sym = arrow THEN  (* super call *) DevCPS.Get(sym);
-									y := x.left;
-									IF y.class = Nderef THEN y := y.left END ;	(* y = record variable *)
-									IF y.obj # NIL THEN
-										proc := DevCPT.topScope;	(* find innermost scope which owner is a TProc *)
-										WHILE (proc.link # NIL) & (proc.link.mode # TProc) DO proc := proc.left END ;
-										IF (proc.link = NIL) OR (proc.link.link # y.obj) (* OR (proc.link.name^ # name) *) THEN err(75)
-										END ;
-										typ := y.obj.typ;
-										IF typ.form = Pointer THEN typ := typ.BaseTyp END ;
-										DevCPT.FindBaseField(x.obj.name^, typ, p);
-										IF p # NIL THEN
-											x.subcl := super; x.typ := p.typ;	(* correct result type *)
-											IF p.conval.setval * {absAttr, empAttr} # {} THEN err(194) END;
-											IF (p.vis = externalR) & (p.mnolev < 0) & (proc.link.name^ # name) THEN err(196) END;
-										ELSE err(74)
-										END
-									ELSE err(75)
-									END
-								ELSE
-									proc := obj;
-									WHILE (proc.mnolev >= 0) & ~(newAttr IN proc.conval.setval) & (typ.BaseTyp # NIL) DO
-										(* find base method *)
-										typ := typ.BaseTyp; DevCPT.FindField(name, typ, proc);
-									END;
-									IF (proc.vis = externalR) & (proc.mnolev < 0) THEN err(196) END;
-								END ;
-								IF (obj.typ # DevCPT.notyp) & (sym # lparen) THEN err(lparen) END
-							END
-						ELSE err(53)
-						END
-					ELSE err(52)
-					END
-				ELSE err(ident)
-				END
-			ELSIF sym = arrow THEN DevCPS.Get(sym); DevCPB.DeRef(x)
-			ELSIF sym = dollar THEN
-				IF x.typ.form = Pointer THEN DevCPB.DeRef(x) END;
-				DevCPS.Get(sym); DevCPB.StrDeref(x)
-			ELSIF sym = lparen THEN
-				IF (x.obj # NIL) & (x.obj.mode IN {XProc, LProc, CProc, TProc}) THEN typ := x.obj.typ
-				ELSIF x.typ.form = ProcTyp THEN typ := x.typ.BaseTyp
-				ELSIF x.class = Nproc THEN EXIT	(* standard procedure *)
-				ELSE typ := NIL
-				END;
-				IF typ # DevCPT.notyp THEN
-					DevCPS.Get(sym);
-					IF typ = NIL THEN	(* type guard *)
-						IF sym = ident THEN
-							qualident(obj);
-							IF obj.mode = Typ THEN DevCPB.TypTest(x, obj, TRUE)
-							ELSE err(52)
-							END
-						ELSE err(ident)
-						END
-					ELSE	(* function call *)
-						pre := NIL; lastp := NIL;
-						DevCPB.PrepCall(x, fpar);
-						IF (x.obj # NIL) & (x.obj.mode = TProc) THEN DevCPB.CheckBuffering(x.left, NIL, x.obj.link, pre, lastp)
-						END;
-						ActualParameters(apar, fpar, pre, lastp);
-						DevCPB.Call(x, apar, fpar);
-						IF pre # NIL THEN DevCPB.Construct(Ncomp, pre, x); pre.typ := x.typ; x := pre END;
-						IF level > 0 THEN DevCPT.topScope.link.leaf := FALSE END
-					END;
-					CheckSym(rparen)
-				ELSE EXIT
-				END
-(*
-			ELSIF (sym = lparen) & (x.class # Nproc) & (x.typ.form # ProcTyp) &
-					((x.obj = NIL) OR (x.obj.mode # TProc)) THEN
-				DevCPS.Get(sym);
-				IF sym = ident THEN
-					qualident(obj);
-					IF obj.mode = Typ THEN DevCPB.TypTest(x, obj, TRUE)
-					ELSE err(52)
-					END
-				ELSE err(ident)
-				END ;
-				CheckSym(rparen)
-*)
-			ELSE EXIT
-			END
-		END
-	END selector;
-
-	PROCEDURE StandProcCall(VAR x: DevCPT.Node);
-		VAR y: DevCPT.Node; m: BYTE; n: SHORTINT;
-	BEGIN m := SHORT(SHORT(x.obj.adr)); n := 0;
-		IF sym = lparen THEN DevCPS.Get(sym);
-			IF sym # rparen THEN
-				LOOP
-					IF n = 0 THEN Expression(x); DevCPB.StPar0(x, m); n := 1
-					ELSIF n = 1 THEN Expression(y); DevCPB.StPar1(x, y, m); n := 2
-					ELSE Expression(y); DevCPB.StParN(x, y, m, n); INC(n)
-					END ;
-					IF sym = comma THEN DevCPS.Get(sym)
-					ELSIF (lparen <= sym) & (sym <= ident) THEN err(comma)
-					ELSE EXIT
-					END
-				END ;
-				CheckSym(rparen)
-			ELSE DevCPS.Get(sym)
-			END ;
-			DevCPB.StFct(x, m, n)
-		ELSE err(lparen)
-		END ;
-		IF (level > 0) & ((m = newfn) OR (m = sysnewfn)) THEN DevCPT.topScope.link.leaf := FALSE END
-	END StandProcCall;
-	
-	PROCEDURE Element(VAR x: DevCPT.Node);
-		VAR y: DevCPT.Node;
-	BEGIN Expression(x);
-		IF sym = upto THEN
-			DevCPS.Get(sym); Expression(y); DevCPB.SetRange(x, y)
-		ELSE DevCPB.SetElem(x)
-		END
-	END Element;
-
-	PROCEDURE Sets(VAR x: DevCPT.Node);
-		VAR y: DevCPT.Node;
-	BEGIN
-		IF sym # rbrace THEN
-			Element(x);
-			LOOP
-				IF sym = comma THEN DevCPS.Get(sym)
-				ELSIF (lparen <= sym) & (sym <= ident) THEN err(comma)
-				ELSE EXIT
-				END ;
-				Element(y); DevCPB.Op(plus, x, y)
-			END
-		ELSE x := DevCPB.EmptySet()
-		END ;
-		CheckSym(rbrace)
-	END Sets;
-	
-	PROCEDURE Factor(VAR x: DevCPT.Node);
-		VAR fpar, id: DevCPT.Object; apar: DevCPT.Node;
-	BEGIN
-		IF sym < not THEN err(13);
-			REPEAT DevCPS.Get(sym) UNTIL sym >= lparen
-		END ;
-		IF sym = ident THEN
-			qualident(id); x := DevCPB.NewLeaf(id); selector(x);
-			IF (x.class = Nproc) & (x.obj.mode = SProc) THEN StandProcCall(x)	(* x may be NIL *)
-(*
-			ELSIF sym = lparen THEN
-				DevCPS.Get(sym); DevCPB.PrepCall(x, fpar);
-				ActualParameters(apar, fpar);
-				DevCPB.Call(x, apar, fpar);
-				CheckSym(rparen);
-				IF level > 0 THEN DevCPT.topScope.link.leaf := FALSE END
-*)
-			END
-		ELSIF sym = number THEN
-			CASE DevCPS.numtyp OF
-			   char:
-				x := DevCPB.NewIntConst(DevCPS.intval); x.typ := DevCPT.char8typ;
-				IF DevCPS.intval > 255 THEN x.typ := DevCPT.char16typ END
-			| integer: x := DevCPB.NewIntConst(DevCPS.intval)
-			| int64: x := DevCPB.NewLargeIntConst(DevCPS.intval, DevCPS.realval)
-			| real: x := DevCPB.NewRealConst(DevCPS.realval, NIL)
-			| real32: x := DevCPB.NewRealConst(DevCPS.realval, DevCPT.real32typ)
-			| real64: x := DevCPB.NewRealConst(DevCPS.realval, DevCPT.real64typ)
-			END ;
-			DevCPS.Get(sym)
-		ELSIF sym = string THEN
-			x := DevCPB.NewString(DevCPS.str, DevCPS.lstr, DevCPS.intval);
-			DevCPS.Get(sym)
-		ELSIF sym = nil THEN
-			x := DevCPB.Nil(); DevCPS.Get(sym)
-		ELSIF sym = lparen THEN
-			DevCPS.Get(sym); Expression(x); CheckSym(rparen)
-		ELSIF sym = lbrak THEN
-			DevCPS.Get(sym); err(lparen); Expression(x); CheckSym(rparen)
-		ELSIF sym = lbrace THEN DevCPS.Get(sym); Sets(x)
-		ELSIF sym = not THEN
-			DevCPS.Get(sym); Factor(x); DevCPB.MOp(not, x)
-		ELSE err(13); DevCPS.Get(sym); x := NIL
-		END ;
-		IF x = NIL THEN x := DevCPB.NewIntConst(1); x.typ := DevCPT.undftyp END
-	END Factor;
-
-	PROCEDURE Term(VAR x: DevCPT.Node);
-		VAR y: DevCPT.Node; mulop: BYTE;
-	BEGIN Factor(x);
-		WHILE (times <= sym) & (sym <= and) DO
-			mulop := sym; DevCPS.Get(sym);
-			Factor(y); DevCPB.Op(mulop, x, y)
-		END
-	END Term;
-
-	PROCEDURE SimpleExpression(VAR x: DevCPT.Node);
-		VAR y: DevCPT.Node; addop: BYTE;
-	BEGIN
-		IF sym = minus THEN DevCPS.Get(sym); Term(x); DevCPB.MOp(minus, x)
-		ELSIF sym = plus THEN DevCPS.Get(sym); Term(x); DevCPB.MOp(plus, x)
-		ELSE Term(x)
-		END ;
-		WHILE (plus <= sym) & (sym <= or) DO
-			addop := sym; DevCPS.Get(sym); Term(y); 
-			IF x.typ.form = Pointer THEN DevCPB.DeRef(x) END;
-			IF (x.typ.comp IN {Array, DynArr}) & (x.typ.BaseTyp.form IN charSet) (* OR (x.typ.sysflag = jstr) *) THEN
-				DevCPB.StrDeref(x)
-			END;
-			IF y.typ.form = Pointer THEN DevCPB.DeRef(y) END;
-			IF (y.typ.comp IN {Array, DynArr}) & (y.typ.BaseTyp.form IN charSet) (* OR (y.typ.sysflag = jstr) *) THEN
-				DevCPB.StrDeref(y)
-			END;
-			DevCPB.Op(addop, x, y)
-		END
-	END SimpleExpression;
-
-	PROCEDURE Expression(VAR x: DevCPT.Node);
-		VAR y, pre, last: DevCPT.Node; obj: DevCPT.Object; relation: BYTE;
-	BEGIN SimpleExpression(x);
-		IF (eql <= sym) & (sym <= geq) THEN
-			relation := sym; DevCPS.Get(sym); SimpleExpression(y);
-			pre := NIL; last := NIL;
-			IF (x.typ.comp IN {Array, DynArr}) & (x.typ.BaseTyp.form IN charSet) THEN
-				DevCPB.StrDeref(x)
-			END;
-			IF (y.typ.comp IN {Array, DynArr}) & (y.typ.BaseTyp.form IN charSet) THEN
-				DevCPB.StrDeref(y)
-			END;
-			DevCPB.CheckBuffering(x, NIL, NIL, pre, last);
-			DevCPB.CheckBuffering(y, NIL, NIL, pre, last);
-			DevCPB.Op(relation, x, y);
-			IF pre # NIL THEN DevCPB.Construct(Ncomp, pre, x); pre.typ := x.typ; x := pre END
-		ELSIF sym = in THEN
-			DevCPS.Get(sym); SimpleExpression(y); DevCPB.In(x, y)
-		ELSIF sym = is THEN
-			DevCPS.Get(sym);
-			IF sym = ident THEN
-				qualident(obj);
-				IF obj.mode = Typ THEN DevCPB.TypTest(x, obj, FALSE)
-				ELSE err(52)
-				END
-			ELSE err(ident)
-			END
-		END
-	END Expression;
-
-	PROCEDURE ProcedureDeclaration(VAR x: DevCPT.Node);
-		VAR proc, fwd: DevCPT.Object;
-			name: DevCPT.Name;
-			mode: BYTE;
-			forward: BOOLEAN;
-			sys: SHORTINT;
-
-		PROCEDURE GetCode;
-			VAR ext: DevCPT.ConstExt; i, n, c: INTEGER; s: ARRAY 256 OF SHORTCHAR;
-		BEGIN
-			n := 0;
-			IF sym = string THEN
-				NEW(ext, DevCPS.intval);
-				WHILE DevCPS.str[n] # 0X DO ext[n+1] := DevCPS.str[n]; INC(n) END ;
-				ext^[0] := SHORT(CHR(n)); DevCPS.Get(sym);
-			ELSE
-				LOOP
-					IF sym = number THEN c := DevCPS.intval; INC(n);
-						IF (c < 0) OR (c > 255) OR (n = 255) THEN
-							err(64); c := 1; n := 1
-						END ;
-						DevCPS.Get(sym); s[n] := SHORT(CHR(c))
-					END ;
-					IF sym = comma THEN DevCPS.Get(sym)
-					ELSIF sym = number THEN err(comma)
-					ELSE s[0] := SHORT(CHR(n)); EXIT
-					END
-				END;
-				NEW(ext, n + 1); i := 0;
-				WHILE i <= n DO ext[i] := s[i]; INC(i) END;
-			END;
-			proc.conval.ext := ext;
-			INCL(proc.conval.setval, hasBody)
-		END GetCode;
-
-		PROCEDURE GetParams;
-			VAR name: DevCPT.String;
-		BEGIN
-			proc.mode := mode; proc.typ := DevCPT.notyp;
-			proc.sysflag := SHORT(sys);
-			proc.conval.setval := {};
-			IF sym = lparen THEN
-				DevCPS.Get(sym); FormalParameters(proc.link, proc.typ, name);
-				IF name # NIL THEN err(0) END
-			END;
-			CheckForwardTypes; userList := NIL;
-			IF fwd # NIL THEN
-				DevCPB.CheckParameters(proc.link, fwd.link, TRUE);
-				IF ~DevCPT.EqualType(proc.typ, fwd.typ) THEN err(117) END ;
-				proc := fwd; DevCPT.topScope := proc.scope;
-				IF mode = IProc THEN proc.mode := IProc END
-			END
-		END GetParams;
-
-		PROCEDURE Body;
-			VAR procdec, statseq: DevCPT.Node; c: INTEGER;
-		BEGIN
-			c := DevCPM.errpos;
-			INCL(proc.conval.setval, hasBody);
-			CheckSym(semicolon); Block(procdec, statseq);
-			DevCPB.Enter(procdec, statseq, proc); x := procdec;
-			x.conval := DevCPT.NewConst(); x.conval.intval := c; x.conval.intval2 := DevCPM.startpos;
-			CheckSym(end);
-			IF sym = ident THEN
-				IF DevCPS.name # proc.name^ THEN err(4) END ;
-				DevCPS.Get(sym)
-			ELSE err(ident)
-			END
-		END Body;
-
-		PROCEDURE TProcDecl;
-			VAR baseProc, o, bo: DevCPT.Object;
-				objTyp, recTyp: DevCPT.Struct;
-				objMode, objVis: BYTE;
-				objName: DevCPT.Name;
-				pnode: DevCPT.Node;
-				fwdAttr: SET;
-		BEGIN
-			DevCPS.Get(sym); mode := TProc;
-			IF level > 0 THEN err(73) END;
-			Receiver(objMode, objVis, objName, objTyp, recTyp);
-			IF sym = ident THEN
-				name := DevCPS.name;
-				DevCPT.FindField(name, recTyp, fwd);
-				DevCPT.FindBaseField(name, recTyp, baseProc);
-				IF (baseProc # NIL) & (baseProc.mode # TProc) THEN baseProc := NIL; err(1) END ;
-				IF fwd = baseProc THEN fwd := NIL END ;
-				IF (fwd # NIL) & (fwd.mnolev # level) THEN fwd := NIL END ;
-				IF (fwd # NIL) & (fwd.mode = TProc) & (fwd.conval.setval * {hasBody, absAttr, empAttr} = {}) THEN
-					(* there exists a corresponding forward declaration *)
-					proc := DevCPT.NewObj(); proc.leaf := TRUE;
-					proc.mode := TProc; proc.conval := DevCPT.NewConst();
-					CheckMark(proc);
-					IF fwd.vis # proc.vis THEN err(118) END;
-					fwdAttr := fwd.conval.setval
-				ELSE
-					IF fwd # NIL THEN err(1); fwd := NIL END ;
-					DevCPT.InsertField(name, recTyp, proc);
-					proc.mode := TProc; proc.conval := DevCPT.NewConst();
-					CheckMark(proc);
-					IF recTyp.strobj # NIL THEN	(* preserve declaration order *)
-						o := recTyp.strobj.link;
-						IF o = NIL THEN recTyp.strobj.link := proc
-						ELSE
-							WHILE o.nlink # NIL DO o := o.nlink END;
-							o.nlink := proc
-						END
-					END
-				END;
-				INC(level); DevCPT.OpenScope(level, proc);
-				DevCPT.Insert(objName, proc.link); proc.link.mode := objMode; proc.link.vis := objVis; proc.link.typ := objTyp;
-				ASSERT(DevCPT.topScope # NIL);
-				GetParams;	(* may change proc := fwd !!! *)
-				ASSERT(DevCPT.topScope # NIL);
-				GetAttributes(proc, baseProc, recTyp);
-				IF (fwd # NIL) & (fwdAttr / proc.conval.setval * {absAttr, empAttr, extAttr} # {}) THEN err(184) END;
-				CheckOverwrite(proc, baseProc, recTyp);
-				IF ~forward THEN
-					IF empAttr IN proc.conval.setval THEN	(* insert empty procedure *)
-						pnode := NIL; DevCPB.Enter(pnode, NIL, proc);
-						pnode.conval := DevCPT.NewConst();
-						pnode.conval.intval := DevCPM.errpos;
-						pnode.conval.intval2 := DevCPM.errpos;
-						x := pnode;
-					ELSIF DevCPM.noCode IN DevCPM.options THEN INCL(proc.conval.setval, hasBody)
-					ELSIF ~(absAttr IN proc.conval.setval) THEN Body
-					END;
-					proc.adr := 0
-				ELSE
-					proc.adr := DevCPM.errpos;
-					IF proc.conval.setval * {empAttr, absAttr} # {} THEN err(184) END
-				END;
-				DEC(level); DevCPT.CloseScope;
-			ELSE err(ident)
-			END;
-		END TProcDecl;
-	
-	BEGIN proc := NIL; forward := FALSE; x := NIL; mode := LProc; sys := 0;
-		IF (sym # ident) & (sym # lparen) THEN
-			CheckSysFlag(sys, DevCPM.GetProcSysFlag);
-			IF sys # 0 THEN
-				IF ODD(sys DIV DevCPM.CProcFlag) THEN mode := CProc END
-			ELSE
-				IF sym = times THEN	(* mode set later in DevCPB.CheckAssign *)
-				ELSIF sym = arrow THEN forward := TRUE
-				ELSE err(ident)
-				END;
-				DevCPS.Get(sym)
-			END
-		END ;
-		IF sym = lparen THEN TProcDecl
-		ELSIF sym = ident THEN DevCPT.Find(DevCPS.name, fwd);
-			name := DevCPS.name;
-			IF (fwd # NIL) & ((fwd.mnolev # level) OR (fwd.mode = SProc)) THEN fwd := NIL END ;
-			IF (fwd # NIL) & (fwd.mode IN {LProc, XProc}) & ~(hasBody IN fwd.conval.setval) THEN
-				(* there exists a corresponding forward declaration *)
-				proc := DevCPT.NewObj(); proc.leaf := TRUE;
-				proc.mode := mode; proc.conval := DevCPT.NewConst();
-				CheckMark(proc);
-				IF fwd.vis # proc.vis THEN err(118) END
-			ELSE
-				IF fwd # NIL THEN err(1); fwd := NIL END ;
-				DevCPT.Insert(name, proc);
-				proc.mode := mode; proc.conval := DevCPT.NewConst();
-				CheckMark(proc);
-			END ;
-			IF (proc.vis # internal) & (mode = LProc) THEN mode := XProc END ;
-			IF (mode # LProc) & (level > 0) THEN err(73) END ;
-			INC(level); DevCPT.OpenScope(level, proc);
-			proc.link := NIL; GetParams;	(* may change proc := fwd !!! *)
-			IF mode = CProc THEN GetCode
-			ELSIF DevCPM.noCode IN DevCPM.options THEN INCL(proc.conval.setval, hasBody)
-			ELSIF ~forward THEN Body; proc.adr := 0
-			ELSE proc.adr := DevCPM.errpos
-			END ;
-			DEC(level); DevCPT.CloseScope
-		ELSE err(ident)
-		END
-	END ProcedureDeclaration;
-
-	PROCEDURE CaseLabelList(VAR lab, root: DevCPT.Node; LabelForm: SHORTINT; VAR min, max: INTEGER);
-		VAR x, y, lastlab: DevCPT.Node; i, f: SHORTINT; xval, yval: INTEGER;
-		
-		PROCEDURE Insert(VAR n: DevCPT.Node);	(* build binary tree of label ranges *)	(* !!! *)
-		BEGIN
-			IF n = NIL THEN
-				IF x.hint # 1 THEN n := x END
-			ELSIF yval < n.conval.intval THEN Insert(n.left)
-			ELSIF xval > n.conval.intval2 THEN Insert(n.right)
-			ELSE err(63)
-			END
-		END Insert;
-		
-	BEGIN lab := NIL; lastlab := NIL;
-		LOOP ConstExpression(x); f := x.typ.form;
-			IF f IN {Int8..Int32} + charSet THEN  xval := x.conval.intval
-			ELSE err(61); xval := 1
-			END ;
-			IF (f IN {Int8..Int32}) # (LabelForm IN {Int8..Int32}) THEN err(60) END;
-			IF sym = upto THEN
-				DevCPS.Get(sym); ConstExpression(y); yval := y.conval.intval;
-				IF (y.typ.form IN {Int8..Int32}) # (LabelForm IN {Int8..Int32}) THEN err(60) END;
-				IF yval < xval THEN err(63); yval := xval END
-			ELSE yval := xval
-			END ;
-			x.conval.intval2 := yval;
-			IF xval < min THEN min := xval END;
-			IF yval > max THEN max := yval END;
-			IF lab = NIL THEN lab := x; Insert(root)
-			ELSIF yval < lab.conval.intval - 1 THEN x.link := lab; lab := x; Insert(root)
-			ELSIF yval = lab.conval.intval - 1 THEN x.hint := 1; Insert(root); lab.conval.intval := xval
-			ELSIF xval = lab.conval.intval2 + 1 THEN x.hint := 1; Insert(root); lab.conval.intval2 := yval
-			ELSE
-				y := lab;
-				WHILE (y.link # NIL) & (xval > y.link.conval.intval2 + 1) DO y := y.link END;
-				IF y.link = NIL THEN y.link := x; Insert(root)
-				ELSIF yval < y.link.conval.intval - 1 THEN x.link := y.link; y.link := x; Insert(root)
-				ELSIF yval = y.link.conval.intval - 1 THEN x.hint := 1; Insert(root); y.link.conval.intval := xval
-				ELSIF xval = y.link.conval.intval2 + 1 THEN x.hint := 1; Insert(root); y.link.conval.intval2 := yval
-				END
-			END;
-			IF sym = comma THEN DevCPS.Get(sym)
-			ELSIF (sym = number) OR (sym = ident) THEN err(comma)
-			ELSE EXIT
-			END
-		END
-	END CaseLabelList;
-	
-	PROCEDURE StatSeq(VAR stat: DevCPT.Node);
-		VAR fpar, id, t, obj: DevCPT.Object; idtyp: DevCPT.Struct; e: BOOLEAN;
-				s, x, y, z, apar, last, lastif, pre, lastp: DevCPT.Node; pos, p: INTEGER; name: DevCPT.Name;
-
-		PROCEDURE CasePart(VAR x: DevCPT.Node);
-			VAR low, high: INTEGER; e: BOOLEAN; cases, lab, y, lastcase, root: DevCPT.Node; 
-		BEGIN
-			Expression(x);
-			IF (x.class = Ntype) OR (x.class = Nproc) THEN err(126)
-			ELSIF x.typ.form = Int64 THEN err(260)
-			ELSIF ~(x.typ.form IN {Int8..Int32} + charSet) THEN err(125)
-			END ;
-			CheckSym(of); cases := NIL; lastcase := NIL; root := NIL;
-			low := MAX(INTEGER); high := MIN(INTEGER);
-			LOOP
-				IF sym < bar THEN
-					CaseLabelList(lab, root, x.typ.form, low, high);
-					CheckSym(colon); StatSeq(y);
-					DevCPB.Construct(Ncasedo, lab, y); DevCPB.Link(cases, lastcase, lab)
-				END ;
-				IF sym = bar THEN DevCPS.Get(sym) ELSE EXIT END
-			END;
-			e := sym = else;
-			IF e THEN DevCPS.Get(sym); StatSeq(y) ELSE y := NIL END ;
-			DevCPB.Construct(Ncaselse, cases, y); DevCPB.Construct(Ncase, x, cases);
-			cases.conval := DevCPT.NewConst();
-			cases.conval.intval := low; cases.conval.intval2 := high;
-			IF e THEN cases.conval.setval := {1} ELSE cases.conval.setval := {} END;
-			DevCPB.OptimizeCase(root); cases.link := root	(* !!! *)
-		END CasePart;
-		
-		PROCEDURE SetPos(x: DevCPT.Node);
-		BEGIN
-			x.conval := DevCPT.NewConst(); x.conval.intval := pos
-		END SetPos;
-
-		PROCEDURE CheckBool(VAR x: DevCPT.Node);
-		BEGIN
-			IF (x.class = Ntype) OR (x.class = Nproc) THEN err(126); x := DevCPB.NewBoolConst(FALSE)
-			ELSIF x.typ.form # Bool THEN err(120); x := DevCPB.NewBoolConst(FALSE)
-			END
-		END CheckBool;
-
-	BEGIN stat := NIL; last := NIL;
-		LOOP x := NIL;
-			IF sym < ident THEN err(14);
-				REPEAT DevCPS.Get(sym) UNTIL sym >= ident
-			END ;
-			pos := DevCPM.startpos;
-			IF sym = ident THEN
-				qualident(id); x := DevCPB.NewLeaf(id); selector(x);
-				IF sym = becomes THEN
-					DevCPS.Get(sym); Expression(y);
-					IF (y.typ.form = Pointer) & (x.typ.form = Comp) THEN DevCPB.DeRef(y) END;
-					pre := NIL; lastp := NIL;
-					DevCPB.CheckBuffering(y, x, NIL, pre, lastp);
-					DevCPB.Assign(x, y);
-					IF pre # NIL THEN SetPos(x); DevCPB.Construct(Ncomp, pre, x); x := pre END;
-				ELSIF sym = eql THEN
-					err(becomes); DevCPS.Get(sym); Expression(y); DevCPB.Assign(x, y)
-				ELSIF (x.class = Nproc) & (x.obj.mode = SProc) THEN
-					StandProcCall(x);
-					IF (x # NIL) & (x.typ # DevCPT.notyp) THEN err(55) END;
-					IF (x # NIL) & (x.class = Nifelse) THEN	(* error pos for ASSERT *)
-						SetPos(x.left); SetPos(x.left.right)
-					END
-				ELSIF x.class = Ncall THEN err(55)
-				ELSE
-					pre := NIL; lastp := NIL;
-					DevCPB.PrepCall(x, fpar);
-					IF (x.obj # NIL) & (x.obj.mode = TProc) THEN DevCPB.CheckBuffering(x.left, NIL, x.obj.link, pre, lastp) END;
-					IF sym = lparen THEN
-						DevCPS.Get(sym); ActualParameters(apar, fpar, pre, lastp); CheckSym(rparen)
-					ELSE apar := NIL;
-						IF fpar # NIL THEN err(65) END
-					END ;
-					DevCPB.Call(x, apar, fpar);
-					IF x.typ # DevCPT.notyp THEN err(55) END;
-					IF pre # NIL THEN SetPos(x); DevCPB.Construct(Ncomp, pre, x); x := pre END;
-					IF level > 0 THEN DevCPT.topScope.link.leaf := FALSE END
-				END
-			ELSIF sym = if THEN
-				DevCPS.Get(sym); pos := DevCPM.startpos; Expression(x); CheckBool(x); CheckSym(then); StatSeq(y);
-				DevCPB.Construct(Nif, x, y); SetPos(x); lastif := x;
-				WHILE sym = elsif DO
-					DevCPS.Get(sym); pos := DevCPM.startpos; Expression(y); CheckBool(y); CheckSym(then); StatSeq(z);
-					DevCPB.Construct(Nif, y, z); SetPos(y); DevCPB.Link(x, lastif, y)
-				END ;
-				pos := DevCPM.startpos;
-				IF sym = else THEN DevCPS.Get(sym); StatSeq(y) ELSE y := NIL END ;
-				DevCPB.Construct(Nifelse, x, y); CheckSym(end); DevCPB.OptIf(x);
-			ELSIF sym = case THEN
-				DevCPS.Get(sym); pos := DevCPM.startpos; CasePart(x); CheckSym(end)
-			ELSIF sym = while THEN
-				DevCPS.Get(sym); pos := DevCPM.startpos; Expression(x); CheckBool(x); CheckSym(do); StatSeq(y);
-				DevCPB.Construct(Nwhile, x, y); CheckSym(end)
-			ELSIF sym = repeat THEN
-				DevCPS.Get(sym); StatSeq(x);
-				IF sym = until THEN DevCPS.Get(sym); pos := DevCPM.startpos; Expression(y); CheckBool(y)
-				ELSE err(43)
-				END ;
-				DevCPB.Construct(Nrepeat, x, y)
-			ELSIF sym = for THEN
-				DevCPS.Get(sym); pos := DevCPM.startpos;
-				IF sym = ident THEN qualident(id);
-					IF ~(id.typ.form IN intSet) THEN err(68) END ;
-					CheckSym(becomes); Expression(y);
-					x := DevCPB.NewLeaf(id); DevCPB.Assign(x, y); SetPos(x);
-					CheckSym(to); pos := DevCPM.startpos; Expression(y);
-					IF y.class # Nconst THEN
-						DevCPB.GetTempVar("@for", x.left.typ, t);
-						z := DevCPB.NewLeaf(t); DevCPB.Assign(z, y); SetPos(z); DevCPB.Link(stat, last, z);
-						y := DevCPB.NewLeaf(t)
-					ELSE
-						DevCPB.CheckAssign(x.left.typ, y)
-					END ;
-					DevCPB.Link(stat, last, x);
-					p := DevCPM.startpos;
-					IF sym = by THEN DevCPS.Get(sym); ConstExpression(z) ELSE z := DevCPB.NewIntConst(1) END ;
-					x := DevCPB.NewLeaf(id);
-					IF z.conval.intval > 0 THEN DevCPB.Op(leq, x, y)
-					ELSIF z.conval.intval < 0 THEN DevCPB.Op(geq, x, y)
-					ELSE err(63); DevCPB.Op(geq, x, y)
-					END ;
-					CheckSym(do); StatSeq(s);
-					y := DevCPB.NewLeaf(id); DevCPB.StPar1(y, z, incfn); pos := DevCPM.startpos; SetPos(y);
-					IF s = NIL THEN s := y
-					ELSE z := s;
-						WHILE z.link # NIL DO z := z.link END ;
-						z.link := y
-					END ;
-					CheckSym(end); DevCPB.Construct(Nwhile, x, s); pos := p
-				ELSE err(ident)
-				END
-			ELSIF sym = loop THEN
-				DevCPS.Get(sym); INC(LoopLevel); StatSeq(x); DEC(LoopLevel);
-				DevCPB.Construct(Nloop, x, NIL); CheckSym(end)
-			ELSIF sym = with THEN
-				DevCPS.Get(sym); idtyp := NIL; x := NIL;
-				LOOP
-					IF sym < bar THEN
-						pos := DevCPM.startpos;
-						IF sym = ident THEN
-							qualident(id); y := DevCPB.NewLeaf(id);
-							IF (id # NIL) & (id.typ.form = Pointer) & ((id.mode = VarPar) OR ~id.leaf) THEN
-								err(-302)	(* warning 302 *)
-							END ;
-							CheckSym(colon);
-							IF sym = ident THEN qualident(t);
-								IF t.mode = Typ THEN
-									IF id # NIL THEN
-										idtyp := id.typ; DevCPB.TypTest(y, t, FALSE); id.typ := t.typ;
-										IF id.ptyp = NIL THEN id.ptyp := idtyp END
-									ELSE err(130)
-									END
-								ELSE err(52)
-								END
-							ELSE err(ident)
-							END
-						ELSE err(ident)
-						END ;
-						CheckSym(do); StatSeq(s); DevCPB.Construct(Nif, y, s); SetPos(y);
-						IF idtyp # NIL THEN
-							IF id.ptyp = idtyp THEN id.ptyp := NIL END;
-							id.typ := idtyp; idtyp := NIL
-						END ;
-						IF x = NIL THEN x := y; lastif := x ELSE DevCPB.Link(x, lastif, y) END
-					END;
-					IF sym = bar THEN DevCPS.Get(sym) ELSE EXIT END
-				END;
-				e := sym = else; pos := DevCPM.startpos;
-				IF e THEN DevCPS.Get(sym); StatSeq(s) ELSE s := NIL END ;
-				DevCPB.Construct(Nwith, x, s); CheckSym(end);
-				IF e THEN x.subcl := 1 END
-			ELSIF sym = exit THEN
-				DevCPS.Get(sym);
-				IF LoopLevel = 0 THEN err(46) END ;
-				DevCPB.Construct(Nexit, x, NIL)
-			ELSIF sym = return THEN DevCPS.Get(sym);
-				IF sym < semicolon THEN Expression(x) END ;
-				IF level > 0 THEN DevCPB.Return(x, DevCPT.topScope.link)
-				ELSE (* not standard Oberon *) DevCPB.Return(x, NIL)
-				END;
-				hasReturn := TRUE
-			END ;
-			IF x # NIL THEN SetPos(x); DevCPB.Link(stat, last, x) END ;
-			IF sym = semicolon THEN DevCPS.Get(sym)
-			ELSIF (sym <= ident) OR (if <= sym) & (sym <= return) THEN err(semicolon)
-			ELSE EXIT
-			END
-		END
-	END StatSeq;
-
-	PROCEDURE Block(VAR procdec, statseq: DevCPT.Node);
-		VAR typ: DevCPT.Struct;
-			obj, first, last, o: DevCPT.Object;
-			x, lastdec: DevCPT.Node;
-			i: SHORTINT;
-			rname: DevCPT.Name;
-			name: DevCPT.String;
-			rec: Elem;
-
-	BEGIN
-		IF ((sym < begin) OR (sym > var)) & (sym # procedure) & (sym # end) & (sym # close) THEN err(36) END;
-		first := NIL; last := NIL; userList := NIL; recList := NIL;
-		LOOP
-			IF sym = const THEN
-				DevCPS.Get(sym);
-				WHILE sym = ident DO
-					DevCPT.Insert(DevCPS.name, obj);
-					obj.mode := Con; CheckMark(obj);
-					obj.typ := DevCPT.int8typ; obj.mode := Var;	(* Var to avoid recursive definition *)
-					IF sym = eql THEN
-						DevCPS.Get(sym); ConstExpression(x)
-					ELSIF sym = becomes THEN
-						err(eql); DevCPS.Get(sym); ConstExpression(x)
-					ELSE err(eql); x := DevCPB.NewIntConst(1)
-					END ;
-					obj.mode := Con; obj.typ := x.typ; obj.conval := x.conval; (* ConstDesc ist not copied *)
-					CheckSym(semicolon)
-				END
-			END ;
-			IF sym = type THEN
-				DevCPS.Get(sym);
-				WHILE sym = ident DO
-					DevCPT.Insert(DevCPS.name, obj); obj.mode := Typ; obj.typ := DevCPT.undftyp;
-					CheckMark(obj); obj.mode := -1;
-					IF sym # eql THEN err(eql) END;
-					IF (sym = eql) OR (sym = becomes) OR (sym = colon) THEN
-						DevCPS.Get(sym); Type(obj.typ, name); SetType(NIL, obj, obj.typ, name);
-					END;
-					obj.mode := Typ;
-					IF obj.typ.form IN {Byte..Set, Char16, Int64} THEN	(* make alias structure *)
-						typ := DevCPT.NewStr(obj.typ.form, Basic); i := typ.ref;
-						typ^ := obj.typ^; typ.ref := i; typ.strobj := NIL; typ.mno := 0; typ.txtpos := DevCPM.errpos;
-						typ.BaseTyp := obj.typ; obj.typ := typ;
-					END;
-					IF obj.typ.strobj = NIL THEN obj.typ.strobj := obj END ;
-					IF obj.typ.form = Pointer THEN	(* !!! *)
-						typ := obj.typ.BaseTyp;
-						IF (typ # NIL) & (typ.comp = Record) & (typ.strobj = NIL) THEN
-							(* pointer to unnamed record: name record as "pointerName^" *)
-							rname := obj.name^$; i := 0;
-							WHILE rname[i] # 0X DO INC(i) END;
-							rname[i] := "^"; rname[i+1] := 0X;
-							DevCPT.Insert(rname, o); o.mode := Typ; o.typ := typ; typ.strobj := o
-						END
-					END;
-					IF obj.vis # internal THEN
-						typ := obj.typ;
-						IF typ.form = Pointer THEN typ := typ.BaseTyp END;
-						IF typ.comp = Record THEN typ.exp := TRUE END
-					END;
-					CheckSym(semicolon)
-				END
-			END ;
-			IF sym = var THEN
-				DevCPS.Get(sym);
-				WHILE sym = ident DO
-					LOOP
-						IF sym = ident THEN
-							DevCPT.Insert(DevCPS.name, obj);
-							obj.mode := Var; obj.link := NIL; obj.leaf := obj.vis = internal; obj.typ := DevCPT.undftyp;
-							CheckMark(obj);
-							IF first = NIL THEN first := obj END ;
-							IF last = NIL THEN DevCPT.topScope.scope := obj ELSE last.link := obj END ;
-							last := obj
-						ELSE err(ident)
-						END ;
-						IF sym = comma THEN DevCPS.Get(sym)
-						ELSIF sym = ident THEN err(comma)
-						ELSE EXIT
-						END
-					END ;
-					CheckSym(colon); Type(typ, name);
-					CheckAlloc(typ, FALSE, DevCPM.errpos);
-					WHILE first # NIL DO SetType(NIL, first, typ, name); first := first.link END ;
-					CheckSym(semicolon)
-				END
-			END ;
-			IF (sym < const) OR (sym > var) THEN EXIT END ;
-		END ;
-		CheckForwardTypes;
-		userList := NIL; rec := recList; recList := NIL;
-		DevCPT.topScope.adr := DevCPM.errpos;
-		procdec := NIL; lastdec := NIL;
-		IF (sym # procedure) & (sym # begin) & (sym # end) & (sym # close) THEN err(37) END;
-		WHILE sym = procedure DO
-			DevCPS.Get(sym); ProcedureDeclaration(x);
-			IF x # NIL THEN
-				IF lastdec = NIL THEN procdec := x ELSE lastdec.link := x END ;
-				lastdec := x
-			END ;
-			CheckSym(semicolon)
-		END ;
-		IF DevCPM.noerr & ~(DevCPM.oberon IN DevCPM.options) THEN CheckRecords(rec) END;
-		hasReturn := FALSE;
-		IF (sym # begin) & (sym # end) & (sym # close) THEN err(38) END;
-		IF sym = begin THEN DevCPS.Get(sym); StatSeq(statseq)
-		ELSE statseq := NIL
-		END ;
-		IF (DevCPT.topScope.link # NIL) & (DevCPT.topScope.link.typ # DevCPT.notyp)
-			& ~hasReturn & (DevCPT.topScope.link.sysflag = 0) THEN err(133) END;
-		IF (level = 0) & (TDinit # NIL) THEN
-			lastTDinit.link := statseq; statseq := TDinit
-		END
-	END Block;
-
-	PROCEDURE Module*(VAR prog: DevCPT.Node);
-		VAR impName, aliasName: DevCPT.Name;
-				procdec, statseq: DevCPT.Node;
-				c, sf: INTEGER; done: BOOLEAN;
-	BEGIN
-		DevCPS.Init; LoopLevel := 0; level := 0; DevCPS.Get(sym);
-		IF sym = module THEN DevCPS.Get(sym) ELSE err(16) END ;
-		IF sym = ident THEN
-			DevCPT.Open(DevCPS.name); DevCPS.Get(sym);
-			DevCPT.libName := "";
-			IF sym = lbrak THEN
-				INCL(DevCPM.options, DevCPM.interface); DevCPS.Get(sym);
-				IF sym = eql THEN DevCPS.Get(sym)
-				ELSE INCL(DevCPM.options, DevCPM.noCode)
-				END;
-				IF sym = string THEN DevCPT.libName := DevCPS.str^$; DevCPS.Get(sym)
-				ELSE err(string)
-				END;
-				CheckSym(rbrak)
-			END;
-			CheckSym(semicolon);
-			IF sym = import THEN DevCPS.Get(sym);
-				LOOP
-					IF sym = ident THEN
-						aliasName := DevCPS.name$; impName := aliasName$; DevCPS.Get(sym);
-						IF sym = becomes THEN DevCPS.Get(sym);
-							IF sym = ident THEN impName := DevCPS.name$; DevCPS.Get(sym) ELSE err(ident) END
-						END ;
-						DevCPT.Import(aliasName, impName, done)
-					ELSE err(ident)
-					END ;
-					IF sym = comma THEN DevCPS.Get(sym)
-					ELSIF sym = ident THEN err(comma)
-					ELSE EXIT
-					END
-				END ;
-				CheckSym(semicolon)
-			END ;
-			IF DevCPM.noerr THEN TDinit := NIL; lastTDinit := NIL; c := DevCPM.errpos;
-				Block(procdec, statseq); DevCPB.Enter(procdec, statseq, NIL); prog := procdec;
-				prog.conval := DevCPT.NewConst(); prog.conval.intval := c; prog.conval.intval2 := DevCPM.startpos;
-				IF sym = close THEN DevCPS.Get(sym); StatSeq(prog.link) END;
-				prog.conval.realval := DevCPM.startpos;
-				CheckSym(end);
-				IF sym = ident THEN
-					IF DevCPS.name # DevCPT.SelfName THEN err(4) END ;
-					DevCPS.Get(sym)
-				ELSE err(ident)
-				END;
-				IF sym # period THEN err(period) END
-			END
-		ELSE err(ident)
-		END ;
-		TDinit := NIL; lastTDinit := NIL;
-		DevCPS.str := NIL
-	END Module;
-
-END DevCPP.

BlackBox/Dev/Mod/CPS.txt

@@ -1,367 +0,0 @@
-MODULE DevCPS;
-
-	(* THIS IS TEXT COPY OF BlackBox 1.6-rc6 Dev/Mod/CPS.odc *)
-	(* DO NOT EDIT *)
-	(* SEE XXX *)
-
-	IMPORT SYSTEM, Math, DevCPM, DevCPT;
-	
-	CONST
-		MaxIdLen = 256;
-	
-	TYPE
-(*
-		Name* = ARRAY MaxIdLen OF SHORTCHAR;
-		String* = POINTER TO ARRAY OF SHORTCHAR;
-*)
-
-	(* name, str, numtyp, intval, realval, realval are implicit results of Get *)
-
-	VAR
-		name*: DevCPT.Name;
-		str*: DevCPT.String;
-		lstr*: POINTER TO ARRAY OF CHAR;
-		numtyp*: SHORTINT; (* 1 = char, 2 = integer, 4 = real, 5 = int64, 6 = real32, 7 = real64 *)
-		intval*: INTEGER;	(* integer value or string length (incl. 0X) *)
-		realval*: REAL;
-
-
-	CONST
-		(* numtyp values *)
-		char = 1; integer = 2; real = 4; int64 = 5; real32 = 6; real64 = 7;
-
-		(*symbol values*)
-		null = 0; times = 1; slash = 2; div = 3; mod = 4;
-		and = 5; plus = 6; minus = 7; or = 8; eql = 9;
-		neq = 10; lss = 11; leq = 12; gtr = 13; geq = 14;
-		in = 15; is = 16; arrow = 17; dollar = 18; period = 19;
-		comma = 20; colon = 21; upto = 22; rparen = 23; rbrak = 24;
-		rbrace = 25; of = 26; then = 27; do = 28; to = 29;
-		by = 30; not = 33;
-		lparen = 40; lbrak = 41; lbrace = 42; becomes = 44;
-		number = 45; nil = 46; string = 47; ident = 48; semicolon = 49;
-		bar = 50; end = 51; else = 52; elsif = 53; until = 54;
-		if = 55; case = 56; while = 57; repeat = 58; for = 59;
-		loop = 60; with = 61; exit = 62; return = 63; array = 64;
-		record = 65; pointer = 66; begin = 67; const = 68; type = 69;
-		var = 70; out = 71; procedure = 72; close = 73; import = 74;
-		module = 75; eof = 76;
-
-	VAR
-		ch: SHORTCHAR;     (*current character*)
-
-	PROCEDURE err(n: SHORTINT);
-	BEGIN DevCPM.err(n)
-	END err;
-	
-	PROCEDURE Str(VAR sym: BYTE);
-		VAR i: SHORTINT; och: SHORTCHAR; lch: CHAR; long: BOOLEAN;
-			s: ARRAY 256 OF CHAR; t: POINTER TO ARRAY OF CHAR;
-	BEGIN i := 0; och := ch; long := FALSE;
-		LOOP DevCPM.GetL(lch);
-			IF lch = och THEN EXIT END ;
-			IF (lch < " ") & (lch # 9X) THEN err(3); EXIT END;
-			IF lch > 0FFX THEN long := TRUE END;
-			IF i < LEN(s) - 1 THEN s[i] := lch
-			ELSIF i = LEN(s) - 1 THEN s[i] := 0X; NEW(lstr, 2 * LEN(s)); lstr^ := s$; lstr[i] := lch
-			ELSIF i < LEN(lstr^) - 1 THEN lstr[i] := lch
-			ELSE t := lstr; t[i] := 0X; NEW(lstr, 2 * LEN(t^)); lstr^ := t^$; lstr[i] := lch
-			END;
-			INC(i)
-		END ;
-		IF i = 1 THEN sym := number; numtyp := 1; intval := ORD(s[0])
-		ELSE
-			sym := string; numtyp := 0; intval := i + 1; NEW(str, intval);
-			IF long THEN
-				IF i < LEN(s) THEN s[i] := 0X; NEW(lstr, intval); lstr^ := s$
-				ELSE lstr[i] := 0X
-				END;
-				str^ := SHORT(lstr$)
-			ELSE
-				IF i < LEN(s) THEN s[i] := 0X; str^ := SHORT(s$);
-				ELSE lstr[i] := 0X; str^ := SHORT(lstr$)
-				END;
-				lstr := NIL
-			END
-		END;
-		DevCPM.Get(ch)
-	END Str;
-
-	PROCEDURE Identifier(VAR sym: BYTE);
-		VAR i: SHORTINT;
-	BEGIN i := 0;
-		REPEAT
-			name[i] := ch; INC(i); DevCPM.Get(ch)
-		UNTIL (ch < "0")
-			OR ("9" < ch) & (CAP(ch) < "A")
-			OR ("Z" < CAP(ch)) & (ch # "_") & (ch < "À")
-			OR (ch = "×")
-			OR (ch = "÷")
-			OR (i = MaxIdLen);
-		IF i = MaxIdLen THEN err(240); DEC(i) END ;
-		name[i] := 0X; sym := ident
-	END Identifier;
-
-	PROCEDURE Number;
-		VAR i, j, m, n, d, e, a: INTEGER; f, g, x: REAL; expCh, tch: SHORTCHAR; neg: BOOLEAN; r: SHORTREAL;
-			dig: ARRAY 30 OF SHORTCHAR; arr: ARRAY 2 OF INTEGER;
-
-		PROCEDURE Ord(ch: SHORTCHAR; hex: BOOLEAN): SHORTINT;
-		BEGIN (* ("0" <= ch) & (ch <= "9") OR ("A" <= ch) & (ch <= "F") *)
-			IF ch <= "9" THEN RETURN SHORT(ORD(ch) - ORD("0"))
-			ELSIF hex THEN RETURN SHORT(ORD(ch) - ORD("A") + 10)
-			ELSE err(2); RETURN 0
-			END
-		END Ord;
-		
-	BEGIN (* ("0" <= ch) & (ch <= "9") *)
-		i := 0; m := 0; n := 0; d := 0;
-		LOOP (* read mantissa *)
-			IF ("0" <= ch) & (ch <= "9") OR (d = 0) & ("A" <= ch) & (ch <= "F") THEN
-				IF (m > 0) OR (ch # "0") THEN (* ignore leading zeros *)
-					IF n < LEN(dig) THEN dig[n] := ch; INC(n) END;
-					INC(m)
-				END;
-				DevCPM.Get(ch); INC(i)
-			ELSIF ch = "." THEN DevCPM.Get(ch);
-				IF ch = "." THEN (* ellipsis *) ch := 7FX; EXIT
-				ELSIF d = 0 THEN (* i > 0 *) d := i
-				ELSE err(2)
-				END
-			ELSE EXIT
-			END
-		END; (* 0 <= n <= m <= i, 0 <= d <= i *)
-		IF d = 0 THEN (* integer *) realval := 0; numtyp := integer;
-			IF n = m THEN intval := 0; i := 0;
-				IF ch = "X" THEN (* character *) DevCPM.Get(ch); numtyp := char;
-					IF n <= 4 THEN
-						WHILE i < n DO intval := intval*10H + Ord(dig[i], TRUE); INC(i) END
-					ELSE err(203)
-					END
-				ELSIF (ch = "H") OR (ch = "S") THEN	(* hex 32bit *)
-					tch := ch; DevCPM.Get(ch);
-					IF (ch = "L") & (DevCPM.oberon IN DevCPM.options) THEN	(* old syntax: hex 64bit *)
-						DevCPM.searchpos := DevCPM.curpos - 2; DevCPM.Get(ch);
-						IF n <= 16 THEN
-							IF (n = 16) & (dig[0] > "7") THEN realval := -1 END;
-							WHILE (i < n) & (i < 10) DO realval := realval * 10H + Ord(dig[i], TRUE); INC(i) END;
-							WHILE i < n DO realval := realval * 10H; intval := intval * 10H + Ord(dig[i], TRUE); INC(i) END;
-							numtyp := int64
-						ELSE err(203)
-						END
-					ELSIF n <= 8 THEN
-						IF (n = 8) & (dig[0] > "7") THEN (* prevent overflow *) intval := -1 END;
-						WHILE i < n DO intval := intval*10H + Ord(dig[i], TRUE); INC(i) END;
-						IF tch = "S" THEN	(* 32 bit hex float *)
-							r := SYSTEM.VAL(SHORTREAL, intval);
-							realval := r; intval := 0; numtyp := real32
-						END
-					ELSE err(203)
-					END
-				ELSIF ch = "L" THEN	(* hex 64bit *)
-					DevCPM.searchpos := DevCPM.curpos - 1; DevCPM.Get(ch);
-					IF n <= 16 THEN
-						IF (n = 16) & (dig[0] > "7") THEN realval := -1 END;
-						WHILE (i < n) & (i < 10) DO realval := realval * 10H + Ord(dig[i], TRUE); INC(i) END;
-						WHILE i < n DO realval := realval * 10H; intval := intval * 10H + Ord(dig[i], TRUE); INC(i) END;
-						numtyp := int64
-					ELSE err(203)
-					END
-				ELSIF ch = "R" THEN	(* hex float 64bit *)
-					DevCPM.searchpos := DevCPM.curpos - 1; DevCPM.Get(ch);
-					IF n <= 16 THEN
-						a := 0; IF (n = 16) & (dig[0] > "7") THEN (* prevent overflow *) a := -1 END;
-						WHILE i < n-8 DO a := a*10H + Ord(dig[i], TRUE); INC(i) END;
-						IF DevCPM.LEHost THEN arr[1] := a ELSE arr[0] := a END;
-						a := 0; IF (n >= 8) & (dig[i] > "7") THEN (* prevent overflow *) a := -1 END;
-						WHILE i < n DO a := a*10H + Ord(dig[i], TRUE); INC(i) END;
-						IF DevCPM.LEHost THEN arr[0] := a ELSE arr[1] := a END;
-						realval := SYSTEM.VAL(REAL, arr);
-						intval := 0; numtyp := real64
-					ELSE err(203)
-					END
-				ELSE	(* decimal *) 
-					WHILE i < n DO d := Ord(dig[i], FALSE); INC(i);
-						a := (MAX(INTEGER) - d) DIV 10;
-						IF intval > a THEN
-							a := (intval - a + 65535) DIV 65536 * 65536;
-							realval := realval + a; intval := intval - a
-						END;
-						realval := realval * 10; intval := intval * 10 + d
-					END;
-					IF realval = 0 THEN numtyp := integer
-					ELSIF intval < 9223372036854775808.0E0 - realval THEN numtyp := int64	(* 2^63 *)
-					ELSE intval := 0; err(203)
-					END
-				END
-			ELSE err(203)
-			END
-		ELSE (* fraction *)
-			f := 0; g := 0; e := 0; j := 0; expCh := "E";
-			WHILE (j < 15) & (j < n) DO g := g * 10 + Ord(dig[j], FALSE); INC(j) END;	(* !!! *)
-			WHILE n > j DO (* 0 <= f < 1 *) DEC(n); f := (Ord(dig[n], FALSE) + f)/10 END;
-			IF (ch = "E") OR (ch = "D") & (DevCPM.oberon IN DevCPM.options) THEN
-				expCh := ch; DevCPM.searchpos := DevCPM.curpos - 1; DevCPM.Get(ch); neg := FALSE;
-				IF ch = "-" THEN neg := TRUE; DevCPM.Get(ch)
-				ELSIF ch = "+" THEN DevCPM.Get(ch)
-				END;
-				IF ("0" <= ch) & (ch <= "9") THEN
-					REPEAT n := Ord(ch, FALSE); DevCPM.Get(ch);
-						IF e <= (MAX(SHORTINT) - n) DIV 10 THEN e := SHORT(e*10 + n)
-						ELSE err(203)
-						END
-					UNTIL (ch < "0") OR ("9" < ch);
-					IF neg THEN e := -e END
-				ELSE err(2)
-				END
-			END;
-			DEC(e, i-d-m); (* decimal point shift *)
-			IF e < -308 - 16 THEN
-				realval := 0.0
-			ELSIF e < -308 + 14 THEN
-				realval := (f + g) / Math.IntPower(10, j-e-30) / 1.0E15 / 1.0E15
-			ELSIF e < j THEN
-				realval := (f + g) / Math.IntPower(10, j-e)	(* Ten(j-e) *)
-			ELSIF e <= 308 THEN
-				realval := (f + g) * Math.IntPower(10, e-j)	(* Ten(e-j) *)
-			ELSIF e = 308 + 1 THEN
-				realval := (f + g) * (Math.IntPower(10, e-j) / 16);
-				IF realval <= DevCPM.MaxReal64 / 16 THEN realval := realval * 16
-				ELSE err(203)
-				END
-			ELSE err(203)
-			END;
-			numtyp := real
-		END
-	END Number;
-
-	PROCEDURE Get*(VAR sym: BYTE);
-		VAR s: BYTE; old: INTEGER;
-
-		PROCEDURE Comment;	(* do not read after end of file *)
-		BEGIN DevCPM.Get(ch);
-			LOOP
-				LOOP
-					WHILE ch = "(" DO DevCPM.Get(ch);
-						IF ch = "*" THEN Comment END
-					END ;
-					IF ch = "*" THEN DevCPM.Get(ch); EXIT END ;
-					IF ch = DevCPM.Eot THEN EXIT END ;
-					DevCPM.Get(ch)
-				END ;
-				IF ch = ")" THEN DevCPM.Get(ch); EXIT END ;
-				IF ch = DevCPM.Eot THEN err(5); EXIT END
-			END
-		END Comment;
-
-	BEGIN
-		DevCPM.errpos := DevCPM.curpos-1;
-		WHILE (ch <= " ") OR (ch = 0A0X) DO (*ignore control characters*)
-			IF ch = DevCPM.Eot THEN sym := eof; RETURN
-			ELSE DevCPM.Get(ch)
-			END
-		END ;
-		DevCPM.startpos := DevCPM.curpos - 1;
-		CASE ch OF   (* ch > " " *)
-			| 22X, 27X  : Str(s)
-			| "#"  : s := neq; DevCPM.Get(ch)
-			| "&"  : s :=  and; DevCPM.Get(ch)
-			| "("  : DevCPM.Get(ch);
-					 IF ch = "*" THEN Comment; old := DevCPM.errpos; Get(s); DevCPM.errpos := old; 
-					 ELSE s := lparen
-					 END
-			| ")"  : s := rparen; DevCPM.Get(ch)
-			| "*"  : s :=  times; DevCPM.Get(ch)
-			| "+"  : s :=  plus; DevCPM.Get(ch)
-			| ","  : s := comma; DevCPM.Get(ch)
-			| "-"  : s :=  minus; DevCPM.Get(ch)
-			| "."  : DevCPM.Get(ch);
-							 IF ch = "." THEN DevCPM.Get(ch); s := upto ELSE s := period END
-			| "/"  : s := slash;  DevCPM.Get(ch)
-			| "0".."9": Number; s := number
-			| ":"  : DevCPM.Get(ch);
-							 IF ch = "=" THEN DevCPM.Get(ch); s := becomes ELSE s := colon END
-			| ";"  : s := semicolon; DevCPM.Get(ch)
-			| "<"  : DevCPM.Get(ch);
-							 IF ch = "=" THEN DevCPM.Get(ch); s := leq ELSE s := lss END
-			| "="  : s :=  eql; DevCPM.Get(ch)
-			| ">"  : DevCPM.Get(ch);
-							 IF ch = "=" THEN DevCPM.Get(ch); s := geq ELSE s := gtr END
-			| "A": Identifier(s); IF name = "ARRAY" THEN s := array END
-			| "B": Identifier(s);
-						IF name = "BEGIN" THEN s := begin
-						ELSIF name = "BY" THEN s := by
-						END
-			| "C": Identifier(s);
-						IF name = "CASE" THEN s := case
-						ELSIF name = "CONST" THEN s := const
-						ELSIF name = "CLOSE" THEN s := close
-						END
-			| "D": Identifier(s);
-						IF name = "DO" THEN s := do
-						ELSIF name = "DIV" THEN s := div
-						END
-			| "E": Identifier(s);
-						IF name = "END" THEN s := end
-						ELSIF name = "ELSE" THEN s := else
-						ELSIF name = "ELSIF" THEN s := elsif
-						ELSIF name = "EXIT" THEN s := exit
-						END
-			| "F": Identifier(s); IF name = "FOR" THEN s := for END
-			| "I": Identifier(s);
-						IF name = "IF" THEN s := if
-						ELSIF name = "IN" THEN s := in
-						ELSIF name = "IS" THEN s := is
-						ELSIF name = "IMPORT" THEN s := import
-						END
-			| "L": Identifier(s); IF name = "LOOP" THEN s := loop END
-			| "M": Identifier(s);
-						IF name = "MOD" THEN s := mod
-						ELSIF name = "MODULE" THEN s := module
-						END
-			| "N": Identifier(s); IF name = "NIL" THEN s := nil END
-			| "O": Identifier(s);
-						IF name = "OR" THEN s := or
-						ELSIF name = "OF" THEN s := of
-						ELSIF name = "OUT" THEN s := out
-						END
-			| "P": Identifier(s);
-						IF name = "PROCEDURE" THEN s := procedure
-						ELSIF name = "POINTER" THEN s := pointer
-						END
-			| "R": Identifier(s);
-						IF name = "RECORD" THEN s := record
-						ELSIF name = "REPEAT" THEN s := repeat
-						ELSIF name = "RETURN" THEN s := return
-						END
-			| "T": Identifier(s);
-						IF name = "THEN" THEN s := then
-						ELSIF name = "TO" THEN s := to
-						ELSIF name = "TYPE" THEN s := type
-						END
-			| "U": Identifier(s); IF name = "UNTIL" THEN s := until END
-			| "V": Identifier(s); IF name = "VAR" THEN s := var END
-			| "W": Identifier(s);
-						IF name = "WHILE" THEN s := while
-						ELSIF name = "WITH" THEN s := with
-						END
-			| "G".."H", "J", "K", "Q", "S", "X".."Z", "a".."z", "_" (* XXX *): Identifier(s)
-			| "["  : s := lbrak; DevCPM.Get(ch)
-			| "]"  : s := rbrak; DevCPM.Get(ch)
-			| "^"  : s := arrow; DevCPM.Get(ch)
-			| "$"  : s := dollar; DevCPM.Get(ch)
-			| "{"  : s := lbrace; DevCPM.Get(ch);
-			| "|"  : s := bar; DevCPM.Get(ch)
-			| "}"  : s := rbrace; DevCPM.Get(ch)
-			| "~"  : s := not; DevCPM.Get(ch)
-			| 7FX  : s := upto; DevCPM.Get(ch)
-		ELSE s :=  null; DevCPM.Get(ch)
-		END ;
-		sym := s
-	END Get;
-
-	PROCEDURE Init*;
-	BEGIN ch := " "
-	END Init;
-
-END DevCPS.

BlackBox/Dev/Mod/CPT.txt

@@ -1,1890 +0,0 @@
-MODULE DevCPT;
-
-	(* THIS IS TEXT COPY OF BlackBox 1.6-rc6 Dev/Mod/CPT.odc *)
-	(* DO NOT EDIT *)
-
-	IMPORT DevCPM;
-
-	CONST
-		MaxIdLen = 256;
-	
-	TYPE
-		Name* = ARRAY MaxIdLen OF SHORTCHAR;
-		String* = POINTER TO ARRAY OF SHORTCHAR;
-		Const* = POINTER TO ConstDesc;
-		Object* = POINTER TO ObjDesc;
-		Struct* = POINTER TO StrDesc;
-		Node* = POINTER TO NodeDesc;
-		ConstExt* = String;
-		LinkList* = POINTER TO LinkDesc;
-
-		ConstDesc* = RECORD
-			ext*: ConstExt;	(* string or code for code proc (longstring in utf8) *)
-			intval*: INTEGER;	(* constant value or adr, proc par size, text position or least case label *)
-			intval2*: INTEGER;	(* string length (#char, incl 0X), proc var size or larger case label *)
-			setval*: SET;	(* constant value, procedure body present or "ELSE" present in case *)
-			realval*: REAL;	(* real or longreal constant value *)
-			link*: Const	(* chain of constants present in obj file *)
-		END ;
-
-		LinkDesc* = RECORD
-			offset*, linkadr*: INTEGER;
-			next*: LinkList;
-		END;
-
-		ObjDesc* = RECORD
-			left*, right*, link*, scope*: Object;
-			name*: String;	(* name = null OR name^ # "" *)
-			leaf*: BOOLEAN;
-			sysflag*: BYTE;
-			mode*, mnolev*: BYTE;	(* mnolev < 0 -> mno = -mnolev *)
-			vis*: BYTE;	(* internal, external, externalR, inPar, outPar *)
-			history*: BYTE;	(* relevant if name # "" *)
-			used*, fpdone*: BOOLEAN;
-			fprint*: INTEGER;
-			typ*: Struct;	(* actual type, changed in with statements *)
-			ptyp*: Struct;	(* original type if typ is changed *)
-			conval*: Const;
-			adr*, num*: INTEGER;	(* mthno *)
-			links*: LinkList;
-			nlink*: Object;	(* link for name list, declaration order for methods, library link for imp obj *)
-			library*, entry*: String;	(* library name, entry name *)
-			modifiers*: POINTER TO ARRAY OF String;	(* additional interface strings *)
-			linkadr*: INTEGER;	(* used in ofront *)
-			red: BOOLEAN;
-		END ;
-
-		StrDesc* = RECORD
-			form*, comp*, mno*, extlev*: BYTE;
-			ref*, sysflag*: SHORTINT;
-			n*, size*, align*, txtpos*: INTEGER;	(* align is alignment for records and len offset for dynarrs *)
-			untagged*, allocated*, pbused*, pvused*, exp*, fpdone, idfpdone: BOOLEAN;
-			attribute*: BYTE;
-			idfp, pbfp*, pvfp*:INTEGER;
-			BaseTyp*: Struct;
-			link*, strobj*: Object;
-			ext*: ConstExt	(* id string for interface records *)
-		END ;
-		
-		NodeDesc* = RECORD
-			left*, right*, link*: Node;
-			class*, subcl*, hint*: BYTE;
-			readonly*: BOOLEAN;
-			typ*: Struct;
-			obj*: Object;
-			conval*: Const
-		END ;
-	
-	CONST
-		maxImps = 127;	(* must be <= MAX(SHORTINT) *)
-		maxStruct = DevCPM.MaxStruct;	(* must be < MAX(INTEGER) DIV 2 *)
-		FirstRef = 32;
-		FirstRef0 = 16;	(* correction for version 0 *)
-		actVersion = 1;
-
-	VAR
-		topScope*: Object;
-		undftyp*, bytetyp*, booltyp*, char8typ*, int8typ*, int16typ*, int32typ*,
-		real32typ*, real64typ*, settyp*, string8typ*, niltyp*, notyp*, sysptrtyp*,
-		anytyp*, anyptrtyp*, char16typ*, string16typ*, int64typ*,
-		restyp*, iunktyp*, punktyp*, guidtyp*,
-		intrealtyp*, lreal64typ*, lint64typ*, lchar16typ*: Struct;
-		nofGmod*: BYTE;	(*nof imports*)
-		GlbMod*: ARRAY maxImps OF Object;	(* .right = first object, .name = module import name (not alias) *)
-		SelfName*: Name;	(* name of module being compiled *)
-		SYSimported*: BOOLEAN;
-		processor*, impProc*: SHORTINT;
-		libName*: Name;	(* library alias of module being compiled *)
-		null*: String;	(* "" *)
-		
-	CONST
-		(* object modes *)
-		Var = 1; VarPar = 2; Con = 3; Fld = 4; Typ = 5; LProc = 6; XProc = 7;
-		SProc = 8; CProc = 9; IProc = 10; Mod = 11; Head = 12; TProc = 13; Attr = 20;
-
-		(* structure forms *)
-		Undef = 0; Byte = 1; Bool = 2; Char8 = 3; Int8 = 4; Int16 = 5; Int32 = 6;
-		Real32 = 7; Real64 = 8; Set = 9; String8 = 10; NilTyp = 11; NoTyp = 12;
-		Pointer = 13; ProcTyp = 14; Comp = 15;
-		AnyPtr = 14; AnyRec = 15;	(* sym file only *)
-		Char16 = 16; String16 = 17; Int64 = 18;
-		Res = 20; IUnk = 21; PUnk = 22; Guid = 23;
-		
-		(* composite structure forms *)
-		Basic = 1; Array = 2; DynArr = 3; Record = 4;
-
-		(*function number*)
-		assign = 0;
-		haltfn = 0; newfn = 1; absfn = 2; capfn = 3; ordfn = 4;
-		entierfn = 5; oddfn = 6; minfn = 7; maxfn = 8; chrfn = 9;
-		shortfn = 10; longfn = 11; sizefn = 12; incfn = 13; decfn = 14;
-		inclfn = 15; exclfn = 16; lenfn = 17; copyfn = 18; ashfn = 19; assertfn = 32;
-		lchrfn = 33; lentierfcn = 34; typfn = 36; bitsfn = 37; bytesfn = 38;
-		
-		(*SYSTEM function number*)
-		adrfn = 20; ccfn = 21; lshfn = 22; rotfn = 23;
-		getfn = 24; putfn = 25; getrfn = 26; putrfn = 27;
-		bitfn = 28; valfn = 29; sysnewfn = 30; movefn = 31;
-		thisrecfn = 45; thisarrfn = 46;
-		
-		(* COM function number *)
-		validfn = 40; iidfn = 41; queryfn = 42;
-		
-		(* attribute flags (attr.adr, struct.attribute, proc.conval.setval) *)
-		newAttr = 16; absAttr = 17; limAttr = 18; empAttr = 19; extAttr = 20;
-		
-		(* procedure flags (conval.setval) *)
-		isHidden = 29;
-
-		(* module visibility of objects *)
-		internal = 0; external = 1; externalR = 2; inPar = 3; outPar = 4;
-
-		(* history of imported objects *)
-		inserted = 0; same = 1; pbmodified = 2; pvmodified = 3; removed = 4; inconsistent = 5;
-
-		(* sysflags *)
-		inBit = 2; outBit = 4; interface = 10; 
-
-		(* symbol file items *)
-		Smname = 16; Send = 18; Stype = 19; Salias = 20; Svar = 21; Srvar = 22;
-		Svalpar = 23; Svarpar = 24; Sfld = 25; Srfld = 26; Shdptr = 27; Shdpro = 28; Stpro = 29; Shdtpro = 30;
-		Sxpro = 31; Sipro = 32; Scpro = 33; Sstruct = 34; Ssys = 35; Sptr = 36; Sarr = 37; Sdarr = 38; Srec = 39; Spro = 40;
-		Shdutptr = 41; Slib = 42; Sentry = 43; Sinpar = 25; Soutpar = 26;
-		Slimrec = 25; Sabsrec = 26; Sextrec = 27; Slimpro = 31; Sabspro = 32; Semppro = 33; Sextpro = 34; Simpo = 22;
-		
-	TYPE
-		ImpCtxt = RECORD
-			nextTag, reffp: INTEGER;
-			nofr, minr, nofm: SHORTINT;
-			self: BOOLEAN;
-			ref: ARRAY maxStruct OF Struct;
-			old: ARRAY maxStruct OF Object;
-			pvfp: ARRAY maxStruct OF INTEGER;	(* set only if old # NIL *)
-			glbmno: ARRAY maxImps OF BYTE	(* index is local mno *)
-		END ;
-
-		ExpCtxt = RECORD
-			reffp: INTEGER;
-			ref: SHORTINT;
-			nofm: BYTE;
-			locmno: ARRAY maxImps OF BYTE	(* index is global mno *)
-		END ;
-
-	VAR
-		universe, syslink, comlink, infinity: Object;
-		impCtxt: ImpCtxt;
-		expCtxt: ExpCtxt;
-		nofhdfld: INTEGER;
-		sfpresent, symExtended, symNew: BOOLEAN;
-		version: INTEGER;
-		symChanges: INTEGER;
-		portable: BOOLEAN;
-		depth: INTEGER;
-		
-
-	PROCEDURE err(n: SHORTINT);
-	BEGIN DevCPM.err(n)
-	END err;
-	
-	PROCEDURE NewConst*(): Const;
-		VAR const: Const;
-	BEGIN NEW(const); RETURN const
-	END NewConst;
-	
-	PROCEDURE NewObj*(): Object;
-		VAR obj: Object;
-	BEGIN NEW(obj); obj.name := null; RETURN obj
-	END NewObj;
-	
-	PROCEDURE NewStr*(form, comp: BYTE): Struct;
-		VAR typ: Struct;
-	BEGIN NEW(typ); typ.form := form; typ.comp := comp; typ.ref := maxStruct; (* ref >= maxStruct: not exported yet *)
-		typ.txtpos := DevCPM.errpos; typ.size := -1; typ.BaseTyp := undftyp; RETURN typ
-	END NewStr;
-	
-	PROCEDURE NewNode*(class: BYTE): Node;
-		VAR node: Node;
-	BEGIN
-		NEW(node); node.class := class; RETURN node
-	END NewNode;
-(*	
-	PROCEDURE NewExt*(): ConstExt;
-		VAR ext: ConstExt;
-	BEGIN NEW(ext); RETURN ext
-	END NewExt;
-*)	
-	PROCEDURE NewName* ((*IN*) name: ARRAY OF SHORTCHAR): String;
-		VAR i: INTEGER; p: String;
-	BEGIN
-		i := 0; WHILE name[i] # 0X DO INC(i) END;
-		IF i > 0 THEN NEW(p, i + 1); p^ := name$; RETURN p
-		ELSE RETURN null
-		END
-	END NewName;
-
-	PROCEDURE OpenScope*(level: BYTE; owner: Object);
-		VAR head: Object;
-	BEGIN head := NewObj();
-		head.mode := Head; head.mnolev := level; head.link := owner;
-		IF owner # NIL THEN owner.scope := head END ;
-		head.left := topScope; head.right := NIL; head.scope := NIL; topScope := head
-	END OpenScope;
-
-	PROCEDURE CloseScope*;
-	BEGIN topScope := topScope.left
-	END CloseScope;
-
-	PROCEDURE Init*(opt: SET);
-	BEGIN
-		topScope := universe; OpenScope(0, NIL); SYSimported := FALSE;
-		GlbMod[0] := topScope; nofGmod := 1;
-		sfpresent := TRUE;	(* !!! *)
-		symChanges := 0;
-		infinity.conval.intval := DevCPM.ConstNotAlloc;
-		depth := 0
-	END Init;
-	
-	PROCEDURE Open* (name: Name);
-	BEGIN
-		SelfName := name$; topScope.name := NewName(name);
-	END Open;
-
-	PROCEDURE Close*;
-		VAR i: SHORTINT;
-	BEGIN	(* garbage collection *)
-		CloseScope;
-		i := 0; WHILE i < maxImps DO GlbMod[i] := NIL; INC(i) END ;
-		i := FirstRef; WHILE i < maxStruct DO impCtxt.ref[i] := NIL; impCtxt.old[i] := NIL; INC(i) END
-	END Close;
-
-	PROCEDURE SameType* (x, y: Struct): BOOLEAN;
-	BEGIN
-		RETURN (x = y) OR (x.form = y.form) & ~(x.form IN {Pointer, ProcTyp, Comp}) OR (x = undftyp) OR (y = undftyp)
-	END SameType;
-	
-	PROCEDURE EqualType* (x, y: Struct): BOOLEAN;
-		VAR xp, yp: Object; n: INTEGER;
-	BEGIN
-		n := 0;
-		WHILE (n < 100) & (x # y)
-			& (((x.comp = DynArr) & (y.comp = DynArr) & (x.sysflag = y.sysflag))
-				OR ((x.form = Pointer) & (y.form = Pointer))
-				OR ((x.form = ProcTyp) & (y.form = ProcTyp))) DO
-			IF x.form = ProcTyp THEN
-				IF x.sysflag # y.sysflag THEN RETURN FALSE END;
-				xp := x.link; yp := y.link;
-				INC(depth);
-				WHILE (xp # NIL) & (yp # NIL) & (xp.mode = yp.mode) & (xp.sysflag = yp.sysflag)
-						& (xp.vis = yp.vis) & (depth < 100) & EqualType(xp.typ, yp.typ) DO
-					xp := xp.link; yp := yp.link
-				END;
-				DEC(depth);
-				IF (xp # NIL) OR (yp # NIL) THEN RETURN FALSE END
-			END;
-			x := x.BaseTyp; y := y.BaseTyp; INC(n)
-		END;
-		RETURN SameType(x, y)
-	END EqualType;
-	
-	PROCEDURE Extends* (x, y: Struct): BOOLEAN;
-	BEGIN
-		IF (x.form = Pointer) & (y.form = Pointer) THEN x := x.BaseTyp; y := y.BaseTyp END;
-		IF (x.comp = Record) & (y.comp = Record) THEN
-			IF (y = anytyp) & ~x.untagged THEN RETURN TRUE END;
-			WHILE (x # NIL) & (x # undftyp) & (x # y) DO x := x.BaseTyp END
-		END;
-		RETURN (x # NIL) & EqualType(x, y)
-	END Extends;
-	
-	PROCEDURE Includes* (xform, yform: INTEGER): BOOLEAN;
-	BEGIN
-		CASE xform OF
-		| Char16: RETURN yform IN {Char8, Char16, Int8}
-		| Int16: RETURN yform IN {Char8, Int8, Int16}
-		| Int32: RETURN yform IN {Char8, Char16, Int8, Int16, Int32}
-		| Int64: RETURN yform IN {Char8, Char16, Int8, Int16, Int32, Int64}
-		| Real32: RETURN yform IN {Char8, Char16, Int8, Int16, Int32, Int64, Real32}
-		| Real64: RETURN yform IN {Char8, Char16, Int8, Int16, Int32, Int64, Real32, Real64}
-		| String16: RETURN yform IN {String8, String16}
-		ELSE RETURN xform = yform
-		END
-	END Includes;
-	
-	PROCEDURE FindImport*(VAR name: Name; mod: Object; VAR res: Object);
-		VAR obj: Object; (* i: INTEGER; n: Name; *)
-	BEGIN obj := mod.scope.right;
-		LOOP
-			IF obj = NIL THEN EXIT END ;
-			IF name < obj.name^ THEN obj := obj.left
-			ELSIF name > obj.name^ THEN obj := obj.right
-			ELSE (*found*)
-				IF (obj.mode = Typ) & (obj.vis = internal) THEN obj := NIL
-				ELSE obj.used := TRUE
-				END ;
-				EXIT
-			END
-		END ;
-		res := obj;
-(*	bh: checks usage of non Unicode WinApi functions and types
-		IF (res # NIL) & (mod.scope.library # NIL)
-				& ~(DevCPM.interface IN DevCPM.options)
-				& (SelfName # "Kernel") & (SelfName # "HostPorts") THEN
-			n := name + "W";
-			FindImport(n, mod, obj);
-			IF obj # NIL THEN
-				DevCPM.err(733)
-			ELSE
-				i := LEN(name$);
-				IF name[i - 1] = "A" THEN
-					n[i - 1] := "W"; n[i] := 0X;
-					FindImport(n, mod, obj);
-					IF obj # NIL THEN
-						DevCPM.err(734)
-					END
-				END
-			END
-		END;
-*)
-	END FindImport;
-
-	PROCEDURE Find*(VAR name: Name; VAR res: Object);
-		VAR obj, head: Object;
-	BEGIN head := topScope;
-		LOOP obj := head.right;
-			LOOP
-				IF obj = NIL THEN EXIT END ;
-				IF name < obj.name^ THEN obj := obj.left
-				ELSIF name > obj.name^ THEN obj := obj.right
-				ELSE (* found, obj.used not set for local objects *) EXIT
-				END
-			END ;
-			IF obj # NIL THEN EXIT END ;
-			head := head.left;
-			IF head = NIL THEN EXIT END
-		END ;
-		res := obj
-	END Find;
-
-	PROCEDURE FindFld (VAR name: ARRAY OF SHORTCHAR; typ: Struct; VAR res: Object);
-		VAR obj: Object;
-	BEGIN 
-		WHILE (typ # NIL) & (typ # undftyp) DO obj := typ.link;
-			WHILE obj # NIL DO
-				IF name < obj.name^ THEN obj := obj.left
-				ELSIF name > obj.name^ THEN obj := obj.right
-				ELSE (*found*) res := obj; RETURN
-				END
-			END ;
-			typ := typ.BaseTyp
-		END;
-		res := NIL
-	END FindFld;
-	
-	PROCEDURE FindField* (VAR name: ARRAY OF SHORTCHAR; typ: Struct; VAR res: Object);
-	BEGIN
-		FindFld(name, typ, res);
-		IF (res = NIL) & ~typ.untagged THEN FindFld(name, anytyp, res) END
-	END FindField;
-	
-	PROCEDURE FindBaseField* (VAR name: ARRAY OF SHORTCHAR; typ: Struct; VAR res: Object);
-	BEGIN
-		FindFld(name, typ.BaseTyp, res);
-		IF (res = NIL) & ~typ.untagged THEN FindFld(name, anytyp, res) END
-	END FindBaseField;
-	
-(*
-	PROCEDURE Rotated (y: Object; name: String): Object;
-		VAR c, gc: Object;
-	BEGIN
-		IF name^ < y.name^ THEN
-			c := y.left;
-			IF name^ < c.name^ THEN gc := c.left; c.left := gc.right; gc.right := c
-			ELSE gc := c.right; c.right := gc.left; gc.left := c
-			END;
-			y.left := gc
-		ELSE
-			c := y.right;
-			IF name^ < c.name^ THEN gc := c.left; c.left := gc.right; gc.right := c
-			ELSE gc := c.right; c.right := gc.left; gc.left := c
-			END;
-			y.right := gc
-		END;
-		RETURN gc
-	END Rotated;
-	
-	PROCEDURE InsertIn (obj, scope: Object; VAR old: Object);
-		VAR gg, g, p, x: Object; name, sname: String;
-	BEGIN
-		sname := scope.name; scope.name := null;
-		gg := scope; g := gg; p := g; x := p.right; name := obj.name;
-		WHILE x # NIL DO
-			IF (x.left # NIL) & (x.right # NIL) & x.left.red & x.right.red THEN
-				x.red := TRUE; x.left.red := FALSE; x.right.red := FALSE;
-				IF p.red THEN
-					g.red := TRUE;
-					IF (name^ < g.name^) # (name^ < p.name^) THEN p := Rotated(g, name) END;
-					x := Rotated(gg, name); x.red := FALSE
-				END
-			END;
-			gg := g; g := p; p := x;
-			IF name^ < x.name^ THEN x := x.left
-			ELSIF name^ > x.name^ THEN x := x.right
-			ELSE old := x; scope.right.red := FALSE; scope.name := sname; RETURN
-			END
-		END;
-		x := obj; old := NIL;
-		IF name^ < p.name^ THEN p.left := x ELSE p.right := x END;
-		x.red := TRUE;
-		IF p.red THEN
-			g.red := TRUE;
-			IF (name^ < g.name^) # (name^ < p.name^) THEN p := Rotated(g, name) END;
-			x := Rotated(gg, name);
-			x.red := FALSE
-		END;
-		scope.right.red := FALSE; scope.name := sname
-	END InsertIn;
-*)	
-	PROCEDURE InsertIn (obj, scope: Object; VAR old: Object);
-		VAR ob0, ob1: Object; left: BOOLEAN; name: String;
-	BEGIN
-		ASSERT((scope # NIL) & (scope.mode = Head), 100);
-		ob0 := scope; ob1 := scope.right; left := FALSE; name := obj.name;
-		WHILE ob1 # NIL DO
-			IF name^ < ob1.name^ THEN ob0 := ob1; ob1 := ob1.left; left := TRUE
-			ELSIF name^ > ob1.name^ THEN ob0 := ob1; ob1 := ob1.right; left := FALSE
-			ELSE old := ob1; RETURN
-			END
-		END;
-		IF left THEN ob0.left := obj ELSE ob0.right := obj END ;
-		obj.left := NIL; obj.right := NIL; old := NIL
-	END InsertIn;
-
-	PROCEDURE Insert* (VAR name: Name; VAR obj: Object);
-		VAR old: Object;
-	BEGIN
-		obj := NewObj(); obj.leaf := TRUE;
-		obj.name := NewName(name);
-		obj.mnolev := topScope.mnolev;
-		InsertIn(obj, topScope, old);
-		IF old # NIL THEN err(1) END	(*double def*)
-	END Insert;
-	
-	PROCEDURE InsertThisField (obj: Object; typ: Struct; VAR old: Object);
-		VAR ob0, ob1: Object; left: BOOLEAN; name: String;
-	BEGIN
-		IF typ.link = NIL THEN typ.link := obj
-		ELSE
-			ob1 := typ.link; name := obj.name;
-			REPEAT
-				IF name^ < ob1.name^ THEN ob0 := ob1; ob1 := ob1.left; left := TRUE
-				ELSIF name^ > ob1.name^ THEN ob0 := ob1; ob1 := ob1.right; left := FALSE
-				ELSE old := ob1; RETURN
-				END
-			UNTIL ob1 = NIL;
-			IF left THEN ob0.left := obj ELSE ob0.right := obj END
-		END
-	END InsertThisField;
-
-	PROCEDURE InsertField* (VAR name: Name; typ: Struct; VAR obj: Object);
-		VAR old: Object;
-	BEGIN
-		obj := NewObj(); obj.leaf := TRUE;
-		obj.name := NewName(name);
-		InsertThisField(obj, typ, old);
-		IF old # NIL THEN err(1) END	(*double def*)
-	END InsertField;
-
-
-(*-------------------------- Fingerprinting --------------------------*)
-
-	PROCEDURE FPrintName(VAR fp: INTEGER; VAR name: ARRAY OF SHORTCHAR);
-		VAR i: SHORTINT; ch: SHORTCHAR;
-	BEGIN i := 0;
-		REPEAT ch := name[i]; DevCPM.FPrint(fp, ORD(ch)); INC(i) UNTIL ch = 0X
-	END FPrintName;
-
-	PROCEDURE ^IdFPrint*(typ: Struct);
-
-	PROCEDURE FPrintSign*(VAR fp: INTEGER; result: Struct; par: Object);
-	(* depends on assignment compatibility of params only *)
-	BEGIN
-		IdFPrint(result); DevCPM.FPrint(fp, result.idfp);
-		WHILE par # NIL DO
-			DevCPM.FPrint(fp, par.mode); IdFPrint(par.typ); DevCPM.FPrint(fp, par.typ.idfp);
-			IF (par.mode = VarPar) & (par.vis # 0) THEN DevCPM.FPrint(fp, par.vis) END;	(* IN / OUT *)
-			IF par.sysflag # 0 THEN DevCPM.FPrint(fp, par.sysflag) END;
-			(* par.name and par.adr not considered *)
-			par := par.link
-		END
-	END FPrintSign;
-
-	PROCEDURE IdFPrint*(typ: Struct);	(* idfp codifies assignment compatibility *)
-		VAR btyp: Struct; strobj: Object; idfp: INTEGER; f, c: SHORTINT;
-	BEGIN
-		IF ~typ.idfpdone THEN
-			typ.idfpdone := TRUE;	(* may be recursive, temporary idfp is 0 in that case *)
-			idfp := 0; f := typ.form; c := typ.comp; DevCPM.FPrint(idfp, f); DevCPM.FPrint(idfp, c);
-			btyp := typ.BaseTyp; strobj := typ.strobj;
-			IF (strobj # NIL) & (strobj.name # null) THEN
-				FPrintName(idfp, GlbMod[typ.mno].name^); FPrintName(idfp, strobj.name^)
-			END ;
-			IF (f = Pointer) OR (c = Record) & (btyp # NIL) OR (c = DynArr) THEN
-				IdFPrint(btyp); DevCPM.FPrint(idfp, btyp.idfp)
-			ELSIF c = Array THEN IdFPrint(btyp); DevCPM.FPrint(idfp, btyp.idfp); DevCPM.FPrint(idfp, typ.n)
-			ELSIF f = ProcTyp THEN FPrintSign(idfp, btyp, typ.link)
-			END ;
-			typ.idfp := idfp
-		END
-	END IdFPrint;
-
-	PROCEDURE FPrintStr*(typ: Struct);
-		VAR f, c: SHORTINT; btyp: Struct; strobj, bstrobj: Object; pbfp, pvfp: INTEGER;
-
-		PROCEDURE ^FPrintFlds(fld: Object; adr: INTEGER; visible: BOOLEAN);
-
-		PROCEDURE FPrintHdFld(typ: Struct; fld: Object; adr: INTEGER);	(* modifies pvfp only *)
-			VAR i, j, n: INTEGER; btyp: Struct;
-		BEGIN
-			IF typ.comp = Record THEN FPrintFlds(typ.link, adr, FALSE)
-			ELSIF typ.comp = Array THEN btyp := typ.BaseTyp; n := typ.n;
-				WHILE btyp.comp = Array DO n := btyp.n * n; btyp := btyp.BaseTyp END ;
-				IF (btyp.form = Pointer) OR (btyp.comp = Record) THEN
-					j := nofhdfld; FPrintHdFld(btyp, fld, adr);
-					IF j # nofhdfld THEN i := 1;
-						WHILE (i < n) (* & (nofhdfld <= DevCPM.MaxHdFld) *) DO	(* !!! *)
-							INC(adr, btyp.size); FPrintHdFld(btyp, fld, adr); INC(i)
-						END
-					END
-				END
-			ELSIF DevCPM.ExpHdPtrFld &
-				((typ.form = Pointer) & ~typ.untagged OR (fld.name^ = DevCPM.HdPtrName)) THEN	(* !!! *)
-				DevCPM.FPrint(pvfp, Pointer); DevCPM.FPrint(pvfp, adr); INC(nofhdfld)
-			ELSIF DevCPM.ExpHdUtPtrFld &
-				((typ.form = Pointer) & typ.untagged OR (fld.name^ = DevCPM.HdUtPtrName)) THEN	(* !!! *)
-				DevCPM.FPrint(pvfp, Pointer); DevCPM.FPrint(pvfp, adr); INC(nofhdfld);
-				IF typ.form = Pointer THEN DevCPM.FPrint(pvfp, typ.sysflag) ELSE DevCPM.FPrint(pvfp, fld.sysflag) END
-			ELSIF DevCPM.ExpHdProcFld & ((typ.form = ProcTyp) OR (fld.name^ = DevCPM.HdProcName)) THEN
-				DevCPM.FPrint(pvfp, ProcTyp); DevCPM.FPrint(pvfp, adr); INC(nofhdfld)
-			END
-		END FPrintHdFld;
-
-		PROCEDURE FPrintFlds(fld: Object; adr: INTEGER; visible: BOOLEAN);	(* modifies pbfp and pvfp *)
-		BEGIN
-			WHILE (fld # NIL) & (fld.mode = Fld) DO
-				IF (fld.vis # internal) & visible THEN
-					DevCPM.FPrint(pvfp, fld.vis); FPrintName(pvfp, fld.name^); DevCPM.FPrint(pvfp, fld.adr);
-					DevCPM.FPrint(pbfp, fld.vis); FPrintName(pbfp, fld.name^); DevCPM.FPrint(pbfp, fld.adr);
-					FPrintStr(fld.typ); DevCPM.FPrint(pbfp, fld.typ.pbfp); DevCPM.FPrint(pvfp, fld.typ.pvfp)
-				ELSE FPrintHdFld(fld.typ, fld, fld.adr + adr)
-				END ;
-				fld := fld.link
-			END
-		END FPrintFlds;
-
-		PROCEDURE FPrintTProcs(obj: Object);	(* modifies pbfp and pvfp *)
-			VAR fp: INTEGER;
-		BEGIN
-			IF obj # NIL THEN
-				FPrintTProcs(obj.left);
-				IF obj.mode = TProc THEN
-					IF obj.vis # internal THEN
-						fp := 0;
-						IF obj.vis = externalR THEN DevCPM.FPrint(fp, externalR) END;
-						IF limAttr IN obj.conval.setval THEN DevCPM.FPrint(fp, limAttr)
-						ELSIF absAttr IN obj.conval.setval THEN DevCPM.FPrint(fp, absAttr)
-						ELSIF empAttr IN obj.conval.setval THEN DevCPM.FPrint(fp, empAttr)
-						ELSIF extAttr IN obj.conval.setval THEN DevCPM.FPrint(fp, extAttr)
-						END;
-						DevCPM.FPrint(fp, TProc); DevCPM.FPrint(fp, obj.num);
-						FPrintSign(fp, obj.typ, obj.link); FPrintName(fp, obj.name^);
-						IF obj.entry # NIL THEN FPrintName(fp, obj.entry^) END;
-						DevCPM.FPrint(pvfp, fp); DevCPM.FPrint(pbfp, fp)
-					ELSIF DevCPM.ExpHdTProc THEN
-						DevCPM.FPrint(pvfp, TProc); DevCPM.FPrint(pvfp, obj.num)
-					END
-				END;
-				FPrintTProcs(obj.right)
-			END
-		END FPrintTProcs;
-
-	BEGIN
-		IF ~typ.fpdone THEN
-			IdFPrint(typ); pbfp := typ.idfp;
-			IF typ.sysflag # 0 THEN DevCPM.FPrint(pbfp, typ.sysflag) END;
-			IF typ.ext # NIL THEN FPrintName(pbfp, typ.ext^) END;
-			IF typ.attribute # 0 THEN DevCPM.FPrint(pbfp, typ.attribute) END;
-			pvfp := pbfp; typ.pbfp := pbfp; typ.pvfp := pvfp;	(* initial fprints may be used recursively *)
-			typ.fpdone := TRUE;
-			f := typ.form; c := typ.comp; btyp := typ.BaseTyp;
-			IF f = Pointer THEN
-				strobj := typ.strobj; bstrobj := btyp.strobj;
-				IF (strobj = NIL) OR (strobj.name = null) OR (bstrobj = NIL) OR (bstrobj.name = null) THEN
-					FPrintStr(btyp); DevCPM.FPrint(pbfp, btyp.pbfp); pvfp := pbfp
-				(* else use idfp as pbfp and as pvfp, do not call FPrintStr(btyp) here, else cycle not broken *)
-				END
-			ELSIF f = ProcTyp THEN (* use idfp as pbfp and as pvfp *)
-			ELSIF c IN {Array, DynArr} THEN FPrintStr(btyp); DevCPM.FPrint(pbfp, btyp.pvfp); pvfp := pbfp
-			ELSE (* c = Record *)
-				IF btyp # NIL THEN FPrintStr(btyp); DevCPM.FPrint(pbfp, btyp.pbfp); DevCPM.FPrint(pvfp, btyp.pvfp) END ;
-				DevCPM.FPrint(pvfp, typ.size); DevCPM.FPrint(pvfp, typ.align); DevCPM.FPrint(pvfp, typ.n);
-				nofhdfld := 0; FPrintFlds(typ.link, 0, TRUE);
-				FPrintTProcs(typ.link); (* DevCPM.FPrint(pvfp, pbfp); *) strobj := typ.strobj;
-				IF (strobj = NIL) OR (strobj.name = null) THEN pbfp := pvfp END
-			END ;
-			typ.pbfp := pbfp; typ.pvfp := pvfp
-		END
-	END FPrintStr;
-
-	PROCEDURE FPrintObj*(obj: Object);
-		VAR fprint: INTEGER; f, m: SHORTINT; rval: SHORTREAL; ext: ConstExt; mod: Object; r: REAL; x: INTEGER;
-	BEGIN
-		IF ~obj.fpdone THEN
-			fprint := 0; obj.fpdone := TRUE;
-			DevCPM.FPrint(fprint, obj.mode);
-			IF obj.mode = Con THEN
-				f := obj.typ.form; DevCPM.FPrint(fprint, f);
-				CASE f OF
-				| Bool, Char8, Char16, Int8, Int16, Int32:
-					DevCPM.FPrint(fprint, obj.conval.intval)
-				| Int64:
-					x := SHORT(ENTIER((obj.conval.realval + obj.conval.intval) / 4294967296.0));
-					r := obj.conval.realval + obj.conval.intval - x * 4294967296.0;
-					IF r > MAX(INTEGER) THEN r := r - 4294967296.0 END;
-					DevCPM.FPrint(fprint, SHORT(ENTIER(r)));
-					DevCPM.FPrint(fprint, x)
-				| Set:
-					DevCPM.FPrintSet(fprint, obj.conval.setval)
-				| Real32:
-					rval := SHORT(obj.conval.realval); DevCPM.FPrintReal(fprint, rval)
-				| Real64:
-					DevCPM.FPrintLReal(fprint, obj.conval.realval)
-				| String8, String16:
-					FPrintName(fprint, obj.conval.ext^)
-				| NilTyp:
-				ELSE err(127)
-				END
-			ELSIF obj.mode = Var THEN
-				DevCPM.FPrint(fprint, obj.vis); FPrintStr(obj.typ); DevCPM.FPrint(fprint, obj.typ.pbfp)
-			ELSIF obj.mode IN {XProc, IProc}  THEN
-				FPrintSign(fprint, obj.typ, obj.link)
-			ELSIF obj.mode = CProc THEN
-				FPrintSign(fprint, obj.typ, obj.link); ext := obj.conval.ext;
-				m := ORD(ext^[0]); f := 1; DevCPM.FPrint(fprint, m);
-				WHILE f <= m DO DevCPM.FPrint(fprint, ORD(ext^[f])); INC(f) END
-			ELSIF obj.mode = Typ THEN
-				FPrintStr(obj.typ); DevCPM.FPrint(fprint, obj.typ.pbfp)
-			END ;
-			IF obj.sysflag < 0 THEN DevCPM.FPrint(fprint, obj.sysflag) END;
-			IF obj.mode IN {LProc, XProc, CProc, Var, Typ, Con} THEN
-				IF obj.library # NIL THEN
-					FPrintName(fprint, obj.library^)
-				ELSIF obj.mnolev < 0 THEN
-					mod := GlbMod[-obj.mnolev];
-					IF (mod.library # NIL) THEN
-						FPrintName(fprint, mod.library^)
-					END
-				ELSIF obj.mnolev = 0 THEN
-					IF libName # "" THEN FPrintName(fprint, libName) END
-				END;
-				IF obj.entry # NIL THEN FPrintName(fprint, obj.entry^) END
-			END;
-			obj.fprint := fprint
-		END
-	END FPrintObj;
-
-	PROCEDURE FPrintErr* (obj: Object; errno: SHORTINT);	(* !!! *)
-	BEGIN
-		IF errno = 249 THEN
-			DevCPM.LogWLn; DevCPM.LogWStr("  ");
-			DevCPM.LogWStr(GlbMod[-obj.mnolev].name^);
-			DevCPM.LogW("."); DevCPM.LogWStr(obj.name^);
-			DevCPM.LogWStr(" is not consistently imported");
-			err(249)
-		ELSIF obj = NIL THEN	(* changed module sys flags *)
-			IF ~symNew & sfpresent THEN
-				DevCPM.LogWLn; DevCPM.LogWStr("  changed library flag")
-			END
-		ELSIF obj.mnolev = 0 THEN	(* don't report changes in imported modules *)
-			IF sfpresent THEN
-				IF symChanges < 20 THEN
-					DevCPM.LogWLn; DevCPM.LogWStr("  "); DevCPM.LogWStr(obj.name^);
-					IF errno = 250 THEN DevCPM.LogWStr(" is no longer in symbol file")
-					ELSIF errno = 251 THEN DevCPM.LogWStr(" is redefined internally ")
-					ELSIF errno = 252 THEN DevCPM.LogWStr(" is redefined")
-					ELSIF errno = 253 THEN DevCPM.LogWStr(" is new in symbol file")
-					END
-				ELSIF symChanges = 20 THEN
-					DevCPM.LogWLn; DevCPM.LogWStr("  ...")
-				END;
-				INC(symChanges)
-			ELSIF (errno = 253) & ~symExtended THEN
-				DevCPM.LogWLn; 
-				DevCPM.LogWStr("  new symbol file")
-			END
-		END;
-		IF errno = 253 THEN symExtended := TRUE ELSE symNew := TRUE END
-	END FPrintErr;
-
-(*-------------------------- Import --------------------------*)
-
-	PROCEDURE InName(VAR name: String);
-		VAR i: SHORTINT; ch: SHORTCHAR; n: Name;
-	BEGIN i := 0;
-		REPEAT
-			DevCPM.SymRCh(ch); n[i] := ch; INC(i)
-		UNTIL ch = 0X;
-		IF i > 1 THEN NEW(name, i); name^ := n$ ELSE name := null END
-	END InName;
-	
-	PROCEDURE InMod(tag: INTEGER; VAR mno: BYTE);	(* mno is global *)
-		VAR head: Object; name: String; mn: INTEGER; i: BYTE; lib: String;
-	BEGIN
-		IF tag = 0 THEN mno := impCtxt.glbmno[0]
-		ELSIF tag > 0 THEN
-			lib := NIL;
-			IF tag = Slib THEN InName(lib); tag := DevCPM.SymRInt() END;
-			ASSERT(tag = Smname);
-			InName(name);
-			IF (name^ = SelfName) & ~impCtxt.self & ~(DevCPM.interface IN DevCPM.options) THEN err(154) END ;
-			i := 0;
-			WHILE (i < nofGmod) & (name^ # GlbMod[i].name^) DO INC(i) END ;
-			IF i < nofGmod THEN mno := i	(*module already present*)
-			ELSE
-				head := NewObj(); head.mode := Head; head.name := name;
-				mno := nofGmod; head.mnolev := SHORT(SHORT(-mno));
-				head.library := lib;
-				IF nofGmod < maxImps THEN
-					GlbMod[mno] := head; INC(nofGmod)
-				ELSE err(227)
-				END
-			END ;
-			impCtxt.glbmno[impCtxt.nofm] := mno; INC(impCtxt.nofm)
-		ELSE
-			mno := impCtxt.glbmno[-tag]
-		END
-	END InMod;
-
-	PROCEDURE InConstant(f: INTEGER; conval: Const);
-		VAR ch, ch1: SHORTCHAR; ext, t: ConstExt; rval: SHORTREAL; r, s: REAL; i, x, y: INTEGER; str: Name;
-	BEGIN
-		CASE f OF
-		| Byte, Char8, Bool:
-			DevCPM.SymRCh(ch); conval.intval := ORD(ch)
-		| Char16:
-			DevCPM.SymRCh(ch); conval.intval := ORD(ch);
-			DevCPM.SymRCh(ch); conval.intval := conval.intval + ORD(ch) * 256
-		| Int8, Int16, Int32:
-			conval.intval := DevCPM.SymRInt()
-		| Int64:
-			DevCPM.SymRCh(ch); x := 0; y := 1; r := 0; s := 268435456 (*2^28*);
-			WHILE (y < 268435456 (*2^28*)) & (ch >= 80X) DO
-				x := x + (ORD(ch) - 128) * y; y := y * 128; DevCPM.SymRCh(ch)
-			END;
-			WHILE ch >= 80X DO r := r + (ORD(ch) - 128) * s; s := s * 128; DevCPM.SymRCh(ch) END;
-			conval.realval := r + x + ((LONG(ORD(ch)) + 64) MOD 128 - 64) * s;
-			conval.intval := SHORT(ENTIER(r + x + ((LONG(ORD(ch)) + 64) MOD 128 - 64) * s - conval.realval))
-		| Set:
-			DevCPM.SymRSet(conval.setval)
-		| Real32:
-			DevCPM.SymRReal(rval); conval.realval := rval;
-			conval.intval := DevCPM.ConstNotAlloc
-		| Real64:
-			DevCPM.SymRLReal(conval.realval);
-			conval.intval := DevCPM.ConstNotAlloc
-		| String8, String16:
-			i := 0;
-			REPEAT
-				DevCPM.SymRCh(ch);
-				IF i < LEN(str) - 1 THEN str[i] := ch
-				ELSIF i = LEN(str) - 1 THEN str[i] := 0X; NEW(ext, 2 * LEN(str)); ext^ := str$; ext[i] := ch
-				ELSIF i < LEN(ext^) - 1 THEN ext[i] := ch
-				ELSE t := ext; t[i] := 0X; NEW(ext, 2 * LEN(t^)); ext^ := t^$; ext[i] := ch
-				END;
-				INC(i)
-			UNTIL ch = 0X;
-			IF i < LEN(str) THEN NEW(ext, i); ext^ := str$ END;
-			conval.ext := ext; conval.intval := DevCPM.ConstNotAlloc;
-			IF f = String8 THEN conval.intval2 := i
-			ELSE
-				i := 0; y := 0;
-				REPEAT DevCPM.GetUtf8(ext^, x, i); INC(y) UNTIL x = 0;
-				conval.intval2 := y
-			END
-(*		
-			ext := NewExt(); conval.ext := ext; i := 0;
-			REPEAT
-				DevCPM.SymRCh(ch); ext^[i] := ch; INC(i)
-			UNTIL ch = 0X;
-			conval.intval2 := i;
-			conval.intval := DevCPM.ConstNotAlloc
-		| String16:
-			ext := NewExt(); conval.ext := ext; i := 0;
-			REPEAT
-				DevCPM.SymRCh(ch); ext^[i] := ch; INC(i);
-				DevCPM.SymRCh(ch1); ext^[i] := ch1; INC(i)
-			UNTIL (ch = 0X) & (ch1 = 0X);
-			conval.intval2 := i;
-			conval.intval := DevCPM.ConstNotAlloc
-*)
-		| NilTyp:
-			conval.intval := 0
-(*
-		| Guid:
-			ext := NewExt(); conval.ext := ext; i := 0;
-			WHILE i < 16 DO
-				DevCPM.SymRCh(ch); ext^[i] := ch; INC(i)
-			END;
-			ext[16] := 0X;
-			conval.intval2 := 16;
-			conval.intval := DevCPM.ConstNotAlloc;
-*)
-		END
-	END InConstant;
-
-	PROCEDURE ^InStruct(VAR typ: Struct);
-
-	PROCEDURE InSign(mno: BYTE; VAR res: Struct; VAR par: Object);
-		VAR last, new: Object; tag: INTEGER;
-	BEGIN
-		InStruct(res);
-		tag := DevCPM.SymRInt(); last := NIL;
-		WHILE tag # Send DO
-			new := NewObj(); new.mnolev := SHORT(SHORT(-mno));
-			IF last = NIL THEN par := new ELSE last.link := new END ;
-			IF tag = Ssys THEN
-				new.sysflag := SHORT(SHORT(DevCPM.SymRInt())); tag := DevCPM.SymRInt();
-				IF ODD(new.sysflag DIV inBit) THEN new.vis := inPar
-				ELSIF ODD(new.sysflag DIV inBit) THEN new.vis := outPar
-				END
-			END;
-			IF tag = Svalpar THEN new.mode := Var
-			ELSE new.mode := VarPar;
-				IF tag = Sinpar THEN new.vis := inPar
-				ELSIF tag = Soutpar THEN new.vis := outPar
-				END
-			END ;
-			InStruct(new.typ); new.adr := DevCPM.SymRInt(); InName(new.name);
-			last := new; tag := DevCPM.SymRInt()
-		END
-	END InSign;
-
-	PROCEDURE InFld(): Object;	(* first number in impCtxt.nextTag, mno set outside *)
-		VAR tag: INTEGER; obj: Object;
-	BEGIN
-		tag := impCtxt.nextTag; obj := NewObj();
-		IF tag <= Srfld THEN
-			obj.mode := Fld;
-			IF tag = Srfld THEN obj.vis := externalR ELSE obj.vis := external END ;
-			InStruct(obj.typ); InName(obj.name);
-			obj.adr := DevCPM.SymRInt()
-		ELSE
-			obj.mode := Fld;
-			IF tag = Shdptr THEN obj.name := NewName(DevCPM.HdPtrName)
-			ELSIF tag = Shdutptr THEN obj.name := NewName(DevCPM.HdUtPtrName);	(* !!! *)
-				obj.sysflag := 1
-			ELSIF tag = Ssys THEN
-				obj.name := NewName(DevCPM.HdUtPtrName); obj.sysflag := SHORT(SHORT(DevCPM.SymRInt()))
-			ELSE obj.name := NewName(DevCPM.HdProcName)
-			END;
-			obj.typ := undftyp; obj.vis := internal;
-			obj.adr := DevCPM.SymRInt()
-		END;
-		RETURN obj
-	END InFld;
-
-	PROCEDURE InTProc(mno: BYTE): Object;	(* first number in impCtxt.nextTag *)
-		VAR tag: INTEGER; obj: Object;
-	BEGIN
-		tag := impCtxt.nextTag;
-		obj := NewObj(); obj.mnolev := SHORT(SHORT(-mno));
-		IF tag = Shdtpro THEN
-			obj.mode := TProc; obj.name := NewName(DevCPM.HdTProcName);
-			obj.link := NewObj();	(* dummy, easier in Browser *)
-			obj.typ := undftyp; obj.vis := internal;
-			obj.num := DevCPM.SymRInt()
-		ELSE
-			obj.vis := external;
-			IF tag = Simpo THEN obj.vis := externalR; tag := DevCPM.SymRInt() END;
-			obj.mode := TProc; obj.conval := NewConst(); obj.conval.intval := -1;
-			IF tag = Sentry THEN InName(obj.entry); tag := DevCPM.SymRInt() END;
-			InSign(mno, obj.typ, obj.link); InName(obj.name);
-			obj.num := DevCPM.SymRInt();
-			IF tag = Slimpro THEN INCL(obj.conval.setval, limAttr)
-			ELSIF tag = Sabspro THEN INCL(obj.conval.setval, absAttr)
-			ELSIF tag = Semppro THEN INCL(obj.conval.setval, empAttr)
-			ELSIF tag = Sextpro THEN INCL(obj.conval.setval, extAttr)
-			END
-		END ;
-		RETURN obj
-	END InTProc;
-
-	PROCEDURE InStruct(VAR typ: Struct);
-		VAR mno: BYTE; ref: SHORTINT; tag: INTEGER; name: String;
-			t: Struct; obj, last, fld, old, dummy: Object;
-	BEGIN
-		tag := DevCPM.SymRInt();
-		IF tag # Sstruct THEN
-			tag := -tag;
-			IF (version = 0) & (tag >= FirstRef0) THEN tag := tag + FirstRef - FirstRef0 END;	(* correction for new FirstRef *)
-			typ := impCtxt.ref[tag]
-		ELSE
-			ref := impCtxt.nofr; INC(impCtxt.nofr);
-			IF ref < impCtxt.minr THEN impCtxt.minr := ref END ;
-			tag := DevCPM.SymRInt();
-			InMod(tag, mno); InName(name); obj := NewObj();
-			IF name = null THEN
-				IF impCtxt.self THEN old := NIL	(* do not insert type desc anchor here, but in OPL *)
-				ELSE obj.name := NewName("@"); InsertIn(obj, GlbMod[mno], old(*=NIL*)); obj.name := null
-				END ;
-				typ := NewStr(Undef, Basic)
-			ELSE obj.name := name; InsertIn(obj, GlbMod[mno], old);
-				IF old # NIL THEN	(* recalculate fprints to compare with old fprints *)
-					FPrintObj(old); impCtxt.pvfp[ref] := old.typ.pvfp;
-					IF impCtxt.self THEN	(* do not overwrite old typ *)
-						typ := NewStr(Undef, Basic)
-					ELSE	(* overwrite old typ for compatibility reason *)
-						typ := old.typ; typ.link := NIL; typ.sysflag := 0; typ.ext := NIL;
-						typ.fpdone := FALSE; typ.idfpdone := FALSE
-					END
-				ELSE typ := NewStr(Undef, Basic)
-				END
-			END ;
-			impCtxt.ref[ref] := typ; impCtxt.old[ref] := old; typ.ref := SHORT(ref + maxStruct);
-			(* ref >= maxStruct: not exported yet, ref used for err 155 *)
-			typ.mno := mno; typ.allocated := TRUE;
-			typ.strobj := obj; obj.mode := Typ; obj.typ := typ;
-			obj.mnolev := SHORT(SHORT(-mno)); obj.vis := internal; (* name not visible here *)
-			tag := DevCPM.SymRInt();
-			IF tag = Ssys THEN
-				typ.sysflag := SHORT(DevCPM.SymRInt()); tag := DevCPM.SymRInt()
-			END;
-			typ.untagged := typ.sysflag > 0;
-			IF tag = Slib THEN
-				InName(obj.library); tag := DevCPM.SymRInt()
-			END;
-			IF tag = Sentry THEN
-				InName(obj.entry); tag := DevCPM.SymRInt()
-			END;
-			IF tag = String8 THEN
-				InName(typ.ext); tag := DevCPM.SymRInt()
-			END;
-			CASE tag OF
-			| Sptr:
-				typ.form := Pointer; typ.size := DevCPM.PointerSize; typ.n := 0; InStruct(typ.BaseTyp)
-			| Sarr:
-				typ.form := Comp; typ.comp := Array; InStruct(typ.BaseTyp); typ.n := DevCPM.SymRInt();
-				typ.size := typ.n * typ.BaseTyp.size	(* !!! *)
-			| Sdarr:
-				typ.form := Comp; typ.comp := DynArr; InStruct(typ.BaseTyp);
-				IF typ.BaseTyp.comp = DynArr THEN typ.n := typ.BaseTyp.n + 1
-				ELSE typ.n := 0
-				END ;
-				typ.size := DevCPM.DArrSizeA + DevCPM.DArrSizeB * typ.n;	(* !!! *)
-				IF typ.untagged THEN typ.size := DevCPM.PointerSize END
-			| Srec, Sabsrec, Slimrec, Sextrec:
-				typ.form := Comp; typ.comp := Record; InStruct(typ.BaseTyp);
-				(* correction by ETH 18.1.96 *)
-				IF typ.BaseTyp = notyp THEN typ.BaseTyp := NIL END;
-				typ.extlev := 0; t := typ.BaseTyp;
-				WHILE (t # NIL) & (t.comp = Record) DO INC(typ.extlev); t := t.BaseTyp END;
-				typ.size := DevCPM.SymRInt(); typ.align := DevCPM.SymRInt();
-				typ.n := DevCPM.SymRInt();
-				IF tag = Sabsrec THEN typ.attribute := absAttr
-				ELSIF tag = Slimrec THEN typ.attribute := limAttr
-				ELSIF tag = Sextrec THEN typ.attribute := extAttr
-				END;
-				impCtxt.nextTag := DevCPM.SymRInt(); last := NIL;
-				WHILE (impCtxt.nextTag >= Sfld) & (impCtxt.nextTag <= Shdpro)
-						OR (impCtxt.nextTag = Shdutptr) OR (impCtxt.nextTag = Ssys) DO
-					fld := InFld(); fld.mnolev := SHORT(SHORT(-mno));
-					IF last # NIL THEN last.link := fld END ;
-					last := fld;
-					InsertThisField(fld, typ, dummy);
-					impCtxt.nextTag := DevCPM.SymRInt()
-				END ;
-				WHILE impCtxt.nextTag # Send DO fld := InTProc(mno);
-					InsertThisField(fld, typ, dummy);
-					impCtxt.nextTag := DevCPM.SymRInt()
-				END
-			| Spro:
-				typ.form := ProcTyp; typ.size := DevCPM.ProcSize; InSign(mno, typ.BaseTyp, typ.link)
-			| Salias:
-				InStruct(t);
-				typ.form := t.form; typ.comp := Basic; typ.size := t.size;
-				typ.pbfp := t.pbfp; typ.pvfp := t.pvfp; typ.fpdone := TRUE;
-				typ.idfp := t.idfp; typ.idfpdone := TRUE; typ.BaseTyp := t
-			END ;
-			IF ref = impCtxt.minr THEN
-				WHILE ref < impCtxt.nofr DO
-					t := impCtxt.ref[ref]; FPrintStr(t);
-					obj := t.strobj;	(* obj.typ.strobj = obj, else obj.fprint differs (alias) *)
-					IF obj.name # null THEN FPrintObj(obj) END ;
-					old := impCtxt.old[ref];
-					IF old # NIL THEN t.strobj := old;	(* restore strobj *)
-						IF impCtxt.self THEN
-							IF old.mnolev < 0 THEN
-								IF old.history # inconsistent THEN
-									IF old.fprint # obj.fprint THEN old.history := pbmodified
-									ELSIF impCtxt.pvfp[ref] # t.pvfp THEN old.history := pvmodified
-									END
-								(* ELSE remain inconsistent *)
-								END
-							ELSIF old.fprint # obj.fprint THEN old.history := pbmodified
-							ELSIF impCtxt.pvfp[ref] # t.pvfp THEN old.history := pvmodified
-							ELSIF old.vis = internal THEN old.history := same	(* may be changed to "removed" in InObj *)
-							ELSE old.history := inserted	(* may be changed to "same" in InObj *)
-							END
-						ELSE
-							(* check private part, delay error message until really used *)
-							IF impCtxt.pvfp[ref] # t.pvfp THEN old.history := inconsistent END ;
-							IF old.fprint # obj.fprint THEN FPrintErr(old, 249) END
-						END
-					ELSIF impCtxt.self THEN obj.history := removed
-					ELSE obj.history := same
-					END ;
-					INC(ref)
-				END ;
-				impCtxt.minr := maxStruct
-			END
-		END
-	END InStruct;
-
-	PROCEDURE InObj(mno: BYTE): Object;	(* first number in impCtxt.nextTag *)
-		VAR ch: SHORTCHAR; obj, old: Object; typ: Struct;
-			tag, i, s: INTEGER; ext: ConstExt;
-	BEGIN
-		tag := impCtxt.nextTag;
-		IF tag = Stype THEN
-			InStruct(typ); obj := typ.strobj;
-			IF ~impCtxt.self THEN obj.vis := external END	(* type name visible now, obj.fprint already done *)
-		ELSE
-			obj := NewObj(); obj.mnolev := SHORT(SHORT(-mno)); obj.vis := external;
-			IF tag = Ssys THEN obj.sysflag := SHORT(SHORT(DevCPM.SymRInt())); tag := DevCPM.SymRInt() END;
-			IF tag = Slib THEN
-				InName(obj.library); tag := DevCPM.SymRInt()
-			END;
-			IF tag = Sentry THEN
-				InName(obj.entry); tag := DevCPM.SymRInt()
-			END;
-			IF tag >= Sxpro THEN
-				IF obj.conval = NIL THEN obj.conval := NewConst() END;
-				obj.conval.intval := -1;
-				InSign(mno, obj.typ, obj.link);
-				CASE tag OF
-				| Sxpro: obj.mode := XProc
-				| Sipro: obj.mode := IProc
-				| Scpro: obj.mode := CProc;
-					s := DevCPM.SymRInt();
-					NEW(ext, s + 1); obj.conval.ext := ext;
-					ext^[0] := SHORT(CHR(s)); i := 1;
-					WHILE i <= s DO DevCPM.SymRCh(ext^[i]); INC(i) END
-				END
-			ELSIF tag = Salias THEN
-				obj.mode := Typ; InStruct(obj.typ)
-			ELSIF (tag = Svar) OR (tag = Srvar) THEN
-				obj.mode := Var;
-				IF tag = Srvar THEN obj.vis := externalR END ;
-				InStruct(obj.typ)
-			ELSE	(* Constant *)
-				obj.conval := NewConst(); InConstant(tag, obj.conval);
-				IF (tag = Int8) OR (tag = Int16) THEN tag := Int32 END;
-				obj.mode := Con; obj.typ := impCtxt.ref[tag]; 
-			END ;
-			InName(obj.name)
-		END ;
-		FPrintObj(obj);
-		IF (obj.mode = Var) & ((obj.typ.strobj = NIL) OR (obj.typ.strobj.name = null)) THEN
-			(* compute a global fingerprint to avoid structural type equivalence for anonymous types *)
-			DevCPM.FPrint(impCtxt.reffp, obj.typ.ref - maxStruct)
-		END ;
-		IF tag # Stype THEN
-			InsertIn(obj, GlbMod[mno], old);
-			IF impCtxt.self THEN
-				IF old # NIL THEN
-					(* obj is from old symbol file, old is new declaration *)
-					IF old.vis = internal THEN old.history := removed
-					ELSE FPrintObj(old); FPrintStr(old.typ);	(* FPrint(obj) already called *)
-						IF obj.fprint # old.fprint THEN old.history := pbmodified
-						ELSIF obj.typ.pvfp # old.typ.pvfp THEN old.history := pvmodified
-						ELSE old.history := same
-						END
-					END
-				ELSE obj.history := removed	(* OutObj not called if mnolev < 0 *)
-				END
-			(* ELSE old = NIL, or file read twice, consistent, OutObj not called *)
-			END
-		ELSE	(* obj already inserted in InStruct *)
-			IF impCtxt.self THEN	(* obj.mnolev = 0 *)
-				IF obj.vis = internal THEN obj.history := removed
-				ELSIF obj.history = inserted THEN obj.history := same
-				END
-			(* ELSE OutObj not called for obj with mnolev < 0 *)
-			END
-		END ;
-		RETURN obj
-	END InObj;
-
-	PROCEDURE Import*(aliasName: Name; VAR name: Name; VAR done: BOOLEAN);
-		VAR obj, h: Object; mno: BYTE; tag, p: INTEGER; lib: String;	(* done used in Browser *)
-	BEGIN
-		IF name = "SYSTEM" THEN
-			SYSimported := TRUE;
-			p := processor;
-			IF (p < 10) OR (p > 30) THEN p := DevCPM.sysImp END;
-			INCL(DevCPM.options, p);	(* for sysflag handling *)
-			Insert(aliasName, obj); obj.mode := Mod; obj.mnolev := 0; obj.scope := syslink; obj.typ := notyp;
-			h := NewObj(); h.mode := Head; h.right := syslink; obj.scope := h
-		ELSIF name = "COM" THEN
-			IF DevCPM.comAware IN DevCPM.options THEN
-				INCL(DevCPM.options, DevCPM.com);	(* for sysflag handling *)
-				Insert(aliasName, obj); obj.mode := Mod; obj.mnolev := 0; obj.scope := comlink; obj.typ := notyp;
-				h := NewObj(); h.mode := Head; h.right := comlink; obj.scope := h;
-			ELSE err(151)
-			END;
-		ELSIF name = "JAVA" THEN
-			INCL(DevCPM.options, DevCPM.java)
-		ELSE
-			impCtxt.nofr := FirstRef; impCtxt.minr := maxStruct; impCtxt.nofm := 0;
-			impCtxt.self := aliasName = "@self"; impCtxt.reffp := 0;
-			DevCPM.OldSym(name, done);
-			IF done THEN
-				lib := NIL;
-				impProc := SHORT(DevCPM.SymRInt());
-				IF (impProc # 0) & (processor # 0) & (impProc # processor) THEN err(151) END;
-				DevCPM.checksum := 0;	(* start checksum here to avoid problems with proc id fixup *)
-				tag := DevCPM.SymRInt();
-				IF tag < Smname THEN version := tag; tag := DevCPM.SymRInt()
-				ELSE version := 0
-				END;
-				IF tag = Slib THEN InName(lib); tag := DevCPM.SymRInt() END;
-				InMod(tag, mno);
-				IF (name[0] # "@") & (GlbMod[mno].name^ # name) THEN	(* symbol file name conflict *)
-					GlbMod[mno] := NIL; nofGmod := mno; DEC(impCtxt.nofm);
-					DevCPM.CloseOldSym; done := FALSE
-				END;
-			END;
-			IF done THEN
-				GlbMod[mno].library := lib;
-				impCtxt.nextTag := DevCPM.SymRInt();
-				WHILE ~DevCPM.eofSF() DO
-					obj := InObj(mno); impCtxt.nextTag := DevCPM.SymRInt()
-				END ;
-				Insert(aliasName, obj);
-				obj.mode := Mod; obj.scope := GlbMod[mno](*.right*);
-				GlbMod[mno].link := obj;
-				obj.mnolev  := SHORT(SHORT(-mno)); obj.typ := notyp;
-				DevCPM.CloseOldSym
-			ELSIF impCtxt.self THEN
-				sfpresent := FALSE
-			ELSE err(152)	(*sym file not found*)
-			END
-		END
-	END Import;
-
-(*-------------------------- Export --------------------------*)
-
-	PROCEDURE OutName(VAR name: ARRAY OF SHORTCHAR);
-		VAR i: SHORTINT; ch: SHORTCHAR;
-	BEGIN i := 0;
-		REPEAT ch := name[i]; DevCPM.SymWCh(ch); INC(i) UNTIL ch = 0X
-	END OutName;
-	
-	PROCEDURE OutMod(mno: SHORTINT);
-		VAR mod: Object;
-	BEGIN
-		IF expCtxt.locmno[mno] < 0 THEN (* new mod *)
-			mod := GlbMod[mno];
-			IF mod.library # NIL THEN
-				DevCPM.SymWInt(Slib); OutName(mod.library^)
-			END;
-			DevCPM.SymWInt(Smname);
-			expCtxt.locmno[mno] := expCtxt.nofm; INC(expCtxt.nofm);
-			OutName(mod.name^)
-		ELSE DevCPM.SymWInt(-expCtxt.locmno[mno])
-		END
-	END OutMod;
-
-	PROCEDURE ^OutStr(typ: Struct);
-	PROCEDURE ^OutFlds(fld: Object; adr: INTEGER; visible: BOOLEAN);
-
-	PROCEDURE OutHdFld(typ: Struct; fld: Object; adr: INTEGER);
-		VAR i, j, n: INTEGER; btyp: Struct;
-	BEGIN
-		IF typ.comp = Record THEN OutFlds(typ.link, adr, FALSE)
-		ELSIF typ.comp = Array THEN btyp := typ.BaseTyp; n := typ.n;
-			WHILE btyp.comp = Array DO n := btyp.n * n; btyp := btyp.BaseTyp END ;
-			IF (btyp.form = Pointer) OR (btyp.comp = Record) THEN
-				j := nofhdfld; OutHdFld(btyp, fld, adr);
-				IF j # nofhdfld THEN i := 1;
-					WHILE (i < n) (* & (nofhdfld <= DevCPM.MaxHdFld) *) DO	(* !!! *)
-						INC(adr, btyp.size); OutHdFld(btyp, fld, adr); INC(i)
-					END
-				END
-			END
-		ELSIF DevCPM.ExpHdPtrFld &
-			((typ.form = Pointer) & ~typ.untagged OR (fld.name^ = DevCPM.HdPtrName)) THEN	(* !!! *)
-			DevCPM.SymWInt(Shdptr); DevCPM.SymWInt(adr); INC(nofhdfld)
-		ELSIF DevCPM.ExpHdUtPtrFld &
-			((typ.form = Pointer) & typ.untagged OR (fld.name^ = DevCPM.HdUtPtrName)) THEN	(* !!! *)
-			DevCPM.SymWInt(Ssys);	(* DevCPM.SymWInt(Shdutptr); *)
-			IF typ.form = Pointer THEN n := typ.sysflag ELSE n := fld.sysflag END;
-			DevCPM.SymWInt(n);
-			DevCPM.SymWInt(adr); INC(nofhdfld);
-			IF n > 1 THEN portable := FALSE END	(* hidden untagged pointer are portable *)
-		ELSIF DevCPM.ExpHdProcFld & ((typ.form = ProcTyp) OR (fld.name^ = DevCPM.HdProcName)) THEN
-			DevCPM.SymWInt(Shdpro); DevCPM.SymWInt(adr); INC(nofhdfld)
-		END
-	END OutHdFld;
-
-	PROCEDURE OutFlds(fld: Object; adr: INTEGER; visible: BOOLEAN);
-	BEGIN
-		WHILE (fld # NIL) & (fld.mode = Fld) DO
-			IF (fld.vis # internal) & visible THEN
-				IF fld.vis = externalR THEN DevCPM.SymWInt(Srfld) ELSE DevCPM.SymWInt(Sfld) END ;
-				OutStr(fld.typ); OutName(fld.name^); DevCPM.SymWInt(fld.adr)
-			ELSE OutHdFld(fld.typ, fld, fld.adr + adr)
-			END ;
-			fld := fld.link
-		END
-	END OutFlds;
-
-	PROCEDURE OutSign(result: Struct; par: Object);
-	BEGIN
-		OutStr(result);
-		WHILE par # NIL DO
-			IF par.sysflag # 0 THEN DevCPM.SymWInt(Ssys); DevCPM.SymWInt(par.sysflag) END;	
-			IF par.mode = Var THEN DevCPM.SymWInt(Svalpar)
-			ELSIF par.vis = inPar THEN DevCPM.SymWInt(Sinpar)
-			ELSIF par.vis = outPar THEN DevCPM.SymWInt(Soutpar)
-			ELSE DevCPM.SymWInt(Svarpar)
-			END ;
-			OutStr(par.typ);
-			DevCPM.SymWInt(par.adr);
-			OutName(par.name^); par := par.link
-		END ;
-		DevCPM.SymWInt(Send)
-	END OutSign;
-
-	PROCEDURE OutTProcs(typ: Struct; obj: Object);
-		VAR bObj: Object;
-	BEGIN
-		IF obj # NIL THEN
-			IF obj.mode = TProc THEN
-(*
-				IF (typ.BaseTyp # NIL) & (obj.num < typ.BaseTyp.n) & (obj.vis = internal) & (obj.scope # NIL) THEN
-					FindBaseField(obj.name^, typ, bObj);
-					ASSERT((bObj # NIL) & (bObj.num = obj.num));
-					IF bObj.vis # internal THEN DevCPM.Mark(109, typ.txtpos) END
-					(* hidden and overriding, not detected in OPP because record exported indirectly or via aliasing *)
-				END;
-*)
-				IF obj.vis # internal THEN
-					IF obj.vis = externalR THEN DevCPM.SymWInt(Simpo) END;
-					IF obj.entry # NIL THEN
-						DevCPM.SymWInt(Sentry); OutName(obj.entry^); portable := FALSE
-					END;
-					IF limAttr IN obj.conval.setval THEN DevCPM.SymWInt(Slimpro)
-					ELSIF absAttr IN obj.conval.setval THEN DevCPM.SymWInt(Sabspro)
-					ELSIF empAttr IN obj.conval.setval THEN DevCPM.SymWInt(Semppro)
-					ELSIF extAttr IN obj.conval.setval THEN DevCPM.SymWInt(Sextpro)
-					ELSE DevCPM.SymWInt(Stpro)
-					END;
-					OutSign(obj.typ, obj.link); OutName(obj.name^);
-					DevCPM.SymWInt(obj.num)
-				ELSIF DevCPM.ExpHdTProc THEN
-					DevCPM.SymWInt(Shdtpro);
-					DevCPM.SymWInt(obj.num)
-				END
-			END;
-			OutTProcs(typ, obj.left);
-			OutTProcs(typ, obj.right)
-		END
-	END OutTProcs;
-
-	PROCEDURE OutStr(typ: Struct);	(* OPV.TypeAlloc already applied *)
-		VAR strobj: Object;
-	BEGIN
-		IF typ.ref < expCtxt.ref THEN DevCPM.SymWInt(-typ.ref)
-		ELSE
-			DevCPM.SymWInt(Sstruct);
-			typ.ref := expCtxt.ref; INC(expCtxt.ref);
-			IF expCtxt.ref >= maxStruct THEN err(228) END ;
-			OutMod(typ.mno); strobj := typ.strobj;
-			IF (strobj # NIL) & (strobj.name # null) THEN OutName(strobj.name^);
-				CASE strobj.history OF
-				| pbmodified: FPrintErr(strobj, 252)
-				| pvmodified: FPrintErr(strobj, 251)
-				| inconsistent: FPrintErr(strobj, 249)
-				ELSE (* checked in OutObj or correct indirect export *)
-				END
-			ELSE DevCPM.SymWCh(0X)	(* anonymous => never inconsistent, pvfp influences the client fp *)
-			END;
-			IF typ.sysflag # 0 THEN	(* !!! *)
-				DevCPM.SymWInt(Ssys); DevCPM.SymWInt(typ.sysflag);
-				IF typ.sysflag > 0 THEN portable := FALSE END
-			END;
-			IF strobj # NIL THEN
-				IF strobj.library # NIL THEN
-					DevCPM.SymWInt(Slib); OutName(strobj.library^); portable := FALSE
-				END;
-				IF strobj.entry # NIL THEN
-					DevCPM.SymWInt(Sentry); OutName(strobj.entry^); portable := FALSE
-				END
-			END;
-			IF typ.ext # NIL THEN
-				DevCPM.SymWInt(String8); OutName(typ.ext^); portable := FALSE
-			END;
-			CASE typ.form OF
-			| Pointer:
-				DevCPM.SymWInt(Sptr); OutStr(typ.BaseTyp)
-			| ProcTyp:
-				DevCPM.SymWInt(Spro); OutSign(typ.BaseTyp, typ.link)
-			| Comp:
-				CASE typ.comp OF
-				| Array:
-					DevCPM.SymWInt(Sarr); OutStr(typ.BaseTyp); DevCPM.SymWInt(typ.n)
-				| DynArr:
-					DevCPM.SymWInt(Sdarr); OutStr(typ.BaseTyp)
-				| Record:
-					IF typ.attribute = limAttr THEN DevCPM.SymWInt(Slimrec)
-					ELSIF typ.attribute = absAttr THEN DevCPM.SymWInt(Sabsrec)
-					ELSIF typ.attribute = extAttr THEN DevCPM.SymWInt(Sextrec)
-					ELSE DevCPM.SymWInt(Srec)
-					END;
-					IF typ.BaseTyp = NIL THEN OutStr(notyp) ELSE OutStr(typ.BaseTyp) END ;
-					(* BaseTyp should be Notyp, too late to change *)
-					DevCPM.SymWInt(typ.size); DevCPM.SymWInt(typ.align); DevCPM.SymWInt(typ.n);
-					nofhdfld := 0; OutFlds(typ.link, 0, TRUE);
-(*
-					IF nofhdfld > DevCPM.MaxHdFld THEN DevCPM.Mark(223, typ.txtpos) END ;	(* !!! *)
-*)
-					OutTProcs(typ, typ.link); DevCPM.SymWInt(Send)
-				END
-			ELSE	(* alias structure *)
-				DevCPM.SymWInt(Salias); OutStr(typ.BaseTyp)
-			END
-		END
-	END OutStr;
-
-	PROCEDURE OutConstant(obj: Object);
-		VAR f, i: SHORTINT; rval: SHORTREAL; a, b, c: INTEGER; r: REAL;
-	BEGIN
-		f := obj.typ.form;
-(*
-		IF obj.typ = guidtyp THEN f := Guid END;
-*)
-		IF f = Int32 THEN
-			IF (obj.conval.intval >= -128) & (obj.conval.intval <= -127) THEN f := Int8
-			ELSIF (obj.conval.intval >= -32768) & (obj.conval.intval <= -32767) THEN f := Int16
-			END
-		END;
-		DevCPM.SymWInt(f);
-		CASE f OF
-		| Bool, Char8:
-			DevCPM.SymWCh(SHORT(CHR(obj.conval.intval)))
-		| Char16:
-			DevCPM.SymWCh(SHORT(CHR(obj.conval.intval MOD 256)));
-			DevCPM.SymWCh(SHORT(CHR(obj.conval.intval DIV 256)))
-		| Int8, Int16, Int32:
-			DevCPM.SymWInt(obj.conval.intval)
-		| Int64:
-			IF ABS(obj.conval.realval + obj.conval.intval) <= MAX(INTEGER) THEN
-				a := SHORT(ENTIER(obj.conval.realval + obj.conval.intval)); b := -1; c := -1
-			ELSIF ABS(obj.conval.realval + obj.conval.intval) <= 1125899906842624.0 (*2^50*) THEN
-				a := SHORT(ENTIER((obj.conval.realval + obj.conval.intval) /  2097152.0 (*2^21*)));
-				b := SHORT(ENTIER(obj.conval.realval + obj.conval.intval - a * 2097152.0 (*2^21*))); c := -1
-			ELSE
-				a := SHORT(ENTIER((obj.conval.realval + obj.conval.intval) / 4398046511104.0 (*2^42*)));
-				r := obj.conval.realval + obj.conval.intval - a * 4398046511104.0 (*2^42*);
-				b := SHORT(ENTIER(r /  2097152.0 (*2^21*)));
-				c := SHORT(ENTIER(r - b * 2097152.0 (*2^21*)))
-			END;
-			IF c >= 0 THEN
-				DevCPM.SymWCh(SHORT(CHR(c MOD 128 + 128))); c := c DIV 128;
-				DevCPM.SymWCh(SHORT(CHR(c MOD 128 + 128))); c := c DIV 128;
-				DevCPM.SymWCh(SHORT(CHR(c MOD 128 + 128)))
-			END;
-			IF b >= 0 THEN
-				DevCPM.SymWCh(SHORT(CHR(b MOD 128 + 128))); b := b DIV 128;
-				DevCPM.SymWCh(SHORT(CHR(b MOD 128 + 128))); b := b DIV 128;
-				DevCPM.SymWCh(SHORT(CHR(b MOD 128 + 128)))
-			END;
-			DevCPM.SymWInt(a)
-		| Set:
-			DevCPM.SymWSet(obj.conval.setval)
-		| Real32:
-			rval := SHORT(obj.conval.realval); DevCPM.SymWReal(rval)
-		| Real64:
-			DevCPM.SymWLReal(obj.conval.realval)
-		| String8, String16:
-			OutName(obj.conval.ext^)
-		| NilTyp:
-(*
-		| Guid:
-			i := 0;
-			WHILE i < 16 DO DevCPM.SymWCh(obj.conval.ext[i]); INC(i) END
-*)
-		ELSE err(127)
-		END
-	END OutConstant;
-
-	PROCEDURE OutObj(obj: Object);
-		VAR i, j: SHORTINT; ext: ConstExt;
-	BEGIN
-		IF obj # NIL THEN
-			OutObj(obj.left);
-			IF obj.mode IN {Con, Typ, Var, LProc, XProc, CProc, IProc} THEN
-				IF obj.history = removed THEN FPrintErr(obj, 250)
-				ELSIF obj.vis # internal THEN
-					CASE obj.history OF
-					| inserted: FPrintErr(obj, 253)
-					| same:	(* ok *)
-					| pbmodified:
-						IF (obj.mode # Typ) OR (obj.typ.strobj # obj) THEN FPrintErr(obj, 252) END
-					| pvmodified:
-						IF (obj.mode # Typ) OR (obj.typ.strobj # obj) THEN FPrintErr(obj, 251) END
-					END ;
-					IF obj.sysflag < 0 THEN DevCPM.SymWInt(Ssys); DevCPM.SymWInt(obj.sysflag); portable := FALSE END;
-					IF obj.mode IN {LProc, XProc, CProc, Var, Con} THEN
-						(* name alias for types handled in OutStr *)
-						IF obj.library # NIL THEN
-							DevCPM.SymWInt(Slib); OutName(obj.library^); portable := FALSE
-						END;
-						IF obj.entry # NIL THEN
-							DevCPM.SymWInt(Sentry); OutName(obj.entry^); portable := FALSE
-						END
-					END;
-					CASE obj.mode OF
-					| Con:
-						OutConstant(obj); OutName(obj.name^)
-					| Typ:
-						IF obj.typ.strobj = obj THEN DevCPM.SymWInt(Stype); OutStr(obj.typ)
-						ELSE DevCPM.SymWInt(Salias); OutStr(obj.typ); OutName(obj.name^)
-						END
-					| Var:
-						IF obj.vis = externalR THEN DevCPM.SymWInt(Srvar) ELSE DevCPM.SymWInt(Svar) END ;
-						OutStr(obj.typ); OutName(obj.name^);
-						IF (obj.typ.strobj = NIL) OR (obj.typ.strobj.name = null) THEN
-							(* compute fingerprint to avoid structural type equivalence *)
-							DevCPM.FPrint(expCtxt.reffp, obj.typ.ref)
-						END
-					| XProc:
-						DevCPM.SymWInt(Sxpro); OutSign(obj.typ, obj.link); OutName(obj.name^)
-					| IProc:
-						DevCPM.SymWInt(Sipro); OutSign(obj.typ, obj.link); OutName(obj.name^)
-					| CProc:
-						DevCPM.SymWInt(Scpro); OutSign(obj.typ, obj.link); ext := obj.conval.ext;
-						j := ORD(ext^[0]); i := 1; DevCPM.SymWInt(j);
-						WHILE i <= j DO DevCPM.SymWCh(ext^[i]); INC(i) END ;
-						OutName(obj.name^); portable := FALSE
-					END
-				END
-			END ;
-			OutObj(obj.right)
-		END
-	END OutObj;
-
-	PROCEDURE Export*(VAR ext, new: BOOLEAN);
-			VAR i: SHORTINT; nofmod: BYTE; done: BOOLEAN; old: Object; oldCSum: INTEGER;
-	BEGIN
-		symExtended := FALSE; symNew := FALSE; nofmod := nofGmod;
-		Import("@self", SelfName, done); nofGmod := nofmod;
-		oldCSum := DevCPM.checksum;
-		ASSERT(GlbMod[0].name^ = SelfName);
-		IF DevCPM.noerr THEN	(* ~DevCPM.noerr => ~done *)
-			DevCPM.NewSym(SelfName);
-			IF DevCPM.noerr THEN
-				DevCPM.SymWInt(0);	(* portable symfile *)
-				DevCPM.checksum := 0;	(* start checksum here to avoid problems with proc id fixup *)
-				DevCPM.SymWInt(actVersion);
-				old := GlbMod[0]; portable := TRUE;
- 				IF libName # "" THEN
-					DevCPM.SymWInt(Slib); OutName(libName); portable := FALSE;
-					IF done & ((old.library = NIL) OR (old.library^ # libName)) THEN
-						FPrintErr(NIL, 252)
-					END
-				ELSIF done & (old.library # NIL) THEN FPrintErr(NIL, 252)
-				END;
-				DevCPM.SymWInt(Smname); OutName(SelfName);
-				expCtxt.reffp := 0; expCtxt.ref := FirstRef;
-				expCtxt.nofm := 1; expCtxt.locmno[0] := 0;
-				i := 1; WHILE i < maxImps DO expCtxt.locmno[i] := -1; INC(i) END ;
-				OutObj(topScope.right);
-				ext := sfpresent & symExtended;
-				new := ~sfpresent OR symNew OR (DevCPM.checksum # oldCSum);
-				IF DevCPM.noerr & ~portable THEN
-					DevCPM.SymReset;
-					DevCPM.SymWInt(processor)	(* nonportable symfile *)
-				END;
-				IF DevCPM.noerr & sfpresent & (impCtxt.reffp # expCtxt.reffp) THEN
-					new := TRUE
-				END ;
-				IF ~DevCPM.noerr THEN DevCPM.DeleteNewSym END
-				(* DevCPM.RegisterNewSym is called in OP2 after writing the object file *)
-			END
-		END
-	END Export;	(* no new symbol file if ~DevCPM.noerr *)
-
-
-	PROCEDURE InitStruct(VAR typ: Struct; form: BYTE);
-	BEGIN
-		typ := NewStr(form, Basic); typ.ref := form; typ.size := 1; typ.allocated := TRUE;
-		typ.strobj := NewObj(); typ.pbfp := form; typ.pvfp := form; typ.fpdone := TRUE;
-		typ.idfp := form; typ.idfpdone := TRUE
-	END InitStruct;
-
-	PROCEDURE EnterBoolConst(name: Name; val: INTEGER);
-		VAR obj: Object;
-	BEGIN
-		Insert(name, obj); obj.conval := NewConst();
-		obj.mode := Con; obj.typ := booltyp; obj.conval.intval := val
-	END EnterBoolConst;
-
-	PROCEDURE EnterRealConst(name: Name; val: REAL; VAR obj: Object);
-	BEGIN
-		Insert(name, obj); obj.conval := NewConst();
-		obj.mode := Con; obj.typ := real32typ; obj.conval.realval := val
-	END EnterRealConst;
-
-	PROCEDURE EnterTyp(name: Name; form: BYTE; size: SHORTINT; VAR res: Struct);
-		VAR obj: Object; typ: Struct;
-	BEGIN
-		Insert(name, obj);
-		typ := NewStr(form, Basic); obj.mode := Typ; obj.typ := typ; obj.vis := external;
-		typ.strobj := obj; typ.size := size; typ.ref := form; typ.allocated := TRUE;
-		typ.pbfp := form; typ.pvfp := form; typ.fpdone := TRUE;
-		typ.idfp := form; typ.idfpdone := TRUE; res := typ
-	END EnterTyp;
-
-	PROCEDURE EnterProc(name: Name; num: SHORTINT);
-		VAR obj: Object;
-	BEGIN Insert(name, obj);
-		obj.mode := SProc; obj.typ := notyp; obj.adr := num
-	END EnterProc;
-	
-	PROCEDURE EnterAttr(name: Name; num: SHORTINT);
-		VAR obj: Object;
-	BEGIN Insert(name, obj);
-		obj.mode := Attr; obj.adr := num
-	END EnterAttr;
-
-	PROCEDURE EnterTProc(ptr, rec: Struct; name: Name; num, typ: SHORTINT);
-		VAR obj, par: Object;
-	BEGIN
-		InsertField(name, rec, obj);
-		obj.mnolev := -128;	(* for correct implement only behaviour *)
-		obj.mode := TProc; obj.num := num; obj.conval := NewConst();
-		obj.conval.setval := obj.conval.setval + {newAttr};
-		IF typ = 0 THEN	(* FINALIZE, RELEASE *)
-			obj.typ := notyp; obj.vis := externalR;
-			INCL(obj.conval.setval, empAttr)
-		ELSIF typ = 1 THEN	(* QueryInterface *)
-			par := NewObj(); par.name := NewName("int"); par.mode := VarPar; par.vis := outPar;
-			par.sysflag := 8; par.adr := 16; par.typ := punktyp;
-			par.link := obj.link; obj.link := par;
-			par := NewObj(); par.name := NewName("iid"); par.mode := VarPar; par.vis := inPar;
-			par.sysflag := 16; par.adr := 12; par.typ := guidtyp;
-			par.link := obj.link; obj.link := par;
-			obj.typ := restyp; obj.vis := external;
-			INCL(obj.conval.setval, extAttr)
-		ELSIF typ = 2 THEN	(* AddRef, Release *)
-			obj.typ := notyp; obj.vis := externalR;
-			INCL(obj.conval.setval, isHidden);
-			INCL(obj.conval.setval, extAttr)
-		END;
-		par := NewObj(); par.name := NewName("this"); par.mode := Var;
-		par.adr := 8; par.typ := ptr;
-		par.link := obj.link; obj.link := par;
-	END EnterTProc;
-
-	PROCEDURE EnterHdField(VAR root: Object; offs: SHORTINT);
-		VAR obj: Object;
-	BEGIN
-		obj := NewObj(); obj.mode := Fld;
-		obj.name := NewName(DevCPM.HdPtrName); obj.typ := undftyp; obj.adr := offs;
-		obj.link := root; root := obj
-	END EnterHdField;
-
-BEGIN
-	NEW(null, 1); null^ := "";
-	topScope := NIL; OpenScope(0, NIL); DevCPM.errpos := 0;
-	InitStruct(undftyp, Undef); InitStruct(notyp, NoTyp);
-	InitStruct(string8typ, String8); InitStruct(niltyp, NilTyp); niltyp.size := DevCPM.PointerSize;
-	InitStruct(string16typ, String16);
-	undftyp.BaseTyp := undftyp;
-
-	(*initialization of module SYSTEM*)
-(*
-	EnterTyp("BYTE", Byte, 1, bytetyp);
-	EnterProc("NEW", sysnewfn);
-*)
-	EnterTyp("PTR", Pointer, DevCPM.PointerSize, sysptrtyp);
-	EnterProc("ADR", adrfn);
-	EnterProc("TYP", typfn);
-	EnterProc("CC", ccfn);
-	EnterProc("LSH", lshfn);
-	EnterProc("ROT", rotfn);
-	EnterProc("GET", getfn);
-	EnterProc("PUT", putfn);
-	EnterProc("GETREG", getrfn);
-	EnterProc("PUTREG", putrfn);
-	EnterProc("BIT", bitfn);
-	EnterProc("VAL", valfn);
-	EnterProc("MOVE", movefn);
-	EnterProc("THISRECORD", thisrecfn);
-	EnterProc("THISARRAY", thisarrfn);
-	syslink := topScope.right; topScope.right := NIL;
-	
-	(* initialization of module COM *)
-	EnterProc("ID", iidfn);
-	EnterProc("QUERY", queryfn);
-	EnterTyp("RESULT", Int32, 4, restyp);
-	restyp.ref := Res;
-	EnterTyp("GUID", Guid, 16, guidtyp);
-	guidtyp.form := Comp; guidtyp.comp := Array; guidtyp.n := 16;
-	EnterTyp("IUnknown^", IUnk, 12, iunktyp);
-	iunktyp.form := Comp; iunktyp.comp := Record; iunktyp.n := 3;
-	iunktyp.attribute := absAttr;
-(*
-	EnterHdField(iunktyp.link, 12);
-*)
-	iunktyp.BaseTyp := NIL; iunktyp.align := 4;
-	iunktyp.sysflag := interface; iunktyp.untagged := TRUE;
-	NEW(iunktyp.ext, 40); iunktyp.ext^ := "{00000000-0000-0000-C000-000000000046}";
-	EnterTyp("IUnknown", PUnk, DevCPM.PointerSize, punktyp);
-	punktyp.form := Pointer; punktyp.BaseTyp := iunktyp;
-	punktyp.sysflag := interface; punktyp.untagged := TRUE;
-	EnterTProc(punktyp, iunktyp, "QueryInterface", 0, 1);
-	EnterTProc(punktyp, iunktyp, "AddRef", 1, 2);
-	EnterTProc(punktyp, iunktyp, "Release", 2, 2);
-	comlink := topScope.right; topScope.right := NIL;
-	
-	universe := topScope;
-	EnterProc("LCHR", lchrfn);
-	EnterProc("LENTIER", lentierfcn);
-	EnterTyp("ANYREC", AnyRec, 0, anytyp);
-	anytyp.form := Comp; anytyp.comp := Record; anytyp.n := 1;
-	anytyp.BaseTyp := NIL; anytyp.extlev := -1;	(* !!! *)
-	anytyp.attribute := absAttr;
-	EnterTyp("ANYPTR", AnyPtr, DevCPM.PointerSize, anyptrtyp);
-	anyptrtyp.form := Pointer; anyptrtyp.BaseTyp := anytyp;
-	EnterTProc(anyptrtyp, anytyp, "FINALIZE", 0, 0);
-	EnterTProc(anyptrtyp, iunktyp, "RELEASE", 1, 0);
-	EnterProc("VALID", validfn);
-
-	EnterTyp("SHORTCHAR", Char8, 1, char8typ);
-	string8typ.BaseTyp := char8typ;
-	EnterTyp("CHAR", Char16, 2, char16typ);
-	EnterTyp("LONGCHAR", Char16, 2, lchar16typ);
-	string16typ.BaseTyp := char16typ;
-	EnterTyp("SET", Set, 4, settyp);
-	EnterTyp("BYTE", Int8, 1, int8typ);
-	guidtyp.BaseTyp := int8typ;
-	EnterTyp("SHORTINT", Int16, 2, int16typ);
-	EnterTyp("INTEGER",  Int32, 4, int32typ);
-	EnterTyp("LONGINT", Int64, 8, int64typ);
-	EnterTyp("LARGEINT", Int64, 8, lint64typ);
-	EnterTyp("SHORTREAL", Real32, 4, real32typ);
-	EnterTyp("REAL", Real64, 8, real64typ);
-	EnterTyp("LONGREAL", Real64, 8, lreal64typ);
-	EnterTyp("BOOLEAN", Bool, 1, booltyp);
-	EnterBoolConst("FALSE", 0);	(* 0 and 1 are compiler internal representation only *)
-	EnterBoolConst("TRUE",  1);
-	EnterRealConst("INF", DevCPM.InfReal, infinity);
-	EnterProc("HALT", haltfn);
-	EnterProc("NEW", newfn);
-	EnterProc("ABS", absfn);
-	EnterProc("CAP", capfn);
-	EnterProc("ORD", ordfn);
-	EnterProc("ENTIER", entierfn);
-	EnterProc("ODD", oddfn);
-	EnterProc("MIN", minfn);
-	EnterProc("MAX", maxfn);
-	EnterProc("CHR", chrfn);
-	EnterProc("SHORT", shortfn);
-	EnterProc("LONG", longfn);
-	EnterProc("SIZE", sizefn);
-	EnterProc("INC", incfn);
-	EnterProc("DEC", decfn);
-	EnterProc("INCL", inclfn);
-	EnterProc("EXCL", exclfn);
-	EnterProc("LEN", lenfn);
-	EnterProc("COPY", copyfn);
-	EnterProc("ASH", ashfn);
-	EnterProc("ASSERT", assertfn);
-(*
-	EnterProc("ADR", adrfn);
-	EnterProc("TYP", typfn);
-*)
-	EnterProc("BITS", bitsfn);
-	EnterAttr("ABSTRACT", absAttr);
-	EnterAttr("LIMITED", limAttr);
-	EnterAttr("EMPTY", empAttr);
-	EnterAttr("EXTENSIBLE", extAttr);
-	NEW(intrealtyp); intrealtyp^ := real64typ^;
-	impCtxt.ref[Undef] := undftyp; impCtxt.ref[Byte] := bytetyp;
-	impCtxt.ref[Bool] := booltyp;  impCtxt.ref[Char8] := char8typ;
-	impCtxt.ref[Int8] := int8typ;  impCtxt.ref[Int16] := int16typ;
-	impCtxt.ref[Int32] := int32typ;  impCtxt.ref[Real32] := real32typ;
-	impCtxt.ref[Real64] := real64typ;  impCtxt.ref[Set] := settyp;
-	impCtxt.ref[String8] := string8typ; impCtxt.ref[NilTyp] := niltyp;
-	impCtxt.ref[NoTyp] := notyp; impCtxt.ref[Pointer] := sysptrtyp;
-	impCtxt.ref[AnyPtr] := anyptrtyp; impCtxt.ref[AnyRec] := anytyp;
-	impCtxt.ref[Char16] := char16typ; impCtxt.ref[String16] := string16typ;
-	impCtxt.ref[Int64] := int64typ;
-	impCtxt.ref[IUnk] := iunktyp; impCtxt.ref[PUnk] := punktyp; 
-	impCtxt.ref[Guid] := guidtyp; impCtxt.ref[Res] := restyp;
-END DevCPT.
-
-Objects:
-
-    mode  | adr    conval  link     scope    leaf
-   ------------------------------------------------
-    Undef |                                         Not used
-    Var   | vadr           next              regopt Glob or loc var or proc value parameter
-    VarPar| vadr           next              regopt Var parameter (vis = 0 | inPar | outPar)
-    Con   |        val                              Constant
-    Fld   | off            next                     Record field
-    Typ   |                                         Named type
-    LProc | entry  sizes   firstpar scope    leaf   Local procedure, entry adr set in back-end
-    XProc | entry  sizes   firstpar scope    leaf   External procedure, entry adr set in back-end
-    SProc | fno    sizes                            Standard procedure
-    CProc |        code    firstpar scope           Code procedure
-    IProc | entry  sizes            scope    leaf   Interrupt procedure, entry adr set in back-end
-    Mod   |                         scope           Module
-    Head  | txtpos         owner    firstvar        Scope anchor
-    TProc | entry  sizes   firstpar scope    leaf   Bound procedure, mthno = obj.num
-                                                    
-		Structures:
-
-    form    comp  | n      BaseTyp   link     mno  txtpos   sysflag
-	----------------------------------------------------------------------------------
-    Undef   Basic |
-    Byte    Basic |
-    Bool    Basic |
-    Char8   Basic |
-    Int8    Basic |
-    Int16   Basic |
-    Int32   Basic |
-    Real32  Basic |
-    Real64  Basic |
-    Set     Basic |
-    String8 Basic |
-    NilTyp  Basic |
-    NoTyp   Basic |
-    Pointer Basic |        PBaseTyp           mno  txtpos   sysflag
-    ProcTyp Basic |        ResTyp    params   mno  txtpos   sysflag
-    Comp    Array | nofel  ElemTyp            mno  txtpos   sysflag
-    Comp    DynArr| dim    ElemTyp            mno  txtpos   sysflag
-    Comp    Record| nofmth RBaseTyp  fields   mno  txtpos   sysflag
-    Char16  Basic |
-    String16Basic |
-    Int64   Basic |
-
-Nodes:
-
-design   = Nvar|Nvarpar|Nfield|Nderef|Nindex|Nguard|Neguard|Ntype|Nproc.
-expr     = design|Nconst|Nupto|Nmop|Ndop|Ncall.
-nextexpr = NIL|expr.
-ifstat   = NIL|Nif.
-casestat = Ncaselse.
-sglcase  = NIL|Ncasedo.
-stat     = NIL|Ninittd|Nenter|Nassign|Ncall|Nifelse|Ncase|Nwhile|Nrepeat|
-           Nloop|Nexit|Nreturn|Nwith|Ntrap.
-
-
-              class     subcl     obj      left      right     link      
-              ---------------------------------------------------------
-
-design        Nvar                var                          nextexpr
-              Nvarpar             varpar                       nextexpr
-              Nfield              field    design              nextexpr
-              Nderef    ptr/str            design              nextexpr
-              Nindex                       design    expr      nextexpr
-              Nguard                       design              nextexpr (typ = guard type)
-              Neguard                      design              nextexpr (typ = guard type)
-              Ntype               type                         nextexpr
-              Nproc     normal    proc                         nextexpr
-                        super     proc                         nextexpr
-
-
-expr          design
-              Nconst              const                                 (val = node.conval)
-              Nupto                        expr      expr      nextexpr 
-              Nmop      not                expr                nextexpr
-                        minus              expr                nextexpr
-                        is        tsttype  expr                nextexpr
-                        conv               expr                nextexpr
-                        abs                expr                nextexpr
-                        cap                expr                nextexpr
-                        odd                expr                nextexpr
-                        bit                expr                nextexpr {x}
-                        adr                expr                nextexpr SYSTEM.ADR
-                        typ                expr                nextexpr SYSTEM.TYP
-                        cc                 Nconst              nextexpr SYSTEM.CC
-                        val                expr                nextexpr SYSTEM.VAL
-              Ndop      times              expr      expr      nextexpr
-                        slash              expr      expr      nextexpr
-                        div                expr      expr      nextexpr
-                        mod                expr      expr      nextexpr
-                        and                expr      expr      nextexpr
-                        plus               expr      expr      nextexpr
-                        minus              expr      expr      nextexpr
-                        or                 expr      expr      nextexpr
-                        eql                expr      expr      nextexpr
-                        neq                expr      expr      nextexpr
-                        lss                expr      expr      nextexpr
-                        leq                expr      expr      nextexpr
-                        grt                expr      expr      nextexpr
-                        geq                expr      expr      nextexpr
-                        in                 expr      expr      nextexpr
-                        ash                expr      expr      nextexpr
-                        msk                expr      Nconst    nextexpr
-                        len                design    Nconst    nextexpr
-                        min                expr      expr      nextexpr MIN
-                        max                expr      expr      nextexpr MAX
-                        bit                expr      expr      nextexpr SYSTEM.BIT
-                        lsh                expr      expr      nextexpr SYSTEM.LSH
-                        rot                expr      expr      nextexpr SYSTEM.ROT
-              Ncall               fpar     design    nextexpr  nextexpr
-              Ncomp                        stat      expr      nextexpr
-
-nextexpr      NIL
-              expr
-
-ifstat        NIL
-              Nif                          expr      stat      ifstat
-
-casestat      Ncaselse                     sglcase   stat           (minmax = node.conval)
-
-sglcase       NIL
-              Ncasedo                      Nconst    stat      sglcase
-
-stat          NIL
-              Ninittd                                          stat     (of node.typ)
-              Nenter              proc     stat      stat      stat     (proc=NIL for mod)
-              Nassign   assign             design    expr      stat
-                        newfn              design    nextexp   stat
-                        incfn              design    expr      stat
-                        decfn              design    expr      stat
-                        inclfn             design    expr      stat
-                        exclfn             design    expr      stat
-                        copyfn             design    expr      stat
-                        getfn              design    expr      stat     SYSTEM.GET
-                        putfn              expr      expr      stat     SYSTEM.PUT
-                        getrfn             design    Nconst    stat     SYSTEM.GETREG
-                        putrfn             Nconst    expr      stat     SYSTEM.PUTREG
-                        sysnewfn           design    expr      stat     SYSTEM.NEW
-                        movefn             expr      expr      stat     SYSTEM.MOVE
-                                                                        (right.link = 3rd par)
-              Ncall               fpar     design    nextexpr  stat
-              Nifelse                      ifstat    stat      stat
-              Ncase                        expr      casestat  stat
-              Nwhile                       expr      stat      stat
-              Nrepeat                      stat      expr      stat
-              Nloop                        stat                stat 
-              Nexit                                            stat 
-              Nreturn             proc     nextexpr            stat     (proc = NIL for mod)
-              Nwith                        ifstat    stat      stat
-              Ntrap                                  expr      stat
-              Ncomp                        stat      stat      stat

BlackBox/Dev/Mod/CPV486.txt

@@ -1,1774 +0,0 @@
-MODULE DevCPV486;
-
-	(* THIS IS TEXT COPY OF BlackBox 1.6-rc6 Dev/Mod/CPV486.odc *)
-	(* DO NOT EDIT *)
-
-	IMPORT SYSTEM, DevCPM, DevCPT, DevCPE, DevCPH, DevCPL486, DevCPC486;
-	
-	CONST
-		processor* = 10; (* for i386 *)
-
-		(* object modes *)
-		Var = 1; VarPar = 2; Con = 3; Fld = 4; Typ = 5; LProc = 6; XProc = 7;
-		SProc = 8; CProc = 9; IProc = 10; Mod = 11; Head = 12; TProc = 13;
-		
-		(* item modes for i386 *)
-		Ind = 14; Abs = 15; Stk = 16; Cond = 17; Reg = 18; DInd = 19;
-
-		(* symbol values and ops *)
-		times = 1; slash = 2; div = 3; mod = 4;
-		and = 5; plus = 6; minus = 7; or = 8; eql = 9;
-		neq = 10; lss = 11; leq = 12; gtr = 13; geq = 14;
-		in = 15; is = 16; ash = 17; msk = 18; len = 19;
-		conv = 20; abs = 21; cap = 22; odd = 23; not = 33;
-		(*SYSTEM*)
-		adr = 24; cc = 25; bit = 26; lsh = 27; rot = 28; val = 29;
-		min = 34; max = 35; typfn = 36;
-		thisrecfn = 45; thisarrfn = 46;
-		shl = 50; shr = 51; lshr = 52; xor = 53;
-
-		(* structure forms *)
-		Undef = 0; Byte = 1; Bool = 2; Char8 = 3; Int8 = 4; Int16 = 5; Int32 = 6;
-		Real32 = 7; Real64 = 8; Set = 9; String8 = 10; NilTyp = 11; NoTyp = 12;
-		Pointer = 13; ProcTyp = 14; Comp = 15;
-		Char16 = 16; String16 = 17; Int64 = 18;
-		VString16to8 = 29; VString8 = 30; VString16 = 31;
-		realSet = {Real32, Real64};
-
-		(* composite structure forms *)
-		Basic = 1; Array = 2; DynArr = 3; Record = 4;
-
-		(* nodes classes *)
-		Nvar = 0; Nvarpar = 1; Nfield = 2; Nderef = 3; Nindex = 4; Nguard = 5; Neguard = 6;
-		Nconst = 7; Ntype = 8; Nproc = 9; Nupto = 10; Nmop = 11; Ndop = 12; Ncall = 13;
-		Ninittd = 14; Nif = 15; Ncaselse = 16; Ncasedo = 17; Nenter = 18; Nassign = 19;
-		Nifelse =20; Ncase = 21; Nwhile = 22; Nrepeat = 23; Nloop = 24; Nexit = 25;
-		Nreturn = 26; Nwith = 27; Ntrap = 28; Ncomp = 30;
-		Ndrop = 50; Nlabel = 51; Ngoto = 52; Njsr = 53; Nret = 54; Ncmp = 55;
-
-		(*function number*)
-		assign = 0; newfn = 1; incfn = 13; decfn = 14;
-		inclfn = 15; exclfn = 16; copyfn = 18; assertfn = 32;
-
-		(*SYSTEM function number*)
-		getfn = 24; putfn = 25; getrfn = 26; putrfn = 27; sysnewfn = 30; movefn = 31;
-		
-		(* COM function number *)
-		validfn = 40; queryfn = 42;
-		
-		(* procedure flags (conval.setval) *)
-		hasBody = 1; isRedef = 2; slNeeded = 3; imVar = 4; isHidden = 29; isGuarded = 30; isCallback = 31;
-
-		(* attribute flags (attr.adr, struct.attribute, proc.conval.setval) *)
-		newAttr = 16; absAttr = 17; limAttr = 18; empAttr = 19; extAttr = 20;
-		
-		(* case statement flags (conval.setval) *)
-		useTable = 1; useTree = 2;
-		
-		(* registers *)
-		AX = 0; CX = 1; DX = 2; BX = 3; SP = 4; BP = 5; SI = 6; DI = 7; AH = 4; CH = 5; DH = 6; BH = 7;
-		stk = 31; mem = 30; con = 29; float = 28; high = 27; short = 26; deref = 25; loaded = 24;
-		wreg = {AX, BX, CX, DX, SI, DI};
-
-		(* module visibility of objects *)
-		internal = 0; external = 1; externalR = 2; inPar = 3; outPar = 4;
-
-		(* sysflag *)
-		untagged = 1; noAlign = 3; align2 = 4; align8 = 6; union = 7;
-		interface = 10; guarded = 8; noframe = 16;
-		nilBit = 1; enumBits = 8; new = 1; iid = 2;
-		stackArray = 120;
-		
-		(* system trap numbers *)
-		withTrap = -1; caseTrap = -2; funcTrap = -3; typTrap = -4;
-		recTrap = -5; ranTrap = -6; inxTrap = -7; copyTrap = -8;
-		
-		ParOff = 8;
-		interfaceSize = 16;	(* SIZE(Kernel.Interface) *)
-		addRefFP = 4E27A847H;	(* fingerprint of AddRef and Release procedures *)
-		intHandlerFP = 24B0EAE3H;	(* fingerprint of InterfaceTrapHandler *)
-		numPreIntProc = 2;
-		
-		
-	VAR
-		Exit, Return: DevCPL486.Label;
-		assert, sequential: BOOLEAN;
-		nesting, actual: INTEGER;
-		query, addRef, release, release2: DevCPT.Object;
-		
-	PROCEDURE Init*(opt: SET);
-		CONST ass = 2;
-	BEGIN
-		DevCPL486.Init(opt); DevCPC486.Init(opt);
-		assert := ass IN opt;
-		DevCPM.breakpc := MAX(INTEGER);
-		query := NIL; addRef := NIL; release := NIL; release2 := NIL; DevCPC486.intHandler := NIL;
-	END Init;
-	
-	PROCEDURE Close*;
-	BEGIN
-		DevCPL486.Close
-	END Close;
-
-	PROCEDURE Align(VAR offset: INTEGER; align: INTEGER);
-	BEGIN
-		CASE align OF
-		   1: (* ok *)
-		| 2: INC(offset, offset MOD 2)
-		| 4: INC(offset, (-offset) MOD 4)
-		| 8: INC(offset, (-offset) MOD 8)
-		END
-	END Align;
-	
-	PROCEDURE NegAlign(VAR offset: INTEGER; align: INTEGER);
-	BEGIN
-		CASE align OF
-		   1: (* ok *)
-		| 2: DEC(offset, offset MOD 2)
-		| 4: DEC(offset, offset MOD 4)
-		| 8: DEC(offset, offset MOD 8)
-		END
-	END NegAlign;
-	
-	PROCEDURE Base(typ: DevCPT.Struct; limit: INTEGER): INTEGER;	(* typ.comp # DynArr *)
-		VAR align: INTEGER;
-	BEGIN
-		WHILE typ.comp = Array DO typ := typ.BaseTyp END ;
-		IF typ.comp = Record THEN
-			align := typ.align
-		ELSE
-			align := typ.size;
-		END;
-		IF align > limit THEN RETURN limit ELSE RETURN align END
-	END Base;
-
-(* -----------------------------------------------------
-	reference implementation of TypeSize for portable symbol files
-	mandatory for all non-system structures
-
-	PROCEDURE TypeSize (typ: DevCPT.Struct);
-		VAR f, c: SHORTINT; offset: LONGINT; fld: DevCPT.Object; btyp: DevCPT.Struct;
-	BEGIN
-		IF typ.size = -1 THEN
-			f := typ.form; c := typ.comp; btyp := typ.BaseTyp;
-			IF c = Record THEN
-				IF btyp = NIL THEN offset := 0 ELSE TypeSize(btyp); offset := btyp.size END;
-				fld := typ.link;
-				WHILE (fld # NIL) & (fld.mode = Fld) DO
-					btyp := fld.typ; TypeSize(btyp);
-					IF btyp.size >= 4 THEN INC(offset, (-offset) MOD 4)
-					ELSIF btyp.size >= 2 THEN INC(offset, offset MOD 2)
-					END;
-					fld.adr := offset; INC(offset, btyp.size);
-					fld := fld.link
-				END;
-				IF offset > 2 THEN INC(offset, (-offset) MOD 4) END;
-				typ.size := offset; typ.align := 4;
-				typ.n := -1  (* methods not counted yet *)
-			ELSIF c = Array THEN
-				TypeSize(btyp);
-				typ.size := typ.n * btyp.size
-			ELSIF f = Pointer THEN
-				typ.size := DevCPM.PointerSize
-			ELSIF f = ProcTyp THEN
-				typ.size := DevCPM.ProcSize
-			ELSE (* c = DynArr *)
-				TypeSize(btyp);
-				IF btyp.comp = DynArr THEN typ.size := btyp.size + 4
-				ELSE typ.size := 8
-				END
-			END
-		END
-	END TypeSize;
-
------------------------------------------------------ *)
-
-	PROCEDURE GTypeSize (typ: DevCPT.Struct; guarded: BOOLEAN);
-		VAR f, c: BYTE; offset, align, falign, alignLimit: INTEGER;
-			fld: DevCPT.Object; btyp: DevCPT.Struct; name: DevCPT.Name;
-	BEGIN
-		IF typ.untagged THEN guarded := TRUE END;
-		IF typ = DevCPT.undftyp THEN DevCPM.err(58)
-		ELSIF typ.size = -1 THEN
-			f := typ.form; c := typ.comp; btyp := typ.BaseTyp;
-			IF c = Record THEN
-				IF btyp = NIL THEN offset := 0; align := 1;
-				ELSE GTypeSize(btyp, guarded); offset := btyp.size; align := btyp.align
-				END ;
-				IF typ.sysflag = noAlign THEN alignLimit := 1
-				ELSIF typ.sysflag = align2 THEN alignLimit := 2
-				ELSIF typ.sysflag = align8 THEN alignLimit := 8
-				ELSE alignLimit := 4
-				END;
-				fld := typ.link;
-				WHILE (fld # NIL) & (fld.mode = Fld) DO
-					btyp := fld.typ; GTypeSize(btyp, guarded);
-					IF typ.sysflag > 0 THEN falign := Base(btyp, alignLimit)
-					ELSIF btyp.size >= 4 THEN falign := 4
-					ELSIF btyp.size >= 2 THEN falign := 2
-					ELSE falign := 1
-					END;
-					IF typ.sysflag = union THEN
-						fld.adr := 0;
-						IF btyp.size > offset THEN offset := btyp.size END;
-					ELSE
-						Align(offset, falign);
-						fld.adr := offset;
-						IF offset <= MAX(INTEGER) - 4 - btyp.size THEN INC(offset, btyp.size)
-						ELSE offset := 4; DevCPM.Mark(214, typ.txtpos)
-						END						
-					END;
-					IF falign > align THEN align := falign END ;
-					fld := fld.link
-				END;
-(*
-				IF (typ.sysflag = interface) & (typ.BaseTyp = NIL) THEN
-					fld := DevCPT.NewObj(); fld.name^ := DevCPM.HdPtrName; fld.mode := Fld;
-					fld.typ := DevCPT.undftyp; fld.adr := 8;
-					fld.right := typ.link; typ.link := fld;
-					fld := DevCPT.NewObj(); fld.name^ := DevCPM.HdPtrName; fld.mode := Fld;
-					fld.typ := DevCPT.undftyp; fld.adr := 12;
-					typ.link.link := fld; typ.link.left := fld;
-					offset := interfaceSize; align := 4
-				END;
-*)
-				IF typ.sysflag <= 0 THEN align := 4 END;
-				typ.align := align;
-				IF (typ.sysflag > 0) OR (offset > 2) THEN Align(offset, align) END;
-				typ.size := offset;
-				typ.n := -1  (* methods not counted yet *)
-			ELSIF c = Array THEN
-				GTypeSize(btyp, guarded);
-				IF (btyp.size = 0) OR (typ.n <= MAX(INTEGER) DIV btyp.size) THEN typ.size := typ.n * btyp.size
-				ELSE typ.size := 4; DevCPM.Mark(214, typ.txtpos)
-				END
-			ELSIF f = Pointer THEN
-				typ.size := DevCPM.PointerSize;
-				IF guarded & ~typ.untagged THEN DevCPM.Mark(143, typ.txtpos) END
-			ELSIF f = ProcTyp THEN
-				typ.size := DevCPM.ProcSize
-			ELSE (* c = DynArr *)
-				GTypeSize(btyp, guarded);
-				IF (typ.sysflag = untagged) OR typ.untagged THEN typ.size := 4
-				ELSE
-					IF btyp.comp = DynArr THEN typ.size := btyp.size + 4
-					ELSE typ.size := 8
-					END
-				END
-			END
-		END
-	END GTypeSize;
-	
-	PROCEDURE TypeSize*(typ: DevCPT.Struct);	(* also called from DevCPT.InStruct for arrays *)
-	BEGIN
-		GTypeSize(typ, FALSE)
-	END TypeSize;
-	
-	PROCEDURE GetComKernel;
-		VAR name: DevCPT.Name; mod: DevCPT.Object;
-	BEGIN
-		IF addRef = NIL THEN
-			DevCPT.OpenScope(SHORT(SHORT(-DevCPT.nofGmod)), NIL);
-			DevCPT.topScope.name := DevCPT.NewName("$$");
-			name := "AddRef"; DevCPT.Insert(name, addRef);
-			addRef.mode := XProc;
-			addRef.fprint := addRefFP;
-			addRef.fpdone := TRUE;
-			name := "Release"; DevCPT.Insert(name, release);
-			release.mode := XProc;
-			release.fprint := addRefFP;
-			release.fpdone := TRUE;
-			name := "Release2"; DevCPT.Insert(name, release2);
-			release2.mode := XProc;
-			release2.fprint := addRefFP;
-			release2.fpdone := TRUE;
-			name := "InterfaceTrapHandler"; DevCPT.Insert(name, DevCPC486.intHandler);
-			DevCPC486.intHandler.mode := XProc;
-			DevCPC486.intHandler.fprint := intHandlerFP;
-			DevCPC486.intHandler.fpdone := TRUE;
-			DevCPT.GlbMod[DevCPT.nofGmod] := DevCPT.topScope;
-			INC(DevCPT.nofGmod);
-			DevCPT.CloseScope;
-		END
-	END GetComKernel;
-
-	PROCEDURE EnumTProcs(rec: DevCPT.Struct);	(* method numbers in declaration order *)
-		VAR btyp: DevCPT.Struct; obj, redef: DevCPT.Object;
-	BEGIN
-		IF rec.n = -1 THEN
-			rec.n := 0; btyp := rec.BaseTyp;
-			IF btyp # NIL THEN
-				EnumTProcs(btyp); rec.n := btyp.n;
-			END;
-			obj := rec.strobj.link;
-			WHILE obj # NIL DO
-				DevCPT.FindBaseField(obj.name^, rec, redef);
-				IF redef # NIL THEN obj.num := redef.num (*mthno*);
-					IF ~(isRedef IN obj.conval.setval) OR (redef.conval.setval * {extAttr, absAttr, empAttr} = {}) THEN
-						DevCPM.Mark(119, rec.txtpos)
-					END
-				ELSE obj.num := rec.n; INC(rec.n)
-				END ;
-				IF obj.conval.setval * {hasBody, absAttr, empAttr} = {} THEN DevCPM.Mark(129, obj.adr) END;
-				obj := obj.nlink
-			END
-		END
-	END EnumTProcs;
-
-	PROCEDURE CountTProcs(rec: DevCPT.Struct);
-		VAR btyp: DevCPT.Struct; comProc: INTEGER; m, rel: DevCPT.Object; name: DevCPT.Name;
-
-		PROCEDURE TProcs(obj: DevCPT.Object);	(* obj.mnolev = 0, TProcs of base type already counted *)
-			VAR redef: DevCPT.Object;
-		BEGIN
-			IF obj # NIL THEN
-				TProcs(obj.left);
-				IF obj.mode = TProc THEN
-					DevCPT.FindBaseField(obj.name^, rec, redef);
-					(* obj.adr := 0 *)
-					IF redef # NIL THEN
-						obj.num := redef.num (*mthno*);
-						IF (redef.link # NIL) & (redef.link.typ.sysflag = interface) THEN
-							obj.num := numPreIntProc + comProc - 1 - obj.num
-						END;
-						IF ~(isRedef IN obj.conval.setval) OR (redef.conval.setval * {extAttr, absAttr, empAttr} = {}) THEN
-							DevCPM.Mark(119, rec.txtpos)
-						END
-					ELSE obj.num := rec.n; INC(rec.n)
-					END ;
-					IF obj.conval.setval * {hasBody, absAttr, empAttr} = {} THEN DevCPM.Mark(129, obj.adr) END
-				END ;
-				TProcs(obj.right)
-			END
-		END TProcs;
-
-	BEGIN
-		IF rec.n = -1 THEN
-			comProc := 0;
-			IF rec.untagged THEN rec.n := 0 ELSE rec.n := DevCPT.anytyp.n END;
-			btyp := rec.BaseTyp;
-			IF btyp # NIL THEN
-				IF btyp.sysflag = interface THEN
-					EnumTProcs(btyp); rec.n := btyp.n + numPreIntProc; comProc := btyp.n;
-				ELSE
-					CountTProcs(btyp); rec.n := btyp.n
-				END
-			END;
-			WHILE (btyp # NIL) & (btyp # DevCPT.undftyp) & (btyp.sysflag # interface) DO btyp := btyp.BaseTyp END;
-			IF (btyp # NIL) & (btyp.sysflag = interface) THEN
-				IF comProc > 0 THEN
-					name := "QueryInterface"; DevCPT.FindField(name, rec, m);
-					IF m.link.typ.sysflag = interface THEN
-						DevCPT.InsertField(name, rec, m); m.mode := TProc; m.typ := rec;
-						m.conval := DevCPT.NewConst(); m.conval.setval := {isRedef, hasBody, isCallback, extAttr};
-						m.nlink := query; query := m
-					END;
-					name := "AddRef";
-					DevCPT.InsertField(name, rec, m); m.mode := TProc; m.mnolev := 0;
-					m.conval := DevCPT.NewConst(); m.conval.setval := {isRedef, hasBody, isCallback, isHidden, extAttr};
-					GetComKernel; addRef.used := TRUE; m.adr := -1; m.nlink := addRef;
-				END;
-				name := "RELEASE";
-				DevCPT.FindField(name, rec, rel);
-				IF (rel # NIL) & (rel.link.typ = DevCPT.anyptrtyp) THEN rel := NIL END;
-				IF (comProc > 0) OR (rel # NIL) THEN
-					name := "Release";
-					DevCPT.InsertField(name, rec, m); m.mode := TProc; m.mnolev := 0;
-					m.conval := DevCPT.NewConst(); m.conval.setval := {isRedef, hasBody, isCallback, isHidden, extAttr};
-					GetComKernel; m.adr := -1;
-					IF rel # NIL THEN release2.used := TRUE; m.nlink := release2
-					ELSE release.used := TRUE; m.nlink := release
-					END
-				END
-			END;
-			TProcs(rec.link);
-		END
-	END CountTProcs;
-	
-	PROCEDURE ^Parameters(firstPar, proc: DevCPT.Object);
-
-	PROCEDURE ^TProcedures(obj: DevCPT.Object);
-
-	PROCEDURE TypeAlloc(typ: DevCPT.Struct);
-		VAR f, c: SHORTINT; fld: DevCPT.Object; btyp: DevCPT.Struct;
-	BEGIN
-		IF ~typ.allocated THEN	(* not imported, not predefined, not allocated yet *)
-			typ.allocated := TRUE;
-			TypeSize(typ);
-			f := typ.form; c := typ.comp; btyp := typ.BaseTyp;
-			IF c = Record THEN
-				IF typ.sysflag = interface THEN
-					EnumTProcs(typ);
-				ELSE
-					CountTProcs(typ)
-				END;
-				IF typ.extlev > 14 THEN DevCPM.Mark(233, typ.txtpos) END;
-				IF btyp # NIL THEN TypeAlloc(btyp) END;
-				IF ~typ.untagged THEN DevCPE.AllocTypDesc(typ) END;
-				fld := typ.link;
-				WHILE (fld # NIL) & (fld.mode = Fld) DO
-					TypeAlloc(fld.typ); fld := fld.link
-				END;
-				TProcedures(typ.link)
-			ELSIF f = Pointer THEN
-				IF btyp = DevCPT.undftyp THEN DevCPM.Mark(128, typ.txtpos)
-				ELSE TypeAlloc(btyp);
-				END
-			ELSIF f = ProcTyp THEN
-				TypeAlloc(btyp);
-				Parameters(typ.link, NIL)
-			ELSE (* c IN {Array, DynArr} *) 
-				TypeAlloc(btyp);
-				IF (btyp.comp = DynArr) & btyp.untagged & ~typ.untagged THEN DevCPM.Mark(225, typ.txtpos) END;
-			END
-		END
-	END TypeAlloc;
-
-	PROCEDURE NumOfIntProc (typ: DevCPT.Struct): INTEGER;
-	BEGIN
-		WHILE (typ # NIL) & (typ.sysflag # interface) DO typ := typ.BaseTyp END;
-		IF typ # NIL THEN RETURN typ.n
-		ELSE RETURN 0
-		END
-	END NumOfIntProc;
-	
-	PROCEDURE Parameters(firstPar, proc: DevCPT.Object);
-	(* firstPar.mnolev = 0 *)
-		VAR par: DevCPT.Object; typ: DevCPT.Struct; padr, vadr: INTEGER;
-	BEGIN
-		padr := ParOff; par := firstPar;
-		WHILE par # NIL DO
-			typ := par.typ; TypeAlloc(typ);
-			par.adr := padr;
-			IF (par.mode = VarPar) & (typ.comp # DynArr) THEN
-				IF (typ.comp = Record) & ~typ.untagged THEN INC(padr, 8)
-				ELSE INC(padr, 4)
-				END
-			ELSE
-				IF (par.mode = Var) & (typ.comp = DynArr) & typ.untagged THEN DevCPM.err(145) END;
-				INC(padr, typ.size); Align(padr, 4)
-			END;
-			par := par.link
-		END;
-		IF proc # NIL THEN
-			IF proc.mode = XProc THEN
-				INCL(proc.conval.setval, isCallback)
-			ELSIF (proc.mode = TProc)
-				& (proc.num >= numPreIntProc)
-				& (proc.num < numPreIntProc + NumOfIntProc(proc.link.typ))
-			THEN
-				INCL(proc.conval.setval, isCallback);
-				INCL(proc.conval.setval, isGuarded)
-			END;
-			IF proc.sysflag = guarded THEN INCL(proc.conval.setval, isGuarded) END;
-			IF isGuarded IN proc.conval.setval THEN
-				GetComKernel; vadr := -24
-			ELSE
-				vadr := 0;
-				IF imVar IN proc.conval.setval THEN DEC(vadr, 4) END;
-				IF isCallback IN proc.conval.setval THEN DEC(vadr, 8) END
-			END;
-			proc.conval.intval := padr; proc.conval.intval2 := vadr;
-		END
-	END Parameters;
-	
-	PROCEDURE Variables(var: DevCPT.Object; VAR varSize: INTEGER);
-	(* allocates only offsets, regs allocated in DevCPC486.Enter *)
-		VAR adr: INTEGER; typ: DevCPT.Struct;
-	BEGIN
-		adr := varSize;
-		WHILE var # NIL DO
-			typ := var.typ; TypeAlloc(typ);
-			DEC(adr, typ.size); NegAlign(adr, Base(typ, 4));
-			var.adr := adr;
-			var := var.link
-		END;
-		NegAlign(adr, 4); varSize := adr
-	END Variables;
-	
-	PROCEDURE ^Objects(obj: DevCPT.Object);
-
-	PROCEDURE Procedure(obj: DevCPT.Object);
-	(* obj.mnolev = 0 *)
-		VAR oldPos: INTEGER;
-	BEGIN
-		oldPos := DevCPM.errpos; DevCPM.errpos := obj.scope.adr;
-		TypeAlloc(obj.typ);
-		Parameters(obj.link, obj);
-		IF ~(hasBody IN obj.conval.setval) THEN DevCPM.Mark(129, obj.adr) END ;
-		Variables(obj.scope.scope, obj.conval.intval2);	(* local variables *)
-		Objects(obj.scope.right);
-		DevCPM.errpos := oldPos
-	END Procedure;
-
-	PROCEDURE TProcedures(obj: DevCPT.Object);
-	(* obj.mnolev = 0 *)
-		VAR par: DevCPT.Object; psize: INTEGER;
-	BEGIN
-		IF obj # NIL THEN
-			TProcedures(obj.left);
-			IF (obj.mode = TProc) & (obj.scope # NIL) THEN
-				TypeAlloc(obj.typ);
-				Parameters(obj.link, obj);
-				Variables(obj.scope.scope, obj.conval.intval2);	(* local variables *)
-				Objects(obj.scope.right);
-			END ;
-			TProcedures(obj.right)
-		END
-	END TProcedures;
-
-	PROCEDURE Objects(obj: DevCPT.Object);
-	BEGIN
-		IF obj # NIL THEN
-			Objects(obj.left);
-			IF obj.mode IN {Con, Typ, LProc, XProc, CProc, IProc} THEN
-				IF (obj.mode IN {Con, Typ}) THEN TypeAlloc(obj.typ);
-				ELSE Procedure(obj)
-				END
-			END ;
-			Objects(obj.right)
-		END
-	END Objects;
-
-	PROCEDURE Allocate*;
-		VAR gvarSize: INTEGER; name: DevCPT.Name;
-	BEGIN
-		DevCPM.errpos := DevCPT.topScope.adr;	(* text position of scope used if error *)
-		gvarSize := 0;
-		Variables(DevCPT.topScope.scope, gvarSize); DevCPE.dsize := -gvarSize;
-		Objects(DevCPT.topScope.right)
-	END Allocate;
-	
-	(************************)
-
-	PROCEDURE SameExp (n1, n2: DevCPT.Node): BOOLEAN;
-	BEGIN
-		WHILE (n1.class = n2.class) & (n1.typ = n2.typ) DO
-			CASE n1.class OF
-			| Nvar, Nvarpar, Nproc: RETURN n1.obj = n2.obj
-			| Nconst: RETURN (n1.typ.form IN {Int8..Int32}) & (n1.conval.intval = n2.conval.intval)
-			| Nfield: IF n1.obj # n2.obj THEN RETURN FALSE END
-			| Nderef, Nguard:
-			| Nindex: IF ~SameExp(n1.right, n2.right) THEN RETURN FALSE END
-			| Nmop: IF (n1.subcl # n2.subcl) OR (n1.subcl = is) THEN RETURN FALSE END
-			| Ndop: IF (n1.subcl # n2.subcl) OR ~SameExp(n1.right, n2.right) THEN RETURN FALSE END
-			ELSE RETURN FALSE
-			END ;
-			n1 := n1.left; n2 := n2.left
-		END;
-		RETURN FALSE
-	END SameExp;
-	
-	PROCEDURE Check (n: DevCPT.Node; VAR used: SET; VAR size: INTEGER);
-		VAR ux, uy: SET; sx, sy, sf: INTEGER; f: BYTE;
-	BEGIN
-		used := {}; size := 0;
-		WHILE n # NIL DO
-			IF n.class # Ncomp THEN
-				Check(n.left, ux, sx);
-				Check(n.right, uy, sy)
-			END;
-			ux := ux + uy; sf := 0;
-			CASE n.class OF
-			| Nvar, Nvarpar:
-					IF (n.class = Nvarpar) OR  (n.typ.comp = DynArr) OR
-						(n.obj.mnolev > 0) &
-						(DevCPC486.imLevel[n.obj.mnolev] < DevCPC486.imLevel[DevCPL486.level]) THEN sf := 1 END
-			| Nguard: sf := 2
-			| Neguard, Nderef: sf := 1
-			| Nindex:
-					IF (n.right.class # Nconst) OR (n.left.typ.comp = DynArr) THEN sf := 1 END;
-					IF sx > 0 THEN INC(sy) END
-			| Nmop:
-					CASE n.subcl OF
-					| is, adr, typfn, minus, abs, cap, val: sf := 1
-					| bit: sf := 2; INCL(ux, CX)
-					| conv:
-							IF n.typ.form = Int64 THEN sf := 2
-							ELSIF ~(n.typ.form IN realSet) THEN sf := 1;
-								IF n.left.typ.form IN realSet THEN INCL(ux, AX) END
-							END
-					| odd, cc, not:
-					END
-			| Ndop:
-					f := n.left.typ.form;
-					IF f # Bool THEN
-						CASE n.subcl OF
-						| times:
-								sf := 1;
-								IF f = Int8 THEN INCL(ux, AX) END
-						| div, mod:
-								sf := 3; INCL(ux, AX);
-								IF f > Int8 THEN INCL(ux, DX) END
-						| eql..geq:
-								IF f IN {String8, String16, Comp} THEN ux := ux + {AX, CX, SI, DI}; sf := 4
-								ELSIF f IN realSet THEN INCL(ux, AX); sf := 1
-								ELSE sf := 1
-								END
-						| ash, lsh, rot:
-								IF n.right.class = Nconst THEN sf := 1 ELSE sf := 2; INCL(ux, CX) END
-						| slash, plus, minus, msk, in, bit:
-								sf := 1
-						| len:
-								IF f IN {String8, String16} THEN ux := ux + {AX, CX, DI}; sf := 3
-								ELSE sf := 1
-								END
-						| min, max:
-								sf := 1;
-								IF f IN realSet THEN INCL(ux, AX) END
-						| queryfn:
-								ux := ux + {CX, SI, DI}; sf := 4
-						END;
-						IF sy > sx THEN INC(sx) ELSE INC(sy) END
-					END
-			| Nupto:
-					IF (n.right.class = Nconst) OR (n.left.class = Nconst) THEN sf := 2
-					ELSE sf := 3
-					END;
-					INCL(ux, CX); INC(sx)
-			| Ncall, Ncomp:
-					sf := 10; ux := wreg + {float}
-			| Nfield, Nconst, Nproc, Ntype:
-			END;
-			used := used + ux;
-			IF sx > size THEN size := sx END;
-			IF sy > size THEN size := sy END;
-			IF sf > size THEN size := sf END;
-			n := n.link
-		END;
-		IF size > 10 THEN size := 10 END
-	END Check;
-	
-	PROCEDURE^ expr (n: DevCPT.Node; VAR x: DevCPL486.Item; hint, stop: SET);
-	
-	PROCEDURE DualExp (left, right: DevCPT.Node; VAR x, y: DevCPL486.Item; hx, hy, stpx, stpy: SET);
-		VAR ux, uy: SET; sx, sy: INTEGER;
-	BEGIN
-		Check(left, ux, sx); Check(right, uy, sy);
-		IF sy > sx THEN
-			expr(right, y, hy + stpy, ux + stpy * {AX, CX});
-			expr(left, x, hx, stpx);
-			DevCPC486.Assert(y, hy, stpy)
-		ELSE
-			expr(left, x, hx + stpx, uy);
-			expr(right, y, hy, stpy);
-			DevCPC486.Assert(x, hx, stpx)
-		END;
-	END DualExp;
-
-	PROCEDURE IntDOp (n: DevCPT.Node; VAR x: DevCPL486.Item; hint: SET);
-		VAR y: DevCPL486.Item; rev: BOOLEAN;
-	BEGIN
-		DualExp(n.left, n.right, x, y, hint, hint, {stk}, {stk});
-		IF (x.mode = Reg) & DevCPC486.Fits(x, hint) THEN
-			DevCPC486.IntDOp(x, y, n.subcl, FALSE)
-		ELSIF (y.mode = Reg) & DevCPC486.Fits(y, hint) THEN
-			DevCPC486.IntDOp(y, x, n.subcl, TRUE); x := y
-		ELSIF x.mode # Reg THEN
-			DevCPC486.Load(x, hint, {con}); DevCPC486.IntDOp(x, y, n.subcl, FALSE)
-		ELSIF y.mode # Reg THEN
-			DevCPC486.Load(y, hint, {con}); DevCPC486.IntDOp(y, x, n.subcl, TRUE); x := y
-		ELSE
-			DevCPC486.IntDOp(x, y, n.subcl, FALSE)
-		END
-	END IntDOp;
-	
-	PROCEDURE FloatDOp (n: DevCPT.Node; VAR x: DevCPL486.Item);
-		VAR y: DevCPL486.Item; ux, uy, uf: SET; sx, sy: INTEGER;
-	BEGIN
-		Check(n.left, ux, sx); Check(n.right, uy, sy);
-		IF (n.subcl = min) OR (n.subcl = max) THEN uf := {AX} ELSE uf := {} END;
-		IF (sy > sx) OR (sy = sx) & ((n.subcl = mod) OR (n.subcl = ash)) THEN
-			expr(n.right, x, {}, ux + {mem, stk});
-			expr(n.left, y, {}, uf);
-			DevCPC486.FloatDOp(x, y, n.subcl, TRUE)
-		ELSIF float IN uy THEN (* function calls in both operands *)
-			expr(n.left, y, {}, uy + {mem});
-			expr(n.right, x, {}, {mem, stk});
-			DevCPC486.FloatDOp(x, y, n.subcl, TRUE)
-		ELSE
-			expr(n.left, x, {}, uy + {mem, stk});
-			expr(n.right, y, {}, uf);
-			DevCPC486.FloatDOp(x, y, n.subcl, FALSE)
-		END
-	END FloatDOp;
-	
-	PROCEDURE design (n: DevCPT.Node; VAR x: DevCPL486.Item; hint, stop: SET);
-		VAR obj: DevCPT.Object; y: DevCPL486.Item; ux, uy: SET; sx, sy: INTEGER;
-	BEGIN
-		CASE n.class OF
-		  Nvar, Nvarpar:
-				obj := n.obj; x.mode := obj.mode; x.obj := obj; x.scale := 0;
-				IF obj.typ.comp = DynArr THEN x.mode := VarPar END;
-				IF obj.mnolev < 0 THEN x.offset := 0; x.tmode := Con
-				ELSIF x.mode = Var THEN x.offset := obj.adr; x.tmode := Con
-				ELSE x.offset := 0; x.tmode := VarPar
-				END
-		| Nfield:
-				design(n.left, x, hint, stop); DevCPC486.Field(x, n.obj)
-		| Nderef:
-				IF n.subcl # 0 THEN
-					expr(n.left, x, hint, stop);
-					IF n.typ.form = String8 THEN x.form := VString8 ELSE x.form := VString16 END
-				ELSE
-					expr(n.left, x, hint, stop + {mem} - {loaded}); DevCPC486.DeRef(x)
-				END
-		| Nindex:
-				Check(n.left, ux, sx); Check(n.right, uy, sy);
-				IF wreg - uy = {} THEN
-					expr(n.right, y, hint + stop, ux);
-					design(n.left, x, hint, stop);
-					IF x.scale # 0 THEN DevCPC486.Index(x, y, {}, {}) ELSE DevCPC486.Index(x, y, hint, stop) END
-				ELSE
-					design(n.left, x, hint, stop + uy);
-					IF x.scale # 0 THEN expr(n.right, y, {}, {}); DevCPC486.Index(x, y, {}, {})
-					ELSE expr(n.right, y, hint, stop); DevCPC486.Index(x, y, hint, stop)
-					END
-				END
-		| Nguard, Neguard:
-				IF n.typ.form = Pointer THEN
-					IF loaded IN stop THEN expr(n.left, x, hint, stop) ELSE expr(n.left, x, hint, stop + {mem}) END
-				ELSE design(n.left, x, hint, stop)
-				END;
-				DevCPC486.TypTest(x, n.typ, TRUE, n.class = Neguard)
-		| Nproc:
-				obj := n.obj; x.mode := obj.mode; x.obj := obj;
-				IF x.mode = TProc THEN x.offset := obj.num; (*mthno*) x.scale := n.subcl (* super *) END
-		END;
-		x.typ := n.typ
-	END design;
-	
-	PROCEDURE IsAllocDynArr (x: DevCPT.Node): BOOLEAN;
-	BEGIN
-		IF (x.typ.comp = DynArr) & ~x.typ.untagged THEN
-			WHILE x.class = Nindex DO x := x.left END;
-			IF x.class = Nderef THEN RETURN TRUE END
-		END;
-		RETURN FALSE
-	END IsAllocDynArr;
-	
-	PROCEDURE StringOp (left, right: DevCPT.Node; VAR x, y: DevCPL486.Item; useLen: BOOLEAN);
-		VAR ax, ay: DevCPL486.Item; ux: SET; sx: INTEGER;
-	BEGIN
-		Check(left, ux, sx);
-		expr(right, y, wreg - {SI} + ux, {});
-		ay := y; DevCPC486.GetAdr(ay, wreg - {SI} + ux, {}); DevCPC486.Assert(ay, wreg - {SI}, ux);
-		IF useLen & IsAllocDynArr(left) THEN	(* keep len descriptor *)
-			design(left, x, wreg - {CX}, {loaded});
-			DevCPC486.Prepare(x, wreg - {CX} + {deref}, {DI})
-		ELSE
-			expr(left, x, wreg - {DI}, {})
-		END;
-		ax := x; DevCPC486.GetAdr(ax, {}, wreg - {DI} + {stk, con});
-		DevCPC486.Load(ay, {}, wreg - {SI} + {con});
-		DevCPC486.Free(ax); DevCPC486.Free(ay)
-	END StringOp;
-	
-	PROCEDURE AdrExpr (n: DevCPT.Node; VAR x: DevCPL486.Item; hint, stop: SET);
-	BEGIN
-		IF n.class < Nconst THEN
-			design(n, x, hint + stop, {loaded}); DevCPC486.Prepare(x, hint + {deref}, stop)
-		ELSE expr(n, x, hint, stop)
-		END
-	END AdrExpr;
-	
-	(* ---------- interface pointer reference counting ---------- *)
-	
-	PROCEDURE HandleIPtrs (typ: DevCPT.Struct; VAR x, y: DevCPL486.Item; add, rel, init: BOOLEAN);
-	
-		PROCEDURE FindPtrs (typ: DevCPT.Struct; adr: INTEGER);
-			VAR fld: DevCPT.Object; btyp: DevCPT.Struct; i, n: INTEGER;
-		BEGIN
-			IF (typ.form = Pointer) & (typ.sysflag = interface) THEN
-				IF add THEN DevCPC486.IPAddRef(y, adr, TRUE) END;
-				IF rel THEN DevCPC486.IPRelease(x, adr, TRUE, init) END
-			ELSIF (typ.comp = Record) & (typ.sysflag # union) THEN
-				btyp := typ.BaseTyp;
-				IF btyp # NIL THEN FindPtrs(btyp, adr) END ;
-				fld := typ.link;
-				WHILE (fld # NIL) & (fld.mode = Fld) DO
-					IF (fld.sysflag = interface) & (fld.name^ = DevCPM.HdUtPtrName) THEN
-						IF add THEN DevCPC486.IPAddRef(y, fld.adr + adr, TRUE) END;
-						IF rel THEN DevCPC486.IPRelease(x, fld.adr + adr, TRUE, init) END
-					ELSE FindPtrs(fld.typ, fld.adr + adr)
-					END;
-					fld := fld.link
-				END
-			ELSIF typ.comp = Array THEN
-				btyp := typ.BaseTyp; n := typ.n;
-				WHILE btyp.comp = Array DO n := btyp.n * n; btyp := btyp.BaseTyp END ;
-				IF DevCPC486.ContainsIPtrs(btyp) THEN
-					i := 0;
-					WHILE i < n DO FindPtrs(btyp, adr); INC(adr, btyp.size); INC(i) END
-				END
-			ELSIF typ.comp = DynArr THEN 
-				IF DevCPC486.ContainsIPtrs(typ) THEN DevCPM.err(221) END
-			END
-		END FindPtrs;
-	
-	BEGIN
-		FindPtrs(typ, 0)
-	END HandleIPtrs;
-	
-	PROCEDURE CountedPtr (n: DevCPT.Node): BOOLEAN;
-	BEGIN
-		RETURN (n.typ.form = Pointer) & (n.typ.sysflag = interface)
-			& ((n.class = Ncall) OR (n.class = Ncomp) & (n.right.class = Ncall))
-	END CountedPtr;
-	
-	PROCEDURE IPAssign (nx, ny: DevCPT.Node; VAR x, y: DevCPL486.Item; ux: SET);
-		(* nx.typ.form = Pointer & nx.typ.sysflag = interface *)
-	BEGIN
-		expr(ny, y, {}, wreg - {SI} + {mem, stk});
-		IF (ny.class # Nconst) & ~CountedPtr(ny) THEN
-			DevCPC486.IPAddRef(y, 0, TRUE)
-		END;
-		IF nx # NIL THEN
-			DevCPC486.Assert(y, {}, wreg - {SI} + ux);
-			expr(nx, x, wreg - {DI}, {loaded});
-			IF (x.mode = Ind) & (x.reg IN wreg - {SI, DI}) OR (x.scale # 0) THEN
-				DevCPC486.GetAdr(x, {}, wreg - {DI} + {con});
-				x.mode := Ind; x.offset := 0; x.scale := 0
-			END;
-			DevCPC486.IPRelease(x, 0, TRUE, FALSE);
-		END
-	END IPAssign;
-	
-	PROCEDURE IPStructAssign (typ: DevCPT.Struct);
-		VAR x, y: DevCPL486.Item;
-	BEGIN
-		IF typ.comp = DynArr THEN DevCPM.err(270) END;
-		(* addresses in SI and DI *)
-		x.mode := Ind; x.reg := DI; x.offset := 0; x.scale := 0;
-		y.mode := Ind; y.reg := SI; y.offset := 0; y.scale := 0;
-		HandleIPtrs(typ, x, y, TRUE, TRUE, FALSE)
-	END IPStructAssign;
-
-	PROCEDURE IPFree (nx: DevCPT.Node; VAR x: DevCPL486.Item);
-	BEGIN
-		expr(nx, x, wreg - {DI}, {loaded}); DevCPC486.GetAdr(x, {}, wreg - {DI} + {con});
-		x.mode := Ind; x.offset := 0; x.scale := 0;
-		IF nx.typ.form = Comp THEN
-			HandleIPtrs(nx.typ, x, x, FALSE, TRUE, TRUE)
-		ELSE	(* nx.typ.form = Pointer & nx.typ.sysflag = interface *)
-			DevCPC486.IPRelease(x, 0, TRUE, TRUE);
-		END
-	END IPFree;
-	
-	(* unchanged val parameters allways counted because of aliasing problems REMOVED! *)
-	
-	PROCEDURE InitializeIPVars (proc: DevCPT.Object);
-		VAR x: DevCPL486.Item; obj: DevCPT.Object;
-	BEGIN
-		x.mode := Ind; x.reg := BP; x.scale := 0; x.form := Pointer;
-		obj := proc.link;
-		WHILE obj # NIL DO
-			IF (obj.mode = Var) & obj.used THEN	(* changed value parameters *)
-				x.offset := obj.adr;
-				HandleIPtrs(obj.typ, x, x, TRUE, FALSE, FALSE)
-			END;
-			obj := obj.link
-		END
-	END InitializeIPVars;
-	
-	PROCEDURE ReleaseIPVars (proc: DevCPT.Object);
-		VAR x, ax, dx, si, di: DevCPL486.Item; obj: DevCPT.Object;
-	BEGIN
-		obj := proc.link;
-		WHILE (obj # NIL) & ((obj.mode # Var) OR ~obj.used OR ~DevCPC486.ContainsIPtrs(obj.typ)) DO
-			obj := obj.link
-		END;
-		IF obj = NIL THEN
-			obj := proc.scope.scope;
-			WHILE (obj # NIL) & ~DevCPC486.ContainsIPtrs(obj.typ) DO obj := obj.link END;
-			IF obj = NIL THEN RETURN END
-		END;
-		DevCPL486.MakeReg(ax, AX, Int32); DevCPL486.MakeReg(si, SI, Int32);
-		DevCPL486.MakeReg(dx, DX, Int32); DevCPL486.MakeReg(di, DI, Int32);
-		IF ~(proc.typ.form IN {Real32, Real64, NoTyp}) THEN DevCPL486.GenMove(ax, si) END;
-		IF proc.typ.form = Int64 THEN DevCPL486.GenMove(dx, di) END;
-		x.mode := Ind; x.reg := BP; x.scale := 0; x.form := Pointer;
-		obj := proc.link;
-		WHILE obj # NIL DO
-			IF (obj.mode = Var) & obj.used THEN	(* value parameters *)
-				x.offset := obj.adr;
-				HandleIPtrs(obj.typ, x, x, FALSE, TRUE, FALSE)
-			END;
-			obj := obj.link
-		END;
-		obj := proc.scope.scope;
-		WHILE obj # NIL DO	(* local variables *)
-			IF obj.used THEN
-				x.offset := obj.adr;
-				HandleIPtrs(obj.typ, x, x, FALSE, TRUE, FALSE);
-			END;
-			obj := obj.link
-		END;
-		IF ~(proc.typ.form IN {Real32, Real64, NoTyp}) THEN DevCPL486.GenMove(si, ax) END;
-		IF proc.typ.form = Int64 THEN DevCPL486.GenMove(di, dx) END
-	END ReleaseIPVars;
-	
-	PROCEDURE CompareIntTypes (
-		typ: DevCPT.Struct; VAR id: DevCPL486.Item; VAR exit: DevCPL486.Label; VAR num: INTEGER
-	);
-		VAR x, y: DevCPL486.Item; local: DevCPL486.Label;
-	BEGIN
-		local := DevCPL486.NewLbl;
-		typ := typ.BaseTyp; num := 0;
-		WHILE (typ # NIL) & (typ # DevCPT.undftyp) DO
-			IF (typ.sysflag = interface) & (typ.ext # NIL) THEN
-				IF num > 0 THEN DevCPC486.JumpT(x, local) END;
-				DevCPC486.GuidFromString(typ.ext, y);
-				x := id; DevCPC486.GetAdr(x, wreg - {SI}, {mem});
-				x := y; DevCPC486.GetAdr(x, wreg - {DI}, {});
-				x := id; DevCPC486.CmpString(x, y, eql, FALSE);
-				INC(num)
-			END;
-			typ := typ.BaseTyp
-		END;
-		IF num > 0 THEN DevCPC486.JumpF(x, exit) END;
-		IF num > 1 THEN DevCPL486.SetLabel(local) END
-	END CompareIntTypes;
-	
-	PROCEDURE InstallQueryInterface (typ: DevCPT.Struct; proc: DevCPT.Object);
-		VAR this, id, int, unk, c: DevCPL486.Item; nil, end: DevCPL486.Label; num: INTEGER;
-	BEGIN
-		nil := DevCPL486.NewLbl; end := DevCPL486.NewLbl;
-		this.mode := Ind; this.reg := BP; this.offset := 8; this.scale := 0; this.form := Pointer; this.typ := DevCPT.anyptrtyp;
-		id.mode := DInd; id.reg := BP; id.offset := 12; id.scale := 0; id.form := Pointer;
-		int.mode := DInd; int.reg := BP; int.offset := 16; int.scale := 0; int.form := Pointer;
-		DevCPC486.GetAdr(int, {}, {AX, CX, SI, DI, mem}); int.mode := Ind; int.offset := 0;
-		DevCPL486.MakeConst(c, 0, Pointer); DevCPC486.Assign(int, c);
-		unk.mode := Ind; unk.reg := BP; unk.offset := 8; unk.scale := 0; unk.form := Pointer; unk.typ := DevCPT.punktyp;
-		DevCPC486.Load(unk, {}, {});
-		unk.mode := Ind; unk.offset := 8;
-		DevCPC486.Load(unk, {}, {});
-		DevCPL486.GenComp(c, unk);
-		DevCPL486.GenJump(4, nil, TRUE);
-		DevCPL486.MakeReg(c, int.reg, Pointer);
-		DevCPL486.GenPush(c);
-		c.mode := Ind; c.reg := BP; c.offset := 12; c.scale := 0; c.form := Pointer;
-		DevCPL486.GenPush(c);
-		DevCPL486.GenPush(unk);
-		c.mode := Ind; c.reg := unk.reg; c.offset := 0; c.scale := 0; c.form := Pointer;
-		DevCPL486.GenMove(c, unk);
-		unk.mode := Ind; unk.offset := 0; unk.scale := 0; unk.form := Pointer;
-		DevCPL486.GenCall(unk);
-		DevCPC486.Free(unk);
-		DevCPL486.GenJump(-1, end, FALSE);
-		DevCPL486.SetLabel(nil);
-		DevCPL486.MakeConst(c, 80004002H, Int32);	(* E_NOINTERFACE *)
-		DevCPC486.Result(proc, c);
-		CompareIntTypes(typ, id, end, num);
-		IF num > 0 THEN
-			DevCPC486.Load(this, {}, {});
-			DevCPC486.Assign(int, this);
-			DevCPC486.IPAddRef(this, 0, FALSE);
-			DevCPL486.MakeConst(c, 0, Int32);	(* S_OK *)
-			DevCPC486.Result(proc, c);
-		END;
-		DevCPL486.SetLabel(end)
-	END InstallQueryInterface;
-
-	(* -------------------- *)
-
-	PROCEDURE ActualPar (n: DevCPT.Node; fp: DevCPT.Object; rec: BOOLEAN; VAR tag: DevCPL486.Item);
-		VAR ap: DevCPL486.Item; x: DevCPT.Node; niltest: BOOLEAN;
-	BEGIN
-		IF n # NIL THEN
-			ActualPar(n.link, fp.link, FALSE, ap);
-			niltest := FALSE;
-			IF fp.mode = VarPar THEN
-				IF (n.class = Ndop) & ((n.subcl = thisarrfn) OR (n.subcl = thisrecfn)) THEN
-					expr(n.right, ap, {}, {}); DevCPC486.Push(ap);	(* push type/length *)
-					expr(n.left, ap, {}, {}); DevCPC486.Push(ap);	(* push adr *)
-					RETURN
-				ELSIF (fp.vis = outPar) & DevCPC486.ContainsIPtrs(fp.typ) & (ap.typ # DevCPT.niltyp) THEN
-					IPFree(n, ap)
-				ELSE
-					x := n;
-					WHILE (x.class = Nfield) OR (x.class = Nindex) DO x := x.left END;
-					niltest := x.class = Nderef;	(* explicit nil test needed *)
-					AdrExpr(n, ap, {}, {})
-				END
-			ELSIF (n.class = Nmop) & (n.subcl = conv) THEN
-				IF n.typ.form IN {String8, String16} THEN expr(n, ap, {}, {}); DevCPM.err(265)
-				ELSIF (DevCPT.Includes(n.typ.form, n.left.typ.form) OR DevCPT.Includes(n.typ.form, fp.typ.form))
-					& (n.typ.form # Set) & (fp.typ # DevCPT.bytetyp) THEN expr(n.left, ap, {}, {high});
-				ELSE expr(n, ap, {}, {high});
-				END
-			ELSE expr(n, ap, {}, {high});
-				IF CountedPtr(n) THEN DevCPM.err(270) END
-			END;
-			DevCPC486.Param(fp, rec, niltest, ap, tag)
-		END
-	END ActualPar;
-	
-	PROCEDURE Call (n: DevCPT.Node; VAR x: DevCPL486.Item);
-		VAR tag: DevCPL486.Item; proc: DevCPT.Object; m: BYTE;
-	BEGIN
-		IF n.left.class = Nproc THEN
-			proc := n.left.obj; m := proc.mode;
-		ELSE proc := NIL; m := 0
-		END;
-		IF (m = CProc) & (n.right # NIL) THEN
-			ActualPar(n.right.link, n.obj.link, FALSE, tag);
-			expr(n.right, tag, wreg - {AX}, {});	(* tag = first param *)
-		ELSE
-			IF proc # NIL THEN DevCPC486.PrepCall(proc) END;
-			ActualPar(n.right, n.obj, (m = TProc) & (n.left.subcl = 0), tag);
-		END;
-		IF proc # NIL THEN design(n.left, x, {}, {}) ELSE expr(n.left, x, {}, {}) END;
-		DevCPC486.Call(x, tag)
-	END Call;
-
-	PROCEDURE Mem (n: DevCPT.Node; VAR x: DevCPL486.Item; typ: DevCPT.Struct; hint, stop: SET);
-		VAR offset: INTEGER;
-	BEGIN
-		IF (n.class = Ndop) & (n.subcl IN {plus, minus}) & (n.right.class = Nconst) THEN
-			expr(n.left, x, hint, stop + {mem}); offset := n.right.conval.intval;
-			IF n.subcl = minus THEN offset := -offset END
-		ELSE
-			expr(n, x, hint, stop + {mem}); offset := 0
-		END;
-		DevCPC486.Mem(x, offset, typ)
-	END Mem;
-	
-	PROCEDURE^ CompStat (n: DevCPT.Node);
-	PROCEDURE^ CompRelease (n: DevCPT.Node; VAR res: DevCPL486.Item);
-
-	PROCEDURE condition (n: DevCPT.Node; VAR x: DevCPL486.Item; VAR false, true: DevCPL486.Label);
-		VAR local: DevCPL486.Label; y, z: DevCPL486.Item; ux: SET; sx, num: INTEGER; f: BYTE; typ: DevCPT.Struct;
-	BEGIN
-		IF n.class = Nmop THEN
-			CASE n.subcl OF
-			   not: condition(n.left, x, true, false); DevCPC486.Not(x)
-			| is: IF n.left.typ.form = Pointer THEN expr(n.left, x, {}, {mem})
-					ELSE design(n.left, x, {}, {})
-					END;
-					DevCPC486.TypTest(x, n.obj.typ, FALSE, FALSE)
-			| odd: expr(n.left, x, {}, {}); DevCPC486.Odd(x)
-			| cc: expr(n.left, x, {}, {}); x.mode := Cond; x.form := Bool
-			| val: DevCPM.err(220)
-			END
-		ELSIF n.class = Ndop THEN
-			CASE n.subcl OF
-			   and: local := DevCPL486.NewLbl; condition(n.left, y, false, local);
-					DevCPC486.JumpF(y, false);
-					IF local # DevCPL486.NewLbl THEN DevCPL486.SetLabel(local) END;
-					condition(n.right, x, false, true)
-			| or: local := DevCPL486.NewLbl; condition(n.left, y, local, true);
-					DevCPC486.JumpT(y, true);
-					IF local # DevCPL486.NewLbl THEN DevCPL486.SetLabel(local) END;
-					condition(n.right, x, false, true)
-			| eql..geq:
-					f := n.left.typ.form;
-					IF f = Int64 THEN DevCPM.err(260)
-					ELSIF f IN {String8, String16, Comp} THEN
-						IF (n.left.class = Nmop) & (n.left.subcl = conv) THEN	(* converted must be source *)
-							StringOp(n.right, n.left, x, y, FALSE); DevCPC486.CmpString(x, y, n.subcl, TRUE)
-						ELSE
-							StringOp(n.left, n.right, x, y, FALSE); DevCPC486.CmpString(x, y, n.subcl, FALSE)
-						END
-					ELSIF f IN {Real32, Real64} THEN FloatDOp(n, x)
-					ELSE
-						IF CountedPtr(n.left) OR CountedPtr(n.right) THEN DevCPM.err(270) END;
-						DualExp(n.left, n.right, x, y, {}, {}, {stk}, {stk});
-						IF (x.mode = Reg) OR (y.mode = Con) THEN DevCPC486.IntDOp(x, y, n.subcl, FALSE)
-						ELSIF (y.mode = Reg) OR (x.mode = Con) THEN DevCPC486.IntDOp(y, x, n.subcl, TRUE); x := y
-						ELSE DevCPC486.Load(x, {}, {}); DevCPC486.IntDOp(x, y, n.subcl, FALSE)
-						END 
-					END
-			| in: DualExp(n.left, n.right, x, y, {}, {}, {short, mem, stk}, {con, stk});
-					DevCPC486.In(x, y)
-			| bit: Check(n.left, ux, sx);
-					expr(n.right, x, {}, ux + {short});
-					Mem(n.left, y, DevCPT.notyp, {}, {});
-					DevCPC486.Load(x, {}, {short});
-					DevCPC486.In(x, y)
-			| queryfn:
-					AdrExpr(n.right, x, {}, {CX, SI, DI});
-					CompareIntTypes(n.left.typ, x, false, num);
-					IF num > 0 THEN 
-						Check(n.right.link, ux, sx); IPAssign(n.right.link, n.left, x, y, ux); DevCPC486.Assign(x, y);
-						x.offset := 1	(* true *)
-					ELSE x.offset := 0	(* false *)
-					END;
-					x.mode := Con; DevCPC486.MakeCond(x)
-			END
-		ELSIF n.class = Ncomp THEN
-			CompStat(n.left); condition(n.right, x, false, true); CompRelease(n.left, x);
-			IF x.mode = Stk THEN DevCPL486.GenCode(9DH); (* pop flags *) x.mode := Cond END
-		ELSE expr(n, x, {}, {}); DevCPC486.MakeCond(x)	(* const, var, or call *)
-		END
-	END condition;
-	
-	PROCEDURE expr(n: DevCPT.Node; VAR x: DevCPL486.Item; hint, stop: SET);
-		VAR y, z: DevCPL486.Item; f, g: BYTE; cval: DevCPT.Const; false, true: DevCPL486.Label;
-			uy: SET; sy: INTEGER; r: REAL;
-	BEGIN
-		f := n.typ.form;
-		IF (f = Bool) & (n.class IN {Ndop, Nmop}) THEN
-			false := DevCPL486.NewLbl; true := DevCPL486.NewLbl;
-			condition(n, y, false, true);
-			DevCPC486.LoadCond(x, y, false, true, hint, stop + {mem})
-		ELSE
-			CASE n.class OF
-			   Nconst:
-					IF n.obj = NIL THEN cval := n.conval ELSE cval := n.obj.conval END;
-					CASE f OF
-					   Byte..Int32, NilTyp, Pointer, Char16: DevCPL486.MakeConst(x, cval.intval, f)
-					| Int64:
-						DevCPL486.MakeConst(x, cval.intval, f);
-						DevCPE.GetLongWords(cval, x.scale, x.offset)
-					| Set: DevCPL486.MakeConst(x, SYSTEM.VAL(INTEGER, cval.setval), Set)
-					| String8, String16, Real32, Real64: DevCPL486.AllocConst(x, cval, f)
-					| Comp: 
-						ASSERT(n.typ = DevCPT.guidtyp);
-						IF n.conval # NIL THEN DevCPC486.GuidFromString(n.conval.ext, x)
-						ELSE DevCPC486.GuidFromString(n.obj.typ.ext, x)
-						END
-					END
-			| Nupto:	(* n.typ = DevCPT.settyp *)
-					Check(n.right, uy, sy);
-					expr(n.left, x, {}, wreg - {CX} + {high, mem, stk});
-					DevCPC486.MakeSet(x, TRUE, FALSE, hint + stop + uy, {});
-					DevCPC486.Assert(x, {}, uy);
-					expr(n.right, y, {}, wreg - {CX} + {high, mem, stk});
-					DevCPC486.MakeSet(y, TRUE, TRUE, hint + stop, {});
-					DevCPC486.Load(x, hint + stop, {});
-					IF x.mode = Con THEN DevCPC486.IntDOp(y, x, msk, TRUE); x := y
-					ELSE DevCPC486.IntDOp(x, y, msk, FALSE)
-					END
-			| Nmop:
-					CASE n.subcl OF
-					| bit:
-							expr(n.left, x, {}, wreg - {CX} + {high, mem, stk});
-							DevCPC486.MakeSet(x, FALSE, FALSE, hint + stop, {})
-					| conv:
-							IF f IN {String8, String16} THEN
-								expr(n.left, x, hint, stop);
-								IF f = String8 THEN x.form := VString16to8 END	(* SHORT *)
-							ELSE
-								IF n.left.class = Nconst THEN	(* largeint -> longreal *)
-									ASSERT((n.left.typ.form = Int64) & (f = Real64));
-									DevCPL486.AllocConst(x, n.left.conval, n.left.typ.form);
-								ELSE
-									expr(n.left, x, hint + stop, {high});
-								END;
-								DevCPC486.Convert(x, f, -1, hint + stop, {})	(* ??? *)
-							END
-					| val:
-							expr(n.left, x, hint + stop, {high, con}); DevCPC486.Convert(x, f, n.typ.size, hint, stop)	(* ??? *)
-					| adr:
-							IF n.left.class = Ntype THEN
-								x.mode := Con; x.offset := 0; x.obj := n.left.obj; x.form := Int32; x.typ := n.left.typ;
-							ELSE
-								AdrExpr(n.left, x, hint + stop, {});
-							END;
-							DevCPC486.GetAdr(x, hint + stop, {})
-					| typfn:
-							IF n.left.class = Ntype THEN
-								x.mode := Con; x.offset := 0; x.obj := n.left.obj; x.form := Int32; x.typ := n.left.typ;
-								IF x.obj.typ.untagged THEN DevCPM.err(111) END
-							ELSE
-								expr(n.left, x, hint + stop, {});
-								DevCPC486.Tag(x, y); DevCPC486.Free(x); x := y
-							END;
-							DevCPC486.Load(x, hint + stop, {})
-					| minus, abs, cap:
-							expr(n.left, x, hint + stop, {mem, stk});
-							IF f = Int64 THEN DevCPM.err(260)
-							ELSIF f IN realSet THEN DevCPC486.FloatMOp(x, n.subcl)
-							ELSE DevCPC486.IntMOp(x, n.subcl)
-							END
-					END
-			| Ndop:
-					IF (f IN realSet) & (n.subcl # lsh) & (n.subcl # rot) THEN
-						IF (n.subcl = ash) & (n.right.class = Nconst) & (n.right.conval.realval >= 0) THEN
-							expr(n.left, x, {}, {mem, stk});
-							cval := n.right.conval; sy := SHORT(ENTIER(cval.realval)); cval.realval := 1;
-							WHILE sy > 0 DO cval.realval := cval.realval * 2; DEC(sy) END;
-							DevCPL486.AllocConst(y, cval, Real32);
-							DevCPC486.FloatDOp(x, y, times, FALSE)
-						ELSE FloatDOp(n, x)
-						END
-					ELSIF (f = Int64) OR (n.typ = DevCPT.intrealtyp) THEN DevCPM.err(260); expr(n.left, x, {}, {})
-					ELSE
-						CASE n.subcl OF
-						   times:
-								IF f = Int8 THEN
-									DualExp(n.left, n.right, x, y, {}, {}, wreg - {AX} + {high, mem, stk, con}, {AX, con, stk});
-									DevCPC486.IntDOp(x, y, times, FALSE)
-								ELSE IntDOp(n, x, hint + stop)
-								END
-						| div, mod:
-								DualExp(n.left, n.right, x, y, {}, {}, wreg - {AX} + {high, mem, stk, con}, {AX, DX, mem, stk});
-								DevCPC486.DivMod(x, y, n.subcl = mod)
-						| plus:
-								IF n.typ.form IN {String8, String16} THEN DevCPM.err(265); expr(n.left, x, {}, {})
-								ELSE IntDOp(n, x, hint + stop)
-								END
-						| slash, minus, msk, min, max:
-								IntDOp(n, x, hint + stop)
-						| ash, lsh, rot:
-								uy := {}; IF n.right.class # Nconst THEN uy := {CX} END;
-								DualExp(n^.right, n^.left, y, x, {}, hint + stop, wreg - {CX} + {high, mem, stk}, uy + {con, mem, stk});
-								DevCPC486.Shift(x, y, n^.subcl)
-						| len:
-								IF n.left.typ.form IN {String8, String16} THEN
-									expr(n.left, x, wreg - {DI} , {}); DevCPC486.GetAdr(x, {}, wreg - {DI} + {con});
-									DevCPC486.StrLen(x, n.left.typ, FALSE)
-								ELSE
-									design(n.left, x, hint + stop, {}); expr(n.right, y, {}, {}); DevCPC486.Len(x, y)
-								END
-						END
-					END
-			| Ncall:
-					Call(n, x)
-			| Ncomp:
-					CompStat(n.left); expr(n.right, x, hint, stop); CompRelease(n.left, x);
-					IF x.mode = Stk THEN DevCPC486.Pop(x, x.form, hint, stop) END
-			ELSE
-				design(n, x, hint + stop, stop * {loaded}); DevCPC486.Prepare(x, hint + stop, {})	(* ??? *)
-			END
-		END;
-		x.typ := n.typ;
-		DevCPC486.Assert(x, hint, stop)
-	END expr;
-	
-	PROCEDURE AddCopy (n: DevCPT.Node; VAR dest, dadr, len: DevCPL486.Item; last: BOOLEAN);
-		VAR adr, src: DevCPL486.Item; u: SET; s: INTEGER;
-	BEGIN
-		Check(n, u, s);
-		DevCPC486.Assert(dadr, wreg - {DI}, u + {SI, CX});
-		IF len.mode # Con THEN DevCPC486.Assert(len, wreg - {CX}, u + {SI, DI}) END;
-		expr(n, src, wreg - {SI}, {});
-		adr := src; DevCPC486.GetAdr(adr, {}, wreg - {SI} + {con});
-		IF len.mode # Con THEN DevCPC486.Load(len, {}, wreg - {CX} + {con}) END;
-		DevCPC486.Load(dadr, {}, wreg - {DI} + {con});
-		DevCPC486.AddCopy(dest, src, last)
-	END AddCopy;
-	
-	PROCEDURE StringCopy (left, right: DevCPT.Node);
-		VAR x, y, ax, ay, len: DevCPL486.Item;
-	BEGIN
-		IF IsAllocDynArr(left) THEN expr(left, x, wreg - {CX}, {DI})	(* keep len descriptor *)
-		ELSE expr(left, x, wreg - {DI}, {})
-		END;
-		ax := x; DevCPC486.GetAdr(ax, {}, wreg - {DI});
-		DevCPC486.Free(x); DevCPC486.ArrayLen(x, len, wreg - {CX}, {});
-		WHILE right.class = Ndop DO
-			ASSERT(right.subcl = plus);
-			AddCopy(right.left, x, ax, len, FALSE);
-			right := right.right
-		END;
-		AddCopy(right, x, ax, len, TRUE);
-		DevCPC486.Free(len)
-	END StringCopy;
-	
-	PROCEDURE Checkpc;
-	BEGIN
-		DevCPE.OutSourceRef(DevCPM.errpos)
-	END Checkpc;
-
-	PROCEDURE^ stat (n: DevCPT.Node; VAR end: DevCPL486.Label);
-	
-	PROCEDURE CondStat (if, last: DevCPT.Node; VAR hint: INTEGER; VAR else, end: DevCPL486.Label);
-		VAR local: DevCPL486.Label; x: DevCPL486.Item; cond, lcond: DevCPT.Node;
-	BEGIN
-		local := DevCPL486.NewLbl;
-		DevCPM.errpos := if.conval.intval; Checkpc; cond := if.left;
-		IF (last # NIL) & (cond.class = Ndop) & (cond.subcl >= eql) & (cond.subcl <= geq)
-				& (last.class = Ndop) & (last.subcl >= eql) & (last.subcl <= geq)
-				& SameExp(cond.left, last.left) & SameExp(cond.right, last.right) THEN	(*  reuse comparison *)
-			DevCPC486.setCC(x, cond.subcl, ODD(hint), hint >= 2)
-		ELSIF (last # NIL) & (cond.class = Nmop) & (cond.subcl = is) & (last.class = Nmop) & (last.subcl = is)
-				& SameExp(cond.left, last.left) THEN
-			DevCPC486.ShortTypTest(x, cond.obj.typ)	(* !!! *)
-		ELSE condition(cond, x, else, local)
-		END;
-		hint := x.reg;
-		DevCPC486.JumpF(x, else);
-		IF local # DevCPL486.NewLbl THEN DevCPL486.SetLabel(local) END;
-		stat(if.right, end);
-	END CondStat;
-
-	PROCEDURE IfStat (n: DevCPT.Node; withtrap: BOOLEAN; VAR end: DevCPL486.Label);
-		VAR else, local: DevCPL486.Label; if, last: DevCPT.Node; hint: INTEGER;
-	BEGIN	(* n.class = Nifelse *)
-		if := n.left; last := NIL;
-		WHILE (if # NIL) & ((if.link # NIL) OR (n.right # NIL) OR withtrap) DO
-			else := DevCPL486.NewLbl; 
-			CondStat(if, last, hint, else, end);
-			IF sequential THEN DevCPC486.Jump(end) END;
-			DevCPL486.SetLabel(else); last := if.left; if := if.link
-		END;
-		IF n.right # NIL THEN stat(n.right, end)
-		ELSIF withtrap THEN DevCPM.errpos := n.conval.intval; Checkpc; DevCPC486.Trap(withTrap); sequential := FALSE
-		ELSE CondStat(if, last, hint, end, end)
-		END
-	END IfStat;
-	
-	PROCEDURE CasePart (n: DevCPT.Node; VAR x: DevCPL486.Item; VAR else: DevCPL486.Label; last: BOOLEAN);
-		VAR this, higher: DevCPL486.Label; m: DevCPT.Node; low, high: INTEGER;
-	BEGIN
-		IF n # NIL THEN
-			this := SHORT(ENTIER(n.conval.realval));
-			IF useTree IN n.conval.setval THEN
-				IF n.left # NIL THEN
-					IF n.right # NIL THEN
-						higher := DevCPL486.NewLbl;
-						DevCPC486.CaseJump(x, n.conval.intval, n.conval.intval2, this, higher, TRUE, FALSE);
-						CasePart(n.left, x, else, FALSE);
-						DevCPL486.SetLabel(higher);
-						CasePart(n.right, x, else, last)
-					ELSE
-						DevCPC486.CaseJump(x, n.conval.intval, n.conval.intval2, this, else, FALSE, FALSE);
-						CasePart(n.left, x, else, last);
-					END
-				ELSE
-					DevCPC486.CaseJump(x, n.conval.intval, n.conval.intval2, this, else, FALSE, TRUE);
-					IF n.right # NIL THEN CasePart(n.right, x, else, last)
-					ELSIF ~last THEN DevCPC486.Jump(else)
-					END
-				END
-			ELSE
-				IF useTable IN n.conval.setval THEN
-					m := n; WHILE m.left # NIL DO m := m.left END; low := m.conval.intval;
-					m := n; WHILE m.right # NIL DO m := m.right END; high := m.conval.intval2;
-					DevCPC486.CaseTableJump(x, low, high, else);
-					actual := low; last := TRUE
-				END;
-				CasePart(n.left, x, else, FALSE);
-				WHILE actual < n.conval.intval DO
-					DevCPL486.GenCaseEntry(else, FALSE); INC(actual)
-				END;
-				WHILE actual < n.conval.intval2 DO
-					DevCPL486.GenCaseEntry(this, FALSE); INC(actual)
-				END;
-				DevCPL486.GenCaseEntry(this, last & (n.right = NIL)); INC(actual);
-				CasePart(n.right, x, else, last)
-			END;
-			n.conval.realval := this
-		END
-	END CasePart;
-	
-	PROCEDURE CaseStat (n: DevCPT.Node; VAR end: DevCPL486.Label);
-		VAR x: DevCPL486.Item; case, lab: DevCPT.Node; low, high, tab: INTEGER; else, this: DevCPL486.Label;
-	BEGIN
-		expr(n.left, x, {}, {mem, con, short, float, stk}); else := DevCPL486.NewLbl;
-		IF (n.right.right # NIL) & (n.right.right.class = Ngoto) THEN	(* jump to goto optimization *)
-			CasePart(n.right.link, x, else, FALSE); DevCPC486.Free(x);
-			n.right.right.right.conval.intval2 := else; sequential := FALSE
-		ELSE
-			CasePart(n.right.link, x, else, TRUE); DevCPC486.Free(x);
-			DevCPL486.SetLabel(else);
-			IF n.right.conval.setval # {} THEN stat(n.right.right, end)
-			ELSE DevCPC486.Trap(caseTrap); sequential := FALSE
-			END
-		END;
-		case := n.right.left;
-		WHILE case # NIL DO	(* case.class = Ncasedo *)
-			IF sequential THEN DevCPC486.Jump(end) END;
-			lab := case.left;
-			IF (case.right # NIL) & (case.right.class = Ngoto) THEN	(* jump to goto optimization *)
-				case.right.right.conval.intval2 := SHORT(ENTIER(lab.conval.realval));
-				ASSERT(lab.link = NIL); sequential := FALSE
-			ELSE
-				WHILE lab # NIL DO
-					this := SHORT(ENTIER(lab.conval.realval)); DevCPL486.SetLabel(this); lab := lab.link
-				END;
-				stat(case.right, end)
-			END;
-			case := case.link
-		END
-	END CaseStat;
-
-	PROCEDURE Dim(n: DevCPT.Node; VAR x, nofel: DevCPL486.Item; VAR fact: INTEGER; dimtyp: DevCPT.Struct);
-		VAR len: DevCPL486.Item; u: SET; s: INTEGER;
-	BEGIN
-		Check(n, u, s);
-		IF (nofel.mode = Reg) & (nofel.reg IN u) THEN DevCPC486.Push(nofel) END;
-		expr(n, len, {}, {mem, short});
-		IF nofel.mode = Stk THEN DevCPC486.Pop(nofel, Int32, {}, {}) END;
-		IF len.mode = Stk THEN DevCPC486.Pop(len, Int32, {}, {}) END;
-		DevCPC486.MulDim(len, nofel, fact, dimtyp);
-		IF n.link # NIL THEN
-			Dim(n.link, x, nofel, fact, dimtyp.BaseTyp);
-		ELSE
-			DevCPC486.New(x, nofel, fact)
-		END;
-		DevCPC486.SetDim(x, len, dimtyp)
-	END Dim;
-
-	PROCEDURE CompStat (n: DevCPT.Node);
-		VAR x, y, sp, old, len, nofel: DevCPL486.Item; fact: INTEGER; typ: DevCPT.Struct;
-	BEGIN
-		Checkpc;
-		WHILE (n # NIL) & DevCPM.noerr DO
-			ASSERT(n.class = Nassign);
-			IF n.subcl = assign THEN
-				IF n.right.typ.form IN {String8, String16} THEN
-					StringCopy(n.left, n.right)
-				ELSE
-					IF (n.left.typ.sysflag = interface) & ~CountedPtr(n.right) THEN
-						IPAssign(NIL, n.right, x, y, {});	(* no Release *)
-					ELSE expr(n.right, y, {}, {})
-					END;
-					expr(n.left, x, {}, {});
-					DevCPC486.Assign(x, y)
-				END
-			ELSE ASSERT(n.subcl = newfn);
-				typ := n.left.typ.BaseTyp;
-				ASSERT(typ.comp = DynArr);
-				ASSERT(n.right.link = NIL);
-				expr(n.right, y, {}, wreg - {CX} + {mem, stk});
-				DevCPL486.MakeReg(sp, SP, Int32);
-				DevCPC486.CopyReg(sp, old, {}, {CX});
-				DevCPC486.CopyReg(y, len, {}, {CX});
-				IF typ.BaseTyp.form = Char16 THEN
-					DevCPL486.MakeConst(x, 2, Int32); DevCPL486.GenMul(x, y, FALSE)
-				END;
-				DevCPC486.StackAlloc;
-				DevCPC486.Free(y);
-				expr(n.left, x, {}, {}); DevCPC486.Assign(x, sp);
-				DevCPC486.Push(len);
-				DevCPC486.Push(old);
-				typ.sysflag := stackArray
-			END;
-			n := n.link
-		END
-	END CompStat;
-	
-	PROCEDURE CompRelease (n: DevCPT.Node; VAR res: DevCPL486.Item);
-		VAR x, y, sp: DevCPL486.Item;
-	BEGIN
-		IF n.link # NIL THEN CompRelease(n.link, res) END;
-		ASSERT(n.class = Nassign);
-		IF n.subcl = assign THEN
-			IF (n.left.typ.form = Pointer) & (n.left.typ.sysflag = interface) THEN
-				IF res.mode = Cond THEN
-					DevCPL486.GenCode(9CH); (* push flags *)
-					res.mode := Stk
-				ELSIF res.mode = Reg THEN
-					IF res.form < Int16 THEN DevCPC486.Push(res)
-					ELSE DevCPC486.Assert(res, {}, {AX, CX, DX})
-					END
-				END;
-				expr(n.left, x, wreg - {DI}, {loaded});
-				DevCPC486.IPRelease(x, 0, TRUE, TRUE);
-				n.left.obj.used := FALSE
-			END
-		ELSE ASSERT(n.subcl = newfn);
-			DevCPL486.MakeReg(sp, SP, Int32); DevCPL486.GenPop(sp);
-			DevCPL486.MakeConst(y, 0, Pointer);
-			expr(n.left, x, {}, {}); DevCPC486.Assign(x, y)
-		END
-	END CompRelease;
-	
-	PROCEDURE Assign(n: DevCPT.Node; ux: SET);
-		VAR r: DevCPT.Node; f: BYTE; false, true: DevCPL486.Label; x, y, z: DevCPL486.Item; uf, uy: SET; s: INTEGER;
-	BEGIN
-		r := n.right; f := r.typ.form; uf := {};
-		IF (r.class IN {Nmop, Ndop}) THEN
-			IF (r.subcl = conv) & (f # Set) &
-(*
-				(DevCPT.Includes(f, r.left.typ.form) OR DevCPT.Includes(f, n.left.typ.form)) THEN r := r.left;
-				IF ~(f IN realSet) & (r.typ.form IN realSet) & (r.typ # DevCPT.intrealtyp) THEN uf := {AX} END (* entier *)
-*)
-				(DevCPT.Includes(f, r.left.typ.form) OR DevCPT.Includes(f, n.left.typ.form)) &
-				((f IN realSet) OR ~(r.left.typ.form IN realSet)) THEN r := r.left
-			ELSIF (f IN {Char8..Int32, Set, Char16, String8, String16}) & SameExp(n.left, r.left) THEN
-				IF r.class = Ndop THEN
-					IF (r.subcl IN {slash, plus, minus, msk}) OR (r.subcl = times) & (f = Set) THEN
-						expr(r.right, y, {}, ux); expr(n.left, x, {}, {});
-						DevCPC486.Load(y, {}, {}); DevCPC486.IntDOp(x, y, r.subcl, FALSE);
-						RETURN
-					ELSIF r.subcl IN {ash, lsh, rot} THEN
-						expr(r.right, y, wreg - {CX} + {high, mem}, ux); expr(n.left, x, {}, {});
-						DevCPC486.Load(y, {}, wreg - {CX} + {high}); DevCPC486.Shift(x, y, r.subcl);
-						RETURN
-					END
-				ELSE
-					IF r.subcl IN {minus, abs, cap} THEN
-						expr(n.left, x, {}, {}); DevCPC486.IntMOp(x, r.subcl); RETURN
-					END
-				END
-			ELSIF f = Bool THEN
-				IF (r.subcl = not) & SameExp(n.left, r.left) THEN
-					expr(n.left, x, {}, {}); DevCPC486.IntMOp(x, not); RETURN
-				END
-			END
-		END;
-		IF (n.left.typ.sysflag = interface) & (n.left.typ.form = Pointer) THEN IPAssign(n.left, r, x, y, ux)
-		ELSE expr(r, y, {high}, ux); expr(n.left, x, {}, uf + {loaded});	(* high ??? *)
-		END;
-		DevCPC486.Assign(x, y)
-	END Assign;
-	
-	PROCEDURE stat (n: DevCPT.Node; VAR end: DevCPL486.Label);
-		VAR x, y, nofel: DevCPL486.Item; local, next, loop, prevExit: DevCPL486.Label; fact, sx, sz: INTEGER; ux, uz: SET;
-	BEGIN
-		sequential := TRUE; INC(nesting);
-		WHILE (n # NIL) & DevCPM.noerr DO
-			IF n.link = NIL THEN next := end ELSE next := DevCPL486.NewLbl END;
-			DevCPM.errpos := n.conval.intval; DevCPL486.BegStat;
-			CASE n.class OF
-			| Ninittd:
-					(* done at load-time *)
-			| Nassign:
-					Checkpc;
-					Check(n.left, ux, sx);
-					CASE n.subcl OF
-					   assign:
-							IF n.left.typ.form = Comp THEN
-								IF (n.right.class = Ndop) & (n.right.typ.form IN {String8, String16}) THEN
-									StringCopy(n.left, n.right)
-								ELSE
-									StringOp(n.left, n.right, x, y, TRUE);
-									IF DevCPC486.ContainsIPtrs(n.left.typ) THEN IPStructAssign(n.left.typ) END;
-									DevCPC486.Copy(x, y, FALSE)
-								END
-							ELSE Assign(n, ux)
-							END
-					| getfn:
-							Mem(n.right, y, n.left.typ, {}, ux);
-							expr(n.left, x, {}, {loaded});
-							DevCPC486.Assign(x, y)
-					| putfn:
-							expr(n.right, y, {}, ux);
-							Mem(n.left, x, n.right.typ, {}, {});
-							DevCPC486.Assign(x, y)
-					| incfn, decfn:
-							expr(n.right, y, {}, ux); expr(n.left, x, {}, {});
-							IF n.left.typ.form = Int64 THEN 
-								DevCPC486.LargeInc(x, y, n.subcl = decfn)
-							ELSE
-								DevCPC486.Load(y, {}, {}); DevCPC486.IntDOp(x, y, SHORT(SHORT(plus - incfn + n.subcl)), FALSE)
-							END
-					| inclfn:
-							expr(n.right, y, {}, wreg - {CX} + {high, mem, stk}); DevCPC486.MakeSet(y, FALSE, FALSE, ux, {});
-							DevCPC486.Assert(y, {}, ux); expr(n.left, x, {}, {});
-							DevCPC486.Load(y, {}, {}); DevCPC486.IntDOp(x, y, plus, FALSE)
-					| exclfn:
-							expr(n.right, y, {}, wreg - {CX} + {high, mem, stk}); DevCPC486.MakeSet(y, FALSE, TRUE, ux, {});
-							DevCPC486.Assert(y, {}, ux); expr(n.left, x, {}, {});
-							DevCPC486.Load(y, {}, {}); DevCPC486.IntDOp(x, y, times, FALSE)
-					| getrfn:
-							expr(n.right, y, {}, {});
-							IF y.offset < 8 THEN	
-								DevCPL486.MakeReg(y, y.offset, n.left.typ.form);	(* ??? *)
-								expr(n.left, x, {}, {loaded}); DevCPC486.Assign(x, y)
-							ELSE DevCPM.err(220)
-							END
-					| putrfn:
-							expr(n.left, x, {}, {});
-							IF x.offset < 8 THEN
-								DevCPL486.MakeReg(x, x.offset, n.right.typ.form);	(* ??? *)
-								expr(n.right, y, wreg - {x.reg}, {}); DevCPC486.Assign(x, y)
-							ELSE DevCPM.err(220)
-							END
-					| newfn:
-							y.typ := n.left.typ;
-							IF n.right # NIL THEN
-								IF y.typ.BaseTyp.comp = Record THEN
-									expr(n.right, nofel, {}, {AX, CX, DX, mem, stk});
-									DevCPC486.New(y, nofel, 1);
-								ELSE (*open array*)
-									nofel.mode := Con; nofel.form := Int32; fact := 1;
-									Dim(n.right, y, nofel, fact, y.typ.BaseTyp)
-								END
-							ELSE
-								DevCPL486.MakeConst(nofel, 0, Int32);
-								DevCPC486.New(y, nofel, 1);
-							END;
-							DevCPC486.Assert(y, {}, ux); expr(n.left, x, {}, {loaded}); DevCPC486.Assign(x, y)
-					| sysnewfn:
-							expr(n.right, y, {}, {mem, short}); DevCPC486.SysNew(y);
-							DevCPC486.Assert(y, {}, ux); expr(n.left, x, {}, {}); DevCPC486.Assign(x, y)
-					| copyfn:
-							StringOp(n.left, n.right, x, y, TRUE);
-							DevCPC486.Copy(x, y, TRUE)
-					| movefn:
-							Check(n.right.link, uz, sz);
-							expr(n.right, y, {}, wreg - {SI} + {short} + ux + uz);
-							expr(n.left, x, {}, wreg - {DI} + {short} + uz);
-							expr(n.right.link, nofel, {}, wreg - {CX} + {mem, stk, short});
-							DevCPC486.Load(x, {}, wreg - {DI} + {con});
-							DevCPC486.Load(y, {}, wreg - {SI} + {con}); 
-							DevCPC486.SysMove(nofel)
-					END;
-					sequential := TRUE
-			| Ncall:
-					Checkpc;
-					Call(n, x); sequential := TRUE
-			| Nifelse:
-					IF (n.subcl # assertfn) OR assert THEN IfStat(n, FALSE, next) END
-			| Ncase:
-					Checkpc;
-					CaseStat(n, next)
-			| Nwhile:
-					local := DevCPL486.NewLbl;
-					IF n.right # NIL THEN DevCPC486.Jump(local) END;
-					loop := DevCPL486.NewLbl; DevCPL486.SetLabel(loop);
-					stat(n.right, local); DevCPL486.SetLabel(local);
-					DevCPM.errpos := n.conval.intval; Checkpc;
-					condition(n.left, x, next, loop); DevCPC486.JumpT(x, loop); sequential := TRUE
-			| Nrepeat:
-					loop := DevCPL486.NewLbl; DevCPL486.SetLabel(loop);
-					local := DevCPL486.NewLbl; stat(n.left, local); DevCPL486.SetLabel(local);
-					DevCPM.errpos := n.conval.intval; Checkpc;
-					condition(n.right, x, loop, next); DevCPC486.JumpF(x, loop); sequential := TRUE
-			| Nloop:
-					prevExit := Exit; Exit := next;
-					loop := DevCPL486.NewLbl; DevCPL486.SetLabel(loop); stat(n.left, loop);
-					IF sequential THEN DevCPC486.Jump(loop) END;
-					next := Exit; Exit := prevExit; sequential := FALSE
-			| Nexit:
-					Checkpc;
-					DevCPC486.Jump(Exit); sequential := FALSE
-			| Nreturn:
-					IF n.left # NIL THEN
-						Checkpc;
-						IF (n.obj.typ.sysflag = interface) & (n.obj.typ.form = Pointer)
-							& (n.left.class # Nconst) & ~CountedPtr(n.left) THEN IPAssign(NIL, n.left, y, x, {})
-						ELSE expr(n.left, x, wreg - {AX}, {})
-						END;
-						DevCPC486.Result(n.obj, x)
-					END;
-					IF (nesting > 1) OR (n.link # NIL) THEN DevCPC486.Jump(Return) END;
-					sequential := FALSE
-			| Nwith:
-					IfStat(n, n.subcl = 0, next)
-			| Ntrap:
-					Checkpc;
-					DevCPC486.Trap(n.right.conval.intval); sequential := TRUE
-			| Ncomp:
-					CompStat(n.left); stat(n.right, next); x.mode := 0; CompRelease(n.left, x)
-			| Ndrop:
-					Checkpc;
-					expr(n.left, x, {}, {}); DevCPC486.Free(x)
-			| Ngoto:
-					IF n.left # NIL THEN
-						Checkpc;
-						condition(n.left, x, next, n.right.conval.intval2);
-						DevCPC486.JumpT(x, n.right.conval.intval2)
-					ELSE
-						DevCPC486.Jump(n.right.conval.intval2);
-						sequential := FALSE
-					END
-			| Njsr:
-					DevCPL486.GenJump(-3, n.right.conval.intval2, FALSE)	(* call n.right *)
-			| Nret:
-					DevCPL486.GenReturn(0); sequential := FALSE	(* ret 0 *)
-			| Nlabel:
-					DevCPL486.SetLabel(n.conval.intval2)
-			END;
-			DevCPC486.CheckReg; DevCPL486.EndStat; n := n.link;
-			IF n = NIL THEN end := next
-			ELSIF next # DevCPL486.NewLbl THEN DevCPL486.SetLabel(next)
-			END
-		END;
-		DEC(nesting)
-	END stat;
-	
-	PROCEDURE CheckFpu (n: DevCPT.Node; VAR useFpu: BOOLEAN);
-	BEGIN
-		WHILE n # NIL DO
-			IF n.typ.form IN {Real32, Real64} THEN useFpu := TRUE END;
-			CASE n.class OF
-			| Ncase:
-				CheckFpu(n.left, useFpu); CheckFpu(n.right.left, useFpu); CheckFpu(n.right.right, useFpu)
-			| Ncasedo:
-				CheckFpu(n.right, useFpu)
-			| Ngoto, Ndrop, Nloop, Nreturn, Nmop, Nfield, Nderef, Nguard:
-				CheckFpu(n.left, useFpu)
-			| Nassign, Ncall, Nifelse, Nif, Nwhile, Nrepeat, Nwith, Ncomp, Ndop, Nupto, Nindex:
-				CheckFpu(n.left, useFpu); CheckFpu(n.right, useFpu)
-			| Njsr, Nret, Nlabel, Ntrap, Nexit, Ninittd, Ntype, Nproc, Nconst, Nvar, Nvarpar:
-			END;
-			n := n.link
-		END
-	END CheckFpu;
-	
-	PROCEDURE procs(n: DevCPT.Node);
-		VAR proc, obj: DevCPT.Object; i, j: INTEGER; end: DevCPL486.Label;
-			ch: SHORTCHAR; name: DevCPT.Name; useFpu: BOOLEAN;
-	BEGIN
-		INC(DevCPL486.level); nesting := 0;
-		WHILE (n # NIL) & DevCPM.noerr DO
-			DevCPC486.imLevel[DevCPL486.level] := DevCPC486.imLevel[DevCPL486.level - 1]; proc := n.obj; 
-			IF imVar IN proc.conval.setval THEN INC(DevCPC486.imLevel[DevCPL486.level]) END;
-			procs(n.left);
-			DevCPM.errpos := n.conval.intval;
-			useFpu := FALSE; CheckFpu(n.right, useFpu);
-			DevCPC486.Enter(proc, n.right = NIL, useFpu);
-			InitializeIPVars(proc);
-			end := DevCPL486.NewLbl; Return := DevCPL486.NewLbl; stat(n.right, end);
-			DevCPM.errpos := n.conval.intval2; Checkpc;
-			IF sequential OR (end # DevCPL486.NewLbl) THEN
-				DevCPL486.SetLabel(end);
-				IF (proc.typ # DevCPT.notyp) & (proc.sysflag # noframe) THEN DevCPC486.Trap(funcTrap) END
-			END;
-			DevCPL486.SetLabel(Return);
-			ReleaseIPVars(proc);
-			DevCPC486.Exit(proc, n.right = NIL);
-			IF proc.mode = TProc THEN
-				name := proc.link.typ.strobj.name^$; i := 0;
-				WHILE name[i] # 0X DO INC(i) END;
-				name[i] := "."; INC(i); j := 0; ch := proc.name[0];
-				WHILE (ch # 0X) & (i < LEN(name)-1) DO name[i] := ch; INC(i); INC(j); ch := proc.name[j] END ;
-				name[i] := 0X;
-			ELSE name := proc.name^$
-			END;
-			DevCPE.OutRefName(name); DevCPE.OutRefs(proc.scope.right);
-			n := n.link
-		END;
-		DEC(DevCPL486.level)
-	END procs;
-	
-	PROCEDURE Module*(prog: DevCPT.Node);
-		VAR end: DevCPL486.Label; name: DevCPT.Name; obj, p: DevCPT.Object; n: DevCPT.Node;
-			aAd, rAd: INTEGER; typ: DevCPT.Struct; useFpu: BOOLEAN;
-	BEGIN
-		DevCPH.UseReals(prog, {DevCPH.longDop, DevCPH.longMop});
-		DevCPM.NewObj(DevCPT.SelfName);
-		IF DevCPM.noerr THEN
-			DevCPE.OutHeader; n := prog.right;
-			WHILE (n # NIL) & (n.class = Ninittd) DO n := n.link END;
-			useFpu := FALSE; CheckFpu(n, useFpu);
-			DevCPC486.Enter(NIL, n = NIL, useFpu);
-			end := DevCPL486.NewLbl; stat(n, end); DevCPL486.SetLabel(end);
-			DevCPM.errpos := prog.conval.intval2; Checkpc;
-			DevCPC486.Exit(NIL, n = NIL);
-			IF prog.link # NIL THEN	(* close section *)
-				DevCPL486.SetLabel(DevCPE.closeLbl);
-				useFpu := FALSE; CheckFpu(prog.link, useFpu);
-				DevCPC486.Enter(NIL, FALSE, useFpu);
-				end := DevCPL486.NewLbl; stat(prog.link, end); DevCPL486.SetLabel(end);
-				DevCPM.errpos := SHORT(ENTIER(prog.conval.realval)); Checkpc;
-				DevCPC486.Exit(NIL, FALSE)
-			END;
-			name := "$$"; DevCPE.OutRefName(name); DevCPE.OutRefs(DevCPT.topScope.right);
-			DevCPM.errpos := prog.conval.intval;
-			WHILE query # NIL DO
-				typ := query.typ; query.typ := DevCPT.int32typ;
-				query.conval.intval := 20;	(* parameters *)
-				query.conval.intval2 := -8;	(* saved registers *)
-				DevCPC486.Enter(query, FALSE, FALSE);
-				InstallQueryInterface(typ, query);
-				DevCPC486.Exit(query, FALSE);
-				name := "QueryInterface"; DevCPE.OutRefName(name);
-				query := query.nlink
-			END;
-			procs(prog.left);
-			DevCPC486.InstallStackAlloc;
-			addRef := NIL; release := NIL; release2 := NIL;
-			DevCPC486.intHandler := NIL;
-			IF DevCPM.noerr THEN DevCPE.OutCode END;
-			IF ~DevCPM.noerr THEN DevCPM.DeleteObj END
-		END
-	END Module;
-
-END DevCPV486.

BlackBox/Dev/Mod/Commanders.txt

@@ -1,361 +0,0 @@
-MODULE DevCommanders;
-
-	(* THIS IS TEXT COPY OF BlackBox 1.6-rc6 Dev/Mod/Commanders.odc *)
-	(* DO NOT EDIT *)
-
-	IMPORT
-		Kernel, Fonts, Ports, Stores, Models, Views, Controllers, Properties, Dialog, Controls,
-		TextModels, TextSetters, TextMappers, Services, StdLog;
-
-	CONST
-		(* additional Scan types *)
-		ident = 19; qualident = 20; execMark = 21;
-
-		point = Ports.point;
-
-		minVersion = 0; maxVersion = 0; maxStdVersion = 0;
-
-
-	TYPE
-		View* = POINTER TO ABSTRACT RECORD (Views.View)
-		END;
-		EndView* = POINTER TO ABSTRACT RECORD (Views.View)
-		END;
-
-		Par* = POINTER TO RECORD
-			text*: TextModels.Model;
-			beg*, end*: INTEGER
-		END;
-
-		Directory* = POINTER TO ABSTRACT RECORD END;
-
-
-		StdView = POINTER TO RECORD (View) END;
-		StdEndView = POINTER TO RECORD (EndView) END;
-
-		StdDirectory = POINTER TO RECORD (Directory) END;
-
-		Scanner = RECORD
-			s: TextMappers.Scanner;
-			ident: ARRAY LEN(Kernel.Name) OF CHAR;
-			qualident: ARRAY LEN(Kernel.Name) * 2 - 1 OF CHAR
-		END;
-		
-		TrapCleaner = POINTER TO RECORD (Kernel.TrapCleaner) END;
-
-	VAR
-		par*: Par;
-		dir-, stdDir-: Directory;
-		
-		cleaner: TrapCleaner;
-		cleanerInstalled: BOOLEAN;
-
-
-	(** Cleaner **)
-
-	PROCEDURE (c: TrapCleaner) Cleanup;
-	BEGIN
-		par := NIL;
-		cleanerInstalled := FALSE;
-	END Cleanup;
-	
-	(** View **)
-
-	PROCEDURE (v: View) Externalize- (VAR wr: Stores.Writer), EXTENSIBLE;
-	BEGIN
-		v.Externalize^(wr);
-		wr.WriteVersion(maxVersion);
-		wr.WriteXInt(execMark)
-	END Externalize;
-
-	PROCEDURE (v: View) Internalize- (VAR rd: Stores.Reader), EXTENSIBLE;
-		VAR thisVersion, type: INTEGER;
-	BEGIN
-		v.Internalize^(rd);
-		IF rd.cancelled THEN RETURN END;
-		rd.ReadVersion(minVersion, maxVersion, thisVersion);
-		IF rd.cancelled THEN RETURN END;
-		rd.ReadXInt(type)
-	END Internalize;
-
-
-	(** Directory **)
-
-	PROCEDURE (d: Directory) New* (): View, NEW, ABSTRACT;
-	PROCEDURE (d: Directory) NewEnd* (): EndView, NEW, ABSTRACT;
-
-
-	(* auxilliary procedures *)
-
-	PROCEDURE IsIdent (VAR s: ARRAY OF CHAR): BOOLEAN;
-		VAR i: INTEGER; ch: CHAR;
-	BEGIN
-		ch := s[0]; i := 1;
-		IF ("A" <= CAP(ch)) & (CAP(ch) <= "Z") OR (ch >= 0C0X) & (ch # "×") & (ch # "÷") & (ch <= 0FFX) OR (ch = "_") THEN
-			REPEAT
-				ch := s[i]; INC(i)
-			UNTIL ~( ("0" <= ch) & (ch <= "9") OR ("A" <= CAP(ch)) & (CAP(ch) <= "Z")
-						OR (ch >= 0C0X) & (ch # "×") & (ch # "÷") & (ch <= 0FFX) OR (ch = "_") );
-			RETURN (ch = 0X) & (i <= LEN(Kernel.Name))
-		ELSE
-			RETURN FALSE
-		END
-	END IsIdent;
-
-	PROCEDURE Scan (VAR s: Scanner);
-		VAR done: BOOLEAN;
-	BEGIN
-		s.s.Scan;
-		IF (s.s.type = TextMappers.view) THEN
-			IF Properties.ThisType(s.s.view, "DevCommanders.View") # NIL THEN s.s.type := execMark END
-		ELSIF (s.s.type = TextMappers.string) & TextMappers.IsQualIdent(s.s.string) THEN
-			s.s.type := qualident; s.qualident := s.s.string$
-		ELSIF (s.s.type = TextMappers.string) & IsIdent(s.s.string) THEN
-			s.ident := s.s.string$;
-			TextMappers.ScanQualIdent(s.s, s.qualident, done);
-			IF done THEN s.s.type := qualident ELSE s.s.type := ident END
-		END
-	END Scan;
-
-	PROCEDURE GetParExtend (r: TextModels.Reader; VAR end: INTEGER);
-		VAR v, v1: Views.View;
-	BEGIN
-		REPEAT r.ReadView(v); 
-			IF v # NIL THEN 
-				v1 := v;
-				v := Properties.ThisType(v1, "DevCommanders.View") ;
-				IF v = NIL THEN v := Properties.ThisType(v1, "DevCommanders.EndView")  END
-			END
-		UNTIL r.eot OR (v # NIL);
-		end := r.Pos(); IF ~r.eot THEN DEC(end) END
-	END GetParExtend;
-
-	PROCEDURE Unload (cmd: Dialog.String);
-		VAR modname: Kernel.Name; str: Dialog.String; i: INTEGER; ch: CHAR; mod: Kernel.Module;
-	BEGIN
-		i := 0; ch := cmd[0];
-		WHILE (ch # 0X) & (ch # ".") DO modname[i] := SHORT(ch); INC(i); ch := cmd[i] END;
-		modname[i] := 0X;
-		mod := Kernel.ThisLoadedMod(modname);
-		IF mod # NIL THEN
-			Kernel.UnloadMod(mod);
-			IF mod.refcnt < 0 THEN
-				str := modname$;
-				Dialog.MapParamString("#Dev:Unloaded", str, "", "", str);
-				StdLog.String(str); StdLog.Ln;
-				Controls.Relink
-			ELSE
-				str := modname$;
-				Dialog.ShowParamMsg("#Dev:UnloadingFailed", str, "", "")
-			END
-		END
-	END Unload;
-
-	PROCEDURE Execute (t: TextModels.Model; pos: INTEGER; VAR end: INTEGER; unload: BOOLEAN);
-		VAR s: Scanner; beg, res: INTEGER; cmd: Dialog.String;
-	BEGIN
-		end := t.Length();
-		s.s.ConnectTo(t); s.s.SetPos(pos); s.s.SetOpts({TextMappers.returnViews});
-		Scan(s); ASSERT(s.s.type = execMark, 100);
-		Scan(s);
-		IF s.s.type IN {qualident, TextMappers.string} THEN
-			beg := s.s.Pos() - 1; GetParExtend(s.s.rider, end);
-			ASSERT(~cleanerInstalled, 101);
-			Kernel.PushTrapCleaner(cleaner); cleanerInstalled := TRUE;
-			NEW(par); par.text := t; par.beg := beg; par.end := end;
-			IF s.s.type = qualident THEN cmd := s.qualident$ ELSE cmd := s.s.string$ END;
-			IF unload (* & (s.s.type = qualident)*) THEN Unload(cmd) END;
-			Dialog.Call(cmd, " ",  res);
-			par := NIL;
-			Kernel.PopTrapCleaner(cleaner); cleanerInstalled := FALSE;
-		END
-	END Execute;
-
-	PROCEDURE Track (v: View; f: Views.Frame; x, y: INTEGER; buttons: SET);
-		VAR c: Models.Context; w, h, end: INTEGER; isDown, in, in0: BOOLEAN; m: SET;
-	BEGIN
-		c := v.context; c.GetSize(w, h); in0 := FALSE; in := TRUE;
-		REPEAT
-			IF in # in0 THEN
-				f.MarkRect(0, 0, w, h, Ports.fill, Ports.invert, Ports.show); in0 := in
-			END;
-			f.Input(x, y, m, isDown);
-			in := (0 <= x) & (x < w) & (0 <= y) & (y < h)
-		UNTIL ~isDown;
-		IF in0 THEN
-			f.MarkRect(0, 0, w, h, Ports.fill, Ports.invert, Ports.hide);
-			WITH c:TextModels.Context DO
-				Execute(c.ThisModel(), c.Pos(), end,Controllers.modify IN buttons)
-			ELSE Dialog.Beep
-			END
-		END
-	END Track;
-
-	(* StdView *)
-
-	PROCEDURE (v: StdView) Externalize (VAR wr: Stores.Writer);
-	BEGIN
-		v.Externalize^(wr);
-		wr.WriteVersion(maxStdVersion)
-	END Externalize;
-
-	PROCEDURE (v: StdView) Internalize (VAR rd: Stores.Reader);
-		VAR thisVersion: INTEGER;
-	BEGIN
-		v.Internalize^(rd);
-		IF rd.cancelled THEN RETURN END;
-		rd.ReadVersion(minVersion, maxStdVersion, thisVersion)
-	END Internalize;
-
-	PROCEDURE (v: StdView) Restore (f: Views.Frame; l, t, r, b: INTEGER);
-		CONST u = point;
-		VAR c: Models.Context; a: TextModels.Attributes; font: Fonts.Font; color: Ports.Color;
-			size, d, w, asc, dsc, fw: INTEGER; s: ARRAY 2 OF CHAR;
-	BEGIN
-		ASSERT(v.context # NIL, 20);
-		c := v.context;
-		WITH c: TextModels.Context DO a := c.Attr(); font := a.font; color := a.color
-		ELSE font := Fonts.dir.Default(); color := Ports.defaultColor
-		END;
-		font.GetBounds(asc, dsc, fw);
-		size := asc + dsc; d := size DIV 2;
-		f.DrawOval(u, 0, u + size, size, Ports.fill, color);
-		s := "!";
-		w := font.StringWidth(s);
-		f.DrawString(u + d - w DIV 2, size - dsc, Ports.background, s, font)
-	END Restore;
-
-	PROCEDURE (v: StdView) HandleCtrlMsg (f: Views.Frame; VAR msg: Controllers.Message;
-																		VAR focus: Views.View);
-	BEGIN
-		WITH msg: Controllers.TrackMsg DO
-			Track(v, f, msg.x, msg.y, msg.modifiers)
-		| msg: Controllers.PollCursorMsg DO
-			msg.cursor := Ports.refCursor
-		ELSE
-		END
-	END HandleCtrlMsg;
-
-	PROCEDURE (v: StdView) HandlePropMsg (VAR msg: Properties.Message);
-		VAR c: Models.Context; a: TextModels.Attributes; font: Fonts.Font; asc, dsc, fw: INTEGER;
-	BEGIN
-		WITH msg: Properties.Preference DO
-			WITH msg: Properties.SizePref DO
-				c := v.context;
-				IF (c # NIL) & (c IS TextModels.Context) THEN
-					a := c(TextModels.Context).Attr(); font := a.font
-				ELSE font := Fonts.dir.Default()
-				END;
-				font.GetBounds(asc, dsc, fw);
-				msg.h := asc + dsc; msg.w := msg.h + 2 * point
-			| msg: Properties.ResizePref DO
-				msg.fixed := TRUE
-			| msg: Properties.FocusPref DO
-				msg.hotFocus := TRUE
-			| msg: TextSetters.Pref DO
-				c := v.context;
-				IF (c # NIL) & (c IS TextModels.Context) THEN
-					a := c(TextModels.Context).Attr(); font := a.font
-				ELSE font := Fonts.dir.Default()
-				END;
-				font.GetBounds(asc, msg.dsc, fw)
-			| msg: Properties.TypePref DO
-				IF Services.Is(v, msg.type) THEN msg.view := v END
-			ELSE
-			END
-		ELSE
-		END
-	END HandlePropMsg;
-	
-	
-	(* StdEndView *)
-
-	PROCEDURE (v: StdEndView) Restore (f: Views.Frame; l, t, r, b: INTEGER);
-		CONST u = point;
-		VAR c: Models.Context; a: TextModels.Attributes; font: Fonts.Font; color: Ports.Color;
-			size, w, asc, dsc, fw: INTEGER; s: ARRAY 2 OF CHAR;
-			points: ARRAY 3 OF Ports.Point;
-	BEGIN
-		ASSERT(v.context # NIL, 20);
-		c := v.context;
-		WITH c: TextModels.Context DO a := c.Attr(); font := a.font; color := a.color
-		ELSE font := Fonts.dir.Default(); color := Ports.defaultColor
-		END;
-		font.GetBounds(asc, dsc, fw);
-		size := asc + dsc;
-		points[0].x := 0; points[0].y := size;
-		points[1].x := u + (size DIV 2); points[1].y := size DIV 2;
-		points[2].x := u + (size DIV 2); points[2].y := size;     
-		f.DrawPath(points, 3, Ports.fill, color, Ports.closedPoly)
-	END Restore;
-	
-	PROCEDURE (v: StdEndView) HandlePropMsg (VAR msg: Properties.Message);
-		VAR c: Models.Context; a: TextModels.Attributes; font: Fonts.Font; asc, dsc, fw: INTEGER;
-	BEGIN
-		WITH msg: Properties.Preference DO
-			WITH msg: Properties.SizePref DO
-				c := v.context;
-				IF (c # NIL) & (c IS TextModels.Context) THEN
-					a := c(TextModels.Context).Attr(); font := a.font
-				ELSE font := Fonts.dir.Default()
-				END;
-				font.GetBounds(asc, dsc, fw);
-				msg.h := asc + dsc; msg.w := (msg.h + 2 * point) DIV 2
-			| msg: Properties.ResizePref DO
-				msg.fixed := TRUE
-			| msg: Properties.FocusPref DO
-				msg.hotFocus := TRUE
-			| msg: TextSetters.Pref DO
-				c := v.context;
-				IF (c # NIL) & (c IS TextModels.Context) THEN
-					a := c(TextModels.Context).Attr(); font := a.font
-				ELSE font := Fonts.dir.Default()
-				END;
-				font.GetBounds(asc, msg.dsc, fw)
-			| msg: Properties.TypePref DO
-				IF Services.Is(v, msg.type) THEN msg.view := v END
-			ELSE
-			END
-		ELSE
-		END
-	END HandlePropMsg;
-
-	(* StdDirectory *)
-
-	PROCEDURE (d: StdDirectory) New (): View;
-		VAR v: StdView;
-	BEGIN
-		NEW(v); RETURN v
-	END New;
-	
-	PROCEDURE (d: StdDirectory) NewEnd (): EndView;
-		VAR v: StdEndView;
-	BEGIN
-		NEW(v); RETURN v
-	END NewEnd;
-
-	PROCEDURE Deposit*;
-	BEGIN
-		Views.Deposit(dir.New())
-	END Deposit;
-
-	PROCEDURE DepositEnd*;
-	BEGIN
-		Views.Deposit(dir.NewEnd())
-	END DepositEnd;
-
-	PROCEDURE SetDir* (d: Directory);
-	BEGIN
-		dir := d
-	END SetDir;
-
-	PROCEDURE Init;
-		VAR d: StdDirectory;
-	BEGIN
-		NEW(d); dir := d; stdDir := d;
-		NEW(cleaner); cleanerInstalled := FALSE;
-	END Init;
-
-BEGIN
-	Init
-END DevCommanders.

BlackBox/Dev/Mod/Compiler.txt

@@ -1,348 +0,0 @@
-MODULE DevCompiler;
-
-	(* THIS IS TEXT COPY OF BlackBox 1.6-rc6 Dev/Mod/Compiler.odc *)
-	(* DO NOT EDIT *)
-
-	IMPORT Kernel,
-		Files, Views, Dialog, Controls,
-		TextModels, TextMappers, TextViews, TextControllers,
-		StdLog, StdDialog,
-		DevMarkers, DevCommanders, DevSelectors,
-		DevCPM, DevCPT, DevCPB, DevCPP, DevCPE, DevCPV := DevCPV486;
-
-	CONST
-		(* compiler options: *)
-		checks = 0; allchecks = 1; assert = 2; obj = 3; ref = 4; allref = 5; srcpos = 6; reallib = 7; signatures = 8;
-		hint = 29; oberon = 30; errorTrap = 31;
-		defopt = {checks, assert, obj, ref, allref, srcpos, signatures};
-
-		(* additional scanner types *)
-		import = 100; module = 101; semicolon = 102; becomes = 103; comEnd = 104;
-
-	VAR
-		sourceR: TextModels.Reader;
-		s: TextMappers.Scanner;
-		str: Dialog.String;
-		found: BOOLEAN;	(* DevComDebug was found -> DTC *)
-
-	PROCEDURE Module (source: TextModels.Reader; opt: SET; log: TextModels.Model; VAR error: BOOLEAN);
-		VAR ext, new: BOOLEAN; p: DevCPT.Node;
-	BEGIN
-		DevCPM.Init(source, log);
-		IF found THEN INCL(DevCPM.options, DevCPM.comAware) END;
-		IF errorTrap IN opt THEN INCL(DevCPM.options, DevCPM.trap) END;
-		IF oberon IN opt THEN INCL(DevCPM.options, DevCPM.oberon) END;
-		DevCPT.Init(opt);
-		DevCPB.typSize := DevCPV.TypeSize;
-		DevCPT.processor := DevCPV.processor;
-		DevCPP.Module(p);
-		IF DevCPM.noerr THEN
-			IF DevCPT.libName # "" THEN EXCL(opt, obj) END;
-(*
-			IF errorTrap IN opt THEN DevCPDump.DumpTree(p) END;
-*)
-			DevCPV.Init(opt); DevCPV.Allocate; DevCPT.Export(ext, new);
-			IF DevCPM.noerr & (obj IN opt) THEN
-				DevCPV.Module(p)
-			END;
-			DevCPV.Close
-		END;
-		IF DevCPM.noerr & (new OR ext) THEN DevCPM.RegisterNewSym
-		ELSE DevCPM.DeleteNewSym
-		END;
-		DevCPT.Close;
-		error := ~DevCPM.noerr;
-		DevCPM.Close;
-		p := NIL;
-		Kernel.FastCollect;
-		IF error THEN
-			DevCPM.InsertMarks(source.Base());
-			DevCPM.LogWLn; DevCPM.LogWStr(" ");
-			IF DevCPM.errors = 1 THEN
-				Dialog.MapString("#Dev:OneErrorDetected", str)
-			ELSE
-				DevCPM.LogWNum(DevCPM.errors, 0); Dialog.MapString("#Dev:ErrorsDetected", str)
-			END;
-			StdLog.String(str)
-		ELSE
-			IF hint IN opt THEN DevCPM.InsertMarks(source.Base()) END;
-			DevCPM.LogWStr("  "); DevCPM.LogWNum(DevCPE.pc, 8);
-			DevCPM.LogWStr("  "); DevCPM.LogWNum(DevCPE.dsize, 8)
-		END;
-		DevCPM.LogWLn
-	END Module;
-
-	PROCEDURE Scan (VAR s: TextMappers.Scanner);
-	BEGIN
-		s.Scan;
-		IF s.type = TextMappers.string THEN
-			IF s.string = "MODULE" THEN s.type := module END
-		ELSIF s.type = TextMappers.char THEN
-			IF s.char = "(" THEN
-				IF s.rider.char = "*" THEN
-					s.rider.Read;
-					REPEAT Scan(s) UNTIL (s.type = TextMappers.eot) OR (s.type = comEnd);
-					Scan(s)
-				END
-			ELSIF s.char = "*" THEN
-				IF s.rider.char = ")" THEN s.rider.Read; s.type := comEnd END
-			END
-		END
-	END Scan;
-
-	PROCEDURE Do (source, log: TextModels.Model; beg: INTEGER; opt: SET; VAR error: BOOLEAN);
-		VAR s: TextMappers.Scanner;
-	BEGIN
-		Dialog.MapString("#Dev:Compiling", str);
-		StdLog.String(str); StdLog.Char(" ");
-		s.ConnectTo(source); s.SetPos(beg);
-		Scan(s);
-		WHILE (s.type # TextMappers.eot) & (s.type # module) DO Scan(s) END;
-		IF s.type = module THEN
-			Scan(s);
-			IF s.type = TextMappers.string THEN
-				StdLog.Char('"'); StdLog.String(s.string); StdLog.Char('"')
-			END
-		END;
-		sourceR := source.NewReader(NIL); sourceR.SetPos(beg);
-		Module(sourceR, opt, log, error)
-	END Do;
-
-
-	PROCEDURE Open;
-	BEGIN
-		Dialog.ShowStatus("#Dev:Compiling");
-		StdLog.buf.Delete(0, StdLog.buf.Length())
-	END Open;
-
-	PROCEDURE Close;
-	BEGIN
-		StdLog.text.Append(StdLog.buf);
-		IF DevCPM.noerr THEN Dialog.ShowStatus("#Dev:Ok")
-		END;
-		sourceR := NIL;
-		Kernel.Cleanup
-	END Close;
-
-	PROCEDURE Compile*;
-		VAR t: TextModels.Model; error: BOOLEAN;
-	BEGIN
-		Open;
-		t := TextViews.FocusText();
-		IF t # NIL THEN
-			Do(t, StdLog.text, 0, defopt, error);
-			IF error THEN DevMarkers.ShowFirstError(t, TextViews.focusOnly) END
-		ELSE Dialog.ShowMsg("#Dev:NoTextViewFound")
-		END;
-		Close
-	END Compile;
-
-	PROCEDURE CompileOpt* (opt: ARRAY OF CHAR);
-		VAR t: TextModels.Model; error: BOOLEAN; i: INTEGER; opts: SET;
-	BEGIN
-		i := 0; opts := defopt;
-		WHILE opt[i] # 0X DO
-			IF opt[i] = "-" THEN
-				IF srcpos IN opts THEN EXCL(opts, srcpos)
-				ELSIF allref IN opts THEN EXCL(opts, allref)
-				ELSIF ref IN opts THEN EXCL(opts, ref)
-				ELSE EXCL(opts, obj)
-				END
-			ELSIF opt[i] = "!" THEN
-				IF assert IN opts THEN EXCL(opts, assert)
-				ELSE EXCL(opts, checks)
-				END
-			ELSIF opt[i] = "+" THEN INCL(opts, allchecks)
-			ELSIF opt[i] = "?" THEN INCL(opts, hint)
-			ELSIF opt[i] = "@" THEN INCL(opts, errorTrap)
-			ELSIF opt[i] = "$" THEN INCL(opts, oberon)
-			END;
-			INC(i)
-		END;
-		Open;
-		t := TextViews.FocusText();
-		IF t # NIL THEN
-			Do(t, StdLog.text, 0, opts, error);
-			IF error THEN DevMarkers.ShowFirstError(t, TextViews.focusOnly) END
-		ELSE Dialog.ShowMsg("#Dev:NoTextViewFound")
-		END;
-		Close
-	END CompileOpt;
-
-	PROCEDURE CompileText* (text: TextModels.Model; beg: INTEGER; OUT error: BOOLEAN);
-	BEGIN
-		ASSERT(text # NIL, 20); ASSERT((beg >= 0) & (beg < text.Length()), 21);
-		Open;
-		Do(text, StdLog.text, beg, defopt, error);
-		IF error THEN DevMarkers.ShowFirstError(text, TextViews.focusOnly) END;
-		Close
-	END CompileText;
-
-	PROCEDURE CompileAndUnload*;
-		VAR t: TextModels.Model; error: BOOLEAN; mod: Kernel.Module; n: ARRAY 256 OF CHAR;
-	BEGIN
-		Open;
-		t := TextViews.FocusText();
-		IF t # NIL THEN
-			Do(t, StdLog.text, 0, defopt, error);
-			IF error THEN DevMarkers.ShowFirstError(t, TextViews.focusOnly)
-			ELSE
-				mod := Kernel.ThisLoadedMod(DevCPT.SelfName);
-				IF mod # NIL THEN
-					Kernel.UnloadMod(mod);
-					n := DevCPT.SelfName$;
-					IF mod.refcnt < 0 THEN
-						Dialog.MapParamString("#Dev:Unloaded", n, "", "", str);
-						StdLog.String(str); StdLog.Ln;
-						Controls.Relink
-					ELSE
-						Dialog.MapParamString("#Dev:UnloadingFailed", n, "", "", str);
-						StdLog.String(str); StdLog.Ln
-					END
-				END
-			END
-		ELSE Dialog.ShowMsg("#Dev:NoTextViewFound")
-		END;
-		Close
-	END CompileAndUnload;
-
-	PROCEDURE CompileSelection*;
-		VAR c: TextControllers.Controller; t: TextModels.Model; beg, end: INTEGER; error: BOOLEAN;
-	BEGIN
-		Open;
-		c := TextControllers.Focus();
-		IF c # NIL THEN
-			t := c.text;
-			IF c.HasSelection() THEN
-				c.GetSelection(beg, end); Do(t, StdLog.text, beg, defopt, error);
-				IF error THEN DevMarkers.ShowFirstError(t, TextViews.focusOnly) END
-			ELSE Dialog.ShowMsg("#Dev:NoSelectionFound")
-			END
-		ELSE Dialog.ShowMsg("#Dev:NoTextViewFound")
-		END;
-		Close
-	END CompileSelection;
-
-	PROCEDURE CompileList (beg, end: INTEGER; c: TextControllers.Controller);
-		VAR v: Views.View; i: INTEGER; error, one: BOOLEAN; name: Files.Name; loc: Files.Locator;
-			t: TextModels.Model; opts: SET; title, entry: ARRAY 64 OF CHAR;
-	BEGIN
-		s.SetPos(beg); s.Scan; one := FALSE;
-		WHILE (s.start < end) & (s.type = TextMappers.string) & (s.len < LEN(name)) DO
-			s.Scan; one := TRUE;
-			WHILE (s.start < end) & (s.type = TextMappers.char) &
-				((s.char = "-") OR (s.char = "+") OR
-				(s.char = "!") OR (s.char = "*") OR (s.char = "?") OR (s.char = "^") OR (s.char = "("))
-			DO
-				IF s.char = "(" THEN
-					WHILE (s.start < end) & ((s.type # TextMappers.char) OR (s.char # ")")) DO s.Scan END
-				END;
-				s.Scan
-			END
-		END;
-		IF one & (s.start >= end) THEN
-			s.SetPos(beg); s.Scan; error := FALSE;
-			WHILE (s.start < end) & (s.type = TextMappers.string) & ~error DO
-				i := 0; WHILE i < LEN(name) DO name[i] := 0X; INC(i) END;
-				StdDialog.GetSubLoc(s.string, "Mod", loc, name);
-				t := NIL;
-				IF loc # NIL THEN
-					v := Views.OldView(loc, name);
-					IF v # NIL THEN
-						WITH v: TextViews.View DO t := v.ThisModel()
-						ELSE Dialog.ShowParamMsg("#Dev:NoTextFileFound", name, "", ""); error := TRUE
-						END
-					ELSE Dialog.ShowParamMsg("#Dev:CannotOpenFile", name, "", ""); error := TRUE
-					END
-				ELSE Dialog.ShowParamMsg("#System:FileNotFound", name, "", ""); error := TRUE
-				END;
-				s.Scan; opts := defopt;
-				WHILE (s.start < end) & (s.type = TextMappers.char) DO
-					IF s.char = "-" THEN
-						IF srcpos IN opts THEN EXCL(opts, srcpos)
-						ELSIF allref IN opts THEN EXCL(opts, allref)
-						ELSIF ref IN opts THEN EXCL(opts, ref)
-						ELSE EXCL(opts, obj)
-						END
-					ELSIF s.char = "!" THEN
-						IF assert IN opts THEN EXCL(opts, assert)
-						ELSE EXCL(opts, checks)
-						END
-					ELSIF s.char = "+" THEN INCL(opts, allchecks)
-					ELSIF s.char = "?" THEN INCL(opts, hint)
-					ELSIF s.char = "@" THEN INCL(opts, errorTrap)
-					ELSIF s.char = "$" THEN INCL(opts, oberon)
-					ELSIF s.char = "(" THEN
-						s.Scan;
-						WHILE (s.start < end) & (s.type = TextMappers.string) DO
-							title := s.string$; s.Scan;
-							IF (s.start < end) & (s.type = TextMappers.char) & (s.char = ":") THEN
-								s.Scan;
-								IF (s.start < end) & (s.type = TextMappers.string) THEN
-									entry := s.string$; s.Scan;
-									IF t # NIL THEN DevSelectors.ChangeTo(t, title, entry) END
-								END
-							END;
-							IF (s.start < end) & (s.type = TextMappers.char) & (s.char = ",") THEN s.Scan END
-						END
-					END;
-					s.Scan
-				END;
-				IF t # NIL THEN
-					Do(t, StdLog.text, 0, opts, error)
-				END
-			END
-		ELSE Dialog.ShowMsg("#Dev:NotOnlyFileNames")
-		END;
-		s.ConnectTo(NIL);
-		IF error & (c # NIL) & c.HasSelection() & (s.start < end) THEN
-			c.SetSelection(s.start, end)
-		END;
-		IF error & (v # NIL) THEN
-			Views.Open(v, loc, name, NIL);
-			DevMarkers.ShowFirstError(t, TextViews.any)
-		END
-	END CompileList;
-
-	PROCEDURE CompileModuleList*;
-		VAR c: TextControllers.Controller; beg, end: INTEGER;
-	BEGIN
-		Open;
-		c := TextControllers.Focus();
-		IF c # NIL THEN
-			s.ConnectTo(c.text);
-			IF c.HasSelection() THEN c.GetSelection(beg, end)
-			ELSE beg := 0; end := c.text.Length()
-			END;
-			CompileList(beg, end, c)
-		ELSE Dialog.ShowMsg("#Dev:NoTextViewFound")
-		END;
-		Close
-	END CompileModuleList;
-
-	PROCEDURE CompileThis*;
-		VAR p: DevCommanders.Par; beg, end: INTEGER;
-	BEGIN
-		Open;
-		p := DevCommanders.par;
-		IF p # NIL THEN
-			DevCommanders.par := NIL;
-			s.ConnectTo(p.text); beg := p.beg; end := p.end;
-			CompileList(beg, end, NIL)
-		ELSE Dialog.ShowMsg("#Dev:NoTextViewFound")
-		END;
-		Close
-	END CompileThis;
-
-	PROCEDURE Init;
-		VAR loc: Files.Locator; f: Files.File;
-	BEGIN
-		loc := Files.dir.This("Dev"); loc := loc.This("Code");
-		f := Files.dir.Old(loc, "ComDebug.ocf", TRUE);
-		found := f # NIL;
-		IF f # NIL THEN f.Close END
-	END Init;
-
-BEGIN
-	Init
-END DevCompiler.

BlackBox/Dev/Mod/Markers.txt

@@ -1,442 +0,0 @@
-MODULE DevMarkers;
-
-	(* THIS IS TEXT COPY OF BlackBox 1.6-rc6 Dev/Mod/Markers.odc *)
-	(* DO NOT EDIT *)
-
-	IMPORT
-		Kernel, Files, Stores, Fonts, Ports, Models, Views, Controllers, Properties, Dialog,
-		TextModels, TextSetters, TextViews, TextControllers, TextMappers;
-
-	CONST
-		(** View.mode **)
-		undefined* = 0; mark* = 1; message* = 2; 
-		firstMode = 1; lastMode = 2;
-
-		(** View.err **)
-		noCode* = 9999;
-
-		errFile = "Errors"; point = Ports.point;
-
-	TYPE
-		View* = POINTER TO ABSTRACT RECORD (Views.View)
-			mode-: INTEGER;
-			err-: INTEGER;
-			msg-: POINTER TO ARRAY OF CHAR;
-			era: INTEGER
-		END;
-
-		Directory* = POINTER TO ABSTRACT RECORD END;
-
-
-		StdView = POINTER TO RECORD (View) END;
-
-		StdDirectory = POINTER TO RECORD (Directory) END;
-
-		SetModeOp = POINTER TO RECORD (Stores.Operation)
-			view: View;
-			mode: INTEGER
-		END;
-		
-
-	VAR
-		dir-, stdDir-: Directory;
-
-		globR: TextModels.Reader; globW: TextModels.Writer;	(* recycling done in Load, Insert *)
-		
-		thisEra: INTEGER;
-
-
-	(** View **)
-
-	PROCEDURE (v: View) CopyFromSimpleView- (source: Views.View), EXTENSIBLE;
-	BEGIN
-		(* v.CopyFrom^(source); *)
-		WITH source: View DO
-			v.err := source.err; v.mode := source.mode;
-			IF source.msg # NIL THEN
-				NEW(v.msg, LEN(source.msg^)); v.msg^ := source.msg^$
-			END
-		END
-	END CopyFromSimpleView;
-
-(*
-	PROCEDURE (v: View) InitContext* (context: Models.Context), EXTENSIBLE;
-	BEGIN
-		ASSERT(v.mode # undefined, 20);
-		v.InitContext^(context)
-	END InitContext;
-*)
-
-	PROCEDURE (v: View) InitErr* (err: INTEGER), NEW, EXTENSIBLE;
-	BEGIN
-		ASSERT(v.msg = NIL, 20);
-		IF v.err # err THEN v.err := err; v.mode := mark END;
-		IF v.mode = undefined THEN v.mode := mark END
-	END InitErr;
-
-	PROCEDURE (v: View) InitMsg* (msg: ARRAY OF CHAR), NEW, EXTENSIBLE;
-		VAR i: INTEGER; str: ARRAY 1024 OF CHAR;
-	BEGIN
-		ASSERT(v.msg = NIL, 20);
-		Dialog.MapString(msg, str);
-		i := 0; WHILE str[i] # 0X DO INC(i) END;
-		NEW(v.msg, i + 1); v.msg^ := str$;
-		v.mode := mark
-	END InitMsg;
-
-	PROCEDURE (v: View) SetMode* (mode: INTEGER), NEW, EXTENSIBLE;
-		VAR op: SetModeOp;
-	BEGIN
-		ASSERT((firstMode <= mode) & (mode <= lastMode), 20);
-		IF v.mode # mode THEN
-			NEW(op); op.view := v; op.mode := mode;
-			Views.Do(v, "#System:ViewSetting", op)
-		END
-	END SetMode;
-
-
-	(** Directory **)
-
-	PROCEDURE (d: Directory) New* (type: INTEGER): View, NEW, ABSTRACT;
-	PROCEDURE (d: Directory) NewMsg* (msg: ARRAY OF CHAR): View, NEW, ABSTRACT;
-
-
-	(* SetModeOp *)
-
-	PROCEDURE (op: SetModeOp) Do;
-		VAR v: View; mode: INTEGER;
-	BEGIN
-		v := op.view;
-		mode := v.mode; v.mode := op.mode; op.mode := mode;
-		Views.Update(v, Views.keepFrames);
-		IF v.context # NIL THEN v.context.SetSize(Views.undefined, Views.undefined) END
-	END Do;
-
-	PROCEDURE ToggleMode (v: View);
-		VAR mode: INTEGER;
-	BEGIN
-		IF ABS(v.err) # noCode THEN
-			IF v.mode < lastMode THEN mode := v.mode + 1 ELSE mode := firstMode END
-		ELSE
-			IF v.mode < message THEN mode := v.mode + 1 ELSE mode := firstMode END
-		END;
-		v.SetMode(mode)
-	END ToggleMode;
-
-
-	(* primitives for StdView *)
-
-	PROCEDURE NumToStr (x: INTEGER; VAR s: ARRAY OF CHAR; VAR i: INTEGER);
-		VAR j: INTEGER; m: ARRAY 32 OF CHAR;
-	BEGIN
-		ASSERT(x >= 0, 20);
-		j := 0; REPEAT m[j] := CHR(x MOD 10 + ORD("0")); x := x DIV 10; INC(j) UNTIL x = 0;
-		i := 0; REPEAT DEC(j); s[i] := m[j]; INC(i) UNTIL j = 0;
-		s[i] := 0X
-	END NumToStr;
-
-	PROCEDURE Load (v: StdView);
-		VAR view: Views.View; t: TextModels.Model; s: TextMappers.Scanner;
-			err: INTEGER; i: INTEGER; ch: CHAR; loc: Files.Locator;
-			msg: ARRAY 1024 OF CHAR;
-	BEGIN
-		err := ABS(v.err); NumToStr(err, msg, i);
-		loc := Files.dir.This("Dev"); IF loc = NIL THEN RETURN END;
-		loc := loc.This("Rsrc"); IF loc = NIL THEN RETURN END;
-		view := Views.OldView(loc, errFile);
-		IF (view # NIL) & (view IS TextViews.View) THEN
-			t := view(TextViews.View).ThisModel();
-			IF t # NIL THEN
-				s.ConnectTo(t);
-				REPEAT
-					s.Scan
-				UNTIL ((s.type = TextMappers.int) & (s.int = err)) OR (s.type = TextMappers.eot);
-				IF s.type = TextMappers.int THEN
-					s.Skip(ch); i := 0;
-					WHILE (ch >= " ") & (i < LEN(msg) - 1) DO
-						msg[i] := ch; INC(i); s.rider.ReadChar(ch)
-					END;
-					msg[i] := 0X
-				END
-			END
-		END;
-		NEW(v.msg, i + 1); v.msg^ := msg$
-	END Load;
-
-	PROCEDURE DrawMsg (v: StdView; f: Views.Frame; font: Fonts.Font; color: Ports.Color);
-		VAR w, h, asc, dsc: INTEGER;
-	BEGIN
-		CASE v.mode OF
-		  mark:
-			v.context.GetSize(w, h);
-			f.DrawLine(point, 0, w - 2 * point, h, 0, color);
-			f.DrawLine(w - 2 * point, 0, point, h, 0, color)
-		| message:
-			font.GetBounds(asc, dsc, w);
-			f.DrawString(2 * point, asc, color, v.msg^, font)
-		END
-	END DrawMsg;
-	
-	PROCEDURE ShowMsg (v: StdView);
-	BEGIN
-		IF v.msg = NIL THEN Load(v) END;
-		Dialog.ShowStatus(v.msg^)
-	END ShowMsg;
-
-	PROCEDURE Track (v: StdView; f: Views.Frame; x, y: INTEGER; buttons: SET);
-		VAR c: Models.Context; t: TextModels.Model; u, w, h: INTEGER; isDown, in, in0: BOOLEAN; m: SET;
-	BEGIN
-		v.context.GetSize(w, h); u := f.dot; in0 := FALSE;
-		in := (0 <= x) & (x < w) & (0 <= y) & (y < h);
-		REPEAT
-			IF in # in0 THEN
-				f.MarkRect(u, 0, w - u, h, Ports.fill, Ports.invert, Ports.show); in0 := in
-			END;
-			f.Input(x, y, m, isDown);
-			in := (0 <= x) & (x < w) & (0 <= y) & (y < h)
-		UNTIL ~isDown;
-		IF in0 THEN
-			f.MarkRect(u, 0, w - u, h, Ports.fill, Ports.invert, Ports.hide);
-			IF Dialog.showsStatus & ~(Controllers.modify IN buttons) & ~(Controllers.doubleClick IN buttons) THEN
-				ShowMsg(v)
-			ELSE
-				ToggleMode(v)
-			END;
-			c := v.context;
-			WITH c: TextModels.Context DO
-				t := c.ThisModel();
-				TextControllers.SetCaret(t, c.Pos() + 1)
-			ELSE
-			END
-		END
-	END Track;
-
-	PROCEDURE SizePref (v: StdView; VAR p: Properties.SizePref);
-		VAR c: Models.Context; a: TextModels.Attributes; font: Fonts.Font; asc, dsc, w: INTEGER;
-	BEGIN
-		c := v.context;
-		IF (c # NIL) & (c IS TextModels.Context) THEN a := c(TextModels.Context).Attr(); font := a.font
-		ELSE font := Fonts.dir.Default()
-		END;
-		font.GetBounds(asc, dsc, w);
-		p.h := asc + dsc;
-		CASE v.mode OF
-		  mark:
-			p.w := p.h + 2 * point
-		| message:
-			IF v.msg = NIL THEN Load(v) END;
-			p.w := font.StringWidth(v.msg^) + 4 * point
-		END
-	END SizePref;
-
-
-	(* StdView *)
-
-	PROCEDURE (v: StdView) ExternalizeAs (VAR s1: Stores.Store);
-	BEGIN
-		s1 := NIL
-	END ExternalizeAs;
-
-	PROCEDURE (v: StdView) SetMode(mode: INTEGER);
-	BEGIN v.SetMode^(mode); ShowMsg(v)
-	END SetMode;
-
-	PROCEDURE (v: StdView) Restore (f: Views.Frame; l, t, r, b: INTEGER);
-		VAR c: Models.Context; a: TextModels.Attributes; font: Fonts.Font; color: Ports.Color;
-			w, h: INTEGER;
-	BEGIN
-		c := v.context; c.GetSize(w, h);
-		WITH c: TextModels.Context DO a := c.Attr(); font := a.font ELSE font := Fonts.dir.Default() END;
-		IF TRUE (*f.colors >= 4*) THEN color := Ports.grey50 ELSE color := Ports.defaultColor END;
-		IF v.err >= 0 THEN
-			f.DrawRect(point, 0, w - point, h, Ports.fill, color);
-			DrawMsg(v, f, font, Ports.background)
-		ELSE
-			f.DrawRect(point, 0, w - point, h, 0, color);
-			DrawMsg(v, f, font, Ports.defaultColor)
-		END
-	END Restore;
-
-	PROCEDURE (v: StdView) GetBackground (VAR color: Ports.Color);
-	BEGIN
-		color := Ports.background
-	END GetBackground;
-
-	PROCEDURE (v: StdView) HandleCtrlMsg (f: Views.Frame; VAR msg: Controllers.Message;
-																		VAR focus: Views.View);
-	BEGIN
-		WITH msg: Controllers.TrackMsg DO
-			Track(v, f, msg.x, msg.y, msg.modifiers)
-		ELSE
-		END
-	END HandleCtrlMsg;
-
-	PROCEDURE (v: StdView) HandlePropMsg (VAR msg: Properties.Message);
-		VAR c: Models.Context; a: TextModels.Attributes; font: Fonts.Font; asc, w: INTEGER;
-	BEGIN
-		WITH msg: Properties.Preference DO
-			WITH msg: Properties.SizePref DO
-				SizePref(v, msg)
-			| msg: Properties.ResizePref DO
-				msg.fixed := TRUE
-			| msg: Properties.FocusPref DO
-				msg.hotFocus := TRUE
-(*
-			| msg: Properties.StorePref DO
-				msg.view := NIL
-*)
-			| msg: TextSetters.Pref DO
-				c := v.context;
-				IF (c # NIL) & (c IS TextModels.Context) THEN
-					a := c(TextModels.Context).Attr(); font := a.font
-				ELSE
-					font := Fonts.dir.Default()
-				END;
-				font.GetBounds(asc, msg.dsc, w)
-			ELSE
-			END
-		ELSE
-		END
-	END HandlePropMsg;
-
-
-	(* StdDirectory *)
-
-	PROCEDURE (d: StdDirectory) New (err: INTEGER): View;
-		VAR v: StdView;
-	BEGIN
-		NEW(v); v.InitErr(err); RETURN v
-	END New;
-
-	PROCEDURE (d: StdDirectory) NewMsg (msg: ARRAY OF CHAR): View;
-		VAR v: StdView;
-	BEGIN
-		NEW(v); v.InitErr(noCode); v.InitMsg(msg); RETURN v
-	END NewMsg;
-
-
-	(** Cleaner **)
-
-	PROCEDURE Cleanup;
-	BEGIN
-		globR := NIL; globW := NIL
-	END Cleanup;
-	
-
-	(** miscellaneous **)
-
-	PROCEDURE Insert* (text: TextModels.Model; pos: INTEGER; v: View);
-		VAR w: TextModels.Writer; r: TextModels.Reader;
-	BEGIN
-		ASSERT(v.era = 0, 20);
-		Models.BeginModification(Models.clean, text);
-		v.era := thisEra;
-		IF pos > text.Length() THEN pos := text.Length() END;
-		globW := text.NewWriter(globW); w := globW; w.SetPos(pos);
-		IF pos > 0 THEN DEC(pos) END;
-		globR := text.NewReader(globR); r := globR; r.SetPos(pos); r.Read;
-		IF r.attr # NIL THEN w.SetAttr(r.attr) END;
-		w.WriteView(v, Views.undefined, Views.undefined);
-		Models.EndModification(Models.clean, text);
-	END Insert;
-
-	PROCEDURE Unmark* (text: TextModels.Model);
-		VAR r: TextModels.Reader; v: Views.View; pos: INTEGER;
-			script: Stores.Operation;
-	BEGIN
-		Models.BeginModification(Models.clean, text);
-		Models.BeginScript(text, "#Dev:DeleteMarkers", script);
-		r := text.NewReader(NIL); r.ReadView(v);
-		WHILE ~r.eot DO
-			IF r.view IS View THEN
-				pos := r.Pos() - 1; text.Delete(pos, pos + 1); r.SetPos(pos)
-			END;
-			r.ReadView(v)
-		END;
-		INC(thisEra);
-		Models.EndScript(text, script);
-		Models.EndModification(Models.clean, text);
-	END Unmark;
-
-	PROCEDURE ShowFirstError* (text: TextModels.Model; focusOnly: BOOLEAN);
-		VAR v1: Views.View; pos: INTEGER;
-	BEGIN
-		globR := text.NewReader(globR); globR.SetPos(0);
-		REPEAT globR.ReadView(v1) UNTIL globR.eot OR (v1 IS View);
-		IF ~globR.eot THEN
-			pos := globR.Pos();
-			TextViews.ShowRange(text, pos, pos, focusOnly);
-			TextControllers.SetCaret(text, pos);
-			v1(View).SetMode(v1(View).mode)
-		END
-	END ShowFirstError;
-
-
-	(** commands **)
-
-	PROCEDURE UnmarkErrors*;
-		VAR t: TextModels.Model;
-	BEGIN
-		t := TextViews.FocusText();
-		IF t # NIL THEN Unmark(t) END
-	END UnmarkErrors;
-
-	PROCEDURE NextError*;
-		VAR c: TextControllers.Controller; t: TextModels.Model; v1: Views.View;
-			beg, pos: INTEGER;
-	BEGIN
-		c := TextControllers.Focus();
-		IF c # NIL THEN
-			t := c.text;
-			IF c.HasCaret() THEN pos := c.CaretPos()
-			ELSIF c.HasSelection() THEN c.GetSelection(beg, pos)
-			ELSE pos := 0
-			END;
-			TextControllers.SetSelection(t, TextControllers.none, TextControllers.none);
-			globR := t.NewReader(globR); globR.SetPos(pos);
-			REPEAT globR.ReadView(v1) UNTIL globR.eot OR (v1 IS View);
-			IF ~globR.eot THEN
-				pos := globR.Pos(); v1(View).SetMode(v1(View).mode);
-				TextViews.ShowRange(t, pos, pos, TextViews.focusOnly)
-			ELSE
-				pos := 0; Dialog.Beep
-			END;
-			TextControllers.SetCaret(t, pos);
-			globR := NIL
-		END
-	END NextError;
-
-	PROCEDURE ToggleCurrent*;
-		VAR c: TextControllers.Controller; t: TextModels.Model; v: Views.View; pos: INTEGER;
-	BEGIN
-		c := TextControllers.Focus();
-		IF (c # NIL) & c.HasCaret() THEN
-			t := c.text; pos := c.CaretPos();
-			globR := t.NewReader(globR); globR.SetPos(pos); globR.ReadPrev;
-			v := globR.view;
-			IF (v # NIL) & (v IS View) THEN ToggleMode(v(View)) END;
-			TextViews.ShowRange(t, pos, pos, TextViews.focusOnly);
-			TextControllers.SetCaret(t, pos);
-			globR := NIL
-		END
-	END ToggleCurrent;
-
-
-	PROCEDURE SetDir* (d: Directory);
-	BEGIN
-		dir := d
-	END SetDir;
-
-
-	PROCEDURE Init;
-		VAR d: StdDirectory;
-	BEGIN
-		thisEra := 1;
-		NEW(d); dir := d; stdDir := d
-	END Init;
-
-BEGIN
-	Init; Kernel.InstallCleaner(Cleanup)
-CLOSE
-	Kernel.RemoveCleaner(Cleanup)
-END DevMarkers.

BlackBox/Dev/Mod/Selectors.txt

@@ -1,411 +0,0 @@
-MODULE DevSelectors;
-
-	(* THIS IS TEXT COPY OF BlackBox 1.6-rc6 Dev/Mod/Selectors.odc *)
-	(* DO NOT EDIT *)
-
-	IMPORT
-		Ports, Stores, Models, Views, Controllers, Fonts, Properties, TextModels, TextViews, TextSetters;
-		
-
-	CONST
-		left* = 1; middle* = 2; right* = 3;
-
-		minVersion = 0; currentVersion = 0;
-		
-		changeSelectorsKey = "#Dev:Change Selectors";
-
-
-	TYPE
-		Selector* = POINTER TO RECORD (Views.View)
-			position-: INTEGER;	(* left, middle, right *)
-			leftHidden: TextModels.Model;	(* valid iff (position = left) *)
-			rightHidden: TextModels.Model	(* valid iff (position = left) *)
-		END;
-
-		Directory* = POINTER TO ABSTRACT RECORD END;
-
-		StdDirectory = POINTER TO RECORD (Directory) END;
-		
-		
-	VAR
-		dir-, stdDir-: Directory;
-
-
-		PROCEDURE (d: Directory) New* (position: INTEGER): Selector, NEW, ABSTRACT;
-
-
-	PROCEDURE GetFirst (selector: Selector; OUT first: Selector; OUT pos: INTEGER);
-		VAR c: Models.Context; rd: TextModels.Reader; v: Views.View; nest: INTEGER;
-	BEGIN
-		c := selector.context; first := NIL; pos := 0;
-		WITH c: TextModels.Context DO
-			IF selector.position = left THEN
-				first := selector
-			ELSE
-				rd := c.ThisModel().NewReader(NIL); rd.SetPos(c.Pos());
-				nest := 1; pos := 1; rd.ReadPrevView(v);
-				WHILE (v # NIL) & (nest > 0) DO
-					WITH v: Selector DO
-						IF v.position = left THEN DEC(nest);
-							IF nest = 0 THEN first := v END
-						ELSIF v.position = right THEN INC(nest)
-						ELSIF nest = 1 THEN INC(pos)
-						END
-					ELSE
-					END;
-					rd.ReadPrevView(v)
-				END
-			END
-		ELSE (* selector not embedded in a text *)
-		END;
-		ASSERT((first = NIL) OR (first.position = left), 100)
-	END GetFirst;
-	
-	PROCEDURE GetNext (rd: TextModels.Reader; OUT next: Selector);
-		VAR nest: INTEGER; v: Views.View;
-	BEGIN
-		nest := 1; next := NIL; rd.ReadView(v);
-		WHILE v # NIL DO
-			WITH v: Selector DO
-				IF v.position = left THEN INC(nest)
-				ELSIF nest = 1 THEN next := v; RETURN
-				ELSIF v.position = right THEN DEC(nest)
-				END
-			ELSE
-			END;
-			rd.ReadView(v)
-		END
-	END GetNext;
-
-	PROCEDURE CalcSize (f: Selector; OUT w, h: INTEGER);
-		VAR c: Models.Context; a: TextModels.Attributes; font: Fonts.Font; asc, dsc, fw: INTEGER;
-	BEGIN
-		c := f.context;
-		IF (c # NIL) & (c IS TextModels.Context) THEN
-			a := c(TextModels.Context).Attr();
-			font := a.font
-		ELSE font := Fonts.dir.Default();
-		END;
-		font.GetBounds(asc, dsc, fw);
-		h := asc + dsc; w := 3 * h DIV 4
-	END CalcSize;
-
-	PROCEDURE GetSection (first: Selector; rd: TextModels.Reader; n: INTEGER; OUT name: ARRAY OF CHAR);
-		VAR i, p0, p1: INTEGER; ch: CHAR; sel: Selector;
-	BEGIN
-		sel := first;
-		IF first.leftHidden.Length() > 0 THEN
-			rd := first.leftHidden.NewReader(rd); rd.SetPos(0);
-			REPEAT p0 := rd.Pos(); GetNext(rd, sel); DEC(n) UNTIL (n < 0) OR (sel = NIL);
-			IF sel = NIL THEN INC(n) END;
-			p1 := rd.Pos() - 1
-		END;
-		IF n >= 0 THEN
-			rd := first.context(TextModels.Context).ThisModel().NewReader(rd);
-			rd.SetPos(first.context(TextModels.Context).Pos() + 1);
-			REPEAT p0 := rd.Pos(); GetNext(rd, sel); DEC(n) UNTIL (n < 0) OR (sel = NIL) OR (sel.position = right);
-			p1 := rd.Pos() - 1
-		END;
-		IF (n >= 0) & (first.rightHidden.Length() > 0) THEN
-			rd := first.rightHidden.NewReader(rd); rd.SetPos(1);
-			REPEAT p0 := rd.Pos(); GetNext(rd, sel); DEC(n) UNTIL (n < 0) OR (sel = NIL);
-			p1 := rd.Pos() - 1;
-			IF sel = NIL THEN p1 := first.rightHidden.Length() END
-		END;
-		IF n < 0 THEN
-			rd.SetPos(p0); rd.ReadChar(ch); i := 0;
-			WHILE (ch <= " ") & (rd.Pos() <= p1) DO rd.ReadChar(ch) END;
-			WHILE (i < LEN(name) - 1) & (rd.Pos() <= p1) & (ch # 0X) DO
-				IF ch >= " " THEN name[i] := ch; INC(i) END;
-				rd.ReadChar(ch)
-			END;
-			WHILE (i > 0) & (name[i - 1] = " ") DO DEC(i) END;
-			name[i] := 0X
-		ELSE
-			name := 7FX + ""
-		END
-	END GetSection;
-	
-
-	PROCEDURE ChangeSelector (first: Selector; rd: TextModels.Reader; selection: INTEGER);
-		VAR pos, p0, len, s: INTEGER; text: TextModels.Model; sel: Selector;
-	BEGIN
-		text := rd.Base();
-		pos := first.context(TextModels.Context).Pos() + 1;
-		(* expand *)
-		rd.SetPos(pos);
-		REPEAT GetNext(rd, sel) UNTIL (sel = NIL) OR (sel.position = right);
-		IF sel # NIL THEN
-			len := first.rightHidden.Length();
-			IF len > 0 THEN text.Insert(rd.Pos() - 1, first.rightHidden, 0, len) END;
-			len := first.leftHidden.Length();
-			IF len > 0 THEN text.Insert(pos, first.leftHidden, 0, len) END;
-			IF selection # 0 THEN	(* collapse *)
-				rd.SetPos(pos); s := 0;
-				REPEAT GetNext(rd, sel); INC(s) UNTIL (s = selection) OR (sel = NIL) OR (sel.position = right);
-				IF (sel # NIL) & (sel.position = middle) THEN
-					first.leftHidden.Insert(0, text, pos, rd.Pos());
-					rd.SetPos(pos); GetNext(rd, sel);
-					p0 := rd.Pos() - 1;
-					WHILE (sel # NIL) & (sel.position # right) DO GetNext(rd, sel) END;
-					IF sel # NIL THEN
-						first.rightHidden.Insert(0, text, p0, rd.Pos() - 1)
-					END
-				END
-			END
-		END;
-		rd.SetPos(pos)
-	END ChangeSelector;
-	
-	PROCEDURE ChangeThis (
-		text: TextModels.Model; rd, rd1: TextModels.Reader; title: ARRAY OF CHAR; selection: INTEGER
-	);
-		VAR v: Views.View; str: ARRAY 256 OF CHAR;
-	BEGIN
-		rd := text.NewReader(rd);
-		rd.SetPos(0); rd.ReadView(v);
-		WHILE v # NIL DO
-			WITH v: Selector DO
-				IF v.position = left THEN
-					GetSection(v, rd1, 0, str);
-					IF str = title THEN
-						ChangeSelector(v, rd, selection)
-					END;
-					IF v.leftHidden.Length() > 0 THEN ChangeThis(v.leftHidden, NIL, rd1, title, selection) END;
-					IF v.rightHidden.Length() > 0 THEN ChangeThis(v.rightHidden, NIL, rd1, title, selection) END
-				END
-			ELSE
-			END;
-			rd.ReadView(v)
-		END
-	END ChangeThis;
-	
-	PROCEDURE Change* (text: TextModels.Model; title: ARRAY OF CHAR; selection: INTEGER);
-		VAR rd, rd1: TextModels.Reader; script: Stores.Operation;
-	BEGIN
-		rd := text.NewReader(NIL);
-		rd1 := text.NewReader(NIL);
-		Models.BeginModification(Models.clean, text);
-		Models.BeginScript(text, changeSelectorsKey, script);
-		ChangeThis(text, rd, rd1, title, selection);
-		Models.EndScript(text, script);
-		Models.EndModification(Models.clean, text);
-	END Change;
-	
-	PROCEDURE ChangeTo* (text: TextModels.Model; title, entry: ARRAY OF CHAR);
-		VAR rd, rd1: TextModels.Reader; str: ARRAY 256 OF CHAR; v: Views.View; sel: INTEGER;
-	BEGIN
-		rd := text.NewReader(NIL);
-		rd1 := text.NewReader(NIL);
-		rd.SetPos(0); rd.ReadView(v);
-		WHILE v # NIL DO
-			WITH v: Selector DO
-				IF v.position = left THEN
-					GetSection(v, rd1, 0, str);
-					IF title = str THEN
-						sel := 0;
-						REPEAT
-							INC(sel); GetSection(v, rd1, sel, str)
-						UNTIL (str[0] = 7FX) OR (str = entry);
-						IF str[0] # 7FX THEN
-							Change(text, title, sel);
-							RETURN
-						END
-					END
-				END
-			ELSE
-			END;
-			rd.ReadView(v)
-		END
-	END ChangeTo;
-
-
-	PROCEDURE (selector: Selector) HandlePropMsg- (VAR msg: Properties.Message);
-		VAR c: Models.Context; a: TextModels.Attributes; asc, w: INTEGER;
-	BEGIN
-		WITH msg: Properties.SizePref DO CalcSize(selector, msg.w, msg.h)
-		| msg: Properties.ResizePref DO msg.fixed := TRUE;
-		| msg: Properties.FocusPref DO msg.hotFocus := TRUE;
-		| msg: TextSetters.Pref DO c := selector.context;
-			IF (c # NIL) & (c IS TextModels.Context) THEN
-				a := c(TextModels.Context).Attr();
-				a.font.GetBounds(asc, msg.dsc, w)
-			END
-		ELSE (*selector.HandlePropMsg^(msg);*)
-		END
-	END HandlePropMsg;
-
-	PROCEDURE Track (selector: Selector; f: Views.Frame; x, y: INTEGER; buttons: SET; VAR hit: BOOLEAN);
-		VAR a: TextModels.Attributes; font: Fonts.Font; c: Models.Context;
-			w, h, asc, dsc, fw: INTEGER; isDown, in, in0: BOOLEAN; modifiers: SET;
-	BEGIN
-		c := selector.context; hit := FALSE;
-		WITH c: TextModels.Context DO
-			a := c.Attr(); font := a.font;
-			c.GetSize(w, h); in0 := FALSE;
-			in := (0 <= x) & (x < w) & (0 <= y) & (y < h);
-			REPEAT
-				IF in # in0 THEN
-					f.MarkRect(0, 0, w, h, Ports.fill, Ports.hilite, FALSE); in0 := in
-				END;
-				f.Input(x, y, modifiers, isDown);
-				in := (0 <= x) & (x < w) & (0 <= y) & (y < h)
-			UNTIL ~isDown;
-			IF in0 THEN hit := TRUE;
-				font.GetBounds(asc, dsc, fw);
-				f.MarkRect(0, 0, w, asc + dsc, Ports.fill, Ports.hilite, FALSE);
-			END
-		ELSE
-		END
-	END Track;
-
-	PROCEDURE (selector: Selector) HandleCtrlMsg* (
-		f: Views.Frame; VAR msg: Views.CtrlMessage; VAR focus: Views.View
-	);
-		VAR hit: BOOLEAN; sel, pos: INTEGER; text: TextModels.Model; title: ARRAY 256 OF CHAR; first: Selector;
-	BEGIN
-		WITH msg: Controllers.TrackMsg DO
-			IF selector.context IS TextModels.Context THEN
-				Track(selector, f, msg.x, msg.y, msg.modifiers, hit);
-				IF hit THEN
-					text := selector.context(TextModels.Context).ThisModel();
-					GetFirst(selector, first, pos);
-					IF first # NIL THEN
-						GetSection(first, NIL, 0, title);
-						IF selector.position = middle THEN sel := pos ELSE sel := 0 END;
-						Change(text, title, sel);
-						text := selector.context(TextModels.Context).ThisModel();
-						IF TextViews.FocusText() = text THEN
-							pos := selector.context(TextModels.Context).Pos();
-							TextViews.ShowRange(text, pos, pos+1, TRUE)
-						END
-					END
-				END
-			END
-		| msg: Controllers.PollCursorMsg DO
-			msg.cursor := Ports.refCursor;
-		ELSE
-		END
-	END HandleCtrlMsg;
-
-	PROCEDURE (selector: Selector) Restore* (f: Views.Frame; l, t, r, b: INTEGER);
-		VAR w, h, d: INTEGER;
-	BEGIN
-		selector.context.GetSize(w, h);
-(*
-		GetFirst(selector, first, pos);
-*)
-		w := w - w MOD f.unit; d := 2 * f.dot;
-		f.DrawLine(d, d, w - d, d, d, Ports.grey25);
-		f.DrawLine(d, h - d, w - d, h - d, d, Ports.grey25);
-		IF selector.position # right THEN f.DrawLine(d, d, d, h - d, d, Ports.grey25) END;
-		IF selector.position # left THEN f.DrawLine(w - d, d, w - d, h - d, d, Ports.grey25) END
-	END Restore;
-
-	PROCEDURE (selector: Selector) CopyFromSimpleView- (source: Views.View);
-	BEGIN
-		(* selector.CopyFrom^(source); *)
-		WITH source: Selector DO
-			selector.position := source.position;
-			IF source.leftHidden # NIL THEN
-				selector.leftHidden := TextModels.CloneOf(source.leftHidden);
-				selector.leftHidden.InsertCopy(0, source.leftHidden, 0, source.leftHidden.Length())
-			END;
-			IF source.rightHidden # NIL THEN
-				selector.rightHidden := TextModels.CloneOf(source.rightHidden);
-				selector.rightHidden.InsertCopy(0, source.rightHidden, 0, source.rightHidden.Length())
-			END
-		END
-	END CopyFromSimpleView;
-
-	PROCEDURE (selector: Selector) InitContext* (context: Models.Context);
-	BEGIN
-		selector.InitContext^(context);
-		IF selector.position = left THEN
-			WITH context: TextModels.Context DO
-				IF selector.leftHidden = NIL THEN 
-					selector.leftHidden := TextModels.CloneOf(context.ThisModel());
-					Stores.Join(selector, selector.leftHidden);
-				END;
-				IF selector.rightHidden = NIL THEN
-					selector.rightHidden := TextModels.CloneOf(context.ThisModel());
-					Stores.Join(selector, selector.rightHidden)
-				END
-			ELSE
-			END
-		END
-	END InitContext;
-	
-	PROCEDURE (selector: Selector) Internalize- (VAR rd: Stores.Reader);
-		VAR version: INTEGER; store: Stores.Store;
-	BEGIN
-		selector.Internalize^(rd);
-		IF rd.cancelled THEN RETURN END;
-		rd.ReadVersion(minVersion, currentVersion, version);
-		IF rd.cancelled THEN RETURN END;
-		rd.ReadInt(selector.position);
-		rd.ReadStore(store);
-		IF store # NIL THEN selector.leftHidden := store(TextModels.Model)
-		ELSE selector.leftHidden := NIL
-		END;
-		rd.ReadStore(store);
-		IF store # NIL THEN selector.rightHidden := store(TextModels.Model)
-		ELSE selector.rightHidden := NIL
-		END
-	END Internalize;
-
-	PROCEDURE (selector: Selector) Externalize- (VAR wr: Stores.Writer);
-	BEGIN
-		selector.Externalize^(wr);
-		wr.WriteVersion(currentVersion);
-		wr.WriteInt(selector.position);
-		wr.WriteStore(selector.leftHidden);
-		wr.WriteStore(selector.rightHidden)
-	END Externalize;
-
-
-	PROCEDURE (d: StdDirectory) New (position: INTEGER): Selector;
-		VAR selector: Selector;
-	BEGIN
-		NEW(selector);
-		selector.position := position;
-		RETURN selector
-	END  New;
-
-	PROCEDURE SetDir* (d: Directory);
-	BEGIN
-		ASSERT(d # NIL, 20);
-		dir := d
-	END SetDir;
-	
-
-	PROCEDURE DepositLeft*;
-	BEGIN
-		Views.Deposit(dir.New(left))
-	END DepositLeft;
-
-	PROCEDURE DepositMiddle*;
-	BEGIN
-		Views.Deposit(dir.New(middle))
-	END DepositMiddle;
-
-	PROCEDURE DepositRight*;
-	BEGIN
-		Views.Deposit(dir.New(right))
-	END DepositRight;
-
-
-	PROCEDURE InitMod;
-		VAR d: StdDirectory;
-	BEGIN
-		NEW(d); dir := d; stdDir := d;
-	END InitMod;
-
-BEGIN
-	InitMod
-END DevSelectors.
-
-
-	"Insert Left"	"*F5"	"DevSelectors.DepositLeft; StdCmds.PasteView"	"StdCmds.PasteViewGuard"
-	"Insert Middle"	"*F6"	"DevSelectors.DepositMiddle; StdCmds.PasteView"	"StdCmds.PasteViewGuard"
-	"Insert Right"	"*F7"	"DevSelectors.DepositRight; StdCmds.PasteView"	"StdCmds.PasteViewGuard"

BlackBox/Std/Mod/Api.txt

@@ -1,229 +0,0 @@
-MODULE StdApi;
-
-	(* THIS IS TEXT COPY OF BlackBox 1.6-rc6 Std/Mod/Api.odc *)
-	(* DO NOT EDIT *)
-
-	IMPORT
-		Kernel, Views, Files, Dialog, Converters, Windows, Sequencers, Stores, Meta,
-		Containers, StdDialog, Documents;
-
-	(* Auxiliary procedures *)
-
-	PROCEDURE CheckQualident (VAR str, mod, name: ARRAY OF CHAR);
-		VAR i, j: INTEGER; ch: CHAR;
-	BEGIN
-		i := 0; 
-		REPEAT
-			ch := str[i]; mod[i] := ch; INC(i)
-		UNTIL (i = LEN(str)) OR (i = LEN(mod)) OR (ch < "0") OR (ch > "9") & (CAP(ch) < "A") OR (CAP(ch) > "Z");
-		IF ch = "." THEN
-			mod[i - 1] := 0X; j := 0;
-			REPEAT
-				ch := str[i]; name[j] := ch; INC(i); INC(j)
-			UNTIL (i = LEN(str)) OR (j = LEN(name)) OR (ch < "0") OR (ch > "9") & (CAP(ch) < "A") OR (CAP(ch) > "Z");
-			IF ch # 0X THEN mod[0] := 0X; name[0] := 0X END
-		ELSE mod[0] := 0X; name[0] := 0X
-		END
-	END CheckQualident;
-	
-	PROCEDURE PathToSpec (VAR path: ARRAY OF CHAR; VAR loc: Files.Locator; VAR name: Files.Name);
-		VAR i, j: INTEGER; ch: CHAR;
-	BEGIN
-		i := 0; j := 0; loc := Files.dir.This("");
-		WHILE (loc.res = 0) & (i < LEN(path) - 1) & (j < LEN(name) - 1) & (path[i] # 0X) DO
-			ch := path[i]; INC(i);
-			IF (j > 0) & ((ch = "/") OR (ch = "\")) THEN
-				name[j] := 0X; j := 0;
-				IF name = "*" THEN
-					IF Dialog.language # "" THEN loc := loc.This(Dialog.language) END
-				ELSE loc := loc.This(name)
-				END
-			ELSE
-				name[j] := ch; INC(j)
-			END
-		END;
-		IF path[i] = 0X THEN name[j] := 0X
-		ELSE loc.res := 1; name := ""
-		END
-	END PathToSpec;
-	
-	PROCEDURE ThisDialog (dialog: ARRAY OF CHAR): Views.View;
-		VAR fname, submod, sub, mod: Files.Name; canCreate: BOOLEAN; conv: Converters.Converter;
-			loc: Files.Locator; file: Files.File; v: Views.View; s: Stores.Store; var: Meta.Item;
-	BEGIN
-		ASSERT(dialog # "", 20);
-		v := NIL; file := NIL; canCreate := FALSE;
-		CheckQualident(dialog, submod, fname);
-		IF submod # "" THEN	(* is qualident *)
-			Meta.LookupPath(dialog, var);
-			IF var.obj = Meta.varObj THEN	(* variable exists *)
-				canCreate := TRUE;
-				Kernel.SplitName(submod, sub, mod);
-				loc := Files.dir.This(sub);
-				IF loc # NIL THEN
-					Kernel.MakeFileName(fname, "");
-					loc := loc.This("Rsrc");
-					IF loc # NIL THEN file := Files.dir.Old(loc, fname, Files.shared) END;
-					IF (file = NIL) & (sub = "") THEN
-						loc := Files.dir.This("System"); ASSERT(loc # NIL, 100);
-						IF loc # NIL THEN
-							loc := loc.This("Rsrc");
-							IF loc # NIL THEN file := Files.dir.Old(loc, fname, Files.shared) END
-						END
-					END
-				END
-			END
-		END;
-		IF (file = NIL) & ~canCreate THEN	(* try file name *)
-			PathToSpec(dialog, loc, fname);
-			IF loc.res = 0 THEN
-				Kernel.MakeFileName(fname, "");
-				file := Files.dir.Old(loc, fname, Files.shared)
-			END
-		END;
-		IF file # NIL THEN
-			Kernel.MakeFileName(fname, "");
-			conv := NIL; Converters.Import(loc, fname, conv, s);
-			IF s # NIL THEN
-				v := s(Views.View)
-			END
-		ELSE Dialog.ShowParamMsg("#System:FileNotFound", dialog, "", "")
-		END;
-		RETURN v
-	END ThisDialog;
-
-	PROCEDURE ThisMask (param: ARRAY OF CHAR): Views.View;
-		VAR v: Views.View; c: Containers.Controller;
-	BEGIN
-		v := ThisDialog(param);
-		IF v # NIL THEN
-			WITH v: Containers.View DO
-				c := v.ThisController();
-				IF c # NIL THEN
-					c.SetOpts(c.opts - {Containers.noFocus} + {Containers.noCaret, Containers.noSelection})
-				ELSE Dialog.ShowMsg("#System:NotEditable")
-				END
-			ELSE Dialog.ShowMsg("#System:ContainerExpected")
-			END
-		END;
-		RETURN v
-	END ThisMask;
-	
-	(* Interface procedures *)
-	
-	PROCEDURE CloseDialog* (OUT closedView: Views.View);
-		CONST canClose = {Windows.neverDirty, Windows.isTool, Windows.isAux};
-		VAR w: Windows.Window; msg: Sequencers.CloseMsg;
-	BEGIN
-		closedView := NIL;
-		w := Windows.dir.First();
-		IF w # NIL THEN
-			IF w.sub THEN
-				closedView := w.frame.view;
-				Windows.dir.Close(w);
-			ELSIF (w.flags * canClose = {}) & w.seq.Dirty() THEN
-				Dialog.ShowMsg("#System:CannotCloseDirtyWindow")
-			ELSE
-				msg.sticky := FALSE; w.seq.Notify(msg);
-				IF ~msg.sticky THEN closedView := w.frame.view; Windows.dir.Close(w) END
-			END
-		END
-	END CloseDialog;
-	
-	PROCEDURE OpenAux* (file, title: ARRAY OF CHAR; OUT v: Views.View);
-		VAR loc: Files.Locator; name: Files.Name; t: Views.Title;
-	BEGIN
-		PathToSpec(file, loc, name);
-		IF loc.res = 0 THEN
-			loc.res := 77; v := Views.OldView(loc, name); loc.res := 0;
-			IF v # NIL THEN t := title$; Views.OpenAux(v, t)
-			ELSE Dialog.ShowParamMsg("#System:FileNotFound", file, "", "")
-			END
-		ELSE Dialog.ShowParamMsg("#System:FileNotFound", file, "", "")
-		END
-	END OpenAux;
-	
-	PROCEDURE OpenAuxDialog* (file, title: ARRAY OF CHAR; OUT v: Views.View);
-		VAR t0: Views.Title; done: BOOLEAN;
-	BEGIN
-		Dialog.MapString(title, t0);
-		Windows.SelectByTitle(NIL, {Windows.isAux}, t0, done);
-		IF ~done THEN
-			v := ThisMask(file);
-			IF v # NIL THEN
-				StdDialog.Open(v, title, NIL, "", NIL, FALSE, TRUE, TRUE, FALSE, TRUE)
-			END
-		END
-	END OpenAuxDialog;
-	
-	PROCEDURE OpenBrowser* (file, title: ARRAY OF CHAR; OUT v: Views.View);
-		VAR loc: Files.Locator; name: Files.Name; t: Views.Title;
-			c: Containers.Controller;
-	BEGIN
-		PathToSpec(file, loc, name);
-		IF loc.res = 0 THEN
-			loc.res := 77; v := Views.OldView(loc, name); loc.res := 0;
-			IF v # NIL THEN
-				WITH v: Containers.View DO
-					c := v.ThisController();
-					IF c # NIL THEN
-						c.SetOpts(c.opts - {Containers.noFocus, Containers.noSelection} + {Containers.noCaret})
-					END
-				ELSE
-				END;
-				t := title$;
-				StdDialog.Open(v, t, NIL, "", NIL, FALSE, TRUE, FALSE, TRUE, FALSE)
-			ELSE Dialog.ShowParamMsg("#System:FileNotFound", file, "", "")
-			END
-		ELSE Dialog.ShowParamMsg("#System:FileNotFound", file, "", "")
-		END
-	END OpenBrowser;
-	
-	PROCEDURE OpenDoc* (file: ARRAY OF CHAR; OUT v: Views.View);
-		VAR loc: Files.Locator; name: Files.Name; conv: Converters.Converter;
-	BEGIN
-		PathToSpec(file, loc, name);
-		IF loc.res = 0 THEN
-			conv := NIL; v := Views.Old(Views.dontAsk, loc, name, conv);
-			IF loc.res = 78 THEN loc := NIL; name := "" END;	(* stationery *)
-			IF v # NIL THEN Views.Open(v, loc, name, conv)
-			ELSE Dialog.ShowParamMsg("#System:FileNotFound", file, "", "")
-			END
-		ELSE Dialog.ShowParamMsg("#System:FileNotFound", file, "", "")
-		END
-	END OpenDoc;
-	
-	PROCEDURE OpenCopyOf* (file: ARRAY OF CHAR; OUT v: Views.View);
-		VAR loc: Files.Locator; name: Files.Name; conv: Converters.Converter;
-	BEGIN
-		PathToSpec(file, loc, name);
-		IF loc.res = 0 THEN
-			conv := NIL; v := Views.Old(Views.dontAsk, loc, name, conv);
-			IF loc.res = 78 THEN loc := NIL; name := "" END;	(* stationary *)
-			IF v # NIL THEN 
-				IF v.context # NIL THEN
-					v := Views.CopyOf(v.context(Documents.Context).ThisDoc(), Views.deep);
-					Stores.InitDomain(v)
-				ELSE v := Views.CopyOf(v, Views.deep)
-				END;
-				Views.Open(v, NIL, "", conv)
-			ELSE Dialog.ShowParamMsg("#System:FileNotFound", file, "", "")
-			END
-		ELSE Dialog.ShowParamMsg("#System:FileNotFound", file, "", "")
-		END
-	END OpenCopyOf;
-	
-	PROCEDURE OpenToolDialog* (file, title: ARRAY OF CHAR; OUT v: Views.View);
-		VAR t0: Views.Title; done: BOOLEAN;
-	BEGIN
-		Dialog.MapString(title, t0);
-		Windows.SelectByTitle(NIL, {Windows.isTool}, t0, done);
-		IF ~done THEN
-			v := ThisMask(file);
-			IF v # NIL THEN
-				StdDialog.Open(v, title, NIL, "", NIL, TRUE, FALSE, TRUE, FALSE, TRUE)
-			END
-		END
-	END OpenToolDialog;
-	
-END StdApi.

BlackBox/Std/Mod/CFrames.txt

@@ -1,243 +0,0 @@
-MODULE StdCFrames;
-
-	(* THIS IS TEXT COPY OF BlackBox 1.6-rc6 Std/Mod/CFrames.odc *)
-	(* DO NOT EDIT *)
-
-	IMPORT Fonts, Ports, Views, Dates, Dialog;
-
-	CONST lineUp* = 0; lineDown* = 1; pageUp* = 2; pageDown* = 3;
-
-	TYPE
-		Frame* = POINTER TO ABSTRACT RECORD (Views.Frame)
-			disabled*, undef*, readOnly*, noRedraw*: BOOLEAN;
-			font*: Fonts.Font
-		END;
-
-		PushButton* = POINTER TO ABSTRACT RECORD (Frame)
-			label*: ARRAY 256 OF CHAR;
-			default*, cancel*: BOOLEAN;
-			Do*: PROCEDURE (f: PushButton)
-		END;
-
-		CheckBox* = POINTER TO ABSTRACT RECORD (Frame)
-			label*: ARRAY 256 OF CHAR;
-			Get*: PROCEDURE (f: CheckBox; OUT on: BOOLEAN);
-			Set*: PROCEDURE (f: CheckBox; on: BOOLEAN)
-		END;
-
-		RadioButton* = POINTER TO ABSTRACT RECORD (Frame)
-			label*: ARRAY 256 OF CHAR;
-			Get*: PROCEDURE (f: RadioButton; OUT on: BOOLEAN);
-			Set*: PROCEDURE (f: RadioButton; on: BOOLEAN)
-		END;
-
-		ScrollBar* = POINTER TO ABSTRACT RECORD (Frame)
-			Track*: PROCEDURE (f: ScrollBar; dir: INTEGER; VAR pos: INTEGER);
-			Get*: PROCEDURE (f: ScrollBar; OUT size, sect, pos: INTEGER);
-			Set*: PROCEDURE (f: ScrollBar; pos: INTEGER)
-		END;
-
-		Field* = POINTER TO ABSTRACT RECORD (Frame)
-			maxLen*: INTEGER;	(* max num of characters in field (w/o 0X) *)
-			left*, right*, multiLine*, password*: BOOLEAN;
-			Get*: PROCEDURE (f: Field; OUT string: ARRAY OF CHAR);
-			Set*: PROCEDURE (f: Field; IN string: ARRAY OF CHAR);
-			Equal*: PROCEDURE (f: Field; IN s1, s2: ARRAY OF CHAR): BOOLEAN
-		END;
-		
-		UpDownField* = POINTER TO ABSTRACT RECORD (Frame)
-			min*, max*, inc*: INTEGER;
-			Get*: PROCEDURE (f: UpDownField; OUT val: INTEGER);
-			Set*: PROCEDURE (f: UpDownField; val: INTEGER)
-		END;
-			
-		DateField* = POINTER TO ABSTRACT RECORD (Frame)
-			Get*: PROCEDURE (f: DateField; OUT date: Dates.Date);
-			Set*: PROCEDURE (f: DateField; IN date: Dates.Date);
-			GetSel*: PROCEDURE (f: DateField; OUT sel: INTEGER);
-			SetSel*: PROCEDURE (f: DateField; sel: INTEGER)
-		END;
-			
-		TimeField* = POINTER TO ABSTRACT RECORD (Frame)
-			Get*: PROCEDURE (f: TimeField; OUT date: Dates.Time);
-			Set*: PROCEDURE (f: TimeField; IN date: Dates.Time);
-			GetSel*: PROCEDURE (f: TimeField; OUT sel: INTEGER);
-			SetSel*: PROCEDURE (f: TimeField; sel: INTEGER)
-		END;
-			
-		ColorField* = POINTER TO ABSTRACT RECORD (Frame)
-			Get*: PROCEDURE (f: ColorField; OUT col: INTEGER);
-			Set*: PROCEDURE (f: ColorField; col: INTEGER)
-		END;
-		
-		ListBox* = POINTER TO ABSTRACT RECORD (Frame)
-			sorted*: BOOLEAN;
-			Get*: PROCEDURE (f: ListBox; OUT i: INTEGER);
-			Set*: PROCEDURE (f: ListBox; i: INTEGER);
-			GetName*: PROCEDURE (f: ListBox; i: INTEGER; VAR name: ARRAY OF CHAR)
-		END;
-		
-		SelectionBox* = POINTER TO ABSTRACT RECORD (Frame)
-			sorted*: BOOLEAN;
-			Get*: PROCEDURE (f: SelectionBox; i: INTEGER; OUT in: BOOLEAN);
-			Incl*: PROCEDURE (f: SelectionBox; from, to: INTEGER);
-			Excl*: PROCEDURE (f: SelectionBox; from, to: INTEGER);
-			Set*: PROCEDURE (f: SelectionBox; from, to: INTEGER);
-			GetName*: PROCEDURE (f: SelectionBox; i: INTEGER; VAR name: ARRAY OF CHAR)
-		END;
-		
-		ComboBox* = POINTER TO ABSTRACT RECORD (Frame)
-			sorted*: BOOLEAN;
-			Get*: PROCEDURE (f: ComboBox; OUT string: ARRAY OF CHAR);
-			Set*: PROCEDURE (f: ComboBox; IN string: ARRAY OF CHAR);
-			GetName*: PROCEDURE (f: ComboBox; i: INTEGER; VAR name: ARRAY OF CHAR)
-		END;
-		
-		Caption* = POINTER TO ABSTRACT RECORD (Frame)
-			label*: ARRAY 256 OF CHAR;
-			left*, right*: BOOLEAN;
-		END;
-		
-		Group* = POINTER TO ABSTRACT RECORD (Frame)
-			label*: ARRAY 256 OF CHAR
-		END;
-
-		TreeFrame* = POINTER TO ABSTRACT RECORD (Frame)
-			sorted*, haslines*, hasbuttons*, atroot*, foldericons*: BOOLEAN;
-			NofNodes*: PROCEDURE (f: TreeFrame): INTEGER;
-			Child*: PROCEDURE (f: TreeFrame; node: Dialog.TreeNode): Dialog.TreeNode;
-			Parent*: PROCEDURE (f: TreeFrame; node: Dialog.TreeNode): Dialog.TreeNode;
-			Next*:  PROCEDURE (f: TreeFrame; node: Dialog.TreeNode): Dialog.TreeNode;
-			Select*:  PROCEDURE (f: TreeFrame; node: Dialog.TreeNode);
-			Selected*:  PROCEDURE (f: TreeFrame): Dialog.TreeNode;
-			SetExpansion*:  PROCEDURE (f: TreeFrame; tn: Dialog.TreeNode; expanded: BOOLEAN)
-		END;
-
-		Directory* = POINTER TO ABSTRACT RECORD END;
-
-
-	VAR
-		setFocus*: BOOLEAN;
-		defaultFont*, defaultLightFont*: Fonts.Font;
-		dir-, stdDir-: Directory;
-
-
-	(** Frame **)
-
-		
-	PROCEDURE (f: Frame) MouseDown* (x, y: INTEGER; buttons: SET), NEW, EMPTY;
-	PROCEDURE (f: Frame) WheelMove* (x, y: INTEGER; op, nofLines: INTEGER;
-																VAR done: BOOLEAN), NEW, EMPTY;
-	PROCEDURE (f: Frame) KeyDown* (ch: CHAR), NEW, EMPTY;
-	PROCEDURE (f: Frame) Restore* (l, t, r, b: INTEGER), NEW, ABSTRACT;
-	PROCEDURE (f: Frame) UpdateList*, NEW, EMPTY;
-	PROCEDURE (f: Frame) Mark* (on, focus: BOOLEAN), NEW, EMPTY;
-	PROCEDURE (f: Frame) Edit* (op: INTEGER; VAR v: Views.View; VAR w, h: INTEGER;
-													VAR singleton, clipboard: BOOLEAN), NEW, EMPTY;
-	PROCEDURE (f: Frame) GetCursor* (x, y: INTEGER; modifiers: SET; VAR cursor: INTEGER), NEW, EMPTY;
-
-	PROCEDURE (f: Frame) Update*, NEW, EXTENSIBLE;
-		VAR l, t, r, b: INTEGER; root: Views.RootFrame;
-	BEGIN
-		l := f.l + f.gx; t := f.t + f.gy; r := f.r + f.gx; b := f.b + f.gy;
-		root := Views.RootOf(f);
-		Views.UpdateRoot(root, l, t, r, b, Views.keepFrames);
-		Views.ValidateRoot(root)
-	END Update;
-
-	PROCEDURE (f: Frame) DblClickOk* (x, y: INTEGER): BOOLEAN, NEW, EXTENSIBLE;
-	BEGIN
-		RETURN TRUE
-	END DblClickOk;
-
-
-	(** Field **)
-
-	PROCEDURE (f: Field) Idle* (), NEW, ABSTRACT;
-	PROCEDURE (f: Field) Select* (from, to: INTEGER), NEW, ABSTRACT;
-	PROCEDURE (f: Field) GetSelection* (OUT from, to: INTEGER), NEW, ABSTRACT;
-	PROCEDURE (f: Field) Length* (): INTEGER, NEW, ABSTRACT;
-
-	PROCEDURE (f: Field) GetCursor* (x, y: INTEGER; modifiers: SET; VAR cursor: INTEGER), EXTENSIBLE;
-	BEGIN
-		cursor := Ports.textCursor
-	END GetCursor;
-
-
-	(** UpDownField **)
-
-	PROCEDURE (f: UpDownField) Idle*, NEW, ABSTRACT;
-	PROCEDURE (f: UpDownField) Select* (from, to: INTEGER), NEW, ABSTRACT;
-	PROCEDURE (f: UpDownField) GetSelection* (OUT from, to: INTEGER), NEW, ABSTRACT;
-
-	PROCEDURE (f: UpDownField) GetCursor* (x, y: INTEGER; modifiers: SET;
-																		VAR cursor: INTEGER), EXTENSIBLE;
-	BEGIN
-		cursor := Ports.textCursor
-	END GetCursor;
-
-
-	(** SelectionBox **)
-
-	PROCEDURE (f: SelectionBox) Select* (from, to: INTEGER), NEW, ABSTRACT;
-	PROCEDURE (f: SelectionBox) GetSelection* (OUT from, to: INTEGER), NEW, ABSTRACT;
-	
-	PROCEDURE (f: SelectionBox) UpdateRange* (op, from, to: INTEGER), NEW, EXTENSIBLE;
-	BEGIN
-		f.Update
-	END UpdateRange;
-
-
-	(** ComboBox **)
-
-	PROCEDURE (f: ComboBox) Idle* (), NEW, ABSTRACT;
-	PROCEDURE (f: ComboBox) Select* (from, to: INTEGER), NEW, ABSTRACT;
-	PROCEDURE (f: ComboBox) GetSelection* (OUT from, to: INTEGER), NEW, ABSTRACT;
-	PROCEDURE (f: ComboBox) Length* (): INTEGER, NEW, ABSTRACT;
-	
-	(* TreeFrame **)
-	PROCEDURE (f: TreeFrame) GetSize* (OUT w, h: INTEGER), NEW, ABSTRACT;
-
-	(** Directory **)
-
-	PROCEDURE (d: Directory) GetPushButtonSize* (VAR w, h: INTEGER), NEW, ABSTRACT;
-	PROCEDURE (d: Directory) GetCheckBoxSize* (VAR w, h: INTEGER), NEW, ABSTRACT;
-	PROCEDURE (d: Directory) GetRadioButtonSize* (VAR w, h: INTEGER), NEW, ABSTRACT;
-	PROCEDURE (d: Directory) GetScrollBarSize* (VAR w, h: INTEGER), NEW, ABSTRACT;
-	PROCEDURE (d: Directory) GetFieldSize* (max: INTEGER; VAR w, h: INTEGER), NEW, ABSTRACT;
-	PROCEDURE (d: Directory) GetUpDownFieldSize* (max: INTEGER; VAR w, h: INTEGER), NEW, ABSTRACT;
-	PROCEDURE (d: Directory) GetDateFieldSize* (VAR w, h: INTEGER), NEW, ABSTRACT;
-	PROCEDURE (d: Directory) GetTimeFieldSize* (VAR w, h: INTEGER), NEW, ABSTRACT;
-	PROCEDURE (d: Directory) GetColorFieldSize* (VAR w, h: INTEGER), NEW, ABSTRACT;
-	PROCEDURE (d: Directory) GetListBoxSize* (VAR w, h: INTEGER), NEW, ABSTRACT;
-	PROCEDURE (d: Directory) GetSelectionBoxSize* (VAR w, h: INTEGER), NEW, ABSTRACT;
-	PROCEDURE (d: Directory) GetComboBoxSize* (VAR w, h: INTEGER), NEW, ABSTRACT;
-	PROCEDURE (d: Directory) GetCaptionSize* (VAR w, h: INTEGER), NEW, ABSTRACT;
-	PROCEDURE (d: Directory) GetGroupSize* (VAR w, h: INTEGER), NEW, ABSTRACT;
-	PROCEDURE (d: Directory) GetTreeFrameSize* (VAR w, h: INTEGER), NEW, ABSTRACT;
-	PROCEDURE (d: Directory) NewPushButton* (): PushButton, NEW, ABSTRACT;
-	PROCEDURE (d: Directory) NewCheckBox* (): CheckBox, NEW, ABSTRACT;
-	PROCEDURE (d: Directory) NewRadioButton* (): RadioButton, NEW, ABSTRACT;
-	PROCEDURE (d: Directory) NewScrollBar* (): ScrollBar, NEW, ABSTRACT;
-	PROCEDURE (d: Directory) NewField* (): Field, NEW, ABSTRACT;
-	PROCEDURE (d: Directory) NewUpDownField* (): UpDownField, NEW, ABSTRACT;
-	PROCEDURE (d: Directory) NewDateField* (): DateField, NEW, ABSTRACT;
-	PROCEDURE (d: Directory) NewTimeField* (): TimeField, NEW, ABSTRACT;
-	PROCEDURE (d: Directory) NewColorField* (): ColorField, NEW, ABSTRACT;
-	PROCEDURE (d: Directory) NewListBox* (): ListBox, NEW, ABSTRACT;
-	PROCEDURE (d: Directory) NewSelectionBox* (): SelectionBox, NEW, ABSTRACT;
-	PROCEDURE (d: Directory) NewComboBox* (): ComboBox, NEW, ABSTRACT;
-	PROCEDURE (d: Directory) NewCaption* (): Caption, NEW, ABSTRACT;
-	PROCEDURE (d: Directory) NewGroup* (): Group, NEW, ABSTRACT;
-	PROCEDURE (d: Directory) NewTreeFrame* (): TreeFrame, NEW, ABSTRACT;
-
-
-	PROCEDURE SetDir* (d: Directory);
-	BEGIN
-		ASSERT(d # NIL, 20); dir := d;
-		IF stdDir = NIL THEN stdDir := d END
-	END SetDir;
-
-BEGIN
-	setFocus := FALSE
-END StdCFrames.

BlackBox/Std/Mod/Clocks.txt

@@ -1,183 +0,0 @@
-MODULE StdClocks;
-
-	(* THIS IS TEXT COPY OF BlackBox 1.6-rc6 Std/Mod/Clocks.odc *)
-	(* DO NOT EDIT *)
-
-	IMPORT
-		Dates, Math, Domains := Stores, Ports, Stores, Models, Views, Services, Properties,
-		TextModels;
-
-	CONST
-		minSize = 25 * Ports.point; niceSize = 42 * Ports.point;
-		minVersion = 0; maxVersion = 0;
-
-	TYPE
-		StdView = POINTER TO RECORD (Views.View)
-			time: Dates.Time
-		END;
-
-		TickAction = POINTER TO RECORD (Services.Action) END;
-
-		Msg = RECORD (Models.Message)
-			consumed: BOOLEAN;
-			time: Dates.Time
-		END;
-
-	VAR
-		clockTime: Dates.Time;
-		action: TickAction;
-		actionIsAlive: BOOLEAN;
-
-
-	PROCEDURE Cos (r, g: INTEGER): INTEGER;
-	BEGIN
-		RETURN SHORT(ENTIER(r * Math.Cos(2 * Math.Pi() * g / 60) + 0.5))
-	END Cos;
-
-	PROCEDURE Sin (r, g: INTEGER): INTEGER;
-	BEGIN
-		RETURN SHORT(ENTIER(r * Math.Sin(2 * Math.Pi() * g / 60) + 0.5))
-	END Sin;
-
-	PROCEDURE (a: TickAction) Do;
-		VAR msg: Msg; time: Dates.Time;
-	BEGIN
-		Dates.GetTime(time);
-		IF clockTime.second = time.second THEN
-			Services.DoLater(action, Services.Ticks() + Services.resolution DIV 2)
-		ELSE
-			clockTime := time;
-			msg.consumed := FALSE;
-			msg.time := time;
-			Views.Omnicast(msg);
-			IF msg.consumed THEN
-				Services.DoLater(action, Services.Ticks() + Services.resolution DIV 2)
-			ELSE
-				actionIsAlive := FALSE
-			END
-		END
-	END Do;
-
-
-	(* View *)
-
-	PROCEDURE DrawTick (f: Views.Frame; m, d0, d1, s, g: INTEGER; c: Ports.Color);
-	BEGIN
-		f.DrawLine(m + Sin(d0, g), m - Cos(d0, g), m + Sin(d1, g), m - Cos(d1, g), s, c)
-	END DrawTick;
-
-
-	PROCEDURE (v: StdView) Externalize (VAR wr: Stores.Writer);
-	BEGIN
-		v.Externalize^(wr);
-		wr.WriteVersion(maxVersion);
-		wr.WriteByte(9)
-	END Externalize;
-
-	PROCEDURE (v: StdView) Internalize (VAR rd: Stores.Reader);
-		VAR thisVersion: INTEGER; format: BYTE;
-	BEGIN
-		v.Internalize^(rd);
-		IF ~rd.cancelled THEN
-			rd.ReadVersion(minVersion, maxVersion, thisVersion);
-			IF ~rd.cancelled THEN
-				rd.ReadByte(format);
-				v.time.second := -1
-			END
-		END
-	END Internalize;
-
-	PROCEDURE (v: StdView) CopyFromSimpleView (source: Views.View);
-	BEGIN
-		WITH source: StdView DO
-			v.time.second := -1
-		END
-	END CopyFromSimpleView;
-
-	PROCEDURE (v: StdView) Restore (f: Views.Frame; l, t, r, b: INTEGER);
-		VAR c: Models.Context; a: TextModels.Attributes; color: Ports.Color;
-			time: Dates.Time;
-			i, m, d, u, hs, hd1, ms, md1, ss, sd0, sd1,  w, h: INTEGER;
-	BEGIN
-		IF ~actionIsAlive THEN
-			 actionIsAlive := TRUE; Services.DoLater(action, Services.now)
-		END;
-		IF v.time.second = -1 THEN Dates.GetTime(v.time) END;
-		c := v.context; c.GetSize(w, h);
-		WITH c: TextModels.Context DO a := c.Attr(); color := a.color
-		ELSE color := Ports.defaultColor
-		END;
-		u := f.unit;
-		d := h DIV u * u;
-		IF ~ODD(d DIV u) THEN DEC(d, u) END;
-		m := (h - u) DIV 2;
-		IF d >= niceSize - 2 * Ports.point THEN
-			hs := 3 * u; ms := 3 * u; ss := u;
-			hd1 := m * 4 DIV 6; md1 := m * 5 DIV 6; sd0 := -(m DIV 6); sd1 := m - 4 * u;
-			i := 0; WHILE i < 12 DO DrawTick(f, m, m * 11 DIV 12, m, u, i  * 5, color); INC(i) END
-		ELSE
-			hd1 := m * 2 DIV 4; hs := u; ms := u; ss := u;
-			md1 := m * 3 DIV 4; sd0 := 0; sd1 := 3 * u
-		END;
-		time := v.time;
-		f.DrawOval(0, 0, d, d, u, color);
-		DrawTick(f, m, 0, m * 4 DIV 6, hs, time.hour MOD 12 * 5 + time.minute DIV 12, color);
-		DrawTick(f, m, 0, md1, ms, time.minute, color);
-		DrawTick(f, m, sd0, sd1, ss, time.second, color)
-	END Restore;
-
-	PROCEDURE (v: StdView) HandleModelMsg (VAR msg: Models.Message);
-		VAR w, h: INTEGER;
-	BEGIN
-		WITH msg: Msg DO
-			msg.consumed := TRUE;
-			IF v.time.second # msg.time.second THEN	(* execute only once per view *)
-				Views.Update(v, Views.keepFrames);
-				v.time := msg.time
-			END
-		ELSE
-		END
-	END HandleModelMsg;
-
-	PROCEDURE SizePref (v: StdView; VAR p: Properties.SizePref);
-	BEGIN
-		IF (p.w > Views.undefined) & (p.h > Views.undefined) THEN
-			Properties.ProportionalConstraint(1, 1, p.fixedW, p.fixedH, p.w, p.h);
-			IF p.w < minSize THEN p.w := minSize; p.h := minSize END
-		ELSE
-			p.w := niceSize; p.h := niceSize
-		END
-	END SizePref;
-
-	PROCEDURE (v: StdView) HandlePropMsg (VAR msg: Properties.Message);
-	BEGIN
-		WITH msg: Properties.Preference DO
-			WITH msg: Properties.SizePref DO
-				SizePref(v, msg)
-			ELSE
-			END
-		ELSE
-		END
-	END HandlePropMsg;
-
-
-	(** allocation **)
-
-	PROCEDURE New* (): Views.View;
-		VAR v: StdView;
-	BEGIN
-		NEW(v); v.time.second := -1; RETURN v
-	END New;
-
-	PROCEDURE Deposit*;
-	BEGIN
-		Views.Deposit(New())
-	END Deposit;
-
-
-BEGIN
-	clockTime.second := -1;
-	NEW(action); actionIsAlive := FALSE
-CLOSE
-	IF actionIsAlive THEN Services.RemoveAction(action) END
-END StdClocks.

BlackBox/Std/Mod/Cmds.txt

@@ -1,1016 +0,0 @@
-MODULE StdCmds;
-
-	(* THIS IS TEXT COPY OF BlackBox 1.6-rc6 Std/Mod/Cmds.odc *)
-	(* DO NOT EDIT *)
-
-	IMPORT
-		Fonts, Ports, Services, Stores, Sequencers, Models, Views,
-		Controllers, Containers, Properties, Dialog, Documents, Windows, Strings,
-		StdDialog, StdApi;
-
-	CONST
-		illegalSizeKey = "#System:IllegalFontSize";
-		defaultAllocator = "TextViews.Deposit; StdCmds.Open";
-
-		(* wType, hType *)
-		fix = 0; page = 1; window = 2;
-
-	VAR
-		size*: RECORD 
-			size*: INTEGER
-		END;
-		layout*: RECORD
-			wType*, hType*: INTEGER;
-			width*, height*: REAL;
-			doc: Documents.Document;
-			u: INTEGER
-		END;
-		allocator*: Dialog.String;
-		
-		propEra: INTEGER;	(* (propEra, props) form cache for StdProps() *)
-		props: Properties.StdProp;	(* valid iff propEra = Props.era *)
-		
-		prop: Properties.Property;	(* usef for copy/paste properties *)
-
-	(* auxiliary procedures *)
-	
-	PROCEDURE StdProp (): Properties.StdProp;
-	BEGIN
-		IF propEra # Properties.era THEN
-			Properties.CollectStdProp(props);
-			propEra := Properties.era
-		END;
-		RETURN props
-	END StdProp;
-
-	PROCEDURE Append (VAR s: ARRAY OF CHAR; t: ARRAY OF CHAR);
-		VAR len, i, j: INTEGER; ch: CHAR;
-	BEGIN
-		len := LEN(s);
-		i := 0; WHILE s[i] # 0X DO INC(i) END;
-		j := 0; REPEAT ch := t[j]; s[i] := ch; INC(j); INC(i) UNTIL (ch = 0X) OR (i = len);
-		s[len - 1] := 0X
-	END Append;	
-
-	(* standard commands *)
-
-	PROCEDURE OpenAuxDialog* (file, title: ARRAY OF CHAR);
-		VAR v: Views.View;
-	BEGIN
-		StdApi.OpenAuxDialog(file, title, v)
-	END OpenAuxDialog;
-
-	PROCEDURE OpenToolDialog* (file, title: ARRAY OF CHAR);
-		VAR v: Views.View;
-	BEGIN
-		StdApi.OpenToolDialog(file, title, v)
-	END OpenToolDialog;
-
-	PROCEDURE OpenDoc* (file: ARRAY OF CHAR);
-		VAR v: Views.View;
-	BEGIN
-		StdApi.OpenDoc(file, v)
-	END OpenDoc;
-	
-	PROCEDURE OpenCopyOf* (file: ARRAY OF CHAR);
-		VAR v: Views.View;
-	BEGIN
-		StdApi.OpenCopyOf(file, v)
-	END OpenCopyOf;
-	
-	PROCEDURE OpenAux* (file, title: ARRAY OF CHAR);
-		VAR v: Views.View; 
-	BEGIN
-		StdApi.OpenAux(file, title, v)
-	END OpenAux;
-
-	PROCEDURE OpenBrowser* (file, title: ARRAY OF CHAR);
-		VAR v: Views.View;
-	BEGIN
-		StdApi.OpenBrowser(file, title, v)
-	END OpenBrowser;
-
-	PROCEDURE CloseDialog*;
-		VAR v: Views.View;
-	BEGIN
-		StdApi.CloseDialog(v)
-	END CloseDialog;
-
-
-	PROCEDURE Open*;
-		VAR i: INTEGER; v: Views.View;
-	BEGIN
-		i := Views.Available();
-		IF i > 0 THEN Views.Fetch(v); Views.OpenView(v)
-		ELSE Dialog.ShowMsg("#System:DepositExpected")
-		END
-	END Open;
-
-	PROCEDURE PasteView*;
-		VAR i: INTEGER; v: Views.View;
-	BEGIN
-		i := Views.Available();
-		IF i > 0 THEN
-			Views.Fetch(v);
-			Controllers.PasteView(v, Views.undefined, Views.undefined, FALSE)
-		ELSE Dialog.ShowMsg("#System:DepositExpected")
-		END
-	END PasteView;
-	
-	(* file menu commands *)
-	
-	PROCEDURE New*;
-		VAR res: INTEGER;
-	BEGIN
-		Dialog.Call(allocator, " ", res)
-	END New;
-	
-	
-	(* edit menu commands *)
-	
-	PROCEDURE Undo*;
-		VAR w: Windows.Window;
-	BEGIN
-		w := Windows.dir.Focus(Controllers.frontPath);
-		IF w # NIL THEN w.seq.Undo END
-	END Undo;
-
-	PROCEDURE Redo*;
-		VAR w: Windows.Window;
-	BEGIN
-		w := Windows.dir.Focus(Controllers.frontPath);
-		IF w # NIL THEN w.seq.Redo END
-	END Redo;
-
-	PROCEDURE CopyProp*;
-	BEGIN
-		Properties.CollectProp(prop)
-	END CopyProp;
-	
-	PROCEDURE PasteProp*;
-	BEGIN
-		Properties.EmitProp(NIL, prop)
-	END PasteProp;
-	
-	PROCEDURE Clear*;
-	(** remove the selection of the current focus **)
-		VAR msg: Controllers.EditMsg;
-	BEGIN
-		msg.op := Controllers.cut; msg.view := NIL;
-		msg.clipboard := FALSE;
-		Controllers.Forward(msg)
-	END Clear;
-
-	PROCEDURE SelectAll*;
-	(** select whole content of current focus **)
-		VAR msg: Controllers.SelectMsg;
-	BEGIN
-		msg.set := TRUE; Controllers.Forward(msg)
-	END SelectAll;
-
-	PROCEDURE DeselectAll*;
-	(** select whole content of current focus **)
-		VAR msg: Controllers.SelectMsg;
-	BEGIN
-		msg.set := FALSE; Controllers.Forward(msg)
-	END DeselectAll;
-
-	PROCEDURE SelectDocument*;
-	(** select whole document **)
-		VAR w: Windows.Window; c: Containers.Controller;
-	BEGIN
-		w := Windows.dir.Focus(Controllers.path);
-		IF w # NIL THEN
-			c := w.doc.ThisController();
-			IF (c # NIL) & ~(Containers.noSelection IN c.opts) & (c.Singleton() = NIL) THEN
-				c.SetSingleton(w.doc.ThisView())
-			END
-		END
-	END SelectDocument;
-
-	PROCEDURE SelectNextView*;
-		VAR c: Containers.Controller; v: Views.View;
-	BEGIN
-		c := Containers.Focus();
-		IF (c # NIL) & ~(Containers.noSelection IN c.opts) THEN
-			IF c.HasSelection() THEN v := c.Singleton() ELSE v := NIL END;
-			IF v = NIL THEN
-				c.GetFirstView(Containers.any, v)
-			ELSE
-				c.GetNextView(Containers.any, v);
-				IF v = NIL THEN c.GetFirstView(Containers.any, v) END
-			END;
-			c.SelectAll(FALSE);
-			IF v # NIL THEN c.SetSingleton(v) END
-		ELSE Dialog.ShowMsg("#Dev:NoTargetFocusFound")
-		END
-	END SelectNextView;
-
-	
-	(** font menu commands **)
-
-	PROCEDURE Font* (typeface: Fonts.Typeface);
-	(** set the selection to the given font family **)
-		VAR p: Properties.StdProp;
-	BEGIN
-		NEW(p); p.valid := {Properties.typeface}; p.typeface := typeface;
-		Properties.EmitProp(NIL, p)
-	END Font;
-
-	PROCEDURE DefaultFont*;
-	(** set the selection to the default font family **)
-		VAR p: Properties.StdProp;
-	BEGIN
-		NEW(p); p.valid := {Properties.typeface}; p.typeface := Fonts.default;
-		Properties.EmitProp(NIL, p)
-	END DefaultFont;
-
-
-	(** attributes menu commands **)
-
-	PROCEDURE Plain*;
-	(** reset the font attribute "weight" and all font style attributes of the selection **)
-		VAR p: Properties.StdProp;
-	BEGIN
-		NEW(p); p.valid := {Properties.style, Properties.weight};
-		p.style.val := {}; p.style.mask := {Fonts.italic, Fonts.underline, Fonts.strikeout};
-		p.weight := Fonts.normal;
-		Properties.EmitProp(NIL, p)
-	END Plain;
-
-	PROCEDURE Bold*;
-	(** change the font attribute "weight" in the selection;
-	if the selection has a homogeneously bold weight: toggle to normal, else force to bold **)
-		VAR p, p0: Properties.StdProp;
-	BEGIN
-		Properties.CollectStdProp(p0);
-		NEW(p); p.valid := {Properties.weight};
-		IF (Properties.weight IN p0.valid) & (p0.weight # Fonts.normal) THEN
-			p.weight := Fonts.normal
-		ELSE p.weight := Fonts.bold
-		END;
-		Properties.EmitProp(NIL, p)
-	END Bold;
-
-	PROCEDURE Italic*;
-	(** change the font style attribute "italic" in the selection;
-	if the selection is homogeneous wrt this attribute: toggle, else force to italic **)
-		VAR p, p0: Properties.StdProp;
-	BEGIN
-		Properties.CollectStdProp(p0);
-		NEW(p); p.valid := {Properties.style}; p.style.mask := {Fonts.italic};
-		IF (Properties.style IN p0.valid) & (Fonts.italic IN p0.style.val) THEN
-			p.style.val := {}
-		ELSE p.style.val := {Fonts.italic}
-		END;
-		Properties.EmitProp(NIL, p)
-	END Italic;
-
-	PROCEDURE Underline*;
-	(** change the font style attribute "underline" in the selection;
-	if the selection is homogeneous wrt this attribute: toggle, else force to underline **)
-		VAR p, p0: Properties.StdProp;
-	BEGIN
-		Properties.CollectStdProp(p0);
-		NEW(p); p.valid := {Properties.style}; p.style.mask := {Fonts.underline};
-		IF (Properties.style IN p0.valid) & (Fonts.underline IN p0.style.val) THEN
-			p.style.val := {}
-		ELSE p.style.val := {Fonts.underline}
-		END;
-		Properties.EmitProp(NIL, p)
-	END Underline;
-
-	PROCEDURE Strikeout*;
-	(** change the font style attribute "strikeout" in the selection,
-	without changing other attributes;
-	if the selection is homogeneous wrt this attribute: toggle,
-	else force to strikeout **)
-		VAR p, p0: Properties.StdProp;
-	BEGIN
-		Properties.CollectStdProp(p0);
-		NEW(p); p.valid := {Properties.style}; p.style.mask := {Fonts.strikeout};
-		IF (Properties.style IN p0.valid) & (Fonts.strikeout IN p0.style.val) THEN
-			p.style.val := {}
-		ELSE p.style.val := {Fonts.strikeout}
-		END;
-		Properties.EmitProp(NIL, p)
-	END Strikeout;
-
-	PROCEDURE Size* (size: INTEGER);
-	(** set the selection to the given font size **)
-		VAR p: Properties.StdProp;
-	BEGIN
-		NEW(p); p.valid := {Properties.size};
-		p.size := size * Ports.point;
-		Properties.EmitProp(NIL, p)
-	END Size;
-
-	PROCEDURE SetSize*;
-		VAR p: Properties.StdProp;
-	BEGIN
-		IF (0 <= size.size) & (size.size < 32768) THEN
-			NEW(p); p.valid := {Properties.size};
-			p.size := size.size * Fonts.point;
-			Properties.EmitProp(NIL, p)
-		ELSE
-			Dialog.ShowMsg(illegalSizeKey)
-		END
-	END SetSize;
-
-	PROCEDURE InitSizeDialog*;
-		VAR p: Properties.StdProp;
-	BEGIN
-		Properties.CollectStdProp(p);
-		IF Properties.size IN p.valid THEN size.size := p.size DIV Fonts.point END
-	END InitSizeDialog;
-
-	PROCEDURE Color* (color: Ports.Color);
-	(** set the color attributes of the selection **)
-		VAR p: Properties.StdProp;
-	BEGIN
-		NEW(p); p.valid := {Properties.color};
-		p.color.val := color;
-		Properties.EmitProp(NIL, p)
-	END Color;
-
-	PROCEDURE UpdateAll*;	(* for HostCmds.Toggle *)
-		VAR w: Windows.Window; pw, ph: INTEGER; dirty: BOOLEAN; msg: Models.UpdateMsg;
-	BEGIN
-		w := Windows.dir.First();
-		WHILE w # NIL DO
-			IF ~w.sub THEN
-				dirty := w.seq.Dirty();
-				Models.Domaincast(w.doc.Domain(), msg);
-				IF ~dirty THEN w.seq.SetDirty(FALSE) END	(* not perfect: "undoable dirt" ... *)
-			END;
-			w.port.GetSize(pw, ph);
-			w.Restore(0, 0, pw, ph);
-			w := Windows.dir.Next(w)
-		END
-	END UpdateAll;
-
-	PROCEDURE RestoreAll*;
-		VAR w: Windows.Window; pw, ph: INTEGER;
-	BEGIN
-		w := Windows.dir.First();
-		WHILE w # NIL DO
-			w.port.GetSize(pw, ph);
-			w.Restore(0, 0, pw, ph);
-			w := Windows.dir.Next(w)
-		END
-	END RestoreAll;
-	
-	
-	(** document layout dialog **)
-	
-	PROCEDURE SetLayout*;
-		VAR opts: SET; l, t, r, b, r0, b0: INTEGER; c: Containers.Controller; script: Stores.Operation;
-	BEGIN
-		c := layout.doc.ThisController();
-		opts := c.opts - {Documents.pageWidth..Documents.winHeight};
-		IF layout.wType = page THEN INCL(opts, Documents.pageWidth)
-		ELSIF layout.wType = window THEN INCL(opts, Documents.winWidth)
-		END;
-		IF layout.hType = page THEN INCL(opts, Documents.pageHeight)
-		ELSIF layout.hType = window THEN INCL(opts, Documents.winHeight)
-		END;
-		layout.doc.PollRect(l, t, r, b); r0 := r; b0 := b;
-		IF layout.wType = fix THEN r := l + SHORT(ENTIER(layout.width * layout.u)) END;
-		IF layout.hType = fix THEN b := t + SHORT(ENTIER(layout.height * layout.u)) END;
-		IF (opts # c.opts) OR (r # r0) OR (b # b0) THEN
-			Views.BeginScript(layout.doc, "#System:ChangeLayout", script);
-			c.SetOpts(opts);
-			layout.doc.SetRect(l, t, r, b);
-			Views.EndScript(layout.doc, script)
-		END
-	END SetLayout;
-	
-	PROCEDURE InitLayoutDialog*;
-	(* guard: WindowGuard *)
-		VAR w: Windows.Window; c: Containers.Controller; l, t, r, b: INTEGER;
-	BEGIN
-		w := Windows.dir.First();
-		IF w # NIL THEN
-			layout.doc := w.doc;
-			c := w.doc.ThisController();
-			IF Documents.pageWidth IN c.opts THEN layout.wType := page
-			ELSIF Documents.winWidth IN c.opts THEN layout.wType := window
-			ELSE layout.wType := fix
-			END;
-			IF Documents.pageHeight IN c.opts THEN layout.hType := page
-			ELSIF Documents.winHeight IN c.opts THEN layout.hType := window
-			ELSE layout.hType := fix
-			END;
-			IF Dialog.metricSystem THEN layout.u := Ports.mm * 10 ELSE layout.u := Ports.inch END;
-			w.doc.PollRect(l, t, r, b);
-			layout.width := (r - l) DIV (layout.u DIV 100) / 100;
-			layout.height := (b - t) DIV (layout.u DIV 100) / 100
-		END
-	END InitLayoutDialog;
-	
-	PROCEDURE WidthGuard* (VAR par: Dialog.Par);
-	BEGIN
-		IF layout.wType # fix THEN par.readOnly := TRUE END
-	END WidthGuard;
-	
-	PROCEDURE HeightGuard* (VAR par: Dialog.Par);
-	BEGIN
-		IF layout.hType # fix THEN par.readOnly := TRUE END
-	END HeightGuard;
-	
-	PROCEDURE TypeNotifier* (op, from, to: INTEGER);
-		VAR w, h, l, t, r, b: INTEGER; d: BOOLEAN;
-	BEGIN
-		layout.doc.PollRect(l, t, r, b);
-		IF layout.wType = page THEN
-			layout.doc.PollPage(w, h, l, t, r, b, d)
-		ELSIF layout.wType = window THEN
-			layout.doc.context.GetSize(w, h); r := w - l
-		END;
-		layout.width := (r - l) DIV (layout.u DIV 100) / 100;
-		layout.doc.PollRect(l, t, r, b);
-		IF layout.hType = page THEN
-			layout.doc.PollPage(w, h, l, t, r, b, d)
-		ELSIF layout.hType = window THEN
-			layout.doc.context.GetSize(w, h); b := h - t
-		END;
-		layout.height := (b - t) DIV (layout.u DIV 100) / 100;
-		Dialog.Update(layout)
-	END TypeNotifier;
-	
-
-	(** window menu command **)
-
-	PROCEDURE NewWindow*;
-	(** guard ModelViewGuard **)
-		VAR win: Windows.Window; doc: Documents.Document; v: Views.View; title: Views.Title;
-			seq: ANYPTR; clean: BOOLEAN;
-	BEGIN
-		win := Windows.dir.Focus(Controllers.frontPath);
-		IF win # NIL THEN
-			v := win.doc.ThisView();
-			IF v.Domain() # NIL THEN seq := v.Domain().GetSequencer() ELSE seq := NIL END;
-			clean := (seq # NIL) & ~seq(Sequencers.Sequencer).Dirty();
-			doc := win.doc.DocCopyOf(v);
-			(* Stores.InitDomain(doc, v.Domain()); *)
-			ASSERT(doc.Domain() = v.Domain(), 100);
-			win.GetTitle(title);
-			Windows.dir.OpenSubWindow(Windows.dir.New(), doc, win.flags, title);
-			IF clean THEN seq(Sequencers.Sequencer).SetDirty(FALSE) END
-		END
-	END NewWindow;
-	
-	(* properties *)
-	
-	PROCEDURE GetCmd (name: ARRAY OF CHAR; OUT cmd: ARRAY OF CHAR);
-		VAR i, j: INTEGER; ch, lch: CHAR; key: ARRAY 256 OF CHAR;
-	BEGIN
-		i := 0; ch := name[0]; key[0] := "#"; j := 1;
-		REPEAT
-			key[j] := ch; INC(j); lch := ch; INC(i); ch := name[i]
-		UNTIL (ch = 0X) OR (ch = ".")
-			OR ((ch >= "A") & (ch <= "Z") OR (ch >= "À") & (ch # "×") & (ch <= "Þ"))
-				& ((lch < "A") OR (lch > "Z") & (lch < "À") OR (lch = "×") OR (lch > "Þ"));
-		IF ch = "." THEN
-			key := "#System:" + name
-		ELSE
-			key[j] := ":"; INC(j); key[j] := 0X; j := 0;
-			WHILE ch # 0X DO name[j] := ch; INC(i); INC(j); ch := name[i] END;
-			name[j] := 0X; key := key + name
-		END;
-		Dialog.MapString(key, cmd);
-		IF cmd = name THEN cmd := "" END
-	END GetCmd;
-	
-	PROCEDURE SearchCmd (call: BOOLEAN; OUT found: BOOLEAN);
-		VAR p: Properties.Property; std: BOOLEAN; v: Views.View;  cmd: ARRAY 256 OF CHAR; pos, res: INTEGER;
-	BEGIN
-		Controllers.SetCurrentPath(Controllers.targetPath);
-		v := Containers.FocusSingleton(); found := FALSE;
-		IF v # NIL THEN
-			Services.GetTypeName(v, cmd);
-			GetCmd(cmd, cmd);
-			IF cmd # "" THEN found := TRUE;
-				IF call THEN Dialog.Call(cmd, "", res) END
-			END
-		END;
-		std := FALSE;
-		Properties.CollectProp(p);
-		WHILE p # NIL DO
-			IF p IS Properties.StdProp THEN std := TRUE
-			ELSE
-				Services.GetTypeName(p, cmd);
-				GetCmd(cmd, cmd);
-				IF cmd # "" THEN found := TRUE;
-					IF call THEN Dialog.Call(cmd, "", res) END
-				ELSE
-					Services.GetTypeName(p, cmd);
-					Strings.Find(cmd, "Desc", LEN(cmd$)-4, pos);
-					IF LEN(cmd$)-4 = pos THEN
-						cmd[pos] := 0X; GetCmd(cmd, cmd);
-						IF cmd # "" THEN found := TRUE;
-							IF call THEN Dialog.Call(cmd, "", res) END
-						END
-					END
-				END
-			END;
-			p := p.next
-		END;
-		IF std & ~found THEN
-			Dialog.MapString("#Host:Properties.StdProp", cmd);
-			IF cmd # "Properties.StdProp" THEN found := TRUE;
-				IF call THEN Dialog.Call(cmd, "", res) END
-			END
-		END;
-		IF ~found THEN
-			Dialog.MapString("#System:ShowProp", cmd);
-			IF cmd # "ShowProp" THEN found := TRUE;
-				IF call THEN Dialog.Call(cmd, "", res) END
-			END
-		END;
-		Controllers.ResetCurrentPath
-	END SearchCmd;
-	
-	PROCEDURE ShowProp*;
-		VAR found: BOOLEAN;
-	BEGIN
-		SearchCmd(TRUE, found)
-	END ShowProp;
-	
-	PROCEDURE ShowPropGuard* (VAR par: Dialog.Par);
-		VAR found: BOOLEAN;
-	BEGIN
-		SearchCmd(FALSE, found);
-		IF ~found THEN par.disabled := TRUE END
-	END ShowPropGuard;
-	
-	
-	(* container commands *)
-	
-	PROCEDURE ActFocus (): Containers.Controller;
-		VAR c: Containers.Controller; v: Views.View;
-	BEGIN
-		c := Containers.Focus();
-		IF c # NIL THEN
-			v := c.ThisView();
-			IF v IS Documents.Document THEN
-				v := v(Documents.Document).ThisView();
-				IF v IS Containers.View THEN
-					c := v(Containers.View).ThisController()
-				ELSE c := NIL
-				END
-			END
-		END;
-		RETURN c
-	END ActFocus;
-
-	PROCEDURE ToggleNoFocus*;
-		VAR c: Containers.Controller; v: Views.View;
-	BEGIN
-		c := ActFocus();
-		IF c # NIL THEN
-			v := c.ThisView();
-			IF ~((v IS Documents.Document) OR (Containers.noSelection IN c.opts)) THEN
-				IF Containers.noFocus IN c.opts THEN
-					c.SetOpts(c.opts - {Containers.noFocus})
-				ELSE
-					c.SetOpts(c.opts + {Containers.noFocus})
-				END
-			END
-		END
-	END ToggleNoFocus;
-
-	PROCEDURE OpenAsAuxDialog*;
-	(** create a new sub-window onto the focus view shown in the top window, mask mode **)
-		VAR win: Windows.Window; doc: Documents.Document; v, u: Views.View; title: Views.Title;
-			c: Containers.Controller;
-	BEGIN
-		v := Controllers.FocusView();
-		IF (v # NIL) & (v IS Containers.View) & ~(v IS Documents.Document) THEN
-			win := Windows.dir.Focus(Controllers.frontPath); ASSERT(win # NIL, 100);
-			doc := win.doc.DocCopyOf(v);
-			u := doc.ThisView();
-			c := u(Containers.View).ThisController();
-			c.SetOpts(c.opts - {Containers.noFocus} + {Containers.noCaret, Containers.noSelection});
-			IF v # win.doc.ThisView() THEN
-				c := doc.ThisController();
-				c.SetOpts(c.opts - {Documents.pageWidth, Documents.pageHeight}
-										+ {Documents.winWidth, Documents.winHeight})
-			END;
-			(* Stores.InitDomain(doc, v.Domain()); already done in DocCopyOf *)
-			win.GetTitle(title);
-			Windows.dir.OpenSubWindow(Windows.dir.New(), doc,
-	{Windows.isAux, Windows.neverDirty, Windows.noResize, Windows.noHScroll, Windows.noVScroll},
-															title)
-		ELSE Dialog.Beep
-		END
-	END OpenAsAuxDialog;
-
-	PROCEDURE OpenAsToolDialog*;
-	(** create a new sub-window onto the focus view shown in the top window, mask mode **)
-		VAR win: Windows.Window; doc: Documents.Document; v, u: Views.View; title: Views.Title;
-			c: Containers.Controller;
-	BEGIN
-		v := Controllers.FocusView();
-		IF (v # NIL) & (v IS Containers.View) & ~(v IS Documents.Document) THEN
-			win := Windows.dir.Focus(Controllers.frontPath); ASSERT(win # NIL, 100);
-			doc := win.doc.DocCopyOf(v);
-			u := doc.ThisView();
-			c := u(Containers.View).ThisController();
-			c.SetOpts(c.opts - {Containers.noFocus} + {Containers.noCaret, Containers.noSelection});
-			IF v # win.doc.ThisView() THEN
-				c := doc.ThisController();
-				c.SetOpts(c.opts - {Documents.pageWidth, Documents.pageHeight}
-										+ {Documents.winWidth, Documents.winHeight})
-			END;
-			(* Stores.InitDomain(doc, v.Domain()); already done in DocCopyOf *)
-			win.GetTitle(title);
-			Windows.dir.OpenSubWindow(Windows.dir.New(), doc,
-	{Windows.isTool, Windows.neverDirty, Windows.noResize, Windows.noHScroll, Windows.noVScroll},
-															title)
-		ELSE Dialog.Beep
-		END
-	END OpenAsToolDialog;
-
-	PROCEDURE RecalcFocusSize*;
-		VAR c: Containers.Controller; v: Views.View; bounds: Properties.BoundsPref;
-	BEGIN
-		c := Containers.Focus();
-		IF c # NIL THEN
-			v := c.ThisView();
-			bounds.w := Views.undefined; bounds.h := Views.undefined;
-			Views.HandlePropMsg(v, bounds);
-			v.context.SetSize(bounds.w, bounds.h)
-		END
-	END RecalcFocusSize;
-
-	PROCEDURE RecalcAllSizes*;
-		VAR w: Windows.Window;
-	BEGIN
-		w := Windows.dir.First();
-		WHILE w # NIL DO
-			StdDialog.RecalcView(w.doc.ThisView());
-			w := Windows.dir.Next(w)
-		END
-	END RecalcAllSizes;
-	
-	PROCEDURE SetMode(opts: SET);
-		VAR 
-			c: Containers.Controller; v: Views.View; 
-			gm: Containers.GetOpts; sm: Containers.SetOpts;
-			w: Windows.Window;
-	BEGIN
-		c := Containers.Focus();
-		gm.valid := {};
-		IF (c # NIL) & (c.Singleton() # NIL) THEN
-			v := c.Singleton();
-			Views.HandlePropMsg(v, gm);
-		END;
-		IF gm.valid = {} THEN
-			w := Windows.dir.Focus(Controllers.path);
-			IF (w # NIL) & (w.doc.ThisView() IS Containers.View) THEN v := w.doc.ThisView() ELSE v := NIL END
-		END;
-		IF v # NIL THEN
-			sm.valid := {Containers.noSelection, Containers.noFocus, Containers.noCaret};
-			sm.opts := opts;
-			Views.HandlePropMsg(v, sm);
-		END;
-	END SetMode;
-	
-	PROCEDURE GetMode(OUT found: BOOLEAN; OUT opts: SET);
-		VAR c: Containers.Controller; gm: Containers.GetOpts; w: Windows.Window;
-	BEGIN
-		c := Containers.Focus();
-		gm.valid := {};
-		IF (c # NIL) & (c.Singleton() # NIL) THEN
-			Views.HandlePropMsg(c.Singleton(), gm);
-		END;
-		IF gm.valid = {}  THEN
-			w := Windows.dir.Focus(Controllers.path);
-			IF (w # NIL) & (w.doc.ThisView() IS Containers.View) THEN
-				Views.HandlePropMsg(w.doc.ThisView(), gm);
-			END
-		END;
-		found := gm.valid # {};
-		opts := gm.opts
-	END GetMode;
-	
-	PROCEDURE SetMaskMode*;
-	(* Guard: SetMaskGuard *)
-	BEGIN
-		SetMode({Containers.noSelection, Containers.noCaret})
-	END SetMaskMode;
-
-	PROCEDURE SetEditMode*;
-	(* Guard: SetEditGuard *)
-	BEGIN
-		SetMode({})
-	END SetEditMode;
-
-	PROCEDURE SetLayoutMode*;
-	(* Guard: SetLayoutGuard *)
-	BEGIN
-		SetMode({Containers.noFocus})
-	END SetLayoutMode;
-
-	PROCEDURE SetBrowserMode*;
-	(* Guard: SetBrowserGuard *)
-	BEGIN
-		SetMode({Containers.noCaret})
-	END SetBrowserMode;
-
-
-	(* standard guards *)
-	
-	PROCEDURE ToggleNoFocusGuard* (VAR par: Dialog.Par);
-		VAR c: Containers.Controller; v: Views.View;
-	BEGIN
-		c := ActFocus();
-		IF c # NIL THEN
-			v := c.ThisView();
-			IF ~((v IS Documents.Document) OR (Containers.noSelection IN c.opts)) THEN
-				IF Containers.noFocus IN c.opts THEN par.label := "#System:AllowFocus"
-				ELSE par.label := "#System:PreventFocus"
-				END
-			ELSE par.disabled := TRUE
-			END
-		ELSE par.disabled := TRUE
-		END
-	END ToggleNoFocusGuard;
-
-	PROCEDURE ReadOnlyGuard* (VAR par: Dialog.Par);
-	BEGIN
-		par.readOnly := TRUE
-	END ReadOnlyGuard;
-	
-	PROCEDURE WindowGuard* (VAR par: Dialog.Par);
-		VAR w: Windows.Window;
-	BEGIN
-		w := Windows.dir.First();
-		IF w = NIL THEN par.disabled := TRUE END
-	END WindowGuard;
-
-	PROCEDURE ModelViewGuard* (VAR par: Dialog.Par);
-		VAR w: Windows.Window;
-	BEGIN
-		w := Windows.dir.Focus(Controllers.frontPath);
-		par.disabled := (w = NIL) OR (w.doc.ThisView().ThisModel() = NIL)
-	END ModelViewGuard;
-
-	PROCEDURE SetMaskModeGuard* (VAR par: Dialog.Par);
-		CONST mode = {Containers.noSelection, Containers.noFocus, Containers.noCaret};
-		VAR opts: SET; found: BOOLEAN;
-	BEGIN
-		GetMode(found, opts);
-		IF found THEN
-			par.checked := opts * mode = {Containers.noSelection, Containers.noCaret}
-		ELSE
-			par.disabled := TRUE
-		END
-	END SetMaskModeGuard;
-
-	PROCEDURE SetEditModeGuard* (VAR par: Dialog.Par);
-		CONST mode = {Containers.noSelection, Containers.noFocus, Containers.noCaret};
-		VAR opts: SET; found: BOOLEAN;
-	BEGIN
-		GetMode(found, opts);
-		IF found THEN
-			par.checked := opts * mode = {}
-		ELSE
-			par.disabled := TRUE
-		END
-	END SetEditModeGuard;
-
-	PROCEDURE SetLayoutModeGuard* (VAR par: Dialog.Par);
-		CONST mode = {Containers.noSelection, Containers.noFocus, Containers.noCaret};
-		VAR opts: SET; found: BOOLEAN;
-	BEGIN
-		GetMode(found, opts);
-		IF found THEN
-			par.checked := opts * mode = {Containers.noFocus}
-		ELSE
-			par.disabled := TRUE
-		END
-	END SetLayoutModeGuard;
-
-	PROCEDURE SetBrowserModeGuard* (VAR par: Dialog.Par);
-		CONST mode = {Containers.noSelection, Containers.noFocus, Containers.noCaret};
-		VAR opts: SET; found: BOOLEAN;
-	BEGIN
-		GetMode(found, opts);
-		IF found THEN
-			par.checked := opts * mode = {Containers.noCaret}
-		ELSE
-			par.disabled := TRUE
-		END
-	END SetBrowserModeGuard;
-
-	PROCEDURE SelectionGuard* (VAR par: Dialog.Par);
-		VAR ops: Controllers.PollOpsMsg;
-	BEGIN
-		Controllers.PollOps(ops);
-		IF ops.valid * {Controllers.cut, Controllers.copy} = {} THEN par.disabled := TRUE END
-	END SelectionGuard;
-
-	PROCEDURE SingletonGuard* (VAR par: Dialog.Par);
-		VAR ops: Controllers.PollOpsMsg;
-	BEGIN
-		Controllers.PollOps(ops);
-		IF ops.singleton = NIL THEN par.disabled := TRUE END
-	END SingletonGuard;
-	
-	PROCEDURE SelectAllGuard* (VAR par: Dialog.Par);
-		VAR ops: Controllers.PollOpsMsg;
-	BEGIN
-		Controllers.PollOps(ops);
-		IF ~ops.selectable THEN par.disabled := TRUE END
-	END SelectAllGuard;
-
-	PROCEDURE CaretGuard* (VAR par: Dialog.Par);
-		VAR ops: Controllers.PollOpsMsg;
-	BEGIN
-		Controllers.PollOps(ops);
-		IF ops.valid * {Controllers.pasteChar .. Controllers.paste} = {} THEN par.disabled := TRUE END
-	END CaretGuard;
-
-	PROCEDURE PasteCharGuard* (VAR par: Dialog.Par);
-		VAR ops: Controllers.PollOpsMsg;
-	BEGIN
-		Controllers.PollOps(ops);
-		IF ~(Controllers.pasteChar IN ops.valid) THEN par.disabled := TRUE END
-	END PasteCharGuard;
-
-	PROCEDURE PasteLCharGuard* (VAR par: Dialog.Par);
-		VAR ops: Controllers.PollOpsMsg;
-	BEGIN
-		Controllers.PollOps(ops);
-		IF ~(Controllers.pasteChar IN ops.valid) THEN par.disabled := TRUE END
-	END PasteLCharGuard;
-
-	PROCEDURE PasteViewGuard* (VAR par: Dialog.Par);
-		VAR ops: Controllers.PollOpsMsg;
-	BEGIN
-		Controllers.PollOps(ops);
-		IF ~(Controllers.paste IN ops.valid) THEN par.disabled := TRUE END
-	END PasteViewGuard;
-	
-	PROCEDURE ContainerGuard* (VAR par: Dialog.Par);
-	BEGIN
-		IF Containers.Focus() = NIL THEN par.disabled := TRUE END
-	END ContainerGuard;
-	
-	PROCEDURE UndoGuard* (VAR par: Dialog.Par);
-		VAR f: Windows.Window; opName: Stores.OpName;
-	BEGIN
-		Dialog.MapString("#System:Undo", par.label);
-		f := Windows.dir.Focus(Controllers.frontPath);
-		IF (f # NIL) & f.seq.CanUndo() THEN
-			f.seq.GetUndoName(opName);
-			Dialog.MapString(opName, opName);
-			Append(par.label, " ");
-			Append(par.label, opName)
-		ELSE
-			par.disabled := TRUE
-		END
-	END UndoGuard;
-
-	PROCEDURE RedoGuard* (VAR par: Dialog.Par);
-		VAR f: Windows.Window; opName: Stores.OpName;
-	BEGIN
-		Dialog.MapString("#System:Redo", par.label);
-		f := Windows.dir.Focus(Controllers.frontPath);
-		IF (f # NIL) & f.seq.CanRedo() THEN
-			f.seq.GetRedoName(opName);
-			Dialog.MapString(opName, opName);
-			Append(par.label, " ");
-			Append(par.label, opName)
-		ELSE
-			par.disabled := TRUE
-		END
-	END RedoGuard;
-	
-	PROCEDURE PlainGuard* (VAR par: Dialog.Par);
-		VAR props: Properties.StdProp;
-	BEGIN
-		props := StdProp();
-		IF props.known * {Properties.style, Properties.weight} # {} THEN
-			par.checked := (Properties.style IN props.valid)
-				& (props.style.val = {}) & ({Fonts.italic, Fonts.underline, Fonts.strikeout} - props.style.mask = {})
-				& (Properties.weight IN props.valid) & (props.weight = Fonts.normal)
-		ELSE
-			par.disabled := TRUE
-		END
-	END PlainGuard;
-
-	PROCEDURE BoldGuard* (VAR par: Dialog.Par);
-		VAR props: Properties.StdProp;
-	BEGIN
-		props := StdProp();
-		IF Properties.weight IN props.known THEN
-			par.checked := (Properties.weight IN props.valid) & (props.weight = Fonts.bold)
-		ELSE
-			par.disabled := TRUE
-		END
-	END BoldGuard;
-
-	PROCEDURE ItalicGuard* (VAR par: Dialog.Par);
-		VAR props: Properties.StdProp;
-	BEGIN
-		props := StdProp();
-		IF Properties.style IN props.known THEN
-			par.checked := (Properties.style IN props.valid) & (Fonts.italic IN props.style.val)
-		ELSE
-			par.disabled := TRUE
-		END
-	END ItalicGuard;
-
-	PROCEDURE UnderlineGuard* (VAR par: Dialog.Par);
-		VAR props: Properties.StdProp;
-	BEGIN
-		props := StdProp();
-		IF Properties.style IN props.known THEN
-			par.checked := (Properties.style IN props.valid) & (Fonts.underline IN props.style.val)
-		ELSE
-			par.disabled := TRUE
-		END
-	END UnderlineGuard;
-
-	PROCEDURE StrikeoutGuard* (VAR par: Dialog.Par);
-		VAR props: Properties.StdProp;
-	BEGIN
-		props := StdProp();
-		IF Properties.style IN props.known THEN
-			par.checked := (Properties.style IN props.valid) & (Fonts.strikeout IN props.style.val)
-		ELSE
-			par.disabled := TRUE
-		END
-	END StrikeoutGuard;
-
-	PROCEDURE SizeGuard* (size: INTEGER; VAR par: Dialog.Par);
-		VAR props: Properties.StdProp;
-	BEGIN
-		props := StdProp();
-		IF Properties.size IN props.known THEN
-			par.checked := (Properties.size IN props.valid) & (size = props.size DIV Ports.point)
-		ELSE
-			par.disabled := TRUE
-		END
-	END SizeGuard;
-
-	PROCEDURE ColorGuard* (color: INTEGER; VAR par: Dialog.Par);
-		VAR props: Properties.StdProp;
-	BEGIN
-		props := StdProp();
-		IF Properties.color IN props.known THEN
-			par.checked := (Properties.color IN props.valid) & (color = props.color.val)
-		ELSE
-			par.disabled := TRUE
-		END
-	END ColorGuard;
-	
-	PROCEDURE DefaultFontGuard* (VAR par: Dialog.Par);
-		VAR props: Properties.StdProp;
-	BEGIN
-		props := StdProp();
-		IF Properties.typeface IN props.known THEN
-			par.checked := (Properties.typeface IN props.valid) & (props.typeface = Fonts.default)
-		ELSE
-			par.disabled := TRUE
-		END
-	END DefaultFontGuard;
-
-	PROCEDURE TypefaceGuard* (VAR par: Dialog.Par);
-		VAR props: Properties.StdProp;
-	BEGIN
-		props := StdProp();
-		IF ~(Properties.typeface IN props.known) THEN par.disabled := TRUE END
-	END TypefaceGuard;
-
-	
-	(* standard notifiers *)
-	
-	PROCEDURE DefaultOnDoubleClick* (op, from, to: INTEGER);
-		VAR  msg: Controllers.EditMsg; c: Containers.Controller;
-	BEGIN
-		IF (op = Dialog.pressed) & (from = 1) THEN
-			Controllers.SetCurrentPath(Controllers.frontPath);
-			c := Containers.Focus();
-			Controllers.ResetCurrentPath;
-			IF {Containers.noSelection, Containers.noCaret} - c.opts = {} THEN
-				msg.op := Controllers.pasteChar;
-				msg.char := 0DX; msg.modifiers := {};
-				Controllers.ForwardVia(Controllers.frontPath, msg)
-			END
-		END
-	END DefaultOnDoubleClick;
-
-
-	PROCEDURE Init;
-	BEGIN
-		allocator := defaultAllocator;
-		propEra := -1
-	END Init;
-
-BEGIN
-	Init
-END StdCmds.

BlackBox/Std/Mod/Coder.txt

@@ -1,682 +0,0 @@
-MODULE StdCoder;
-
-	(* THIS IS TEXT COPY OF BlackBox 1.6-rc6 Std/Mod/Coder.odc *)
-	(* DO NOT EDIT *)
-
-	IMPORT
-		Kernel, Files, Converters, Stores, Views, Controllers, Dialog, Documents, Windows,
-		TextModels, TextViews, TextControllers, TextMappers,
-		StdCmds;
-
-	CONST
-		N = 16384;
-		LineLength = 74;
-		OldVersion = 0; ThisVersion = 1;
-		Tag = "StdCoder.Decode";	(* first letter of Tag must not to appear within Tag again *)
-		Separator = "/";
-		View = 1; File = 2; List = 3;
-
-	TYPE
-		FileList = POINTER TO RECORD
-			next: FileList;
-			file: Files.File;
-			type: Files.Type;
-			name:Dialog.String
-		END;
-
-		ParList* = RECORD
-			list*: Dialog.Selection;
-			storeAs*: Dialog.String;
-			files: FileList
-		END;
-
-	VAR
-		par*: ParList;
-		code: ARRAY 64 OF CHAR;
-		revCode: ARRAY 256 OF BYTE;
-		table: ARRAY N OF BYTE;
-		stdDocuType: Files.Type;
-
-	PROCEDURE NofSelections(IN list: Dialog.Selection): INTEGER;
-		VAR i, n: INTEGER;
-	BEGIN
-		i := 0; n := 0;
-		WHILE i # list.len DO
-			IF list.In(i) THEN INC(n) END;
-			INC(i)
-		END;
-		RETURN n
-	END NofSelections;
-
-	PROCEDURE ShowError(n: INTEGER; par: ARRAY OF CHAR);
-	BEGIN
-		Dialog.Beep;
-		CASE n OF
-		 1: Dialog.ShowParamMsg("#Std:bad characters", par, "", "")
-		| 2: Dialog.ShowParamMsg("#Std:checksum error", par, "", "")
-		| 3: Dialog.ShowParamMsg("#Std:incompatible version", par, "", "")
-		| 4: Dialog.ShowParamMsg("#Std:filing error", par, "", "")
-		| 5: Dialog.ShowParamMsg("#Std:directory ^0 not found", par, "", "")
-		| 6: Dialog.ShowParamMsg("#Std:file ^0 not found", par, "", "")
-		| 7: Dialog.ShowParamMsg("#Std:illegal path", par, "", "")
-		| 8: Dialog.ShowParamMsg("#Std:no tag", par, "", "")
-		| 9: Dialog.ShowParamMsg("#Std:disk write protected", par, "", "")
-		| 10: Dialog.ShowParamMsg("#Std:io error", par, "", "")
-		END
-	END ShowError;
-
-	PROCEDURE ShowSizeMsg(x: INTEGER);
-		VAR i, j: INTEGER; ch: CHAR; s: ARRAY 20 OF CHAR;
-	BEGIN
-		ASSERT(x >= 0, 20);
-		i := 0;
-		REPEAT s[i] := CHR(ORD("0") + x MOD 10); INC(i); x := x DIV 10 UNTIL x = 0;
-		s[i] := 0X;
-		DEC(i); j := 0;
-		WHILE j < i DO ch := s[j]; s[j] := s[i]; s[i] := ch; INC(j); DEC(i) END;
-		Dialog.ShowParamStatus("#Std:^0 characters coded", s, "", "")
-	END ShowSizeMsg;
-
-	PROCEDURE Write(dest: TextModels.Writer; x: INTEGER; VAR n: INTEGER);
-	BEGIN
-		dest.WriteChar(code[x]); INC(n);
-		IF n = LineLength THEN dest.WriteChar(0DX); dest.WriteChar(" "); n := 0 END
-	END Write;
-
-	PROCEDURE WriteHeader(dest: TextModels.Writer; VAR n: INTEGER;
-		name: ARRAY OF CHAR; type: BYTE
-	);
-		VAR byte, bit, i: INTEGER; ch: CHAR; tag: ARRAY 16 OF CHAR;
-	BEGIN
-		tag := Tag; i := 0; ch := tag[0];
-		WHILE ch # 0X DO dest.WriteChar(ch); INC(n); INC(i); ch := tag[i] END;
-		dest.WriteChar(" "); INC(n);
-		bit := 0; byte := 0; i := 0;
-		REPEAT
-			ch := name[i]; INC(byte, ASH(ORD(ch), bit)); INC(bit, 8);
-			WHILE bit >= 6 DO Write(dest, byte MOD 64, n); byte := byte DIV 64; DEC(bit, 6) END;
-			INC(i)
-		UNTIL ch = 0X;
-		IF bit # 0 THEN Write(dest, byte, n) END;
-		Write(dest, ThisVersion, n); Write(dest, type, n)
-	END WriteHeader;
-
-	PROCEDURE WriteFileType(dest: TextModels.Writer; VAR n: INTEGER; t: Files.Type);
-		VAR byte, bit, i: INTEGER; ch: CHAR;
-	BEGIN
-		IF t = Kernel.docType THEN t := stdDocuType END;
-		bit := 0; byte := 0; i := 0; dest.WriteChar(" ");
-		REPEAT
-			ch := t[i]; INC(byte, ASH(ORD(ch), bit)); INC(bit, 8);
-			WHILE bit >= 6 DO Write(dest, byte MOD 64, n); byte := byte DIV 64; DEC(bit, 6) END;
-			INC(i)
-		UNTIL ch = 0X;
-		IF bit # 0 THEN Write(dest, byte, n) END
-	END WriteFileType;
-
-	PROCEDURE WriteFile(dest: TextModels.Writer; VAR n: INTEGER; f: Files.File);
-		VAR hash, byte, bit, i, j, sum, len: INTEGER; src: Files.Reader; b: BYTE;
-	BEGIN
-		len := f.Length(); j := len; i := 6;
-		WHILE i # 0 DO Write(dest, j MOD 64, n); j := j DIV 64; DEC(i) END;
-		i := 0;
-		REPEAT table[i] := 0; INC(i) UNTIL i = N;
-		hash := 0; bit := 0; byte := 0; sum := 0; src := f.NewReader(NIL);
-		WHILE len # 0 DO
-			src.ReadByte(b); DEC(len);
-			sum := (sum + b MOD 256) MOD (16 * 1024);
-			IF table[hash] = b THEN INC(bit)	(* 0 bit for correct prediction *)
-			ELSE	(* Incorrect prediction -> 1'xxxx'xxxx bits *)
-				table[hash] := b; INC(byte, ASH(1, bit)); INC(bit);
-				INC(byte, ASH(b MOD 256, bit)); INC(bit, 8)
-			END;
-			WHILE bit >= 6 DO Write(dest, byte MOD 64, n); byte := byte DIV 64; DEC(bit, 6) END;
-			hash := (16 * hash + b MOD 256) MOD N
-		END;
-		IF bit # 0 THEN Write(dest, byte, n) END;
-		i := 6;
-		WHILE i # 0 DO Write(dest, sum MOD 64, n); sum := sum DIV 64; DEC(i) END;
-		IF n # 0 THEN dest.WriteChar(0DX); n := 0 END
-	END WriteFile;
-
-	PROCEDURE Read(src: TextModels.Reader; VAR x: INTEGER; VAR res: INTEGER);
-		VAR ch: CHAR;
-	BEGIN
-		IF res = 0 THEN
-			REPEAT src.ReadChar(ch); x := revCode[ORD(ch)] UNTIL (x >= 0) OR src.eot;
-			IF src.eot THEN res := 1 END
-		END;
-		IF res # 0 THEN x := 0 END
-	END Read;
-
-	PROCEDURE ReadHeader(src: TextModels.Reader; VAR res: INTEGER;
-		VAR name: ARRAY OF CHAR; VAR type: BYTE
-	);
-		VAR x, bit, i, j: INTEGER; ch: CHAR; tag: ARRAY 16 OF CHAR;
-	BEGIN
-		tag := Tag; i := 0;
-		WHILE ~src.eot & (tag[i] # 0X) DO
-			src.ReadChar(ch);
-			IF ch = tag[i] THEN INC(i) ELSIF ch = tag[0] THEN i := 1 ELSE i := 0 END
-		END;
-		IF ~src.eot THEN
-			res := 0; i := 0; bit := 0; x := 0;
-			REPEAT
-				WHILE (res = 0) & (bit < 8) DO Read(src, j, res); INC(x, ASH(j, bit)); INC(bit, 6) END;
-				IF res = 0 THEN
-					ch := CHR(x MOD 256); x := x DIV 256; DEC(bit, 8); name[i] := ch; INC(i)
-				END
-			UNTIL (res # 0) OR (ch = 0X);
-			Read(src, j, res);
-			IF res = 0 THEN
-				IF (j = ThisVersion) OR (j = OldVersion) THEN
-					Read(src, j, res); type := SHORT(SHORT(j))
-				ELSE res := 3
-				END
-			END
-		ELSE res := 8
-		END
-	END ReadHeader;
-
-	PROCEDURE ReadFileType(src: TextModels.Reader; VAR res: INTEGER; VAR ftype: Files.Type);
-		VAR x, bit, i, j: INTEGER; ch: CHAR;
-	BEGIN
-		res := 0; i := 0; bit := 0; x := 0;
-		REPEAT
-			WHILE (res = 0) & (bit < 8) DO Read(src, j, res); INC(x, ASH(j, bit)); INC(bit, 6) END;
-			IF res = 0 THEN ch := CHR(x MOD 256); x := x DIV 256; DEC(bit, 8); ftype[i] := ch; INC(i) END
-		UNTIL (res # 0) OR (ch = 0X);
-		IF ftype = stdDocuType THEN ftype := Kernel.docType END
-	END ReadFileType;
-
-	PROCEDURE ReadFile(src: TextModels.Reader; VAR res: INTEGER; f: Files.File);
-		VAR hash, x, bit, i, j, len, sum, s: INTEGER; byte: BYTE; dest: Files.Writer;
-	BEGIN
-		res := 0; i := 0; len := 0;
-		REPEAT Read(src, x, res); len := len + ASH(x, 6 * i); INC(i) UNTIL (res # 0) OR (i = 6);
-		i := 0;
-		REPEAT table[i] := 0; INC(i) UNTIL i = N;
-		bit := 0; hash := 0; sum := 0; dest := f.NewWriter(NIL);
-		WHILE (res = 0) & (len # 0) DO
-			IF bit = 0 THEN Read(src, x, res); bit := 6 END;
-			IF ODD(x) THEN	(* Incorrect prediction -> 1'xxxx'xxxx *)
-				x := x DIV 2; DEC(bit);
-				WHILE (res = 0) & (bit < 8) DO Read(src, j, res); INC(x, ASH(j, bit)); INC(bit, 6) END;
-				i := x MOD 256;
-				IF i > MAX(BYTE) THEN i := i - 256 END;
-				byte := SHORT(SHORT(i)); x := x DIV 256; DEC(bit, 8);
-				table[hash] := byte
-			ELSE byte := table[hash]; x := x DIV 2; DEC(bit)	(* correct prediction *)
-			END;
-			hash := (16 * hash + byte MOD 256) MOD N;
-			dest.WriteByte(byte); sum := (sum + byte MOD 256) MOD (16 * 1024); DEC(len)
-		END;
-		IF res = 0 THEN
-			i := 0; s := 0;
-			REPEAT Read(src, x, res); s := s + ASH(x, 6 * i); INC(i) UNTIL (res # 0) OR (i = 6);
-			IF (res = 0) & (s # sum) THEN res := 2 END
-		END
-	END ReadFile;
-
-	PROCEDURE ShowText (t: TextModels.Model);
-		VAR l: INTEGER; v: Views.View; wr: TextMappers.Formatter; conv: Converters.Converter;
-	BEGIN
-		l := t.Length();
-		wr.ConnectTo(t); wr.SetPos(l); wr.WriteString(" --- end of encoding ---");
-		ShowSizeMsg(l);
-		v := TextViews.dir.New(t);
-		conv := Converters.list;
-		WHILE (conv # NIL) & (conv.imp # "HostTextConv.ImportText") DO conv := conv.next END;
-		Views.Open(v, NIL, "", conv);
-		Views.SetDirty(v)
-	END ShowText;
-
-	PROCEDURE EncodedView*(v: Views.View): TextModels.Model;
-		VAR n: INTEGER; f: Files.File; wrs: Stores.Writer; t: TextModels.Model; wr: TextModels.Writer;
-	BEGIN
-		f := Files.dir.Temp(); wrs.ConnectTo(f); Views.WriteView(wrs, v);
-		t := TextModels.dir.New(); wr := t.NewWriter(NIL);
-		n := 0; WriteHeader(wr, n, "", View); WriteFileType(wr, n, f.type); WriteFile(wr, n, f);
-		RETURN t
-	END EncodedView;
-
-	PROCEDURE EncodeDocument*;
-		VAR v: Views.View; w: Windows.Window;
-	BEGIN
-		w := Windows.dir.First();
-		IF w # NIL THEN
-			v := w.doc.OriginalView();
-			IF (v.context # NIL) & (v.context IS Documents.Context) THEN
-				v := v.context(Documents.Context).ThisDoc()
-			END;
-			IF v # NIL THEN ShowText(EncodedView(v)) END
-		END
-	END EncodeDocument;
-
-	PROCEDURE EncodeFocus*;
-		VAR v: Views.View;
-	BEGIN
-		v := Controllers.FocusView();
-		IF v # NIL THEN ShowText(EncodedView(v)) END
-	END EncodeFocus;
-
-	PROCEDURE EncodeSelection*;
-		VAR beg, end: INTEGER; t: TextModels.Model; c: TextControllers.Controller;
-	BEGIN
-		c := TextControllers.Focus();
-		IF (c # NIL) & c.HasSelection() THEN
-			c.GetSelection(beg, end);
-			t := TextModels.CloneOf(c.text); t.InsertCopy(0, c.text, beg, end);
-			ShowText(EncodedView(TextViews.dir.New(t)))
-		END
-	END EncodeSelection;
-
-	PROCEDURE EncodeFile*;
-		VAR n: INTEGER; loc: Files.Locator; name: Files.Name; f: Files.File;
-			t: TextModels.Model; wr: TextModels.Writer;
-	BEGIN
-		Dialog.GetIntSpec("", loc, name);
-		IF loc # NIL THEN
-			f := Files.dir.Old(loc, name, TRUE);
-			IF f # NIL THEN
-				t := TextModels.dir.New(); wr := t.NewWriter(NIL);
-				n := 0; WriteHeader(wr, n, name, File); WriteFileType(wr, n, f.type); WriteFile(wr, n, f);
-				ShowText(t)
-			END
-		END
-	END EncodeFile;
-
-	PROCEDURE GetFile(VAR path: ARRAY OF CHAR; VAR loc: Files.Locator; VAR name: Files.Name);
-		VAR i, j: INTEGER; ch: CHAR;
-	BEGIN
-		i := 0; ch := path[0]; loc := Files.dir.This("");
-		WHILE (ch # 0X) & (loc # NIL) DO
-			j := 0;
-			WHILE (ch # 0X) & (ch # Separator) DO name[j] := ch; INC(j); INC(i); ch := path[i] END;
-			name[j] := 0X;
-			IF ch = Separator THEN loc := loc.This(name); INC(i); ch := path[i] END;
-			IF loc.res # 0 THEN loc := NIL END
-		END;
-		path[i] := 0X
-	END GetFile;
-
-	PROCEDURE ReadPath(rd: TextModels.Reader; VAR path: ARRAY OF CHAR; VAR len: INTEGER);
-		VAR i, l: INTEGER; ch: CHAR;
-	BEGIN
-		i := 0; l := LEN(path) - 1;
-		REPEAT rd.ReadChar(ch) UNTIL rd.eot OR (ch > " ");
-		WHILE ~rd.eot & (ch > " ") & (i < l) DO path[i] := ch; INC(i); rd.ReadChar(ch) END;
-		path[i] := 0X; len := i
-	END ReadPath;
-	
-	PROCEDURE WriteString(w: Files.Writer; IN str: ARRAY OF CHAR; len: INTEGER);
-		VAR i: INTEGER;
-	BEGIN
-		i := 0;
-		WHILE i < len DO
-			IF ORD(str[i]) > MAX(BYTE) THEN w.WriteByte(SHORT(SHORT(ORD(str[i]) - 256)))
-			ELSE w.WriteByte(SHORT(SHORT(ORD(str[i]))))
-			END;
-			INC(i)
-		END
-	END WriteString;
-
-	PROCEDURE EncodeFileList*;
-		TYPE
-			FileList = POINTER TO RECORD
-				next: FileList;
-				f: Files.File
-			END;
-		VAR
-			beg, end, i, j, n: INTEGER; err: BOOLEAN;
-			files, last: FileList;
-			list, f: Files.File; w: Files.Writer; loc: Files.Locator;
-			rd: TextModels.Reader; wr: TextModels.Writer; t: TextModels.Model;
-			c: TextControllers.Controller;
-			name: Files.Name; path, next: ARRAY 2048 OF CHAR;
-	BEGIN
-		c := TextControllers.Focus();
-		IF (c # NIL) & c.HasSelection() THEN c.GetSelection(beg, end);
-			rd := c.text.NewReader(NIL); rd.SetPos(beg); err := FALSE;
-			list := Files.dir.Temp(); w := list.NewWriter(NIL); files := NIL; last := NIL;
-			ReadPath(rd, path, i);
-			WHILE (path # "") & (rd.Pos() - i < end) & ~err DO
-				GetFile(path, loc, name);
-				IF loc # NIL THEN
-					f := Files.dir.Old(loc, name, TRUE); err := f = NIL;
-					IF ~err THEN
-						IF last = NIL THEN NEW(last); files := last ELSE NEW(last.next); last := last.next END;
-						last.f := f;
-						ReadPath(rd, next, j);
-						IF (next = "=>") & (rd.Pos() - j < end) THEN
-							ReadPath(rd, next, j);
-							IF next # "" THEN WriteString(w, next, j + 1); ReadPath(rd, next, j)
-							ELSE err := TRUE
-							END
-						ELSE WriteString(w, path, i + 1)
-						END;
-						path := next; i := j
-					END
-				ELSE err := TRUE
-				END
-			END;
-			IF ~err & (files # NIL) THEN
-				t := TextModels.dir.New(); wr := t.NewWriter(NIL);
-				n := 0; WriteHeader(wr, n, "", List);
-				WriteFileType(wr, n, list.type); WriteFile(wr, n, list);
-				WHILE files # NIL DO
-					WriteFileType(wr, n, files.f.type); WriteFile(wr, n, files.f); files := files.next
-				END;
-				ShowText(t)
-			ELSIF err THEN
-				IF path = "" THEN ShowError(7, path)
-				ELSIF loc # NIL THEN ShowError(6, path)
-				ELSE ShowError(5, path)
-				END
-			END
-		END
-	END EncodeFileList;
-
-	PROCEDURE DecodeView(rd: TextModels.Reader; name: Files.Name);
-		VAR res: INTEGER; f: Files.File; ftype: Files.Type; rds: Stores.Reader; v: Views.View;
-	BEGIN
-		ReadFileType(rd, res, ftype);
-		IF res = 0 THEN
-			f := Files.dir.Temp(); ReadFile(rd, res, f);
-			IF res = 0 THEN
-				rds.ConnectTo(f); Views.ReadView(rds, v); Views.Open(v, NIL, name, NIL);
-				Views.SetDirty(v)
-			ELSE ShowError(res, "")
-			END
-		ELSE ShowError(res, "")
-		END
-	END DecodeView;
-
-	PROCEDURE DecodeFile(rd: TextModels.Reader; name: Files.Name);
-		VAR res: INTEGER; ftype: Files.Type; loc: Files.Locator; f: Files.File;
-	BEGIN
-		ReadFileType(rd, res, ftype);
-		IF res = 0 THEN
-			Dialog.GetExtSpec(name, ftype, loc, name);
-			IF loc # NIL THEN
-				f := Files.dir.New(loc, Files.ask);
-				IF f # NIL THEN
-					ReadFile(rd, res, f);
-					IF res = 0 THEN
-						f.Register(name, ftype, Files.ask, res);
-						IF res # 0 THEN ShowError(4, "") END
-					ELSE ShowError(res, "")
-					END
-				ELSIF loc.res = 4 THEN ShowError(9, "")
-				ELSIF loc.res = 5 THEN ShowError(10, "")
-				END
-			END
-		ELSE ShowError(res, "")
-		END
-	END DecodeFile;
-
-	PROCEDURE DecodeFileList (rd: TextModels.Reader; VAR files: FileList; VAR len, res: INTEGER);
-		VAR i, n: INTEGER; b: BYTE; p: FileList;
-			ftype: Files.Type; f: Files.File; frd: Files.Reader; path: Dialog.String;
-	BEGIN
-		ReadFileType(rd, res, ftype);
-		IF res = 0 THEN
-			f := Files.dir.Temp(); ReadFile(rd, res, f);
-			IF res = 0 THEN
-				files := NIL; p := NIL; n := 0;
-				frd := f.NewReader(NIL); frd.ReadByte(b);
-				WHILE ~frd.eof & (res = 0) DO
-					INC(n); i := 0;
-					WHILE ~frd.eof & (b # 0) DO path[i] := CHR(b MOD 256); INC(i); frd.ReadByte(b) END;
-					IF (i > 4) & (path[i - 4] = ".") & (CAP(path[i - 3]) = "O")
-						& (CAP(path[i - 2]) = "D") & (CAP(path[i - 1]) = "C")
-					THEN path[i - 4] := 0X
-					ELSE path[i] := 0X
-					END;
-					IF ~frd.eof THEN
-						IF p = NIL THEN NEW(p); files := p ELSE NEW(p.next); p := p.next END;
-						p.name := path;
-						frd.ReadByte(b)
-					ELSE res := 1
-					END
-				END;
-				p := files; len := n;
-				WHILE (res = 0) & (p # NIL) DO
-					ReadFileType(rd, res, p.type);
-					IF res = 0 THEN p.file := Files.dir.Temp(); ReadFile(rd, res, p.file) END;
-					p := p.next
-				END
-			END
-		END
-	END DecodeFileList;
-
-	PROCEDURE OpenDialog(files: FileList; len: INTEGER);
-		VAR i: INTEGER; p: FileList;
-	BEGIN
-		par.files := files; par.list.SetLen(len);
-		p := files; i := 0;
-		WHILE p # NIL DO par.list.SetItem(i, p.name); INC(i); p := p.next END;
-		par.storeAs := "";
-		Dialog.Update(par); Dialog.UpdateList(par.list);
-		StdCmds.OpenAuxDialog("Std/Rsrc/Coder", "Decode")
-	END OpenDialog;
-
-	PROCEDURE CloseDialog*;
-	BEGIN
-		par.files := NIL; par.list.SetLen(0); par.storeAs := "";
-		Dialog.UpdateList(par.list); Dialog.Update(par)
-	END CloseDialog;
-
-	PROCEDURE Select*(op, from, to: INTEGER);
-		VAR p: FileList; i: INTEGER;
-	BEGIN
-		IF (op = Dialog.included) OR (op = Dialog.excluded) OR (op = Dialog.set) THEN
-			IF NofSelections(par.list) = 1 THEN
-				i := 0; p := par.files;
-				WHILE ~par.list.In(i) DO INC(i); p := p.next END;
-				par.storeAs := p.name
-			ELSE par.storeAs := ""
-			END;
-			Dialog.Update(par)
-		END
-	END Select;
-
-	PROCEDURE CopyFile(from: Files.File; loc: Files.Locator; name: Files.Name; type: Files.Type);
-		CONST BufSize = 4096;
-		VAR res, k, l: INTEGER; f: Files.File; r: Files.Reader; w: Files.Writer;
-			buf: ARRAY BufSize OF BYTE;
-	BEGIN
-		f := Files.dir.New(loc, Files.ask);
-		IF f # NIL THEN
-			r := from.NewReader(NIL); w := f.NewWriter(NIL); l := from.Length();
-			WHILE l # 0 DO
-				IF l <= BufSize THEN k := l ELSE k := BufSize END;
-				r.ReadBytes(buf, 0, k); w.WriteBytes(buf, 0, k);
-				l := l - k
-			END;
-			f.Register(name, type, Files.ask, res);
-			IF res # 0 THEN ShowError(4, "") END
-		ELSIF loc.res = 4 THEN ShowError(9, "")
-		ELSIF loc.res = 5 THEN ShowError(10, "")
-		END
-	END CopyFile;
-
-	PROCEDURE StoreSelection*;
-		VAR i, n: INTEGER; p: FileList; loc: Files.Locator; name: Files.Name;
-	BEGIN
-		n := NofSelections(par.list);
-		IF n > 1 THEN
-			i := 0; p := par.files;
-			WHILE n # 0 DO
-				WHILE ~par.list.In(i) DO INC(i); p := p.next END;
-				GetFile(p.name, loc, name); CopyFile(p.file, loc, name, p.type);
-				DEC(n); INC(i); p := p.next
-			END
-		ELSIF (n = 1) & (par.storeAs # "") THEN
-			i := 0; p := par.files;
-			WHILE ~par.list.In(i) DO INC(i); p := p.next END;
-			GetFile(par.storeAs, loc, name); CopyFile(p.file, loc, name, p.type)
-		END
-	END StoreSelection;
-
-	PROCEDURE StoreSelectionGuard*(VAR p: Dialog.Par);
-		VAR n: INTEGER;
-	BEGIN
-		n := NofSelections(par.list);
-		p.disabled := (n = 0) OR ((n = 1) & (par.storeAs = ""))
-	END StoreSelectionGuard;
-
-	PROCEDURE StoreSingle*;
-		VAR i: INTEGER; p: FileList; loc: Files.Locator; name: Files.Name;
-	BEGIN
-		IF NofSelections(par.list) = 1 THEN
-			i := 0; p := par.files;
-			WHILE ~par.list.In(i) DO INC(i); p := p.next END;
-			GetFile(p.name, loc, name);
-			Dialog.GetExtSpec(name, p.type, loc, name);
-			IF loc # NIL THEN CopyFile(p.file, loc, name, p.type) END
-		END
-	END StoreSingle;
-
-	PROCEDURE StoreSingleGuard*(VAR p: Dialog.Par);
-	BEGIN
-		p.disabled := NofSelections(par.list) # 1
-	END StoreSingleGuard;
-
-	PROCEDURE StoreAllFiles(files: FileList);
-		VAR loc: Files.Locator; name: Files.Name;
-	BEGIN
-		WHILE files # NIL DO
-			GetFile(files.name, loc, name); CopyFile(files.file, loc, name, files.type); files := files.next
-		END
-	END StoreAllFiles;
-
-	PROCEDURE StoreAll*;
-	BEGIN
-		StoreAllFiles(par.files)
-	END StoreAll;
-
-	PROCEDURE DecodeAllFromText*(text: TextModels.Model; beg: INTEGER; ask: BOOLEAN);
-		VAR res, i: INTEGER; type: BYTE; name: Files.Name; rd: TextModels.Reader; files: FileList;
-	BEGIN
-		CloseDialog;
-		rd := text.NewReader(NIL); rd.SetPos(beg);
-		ReadHeader(rd, res, name, type);
-		i := 0;
-		WHILE name[i] # 0X DO INC(i) END;
-		IF (i > 4) & (name[i - 4] = ".") & (CAP(name[i - 3]) = "O")
-			& (CAP(name[i - 2]) = "D") & (CAP(name[i - 1]) = "C")
-		THEN name[i - 4] := 0X
-		END;
-		IF res = 0 THEN
-			IF type = View THEN DecodeView(rd, name)
-			ELSIF type = File THEN DecodeFile(rd, name)
-			ELSIF type = List THEN
-				DecodeFileList(rd, files, i, res);
-				IF res = 0 THEN
-					IF ask THEN OpenDialog(files, i) ELSE StoreAllFiles(files) END
-				ELSE ShowError(res, "")
-				END
-			ELSE ShowError(3, "")
-			END
-		ELSE ShowError(res, "")
-		END
-	END DecodeAllFromText;
-
-	PROCEDURE Decode*;
-		VAR beg, end: INTEGER; c: TextControllers.Controller;
-	BEGIN
-		CloseDialog;
-		c := TextControllers.Focus();
-		IF c # NIL THEN
-			IF c.HasSelection() THEN c.GetSelection(beg, end) ELSE beg := 0 END;
-			DecodeAllFromText(c.text, beg, TRUE)
-		END
-	END Decode;
-
-	PROCEDURE ListFiles(rd: TextModels.Reader; VAR wr: TextMappers.Formatter);
-		VAR i, n, res: INTEGER; b: BYTE;
-			ftype: Files.Type; f: Files.File; frd: Files.Reader; path: Dialog.String;
-	BEGIN
-		ReadFileType(rd, res, ftype);
-		IF res = 0 THEN
-			f := Files.dir.Temp(); ReadFile(rd, res, f);
-			IF res = 0 THEN
-				n := 0;
-				frd := f.NewReader(NIL); frd.ReadByte(b);
-				WHILE ~frd.eof & (res = 0) DO
-					INC(n); i := 0;
-					WHILE ~frd.eof & (b # 0) DO path[i] := CHR(b MOD 256); INC(i); frd.ReadByte(b) END;
-					IF (i > 4) & (path[i - 4] = ".") & (CAP(path[i - 3]) = "O")
-						& (CAP(path[i - 2]) = "D") & (CAP(path[i - 1]) = "C")
-					THEN path[i - 4] := 0X
-					ELSE path[i] := 0X
-					END;
-					IF ~frd.eof THEN wr.WriteString(path); wr.WriteLn; frd.ReadByte(b) ELSE res := 1 END
-				END
-			ELSE ShowError(res, "")
-			END
-		ELSE ShowError(res, "")
-		END
-	END ListFiles;
-
-	PROCEDURE ListSingleton(type, name: ARRAY OF CHAR; VAR wr: TextMappers.Formatter);
-	BEGIN
-		wr.WriteString(type);
-		IF name # "" THEN wr.WriteString(": '"); wr.WriteString(name); wr.WriteChar("'") END;
-		wr.WriteLn
-	END ListSingleton;
-
-	PROCEDURE EncodedInText*(text: TextModels.Model; beg: INTEGER): TextModels.Model;
-		VAR res, i: INTEGER; type: BYTE; name: Files.Name;
-			rd: TextModels.Reader; report: TextModels.Model; wr: TextMappers.Formatter;
-	BEGIN
-		report := TextModels.dir.New(); wr.ConnectTo(report);
-		rd := text.NewReader(NIL); rd.SetPos(beg);
-		ReadHeader(rd, res, name, type);
-		i := 0;
-		WHILE name[i] # 0X DO INC(i) END;
-		IF (i > 4) & (name[i - 4] = ".") & (CAP(name[i - 3]) = "O")
-			& (CAP(name[i - 2]) = "D") & (CAP(name[i - 1]) = "C")
-		THEN name[i - 4] := 0X
-		END;
-		IF res = 0 THEN
-			IF type = View THEN ListSingleton("View", name, wr)
-			ELSIF type = File THEN ListSingleton("File", name, wr)
-			ELSIF type = List THEN ListFiles(rd, wr)
-			ELSE ShowError(3, "")
-			END
-		ELSE ShowError(res, "")
-		END;
-		RETURN report
-	END EncodedInText;
-
-	PROCEDURE ListEncodedMaterial*;
-		VAR beg, end: INTEGER; c: TextControllers.Controller;
-	BEGIN
-		c := TextControllers.Focus();
-		IF c # NIL THEN
-			IF c.HasSelection() THEN c.GetSelection(beg, end) ELSE beg := 0 END;
-			Views.OpenView(TextViews.dir.New(EncodedInText(c.text, beg)))
-		END
-	END ListEncodedMaterial;
-
-	PROCEDURE InitCodes;
-		VAR i: BYTE; j: INTEGER;
-	BEGIN
-		j := 0;
-		WHILE j # 256 DO revCode[j] := -1; INC(j) END;
-		code[0] := "."; revCode[ORD(".")] := 0; code[1] := ","; revCode[ORD(",")] := 1;
-		i := 2; j := ORD("0");
-		WHILE j <= ORD("9") DO code[i] := CHR(j); revCode[j] := i; INC(i); INC(j) END;
-		j := ORD("A");
-		WHILE j <= ORD("Z") DO code[i] := CHR(j); revCode[j] := i; INC(i); INC(j) END;
-		j := ORD("a");
-		WHILE j <= ORD("z") DO code[i] := CHR(j); revCode[j] := i; INC(i); INC(j) END;
-		ASSERT(i = 64, 60)
-	END InitCodes;
-
-BEGIN
-	InitCodes;
-	stdDocuType[0] := 3X; stdDocuType[1] := 3X; stdDocuType[2] := 3X; stdDocuType[3] := 0X
-END StdCoder.

BlackBox/Std/Mod/Debug.txt

@@ -1,621 +0,0 @@
-MODULE StdDebug;
-
-	(* THIS IS TEXT COPY OF BlackBox 1.6-rc6 Std/Mod/Debug.odc *)
-	(* DO NOT EDIT *)
-
-	IMPORT SYSTEM,
-		Kernel, Strings, Fonts, Services, Ports, Views, Properties, Dialog, Containers, StdFolds,
-		TextModels, TextMappers, TextViews, TextRulers;
-	
-	CONST
-		refViewSize = 9 * Ports.point;
-		
-		heap = 1; source = 2; module = 3; modules = 4;	(* RefView types *)
-		
-	TYPE
-		Name = Kernel.Name;
-
-		ArrayPtr = POINTER TO RECORD
-			last, t, first: INTEGER;	(* gc header *)
-			len: ARRAY 16 OF INTEGER	(* dynamic array length table *)
-		END;
-
-		RefView = POINTER TO RefViewDesc;
-
-		RefViewDesc = RECORD
-			type: SHORTINT;
-			command: SHORTINT;
-			back: RefView;
-			adr: INTEGER;
-			desc: Kernel.Type;
-			ptr: ArrayPtr;
-			name: Name
-		END;
-		
-		Action = POINTER TO RECORD (Services.Action)
-			text: TextModels.Model
-		END;
-		
-		Cluster = POINTER TO RECORD [untagged]	(* must correspond to Kernel.Cluster *)
-			size: INTEGER;
-			next: Cluster
-		END;
-		
-	
-	VAR
-		out: TextMappers.Formatter;
-		path: ARRAY 4 OF Ports.Point;
-		empty: Name;
-
-
-	PROCEDURE NewRuler (): TextRulers.Ruler;
-		CONST mm = Ports.mm;
-		VAR r: TextRulers.Ruler;
-	BEGIN
-		r := TextRulers.dir.New(NIL);
-		TextRulers.SetRight(r, 140 * mm);
-		TextRulers.AddTab(r, 4 * mm); TextRulers.AddTab(r, 34 * mm); TextRulers.AddTab(r, 80 * mm);
-		RETURN r
-	END NewRuler;
-
-	PROCEDURE OpenViewer (t: TextModels.Model; title: Views.Title; ruler:TextRulers.Ruler);
-		VAR v: TextViews.View; c: Containers.Controller;
-	BEGIN
-		Dialog.MapString(title, title);
-		v := TextViews.dir.New(t);
-		v.SetDefaults(ruler, TextViews.dir.defAttr);
-		c := v.ThisController();
-		IF c # NIL THEN
-			c.SetOpts(c.opts - {Containers.noFocus, Containers.noSelection} + {Containers.noCaret})
-		END;
-		Views.OpenAux(v, title)
-	END OpenViewer;
-	
-	PROCEDURE OpenFold (hidden: ARRAY OF CHAR);
-		VAR fold: StdFolds.Fold; t: TextModels.Model; w: TextMappers.Formatter;
-	BEGIN
-		Dialog.MapString(hidden, hidden);
-		t := TextModels.dir.New();
-		w.ConnectTo(t); w.WriteString(hidden);
-		fold := StdFolds.dir.New(StdFolds.expanded, "", t);
-		out.WriteView(fold)
-	END OpenFold;
-	
-	PROCEDURE CloseFold (collaps: BOOLEAN);
-		VAR fold: StdFolds.Fold; m: TextModels.Model;
-	BEGIN
-		fold := StdFolds.dir.New(StdFolds.expanded, "", NIL);
-		out.WriteView(fold);
-		IF collaps THEN fold.Flip(); m := out.rider.Base(); out.SetPos(m.Length()) END
-	END CloseFold;
-	
-	PROCEDURE WriteHex (n: INTEGER);
-	BEGIN
-		out.WriteIntForm(n, TextMappers.hexadecimal, 9, "0", TextMappers.showBase)
-	END WriteHex;
-	
-	PROCEDURE WriteString (adr, len, base: INTEGER; zterm, unicode: BOOLEAN);
-		CONST beg = 0; char = 1; code = 2;
-		VAR ch: CHAR; sc: SHORTCHAR; val, mode: INTEGER; str: ARRAY 16 OF CHAR;
-	BEGIN
-		mode := beg;
-		IF base = 2 THEN SYSTEM.GET(adr, ch); val := ORD(ch) ELSE SYSTEM.GET(adr, sc); val := ORD(sc) END;
-		IF zterm & (val = 0) THEN out.WriteSString('""')
-		ELSE
-			REPEAT
-				IF (val >= ORD(" ")) & (val < 7FH) OR (val > 0A0H) & (val < 100H) OR unicode & (val >= 100H) THEN
-					IF mode # char THEN
-						IF mode = code THEN out.WriteSString(", ") END;
-						out.WriteChar(22X); mode := char
-					END;
-					out.WriteChar(CHR(val))
-				ELSE
-					IF mode = char THEN out.WriteChar(22X) END;
-					IF mode # beg THEN out.WriteSString(", ") END;
-					mode := code; Strings.IntToStringForm(val, Strings.hexadecimal, 1, "0", FALSE, str);
-					IF str[0] > "9" THEN out.WriteChar("0") END;
-					out.WriteString(str); out.WriteChar("X")
-				END;
-				INC(adr, base); DEC(len);
-				IF base = 2 THEN SYSTEM.GET(adr, ch); val := ORD(ch) ELSE SYSTEM.GET(adr, sc); val := ORD(sc) END
-			UNTIL (len = 0) OR zterm & (val = 0)
-		END;
-		IF mode = char THEN out.WriteChar(22X) END
-	END WriteString;
-	
-	PROCEDURE OutString (s: ARRAY OF CHAR);
-		VAR str: Dialog.String;
-	BEGIN
-		Dialog.MapString(s, str);
-		out.WriteString(str)
-	END OutString;
-
-	(* -------------------  variable display ------------------- *)
-	
-	PROCEDURE FormOf (t: Kernel.Type): SHORTCHAR;
-	BEGIN
-		IF SYSTEM.VAL(INTEGER, t) DIV 256 = 0 THEN
-			RETURN SHORT(CHR(SYSTEM.VAL(INTEGER, t)))
-		ELSE
-			RETURN SHORT(CHR(16 + t.id MOD 4))
-		END
-	END FormOf;
-	
-	PROCEDURE LenOf (t: Kernel.Type; ptr: ArrayPtr): INTEGER;
-	BEGIN
-		IF t.size # 0 THEN RETURN t.size
-		ELSIF ptr # NIL THEN RETURN ptr.len[t.id DIV 16 MOD 16 - 1]
-		ELSE RETURN 0
-		END
-	END LenOf;
-	
-	PROCEDURE SizeOf (t: Kernel.Type; ptr: ArrayPtr): INTEGER;
-	BEGIN
-		CASE FormOf(t) OF
-		| 0BX: RETURN 0
-		| 1X, 2X, 4X: RETURN 1
-		| 3X, 5X: RETURN 2
-		| 8X, 0AX: RETURN 8
-		| 11X: RETURN t.size
-		| 12X: RETURN LenOf(t, ptr) * SizeOf(t.base[0], ptr)
-		ELSE RETURN 4
-		END
-	END SizeOf;
-
-	PROCEDURE WriteName (t: Kernel.Type; ptr: ArrayPtr);
-		VAR name: Kernel.Name; f: SHORTCHAR;
-	BEGIN
-		f := FormOf(t);
-		CASE f OF
-		| 0X: OutString("#Dev:Unknown")
-		| 1X: out.WriteSString("BOOLEAN")
-		| 2X: out.WriteSString("SHORTCHAR")
-		| 3X: out.WriteSString("CHAR")
-		| 4X: out.WriteSString("BYTE")
-		| 5X: out.WriteSString("SHORTINT")
-		| 6X: out.WriteSString("INTEGER")
-		| 7X: out.WriteSString("SHORTREAL")
-		| 8X: out.WriteSString("REAL")
-		| 9X: out.WriteSString("SET")
-		| 0AX: out.WriteSString("LONGINT")
-		| 0BX: out.WriteSString("ANYREC")
-		| 0CX: out.WriteSString("ANYPTR")
-		| 0DX: out.WriteSString("POINTER")
-		| 0EX: out.WriteSString("PROCEDURE")
-		| 0FX: out.WriteSString("STRING")
-		| 10X..13X:
-			Kernel.GetTypeName(t, name);
-			IF name = "!" THEN
-				IF f = 11X THEN out.WriteSString("RECORD")
-				ELSIF f = 12X THEN out.WriteSString("ARRAY")
-				ELSE OutString("#Dev:Unknown")
-				END
-			ELSIF (t.id DIV 256 # 0) & (t.mod.refcnt >= 0) THEN
-				out.WriteSString(t.mod.name); out.WriteChar("."); out.WriteSString(name)
-			ELSIF f = 11X THEN
-				out.WriteSString(t.mod.name); out.WriteSString(".RECORD") 
-			ELSIF f = 12X THEN
-				out.WriteSString("ARRAY "); out.WriteInt(LenOf(t, ptr)); t := t.base[0];
-				WHILE (FormOf(t) = 12X) & ((t.id DIV 256 = 0) OR (t.mod.refcnt < 0)) DO
-					out.WriteSString(", "); out.WriteInt(LenOf(t, ptr)); t := t.base[0]
-				END;
-				out.WriteSString(" OF "); WriteName(t, ptr)
-			ELSIF f = 13X THEN
-				out.WriteSString("POINTER")
-			ELSE
-				out.WriteSString("PROCEDURE")
-			END
-		| 20X: out.WriteSString("COM.IUnknown")
-		| 21X: out.WriteSString("COM.GUID")
-		| 22X: out.WriteSString("COM.RESULT")
-		ELSE OutString("#Dev:UnknownFormat"); out.WriteInt(ORD(f))
-		END
-	END WriteName;
-	
-	PROCEDURE WriteGuid (a: INTEGER);
-
-		PROCEDURE Hex (a: INTEGER);
-			VAR x: SHORTCHAR;
-		BEGIN
-			SYSTEM.GET(a, x);
-			out.WriteIntForm(ORD(x), TextMappers.hexadecimal, 2, "0", FALSE)
-		END Hex;
-
-	BEGIN
-		out.WriteChar("{");
-		Hex(a + 3); Hex(a + 2); Hex(a + 1); Hex(a);
-		out.WriteChar("-");
-		Hex(a + 5); Hex(a + 4);
-		out.WriteChar("-");
-		Hex(a + 7); Hex(a + 6);
-		out.WriteChar("-");
-		Hex(a + 8);
-		Hex(a + 9);
-		out.WriteChar("-");
-		Hex(a + 10);
-		Hex(a + 11);
-		Hex(a + 12);
-		Hex(a + 13);
-		Hex(a + 14);
-		Hex(a + 15);
-		out.WriteChar("}")
-	END WriteGuid;
-	
-	PROCEDURE^ ShowVar (ad, ind: INTEGER; f, c: SHORTCHAR; desc: Kernel.Type; ptr: ArrayPtr;
-											back: RefView; VAR name, sel: Name);
-	
-	PROCEDURE ShowRecord (a, ind: INTEGER; desc: Kernel.Type; back: RefView; VAR sel: Name);
-		VAR dir: Kernel.Directory; obj: Kernel.Object; name: Kernel.Name; i, j, n: INTEGER; base: Kernel.Type;
-	BEGIN
-		WriteName(desc, NIL); out.WriteTab;
-		IF desc.mod.refcnt >= 0 THEN
-			OpenFold("#Dev:Fields");
-			n := desc.id DIV 16 MOD 16; j := 0;
-			WHILE j <= n DO
-				base := desc.base[j];
-				IF base # NIL THEN
-					dir := base.fields; i := 0;
-					WHILE i < dir.num DO
-						obj := SYSTEM.VAL(Kernel.Object, SYSTEM.ADR(dir.obj[i]));
-						Kernel.GetObjName(base.mod, obj, name);
-						ShowVar(a + obj.offs, ind, FormOf(obj.struct), 1X, obj.struct, NIL, back, name, sel);
-						INC(i)
-					END
-				END;
-				INC(j)
-			END;
-			out.WriteSString("   "); CloseFold((ind > 1) OR (sel # ""))
-		ELSE
-			OutString("#Dev:Unloaded")
-		END
-	END ShowRecord;
-	
-	PROCEDURE ShowArray (a, ind: INTEGER; desc: Kernel.Type; ptr: ArrayPtr; back: RefView; VAR sel: Name);
-		VAR f: SHORTCHAR; i, n, m, size, len: INTEGER; name: Kernel.Name; eltyp, t: Kernel.Type;
-			vi: SHORTINT; vs: BYTE; str: Dialog.String; high: BOOLEAN;
-	BEGIN
-		WriteName(desc, ptr); out.WriteTab;
-		len := LenOf(desc, ptr); eltyp := desc.base[0]; f := FormOf(eltyp); size := SizeOf(eltyp, ptr);
-		IF (f = 2X) OR (f = 3X) THEN	(* string *)
-			n := 0; m := len; high := FALSE;
-			IF f = 2X THEN
-				REPEAT SYSTEM.GET(a + n, vs); INC(n) UNTIL (n = 32) OR (n = len) OR (vs = 0);
-				REPEAT DEC(m); SYSTEM.GET(a + m, vs) UNTIL (m = 0) OR (vs # 0)
-			ELSE
-				REPEAT
-					SYSTEM.GET(a + n * 2, vi); INC(n);
-					IF vi DIV 256 # 0 THEN high := TRUE END
-				UNTIL (n = len) OR (vi = 0);
-				n := MIN(n, 32);
-				REPEAT DEC(m); SYSTEM.GET(a + m * 2, vi) UNTIL (m = 0) OR (vi # 0)
-			END;
-			WriteString(a, n, size, TRUE, TRUE);
-			INC(m, 2);
-			IF m > len THEN m := len END;
-			IF high OR (m > n) THEN
-				out.WriteSString("   "); OpenFold("...");
-				out.WriteLn;
-				IF high & (n = 32) THEN
-					WriteString(a, m, size, TRUE, TRUE);
-					out.WriteLn; out.WriteLn
-				END;
-				WriteString(a, m, size, FALSE, FALSE);
-				IF m < len THEN out.WriteSString(", ..., 0X") END;
-				out.WriteSString("   "); CloseFold(TRUE)
-			END
-		ELSE
-			t := eltyp;
-			WHILE FormOf(t) = 12X DO t := t.base[0] END;
-			IF FormOf(t) # 0X THEN
-				OpenFold("#Dev:Elements");
-				i := 0;
-				WHILE i < len DO
-					Strings.IntToString(i, str);
-					name := "[" + SHORT(str$) + "]";
-					ShowVar(a, ind, f, 1X, eltyp, ptr, back, name, sel);
-					INC(i); INC(a, size)
-				END;
-				out.WriteSString("   "); CloseFold(TRUE)
-			END
-		END
-	END ShowArray;
-	
-	PROCEDURE ShowProcVar (a: INTEGER);
-		VAR vli, n, ref: INTEGER; m: Kernel.Module; name: Kernel.Name;
-	BEGIN
-		SYSTEM.GET(a, vli);
-		Kernel.SearchProcVar(vli, m, vli);
-		IF m = NIL THEN
-			IF vli = 0 THEN out.WriteSString("NIL")
-			ELSE WriteHex(vli)
-			END
-		ELSE
-			IF m.refcnt >= 0 THEN
-				out.WriteSString(m.name); ref := m.refs;
-				REPEAT Kernel.GetRefProc(ref, n, name) UNTIL (n = 0) OR (vli < n);
-				IF vli < n THEN out.WriteChar("."); out.WriteSString(name) END
-			ELSE
-				OutString("#Dev:ProcInUnloadedMod");
-				out.WriteSString(m.name); out.WriteSString(" !!!")
-			END
-		END
-	END ShowProcVar;
-
-	PROCEDURE ShowPointer (a: INTEGER; f: SHORTCHAR; desc: Kernel.Type; back: RefView; VAR sel: Name);
-		VAR adr, x: INTEGER; ptr: ArrayPtr; c: Cluster; btyp: Kernel.Type;
-	BEGIN
-		SYSTEM.GET(a, adr);
-		IF f = 13X THEN btyp := desc.base[0] ELSE btyp := NIL END;
-		IF adr = 0 THEN out.WriteSString("NIL")
-		ELSIF f = 20X THEN
-			out.WriteChar("["); WriteHex(adr); out.WriteChar("]");
-			out.WriteChar(" "); c := SYSTEM.VAL(Cluster, Kernel.Root());
-			WHILE (c # NIL) & ((adr < SYSTEM.VAL(INTEGER, c)) OR (adr >= SYSTEM.VAL(INTEGER, c) + c.size)) DO c := c.next END;
-			IF c # NIL THEN
-				ptr := SYSTEM.VAL(ArrayPtr, adr)
-			END
-		ELSE
-			IF (f = 13X) OR (f = 0CX) THEN x := adr - 4 ELSE x := adr END;
-			IF ((adr < -4) OR (adr >= 65536)) & Kernel.IsReadable(x, adr + 16) THEN
-				out.WriteChar("["); WriteHex(adr); out.WriteChar("]");
-				IF (f = 13X) OR (f = 0CX) THEN
-					out.WriteChar(" "); c := SYSTEM.VAL(Cluster, Kernel.Root());
-					WHILE (c # NIL) & ((adr < SYSTEM.VAL(INTEGER, c)) OR (adr >= SYSTEM.VAL(INTEGER, c) + c.size)) DO
-						c := c.next
-					END;
-					IF c # NIL THEN
-						ptr := SYSTEM.VAL(ArrayPtr, adr);
-						IF (f = 13X) & (FormOf(btyp) = 12X) THEN	(* array *)
-							adr := SYSTEM.ADR(ptr.len[btyp.id DIV 16 MOD 16]) 
-						END
-					ELSE OutString("#Dev:IllegalPointer")
-					END
-				END
-			ELSE OutString("#Dev:IllegalAddress"); WriteHex(adr)
-			END
-		END
-	END ShowPointer;
-	
-	PROCEDURE ShowSelector (ref: RefView);
-		VAR b: RefView; n: SHORTINT; a, a0: TextModels.Attributes;
-	BEGIN
-		b := ref.back; n := 1;
-		IF b # NIL THEN
-			WHILE (b.name = ref.name) & (b.back # NIL) DO INC(n); b := b.back END;
-			ShowSelector(b);
-			IF n > 1 THEN out.WriteChar("(") END;
-			out.WriteChar(".")
-		END;
-		out.WriteSString(ref.name);
-		IF ref.type = heap THEN out.WriteChar("^") END;
-		IF n > 1 THEN
-			out.WriteChar(")");
-			a0 := out.rider.attr; a := TextModels.NewOffset(a0, 2 * Ports.point);
-			out.rider.SetAttr(a);
-			out.WriteInt(n); out.rider.SetAttr(a0)
-		END
-	END ShowSelector;
-	
-	PROCEDURE ShowVar (ad, ind: INTEGER; f, c: SHORTCHAR; desc: Kernel.Type; ptr: ArrayPtr; back: RefView;
-											VAR name, sel: Name);
-		VAR i, j, vli, a: INTEGER; tsel: Name; a0: TextModels.Attributes;
-			vc: SHORTCHAR; vsi: BYTE; vi: SHORTINT; vr: SHORTREAL; vlr: REAL; vs: SET;
-	BEGIN
-		out.WriteLn; out.WriteTab; i := 0;
-		WHILE i < ind DO out.WriteSString("  "); INC(i) END;
-		a := ad; i := 0; j := 0;
-		IF sel # "" THEN
-			WHILE sel[i] # 0X DO tsel[i] := sel[i]; INC(i) END;
-			IF (tsel[i-1] # ":") & (name[0] # "[") THEN tsel[i] := "."; INC(i) END
-		END;
-		WHILE name[j] # 0X DO tsel[i] := name[j]; INC(i); INC(j) END;
-		tsel[i] := 0X;
-		a0 := out.rider.attr;
-		IF c = 3X THEN	(* varpar *)
-			SYSTEM.GET(ad, a);
-			out.rider.SetAttr(TextModels.NewStyle(a0, {Fonts.italic}))
-		END;
-		IF name[0] # "[" THEN out.WriteChar(".") END;
-		out.WriteSString(name);
-		out.rider.SetAttr(a0); out.WriteTab;
-		IF (c = 3X) & (a >= 0) & (a < 65536) THEN 
-			out.WriteTab; out.WriteSString("NIL VARPAR")
-		ELSIF f = 11X THEN
-			Kernel.GetTypeName(desc, name);
-			IF (c = 3X) & (name[0] # "!") THEN SYSTEM.GET(ad + 4, desc) END;	(* dynamic type *)
-			ShowRecord(a, ind + 1, desc, back, tsel)
-		ELSIF (c = 3X) & (f = 0BX) THEN	(* VAR anyrecord *)
-			SYSTEM.GET(ad + 4, desc);
-			ShowRecord(a, ind + 1, desc, back, tsel)
-		ELSIF f = 12X THEN
-			IF (desc.size = 0) & (ptr = NIL) THEN SYSTEM.GET(ad, a) END;	(* dyn array val par *)
-			IF ptr = NIL THEN ptr := SYSTEM.VAL(ArrayPtr, ad - 8) END;
-			ShowArray(a, ind + 1, desc, ptr, back, tsel)
-		ELSE
-			IF desc = NIL THEN desc := SYSTEM.VAL(Kernel.Type, ORD(f)) END;
-			WriteName(desc, NIL); out.WriteTab;
-			CASE f OF
-			| 0X: (* SYSTEM.GET(a, vli); WriteHex(vli) *)
-			| 1X: SYSTEM.GET(a, vc); 
-				IF vc = 0X THEN out.WriteSString("FALSE")
-				ELSIF vc = 1X THEN out.WriteSString("TRUE")
-				ELSE OutString("#Dev:Undefined"); out.WriteInt(ORD(vc))
-				END
-			| 2X: WriteString(a, 1, 1, FALSE, FALSE)
-			| 3X: WriteString(a, 1, 2, FALSE, TRUE);
-					SYSTEM.GET(a, vi);
-					IF vi DIV 256 # 0 THEN out.WriteString("  "); WriteString(a, 1, 2, FALSE, FALSE) END
-			| 4X: SYSTEM.GET(a, vsi); out.WriteInt(vsi)
-			| 5X: SYSTEM.GET(a, vi); out.WriteInt(vi)
-			| 6X: SYSTEM.GET(a, vli); out.WriteInt(vli)
-			| 7X: SYSTEM.GET(a, vr); out.WriteReal(vr)
-			| 8X: SYSTEM.GET(a, vlr); out.WriteReal(vlr)
-			| 9X: SYSTEM.GET(a, vs); out.WriteSet(vs)
-			| 0AX: SYSTEM.GET(a, vli); SYSTEM.GET(a + 4, i);
-				IF (vli >= 0) & (i = 0) OR (vli < 0) & (i = -1) THEN out.WriteInt(vli)
-				ELSE out.WriteIntForm(i, TextMappers.hexadecimal, 8, "0", TextMappers.hideBase); WriteHex(vli)
-				END
-			| 0CX, 0DX, 13X, 20X: ShowPointer(a, f, desc, back, tsel)
-			| 0EX, 10X: ShowProcVar(a)
-			| 0FX: WriteString(a, 256, 1, TRUE, FALSE)
-			| 21X: WriteGuid(a)
-			| 22X: SYSTEM.GET(a, vli); WriteHex(vli)
-			ELSE 
-			END
-		END
-	END ShowVar;
-	
-
-	PROCEDURE ShowStack;
-		VAR ref, end, i, j, x, a, b, c: INTEGER; m, f: SHORTCHAR; mod: Kernel.Module; name, sel: Kernel.Name;
-			d: Kernel.Type;
-	BEGIN
-		a := Kernel.pc; b := Kernel.fp; c := 100;
-		REPEAT
-			mod := Kernel.modList;
-			WHILE (mod # NIL) & ((a < mod.code) OR (a >= mod.code + mod.csize)) DO mod := mod.next END;
-			IF mod # NIL THEN
-				DEC(a, mod.code);
-				IF mod.refcnt >= 0 THEN
-					out.WriteChar(" "); out.WriteSString(mod.name); ref := mod.refs;
-					REPEAT Kernel.GetRefProc(ref, end, name) UNTIL (end = 0) OR (a < end);
-					IF a < end THEN
-						out.WriteChar("."); out.WriteSString(name);
-						sel := mod.name$; i := 0;
-						WHILE sel[i] # 0X DO INC(i) END;
-						sel[i] := "."; INC(i); j := 0;
-						WHILE name[j] # 0X DO sel[i] := name[j]; INC(i); INC(j) END;
-						sel[i] := ":"; sel[i+1] := 0X;
-						out.WriteSString("   ["); WriteHex(a);
-						out.WriteSString("] ");
-						i := Kernel.SourcePos(mod, 0);
-						IF name # "$$" THEN
-							Kernel.GetRefVar(ref, m, f, d, x, name);
-							WHILE m # 0X DO
-								IF name[0] # "@" THEN ShowVar(b + x, 0, f, m, d, NIL, NIL, name, sel) END;
-								Kernel.GetRefVar(ref, m, f, d, x, name)
-							END
-						END;
-						out.WriteLn
-					ELSE out.WriteSString(".???"); out.WriteLn
-					END
-				ELSE
-					out.WriteChar("("); out.WriteSString(mod.name);
-					out.WriteSString(")   (pc="); WriteHex(a);
-					out.WriteSString(",  fp="); WriteHex(b); out.WriteChar(")");
-					out.WriteLn
-				END
-			ELSE
-				out.WriteSString("<system>   (pc="); WriteHex(a);
-				out.WriteSString(",  fp="); WriteHex(b); out.WriteChar(")");
-				out.WriteLn
-			END;
-			IF (b >= Kernel.fp) & (b < Kernel.stack) THEN
-				SYSTEM.GET(b+4, a);	(* stacked pc *)
-				SYSTEM.GET(b, b);	(* dynamic link *)
-				DEC(a); DEC(c)
-			ELSE c := 0
-			END
-		UNTIL c = 0
-	END ShowStack;
-
-	PROCEDURE (a: Action) Do;	(* delayed trap window open *)
-	BEGIN
-		Kernel.SetTrapGuard(TRUE);
-		OpenViewer(a.text, "#Dev:Trap", NewRuler());
-		Kernel.SetTrapGuard(FALSE);
-	END Do;
-
-	PROCEDURE GetTrapMsg(OUT msg: ARRAY OF CHAR);
-		VAR ref, end, a: INTEGER; mod: Kernel.Module; name: Kernel.Name; head, tail, errstr: ARRAY 32 OF CHAR;
-			key: ARRAY 128 OF CHAR;
-	BEGIN
-		a := Kernel.pc; mod := Kernel.modList;
-		WHILE (mod # NIL) & ((a < mod.code) OR (a >= mod.code + mod.csize)) DO mod := mod.next END;
-		IF mod # NIL THEN
-			DEC(a, mod.code); ref := mod.refs;
-			REPEAT Kernel.GetRefProc(ref, end, name) UNTIL (end = 0) OR (a < end);
-			IF a < end THEN
-				Kernel.SplitName (mod.name$, head, tail);
-				IF head = "" THEN head := "System" END;
-				Strings.IntToString(Kernel.err, errstr);
-				key := tail + "." + name + "." + errstr;
-				Dialog.MapString("#" + head + ":" + key, msg);
-				(* IF key # msg THEN out.WriteString(" " + msg) END; *)
-				IF key = msg THEN msg := "" END;
-			END
-		END
-	END GetTrapMsg;
-
-	PROCEDURE Trap;
-		VAR a0: TextModels.Attributes; action: Action; msg: ARRAY 512 OF CHAR;
-	BEGIN
-		out.ConnectTo(TextModels.dir.New());
-		a0 := out.rider.attr;
-		out.rider.SetAttr(TextModels.NewWeight(a0, Fonts.bold));
-		IF Kernel.err = 129 THEN out.WriteSString("invalid WITH")
-		ELSIF Kernel.err = 130 THEN out.WriteSString("invalid CASE")
-		ELSIF Kernel.err = 131 THEN out.WriteSString("function without RETURN")
-		ELSIF Kernel.err = 132 THEN out.WriteSString("type guard")
-		ELSIF Kernel.err = 133 THEN out.WriteSString("implied type guard")
-		ELSIF Kernel.err = 134 THEN out.WriteSString("value out of range")
-		ELSIF Kernel.err = 135 THEN out.WriteSString("index out of range")
-		ELSIF Kernel.err = 136 THEN out.WriteSString("string too long")
-		ELSIF Kernel.err = 137 THEN out.WriteSString("stack overflow")
-		ELSIF Kernel.err = 138 THEN out.WriteSString("integer overflow")
-		ELSIF Kernel.err = 139 THEN out.WriteSString("division by zero")
-		ELSIF Kernel.err = 140 THEN out.WriteSString("infinite real result")
-		ELSIF Kernel.err = 141 THEN out.WriteSString("real underflow")
-		ELSIF Kernel.err = 142 THEN out.WriteSString("real overflow")
-		ELSIF Kernel.err = 143 THEN out.WriteSString("undefined real result")
-		ELSIF Kernel.err = 144 THEN out.WriteSString("not a number")
-		ELSIF Kernel.err = 200 THEN out.WriteSString("keyboard interrupt")
-		ELSIF Kernel.err = 201 THEN
-			out.WriteSString("NIL dereference")
-		ELSIF Kernel.err = 202 THEN
-			out.WriteSString("illegal instruction: ");
-			out.WriteIntForm(Kernel.val, TextMappers.hexadecimal, 5, "0", TextMappers.showBase)
-		ELSIF Kernel.err = 203 THEN
-			IF (Kernel.val >= -4) & (Kernel.val < 65536) THEN out.WriteSString("NIL dereference (read)")
-			ELSE out.WriteSString("illegal memory read (ad = "); WriteHex(Kernel.val); out.WriteChar(")")
-			END
-		ELSIF Kernel.err = 204 THEN
-			IF (Kernel.val >= -4) & (Kernel.val < 65536) THEN out.WriteSString("NIL dereference (write)")
-			ELSE out.WriteSString("illegal memory write (ad = "); WriteHex(Kernel.val); out.WriteChar(")")
-			END
-		ELSIF Kernel.err = 205 THEN
-			IF (Kernel.val >= -4) & (Kernel.val < 65536) THEN out.WriteSString("NIL procedure call")
-			ELSE out.WriteSString("illegal execution (ad = "); WriteHex(Kernel.val); out.WriteChar(")")
-			END
-		ELSIF Kernel.err = 257 THEN out.WriteSString("out of memory")
-		ELSIF Kernel.err = 10001H THEN out.WriteSString("bus error")
-		ELSIF Kernel.err = 10002H THEN out.WriteSString("address error")
-		ELSIF Kernel.err = 10007H THEN out.WriteSString("fpu error")
-		ELSIF Kernel.err < 0 THEN
-			out.WriteSString("Exception "); out.WriteIntForm(-Kernel.err, TextMappers.hexadecimal, 3, "0", TextMappers.showBase)
-		ELSE
-			out.WriteSString("TRAP "); out.WriteInt(Kernel.err);
-			IF Kernel.err = 126 THEN out.WriteSString("  (not yet implemented)")
-			ELSIF Kernel.err = 125 THEN out.WriteSString("  (call of obsolete procedure)")
-			ELSIF Kernel.err >= 100 THEN out.WriteSString("  (invariant violated)")
-			ELSIF Kernel.err >= 60 THEN out.WriteSString("  (postcondition violated)")
-			ELSIF Kernel.err >= 20 THEN out.WriteSString("  (precondition violated)")
-			END
-		END;
-		GetTrapMsg(msg);
-		IF msg # "" THEN out.WriteLn; out.WriteString(msg) END;
-		out.WriteLn; out.rider.SetAttr(a0);
-		out.WriteLn; ShowStack;
-		NEW(action); action.text := out.rider.Base();
-		Services.DoLater(action, Services.now);
-		out.ConnectTo(NIL)
-	END Trap;
-
-BEGIN
-	Kernel.InstallTrapViewer(Trap);
-	empty := "";
-	path[0].x := refViewSize DIV 2; path[0].y := 0;
-	path[1].x := refViewSize; path[1].y := refViewSize DIV 2;
-	path[2].x := refViewSize DIV 2; path[2].y := refViewSize;
-	path[3].x := 0; path[3].y := refViewSize DIV 2;
-END StdDebug.

BlackBox/Std/Mod/Dialog.txt

@@ -1,297 +0,0 @@
-MODULE StdDialog;
-
-	(* THIS IS TEXT COPY OF BlackBox 1.6-rc6 Std/Mod/Dialog.odc *)
-	(* DO NOT EDIT *)
-
-	IMPORT
-		Kernel, Meta, Strings, Files, Stores, Models, Sequencers, Views,
-		Containers, Dialog, Properties, Documents, Converters, Windows;
-
-
-	TYPE
-		Item* = POINTER TO EXTENSIBLE RECORD
-			next*: Item;
-			item-, string-, filter-: POINTER TO ARRAY OF CHAR;
-			shortcut-: ARRAY 8 OF CHAR;
-			privateFilter-, failed, trapped: BOOLEAN;	(* filter call failed, caused a trap *)
-			res: INTEGER	(* result code of failed filter *)
-		END;
-		
-		FilterProcVal = RECORD (Meta.Value) p: Dialog.GuardProc END;
-		FilterProcPVal = RECORD (Meta.Value) p: PROCEDURE(n: INTEGER; VAR p: Dialog.Par) END;
-
-		ViewHook = POINTER TO RECORD (Views.ViewHook) END;
-
-
-	VAR curItem-: Item;	(** IN parameter for item filters **)
-
-
-	PROCEDURE GetSubLoc* (mod: ARRAY OF CHAR; cat: Files.Name;
-											OUT loc: Files.Locator; OUT name: Files.Name);
-		VAR sub: Files.Name; file: Files.File; type: Files.Type;
-	BEGIN
-		IF (cat[0] = "S") & (cat[1] = "y") & (cat[2] = "m") THEN type := Kernel.symType
-		ELSIF (cat[0] = "C") & (cat[1] = "o") & (cat[2] = "d") & (cat[3] = "e") THEN type := Kernel.objType
-		ELSE type := ""
-		END;
-		Kernel.SplitName(mod, sub, name); Kernel.MakeFileName(name, type);
-		loc := Files.dir.This(sub); file := NIL;
-		IF loc # NIL THEN
-			loc := loc.This(cat);
-			IF sub = "" THEN
-				IF loc # NIL THEN
-					file := Files.dir.Old(loc, name, Files.shared);
-					IF file = NIL THEN loc := NIL END
-				END;
-				IF loc = NIL THEN
-					loc := Files.dir.This("System");
-					IF loc # NIL THEN loc := loc.This(cat) END
-				END
-			END
-		END
-	END GetSubLoc;
-
-
-	PROCEDURE Len (VAR str: ARRAY OF CHAR): INTEGER;
-		VAR i: INTEGER;
-	BEGIN
-		i := 0; WHILE str[i] # 0X DO INC(i) END;
-		RETURN i
-	END Len;
-
-	PROCEDURE AddItem* (i: Item; item, string, filter, shortcut: ARRAY OF CHAR);
-		VAR j: INTEGER; ch: CHAR;
-	BEGIN
-		ASSERT(i # NIL, 20);
-		NEW(i.item, Len(item) + 1);
-		NEW(i.string, Len(string) + 1);
-		NEW(i.filter, Len(filter) + 1);
-		ASSERT((i.item # NIL) & (i.string # NIL) & (i.filter # NIL), 100);
-		i.item^ := item$;
-		i.string^ := string$;
-		i.filter^ := filter$;
-		i.shortcut := shortcut$;
-		j := 0; ch := filter[0]; WHILE (ch # ".") & (ch # 0X) DO INC(j); ch := filter[j] END;
-		i.privateFilter := (j > 0) & (ch = 0X);
-		i.failed := FALSE; i.trapped := FALSE
-	END AddItem;
-
-	PROCEDURE ClearGuards* (i: Item);
-	BEGIN
-		i.failed := FALSE; i.trapped := FALSE
-	END ClearGuards;
-
-	PROCEDURE GetGuardProc (name: ARRAY OF CHAR; VAR i: Meta.Item;
-														VAR par: BOOLEAN; VAR n: INTEGER);
-		VAR j, k: INTEGER; num: ARRAY 32 OF CHAR;
-	BEGIN
-		j := 0;
-		WHILE (name[j] # 0X) & (name[j] # "(") DO INC(j) END;
-		IF name[j] = "(" THEN
-			name[j] := 0X; INC(j); k := 0;
-			WHILE (name[j] # 0X) & (name[j] # ")") DO num[k] := name[j]; INC(j); INC(k) END;
-			IF (name[j] = ")") & (name[j+1] = 0X) THEN
-				num[k] := 0X; Strings.StringToInt(num, n, k);
-				IF k = 0 THEN Meta.LookupPath(name, i); par := TRUE
-				ELSE Meta.Lookup("", i)
-				END
-			ELSE Meta.Lookup("", i)
-			END
-		ELSE
-			Meta.LookupPath(name, i); par := FALSE
-		END
-	END GetGuardProc;
-	
-	PROCEDURE CheckFilter* (i: Item; VAR failed, ok: BOOLEAN; VAR par: Dialog.Par);
-		VAR x: Meta.Item; v: FilterProcVal; vp: FilterProcPVal; p: BOOLEAN; n: INTEGER;
-	BEGIN
-		IF ~i.failed THEN
-			curItem := i;
-			par.disabled := FALSE; par.checked := FALSE; par.label := i.item$;
-			par.undef := FALSE; par.readOnly := FALSE;
-			i.failed := TRUE; i.trapped := TRUE;
-			GetGuardProc(i.filter^, x, p, n);
-			IF (x.obj = Meta.procObj) OR (x.obj = Meta.varObj) & (x.typ = Meta.procTyp) THEN
-				IF p THEN
-					x.GetVal(vp, ok);
-					IF ok THEN vp.p(n, par) END
-				ELSE
-					x.GetVal(v, ok);
-					IF ok THEN v.p(par) END
-				END
-			ELSE ok := FALSE
-			END;
-			IF ok THEN i.res := 0 ELSE i.res := 1 END;
-			i.trapped := FALSE; i.failed := ~ok
-		END;
-		failed := i.failed
-	END CheckFilter;
-
-	PROCEDURE HandleItem* (i: Item);
-		VAR res: INTEGER;
-	BEGIN
-		IF ~i.failed THEN
-			Views.ClearQueue; res := 0;
-			Dialog.Call(i.string^, " ", res)
-		ELSIF (i # NIL) & i.failed THEN
-			IF i.trapped THEN
-				Dialog.ShowParamMsg("#System:ItemFilterTrapped", i.string^, i.filter^, "")
-			ELSE
-				Dialog.ShowParamMsg("#System:ItemFilterNotFound", i.string^, i.filter^, "")
-			END
-		END
-	END HandleItem;
-
-	PROCEDURE RecalcView* (v: Views.View);
-	(* recalc size of all subviews of v, then v itself *)
-	VAR m: Models.Model; v1: Views.View; c: Containers.Controller;
-		minW, maxW, minH, maxH, w, h, w0, h0: INTEGER;
-	BEGIN
-		IF v IS Containers.View THEN
-			c := v(Containers.View).ThisController();
-			IF c # NIL THEN
-				v1 := NIL; c.GetFirstView(Containers.any, v1);
-				WHILE v1 # NIL DO
-					RecalcView(v1);
-					c.GetNextView(Containers.any, v1)
-				END
-			END
-		END;
-		IF v.context # NIL THEN
-			m := v.context.ThisModel();
-			IF (m # NIL) & (m IS Containers.Model) THEN
-				m(Containers.Model).GetEmbeddingLimits(minW, maxW, minH, maxH);
-				v.context.GetSize(w0, h0); w := w0; h := h0;
-				Properties.PreferredSize(v, minW, maxW, minH, maxH, w, h, w, h);
-				IF (w # w0) OR (h # h0) THEN v.context.SetSize(w, h) END
-			END
-		END
-	END RecalcView;
-
-
-	PROCEDURE Open* (v: Views.View; title: ARRAY OF CHAR;
-									loc: Files.Locator; name: Files.Name; conv: Converters.Converter;
-									asTool, asAux, noResize, allowDuplicates, neverDirty: BOOLEAN);
-		VAR t: Views.Title; flags, opts: SET; done: BOOLEAN; d: Documents.Document; i: INTEGER;
-			win: Windows.Window; c: Containers.Controller; seq: ANYPTR;
-	BEGIN
-		IF conv = NIL THEN conv := Converters.list END;	(* use document converter *)
-		ASSERT(v # NIL, 20);
-		flags := {}; done := FALSE;
-		IF noResize THEN
-			flags := flags + {Windows.noResize, Windows.noHScroll, Windows.noVScroll}
-		END;
-		IF asTool THEN INCL(flags, Windows.isTool) END;
-		IF asAux THEN INCL(flags, Windows.isAux) END;
-		IF neverDirty THEN INCL(flags, Windows.neverDirty) END;
-		i := 0;
-		WHILE (i < LEN(t) - 1) & (title[i] # 0X) DO t[i] := title[i]; INC(i) END;
-		t[i] := 0X;
-		IF ~allowDuplicates THEN
-			IF ~asTool & ~asAux THEN
-				IF (loc # NIL) & (name # "") THEN Windows.SelectBySpec(loc, name, conv, done) END
-			ELSE
-				IF title # "" THEN Windows.SelectByTitle(v, flags, t, done) END
-			END
-		ELSE
-			INCL(flags, Windows.allowDuplicates)
-		END;
-		IF ~done THEN
-			IF v IS Documents.Document THEN
-				IF v.context # NIL THEN
-					d := Documents.dir.New(
-								Views.CopyOf(v(Documents.Document).ThisView(), Views.shallow), 
-								Views.undefined, Views.undefined)
-				ELSE
-					d := v(Documents.Document)
-				END;
-				ASSERT(d.context = NIL, 22);
-				v := d.ThisView(); ASSERT(v # NIL, 23)
-			ELSIF v.context # NIL THEN
-				ASSERT(v.context IS Documents.Context, 24);
-				d := v.context(Documents.Context).ThisDoc();
-				IF d.context # NIL THEN
-					d := Documents.dir.New(Views.CopyOf(v, Views.shallow), Views.undefined, Views.undefined)
-				END;
-				ASSERT(d.context = NIL, 25)
-				(*IF d.Domain() = NIL THEN Stores.InitDomain(d, v.Domain()) END (for views opened via Views.Old *)
-			ELSE
-				d := Documents.dir.New(v, Views.undefined, Views.undefined)
-			END;
-			IF asTool OR asAux THEN
-				c := d.ThisController();
-				c.SetOpts(c.opts + {Containers.noSelection})
-			END;
-			ASSERT(d.Domain() = v.Domain(), 100);
-			ASSERT(d.Domain() # NIL, 101);
-			seq := d.Domain().GetSequencer();
-			IF neverDirty & (seq # NIL) THEN
-				ASSERT(seq IS Sequencers.Sequencer, 26);
-				seq(Sequencers.Sequencer).SetDirty(FALSE)
-			END;
-			IF neverDirty THEN
-				(* change "fit to page" to "fit to window" in secondary windows *)
-				c := d.ThisController(); opts := c.opts;
-				IF Documents.pageWidth IN opts THEN
-					opts := opts - {Documents.pageWidth} + {Documents.winWidth}
-				END;
-				IF Documents.pageHeight IN opts THEN
-					opts := opts - {Documents.pageHeight} + {Documents.winHeight}
-				END;
-				c.SetOpts(opts)
-			END;
-			win := Windows.dir.New();
-			IF seq # NIL THEN
-				Windows.dir.OpenSubWindow(win, d, flags, t)
-			ELSE
-				Windows.dir.Open(win, d, flags, t, loc, name, conv)
-			END
-		END
-	END Open;
-	
-	PROCEDURE (h: ViewHook) Open (v: Views.View; title: ARRAY OF CHAR;
-								loc: Files.Locator; name: Files.Name; conv: Converters.Converter;
-								asTool, asAux, noResize, allowDuplicates, neverDirty: BOOLEAN);
-	BEGIN
-		Open(v, title, loc, name, conv, asTool, asAux, noResize, allowDuplicates, neverDirty)
-	END Open;
-
-	PROCEDURE (h: ViewHook) OldView (loc: Files.Locator; name: Files.Name;
-																VAR conv: Converters.Converter): Views.View;
-		VAR w: Windows.Window; s: Stores.Store; c: Converters.Converter;
-	BEGIN
-		ASSERT(loc # NIL, 20); ASSERT(name # "", 21);
-		Kernel.MakeFileName(name, ""); s := NIL;
-		IF loc.res # 77 THEN
-			w := Windows.dir.First(); c := conv;
-			IF c = NIL THEN c := Converters.list END;	(* use document converter *)
-			WHILE (w # NIL) & ((w.loc = NIL) OR (w.name = "") OR (w.loc.res = 77) OR
-											~Files.dir.SameFile(loc, name, w.loc, w.name) OR (w.conv # c)) DO
-				w := Windows.dir.Next(w)
-			END;
-			IF w # NIL THEN s := w.doc.ThisView() END
-		END;
-		IF s = NIL THEN
-			Converters.Import(loc, name, conv, s);
-			IF s # NIL THEN RecalcView(s(Views.View)) END
-		END;
-		IF s # NIL THEN RETURN s(Views.View) ELSE RETURN NIL END
-	END OldView;
-
-	PROCEDURE (h: ViewHook) RegisterView (v: Views.View; 
-															loc: Files.Locator; name: Files.Name; conv: Converters.Converter);
-	BEGIN
-		ASSERT(v # NIL, 20); ASSERT(loc # NIL, 21); ASSERT(name # "", 22);
-		Kernel.MakeFileName(name, "");
-		Converters.Export(loc, name, conv, v)
-	END RegisterView;
-
-	PROCEDURE Init;
-		VAR h: ViewHook;
-	BEGIN
-		NEW(h); Views.SetViewHook(h)
-	END Init;
-
-BEGIN
-	Init
-END StdDialog.

BlackBox/Std/Mod/ETHConv.txt

@@ -1,223 +0,0 @@
-MODULE StdETHConv;
-
-	(* THIS IS TEXT COPY OF BlackBox 1.6-rc6 Std/Mod/ETHConv.odc *)
-	(* DO NOT EDIT *)
-
-	IMPORT
-		Fonts, Files, Stores, Ports, Views,
-		TextModels, TextRulers, TextViews,
-		Stamps := StdStamps, Clocks := StdClocks, StdFolds;
-
-	CONST
-		V2Tag = -4095; (* 01 F0 *)
-		V4Tag = 496; (* F0 01 *)
-
-	TYPE
-		FontDesc = RECORD
-			typeface: Fonts.Typeface;
-			size: INTEGER;
-			style: SET;
-			weight: INTEGER
-		END;
-
-	VAR default: Fonts.Font;
-
-	PROCEDURE Split (name: ARRAY OF CHAR; VAR d: FontDesc);
-		VAR i: INTEGER; ch: CHAR;
-	BEGIN
-		i := 0; ch := name[0];
-		WHILE (ch < "0") OR (ch >"9") DO
-			d.typeface[i] := ch; INC(i); ch := name[i]
-		END;
-		d.typeface[i] := 0X;
-		d.size := 0;
-		WHILE ("0" <= ch) & (ch <= "9") DO
-			d.size := d.size * 10 + (ORD(ch) - 30H); INC(i); ch := name[i]
-		END;
-		CASE ch OF
-		  "b": d.style := {}; d.weight := Fonts.bold
-		| "i": d.style := {Fonts.italic}; d.weight := Fonts.normal
-		| "j": d.style := {Fonts.italic}; d.weight := Fonts.bold
-		| "m": d.style := {}; d.weight := Fonts.bold
-		ELSE d.style := {}; d.weight := Fonts.normal	(* unknown style *)
-		END
-	END Split;
-
-	PROCEDURE ThisFont (name: ARRAY OF CHAR): Fonts.Font; 
-		VAR d: FontDesc;
-	BEGIN
-		Split(name, d);
-		IF d.typeface = "Syntax" THEN d.typeface := default.typeface END;
-		IF d.size = 10 THEN d.size := default.size
-		ELSE d.size := (d.size - 2) * Ports.point
-		END;
-		RETURN Fonts.dir.This(d.typeface, d.size, d.style, d.weight)
-	END ThisFont;
-
-	PROCEDURE ThisChar (ch: CHAR): CHAR;
-	BEGIN
-		CASE ORD(ch) OF
-		  80H: ch := 0C4X | 81H: ch := 0D6X | 82H: ch := 0DCX
-		| 83H: ch := 0E4X | 84H: ch := 0F6X | 85H: ch := 0FCX
-		| 86H: ch := 0E2X | 87H: ch := 0EAX | 88H: ch := 0EEX | 89H: ch := 0F4X | 8AH: ch := 0FBX
-		| 8BH: ch := 0E0X | 8CH: ch := 0E8X | 8DH: ch := 0ECX | 8EH: ch := 0F2X | 8FH: ch := 0F9X
-		| 90H: ch := 0E9X
-		| 91H: ch := 0EBX | 92H: ch := 0EFX
-		| 93H: ch := 0E7X
-		| 94H: ch := 0E1X
-		| 95H: ch := 0F1X
-		| 9BH: ch := TextModels.hyphen
-		| 9FH: ch := TextModels.nbspace
-		| 0ABH: ch := 0DFX
-		ELSE
-			ch := 0BFX	(* use inverted question mark for unknown character codes *)
-		END;
-		RETURN ch
-	END ThisChar;
-	
-	PROCEDURE ^ LoadTextBlock (r: Stores.Reader; t: TextModels.Model);
-	
-	PROCEDURE StdFold (VAR r: Stores.Reader): Views.View;
-		CONST colLeft = 0; colRight = 1; expRight = 2; expLeft = 3;
-		VAR k: BYTE; state: BOOLEAN; hidden: TextModels.Model; fold: StdFolds.Fold;
-	BEGIN
-		r.ReadByte(k);
-		CASE k MOD 4 OF
-			| colLeft: state := StdFolds.collapsed
-			| colRight: state := StdFolds.collapsed
-			| expRight: state := StdFolds.expanded
-			| expLeft: state := StdFolds.expanded
-		END;
-		IF (k MOD 4 IN {colLeft, expLeft}) & (k < 4) THEN
-			hidden := TextModels.dir.New(); LoadTextBlock(r, hidden);
-		ELSE hidden := NIL;
-		END;
-		fold := StdFolds.dir.New(state, "", hidden);
-		RETURN fold;
-	END StdFold;
-	
-	PROCEDURE LoadTextBlock (r: Stores.Reader; t: TextModels.Model);
-		VAR r0: Stores.Reader; wr: TextModels.Writer;
-			org, len: INTEGER; en, ano, i, n: BYTE; col, voff, ch: CHAR; tag: INTEGER;
-			fname: ARRAY 32 OF CHAR;
-			attr: ARRAY 32 OF TextModels.Attributes;
-			mod, proc: ARRAY 32 OF ARRAY 32 OF CHAR;
-
-		PROCEDURE ReadNum (VAR n: INTEGER);
-			VAR s: BYTE; ch: CHAR; y: INTEGER;
-		BEGIN
-			s := 0; y := 0; r.ReadXChar(ch);
-			WHILE ch >= 80X DO
-				INC(y, ASH(ORD(ch)-128, s)); INC(s, 7); r.ReadXChar(ch)
-			END;
-			n := ASH((ORD(ch) + 64) MOD 128 - 64, s) + y
-		END ReadNum;
-
-		PROCEDURE ReadSet (VAR s: SET);
-			VAR x: INTEGER;
-		BEGIN
-			ReadNum(x); s := BITS(x)
-		END ReadSet;
-
-		PROCEDURE Elem (VAR r: Stores.Reader; span: INTEGER);
-			VAR v: Views.View; end, ew, eh, n, indent: INTEGER; eno, version: BYTE;
-				p: TextRulers.Prop; opts: SET;
-		BEGIN
-			r.ReadInt(ew); r.ReadInt(eh); r.ReadByte(eno);
-			IF eno > en THEN en := eno; r.ReadXString(mod[eno]); r.ReadXString(proc[eno]) END;
-			end := r.Pos() + span;
-			IF (mod[eno] = "ParcElems") OR (mod[eno] = "StyleElems") THEN
-				r.ReadByte(version);
-				NEW(p);
-				p.valid := {TextRulers.first .. TextRulers.tabs};
-				ReadNum(indent); ReadNum(p.left);
-				p.first := p.left + indent;
-				ReadNum(n); p.right := p.left + n;
-				ReadNum(p.lead);
-				ReadNum(p.grid);
-				ReadNum(p.dsc); p.asc := p.grid - p.dsc;
-				ReadSet(opts); p.opts.val := {};
-				IF ~(0 IN opts) THEN p.grid := 1 END;
-				IF 1 IN opts THEN INCL(p.opts.val, TextRulers.leftAdjust) END;
-				IF 2 IN opts THEN INCL(p.opts.val, TextRulers.rightAdjust) END;
-				IF 3 IN opts THEN INCL(p.opts.val, TextRulers.pageBreak) END;
-				INCL(p.opts.val, TextRulers.rightFixed);
-				p.opts.mask := {TextRulers.leftAdjust .. TextRulers.pageBreak, TextRulers.rightFixed};
-				ReadNum(n); p.tabs.len := n;
-				i := 0; WHILE i < p.tabs.len DO ReadNum(p.tabs.tab[i].stop); INC(i) END;
-				v := TextRulers.dir.NewFromProp(p);
-				wr.WriteView(v, ew, eh)
-			ELSIF mod[eno] = "StampElems" THEN
-				v := Stamps.New();
-				wr.WriteView(v, ew, eh)
-			ELSIF mod[eno] = "ClockElems" THEN
-				v := Clocks.New();
-				wr.WriteView(v, ew, eh)
-			ELSIF mod[eno] = "FoldElems" THEN
-				v := StdFold(r);
-				wr.WriteView(v, ew, eh);
-			END;
-			r.SetPos(end)
-		END Elem;
-
-	BEGIN
-		(* skip inner text tags (legacy from V2) *)
-		r.ReadXInt(tag);
-		IF tag # V2Tag THEN r.SetPos(r.Pos()-2) END;
-		(* load text block *)
-		org := r.Pos(); r.ReadInt(len); INC(org, len - 2);
-		r0.ConnectTo(r.rider.Base()); r0.SetPos(org);
-		wr := t.NewWriter(NIL); wr.SetPos(0);
-		n := 0; en := 0; r.ReadByte(ano);
-		WHILE ano # 0 DO
-			IF ano > n THEN
-				n := ano; r.ReadXString(fname);
-				attr[n] := TextModels.NewFont(wr.attr, ThisFont(fname))
-			END;
-			r.ReadXChar(col); r.ReadXChar(voff); r.ReadInt(len);
-			wr.SetAttr(attr[ano]);
-			IF len > 0 THEN
-				WHILE len # 0 DO
-					r0.ReadXChar(ch);
-					IF ch >= 80X THEN ch := ThisChar(ch) END;
-					IF (ch >= " ") OR (ch = TextModels.tab) OR (ch = TextModels.line) THEN
-						wr.WriteChar(ch)
-					END;
-					DEC(len)
-				END
-			ELSE
-				Elem(r, -len); r0.ReadXChar(ch)
-			END;
-			r.ReadByte(ano)
-		END;
-		r.ReadInt(len);
-		r.SetPos(r.Pos() + len);
-	END LoadTextBlock;
-
-	PROCEDURE ImportOberon* (f: Files.File): TextModels.Model;
-		VAR r: Stores.Reader; t: TextModels.Model; tag: INTEGER;
-	BEGIN
-		r.ConnectTo(f); r.SetPos(0);
-		r.ReadXInt(tag);
-		IF tag = ORD("o") + 256 * ORD("B") THEN
-			(* ignore file header of Oberon for Windows and DOSOberon files *)
-			r.SetPos(34); r.ReadXInt(tag)
-		END;
-		ASSERT((tag = V2Tag) OR (tag = V4Tag), 100);
-		t := TextModels.dir.New();
-		LoadTextBlock(r, t);
-		RETURN t;
-	END ImportOberon;
-	
-
-	PROCEDURE ImportETHDoc* (f: Files.File; OUT s: Stores.Store);
-		VAR t: TextModels.Model;
-	BEGIN
-		ASSERT(f # NIL, 20);
-		t := ImportOberon(f);
-		IF t # NIL THEN s := TextViews.dir.New(t) END
-	END ImportETHDoc;
-
-BEGIN
-	default := Fonts.dir.Default()
-END StdETHConv.

BlackBox/Std/Mod/Folds.txt

@@ -1,779 +0,0 @@
-MODULE StdFolds;
-
-	(* THIS IS TEXT COPY OF BlackBox 1.6-rc6 Std/Mod/Folds.odc *)
-	(* DO NOT EDIT *)
-
-	IMPORT
-		Domains := Stores, Ports, Stores, Containers, Models, Views, Controllers, Fonts,
-		Properties,Controls,
-		TextModels, TextViews, TextControllers, TextSetters,
-		Dialog, Services;
-
-	CONST
-		expanded* = FALSE; collapsed* = TRUE;
-		minVersion = 0; currentVersion = 0;
-
-		collapseFoldKey = "#Std:Collapse Fold";
-		expandFoldKey = "#Std:Expand Fold";
-		zoomInKey = "#Std:Zoom In";
-		zoomOutKey = "#Std:Zoom Out";
-		expandFoldsKey = "#Std:Expand Folds";
-		collapseFoldsKey = "#Std:Collapse Folds";
-		insertFoldKey = "#Std:Insert Fold";
-		setLabelKey = "#Std:Set Label";
-
-
-	TYPE
-		Label* = ARRAY 32 OF CHAR;
-		
-		Fold* = POINTER TO RECORD (Views.View)
-			leftSide-: BOOLEAN;
-			collapsed-: BOOLEAN;
-			label-: Label; (* valid iff leftSide *)
-			hidden: TextModels.Model (* valid iff leftSide; NIL if no hidden text *)
-		END;
-
-		Directory* = POINTER TO ABSTRACT RECORD END;
-
-		StdDirectory = POINTER TO RECORD (Directory) END;
-
-		FlipOp = POINTER TO RECORD (Domains.Operation)
-			text: TextModels.Model; (* containing text *)
-			leftpos, rightpos: INTEGER (* position of left and right Fold *)
-		END;
-		
-		SetLabelOp = POINTER TO RECORD (Domains.Operation)
-			text: TextModels.Model; (* containing text *)
-			pos: INTEGER; (* position of fold in text *)
-			oldlabel: Label
-		END;
-		
-		Action = POINTER TO RECORD (Services.Action) END;
-
-		
-	VAR
-		dir-, stdDir-: Directory;
-
-		foldData*: RECORD
-			nested*: BOOLEAN;
-			all*: BOOLEAN;
-			findLabel*: Label;
-			newLabel*: Label
-		END;
-
-		iconFont: Fonts.Typeface;
-		leftExp, rightExp, leftColl, rightColl: ARRAY 8 OF SHORTCHAR;
-		coloredBackg: BOOLEAN;
-		action: Action;
-		fingerprint: INTEGER;	(* for the property inspector *)
-
-		PROCEDURE (d: Directory) New* (collapsed: BOOLEAN; label: Label;
-																	hiddenText: TextModels.Model): Fold, NEW, ABSTRACT;
-
-
-	PROCEDURE GetPair (fold: Fold; VAR l, r: Fold);
-		VAR c: Models.Context; text: TextModels.Model; rd: TextModels.Reader; v: Views.View;
-			nest: INTEGER;
-	BEGIN
-		c := fold.context; l := NIL; r := NIL;
-		WITH c: TextModels.Context DO
-			text := c.ThisModel(); rd := text.NewReader(NIL);
-			IF fold.leftSide THEN l := fold;
-				rd.SetPos(c.Pos()+1); nest := 1;
-				REPEAT rd.ReadView(v);
-					IF (v # NIL) & (v IS Fold) THEN
-						IF v(Fold).leftSide THEN INC(nest) ELSE DEC(nest) END
-					END
-				UNTIL (v = NIL) OR (nest = 0);
-				IF v # NIL THEN r := v(Fold) ELSE r := NIL END
-			ELSE r := fold;
-				rd.SetPos(c.Pos()); nest := 1;
-				REPEAT rd.ReadPrevView(v);
-					IF (v # NIL) & (v IS Fold) THEN
-						IF ~v(Fold).leftSide THEN INC(nest) ELSE DEC(nest) END
-					END
-				UNTIL (v = NIL) OR (nest = 0);
-				IF v # NIL THEN l := v(Fold) ELSE l := NIL END
-			END
-		ELSE (* fold not embedded in a text *)
-		END;
-		ASSERT((l = NIL) OR l.leftSide & (l.hidden # NIL), 100);
-		ASSERT((r = NIL) OR ~r.leftSide & (r.hidden = NIL), 101)
-	END GetPair;
-
-	PROCEDURE (fold: Fold) HiddenText* (): TextModels.Model, NEW;
-		VAR l, r: Fold;
-	BEGIN
-		IF fold.leftSide THEN RETURN fold.hidden
-		ELSE GetPair(fold, l, r);
-			IF l # NIL THEN RETURN l.hidden ELSE RETURN NIL END
-		END
-	END HiddenText;
-
-	PROCEDURE (fold: Fold) MatchingFold* (): Fold, NEW;
-		VAR l, r: Fold;
-	BEGIN
-		GetPair(fold, l, r);
-		IF l # NIL THEN
-			IF fold = l THEN RETURN r ELSE RETURN l END
-		ELSE RETURN NIL
-		END
-	END MatchingFold;
-
-	PROCEDURE GetIcon (fold: Fold; VAR icon: ARRAY OF SHORTCHAR);
-	BEGIN
-		IF fold.leftSide THEN
-			IF fold.collapsed THEN icon := leftColl$ ELSE icon := leftExp$ END
-		ELSE
-			 IF fold.collapsed THEN icon := rightColl$ ELSE icon := rightExp$ END
-		END
-	END GetIcon;
-
-	PROCEDURE CalcSize (f: Fold; VAR w, h: INTEGER);
-		VAR icon: ARRAY 8 OF SHORTCHAR; c: Models.Context; a: TextModels.Attributes; font: Fonts.Font;
-			asc, dsc, fw: INTEGER;
-	BEGIN
-		GetIcon(f, icon);
-		c := f.context;
-		IF (c # NIL) & (c IS TextModels.Context) THEN
-			a := c(TextModels.Context).Attr();
-			font := Fonts.dir.This(iconFont, a.font.size, {}, Fonts.normal)
-		ELSE font := Fonts.dir.Default()
-		END;
-		w := font.SStringWidth(icon);
-		font.GetBounds(asc, dsc, fw);
-		h := asc + dsc
-	END CalcSize;
-
-	PROCEDURE Update (f: Fold);
-		VAR w, h: INTEGER;
-	BEGIN
-		CalcSize(f, w, h);
-		f.context.SetSize(w, h);
-		Views.Update(f, Views.keepFrames)
-	END Update;
-
-	PROCEDURE FlipPair (l, r: Fold);
-		VAR text, hidden: TextModels.Model; cl, cr: Models.Context;
-			lpos, rpos: INTEGER;
-	BEGIN
-		IF (l # NIL) & (r # NIL) THEN
-			ASSERT(l.leftSide, 100);
-			ASSERT(~r.leftSide, 101);
-			ASSERT(l.hidden # NIL, 102);
-			ASSERT(r.hidden = NIL, 103);
-			cl := l.context; cr := r.context;
-			text := cl(TextModels.Context).ThisModel();
-			lpos := cl(TextModels.Context).Pos() + 1; rpos := cr(TextModels.Context).Pos();
-			ASSERT(lpos <= rpos, 104);
-			hidden := TextModels.CloneOf(text); 
-			hidden.Insert(0, text, lpos, rpos);
-			text.Insert(lpos, l.hidden, 0, l.hidden.Length());
-			l.hidden := hidden; Stores.Join(l, hidden);
-			l.collapsed := ~l.collapsed;
-			r.collapsed := l.collapsed;
-			Update(l); Update(r);
-			TextControllers.SetCaret(text, lpos)
-		END
-	END FlipPair;
-
-	PROCEDURE (op: FlipOp) Do;
-		VAR rd: TextModels.Reader; left, right: Views.View;
-	BEGIN
-		rd := op.text.NewReader(NIL);
-		rd.SetPos(op.leftpos); rd.ReadView(left);
-		rd.SetPos(op.rightpos); rd.ReadView(right);
-		FlipPair(left(Fold), right(Fold));
-		op.leftpos := left.context(TextModels.Context).Pos();
-		op.rightpos := right.context(TextModels.Context).Pos()
-	END Do;
-
-	PROCEDURE (op: SetLabelOp) Do;
-		VAR rd: TextModels.Reader; fold: Views.View; left, right: Fold; lab: Label;
-	BEGIN
-		rd := op.text.NewReader(NIL);
-		rd.SetPos(op.pos); rd.ReadView(fold);
-		WITH fold: Fold DO
-			GetPair(fold, left, right);
-			IF left # NIL THEN
-				lab := fold.label; left.label := op.oldlabel; op.oldlabel := lab;
-				right.label := left.label
-			END
-		END
-	END Do;
-
-	PROCEDURE SetProp (fold: Fold; p : Properties.Property);
-		VAR op: SetLabelOp; left, right: Fold;
-	BEGIN
-		WHILE p # NIL DO
-			WITH p: Controls.Prop DO
-				IF (Controls.label IN p.valid) & (p.label # fold.label) THEN
-					GetPair(fold, left, right);
-					IF left # NIL THEN
-						NEW(op); op.oldlabel := p.label$;
-						op.text := fold.context(TextModels.Context).ThisModel();
-						op.pos := fold.context(TextModels.Context).Pos();
-						Views.Do(fold, setLabelKey, op)
-					END
-				END
-			ELSE
-			END;
-			p := p.next
-		END
-	END SetProp;
-
-	PROCEDURE (fold: Fold) Flip*, NEW;
-		VAR op: FlipOp; left, right: Fold;
-	BEGIN
-		ASSERT(fold # NIL, 20);
-		NEW(op);
-		GetPair(fold, left, right);
-		IF (left # NIL) & (right # NIL) THEN
-			op.text := fold.context(TextModels.Context).ThisModel();
-			op.leftpos := left.context(TextModels.Context).Pos();
-			op.rightpos := right.context(TextModels.Context).Pos();
-			Views.BeginModification(Views.clean, fold);
-			IF ~left.collapsed THEN Views.Do(fold, collapseFoldKey, op)
-			ELSE Views.Do(fold, expandFoldKey, op)
-			END;
-			Views.EndModification(Views.clean, fold)
-		END
-	END Flip;
-
-	PROCEDURE ReadNext (rd: TextModels.Reader; VAR fold: Fold);
-		VAR v: Views.View;
-	BEGIN
-		REPEAT rd.ReadView(v) UNTIL rd.eot OR (v IS Fold);
-		IF ~rd.eot THEN fold := v(Fold) ELSE fold := NIL END
-	END ReadNext;
-
-	PROCEDURE (fold: Fold) FlipNested*, NEW;
-		VAR text: TextModels.Model; rd: TextModels.Reader; l, r: Fold; level: INTEGER;
-			op: Domains.Operation;
-	BEGIN
-		ASSERT(fold # NIL, 20);
-		GetPair(fold, l, r);
-		IF (l # NIL) & (l.context # NIL) & (l.context IS TextModels.Context) THEN
-			text := l.context(TextModels.Context).ThisModel();
-			Models.BeginModification(Models.clean, text);
-			rd := text.NewReader(NIL);
-			rd.SetPos(l.context(TextModels.Context).Pos());
-			IF l.collapsed THEN
-				Models.BeginScript(text, expandFoldsKey, op);
-				ReadNext(rd, fold); level := 1;
-				WHILE (fold # NIL) & (level > 0) DO
-					IF fold.leftSide & fold.collapsed THEN fold.Flip END;
-					ReadNext(rd, fold);
-					IF fold.leftSide THEN INC(level) ELSE DEC(level) END
-				END
-			ELSE (* l.state = expanded *)
-				Models.BeginScript(text, collapseFoldsKey, op);
-				level := 0;
-				REPEAT ReadNext(rd, fold);
-					IF fold.leftSide THEN INC(level) ELSE DEC(level) END;
-					IF (fold # NIL) & ~fold.leftSide & ~fold.collapsed THEN
-						fold.Flip;
-						rd.SetPos(fold.context(TextModels.Context).Pos()+1)
-					END
-				UNTIL (fold = NIL) OR (level = 0)
-			END;
-			Models.EndScript(text, op);
-			Models.EndModification(Models.clean, text)
-		END
-	END FlipNested;
-
-	PROCEDURE (fold: Fold) HandlePropMsg- (VAR msg: Properties.Message);
-		VAR prop: Controls.Prop; c: Models.Context; a: TextModels.Attributes; asc, w: INTEGER;
-	BEGIN
-		WITH msg: Properties.SizePref DO
-			CalcSize(fold, msg.w, msg.h)
-		| msg: Properties.ResizePref DO
-			msg.fixed := TRUE
-		| msg: Properties.FocusPref DO msg.hotFocus := TRUE
-		| msg: Properties.PollMsg DO NEW(prop);
-			prop.known := {Controls.label}; prop.valid := {Controls.label}; prop.readOnly := {};
-			prop.label := fold.label$;
-			msg.prop := prop
-		| msg: Properties.SetMsg DO SetProp(fold, msg.prop)
-		| msg: TextSetters.Pref DO c := fold.context;
-			IF (c # NIL) & (c IS TextModels.Context) THEN
-				a := c(TextModels.Context).Attr();
-				a.font.GetBounds(asc, msg.dsc, w)
-			END
-		ELSE
-		END
-	END HandlePropMsg;
-
-	PROCEDURE Track (fold: Fold; f: Views.Frame; x, y: INTEGER; buttons: SET; VAR hit: BOOLEAN);
-		VAR a: TextModels.Attributes; font: Fonts.Font; c: Models.Context;
-			w, h, asc, dsc, fw: INTEGER; isDown, in, in0: BOOLEAN; modifiers: SET;
-	BEGIN
-		c := fold.context; hit := FALSE;
-		WITH c: TextModels.Context DO
-			a := c.Attr(); font := a.font;
-			c.GetSize(w, h); in0 := FALSE;
-			in := (0 <= x) & (x < w) & (0 <= y) & (y < h);
-			REPEAT
-				IF in # in0 THEN
-					f.MarkRect(0, 0, w, h, Ports.fill, Ports.hilite, FALSE); in0 := in
-				END;
-				f.Input(x, y, modifiers, isDown);
-				in := (0 <= x) & (x < w) & (0 <= y) & (y < h)
-			UNTIL ~isDown;
-			IF in0 THEN hit := TRUE;
-				font.GetBounds(asc, dsc, fw);
-				f.MarkRect(0, 0, w, asc + dsc, Ports.fill, Ports.hilite, FALSE)
-			END
-		ELSE
-		END
-	END Track;
-
-		PROCEDURE (fold: Fold) HandleCtrlMsg* (f: Views.Frame; VAR msg: Views.CtrlMessage;
-																							VAR focus: Views.View);
-			VAR hit: BOOLEAN; pos: INTEGER; l, r: Fold;
-				context: TextModels.Context; text: TextModels.Model;
-		BEGIN
-			WITH msg: Controllers.TrackMsg DO
-				IF fold.context IS TextModels.Context THEN
-					Track(fold, f, msg.x, msg.y, msg.modifiers, hit);
-					IF hit THEN
-						IF Controllers.modify IN msg.modifiers THEN
-							fold.FlipNested
-						ELSE
-							fold.Flip;
-							context := fold.context(TextModels.Context);
-							text := context.ThisModel();
-							IF TextViews.FocusText() = text THEN
-								GetPair(fold, l, r);
-								pos := context.Pos();
-								IF fold = l THEN
-									TextControllers.SetCaret(text, pos + 1)
-								ELSE
-									TextControllers.SetCaret(text, pos)
-								END;
-								TextViews.ShowRange(text, pos, pos + 1, TRUE)
-							END
-						END
-					END
-				END
-			| msg: Controllers.PollCursorMsg DO
-				msg.cursor := Ports.refCursor
-			ELSE
-			END
-		END HandleCtrlMsg;
-
-	PROCEDURE (fold: Fold) Restore* (f: Views.Frame; l, t, r, b: INTEGER);
-		VAR a: TextModels.Attributes; color: Ports.Color; c: Models.Context; font: Fonts.Font;
-			icon: ARRAY 8 OF SHORTCHAR; w, h: INTEGER; asc, dsc, fw: INTEGER;
-	BEGIN
-		GetIcon(fold, icon); c := fold.context;
-		IF (c # NIL) & (c IS TextModels.Context) THEN
-			a := fold.context(TextModels.Context).Attr();
-			font := Fonts.dir.This(iconFont, a.font.size, {}, Fonts.normal);
-			color := a.color
-		ELSE font := Fonts.dir.Default(); color := Ports.black
-		END;
-		IF coloredBackg THEN
-			fold.context.GetSize(w, h);
-			f.DrawRect(f.l, f.dot, f.r, h-f.dot, Ports.fill, Ports.grey50);
-			color := Ports.white
-		END;
-		font.GetBounds(asc, dsc, fw);
-		f.DrawSString(0, asc, color, icon, font)
-	END Restore;
-
-	PROCEDURE (fold: Fold) CopyFromSimpleView- (source: Views.View);
-	BEGIN
-		(* fold.CopyFrom^(source); *)
-		WITH source: Fold DO
-			ASSERT(source.leftSide = (source.hidden # NIL), 100);
-			fold.leftSide := source.leftSide;
-			fold.collapsed := source.collapsed;
-			fold.label := source.label;
-			IF source.hidden # NIL THEN
-				fold.hidden := TextModels.CloneOf(source.hidden); Stores.Join(fold.hidden, fold);
-				fold.hidden.InsertCopy(0, source.hidden, 0, source.hidden.Length())
-			END
-		END
-	END CopyFromSimpleView;
-
-	PROCEDURE (fold: Fold) Internalize- (VAR rd: Stores.Reader);
-		VAR version: INTEGER; store: Stores.Store; xint: INTEGER;
-	BEGIN
-		fold.Internalize^(rd);
-		IF rd.cancelled THEN RETURN END;
-		rd.ReadVersion(minVersion, currentVersion, version);
-		IF rd.cancelled THEN RETURN END;
-		rd.ReadXInt(xint);fold.leftSide := xint = 0;
-		rd.ReadXInt(xint); fold.collapsed := xint = 0;
-		rd.ReadXString(fold.label);
-		rd.ReadStore(store);
-		IF store # NIL THEN fold.hidden := store(TextModels.Model); Stores.Join(fold.hidden, fold)
-		ELSE fold.hidden := NIL
-		END;
-		fold.leftSide := store # NIL
-	END Internalize;
-
-	PROCEDURE (fold: Fold) Externalize- (VAR wr: Stores.Writer);
-		VAR xint: INTEGER;
-	BEGIN
-		fold.Externalize^(wr);
-		wr.WriteVersion(currentVersion);
-		IF fold.hidden # NIL THEN xint := 0 ELSE xint := 1 END;
-		wr.WriteXInt(xint);
-		IF fold.collapsed THEN xint := 0 ELSE xint := 1 END;
-		wr.WriteXInt(xint);
-		wr.WriteXString(fold.label);
-		wr.WriteStore(fold.hidden)
-	END Externalize;
-
-	(* --------------------- expanding and collapsing in focus text ------------------------ *)
-
-	PROCEDURE ExpandFolds* (text: TextModels.Model; nested: BOOLEAN; IN label: ARRAY OF CHAR);
-		VAR op: Domains.Operation; fold, l, r: Fold; rd: TextModels.Reader;
-	BEGIN
-		ASSERT(text # NIL, 20);
-		Models.BeginModification(Models.clean, text);
-		IF nested THEN Models.BeginScript(text, expandFoldsKey, op)
-		ELSE Models.BeginScript(text, zoomInKey, op)
-		END;
-		rd := text.NewReader(NIL); rd.SetPos(0);
-		ReadNext(rd, fold);
-		WHILE ~rd.eot DO
-			IF fold.leftSide & fold.collapsed THEN
-				IF (label = "") OR (label = fold.label) THEN
-					fold.Flip;
-					IF ~nested THEN 
-						GetPair(fold, l, r);
-						rd.SetPos(r.context(TextModels.Context).Pos())
-					END
-				END
-			END;
-			ReadNext(rd, fold)
-		END;
-		Models.EndScript(text, op);
-		Models.EndModification(Models.clean, text)
-	END ExpandFolds;
-
-	PROCEDURE CollapseFolds* (text: TextModels.Model; nested: BOOLEAN; IN label: ARRAY OF CHAR);
-		VAR op: Domains.Operation; fold, r, l: Fold; rd: TextModels.Reader;
-	BEGIN
-		ASSERT(text # NIL, 20);
-		Models.BeginModification(Models.clean, text);
-		IF nested THEN Models.BeginScript(text, collapseFoldsKey, op)
-		ELSE Models.BeginScript(text, zoomOutKey, op)
-		END;
-		rd := text.NewReader(NIL); rd.SetPos(0);
-		ReadNext(rd, fold);
-		WHILE ~rd.eot DO
-			IF ~fold.leftSide & ~fold.collapsed THEN
-				GetPair(fold, l, r);
-				IF (label = "") OR (label = l.label) THEN
-					fold.Flip;
-					GetPair(l, l, r);
-					rd.SetPos(r.context(TextModels.Context).Pos()+1);
-					IF ~nested THEN REPEAT ReadNext(rd, fold) UNTIL rd.eot OR fold.leftSide
-					ELSE ReadNext(rd, fold)
-					END
-				ELSE ReadNext(rd, fold)
-				END
-			ELSE ReadNext(rd, fold)
-			END
-		END;
-		Models.EndScript(text, op);
-		Models.EndModification(Models.clean, text)
-	END CollapseFolds;
-
-	PROCEDURE ZoomIn*;
-		VAR text: TextModels.Model;
-	BEGIN
-		text := TextViews.FocusText();
-		IF text # NIL THEN ExpandFolds(text, FALSE, "") END
-	END ZoomIn;
-
-	PROCEDURE ZoomOut*;
-		VAR text: TextModels.Model;
-	BEGIN
-		text := TextViews.FocusText();
-		IF text # NIL THEN CollapseFolds(text, FALSE, "") END
-	END ZoomOut;
-
-	PROCEDURE Expand*;
-		VAR text: TextModels.Model;
-	BEGIN
-		text := TextViews.FocusText();
-		IF text # NIL THEN ExpandFolds(text, TRUE, "") END
-	END Expand;
-
-	PROCEDURE Collapse*;
-		VAR text: TextModels.Model;
-	BEGIN
-		text := TextViews.FocusText();
-		IF text # NIL THEN CollapseFolds(text, TRUE, "") END
-	END Collapse;
-
-	(* ---------------------- foldData dialogbox --------------------------- *)
-
-	PROCEDURE FindLabelGuard* (VAR par: Dialog.Par);
-	BEGIN
-		par.disabled := (TextViews.Focus() = NIL) OR foldData.all
-	END FindLabelGuard;
-		
-	PROCEDURE SetLabelGuard* ( VAR p : Dialog.Par );
-		VAR v: Views.View;
-	BEGIN
-		Controllers.SetCurrentPath(Controllers.targetPath);
-		v := Containers.FocusSingleton();
-		p.disabled := (v = NIL) OR ~(v IS Fold) OR ~v(Fold).leftSide;
-		Controllers.ResetCurrentPath()
-	END SetLabelGuard;
-
-	PROCEDURE ExpandLabel*;
-		VAR text: TextModels.Model;
-	BEGIN
-		IF foldData.all & (foldData.findLabel # "") THEN
-			foldData.findLabel := ""; Dialog.Update(foldData)
-		END;
-		text := TextViews.FocusText();
-		IF text # NIL THEN
-			IF ~foldData.all THEN ExpandFolds(text, foldData.nested, foldData.findLabel)
-			ELSE ExpandFolds(text, foldData.nested, "")
-			END
-		END
-	END ExpandLabel;
-
-	PROCEDURE CollapseLabel*;
-		VAR text: TextModels.Model;
-	BEGIN
-		IF foldData.all & (foldData.findLabel # "") THEN
-			foldData.findLabel := ""; Dialog.Update(foldData)
-		END;
-		text := TextViews.FocusText();
-		IF text # NIL THEN
-			IF ~foldData.all THEN CollapseFolds(text, foldData.nested, foldData.findLabel)
-			ELSE CollapseFolds(text, foldData.nested, "")
-			END
-		END
-	END CollapseLabel;
-
-	PROCEDURE FindFold(first: BOOLEAN);
-	VAR c : TextControllers.Controller; r: TextModels.Reader; 
-		v : Views.View; pos, i : INTEGER;
-	BEGIN
-		c := TextControllers.Focus();
-		IF c # NIL THEN
-			IF first THEN pos := 0 
-			ELSE
-				pos := c.CaretPos();
-				IF pos = TextControllers.none THEN
-					c.GetSelection(i, pos);
-					IF pos = i THEN pos := 0 ELSE INC(pos) END;
-					pos := MIN(pos, c.text.Length()-1)
-				END
-			END;
-			r := c.text.NewReader(NIL); r.SetPos(pos);
-			REPEAT r.ReadView(v)
-			UNTIL r.eot OR ((v IS Fold) & v(Fold).leftSide) & (foldData.all OR (v(Fold).label$ = foldData.findLabel$));
-			IF r.eot THEN
-				c.SetCaret(0); Dialog.Beep
-			ELSE
-				pos := r.Pos();
-				c.view.ShowRange(pos-1, pos, FALSE);
-				c.SetSelection(pos-1, pos);
-				IF LEN(v(Fold).label) > 0 THEN
-					foldData.newLabel := v(Fold).label
-				END;
-				Dialog.Update(foldData)
-			END
-		ELSE
-			Dialog.Beep
-		END
-	END FindFold;
-
-	PROCEDURE FindNextFold*;
-	BEGIN
-		FindFold(FALSE)
-	END FindNextFold;
-	
-	PROCEDURE FindFirstFold*;
-	BEGIN
-		FindFold(TRUE)
-	END FindFirstFold;
-	
-	PROCEDURE SetLabel*;
-		VAR v: Views.View;
-	BEGIN
-		Controllers.SetCurrentPath(Controllers.targetPath);
-		v := Containers.FocusSingleton();
-		IF (v # NIL) & (v IS Fold) & (LEN(foldData.newLabel) > 0) THEN
-			v(Fold).label := foldData.newLabel
-		ELSE
-			Dialog.Beep
-		END;
-		Controllers.ResetCurrentPath()
-	END SetLabel;
-
-	PROCEDURE (a: Action) Do;
-		VAR v: Views.View; fp: INTEGER;
-	BEGIN
-		Controllers.SetCurrentPath(Controllers.targetPath);
-		v := Containers.FocusSingleton();
-		IF (v = NIL) OR ~(v IS Fold) THEN 
-			fingerprint := 0;
-			foldData.newLabel := ""
-		ELSE 
-			fp := Services.AdrOf(v);
-			IF fp # fingerprint THEN 
-				foldData.newLabel := v(Fold).label;
-				fingerprint := fp;
-				Dialog.Update(foldData)
-			END
-		END;
-		Controllers.ResetCurrentPath();
-		Services.DoLater(action, Services.Ticks() + Services.resolution DIV 2)
-	END Do;
-
-	(* ------------------------ inserting folds ------------------------ *)
-		
-	PROCEDURE Overlaps* (text: TextModels.Model; beg, end: INTEGER): BOOLEAN;
-		VAR n, level: INTEGER; rd: TextModels.Reader; v: Views.View;
-	BEGIN
-		ASSERT(text # NIL, 20);
-		ASSERT((beg >= 0) & (end <= text.Length()) & (beg <= end), 21);
-		rd := text.NewReader(NIL); rd.SetPos(beg);
-		n := 0; level := 0;
-		REPEAT rd.ReadView(v);
-			IF ~rd.eot & (rd.Pos() <= end) THEN
-				WITH v: Fold DO INC(n);
-					IF v.leftSide THEN INC(level) ELSE DEC(level) END
-				ELSE
-				END
-			END
-		UNTIL rd.eot OR (level < 0) OR (rd.Pos() >= end);
-		RETURN (level # 0) OR ODD(n)
-	END Overlaps;
-
-	PROCEDURE InsertionAttr (text: TextModels.Model; pos: INTEGER): TextModels.Attributes;
-		VAR rd: TextModels.Reader; ch: CHAR;
-	BEGIN
-		rd := text.NewReader(NIL);
-		rd.SetPos(pos); rd.ReadChar(ch);
-		RETURN rd.attr
-	END InsertionAttr;
-
-	PROCEDURE Insert* (text: TextModels.Model; label: Label; beg, end: INTEGER; collapsed: BOOLEAN);
-		VAR w: TextModels.Writer; fold: Fold; insop: Domains.Operation; a: TextModels.Attributes;
-	BEGIN
-		ASSERT(text # NIL, 20);
-		ASSERT((beg >= 0) & (end <= text.Length()) & (beg <= end), 21);
-		a := InsertionAttr(text, beg);
-		w := text.NewWriter(NIL); w.SetPos(beg);
-		IF a # NIL THEN w.SetAttr(a) END;
-		NEW(fold);
-		fold.leftSide := TRUE; fold.collapsed := collapsed;
-		fold.hidden := TextModels.CloneOf(text); Stores.Join(fold, fold.hidden);
-		fold.label := label$;
-		Models.BeginScript(text, insertFoldKey, insop);
-		w.WriteView(fold, 0, 0);
-		w.SetPos(end+1);
-		a := InsertionAttr(text, end+1);
-		IF a # NIL THEN w.SetAttr(a) END;
-		NEW(fold);
-		fold.leftSide := FALSE; fold.collapsed := collapsed;
-		fold.hidden := NIL; fold.label := "";
-		w.WriteView(fold, 0, 0);
-		Models.EndScript(text, insop)
-	END Insert;
-
-	PROCEDURE CreateGuard* (VAR par: Dialog.Par);
-		VAR c: TextControllers.Controller; beg, end: INTEGER;
-	BEGIN c := TextControllers.Focus();
-		IF (c # NIL) &  ~(Containers.noCaret IN c.opts) THEN
-			IF c.HasSelection() THEN c.GetSelection(beg, end);
-				IF Overlaps(c.text, beg, end) THEN par.disabled := TRUE END
-			END
-		ELSE par.disabled := TRUE
-		END
-	END CreateGuard;
-
-	PROCEDURE Create* (state: INTEGER);	(* menu cmd parameters don't accept Booleans *)
-		VAR c: TextControllers.Controller; beg, end: INTEGER; collapsed: BOOLEAN;
-	BEGIN
-		collapsed := state = 0;
-		c := TextControllers.Focus();
-		IF (c # NIL) & ~(Containers.noCaret IN c.opts) THEN
-			IF c.HasSelection() THEN c.GetSelection(beg, end);
-				IF ~Overlaps(c.text, beg, end) THEN Insert(c.text, "", beg, end, collapsed) END
-			ELSE beg := c.CaretPos(); Insert(c.text, "", beg, beg, collapsed)
-			END
-		END
-	END Create;
-
-	PROCEDURE InitIcons;
-		VAR font: Fonts.Font;
-
-		PROCEDURE DefaultAppearance;
-		BEGIN
-			font := Fonts.dir.Default(); iconFont := font.typeface$;
-			leftExp := ">"; rightExp := "<";
-			leftColl := "=>"; rightColl := "<=";
-			coloredBackg := TRUE
-		END DefaultAppearance;
-
-	BEGIN
-		IF Dialog.platform = Dialog.linux THEN (* Linux *)
-			DefaultAppearance; 
-			coloredBackg := FALSE
-		ELSIF Dialog.platform DIV 10 = 1 THEN (* Windows *)
-			iconFont := "Wingdings";
-			font := Fonts.dir.This(iconFont, 10*Fonts.point (*arbitrary*), {}, Fonts.normal);
-			IF font.IsAlien() THEN DefaultAppearance
-			ELSE
-				leftExp[0] := SHORT(CHR(240)); leftExp[1] := 0X;
-				rightExp[0] := SHORT(CHR(239)); rightExp[1] := 0X;
-				leftColl[0] := SHORT(CHR(232)); leftColl[1] := 0X;
-				rightColl[0] := SHORT(CHR(231)); rightColl[1] := 0X;
-				coloredBackg := FALSE
-			END
-		ELSIF Dialog.platform DIV 10 = 2 THEN (* Mac *)
-			iconFont := "Chicago";
-			font := Fonts.dir.This(iconFont, 10*Fonts.point (*arbitrary*), {}, Fonts.normal);
-			IF font.IsAlien() THEN DefaultAppearance
-			ELSE
-				leftExp := ">"; rightExp := "<";
-				leftColl := "»"; rightColl := "«";
-				coloredBackg := TRUE
-			END
-		ELSE
-			DefaultAppearance
-		END
-	END InitIcons;
-
-	PROCEDURE (d: StdDirectory) New (collapsed: BOOLEAN; label: Label;
-																hiddenText: TextModels.Model): Fold;
-		VAR fold: Fold;
-	BEGIN
-		NEW(fold); fold.leftSide := hiddenText # NIL; fold.collapsed := collapsed;
-		fold.label := label; fold.hidden := hiddenText; 
-		IF hiddenText # NIL THEN Stores.Join(fold, fold.hidden) END;
-		RETURN fold
-	END  New;
-
-	PROCEDURE SetDir* (d: Directory);
-	BEGIN
-		ASSERT(d # NIL, 20);
-		dir := d
-	END SetDir;
-
-	PROCEDURE InitMod;
-		VAR d: StdDirectory;
-	BEGIN
-		foldData.all := TRUE; foldData.nested := FALSE; foldData.findLabel := ""; foldData.newLabel := "";
-		NEW(d); dir := d; stdDir := d;
-		InitIcons;
-		NEW(action); Services.DoLater(action, Services.now);
-	END InitMod;
-
-BEGIN
-	InitMod
-END StdFolds.

BlackBox/Std/Mod/Headers.txt

@@ -1,436 +0,0 @@
-MODULE StdHeaders;
-
-	(* THIS IS TEXT COPY OF BlackBox 1.6-rc6 Std/Mod/Headers.odc *)
-	(* DO NOT EDIT *)
-
-(* headers / footers support the following macros:
-
-			&p - replaced by current page number as arabic numeral
-			&r - replaced by current page number as roman numeral
-			&R - replaced by current page number as capital roman numeral
-			&a - replaced by current page number as alphanumeric character
-			&A - replaced by current page number as capital alphanumeric character
-			&d - replaced by printing date 
-			&t - replaced by printing time
-			&&- replaced by & character
-			&; - specifies split point
-			&f - filename with path/title
-
-*)
-
-	IMPORT
-		Stores, Ports, Models, Views, Properties, Printing, TextModels, Fonts, Dialog,
-		TextViews, Dates, Windows, Controllers, Containers;
-
-	CONST
-		minVersion = 0; maxVersion = 2;
-		mm = Ports.mm; point = Ports.point;
-		maxWidth = 10000 * mm;
-		alternate* = 0; number* = 1; head* = 2; foot* = 3; showFoot* = 4;
-
-	TYPE
-		Banner* = RECORD
-			left*, right*: ARRAY 128 OF CHAR;
-			gap*: INTEGER
-		END;
-		
-		NumberInfo* = RECORD
-			new*: BOOLEAN;
-			first*: INTEGER
-		END;
-		
-		View = POINTER TO RECORD (Views.View)
-			alternate: BOOLEAN;	(* alternate left/right *)
-			number: NumberInfo;	(* new page number *)
-			head, foot: Banner;
-			font: Fonts.Font;
-			showFoot: BOOLEAN;
-		END;
-
-		Prop* = POINTER TO RECORD (Properties.Property)
-			alternate*, showFoot*: BOOLEAN;
-			number*: NumberInfo;
-			head*, foot*: Banner
-		END;
-
-		ChangeFontOp = POINTER TO RECORD (Stores.Operation)
-			header: View;
-			font: Fonts.Font
-		END;
-
-		ChangeAttrOp = POINTER TO RECORD (Stores.Operation)
-			header: View;
-			alternate, showFoot: BOOLEAN;
-			number: NumberInfo;
-			head, foot: Banner
-		END;
-
-	VAR
-		dialog*: RECORD
-			view: View;
-			alternate*, showFoot*: BOOLEAN;
-			number*: NumberInfo;
-			head*, foot*: Banner;
-		END;
-		
-	PROCEDURE (p: Prop) IntersectWith* (q: Properties.Property; OUT equal: BOOLEAN);
-		VAR valid: SET;
-		PROCEDURE Equal(IN b1, b2: Banner): BOOLEAN;
-		BEGIN
-			RETURN (b1.left = b2.left) & (b1.right = b2.right) & (b1.gap = b2.gap)
-		END Equal;
-	BEGIN
-		WITH q: Prop DO
-			valid := p.valid * q.valid; equal := TRUE;
-			IF p.alternate # q.alternate THEN EXCL(valid, alternate) END;
-			IF p.showFoot # q.showFoot THEN EXCL(valid, showFoot) END;
-			IF (p.number.new # q.number.new) OR (p.number.first # q.number.first) THEN EXCL(valid, number) END;
-			IF ~Equal(p.head, q.head) THEN EXCL(valid, head) END;
-			IF ~Equal(p.foot, q.foot) THEN EXCL(valid, foot) END;
-			IF p.valid # valid THEN p.valid := valid; equal := FALSE END
-		END
-	END IntersectWith;
-		
-	(* SetAttrOp *)
-
-	PROCEDURE (op: ChangeFontOp) Do;
-		VAR v: View; font: Fonts.Font; asc, dsc, w: INTEGER; c: Models.Context;
-	BEGIN
-		v := op.header;
-		font := op.font; op.font := v.font; v.font := font;
-		font.GetBounds(asc, dsc, w);
-		c := v.context;
-		c.SetSize(maxWidth, asc + dsc + 2*point);
-		Views.Update(v, Views.keepFrames)
-	END Do;
-
-	PROCEDURE DoChangeFontOp (v: View; font: Fonts.Font);
-		VAR op: ChangeFontOp;
-	BEGIN
-		IF v.font # font THEN
-			NEW(op); op.header := v; op.font := font;
-			Views.Do(v,   "#System:SetProp", op)
-		END
-	END DoChangeFontOp;
-
-	PROCEDURE (op: ChangeAttrOp) Do;
-		VAR v: View; alternate, showFoot: BOOLEAN; number: NumberInfo; head, foot: Banner;
-	BEGIN
-		v := op.header;
-		alternate := op.alternate; showFoot := op.showFoot; number := op.number; head := op.head; foot := op.foot;
-		op.alternate := v.alternate; op.showFoot := v.showFoot; op.number := v.number; op.head := v.head;
-		op.foot := v.foot;
-		v.alternate := alternate; v.showFoot := showFoot; v.number := number; v.head := head; v.foot := foot;
-		Views.Update(v, Views.keepFrames)
-	END Do;
-
-	PROCEDURE DoChangeAttrOp (v: View; alternate, showFoot: BOOLEAN; number: NumberInfo;
-													head, foot: Banner);
-		VAR op: ChangeAttrOp;
-	BEGIN
-		NEW(op); op.header := v; op.alternate := alternate; op.showFoot := showFoot; 
-		op.number := number; op.head := head; op.foot := foot;
-		Views.Do(v,   "#Std:HeaderChange", op)
-	END DoChangeAttrOp;
-
-	PROCEDURE (v: View) CopyFromSimpleView (source: Views.View);
-	BEGIN
-		WITH source: View DO
-			v.alternate := source.alternate;
-			v.number.new := source.number.new; v.number.first := source.number.first;
-			v.head := source.head;
-			v.foot := source.foot;
-			v.font := source.font;
-			v.showFoot := source.showFoot
-		END
-	END CopyFromSimpleView;
-
-	PROCEDURE (v: View) Externalize (VAR wr: Stores.Writer);
-	BEGIN
-		v.Externalize^(wr);
-		wr.WriteVersion(maxVersion);
-		wr.WriteString(v.head.left);
-		wr.WriteString(v.head.right);
-		wr.WriteInt(v.head.gap);
-		wr.WriteString(v.foot.left);
-		wr.WriteString(v.foot.right);
-		wr.WriteInt(v.foot.gap);
-		wr.WriteString(v.font.typeface);
-		wr.WriteInt(v.font.size);
-		wr.WriteSet(v.font.style);
-		wr.WriteInt(v.font.weight);
-		wr.WriteBool(v.alternate);
-		wr.WriteBool(v.number.new);
-		wr.WriteInt(v.number.first);
-		wr.WriteBool(v.showFoot);
-	END Externalize;
-	
-	PROCEDURE (v: View) Internalize (VAR rd: Stores.Reader);
-		VAR version: INTEGER; typeface: Fonts.Typeface; size: INTEGER; style: SET; weight: INTEGER;
-
-	BEGIN
-		v.Internalize^(rd);
-		IF ~rd.cancelled THEN
-			rd.ReadVersion(minVersion, maxVersion, version);
-			IF ~rd.cancelled THEN
-				IF version = 0 THEN
-					rd.ReadXString(v.head.left);
-					rd.ReadXString(v.head.right); 
-					v.head.gap := 5*mm;
-					rd.ReadXString(v.foot.left);
-					rd.ReadXString(v.foot.right);
-					v.foot.gap := 5*mm;
-					rd.ReadXString(typeface);
-					rd.ReadXInt(size); 
-					v.font := Fonts.dir.This(typeface, size * point, {}, Fonts.normal);
-					rd.ReadXInt(v.number.first);
-					rd.ReadBool(v.number.new);
-					rd.ReadBool(v.alternate)
-				ELSE
-					rd.ReadString(v.head.left);
-					rd.ReadString(v.head.right);
-					rd.ReadInt(v.head.gap);
-					rd.ReadString(v.foot.left);
-					rd.ReadString(v.foot.right);
-					rd.ReadInt(v.foot.gap);
-					rd.ReadString(typeface);
-					rd.ReadInt(size);
-					rd.ReadSet(style);
-					rd.ReadInt(weight);
-					v.font := Fonts.dir.This(typeface, size, style, weight);
-					rd.ReadBool(v.alternate);
-					rd.ReadBool(v.number.new);
-					rd.ReadInt(v.number.first);
-					IF version = 2 THEN rd.ReadBool(v.showFoot) ELSE v.showFoot := FALSE END
-				END
-			END
-		END
-	END Internalize;
-
-	PROCEDURE SetProp(v: View; msg: Properties.SetMsg);
-		VAR p: Properties.Property;
-			typeface: Fonts.Typeface; size: INTEGER; style: SET; weight: INTEGER;
-			alt, sf: BOOLEAN; num: NumberInfo; h, f: Banner;
- 	BEGIN
-		p := msg.prop;
-		WHILE p # NIL DO
-			WITH p: Properties.StdProp DO
-				IF Properties.typeface IN p.valid THEN typeface := p.typeface 
-				ELSE typeface := v.font.typeface
-				END;
-				IF Properties.size IN p.valid THEN size := p.size 
-				ELSE size := v.font.size
-				END;
-				IF Properties.style IN p.valid THEN style := p.style.val
-				ELSE style := v.font.style
-				END;
-				IF Properties.weight IN p.valid THEN weight := p.weight 
-				ELSE weight := v.font.weight
-				END;
-				DoChangeFontOp (v, Fonts.dir.This(typeface, size, style, weight) );
-			| p: Prop DO
-				IF alternate IN p.valid THEN alt := p.alternate ELSE alt := v.alternate END;
-				IF showFoot IN p.valid THEN sf := p.showFoot ELSE sf := v.showFoot END;
-				IF number IN p.valid THEN num := p.number ELSE num := v.number END;
-				IF head IN p.valid THEN h := p.head ELSE h := v.head END;
-				IF foot IN p.valid THEN f := p.foot ELSE f := v.foot END;
-				DoChangeAttrOp(v, alt, sf, num, h, f)
-			ELSE
-			END;
-			p := p.next
-		END
-	END SetProp;
-	
-	PROCEDURE PollProp(v: View; VAR msg: Properties.PollMsg);
-		VAR sp: Properties.StdProp; p: Prop;
-	BEGIN
-		NEW(sp);
-		sp.known := {Properties.size, Properties.typeface, Properties.style, Properties.weight};
-		sp.valid := sp.known;
-		sp.size := v.font.size; sp.typeface := v.font.typeface; 
-		sp.style.val := v.font.style; sp.style.mask := {Fonts.italic, Fonts.underline, Fonts.strikeout};
-		sp.weight := v.font.weight;
-		Properties.Insert(msg.prop, sp);
-		NEW(p);
-		p.known := {alternate, number, head, foot, showFoot}; p.valid := p.known;
-		p.head := v.head; p.foot := v.foot;
-		p.alternate := v.alternate;
-		p.showFoot := v.showFoot;
-		p.number := v.number;
-		Properties.Insert(msg.prop, p)
-	END PollProp;
-	
-	PROCEDURE PageMsg(v: View; msg: TextViews.PageMsg);
-	BEGIN
-		IF Printing.par # NIL THEN
-			Dialog.MapString(v.head.left, Printing.par.header.left);
-			Dialog.MapString(v.head.right, Printing.par.header.right);
-			Dialog.MapString(v.foot.left, Printing.par.footer.left);
-			Dialog.MapString(v.foot.right, Printing.par.footer.right);
-			Printing.par.header.font := v.font;
-			Printing.par.footer.font := v.font;
-			Printing.par.page.alternate := v.alternate;
-			IF v.number.new THEN
-				Printing.par.page.first := v.number.first - msg.current
-			END;
-			Printing.par.header.gap := 5*Ports.mm;
-			Printing.par.footer.gap := 5*Ports.mm
-		END
-	END PageMsg;
-
-	PROCEDURE (v: View) Restore (f: Views.Frame; l, t, r, b: INTEGER);
-		VAR d, w, h: INTEGER; (*line: Line; *)asc, dsc, x0, x1, y: INTEGER;
-			win: Windows.Window; title: Views.Title; dec: BOOLEAN;
-			pw, ph: INTEGER;
-			date: Dates.Date; time: Dates.Time; pageInfo: Printing.PageInfo; banner: Printing.Banner;
-	BEGIN
-		IF Views.IsPrinterFrame(f) THEN (* am drucken *) END;
-
-		v.font.GetBounds(asc, dsc, w);
-
-		win := Windows.dir.First();
-		WHILE (win # NIL) & (win.doc.Domain() # v.Domain()) DO win := Windows.dir.Next(win) END;
-		IF win = NIL THEN title := "(" + Dialog.appName + ")"
-		ELSE win.GetTitle(title)
-		END;
-		d := f.dot; 
-		v.context.GetSize(w, h);
-		win.doc.PollPage(pw, ph, l, t, r, b, dec);
-		w := r - l;
-
-		f.DrawRect(0, 0, w, h, Ports.fill, Ports.grey25);
-		f.DrawRect(0, 0, w, h, 0, Ports.black);
-		
-		x0 := d; x1 := w-2*d; y := asc + d;
-
-		Dates.GetDate(date);
-		Dates.GetTime(time);
-		pageInfo.alternate := FALSE;
-		pageInfo.title := title;
-		banner.font := v.font;		
-		IF v.showFoot THEN
-			banner.gap := v.foot.gap;
-			Dialog.MapString(v.foot.left, banner.left); Dialog.MapString(v.foot.right, banner.right)
-		ELSE
-			banner.gap := v.head.gap;
-			Dialog.MapString(v.head.left, banner.left); Dialog.MapString(v.head.right, banner.right)
-		END;
-		Printing.PrintBanner(f, pageInfo, banner, date, time, x0, x1, y)
-	END Restore;
-
-	PROCEDURE (v: View) HandlePropMsg (VAR msg: Properties.Message);
-		VAR asc, dsc, w: INTEGER;
-	BEGIN
-		WITH msg: Properties.SizePref DO
-			msg.w := maxWidth; 
-			IF msg.h = Views.undefined THEN
-				v.font.GetBounds(asc, dsc, w);
-				msg.h := asc + dsc + 2*point
-			 END
-		| msg: Properties.ResizePref DO
-			msg.fixed := TRUE
-		| msg: TextModels.Pref DO
-			msg.opts := {TextModels.hideable}
-		| msg: Properties.PollMsg DO
-			PollProp(v, msg)
-		| msg: Properties.SetMsg DO
-			SetProp(v, msg)
-		| msg: TextViews.PageMsg DO
-			PageMsg(v, msg)
-		ELSE
-		END
-	END HandlePropMsg;
-	
-	PROCEDURE (v: View) HandleCtrlMsg (f: Views.Frame; VAR msg: Controllers.Message;
-																VAR focus: Views.View);
-	BEGIN
-		WITH msg: Properties.EmitMsg DO Views.HandlePropMsg(v, msg.set)
-		| msg: Properties.CollectMsg DO Views.HandlePropMsg(v, msg.poll)
-		ELSE
-		END
-	END HandleCtrlMsg;
-	
-	PROCEDURE New*(p: Prop; f: Fonts.Font): Views.View;
-		VAR v: View;
-	BEGIN
-		NEW(v);
-		v.head := p.head;
-		v.foot := p.foot;
-		v.number := p.number;
-		v.alternate := p.alternate;
-		v.font := f; 
-		v.showFoot := FALSE;
-		RETURN v;	
-	END New;
-
-	PROCEDURE Deposit*;
-		VAR v: View;
-	BEGIN
-		NEW(v);
-		v.head.left := ""; v.head.right :=  "&d&;&p"; v.head.gap := 5*mm;
-		v.foot.left := ""; v.foot.right := ""; v.foot.gap := 5*mm;
-		v.font := Fonts.dir.Default();
-		v.number.first := 1; v.number.new := FALSE; v.alternate := FALSE; v.showFoot := FALSE;
-		Views.Deposit(v)
-	END Deposit;
-	
-	(* property dialog *)
-	
-	PROCEDURE InitDialog*;
-		VAR  p: Properties.Property;
-	BEGIN
-		Properties.CollectProp(p);
-		WHILE p # NIL DO
-			WITH p: Properties.StdProp DO
-			| p: Prop DO
-				dialog.alternate := p.alternate; dialog.showFoot := p.showFoot;
-				dialog.number := p.number;
-				dialog.head := p.head; dialog.head.gap := dialog.head.gap DIV point;
-				dialog.foot := p.foot; dialog.foot.gap := dialog.foot.gap DIV point;
-				Dialog.Update(dialog)
-			ELSE
-			END;
-			p := p.next
-		END
-	END InitDialog;
-	
-	PROCEDURE Set*;
-		VAR p: Prop;
-	BEGIN
-		NEW(p); p.valid := {alternate, number, head, foot, showFoot};
-		p.alternate := dialog.alternate; p.showFoot := dialog.showFoot;
-		p.number := dialog.number;
-		p.head := dialog.head; p.head.gap := p.head.gap * point;
-		p.foot := dialog.foot; p.foot.gap := p.foot.gap * point;
-		Properties.EmitProp(NIL, p)
-	END Set;
-	
-	PROCEDURE HeaderGuard* (VAR par: Dialog.Par);
-		VAR v: Views.View;
-	BEGIN
-		v := Containers.FocusSingleton();
-		IF (v # NIL) & (v IS View) THEN
-			par.disabled := FALSE;
-			IF (dialog.view = NIL) OR (dialog.view # v) THEN
-				dialog.view := v(View);
-				InitDialog
-			END
-		ELSE
-			par.disabled := TRUE;
-			dialog.view := NIL
-		END
-	END HeaderGuard;
-	
-	PROCEDURE AlternateGuard* (VAR par: Dialog.Par);
-	BEGIN
-		HeaderGuard(par);
-		IF ~par.disabled THEN par.disabled := ~ dialog.alternate END
-	END AlternateGuard;
-	
-	PROCEDURE NewNumberGuard* (VAR par: Dialog.Par);
-	BEGIN
-		HeaderGuard(par);
-		IF ~par.disabled THEN par.disabled := ~ dialog.number.new END
-	END NewNumberGuard;
-	
-END StdHeaders.

BlackBox/Std/Mod/Interpreter.txt

@@ -1,234 +0,0 @@
-MODULE StdInterpreter;
-
-	(* THIS IS TEXT COPY OF BlackBox 1.6-rc6 Std/Mod/Interpreter.odc *)
-	(* DO NOT EDIT *)
-
-	IMPORT Kernel, Meta, Strings, Views, Dialog;
-
-	TYPE
-		IntValue = POINTER TO RECORD (Meta.Value)
-			int: INTEGER;
-		END;
-		StrValue = POINTER TO RECORD (Meta.Value)
-			str: Dialog.String;
-		END;
-		CallHook = POINTER TO RECORD (Dialog.CallHook) END;
-
-		
-	PROCEDURE (hook: CallHook) Call (IN proc, errorMsg: ARRAY OF CHAR; VAR res: INTEGER);
-		TYPE Ident = ARRAY 32 OF CHAR;
-		CONST
-			modNotFound = 10; procNotFound = 11; identExpected = 12; unknownIdent = 13;
-			depositExpected = 14; noDepositExpected = 15; syntaxError = 16;
-			lparenExpected = 17; rparenExpected = 18; containerExpected = 19; quoteExpected = 20;
-			fileNotFound = 21; noController = 22; noDialog = 23; cannotUnload = 24; commaExpected = 25;
-			incompParList = 26;
-		CONST
-			 ident = 0; dot = 1; semicolon = 2; eot = 3; lparen = 4; rparen = 5; quote = 6; comma = 7; int = 8;
-		VAR
-			i, type: INTEGER; ch: CHAR; id: Ident; x: INTEGER;
-			par: ARRAY 100 OF POINTER TO Meta.Value; numPar: INTEGER;
-			
-		PROCEDURE Concat (a, b: ARRAY OF CHAR; VAR c: ARRAY OF CHAR);
-			VAR i, j: INTEGER; ch: CHAR;
-		BEGIN
-			IF a = " " THEN Dialog.MapString("#System:CommandError", c) ELSE c := a$ END;
-			i := 0; WHILE c[i] # 0X DO INC(i) END;
-			c[i] := " "; INC(i);
-			j := 0; ch := b[0]; WHILE ch # 0X DO c[i] := ch; INC(i); INC(j); ch := b[j] END;
-			c[i] := 0X
-		END Concat;
-
-		PROCEDURE Error (n: INTEGER; msg, par0, par1: ARRAY OF CHAR);
-			VAR e, f: ARRAY 256 OF CHAR;
-		BEGIN
-			IF res = 0 THEN
-				res := n;
-				IF errorMsg # "" THEN
-					Dialog.MapString(errorMsg, e);
-					Dialog.MapParamString(msg, par0, par1, "", f);
-					Concat(e, f, f);
-					Dialog.ShowMsg(f)
-				END
-			END
-		END Error;
-		
-		PROCEDURE Init (VAR s: ARRAY OF CHAR);
-			VAR i: INTEGER;
-		BEGIN
-			i := 0; WHILE i < LEN(s) DO s[i] := 0X; INC(i) END
-		END Init;
-		
-		PROCEDURE ShowLoaderResult (IN mod: ARRAY OF CHAR);
-			VAR res: INTEGER; importing, imported, object: ARRAY 256 OF CHAR;
-		BEGIN
-			Kernel.GetLoaderResult(res, importing, imported, object);
-			CASE res OF
-			| Kernel.fileNotFound:
-				Error(Kernel.fileNotFound, "#System:CodeFileNotFound", imported, "")
-			| Kernel.syntaxError:
-				Error(Kernel.syntaxError, "#System:CorruptedCodeFileFor", imported, "")
-			| Kernel.objNotFound:
-				Error(Kernel.objNotFound, "#System:ObjNotFoundImpFrom", imported, importing)
-			| Kernel.illegalFPrint:
-				Error(Kernel.illegalFPrint, "#System:ObjInconsImpFrom", imported, importing)
-			| Kernel.cyclicImport:
-				Error(Kernel.cyclicImport, "#System:CyclicImpFrom", imported, importing)
-			| Kernel.noMem:
-				Error(Kernel.noMem, "#System:NotEnoughMemoryFor", imported, "")
-			ELSE
-				Error(res, "#System:CannotLoadModule", mod, "")
-			END
-		END ShowLoaderResult;
-
-		PROCEDURE CallProc (IN mod, proc: ARRAY OF CHAR);
-			VAR i, t: Meta.Item; ok: BOOLEAN;
-		BEGIN
-			ok := FALSE;
-			Meta.Lookup(mod, i);
-			IF i.obj = Meta.modObj THEN
-				i.Lookup(proc, i);
-				IF i.obj = Meta.procObj THEN
-					i.GetReturnType(t);
-					IF (t.typ = 0) & (i.NumParam() = numPar) THEN
-						i.ParamCallVal(par, t, ok)
-					ELSE ok := FALSE
-					END;
-					IF ~ok THEN
-						Error(incompParList, "#System:IncompatibleParList", mod, proc)
-					END
-				ELSE
-					Error(Kernel.commNotFound, "#System:CommandNotFoundIn", proc, mod)
-				END
-			ELSE
-				ShowLoaderResult(mod)
-			END
-		END CallProc;
-
-		PROCEDURE GetCh;
-		BEGIN
-			IF i < LEN(proc) THEN ch := proc[i]; INC(i) ELSE ch := 0X END
-		END GetCh;
-
-		PROCEDURE Scan;
-			VAR j: INTEGER; num: ARRAY 32 OF CHAR; r: INTEGER;
-		BEGIN
-			IF res = 0 THEN
-				WHILE (ch # 0X) & (ch <= " ") DO GetCh END;
-				IF ch = 0X THEN
-					type := eot
-				ELSIF ch = "." THEN
-					type := dot; GetCh
-				ELSIF ch = ";" THEN
-					type := semicolon; GetCh
-				ELSIF ch = "(" THEN
-					type := lparen; GetCh
-				ELSIF ch = ")" THEN
-					type := rparen; GetCh
-				ELSIF ch = "'" THEN
-					type := quote; GetCh
-				ELSIF ch = "," THEN
-					type := comma; GetCh
-				ELSIF (ch >= "0") & (ch <= "9") OR (ch = "-") THEN
-					type := int; j := 0;
-					REPEAT num[j] := ch; INC(j); GetCh UNTIL (ch < "0") OR (ch > "9") & (ch < "A") OR (ch > "H");
-					num[j] := 0X; Strings.StringToInt(num, x, r)
-				ELSIF (ch >= "a") & (ch <= "z") OR (ch >= "A") & (ch <= "Z") OR
-						(ch >= 0C0X) & (ch # "×") & (ch # "÷") & (ch <= 0FFX) OR (ch = "_") THEN
-					type := ident;
-					id[0] := ch; j := 1; GetCh;
-					WHILE (ch # 0X) & (i < LEN(proc)) &
-								((ch >= "a") & (ch <= "z") OR (ch >= "A") & (ch <= "Z") OR
-								(ch >= 0C0X) & (ch # "×") & (ch # "÷") & (ch <= 0FFX) OR
-								(ch = "_") OR (ch >= "0") & (ch <= "9")) DO
-						id[j] := ch; INC(j); GetCh
-					END;
-					id[j] := 0X
-				ELSE Error(syntaxError, "#System:SyntaxError", "", "")
-				END
-			END
-		END Scan;
-		
-		PROCEDURE String (VAR s: ARRAY OF CHAR);
-			VAR j: INTEGER;
-		BEGIN
-			IF type = quote THEN
-				j := 0;
-				WHILE (ch # 0X) & (ch # "'") & (j < LEN(s) - 1) DO s[j] := ch; INC(j); GetCh END; s[j] := 0X;
-				IF ch = "'" THEN
-					GetCh; Scan
-				ELSE Error(quoteExpected, "#System:QuoteExpected", "", "")
-				END
-			ELSE Error(quoteExpected, "#System:QuoteExpected", "", "")
-			END
-		END String;
-
-		PROCEDURE ParamList ();
-			VAR iv: IntValue; sv: StrValue;
-		BEGIN
-			numPar := 0;
-			IF type = lparen THEN Scan;
-				WHILE (numPar < LEN(par)) & (type # rparen) & (res = 0) DO
-					IF type = quote THEN
-						NEW(sv);
-						String(sv.str);
-						par[numPar] := sv;
-						INC(numPar)
-					ELSIF type = int THEN
-						NEW(iv);
-						iv.int := x; Scan;
-						par[numPar] := iv;
-						INC(numPar)
-					ELSE Error(syntaxError, "#System:SyntaxError", "", "")
-					END;
-					IF type = comma THEN Scan
-					ELSIF type # rparen THEN Error(rparenExpected, "#System:RParenExpected", "", "")
-					END
-				END;
-				Scan
-			END
-		END ParamList;
-
-		PROCEDURE Command;
-			VAR left, right: Ident;
-		BEGIN
-			(* protect from parasitic anchors on stack *)
-			Init(left); Init(right);
-			left := id; Scan;
-			IF type = dot THEN	(* Oberon command *)
-				Scan;
-				IF type = ident THEN
-					right := id; Scan; ParamList();
-					CallProc(left, right)
-				ELSE Error(identExpected, "#System:IdentExpected", "", "")
-				END
-			ELSE Error(unknownIdent, "#System:UnknownIdent", id, "")
-			END
-		END Command;
-
-	BEGIN
-		(* protect from parasitic anchors on stack *)
-		i := 0; type := 0; Init(id); x := 0;
-		Views.ClearQueue;
-		res := 0; i := 0; GetCh;
-		Scan;
-		IF type = ident THEN
-			Command; WHILE (type = semicolon) & (res = 0) DO Scan; Command END;
-			IF type # eot THEN Error(syntaxError, "#System:SyntaxError", "", "") END
-		ELSE Error(syntaxError, "#System:SyntaxError", "", "")
-		END;
-		IF (res = 0) & (Views.Available() > 0) THEN
-			Error(noDepositExpected, "#System:NoDepositExpected", "", "")
-		END;
-		Views.ClearQueue
-	END Call;
-	
-	PROCEDURE Init;
-		VAR hook: CallHook;
-	BEGIN
-		NEW(hook); Dialog.SetCallHook(hook)
-	END Init;
-
-BEGIN
-	Init
-END StdInterpreter.

BlackBox/Std/Mod/Links.txt

@@ -1,893 +0,0 @@
-MODULE StdLinks;
-
-	(* THIS IS TEXT COPY OF BlackBox 1.6-rc6 Std/Mod/Links.odc *)
-
-	IMPORT Kernel, Services,
-		Stores, Ports, Fonts,  Models, Views, Controllers, Properties, Dialog, Containers,
-		TextModels, TextMappers, TextViews, TextControllers, TextSetters, TextRulers,
-		Strings, StdCmds;
-
-	CONST
-		kind* = 0; cmd* = 1; close* = 2;	(* constants for Prop.valid *)
-		always* = 0; ifShiftDown* = 1; never* = 2;	(* constants for close attrubute *)
-		minLinkVersion = 0; maxLinkVersion = 1;
-		minTargVersion = 0; maxTargVersion = 0;
-
-	TYPE
-		Directory* = POINTER TO ABSTRACT RECORD END;
-
-		Link* = POINTER TO RECORD (Views.View)
-			leftSide-: BOOLEAN;
-			cmd: POINTER TO ARRAY OF CHAR;
-			close: INTEGER
-		END;
-
-		Target* = POINTER TO RECORD (Views.View)
-			leftSide-: BOOLEAN;
-			ident: POINTER TO ARRAY OF CHAR
-		END;
-
-		Prop* = POINTER TO RECORD (Properties.Property)
-			cmd*: POINTER TO ARRAY OF CHAR;
-			link-: BOOLEAN;
-			close*: INTEGER
-		END;
-		
-		ChangeAttrOp = POINTER TO RECORD (Stores.Operation)
-			v: Views.View;
-			cmd: POINTER TO ARRAY OF CHAR;
-			close: INTEGER;
-			valid: SET
-		END;
-		
-		StdDirectory = POINTER TO RECORD (Directory) END;
-
-		TrapCleaner = POINTER TO RECORD (Kernel.TrapCleaner) END;
-
-	VAR
-		dir-, stdDir-: Directory;
-		par-: Link;
-		iconFont: Fonts.Typeface;
-		linkLeft, linkRight, targetLeft, targetRight: ARRAY 8 OF SHORTCHAR;
-		coloredBackg: BOOLEAN;
-		
-		cleaner: TrapCleaner;
-
-		dialog*: RECORD
-			cmd*: ARRAY 512 OF CHAR;
-			type-: ARRAY 32 OF CHAR;
-			close*: Dialog.List;
-			known, valid: SET;
-		END;
-		fingerprint: INTEGER;
-
-	(** Cleaner **)
-
-	PROCEDURE (c: TrapCleaner) Cleanup;
-	BEGIN
-		par := NIL
-	END Cleanup;
-
-	(** Properties **)
-
-	PROCEDURE (p: Prop) IntersectWith* (q: Properties.Property; OUT equal: BOOLEAN);
-		VAR valid: SET;
-	BEGIN
-		WITH q: Prop DO
-			valid := p.valid * q.valid; equal := TRUE;
-			IF (cmd IN valid) & (p.cmd^ # q.cmd^) THEN EXCL(valid, cmd) END;
-			IF (kind IN valid) & (p.link # q.link) THEN EXCL(valid, kind) END;
-			IF (close IN valid) & (p.close # q.close) THEN EXCL (valid, close) END;
-			IF p.valid # valid THEN p.valid := valid; equal := FALSE END
-		END
-	END IntersectWith;
-		
-	PROCEDURE (op: ChangeAttrOp) Do;
-		VAR v: Views.View; s: POINTER TO ARRAY OF CHAR; c: INTEGER;
-	BEGIN
-		v := op.v; 
-		WITH 
-		| v: Link DO 
-			IF cmd IN op.valid THEN s := op.cmd; op.cmd := v.cmd; v.cmd := s END;
-			IF close IN op.valid THEN c := op.close; op.close := v.close; v.close := c END
-		| v: Target DO 
-			IF cmd IN op.valid THEN s := op.cmd; op.cmd := v.ident; v.ident := s END
-		END
-	END Do;
-
-	PROCEDURE DoChangeAttrOp (v: Views.View; s: POINTER TO ARRAY OF CHAR; c: INTEGER; valid: SET);
-		VAR op: ChangeAttrOp;
-	BEGIN
-		NEW(op); op.v := v; op.valid := valid;
-		IF close IN valid THEN 
-		op.close := c END;
-		IF cmd IN valid THEN NEW(op.cmd, LEN(s)+1); op.cmd^ := s$ END;
-		Views.Do(v,   "#Std:LinkChange", op)
-	END DoChangeAttrOp;
-	
-	PROCEDURE SetProp(v: Views.View; msg: Properties.SetMsg);
-		VAR p: Properties.Property;
- 	BEGIN
-		p := msg.prop;
-		WHILE p # NIL DO
-			WITH p: Prop DO
-				IF (cmd IN p.valid) OR (close IN p.valid) THEN DoChangeAttrOp(v, p.cmd, p.close, p.valid) END
-			ELSE
-			END;
-			p := p.next
-		END
-	END SetProp;
-	
-	PROCEDURE PollProp(v: Views.View; VAR msg: Properties.PollMsg);
-		VAR p: Prop;
-	BEGIN
-		NEW(p);	
-		WITH v: Link DO
-			p.known := {kind, cmd, close}; 
-			p.link := TRUE;
-			p.cmd := v.cmd;
-			p.close := v.close
-		| v: Target DO
-			p.known := {kind, cmd}; 
-			p.link := FALSE;
-			p.cmd := v.ident
-		ELSE
-		END;
-		p.valid := p.known;
-		Properties.Insert(msg.prop, p)
-	END PollProp;
-	
-	PROCEDURE InitDialog*;
-		VAR  p: Properties.Property;
-	BEGIN
-		dialog.cmd := ""; dialog.type := ""; dialog.close.index := -1;
-		dialog.known := {}; dialog.valid := {};
-		Properties.CollectProp(p);
-		WHILE p # NIL DO
-			WITH p: Prop DO
-				dialog.valid := p.valid; dialog.known := p.known;
-				IF cmd IN p.valid THEN
-					dialog.cmd := p.cmd$
-				END;
-				IF kind IN p.valid THEN 
-					IF p.link THEN Dialog.MapString("#Std:Link", dialog.type)
-					ELSE Dialog.MapString("#Std:Target", dialog.type)
-					END
-				END;
-				IF close IN p.valid THEN
-					dialog.close.index := p.close
-				END
-			ELSE
-			END;
-			p := p.next
-		END;
-		Dialog.Update(dialog)
-	END InitDialog;
-	
-	PROCEDURE Set*;
-		VAR p: Prop;
-	BEGIN
-		NEW(p);
-		p.valid := dialog.valid;
-		IF cmd IN p.valid THEN
-			NEW(p.cmd, LEN(dialog.cmd) + 1);
-			p.cmd^ := dialog.cmd$
-		END;
-		p.close := dialog.close.index;
-		Properties.EmitProp(NIL, p);
-		fingerprint := 0	(* force actualization of fields *)
-	END Set;
-	
-	PROCEDURE CmdGuard* (VAR par: Dialog.Par);
-		VAR c: Containers.Controller; v: Views.View; fp: INTEGER;
-	BEGIN
-		IF ~(cmd IN dialog.known) THEN par.disabled := TRUE
-		ELSIF ~(cmd IN dialog.valid) THEN par.undef := TRUE
-		END;
-		Controllers.SetCurrentPath(Controllers.targetPath);
-		fp := 0;
-		c := Containers.Focus();
-		IF c # NIL THEN
-			c.GetFirstView(Containers.selection, v);
-			WHILE v # NIL DO fp := fp + Services.AdrOf(v); c.GetNextView(TRUE, v) END
-		END;
-		IF fp # fingerprint THEN fingerprint := fp; InitDialog END;
-		Controllers.ResetCurrentPath()
-	END CmdGuard;
-	
-	PROCEDURE CloseGuard* (VAR par: Dialog.Par);
-	BEGIN
-		IF ~(close IN dialog.known) THEN par.disabled := TRUE
-		ELSIF ~(close IN dialog.valid) THEN par.undef := TRUE
-		END;
-	END CloseGuard;
-	
-	PROCEDURE Notifier* (idx, op, from, to: INTEGER);
-	BEGIN
-		IF op = Dialog.changed THEN INCL(dialog.valid, idx) END
-	END Notifier;
-
-	PROCEDURE (d: Directory) NewLink* (IN cmd: ARRAY OF CHAR): Link, NEW, ABSTRACT;
-	PROCEDURE (d: Directory) NewTarget* (IN ident: ARRAY OF CHAR): Target, NEW, ABSTRACT;
-
-
-	PROCEDURE InFrame (f: Views.Frame; x, y: INTEGER): BOOLEAN;
-	BEGIN
-		RETURN (f.l <= x) & (x < f.r) & (f.t <= y) & (y < f.b)
-	END InFrame;
-
-	PROCEDURE Mark (f: Views.Frame; show: BOOLEAN);
-	BEGIN
-		f.MarkRect(f.l, f.t, f.r, f.b, Ports.fill, Ports.hilite, show)
-	END Mark;
-
-	PROCEDURE ThisPos (v: TextViews.View; f: Views.Frame; x, y: INTEGER): INTEGER;
-		(* "corrected" v.ThisPos: does not adjust position when crossing 50% boundary of characters *)
-		VAR loc: TextViews.Location; pos: INTEGER;
-	BEGIN
-		pos := v.ThisPos(f, x, y); v.GetThisLocation(f, pos, loc);
-		IF (loc.y <= y) & (y < loc.y + loc.asc + loc.dsc) & (x < loc.x) THEN DEC(pos) END;
-		RETURN pos
-	END ThisPos;
-
-	PROCEDURE GetLinkPair (this: Link; VAR l, r: Link);
-		(* POST: BalancedPair(l, r) & (l # r) & (l = this OR r = this) OR  (l = r = NIL) *)
-		VAR t: TextModels.Model; rd: TextModels.Reader; v: Views.View; level: INTEGER;
-	BEGIN
-		l := NIL; r := NIL; level := 1;
-		IF (this.context # NIL) & (this.context IS TextModels.Context) THEN
-			t := this.context(TextModels.Context).ThisModel();
-			rd := t.NewReader(NIL);
-			IF this.leftSide THEN
-				rd.SetPos(this.context(TextModels.Context).Pos() + 1);
-				REPEAT
-					rd.ReadView(v);
-					IF (v # NIL) & (v IS Link) THEN
-						IF v(Link).leftSide THEN INC(level) ELSE DEC(level) END
-					END
-				UNTIL (v = NIL) OR (level = 0);
-				IF v # NIL THEN l := this; r := v(Link) END
-			ELSE
-				rd.SetPos(this.context(TextModels.Context).Pos());
-				REPEAT
-					rd.ReadPrevView(v);
-					IF (v # NIL) & (v IS Link) THEN
-						IF v(Link).leftSide THEN DEC(level) ELSE INC(level) END
-					END
-				UNTIL (v = NIL) OR (level = 0);
-				IF v # NIL THEN l := v(Link); r := this END
-			END
-		END
-	END GetLinkPair;
-
-	PROCEDURE GetTargetPair (this: Target; VAR l, r: Target);
-		(* POST: BalancedPair(l, r) & (l # r) & (l = this OR r = this) OR  (l = r = NIL) *)
-		VAR t: TextModels.Model; rd: TextModels.Reader; v: Views.View; level: INTEGER;
-	BEGIN
-		l := NIL; r := NIL; level := 1;
-		IF (this.context # NIL) & (this.context IS TextModels.Context) THEN
-			t := this.context(TextModels.Context).ThisModel();
-			rd := t.NewReader(NIL);
-			IF this.leftSide THEN
-				rd.SetPos(this.context(TextModels.Context).Pos() + 1);
-				REPEAT
-					rd.ReadView(v);
-					IF (v # NIL) & (v IS Target) THEN
-						IF v(Target).leftSide THEN INC(level) ELSE DEC(level) END
-					END
-				UNTIL (v = NIL) OR (level = 0);
-				IF v # NIL THEN l := this; r := v(Target) END
-			ELSE
-				rd.SetPos(this.context(TextModels.Context).Pos());
-				REPEAT
-					rd.ReadPrevView(v);
-					IF (v # NIL) & (v IS Target) THEN
-						IF v(Target).leftSide THEN DEC(level) ELSE INC(level) END
-					END
-				UNTIL (v = NIL) OR (level = 0);
-				IF v # NIL THEN l := v(Target); r := this END
-			END
-		END
-	END GetTargetPair;
-
-	PROCEDURE GetRange (l, r: Link; VAR beg, end: INTEGER);
-	BEGIN
-		beg := l.context(TextModels.Context).Pos();
-		end := r.context(TextModels.Context).Pos() + 1
-	END GetRange;
-
-	PROCEDURE MarkRange (v: TextViews.View; f: Views.Frame; beg, end: INTEGER; show: BOOLEAN);
-		VAR b, e: TextViews.Location; r, t: INTEGER;
-	BEGIN
-		ASSERT(beg < end, 20);
-		v.GetThisLocation(f, beg, b); v.GetThisLocation(f, end, e);
-		IF (b.pos < e.pos) OR (b.pos = e.pos) & (b.x < e.x) THEN
-			IF b.start # e.start THEN
-				r := f.r; t := b.y + b.asc + b.dsc;
-				f.MarkRect(b.x, b.y, r, t, Ports.fill, Ports.hilite, show);
-				IF t < e.y THEN f.MarkRect(0, t, r, e.y, Ports.fill, Ports.hilite, show) END;
-				b.x := f.l; b.y := e.y
-			END;
-		    f.MarkRect(b.x, b.y, e.x, e.y + e.asc + e.dsc, Ports.fill, Ports.hilite, show)
-		END
-	END MarkRange;
-
-	PROCEDURE Reveal (left, right: Views.View; str: ARRAY OF CHAR; opname: Stores.OpName);
-		VAR con: TextModels.Context; t: TextModels.Model; pos: INTEGER;
-			w: TextMappers.Formatter; op: Stores.Operation;
-	BEGIN
-		con := left.context(TextModels.Context);
-		t := con.ThisModel(); pos := con.Pos();
-		w.ConnectTo(t); w.SetPos(pos);
-		IF con.Attr() # NIL THEN w.rider.SetAttr(con.Attr()) END;
-		Models.BeginScript(t, opname, op);
-		t.Delete(pos, pos + 1);
-		w.WriteChar("<");
-		IF str # "" THEN w.WriteString(str) END;
-		w.WriteChar(">");
-		con := right.context(TextModels.Context);
-		pos := con.Pos();
-		w.SetPos(pos);
-		IF con.Attr() # NIL THEN w.rider.SetAttr(con.Attr()) END;
-		t.Delete(pos, pos + 1);
-		w.WriteString("<>");
-		Models.EndScript(t, op)
-	END Reveal;
-	
-	PROCEDURE RevealCmd (v: Link);
-		VAR left, right: Link;
-	BEGIN GetLinkPair(v, left, right);
-		IF left # NIL THEN
-			IF v.cmd # NIL THEN Reveal(left, right, v.cmd^, "#StdLinks:Reveal Link Command") 
-			ELSE Reveal(left, right, "", "#StdLinks:Reveal Link Command") 
-			END
-		END
-	END RevealCmd;
-
-	PROCEDURE RevealTarget (targ: Target);
-		VAR  left, right: Target;
-	BEGIN GetTargetPair(targ, left, right);
-		IF left # NIL THEN
-			IF left.ident # NIL THEN Reveal(left, right, left.ident^, "#SdtLinks:Reveal Target Ident")
-			ELSE Reveal(left, right, "", "#SdtLinks:Reveal Target Ident")
-			END
-		END
-	END RevealTarget;
-	
-	PROCEDURE CallCmd (v: Link; close: BOOLEAN);
-		VAR res: INTEGER;
-	BEGIN
-		Kernel.PushTrapCleaner(cleaner); 
-		par := v;
-		IF v.cmd^ # "" THEN 
-			IF close & (v.close = ifShiftDown) OR (v.close = always) THEN
-				StdCmds.CloseDialog
-			END;
-			Dialog.Call(v.cmd^, "#StdLinks:Link Call Failed", res) 
-		END;
-		par := NIL;
-		Kernel.PopTrapCleaner(cleaner)
-	END CallCmd;
-
-	PROCEDURE TrackSingle (f: Views.Frame; VAR in: BOOLEAN);
-		VAR x, y: INTEGER; modifiers: SET; in0, isDown: BOOLEAN;
-	BEGIN
-		in := FALSE;
-		REPEAT
-			f.Input(x, y, modifiers, isDown);
-			in0 := in; in := InFrame(f, x, y);
-			IF in # in0 THEN Mark(f, in) END
-		UNTIL ~isDown;
-		IF in THEN Mark(f, FALSE) END
-	END TrackSingle;
-
-	PROCEDURE TrackRange (v: TextViews.View; f: Views.Frame; l, r: Link; x, y: INTEGER;
-												VAR in: BOOLEAN);
-		VAR pos, beg, end: INTEGER; modifiers: SET; in0, isDown: BOOLEAN;
-	BEGIN
-		in := FALSE;
-		GetRange(l, r, beg, end); pos := ThisPos(v, f, x, y);
-		IF (beg <= pos) & (pos < end) THEN
-			REPEAT
-				f.Input(x, y, modifiers, isDown); pos := ThisPos(v, f, x, y);
-				in0 := in; in := (beg <= pos) & (pos < end);
-				IF in # in0 THEN MarkRange(v, f, beg, end, in) END
-			UNTIL ~isDown;
-			IF in THEN
-				MarkRange(v, f, beg, end, FALSE)
-			END
-		END
-	END TrackRange;
-
-	PROCEDURE Track (v: Link; f: Views.Frame; c: TextControllers.Controller;
-									x, y: INTEGER; modifiers: SET);
-	(* PRE: (c # NIL) & (f.view.ThisModel() = v.context.ThisModel())  OR  (c = NIL) & (f.view = v) *)
-		VAR l, r: Link; in: BOOLEAN;
-	BEGIN
-		GetLinkPair(v, l, r);
-		IF l # NIL THEN
-			IF c # NIL THEN TrackRange(c.view, f, l, r, x, y, in)
-			ELSE TrackSingle(f, in)
-			END;
-			IF in THEN
-				IF (Controllers.modify IN modifiers) & ((c = NIL) OR ~(Containers.noCaret IN c.opts)) THEN
-					RevealCmd(l)
-				ELSE
-					CallCmd(l, Controllers.extend IN modifiers)
-				END
-			END
-		END
-	END Track;
-
-	PROCEDURE TrackTarget (targ: Target; f: Views.Frame; modifiers: SET);
-		VAR in: BOOLEAN;
-	BEGIN
-		TrackSingle(f, in);
-		IF in & (Controllers.modify IN modifiers) THEN RevealTarget(targ) END
-	END TrackTarget;
-
-	PROCEDURE (v: Link) CopyFromSimpleView- (source: Views.View);
-	BEGIN
-		WITH source: Link DO
-			ASSERT(source.leftSide = (source.cmd # NIL), 100);
-			v.leftSide := source.leftSide;
-			v.close := source.close;
-			IF source.cmd # NIL THEN
-				NEW(v.cmd, LEN(source.cmd^));
-				v.cmd^ := source.cmd^$
-			ELSE v.cmd := NIL
-			END
-		END
-	END CopyFromSimpleView;
-
-	PROCEDURE (t: Target) CopyFromSimpleView- (source: Views.View);
-	BEGIN
-		WITH source: Target DO
-			ASSERT(source.leftSide = (source.ident # NIL), 100);
-			t.leftSide := source.leftSide;
-			IF source.ident # NIL THEN
-				NEW(t.ident, LEN(source.ident^));
-				t.ident^ := source.ident^$
-			ELSE t.ident := NIL
-			END
-		END
-	END CopyFromSimpleView;
-
-	PROCEDURE (v: Link) Internalize- (VAR rd: Stores.Reader);
-		VAR len: INTEGER; version: INTEGER; pos: INTEGER;
-	BEGIN
-		v.Internalize^(rd);
-		IF rd.cancelled THEN RETURN END;
-		rd.ReadVersion(minLinkVersion, maxLinkVersion, version);
-		IF rd.cancelled THEN RETURN END;
-		rd.ReadBool(v.leftSide);
-		rd.ReadInt(len);
-		IF len = 0 THEN v.cmd := NIL
-		ELSE NEW(v.cmd, len); rd.ReadXString(v.cmd^)
-		END;
-		v.leftSide := v.cmd # NIL;
-		IF v.leftSide THEN
-			IF version = 1 THEN
-				rd.ReadInt(v.close)
-			ELSE
-				Strings.Find(v.cmd, "StdLinks.ShowTarget", 0, pos);
-				IF (pos # 0) THEN v.close := ifShiftDown
-				ELSE v.close := never
-				END
-			END
-		END
-	END Internalize;
-
-	PROCEDURE (v: Link) Externalize- (VAR wr: Stores.Writer);
-		VAR pos, version: INTEGER;
-	BEGIN
-		v.Externalize^(wr);
-		IF v.leftSide THEN
-			Strings.Find(v.cmd, "StdLinks.ShowTarget", 0, pos);
-			IF (pos = 0) & (v.close = never) OR (v.close = ifShiftDown) THEN version := 0
-			ELSE version := 1
-			END
-		ELSE
-			version := 0
-		END;
-		wr.WriteVersion(version);
-		wr.WriteBool(v.cmd # NIL);
-		IF v.cmd = NIL THEN wr.WriteInt(0)
-		ELSE wr.WriteInt(LEN(v.cmd^)); wr.WriteXString(v.cmd^)
-		END;
-		IF version = 1 THEN wr.WriteInt(v.close) END
-	END Externalize;
-
-	PROCEDURE (t: Target) Internalize- (VAR rd: Stores.Reader);
-		VAR len: INTEGER; version: INTEGER;
-	BEGIN
-		t.Internalize^(rd);
-		IF rd.cancelled THEN RETURN END;
-		rd.ReadVersion(minTargVersion, maxTargVersion, version);
-		IF rd.cancelled THEN RETURN END;
-		rd.ReadBool(t.leftSide);
-		rd.ReadInt(len);
-		IF len = 0 THEN t.ident := NIL
-		ELSE NEW(t.ident, len); rd.ReadXString(t.ident^)
-		END;
-		t.leftSide := t.ident # NIL
-	END Internalize;
-
-	PROCEDURE (t: Target) Externalize- (VAR wr: Stores.Writer);
-	BEGIN
-		t.Externalize^(wr);
-		wr.WriteVersion(maxTargVersion);
-		wr.WriteBool(t.ident # NIL);
-		IF t.ident = NIL THEN wr.WriteInt(0)
-		ELSE wr.WriteInt(LEN(t.ident^)); wr.WriteXString(t.ident^)
-		END
-	END Externalize;
-
-	PROCEDURE RestoreView (v: Views.View; f: Views.Frame; icon: ARRAY OF SHORTCHAR);
-		VAR c: Models.Context; a: TextModels.Attributes; font: Fonts.Font; color: Ports.Color;
-			asc, dsc, w: INTEGER;
-	BEGIN
-		c := v.context;
-		IF (c # NIL) & (c IS TextModels.Context) THEN
-			a := c(TextModels.Context).Attr();
-			font := Fonts.dir.This(iconFont, a.font.size, {}, Fonts.normal);
-			color := a.color
-		ELSE font := Fonts.dir.Default(); color := Ports.black
-		END;
-		IF coloredBackg THEN
-		f.DrawRect(f.l, f.t, f.r, f.b, Ports.fill, Ports.grey25) END;
-		font.GetBounds(asc, dsc, w);
-		f.DrawSString(1*Ports.mm DIV 2, asc, color, icon, font)
-	END RestoreView;
-
-	PROCEDURE (v: Link) Restore* (f: Views.Frame; l, t, r, b: INTEGER);
-	BEGIN
-		IF v.leftSide THEN RestoreView(v, f, linkLeft)
-		ELSE RestoreView(v, f, linkRight)
-		END
-	END Restore;
-
-	PROCEDURE (targ: Target) Restore* (f: Views.Frame; l, t, r, b: INTEGER);
-	BEGIN
-		IF targ.leftSide THEN RestoreView(targ, f, targetLeft)
-		ELSE RestoreView(targ, f, targetRight)
-		END
-	END Restore;
-
-	PROCEDURE SizePref (v: Views.View; icon: ARRAY OF SHORTCHAR; VAR msg: Properties.SizePref);
-		VAR c: Models.Context; a: TextModels.Attributes; font: Fonts.Font;
-			asc, dsc, w: INTEGER;
-	BEGIN
-		c := v.context;
-		IF (c # NIL) & (c IS TextModels.Context) THEN
-			a := c(TextModels.Context).Attr();
-			font := Fonts.dir.This(iconFont, a.font.size, {}, Fonts.normal)
-		ELSE
-			font := Fonts.dir.Default()
-		END;
-		msg.w := font.SStringWidth(icon) + 1*Ports.mm;
-		font.GetBounds(asc, dsc, w);
-		msg.h := asc + dsc
-	END SizePref;
-	
-	PROCEDURE (v: Link) HandlePropMsg- (VAR msg: Properties.Message);
-		VAR a: TextModels.Attributes; c: Models.Context; asc, dsc, w: INTEGER; l, r: Link;
-	BEGIN
-		WITH msg: Properties.SizePref DO
-			IF v.leftSide THEN SizePref(v, linkLeft, msg)
-			ELSE SizePref(v, linkRight, msg)
-			END
-		| msg: Properties.FocusPref DO
-			msg.hotFocus := TRUE
-		| msg: Properties.ResizePref DO
-			msg.fixed := TRUE
-		| msg: TextModels.Pref DO
-			msg.opts := {TextModels.hideable}
-		| msg: TextControllers.FilterPref DO
-			msg.filter := TRUE
-		| msg: TextSetters.Pref DO c := v.context;
-			IF (c # NIL) & (c IS TextModels.Context) THEN
-				a := c(TextModels.Context).Attr();
-				a.font.GetBounds(asc, dsc, w);
-				msg.dsc := dsc
-			END
-		| msg: Properties.PollMsg DO
-			IF v.leftSide THEN PollProp(v, msg) 
-			ELSE
-				GetLinkPair(v, l, r);
-				IF l # NIL THEN PollProp(l, msg) END
-			END
-		| msg: Properties.SetMsg DO
-			IF v.leftSide THEN SetProp(v, msg)
-			ELSE GetLinkPair(v, l, r); SetProp(l, msg)
-			END
-		ELSE
-		END
-	END HandlePropMsg;
-	
-	PROCEDURE (targ: Target) HandlePropMsg- (VAR msg: Properties.Message);
-		VAR a: TextModels.Attributes; c: Models.Context; asc, dsc, w: INTEGER;  l, r: Target;
-	BEGIN
-		WITH msg: Properties.SizePref DO
-			IF targ.leftSide THEN SizePref(targ, targetLeft, msg)
-			ELSE SizePref(targ, targetRight, msg)
-			END
-		| msg: Properties.FocusPref DO
-			msg.hotFocus := TRUE
-		| msg: Properties.ResizePref DO
-			msg.fixed := TRUE
-		| msg: TextModels.Pref DO
-			msg.opts := {TextModels.hideable}
-		| msg: TextSetters.Pref DO c := targ.context;
-			IF (c # NIL) & (c IS TextModels.Context) THEN
-				a := c(TextModels.Context).Attr();
-				a.font.GetBounds(asc, dsc, w);
-				msg.dsc := dsc
-			END
-		| msg: Properties.PollMsg DO
-			IF targ.leftSide THEN PollProp(targ, msg)
-			ELSE
-				GetTargetPair(targ, l, r);
-				IF l # NIL THEN PollProp(l, msg) END
-			END
-		| msg: Properties.SetMsg DO
-			IF targ.leftSide THEN SetProp(targ, msg)
-			ELSE GetTargetPair(targ, l, r); SetProp(l, msg)
-			END
-		ELSE
-		END
-	END HandlePropMsg;
-
-	PROCEDURE (v: Link) HandleCtrlMsg* (f: Views.Frame;
-		VAR msg: Controllers.Message; VAR focus: Views.View);
-
-		PROCEDURE isHot(c: TextControllers.Controller; x, y: INTEGER; mod: SET): BOOLEAN;
-			VAR pos, beg, end: INTEGER;
-		BEGIN
-			(* ignore alt, cmd, and middle clicks in edit mode *)
-			IF ~(Containers.noCaret IN c.opts) & (mod * {17, 27, 28} # {}) THEN RETURN FALSE END;
-			pos := ThisPos(c.view, f, x, y);
-			(* ignore clicks in selection *)
-			c.GetSelection(beg, end);
-			IF (end > beg) & (pos >= beg) & (pos <= end) THEN RETURN FALSE END;
-			IF v.leftSide THEN RETURN pos >= v.context(TextModels.Context).Pos()
-			ELSE RETURN pos < v.context(TextModels.Context).Pos()
-			END
-		END isHot;
-		
-	BEGIN
-		WITH msg: Controllers.PollCursorMsg DO
-			msg.cursor := Ports.refCursor
-		| msg: TextControllers.FilterPollCursorMsg DO
-			IF isHot(msg.controller, msg.x, msg.y, {}) THEN
-				msg.cursor := Ports.refCursor; msg.done := TRUE
-			END
-		| msg: Controllers.TrackMsg DO
-			Track(v, f, NIL, msg.x, msg.y, msg.modifiers)
-		| msg: TextControllers.FilterTrackMsg DO
-			IF isHot(msg.controller, msg.x, msg.y, msg.modifiers) THEN
-				Track(v, f,  msg.controller, msg.x, msg.y, msg.modifiers);
-				msg.done := TRUE
-			END
-		ELSE
-		END
-	END HandleCtrlMsg;
-
-	PROCEDURE (targ: Target) HandleCtrlMsg* (f: Views.Frame; VAR msg: Controllers.Message;
-																		VAR focus: Views.View);
-	BEGIN
-		WITH msg: Controllers.TrackMsg DO TrackTarget(targ, f, msg.modifiers)
-		ELSE
-		END
-	END HandleCtrlMsg;
-
-	PROCEDURE (v: Link) GetCmd* (OUT cmd: ARRAY OF CHAR), NEW;
-	BEGIN
-		ASSERT(v.leftSide, 20);
-		ASSERT(v.cmd # NIL, 100);
-		cmd := v.cmd$
-	END GetCmd;
-
-	PROCEDURE (t: Target) GetIdent* (OUT ident: ARRAY OF CHAR), NEW;
-	BEGIN
-		ASSERT(t.leftSide, 20);
-		ASSERT(t.ident # NIL, 100);
-		ident := t.ident$
-	END GetIdent;
-
-	(* --------------- create commands and menu guards ------------------------ *)
-
-	PROCEDURE GetParam (c: TextControllers.Controller; VAR param: ARRAY OF CHAR;
-									VAR lbrBeg, lbrEnd, rbrBeg, rbrEnd: INTEGER);
-		VAR rd: TextModels.Reader; i, beg, end: INTEGER;
-			ch0, ch1, ch2: CHAR;
-	BEGIN
-		param[0] := 0X;
-		IF (c # NIL) & c.HasSelection() THEN
-			c.GetSelection(beg, end);
-			IF end - beg > 4 THEN
-				rd := c.text.NewReader(NIL);
-				rd.SetPos(beg); rd.ReadChar(ch0);
-				rd.SetPos(end-2); rd.ReadChar(ch1); rd.ReadChar(ch2);
-				IF (ch0 = "<") & (ch1 = "<") & (ch2 = ">") THEN
-					rd.SetPos(beg+1); rd.ReadChar(ch0); i := 0;
-					WHILE ~rd.eot & (ch0 # ">") DO
-						IF i < LEN(param) - 1 THEN param[i] := ch0; INC(i) END;
-						rd.ReadChar(ch0)
-					END;
-					param[i] := 0X;
-					lbrBeg := beg; lbrEnd := rd.Pos();
-					rbrBeg := end -2; rbrEnd := end
-				END
-			END
-		END
-	END GetParam;
-	
-	PROCEDURE CreateGuard* (VAR par: Dialog.Par);
-		VAR param: ARRAY 512 OF CHAR; lbrBeg, lbrEnd, rbrBeg, rbrEnd: INTEGER;
-	BEGIN
-		GetParam(TextControllers.Focus(), param, lbrBeg, lbrEnd, rbrBeg, rbrEnd);
-		par.disabled := param = ""
-	END CreateGuard;
-
-	PROCEDURE InsertionAttr (c: TextControllers.Controller; pos: INTEGER): TextModels.Attributes;
-		VAR rd: TextModels.Reader; r: TextRulers.Ruler; a: TextModels.Attributes; ch: CHAR;
-	BEGIN
-		rd := c.text.NewReader(NIL);  a := NIL;
-		rd.SetPos(pos); rd.ReadChar(ch); a := rd.attr;
-		IF a = NIL THEN c.view.PollDefaults(r, a) END;
-		RETURN a
-	END InsertionAttr;
-
-	PROCEDURE CreateLink*;
-		VAR lbrBeg, lbrEnd, rbrBeg, rbrEnd: INTEGER;
-			left, right: Link; c: TextControllers.Controller;
-			cmd: ARRAY 512 OF CHAR;
-			op: Stores.Operation;
-			w: TextModels.Writer; a: TextModels.Attributes;
-	BEGIN
-		c := TextControllers.Focus();
-		GetParam(TextControllers.Focus(), cmd, lbrBeg, lbrEnd, rbrBeg, rbrEnd);
-		IF cmd # "" THEN
-			w := c.text.NewWriter(NIL);
-			Models.BeginScript(c.text, "#StdLinks:Create Link", op);
-			a := InsertionAttr(c, rbrBeg);
-			c.text.Delete(rbrBeg, rbrEnd);
-			right := dir.NewLink("");
-			w.SetPos(rbrBeg);
-			IF a # NIL THEN w.SetAttr(a) END;
-			w.WriteView(right, 0, 0);
-			a := InsertionAttr(c, lbrBeg);
-			c.text.Delete(lbrBeg, lbrEnd);
-			left := dir.NewLink(cmd);
-			w.SetPos(lbrBeg);
-			IF a # NIL THEN w.SetAttr(a) END;
-			w.WriteView(left, 0, 0);
-			Models.EndScript(c.text, op)
-		END
-	END CreateLink;
-
-	PROCEDURE CreateTarget*;
-		VAR lbrBeg, lbrEnd, rbrBeg, rbrEnd: INTEGER;
-			left, right: Target; c: TextControllers.Controller;
-			ident: ARRAY 512 OF CHAR;
-			op: Stores.Operation;
-			w: TextModels.Writer; a: TextModels.Attributes;
-	BEGIN
-		c := TextControllers.Focus();
-		GetParam(TextControllers.Focus(), ident, lbrBeg, lbrEnd, rbrBeg, rbrEnd);
-		IF ident # "" THEN
-			w := c.text.NewWriter(NIL);
-			Models.BeginScript(c.text, "#StdLinks:Create Target", op);
-			a := InsertionAttr(c, rbrBeg);
-			c.text.Delete(rbrBeg, rbrEnd);
-			right := dir.NewTarget("");
-			w.SetPos(rbrBeg);
-			IF a # NIL THEN w.SetAttr(a) END;
-			w.WriteView(right, 0, 0);
-			a := InsertionAttr(c, lbrBeg);
-			c.text.Delete(lbrBeg, lbrEnd);
-			left := dir.NewTarget(ident);
-			w.SetPos(lbrBeg);
-			IF a # NIL THEN w.SetAttr(a) END;
-			w.WriteView(left, 0, 0);
-			Models.EndScript(c.text, op)
-		END
-	END CreateTarget;
-
-	PROCEDURE ShowTarget* (IN ident: ARRAY OF CHAR);
-		VAR c: TextControllers.Controller; rd: TextModels.Reader;
-			v: Views.View; left, right: Target; beg, end: INTEGER;
-	BEGIN
-		c := TextControllers.Focus();
-		IF c # NIL THEN
-			rd := c.text.NewReader(NIL);
-			REPEAT rd.ReadView(v)
-			UNTIL rd.eot OR (v # NIL) & (v IS Target) & v(Target).leftSide & (v(Target).ident^ = ident);
-			IF ~rd.eot THEN
-				GetTargetPair(v(Target), left, right);
-				IF (left # NIL) & (right # NIL) THEN
-					beg := left.context(TextModels.Context).Pos();
-					end := right.context(TextModels.Context).Pos() + 1;
-					c.SetSelection(beg, end);
-					c.view.SetOrigin(beg, 0)
-				ELSE
-					Dialog.ShowParamMsg("target '^0' not found", ident, "", "")
-				END
-			ELSE
-				Dialog.ShowParamMsg("target '^0' not found", ident, "", "")
-			END
-		END
-	END ShowTarget;
-
-
-	(* programming interface *)
-
-	PROCEDURE (d: StdDirectory) NewLink (IN cmd: ARRAY OF CHAR): Link;
-		VAR link: Link; i: INTEGER;
-	BEGIN
-		NEW(link); link.leftSide := cmd # "";
-		IF link.leftSide THEN
-			i := 0; WHILE cmd[i] # 0X DO INC(i) END;
-			NEW(link.cmd, i + 1); link.cmd^ := cmd$
-		ELSE
-			link.cmd := NIL
-		END;
-		link.close := ifShiftDown;
-		RETURN link
-	END NewLink;
-
-	PROCEDURE (d: StdDirectory) NewTarget (IN ident: ARRAY OF CHAR): Target;
-		VAR t: Target; i: INTEGER;
-	BEGIN
-		NEW(t); t.leftSide := ident # "";
-		IF t.leftSide THEN
-			i := 0; WHILE ident[i] # 0X DO INC(i) END;
-			NEW(t.ident, i + 1); t.ident^ := ident$
-		ELSE
-			t.ident := NIL
-		END;
-		RETURN t
-	END NewTarget;
-
-	PROCEDURE SetDir* (d: Directory);
-	BEGIN
-		ASSERT(d # NIL, 20);
-		dir := d
-	END SetDir;
-
-	PROCEDURE Init;
-		VAR font: Fonts.Font; d: StdDirectory;
-
-		PROCEDURE DefaultAppearance;
-		BEGIN font := Fonts.dir.Default(); iconFont := font.typeface;
-			linkLeft := "Link"; linkRight := "~";
-			targetLeft := "Targ"; targetRight :=  "~";
-			coloredBackg := TRUE
-		END DefaultAppearance;
-
-	BEGIN
-		NEW(d); dir := d; stdDir := d;
-		IF Dialog.platform DIV 10 = 1 THEN (* Windows *)
-			iconFont := "Wingdings";
-			font := Fonts.dir.This(iconFont, 10*Fonts.point (*arbitrary*), {}, Fonts.normal);
-			IF font.IsAlien() THEN DefaultAppearance
-			ELSE
-				linkLeft[0] := SHORT(CHR(246)); linkLeft[1] := 0X;
-				linkRight[0] := SHORT(CHR(245)); linkRight[1] := 0X;
-				targetLeft[0] := SHORT(CHR(164)); targetLeft[1] := 0X;
-				targetRight[0] := SHORT(CHR(161)); targetRight[1] := 0X;
-				coloredBackg := FALSE
-			END
-		ELSIF Dialog.platform DIV 10 = 2 THEN (* Mac *)
-			DefaultAppearance
-		ELSE
-			DefaultAppearance
-		END;
-		NEW(cleaner);
-		dialog.close.SetResources("#Std:links")
-	END Init;
-
-BEGIN
-	Init
-END StdLinks.

BlackBox/Std/Mod/Loader.txt

@@ -1,336 +0,0 @@
-MODULE StdLoader;
-
-	(* THIS IS TEXT COPY OF BlackBox 1.6-rc6 Std/Mod/Loader.odc *)
-	(* DO NOT EDIT *)
-
-	IMPORT S := SYSTEM, Kernel, Files;
-	
-	CONST
-		done = Kernel.done;
-		fileNotFound = Kernel.fileNotFound;
-		syntaxError = Kernel.syntaxError;
-		objNotFound = Kernel.objNotFound;
-		illegalFPrint = Kernel.illegalFPrint;
-		cyclicImport = Kernel.cyclicImport;
-		noMem = Kernel.noMem;
-		commNotFound = Kernel.commNotFound;
-		commSyntaxError = Kernel.commSyntaxError;
-		descNotFound = -1;
-
-		OFdir = "Code";
-		SYSdir = "System";
-		initMod = "Init";
-		OFtag = 6F4F4346H;
-		
-		(* meta interface consts *)
-		mConst = 1; mTyp = 2; mVar = 3; mProc = 4; mField = 5;
-		mBool = 1; mChar = 2; mLChar = 3; mSInt = 4; mInt = 5; mLInt = 6;
-		mReal = 7; mLReal = 8; mSet = 9; mString = 10; mLString = 11;
-		mRecord = 1; mArray = 2; mPointer = 3; mProctyp = 4;
-		mInternal = 1; mReadonly = 2; mPrivate = 3; mExported = 4;
-		
-		(* fixup types *)
-		absolute = 100; relative = 101; copy = 102; table = 103; tableend = 104; deref = 105; halfword = 106;
-		
-	TYPE
-		Name = ARRAY 256 OF CHAR;
-		ModSpec = POINTER TO RECORD
-			next, link, imp: ModSpec;
-			name: Name;
-			file: Files.File;
-			mod: Kernel.Module;
-			hs, ms, ds, cs, vs, mad, dad: INTEGER
-		END;
-		
-		Hook = POINTER TO RECORD (Kernel.LoaderHook) END;
-
-	VAR
-		res-: INTEGER;
-		importing-, imported-, object-: Name;
-		inp: Files.Reader;
-		m: Kernel.Module;
-	
-	PROCEDURE Error (r: INTEGER; impd, impg: ModSpec);
-	BEGIN
-		res := r; imported := impd.name$;
-		IF impg # NIL THEN importing := impg.name$ END;
-	END Error;
-	
-	PROCEDURE Append (VAR s: ARRAY OF CHAR; t: ARRAY OF CHAR);
-		VAR len, i, j: INTEGER; ch: CHAR;
-	BEGIN
-		len := LEN(s);
-		i := 0; WHILE s[i] # 0X DO INC(i) END;
-		j := 0; REPEAT ch := t[j]; s[i] := ch; INC(j); INC(i) UNTIL (ch = 0X) OR (i = len);
-		s[len - 1] := 0X
-	END Append;
-
-	PROCEDURE ThisObjFile (VAR name: ARRAY OF CHAR): Files.File;
-		VAR f: Files.File; loc: Files.Locator; dir, fname: Files.Name;
-	BEGIN
-		Kernel.SplitName(name, dir, fname);
-		Kernel.MakeFileName(fname, Kernel.objType);
-		loc := Files.dir.This(dir); loc := loc.This(OFdir);
-		f := Files.dir.Old(loc, fname, TRUE);
-		IF (f = NIL) & (dir = "") THEN
-			loc := Files.dir.This(SYSdir); loc := loc.This(OFdir);
-			f := Files.dir.Old(loc, fname, TRUE)
-		END;
-		RETURN f
-	END ThisObjFile;
-	
-	PROCEDURE RWord (VAR x: INTEGER);
-		VAR b: BYTE; y: INTEGER;
-	BEGIN
-		inp.ReadByte(b); y := b MOD 256;
-		inp.ReadByte(b); y := y + 100H * (b MOD 256);
-		inp.ReadByte(b); y := y + 10000H * (b MOD 256);
-		inp.ReadByte(b); x := y + 1000000H * b
-	END RWord;
-	
-	PROCEDURE RNum (VAR x: INTEGER);
-		VAR b: BYTE; s, y: INTEGER;
-	BEGIN
-		s := 0; y := 0; inp.ReadByte(b);
-		WHILE b < 0 DO INC(y, ASH(b + 128, s)); INC(s, 7); inp.ReadByte(b) END;
-		x := ASH((b + 64) MOD 128 - 64, s) + y
-	END RNum;
-	
-	PROCEDURE RName (VAR name: ARRAY OF CHAR);
-		VAR b: BYTE; i, n: INTEGER;
-	BEGIN
-		i := 0; n := LEN(name) - 1; inp.ReadByte(b);
-		WHILE (i < n) & (b # 0) DO name[i] := CHR(b MOD 256); INC(i); inp.ReadByte(b) END;
-		WHILE b # 0 DO inp.ReadByte(b) END;
-		name[i] := 0X
-	END RName;
-
-	PROCEDURE Fixup (adr: INTEGER; mod: ModSpec);
-		VAR link, offset, linkadr, t, n, x, low, hi: INTEGER;
-	BEGIN
-		RNum(link);
-		WHILE link # 0 DO
-			RNum(offset);
-			WHILE link # 0 DO
-				IF link > 0 THEN linkadr := mod.mad + mod.ms + link
-				ELSE link := -link;
-					IF link < mod.ms THEN linkadr := mod.mad + link
-					ELSE linkadr := mod.dad + link - mod.ms
-					END
-				END;
-				S.GET(linkadr, x); t := x DIV 1000000H;
-				n := (x + 800000H) MOD 1000000H - 800000H;
-				IF t = absolute THEN x := adr + offset
-				ELSIF t = relative THEN x := adr + offset - linkadr - 4
-				ELSIF t = copy THEN S.GET(adr + offset, x)
-				ELSIF t = table THEN x := adr + n; n := link + 4
-				ELSIF t = tableend THEN x := adr + n; n := 0
-				ELSIF t = deref THEN S.GET(adr+2, x); INC(x, offset);
-				ELSIF t = halfword THEN
-					x := adr + offset;
-					low := (x + 8000H) MOD 10000H - 8000H;
-					hi := (x - low) DIV 10000H;
-					S.GET(linkadr + 4, x);
-					S.PUT(linkadr + 4, x DIV 10000H * 10000H + low MOD 10000H);
-					x := x * 10000H + hi MOD 10000H
-				ELSE Error(syntaxError, mod, NIL)
-				END;
-				S.PUT(linkadr, x); link := n
-			END;
-			RNum(link)
-		END
-	END Fixup;
-	
-	PROCEDURE ReadHeader (mod: ModSpec);
-		VAR n, p: INTEGER; name: Name; imp, last: ModSpec;
-	BEGIN
-		mod.file := ThisObjFile(mod.name);
-		IF (mod.file = NIL) & (mod.link # NIL) THEN	(* try closing importing obj file *)
-			mod.link.file.Close; mod.link.file := NIL;
-			mod.file := ThisObjFile(mod.name)
-		END;
-		IF mod.file # NIL THEN
-			inp := mod.file.NewReader(inp);
-			IF inp # NIL THEN
-				inp.SetPos(0); RWord(n); RWord(p);
-				IF (n = OFtag) & (p = Kernel.processor) THEN
-					RWord(mod.hs); RWord(mod.ms); RWord(mod.ds); RWord(mod.cs); RWord(mod.vs); 
-					RNum(n); RName(name);
-					IF name = mod.name THEN
-						mod.imp := NIL; last := NIL;
-						WHILE n > 0 DO
-							NEW(imp); RName(imp.name);
-							IF last = NIL THEN mod.imp := imp ELSE last.next := imp END;
-							last := imp; imp.next := NIL; DEC(n) 
-						END
-					ELSE Error(fileNotFound, mod, NIL)
-					END
-				ELSE Error(syntaxError, mod, NIL)
-				END
-			ELSE Error(noMem, mod, NIL)
-			END
-		ELSE Error(fileNotFound, mod, NIL)
-		END
-	END ReadHeader;
-	
-	PROCEDURE ReadModule (mod: ModSpec);
-		TYPE BlockPtr = POINTER TO ARRAY [1] 1000000H OF BYTE;
-		VAR imptab, x, fp, ofp, opt, a: INTEGER;
-			name: Name; dp, mp: BlockPtr; imp: ModSpec; obj: Kernel.Object; in, n: Kernel.Name;
-	BEGIN
-		IF mod.file = NIL THEN mod.file := ThisObjFile(mod.name) END;
-		inp := mod.file.NewReader(inp);
-		IF inp # NIL THEN
-			inp.SetPos(mod.hs);
-			Kernel.AllocModMem(mod.ds, mod.ms + mod.cs + mod.vs, mod.dad, mod.mad);
-			IF (mod.dad # 0) & (mod.mad # 0) THEN
-				dp := S.VAL(BlockPtr, mod.dad); mp := S.VAL(BlockPtr, mod.mad);
-				inp.ReadBytes(mp^, 0, mod.ms);
-				inp.ReadBytes(dp^, 0, mod.ds);
-				inp.ReadBytes(mp^, mod.ms, mod.cs);
-				mod.mod := S.VAL(Kernel.Module, mod.dad);
-				Fixup(S.ADR(Kernel.NewRec), mod);
-				Fixup(S.ADR(Kernel.NewArr), mod);
-				Fixup(mod.mad, mod);
-				Fixup(mod.dad, mod);
-				Fixup(mod.mad + mod.ms, mod);
-				Fixup(mod.mad + mod.ms + mod.cs, mod);
-				imp := mod.imp; imptab := S.VAL(INTEGER, mod.mod.imports);
-				WHILE (res = done) & (imp # NIL) DO
-					RNum(x);
-					WHILE (res <= done) & (x # 0) DO
-						RName(name); RNum(fp); opt := 0;
-						IF imp.mod # NIL THEN
-							IF name = "" THEN obj := Kernel.ThisDesc(imp.mod, fp)
-							ELSE n := SHORT(name$); obj := Kernel.ThisObject(imp.mod, n)
-							END;
-							IF (obj # NIL) & (obj.id MOD 16 = x) THEN
-								ofp := obj.fprint;
-								IF x = mTyp THEN
-									RNum(opt);
-									IF ODD(opt) THEN ofp := obj.offs END;
-									IF (opt > 1) & (obj.id DIV 16 MOD 16 # mExported) THEN
-										Error(objNotFound, imp, mod); object := name$
-									END;
-									Fixup(S.VAL(INTEGER, obj.struct), mod)
-								ELSIF x = mVar THEN
-									Fixup(imp.mod.varBase + obj.offs, mod)
-								ELSIF x = mProc THEN
-									Fixup(imp.mod.procBase + obj.offs, mod)
-								END;
-								IF ofp # fp THEN Error(illegalFPrint, imp, mod); object := name$ END
-							ELSIF name # "" THEN
-								Error(objNotFound, imp, mod); object := name$
-							ELSE
-								Error(descNotFound, imp, mod);	(* proceed to find failing named object *)
-								RNum(opt); Fixup(0, mod)
-							END
-						ELSE	(* imp is dll *)
-							IF x IN {mVar, mProc} THEN
-								in := SHORT(imp.name$); n := SHORT(name$);
-								a := Kernel.ThisDllObj(x, fp, in, n);
-								IF a # 0 THEN Fixup(a, mod)
-								ELSE Error(objNotFound, imp, mod); object := name$
-								END
-							ELSIF x = mTyp THEN
-								RNum(opt); RNum(x);
-								IF x # 0 THEN Error(objNotFound, imp, mod); object := name$ END
-							END
-						END;
-						RNum(x)
-					END;
-					S.PUT(imptab, imp.mod); INC(imptab, 4); imp := imp.next
-				END;
-				IF res # done THEN
-					Kernel.DeallocModMem(mod.ds, mod.ms + mod.cs + mod.vs, mod.dad, mod.mad); mod.mod := NIL
-				END
-			ELSE Error(noMem, mod, NIL)
-			END
-		ELSE Error(noMem, mod, NIL)
-		END;
-		mod.file.Close; mod.file := NIL
-	END ReadModule;
-	
-	PROCEDURE LoadMod (mod: ModSpec);
-		VAR i: ModSpec; ok: BOOLEAN; j: INTEGER; n: Kernel.Name;
-	BEGIN
-		importing := ""; imported := ""; object := ""; i := mod;
-		WHILE (i.link # NIL) & (i.link.name # mod.name) DO i := i.link END;
-		IF i.link = NIL THEN ReadHeader(mod)
-		ELSE Error(cyclicImport, i, i.link)
-		END;
-		i := mod.imp;
-		WHILE (res = done) & (i # NIL) DO	(* get imported module *)
-			IF i.name = "$$" THEN i.name := "Kernel" END;
-			IF i.name[0] = "$" THEN	(* dll *)
-				j := 1;
-				WHILE i.name[j] # 0X DO i.name[j - 1] := i.name[j]; INC(j) END;
-				i.name[j - 1] := 0X; n := SHORT(i.name$);
-				Kernel.LoadDll(n, ok);
-				IF ~ok THEN Error(fileNotFound, i, NIL) END
-			ELSE
-				n := SHORT(i.name$);
-				i.mod := Kernel.ThisLoadedMod(n);	(* loaded module *)
-				IF i.mod = NIL THEN i.link := mod; LoadMod(i) END	(* new module *)
-			END;
-			i := i.next
-		END;
-		IF res = done THEN
-			n := SHORT(mod.name$);
-			mod.mod := Kernel.ThisLoadedMod(n);	(* guaranties uniqueness *)
-			IF mod.mod = NIL THEN
-				ReadModule(mod);
-				IF res = done THEN
-					Kernel.RegisterMod(mod.mod);
-					res := done
-				END
-			END
-		END;
-		IF res = descNotFound THEN res := objNotFound; object := "<TypeDesc>" END;
-		IF object # "" THEN Append(imported, "."); Append(imported, object); object := "" END
-	END LoadMod;
-
-	PROCEDURE (h: Hook) ThisMod (IN name: ARRAY OF SHORTCHAR): Kernel.Module;
-		VAR m: Kernel.Module; ms: ModSpec;
-	BEGIN
-		res := done;
-		m := Kernel.ThisLoadedMod(name);
-		IF m = NIL THEN
-			NEW(ms); ms.link := NIL; ms.name := name$;
-			LoadMod(ms);
-			m := ms.mod;
-			inp := NIL	(* free last file *)
-		END;
-		h.res := res;
-		h.importing := importing$;
-		h.imported := imported$;
-		h.object := object$;
-		RETURN m
-	END ThisMod;
-
-	PROCEDURE Init;
-		VAR h: Hook;
-	BEGIN
-		NEW(h); Kernel.SetLoaderHook(h)
-	END Init;
-
-BEGIN
-	Init;
-	m := Kernel.ThisMod("Init");
-	IF res # 0 THEN
-		CASE res OF
-		| fileNotFound: Append(imported, ": code file not found")
-		| syntaxError: Append(imported, ": corrupted code file")
-		| objNotFound: Append(imported, " not found")
-		| illegalFPrint: Append(imported, ": wrong fingerprint")
-		| cyclicImport: Append(imported, ": cyclic import")
-		| noMem: Append(imported, ": not enough memory")
-		ELSE Append(imported, ": loader error")
-		END;
-		IF res IN {objNotFound, illegalFPrint, cyclicImport} THEN
-			Append(imported, " (imported from "); Append(imported, importing); Append(imported, ")")
-		 END;
-		Kernel.FatalError(res, imported)
-	END
-END StdLoader.
-

BlackBox/Std/Mod/Log.txt

@@ -1,373 +0,0 @@
-MODULE StdLog;
-
-	(* THIS IS TEXT COPY OF BlackBox 1.6-rc6 Std/Mod/Log.odc *)
-	(* DO NOT EDIT *)
-
-	IMPORT
-		Log, Fonts, Ports, Stores, Models, Views, Dialog, HostDialog, StdDialog,
-		TextModels, TextMappers, TextRulers, TextViews, TextControllers;
-
-	CONST
-		(** IntForm base **)
-		charCode* = TextMappers.charCode; decimal* = TextMappers.decimal; hexadecimal* = TextMappers.hexadecimal;
-
-		(** IntForm showBase **)
-		hideBase* = TextMappers.hideBase; showBase* = TextMappers.showBase;
-
-		mm = Ports.mm;
-
-	TYPE
-		ShowHook = POINTER TO RECORD (Dialog.ShowHook) END;
-		LogHook = POINTER TO RECORD (Log.Hook) END;
-
-	VAR
-		logAlerts: BOOLEAN;
-
-		text-, buf-: TextModels.Model;
-		defruler-: TextRulers.Ruler;
-		dir-: TextViews.Directory;
-
-		out, subOut: TextMappers.Formatter;
-		
-		showHook: ShowHook;
-
-
-	PROCEDURE Flush;
-	BEGIN
-		text.Append(buf); Views.RestoreDomain(text.Domain())
-	END Flush;
-
-	PROCEDURE Char* (ch: CHAR);
-	BEGIN
-		out.WriteChar(ch); Flush
-	END Char;
-
-	PROCEDURE Int* (i: LONGINT);
-	BEGIN
-		out.WriteChar(" "); out.WriteInt(i); Flush
-	END Int;
-
-	PROCEDURE Real* (x: REAL);
-	BEGIN
-		out.WriteChar(" "); out.WriteReal(x); Flush
-	END Real;
-
-	PROCEDURE String* (IN str: ARRAY OF CHAR);
-	BEGIN
-		out.WriteString(str); Flush
-	END String;
-
-	PROCEDURE Bool* (x: BOOLEAN);
-	BEGIN
-		out.WriteChar(" "); out.WriteBool(x); Flush
-	END Bool;
-
-	PROCEDURE Set* (x: SET);
-	BEGIN
-		out.WriteChar(" "); out.WriteSet(x); Flush
-	END Set;
-
-	PROCEDURE IntForm* (x: LONGINT; base, minWidth: INTEGER; fillCh: CHAR; showBase: BOOLEAN);
-	BEGIN
-		out.WriteIntForm(x, base, minWidth, fillCh, showBase); Flush
-	END IntForm;
-
-	PROCEDURE RealForm* (x: REAL; precision, minW, expW: INTEGER; fillCh: CHAR);
-	BEGIN
-		out.WriteRealForm(x, precision, minW, expW, fillCh); Flush
-	END RealForm;
-
-	PROCEDURE Tab*;
-	BEGIN
-		out.WriteTab; Flush
-	END Tab;
-
-	PROCEDURE Ln*;
-	BEGIN
-		out.WriteLn; Flush;
-		TextViews.ShowRange(text, text.Length(), text.Length(), TextViews.any)
-	END Ln;
-
-	PROCEDURE Para*;
-	BEGIN
-		out.WritePara; Flush;
-		TextViews.ShowRange(text, text.Length(), text.Length(), TextViews.any)
-	END Para;
-
-	PROCEDURE View* (v: Views.View);
-	BEGIN
-		out.WriteView(v); Flush
-	END View;
-
-	PROCEDURE ViewForm* (v: Views.View; w, h: INTEGER);
-	BEGIN
-		out.WriteViewForm(v, w, h); Flush
-	END ViewForm;
-
-	PROCEDURE ParamMsg* (IN msg, p0, p1, p2: ARRAY OF CHAR);
-	BEGIN
-		out.WriteParamMsg(msg, p0, p1, p2); Flush
-	END ParamMsg;
-
-	PROCEDURE Msg* (IN msg: ARRAY OF CHAR);
-	BEGIN
-		out.WriteMsg(msg); Flush
-	END Msg;
-	
-
-	PROCEDURE^ Open*;
-
-	PROCEDURE (hook: ShowHook) ShowParamMsg (IN s, p0, p1, p2: ARRAY OF CHAR);
-	BEGIN
-		IF Dialog.showsStatus THEN
-			Dialog.ShowParamStatus(s, p0, p1, p2);
-			IF logAlerts THEN
-				ParamMsg(s, p0, p1, p2); Ln
-			END
-		ELSE
-			IF logAlerts THEN
-				Open;
-				ParamMsg(s, p0, p1, p2); Ln
-			ELSE
-				HostDialog.ShowParamMsg(s, p0, p1, p2)
-			END
-		END
-	END ShowParamMsg;
-	
-	PROCEDURE (hook: ShowHook) ShowParamStatus (IN s, p0, p1, p2: ARRAY OF CHAR);
-	BEGIN
-		HostDialog.ShowParamStatus(s, p0, p1, p2)
-	END ShowParamStatus;
-
-
-	PROCEDURE NewView* (): TextViews.View;
-		VAR v: TextViews.View;
-	BEGIN
-		Flush;
-		Dialog.SetShowHook(showHook); 	(* attach alert dialogs *)
-		v := dir.New(text);
-		v.SetDefaults(TextRulers.CopyOf(defruler, Views.deep), dir.defAttr);
-		RETURN v
-	END NewView;
-
-	PROCEDURE New*;
-	BEGIN
-		Views.Deposit(NewView())
-	END New;
-
-
-	PROCEDURE SetDefaultRuler* (ruler: TextRulers.Ruler);
-	BEGIN
-		defruler := ruler
-	END SetDefaultRuler;
-
-	PROCEDURE SetDir* (d: TextViews.Directory);
-	BEGIN
-		ASSERT(d # NIL, 20); dir := d
-	END SetDir;
-
-
-	PROCEDURE Open*;
-		VAR v: Views.View; pos: INTEGER;
-	BEGIN
-		v := NewView();
-		StdDialog.Open(v, "#Dev:Log", NIL, "", NIL, FALSE, TRUE, FALSE, FALSE, TRUE);
-		Views.RestoreDomain(text.Domain());
-		pos := text.Length();
-		TextViews.ShowRange(text, pos, pos, TextViews.any);
-		TextControllers.SetCaret(text, pos)
-	END Open;
-
-	PROCEDURE Clear*;
-	BEGIN
-		Models.BeginModification(Models.notUndoable, text);
-		text.Delete(0, text.Length());
-		buf.Delete(0, buf.Length());
-		Models.EndModification(Models.notUndoable, text)
-	END Clear;
-	
-
-	(* Sub support *)
-
-	PROCEDURE* Guard (o: ANYPTR): BOOLEAN;
-	BEGIN
-		RETURN
-			(o # NIL) &
-			~(		(o IS TextModels.Model) & (o = text)
-				OR   (o IS Stores.Domain) & (o = text.Domain())
-				OR   (o IS TextViews.View) & (o(TextViews.View).ThisModel() = text)
-			)
-	END Guard;
-
-	PROCEDURE* ClearBuf;
-		VAR subBuf: TextModels.Model;
-	BEGIN
-		subBuf := subOut.rider.Base(); subBuf.Delete(0, subBuf.Length())
-	END ClearBuf;
-
-	PROCEDURE* FlushBuf;
-		VAR buf: TextModels.Model;
-	BEGIN
-		buf := subOut.rider.Base();
-		IF buf.Length() > 0 THEN
-			IF ~Log.synch THEN Open() END;
-			text.Append(buf)
-		END
-	END FlushBuf;
-
-	PROCEDURE* SubFlush;
-	BEGIN
-		IF Log.synch THEN
-			FlushBuf;
-			IF Log.force THEN Views.RestoreDomain(text.Domain()) END
-		END;
-	END SubFlush;
-
-
-
-
-	PROCEDURE (log: LogHook) Guard* (o: ANYPTR): BOOLEAN;
-	BEGIN RETURN Guard(o)
-	END Guard;
-	
-	PROCEDURE (log: LogHook) ClearBuf*;
-	BEGIN ClearBuf
-	END ClearBuf;
-	
-	PROCEDURE (log: LogHook) FlushBuf*;
-	BEGIN FlushBuf
-	END FlushBuf;
-	
-	PROCEDURE (log: LogHook) Beep*;
-	BEGIN Dialog.Beep
-	END Beep;
-	
-	PROCEDURE (log: LogHook) Char* (ch: CHAR);
-	BEGIN
-		subOut.WriteChar(ch); SubFlush
-	END Char;
-	
-	PROCEDURE (log: LogHook) Int* (n: INTEGER);
-	BEGIN
-		subOut.WriteChar(" "); subOut.WriteInt(n); SubFlush
-	END Int;
-	
-	PROCEDURE (log: LogHook) Real* (x: REAL);
-	BEGIN
-		subOut.WriteChar(" "); subOut.WriteReal(x); SubFlush
-	END Real;
-	
-	PROCEDURE (log: LogHook) String* (IN str: ARRAY OF CHAR);
-	BEGIN
-		subOut.WriteString(str); SubFlush
-	END String;
-	
-	PROCEDURE (log: LogHook) Bool* (x: BOOLEAN);
-	BEGIN
-		subOut.WriteChar(" "); subOut.WriteBool(x); SubFlush
-	END Bool;
-	
-	PROCEDURE (log: LogHook) Set* (x: SET);
-	BEGIN
-		subOut.WriteChar(" "); subOut.WriteSet(x); SubFlush
-	END Set;
-	
-	PROCEDURE (log: LogHook) IntForm* (x: INTEGER; base, minWidth: INTEGER; fillCh: CHAR; showBase: BOOLEAN);
-	BEGIN
-		subOut.WriteIntForm(x, base, minWidth, fillCh, showBase); SubFlush
-	END IntForm;
-	
-	PROCEDURE (log: LogHook) RealForm* (x: REAL; precision, minW, expW: INTEGER; fillCh: CHAR);
-	BEGIN
-		subOut.WriteRealForm(x, precision, minW, expW, fillCh); SubFlush
-	END RealForm;
-	
-	PROCEDURE (log: LogHook) Tab*;
-	BEGIN
-		subOut.WriteTab; SubFlush
-	END Tab;
-	
-	PROCEDURE (log: LogHook) Ln*;
-	BEGIN
-		subOut.WriteLn; SubFlush;
-		IF Log.synch THEN Views.RestoreDomain(text.Domain()) END	
-	END Ln;
-	
-	PROCEDURE (log: LogHook) Para*;
-	BEGIN
-		subOut.WritePara; SubFlush;
-		IF Log.synch THEN Views.RestoreDomain(text.Domain()) END
-	END Para;
-	
-	PROCEDURE (log: LogHook) View* (v: ANYPTR);
-	BEGIN
-		IF (v # NIL) & (v IS Views.View) THEN
-			subOut.WriteView(v(Views.View)); SubFlush
-		END
-	END View;
-	
-	PROCEDURE (log: LogHook) ViewForm* (v: ANYPTR; w, h: INTEGER);
-	BEGIN
-		ASSERT(v # NIL, 20);
-		IF (v # NIL) & (v IS Views.View) THEN
-			subOut.WriteViewForm(v(Views.View), w, h); SubFlush
-		END
-	END ViewForm;
-
-	PROCEDURE (log: LogHook) ParamMsg* (IN s, p0, p1, p2: ARRAY OF CHAR);
-		VAR msg: ARRAY 256 OF CHAR; i: INTEGER; ch: CHAR;
-	BEGIN
-		IF logAlerts THEN
-			IF Log.synch THEN Open END;
-			Dialog.MapParamString(s, p0, p1, p2, msg);
-			i := 0; ch := msg[0];
-			WHILE ch # 0X DO
-				IF ch = TextModels.line THEN subOut.WriteLn
-				ELSIF ch = TextModels.para THEN subOut.WritePara
-				ELSIF ch = TextModels.tab THEN subOut.WriteTab
-				ELSIF ch >= " " THEN subOut.WriteChar(ch)
-				END;
-				INC(i); ch := msg[i];
-			END;
-			subOut.WriteLn; SubFlush
-		ELSE
-			HostDialog.ShowParamMsg(s, p0, p1, p2)
-		END
-	END ParamMsg;
-
-
-	PROCEDURE AttachSubLog;
-		VAR h: LogHook;
-	BEGIN
-		subOut.ConnectTo(TextModels.dir.New());
-		NEW(h);
-		Log.SetHook(h);
-	END AttachSubLog;
-
-	PROCEDURE DetachSubLog;
-	BEGIN
-		Log.SetHook(NIL);
-	END DetachSubLog;
-
-
-	PROCEDURE Init;
-		VAR font: Fonts.Font; p: TextRulers.Prop; x: INTEGER; i: INTEGER;
-	BEGIN
-		logAlerts := TRUE; (* logReports := FALSE; *)
-
-		text := TextModels.dir.New();
-		buf := TextModels.CloneOf(text);
-		out.ConnectTo(buf);
-
-		font := TextModels.dir.attr.font;
-		defruler := TextRulers.dir.New(NIL);
-		TextRulers.SetRight(defruler, 80*mm);
-		dir := TextViews.dir;
-		NEW(showHook)
-	END Init;
-
-BEGIN
-	Init; AttachSubLog
-CLOSE
-	DetachSubLog; 
-END StdLog.

BlackBox/Std/Mod/Logos.txt

@@ -1,162 +0,0 @@
-MODULE StdLogos;
-
-	(* THIS IS TEXT COPY OF BlackBox 1.6-rc6 Std/Mod/Logos.odc *)
-	(* DO NOT EDIT *)
-
-	IMPORT Ports, Stores, Views, Controllers, Properties;
-
-	CONST
-		W = 4;
-		baseSize = 24 * Ports.point;
-
-		colBase = 00202020H;
-
-		changeColorKey = "#System:ChangeColor";
-
-		minVersion = 0; maxVersion = 0;
-
-
-	TYPE
-		View = POINTER TO RECORD (Views.View)
-			c: Ports.Color
-		END;
-		
-		ChangeSizeOp = POINTER TO RECORD (Stores.Operation)
-			view: View;
-			size: INTEGER;
-		END;
-	
-		ChangeColorOp = POINTER TO RECORD (Stores.Operation)
-			view: View;
-			color: Ports.Color
-		END;
-		
-	(* curve painting *)
-
-	PROCEDURE Paint (f: Views.Frame; size: INTEGER; col, bgnd: Ports.Color);
-		VAR i, d, s, g, m, a, b, l, l0, rl, rt, rr, rb: INTEGER; c: Ports.Color;
-	BEGIN
-		s := size DIV 10; d := size DIV 2; g := d DIV 8; m := size * W DIV 2;
-		f.DrawOval(0, s * 2, size * W, size, Ports.fill, col);
-		f.DrawOval(s * W, s * 11 DIV 4, (size - s) * W, size - s * 3 DIV 4, Ports.fill, bgnd);
-		a := m; b := m + d; c := 7 * colBase; i := 0;
-		WHILE i < 4 DO
-			f.DrawOval(a, 0, b, d, Ports.fill, c);
-			INC(a, g); DEC(b, g); DEC(c, colBase); INC(i)
-		END;
-		f.rider.GetRect(rl, rt, rr, rb);
-		l0 := rl; l := (f.gx + m + d DIV 2) DIV f.unit;
-		IF l < rr THEN
-			f.rider.SetRect(l, rt, rr, rb);
-			a := m; b := m + d; c := 0; i := 0;
-			WHILE i < 4 DO
-				f.DrawOval(a, 0, b, d, Ports.fill, c);
-				INC(a, g); DEC(b, g); INC(c, colBase); INC(i)
-			END;
-			f.rider.SetRect(l0, rt, rr, rb)
-		END
-	END Paint;
-
-	(* ChangeOp *)
-
-	PROCEDURE (op: ChangeSizeOp) Do;
-		VAR v: View; size, w: INTEGER;
-	BEGIN
-		v := op.view;
-		size := op.size; v.context.GetSize(w, op.size); v.context.SetSize(size * W, size);
-		Views.Update(v, Views.keepFrames)
-	END Do;
-
-	PROCEDURE (op: ChangeColorOp) Do;
-		VAR v: View; color: Ports.Color;
-	BEGIN
-		v := op.view;
-		color := op.color; op.color := v.c; v.c := color;
-		Views.Update(v, Views.keepFrames)
-	END Do;
-
-	(* View *)
-
-	PROCEDURE (v: View) Internalize (VAR rd: Stores.Reader);
-		VAR thisVersion: INTEGER;
-	BEGIN
-		v.Internalize^(rd); IF rd.cancelled THEN RETURN END;
-		rd.ReadVersion(minVersion, maxVersion, thisVersion); IF rd.cancelled THEN RETURN END;
-		rd.ReadInt(v.c)
-	END Internalize;
-
-	PROCEDURE (v: View) Externalize (VAR wr: Stores.Writer);
-	BEGIN
-		v.Externalize^(wr);
-		wr.WriteVersion(maxVersion);
-		wr.WriteInt(v.c)
-	END Externalize;
-
-	PROCEDURE (v: View) CopyFromSimpleView (source: Views.View);
-	BEGIN
-		WITH source: View DO v.c := source.c END
-	END CopyFromSimpleView;
-
-	PROCEDURE (v: View) Restore (f: Views.Frame; l, t, r, b: INTEGER);
-		VAR w, h: INTEGER; bgnd: Ports.Color; g: Views.Frame;
-	BEGIN
-		g := f;
-		REPEAT
-			g := Views.HostOf(g);
-			bgnd := Views.transparent;
-			g.view.GetBackground(bgnd)
-		UNTIL bgnd # Views.transparent;
-		v.context.GetSize(w, h);
-		Paint(f, h, v.c, bgnd)
-	END Restore;
-	
-	PROCEDURE (v: View) HandleCtrlMsg (f: Views.Frame; VAR msg: Controllers.Message;
-																VAR focus: Views.View);
-	BEGIN
-		WITH msg: Properties.CollectMsg DO
-			Views.HandlePropMsg(v, msg.poll)
-		| msg: Properties.EmitMsg DO
-			Views.HandlePropMsg(v, msg.set)
-		ELSE	(* ignore other messages *)
-		END
-	END HandleCtrlMsg;
-
-	PROCEDURE (v: View) HandlePropMsg (VAR msg: Properties.Message);
-		VAR q: Properties.Property; p: Properties.StdProp;
-			cop: ChangeColorOp;
-	BEGIN
-		WITH msg: Properties.SizePref DO
-			IF (msg.w > Views.undefined) & (msg.h > Views.undefined) THEN
-				(* constrain proposed size *)
-				Properties.ProportionalConstraint(W, 1, msg.fixedW, msg.fixedH, msg.w, msg.h)
-			ELSE
-				(* return default size *)
-				msg.w := W * baseSize; msg.h := baseSize
-			END
-		| msg: Properties.PollMsg DO
-			NEW(p); p.known := {Properties.color}; p.valid := p.known;
-			p.color.val := v.c;
-			msg.prop := p
-		| msg: Properties.SetMsg DO
-			q := msg.prop;
-			WHILE q # NIL DO
-				WITH q: Properties.StdProp DO
-					IF Properties.color IN q.valid THEN
-						NEW(cop); cop.view := v; cop.color := q.color.val;
-						Views.Do(v, changeColorKey, cop)
-					END;
-				ELSE
-				END;
-				q :=q.next
-			END
-		ELSE
-		END
-	END HandlePropMsg;
-	
-	PROCEDURE Deposit*;
-		VAR v: View;
-	BEGIN
-		NEW(v); v.c := Ports.grey50; Views.Deposit(v)
-	END Deposit;
-
-END StdLogos.

BlackBox/Std/Mod/Scrollers.txt

@@ -1,853 +0,0 @@
-MODULE StdScrollers;
-
-	(* THIS IS TEXT COPY OF BlackBox 1.6-rc6 Std/Mod/Scrollers.odc *)
-	(* DO NOT EDIT *)
-
-	IMPORT Dialog, Ports, Services, Stores, Models, Views, Properties, Controllers, StdCFrames;
-	
-	
-	CONST
-		(* properties & options *)
-		horBar* = 0; verBar* = 1; horHide* = 2; verHide* = 3; width* = 4; height* = 5; showBorder* = 6; savePos* = 7;
-		
-
-	TYPE
-		Prop* = POINTER TO RECORD (Properties.Property)
-			horBar*, verBar*: BOOLEAN;
-			horHide*, verHide*: BOOLEAN;
-			width*, height*: INTEGER;
-			showBorder*: BOOLEAN;
-			savePos*: BOOLEAN
-		END;
-		
-		ScrollBar = POINTER TO RECORD (Views.View)
-			v: View;
-			ver: BOOLEAN
-		END;
-		
-		InnerView = POINTER TO RECORD (Views.View)
-			v: View
-		END;
-		
-		View = POINTER TO RECORD (Views.View);
-			view: Views.View;
-			sbW: INTEGER;
-			orgX, orgY: INTEGER;
-			w, h: INTEGER;						(* = 0: adapt to container *)
-			opts: SET;
-			(* not persistent *)
-			hor, ver: ScrollBar;
-			inner: InnerView;
-			rgap, bgap: INTEGER;				(* = 0: no scrollbar *)
-			border: INTEGER;
-			update: Action
-		END;
-		
-		Context = POINTER TO RECORD (Models.Context)
-			v: View;
-			type: INTEGER
-		END;
-		
-		Action = POINTER TO RECORD (Services.Action)
-			v: View
-		END;
-	
-		Op = POINTER TO RECORD (Stores.Operation)
-			v: View;
-			p: Prop
-		END;
-		
-		SOp = POINTER TO RECORD (Stores.Operation)
-			v: View;
-			x, y: INTEGER
-		END;
-		
-		UpdateMsg = RECORD (Views.Message)
-			changed: BOOLEAN
-		END;
-
-	
-	VAR
-		dialog*: RECORD
-			horizontal*, vertical*: RECORD
-				mode*: INTEGER;
-				adapt*: BOOLEAN;
-				size*: REAL
-			END;
-			showBorder*: BOOLEAN;
-			savePos*: BOOLEAN;
-			valid, readOnly: SET
-		END;
-		
-
-	(* tools *)
-	
-	PROCEDURE CheckPos (v: View; VAR x, y: INTEGER);
-		VAR w, h: INTEGER;
-	BEGIN
-		v.context.GetSize(w, h);
-		DEC(w, v.rgap + 2 * v.border);
-		DEC(h, v.bgap + 2 * v.border);
-		IF x > v.w - w THEN x := v.w - w END;
-		IF x < 0 THEN x := 0 END;
-		IF y > v.h - h THEN y := v.h - h END;
-		IF y < 0 THEN y := 0 END
-	END CheckPos;
-	
-	PROCEDURE InnerFrame (v: View; f: Views.Frame): Views.Frame;
-		VAR g, h: Views.Frame;
-	BEGIN
-		g := Views.ThisFrame(f, v.inner);
-		IF g = NIL THEN
-			Views.InstallFrame(f, v.inner, v.border, v.border, 0, TRUE);
-			g := Views.ThisFrame(f, v.inner)
-		END;
-		IF g # NIL THEN
-			h := Views.ThisFrame(g, v.view);
-			IF h = NIL THEN
-				Views.InstallFrame(g, v.view, -v.orgX, -v.orgY, 0, TRUE);
-				h := Views.ThisFrame(g, v.view)
-			END
-		END;
-		RETURN h
-	END InnerFrame;
-
-	PROCEDURE Scroll (v: View; dir: INTEGER; ver: BOOLEAN; p: INTEGER; OUT pos: INTEGER);
-		VAR x, y: INTEGER; last: Stores.Operation; op: SOp;
-	BEGIN
-		x := v.orgX; y := v.orgY;
-		IF ver THEN pos := y ELSE pos := x END;
-		IF dir = StdCFrames.lineUp THEN
-			DEC(pos, 10 * Ports.mm)
-		ELSIF dir = StdCFrames.lineDown THEN
-			INC(pos, 10 * Ports.mm)
-		ELSIF dir = StdCFrames.pageUp THEN
-			DEC(pos, 40 * Ports.mm)
-		ELSIF dir = StdCFrames.pageDown THEN
-			INC(pos, 40 * Ports.mm)
-		ELSIF dir = Controllers.gotoPos THEN
-			pos := p
-		END;
-		IF ver THEN CheckPos(v, x, pos); y := pos
-		ELSE CheckPos(v, pos, y); x := pos
-		END;
-		IF (x # v.orgX) OR (y # v.orgY) THEN
-			last := Views.LastOp(v);
-			IF ~(savePos IN v.opts) OR (last # NIL) & (last IS SOp) THEN
-				v.orgX := x; v.orgY := y;
-				Views.Update(v.view, Views.keepFrames)
-			ELSE
-				NEW(op); op.v := v; op.x := x; op.y := y;
-				Views.Do(v, "#System:Scrolling", op)
-			END
-		END
-	END Scroll;
-	
-	PROCEDURE PollSection (v: View; ver: BOOLEAN; OUT size, sect, pos: INTEGER);
-		VAR w, h: INTEGER;
-	BEGIN
-		v.context.GetSize(w, h);
-		IF ver THEN size := v.h; sect := h - v.bgap - 2 * v.border; pos := v.orgY
-		ELSE size := v.w; sect := w - v.rgap - 2 * v.border; pos := v.orgX
-		END
-	END PollSection;
-	
-	
-	(* SOp *)
-	
-	PROCEDURE (op: SOp) Do;
-		VAR x, y: INTEGER;
-	BEGIN
-		x := op.x; op.x := op.v.orgX; op.v.orgX := x;
-		y := op.y; op.y := op.v.orgY; op.v.orgY := y;
-		Views.Update(op.v.view, Views.keepFrames)
-	END Do;
-	
-
-	(* properties *)
-	
-	PROCEDURE (p: Prop) IntersectWith* (q: Properties.Property; OUT equal: BOOLEAN);
-		VAR valid: SET;
-	BEGIN
-		WITH q: Prop DO
-			valid := p.valid * q.valid; equal := TRUE;
-			IF p.horBar # q.horBar THEN EXCL(valid, horBar) END;
-			IF p.verBar # q.verBar THEN EXCL(valid, verBar) END;
-			IF p.horHide # q.horHide THEN EXCL(valid, horHide) END;
-			IF p.verHide # q.verHide THEN EXCL(valid, verHide) END;
-			IF p.width # q.width THEN EXCL(valid, width) END;
-			IF p.height # q.height THEN EXCL(valid, height) END;
-			IF p.showBorder # q.showBorder THEN EXCL(valid, showBorder) END;
-			IF p.savePos # q.savePos THEN EXCL(valid, savePos) END;
-			IF p.valid # valid THEN p.valid := valid; equal := FALSE END
-		END
-	END IntersectWith;
-	
-	PROCEDURE SetProp (v: View; p: Properties.Property);
-		VAR op: Op;
-	BEGIN
-		WITH p: Prop DO
-			NEW(op); op.v := v; op.p := p;
-			Views.Do(v, "#System:SetProp", op)
-		END
-	END SetProp;
-	
-	PROCEDURE PollProp (v: View; OUT prop: Prop);
-		VAR p: Prop;
-	BEGIN
-		NEW(p);
-		p.valid := {horBar, verBar, horHide, verHide, width, height, showBorder, savePos};
-		p.readOnly := {width, height} - v.opts;
-		p.horBar := horBar IN v.opts;
-		p.verBar := verBar IN v.opts;
-		p.horHide := horHide IN v.opts;
-		p.verHide := verHide IN v.opts;
-		p.width := v.w;
-		p.height := v.h;
-		p.showBorder := showBorder IN v.opts;
-		p.savePos := savePos IN v.opts;
-		p.known := p.valid; prop := p
-	END PollProp;
-	
-	
-	(* Op *)
-	
-	PROCEDURE (op: Op) Do;
-		VAR p: Prop; v: View; valid: SET;
-	BEGIN
-		v := op.v; p := op.p; PollProp(v, op.p); op.p.valid := p.valid;
-		valid := p.valid * ({horBar, verBar, horHide, verHide, showBorder, savePos} + v.opts * {width, height});
-		IF horBar IN valid THEN
-			IF p.horBar THEN INCL(v.opts, horBar) ELSE EXCL(v.opts, horBar) END
-		END;
-		IF verBar IN valid THEN
-			IF p.verBar THEN INCL(v.opts, verBar) ELSE EXCL(v.opts, verBar) END
-		END;
-		IF horHide IN valid THEN
-			IF p.horHide THEN INCL(v.opts, horHide) ELSE EXCL(v.opts, horHide) END
-		END;
-		IF verHide IN valid THEN
-			IF p.verHide THEN INCL(v.opts, verHide) ELSE EXCL(v.opts, verHide) END
-		END;
-		IF width IN valid THEN v.w := p.width END;
-		IF height IN valid THEN v.h := p.height END;
-		IF showBorder IN valid THEN
-			IF p.showBorder THEN INCL(v.opts, showBorder); v.border := 2 * Ports.point
-			ELSE EXCL(v.opts, showBorder); v.border := 0
-			END
-		END;
-		IF savePos IN valid THEN
-			IF p.savePos THEN INCL(v.opts, savePos) ELSE EXCL(v.opts, savePos) END
-		END;
-		Views.Update(v, Views.rebuildFrames)
-	END Do;
-	
-	
-	(* Action *)
-	
-	PROCEDURE (a: Action) Do;
-		VAR msg: UpdateMsg;
-	BEGIN
-		msg.changed := FALSE;
-		Views.Broadcast(a.v, msg);
-		IF msg.changed THEN Views.Update(a.v, Views.keepFrames)
-		ELSE
-			Views.Broadcast(a.v.hor, msg);
-			Views.Broadcast(a.v.ver, msg)
-		END
-	END Do;
-	
-	
-	(* ScrollBars *)
-	
-	PROCEDURE TrackSB (f: StdCFrames.ScrollBar; dir: INTEGER; VAR pos: INTEGER);
-		VAR s: ScrollBar; msg: Controllers.ScrollMsg; pmsg: Controllers.PollSectionMsg; host, inner: Views.Frame;
-	BEGIN
-		s := f.view(ScrollBar); host := Views.HostOf(f);
-		msg.focus := FALSE; msg.vertical := s.ver;
-		msg.op := dir; msg.done := FALSE;
-		inner := InnerFrame(s.v, host);
-		IF inner # NIL THEN Views.ForwardCtrlMsg(inner, msg) END;
-		IF msg.done THEN
-			pmsg.focus := FALSE; pmsg.vertical := s.ver;
-			pmsg.valid := FALSE; pmsg.done := FALSE;
-			inner := InnerFrame(s.v, host);
-			IF inner # NIL THEN Views.ForwardCtrlMsg(inner, pmsg) END;
-			IF pmsg.done THEN
-				pos := pmsg.partPos
-			END
-		ELSE
-			Scroll(s.v, dir, s.ver, 0, pos);
-			Views.ValidateRoot(Views.RootOf(host))
-		END
-	END TrackSB;
-
-	PROCEDURE SetSB (f: StdCFrames.ScrollBar; pos: INTEGER);
-		VAR s: ScrollBar; msg: Controllers.ScrollMsg; p: INTEGER; host, inner: Views.Frame;
-	BEGIN
-		s := f.view(ScrollBar); host := Views.HostOf(f);
-		msg.focus := FALSE; msg.vertical := s.ver;
-		msg.op := Controllers.gotoPos; msg.pos := pos;
-		msg.done := FALSE;
-		inner := InnerFrame(s.v, host);
-		IF inner # NIL THEN Views.ForwardCtrlMsg(inner, msg) END;
-		IF ~msg.done THEN
-			Scroll(s.v, Controllers.gotoPos, s.ver, pos, p);
-			Views.ValidateRoot(Views.RootOf(host))
-		END
-	END SetSB;
-
-	PROCEDURE GetSB (f: StdCFrames.ScrollBar; OUT size, sect, pos: INTEGER);
-		VAR s: ScrollBar; msg: Controllers.PollSectionMsg; host, inner: Views.Frame;
-	BEGIN
-		s := f.view(ScrollBar); host := Views.HostOf(f);
-		msg.focus := FALSE; msg.vertical := s.ver;
-		msg.wholeSize := 1; msg.partSize := 0; msg.partPos := 0;
-		msg.valid := FALSE; msg.done := FALSE;
-		inner := InnerFrame(s.v, host);
-		IF inner # NIL THEN Views.ForwardCtrlMsg(inner, msg) END;
-		IF msg.done THEN
-			IF msg.valid THEN
-				size := msg.wholeSize; sect := msg.partSize; pos := msg.partPos
-			ELSE
-				size := 1; sect := 1; pos := 0
-			END
-		ELSE
-			PollSection(s.v, s.ver, size, sect, pos)
-		END
-	END GetSB;
-
-	PROCEDURE (s: ScrollBar) GetNewFrame (VAR frame: Views.Frame);
-		VAR f: StdCFrames.ScrollBar;
-	BEGIN
-		f := StdCFrames.dir.NewScrollBar();
-		f.disabled := FALSE; f.undef := FALSE; f.readOnly := FALSE;
-		f.Track := TrackSB; f.Get := GetSB; f.Set := SetSB;
-		frame := f
-	END GetNewFrame;
-
-	PROCEDURE (s: ScrollBar) Restore (f: Views.Frame; l, t, r, b: INTEGER);
-	BEGIN
-		WITH f: StdCFrames.Frame DO f.Restore(l, t, r, b) END
-	END Restore;
-	
-	PROCEDURE (s: ScrollBar) HandleCtrlMsg (f: Views.Frame; VAR msg: Controllers.Message;
-																		VAR focus: Views.View);
-	BEGIN
-		WITH f: StdCFrames.Frame DO
-			WITH msg: Controllers.PollCursorMsg DO
-				f.GetCursor(msg.x, msg.y, msg.modifiers, msg.cursor)
-			| msg: Controllers.TrackMsg DO
-				f.MouseDown(msg.x, msg.y, msg.modifiers)
-			ELSE
-			END
-		END
-	END HandleCtrlMsg;
-	
-	PROCEDURE (s: ScrollBar) HandleViewMsg (f: Views.Frame; VAR msg: Views.Message);
-	BEGIN
-		WITH msg: UpdateMsg DO
-			WITH f: StdCFrames.Frame DO f.Update() END
-		ELSE
-		END
-	END HandleViewMsg;
-
-	
-	(* View *)
-	
-	PROCEDURE Update (v: View; f: Views.Frame);
-		VAR msg: Controllers.PollSectionMsg; w, h: INTEGER; depends: BOOLEAN; inner: Views.Frame;
-	BEGIN
-		v.bgap := 0; v.rgap := 0; depends := FALSE;
-		v.context.GetSize(w, h);
-		DEC(w, 2 * v.border); DEC(h, 2 * v.border);
-		IF horBar IN v.opts THEN
-			IF horHide IN v.opts THEN
-				msg.focus := FALSE; msg.vertical := FALSE;
-				msg.wholeSize := 1; msg.partSize := 0; msg.partPos := 0;
-				msg.valid := FALSE; msg.done := FALSE;
-				inner := InnerFrame(v, f);
-				IF inner # NIL THEN Views.ForwardCtrlMsg(inner, msg) END;
-				IF msg.done THEN
-					IF msg.valid THEN v.bgap := v.sbW END
-				ELSIF v.w > 0 THEN
-					IF w < v.w THEN v.bgap := v.sbW
-					ELSIF w - v.sbW < v.w THEN depends := TRUE
-					END
-				END
-			ELSE v.bgap := v.sbW
-			END
-		END;
-		IF verBar IN v.opts THEN
-			IF verHide IN v.opts THEN
-				msg.focus := FALSE; msg.vertical := TRUE;
-				msg.wholeSize := 1; msg.partSize := 0; msg.partPos := 0;
-				msg.valid := FALSE; msg.done := FALSE;
-				inner := InnerFrame(v, f);
-				IF inner # NIL THEN Views.ForwardCtrlMsg(inner, msg) END;
-				IF msg.done THEN
-					IF msg.valid THEN v.rgap := v.sbW END
-				ELSIF v.h > 0 THEN
-					IF h - v.bgap < v.h THEN v.rgap := v.sbW END
-				END
-			ELSE v.rgap := v.sbW
-			END
-		END;
-		IF depends & (v.rgap > 0) THEN v.bgap := v.sbW END;
-		CheckPos(v, v.orgX, v.orgY)
-	END Update;
-	
-	PROCEDURE Init (v: View; newView: BOOLEAN);
-		CONST min = 2 * Ports.mm; max = MAX(INTEGER); default = 50 * Ports.mm;
-		VAR c: Context; x: INTEGER; msg: Properties.ResizePref;
-	BEGIN
-		IF newView THEN
-			v.opts := v.opts + {horBar, verBar, horHide, verHide};
-			StdCFrames.dir.GetScrollBarSize(x, v.sbW);
-			IF v.view.context # NIL THEN
-				v.view.context.GetSize(v.w, v.h);
-				v.view := Views.CopyOf(v.view, Views.shallow)
-			ELSE
-				v.w := Views.undefined; v.h := Views.undefined;
-				Properties.PreferredSize(v.view, min, max, min, max, default, default, v.w, v.h)
-			END;
-			msg.fixed := FALSE;
-			msg.horFitToWin := FALSE; msg.verFitToWin := FALSE;
-			msg.horFitToPage := FALSE; msg.verFitToPage := FALSE;
-			Views.HandlePropMsg(v.view, msg);
-			IF ~msg.fixed THEN
-				INCL(v.opts, width); INCL(v.opts, height);
-				IF msg.horFitToWin OR msg.horFitToPage THEN v.w := 0 END;
-				IF msg.verFitToWin OR msg.verFitToPage THEN v.h := 0 END
-			END
-		END;
-		v.rgap := 0; v.bgap := 0;
-		IF showBorder IN v.opts THEN v.border := 2 * Ports.point ELSE v.border := 0 END;
-		NEW(v.inner); v.inner.v := v;
-		NEW(c); c.v := v; c.type := 3; v.inner.InitContext(c);
-		NEW(v.hor); v.hor.ver := FALSE; v.hor.v := v;
-		NEW(c); c.v := v; c.type := 2; v.hor.InitContext(c);
-		NEW(v.ver); v.ver.ver := TRUE; v.ver.v := v;
-		NEW(c); c.v := v; c.type := 1; v.ver.InitContext(c);
-		NEW(v.update); v.update.v := v;
-		Stores.Join(v, v.view);
-		Stores.Join(v, v.inner);
-		Stores.Join(v, v.hor);
-		Stores.Join(v, v.ver);
-		Services.DoLater(v.update, Services.now)
-	END Init;
-	
-	PROCEDURE (v: View) Internalize (VAR rd: Stores.Reader);
-		VAR thisVersion: INTEGER;
-	BEGIN
-		v.Internalize^(rd);
-		IF ~rd.cancelled THEN
-			rd.ReadVersion(0, 0, thisVersion);
-			IF ~rd.cancelled THEN
-				Views.ReadView(rd, v.view);
-				rd.ReadInt(v.sbW);
-				rd.ReadInt(v.orgX);
-				rd.ReadInt(v.orgY);
-				rd.ReadInt(v.w);
-				rd.ReadInt(v.h);
-				rd.ReadSet(v.opts);
-				Init(v, FALSE)
-			END
-		END
-	END Internalize;
-
-	PROCEDURE (v: View) Externalize (VAR wr: Stores.Writer);
-	BEGIN
-		v.Externalize^(wr);
-		wr.WriteVersion(0);
-		Views.WriteView(wr, v.view);
-		wr.WriteInt(v.sbW);
-		IF savePos IN v.opts THEN
-			wr.WriteInt(v.orgX);
-			wr.WriteInt(v.orgY)
-		ELSE
-			wr.WriteInt(0);
-			wr.WriteInt(0)
-		END;
-		wr.WriteInt(v.w);
-		wr.WriteInt(v.h);
-		wr.WriteSet(v.opts);
-	END Externalize;
-
-	PROCEDURE (v: View) ThisModel(): Models.Model;
-	BEGIN
-		RETURN v.view.ThisModel()
-	END ThisModel;
-	
-	PROCEDURE (v: View) CopyFromModelView (source: Views.View; model: Models.Model);
-	BEGIN
-		WITH source: View DO
-			IF model = NIL THEN v.view := Views.CopyOf(source.view, Views.deep)
-			ELSE v.view := Views.CopyWithNewModel(source.view, model)
-			END;
-			v.sbW := source.sbW;
-			v.orgX := source.orgX;
-			v.orgY := source.orgY;
-			v.w := source.w;
-			v.h := source.h;
-			v.opts := source.opts;
-		END;
-		Init(v, FALSE)
-	END CopyFromModelView;
-	
-	PROCEDURE (v: View) InitContext (context: Models.Context);
-		VAR c: Context;
-	BEGIN
-		v.InitContext^(context);
-		IF v.view.context = NIL THEN
-			NEW(c); c.v := v; c.type := 0; v.view.InitContext(c)
-		END
-	END InitContext;
-
-	PROCEDURE (v: View) Neutralize;
-	BEGIN
-		v.view.Neutralize
-	END Neutralize;
-
-	PROCEDURE (v: View) Restore (f: Views.Frame; l, t, r, b: INTEGER);
-		VAR w, h: INTEGER;
-	BEGIN
-		v.context.GetSize(w, h);
-		IF showBorder IN v.opts THEN
-			v.border := 2 * f.dot;
-			f.DrawRect(0, f.dot, w, v.border, Ports.fill, Ports.black);
-			f.DrawRect(f.dot, 0, v.border, h, Ports.fill, Ports.black);
-			f.DrawRect(0, h - v.border, w, h - f.dot, Ports.fill, Ports.grey25);
-			f.DrawRect(w - v.border, 0, w - f.dot, h, Ports.fill, Ports.grey25);
-			f.DrawRect(0, 0, w, f.dot, Ports.fill, Ports.grey50);
-			f.DrawRect(0, 0, f.dot, h, Ports.fill, Ports.grey50);
-			f.DrawRect(0, h - f.dot, w, h, Ports.fill, Ports.white);
-			f.DrawRect(w - f.dot, 0, w, h, Ports.fill, Ports.white)
-		END;
-		Views.InstallFrame(f, v.inner, v.border, v.border, 0, TRUE);
-		IF v.bgap > 0 THEN Views.InstallFrame(f, v.hor, v.border, h - v.border - v.bgap, 0, FALSE) END;
-		IF v.rgap > 0 THEN Views.InstallFrame(f, v.ver, w - v.border - v.rgap, v.border, 0, FALSE) END
-	END Restore;
-	
-	PROCEDURE (v: View) HandleCtrlMsg (f: Views.Frame; VAR msg: Controllers.Message; VAR focus: Views.View);
-		VAR w, h, p, n: INTEGER;smsg: Controllers.ScrollMsg; inner: Views.Frame;
-	BEGIN
-		WITH msg: Controllers.WheelMsg DO
-			smsg.focus := FALSE; smsg.op := msg.op; smsg.pos := 0; smsg.done := FALSE; n := msg.nofLines;
-			IF (v.rgap > 0) OR (v.bgap > 0) THEN
-				smsg.vertical := v.rgap > 0;
-				REPEAT
-					smsg.done := FALSE;
-					inner := InnerFrame(v, f);
-					IF inner # NIL THEN Views.ForwardCtrlMsg(inner, smsg) END;
-					IF ~smsg.done THEN
-						Scroll(v, smsg.op, smsg.vertical, 0, p);
-						Views.ValidateRoot(Views.RootOf(f))
-					END;
-					DEC(n)
-				UNTIL n <= 0;
-				msg.done := TRUE
-			ELSE
-				focus := v.inner
-			END
-		| msg: Controllers.CursorMessage DO
-			v.context.GetSize(w, h);
-			IF msg.x > w - v.border - v.rgap THEN
-				IF msg.y <= h - v.border - v.bgap THEN focus := v.ver END
-			ELSIF msg.y > h - v.border - v.bgap THEN focus := v.hor
-			ELSE focus := v.inner
-			END
-		| msg: Controllers.PollSectionMsg DO
-			inner := InnerFrame(v, f);
-			IF inner # NIL THEN Views.ForwardCtrlMsg(inner, msg) END;
-			IF ~msg.done THEN
-				PollSection(v, msg.vertical, msg.wholeSize, msg.partSize, msg.partPos);
-				msg.valid := msg.partSize < msg.wholeSize;
-				msg.done := TRUE
-			END
-		| msg: Controllers.ScrollMsg DO
-			inner := InnerFrame(v, f);
-			IF inner # NIL THEN Views.ForwardCtrlMsg(inner, msg) END;
-			IF ~msg.done THEN
-				Scroll(v, msg.op, msg.vertical, msg.pos, p);
-				Views.ValidateRoot(Views.RootOf(f));
-				msg.done := TRUE
-			END
-		ELSE focus := v.inner
-		END;
-		IF ~(msg IS Controllers.TickMsg) THEN
-			Services.DoLater(v.update, Services.now)
-		END
-	END HandleCtrlMsg;
-
-	PROCEDURE (v: View) HandleViewMsg (f: Views.Frame; VAR msg: Views.Message);
-		VAR b, r: INTEGER;
-	BEGIN
-		WITH msg: UpdateMsg DO
-			b := v.bgap; r := v.rgap;
-			Update(v, f);
-			IF (v.bgap # b) OR (v.rgap # r) THEN msg.changed := TRUE END
-		ELSE
-		END
-	END HandleViewMsg;
-
-	PROCEDURE (v: View) HandlePropMsg (VAR msg: Properties.Message);
-		VAR w, h: INTEGER; p: Properties.Property; prop: Prop; fv: Views.View;
-	BEGIN
-		WITH msg: Properties.FocusPref DO
-			v.context.GetSize(w, h);
-			Views.HandlePropMsg(v.view, msg);
-			IF msg.atLocation THEN
-				IF (msg.x > w - v.border - v.rgap) & (msg.y > h - v.border - v.bgap) THEN
-					msg.hotFocus := FALSE; msg.setFocus := FALSE
-				ELSIF ((msg.x > w - v.border - v.rgap) OR (msg.y > h - v.border - v.bgap)) & ~msg.setFocus THEN
-					msg.hotFocus := TRUE
-				END
-			END
-		| msg: Properties.SizePref DO
-			IF (v.w > 0) & (v.h > 0) THEN
-				IF msg.w = Views.undefined THEN msg.w := 50 * Ports.mm END;
-				IF msg.h = Views.undefined THEN msg.h := 50 * Ports.mm END
-			ELSE
-				IF msg.w > v.rgap THEN DEC(msg.w, v.rgap + 2 * v.border) END;
-				IF msg.h > v.bgap THEN DEC(msg.h, v.bgap + 2 * v.border) END;
-				Views.HandlePropMsg(v.view, msg);
-				IF msg.w > 0 THEN INC(msg.w, v.rgap + 2 * v.border) END;
-				IF msg.h > 0 THEN INC(msg.h, v.bgap + 2 * v.border) END
-			END;
-			IF msg.w < 3 * v.sbW THEN msg.w := 3 * v.sbW END;
-			IF msg.h < 3 * v.sbW THEN msg.h := 3 * v.sbW END
-		| msg: Properties.ResizePref DO
-			Views.HandlePropMsg(v.view, msg);
-			IF v.w > 0 THEN
-				msg.fixed := FALSE;
-				msg.horFitToWin := TRUE;
-				msg.horFitToPage := FALSE
-			END;
-			IF v.h > 0 THEN
-				msg.fixed := FALSE;
-				msg.verFitToWin := TRUE;
-				msg.verFitToPage := FALSE
-			END
-		| msg: Properties.BoundsPref DO
-			Views.HandlePropMsg(v.view, msg);
-			INC(msg.w, 2 * v.border);
-			INC(msg.h, 2 * v.border);
-			IF (horBar IN v.opts) & ~(horHide IN v.opts) THEN INC(msg.w, v.sbW) END;
-			IF (verBar IN v.opts) & ~(verHide IN v.opts) THEN INC(msg.h, v.sbW) END
-		| msg: Properties.PollMsg DO
-			Views.HandlePropMsg(v.view, msg);
-			PollProp(v, prop); Properties.Insert(msg.prop, prop)
-		| msg: Properties.SetMsg DO
-			p := msg.prop; WHILE (p # NIL) & ~(p IS Prop) DO p := p.next END;
-			IF p # NIL THEN SetProp(v, p) END;
-			Views.HandlePropMsg(v.view, msg);
-		| msg: Properties.ControlPref DO
-			fv := msg.focus;
-			IF fv = v THEN msg.focus := v.view END;
-			Views.HandlePropMsg(v.view, msg);
-			msg.focus := fv
-		ELSE
-			Views.HandlePropMsg(v.view, msg);
-		END;
-	END HandlePropMsg;
-	
-	
-	(* InnerView *)
-	
-	PROCEDURE (v: InnerView) GetBackground (VAR color: Ports.Color);
-	BEGIN
-		color := Ports.background
-	END GetBackground;
-
-	PROCEDURE (v: InnerView) Restore (f: Views.Frame; l, t, r, b: INTEGER);
-	BEGIN
-		Views.InstallFrame(f, v.v.view, -v.v.orgX, -v.v.orgY, 0, TRUE)
-	END Restore;
-	
-	PROCEDURE (v: InnerView) HandleCtrlMsg (f: Views.Frame; VAR msg: Controllers.Message;
-																		VAR focus: Views.View);
-	BEGIN
-		focus := v.v.view
-	END HandleCtrlMsg;
-
-
-	(* Context *)
-	
-	PROCEDURE (c: Context) MakeVisible (l, t, r, b: INTEGER);
-		VAR w, h, x, y: INTEGER;
-	BEGIN
-		IF ~(savePos IN c.v.opts) THEN
-			c.v.context.GetSize(w, h);
-			x := c.v.orgX; y := c.v.orgY;
-			IF c.v.w > 0 THEN
-				DEC(w, c.v.rgap + 2 * c.v.border);
-				IF r > x + w - Ports.point THEN x := r - w + Ports.point END;
-				IF l < x + Ports.point THEN x := l - Ports.point END;
-			END;
-			IF c.v.h > 0 THEN
-				DEC(h, c.v.bgap + 2 * c.v.border);
-				IF b > y + h - Ports.point THEN y := b - h + Ports.point END;
-				IF t < y + Ports.point THEN y := t - Ports.point END;
-			END;
-			IF (x # c.v.orgX) OR (y # c.v.orgY) THEN
-				CheckPos(c.v, x, y); c.v.orgX := x; c.v.orgY := y; 
-				Views.Update(c.v.view, Views.keepFrames)
-			END;
-			Services.DoLater(c.v.update, Services.now)
-		END
-	END MakeVisible;
-	
-	PROCEDURE (c: Context) Consider (VAR p: Models.Proposal);
-	BEGIN
-		c.v.context.Consider(p)
-	END Consider;
-	
-	PROCEDURE (c: Context) Normalize (): BOOLEAN;
-	BEGIN
-		RETURN ~(savePos IN c.v.opts)
-	END Normalize;
-	
-	PROCEDURE (c: Context) GetSize (OUT w, h: INTEGER);
-	BEGIN
-		c.v.context.GetSize(w, h);
-		DEC(w, c.v.rgap + 2 * c.v.border);
-		DEC(h, c.v.bgap + 2 * c.v.border);
-		IF c.type = 0 THEN
-			IF c.v.w > 0 THEN w := c.v.w END;
-			IF c.v.h > 0 THEN h := c.v.h END
-		ELSIF c.type = 1 THEN
-			w := c.v.rgap
-		ELSIF c.type = 2 THEN
-			h := c.v.bgap
-		END
-	END GetSize;
-	
-	PROCEDURE (c: Context) SetSize (w, h: INTEGER);
-		VAR w0, h0, w1, h1: INTEGER;
-	BEGIN
-		ASSERT(c.type = 0, 100);
-		c.v.context.GetSize(w0, h0); w1 := w0; h1 := h0;
-		IF c.v.w > 0 THEN c.v.w := w
-		ELSE w1 := w + c.v.rgap + 2 * c.v.border
-		END;
-		IF c.v.h > 0 THEN c.v.h := h
-		ELSE h1 := h + c.v.bgap + 2 * c.v.border
-		END;
-		IF (w1 # w0) OR (h1 # h0) THEN
-			c.v.context.SetSize(w1, h1)
-		END
-	END SetSize;
-	
-	PROCEDURE (c: Context) ThisModel (): Models.Model;
-	BEGIN
-		RETURN NIL
-	END ThisModel;
-	
-	
-	(* dialog *)
-	
-	PROCEDURE InitDialog*;
-		VAR  p: Properties.Property; u: INTEGER;
-	BEGIN
-		Properties.CollectProp(p);
-		WHILE (p # NIL) & ~(p IS Prop) DO p := p.next END;
-		IF p # NIL THEN
-			WITH p: Prop DO
-				IF Dialog.metricSystem THEN u := Ports.mm DIV 10 ELSE u := Ports.inch DIV 100 END;
-				dialog.valid := p.valid;
-				dialog.readOnly := p.readOnly;
-				IF ~p.horBar THEN dialog.horizontal.mode := 0
-				ELSIF p.horHide THEN dialog.horizontal.mode := 1
-				ELSE dialog.horizontal.mode := 2
-				END;
-				IF ~p.verBar THEN dialog.vertical.mode := 0
-				ELSIF p.verHide THEN dialog.vertical.mode := 1
-				ELSE dialog.vertical.mode := 2
-				END;
-				dialog.horizontal.size := p.width DIV u / 100;
-				dialog.vertical.size := p.height DIV u / 100;
-				dialog.horizontal.adapt := p.width = 0;
-				dialog.vertical.adapt := p.height = 0;
-				dialog.showBorder := p.showBorder;
-				dialog.savePos := p.savePos
-			END
-		END
-	END InitDialog;
-	
-	PROCEDURE Set*;
-		VAR p: Prop; u: INTEGER;
-	BEGIN
-		IF Dialog.metricSystem THEN u := 10 * Ports.mm ELSE u := Ports.inch END;
-		NEW(p); p.valid := dialog.valid;
-		p.horBar := dialog.horizontal.mode # 0;
-		p.verBar := dialog.vertical.mode # 0;
-		p.horHide := dialog.horizontal.mode = 1;
-		p.verHide := dialog.vertical.mode = 1;
-		IF ~dialog.horizontal.adapt THEN p.width := SHORT(ENTIER(dialog.horizontal.size * u)) END;
-		IF ~dialog.vertical.adapt THEN p.height := SHORT(ENTIER(dialog.vertical.size * u)) END;
-		p.showBorder := dialog.showBorder;
-		p.savePos := dialog.savePos;
-		Properties.EmitProp(NIL, p)
-	END Set;
-	
-	PROCEDURE DialogGuard* (VAR par: Dialog.Par);
-		VAR  p: Properties.Property;
-	BEGIN
-		Properties.CollectProp(p);
-		WHILE (p # NIL) & ~(p IS Prop) DO p := p.next END;
-		IF p = NIL THEN par.disabled := TRUE END
-	END DialogGuard;
-	
-	PROCEDURE HorAdaptGuard* (VAR par: Dialog.Par);
-	BEGIN
-		IF width IN dialog.readOnly THEN par.readOnly := TRUE END
-	END HorAdaptGuard;
-	
-	PROCEDURE VerAdaptGuard* (VAR par: Dialog.Par);
-	BEGIN
-		IF height IN dialog.readOnly THEN par.readOnly := TRUE END
-	END VerAdaptGuard;
-	
-	PROCEDURE WidthGuard* (VAR par: Dialog.Par);
-	BEGIN
-		IF dialog.horizontal.adapt THEN par.disabled := TRUE
-		ELSIF width IN dialog.readOnly THEN par.readOnly := TRUE
-		END
-	END WidthGuard;
-	
-	PROCEDURE HeightGuard* (VAR par: Dialog.Par);
-	BEGIN
-		IF dialog.vertical.adapt THEN par.disabled := TRUE
-		ELSIF height IN dialog.readOnly THEN par.readOnly := TRUE
-		END
-	END HeightGuard;
-	
-	
-	(* commands *)	
-	
-	PROCEDURE AddScroller*;
-		VAR poll: Controllers.PollOpsMsg; v: View; replace: Controllers.ReplaceViewMsg;
-	BEGIN
-		Controllers.PollOps(poll);
-		IF (poll.singleton # NIL) & ~(poll.singleton IS View) THEN
-			NEW(v); v.view := poll.singleton; Init(v, TRUE);
-			replace.old := poll.singleton; replace.new := v;
-			Controllers.Forward(replace)
-		ELSE Dialog.Beep
-		END
-	END AddScroller;
-
-	PROCEDURE RemoveScroller*;
-		VAR poll: Controllers.PollOpsMsg; replace: Controllers.ReplaceViewMsg;
-	BEGIN
-		Controllers.PollOps(poll);
-		IF (poll.singleton # NIL) & (poll.singleton IS View) THEN
-			replace.old := poll.singleton;
-			replace.new := Views.CopyOf(poll.singleton(View).view, Views.shallow);
-			Controllers.Forward(replace)
-		ELSE Dialog.Beep
-		END
-	END RemoveScroller;
-
-END StdScrollers.

BlackBox/Std/Mod/Stamps.txt

@@ -1,436 +0,0 @@
-MODULE StdStamps;
-
-	(* THIS IS TEXT COPY OF BlackBox 1.6-rc6 Std/Mod/Stamps.odc *)
-	(* DO NOT EDIT *)
-
-(*
-	StdStamps are used to keep track of document changes, in particular program texts.
-	StdStamps carry a sequence number and a fingerprint of the document with them.
-	Each time the document (and therefore its fingerprint) is changed and stored,
-	the sequence number is incremented. (When determining the fingerprint of the
-	document, whitespace is ignored, except in string literals.)
-	
-	Each StdStamp also keeps track of the history of most recent changes.
-	For the last maxHistoryEntries sequence numbers, the date and time,
-	and an optional one-line comment is stored. To avoid too many entries in the history
-	while working on a module, the most recent history entry is overwritten upon the
-	generation of a new sequence number if the current date is the same as the date in
-	the history entry.
-
-*)
-
-	IMPORT
-		SYSTEM, (* SYSTEM.ROT only, for fingerprint calculation *)
-		Strings, Dates, StdCmds,
-		Ports, Models, Stores, Containers, Properties, Views, Controllers, Fonts,
-		TextModels, TextSetters, TextMappers, TextViews, TextRulers;
-
-	CONST
-		setCommentKey = "#Std:Set Comment";
-		maxHistoryEntries = 25;
-		minVersion = 0; origStampVersion = 0; thisVersion = 2;
-		
-	TYPE
-		History = ARRAY maxHistoryEntries OF RECORD
-			fprint, snr: INTEGER;	(* fingerprint, sequence number *)
-			date: INTEGER;			(* days since 1/1/1 *)
-			time: INTEGER;			(* min + 64 * hour *)
-			comment: POINTER TO ARRAY OF CHAR;	(* nil if no comment  *)
-		END;
-			
-		StdView = POINTER TO RECORD (Views.View)
-			(*--snr: LONGINT;*)			
-			nentries: INTEGER;	(* number of entries in history *)
-			history: History;			(* newest entry in history[0] *)
-			cache: ARRAY 64 OF CHAR;
-		END;
-
-		SetCmtOp = POINTER TO RECORD (Stores.Operation)
-			stamp: StdView;
-			oldcomment: POINTER TO ARRAY OF CHAR;
-		END;
-
-	VAR
-		comment*: RECORD
-			s*: ARRAY 64 OF CHAR;
-		END;
-
-
-	PROCEDURE (op: SetCmtOp) Do;
-		VAR temp: POINTER TO ARRAY OF CHAR;
-	BEGIN
-		temp := op.stamp.history[0].comment;
-		op.stamp.history[0].comment := op.oldcomment;
-		op.oldcomment := temp;
-	END Do;
-
-	PROCEDURE Format (v: StdView);
-		VAR s: ARRAY 64 OF CHAR; d: Dates.Date; t: INTEGER;
-	BEGIN
-		t := v.history[0].time;
-		Dates.DayToDate(v.history[0].date, d);
-		Dates.DateToString(d, Dates.plainAbbreviated, s); v.cache := s$;
-		Strings.IntToStringForm(v.history[0].snr, Strings.decimal, 4, "0", FALSE, s);
-		v.cache := v.cache + " (" + s + ")"
-	END Format;
-
-
-	PROCEDURE FontContext (v: StdView): Fonts.Font;
-		VAR c: Models.Context;
-	BEGIN
-		c := v.context;
-		IF (c # NIL) & (c IS TextModels.Context) THEN
-			RETURN c(TextModels.Context).Attr().font;
-		ELSE
-			RETURN Fonts.dir.Default()
-		END;
-	END FontContext;
-
-	PROCEDURE CalcFP (t: TextModels.Model): INTEGER;
-		CONST sglQuote = "'"; dblQuote = '"';
-		VAR fp: INTEGER;  rd: TextModels.Reader; ch, quoteChar: CHAR; 
-	BEGIN
-		quoteChar := 0X; fp := 0;
-		rd := t.NewReader(NIL); rd.ReadChar(ch);
-		WHILE ~rd.eot DO
-			IF ch = quoteChar THEN quoteChar := 0X;
-			ELSIF (quoteChar = 0X) & ((ch = dblQuote) OR (ch = sglQuote)) THEN quoteChar := ch;
-			END;
-			IF (quoteChar = 0X) & (21X <= ch) & (ch # 8BX) & (ch # 8FX) & (ch # 0A0X) (* not in string literal *)
-				OR (quoteChar # 0X) & (20X <= ch) (* within string literal *)
-			THEN
-				fp := SYSTEM.ROT(fp, 1) + 13 * ORD(ch);
-			END;
-			rd.ReadChar(ch);
-		END;
-		RETURN fp;
-	END CalcFP;
-
-	PROCEDURE Update (v: StdView; forcenew: BOOLEAN);
-		VAR fp: INTEGER; i: INTEGER; ndays: INTEGER; d: Dates.Date; t: Dates.Time;
-	BEGIN
-		IF (v.context # NIL) & (v.context IS TextModels.Context) THEN
-			fp := CalcFP(v.context(TextModels.Context).ThisModel());
-			IF (fp # v.history[0].fprint) OR forcenew THEN
-				Dates.GetDate(d); Dates.GetTime(t);
-				ndays := Dates.Day(d);
-				IF (ndays # v.history[0].date) OR forcenew THEN
-					(* move down entries in history list *)
-					i := maxHistoryEntries-1;
-					WHILE i > 0 DO
-						v.history[i] := v.history[i-1];
-						DEC(i);
-					END;
-					v.history[0].comment := NIL;
-				END;
-				IF v.nentries < maxHistoryEntries THEN INC(v.nentries) END;
-				INC(v.history[0].snr);
-				v.history[0].fprint := fp;
-				v.history[0].date := ndays;
-				v.history[0].time := t.minute + t.hour*64;
-				Format(v);
-				Views.Update(v, Views.keepFrames);
-			END;
-		END;
-	END Update;
-
-	PROCEDURE (v: StdView) Externalize (VAR wr: Stores.Writer);
-		VAR i, len: INTEGER;
-	BEGIN
-		Update(v, FALSE);
-		v.Externalize^(wr);
-		wr.WriteVersion(thisVersion);
-		(*--wr.WriteLInt(v.snr);*)
-		wr.WriteXInt(v.nentries);
-		FOR i := 0 TO v.nentries-1 DO
-			wr.WriteInt(v.history[i].fprint);
-			wr.WriteInt(v.history[i].snr);
-			wr.WriteInt(v.history[i].date);
-			wr.WriteXInt(v.history[i].time);
-			IF v.history[i].comment # NIL THEN
-				len := LEN(v.history[i].comment$);
-				wr.WriteXInt(len);
-				wr.WriteXString(v.history[i].comment^);
-			ELSE wr.WriteXInt(0);
-			END
-		END;
-	END Externalize;
-
-	PROCEDURE (v: StdView) Internalize (VAR rd: Stores.Reader);
-		VAR version: INTEGER; format: BYTE; i, len: INTEGER;
-			d: Dates.Date; t: Dates.Time;
-	BEGIN
-		v.Internalize^(rd);
-		IF ~rd.cancelled THEN
-			rd.ReadVersion(minVersion, thisVersion, version);
-			IF ~rd.cancelled THEN
-				IF version = origStampVersion THEN (* deal with old StdStamp format *)
-					(* would like to calculate fingerprint, but hosting model not available at this time *)
-					v.history[0].fprint := 0;
-					v.history[0].snr := 1; v.nentries := 1;
-					rd.ReadXInt(d.year); rd.ReadXInt(d.month); rd.ReadXInt(d.day);
-					rd.ReadXInt(t.hour); rd.ReadXInt(t.minute); rd.ReadXInt(t.second);
-					rd.ReadByte(format); (* format not used anymore *)
-					v.history[0].date := Dates.Day(d);
-					v.history[0].time := t.minute + t.hour*64;
-				ELSE
-					IF version = 1 THEN rd.ReadInt(v.history[0].snr) END; (* red text: to be removed soon *)
-					rd.ReadXInt(v.nentries);
-					FOR i := 0 TO v.nentries-1 DO
-						rd.ReadInt(v.history[i].fprint);
-						IF version > 1 THEN rd.ReadInt(v.history[i].snr)
-						ELSIF (* (version = 1) & *) i > 0 THEN v.history[i].snr := v.history[i-1].snr - 1;
-						END; (* red text: to be removed soon *)
-						rd.ReadInt(v.history[i].date);
-						rd.ReadXInt(v.history[i].time);
-						rd.ReadXInt(len);
-						IF len > 0 THEN
-							NEW(v.history[i].comment, len + 1);
-							rd.ReadXString(v.history[i].comment^);
-						ELSE v.history[i].comment := NIL;
-						END
-					END;
-				END;
-				Format(v);
-			END
-		END
-	END Internalize;
-
-	PROCEDURE (v: StdView) CopyFromSimpleView (source: Views.View);
-		VAR i: INTEGER;
-	BEGIN
-		(* v.CopyFrom^(source); *)
-		WITH source: StdView DO
-			(*--v.snr := source.snr;*)
-			v.nentries := source.nentries;
-			v.history := source.history;
-			v.cache := source.cache;
-			FOR i := 0 TO v.nentries - 1 DO
-				IF source.history[i].comment # NIL THEN
-					NEW(v.history[i].comment, LEN(source.history[i].comment$) + 1);
-					v.history[i].comment^ := source.history[i].comment^$;
-				END
-			END
-		END
-	END CopyFromSimpleView;
-
-	PROCEDURE (v: StdView) Restore (f: Views.Frame; l, t, r, b: INTEGER);
-		VAR a: TextModels.Attributes; color: Ports.Color; c: Models.Context; font: Fonts.Font;
-			asc, dsc, fw: INTEGER;
-	BEGIN
-		c := v.context;
-		IF (c # NIL) & (c IS TextModels.Context) THEN
-			a := v.context(TextModels.Context).Attr();
-			font := a.font;
-			color := a.color;
-		ELSE font := Fonts.dir.Default(); color := Ports.black;
-		END;
-		font.GetBounds(asc, dsc, fw);
-		f.DrawLine(f.l, asc + f.dot, f.r, asc + f.dot, 1, Ports.grey25 );
-		f.DrawString(0, asc, color, v.cache, font);
-	END Restore;
-
-	PROCEDURE SizePref (v: StdView; VAR p: Properties.SizePref);
-		VAR font: Fonts.Font; asc, dsc, w: INTEGER; d: Dates.Date; s: ARRAY 64 OF CHAR;
-	BEGIN
-		font := FontContext(v);
-		font.GetBounds(asc, dsc, w);
-		d.day := 28; d.month := 1; d.year := 2222; p.w := 0;
-		WHILE d.month <= 12 DO
-			Dates.DateToString(d, Dates.plainAbbreviated, s);
-			s := s + " (0000)";
-			w := font.StringWidth(s);
-			IF w > p.w THEN p.w := w END;
-			INC(d.month)
-		END;
-		p.h := asc + dsc;
-	END SizePref;
-
-	PROCEDURE (v: StdView) HandlePropMsg (VAR msg: Properties.Message);
-		VAR font: Fonts.Font; asc, w: INTEGER;
-	BEGIN
-		WITH msg: Properties.Preference DO
-			WITH msg: Properties.SizePref DO
-				SizePref(v, msg)
-			| msg: Properties.ResizePref DO
-				msg.fixed := TRUE
-			| msg: Properties.FocusPref DO
-				msg.hotFocus := TRUE
-			| msg: TextSetters.Pref DO
-				font := FontContext(v);
-				font.GetBounds(asc, msg.dsc, w);
-			ELSE
-			END
-		ELSE
-		END
-	END HandlePropMsg;
-
-	PROCEDURE NewRuler (): TextRulers.Ruler;
-		CONST mm = Ports.mm;
-		VAR r: TextRulers.Ruler;
-	BEGIN
-		r := TextRulers.dir.New(NIL);
-		TextRulers.SetRight(r, 140 * mm);
-		TextRulers.AddTab(r, 15 * mm); TextRulers.AddTab(r, 35 * mm); TextRulers.AddTab(r, 75 * mm);
-		RETURN r
-	END NewRuler;
-
-	PROCEDURE ShowHistory (v: StdView);
-		VAR text: TextModels.Model; f: TextMappers.Formatter;
-			i: INTEGER; d: Dates.Date; s: ARRAY 64 OF CHAR;
-			tv: TextViews.View; attr: TextModels.Attributes;
-	BEGIN
-		text := TextModels.dir.New();
-		f.ConnectTo(text);
-		attr := f.rider.attr;
-		f.rider.SetAttr(TextModels.NewStyle(attr, {Fonts.italic}));
-		f.WriteString("seq nr."); f.WriteTab;
-		f.WriteString("fingerprint"); f.WriteTab;
-		f.WriteString("date and time"); f.WriteTab;
-		f.WriteString("comment"); f.WriteLn;
-		f.rider.SetAttr(attr); f.WriteLn;
-		(*--n := v.snr;*)
-		FOR i := 0 TO v.nentries-1 DO
-			f.WriteIntForm(v.history[i].snr, 10, 4, "0", FALSE);
-			(*--DEC(n);*)
-			f.WriteTab;
-			f.WriteIntForm(v.history[i].fprint, TextMappers.hexadecimal, 8, "0", FALSE);
-			f.WriteTab;
-			Dates.DayToDate(v.history[i].date, d);
-			Dates.DateToString(d, Dates.plainAbbreviated, s);
-			f.WriteString(s);
-			f.WriteString("  ");
-			f.WriteIntForm(v.history[i].time DIV 64, 10, 2, "0", FALSE);
-			f.WriteString(":");
-			f.WriteIntForm(v.history[i].time MOD 64, 10, 2, "0", FALSE);
-			IF v.history[i].comment # NIL THEN
-				f.WriteTab;
-				f.WriteString( v.history[i].comment^);
-			END;
-			f.WriteLn;
-		END;
-		tv := TextViews.dir.New(text);
-		tv.SetDefaults(NewRuler(), TextViews.dir.defAttr);
-		tv.ThisController().SetOpts({Containers.noFocus, Containers.noCaret});
-		Views.OpenAux(tv, "History");
-	END ShowHistory;
-
-	PROCEDURE Track (v: StdView; f: Views.Frame; x, y: INTEGER; buttons: SET);
-		VAR c: Models.Context; w, h: INTEGER; isDown, in, in0: BOOLEAN; m: SET;
-	BEGIN
-		c := v.context; c.GetSize(w, h); in0 := FALSE; in := TRUE;
-		REPEAT
-			IF in # in0 THEN
-				f.MarkRect(0, 0, w, h, Ports.fill, Ports.invert, Ports.show); in0 := in
-			END;
-			f.Input(x, y, m, isDown);
-			in := (0 <= x) & (x < w) & (0 <= y) & (y < h)
-		UNTIL ~isDown;
-		IF in0 THEN
-			f.MarkRect(0, 0, w, h, Ports.fill, Ports.invert, Ports.hide);
-			IF Controllers.modify IN m THEN
-				IF v.history[0].comment # NIL THEN comment.s := v.history[0].comment^$;
-				ELSE comment.s := "";
-				END;
-				StdCmds.OpenToolDialog("Std/Rsrc/Stamps", "Comment");
-			ELSE ShowHistory(v);
-			END
-		END
-	END Track;
-
-	PROCEDURE (v: StdView) HandleCtrlMsg (
-				f: Views.Frame; VAR msg: Controllers.Message; VAR focus: Views.View);
-	BEGIN
-		WITH msg: Controllers.TrackMsg DO
-			Track(v, f, msg.x, msg.y, msg.modifiers)
-		| msg: Controllers.PollCursorMsg DO
-			msg.cursor := Ports.refCursor
-		ELSE
-		END
-	END HandleCtrlMsg;
-
-
-	(* ------------ programming interface: ---------------------- *)
-
-	PROCEDURE GetFirstInText* (t: TextModels.Model): Views.View;
-		VAR r: TextModels.Reader; v: Views.View;
-	BEGIN
-		IF t # NIL THEN
-			r := t.NewReader(NIL);
-			REPEAT r.ReadView(v) UNTIL (v = NIL) OR (v IS StdView);
-			RETURN v;
-		ELSE RETURN NIL;
-		END;
-	END GetFirstInText;
-
-	PROCEDURE IsStamp* (v: Views.View): BOOLEAN;
-	BEGIN
-		RETURN v IS StdView;
-	END IsStamp;
-
-	PROCEDURE GetInfo* (v: Views.View; VAR snr, historylen: INTEGER);
-	BEGIN
-		ASSERT(v IS StdView, 20);
-		WITH v: StdView DO
-			snr := v.history[0].snr; historylen := v.nentries;
-		END
-	END GetInfo;
-
-	PROCEDURE GetData* (v: Views.View; entryno: INTEGER;
-				VAR fprint: INTEGER; VAR date: Dates.Date; VAR time: Dates.Time);
-	BEGIN
-		ASSERT(v IS StdView, 20);
-		WITH v: StdView DO
-			IF entryno <= v.nentries THEN
-				fprint := v.history[entryno].fprint;
-				Dates.DayToDate(v.history[entryno].date, date);
-				time.minute := v.history[entryno].time MOD 64;
-				time.minute := v.history[entryno].time DIV 64;
-				time.second := 0;
-			END
-		END
-	END GetData;
-
-	(** Insert new history entry with comment in v. *)
-	PROCEDURE Stamp* (v: Views.View; comment: ARRAY OF CHAR);
-	BEGIN
-		ASSERT(v IS StdView, 20);
-		WITH v: StdView DO
-			Update(v, TRUE);
-			NEW(v.history[0].comment, LEN(comment$) + 1);
-			v.history[0].comment^ := comment$;
-		END
-	END Stamp;
-
-	PROCEDURE New* (): Views.View;
-		VAR v: StdView; d: Dates.Date; t: Dates.Time;
-	BEGIN
-		NEW(v); v.history[0].snr := 0; v.nentries := 0;
-		v.history[0].fprint := 0;
-		Dates.GetDate(d); Dates.GetTime(t);
-		v.history[0].date := Dates.Day(d);
-		v.history[0].time := t.minute + t.hour*64;
-		Format(v);
-		RETURN v;
-	END New;
-
-	PROCEDURE SetComment*;
-		VAR v: Views.View; op: SetCmtOp;
-	BEGIN
-		v := GetFirstInText(TextViews.FocusText());
-		IF v # NIL THEN
-			WITH v: StdView DO
-				NEW(op); op.stamp := v;
-				NEW(op.oldcomment, LEN(comment.s$) + 1);
-				op.oldcomment^ := comment.s$;
-				Views.Do(v, setCommentKey, op);
-			END
-		END
-	END SetComment;
-
-	PROCEDURE Deposit*;
-	BEGIN
-		Views.Deposit(New())
-	END Deposit;
-
-END StdStamps.

BlackBox/Std/Mod/ViewSizer.txt

@@ -1,133 +0,0 @@
-MODULE StdViewSizer;
-
-	(* THIS IS TEXT COPY OF BlackBox 1.6-rc6 Std/Mod/ViewSizer.odc *)
-	(* DO NOT EDIT *)
-
-	IMPORT Services, Ports, Dialog, Views, Containers, Properties;
-
-	CONST width = 1; height = 2;
-
-	VAR
-		size*: RECORD
-			typeName-: Dialog.String;
-			w*, h*: REAL;
-			proportional*, fixedW, fixedH: BOOLEAN;
-			unit, scaleW, scaleH, lastChanged: INTEGER;
-			unitText: ARRAY 6 OF CHAR;
-			view: Views.View;
-			container: Containers.Controller
-		END;
-
-	PROCEDURE ConnectDialog (v: Views.View; c: Containers.Controller);
-		VAR pref: Properties.ResizePref;
-	BEGIN
-		IF (v # NIL) & (v.context # NIL) THEN
-			IF Dialog.metricSystem THEN size.unit := Ports.mm * 10; size.unitText := "cm"
-			ELSE size.unit := Ports.inch; size.unitText := "inch"
-			END;
-			size.view := v; size.container := c;
-			Services.GetTypeName(v, size.typeName);
-			v.context.GetSize(size.scaleW, size.scaleH);
-			size.w := size.scaleW / size.unit; size.h := size.scaleH / size.unit;
-			pref.fixed := FALSE;
-			pref.horFitToPage := FALSE; pref.verFitToPage := FALSE;
-			pref.horFitToWin := FALSE; pref.verFitToWin := FALSE;
-			Views.HandlePropMsg(v, pref);
-			size.fixedW := pref.fixed;
-			size.fixedH := pref.fixed;
-			size.proportional := FALSE
-		ELSE
-			size.view := NIL; size.container := c; size.typeName := ""
-		END;
-		Dialog.Update(size)
-	END ConnectDialog;
-
-	PROCEDURE SetViewSize*;
-	BEGIN
-		IF size.view # NIL THEN
-			size.view.context.SetSize(SHORT(ENTIER(size.w * size.unit + 0.5)),
-												SHORT(ENTIER(size.h * size.unit + 0.5)));
-			IF size.container # NIL THEN size.container.SetSingleton(size.view) END;
-			ConnectDialog(size.view, size.container)
-		ELSE Dialog.Beep
-		END
-	END SetViewSize;
-
-	PROCEDURE InitDialog*;
-		VAR v: Views.View; c: Containers.Controller;
-	BEGIN
-		c := Containers.Focus();
-		IF c # NIL THEN v := c.Singleton() ELSE v := NIL END;
-		IF (v # size.view) OR (c # size.container) THEN ConnectDialog(v, c) END
-	END InitDialog;
-
-	PROCEDURE ResetDialog*;
-		VAR proportional: BOOLEAN; v: Views.View;
-	BEGIN
-		proportional := size.proportional; v := size.view;
-		size.view := NIL; InitDialog;
-		IF proportional & (v = size.view) THEN size.proportional := TRUE; Dialog.Update(size) END
-	END ResetDialog;
-
-	PROCEDURE WidthGuard* (VAR par: Dialog.Par);
-	BEGIN
-		InitDialog;
-		par.disabled := size.view = NIL;
-		par.readOnly := size.fixedW
-	END WidthGuard;
-
-	PROCEDURE HeightGuard* (VAR par: Dialog.Par);
-	BEGIN
-		InitDialog;
-		par.disabled := size.view = NIL;
-		par.readOnly := size.fixedH
-	END HeightGuard;
-
-	PROCEDURE ProportionGuard* (VAR par: Dialog.Par);
-	BEGIN
-		par.disabled := (size.view = NIL) OR size.fixedW OR size.fixedH OR (size.scaleW = 0) OR (size.scaleH = 0)
-	END ProportionGuard;
-
-	PROCEDURE UnitGuard* (VAR par: Dialog.Par);
-	BEGIN
-		IF size.view # NIL THEN par.label := size.unitText$ ELSE par.label := "" END
-	END UnitGuard;
-
-	PROCEDURE AdjustDialogToPref (fixedW, fixedH: BOOLEAN);
-		VAR w, h: INTEGER; w0, h0: REAL; pref: Properties.SizePref;
-	BEGIN
-		w := SHORT(ENTIER(size.w * size.unit + 0.5)); h := SHORT(ENTIER(size.h * size.unit + 0.5));
-		IF size.proportional & (w > 0) & (h > 0) & (size.scaleW > 0) & (size.scaleH > 0) THEN
-			Properties.ProportionalConstraint(size.scaleW, size.scaleH, fixedW, fixedH, w, h)
-		END;
-		pref.w := w; pref.h := h; pref.fixedW := fixedW; pref.fixedH := fixedH;
-		Views.HandlePropMsg(size.view, pref);
-		IF ~fixedW THEN w0 := pref.w / size.unit ELSE w0 := size.w END;
-		IF ~fixedH THEN h0 := pref.h / size.unit ELSE h0 := size.h END;
-		IF (w0 # size.w) OR (h0 # size.h) THEN size.w := w0; size.h := h0; Dialog.Update(size) END
-	END AdjustDialogToPref;
-
-	PROCEDURE WNotifier* (op, from, to: INTEGER);
-	BEGIN
-		IF size.w > 0 THEN AdjustDialogToPref(TRUE, FALSE); size.lastChanged := width
-		ELSIF size.w # 0 THEN Dialog.Beep
-		END
-	END WNotifier;
-
-	PROCEDURE HNotifier* (op, from, to: INTEGER);
-	BEGIN
-		IF size.h > 0 THEN AdjustDialogToPref(FALSE, TRUE); size.lastChanged := height
-		ELSIF size.h # 0 THEN Dialog.Beep
-		END
-	END HNotifier;
-
-	PROCEDURE ProportionNotifier* (op, from, to: INTEGER);
-	BEGIN
-		IF (op = Dialog.changed) & size.proportional THEN
-			IF size.lastChanged = width THEN AdjustDialogToPref(TRUE, FALSE)
-			ELSIF size.lastChanged = height THEN AdjustDialogToPref(FALSE, TRUE)
-			END
-		END
-	END ProportionNotifier;
-
-END StdViewSizer.

BlackBox/System/Mod/Console.txt

@@ -1,58 +0,0 @@
-MODULE Console;
-
-	(* THIS IS TEXT COPY OF Console.odc *)
-	(* DO NOT EDIT *)
-
-	(*
-		A. V. Shiryaev, 2012.10
-
-		Interface based on OpenBUGS Console
-	*)
-
-	TYPE
-		Console* = POINTER TO ABSTRACT RECORD END;
-
-	VAR
-		cons: Console;
-
-	(* Console *)
-
-	PROCEDURE (c: Console) WriteStr- (IN s: ARRAY OF CHAR), NEW, ABSTRACT;
-	PROCEDURE (c: Console) WriteChar- (ch: CHAR), NEW, ABSTRACT;
-	PROCEDURE (c: Console) WriteLn-, NEW, ABSTRACT;
-
-	(*
-		post:
-			s = "": end of input or input error
-			s # "": line with end of line postfix
-	*)
-	PROCEDURE (c: Console) ReadLn- (OUT s: ARRAY OF CHAR), NEW, ABSTRACT;
-
-
-	PROCEDURE WriteStr* (IN text: ARRAY OF CHAR);
-	BEGIN
-		cons.WriteStr(text)
-	END WriteStr;
-
-	PROCEDURE WriteChar* (c: CHAR);
-	BEGIN
-		cons.WriteChar(c)
-	END WriteChar;
-
-	PROCEDURE WriteLn*;
-	BEGIN
-		cons.WriteLn
-	END WriteLn;
-
-	PROCEDURE ReadLn* (OUT text: ARRAY OF CHAR);
-	BEGIN
-		cons.ReadLn(text)
-	END ReadLn;
-
-
-	PROCEDURE SetConsole* (c: Console);
-	BEGIN
-		cons := c
-	END SetConsole;
-
-END Console.