blackbox-linux-console/BlackBox/Dev0/Mod/CPE.txt

MODULE Dev0CPE;

	(* THIS IS TEXT COPY OF CPE.odc *)
	(* DO NOT EDIT *)

(**
	project	= "BlackBox"
	organization	= "www.oberon.ch"
	contributors	= "Oberon microsystems, Robert Campbell"
	version	= "System/Rsrc/About"
	copyright	= "System/Rsrc/About"
	license	= "Docu/BB-License"
	references	= "ftp://ftp.inf.ethz.ch/pub/software/Oberon/OberonV4/Docu/OP2.Paper.ps"
	changes	= ""
	issues	= ""

**)

	IMPORT SYSTEM, (* Dates, *) DevCPM := Dev0CPM, DevCPT := Dev0CPT;


	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); *)
		Out2(2007); Out2(5); Out2(25);
		Out2(0); Out2(0); Out2(0);
		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 Dev0CPE.