gpcp/Browse.cp

@@ -0,0 +1,2547 @@
+MODULE Browse;
+
+  IMPORT 
+        RTS,
+        Console,
+        Error,
+        CPmain,
+        GPFiles,
+	GPBinFiles,
+        ProgArgs,
+	Symbols,
+        IdDesc,
+        GPText,
+        GPTextFiles,
+        GPCPcopyright,
+	FileNames;
+
+(* ========================================================================= *
+// Collected syntax ---
+// 
+// SymFile    = Header [String (falSy | truSy | <other attribute>)]
+//		{Import | Constant | Variable | Type | Procedure} 
+//		TypeList Key.
+//	-- optional String is external name.
+//	-- falSy ==> Java class
+//	-- truSy ==> Java interface
+//	-- others ...
+// Header     = magic modSy Name.
+// Import     = impSy Name [String] Key.
+//	-- optional string is explicit external name of class
+// Constant   = conSy Name Literal.
+// Variable   = varSy Name TypeOrd.
+// Type       = typSy Name TypeOrd.
+// Procedure  = prcSy Name [String] FormalType.
+//	-- optional string is explicit external name of procedure
+// Method     = mthSy Name byte byte TypeOrd [String][Name] FormalType.
+//	-- optional string is explicit external name of method
+// FormalType = [retSy TypeOrd] frmSy {parSy byte TypeOrd [String]} endFm.
+//	-- optional phrase is return type for proper procedures
+// TypeOrd    = ordinal.
+// TypeHeader = tDefS Ord [fromS Ord Name].
+//	-- optional phrase occurs if:
+//	-- type not from this module, i.e. indirect export
+// TypeList   = start { Array | Record | Pointer | ProcType | 
+//                      NamedType | Enum | Vector } close.
+// Array      = TypeHeader arrSy TypeOrd (Byte | Number | <empty>) endAr.
+//	-- nullable phrase is array length for fixed length arrays
+// Vector     = TypeHeader arrSy basSy TypeOrd endAr.
+// Pointer    = TypeHeader ptrSy TypeOrd.
+// Event      = TypeHeader evtSy FormalType.
+// ProcType   = TypeHeader pTpSy FormalType.
+// Record     = TypeHeader recSy recAtt [truSy | falSy] 
+//		[basSy TypeOrd] [iFcSy {basSy TypeOrd}]
+//		{Name TypeOrd} {Method} {Statics} endRc.
+//	-- truSy ==> is an extension of external interface
+//	-- falSy ==> is an extension of external class
+// 	-- basSy option defines base type, if not ANY / j.l.Object
+// NamedType  = TypeHeader.
+// Statics    = ( Constant | Variable | Procedure ).
+// Enum       = TypeHeader eTpSy { Constant } endRc.
+// Name	      = namSy byte UTFstring.
+// Literal    = Number | String | Set | Char | Real | falSy | truSy.
+// Byte       = bytSy byte.
+// String     = strSy UTFstring.
+// Number     = numSy longint.
+// Real       = fltSy ieee-double.
+// Set        = setSy integer.
+// Key        = keySy integer..
+// Char       = chrSy unicode character.
+//
+// Notes on the syntax:
+// All record types must have a Name field, even though this is often
+// redundant.  The issue is that every record type (including those that
+// are anonymous in CP) corresponds to a IR class, and the definer 
+// and the user of the class _must_ agree on the IR name of the class.
+// The same reasoning applies to procedure types, which must have equal
+// interface names in all modules.
+// ======================================================================== *)
+
+  CONST
+	modSy = ORD('H'); namSy = ORD('$'); bytSy = ORD('\');
+	numSy = ORD('#'); chrSy = ORD('c'); strSy = ORD('s');
+	fltSy = ORD('r'); falSy = ORD('0'); truSy = ORD('1');
+	impSy = ORD('I'); setSy = ORD('S'); keySy = ORD('K');
+	conSy = ORD('C'); typSy = ORD('T'); tDefS = ORD('t');
+	prcSy = ORD('P'); retSy = ORD('R'); mthSy = ORD('M');
+	varSy = ORD('V'); parSy = ORD('p'); start = ORD('&');
+	close = ORD('!'); recSy = ORD('{'); endRc = ORD('}');
+	frmSy = ORD('('); fromS = ORD('@'); endFm = ORD(')');
+	arrSy = ORD('['); endAr = ORD(']'); pTpSy = ORD('%');
+	ptrSy = ORD('^'); basSy = ORD('+'); eTpSy = ORD('e');
+	iFcSy = ORD('~'); evtSy = ORD('v'); vecSy = ORD('*');
+
+  CONST
+	magic   = 0DEADD0D0H;
+	syMag   = 0D0D0DEADH;
+	dumped* = -1;
+        symExt  = ".cps";
+        broExt  = ".bro";
+        htmlExt = ".html";
+
+
+(* ============================================================ *)
+
+  TYPE
+
+    Desc = POINTER TO ABSTRACT RECORD
+             name : FileNames.NameString;
+             access : INTEGER;
+           END;
+
+    DescList = RECORD
+                 list : POINTER TO ARRAY OF Desc;
+                 tide : INTEGER;
+               END;
+
+    LitValue = POINTER TO ABSTRACT RECORD
+               END;
+
+    NumValue = POINTER TO RECORD (LitValue)
+                 numVal : LONGINT;
+               END;
+
+    SetValue = POINTER TO RECORD (LitValue)
+                 setVal : SET;
+               END;
+
+    StrValue = POINTER TO RECORD (LitValue)
+                 strVal : FileNames.NameString;
+               END;
+
+    FltValue = POINTER TO RECORD (LitValue)
+                 fltVal : REAL;
+               END;
+
+    BoolValue = POINTER TO RECORD (LitValue)
+                  boolVal : BOOLEAN;
+                END;
+
+    ChrValue = POINTER TO RECORD (LitValue)
+                 chrVal : CHAR;
+               END;
+
+    Type = POINTER TO ABSTRACT RECORD
+             declarer : Desc;             
+             importedFrom : Module;
+             importedName : FileNames.NameString;
+           END;
+
+    TypeList = POINTER TO ARRAY OF Type;
+
+    Named = POINTER TO RECORD (Type)
+            END;
+
+    Basic = POINTER TO EXTENSIBLE RECORD (Type)
+              name : FileNames.NameString;
+            END;
+
+    Enum = POINTER TO EXTENSIBLE RECORD (Type)
+             ids : DescList; 
+           END;
+
+    Pointer = POINTER TO EXTENSIBLE RECORD (Type)
+                baseNum : INTEGER;
+                isAnonPointer : BOOLEAN;
+                baseType : Type;
+              END;
+
+    Record = POINTER TO EXTENSIBLE RECORD (Type)
+               recAtt    : INTEGER;
+               baseType  : Type;
+               ptrType   : Pointer;
+               isAnonRec : BOOLEAN;
+               baseNum   : INTEGER;
+               intrFaces : DescList; 
+               fields    : DescList; 
+               methods   : DescList; 
+               statics   : DescList;
+             END;
+    
+    Array = POINTER TO EXTENSIBLE RECORD (Type)
+              size : INTEGER;
+              elemType : Type;
+              elemTypeNum : INTEGER;
+            END;
+
+    Vector = POINTER TO EXTENSIBLE RECORD (Type)
+               elemType : Type;
+               elemTypeNum : INTEGER;
+             END;
+
+    Par = POINTER TO RECORD
+            typeNum : INTEGER;
+            type    : Type;
+            opNm    : CharOpen; (* Optional *)
+            mode    : INTEGER;
+           END;
+
+    ParList = RECORD
+                list : POINTER TO ARRAY OF Par;
+                tide : INTEGER;
+              END;
+
+    Proc = POINTER TO EXTENSIBLE RECORD (Type)
+             fName         : FileNames.NameString;
+             retType       : Type;
+             retTypeNum    : INTEGER;
+             noModes       : BOOLEAN;
+             isConstructor : BOOLEAN;
+             pars          : ParList;
+           END;
+
+    Event   = POINTER TO RECORD (Proc) END;
+
+    Meth = POINTER TO EXTENSIBLE RECORD (Proc)
+             receiver   : Type;
+             recName    : CharOpen; (* Optional *)
+             recTypeNum : INTEGER;
+             attr       : INTEGER;
+             recMode    : INTEGER;
+           END;
+
+    
+    ImportDesc = POINTER TO RECORD (Desc)
+                 END;
+                 
+    ConstDesc = POINTER TO RECORD  (Desc)
+                  val : LitValue;
+                END;
+
+    TypeDesc = POINTER TO EXTENSIBLE RECORD (Desc)
+                type : Type;
+                typeNum : INTEGER;
+              END;
+
+    UserTypeDesc = POINTER TO RECORD (TypeDesc)
+                   END;
+
+    VarDesc = POINTER TO RECORD (TypeDesc)
+              END;
+
+    ProcDesc = POINTER TO RECORD (Desc)
+                 pType : Proc; 
+               END;
+
+    ModList = RECORD
+                tide : INTEGER;
+                list : POINTER TO ARRAY OF Module;
+              END;
+
+    Module = POINTER TO RECORD
+               name      : FileNames.NameString;
+               symName   : FileNames.NameString;
+               fName     : FileNames.NameString;
+               pathName  : GPFiles.FileNameArray;
+               imports   : ModList;
+               consts    : DescList;
+               vars      : DescList;
+               types     : DescList;
+               procs     : DescList;
+               systemMod : BOOLEAN;
+               progArg   : BOOLEAN;
+               print     : BOOLEAN;
+               strongNm  : POINTER TO ARRAY 6 OF INTEGER;
+             END;
+    
+(* ============================================================ *)
+
+  TYPE
+    
+    Output = POINTER TO EXTENSIBLE RECORD
+               thisMod : Module;
+             END;
+
+    FileOutput = POINTER TO EXTENSIBLE RECORD (Output)
+                   file : GPTextFiles.FILE;
+                 END;
+
+    HtmlOutput = POINTER TO RECORD (FileOutput)
+                 END;
+                    
+(* ============================================================ *)
+
+  TYPE
+
+    CharOpen = POINTER TO ARRAY OF CHAR;
+
+(* ============================================================ *)
+
+  VAR
+    args, argNo  : INTEGER;
+    fileName, modName  : FileNames.NameString;
+    printFNames, doAll, verbatim, hexCon, alpha : BOOLEAN;
+    file  : GPBinFiles.FILE;
+    sSym  : INTEGER;
+    cAtt  : CHAR;
+    iAtt  : INTEGER;
+    lAtt  : LONGINT;
+    rAtt  : REAL;
+    sAtt  : FileNames.NameString;
+    typeList : TypeList;
+    accArray : ARRAY 4 OF CHAR;
+    outExt  : ARRAY 6 OF CHAR;
+    output : Output;
+    module : Module;
+    modList : ModList;
+
+(* ============================================================ *)
+(* ============================================================ *)
+
+  PROCEDURE QuickSortDescs(lo, hi : INTEGER; dLst : DescList);
+    VAR i,j : INTEGER;
+        dsc : Desc;
+	tmp : Desc;
+   (* -------------------------------------------------- *)
+    PROCEDURE canonLT(l,r : ARRAY OF CHAR) : BOOLEAN;
+      VAR i : INTEGER;
+    BEGIN
+      FOR i := 0 TO LEN(l) - 1 DO l[i] := CAP(l[i]) END;
+      FOR i := 0 TO LEN(r) - 1 DO r[i] := CAP(r[i]) END;
+      RETURN l < r;
+    END canonLT;
+   (* -------------------------------------------------- *)
+   (* -------------------------------------------------- *)
+    PROCEDURE canonGT(l,r : ARRAY OF CHAR) : BOOLEAN;
+      VAR i : INTEGER;
+    BEGIN
+      FOR i := 0 TO LEN(l) - 1 DO l[i] := CAP(l[i]) END;
+      FOR i := 0 TO LEN(r) - 1 DO r[i] := CAP(r[i]) END;
+      RETURN l > r;
+    END canonGT;
+   (* -------------------------------------------------- *)
+  BEGIN
+    i := lo; j := hi;
+    dsc := dLst.list[(lo+hi) DIV 2];
+    REPEAT
+   (*
+    * WHILE dLst.list[i].name < dsc.name DO INC(i) END;
+    * WHILE dLst.list[j].name > dsc.name DO DEC(j) END;
+    *)
+      WHILE canonLT(dLst.list[i].name$, dsc.name$) DO INC(i) END;
+      WHILE canonGT(dLst.list[j].name$, dsc.name$) DO DEC(j) END;
+      IF i <= j THEN
+        tmp := dLst.list[i]; dLst.list[i] := dLst.list[j]; dLst.list[j] := tmp; 
+	INC(i); DEC(j);
+      END;
+    UNTIL i > j;
+    IF lo < j THEN QuickSortDescs(lo, j,  dLst) END;
+    IF i < hi THEN QuickSortDescs(i,  hi, dLst) END;
+  END QuickSortDescs;
+
+(* ============================================================ *)
+(* ============================================================ *)
+
+  PROCEDURE GetModule(name : FileNames.NameString) : Module;
+  VAR
+    i : INTEGER;
+    tmp : POINTER TO ARRAY OF Module;
+    mod : Module;
+  BEGIN
+    ASSERT(modList.list # NIL);
+    FOR i := 0 TO modList.tide-1 DO
+      IF modList.list[i].name = name THEN RETURN modList.list[i] END;
+    END;
+    IF modList.tide >= LEN(modList.list) THEN
+      tmp := modList.list;
+      NEW(modList.list,modList.tide*2);
+      FOR i := 0 TO modList.tide-1 DO
+        modList.list[i] := tmp[i]; 
+      END;
+    END; 
+    NEW(mod);
+    mod.systemMod := FALSE;
+    mod.progArg := FALSE;
+    mod.name := name;
+    mod.symName := name + symExt;
+    modList.list[modList.tide] := mod;
+    INC(modList.tide);
+    RETURN mod;
+  END GetModule;
+
+  PROCEDURE AddMod (VAR mList : ModList; m : Module);
+  VAR
+    tmp : POINTER TO ARRAY OF Module;
+    i : INTEGER;
+  BEGIN
+    IF mList.list = NIL THEN
+      NEW(mList.list,10);
+      mList.tide := 0;
+    ELSIF mList.tide >= LEN(mList.list) THEN 
+      tmp := mList.list;
+      NEW(mList.list,LEN(tmp)*2);
+      FOR i := 0 TO mList.tide-1 DO
+        mList.list[i] := tmp[i];
+      END;
+    END;
+    mList.list[mList.tide] := m;
+    INC(mList.tide);
+  END AddMod;
+
+(* ============================================================ *)
+
+  PROCEDURE AddDesc (VAR dList : DescList; d : Desc);
+  VAR
+    tmp : POINTER TO ARRAY OF Desc;
+    i : INTEGER;
+  BEGIN
+    IF dList.list = NIL THEN
+      NEW(dList.list,10);
+      dList.tide := 0;
+    ELSIF dList.tide >= LEN(dList.list) THEN 
+      tmp := dList.list;
+      NEW(dList.list,LEN(tmp)*2);
+      FOR i := 0 TO dList.tide-1 DO
+        dList.list[i] := tmp[i];
+      END;
+    END;
+    dList.list[dList.tide] := d;
+    INC(dList.tide);
+  END AddDesc;
+
+  PROCEDURE AddPar (VAR pList : ParList; p : Par);
+  VAR
+    tmp : POINTER TO ARRAY OF Par;
+    i : INTEGER;
+  BEGIN
+    IF pList.list = NIL THEN
+      NEW(pList.list,10);
+      pList.tide := 0;
+    ELSIF pList.tide >= LEN(pList.list) THEN 
+      tmp := pList.list;
+      NEW(pList.list,LEN(tmp)*2);
+      FOR i := 0 TO pList.tide-1 DO
+        pList.list[i] := tmp[i];
+      END;
+    END;
+    pList.list[pList.tide] := p;
+    INC(pList.tide);
+  END AddPar;
+
+  PROCEDURE AddType (VAR tList : TypeList; t : Type; pos : INTEGER);
+  VAR
+    tmp : POINTER TO ARRAY OF Type;
+    i : INTEGER;
+  BEGIN
+    ASSERT(tList # NIL);
+    IF pos >= LEN(tList) THEN 
+      tmp := tList;
+      NEW(tList,LEN(tmp)*2);
+      FOR i := 0 TO LEN(tmp)-1 DO
+        tList[i] := tmp[i];
+      END;
+    END;
+    tList[pos] := t;
+  END AddType;
+
+(* ============================================================ *)
+(* ========	Various reading utility procedures	======= *)
+(* ============================================================ *)
+
+  PROCEDURE read() : INTEGER;
+  BEGIN
+    RETURN GPBinFiles.readByte(file);
+  END read;
+
+(* ======================================= *)
+
+  PROCEDURE ReadUTF(OUT nam : ARRAY OF CHAR);
+    CONST
+	bad = "Bad UTF-8 string";
+    VAR num : INTEGER;
+	bNm : INTEGER;
+	idx : INTEGER;
+	chr : INTEGER;
+  BEGIN
+    num := 0;
+    bNm := read() * 256 + read();
+    FOR idx := 0 TO bNm-1 DO
+      chr := read();
+      IF chr <= 07FH THEN		(* [0xxxxxxx] *)
+	nam[num] := CHR(chr); INC(num);
+      ELSIF chr DIV 32 = 06H THEN	(* [110xxxxx,10xxxxxx] *)
+	bNm := chr MOD 32 * 64;
+	chr := read();
+	IF chr DIV 64 = 02H THEN
+	  nam[num] := CHR(bNm + chr MOD 64); INC(num);
+	ELSE
+	  RTS.Throw(bad);
+	END;
+      ELSIF chr DIV 16 = 0EH THEN	(* [1110xxxx,10xxxxxx,10xxxxxxx] *)
+	bNm := chr MOD 16 * 64;
+	chr := read();
+	IF chr DIV 64 = 02H THEN
+	  bNm := (bNm + chr MOD 64) * 64; 
+	  chr := read();
+	  IF chr DIV 64 = 02H THEN
+	    nam[num] := CHR(bNm + chr MOD 64); INC(num);
+	  ELSE 
+	    RTS.Throw(bad);
+	  END;
+	ELSE
+	  RTS.Throw(bad);
+	END;
+      ELSE
+	RTS.Throw(bad);
+      END;
+    END;
+    nam[num] := 0X;
+  END ReadUTF;
+
+(* ======================================= *)
+(*
+ * PROCEDURE ReadUTF(OUT nam : ARRAY OF CHAR);
+ *   CONST
+ *	bad = "Bad UTF-8 string";
+ *   VAR num : INTEGER;
+ *	bNm : INTEGER;
+ *	idx : INTEGER;
+ *	chr : INTEGER;
+ * BEGIN
+ *   num := 0;
+ *   bNm := read() * 256 + read();
+ *   FOR idx := 0 TO bNm-1 DO
+ *     chr := read();
+ *     IF chr <= 07FH THEN
+ *	nam[num] := CHR(chr); INC(num);
+ *     ELSIF chr DIV 32 = 06H THEN
+ *	bNm := chr MOD 32 * 64;
+ *	chr := read();
+ *	IF chr DIV 64 = 02H THEN
+ *	  nam[num] := CHR(bNm + chr DIV 64); INC(num);
+ *	ELSE
+ *	  RTS.Throw(bad);
+ *	END;
+ *     ELSIF chr DIV 16 = 0EH THEN
+ *	bNm := chr MOD 16 * 64;
+ *	chr := read();
+ *	IF chr DIV 64 = 02H THEN
+ *	  bNm := bNm + chr DIV 64; 
+ *	  chr := read();
+ *	  IF chr DIV 64 = 02H THEN
+ *	    nam[num] := CHR(bNm + chr DIV 64); INC(num);
+ *	  ELSE 
+ *	    RTS.Throw(bad);
+ *	  END;
+ *	ELSE
+ *	  RTS.Throw(bad);
+ *	END;
+ *     ELSE
+ *	RTS.Throw(bad);
+ *     END;
+ *   END;
+ *   nam[num] := 0X;
+ * END ReadUTF;
+ *)
+(* ======================================= *)
+
+  PROCEDURE readChar() : CHAR;
+  BEGIN
+    RETURN CHR(read() * 256 + read());
+  END readChar;
+
+(* ======================================= *)
+
+  PROCEDURE readInt() : INTEGER;
+  BEGIN [UNCHECKED_ARITHMETIC]
+    (* overflow checking off here *)
+    RETURN ((read() * 256 + read()) * 256 + read()) * 256 + read();
+  END readInt;
+
+(* ======================================= *)
+
+  PROCEDURE readLong() : LONGINT;
+    VAR result : LONGINT;
+	index  : INTEGER;
+  BEGIN [UNCHECKED_ARITHMETIC]
+    (* overflow checking off here *)
+    result := read();
+    FOR index := 1 TO 7 DO
+      result := result * 256 + read();
+    END;
+    RETURN result;
+  END readLong;
+
+(* ======================================= *)
+
+  PROCEDURE readReal() : REAL;
+    VAR result : LONGINT;
+  BEGIN
+    result := readLong();
+    RETURN RTS.longBitsToReal(result);
+  END readReal;
+
+(* ======================================= *)
+
+  PROCEDURE readOrd() : INTEGER;
+    VAR chr : INTEGER;
+  BEGIN
+    chr := read();
+    IF chr <= 07FH THEN RETURN chr;
+    ELSE
+      DEC(chr, 128);
+      RETURN chr + read() * 128;
+    END;
+  END readOrd;
+
+(* ============================================================ *)
+(* ========		Symbol File Reader		======= *)
+(* ============================================================ *)
+
+  PROCEDURE GetSym();
+  BEGIN
+    sSym := read();
+    CASE sSym OF
+    | namSy : 
+	iAtt := read(); ReadUTF(sAtt);
+    | strSy : 
+	ReadUTF(sAtt);
+    | retSy, fromS, tDefS, basSy :
+	iAtt := readOrd();
+    | bytSy :
+	iAtt := read();
+    | keySy, setSy :
+	iAtt := readInt();
+    | numSy :
+	lAtt := readLong();
+    | fltSy :
+	rAtt := readReal();
+    | chrSy :
+	cAtt := readChar();
+    ELSE (* nothing to do *)
+    END;
+  END GetSym;
+
+(* ======================================= *)
+
+  PROCEDURE ReadPast(sym : INTEGER);
+  BEGIN
+    IF sSym # sym THEN 
+      Console.WriteString("Expected ");
+      Console.Write(CHR(sym));
+      Console.WriteString(" got ");
+      Console.Write(CHR(sSym));
+      Console.WriteLn;
+      RTS.Throw("Bad symbol file format"); 
+    END;
+    GetSym();
+  END ReadPast;
+
+(* ============================================ *)
+
+  PROCEDURE GetLiteral(VAR lit : LitValue);
+  VAR
+    b : BoolValue;
+    n : NumValue;
+    c : ChrValue;
+    f : FltValue;
+    s : SetValue;
+    st : StrValue;
+  BEGIN
+    CASE sSym OF
+    | truSy : NEW(b); b.boolVal := TRUE; lit := b;
+    | falSy : NEW(b); b.boolVal := FALSE; lit := b;
+    | numSy : NEW(n); n.numVal := lAtt; lit := n;
+    | chrSy : NEW(c); c.chrVal := cAtt; lit := c;
+    | fltSy : NEW(f); f.fltVal := rAtt; lit := f;
+    | setSy : NEW(s); s.setVal := BITS(iAtt); lit := s;
+    | strSy : NEW(st); st.strVal := sAtt; lit := st;
+    END;
+    GetSym();						(* read past value  *)
+  END GetLiteral;
+
+(* ============================================ *)
+
+  PROCEDURE GetFormalType(p : Proc);
+  (*
+  // FormalType = [retSy TypeOrd] frmSy {parSy byte TypeOrd} endFm.
+  //	-- optional phrase is return type for proper procedures
+  *)
+    VAR 
+ 	par : Par;
+	byte : INTEGER;
+  BEGIN
+    p.noModes := TRUE;
+    IF sSym = retSy THEN 
+      p.retTypeNum := iAtt;
+      GetSym();
+    ELSE
+      p.retTypeNum := 0; 
+    END;
+    ReadPast(frmSy);
+    WHILE sSym = parSy DO
+      NEW(par);
+      par.mode := read();
+      IF par.mode > 0 THEN p.noModes := FALSE; END;
+      par.typeNum := readOrd();
+      GetSym();
+      IF sSym = strSy THEN
+        par.opNm := BOX(sAtt);
+        GetSym();
+      END;
+      AddPar(p.pars,par);
+    END;
+    ReadPast(endFm);
+  END GetFormalType;
+
+(* ============================================ *)
+
+  PROCEDURE pointerType() : Pointer;
+  (* Assert: the current symbol is ptrSy.	*)
+  (* Pointer   = TypeHeader ptrSy TypeOrd.	*)
+    VAR 
+      ptr : Pointer;
+  BEGIN
+    NEW(ptr);
+    ptr.baseNum := readOrd();
+    ptr.isAnonPointer := FALSE;
+    GetSym();
+    RETURN ptr;
+  END pointerType;
+
+(* ============================================ *)
+
+  PROCEDURE eventType() : Proc;
+  (* Assert: the current symbol is evtSy.	*)
+  (* Event   = TypeHeader evtSy FormalType.	*)
+    VAR p : Event;
+  BEGIN
+    NEW(p);
+    GetSym();		(* read past evtSy *)
+    GetFormalType(p);
+    RETURN p;
+  END eventType;
+
+(* ============================================ *)
+
+  PROCEDURE procedureType() : Proc;
+  (* Assert: the current symbol is pTpSy.	*)
+  (* ProcType  = TypeHeader pTpSy FormalType.	*)
+  VAR
+    p : Proc;
+  BEGIN
+    NEW(p);
+    GetSym();		(* read past pTpSy *)
+    GetFormalType(p);
+    RETURN p;
+  END procedureType;
+
+(* ============================================ *)
+
+  PROCEDURE^ GetConstant() : ConstDesc;
+
+  PROCEDURE enumType() : Enum;
+  (* Assert: the current symbol is eTpSy.	  *)
+  (* Enum  = TypeHeader eTpSy { Constant } endRc. *)
+  VAR
+    e : Enum;
+  BEGIN
+    NEW(e);
+    GetSym();
+    WHILE (sSym = conSy) DO
+      AddDesc(e.ids,GetConstant());
+    END;
+    ReadPast(endRc);
+    RETURN e;
+  END enumType;
+
+(* ============================================ *)
+
+  PROCEDURE arrayType() : Type;
+  (* Assert: at entry the current symbol is arrSy.		     *)
+  (* Array      = TypeHeader arrSy TypeOrd (Byte | Number | ) endAr. *)
+  (*	-- nullable phrase is array length for fixed length arrays   *)
+    VAR 
+        arr : Array;
+  BEGIN
+    NEW(arr); 
+    arr.elemTypeNum := readOrd();
+    GetSym();
+    IF sSym = bytSy THEN
+      arr.size := iAtt;
+      GetSym();
+    ELSIF sSym = numSy THEN
+      arr.size := SHORT(lAtt);
+      GetSym();
+    ELSE 
+      arr.size := 0 
+    END;
+    ReadPast(endAr);
+    RETURN arr;
+  END arrayType;
+
+(* ============================================ *)
+
+  PROCEDURE vectorType() : Type;
+  (* Assert: at entry the current symbol is vecSy.		     *)
+  (* Vector   = TypeHeader vecSy TypeOrd endAr.                      *)
+    VAR 
+        vec : Vector;
+  BEGIN
+    NEW(vec); 
+    vec.elemTypeNum := readOrd();
+    GetSym();
+    ReadPast(endAr);
+    RETURN vec;
+  END vectorType;
+
+(* ============================================ *)
+
+  PROCEDURE^ GetProc() : ProcDesc;
+  PROCEDURE^ GetVar() : VarDesc;
+
+  PROCEDURE recordType(recNum : INTEGER) : Record;
+  (* Assert: at entry the current symbol is recSy.			*)
+  (* Record     = TypeHeader recSy recAtt [truSy | falSy | <others>] 	*)
+  (*	[basSy TypeOrd] [iFcSy {basSy TypeOrd}]				*)
+  (*	{Name TypeOrd} {Method} {Statics} endRc.			*)
+    VAR 
+        rec  : Record;
+        f : VarDesc;
+        t : TypeDesc;
+        m : ProcDesc;
+        mth : Meth;
+  BEGIN
+    NEW(rec);
+    rec.recAtt := read();
+(*
+    IF rec.recAtt >=8 THEN rec.recAtt := rec.recAtt - 8; END;
+*)
+    rec.isAnonRec := FALSE;
+    GetSym();				(* Get past recSy rAtt	*)
+    IF (sSym = falSy) OR (sSym = truSy) THEN
+      GetSym();
+    END;
+    IF sSym = basSy THEN
+      rec.baseNum := iAtt;
+      GetSym();
+    ELSE
+      rec.baseNum := 0;
+    END;
+    IF sSym = iFcSy THEN
+      GetSym();
+      WHILE sSym = basSy DO
+(* *
+ * *	Console.WriteString("got interface $T");
+ * *	Console.WriteInt(iAtt,1);
+ * *	Console.WriteLn;
+ * *)
+        NEW(t);
+        t.typeNum := iAtt;
+	GetSym();
+	AddDesc(rec.intrFaces,t);
+      END;
+    END;
+    WHILE sSym = namSy DO
+      NEW(f);
+      f.name := sAtt;
+      f.access := iAtt;
+      f.typeNum := readOrd();
+      GetSym();
+      AddDesc(rec.fields,f);
+    END;
+   (* Method     = mthSy Name byte byte TypeOrd [String] FormalType. *)
+    WHILE sSym = mthSy DO
+      NEW(m);
+      NEW(mth);
+      mth.importedFrom := NIL;
+      mth.isConstructor := FALSE;
+      m.pType := mth;
+      GetSym();
+      IF (sSym # namSy) THEN RTS.Throw("Bad symbol file format"); END;
+      m.name := sAtt;
+      m.access := iAtt;
+      mth.declarer := m;
+     (* byte1 is the method attributes  *)
+      mth.attr := read();
+     (* byte2 is param form of receiver *)
+      mth.recMode := read();
+     (* next 1 or 2 bytes are rcv-type  *)
+      mth.recTypeNum := readOrd();
+      GetSym();
+      IF sSym = strSy THEN 
+        mth.fName := sAtt;
+        GetSym(); 
+      ELSE
+        mth.fName[0] := 0X;
+      END;
+      IF sSym = namSy THEN 
+        mth.recName := BOX(sAtt);
+        GetSym(); 
+      END;
+      GetFormalType(mth);
+      AddDesc(rec.methods,m);
+    END;
+    WHILE (sSym = conSy) OR (sSym = prcSy) OR (sSym = varSy) DO
+      IF sSym = conSy THEN
+        AddDesc(rec.statics,GetConstant());
+      ELSIF sSym = prcSy THEN
+        AddDesc(rec.statics,GetProc());
+      ELSE
+        AddDesc(rec.statics,GetVar());
+      END;
+    END;
+    ReadPast(endRc); 
+    RETURN rec;
+  END recordType;
+
+(* ============================================ *)
+
+  PROCEDURE ResolveProc(p : Proc);
+  VAR
+    i : INTEGER;
+  BEGIN
+    p.retType := typeList[p.retTypeNum];
+    IF p.retTypeNum = 0 THEN ASSERT(p.retType = NIL); END;
+    IF p IS Meth THEN
+      p(Meth).receiver := typeList[p(Meth).recTypeNum];
+    END;
+    FOR i := 0 TO p.pars.tide-1 DO
+      p.pars.list[i].type := typeList[p.pars.list[i].typeNum];
+    END; 
+  END ResolveProc;
+
+(* ============================================ *)
+
+  PROCEDURE ReadTypeList(mod : Module);
+  (* TypeList   = start { Array | Record | Pointer 	*)
+  (*		| ProcType | NamedType | Enum } close.  *)
+  (* TypeHeader = tDefS Ord [fromS Ord Name].		*)
+    VAR modOrd : INTEGER;
+	typOrd : INTEGER;
+        typ    : Type;
+        namedType : Named;
+        f : VarDesc;
+        rec : Record;
+        impName : FileNames.NameString;
+        i,j : INTEGER;
+  BEGIN
+    GetSym();
+    typOrd := 0;
+    WHILE sSym = tDefS DO
+      typOrd := iAtt;
+      ASSERT(typOrd # 0);
+      ReadPast(tDefS);
+      modOrd := -1;
+      impName := "";
+     (*
+      *  The fromS symbol appears if the type is imported.
+      *)
+      IF sSym = fromS THEN
+	modOrd := iAtt;
+	GetSym();
+        impName := sAtt;
+	ReadPast(namSy);
+      END;
+     (* Get type info. *)
+      CASE sSym OF 
+      | arrSy : typ := arrayType();
+      | vecSy : typ := vectorType();
+      | recSy : typ := recordType(typOrd);
+      | ptrSy : typ := pointerType();
+      | evtSy : typ := eventType();
+      | pTpSy : typ := procedureType();
+      | eTpSy : typ := enumType();
+      ELSE 
+	NEW(namedType);
+	typ := namedType;
+      END;
+      IF typ # NIL THEN
+        AddType(typeList,typ,typOrd);
+        IF modOrd > -1 THEN      
+          typ.importedFrom := mod.imports.list[modOrd]; 
+          typ.importedName := impName;
+        END;
+      END;
+    END;
+    ReadPast(close);
+    FOR i := Symbols.tOffset TO typOrd DO
+      typ := typeList[i];
+      IF typ IS Array THEN
+        typ(Array).elemType := typeList[typ(Array).elemTypeNum];
+      ELSIF typ IS Vector THEN
+        typ(Vector).elemType := typeList[typ(Vector).elemTypeNum];
+      ELSIF typ IS Record THEN
+        rec := typ(Record);
+        IF (rec.baseNum > 0) THEN
+          rec.baseType := typeList[rec.baseNum];
+        END;
+        FOR j := 0 TO rec.fields.tide-1 DO
+          f := rec.fields.list[j](VarDesc);
+          f.type := typeList[f.typeNum];
+        END;
+        FOR j := 0 TO rec.methods.tide-1 DO
+          ResolveProc(rec.methods.list[j](ProcDesc).pType);
+        END;
+        FOR j := 0 TO rec.statics.tide-1 DO
+          IF rec.statics.list[j] IS ProcDesc THEN
+            ResolveProc(rec.statics.list[j](ProcDesc).pType);
+          ELSIF rec.statics.list[j] IS VarDesc THEN
+            f := rec.statics.list[j](VarDesc);
+            f.type := typeList[f.typeNum];
+          END;
+        END;
+      ELSIF typ IS Pointer THEN
+        typ(Pointer).baseType := typeList[typ(Pointer).baseNum];
+      ELSIF typ IS Proc THEN
+        ResolveProc(typ(Proc));
+      END;
+    END;
+  END ReadTypeList;
+
+(* ============================================ *)
+
+  PROCEDURE ResolveAnonRecs();
+  VAR r : Record;
+      typ : Type;
+      ch0 : CHAR;
+      i,j,k : INTEGER;
+  BEGIN
+    FOR i := Symbols.tOffset TO LEN(typeList)-1 DO
+      typ := typeList[i];
+      IF ~verbatim & (typ # NIL) & (typ.declarer # NIL) THEN
+        ch0 := typ.declarer.name[0];
+        IF (ch0 = "@") OR (ch0 = "$") THEN typ.declarer := NIL END;
+      END;
+(*
+      IF (typ IS Record) & (typ.declarer = NIL) THEN (* anon record *)
+ *)
+      IF typ IS Record THEN 
+	r := typ(Record);
+	FOR j := 0 TO r.intrFaces.tide - 1 DO
+	  k := r.intrFaces.list[j](TypeDesc).typeNum;
+	  r.intrFaces.list[j](TypeDesc).type := typeList[k];
+	END;
+	IF typ.declarer = NIL THEN (* anon record *)
+(*
+          Console.WriteString("Type ");
+          Console.WriteInt(i,1);
+          Console.WriteString(" is an AnonRecord ");
+          Console.WriteLn;
+ *)
+          typ(Record).isAnonRec := TRUE;
+	END;
+      ELSIF (typ IS Pointer) & (typ(Pointer).baseType IS Record) THEN
+        IF (typ.declarer = NIL) & (typ.importedFrom = NIL) THEN 
+(*
+        Console.WriteString("Type ");
+        Console.WriteInt(i,1);
+        Console.WriteString(" is an AnonPointer ");
+        Console.WriteLn;
+ *)
+          typ(Pointer).isAnonPointer := TRUE; 
+        END;
+        r := typ(Pointer).baseType(Record);
+        IF (r.declarer = NIL) THEN  (* anon record *)
+(*
+        Console.WriteString("Type ");
+        Console.WriteInt(i,1);
+        Console.WriteString(" is an Pointer to anon record - fixing");
+        Console.WriteLn;
+ *)
+          r.isAnonRec := TRUE;
+          r.ptrType := typ(Pointer);
+        END;
+      END;
+    END;
+  END ResolveAnonRecs;
+
+(* ============================================ *)
+  
+  PROCEDURE GetType() : UserTypeDesc;
+  (* Type       = typSy Name TypeOrd. *)
+  VAR
+    typeDesc : UserTypeDesc;
+  BEGIN
+    GetSym();
+    NEW (typeDesc);
+    typeDesc.name := sAtt;
+    typeDesc.access := iAtt;
+    typeDesc.typeNum := readOrd();
+    GetSym();
+    RETURN typeDesc;
+  END GetType;
+
+(* ============================================ *)
+
+  PROCEDURE GetImport() : Module;
+  (* Import     = impSy Name [String] Key.  *)
+  VAR
+    impMod : Module;
+  BEGIN
+    GetSym();
+    IF doAll THEN
+      impMod := GetModule(sAtt); 
+    ELSE
+      NEW(impMod);
+      impMod.name := sAtt;
+      impMod.systemMod := FALSE;
+      impMod.progArg := FALSE;
+    END;
+    GetSym();
+    IF sSym = strSy THEN impMod.fName := sAtt; GetSym(); END;
+    ReadPast(keySy);
+    RETURN impMod;
+  END GetImport;
+
+(* ============================================ *)
+
+  PROCEDURE GetConstant() : ConstDesc;
+  (*  Constant   = conSy Name Literal.  *)
+  VAR
+    constDesc : ConstDesc;
+  BEGIN
+    GetSym();
+    NEW(constDesc);
+    constDesc.name := sAtt;
+    constDesc.access := iAtt;
+    GetSym();
+    GetLiteral(constDesc.val);
+    RETURN constDesc;
+  END GetConstant;
+
+(* ============================================ *)
+
+  PROCEDURE GetVar() : VarDesc;
+  (*  Variable   = varSy Name TypeOrd.  *)
+  VAR
+    varDesc : VarDesc;
+  BEGIN
+    GetSym();
+    NEW(varDesc);
+    varDesc.name := sAtt;
+    varDesc.access := iAtt;
+    varDesc.typeNum := readOrd();
+    GetSym();
+    RETURN varDesc;
+  END GetVar;
+
+(* ============================================ *)
+
+  PROCEDURE GetProc() : ProcDesc;
+  (* Procedure  = prcSy Name [String] [trySy] FormalType.  *)
+  VAR
+    procDesc : ProcDesc;
+  BEGIN
+    GetSym();
+    NEW(procDesc);
+    procDesc.name := sAtt;
+    procDesc.access := iAtt;
+    GetSym();
+    NEW(procDesc.pType);
+    IF sSym = strSy THEN 
+      IF sAtt = "<init>" THEN
+        procDesc.pType.fName := "< init >";  
+      ELSE
+        procDesc.pType.fName := sAtt;
+      END;
+      GetSym(); 
+    ELSE
+      procDesc.pType.fName[0] := 0X;
+    END;
+    IF sSym = truSy THEN
+      procDesc.pType.isConstructor := TRUE;
+      GetSym();
+    ELSE
+      procDesc.pType.isConstructor := FALSE;
+    END;
+    procDesc.pType.importedFrom := NIL;
+    procDesc.pType.declarer := procDesc;
+    GetFormalType(procDesc.pType);
+    RETURN procDesc;
+  END GetProc;
+
+(* ============================================ *)
+
+  PROCEDURE SymFile(mod : Module);
+   (*
+   // SymFile    = Header [String (falSy | truSy | <others>)]
+   //		{Import | Constant | Variable | Type | Procedure} 
+   //		TypeList Key.
+   // Header     = magic modSy Name.
+   //
+   //  magic has already been recognized.
+   *)
+  VAR 
+    i,j,k : INTEGER;
+    typeDesc : UserTypeDesc;
+    varDesc  : VarDesc;
+    procDesc : ProcDesc;
+    thisType : Type;
+  BEGIN
+    AddMod(mod.imports,mod);
+    ReadPast(modSy);
+    IF sSym = namSy THEN (* do something with f.sAtt *)
+      IF mod.name # sAtt THEN
+        Error.WriteString("Wrong name in symbol file. Expected <");
+        Error.WriteString(mod.name + ">, found <");
+        Error.WriteString(sAtt + ">"); 
+	Error.WriteLn;
+        HALT(1);
+      END;
+      GetSym();
+    ELSE RTS.Throw("Bad symfile header");
+    END;
+    IF sSym = strSy THEN (* optional name *)
+      mod.fName := sAtt;
+      GetSym();
+      IF (sSym = falSy) OR (sSym = truSy) THEN 
+	GetSym();
+      ELSE RTS.Throw("Bad explicit name");
+      END; 
+    ELSE
+      mod.fName[0] := 0X;
+    END; 
+   (*
+    *  Optional strong name info.
+    *)
+    IF sSym = numSy THEN 
+      NEW(mod.strongNm);   (* POINTER TO ARRAY 6 OF INTEGER *)
+      mod.strongNm[0] := RTS.hiInt(lAtt);
+      mod.strongNm[1] := RTS.loInt(lAtt);
+      GetSym();
+      mod.strongNm[2] := RTS.hiInt(lAtt);
+      mod.strongNm[3] := RTS.loInt(lAtt);
+      GetSym();
+      mod.strongNm[4] := RTS.hiInt(lAtt);
+      mod.strongNm[5] := RTS.loInt(lAtt);
+      GetSym();
+    END;
+    (* end optional strong name information *)
+    LOOP
+      CASE sSym OF
+      | start : EXIT;
+      | typSy : AddDesc(mod.types,GetType());
+      | impSy : AddMod(mod.imports,GetImport());
+      | conSy : AddDesc(mod.consts,GetConstant());
+      | varSy : AddDesc(mod.vars,GetVar());
+      | prcSy : AddDesc(mod.procs,GetProc());
+      ELSE RTS.Throw("Bad object");
+      END;
+    END;
+    ReadTypeList(mod);
+    IF sSym # keySy THEN
+      RTS.Throw("Missing keySy");
+    END; 
+    FOR i := 0 TO mod.types.tide-1 DO
+      typeDesc := mod.types.list[i](UserTypeDesc);
+      thisType := typeList[typeDesc.typeNum];
+      typeDesc.type := thisType;
+      typeDesc.type.declarer := typeDesc;
+    END;
+    FOR i := 0 TO mod.vars.tide-1 DO
+      varDesc := mod.vars.list[i](VarDesc);
+      varDesc.type := typeList[varDesc.typeNum];
+    END;
+    FOR i := 0 TO mod.procs.tide-1 DO
+      procDesc := mod.procs.list[i](ProcDesc);
+      ResolveProc(mod.procs.list[i](ProcDesc).pType);
+    END;
+    ResolveAnonRecs();
+  END SymFile;
+
+(* ============================================================ *)
+
+  PROCEDURE GetSymAndModNames*(VAR symName : FileNames.NameString;
+                               OUT modName : FileNames.NameString);
+  VAR i,j : INTEGER;
+      ok : BOOLEAN; 
+  BEGIN
+    modName := symName;
+    i := 0;
+    WHILE ((i < LEN(symName)) & (symName[i] # '.') & 
+           (symName[i] # 0X)) DO INC(i); END;
+    IF (i >= LEN(symName)) OR (symName[i] # '.') THEN 
+      symName := symName + symExt;
+    ELSE
+      modName[i] := 0X;
+    END;
+  END GetSymAndModNames;
+
+  PROCEDURE Parse*();
+  VAR 
+    marker,modIx,i   : INTEGER;
+    mod : Module;
+  BEGIN
+    modIx := 0;
+    WHILE (modIx < modList.tide) DO
+      mod := modList.list[modIx];
+      INC(modIx);
+      mod.print := FALSE;
+      file := GPBinFiles.findLocal(mod.symName);
+      IF file = NIL THEN
+        file := GPBinFiles.findOnPath("CPSYM", mod.symName);
+        IF (file = NIL) OR (mod.progArg) THEN
+          Error.WriteString("File <" + mod.symName + "> not found"); 
+          Error.WriteLn;
+	  HALT(1);
+        END;
+        mod.pathName := GPBinFiles.getFullPathName(file);
+        i := 0;
+        WHILE (i < LEN(mod.pathName)) & (mod.pathName[i] # ".") DO INC(i); END;
+        mod.pathName[i] := 0X;
+      ELSE 
+        marker := readInt();
+        IF marker = RTS.loInt(magic) THEN
+        (* normal case, nothing to do *)
+        ELSIF marker = RTS.loInt(syMag) THEN
+          mod.systemMod := TRUE;
+        ELSE
+          Error.WriteString("File <"+fileName+"> is not a valid symbol file"); 
+          Error.WriteLn;
+          RETURN;
+        END;
+        mod.print := TRUE;
+        GetSym();
+        SymFile(mod);
+        GPBinFiles.CloseFile(file);
+      END;
+    END;
+  RESCUE (x)
+    Error.WriteString("Error in Parse()"); Error.WriteLn;
+    Error.WriteString(RTS.getStr(x)); Error.WriteLn;
+  END Parse;
+
+(* ===================================================================== *)
+
+PROCEDURE (o : Output) WriteStart(mod : Module),NEW,EMPTY;
+
+PROCEDURE (o : Output) WriteEnd(),NEW,EMPTY;
+
+PROCEDURE (o : Output) Write(ch : CHAR),NEW,EXTENSIBLE;
+BEGIN
+  Console.Write(ch);
+END Write;
+
+PROCEDURE (o : Output) WriteIdent(str : ARRAY OF CHAR),NEW,EXTENSIBLE;
+BEGIN
+  Console.WriteString(str);
+END WriteIdent;
+
+PROCEDURE (o : Output) WriteImport(impMod : Module),NEW,EXTENSIBLE;
+BEGIN
+  Console.WriteString(impMod.name);
+END WriteImport;
+
+PROCEDURE (o : Output) WriteString(str : ARRAY OF CHAR),NEW,EXTENSIBLE;
+BEGIN
+  Console.WriteString(str);
+END WriteString;
+
+PROCEDURE (o : Output) WriteLn(),NEW,EXTENSIBLE;
+BEGIN
+  Console.WriteLn;
+END WriteLn;
+
+PROCEDURE (o : Output) WriteInt(i : INTEGER),NEW,EXTENSIBLE;
+BEGIN
+  Console.WriteInt(i,1);
+END WriteInt;
+
+PROCEDURE (o : Output) WriteLong(l : LONGINT),NEW,EXTENSIBLE;
+VAR
+  str : ARRAY 30 OF CHAR;
+BEGIN
+  IF (l > MAX(INTEGER)) OR (l < MIN(INTEGER)) THEN
+    RTS.LongToStr(l,str);
+    Console.WriteString(str);
+  ELSE
+    Console.WriteInt(SHORT(l),1);
+  END;
+END WriteLong;
+
+PROCEDURE (o : Output) WriteKeyword(str : ARRAY OF CHAR),NEW,EXTENSIBLE;
+BEGIN
+  Console.WriteString(str);
+END WriteKeyword;
+
+PROCEDURE (o : Output) Indent(i : INTEGER),NEW,EXTENSIBLE;
+BEGIN
+  WHILE i > 0 DO
+    Console.Write(' ');
+    DEC(i);
+  END;
+END Indent;
+
+PROCEDURE (o : Output) WriteImportedTypeName(impMod : Module;
+                                        tName : ARRAY OF CHAR),NEW,EXTENSIBLE;
+BEGIN
+  Console.WriteString(impMod.name + "." + tName);
+END WriteImportedTypeName;
+
+PROCEDURE (o : Output) WriteTypeName(tName : ARRAY OF CHAR),NEW,EXTENSIBLE;
+BEGIN
+  Console.WriteString(tName);
+END WriteTypeName;
+
+PROCEDURE (o : Output) WriteTypeDecl(tName : ARRAY OF CHAR),NEW,EXTENSIBLE;
+BEGIN
+  Console.WriteString(tName);
+END WriteTypeDecl;
+
+(* FIXME *)
+PROCEDURE (o : Output) MethRef(IN nam : ARRAY OF CHAR),NEW,EMPTY;
+PROCEDURE (o : Output) MethAnchor(IN nam : ARRAY OF CHAR),NEW,EMPTY;
+(* FIXME *)
+
+(* ------------------------------------------------------------------- *)
+
+PROCEDURE (f : FileOutput) Write(ch : CHAR),EXTENSIBLE;
+BEGIN
+  GPText.Write(f.file,ch);
+END Write;
+
+PROCEDURE (f : FileOutput) WriteIdent(str : ARRAY OF CHAR),EXTENSIBLE;
+BEGIN
+  GPText.WriteString(f.file,str);
+END WriteIdent;
+
+PROCEDURE (f : FileOutput) WriteImport(impMod : Module),EXTENSIBLE;
+BEGIN
+  GPText.WriteString(f.file,impMod.name);
+END WriteImport;
+
+PROCEDURE (f : FileOutput) WriteString(str : ARRAY OF CHAR),EXTENSIBLE;
+BEGIN
+  GPText.WriteString(f.file,str);
+END WriteString;
+
+PROCEDURE (f : FileOutput) WriteLn(),EXTENSIBLE;
+BEGIN
+  GPText.WriteLn(f.file);
+END WriteLn;
+
+PROCEDURE (f : FileOutput) WriteInt(i : INTEGER),EXTENSIBLE;
+BEGIN
+  GPText.WriteInt(f.file,i,1);
+END WriteInt;
+
+PROCEDURE (f : FileOutput) WriteLong(l : LONGINT),EXTENSIBLE;
+BEGIN
+  GPText.WriteLong(f.file,l,1);
+END WriteLong;
+
+PROCEDURE (f : FileOutput) WriteKeyword(str : ARRAY OF CHAR),EXTENSIBLE;
+BEGIN
+  GPText.WriteString(f.file,str);
+END WriteKeyword;
+
+PROCEDURE (f : FileOutput) Indent(i : INTEGER),EXTENSIBLE;
+BEGIN
+  WHILE i > 0 DO
+    GPText.Write(f.file,' ');
+    DEC(i);
+  END;
+END Indent;
+
+PROCEDURE (f : FileOutput) WriteImportedTypeName(impMod : Module;
+                                              tName : ARRAY OF CHAR),EXTENSIBLE;
+BEGIN
+  GPText.WriteString(f.file,impMod.name + "." + tName);
+END WriteImportedTypeName;
+
+PROCEDURE (f : FileOutput) WriteTypeName(tName : ARRAY OF CHAR),EXTENSIBLE;
+BEGIN
+  GPText.WriteString(f.file,tName);
+END WriteTypeName;
+
+PROCEDURE (f : FileOutput) WriteTypeDecl(tName : ARRAY OF CHAR),EXTENSIBLE;
+BEGIN
+  GPText.WriteString(f.file,tName);
+END WriteTypeDecl;
+
+(* ------------------------------------------------------------------- *)
+
+PROCEDURE (h : HtmlOutput) WriteStart(mod : Module);
+BEGIN
+  GPText.WriteString(h.file,"<html><head><title>");
+  GPText.WriteString(h.file,mod.name);
+  GPText.WriteString(h.file,"</title></head>");
+  GPText.WriteLn(h.file);
+  GPText.WriteString(h.file,'<body bgcolor="white">');
+  GPText.WriteLn(h.file);
+  GPText.WriteString(h.file,"<hr><pre>");
+  GPText.WriteLn(h.file);
+END WriteStart;
+
+PROCEDURE (h : HtmlOutput) WriteEnd();
+BEGIN
+  GPText.WriteString(h.file,"</font></pre></hr></body></html>");
+  GPText.WriteLn(h.file);
+END WriteEnd;
+
+PROCEDURE (h : HtmlOutput) Write(ch : CHAR);
+BEGIN
+  GPText.Write(h.file,ch);
+END Write;
+
+PROCEDURE (h : HtmlOutput) WriteImport(impMod : Module);
+BEGIN
+  GPText.WriteString(h.file,'<a href="');
+  IF impMod.pathName = NIL THEN
+    GPText.WriteString(h.file,impMod.name);
+  ELSE
+    GPText.WriteString(h.file,impMod.pathName);
+  END;
+  GPText.WriteString(h.file,'.html">');
+  GPText.WriteString(h.file,impMod.name);
+  GPText.WriteString(h.file,'</a>');
+END WriteImport;
+
+PROCEDURE (h : HtmlOutput) WriteIdent(str : ARRAY OF CHAR);
+BEGIN
+  GPText.WriteString(h.file,'<font color="#cc0033">');
+  GPText.WriteString(h.file,str);
+  GPText.WriteString(h.file,"</font>");
+END WriteIdent;
+
+PROCEDURE (h : HtmlOutput) WriteString(str : ARRAY OF CHAR);
+BEGIN
+  GPText.WriteString(h.file,str);
+END WriteString;
+
+PROCEDURE (h : HtmlOutput) WriteLn();
+BEGIN
+  GPText.WriteLn(h.file);
+END WriteLn;
+
+PROCEDURE (h : HtmlOutput) WriteInt(i : INTEGER );
+BEGIN
+  GPText.WriteInt(h.file,i,1);
+END WriteInt;
+
+PROCEDURE (h : HtmlOutput) WriteLong(l : LONGINT);
+BEGIN
+  GPText.WriteLong(h.file,l,1);
+END WriteLong;
+
+PROCEDURE (h : HtmlOutput) WriteKeyword(str : ARRAY OF CHAR);
+BEGIN
+  GPText.WriteString(h.file,"<b>" + str + "</b>");
+END WriteKeyword;
+
+PROCEDURE (h : HtmlOutput) Indent(i : INTEGER);
+BEGIN
+  WHILE i > 0 DO
+    GPText.Write(h.file,' ');
+    DEC(i);
+  END;
+END Indent;
+
+PROCEDURE (h : HtmlOutput) WriteImportedTypeName(impMod : Module;
+                                                 tName : ARRAY OF CHAR);
+BEGIN
+  GPText.WriteString(h.file,'<a href="');
+  IF impMod.pathName = NIL THEN
+    GPText.WriteString(h.file,impMod.name);
+  ELSE
+    GPText.WriteString(h.file,impMod.pathName);
+  END;
+  GPText.WriteString(h.file,'.html#type-');;
+  GPText.WriteString(h.file,tName);
+  GPText.WriteString(h.file,'">');
+  GPText.WriteString(h.file,impMod.name + "." + tName);
+  GPText.WriteString(h.file,'</a>');
+END WriteImportedTypeName;
+
+PROCEDURE (h : HtmlOutput) WriteTypeName(tName : ARRAY OF CHAR);
+BEGIN
+  GPText.WriteString(h.file,'<a href="#type-');;
+  GPText.WriteString(h.file,tName);
+  GPText.WriteString(h.file,'">');
+  GPText.WriteString(h.file,tName);
+  GPText.WriteString(h.file,'</a>');
+END WriteTypeName;
+
+PROCEDURE (h : HtmlOutput) WriteTypeDecl(tName : ARRAY OF CHAR);
+BEGIN
+  GPText.WriteString(h.file,'<a name="type-');
+  GPText.WriteString(h.file,tName);
+  GPText.WriteString(h.file,'"></a>');
+  GPText.WriteString(h.file,'<font color="#cc0033">');
+  GPText.WriteString(h.file,tName);
+  GPText.WriteString(h.file,"</font>");
+END WriteTypeDecl;
+
+(* FIXME *)
+PROCEDURE (h : HtmlOutput) MethRef(IN nam : ARRAY OF CHAR);
+BEGIN
+  GPText.WriteString(h.file, '    <a href="#meths-');;
+  GPText.WriteString(h.file, nam);
+  GPText.WriteString(h.file, '">');
+  GPText.WriteString(h.file, '<font color="#cc0033">');
+  GPText.WriteString(h.file, "(* Typebound Procedures *)");
+  GPText.WriteString(h.file, "</font>");
+  GPText.WriteString(h.file, '</a>');
+END MethRef;
+
+PROCEDURE (h : HtmlOutput) MethAnchor(IN nam : ARRAY OF CHAR);
+BEGIN
+  GPText.WriteString(h.file, '<a name="meths-');
+  GPText.WriteString(h.file, nam);
+  GPText.WriteString(h.file, '"></a>');
+END MethAnchor;
+(* FIXME *)
+
+(* ==================================================================== *)
+(*				Format Helpers				*)
+(* ==================================================================== *)
+
+  PROCEDURE qStrOf(str : FileNames.NameString) : CharOpen;
+    VAR len : INTEGER;
+	res : CharOpen;
+	idx : INTEGER;
+	dQt : BOOLEAN;
+  BEGIN
+    dQt := FALSE;
+    len := LEN(str$);
+    FOR idx := 0 TO len-1 DO
+      IF str[idx] = '"' THEN dQt := TRUE END;
+    END;
+    NEW(res, len+3);
+    IF dQt THEN res[0] := "'" ELSE res[0] := '"' END;
+    FOR idx := 1 TO len DO res[idx] := str[idx-1] END;
+    IF dQt THEN res[len+1] := "'" ELSE res[len+1] := '"' END;
+    res[len+2] := 0X;
+    RETURN res;
+  END qStrOf;
+
+  PROCEDURE hexOf(ch : CHAR) : CharOpen;
+    VAR res : CharOpen;
+	idx : INTEGER;
+	ord : INTEGER;
+    (* -------------------------------------- *)
+    PROCEDURE hexDigit(d : INTEGER) : CHAR;
+    BEGIN
+      IF d < 10 THEN RETURN CHR(d + ORD('0')) 
+      ELSE RETURN CHR(d-10 + ORD('A'));
+      END;
+    END hexDigit;
+    (* -------------------------------------- *)
+  BEGIN
+    ord := ORD(ch);
+    IF ord <= 7FH THEN
+      NEW(res, 4); res[3] := 0X; res[2] := "X";
+      res[1] := hexDigit(ord MOD 16);
+      res[0] := hexDigit(ord DIV 16);
+    ELSIF ord <= 0FFH THEN
+      NEW(res, 5); res[4] := 0X; res[3] := "X";
+      res[2] := hexDigit(ord MOD 16);
+      res[1] := hexDigit(ord DIV 16);
+      res[0] := "0";
+    ELSIF ord <= 07FFFH THEN
+      NEW(res, 10); res[9] := 0X; res[8] := "X";
+      FOR idx := 7 TO 0 BY -1 DO
+        res[idx] := hexDigit(ord MOD 16); ord := ord DIV 16;
+      END;
+    ELSE
+      NEW(res, 11); res[10] := 0X; res[9] := "X";
+      FOR idx := 8 TO 0 BY -1 DO
+        res[idx] := hexDigit(ord MOD 16); ord := ord DIV 16;
+      END;
+    END;
+    RETURN res;
+  END hexOf;
+
+(* ==================================================================== *)
+
+  PROCEDURE LongToHex(n : LONGINT) : CharOpen;
+    VAR arr : ARRAY 40 OF CHAR;
+        idx : INTEGER;
+   (* -------------------------------------- *)
+    PROCEDURE hexDigit(d : INTEGER) : CHAR;
+    BEGIN
+      IF d < 10 THEN RETURN CHR(d + ORD('0')) 
+      ELSE RETURN CHR(d-10 + ORD('a'));
+      END;
+    END hexDigit;
+   (* -------------------------------------- *)
+    PROCEDURE DoDigit(n : LONGINT;
+                  VAR a : ARRAY OF CHAR; 
+                  VAR i : INTEGER);
+    BEGIN
+      ASSERT(n >= 0);
+      IF n > 15 THEN 
+        DoDigit(n DIV 16, a, i);
+        a[i] := hexDigit(SHORT(n MOD 16)); INC(i);
+      ELSIF n > 9 THEN
+        a[0] := '0';
+        a[1] := hexDigit(SHORT(n)); i := 2;
+      ELSE
+        a[0] := hexDigit(SHORT(n)); i := 1;
+      END;
+    END DoDigit;
+   (* -------------------------------------- *)
+  BEGIN
+    idx := 0;
+    DoDigit(n, arr, idx);
+    arr[idx] := 'H'; INC(idx); arr[idx] := 0X;
+    RETURN BOX(arr);
+  END LongToHex;
+
+(* ==================================================================== *)
+
+  PROCEDURE Length(a : ARRAY OF CHAR) : INTEGER;
+  VAR i : INTEGER;
+  BEGIN
+    i := 0;
+    WHILE (a[i] # 0X) & (i < LEN(a)) DO INC(i); END;
+    RETURN i; 
+  END Length;
+
+  PROCEDURE (v : LitValue) Print(),NEW,EMPTY;
+
+  PROCEDURE (n : NumValue) Print();
+  BEGIN
+    IF hexCon & (n.numVal >= 0) THEN
+      output.WriteString(LongToHex(n.numVal));
+    ELSE
+      output.WriteLong(n.numVal);
+    END;
+  END Print;
+
+  PROCEDURE (f : FltValue) Print();
+  VAR
+    str : ARRAY 30 OF CHAR;
+  BEGIN
+    RTS.RealToStr(f.fltVal,str);
+    output.WriteString(str);
+  END Print;
+
+  PROCEDURE (s : SetValue) Print();
+  VAR
+    i,j,k : INTEGER;
+    first : BOOLEAN;
+    inSet : BOOLEAN;
+   (* ----------------------------------- *)
+    PROCEDURE WriteRange(j,k:INTEGER; VAR f : BOOLEAN);
+    BEGIN
+      IF f THEN f := FALSE ELSE output.Write(',') END;
+      output.WriteInt(j);
+      CASE k-j OF
+      | 0 : (* skip *)
+      | 1 : output.Write(','); 
+	    output.WriteInt(k);
+      ELSE  output.WriteString('..');
+            output.WriteInt(k);
+      END;
+    END WriteRange;
+   (* ----------------------------------- *)
+  BEGIN  (* this is an FSA with two states *)
+    output.Write("{");
+    first := TRUE;  inSet := FALSE; j := 0; k := 0;
+    FOR i := 0 TO MAX(SET) DO
+      IF inSet THEN
+	IF i IN s.setVal THEN k := i;
+	ELSE inSet := FALSE; WriteRange(j,k,first);
+	END;
+      ELSE
+	IF i IN s.setVal THEN inSet := TRUE; j := i; k := i END;
+      END;
+    END;
+    IF k = MAX(SET) THEN WriteRange(j,k,first) END;
+    output.Write("}");
+  END Print;
+
+  PROCEDURE (c : ChrValue) Print();
+  BEGIN
+    IF (c.chrVal <= " ") OR (c.chrVal > 7EX) THEN
+      output.WriteString(hexOf(c.chrVal));
+    ELSE
+      output.Write("'");
+      output.Write(c.chrVal);
+      output.Write("'");
+    END;
+  END Print;
+
+  PROCEDURE (s : StrValue) Print();
+  BEGIN
+    output.WriteString(qStrOf(s.strVal));
+  END Print;
+
+  PROCEDURE (b : BoolValue) Print();
+  BEGIN
+    IF b.boolVal THEN
+      output.WriteString("TRUE");
+    ELSE
+      output.WriteString("FALSE");
+    END;
+  END Print;
+
+  PROCEDURE (t : Type) PrintType(indent : INTEGER),NEW,EMPTY;
+
+  PROCEDURE (t : Type) Print(indent : INTEGER;details : BOOLEAN),NEW,EXTENSIBLE;
+  BEGIN
+    IF t.importedFrom # NIL THEN
+      IF t.importedFrom = output.thisMod THEN
+        output.WriteKeyword(t.importedName);
+      ELSE
+        output.WriteImportedTypeName(t.importedFrom, t.importedName);
+      END;
+      RETURN;
+    END;
+
+    IF ~details & (t.declarer # NIL) THEN
+      output.WriteTypeName(t.declarer.name); 
+    ELSE
+      t.PrintType(indent);
+    END;
+  END Print;
+
+  PROCEDURE (b : Basic) Print(indent : INTEGER; details : BOOLEAN);
+  BEGIN
+    output.WriteString(b.name);
+  END Print;
+
+  PROCEDURE^ PrintList(indent : INTEGER; dl : DescList; xLine : BOOLEAN);
+
+  PROCEDURE (e : Enum) PrintType(indent : INTEGER),EXTENSIBLE;
+  VAR
+    i : INTEGER;
+  BEGIN
+    output.WriteKeyword("ENUM");  output.WriteLn;
+    PrintList(indent+2,e.ids,FALSE);
+    output.Indent(indent);
+    output.WriteKeyword("END");
+  END PrintType;
+
+  PROCEDURE printBaseType(r : Record) : BOOLEAN;
+  VAR
+    pType : Pointer;
+  BEGIN
+    IF r.intrFaces.tide # 0 THEN RETURN TRUE END;
+    IF (r.baseType # NIL) & ~(r.baseType IS Basic) THEN
+      IF (r.baseType IS Pointer) THEN
+        RETURN ~r.baseType(Pointer).isAnonPointer;
+      END; 
+      IF (r.baseType IS Record) & (r.baseType(Record).isAnonRec) THEN
+        pType := r.baseType(Record).ptrType;
+        IF (pType = NIL) OR (pType.isAnonPointer) THEN
+          RETURN FALSE;
+        END;
+      END;
+      RETURN TRUE;
+    ELSE RETURN FALSE;
+    END;
+  END printBaseType;
+
+  PROCEDURE (r : Record) PrintType(indent : INTEGER),EXTENSIBLE;
+  CONST
+    eStr = "EXTENSIBLE ";
+    aStr = "ABSTRACT ";
+    lStr = "LIMITED ";
+    iStr = "INTERFACE ";
+    vStr = "(* vlCls *) ";
+    nStr = "(* noNew *) ";
+  VAR
+    rStr : ARRAY 12 OF CHAR; 
+    iTyp : Type;
+    i    : INTEGER;
+    fLen : INTEGER;
+    fNum : INTEGER;
+    sLen : INTEGER;
+
+    PROCEDURE maxFldLen(r : Record) : INTEGER;
+      VAR j,l,m : INTEGER;
+    BEGIN
+      m := 0;
+      FOR j := 0 TO r.fields.tide-1 DO
+        l := LEN(r.fields.list[j].name$);
+        m := MAX(l,m);
+      END;
+      RETURN m;
+    END maxFldLen;
+
+    PROCEDURE fieldNumber(VAR lst : DescList) : INTEGER;
+      VAR count : INTEGER;
+    BEGIN
+      count := 0;
+      FOR count := 0 TO lst.tide - 1 DO
+        IF lst.list[count] IS ProcDesc THEN RETURN count END;
+      END;
+      RETURN lst.tide;
+    END fieldNumber;
+
+  BEGIN
+    CASE r.recAtt MOD 8 OF
+    | 1 : rStr := aStr;
+    | 2 : rStr := lStr;
+    | 3 : rStr := eStr;
+    | 4 : rStr := iStr;
+    ELSE  rStr := "";
+    END;
+    IF printFNames THEN
+      IF r.recAtt DIV 8 = 1 THEN output.WriteString(nStr);
+      ELSIF r.recAtt DIV 16 = 1 THEN output.WriteString(vStr);
+      END;
+    END;
+    output.WriteKeyword(rStr + "RECORD"); 
+    IF printBaseType(r) THEN
+      output.WriteString(" (");
+      IF (r.baseType IS Record) & (r.baseType(Record).ptrType # NIL) THEN
+        r.baseType(Record).ptrType.Print(0,FALSE);
+      ELSIF r.baseType = NIL THEN
+        output.WriteString("ANYPTR");
+      ELSE
+        r.baseType.Print(0,FALSE); 
+      END;
+     (* ##### *)
+      FOR i := 0 TO r.intrFaces.tide-1 DO
+        output.WriteString(" + ");
+	iTyp := r.intrFaces.list[i](TypeDesc).type;
+        IF (iTyp IS Record) & (iTyp(Record).ptrType # NIL) THEN
+          iTyp(Record).ptrType.Print(0,FALSE);
+        ELSE
+          iTyp.Print(0,FALSE); 
+        END;
+      END;
+     (* ##### *)
+      output.WriteString(")"); 
+    END;
+
+(* FIXME *)
+    IF r.methods.tide > 0 THEN
+      IF r.declarer # NIL THEN 
+        output.MethRef(r.declarer.name);
+      ELSIF (r.ptrType # NIL) & (r.ptrType.declarer # NIL) THEN
+        output.MethRef(r.ptrType.declarer.name);
+      END;
+    END;
+(* FIXME *)
+
+    output.WriteLn;
+    fLen := maxFldLen(r);
+    FOR i := 0 TO r.fields.tide-1 DO
+      output.Indent(indent+2);
+      output.WriteIdent(r.fields.list[i].name);
+      output.Write(accArray[r.fields.list[i].access]);
+      output.Indent(fLen - LEN(r.fields.list[i].name$));
+      output.WriteString(" : ");
+      r.fields.list[i](VarDesc).type.Print(indent + fLen + 6, FALSE);
+      output.Write(';'); output.WriteLn;
+    END;
+    IF r.statics.tide > 0 THEN
+      IF alpha THEN
+        sLen := r.statics.tide - 1;
+        fNum := fieldNumber(r.statics);
+        IF fNum > 1    THEN QuickSortDescs(0, fNum-1, r.statics) END;
+        IF fNum < sLen THEN QuickSortDescs(fNum, sLen, r.statics) END;
+      END;
+      output.Indent(indent);
+      output.WriteKeyword("STATIC"); output.WriteLn;
+      PrintList(indent+2, r.statics, FALSE);
+    END;
+    output.Indent(indent);
+    output.WriteKeyword("END"); 
+  END PrintType;
+
+  PROCEDURE (a : Array) PrintType(indent : INTEGER),EXTENSIBLE;
+  BEGIN
+    output.WriteKeyword("ARRAY ");
+    IF a.size > 0 THEN output.WriteInt(a.size);  output.Write(' '); END;
+    output.WriteKeyword("OF ");
+    a.elemType.Print(indent,FALSE);
+  END PrintType;
+
+  PROCEDURE (a : Vector) PrintType(indent : INTEGER),EXTENSIBLE;
+  BEGIN
+    output.WriteKeyword("VECTOR ");
+    output.WriteKeyword("OF ");
+    a.elemType.Print(indent,FALSE);
+  END PrintType;
+
+  PROCEDURE PrintPar(p : Par; num, indent, pLen : INTEGER; noModes : BOOLEAN);
+    VAR extra : INTEGER;
+  BEGIN
+    extra := pLen+3;
+    output.Indent(indent);
+    IF ~noModes THEN 
+      INC(extra, 4);
+      CASE p.mode OF
+      | 1 : output.WriteString("IN  ");
+      | 2 : output.WriteString("OUT ");
+      | 3 : output.WriteString("VAR ");
+      ELSE  output.WriteString("    ");
+      END;
+    END;
+    IF p.opNm = NIL THEN
+      output.WriteString("p");
+      output.WriteInt(num);
+      IF num > 9 THEN output.Indent(pLen-3) ELSE output.Indent(pLen-2) END;
+    ELSE
+      output.WriteString(p.opNm);
+      output.Indent(pLen - LEN(p.opNm$));
+    END;
+    output.WriteString(" : ");
+    p.type.Print(indent+extra,FALSE); 
+  END PrintPar;
+
+  PROCEDURE PrintFormals(p : Proc; indent : INTEGER);
+  VAR
+    i    : INTEGER;
+    pLen : INTEGER;
+
+    PROCEDURE maxParLen(p : Proc) : INTEGER;
+      VAR j,l,m : INTEGER;
+    BEGIN
+      m := 0;
+      FOR j := 0 TO p.pars.tide-1 DO
+        IF p.pars.list[j].opNm # NIL THEN
+          l := LEN(p.pars.list[j].opNm$);
+        ELSIF j > 9 THEN 
+          l := 3;
+        ELSE  
+          l := 2;
+        END;
+        m := MAX(m,l);
+      END;
+      RETURN m;
+    END maxParLen;
+
+  BEGIN
+    output.Write('('); 
+    IF p.pars.tide > 0 THEN
+      pLen := maxParLen(p);
+      PrintPar(p.pars.list[0],0,0, pLen, p.noModes);
+      FOR i := 1 TO p.pars.tide-1 DO
+        output.Write(';');
+        output.WriteLn; 
+        PrintPar(p.pars.list[i], i, indent+1, pLen, p.noModes);
+      END;
+    END;
+    output.Write(')'); 
+    IF p.retType # NIL THEN
+      output.WriteString(' : ');
+      p.retType.Print(indent,FALSE);
+    END;
+  END PrintFormals;
+
+ (* -----------------------------------------------------------	*)
+
+  PROCEDURE (p : Proc) PrintType(indent : INTEGER),EXTENSIBLE;
+  BEGIN
+    output.WriteKeyword("PROCEDURE");
+    PrintFormals(p, indent+9);
+  END PrintType;
+
+ (* -----------------------------------------------------------	*)
+
+  PROCEDURE (p : Proc) PrintProc(indent : INTEGER),NEW;
+  BEGIN
+    output.Indent(indent);
+    output.WriteKeyword("PROCEDURE ");
+    output.WriteIdent(p.declarer.name);
+    output.Write(accArray[p.declarer.access]);
+    IF printFNames & (p.fName[0] # 0X) THEN
+      output.WriteString('["' + p.fName + '"]');
+      INC(indent,Length(p.fName)+4);
+    END; 
+    PrintFormals(p,indent+11+Length(p.declarer.name));
+    IF p.isConstructor THEN output.WriteKeyword(",CONSTRUCTOR"); END;
+    output.WriteString(";"); output.WriteLn;
+  END PrintProc;
+
+ (* -----------------------------------------------------------	*)
+
+  PROCEDURE (m : Meth) PrintType(indent : INTEGER),EXTENSIBLE;
+  BEGIN
+    output.WriteLn;
+    output.WriteKeyword("PROCEDURE ");
+    output.Write("(");
+    IF m.recMode = 1 THEN 
+      output.WriteString("IN "); 
+      INC(indent,3);
+    ELSIF m.recMode = 3 THEN 
+      output.WriteString("VAR "); 
+      INC(indent,4);
+    END;
+    IF m.recName = NIL THEN
+      output.WriteString("self"); 
+      INC(indent,4);
+    ELSE
+      output.WriteString(m.recName); 
+      INC(indent,LEN(m.recName$));
+    END;
+    output.WriteString(":"); 
+    ASSERT(m.receiver.importedFrom = NIL);
+    output.WriteString(m.receiver.declarer.name);
+    output.WriteString(") ");
+    output.WriteIdent(m.declarer.name);
+    output.Write(accArray[m.declarer.access]);
+    IF printFNames & (m.fName[0] # 0X) THEN
+      output.WriteString('["' + m.fName + '"]');
+      INC(indent,Length(m.fName)+4);
+    END; 
+    PrintFormals(m, indent + 15 + 
+                    Length(m.declarer.name)+
+                    Length(m.receiver.declarer.name));
+  
+    CASE m.attr OF
+    | 1 : output.WriteKeyword(",NEW");
+    | 2 : output.WriteKeyword(",ABSTRACT");
+    | 3 : output.WriteKeyword(",NEW,ABSTRACT");
+    | 4 : output.WriteKeyword(",EMPTY");
+    | 5 : output.WriteKeyword(",NEW,EMPTY");
+    | 6 : output.WriteKeyword(",EXTENSIBLE");
+    | 7 : output.WriteKeyword(",NEW,EXTENSIBLE");
+    ELSE  (* nothing *)
+    END;
+    output.WriteString(";"); output.WriteLn;
+  END PrintType;
+
+  PROCEDURE (p : Pointer) PrintType(indent : INTEGER),EXTENSIBLE;
+  BEGIN
+    output.WriteKeyword("POINTER TO ");
+    p.baseType.Print(indent,FALSE);
+  END PrintType;
+
+  PROCEDURE (p : Event) PrintType(indent : INTEGER);
+  BEGIN
+    output.WriteKeyword("EVENT");
+    PrintFormals(p, indent+5);
+  END PrintType;
+
+  PROCEDURE PrintList(indent : INTEGER; dl : DescList; xLine : BOOLEAN);
+  VAR
+    i : INTEGER;
+    d : Desc;
+    m : INTEGER;
+   (* ----------------------------------------------- *)
+    PROCEDURE notHidden(d : Desc) : BOOLEAN;
+    BEGIN
+      RETURN verbatim OR ((d.name[0] # "@") & (d.name[0] # "$"));
+    END notHidden;
+   (* ----------------------------------------------- *)
+    PROCEDURE maxNamLen(dl : DescList) : INTEGER;
+      VAR j,l,m : INTEGER; 
+          d     : Desc;
+    BEGIN
+      m := 0;
+      FOR j := 0 TO dl.tide-1 DO
+        d := dl.list[j];
+        IF notHidden(d) THEN m := MAX(m, LEN(d.name$)) END;
+      END;
+      RETURN m;
+    END maxNamLen;
+   (* ----------------------------------------------- *)
+  BEGIN
+    m := maxNamLen(dl);
+    FOR i := 0 TO dl.tide -1 DO 
+      d := dl.list[i];
+      IF ~notHidden(d) THEN 
+        (* skip *)
+      ELSIF d IS ProcDesc THEN 
+        d(ProcDesc).pType.PrintProc(indent);
+        IF xLine THEN output.WriteLn; END;
+      ELSE
+        output.Indent(indent);
+        IF d IS TypeDesc THEN 
+          output.WriteTypeDecl(d.name); 
+        ELSE
+          output.WriteIdent(d.name);
+        END;
+        output.Write(accArray[d.access]);
+
+        IF (d IS VarDesc) OR (d IS ConstDesc) THEN 
+          output.Indent(m - LEN(d.name$));
+        END;
+
+        WITH d : ConstDesc DO
+            output.WriteString(" = ");
+            d.val.Print();
+        | d : TypeDesc DO
+          IF d IS VarDesc THEN
+            output.WriteString(" : ");
+          ELSE
+            output.WriteString(" = ");
+          END;
+          d.type.Print(Length(d.name)+6, d IS UserTypeDesc);
+        END;
+        output.Write(";");
+        output.WriteLn;
+        IF xLine THEN output.WriteLn; END;
+      END;
+    END;
+  END PrintList;
+
+(* ==================================================================== *)
+
+  PROCEDURE PrintDigest(i0,i1 : INTEGER);
+    VAR buffer : ARRAY 17 OF CHAR;
+        index  : INTEGER;
+   (* ------------------------------------ *)
+    PROCEDURE hexRep(i : INTEGER) : CHAR;
+    BEGIN
+      i := ORD(BITS(i) * {0..3});
+      IF i <= 9 THEN RETURN CHR(ORD("0") + i);
+      ELSE RETURN CHR(ORD("A") - 10 + i);
+      END;
+    END hexRep;
+   (* ------------------------------------ *)
+  BEGIN
+    IF (i0 = 0) & (i1 = 0) THEN RETURN END;
+    output.Write(" "); output.Write("[");
+    FOR index := 7 TO 0 BY -1 DO
+      buffer[index] := hexRep(i0); i0 := i0 DIV 16;
+    END;
+    FOR index := 15 TO 8 BY -1 DO
+      buffer[index] := hexRep(i1); i1 := i1 DIV 16;
+    END;
+    buffer[16] := 0X;
+    output.WriteString(buffer);
+    output.Write("]");
+  END PrintDigest;
+
+(* ==================================================================== *)
+
+  PROCEDURE PrintModule(mod : Module);
+  VAR
+    i,j : INTEGER;
+    ty : Type;
+    rec : Record;
+    first : BOOLEAN;
+    heading : ARRAY 20 OF CHAR;
+    (* --------------------------- *)
+    PROCEDURE WriteOptionalExtras(impMod : Module);
+    BEGIN
+      IF impMod.fName[0] # 0X THEN
+        IF printFNames THEN
+          output.WriteString(' (* "' + impMod.fName + '" *)');
+        ELSE
+          output.WriteString(' := "' + impMod.fName + '"');
+        END; 
+      END; 
+    END WriteOptionalExtras;
+    (* --------------------------- *)
+  BEGIN
+
+    IF (mod.types.tide > 0) & alpha THEN 
+      QuickSortDescs(0, mod.types.tide-1, mod.types);
+    END;
+
+    output.WriteStart(mod);
+    IF mod.systemMod THEN
+      heading := "SYSTEM ";
+    ELSIF mod.fName[0] # 0X THEN
+      heading := "FOREIGN ";
+    ELSE
+      heading := "";
+    END;
+    heading := heading + "MODULE ";
+    output.WriteKeyword(heading);
+    output.WriteIdent(mod.name);
+    IF printFNames & (mod.fName[0] # 0X) THEN 
+      output.WriteString(' ["' + mod.fName + '"]'); 
+    END;
+    output.Write(';'); 
+   (*
+    *  Optional strong name goes here.
+    *)
+    IF mod.strongNm # NIL THEN
+      output.WriteLn; 
+      output.WriteString("    (* version ");
+      output.WriteInt(mod.strongNm[0]); output.Write(":");
+      output.WriteInt(mod.strongNm[1]); output.Write(":");
+      output.WriteInt(mod.strongNm[2]); output.Write(":");
+      output.WriteInt(mod.strongNm[3]); 
+      PrintDigest(mod.strongNm[4], mod.strongNm[5]);
+      output.WriteString(" *)");
+    END;
+   (*  end optional strong name.  *)
+    output.WriteLn; output.WriteLn;
+    IF mod.imports.tide > 1 THEN
+      output.WriteKeyword("IMPORT"); output.WriteLn;
+      output.Indent(4);
+      output.WriteImport(mod.imports.list[1]); 
+      WriteOptionalExtras(mod.imports.list[1]);
+      FOR i := 2 TO mod.imports.tide -1 DO 
+        output.Write(','); output.WriteLn; 
+        output.Indent(4);
+        output.WriteImport(mod.imports.list[i]); 
+        WriteOptionalExtras(mod.imports.list[i]);
+      END;
+      output.Write(';'); output.WriteLn;
+      output.WriteLn;
+    END;
+    IF mod.consts.tide > 0 THEN 
+      output.WriteKeyword("CONST"); output.WriteLn; 
+      PrintList(2,mod.consts,FALSE);
+      output.WriteLn;
+    END;
+    IF mod.types.tide > 0 THEN 
+      output.WriteKeyword("TYPE");  
+      output.WriteLn; output.WriteLn;
+      PrintList(2,mod.types,TRUE);
+      output.WriteLn;
+    END;
+    IF mod.vars.tide > 0 THEN 
+      output.WriteKeyword("VAR"); output.WriteLn; 
+      PrintList(2,mod.vars,FALSE);
+      output.WriteLn;
+    END;
+    FOR i := 0 TO mod.procs.tide -1 DO 
+      output.WriteLn;
+      mod.procs.list[i](ProcDesc).pType.PrintProc(0);
+    END;
+    output.WriteLn;
+    FOR i := 0 TO mod.types.tide -1 DO 
+      ty := mod.types.list[i](UserTypeDesc).type;
+      IF ty IS Pointer THEN ty := ty(Pointer).baseType; END;
+      IF ty IS Record THEN
+        rec := ty(Record);
+
+        IF (rec.methods.tide > 0) & alpha THEN 
+          QuickSortDescs(0, rec.methods.tide-1, rec.methods);
+        END;
+
+(* FIXME *)
+        IF rec.methods.tide > 0 THEN
+          IF rec.declarer # NIL THEN 
+            output.MethAnchor(rec.declarer.name);
+          ELSIF (rec.ptrType # NIL) & (rec.ptrType.declarer # NIL) THEN
+            output.MethAnchor(rec.ptrType.declarer.name);
+          END;
+        END;
+(* FIXME *)
+
+        FOR j := 0 TO rec.methods.tide -1 DO
+          rec.methods.list[j](ProcDesc).pType.PrintType(0);
+        END;
+      END;
+    END;
+    output.WriteLn;
+    output.WriteKeyword("END ");
+    output.WriteIdent(mod.name);
+    output.Write("."); output.WriteLn; 
+    output.WriteEnd();
+  END PrintModule;
+
+(* ============================================================ *)
+
+  PROCEDURE InitTypes();
+  VAR
+    t : Basic;
+  BEGIN
+    NEW(typeList,50);
+    typeList[0] := NIL;
+    NEW(t); t.name := "BOOLEAN"; typeList[1] := t;
+    NEW(t); t.name := "SHORTCHAR"; typeList[2] := t;
+    NEW(t); t.name := "CHAR"; typeList[3] := t;
+    NEW(t); t.name := "BYTE"; typeList[4] := t;
+    NEW(t); t.name := "SHORTINT"; typeList[5] := t;
+    NEW(t); t.name := "INTEGER"; typeList[6] := t;
+    NEW(t); t.name := "LONGINT"; typeList[7] := t;
+    NEW(t); t.name := "SHORTREAL"; typeList[8] := t;
+    NEW(t); t.name := "REAL"; typeList[9] := t;
+    NEW(t); t.name := "SET"; typeList[10] := t;
+    NEW(t); t.name := "ANYREC"; typeList[11] := t;
+    NEW(t); t.name := "ANYPTR"; typeList[12] := t;
+    NEW(t); t.name := "ARRAY OF CHAR"; typeList[13] := t;
+    NEW(t); t.name := "ARRAY OF SHORTCHAR"; typeList[14] := t;
+    NEW(t); t.name := "UBYTE"; typeList[15] := t;
+(*
+ *  NEW(t); t.name := "SPECIAL"; typeList[16] := t;
+ *)
+  END InitTypes;
+ 
+  PROCEDURE InitAccArray();
+  BEGIN
+    accArray[0] := ' ';
+    accArray[1] := '*';
+    accArray[2] := '-';
+    accArray[3] := '!';
+  END InitAccArray;
+
+(* ============================================================ *)
+
+PROCEDURE Usage();
+BEGIN
+  Console.WriteString("gardens point Browse: " + GPCPcopyright.verStr);
+  Console.WriteLn;
+  IF RTS.defaultTarget = "net" THEN
+    Console.WriteString("Usage:  Browse [options] <ModuleName>");
+    Console.WriteLn;
+    Console.WriteString("Browse Options ... ");
+    Console.WriteLn;
+    Console.WriteString(" /all ==> browse this and all imported modules");
+    Console.WriteLn;
+    Console.WriteString(" /file ==> write output to a file <ModuleName>.bro ");
+    Console.WriteLn;
+    Console.WriteString(" /full ==> display explicit foreign names ");
+    Console.WriteLn;
+    Console.WriteString(" /help ==> display this usage message");
+    Console.WriteLn;
+    Console.WriteString(" /hex  ==> use hexadecimal for short literals"); 
+    Console.WriteLn;
+    Console.WriteString(
+                    " /html ==> write html output to file <ModuleName>.html");
+    Console.WriteLn;
+    Console.WriteString(" /sort ==> sort procedures and types alphabetically");
+    Console.WriteLn;
+    Console.WriteString(" /verbatim ==> display anonymous public type names");
+    Console.WriteLn;
+  ELSE			(* RTS.defaultTarget = "jvm" *)
+    Console.WriteString("Usage: cprun Browse [options] <ModuleName>");
+    Console.WriteLn;
+    Console.WriteString("Browse Options ... ");
+    Console.WriteLn;
+    Console.WriteString(" -all ==> browse this and all imported modules");
+    Console.WriteLn;
+    Console.WriteString(" -file ==> write output to a file <ModuleName>.bro ");
+    Console.WriteLn;
+    Console.WriteString(" -full ==> display explicit foreign names ");
+    Console.WriteLn;
+    Console.WriteString(" -help ==> display this usage message");
+    Console.WriteLn;
+    Console.WriteString(" -hex  ==> use hexadecimal for short literals"); 
+    Console.WriteLn;
+    Console.WriteString(
+	" -html ==> write html output to file <ModuleName>.html");
+    Console.WriteLn;
+    Console.WriteString(" -sort ==> sort procedures and types alphabetically");
+    Console.WriteLn;
+    Console.WriteString(" -verbatim ==> display anonymous public type names");
+    Console.WriteLn;
+  END;
+  HALT(1);
+END Usage;
+
+PROCEDURE BadOption(optStr : ARRAY OF CHAR);
+BEGIN
+  Console.WriteString("Unrecognised option: " + optStr);
+  Console.WriteLn;
+END BadOption;
+
+PROCEDURE ParseOptions() : INTEGER;
+VAR
+  argNo : INTEGER;
+  option : FileNames.NameString;
+  fOutput : FileOutput;
+  hOutput : HtmlOutput; 
+  fileOutput, htmlOutput : BOOLEAN;
+BEGIN
+  printFNames := FALSE;
+  fileOutput := FALSE;
+  htmlOutput := FALSE;
+  verbatim := FALSE;
+  hexCon := FALSE;
+  doAll := FALSE;
+  alpha := FALSE;
+  argNo := 0;
+  ProgArgs.GetArg(argNo,option); 
+  WHILE (option[0] = '-') OR (option[0] = GPFiles.optChar) DO
+    INC(argNo);
+    option[0] := '-';
+    IF option[1] = 'f' THEN
+      IF option = "-full" THEN
+        printFNames := TRUE;
+      ELSIF option = "-file" THEN
+        IF htmlOutput THEN 
+          Console.WriteString("Cannot have html and file output");
+          Console.WriteLn;
+        ELSE
+          fileOutput := TRUE;
+          NEW(fOutput);
+          output := fOutput;
+        END;
+      ELSE
+        BadOption(option);
+      END;
+    ELSIF option = "-verbatim" THEN
+      verbatim := TRUE;
+    ELSIF option = "-all" THEN
+      doAll := TRUE;
+    ELSIF option = "-hex" THEN
+      hexCon := TRUE;
+    ELSIF option = "-html" THEN
+      IF fileOutput THEN 
+        Console.WriteString("Cannot have html and file output");
+        Console.WriteLn;
+      ELSE
+        htmlOutput := TRUE;
+        NEW(hOutput);
+        output := hOutput;
+      END;
+    ELSIF option = "-sort" THEN
+      alpha := TRUE;
+    ELSIF option = "-help" THEN
+      Usage();
+    ELSE
+      BadOption(option);
+    END;
+    IF argNo < args THEN ProgArgs.GetArg(argNo,option) ELSE RETURN argNo END;
+  END;
+  RETURN argNo;
+END ParseOptions;
+
+PROCEDURE Print();
+VAR
+  i : INTEGER;
+BEGIN
+  FOR i := 0 TO modList.tide-1 DO
+    IF modList.list[i].print THEN
+      output.thisMod := modList.list[i];
+      IF output IS FileOutput THEN
+        output(FileOutput).file := 
+            GPTextFiles.createFile(modList.list[i].name + outExt);
+      END;
+      PrintModule(modList.list[i]); 
+      IF output IS FileOutput THEN
+        GPTextFiles.CloseFile(output(FileOutput).file);
+      END;
+    END;
+  END;
+RESCUE (x)
+  Error.WriteString("Error in Parse()"); Error.WriteLn;
+  Error.WriteString(RTS.getStr(x)); Error.WriteLn;
+END Print;
+
+BEGIN
+  InitTypes();
+  InitAccArray();
+  modList.tide := 0;
+  NEW(modList.list,5);
+  NEW(output);
+  args := ProgArgs.ArgNumber();
+  IF (args < 1) THEN Usage(); END; 
+  argNo := ParseOptions(); 
+  IF (output IS FileOutput) THEN
+    IF (output IS HtmlOutput) THEN 
+      outExt := htmlExt;
+    ELSE
+      outExt := broExt;
+    END; 
+  END;
+  WHILE (argNo < args) DO
+    ProgArgs.GetArg(argNo,fileName);
+    GetSymAndModNames(fileName,modName);
+    module := GetModule(modName);
+    module.symName := fileName;
+    module.progArg := TRUE;
+    INC(argNo);
+  END;
+  Parse();
+  Print();
+END Browse.
+
+(* ============================================================ *)

gpcp/Builtin.cp

@@ -0,0 +1,468 @@
+(* ==================================================================== *)
+(*									*)
+(*  Builtin Symbols for the Gardens Point Component Pascal Compiler.	*)
+(*	Copyright (c) John Gough 1999, 2000.				*)
+(*									*)
+(* ==================================================================== *)
+
+MODULE Builtin;
+
+  IMPORT 
+	GPCPcopyright,
+	Console,
+ 	NameHash,
+	CompState,
+	Symbols,
+	IdDesc,
+        LitValue,
+	Typ := TypeDesc;
+
+(* ============================================================ *)
+  CONST	(* Here are global ordinals for builtin objects	procs	*)
+	(* Builtin Functions					*)
+      absP*  =  1; ashP*  =  2; bitsP* =  3; capP*  =  4;
+      chrP*  =  5; entP*  =  6; lenP*  =  7; longP* =  8; 
+      maxP*  =  9; minP*  = 10; oddP*  = 11; ordP*  = 12; 
+      shrtP* = 13; sizeP* = 14; mStrP* = 15; tpOfP* = 16;
+      boxP*  = 17; uBytP* = 18; 
+	(* Builtin Proper Procedures				*)
+      asrtP* = 21; decP*  = 22; incP*  = 23; inclP* = 24; 
+      exclP* = 25; haltP* = 26; newP*  = 27; throwP*= 28;
+      subsP* = 29; unsbP* = 30; apndP* = 31; cutP*  = 32;
+	(* Builtin SYSTEM Functions      			*)
+      adrP*  = 33; getP*  = 34; putP*  = 35;
+
+  CONST builtinTypeNum* = 16;
+
+(* ============================================================ *)
+
+  VAR	(* Here are the global descriptors for builtin objects.	*)
+	(* Builtin Types					*)
+      boolTp- : Symbols.Type;	(* type descriptor of BOOLEAN	*)
+      byteTp- : Symbols.Type;	(* type descriptor of BYTE	*)
+      uBytTp- : Symbols.Type;	(* type descriptor of UBYTE	*)
+      charTp- : Symbols.Type;	(* type descriptor of CHAR	*)
+      sChrTp- : Symbols.Type;	(* type descriptor of SHORTCHAR	*)
+      intTp-  : Symbols.Type;	(* type descriptor of INTEGER	*)
+      sIntTp- : Symbols.Type;	(* type descriptor of SHORTINT	*)
+      lIntTp- : Symbols.Type;	(* type descriptor of LONGINT	*)
+      realTp- : Symbols.Type;	(* type descriptor of REAL	*)
+      sReaTp- : Symbols.Type;	(* type descriptor of SHORTREAL	*)
+      anyRec- : Symbols.Type;	(* type descriptor of ANYREC	*)
+      anyPtr- : Symbols.Type;	(* type descriptor of ANYPTR	*)
+      setTp-  : Symbols.Type;	(* type descriptor of SET	*)
+      strTp-  : Symbols.Type;	(* type descriptor of <strings>	*)
+      sStrTp- : Symbols.Type;	(* type descriptor of <shortSt>	*)
+      metaTp- : Symbols.Type;	(* type descriptor of META	*)
+
+      chrArr- : Symbols.Type;	(* open value array of CHAR     *)
+
+      anyTpId- : IdDesc.TypId;
+
+  VAR baseTypeArray- : ARRAY builtinTypeNum+1 OF Symbols.Type;
+
+  VAR sysBkt- : INTEGER;
+      frnBkt- : INTEGER;
+      noChkB- : INTEGER;
+      constB- : INTEGER;
+      basBkt- : INTEGER;
+      selfBk- : INTEGER;
+      xpndBk- : INTEGER;
+
+(* ============================================================ *)
+
+  VAR	(* Here are more global descriptors for builtin objects	*)
+	(* Builtin Functions					*)
+      absPd-  : Symbols.Idnt;	(* ident descriptor of ABS	*)
+      ashPd-  : Symbols.Idnt;	(* ident descriptor of ASH	*)
+      bitsPd- : Symbols.Idnt;	(* ident descriptor of BITS	*)
+      capPd-  : Symbols.Idnt;	(* ident descriptor of CAP	*)
+      chrPd-  : Symbols.Idnt;	(* ident descriptor of CHR	*)
+      entPd-  : Symbols.Idnt;	(* ident descriptor of ENTIER	*)
+      lenPd-  : Symbols.Idnt;	(* ident descriptor of LEN	*)
+      longPd- : Symbols.Idnt;	(* ident descriptor of LONG	*)
+      maxPd-  : Symbols.Idnt;	(* ident descriptor of MAX	*)
+      minPd-  : Symbols.Idnt;	(* ident descriptor of MIN	*)
+      oddPd-  : Symbols.Idnt;	(* ident descriptor of ODD	*)
+      ordPd-  : Symbols.Idnt;	(* ident descriptor of ORD	*)
+      uBytPd- : Symbols.Idnt;	(* ident descriptor of USHORT	*)
+      shrtPd- : Symbols.Idnt;	(* ident descriptor of SHORT	*)
+      sizePd- : Symbols.Idnt;	(* ident descriptor of SIZE	*)
+      mStrPd- : Symbols.Idnt;	(* ident descriptor of MKSTR	*)
+      tpOfPd- : Symbols.Idnt;	(* ident descriptor of TYPEOF	*)
+      boxPd-  : Symbols.Idnt;	(* ident descriptor of BOX      *)
+	(* SYSTEM functions                                     *)
+      adrPd-  : Symbols.Idnt;	(* ident descriptor of ADR      *)
+      getPd-  : Symbols.Idnt;	(* ident descriptor of GET      *)
+      putPd-  : Symbols.Idnt;	(* ident descriptor of PUT      *)
+	(* Builtin Proper Procedures				*)
+      asrtPd- : Symbols.Idnt;	(* ident descriptor of ASSERT	*)
+      decPd-  : Symbols.Idnt;	(* ident descriptor of DEC	*)
+      incPd-  : Symbols.Idnt;	(* ident descriptor of INC	*)
+      inclPd- : Symbols.Idnt;	(* ident descriptor of INCL	*)
+      exclPd- : Symbols.Idnt;	(* ident descriptor of EXCL	*)
+      haltPd- : Symbols.Idnt;	(* ident descriptor of HALT	*)
+      throwPd-: Symbols.Idnt;	(* ident descriptor of THROW	*)
+      newPd-  : Symbols.Idnt;	(* ident descriptor of NEW	*)
+      subsPd- : Symbols.Idnt;	(* ident desc of REGISTER	*)
+      unsbPd- : Symbols.Idnt;	(* ident desc of DEREGISTER	*)
+      apndPd- : Symbols.Idnt;	(* ident descriptor of APPEND   *)
+      cutPd-  : Symbols.Idnt;	(* ident descriptor of CUT      *)
+
+(* ============================================================ *)
+
+  VAR	(* Here are more global descriptors for builtin objects	*)
+	(* Builtin Constants					*)
+      trueC- : Symbols.Idnt;	(* ident descriptor of TRUE	*)
+      falsC- : Symbols.Idnt;	(* ident descriptor of FALSE	*)
+      infC-  : Symbols.Idnt;	(* ident descriptor of INF	*)
+      nInfC- : Symbols.Idnt;	(* ident descriptor of NEGINF	*)
+      nilC-  : Symbols.Idnt;	(* ident descriptor of NIL	*)
+
+(* ============================================================ *)
+
+  VAR (* some private stuff *)
+      dummyProcType : Typ.Procedure;
+      dummyFuncType : Typ.Procedure;
+
+(* ============================================================ *)
+
+  PROCEDURE MkDummyImport*(IN  nam : ARRAY OF CHAR;
+			   IN  xNm : ARRAY OF CHAR;
+			   OUT blk : IdDesc.BlkId);
+    VAR jnk : BOOLEAN;
+  BEGIN
+    blk := IdDesc.newImpId();
+    blk.dfScp   := blk;
+    blk.hash    := NameHash.enterStr(nam);
+    IF LEN(xNm) > 1 THEN blk.scopeNm := LitValue.strToCharOpen(xNm) END;
+    jnk := CompState.thisMod.symTb.enter(blk.hash, blk);
+    INCL(blk.xAttr, Symbols.isFn);
+  END MkDummyImport;
+
+(* ------------------------------------------------------------	*)
+
+  PROCEDURE MkDummyClass*(IN  nam : ARRAY OF CHAR;
+			      blk : IdDesc.BlkId;
+			      att : INTEGER;
+			  OUT tId : IdDesc.TypId);
+    VAR ptr : TypeDesc.Pointer;
+	rec : TypeDesc.Record;
+	jnk : BOOLEAN;
+  BEGIN
+    ptr := TypeDesc.newPtrTp(); 
+    rec := TypeDesc.newRecTp(); 
+    tId := IdDesc.newTypId(ptr);
+    ptr.idnt    := tId;
+    ptr.boundTp := rec;
+    rec.bindTp  := ptr;
+    rec.extrnNm := blk.scopeNm;
+    rec.recAtt  := att;
+    INCL(rec.xAttr, Symbols.clsTp);		(* new 04.jun.01 *)
+(*
+ *  INCL(rec.xAttr, Symbols.noNew);		(* new 04.aug.01 *)
+ *)
+    tId.SetMode(Symbols.pubMode);
+    tId.dfScp := blk;
+    tId.hash  := NameHash.enterStr(nam);
+    jnk := blk.symTb.enter(tId.hash, tId);
+  END MkDummyClass;
+
+(* ------------------------------------------------------------	*)
+
+  PROCEDURE MkDummyVar*(IN  nam : ARRAY OF CHAR;
+                            blk : IdDesc.BlkId;
+                            typ : Symbols.Type;
+                        OUT vId : IdDesc.VarId);
+    VAR jnk : BOOLEAN;
+  BEGIN
+    vId := IdDesc.newVarId();
+    vId.SetMode(Symbols.pubMode);
+    vId.type  := typ;
+    vId.dfScp := blk;
+    vId.hash  := NameHash.enterStr(nam);
+    jnk := blk.symTb.enter(vId.hash, vId);
+  END MkDummyVar;
+
+(* ------------------------------------------------------------	*)
+
+  PROCEDURE MkDummyAlias*(IN  nam : ARRAY OF CHAR;
+			      blk : IdDesc.BlkId;
+			      typ : Symbols.Type;
+			  OUT tId : Symbols.Idnt);
+    VAR (* tId : IdDesc.TypId; *)
+	jnk : BOOLEAN;
+  BEGIN
+    tId := IdDesc.newTypId(typ);
+    tId.SetMode(Symbols.pubMode);
+    tId.dfScp := blk;
+    tId.hash  := NameHash.enterStr(nam);
+    jnk := blk.symTb.enter(tId.hash, tId);
+  END MkDummyAlias;
+
+(* ------------------------------------------------------------	*)
+
+  PROCEDURE SetPtrBase*(cls, bas : IdDesc.TypId);
+    VAR ptrC : TypeDesc.Pointer;
+	recC : TypeDesc.Record;
+    VAR ptrB : TypeDesc.Pointer;
+	recB : TypeDesc.Record;
+  BEGIN
+    ptrC := cls.type(TypeDesc.Pointer); 
+    recC := ptrC.boundTp(TypeDesc.Record);
+    ptrB := bas.type(TypeDesc.Pointer); 
+    recB := ptrB.boundTp(TypeDesc.Record);
+    recC.baseTp := recB;
+  END SetPtrBase;
+
+(* ============================================================ *)
+
+  PROCEDURE InitAnyRec(ord : INTEGER);
+    VAR base : TypeDesc.Base;
+        tpId : IdDesc.TypId;
+  BEGIN
+    base := TypeDesc.anyRecTp;
+    tpId := IdDesc.newTypId(base);
+    anyRec := base;
+    anyTpId := tpId;
+    base.idnt  := tpId;
+    base.tpOrd := ord;
+    base.dump  := ord;
+    baseTypeArray[ord] := base;
+  END InitAnyRec;
+
+  PROCEDURE InitAnyPtr(ord : INTEGER);
+    VAR base : TypeDesc.Base;
+	tpId : IdDesc.TypId;
+  BEGIN
+    base := TypeDesc.anyPtrTp;
+    tpId := IdDesc.newTypId(base);
+    anyPtr := base;
+    base.idnt  := tpId;
+    base.tpOrd := ord;
+    base.dump  := ord;
+    baseTypeArray[ord] := base;
+  END InitAnyPtr;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE StdType(ord : INTEGER; OUT var : Symbols.Type);
+    VAR base : TypeDesc.Base;
+	tpId : IdDesc.TypId;
+  BEGIN
+    base := TypeDesc.newBasTp();
+    tpId := IdDesc.newTypId(base);
+    base.idnt  := tpId;
+    base.tpOrd := ord;
+    base.dump  := ord;
+    var := base;
+    baseTypeArray[ord] := base;
+  END StdType;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE StdConst(typ : Symbols.Type; OUT var : Symbols.Idnt);
+    VAR conD : IdDesc.ConId;
+  BEGIN
+    conD := IdDesc.newConId();
+    conD.SetStd();
+    conD.type  := typ;
+    var := conD;
+  END StdConst;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE StdFunc(ord : INTEGER; OUT var : Symbols.Idnt);
+    VAR proc : IdDesc.PrcId;
+  BEGIN
+    proc := IdDesc.newPrcId();
+    proc.SetKind(IdDesc.conPrc);
+    proc.SetOrd(ord);
+    proc.type := dummyFuncType;
+    var := proc;
+  END StdFunc;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE StdProc(ord : INTEGER; OUT var : Symbols.Idnt);
+    VAR proc : IdDesc.PrcId;
+  BEGIN
+    proc := IdDesc.newPrcId();
+    proc.SetKind(IdDesc.conPrc);
+    proc.SetOrd(ord);
+    proc.type := dummyProcType;
+    var := proc;
+  END StdProc;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE BindName(var : Symbols.Idnt; IN str : ARRAY OF CHAR);
+    VAR hash : INTEGER;
+	temp : IdDesc.BlkId;
+  BEGIN
+    hash := NameHash.enterStr(str);
+    var.hash := hash;
+    var.dfScp := NIL;
+    ASSERT(CompState.thisMod.symTb.enter(hash, var));
+  END BindName;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE BindSysName(var : Symbols.Idnt; IN str : ARRAY OF CHAR);
+    VAR hash : INTEGER;
+	temp : IdDesc.BlkId;
+  BEGIN
+    hash := NameHash.enterStr(str);
+    var.hash := hash;
+    var.dfScp := NIL;
+    ASSERT(CompState.sysMod.symTb.enter(hash, var));
+  END BindSysName;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE RebindBuiltins*;
+  BEGIN
+    selfBk := NameHash.enterStr("SELF");
+    basBkt := NameHash.enterStr("BASE");
+    sysBkt := NameHash.enterStr("SYSTEM");
+    xpndBk := NameHash.enterStr("expand");
+    frnBkt := NameHash.enterStr("FOREIGN");
+    constB := NameHash.enterStr("CONSTRUCTOR");
+    noChkB := NameHash.enterStr("UNCHECKED_ARITHMETIC");
+    BindName(boolTp.idnt, "BOOLEAN");
+    BindName(byteTp.idnt, "BYTE");
+    BindName(uBytTp.idnt, "UBYTE");
+    BindName(charTp.idnt, "CHAR");
+    BindName(sChrTp.idnt, "SHORTCHAR");
+    BindName(intTp.idnt,  "INTEGER");
+    BindName(sIntTp.idnt, "SHORTINT");
+    BindName(lIntTp.idnt, "LONGINT");
+    BindName(realTp.idnt, "REAL");
+    BindName(sReaTp.idnt, "SHORTREAL");
+    BindName(anyRec.idnt, "ANYREC");
+    BindName(anyPtr.idnt, "ANYPTR");
+    BindName(setTp.idnt,  "SET");
+    BindName(strTp.idnt,  "<string>");
+    BindName(sStrTp.idnt, "<shortString>");
+    BindName(metaTp.idnt, "<META-TYPE>");
+
+    BindName(absPd,  "ABS");
+    BindName(ashPd,  "ASH");
+    BindName(bitsPd, "BITS");
+    BindName(capPd,  "CAP");
+    BindName(chrPd,  "CHR");
+    BindName(entPd,  "ENTIER");
+    BindName(lenPd,  "LEN");
+    BindName(longPd, "LONG");
+    BindName(maxPd,  "MAX");
+    BindName(minPd,  "MIN");
+    BindName(oddPd,  "ODD");
+    BindName(ordPd,  "ORD");
+    BindName(uBytPd, "USHORT");
+    BindName(shrtPd, "SHORT");
+    BindName(sizePd, "SIZE");
+    BindName(mStrPd, "MKSTR");
+    BindName(boxPd,  "BOX");
+    BindName(tpOfPd, "TYPEOF");
+
+    BindSysName(adrPd, "ADR");
+    BindSysName(getPd, "GET");
+    BindSysName(putPd, "PUT");
+
+    BindName(asrtPd, "ASSERT");
+    BindName(decPd,  "DEC");
+    BindName(incPd,  "INC");
+    BindName(inclPd, "INCL");
+    BindName(exclPd, "EXCL");
+    BindName(haltPd, "HALT");
+    BindName(throwPd,"THROW");
+    BindName(newPd,  "NEW");
+    BindName(subsPd, "REGISTER");
+    BindName(unsbPd, "DEREGISTER");
+    BindName(apndPd, "APPEND");
+    BindName(cutPd,  "CUT");
+
+    BindName(trueC, "TRUE");
+    BindName(falsC, "FALSE");
+    BindName(infC,  "INF");
+    BindName(nInfC, "NEGINF");
+    BindName(nilC,  "NIL");
+
+    CompState.sysMod.hash := sysBkt;
+  END RebindBuiltins;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE InitBuiltins*;
+  BEGIN
+    InitAnyRec(Typ.anyRec);
+    InitAnyPtr(Typ.anyPtr);
+    StdType(Typ.boolN, boolTp);
+    StdType(Typ.byteN, byteTp);
+    StdType(Typ.uBytN, uBytTp);
+    StdType(Typ.charN, charTp); chrArr := Typ.mkArrayOf(charTp);
+    StdType(Typ.sChrN, sChrTp);
+    StdType(Typ.intN,  intTp);  Typ.integerT := intTp;
+    StdType(Typ.sIntN, sIntTp);
+    StdType(Typ.lIntN, lIntTp);
+    StdType(Typ.realN, realTp);
+    StdType(Typ.sReaN, sReaTp);
+(*
+    StdType(Typ.anyPtr,anyPtr);
+ *)
+    StdType(Typ.setN,  setTp);
+    StdType(Typ.strN,  strTp);
+    StdType(Typ.sStrN, sStrTp);
+    StdType(Typ.metaN, metaTp);
+
+    dummyProcType := Typ.newPrcTp();
+    dummyFuncType := Typ.newPrcTp(); 
+    dummyFuncType.retType := anyPtr;
+
+    StdFunc(absP,  absPd);
+    StdFunc(ashP,  ashPd);
+    StdFunc(bitsP, bitsPd);
+    StdFunc(capP,  capPd);
+    StdFunc(chrP,  chrPd);
+    StdFunc(entP,  entPd);
+    StdFunc(lenP,  lenPd);
+    StdFunc(longP, longPd);
+    StdFunc(maxP,  maxPd);
+    StdFunc(minP,  minPd);
+    StdFunc(oddP,  oddPd);
+    StdFunc(ordP,  ordPd);
+    StdFunc(uBytP, uBytPd);
+    StdFunc(shrtP, shrtPd);
+    StdFunc(sizeP, sizePd);
+    StdFunc(mStrP, mStrPd);
+    StdFunc(boxP,  boxPd);
+    StdFunc(tpOfP, tpOfPd);
+
+    StdFunc(adrP,  adrPd);
+    StdProc(getP,  getPd);
+    StdProc(putP,  putPd);
+
+    StdProc(asrtP, asrtPd);
+    StdProc(decP,  decPd);
+    StdProc(incP,  incPd);
+    StdProc(inclP, inclPd);
+    StdProc(exclP, exclPd);
+    StdProc(haltP, haltPd);
+    StdProc(throwP,throwPd);
+    StdProc(newP,  newPd);
+    StdProc(subsP, subsPd);
+    StdProc(unsbP, unsbPd);
+    StdProc(apndP, apndPd);
+    StdProc(cutP,  cutPd);
+
+    StdConst(boolTp, trueC);
+    StdConst(boolTp, falsC);
+    StdConst(sReaTp, infC);
+    StdConst(sReaTp, nInfC);
+    StdConst(anyPtr, nilC);
+  END InitBuiltins;
+
+(* ============================================================ *)
+END Builtin.  (* ============================================== *)
+(* ============================================================ *)
+

gpcp/CPMake.cp

@@ -0,0 +1,391 @@
+(***********************************************************************)
+(*                     Component Pascal Make Tool                      *)
+(*                                                                     *)
+(*           Diane Corney, 20th July 1999                              *)
+(*           Modifications:                                            *)
+(*                                                                     *)
+(*                                                                     *)
+(***********************************************************************)
+MODULE CPMake ;
+
+IMPORT GPCPcopyright,
+       CPmain, 
+       CPascal,
+       G := CPascalG,
+       S := CPascalS, 
+       CPascalErrors,
+       LitValue,
+       ForeignName,
+       GPFiles,
+       GPBinFiles,
+       GPTextFiles, 
+       NameHash,
+       CompState,
+       NewSymFileRW,
+       MH := ModuleHandler, 
+       SF := SymbolFile,
+       ProgArgs,
+       FileNames,
+       Error,
+       RTS,
+       Console;
+
+TYPE
+  ArgString = ARRAY 256 OF CHAR;
+  ArgBlock = RECORD
+               args : POINTER TO ARRAY OF ArgString;
+               argNum : INTEGER;
+             END;
+
+CONST
+  argSize = 10;
+
+VAR
+  startT, endT : LONGINT;
+
+VAR
+  toDoList, compList : MH.ModList; 
+  graph : MH.ModInfo;
+  token : S.Token;
+  sysBkt : INTEGER;
+  frnBkt : INTEGER;
+  buildOK : BOOLEAN;
+  compCount : INTEGER;
+  args : ArgBlock;
+  force : BOOLEAN;
+
+  PROCEDURE Chuck(IN msg : ARRAY OF CHAR);
+  BEGIN
+    Error.WriteString('CPMake: "');
+    Error.WriteString(msg); 
+    Error.WriteString('" Halting...');
+    Error.WriteLn; HALT(1);
+  END Chuck;
+
+  PROCEDURE Warn(IN msg : ARRAY OF CHAR);
+  BEGIN
+    Console.WriteString('CPMake: ');
+    Console.WriteString(msg); Console.WriteLn; 
+  END Warn;
+
+  PROCEDURE Usage();
+    CONST jPre = "cprun ";
+	  str1 = "Usage: CPMake [";
+	  str2 = "all] [gpcp-options] <ModuleName>";
+	  str3 = "	For gpcp-options, type: ";
+	  str4 = "gpcp ";
+	  str5 = "help";
+    VAR   isNt : BOOLEAN;
+  BEGIN
+    Console.WriteString("gardens point CPMake: " + GPCPcopyright.verStr);
+    Console.WriteLn;
+    isNt := RTS.defaultTarget = "net";
+    IF ~isNt THEN Console.WriteString(jPre) END;
+    Console.WriteString(str1);
+    Console.Write(GPFiles.optChar);
+    Console.WriteString(str2);
+    Console.WriteLn();
+    Console.WriteString(str3);
+    IF ~isNt THEN Console.WriteString(jPre) END;
+    Console.WriteString(str4);
+    Console.Write(GPFiles.optChar);
+    Console.WriteString(str5);
+    Console.WriteLn();
+  END Usage;
+
+PROCEDURE ReadModuleName(VAR name : ARRAY OF CHAR);
+VAR
+  i, pos, parNum, numArgs : INTEGER;
+  opt : ArgString;
+BEGIN
+  numArgs := ProgArgs.ArgNumber();
+  args.argNum := 0;
+  CompState.InitOptions();
+  IF numArgs < 1 THEN
+    Usage();
+    HALT(1);
+  END;
+  IF numArgs > 1 THEN
+    NEW(args.args, numArgs-1);
+    FOR parNum := 0 TO numArgs-2 DO
+      ProgArgs.GetArg(parNum,opt);
+      IF (opt[0] = '-') OR (opt[0] = GPFiles.optChar) THEN
+	opt[0] := '-';
+	IF opt = "-all" THEN 
+	  force := TRUE;
+	ELSE
+          CPascal.DoOption(opt);
+          args.args[args.argNum] := opt;
+          INC(args.argNum);
+	END;
+      ELSE
+        Console.WriteString("Unknown option:  " + opt); 
+	Console.WriteLn;
+      END;
+    END; 
+  END;
+  ProgArgs.GetArg(numArgs-1,name);
+  IF (name[0] = '-') OR (name[0] = GPFiles.optChar) THEN
+    Usage();
+    HALT(1);
+  END;
+  i := 0;
+  WHILE (name[i] # '.') & (name[i] # 0X) & (i < LEN(name)) DO INC(i); END;
+  IF (i < LEN(name)) & (name[i] = '.') THEN
+    WHILE (name[i] # 0X) & (i < LEN(name)) DO
+      name[i] := 0X; INC(i);
+    END;
+  END;
+END ReadModuleName;
+
+PROCEDURE Check (sym : INTEGER; mod : MH.ModInfo);
+BEGIN
+  IF token.sym # sym THEN 
+    S.ParseErr.Report(sym,token.lin,token.col);
+    GPBinFiles.CloseFile(S.src);
+    CPascal.FixListing();
+    CPascal.Finalize();
+    Chuck("Parse error(s) in module <" + mod.name + ">");
+  END;
+END Check;
+
+PROCEDURE DoImport(mod : MH.ModInfo; VAR mainImported : BOOLEAN);
+VAR
+  mName : FileNames.NameString;
+  aMod  : MH.ModInfo;
+  last  : S.Token;
+  strng, impNm : POINTER TO ARRAY OF CHAR;
+  (* ----------------------------------------------------------- *)
+  PROCEDURE AssignOpen(src : LitValue.CharOpen; 
+                   OUT dst : FileNames.NameString);
+    VAR idx, max : INTEGER;
+  BEGIN
+    max := MIN(LEN(src), LEN(FileNames.NameString));
+    FOR idx := 0 TO max-1 DO dst[idx] := src[idx] END;
+  END AssignOpen;
+  (* ----------------------------------------------------------- *)
+BEGIN
+  Check(G.identSym,mod);
+  last := token;
+  token := S.get();			(* read past ident *)
+  IF (token.sym = G.colonequalSym) THEN
+    last  := S.get();			(* read past ":="  *)
+    token := S.get();			(* read past ident *)
+  END;
+  IF last.sym = G.identSym THEN
+    S.GetString(last.pos, last.len, mName);
+  ELSIF last.sym = G.stringSym THEN
+    strng := LitValue.subStrToCharOpen(last.pos+1, last.len-2);
+    ForeignName.ParseModuleString(strng, impNm);
+    AssignOpen(impNm, mName);
+  ELSE
+    Chuck("Bad module name for alias import");
+  END;
+  IF (NameHash.enterSubStr(last.pos, last.len) = NameHash.mainBkt) OR 
+     (NameHash.enterSubStr(last.pos, last.len) = NameHash.winMain) THEN
+    mainImported := TRUE;
+  ELSE
+    aMod := MH.GetModule(mName);
+    MH.Add(mod.imports,aMod);
+    MH.Add(aMod.importedBy,mod);
+    IF ~aMod.importsLinked THEN MH.Add(toDoList,aMod); END;
+  END;
+END DoImport;
+
+PROCEDURE LinkImports(mod : MH.ModInfo);
+VAR
+  mName : FileNames.NameString;
+  cpmainImported : BOOLEAN;
+  hsh : INTEGER;
+BEGIN
+  CompState.InitCompState(mod.name + ".cp");
+  mod.importsLinked := TRUE;
+  cpmainImported := FALSE;
+  S.Reset;
+  token := S.get(); 
+  IF (token.sym = G.identSym) THEN
+    hsh := NameHash.enterSubStr(token.pos,token.len);
+    IF (hsh = sysBkt) OR (hsh = frnBkt) THEN
+      mod.isForeign := TRUE;
+      token := S.get();
+    END;
+  END; 
+  Check(G.MODULESym,mod); token := S.get();
+  Check(G.identSym,mod);
+  S.GetString(token.pos,token.len,mName);
+  IF (mName # mod.name) THEN 
+    Chuck("File " + mod.name + ".cp does not contain MODULE " + mName);
+  END;
+  token := S.get();
+  IF token.sym = G.lbrackSym THEN
+    (* mod.isForeign := TRUE; *)
+    token := S.get();  (* skip string and rbracket *)
+    token := S.get(); 
+    token := S.get();
+  END; 
+  Check(G.semicolonSym,mod); token := S.get();
+  IF (token.sym = G.IMPORTSym) THEN
+    token := S.get();
+    DoImport(mod,cpmainImported);
+    WHILE (token.sym = G.commaSym) DO
+      token := S.get();
+      DoImport(mod,cpmainImported);
+    END;
+  END;
+  IF (mod = graph) & ~cpmainImported THEN
+    Warn("WARNING: " + mod.name + " is not a base module.");
+    Warn("Modules that " + mod.name + " depends on will be checked for consistency");
+    Warn("Modules that depend on " + mod.name + " will not be checked or recompiled");
+  END;
+END LinkImports;
+
+PROCEDURE BuildGraph() : BOOLEAN;
+VAR
+  name : FileNames.NameString;
+  nextIx : INTEGER;
+  nextModule : MH.ModInfo;
+  srcFound : BOOLEAN;
+BEGIN
+  NEW(graph); 
+  ReadModuleName(name);
+  graph := MH.GetModule(name);
+  S.src := GPBinFiles.findLocal(graph.name + ".cp");
+  IF S.src = NIL THEN
+    Chuck("Could not find base file <" + graph.name + ".cp>");
+  ELSE
+    GPBinFiles.CloseFile(S.src);
+  END;
+  MH.Add(toDoList,graph);
+  nextIx := 0; 
+  WHILE (nextIx < toDoList.tide) DO
+    nextModule := toDoList.list[nextIx]; INC(nextIx);
+    S.src := GPBinFiles.findLocal(nextModule.name + ".cp");
+    SF.OpenSymbolFile(nextModule.name, S.src = NIL);
+    IF S.src = NIL THEN
+      IF SF.file = NIL THEN 
+        Chuck("Cannot find source file <" + nextModule.name + 
+                  ".cp> or symbol file <" + nextModule.name + 
+                  ".cps> on CPSYM path.");
+      ELSE 
+        SF.ReadSymbolFile(nextModule,FALSE); 
+      END ;
+    ELSE
+      LinkImports(nextModule); 
+      IF force OR (SF.file = NIL) OR ~GPFiles.isOlder(S.src,SF.file) THEN
+        nextModule.compile := TRUE; 
+(*
+ *      IF force THEN
+ *	  Console.WriteString("force: Setting compile flag on ");
+ *	  Console.WriteString(nextModule.name);
+ *	  Console.WriteLn;
+ *      ELSIF (SF.file = NIL) THEN
+ *	  Console.WriteString("file=NIL: Setting compile flag on ");
+ *	  Console.WriteString(nextModule.name);
+ *	  Console.WriteLn;
+ *      ELSIF ~GPFiles.isOlder(S.src,SF.file) THEN
+ *	  Console.WriteString("isOlder: Setting compile flag on ");
+ *	  Console.WriteString(nextModule.name);
+ *	  Console.WriteLn;
+ *      END;
+ *)
+      ELSE 
+        SF.ReadSymbolFile(nextModule,TRUE);
+      END;
+      SF.CloseSymFile();		(* or .NET barfs! *)
+    END;
+  END;
+  RETURN TRUE;
+RESCUE (buildX)
+  Console.WriteString("#cpmake:  ");
+  Console.WriteString(RTS.getStr(buildX));
+  Console.WriteLn;
+  RETURN FALSE;
+END BuildGraph;
+
+PROCEDURE CompileModule(mod : MH.ModInfo; VAR retVal : INTEGER);
+VAR
+  i : INTEGER;
+BEGIN
+  CompState.InitOptions();
+  FOR i := 0 TO args.argNum-1 DO
+    CPascal.DoOption(args.args[i]);
+  END; 
+  IF mod.isForeign THEN
+    IF ~CompState.quiet THEN
+      Console.WriteString(
+	  "#cpmake:  "+mod.name+" is foreign, compiling with -special.");
+      Console.WriteLn;
+      Console.WriteString(
+	  "#cpmake:  Foreign implementation may need recompilation.");
+      Console.WriteLn;
+    END;
+    CPascal.DoOption("-special");
+  ELSIF ~CompState.quiet THEN
+    Console.WriteString("#cpmake:  compiling " + mod.name);
+    Console.WriteLn;
+  END;
+  CPascal.Compile(mod.name+".cp",retVal); 
+  mod.key := NewSymFileRW.GetLastKeyVal(); 
+  INC(compCount);
+END CompileModule;
+
+PROCEDURE DFS(VAR node : MH.ModInfo);
+VAR
+  ix,retVal : INTEGER;
+  imp : MH.ModInfo;
+BEGIN
+  IF ~node.done THEN
+    node.done := TRUE;
+    FOR ix := 0 TO node.imports.tide-1 DO
+      DFS(node.imports.list[ix]);
+    END;
+    IF node.compile THEN
+      retVal := 0;
+      CompileModule(node,retVal);
+      IF retVal # 0 THEN
+        Chuck("Compile errors in module <" + node.name + ">");
+      END;
+    END;
+    FOR ix := 0 TO node.importedBy.tide-1 DO
+      imp := node.importedBy.list[ix];
+      IF (~imp.compile) & (node.key # MH.GetKey(imp,node)) THEN
+        node.importedBy.list[ix].compile := TRUE;
+      END;
+    END; 
+  END;
+END DFS;
+
+PROCEDURE WalkGraph(VAR node : MH.ModInfo);
+BEGIN
+  DFS(node);
+RESCUE (compX)
+  Console.WriteString("#cpmake:  ");
+  Console.WriteString(RTS.getStr(compX));
+  Console.WriteLn;
+END WalkGraph;
+
+BEGIN
+  force := FALSE;
+  compCount := 0;
+  NameHash.InitNameHash(0);
+  sysBkt := NameHash.enterStr("SYSTEM");
+  frnBkt := NameHash.enterStr("FOREIGN");
+  CPascalErrors.Init();
+  buildOK := BuildGraph();
+  IF buildOK THEN
+    startT := RTS.GetMillis();
+    WalkGraph(graph);
+    endT := RTS.GetMillis();
+    Console.WriteString("#cpmake:  ");
+    IF compCount = 0 THEN
+      Console.WriteString("no re-compilation required.");
+    ELSIF compCount = 1 THEN
+      Console.WriteString("one module compiled.");
+    ELSE
+      Console.WriteInt(compCount,1);
+      Console.WriteString(" modules compiled.");
+    END;
+    Console.WriteLn;
+    CompState.TimeMsg("Total Compilation Time ", endT - startT);
+  END;
+END CPMake.

gpcp/CPascal.cp

@@ -0,0 +1,212 @@
+(* ==================================================================== *)
+(*                                                                      *)
+(*  Main Module for the Gardens Point Component Pascal Compiler.        *)
+(*      Copyright (c) John Gough 1999, 2000.                            *)
+(*      This module was extensively modified from the driver            *)
+(*      automatically produced by the M2 version of COCO/R, using       *)
+(*      the CPascal.atg grammar used for the JVM version of GPCP.       *)
+(*                                                                      *)
+(* ==================================================================== *)
+
+MODULE CPascal;
+(* This is an example of a rudimentary main module for use with COCO/R.
+   The auxiliary modules <Grammar>S (scanner) and <Grammar>P (parser)
+   are assumed to have been constructed with COCO/R compiler generator. *)
+
+  IMPORT
+        GPCPcopyright,
+        Symbols,
+        RTS,
+        FileNames,
+        IdDesc,
+        Error,
+        Console,
+        ProgArgs,
+        CSt := CompState,
+        CPascalP,
+        Scnr := CPascalS,
+        CPascalErrors,
+        New := NewSymFileRW,
+        Old := OldSymFileRW,
+        NameHash,
+        Visitor,
+        Builtin,
+        GPText,
+        Target,
+        TxtFil := GPTextFiles,
+        BinFil := GPBinFiles;
+
+(* ==================================================================== *)
+(*                         Option Setting                               *)
+(* ==================================================================== *)
+
+    PROCEDURE ResetOptions*;
+    BEGIN
+      CSt.InitOptions;
+    END ResetOptions;
+
+    (* -------------------------- *)
+
+    PROCEDURE Message*(IN msg : ARRAY OF CHAR);
+    BEGIN
+      CSt.Message(msg);
+    END Message;
+
+    (* -------------------------- *)
+
+    PROCEDURE DoOption*(IN opt : ARRAY OF CHAR);
+    BEGIN
+      CSt.ParseOption(opt);
+    END DoOption;
+
+    (* -------------------------- *)
+
+    PROCEDURE CondMsg(IN msg : ARRAY OF CHAR);
+    BEGIN
+      IF CSt.verbose THEN CSt.Message(msg) END;
+    END CondMsg;
+
+(* ==================================================================== *)
+(*                    Calling the Compiler                              *)
+(* ==================================================================== *)
+
+    PROCEDURE Finalize*;
+      VAR a : ARRAY 16 OF CHAR;
+          b : ARRAY 256 OF CHAR;
+    BEGIN
+      IF CPascalErrors.forVisualStudio OR
+         CPascalErrors.xmlErrors THEN RETURN END;
+      b := "<" + CompState.modNam + ">";
+      IF Scnr.errors = 0 THEN
+        b := (b + " No errors");
+      ELSIF Scnr.errors = 1 THEN
+        b := (b + " There was one error");
+      ELSE
+        GPText.IntToStr(Scnr.errors, a);
+        b := (b + " There were " + a + " errors");
+      END;
+      IF Scnr.warnings = 1 THEN
+        b := (b + ", and one warning");
+      ELSIF Scnr.warnings > 1 THEN
+        GPText.IntToStr(Scnr.warnings, a);
+        b := (b + ", and " + a + " warnings");
+      END;
+      IF ~CSt.quiet THEN CSt.Message(b) END;
+    END Finalize;
+
+(* ==================================================================== *)
+
+    PROCEDURE FixListing*;
+      VAR doList : BOOLEAN;
+          events : INTEGER;
+    BEGIN
+      doList := (CSt.listLevel > Scnr.listNever);
+      events := Scnr.errors;
+      IF CSt.warning THEN INC(events, Scnr.warnings) END;
+      IF (events > 0) OR
+         (CSt.listLevel = Scnr.listAlways) THEN
+        Scnr.lst := TxtFil.createFile(CSt.lstNam);
+        IF Scnr.lst # NIL THEN
+          CPascalErrors.PrintListing(doList);
+          TxtFil.CloseFile(Scnr.lst);
+          Scnr.lst := NIL;
+        ELSE
+          CSt.Message("cannot create file <" + CSt.lstNam + ">");
+          IF events > 0 THEN CPascalErrors.PrintListing(FALSE) END;
+        END;
+      END;
+      CPascalErrors.ResetErrorList();
+    END FixListing;
+
+(* ==================================================================== *)
+
+    PROCEDURE Compile*(IN nam : ARRAY OF CHAR; OUT retVal : INTEGER);
+    BEGIN
+      CSt.CheckOptionsOK;
+      retVal := 0;
+      CSt.totalS := RTS.GetMillis();
+(*
+      Scnr.src := TxtFil.findLocal(nam);
+ *)
+      Scnr.src := BinFil.findLocal(nam);
+      IF Scnr.src = NIL THEN
+        CSt.Message("cannot open local file <" + nam + ">");
+      ELSE
+        NameHash.InitNameHash(CSt.hashSize);
+        CSt.outNam := NIL;
+        CSt.InitCompState(nam);
+        Builtin.RebindBuiltins();
+        Target.Select(CSt.thisMod, CSt.target);
+        Target.Init();
+        CondMsg("Starting Parse");
+        CPascalP.Parse;   (* do the compilation here *)
+        CSt.parseE := RTS.GetMillis();
+        IF Scnr.errors = 0 THEN
+          CondMsg("Doing statement attribution");
+          CSt.thisMod.StatementAttribution(Visitor.newImplementedCheck());
+          IF (Scnr.errors = 0) & CSt.extras THEN
+            CondMsg("Doing type erasure");
+            CSt.thisMod.TypeErasure(Visitor.newTypeEraser());
+          END;
+          IF Scnr.errors = 0 THEN
+            CondMsg("Doing dataflow analysis");
+            CSt.thisMod.DataflowAttribution();
+            CSt.attrib := RTS.GetMillis();
+            IF Scnr.errors = 0 THEN
+              IF CSt.doSym THEN
+                CondMsg("Emitting symbol file");
+                IF CSt.legacy THEN
+                  Old.EmitSymfile(CSt.thisMod);
+                ELSE
+                  New.EmitSymfile(CSt.thisMod);
+                END;
+                CSt.symEnd := RTS.GetMillis();
+                IF CSt.doAsm THEN
+                  IF CSt.isForeign() THEN
+                    CondMsg("Foreign module: no code output");
+                  ELSE
+                    CondMsg("Emitting assembler");
+                    Target.Emit();
+                    CSt.asmEnd := RTS.GetMillis();
+                    IF CSt.doCode THEN Target.Assemble() END;
+                  END;
+                END;
+              END;
+            END;
+          END;
+        END;
+        IF Scnr.errors # 0 THEN retVal := 2 END;
+        CSt.totalE := RTS.GetMillis();
+        FixListing;
+        Finalize;
+        IF CSt.doStats THEN CSt.Report END;
+      END;
+    RESCUE (sysX)
+      retVal := 2;
+      CSt.Message("<< COMPILER PANIC >>");
+      Scnr.SemError.RepSt1(299, RTS.getStr(sysX), 1, 1);
+     (* 
+      *  If an exception is raised during listing, FixListing will
+      *  be called twice. Avoid an attempted sharing violation...
+      *)
+      IF Scnr.lst # NIL THEN 
+      TxtFil.CloseFile(Scnr.lst);
+      CSt.Message(RTS.getStr(sysX));
+      Scnr.lst := NIL;
+      ELSE
+        FixListing;
+      END;
+      Finalize;
+    END Compile;
+
+(* ==================================================================== *)
+(*                       Main Argument Loop                             *)
+(* ==================================================================== *)
+
+BEGIN
+  CSt.InitOptions;
+  CPascalErrors.Init;
+  Builtin.InitBuiltins;
+END CPascal.
+
+(* ==================================================================== *)

gpcp/CPascalErrors.cp

@@ -0,0 +1,994 @@
+(* ==================================================================== *)
+(*									*)
+(*  Error Module for the Gardens Point Component Pascal Compiler.	*)
+(*	Copyright (c) John Gough 1999, 2000.				*)
+(*									*)
+(* ==================================================================== *)
+
+MODULE CPascalErrors;
+
+  IMPORT 
+	GPCPcopyright,
+	GPTextFiles,
+	Console,
+        FileNames,
+	Scnr := CPascalS, 
+	LitValue,
+	GPText;
+
+(* ============================================================ *)
+
+  CONST
+    consoleWidth = 80;
+    listingWidth = 256;
+    listingMax   = listingWidth-1;
+
+  TYPE
+    ParseHandler* = POINTER TO RECORD (Scnr.ErrorHandler)
+		    END;
+    SemanticHdlr* = POINTER TO RECORD (Scnr.ErrorHandler)
+		    END;
+
+  TYPE
+      Message = LitValue.CharOpen;
+
+      Err     = POINTER TO ErrDesc;
+      ErrDesc = RECORD
+		  num, lin, col: INTEGER;
+		  msg: Message;
+		END;
+      ErrBuff = POINTER TO ARRAY OF Err;
+
+  VAR
+      parsHdlr : ParseHandler;
+      semaHdlr : SemanticHdlr;
+      eBuffer  : ErrBuff;	(* Invariant: eBuffer[eTide] = NIL *)
+      eLimit   : INTEGER;	(* High index of dynamic array.    *)
+      eTide    : INTEGER;	(* Next index for insertion in buf *)
+      prompt*  : BOOLEAN;	(* Emit error message immediately  *)
+      nowarn*  : BOOLEAN;	(* Don't store warning messages    *)
+      srcNam   : FileNames.NameString;
+      forVisualStudio* : BOOLEAN;
+      xmlErrors* : BOOLEAN;
+
+(* ============================================================ *)
+
+  PROCEDURE StoreError (eNum, linN, colN : INTEGER; mesg: Message);
+  (* Store an error message for later printing *)
+    VAR
+      nextErr: Err;
+
+    (* -------------------------------------- *)
+
+    PROCEDURE append(b : ErrBuff; n : Err) : ErrBuff;
+      VAR s : ErrBuff;
+	  i : INTEGER;
+    BEGIN
+      IF eTide = eLimit THEN (* must expand *)
+	s := b;
+        eLimit := eLimit * 2 + 1;
+	NEW(b, eLimit+1);
+	FOR i := 0 TO eTide DO b[i] := s[i] END;
+      END;
+      b[eTide] := n; INC(eTide); b[eTide] := NIL;
+      RETURN b;
+    END append;
+
+    (* -------------------------------------- *)
+
+  BEGIN
+    NEW(nextErr);
+    nextErr.num := eNum; 
+    nextErr.msg := mesg;
+    nextErr.col := colN;
+    nextErr.lin := linN; 
+    eBuffer := append(eBuffer, nextErr);
+  END StoreError;
+
+(* ============================================================ *)
+
+  PROCEDURE QuickSort(min, max : INTEGER);
+    VAR i,j : INTEGER;
+        key : INTEGER;
+	tmp : Err;
+   (* -------------------------------------------------	*)
+    PROCEDURE keyVal(i : INTEGER) : INTEGER;
+    BEGIN 
+      IF (eBuffer[i].col <= 0) OR (eBuffer[i].col >= listingWidth) THEN
+        eBuffer[i].col := listingMax;
+      END;
+      RETURN eBuffer[i].lin * 256 + eBuffer[i].col;
+    END keyVal;
+   (* -------------------------------------------------	*)
+  BEGIN
+    i := min; j := max;
+    key := keyVal((min+max) DIV 2);
+    REPEAT
+      WHILE keyVal(i) < key DO INC(i) END;
+      WHILE keyVal(j) > key DO DEC(j) END;
+      IF i <= j THEN
+        tmp := eBuffer[i]; eBuffer[i] := eBuffer[j]; eBuffer[j] := tmp; 
+	INC(i); DEC(j);
+      END;
+    UNTIL i > j;
+    IF min < j THEN QuickSort(min,j) END;
+    IF i < max THEN QuickSort(i,max) END;
+  END QuickSort;
+
+(* ============================================================ *)
+
+  PROCEDURE (h : ParseHandler)Report*(num,lin,col : INTEGER); 
+    VAR str : ARRAY 128 OF CHAR;
+	msg : Message;
+	idx : INTEGER;
+	len : INTEGER;
+  BEGIN
+    CASE num OF
+    |  0: str := "EOF expected";
+    |  1: str := "ident expected";
+    |  2: str := "integer expected";
+    |  3: str := "real expected";
+    |  4: str := "CharConstant expected";
+    |  5: str := "string expected";
+    |  6: str := "'*' expected";
+    |  7: str := "'-' expected";
+    |  8: str := "'!' expected";
+    |  9: str := "'.' expected";
+    | 10: str := "'=' expected";
+    | 11: str := "'ARRAY' expected";
+    | 12: str := "',' expected";
+    | 13: str := "'OF' expected";
+    | 14: str := "'ABSTRACT' expected";
+    | 15: str := "'EXTENSIBLE' expected";
+    | 16: str := "'LIMITED' expected";
+    | 17: str := "'RECORD' expected";
+    | 18: str := "'(' expected";
+    | 19: str := "'+' expected";
+    | 20: str := "')' expected";
+    | 21: str := "'END' expected";
+    | 22: str := "';' expected";
+    | 23: str := "':' expected";
+    | 24: str := "'POINTER' expected";
+    | 25: str := "'TO' expected";
+    | 26: str := "'PROCEDURE' expected";
+    | 27: str := "'[' expected";
+    | 28: str := "']' expected";
+    | 29: str := "'^' expected";
+    | 30: str := "'$' expected";
+    | 31: str := "'#' expected";
+    | 32: str := "'<' expected";
+    | 33: str := "'<=' expected";
+    | 34: str := "'>' expected";
+    | 35: str := "'>=' expected";
+    | 36: str := "'IN' expected";
+    | 37: str := "'IS' expected";
+    | 38: str := "'OR' expected";
+    | 39: str := "'/' expected";
+    | 40: str := "'DIV' expected";
+    | 41: str := "'MOD' expected";
+    | 42: str := "'&' expected";
+    | 43: str := "'NIL' expected";
+    | 44: str := "'~' expected";
+    | 45: str := "'{' expected";
+    | 46: str := "'}' expected";
+    | 47: str := "'..' expected";
+    | 48: str := "'EXIT' expected";
+    | 49: str := "'RETURN' expected";
+    | 50: str := "'NEW' expected";
+    | 51: str := "':=' expected";
+    | 52: str := "'IF' expected";
+    | 53: str := "'THEN' expected";
+    | 54: str := "'ELSIF' expected";
+    | 55: str := "'ELSE' expected";
+    | 56: str := "'CASE' expected";
+    | 57: str := "'|' expected";
+    | 58: str := "'WHILE' expected";
+    | 59: str := "'DO' expected";
+    | 60: str := "'REPEAT' expected";
+    | 61: str := "'UNTIL' expected";
+    | 62: str := "'FOR' expected";
+    | 63: str := "'BY' expected";
+    | 64: str := "'LOOP' expected";
+    | 65: str := "'WITH' expected";
+    | 66: str := "'EMPTY' expected";
+    | 67: str := "'BEGIN' expected";
+    | 68: str := "'CONST' expected";
+    | 69: str := "'TYPE' expected";
+    | 70: str := "'VAR' expected";
+    | 71: str := "'OUT' expected";
+    | 72: str := "'IMPORT' expected";
+    | 73: str := "'MODULE' expected";
+    | 74: str := "'CLOSE' expected";
+    | 75: str := "'JAVACLASS' expected";
+    | 76: str := "not expected";
+    | 77: str := "error in OtherAtts";
+    | 78: str := "error in MethAttributes";
+    | 79: str := "error in ProcedureStuff";
+    | 80: str := "this symbol not expected in StatementSequence";
+    | 81: str := "this symbol not expected in StatementSequence";
+    | 82: str := "error in IdentStatement";
+    | 83: str := "error in MulOperator";
+    | 84: str := "error in Factor";
+    | 85: str := "error in AddOperator";
+    | 86: str := "error in Relation";
+    | 87: str := "error in OptAttr";
+    | 88: str := "error in ProcedureType";
+    | 89: str := "error in Type";
+    | 90: str := "error in Module";
+    | 91: str := "invalid lexical token";
+    END;
+    len := LEN(str$);
+    NEW(msg, len+1);
+    FOR idx := 0 TO len-1 DO
+      msg[idx] := str[idx];
+    END;
+    msg[len] := 0X;
+    StoreError(num,lin,col,msg); 
+    INC(Scnr.errors);
+  END Report;
+
+(* ============================================================ *)
+
+  PROCEDURE (h : ParseHandler)RepSt1*(num       : INTEGER;
+				        IN s1   : ARRAY OF CHAR;
+					lin,col : INTEGER),EMPTY; 
+  PROCEDURE (h : ParseHandler)RepSt2*(num       : INTEGER;
+				       IN s1,s2 : ARRAY OF CHAR;
+					lin,col : INTEGER),EMPTY; 
+
+(* ============================================================ *)
+
+  PROCEDURE (h : SemanticHdlr)Report*(num,lin,col : INTEGER); 
+    VAR str : ARRAY 128 OF CHAR;
+	msg : Message;
+	idx : INTEGER;
+	len : INTEGER;
+  BEGIN
+    CASE num OF
+    (* ======================= ERRORS =========================	*)
+    |  -1: str := "invalid character";
+    |   0: RETURN;			(* just a placeholder *)
+    |   1: str := "Name after 'END' does not match";
+    |   2: str := "Identifier not known in this scope";
+    |   3: str := "Identifier not known in qualified scope";
+    |   4: str := "This name already known in this scope";
+    |   5: str := "This identifier is not a type name";
+    |   6: str := "This fieldname clashes with previous fieldname";
+    |   7: str := "Qualified identifier is not a type name";
+    |   8: str := "Not a record type, so you cannot select a field";
+    |   9: str := "Identifier is not a fieldname of the current type";
+
+    |  10: str := "Not an array type, so you cannot index into it";
+    |  11: str := "Too many indices for the dimension of the array";
+    |  12: str := "Not a pointer type, so you cannot dereference it";
+    |  13: str := "Not a procedure call or type guard";
+    |  14: str := "Basetype is not record or pointer type";
+    |  15: str := "Typename not a subtype of the current type";
+    |  16: str := "Basetype was not declared ABSTRACT or EXTENSIBLE";
+    |  17: str := "Not dynamically typed, so you cannot have type-guard";
+    |  18: str := "The type-guard must be a record type here";
+    |  19: str := "This constant token not known";
+
+    |  20: str := "Name of formal is not unique";
+    |  21: str := "Actual parameter is not compatible with formal type";
+    |  22: str := "Too few actual parameters";
+    |  23: str := "Too many actual parameters";
+    |  24: str := "Attempt to use a proper procedure when function needed";
+    |  25: str := "Expression is not constant";
+    |  26: str := "Range of the numerical type exceeded";
+    |  27: str := "String literal too long for destination type";
+    |  28: str := "Low value of range not in SET base-type range";
+    |  29: str := "High value of range not in SET base-type range";
+
+    |  30: str := "Low value of range cannot be greater than high value";
+    |  31: str := "Array index not of an integer type";
+    |  32: str := "Literal array index is outside array bounds";
+    |  33: str := "Literal value is not in SET base-type range";
+    |  34: str := "Typename is not a subtype of the type of destination";
+    |  35: str := "Expression is not of SET type";
+    |  36: str := "Expression is not of BOOLEAN type";
+    |  37: str := "Expression is not of an integer type";
+    |  38: str := "Expression is not of a numeric type";
+    |  39: str := "Overflow of negation of literal value";
+
+    |  40: str := "Expression is not of ARRAY type";
+    |  41: str := "Expression is not of character array type";
+    |  42: str := "Expression is not a standard function";
+    |  43: str := "Expression is not of character type";
+    |  44: str := "Literal expression is not in CHAR range";
+    |  45: str := "Expression is not of REAL type";
+    |  46: str := "Optional param of LEN must be a positive integer constant";
+    |  47: str := "LONG cannot be applied to this type";
+    |  48: str := "Name is not the name of a basic type";
+    |  49: str := "MAX and MIN not applicable to this type";
+
+    |  50: str := "ORD only applies to SET and CHAR types";
+    |  51: str := "SHORT cannot be applied to this type";
+    |  52: str := "Both operands must be numeric, SET or CHAR types";
+    |  53: str := "Character constant outside CHAR range";
+    |  54: str := "Bad conversion type";
+    |  55: str := "Numeric overflow in constant evaluation";
+    |  56: str := "BITS only applies to expressions of type INTEGER";
+    |  57: str := "Operands in '=' or '#' test are not type compatible";
+    |  58: str := "EXIT is only permitted inside a LOOP";
+    |  59: str := "BY expression must be a constant expression";
+
+    |  60: str := "Case label is not an integer or character constant";
+    |  61: str := "Method attributes don't apply to ordinary procedure";
+    |  62: str := "Forward type-bound method elaborated as static procedure";
+    |  63: str := "Forward static procedure elaborated as type-bound method";
+    |  64: str := "Forward method had different receiver mode";
+    |  65: str := "Forward procedure had non-matching formal types";
+    |  66: str := "Forward method had different attributes";
+    |  67: str := "Variable cannot have open array type";
+    |  68: str := "Arrays must have at least one element";
+    |  69: str := "Fixed array cannot have open array element type";
+
+    |  70: str := "Forward procedure had different names for formals";
+    |  71: str := "This imported type is LIMITED, and cannot be instantiated";
+    |  72: str := "Forward procedure was not elaborated by end of block";
+    |  73: str := "RETURN is not legal in a module body";
+    |  74: str := "This is a proper procedure, it cannot return a value";
+    |  75: str := "This is a function, it must return a value";
+    |  76: str := "RETURN value not assign-compatible with function type";
+    |  77: str := "Actual for VAR formal must be a writeable variable";
+    |  78: str := "Functions cannot return record types";
+    |  79: str := "Functions cannot return array types";
+
+    |  80: str := "This designator is not the name of a proper procedure";
+    |  81: str := "FOR loops cannot have zero step size";
+    |  82: str := "This fieldname clashes with an inherited fieldname";
+    |  83: str := "Expression not assign-compatible with destination";
+    |  84: str := "FOR loop control variable must be of integer type";
+    |  85: str := "Identifier is not the name of a variable";
+    |  86: str := "Typename is not an extension of the variable type";
+    |  87: str := "The selected identifier is not of dynamic type";
+    |  88: str := "Case select expression is not of integer or CHAR type";
+    |  89: str := "Case select value is duplicated for this statement";
+
+    |  90: str := "Variables of ABSTRACT type cannot be instantiated";
+    |  91: str := "Optional param of ASSERT must be an integer constant";
+    |  92: str := "This is not a standard procedure";
+    |  93: str := "The param of HALT must be a constant integer";
+    |  94: str := "This variable is not of pointer or vector type";
+    |  95: str := "NEW requires a length param for open arrays and vectors";
+    |  96: str := "NEW only applies to pointers to records and arrays";
+    |  97: str := "This call of NEW has too many lengths specified";
+    |  98: str := "Length for an open array NEW must be an integer type";
+    |  99: str := "Length only applies to open arrays and vectors";
+
+    | 100: str := "This call of NEW needs more length params";
+    | 101: str := "Numeric literal is too large, even for long type";
+    | 102: str := "Only ABSTRACT basetypes can have abstract extensions";
+    | 103: str := "This expression is read-only";
+    | 104: str := "Receiver type must be a record, or pointer to record";
+    | 105: str := "This method is not a redefinition, you must use NEW";
+    | 106: str := "This method is a redefinition, you must not use NEW";
+    | 107: str := "Receivers of record type must be VAR or IN mode";
+    | 108: str := "Final method cannot be redefined";
+    | 109: str := "Only ABSTRACT method can have ABSTRACT redefinition";
+
+    | 110: str := "This type has ABSTRACT method, must be ABSTRACT";
+    | 111: str := "Type has NEW,EMPTY method, must be ABSTRACT or EXTENSIBLE";
+    | 112: str := "Only EMPTY or ABSTRACT method can be redefined EMPTY";
+    | 113: str := "This redefinition of exported method must be exported";
+    | 114: str := "This is an EMPTY method, and cannot have OUT parameters";
+    | 115: str := "This is an EMPTY method, and cannot return a value";
+    | 116: str := "Redefined method must have consistent return type";
+    | 117: str := "Type has EXTENSIBLE method, must be ABSTRACT or EXTENSIBLE";
+    | 118: str := "Empty or abstract methods cannot be called by super-call";
+    | 119: str := "Super-call is invalid here";
+
+    | 120: str := "There is no overridden method with this name";
+    | 121: str := "Not all abstract methods were implemented";
+    | 122: str := "This procedure is not at module scope, cannot be a method";
+    | 123: str := "There is a cycle in the base-type declarations";
+    | 124: str := "There is a cycle in the field-type declarations";
+    | 125: str := "Cycle in typename equivalence declarations";
+    | 126: str := "There is a cycle in the array element type declarations";
+    | 127: str := "This is an implement-only method, and cannot be called";
+    | 128: str := "Only declarations at module level can be exported";
+    | 129: str := "Cannot open symbol file";
+
+    | 130: str := "Bad magic number in symbol file";
+    | 131: str := "This type is an INTERFACE, and cannot be instantiated";
+    | 132: str := "Corrupted symbol file";
+    | 133: str := "Inconsistent module keys";
+    | 134: str := "Types can only be public or fully private";
+    | 135: str := "This variable may be uninitialized";
+    | 136: str := "Not all paths to END contain a RETURN statement";
+    | 137: str := "This type tries to directly include itself";
+    | 138: str := "Not all paths to END in RESCUE contain a RETURN statement";
+    | 139: str := "Not all OUT parameters have been assigned to";
+
+    | 140: str := "Pointer bound type can only be RECORD or ARRAY";
+    | 141: str := "GPCP restriction: select expression cannot be LONGINT";
+    | 142: str := "Cannot assign entire open array";
+    | 143: str := "Cannot assign entire extensible or abstract record";
+    | 144: str := "Foreign modules must be compiled with '-special'";
+    | 145: str := "This type tries to indirectly include itself";
+    | 146: str := "Constructors are declared without receiver";
+    | 147: str := "Multiple supertype constructors match these parameters";
+    | 148: str := "This type has another constructor with equal signature";
+    | 149: str := "This procedure needs parameters";
+
+    | 150: str := "Parameter types of exported procedures must be exported";
+    | 151: str := "Return types of exported procedures must be exported";
+    | 152: str := "Bound type of foreign reference type cannot be assigned";
+    | 153: str := "Bound type of foreign reference type cannot be value param";
+    | 154: str := "It is not possible to extend an interface type";
+    | 155: str := "NEW illegal unless foreign supertype has no-arg constructor";
+    | 156: str := "Interfaces can't extend anything. Leave blank or use ANYREC";
+    | 157: str := "Only extensions of Foreign classes can implement interfaces";
+    | 158: str := "Additional base types must be interface types";
+    | 159: str := "Not all interface methods were implemented";
+
+    | 160: str := "Inherited procedure had non-matching formal types";
+    | 161: str := "Only foreign procs and fields can have protected mode";
+    | 162: str := "This name only accessible in extensions of defining type";
+    | 163: str := "Interface implementation has wrong export mode";
+(**)| 164: str := "Non-locally accessed variable may be uninitialized";
+    | 165: str := "This procedure cannot be used as a procedure value";
+    | 166: str := "Super calls are only valid on the current receiver";
+    | 167: str := "SIZE is not meaningful in this implementation";
+    | 168: str := "Character literal outside SHORTCHAR range";
+    | 169: str := "Module exporting this type is not imported";
+
+    | 170: str := "This module has already been directly imported";
+    | 171: str := "Invalid binary operation on these types";
+    | 172: str := "Name clash in imported scope";
+    | 173: str := "This module indirectly imported with different key";
+    | 174: str := "Actual for IN formal must be record, array or string";
+    | 175: str := "The module exporting this name has not been imported";
+    | 176: str := "The current type is opaque and cannot be selected further";
+    | 177: str := "File creation error";
+    | 178: str := "This record field is read-only";
+    | 179: str := "This IN parameter is read-only";
+
+    | 180: str := "This variable is read-only";
+    | 181: str := "This identifier is read-only";
+    | 182: str := "Attempt to use a function when a proper procedure needed";
+    | 183: str := "This record is private, you cannot export this field";
+    | 184: str := "This record is readonly, this field cannot be public";
+    | 185: str := "Static members can only be defined with -special";
+    | 186: str := 'Ids with "$", "@" or "`" can only be defined with -special';
+    | 187: str := "Idents escaped with ` must have length >= 2";
+    | 188: str := "Methods of INTERFACE types must be ABSTRACT";
+    | 189: str := "Non-local access to byref param of value type";
+
+    | 190: str := "Temporary restriction: non-locals not allowed";
+    | 191: str := "Temporary restriction: only name equivalence here";
+    | 192: str := "Only '=' or ':' can go here";
+    | 193: str := "THROW needs a string or native exception object";
+    | 194: str := 'Only "UNCHECKED_ARITHMETIC" can go here';
+    | 195: str := "NEW method cannot be exported if receiver type is private";
+    | 196: str := "Only static fields can select on a type-name";
+    | 197: str := "Only static methods can select on a type-name";
+    | 198: str := "Static fields can only select on a type-name";
+    | 199: str := "Static methods can only select on a type-name";
+
+    | 200: str := "Constructors cannot be declared for imported types";
+    | 201: str := "Constructors must return POINTER TO RECORD type";
+    | 202: str := "Base type does not have a matching constructor";
+    | 203: str := "Base type does not allow a no-arg constructor";
+    | 204: str := "Constructors only allowed for extensions of foreign types";
+    | 205: str := "Methods can only be declared for local record types";
+    | 206: str := "Receivers of pointer type must have value mode";
+    | 207: str := "Feature with this name already known in binding scope";
+    | 208: str := "EVENT types only valid for .NET target";
+    | 209: str := "Events must have a valid formal parameter list";
+
+    | 210: str := "REGISTER expects an EVENT type here";
+    | 211: str := "Only procedure literals allowed here";
+    | 212: str := "Event types cannot be local to procedures";
+    | 213: str := "Temporary restriction: no proc. variables with JVM";
+    | 214: str := "Interface types cannot be anonymous";
+    | 215: str := "Interface types must be exported";
+    | 216: str := "Interface methods must be exported";
+    | 217: str := "Covariant OUT parameters unsafe removed from language";
+    | 218: str := "No procedure of this name with matching parameters";
+    | 219: str := "Multiple overloaded procedure signatures match this call";
+
+    | 220: RETURN;                                  (* BEWARE PREMATURE EXIT *)
+    | 221: str := "Non-standard construct, not allowed with /strict";
+    | 222: str := "This is not a value: thus cannot end with a type guard";
+    | 223: str := "Override of imp-only in exported type must be imp-only";
+    | 224: str := "This designator is not a procedure or a function call";
+    | 225: str := "Non-empty constructors can only return SELF";
+    | 226: str := "USHORT cannot be applied to this type";
+    | 227: str := "Cannot import SYSTEM without /unsafe option";
+    | 228: str := "Cannot import SYSTEM unless target=net";
+    | 229: str := "Designator is not of VECTOR type";
+
+    | 230: str := "Type is incompatible with element type";
+    | 231: str := "Vectors are always one-dimensional only";
+    | 232: str := 'Hex constant too big, use suffix "L" instead';
+    | 233: str := "Literal constant too big, even for LONGINT";
+    | 234: str := "Extension of LIMITED type must be limited";
+    | 235: str := "LIMITED types can only be extended in the same module";
+
+    | 298: str := "ILASM failed to assemble IL file";
+    | 299: str := "Compiler raised an internal exception";
+    (* ===================== END ERRORS =======================	*)
+    (* ====================== WARNINGS ========================	*)
+    | 300: str := "Warning: Super calls are deprecated";
+    | 301: str := "Warning: Procedure variables are deprecated";
+    | 302: str := "Warning: Non-local variable access here";
+    | 303: str := "Warning: Numeric literal is not in the SET range [0 .. 31]";
+    | 304: str := "Warning: This procedure is not exported, called or assigned";
+    | 305: str := "Warning: Another constructor has an equal signature";
+    | 306: str := "Warning: Covariant OUT parameters unsafe when aliassed";
+    | 307: str := "Warning: Multiple overloaded procedure signatures match this call";
+    | 308: str := "Warning: Default static class has name clash";
+    | 309: str := "Warning: Looking for an automatically renamed module";
+
+    | 310,
+      311: str := "Warning: This variable is accessed from nested procedure";
+    | 312,
+      313: RETURN;                                  (* BEWARE PREMATURE EXIT *)
+    | 314: str := "The anonymous record type is incomptible with all values";
+    | 315: str := "The anonymous array type is incomptible with all values";
+    | 316: str := "This pointer type may still have its default NIL value";
+    | 317: str := "Empty CASE statement will trap if control reaches here";
+    | 318: str := "Empty WITH statement will trap if control reaches here";
+    (* ==================== END WARNINGS ====================== *)
+    ELSE
+      str := "Semantic error: " + LitValue.intToCharOpen(num)^;	
+    END;
+    len := LEN(str$);
+    NEW(msg, len+1);
+    FOR idx := 0 TO len-1 DO
+      msg[idx] := str[idx];
+    END;
+    msg[len] := 0X;
+    IF num < 300 THEN 
+      INC(Scnr.errors); 
+      StoreError(num,lin,col,msg); 
+    ELSE 
+      INC(Scnr.warnings); 
+      IF ~nowarn THEN StoreError(num,lin,col,msg); END; 
+    END;
+
+    IF prompt THEN
+      IF num < 300 THEN 
+        Console.WriteString("Error");
+      ELSE 
+        Console.WriteString("Warning");
+      END;
+      Console.WriteInt(num,0);
+      Console.WriteString("@ line:");
+      Console.WriteInt(lin,0);
+      Console.WriteString(", col:");
+      Console.WriteInt(col,0);
+      Console.WriteLn;
+      Console.WriteString(str);
+      Console.WriteLn;
+    END;
+
+  END Report;
+
+(* ============================================================ *)
+
+  PROCEDURE (h : SemanticHdlr)RepSt1*(num     : INTEGER;
+				      IN s1   : ARRAY OF CHAR;
+				      lin,col : INTEGER); 
+    VAR msg : Message;
+  BEGIN
+    CASE num OF
+    |   0: msg := LitValue.strToCharOpen("Expected: END " + s1);
+    |   1: msg := LitValue.strToCharOpen("Expected: " + s1);
+    |  89: msg := LitValue.strToCharOpen("Duplicated selector values <" 
+						+ s1 + ">");
+    |   9,
+      169: msg := LitValue.strToCharOpen("Current type was <" 
+			+ s1 + '>');
+    | 117: msg := LitValue.strToCharOpen("Type <" 
+			+ s1 + "> must be extensible");
+    | 121: msg := LitValue.strToCharOpen("Missing methods <" + s1 + '>');
+    | 145: msg := LitValue.strToCharOpen("Types on cycle <" + s1 + '>');
+    | 129, 
+      130, 
+      132: msg := LitValue.strToCharOpen("Filename <" + s1 + '>');
+    | 133: msg := LitValue.strToCharOpen("Module <" 
+			+ s1 + "> already imported with different key");
+    | 138: msg := LitValue.strToCharOpen('<' 
+			+ s1 + '> not assigned before "RETURN"');
+    | 139: msg := LitValue.strToCharOpen('<' 
+			+ s1 + '> not assigned before end of procedure');
+    | 154: msg := LitValue.strToCharOpen('<' 
+			+ s1 + "> is a Foreign interface type");
+    | 157: msg := LitValue.strToCharOpen('<' 
+			+ s1 + "> is not a Foreign type");
+    | 158: msg := LitValue.strToCharOpen('<' 
+			+ s1 + "> is not a foreign language interface type");
+    | 159: msg := LitValue.strToCharOpen("Missing interface methods <" 
+						+ s1 + '>');
+    | 162: msg := LitValue.strToCharOpen('<' 
+			+ s1 + "> is a protected, foreign-language feature");
+    | 164: msg := LitValue.strToCharOpen('<' 
+			+ s1 + "> not assigned before this call");
+    | 172: msg := LitValue.strToCharOpen('Name <' 
+			+ s1 + '> clashes in imported scope');
+    | 175,
+      176: msg := LitValue.strToCharOpen("Module " 
+			+ '<' + s1 + "> is not imported");
+    | 189: msg := LitValue.strToCharOpen('Non-local access to <' 
+			+ s1 + '> cannot be verified on .NET');
+    | 205,
+      207: msg := LitValue.strToCharOpen(
+		       "Binding scope of feature is record type <" + s1 + ">");
+    | 299: msg := LitValue.strToCharOpen("Exception: " + s1);
+    | 308: msg := LitValue.strToCharOpen(
+                       "Renaming static class to <" + s1 + ">");
+    | 310: msg := LitValue.strToCharOpen('Access to <' 
+                       + s1 + '> has copying not reference semantics');
+    | 311: msg := LitValue.strToCharOpen('Access to variable <' 
+		       + s1 + '> will be inefficient');
+    | 220,
+      312: msg := LitValue.strToCharOpen("Matches with - " + s1);
+    | 313: msg := LitValue.strToCharOpen("Bound to - " + s1);
+    END;
+    IF ~nowarn OR                        (* If warnings are on OR  *)
+       (num < 300) THEN                  (* this is an error then  *)
+      StoreError(num,lin,0,msg);         (* (1) Store THIS message *)
+      h.Report(num,lin,col);             (* (2) Generate other msg *)
+    END;
+(*
+ *  IF (num # 251) & (num # 252) THEN 
+ *    StoreError(num,lin,col,msg); 
+ *    h.Report(num,lin,col);
+ *  ELSIF ~nowarn THEN
+ *    StoreError(num,lin,col,msg); 
+ *  END;
+ *)
+  END RepSt1;
+
+(* ============================================================ *)
+
+  PROCEDURE (h : SemanticHdlr)RepSt2*(num      : INTEGER;
+				      IN s1,s2 : ARRAY OF CHAR;
+				      lin,col  : INTEGER); 
+(*
+ *  VAR str : ARRAY 128 OF CHAR;
+ *      msg : Message;
+ *      idx : INTEGER;
+ *      len : INTEGER;
+ *)
+    VAR msg : Message;
+  BEGIN
+    CASE num OF
+    |  21,
+      217,
+      306: msg := LitValue.strToCharOpen(
+                  "Actual par-type was " + s1 + ", Formal type was " + s2);
+    |  76: msg := LitValue.strToCharOpen(
+                  "Expr-type was " + s2 + ", should be " + s1);
+    |  57,
+       83: msg := LitValue.strToCharOpen(
+                  "LHS type was " + s1 + ", RHS type was " + s2);
+    | 116: msg := LitValue.strToCharOpen(
+                  "Inherited retType is " + s1 + ", this retType " + s2);
+    | 131: msg := LitValue.strToCharOpen(
+                  "Module name in file <" + s1 + ".cps> was <" + s2 + '>');
+    | 172: msg := LitValue.strToCharOpen(
+                  'Name <' + s1 + '> clashes in scope <' + s2 + '>');
+    | 230: msg := LitValue.strToCharOpen(
+                  "Expression type is " + s2 + ", element type is " + s1);
+    | 309: msg := LitValue.strToCharOpen(
+                  'Looking for module "' + s1 + '" in file <' + s2 + '>');
+    END;
+(*
+ *  len := LEN(str$);
+ *  NEW(msg, len+1);
+ *  FOR idx := 0 TO len-1 DO
+ *    msg[idx] := str[idx];
+ *  END;
+ *  msg[len] := 0X;
+ *)
+    StoreError(num,lin,col,msg); 
+    h.Report(num,lin,col);
+  END RepSt2;
+
+(* ============================================================ *)
+
+    PROCEDURE GetLine (VAR pos  : INTEGER;
+                       OUT line : ARRAY OF CHAR;
+                       OUT eof  : BOOLEAN);
+    (** Read a source line. Return empty line if eof *)
+      CONST
+        cr  = 0DX;
+        lf  = 0AX;
+        tab = 09X;
+      VAR
+        ch: CHAR;
+        i:  INTEGER;
+      BEGIN
+        ch := Scnr.charAt(pos); INC(pos);
+        i := 0; 
+	eof := FALSE;
+        WHILE (ch # lf) & (ch # 0X) DO 
+          IF ch = cr THEN (* skip *)
+          ELSIF ch = tab THEN 
+	    REPEAT line[MIN(i,listingMax)] := ' '; INC(i) UNTIL i MOD 8 = 0;
+	  ELSE
+            line[MIN(i,listingMax)] := ch; INC(i);
+	  END;
+          ch := Scnr.charAt(pos); INC(pos);
+        END;
+        eof := (i = 0) & (ch = 0X); line[MIN(i,listingMax)] := 0X;
+      END GetLine;
+
+(* ============================================================ *)
+
+    PROCEDURE PrintErr(IN desc : ErrDesc);
+    (** Print an error message *)
+      VAR mLen : INTEGER;
+	  indx : INTEGER;
+    BEGIN
+      GPText.WriteString(Scnr.lst, "**** ");
+      mLen := LEN(desc.msg$);
+      IF desc.col = listingMax THEN (* write field of width (col-2) *)
+        GPText.WriteString(Scnr.lst, desc.msg);
+      ELSIF mLen < desc.col-1 THEN (* write field of width (col-2) *)
+	GPText.WriteFiller(Scnr.lst, desc.msg, "-", desc.col-1);
+	GPText.Write(Scnr.lst, "^");
+      ELSIF mLen + desc.col + 5 < consoleWidth THEN
+	GPText.WriteFiller(Scnr.lst, "", "-", desc.col-1);
+        GPText.WriteString(Scnr.lst, "^ ");
+        GPText.WriteString(Scnr.lst, desc.msg);
+      ELSE
+	GPText.WriteFiller(Scnr.lst, "", "-", desc.col-1);
+	GPText.Write(Scnr.lst, "^");
+	GPText.WriteLn(Scnr.lst);
+	GPText.WriteString(Scnr.lst, "**** ");
+        GPText.WriteString(Scnr.lst, desc.msg);
+      END; 
+      GPText.WriteLn(Scnr.lst);
+    END PrintErr;
+
+(* ============================================================ *)
+
+    PROCEDURE Display (IN desc : ErrDesc);
+    (** Display an error message *)
+      VAR mLen : INTEGER;
+	  indx : INTEGER;
+    BEGIN
+      Console.WriteString("**** ");
+      mLen := LEN(desc.msg$);
+      IF desc.col = listingMax THEN
+        Console.WriteString(desc.msg);
+      ELSIF mLen < desc.col-1 THEN
+	Console.WriteString(desc.msg);
+	FOR indx := mLen TO desc.col-2 DO Console.Write("-") END;
+	Console.Write("^");
+      ELSIF mLen + desc.col + 5 < consoleWidth THEN
+	FOR indx := 2 TO desc.col DO Console.Write("-") END;
+        Console.WriteString("^ ");
+        Console.WriteString(desc.msg);
+      ELSE
+	FOR indx := 2 TO desc.col DO Console.Write("-") END;
+	Console.Write("^");
+	Console.WriteLn;
+	Console.WriteString("**** ");
+        Console.WriteString(desc.msg);
+      END; 
+      Console.WriteLn;
+    END Display;
+
+(* ============================================================ *)
+
+    PROCEDURE DisplayVS (IN desc : ErrDesc);
+    (** Display an error message for Visual Studio *)
+      VAR mLen : INTEGER;
+	  indx : INTEGER;
+    BEGIN
+      Console.WriteString(srcNam);
+      Console.Write("(");
+      Console.WriteInt(desc.lin,1);
+      Console.Write(",");
+      Console.WriteInt(desc.col,1);
+      Console.WriteString(") : ");
+      IF desc.num < 300 THEN
+        Console.WriteString("error : ");
+      ELSE
+        Console.WriteString("warning : ");
+      END;
+      Console.WriteString(desc.msg);
+      Console.WriteLn; 
+    END DisplayVS;
+
+(* ============================================================ *)
+
+    PROCEDURE DisplayXMLHeader ();
+    BEGIN
+      Console.WriteString('<?xml version="1.0"?>');
+      Console.WriteLn;
+      Console.WriteString('<compilererrors errorsContained="yes">');
+      Console.WriteLn;
+    END DisplayXMLHeader;
+
+    PROCEDURE DisplayXMLEnd ();
+    BEGIN
+      Console.WriteString('</compilererrors>');
+      Console.WriteLn;
+    END DisplayXMLEnd;
+
+    PROCEDURE DisplayXML (IN desc : ErrDesc);
+    (** Display an error message in xml format (for eclipse) *)
+    (*  <?xml version="1.0"?>
+     *  <compilererrors errorsContained="yes">
+     *    <error>
+     *      <line> 1 </line>
+     *      <position> 34 </position>
+     *      <description> ; expected </description>
+     *    </error>
+     * ...
+     *  </compilererrors>
+     *)
+          
+      VAR mLen : INTEGER;
+	  indx : INTEGER;
+        isWarn : BOOLEAN;
+    BEGIN
+      isWarn := desc.num >= 300;
+      IF isWarn THEN
+        Console.WriteString("  <warning> "); 
+      ELSE
+        Console.WriteString("  <error> "); 
+      END;
+      Console.WriteLn; 
+      Console.WriteString("    <line> ");  
+      Console.WriteInt(desc.lin,1);
+      Console.WriteString(" </line>"); Console.WriteLn; 
+      Console.WriteString("    <position> ");  
+      Console.WriteInt(desc.col,1);
+      Console.WriteString(" </position>"); Console.WriteLn; 
+      Console.WriteString("    <description> ");  
+      IF isWarn THEN
+        Console.WriteString("warning : ");
+      ELSE
+        Console.WriteString("error : ");
+      END;
+      Console.WriteString(desc.msg);
+      Console.WriteString(" </description> ");  Console.WriteLn; 
+      IF isWarn THEN
+        Console.WriteString("  </warning> "); 
+      ELSE
+        Console.WriteString("  </error> "); 
+      END;
+      Console.WriteLn; 
+    END DisplayXML;
+
+(* ============================================================ *)
+
+    PROCEDURE PrintLine(n : INTEGER; IN l : ARRAY OF CHAR);
+    BEGIN
+      GPText.WriteInt(Scnr.lst, n, 4); GPText.Write(Scnr.lst, " ");
+      GPText.WriteString(Scnr.lst, l); GPText.WriteLn(Scnr.lst);
+    END PrintLine;
+
+(* ============================================================ *)
+
+    PROCEDURE DisplayLn(n : INTEGER; IN l : ARRAY OF CHAR);
+    BEGIN
+      Console.WriteInt(n, 4); Console.Write(" ");
+      Console.WriteString(l); Console.WriteLn;
+    END DisplayLn;
+
+(* ============================================================ *)
+
+    PROCEDURE PrintListing*(list : BOOLEAN);
+    (** Print a source listing with error messages *)
+      VAR
+        nextErr : Err;		(* next error descriptor *)
+	nextLin : INTEGER;	(* line num of nextErr   *)
+        eof     : BOOLEAN;	(* end of file found     *)
+        lnr     : INTEGER;	(* current line number   *)
+	errC    : INTEGER;	(* current error index   *)
+        srcPos  : INTEGER;	(* postion in sourceFile *)
+        line    : ARRAY listingWidth OF CHAR;
+      BEGIN
+        IF xmlErrors THEN DisplayXMLHeader(); END;
+	nextLin := 0;
+	IF eTide > 0 THEN QuickSort(0, eTide-1) END;
+	IF list THEN
+	  GPText.WriteString(Scnr.lst, "Listing:");
+	  GPText.WriteLn(Scnr.lst); GPText.WriteLn(Scnr.lst);
+	END;
+        srcPos := 0; nextErr := eBuffer[0];
+        GetLine(srcPos, line, eof); lnr := 1; errC := 0;
+        WHILE ~ eof DO
+	  IF nextErr # NIL THEN nextLin := nextErr.lin END;
+	  IF list THEN PrintLine(lnr, line) END;
+	  IF ~forVisualStudio & ~xmlErrors & (~list OR (lnr = nextLin)) THEN 
+            DisplayLn(lnr, line) 
+          END;
+          WHILE (nextErr # NIL) & (nextErr.lin = lnr) DO
+	    IF list THEN PrintErr(nextErr) END; 
+            IF forVisualStudio THEN
+              DisplayVS(nextErr);
+            ELSIF xmlErrors THEN
+              DisplayXML(nextErr);
+            ELSE
+	      Display(nextErr);
+            END;
+	    INC(errC);
+            nextErr := eBuffer[errC];
+          END;
+          GetLine(srcPos, line, eof); INC(lnr);
+        END;
+        WHILE nextErr # NIL DO
+          IF list THEN PrintErr(nextErr) END; 
+          IF forVisualStudio THEN
+            DisplayVS(nextErr);
+          ELSE
+	    Display(nextErr);
+          END;
+	  INC(errC);
+          nextErr := eBuffer[errC];
+        END;
+(*
+ *	IF list THEN
+ *	  GPText.WriteLn(Scnr.lst);
+ *     	  GPText.WriteInt(Scnr.lst, errC, 5); 
+ *        GPText.WriteString(Scnr.lst, " error");
+ *        IF errC # 1 THEN GPText.Write(Scnr.lst, "s") END;
+ *        GPText.WriteLn(Scnr.lst); 
+ *        GPText.WriteLn(Scnr.lst); 
+ *        GPText.WriteLn(Scnr.lst);
+ *	END;
+ *)
+        IF list THEN
+	  GPText.WriteLn(Scnr.lst);
+          GPText.WriteString(Scnr.lst, "There were: ");
+          IF Scnr.errors = 0 THEN
+            GPText.WriteString(Scnr.lst, "No errors");
+          ELSE
+       	    GPText.WriteInt(Scnr.lst, Scnr.errors, 0); 
+            GPText.WriteString(Scnr.lst, " error");
+            IF Scnr.errors # 1 THEN GPText.Write(Scnr.lst, "s") END;
+          END;
+          GPText.WriteString(Scnr.lst, ", and ");
+          IF Scnr.warnings = 0 THEN
+            GPText.WriteString(Scnr.lst, "No warnings");
+          ELSE
+       	    GPText.WriteInt(Scnr.lst, Scnr.warnings, 0); 
+            GPText.WriteString(Scnr.lst, " warning");
+            IF Scnr.warnings # 1 THEN GPText.Write(Scnr.lst, "s") END;
+          END;
+          GPText.WriteLn(Scnr.lst); 
+          GPText.WriteLn(Scnr.lst); 
+          GPText.WriteLn(Scnr.lst); 
+        END;
+        IF xmlErrors THEN DisplayXMLEnd(); END;
+      END PrintListing;
+
+      PROCEDURE ResetErrorList*();
+      BEGIN
+	eTide := 0;
+	eBuffer[0] := NIL;
+      END ResetErrorList;
+
+(* ============================================================ *)
+
+      PROCEDURE Init*; 
+      BEGIN
+	NEW(parsHdlr); Scnr.ParseErr := parsHdlr;
+	NEW(semaHdlr); Scnr.SemError := semaHdlr;
+      END Init;
+
+(* ============================================================ *)
+
+    PROCEDURE SetSrcNam* (IN nam : ARRAY OF CHAR);
+    BEGIN
+      GPText.Assign(nam,srcNam);
+    END SetSrcNam;
+
+(* ============================================================ *)
+BEGIN
+  NEW(eBuffer, 8); eBuffer[0] := NIL; eLimit := 7; eTide := 0;
+  prompt := FALSE;
+  nowarn := FALSE;
+  forVisualStudio := FALSE;
+END CPascalErrors.
+(* ============================================================ *)

gpcp/CPascalG.cp

@@ -0,0 +1,26 @@
+MODULE CPascalG;
+  IMPORT GPCPcopyright;
+
+CONST
+  EOFSYM* = 0;  identSym* = 1;  integerSym* = 2;  realSym* = 3;
+  CharConstantSym* = 4;  stringSym* = 5;  starSym* = 6;  minusSym* = 7;
+  bangSym* = 8;  pointSym* = 9;  equalSym* = 10;  ARRAYSym* = 11;  
+  commaSym* = 12; OFSym* = 13;  ABSTRACTSym* = 14;  EXTENSIBLESym* = 15;  
+  LIMITEDSym* = 16; RECORDSym* = 17;  lparenSym* = 18;  plusSym* = 19;  
+  rparenSym* = 20;  ENDSym* = 21; semicolonSym* = 22;  colonSym* = 23;  
+  POINTERSym* = 24;  TOSym* = 25; PROCEDURESym* = 26;  lbrackSym* = 27;  
+  rbrackSym* = 28;  uparrowSym* = 29; dollarSym* = 30;  hashSym* = 31;  
+  lessSym* = 32;  lessequalSym* = 33; greaterSym* = 34;  greaterequalSym* = 35;
+  INSym* = 36;  ISSym* = 37;  ORSym* = 38; slashSym* = 39;  DIVSym* = 40;  
+  MODSym* = 41;  andSym* = 42;  NILSym* = 43; tildeSym* = 44;  lbraceSym* = 45;
+  rbraceSym* = 46;  pointpointSym* = 47; EXITSym* = 48;  RETURNSym* = 49;  
+  NEWSym* = 50;  colonequalSym* = 51;  IFSym* = 52; THENSym* = 53;  
+  ELSIFSym* = 54;  ELSESym* = 55;  CASESym* = 56;  barSym* = 57; WHILESym* = 58;
+  DOSym* = 59;  REPEATSym* = 60;  UNTILSym* = 61;  FORSym* = 62; BYSym* = 63;  
+  LOOPSym* = 64;  WITHSym* = 65;  EMPTYSym* = 66;  BEGINSym* = 67; 
+  CONSTSym* = 68;  TYPESym* = 69;  VARSym* = 70;  OUTSym* = 71;  
+  IMPORTSym* = 72; MODULESym* = 73;  CLOSESym* = 74;  
+  INTERFACESym* = 75;  RESCUESym* = 76; 
+  STATICSym* = 77; ENUMSym* = 78; DIV0Sym* = 79; REM0Sym* = 80;
+  EVENTSym* = 81; VECTORSym* = 82; NOSYM* = 83; idVariant* = 84; 
+END CPascalG.

gpcp/CPascalP.cp

@@ -0,0 +1,3493 @@
+(* ==================================================================== *)
+(*                                                                      *)
+(*  Parser Module for the Gardens Point Component Pascal Compiler.      *)
+(*      Copyright (c) John Gough 1999, 2000.                            *)
+(*      This module was extensively modified from the parser            *)
+(*      automatically produced by the M2 version of COCO/R, using       *)
+(*      the CPascal.atg grammar used for the JVM version of GPCP.       *)
+(*                                                                      *)
+(* ==================================================================== *)
+
+MODULE CPascalP;
+
+  IMPORT
+        GPCPcopyright,
+        RTS,
+        FileNames,
+        ForeignName,
+        LitValue,
+        C := Console,
+        T := CPascalG,
+        S := CPascalS,
+        G := CompState,
+        Sy := Symbols,
+        Id := IdDesc,
+        Ty := TypeDesc,
+        Xp := ExprDesc,
+        Bi := Builtin,
+        StatDesc,
+        Visitor,
+        OldSymFileRW,
+        NewSymFileRW,
+        NameHash;
+
+(* ==================================================================== *)
+
+CONST
+  maxT       = 82;
+  minErrDist =  2;  (* minimal distance (good tokens) between two errors *)
+  setsize    = 32;
+  noError    = -1;
+
+TYPE
+  SymbolSet = ARRAY (maxT DIV setsize + 1) OF SET; (* 0 .. 2 *)
+
+VAR
+  symSet  : ARRAY 13 OF SymbolSet; (*symSet[0] = allSyncSyms*)
+  errDist : INTEGER;   (* number of symbols recognized since last error *)
+  token   : S.Token;   (* current input symbol   *)
+  nextT   : S.Token;   (* lookahead input symbol *)
+  comma   : LitValue.CharOpen;
+
+(* ==================================================================== *)
+(*                         Utilities                                    *)
+(* ==================================================================== *)
+
+  PROCEDURE  Error (errNo: INTEGER);
+  BEGIN
+    IF errDist >= minErrDist THEN
+      S.ParseErr.Report(errNo, nextT.lin, nextT.col);
+    END;
+    IF errNo < 300 THEN errDist := 0 END;
+  END Error;
+
+(* ==================================================================== *)
+
+  PROCEDURE  SemError(errNo: INTEGER);
+  BEGIN
+    IF errDist >= minErrDist THEN
+      S.SemError.Report(errNo, token.lin, token.col);
+    END;
+    IF errNo < 300 THEN errDist := 0 END;
+  END SemError;
+
+(* ==================================================================== *)
+
+  PROCEDURE  SemErrorS1(errNo: INTEGER; IN str : ARRAY OF CHAR);
+  BEGIN
+    IF errDist >= minErrDist THEN
+      S.SemError.RepSt1(errNo, str, token.lin, token.col);
+    END;
+    IF errNo < 300 THEN errDist := 0 END;
+  END SemErrorS1;
+
+(* ==================================================================== *)
+
+  PROCEDURE  SemErrorT(errNo: INTEGER; tok : S.Token);
+  BEGIN
+    IF errDist >= minErrDist THEN
+      S.SemError.Report(errNo, tok.lin, tok.col);
+    END;
+    IF errNo < 300 THEN errDist := 0 END;
+  END SemErrorT;
+
+(* ==================================================================== *)
+
+  PROCEDURE TypeResolve(scp : Sy.Scope);
+  BEGIN
+   (*
+    *  This visitor marks all reachable types with depth=REACHED;
+    *)
+    scp.symTb.Apply(Visitor.newResolver());
+  END TypeResolve;
+
+(* ==================================================================== *)
+
+  PROCEDURE bindToken(scp : Sy.Scope) : Sy.Idnt;
+    VAR hash : INTEGER;
+  BEGIN
+    hash  := NameHash.enterSubStr(token.pos, token.len);
+    RETURN Sy.bind(hash, scp);
+  END bindToken;
+
+(* ==================================================================== *)
+
+  PROCEDURE bindFieldToken(typ : Sy.Type; tok : S.Token) : Sy.Idnt;
+    VAR hash : INTEGER;
+        recT : Ty.Record;
+        idnt : Sy.Idnt;
+  BEGIN
+   (*
+    *  We must do a full bind here, rather than just a bind-local
+    *  since we must look for inherited methods from the supertypes
+    *)
+    hash := NameHash.enterSubStr(tok.pos, tok.len);
+    WITH typ : Ty.Record DO
+        RETURN typ.bindField(hash);
+    | typ : Ty.Enum DO
+        RETURN typ.symTb.lookup(hash);
+    END;
+  END bindFieldToken;
+
+(* ==================================================================== *)
+
+  PROCEDURE bindTokenLocal(scp : Sy.Scope) : Sy.Idnt;
+    VAR hash : INTEGER;
+  BEGIN
+    hash  := NameHash.enterSubStr(token.pos, token.len);
+    RETURN Sy.bindLocal(hash, scp);
+  END bindTokenLocal;
+
+(* ==================================================================== *)
+
+  PROCEDURE  Get;
+  BEGIN
+    REPEAT
+      token := nextT;
+      nextT := S.get();
+      IF nextT.sym <= maxT THEN INC(errDist) ELSE Error(91) END;
+    UNTIL nextT.sym <= maxT;
+    S.prevTok := token;
+  END Get;
+
+(* ==================================================================== *)
+
+  PROCEDURE  in (VAR s: SymbolSet; x: INTEGER): BOOLEAN;
+  BEGIN
+    RETURN x MOD setsize IN s[x DIV setsize];
+  END in;
+
+(* ==================================================================== *)
+
+  PROCEDURE  Expect (n: INTEGER);
+  BEGIN
+    IF nextT.sym = n THEN Get ELSE Error(n) END;
+  END Expect;
+
+(* ==================================================================== *)
+
+  PROCEDURE  weakSeparator (n, syFol, repFol: INTEGER): BOOLEAN;
+  VAR
+    s: SymbolSet;
+    i: INTEGER;
+  BEGIN
+    IF nextT.sym = n THEN Get; RETURN TRUE
+    ELSIF in(symSet[repFol], nextT.sym) THEN RETURN FALSE
+    ELSE
+      FOR i := 0 TO maxT DIV setsize DO
+        s[i] := symSet[0, i] + symSet[syFol, i] + symSet[repFol, i];
+      END;
+      Error(n); WHILE ~ in(s, nextT.sym) DO Get END;
+      RETURN in(symSet[syFol], nextT.sym)
+    END
+  END weakSeparator;
+
+(* ==================================================================== *)
+(*                   Forward Procedure Declarations                     *)
+(* ==================================================================== *)
+
+  PROCEDURE^ ActualParameters(VAR rslt : Sy.ExprSeq; inhScp : Sy.Scope);
+  PROCEDURE^ ImportList (modScope : Id.BlkId);
+  PROCEDURE^ DeclarationSequence (defScp : Sy.Scope);
+  PROCEDURE^ ConstantDeclaration (defScp : Sy.Scope);
+  PROCEDURE^ TypeDeclaration(defScp : Sy.Scope);
+  PROCEDURE^ VariableDeclaration(defScp : Sy.Scope);
+  PROCEDURE^ IdentDefList(OUT iSeq : Sy.IdSeq; scp : Sy.Scope; kind : INTEGER);
+  PROCEDURE^ typeQualid(defScp : Sy.Scope) : Id.TypId;
+  PROCEDURE^ qualident(defScp : Sy.Scope) : Sy.Idnt;
+  PROCEDURE^ FPSection(VAR pars : Id.ParSeq; thisP, defScp : Sy.Scope);
+  PROCEDURE^ type(defScp : Sy.Scope; vMod : INTEGER) : Sy.Type;
+  PROCEDURE^ identDef(inhScp : Sy.Scope; tag : INTEGER) : Sy.Idnt;
+  PROCEDURE^ constExpression(defScp : Sy.Scope) : Xp.LeafX;
+  PROCEDURE^ expression(scope : Sy.Scope) : Sy.Expr;
+  PROCEDURE^ designator(inhScp : Sy.Scope) : Sy.Expr;
+  PROCEDURE^ OptExprList(VAR xList : Sy.ExprSeq; inhScp : Sy.Scope);
+  PROCEDURE^ ExprList(VAR xList : Sy.ExprSeq; inhScp : Sy.Scope);
+  PROCEDURE^ statementSequence(inhLp : Sy.Stmt; inhSc : Sy.Scope) : Sy.Stmt;
+  PROCEDURE^ ProcedureStuff(scope : Sy.Scope);
+  PROCEDURE^ CheckVisibility(seq : Sy.IdSeq; in : INTEGER; OUT out : INTEGER);
+  PROCEDURE^ FormalParameters(thsP : Ty.Procedure;
+                              proc : Id.Procs;
+                              scpe : Sy.Scope);
+
+(* ==================================================================== *)
+
+  PROCEDURE  CPmodule();
+    VAR name : LitValue.CharOpen;
+  BEGIN
+    Expect(T.MODULESym);
+    Expect(T.identSym);
+    G.thisMod.hash := NameHash.enterSubStr(token.pos, token.len);
+    G.thisMod.token := token;
+    Sy.getName.Of(G.thisMod, G.modNam);
+   (* Manual addition 15-June-2000. *)
+    IF nextT.sym = T.lbrackSym THEN
+      Get;
+      IF G.strict THEN SemError(221); END;
+      Expect(T.stringSym);
+      name := LitValue.subStrToCharOpen(token.pos+1, token.len-2);
+      G.thisMod.scopeNm := name;
+      Expect(T.rbrackSym);
+      IF G.verbose THEN G.Message('external modName "' + name^ + '"') END;
+(*
+ *    SemError(144);
+ *    Get;
+ *    Expect(T.stringSym);
+ *    Expect(T.rbrackSym);
+ *)
+    END;
+   (* End addition 15-June-2000 kjg *)
+    Expect(T.semicolonSym);
+    IF (nextT.sym = T.IMPORTSym) THEN
+      ImportList(G.thisMod);
+    ELSE
+      Sy.ResetScpSeq(G.impSeq);
+    END;
+    DeclarationSequence(G.thisMod);
+    IF (nextT.sym = T.BEGINSym) THEN
+      G.thisMod.begTok := nextT;
+      Get;
+     (*
+      *     "BEGIN" [ '[' "UNCHECKED_ARITHMETIC" ']' ] ...
+      *)
+      IF nextT.sym = T.lbrackSym THEN
+        Get;
+        IF G.strict THEN SemError(221); END;
+        Expect(T.identSym);
+        IF NameHash.enterSubStr(token.pos, token.len) = Bi.noChkB THEN
+          G.thisMod.ovfChk := FALSE;
+        ELSE
+          SemError(194);
+        END;
+        Expect(T.rbrackSym);
+      END;
+      G.thisMod.modBody := statementSequence(NIL, G.thisMod);
+      IF (nextT.sym = T.CLOSESym) THEN
+        Get;
+        G.thisMod.modClose := statementSequence(NIL, G.thisMod);
+      END;
+    END;
+  END CPmodule;
+
+(* ==================================================================== *)
+
+  PROCEDURE  ForeignMod();
+    VAR name : LitValue.CharOpen;
+  BEGIN
+    Expect(T.MODULESym);
+    Expect(T.identSym);
+    G.thisMod.hash := NameHash.enterSubStr(token.pos, token.len);
+    G.thisMod.token := token;
+    Sy.getName.Of(G.thisMod, G.modNam);
+    IF nextT.sym = T.lbrackSym THEN
+      Get;
+      Expect(T.stringSym);
+      name := LitValue.subStrToCharOpen(token.pos+1, token.len-2);
+      G.thisMod.scopeNm := name;
+      Expect(T.rbrackSym);
+      IF G.verbose THEN G.Message('external modName "' + name^ + '"') END;
+    END;
+    Expect(T.semicolonSym);
+    IF (nextT.sym = T.IMPORTSym) THEN
+      ImportList(G.thisMod);
+    ELSE
+      Sy.ResetScpSeq(G.impSeq);
+    END;
+    DeclarationSequence(G.thisMod);
+  END ForeignMod;
+
+(* ==================================================================== *)
+
+  PROCEDURE  Import (modScope : Id.BlkId; VAR impSeq : Sy.ScpSeq);
+    VAR ident : Id.BlkId;  (* The imported module name descriptor *)
+        alias : Id.BlkId;  (* The declared alias name (optional)  *)
+        clash : Sy.Idnt;
+        dummy : BOOLEAN;
+        idHsh : INTEGER;
+        strng : LitValue.CharOpen;
+        impNm : LitValue.CharOpen;
+  BEGIN
+    alias := NIL;
+    ident := Id.newImpId();
+    Expect(T.identSym);
+    IF (nextT.sym = T.colonequalSym) THEN
+      alias := Id.newAlias();
+      alias.hash  := NameHash.enterSubStr(token.pos, token.len);
+      IF Sy.refused(alias, modScope) THEN SemError(4) END;
+      Get; (* Read past colon symbol *)
+     (*
+      *          the place to put
+      *  Here is ^ the experimental processing for the option
+      *  of using a literal string at this position.  If there
+      *  is a literal string, it should be mapped to the default
+      *  name here.
+      *)
+      IF nextT.sym = T.stringSym THEN
+        Get;
+        strng := LitValue.subStrToCharOpen(token.pos+1, token.len-2);
+        ForeignName.ParseModuleString(strng, impNm);
+        alias.token := token;  (* fake the name for err-msg use *)
+        idHsh := NameHash.enterStr(impNm);
+        IF G.strict THEN Error(221) END;
+      ELSE
+        Expect(T.identSym);
+        alias.token := token;  (* fake the name for err-msg use *)
+        idHsh := NameHash.enterSubStr(token.pos, token.len);
+      END;
+    ELSE
+      idHsh := NameHash.enterSubStr(token.pos, token.len);
+    END;
+    ident.token := token;
+    ident.dfScp := ident;
+    ident.hash  := idHsh;
+
+    IF ident.hash = Bi.sysBkt THEN
+      dummy := CompState.thisMod.symTb.enter(Bi.sysBkt, CompState.sysMod);
+      IF G.verbose THEN G.Message("imports unsafe SYSTEM module") END;
+      IF ~CompState.unsafe THEN SemError(227);
+      ELSIF ~CompState.targetIsNET() THEN SemError(228);
+      END;
+    ELSE
+      INCL(ident.xAttr, Sy.weak);
+    END;
+
+    clash := Sy.bind(ident.hash, modScope);
+    IF clash = NIL THEN
+      dummy := Sy.refused(ident, modScope);
+    ELSIF clash.kind = Id.impId THEN
+     (*
+      *  This import might already be known as a result of an
+      *  indirect import.  If that is the case, then we must
+      *  substitute the old descriptor for "ident" in case there
+      *  there are already references to it in the structure.
+      *)
+      clash.token := ident.token;   (* to help error reports  *)
+      ident := clash(Id.BlkId);
+      IF ~ident.isWeak() & 
+         (ident.hash # Bi.sysBkt) THEN SemError(170) END; (* imported twice  *)
+    ELSE
+      SemError(4);
+    END;
+
+    IF ident.hash = NameHash.mainBkt THEN
+      modScope.main := TRUE;      (* the import is "CPmain" *)
+      IF G.verbose THEN G.Message("contains CPmain entry point") END;
+      INCL(modScope.xAttr, Sy.cMain); (* Console Main *)
+    ELSIF ident.hash = NameHash.winMain THEN
+      modScope.main := TRUE;      (* the import is "CPmain" *)
+      INCL(modScope.xAttr, Sy.wMain); (* Windows Main *)
+      IF G.verbose THEN G.Message("contains WinMain entry point") END;
+    END;
+
+    IF Sy.weak IN ident.xAttr THEN
+     (*
+      *  List the file, for importation later  ...
+      *)
+      Sy.AppendScope(impSeq, ident);
+     (*
+      *  Alias (if any) must appear after ImpId
+      *)
+      IF alias # NIL THEN
+        alias.dfScp  := ident;    (* AFTER clash resolved. *)
+        Sy.AppendScope(impSeq, alias);
+      END;
+
+      EXCL(ident.xAttr, Sy.weak); (* ==> directly imported *)
+      INCL(ident.xAttr, Sy.need); (* ==> needed in symfile *)
+    END;
+  END Import;
+
+(* ==================================================================== *)
+
+  PROCEDURE  ImportList (modScope : Id.BlkId);
+    VAR index  : INTEGER;
+  BEGIN
+    Get;
+    Sy.ResetScpSeq(G.impSeq);
+    Import(modScope, G.impSeq);
+    WHILE (nextT.sym = T.commaSym) DO
+      Get;
+      Import(modScope, G.impSeq);
+    END;
+    Expect(T.semicolonSym);
+    G.import1 := RTS.GetMillis();
+IF G.legacy THEN
+    OldSymFileRW.WalkImports(G.impSeq, modScope);
+ELSE
+    NewSymFileRW.WalkImports(G.impSeq, modScope);
+END;
+    G.import2 := RTS.GetMillis();
+  END ImportList;
+
+(* ==================================================================== *)
+
+  PROCEDURE  FPSection(VAR pars : Id.ParSeq; thisP, defScp : Sy.Scope);
+  (* sequence is passed in from the caller *)
+    VAR mode : INTEGER;
+        indx : INTEGER;
+        parD : Id.ParId;
+        tpDx : Sy.Type;
+        tokn : S.Token;
+        pTst : BOOLEAN; (* test if formal type is private *)
+   (* --------------------------- *)
+    PROCEDURE isPrivate(t : Sy.Type) : BOOLEAN;
+    BEGIN
+      RETURN ~(t IS Ty.Base) & (t.idnt.vMod = Sy.prvMode);
+    END isPrivate;
+   (* --------------------------- *)
+    PROCEDURE CheckFormalType(tst : BOOLEAN; tok : S.Token; typ : Sy.Type);
+    BEGIN (*
+      * There are two separate kinds of tests here:
+      * * formals must not be less visible than the procedure
+      * * anonymous formals are only useful in two cases:
+      *   - open arrays, provided the element type is visible enough;
+      *   - pointer types, provided the bound type is visible enough.
+      *)
+      IF typ = NIL THEN RETURN;
+      ELSIF typ.idnt # NIL THEN
+        IF tst & isPrivate(typ) THEN SemErrorT(150, tok) END;
+      ELSE
+        WITH typ : Ty.Record  DO
+            SemErrorT(314, tok);
+        | typ : Ty.Pointer DO
+            CheckFormalType(tst, tok, typ.boundTp);
+        | typ : Ty.Array   DO
+            CheckFormalType(tst, tok, typ.elemTp);
+            (* Open arrays and vectors have length = 0 *)
+            IF typ.length # 0 THEN SemErrorT(315, tok) END;
+        ELSE (* skip procs? *)
+        END;
+      END;
+    END CheckFormalType;
+   (* --------------------------- *)
+  BEGIN
+    Id.ResetParSeq(pars);     (* make sequence empty  *)
+    IF nextT.sym = T.INSym THEN
+      Get;
+      mode := Sy.in;
+    ELSIF nextT.sym = T.OUTSym THEN
+      Get;
+      mode := Sy.out;
+    ELSIF nextT.sym = T.VARSym THEN
+      Get;
+      mode := Sy.var;
+    ELSE
+      mode := Sy.val;
+    END;
+    parD := identDef(defScp, Id.parId)(Id.ParId);
+    Id.AppendParam(pars, parD);
+    WHILE weakSeparator(12, 1, 2) DO
+      parD := identDef(defScp, Id.parId)(Id.ParId);
+      Id.AppendParam(pars, parD);
+    END;
+    Expect(T.colonSym);
+    tokn := nextT;
+    tpDx := type(defScp, Sy.prvMode);
+    IF tpDx # NIL THEN
+      pTst := ~G.special & (thisP # NIL) & (thisP.vMod = Sy.pubMode);
+
+      CheckFormalType(pTst, tokn, tpDx);
+
+      FOR indx := 0 TO pars.tide-1 DO
+        pars.a[indx].parMod := mode;
+        pars.a[indx].type := tpDx;
+      END;
+    END;
+  END FPSection;
+
+(* ==================================================================== *)
+
+  PROCEDURE  DeclarationSequence (defScp : Sy.Scope);
+  BEGIN
+    WHILE (nextT.sym = T.CONSTSym) OR
+          (nextT.sym = T.TYPESym) OR
+          (nextT.sym = T.VARSym) DO
+      IF (nextT.sym = T.CONSTSym) THEN
+        Get;
+        WHILE (nextT.sym = T.identSym) DO
+          ConstantDeclaration(defScp);
+          Expect(T.semicolonSym);
+        END;
+      ELSIF (nextT.sym = T.TYPESym) THEN
+        Get;
+        WHILE (nextT.sym = T.identSym) DO
+          TypeDeclaration(defScp);
+          Expect(T.semicolonSym);
+        END;
+      ELSE
+        Get;
+        WHILE (nextT.sym = T.identSym) DO
+          VariableDeclaration(defScp);
+          Expect(T.semicolonSym);
+        END;
+      END;
+    END;
+    (* Last chance to resolve forward types in this block *)
+    defScp.endDecl := TRUE;
+    TypeResolve(defScp);
+    (* Now the local procedures *)
+    WHILE (nextT.sym = T.PROCEDURESym) DO
+      ProcedureStuff(defScp);
+      Expect(T.semicolonSym);
+    END;
+  END DeclarationSequence;
+
+(* ==================================================================== *)
+
+  PROCEDURE otherAtts(in : SET) : SET;
+  BEGIN
+    IF nextT.sym = T.ABSTRACTSym THEN
+      Get;
+      RETURN in + Id.isAbs;
+    ELSIF nextT.sym = T.EMPTYSym THEN
+      Get;
+      RETURN in + Id.empty;
+    ELSIF nextT.sym = T.EXTENSIBLESym THEN
+      Get;
+      RETURN in + Id.extns;
+    ELSE
+      Error(77);
+      RETURN in;
+    END;
+  END otherAtts;
+
+(* ==================================================================== *)
+
+  PROCEDURE^ MethAttributes(pDesc : Id.Procs);
+
+(* ==================================================================== *)
+
+  PROCEDURE receiver(scope : Sy.Scope) : Id.ParId;
+    VAR mode : INTEGER;
+        parD : Id.ParId;
+        rcvD : Sy.Idnt;
+  BEGIN
+    Get;  (* read past lparenSym *)
+    IF nextT.sym = T.INSym THEN
+      Get;
+      mode := Sy.in;
+    ELSIF nextT.sym = T.VARSym THEN
+      Get;
+      mode := Sy.var;
+    ELSE
+      mode := Sy.val;
+    END;
+    parD := identDef(scope, Id.parId)(Id.ParId);
+    parD.isRcv := TRUE;
+    parD.parMod := mode;
+    Expect(T.colonSym);
+    Expect(T.identSym);
+    rcvD := bindToken(scope);
+    IF rcvD = NIL THEN
+      SemError(2);
+    ELSIF ~(rcvD IS Id.TypId) THEN
+      SemError(5);
+    ELSE
+      parD.type := rcvD.type;
+    END;
+    Expect(T.rparenSym);
+    RETURN parD;
+  END receiver;
+
+(* ==================================================================== *)
+
+  PROCEDURE ExceptBody(pInhr : Id.Procs);
+    VAR excp : Id.LocId;
+  BEGIN
+   (*
+    *  This procedure has an exception handler. We must...
+    *  (i)  define a local to hold the exception value
+    *  (ii) parse the rescue statement sequence
+    *)
+    Expect(T.lparenSym);
+    excp := identDef(pInhr, Id.varId)(Id.LocId);
+    excp.SetKind(Id.conId);     (* mark immutable *)
+    excp.type := G.ntvExc;
+    excp.varOrd := pInhr.locals.tide;
+    IF Sy.refused(excp, pInhr) THEN
+      excp.IdError(4);
+    ELSE
+      Sy.AppendIdnt(pInhr.locals, excp);
+      pInhr.except := excp;
+    END;
+    Expect(T.rparenSym);
+    pInhr.rescue := statementSequence(NIL, pInhr); (* inhLp is NIL *)
+  END ExceptBody;
+
+(* ==================================================================== *)
+
+  PROCEDURE ProcedureBody(pInhr : Id.Procs);(* Inherited descriptor *)
+  BEGIN
+    DeclarationSequence(pInhr);
+    IF nextT.sym = T.BEGINSym THEN
+      Get;
+     (*
+      *     "BEGIN" [ '[' "UNCHECKED_ARITHMETIC" ']' ] ...
+      *)
+      IF nextT.sym = T.lbrackSym THEN
+        Get;
+        Expect(T.identSym);
+        IF NameHash.enterSubStr(token.pos, token.len) = Bi.noChkB THEN
+          pInhr.ovfChk := FALSE;
+        ELSE
+          SemError(194);
+        END;
+        Expect(T.rbrackSym);
+      END;
+      pInhr.body := statementSequence(NIL, pInhr); (* inhLp is NIL *)
+    END;
+    IF nextT.sym = T.RESCUESym THEN
+      Get;
+      IF G.strict THEN SemError(221); END;
+      ExceptBody(pInhr);
+    END;
+    Expect(T.ENDSym);
+  END ProcedureBody;
+
+(* ==================================================================== *)
+
+  PROCEDURE procedureHeading(scope : Sy.Scope) : Id.Procs;
+    VAR rcvD : Id.ParId;
+        prcD : Id.Procs;
+        mthD : Id.MthId;
+        prcT : Ty.Procedure;
+        name : LitValue.CharOpen;
+  BEGIN
+    IF nextT.sym # T.lparenSym THEN
+      rcvD := NIL;
+      prcD := identDef(scope, Id.conPrc)(Id.Procs);
+      prcD.SetKind(Id.conPrc);
+    ELSE
+      rcvD := receiver(scope);
+      mthD := identDef(scope, Id.conMth)(Id.MthId);
+      mthD.SetKind(Id.conMth);
+      IF (rcvD.type # NIL) &
+         (rcvD.type.idnt # NIL) THEN
+        IF rcvD.type.isInterfaceType() &
+             (mthD.vMod = Sy.prvMode) THEN SemError(216);
+        END;
+      END;
+      prcD := mthD;
+      mthD.rcvFrm := rcvD;
+      IF Sy.refused(rcvD, mthD) THEN     (* insert receiver in scope  *)
+        rcvD.IdError(4);    (* refusal impossible maybe? *)
+      ELSE
+        rcvD.dfScp  := mthD;    (* Correct the defScp *)
+        rcvD.varOrd := mthD.locals.tide;
+        Sy.AppendIdnt(mthD.locals, rcvD);
+      END;
+    END;
+    IF nextT.sym = T.lbrackSym THEN
+      IF ~G.special THEN SemError(144) END;
+      Get;
+      Expect(T.stringSym);
+      name := LitValue.subStrToCharOpen(token.pos+1, token.len-2);
+      prcD.prcNm := name;
+      Expect(T.rbrackSym);
+      IF G.verbose THEN G.Message('external procName "' + name^ + '"') END;
+    END;
+    prcT := Ty.newPrcTp();
+    prcT.idnt := prcD;
+    prcD.type := prcT;
+    IF prcD.vMod # Sy.prvMode THEN INCL(prcD.pAttr, Id.public) END;
+    IF nextT.sym = T.lparenSym THEN
+      FormalParameters(prcT, prcD, scope);
+    END;
+    IF nextT.sym = T.commaSym THEN
+      Get;
+      MethAttributes(prcD);  
+    END;
+    IF rcvD # NIL THEN prcT.receiver := rcvD.type END;
+    prcD.EnterProc(rcvD, scope);
+    RETURN prcD;
+  END procedureHeading;
+
+(* ==================================================================== *)
+
+  PROCEDURE ProcDeclStuff(scope : Sy.Scope);
+    VAR desc : Id.Procs;
+        name : FileNames.NameString;
+        pNam : FileNames.NameString;
+        errN : INTEGER;
+  BEGIN
+    desc := procedureHeading(scope);
+    WITH scope : Id.Procs DO               (* a nested proc *)
+      Id.AppendProc(scope.nestPs, desc);
+      desc.lxDepth := scope.lxDepth + 1;
+    ELSE
+      desc.lxDepth := 0;
+    END;
+    Id.AppendProc(G.thisMod.procs, desc);
+    IF ~desc.isEmpty() & ~G.isForeign() THEN
+      Expect(T.semicolonSym);
+      ProcedureBody(desc);
+      desc.endSpan := S.mkSpanTT(token, nextT);
+      Expect(T.identSym);
+     (* check closing name *)
+      S.GetString(token.pos, token.len, name);
+      Sy.getName.Of(desc, pNam);
+      IF name # pNam THEN
+        IF token.sym = T.identSym THEN errN := 1 ELSE errN := 0 END;
+        SemErrorS1(errN, pNam$);
+      END;
+    END;
+  END ProcDeclStuff;
+
+(* ==================================================================== *)
+
+  PROCEDURE ForwardStuff(scope : Sy.Scope);
+    VAR desc : Id.Procs;
+  BEGIN
+    Get;        (* read past uparrowSym *)
+    desc := procedureHeading(scope);
+   (* Set lexical depth for forward procs as well. kjg Sep-2001 *)
+    WITH scope : Id.Procs DO               (* a nested proc *)
+      desc.lxDepth := scope.lxDepth + 1;
+    ELSE
+      desc.lxDepth := 0;
+    END;
+    IF desc.kind = Id.conMth THEN
+      desc.setPrcKind(Id.fwdMth);
+    ELSIF desc.kind = Id.conPrc THEN
+      desc.setPrcKind(Id.fwdPrc);
+    END;
+    Id.AppendProc(G.thisMod.procs, desc);
+  END ForwardStuff;
+
+(* ==================================================================== *)
+
+  PROCEDURE ProcedureStuff(scope : Sy.Scope);
+  (* parse procedure and add to list in scope *)
+  BEGIN
+    Get;        (* read past PROCEDURESym *)
+    IF nextT.sym = T.uparrowSym THEN
+      ForwardStuff(scope);
+    ELSIF (nextT.sym = T.identSym) OR
+          (nextT.sym = T.lparenSym) THEN
+      ProcDeclStuff(scope);
+    ELSE Error(79);
+    END;
+  END ProcedureStuff;
+
+(* ==================================================================== *)
+
+  PROCEDURE guard(scope : Sy.Scope) : Sy.Expr;
+    VAR expr : Xp.BinaryX;
+        qual : Sy.Expr;
+        dstX : Sy.Expr;       (* should be typeQualid *)
+  BEGIN
+    qual := Xp.mkIdLeaf(qualident(scope));
+    Expect(T.colonSym);
+    expr := Xp.newBinaryX(Xp.isOp, qual, NIL);
+    dstX := Xp.mkIdLeaf(typeQualid(scope));
+   (* Check #1 : that the expression has a type that is dynamic   *)
+    IF ~qual.hasDynamicType() THEN qual.ExprError(17) END;
+   (* Check #2 : that manifest type is a base of the asserted type  *)
+    IF (qual.type # NIL) &
+        ~qual.type.isBaseOf(dstX.type) &
+        ~qual.type.isInterfaceType() &
+        ~dstX.type.isInterfaceType() THEN SemError(15) END;
+    expr.rKid := dstX;
+    RETURN expr;
+  END guard;
+
+(* ==================================================================== *)
+
+  PROCEDURE caseLabel(chTp  : BOOLEAN;
+                      tide  : INTEGER;
+                      scope : Sy.Scope) : StatDesc.Triple;
+    VAR lExp, rExp : Sy.Expr;
+        xpOk       : BOOLEAN;
+        lo, hi     : INTEGER;
+  BEGIN
+    lo := 0; hi := 0;
+    xpOk := TRUE;
+    lExp := constExpression(scope);
+    IF lExp # NIL THEN
+      IF chTp THEN
+        IF lExp.isCharLit() THEN
+          lo := ORD(lExp(Xp.LeafX).charValue());
+        ELSE
+          lExp.ExprError(43); xpOk := FALSE;
+        END;
+      ELSE
+        IF lExp.isNumLit() THEN
+          lo := lExp(Xp.LeafX).value.int();
+        ELSE
+          lExp.ExprError(37); xpOk := FALSE;
+        END;
+      END;
+    ELSE xpOk := FALSE;
+    END;
+    IF nextT.sym = T.pointpointSym THEN
+      Get;
+      rExp := constExpression(scope);
+      IF rExp # NIL THEN
+        IF chTp THEN
+          IF rExp.isCharLit() THEN
+            hi := ORD(rExp(Xp.LeafX).charValue());
+          ELSE
+            rExp.ExprError(43); xpOk := FALSE;
+          END;
+        ELSE
+          IF rExp.isNumLit() THEN
+            hi := rExp(Xp.LeafX).value.int();
+          ELSE
+            rExp.ExprError(37); xpOk := FALSE;
+          END;
+        END;
+      ELSE xpOk := FALSE;
+      END;
+      IF xpOk & (lo > hi) THEN lExp.ExprError(30) END;
+    ELSE
+      hi := lo;
+    END;
+    RETURN StatDesc.newTriple(lo, hi, tide);
+  END caseLabel;
+
+(* ==================================================================== *)
+
+  PROCEDURE CaseLabelList(VAR labels : StatDesc.TripleSeq;
+                              isChar : BOOLEAN;
+                              stTide : INTEGER;
+                              scope  : Sy.Scope);
+    VAR next : StatDesc.Triple;
+  BEGIN
+    next := caseLabel(isChar, stTide, scope);
+    StatDesc.AppendTriple(labels, next);
+    WHILE nextT.sym = T.commaSym DO
+      Get;
+      next := caseLabel(isChar, stTide, scope);
+      StatDesc.AppendTriple(labels, next);
+    END;
+  END CaseLabelList;
+
+(* ==================================================================== *)
+
+  PROCEDURE Case(desc : StatDesc.CaseSt; inhLp : Sy.Stmt; scope : Sy.Scope);
+  BEGIN
+    IF in(symSet[3], nextT.sym) THEN
+      CaseLabelList(desc.labels, desc.chrSel, desc.blocks.tide, scope);
+      Expect(T.colonSym);
+      Sy.AppendStmt(desc.blocks, statementSequence(inhLp, scope));
+    END;
+  END Case;
+
+(* ==================================================================== *)
+
+  PROCEDURE  ActualParameters(VAR rslt : Sy.ExprSeq; inhScp : Sy.Scope);
+  BEGIN
+    Expect(T.lparenSym);
+    OptExprList(rslt, inhScp);
+    Expect(T.rparenSym);
+  END ActualParameters;
+
+(* ==================================================================== *)
+
+  PROCEDURE withStatement(inhLp : Sy.Stmt; scope : Sy.Scope) : Sy.Stmt;
+    VAR synthS : StatDesc.Choice;
+        predXp : Sy.Expr;
+        block  : Sy.Stmt;
+        savedI : Sy.Idnt;
+        tmpId  : Id.LocId;
+  BEGIN
+    Get;
+    synthS := StatDesc.newWithS();
+    IF nextT.sym = T.ENDSym THEN
+      Get;
+      SemError(318);
+      RETURN synthS;
+    ELSIF nextT.sym = T.barSym THEN
+      Get;
+      IF G.strict THEN SemError(221); END;
+    END;
+    IF nextT.sym # T.ELSESym THEN
+      predXp := guard(scope);
+      Expect(T.DOSym);
+
+      tmpId := Id.newLocId();
+      tmpId.dfScp := scope;
+
+      savedI := predXp.enterGuard(tmpId);
+      block  := statementSequence(inhLp, scope);
+      predXp.ExitGuard(savedI, tmpId);
+      Sy.AppendIdnt(synthS.temps, tmpId);
+      Sy.AppendExpr(synthS.preds, predXp);
+      Sy.AppendStmt(synthS.blocks, block);
+      WHILE nextT.sym = T.barSym DO
+        Get;
+        predXp := guard(scope);
+        Expect(T.DOSym);
+
+        tmpId := Id.newLocId();
+        tmpId.dfScp := scope;
+
+        savedI := predXp.enterGuard(tmpId);
+        block  := statementSequence(inhLp, scope);
+        predXp.ExitGuard(savedI, tmpId);
+        Sy.AppendIdnt(synthS.temps, tmpId);
+        Sy.AppendExpr(synthS.preds, predXp);
+        Sy.AppendStmt(synthS.blocks, block);
+      END;
+    END;
+    IF nextT.sym = T.ELSESym THEN
+      Get;
+      block  := statementSequence(inhLp, scope);
+      Sy.AppendIdnt(synthS.temps, NIL);
+      Sy.AppendExpr(synthS.preds, NIL);
+      Sy.AppendStmt(synthS.blocks, block);
+    END;
+    Expect(T.ENDSym);
+    RETURN synthS;
+  END withStatement;
+
+(* ==================================================================== *)
+
+  PROCEDURE loopStatement(scope : Sy.Scope) : Sy.Stmt;
+  (* This procedure ignores the inherited attribute which for   *
+   * other cases designates the enclosing loop. This becomes    *
+   * the source of the enclosing loop for all nested statements *)
+    VAR newLoop : StatDesc.TestLoop;
+  BEGIN
+    Get;
+    newLoop := StatDesc.newLoopS();
+    newLoop.body := statementSequence(newLoop, scope);
+    Expect(T.ENDSym);
+    RETURN newLoop;
+  END loopStatement;
+
+(* ==================================================================== *)
+
+  PROCEDURE forStatement(inhLp : Sy.Stmt; scope : Sy.Scope) : Sy.Stmt;
+    VAR rslt : StatDesc.ForLoop;
+        cIdn : Sy.Idnt;
+
+   (* ------------------------- *)
+    PROCEDURE Check(id : Sy.Idnt);
+    BEGIN
+      IF id = NIL THEN SemError(2);
+      ELSIF ~(id IS Id.AbVar) THEN SemError(85);
+      ELSIF ~id.mutable() THEN SemError(103);
+      ELSIF (id.type # NIL) & ~id.type.isIntType() THEN SemError(84);
+      END;
+    END Check;
+   (* ------------------------- *)
+
+  BEGIN
+    Get;
+    rslt := StatDesc.newForStat();
+    Expect(T.identSym);
+    cIdn := bindToken(scope);
+    Check(cIdn);
+    Expect(T.colonequalSym);
+    rslt.cVar := cIdn;
+    rslt.loXp := expression(scope);
+    Expect(T.TOSym);
+    rslt.hiXp := expression(scope);
+    IF (nextT.sym = T.BYSym) THEN
+      Get;
+      rslt.byXp := constExpression(scope);
+      IF rslt.byXp # NIL THEN
+        IF rslt.byXp.kind # Xp.numLt THEN
+          rslt.byXp.ExprError(59);
+        ELSIF rslt.byXp(Xp.LeafX).value.long() = 0 THEN
+          rslt.byXp.ExprError(81);
+        END;
+      END;
+    ELSE
+      rslt.byXp := Xp.mkNumLt(1);
+    END;
+    Expect(T.DOSym);
+    rslt.body := statementSequence(inhLp, scope);
+    Expect(T.ENDSym);
+    RETURN rslt;
+  END forStatement;
+
+(* ==================================================================== *)
+
+  PROCEDURE repeatStatement(inhLp : Sy.Stmt; scope : Sy.Scope) : Sy.Stmt;
+    VAR rslt : StatDesc.TestLoop;
+  BEGIN
+    Get;
+    rslt := StatDesc.newRepeatS();
+    rslt.body := statementSequence(inhLp, scope);
+    Expect(T.UNTILSym);
+    rslt.test := expression(scope);
+    RETURN rslt;
+  END repeatStatement;
+
+(* ==================================================================== *)
+
+  PROCEDURE whileStatement(inhLp : Sy.Stmt; scope : Sy.Scope) : Sy.Stmt;
+    VAR rslt : StatDesc.TestLoop;
+  BEGIN
+    Get;
+    rslt := StatDesc.newWhileS();
+    rslt.test := expression(scope);
+    Expect(T.DOSym);
+    rslt.body := statementSequence(inhLp, scope);
+    Expect(T.ENDSym);
+    RETURN rslt;
+  END whileStatement;
+
+(* ==================================================================== *)
+
+  PROCEDURE caseStatement(inhLp : Sy.Stmt; scope : Sy.Scope) : Sy.Stmt;
+    VAR rslt : StatDesc.CaseSt;
+        slct : Sy.Expr;
+        isCh : BOOLEAN;
+  BEGIN
+    Get;
+    rslt := StatDesc.newCaseS();
+    slct := expression(scope);
+    Expect(T.OFSym);
+    IF slct # NIL THEN slct := slct.exprAttr() END;
+    IF (slct # NIL) & (slct.type # NIL) THEN
+      rslt.chrSel := FALSE;
+      rslt.select := slct;
+      IF slct.isCharExpr() THEN
+        rslt.chrSel := TRUE;
+      ELSIF slct.isIntExpr() THEN
+        IF slct.type.isLongType() THEN slct.ExprError(141) END;
+      ELSE
+        slct.ExprError(88);
+      END;
+    END;
+    IF nextT.sym = T.ENDSym THEN 
+      SemError(317);
+    ELSE
+      Case(rslt, inhLp, scope);
+      WHILE nextT.sym = T.barSym DO
+        Get;
+        Case(rslt, inhLp, scope);
+      END;
+      IF nextT.sym = T.ELSESym THEN
+        Get;
+        rslt.elsBlk := statementSequence(inhLp, scope);
+      END;
+    END;
+    Expect(T.ENDSym);
+    RETURN rslt;
+  END caseStatement;
+
+(* ==================================================================== *)
+
+  PROCEDURE ifStatement(inhLp : Sy.Stmt; scope : Sy.Scope) : Sy.Stmt;
+    VAR synthStat : StatDesc.Choice;
+  BEGIN
+    Get;
+    synthStat := StatDesc.newIfStat();
+    Sy.AppendExpr(synthStat.preds, expression(scope));
+    Expect(T.THENSym);
+    Sy.AppendStmt(synthStat.blocks, statementSequence(inhLp, scope));
+    WHILE nextT.sym = T.ELSIFSym DO
+      Get;
+      Sy.AppendExpr(synthStat.preds, expression(scope));
+      Expect(T.THENSym);
+      Sy.AppendStmt(synthStat.blocks, statementSequence(inhLp, scope));
+    END;
+    IF (nextT.sym = T.ELSESym) THEN
+      Get;
+      Sy.AppendExpr(synthStat.preds, NIL);
+      Sy.AppendStmt(synthStat.blocks, statementSequence(inhLp, scope));
+    END;
+    Expect(T.ENDSym);
+    RETURN synthStat;
+  END ifStatement;
+
+(* ==================================================================== *)
+
+  PROCEDURE^ ConvertOverloaded(VAR e : Sy.Expr);
+
+  PROCEDURE^ makeCall(xCr : Sy.Expr; IN actuals : Sy.ExprSeq;
+                     inhScp : Sy.Scope) : Sy.Expr;
+
+(* ==================================================================== *)
+
+  PROCEDURE identStatement(inhLp : Sy.Stmt; scope : Sy.Scope) : Sy.Stmt;
+    VAR assign  : StatDesc.Assign;
+        prCall  : StatDesc.ProcCall;
+        argLst  : Sy.ExprSeq;
+        desig   : Sy.Expr;
+        value   : Sy.Expr;
+        saveT   : S.Token;
+  BEGIN
+    saveT := nextT;
+    desig := designator(scope);
+    IF nextT.sym = T.colonequalSym THEN
+      ConvertOverloaded(desig);
+      IF desig # NIL THEN desig.tSpan := S.mkSpanTT(saveT, S.prevTok) END;
+      Get;
+      assign := StatDesc.newAssignS();
+      value := expression(scope);
+      assign.lhsX := desig;
+      assign.rhsX := value;
+      Xp.CheckIsVariable(desig);
+      RETURN assign;
+    ELSIF in(symSet[8], nextT.sym) THEN
+      IF (desig # NIL) & ~(desig IS Xp.CallX) THEN
+        desig := makeCall(desig,argLst,scope);
+      END;
+      prCall := StatDesc.newProcCall();
+      prCall.expr := desig;
+      IF desig # NIL THEN desig.tSpan := S.mkSpanTT(saveT, S.prevTok) END;
+      IF (desig # NIL) & 
+         (desig.type # NIL) & ~desig.type.isProperProcType() THEN
+        desig.ExprError(182);
+      END;
+      RETURN prCall;
+    ELSE Error(82); RETURN StatDesc.newEmptyS();
+    END;
+  END identStatement;
+
+(* ==================================================================== *)
+
+  PROCEDURE statement(inhLp : Sy.Stmt; inhSc : Sy.Scope) : Sy.Stmt;
+    VAR synthStat : Sy.Stmt;
+        synthExpr : Sy.Expr;
+        keywordTk : S.Token;
+
+   (* ------------------------- *)
+
+    PROCEDURE newStatement(inhSc : Sy.Scope) : Sy.Stmt;
+    (* This case is pulled out of line, so that the cost of *
+     * initialisation of the sequence is only paid when needed  *)
+      VAR argList : Sy.ExprSeq;
+          callExp : Sy.Expr;
+          qualId  : Sy.Expr;
+          callNew : StatDesc.ProcCall;
+    BEGIN
+      Get;
+      callNew := StatDesc.newProcCall();
+      ActualParameters(argList, inhSc);
+      qualId := Xp.mkIdLeaf(Bi.newPd);
+      callExp := Xp.newCallX(Xp.prCall, argList, qualId);
+      callExp.tSpan := S.mkSpanTT(callNew.token, S.prevTok); 
+      callNew.expr := callExp;
+      RETURN callNew;
+    END newStatement;
+
+   (* ------------------------- *)
+
+  BEGIN
+    keywordTk := nextT;
+    IF in(symSet[9], nextT.sym) THEN
+      CASE nextT.sym OF
+      | T.identSym:
+          synthStat := identStatement(inhLp, inhSc);
+      | T.LOOPSym:
+          synthStat := loopStatement(inhSc);
+      | T.IFSym:
+          synthStat := ifStatement(inhLp, inhSc);
+      | T.CASESym:
+          synthStat := caseStatement(inhLp, inhSc);
+      | T.WHILESym:
+          synthStat := whileStatement(inhLp, inhSc);
+      | T.REPEATSym:
+          synthStat := repeatStatement(inhLp, inhSc);
+      | T.FORSym:
+          synthStat := forStatement(inhLp, inhSc);
+      | T.WITHSym:
+          synthStat := withStatement(inhLp, inhSc);
+      | T.NEWSym :
+          synthStat := newStatement(inhSc);
+      | T.EXITSym:
+         (* Semantic action is inline *)
+          Get;
+          synthStat := StatDesc.newExitS(inhLp);
+          IF inhLp = NIL THEN SemError(58) END;
+      | T.RETURNSym :
+         (* Semantic action is inline *)
+          Get;
+          IF in(symSet[3], nextT.sym) THEN
+            synthExpr := expression(inhSc);
+          ELSE
+            synthExpr := NIL;
+          END;
+          synthStat := StatDesc.newReturnS(synthExpr);
+          synthStat.token := keywordTk;
+      ELSE synthStat := StatDesc.newEmptyS();
+
+      END;
+    ELSE
+      synthStat := StatDesc.newEmptyS();
+    END;
+    RETURN synthStat;
+  END statement;
+
+(* ==================================================================== *)
+
+  PROCEDURE statementSequence(inhLp : Sy.Stmt; inhSc : Sy.Scope) : Sy.Stmt;
+    VAR block : StatDesc.Block;
+        first : Sy.Stmt;
+  BEGIN
+    WHILE ~ (in(symSet[4], nextT.sym)) DO Error(80); Get END;
+    first := statement(inhLp, inhSc);
+    block := NIL;
+    WHILE weakSeparator(22, 5, 6) DO
+      WHILE ~ (in(symSet[4], nextT.sym)) DO Error(81); Get END;
+      IF block = NIL THEN
+        block := StatDesc.newBlockS(first.token);
+        IF first.kind # StatDesc.emptyS THEN Sy.AppendStmt(block.sequ,first) END
+      END;
+      first := statement(inhLp, inhSc);
+      IF first.kind # StatDesc.emptyS THEN Sy.AppendStmt(block.sequ,first) END;
+    END;
+    IF block = NIL THEN RETURN first ELSE RETURN block END;
+  END statementSequence;
+
+(* ==================================================================== *)
+
+  PROCEDURE  element(defScp : Sy.Scope) : Sy.Expr;
+    VAR rslt : Sy.Expr;
+        xTop : Sy.Expr;
+        dTok : S.Token;
+  BEGIN
+    rslt := expression(defScp);
+    IF nextT.sym = T.pointpointSym THEN (* a range *)
+      Get; dTok := token;
+      xTop := expression(defScp);
+      rslt := Xp.newBinaryT(Xp.range, rslt, xTop, dTok);;
+    END;
+    RETURN rslt;
+  END element;
+
+(* ==================================================================== *)
+
+  PROCEDURE  set(defScp : Sy.Scope) : Sy.Expr;
+    VAR rslt : Xp.SetExp;
+  BEGIN
+    Expect(T.lbraceSym);
+    rslt := Xp.mkEmptySet();
+    IF in(symSet[3], nextT.sym) THEN
+      Sy.AppendExpr(rslt.varSeq, element(defScp));
+      WHILE nextT.sym = T.commaSym DO
+        Get;
+        Sy.AppendExpr(rslt.varSeq, element(defScp));
+      END;
+    END;
+    Expect(T.rbraceSym);
+    RETURN rslt;
+  END set;
+
+(* ==================================================================== *)
+
+  PROCEDURE  mulOperator() : INTEGER;
+    VAR oSyn : INTEGER;
+  BEGIN
+    IF (nextT.sym = T.starSym) THEN
+      Get;
+      oSyn := Xp.mult;
+    ELSIF (nextT.sym = T.slashSym) THEN
+      Get;
+      oSyn := Xp.slash;
+    ELSIF (nextT.sym = T.DIVSym) THEN
+      Get;
+      oSyn := Xp.divOp;
+    ELSIF (nextT.sym = T.MODSym) THEN
+      Get;
+      oSyn := Xp.modOp;
+    ELSIF (nextT.sym = T.andSym) THEN
+      Get;
+      oSyn := Xp.blAnd;
+    ELSIF (nextT.sym = T.DIV0Sym) THEN
+      Get;
+      oSyn := Xp.div0op;
+    ELSIF (nextT.sym = T.REM0Sym) THEN
+      Get;
+      oSyn := Xp.rem0op;
+    ELSE
+      Error(83); oSyn := T.starSym;
+    END;
+    RETURN oSyn;
+  END mulOperator;
+
+(* ==================================================================== *)
+
+  PROCEDURE  factor(scope : Sy.Scope) : Sy.Expr;
+    VAR xSyn : Sy.Expr;
+        junk : Sy.ExprSeq;
+        long : LONGINT;
+        save : S.Token;
+  BEGIN
+    CASE nextT.sym OF
+      T.lbraceSym :
+        xSyn := set(scope);
+    | T.lparenSym :
+        Get;
+        xSyn := expression(scope);
+        Expect(T.rparenSym);
+    | T.integerSym :
+        Get;
+        xSyn := Xp.mkNumLt(S.tokToLong(token));
+    | T.realSym :
+        Get;
+        xSyn := Xp.mkRealLt(S.tokToReal(token));
+    | T.CharConstantSym :
+        Get;
+        xSyn := Xp.mkCharLt(S.tokToChar(token));
+    | T.stringSym :
+        Get;
+        xSyn := Xp.tokToStrLt(token.pos, token.len);
+    | T.NILSym :
+        Get;
+        xSyn := Xp.mkNilX();
+    | T.identSym :
+        xSyn := designator(scope);
+        ConvertOverloaded(xSyn);
+        IF (xSyn # NIL) & (xSyn.kind = Xp.prCall) THEN
+          SemError(24);   (* use of proper proc as function *)
+        END;
+    | T.tildeSym :
+        Get;
+        xSyn := factor(scope);
+        xSyn := Xp.newUnaryX(Xp.blNot, xSyn);
+    ELSE
+      Error(84); xSyn := NIL;
+    END;
+    RETURN xSyn;
+  END factor;
+
+(* ==================================================================== *)
+
+  PROCEDURE  addOperator() : INTEGER;
+    VAR oSyn : INTEGER;
+  BEGIN
+    IF (nextT.sym = T.plusSym) THEN
+      Get;
+      oSyn := Xp.plus;
+    ELSIF (nextT.sym = T.minusSym) THEN
+      Get;
+      oSyn := Xp.minus;
+    ELSIF (nextT.sym = T.ORSym) THEN
+      Get;
+      oSyn := Xp.blOr;
+    ELSE
+      Error(85); oSyn := T.plusSym;
+    END;
+    RETURN oSyn;
+  END addOperator;
+
+(* ==================================================================== *)
+
+  PROCEDURE  term(scope : Sy.Scope) : Sy.Expr;
+    VAR xSyn1 : Sy.Expr;
+        xSyn2 : Sy.Expr;
+        mulOp : INTEGER;
+        saveT : S.Token;
+  BEGIN
+    xSyn1 := factor(scope);
+    WHILE (nextT.sym = T.starSym) OR
+          (nextT.sym = T.slashSym) OR
+          (nextT.sym = T.DIVSym) OR
+          (nextT.sym = T.MODSym) OR
+          (nextT.sym = T.DIV0Sym) OR
+          (nextT.sym = T.REM0Sym) OR
+          (nextT.sym = T.andSym) DO
+      mulOp := mulOperator(); saveT := token;
+      xSyn2 := factor(scope);
+      xSyn1 := Xp.newBinaryT(mulOp, xSyn1, xSyn2, saveT);
+    END;
+    RETURN xSyn1;
+  END term;
+
+(* ==================================================================== *)
+
+  PROCEDURE  relation() : INTEGER;
+    VAR oSyn : INTEGER;
+  BEGIN
+    CASE nextT.sym OF
+    | T.equalSym :
+        Get; oSyn := Xp.equal;
+    | T.hashSym :
+        Get; oSyn := Xp.notEq;
+    | T.lessSym :
+        Get; oSyn := Xp.lessT;
+    | T.lessequalSym :
+        Get; oSyn := Xp.lessEq;
+    | T.greaterSym :
+        Get; oSyn := Xp.greT;
+    | T.greaterequalSym :
+        Get; oSyn := Xp.greEq;
+    | T.INSym :
+        Get; oSyn := Xp.inOp;
+    | T.ISSym :
+        Get; oSyn := Xp.isOp;
+    ELSE
+      Error(86); oSyn := Xp.equal;
+    END;
+    RETURN oSyn;
+  END relation;
+
+(* ==================================================================== *)
+
+  PROCEDURE  simpleExpression(scope : Sy.Scope) : Sy.Expr;
+    VAR opNeg : BOOLEAN;
+        addOp : INTEGER;
+        term1 : Sy.Expr;
+        term2 : Sy.Expr;
+        saveT : S.Token;
+  BEGIN
+    opNeg := FALSE;
+    IF nextT.sym = T.minusSym THEN
+      Get; opNeg := TRUE;
+    ELSIF nextT.sym = T.plusSym THEN
+      Get;
+    END;
+    term1 := term(scope);
+    IF opNeg THEN term1 := Xp.newUnaryX(Xp.neg, term1) END;
+    WHILE (nextT.sym = T.minusSym) OR
+          (nextT.sym = T.plusSym) OR
+          (nextT.sym = T.ORSym) DO
+      addOp := addOperator(); saveT := token;
+      term2 := term(scope);
+      term1 := Xp.newBinaryT(addOp, term1, term2, saveT);
+    END;
+    RETURN term1;
+  END simpleExpression;
+
+(* ==================================================================== *)
+
+  PROCEDURE  OptExprList(VAR xList : Sy.ExprSeq; inhScp : Sy.Scope);
+  BEGIN
+    IF in(symSet[3], nextT.sym) THEN
+      ExprList(xList, inhScp);
+    ELSE      (* empty list *)
+      xList.ResetTo(0);
+    END;
+  END OptExprList;
+
+(* ==================================================================== *)
+
+  PROCEDURE  ExprList(VAR xList : Sy.ExprSeq; inhScp : Sy.Scope);
+  BEGIN
+   (*
+    *  To avoid aliassing, ALWAYS Discard old sequence.
+    *)
+    Sy.InitExprSeq(xList, 4);
+    Sy.AppendExpr(xList, expression(inhScp));
+    WHILE (nextT.sym = T.commaSym) DO
+      Get;
+      Sy.AppendExpr(xList, expression(inhScp));
+    END;
+  END ExprList;
+
+(* ==================================================================== *)
+
+  PROCEDURE findMatchingProcs(oId      : Id.OvlId; 
+                              actuals  : Sy.ExprSeq;
+                              VAR rslt : Id.PrcSeq);
+  VAR
+    index : INTEGER;
+    visited : Id.PrcSeq;
+    rec : Ty.Record;
+    id : Sy.Idnt;
+    prcTy : Ty.Procedure;
+    finished : BOOLEAN;
+
+    PROCEDURE seen(newP : Ty.Procedure; visited : Id.PrcSeq) : BOOLEAN;
+    VAR
+      index : INTEGER;
+    BEGIN
+      FOR index := 0 TO visited.tide-1 DO
+        IF newP.sigsMatch(visited.a[index].type) THEN RETURN TRUE; END;
+      END;
+      RETURN FALSE;
+    END seen;
+
+  BEGIN
+    Id.InitPrcSeq(rslt,1);
+    Id.InitPrcSeq(visited,5);
+    rec := oId.rec(Ty.Record);
+    id := oId;
+    finished := id = NIL;
+    WHILE ~finished & (id # NIL) DO
+      WITH id : Id.OvlId DO
+        FOR index := 0 TO id.list.tide-1 DO
+          prcTy := id.list.a[index].type(Ty.Procedure);
+          IF Xp.MatchPars(prcTy.formals,actuals) & ~seen(prcTy,rslt) THEN
+            Id.AppendProc(rslt,id.list.a[index]);
+          END;
+        END;
+      | id : Id.Procs DO
+          prcTy := id.type(Ty.Procedure);
+          IF Xp.MatchPars(prcTy.formals,actuals) & ~seen(prcTy,rslt) THEN
+            Id.AppendProc(rslt,id);
+          END;
+          finished := TRUE;
+      ELSE
+        finished := TRUE;
+      END;
+      IF (rec.baseTp = NIL) OR (rec.baseTp = Ty.anyRecTp) THEN
+        finished := TRUE;
+      ELSE
+        rec := rec.baseTp.boundRecTp()(Ty.Record);
+        id := rec.symTb.lookup(oId.hash);
+      END;
+    END;
+  END findMatchingProcs;
+
+  PROCEDURE FindBestMatch(IN actuals : Sy.ExprSeq; IN procs : Id.PrcSeq;
+                           OUT match : BOOLEAN; OUT ix : INTEGER);
+  VAR pIx : INTEGER;
+      pTy : Ty.Procedure;
+
+    PROCEDURE IsSameAs(lhs : Sy.Type; rhs : Sy.Type) : BOOLEAN;
+    BEGIN
+      IF lhs = rhs THEN RETURN TRUE;
+      ELSE RETURN lhs.equalType(rhs);
+      END;
+    END IsSameAs;
+
+    PROCEDURE IsSameWithNativeCoercions(lhs : Sy.Type; rhs : Sy.Type) : BOOLEAN;
+    BEGIN
+      IF lhs = rhs THEN RETURN TRUE;
+      ELSIF lhs.isStringType() & rhs.isStringType() THEN RETURN TRUE;
+      ELSIF lhs.isNativeObj() & rhs.isNativeObj() THEN RETURN TRUE;
+      ELSE RETURN lhs.equalType(rhs);
+      END;
+    END IsSameWithNativeCoercions;
+
+
+
+  BEGIN
+    match := FALSE;
+    ix := 0;  
+    WHILE ~match & (ix < procs.tide) DO
+      pIx := 0; match := TRUE;
+      WHILE match & (pIx < actuals.tide) DO
+        pTy := procs.a[ix].type(Ty.Procedure);
+        match := IsSameAs(actuals.a[pIx].type, pTy.formals.a[pIx].type);
+        INC(pIx);
+      END;
+      IF ~match THEN INC(ix) ELSE RETURN END;
+    END;
+    ix := 0;  
+    WHILE ~match & (ix < procs.tide) DO
+      pIx := 0; match := TRUE;
+      WHILE match & (pIx < actuals.tide) DO
+        pTy := procs.a[ix].type(Ty.Procedure);
+        match := IsSameWithNativeCoercions(actuals.a[pIx].type, pTy.formals.a[pIx].type);
+        INC(pIx);
+      END;
+      IF ~match THEN INC(ix) END;
+    END;
+    IF ~match THEN ix := 0 END;
+  END FindBestMatch;
+                              
+(* ==================================================================== *)
+
+  PROCEDURE makeCall(xCr        : Sy.Expr; 
+                     IN actuals : Sy.ExprSeq;
+                     inhScp     : Sy.Scope) : Sy.Expr;
+  VAR
+    procs : Id.PrcSeq;
+    moreThanOne, found : BOOLEAN;
+    oId : Id.OvlId;
+    prcTy : Ty.Procedure;
+    index, pIx, err : INTEGER;
+    nam : LitValue.CharOpen;
+
+   (* ------------------------- *)
+
+    PROCEDURE RepMulErr(eNo : INTEGER; 
+                        pNam : LitValue.CharOpen; 
+                        frmSeq : Id.ParSeq);
+    VAR
+      ix : INTEGER;
+      len : INTEGER;
+      par : Id.ParId;
+      cSeq : LitValue.CharOpenSeq;
+
+    BEGIN
+      LitValue.InitCharOpenSeq(cSeq,3);
+      LitValue.AppendCharOpen(cSeq,pNam);
+      LitValue.AppendCharOpen(cSeq,LitValue.strToCharOpen("("));
+      len := frmSeq.tide - 1;
+      FOR ix := 0 TO len DO
+        par := frmSeq.a[ix];
+        LitValue.AppendCharOpen(cSeq,par.type.name());
+        IF ix < len THEN LitValue.AppendCharOpen(cSeq,comma) END;
+      END;
+      LitValue.AppendCharOpen(cSeq,LitValue.strToCharOpen(")"));
+      S.SemError.RepSt1(eNo, LitValue.arrayCat(cSeq)^, token.lin, 0);
+    END RepMulErr;
+
+   (* ------------------------- *)
+
+    PROCEDURE CheckSuper(xIn : Xp.IdentX);
+      VAR fld : Sy.Idnt;      (* Selector identifier  *)
+          sId : Sy.Idnt;      (* Super method ident *)
+          mth : Id.MthId;     (* Method identifier  *)
+          rcT : Ty.Record;    (* Method bound recType *)
+    BEGIN
+      fld := xIn.ident;
+(*
+ *    Console.WriteLn;
+ *    fld.Diagnose(0);
+ *    Console.WriteLn;
+ *)
+      IF (fld.kind # Id.conMth) & (fld.kind # Id.fwdMth) THEN
+        SemError(119);      (* super call invalid   *)
+      ELSE          (* OK, fld is a method  *)
+       (* Find the receiver type, and check in scope of base type. *)
+        mth := fld(Id.MthId);
+        rcT := mth.bndType(Ty.Record);
+        IF (rcT # NIL) &
+           (rcT.baseTp # NIL) &
+           (rcT.baseTp.kind = Ty.recTp) THEN
+         (*
+          *  Bind to the overridden method, not necessarily
+          *  defined in the immediate supertype.
+          *)
+          sId := rcT.baseTp(Ty.Record).bindField(fld.hash);
+         (*
+          *  Inherited method could be overloaded
+          *  Find single sId that matches mth
+          *)
+          IF (sId # NIL) & (sId IS Id.OvlId) THEN
+            sId := sId(Id.OvlId).findProc(mth);
+(*
+ *          IF sId # NIL THEN
+ *            Console.WriteLn;
+ *            sId.Diagnose(0);
+ *            Console.WriteLn;
+ *          END;
+ *)
+          END;
+         (*
+          *  Now check various semantic constraints
+          *)
+          IF (sId # NIL) & (sId IS Id.MthId) THEN
+            IF sId(Id.MthId).mthAtt * Id.mask # Id.extns THEN
+              SemError(118);    (* call empty or abstract *)
+            ELSE
+              xIn.ident := sId;
+              xIn.type  := sId.type;
+            END;
+          ELSE
+            SemError(120);      (* unknown super method *)
+          END;
+        ELSE
+          SemError(120);      (* unknown super method *)
+        END;
+      END;
+    END CheckSuper;
+
+   (* ------------------------- *)
+  BEGIN
+    moreThanOne := FALSE;
+    IF (xCr = NIL) OR (xCr.type = NIL) OR (xCr IS Xp.CallX) THEN
+      RETURN xCr;
+    END;
+    pIx := 0;
+    IF xCr.type.kind = Ty.ovlTp THEN
+      oId := xCr.type.idnt(Id.OvlId);
+      nam := Sy.getName.ChPtr(oId);
+      Xp.AttributePars(actuals);
+      findMatchingProcs(oId,actuals,procs);
+      IF procs.tide = 0 THEN
+        SemError(218);
+        RETURN NIL;
+      ELSIF procs.tide > 1 THEN
+        FindBestMatch(actuals,procs,found,pIx);
+        IF ~found THEN err := 220 ELSE err := 312 END;
+        FOR index := 0 TO procs.tide-1 DO
+          IF ~(found & (index = pIx)) THEN (* just for info *)
+            RepMulErr(err,nam,procs.a[index].type(Ty.Procedure).formals);
+          END;
+        END;
+        IF found THEN
+          RepMulErr(313,nam,procs.a[pIx].type(Ty.Procedure).formals);
+          SemError(307);
+        ELSE
+          SemError(219);
+          RETURN NIL;
+        END;
+      END;
+      WITH xCr : Xp.IdLeaf DO
+        xCr.ident := procs.a[pIx];
+        xCr.type := xCr.ident.type;
+      | xCr : Xp.IdentX DO
+        xCr.ident := procs.a[pIx];
+        xCr.type := xCr.ident.type;
+      END;
+    END;
+   (*
+    *   Overloading (if any) is by now resolved.
+    *   Now check for super calls.  See if 
+    *   we can find a match for xCr.ident
+    *   in the supertype of 
+    *   -  xCr.kid.ident(Id.MthId).bndType
+    *)
+    IF xCr.kind = Xp.sprMrk THEN
+      CheckSuper(xCr(Xp.IdentX));
+    END;
+   (*
+    *   Now create CallX node in tree.
+    *)
+    IF (xCr.type.kind # Ty.prcTp) &
+       (xCr.type.kind # Ty.evtTp) THEN
+      xCr.ExprError(224); RETURN NIL;
+    ELSIF xCr.type.isProperProcType() THEN
+      xCr := Xp.newCallX(Xp.prCall, actuals, xCr);
+      xCr.NoteCall(inhScp);  (* note "inhScp" calls "eSyn.kid" *)
+    ELSE
+      xCr := Xp.newCallX(Xp.fnCall, actuals, xCr);
+      xCr := Xp.checkCall(xCr(Xp.CallX));
+      IF (xCr # NIL) THEN
+        xCr.NoteCall(inhScp);  (* note "inhScp" calls "eSyn.kid" *)
+        IF (xCr IS Xp.CallX) & (xCr(Xp.CallX).kid.kind = Xp.sprMrk) THEN
+          Xp.CheckSuper(xCr(Xp.CallX), inhScp);
+        END;
+      END;
+    END;
+    RETURN xCr;
+  END makeCall;
+
+   (* ------------------------- *)
+
+  PROCEDURE findFieldId(id : Id.OvlId) : Sy.Idnt;
+  VAR
+    fId : Sy.Idnt;
+    rec : Ty.Record;
+    ident : Sy.Idnt;
+  BEGIN
+    IF id = NIL THEN RETURN NIL END;
+    fId := id.fld;
+    rec := id.rec(Ty.Record);
+    WHILE (fId = NIL) & (rec.baseTp # NIL) & (rec.baseTp IS Ty.Record) DO
+      rec := rec.baseTp(Ty.Record);
+      ident := rec.symTb.lookup(id.hash);
+      IF ident IS Id.OvlId THEN
+        fId := ident(Id.OvlId).fld;
+      ELSIF (ident.kind = Id.fldId) OR (ident.kind = Id.varId) OR
+            (ident.kind = Id.conId) THEN
+        fId := ident;
+      END;
+    END;
+    RETURN fId;
+  END findFieldId;
+
+   (* ------------------------- *)
+
+  PROCEDURE FindOvlField(e : Sy.Expr);
+  BEGIN
+    ASSERT(e.type.kind = Ty.ovlTp);
+    WITH e : Xp.IdentX DO
+      e.ident := findFieldId(e.ident(Id.OvlId));
+      IF e.ident = NIL THEN
+        e.ExprError(9);
+      ELSE
+        e.type := e.ident.type;
+      END;
+    | e : Xp.IdLeaf DO
+      e.ident := findFieldId(e.ident(Id.OvlId));
+      IF e.ident = NIL THEN
+        e.ExprError(9);
+      ELSE
+        e.type := e.ident.type;
+      END;
+    END;
+  END FindOvlField;
+
+   (* ------------------------- *)
+
+  PROCEDURE ConvertOverloaded(VAR e : Sy.Expr);
+  BEGIN
+    IF (e # NIL) & (e.type IS Ty.Overloaded) THEN
+(*
+ *    WITH e : Xp.IdentX DO
+ *      e.ident := e.ident(Id.OvlId).fld;
+ *      IF (e.ident = NIL) THEN
+ *        SemErrorT(9, e.token);
+ *      ELSE
+ *        e.type := e.ident.type;
+ *      END;
+ *    END;
+ *)
+      WITH e : Xp.IdentX DO
+          e.ident := e.ident(Id.OvlId).fld;
+          IF (e.ident = NIL) THEN
+            SemErrorT(9, e.token);
+          ELSE
+            e.type := e.ident.type;
+          END;
+      | e : Xp.IdLeaf DO
+          e.ident := e.ident(Id.OvlId).fld;
+          IF (e.ident = NIL) THEN
+            SemErrorT(9, e.token);
+          ELSE
+            e.type := e.ident.type;
+          END;
+      END;
+    END;
+  END ConvertOverloaded;
+
+(* ==================================================================== *)
+
+  PROCEDURE MethAttributes(pDesc : Id.Procs);
+    VAR mAtt : SET;
+        hash : INTEGER;
+   (* ------------------------- *)
+    PROCEDURE CheckBasecall(proc : Id.Procs);
+      VAR idx : INTEGER;
+          rec : Sy.Type;
+          bRc : Ty.Record;
+          sId : Sy.Idnt;
+          bas : Id.BaseCall;
+          sTp : Ty.Procedure;
+          seq : Id.PrcSeq;
+          mOk : BOOLEAN;
+    BEGIN
+      bRc := NIL;
+      bas := proc.basCll;
+      rec := proc.type.returnType();
+      IF rec # NIL THEN rec := rec.boundRecTp(); bRc := rec(Ty.Record) END;
+      IF rec # NIL THEN rec := rec(Ty.Record).baseTp END;
+      IF rec # NIL THEN rec := rec.boundRecTp() END;
+     (*
+      *  Compute the apparent type of each actual.
+      *)
+      FOR idx := 0 TO bas.actuals.tide - 1 DO
+        bas.actuals.a[idx] := bas.actuals.a[idx].exprAttr();
+      END;
+     (*
+      *  Now try to find matching super-ctor.
+      *  IF there are not actuals, then assume the existence of
+      *  a noarg constructor.  TypeDesc.okToList will check this!
+      *)
+      IF bas.actuals.tide # 0 THEN 
+        WITH rec : Ty.Record DO
+          FOR idx := 0 TO rec.statics.tide - 1 DO
+            sId := rec.statics.a[idx];
+           (*
+            *  If this is a .ctor, then try to match arguments ...
+            *)
+            IF sId.kind = Id.ctorP THEN
+              sTp := sId.type(Ty.Procedure);
+              IF  Xp.MatchPars(sTp.formals, bas.actuals) THEN
+                Id.AppendProc(seq, sId(Id.Procs));
+              END;
+            END;
+          END;
+        END;
+      ELSE
+        Id.AppendProc(seq, NIL);
+      END;
+      IF seq.tide = 0 THEN SemError(202);
+      ELSIF seq.tide = 1 THEN bas.sprCtor := seq.a[0];
+      ELSE 
+        FindBestMatch(bas.actuals, seq, mOk, idx);
+        IF mOk THEN bas.sprCtor := seq.a[idx] ELSE SemError(147) END;
+      END;
+      IF bRc # NIL THEN 
+        Sy.AppendIdnt(bRc.statics, proc);
+       (*
+        *  And, while we are at it, if this is a no-arg
+        *  constructor, suppress emission of the default.
+        *)
+        IF proc.locals.tide = 1 THEN INCL(bRc.xAttr, Sy.xCtor) END;
+      END;
+    END CheckBasecall;
+   (* ------------------------- *)
+    PROCEDURE DummyParameters(VAR seq : Sy.ExprSeq; prT : Ty.Procedure);
+      VAR idx : INTEGER;
+          idl : Xp.IdLeaf;
+    BEGIN
+      FOR idx := 0 TO prT.formals.tide - 1 DO
+        idl := Xp.mkIdLeaf(prT.formals.a[idx]);
+        idl.type := idl.ident.type;
+        Sy.AppendExpr(seq, idl);
+      END;
+    END DummyParameters;
+   (* ------------------------- *)
+    PROCEDURE InsertSelf(prc : Id.Procs);
+      VAR par : Id.ParId;
+          tmp : Sy.IdSeq;
+          idx : INTEGER;
+    BEGIN
+      par := Id.newParId();
+      par.hash := Bi.selfBk;
+      par.dfScp := prc;
+      par.parMod := Sy.in; (* so it is read only *)
+      par.varOrd := 0;     (* both .NET and JVM  *)
+      par.type := prc.type.returnType();
+      ASSERT(prc.symTb.enter(par.hash, par));
+     (*
+      *  Now adjust the locals sequence.
+      *)
+      Sy.AppendIdnt(tmp, par);
+      FOR idx := 0 TO prc.locals.tide-1 DO
+        Sy.AppendIdnt(tmp, prc.locals.a[idx]);
+        prc.locals.a[idx](Id.AbVar).varOrd := idx+1;
+      END;
+      prc.locals := tmp;
+    END InsertSelf;
+   (* ------------------------- *)
+  BEGIN
+    mAtt := {};
+    IF nextT.sym = T.NEWSym THEN
+      Get;
+      mAtt := Id.isNew;
+      IF nextT.sym = T.commaSym THEN Get; mAtt := otherAtts(mAtt) END;
+    ELSIF nextT.sym = T.identSym THEN
+      hash := NameHash.enterSubStr(nextT.pos, nextT.len);
+      IF (hash = Bi.constB) OR (hash = Bi.basBkt) THEN 
+        Get;
+        IF G.strict THEN SemError(221); END;
+        NEW(pDesc.basCll);
+        IF hash = Bi.basBkt THEN 
+          pDesc.basCll.empty := FALSE;
+          ActualParameters(pDesc.basCll.actuals, pDesc);
+         (*
+          *  Insert the arg0 identifier "SELF"
+          *)
+          InsertSelf(pDesc);
+        ELSE
+          pDesc.basCll.empty := TRUE;
+          DummyParameters(pDesc.basCll.actuals, pDesc.type(Ty.Procedure));
+        END;
+        CheckBasecall(pDesc);
+        pDesc.SetKind(Id.ctorP);
+      END;
+    ELSIF (nextT.sym = T.ABSTRACTSym)   OR
+          (nextT.sym = T.EXTENSIBLESym) OR
+          (nextT.sym = T.EMPTYSym) THEN
+      mAtt := otherAtts({});
+    ELSE
+      Error(78);
+    END;
+    IF pDesc IS Id.MthId THEN
+      pDesc(Id.MthId).mthAtt := mAtt;
+      IF pDesc.kind = Id.ctorP THEN SemError(146) END;
+    ELSIF pDesc.kind # Id.ctorP THEN
+      SemError(61);
+    END;
+  END MethAttributes;
+
+(* ==================================================================== *)
+
+  PROCEDURE getTypeAssertId(lst : Sy.ExprSeq) : Sy.Idnt;
+  VAR
+    lf : Xp.IdLeaf;
+  BEGIN
+    IF (lst.tide = 1) & (lst.a[0] IS Xp.IdLeaf) THEN
+      lf := lst.a[0](Xp.IdLeaf);
+      IF lf.ident IS Id.TypId THEN RETURN lf.ident; END;
+    END;
+    RETURN NIL;
+  END getTypeAssertId;
+
+(* ==================================================================== *)
+
+  PROCEDURE  designator(inhScp : Sy.Scope) : Sy.Expr;
+    VAR eSyn : Sy.Expr;     (* the synthesized expression attribute *)
+        qual : Sy.Idnt;     (* the base qualident of the designator *)
+        iLst : Sy.ExprSeq;  (* a list of array index expressions  *)
+        exTp : Sy.Type;
+        isTp : BOOLEAN;
+
+   (* ------------------------- *)
+
+    PROCEDURE implicitDerefOf(wrkX : Sy.Expr) : Sy.Expr;
+    (* Make derefs explicit, returning NIL if invalid pointer type. *)
+      VAR wrkT : Sy.Type;
+          bndT : Sy.Type;
+    save : S.Token;
+    BEGIN
+      IF (wrkX # NIL) &
+         (wrkX.type # NIL) THEN
+        wrkT := wrkX.type;
+        WITH wrkT : Ty.Pointer DO
+            bndT := wrkT.boundTp;
+            IF bndT = NIL THEN RETURN NIL END;
+            save := wrkX.token;
+            wrkX := Xp.newUnaryX(Xp.deref, wrkX);
+            wrkX.token := save;   (* point to the same token  *)
+            wrkX.type  := bndT;   (* type is bound type of ptr. *)
+        | wrkT : Ty.Base DO
+            IF wrkT = Ty.anyPtrTp THEN
+              save := wrkX.token;
+              wrkX := Xp.newUnaryX(Xp.deref, wrkX);
+              wrkX.token := save;
+              wrkX.type  := Ty.anyRecTp;
+            END;
+        | wrkT : Ty.Event DO
+            wrkX.type := wrkT.bndRec;
+        ELSE (* skip *)
+        END;
+      END;
+      RETURN wrkX;
+    END implicitDerefOf;
+
+   (* ------------------------- *)
+
+    PROCEDURE checkRecord(xIn : Sy.Expr;        (* referencing expression *)
+                          tok : S.Token;        (* field/procedure ident  *)
+                          scp : Sy.Scope;       (* current scope of ref.  *)
+                          tId : BOOLEAN) : Sy.Expr; (* left context is tp *)
+      VAR fId : Sy.Idnt;    (* the field identifier desc. *)
+          xNw : Sy.Expr;
+     (* ------------------------- *)
+      PROCEDURE Rep162(f : Sy.Idnt);
+      BEGIN SemErrorS1(162, Sy.getName.ChPtr(f)) END Rep162;
+     (* ------------------------- *)
+    BEGIN       (* quit at first trouble sign *)
+      ConvertOverloaded(xIn);
+      xNw := implicitDerefOf(xIn);
+      IF (xNw = NIL) OR (xNw.type = NIL) THEN RETURN NIL END;
+      IF (xNw.type.kind # Ty.recTp) &
+         (xNw.type.kind # Ty.enuTp) THEN SemError(8); RETURN NIL END;
+      fId := bindFieldToken(xNw.type, tok);
+      IF fId = NIL THEN
+        SemErrorS1(9, xIn.type.name()); RETURN NIL;
+      ELSE
+        IF tId THEN (* fId must be a foreign, static feature! *)
+          IF fId IS Id.FldId THEN SemError(196) END;
+          IF fId IS Id.MthId THEN SemError(197) END;
+          xNw := Xp.mkIdLeaf(fId);
+        ELSE
+          WITH fId : Id.VarId DO SemError(198);
+             | fId : Id.PrcId DO SemError(199);
+             | fId : Id.MthId DO
+                 IF fId.callForbidden() THEN SemErrorT(127, tok) END;
+(*
+ *               IF (fId.vMod = Sy.rdoMode) &
+ *                  xNw.type.isImportedType() THEN SemErrorT(127, tok) END;
+ *)
+
+          ELSE (* skip *)
+          END;
+          xNw := Xp.newIdentX(Xp.selct, fId, xNw);
+        END;
+        IF fId.vMod = Sy.protect THEN
+         (*
+          *  If fId is a protected feature (and hence
+          *  foreign) then the context must be a method
+          *  body.  Furthermore, the method scope must
+          *  be derived from the field's defining scope.
+          *)
+          WITH scp : Id.MthId DO
+            IF ~xIn.type.isBaseOf(scp.rcvFrm.type) THEN Rep162(fId) END;
+          ELSE
+            Rep162(fId);
+          END;
+        END;
+        IF (fId.type # NIL) &
+           (fId.type IS Ty.Opaque) THEN
+           (* ------------------------------------------- *
+            *  Permanently fix the field type attribute.
+            * ------------------------------------------- *)
+          fId.type := fId.type.elaboration();
+        END;
+        xNw.type := fId.type;
+        RETURN xNw;
+      END;
+    END checkRecord;
+
+   (* ------------------------- *)
+
+    PROCEDURE checkArray(xCr : Sy.Expr; IN seq : Sy.ExprSeq) : Sy.Expr;
+      VAR xTp : Sy.Type;    (* type of current expr xCr *)
+          aTp : Ty.Array;   (* current array type of expr *)
+          iCr : Sy.Expr;    (* the current index expression *)
+          idx : INTEGER;    (* index into expr. sequence  *)
+          tok : S.Token;
+    BEGIN       (* quit at first trouble sign *)
+      ConvertOverloaded(xCr);
+      tok := xCr.token;
+      FOR idx := 0 TO seq.tide-1 DO
+        xCr := implicitDerefOf(xCr);
+        IF xCr # NIL THEN xTp := xCr.type ELSE RETURN NIL END;
+(* ----------- * 
+ *      IF xTp.kind # Ty.arrTp THEN
+ *        IF idx = 0 THEN xCr.ExprError(10) ELSE xCr.ExprError(11) END;
+ *        RETURN NIL;
+ *      ELSE
+ *        aTp := xTp(Ty.Array);
+ *      END;
+ * ----------- *) 
+        WITH xTp : Ty.Array DO
+          aTp := xTp(Ty.Array);
+        ELSE
+          IF idx = 0 THEN xCr.ExprError(10) ELSE xCr.ExprError(11) END;
+          RETURN NIL;
+        END;
+(* ----------- *) 
+        xTp := aTp.elemTp;
+        iCr := seq.a[idx];
+        IF iCr # NIL THEN iCr := iCr.exprAttr() END;
+        IF iCr # NIL THEN    (* check is integertype , literal in range *)
+          IF ~iCr.isIntExpr() THEN iCr.ExprError(31) END;
+          IF iCr.type = Bi.lIntTp THEN
+            iCr := Xp.newIdentX(Xp.cvrtDn, Bi.intTp.idnt, iCr);
+          END;
+          IF iCr.isNumLit() & ~iCr.inRangeOf(aTp) THEN iCr.ExprError(32) END;
+          tok := iCr.token;
+        END;
+        xCr := Xp.newBinaryT(Xp.index, xCr, iCr, tok);
+        IF xTp # NIL THEN xCr.type := xTp ELSE RETURN NIL END;
+      END;
+      RETURN xCr;
+    END checkArray;
+
+   (* ------------------------- *)
+
+    PROCEDURE checkTypeAssert(xpIn : Sy.Expr; tpId : Sy.Idnt) : Sy.Expr;
+      VAR dstT : Sy.Type;
+          recT : Ty.Record;
+    BEGIN
+      IF xpIn.type.kind = Ty.ovlTp THEN FindOvlField(xpIn); END;
+      IF (xpIn = NIL) OR (tpId = NIL) OR (tpId.type = NIL) THEN RETURN NIL END;
+      dstT := tpId.type;
+      recT := dstT.boundRecTp()(Ty.Record);
+     (* Check #1 : qualident must be a [possibly ptr to] record type  *)
+      IF recT = NIL THEN SemError(18); RETURN NIL END;
+     (* Check #2 : Check that the expression has some dynamic type  *)
+      IF ~xpIn.hasDynamicType() THEN xpIn.ExprError(17); RETURN NIL END;
+      IF dstT.kind = Ty.recTp THEN xpIn := implicitDerefOf(xpIn) END;
+     (* Check #3 : Check that manifest type is a base of asserted type  *)
+      IF G.extras THEN
+        IF ~xpIn.type.isBaseOf(dstT) &
+           ~xpIn.type.isInterfaceType() &
+           ~dstT.isInterfaceType() &
+           ~(dstT.isCompoundType() & recT.compoundCompat(xpIn.type) ) &
+           ~dstT.isEventType() THEN SemError(15); RETURN NIL END;
+
+      ELSE
+        IF ~xpIn.type.isBaseOf(dstT) &
+           ~xpIn.type.isInterfaceType() &
+           ~dstT.isInterfaceType() &
+           ~dstT.isEventType() &
+           ~Ty.isBoxedStruct(xpIn.type, dstT) THEN SemError(15); RETURN NIL END;
+      END; (* IF G.extras *)
+     (* Geez, it seems to be ok! *)
+      xpIn := Xp.newUnaryX(Xp.tCheck, xpIn);
+      xpIn.type := dstT;
+      RETURN xpIn;
+    END checkTypeAssert;
+
+   (* ------------------------- *)
+
+    PROCEDURE mkSuperCall(xIn : Sy.Expr) : Sy.Expr;
+      VAR new : Sy.Expr;
+    BEGIN
+      new := NIL;
+      WITH xIn : Xp.IdentX DO
+        new := Xp.newIdentX(Xp.sprMrk, xIn.ident, xIn.kid);
+        new.type := xIn.ident.type;
+      ELSE
+        SemError(119);        (* super call invalid   *)
+      END;
+      RETURN new;
+    END mkSuperCall;
+
+   (* ------------------------- *)
+
+    PROCEDURE stringifier(xIn : Sy.Expr) : Sy.Expr;
+    BEGIN
+      xIn := implicitDerefOf(xIn);
+      IF xIn.isCharArray() THEN
+        xIn := Xp.newUnaryX(Xp.mkStr, xIn);
+        xIn.type := Bi.strTp;
+      ELSE
+        SemError(41); RETURN NIL;
+      END;
+      RETURN xIn;
+    END stringifier;
+
+   (* ------------------------- *)
+
+    PROCEDURE explicitDerefOf(wrkX : Sy.Expr) : Sy.Expr;
+    (* Make derefs explicit, returning NIL if invalid pointer type. *)
+      VAR expT, bndT : Sy.Type;
+    BEGIN
+      expT := wrkX.type;
+      WITH expT : Ty.Pointer DO
+          bndT := expT.boundTp;
+          IF bndT = NIL THEN RETURN NIL END;
+          wrkX := Xp.newUnaryX(Xp.deref, wrkX);
+          wrkX.type  := bndT;     (* type is bound type of ptr. *)
+      | expT : Ty.Base DO
+          IF expT = Ty.anyPtrTp THEN
+            wrkX := Xp.newUnaryX(Xp.deref, wrkX);
+            wrkX.type  := Ty.anyRecTp;  (* type is bound type of ptr. *)
+          ELSE
+            SemError(12); RETURN NIL; (* expr. not a pointer type *)
+          END;
+      | expT : Ty.Overloaded DO RETURN mkSuperCall(wrkX);
+      | expT : Ty.Procedure  DO RETURN mkSuperCall(wrkX);
+(*
+ *    | expT : Ty.Procedure DO
+ *        RETURN checkSuperCall(wrkX);
+ *)
+      ELSE
+        SemError(12); RETURN NIL; (* expr. not a pointer type *)
+      END;
+      RETURN wrkX;
+    END explicitDerefOf;
+
+   (* ------------------------- *)
+
+    PROCEDURE ReportIfOpaque(exp : Sy.Expr);
+    BEGIN
+      IF (exp # NIL) &
+         (exp.type # NIL) &
+         (exp.type.kind = Ty.namTp) &
+         (exp.type.idnt # NIL) &
+         (exp.type.idnt.dfScp # NIL) &
+          exp.type.idnt.dfScp.isWeak() THEN
+        SemErrorS1(176, Sy.getName.ChPtr(exp.type.idnt.dfScp));
+      END;
+    END ReportIfOpaque;
+
+   (* ------------------------- *)
+
+  BEGIN         (* body of designator *)
+   (* --------------------------------------------------------- *
+    *  First deal with the qualified identifier part.   *
+    * --------------------------------------------------------- *)
+    qual := qualident(inhScp);
+    IF (qual # NIL) & (qual.type # NIL) THEN
+      eSyn := Xp.mkIdLeaf(qual);
+      eSyn.type := qual.type;
+      isTp := qual IS Id.TypId;
+    ELSE
+      eSyn := NIL;
+      isTp := FALSE;
+    END;
+   (* --------------------------------------------------------- *
+    *  Now deal with each selector, in sequence, by a loop.     *
+    *  It is an invariant of this loop, that if eSyn # NIL,     *
+    *  the expression has a valid, non-NIL type value.          *
+    * --------------------------------------------------------- *)
+    WHILE (nextT.sym = T.pointSym)   OR
+          (nextT.sym = T.lparenSym)  OR
+          (nextT.sym = T.lbrackSym)  OR
+          (nextT.sym = T.uparrowSym) OR
+          (nextT.sym = T.dollarSym)  DO
+     (* ------------------------------------------------------- *
+      *  If this is an opaque, resolve it if possible
+      * ------------------------------------------------------- *)
+      IF (eSyn # NIL) & (eSyn.type IS Ty.Opaque) THEN
+        eSyn.type := eSyn.type.elaboration();
+        IF eSyn.type IS Ty.Opaque THEN ReportIfOpaque(eSyn) END;
+      END;
+     (* ------------------------------------------------------- *
+      *  If expr is typeName, must be static feature selection
+      * ------------------------------------------------------- *)
+      IF isTp &
+         (eSyn # NIL) &
+         (eSyn IS Xp.IdLeaf) &
+         (nextT.sym # T.pointSym) THEN eSyn.ExprError(85) END;
+
+      IF nextT.sym = T.pointSym THEN
+     (* ------------------------------------------------------- *
+      *  This must be a field selection, or a method call
+      * ------------------------------------------------------- *)
+        Get;
+        Expect(T.identSym);
+       (* Check that this is a valid record type. *)
+        IF eSyn # NIL THEN eSyn := checkRecord(eSyn, token, inhScp, isTp) END;
+        isTp := FALSE;  (* clear the flag *)
+      ELSIF (nextT.sym = T.lbrackSym) THEN
+     (* ------------------------------------------------------- *
+      *  This must be a indexed selection on an array type
+      * ------------------------------------------------------- *)
+        Get;
+        ExprList(iLst, inhScp);
+        Expect(T.rbrackSym);
+       (* Check that this is a valid array type. *)
+        IF eSyn # NIL THEN eSyn := checkArray(eSyn, iLst) END;
+      ELSIF (nextT.sym = T.lparenSym) THEN
+     (* -------------------------------------------------------------- *
+      *  This could be a function/procedure call, or a type assertion  *
+      * -------------------------------------------------------------- *)
+        Get;
+        OptExprList(iLst, inhScp);
+        IF eSyn # NIL THEN
+          qual := getTypeAssertId(iLst);
+          IF (qual # NIL) & ~eSyn.isStdFunc() THEN
+           (* 
+            *  This must be a type test, so ...
+            *
+            *  This following test is inline in checkTypeAssert()
+            *     IF eSyn.type.kind = Ty.ovlTp THEN FindOvlField(eSyn); END; 
+            *)
+            eSyn := checkTypeAssert(eSyn,qual);
+          ELSIF (eSyn.type.kind = Ty.prcTp) OR 
+                (eSyn.type.kind = Ty.ovlTp) OR
+                (eSyn.type.kind = Ty.evtTp) THEN
+            (* A (possibly overloaded) function/procedure call *)
+            eSyn := makeCall(eSyn, iLst, inhScp);
+          ELSE          (* A syntax error.  *)
+            SemError(13);
+            eSyn := NIL;
+          END;
+        END;
+        Expect(T.rparenSym);
+        IF (eSyn # NIL) & (eSyn.kind = Xp.prCall) THEN RETURN eSyn; END;
+        (* Watch it! that was a semantically selected parser action.  *)
+      ELSIF (nextT.sym = T.uparrowSym) THEN
+     (* ------------------------------------------------------- *
+      *  This can be an explicit dereference or a super call  *
+      * ------------------------------------------------------- *)
+        Get;
+        IF eSyn # NIL THEN eSyn := explicitDerefOf(eSyn) END;
+      ELSE
+     (* ------------------------------------------------------- *
+      *  This can only be an explicit make-string operator
+      * ------------------------------------------------------- *)
+        Get;
+        IF eSyn # NIL THEN eSyn := stringifier(eSyn) END;
+     (* ------------------------------------------------------- *)
+      END;
+    END;
+   (* ------------------------------------------------------- *
+    *  Some special case cleanup code for enums, opaques...
+    * ------------------------------------------------------- *)
+    IF eSyn # NIL THEN
+      IF isTp THEN
+        eSyn.type := Bi.metaTp;
+      ELSIF eSyn.type # NIL THEN
+        exTp := eSyn.type;
+        WITH exTp : Ty.Enum DO
+            eSyn.type := Bi.intTp;
+        | exTp : Ty.Opaque DO
+            eSyn.type := exTp.elaboration();
+        ELSE (* skip *)
+        END;
+      END;
+    END;
+    RETURN eSyn;
+  END designator;
+
+(* ==================================================================== *)
+
+  PROCEDURE FixAnon(defScp : Sy.Scope; tTyp : Sy.Type; mode : INTEGER);
+    VAR iSyn : Sy.Idnt;
+  BEGIN
+    IF (tTyp # NIL) & (tTyp.idnt = NIL) THEN
+      iSyn := Id.newAnonId(tTyp.serial);
+      iSyn.SetMode(mode);
+      tTyp.idnt := iSyn;
+      iSyn.type := tTyp;
+      ASSERT(CompState.thisMod.symTb.enter(iSyn.hash, iSyn));
+    END;
+  END FixAnon;
+
+(* ==================================================================== *)
+
+  PROCEDURE  VariableDeclaration(defScp : Sy.Scope);
+    VAR vSeq : Sy.IdSeq;  (* idents of the shared type     *)
+        tTyp : Sy.Type;   (* the shared variable type desc *)
+        indx : INTEGER;
+        neId : Sy.Idnt;   (* temp to hold Symbols.Idnet    *)
+        vrId : Id.AbVar;  (* same temp, but cast to VarId  *)
+        mOut : INTEGER;   (* maximum visibility of idlist  *)
+  BEGIN
+    IdentDefList(vSeq, defScp, Id.varId);
+    CheckVisibility(vSeq, Sy.pubMode, mOut); (* no errors! *)
+    Expect(T.colonSym);
+    tTyp := type(defScp, mOut);
+    IF mOut # Sy.prvMode THEN FixAnon(defScp, tTyp, mOut) END;
+(*
+ *  Expect(T.colonSym);
+ *  tTyp := type(defScp, Sy.prvMode); (* not sure about this? *)
+ *)
+    FOR indx := 0 TO vSeq.tide-1 DO
+      (* this works around a bug in the JVM boot compiler (kjg 7.jan.00) *)
+      neId := vSeq.a[indx];
+      vrId := neId(Id.AbVar);
+      (* ------------------------- *)
+      vrId.type := tTyp;
+      vrId.varOrd := defScp.locals.tide;
+      IF Sy.refused(vrId, defScp) THEN
+        vrId.IdError(4);
+      ELSE
+        Sy.AppendIdnt(defScp.locals, vrId);
+      END;
+    END;
+  END VariableDeclaration;
+
+(* ==================================================================== *)
+
+  PROCEDURE  FormalParameters(thsP : Ty.Procedure;
+                              proc : Id.Procs;
+                              scpe : Sy.Scope);
+    VAR group : Id.ParSeq;
+    (*  typId : Id.TypId; *)
+
+   (* --------------------------- *)
+    PROCEDURE EnterFPs(VAR grp, seq : Id.ParSeq; pSc, sSc : Sy.Scope);
+      VAR index : INTEGER;
+    param : Id.ParId;
+    BEGIN
+      FOR index := 0 TO grp.tide-1 DO
+        param := grp.a[index];
+        Id.AppendParam(seq, param);
+        IF pSc # NIL THEN
+          IF Sy.refused(param, pSc) THEN
+            param.IdError(20);
+          ELSE
+            param.varOrd := pSc.locals.tide;
+            param.dfScp  := pSc;
+            Sy.AppendIdnt(pSc.locals, param);
+          END;
+        END;
+      END;
+    END EnterFPs;
+   (* --------------------------- *)
+    PROCEDURE isPrivate(t : Sy.Type) : BOOLEAN;
+    BEGIN
+      RETURN ~(t IS Ty.Base) & (t.idnt.vMod = Sy.prvMode);
+    END isPrivate;
+   (* --------------------------- *)
+    PROCEDURE CheckRetType(tst : BOOLEAN; tok : S.Token; typ : Sy.Type);
+      VAR bndT : Sy.Type;
+    BEGIN
+      IF typ = NIL THEN RETURN;
+      ELSIF typ.kind = Ty.recTp THEN SemErrorT(78, tok);
+      ELSIF typ.kind = Ty.arrTp THEN SemErrorT(79, tok);
+      ELSIF typ.idnt # NIL THEN (* not anon *)
+        IF tst & isPrivate(typ) THEN SemErrorT(151, tok) END;
+      ELSIF typ.kind = Ty.ptrTp THEN 
+        bndT := typ(Ty.Pointer).boundTp;
+        IF tst & (bndT # NIL) & isPrivate(bndT) THEN SemErrorT(151, tok) END;
+      END;
+    END CheckRetType;
+   (* --------------------------- *)
+    PROCEDURE ReturnType(typ : Ty.Procedure; prc : Id.Procs; scp : Sy.Scope);
+      VAR tpRt : Sy.Type;
+          tokn : S.Token;
+          test : BOOLEAN;
+    BEGIN
+      Get; (* read past colon symbol *)
+      tokn := nextT;
+      tpRt := type(scp, Sy.prvMode);
+      typ.retType := tpRt;
+      test := ~G.special & (prc # NIL) & (prc.vMod = Sy.pubMode);
+      CheckRetType(test, tokn, tpRt);
+    END ReturnType;
+   (* --------------------------- *)
+  BEGIN
+    Get;        (* read past lparenSym  *)
+    IF (nextT.sym = T.identSym) OR
+       (nextT.sym = T.INSym) OR
+       (nextT.sym = T.VARSym) OR
+       (nextT.sym = T.OUTSym) THEN
+      FPSection(group, proc, scpe);
+      EnterFPs(group, thsP.formals, proc, scpe);
+
+      WHILE weakSeparator(22, 10, 11) DO
+        Id.ResetParSeq(group);
+        FPSection(group, proc, scpe);
+        EnterFPs(group, thsP.formals, proc, scpe);
+      END;
+    END;
+    Expect(T.rparenSym);
+    IF (nextT.sym = T.colonSym) THEN ReturnType(thsP, proc, scpe) END;
+  END FormalParameters;
+
+(* ==================================================================== *)
+
+  PROCEDURE CheckVisibility(seq : Sy.IdSeq; in : INTEGER; OUT out : INTEGER);
+    VAR ix : INTEGER;
+        id : Sy.Idnt;
+        md : INTEGER;
+  BEGIN
+    out := Sy.prvMode;
+    FOR ix := 0 TO seq.tide-1 DO
+      id := seq.a[ix];
+      md := id.vMod;
+      CASE in OF
+      | Sy.prvMode : IF md # Sy.prvMode THEN id.IdError(183) END;
+      | Sy.pubMode :
+      | Sy.rdoMode : IF md = Sy.pubMode THEN id.IdError(184) END;
+      END;
+      out := Sy.maxMode(md, out);
+    END;
+  END CheckVisibility;
+
+(* ==================================================================== *)
+
+  PROCEDURE  IdentDefList(OUT iSeq : Sy.IdSeq; 
+                              scp  : Sy.Scope; 
+                              kind : INTEGER);
+  BEGIN
+    Sy.AppendIdnt(iSeq, identDef(scp, kind));
+    WHILE (nextT.sym = T.commaSym) DO
+      Get;
+      Sy.AppendIdnt(iSeq, identDef(scp, kind));
+    END;
+  END IdentDefList;
+
+(* ==================================================================== *)
+
+  PROCEDURE  FieldList(recT   : Ty.Record;
+                       defScp : Sy.Scope;
+                       vMod   : INTEGER);
+    VAR list : Sy.IdSeq;
+        fTyp : Sy.Type;
+        fDsc : Id.FldId;
+        fIdx : INTEGER;
+        vOut : INTEGER;
+  BEGIN
+    IF nextT.sym = T.identSym THEN
+      IdentDefList(list, defScp, Id.fldId);
+      CheckVisibility(list, vMod, vOut);
+      Expect(T.colonSym);
+      fTyp := type(defScp, vOut);
+      IF vOut # Sy.prvMode THEN FixAnon(defScp, fTyp, vOut) END;
+
+      FOR fIdx := 0 TO list.tide-1 DO
+        fDsc := list.a[fIdx](Id.FldId);
+        fDsc.type := fTyp;
+        fDsc.recTyp := recT;
+        Sy.AppendIdnt(recT.fields, fDsc);
+      END;
+    END;
+  END FieldList;
+
+(* ==================================================================== *)
+
+  PROCEDURE FieldListSequence(recT   : Ty.Record;
+                              defScp : Sy.Scope;
+                              vMod   : INTEGER);
+    VAR start : INTEGER;
+        final : INTEGER;
+        index : INTEGER;
+        ident : Sy.Idnt;
+  BEGIN
+    start := recT.fields.tide;
+    FieldList(recT, defScp, vMod);
+    WHILE (nextT.sym = T.semicolonSym) DO
+      Get;
+      FieldList(recT, defScp, vMod);
+    END;
+    final := recT.fields.tide;
+   (* now insert into the fieldname scope *)
+    FOR index := start TO final-1 DO
+      ident := recT.fields.a[index];
+      IF ~recT.symTb.enter(ident.hash, ident) THEN ident.IdError(6) END;
+    END;
+  END FieldListSequence;
+
+(* ==================================================================== *)
+
+  PROCEDURE StaticStuff(recT   : Ty.Record;
+                        defScp : Sy.Scope;
+                        vMod   : INTEGER);  (* vMod ??? *)
+   (* ----------------------------------------- *)
+    PROCEDURE StaticProc(rec : Ty.Record; scp : Sy.Scope);
+      VAR prcD : Id.Procs;
+          prcT : Ty.Procedure;
+          name : LitValue.CharOpen;
+          oId  : Id.OvlId;
+          ok   : BOOLEAN;
+    BEGIN
+      Get;    (* read past procedureSym *)
+      prcD := identDef(scp, Id.conPrc)(Id.Procs);
+      prcD.SetKind(Id.conPrc);
+      prcD.bndType := rec;
+      IF nextT.sym = T.lbrackSym THEN
+        IF ~G.special THEN SemError(144) END;
+        Get;
+        Expect(T.stringSym);
+        name := LitValue.subStrToCharOpen(token.pos+1, token.len-2);
+        prcD.prcNm := name;
+        Expect(T.rbrackSym);
+        IF G.verbose THEN G.Message('external procName "' + name^ + '"') END;
+      END;
+      prcT := Ty.newPrcTp();
+      prcT.idnt := prcD;
+      IF prcD.vMod # Sy.prvMode THEN INCL(prcD.pAttr, Id.public) END;
+      IF nextT.sym = T.lparenSym THEN
+        FormalParameters(prcT, prcD, scp);
+      END;
+      prcD.type := prcT;
+      Ty.InsertInRec(prcD,rec,FALSE,oId,ok);
+      IF ok THEN
+        Sy.AppendIdnt(rec.statics, prcD);
+       (*
+        *  Put this header on the procedure list,
+        *  so that it gets various semantic checks.
+        *)
+        Id.AppendProc(G.thisMod.procs, prcD);
+      ELSE
+        prcD.IdError(6);
+      END;
+    END StaticProc;
+   (* ----------------------------------------- *)
+    PROCEDURE StaticConst(lst : Sy.IdSeq;
+                          rec : Ty.Record;
+                          scp : Sy.Scope);
+      VAR vrId : Sy.Idnt;
+          cnId : Id.ConId;
+          cnEx : Sy.Expr;
+          oId  : Id.OvlId;
+          ok   : BOOLEAN;
+    BEGIN
+      Expect(T.equalSym);
+     (*
+      *  We have a list of VarId here. If the list
+      *  has more than one element, then that is an
+      *  error, otherwise copy info to a ConId ...
+      *)
+      IF lst.tide > 1 THEN lst.a[1].IdError(192); RETURN END;
+      vrId := lst.a[0];
+      cnId := Id.newConId();
+      cnId.token := vrId.token;
+      cnId.hash  := vrId.hash;
+      cnId.dfScp := vrId.dfScp;
+      cnId.SetMode(vrId.vMod);
+      cnEx := constExpression(scp);
+      cnId.conExp := cnEx;
+      cnId.type   := cnEx.type;
+      Ty.InsertInRec(cnId,rec,FALSE,oId,ok);
+      IF ok THEN
+        Sy.AppendIdnt(rec.statics, cnId);
+      ELSE
+        cnId.IdError(6);
+      END;
+    END StaticConst;
+   (* ----------------------------------------- *)
+    PROCEDURE StaticField(lst : Sy.IdSeq;
+                          rec : Ty.Record;
+                          scp : Sy.Scope);
+      VAR flTp : Sy.Type;
+          flId : Id.VarId;
+          indx : INTEGER;
+          oId  : Id.OvlId;
+          ok   : BOOLEAN;
+    BEGIN
+      Get;    (* read past colon *)
+      flTp := type(scp, Sy.pubMode);
+      FOR indx := 0 TO lst.tide-1 DO
+        flId := lst.a[indx](Id.VarId);
+        flId.type := flTp;
+        flId.recTyp := rec;
+        Ty.InsertInRec(flId,rec,FALSE,oId,ok);
+        IF ok THEN
+          Sy.AppendIdnt(rec.statics, flId);
+        ELSE
+          flId.IdError(6);
+        END;
+      END;
+    END StaticField;
+   (* ----------------------------------------- *)
+    PROCEDURE DoStatic(rec : Ty.Record;
+                       scp : Sy.Scope);
+     (*
+      *  StatDef --> PROCEDURE ProcHeading
+      *              |  IdentDef { ',' IdentDef } ":" Type
+      *              |  IdentDef "=" Constant .
+      *)
+      VAR list : Sy.IdSeq;
+    BEGIN
+      IF nextT.sym = T.PROCEDURESym THEN
+        StaticProc(rec, scp);
+      ELSIF nextT.sym = T.identSym THEN
+       (*
+        *  There is a syntactic ambiguity here.
+        *  after an abitrary lookahead we find
+        *  the symbol which determines if this
+        *  is a constant or a variable definition.
+        *  We will "predict" a variable and then
+        *  back-patch later, if necessary.
+        *)
+        IdentDefList(list, scp, Id.varId);
+        IF nextT.sym = T.colonSym THEN
+          StaticField(list, rec, scp);
+        ELSIF nextT.sym = T.equalSym THEN
+          StaticConst(list, rec, scp);
+        ELSE
+          SemError(192); Get;
+        END;
+      ELSE (* skip redundant semicolons *)
+      END;
+    END DoStatic;
+   (* ----------------------------------------- *)
+  BEGIN
+    DoStatic(recT, defScp);
+    WHILE (nextT.sym = T.semicolonSym) DO
+      Get;
+      DoStatic(recT, defScp);
+    END;
+  END StaticStuff;
+
+(* ==================================================================== *)
+
+  PROCEDURE EnumConst(enum   : Ty.Enum;
+                      defScp : Sy.Scope;
+                      vMod   : INTEGER);  (* vMod ??? *)
+    VAR idnt : Sy.Idnt;
+        cnId : Id.ConId;
+        cnEx : Sy.Expr;
+  BEGIN
+    IF nextT.sym # T.identSym THEN RETURN END;    (* skip extra semis! *)
+    idnt := identDef(defScp, Id.conId);
+    cnId := idnt(Id.ConId);       (* don't insert yet! *)
+    Expect(T.equalSym);
+    cnEx := constExpression(defScp);
+    cnId.conExp := cnEx;
+    cnId.type   := cnEx.type;
+    IF cnId.type # Bi.intTp THEN cnEx.ExprError(37) END;
+    IF enum.symTb.enter(cnId.hash, cnId) THEN
+      Sy.AppendIdnt(enum.statics, cnId);
+    ELSE
+      cnId.IdError(6);
+    END;
+  END EnumConst;
+
+(* ==================================================================== *)
+
+  PROCEDURE  ArrLength(defScp : Sy.Scope; OUT n : INTEGER; OUT p : BOOLEAN);
+    VAR xSyn : Xp.LeafX;
+  BEGIN
+    n := 0;
+    p := FALSE;
+    xSyn := constExpression(defScp);
+    IF xSyn # NIL THEN
+      IF xSyn.kind = Xp.numLt THEN
+        n := xSyn.value.int();
+        IF n > 0 THEN p := TRUE ELSE SemError(68) END;
+      ELSE
+        SemError(31);
+      END;
+    END;
+  END ArrLength;
+
+(* ==================================================================== *)
+
+  PROCEDURE  PointerType(pTyp : Ty.Pointer; defScp : Sy.Scope; vMod : INTEGER);
+  BEGIN
+    Expect(T.POINTERSym);
+    Expect(T.TOSym);
+    pTyp.boundTp := type(defScp, vMod);
+  END PointerType;
+
+(* ==================================================================== *)
+
+  PROCEDURE  EventType(eTyp : Ty.Procedure; defScp : Sy.Scope; vMod : INTEGER);
+  BEGIN
+    Expect(T.EVENTSym);
+    IF ~G.targetIsNET() THEN SemError(208);
+    ELSIF G.strict THEN SemError(221); 
+    END;
+    IF ~(defScp IS Id.BlkId) THEN SemError(212) END;
+    IF (nextT.sym = T.lparenSym) THEN
+      FormalParameters(eTyp, NIL, defScp);
+    ELSE SemError(209);
+    END;
+  END EventType;
+
+(* ==================================================================== *)
+
+  PROCEDURE  RecordType(rTyp : Ty.Record; defScp : Sy.Scope; vMod : INTEGER);
+   (*
+    *  Record --> RECORD ['(' tpQual { '+' tpQual } ')']
+    *             FieldListSequence
+    *             [ STATIC StatDef { ';' StatDef } ] END .
+    *)
+    VAR tpId : Id.TypId;
+  BEGIN
+    Expect(T.RECORDSym);
+    IF Sy.frnMd IN G.thisMod.xAttr THEN
+      INCL(rTyp.xAttr, Sy.isFn);         (* must be foreign *)
+    END;
+    IF (nextT.sym = T.lparenSym) THEN
+      Get;
+      IF nextT.sym # T.plusSym THEN
+        tpId := typeQualid(defScp);
+      ELSE
+        tpId := Bi.anyTpId;
+      END;
+      IF tpId # NIL THEN rTyp.baseTp := tpId.type END;
+      INCL(rTyp.xAttr, Sy.clsTp); (* must be a class *)
+     (* interfaces ... *)
+      WHILE (nextT.sym = T.plusSym) DO
+        Get;
+        IF G.strict & (nextT.sym = T.plusSym) THEN SemError(221); END;
+        tpId := typeQualid(defScp);
+        IF tpId # NIL THEN Sy.AppendType(rTyp.interfaces, tpId.type) END;
+      END;
+      Expect(T.rparenSym);
+    END;
+    FieldListSequence(rTyp, defScp, vMod);
+    IF nextT.sym = T.STATICSym THEN
+      Get;
+      IF ~G.special THEN SemError(185) END;
+      INCL(rTyp.xAttr, Sy.isFn);         (* must be foreign *)
+      StaticStuff(rTyp, defScp, vMod);
+    END;
+    Expect(T.ENDSym);
+  END RecordType;
+
+(* ==================================================================== *)
+
+  PROCEDURE  EnumType(enum : Ty.Enum; defScp : Sy.Scope; vMod : INTEGER);
+   (*
+    *  Enum --> ENUM RECORD StatDef { ';' StatDef } END .
+    *)
+  BEGIN
+    IF ~G.special THEN SemError(185) END;
+    Get;      (* read past ENUM *)
+    (* Expect(T.RECORDSym); *)
+    EnumConst(enum, defScp, vMod);
+    WHILE (nextT.sym = T.semicolonSym) DO
+      Get;
+      EnumConst(enum, defScp, vMod);
+    END;
+    Expect(T.ENDSym);
+  END EnumType;
+
+(* ==================================================================== *)
+
+  PROCEDURE  OptAttr (rTyp : Ty.Record);
+  BEGIN
+    INCL(rTyp.xAttr, Sy.clsTp);   (* must be a class *)
+    IF nextT.sym = T.ABSTRACTSym THEN
+      Get;
+      rTyp.recAtt := Ty.isAbs;
+    ELSIF nextT.sym = T.EXTENSIBLESym THEN
+      Get;
+      rTyp.recAtt := Ty.extns;
+    ELSIF nextT.sym = T.LIMITEDSym THEN
+      Get;
+      rTyp.recAtt := Ty.limit;
+    ELSIF nextT.sym = T.INTERFACESym THEN
+      Get;
+      IF G.strict THEN SemError(221); END;
+      rTyp.recAtt := Ty.iFace;
+    ELSE Error(87);
+    END;
+  END OptAttr;
+
+(* ==================================================================== *)
+
+  PROCEDURE  ArrayType (aTyp : Ty.Array; defScp : Sy.Scope; vMod : INTEGER);
+    VAR length : INTEGER;
+        ok     : BOOLEAN;
+        elemT  : Ty.Array;
+  BEGIN
+    Expect(T.ARRAYSym);
+    IF in(symSet[3], nextT.sym) THEN
+      ArrLength(defScp, length, ok);
+      IF ok THEN aTyp.length := length END;
+      WHILE (nextT.sym = T.commaSym) DO
+        Get;
+        ArrLength(defScp, length, ok);
+        elemT := Ty.newArrTp(); aTyp.elemTp := elemT; aTyp := elemT;
+        IF ok THEN aTyp.length := length END;
+      END;
+    END;
+    Expect(T.OFSym);
+    aTyp.elemTp := type(defScp, vMod);
+
+    IF vMod # Sy.prvMode THEN FixAnon(defScp, aTyp.elemTp, vMod) END;
+  END ArrayType;
+
+(* ==================================================================== *)
+
+  PROCEDURE  VectorType (aTyp : Ty.Vector; defScp : Sy.Scope; vMod : INTEGER);
+    VAR length : INTEGER;
+        ok     : BOOLEAN;
+        elemT  : Ty.Array;
+  BEGIN
+    Expect(T.VECTORSym);
+    Expect(T.OFSym);
+    aTyp.elemTp := type(defScp, vMod);
+    IF vMod # Sy.prvMode THEN FixAnon(defScp, aTyp.elemTp, vMod) END;
+    IF G.strict THEN SemError(221) END;
+  END VectorType;
+
+(* ==================================================================== *)
+
+  PROCEDURE ProcedureType(pTyp : Ty.Procedure; defScp : Sy.Scope);
+  BEGIN
+    Expect(T.PROCEDURESym);
+    IF (nextT.sym = T.lparenSym) THEN
+      FormalParameters(pTyp, NIL, defScp);
+    ELSIF (nextT.sym = T.rparenSym) OR
+          (nextT.sym = T.ENDSym) OR
+          (nextT.sym = T.semicolonSym) THEN
+      (* skip *)
+    ELSE Error(88);
+    END;
+  END ProcedureType;
+
+(* ==================================================================== *)
+
+  PROCEDURE CompoundType(defScp : Sy.Scope; firstType : Id.TypId) : Sy.Type;
+  (* Parses a compound type from a series of comma separated qualidents.
+   * One component of the compound type has already been parsed and is
+   * passed as firstType. The next token is a comma. At most one of the
+   * types can be a class, and all the others must be interfaces. The
+   * type that is returned is a Pointer to a Record with the compound
+   * type flag set. *)
+  (* Things that could be checked here but aren't yet:
+   *  - that any interfaces are not part of the base type
+      - that any interfaces are not entered more than once
+   *)
+    VAR
+      ptrT : Ty.Pointer;
+      cmpT : Ty.Record;
+      tpId : Id.TypId;
+
+   (* Checks to make sure the type is suitable for use in a compound
+    * type *)
+    PROCEDURE checkType(type : Sy.Type) : BOOLEAN;
+    BEGIN
+      IF (type = NIL) OR
+         ~(type.isRecordType() OR type.isDynamicType()) THEN
+        Error(89);
+        RETURN FALSE;
+      ELSE
+        RETURN TRUE;
+      END;
+    END checkType;
+
+  BEGIN
+    (* Check that we were passed an appropriate type and that
+     * a comma is following *)
+    IF ~checkType(firstType.type) THEN Error(89); RETURN NIL END;
+    IF nextT.sym # T.commaSym THEN Error(12); RETURN NIL END;
+
+    (* Create the compound type *)
+    cmpT := Ty.newRecTp();
+    cmpT.recAtt := Ty.cmpnd;
+
+    IF firstType.type.isInterfaceType() THEN
+      (* Add it to the list of interfaces *)
+      Sy.AppendType(cmpT.interfaces, firstType.type);
+    ELSE
+      (* Make it our base type *)
+      cmpT.baseTp := firstType.type;
+    END;
+
+    WHILE nextT.sym = T.commaSym DO
+      Get;   (* Eat the comma *)
+      IF nextT.sym # T.identSym THEN Error(T.identSym) END;
+      tpId := typeQualid(defScp);
+      IF ~checkType(tpId.type) THEN RETURN NIL END;
+      IF tpId.type.isInterfaceType() THEN
+        Sy.AppendType(cmpT.interfaces, tpId.type);
+      ELSE
+        IF cmpT.baseTp # NIL THEN Error(89); RETURN NIL END;
+        cmpT.baseTp := tpId.type;
+      END;
+    END;
+    INCL(cmpT.xAttr, Sy.clsTp);   (* must be a class *)
+    ptrT := Ty.newPtrTp();
+    ptrT.boundTp := cmpT;
+    RETURN ptrT;
+  END CompoundType;
+
+(* ==================================================================== *)
+
+  PROCEDURE type(defScp : Sy.Scope; vMod : INTEGER) : Sy.Type;
+    VAR tpId : Id.TypId;
+        prcT : Ty.Procedure;
+        recT : Ty.Record;
+        arrT : Ty.Array;
+        vecT : Ty.Vector;
+        ptrT : Ty.Pointer;
+        enuT : Ty.Enum;
+  BEGIN
+    IF (nextT.sym = T.identSym) THEN
+      tpId := typeQualid(defScp);
+      IF tpId = NIL THEN RETURN NIL END;
+      IF ~G.extras THEN RETURN tpId.type END;
+      (* Compound type parsing... look for comma *)
+      IF nextT.sym # T.commaSym THEN RETURN tpId.type
+      ELSE RETURN CompoundType(defScp, tpId) END;
+    ELSIF (nextT.sym = T.PROCEDURESym) THEN
+      prcT := Ty.newPrcTp();
+      ProcedureType(prcT, defScp); RETURN prcT;
+    ELSIF (nextT.sym = T.ARRAYSym) THEN
+      arrT := Ty.newArrTp();
+      ArrayType(arrT, defScp, vMod); RETURN arrT;
+    ELSIF (nextT.sym = T.VECTORSym) THEN
+      vecT := Ty.newVecTp();
+      VectorType(vecT, defScp, vMod); RETURN vecT;
+    ELSIF (nextT.sym = T.ABSTRACTSym) OR
+          (nextT.sym = T.EXTENSIBLESym) OR
+          (nextT.sym = T.LIMITEDSym) OR
+          (nextT.sym = T.INTERFACESym) OR
+          (nextT.sym = T.RECORDSym) THEN
+      recT := Ty.newRecTp();
+      IF nextT.sym # T.RECORDSym THEN OptAttr(recT) END;
+      RecordType(recT, defScp, vMod);  RETURN recT;
+    ELSIF (nextT.sym = T.POINTERSym) THEN
+      ptrT := Ty.newPtrTp();
+      PointerType(ptrT, defScp, vMod); RETURN ptrT;
+    ELSIF (nextT.sym = T.ENUMSym) THEN
+      enuT := Ty.newEnuTp();
+      EnumType(enuT, defScp, vMod);  RETURN enuT;
+    ELSIF (nextT.sym = T.EVENTSym) THEN
+      prcT := Ty.newEvtTp();
+      EventType(prcT, defScp, vMod);  RETURN prcT;
+    ELSE
+      Error(89); RETURN NIL;
+    END;
+  END type;
+
+(* ==================================================================== *)
+
+  PROCEDURE  TypeDeclaration(defScp : Sy.Scope);
+    VAR iTmp  : Sy.Idnt;
+        stuck : BOOLEAN;
+  BEGIN
+    iTmp := identDef(defScp, Id.typId);
+    IF iTmp.vMod = Sy.rdoMode THEN SemError(134) END;
+    Expect(T.equalSym);
+    iTmp.type := type(defScp, iTmp.vMod);
+    IF (iTmp.type # NIL) & iTmp.type.isAnonType() THEN
+      iTmp.type.idnt := iTmp;
+    END;
+    stuck := Sy.refused(iTmp, defScp);
+    IF stuck THEN iTmp.IdError(4) END;
+  END TypeDeclaration;
+
+(* ==================================================================== *)
+
+  PROCEDURE  expression(scope : Sy.Scope) : Sy.Expr;
+    VAR relOp : INTEGER;
+        expN1 : Sy.Expr;
+        expN2 : Sy.Expr;
+        saveT : S.Token;
+        tokN1 : S.Token;
+  (* ------------------------------------------ *)
+    PROCEDURE MarkAssign(id : Sy.Idnt);
+    BEGIN
+      IF (id # NIL) & (id IS Id.Procs) THEN
+        INCL(id(Id.Procs).pAttr, Id.assgnd);
+      END;
+    END MarkAssign;
+  (* ------------------------------------------ *)
+  BEGIN
+    tokN1 := nextT;
+    expN1 := simpleExpression(scope);
+   (*
+    *  Mark use of procedure-valued expressions.
+    *)
+    WITH expN1 : Xp.IdLeaf DO
+        MarkAssign(expN1.ident);
+    | expN1 : Xp.IdentX DO
+        MarkAssign(expN1.ident);
+    ELSE
+    END;
+   (*
+    *  ... and parse the substructures!
+    *)
+    IF in(symSet[12], nextT.sym) THEN
+      relOp := relation(); saveT := token;
+      expN2 := simpleExpression(scope);
+      expN1 := Xp.newBinaryT(relOp, expN1, expN2, saveT);
+    END;
+    IF expN1 # NIL THEN expN1.tSpan := S.mkSpanTT(tokN1, S.prevTok) END;
+    RETURN expN1;
+  END expression;
+
+(* ==================================================================== *)
+
+  PROCEDURE  constExpression(defScp : Sy.Scope) : Xp.LeafX;
+    VAR expr : Sy.Expr;
+        orig : S.Span;
+  (* ------------------------------------------ *)
+    PROCEDURE eval(exp : Sy.Expr) : Sy.Expr;
+    BEGIN
+      RETURN exp.exprAttr();
+    RESCUE (junk)
+      exp.ExprError(55);
+      RETURN NIL;
+    END eval;
+  (* ------------------------------------------ *)
+  BEGIN
+    expr := expression(defScp);
+    IF expr # NIL THEN
+      orig := expr.tSpan;
+      expr := eval(expr);
+      IF expr = NIL THEN (* skip *)
+      ELSIF (expr IS Xp.LeafX) &
+            (expr.kind # Xp.setXp) THEN
+        expr.tSpan := orig;
+        RETURN expr(Xp.LeafX);
+      ELSE
+        expr.ExprError(25);   (* expr not constant *)
+      END;
+    END;
+    RETURN NIL;
+  END constExpression;
+
+(* ==================================================================== *)
+
+  PROCEDURE  ConstantDeclaration (defScp : Sy.Scope);
+    VAR idnt : Sy.Idnt;
+        cnId : Id.ConId;
+        cnEx : Xp.LeafX;
+  BEGIN
+    idnt := identDef(defScp, Id.conId);
+    cnId := idnt(Id.ConId);       (* don't insert yet! *)
+    Expect(T.equalSym);
+    cnEx := constExpression(defScp);
+    IF Sy.refused(idnt, defScp) THEN idnt.IdError(4) END;
+    IF (cnId # NIL) & (cnEx # NIL) THEN
+      cnId.conExp := cnEx;
+      cnId.type   := cnEx.type;
+    END;
+  END ConstantDeclaration;
+
+(* ==================================================================== *)
+
+  PROCEDURE  qualident(defScp : Sy.Scope) : Sy.Idnt;
+  (*  Postcondition: returns a valid Id, or NIL.      *
+   *  NIL ==> error already notified.           *)
+    VAR idnt : Sy.Idnt;
+        locl : Id.LocId;
+        tpId : Id.TypId;
+        tpTp : Sy.Type;
+        modS : Sy.Scope;
+        hash : INTEGER;
+        eNum : INTEGER;
+  BEGIN
+    Expect(T.identSym);
+    hash := NameHash.enterSubStr(token.pos, token.len);
+    idnt := Sy.bind(hash, defScp);
+    IF idnt = NIL THEN
+      SemError(2); RETURN NIL;
+    ELSIF (idnt.kind # Id.impId) & (idnt.kind # Id.alias) THEN
+     (*
+      *   This is a single token qualident.
+      *   Now we check for uplevel addressing.
+      *   Temporarily disallowed in boot version 0.n and 1.0
+      *)
+      IF (idnt.dfScp # NIL) &   (* There is a scope,  *)
+         (idnt.dfScp # defScp) &  (* not current scope, *)
+         (idnt IS Id.AbVar) &   (* is a variable, and *)
+         (idnt.dfScp IS Id.Procs) THEN  (* scope is a PROC.   *)
+        SemError(302);
+        locl := idnt(Id.LocId);
+        IF ~(Id.uplevA IN locl.locAtt) THEN
+          eNum := 311;
+          WITH locl : Id.ParId DO
+            IF (locl.parMod # Sy.val) &
+               (locl.type # NIL) & 
+                ~G.targetIsJVM() &
+                ~locl.type.isRefSurrogate() THEN
+              eNum := 310;
+              INCL(locl.locAtt, Id.cpVarP);
+            END;
+          ELSE (* skip *)
+          END;
+          locl.IdErrorStr(eNum, Sy.getName.ChPtr(idnt));
+          INCL(idnt.dfScp(Id.Procs).pAttr, Id.hasXHR);
+          INCL(locl.locAtt, Id.uplevA); (* uplevel Any *)
+        END;
+(*
+ *     (*
+ *      *  As of version 1.06 uplevel addressing is
+ *      *  ok, except for reference params in .NET.
+ *      *  This needs to be fixed by 
+ *      *     (1) producing unverifiable code
+ *      *     (2) adopting inexact semantics in this case.
+ *      *  To be determined later ...
+ *      *)
+ *      WITH locl : Id.ParId DO
+ *        IF (locl.parMod # Sy.val) &
+ *           (locl.type # NIL) & 
+ *            ~G.targetIsJVM() &
+ *            ~locl.type.isRefSurrogate() THEN
+ *           S.SemError.RepSt1(189, Sy.getName.ChPtr(idnt), token.lin, 0);
+ *        END;
+ *      ELSE (* skip *)
+ *      END;
+ *)
+      END;
+      RETURN idnt;
+    ELSE
+      modS := idnt(Sy.Scope);
+    END;
+    Expect(T.pointSym);
+    Expect(T.identSym);
+   (*
+    *  At this point the only live control flow branch is
+    *  the one predicated on the ident being a scope name.
+    *)
+    idnt := bindTokenLocal(modS);
+    IF idnt = NIL THEN
+      SemError(3);      (* name not known in qualified scope *)
+    ELSIF modS.isWeak() THEN
+      SemErrorS1(175, Sy.getName.ChPtr(modS));  (* mod not directly imported *)
+    ELSE
+      RETURN idnt;
+    END;
+    RETURN NIL;
+  END qualident;
+
+(* ==================================================================== *)
+
+  PROCEDURE typeQualid(defScp : Sy.Scope) : Id.TypId;
+  (** This procedure returns one of --
+        a valid Id.TypId (possibly a forward type)
+        NIL (with an error already notified)        *)
+    VAR idnt : Sy.Idnt;
+        tpId : Id.TypId;
+        tpTp : Sy.Type;
+        modS : Sy.Scope;
+        hash : INTEGER;
+  BEGIN
+    Expect(T.identSym);
+    hash := NameHash.enterSubStr(token.pos, token.len);
+    idnt := Sy.bind(hash, defScp);
+    modS := NIL;
+    IF idnt = NIL THEN
+     (*
+      *  This _might_ just be a forward type.  It cannot be so
+      *  if the next token is "." or if declarations in this
+      *  scope are officially closed.
+      *)
+      IF (nextT.sym = T.pointSym) OR defScp.endDecl THEN
+        SemError(2);
+        IF nextT.sym # T.pointSym THEN RETURN NIL END;
+      ELSE
+        tpTp := Ty.newTmpTp();
+        tpId := Id.newTypId(tpTp);
+        tpId.dfScp := defScp;
+        tpId.token := token;
+        tpId.hash  := hash;
+        tpTp.idnt  := tpId;
+        RETURN tpId;
+      END;
+    ELSIF idnt.kind = Id.typId THEN
+      RETURN idnt(Id.TypId);
+    ELSIF (idnt.kind = Id.impId) OR (idnt.kind = Id.alias) THEN
+      modS := idnt(Sy.Scope);
+    ELSE
+      SemError(5);
+      IF nextT.sym # T.pointSym THEN RETURN NIL END;
+    END;
+    Expect(T.pointSym);
+    Expect(T.identSym);
+    IF modS = NIL THEN RETURN NIL END;
+   (*
+    *  At this point the only live control flow branch is
+    *  the one predicated on the ident being a scope name.
+    *)
+    idnt := bindTokenLocal(modS);
+    IF idnt = NIL THEN
+      SemError(3);    (* name not known in qualified scope *)
+    ELSIF modS.isWeak() THEN
+      SemErrorS1(175, Sy.getName.ChPtr(modS));  (* mod not directly imported *)
+    ELSIF idnt.kind # Id.typId THEN
+      SemError(7);    (* name is not the name of a type    *)
+    ELSE
+      tpId := idnt(Id.TypId);
+      RETURN tpId;
+    END;
+    RETURN NIL;
+  END typeQualid;
+
+(* ==================================================================== *)
+
+  PROCEDURE  identDef(inhScp : Sy.Scope; tag : INTEGER) : Sy.Idnt;
+  (** This non-terminal symbol creates an Id of prescribed kind for
+      the ident. The Id has its parent scope assigned, but is not yet
+      inserted into the prescribed scope.          *)
+    VAR iSyn : Sy.Idnt;
+  BEGIN
+    CASE tag OF
+    | Id.conId  : iSyn := Id.newConId();
+    | Id.parId  : iSyn := Id.newParId();
+    | Id.quaId  : iSyn := Id.newQuaId();
+    | Id.modId  : iSyn := Id.newModId();
+    | Id.impId  : iSyn := Id.newImpId();
+    | Id.fldId  : iSyn := Id.newFldId();
+    | Id.fwdMth : iSyn := Id.newMthId();
+    | Id.conMth : iSyn := Id.newMthId();
+    | Id.fwdPrc : iSyn := Id.newPrcId();
+    | Id.conPrc : iSyn := Id.newPrcId();
+    | Id.typId  : iSyn := Id.newTypId(NIL);
+    | Id.fwdTyp : iSyn := Id.newTypId(NIL);
+    | Id.varId  : IF inhScp IS Id.BlkId THEN
+                    iSyn := Id.newVarId();
+                  ELSE
+                    iSyn := Id.newLocId();
+                  END;
+    END;
+    IF iSyn IS Sy.Scope THEN iSyn(Sy.Scope).ovfChk := G.ovfCheck END;
+    iSyn.token := nextT;
+    iSyn.hash  := NameHash.enterSubStr(nextT.pos, nextT.len);
+    iSyn.dfScp := inhScp;
+    IF nextT.dlr & ~G.special THEN SemErrorT(186, nextT) END;
+    Expect(T.identSym);
+    IF (nextT.sym = T.starSym) OR
+       (nextT.sym = T.bangSym) OR
+       (nextT.sym = T.minusSym) THEN
+      IF (nextT.sym = T.starSym) THEN
+        Get;
+        iSyn.SetMode(Sy.pubMode);
+      ELSIF (nextT.sym = T.minusSym) THEN
+        Get;
+        iSyn.SetMode(Sy.rdoMode);
+      ELSE
+        Get;
+        iSyn.SetMode(Sy.protect);
+        IF ~G.special THEN SemError(161) END;
+      END;
+    END;
+    IF  (iSyn.vMod # Sy.prvMode) & (inhScp # G.thisMod) THEN
+      SemError(128);
+    END;
+    RETURN iSyn;
+  END identDef;
+
+(* ==================================================================== *)
+
+  PROCEDURE Module;
+    VAR err : INTEGER;
+        nam : FileNames.NameString;
+        hsh : INTEGER;
+        tok : S.Token;
+  BEGIN
+    IF nextT.sym = T.identSym THEN
+      hsh := NameHash.enterSubStr(nextT.pos, nextT.len);
+      IF hsh = Bi.sysBkt THEN
+        Get;
+        INCL(G.thisMod.xAttr, Sy.rtsMd);
+        IF G.verbose THEN G.Message("Compiling a SYSTEM Module") END;
+        IF ~G.special THEN SemError(144) END;
+      ELSIF hsh = Bi.frnBkt THEN
+        Get;
+        INCL(G.thisMod.xAttr, Sy.frnMd);
+        IF G.verbose THEN G.Message("Compiling a FOREIGN Module") END;
+        IF ~G.special THEN SemError(144) END;
+      END;
+      ForeignMod;
+    ELSIF nextT.sym = T.MODULESym THEN
+      (*  Except for empty bodies this next will be overwritten later *)
+      G.thisMod.begTok := nextT;
+      CPmodule;
+    END;
+    G.thisMod.endTok := nextT;
+    Expect(T.ENDSym);
+    Expect(T.identSym);
+    S.GetString(token.pos, token.len, nam);
+    IF nam # G.modNam THEN
+      IF token.sym = T.identSym THEN err := 1 ELSE err := 0 END;
+      SemErrorS1(err, G.modNam$);
+    END;
+    Expect(T.pointSym);
+  END Module;
+
+(* ==================================================================== *)
+
+  PROCEDURE Parse*;
+  BEGIN
+    NEW(nextT); (* so that token is not even NIL initially *)
+    S.Reset; Get;
+    G.parseS := RTS.GetMillis();
+    Module;
+  END Parse;
+
+(* ==================================================================== *)
+
+BEGIN
+  comma := LitValue.strToCharOpen(",");
+  errDist := minErrDist;
+  (* ------------------------------------------------------------ *)
+
+  symSet[ 0, 0] := {T.EOFSYM, T.identSym, T.ENDSym, T.semicolonSym};
+  symSet[ 0, 1] := {T.EXITSym-32, T.RETURNSym-32, T.NEWSym-32, T.IFSym-32,
+                    T.ELSIFSym-32, T.ELSESym-32, T.CASESym-32, T.barSym-32,
+                    T.WHILESym-32, T.REPEATSym-32, T.UNTILSym-32, T.FORSym-32};
+  symSet[ 0, 2] := {T.LOOPSym-64, T.WITHSym-64, T.CLOSESym-64};
+  (* ------------------------------------------------------------ *)
+
+  (* Follow comma in ident-list *)
+  symSet[ 1, 0] := {T.identSym};
+  symSet[ 1, 1] := {};
+  symSet[ 1, 2] := {};
+  (* ------------------------------------------------------------ *)
+
+  (* Follow(ident-list) *)
+  symSet[ 2, 0] := {T.colonSym};
+  symSet[ 2, 1] := {};
+  symSet[ 2, 2] := {};
+  (* ------------------------------------------------------------ *)
+
+  (* Start(expression) *)
+  symSet[ 3, 0] := {T.identSym, T.integerSym, T.realSym, T.CharConstantSym,
+                    T.stringSym, T.minusSym, T.lparenSym, T.plusSym};
+  symSet[ 3, 1] := {T.NILSym-32, T.tildeSym-32, T.lbraceSym-32};
+  symSet[ 3, 2] := {};
+  (* ------------------------------------------------------------ *)
+
+  (* lookahead of optional statement *)
+  symSet[ 4, 0] := {T.EOFSYM, T.identSym, T.ENDSym, T.semicolonSym};
+  symSet[ 4, 1] := {T.EXITSym-32, T.RETURNSym-32, T.NEWSym-32, T.IFSym-32,
+                    T.ELSIFSym-32, T.ELSESym-32, T.CASESym-32, T.barSym-32,
+                    T.WHILESym-32, T.REPEATSym-32, T.UNTILSym-32, T.FORSym-32};
+  symSet[ 4, 2] := {T.LOOPSym-64, T.WITHSym-64, T.CLOSESym-64, T.RESCUESym-64};
+  (* ------------------------------------------------------------ *)
+
+  (* follow semicolon in statementSequence *)
+  symSet[ 5, 0] := {T.identSym, T.ENDSym, T.semicolonSym};
+  symSet[ 5, 1] := {T.EXITSym-32, T.RETURNSym-32, T.NEWSym-32, T.IFSym-32,
+                    T.ELSIFSym-32, T.ELSESym-32, T.CASESym-32, T.barSym-32,
+                    T.WHILESym-32, T.REPEATSym-32, T.UNTILSym-32, T.FORSym-32};
+  symSet[ 5, 2] := {T.LOOPSym-64, T.WITHSym-64, T.CLOSESym-64, T.RESCUESym-64};
+  (* ------------------------------------------------------------ *)
+
+  (* Follow(statementSequence) *)
+  symSet[ 6, 0] := {T.ENDSym};
+  symSet[ 6, 1] := {T.ELSIFSym-32, T.ELSESym-32, T.barSym-32, T.UNTILSym-32};
+  symSet[ 6, 2] := {T.CLOSESym-64, T.RESCUESym-64};
+  (* ------------------------------------------------------------ *)
+
+  (* Follow(barSym) *)
+  symSet[ 7, 0] := {T.EOFSYM, T.identSym, T.integerSym, T.realSym,
+                    T.CharConstantSym, T.stringSym, T.minusSym, T.lparenSym,
+                    T.plusSym, T.ENDSym, T.semicolonSym};
+  symSet[ 7, 1] := {T.NILSym-32, T.tildeSym-32, T.lbraceSym-32,
+                    T.EXITSym-32, T.RETURNSym-32, T.NEWSym-32, T.IFSym-32,
+                    T.ELSIFSym-32, T.ELSESym-32, T.CASESym-32, T.barSym-32,
+                    T.WHILESym-32, T.REPEATSym-32, T.UNTILSym-32, T.FORSym-32};
+  symSet[ 7, 2] := {T.LOOPSym-64, T.WITHSym-64, T.CLOSESym-64};
+  (* ------------------------------------------------------------ *)
+
+  (* lookahead to optional arglist *)
+  symSet[ 8, 0] := {(*T.lparenSym,*) T.ENDSym, T.semicolonSym};
+  symSet[ 8, 1] := {T.ELSIFSym-32, T.ELSESym-32, T.barSym-32, T.UNTILSym-32};
+  symSet[ 8, 2] := {T.CLOSESym-64};
+  (* ------------------------------------------------------------ *)
+
+  (* Start(statement) *)
+  symSet[ 9, 0] := {T.identSym};
+  symSet[ 9, 1] := {T.EXITSym-32, T.RETURNSym-32, T.NEWSym-32, T.IFSym-32,
+                    T.CASESym-32, T.WHILESym-32, T.REPEATSym-32, T.FORSym-32};
+  symSet[ 9, 2] := {T.LOOPSym-64, T.WITHSym-64};
+  (* ------------------------------------------------------------ *)
+
+  (* follow semicolon in FormalParamLists *)
+  symSet[10, 0] := {T.identSym};
+  symSet[10, 1] := {T.INSym-32};
+  symSet[10, 2] := {T.VARSym-64, T.OUTSym-64};
+  (* ------------------------------------------------------------ *)
+
+  (* Follow(FPsection-repetition) *)
+  symSet[11, 0] := {T.rparenSym};
+  symSet[11, 1] := {};
+  symSet[11, 2] := {};
+  (* ------------------------------------------------------------ *)
+
+  (* Follow(simpleExpression) - Follow(expression) *)
+  symSet[12, 0] := {T.equalSym, T.hashSym};
+  symSet[12, 1] := {T.lessSym-32, T.lessequalSym-32, T.greaterSym-32,
+                    T.greaterequalSym-32, T.INSym-32, T.ISSym-32};
+  symSet[12, 2] := {};
+  (* ------------------------------------------------------------ *)
+END CPascalP.
+

gpcp/CPascalS.cp

@@ -0,0 +1,756 @@
+(* ==================================================================== *)
+(*									*)
+(*  Scanner Module for the Gardens Point Component Pascal Compiler.	*)
+(*	Copyright (c) John Gough 1999, 2000.				*)
+(*	This module was extensively modified from the scanner		*)
+(*	automatically produced by the M2 version of COCO/R, using	*)
+(*	the CPascal.atg grammar used for the JVM version of GPCP.	*)
+(*									*)
+(* ==================================================================== *)
+
+MODULE CPascalS;
+
+(* This is a modified version for Mburg --- it computes column positions *)
+(* Scanner generated by Coco/R *)
+
+IMPORT	
+	GPCPcopyright,
+	RTS,
+	Console,
+	Tok := CPascalG,
+	GPBinFiles,
+	GPTextFiles;
+
+CONST
+  noSym   = Tok.NOSYM; (*error token code*)
+  (* not only for errors but also for not finished states of scanner analysis *)
+  eof     = 0X;
+  eofByt  = 0;
+  EOL     = 0AX;
+  BlkSize = 32768;
+  asciiHT = 9X;
+  asciiLF = EOL;
+
+CONST   
+  listAlways*  = 2;		(* listing control constants *)
+  listErrOnly* = 1;
+  listNever*   = 0;
+
+TYPE
+  BufBlk     = ARRAY BlkSize OF UBYTE;
+  Buffer     = ARRAY 32  OF POINTER TO BufBlk;
+  StartTable = ARRAY 256 OF INTEGER;
+
+(* ======================== EXPORTS ========================= *)
+TYPE
+  ErrorHandler* = POINTER TO ABSTRACT RECORD END;
+  
+  Token*	= POINTER TO RECORD
+		    sym* : INTEGER;
+		    lin* : INTEGER;
+		    col* : INTEGER;
+		    pos* : INTEGER;
+		    len* : INTEGER;
+		    dlr* : BOOLEAN;
+		  END;
+		  
+  Span*     = POINTER TO RECORD
+            sLin*, sCol*, eLin*, eCol* : INTEGER
+          END;
+
+(* ====================== END EXPORTS ======================= *)
+
+VAR
+  ch:        CHAR;       (*current input character*)
+  curLine:   INTEGER;    (*current input line (may be higher than line)*)
+  lineStart: INTEGER;    (*start position of current line*)
+  apx:       INTEGER;    (*length of appendix (CONTEXT phrase)*)
+  oldEols:   INTEGER;    (*number of EOLs in a comment*)
+  bp:        INTEGER;    (*current position in buf*)
+  bp0:       INTEGER;    (*position of current token)*)
+  LBlkSize:  INTEGER;    (*BlkSize*)
+  inputLen:  INTEGER;    (*source file size*)
+  buf:       Buffer;     (*source buffer for low-level access*)
+  start:     StartTable; (*start state for every character*)
+  nextLine:  INTEGER;    (*line of lookahead symbol*)
+  nextCol:   INTEGER;    (*column of lookahead symbol*)
+  nextLen:   INTEGER;    (*length of lookahead symbol*)
+  nextPos:   INTEGER;    (*file position of lookahead symbol*)
+
+  spaces:    INTEGER;   (* ############# NEW ############## *)
+
+(* ======================== EXPORTS ========================= *)
+VAR
+  src*:    GPBinFiles.FILE;  (*source file. To be opened by main *)
+  lst*:    GPTextFiles.FILE; (*list file. To be opened by main   *)
+  line*, col*: INTEGER;      (*line and column of current symbol*)
+  len*:        INTEGER;      (*length of current symbol*)
+  pos*:        INTEGER;      (*file position of current symbol*)
+  errors*:     INTEGER;      (*number of detected errors*)
+  warnings*:   INTEGER;      (*number of detected warnings*)
+  prevTok*:    Token;
+  ParseErr*:   ErrorHandler;
+  SemError*:   ErrorHandler;
+(* ====================== END EXPORTS ======================= *)
+
+(* ======================== EXPORTS ========================= *)
+PROCEDURE (s : ErrorHandler)Report*(num : INTEGER; 
+				    lin : INTEGER;
+			            col : INTEGER) ,NEW,ABSTRACT;
+
+PROCEDURE (s : ErrorHandler)RepSt1*(num : INTEGER; 
+				 IN str : ARRAY OF CHAR;
+				    lin : INTEGER;
+			            col : INTEGER) ,NEW,ABSTRACT;
+
+PROCEDURE (s : ErrorHandler)RepSt2*(num : INTEGER; 
+				 IN st1 : ARRAY OF CHAR;
+				 IN st2 : ARRAY OF CHAR;
+				    lin : INTEGER;
+			        col : INTEGER) ,NEW,ABSTRACT;
+
+PROCEDURE (s : Span)SpanSS*(e : Span) : Span,NEW;
+  VAR res : Span;
+BEGIN
+  IF e = NIL THEN RETURN s;
+  ELSE
+    NEW(res); 
+    res.sLin := s.sLin; res.eLin := e.eLin; 
+    res.sCol := s.sCol; res.eCol := e.eCol;
+  END;
+  RETURN res;
+END SpanSS;
+
+PROCEDURE mkSpanTT*(s, e : Token) : Span;
+  VAR res : Span;
+BEGIN
+  NEW(res);
+  res.sLin := s.lin; res.eLin := e.lin; 
+  res.sCol := s.col; res.eCol := e.col + e.len;
+  RETURN res; 
+END mkSpanTT;
+
+PROCEDURE mkSpanT*(t : Token) : Span;
+  VAR res : Span;
+BEGIN
+  NEW(res);
+  res.sLin := t.lin; res.eLin := t.lin; 
+  res.sCol := t.col; res.eCol := t.col + t.len;
+  RETURN res; 
+END mkSpanT;
+			            
+PROCEDURE Merge*(s, e : Span) : Span;
+BEGIN
+  IF s # NIL THEN RETURN s.SpanSS(e) ELSE RETURN NIL END;
+END Merge;
+
+(* ====================== END EXPORTS ======================= *)
+
+PROCEDURE^ get*() : Token;
+(* Gets next symbol from source file *)
+
+PROCEDURE^ GetString*(pos: INTEGER; len: INTEGER; OUT name: ARRAY OF CHAR);
+(* Retrieves exact string of max length len from position pos in source file *)
+
+PROCEDURE^ charAt*(pos: INTEGER): CHAR;
+(* Returns exact character at position pos in source file *)
+
+PROCEDURE^ Reset*;
+(* Reads and stores source file internally *)
+
+PROCEDURE^ SkipAndGetLine*(i : INTEGER;		(* indent to skip *)
+			   e : INTEGER;		(* end file-pos   *)
+		       VAR p : INTEGER;		(* crnt file-pos  *)
+		       OUT l : INTEGER;		(* fetched length *)
+		       VAR s : ARRAY OF CHAR);	(* output string  *)
+
+(* ==================================================================== *)
+
+  PROCEDURE (t : Token)DiagToken*(),NEW;
+    VAR i : INTEGER;
+  BEGIN
+    Console.Write("l"); Console.WriteInt(t.lin,1); Console.Write(":");
+    Console.Write("c"); Console.WriteInt(t.col,1); Console.WriteString(" '");
+    FOR i := 0 TO t.len - 1 DO Console.Write(charAt(t.pos+i)) END;
+    Console.Write("'"); Console.WriteLn;
+  END DiagToken;
+
+  PROCEDURE digitAt(pos : INTEGER) : INTEGER;
+    VAR ch : CHAR;
+  BEGIN
+    ch := charAt(pos);
+    IF (ch >= '0') & (ch <= '9') THEN RETURN ORD(ch) - ORD('0');
+    ELSE RETURN ORD(ch) + (10 - ORD('A'));
+    END;
+  END digitAt;
+
+PROCEDURE tokToLong*(t : Token) : LONGINT;
+  VAR long : LONGINT;
+      last : LONGINT;
+      indx : INTEGER;
+      limt : INTEGER;
+      hexD : INTEGER;
+      ch   : CHAR;
+BEGIN [UNCHECKED_ARITHMETIC]
+ (*
+  *  This code requires special care.
+  *  For the CLR it would be simplest to catch overflows
+  *  in the per-character loop, and put in a rescue clause
+  *  that reported the Error-233.  Unfortunately this does
+  *  not work on the JVM, so we have to catch the overflow
+  *  manually by detecting the sum wrapping to negative.
+  *)
+  limt := t.pos + t.len - 1;
+  long := 0;
+  ch := charAt(limt);
+  IF (ch = "H") OR (ch = "L") THEN
+    DEC(limt);
+    FOR indx := t.pos TO limt DO
+      hexD := digitAt(indx);
+      long := long * 16 + hexD;
+      IF long < 0 THEN SemError.Report(233, t.lin, t.col); RETURN 0 END;
+    END;
+    IF ch = "H" THEN
+      IF RTS.hiInt(long) # 0 THEN
+        SemError.Report(232, t.lin, t.col); RETURN 0;
+      ELSE 
+        long := LONG(RTS.loInt(long));
+      END;
+    END;
+  ELSE
+    FOR indx := t.pos TO limt DO
+      ch := charAt(indx);
+      long := long * 10 + (ORD(ch) - ORD('0'));
+      IF long < 0 THEN SemError.Report(233, t.lin, t.col); RETURN 0 END;
+    END;
+  END;
+  RETURN long;
+END tokToLong;
+
+PROCEDURE tokToReal*(t : Token) : REAL;
+  VAR str : ARRAY 256 OF CHAR;
+      pOk : BOOLEAN;
+      num : REAL;
+BEGIN
+  GetString(t.pos, t.len, str);
+  RTS.StrToRealInvar(str$, num, pOk);
+  IF ~pOk THEN 
+    SemError.Report(45, t.lin, t.col); RETURN 0.0;
+  ELSE
+    RETURN num;
+  END;
+END tokToReal;
+
+PROCEDURE tokToChar*(t : Token) : CHAR;
+  VAR cOrd : LONGINT;
+      indx : INTEGER;
+      limt : INTEGER;
+      hexD : INTEGER;
+      ch   : CHAR;
+BEGIN
+  limt := t.pos + t.len - 2;
+  cOrd := 0;
+  FOR indx := t.pos TO limt DO
+    hexD := digitAt(indx);
+    cOrd := cOrd * 16 + hexD;
+  END;
+(* RANGE CHECK HERE *)
+  RETURN CHR(cOrd);
+END tokToChar;
+
+(* ====================== END EXPORTS ======================= *)
+
+  PROCEDURE NextCh;
+  (* Return global variable ch *)
+  BEGIN
+    INC(bp); ch := charAt(bp);
+    IF ch = asciiHT THEN 
+      INC(spaces,8); DEC(spaces,spaces MOD 8);
+    ELSE
+      INC(spaces);
+    END;
+    IF ch = EOL THEN INC(curLine); lineStart := bp; spaces := 0 END
+  END NextCh;
+
+(* ==================================================================== *)
+
+  PROCEDURE comment (): BOOLEAN;
+  VAR
+    level, startLine: INTEGER;
+    oldLineStart : INTEGER;
+    oldSpaces    : INTEGER;
+  BEGIN
+    level := 1; startLine := curLine; 
+    oldLineStart := lineStart; oldSpaces := spaces;
+    IF (ch = "(") THEN
+      NextCh;
+      IF (ch = "*") THEN
+        NextCh;
+        LOOP
+          IF (ch = "*") THEN
+            NextCh;
+            IF (ch = ")") THEN
+              DEC(level); NextCh;
+              IF level = 0 THEN RETURN TRUE END
+            END;
+          ELSIF (ch = "(") THEN
+            NextCh;
+            IF (ch = "*") THEN INC(level); NextCh END;
+          ELSIF ch = eof THEN RETURN FALSE
+          ELSE NextCh END;
+        END; (* LOOP *)
+      ELSE
+        IF ch = EOL THEN DEC(curLine); lineStart := oldLineStart END;
+        DEC(bp, 2); NextCh; spaces := oldSpaces; RETURN FALSE
+      END;
+    END;
+    RETURN FALSE;
+  END comment;
+
+(* ==================================================================== *)
+
+  PROCEDURE get() : Token;
+    VAR
+      state: INTEGER;
+      sym  : INTEGER;
+
+    PROCEDURE equal (IN s: ARRAY OF CHAR): BOOLEAN;
+      VAR
+        i: INTEGER;
+        q: INTEGER;
+      BEGIN
+       (* Assert: only called with literals ==> LEN(s$) = LEN(s)-1 *)
+        IF nextLen # LEN(s)-1 THEN RETURN FALSE END;
+        i := 1; q := bp0; INC(q);
+        WHILE i < nextLen DO
+          IF charAt(q) # s[i] THEN RETURN FALSE END;
+          INC(i); INC(q)
+        END;
+        RETURN TRUE
+      END equal;
+
+    PROCEDURE CheckLiteral(VAR sym : INTEGER);
+      BEGIN
+        CASE charAt(bp0) OF
+          "A": IF equal("ABSTRACT") THEN sym := Tok.ABSTRACTSym; 
+               ELSIF equal("ARRAY") THEN sym := Tok.ARRAYSym; 
+               END
+        | "B": IF equal("BEGIN") THEN sym := Tok.BEGINSym; 
+               ELSIF equal("BY") THEN sym := Tok.BYSym; 
+               END
+        | "C": IF equal("CASE") THEN sym := Tok.CASESym; 
+               ELSIF equal("CLOSE") THEN sym := Tok.CLOSESym; 
+               ELSIF equal("CONST") THEN sym := Tok.CONSTSym; 
+               END
+        | "D": IF equal("DO") THEN sym := Tok.DOSym; 
+	       ELSIF equal("DIV") THEN sym := Tok.DIVSym; 
+               ELSIF equal("DIV0") THEN sym := Tok.DIV0Sym; 
+               END
+        | "E": IF equal("ELSE") THEN sym := Tok.ELSESym; 
+               ELSIF equal("ELSIF") THEN sym := Tok.ELSIFSym; 
+               ELSIF equal("EMPTY") THEN sym := Tok.EMPTYSym; 
+               ELSIF equal("END") THEN sym := Tok.ENDSym; 
+               ELSIF equal("EXIT") THEN sym := Tok.EXITSym; 
+               ELSIF equal("EXTENSIBLE") THEN sym := Tok.EXTENSIBLESym; 
+               ELSIF equal("ENUM") THEN sym := Tok.ENUMSym; 
+               ELSIF equal("EVENT") THEN sym := Tok.EVENTSym; 
+               END
+        | "F": IF equal("FOR") THEN sym := Tok.FORSym; 
+               END
+        | "I": IF equal("IF") THEN sym := Tok.IFSym; 
+               ELSIF equal("IMPORT") THEN sym := Tok.IMPORTSym; 
+               ELSIF equal("IN") THEN sym := Tok.INSym; 
+               ELSIF equal("IS") THEN sym := Tok.ISSym; 
+               ELSIF equal("INTERFACE") THEN sym := Tok.INTERFACESym; 
+               END
+        | "L": IF equal("LIMITED") THEN sym := Tok.LIMITEDSym; 
+               ELSIF equal("LOOP") THEN sym := Tok.LOOPSym; 
+               END
+        | "M": IF equal("MOD") THEN sym := Tok.MODSym; 
+               ELSIF equal("MODULE") THEN sym := Tok.MODULESym; 
+               END
+        | "N": IF equal("NEW") THEN sym := Tok.NEWSym; 
+               ELSIF equal("NIL") THEN sym := Tok.NILSym; 
+               END
+        | "O": IF equal("OF") THEN sym := Tok.OFSym; 
+               ELSIF equal("OR") THEN sym := Tok.ORSym; 
+               ELSIF equal("OUT") THEN sym := Tok.OUTSym; 
+               END
+        | "P": IF equal("POINTER") THEN sym := Tok.POINTERSym; 
+               ELSIF equal("PROCEDURE") THEN sym := Tok.PROCEDURESym; 
+               END
+        | "R": IF equal("RECORD") THEN sym := Tok.RECORDSym; 
+               ELSIF equal("REPEAT") THEN sym := Tok.REPEATSym; 
+               ELSIF equal("RETURN") THEN sym := Tok.RETURNSym; 
+               ELSIF equal("RESCUE") THEN sym := Tok.RESCUESym; 
+               ELSIF equal("REM0")   THEN sym := Tok.REM0Sym; 
+               END
+        | "S": IF equal("STATIC") THEN sym := Tok.STATICSym; 
+               END
+        | "T": IF equal("THEN") THEN sym := Tok.THENSym; 
+               ELSIF equal("TO") THEN sym := Tok.TOSym; 
+               ELSIF equal("TYPE") THEN sym := Tok.TYPESym; 
+               END
+        | "U": IF equal("UNTIL") THEN sym := Tok.UNTILSym; 
+               END
+        | "V": IF equal("VAR") THEN sym := Tok.VARSym; 
+               ELSIF equal("VECTOR") THEN sym := Tok.VECTORSym; 
+               END
+        | "W": IF equal("WHILE") THEN sym := Tok.WHILESym; 
+               ELSIF equal("WITH") THEN sym := Tok.WITHSym; 
+               END
+        ELSE
+        END
+      END CheckLiteral;
+
+      PROCEDURE mkToken(kind : INTEGER) : Token;
+        VAR new : Token;
+      BEGIN
+        NEW(new);
+	IF kind = Tok.idVariant THEN kind := Tok.identSym; new.dlr := TRUE END;
+        new.sym := kind; 
+        new.lin := nextLine; new.col := nextCol;
+        new.len := nextLen;  new.pos := nextPos;
+        RETURN new;
+      END mkToken;
+  
+  BEGIN (*get*)
+    WHILE (ch=' ') OR
+          (ch >= CHR(9)) & (ch <= CHR(10)) OR
+          (ch = CHR(13)) DO NextCh END;
+    IF ((ch = "(")) & comment() THEN RETURN get() END;
+    pos := nextPos;   nextPos := bp;
+    col := nextCol;   nextCol := spaces;
+    line := nextLine; nextLine := curLine;
+    len := nextLen;   nextLen := 0;
+    apx := 0; state := start[ORD(ch)]; bp0 := bp;
+    LOOP
+      NextCh; INC(nextLen);
+      CASE state OF
+      (* ---------------------------------- *)
+         1: (* start of ordinary identifier *)
+	    IF (ch >= "0") & (ch <= "9") OR
+               (ch >= "A") & (ch <= "Z") OR
+               (ch >= "a") & (ch <= "z") OR
+               (ch >= 0C0X) & (ch <= 0D6X) OR
+               (ch >= 0D8X) & (ch <= 0F6X) OR
+               (ch >= 0F8X) & (ch <= 0FFX) OR
+	       (ch = "_")                THEN (* skip *)
+	    ELSIF ch = "@" THEN state := 45;
+	    ELSIF ch = "$" THEN state := 46; 
+            ELSE sym := Tok.identSym; CheckLiteral(sym); RETURN mkToken(sym);
+            END;
+      (* ---------------------------------- *)
+      | 44:(* start of ` escaped identifier *)
+	    IF (ch >= "0") & (ch <= "9") OR
+               (ch >= "A") & (ch <= "Z") OR
+               (ch >= "a") & (ch <= "z") OR
+               (ch >= 0C0X) & (ch <= 0D6X) OR
+               (ch >= 0D8X) & (ch <= 0F6X) OR
+               (ch >= 0F8X) & (ch <= 0FFX) OR
+               (ch = "_")                THEN (* skip *)
+	    ELSE 
+	      SemError.Report(187, nextLine, spaces); 
+	      RETURN mkToken(noSym);
+	    END;
+	    (* throw away the escape char *)
+	    INC(nextPos); INC(nextCol); DEC(nextLen);
+	    state := 45;
+      (* ---------------------------------- *)
+      | 45:(* rest of ` escaped identifier  *)
+	    IF (ch >= "0") & (ch <= "9") OR
+               (ch >= "A") & (ch <= "Z") OR
+               (ch >= "a") & (ch <= "z") OR
+	       (ch = "@")                OR 
+	       (ch = "_")                THEN (* skip *)
+	    ELSIF ch = "$" THEN state := 47; 
+            ELSE RETURN mkToken(Tok.idVariant); (* No check for reserved words *)
+            END;
+      (* ---------------------------------- *)
+      | 46:(* check for $ at end of ident.  *)
+	    IF (ch >= "0") & (ch <= "9") OR
+               (ch >= "A") & (ch <= "Z") OR
+               (ch >= "a") & (ch <= "z") OR
+	       (ch = "_")                THEN state := 45; (* embedded "$" *)
+            ELSE 
+              DEC(bp, 2); DEC(nextLen); NextCh; 
+              sym := Tok.identSym; CheckLiteral(sym); RETURN mkToken(sym);
+            END;
+      (* ---------------------------------- *)
+      | 47:(* check for $ at end of idVar't *)
+	    IF (ch >= "0") & (ch <= "9") OR
+               (ch >= "A") & (ch <= "Z") OR
+               (ch >= "a") & (ch <= "z") OR
+	       (ch = "_")                THEN state := 45; (* embedded "$" *)
+            ELSE 
+              DEC(bp, 2); DEC(nextLen); NextCh; 
+              RETURN mkToken(Tok.idVariant); (* No check for reserved words *)
+            END;
+      (* ---------------------------------- *)
+      |  2: RETURN mkToken(Tok.integerSym);
+      |  3: DEC(bp, apx+1); DEC(nextLen, apx);
+	    NextCh; RETURN mkToken(Tok.integerSym);
+      |  4: IF (ch >= "0") & (ch <= "9") THEN 
+            ELSIF (ch = "E") THEN state := 5; 
+            ELSE RETURN mkToken(Tok.realSym);
+            END;
+      |  5: IF (ch >= "0") & (ch <= "9") THEN state := 7; 
+            ELSIF (ch = "+") OR
+                  (ch = "-") THEN state := 6; 
+            ELSE RETURN mkToken(noSym);
+            END;
+      |  6: IF (ch >= "0") & (ch <= "9") THEN state := 7; 
+            ELSE RETURN mkToken(noSym);
+            END;
+      |  7: IF (ch >= "0") & (ch <= "9") THEN 
+            ELSE RETURN mkToken(Tok.realSym);
+            END;
+      |  8: RETURN mkToken(Tok.CharConstantSym);
+      |  9: IF (ch <= CHR(9)) OR
+               (ch >= CHR(11)) & (ch <= CHR(12)) OR
+               (ch >= CHR(14)) & (ch <= "!") OR
+               (ch>="#") THEN 
+            ELSIF (ch = '"') THEN state := 10; 
+            ELSE RETURN mkToken(noSym);
+            END;
+      | 10: RETURN mkToken(Tok.stringSym);
+      | 11: IF (ch <= CHR(9)) OR
+               (ch >= CHR(11)) & (ch <= CHR(12)) OR
+               (ch >= CHR(14)) & (ch <= "&") OR
+               (ch>="(") THEN 
+            ELSIF (ch = "'") THEN state := 10; 
+            ELSE RETURN mkToken(noSym);
+            END;
+      | 12: IF (ch >= "0") & (ch <= "9") THEN 
+            ELSIF (ch >= "A") & (ch <= "F") THEN state := 13; 
+            ELSIF (ch = "H") OR
+                  (ch = "L") THEN state := 2; 
+            ELSIF (ch = ".") THEN state := 14; INC(apx) 
+            ELSIF (ch = "X") THEN state := 8; 
+            ELSE RETURN mkToken(Tok.integerSym);
+            END;
+      | 13: IF (ch >= "0") & (ch <= "9") OR
+               (ch >= "A") & (ch <= "F") THEN 
+            ELSIF (ch = "H") OR
+                  (ch = "L") THEN state := 2; 
+            ELSIF (ch = "X") THEN state := 8; 
+            ELSE RETURN mkToken(noSym);
+            END;
+      | 14: IF (ch >= "0") & (ch <= "9") THEN state := 4; apx := 0 
+            ELSIF (ch = ".") THEN state := 3; INC(apx) 
+            ELSIF (ch = "E") THEN state := 5; apx := 0 
+            ELSE RETURN mkToken(Tok.realSym);
+            END;
+      | 15: RETURN mkToken(Tok.starSym);
+      | 16: RETURN mkToken(Tok.minusSym);
+      | 17: RETURN mkToken(Tok.bangSym);
+      | 18: IF (ch = ".") THEN state := 40; 
+            ELSE RETURN mkToken(Tok.pointSym);
+            END;
+      | 19: RETURN mkToken(Tok.equalSym);
+      | 20: RETURN mkToken(Tok.commaSym);
+      | 21: RETURN mkToken(Tok.lparenSym);
+      | 22: RETURN mkToken(Tok.plusSym);
+      | 23: RETURN mkToken(Tok.rparenSym);
+      | 24: RETURN mkToken(Tok.semicolonSym);
+      | 25: IF (ch = "=") THEN state := 41; 
+            ELSE RETURN mkToken(Tok.colonSym);
+            END;
+      | 26: RETURN mkToken(Tok.lbrackSym);
+      | 27: RETURN mkToken(Tok.rbrackSym);
+      | 28: RETURN mkToken(Tok.uparrowSym);
+      | 29: RETURN mkToken(Tok.dollarSym);
+      | 30: RETURN mkToken(Tok.hashSym);
+      | 31: IF (ch = "=") THEN state := 32; 
+            ELSE RETURN mkToken(Tok.lessSym);
+            END;
+      | 32: RETURN mkToken(Tok.lessequalSym);
+      | 33: IF (ch = "=") THEN state := 34; 
+            ELSE RETURN mkToken(Tok.greaterSym);
+            END;
+      | 34: RETURN mkToken(Tok.greaterequalSym);
+      | 35: RETURN mkToken(Tok.slashSym);
+      | 36: RETURN mkToken(Tok.andSym);
+      | 37: RETURN mkToken(Tok.tildeSym);
+      | 38: RETURN mkToken(Tok.lbraceSym);
+      | 39: RETURN mkToken(Tok.rbraceSym);
+      | 40: RETURN mkToken(Tok.pointpointSym);
+      | 41: RETURN mkToken(Tok.colonequalSym);
+      | 42: RETURN mkToken(Tok.barSym);
+      | 43: ch := 0X; DEC(bp); RETURN mkToken(Tok.EOFSYM);
+      ELSE  RETURN mkToken(noSym); (*NextCh already done*)
+      END
+    END
+  END get;
+
+(* ==================================================================== *)
+
+  PROCEDURE SkipAndGetLine(i : INTEGER;		(* indent to skip *)
+			 e : INTEGER;		(* end file-pos   *)
+		     VAR p : INTEGER;		(* crnt file-pos  *)
+		     OUT l : INTEGER;		(* fetched length *)
+		     VAR s : ARRAY OF CHAR);	(* output string  *)
+  VAR 
+    ch : CHAR;
+    ix : INTEGER;
+    sp : INTEGER;
+  BEGIN
+    sp := 0;
+    ch := charAt(p); INC(p);
+   (* skip i positions if possible *)
+    WHILE (sp < i) & (ch <= " ") & (p <= e) & (ch # asciiLF) DO
+      IF ch = asciiHT THEN INC(sp,8); DEC(sp,sp MOD 8) ELSE INC(sp) END;
+      ch := charAt(p); INC(p); 
+    END;
+    ix := 0;
+    WHILE sp > i DO
+      s[ix] := " "; INC(ix); DEC(sp);
+    END;
+    WHILE (p <= e) & (ch # asciiLF) DO
+      s[ix] := ch; INC(ix);
+      ch := charAt(p); INC(p);
+    END;
+    s[ix] := 0X; l := ix;
+  END SkipAndGetLine;
+
+(* ==================================================================== *)
+
+  PROCEDURE GetString (pos: INTEGER; len: INTEGER; OUT name: ARRAY OF CHAR);
+  VAR
+    i: INTEGER;
+    p: INTEGER;
+  BEGIN
+    IF len >= LEN(name) THEN len := LEN(name)-1 END;
+    p := pos; i := 0;
+    WHILE i < len DO
+      name[i] := charAt(p); INC(i); INC(p)
+    END;
+    name[len] := 0X;
+  END GetString;
+
+(* ==================================================================== *)
+
+  PROCEDURE charAt (pos: INTEGER): CHAR;
+  VAR
+    ch : CHAR;
+  BEGIN
+    IF pos >= inputLen THEN RETURN eof END;
+    ch := buf[pos DIV LBlkSize][pos MOD LBlkSize];
+    IF ch # eof THEN RETURN ch ELSE RETURN eof END
+  END charAt;
+
+(* ==================================================================== *)
+
+  PROCEDURE Reset;
+  VAR
+    len: INTEGER;
+    i, read: INTEGER;
+  BEGIN (*assert: src has been opened*)
+    i := -1;
+    inputLen := 0;
+    REPEAT
+      INC(i);
+     (*
+      *  Conserve memory by not deallocating the buffer.
+      *  Reuse for later compilation, expanding if necessary.
+      *)
+      IF buf[i] = NIL THEN NEW(buf[i]) END;
+(*
+      read := GPTextFiles.readNChars(src, buf[i]^, BlkSize);
+ *)
+      read := GPBinFiles.readNBytes(src, buf[i]^, BlkSize);
+      INC(inputLen, read);
+    UNTIL read < BlkSize;
+    GPBinFiles.CloseFile(src);
+    buf[i][read] := eofByt;
+    curLine := 1; lineStart := -2; bp := -1;
+    oldEols := 0; apx := 0; errors := 0; warnings := 0;
+    spaces := 0; (* # new # *)
+    NextCh;
+  END Reset;
+
+(* ==================================================================== *)
+
+BEGIN
+  start[  0] := 43; start[  1] := 48; start[  2] := 48; start[  3] := 48; 
+  start[  4] := 48; start[  5] := 48; start[  6] := 48; start[  7] := 48; 
+  start[  8] := 48; start[  9] := 48; start[ 10] := 48; start[ 11] := 48; 
+  start[ 12] := 48; start[ 13] := 48; start[ 14] := 48; start[ 15] := 48; 
+  start[ 16] := 48; start[ 17] := 48; start[ 18] := 48; start[ 19] := 48; 
+  start[ 20] := 48; start[ 21] := 48; start[ 22] := 48; start[ 23] := 48; 
+  start[ 24] := 48; start[ 25] := 48; start[ 26] := 48; start[ 27] := 48; 
+  start[ 28] := 48; start[ 29] := 48; start[ 30] := 48; start[ 31] := 48; 
+  start[ 32] := 48; start[ 33] := 17; start[ 34] :=  9; start[ 35] := 30; 
+  start[ 36] := 29; start[ 37] := 48; start[ 38] := 36; start[ 39] := 11; 
+  start[ 40] := 21; start[ 41] := 23; start[ 42] := 15; start[ 43] := 22; 
+  start[ 44] := 20; start[ 45] := 16; start[ 46] := 18; start[ 47] := 35; 
+  start[ 48] := 12; start[ 49] := 12; start[ 50] := 12; start[ 51] := 12; 
+  start[ 52] := 12; start[ 53] := 12; start[ 54] := 12; start[ 55] := 12; 
+  start[ 56] := 12; start[ 57] := 12; start[ 58] := 25; start[ 59] := 24; 
+  start[ 60] := 31; start[ 61] := 19; start[ 62] := 33; start[ 63] := 48; 
+  start[ 64] := 48; start[ 65] :=  1; start[ 66] :=  1; start[ 67] :=  1; 
+  start[ 68] :=  1; start[ 69] :=  1; start[ 70] :=  1; start[ 71] :=  1; 
+  start[ 72] :=  1; start[ 73] :=  1; start[ 74] :=  1; start[ 75] :=  1; 
+  start[ 76] :=  1; start[ 77] :=  1; start[ 78] :=  1; start[ 79] :=  1; 
+  start[ 80] :=  1; start[ 81] :=  1; start[ 82] :=  1; start[ 83] :=  1; 
+  start[ 84] :=  1; start[ 85] :=  1; start[ 86] :=  1; start[ 87] :=  1; 
+  start[ 88] :=  1; start[ 89] :=  1; start[ 90] :=  1; start[ 91] := 26; 
+  start[ 92] := 48; start[ 93] := 27; start[ 94] := 28;
+	    (* ------------------------------------------- *)
+	    (* Two special-case characters ... "_" and "`" *)
+	    (* ------------------------------------------- *)
+		    start[ 95] :=  1; start[ 96] := 44;
+	    (* ------------------------------------------- *)
+		    start[ 97] :=  1; start[ 98] :=  1; start[ 99] :=  1; 
+  start[100] :=  1; start[101] :=  1; start[102] :=  1; start[103] :=  1; 
+  start[104] :=  1; start[105] :=  1; start[106] :=  1; start[107] :=  1; 
+  start[108] :=  1; start[109] :=  1; start[110] :=  1; start[111] :=  1; 
+  start[112] :=  1; start[113] :=  1; start[114] :=  1; start[115] :=  1; 
+  start[116] :=  1; start[117] :=  1; start[118] :=  1; start[119] :=  1; 
+  start[120] :=  1; start[121] :=  1; start[122] :=  1; start[123] := 38; 
+  start[124] := 42; start[125] := 39; start[126] := 37; start[127] := 48; 
+  start[128] := 48; start[129] := 48; start[130] := 48; start[131] := 48; 
+  start[132] := 48; start[133] := 48; start[134] := 48; start[135] := 48; 
+  start[136] := 48; start[137] := 48; start[138] := 48; start[139] := 48; 
+  start[140] := 48; start[141] := 48; start[142] := 48; start[143] := 48; 
+  start[144] := 48; start[145] := 48; start[148] := 48; start[147] := 48; 
+  start[148] := 48; start[149] := 48; start[150] := 48; start[151] := 48; 
+  start[152] := 48; start[153] := 48; start[154] := 48; start[155] := 48; 
+  start[156] := 48; start[157] := 48; start[158] := 48; start[159] := 48; 
+  start[160] := 48; start[161] := 48; start[162] := 48; start[163] := 48; 
+  start[164] := 48; start[165] := 48; start[166] := 48; start[167] := 48; 
+  start[168] := 48; start[169] := 48; start[170] := 48; start[171] := 48; 
+  start[172] := 48; start[173] := 48; start[174] := 48; start[175] := 48; 
+  start[176] := 48; start[177] := 48; start[178] := 48; start[179] := 48; 
+  start[180] := 48; start[181] := 48; start[182] := 48; start[183] := 48; 
+  start[184] := 48; start[185] := 48; start[186] := 48; start[187] := 48; 
+  start[188] := 48; start[189] := 48; start[190] := 48; start[191] := 48; 
+	    (* ------------------------------------------- *)
+            (*      Latin-8 alphabetics start here ...     *)
+	    (* ------------------------------------------- *)
+  start[192] := 1; start[193] := 1; start[194] := 1; start[195] := 1; 
+  start[196] := 1; start[197] := 1; start[198] := 1; start[199] := 1; 
+  start[200] := 1; start[201] := 1; start[202] := 1; start[203] := 1; 
+  start[204] := 1; start[205] := 1; start[206] := 1; start[207] := 1; 
+  start[208] := 1; start[209] := 1; start[210] := 1; start[211] := 1; 
+  start[212] := 1; start[213] := 1; start[214] := 1; 
+
+            (* odd character out *) 
+            start[215] := 48; 
+
+  start[216] := 1; start[217] := 1; start[218] := 1; start[219] := 1; 
+  start[220] := 1; start[221] := 1; start[222] := 1; start[223] := 1; 
+  start[224] := 1; start[225] := 1; start[226] := 1; start[227] := 1; 
+  start[228] := 1; start[229] := 1; start[230] := 1; start[231] := 1; 
+  start[232] := 1; start[233] := 1; start[234] := 1; start[235] := 1; 
+  start[236] := 1; start[237] := 1; start[238] := 1; start[239] := 1; 
+  start[240] := 1; start[241] := 1; start[242] := 1; start[243] := 1; 
+  start[244] := 1; start[245] := 1; start[246] := 1; 
+
+            (* odd character out *) 
+            start[247] := 48; 
+
+  start[248] := 1; start[249] := 1; start[250] := 1; start[251] := 1; 
+  start[252] := 1; start[253] := 1; start[254] := 1; start[255] := 1; 
+  LBlkSize := BlkSize;
+END CPascalS.

gpcp/ClassMaker.cp

@@ -0,0 +1,36 @@
+(* ============================================================ *)
+(*  ClassMaker is the abstract class for all code emitters.	*)
+(*  The method Target.Select(mod, <name>) will allocate a 	*)
+(*  ClassMaker  object of an appropriate kind, and will call	*)
+(*	classMaker.Emit()					*)
+(*  Copyright (c) John Gough 1999, 2000.			*)
+(* ============================================================ *)
+
+MODULE ClassMaker;
+
+  IMPORT 
+	GPCPcopyright,
+	Console,
+	IdDesc;
+
+(* ============================================================ *)
+
+  TYPE
+    ClassEmitter* = POINTER TO ABSTRACT 
+ 		    RECORD 
+		      mod* : IdDesc.BlkId;
+		    END;
+
+    Assembler*    = POINTER TO ABSTRACT 
+ 		    RECORD 
+		    END;
+
+(* ============================================================ *)
+
+  PROCEDURE (maker : ClassEmitter)Init*(),NEW,EMPTY;
+  PROCEDURE (maker : ClassEmitter)Emit*(),NEW,ABSTRACT;
+  PROCEDURE (asmbl : Assembler)Assemble*(),NEW,EMPTY;
+
+(* ============================================================ *)
+END ClassMaker.
+(* ============================================================ *)

gpcp/ClassUtil.cp

@@ -0,0 +1,2340 @@
+(* ============================================================ *)
+(*  ClassUtil is the module which writes java classs file       *)
+(*  structures  						*)
+(*  Copyright (c) John Gough 1999, 2000.			*)
+(*  Modified DWC September, 2000.				*)
+(* ============================================================ *)
+
+MODULE ClassUtil;
+
+  IMPORT 
+        GPCPcopyright,
+        RTS,
+        Console,
+        L := LitValue,
+        J := JavaUtil,
+        FileNames,
+        GPFiles,
+        D := Symbols,
+        G := Builtin,
+        F := GPBinFiles,
+        CSt := CompState,
+        Jvm := JVMcodes,
+        Id := IdDesc,
+        Ty := TypeDesc;
+
+(* ============================================================ *)
+
+   CONST
+        classPrefix = "CP";
+        maxUnsignedByte = 255;
+        pubStat = Jvm.acc_public + Jvm.acc_static;
+        genSep = "/";
+
+(* ============================================================ *)
+(* ============================================================ *)
+(*                  Java Class File Format                      *)
+(*                                                              *)
+(* Classfile { u4 magic;                                        *)
+(*             u2 minor_version;                                *) 
+(*             u2 major_version;                                *) 
+(*             u2 constant_pool_count;                          *) 
+(*             cp_info constant_pool[constant_pool_count];      *)
+(*             u2 access_flags;                                 *) 
+(*             u2 this_class;                                   *) 
+(*             u2 super_class;                                  *) 
+(*             u2 interfaces_count;                             *) 
+(*             u2 interfaces[interfaces_count];                 *)
+(*             u2 fields_count;                                 *) 
+(*             field_info fields[field_count];                  *)
+(*             u2 methods_count;                                *) 
+(*             method_info methods[method_count];               *)
+(*             u2 attributes_count;                             *) 
+(*             attribute_info attributes[attribute_count];      *)
+(*           }                                                  *)
+(*                                                              *)
+(* ============================================================ *)
+
+  CONST 
+        (* magic = -889275714;    (* 0xCAFEBABE *) *)
+        magic = 0CAFEBABEH;
+        minorVersion = 3;
+        majorVersion = 45;
+        initSize = 50;
+
+(* ============================================================ *)
+
+  TYPE CPEntry = POINTER TO ABSTRACT RECORD
+                 END;
+
+  TYPE ClassRef = POINTER TO EXTENSIBLE RECORD (CPEntry)
+                    nameIx : INTEGER;
+                  END;
+
+  TYPE RecClass = POINTER TO RECORD (ClassRef)
+                    rec : Ty.Record;
+                  END;
+
+  TYPE ModClass = POINTER TO RECORD (ClassRef)
+                    mod : D.Scope;
+                  END;
+
+  TYPE Reference = POINTER TO EXTENSIBLE RECORD (CPEntry)
+                     classIx : INTEGER;
+                     nameAndTypeIx : INTEGER;
+                   END;
+
+  TYPE FieldRef = POINTER TO RECORD (Reference)
+                  END;
+
+  TYPE MethodRef = POINTER TO RECORD (Reference)
+                   END;
+
+  TYPE IntMethodRef = POINTER TO RECORD (Reference)
+                      END;
+
+  TYPE StringRef = POINTER TO RECORD (CPEntry)
+                     stringIx : INTEGER;
+                   END;
+
+  TYPE Integer = POINTER TO RECORD (CPEntry)
+                   iVal : INTEGER;
+                 END;
+
+  TYPE Float = POINTER TO RECORD (CPEntry)
+                 fVal : SHORTREAL;
+               END;
+
+  TYPE Long = POINTER TO RECORD (CPEntry)
+                lVal : LONGINT;
+              END;
+
+  TYPE Double = POINTER TO RECORD (CPEntry)
+                  dVal : REAL;
+                END;
+
+  TYPE NameAndType = POINTER TO RECORD (CPEntry)
+                       nameIx : INTEGER;
+                       descIx : INTEGER;
+                     END;
+
+  TYPE UTF8 = POINTER TO RECORD (CPEntry)
+                val : L.CharOpen;
+                stringRef : INTEGER;
+              END;
+
+  TYPE ConstantPool = RECORD
+                        pool : POINTER TO ARRAY OF CPEntry;
+                        tide : INTEGER;
+                      END;
+
+  TYPE FieldInfo* = POINTER TO RECORD
+                      access : INTEGER;
+                      nameIx : INTEGER;
+                      descIx : INTEGER;
+                      constValIx : INTEGER;
+                    END;
+                      
+  TYPE ExceptHandler = POINTER TO RECORD
+                         start : INTEGER;
+                         endAndHandler : INTEGER;
+                       END;
+
+  TYPE LineNumberTable = RECORD
+                           start : POINTER TO ARRAY OF INTEGER;
+                           lineNum : POINTER TO ARRAY OF INTEGER;
+                           tide : INTEGER;
+                         END;
+
+  TYPE Op = POINTER TO EXTENSIBLE RECORD
+              offset : INTEGER;
+              op : INTEGER;
+            END;
+
+  TYPE OpI = POINTER TO RECORD (Op)  
+               numBytes : INTEGER;
+               val : INTEGER;
+             END;
+                   
+  TYPE OpL = POINTER TO RECORD (Op)
+               lab : J.Label;
+             END;
+
+  TYPE OpII = POINTER TO RECORD (Op)
+               numBytes : INTEGER;
+               val1 : INTEGER; 
+               val2 : INTEGER;
+             END;
+
+  TYPE Op2IB = POINTER TO RECORD (Op)
+                 val : INTEGER; 
+                 bVal : INTEGER;
+                 trailingZero : BOOLEAN;
+               END;
+
+  TYPE OpSwitch = POINTER TO RECORD (Op)
+                    defLabel : J.Label;
+                    padding : INTEGER;
+                    low,high : INTEGER;
+                    offs : POINTER TO ARRAY OF J.Label;
+                  END;
+
+  TYPE CodeList = RECORD
+                    code : POINTER TO ARRAY OF Op;
+                    tide : INTEGER;
+                    codeLen : INTEGER;
+                  END;
+                   
+  TYPE MethodInfo* = POINTER TO RECORD
+                       methId- : D.Scope;
+                       localNum : INTEGER;    (* current locals proc  *)
+                       currStack  : INTEGER;  (* current depth proc.  *)
+                       exLb  : INTEGER;
+                       hnLb  : INTEGER;
+                       access : INTEGER;
+                       nameIx : INTEGER;
+                       descIx : INTEGER;
+                       maxStack : INTEGER;
+                       maxLocals : INTEGER;
+                       codes : CodeList;
+                       except : ExceptHandler;
+                       lineNumTab : LineNumberTable;
+                     END;
+                      
+  TYPE ClassFile* = POINTER TO RECORD (J.JavaFile)
+                      file* : GPBinFiles.FILE;
+                      meth*  : MethodInfo;
+                      nxtLb : INTEGER;
+                      access : INTEGER;
+                      cp : ConstantPool;
+                      thisClassIx : INTEGER;
+                      superClassIx : INTEGER;
+                      interfaces : POINTER TO ARRAY OF INTEGER;
+                      numInterfaces : INTEGER;
+                      fields : POINTER TO ARRAY OF FieldInfo;
+                      numFields : INTEGER;
+                      methods : POINTER TO ARRAY OF MethodInfo;
+                      numMethods : INTEGER;
+                      srcFileIx : INTEGER;
+                      srcFileAttIx : INTEGER;
+                      codeAttIx : INTEGER; 
+                      exceptAttIx : INTEGER; 
+                      lineNumTabIx : INTEGER; 
+                      jlExceptIx : INTEGER;
+                    END;
+
+(* ============================================================ *)
+
+  TYPE  TypeNameString = ARRAY 12 OF CHAR;
+
+(* ============================================================ *)
+
+  VAR
+        typeArr   : ARRAY 16 OF INTEGER;
+        procNames : ARRAY 24 OF L.CharOpen;
+        procSigs  : ARRAY 24 OF L.CharOpen;
+
+        object-       : L.CharOpen;
+        init-         : L.CharOpen;
+        clinit-       : L.CharOpen;
+        getCls-       : L.CharOpen;
+        noArgVoid-    : L.CharOpen;
+        noArgClass-   : L.CharOpen;
+        errorClass-   : L.CharOpen;
+        errorInitSig- : L.CharOpen;
+        rtsClass-     : L.CharOpen;
+        main-         : L.CharOpen;
+        mainSig-      : L.CharOpen;
+        CPmainClass-  : L.CharOpen;
+        putArgs-      : L.CharOpen;
+        srcFileStr    : L.CharOpen;
+        codeStr       : L.CharOpen;
+        lineNumTabStr : L.CharOpen;
+        caseTrap      : L.CharOpen;
+        caseTrapSig   : L.CharOpen;
+        withTrap      : L.CharOpen;
+        withTrapSig   : L.CharOpen;
+        exceptType-   : L.CharOpen;
+        srcFileName   : L.CharOpen;
+        copy-         : L.CharOpen;
+        sysClass      : L.CharOpen;
+        charClass     : L.CharOpen;
+        mathClass     : L.CharOpen;
+        IIretI        : L.CharOpen;
+        JJretJ        : L.CharOpen;
+
+  VAR
+    byte-    : L.CharOpen;
+    char-    : L.CharOpen;
+    double-  : L.CharOpen;
+    float-   : L.CharOpen;
+    int-     : L.CharOpen;
+    long-    : L.CharOpen;
+    short-   : L.CharOpen;
+    boolean- : L.CharOpen;
+
+
+(* ============================================================ *)
+
+  PROCEDURE^ cat2(i,j : L.CharOpen) : L.CharOpen;
+  PROCEDURE^ GetTypeName(typ : D.Type) : L.CharOpen;
+
+  PROCEDURE^ (cf : ClassFile)Code2I*(code,val : INTEGER; updateS : BOOLEAN),NEW;
+
+(* ============================================================ *)
+(*                   Constant Pool Stuff                        *)
+(* ============================================================ *)
+
+  PROCEDURE Add(VAR cp : ConstantPool; entry : CPEntry) : INTEGER;
+  VAR
+    i : INTEGER;
+    tmp : POINTER TO ARRAY OF CPEntry;
+  BEGIN
+    IF LEN(cp.pool) <= cp.tide+1 THEN
+      tmp := cp.pool;
+      NEW(cp.pool,2 * cp.tide);
+      FOR i := 1 TO cp.tide-1 DO
+        cp.pool[i] := tmp[i];
+      END;
+    END;
+    cp.pool[cp.tide] := entry;
+    IF (entry IS Long) OR (entry IS Double) THEN
+      INC(cp.tide,2);
+      RETURN cp.tide-2;
+    ELSE
+      INC(cp.tide);
+      RETURN cp.tide-1;
+    END;
+  END Add;
+
+  PROCEDURE Equal(utf : UTF8; str2 : L.CharOpen) : BOOLEAN;
+  VAR
+    i : INTEGER;
+    str1 : L.CharOpen;
+  BEGIN
+    IF utf.val = str2 THEN RETURN TRUE; END;
+    str1 := utf.val;
+    IF str1[0] # str2[0] THEN RETURN FALSE; END;
+    i := 1;
+    WHILE (i < LEN(str1)) & (i < LEN(str2)) &
+          (str1[i] = str2[i]) & (str1[i] # 0X) DO 
+      INC(i); 
+    END; 
+    IF (i = LEN(str1)) THEN
+      RETURN (i = LEN(str2)) OR (str2[i] = 0X);
+    ELSIF (i = LEN(str2)) THEN
+      RETURN (str1[i] = 0X);
+    ELSE
+      RETURN ((str1[i] = 0X) & (str2[i] = 0X));
+    END;
+  END Equal;
+
+  PROCEDURE AddUTF(VAR cp : ConstantPool; str : L.CharOpen) : INTEGER;
+  VAR
+    i : INTEGER;
+    utf : UTF8;
+  BEGIN
+    FOR i := 1 TO cp.tide-1 DO
+      IF (cp.pool[i] # NIL) & (cp.pool[i] IS UTF8) & 
+         (Equal(cp.pool[i](UTF8),str)) THEN
+        RETURN i;
+      END;
+    END; 
+    NEW(utf);
+    utf.val := str;
+    utf.stringRef := -1;
+    RETURN Add(cp,utf);
+  END AddUTF;
+
+  PROCEDURE AddRecClassRef(VAR cp : ConstantPool; rec : Ty.Record) : INTEGER;
+  VAR
+    i : INTEGER;
+    rc : RecClass;
+  BEGIN
+    FOR i := 1 TO cp.tide-1 DO
+      IF (cp.pool[i] # NIL) & (cp.pool[i] IS RecClass) & 
+         (cp.pool[i](RecClass).rec = rec) THEN
+        RETURN i;
+      END;
+    END; 
+    NEW(rc);
+    rc.rec := rec;
+    IF rec.xName = NIL THEN J.MkRecName(rec); END;
+    rc.nameIx := AddUTF(cp,rec.xName);
+    RETURN Add(cp,rc);
+  END AddRecClassRef;
+
+  PROCEDURE AddModClassRef(VAR cp : ConstantPool; mod : Id.BlkId) : INTEGER;
+  VAR
+    i : INTEGER;
+    mc : ModClass; 
+  BEGIN
+    FOR i := 1 TO cp.tide-1 DO
+      IF (cp.pool[i] # NIL) & (cp.pool[i] IS ModClass) & 
+         (cp.pool[i](ModClass).mod = mod) THEN
+        RETURN i;
+      END;
+    END; 
+    NEW(mc);
+    mc.mod := mod;
+    mc.nameIx := AddUTF(cp,mod.xName);
+    RETURN Add(cp,mc);
+  END AddModClassRef;
+
+  PROCEDURE AddClassRef(VAR cp : ConstantPool; clName : L.CharOpen) : INTEGER;
+  VAR
+    i,namIx : INTEGER;
+    cr : ClassRef; 
+  BEGIN
+    namIx := AddUTF(cp,clName);
+    FOR i := 1 TO cp.tide-1 DO
+      IF (cp.pool[i] # NIL) & (cp.pool[i] IS ClassRef) & 
+         (cp.pool[i](ClassRef).nameIx = namIx) THEN
+        RETURN i;
+      END;
+    END; 
+    NEW(cr);
+    cr.nameIx := namIx;
+    RETURN Add(cp,cr);
+  END AddClassRef;
+
+  PROCEDURE AddStringRef(VAR cp : ConstantPool;  str : L.CharOpen) : INTEGER;
+  VAR
+    utfIx,strIx : INTEGER;
+    strRef : StringRef;
+  BEGIN
+    utfIx := AddUTF(cp,str);
+    strIx := cp.pool[utfIx](UTF8).stringRef;
+    IF strIx = -1 THEN
+      NEW(strRef);
+      strRef.stringIx := utfIx;
+      RETURN Add(cp,strRef);
+    ELSE
+      RETURN strIx;
+    END; 
+  END AddStringRef;
+
+  PROCEDURE AddNameAndType(VAR cp : ConstantPool; nam : L.CharOpen;
+                           typ : L.CharOpen) : INTEGER;
+  VAR
+    namIx,typIx,i : INTEGER;
+    nt : NameAndType;
+  BEGIN
+    namIx := AddUTF(cp,nam);
+    typIx := AddUTF(cp,typ);
+    FOR i := 1 TO cp.tide-1 DO
+      IF (cp.pool[i] # NIL) & (cp.pool[i] IS NameAndType) THEN
+        nt := cp.pool[i](NameAndType);
+        IF (nt.nameIx = namIx) & (nt.descIx = typIx) THEN RETURN i; END;
+      END;
+    END; 
+    NEW(nt);
+    nt.nameIx := namIx; 
+    nt.descIx := typIx; 
+    RETURN Add(cp,nt);
+  END AddNameAndType;
+
+  PROCEDURE AddMethodRef(VAR cp : ConstantPool; classIx : INTEGER;
+                         methName, signature : L.CharOpen) : INTEGER;
+  VAR
+    ntIx,mIx,i : INTEGER;
+    meth : MethodRef;
+  BEGIN
+    ntIx := AddNameAndType(cp,methName,signature);
+    FOR i := 1 TO cp.tide-1 DO
+      IF (cp.pool[i] # NIL) & (cp.pool[i] IS MethodRef) THEN
+        meth := cp.pool[i](MethodRef);
+        IF (meth.classIx = classIx) & (meth.nameAndTypeIx = ntIx) THEN 
+          RETURN i; 
+        END;
+      END;
+    END; 
+    NEW(meth);
+    meth.classIx := classIx; 
+    meth.nameAndTypeIx := ntIx; 
+    RETURN Add(cp,meth);
+  END AddMethodRef;
+
+  PROCEDURE AddInterfaceMethodRef(VAR cp : ConstantPool; classIx : INTEGER;
+                         methName, signature : L.CharOpen) : INTEGER;
+  VAR
+    ntIx,mIx,i : INTEGER;
+    meth : IntMethodRef;
+  BEGIN
+    ntIx := AddNameAndType(cp,methName,signature);
+    FOR i := 1 TO cp.tide-1 DO
+      IF (cp.pool[i] # NIL) & (cp.pool[i] IS IntMethodRef) THEN
+        meth := cp.pool[i](IntMethodRef);
+        IF (meth.classIx = classIx) & (meth.nameAndTypeIx = ntIx) THEN 
+          RETURN i; 
+        END;
+      END;
+    END; 
+    NEW(meth);
+    meth.classIx := classIx; 
+    meth.nameAndTypeIx := ntIx; 
+    RETURN Add(cp,meth);
+  END AddInterfaceMethodRef;
+
+  PROCEDURE AddFieldRef(VAR cp : ConstantPool; classIx : INTEGER;
+                        fieldName, signature : L.CharOpen) : INTEGER;
+  VAR
+    ntIx,mIx,i : INTEGER;
+    field : FieldRef;
+  BEGIN
+    ntIx := AddNameAndType(cp,fieldName,signature);
+    FOR i := 1 TO cp.tide-1 DO
+      IF (cp.pool[i] # NIL) & (cp.pool[i] IS FieldRef) THEN
+        field := cp.pool[i](FieldRef);
+        IF (field.classIx = classIx) & (field.nameAndTypeIx = ntIx) THEN 
+          RETURN i; 
+        END;
+      END;
+    END; 
+    NEW(field);
+    field.classIx := classIx; 
+    field.nameAndTypeIx := ntIx; 
+    RETURN Add(cp,field);
+  END AddFieldRef;
+
+  PROCEDURE AddConstInt(VAR cp : ConstantPool; val : INTEGER) : INTEGER;
+  VAR
+    i : INTEGER;
+    conInt : Integer;
+  BEGIN
+    FOR i := 1 TO cp.tide-1 DO
+      IF (cp.pool[i] # NIL) & (cp.pool[i] IS Integer) & 
+         (cp.pool[i](Integer).iVal = val) THEN
+        RETURN i;
+      END;
+    END;
+    NEW(conInt);
+    conInt.iVal := val;
+    RETURN Add(cp,conInt);
+  END AddConstInt;
+
+  PROCEDURE AddConstLong(VAR cp : ConstantPool; val : LONGINT) : INTEGER;
+  VAR
+    i : INTEGER;
+    conLong : Long;
+  BEGIN
+    FOR i := 1 TO cp.tide-1 DO
+      IF (cp.pool[i] # NIL) & (cp.pool[i] IS Long) & 
+         (cp.pool[i](Long).lVal = val) THEN
+        RETURN i;
+      END;
+    END;
+    NEW(conLong);
+    conLong.lVal := val;
+    RETURN Add(cp,conLong);
+  END AddConstLong;
+
+  PROCEDURE AddConstFloat(VAR cp : ConstantPool; val : SHORTREAL) : INTEGER;
+  VAR
+    i : INTEGER;
+    conFloat : Float;
+  BEGIN
+    FOR i := 1 TO cp.tide-1 DO
+      IF (cp.pool[i] # NIL) & (cp.pool[i] IS Float) & 
+         (cp.pool[i](Float).fVal = val) THEN
+        RETURN i;
+      END;
+    END;
+    NEW(conFloat);
+    conFloat.fVal := val;
+    RETURN Add(cp,conFloat);
+  END AddConstFloat;
+
+  PROCEDURE AddConstDouble(VAR cp : ConstantPool; val : REAL) : INTEGER;
+  VAR
+    i : INTEGER;
+    conDouble : Double;
+  BEGIN
+    FOR i := 1 TO cp.tide-1 DO
+      IF (cp.pool[i] # NIL) & (cp.pool[i] IS Double) &
+         (cp.pool[i](Double).dVal = val) THEN
+        RETURN i;
+      END;
+    END;
+    NEW(conDouble);
+    conDouble.dVal := val;
+    RETURN Add(cp,conDouble);
+  END AddConstDouble;
+
+(* ============================================================ *)
+(*			Constructor Method			*)
+(* ============================================================ *)
+
+  PROCEDURE newClassFile*(fileName : ARRAY OF CHAR) : ClassFile;
+    VAR fil : ClassFile;
+        ptr : L.CharOpen;
+   (* -------------------------------------------------	*)
+    PROCEDURE Warp(VAR s : ARRAY OF CHAR);
+      VAR i : INTEGER;
+    BEGIN
+      FOR i := 0 TO LEN(s)-1 DO
+        IF s[i] = "/" THEN s[i] := GPFiles.fileSep END;
+      END;
+    END Warp;
+   (* -------------------------------------------------	*)
+    PROCEDURE GetFullPath(IN fn : ARRAY OF CHAR) : L.CharOpen;
+      VAR ps : L.CharOpen;
+          ch : CHAR;
+    BEGIN
+      ps := BOX(CSt.binDir);
+      ch := ps[LEN(ps) - 2];
+      IF (ch # "/") & (ch # "\") THEN
+        ps := BOX(ps^ + genSep + fn);
+      ELSE
+        ps := BOX(ps^ + fn);
+      END;
+      RETURN ps;
+    END GetFullPath;
+   (* -------------------------------------------------	*)
+  BEGIN
+    IF CSt.binDir # "" THEN
+      ptr := GetFullPath(fileName);
+    ELSE
+      ptr := BOX(fileName);
+    END;
+    Warp(ptr);
+(*
+ *  IF GPFiles.fileSep # "/" THEN Warp(fileName) END;
+ * 
+ *  srcFileName := L.strToCharOpen(CSt.srcNam); 
+ *  NEW(f);
+ *
+ *  f.file := GPBinFiles.createPath(fileName);
+ *)
+    srcFileName := BOX(CSt.srcNam); 
+    NEW(fil);
+    fil.file := GPBinFiles.createPath(ptr);
+
+    IF fil.file = NIL THEN RETURN NIL; END;
+(*
+ *  Console.WriteString("Creating file ");
+ *  Console.WriteString(ptr);
+ *  Console.WriteLn;
+ *)
+    fil.access := 0;
+    NEW(fil.cp.pool,initSize); 
+    fil.cp.tide := 1;
+    fil.thisClassIx := 0;
+    fil.superClassIx := 0;
+    fil.numInterfaces := 0;
+    fil.numFields := 0;
+    fil.numMethods := 0;
+    fil.srcFileIx := AddUTF(fil.cp,srcFileName);
+    fil.srcFileAttIx := AddUTF(fil.cp,srcFileStr);
+    fil.codeAttIx := AddUTF(fil.cp,codeStr);
+    fil.exceptAttIx := 0;
+    fil.lineNumTabIx := 0;
+    fil.jlExceptIx := 0;
+    RETURN fil;
+  END newClassFile;
+
+  PROCEDURE (cf : ClassFile) StartModClass*(mod : Id.BlkId);
+  BEGIN
+    cf.access := Jvm.acc_public + Jvm.acc_final + Jvm.acc_super; 
+    cf.thisClassIx := AddModClassRef(cf.cp,mod);
+    cf.superClassIx := AddClassRef(cf.cp,object);
+  END StartModClass;
+
+  PROCEDURE^ (cf : ClassFile) AddInterface*(interface : Ty.Record),NEW;
+                                                
+  PROCEDURE (cf : ClassFile)StartRecClass*(rec : Ty.Record);
+  VAR
+    clsId  : D.Idnt;
+    impRec : D.Type;
+    recAcc : INTEGER;
+    index  : INTEGER;
+  BEGIN
+    recAcc := Jvm.acc_super;
+    IF rec.recAtt = Ty.noAtt THEN
+      recAcc := recAcc + Jvm.acc_final;
+    ELSIF rec.recAtt = Ty.isAbs THEN
+      recAcc := recAcc + Jvm.acc_abstract;
+    END; 
+    IF rec.bindTp = NIL THEN
+      clsId := rec.idnt;
+    ELSE
+      clsId := rec.bindTp.idnt;
+    END;  
+    IF clsId # NIL THEN
+      IF clsId.vMod = D.pubMode THEN
+        recAcc := recAcc + Jvm.acc_public;
+      ELSIF clsId.vMod = D.prvMode THEN
+        recAcc := recAcc + Jvm.acc_package;
+      END;
+    END;
+    cf.access := recAcc;
+    cf.thisClassIx := AddRecClassRef(cf.cp,rec);
+    IF rec.baseTp IS Ty.Record THEN
+      IF rec.baseTp.xName = NIL THEN J.MkRecName(rec.baseTp(Ty.Record)); END;
+      cf.superClassIx := AddClassRef(cf.cp,rec.baseTp.xName);
+    ELSE
+      cf.superClassIx := AddClassRef(cf.cp,object);
+    END; 
+   (*
+    *   Emit interface declarations (if any)
+    *)
+    IF rec.interfaces.tide > 0 THEN
+      FOR index := 0 TO rec.interfaces.tide-1 DO
+        impRec := rec.interfaces.a[index];
+        cf.AddInterface(impRec.boundRecTp()(Ty.Record));
+      END;
+    END;
+  END StartRecClass;
+
+(* ============================================================ *)
+(*                   Java Class File Stuff                      *)
+(* ============================================================ *)
+
+  PROCEDURE (cf : ClassFile) InitFields*(numFields : INTEGER);
+  BEGIN
+    NEW(cf.fields,numFields);
+  END InitFields;
+
+  PROCEDURE (cf : ClassFile) AddField*(field : FieldInfo),NEW;
+  CONST
+    incSize = 10;
+  VAR
+    tmp : POINTER TO ARRAY OF FieldInfo;
+    i : INTEGER;
+  BEGIN
+    IF cf.fields = NIL THEN
+      NEW(cf.fields,incSize); 
+    ELSIF cf.numFields >= LEN(cf.fields) THEN 
+      tmp := cf.fields;
+      NEW(cf.fields,cf.numFields+incSize); 
+      FOR i := 0 TO cf.numFields-1 DO
+        cf.fields[i] := tmp[i];
+      END;
+    END; 
+    cf.fields[cf.numFields] := field;
+    INC(cf.numFields);
+  END AddField;
+
+  PROCEDURE (cf : ClassFile) InitMethods*(numMethods : INTEGER);
+  BEGIN
+    NEW(cf.methods,numMethods);
+  END InitMethods;
+
+  PROCEDURE (cf : ClassFile)AddMethod*(method : MethodInfo),NEW;
+  CONST
+    incSize = 10;
+  VAR
+    tmp : POINTER TO ARRAY OF MethodInfo;
+    i : INTEGER;
+  BEGIN
+    IF cf.methods = NIL THEN
+      NEW(cf.methods,incSize); 
+    ELSIF cf.numMethods >= LEN(cf.methods) THEN 
+      tmp := cf.methods;
+      NEW(cf.methods,cf.numMethods+incSize); 
+      FOR i := 0 TO cf.numMethods-1 DO
+        cf.methods[i] := tmp[i];
+      END;
+    END; 
+    cf.methods[cf.numMethods] := method;
+    INC(cf.numMethods);
+  END AddMethod;
+
+  PROCEDURE (cf : ClassFile) InitInterfaces*(numInterfaces : INTEGER),NEW;
+  BEGIN
+    NEW(cf.interfaces,numInterfaces);
+  END InitInterfaces;
+
+  PROCEDURE (cf : ClassFile) AddInterface*(interface : Ty.Record),NEW;
+  CONST
+    incSize = 10;
+  VAR
+    tmp : POINTER TO ARRAY OF INTEGER;
+    i, intIx : INTEGER;
+  BEGIN
+    IF cf.interfaces = NIL THEN
+      NEW(cf.interfaces,incSize); 
+    ELSIF cf.numInterfaces >= LEN(cf.interfaces) THEN 
+      tmp := cf.interfaces;
+      NEW(cf.interfaces,cf.numInterfaces+incSize); 
+      FOR i := 0 TO cf.numInterfaces-1 DO
+        cf.interfaces[i] := tmp[i];
+      END;
+    END; 
+    IF interface.xName = NIL THEN J.MkRecName(interface); END;
+    intIx := AddRecClassRef(cf.cp,interface); 
+    cf.interfaces[cf.numInterfaces] := intIx;
+    INC(cf.numInterfaces);
+  END AddInterface;
+
+(* ============================================================ *)
+(*			FieldInfo Methods			*)
+(* ============================================================ *)
+
+  PROCEDURE (cf : ClassFile) EmitField*(field : Id.AbVar);
+  VAR  
+    f : FieldInfo;
+  BEGIN
+    NEW(f);
+    CASE field.vMod OF
+    | D.prvMode : f.access := Jvm.acc_package;
+    | D.pubMode : f.access := Jvm.acc_public;
+    | D.rdoMode : f.access := Jvm.acc_public;
+    | D.protect : f.access := Jvm.acc_protected;
+    END;
+    WITH field : Id.VarId DO
+      f.access := f.access + Jvm.acc_static; 
+      IF field.varNm = NIL THEN J.MkVarName(field(Id.VarId)); END;
+      f.nameIx := AddUTF(cf.cp,field.varNm);
+    | field : Id.FldId DO
+      f.nameIx := AddUTF(cf.cp,D.getName.ChPtr(field));
+    END;
+    f.descIx := AddUTF(cf.cp, GetTypeName(field.type));
+    f.constValIx := -1; (* constants not currently stored in class file *)
+    cf.AddField(f);
+  END EmitField;
+
+(* ============================================================ *)
+(*			MethodInfo Methods			*)
+(* ============================================================ *)
+
+  PROCEDURE newMethodInfo*(meth : Id.Procs) : MethodInfo;
+    VAR m : MethodInfo;
+  BEGIN
+    NEW(m);
+    m.methId := meth;
+    IF meth = NIL THEN
+      m.localNum := 0;
+      m.maxLocals := 1;
+    ELSE        (* Id.BlkId *)
+      m.localNum := meth.rtsFram;
+      m.maxLocals := MAX(meth.rtsFram, 1);
+    END;
+    m.currStack := 0;
+    m.maxStack := 0;
+    NEW(m.codes.code,initSize);
+    m.codes.tide := 0;
+    m.codes.codeLen := 0;
+    m.lineNumTab.tide := 0;
+    RETURN m;
+  END newMethodInfo;
+
+(* ------------------------------------------------------------ *)
+
+  PROCEDURE (cf : ClassFile)StartProc*(proc : Id.Procs);
+  VAR
+    attr : INTEGER;
+    method : Id.MthId;
+  BEGIN
+    cf.meth := newMethodInfo(proc);
+    cf.AddMethod(cf.meth); 
+   (*
+    *  Compute the method attributes
+    *)
+    IF proc.kind = Id.conMth THEN
+      method := proc(Id.MthId);
+      attr := 0;
+      IF method.mthAtt * Id.mask = {} THEN attr := Jvm.acc_final; END;
+      IF method.mthAtt * Id.mask = Id.isAbs THEN
+        attr := attr + Jvm.acc_abstract;
+      END;
+      IF Id.widen IN method.mthAtt THEN attr := attr + Jvm.acc_public END; 
+    ELSE
+      attr := Jvm.acc_static;
+    END;
+(*
+ *  The following code fails for "implement-only" methods
+ *  since the JVM places the "override method" in a different 
+ *  slot! We must thus live with the insecurity of public mode.
+ *
+ *  IF proc.vMod = D.pubMode THEN	(* explicitly public *)
+ *)
+    IF (proc.vMod = D.pubMode) OR	(* explicitly public *)
+       (proc.vMod = D.rdoMode) THEN     (* "implement only"  *)
+      attr := attr + Jvm.acc_public;
+    ELSIF proc.dfScp IS Id.PrcId THEN	(* nested procedure  *)
+      attr := attr + Jvm.acc_private;
+    END;
+    cf.meth.access := attr;
+    IF (cf.meth.access >= Jvm.acc_abstract) THEN
+      cf.meth.maxLocals := 0;
+    END;
+    cf.meth.nameIx := AddUTF(cf.cp,proc.prcNm);
+    cf.meth.descIx := AddUTF(cf.cp,proc.type.xName);
+  END StartProc;
+
+  PROCEDURE (cf : ClassFile)isAbstract*() : BOOLEAN;
+  BEGIN
+    RETURN (cf.meth.access >= Jvm.acc_abstract);
+  END isAbstract;
+
+(* ------------------------------------------------------------ *)
+
+  PROCEDURE (cf : ClassFile)getScope*() : D.Scope;
+  BEGIN
+    RETURN cf.meth.methId;
+  END getScope;
+
+(* ------------------------------------------------------------ *)
+
+  PROCEDURE (cf : ClassFile)newLocal*() : INTEGER;
+    VAR ord : INTEGER;
+  BEGIN
+    ord := cf.meth.localNum;
+    INC(cf.meth.localNum);
+    IF cf.meth.localNum > cf.meth.maxLocals THEN 
+      cf.meth.maxLocals := cf.meth.localNum;
+    END;
+    RETURN ord;
+  END newLocal;
+
+(* ------------------------------------------------------------ *)
+
+  PROCEDURE (cf : ClassFile)ReleaseLocal*(i : INTEGER);
+  BEGIN
+   (*
+    *  If you try to release not in LIFO order, the 
+    *  location will not be made free again. This is safe!
+    *)
+    IF i+1 = cf.meth.localNum THEN DEC(cf.meth.localNum) END;
+  END ReleaseLocal;
+
+(* ------------------------------------------------------------ *)
+
+  PROCEDURE (cf : ClassFile)markTop*() : INTEGER;
+  BEGIN
+    RETURN cf.meth.localNum;
+  END markTop;
+
+(* ------------------------------------------------------------ *)
+
+  PROCEDURE (cf : ClassFile)ReleaseAll*(m : INTEGER);
+  BEGIN
+    cf.meth.localNum := m;
+  END ReleaseAll;
+
+(* ------------------------------------------------------------ *)
+
+  PROCEDURE (cf : ClassFile)getDepth*() : INTEGER;
+  BEGIN RETURN cf.meth.currStack END getDepth;
+
+  (* ------------------------------------------ *)
+
+  PROCEDURE (cf : ClassFile)setDepth*(i : INTEGER);
+  BEGIN cf.meth.currStack := i END setDepth;
+
+
+(* ============================================================ *)
+(*			Init Methods				*)
+(* ============================================================ *)
+
+  PROCEDURE (cf : ClassFile)ClinitHead*();
+  VAR 
+    meth : MethodInfo;
+    returned : BOOLEAN;
+  BEGIN
+    meth := newMethodInfo(NIL);
+    cf.AddMethod(meth); 
+    meth.access := pubStat;
+    meth.nameIx := AddUTF(cf.cp,clinit);
+    meth.descIx := AddUTF(cf.cp,noArgVoid);
+    cf.meth := meth; 
+  END ClinitHead;
+
+(* ============================================================ *)
+
+  PROCEDURE (cf : ClassFile)VoidTail*();
+  BEGIN
+    cf.Code(Jvm.opc_return);
+  END VoidTail;
+
+(* ============================================================ *)
+
+  PROCEDURE^ (cf : ClassFile)CallS*(code : INTEGER; 
+                            IN className : L.CharOpen;
+                            IN procName  : L.CharOpen; 
+                            IN signature : L.CharOpen; 
+	                       argL,retL : INTEGER),NEW;
+
+(* ============================================================ *)
+
+  PROCEDURE (cf : ClassFile)MainHead*();
+  VAR 
+    meth : MethodInfo;
+    returned : BOOLEAN;
+  BEGIN
+    meth := newMethodInfo(NIL);
+    cf.AddMethod(meth); 
+    meth.access := pubStat;
+    meth.nameIx := AddUTF(cf.cp,main);
+    meth.descIx := AddUTF(cf.cp,mainSig);
+    cf.meth := meth; 
+   (*
+    *  Save the command-line arguments to the RTS.
+    *)
+    cf.Code(Jvm.opc_aload_0);
+    cf.CallS(Jvm.opc_invokestatic,CPmainClass,putArgs,mainSig,1,0);
+  END MainHead;
+
+(* ============================================================ *)
+
+  PROCEDURE (cf : ClassFile)ModNoArgInit*();
+  VAR 
+    meth : MethodInfo;
+  BEGIN
+    meth := newMethodInfo(NIL);
+    cf.AddMethod(meth); 
+    meth.access := Jvm.acc_public;
+    meth.nameIx := AddUTF(cf.cp,init);
+    meth.descIx := AddUTF(cf.cp,noArgVoid);
+    cf.meth := meth; 
+    cf.Code(Jvm.opc_aload_0);
+    cf.CallS(Jvm.opc_invokespecial,object,init,noArgVoid,1,0);
+    cf.Code(Jvm.opc_return);
+  END ModNoArgInit;
+
+(* ---------------------------------------------------- *)
+
+  PROCEDURE (cf : ClassFile)RecMakeInit*(rec : Ty.Record;
+					 prc : Id.PrcId);
+    VAR meth : MethodInfo;
+	pTp : Ty.Procedure;
+	signature : L.CharOpen;
+  BEGIN
+    IF (prc = NIL) & 
+       ((D.noNew IN rec.xAttr) OR (D.xCtor IN rec.xAttr)) THEN 
+      RETURN;                                       (* PREMATURE RETURN HERE *)
+    END;
+    meth := newMethodInfo(prc);
+    cf.AddMethod(meth); 
+    cf.meth := meth; 
+    cf.Code(Jvm.opc_aload_0);
+    meth.access := Jvm.acc_public;
+    meth.nameIx := AddUTF(cf.cp,init);
+   (*
+    *  Get the procedure type, if any.
+    *)
+    IF prc # NIL THEN
+      pTp := prc.type(Ty.Procedure);
+      J.MkCallAttr(prc, pTp);
+      signature := pTp.xName;
+    ELSE
+      pTp := NIL;
+      signature := noArgVoid;
+    END;
+    meth.descIx := AddUTF(cf.cp,signature);
+  END RecMakeInit;
+
+(*
+ *  IF pTp # NIL THEN
+ *   (*
+ *    *  Copy the args to the super-constructor
+ *    *)
+ *    FOR idx := 0 TO pNm-1 DO cf.GetLocal(pTp.formals.a[idx]) END;
+ *  END;
+ *)
+
+  PROCEDURE (cf : ClassFile)CallSuperCtor*(rec : Ty.Record;
+					   pTy : Ty.Procedure);
+    VAR idx : INTEGER;
+	fld : D.Idnt;
+	pNm : INTEGER;
+        initClass : L.CharOpen;
+	signature : L.CharOpen;
+  BEGIN
+    IF pTy # NIL THEN
+      pNm := pTy.formals.tide;
+      signature := pTy.xName;
+    ELSE
+      pNm := 0;			(* was 1 *)
+      signature := noArgVoid;
+    END;
+   (*
+    *    Initialize the embedded superclass object.
+    *)
+    IF (rec.baseTp # NIL) & (rec.baseTp # G.anyRec) THEN
+      initClass := rec.baseTp(Ty.Record).xName;
+    ELSE
+      initClass := object; 
+    END;
+    cf.CallS(Jvm.opc_invokespecial, initClass, init, signature, pNm+1, 0);
+   (*
+    *    Initialize fields, as necessary.
+    *)
+    FOR idx := 0 TO rec.fields.tide-1 DO
+      fld := rec.fields.a[idx];
+      IF (fld.type IS Ty.Record) OR (fld.type IS Ty.Array) THEN
+	cf.Code(Jvm.opc_aload_0);
+	cf.VarInit(fld);
+        cf.PutGetF(Jvm.opc_putfield, rec, fld(Id.FldId));
+      END;
+    END;
+(*
+ *  cf.Code(Jvm.opc_return);
+ *)
+  END CallSuperCtor;
+
+(* ============================================================ *)
+
+  PROCEDURE makeClassVoidArgList(rec : Ty.Record) : L.CharOpen;
+  BEGIN
+    IF rec.xName = NIL THEN J.MkRecName(rec); END;
+    RETURN J.cat3(J.lPar,rec.scopeNm,J.rParV); 
+  END makeClassVoidArgList;
+  
+(* ---------------------------------------------------- *)
+
+  PROCEDURE (cf : ClassFile)CopyProcHead*(rec : Ty.Record);
+  VAR
+    meth : MethodInfo;
+  BEGIN
+    meth := newMethodInfo(NIL);
+    cf.AddMethod(meth); 
+    meth.access := Jvm.acc_public;
+    meth.nameIx := AddUTF(cf.cp,copy);
+    meth.descIx := AddUTF(cf.cp,makeClassVoidArgList(rec));
+    cf.meth := meth; 
+  END CopyProcHead;
+
+(* ============================================================ *)
+(*			Private Methods				*)
+(* ============================================================ *)
+
+  PROCEDURE (meth : MethodInfo)FixStack(code : INTEGER),NEW;
+  BEGIN
+    INC(meth.currStack, Jvm.dl[code]);
+    IF meth.currStack > meth.maxStack THEN meth.maxStack := meth.currStack END;
+  END FixStack;
+
+(* ============================================================ *)
+
+  PROCEDURE GetTypeName*(typ : D.Type) : L.CharOpen;
+  VAR
+    arrayName : L.CharOpenSeq;
+    arrayTy : D.Type;
+  BEGIN
+    WITH typ : Ty.Base DO
+        RETURN typ.xName;
+    | typ : Ty.Vector DO
+        IF typ.xName = NIL THEN J.MkVecName(typ) END;
+        RETURN typ.xName;
+    | typ : Ty.Array DO
+        IF typ.xName = NIL THEN
+          L.InitCharOpenSeq(arrayName,3);
+          arrayTy := typ;
+          WHILE arrayTy IS Ty.Array DO 
+            L.AppendCharOpen(arrayName,J.brac); 
+            arrayTy := arrayTy(Ty.Array).elemTp;
+          END;
+          L.AppendCharOpen(arrayName,GetTypeName(arrayTy)); 
+          typ.xName := L.arrayCat(arrayName);
+        END;
+        ASSERT(typ.xName # NIL);
+        RETURN typ.xName;
+    | typ : Ty.Record DO
+	IF typ.xName = NIL THEN J.MkRecName(typ) END;
+        RETURN typ.scopeNm;
+    | typ : Ty.Enum DO
+	RETURN G.intTp.xName;
+    | typ : Ty.Pointer DO
+        RETURN GetTypeName(typ.boundTp);
+    | typ : Ty.Opaque DO
+	IF typ.xName = NIL THEN J.MkAliasName(typ) END;
+        RETURN typ.scopeNm;
+    END;
+  END GetTypeName;
+
+(* ============================================================ *)
+(*			Exported Methods			*)
+(* ============================================================ *)
+
+  PROCEDURE (cf : ClassFile)newLabel*() : J.Label;
+  VAR
+    lab : J.Label;
+  BEGIN
+    NEW(lab);
+    lab.defIx := 0;
+    RETURN lab;
+  END newLabel;
+
+(* ============================================================ *)
+
+  PROCEDURE (cf : ClassFile)getLabelRange*(VAR labs : ARRAY OF J.Label);
+  VAR
+    i : INTEGER;
+  BEGIN
+    FOR i := 0 TO LEN(labs)-1 DO
+      NEW(labs[i]);
+      labs[i].defIx := 0;
+    END;
+  END getLabelRange;
+
+(* ============================================================ *)
+
+  PROCEDURE (VAR lst : CodeList)AddInstruction(op : Op),NEW;
+  VAR
+    tmp : POINTER TO ARRAY OF Op;
+    i : INTEGER;
+  BEGIN
+    ASSERT(lst.code # NIL);
+    IF lst.tide >= LEN(lst.code) THEN
+      tmp := lst.code;
+      NEW(lst.code,2 * lst.tide);
+      FOR i := 0 TO lst.tide-1 DO
+        lst.code[i] := tmp[i];
+      END;
+    END;
+    lst.code[lst.tide] := op;
+    INC(lst.tide); 
+  END AddInstruction;
+
+(* -------------------------------------------- *)
+ 
+  PROCEDURE (cf : ClassFile)DefLab*(lab : J.Label);
+  BEGIN
+    ASSERT(lab.defIx = 0);
+    lab.defIx := cf.meth.codes.codeLen;
+  END DefLab;
+
+  PROCEDURE (cf : ClassFile)DefLabC*(lab : J.Label; IN c : ARRAY OF CHAR);
+  BEGIN
+    ASSERT(lab.defIx = 0);
+    lab.defIx := cf.meth.codes.codeLen;
+  END DefLabC;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE (cf : ClassFile)AddSwitchLab*(lab : J.Label; pos : INTEGER);
+  VAR
+    sw : OpSwitch;
+  BEGIN
+    sw := cf.meth.codes.code[cf.meth.codes.tide-1](OpSwitch);
+    sw.offs[pos] := lab;
+  END AddSwitchLab;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE (cf : ClassFile)CodeLb*(code : INTEGER; lab : J.Label);
+  VAR
+    tmp : POINTER TO ARRAY OF INTEGER;
+    i : INTEGER;
+    op : OpL;
+  BEGIN
+    NEW(op);
+    op.offset := cf.meth.codes.codeLen;
+    op.op := code;
+    op.lab := lab;
+    INC(cf.meth.codes.codeLen,3);
+    cf.meth.codes.AddInstruction(op);
+    cf.meth.FixStack(code);
+  END CodeLb;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE (cf : ClassFile)Code*(code : INTEGER);
+  VAR
+    op : Op;
+  BEGIN
+    NEW(op);
+    op.offset := cf.meth.codes.codeLen;
+    op.op := code;
+    INC(cf.meth.codes.codeLen);
+    cf.meth.codes.AddInstruction(op);
+    cf.meth.FixStack(code);
+  END Code;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE (cf : ClassFile)CodeI*(code,val : INTEGER);
+  VAR
+    op : OpI;
+  BEGIN
+    NEW(op);
+    op.offset := cf.meth.codes.codeLen;
+    op.op := code;
+    op.val := val;
+    IF (val > maxUnsignedByte) & 
+       (((code >= Jvm.opc_iload) & (code <= Jvm.opc_aload)) OR
+       ((code >= Jvm.opc_istore) & (code <= Jvm.opc_astore))) THEN
+      cf.Code(Jvm.opc_wide);
+      op.numBytes := 2;
+      INC(cf.meth.codes.codeLen,3);
+    ELSE
+      op.numBytes := 1;
+      INC(cf.meth.codes.codeLen,2);
+    END; 
+    cf.meth.codes.AddInstruction(op);
+    cf.meth.FixStack(code);
+  END CodeI;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE (cf : ClassFile)Code2I*(code,val : INTEGER; updateS : BOOLEAN),NEW;
+  VAR
+    op : OpI;
+  BEGIN
+    NEW(op);
+    op.offset := cf.meth.codes.codeLen;
+    op.op := code;
+    op.val := val;
+    op.numBytes := 2;
+    INC(cf.meth.codes.codeLen,3);
+    cf.meth.codes.AddInstruction(op);
+    IF updateS THEN cf.meth.FixStack(code); END;
+  END Code2I;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE (cf : ClassFile)Code4I*(code,val : INTEGER),NEW;
+  VAR
+    op : OpI;
+  BEGIN
+    NEW(op);
+    op.offset := cf.meth.codes.codeLen;
+    op.op := code;
+    op.val := val;
+    op.numBytes := 4;
+    INC(cf.meth.codes.codeLen,5);
+    cf.meth.codes.AddInstruction(op);
+    cf.meth.FixStack(code);
+  END Code4I;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE (cf : ClassFile)Code2IB*(code,val,bVal : INTEGER;
+                                     endZero : BOOLEAN; updateS : BOOLEAN),NEW;
+  VAR
+    op : Op2IB;
+    instSize : INTEGER;
+  BEGIN
+    NEW(op);
+    op.offset := cf.meth.codes.codeLen;
+    op.op := code;
+    op.val := val;
+    op.bVal := bVal;
+    op.trailingZero := endZero;
+    IF endZero THEN INC(cf.meth.codes.codeLen,5);
+    ELSE INC(cf.meth.codes.codeLen,4); END;
+    cf.meth.codes.AddInstruction(op);
+    IF updateS THEN cf.meth.FixStack(code); END;
+  END Code2IB;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE (cf : ClassFile)CodeL*(code : INTEGER; num : LONGINT);
+  VAR
+    conIx : INTEGER;
+  BEGIN
+    conIx := AddConstLong(cf.cp,num);
+    cf.Code2I(Jvm.opc_ldc2_w, conIx, TRUE);
+  END CodeL;
+
+  PROCEDURE (cf : ClassFile)CodeR*(code : INTEGER; num : REAL; short : BOOLEAN);
+  VAR
+    conIx : INTEGER;
+  BEGIN
+    IF short THEN 
+      conIx := AddConstFloat(cf.cp,SHORT(num));
+      IF conIx > maxUnsignedByte THEN
+        cf.Code2I(Jvm.opc_ldc_w, conIx, TRUE);
+      ELSE
+        cf.CodeI(Jvm.opc_ldc, conIx);
+      END;
+    ELSE 
+      conIx := AddConstDouble(cf.cp,num);
+      cf.Code2I(Jvm.opc_ldc2_w, conIx, TRUE);
+    END;
+  END CodeR;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE (cf : ClassFile)CodeInc*(localIx,incVal : INTEGER);
+  VAR
+    op : OpII;
+    needWide : BOOLEAN;
+  BEGIN
+    needWide := (localIx > maxUnsignedByte) OR (incVal < MIN(BYTE)) OR 
+                (incVal > MAX(BYTE));
+    IF needWide THEN cf.Code(Jvm.opc_wide); END;
+    NEW(op);
+    op.offset := cf.meth.codes.codeLen;
+    op.op := Jvm.opc_iinc;
+    op.val1 := localIx;
+    op.val2 := incVal;
+    IF needWide THEN
+      op.numBytes := 2;
+      INC(cf.meth.codes.codeLen,5);
+    ELSE
+      op.numBytes := 1;
+      INC(cf.meth.codes.codeLen,3);
+    END;
+    cf.meth.codes.AddInstruction(op);
+  END CodeInc;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE (cf : ClassFile)CodeSwitch*(low,high : INTEGER; defLab : J.Label);
+  VAR
+    sw : OpSwitch;
+    len : INTEGER;
+  BEGIN
+    NEW(sw);
+    sw.offset := cf.meth.codes.codeLen;
+    sw.op := Jvm.opc_tableswitch;
+    sw.defLabel := defLab;
+    sw.low := low;
+    sw.high := high;
+    len := high-low+1;
+    NEW(sw.offs,len); 
+    sw.padding := 3 - (sw.offset MOD 4);
+    INC(cf.meth.codes.codeLen,13+sw.padding+4*len);
+    cf.meth.codes.AddInstruction(sw);
+    cf.meth.FixStack(Jvm.opc_tableswitch);
+  END CodeSwitch;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE (cf : ClassFile)CodeT*(code : INTEGER; ty : D.Type);
+  VAR
+    op : OpI;
+  BEGIN
+    IF ty IS Ty.Pointer THEN ty := ty(Ty.Pointer).boundTp; END;
+    NEW(op);
+    op.offset := cf.meth.codes.codeLen;
+    op.op := code;
+(* 
+ *  // old code ...
+ *  op.val := AddRecClassRef(cf.cp,ty(Ty.Record));
+ *  // now new code ...
+ *)
+    IF ty IS Ty.Record THEN
+      op.val := AddRecClassRef(cf.cp, ty(Ty.Record)); 
+    ELSE
+      op.val := AddClassRef(cf.cp, GetTypeName(ty)); 
+    END;
+
+    op.numBytes := 2;
+    INC(cf.meth.codes.codeLen,3);
+    cf.meth.codes.AddInstruction(op);
+    cf.meth.FixStack(code);
+  END CodeT;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE (cf : ClassFile)CodeC*(code : INTEGER; IN str : ARRAY OF CHAR);
+  VAR
+    op : Op;
+  BEGIN
+    NEW(op);
+    op.offset := cf.meth.codes.codeLen;
+    op.op := code;
+    INC(cf.meth.codes.codeLen);
+    cf.meth.codes.AddInstruction(op);
+    cf.meth.FixStack(code);
+  END CodeC;
+
+(* -------------------------------------------- *)
+  PROCEDURE (cf : ClassFile)PushStr*(IN str : L.CharOpen);
+  (* Use target quoting conventions for the literal string *)
+  VAR
+    strIx : INTEGER;
+  BEGIN
+    strIx := AddStringRef(cf.cp,str);
+    IF strIx > maxUnsignedByte THEN  
+      cf.Code2I(Jvm.opc_ldc_w, strIx, TRUE);
+    ELSE
+      cf.CodeI(Jvm.opc_ldc, strIx);
+    END;
+  END PushStr;
+
+(* ============================================================ *)
+
+  PROCEDURE (cf : ClassFile)CallS*(code : INTEGER; 
+			  	   IN className : L.CharOpen;
+                                   IN procName  : L.CharOpen;
+                                   IN signature : L.CharOpen; 
+				      argL,retL : INTEGER),NEW;
+  VAR
+    cIx,mIx : INTEGER;
+  BEGIN
+    ASSERT(code # Jvm.opc_invokeinterface);
+    cIx := AddClassRef(cf.cp,className);
+    mIx := AddMethodRef(cf.cp,cIx,procName,signature);
+    cf.Code2I(code,mIx,FALSE);
+    INC(cf.meth.currStack, retL-argL);
+    IF cf.meth.currStack > cf.meth.maxStack THEN 
+      cf.meth.maxStack := cf.meth.currStack;
+    END;
+  END CallS;
+
+(* ============================================================ *)
+
+  PROCEDURE (cf : ClassFile)CallIT*(code : INTEGER; 
+				   proc : Id.Procs; 
+				   type : Ty.Procedure);
+    VAR cIx,mIx : INTEGER;
+        scp : D.Scope;
+  BEGIN
+    IF proc.scopeNm = NIL THEN J.MkProcName(proc) END;
+    WITH proc : Id.PrcId DO 
+      cIx := AddClassRef(cf.cp,proc.clsNm);
+    |    proc : Id.MthId DO 
+      cIx := AddRecClassRef(cf.cp,proc.bndType(Ty.Record));
+    END;
+    IF code = Jvm.opc_invokeinterface THEN 
+      mIx := AddInterfaceMethodRef(cf.cp,cIx,proc.prcNm,proc.type.xName); 
+      cf.Code2IB(code,mIx,type.argN,TRUE,FALSE);
+    ELSE 
+      mIx := AddMethodRef(cf.cp,cIx,proc.prcNm,proc.type.xName);
+      cf.Code2I(code,mIx,FALSE);
+    END;
+    INC(cf.meth.currStack, type.retN-type.argN);
+    IF cf.meth.currStack > cf.meth.maxStack THEN 
+      cf.meth.maxStack := cf.meth.currStack;
+    END;
+  END CallIT;
+
+(* ============================================================ *)
+
+  PROCEDURE (cf : ClassFile)MultiNew*(arrName : L.CharOpen;
+				     dms : INTEGER),NEW;
+   (* dsc is the array descriptor, dms the number of dimensions *)
+  VAR
+    classIx : INTEGER;
+  BEGIN
+    classIx := AddClassRef(cf.cp,arrName);
+    cf.Code2IB(Jvm.opc_multianewarray,classIx,dms,FALSE,TRUE);
+    DEC(cf.meth.currStack, dms-1);
+  END MultiNew;
+
+(* ============================================================ *)
+
+  PROCEDURE (cf : ClassFile)PutGetS*(code : INTEGER;
+				    blk  : Id.BlkId;
+				    fld  : Id.VarId);
+    VAR size : INTEGER;
+        classIx : INTEGER;
+        fieldIx : INTEGER;
+        op : OpI;
+  (* Emit putstatic and getstatic for static field *)
+  BEGIN
+    IF blk.xName = NIL THEN J.MkBlkName(blk) END;
+    IF fld.varNm = NIL THEN J.MkVarName(fld) END;
+    IF fld.recTyp = NIL THEN
+      classIx := AddModClassRef(cf.cp,blk);
+    ELSE
+      classIx := AddRecClassRef(cf.cp,fld.recTyp(Ty.Record));
+    END;
+    fieldIx := AddFieldRef(cf.cp,classIx,fld.varNm,GetTypeName(fld.type));
+    NEW(op);
+    op.offset := cf.meth.codes.codeLen;
+    op.op := code;
+    op.val := fieldIx;
+    op.numBytes := 2;
+    INC(cf.meth.codes.codeLen,3);
+    cf.meth.codes.AddInstruction(op);
+    size := J.jvmSize(fld.type);
+    IF    code = Jvm.opc_getstatic THEN INC(cf.meth.currStack, size);
+    ELSIF code = Jvm.opc_putstatic THEN DEC(cf.meth.currStack, size);
+    END;
+    IF cf.meth.currStack > cf.meth.maxStack THEN 
+      cf.meth.maxStack := cf.meth.currStack 
+    END;
+  END PutGetS;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE (cf : ClassFile)PutGetF*(code : INTEGER;
+				    rec  : Ty.Record;
+				    fld  : Id.AbVar);
+    VAR size : INTEGER;
+        classIx : INTEGER;
+        fieldIx : INTEGER;
+        op : OpI;
+  (* Emit putfield and getfield for record field *)
+  BEGIN
+    classIx := AddRecClassRef(cf.cp,rec);
+    fieldIx := AddFieldRef(cf.cp,classIx,D.getName.ChPtr(fld),
+                           GetTypeName(fld.type));
+    NEW(op);
+    op.offset := cf.meth.codes.codeLen;
+    op.op := code;
+    op.val := fieldIx;
+    op.numBytes := 2;
+    INC(cf.meth.codes.codeLen,3);
+    cf.meth.codes.AddInstruction(op);
+    size := J.jvmSize(fld.type);
+    IF    code = Jvm.opc_getfield THEN INC(cf.meth.currStack, size-1);
+    ELSIF code = Jvm.opc_putfield THEN DEC(cf.meth.currStack, size+1);
+    END;
+    IF cf.meth.currStack > cf.meth.maxStack THEN 
+      cf.meth.maxStack := cf.meth.currStack;
+    END;
+  END PutGetF;
+
+(* ============================================================ *)
+
+  PROCEDURE (cf : ClassFile)Alloc1d*(elTp : D.Type);
+  VAR
+    tName : L.CharOpen;
+    classIx : INTEGER;
+  BEGIN
+    WITH elTp : Ty.Base DO
+      IF (elTp.tpOrd < Ty.anyRec) OR (elTp.tpOrd = Ty.uBytN) THEN
+        cf.CodeI(Jvm.opc_newarray, typeArr[elTp.tpOrd]);
+      ELSE
+        classIx := AddClassRef(cf.cp,object);
+        cf.Code2I(Jvm.opc_anewarray,classIx,TRUE); 
+      END;
+    ELSE
+      IF elTp IS Ty.Pointer THEN elTp := elTp(Ty.Pointer).boundTp; END;
+      IF elTp IS Ty.Record THEN
+        classIx := AddRecClassRef(cf.cp,elTp(Ty.Record)); 
+      ELSE
+        classIx := AddClassRef(cf.cp,GetTypeName(elTp)); 
+      END;
+      cf.Code2I(Jvm.opc_anewarray,classIx,TRUE); 
+    END;
+  END Alloc1d;
+
+(* ============================================================ *)
+
+  PROCEDURE (cf : ClassFile)MkNewRecord*(typ : Ty.Record);
+  VAR
+    methIx,classIx : INTEGER;
+  BEGIN
+    classIx := AddRecClassRef(cf.cp,typ);
+    cf.Code2I(Jvm.opc_new,classIx,TRUE);
+    cf.Code(Jvm.opc_dup);
+    methIx := AddMethodRef(cf.cp,classIx,init,noArgVoid); 
+    cf.Code2I(Jvm.opc_invokespecial,methIx,TRUE); 
+  END MkNewRecord;
+
+(* ============================================================ *)
+
+  PROCEDURE (cf : ClassFile)MkNewFixedArray*(topE : D.Type; len0 : INTEGER);
+    VAR dims : INTEGER;
+	arTp : Ty.Array;
+	elTp : D.Type;
+  BEGIN
+    (*
+    //  Fixed-size, possibly multi-dimensional arrays.
+    //  The code relies on the semantic property in CP
+    //  that the element-type of a fixed array type cannot
+    //  be an open array. This simplifies the code somewhat.
+    *)
+    cf.PushInt(len0);
+    dims := 1;
+    elTp := topE;
+   (*
+    *  Find the number of dimensions ...
+    *)
+    LOOP
+      WITH elTp : Ty.Array DO arTp := elTp ELSE EXIT END;
+      elTp := arTp.elemTp;
+      cf.PushInt(arTp.length);
+      INC(dims);
+    END;
+    IF dims = 1 THEN
+      cf.Alloc1d(elTp);
+     (*
+      *  Stack is (top) len0, ref...
+      *)
+      IF elTp.kind = Ty.recTp THEN cf.Init1dArray(elTp, len0) END;
+    ELSE
+     (*
+      *  Allocate the array headers for all dimensions.
+      *  Stack is (top) lenN, ... len0, ref...
+      *)
+      cf.MultiNew(cat2(J.brac,GetTypeName(topE)), dims);
+     (*
+      *  Stack is (top) ref...
+      *)
+      IF elTp.kind = Ty.recTp THEN cf.InitNdArray(topE, elTp) END;
+    END;
+  END MkNewFixedArray;
+
+(* ============================================================ *)
+
+  PROCEDURE (cf : ClassFile)MkNewOpenArray*(arrT : Ty.Array;dims : INTEGER);
+    VAR elTp : D.Type;
+	indx : INTEGER;
+  BEGIN
+   (* 
+    *  Assert: lengths are pushed already...
+    *  and we know from semantic analysis that
+    *  the number of open array dimensions match
+    *  the number of integer LENs in dims.
+    *)
+    elTp := arrT;
+   (*
+    *   Find the number of dimensions ...
+    *)
+    FOR indx := 0 TO dims-1 DO
+      elTp := elTp(Ty.Array).elemTp;
+    END;
+   (*
+    *   Allocate the array headers for all _open_ dimensions.
+    *)
+    IF dims = 1 THEN
+      cf.Alloc1d(elTp);
+     (*
+      *  Stack is now (top) ref ...
+      *  and we _might_ need to initialize the elements.
+      *)
+      IF (elTp.kind = Ty.recTp) OR 
+	 (elTp.kind = Ty.arrTp) THEN 
+	cf.Init1dArray(elTp, 0);
+      END;
+    ELSE
+      cf.MultiNew(GetTypeName(arrT), dims);
+     (*
+      *    Stack is now (top) ref ...
+      *    Now we _might_ need to initialize the elements.
+      *)
+      IF (elTp.kind = Ty.recTp) OR 
+	 (elTp.kind = Ty.arrTp) THEN 
+	cf.InitNdArray(arrT.elemTp, elTp);
+      END;
+    END;
+  END MkNewOpenArray;
+
+(* ============================================================ *)
+
+  PROCEDURE (cf : ClassFile)MkArrayCopy*(arrT : Ty.Array);
+    VAR dims : INTEGER;
+        elTp : D.Type;
+  BEGIN
+   (*
+    *	Assert: we must find the lengths from the runtime 
+    *   descriptors.  Find the number of dimensions.  The 
+    *   array to copy is on the top of stack, which reads -
+    *		(top) aRef, ...
+    *)
+    elTp := arrT.elemTp;
+    IF elTp.kind # Ty.arrTp THEN
+      cf.Code(Jvm.opc_arraylength);     (* (top) len0, aRef,...	*)
+      cf.Alloc1d(elTp);			     (* (top) aRef, ...		*)
+      IF elTp.kind = Ty.recTp THEN cf.Init1dArray(elTp, 0) END; (*0 ==> open*)
+    ELSE
+      dims := 1;
+      REPEAT
+       (* 
+        *  Invariant: an array reference is on the top of
+        *  of the stack, which reads:
+        *		(top) [arRf, lengths,] arRf ...
+	*)
+	INC(dims);
+        elTp := elTp(Ty.Array).elemTp;
+        cf.Code(Jvm.opc_dup);	     (*          arRf, arRf,... *)
+        cf.Code(Jvm.opc_arraylength);   (*    len0, arRf, arRf,... *)
+        cf.Code(Jvm.opc_swap);	     (*    arRf, len0, arRf,... *)
+        cf.Code(Jvm.opc_iconst_0);	     (* 0, arRf, len0, arRf,... *)
+        cf.Code(Jvm.opc_aaload);	     (*    arRf, len0, arRf,... *)
+       (* 
+        *  Stack reads:	(top) arRf, lenN, [lengths,] arRf ...
+	*)
+      UNTIL  elTp.kind # Ty.arrTp;
+     (*
+      *  Now get the final length...
+      *)
+      cf.Code(Jvm.opc_arraylength);  
+     (* 
+      *   Stack reads:	(top) lenM, lenN, [lengths,] arRf ...
+      *   Allocate the array headers for all dimensions.
+      *)
+      cf.MultiNew(GetTypeName(arrT), dims);
+     (*
+      *  Stack is (top) ref...
+      *)
+      IF elTp.kind = Ty.recTp THEN cf.InitNdArray(arrT.elemTp, elTp) END;
+    END;
+  END MkArrayCopy;
+
+(* ============================================================ *)
+
+  PROCEDURE (cf : ClassFile)VarInit*(var : D.Idnt);
+    VAR typ : D.Type;
+  BEGIN
+   (*
+    *  Precondition: var is of a type that needs initialization
+    *)
+    typ := var.type;
+    WITH typ : Ty.Record DO
+	cf.MkNewRecord(typ);
+    | typ : Ty.Array DO
+	cf.MkNewFixedArray(typ.elemTp, typ.length);
+    ELSE
+      cf.Code(Jvm.opc_aconst_null);
+    END;
+  END VarInit;
+
+(* ============================================================ *)
+
+  PROCEDURE (cf : ClassFile)ValRecCopy*(typ : Ty.Record);
+  BEGIN
+   (*
+    *     Stack at entry is (top) srcRef, dstRef...
+    *)
+    IF typ.xName = NIL THEN J.MkRecName(typ) END;
+    cf.CallS(Jvm.opc_invokevirtual, typ.xName, copy, 
+                                    makeClassVoidArgList(typ), 2, 0);
+  END ValRecCopy;
+
+(* ============================================================ *)
+
+  PROCEDURE (cf : ClassFile)CallRTS*(ix,args,ret : INTEGER);
+  VAR
+    className : L.CharOpen;
+  BEGIN
+    IF ix = J.ToUpper THEN 
+      className := charClass;
+    ELSIF ix = J.DFloor THEN 
+      className := mathClass;
+    ELSIF ix = J.SysExit THEN 
+      className := sysClass;
+    ELSE
+      className := rtsClass;
+    END;
+    cf.CallS(Jvm.opc_invokestatic,className,procNames[ix],procSigs[ix],args,ret);
+  END CallRTS;
+
+(* ============================================================ *)
+
+  PROCEDURE (cf : ClassFile)CallGetClass*();
+  BEGIN
+    cf.CallS(Jvm.opc_invokevirtual, object, getCls, noArgClass, 1, 1);
+  END CallGetClass;
+
+(* ============================================================ *)
+
+  PROCEDURE (cf : ClassFile)Trap*(IN str : ARRAY OF CHAR);
+  VAR
+   clIx : INTEGER;
+  BEGIN
+    clIx := AddClassRef(cf.cp,errorClass);
+    cf.Code2I(Jvm.opc_new,clIx,TRUE);
+    cf.Code(Jvm.opc_dup);
+    cf.PushStr(L.strToCharOpen(str));
+    cf.CallS(Jvm.opc_invokespecial,errorClass,init,errorInitSig,2,0);
+    cf.Code(Jvm.opc_athrow);
+  END Trap;
+
+(* ============================================================ *)
+
+  PROCEDURE (cf : ClassFile)CaseTrap*(i : INTEGER);
+  VAR
+   clIx : INTEGER;
+  BEGIN
+    clIx := AddClassRef(cf.cp,errorClass);
+    cf.Code2I(Jvm.opc_new,clIx,TRUE);
+    cf.Code(Jvm.opc_dup);
+    cf.LoadLocal(i, G.intTp);
+    cf.CallS(Jvm.opc_invokestatic,rtsClass,caseTrap,caseTrapSig,1,1);
+    cf.CallS(Jvm.opc_invokespecial,errorClass,init,errorInitSig,2,0);
+    cf.Code(Jvm.opc_athrow);
+  END CaseTrap;
+
+(* ============================================================ *)
+
+  PROCEDURE (cf : ClassFile)WithTrap*(id : D.Idnt);
+  VAR
+   clIx : INTEGER;
+  BEGIN
+    clIx := AddClassRef(cf.cp,errorClass);
+    cf.Code2I(Jvm.opc_new,clIx,TRUE);
+    cf.Code(Jvm.opc_dup);
+    cf.GetVar(id);
+    cf.CallS(Jvm.opc_invokestatic,rtsClass,withTrap,withTrapSig,1,1);
+    cf.CallS(Jvm.opc_invokespecial,errorClass,init,errorInitSig,2,0);
+    cf.Code(Jvm.opc_athrow);
+  END WithTrap;
+
+(* ============================================================ *)
+
+  PROCEDURE (cf : ClassFile)Line*(nm : INTEGER);
+  VAR
+    tmpStart, tmpNum : POINTER TO ARRAY OF INTEGER; 
+    i : INTEGER;
+  BEGIN
+    IF cf.lineNumTabIx = 0 THEN
+      cf.lineNumTabIx := AddUTF(cf.cp,lineNumTabStr);
+    END;
+    IF cf.meth.lineNumTab.start = NIL THEN
+      NEW(cf.meth.lineNumTab.start,initSize);
+      NEW(cf.meth.lineNumTab.lineNum,initSize);
+    ELSIF cf.meth.lineNumTab.tide >= LEN(cf.meth.lineNumTab.start) THEN
+      tmpStart := cf.meth.lineNumTab.start; 
+      tmpNum := cf.meth.lineNumTab.lineNum; 
+      NEW(cf.meth.lineNumTab.start,cf.meth.lineNumTab.tide + initSize);
+      NEW(cf.meth.lineNumTab.lineNum,cf.meth.lineNumTab.tide + initSize);
+      FOR i := 0 TO cf.meth.lineNumTab.tide-1 DO
+        cf.meth.lineNumTab.start[i] := tmpStart[i];  
+        cf.meth.lineNumTab.lineNum[i] := tmpNum[i];  
+      END;
+    END;
+    cf.meth.lineNumTab.start[cf.meth.lineNumTab.tide] := cf.meth.codes.codeLen;
+    cf.meth.lineNumTab.lineNum[cf.meth.lineNumTab.tide] := nm;
+    INC(cf.meth.lineNumTab.tide);
+  END Line;
+
+(* ============================================================ *)
+(*			Namehandling Methods			*)
+(* ============================================================ *)
+
+  PROCEDURE cat2(i,j : L.CharOpen) : L.CharOpen;
+  BEGIN
+    L.ResetCharOpenSeq(J.nmArray);
+    L.AppendCharOpen(J.nmArray, i);
+    L.AppendCharOpen(J.nmArray, j);
+    RETURN L.arrayCat(J.nmArray);
+  END cat2;
+
+(* ------------------------------------------------------------ *)
+
+
+  PROCEDURE (cf : ClassFile)LoadConst*(num : INTEGER);
+  VAR
+    conIx : INTEGER;
+  BEGIN
+    IF (num >= MIN(SHORTINT)) & (num <= MAX(SHORTINT)) THEN
+      cf.Code2I(Jvm.opc_sipush, num,TRUE);
+    ELSE
+      conIx := AddConstInt(cf.cp,num);
+      IF conIx > maxUnsignedByte THEN  
+        cf.Code2I(Jvm.opc_ldc_w, conIx,TRUE);
+      ELSE
+        cf.CodeI(Jvm.opc_ldc, conIx);
+      END;
+    END;
+  END LoadConst;
+
+(* ------------------------------------------------------------ *)
+
+  PROCEDURE (cf : ClassFile)Try*();
+    VAR start : INTEGER;
+  BEGIN
+    NEW(cf.meth.except);
+    cf.meth.except.start := cf.meth.codes.codeLen;
+    IF cf.jlExceptIx = 0 THEN
+      cf.jlExceptIx := AddClassRef(cf.cp,exceptType);
+    END;
+  END Try;
+
+(* ------------------------------------------------------------ *)
+
+  PROCEDURE (cf : ClassFile)MkNewException*();
+  BEGIN
+    IF cf.jlExceptIx = 0 THEN
+      cf.jlExceptIx := AddClassRef(cf.cp,exceptType);
+    END;
+    cf.Code2I(Jvm.opc_new, cf.jlExceptIx,TRUE);
+  END MkNewException; 
+
+  PROCEDURE (cf : ClassFile)InitException*();
+  BEGIN
+    cf.CallS(Jvm.opc_invokespecial, exceptType, init, errorInitSig, 2, 0);
+  END InitException;
+
+(* ------------------------------------------------------------ *)
+
+  PROCEDURE (cf : ClassFile)Catch*(prc : Id.Procs);
+  BEGIN
+    cf.meth.except.endAndHandler := cf.meth.codes.codeLen;
+    cf.StoreLocal(prc.except.varOrd, NIL);
+   (*
+    *  Now make sure that the overall stack
+    *  depth computation is correctly initialized
+    *)
+    IF cf.meth.maxStack < 1 THEN cf.meth.maxStack := 1 END;
+    cf.meth.currStack := 0;
+  END Catch;
+
+(* ============================================================ *)
+(* ============================================================ *)
+(*                Class File Writing Procedures                 *)
+(* ============================================================ *)
+(* ============================================================ *)
+
+  PROCEDURE u2 (file : F.FILE; val : INTEGER);
+  VAR  
+    b1,b2 : INTEGER;
+  BEGIN
+    b1 := val MOD 256; 
+    b2 := val DIV 256;
+    F.WriteByte(file,b2);
+    F.WriteByte(file,b1);
+  END u2;
+
+(* ------------------------------------------------------------ *)
+
+  PROCEDURE u4 (file : F.FILE; val : INTEGER);
+  VAR
+    b1,b2,b3,b4 : INTEGER;
+  BEGIN
+    b1 := val MOD 256; val := val DIV 256;
+    b2 := val MOD 256; val := val DIV 256;
+    b3 := val MOD 256; val := val DIV 256;
+    b4 := val;
+    F.WriteByte(file,b4);
+    F.WriteByte(file,b3);
+    F.WriteByte(file,b2);
+    F.WriteByte(file,b1);
+  END u4;
+
+(* ============================================================ *)
+
+  PROCEDURE WriteVal(file : F.FILE; val : INTEGER; numBytes : INTEGER);
+  BEGIN
+    CASE numBytes OF
+    | 1 : F.WriteByte(file,val);
+    | 2 : u2(file,val);
+    | 4 : u4(file,val);
+    END;
+  END WriteVal;
+
+  PROCEDURE (IN codes : CodeList)Dump(file : F.FILE),NEW;
+  VAR
+    i,j : INTEGER;
+    op : Op;
+    offset : INTEGER;
+  BEGIN
+    FOR i := 0 TO codes.tide-1 DO
+      op := codes.code[i];
+      F.WriteByte(file,op.op);
+      WITH op : OpI DO
+          WriteVal(file,op.val,op.numBytes); 
+      | op : OpII DO 
+          WriteVal(file,op.val1,op.numBytes); 
+          WriteVal(file,op.val2,op.numBytes); 
+      | op : OpL DO 
+          offset := op.lab.defIx - op.offset;
+          u2(file,offset); 
+      | op : Op2IB DO 
+          u2(file,op.val);
+          F.WriteByte(file,op.bVal);
+          IF op.trailingZero THEN F.WriteByte(file,0); END;
+      | op : OpSwitch DO
+          FOR j := 0 TO op.padding-1 DO F.WriteByte(file,0); END; 
+          u4(file,(op.defLabel.defIx - op.offset));
+          u4(file,op.low);
+          u4(file,op.high);
+          FOR j := 0 TO LEN(op.offs)-1 DO
+            offset := op.offs[j].defIx - op.offset;
+            u4(file,offset);
+          END;
+      ELSE (* nothing to do *)
+      END;
+    END;
+  END Dump;
+
+(* ============================================================ *)
+
+  PROCEDURE (meth : MethodInfo)Dump(cf : ClassFile),NEW;
+  VAR 
+    i,len : INTEGER;
+    linNumAttSize : INTEGER; 
+  BEGIN
+    u2(cf.file,meth.access);
+    u2(cf.file,meth.nameIx);
+    u2(cf.file,meth.descIx);
+    IF (meth.access >= Jvm.acc_abstract) THEN
+      u2(cf.file,0);         (* no attributes *)
+    ELSE
+      u2(cf.file,1);         (* only attribute is code *)
+      (* Start of Code attribute *)
+      (* Calculate size of code attribute *)
+      IF meth.lineNumTab.tide > 0 THEN
+        linNumAttSize := 8 + 4 * meth.lineNumTab.tide;
+      ELSE
+        linNumAttSize := 0;
+      END;
+      len := 12 + meth.codes.codeLen + linNumAttSize;
+      IF meth.except # NIL THEN INC(len,8); END;
+      u2(cf.file,cf.codeAttIx);
+      u4(cf.file,len);
+      u2(cf.file,meth.maxStack);
+      u2(cf.file,meth.maxLocals);
+      u4(cf.file,meth.codes.codeLen);
+      meth.codes.Dump(cf.file);
+      IF meth.except # NIL THEN
+        u2(cf.file,1);
+        u2(cf.file,meth.except.start);
+        u2(cf.file,meth.except.endAndHandler);
+        u2(cf.file,meth.except.endAndHandler);
+        u2(cf.file,cf.jlExceptIx);
+      ELSE
+        u2(cf.file,0);
+      END; 
+      IF meth.lineNumTab.tide > 0 THEN
+        u2(cf.file,1);
+        (* Start of line number table attribute *)
+        u2(cf.file,cf.lineNumTabIx);
+        u4(cf.file,linNumAttSize-6);
+        u2(cf.file,meth.lineNumTab.tide);
+        FOR i := 0 TO meth.lineNumTab.tide-1 DO
+          u2(cf.file,meth.lineNumTab.start[i]);
+          u2(cf.file,meth.lineNumTab.lineNum[i]);
+        END; 
+        (* End of line number table attribute *)
+      ELSE
+        u2(cf.file,0);
+      END;
+      (* End of Code attribute *)
+    END;
+  END Dump;
+
+(* ------------------------------------------------------------ *)
+
+  PROCEDURE (field : FieldInfo)Dump(cf : ClassFile),NEW;
+  BEGIN
+    u2(cf.file,field.access);
+    u2(cf.file,field.nameIx);
+    u2(cf.file,field.descIx);
+    u2(cf.file,0);  (* No attributes for fields.  ConstantValue is the     *)
+                    (* only attribute recognized for fields, but constants *)
+                    (* are not currently stored in the class file          *)
+  END Dump;
+
+(* ============================================================ *)
+
+  PROCEDURE (e : CPEntry)Dump(file : F.FILE),NEW,ABSTRACT;
+
+  PROCEDURE (u : UTF8)Dump(file : F.FILE);
+  VAR 
+    buf : POINTER TO ARRAY OF INTEGER;
+    num : INTEGER;
+    idx : INTEGER;
+    chr : INTEGER;
+   (* ================================= *)
+    PROCEDURE Expand(VAR b : POINTER TO ARRAY OF INTEGER);
+      VAR old : POINTER TO ARRAY OF INTEGER; len, idx : INTEGER;
+    BEGIN
+      len := LEN(b);
+      old := b;
+      NEW(b, len * 2);
+      FOR idx := 0 TO len-1 DO b[idx] := old[idx] END;
+    END Expand;
+   (* ================================= *)
+  BEGIN
+    NEW(buf, 256);
+    num := 0;
+    idx := 0;
+    chr := ORD(u.val[0]);
+    WHILE chr # 0H DO
+      IF num > LEN(buf)-3 THEN Expand(buf) END;
+      IF chr <= 7FH THEN
+        buf[num] := chr; INC(num);
+      ELSIF chr <= 7FFH THEN
+        buf[num+1] := 080H + chr MOD 64; chr := chr DIV 64;
+        buf[num  ] := 0C0H + chr; INC(num, 2);
+      ELSE
+        buf[num+2] := 080H + chr MOD 64; chr := chr DIV 64;
+        buf[num+1] := 080H + chr MOD 64; chr := chr DIV 64;
+        buf[num  ] := 0E0H + chr; INC(num, 3);
+      END;
+      INC(idx);
+      chr := ORD(u.val[idx]);
+    END;
+    F.WriteByte(file,Jvm.const_utf8);
+    u2(file,num);
+    FOR idx := 0 TO num-1 DO F.WriteByte(file,buf[idx]) END;
+  END Dump;
+
+  PROCEDURE (c : ClassRef)Dump(file : F.FILE);
+  BEGIN
+    F.WriteByte(file,Jvm.const_class);
+    u2(file,c.nameIx);
+  END Dump;
+
+  PROCEDURE (r : Reference)Dump(file : F.FILE);
+  VAR
+    tag : INTEGER;
+  BEGIN
+    IF r IS MethodRef THEN
+      tag := Jvm.const_methodref;
+    ELSIF r IS FieldRef THEN
+      tag := Jvm.const_fieldref;
+    ELSE
+      tag := Jvm.const_interfacemethodref;
+    END;
+    F.WriteByte(file,tag);
+    u2(file,r.classIx);
+    u2(file,r.nameAndTypeIx);
+  END Dump;
+
+  PROCEDURE (n : NameAndType)Dump(file : F.FILE);
+  BEGIN
+    F.WriteByte(file,Jvm.const_nameandtype);
+    u2(file,n.nameIx);
+    u2(file,n.descIx);
+  END Dump;
+
+  PROCEDURE (s : StringRef)Dump(file : F.FILE);
+  BEGIN
+    F.WriteByte(file,Jvm.const_string);
+    u2(file,s.stringIx);
+  END Dump;
+
+  PROCEDURE (i : Integer)Dump(file : F.FILE);
+  BEGIN
+    F.WriteByte(file,Jvm.const_integer);
+    u4(file,i.iVal);
+  END Dump;
+
+  PROCEDURE (f : Float)Dump(file : F.FILE);
+  BEGIN
+    F.WriteByte(file,Jvm.const_float);
+    u4(file,RTS.shortRealToIntBits(f.fVal));
+  END Dump;
+
+  PROCEDURE (l : Long)Dump(file : F.FILE);
+  BEGIN
+    F.WriteByte(file,Jvm.const_long);
+    u4(file,RTS.hiInt(l.lVal));
+    u4(file,RTS.loInt(l.lVal));
+  END Dump;
+
+  PROCEDURE (d : Double)Dump(file : F.FILE);
+  VAR
+    rBits : LONGINT;
+  BEGIN
+    F.WriteByte(file,Jvm.const_double);
+    rBits := RTS.realToLongBits(d.dVal);
+    u4(file,RTS.hiInt(rBits));
+    u4(file,RTS.loInt(rBits));
+  END Dump;
+
+(* ============================================================ *)
+
+  PROCEDURE (cf : ClassFile)Dump*();
+  VAR
+    i,j : INTEGER;
+  BEGIN
+    u4(cf.file,RTS.loInt(magic));        
+    u2(cf.file,minorVersion);
+    u2(cf.file,majorVersion);
+    u2(cf.file,cf.cp.tide);     (* constant pool count *)
+    FOR i := 1 TO cf.cp.tide-1 DO
+      IF cf.cp.pool[i] # NIL THEN cf.cp.pool[i].Dump(cf.file); END;
+    END;
+    u2(cf.file,cf.access);
+    u2(cf.file,cf.thisClassIx); 
+    u2(cf.file,cf.superClassIx); 
+    u2(cf.file,cf.numInterfaces);
+    FOR i := 0 TO cf.numInterfaces-1 DO
+      u2(cf.file,cf.interfaces[i]);
+    END;
+    u2(cf.file,cf.numFields);
+    FOR i := 0 TO cf.numFields-1 DO
+      cf.fields[i].Dump(cf);
+    END;
+    u2(cf.file,cf.numMethods);
+    FOR i := 0 TO cf.numMethods-1 DO
+      cf.methods[i].Dump(cf);
+    END;
+    u2(cf.file,1);  (* only class file attribute is SourceFile *)
+    u2(cf.file,cf.srcFileAttIx); 
+    u4(cf.file,2);  (* length of source file attribute *) 
+    u2(cf.file,cf.srcFileIx); 
+    GPBinFiles.CloseFile(cf.file);
+  END Dump;
+
+(* ============================================================ *)
+
+BEGIN
+  srcFileStr := L.strToCharOpen("SourceFile");
+  codeStr := L.strToCharOpen("Code");
+  lineNumTabStr := L.strToCharOpen("LineNumberTable");
+  object := L.strToCharOpen("java/lang/Object");
+  init := L.strToCharOpen("<init>");
+  clinit := L.strToCharOpen("<clinit>");
+  noArgVoid := L.strToCharOpen("()V");
+  noArgClass := L.strToCharOpen("()Ljava/lang/Class;");
+(*
+  errorClass := L.strToCharOpen("java/lang/Error"); 
+ *)
+  errorClass := L.strToCharOpen("java/lang/Exception"); 
+  errorInitSig := L.strToCharOpen("(Ljava/lang/String;)V");
+  rtsClass := L.strToCharOpen("CP/CPJrts/CPJrts");
+  caseTrap := L.strToCharOpen("CaseMesg");
+  caseTrapSig := L.strToCharOpen("(I)Ljava/lang/String;");
+  withTrap := L.strToCharOpen("WithMesg");
+  withTrapSig := L.strToCharOpen("(Ljava/lang/Object;)Ljava/lang/String;");
+  exceptType := L.strToCharOpen("java/lang/Exception");
+  main := L.strToCharOpen("main");
+  mainSig := L.strToCharOpen("([Ljava/lang/String;)V");
+  CPmainClass := L.strToCharOpen("CP/CPmain/CPmain");
+  putArgs := L.strToCharOpen("PutArgs");
+  copy := L.strToCharOpen("__copy__");
+  sysClass := L.strToCharOpen("java/lang/System");
+  charClass := L.strToCharOpen("java/lang/Character");
+  mathClass := L.strToCharOpen("java/lang/Math");
+
+  procNames[J.StrCmp]  := L.strToCharOpen("strCmp");
+  procNames[J.StrToChrOpen] := L.strToCharOpen("JavaStrToChrOpen");
+  procNames[J.StrToChrs] := L.strToCharOpen("JavaStrToFixChr");
+  procNames[J.ChrsToStr] := L.strToCharOpen("FixChToJavaStr");
+  procNames[J.StrCheck] := L.strToCharOpen("ChrArrCheck");
+  procNames[J.StrLen] := L.strToCharOpen("ChrArrLength");
+  procNames[J.ToUpper] := L.strToCharOpen("toUpperCase");
+  procNames[J.DFloor] := L.strToCharOpen("floor");
+  procNames[J.ModI] := L.strToCharOpen("CpModI");
+  procNames[J.ModL] := L.strToCharOpen("CpModL");
+  procNames[J.DivI] := L.strToCharOpen("CpDivI");
+  procNames[J.DivL] := L.strToCharOpen("CpDivL");
+  procNames[J.StrCatAA] := L.strToCharOpen("ArrArrToString");
+  procNames[J.StrCatSA] := L.strToCharOpen("StrArrToString");
+  procNames[J.StrCatAS] := L.strToCharOpen("ArrStrToString");
+  procNames[J.StrCatSS] := L.strToCharOpen("StrStrToString");
+  procNames[J.StrLP1] := L.strToCharOpen("ChrArrLplus1");
+  procNames[J.StrVal] := L.strToCharOpen("ChrArrStrCopy");
+  procNames[J.SysExit] := L.strToCharOpen("exit");
+  procNames[J.LoadTp1] := L.strToCharOpen("getClassByOrd");
+  procNames[J.LoadTp2] := L.strToCharOpen("getClassByName");
+  getCls := L.strToCharOpen("getClass");
+
+  IIretI := L.strToCharOpen("(II)I");
+  JJretJ := L.strToCharOpen("(JJ)J");
+
+  procSigs[J.StrCmp]   := L.strToCharOpen("([C[C)I");
+  procSigs[J.StrToChrOpen] := L.strToCharOpen("(Ljava/lang/String;)[C");
+  procSigs[J.StrToChrs] := L.strToCharOpen("([CLjava/lang/String;)V");
+  procSigs[J.ChrsToStr] := L.strToCharOpen("([C)Ljava/lang/String;");
+  procSigs[J.StrCheck] := L.strToCharOpen("([C)V");
+  procSigs[J.StrLen] := L.strToCharOpen("([C)I");
+  procSigs[J.ToUpper] := L.strToCharOpen("(C)C");
+  procSigs[J.DFloor] := L.strToCharOpen("(D)D");
+  procSigs[J.ModI] := IIretI;
+  procSigs[J.ModL] := JJretJ;
+  procSigs[J.DivI] := IIretI;
+  procSigs[J.DivL] := JJretJ;
+  procSigs[J.StrCatAA] := L.strToCharOpen("([C[C)Ljava/lang/String;");
+  procSigs[J.StrCatSA] := L.strToCharOpen(
+                                "(Ljava/lang/String;[C)Ljava/lang/String;");
+  procSigs[J.StrCatAS] := L.strToCharOpen(
+                                "([CLjava/lang/String;)Ljava/lang/String;");
+  procSigs[J.StrCatSS] := L.strToCharOpen(
+                   "(Ljava/lang/String;Ljava/lang/String;)Ljava/lang/String;");
+  procSigs[J.StrLP1] := procSigs[J.StrLen];
+  procSigs[J.StrVal] := L.strToCharOpen("([C[C)V");
+  procSigs[J.SysExit] := L.strToCharOpen("(I)V");
+  procSigs[J.LoadTp1] := L.strToCharOpen("(I)Ljava/lang/Class;");
+  procSigs[J.LoadTp2] := L.strToCharOpen(
+                               "(Ljava/lang/String;)Ljava/lang/Class;");
+
+  typeArr[ Ty.boolN] := 4;
+  typeArr[ Ty.sChrN] := 8;
+  typeArr[ Ty.charN] := 5;
+  typeArr[ Ty.byteN] := 8;
+  typeArr[ Ty.uBytN] := 8;
+  typeArr[ Ty.sIntN] := 9;
+  typeArr[  Ty.intN] := 10;
+  typeArr[ Ty.lIntN] := 11;
+  typeArr[ Ty.sReaN] := 6;
+  typeArr[ Ty.realN] := 7;
+  typeArr[  Ty.setN] := 10;
+END ClassUtil.
+(* ============================================================ *)
+(* ============================================================ *)
+

gpcp/ClsToType.cp

@@ -0,0 +1,1356 @@
+
+(* ================================================================ *)
+(*                                                                  *)
+(*  Module of the V1.4+ gpcp tool to create symbol files from       *)
+(*  the metadata of .NET assemblies, using the PERWAPI interface.   *)
+(*                                                                  *)
+(*  Copyright QUT 2004 - 2005.                                      *)
+(*                                                                  *)
+(*  This code released under the terms of the GPCP licence.         *)
+(*                                                                  *)
+(*  This Module:   <ClsToType>                                      *)
+(*       Transforms PERWAPI classes to GPCP TypeDesc structures.    *)
+(*       Original module, kjg December 2004                         *)
+(*                                                                  *)
+(* ================================================================ *)
+
+MODULE ClsToType;
+  IMPORT
+(*
+ *  Rfl := mscorlib_System_Reflection,  (* temporary *)
+ *  Sio := mscorlib_System_IO,          (* temporary *)
+ *)
+    FNm := FileNames,
+    Mng := ForeignName,
+    Per := "[QUT.PERWAPI]QUT.PERWAPI",
+    Glb := N2State,
+    Ltv := LitValue,
+    Cst := CompState,
+    Nh  := NameHash,
+    Id  := IdDesc,
+    Ty  := TypeDesc,
+    Xp  := ExprDesc,
+    Sy  := Symbols,
+    Bi  := Builtin,
+    Console,
+    ASCII,
+    RTS;
+
+ (* ------------------------------------------------------------ *)
+
+  CONST anon*      = 0; (* The anonymous hash index *)
+
+  CONST (* class kind enumeration *)
+        default* =  0; refCls*  =  1; valCls*  =  2;
+        enuCls*  =  3; evtCls*  =  4; dlgCls*  =  5;
+        primTyp* =  6; arrTyp*  =  7; voidTyp* =  8;
+        strTyp*  =  9; objTyp*  = 10; sysValT* = 11;
+        sysEnuT* = 12; sysDelT* = 13; sysExcT* = 14; voidStar* = 15;
+
+  CONST (* type attribute enumeration bits   *)
+        absTp = 7; intTp = 5; sldTp = 8;
+
+        (* field attribute enumeration bits  *)
+        stFld = 4; ltFld = 6; 
+
+        (* method attribute enumeration bits *)
+        stMth = 4; fnMth = 5; vrMth = 6; nwMth = 8; abMth = 10;
+
+ (* ------------------------------------------------------------ *)
+
+  TYPE  Namespace*    = POINTER TO ABSTRACT RECORD
+                          hash  : INTEGER;
+                          bloc* : Id.BlkId;
+                          tIds  : VECTOR OF Id.TypId;
+                        END;
+
+        DefNamespace* = POINTER TO RECORD (Namespace)
+                          clss  : VECTOR OF Per.ClassDef;
+                        END;
+
+        RefNamespace* = POINTER TO RECORD (Namespace)
+                          clss  : VECTOR OF Per.ClassRef;
+                        END;
+
+ (* ------------------------------------------------------------ *)
+
+  VAR   ntvObj : Sy.Type; 
+        ntvStr : Sy.Type; 
+        ntvExc : Sy.Type;
+        ntvTyp : Sy.Type; 
+        ntvEnu : Sy.Type;
+        ntvEvt : Sy.Type;
+        ntvVal : Sy.Type;
+        sysU16 : Sy.Type;
+        sysU32 : Sy.Type;
+        sysU64 : Sy.Type;
+        voidSt : Sy.Type;
+
+        intPtr : Sy.Type;
+        uIntPt : Sy.Type;
+        tpdRef : Sy.Type;
+
+        corLib : Id.BlkId;
+
+        baseArrs : ARRAY 18 OF Sy.Type;
+
+ (* ------------------------------------------------------------ *)
+ (*                   Utilities and Predicates                   *)
+ (* ------------------------------------------------------------ *)
+
+  PROCEDURE^ cpTypeFromCTS(peT : Per.Type; spc : DefNamespace) : Sy.Type;
+
+ (* ------------------------------------------------ *)
+
+  PROCEDURE isExportedType(attr : Per.TypeAttr) : BOOLEAN;
+    VAR bits : SET;
+  BEGIN
+    bits := BITS(attr) * {0..2};
+    CASE ORD(bits) OF
+    | 1, 2, 4, 7 : RETURN TRUE;
+    ELSE RETURN FALSE;
+    END;
+  END isExportedType;
+
+ (* ------------------------------------------------ *)
+
+  PROCEDURE isProtectedType(attr : Per.TypeAttr) : BOOLEAN;
+    VAR bits : SET;
+  BEGIN
+    bits := BITS(attr) * {0..2};
+    CASE ORD(bits) OF
+    | 4, 7 : RETURN TRUE;
+    ELSE RETURN FALSE;
+    END;
+  END isProtectedType;
+
+ (* ------------------------------------------------ *)
+
+  PROCEDURE isGenericClass(cls : Per.ClassDesc) : BOOLEAN;
+  BEGIN
+    RETURN LEN(cls.GetGenericParams()) > 0;
+  END isGenericClass;
+
+ (* ------------------------------------------------ *)
+
+  PROCEDURE isGenericType(typ : Per.Type) : BOOLEAN;
+  BEGIN
+    WITH typ : Per.ClassSpec DO RETURN TRUE;
+       | typ : Per.ClassDesc DO RETURN isGenericClass(typ);
+       | typ : Per.Array     DO RETURN isGenericType(typ.ElemType());
+    ELSE RETURN FALSE;
+    END;
+  END isGenericType;
+
+ (* ------------------------------------------------ *)
+
+  PROCEDURE isPublicClass(cls : Per.Class) : BOOLEAN;
+  BEGIN
+    WITH cls : Per.NestedClassDef DO
+      RETURN isExportedType(cls.GetAttributes()) &
+             ~isGenericType(cls) &
+             isPublicClass(cls.GetParentClass());
+    |    cls : Per.ClassDef DO
+      RETURN isExportedType(cls.GetAttributes()) & 
+             ~isGenericType(cls);
+    ELSE (* cls : Per.ClassRef ==> exported *)
+      RETURN TRUE;
+    END;
+  END isPublicClass;
+
+ (* ------------------------------------------------ *)
+
+  PROCEDURE hasGenericArg(mth : Per.Method) : BOOLEAN;
+    VAR idx : INTEGER;
+        par : Per.Type;
+        prs : POINTER TO ARRAY OF Per.Type;
+  BEGIN
+    prs := mth.GetParTypes();
+    FOR idx := 0 TO LEN(prs) - 1 DO
+      par := prs[idx];
+      IF isGenericType(par) THEN RETURN TRUE END;
+    END;
+    RETURN FALSE;
+  END hasGenericArg;
+
+ (* ------------------------------------------------ *)
+
+  PROCEDURE isGenericMethod(mth : Per.Method) : BOOLEAN;
+  BEGIN
+    RETURN (mth.GetGenericParam(0) # NIL) OR hasGenericArg(mth);
+  END isGenericMethod;
+
+ (* ------------------------------------------------ *)
+
+  PROCEDURE isVarargMethod(mth : Per.Method) : BOOLEAN;
+  BEGIN
+    RETURN mth.GetCallConv() = Per.CallConv.Vararg;
+  END isVarargMethod;
+
+ (* ------------------------------------------------ *)
+ (*
+  PROCEDURE isNestedType(attr : Per.TypeAttr) : BOOLEAN;
+    VAR bits : INTEGER;
+  BEGIN
+    bits := ORD(BITS(attr) * {0..2});
+    RETURN (bits >= 2) & (bits <= 7);
+  END isNestedType;
+  *)
+ (* ------------------------------------------------ *)
+
+  PROCEDURE gpName(typ : Per.Class) : RTS.NativeString;
+  BEGIN
+    WITH typ : Per.NestedClassDef DO
+        RETURN gpName(typ.GetParentClass()) + "$" + typ.Name();
+    | typ : Per.NestedClassRef DO
+        RETURN gpName(typ.GetParentClass()) + "$" + typ.Name();
+    ELSE
+      RETURN typ.Name();
+    END;
+  END gpName;
+
+ (* ------------------------------------------------ *)
+
+  PROCEDURE gpSpce(typ : Per.Class) : RTS.NativeString;
+  BEGIN
+    WITH typ : Per.NestedClassDef DO
+        RETURN gpSpce(typ.GetParentClass());
+    | typ : Per.NestedClassRef DO
+        RETURN gpSpce(typ.GetParentClass());
+    ELSE
+      RETURN typ.NameSpace();
+    END;
+  END gpSpce;
+
+ (* ------------------------------------------------ *)
+
+  PROCEDURE ilName(mth : Per.Method) : RTS.NativeString;
+    VAR cls : Per.Class;
+  BEGIN
+    cls := mth.GetParent()(Per.Class);
+    RETURN gpSpce(cls) + "." + gpName(cls) + "::'" + mth.Name() + "'";
+  END ilName;
+
+ (* ------------------------------------------------ *)
+
+  PROCEDURE isCorLibRef(res : Per.ResolutionScope) : BOOLEAN;
+    VAR str : RTS.NativeString;
+  BEGIN
+    IF Glb.isCorLib THEN 
+      RETURN FALSE; (* ==> this is corlib DEFINITION! *)
+    ELSIF res = NIL THEN 
+      RETURN FALSE;
+    ELSE
+      str := res.Name();
+      RETURN ((str = "mscorlib") OR (str = "CommonLanguageRuntimeLibrary"));
+    END;
+  END isCorLibRef;
+
+ (* ------------------------------------------------ *)
+
+  PROCEDURE SayWhy(cls : Per.Class);
+    VAR str : Glb.CharOpen;
+  BEGIN
+    WITH cls : Per.ClassSpec DO
+      str := BOX(" Hiding generic class -- "); 
+    |   cls : Per.NestedClassDef DO
+      IF ~isExportedType(cls.GetAttributes()) THEN RETURN; (* just private! *)
+      ELSIF isGenericType(cls) THEN
+        str := BOX(" Hiding generic class -- "); 
+      ELSE (* ~isPublicClass(cls.GetParentClass()); *)
+        str := BOX(" Hiding public child of private class -- "); 
+      END;
+    |   cls : Per.ClassDef DO
+      IF ~isExportedType(cls.GetAttributes()) THEN RETURN; (* just private! *)
+      ELSE (* isGenericType(cls) *)
+        str := BOX(" Hiding generic class -- "); 
+      END;
+    END;
+    Glb.Message(str^ + gpSpce(cls) + "." + gpName(cls));
+  END SayWhy;
+
+ (* ------------------------------------------------ *)
+
+  PROCEDURE getKind(typ : Per.Type) : INTEGER;
+    VAR pEnu : INTEGER;
+        pTyp : Per.Class;
+        name : RTS.NativeString;
+        rScp : Per.ResolutionScope;
+  BEGIN
+    WITH typ : Per.Array DO (* --------------- *) RETURN arrTyp;
+    | typ : Per.UnmanagedPointer DO (* ------- *) RETURN voidStar;
+    | typ : Per.PrimitiveType DO
+        IF    typ = Per.PrimitiveType.Object THEN RETURN objTyp;
+        ELSIF typ = Per.PrimitiveType.String THEN RETURN strTyp;
+        ELSIF typ = Per.PrimitiveType.Void   THEN RETURN voidTyp;
+        ELSE                                      RETURN primTyp;
+        END;
+    | typ : Per.ClassDef DO
+        rScp := typ.GetScope();
+        pTyp := typ.get_SuperType();
+       (*
+        *  If this is *not* mscorlib, then check the kind of the parent.
+        *)
+        IF ~Glb.isCorLib THEN
+          pEnu := getKind(pTyp);
+          name := gpName(typ);
+       (*
+        *  If it has no parent, then it must be Object, or some ref class.
+        *)
+        ELSIF pTyp = NIL THEN                     RETURN refCls;
+       (*
+        *  Since "ntvObj" and the others have not been initialized
+        *  for the special case of processing mscorlib, we must look
+        *  at the names of the parents.
+        *)
+        ELSE 
+          name := gpName(pTyp);
+          IF    name = "ValueType"               THEN RETURN valCls;
+          ELSIF name = "Enum"                    THEN RETURN enuCls;
+          ELSIF name = "MulticastDelegate"       THEN RETURN dlgCls;
+          ELSE (* -------------------------------- *) RETURN refCls;
+          END;
+        END;
+    | typ : Per.ClassRef DO
+        rScp := typ.GetScope();
+        name := gpName(typ);
+        pEnu := default;
+    ELSE (* ---------------------------------- *) RETURN default; 
+    END;
+
+    IF isCorLibRef(rScp) THEN
+      IF    name = "Object"                  THEN RETURN objTyp;
+      ELSIF name = "ValueType"               THEN RETURN sysValT;
+      ELSIF name = "Enum"                    THEN RETURN sysEnuT;
+      ELSIF name = "MulticastDelegate"       THEN RETURN sysDelT;
+      ELSIF name = "Exception"               THEN RETURN sysExcT;
+      END;
+    END;
+
+    IF    pEnu = sysValT                     THEN RETURN valCls;
+    ELSIF pEnu = sysDelT                     THEN RETURN dlgCls;
+    ELSIF pEnu = sysEnuT                     THEN RETURN enuCls;
+    ELSE (* ---------------------------------- *) RETURN refCls;
+    END;
+  END getKind;
+
+ (* ------------------------------------------------ *)
+
+  PROCEDURE kindStr(kind : INTEGER) : Glb.CharOpen;
+  BEGIN
+    CASE kind OF
+    | default  : RETURN BOX("opaque               ");
+    | refCls   : RETURN BOX("reference class      ");
+    | valCls   : RETURN BOX("value class          ");
+    | enuCls   : RETURN BOX("enumeration class    ");
+    | evtCls   : RETURN BOX("event class          ");
+    | dlgCls   : RETURN BOX("delegate             ");
+    | primTyp  : RETURN BOX("primitive            ");
+    | arrTyp   : RETURN BOX("array type           ");
+    | voidTyp  : RETURN BOX("void type            ");
+    | strTyp   : RETURN BOX("Sys.String           ");
+    | objTyp   : RETURN BOX("Sys.Object           ");
+    | sysValT  : RETURN BOX("Sys.ValueType        ");
+    | sysEnuT  : RETURN BOX("Sys.Enum Type        ");
+    | sysDelT  : RETURN BOX("Sys.MulticastDelegate");
+    | sysExcT  : RETURN BOX("Sys.Exception        ");
+    | voidStar : RETURN BOX("Sys.Void*            ");
+    ELSE         RETURN BOX("unknown              ");
+    END;
+  END kindStr;
+
+ (* ------------------------------------------------ *)
+
+  PROCEDURE mapPrimitive(peT : Per.Type) : Sy.Type;
+  BEGIN
+    IF    peT = Per.PrimitiveType.Int32    THEN RETURN Bi.intTp;
+    ELSIF peT = Per.PrimitiveType.Char     THEN RETURN Bi.charTp;
+    ELSIF peT = Per.PrimitiveType.Boolean  THEN RETURN Bi.boolTp;
+    ELSIF peT = Per.PrimitiveType.Int16    THEN RETURN Bi.sIntTp;
+    ELSIF peT = Per.PrimitiveType.Float64  THEN RETURN Bi.realTp;
+    ELSIF peT = Per.PrimitiveType.Int64    THEN RETURN Bi.lIntTp;
+    ELSIF peT = Per.PrimitiveType.Float32  THEN RETURN Bi.sReaTp;
+    ELSIF peT = Per.PrimitiveType.Int8     THEN RETURN Bi.byteTp;
+    ELSIF peT = Per.PrimitiveType.UInt8    THEN RETURN Bi.uBytTp;
+    ELSIF peT = Per.PrimitiveType.UInt16   THEN RETURN sysU16;
+    ELSIF peT = Per.PrimitiveType.UInt32   THEN RETURN sysU32;
+    ELSIF peT = Per.PrimitiveType.UInt64   THEN RETURN sysU64;
+    ELSIF peT = Per.PrimitiveType.IntPtr   THEN RETURN intPtr;
+    ELSIF peT = Per.PrimitiveType.UIntPtr  THEN RETURN uIntPt;
+    ELSIF peT = Per.PrimitiveType.TypedRef THEN RETURN tpdRef;
+    ELSE (* ------------------------------- *) RETURN NIL;
+    END;
+  END mapPrimitive;
+
+ (* ------------------------------------------------ *)
+
+  PROCEDURE makeNameType(blk : Id.BlkId; hsh : INTEGER) : Id.TypId;
+    VAR tId : Id.TypId;
+  BEGIN
+    tId := Id.newTypId(Ty.newNamTp());
+    tId.hash := hsh;
+    tId.dfScp := blk;
+    tId.type.idnt := tId;
+    tId.SetMode(Sy.pubMode);
+    Glb.ListTy(tId.type);
+    IF Sy.refused(tId, blk) THEN Glb.AbortMsg("bad TypId insert") END;
+    RETURN tId;
+  END makeNameType;
+
+ (* ------------------------------------------------ *)
+
+  PROCEDURE lookup(peT : Per.Class; nSp : DefNamespace) : Sy.Type;
+    VAR asm : Glb.CharOpen;  (* assembly file name *)
+        spc : Glb.CharOpen;  (* namespace name str *)
+        mNm : Glb.CharOpen;  (* CP module name     *)
+        cNm : Glb.CharOpen;  (* PE file class name *)
+        blk : Sy.Idnt;       (* The Blk descriptor *)
+        bId : Id.BlkId;      (* The Blk descriptor *)
+        tId : Sy.Idnt;       (* TypId descriptor   *)
+        hsh : INTEGER;       (* Class name hash    *)
+   (* -------------------------------------------- *)
+    PROCEDURE NoteImport(spc : DefNamespace; imp : Id.BlkId);
+    BEGIN
+      IF (spc # NIL) & (spc.bloc # imp) THEN
+        IF ~Sy.refused(imp, spc.bloc) THEN
+          IF Glb.superVb THEN
+            Console.WriteString("Inserting import <");
+            Console.WriteString(Nh.charOpenOfHash(imp.hash));
+            Console.WriteString("> in Namespace ");
+            Console.WriteString(Nh.charOpenOfHash(spc.bloc.hash));
+            Console.WriteLn;
+          END;
+        END;
+      END; 
+    END NoteImport;
+   (* -------------------------------------------- *)
+  BEGIN
+    bId := NIL;
+   (*
+    *  First we establish the (mangled) name of the defining scope.
+    *)
+    WITH peT : Per.ClassDef DO
+        asm := BOX(Glb.basNam^); (* Must do a value copy *)
+    | peT : Per.ClassRef DO
+        asm := BOX(peT.GetScope().Name());
+    ELSE 
+        RETURN NIL;
+    END;
+(*
+ *  FNm.StripExt(asm, asm);
+ *  spc := BOX(peT.NameSpace());
+ *)
+    spc := BOX(gpSpce(peT));
+    mNm := Mng.MangledName(asm, spc);
+   (*
+    *  Check if this name is already known to PeToCps
+    *)
+    blk := Glb.thisMod.symTb.lookup(Nh.enterStr(mNm));
+    cNm := BOX(gpName(peT));
+    hsh := Nh.enterStr(cNm);
+    WITH blk : Id.BlkId DO
+       (*
+        *  The module name is known to PeToCps.
+        *  However, it may not have been listed as an import
+        *  into the current namespace, in the case of multiple
+        *  namespaces defined in the same source PEFile.
+        *)
+        NoteImport(nSp, blk);
+
+        tId := blk.symTb.lookup(hsh);
+        IF (tId # NIL) & (tId IS Id.TypId) THEN 
+          RETURN tId.type;
+        ELSE
+          bId := blk;
+        END;
+    ELSE 
+    END;
+   (*
+    *  Could not find the type identifier descriptor.
+    *)
+    IF bId = NIL THEN
+     (*
+      *  Create a BlkId for the namespace.
+      *)
+      NEW(bId);
+      INCL(bId.xAttr, Sy.need);
+      Glb.BlkIdInit(bId, asm, spc);
+     (*
+      *  ... and in any case, this new BlkId is an
+      *  import into the current namespace scope.
+      *)
+      NoteImport(nSp, bId);
+    END;
+   (*
+    *  Now create a TypId, and insert in block symTab.
+    *)
+    tId := makeNameType(bId, hsh);
+    RETURN tId.type;
+  END lookup;
+
+ (* ------------------------------------------------ *)
+
+  PROCEDURE ptrToArrayOf(elTp : Sy.Type) : Sy.Type;
+    VAR ptrT : Sy.Type;
+   (* -------------------------------------------- *)
+    PROCEDURE getPtr(elT : Sy.Type) : Sy.Type;
+      VAR arT, ptT : Sy.Type;
+    BEGIN
+      arT := Ty.mkArrayOf(elT); Glb.ListTy(arT);
+      ptT := Ty.mkPtrTo(arT);   Glb.ListTy(ptT); RETURN ptT;
+    END getPtr;
+   (* -------------------------------------------- *)
+  BEGIN
+    WITH elTp : Ty.Base DO
+      ptrT := baseArrs[elTp.tpOrd];
+      IF ptrT = NIL THEN
+        ptrT := getPtr(elTp);
+        baseArrs[elTp.tpOrd] := ptrT;
+      END;
+    ELSE
+      ptrT := getPtr(elTp);
+    END;
+    RETURN ptrT;
+  END ptrToArrayOf;
+
+ (* ------------------------------------------------ *)
+
+  PROCEDURE cpTypeFromCTS(peT : Per.Type; spc : DefNamespace) : Sy.Type;
+    VAR kind : INTEGER;
+  BEGIN
+    kind := getKind(peT);
+    CASE kind OF
+    | voidTyp  : RETURN NIL;
+    | arrTyp   : RETURN ptrToArrayOf(
+                             cpTypeFromCTS(peT(Per.Array).ElemType(), spc));
+    | primTyp  : RETURN mapPrimitive(peT);
+    | strTyp   : RETURN ntvStr;
+    | objTyp   : RETURN ntvObj;
+    | sysValT  : RETURN ntvVal;
+    | sysEnuT  : RETURN ntvEnu;
+    | sysDelT  : RETURN ntvEvt;
+    | voidStar : RETURN voidSt;
+
+    ELSE (* default, refCls, valCls, enuCls, evtCls, dlgCls *)  
+      WITH peT : Per.Class DO
+        RETURN lookup(peT, spc);
+      ELSE
+        IF peT # NIL THEN
+          Console.WriteString("Not a class -- ");
+          Console.WriteLn;
+        END;
+        RETURN NIL;
+      END;
+    END;
+  END cpTypeFromCTS;
+
+ (* ------------------------------------------------ *)
+
+  PROCEDURE modeFromMbrAtt(att : SET) : INTEGER;
+  BEGIN
+    CASE ORD(att * {0,1,2}) OF
+    | 4, 5 : RETURN Sy.protect;
+    | 6    : RETURN Sy.pubMode;
+    ELSE     RETURN Sy.prvMode;
+    END;
+  END modeFromMbrAtt;
+
+ (* ------------------------------------------------ *)
+
+  PROCEDURE mkParam(IN nam : ARRAY OF CHAR; 
+                       mod : INTEGER;
+                       typ : Sy.Type; 
+                       rcv : BOOLEAN) : Id.ParId;
+    VAR par : Id.ParId;
+  BEGIN
+    par := Id.newParId();
+    par.parMod := mod;
+    par.type   := typ;
+    par.hash   := Nh.enterStr(nam);
+    par.isRcv  := rcv;
+    RETURN par;
+  END mkParam;
+
+ (* ------------------------------------------------------------ *)
+
+  PROCEDURE isValClass(cls : Per.Type) : BOOLEAN;
+  BEGIN
+    RETURN getKind(cls) = valCls;
+  END isValClass;
+
+ (* ------------------------------------------------------------ *)
+ (*                   Main processing code                       *)
+ (* ------------------------------------------------------------ *)
+
+  PROCEDURE (spc : DefNamespace)AddRecFld(rec : Ty.Record; 
+                                          fld : Per.FieldDef), NEW;
+    VAR   mod : INTEGER;
+          hsh : INTEGER;
+          bts : SET;
+          res : BOOLEAN;
+          fId : Id.FldId;
+          vId : Id.VarId;
+          cId : Id.ConId;
+   (* ------------------------------------ *)
+    PROCEDURE conExp(val : Per.Constant) : Sy.Expr;
+      VAR byts : POINTER TO ARRAY OF UBYTE;
+          chrs : POINTER TO ARRAY OF CHAR;
+          indx : INTEGER;
+    BEGIN
+      WITH val : Per.DoubleConst DO
+          RETURN Xp.mkRealLt(val.GetDouble());
+      | val : Per.FloatConst DO
+          RETURN Xp.mkRealLt(val.GetDouble());
+      | val : Per.CharConst DO
+          RETURN Xp.mkCharLt(val.GetChar());
+      | val : Per.IntConst DO
+          RETURN Xp.mkNumLt(val.GetLong());
+      | val : Per.UIntConst DO
+          RETURN Xp.mkNumLt(val.GetULongAsLong());
+      | val : Per.StringConst DO
+          byts := val.GetStringBytes();
+          NEW(chrs, LEN(byts) DIV 2 + 1);
+          FOR indx := 0 TO (LEN(byts) DIV 2)-1 DO
+            chrs[indx] := CHR(byts[indx*2] + byts[indx*2 + 1] * 256);
+          END;
+          RETURN Xp.mkStrLt(chrs);
+      END;
+    END conExp;
+   (* ------------------------------------ *)
+  BEGIN
+    bts := BITS(fld.GetFieldAttr());
+    mod := modeFromMbrAtt(bts);
+    IF mod > Sy.prvMode THEN
+      hsh := Nh.enterStr(fld.Name());
+      IF ltFld IN bts THEN                 (* literal field  *)
+        cId := Id.newConId();
+        cId.hash := hsh;
+        cId.SetMode(mod);
+        cId.recTyp := rec;
+        cId.type := cpTypeFromCTS(fld.GetFieldType(), spc);
+        cId.conExp := conExp(fld.GetValue());
+        res := rec.symTb.enter(hsh, cId);
+        Sy.AppendIdnt(rec.statics, cId);
+      ELSIF stFld IN bts THEN              (* static field   *)
+        vId := Id.newVarId();
+        vId.hash := hsh;
+        vId.SetMode(mod);
+        vId.recTyp := rec;
+        vId.type := cpTypeFromCTS(fld.GetFieldType(), spc);
+        res := rec.symTb.enter(hsh, vId);
+        Sy.AppendIdnt(rec.statics, vId);
+      ELSE                                 (* instance field *)
+        fId := Id.newFldId();
+        fId.hash := hsh;
+        fId.SetMode(mod);
+        fId.recTyp := rec;
+        fId.type := cpTypeFromCTS(fld.GetFieldType(), spc);
+        res := rec.symTb.enter(hsh, fId);
+        Sy.AppendIdnt(rec.fields, fId);
+      END;
+    END;
+  END AddRecFld;
+
+ (* ------------------------------------------------------------ *)
+
+  PROCEDURE (spc : DefNamespace)AddFormals(typ : Ty.Procedure; 
+                                           mth : Per.MethodDef), NEW;
+    VAR indx : INTEGER;
+        pMod : INTEGER;
+        thsP : Per.Param;
+        thsT : Per.Type;
+        pPar : Id.ParId;
+        pars : POINTER TO ARRAY OF Per.Param;
+
+  BEGIN
+    typ.retType := cpTypeFromCTS(mth.GetRetType(), spc);
+    pars := mth.GetParams();
+    FOR indx := 0 TO LEN(pars) - 1 DO
+      pMod := Sy.val;
+      thsP := pars[indx];
+      thsT := thsP.GetParType();
+      IF thsT IS Per.ManagedPointer THEN
+        thsT := thsT(Per.PtrType).GetBaseType(); pMod := Sy.var;
+      END;
+      pPar := mkParam(thsP.GetName(), pMod, cpTypeFromCTS(thsT, spc), FALSE);
+      Id.AppendParam(typ.formals, pPar);
+    END;
+  END AddFormals;
+
+ (* ------------------------------------------------------------ *)
+
+  PROCEDURE (spc : DefNamespace)AddRecMth(rec : Ty.Record; 
+                                          mth : Per.MethodDef), NEW;
+    VAR   mod : INTEGER;
+          hsh : INTEGER;
+          pMd : INTEGER;
+          bts : SET;
+          res : BOOLEAN;
+          pId : Id.PrcId;
+          mId : Id.MthId;
+          rcv : Per.Type;        (* Receiver type *)
+          pTp : Ty.Procedure;
+  BEGIN
+   (* SPECIAL FOR PRE 1.4 VERSION *)
+    IF isGenericMethod(mth) THEN
+      Glb.CondMsg(" Hiding generic method -- " + ilName(mth));
+      RETURN;
+    ELSIF isVarargMethod(mth) THEN
+      Glb.CondMsg(" Hiding Vararg call method -- " + ilName(mth));
+      RETURN;
+    END;
+    bts := BITS(mth.GetMethAttributes());
+    mod := modeFromMbrAtt(bts);
+    IF mod > Sy.prvMode THEN
+      hsh := Nh.enterStr(mth.Name());
+
+      IF stMth IN bts THEN                (* static method *)
+        pId := Id.newPrcId(); 
+        pId.SetKind(Id.conPrc);
+        pId.hash := hsh;
+        pId.SetMode(mod);
+        pTp := Ty.newPrcTp();
+        pTp.idnt := pId;
+        pId.type := pTp;
+        spc.AddFormals(pTp, mth);
+        res := rec.symTb.enter(hsh, pId);
+        Sy.AppendIdnt(rec.statics, pId);
+        Glb.ListTy(pTp);
+
+      ELSIF hsh = Glb.ctorBkt THEN        (* constructor method *)
+        pId := Id.newPrcId(); 
+        pId.SetKind(Id.ctorP);
+        pId.hash := Glb.initBkt;
+        pId.prcNm := BOX(".ctor");
+        pId.SetMode(mod);
+        pTp := Ty.newPrcTp();
+        pTp.idnt := pId;
+        pId.type := pTp;
+        spc.AddFormals(pTp, mth);
+        rcv := mth.GetParent()(Per.Type);
+        pTp.retType := cpTypeFromCTS(rcv, spc);
+        res := rec.symTb.enter(Glb.initBkt, pId);
+        Sy.AppendIdnt(rec.statics, pId);
+        Glb.ListTy(pTp);
+
+      ELSE                                (* instance method *)
+        mId := Id.newMthId();
+        mId.SetKind(Id.conMth);
+        mId.hash := hsh;
+        mId.SetMode(mod);
+
+        pMd := Sy.val;
+        rcv := mth.GetParent()(Per.Type);
+        IF isValClass(rcv) THEN pMd := Sy.var END;
+
+        mId.rcvFrm := mkParam("this", pMd, cpTypeFromCTS(rcv, spc), TRUE);
+        pTp := Ty.newPrcTp();
+        pTp.idnt := mId;
+        mId.type := pTp;
+        pTp.receiver := rec;
+        spc.AddFormals(pTp, mth);
+
+        IF    abMth IN bts    THEN 
+          mId.mthAtt := Id.isAbs;
+        ELSIF (vrMth IN bts) & ~(fnMth IN bts) THEN 
+          mId.mthAtt := Id.extns;
+        END;
+        IF ~(vrMth IN bts) OR (nwMth IN bts) THEN 
+          INCL(mId.mthAtt, Id.newBit);
+        END;
+
+(* FIXME -- boxRcv flag needs to be set ... *)
+
+        res := rec.symTb.enter(hsh, mId);
+        Sy.AppendIdnt(rec.methods, mId);
+      END;
+    END;
+  END AddRecMth;
+
+ (* ------------------------------------------------------------ *)
+
+  PROCEDURE (spc : DefNamespace)AddRecEvt(rec : Ty.Record; 
+                                          evt : Per.Event), NEW;
+    VAR   eTp : Per.Type;
+          nam : RTS.NativeString;
+          hsh : INTEGER;
+          fId : Id.FldId;
+          res : BOOLEAN;
+  BEGIN
+    eTp := evt.GetEventType();
+    nam := evt.Name();
+    hsh := Nh.enterStr(nam);
+    fId := Id.newFldId();
+    fId.hash := hsh;
+    fId.SetMode(Sy.pubMode);
+    fId.recTyp := rec;
+    fId.type := cpTypeFromCTS(eTp, spc);
+    res := rec.symTb.enter(hsh, fId);
+    Sy.AppendIdnt(rec.fields, fId);
+  END AddRecEvt;
+
+ (* ------------------------------------------------------------ *)
+
+  PROCEDURE MakeRefCls(cls : Per.ClassDef; 
+                       spc : DefNamespace;
+                       att : Per.TypeAttr;
+                   OUT tId : Id.TypId);
+    VAR ptr  : Ty.Pointer;
+   (* ------------------------------------------------- *)
+    PROCEDURE mkRecord(cls : Per.ClassDef; 
+                       spc : DefNamespace;
+                       att : Per.TypeAttr) : Ty.Record;
+      VAR rec : Ty.Record;
+          spr : Per.Class;
+          knd : INTEGER;
+          bts : SET;
+          idx : INTEGER;
+          ifE : Per.Class;
+          ifA : POINTER TO ARRAY OF Per.Class;
+    BEGIN
+      bts := BITS(att);
+      rec := Ty.newRecTp();
+      spr := cls.get_SuperType();
+
+      ifA := cls.GetInterfaces();
+      IF ifA # NIL THEN
+        FOR idx := 0 TO LEN(ifA) - 1 DO
+          ifE := ifA[idx];
+          IF ~(ifE IS Per.ClassSpec) & isPublicClass(ifE) THEN
+            Sy.AppendType(rec.interfaces, cpTypeFromCTS(ifE, spc));
+          ELSIF Glb.verbose THEN 
+            SayWhy(ifE);
+          END;
+        END;
+      END;
+
+      IF spr = NIL THEN knd := objTyp ELSE knd := getKind(spr) END;
+      IF knd # objTyp THEN rec.baseTp := cpTypeFromCTS(spr, spc) END;
+     (*
+      *  The INTERFACE test must come first, since
+      *  these have the ABSTRACT bit set as well.
+      *)
+      IF    intTp IN bts THEN rec.recAtt := Ty.iFace;
+     (*
+      *  Now the ABSTRACT but not interface case.
+      *)
+      ELSIF absTp IN bts THEN rec.recAtt := Ty.isAbs;
+     (*
+      *  If class is sealed, then default for CP.
+      *)
+      ELSIF sldTp IN bts THEN rec.recAtt := Ty.noAtt;
+     (*
+      *  Else CP default is EXTENSIBLE.
+      *)
+      ELSE                    rec.recAtt := Ty.extns;
+      END;
+     (*
+      *  This is effectively the "no __copy__" flag.
+      *)
+      IF ~Glb.cpCmpld THEN INCL(rec.xAttr, Sy.isFn) END;
+      Glb.ListTy(rec);
+      RETURN rec;
+    END mkRecord;
+   (* ------------------------------------------------- *)
+  BEGIN
+   (*
+    *  Create the descriptors.
+    *)
+    ptr := Ty.newPtrTp();
+    tId := Id.newTypId(ptr);
+    ptr.idnt := tId;
+    ptr.boundTp := mkRecord(cls, spc, att);
+    ptr.boundTp(Ty.Record).bindTp := ptr;
+    tId.hash := Nh.enterStr(gpName(cls));
+    Glb.ListTy(ptr);
+  END MakeRefCls;
+
+ (* ------------------------------------------------------------ *)
+
+  PROCEDURE MakeEnumTp(cls : Per.ClassDef; 
+                   OUT tId : Id.TypId);
+    VAR enu : Ty.Enum;
+  BEGIN
+   (*
+    *  Create the descriptors.
+    *)
+    enu := Ty.newEnuTp();
+    tId := Id.newTypId(enu);
+    tId.hash := Nh.enterStr(gpName(cls));
+    enu.idnt := tId;
+    Glb.ListTy(enu);
+  END MakeEnumTp;
+
+ (* ------------------------------------------------ *)
+
+  PROCEDURE MakeValCls(cls : Per.ClassDef; 
+                   OUT tId : Id.TypId);
+    VAR rec  : Ty.Record;
+  BEGIN
+   (*
+    *  Create the descriptors.
+    *)
+    rec := Ty.newRecTp();
+    tId := Id.newTypId(rec);
+    rec.idnt := tId;
+    tId.hash := Nh.enterStr(gpName(cls));
+    IF ~Glb.cpCmpld THEN INCL(rec.xAttr, Sy.isFn) END;
+    Glb.ListTy(rec);
+  END MakeValCls;
+
+ (* ------------------------------------------------ *)
+
+  PROCEDURE MakePrcCls(cls : Per.ClassDef; 
+                   OUT tId : Id.TypId);
+    VAR prc  : Ty.Procedure;
+  BEGIN
+   (*
+    *  Create the descriptors.
+    *)
+(*                          (* We have no way of distinguishing between *)
+ *   prc := Ty.newPrcTp();  (* CP EVENT and CP PROCEDURE types from the *)
+ *)                         (* PE-file.  So, default to EVENT meantime. *)
+    prc := Ty.newEvtTp();
+    tId := Id.newTypId(prc);
+    prc.idnt := tId;
+    tId.hash := Nh.enterStr(gpName(cls));
+    Glb.ListTy(prc);
+  END MakePrcCls;
+
+ (* ------------------------------------------------------------ *)
+
+  PROCEDURE (spc : DefNamespace)DefineRec(cls : Per.ClassDef; 
+                                          rec : Ty.Record), NEW;
+    VAR indx : INTEGER;
+        flds : POINTER TO ARRAY OF Per.FieldDef;
+        evts : POINTER TO ARRAY OF Per.Event;
+        mths : POINTER TO ARRAY OF Per.MethodDef;
+  BEGIN
+   (*
+    *  Now fill in record fields ...
+    *)
+    flds := cls.GetFields();
+    FOR indx := 0 TO LEN(flds) - 1 DO
+      spc.AddRecFld(rec, flds[indx]);
+    END;
+   (*
+    *  Now fill in record events ...
+    *)
+    evts := cls.GetEvents();
+    FOR indx := 0 TO LEN(evts) - 1 DO
+      spc.AddRecEvt(rec, evts[indx]);
+    END;
+   (*
+    *  Now fill in record methods ...
+    *)
+    mths := cls.GetMethods();
+    FOR indx := 0 TO LEN(mths) - 1 DO
+      spc.AddRecMth(rec, mths[indx]);
+    END;
+  END DefineRec;
+
+ (* ------------------------------------------------------------ *)
+
+  PROCEDURE (spc : DefNamespace)DefineEnu(cls : Per.ClassDef; 
+                                          enu : Ty.Enum), NEW;
+    CONST litB = 6; (* 40H *)
+    VAR   indx : INTEGER;
+          valu : LONGINT;
+          flds : POINTER TO ARRAY OF Per.FieldDef;
+          thsF : Per.FieldDef;
+          thsC : Id.ConId;
+          mode : INTEGER;
+          bits : SET;
+          sCon : Per.SimpleConstant;
+  BEGIN
+   (*
+    *  Now fill in record details ...
+    *)
+    flds := cls.GetFields();
+    FOR indx := 0 TO LEN(flds) - 1 DO
+      thsF := flds[indx];
+      bits := BITS(thsF.GetFieldAttr());
+      mode := modeFromMbrAtt(bits);
+      IF (mode > Sy.prvMode) & (litB IN bits) THEN
+        sCon := thsF.GetValue()(Per.SimpleConstant);
+        WITH sCon : Per.IntConst DO valu := sCon.GetLong();
+           | sCon : Per.UIntConst DO valu := sCon.GetULongAsLong();
+        END;
+        thsC := Id.newConId();
+        thsC.SetMode(mode);
+        thsC.hash := Nh.enterStr(thsF.Name());
+        thsC.conExp := Xp.mkNumLt(valu);
+        thsC.type := Bi.intTp;
+        Sy.AppendIdnt(enu.statics, thsC);
+      END;
+    END;
+  END DefineEnu;
+
+ (* ------------------------------------------------------------ *)
+
+  PROCEDURE (spc : DefNamespace)DefinePrc(cls : Per.ClassDef; 
+                                          prc : Ty.Procedure), NEW;
+    VAR indx : INTEGER;
+        valu : INTEGER;
+        invk : Per.MethodDef;
+  BEGIN
+   (*
+    *  Now fill in parameter details ...
+    *)
+    invk := cls.GetMethod(MKSTR("Invoke"));
+    spc.AddFormals(prc, invk);
+    RETURN;
+  END DefinePrc;
+
+ (* ------------------------------------------------------------ *)
+
+  PROCEDURE MakeTypIds*(thsN : DefNamespace);
+    VAR indx : INTEGER;
+        thsC : Per.ClassDef;
+        attr : Per.TypeAttr;
+        tEnu : INTEGER;
+        tpId : Id.TypId;
+        clsh : Sy.Idnt;
+  BEGIN
+   (*
+    *  For every namespace, define gpcp descriptors 
+    *  for each class, method, field and constant.
+    *)
+    Glb.CondMsg(" CP Module name - " + Nh.charOpenOfHash(thsN.bloc.hash)^);
+    Glb.CondMsg(' Alternative import name - "' + thsN.bloc.scopeNm^ + '"');
+    FOR indx := 0 TO LEN(thsN.clss) - 1 DO
+      thsC := thsN.clss[indx];
+      attr := thsC.GetAttributes();
+      tEnu := getKind(thsC);
+
+      IF Glb.Verbose THEN
+        Console.WriteString("        ");
+        Console.WriteString(kindStr(tEnu)); Console.Write(ASCII.HT);
+        Console.WriteString(gpName(thsC));
+        Console.WriteLn;
+      END;
+      
+      CASE tEnu OF
+      | refCls  : MakeRefCls(thsC, thsN, attr, tpId);
+      | valCls  : MakeValCls(thsC, tpId);
+      | enuCls  : MakeEnumTp(thsC, tpId);
+(*
+ *    | evtCls  : MakeEvtCls(thsC, tpId);
+ *)
+      | dlgCls  : MakePrcCls(thsC, tpId);
+      ELSE tpId := NIL;
+      END;
+(* ---- temporary ---- *)
+IF tpId # NIL THEN
+(* ---- temporary ---- *)
+      IF isProtectedType(attr) THEN
+        tpId.SetMode(Sy.protect);
+      ELSE
+        tpId.SetMode(Sy.pubMode);
+      END;
+      tpId.dfScp := thsN.bloc;
+      IF ~thsN.bloc.symTb.enter(tpId.hash, tpId) THEN
+       (*
+        *  Just a sanity check!
+        *)
+        clsh := thsN.bloc.symTb.lookup(tpId.hash);
+        ASSERT((clsh IS Id.TypId) & (clsh.type IS Ty.Opaque));
+
+        thsN.bloc.symTb.Overwrite(tpId.hash, tpId);
+      END;
+(* ---- temporary ---- *)
+END;
+(* ---- temporary ---- *)
+      APPEND(thsN.tIds, tpId);
+    END;
+  END MakeTypIds;
+
+ (* ------------------------------------------------ *)
+ (* ------------------------------------------------ * 
+
+  PROCEDURE MakeRefIds(thsN : RefNamespace);
+    VAR indx : INTEGER;
+        thsC : Per.ClassRef;
+        tEnu : INTEGER;
+        tpId : Id.TypId;
+  BEGIN
+   (*
+    *  For every namespace, define gpcp TypId descriptors for each class
+    *)
+    IF Glb.verbose THEN
+      Glb.Message(" GPCP-Module name - " + Nh.charOpenOfHash(thsN.bloc.hash)^);
+    END;
+    FOR indx := 0 TO LEN(thsN.clss) - 1 DO
+      thsC := thsN.clss[indx];
+      IF Glb.Verbose THEN
+        Console.WriteString("        class rfrnce ");
+        Console.WriteString(gpName(thsC));
+        Console.WriteLn;
+      END;
+      tpId := makeNameType(thsN.bloc, Nh.enterStr(gpName(thsC)));
+      APPEND(thsN.tIds, tpId);
+    END;
+  END MakeRefIds;
+
+  * ------------------------------------------------ *)
+ (* ------------------------------------------------ *)
+
+  PROCEDURE MakeBlkId*(spc : Namespace; aNm : Glb.CharOpen);
+  BEGIN
+    NEW(spc.bloc);
+    INCL(spc.bloc.xAttr, Sy.need);
+    Glb.BlkIdInit(spc.bloc, aNm, Nh.charOpenOfHash(spc.hash));
+    IF Glb.superVb THEN Glb.Message("Creating blk - " +
+                                     Nh.charOpenOfHash(spc.bloc.hash)^) END;
+  END MakeBlkId;
+
+ (* ------------------------------------------------ *)
+
+  PROCEDURE DefineClss*(thsN : DefNamespace);
+    VAR indx : INTEGER;
+        tEnu : INTEGER;
+        thsT : Sy.Type;
+        thsI : Id.TypId;
+        thsC : Per.ClassDef;
+  BEGIN
+   (*
+    *  For every namespace, define gpcp descriptors 
+    *  for each class, method, field and constant.
+    *)
+    FOR indx := 0 TO LEN(thsN.clss) - 1 DO
+      thsC := thsN.clss[indx];
+      thsI := thsN.tIds[indx];
+      tEnu := getKind(thsC);
+
+      CASE tEnu OF
+      | valCls  : thsN.DefineRec(thsC, thsI.type(Ty.Record));
+      | enuCls  : thsN.DefineEnu(thsC, thsI.type(Ty.Enum));
+      | dlgCls  : thsN.DefinePrc(thsC, thsI.type(Ty.Procedure));
+      | refCls  : thsT := thsI.type(Ty.Pointer).boundTp;
+                  thsN.DefineRec(thsC, thsT(Ty.Record));
+(*
+ *    | evtCls  : thsN.MakeEvtCls(thsC, ); (* Can't distinguish from dlgCls! *)
+ *)
+      ELSE (* skip *)
+      END;
+    END;
+  END DefineClss;
+
+ (* ------------------------------------------------------------ *)
+ (*    Separate flat class-list into lists for each namespace    *)
+ (* ------------------------------------------------------------ *)
+
+  PROCEDURE Classify*(IN  clss : ARRAY OF Per.ClassDef;
+                      OUT nVec : VECTOR OF DefNamespace);
+    VAR indx : INTEGER;
+        thsC : Per.ClassDef;
+        attr : Per.TypeAttr;
+   (* ======================================= *)
+    PROCEDURE Insert(nVec : VECTOR OF DefNamespace; 
+                     thsC : Per.ClassDef);
+      VAR thsH : INTEGER;
+          jndx : INTEGER;
+          nSpc : RTS.NativeString;
+          cNam : RTS.NativeString;
+          newN : DefNamespace;
+    BEGIN
+      nSpc := gpSpce(thsC);
+      cNam := gpName(thsC);
+      IF nSpc = "" THEN thsH := anon ELSE thsH := Nh.enterStr(nSpc) END;
+     (*
+      *  See if already a Namespace for this hash bucket
+      *)
+      FOR jndx := 0 TO LEN(nVec) - 1 DO
+        IF nVec[jndx].hash = thsH THEN
+          APPEND(nVec[jndx].clss, thsC); RETURN;    (* FORCED EXIT! *)
+        END;
+      END;
+     (*
+      *  Else insert in a new Namespace
+      *)
+      NEW(newN);                  (* Create new DefNamespace object    *)
+      NEW(newN.clss, 8);          (* Create new vector of ClassDef     *)
+      NEW(newN.tIds, 8);          (* Create new vector of Id.TypId     *)
+      newN.hash := thsH;
+      APPEND(newN.clss, thsC);    (* Append class to new class vector  *)
+      APPEND(nVec, newN);         (* Append new DefNamespace to result *)
+    END Insert;
+   (* ======================================= *)
+  BEGIN
+    NEW(nVec, 8);
+    FOR indx := 0 TO LEN(clss) - 1 DO
+      thsC := clss[indx];
+      IF isPublicClass(thsC) THEN 
+        Insert(nVec, thsC);
+      ELSIF Glb.verbose THEN
+        SayWhy(thsC);
+      END;
+(* ------------------------------------- *
+ *    attr := thsC.GetAttributes();
+ *    IF isExportedType(attr) THEN 
+ *      IF ~isGenericClass(thsC) THEN (* SPECIAL FOR PRE 1.4 VERSION *)
+ *        Insert(nVec, thsC);
+ *      ELSIF Glb.verbose THEN
+ *        Glb.Message(" Hiding generic class -- " + 
+ *                         gpSpce(thsC) + "." + gpName(thsC));
+ *      END;
+ *    END;
+ * ------------------------------------- *)
+    END;
+    IF Glb.verbose THEN
+      IF LEN(nVec) = 1 THEN
+        Glb.Message(" Found one def namespace");
+      ELSE
+        Glb.Message(" Found "+Ltv.intToCharOpen(LEN(nVec))^+" def namespaces");
+      END;
+    END;
+  END Classify;
+
+(* ------------------------------------------------------------- *)
+(* ------------------------------------------------------------- *)
+
+  PROCEDURE InitCorLibTypes*();
+  BEGIN
+   (*
+    *  Create import descriptor for [mscorlib]System
+    *)
+    Bi.MkDummyImport("mscorlib_System", "[mscorlib]System", corLib);
+   (*
+    *  Create various classes.
+    *)
+    ntvObj := makeNameType(corLib, Nh.enterStr("Object")).type;
+    ntvStr := makeNameType(corLib, Nh.enterStr("String")).type;
+    ntvExc := makeNameType(corLib, Nh.enterStr("Exception")).type;
+    ntvTyp := makeNameType(corLib, Nh.enterStr("Type")).type;
+    ntvEvt := makeNameType(corLib, Nh.enterStr("MulticastDelegate")).type;
+    ntvVal := makeNameType(corLib, Nh.enterStr("ValueType")).type;
+    ntvEnu := makeNameType(corLib, Nh.enterStr("Enum")).type;
+   (*
+    *  Do the unsigned types with no CP equivalent.
+    *)
+    sysU16 := makeNameType(corLib, Nh.enterStr("UInt16")).type;
+    sysU32 := makeNameType(corLib, Nh.enterStr("UInt32")).type;
+    sysU64 := makeNameType(corLib, Nh.enterStr("UInt64")).type;
+    voidSt := makeNameType(corLib, Nh.enterStr("VoidStar")).type;
+    intPtr := makeNameType(corLib, Nh.enterStr("IntPtr")).type;
+    uIntPt := makeNameType(corLib, Nh.enterStr("UIntPtr")).type;
+    tpdRef := makeNameType(corLib, Nh.enterStr("TypedReference")).type;
+  END InitCorLibTypes;
+
+(* ------------------------------------------------------------- *)
+(*
+  PROCEDURE ImportCorlib*();
+  BEGIN
+    Glb.InsertImport(corLib);
+    INCL(corLib.xAttr, Sy.need);
+  END ImportCorlib;
+ *)
+(* ------------------------------------------------------------- *)
+
+  PROCEDURE ImportCorlib*(spc : DefNamespace);
+  BEGIN
+    IF (spc # NIL) & (spc.bloc # corLib) THEN
+      IF ~Sy.refused(corLib, spc.bloc) THEN
+        IF Glb.superVb THEN
+          Console.WriteString("Inserting import <");
+          Console.WriteString(Nh.charOpenOfHash(corLib.hash));
+          Console.WriteString("> in Namespace ");
+          Console.WriteString(Nh.charOpenOfHash(spc.bloc.hash));
+          Console.WriteLn;
+        END;
+      END; 
+    END;
+    INCL(corLib.xAttr, Sy.need);
+  END ImportCorlib;
+
+(* ------------------------------------------------------------- *)
+
+  PROCEDURE BindSystemTypes*();
+    VAR blk : Id.BlkId;       (* The Blk descriptor *)
+        tId : Sy.Idnt;
+   (* -------------------------- *)
+    PROCEDURE MakeAbstract(blk : Id.BlkId; hsh : INTEGER);
+    BEGIN
+      blk.symTb.lookup(hsh).type(Ty.Record).recAtt := Ty.isAbs;
+    END MakeAbstract;
+   (* -------------------------- *)
+  BEGIN
+   (*
+    *  Load import descriptor for [mscorlib]System
+    *)
+    corLib := Glb.thisMod.symTb.lookup(
+                        Nh.enterStr("mscorlib_System"))(Id.BlkId);
+    blk := corLib;
+
+   (* 
+    *  THIS IS ONLY EXPERIMENTAL 
+    *  We make the record types that correspond to the
+    *  primitive types abstract to prevent the declaration
+    *  of variables of these types.
+    *
+    *  The static methods can still be called, of course.
+    *)
+    MakeAbstract(blk, Nh.enterStr("Boolean"));
+    MakeAbstract(blk, Nh.enterStr("Byte"));
+    MakeAbstract(blk, Nh.enterStr("Char"));
+    MakeAbstract(blk, Nh.enterStr("SByte"));
+    MakeAbstract(blk, Nh.enterStr("Int16"));
+    MakeAbstract(blk, Nh.enterStr("Int32"));
+    MakeAbstract(blk, Nh.enterStr("Int64"));
+    MakeAbstract(blk, Nh.enterStr("UInt16"));
+    MakeAbstract(blk, Nh.enterStr("UInt32"));
+    MakeAbstract(blk, Nh.enterStr("UInt64"));
+   (*
+    *  Create various classes.
+    *)
+    tId := blk.symTb.lookup(Nh.enterStr("Object"));
+    ntvObj := tId.type;
+
+    tId := blk.symTb.lookup(Nh.enterStr("String"));
+    ntvStr := tId.type;
+
+    tId := blk.symTb.lookup(Nh.enterStr("Exception"));
+    ntvExc := tId.type;
+
+    tId := blk.symTb.lookup(Nh.enterStr("Type"));
+    ntvTyp := tId.type;
+
+    tId := blk.symTb.lookup(Nh.enterStr("MulticastDelegate"));
+    ntvEvt := tId.type;
+
+    tId := blk.symTb.lookup(Nh.enterStr("ValueType"));
+    ntvVal := tId.type;
+
+    tId := blk.symTb.lookup(Nh.enterStr("Enum"));
+    ntvEnu := tId.type;
+   (*
+    *  Do the unsigned types with no CP equivalent.
+    *)
+    tId := blk.symTb.lookup(Nh.enterStr("UInt16"));
+    sysU16 := tId.type;
+
+    tId := blk.symTb.lookup(Nh.enterStr("UInt32"));
+    sysU32 := tId.type;
+
+    tId := blk.symTb.lookup(Nh.enterStr("UInt64"));
+    sysU64 := tId.type;
+   (*
+    *  Do the miscellaneous values
+    *)
+    tId := blk.symTb.lookup(Nh.enterStr("IntPtr"));
+    voidSt := tId.type;
+    intPtr := tId.type;
+
+    tId := blk.symTb.lookup(Nh.enterStr("UIntPtr"));
+    uIntPt := tId.type;
+
+    tId := blk.symTb.lookup(Nh.enterStr("TypedReference"));
+    tpdRef := tId.type;
+
+  END BindSystemTypes;
+
+(* ------------------------------------------------------------- *)
+BEGIN
+  Bi.InitBuiltins;
+END ClsToType.
+(* ------------------------------------------------------------- *)

gpcp/CompState.cp

@@ -0,0 +1,646 @@
+(* ==================================================================== *)
+(*									*)
+(*  State Module for the Gardens Point Component Pascal Compiler.	*)
+(*	Copyright (c) John Gough 1999, 2000.				*)
+(*									*)
+(*  Note that since this module is likely to be imported by most other  *)
+(*  modules, it is important to ensure that it does not import others,  *)
+(*  to avoid import cycles. 						*)
+(*									*)
+(* ==================================================================== *)
+
+MODULE CompState;
+
+  IMPORT 
+        GPCPcopyright,
+        RTS,
+        Error,
+        GPText,
+        Symbols,
+        IdDesc,
+        Console, 
+        CPascalS,
+        NameHash,
+        FileNames,
+        CPascalErrors;
+
+  CONST	prefix     = "#gpcp: ";
+        millis     = "mSec";
+
+  CONST netV1_0* = 0;
+        netV1_1* = 1;
+        netV2_0* = 2;
+
+(* ==================================================================== *)
+(*		     State Variables of this compilation		*)
+(* ==================================================================== *)
+
+  VAR
+    ntvObj* : Symbols.Type;     (* native Object type          	*)
+    ntvStr* : Symbols.Type;     (* native String type          	*)
+    ntvExc* : Symbols.Type;     (* native Exceptions type       *)
+    ntvTyp* : Symbols.Type;     (* native System.Type type      *)
+    ntvEvt* : Symbols.Type;     (* native MulticastDelegate     *)
+    rtsXHR* : Symbols.Type;     (* native XHR type descriptor   *)
+    ntvVal* : Symbols.Type;     (* native ValueType type        *)
+
+    objId*  : Symbols.Idnt;
+    strId*  : Symbols.Idnt;
+    excId*  : Symbols.Idnt;
+    clsId*  : Symbols.Idnt;
+    xhrId*  : IdDesc.FldId;     (* descriptor of RTS.XHR.prev   *)
+    rtsBlk* : IdDesc.BlkId;
+    prgArg* : IdDesc.BlkId;
+    argLst* : IdDesc.VarId;     (* descriptor of RTS.argList    *)
+
+    srcBkt* : INTEGER;          (* hashtable bucket of "src"    *)
+    corBkt* : INTEGER;          (* bucket of "mscorlib_System"  *)
+
+    fltInf*  : IdDesc.VarId;    (* descriptor of RTS.fltPosInf. *)
+    dblInf*  : IdDesc.VarId;    (* descriptor of RTS.dblPosInf. *)
+    fltNInf* : IdDesc.VarId;    (* descriptor of RTS.fltNegInf. *)
+    dblNInf* : IdDesc.VarId;    (* descriptor of RTS.dblNegInf. *)
+
+  VAR
+    modNam*   : FileNames.NameString;    (* name of the _MODULE_        *)
+    basNam-,                             (* base name of source _FILE_  *)
+    srcNam-,                             (* name of the source file     *)
+    lstNam-   : FileNames.NameString;    (* name of the listing file    *)
+
+    target-   : ARRAY 4 OF CHAR;
+
+    cpSymX-,                             (* User supplied CPSYM name    *)
+    binDir-,                             (* PE-file directory .NET only *)
+    symDir-   : FileNames.NameString;    (* Symbol file directory       *)
+
+    strict-,
+    special-,
+    warning-,
+    verbose-,
+    extras-,
+    unsafe-,
+    doStats-,
+    doHelp-,
+    ovfCheck-,
+    debug-,
+    doneHelp,
+    doVersion-,
+    doneVersion,
+    doSym-,
+    doAsm-,
+    doJsmn-,
+    forceIlasm,
+    forcePerwapi,
+    doIlasm-,
+    doCode-,
+    quiet-,
+    system-    : BOOLEAN;
+    legacy*    : BOOLEAN;
+    netRel-,
+    listLevel-,
+    hashSize-  : INTEGER;
+
+    thisMod-   : IdDesc.BlkId;           (* Desc. of compiling module.  *)
+    sysMod-    : IdDesc.BlkId;           (* Desc. of compiling module.  *)
+
+    impSeq*    : Symbols.ScpSeq;
+
+    totalS*    : LONGINT;
+    parseS*    : LONGINT;
+    parseE*    : LONGINT;
+    attrib*    : LONGINT;
+    symEnd*    : LONGINT;
+    asmEnd*    : LONGINT;
+    totalE*    : LONGINT;
+    import1*   : LONGINT;
+    import2*   : LONGINT;
+
+    impMax*    : INTEGER;
+    
+  VAR outNam*  : POINTER TO ARRAY OF CHAR;
+
+  VAR
+    expectedNet : BOOLEAN;         (* A .NET specific option was parsed *)
+    expectedJvm : BOOLEAN;         (* A JVM specific option was parsed  *)
+
+(* ==================================================================== *)
+(*				Utilities				*)
+(* ==================================================================== *)
+
+    PROCEDURE targetIsNET*() : BOOLEAN;
+    BEGIN
+      RETURN target = "net";
+    END targetIsNET;
+
+    PROCEDURE targetIsJVM*() : BOOLEAN;
+    BEGIN
+      RETURN target = "jvm";
+    END targetIsJVM;
+
+    PROCEDURE Message*(IN mss : ARRAY OF CHAR);
+    BEGIN
+      Console.WriteString(prefix);
+      Console.WriteString(mss);
+      Console.WriteLn;
+    END Message;
+
+    PROCEDURE PrintLn*(IN mss : ARRAY OF CHAR);
+    BEGIN
+      Console.WriteString(mss);
+      Console.WriteLn;
+    END PrintLn;
+
+    PROCEDURE ErrMesg*(IN mss : ARRAY OF CHAR);
+    BEGIN
+      Console.WriteString(prefix);
+      Error.WriteString(mss);
+      Error.WriteLn;
+    END ErrMesg;
+
+    PROCEDURE Abort*(IN mss : ARRAY OF CHAR);
+    BEGIN
+      ErrMesg(mss); ASSERT(FALSE);
+    END Abort;
+
+    PROCEDURE isForeign*() : BOOLEAN;
+    BEGIN
+      RETURN 
+        (Symbols.rtsMd IN thisMod.xAttr) OR
+        (Symbols.frnMd IN thisMod.xAttr);
+    END isForeign;
+
+    PROCEDURE TimeMsg*(IN mss : ARRAY OF CHAR; tim : LONGINT);
+    BEGIN
+      IF (tim < 0) OR (tim >= totalS) THEN tim := 0 END;
+      Console.WriteString(prefix);
+      Console.WriteString(mss);
+      Console.WriteInt(SHORT(tim), 5);
+      Console.WriteString(millis);
+      Console.WriteLn;
+    END TimeMsg;
+
+(* ==================================================================== *)
+
+    PROCEDURE Usage;
+    BEGIN
+      PrintLn("gardens point component pascal: " + GPCPcopyright.verStr);
+      Message("Usage from the command line ...");
+      IF RTS.defaultTarget = "net" THEN
+PrintLn("       $ gpcp [cp-options] file {file}");
+PrintLn("# CP Options ...");
+PrintLn("       /bindir=XXX  ==> Place binary files in directory XXX");
+PrintLn("       /copyright   ==> Display copyright notice");
+PrintLn("       /cpsym=XXX   ==> Use environ. variable XXX instead of CPSYM");
+PrintLn("       /debug       ==> Generate debugging information (default)");
+PrintLn("       /nodebug     ==> Give up debugging for maximum speed");
+PrintLn("       /dostats     ==> Give a statistical summary");
+PrintLn("       /extras      ==> Enable experimental compiler features");
+PrintLn("       /help        ==> Write out this usage message");
+PrintLn("       /hsize=NNN   ==> Set hashtable size >= NNN (0 .. 65000)");
+PrintLn("       /ilasm       ==> Force compilation via ILASM");
+PrintLn("       /list        ==> (default) Create *.lst file if errors");
+PrintLn("       /list+       ==> Unconditionally create *.lst file");
+PrintLn("       /list-       ==> Don't create error *.lst file");
+PrintLn("       /noasm       ==> Don't create asm (or object) files");
+PrintLn("       /nocode      ==> Don't create any object files");
+PrintLn("       /nocheck     ==> Don't perform arithmetic overflow checks");
+PrintLn("       /nosym       ==> Don't create *.sym (or asm or object) files");
+PrintLn("       /perwapi     ==> Force compilation via PERWAPI");
+PrintLn("       /quiet       ==> Compile silently if possible");
+PrintLn("       /strict      ==> Disallow non-standard constructs");
+PrintLn("       /special     ==> Compile dummy symbol file");
+PrintLn("       /symdir=XXX  ==> Place symbol files in directory XXX");
+PrintLn("       /target=XXX  ==> Emit (jvm|net|dcf) assembly");
+PrintLn("       /unsafe      ==> Allow unsafe code generation");
+PrintLn("       /vX.X        ==> (v1.0 | v1.1 | v2.0) CLR target version");
+PrintLn("       /verbose     ==> Emit verbose diagnostics");
+PrintLn("       /version     ==> Write out version number");
+PrintLn("       /vserror     ==> Print error messages in Visual Studio format");
+PrintLn("       /warn-       ==> Don't emit warnings");
+PrintLn("       /nowarn      ==> Don't emit warnings");
+PrintLn("       /whidbey     ==> Target code for Whidbey Beta release");
+PrintLn("       /xmlerror    ==> Print error messages in XML format");
+PrintLn(' Unix-style options: "-option" are recognized also');
+      ELSE
+        IF RTS.defaultTarget = "jvm" THEN
+PrintLn("       $ cprun gpcp [cp-options] file {file}, OR");
+PrintLn("       $ java [java-options] CP.gpcp.gpcp [cp-options] file {file}");
+        ELSIF RTS.defaultTarget = "dcf" THEN
+          PrintLn("       $ gpcp [cp-options] file {file}");
+	END;
+PrintLn("# CP Options ...");
+PrintLn("       -clsdir=XXX  ==> Set class tree root in directory XXX");
+PrintLn("       -copyright   ==> Display copyright notice");
+PrintLn("       -cpsym=XXX   ==> Use environ. variable XXX instead of CPSYM");
+PrintLn("       -dostats     ==> Give a statistical summary");
+PrintLn("       -extras      ==> Enable experimental compiler features");
+PrintLn("       -help        ==> Write out this usage message");
+PrintLn("       -hsize=NNN   ==> Set hashtable size >= NNN (0 .. 65000)");
+PrintLn("       -jasmin      ==> Ceate asm files and run Jasmin");
+PrintLn("       -list        ==> (default) Create *.lst file if errors");
+PrintLn("       -list+       ==> Unconditionally create *.lst file");
+PrintLn("       -list-       ==> Don't create error *.lst file");
+PrintLn("       -nocode      ==> Don't create any object files");
+PrintLn("       -noasm       ==> Don't create asm (or object) files");
+PrintLn("       -nosym       ==> Don't create *.sym (or asm or object) files");
+PrintLn("       -quiet       ==> Compile silently if possible");
+PrintLn("       -special     ==> Compile dummy symbol file");
+PrintLn("       -strict      ==> Disallow non-standard constructs");
+PrintLn("       -symdir=XXX  ==> Place symbol files in directory XXX");
+PrintLn("       -target=XXX  ==> Emit (jvm|net|dcf) assembly");
+PrintLn("       -verbose     ==> Emit verbose diagnostics");
+PrintLn("       -version     ==> Write out version number");
+PrintLn("       -warn-       ==> Don't emit warnings");
+PrintLn("       -nowarn      ==> Don't emit warnings");
+PrintLn("       -xmlerror    ==> Print error messages in XML format");
+        IF RTS.defaultTarget = "jvm" THEN
+PrintLn("# Java Options ...");
+PrintLn("       -D<name>=<value>  pass <value> to JRE as system property <name>");
+PrintLn("       -DCPSYM=$CPSYM    pass value of CPSYM environment variable to JRE");
+        END;
+      END;
+      Message("This program comes with NO WARRANTY");
+      Message("Read source/GPCPcopyright for license details");
+    END Usage;
+
+(* ==================================================================== *)
+(*			     Option Setting				*)
+(* ==================================================================== *)
+
+    PROCEDURE ParseOption*(IN opt : ARRAY OF CHAR);
+      VAR copy : ARRAY 16 OF CHAR;
+          indx : INTEGER;
+     (* ----------------------------------------- *)
+      PROCEDURE Unknown(IN str : ARRAY OF CHAR);
+      BEGIN
+        Message('Unknown option "' + str + '"');
+        doHelp := TRUE;
+      END Unknown;
+     (* ----------------------------------------- *)
+      PROCEDURE BadSize();
+      BEGIN Message('hsize must be integer in range 0 .. 65000') END BadSize;
+     (* ----------------------------------------- *)
+      PROCEDURE ParseSize(IN opt : ARRAY OF CHAR);
+        VAR ix : INTEGER;
+            nm : INTEGER;
+            ch : CHAR;
+      BEGIN
+        nm := 0;
+        ix := 7;
+        WHILE opt[ix] # 0X DO
+          ch := opt[ix];
+          IF (ch >= '0') & (ch <= '9') THEN
+            nm := nm * 10 + ORD(ch) - ORD('0');
+            IF nm > 65521 THEN BadSize; hashSize := nm; RETURN END;
+          ELSE
+            BadSize; doHelp := TRUE; hashSize := nm; RETURN;
+          END;
+          INC(ix);
+        END;
+        hashSize := nm;
+      END ParseSize;
+     (* ----------------------------------------- *)
+      PROCEDURE GetSuffix(preLen : INTEGER;
+                         IN  opt : ARRAY OF CHAR;
+                         OUT dir : ARRAY OF CHAR);
+        VAR idx : INTEGER;
+            chr : CHAR;
+      BEGIN
+        idx := preLen;
+        chr := opt[idx];
+        WHILE (chr # 0X) & (idx < LEN(opt)) DO
+          dir[idx - preLen] := chr;
+          INC(idx); chr := opt[idx];
+        END;
+      END GetSuffix;
+     (* ----------------------------------------- *)
+      PROCEDURE StartsWith(str : ARRAY OF CHAR; IN pat : ARRAY OF CHAR) : BOOLEAN;
+      BEGIN
+        str[LEN(pat$)] := 0X;
+        RETURN str = pat;
+      END StartsWith;
+     (* ----------------------------------------- *)
+    BEGIN
+      indx := 1;
+      WHILE (indx < 16) & (indx < LEN(opt)) DO
+        copy[indx-1] := opt[indx]; INC(indx);
+      END;
+      copy[15] := 0X;
+
+      CASE copy[0] OF
+      | "b" : 
+          IF StartsWith(copy, "bindir=") THEN
+            GetSuffix(LEN("/bindir="), opt, binDir);
+            expectedNet := TRUE;
+            IF ~quiet THEN 
+              Message("bin directory set to <" + binDir +">");
+            END;
+          ELSE 
+            Unknown(opt);
+          END;
+      | "c" : 
+          IF copy = "copyright" THEN 
+            GPCPcopyright.Write;
+          ELSIF StartsWith(copy, "clsdir=") THEN
+            GetSuffix(LEN("/clsdir="), opt, binDir);
+            expectedJvm := TRUE;
+            IF ~quiet THEN 
+              Message("output class tree rooted at <" + binDir +">");
+            END;
+          ELSIF StartsWith(copy, "cpsym=") THEN
+            GetSuffix(LEN("/cpsym="), opt, cpSymX);
+            IF ~quiet THEN 
+              Message("using %" + cpSymX +"% as symbol file path");
+            END;
+          ELSE
+            Unknown(opt);
+          END;
+      | "d" : 
+          IF copy = "dostats" THEN 
+            doStats := TRUE;
+          ELSIF copy = "debug" THEN
+            debug := TRUE;
+            expectedNet := TRUE;
+          ELSE 
+            Unknown(opt);
+          END;
+      | "e" : IF copy = "extras" THEN extras := TRUE ELSE Unknown(opt) END;
+      | "h" : 
+          copy[6] := 0X;
+          IF copy = "help" THEN
+            doHelp := TRUE;
+          ELSIF copy = "hsize=" THEN
+            ParseSize(opt);
+          ELSE
+            Unknown(opt);
+          END;
+      | "i" : 
+          IF copy = "ilasm" THEN 
+            forceIlasm := TRUE;
+            expectedNet := TRUE;
+          ELSE 
+            Unknown(opt);
+          END;
+      | "j" :
+          IF copy = "jasmin" THEN
+            doCode     := TRUE;
+            doJsmn     := TRUE;
+            expectedJvm := TRUE;
+          ELSE 
+            Unknown(opt);
+          END;
+      | "l" :
+          IF copy = "list-" THEN
+            listLevel  := CPascalS.listNever;
+          ELSIF copy = "list+" THEN
+            listLevel  := CPascalS.listAlways;
+          ELSIF copy = "list" THEN
+            listLevel  := CPascalS.listErrOnly;
+          ELSIF copy = "legacy" THEN
+            legacy := TRUE;
+          ELSE 
+            Unknown(opt);
+          END;
+      | "n" :
+          IF copy = "nosym" THEN
+            doSym      := FALSE;
+            doAsm      := FALSE;
+            doCode     := FALSE;
+          ELSIF copy = "noasm" THEN
+            doAsm      := FALSE;
+            doCode     := FALSE;
+          ELSIF copy = "nocode" THEN
+            doCode     := FALSE;
+          ELSIF copy = "nowarn" THEN
+            warning    := FALSE;
+            CPascalErrors.nowarn := TRUE;
+          ELSIF copy = "nocheck" THEN
+            ovfCheck   := FALSE;
+            expectedNet := TRUE;
+          ELSIF copy = "nodebug" THEN
+            debug    := FALSE;
+            expectedNet := TRUE;
+          ELSE 
+            Unknown(opt);
+          END;
+          | "p" :
+          IF copy = "perwapi" THEN
+            forcePerwapi := TRUE;
+            expectedNet := TRUE;
+          ELSE
+            Unknown(opt);
+          END;
+      | "q" :
+          IF copy = "quiet" THEN
+            quiet := TRUE;
+            warning := FALSE;
+          ELSE
+            Unknown(opt);
+          END;
+      | "s" :
+          IF copy = "special" THEN
+            doAsm      := FALSE;
+            special    := TRUE;
+            strict     := FALSE;
+          ELSIF copy = "strict" THEN
+            strict     := TRUE;
+          ELSIF StartsWith(copy, "symdir=") THEN
+            GetSuffix(LEN("/symdir="), opt, symDir);
+            IF ~quiet THEN 
+              Message("sym directory set to <" + symDir +">");
+            END;
+          ELSE
+            Unknown(opt);
+          END;
+      | "t" :
+          IF (copy = "target=jvm") OR
+             (copy = "target=JVM") THEN
+            IF RTS.defaultTarget = "jvm" THEN
+              Message("JVM is default target for this build");
+            END;
+            target := "jvm";
+          ELSIF (copy = "target=vos") OR
+                (copy = "target=net") OR
+                (copy = "target=NET") THEN
+            IF RTS.defaultTarget = "net" THEN
+              Message("NET is default target for this build");
+            END;
+            target := "net";
+          ELSIF copy = "target=dcf" THEN
+            Message('DCode emitter not yet available, using "target=' +
+                                                    RTS.defaultTarget + '"');
+          ELSE 
+            Unknown(opt);
+          END;
+      | "u" :
+          IF copy = "unsafe" THEN
+            unsafe := TRUE;
+            expectedNet := TRUE;
+          ELSE 
+            Unknown(opt);
+          END;
+      | "v" :
+          IF copy = "version" THEN
+            doVersion  := TRUE;
+          ELSIF copy = "verbose" THEN
+            quiet      := FALSE;
+            warning    := TRUE;
+            verbose    := TRUE;
+            doStats    := TRUE;
+            CPascalErrors.prompt := TRUE;
+          ELSIF copy = "vserror" THEN
+            CPascalErrors.forVisualStudio := TRUE;
+            expectedNet := TRUE;
+          ELSIF copy = "v1.0" THEN
+            netRel := netV1_0;
+            expectedNet := TRUE;
+          ELSIF copy = "v1.1" THEN
+            netRel := netV1_1;
+            expectedNet := TRUE;
+          ELSIF copy = "v2.0" THEN
+            netRel := netV2_0;
+            expectedNet := TRUE;
+          ELSE 
+            Unknown(opt);
+          END;
+      | "w" :
+          IF copy = "warn-" THEN
+            warning    := FALSE;
+            CPascalErrors.nowarn := TRUE;
+          ELSIF copy = "whidbey" THEN
+            netRel := netV2_0;
+            expectedNet := TRUE;
+          ELSE 
+            Unknown(opt);
+          END;
+      | "x" :
+          IF copy = "xmlerror" THEN
+            CPascalErrors.xmlErrors := TRUE;
+          ELSE 
+            Unknown(opt);
+          END;
+      ELSE
+        Unknown(opt);
+      END;
+      IF doVersion & ~doneVersion THEN 
+        Message(target + GPCPcopyright.verStr); 
+        doneVersion := TRUE;
+      END;
+      IF doHelp & ~doneHelp THEN Usage; doneHelp := TRUE END;
+    END ParseOption;
+
+(* ==================================================================== *)
+
+    PROCEDURE CheckOptionsOK*;
+    BEGIN
+      IF target = "net" THEN
+        IF expectedJvm THEN Message
+          ("WARNING - a JVM-specific option was specified for .NET target");
+          expectedJvm := FALSE;
+        END;
+      ELSIF target = "jvm" THEN
+        IF expectedNet THEN Message
+          ("WARNING - a .NET-specific option was specified for JVM target");
+          expectedNet := FALSE;
+        END;
+      END;
+     (* 
+      *  If debug is set, for this version, ILASM is used unless /perwapi is explicit
+      *  If debug is clar, for this versin, PERWAPI is used unless /ilasm is explicit
+      *)
+      IF forceIlasm THEN      doIlasm := TRUE;
+      ELSIF forcePerwapi THEN doIlasm := FALSE;
+      ELSE                    doIlasm := debug;
+      END;
+    END CheckOptionsOK;
+
+(* ==================================================================== *)
+
+    PROCEDURE CreateThisMod*();
+    BEGIN
+      NEW(thisMod); 
+      thisMod.SetKind(IdDesc.modId);
+      thisMod.ovfChk := ovfCheck;
+    END CreateThisMod;
+
+    PROCEDURE InitCompState*(IN nam : ARRAY OF CHAR);
+    BEGIN
+      IF verbose THEN Message("opened local file <" + nam + ">") END;
+      GPText.Assign(nam, srcNam);
+      CPascalErrors.SetSrcNam(nam);
+      FileNames.StripExt(nam, basNam);
+      FileNames.AppendExt(basNam, "lst", lstNam);
+
+      CreateThisMod;
+      xhrId := IdDesc.newFldId();
+      xhrId.hash := NameHash.enterStr("prev");
+      srcBkt     := NameHash.enterStr("src");
+      corBkt     := NameHash.enterStr("mscorlib_System");
+
+      NEW(sysMod); 
+      sysMod.SetKind(IdDesc.impId);
+    END InitCompState;
+
+(* ==================================================================== *)
+
+  PROCEDURE Report*;
+    VAR str1 : ARRAY 8 OF CHAR;
+        str2 : ARRAY 8 OF CHAR;
+  BEGIN
+    Message(target + GPCPcopyright.verStr); 
+    GPText.IntToStr(CPascalS.line, str1);
+    Message(str1 + " source lines");
+    GPText.IntToStr(impMax, str1);
+    Message("import recursion depth " + str1);
+    GPText.IntToStr(NameHash.size, str2);
+    GPText.IntToStr(NameHash.entries, str1);
+    Message(str1 + " entries in hashtable of size " + str2);
+    TimeMsg("import time   ", import2 - import1);
+    TimeMsg("source time   ", parseS  - totalS);
+    TimeMsg("parse time    ", parseE  - parseS - import2 + import1);
+    TimeMsg("analysis time ", attrib  - parseE);
+    TimeMsg("symWrite time ", symEnd  - attrib);
+    TimeMsg("asmWrite time ", asmEnd  - symEnd);
+    TimeMsg("assemble time ", totalE  - asmEnd);
+    TimeMsg("total time    ", totalE  - totalS);
+  END Report;
+
+(* ==================================================================== *)
+
+  PROCEDURE InitOptions*;
+  BEGIN
+    legacy      := FALSE;
+    warning     := TRUE;
+    verbose     := FALSE;
+    doHelp      := FALSE; doneHelp    := FALSE;
+    doVersion   := FALSE; doneVersion := FALSE;
+    ovfCheck    := TRUE;
+    debug       := TRUE;
+    netRel      := netV2_0; (* probably should be from RTS? *)
+    doSym       := TRUE;
+    extras      := FALSE;
+    unsafe      := FALSE;
+    doStats     := FALSE;
+    doJsmn      := FALSE;
+    doIlasm     := TRUE;
+    forceIlasm  := FALSE;
+    forcePerwapi := FALSE;
+    doCode      := TRUE;
+    doAsm       := TRUE;
+    special     := FALSE;
+    strict      := FALSE;
+    quiet       := FALSE;
+    system      := FALSE;
+    listLevel   := CPascalS.listErrOnly;
+    hashSize    := 5000;        (* gets default hash size *)
+    expectedNet := FALSE;
+    expectedJvm := FALSE;
+    cpSymX      := "CPSYM";
+  END InitOptions;
+
+(* ==================================================================== *)
+BEGIN
+  GPText.Assign(RTS.defaultTarget, target);
+END CompState.
+(* ==================================================================== *)
+

gpcp/Console.cp

@@ -0,0 +1,23 @@
+(* 
+ *  Library module for GP Component Pascal.
+ *  Low level reading and writing to the command-line console.
+ *  Original : kjg November 1998
+ *
+ *
+ *  This is a dummy module, it exists only to cause the 
+ *  generation of a corresponding symbol file: Console.cps
+ *  when compiled with the -special flag.
+ *)
+SYSTEM MODULE Console;
+
+  PROCEDURE WriteLn*();
+
+  PROCEDURE Write*(ch : CHAR);
+
+  PROCEDURE WriteString*(IN str : ARRAY OF CHAR);
+
+  PROCEDURE WriteInt*(val : INTEGER; width : INTEGER); 
+
+  PROCEDURE WriteHex*(val : INTEGER; width : INTEGER);
+
+END Console.

gpcp/DiagHelper.cp

@@ -0,0 +1,31 @@
+(* ============================================================ *)
+(* 								*)
+(*	   Gardens Point Component Pascal Library Module.	*)
+(* 	   Copyright (c) K John Gough 1999, 2000		*)
+(*	   Created : 26 December 1999 kjg			*)
+(* 								*)
+(* ============================================================ *)
+MODULE DiagHelper;
+
+  IMPORT 
+	GPCPcopyright,
+	RTS,
+	Console;
+
+  PROCEDURE Indent*(j : INTEGER);
+    VAR i : INTEGER;
+  BEGIN
+    Console.WriteString("D:");
+    FOR i := 0 TO j-1 DO Console.Write(" ") END;
+  END Indent;
+
+  PROCEDURE Class*(IN str : ARRAY OF CHAR; o : ANYPTR; i : INTEGER);
+  BEGIN
+    Indent(i);
+    Console.WriteString(str);
+    Console.WriteString(" RTSclass ");
+    RTS.ClassMarker(o);
+    Console.WriteLn;
+  END Class;
+
+END DiagHelper.

gpcp/ExprDesc.cp

@@ -0,0 +1,3054 @@
+(* ==================================================================== *)
+(*                                                                      *)
+(*  ExprDesc Module for the Gardens Point Component Pascal Compiler.    *)
+(*  Implements Expr. Descriptors that are extensions of Symbols.Expr    *)
+(*  Copyright (c) John Gough 1999, 2000.                                *)
+(*                                                                      *)
+(* ==================================================================== *)
+
+MODULE ExprDesc;
+
+  IMPORT
+        GPCPcopyright,
+        RTS,
+        Console,
+        Builtin,
+        G := CompState,
+        S := CPascalS,
+        L := LitValue,
+        D := Symbols,
+        I := IdDesc,
+        T := TypeDesc,
+        H := DiagHelper,
+        V := VarSets,
+        FileNames;
+
+(* ============================================================ *)
+
+  CONST (* expr-kinds *)
+  (* leaves *)
+    qualId* = 0;  numLt*  = 1;  realLt* = 2;  charLt* = 3;  strLt* = 4;
+    nilLt*  = 5;  tBool*  = 6;  fBool*  = 7;  setLt*  = 8;  setXp* = 9;
+
+  (* unaries *)
+    deref*  = 10; selct*  = 11; tCheck* = 12; mkStr*  = 13; fnCall* = 14;
+    prCall* = 15; mkBox*  = 16; compl*  = 17; sprMrk* = 18; neg*    = 19;
+    absVl*  = 20; entVl*  = 21; capCh*  = 22; strLen* = 23; strChk* = 24;
+    cvrtUp* = 25; cvrtDn* = 26; oddTst* = 27; mkNStr* = 28; getTp*  = 29;
+
+  (* leaves *)
+    typOf*  = 30; infLt*  = 31; nInfLt* = 32;
+
+  (* binaries *)                index*  = 32; range*  = 33; lenOf*  = 34;
+    maxOf*  = 35; minOf*  = 36; bitAnd* = 37; bitOr*  = 38; bitXor* = 39;
+    plus*   = 40; minus*  = 41; greT*   = 42; greEq*  = 43; notEq*  = 44;
+    lessEq* = 45; lessT*  = 46; equal*  = 47; isOp*   = 48; inOp*   = 49;
+    mult*   = 50; slash*  = 51; modOp*  = 52; divOp*  = 53; blNot*  = 54;
+    blOr*   = 55; blAnd*  = 56; strCat* = 57; ashInt* = 58; rem0op* = 59;
+    div0op* = 60;
+
+  (* more unaries *)
+    adrOf*  = 70; 
+
+
+(* ============================================================ *)
+
+  TYPE
+    LeafX*  = POINTER TO EXTENSIBLE RECORD (D.Expr)
+             (* ... inherited from Expr ... ------------- *
+              * kind-  : INTEGER; (* tag for unions *)
+              * token* : S.Token; (* exp mark token *)
+              * type*  : Type;
+              * ----------------------------------------- *)
+                value* : L.Value;
+              END;  (* ------------------------------ *)
+
+    IdLeaf* = POINTER TO RECORD (LeafX)
+                ident*   : D.Idnt;  (* qualified-idnt *)
+              END;
+
+    SetExp* = POINTER TO RECORD (LeafX)
+                varSeq*  : D.ExprSeq;
+              END;
+
+
+(* ============================================================ *)
+
+  TYPE
+    UnaryX* = POINTER TO EXTENSIBLE RECORD (D.Expr)
+             (* ... inherited from Expr ... ------------- *
+              * kind-  : INTEGER; (* tag for unions *)
+              * token* : S.Token; (* exp mark token *)
+              * type*  : Type;
+              * ----------------------------------------- *)
+                kid*   : D.Expr;
+              END;  (* ------------------------------ *)
+
+    IdentX* = POINTER TO RECORD (UnaryX)
+                ident*   : D.Idnt;  (* field selction *)
+              END;
+
+    CallX*  = POINTER TO RECORD (UnaryX)
+                actuals* : D.ExprSeq;
+              END;
+
+(* ============================================================ *)
+
+  TYPE
+    BinaryX* = POINTER TO RECORD (D.Expr)
+             (* ... inherited from Expr ... ------------- *
+              * kind-  : INTEGER; (* tag for unions *)
+              * token* : S.Token; (* exp mark token *)
+              * type*  : Type;
+              * ----------------------------------------- *)
+                lKid*  : D.Expr;
+                rKid*  : D.Expr;
+              END;  (* ------------------------------ *)
+
+(* ============================================================ *)
+
+  PROCEDURE isPowerOf2(val : LONGINT) : BOOLEAN;
+    VAR lo, hi : INTEGER;
+  BEGIN
+    IF val < 0 THEN
+      RETURN FALSE;
+    ELSE
+      lo := RTS.loInt(val);
+      hi := RTS.hiInt(val);
+      IF hi = 0 THEN
+        RETURN BITS(lo) * BITS(-lo) = BITS(lo);
+      ELSIF lo = 0 THEN
+        RETURN BITS(hi) * BITS(-hi) = BITS(hi);
+      ELSE
+        RETURN FALSE;
+      END;
+    END;
+  END isPowerOf2;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE coverType(a,b : D.Type) : D.Type;
+  BEGIN
+    IF    a.includes(b) THEN RETURN a;
+    ELSIF b.includes(a) THEN RETURN b;
+    ELSIF a = Builtin.uBytTp THEN RETURN coverType(Builtin.sIntTp, b);
+    ELSIF b = Builtin.uBytTp THEN RETURN coverType(a, Builtin.sIntTp);
+    ELSE RETURN NIL;
+    END;
+  END coverType;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE log2(val : LONGINT) : INTEGER;
+    VAR lo, hi, nm : INTEGER;
+  BEGIN
+    lo := RTS.loInt(val);
+    hi := RTS.hiInt(val);
+    IF hi = 0 THEN
+      FOR nm := 0 TO 31 DO
+        IF ODD(lo) THEN RETURN nm ELSE lo := lo DIV 2 END;
+      END;
+    ELSE
+      FOR nm := 32 TO 63 DO
+        IF ODD(hi) THEN RETURN nm ELSE hi := hi DIV 2 END;
+      END;
+    END;
+    THROW("Bad log2 argument");
+    RETURN 0;
+  END log2;
+
+(* ============================================================ *)
+  PROCEDURE^ (x : LeafX)charValue*() : CHAR,NEW;
+  PROCEDURE^ convert(expr : D.Expr; dstT : D.Type) : D.Expr;
+  PROCEDURE^ FormalsVsActuals*(prcX : D.Expr; actSeq : D.ExprSeq);
+(* ============================================================ *)
+(*          LeafX Constructor methods     *)
+(* ============================================================ *)
+
+  PROCEDURE mkLeafVal*(k : INTEGER; v : L.Value) : LeafX;
+    VAR n : LeafX;
+  BEGIN
+    NEW(n); n.token := S.prevTok;
+    n.SetKind(k); n.value := v; RETURN n;
+  END mkLeafVal;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE mkNilX*() : LeafX;
+    VAR n : LeafX;
+  BEGIN
+    NEW(n);
+    n.type := Builtin.anyPtr;
+    n.token := S.prevTok;
+    n.SetKind(nilLt); RETURN n;
+  END mkNilX;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE mkInfX*() : LeafX;
+    VAR n : LeafX;
+  BEGIN
+    NEW(n);
+   (* 
+    *  Here is a dirty trick!
+    *   We assign this the type SHORTREAL, and trap
+    *   the attempt to coerce the value to REAL.
+    *   If the value is coerced we assign it the type 
+    *   Bi.realTp  so that the correct constant is emitted.
+    *)
+    n.type := Builtin.sReaTp;      
+    n.token := S.prevTok;
+    n.SetKind(infLt); RETURN n;
+  END mkInfX;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE mkNegInfX*() : LeafX;
+    VAR n : LeafX;
+  BEGIN
+    NEW(n);
+    n.type := Builtin.sReaTp;
+    n.token := S.prevTok;
+    n.SetKind(nInfLt); RETURN n;
+  END mkNegInfX;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE mkTrueX*() : LeafX;
+    VAR n : LeafX;
+  BEGIN
+    NEW(n);
+    n.type := Builtin.boolTp;
+    n.token := S.prevTok;
+    n.SetKind(tBool); RETURN n;
+  END mkTrueX;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE mkFalseX*() : LeafX;
+    VAR n : LeafX;
+  BEGIN
+    NEW(n);
+    n.type := Builtin.boolTp;
+    n.token := S.prevTok;
+    n.SetKind(fBool); RETURN n;
+  END mkFalseX;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE mkIdLeaf*(id : D.Idnt) : IdLeaf;
+    VAR l : IdLeaf;
+  BEGIN
+    NEW(l);
+    (* l.type := NIL; *)
+    l.token := S.prevTok;
+    l.SetKind(qualId); l.ident := id; RETURN l;
+  END mkIdLeaf;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE mkEmptySet*() : SetExp;
+    VAR l : SetExp;
+  BEGIN
+    NEW(l);
+    l.type := Builtin.setTp;
+    l.token := S.prevTok;
+    l.SetKind(setXp); RETURN l;
+  END mkEmptySet;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE mkSetLt*(s : SET) : SetExp;
+    VAR l : SetExp;
+  BEGIN
+    NEW(l);
+    l.token := S.prevTok;
+    l.SetKind(setLt);
+    l.type := Builtin.setTp;
+    l.value := L.newSetVal(s); RETURN l;
+  END mkSetLt;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE mkCharLt*(ch : CHAR) : LeafX;
+    VAR l : LeafX;
+  BEGIN
+    NEW(l);
+    l.token := S.prevTok;
+    l.type := Builtin.charTp;
+    l.SetKind(charLt);
+    l.value := L.newChrVal(ch); RETURN l;
+  END mkCharLt;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE mkNumLt*(nm : LONGINT) : LeafX;
+    VAR l : LeafX;
+  BEGIN
+    NEW(l);
+    l.token := S.prevTok;
+    l.SetKind(numLt);
+    IF (nm <= MAX(INTEGER)) & (nm >= MIN(INTEGER)) THEN
+      l.type := Builtin.intTp;
+    ELSE
+      l.type := Builtin.lIntTp;
+    END;
+    l.value := L.newIntVal(nm); RETURN l;
+  END mkNumLt;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE mkRealLt*(rv : REAL) : LeafX;
+    VAR l : LeafX;
+  BEGIN
+    NEW(l);
+    l.token := S.prevTok;
+    l.type := Builtin.realTp;
+    l.SetKind(realLt);
+    l.value := L.newFltVal(rv); RETURN l;
+  END mkRealLt;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE mkStrLt*(IN sv : ARRAY OF CHAR) : LeafX;
+    VAR l : LeafX;
+  BEGIN
+    NEW(l);
+    l.token := S.prevTok;
+    l.SetKind(strLt);
+    l.type := Builtin.strTp;
+    l.value := L.newStrVal(sv); RETURN l;
+  END mkStrLt;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE tokToStrLt*(pos,len : INTEGER) : LeafX;
+  (** Generate a LeafX for this string, stripping off the quote *
+    * characters which surround it in the scanner buffer. *)
+    VAR l : LeafX;
+  BEGIN
+    NEW(l);
+    l.token := S.prevTok;
+    l.SetKind(strLt);
+    l.type := Builtin.strTp;
+    l.value := L.newBufVal(pos+1,len-2); RETURN l;
+  END tokToStrLt;
+
+(* ============================================================ *)
+(*         UnaryX Constructor methods     *)
+(* ============================================================ *)
+
+  PROCEDURE newUnaryX*(tag : INTEGER; kid : D.Expr) : UnaryX;
+    VAR u : UnaryX;
+  BEGIN
+    NEW(u); u.token := S.prevTok;
+    u.SetKind(tag); u.kid := kid; RETURN u;
+  END newUnaryX;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE mkDeref*(kid : D.Expr) : D.Expr;
+    VAR new : UnaryX;
+  BEGIN
+    new := newUnaryX(deref, kid);
+    new.token := kid.token;
+    new.type  := kid.type(T.Pointer).boundTp;
+    RETURN new;
+  END mkDeref;
+
+(* ---------------------------- *)
+
+  PROCEDURE newIdentX*(tag : INTEGER; id : D.Idnt; kid : D.Expr) : IdentX;
+    VAR u : IdentX;
+  BEGIN
+    NEW(u); u.token := S.prevTok;
+    u.SetKind(tag); u.ident := id; u.kid := kid; RETURN u;
+  END newIdentX;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE newCallX*(tag : INTEGER; prm : D.ExprSeq; kid : D.Expr) : CallX;
+    VAR u : CallX;
+  BEGIN
+(*
+ *
+ *  NEW(u); u.token := S.prevTok;
+ *
+ *  EXPERIMENTAL
+ *)
+    NEW(u); u.token := kid.token;
+    u.SetKind(tag); u.actuals := prm; u.kid := kid; RETURN u;
+  END newCallX;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE newCallT*(tag : INTEGER; prm : D.ExprSeq;
+                      kid : D.Expr;  tok : S.Token) : CallX;
+    VAR u : CallX;
+  BEGIN
+    NEW(u); u.token := tok;
+    u.SetKind(tag); u.actuals := prm; u.kid := kid; RETURN u;
+  END newCallT;
+
+(* ============================================================ *)
+(*        BinaryX Constructor methods     *)
+(* ============================================================ *)
+
+  PROCEDURE newBinaryX*(tag : INTEGER; lSub,rSub : D.Expr) : BinaryX;
+    VAR b : BinaryX;
+  BEGIN
+    NEW(b); b.token := S.prevTok;
+    b.SetKind(tag); b.lKid := lSub; b.rKid := rSub; RETURN b;
+  END newBinaryX;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE newBinaryT*(k : INTEGER; l,r : D.Expr; t : S.Token) : BinaryX;
+    VAR b : BinaryX;
+  BEGIN
+    NEW(b); b.token := t;
+    b.SetKind(k); b.lKid := l; b.rKid := r; RETURN b;
+  END newBinaryT;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE maxOfType*(t : T.Base) : LeafX;
+  BEGIN
+    CASE t.tpOrd OF
+    | T.byteN : RETURN mkNumLt(MAX(BYTE));
+    | T.uBytN : RETURN mkNumLt(255);
+    | T.sIntN : RETURN mkNumLt(MAX(SHORTINT));
+    | T.intN  : RETURN mkNumLt(MAX(INTEGER));
+    | T.lIntN : RETURN mkNumLt(MAX(LONGINT));
+    | T.sReaN : RETURN mkRealLt(MAX(SHORTREAL));
+    | T.realN : RETURN mkRealLt(MAX(REAL));
+    | T.sChrN : RETURN mkCharLt(MAX(SHORTCHAR));
+    | T.charN : RETURN mkCharLt(MAX(CHAR));
+    | T.setN  : RETURN mkNumLt(31);
+    ELSE
+      RETURN NIL;
+    END;
+  END maxOfType;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE minOfType*(t : T.Base) : LeafX;
+  BEGIN
+    CASE t.tpOrd OF
+    | T.byteN : RETURN mkNumLt(MIN(BYTE));
+    | T.uBytN : RETURN mkNumLt(0);
+    | T.sIntN : RETURN mkNumLt(MIN(SHORTINT));
+    | T.intN  : RETURN mkNumLt(MIN(INTEGER));
+    | T.lIntN : RETURN mkNumLt(MIN(LONGINT));
+    | T.sReaN : RETURN mkRealLt(-MAX(SHORTREAL));   (* for bootstrap *)
+    | T.realN : RETURN mkRealLt(-MAX(REAL));        (* for bootstrap *)
+(*
+ *  | T.sReaN : RETURN mkRealLt(MIN(SHORTREAL));    (* production version *)
+ *  | T.realN : RETURN mkRealLt(MIN(REAL));         (* production version *)
+ *)
+    | T.sChrN,
+      T.charN : RETURN mkCharLt(0X);
+    | T.setN  : RETURN mkNumLt(0);
+    ELSE
+      RETURN NIL;
+    END;
+  END minOfType;
+
+(* ============================================================ *)
+
+  PROCEDURE coerceUp*(x : D.Expr; t : D.Type) : D.Expr;
+  (* 
+   *   Fix to string arrays coerced to native strings: kjg April 2006
+   *)
+  BEGIN
+    IF x.kind = realLt THEN RETURN x;
+    ELSIF (t = G.ntvStr) OR (t = G.ntvObj) & x.isString() THEN
+      RETURN newUnaryX(mkNStr, x);
+    ELSIF x.kind = numLt THEN
+      IF ~t.isRealType() THEN 
+        x.type := t; RETURN x;
+      ELSE
+        RETURN mkRealLt(x(LeafX).value.long());
+      END;
+    ELSIF x.isInf() THEN
+      x.type := t; RETURN x;
+    ELSE
+      RETURN convert(x, t);
+    END;
+  END coerceUp;
+
+(* ============================================================ *)
+(*         Various attribution methods    *)
+(* ============================================================ *)
+
+  PROCEDURE (i : LeafX)TypeErase*() : D.Expr, EXTENSIBLE;
+  (* If the type of the leaf is a compound, it must be erased *)
+  BEGIN
+    IF i.type.isCompoundType() THEN
+      Console.WriteString("FOUND A COMPOUND LEAFX!");Console.WriteLn;
+    END;
+    RETURN i;
+  END TypeErase;
+
+  PROCEDURE (i : IdLeaf)TypeErase*() : D.Expr;
+  BEGIN
+    RETURN i;
+  END TypeErase;
+
+  PROCEDURE (i : SetExp)TypeErase*() : D.Expr;
+  VAR
+    exprN : D.Expr;
+    index : INTEGER;
+  BEGIN
+      FOR index := 0 TO i.varSeq.tide - 1 DO
+        exprN := i.varSeq.a[index];
+        IF exprN # NIL THEN
+          exprN := exprN.TypeErase();
+        END;
+      END;
+      RETURN i;
+  END TypeErase;
+
+  PROCEDURE (i : UnaryX)TypeErase*() : D.Expr,EXTENSIBLE;
+  BEGIN
+      IF i.kid = NIL THEN RETURN NIL END;
+      i.kid := i.kid.TypeErase();
+      IF i.kid = NIL THEN RETURN NIL END;
+      RETURN i;
+  END TypeErase;
+
+  PROCEDURE (i : IdentX)TypeErase*() : D.Expr;
+  BEGIN
+    (* If the IdentX is a type assertion node, and
+     * the assertion is to a compound type, replace
+     * the IdentX with a sequance of assertions *)
+     IF i.kind = tCheck THEN
+      (* IF i.ident.... *)
+     END;
+  RETURN i; END TypeErase;
+
+  PROCEDURE (i : CallX)TypeErase*() : D.Expr;
+  VAR
+    exprN : D.Expr;
+    index : INTEGER;
+  BEGIN
+      FOR index := 0 TO i.actuals.tide - 1 DO
+        exprN := i.actuals.a[index];
+        IF exprN # NIL THEN
+          exprN := exprN.TypeErase();
+        END;
+      END;
+      RETURN i;
+  END TypeErase;
+
+  PROCEDURE (i : BinaryX)TypeErase*() : D.Expr;
+  VAR rslt : D.Expr;
+  BEGIN
+    IF (i.lKid = NIL) OR (i.rKid = NIL) THEN RETURN NIL END;
+    i.lKid := i.lKid.TypeErase();    (* process subtree  *)
+    i.rKid := i.rKid.TypeErase();    (* process subtree  *)
+    IF (i.lKid = NIL) OR (i.rKid = NIL) THEN RETURN NIL END;
+    RETURN i;
+  END TypeErase;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE isRelop(op : INTEGER) : BOOLEAN;
+  BEGIN
+    RETURN (op = equal) OR (op = notEq) OR (op = lessEq) OR
+     (op = lessT) OR (op = greEq) OR (op = greT) OR
+     (op = inOp)  OR (op = isOp);
+  END isRelop;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE getQualType*(exp : D.Expr) : D.Type;
+  (* Return the qualified type with TypId descriptor in the   *
+   * IdLeaf exp, otherwise return the NIL pointer.    *)
+    VAR leaf : IdLeaf;
+        tpId : D.Idnt;
+  BEGIN
+    IF ~(exp IS IdLeaf) THEN RETURN NIL END;
+    leaf := exp(IdLeaf);
+    IF ~(leaf.ident IS I.TypId) THEN RETURN NIL END;
+    tpId := leaf.ident;
+    RETURN tpId.type;
+  END getQualType;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE CheckIsVariable*(e : D.Expr);
+  VAR
+    isVar : BOOLEAN;
+  BEGIN
+    IF (e = NIL) THEN RETURN; END;
+    WITH e : IdentX DO
+      IF e.ident IS I.OvlId THEN e.ident := e.ident(I.OvlId).fld; END;
+      isVar := (e.ident # NIL) & (e.ident IS I.FldId);
+    | e : IdLeaf DO
+      IF e.ident IS I.OvlId THEN e.ident := e.ident(I.OvlId).fld; END;
+      isVar := (e.ident # NIL) & ((e.ident IS I.VarId) OR (e.ident IS I.LocId));
+    | e : BinaryX DO
+      isVar := e.kind = index;
+    | e : UnaryX DO
+      IF e.kind = tCheck THEN
+        isVar := TRUE;
+        e.ExprError(222); 
+      ELSE 
+        isVar := e.kind = deref;
+      END;
+    ELSE
+      isVar := FALSE;
+    END;
+    IF (~isVar) THEN e.ExprError(85); END;
+  END CheckIsVariable;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE (i : LeafX)exprAttr*() : D.Expr,EXTENSIBLE;
+  BEGIN (* most of these are done already ... *)
+    IF (i.kind = numLt) & i.inRangeOf(Builtin.intTp) THEN
+      i.type := Builtin.intTp;
+    END;
+    RETURN i;
+  END exprAttr;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE (i : IdLeaf)exprAttr*() : D.Expr;
+  (* If this references a constant, then return literal *)
+   (* ----------------------------------------- *)
+    PROCEDURE constClone(i : IdLeaf) : D.Expr;
+      VAR conXp : D.Expr;
+    clone : LeafX;
+   (* ----------------------------------------- *
+    *  We must clone the literal rather than  *
+    *  just take a reference copy, as it may  *
+    *  appear in a later error message. If it   *
+    *  does, it needs to have correct line:col. *
+    * ----------------------------------------- *)
+    BEGIN
+      conXp := i.ident(I.ConId).conExp;
+      WITH conXp : SetExp DO
+        clone := mkSetLt({});
+        clone.value := conXp.value;
+      |    conXp : LeafX DO
+        clone := mkLeafVal(conXp.kind, conXp.value);
+        clone.type  := conXp.type;
+      END;
+      clone.token := i.token;
+      RETURN clone;
+    END constClone;
+   (* --------------------------------- *)
+  BEGIN
+    IF (i.ident # NIL) & (i.ident IS I.ConId) THEN
+      IF i.ident(I.ConId).isStd THEN
+        IF    i.ident = Builtin.trueC THEN RETURN mkTrueX();
+        ELSIF i.ident = Builtin.falsC THEN RETURN mkFalseX();
+        ELSIF i.ident = Builtin.nilC  THEN RETURN mkNilX();
+        ELSIF i.ident = Builtin.infC  THEN RETURN mkInfX();
+        ELSIF i.ident = Builtin.nInfC THEN RETURN mkNegInfX();
+        ELSE  i.ExprError(19); RETURN NIL;
+        END;
+      ELSE
+        RETURN constClone(i);
+      END;
+    ELSE
+      RETURN i;
+    END;
+  END exprAttr;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE (i : SetExp)exprAttr*() : D.Expr;
+    VAR exprN : D.Expr;     (* the n-th expression  *)
+        index : INTEGER;    (* reading index  *)
+        write : INTEGER;    (* writing index  *)
+        cPart : SET;        (* constant accumulator *)
+        rngXp : BinaryX;
+        num   : INTEGER;
+
+    (* ----------------------------------- *)
+
+    PROCEDURE isLitRange(exp : BinaryX) : BOOLEAN;
+    BEGIN
+      RETURN (exp.lKid # NIL) &
+             (exp.rKid # NIL) &
+             (exp.lKid.kind = numLt) &
+             (exp.rKid.kind = numLt);
+    END isLitRange;
+
+    (* ----------------------------------- *)
+
+    PROCEDURE mkSetFromRange(exp : BinaryX) : SET;
+      VAR ln,rn : INTEGER;
+    BEGIN
+      ln := exp.lKid(LeafX).value.int();
+      rn := exp.rKid(LeafX).value.int();
+      IF (ln > 31) OR (ln < 0) THEN exp.lKid.ExprError(28); RETURN {} END;
+      IF (rn > 31) OR (rn < 0) THEN exp.rKid.ExprError(29); RETURN {} END;
+      IF rn < ln THEN exp.ExprError(30); RETURN {} END;
+      RETURN {ln .. rn}
+    END mkSetFromRange;
+
+    (* ----------------------------------- *)
+
+  BEGIN (* body of (i : SetExp)exprAttr *)
+    write := 0;
+    cPart := {};
+    FOR index := 0 TO i.varSeq.tide - 1 DO
+      exprN := i.varSeq.a[index];
+      IF exprN # NIL THEN
+        exprN := exprN.exprAttr();
+        IF exprN.kind = numLt THEN  (* singleton element  *)
+          num := exprN(LeafX).value.int();
+          IF (num < 32) & (num >= 0) THEN
+            INCL(cPart, num);
+          ELSE
+            exprN.ExprError(303);
+          END;
+        ELSIF exprN.kind = range THEN
+          rngXp := exprN(BinaryX);
+          IF isLitRange(rngXp) THEN (* const elem range *)
+            cPart := cPart + mkSetFromRange(rngXp);
+          ELSE
+            IF ~rngXp.lKid.isIntExpr() THEN rngXp.lKid.ExprError(37) END;
+            IF ~rngXp.rKid.isIntExpr() THEN rngXp.rKid.ExprError(37) END;
+            i.varSeq.a[write] := exprN; INC(write);
+          END;
+        ELSE        (* variable element(s)  *)
+          IF ~exprN.isIntExpr() THEN exprN.ExprError(37) END;
+          i.varSeq.a[write] := exprN; INC(write);
+        END;
+      END;
+    END;
+    IF write # i.varSeq.tide THEN   (* expression changed *)
+      i.value := L.newSetVal(cPart);
+      IF write = 0 THEN     (* set is all constant  *)
+        i.SetKind(setLt);
+      END;
+      i.varSeq.ResetTo(write);    (* truncate elem list *)
+    ELSIF write = 0 THEN    (* this is empty set  *)
+      i.SetKind(setLt);
+    END;
+    i.type := Builtin.setTp;
+    RETURN i;
+  END exprAttr;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE (i : UnaryX)exprAttr*() : D.Expr,EXTENSIBLE;
+    VAR leaf : LeafX;
+        rslt : D.Expr;
+  BEGIN
+    IF i.kid = NIL THEN RETURN NIL END;
+    i.kid := i.kid.exprAttr();
+    IF i.kid = NIL THEN RETURN NIL END;
+    rslt := i;
+    CASE i.kind OF
+    | neg :      (* Fold constants and mark sets *)
+        IF i.kid.kind = setXp THEN
+          i.SetKind(compl);
+          i.type := Builtin.setTp;
+        ELSIF i.kid.kind = setLt THEN
+          leaf := i.kid(LeafX);
+          leaf.value := L.newSetVal(-leaf.value.set());
+          rslt := leaf;
+        ELSIF i.kid.kind = numLt THEN
+          leaf := i.kid(LeafX);
+          leaf.value := L.newIntVal(-leaf.value.long());
+          rslt := leaf;
+        ELSIF i.kid.kind = realLt THEN
+          leaf := i.kid(LeafX);
+          leaf.value := L.newFltVal(-leaf.value.real());
+          rslt := leaf;
+        ELSE
+          i.type := i.kid.type;
+        END;
+    | blNot : (* Type check subtree, and fold consts *)
+        IF i.kid.type # Builtin.boolTp THEN i.ExprError(36) END;
+        IF i.kid.kind = blNot THEN (* fold double negation *)
+          rslt := i.kid(UnaryX).kid;
+        ELSIF i.kid.kind = tBool THEN
+          rslt := mkFalseX();
+        ELSIF i.kid.kind = fBool THEN
+          rslt := mkTrueX();
+        ELSE
+          i.type := Builtin.boolTp;
+        END;
+    ELSE (* Nothing to do. Parser did type check already *)
+         (* mkStr, absVl, convert, capCh, entVl, strLen, lenOf, oddTst *)
+         (* tCheck *)
+    END;
+    RETURN rslt;
+  END exprAttr;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE (i : IdentX)exprAttr*() : D.Expr;
+  BEGIN
+    IF (i.kind = selct) & (i.ident # NIL) & (i.ident IS I.ConId) THEN
+      RETURN i.ident(I.ConId).conExp.exprAttr();
+    ELSE
+      ASSERT((i.kind = selct)  OR
+       (i.kind = cvrtUp) OR (i.kind = cvrtDn));
+      RETURN i;
+    END;
+  END exprAttr;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE (i : CallX)exprAttr*() : D.Expr;
+ (* fnCall nodes are attributed during parsing of the designator  *
+  * so there is nothing left to do here.  Do not recurse further down.  *)
+  BEGIN RETURN i END exprAttr;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE checkCall*(i : CallX) : D.Expr;
+    VAR prTp : T.Procedure;
+        prXp : D.Expr;
+
+    (* --------------------------- *)
+
+    PROCEDURE length(arg0 : D.Expr; arg1 : LeafX) : D.Expr;
+      VAR dimN : INTEGER;
+          dIdx : INTEGER;
+          cTyp : D.Type;
+          cLen : INTEGER;
+    BEGIN
+      dimN := arg1.value.int();
+      IF dimN < 0 THEN arg1.ExprError(46); RETURN NIL END;
+
+     (*
+      *   Take care of LEN(typename) case ... kjg December 2004
+      *)
+      WITH arg0 : IdLeaf DO
+        IF arg0.ident IS I.TypId THEN arg0.type := arg0.ident.type END;
+      ELSE
+      END;
+
+      IF arg0.type.kind = T.ptrTp THEN arg0 := mkDeref(arg0) END;
+      cLen := 0;
+      cTyp := arg0.type;
+      IF cTyp.kind = T.vecTp THEN
+        IF dimN # 0 THEN arg1.ExprError(231) END;
+      ELSE
+        FOR dIdx := 0 TO dimN DO
+          IF cTyp.kind = T.arrTp THEN
+            cLen := cTyp(T.Array).length;
+            cTyp := cTyp(T.Array).elemTp;
+          ELSE
+            arg1.ExprError(40); RETURN NIL;
+          END;
+        END;
+      END;
+      IF cLen = 0 THEN (* must compute at runtime *)
+        RETURN newBinaryX(lenOf, arg0, arg1);
+      ELSE
+        RETURN mkNumLt(cLen);
+      END;
+    END length;
+
+    (* --------------------------- *)
+
+    PROCEDURE stdFunction(i : CallX; act : D.ExprSeq) : D.Expr;
+    (* Assert: prc holds a procedure ident descriptor of a standard Fn. *)
+      VAR prc  : IdLeaf;
+          funI : I.PrcId;
+          rslt : D.Expr;
+          leaf : LeafX;
+          arg0 : D.Expr;
+          arg1 : D.Expr;
+          typ0 : D.Type;
+          dstT : D.Type;
+          funN : INTEGER;
+          lVal : LONGINT;
+          rVal : REAL;
+          ptrT : T.Pointer;
+    BEGIN
+      prc  := i.kid(IdLeaf);
+      rslt := NIL;
+      arg0 := NIL;
+      arg1 := NIL;
+      funI := prc.ident(I.PrcId);
+      funN := funI.stdOrd;
+      IF act.tide >= 1 THEN
+        arg0 := act.a[0];
+        IF arg0 # NIL THEN arg0 := arg0.exprAttr() END;
+        IF act.tide >= 2 THEN
+          arg1 := act.a[1];
+          IF arg1 # NIL THEN arg1 := arg1.exprAttr() END;
+          IF arg1 = NIL THEN RETURN NIL END;
+        END;
+        IF arg0 = NIL THEN RETURN NIL END;
+      END;
+     (*
+      *  Now we check the per-case semantics.
+      *)
+      CASE funN OF
+      (* ---------------------------- *)
+      | Builtin.absP :
+          IF    act.tide = 0 THEN prc.ExprError(22);
+          ELSIF act.tide > 1 THEN prc.ExprError(23);
+          ELSE
+            IF arg0.isNumericExpr() THEN
+              IF arg0.kind = numLt THEN
+                leaf := arg0(LeafX); leaf.value := L.absV(leaf.value);
+          IF leaf.value = NIL THEN arg0.ExprError(39)END;
+          rslt := leaf;
+              ELSIF arg0.kind = realLt THEN
+          rslt := mkRealLt(ABS(arg0(LeafX).value.real()));
+              ELSE
+          rslt := newUnaryX(absVl, arg0);
+              END;
+              rslt.type := arg0.type;
+            ELSE
+              arg0.ExprError(38);
+            END;
+          END;
+      (* ---------------------------- *)
+      | Builtin.ashP :
+          IF    act.tide < 2 THEN prc.ExprError(22);
+          ELSIF act.tide > 2 THEN prc.ExprError(23);
+          ELSE
+            IF ~arg0.isIntExpr() THEN arg0.ExprError(37) END;
+            IF ~arg1.isIntExpr() THEN arg1.ExprError(37) END;
+            IF (arg0.kind = numLt) & (arg1.kind = numLt) THEN
+              rslt := mkNumLt(ASH(arg0(LeafX).value.int(),
+                arg1(LeafX).value.int()));
+            ELSE
+              IF arg0.type # Builtin.intTp THEN
+                arg0 := convert(arg0, Builtin.intTp);
+              END;
+              IF arg1.type # Builtin.intTp THEN
+                arg1 := convert(arg1, Builtin.intTp);
+              END;
+              rslt := newBinaryX(ashInt, arg0, arg1);
+            END;
+            rslt.type := Builtin.intTp;
+          END;
+      (* ---------------------------- *)
+      | Builtin.bitsP :
+          IF    act.tide < 1 THEN prc.ExprError(22);
+          ELSIF act.tide > 1 THEN prc.ExprError(23);
+          ELSE
+            rslt := arg0;
+            IF rslt.isIntExpr() THEN
+              (*
+               *  BITS accepts an integer expression
+               *  which may be either short or long.
+               *  In the case of short values these
+               *  are sign-extended to 32 bits.
+               *  In the case of long values gpcp
+               *  performs an unsigned conversion to
+               *  uint32, capturing the 32 least
+               *  significant bits of the long value.
+               *)
+              IF rslt.kind = numLt THEN
+                (* Pull out ALL of the bits of the numLt.   *)
+                (* At compile-time gpcp will convert from   *)
+                (* int64 to uint32 using the elsepart below *)
+                rslt := mkSetLt(BITS(arg0(LeafX).value.long()));
+                rslt.type := Builtin.setTp;
+              ELSE
+                (* Graft an unchecked conversion onto the   *)
+                (* root of the argument expression tree.    *)
+                rslt := convert(rslt, Builtin.setTp); 
+              END;
+            ELSE
+              arg0.ExprError(56);
+            END;
+          END;
+      (* ---------------------------- *)
+      | Builtin.capP :
+          IF    act.tide = 0 THEN prc.ExprError(22);
+          ELSIF act.tide > 1 THEN prc.ExprError(23);
+          ELSE
+            IF arg0.isCharExpr() THEN
+              IF arg0.isCharLit() THEN
+                rslt := mkCharLt(CAP(arg0(LeafX).charValue()));
+              ELSE
+                rslt := newUnaryX(capCh, arg0);
+              END;
+              rslt.type := Builtin.charTp;
+            ELSE
+              arg0.ExprError(43);
+            END;
+          END;
+      (* ---------------------------- *)
+      | Builtin.chrP :
+          IF    act.tide = 0 THEN prc.ExprError(22);
+          ELSIF act.tide > 1 THEN prc.ExprError(23);
+          ELSE
+            IF arg0.isIntExpr() THEN
+              IF arg0.kind = numLt THEN
+                lVal := arg0(LeafX).value.long();
+                IF (lVal >= 0) & (lVal <= LONG(ORD(MAX(CHAR)))) THEN
+                  rslt := mkCharLt(CHR(lVal));
+                  rslt.type := Builtin.charTp;
+                ELSE
+                  arg0.ExprError(44);
+                END;
+              ELSE
+                rslt := convert(arg0, Builtin.charTp);
+              END;
+            ELSE
+              arg0.ExprError(37);
+            END;
+          END;
+      (* ---------------------------- *)
+      | Builtin.entP :
+          IF    act.tide = 0 THEN prc.ExprError(22);
+          ELSIF act.tide > 1 THEN prc.ExprError(23);
+          ELSE
+            dstT := Builtin.lIntTp;
+            IF arg0.isRealExpr() THEN
+              IF arg0.kind = realLt THEN
+                leaf := mkLeafVal(numLt, L.entV(arg0(LeafX).value));
+                IF leaf.value = NIL THEN
+                   arg0.ExprError(55);
+                ELSIF i.inRangeOf(Builtin.intTp) THEN
+                  dstT := Builtin.intTp;
+                END;
+                rslt := leaf;
+              ELSE
+                rslt := newUnaryX(entVl, arg0);
+              END;
+              rslt.type := dstT;
+            ELSE
+              arg0.ExprError(45);
+            END;
+          END;
+      (* ---------------------------- *)
+      | Builtin.lenP :
+          IF    act.tide = 0 THEN prc.ExprError(22);
+          ELSIF act.tide > 2 THEN prc.ExprError(23);
+          ELSIF act.tide = 1 THEN
+            IF arg0.kind = strLt THEN
+              rslt := mkNumLt(arg0(LeafX).value.len());
+            ELSIF arg0.kind = mkStr THEN
+              rslt := newUnaryX(strLen, arg0);
+            ELSE        (* add default dimension *)
+              D.AppendExpr(act, mkNumLt(0));
+            END;
+          END;
+          IF act.tide = 2 THEN
+            arg1 := act.a[1];
+            IF arg1.kind = numLt THEN
+              rslt := length(arg0, arg1(LeafX));
+            ELSE
+              arg1.ExprError(46);
+            END;
+          END;
+          IF rslt # NIL THEN rslt.type := Builtin.intTp END;
+      (* ---------------------------- *)
+      | Builtin.tpOfP :
+          IF G.strict THEN prc.ExprError(221); END;
+          IF    act.tide = 0 THEN prc.ExprError(22);
+          ELSIF act.tide > 1 THEN prc.ExprError(23);
+          ELSIF arg0.type = Builtin.metaTp THEN
+            ASSERT(arg0 IS IdLeaf);
+            rslt := arg0;
+            rslt.SetKind(typOf);
+          ELSIF arg0.isVarDesig() THEN
+            IF arg0.type.isDynamicType() THEN
+              rslt := newUnaryX(getTp, arg0);
+            ELSE
+              dstT := arg0.type;    
+              IF dstT.idnt = NIL THEN          (* Anonymous type *)
+                dstT.idnt := I.newAnonId(dstT.serial);
+                dstT.idnt.type := dstT;
+              END; 
+              rslt := mkIdLeaf(dstT.idnt);
+              rslt.SetKind(typOf);
+            END;
+          ELSE arg0.ExprError(85);
+          END;
+          IF rslt # NIL THEN rslt.type := G.ntvTyp END;
+      (* ---------------------------- *)
+      | Builtin.adrP :
+          IF G.strict THEN prc.ExprError(221); END;
+          IF    act.tide = 0 THEN prc.ExprError(22);
+          ELSIF act.tide > 1 THEN prc.ExprError(23);
+          ELSIF arg0.isVarDesig() THEN
+            rslt := newUnaryX(adrOf, arg0);
+          ELSE arg0.ExprError(85);
+          END;
+          IF rslt # NIL THEN rslt.type := Builtin.intTp END;
+      (* ---------------------------- *)
+      | Builtin.maxP,
+        Builtin.minP :
+          IF    act.tide = 0 THEN prc.ExprError(22);
+          ELSIF act.tide > 2 THEN prc.ExprError(23);
+          ELSIF act.tide = 1 THEN (* should be the MAX(TypeName) case *)
+            dstT := getQualType(arg0);
+            IF dstT.kind # T.basTp THEN prc.ExprError(48) END;
+            IF funN = Builtin.maxP THEN
+              rslt := maxOfType(dstT(T.Base));
+            ELSE
+              rslt := minOfType(dstT(T.Base));
+            END;
+            IF rslt # NIL THEN rslt.type := dstT END;
+          ELSE (*  must be the MAX(exp1, exp2) case *)
+           (*
+            *  Note that for literals, coverType is always >= int.
+            *)
+            dstT := coverType(arg0.type, arg1.type);
+            IF dstT = NIL THEN arg0.ExprError(38);
+            ELSIF (arg0.kind = numLt) & (arg1.kind = numLt) THEN
+              IF funN = Builtin.maxP THEN
+                lVal := MAX(arg0(LeafX).value.long(),arg1(LeafX).value.long());
+              ELSE
+                lVal := MIN(arg0(LeafX).value.long(),arg1(LeafX).value.long());
+              END;
+              rslt := mkNumLt(lVal);
+            ELSIF (arg0.kind = realLt) & (arg1.kind = realLt) THEN
+              IF funN = Builtin.maxP THEN
+                rVal := MAX(arg0(LeafX).value.real(),arg1(LeafX).value.real());
+              ELSE
+                rVal := MIN(arg0(LeafX).value.real(),arg1(LeafX).value.real());
+              END;
+              rslt := mkRealLt(rVal);
+            ELSE
+              IF arg0.type # dstT THEN arg0 := convert(arg0, dstT) END;
+              IF arg1.type # dstT THEN arg1 := convert(arg1, dstT) END;
+              IF funN = Builtin.maxP THEN
+                rslt := newBinaryX(maxOf, arg0, arg1)
+              ELSE
+                rslt := newBinaryX(minOf, arg0, arg1)
+              END;
+            END;
+            IF rslt # NIL THEN rslt.type := dstT END;
+          END;
+      (* ---------------------------- *)
+      | Builtin.oddP :
+          IF    act.tide = 0 THEN prc.ExprError(22);
+          ELSIF act.tide > 1 THEN prc.ExprError(23);
+          ELSE
+            rslt := arg0;
+            IF ~rslt.isIntExpr() THEN rslt.ExprError(37);
+            ELSIF rslt.kind = numLt THEN  (* calculate right now  *)
+              IF ODD(rslt(LeafX).value.int()) THEN
+                rslt := mkTrueX();
+              ELSE
+                rslt := mkFalseX();
+              END;
+            ELSE        (* else leave to runtime*)
+              rslt := newUnaryX(oddTst, rslt);
+            END;
+            rslt.type := Builtin.boolTp;
+          END;
+      (* ---------------------------- *)
+      | Builtin.ordP :
+          IF    act.tide = 0 THEN prc.ExprError(22);
+          ELSIF act.tide > 1 THEN prc.ExprError(23);
+          ELSE
+            rslt := arg0;
+            IF rslt.isCharLit() THEN
+              rslt := mkNumLt(ORD(rslt(LeafX).charValue()));
+            ELSIF rslt.kind = setLt THEN
+              rslt := mkNumLt(rslt(LeafX).value.int());
+            ELSIF rslt.isCharExpr() OR rslt.isSetExpr() THEN
+              rslt := convert(rslt, Builtin.intTp);
+            ELSE
+              prc.ExprError(50);
+            END;
+            rslt.type := Builtin.intTp;
+          END;
+      (* ---------------------------- *)
+      | Builtin.uBytP :
+          IF    act.tide = 0 THEN prc.ExprError(22);
+          ELSIF act.tide > 1 THEN prc.ExprError(23);
+          ELSE
+            rslt := arg0;
+            dstT := Builtin.uBytTp;
+            IF rslt.kind = numLt THEN
+              IF ~rslt.inRangeOf(dstT) THEN rslt.ExprError(26) END;
+            ELSIF arg0.isNumericExpr() THEN
+              rslt := convert(rslt, dstT);
+            ELSE
+              rslt.ExprError(226);
+            END;
+            rslt.type := dstT;
+          END;
+      (* ---------------------------- *)
+      | Builtin.mStrP :
+          IF G.strict THEN prc.ExprError(221); END;
+          IF    act.tide = 0 THEN prc.ExprError(22);
+          ELSIF act.tide > 1 THEN prc.ExprError(23);
+          ELSIF ~arg0.isString() & ~arg0.isCharArray() THEN
+            arg0.ExprError(41);
+          END;
+          rslt := newUnaryX(mkNStr, arg0);
+          rslt.type := G.ntvStr;
+      (* ---------------------------- *)
+      | Builtin.boxP :
+          IF G.strict THEN prc.ExprError(221); END;
+          IF    act.tide = 0 THEN prc.ExprError(22);
+          ELSIF act.tide > 1 THEN prc.ExprError(23);
+          ELSE
+            typ0 := arg0.type;
+            rslt := newUnaryX(mkBox, arg0);
+            WITH typ0 : T.Record DO 
+                 IF D.isFn IN typ0.xAttr THEN
+                   ptrT := G.ntvObj(T.Pointer);
+                 ELSE
+                   ptrT := T.newPtrTp();
+                   ptrT.boundTp := typ0;
+                 END;
+            | typ0 : T.Array  DO 
+                 ptrT := T.newPtrTp();
+                 IF typ0.length = 0 THEN  (* typ0 already an open array *)
+                   ptrT.boundTp := typ0;
+                 ELSE                     (* corresponding open array   *)
+                   ptrT.boundTp := T.mkArrayOf(typ0.elemTp);
+                 END;
+            ELSE 
+              ptrT := T.newPtrTp();
+              IF typ0.isStringType() THEN 
+                ptrT.boundTp := Builtin.chrArr;
+              ELSE 
+                arg0.ExprError(140);
+              END;
+            END;
+            rslt.type := ptrT;
+          END;
+      (* ---------------------------- *)
+      | Builtin.shrtP :
+          IF    act.tide = 0 THEN prc.ExprError(22);
+          ELSIF act.tide > 1 THEN prc.ExprError(23);
+          ELSE
+            rslt := arg0;
+            IF rslt.kind = charLt THEN      (* do right away *)
+              IF ~rslt.inRangeOf(Builtin.sChrTp) THEN rslt.ExprError(168) END;
+              rslt.type := Builtin.sChrTp;
+            ELSIF rslt.kind = strLt THEN    (* do right away *)
+              IF ~L.isShortStr(rslt(LeafX).value) THEN
+                rslt.ExprError(168) END;
+              rslt.type := Builtin.sStrTp;
+            ELSIF rslt.type = Builtin.strTp  THEN (* do at runtime *)
+              rslt := newUnaryX(strChk, rslt);
+              rslt.type := Builtin.sStrTp;
+            ELSE
+              IF    rslt.type = Builtin.lIntTp THEN dstT := Builtin.intTp;
+              ELSIF rslt.type = Builtin.intTp  THEN dstT := Builtin.sIntTp;
+              ELSIF rslt.type = Builtin.sIntTp THEN dstT := Builtin.byteTp;
+              ELSIF rslt.type = Builtin.realTp THEN dstT := Builtin.sReaTp;
+              ELSIF rslt.type = Builtin.charTp THEN dstT := Builtin.sChrTp;
+              ELSE  rslt.ExprError(51);             dstT := Builtin.intTp;
+              END;
+              IF rslt.kind = numLt THEN
+                IF ~rslt.inRangeOf(dstT) THEN rslt.ExprError(26) END;
+              ELSE
+                rslt := convert(rslt, dstT);
+              END;
+            END;
+          END;
+      (* ---------------------------- *)
+      | Builtin.longP :
+          IF    act.tide = 0 THEN prc.ExprError(22);
+          ELSIF act.tide > 1 THEN prc.ExprError(23);
+          ELSE
+            rslt := arg0;
+            IF    rslt.type = Builtin.intTp  THEN dstT := Builtin.lIntTp;
+            ELSIF rslt.type = Builtin.sIntTp THEN dstT := Builtin.intTp;
+            ELSIF rslt.type = Builtin.byteTp THEN dstT := Builtin.sIntTp;
+            ELSIF rslt.type = Builtin.sReaTp THEN dstT := Builtin.realTp;
+            ELSIF rslt.type = Builtin.sChrTp THEN dstT := Builtin.charTp;
+            ELSE  rslt.ExprError(47);     dstT := Builtin.lIntTp;
+            END;
+            rslt := convert(rslt, dstT);
+          END;
+      (* ---------------------------- *)
+      | Builtin.sizeP :
+          prc.ExprError(167);
+      (* ---------------------------- *)
+      ELSE
+        prc.ExprError(42);
+      END;
+      RETURN rslt;
+    END stdFunction;
+
+    (* --------------------------- *)
+
+    PROCEDURE StdProcedure(i : CallX; act : D.ExprSeq);
+    (* Assert: prc holds a procedure ident descriptor of a standard Pr. *)
+      VAR prc  : IdLeaf;
+          funI : I.PrcId;
+          funN : INTEGER;
+          argN : INTEGER;
+          arg0 : D.Expr;
+          arg1 : D.Expr;
+          argT : D.Type;
+          bndT : D.Type;
+          ptrT : T.Pointer;
+    (* --------------------------- *)
+      PROCEDURE CheckNonZero(arg : D.Expr);
+      BEGIN
+        IF arg(LeafX).value.int() <= 0 THEN arg.ExprError(68) END;
+      END CheckNonZero;
+    (* --------------------------- *)
+    BEGIN
+      prc  := i.kid(IdLeaf);
+      arg0 := NIL;
+      arg1 := NIL;
+      funI := prc.ident(I.PrcId);
+      funN := funI.stdOrd;
+      IF act.tide >= 1 THEN
+        arg0 := act.a[0].exprAttr();
+        act.a[0] := arg0;
+        IF act.tide >= 2 THEN
+          arg1 := act.a[1].exprAttr();
+          IF arg1 = NIL THEN RETURN END;
+          act.a[1] := arg1;
+        END;
+        IF arg0 = NIL THEN RETURN END;
+      END;
+     (*
+      *  Now we check the per-case semantics.
+      *)
+      CASE funN OF
+      (* ---------------------------- *)
+      | Builtin.asrtP :
+          IF    act.tide = 0 THEN prc.ExprError(22);
+          ELSIF act.tide > 2 THEN prc.ExprError(23);
+          ELSE
+            IF arg0.type # Builtin.boolTp THEN
+              arg0.ExprError(36);
+            END;
+            IF (arg1 # NIL) & (arg1.kind # numLt) THEN
+              arg1.ExprError(91);
+            END;
+          END;
+      (* ---------------------------- *)
+      | Builtin.incP,
+        Builtin.decP :
+          IF    act.tide = 0 THEN prc.ExprError(22);
+          ELSIF act.tide > 2 THEN prc.ExprError(23);
+          ELSE
+            IF arg0.isVarDesig() THEN
+              arg0.CheckWriteable();
+              IF ~arg0.isIntExpr()   THEN arg0.ExprError(37) END;
+            ELSE
+              arg0.ExprError(85);
+            END;
+            IF arg1 = NIL THEN
+              D.AppendExpr(act, mkNumLt(1));
+            ELSIF ~arg1.isIntExpr() THEN
+              arg1.ExprError(37);
+            END;
+          END;
+      (* ---------------------------- *)
+      | Builtin.inclP,
+        Builtin.exclP :
+          IF    act.tide < 2 THEN prc.ExprError(22);
+          ELSIF act.tide > 2 THEN prc.ExprError(23);
+          ELSE
+            IF arg0.isVarDesig() THEN
+              arg0.CheckWriteable();
+              IF ~arg0.isSetExpr()   THEN arg0.ExprError(35) END;
+              IF ~arg1.isIntExpr()   THEN arg1.ExprError(37) END;
+            ELSE
+              arg0.ExprError(85);
+            END;
+            IF arg1.isIntExpr() THEN
+              IF (arg1.kind = numLt) &    (* Should be warning only? *)
+                 ~arg1.inRangeOf(Builtin.setTp) THEN arg1.ExprError(303) END;
+            ELSE
+              arg1.ExprError(37);
+            END;
+          END;
+      (* ---------------------------- *)
+      | Builtin.getP :
+          IF    act.tide = 0 THEN prc.ExprError(22);
+          ELSIF act.tide > 2 THEN prc.ExprError(23);
+          ELSE
+            IF arg0.type # Builtin.intTp THEN arg0.ExprError(37) END;
+            IF ~arg1.isVarDesig() THEN arg1.ExprError(85) END; 
+            IF arg1.type.kind # T.basTp THEN arg1.ExprError(48) END;
+          END;
+      (* ---------------------------- *)
+      | Builtin.putP :
+          IF    act.tide = 0 THEN prc.ExprError(22);
+          ELSIF act.tide > 2 THEN prc.ExprError(23);
+          ELSE
+            IF arg0.type # Builtin.intTp THEN arg0.ExprError(37) END;
+            IF arg1.type.kind # T.basTp THEN arg1.ExprError(48) END;
+          END;
+      (* ---------------------------- *)
+      | Builtin.cutP  :
+          IF    act.tide < 2 THEN prc.ExprError(22);
+          ELSIF act.tide > 2 THEN prc.ExprError(23);
+          ELSIF arg0.isVarDesig() THEN
+            arg0.CheckWriteable();
+            IF ~arg0.isVectorExpr() THEN arg0.ExprError(229) END;
+          ELSE
+            arg0.ExprError(85);
+          END;
+          IF ~arg1.isIntExpr() THEN arg1.ExprError(37) END;
+      (* ---------------------------- *)
+      | Builtin.apndP :
+          IF    act.tide < 2 THEN prc.ExprError(22);
+          ELSIF act.tide > 2 THEN prc.ExprError(23);
+          ELSIF arg0.isVarDesig() THEN
+            argT := arg0.type;
+            arg0.CheckWriteable();
+            WITH argT : T.Vector DO
+              IF ~argT.elemTp.equalType(arg1.type) THEN 
+                D.RepTypesErrTok(230, argT.elemTp, arg1.type, arg1.token);
+              END;
+            ELSE 
+              arg0.ExprError(229);
+            END;
+          ELSE
+            arg0.ExprError(85);
+          END;
+      (* ---------------------------- *)
+      | Builtin.subsP,
+        Builtin.unsbP :
+          IF G.strict THEN prc.ExprError(221); END;
+          IF    act.tide < 2 THEN prc.ExprError(22);
+          ELSIF act.tide > 2 THEN prc.ExprError(23);
+          ELSE
+            IF arg0.isVarDesig() THEN
+              arg0.CheckWriteable();
+              IF ~arg0.type.isEventType() THEN arg0.ExprError(210) END;
+              IF ~arg1.isProcLit()        THEN arg1.ExprError(211) END;
+              IF ~arg0.type.assignCompat(arg1) THEN arg1.ExprError(83) END;
+            ELSE
+              arg0.ExprError(85);
+            END;
+          END;
+      (* ---------------------------- *)
+      | Builtin.haltP :
+          IF    act.tide = 0 THEN prc.ExprError(22);
+          ELSIF act.tide > 1 THEN prc.ExprError(23);
+          ELSIF arg0.kind # numLt THEN arg0.ExprError(93);
+          END;
+      (* ---------------------------- *)
+      | Builtin.throwP :
+          IF G.strict THEN prc.ExprError(221); END;
+          IF    act.tide = 0 THEN prc.ExprError(22);
+          ELSIF act.tide > 1 THEN prc.ExprError(23);
+          ELSIF G.ntvExc.assignCompat(arg0) OR
+                G.ntvStr.assignCompat(arg0) THEN (* skip *)
+          ELSE  arg0.ExprError(193);
+          END;
+      (* ---------------------------- *)
+      | Builtin.newP :
+          IF    act.tide = 0 THEN prc.ExprError(22);
+          ELSIF arg0.type # NIL THEN
+            argT := arg0.type;
+            IF ~arg0.isVarDesig() THEN
+              arg0.ExprError(85);
+            ELSE
+              arg0.CheckWriteable();
+              WITH argT : T.Base DO
+                  arg0.ExprError(90);
+              | argT : T.Vector DO
+                  IF act.tide = 1 THEN prc.ExprError(95);
+                  ELSIF act.tide > 2 THEN prc.ExprError(97);
+                  ELSIF ~arg1.isIntExpr() THEN
+                    arg1.ExprError(98);
+                  ELSIF arg1.kind = numLt THEN 
+                    CheckNonZero(arg1);
+                  END;
+              | argT : T.Pointer DO
+                  bndT := argT.boundTp;
+                  IF act.tide = 1 THEN
+                   (*
+                    *  Bound-type must be a record or a fixed
+                    *  length, one-dimensional array type.
+                    *)
+                    IF bndT.kind = T.recTp THEN
+                      bndT(T.Record).InstantiateCheck(arg0.token);
+                    ELSIF bndT.kind = T.arrTp THEN
+                      IF bndT.isOpenArrType() THEN arg0.ExprError(95) END;
+                    ELSE
+                      arg0.ExprError(96);
+                    END;
+                  ELSE
+                   (*
+                    *  This must be a possibly multi-dimensional array type.
+                    *)
+                    IF ~bndT.isOpenArrType() THEN
+                      arg0.ExprError(99);
+                    ELSIF ~arg1.isIntExpr() THEN
+                      arg1.ExprError(98);
+                    ELSE
+                      IF arg1.kind = numLt THEN CheckNonZero(arg1) END;
+                      bndT := bndT(T.Array).elemTp;
+                      FOR argN := 2 TO act.tide-1 DO
+                        arg1 := act.a[argN].exprAttr();
+                        IF arg1.kind = numLt THEN CheckNonZero(arg1) END;
+                        IF ~bndT.isOpenArrType() THEN
+                          arg0.ExprError(97);
+                        ELSIF ~arg1.isIntExpr() THEN
+                          arg1.ExprError(98);
+                        ELSE
+                          bndT := bndT(T.Array).elemTp;
+                        END;
+                        act.a[argN] := arg1;  (* update expression *)
+                      END;
+                      (* check if we need more length params *)
+                      IF bndT.isOpenArrType() THEN arg1.ExprError(100) END;
+                    END;
+                  END;
+              ELSE
+                arg0.ExprError(94);
+              END; (* with argT *)
+            END; (* if isVarDesig() *)
+          END; (* if *)
+      (* ---------------------------- *)
+      ELSE
+        prc.ExprError(92);
+      END;
+    END StdProcedure;
+
+    (* --------------------------- *)
+
+  BEGIN (* body of checkCall *)
+    prXp := i.kid;
+    prTp := prXp.type(T.Procedure);
+    IF i.kind = prCall THEN
+      IF prXp.isStdProc() THEN
+        StdProcedure(i, i.actuals);
+      ELSIF prXp.kind = fnCall THEN
+        prXp.ExprError(80);
+      ELSE
+        FormalsVsActuals(prXp, i.actuals);
+        IF prTp.retType # NIL THEN i.ExprError(74) END;
+        i.type := NIL;
+      END;
+    ELSIF i.kind = fnCall THEN
+      IF prXp.isStdFunc() THEN
+        RETURN stdFunction(i, i.actuals);
+      ELSE
+        FormalsVsActuals(prXp, i.actuals);
+        IF prTp.retType = NIL THEN
+          i.ExprError(24);
+        ELSIF prTp.retType IS T.Opaque THEN
+          prTp.retType := prTp.retType.elaboration();
+        END;
+        i.type := prTp.retType;
+      END;
+    ELSE
+      Console.WriteString("unexpected callx"); Console.WriteLn; i.Diagnose(0);
+    END;
+    RETURN i;
+  END checkCall;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE CheckSuper*(c : CallX; s : D.Scope);
+    VAR kid1, kid2 : D.Expr;
+  BEGIN
+   (* ------------------------------------------------- *
+    * Precondition: c.kid.kind = sprMrk.
+    * The only correct expression cases are
+    *
+    *   CallX
+    *       IdentX --- (kind = sprMrk)
+    *           IdLeaf --- (ident = s(MthId).rcvFrm)
+    *
+    *   CallX
+    *       IdentX --- (kind = sprMrk)
+    *           UnaryX --- (kind = deref)
+    *               IdLeaf --- (ident = s(MthId).rcvFrm)
+    *
+    * ------------------------------------------------- *)
+    kid1 := c.kid;
+    kid1.ExprError(300);                (* A warning only ...   *)
+    WITH kid1 : IdentX DO
+      kid2 := kid1.kid;
+      IF kid2.kind = deref THEN kid2 := kid2(UnaryX).kid END;
+      WITH kid2 : IdLeaf DO
+        WITH s : IdDesc.MthId DO
+          IF kid2.ident # s.rcvFrm THEN c.ExprError(166) END;
+        ELSE
+          c.ExprError(166);
+        END;
+      ELSE
+        c.ExprError(166);
+      END;
+    ELSE
+      c.ExprError(166);
+    END;
+  END CheckSuper;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE (i : BinaryX)exprAttr*() : D.Expr;
+    VAR rslt : D.Expr;
+        kind : INTEGER;
+
+    (* --------------------------- *)
+
+    PROCEDURE chrOp(i : BinaryX) : D.Expr;
+      VAR ch1,ch2 : CHAR;
+          dRes : BOOLEAN;
+          rslt : D.Expr;
+    BEGIN
+      rslt := i;
+      IF i.lKid.isCharLit() & i.rKid.isCharLit() THEN
+        ch1 := i.lKid(LeafX).charValue();
+        ch2 := i.rKid(LeafX).charValue();
+        CASE i.kind OF
+        | greT   : dRes := ch1 > ch2;
+        | greEq  : dRes := ch1 >= ch2;
+        | notEq  : dRes := ch1 # ch2;
+        | lessEq : dRes := ch1 <= ch2;
+        | lessT  : dRes := ch1 < ch2;
+        | equal  : dRes := ch1 = ch2;
+        ELSE i.ExprError(171); RETURN NIL;
+        END;
+        IF dRes THEN
+          rslt := mkTrueX();
+        ELSE
+          rslt := mkFalseX();
+        END;
+      ELSIF ~isRelop(i.kind) THEN
+        i.ExprError(171);
+      ELSE
+        i.lKid.type := Builtin.charTp;
+        i.rKid.type := Builtin.charTp;
+      END;
+      rslt.type := Builtin.boolTp; RETURN rslt;
+    END chrOp;
+
+    (* --------------------------- *)
+
+    PROCEDURE strOp(i : BinaryX) : D.Expr;
+      VAR fold : BOOLEAN;
+          sRes : INTEGER;
+          bRes : BOOLEAN;
+          rslt : D.Expr;
+    BEGIN (* Pre: lKid,rKid are a string-valued expressions *)
+      IF i.kind = strCat THEN RETURN i END;                  (* ALREADY DONE *)
+      fold := i.lKid.isStrLit() & i.rKid.isStrLit();
+      rslt := i;
+      IF i.kind = plus THEN
+        IF fold THEN
+          rslt :=  mkLeafVal(strLt, L.concat(i.lKid(LeafX).value,
+                             i.rKid(LeafX).value));
+        ELSE
+          i.SetKind(strCat); (* can't assign via rslt, it is readonly! *)
+        END;
+        rslt.type := Builtin.strTp;
+      ELSIF isRelop(i.kind) THEN
+        IF fold THEN
+          sRes := L.strCmp(i.lKid(LeafX).value, i.rKid(LeafX).value);
+          CASE i.kind OF
+          | greT   : bRes := sRes > 1;
+          | greEq  : bRes := sRes >= 0;
+          | notEq  : bRes := sRes # 0;
+          | lessEq : bRes := sRes <= 0;
+          | lessT  : bRes := sRes < 0;
+          | equal  : bRes := sRes = 0;
+          END;
+          IF bRes THEN
+            rslt := mkTrueX();
+          ELSE
+            rslt := mkFalseX();
+          END;
+        (* ELSE nothing to do *)
+        END;
+        rslt.type := Builtin.boolTp;
+      ELSE
+        i.ExprError(171); RETURN NIL;
+      END;
+      RETURN rslt;
+    END strOp;
+
+    (* --------------------------- *)
+
+    PROCEDURE setOp(i : BinaryX) : D.Expr;
+      VAR newX : D.Expr;
+          rsTp : D.Type;
+          dRes : BOOLEAN;
+          lSet,rSet,dSet : SET;
+    BEGIN (* Pre: lKid is a set-valued expression *)
+      rsTp := Builtin.setTp;
+      dRes := FALSE; dSet := {};
+      IF ~i.rKid.isSetExpr() THEN i.rKid.ExprError(35); RETURN NIL END;
+      IF (i.lKid.kind = setLt) & (i.rKid.kind = setLt) THEN
+        lSet := i.lKid(LeafX).value.set();
+        rSet := i.rKid(LeafX).value.set();
+        CASE i.kind OF
+        | plus, bitOr:  dSet := lSet + rSet;
+        | minus :   dSet := lSet - rSet;
+        | mult, bitAnd: dSet := lSet * rSet;
+        | slash,bitXor: dSet := lSet / rSet;
+        | greT   :  dRes := lSet > rSet;  rsTp := Builtin.boolTp;
+        | greEq  :  dRes := lSet >= rSet; rsTp := Builtin.boolTp;
+        | notEq  :  dRes := lSet # rSet;  rsTp := Builtin.boolTp;
+        | lessEq :  dRes := lSet <= rSet; rsTp := Builtin.boolTp;
+        | lessT  :  dRes := lSet < rSet;  rsTp := Builtin.boolTp;
+        | equal  :  dRes := lSet = rSet;  rsTp := Builtin.boolTp;
+        ELSE i.ExprError(171);
+        END;
+        IF rsTp # Builtin.boolTp THEN
+          newX := mkSetLt(dSet);
+        ELSIF dRes THEN
+          newX := mkTrueX();
+        ELSE
+          newX := mkFalseX();
+        END;
+      ELSE
+        CASE i.kind OF
+        | plus   : i.SetKind(bitOr);
+        | mult   : i.SetKind(bitAnd);
+        | slash  : i.SetKind(bitXor);
+        | minus  : i.SetKind(bitAnd);
+             i.rKid := newUnaryX(compl, i.rKid);
+             i.rKid.type := rsTp;
+        | greT, greEq, notEq, lessEq, lessT, equal : rsTp := Builtin.boolTp;
+        ELSE i.ExprError(171);
+        END;
+        newX := i;
+      END;
+      newX.type := rsTp; RETURN newX;
+    END setOp;
+
+    (* --------------------------- *)
+
+    PROCEDURE numOp(i : BinaryX) : D.Expr;
+      VAR newX : D.Expr;
+          rsTp : D.Type;
+          dRes : BOOLEAN;
+          rLit : LONGINT;
+          lVal, rVal, dVal : L.Value;
+          lFlt, rFlt, dFlt : REAL;
+    BEGIN (* Pre: rKid is a numeric expression *)
+      dRes := FALSE; dFlt := 0.0; dVal := NIL;
+      IF ~i.lKid.isNumericExpr() THEN i.lKid.ExprError(38); RETURN NIL END;
+      IF i.kind = slash THEN
+        rsTp := Builtin.realTp;
+      ELSE
+        rsTp := coverType(i.lKid.type, i.rKid.type);
+        IF rsTp = NIL THEN i.ExprError(38); RETURN NIL END;
+      END;
+      (* First we coerce to a common type, if that is necessary *)
+      IF rsTp # i.lKid.type THEN i.lKid := coerceUp(i.lKid, rsTp) END;
+      IF rsTp # i.rKid.type THEN i.rKid := coerceUp(i.rKid, rsTp) END;
+
+      IF (i.lKid.kind = numLt) & (i.rKid.kind = numLt) THEN
+        lVal := i.lKid(LeafX).value;
+        rVal := i.rKid(LeafX).value;
+        CASE i.kind OF
+        | plus   : dVal := L.addV(lVal, rVal);
+        | minus  : dVal := L.subV(lVal, rVal);
+        | mult   : dVal := L.mulV(lVal, rVal);
+        | modOp  : dVal := L.modV(lVal, rVal);
+        | divOp  : dVal := L.divV(lVal, rVal);
+      
+        | rem0op : dVal := L.rem0V(lVal, rVal);
+        | div0op : dVal := L.div0V(lVal, rVal);
+      
+        | slash  : dVal := L.slashV(lVal, rVal);       rsTp := Builtin.realTp;
+        | greT   : dRes := lVal.long() >  rVal.long(); rsTp := Builtin.boolTp;
+        | greEq  : dRes := lVal.long() >= rVal.long(); rsTp := Builtin.boolTp;
+        | notEq  : dRes := lVal.long() #  rVal.long(); rsTp := Builtin.boolTp;
+        | lessEq : dRes := lVal.long() <= rVal.long(); rsTp := Builtin.boolTp;
+        | lessT  : dRes := lVal.long() <  rVal.long(); rsTp := Builtin.boolTp;
+        | equal  : dRes := lVal.long() =  rVal.long(); rsTp := Builtin.boolTp;
+        ELSE i.ExprError(171);
+        END;
+        IF rsTp = Builtin.realTp THEN
+          newX := mkRealLt(dFlt);
+        ELSIF rsTp # Builtin.boolTp THEN (* ==> some int type *)
+          newX := mkLeafVal(numLt, dVal);
+        ELSIF dRes THEN
+          newX := mkTrueX();
+        ELSE
+          newX := mkFalseX();
+        END;
+      ELSIF (i.lKid.kind = realLt) & (i.rKid.kind = realLt) THEN
+        lFlt := i.lKid(LeafX).value.real(); rFlt := i.rKid(LeafX).value.real();
+        CASE i.kind OF
+        | plus   : dFlt := lFlt + rFlt;
+        | minus  : dFlt := lFlt - rFlt;
+        | mult   : dFlt := lFlt * rFlt;
+        | slash  : dFlt := lFlt / rFlt;
+        | greT   : dRes := lFlt > rFlt;   rsTp := Builtin.boolTp;
+        | greEq  : dRes := lFlt >= rFlt;  rsTp := Builtin.boolTp;
+        | notEq  : dRes := lFlt # rFlt;   rsTp := Builtin.boolTp;
+        | lessEq : dRes := lFlt <= rFlt;  rsTp := Builtin.boolTp;
+        | lessT  : dRes := lFlt < rFlt;   rsTp := Builtin.boolTp;
+        | equal  : dRes := lFlt = rFlt;   rsTp := Builtin.boolTp;
+        ELSE i.ExprError(171);
+        END;
+        IF rsTp # Builtin.boolTp THEN
+           newX := mkRealLt(dFlt);
+        ELSIF dRes THEN
+          newX := mkTrueX();
+        ELSE
+          newX := mkFalseX();
+        END;
+(* 
+ *    SHOULD FOLD IEEE INFINITIES HERE! 
+ *)
+      ELSE
+        CASE i.kind OF
+        | plus, minus, mult, slash :
+            (* skip *)
+        | rem0op, div0op :
+            IF rsTp.isRealType() THEN i.ExprError(45) END;
+        | modOp, divOp :
+            IF rsTp.isRealType() THEN
+              i.ExprError(45);
+            ELSIF  (i.rKid.kind = numLt) THEN
+              rLit := i.rKid(LeafX).value.long();
+              IF isPowerOf2(rLit) THEN
+                IF i.kind = modOp THEN
+                  i.SetKind(bitAnd);
+                  i.rKid := mkNumLt(rLit - 1);
+                ELSE
+                  i.SetKind(ashInt);
+                  i.rKid := mkNumLt(-log2(rLit)); (* neg ==> right shift *)
+                END;
+              END;
+            END;
+        | greT,  greEq, notEq, lessEq, lessT, equal :
+            rsTp := Builtin.boolTp;
+        ELSE i.ExprError(171);
+        END;
+        newX := i;
+      END;
+      newX.type := rsTp; RETURN newX;
+    END numOp;
+
+    (* --------------------------- *)
+
+    PROCEDURE isTest(b : BinaryX) : D.Expr;
+      VAR dstT : D.Type;
+    BEGIN
+      IF b.lKid.type = NIL THEN RETURN NIL END;
+      dstT := getQualType(b.rKid);
+      IF dstT = NIL THEN b.rKid.ExprError(5); RETURN NIL END;
+      IF ~b.lKid.hasDynamicType() THEN b.lKid.ExprError(17); RETURN NIL END;
+      IF ~b.lKid.type.isBaseOf(dstT) THEN b.ExprError(34); RETURN NIL END;
+      b.type := Builtin.boolTp; RETURN b;
+    END isTest;
+
+    (* --------------------------- *)
+
+    PROCEDURE inTest(b : BinaryX) : D.Expr;
+      VAR sVal : SET;
+          iVal : INTEGER;
+          rslt : D.Expr;
+    BEGIN
+      IF ~b.lKid.isIntExpr() THEN b.lKid.ExprError(37); RETURN NIL END;
+      IF ~b.rKid.isSetExpr() THEN b.rKid.ExprError(35); RETURN NIL END;
+      rslt := b;
+      IF (b.lKid.kind = strLt) & (b.rKid.kind = setLt) THEN
+        iVal := b.lKid(LeafX).value.int();
+        sVal := b.rKid(LeafX).value.set();
+        IF iVal IN sVal THEN
+          rslt := mkTrueX();
+        ELSE
+          rslt := mkFalseX();
+        END;
+      END;
+      rslt.type := Builtin.boolTp; RETURN rslt;
+    END inTest;
+
+    (* --------------------------- *)
+
+    PROCEDURE EqualOkCheck(node : BinaryX);
+      VAR lTp,rTp : D.Type;
+    BEGIN
+      lTp := node.lKid.type;
+      rTp := node.rKid.type;
+      IF (lTp = NIL) OR (rTp = NIL) THEN RETURN END;
+     (*
+      *  The permitted cases here are:
+      *   comparisons of Booleans
+      *   comparisons of pointers (maybe sanity checked?)
+      *   comparisons of procedures (maybe sanity checked?)
+      *)
+      IF (node.lKid.isBooleanExpr() & node.rKid.isBooleanExpr()) OR
+         (node.lKid.isPointerExpr() & node.rKid.isPointerExpr()) OR
+         (node.lKid.isProcExpr()    & node.rKid.isProcExpr()) THEN
+        node.type := Builtin.boolTp;
+      ELSE
+        D.RepTypesErrTok(57, node.lKid.type, node.rKid.type, node.token);
+      END;
+    END EqualOkCheck;
+
+    (* --------------------------- *)
+
+    PROCEDURE boolBinOp(i : BinaryX) : D.Expr;
+      VAR rslt : D.Expr;
+    BEGIN
+      IF i.lKid.type # Builtin.boolTp THEN i.lKid.ExprError(36) END;
+      IF i.rKid.type # Builtin.boolTp THEN i.rKid.ExprError(36) END;
+      IF i.lKid.kind = tBool THEN
+        IF i.kind = blOr THEN
+          rslt := i.lKid;       (* return the TRUE  *)
+        ELSE
+          rslt := i.rKid;       (* return the rhs-expr  *)
+        END;
+      ELSIF i.lKid.kind = fBool THEN
+        IF i.kind = blOr THEN
+          rslt := i.rKid;       (* return the rhs-expr  *)
+        ELSE
+          rslt := i.lKid;       (* return the FALSE *)
+        END;
+      ELSE
+        rslt := i;
+        rslt.type := Builtin.boolTp;
+      END;
+      RETURN rslt;
+    END boolBinOp;
+
+    (* --------------------------- *)
+
+  BEGIN  (* BinaryX exprAttr body *)
+    rslt := NIL;
+    kind := i.kind;
+   (*
+    *  The following cases are fully attributed already
+    *  perhaps as a result of a call of checkCall()
+    *)
+    IF (kind = index) OR (kind = ashInt) OR
+       (kind = lenOf) OR (kind = minOf) OR (kind = maxOf) THEN RETURN i END;
+   (*
+    *  First, attribute the subtrees.
+    *)
+    IF (i.lKid = NIL) OR (i.rKid = NIL) THEN RETURN NIL END;
+    i.lKid := i.lKid.exprAttr();    (* process subtree  *)
+    i.rKid := i.rKid.exprAttr();    (* process subtree  *)
+    IF (i.lKid = NIL) OR (i.rKid = NIL) THEN RETURN NIL END;
+   (*
+    *  Deal with unique cases first... IN and IS, then OR and &
+    *)
+    IF kind = range THEN
+      rslt := i;
+    ELSIF kind = inOp THEN
+      rslt := inTest(i);
+    ELSIF kind = isOp THEN
+      rslt := isTest(i);
+    ELSIF (kind = blOr) OR
+    (kind = blAnd) THEN
+      rslt := boolBinOp(i);
+   (*
+    *  Deal with set-valued expressions, including constant folding.
+    *)
+    ELSIF i.lKid.isSetExpr() THEN
+      rslt := setOp(i);
+   (*
+    *  Deal with numerical expressions, including constant folding.
+    *  Note that we test the right subtree, to avoid (num IN set) case.
+    *)
+    ELSIF i.rKid.isNumericExpr() THEN
+      rslt := numOp(i);
+   (*
+    *  Deal with string expressions, including constant folding.
+    *  Note that this must be done before dealing characters so
+    *  as to correctly deal with literal strings of length one.
+    *)
+    ELSIF (i.lKid.isString() OR i.lKid.isCharArray()) &
+    (i.rKid.isString() OR i.rKid.isCharArray()) THEN
+      rslt := strOp(i);
+   (*
+    *  Deal with character expressions, including constant folding.
+    *)
+    ELSIF i.lKid.isCharExpr() & i.rKid.isCharExpr() THEN
+      rslt := chrOp(i);
+   (*
+    *  Now all the irregular cases.
+    *)
+    ELSIF (kind = equal) OR (kind = notEq) THEN
+      EqualOkCheck(i);
+      i.type := Builtin.boolTp;
+      rslt := i;
+    ELSE
+      i.ExprError(171);
+    END;
+    RETURN rslt;
+  END exprAttr;
+
+(* ============================================================ *)
+(*         Flow attribution for actual parameter lists    *)
+(* ============================================================ *)
+
+  PROCEDURE (cXp : CallX)liveActuals(scp : D.Scope;
+                                     set : V.VarSet) : V.VarSet,NEW;
+    VAR idx : INTEGER;
+        act : D.Expr;
+        xKd : D.Expr;
+        frm : I.ParId;
+        pTp : T.Procedure;
+        new : V.VarSet;
+  BEGIN
+    new := set.newCopy();
+    xKd := cXp.kid;
+    pTp := xKd.type(T.Procedure);
+    FOR idx := 0 TO cXp.actuals.tide-1 DO
+      act := cXp.actuals.a[idx];
+      frm := pTp.formals.a[idx];
+      IF frm.parMod # D.out THEN
+       (*
+        *  We accumulate the effect of each evaluation, using
+        *  "set" as input in each case.  This is conservative,
+        *  assuming parallel (but strict) evaluation.
+        *)
+        new := act.checkLive(scp, set).cup(new);
+      ELSE
+        new := act.assignLive(scp, new);
+      END;
+    END;
+   (* 
+    *   If locals are uplevel addressed we presume that they
+    *   might be initialized by any call of a nested procedure.
+    *)
+    IF scp IS I.Procs THEN
+      WITH xKd : IdentX DO
+          IF xKd.ident.dfScp = scp THEN scp.UplevelInitialize(new) END;
+      | xKd : IdLeaf DO
+          IF xKd.ident.dfScp = scp THEN scp.UplevelInitialize(new) END;
+      | xKd : UnaryX DO
+          ASSERT(xKd.kind = tCheck);
+      END (* skip *)
+    END;
+    (* #### kjg, Sep-2001 *)
+    RETURN new;
+  END liveActuals;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE (x : CallX)liveStdProc(scp : D.Scope;
+                                   set : V.VarSet) : V.VarSet,NEW;
+  (** Compute the live-out set as a result of the call of this  *)
+  (*  standard procedure.  Standard functions are all inline.   *)
+    VAR funI : I.PrcId;
+        funN : INTEGER;
+        arg0 : D.Expr;
+        tmpS : V.VarSet;
+        indx : INTEGER;
+  BEGIN
+    funI := x.kid(IdLeaf).ident(I.PrcId);
+    funN := funI.stdOrd;
+    arg0 := x.actuals.a[0];
+   (*
+    *  Now we check the per-case semantics.
+    *)
+    IF funN = Builtin.newP THEN
+     (*
+      *  It is tempting, but incorrect to omit the newCopy()
+      *  and chain the values from arg to arg.  However we do
+      *  not guarantee the order of evaluation (for native code).
+      *  Likewise, it is not quite correct to skip the "cup" with
+      *      tmpS := arg0.assignLive(scp, tmpS);
+      *  since one of the LEN evals might have a side-effect on
+      *  the base qualId of the first parameter.
+      *)
+      IF x.actuals.tide > 1 THEN
+        tmpS := set.newCopy();
+        FOR indx := 1 TO x.actuals.tide-1 DO
+          tmpS := tmpS.cup(x.actuals.a[indx].checkLive(scp, set));
+        END;
+        tmpS := tmpS.cup(arg0.assignLive(scp, set));
+      ELSE
+        tmpS := arg0.assignLive(scp, set);
+      END;
+    ELSIF funN = Builtin.asrtP THEN
+      tmpS := arg0.checkLive(scp, set); (* arg1 is a literal! *)
+    ELSIF (funN = Builtin.haltP) OR (funN = Builtin.throwP) THEN
+      tmpS := arg0.checkLive(scp, set); (* and discard *)
+      tmpS := V.newUniv(set.cardinality()); 
+    ELSIF funN = Builtin.getP THEN
+      tmpS := arg0.checkLive(scp, set);
+      tmpS := tmpS.cup(x.actuals.a[1].assignLive(scp, set));
+    ELSIF funN = Builtin.putP THEN
+      tmpS := arg0.checkLive(scp, set);
+      tmpS := tmpS.cup(x.actuals.a[1].checkLive(scp, set));
+    ELSE (* Builtin.incP, decP, inclP, exclP, cutP, apndP *)
+      tmpS := arg0.assignLive(scp, set);
+      IF x.actuals.tide = 2 THEN
+        tmpS := tmpS.cup(x.actuals.a[1].checkLive(scp, set));
+      END;
+    END;
+    RETURN tmpS;
+  END liveStdProc;
+
+(* ============================================================ *)
+(*    Flow attribution for leaves: nothing to do for LeafX  *)
+(* ============================================================ *)
+
+  PROCEDURE (x : IdLeaf)checkLive*(scp : D.Scope;
+                                   lIn : V.VarSet) : V.VarSet;
+  (* If the variable is local, check that is is live *)
+  (* Assert: expression has been fully attributed.   *)
+  BEGIN
+    IF  (x.ident.kind # I.conId) &
+        (x.ident.dfScp = scp) &
+        ~x.ident.isIn(lIn) THEN 
+      IF x.isPointerExpr() THEN
+        x.ExprError(316);
+      ELSE
+        x.ExprError(135);
+      END;
+    END;
+    RETURN lIn;
+  END checkLive;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE (x : SetExp)checkLive*(scp : D.Scope;
+                                   lIn : V.VarSet) : V.VarSet;
+  (* Assert: expression has been fully attributed.   *)
+  BEGIN
+      (* Really: recurse over set elements *)
+    RETURN lIn;
+  END checkLive;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE (x : LeafX)BoolLive*(scp : D.Scope;
+                                 set : V.VarSet;
+                             OUT tru,fal : V.VarSet);
+  BEGIN
+    IF    x.kind = tBool THEN
+      tru := set;
+      fal := V.newUniv(set.cardinality());
+    ELSIF x.kind = fBool THEN
+      tru := V.newUniv(set.cardinality());
+      fal := set;
+    ELSE
+      tru := x.checkLive(scp, set);
+      fal := tru;
+    END;
+  END BoolLive;
+
+(* ============================================================ *)
+(*    Flow attribution for unaries: nothing to do for IdentX  *)
+(* ============================================================ *)
+
+  PROCEDURE (x : UnaryX)BoolLive*(scp : D.Scope;
+                                  set : V.VarSet;
+                              OUT tru,fal : V.VarSet);
+  BEGIN
+    IF x.kind = blNot THEN
+      x.kid.BoolLive(scp, set, fal, tru);
+    ELSE
+      tru := x.checkLive(scp, set);
+      fal := tru;
+    END;
+  END BoolLive;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE (x : UnaryX)checkLive*(scp : D.Scope;
+                                   lIn : V.VarSet) : V.VarSet,EXTENSIBLE;
+  (* Assert: expression has been fully attributed.   *)
+  BEGIN
+    RETURN x.kid.checkLive(scp, lIn);
+  END checkLive;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE (x : CallX)checkLive*(scp : D.Scope;
+                                  lIn : V.VarSet) : V.VarSet;
+  (* Assert: expression has been fully attributed.   *)
+    VAR tmpS : V.VarSet;
+  BEGIN
+    tmpS :=  x.kid.checkLive(scp, lIn);
+    IF (x.kind = prCall) & x.kid.isStdProc() THEN
+      RETURN x.liveStdProc(scp, tmpS);
+    ELSE
+      RETURN x.liveActuals(scp, tmpS);
+    END;
+  END checkLive;
+
+(* ============================================================ *)
+(*      Flow attribution for binary expressions     *)
+(* ============================================================ *)
+
+  PROCEDURE (x : BinaryX)BoolLive*(scp : D.Scope;
+                                   set : V.VarSet;
+                               OUT tru,fal : V.VarSet);
+  (** If this is a short-circuit operator evaluate the two      *)
+  (*  subtrees and combine. Otherwise return unconditional set. *)
+    VAR lhT, lhF, rhT, rhF : V.VarSet;
+  BEGIN
+    IF x.kind = blOr THEN
+      x.lKid.BoolLive(scp, set, lhT, lhF);
+      x.rKid.BoolLive(scp, lhF, rhT, fal);
+      tru := lhT.cap(rhT);
+    ELSIF x.kind = blAnd THEN
+      x.lKid.BoolLive(scp, set, lhT, lhF);
+      x.rKid.BoolLive(scp, lhT, tru, rhF);
+      fal := lhF.cap(rhF);
+    ELSE
+      tru := x.checkLive(scp, set);
+      fal := tru;
+    END;
+  END BoolLive;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE (x : BinaryX)checkLive*(scp : D.Scope;
+                                    lIn : V.VarSet) : V.VarSet;
+  (* Assert: expression has been fully attributed.   *)
+  (** Compute the live-out set resulting from the evaluation of *)
+  (*  this expression, and check that any used occurrences of   *)
+  (*  local variables are in the live set. Beware of the case   *)
+  (*  where this is a Boolean expression with side effects!     *)
+    VAR fSet, tSet : V.VarSet;
+  BEGIN
+    IF (x.kind = blOr) OR (x.kind = blAnd) THEN
+      x.lKid.BoolLive(scp, lIn, tSet, fSet);
+      IF x.kind = blOr THEN
+       (*
+        *  If this evaluation short circuits, then the result
+        *  is tSet.  If the second factor is evaluated, the result
+        *  is obtained by passing fSet as input to the second
+        *  term evaluation. Thus the guaranteed output is the
+        *  intersection of tSet and x.rKid.checkLive(fSet).
+        *)
+        RETURN tSet.cap(x.rKid.checkLive(scp, fSet));
+      ELSE (* x.kind = blAnd *)
+       (*
+        *  If this evaluation short circuits, then the result
+        *  is fSet.  If the second factor is evaluated, the result
+        *  is obtained by passing tSet as input to the second
+        *  factor evaluation. Thus the guaranteed output is the
+        *  intersection of fSet and x.rKid.checkLive(tSet).
+        *)
+        RETURN fSet.cap(x.rKid.checkLive(scp, tSet));
+      END;
+    ELSE
+      (* TO DO : check that this is OK for all the inlined standard functions *)
+      RETURN x.lKid.checkLive(scp, lIn).cup(x.rKid.checkLive(scp, lIn));
+    END;
+  END checkLive;
+
+(* ============================================================ *)
+(*     Assign flow attribution for qualified id expressions   *)
+(* ============================================================ *)
+
+  PROCEDURE (p : IdLeaf)assignLive*(scpe : D.Scope;
+                                    lvIn : V.VarSet) : V.VarSet;
+    VAR tmpS : V.VarSet;
+  BEGIN
+    (* Invariant: input set lvIn is unchanged *)
+    IF p.ident.dfScp = scpe THEN
+      tmpS := lvIn.newCopy();
+      tmpS.Incl(p.ident(I.AbVar).varOrd);
+      RETURN tmpS;
+    ELSE
+      RETURN lvIn;
+    END;
+  END assignLive;
+
+(* ============================================================ *)
+(*         Predicates on Expr extensions              *)
+(* ============================================================ *)
+
+  PROCEDURE (x : IdLeaf)hasDynamicType*() : BOOLEAN;
+  BEGIN
+    RETURN (x.ident # NIL) & x.ident.isDynamic();
+  END hasDynamicType;
+
+(* -------------------------------------------- *)
+(* -------------------------------------------- *)
+
+  PROCEDURE (x : IdLeaf)isWriteable*() : BOOLEAN;
+  (* A qualident is writeable if the IdLeaf is writeable  *)
+  BEGIN
+    RETURN x.ident.mutable();
+  END isWriteable;
+
+  PROCEDURE (x : IdLeaf)CheckWriteable*();
+  (* A qualident is writeable if the IdLeaf is writeable  *)
+  BEGIN
+    x.ident.CheckMutable(x);
+  END CheckWriteable;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE (x : UnaryX)isWriteable*() : BOOLEAN,EXTENSIBLE;
+  (* A referenced object is always writeable. *)
+  (* tCheck nodes are always NOT writeable.   *)
+  BEGIN RETURN x.kind = deref END isWriteable;
+
+  PROCEDURE (x : UnaryX)CheckWriteable*(),EXTENSIBLE;
+  (* A referenced object is always writeable. *)
+  (* tCheck nodes are always NOT writeable.   *)
+  BEGIN
+    IF x.kind # deref THEN x.ExprError(103) END;
+  END CheckWriteable;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE (x : IdentX)isWriteable*() : BOOLEAN;
+  (*  This case depends on the mutability of the record field,  *
+   *  other cases of IdentX are not writeable at all.   *)
+  BEGIN
+    RETURN (x.kind = selct) & x.ident.mutable() & x.kid.isWriteable();
+  END isWriteable;
+
+  PROCEDURE (x : IdentX)CheckWriteable*();
+  (*  This case depends on the mutability of the record field,  *
+   *  other cases of IdentX are not writeable at all.   *)
+  BEGIN
+    IF x.kind = selct THEN
+      x.ident.CheckMutable(x);
+      x.kid.CheckWriteable();
+    ELSE
+      x.ExprError(103);
+    END;
+  END CheckWriteable;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE (x : BinaryX)isWriteable*() : BOOLEAN;
+  (*  The only possibly writeable case here is for array  *
+   *  elements.  These are writeable if the underlying array is *)
+  BEGIN
+    RETURN (x.kind = index) & x.lKid.isWriteable();
+  END isWriteable;
+
+  PROCEDURE (x : BinaryX)CheckWriteable*();
+  (*  The only possibly writeable case here is for array  *
+   *  elements.  These are writeable if the underlying array is *)
+  BEGIN
+    IF x.kind # index THEN
+      x.ExprError(103);
+    ELSE
+      x.lKid.CheckWriteable();
+    END;
+  END CheckWriteable;
+
+(* -------------------------------------------- *)
+(* -------------------------------------------- *)
+
+  PROCEDURE (x : IdLeaf)isVarDesig*() : BOOLEAN;
+  BEGIN
+    RETURN x.ident IS I.AbVar; (* varId or parId *)
+  END isVarDesig;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE (x : UnaryX)isVarDesig*() : BOOLEAN,EXTENSIBLE;
+  BEGIN RETURN x.kind = deref END isVarDesig;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE (x : IdentX)isVarDesig*() : BOOLEAN;
+  BEGIN
+    RETURN x.kind = selct;
+  END isVarDesig;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE (x : BinaryX)isVarDesig*() : BOOLEAN;
+  BEGIN
+    RETURN x.kind = index;
+  END isVarDesig;
+
+(* -------------------------------------------- *)
+(* -------------------------------------------- *)
+
+  PROCEDURE (x : IdLeaf)isProcLit*() : BOOLEAN;
+  BEGIN
+   (*
+    *  True if this is a concrete procedure
+    *)
+    RETURN (x.ident.kind = I.conPrc) OR
+     (x.ident.kind = I.fwdPrc);
+  END isProcLit;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE (x : IdentX)isProcLit*() : BOOLEAN;
+  BEGIN
+   (*
+    *  True if this is a concrete procedure
+    *)
+    RETURN (x.ident.kind = I.conMth) OR
+     (x.ident.kind = I.fwdMth);
+  END isProcLit;
+
+(* -------------------------------------------- *)
+(* -------------------------------------------- *)
+
+  PROCEDURE (x : IdLeaf)isProcVar*() : BOOLEAN;
+  BEGIN
+   (*
+    *  True if this has procedure type, but is not a concrete procedure
+    *)
+    RETURN x.type.isProcType() &
+     (x.ident.kind # I.conPrc) &
+     (x.ident.kind # I.fwdPrc) &
+     (x.ident.kind # I.ctorP);
+  END isProcVar;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE (x : IdentX)isProcVar*() : BOOLEAN;
+  BEGIN
+   (*
+    *  True if this is a selct, and field has procedure type
+    *)
+    RETURN (x.kind = selct) &
+     (x.ident IS I.FldId) &
+      x.type.isProcType();
+  END isProcVar;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE (x : UnaryX)isProcVar*() : BOOLEAN,EXTENSIBLE;
+  BEGIN
+   (*
+    *  This depends on the fact that x.kid will be
+    *  of System.Delegate type, and is being cast
+    *  to some subtype of Procedure or Event type.
+    *)
+    RETURN (x.kind = tCheck) & x.type.isProcType();
+  END isProcVar;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE (x : BinaryX)isProcVar*() : BOOLEAN;
+  BEGIN
+   (*
+    *  True if this is an index, and element has procedure type
+    *)
+    RETURN (x.kind = index) & x.type.isProcType();
+  END isProcVar;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE (x : LeafX)isNil*() : BOOLEAN;
+  BEGIN RETURN x.kind = nilLt END isNil;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE (x : LeafX)isInf*() : BOOLEAN;
+  BEGIN RETURN (x.kind = infLt) OR (x.kind = nInfLt) END isInf;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE (x : LeafX)isNumLit*() : BOOLEAN;
+  BEGIN RETURN x.kind = numLt END isNumLit;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE (x : LeafX)isCharLit*() : BOOLEAN;
+  (** A literal character, or a literal string of length = 1.   *)
+  BEGIN
+    RETURN (x.kind = charLt)
+        OR ((x.kind = strLt) & (x.value.len() = 1));
+  END isCharLit;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE (x : LeafX)isStrLit*() : BOOLEAN;
+  (* If this is a LeafX of string type, it must b a lit-string. *)
+  BEGIN RETURN x.kind = strLt END isStrLit;
+
+(* ==================================================================== *)
+(*      Possible structures of procedure call expressions are:          *)
+(* ==================================================================== *)
+(*                  o                               o                   *)
+(*                 /                               /                    *)
+(*              [CallX]                         [CallX]                 *)
+(*               / +--- actuals --> ...          / +--- actuals --> ... *)
+(*              /                               /                       *)
+(*          [IdentX]                        [IdLeaf]                    *)
+(*            /  +--- ident ---> [PrcId]      +--- ident ---> [PrcId]   *)
+(*           /                                                          *)
+(*       kid expr                                                       *)
+(*                                                                      *)
+(* ==================================================================== *)
+(*  only the right hand side case can be a standard proc or function    *)
+(* ==================================================================== *)
+
+  PROCEDURE (x : IdLeaf)isStdFunc*() : BOOLEAN;
+  BEGIN
+    RETURN (x.ident # NIL)
+         & (x.ident.kind = I.conPrc)
+         & (x.ident(I.PrcId).stdOrd # 0);
+  END isStdFunc;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE (x : IdLeaf)isStdProc*() : BOOLEAN;
+  BEGIN
+    RETURN (x.ident # NIL)
+         & (x.ident.kind = I.conPrc)
+         & (x.ident(I.PrcId).stdOrd # 0);
+  END isStdProc;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE (p : CallX)NoteCall*(s : D.Scope);
+  BEGIN
+    p.kid.NoteCall(s);
+  END NoteCall;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE (p : IdLeaf)NoteCall*(s : D.Scope);
+    VAR proc : I.PrcId;
+  BEGIN
+    IF (p.ident # NIL) &
+       ((p.ident.kind = I.fwdPrc) OR
+        (p.ident.kind = I.conPrc)) THEN
+      proc := p.ident(I.PrcId);
+      IF proc.stdOrd = 0 THEN INCL(proc.pAttr, I.called) END;
+    END;
+  END NoteCall;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE (p : IdentX)NoteCall*(s : D.Scope);
+    VAR proc : I.MthId;
+  BEGIN
+    IF (p.ident # NIL) &
+       ((p.ident.kind = I.fwdMth) OR
+        (p.ident.kind = I.conMth)) THEN
+      proc := p.ident(I.MthId);
+      INCL(proc.pAttr, I.called);
+    END;
+  END NoteCall;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE (x : LeafX)inRangeOf*(dst : D.Type) : BOOLEAN;
+    VAR lVal : LONGINT;
+        cVal : CHAR;
+        sLen : INTEGER;
+        aLen : INTEGER;
+  BEGIN
+    IF x.kind = numLt THEN
+      lVal := x.value.long();
+      IF dst.kind = T.vecTp THEN RETURN TRUE;
+      ELSIF dst.kind = T.arrTp THEN
+        sLen := dst(T.Array).length;
+        RETURN (lVal >= 0) &      (* check open array later *)
+               ((sLen = 0) OR (lVal < sLen))  (* otherwise check now    *)
+      ELSIF dst = Builtin.setTp THEN
+        RETURN (lVal >= 0) & (lVal <= 31);
+      ELSIF ~dst.isNumType() THEN
+        RETURN FALSE;
+      ELSE
+        CASE dst(T.Base).tpOrd OF
+        | T.uBytN : RETURN (lVal >= ORD(MIN(SHORTCHAR))) &
+                           (lVal <= ORD(MAX(SHORTCHAR)));
+        | T.byteN : RETURN (lVal >= MIN(BYTE))   & (lVal <= MAX(BYTE));
+        | T.sIntN : RETURN (lVal >= MIN(SHORTINT)) & (lVal <= MAX(SHORTINT));
+        | T.intN  : RETURN (lVal >= MIN(INTEGER))  & (lVal <= MAX(INTEGER));
+        | T.lIntN : RETURN TRUE;
+        ELSE RETURN FALSE;
+        END
+      END;
+(*
+ *  Changed for 1.2.3.4 to allow S1 to be compat with ARRAY OF CHAR (kjg)
+ *
+ *  ELSIF x.isCharLit() THEN
+ *    IF ~dst.isCharType() THEN
+ *)
+    ELSIF dst.isCharType() THEN
+      IF ~x.isCharLit() THEN
+        RETURN FALSE;
+      ELSE
+        cVal := x.charValue();
+        IF dst(T.Base).tpOrd = T.sChrN THEN
+          RETURN (cVal >= MIN(SHORTCHAR)) & (cVal <= MAX(SHORTCHAR));
+        ELSE
+          RETURN TRUE;
+        END;
+      END;
+(*
+ *  ELSIF x.kind = strLt THEN
+ *    IF ~dst.isCharArrayType() THEN
+ *)
+    ELSIF dst.isCharArrayType() THEN
+      IF x.kind # strLt THEN
+        RETURN FALSE;
+      ELSE
+        aLen := dst(T.Array).length;
+        sLen := x.value.len();
+        RETURN  (aLen = 0) OR   (* lhs is open array, runtime test *)
+                (aLen > sLen);    (* string fits in fixed array OK   *)
+      END;
+    ELSE
+      RETURN FALSE;
+    END;
+  END inRangeOf;
+
+(* ============================================================ *)
+
+  PROCEDURE (x : LeafX)charValue*() : CHAR,NEW;
+  (** A literal character, or a literal string of length = 1.   *)
+    VAR chr : CHAR;
+  BEGIN
+    IF x.kind = charLt THEN
+      chr := x.value.char();
+    ELSE (* x.kind = strLt *)
+      chr := x.value.chr0();
+    END;
+    RETURN chr;
+  END charValue;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE convert(expr : D.Expr; dstT : D.Type) : D.Expr;
+  (* Make permitted base-type coercions explicit in the AST *)
+    VAR rslt : D.Expr;
+        expT : D.Type;
+  BEGIN
+    expT := expr.type;
+    IF  (expT = dstT) OR
+        (dstT.kind # T.basTp) OR
+        (dstT = Builtin.anyPtr) THEN
+      RETURN expr;
+    ELSIF (dstT = Builtin.charTp) & (expT = Builtin.strTp) THEN
+      expr.type := dstT;
+      RETURN expr;
+    END;
+    IF dstT.includes(expr.type) THEN
+      rslt := newIdentX(cvrtUp, dstT.idnt, expr);
+    ELSE
+      rslt := newIdentX(cvrtDn, dstT.idnt, expr);
+    END;
+    rslt.type := dstT;
+    RETURN rslt;
+  END convert;
+
+(* ============================================================ *)
+
+  PROCEDURE FormalsVsActuals*(prcX : D.Expr; actSeq : D.ExprSeq);
+    VAR prcT   : T.Procedure;
+        index  : INTEGER;
+        bound  : INTEGER;
+        frmMod : INTEGER;
+        actual : D.Expr;
+        formal : I.ParId;
+        frmTyp : D.Type;
+        actTyp : D.Type;
+        frmSeq : I.ParSeq;
+        fIsPtr : BOOLEAN;
+
+(* ---------------------------- *)
+
+    PROCEDURE CheckCompatible(frm : D.Idnt; act : D.Expr);
+    BEGIN
+      IF frm.paramCompat(act) OR
+         frm.type.arrayCompat(act.type) THEN (* is OK, skip *)
+      ELSE
+        D.RepTypesErrTok(21, act.type, frm.type, act.token);
+        IF (act.type IS T.Opaque) &
+           (act.type.idnt # NIL) &
+           (act.type.idnt.dfScp # NIL) THEN
+          S.SemError.RepSt1(175,
+                            D.getName.ChPtr(act.type.idnt.dfScp),
+                            act.token.lin, act.token.col);
+        END;
+      END;
+    END CheckCompatible;
+
+(* ---------------------------- *)
+
+    PROCEDURE CheckVarModes(mod : INTEGER; exp : D.Expr);
+
+     (* ---------------------------- *)
+
+      PROCEDURE hasReferenceType(t : D.Type) : BOOLEAN;
+      BEGIN
+        RETURN  (t.kind = T.ptrTp) OR
+                (t.kind = T.recTp) OR
+                (t.kind = T.arrTp) OR
+                (t.kind = T.namTp) OR
+                (t = Builtin.strTp) OR
+                (t = Builtin.anyPtr);
+      END hasReferenceType;
+
+     (* ---------------------------- *)
+
+      PROCEDURE MarkAddrsd(id : D.Idnt);
+      BEGIN
+        WITH id : I.LocId DO INCL(id.locAtt, I.addrsd); ELSE END;
+      END MarkAddrsd;
+
+     (* ---------------------------- *)
+
+    BEGIN (* Assert: mod is IN, OUT, or VAR *)
+      IF mod = D.in THEN      (* IN mode only   *)
+       (*
+        *  Not strictly correct according to the report, but an *
+        *  innocuous extension -- allow literal strings here. *
+        *
+        * IF (exp.type # Builtin.strTp) & ~exp.isVarDesig() THEN
+        *)
+        IF ~exp.isVarDesig() &
+           (exp.type # NIL) & ~hasReferenceType(exp.type) THEN
+          exp.ExprError(174);
+        END;
+      ELSE
+        exp.CheckWriteable();     (* OUT and VAR modes  *)
+        WITH exp : IdLeaf DO MarkAddrsd(exp.ident) ELSE END;
+      END;
+    END CheckVarModes;
+
+(* ---------------------------- *)
+
+  BEGIN
+    prcT := prcX.type(T.Procedure);
+    frmSeq := prcT.formals;
+    bound  := MIN(actSeq.tide, frmSeq.tide) - 1;
+    FOR index := 0 TO bound DO
+      formal := frmSeq.a[index];
+      actual := actSeq.a[index];
+
+     (* compute attributes for the actual param expression *)
+      IF actual # NIL THEN actual := actual.exprAttr() END;
+     (* Now check the semantic rules for conformance *)
+      IF (actual # NIL) &
+         (formal # NIL) &
+         (actual.type # NIL) &
+         (formal.type # NIL) THEN
+        frmTyp := formal.type;
+        actTyp := actual.type;
+
+        IF frmTyp IS T.Procedure THEN
+          formal.IdError(301);
+          IF G.targetIsJVM() THEN formal.IdError(213);
+          ELSIF (frmTyp # actTyp) &
+             ~actual.isProcLit() THEN formal.IdError(191) END;
+        END;
+        IF frmTyp IS T.Opaque THEN
+          formal.type := frmTyp.resolve(1);
+          frmTyp := formal.type;
+        END;
+        frmMod := formal.parMode();
+        fIsPtr := frmTyp.isPointerType();
+        IF (actTyp.kind = T.ptrTp) &
+           ~fIsPtr THEN actual := mkDeref(actual) END;
+        CheckCompatible(formal, actual);
+        IF frmMod # D.val THEN    (* IN, OUT or VAR modes *)
+          CheckVarModes(frmMod, actual);
+          IF (frmMod = D.out) & (actTyp # frmTyp) & actTyp.isDynamicType() THEN
+            D.RepTypesErrTok(306, actTyp, frmTyp, actual.token);
+          END;
+        ELSIF actTyp # frmTyp THEN
+          actual := convert(actual, frmTyp);
+          IF ~frmTyp.valCopyOK() THEN formal.IdError(153) END;
+        END;
+        actSeq.a[index] := actual;
+      END;
+    END;
+    IF frmSeq.tide > actSeq.tide THEN
+      IF actSeq.tide = 0 THEN
+        prcX.ExprError(149);
+      ELSE
+        actSeq.a[actSeq.tide-1].ExprError(22);
+      END;
+    ELSIF actSeq.tide > frmSeq.tide THEN
+      actual := actSeq.a[frmSeq.tide];
+      IF actual # NIL THEN 
+        actSeq.a[frmSeq.tide].ExprError(23);
+      ELSE
+        prcX.ExprError(23);
+      END;
+    END;
+  END FormalsVsActuals;
+
+(* ============================================================ *)
+
+  PROCEDURE AttributePars*(actSeq : D.ExprSeq);
+  VAR actual : D.Expr;
+      index : INTEGER;
+  BEGIN
+    FOR index := 0 TO actSeq.tide-1 DO
+      actual := actSeq.a[index];
+      IF actual # NIL THEN actSeq.a[index] := actual.exprAttr(); END;
+    END;
+  END AttributePars;
+
+(* ============================================================ *)
+
+  PROCEDURE MatchPars*(frmSeq : I.ParSeq; actSeq : D.ExprSeq) : BOOLEAN;
+    VAR
+        index  : INTEGER;
+        actual : D.Expr;
+        formal : I.ParId;
+        frmTyp : D.Type;
+        actTyp : D.Type;
+        fIsPtr : BOOLEAN;
+
+  BEGIN
+    IF (frmSeq.tide # actSeq.tide) THEN RETURN FALSE; END;
+    FOR index := 0 TO frmSeq.tide-1 DO
+      formal := frmSeq.a[index];
+      actual := actSeq.a[index];
+     (* Now check the semantic rules for conformance *)
+      IF (actual # NIL) &
+         (formal # NIL) &
+         (actual.type # NIL) &
+         (formal.type # NIL) THEN
+        IF ~(formal.paramCompat(actual) OR
+             formal.type.arrayCompat(actual.type)) THEN
+          RETURN FALSE;
+        END;
+      ELSE
+        RETURN FALSE;
+      END;
+    END;
+    RETURN TRUE;
+  END MatchPars;
+
+(* ============================================================ *)
+
+  PROCEDURE (p : BinaryX)enterGuard*(tmp : D.Idnt) : D.Idnt;
+    VAR oldI  : D.Idnt;
+        junk  : BOOLEAN;
+        lHash : INTEGER;
+        lQual : IdLeaf;
+        rQual : IdLeaf;
+  BEGIN
+    IF  (p.lKid = NIL) OR
+        ~(p.lKid IS IdLeaf) OR
+        (p.rKid = NIL) OR
+        ~(p.rKid IS IdLeaf) THEN RETURN NIL END;
+
+    lQual := p.lKid(IdLeaf);
+    rQual := p.rKid(IdLeaf);
+    IF (lQual.ident = NIL) OR (rQual.ident = NIL) THEN RETURN NIL END;
+   (*
+    *  We first determine if this is a local variable.
+    *  If it is, we must overwrite this in the local scope
+    *  with the temporary of the guard type.
+    *  If any case, we return the previous local.
+    *)
+    lHash := lQual.ident.hash;
+    tmp.hash := lHash;
+    tmp.type := rQual.ident.type;
+    tmp.SetKind(I.conId);     (* mark immutable *)
+    oldI := tmp.dfScp.symTb.lookup(lHash);
+    IF oldI = NIL THEN (* not local *)
+      junk := tmp.dfScp.symTb.enter(lHash, tmp);
+      ASSERT(junk);
+    ELSE
+      tmp.dfScp.symTb.Overwrite(lHash, tmp);
+    END;
+    RETURN oldI;
+  END enterGuard;
+
+  PROCEDURE (p : BinaryX)ExitGuard*(sav : D.Idnt; tmp : D.Idnt);
+  BEGIN
+    IF tmp.type = NIL THEN RETURN END;
+    IF sav = NIL THEN
+      (* remove tmp from tmp.dfScp.symTb *)
+      tmp.dfScp.symTb.RemoveLeaf(tmp.hash);
+    ELSE
+      (* overwrite with previous value   *)
+      tmp.dfScp.symTb.Overwrite(tmp.hash, sav);
+    END;
+  END ExitGuard;
+
+(* ============================================================ *)
+(*      Diagnostic methods      *)
+(* ============================================================ *)
+
+  PROCEDURE Diag(i : INTEGER; e : D.Expr);
+  BEGIN
+    IF e = NIL THEN
+      H.Indent(i); Console.WriteString("<nil>"); Console.WriteLn;
+    ELSE
+      e.Diagnose(i);
+    END;
+  END Diag;
+
+  (* ------------------------------- *)
+
+  PROCEDURE PType(t : D.Type);
+  BEGIN
+    IF t # NIL THEN
+      Console.WriteString(t.name());
+    ELSE
+      Console.WriteString("<nil>");
+    END;
+  END PType;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE (s : LeafX)Diagnose*(i : INTEGER),EXTENSIBLE;
+    VAR name : FileNames.NameString;
+  BEGIN
+    H.Indent(i);
+    CASE s.kind OF
+    | realLt : Console.WriteString("realLt  ");
+         RTS.RealToStr(s.value.real(), name);
+         Console.WriteString(name$);
+    | numLt  : Console.WriteString("numLt   ");
+         Console.WriteInt(s.value.int(), 0);
+    | charLt : Console.WriteString("charLt  '");
+         Console.Write(s.value.char());
+         Console.Write("'");
+    | strLt  : Console.WriteString("strLt   ");
+         s.value.GetStr(name);
+         Console.Write('"');
+         Console.WriteString(name$);
+         Console.WriteString('" LEN=');
+         Console.WriteInt(s.value.len(),1);
+    | infLt  : Console.WriteString("INF     "); PType(s.type);
+    | nInfLt : Console.WriteString("NEG-INF "); PType(s.type);
+    | nilLt  : Console.WriteString("NIL     "); PType(s.type);
+    | tBool  : Console.WriteString("TRUE    BOOLEAN");
+    | fBool  : Console.WriteString("FALSE   BOOLEAN");
+    ELSE       Console.WriteString("?leaf?  ");
+    END;
+    Console.WriteLn;
+  END Diagnose;
+
+  (* ------------------------------- *)
+
+  PROCEDURE (s : IdLeaf)Diagnose*(i : INTEGER);
+    VAR name : FileNames.NameString;
+  BEGIN
+    H.Indent(i);
+    D.getName.Of(s.ident, name);
+    Console.WriteString(name);
+    Console.Write(':');
+    Console.Write(' ');
+    PType(s.type);
+    Console.WriteLn;
+  END Diagnose;
+
+  (* ------------------------------- *)
+
+  PROCEDURE (s : SetExp)Diagnose*(i : INTEGER);
+    VAR j  : INTEGER;
+        v  : SET;
+        ch : CHAR;
+  BEGIN
+    ch := 0X;
+    H.Indent(i);
+    Console.WriteString("setLt  {");
+    IF s.value # NIL THEN
+      v := s.value.set();
+      FOR j := 0 TO 31 DO
+        IF j IN v THEN ch := '1' ELSE ch := '.' END;
+        Console.Write(ch);
+      END;
+    END;
+    Console.Write("}");
+    IF s.kind = setLt THEN
+      Console.WriteLn;
+    ELSE
+      Console.WriteString(" + "); Console.WriteLn;
+      FOR j := 0 TO s.varSeq.tide - 1 DO
+        Diag(i+4, s.varSeq.a[j]);
+      END;
+    END;
+  END Diagnose;
+
+  (* ------------------------------- *)
+
+  PROCEDURE (s : UnaryX)Diagnose*(i : INTEGER),EXTENSIBLE;
+  BEGIN
+    H.Indent(i);
+    CASE s.kind OF
+    | deref  : Console.WriteString("'^'    ");
+    | compl  : Console.WriteString("compl  ");
+    | sprMrk : Console.WriteString("super  ");
+    | neg    : Console.WriteString("neg    ");
+    | absVl  : Console.WriteString("ABS    ");
+    | entVl  : Console.WriteString("ENTIER ");
+    | capCh  : Console.WriteString("CAP    ");
+    | strLen : Console.WriteString("strLen ");
+    | strChk : Console.WriteString("strChk ");
+    | mkStr  : Console.WriteString("$      ");
+    | tCheck : Console.WriteString("tCheck ");
+               IF s.type # NIL THEN Console.WriteString(s.type.name()) END;
+    END;
+    PType(s.type);
+    Console.WriteLn;
+    Diag(i+4, s.kid);
+  END Diagnose;
+
+  (* ------------------------------- *)
+
+  PROCEDURE (s : IdentX)Diagnose*(i : INTEGER);
+    VAR name : FileNames.NameString;
+  BEGIN
+    H.Indent(i);
+    D.getName.Of(s.ident, name);
+    IF    s.kind = sprMrk THEN Console.WriteString("sprMrk " + name);
+    ELSIF s.kind = cvrtUp THEN Console.WriteString("cvrtUp: " + name);
+    ELSIF s.kind = cvrtDn THEN Console.WriteString("cvrtDn: " + name);
+    ELSE Console.WriteString("selct: " + name);
+    END;
+    Console.Write(' ');
+    PType(s.type);
+    Console.WriteLn;
+    Diag(i+4, s.kid);
+  END Diagnose;
+
+  (* ------------------------------- *)
+
+  PROCEDURE (s : CallX)Diagnose*(i : INTEGER);
+  BEGIN
+    H.Indent(i);
+    IF s.kind = fnCall THEN
+      Console.WriteString("CallX(fn) "); PType(s.type);
+    ELSE
+      Console.WriteString("CallX(pr)");
+    END;
+    Console.WriteLn;
+    Diag(i+4, s.kid);
+  END Diagnose;
+
+  (* ------------------------------- *)
+
+  PROCEDURE (s : BinaryX)Diagnose*(i : INTEGER);
+  BEGIN
+    H.Indent(i);
+    CASE s.kind OF
+    | index  : Console.WriteString("index  ");
+    | range  : Console.WriteString("range  ");
+    | lenOf  : Console.WriteString("lenOf  ");
+    | maxOf  : Console.WriteString("maxOf  ");
+    | minOf  : Console.WriteString("minOf  ");
+    | bitAnd : Console.WriteString("bitAND ");
+    | bitOr  : Console.WriteString("bitOR  ");
+    | bitXor : Console.WriteString("bitXOR ");
+    | plus   : Console.WriteString("'+'    ");
+    | minus  : Console.WriteString("'-'    ");
+    | greT   : Console.WriteString("'>'    ");
+    | greEq  : Console.WriteString("'>='   ");
+    | notEq  : Console.WriteString("'#'    ");
+    | lessEq : Console.WriteString("'<='   ");
+    | lessT  : Console.WriteString("'<'    ");
+    | equal  : Console.WriteString("'='    ");
+    | isOp   : Console.WriteString("IS     ");
+    | inOp   : Console.WriteString("IN     ");
+    | mult   : Console.WriteString("'*'    ");
+    | slash  : Console.WriteString("'/'    ");
+    | modOp  : Console.WriteString("MOD    ");
+    | divOp  : Console.WriteString("DIV    ");
+    | rem0op : Console.WriteString("REM0   ");
+    | div0op : Console.WriteString("DIV0   ");
+    | blNot  : Console.WriteString("'~'    ");
+    | blOr   : Console.WriteString("OR     ");
+    | blAnd  : Console.WriteString("'&'    ");
+    | strCat : Console.WriteString("strCat ");
+    | ashInt : Console.WriteString("ASH    ");
+    END;
+    PType(s.type);
+    Console.WriteLn;
+    Diag(i+4, s.lKid);
+    Diag(i+4, s.rKid);
+  END Diagnose;
+
+(* ============================================================ *)
+BEGIN (* ====================================================== *)
+END ExprDesc.  (* ============================================== *)
+(* ============================================================ *)
+

gpcp/FileNames.cp

@@ -0,0 +1,128 @@
+(* ==================================================================== *)
+(*									*)
+(*  FileNames Module for the Gardens Point Component Pascal Compiler.	*)
+(*	Copyright (c) John Gough 1999, 2000.				*)
+(*									*)
+(* ==================================================================== *)
+
+MODULE FileNames;
+  IMPORT GPFiles;
+
+  TYPE
+	NameString* = ARRAY 128 OF CHAR;
+
+(* ==================================================================== *)
+(*				Utilities				*)
+(* ==================================================================== *)
+
+    PROCEDURE GetBaseName*(IN in : ARRAY OF CHAR; OUT out : ARRAY OF CHAR);
+      VAR sPos : INTEGER;
+	  dPos : INTEGER;
+	  idx  : INTEGER;
+	  chr  : CHAR;
+    BEGIN
+     (* ------------------------- *)
+     (* Index 012...      v--LEN  *)
+     (*       xxxxxxxxxxxx0       *)
+     (*      ^---------------sPos *)
+     (*                   ^--dPos *)
+     (* ------------------------- *)
+     (*           before          *)
+     (* ------------------------- *)
+     (*                           *) 
+     (*       xxx/xxxxx.xx0       *)
+     (*          ^-----------sPos *)
+     (*                ^-----dPos *)
+     (* ------------------------- *)
+     (*           after           *)
+     (* ------------------------- *)
+      sPos := -1;
+      dPos := LEN(in$); 
+      FOR idx := 0 TO dPos DO
+	chr := in[idx];
+	IF chr = '.' THEN 
+	  dPos := idx;
+	ELSIF chr = GPFiles.fileSep THEN 
+	  sPos := idx;
+	END;
+      END;
+      FOR idx := 0 TO dPos-sPos-1 DO
+	out[idx] := in[idx+sPos+1];
+      END;
+      out[dPos-sPos] := 0X;
+    END GetBaseName;
+
+(* ==================================================================== *)
+
+    PROCEDURE StripUpToLast*(mark : CHAR; 
+			 IN  in   : ARRAY OF CHAR;
+			 OUT out  : ARRAY OF CHAR);
+      VAR sPos : INTEGER;
+	  dPos : INTEGER;
+	  idx  : INTEGER;
+	  chr  : CHAR;
+    BEGIN
+     (* ------------------------- *)
+     (* Index 012...      v--LEN  *)
+     (*       xxxxxxxxxxxx0       *)
+     (*      ^---------------sPos *)
+     (*                   ^--dPos *)
+     (* ------------------------- *)
+     (*           before          *)
+     (* ------------------------- *)
+     (*                           *) 
+     (*       xxx!xxxxx.xx0       *)
+     (*          ^-----------sPos *)
+     (*                ^-----dPos *)
+     (* ------------------------- *)
+     (*           after           *)
+     (* ------------------------- *)
+      sPos := -1;
+      dPos := LEN(in$); 
+      FOR idx := 0 TO dPos DO
+	chr := in[idx];
+	IF chr = '.' THEN 
+	  dPos := idx;
+	ELSIF chr = mark THEN 
+	  sPos := idx;
+	END;
+      END;
+      FOR idx := 0 TO dPos-sPos-1 DO
+	out[idx] := in[idx+sPos+1];
+      END;
+      out[dPos-sPos] := 0X;
+    END StripUpToLast;
+
+(* ==================================================================== *)
+
+    PROCEDURE AppendExt*(IN in,ext : ARRAY OF CHAR; OUT out : ARRAY OF CHAR);
+      VAR pos : INTEGER;
+	  idx : INTEGER;
+	  chr : CHAR;
+    BEGIN
+      pos := LEN(in$);
+      FOR idx := 0 TO pos-1 DO out[idx] := in[idx] END;
+      out[pos] := ".";
+      FOR idx := 0 TO LEN(ext$) DO out[idx+pos+1] := ext[idx] END;
+    END AppendExt;
+
+(* ==================================================================== *)
+
+    PROCEDURE StripExt*(IN in : ARRAY OF CHAR; OUT out : ARRAY OF CHAR);
+      VAR pos : INTEGER;
+	  idx : INTEGER;
+	  chr : CHAR;
+    BEGIN
+      pos := LEN(in$);
+      FOR idx := 0 TO pos DO
+	chr := in[idx];
+	IF chr = '.' THEN pos := idx END;
+	out[idx] := chr;
+      END;
+      out[pos] := 0X;
+    END StripExt;
+
+(* ==================================================================== *)
+BEGIN
+END FileNames.
+

gpcp/ForeignName.cp

@@ -0,0 +1,147 @@
+(* ================================================================ *)
+(*                                                                  *)
+(*  Module of the V1.4+ gpcp tool to create symbol files from       *)
+(*  the metadata of .NET assemblies, using the PERWAPI interface.   *)
+(*  Also used in GPCP itself.                                       *)
+(*                                                                  *)
+(*  Copyright K John Gough, QUT 2004 - 2007.                        *)
+(*                                                                  *)
+(*  This code released under the terms of the GPCP licence.         *)
+(*                                                                  *)
+(* ================================================================ *)
+
+MODULE ForeignName;
+  IMPORT GPCPcopyright;
+
+ (* ---------------------------------------------------------- *)
+
+  TYPE  CharOpen* = POINTER TO ARRAY OF CHAR;
+
+ (* ---------------------------------------------------------- *)
+
+  PROCEDURE QuotedName*(asmN, nmsN : CharOpen) : CharOpen;
+  BEGIN
+    IF nmsN = NIL THEN RETURN BOX("[" + asmN^ + "]");
+    ELSE RETURN BOX("[" + asmN^ + "]" + nmsN^);
+    END;
+  END QuotedName;
+
+  PROCEDURE MangledName*(asmN, nmsN : CharOpen) : CharOpen;
+    CONST prefix = 2; equal = 1; unequal = 0;
+    VAR   sNm, aNm : CharOpen;
+   (* ------------------------------------------------ *)
+    PROCEDURE canonEq(l,r : CharOpen) : INTEGER;
+      VAR cl, cr : CHAR; ix : INTEGER;
+    BEGIN
+      ix := 0; cl := l[ix];
+      WHILE cl # 0X DO
+        cr := r[ix];
+        IF CAP(cl) # CAP(cr) THEN RETURN unequal END;
+        INC(ix); cl := l[ix];
+      END;
+      cr := r[ix];
+      IF    cr = 0X  THEN RETURN equal;
+      ELSIF cr = "_" THEN RETURN prefix;
+      ELSE (* -------- *) RETURN unequal;
+      END;
+    END canonEq;
+   (* ------------------------------------------------ *)
+    PROCEDURE canonicalizeId(str : CharOpen) : CharOpen;
+      VAR ix : INTEGER; co : CharOpen; ch : CHAR;
+    BEGIN
+      NEW(co, LEN(str));
+      FOR ix := 0 TO LEN(str)-1 DO 
+        ch := str[ix];
+        IF (ch >= 'a') & (ch <= 'z') OR
+           (ch >= 'A') & (ch <= 'Z') OR
+           (ch >= '0') & (ch <= '9') OR
+           (ch >= 0C0X) & (ch <= 0D6X) OR
+           (ch >= 0D8X) & (ch <= 0F6X) OR
+           (ch >= 0F8X) & (ch <= 0FFX) OR
+           (ch = 0X) THEN (* skip *) ELSE ch := '_' END;
+        co[ix] := ch;
+      END;
+      RETURN co;
+    END canonicalizeId;
+   (* ------------------------------------------------ *)
+    PROCEDURE merge(str : CharOpen; pos : INTEGER) : CharOpen;
+      VAR res : CharOpen;
+          len : INTEGER;
+          idx : INTEGER;
+    BEGIN
+      len := LEN(str);
+      NEW(res, len+1);
+      FOR idx := 0 TO pos-1 DO res[idx] := str[idx] END;
+      res[pos] := "_";
+      FOR idx := pos TO len-1 DO res[idx+1] := str[idx] END;
+      RETURN res;
+    END merge;
+   (* ------------------------------------------------ *)
+  BEGIN
+    aNm := canonicalizeId(asmN);
+    IF (nmsN = NIL) OR (nmsN[0] = 0X) THEN
+     (*
+      *   There is no namespace name, so the CP
+      *   name is "aNm" and the scopeNm is "[asmN]"
+      *) 
+      RETURN aNm;
+    ELSE
+      sNm := canonicalizeId(nmsN);
+      CASE canonEq(aNm, sNm) OF
+      | unequal :
+         (* 
+          *  The CP name is "aNm_sNm"
+          *  and scopeNm is "[asmN]nmsN"
+          *) 
+          RETURN BOX(aNm^ + "_" + sNm^);
+      | equal   :
+         (* 
+          *  The CP name is "sNm_"
+          *  and scopeNm is "[asmN]nmsN"
+          *) 
+          RETURN BOX(sNm^ + "_");
+      | prefix  :
+         (* 
+          *  The CP name is prefix(sNm) + "_" + suffix(sNm)
+          *  and scopeNm is "[asmN]nmsN"
+          *) 
+          RETURN merge(sNm, LEN(aNm$));
+      END;
+    END;
+  END MangledName;
+
+ (* ---------------------------------------------------------- *)
+
+  PROCEDURE ParseModuleString*(str : CharOpen; OUT nam : CharOpen);
+    VAR idx : INTEGER;
+        max : INTEGER;
+        lBr : INTEGER;
+        rBr : INTEGER;
+        chr : CHAR;
+        fNm : CharOpen;
+        cNm : CharOpen;
+  BEGIN
+    lBr := 0; 
+    rBr := 0;
+    max := LEN(str^) - 1;
+    FOR idx := 0 TO max DO
+      chr := str[idx];
+      IF chr = '[' THEN lBr := idx;
+      ELSIF chr = ']' THEN rBr := idx;
+      END;
+    END;
+    IF (lBr = 0) & (rBr > 1) & (rBr < max) THEN
+      NEW(fNm, rBr - lBr);
+      NEW(cNm, max - rBr + 1);
+      FOR idx := 0 TO rBr - lBr - 2 DO fNm[idx] := str[idx + lBr + 1] END;
+      FOR idx := 0 TO max - rBr - 1 DO cNm[idx] := str[idx + rBr + 1] END;
+      nam := MangledName(fNm, cNm);
+    ELSE
+      nam := NIL;
+    END;
+  END ParseModuleString;
+
+ (* ---------------------------------------------------------- *)
+
+END ForeignName.
+

gpcp/GPCPcopyright.cp

@@ -0,0 +1,80 @@
+MODULE GPCPcopyright;
+  IMPORT Console;
+
+  CONST
+     (*	VERSION    = "0.1 of 26 December 1999"; *)
+     (*	VERSION    = "0.2 of 01 March 2000"; *)
+     (*	VERSION    = "0.3 of 22 April 2000"; *)
+     (*	VERSION    = "0.4 of 01 May 2000"; *)
+     (*	VERSION    = "0.5 of 10 June 2000"; *)
+     (*	VERSION    = "0.6 of 17 June 2000"; *)
+     (*	VERSION    = "0.7 of 18 June 2000"; *)
+     (*	VERSION    = "0.8 of 18 July 2000"; *)
+     (*	VERSION    = "0.9 of 27 August 2000"; *)
+     (*	VERSION    = "0.95 of 26 October 2000"; *)
+     (*	VERSION    = "0.96 of 18 November 2000"; *)
+     (*	VERSION    = "1-d of 22 January 2001"; *)
+     (*	VERSION    = "1.0 of 01 June 2001"; *)
+     (*	VERSION    = "1.06 of 25 August 2001"; *)
+     (*	VERSION    = "1.10 of 10 September 2001"; *)
+     (*	VERSION    = "1.1.3 of 26 November 2001"; *)
+     (*	VERSION    = "1.1.4 of 16 January 2002"; *)
+     (*	VERSION    = "1.1.5x of 23 January 2002"; *)
+     (*	VERSION    = "1.1.6 of 28 March 2002"; *)
+     (*	VERSION    = "1.1.6a of 10 May 2002"; *)
+     (*	VERSION    = "1.1.7e of 23 May 2002"; *)
+     (*	VERSION    = "1.2.0 of 12 September 2002"; *)
+     (*	VERSION    = "1.2.1 of 07 October 2002"; *)
+     (*	VERSION    = "1.2.2 of 07 January 2003"; *)
+     (*	VERSION    = "1.2.3 of 01 April 2003"; *)
+     (* VERSION    = "1.2.3.1 of 16 April 2003"; *)
+     (*	VERSION    = "1.2.3.2 of 20 July 2003"; *)
+     (*	VERSION    = "1.2.3.3 of 16 September 2003"; *)
+     (*	VERSION    = "1.2.4   of 26 February 2004"; *)
+     (*	VERSION    = "1.2.x   of June+ 2004"; *)
+     (*	VERSION    = "1.3.0 of 16 September 2004"; *)
+     (*	VERSION    = "1.3.1 of 12 November 2004"; *)
+     (*	VERSION    = "1.3.1.1 of 1 April 2005"; *)
+     (* VERSION    = "1.3.1.2 of 10 April 2005"; *)
+     (* VERSION    = "1.3.2.0 of 1 May 2005"; *)
+     (* VERSION    = "1.3.4 of 20 August 2006"; *)
+     (* VERSION    = "1.3.4e of 7 November 2006"; *)
+     (* VERSION    = "1.3.6 of 1 September 2007"; *)
+     (* VERSION    = "1.3.8 of 18 November 2007"; *)
+     (* VERSION    = "1.3.9 of 15 January 2008"; *)
+        VERSION    = "1.3.10 of 15 November 2010";
+	verStr*    = " version " + VERSION;
+
+  CONST	prefix     = "#gpcp: ";
+	millis     = "mSec";
+
+(* ==================================================================== *)
+  PROCEDURE W(IN s : ARRAY OF CHAR);
+  BEGIN Console.WriteString(s); Console.WriteLn END W;
+
+  PROCEDURE Write*();
+  BEGIN
+    W("GARDENS POINT COMPONENT PASCAL");
+    W("The files which import this module constitute a compiler");
+    W("for the programming language Component Pascal.");
+    W("Copyright (c) 1998 -- 2010 K John Gough.");
+    W("Copyright (c) 2000 -- 2010 Queensland University of Technology.");
+    Console.WriteLn;
+
+    W("This program is free software; you can redistribute it and/or modify");
+    W("it under the terms of the GPCP Copyright as included with this");
+    W("distribution in the root directory.");
+    W("See the file GPCPcopyright.rtf in the 'gpcp' directory for details.");
+    Console.WriteLn;
+
+    W("This program is distributed in the hope that it will be useful,");
+    W("but WITHOUT ANY WARRANTY as is explained in the copyright notice.");
+    Console.WriteLn;
+
+    W("The authoritative version for this program, and all future upgrades");
+    W("is at http://gpcp.codeplex.com. The project page on CodePlex allows");
+    W("discussions, an issue tracker and source code repository");
+    W("The program's news group is GPCP@yahoogroups.com.");
+  END Write;
+
+END GPCPcopyright.

gpcp/GPCPcopyright.rtf

@@ -0,0 +1,47 @@
+{\rtf1\ansi\ansicpg1252\uc1\deff0\stshfdbch0\stshfloch0\stshfhich0\stshfbi0\deflang1033\deflangfe1033{\fonttbl{\f0\froman\fcharset0\fprq2{\*\panose 02020603050405020304}Times New Roman;}{\f1\fswiss\fcharset0\fprq2{\*\panose 020b0604020202020204}Arial;}
+{\f36\froman\fcharset238\fprq2 Times New Roman CE;}{\f37\froman\fcharset204\fprq2 Times New Roman Cyr;}{\f39\froman\fcharset161\fprq2 Times New Roman Greek;}{\f40\froman\fcharset162\fprq2 Times New Roman Tur;}
+{\f41\froman\fcharset177\fprq2 Times New Roman (Hebrew);}{\f42\froman\fcharset178\fprq2 Times New Roman (Arabic);}{\f43\froman\fcharset186\fprq2 Times New Roman Baltic;}{\f44\froman\fcharset163\fprq2 Times New Roman (Vietnamese);}
+{\f46\fswiss\fcharset238\fprq2 Arial CE;}{\f47\fswiss\fcharset204\fprq2 Arial Cyr;}{\f49\fswiss\fcharset161\fprq2 Arial Greek;}{\f50\fswiss\fcharset162\fprq2 Arial Tur;}{\f51\fswiss\fcharset177\fprq2 Arial (Hebrew);}
+{\f52\fswiss\fcharset178\fprq2 Arial (Arabic);}{\f53\fswiss\fcharset186\fprq2 Arial Baltic;}{\f54\fswiss\fcharset163\fprq2 Arial (Vietnamese);}}{\colortbl;\red0\green0\blue0;\red0\green0\blue255;\red0\green255\blue255;\red0\green255\blue0;
+\red255\green0\blue255;\red255\green0\blue0;\red255\green255\blue0;\red255\green255\blue255;\red0\green0\blue128;\red0\green128\blue128;\red0\green128\blue0;\red128\green0\blue128;\red128\green0\blue0;\red128\green128\blue0;\red128\green128\blue128;
+\red192\green192\blue192;}{\stylesheet{\ql \li0\ri0\widctlpar\wrapdefault\aspalpha\aspnum\faauto\adjustright\rin0\lin0\itap0 \fs24\lang1033\langfe1033\cgrid\langnp1033\langfenp1033 \snext0 Normal;}{
+\s1\ql \li0\ri0\sb240\sa60\keepn\widctlpar\wrapdefault\aspalpha\aspnum\faauto\outlinelevel0\adjustright\rin0\lin0\itap0 \b\f1\fs32\lang1033\langfe1033\kerning32\cgrid\langnp1033\langfenp1033 \sbasedon0 \snext0 heading 1;}{\*\cs10 \additive \ssemihidden 
+Default Paragraph Font;}{\*\ts11\tsrowd\trftsWidthB3\trpaddl108\trpaddr108\trpaddfl3\trpaddft3\trpaddfb3\trpaddfr3\trcbpat1\trcfpat1\tblind0\tblindtype3\tscellwidthfts0\tsvertalt\tsbrdrt\tsbrdrl\tsbrdrb\tsbrdrr\tsbrdrdgl\tsbrdrdgr\tsbrdrh\tsbrdrv 
+\ql \li0\ri0\widctlpar\wrapdefault\aspalpha\aspnum\faauto\adjustright\rin0\lin0\itap0 \fs20\lang1024\langfe1024\cgrid\langnp1024\langfenp1024 \snext11 \ssemihidden Normal Table;}}{\*\listtable{\list\listtemplateid-1508889896\listhybrid{\listlevel
+\levelnfc0\levelnfcn0\leveljc0\leveljcn0\levelfollow0\levelstartat1\levelspace360\levelindent0{\leveltext\leveltemplateid67698703\'02\'00.;}{\levelnumbers\'01;}\hres0\chhres0 \fi-360\li720\jclisttab\tx720\lin720 }{\listlevel\levelnfc4\levelnfcn4\leveljc0
+\leveljcn0\levelfollow0\levelstartat1\levelspace360\levelindent0{\leveltext\leveltemplateid67698713\'02\'01.;}{\levelnumbers\'01;}\hres0\chhres0 \fi-360\li1440\jclisttab\tx1440\lin1440 }{\listlevel\levelnfc2\levelnfcn2\leveljc2\leveljcn2\levelfollow0
+\levelstartat1\levelspace360\levelindent0{\leveltext\leveltemplateid67698715\'02\'02.;}{\levelnumbers\'01;}\hres0\chhres0 \fi-180\li2160\jclisttab\tx2160\lin2160 }{\listlevel\levelnfc0\levelnfcn0\leveljc0\leveljcn0\levelfollow0\levelstartat1\levelspace360
+\levelindent0{\leveltext\leveltemplateid67698703\'02\'03.;}{\levelnumbers\'01;}\hres0\chhres0 \fi-360\li2880\jclisttab\tx2880\lin2880 }{\listlevel\levelnfc4\levelnfcn4\leveljc0\leveljcn0\levelfollow0\levelstartat1\levelspace360\levelindent0{\leveltext
+\leveltemplateid67698713\'02\'04.;}{\levelnumbers\'01;}\hres0\chhres0 \fi-360\li3600\jclisttab\tx3600\lin3600 }{\listlevel\levelnfc2\levelnfcn2\leveljc2\leveljcn2\levelfollow0\levelstartat1\levelspace360\levelindent0{\leveltext\leveltemplateid67698715
+\'02\'05.;}{\levelnumbers\'01;}\hres0\chhres0 \fi-180\li4320\jclisttab\tx4320\lin4320 }{\listlevel\levelnfc0\levelnfcn0\leveljc0\leveljcn0\levelfollow0\levelstartat1\levelspace360\levelindent0{\leveltext\leveltemplateid67698703\'02\'06.;}{\levelnumbers
+\'01;}\hres0\chhres0 \fi-360\li5040\jclisttab\tx5040\lin5040 }{\listlevel\levelnfc4\levelnfcn4\leveljc0\leveljcn0\levelfollow0\levelstartat1\levelspace360\levelindent0{\leveltext\leveltemplateid67698713\'02\'07.;}{\levelnumbers\'01;}\hres0\chhres0 
+\fi-360\li5760\jclisttab\tx5760\lin5760 }{\listlevel\levelnfc2\levelnfcn2\leveljc2\leveljcn2\levelfollow0\levelstartat1\levelspace360\levelindent0{\leveltext\leveltemplateid67698715\'02\'08.;}{\levelnumbers\'01;}\hres0\chhres0 \fi-180\li6480
+\jclisttab\tx6480\lin6480 }{\listname ;}\listid1123961876}}{\*\listoverridetable{\listoverride\listid1123961876\listoverridecount0\ls1}}{\*\rsidtbl \rsid30932\rsid9770042}{\*\generator Microsoft Word 10.0.6866;}{\info
+{\title Gardens Point Component Pascal Copyright}{\author gough}{\operator K John Gough}{\creatim\yr2001\mo12\dy17\hr21\min36}{\revtim\yr2010\mo11\dy16\hr18\min55}{\version3}{\edmins16}{\nofpages1}{\nofwords229}{\nofchars1308}
+{\*\company Faculty of Information Technology}{\nofcharsws1534}{\vern16393}{\*\password 00000000}}{\*\xmlnstbl {\xmlns1 urn:schemas-microsoft-com:office:smarttags}}\paperw12240\paperh15840\margl1800\margr1800\margt1440\margb1440\gutter0 
+\widowctrl\ftnbj\aenddoc\grfdocevents0\noxlattoyen\expshrtn\noultrlspc\dntblnsbdb\nospaceforul\formshade\horzdoc\dgmargin\dghspace180\dgvspace180\dghorigin1800\dgvorigin1440\dghshow1\dgvshow1
+\jexpand\viewkind1\viewscale100\pgbrdrhead\pgbrdrfoot\splytwnine\ftnlytwnine\htmautsp\nolnhtadjtbl\useltbaln\alntblind\lytcalctblwd\lyttblrtgr\lnbrkrule\rsidroot9770042 \fet0{\*\wgrffmtfilter 013f}{\*\template 
+C:\\Documents and Settings\\gough\\Application Data\\Microsoft\\Templates\\Normal.dot}\sectd \linex0\endnhere\sectlinegrid360\sectdefaultcl\sftnbj {\*\pnseclvl1\pnucrm\pnstart1\pnindent720\pnhang {\pntxta .}}{\*\pnseclvl2
+\pnucltr\pnstart1\pnindent720\pnhang {\pntxta .}}{\*\pnseclvl3\pndec\pnstart1\pnindent720\pnhang {\pntxta .}}{\*\pnseclvl4\pnlcltr\pnstart1\pnindent720\pnhang {\pntxta )}}{\*\pnseclvl5\pndec\pnstart1\pnindent720\pnhang {\pntxtb (}{\pntxta )}}{\*\pnseclvl6
+\pnlcltr\pnstart1\pnindent720\pnhang {\pntxtb (}{\pntxta )}}{\*\pnseclvl7\pnlcrm\pnstart1\pnindent720\pnhang {\pntxtb (}{\pntxta )}}{\*\pnseclvl8\pnlcltr\pnstart1\pnindent720\pnhang {\pntxtb (}{\pntxta )}}{\*\pnseclvl9\pnlcrm\pnstart1\pnindent720\pnhang 
+{\pntxtb (}{\pntxta )}}\pard\plain \s1\ql \li0\ri0\sb240\sa60\keepn\widctlpar\wrapdefault\aspalpha\aspnum\faauto\outlinelevel0\adjustright\rin0\lin0\itap0 \b\f1\fs32\lang1033\langfe1033\kerning32\cgrid\langnp1033\langfenp1033 {\insrsid9770042 
+Gardens Point Component Pascal Copyright
+\par }\pard\plain \ql \li0\ri0\widctlpar\wrapdefault\aspalpha\aspnum\faauto\adjustright\rin0\lin0\itap0 \fs24\lang1033\langfe1033\cgrid\langnp1033\langfenp1033 {\insrsid9770042 
+\par }{\insrsid30932 Copyright \'a9 1998 \endash  2010}{\insrsid9770042  Queensland {\*\xmlopen\xmlns1{\factoidname place}}{\*\xmlopen\xmlns1{\factoidname PlaceType}}University{\*\xmlclose} of {\*\xmlopen\xmlns1{\factoidname PlaceName}}Technology{\*\xmlclose}
+{\*\xmlclose} (QUT). All rights reserved.
+\par 
+\par Redistribution and use in source and binary forms, with or without modification are permitted provided that the following conditions are met:
+\par 
+\par {\listtext\pard\plain\insrsid9770042 \hich\af0\dbch\af0\loch\f0 1.\tab}}\pard \ql \fi-360\li720\ri0\widctlpar\jclisttab\tx720\wrapdefault\aspalpha\aspnum\faauto\ls1\adjustright\rin0\lin720\itap0 {\insrsid9770042 
+Redistribution of source code must retain the above copyright notice, this list of conditions and the following disclaimer.
+\par {\listtext\pard\plain\insrsid9770042 \hich\af0\dbch\af0\loch\f0 2.\tab}
+Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials with the distribution.
+\par }\pard \ql \li0\ri0\widctlpar\wrapdefault\aspalpha\aspnum\faauto\adjustright\rin0\lin0\itap0 {\insrsid9770042 
+\par THIS SOFTWARE IS PROVIDED BY THE GPCP PROJECT \'93AS IS\rquote  {\*\xmlopen\xmlns1{\factoidname stockticker}}AND{\*\xmlclose} ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO THE IMPLIED WARRANTIES OF MERCHANTABILITY {\*\xmlopen\xmlns1
+{\factoidname stockticker}}AND{\*\xmlclose} FITNESS FOR A PARTICULAR PURPOSE {\*\xmlopen\xmlns1{\factoidname stockticker}}ARE{\*\xmlclose} HEREBY DISCLAIMED. IN NO EVENT SHALL THE GPCP PROJECT OR QUT BE LIABLE FOR ANY DIRECT, INDIREC
+T, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, {\*\xmlopen\xmlns1{\factoidname stockticker}}DATA{\*\xmlclose}
+, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED {\*\xmlopen\xmlns1{\factoidname stockticker}}AND{\*\xmlclose} ON ANY THEORY OF LIABILITY, WHETHER IN CONTR
+ACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+\par 
+\par The views and conclusions contained in the software and documentation are those of the authors and should not be interpreted as representing official policies, either expressed or implied, of the GPCP project or QUT.
+\par }}

gpcp/GPText.cp

@@ -0,0 +1,164 @@
+(* ============================================================ *)
+(* 								*)
+(*	   Gardens Point Component Pascal Library Module.	*)
+(* 	   Copyright (c) K John Gough 1999, 2000		*)
+(*	   Created : 26 December 1999 kjg			*)
+(* 								*)
+(* ============================================================ *)
+MODULE GPText;
+
+  IMPORT 
+	Console,
+	T := GPTextFiles;
+
+  CONST CWd = 24;
+  TYPE	CVS = ARRAY CWd OF CHAR;
+
+  PROCEDURE Write*(f : T.FILE; c : CHAR);
+  (** Write a single character to file f. *)
+  BEGIN
+    T.WriteChar(f,c);
+  END Write;
+
+  PROCEDURE WriteLn*(f : T.FILE);
+  (** Write an end of line to file f. *)
+  BEGIN
+    T.WriteEOL(f);
+  END WriteLn;
+
+  PROCEDURE WriteString*(f : T.FILE; IN s : ARRAY OF CHAR);
+  (** Write a character string to file f. *)
+    VAR l : INTEGER;
+  BEGIN
+    l := LEN(s$);
+    T.WriteNChars(f,s,l);
+  END WriteString;
+
+  PROCEDURE WriteFiller*(f: T.FILE; IN s: ARRAY OF CHAR; c: CHAR; w: INTEGER);
+  (** Write s left-justified in a field of width w, fill with char c. *)
+    VAR l : INTEGER;
+	i : INTEGER;
+  BEGIN
+    l := LEN(s$);
+    IF l < w THEN
+      T.WriteNChars(f,s,l);
+      FOR i := l TO w-1 DO T.WriteChar(f,c) END;
+    ELSE
+      T.WriteNChars(f,s,w);
+    END;
+  END WriteFiller;
+
+  PROCEDURE WriteRight(f : T.FILE; IN arr : CVS; sig,wid : INTEGER);
+    VAR i : INTEGER;
+	high : INTEGER;
+  BEGIN
+    IF wid = 0 THEN 
+      T.WriteChar(f," ");
+    ELSIF sig < wid THEN (* fill *)
+      FOR i := 1 TO wid-sig DO T.WriteChar(f," ") END;
+    END;
+    FOR i := CWd - sig TO CWd-1 DO T.WriteChar(f,arr[i]) END;
+  END WriteRight;
+
+  PROCEDURE FormatL(n : LONGINT; OUT str : CVS; OUT sig : INTEGER);
+    VAR idx : INTEGER;
+        neg : BOOLEAN;
+        big : BOOLEAN;
+  BEGIN
+    big := (n = MIN(LONGINT)); 
+    IF big THEN n := n+1 END; (* boot compiler gets INC(long) wrong! *)
+    neg := (n < 0);
+    IF neg THEN n := -n END; (* MININT is OK! *)
+    idx := CWd;
+    REPEAT
+      DEC(idx);
+      str[idx] := CHR(n MOD 10 + ORD('0')); 
+      n := n DIV 10; 
+    UNTIL n = 0;
+    IF neg THEN DEC(idx); str[idx] := '-' END;
+    IF big THEN str[CWd-1] := CHR(ORD(str[CWd-1]) + 1) END;
+    sig := CWd - idx;
+  END FormatL;
+
+  PROCEDURE FormatI(n : INTEGER; OUT str : CVS; OUT sig : INTEGER);
+    VAR idx : INTEGER;
+        neg : BOOLEAN;
+  BEGIN
+    IF n = MIN(INTEGER) THEN FormatL(n, str, sig); RETURN END;
+    neg := (n < 0);
+    IF neg THEN n := -n END; 
+    idx := CWd;
+    REPEAT
+      DEC(idx);
+      str[idx] := CHR(n MOD 10 + ORD('0')); 
+      n := n DIV 10; 
+    UNTIL n = 0;
+    IF neg THEN DEC(idx); str[idx] := '-' END;
+    sig := CWd - idx;
+  END FormatI;
+
+  PROCEDURE WriteInt*(f : T.FILE; n : INTEGER; w : INTEGER);
+  (** Write an integer to file f to a field of width w; 
+      if w = 0, then leave a space then left justify. *)
+    VAR str : CVS;
+	sig : INTEGER;
+  BEGIN
+    IF w < 0 THEN w := 0 END;
+    FormatI(n, str, sig);
+    WriteRight(f, str, sig, w);
+  END WriteInt;
+
+  PROCEDURE IntToStr*(n : INTEGER; OUT a : ARRAY OF CHAR);
+  (** Format an integer into the character array a. *)
+    VAR str : CVS;
+	idx : INTEGER;
+	sig : INTEGER;
+  BEGIN
+    FormatI(n, str, sig);
+    IF sig < LEN(a) THEN
+      FOR idx := 0 TO sig-1 DO a[idx] := str[CWd-sig+idx] END;
+      a[sig] := 0X;
+    ELSE
+      FOR idx := 0 TO LEN(a) - 2 DO a[idx] := '*' END;
+      a[LEN(a)-1] := 0X;
+    END;
+  END IntToStr;
+
+  PROCEDURE WriteLong*(f : T.FILE; n : LONGINT; w : INTEGER);
+  (** Write an longint to file f to a field of width w; 
+      if w = 0, then leave a space then left justify. *)
+    VAR str : CVS;
+	sig : INTEGER;
+  BEGIN
+    IF w < 0 THEN w := 0 END;
+    FormatL(n, str, sig);
+    WriteRight(f, str, sig, w);
+  END WriteLong;
+
+  PROCEDURE LongToStr*(n : LONGINT; OUT a : ARRAY OF CHAR);
+  (** Format a long integer into the character array a. *)
+    VAR str : CVS;
+	idx : INTEGER;
+	sig : INTEGER;
+  BEGIN
+    FormatL(n, str, sig);
+    IF sig < LEN(a) THEN
+      FOR idx := 0 TO sig-1 DO a[idx] := str[CWd-sig+idx] END;
+      a[sig] := 0X;
+    ELSE
+      FOR idx := 0 TO LEN(a) - 2 DO a[idx] := '*' END;
+      a[LEN(a)-1] := 0X;
+    END;
+  END LongToStr;
+
+  PROCEDURE Assign*(IN r : ARRAY OF CHAR; OUT l : ARRAY OF CHAR);
+    VAR i : INTEGER; lh,rh : INTEGER;
+  BEGIN
+    rh := LEN(r$) - 1;		(* string high-val, not including nul *)
+    lh := LEN(l) - 2;		(* array capacity, with space for nul *)
+    lh := MIN(lh,rh);
+    FOR i := 0 TO lh DO l[i] := r[i] END;
+    l[lh+1] := 0X;
+  END Assign;
+
+END GPText.

gpcp/Hello.cp

@@ -0,0 +1,9 @@
+MODULE Hello;
+  IMPORT CPmain, Console;
+
+  CONST greet = "Hello Beta2 world";
+
+BEGIN
+  Console.WriteString(greet); 
+  Console.WriteLn;
+END Hello.

gpcp/IdDesc.cp

@@ -0,0 +1,1441 @@
+(* ==================================================================== *)
+(*                                                                      *)
+(*  IdDesc Module for the Gardens Point Component Pascal Compiler.      *)
+(*  Implements identifier descriptors that are extensions of            *)
+(*  Symbols.Idnt                                                        *)
+(*                                                                      *)
+(*  Copyright (c) John Gough 1999, 2000.                                *)
+(*                                                                      *)
+(* ==================================================================== *)
+
+MODULE IdDesc;
+
+  IMPORT
+        GPCPcopyright,
+        GPText,
+        Console,
+        V := VarSets,
+        S := CPascalS,
+        D := Symbols,
+        L := LitValue,
+        H := DiagHelper,
+        N := NameHash,
+        FileNames;
+
+(* ============================================================ *)
+
+  CONST (* idnt-kinds *)
+    errId*  = 0;  conId*  = 1;  varId*  = 2;  parId*  = 3;  quaId*  = 4;
+    typId*  = 5;  modId*  = 6;  impId*  = 7;  alias*  = 8;  fldId*  = 9;
+    fwdMth* = 10; conMth* = 11; fwdPrc* = 12; conPrc* = 13; fwdTyp* = 14;
+    ctorP*  = 15;
+
+  CONST (* method attributes *)
+    newBit* = 0;
+    final*  = {};  isNew* = {newBit}; isAbs* = {1};
+    empty*  = {2}; extns* = {1,2};    mask*  = {1,2};
+    covar*  = 3; (* ==> method has covariant type  *)
+    boxRcv* = 4; (* ==> receiver is boxed in .NET  *)
+    widen*  = 5; (* ==> visibility must be widened *)
+                 (* in the runtime representation. *)
+    noCall* = 6; (* ==> method is an override of   *)
+                 (* an implement only method.      *)
+
+  CONST (* procedure and method pAttr attributes *)
+    hasXHR* = 0;        (* ==> has non-locally accessed data  *)
+    assgnd* = 1;        (* ==> is assigned as a proc variable *)
+    called* = 2;        (* ==> is directly called in this mod *)
+    public* = 3;        (* ==> is exported from this module   *)
+    useMsk* = {1,2,3};  (* pAttr*useMsk={} ==> a useless proc *)
+
+(* ============================================================ *)
+
+  TYPE
+    TypId*  = POINTER TO RECORD (D.Idnt)
+             (* ---- ... inherited from Idnt ...  ------- *
+              * kind-  : INTEGER; (* tag for unions *)
+              * token* : Scanner.Token; (* scanner token  *)
+              * type*  : D.Type;  (* typ-desc | NIL *)
+              * hash*  : INTEGER; (* hash bucket no *)
+              * vMod-  : INTEGER; (* visibility tag *)
+              * dfScp* : Scope;   (* defining scope *)
+              * tgXtn* : ANYPTR;
+              * ----------------------------------------- *)
+              END;  (* ------------------------------ *)
+
+(* ============================================================ *)
+
+  TYPE
+    ConId*  = POINTER TO RECORD (D.Idnt)
+             (* ---- ... inherited from Idnt ...  ------- *
+              * kind-  : INTEGER; (* tag for unions *)
+              * token* : Scanner.Token; (* scanner token  *)
+              * type*  : D.Type;  (* typ-desc | NIL *)
+              * hash*  : INTEGER; (* hash bucket no *)
+              * vMod-  : INTEGER; (* visibility tag *)
+              * dfScp* : Scope;   (* defining scope *)
+              * tgXtn* : ANYPTR;
+              * ----------------------------------------- *)
+                recTyp* : D.Type;
+                conExp* : D.Expr;
+                isStd-  : BOOLEAN;  (* false if ~std  *)
+              END;  (* ------------------------------ *)
+
+(* ============================================================ *)
+
+  TYPE
+    AbVar*  = POINTER TO ABSTRACT RECORD (D.Idnt)
+              (* Abstract Variables ... *)
+                varOrd* : INTEGER;  (* local var ord. *)
+              END;
+
+(* ============================================================ *)
+
+  TYPE
+    VarId*  = POINTER TO RECORD (AbVar)
+             (* ---- ... inherited from Idnt ...  ------- *
+              * kind-  : INTEGER;       (* tag for unions *)
+              * token* : Scanner.Token; (* scanner token  *)
+              * type*  : D.Type;        (* typ-desc | NIL *)
+              * hash*  : INTEGER;       (* hash bucket no *)
+              * vMod-  : INTEGER;       (* visibility tag *)
+              * dfScp* : Scope;         (* defining scope *)
+              * tgXtn* : ANYPTR;
+              * ---- ... inherited from AbVar ... ------- *
+              * varOrd* : INTEGER;      (* local var ord. *)
+              * ----------------------------------------- *)
+                recTyp* : D.Type;
+                clsNm*  : L.CharOpen;   (* external name  *)
+                varNm*  : L.CharOpen;   (* external name  *)
+              END;      (* ------------------------------ *)
+
+(* ============================================================ *)
+
+  TYPE
+    FldId*  = POINTER TO RECORD (AbVar)
+             (* ---- ... inherited from Idnt ...  ------- *
+              * kind-  : INTEGER;       (* tag for unions *)
+              * token* : Scanner.Token; (* scanner token  *)
+              * type*  : D.Type;        (* typ-desc | NIL *)
+              * hash*  : INTEGER;       (* hash bucket no *)
+              * vMod-  : INTEGER;       (* visibility tag *)
+              * dfScp* : Scope;         (* defining scope *)
+              * tgXtn* : ANYPTR;
+              * ---- ... inherited from AbVar ... ------- *
+              * varOrd* : INTEGER;      (* local var ord. *)
+              * ----------------------------------------- *)
+                recTyp* : D.Type;
+                fldNm*  : L.CharOpen;   (* external name  *)
+              END;      (* ------------------------------ *)
+
+(* ============================================================ *)
+
+  CONST (* local variable and arg access attribs *)
+    addrsd* = 0;  (* This bit is set if object has adrs taken   *)
+    uplevR* = 1;  (* This bit is set if local is uplevel read   *)
+    uplevW* = 2;  (* This bit set if local is uplevel written   *)
+    uplevA* = 3;  (* This bit is set if Any uplevel access      *)
+    cpVarP* = 4;  (* This bit denotes uplevel access to var-par *)
+    xMark* = -1;  (* varOrd is set to xMark is local is uplevel *)
+                  (* BUT ... not until after flow attribution!  *)
+
+  TYPE
+    LocId*  = POINTER TO EXTENSIBLE RECORD (AbVar)
+             (* NB: LocId sometimes have kind = conId!    *
+              * ---- ... inherited from Idnt ...  ------- *
+              * kind-  : INTEGER;       (* tag for unions *)
+              * token* : D.Token;       (* scanner token  *)
+              * type*  : D.Type;        (* typ-desc | NIL *)
+              * hash*  : INTEGER;       (* hash bucket no *)
+              * vMod-  : INTEGER;       (* visibility tag *)
+              * dfScp* : Scope;         (* defining scope *)
+              * tgXtn* : ANYPTR;
+              * ---- ... inherited from AbVar ... ------- *
+              * varOrd* : INTEGER;      (* local var ord. *)
+              * ----------------------------------------- *)
+                locAtt* : SET;
+                boxOrd* : INTEGER;      (* if boxd in RTS *)
+              END;      (* ------------------------------ *)
+
+(* ============================================================ *)
+
+  TYPE
+    ParId*  = POINTER TO RECORD (LocId)
+             (* ---- ... inherited from Idnt ...  ------- *
+              * kind-  : INTEGER;       (* tag for unions *)
+              * token* : Scanner.Token; (* scanner token  *)
+              * type*  : D.Type;        (* typ-desc | NIL *)
+              * hash*  : INTEGER;       (* hash bucket no *)
+              * vMod-  : INTEGER;       (* visibility tag *)
+              * dfScp* : Scope;         (* defining scope *)
+              * tgXtn* : ANYPTR;
+              * ---- ... inherited from AbVar ... ------- *
+              * varOrd* : INTEGER;      (* local var ord. *)
+              * ---- ... inherited from LocId ... ------- *
+              * locAtt* : SET;   
+              * boxOrd* : INTEGER;      (* if boxd in RTS *)
+              * ----------------------------------------- *)
+                parMod* : INTEGER;      (* parameter mode *)
+                isRcv*  : BOOLEAN;      (* this is "this" *)
+                rtsTmp* : INTEGER;      (* caller box ref *)
+                rtsSrc* : VarId;        (* used for quasi *)
+              END;      (* ------------------------------ *)
+
+    ParSeq* = RECORD
+                tide-, high : INTEGER;
+                a- : POINTER TO ARRAY OF ParId;
+              END;
+
+(* ============================================================ *)
+
+  TYPE
+    BaseCall* = POINTER TO RECORD
+                  actuals* : D.ExprSeq;
+                  sprCtor* : Procs;
+                  empty*   : BOOLEAN;
+                END;
+
+(* ============================================================ *)
+
+  TYPE
+    Procs*  = POINTER TO ABSTRACT RECORD (D.Scope)
+             (* ---- ... inherited from Idnt ...  ------- *
+              * kind-  : INTEGER; (* tag for unions *)
+              * token* : Scanner.Token; (* scanner token  *)
+              * type*  : D.Type;  (* typ-desc | NIL *)
+              * hash*  : INTEGER; (* hash bucket no *)
+              * vMod-  : INTEGER; (* visibility tag *)
+              * dfScp* : Scope;   (* defining scope *)
+              * tgXtn* : ANYPTR;
+              * ---- ... inherited from Scope ...  ------ *
+              * symTb*   : SymbolTable; (* symbol scope   *)
+              * endDecl* : BOOLEAN; (* can't add more *)
+              * ovfChk*  : BOOLEAN; (* check overflow *)
+              * locals*  : IdSeq; (* varId sequence *)
+              * scopeNm* : L.CharOpen;  (* external name  *)
+              * ----------------------------------------- *)
+                prcNm*   : L.CharOpen;  (* external name  *)
+                body*    : D.Stmt;      (* procedure-code *)
+                except*  : LocId;       (* except-object  *)
+                rescue*  : D.Stmt;      (* except-handler *)
+                resolve* : Procs;       (* fwd resolution *)
+                rtsFram* : INTEGER;     (* RTS local size *)
+                nestPs*  : PrcSeq;      (* local proclist *)
+                pAttr*   : SET;         (* procAttributes *)
+                lxDepth* : INTEGER;     (* lexical depth  *)
+                bndType* : D.Type;      (* bound RecTp    *)
+                xhrType* : D.Type;      (* XHR rec. type  *)
+                basCll*  : BaseCall;    (* for ctors only *)
+                endSpan* : S.Span;    (* END ident span *)
+              END;      (* ------------------------------ *)
+
+    PrcSeq*  = RECORD
+                tide-, high : INTEGER;
+                a- : POINTER TO ARRAY OF Procs;
+              END;
+
+    PrcId*  = POINTER TO EXTENSIBLE RECORD (Procs)
+                clsNm*  : L.CharOpen;   (* external name  *)
+                stdOrd* : INTEGER;
+              END;      (* ------------------------------ *)
+
+    MthId*  = POINTER TO RECORD (Procs)
+                mthAtt*  : SET;         (* mth attributes *)
+                rcvFrm*  : ParId;       (* receiver frmal *)
+              END;      (* ------------------------------ *)
+
+(* ============================================================ *)
+
+   (* ------------------------------------------------------- *
+    *  OvlIds do not occur in pure Component Pascal.  They    *
+    *  appear transiently as descriptors of identifiers that  *
+    *  are bound to overloaded names from foreign libraries.  *
+    * ------------------------------------------------------- *)
+    OvlId*  = POINTER TO RECORD (D.Idnt)
+                list* : PrcSeq;
+                rec*  : D.Type;
+                fld*  : D.Idnt;
+              END;
+
+(* ============================================================ *)
+
+  TYPE
+    BlkId*  = POINTER TO RECORD (D.Scope)
+             (* ---- ... inherited from Idnt ...  ------- *
+              * kind-  : INTEGER;       (* tag for unions *)
+              * token* : Scanner.Token; (* scanner token  *)
+              * type*  : D.Type;        (* typ-desc | NIL *)
+              * hash*  : INTEGER;       (* hash bucket no *)
+              * vMod-  : INTEGER;       (* visibility tag *)
+              * dfScp* : D.Scope;       (* defining scope *)
+              * tgXtn* : ANYPTR;
+              * ---- ... inherited from Scope ...  ------ *
+              * symTb*   : SymbolTable; (* symbol scope   *)
+              * endDecl* : BOOLEAN;     (* can't add more *)
+              * ovfChk*  : BOOLEAN;     (* check overflow *)
+              * locals*  : IdSeq;       (* varId sequence *)
+              * scopeNm* : L.CharOpen   (* external name  *)
+              * ----------------------------------------- *)
+                modBody*  : D.Stmt;     (* mod init-stmts *)
+                modClose* : D.Stmt;     (* mod finaliz'n  *)
+                impOrd*   : INTEGER;    (* implement ord. *)
+                modKey*   : INTEGER;    (* module magicNm *)
+                main*     : BOOLEAN;    (* module is main *)
+                procs*    : PrcSeq;     (* local proclist *)
+                expRecs*  : D.TypeSeq;  (* exported recs. *)
+                xAttr*    : SET;        (* external types *)
+                xName*    : L.CharOpen; (* ext module nam *)
+                pkgNm*    : L.CharOpen; (* package name   *)
+                clsNm*    : L.CharOpen; (* dummy class nm *)
+                verNm*    : POINTER TO ARRAY 6 OF INTEGER;
+                begTok*   : S.Token; 
+                endTok*   : S.Token;
+              END;      (* ------------------------------ *)
+
+(* ============================================================ *)
+(*               Append for the PrcSeq, ParSeq types.   *)
+(* ============================================================ *)
+
+  PROCEDURE InitPrcSeq*(VAR seq : PrcSeq; capacity : INTEGER);
+  BEGIN
+    NEW(seq.a, capacity); seq.tide := 0; seq.high := capacity-1;
+  END InitPrcSeq;
+
+  PROCEDURE ResetPrcSeq*(VAR seq : PrcSeq);
+  BEGIN
+    seq.tide := 0;
+    IF seq.a = NIL THEN InitPrcSeq(seq, 2) END;
+    seq.a[0] := NIL;
+  END ResetPrcSeq;
+
+  PROCEDURE AppendProc*(VAR seq : PrcSeq; elem : Procs);
+    VAR temp : POINTER TO ARRAY OF Procs;
+        i    : INTEGER;
+  BEGIN
+    IF seq.a = NIL THEN
+      InitPrcSeq(seq, 2);
+    ELSIF seq.tide > seq.high THEN (* must expand *)
+      temp := seq.a;
+      seq.high := seq.high * 2 + 1;
+      NEW(seq.a, (seq.high+1));
+      FOR i := 0 TO seq.tide-1 DO seq.a[i] := temp[i] END;
+    END;
+    seq.a[seq.tide] := elem; INC(seq.tide);
+  END AppendProc;
+
+  PROCEDURE RemoveProc*(VAR seq : PrcSeq; elemPos : INTEGER);
+  VAR
+    ix : INTEGER;
+  BEGIN
+    FOR ix := elemPos TO seq.tide-2 DO
+      seq.a[ix] := seq.a[ix+1];
+    END;
+    DEC(seq.tide);
+  END RemoveProc;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE InitParSeq*(VAR seq : ParSeq; capacity : INTEGER);
+  BEGIN
+    NEW(seq.a, capacity); seq.tide := 0; seq.high := capacity-1;
+  END InitParSeq;
+
+  PROCEDURE ResetParSeq*(VAR seq : ParSeq);
+  BEGIN
+    seq.tide := 0;
+    IF seq.a = NIL THEN InitParSeq(seq, 2) END;
+    seq.a[0] := NIL;
+  END ResetParSeq;
+
+  PROCEDURE AppendParam*(VAR seq : ParSeq; elem : ParId);
+    VAR temp : POINTER TO ARRAY OF ParId;
+        i    : INTEGER;
+  BEGIN
+    IF seq.a = NIL THEN
+      InitParSeq(seq, 2);
+    ELSIF seq.tide > seq.high THEN (* must expand *)
+      temp := seq.a;
+      seq.high := seq.high * 2 + 1;
+      NEW(seq.a, (seq.high+1));
+      FOR i := 0 TO seq.tide-1 DO seq.a[i] := temp[i] END;
+    END;
+    seq.a[seq.tide] := elem; INC(seq.tide);
+  END AppendParam;
+
+(* ============================================================ *)
+(*        Predicate implementations     *)
+(* ============================================================ *)
+
+  PROCEDURE (s : AbVar)mutable*() : BOOLEAN,EXTENSIBLE;
+  (** Determine if this variable is mutable in this scope.  *
+   *  Overrides mutable() for Symbols.Idnt      *)
+  BEGIN
+    IF s.kind = conId THEN RETURN FALSE;
+    ELSE RETURN (s.vMod = D.pubMode)  (* public vars are RW *)
+             OR (s.vMod = D.protect)  (* bad access caught elsewhere *)
+             OR ((s.dfScp # NIL)      (* or scope not import  *)
+                & (s.dfScp.kind # impId)
+                & (s.dfScp.kind # alias));
+    END;
+  END mutable;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE (s : AbVar)CheckMutable*(x : D.Expr),EXTENSIBLE;
+  (** Determine if this variable is mutable in this scope.  *
+   *  Overrides CheckMutable() for Symbols.Idnt     *)
+  BEGIN
+    IF s.kind = conId THEN x.ExprError(180) END;
+    IF ~((s.vMod = D.pubMode)   (* public vars are RW *)
+        OR ((s.dfScp # NIL)     (* or scope not import  *)
+              & (s.dfScp.kind # impId)
+              & (s.dfScp.kind # alias))) THEN x.ExprError(180);
+    END;
+  END CheckMutable;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE (s : ParId)mutable*() : BOOLEAN;
+  (** Determine if this variable is mutable in this scope.  *
+   *  Overrides mutable() for IdDesc.AbVar      *)
+  BEGIN
+    RETURN (s.parMod # D.in)    (* ok if param not IN *)
+  END mutable;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE (s : ParId)CheckMutable*(x : D.Expr);
+  (** Determine if this variable is mutable in this scope.  *
+   *  Overrides CheckMutable() for IdDesc.AbVar     *)
+  BEGIN
+    IF s.parMod = D.in THEN x.ExprError(179) END;
+  END CheckMutable;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE (s : BlkId)isImport*() : BOOLEAN;
+  (** Determine if this block is an module-import descriptor. *
+   *  Overrides isImport() for Symbols.Scope.     *)
+  BEGIN RETURN s.kind # modId END isImport;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE (s : BlkId)isWeak*() : BOOLEAN;
+  (** Determine if this block is an indirect module-import. *
+   *  Overrides isWeak() for Symbols.Scope.     *)
+  BEGIN RETURN D.weak IN s.xAttr END isWeak;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE (s : AbVar)isStatic*() : BOOLEAN;
+  (** Determine if this variable is a static variable.    *
+   *  Overrides isStatic() for Symbols.Idnt.      *)
+  BEGIN
+    RETURN (s.dfScp # NIL)    (* Var is static iff: *)
+         & (s.dfScp IS BlkId);    (* parent is a BlkId.   *)
+  END isStatic;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE (s : Procs)isStatic*() : BOOLEAN;
+  (** Determine if this procedure is a static procedure.  *
+   *  Overrides isStatic() for Symbols.Idnt.      *)
+  BEGIN
+    RETURN (s.kind = conPrc)    (* Proc is static iff:  *)
+        OR (s.kind = fwdPrc);   (* it is not a method.  *)
+  END isStatic;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE (s : LocId)isLocalVar*() : BOOLEAN;
+  (** Determine if this variable is a local var or parameter.   *
+   *  Overrides isLocalVar() for Symbols.Idnt.                  *
+   *
+   *  This predicate is called by JavaMaker.  It should return  *
+   *  FALSE if the variable is in an XHR (non-locally accessed)   *)
+  BEGIN
+    RETURN ~(uplevA IN s.locAtt);
+  (*
+    RETURN TRUE;
+   *)
+  END isLocalVar;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE (s : AbVar)isDynamic*() : BOOLEAN,EXTENSIBLE;
+  (** Determine if this variable is of dynamic type.    *
+   *  A variable is dynamic if it is a pointer to a record. *
+   *  Overrides isDynamic() for Symbols.Idnt.     *)
+  BEGIN
+    RETURN (s.type # NIL) & s.type.isDynamicType();
+  END isDynamic;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE (s : ParId)isDynamic*() : BOOLEAN;
+  (** Determine if this parameter is of dynamic type.   *
+   *  A parameter is dynamic if it is a pointer to a record,  *
+   *  OR if it is a VAR or IN parameter of record type.   *
+   *  Overrides isDynamic() for IdDesc.AbVar.     *)
+    VAR sTp : D.Type;
+  BEGIN
+    sTp := s.type;
+    IF sTp # NIL THEN
+      RETURN sTp.isDynamicType()
+          OR sTp.isRecordType() & ((s.parMod = D.var) OR (s.parMod = D.in));
+    END;
+    RETURN FALSE;
+  END isDynamic;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE (s : MthId)isAbstract*() : BOOLEAN;
+  (** Determine if this method is an abstract method.   *
+   *  Overrides isAbstract() for Symbols.IdDesc.    *)
+  BEGIN
+    RETURN s.mthAtt * mask = isAbs;
+  END isAbstract;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE (s : MthId)isImported*() : BOOLEAN;
+   (*  Overrides isImported() for Symbols.IdDesc.   *)
+  BEGIN
+    RETURN (s.bndType # NIL) & s.bndType.isImportedType();
+  END isImported;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE (s : MthId)callForbidden*() : BOOLEAN,NEW;
+   (*
+    *  A call is forbidden if
+    *  (1) this is an override of an implement-only method
+    *  (2) this is an imported, implement-only method
+    *)
+  BEGIN
+    RETURN (noCall IN s.mthAtt) OR
+           (s.vMod = D.rdoMode) & s.bndType.isImportedType();
+  END callForbidden;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE (s : MthId)isEmpty*() : BOOLEAN;
+  (** Determine if this method is an abstract method.   *
+   *  Overrides isEmpty() for Symbols.IdDesc.     *)
+    VAR set : SET;
+  BEGIN
+    set := s.mthAtt * mask;
+    RETURN (set = empty) OR (set = isAbs);
+  END isEmpty;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE (s : PrcId)isEmpty*() : BOOLEAN,EXTENSIBLE;
+  (** Determine if this procedure is a .ctor method.    *
+   *  Overrides isEmpty() for Symbols.IdDesc.     *)
+  BEGIN
+    RETURN (s.kind = ctorP) & 
+           ((s.basCll = NIL) OR s.basCll.empty);
+  END isEmpty;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE (s : ParId)parMode*() : INTEGER;
+  (** Return the parameter mode.    *
+   *  Overrides pMode() for Symbols.IdDesc. *)
+  BEGIN
+    RETURN s.parMod;
+  END parMode;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE (s : LocId)isIn*(set : V.VarSet) : BOOLEAN;
+  (** Determine if this variable is in this live set.   *
+   *  Overrides isIn() for Symbols.IdDesc.              *)
+  BEGIN 
+    RETURN set.includes(s.varOrd);
+  END isIn;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE (id : OvlId)findProc*(p : Procs) : Procs, NEW;
+  VAR
+    index : INTEGER;
+  BEGIN
+    ASSERT(id.hash = p.hash);
+    FOR index := 0 TO id.list.tide-1 DO
+      IF p.type.sigsMatch(id.list.a[index].type) THEN
+        RETURN id.list.a[index];
+      END;
+    END;
+    RETURN NIL;
+  END findProc;
+
+(* ============================================================ *)
+(*     Constructor procedures for Subtypes    *)
+(* ============================================================ *)
+
+  PROCEDURE newConId*() : ConId;
+    VAR rslt : ConId;
+  BEGIN
+    NEW(rslt);
+    rslt.isStd := FALSE;
+    rslt.SetKind(conId);
+    RETURN rslt;
+  END newConId;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE newTypId*(type : D.Type) : TypId;
+    VAR rslt : TypId;
+  BEGIN
+    NEW(rslt);
+    rslt.type  := type;
+    rslt.SetKind(typId);
+    RETURN rslt;
+  END newTypId;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE newDerefId*(ptrId : D.Idnt) : TypId;
+    VAR rslt : TypId;
+  BEGIN
+    rslt := newTypId(NIL);
+(*
+ *  rslt.hash  := N.enterStr(N.charOpenOfHash(ptrId.hash)^ + '^');
+ *)
+    rslt.hash  := ptrId.hash;
+    rslt.dfScp := ptrId.dfScp;
+    RETURN rslt;
+  END newDerefId;
+
+
+(* -------------------------------------------- *)
+
+  PROCEDURE newAnonId*(ord : INTEGER) : TypId;
+    VAR rslt : TypId;
+        iStr : ARRAY 16 OF CHAR;
+  BEGIN
+    rslt := newTypId(NIL);
+    GPText.IntToStr(ord, iStr);
+    rslt.hash  := N.enterStr(D.anonMrk + iStr);
+    RETURN rslt;
+  END newAnonId;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE newSfAnonId*(ord : INTEGER) : TypId;
+    VAR rslt : TypId;
+        iStr : ARRAY 16 OF CHAR;
+  BEGIN
+    rslt := newTypId(NIL);
+    GPText.IntToStr(ord, iStr);
+    rslt.hash  := N.enterStr("__t" + iStr);
+    RETURN rslt;
+  END newSfAnonId;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE newVarId*() : VarId;
+    VAR rslt : VarId;
+  BEGIN
+    NEW(rslt); rslt.SetKind(varId); RETURN rslt;
+  END newVarId;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE newLocId*() : LocId;
+    VAR rslt : LocId;
+  BEGIN
+    NEW(rslt); rslt.SetKind(varId); RETURN rslt;
+  END newLocId;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE newFldId*() : FldId;
+    VAR rslt : FldId;
+  BEGIN
+    NEW(rslt); rslt.SetKind(fldId); RETURN rslt;
+  END newFldId;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE newParId*() : ParId;
+    VAR rslt : ParId;
+  BEGIN
+    NEW(rslt); rslt.SetKind(parId); RETURN rslt;
+  END newParId;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE newQuaId*() : ParId;
+    VAR rslt : ParId;
+  BEGIN
+    NEW(rslt); rslt.SetKind(quaId); RETURN rslt;
+  END newQuaId;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE newOvlId*() : OvlId;
+    VAR rslt : OvlId;
+  BEGIN
+    NEW(rslt);
+    rslt.SetKind(errId);
+    InitPrcSeq(rslt.list, 2);
+    RETURN rslt;
+  END newOvlId;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE newPrcId*() : PrcId;
+    VAR rslt : PrcId;
+  BEGIN
+    NEW(rslt);
+    rslt.SetKind(errId);
+    rslt.stdOrd := 0;
+    RETURN rslt;
+  END newPrcId;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE newMthId*() : MthId;
+    VAR rslt : MthId;
+  BEGIN
+    NEW(rslt);
+    rslt.SetKind(errId);
+    rslt.mthAtt := {};
+    RETURN rslt;
+  END newMthId;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE newImpId*() : BlkId;
+    VAR rslt : BlkId;
+  BEGIN
+    NEW(rslt);
+    INCL(rslt.xAttr, D.weak);
+    rslt.SetKind(impId);
+    RETURN rslt;
+  END newImpId;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE newAlias*() : BlkId;
+    VAR rslt : BlkId;
+  BEGIN
+    NEW(rslt); rslt.SetKind(alias); RETURN rslt;
+  END newAlias;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE newModId*() : BlkId;
+    VAR rslt : BlkId;
+  BEGIN
+    NEW(rslt); rslt.SetKind(modId); RETURN rslt;
+  END newModId;
+
+(* ============================================================ *)
+(*    Set procedures for ReadOnly fields    *)
+(* ============================================================ *)
+
+  PROCEDURE (c : ConId)SetStd*(),NEW;
+  BEGIN
+    c.isStd := TRUE;
+  END SetStd;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE (c : PrcId)SetOrd*(n : INTEGER),NEW;
+  BEGIN
+    c.stdOrd := n;
+  END SetOrd;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE (p : Procs)setPrcKind*(kind : INTEGER),NEW;
+  BEGIN
+    ASSERT((kind = conMth) OR (kind = conPrc) OR
+           (kind = fwdMth) OR (kind = fwdPrc) OR
+           (kind = ctorP));
+    p.SetKind(kind);
+  END setPrcKind;
+
+(* ============================================================ *)
+(*   Methods on PrcId type, for procedure/method entry. *)
+(* ============================================================ *)
+
+  PROCEDURE (desc : Procs)CheckElab*(fwd : D.Idnt),NEW,EMPTY;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE (desc : PrcId)CheckElab*(fwd : D.Idnt);
+    VAR fwdD : PrcId;
+  BEGIN
+    fwdD := fwd(PrcId);
+    IF (fwdD.type # NIL) & (desc.type # NIL) THEN
+      IF ~desc.type.procMatch(fwdD.type) THEN
+        desc.IdError(65);
+      ELSIF ~desc.type.namesMatch(fwdD.type) THEN
+        desc.IdError(70);
+      ELSIF fwdD.pAttr * useMsk # {} THEN
+        desc.pAttr := desc.pAttr + fwdD.pAttr;
+      END;
+      IF desc.vMod = D.prvMode THEN desc.SetMode(fwd.vMod) END; (* copy *)
+      fwdD.resolve := desc;
+      (* ### *)
+      fwdD.type := desc.type;
+    END;
+  END CheckElab;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE (desc : MthId)CheckElab*(fwd : D.Idnt);
+    VAR fwdD : MthId;
+  BEGIN
+    fwdD := fwd(MthId);
+    IF desc.mthAtt # fwdD.mthAtt THEN desc.IdError(66) END;
+    IF (desc.rcvFrm # NIL) & (fwdD.rcvFrm # NIL) THEN
+      IF desc.rcvFrm.parMod # fwdD.rcvFrm.parMod THEN desc.IdError(64) END;
+      IF desc.rcvFrm.hash   # fwdD.rcvFrm.hash   THEN desc.IdError(65) END;
+      IF desc.rcvFrm.type   # fwdD.rcvFrm.type   THEN desc.IdError(70) END;
+    END;
+    IF (fwdD.type # NIL) & (desc.type # NIL) THEN
+      IF ~desc.type.procMatch(fwdD.type) THEN
+        desc.IdError(65);
+      ELSIF ~desc.type.namesMatch(fwdD.type) THEN
+        desc.IdError(70);
+      ELSIF fwdD.pAttr * useMsk # {} THEN
+        desc.pAttr := desc.pAttr + fwdD.pAttr;
+      END;
+      IF desc.vMod = D.prvMode THEN desc.SetMode(fwd.vMod) END; (* copy *)
+      fwdD.resolve := desc;
+      (* ### *)
+      fwdD.type := desc.type;
+    END;
+  END CheckElab;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE (desc : Procs)EnterProc*(rcv : ParId; scp : D.Scope),NEW,EMPTY;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE (desc : PrcId)EnterProc*(rcv : ParId; scp : D.Scope);
+    VAR fwd : D.Idnt;
+  BEGIN
+    ASSERT(rcv = NIL);
+    IF D.refused(desc, scp) THEN
+      fwd := scp.symTb.lookup(desc.hash);
+      IF fwd.kind = fwdPrc THEN (* check the elaboration *)
+        desc.CheckElab(fwd);
+        scp.symTb.Overwrite(desc.hash, desc);
+      ELSIF fwd.kind = fwdMth THEN
+        fwd.IdError(62);
+      ELSE
+        desc.IdError(4);
+      END;
+    ELSE
+    END;
+  END EnterProc;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE (desc : MthId)EnterProc*(rcv : ParId; scp : D.Scope);
+    VAR fwd : D.Idnt;
+        rTp : D.Type;
+  BEGIN
+    rTp := NIL;
+    ASSERT(rcv # NIL);
+    IF desc.dfScp.kind # modId THEN
+       desc.IdError(122); RETURN;     (* PREMATURE RETURN *)
+    END;
+    IF rcv.isDynamic() THEN
+      rTp := rcv.type.boundRecTp();
+      IF (rcv.parMod # D.val) & rcv.type.isPointerType() THEN
+        rcv.IdError(206); RETURN;     (* PREMATURE RETURN *)
+      ELSIF rTp.isImportedType() THEN
+        rcv.IdErrorStr(205, rTp.name()); RETURN;  (* PREMATURE RETURN *)
+      END;
+    ELSIF (rcv.type # NIL) & rcv.type.isRecordType() THEN
+      desc.IdError(107); RETURN;      (* PREMATURE RETURN *)
+    ELSE
+      desc.IdError(104); RETURN;      (* PREMATURE RETURN *)
+    END;
+    IF rTp # NIL THEN       (* insert in rec. scope *)
+      rTp.InsertMethod(desc);
+      desc.bndType := rTp;
+    END;
+  END EnterProc;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE (desc : Procs)MethodAttr(),NEW,EMPTY;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE (mDesc : MthId)MethodAttr();
+    VAR rcvTp : D.Type;
+        bndTp : D.Type;
+        inhId : D.Idnt;
+        prevM : MthId;
+        mMask, pMask : SET;
+  BEGIN
+    bndTp := mDesc.bndType;
+    rcvTp := mDesc.rcvFrm.type;
+    mMask := mDesc.mthAtt * mask;
+    IF (mMask # isAbs) & bndTp.isInterfaceType() THEN
+      mDesc.IdError(188); RETURN;
+    END;
+   (*
+    *  Check #1: is there an equally named method inherited?
+    *)
+    inhId := bndTp.inheritedFeature(mDesc);
+   (*
+    *  Check #2: are the method attributes consistent
+    *)
+    IF inhId = NIL THEN
+     (*
+      *  2.0 If not an override, then must be NEW
+      *)
+      IF ~(newBit IN mDesc.mthAtt) THEN mDesc.IdError(105);
+      ELSIF (rcvTp.idnt.vMod = D.prvMode) &
+            (mDesc.vMod = D.pubMode) THEN mDesc.IdError(195);
+      END;
+    ELSIF inhId.kind = conMth THEN
+      prevM := inhId(MthId);
+      pMask := prevM.mthAtt * mask;
+     (*
+      *  2.1 Formals must match, with retType covariant maybe
+      *)
+      prevM.type.CheckCovariance(mDesc);
+     (*
+      *  2.2 If an override, then must not be NEW
+      *)
+      IF newBit IN mDesc.mthAtt THEN mDesc.IdError(106) END;
+     (*
+      *  2.3 Super method must be extensible
+      *)
+      IF pMask = final THEN mDesc.IdError(108) END;
+     (*
+      *  2.4 If this is abstract, so must be the super method
+      *)
+      IF (mMask = isAbs) & (pMask # isAbs) THEN mDesc.IdError(109) END;
+     (*
+      *  2.5 If empty, the super method must be abstract or empty
+      *)
+      IF (mMask = empty) &
+         (pMask # isAbs) & (pMask # empty) THEN mDesc.IdError(112) END;
+     (*
+      *  2.6 If inherited method is exported, then so must this method
+      *)
+
+     (*
+      *  Not clear about the semantics here.  The ComPlus2 VOS
+      *  (and the JVM) rejects redefined methods that try to 
+      *  limit access, even if the receiver is not public.
+      *
+      *  It would be possible to only reject cases where the 
+      *  receiver is exported, and then secretly mark the method
+      *  definition in the IL as public after all ...
+      *                                      (kjg 17-Dec-2001)
+      *  ... and this is the implemented semantics from gpcp 1.1.5
+      *                                      (kjg 10-Jan-2002)
+      *)
+      IF (prevM.vMod = D.pubMode) &
+         (mDesc.vMod # D.pubMode) THEN 
+        IF rcvTp.idnt.vMod = D.pubMode THEN
+          mDesc.IdError(113);
+        ELSE
+          INCL(mDesc.mthAtt, widen);
+        END; 
+      ELSIF (prevM.vMod = D.rdoMode) &
+            (mDesc.vMod # D.rdoMode) THEN 
+        IF rcvTp.idnt.vMod = D.pubMode THEN
+          mDesc.IdError(223);
+        ELSIF rcvTp.idnt.vMod = D.prvMode THEN
+          INCL(mDesc.mthAtt, widen);
+        END; 
+      END;
+     (*
+      *  If inherited method is overloaded, then so must this be.
+      *)
+      IF prevM.prcNm # NIL THEN mDesc.prcNm := prevM.prcNm END;
+    ELSE
+      mDesc.IdError(4);
+    END;
+    IF (mMask = isAbs) & ~bndTp.isAbsRecType() THEN
+     (*
+      *  Check #3: if method is abstract bndTp must be abstract
+      *)
+      rcvTp.TypeError(110);
+    ELSIF mMask = empty THEN
+     (*
+      *  Check #4: if method is empty then no-ret and no OUTpars
+      *)
+      mDesc.type.CheckEmptyOK();
+      IF (newBit IN mDesc.mthAtt) & ~bndTp.isExtnRecType() THEN
+       (*
+        *  Check #5: if mth is empty and new, rcv must be extensible
+        *)
+        rcvTp.TypeError(111);
+      END;
+    ELSIF (mMask = extns) & ~bndTp.isExtnRecType() THEN
+     (*
+      *  Check #6: if mth is ext. rcv must be abs. or extensible
+      *)
+      S.SemError.RepSt1(117,
+                        D.getName.ChPtr(rcvTp.idnt),
+                        mDesc.token.lin, mDesc.token.col);
+    END;
+  END MethodAttr;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE (desc : Procs)retTypBound*() : D.Type,NEW,EXTENSIBLE;
+  BEGIN RETURN NIL END retTypBound;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE (mDesc : MthId)retTypBound*() : D.Type;
+    VAR bndTp : D.Type;
+        prevM : MthId;
+  BEGIN
+    bndTp := mDesc.bndType;
+    prevM := bndTp.inheritedFeature(mDesc)(MthId);
+    IF covar IN prevM.mthAtt THEN
+      RETURN prevM.retTypBound();
+    ELSE
+      RETURN prevM.type.returnType();
+    END;
+  END retTypBound;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE (prc : Procs)RetCheck(fin : V.VarSet; eNm : INTEGER),NEW;
+  BEGIN
+    IF ~prc.type.isProperProcType() & (* ==> function procedure *)
+       ~prc.isAbstract() &    (* ==> concrete procedure *)
+       ~fin.isUniv() THEN   (* ==> flow missed RETURN *)
+      prc.IdError(136);
+      prc.IdError(eNm);
+    END;
+  END RetCheck;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE (var : AbVar)VarInit(ini : V.VarSet),NEW;
+  BEGIN
+    WITH var : ParId DO
+        IF (var.parMod # D.out) OR
+           ~var.type.isScalarType() THEN ini.Incl(var.varOrd) END;
+    | var : LocId DO
+        IF ~var.type.isScalarType() THEN ini.Incl(var.varOrd) END;
+    | var : VarId DO
+        IF ~var.type.isScalarType() THEN ini.Incl(var.varOrd) END;
+    ELSE
+    END;
+  END VarInit;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE (mod : BlkId)LiveInitialize*(ini : V.VarSet);
+    VAR var : D.Idnt;
+        ix  : INTEGER;
+  BEGIN
+    (* initialize the local vars *)
+    FOR ix := 0 TO mod.locals.tide-1 DO
+      var := mod.locals.a[ix];
+      var(AbVar).VarInit(ini);
+    END;
+  END LiveInitialize;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE (prc : Procs)LiveInitialize*(ini : V.VarSet);
+    VAR var : D.Idnt;
+        ix  : INTEGER;
+  BEGIN
+    (* [initialize the receiver] *)
+    (* initialize the parameters *)
+    (* initialize the quasi-pars *)
+    (* initialize the local vars *)
+    FOR ix := 0 TO prc.locals.tide-1 DO
+      var := prc.locals.a[ix];
+      var(AbVar).VarInit(ini);
+    END;
+  END LiveInitialize;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE (prc : Procs)UplevelInitialize*(ini : V.VarSet);
+    VAR var : LocId;
+        ix  : INTEGER;
+  BEGIN
+    FOR ix := 0 TO prc.locals.tide-1 DO
+     (*  
+      *  If we were setting uplevR and uplevW separately, we
+      *  could be less conservative and test uplevW only.
+      *)
+      var := prc.locals.a[ix](LocId);
+      IF uplevA IN var.locAtt THEN ini.Incl(var.varOrd) END;
+    END;
+  END UplevelInitialize;
+
+(* ============================================================ *)
+(*    Methods on BlkId type, for mainline computation *)
+(* ============================================================ *)
+
+  PROCEDURE (b : BlkId)EmitCode*(),NEW;
+  BEGIN
+  END EmitCode;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE (b : BlkId)TypeErasure*(sfa : D.SymForAll), NEW;
+    VAR prcIx : INTEGER;
+        iDesc : D.Idnt;
+        pDesc : Procs;
+  BEGIN
+    FOR prcIx := 0 TO b.procs.tide - 1 DO
+      iDesc := b.procs.a[prcIx];
+      pDesc := iDesc(Procs);
+      IF (pDesc.kind # fwdPrc) &
+         (pDesc.kind # fwdMth) &
+         (pDesc.body # NIL)    THEN
+        IF pDesc.body # NIL THEN pDesc.body.TypeErase(pDesc) END;
+        IF pDesc.rescue # NIL THEN pDesc.rescue.TypeErase(pDesc) END;
+      END;
+    END;
+    IF b.modBody  # NIL THEN b.modBody.TypeErase(b) END;
+    IF b.modClose # NIL THEN b.modClose.TypeErase(b) END;
+    (* Erase types in the symbol table *)
+    b.symTb.Apply(sfa);
+  END TypeErasure;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE (b : BlkId)StatementAttribution*(sfa : D.SymForAll),NEW;
+    VAR prcIx : INTEGER;
+        iDesc : D.Idnt;
+        pDesc : Procs;
+        bType : D.Type;
+        dName : L.CharOpen;
+   (* ---------------------------------------- *)
+    PROCEDURE parentIsCalled(mthd : MthId) : BOOLEAN;
+      VAR prId : D.Idnt;
+    BEGIN
+     (*
+      *  Invariant : ~(called IN mthd.pAttr)
+      *)
+      LOOP
+        IF newBit IN mthd.mthAtt THEN RETURN FALSE;
+        ELSE
+          prId := mthd.bndType.inheritedFeature(mthd);
+         (* This next can never be true for correct programs *)
+          IF prId = NIL THEN RETURN FALSE END;
+          mthd := prId(MthId);
+          IF prId.isImported() OR
+             (mthd.pAttr * useMsk # {}) THEN RETURN TRUE END;
+        END;
+      END;
+    END parentIsCalled;
+   (* ---------------------------------------- *)
+  BEGIN
+    FOR prcIx := 0 TO b.procs.tide - 1 DO
+      iDesc := b.procs.a[prcIx];
+      pDesc := iDesc(Procs);
+      IF (pDesc.kind = fwdPrc) OR (pDesc.kind = fwdMth) THEN
+        IF pDesc.resolve = NIL THEN pDesc.IdError(72) END;
+      ELSIF pDesc.kind = ctorP THEN
+        bType := pDesc.type.returnType();
+        IF bType # NIL THEN bType := bType.boundRecTp() END;
+        IF bType = NIL THEN
+          pDesc.IdError(201);
+        ELSIF bType.isImportedType() THEN
+          pDesc.IdError(200);
+        ELSE (* remainder of semantic checks in AppendCtor *)
+          bType.AppendCtor(pDesc);
+        END;
+      ELSE
+        IF pDesc.kind = conMth THEN pDesc.MethodAttr() END;
+        IF pDesc.body # NIL THEN pDesc.body.StmtAttr(pDesc) END;;
+        IF pDesc.rescue # NIL THEN pDesc.rescue.StmtAttr(pDesc) END;;
+       (*
+        *  Now we generate warnings for useless procedures.
+        *)
+        IF pDesc.pAttr * useMsk = {} THEN
+          WITH pDesc : MthId DO
+           (*
+            *  The test here is tricky: if an overridden
+            *  method is called, then this method might
+            *  be dynamically dispatched.  We check this.
+            *)
+            IF ~parentIsCalled(pDesc) THEN pDesc.IdError(304) END;
+          ELSE
+           (*
+            *  On the other hand, if it is static, not exported
+            *  and is not called then it definitely is useless.
+            *)
+            pDesc.IdError(304);
+          END;
+        END;
+      END;
+    END;
+    b.symTb.Apply(sfa);
+   (*
+    *  Now we must check if the synthetic static class
+    *  in the .NET version will have a name clash with
+    *  any other symbol in the assembly.
+    *  If so, we must mangle the explicit name.
+    *)  
+    IF D.trgtNET & 
+       ~(D.rtsMd IN b.xAttr) &
+       (b.symTb.lookup(b.hash) # NIL) THEN
+      dName := D.getName.ChPtr(b);
+      b.scopeNm := LitValue.strToCharOpen("[" + dName^ + "]" + dName^);
+      b.hash := N.enterStr("__" + dName^);
+      S.SemError.RepSt1(308, D.getName.ChPtr(b), b.token.lin, b.token.col);
+    END;
+    IF b.modBody  # NIL THEN b.modBody.StmtAttr(b) END;
+    IF b.modClose # NIL THEN b.modClose.StmtAttr(b) END;
+  END StatementAttribution;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE (b : BlkId)DataflowAttribution*(),NEW;
+    VAR prcIx : INTEGER;
+        iDesc : D.Idnt;
+        pDesc : Procs;
+        initL : V.VarSet;
+  BEGIN
+   (*
+    *  Fix up the modes of quasi parameters here ...
+    *)
+
+   (*
+    *  Now do dataflow analysis on each procedure ...
+    *)
+    FOR prcIx := 0 TO b.procs.tide - 1 DO
+      iDesc := b.procs.a[prcIx];
+      pDesc := iDesc(Procs);
+      IF (pDesc.kind # fwdPrc) &
+         (pDesc.kind # fwdMth) &
+         (pDesc.body # NIL)    THEN
+       (*
+        *  We do flow analysis even if there are no local
+        *  variables, in order to diagnose paths that miss
+        *  RETURN in function procedures.
+        *
+        *  Note that we throw an extra, dummy variable into
+        *  the set so that the RetCheck will always have a
+        *  missing local if there has been no return stmt.
+        *)
+        initL := V.newSet(pDesc.locals.tide+1);
+        pDesc.LiveInitialize(initL);
+        initL := pDesc.body.flowAttr(pDesc, initL);
+        pDesc.RetCheck(initL, 136);
+        pDesc.type.OutCheck(initL);
+        IF (pDesc.rescue # NIL) THEN
+          initL := V.newSet(pDesc.locals.tide+1);
+          pDesc.LiveInitialize(initL);
+          initL.Incl(pDesc.except.varOrd);
+          initL := pDesc.rescue.flowAttr(pDesc, initL);
+          pDesc.RetCheck(initL, 138);
+          pDesc.type.OutCheck(initL);
+        END;
+      END;
+    END;
+    initL := V.newSet(b.locals.tide);
+    b.LiveInitialize(initL);
+    IF b.modBody  # NIL THEN initL := b.modBody.flowAttr(b, initL) END;
+    IF b.modClose # NIL THEN initL := b.modClose.flowAttr(b, initL) END;
+  END DataflowAttribution;
+
+(* ============================================================ *)
+(*      Diagnostic methods      *)
+(* ============================================================ *)
+
+  PROCEDURE PType(t : D.Type);
+  BEGIN
+    IF t # NIL THEN Console.WriteString(t.name()) END;
+  END PType;
+
+  (* ------------------------------- *)
+
+  PROCEDURE KType*(i : INTEGER);
+  BEGIN
+    CASE i OF
+    | errId   : Console.WriteString("errId  ");
+    | conId   : Console.WriteString("conId  ");
+    | varId   : Console.WriteString("varId  ");
+    | parId   : Console.WriteString("parId  ");
+    | quaId   : Console.WriteString("quaId  ");
+    | typId   : Console.WriteString("typId  ");
+    | modId   : Console.WriteString("modId  ");
+    | impId   : Console.WriteString("impId  ");
+    | alias   : Console.WriteString("alias  ");
+    | fldId   : Console.WriteString("fldId  ");
+    | fwdMth  : Console.WriteString("fwdMth ");
+    | conMth  : Console.WriteString("conMth ");
+    | fwdPrc  : Console.WriteString("fwdPrc ");
+    | conPrc  : Console.WriteString("conPrc ");
+    | fwdTyp  : Console.WriteString("fwdTyp ");
+    | ctorP   : Console.WriteString("ctorP  ");
+    ELSE Console.WriteString("ERROR ");
+    END;
+  END KType;
+
+  (* ------------------------------- *)
+
+  PROCEDURE (s : ConId)Diagnose*(i : INTEGER);
+  BEGIN
+    s.SuperDiag(i);
+    H.Indent(i+2); KType(s.kind); Console.WriteLn;
+    IF s.conExp # NIL THEN s.conExp.Diagnose(i+4) END;
+  END Diagnose;
+
+  PROCEDURE (s : FldId)Diagnose*(i : INTEGER);
+  BEGIN
+    s.SuperDiag(i);
+    H.Indent(i+2); KType(s.kind);
+    IF s.type # NIL THEN PType(s.type) END;
+    Console.WriteLn;
+  END Diagnose;
+
+  PROCEDURE (s : TypId)Diagnose*(i : INTEGER);
+  BEGIN
+    s.SuperDiag(i);
+    H.Indent(i+2); KType(s.kind);
+    IF s.type # NIL THEN
+      PType(s.type); Console.WriteLn;
+      s.type.SuperDiag(i+2);
+    END;
+    Console.WriteLn;
+  END Diagnose;
+
+  PROCEDURE (s : AbVar)Diagnose*(i : INTEGER),EXTENSIBLE;
+  BEGIN
+    s.SuperDiag(i);
+    H.Indent(i+2); KType(s.kind);
+    IF s.type # NIL THEN PType(s.type) END;
+    Console.WriteLn;
+  END Diagnose;
+
+  PROCEDURE (s : ParId)Diagnose*(i : INTEGER);
+  BEGIN
+    s.SuperDiag(i);
+    H.Indent(i+2); KType(s.kind);
+    IF s.type # NIL THEN PType(s.type) END;
+    Console.WriteLn;
+  END Diagnose;
+
+  PROCEDURE (s : ParId)DiagPar*(),NEW;
+    VAR str : L.CharOpen;
+  BEGIN
+    Console.WriteString(D.modStr[s.parMod]);
+    str := D.getName.ChPtr(s);
+    IF str # NIL THEN
+      Console.WriteString(str);
+    ELSE
+      Console.WriteString("(p#");
+      Console.WriteInt(s.varOrd,1);
+      Console.Write(")");
+    END;
+    Console.WriteString(" : ");
+    Console.WriteString(s.type.name());
+  END DiagPar;
+
+  PROCEDURE (s : LocId)DiagVar*(),NEW;
+  BEGIN
+    Console.WriteString(D.getName.ChPtr(s));
+    Console.WriteString(" (#");
+    Console.WriteInt(s.varOrd,1);
+    Console.Write(")");
+    Console.WriteString(" : ");
+    Console.WriteString(s.type.name());
+    Console.Write(";");
+  END DiagVar;
+
+  PROCEDURE (s : Procs)DiagVars(i : INTEGER),NEW;
+    VAR var : D.Idnt;
+        ix  : INTEGER;
+  BEGIN
+    H.Indent(i); Console.Write("{");
+    IF s.locals.tide = 0 THEN
+      Console.Write("}");
+    ELSE
+      Console.WriteLn;
+      FOR ix := 0 TO s.locals.tide-1 DO
+        H.Indent(i+4);
+        var := s.locals.a[ix];
+        var(LocId).DiagVar();
+        Console.WriteLn;
+      END;
+      H.Indent(i); Console.Write("}");
+    END;
+    Console.WriteLn;
+  END DiagVars;
+
+  PROCEDURE (s : PrcId)Diagnose*(i : INTEGER);
+  BEGIN
+    H.Indent(i); Console.WriteString("PROCEDURE");
+    IF s.kind = fwdPrc THEN Console.Write("^") END;
+    Console.Write(" ");
+    Console.WriteString(D.getName.ChPtr(s));
+    s.type.DiagFormalType(i+4);
+    IF s.kind = ctorP THEN Console.WriteString(",CONSTRUCTOR") END;
+    Console.WriteLn;
+    s.DiagVars(i);
+    D.DoXName(i, s.prcNm);
+    D.DoXName(i, s.clsNm);
+    D.DoXName(i, s.scopeNm);
+  END Diagnose;
+
+  PROCEDURE (s : MthId)Diagnose*(i : INTEGER);
+  BEGIN
+    H.Indent(i); Console.WriteString("PROCEDURE");
+    IF s.kind = fwdMth THEN Console.Write("^") END;
+    Console.Write(" ");
+    Console.Write("(");
+    s.rcvFrm.DiagPar();
+    Console.Write(")");
+    Console.WriteString(D.getName.ChPtr(s));
+    s.type.DiagFormalType(i+4);
+    Console.WriteLn;
+    s.DiagVars(i);
+    D.DoXName(i, s.prcNm);
+  END Diagnose;
+
+  PROCEDURE (s : OvlId)Diagnose*(i : INTEGER);
+  VAR
+    index : INTEGER;
+  BEGIN
+    H.Indent(i); Console.WriteString("OVERLOADED PROCS with name <");
+    Console.WriteString(D.getName.ChPtr(s));
+    Console.WriteString(">");
+    Console.WriteLn;
+    FOR index := 0 TO s.list.tide-1 DO
+      s.list.a[index].Diagnose(i+2);
+    END;
+    H.Indent(i); Console.WriteString("END OVERLOADED PROCS with name ");
+    Console.WriteString(D.getName.ChPtr(s));
+    Console.WriteString(">");
+    Console.WriteLn;
+  END Diagnose;
+
+  PROCEDURE (s : BlkId)Diagnose*(i : INTEGER);
+  BEGIN
+    s.SuperDiag(i);
+    H.Indent(i+2); KType(s.kind);
+    IF D.weak IN s.xAttr THEN Console.WriteString(" (weak)") END;
+    Console.WriteLn;
+    s.symTb.Dump(i+4);
+    D.DoXName(i, s.scopeNm);
+    D.DoXName(i, s.xName);
+  END Diagnose;
+
+(* ============================================================ *)
+BEGIN (* ====================================================== *)
+END IdDesc.   (* ============================================== *)
+(* ============================================================ *)
+

gpcp/IlasmCodes.cp

@@ -0,0 +1,1029 @@
+(* ============================================================ *)
+(*  IlasmCodes is the module which defines ilasm name ordinals. *)
+(*  Name spelling is defined by the lexical rules of ILASM.	*)
+(*  Copyright (c) John Gough 1999, 2000.			*)
+(* ============================================================ *)
+
+MODULE IlasmCodes;
+IMPORT
+        GPCPcopyright;
+
+(* ============================================================ *)
+
+  CONST
+        dot_error*     = 0;
+        dot_try*       = 1;
+        dot_class*     = 2;
+        dot_entrypoint*= 3;
+        dot_field*     = 4;
+        dot_implements*= 5;
+        dot_interface* = 6;
+        dot_locals*    = 7;
+        dot_line*      = 8;
+        dot_method*    = 9;
+        dot_source*    = 10;
+        dot_super*     = 11;
+        dot_throws*    = 12;
+        dot_var*       = 13;
+        dot_assembly*  = 14;
+        dot_namespace* = 15;
+        dot_maxstack*  = 16;
+
+  CONST
+        att_empty*       = {};
+        att_public*      = {0};
+        att_private*     = {1};
+        att_assembly*    = {2};
+        att_protected*   = {3};
+        att_value*       = {4};
+        att_static*      = {5};
+        att_final*       = {6};
+        att_sealed*      = {7};
+        att_abstract*    = {8};
+        att_newslot*     = {9};
+        att_interface*   = {10};
+        att_synchronized*= {11};
+        att_extern*      = {12};
+        att_virtual*     = {13};
+        att_instance*    = {14};
+        att_volatile*    = {15};
+	maxAttIndex*     = 15;
+
+  CONST modAttr* = att_public + att_sealed (* + att_abstract *);
+
+(* ============================================================ *)
+
+  CONST
+	opc_error*		= 0;		(* Start opcodes with *)
+	opc_add*		= 1;		(* no arguments...    *)
+	opc_add_ovf*		= 2;
+	opc_add_ovf_un*		= 3;
+	opc_and*		= 4;
+
+	opc_arglist*		= 9;
+	opc_break*		= 10;
+	opc_ceq*		= 11;
+	opc_cgt*		= 12;
+	opc_cgt_un*		= 13;
+	opc_ckfinite*		= 14;
+	opc_clt*		= 15;
+	opc_clt_un*		= 16;
+	opc_conv_i*		= 17;
+	opc_conv_i1*		= 18;
+	opc_conv_i2*		= 19;
+	opc_conv_i4*		= 20;
+	opc_conv_i8*		= 21;
+	opc_conv_ovf_i*		= 22;
+	opc_conv_ovf_i_un*	= 23;
+	opc_conv_ovf_i1*	= 24;
+	opc_conv_ovf_i1_un*	= 25;
+	opc_conv_ovf_i2*	= 26;
+	opc_conv_ovf_i2_un*	= 27;
+	opc_conv_ovf_i4*	= 28;
+	opc_conv_ovf_i4_un*	= 29;
+	opc_conv_ovf_i8*	= 30;
+	opc_conv_ovf_i8_un*	= 31;
+	opc_conv_ovf_u*		= 32;
+	opc_conv_ovf_u_un*	= 32;
+	opc_conv_ovf_u1*	= 34;
+	opc_conv_ovf_u1_un*	= 35;
+	opc_conv_ovf_u2*	= 36;
+	opc_conv_ovf_u2_un*	= 37;
+	opc_conv_ovf_u4*	= 38;
+	opc_conv_ovf_u4_un*	= 39;
+	opc_conv_ovf_u8*	= 40;
+	opc_conv_ovf_u8_un*	= 41;
+	opc_conv_r4*		= 42;
+	opc_conv_r8*		= 43;
+	opc_conv_u*		= 44;
+	opc_conv_u1*		= 45;
+	opc_conv_u2*		= 46;
+	opc_conv_u4*		= 47;
+	opc_conv_u8*		= 48;
+	opc_cpblk*		= 49;
+	opc_div*		= 50;
+	opc_div_un*		= 51;
+	opc_dup*		= 52;
+	opc_endcatch*		= 53;
+	opc_endfilter*		= 54;
+	opc_endfinally*		= 55;
+	opc_initblk*		= 56;
+	opc_jmpi*		= 57;
+	opc_ldarg_0*		= 58;
+	opc_ldarg_1*		= 59;
+	opc_ldarg_2*		= 60;
+	opc_ldarg_3*		= 61;
+	opc_ldc_i4_0*		= 62;
+	opc_ldc_i4_1*		= 63;
+	opc_ldc_i4_2*		= 64;
+	opc_ldc_i4_3*		= 65;
+	opc_ldc_i4_4*		= 66;
+	opc_ldc_i4_5*		= 67;
+	opc_ldc_i4_6*		= 68;
+	opc_ldc_i4_7*		= 69;
+	opc_ldc_i4_8*		= 70;
+	opc_ldc_i4_M1*		= 71;
+	opc_ldelem_i*		= 72;
+	opc_ldelem_i1*		= 73;
+	opc_ldelem_i2*		= 74;
+	opc_ldelem_i4*		= 75;
+	opc_ldelem_i8*		= 76;
+	opc_ldelem_r4*		= 77;
+	opc_ldelem_r8*		= 78;
+	opc_ldelem_ref*		= 79;
+	opc_ldelem_u*		= 80;
+	opc_ldelem_u1*		= 81;
+	opc_ldelem_u2*		= 82;
+	opc_ldelem_u4*		= 83;
+	opc_ldind_i*		= 84;
+	opc_ldind_i1*		= 85;
+	opc_ldind_i2*		= 86;
+	opc_ldind_i4*		= 87;
+	opc_ldind_i8*		= 88;
+	opc_ldind_r4*		= 89;
+	opc_ldind_r8*		= 90;
+	opc_ldind_ref*		= 91;
+	opc_ldind_u*		= 92;
+	opc_ldind_u1*		= 93;
+	opc_ldind_u2*		= 94;
+	opc_ldind_u4*		= 95;
+	opc_ldlen*		= 96;
+	opc_ldloc_0*		= 97;
+	opc_ldloc_1*		= 98;
+	opc_ldloc_2*		= 99;
+	opc_ldloc_3*		= 100;
+	opc_ldnull*		= 101;
+	opc_localloc*		= 102;
+	opc_mul*		= 103;
+	opc_mul_ovf*		= 104;
+	opc_mul_ovf_un*		= 105;
+	opc_neg*		= 106;
+	opc_nop*		= 107;
+	opc_not*		= 108;
+	opc_or*			= 109;
+	opc_pop*		= 110;
+	opc_refanytype*		= 111;
+	opc_rem*		= 112;
+	opc_rem_un*		= 113;
+	opc_ret*		= 114;
+	opc_rethrow*		= 115;
+	opc_shl*		= 116;
+	opc_shr*		= 117;
+	opc_shr_un*		= 118;
+	opc_stelem_i*		= 119;
+	opc_stelem_i1*		= 120;
+	opc_stelem_i2*		= 121;
+	opc_stelem_i4*		= 122;
+	opc_stelem_i8*		= 123;
+	opc_stelem_r4*		= 124;
+	opc_stelem_r8*		= 125;
+	opc_stelem_ref*		= 126;
+	opc_stind_i*		= 127;
+	opc_stind_i1*		= 128;
+	opc_stind_i2*		= 129;
+	opc_stind_i4*		= 130;
+	opc_stind_i8*		= 131;
+	opc_stind_r4*		= 132;
+	opc_stind_r8*		= 133;
+	opc_stind_ref*		= 134;
+	opc_stloc_0*		= 135;
+	opc_stloc_1*		= 136;
+	opc_stloc_2*		= 137;
+	opc_stloc_3*		= 138;
+	opc_sub*		= 139;
+	opc_sub_ovf*		= 140;
+	opc_sub_ovf_un*		= 141;
+	opc_tailcall*		= 142;
+	opc_throw*		= 143;
+	opc_volatile*		= 144;
+	opc_xor*		= 145;
+(*
+ *)
+	opc_ldarg*		= 151;
+	opc_ldarg_s*		= 152;
+	opc_ldarga*		= 153;
+	opc_ldarga_s*		= 154;
+	opc_starg*		= 155;
+	opc_starg_s*		= 156;
+	opc_ldloc*		= 225;		(* oops! *)
+	opc_ldloc_s*		= 226;		(* oops! *)
+	opc_ldloca*		= 227;		(* oops! *)
+	opc_ldloca_s*		= 228;		(* oops! *)
+	opc_stloc*		= 157;
+	opc_stloc_s*		= 158;
+
+	opc_ldc_i4*		= 159;		(* Opcodes with i4 arg. *)
+	opc_unaligned_*		= 160;
+	opc_ldc_i4_s*		= 161;
+	opc_ldc_i8*		= 162;		(* Opcodes with i8 arg. *)
+	opc_ldc_r4*		= 163;		(* Opcodes with flt/dbl *)
+	opc_ldc_r8*		= 164;
+(*
+ *)
+	opc_beq*		= 166;
+	opc_beq_s*		= 167;
+	opc_bge*		= 168;
+	opc_bge_s*		= 169;
+	opc_bge_un*		= 170;
+	opc_bge_un_s*		= 171;
+	opc_bgt*		= 172;
+	opc_bgt_s*		= 173;
+	opc_bgt_un*		= 174;
+	opc_bgt_un_s*		= 175;
+	opc_ble*		= 176;
+	opc_ble_s*		= 177;
+	opc_ble_un*		=   5;
+	opc_ble_un_s*		=   6;
+	opc_blt*		= 178;
+	opc_blt_s*		= 179;
+	opc_blt_un*		= 180;
+	opc_blt_un_s*		= 181;
+	opc_bne_un*		= 182;
+	opc_bne_un_s*		= 183;
+	opc_br*			= 184;
+	opc_br_s*		= 185;
+	opc_brfalse*		= 186;
+	opc_brfalse_s*		= 187;
+	opc_brtrue*		= 188;
+	opc_brtrue_s*		= 189;
+	opc_leave*		= 190;
+(*
+ *	opc_leave_s*		= 191;
+ *
+ *)
+	opc_call*		= 194;
+	opc_callvirt*		= 195;
+	opc_jmp*		= 196;
+	opc_ldftn*		= 197;
+	opc_ldvirtftn*		= 198;
+	opc_newobj*		= 199;
+
+	opc_ldfld*		= 200;		(* Opcodes with fldNm args *)
+	opc_ldflda*		= 201;
+	opc_ldsfld*		= 202;
+	opc_ldsflda*		= 203;
+	opc_stfld*		= 204;
+	opc_stsfld*		= 205;
+
+	opc_box*		= 206;		(* Opcodes with type arg   *)
+	opc_castclass*		= 207;
+	opc_cpobj*		= 208;
+	opc_initobj*		= 209;
+	opc_isinst*		= 210;
+	opc_ldelema*		= 211;
+	opc_ldobj*		= 212;
+	opc_mkrefany*		= 213;
+	opc_newarr*		= 214;
+	opc_refanyval*		= 215;
+	opc_sizeof*		= 216;
+	opc_stobj*		= 217;
+	opc_unbox*		= 218;
+
+	opc_ldstr*		= 219;		(* Miscellaneous	*)
+	opc_calli*		= 220;
+	opc_ldptr*		= 221;
+	opc_ldtoken*		= 222;
+(*
+ *)
+	opc_switch*		= 224;
+
+(* ============================================================ *)
+
+  TYPE
+     OpName* = ARRAY 20 OF CHAR;
+
+(* ============================================================ *)
+
+  VAR	op* : ARRAY 232 OF OpName;
+        cd* : ARRAY 232 OF INTEGER;
+	dl* : ARRAY 232 OF INTEGER;
+
+  VAR   dirStr* : ARRAY 18 OF OpName;
+	access* : ARRAY 16 OF OpName;
+
+(* ============================================================ *)
+
+BEGIN
+  (* ---------------------------------------------- *)
+
+        dirStr[dot_error]       := ".ERROR";
+        dirStr[dot_try]		:= "    .try";
+        dirStr[dot_class]       := ".class";
+        dirStr[dot_entrypoint]  := ".entrypoint";
+        dirStr[dot_field]       := ".field";
+        dirStr[dot_implements]  := "	implements";
+        dirStr[dot_interface]   := ".interface";
+        dirStr[dot_locals]      := ".locals";
+        dirStr[dot_line]        := ".line";
+        dirStr[dot_method]      := ".method";
+        dirStr[dot_source]      := ".source";
+        dirStr[dot_super]       := "	extends";
+        dirStr[dot_throws]      := ".throws";
+        dirStr[dot_var]         := ".var";
+        dirStr[dot_assembly]    := ".assembly";
+        dirStr[dot_namespace]   := ".namespace";
+        dirStr[dot_maxstack]	:= ".maxstack";
+
+  (* ---------------------------------------------- *)
+
+	access[ 0]		:= "public";
+	access[ 1]		:= "private";
+	access[ 2]		:= "assembly";
+	access[ 3]		:= "protected";
+	access[ 4]		:= "value";
+	access[ 5]		:= "static";
+	access[ 6]		:= "final";
+	access[ 7]		:= "sealed";
+	access[ 8]		:= "abstract";
+	access[ 9]		:= "newslot";
+	access[10]		:= "interface";
+	access[11]		:= "synchronized";
+	access[12]		:= "extern";
+	access[13]		:= "virtual";
+	access[14]		:= "instance";
+	access[15]		:= "volatile";
+
+  (* ---------------------------------------------- *)
+
+	op[opc_error]		:= "ERROR";
+	op[opc_add]		:= "add";
+	op[opc_add_ovf]		:= "add.ovf";
+	op[opc_add_ovf_un]	:= "add.ovf.un";
+	op[opc_and]		:= "and";
+
+	op[opc_arglist]		:= "arglist";
+	op[opc_break]		:= "break";
+	op[opc_ceq]		:= "ceq";
+	op[opc_cgt]		:= "cgt";
+	op[opc_cgt_un]		:= "cgt.un";
+	op[opc_ckfinite]	:= "ckfinite";
+	op[opc_clt]		:= "clt";
+	op[opc_clt_un]		:= "clt.un";
+	op[opc_conv_i]		:= "conv.i";
+	op[opc_conv_i1]		:= "conv.i1";
+	op[opc_conv_i2]		:= "conv.i2";
+	op[opc_conv_i4]		:= "conv.i4";
+	op[opc_conv_i8]		:= "conv.i8";
+	op[opc_conv_ovf_i]	:= "conv.ovf.i";
+	op[opc_conv_ovf_i_un]	:= "conv.ovf.i.un";
+	op[opc_conv_ovf_i1]	:= "conv.ovf.i1";
+	op[opc_conv_ovf_i1_un]	:= "conv.ovf.i1.un";
+	op[opc_conv_ovf_i2]	:= "conv.ovf.i2";
+	op[opc_conv_ovf_i2_un]	:= "conv.ovf.i2.un";
+	op[opc_conv_ovf_i4]	:= "conv.ovf.i4";
+	op[opc_conv_ovf_i4_un]	:= "conv.ovf.i4.un";
+	op[opc_conv_ovf_i8]	:= "conv.ovf.i8";
+	op[opc_conv_ovf_i8_un]	:= "conv.ovf.i8.un";
+	op[opc_conv_ovf_u]	:= "conv.ovf.u";
+	op[opc_conv_ovf_u_un]	:= "conv.ovf.u.un";
+	op[opc_conv_ovf_u1]	:= "conv.ovf.u1";
+	op[opc_conv_ovf_u1_un]	:= "conv.ovf.u1.un";
+	op[opc_conv_ovf_u2]	:= "conv.ovf.u2";
+	op[opc_conv_ovf_u2_un]	:= "conv.ovf.u2.un";
+	op[opc_conv_ovf_u4]	:= "conv.ovf.u4";
+	op[opc_conv_ovf_u4_un]	:= "conv.ovf.u4.un";
+	op[opc_conv_ovf_u8]	:= "conv.ovf.u8";
+	op[opc_conv_ovf_u8_un]	:= "conv.ovf.u8.un";
+	op[opc_conv_r4]		:= "conv.r4";
+	op[opc_conv_r8]		:= "conv.r8";
+	op[opc_conv_u]		:= "conv.u";
+	op[opc_conv_u1]		:= "conv.u1";
+	op[opc_conv_u2]		:= "conv.u2";
+	op[opc_conv_u4]		:= "conv.u4";
+	op[opc_conv_u8]		:= "conv.u8";
+	op[opc_cpblk]		:= "cpblk";
+	op[opc_div]		:= "div";
+	op[opc_div_un]		:= "div.un";
+	op[opc_dup]		:= "dup";
+	op[opc_endcatch]	:= "endcatch";
+	op[opc_endfilter]	:= "endfilter";
+	op[opc_endfinally]	:= "endfinally";
+	op[opc_initblk]		:= "initblk";
+	op[opc_jmpi]		:= "jmpi";
+	op[opc_ldarg_0]		:= "ldarg.0";
+	op[opc_ldarg_1]		:= "ldarg.1";
+	op[opc_ldarg_2]		:= "ldarg.2";
+	op[opc_ldarg_3]		:= "ldarg.3";
+	op[opc_ldc_i4_0]	:= "ldc.i4.0";
+	op[opc_ldc_i4_1]	:= "ldc.i4.1";
+	op[opc_ldc_i4_2]	:= "ldc.i4.2";
+	op[opc_ldc_i4_3]	:= "ldc.i4.3";
+	op[opc_ldc_i4_4]	:= "ldc.i4.4";
+	op[opc_ldc_i4_5]	:= "ldc.i4.5";
+	op[opc_ldc_i4_6]	:= "ldc.i4.6";
+	op[opc_ldc_i4_7]	:= "ldc.i4.7";
+	op[opc_ldc_i4_8]	:= "ldc.i4.8";
+	op[opc_ldc_i4_M1]	:= "ldc.i4.M1";
+	op[opc_ldelem_i]	:= "ldelem.i";
+	op[opc_ldelem_i1]	:= "ldelem.i1";
+	op[opc_ldelem_i2]	:= "ldelem.i2";
+	op[opc_ldelem_i4]	:= "ldelem.i4";
+	op[opc_ldelem_i8]	:= "ldelem.i8";
+	op[opc_ldelem_r4]	:= "ldelem.r4";
+	op[opc_ldelem_r8]	:= "ldelem.r8";
+	op[opc_ldelem_ref]	:= "ldelem.ref";
+	op[opc_ldelem_u]	:= "ldelem.u";
+	op[opc_ldelem_u1]	:= "ldelem.u1";
+	op[opc_ldelem_u2]	:= "ldelem.u2";
+	op[opc_ldelem_u4]	:= "ldelem.u4";
+	op[opc_ldind_i]		:= "ldind.i";
+	op[opc_ldind_i1]	:= "ldind.i1";
+	op[opc_ldind_i2]	:= "ldind.i2";
+	op[opc_ldind_i4]	:= "ldind.i4";
+	op[opc_ldind_i8]	:= "ldind.i8";
+	op[opc_ldind_r4]	:= "ldind.r4";
+	op[opc_ldind_r8]	:= "ldind.r8";
+	op[opc_ldind_ref]	:= "ldind.ref";
+	op[opc_ldind_u]		:= "ldind.u";
+	op[opc_ldind_u1]	:= "ldind.u1";
+	op[opc_ldind_u2]	:= "ldind.u2"; (* NOT ldind.u3! *)
+	op[opc_ldind_u4]	:= "ldind.u4";
+	op[opc_ldlen]		:= "ldlen";
+	op[opc_ldloc_0]		:= "ldloc.0";
+	op[opc_ldloc_1]		:= "ldloc.1";
+	op[opc_ldloc_2]		:= "ldloc.2";
+	op[opc_ldloc_3]		:= "ldloc.3";
+	op[opc_ldnull]		:= "ldnull";
+	op[opc_localloc]	:= "localloc";
+	op[opc_mul]		:= "mul";
+	op[opc_mul_ovf]		:= "mul.ovf";
+	op[opc_mul_ovf_un]	:= "mul.ovf.un";
+	op[opc_neg]		:= "neg";
+	op[opc_nop]		:= "nop";
+	op[opc_not]		:= "not";
+	op[opc_or]		:= "or";
+	op[opc_pop]		:= "pop";
+	op[opc_refanytype]	:= "refanytype";
+	op[opc_rem]		:= "rem";
+	op[opc_rem_un]		:= "rem.un";
+	op[opc_ret]		:= "ret";
+	op[opc_rethrow]		:= "rethrow";
+	op[opc_shl]		:= "shl";
+	op[opc_shr]		:= "shr";
+	op[opc_shr_un]		:= "shr.un";
+	op[opc_stelem_i]	:= "stelem.i";
+	op[opc_stelem_i1]	:= "stelem.i1";
+	op[opc_stelem_i2]	:= "stelem.i2";
+	op[opc_stelem_i4]	:= "stelem.i4";
+	op[opc_stelem_i8]	:= "stelem.i8";
+	op[opc_stelem_r4]	:= "stelem.r4";
+	op[opc_stelem_r8]	:= "stelem.r8";
+	op[opc_stelem_ref]	:= "stelem.ref";
+	op[opc_stind_i]		:= "stind.i";
+	op[opc_stind_i1]	:= "stind.i1";
+	op[opc_stind_i2]	:= "stind.i2";
+	op[opc_stind_i4]	:= "stind.i4";
+	op[opc_stind_i8]	:= "stind.i8";
+	op[opc_stind_r4]	:= "stind.r4";
+	op[opc_stind_r8]	:= "stind.r8";
+	op[opc_stind_ref]	:= "stind.ref";
+	op[opc_stloc_0]		:= "stloc.0";
+	op[opc_stloc_1]		:= "stloc.1";
+	op[opc_stloc_2]		:= "stloc.2";
+	op[opc_stloc_3]		:= "stloc.3";
+	op[opc_sub]		:= "sub";
+	op[opc_sub_ovf]		:= "sub.ovf";
+	op[opc_sub_ovf_un]	:= "sub.ovf.un";
+	op[opc_tailcall]	:= "tailcall";
+	op[opc_throw]		:= "throw";
+	op[opc_volatile]	:= "volatile";
+	op[opc_xor]		:= "xor";
+
+	op[opc_ldarg]		:= "ldarg";
+	op[opc_ldarg_s]		:= "ldarg.s";
+	op[opc_ldarga]		:= "ldarga";
+	op[opc_ldarga_s]	:= "ldarga.s";
+	op[opc_starg]		:= "starg";
+	op[opc_starg_s]		:= "starg.s";
+	op[opc_ldloc]		:= "ldloc";
+	op[opc_ldloc_s]		:= "ldloc.s";
+	op[opc_ldloca]		:= "ldloca";
+	op[opc_ldloca_s]	:= "ldloca.s";
+	op[opc_stloc]		:= "stloc";
+	op[opc_stloc_s]		:= "stloc.s";
+
+	op[opc_ldc_i4]		:= "ldc.i4";
+	op[opc_unaligned_]	:= "unaligned.";
+	op[opc_ldc_i4_s]	:= "ldc.i4.s";
+	op[opc_ldc_i8]		:= "ldc.i8";
+	op[opc_ldc_r4]		:= "ldc.r4";
+	op[opc_ldc_r8]		:= "ldc.r8";
+
+	op[opc_beq]		:= "beq";
+	op[opc_beq_s]		:= "beq.s";
+	op[opc_bge]		:= "bge";
+	op[opc_bge_s]		:= "bge.s";
+	op[opc_bge_un]		:= "bge.un";
+	op[opc_bge_un_s]	:= "bge.un.s";
+	op[opc_bgt]		:= "bgt";
+	op[opc_bgt_s]		:= "bgt.s";
+	op[opc_bgt_un]		:= "bgt.un";
+	op[opc_bgt_un_s]	:= "bgt.un.s";
+	op[opc_ble]		:= "ble";
+	op[opc_ble_s]		:= "ble.s";
+	op[opc_ble_un]		:= "ble.un";
+	op[opc_ble_un_s]	:= "ble.un.s";
+	op[opc_blt]		:= "blt";
+	op[opc_blt_s]		:= "blt.s";
+	op[opc_blt_un]		:= "blt.un";
+	op[opc_blt_un_s]	:= "blt.un.s";
+	op[opc_bne_un]		:= "bne.un";
+	op[opc_bne_un_s]	:= "bne.un.s";
+	op[opc_br]		:= "br";
+	op[opc_br_s]		:= "br.s";
+	op[opc_brfalse]		:= "brfalse";
+	op[opc_brfalse_s]	:= "brfalse.s";
+	op[opc_brtrue]		:= "brtrue";
+	op[opc_brtrue_s]	:= "brtrue.s";
+	op[opc_leave]		:= "leave";
+(*
+ *	op[opc_leave_s]		:= "leave.s";
+ *)
+	op[opc_call]		:= "call";
+	op[opc_callvirt]	:= "callvirt";
+	op[opc_jmp]		:= "jmp";
+	op[opc_ldftn]		:= "ldftn";
+	op[opc_ldvirtftn]	:= "ldvirtftn";
+	op[opc_newobj]		:= "newobj";
+
+	op[opc_ldfld]		:= "ldfld";
+	op[opc_ldflda]		:= "ldflda";
+	op[opc_ldsfld]		:= "ldsfld";
+	op[opc_ldsflda]		:= "ldsflda";
+	op[opc_stfld]		:= "stfld";
+	op[opc_stsfld]		:= "stsfld";
+
+	op[opc_box]		:= "box";
+	op[opc_castclass]	:= "castclass";
+	op[opc_cpobj]		:= "cpobj";
+	op[opc_initobj]		:= "initobj";
+	op[opc_isinst]		:= "isinst";
+	op[opc_ldelema]		:= "ldelema";
+	op[opc_ldobj]		:= "ldobj";
+	op[opc_mkrefany]	:= "mkrefany";
+	op[opc_newarr]		:= "newarr";
+	op[opc_refanyval]	:= "refanyval";
+	op[opc_sizeof]		:= "sizeof";
+	op[opc_stobj]		:= "stobj";
+	op[opc_unbox]		:= "unbox";
+
+	op[opc_ldstr]		:= "ldstr";
+	op[opc_calli]		:= "calli";
+	op[opc_ldptr]		:= "ldptr";
+	op[opc_ldtoken]		:= "ldtoken";
+	op[opc_switch]		:= "switch";
+
+  (* ---------------------------------------------- *)
+
+	cd[opc_error]	        := -1;
+
+
+	cd[opc_nop]		:= 0;
+	cd[opc_break]		:= 1;
+	cd[opc_ldarg_0]		:= 2;
+	cd[opc_ldarg_1]		:= 3;
+	cd[opc_ldarg_2]		:= 4;
+	cd[opc_ldarg_3]		:= 5;
+	cd[opc_ldloc_0]		:= 6;
+	cd[opc_ldloc_1]		:= 7;
+	cd[opc_ldloc_2]		:= 8;
+	cd[opc_ldloc_3]		:= 9;
+	cd[opc_stloc_0]		:= 10;
+	cd[opc_stloc_1]		:= 11;
+	cd[opc_stloc_2]		:= 12;
+	cd[opc_stloc_3]		:= 13;
+
+        cd[opc_ldarg_s]         := 0EH;
+        cd[opc_ldarga_s]        := 0FH;
+        cd[opc_starg_s]         := 10H;
+        cd[opc_ldloc_s]         := 11H;
+        cd[opc_ldloca_s]        := 12H;
+        cd[opc_stloc_s]         := 13H;
+
+	cd[opc_ldnull]		:= 14H;
+	cd[opc_ldc_i4_M1]	:= 15H;
+	cd[opc_ldc_i4_0]	:= 16H;
+	cd[opc_ldc_i4_1]	:= 17H;
+	cd[opc_ldc_i4_2]	:= 18H;
+	cd[opc_ldc_i4_3]	:= 19H;
+	cd[opc_ldc_i4_4]	:= 1AH;
+	cd[opc_ldc_i4_5]	:= 1BH;
+	cd[opc_ldc_i4_6]	:= 1CH;
+	cd[opc_ldc_i4_7]	:= 1DH;
+	cd[opc_ldc_i4_8]	:= 1EH;
+        cd[opc_ldc_i4_s]        := 1FH; 
+        cd[opc_ldc_i4]          := 20H; 
+        cd[opc_ldc_i8]          := 21H; 
+        cd[opc_ldc_r4]          := 22H; 
+        cd[opc_ldc_r8]          := 23H; 
+
+	cd[opc_dup]		:= 25H;
+	cd[opc_pop]		:= 26H;
+        cd[opc_jmp]             := 27H; 
+        cd[opc_call]            := 28H;
+
+	cd[opc_ret]		:= 2AH;
+        cd[opc_br]              := 2BH; 
+        cd[opc_brfalse]         := 2CH;
+        cd[opc_brtrue]          := 2DH;
+        cd[opc_beq]             := 2EH;
+        cd[opc_bge]             := 2FH;
+        cd[opc_bgt]             := 30H;
+        cd[opc_ble]             := 31H;
+        cd[opc_blt]             := 32H;
+        cd[opc_bne_un]          := 33H;
+        cd[opc_bge_un]          := 34H;
+        cd[opc_bgt_un]          := 35H;
+        cd[opc_ble_un]          := 36H;
+        cd[opc_blt_un]          := 37H;
+
+        cd[opc_ldind_i1]        := 46H;
+        cd[opc_ldind_u1]        := 71;
+        cd[opc_ldind_i2]        := 72;
+        cd[opc_ldind_u2]        := 73;
+        cd[opc_ldind_i4]        := 74;
+        cd[opc_ldind_u4]        := 75;
+        cd[opc_ldind_i8]        := 76;
+        cd[opc_ldind_i]         := 77;
+        cd[opc_ldind_r4]        := 78;
+        cd[opc_ldind_r8]        := 79;
+        cd[opc_ldind_ref]       := 80;
+        cd[opc_stind_ref]       := 81;
+        cd[opc_stind_i1]        := 82;
+        cd[opc_stind_i2]        := 83;
+        cd[opc_stind_i4]        := 84;
+        cd[opc_stind_i8]        := 85;
+        cd[opc_stind_r4]        := 86;
+        cd[opc_stind_r8]        := 87;
+        cd[opc_add]             := 88;
+        cd[opc_sub]             := 89;
+        cd[opc_mul]             := 90;
+        cd[opc_div]             := 91;
+        cd[opc_div_un]          := 92;
+        cd[opc_rem]             := 93;
+        cd[opc_rem_un]          := 94;
+        cd[opc_and]             := 95;
+        cd[opc_or]              := 96;
+        cd[opc_xor]             := 97;
+        cd[opc_shl]             := 98;
+        cd[opc_shr]             := 99;
+        cd[opc_shr_un]          := 100;
+        cd[opc_neg]             := 101;
+        cd[opc_not]             := 102;
+        cd[opc_conv_i1]         := 103;
+        cd[opc_conv_i2]         := 104;
+        cd[opc_conv_i4]         := 105;
+        cd[opc_conv_i8]         := 106;
+        cd[opc_conv_r4]         := 107;
+        cd[opc_conv_r8]         := 108;
+        cd[opc_conv_u4]         := 109;
+        cd[opc_conv_u8]         := 110;
+
+        cd[opc_callvirt]        := 6FH; 
+        cd[opc_cpobj]           := 70H; 
+        cd[opc_ldobj]           := 71H;
+        cd[opc_ldstr]           := 72H;
+        cd[opc_newobj]          := 73H; 
+        cd[opc_castclass]       := 74H; 
+        cd[opc_isinst]          := 75H;
+(*
+ *      cd[opc_conv_r_un]       := 76H;
+ *)
+        cd[opc_unbox]           := 79H; 
+        cd[opc_throw]           := 7AH;
+        cd[opc_ldfld]           := 7BH; 
+        cd[opc_ldflda]          := 7CH;
+        cd[opc_stfld]           := 7DH;
+        cd[opc_ldsfld]          := 7EH;
+        cd[opc_ldsflda]         := 7FH;
+        cd[opc_stsfld]          := 80H;
+        cd[opc_stobj]           := 81H; 
+        cd[opc_conv_ovf_i1_un]  := 82H;
+        cd[opc_conv_ovf_i2_un]  := 83H;
+        cd[opc_conv_ovf_i4_un]  := 84H;
+        cd[opc_conv_ovf_i8_un]  := 85H;
+        cd[opc_conv_ovf_u1_un]  := 86H;
+        cd[opc_conv_ovf_u2_un]  := 87H;
+        cd[opc_conv_ovf_u4_un]  := 88H;
+        cd[opc_conv_ovf_u8_un]  := 89H;
+        cd[opc_conv_ovf_i_un]   := 8AH;
+        cd[opc_conv_ovf_u_un]   := 8BH;
+        cd[opc_box]             := 8CH; 
+        cd[opc_newarr]          := 8DH;
+        cd[opc_ldlen]           := 8EH;
+        cd[opc_ldelema]         := 8FH; 
+        cd[opc_ldelem_i1]       := 90H;
+        cd[opc_ldelem_u1]       := 91H;
+        cd[opc_ldelem_i2]       := 92H;
+        cd[opc_ldelem_u2]       := 93H;
+        cd[opc_ldelem_i4]       := 94H;
+        cd[opc_ldelem_u4]       := 95H;
+        cd[opc_ldelem_i8]       := 96H;
+        cd[opc_ldelem_i]        := 97H;
+        cd[opc_ldelem_r4]       := 98H;
+        cd[opc_ldelem_r8]       := 99H;
+        cd[opc_ldelem_ref]      := 9AH;
+
+        cd[opc_stelem_i]        := 9BH;
+        cd[opc_stelem_i1]       := 9CH;
+        cd[opc_stelem_i2]       := 9DH;
+        cd[opc_stelem_i4]       := 9EH;
+        cd[opc_stelem_i8]       := 9FH;
+        cd[opc_stelem_r4]       := 0A0H;
+        cd[opc_stelem_r8]       := 0A1H;
+        cd[opc_stelem_ref]      := 0A2H;
+
+        cd[opc_conv_ovf_i1]     := 0B3H;
+        cd[opc_conv_ovf_u1]     := 0B4H;
+        cd[opc_conv_ovf_i2]     := 0B5H;
+        cd[opc_conv_ovf_u2]     := 0B6H;
+        cd[opc_conv_ovf_i4]     := 0B7H;
+        cd[opc_conv_ovf_u4]     := 0B8H;
+        cd[opc_conv_ovf_i8]     := 0B9H;
+        cd[opc_conv_ovf_u8]     := 0BAH;
+
+        cd[opc_refanyval]       := 0C2H; 
+        cd[opc_ckfinite]        := 0C3H;
+        cd[opc_mkrefany]        := 0C6H; 
+
+        cd[opc_ldtoken]         := 0D0H; 
+        cd[opc_conv_u2]         := 0D1H;
+        cd[opc_conv_u1]         := 0D2H;
+        cd[opc_conv_i]          := 0D3H;
+        cd[opc_conv_ovf_i]      := 0D4H;
+        cd[opc_conv_ovf_u]      := 0D5H;
+        cd[opc_add_ovf]         := 0D6H;
+        cd[opc_add_ovf_un]      := 0D7H;
+        cd[opc_mul_ovf]         := 0D8H;
+        cd[opc_mul_ovf_un]      := 0D9H;
+        cd[opc_sub_ovf]         := 0DAH;
+        cd[opc_sub_ovf_un]      := 0DBH;
+        cd[opc_endfinally]      := 0DCH; 
+
+        cd[opc_leave]           := 0DEH;  (* actually leave.s *)
+(*
+ *      cd[opc_leave_s]         := 0DEH; 
+ *)
+        cd[opc_stind_i]         := 0DFH;
+        cd[opc_conv_u]          := 0E0H;
+
+        cd[opc_localloc]        := 0F1H;
+        cd[opc_endfilter]       := 0F2H;
+        cd[opc_volatile]        := 0F4H;
+        cd[opc_tailcall]        := 0F5H;
+        cd[opc_cpblk]           := 0F8H;
+        cd[opc_initblk]         := 0F9H;
+
+        cd[opc_arglist]         := 0FE00H;
+        cd[opc_ceq]             := 0FE01H;
+        cd[opc_cgt]             := 0FE02H;
+        cd[opc_cgt_un]          := 0FE03H;
+        cd[opc_clt]             := 0FE04H;
+        cd[opc_clt_un]          := 0FE05H;
+        cd[opc_ldftn]           := 0FE06H; 
+        cd[opc_ldvirtftn]       := 0FE07H;
+        cd[opc_ldarg]           := 0FE09H;
+        cd[opc_ldarga]          := 0FE0AH;
+        cd[opc_starg]           := 0FE0BH;
+        cd[opc_ldloc]           := 0FE0CH;
+        cd[opc_ldloca]          := 0FE0DH;
+        cd[opc_stloc]           := 0FE0EH;
+        cd[opc_unaligned_]      := 0FE12H;
+        cd[opc_initobj]         := 0FE15H; 
+        cd[opc_rethrow]         := 0FE1AH;
+        cd[opc_sizeof]          := 0FE1CH; 
+        cd[opc_refanytype]      := 0FE1DH;
+
+
+ (* ---------------------------------------------- *)
+
+	dl[opc_error]		:= 0;
+	dl[opc_add]		:= -1;
+	dl[opc_add_ovf]		:= -1;
+	dl[opc_add_ovf_un]	:= -1;
+	dl[opc_and]		:= -1;
+	dl[opc_arglist]		:= 1;
+	dl[opc_break]		:= 0;
+	dl[opc_ceq]		:= -1;
+	dl[opc_cgt]		:= -1;
+	dl[opc_cgt_un]		:= -1;
+	dl[opc_ckfinite]	:= -1;
+	dl[opc_clt]		:= -1;
+	dl[opc_clt_un]		:= -1;
+	dl[opc_conv_i]		:= 0;
+	dl[opc_conv_i1]		:= 0;
+	dl[opc_conv_i2]		:= 0;
+	dl[opc_conv_i4]		:= 0;
+	dl[opc_conv_i8]		:= 0;
+	dl[opc_conv_ovf_i]	:= 0;
+	dl[opc_conv_ovf_i_un]	:= 0;
+	dl[opc_conv_ovf_i1]	:= 0;
+	dl[opc_conv_ovf_i1_un]	:= 0;
+	dl[opc_conv_ovf_i2]	:= 0;
+	dl[opc_conv_ovf_i2_un]	:= 0;
+	dl[opc_conv_ovf_i4]	:= 0;
+	dl[opc_conv_ovf_i4_un]	:= 0;
+	dl[opc_conv_ovf_i8]	:= 0;
+	dl[opc_conv_ovf_i8_un]	:= 0;
+	dl[opc_conv_ovf_u]	:= 0;
+	dl[opc_conv_ovf_u_un]	:= 0;
+	dl[opc_conv_ovf_u1]	:= 0;
+	dl[opc_conv_ovf_u1_un]	:= 0;
+	dl[opc_conv_ovf_u2]	:= 0;
+	dl[opc_conv_ovf_u2_un]	:= 0;
+	dl[opc_conv_ovf_u4]	:= 0;
+	dl[opc_conv_ovf_u4_un]	:= 0;
+	dl[opc_conv_ovf_u8]	:= 0;
+	dl[opc_conv_ovf_u8_un]	:= 0;
+	dl[opc_conv_r4]		:= 0;
+	dl[opc_conv_r8]		:= 0;
+	dl[opc_conv_u]		:= 0;
+	dl[opc_conv_u1]		:= 0;
+	dl[opc_conv_u2]		:= 0;
+	dl[opc_conv_u4]		:= 0;
+	dl[opc_conv_u8]		:= 0;
+	dl[opc_cpblk]		:= -3;
+	dl[opc_div]		:= -1;
+	dl[opc_div_un]		:= -1;
+	dl[opc_dup]		:= 1;
+	dl[opc_endcatch]	:= 0;
+	dl[opc_endfilter]	:= -1;
+	dl[opc_endfinally]	:= 0;
+	dl[opc_initblk]		:= -3;
+	dl[opc_ldarg_0]		:= 1;
+	dl[opc_ldarg_1]		:= 1;
+	dl[opc_ldarg_2]		:= 1;
+	dl[opc_ldarg_3]		:= 1;
+	dl[opc_ldc_i4_0]	:= 1;
+	dl[opc_ldc_i4_1]	:= 1;
+	dl[opc_ldc_i4_2]	:= 1;
+	dl[opc_ldc_i4_3]	:= 1;
+	dl[opc_ldc_i4_4]	:= 1;
+	dl[opc_ldc_i4_5]	:= 1;
+	dl[opc_ldc_i4_6]	:= 1;
+	dl[opc_ldc_i4_7]	:= 1;
+	dl[opc_ldc_i4_8]	:= 1;
+	dl[opc_ldc_i4_M1]	:= 1;
+	dl[opc_ldelem_i]	:= -1;
+	dl[opc_ldelem_i1]	:= -1;
+	dl[opc_ldelem_i2]	:= -1;
+	dl[opc_ldelem_i4]	:= -1;
+	dl[opc_ldelem_i8]	:= -1;
+	dl[opc_ldelem_r4]	:= -1;
+	dl[opc_ldelem_r8]	:= -1;
+	dl[opc_ldelem_ref]	:= -1;
+	dl[opc_ldelem_u]	:= -1;
+	dl[opc_ldelem_u1]	:= -1;
+	dl[opc_ldelem_u2]	:= -1;
+	dl[opc_ldelem_u4]	:= -1;
+	dl[opc_ldind_i]		:= 0;
+	dl[opc_ldind_i1]	:= 0;
+	dl[opc_ldind_i2]	:= 0;
+	dl[opc_ldind_i4]	:= 0;
+	dl[opc_ldind_i8]	:= 0;
+	dl[opc_ldind_r4]	:= 0;
+	dl[opc_ldind_r8]	:= 0;
+	dl[opc_ldind_ref]	:= 0;
+	dl[opc_ldind_u]		:= 0;
+	dl[opc_ldind_u1]	:= 0;
+	dl[opc_ldind_u2]	:= 0;
+	dl[opc_ldind_u4]	:= 0;
+	dl[opc_ldlen]		:= 0;
+	dl[opc_ldloc_0]		:= 1;
+	dl[opc_ldloc_1]		:= 1;
+	dl[opc_ldloc_2]		:= 1;
+	dl[opc_ldloc_3]		:= 1;
+	dl[opc_ldnull]		:= 1;
+	dl[opc_localloc]	:= 0;
+	dl[opc_mul]		:= -1;
+	dl[opc_mul_ovf]		:= -1;
+	dl[opc_mul_ovf_un]	:= -1;
+	dl[opc_neg]		:= 0;
+	dl[opc_nop]		:= 0;
+	dl[opc_not]		:= 0;
+	dl[opc_or]		:= -1;
+	dl[opc_pop]		:= -1;
+	dl[opc_refanytype]	:= 0;
+	dl[opc_rem]		:= -1;
+	dl[opc_rem_un]		:= -1;
+	dl[opc_ret]		:= 0;
+	dl[opc_rethrow]		:= 0;
+	dl[opc_shl]		:= -1;
+	dl[opc_shr]		:= -1;
+	dl[opc_shr_un]		:= -1;
+	dl[opc_stelem_i]	:= -3;
+	dl[opc_stelem_i1]	:= -3;
+	dl[opc_stelem_i2]	:= -3;
+	dl[opc_stelem_i4]	:= -3;
+	dl[opc_stelem_i8]	:= -3;
+	dl[opc_stelem_r4]	:= -3;
+	dl[opc_stelem_r8]	:= -3;
+	dl[opc_stelem_ref]	:= -3;
+	dl[opc_stind_i]		:= -2;
+	dl[opc_stind_i1]	:= -2;
+	dl[opc_stind_i2]	:= -2;
+	dl[opc_stind_i4]	:= -2;
+	dl[opc_stind_i8]	:= -2;
+	dl[opc_stind_r4]	:= -2;
+	dl[opc_stind_r8]	:= -2;
+	dl[opc_stind_ref]	:= -2;
+	dl[opc_stloc_0]		:= -1;
+	dl[opc_stloc_1]		:= -1;
+	dl[opc_stloc_2]		:= -1;
+	dl[opc_stloc_3]		:= -1;
+	dl[opc_sub]		:= -1;
+	dl[opc_sub_ovf]		:= -1;
+	dl[opc_sub_ovf_un]	:= -1;
+	dl[opc_tailcall]	:= 0;
+	dl[opc_throw]		:= -1;
+	dl[opc_volatile]	:= 0;
+	dl[opc_xor]		:= -1;
+
+	dl[opc_ldarg]		:= 1;
+	dl[opc_ldarg_s]		:= 1;
+	dl[opc_ldarga]		:= 1;
+	dl[opc_ldarga_s]	:= 1;
+	dl[opc_starg]		:= -1;
+	dl[opc_starg_s]		:= -1;
+	dl[opc_ldloc]		:= 1;
+	dl[opc_ldloc_s]		:= 1;
+	dl[opc_ldloca]		:= 1;
+	dl[opc_ldloca_s]	:= 1;
+	dl[opc_stloc]		:= -1;
+	dl[opc_stloc_s]		:= -1;
+
+	dl[opc_ldc_i4]		:= 1;
+	dl[opc_unaligned_]	:= 0;
+	dl[opc_ldc_i4_s]	:= 1;
+	dl[opc_ldc_i8]		:= 1;
+	dl[opc_ldc_r4]		:= 1;
+	dl[opc_ldc_r8]		:= 1;
+
+	dl[opc_beq]		:= -2;
+	dl[opc_beq_s]		:= -2;
+	dl[opc_bge]		:= -2;
+	dl[opc_bge_s]		:= -2;
+	dl[opc_bge_un]		:= -2;
+	dl[opc_bge_un_s]	:= -2;
+	dl[opc_bgt]		:= -2;
+	dl[opc_bgt_s]		:= -2;
+	dl[opc_bgt_un]		:= -2;
+	dl[opc_bgt_un_s]	:= -2;
+	dl[opc_ble]		:= -2;
+	dl[opc_ble_s]		:= -2;
+	dl[opc_ble_un]		:= -2;
+	dl[opc_ble_un_s]	:= -2;
+	dl[opc_blt]		:= -2;
+	dl[opc_blt_s]		:= -2;
+	dl[opc_blt_un]		:= -2;
+	dl[opc_blt_un_s]	:= -2;
+	dl[opc_bne_un]		:= -2;
+	dl[opc_bne_un_s]	:= -2;
+	dl[opc_br]		:= 0;
+	dl[opc_br_s]		:= 0;
+	dl[opc_brfalse]		:= -1;
+	dl[opc_brfalse_s]	:= -1;
+	dl[opc_brtrue]		:= -1;
+	dl[opc_brtrue_s]	:= -1;
+	dl[opc_leave]		:= 0;
+(*
+ *	dl[opc_leave_s]		:= 0;
+ *)
+	dl[opc_call]		:= 0;		(* variable *)
+	dl[opc_callvirt]	:= 0;		(* variable *)
+	dl[opc_jmp]		:= 0;
+	dl[opc_jmpi]		:= -1;
+
+	dl[opc_ldftn]		:= 1;
+	dl[opc_ldvirtftn]	:= 1;
+	dl[opc_newobj]		:= 0;		(* variable *)
+
+	dl[opc_ldfld]		:= 0;
+	dl[opc_ldflda]		:= 0;
+	dl[opc_ldsfld]		:= 1;
+	dl[opc_ldsflda]		:= 1;
+	dl[opc_stfld]		:= -2;
+	dl[opc_stsfld]		:= -1;
+
+	dl[opc_box]		:= 0;
+	dl[opc_castclass]	:= 0;
+	dl[opc_cpobj]		:= -2;
+	dl[opc_initobj]		:= -1;
+	dl[opc_isinst]		:= 0;
+	dl[opc_ldelema]		:= -1;
+	dl[opc_ldobj]		:= 0;
+	dl[opc_mkrefany]	:= 0;
+	dl[opc_newarr]		:= 0;
+	dl[opc_refanyval]	:= 0;
+	dl[opc_sizeof]		:= 1;
+	dl[opc_stobj]		:= -2;
+	dl[opc_unbox]		:= 0;
+
+	dl[opc_ldstr]		:= 1;
+	dl[opc_calli]		:= 0;		(* variable *)
+	dl[opc_ldptr]		:= 1;
+	dl[opc_ldtoken]		:= 1;
+	dl[opc_switch]		:= -1;
+
+END IlasmCodes.
+(* ============================================================ *)

gpcp/IlasmUtil.cp

@@ -0,0 +1,1961 @@
+(* ============================================================ *)
+(*  MsilUtil is the module which writes ILASM file structures   *)
+(*  Copyright (c) John Gough 1999, 2000.                        *)
+(* ============================================================ *)
+
+MODULE IlasmUtil;
+
+  IMPORT 
+        GPCPcopyright,
+        RTS, 
+        ASCII,
+        Console,
+        GPText,
+        GPBinFiles,
+        GPTextFiles,
+     
+        Lv := LitValue,
+        Cs := CompState,
+        Sy := Symbols,
+        Mu := MsilUtil,
+        Bi := Builtin,
+        Id  := IdDesc,
+        Ty  := TypeDesc,
+        Scn := CPascalS,
+        Asm := IlasmCodes;
+
+(* ============================================================ *)
+
+   CONST
+        (* various ILASM-specific runtime name strings *)
+        initPrefix  = "instance void ";
+        initSuffix  = ".ctor() ";
+        initString  = ".ctor";
+        managedStr  = "il managed";
+        specialStr  = "public specialname rtspecialname ";
+        cctorStr    = "static void .cctor() ";
+        objectInit  = "instance void $o::.ctor() ";
+        mainString  = "public static void '.CPmain'($S[]) il managed";
+        winString   = "public static void '.WinMain'($S[]) il managed";
+        subSysStr   = "  .subsystem 0x00000002";
+        copyHead    = "public void __copy__(";
+        valueType* = "[mscorlib]System.ValueType";
+
+   CONST
+        putArgStr   = "$S[] [RTS]ProgArgs::argList";
+        catchStr    = "      catch [mscorlib]System.Exception";
+
+(* ============================================================ *)
+(* ============================================================ *)
+
+  TYPE IlasmFile* = POINTER TO RECORD (MsilUtil.MsilFile)
+                 (* Fields inherited from MsilFile *
+                  *   srcS* : Lv.CharOpen; (* source file name   *)
+                  *   outN* : Lv.CharOpen;
+                  *   proc* : ProcInfo;
+                  *)
+                      nxtLb : INTEGER;
+                      clsN* : Lv.CharOpen; (* current class name *)
+                      file* : GPBinFiles.FILE;
+                    END;
+
+(* ============================================================ *)
+
+  TYPE ILabel*    = POINTER TO RECORD (Mu.Label) 
+                      labl : INTEGER;
+                    END;
+
+(* ============================================================ *)
+
+  TYPE UByteArrayPtr* = POINTER TO ARRAY OF UBYTE;
+
+(* ============================================================ *)
+
+  VAR   nmArray   : Lv.CharOpenSeq;
+        rts       : ARRAY Mu.rtsLen OF Lv.CharOpen;
+
+  VAR   vals,                           (* "value"  *)
+        clss,                           (* "class"  *)
+        cln2,                           (* "::"     *)
+        brks,                           (* "[]"     *)
+        vStr,                           (* "void "  *)
+        ouMk,                           (* "[out]"  *)
+        lPar, rPar,                     (* ( )      *)
+        rfMk,                           (* "&"      *)
+        cmma,                           (* ","      *)
+        brsz,                           (* "{} etc" *)
+        vFld,                           (* "v$"     *)
+        inVd : Lv.CharOpen;       (* "in.v "  *)
+
+  VAR   evtAdd, evtRem : Lv.CharOpen;
+        pVarSuffix     : Lv.CharOpen;
+        xhrMk          : Lv.CharOpen;
+
+  VAR   boxedObj       : Lv.CharOpen;
+
+(* ============================================================ *)
+(*                 Utility Coercion Method                      *)
+(* ============================================================ *)
+
+  PROCEDURE UBytesOf(IN str : ARRAY OF CHAR) : UByteArrayPtr;
+    VAR result : UByteArrayPtr;
+        index  : INTEGER;
+        length : INTEGER;
+  BEGIN
+    length := LEN(str$);
+    NEW(result, length);
+    FOR index := 0 TO length-1 DO
+      result[index] := USHORT(ORD(str[index]) MOD 256);
+    END;
+    RETURN result;
+  END UBytesOf;
+
+(* ============================================================ *)
+(*                    Constructor Method                        *)
+(* ============================================================ *)
+
+  PROCEDURE newIlasmFile*(IN nam : ARRAY OF CHAR) : IlasmFile;
+    VAR f : IlasmFile;
+  BEGIN
+    NEW(f);
+    f.outN := BOX(nam + ".il");
+    f.file := GPBinFiles.createFile(f.outN);
+    RETURN f;
+  END newIlasmFile;
+
+(* ============================================================ *)
+
+  PROCEDURE (t : IlasmFile)fileOk*() : BOOLEAN;
+  BEGIN
+    RETURN t.file # NIL;
+  END fileOk;
+
+(* ============================================================ *)
+(*                    Some static utilities                     *)
+(* ============================================================ *)
+
+  PROCEDURE^ (os : IlasmFile)Locals(),NEW;
+  PROCEDURE^ (os : IlasmFile)TypeName(typ : Sy.Type),NEW;
+  PROCEDURE^ (os : IlasmFile)CallCombine(typ : Sy.Type; add : BOOLEAN),NEW;
+  PROCEDURE^ (os : IlasmFile)Comment*(IN s : ARRAY OF CHAR);
+  PROCEDURE^ (os : IlasmFile)CodeLb*(code : INTEGER; i2 : Mu.Label);
+  PROCEDURE^ (os : IlasmFile)DefLabC*(l : Mu.Label; IN c : ARRAY OF CHAR);
+
+(* ------------------------------------------------------------ *)
+(*
+  PROCEDURE (os : IlasmFile)newProcInfo*(proc : Sy.Scope) : Mu.ProcInfo;
+    VAR p : Mu.ProcInfo;
+  BEGIN
+    NEW(p);
+    Mu.InitProcInfo(p, proc);
+    RETURN p;
+  END newProcInfo;
+ *)
+(* ============================================================ *)
+
+  PROCEDURE (os : IlasmFile)MkNewProcInfo*(proc : Sy.Scope);
+  BEGIN
+    NEW(os.proc);
+    Mu.InitProcInfo(os.proc, proc);
+  END MkNewProcInfo;
+
+(* ============================================================ *)
+
+  PROCEDURE (os : IlasmFile)newLabel*() : Mu.Label;
+    VAR label : ILabel;
+  BEGIN
+    NEW(label); 
+    INC(os.nxtLb); 
+    label.labl := os.nxtLb;
+    RETURN label;
+  END newLabel;
+
+(* ============================================================ *)
+(*   Signature handling for this version                        *)
+(* ============================================================ *)
+
+  PROCEDURE (os : IlasmFile)NumberParams*(pIdn : Id.Procs; 
+                                          pTyp : Ty.Procedure);
+    VAR parId : Id.ParId;
+        index : INTEGER;
+        count : INTEGER;
+        first : BOOLEAN;
+        fmArray  : Lv.CharOpenSeq;
+   (* ----------------------------------------- *)
+    PROCEDURE AppendTypeName(VAR lst : Lv.CharOpenSeq; 
+                                 typ : Sy.Type;
+                                 slf : IlasmFile);
+    BEGIN
+     (*
+      *   We append type names, which must be lexically
+      *   equivalent to the names used in the declaration
+      *   in MethodDecl.
+      *)
+      IF typ.xName = NIL THEN Mu.MkTypeName(typ, slf) END;
+      WITH typ : Ty.Base DO
+          Lv.AppendCharOpen(lst, typ.xName);
+      | typ : Ty.Vector DO
+          Lv.AppendCharOpen(lst, clss);
+          Lv.AppendCharOpen(lst, typ.xName);
+      | typ : Ty.Array DO
+          AppendTypeName(lst, typ.elemTp, slf);
+          Lv.AppendCharOpen(lst, brks);
+      | typ : Ty.Record DO
+          IF ~(Sy.clsTp IN typ.xAttr) THEN Lv.AppendCharOpen(lst,vals) END;
+          IF ~(Sy.spshl IN typ.xAttr) THEN Lv.AppendCharOpen(lst,clss) END;
+          Lv.AppendCharOpen(lst, typ.scopeNm);
+      | typ : Ty.Pointer DO
+         (* 
+          *  This is a pointer to a value class, which has a
+          *  runtime representation as a boxed-class reference.
+          *)
+          IF Mu.isValRecord(typ.boundTp) THEN
+            Lv.AppendCharOpen(lst, clss);
+            Lv.AppendCharOpen(lst, typ.xName);
+          ELSE
+            AppendTypeName(lst, typ.boundTp, slf);
+          END;
+      | typ : Ty.Opaque DO
+          Lv.AppendCharOpen(lst, clss);
+          Lv.AppendCharOpen(lst, typ.xName);
+      | typ : Ty.Enum DO
+          Lv.AppendCharOpen(lst, vals);
+          Lv.AppendCharOpen(lst, clss);
+          Lv.AppendCharOpen(lst, typ.xName);
+      | typ : Ty.Procedure DO
+          Lv.AppendCharOpen(lst, clss);
+          Lv.AppendCharOpen(lst, typ.tName);
+      END;
+    END AppendTypeName;
+   (* ----------------------------------------- *)
+  BEGIN
+    first := TRUE;
+    count := pTyp.argN;
+    Lv.InitCharOpenSeq(fmArray, 4);
+    Lv.AppendCharOpen(fmArray, lPar);
+    IF (pIdn # NIL) & (pIdn.lxDepth > 0) THEN
+      Lv.AppendCharOpen(fmArray, xhrMk); first := FALSE;
+    END;
+    FOR index := 0 TO pTyp.formals.tide-1 DO
+      IF ~first THEN Lv.AppendCharOpen(fmArray, cmma) END;
+      parId := pTyp.formals.a[index];
+      parId.varOrd := count; INC(count);
+      AppendTypeName(fmArray, parId.type, os);
+      IF Mu.takeAdrs(parId) THEN 
+        parId.boxOrd := parId.parMod;
+        Lv.AppendCharOpen(fmArray, rfMk);
+        IF Id.uplevA IN parId.locAtt THEN 
+          parId.boxOrd := Sy.val;
+          ASSERT(Id.cpVarP IN parId.locAtt);
+        END;
+      END; (* just mark *)
+      first := FALSE;
+    END;
+    Lv.AppendCharOpen(fmArray, rPar);
+    pTyp.xName := Lv.arrayCat(fmArray);
+   (*
+    *   The current info.lNum (before the locals
+    *   have been added) is the argsize.
+    *)
+    pTyp.argN := count;
+    IF pTyp.retType # NIL THEN pTyp.retN := 1 END;
+  END NumberParams;
+ 
+(* ============================================================ *)
+(*                    Private Methods                           *)
+(* ============================================================ *)
+
+  PROCEDURE (os : IlasmFile)CatChar(chr : CHAR),NEW;
+  BEGIN
+    GPBinFiles.WriteByte(os.file, ORD(chr) MOD 256);
+  END CatChar;
+
+(* ============================================================ *)
+
+  PROCEDURE (os : IlasmFile)CatStr(IN str : ARRAY OF CHAR),NEW;
+  BEGIN
+    GPBinFiles.WriteNBytes(os.file, UBytesOf(str), LEN(str$));
+  END CatStr;
+
+(* ============================================================ *)
+
+  PROCEDURE (os : IlasmFile)CatInt(val : INTEGER),NEW;
+    VAR arr : ARRAY 16 OF CHAR;
+  BEGIN
+    GPText.IntToStr(val, arr); os.CatStr(arr);
+  END CatInt;
+
+(* ============================================================ *)
+
+  PROCEDURE (os : IlasmFile)CatLong(val : LONGINT),NEW;
+    VAR arr : ARRAY 32 OF CHAR;
+  BEGIN
+    GPText.LongToStr(val, arr); os.CatStr(arr);
+  END CatLong;
+
+(* ============================================================ *)
+
+  PROCEDURE (os : IlasmFile)CatEOL(),NEW;
+  BEGIN
+    os.CatStr(RTS.eol);
+  END CatEOL;
+
+(* ============================================================ *)
+
+  PROCEDURE (os : IlasmFile)Tstring(IN str : ARRAY OF CHAR),NEW;
+   (* TAB, then string *)
+  BEGIN
+    os.CatChar(ASCII.HT); os.CatStr(str);
+  END Tstring;
+
+(* ============================================================ *)
+
+  PROCEDURE (os : IlasmFile)Bstring(IN str : ARRAY OF CHAR),NEW;
+   (* BLANK, then string *)
+  BEGIN
+    os.CatChar(" "); os.CatStr(str);
+  END Bstring;
+
+(* ============================================================ *)
+
+  PROCEDURE (os : IlasmFile)Tint(int : INTEGER),NEW;
+   (* TAB, then int *)
+  BEGIN
+    os.CatChar(ASCII.HT); os.CatInt(int);
+  END Tint;
+
+(* ============================================================ *)
+
+  PROCEDURE (os : IlasmFile)Tlong(long : LONGINT),NEW;
+   (* TAB, then long *)
+  BEGIN
+    os.CatChar(ASCII.HT); os.CatLong(long);
+  END Tlong;
+
+(* ============================================================ *)
+
+  PROCEDURE (os : IlasmFile)QuoteStr(IN str : ARRAY OF CHAR),NEW;
+    VAR idx : INTEGER;
+        chr : CHAR;
+        ord : INTEGER;
+  BEGIN
+    idx := 0;
+    chr := str[0];
+    os.CatChar('"');
+    WHILE chr # 0X DO
+      CASE chr OF
+      | "\",'"' : os.CatChar("\");
+                  os.CatChar(chr);
+      | 9X      : os.CatChar("\");
+                  os.CatChar("t");
+      | 0AX     : os.CatChar("\");
+                  os.CatChar("n");
+      ELSE
+        IF chr > 07EX THEN
+          ord := ORD(chr);
+          os.CatChar('\');
+          os.CatChar(CHR(ord DIV 64 + ORD('0')));
+          os.CatChar(CHR(ord MOD 64 DIV 8 + ORD('0')));
+          os.CatChar(CHR(ord MOD 8 + ORD('0')));
+        ELSE
+          os.CatChar(chr);
+        END
+      END;
+      INC(idx);
+      chr := str[idx];
+    END;
+    os.CatChar('"');
+  END QuoteStr;
+
+(* ============================================================ *)
+
+  PROCEDURE (os : IlasmFile)Prefix(code : INTEGER),NEW;
+  BEGIN
+    os.CatChar(ASCII.HT); os.CatStr(Asm.op[code]);
+  END Prefix;
+
+(* ============================================================ *)
+
+  PROCEDURE (os : IlasmFile)IAdjust*(delta : INTEGER),NEW; 
+  BEGIN
+    os.Adjust(delta);
+    IF Cs.verbose THEN
+      os.CatStr(" // ");
+      os.CatInt(os.proc.dNum);
+      os.CatChar(",");
+      os.CatInt(os.proc.dMax);
+    END;
+    os.CatEOL();
+  END IAdjust;
+
+(* ============================================================ *)
+
+  PROCEDURE (os : IlasmFile)Suffix(code : INTEGER),NEW;
+  BEGIN
+    os.Adjust(Asm.dl[code]);
+    IF Cs.verbose THEN
+      os.CatStr(" // ");
+      os.CatInt(os.proc.dNum);
+      os.CatChar(",");
+      os.CatInt(os.proc.dMax);
+    END;
+    os.CatEOL();
+  END Suffix;
+
+(* ============================================================ *)
+
+  PROCEDURE (os : IlasmFile)Access*(acc : SET),NEW;
+    VAR att : INTEGER;
+  BEGIN
+    os.CatChar(" ");
+    FOR att := 0 TO Asm.maxAttIndex DO
+      IF att IN acc THEN
+        os.CatStr(Asm.access[att]);
+        os.CatChar(' ');
+      END;
+    END;
+  END Access;
+
+(* ============================================================ *)
+
+  PROCEDURE (os : IlasmFile)RefLab*(l : Mu.Label),NEW;
+  BEGIN
+    os.CatChar(ASCII.HT);
+    os.CatChar("l");
+    os.CatChar("b");
+    os.CatInt(l(ILabel).labl);
+  END RefLab;
+
+(* ------------------------------------ *)
+
+  PROCEDURE (os : IlasmFile)LstLab*(l : Mu.Label);
+  BEGIN
+    os.CatChar(",");
+    os.CatEOL();
+    os.Tstring("       lb");
+    os.CatInt(l(ILabel).labl);
+  END LstLab;
+
+(* ============================================================ *)
+
+  PROCEDURE (os : IlasmFile)SwitchHead*(n : INTEGER);
+   (* n is table length, ignored here *)
+  BEGIN
+    os.Prefix(Asm.opc_switch);
+    os.Tstring("( // dispatch table: ");
+    os.CatInt(n);
+  END SwitchHead;
+
+(* ------------------------------------ *)
+
+  PROCEDURE (os : IlasmFile)SwitchTail*();
+  BEGIN
+    os.CatChar(")");
+    os.IAdjust(-1);
+  END SwitchTail;
+
+(* ============================================================ *)
+
+  PROCEDURE (os : IlasmFile)Idnt(idD : Sy.Idnt),NEW;
+  BEGIN
+    os.CatChar("'");
+    os.CatStr(Sy.getName.ChPtr(idD));
+    os.CatChar("'");
+  END Idnt;
+
+(* ------------------------------------ *)
+
+  PROCEDURE (os : IlasmFile)SQuote(str : Lv.CharOpen),NEW;
+  BEGIN
+    os.CatChar("'");
+    os.CatStr(str);
+    os.CatChar("'");
+  END SQuote;
+
+(* ------------------------------------ *)
+
+  PROCEDURE (os : IlasmFile)TsQuote(str : Lv.CharOpen),NEW;
+  BEGIN
+    os.CatChar(ASCII.HT); os.SQuote(str);
+  END TsQuote;
+
+(* ------------------------------------ *)
+
+  PROCEDURE (os : IlasmFile)Tidnt(idD : Sy.Idnt),NEW;
+  BEGIN
+    os.CatChar(ASCII.HT); os.Idnt(idD);
+  END Tidnt;
+
+(* ------------------------------------ *)
+
+  PROCEDURE (os : IlasmFile)Bidnt(idD : Sy.Idnt),NEW;
+  BEGIN
+    os.CatChar(" "); os.Idnt(idD);
+  END Bidnt;
+
+(* ------------------------------------ *)
+
+  PROCEDURE (os : IlasmFile)PIdnt(idD : Id.Procs),NEW;
+   (* Write out procedure identifier name *)
+    VAR fullNm : Lv.CharOpen;
+  BEGIN
+    IF idD.scopeNm = NIL THEN Mu.MkProcName(idD, os) END;
+    os.CatChar(" ");
+    WITH idD : Id.PrcId DO 
+        IF idD.bndType = NIL THEN
+          fullNm := Mu.cat2(idD.scopeNm, idD.clsNm);
+        ELSE (* beware of special cases for object and string! *)
+          fullNm := idD.bndType(Ty.Record).scopeNm;
+        END;
+    | idD : Id.MthId DO 
+        IF Id.boxRcv IN idD.mthAtt THEN
+          fullNm := Mu.cat3(idD.scopeNm, boxedObj, idD.bndType.xName);
+        ELSE (* beware of special cases for object and string! *)
+          fullNm := idD.bndType(Ty.Record).scopeNm;
+        END;
+    END;
+    os.CatStr(fullNm);
+    os.CatStr(cln2);
+    os.SQuote(idD.prcNm);
+  END PIdnt;
+
+(* ============================================================ *)
+
+  PROCEDURE (os : IlasmFile)TypeTag(typ : Sy.Type),NEW;
+  BEGIN
+    IF typ.xName = NIL THEN Mu.MkTypeName(typ,os) END;
+    WITH typ : Ty.Base DO
+        os.CatStr(typ.xName);
+    | typ : Ty.Vector DO
+        os.CatStr(clss);
+        os.CatStr(typ.xName);
+    | typ : Ty.Array DO
+        os.TypeTag(typ.elemTp);
+        os.CatStr(brks);
+    | typ : Ty.Record DO
+        IF ~(Sy.clsTp IN typ.xAttr) THEN os.CatStr(vals) END;
+        IF ~(Sy.spshl IN typ.xAttr) THEN os.CatStr(clss) END;
+        os.CatStr(typ.scopeNm);
+    | typ : Ty.Procedure DO (* and also Event! *)
+        os.CatStr(clss);
+        os.CatStr(typ.tName);
+    | typ : Ty.Pointer DO
+        IF Mu.isValRecord(typ.boundTp) THEN
+         (* 
+          *  This is a pointer to a value class, which has a
+          *  runtime representation as a boxed-class reference.
+          *)
+          os.CatStr(clss);
+          os.CatStr(typ.xName);
+        ELSE
+          os.TypeTag(typ.boundTp);
+        END;
+    | typ : Ty.Opaque DO
+        os.CatStr(clss);
+        os.CatStr(typ.xName);
+    | typ : Ty.Enum DO
+        os.CatStr(vals);
+        os.CatStr(clss);
+        os.CatStr(typ.xName);
+    END;
+  END TypeTag;
+
+(* ============================================================ *)
+
+  PROCEDURE (os : IlasmFile)Translate(IN str : ARRAY OF CHAR),NEW;
+    VAR ix : INTEGER;
+        ch : CHAR;
+  BEGIN
+    ix := 0; ch := str[0];
+    WHILE ch # 0X DO
+      IF ch = '$' THEN
+        INC(ix); ch := str[ix];
+        IF    ch = "s" THEN os.TypeName(Cs.ntvStr);
+        ELSIF ch = "o" THEN os.TypeName(Cs.ntvObj);
+        ELSIF ch = "S" THEN os.TypeTag(Cs.ntvStr);
+        ELSIF ch = "O" THEN os.TypeTag(Cs.ntvObj);
+        END;
+      ELSE
+        os.CatChar(ch);
+      END;
+      INC(ix); ch := str[ix];
+    END;
+  END Translate;
+
+  PROCEDURE (os : IlasmFile)TTranslate(IN str : ARRAY OF CHAR),NEW;
+  BEGIN
+    os.CatChar(ASCII.HT);
+    os.Translate(str);
+  END TTranslate;
+
+(* ============================================================ *)
+
+  PROCEDURE (os : IlasmFile)TtypeTag(typ : Sy.Type),NEW;
+  BEGIN
+    os.CatChar(ASCII.HT);
+    os.TypeTag(typ);
+  END TtypeTag;
+
+(* ------------------------------------ *)
+
+  PROCEDURE (os : IlasmFile)TtypeNam(typ : Sy.Type),NEW;
+  BEGIN
+    os.Tstring(Mu.typeName(typ, os));
+  END TtypeNam;
+
+(* ------------------------------------ *)
+
+  PROCEDURE (os : IlasmFile)TypeName(typ : Sy.Type),NEW;
+  BEGIN
+    os.CatStr(Mu.typeName(typ, os));
+  END TypeName;
+
+(* ============================================================ *)
+
+  PROCEDURE (os : IlasmFile)RetType(typ : Ty.Procedure; pId : Id.Procs),NEW;
+  BEGIN
+    IF typ.retType = NIL THEN
+      os.CatStr(vStr);
+    ELSIF (pId # NIL) & (pId IS Id.MthId) & 
+        (Id.covar IN pId(Id.MthId).mthAtt) THEN
+     (*
+      *  This is a method with a covariant return type. We must
+      *  erase the declared type, substituting the non-covariant
+      *  upper-bound. Calls will cast the result to the real type.
+      *)
+      os.TypeTag(pId.retTypBound());
+    ELSE
+      os.TypeTag(typ.retType);
+    END;
+  END RetType;
+
+(* ============================================================ *)
+(*                    Exported Methods                          *)
+(* ============================================================ *)
+
+  PROCEDURE (os : IlasmFile)Blank*();
+  BEGIN
+    os.CatEOL();
+  END Blank;
+
+(* ============================================================ *)
+
+  PROCEDURE (os : IlasmFile)Separator(c : CHAR; i : INTEGER),NEW;
+  BEGIN
+    os.CatChar(c);
+    os.CatEOL();
+    WHILE i > 0 DO os.CatChar(ASCII.HT); DEC(i) END;
+  END Separator;
+
+(* ============================================================ *)
+
+  PROCEDURE (os : IlasmFile)OpenBrace*(i : INTEGER);
+  BEGIN
+    WHILE i > 0 DO os.CatChar(" "); DEC(i) END;
+    os.CatChar("{");
+    os.CatEOL();
+  END OpenBrace;
+
+(* ============================================================ *)
+
+  PROCEDURE (os : IlasmFile)CloseBrace*(i : INTEGER);
+  BEGIN
+    WHILE i > 0 DO os.CatChar(" "); DEC(i) END;
+    os.CatChar("}");
+    os.CatEOL();
+  END CloseBrace;
+
+(* ============================================================ *)
+
+  PROCEDURE (os : IlasmFile)Directive*(dir : INTEGER),NEW;
+  BEGIN
+    os.CatStr(Asm.dirStr[dir]);
+    os.CatEOL();
+  END Directive;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE (os : IlasmFile)DirectiveS*(dir : INTEGER;
+                             IN str : ARRAY OF CHAR),NEW;
+  BEGIN
+    os.CatStr(Asm.dirStr[dir]);
+    os.Bstring(str);
+    os.CatEOL();
+  END DirectiveS;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE (os : IlasmFile)DirectiveIS*(dir : INTEGER;
+                                  att : SET;
+                               IN str : ARRAY OF CHAR),NEW;
+  BEGIN
+    os.CatStr(Asm.dirStr[dir]);
+    os.Access(att);
+    os.CatStr(str);
+    os.CatEOL();
+  END DirectiveIS;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE (os : IlasmFile)DirectiveISS*(dir : INTEGER;
+                                    att : SET;
+                                 IN s1  : ARRAY OF CHAR;
+                                 IN s2  : ARRAY OF CHAR),NEW;
+  BEGIN
+    os.CatStr(Asm.dirStr[dir]);
+    os.Access(att);
+    os.CatStr(s1);
+    os.CatStr(s2);
+    IF dir = Asm.dot_method THEN os.Bstring(managedStr) END;
+    os.CatEOL();
+  END DirectiveISS;
+
+(* ============================================================ *)
+
+  PROCEDURE (os : IlasmFile)Finish*();
+  BEGIN
+    GPBinFiles.CloseFile(os.file);
+  END Finish;
+ 
+(* ------------------------------------------------- *)
+
+  PROCEDURE (os : IlasmFile)MkBodyClass*(mod : Id.BlkId);
+  BEGIN
+    os.clsN := mod.clsNm;
+    os.DirectiveIS(Asm.dot_class, Asm.modAttr, os.clsN);
+  END MkBodyClass;
+
+(* ------------------------------------------------- *)
+
+  PROCEDURE (os : IlasmFile)ClassHead*(attSet : SET; 
+                                       thisRc : Ty.Record;
+                                       superT : Ty.Record);
+  BEGIN
+    os.clsN := thisRc.xName;
+    os.DirectiveIS(Asm.dot_class, attSet, os.clsN);
+    IF superT # NIL THEN
+      IF superT.xName = NIL THEN Mu.MkRecName(superT, os) END;
+      os.DirectiveS(Asm.dot_super, superT.scopeNm);
+    END;
+  END ClassHead;
+
+(* ------------------------------------------------- *)
+
+  PROCEDURE (os : IlasmFile)StartNamespace*(name : Lv.CharOpen);
+  BEGIN
+    os.DirectiveS(Asm.dot_namespace, name);
+  END StartNamespace;
+
+(* ------------------------------------------------- *)
+
+  PROCEDURE (os : IlasmFile)AsmDef*(IN pkNm : ARRAY OF CHAR);
+  BEGIN
+    os.DirectiveIS(Asm.dot_assembly, {}, "'" + pkNm + "' {}");
+  END AsmDef;
+
+(* ------------------------------------------------- *)
+
+  PROCEDURE (os : IlasmFile)RefRTS*();
+  BEGIN
+    os.DirectiveIS(Asm.dot_assembly, Asm.att_extern, "RTS {}");
+    IF Cs.netRel = Cs.netV2_0 THEN
+      os.DirectiveIS(Asm.dot_assembly, Asm.att_extern, "mscorlib {}");
+    END;
+  END RefRTS;
+
+(* ============================================================ *)
+
+  PROCEDURE (os : IlasmFile)SignatureDecl(prcT : Ty.Procedure),NEW;
+    VAR indx : INTEGER;
+        parD : Id.ParId;
+        long : BOOLEAN;
+        nest : BOOLEAN;
+        frst : BOOLEAN;
+  BEGIN
+    frst := TRUE;
+    indx := prcT.formals.tide;
+    nest := (prcT.idnt IS Id.Procs) & (prcT.idnt(Id.Procs).lxDepth > 0);
+    long := (indx > 1) OR (nest & (indx > 0));
+
+    os.CatChar("(");
+    IF long THEN os.Separator(' ', 2) END;
+    IF nest THEN os.CatStr(xhrMk); frst := FALSE END;
+    FOR indx := 0 TO prcT.formals.tide-1 DO
+      parD := prcT.formals.a[indx];
+      IF long THEN
+        IF ~frst THEN os.Separator(',', 2) END;
+        IF parD.boxOrd = Sy.out THEN os.CatStr(ouMk) END;
+        os.TypeTag(parD.type);
+        IF (parD.boxOrd # Sy.val) OR
+           (Id.cpVarP IN parD.locAtt) THEN os.CatStr(rfMk) END;
+        os.Tidnt(parD); 
+      ELSE
+        IF ~frst THEN os.CatStr(cmma) END;
+        IF parD.boxOrd = Sy.out THEN os.CatStr(ouMk) END;
+        os.TypeTag(parD.type);
+        IF (parD.boxOrd # Sy.val) OR
+           (Id.cpVarP IN parD.locAtt) THEN os.CatStr(rfMk) END;
+        os.Bidnt(parD);
+      END;
+      frst := FALSE;
+    END;
+    os.CatChar(")");
+  END SignatureDecl;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE (os : IlasmFile)MethodDecl*(attr : SET; proc : Id.Procs);
+    VAR prcT : Ty.Procedure;
+  BEGIN
+    prcT := proc.type(Ty.Procedure);
+    os.CatStr(Asm.dirStr[Asm.dot_method]);
+    os.Access(attr);
+    os.RetType(prcT, proc);
+    os.CatChar(" ");
+    os.CatChar("'");
+    os.CatStr(proc.prcNm);
+    os.CatChar("'");
+    os.SignatureDecl(prcT);
+    os.Bstring(managedStr);
+    os.CatEOL();
+    IF Asm.att_abstract * attr # {} THEN 
+      os.Tstring(brsz); os.CatEOL();
+    END;
+  END MethodDecl;
+
+(* ------------------------------------------------------------ *)
+
+  PROCEDURE (os : IlasmFile)CheckNestedClass*(typ : Ty.Record;
+                                              scp : Sy.Scope;
+                                              str : Lv.CharOpen);
+    VAR i, len: INTEGER;
+  BEGIN
+   (* 
+    *  scan str with all occurences of 
+    *  '$' replaced by '/', except at index 0  
+    *)
+    len := LEN(str); 
+    FOR i := 1 TO len-1 DO
+      IF str[i] = '$' THEN str[i] := '/' END;
+    END; (* FOR *)
+  END CheckNestedClass;
+
+(* ------------------------------------------------------------ *)
+
+  PROCEDURE (os : IlasmFile)ExternList*();
+    VAR idx : INTEGER;
+        blk : Id.BlkId;
+   (* ----------------------------------------- *)
+    PROCEDURE Assembly(fl : IlasmFile; bk : Id.BlkId);
+      VAR ix : INTEGER;
+          ch : CHAR;
+    BEGIN
+      IF Sy.isFn IN bk.xAttr THEN
+        IF bk.scopeNm[0] # '[' THEN 
+                          RTS.Throw("bad extern name "+bk.scopeNm^) END;
+        ix := 1;
+        ch := bk.scopeNm[ix];
+        WHILE (ch # 0X) & (ch # ']') DO
+          fl.CatChar(ch);
+          INC(ix);
+          ch := bk.scopeNm[ix];
+        END;
+      ELSE
+        fl.CatStr(bk.xName);
+      END;
+    END Assembly;
+   (* ----------------------------------------- *)
+    PROCEDURE WriteHex(fl : IlasmFile; int : INTEGER);
+      VAR ord : INTEGER;
+    BEGIN
+      IF int <= 9 THEN ord := ORD('0') + int ELSE ord := (ORD('A')-10)+int END;
+      fl.CatChar(CHR(ord));
+    END WriteHex;
+   (* ----------------------------------------- *)
+    PROCEDURE WriteHexByte(fl : IlasmFile; int : INTEGER);
+    BEGIN
+      WriteHex(fl, int DIV 16);
+      WriteHex(fl, int MOD 16);
+      fl.CatChar(' ');
+    END WriteHexByte;
+   (* ----------------------------------------- *)
+    PROCEDURE WriteBytes(fl : IlasmFile; int : INTEGER);
+    BEGIN
+      WriteHexByte(fl, int DIV 1000000H MOD 100H);
+      WriteHexByte(fl, int DIV 10000H MOD 100H);
+      WriteHexByte(fl, int DIV 100H MOD 100H);
+      WriteHexByte(fl, int      MOD 100H);
+    END WriteBytes;
+   (* ----------------------------------------- *)
+    PROCEDURE WriteVersionName(os : IlasmFile; IN nam : ARRAY OF INTEGER);
+    BEGIN
+      os.CatStr(" {"); os.CatEOL();
+
+      IF (nam[4] # 0) OR (nam[5] # 0) THEN
+        os.CatStr("    .publickeytoken = ("); 
+(*
+ *      IF Cs.netRel = Cs.beta2 THEN
+ *        os.CatStr("    .publickeytoken = ("); 
+ *      ELSE
+ *        os.CatStr("    .originator = ("); 
+ *      END;
+ *)
+        WriteBytes(os, nam[4]);
+        WriteBytes(os, nam[5]);
+        os.CatChar(")"); 
+        os.CatEOL(); 
+      END;
+
+      os.CatStr("    .ver "); 
+      os.CatInt(nam[0]); 
+      os.CatChar(":"); 
+      os.CatInt(nam[1]); 
+      os.CatChar(":"); 
+      os.CatInt(nam[2]); 
+      os.CatChar(":"); 
+      os.CatInt(nam[3]); 
+      os.CatEOL(); 
+      os.CatChar("}"); 
+    END WriteVersionName;
+   (* ----------------------------------------- *)
+  BEGIN
+   (*
+    *   It is empirically established that all the
+    *   .assembly extern declarations must come at
+    *   the beginning of the ILASM file, at once.
+    *)
+    FOR idx := 0 TO Cs.impSeq.tide-1 DO
+      blk := Cs.impSeq.a[idx](Id.BlkId);
+      IF ~(Sy.rtsMd IN blk.xAttr) & (Sy.need IN blk.xAttr) THEN
+        Mu.MkBlkName(blk);
+        os.CatStr(Asm.dirStr[Asm.dot_assembly]);
+        os.Access(Asm.att_extern);
+        Assembly(os, blk);
+        IF blk.verNm = NIL THEN
+          os.CatStr(" {}");
+        ELSE
+          WriteVersionName(os, blk.verNm);
+        END;
+        os.CatEOL();
+      END;
+    END;
+  END ExternList;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE (os : IlasmFile)Comment*(IN s : ARRAY OF CHAR);
+  BEGIN
+    os.CatStr("// ");
+    os.CatStr(s);
+    os.CatEOL();
+  END Comment;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE (os : IlasmFile)CommentT*(IN s : ARRAY OF CHAR);
+  BEGIN
+    os.CatStr("//        ");
+    os.CatStr(s);
+    os.CatEOL();
+  END CommentT;
+
+(* ============================================================ *)
+
+  PROCEDURE (os : IlasmFile)DefLab*(l : Mu.Label);
+  BEGIN
+    os.CatChar("l");
+    os.CatChar("b");
+    os.CatInt(l(ILabel).labl);
+    os.CatChar(":");
+    os.CatEOL();
+  END DefLab;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE (os : IlasmFile)DefLabC*(l : Mu.Label; IN c : ARRAY OF CHAR);
+  BEGIN
+    os.CatChar("l");
+    os.CatChar("b");
+    os.CatInt(l(ILabel).labl);
+    os.CatChar(":");
+    os.CatChar(ASCII.HT);
+    os.Comment(c);
+  END DefLabC;
+
+(* ============================================================ *)
+
+  PROCEDURE (os : IlasmFile)Code*(code : INTEGER);
+  BEGIN
+    os.Prefix(code);
+    os.Suffix(code);
+  END Code;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE (os : IlasmFile)CodeI*(code,int : INTEGER);
+  BEGIN
+    os.Prefix(code);
+    os.Tint(int);
+    os.Suffix(code);
+  END CodeI;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE (os : IlasmFile)CodeT*(code : INTEGER; type : Sy.Type);
+  BEGIN
+    os.Prefix(code);
+    os.TtypeTag(type);
+    os.Suffix(code);
+  END CodeT;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE (os : IlasmFile)CodeTn*(code : INTEGER; type : Sy.Type);
+  BEGIN
+    os.Prefix(code);
+    os.TtypeNam(type);
+    os.Suffix(code);
+  END CodeTn;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE (os : IlasmFile)CodeL*(code : INTEGER; long : LONGINT);
+  BEGIN
+    os.Prefix(code);
+    os.Tlong(long);
+    os.Suffix(code);
+  END CodeL;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE (os : IlasmFile)CodeR*(code : INTEGER; real : REAL);
+    VAR nam : ARRAY 64 OF CHAR;
+  BEGIN
+    os.Prefix(code);
+    RTS.RealToStr(real, nam);
+    os.Tstring(nam$);
+    os.Suffix(code);
+  END CodeR;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE (os : IlasmFile)CodeLb*(code : INTEGER; i2 : Mu.Label);
+  BEGIN
+    os.Prefix(code);
+    os.RefLab(i2);
+    os.Suffix(code);
+  END CodeLb;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE (os : IlasmFile)CodeStr(code : INTEGER; 
+                                 IN str  : ARRAY OF CHAR),NEW;
+  BEGIN
+    os.Prefix(code);
+    os.TTranslate(str);
+    os.Suffix(code);
+  END CodeStr;
+
+  PROCEDURE (os : IlasmFile)CodeS*(code : INTEGER; str : INTEGER);
+  BEGIN
+    os.CodeStr(code, rts[str]);
+  END CodeS;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE (os : IlasmFile)StaticCall*(s : INTEGER; d : INTEGER);
+  BEGIN
+    os.Prefix(Asm.opc_call);
+    os.TTranslate(rts[s]);
+    os.IAdjust(d);
+  END StaticCall;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE (os : IlasmFile)Try*();
+    VAR retT : Sy.Type;
+  BEGIN
+    retT := os.proc.prId.type.returnType();
+    os.Directive(Asm.dot_try);
+    os.OpenBrace(4);
+    os.proc.exLb := os.newLabel();
+    IF retT # NIL THEN os.proc.rtLc := os.proc.newLocal(retT) END;
+  END Try;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE (os : IlasmFile)Catch*(proc : Id.Procs);
+  BEGIN
+    os.CloseBrace(4);
+    os.CatStr(catchStr);
+    os.CatEOL();
+    os.OpenBrace(4);
+    os.Adjust(1);	(* allow for incoming exception reference *)
+    os.StoreLocal(proc.except.varOrd);
+  END Catch;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE (os : IlasmFile)CloseCatch*();
+  BEGIN
+    os.CloseBrace(4);
+  END CloseCatch;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE (os : IlasmFile)CopyCall*(typ : Ty.Record);
+  BEGIN
+    os.Prefix(Asm.opc_call);
+    os.Tstring(initPrefix);
+    os.Bstring(typ.scopeNm);
+    os.CatStr("::__copy__(");
+    os.TypeTag(typ);
+    os.CatChar(")");
+    os.IAdjust(-2);
+  END CopyCall;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE (os : IlasmFile)PushStr*(IN str : ARRAY OF CHAR);
+  (* Use target quoting conventions for the literal string *)
+  BEGIN
+    os.Prefix(Asm.opc_ldstr);
+    os.CatChar(ASCII.HT);
+    os.QuoteStr(str);
+    os.IAdjust(1);
+  END PushStr;
+
+(* ============================================================ *)
+
+  PROCEDURE (os : IlasmFile)CallIT*(code : INTEGER; 
+                              proc : Id.Procs; 
+                              type : Ty.Procedure);
+  BEGIN
+    os.Prefix(code);
+    os.CatChar(ASCII.HT);
+   (*
+    *   For static calls to procedures we want
+    *            call  <ret-type> <idnt>(<signature>)
+    *   for static calls to final or super methods, we need
+    *            call  instance <ret-type> <idnt>(<signature>)
+    *   for calls to type-bound methods that are not final
+    *            callvirt  instance <ret-type> <idnt>(<signature>)
+    *)
+    IF proc IS Id.MthId THEN os.CatStr("instance ") END;
+    os.RetType(type, proc);
+    os.PIdnt(proc);
+    os.CatStr(type.xName);
+    os.IAdjust(type.retN - type.argN);        
+  END CallIT;
+
+(* ============================================================ *)
+
+  PROCEDURE (os : IlasmFile)CallCT*(proc : Id.Procs; 
+                                    type : Ty.Procedure);
+  BEGIN
+    os.Prefix(Asm.opc_newobj);
+    os.Tstring(initPrefix);
+    os.PIdnt(proc);
+    os.CatStr(type.xName);
+    os.IAdjust(type.retN - type.argN);        
+  END CallCT;
+
+(* ============================================================ *)
+
+  PROCEDURE (os : IlasmFile)CallDelegate*(typ : Ty.Procedure);
+  BEGIN
+    os.Prefix(Asm.opc_callvirt);
+    os.Tstring("instance ");
+    os.RetType(typ, NIL);
+    os.Bstring(typ.tName);
+    os.CatStr("::Invoke");
+    os.CatStr(typ.xName);
+    os.IAdjust(typ.retN - typ.argN);        
+  END CallDelegate;
+
+(* ============================================================ *)
+
+  PROCEDURE (os : IlasmFile)PutGetS*(code : INTEGER;
+                                     blk  : Id.BlkId;
+                                     fld  : Id.VarId);
+    VAR size : INTEGER;
+  (* Emit putstatic and getstatic for static field *)
+  BEGIN
+    os.Prefix(code);
+    os.TtypeTag(fld.type);
+    os.CatChar(ASCII.HT);
+    IF blk.xName = NIL THEN Mu.MkBlkName(blk) END;
+    IF fld.varNm = NIL THEN Mu.MkVarName(fld, os) END;
+    os.CatStr(blk.scopeNm);
+    os.CatStr(fld.clsNm);
+    os.CatStr(cln2);
+    os.SQuote(fld.varNm);
+    os.Suffix(code);
+  END PutGetS;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE (os : IlasmFile)PutGetFld(code : INTEGER;
+                                      fTyp : Sy.Type;
+                                      rTyp : Sy.Type;
+                                      name : Lv.CharOpen),NEW;
+  BEGIN
+    os.Prefix(code);
+    os.TtypeTag(fTyp);
+    os.TtypeNam(rTyp);
+    os.CatStr(cln2);
+    os.SQuote(name);
+    os.Suffix(code);
+  END PutGetFld;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE (os : IlasmFile)GetValObj*(code : INTEGER; 
+                                       ptrT : Ty.Pointer);
+  BEGIN
+    os.PutGetFld(code, ptrT.boundTp, ptrT, vFld);
+  END GetValObj;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE (os : IlasmFile)PutGetXhr*(code : INTEGER;
+                                       proc : Id.Procs;
+                                       locD : Id.LocId);
+    VAR name : Lv.CharOpen;
+  BEGIN
+    name := Sy.getName.ChPtr(locD);
+    os.PutGetFld(code, locD.type, proc.xhrType, name);
+  END PutGetXhr;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE (os : IlasmFile)PutGetF*(code : INTEGER;
+                                     fld  : Id.FldId);
+    VAR recT : Ty.Record;
+  (* Emit putfield and getfield for record field *)
+  BEGIN
+    recT := fld.recTyp(Ty.Record);
+    os.Prefix(code);
+    os.TtypeTag(fld.type);
+    os.CatChar(ASCII.HT);
+    IF fld.fldNm = NIL THEN fld.fldNm := Sy.getName.ChPtr(fld) END;
+   (*
+    *  Note the difference here. JVM needs the
+    *  static type of the variable, VOS wants
+    *  the name of the record with the field.
+    *)
+    os.CatStr(recT.scopeNm);
+    os.CatStr(cln2);
+    os.SQuote(fld.fldNm);
+    os.Suffix(code);
+  END PutGetF;
+
+(* ============================================================ *)
+(* ============================================================ *)
+
+  PROCEDURE (os : IlasmFile)MkNewRecord*(typ : Ty.Record);
+    VAR name : Lv.CharOpen;
+  BEGIN
+   (*
+    *  We need "newobj instance void <name>::.ctor()"
+    *)
+    IF typ.xName = NIL THEN Mu.MkRecName(typ, os) END;
+    IF Sy.clsTp IN typ.xAttr THEN
+      name := typ.scopeNm;
+    ELSE
+      name := Mu.boxedName(typ, os);
+    END;
+    os.Prefix(Asm.opc_newobj);
+    os.Tstring(initPrefix);
+    os.Bstring(name);
+    os.CatStr(cln2);
+    os.CatStr(initSuffix);
+    os.IAdjust(1);
+  END MkNewRecord;
+
+(* ============================================================ *)
+(* ============================================================ *)
+
+  PROCEDURE (os : IlasmFile)MkNewProcVal*(p : Sy.Idnt; t : Sy.Type);
+    VAR name : Lv.CharOpen;
+        proc : Id.Procs;
+        type : Ty.Procedure;
+        code : INTEGER;
+  BEGIN
+    proc := p(Id.Procs);
+    type := t(Ty.Procedure);
+   (*
+    *  We need "ldftn [instance] <retType> <procName>
+    *)
+    IF type.xName = NIL THEN Mu.MkPTypeName(type, os) END;
+    WITH p : Id.MthId DO
+      IF p.bndType.isInterfaceType() THEN
+        code := Asm.opc_ldvirtftn;
+      ELSIF p.mthAtt * Id.mask = Id.final THEN
+        code := Asm.opc_ldftn;
+      ELSE
+        code := Asm.opc_ldvirtftn;
+      END;
+    ELSE
+      code := Asm.opc_ldftn;
+    END;
+   (*
+    *   If this will be a virtual method call, then we
+    *   must duplicate the receiver, since the call of
+    *   ldvirtftn uses up one copy.
+    *)
+    IF code = Asm.opc_ldvirtftn THEN os.Code(Asm.opc_dup) END;
+    os.Prefix(code);
+    os.CatChar(ASCII.HT);
+    IF p IS Id.MthId THEN os.CatStr("instance ") END;
+    os.RetType(type, NIL);
+    os.PIdnt(proc);
+    os.CatStr(type.xName);
+    os.IAdjust(1);
+   (*
+    *  We need "newobj instance void <name>::.ctor(...)"
+    *)
+    os.Prefix(Asm.opc_newobj);
+    os.Tstring(initPrefix);
+    os.Bstring(type.tName);
+    os.CatStr(cln2);
+    os.Translate(pVarSuffix);
+    os.IAdjust(-2);
+  END MkNewProcVal;
+
+(* ============================================================ *)
+
+  PROCEDURE (os : IlasmFile)InitHead*(typ : Ty.Record;
+                                      prc : Id.PrcId);
+    VAR pTp : Ty.Procedure;
+  BEGIN
+   (*
+    *  Get the procedure type, if any ...
+    *)
+    IF prc # NIL THEN 
+      pTp := prc.type(Ty.Procedure);
+    ELSE 
+      pTp := NIL;
+    END;
+
+    os.CatStr(Asm.dirStr[Asm.dot_method]);
+    os.Bstring(specialStr);
+    os.Bstring(initPrefix);
+    IF prc = NIL THEN
+      os.Bstring(initSuffix);
+    ELSE
+      os.Bstring(initString);
+      os.SignatureDecl(pTp);
+    END;
+    os.CatStr(managedStr);
+    os.CatEOL();
+    os.CatStr("    {");
+    os.CatEOL();
+   (*
+    *   Now we begin to initialize the supertype;
+    *)
+    os.CommentT("Call supertype constructor");
+    os.Code(Asm.opc_ldarg_0);
+  END InitHead;
+
+(* ============================================================ *)
+
+  PROCEDURE (os : IlasmFile)CallSuper*(typ : Ty.Record;
+                                       prc : Id.PrcId);
+    VAR pTp : Ty.Procedure;
+        pNm : INTEGER;
+  BEGIN
+   (*
+    *  Get the procedure type, if any ...
+    *)
+    IF prc # NIL THEN 
+      pTp := prc.type(Ty.Procedure);
+      pNm := pTp.formals.tide;
+    ELSE 
+      pTp := NIL;
+      pNm := 0;
+    END;
+    os.Prefix(Asm.opc_call);
+    IF  (typ # NIL) & 
+        (typ.baseTp # NIL) & 
+        (typ.baseTp # Bi.anyRec) THEN
+      os.Tstring(initPrefix);
+      os.Bstring(typ.baseTp(Ty.Record).scopeNm);
+      os.CatStr(cln2);
+      IF pTp # NIL THEN
+        os.Bstring(initString);
+        os.CatStr(pTp.xName);
+      ELSE
+        os.CatStr(initSuffix);
+      END;
+    ELSE
+      os.TTranslate(objectInit);
+    END;
+    os.IAdjust(-(pNm+1));
+  END CallSuper;
+
+(* ============================================================ *)
+
+  PROCEDURE (os : IlasmFile)InitTail*(typ : Ty.Record);
+  BEGIN
+    os.Locals();
+    os.CatStr("    } // end of method '");
+    IF typ # NIL THEN 
+      os.CatStr(typ.xName);
+    END;
+    os.CatStr("::.ctor'");
+    os.CatEOL();
+  END InitTail;
+
+(* ============================================================ *)
+
+  PROCEDURE (os : IlasmFile)CopyHead*(typ : Ty.Record);
+  BEGIN
+    os.Comment("standard record copy method");
+    os.CatStr(Asm.dirStr[Asm.dot_method]);
+    os.Tstring(copyHead);
+(* FIX FOR BOXED CLASS COPY *)
+    IF ~(Sy.clsTp IN typ.xAttr) THEN os.CatStr(vals) END;
+    os.CatStr(clss);
+    os.CatStr(typ.scopeNm);
+    IF ~(Sy.clsTp IN typ.xAttr) THEN os.CatStr(rfMk) END;
+    os.CatStr(") ");
+    os.CatStr(managedStr);
+    os.CatEOL();
+    os.CatStr("    {");
+    os.CatEOL();
+  END CopyHead;
+
+(* ============================================================ *)
+
+  PROCEDURE (os : IlasmFile)CopyTail*();
+  BEGIN
+    os.Locals();
+    os.CatStr("    } // end of __copy__ method '");
+    os.CatEOL();
+  END CopyTail;
+
+(* ============================================================ *)
+
+  PROCEDURE (os : IlasmFile)MarkInterfaces*(IN seq : Sy.TypeSeq);
+    VAR index  : INTEGER;
+        tideX  : INTEGER;
+        implT  : Ty.Record;
+  BEGIN
+    tideX := seq.tide-1;
+    ASSERT(tideX >= 0);
+    os.CatStr(Asm.dirStr[Asm.dot_implements]); 
+    FOR index := 0 TO tideX DO
+      implT := seq.a[index].boundRecTp()(Ty.Record);
+      IF implT.xName = NIL THEN Mu.MkRecName(implT, os) END;
+      os.Bstring(implT.scopeNm);
+      IF index < tideX THEN os.CatChar(",") END;
+      os.CatEOL();
+      IF index < tideX THEN os.CatStr("                 ") END;
+    END;
+  END MarkInterfaces;
+
+(* ============================================================ *)
+
+  PROCEDURE (os : IlasmFile)MainHead*(xAtt : SET);
+  BEGIN
+    os.Comment("Main entry point");
+    os.CatStr(Asm.dirStr[Asm.dot_method]);
+    IF Sy.wMain IN xAtt THEN
+      os.TTranslate(winString);
+    ELSE
+      os.TTranslate(mainString);
+    END;
+    os.CatEOL();
+    os.OpenBrace(4);
+    os.Directive(Asm.dot_entrypoint);
+    IF Cs.debug THEN os.LineSpan(Scn.mkSpanT(Cs.thisMod.begTok)) END;
+   (*
+    *  Save the command-line arguments to the RTS.
+    *)
+    os.Code(Asm.opc_ldarg_0);
+    os.CodeStr(Asm.opc_stsfld, putArgStr);
+  END MainHead;
+
+(* ============================================================ *)
+
+  PROCEDURE (os : IlasmFile)SubSys*(xAtt : SET);
+  BEGIN
+    IF Sy.wMain IN xAtt THEN
+      os.TTranslate(subSysStr);
+      os.Comment("WinMain entry");
+      os.CatEOL();
+    ELSIF Sy.cMain IN xAtt THEN
+      os.Comment("CPmain entry");
+    END;
+  END SubSys;
+
+(* ============================================================ *)
+
+  PROCEDURE (os : IlasmFile)StartBoxClass*(rec : Ty.Record;
+                                   att : SET;
+                                   blk : Id.BlkId);
+    VAR name : Lv.CharOpen;
+        bNam : Lv.CharOpen;
+  BEGIN
+    os.CatEOL();
+    name := Mu.cat2(boxedObj, os.clsN);
+    os.DirectiveIS(Asm.dot_class, att, name);
+    os.OpenBrace(2);
+    os.CatStr(Asm.dirStr[Asm.dot_field]);
+    os.Access(Asm.att_public);
+    os.TtypeTag(rec);
+    os.Bstring(vFld);
+    os.CatEOL();
+   (*
+    *   Emit the no-arg constructor
+    *)
+    os.CatEOL();
+    os.MkNewProcInfo(blk);
+    os.InitHead(rec, NIL);
+    os.CallSuper(rec, NIL);
+    os.Code(Asm.opc_ret);
+    os.InitTail(rec);
+   (*
+    *   Copies of value classes are always done inline.
+    *)
+  END StartBoxClass;
+
+(* ============================================================ *)
+
+  PROCEDURE (os : IlasmFile)Tail(IN s : ARRAY OF CHAR),NEW;
+  BEGIN
+    os.Locals();
+    os.CatStr(s);
+    os.CatEOL();
+  END Tail;
+
+(* ------------------------------------------------------------ *)
+
+  PROCEDURE (os : IlasmFile)MainTail*();
+  BEGIN os.Tail("    } // end of method .CPmain") END MainTail;
+
+(* ------------------------------------------------------------ *)
+
+  PROCEDURE (os : IlasmFile)ClinitTail*();
+  BEGIN os.Tail("    } // end of .cctor method") END ClinitTail;
+
+(* ------------------------------------------------------------ *)
+
+  PROCEDURE (os : IlasmFile)MethodTail*(id : Id.Procs);
+  BEGIN os.Tail("    } // end of method " + id.prcNm^) END MethodTail;
+
+(* ============================================================ *)
+
+  PROCEDURE (os : IlasmFile)ClinitHead*();
+  BEGIN
+    os.CatStr(Asm.dirStr[Asm.dot_method]);
+    os.Tstring(specialStr);
+    os.CatStr(cctorStr);
+    os.CatStr(managedStr);
+    os.CatEOL();
+    os.CatStr("    {");
+    os.CatEOL();
+  END ClinitHead;
+
+(* ============================================================ *)
+
+  PROCEDURE (os : IlasmFile)EmitField*(id : Id.AbVar; att : SET);
+    VAR nm : Lv.CharOpen;
+  BEGIN
+    WITH id : Id.FldId DO 
+         IF id.fldNm = NIL THEN Mu.MkFldName(id, os) END;
+         nm := id.fldNm;
+    | id : Id.VarId DO
+         IF id.varNm = NIL THEN Mu.MkVarName(id, os) END;
+         nm := id.varNm;
+    END;
+    os.CatStr(Asm.dirStr[Asm.dot_field]);
+    os.Access(att);
+    os.TtypeTag(id.type);
+    os.TsQuote(nm);
+    os.CatEOL();
+  END EmitField;
+
+(* ============================================================ *)
+(*           Start of Procedure Variable and Event Stuff        *)
+(* ============================================================ *)
+
+  PROCEDURE (os : IlasmFile)EmitEventMethods*(id : Id.AbVar);
+    VAR eTp  : Ty.Event;
+   (* ------------------------------------------------- *)
+    PROCEDURE Head(os : IlasmFile; fn, tn : Lv.CharOpen; add : BOOLEAN);
+    BEGIN
+      os.CatEOL(); 
+      os.CatChar(ASCII.HT);
+      IF add THEN os.CatStr(evtAdd) ELSE os.CatStr(evtRem) END; 
+      os.CatStr(fn); os.CatStr("(class "); os.CatStr(tn); 
+      os.CatStr(") il managed synchronized {"); 
+      os.CatEOL(); 
+    END Head;
+   (* ------------------------------------------------- *)
+    PROCEDURE EmitEvtMth(os : IlasmFile; add : BOOLEAN; fld : Id.AbVar);
+    BEGIN
+      os.MkNewProcInfo(NIL);
+      WITH fld : Id.FldId DO
+          os.CatStr(".method public specialname instance void");
+          Head(os, fld.fldNm, fld.type(Ty.Event).tName, add);
+          os.Code(Asm.opc_ldarg_0);
+          os.Code(Asm.opc_ldarg_0);
+          os.PutGetF(Asm.opc_ldfld, fld);
+          os.Code(Asm.opc_ldarg_1);
+          os.CallCombine(fld.type, add);
+          os.PutGetF(Asm.opc_stfld, fld);
+      | fld : Id.VarId DO
+          os.CatStr(".method public specialname static void");
+          Head(os, fld.varNm, fld.type(Ty.Event).tName, add);
+          os.PutGetS(Asm.opc_ldsfld, fld.dfScp(Id.BlkId), fld);
+          os.Code(Asm.opc_ldarg_0);
+          os.CallCombine(fld.type, add);
+          os.PutGetS(Asm.opc_stsfld, fld.dfScp(Id.BlkId), fld);
+      END;
+      os.Code(Asm.opc_ret);
+      os.CloseBrace(4);
+      os.CatEOL(); 
+    END EmitEvtMth;
+   (* ------------------------------------------------- *)
+    PROCEDURE Decl(os : IlasmFile; cv, cl, fn, tn : Lv.CharOpen);
+    BEGIN
+      os.CatStr(".event ");
+      os.Tstring(tn);
+      os.CatChar(' '); 
+      os.SQuote(fn);        (* field name *)
+      os.CatEOL(); os.OpenBrace(4);
+
+      os.Tstring(".addon "); os.CatStr(cv); os.CatStr(cl); os.CatStr(cln2);
+      os.CatStr(evtAdd); os.CatStr(fn); os.CatStr("(class "); 
+      os.CatStr(tn); os.CatChar(')'); 
+      os.CatEOL(); 
+
+      os.Tstring(".removeon "); os.CatStr(cv); os.CatStr(cl); os.CatStr(cln2);
+      os.CatStr(evtRem); os.CatStr(fn); os.CatStr("(class "); 
+      os.CatStr(tn); os.CatChar(')'); 
+      os.CatEOL(); 
+    END Decl;
+   (* ------------------------------------------------- *)
+  BEGIN
+    eTp := id.type(Ty.Event);
+    os.CatEOL(); 
+   (*
+    *  Emit the "add_*" method
+    *)
+    EmitEvtMth(os, TRUE, id);
+   (*
+    *  Emit the "remove_*" method
+    *)
+    EmitEvtMth(os, FALSE, id);
+   (*
+    *  Emit the .event declaration" 
+    *)
+    WITH id : Id.FldId DO
+        Decl(os, inVd, id.recTyp(Ty.Record).scopeNm, id.fldNm, eTp.tName); 
+    | id : Id.VarId DO
+        Decl(os, vStr, 
+              Mu.cat2(id.dfScp(Id.BlkId).scopeNm, id.clsNm), 
+              id.varNm, eTp.tName); 
+    END;
+    os.CloseBrace(4);
+    os.CatEOL(); 
+  END EmitEventMethods;
+
+(* ============================================================ *)
+
+  PROCEDURE (os : IlasmFile)CallCombine(typ : Sy.Type;
+                                        add : BOOLEAN),NEW;
+  BEGIN
+    os.CatStr("        call        class [mscorlib]System.Delegate ");
+    os.CatEOL(); 
+    os.CatStr("                       [mscorlib]System.Delegate::");
+    IF add THEN os.CatStr("Combine(") ELSE os.CatStr("Remove(") END; 
+    os.CatEOL(); 
+    os.CatStr(
+"                               class [mscorlib]System.Delegate,");
+    os.CatEOL(); 
+    os.CatStr(
+"                               class [mscorlib]System.Delegate)");
+    os.CatEOL(); 
+    os.CodeT(Asm.opc_castclass, typ);
+  END CallCombine;
+
+(* ============================================================ *)
+(* ============================================================ *)
+
+  PROCEDURE (os : IlasmFile)MkAndLinkDelegate*(dl  : Sy.Idnt;
+                                               id  : Sy.Idnt;
+                                               ty  : Sy.Type;
+                                               add : BOOLEAN);
+    VAR rcv : INTEGER;
+   (* --------------------------------------------------------- *)
+    PROCEDURE Head(os : IlasmFile; 
+                   id : Sy.Idnt; 
+                   cc : Lv.CharOpen); 
+    BEGIN
+      Mu.MkIdName(id, os);
+      os.Prefix(Asm.opc_call);
+      os.Tstring(cc);
+    END Head;
+   (* --------------------------------------------------------- *)
+    PROCEDURE Tail(os  : IlasmFile; 
+                   ty  : Sy.Type; 
+                 nm  : Lv.CharOpen; 
+                   add : BOOLEAN);
+    BEGIN
+      os.CatStr(cln2);
+      IF add THEN os.CatStr(evtAdd) ELSE os.CatStr(evtRem) END; 
+      os.CatStr(nm);  os.CatChar("(");
+      os.TypeTag(ty); os.CatChar(")");
+      os.Suffix(Asm.opc_call);
+    END Tail;
+   (* --------------------------------------------------------- *)
+  BEGIN
+    WITH id : Id.FldId DO
+       (*
+        *      <push handle>                 // ... already done
+        *      <push receiver (or nil)>      // ... already done
+        *      <make new proc value>         // ... still to do
+        *      call      instance void A.B::add_fld(class tyName)
+        *)
+        os.MkNewProcVal(dl, ty);
+        Head(os, id, inVd);
+        os.CatStr(id.recTyp(Ty.Record).scopeNm);
+        Tail(os, ty, id.fldNm, add);
+    | id : Id.VarId DO
+       (*
+        *      <push receiver (or nil)>      // ... already done
+        *      <make new proc value>         // ... still to do
+        *      call      void A.B::add_fld(class tyName)
+        *)
+        os.MkNewProcVal(dl, ty);
+        Head(os, id, vStr);
+        Mu.MkBlkName(id.dfScp(Id.BlkId));
+        os.CatStr(id.dfScp.scopeNm);
+        os.CatStr(id.clsNm);
+        Tail(os, ty, id.varNm, add);
+    | id : Id.LocId DO
+       (*
+        *      <save receiver>      
+        *      ldloc      'local'
+        *      <restore receiver>      
+        *      <make new proc value>            // ... still to do
+        *      call      class D D::Combine(class D, class D)
+        *)
+        rcv := os.proc.newLocal(Cs.ntvObj);
+        os.StoreLocal(rcv);
+        os.GetLocal(id);
+        os.PushLocal(rcv);
+        os.MkNewProcVal(dl, ty);
+        os.CallCombine(ty, add);
+        os.PutLocal(id); 
+    END;
+  END MkAndLinkDelegate;
+
+(* ============================================================ *)
+(* ============================================================ *)
+
+  PROCEDURE (os : IlasmFile)EmitPTypeBody*(tId : Id.TypId);
+    VAR pTp : Ty.Procedure;
+  BEGIN
+    pTp := tId.type(Ty.Procedure);
+    os.CatEOL(); 
+    os.CatStr(".class public auto sealed "); os.CatStr(tId.type.name());
+    os.CatEOL(); 
+   (*
+    *  From Beta-2, all delegates derive from MulticastDelegate
+    *)
+    os.Tstring("extends [mscorlib]System.MulticastDelegate {");
+    os.CatEOL(); 
+    os.CatStr(".method public specialname rtspecialname instance void");
+    os.CatEOL(); 
+    os.Translate(pVarSuffix);
+    os.CatStr(" runtime managed { }");
+    os.CatEOL(); 
+    os.CatStr(".method public virtual instance ");
+    os.RetType(pTp, NIL);
+    os.CatEOL(); 
+    os.Tstring("Invoke"); 
+
+    os.SignatureDecl(pTp);
+
+    os.CatStr(" runtime managed { }"); os.CatEOL(); 
+    os.CloseBrace(2);
+    os.CatEOL(); 
+  END EmitPTypeBody;
+
+(* ============================================================ *)
+(*            End of Procedure Variable and Event Stuff         *)
+(* ============================================================ *)
+
+  PROCEDURE (os : IlasmFile)Line*(nm : INTEGER);
+  BEGIN
+    os.CatStr(Asm.dirStr[Asm.dot_line]); 
+    os.Tint(nm);
+    os.Tstring(os.srcS);
+    os.CatEOL();
+  END Line;
+
+(* ============================================================ *)
+
+  PROCEDURE (os : IlasmFile)LinePlus*(l,w : INTEGER);
+  BEGIN
+    os.CatStr(Asm.dirStr[Asm.dot_line]); 
+    os.Tint(l);
+    os.CatChar(":");
+    os.CatInt(w);
+    os.Tstring(os.srcS);
+    os.CatEOL();
+  END LinePlus;
+
+(* ============================================================ *)
+
+  PROCEDURE (os : IlasmFile)LineSpan*(s : Scn.Span);
+  BEGIN
+    IF s = NIL THEN RETURN END;
+    os.CatStr(Asm.dirStr[Asm.dot_line]); 
+    os.Tint(s.sLin);
+    os.CatChar(",");
+    os.CatInt(s.eLin);
+    os.CatChar(":");
+    os.CatInt(s.sCol);
+    os.CatChar(",");
+    os.CatInt(s.eCol);
+    os.Bstring(os.srcS);
+    os.CatEOL();
+  END LineSpan;
+  
+(* ============================================================ *)
+
+  PROCEDURE (os : IlasmFile)Locals(),NEW;
+  (** Declare the local of this method. *)
+    VAR count : INTEGER;
+        index : INTEGER;
+        prcId : Sy.Scope;
+        locId : Id.LocId;
+  BEGIN
+    count := 0;
+   (* if dMax < 8, leave maxstack as default *)
+    IF os.proc.dMax < 8 THEN os.CatStr("//") END;
+    os.CatChar(ASCII.HT);
+    os.CatStr(Asm.dirStr[Asm.dot_maxstack]); 
+    os.Tint(os.proc.dMax);
+    os.CatEOL();
+
+    os.CatChar(ASCII.HT);
+    os.CatStr(Asm.dirStr[Asm.dot_locals]); 
+    IF os.proc.tLst.tide > 0 THEN os.CatStr(" init ") END; 
+    IF os.proc.tLst.tide > 1 THEN 
+      os.Separator("(",2);
+    ELSE
+      os.CatChar("(");
+    END;
+    IF os.proc.prId # NIL THEN 
+      prcId := os.proc.prId;
+      WITH prcId : Id.Procs DO
+        IF Id.hasXHR IN prcId.pAttr THEN
+          os.TypeTag(prcId.xhrType);
+          INC(count);
+        END;
+        FOR index := 0 TO prcId.locals.tide-1 DO
+          locId := prcId.locals.a[index](Id.LocId);
+          IF ~(locId IS Id.ParId) & (locId.varOrd # Id.xMark) THEN
+            IF count > 0 THEN os.Separator(',', 2) END;
+            os.TypeTag(locId.type);
+            os.Tidnt(locId);
+            INC(count);
+          END;
+        END;
+      ELSE (* nothing for module blocks *)
+      END;
+    END;
+    WHILE count < os.proc.tLst.tide DO 
+      IF count > 0 THEN os.Separator(',', 2) END;
+      os.TypeTag(os.proc.tLst.a[count]);
+      INC(count);
+    END;
+    os.CatChar(")");
+    os.CatEOL();
+  END Locals;
+
+(* ============================================================ *)
+
+  PROCEDURE (os : IlasmFile)LoadType*(id : Sy.Idnt);
+  BEGIN
+   (*
+    *    ldtoken <Type>
+    *    call class [mscorlib]System.Type 
+    *           [mscorlib]System.Type::GetTypeFromHandle(
+    *                     value class [mscorlib]System.RuntimeTypeHandle)
+    *)
+    os.CodeT(Asm.opc_ldtoken, id.type);
+    os.CatStr("        call    class [mscorlib]System.Type");
+            os.CatEOL(); 
+    os.CatStr("            [mscorlib]System.Type::GetTypeFromHandle(");
+            os.CatEOL(); 
+    os.CatStr("            value class [mscorlib]System.RuntimeTypeHandle)");
+            os.CatEOL(); 
+  END LoadType;
+
+(* ============================================================ *)
+(* ============================================================ *)
+BEGIN
+  rts[Mu.vStr2ChO] := BOX("wchar[] [RTS]CP_rts::strToChO($S)");
+  rts[Mu.vStr2ChF] := BOX("void [RTS]CP_rts::StrToChF(wchar[], $S)");
+  rts[Mu.sysExit]  := BOX("void    [mscorlib]System.Environment::Exit(int32)");
+  rts[Mu.toUpper]  := BOX("wchar   [mscorlib]System.Char::ToUpper(wchar) ");
+  rts[Mu.dFloor]   := BOX("float64 [mscorlib]System.Math::Floor(float64) ");
+  rts[Mu.dAbs]     := BOX("float64 [mscorlib]System.Math::Abs(float64) ");
+  rts[Mu.fAbs]     := BOX("float32 [mscorlib]System.Math::Abs(float32) ");
+  rts[Mu.iAbs]     := BOX("int32   [mscorlib]System.Math::Abs(int32) ");
+  rts[Mu.lAbs]     := BOX("int64   [mscorlib]System.Math::Abs(int64) ");
+  rts[Mu.getTpM]   := BOX("instance class [mscorlib]System.Type $o::GetType()");
+  rts[Mu.CpModI]   := BOX("int32 [RTS]CP_rts::CpModI(int32, int32)");
+  rts[Mu.CpDivI]   := BOX("int32 [RTS]CP_rts::CpDivI(int32, int32)");
+  rts[Mu.CpModL]   := BOX("int64 [RTS]CP_rts::CpModL(int64, int64)");
+  rts[Mu.CpDivL]   := BOX("int64 [RTS]CP_rts::CpDivL(int64, int64)");
+  rts[Mu.aStrLen]  := BOX("int32 [RTS]CP_rts::chrArrLength(wchar[])");
+  rts[Mu.aStrChk]  := BOX("void  [RTS]CP_rts::ChrArrCheck(wchar[])");
+  rts[Mu.aStrLp1]  := BOX("int32 [RTS]CP_rts::chrArrLplus1(wchar[])");
+  rts[Mu.aaStrCmp] := BOX("int32 [RTS]CP_rts::strCmp(wchar[],wchar[])");
+  rts[Mu.aaStrCopy]:= BOX("void  [RTS]CP_rts::Stringify(wchar[],wchar[])");
+  rts[Mu.caseMesg] := BOX("$S [RTS]CP_rts::caseMesg(int32)");
+  rts[Mu.withMesg] := BOX("$S [RTS]CP_rts::withMesg($O)");
+  rts[Mu.chs2Str]  :=  BOX("$S [RTS]CP_rts::mkStr(wchar[])");
+  rts[Mu.CPJstrCatAA] := BOX("$S [RTS]CP_rts::aaToStr(wchar[],wchar[])");
+  rts[Mu.CPJstrCatSA] := BOX("$S [RTS]CP_rts::saToStr($S, wchar[])");
+  rts[Mu.CPJstrCatAS] := BOX("$S [RTS]CP_rts::asToStr(wchar[], $S)");
+  rts[Mu.CPJstrCatSS] := BOX("$S [RTS]CP_rts::ssToStr($S, $S)");
+  rts[Mu.mkExcept]    := BOX(
+            "instance void [mscorlib]System.Exception::.ctor($S)");
+
+(* ============================================================ *)
+
+  Lv.InitCharOpenSeq(nmArray, 8);
+
+  evtAdd := Lv.strToCharOpen("add_"); 
+  evtRem := Lv.strToCharOpen("remove_"); 
+
+  cln2 := Lv.strToCharOpen("::"); 
+  brks := Lv.strToCharOpen("[]"); 
+  cmma := Lv.strToCharOpen(","); 
+  lPar := Lv.strToCharOpen("("); 
+  rPar := Lv.strToCharOpen(")"); 
+  rfMk := Lv.strToCharOpen("&"); 
+  vFld := Lv.strToCharOpen("v$"); 
+  ouMk := Lv.strToCharOpen("[out] ");
+  clss := Lv.strToCharOpen("class "); 
+  vals := Lv.strToCharOpen("value "); 
+  vStr := Lv.strToCharOpen("void "); 
+  inVd := Lv.strToCharOpen("instance void "); 
+  brsz := Lv.strToCharOpen("    {} // abstract method"); 
+  xhrMk := Lv.strToCharOpen("class [RTS]XHR"); 
+  boxedObj := Lv.strToCharOpen("Boxed_"); 
+  pVarSuffix := Lv.strToCharOpen(".ctor($O, native int) ");
+
+END IlasmUtil.
+(* ============================================================ *)
+(* ============================================================ *)
+

gpcp/JVMcodes.cp

@@ -0,0 +1,734 @@
+(* ============================================================ *)
+(*  JVMcodes is the module which defines jasmin name ordinals.  *)
+(*  Name spelling is defined by the lexical rules of Jasmin.	*)
+(*  Copyright (c) John Gough 1999, 2000.			*)
+(* ============================================================ *)
+
+MODULE JVMcodes;
+  IMPORT GPCPcopyright;
+
+(* ============================================================ *)
+
+  CONST
+        dot_error*     = 0;
+        dot_catch*     = 1;
+        dot_class*     = 2;
+        dot_end*       = 3;
+        dot_field*     = 4;
+        dot_implements*= 5;
+        dot_interface* = 6;
+        dot_limit*     = 7;
+        dot_line*      = 8;
+        dot_method*    = 9;
+        dot_source*    = 10;
+        dot_super*     = 11;
+        dot_throws*    = 12;
+        dot_var*       = 13;
+
+  CONST
+        att_empty*       = {};
+        att_public*      = {0};
+        att_private*     = {1};
+        att_protected*   = {2};
+        att_static*      = {3};
+        att_final*       = {4};
+        att_synchronized*= {5};
+        att_native*      = {6};
+        att_volatile*    = {7};
+        att_abstract*    = {8};
+        att_transient*   = {9};
+        att_interface*   = {10};
+
+(* Constants for java class files *)
+
+  CONST
+        (* access flags *)
+        acc_package*      = 0000H;
+        acc_public*       = 0001H;
+        acc_private*      = 0002H;
+        acc_protected*    = 0004H;
+        acc_static*       = 0008H;
+        acc_final*        = 0010H;
+        acc_synchronized* = 0020H;
+        acc_volatile*     = 0040H;
+        acc_transient*    = 0080H;
+        acc_super*        = 0020H;
+        acc_native*       = 0100H;
+        acc_interface*    = 0200H;
+        acc_abstract*     = 0400H;
+
+        (* constant pool tags *)
+        const_utf8*               =  1;
+        const_integer*            =  3;
+        const_float*              =  4;
+        const_long*               =  5;
+        const_double*             =  6;
+        const_class*              =  7;
+        const_string*             =  8;
+        const_fieldref*           =  9;
+        const_methodref*          = 10;
+        const_interfacemethodref* = 11;
+        const_nameandtype*        = 12;
+
+(* ============================================================ *)
+
+  CONST
+	opc_nop*	= 0;
+	opc_aconst_null*= 1;
+	opc_iconst_m1*	= 2;
+	opc_iconst_0*	= 3;
+	opc_iconst_1*	= 4;
+	opc_iconst_2*	= 5;
+	opc_iconst_3*	= 6;
+	opc_iconst_4*	= 7;
+	opc_iconst_5*	= 8;
+	opc_lconst_0*	= 9;
+	opc_lconst_1*	= 10;
+	opc_fconst_0*	= 11;
+	opc_fconst_1*	= 12;
+	opc_fconst_2*	= 13;
+	opc_dconst_0*	= 14;
+	opc_dconst_1*	= 15;
+	opc_bipush*	= 16;
+	opc_sipush*	= 17;
+	opc_ldc*	= 18;
+	opc_ldc_w*	= 19;
+	opc_ldc2_w*	= 20;
+	opc_iload*	= 21;
+	opc_lload*	= 22;
+	opc_fload*	= 23;
+	opc_dload*	= 24;
+	opc_aload*	= 25;
+	opc_iload_0*	= 26;
+	opc_iload_1*	= 27;
+	opc_iload_2*	= 28;
+	opc_iload_3*	= 29;
+	opc_lload_0*	= 30;
+	opc_lload_1*	= 31;
+	opc_lload_2*	= 32;
+	opc_lload_3*	= 33;
+	opc_fload_0*	= 34;
+	opc_fload_1*	= 35;
+	opc_fload_2*	= 36;
+	opc_fload_3*	= 37;
+	opc_dload_0*	= 38;
+	opc_dload_1*	= 39;
+	opc_dload_2*	= 40;
+	opc_dload_3*	= 41;
+	opc_aload_0*	= 42;
+	opc_aload_1*	= 43;
+	opc_aload_2*	= 44;
+	opc_aload_3*	= 45;
+	opc_iaload*	= 46;
+	opc_laload*	= 47;
+	opc_faload*	= 48;
+	opc_daload*	= 49;
+	opc_aaload*	= 50;
+	opc_baload*	= 51;
+	opc_caload*	= 52;
+	opc_saload*	= 53;
+	opc_istore*	= 54;
+	opc_lstore*	= 55;
+	opc_fstore*	= 56;
+	opc_dstore*	= 57;
+	opc_astore*	= 58;
+	opc_istore_0*	= 59;
+	opc_istore_1*	= 60;
+	opc_istore_2*	= 61;
+	opc_istore_3*	= 62;
+	opc_lstore_0*	= 63;
+	opc_lstore_1*	= 64;
+	opc_lstore_2*	= 65;
+	opc_lstore_3*	= 66;
+	opc_fstore_0*	= 67;
+	opc_fstore_1*	= 68;
+	opc_fstore_2*	= 69;
+	opc_fstore_3*	= 70;
+	opc_dstore_0*	= 71;
+	opc_dstore_1*	= 72;
+	opc_dstore_2*	= 73;
+	opc_dstore_3*	= 74;
+	opc_astore_0*	= 75;
+	opc_astore_1*	= 76;
+	opc_astore_2*	= 77;
+	opc_astore_3*	= 78;
+	opc_iastore*	= 79;
+	opc_lastore*	= 80;
+	opc_fastore*	= 81;
+	opc_dastore*	= 82;
+	opc_aastore*	= 83;
+	opc_bastore*	= 84;
+	opc_castore*	= 85;
+	opc_sastore*	= 86;
+	opc_pop*	= 87;
+	opc_pop2*	= 88;
+	opc_dup*	= 89;
+	opc_dup_x1*	= 90;
+	opc_dup_x2*	= 91;
+	opc_dup2*	= 92;
+	opc_dup2_x1*	= 93;
+	opc_dup2_x2*	= 94;
+	opc_swap*	= 95;
+	opc_iadd*	= 96;
+	opc_ladd*	= 97;
+	opc_fadd*	= 98;
+	opc_dadd*	= 99;
+	opc_isub*	= 100;
+	opc_lsub*	= 101;
+	opc_fsub*	= 102;
+	opc_dsub*	= 103;
+	opc_imul*	= 104;
+	opc_lmul*	= 105;
+	opc_fmul*	= 106;
+	opc_dmul*	= 107;
+	opc_idiv*	= 108;
+	opc_ldiv*	= 109;
+	opc_fdiv*	= 110;
+	opc_ddiv*	= 111;
+	opc_irem*	= 112;
+	opc_lrem*	= 113;
+	opc_frem*	= 114;
+	opc_drem*	= 115;
+	opc_ineg*	= 116;
+	opc_lneg*	= 117;
+	opc_fneg*	= 118;
+	opc_dneg*	= 119;
+	opc_ishl*	= 120;
+	opc_lshl*	= 121;
+	opc_ishr*	= 122;
+	opc_lshr*	= 123;
+	opc_iushr*	= 124;
+	opc_lushr*	= 125;
+	opc_iand*	= 126;
+	opc_land*	= 127;
+	opc_ior*	= 128;
+	opc_lor*	= 129;
+	opc_ixor*	= 130;
+	opc_lxor*	= 131;
+	opc_iinc*	= 132;
+	opc_i2l*	= 133;
+	opc_i2f*	= 134;
+	opc_i2d*	= 135;
+	opc_l2i*	= 136;
+	opc_l2f*	= 137;
+	opc_l2d*	= 138;
+	opc_f2i*	= 139;
+	opc_f2l*	= 140;
+	opc_f2d*	= 141;
+	opc_d2i*	= 142;
+	opc_d2l*	= 143;
+	opc_d2f*	= 144;
+	opc_i2b*	= 145;
+	opc_i2c*	= 146;
+	opc_i2s*	= 147;
+	opc_lcmp*	= 148;
+	opc_fcmpl*	= 149;
+	opc_fcmpg*	= 150;
+	opc_dcmpl*	= 151;
+	opc_dcmpg*	= 152;
+	opc_ifeq*	= 153;
+	opc_ifne*	= 154;
+	opc_iflt*	= 155;
+	opc_ifge*	= 156;
+	opc_ifgt*	= 157;
+	opc_ifle*	= 158;
+	opc_if_icmpeq*	= 159;
+	opc_if_icmpne*	= 160;
+	opc_if_icmplt*	= 161;
+	opc_if_icmpge*	= 162;
+	opc_if_icmpgt*	= 163;
+	opc_if_icmple*	= 164;
+	opc_if_acmpeq*	= 165;
+	opc_if_acmpne*	= 166;
+	opc_goto*	= 167;
+	opc_jsr*	= 168;
+	opc_ret*	= 169;
+	opc_tableswitch*	= 170;
+	opc_lookupswitch*	= 171;
+	opc_ireturn*		= 172;
+	opc_lreturn*		= 173;
+	opc_freturn*		= 174;
+	opc_dreturn*		= 175;
+	opc_areturn*		= 176;
+	opc_return*		= 177;
+	opc_getstatic*		= 178;
+	opc_putstatic*		= 179;
+	opc_getfield*		= 180;
+	opc_putfield*		= 181;
+	opc_invokevirtual*	= 182;
+	opc_invokespecial*	= 183;
+	opc_invokestatic*	= 184;
+	opc_invokeinterface*	= 185;
+	opc_xxxunusedxxx	= 186;
+	opc_new*		= 187;
+	opc_newarray*		= 188;
+	opc_anewarray*		= 189;
+	opc_arraylength*	= 190;
+	opc_athrow*		= 191;
+	opc_checkcast*		= 192;
+	opc_instanceof*		= 193;
+	opc_monitorenter*	= 194;
+	opc_monitorexit*	= 195;
+	opc_wide*		= 196;
+	opc_multianewarray*	= 197;
+	opc_ifnull*		= 198;
+	opc_ifnonnull*		= 199;
+	opc_goto_w*		= 200;
+	opc_jsr_w*		= 201;
+	opc_breakpoint*		= 202;
+
+(* ============================================================ *)
+
+  TYPE
+     OpName* = ARRAY 24 OF CHAR;
+
+(* ============================================================ *)
+
+  VAR	op* : ARRAY 203 OF OpName;
+	dl* : ARRAY 203 OF INTEGER;
+
+  VAR   dirStr* : ARRAY 14 OF OpName;
+	access* : ARRAY 12 OF OpName;
+
+(* ============================================================ *)
+
+BEGIN
+        dirStr[dot_error]       := ".ERROR";
+        dirStr[dot_catch]       := ".catch";
+        dirStr[dot_class]       := ".class";
+        dirStr[dot_end]         := ".end method";
+        dirStr[dot_field]       := ".field";
+        dirStr[dot_implements]  := ".implements";
+        dirStr[dot_interface]   := ".interface";
+        dirStr[dot_limit]       := ".limit";
+        dirStr[dot_line]        := ".line";
+        dirStr[dot_method]      := ".method";
+        dirStr[dot_source]      := ".source";
+        dirStr[dot_super]       := ".super";
+        dirStr[dot_throws]      := ".throws";
+        dirStr[dot_var]         := ".var";
+
+	access[ 0]		:= "public";
+	access[ 1]		:= "private";
+	access[ 2]		:= "protected";
+	access[ 3]		:= "static";
+	access[ 4]		:= "final";
+	access[ 5]		:= "synchronized";
+	access[ 6]		:= "native";
+	access[ 7]		:= "volatile";
+	access[ 8]		:= "abstract";
+	access[ 9]		:= "transient";
+	access[10]		:= "interface";
+
+	op[opc_nop] 		:= "nop";
+	op[opc_aconst_null]	:= "aconst_null";
+	op[opc_iconst_m1]	:= "iconst_m1";
+	op[opc_iconst_0]	:= "iconst_0";
+	op[opc_iconst_1]	:= "iconst_1";
+	op[opc_iconst_2]	:= "iconst_2";
+	op[opc_iconst_3]	:= "iconst_3";
+	op[opc_iconst_4]	:= "iconst_4";
+	op[opc_iconst_5]	:= "iconst_5";
+	op[opc_lconst_0]	:= "lconst_0";
+	op[opc_lconst_1]	:= "lconst_1";
+	op[opc_fconst_0]	:= "fconst_0";
+	op[opc_fconst_1]	:= "fconst_1";
+	op[opc_fconst_2]	:= "fconst_2";
+	op[opc_dconst_0]	:= "dconst_0";
+	op[opc_dconst_1]	:= "dconst_1";
+	op[opc_bipush]		:= "bipush";
+	op[opc_sipush]		:= "sipush";
+	op[opc_ldc]		:= "ldc";
+	op[opc_ldc_w]		:= "ldc_w";
+	op[opc_ldc2_w]		:= "ldc2_w";
+	op[opc_iload]		:= "iload";
+	op[opc_lload]		:= "lload";
+	op[opc_fload]		:= "fload";
+	op[opc_dload]		:= "dload";
+	op[opc_aload]		:= "aload";
+	op[opc_iload_0]		:= "iload_0";
+	op[opc_iload_1]		:= "iload_1";
+	op[opc_iload_2]		:= "iload_2";
+	op[opc_iload_3]		:= "iload_3";
+	op[opc_lload_0]		:= "lload_0";
+	op[opc_lload_1]		:= "lload_1";
+	op[opc_lload_2]		:= "lload_2";
+	op[opc_lload_3]		:= "lload_3";
+	op[opc_fload_0]		:= "fload_0";
+	op[opc_fload_1]		:= "fload_1";
+	op[opc_fload_2]		:= "fload_2";
+	op[opc_fload_3]		:= "fload_3";
+	op[opc_dload_0]		:= "dload_0";
+	op[opc_dload_1]		:= "dload_1";
+	op[opc_dload_2]		:= "dload_2";
+	op[opc_dload_3]		:= "dload_3";
+	op[opc_aload_0]		:= "aload_0";
+	op[opc_aload_1]		:= "aload_1";
+	op[opc_aload_2]		:= "aload_2";
+	op[opc_aload_3]		:= "aload_3";
+	op[opc_iaload]		:= "iaload";
+	op[opc_laload]		:= "laload";
+	op[opc_faload]		:= "faload";
+	op[opc_daload]		:= "daload";
+	op[opc_aaload]		:= "aaload";
+	op[opc_baload]		:= "baload";
+	op[opc_caload]		:= "caload";
+	op[opc_saload]		:= "saload";
+	op[opc_istore]		:= "istore";
+	op[opc_lstore]		:= "lstore";
+	op[opc_fstore]		:= "fstore";
+	op[opc_dstore]		:= "dstore";
+	op[opc_astore]		:= "astore";
+	op[opc_istore_0]	:= "istore_0";
+	op[opc_istore_1]	:= "istore_1";
+	op[opc_istore_2]	:= "istore_2";
+	op[opc_istore_3]	:= "istore_3";
+	op[opc_lstore_0]	:= "lstore_0";
+	op[opc_lstore_1]	:= "lstore_1";
+	op[opc_lstore_2]	:= "lstore_2";
+	op[opc_lstore_3]	:= "lstore_3";
+	op[opc_fstore_0]	:= "fstore_0";
+	op[opc_fstore_1]	:= "fstore_1";
+	op[opc_fstore_2]	:= "fstore_2";
+	op[opc_fstore_3]	:= "fstore_3";
+	op[opc_dstore_0]	:= "dstore_0";
+	op[opc_dstore_1]	:= "dstore_1";
+	op[opc_dstore_2]	:= "dstore_2";
+	op[opc_dstore_3]	:= "dstore_3";
+	op[opc_astore_0]	:= "astore_0";
+	op[opc_astore_1]	:= "astore_1";
+	op[opc_astore_2]	:= "astore_2";
+	op[opc_astore_3]	:= "astore_3";
+	op[opc_iastore]		:= "iastore";
+	op[opc_lastore]		:= "lastore";
+	op[opc_fastore]		:= "fastore";
+	op[opc_dastore]		:= "dastore";
+	op[opc_aastore]		:= "aastore";
+	op[opc_bastore]		:= "bastore";
+	op[opc_castore]		:= "castore";
+	op[opc_sastore]		:= "sastore";
+	op[opc_pop]		:= "pop";
+	op[opc_pop2]		:= "pop2";
+	op[opc_dup]		:= "dup";
+	op[opc_dup_x1]		:= "dup_x1";
+	op[opc_dup_x2]		:= "dup_x2";
+	op[opc_dup2]		:= "dup2";
+	op[opc_dup2_x1]		:= "dup2_x1";
+	op[opc_dup2_x2]		:= "dup2_x2";
+	op[opc_swap]		:= "swap";
+	op[opc_iadd]		:= "iadd";
+	op[opc_ladd]		:= "ladd";
+	op[opc_fadd]		:= "fadd";
+	op[opc_dadd]		:= "dadd";
+	op[opc_isub]		:= "isub";
+	op[opc_lsub]		:= "lsub";
+	op[opc_fsub]		:= "fsub";
+	op[opc_dsub]		:= "dsub";
+	op[opc_imul]		:= "imul";
+	op[opc_lmul]		:= "lmul";
+	op[opc_fmul]		:= "fmul";
+	op[opc_dmul]		:= "dmul";
+	op[opc_idiv]		:= "idiv";
+	op[opc_ldiv]		:= "ldiv";
+	op[opc_fdiv]		:= "fdiv";
+	op[opc_ddiv]		:= "ddiv";
+	op[opc_irem]		:= "irem";
+	op[opc_lrem]		:= "lrem";
+	op[opc_frem]		:= "frem";
+	op[opc_drem]		:= "drem";
+	op[opc_ineg]		:= "ineg";
+	op[opc_lneg]		:= "lneg";
+	op[opc_fneg]		:= "fneg";
+	op[opc_dneg]		:= "dneg";
+	op[opc_ishl]		:= "ishl";
+	op[opc_lshl]		:= "lshl";
+	op[opc_ishr]		:= "ishr";
+	op[opc_lshr]		:= "lshr";
+	op[opc_iushr]		:= "iushr";
+	op[opc_lushr]		:= "lushr";
+	op[opc_iand]		:= "iand";
+	op[opc_land]		:= "land";
+	op[opc_ior]		:= "ior";
+	op[opc_lor]		:= "lor";
+	op[opc_ixor]		:= "ixor";
+	op[opc_lxor]		:= "lxor";
+	op[opc_iinc]		:= "iinc";
+	op[opc_i2l]		:= "i2l";
+	op[opc_i2f]		:= "i2f";
+	op[opc_i2d]		:= "i2d";
+	op[opc_l2i]		:= "l2i";
+	op[opc_l2f]		:= "l2f";
+	op[opc_l2d]		:= "l2d";
+	op[opc_f2i]		:= "f2i";
+	op[opc_f2l]		:= "f2l";
+	op[opc_f2d]		:= "f2d";
+	op[opc_d2i]		:= "d2i";
+	op[opc_d2l]		:= "d2l";
+	op[opc_d2f]		:= "d2f";
+	op[opc_i2b]		:= "i2b";
+	op[opc_i2c]		:= "i2c";
+	op[opc_i2s]		:= "i2s";
+	op[opc_lcmp]		:= "lcmp";
+	op[opc_fcmpl]		:= "fcmpl";
+	op[opc_fcmpg]		:= "fcmpg";
+	op[opc_dcmpl]		:= "dcmpl";
+	op[opc_dcmpg]		:= "dcmpg";
+	op[opc_ifeq]		:= "ifeq";
+	op[opc_ifne]		:= "ifne";
+	op[opc_iflt]		:= "iflt";
+	op[opc_ifge]		:= "ifge";
+	op[opc_ifgt]		:= "ifgt";
+	op[opc_ifle]		:= "ifle";
+	op[opc_if_icmpeq]	:= "if_icmpeq";
+	op[opc_if_icmpne]	:= "if_icmpne";
+	op[opc_if_icmplt]	:= "if_icmplt";
+	op[opc_if_icmpge]	:= "if_icmpge";
+	op[opc_if_icmpgt]	:= "if_icmpgt";
+	op[opc_if_icmple]	:= "if_icmple";
+	op[opc_if_acmpeq]	:= "if_acmpeq";
+	op[opc_if_acmpne]	:= "if_acmpne";
+	op[opc_goto]		:= "goto";
+	op[opc_jsr]		:= "jsr";
+	op[opc_ret]		:= "ret";
+	op[opc_tableswitch]	:= "tableswitch";
+	op[opc_lookupswitch]	:= "lookupswitch";
+	op[opc_ireturn]		:= "ireturn";
+	op[opc_lreturn]		:= "lreturn";
+	op[opc_freturn]		:= "freturn";
+	op[opc_dreturn]		:= "dreturn";
+	op[opc_areturn]		:= "areturn";
+	op[opc_return]		:= "return";
+	op[opc_getstatic]	:= "getstatic";
+	op[opc_putstatic]	:= "putstatic";
+	op[opc_getfield]	:= "getfield";
+	op[opc_putfield]	:= "putfield";
+	op[opc_invokevirtual]	:= "invokevirtual";
+	op[opc_invokespecial]	:= "invokespecial";
+	op[opc_invokestatic]	:= "invokestatic";
+	op[opc_invokeinterface]	:= "invokeinterface";
+	op[opc_xxxunusedxxx]	:= "xxxunusedxxx";
+	op[opc_new]		:= "new";
+	op[opc_newarray]	:= "newarray";
+	op[opc_anewarray]	:= "anewarray";
+	op[opc_arraylength]	:= "arraylength";
+	op[opc_athrow]		:= "athrow";
+	op[opc_checkcast]	:= "checkcast";
+	op[opc_instanceof]	:= "instanceof";
+	op[opc_monitorenter]	:= "monitorenter";
+	op[opc_monitorexit]	:= "monitorexit";
+	op[opc_wide]		:= "wide";
+	op[opc_multianewarray]	:= "multianewarray";
+	op[opc_ifnull]		:= "ifnull";
+	op[opc_ifnonnull]	:= "ifnonnull";
+	op[opc_goto_w]		:= "goto_w";
+	op[opc_jsr_w]		:= "jsr_w";
+	op[opc_breakpoint] 	:= "breakpoint";
+
+	dl[opc_nop] 		:= 0;
+	dl[opc_aconst_null]	:= 1;
+	dl[opc_iconst_m1]	:= 1;
+	dl[opc_iconst_0]	:= 1;
+	dl[opc_iconst_1]	:= 1;
+	dl[opc_iconst_2]	:= 1;
+	dl[opc_iconst_3]	:= 1;
+	dl[opc_iconst_4]	:= 1;
+	dl[opc_iconst_5]	:= 1;
+	dl[opc_lconst_0]	:= 2;
+	dl[opc_lconst_1]	:= 2;
+	dl[opc_fconst_0]	:= 1;
+	dl[opc_fconst_1]	:= 1;
+	dl[opc_fconst_2]	:= 1;
+	dl[opc_dconst_0]	:= 2;
+	dl[opc_dconst_1]	:= 2;
+	dl[opc_bipush]		:= 1;
+	dl[opc_sipush]		:= 1;
+	dl[opc_ldc]		:= 1;
+	dl[opc_ldc_w]		:= 1;
+	dl[opc_ldc2_w]		:= 2;
+	dl[opc_iload]		:= 1;
+	dl[opc_lload]		:= 2;
+	dl[opc_fload]		:= 1;
+	dl[opc_dload]		:= 2;
+	dl[opc_aload]		:= 1;
+	dl[opc_iload_0]		:= 1;
+	dl[opc_iload_1]		:= 1;
+	dl[opc_iload_2]		:= 1;
+	dl[opc_iload_3]		:= 1;
+	dl[opc_lload_0]		:= 2;
+	dl[opc_lload_1]		:= 2;
+	dl[opc_lload_2]		:= 2;
+	dl[opc_lload_3]		:= 2;
+	dl[opc_fload_0]		:= 1;
+	dl[opc_fload_1]		:= 1;
+	dl[opc_fload_2]		:= 1;
+	dl[opc_fload_3]		:= 1;
+	dl[opc_dload_0]		:= 2;
+	dl[opc_dload_1]		:= 2;
+	dl[opc_dload_2]		:= 2;
+	dl[opc_dload_3]		:= 2;
+	dl[opc_aload_0]		:= 1;
+	dl[opc_aload_1]		:= 1;
+	dl[opc_aload_2]		:= 1;
+	dl[opc_aload_3]		:= 1;
+	dl[opc_iaload]		:= -1;		(* pop 2, push 1 *)
+	dl[opc_laload]		:= 0;		(* pop 2, push 2 *)
+	dl[opc_faload]		:= -1;		(* pop 2, push 1 *)
+	dl[opc_daload]		:= 0;		(* pop 2, push 2 *)
+	dl[opc_aaload]		:= -1;		(* pop 2, push 1 *)
+	dl[opc_baload]		:= -1;		(* pop 2, push 1 *)
+	dl[opc_caload]		:= -1;		(* pop 2, push 1 *)
+	dl[opc_saload]		:= -1;		(* pop 2, push 1 *)
+	dl[opc_istore]		:= -1;
+	dl[opc_lstore]		:= -2;
+	dl[opc_fstore]		:= -1;
+	dl[opc_dstore]		:= -2;
+	dl[opc_astore]		:= -1;
+	dl[opc_istore_0]	:= -1;
+	dl[opc_istore_1]	:= -1;
+	dl[opc_istore_2]	:= -1;
+	dl[opc_istore_3]	:= -1;
+	dl[opc_lstore_0]	:= -2;
+	dl[opc_lstore_1]	:= -2;
+	dl[opc_lstore_2]	:= -2;
+	dl[opc_lstore_3]	:= -2;
+	dl[opc_fstore_0]	:= -1;
+	dl[opc_fstore_1]	:= -1;
+	dl[opc_fstore_2]	:= -1;
+	dl[opc_fstore_3]	:= -1;
+	dl[opc_dstore_0]	:= -2;
+	dl[opc_dstore_1]	:= -2;
+	dl[opc_dstore_2]	:= -2;
+	dl[opc_dstore_3]	:= -2;
+	dl[opc_astore_0]	:= -1;
+	dl[opc_astore_1]	:= -1;
+	dl[opc_astore_2]	:= -1;
+	dl[opc_astore_3]	:= -1;
+	dl[opc_iastore]		:= -3;
+	dl[opc_lastore]		:= -4;
+	dl[opc_fastore]		:= -3;
+	dl[opc_dastore]		:= -4;
+	dl[opc_aastore]		:= -3;
+	dl[opc_bastore]		:= -3;
+	dl[opc_castore]		:= -3;
+	dl[opc_sastore]		:= -3;
+	dl[opc_pop]		:= -1;
+	dl[opc_pop2]		:= -2;
+	dl[opc_dup]		:= 1;
+	dl[opc_dup_x1]		:= 1;
+	dl[opc_dup_x2]		:= 1;
+	dl[opc_dup2]		:= 2;
+	dl[opc_dup2_x1]		:= 2;
+	dl[opc_dup2_x2]		:= 2;
+	dl[opc_swap]		:= 0;
+	dl[opc_iadd]		:= -1;
+	dl[opc_ladd]		:= -2;
+	dl[opc_fadd]		:= -1;
+	dl[opc_dadd]		:= -2;
+	dl[opc_isub]		:= -1;
+	dl[opc_lsub]		:= -2;
+	dl[opc_fsub]		:= -1;
+	dl[opc_dsub]		:= -2;
+	dl[opc_imul]		:= -1;
+	dl[opc_lmul]		:= -2;
+	dl[opc_fmul]		:= -1;
+	dl[opc_dmul]		:= -2;
+	dl[opc_idiv]		:= -1;
+	dl[opc_ldiv]		:= -2;
+	dl[opc_fdiv]		:= -1;
+	dl[opc_ddiv]		:= -2;
+	dl[opc_irem]		:= -1;
+	dl[opc_lrem]		:= -2;
+	dl[opc_frem]		:= -1;
+	dl[opc_drem]		:= -2;
+	dl[opc_ineg]		:= 0;
+	dl[opc_lneg]		:= 0;
+	dl[opc_fneg]		:= 0;
+	dl[opc_dneg]		:= 0;
+	dl[opc_ishl]		:= -1;
+	dl[opc_lshl]		:= -2;
+	dl[opc_ishr]		:= -1;
+	dl[opc_lshr]		:= -1;
+	dl[opc_iushr]		:= -1;
+	dl[opc_lushr]		:= -1;
+	dl[opc_iand]		:= -1;
+	dl[opc_land]		:= -2;
+	dl[opc_ior]		:= -1;
+	dl[opc_lor]		:= -2;
+	dl[opc_ixor]		:= -1;
+	dl[opc_lxor]		:= -2;
+	dl[opc_iinc]		:= 0;
+	dl[opc_i2l]		:= 1;
+	dl[opc_i2f]		:= 0;
+	dl[opc_i2d]		:= 1;
+	dl[opc_l2i]		:= -1;
+	dl[opc_l2f]		:= -1;
+	dl[opc_l2d]		:= 0;
+	dl[opc_f2i]		:= 0;
+	dl[opc_f2l]		:= 1;
+	dl[opc_f2d]		:= 1;
+	dl[opc_d2i]		:= -1;
+	dl[opc_d2l]		:= 0;
+	dl[opc_d2f]		:= -1;
+	dl[opc_i2b]		:= 0;
+	dl[opc_i2c]		:= 0;
+	dl[opc_i2s]		:= 0;
+	dl[opc_lcmp]		:= -3;
+	dl[opc_fcmpl]		:= -1;
+	dl[opc_fcmpg]		:= -1;
+	dl[opc_dcmpl]		:= -3;
+	dl[opc_dcmpg]		:= -3;
+	dl[opc_ifeq]		:= -1;
+	dl[opc_ifne]		:= -1;
+	dl[opc_iflt]		:= -1;
+	dl[opc_ifge]		:= -1;
+	dl[opc_ifgt]		:= -1;
+	dl[opc_ifle]		:= -1;
+	dl[opc_if_icmpeq]	:= -2;
+	dl[opc_if_icmpne]	:= -2;
+	dl[opc_if_icmplt]	:= -2;
+	dl[opc_if_icmpge]	:= -2;
+	dl[opc_if_icmpgt]	:= -2;
+	dl[opc_if_icmple]	:= -2;
+	dl[opc_if_acmpeq]	:= -2;
+	dl[opc_if_acmpne]	:= -2;
+	dl[opc_goto]		:= 0;
+	dl[opc_jsr]		:= 1;
+	dl[opc_ret]		:= 0;
+	dl[opc_tableswitch]	:= -1;
+	dl[opc_lookupswitch]	:= -1;
+	dl[opc_ireturn]		:= -1;		(* don't care ? *)
+	dl[opc_lreturn]		:= -2;		(* don't care ? *)
+	dl[opc_freturn]		:= -1;		(* don't care ? *)
+	dl[opc_dreturn]		:= -2;		(* don't care ? *)
+	dl[opc_areturn]		:= -1;		(* don't care ? *)
+	dl[opc_return]		:= 0;		(* don't care ? *)
+
+	(* Defaults for single word load/store		     short Vs long *)
+	dl[opc_getstatic]	:= 1;		(* Special case  1 or  2 *)
+	dl[opc_putstatic]	:= -1;		(* Special case -1 or -2 *)
+	dl[opc_getfield]	:= 0;		(* Special case  0 or  1 *)
+	dl[opc_putfield]	:= -2;		(* Special case -2 or -3 *)
+
+	dl[opc_invokevirtual]	:= 0;		(* Special case *)
+	dl[opc_invokespecial]	:= -1;		(* Special case *)
+	dl[opc_invokestatic]	:= 0;		(* Special case *)
+	dl[opc_invokeinterface]	:= 0;		(* Special case *)
+	dl[opc_xxxunusedxxx]	:= 0;
+	dl[opc_new]		:= 1;
+	dl[opc_newarray]	:= 0;
+	dl[opc_anewarray]	:= 0;
+	dl[opc_arraylength]	:= 0;
+	dl[opc_athrow]		:= -1;		(* don't care *)
+	dl[opc_checkcast]	:= 0;
+	dl[opc_instanceof]	:= 0;
+	dl[opc_monitorenter]	:= -1;
+	dl[opc_monitorexit]	:= -1;
+	dl[opc_wide]		:= 0;
+	dl[opc_multianewarray]	:= 0;		(* Special case (1-dim#) *)
+	dl[opc_ifnull]		:= -1;
+	dl[opc_ifnonnull]	:= -1;
+	dl[opc_goto_w]		:= 0;
+	dl[opc_jsr_w]		:= 1;
+	dl[opc_breakpoint] 	:= 0;
+END JVMcodes.
+(* ============================================================ *)

gpcp/JasminAsm.cp

@@ -0,0 +1,18 @@
+(* ============================================================ *)
+(**	Interface to the Jasmin Byte-code assembler.		*)
+(*      Copyright (c) John Gough 1999, 2000.			*)
+(*	K John Gough, 10th June 1999				*)
+(*	Modifications:						*)
+(*		Version for GPCP V0.3 April 2000 (kjg)		*)
+(* ============================================================ *)
+(*	The real code is in JasminAsm.java			*)	
+(* ============================================================ *)
+
+FOREIGN MODULE JasminAsm;
+  IMPORT GPCPcopyright;
+
+  PROCEDURE Init*();
+
+  PROCEDURE Assemble*(IN fil : ARRAY OF CHAR);
+
+END JasminAsm.

gpcp/JavaBase.cp

@@ -0,0 +1,36 @@
+(* ============================================================ *)
+(*  JavaBase is the abstract class for java byte code emitters.	*)
+(*  The method Target.Select(mod, <name>) will allocate a 	*)
+(*  ClassMaker  object of an appropriate kind, and will call	*)
+(*	classMaker.Emit()					*)
+(*  Copyright (c) John Gough 1999, 2000. 			*)
+(*  Modified DWC September,2000		 			*)
+(* ============================================================ *)
+
+MODULE JavaBase;
+
+  IMPORT 
+	GPCPcopyright,
+	Console,
+	Ty := TypeDesc,
+	ClassMaker;
+	
+
+(* ============================================================ *)
+
+  TYPE
+    ClassEmitter* = POINTER TO ABSTRACT 
+ 		      RECORD (ClassMaker.ClassEmitter) END;
+
+(* ============================================================ *)
+(*  Not very elegant, but we need to get at the worklist from   *)
+(*  inside static procedures in JsmnUtil.			*)
+(* ============================================================ *)
+
+  VAR worklist*   : ClassEmitter;
+
+  PROCEDURE (list : ClassEmitter)AddNewRecEmitter*(rec : Ty.Record),NEW,EMPTY;
+
+(* ============================================================ *)
+END JavaBase.
+(* ============================================================ *)

gpcp/JavaMaker.cp

@@ -0,0 +1,3211 @@
+(* ============================================================ *)
+(*  JavaMaker is the concrete class for emitting java           *)
+(*  class files.						*)
+(*  Diane Corney - September,2000.                              *)
+(* ============================================================ *)
+
+MODULE JavaMaker;
+
+  IMPORT 
+        GPCPcopyright,
+        Error,
+        Console,
+        L := LitValue,
+        CPascalS,
+        FileNames,
+        CompState,
+        ClassMaker,
+        JavaBase,
+        GPBinFiles,
+        GPTextFiles,
+        Jvm := JVMcodes,
+        J := JavaUtil,
+        JasminAsm,
+        ClassUtil,
+        JsmnUtil,
+        G  := Builtin,
+        D  := Symbols,
+        Id := IdDesc,
+        Ty := TypeDesc,
+        Xp := ExprDesc,
+        St := StatDesc;
+
+(* ------------------------------------ *)
+
+  TYPE JavaWorkList* = 	
+        POINTER TO 
+          RECORD (JavaBase.ClassEmitter)
+         (* --------------------------- *
+          * mod* : Id.BlkId; 		*
+          * --------------------------- *)
+            tide : INTEGER;
+            high : INTEGER;
+            work : POINTER TO ARRAY OF JavaEmitter;
+          END;
+
+(* ------------------------------------ *)
+
+  TYPE JavaEmitter* = 	
+        POINTER TO ABSTRACT
+          RECORD (JavaBase.ClassEmitter)
+         (* --------------------------- *
+          * mod* : Id.BlkId; 		*
+          * --------------------------- *)
+            outF  : J.JavaFile;
+          END;
+
+(* ------------------------------------ *)
+
+  TYPE JavaModEmitter* = 	
+        POINTER TO 
+          RECORD (JavaEmitter);
+         (* --------------------------- *
+          * mod* : Id.BlkId; 		*
+          * outF : JavaBase.JavaFile;   *
+          * --------------------------- *)
+          END;
+
+(* ------------------------------------ *)
+
+  TYPE JavaRecEmitter* = 	
+        POINTER TO 
+          RECORD (JavaEmitter)
+         (* --------------------------- *
+          * mod* : Id.BlkId; 		*
+          * outF : J.JavaFile; 		*
+          * --------------------------- *)
+            recT : Ty.Record;
+          END;
+
+(* ------------------------------------ *)
+
+  TYPE JavaAssembler* = 	
+        POINTER TO 
+          RECORD (ClassMaker.Assembler)
+          END;
+
+
+(* ------------------------------------ *)
+
+  VAR
+        asmList : LitValue.CharOpenSeq;
+        currentLoopLabel : J.Label;
+
+(* ============================================================ *)
+
+  PROCEDURE Append(list : JavaWorkList; 
+        	   emit : JavaEmitter);
+    VAR temp : POINTER TO ARRAY OF JavaEmitter;
+        i    : INTEGER;
+  BEGIN
+    IF list.tide > list.high THEN (* must expand *)
+      temp := list.work;
+      list.high := list.high * 2 + 1;
+      NEW(list.work, (list.high+1));
+      FOR i := 0 TO list.tide-1 DO list.work[i] := temp[i] END;
+    END;
+    list.work[list.tide] := emit; INC(list.tide);
+  END Append;
+
+(* ============================================================ *)
+ 
+  PROCEDURE newJavaEmitter*(mod : Id.BlkId) : JavaWorkList;
+    VAR emitter : JavaWorkList;
+        modEmit : JavaModEmitter;
+        modName : LitValue.CharOpen;
+  BEGIN
+    modName := D.getName.ChPtr(mod);
+   (*
+    *  Allocate a new worklist object.
+    *)
+    NEW(emitter);
+    emitter.mod := mod;
+    NEW(emitter.work, 4);
+    emitter.tide := 0;
+    emitter.high := 3;
+    JavaBase.worklist := emitter;
+   (*
+    *  Allocate a JavaModEmitter to be first item
+    *  on the worklist.  All later items will be of
+    *  JavaRecEmitter type.
+    *)
+    NEW(modEmit);
+    modEmit.mod  := mod;
+   (*
+    *  Now append the mod-emitter to the worklist.
+    *)
+    Append(emitter, modEmit);
+    RETURN emitter;
+  END newJavaEmitter;
+
+(* ============================================================ *)
+
+  PROCEDURE newJavaAsm*() : JavaAssembler;
+    VAR asm : JavaAssembler;
+  BEGIN
+    NEW(asm);
+    LitValue.ResetCharOpenSeq(asmList);
+    RETURN asm;
+  END newJavaAsm;
+
+(* ============================================================ *)
+
+  PROCEDURE (list : JavaWorkList)AddNewRecEmitter*(inTp : Ty.Record);
+    VAR emit : JavaRecEmitter;
+        mNam : LitValue.CharOpen;
+        rNam : LitValue.CharOpen;
+  BEGIN
+    NEW(emit);
+    emit.mod  := list.mod;
+   (*
+    *  Set the current record type for this class.
+    *)
+    emit.recT := inTp;
+   (*
+    *  Now append the new RecEmitter to the worklist.
+    *)
+    Append(list, emit);
+  END AddNewRecEmitter;
+
+(* ============================================================ *)
+(*  Mainline emitter, consumes worklist emitting assembler	*)
+(*  files until the worklist is empty.				*)
+(* ============================================================ *)
+
+  PROCEDURE (this : JavaWorkList)Emit*();
+    VAR ix : INTEGER;
+  BEGIN
+   (*
+    *  First construct the base class-name string in the BlkId.
+    *)
+    J.Init();
+    J.MkBlkName(this.mod);
+
+    ix := 0;
+    WHILE ix < this.tide DO
+      this.work[ix].Emit();
+      INC(ix);
+    END;
+  END Emit;
+
+(* ============================================================ *)
+(*  Creates basic imports for java.lang, and inserts a few type *)
+(*  descriptors for Object, Exception, and String.		*)
+(* ============================================================ *)
+
+  PROCEDURE (this : JavaWorkList)Init*();
+    VAR tId : Id.TypId;
+        blk : Id.BlkId;
+        obj : Id.TypId;
+        cls : Id.TypId;
+        str : Id.TypId;
+        exc : Id.TypId;
+        xhr : Id.TypId;
+  BEGIN
+   (*
+    *  Create import descriptor for java.lang
+    *)
+    Builtin.MkDummyImport("java_lang", "java.lang", blk);
+   (*
+    *  Create various classes.
+    *)
+    Builtin.MkDummyClass("Object", blk, Ty.isAbs, obj);
+    CompState.ntvObj := obj.type;
+    Builtin.MkDummyClass("String", blk, Ty.noAtt, str);
+    CompState.ntvStr := str.type;
+    Builtin.MkDummyClass("Exception", blk, Ty.extns, exc);
+    CompState.ntvExc := exc.type;
+    Builtin.MkDummyClass("Class", blk, Ty.noAtt, cls);
+    CompState.ntvTyp := cls.type;
+   (*
+    *  Create import descriptor for CP.RTS
+    *)
+    Builtin.MkDummyImport("RTS", "", blk);
+    Builtin.MkDummyAlias("NativeType", blk, cls.type, CompState.clsId);
+    Builtin.MkDummyAlias("NativeObject", blk, obj.type, CompState.objId);
+    Builtin.MkDummyAlias("NativeString", blk, str.type, CompState.strId);
+    Builtin.MkDummyAlias("NativeException", blk, exc.type, CompState.excId);
+
+    Builtin.MkDummyVar("dblPosInfinity",blk,Builtin.realTp,CompState.dblInf);
+    Builtin.MkDummyVar("dblNegInfinity",blk,Builtin.realTp,CompState.dblNInf);
+    Builtin.MkDummyVar("fltPosInfinity",blk,Builtin.sReaTp,CompState.fltInf);
+    Builtin.MkDummyVar("fltNegInfinity",blk,Builtin.sReaTp,CompState.fltNInf);
+    INCL(blk.xAttr, D.need);
+   (*
+    *  Uplevel addressing stuff.
+    *)
+    Builtin.MkDummyImport("$CPJrts$", "CP.CPJrts", blk);
+    Builtin.MkDummyClass("XHR", blk, Ty.isAbs, xhr);
+    CompState.rtsXHR := xhr.type;
+    CompState.xhrId.recTyp := CompState.rtsXHR;
+    CompState.xhrId.type   := CompState.rtsXHR;
+  END Init;
+
+(* ============================================================ *)
+
+  PROCEDURE (this : JavaAssembler)Assemble*();
+    VAR ix : INTEGER;
+  BEGIN
+    FOR ix := 0 TO asmList.tide-1 DO
+      IF CompState.verbose THEN
+        CompState.Message("Assembling " + asmList.a[ix]^);
+      END;
+      JasminAsm.Assemble(asmList.a[ix]);
+    END;
+  END Assemble;
+
+(* ============================================================ *)
+
+  PROCEDURE (t : JavaEmitter)EmitBody(f : J.JavaFile),NEW,ABSTRACT;
+  PROCEDURE^ (e : JavaEmitter)EmitProc(proc : Id.Procs),NEW;
+  PROCEDURE^ (e : JavaEmitter)EmitStat(stat : D.Stmt; OUT ok : BOOLEAN),NEW;
+  PROCEDURE^ (e : JavaEmitter)PushCall(callX : Xp.CallX),NEW;
+  PROCEDURE^ (e : JavaEmitter)PushValue(exp : D.Expr; typ : D.Type),NEW;
+  PROCEDURE^ (e : JavaEmitter)FallFalse(exp : D.Expr; tLb : J.Label),NEW;
+  PROCEDURE^ (e : JavaEmitter)ValueCopy(act : D.Expr; fmT : D.Type),NEW;
+  PROCEDURE^ (e : JavaEmitter)PushArg(act : D.Expr;
+        			      frm : Id.ParId;
+        			  VAR seq : D.ExprSeq),NEW;
+
+(* ============================================================ *)
+
+  PROCEDURE (t : JavaRecEmitter)CopyProc(),NEW;
+    VAR out  : J.JavaFile;
+        junk : INTEGER;
+        indx : INTEGER;
+        idnt : D.Idnt;
+        fTyp : D.Type;
+        
+  BEGIN
+   (*
+    *   Emit the copy procedure "__copy__()
+    *)
+    out := t.outF;
+    out.CopyProcHead(t.recT);
+    junk := out.newLocal();	(* create space for two locals *)
+    junk := out.newLocal();
+   (*
+    *    Recurse to super class, if necessary.
+    *) 
+    IF (t.recT.baseTp # NIL) & 
+       (t.recT.baseTp IS Ty.Record) & 
+       ~t.recT.baseTp.isAbsRecType() THEN
+      out.Code(Jvm.opc_aload_0);
+      out.Code(Jvm.opc_aload_1);
+      out.ValRecCopy(t.recT.baseTp(Ty.Record));
+    END;
+   (*
+    *    Emit field-by-field copy.
+    *)
+    FOR indx := 0 TO t.recT.fields.tide-1 DO
+      idnt := t.recT.fields.a[indx];
+      fTyp := idnt.type;
+      out.Code(Jvm.opc_aload_0);
+      IF (fTyp.kind = Ty.recTp) OR 
+         (fTyp.kind = Ty.arrTp) THEN
+        out.PutGetF(Jvm.opc_getfield, t.recT, idnt(Id.FldId));
+      END;
+      out.Code(Jvm.opc_aload_1);
+      out.PutGetF(Jvm.opc_getfield, t.recT, idnt(Id.FldId));
+      WITH fTyp : Ty.Array DO 
+          out.ValArrCopy(fTyp);
+      | fTyp : Ty.Record DO
+          out.ValRecCopy(fTyp);
+      ELSE
+        out.PutGetF(Jvm.opc_putfield, t.recT, idnt(Id.FldId));
+      END;
+    END;
+    out.VoidTail();
+  END CopyProc;
+
+(* ============================================================ *)
+
+  PROCEDURE (this : JavaRecEmitter)EmitBody(out : J.JavaFile);
+  (** Create the assembler for a class file for this record. *)
+    VAR index  : INTEGER;
+        parIx  : INTEGER;
+        clsId  : D.Idnt;
+        ident  : D.Idnt;
+        ctorD  : Id.PrcId;
+        sCtor  : Id.PrcId;
+        sCtTy  : Ty.Procedure;
+        baseT  : D.Type;
+        field  : Id.FldId;
+        method : Id.MthId;
+        record : Ty.Record;
+        impRec : D.Idnt;
+        attr   : INTEGER;
+        form   : Id.ParId;
+        expr   : D.Expr;
+        live   : BOOLEAN;
+        retn   : D.Type;
+  BEGIN
+    record := this.recT;
+    out.StartRecClass(record); 
+   (*
+    *  Emit all the fields ...
+    *)
+    out.InitFields(record.fields.tide);
+    FOR index := 0 TO record.fields.tide-1 DO
+      out.EmitField(record.fields.a[index](Id.FldId));
+    END;
+    out.InitMethods(record.methods.tide+2);
+   (*
+    *  Emit the no-arg constructor
+    *)
+    IF ~(D.noNew IN record.xAttr) &
+       ~(D.xCtor IN record.xAttr) THEN
+      out.RecMakeInit(record, NIL);
+      out.CallSuperCtor(record, NIL);
+      out.VoidTail();
+    END;
+   (*
+    *  Emit constructors with args
+    *)
+    FOR index := 0 TO record.statics.tide-1 DO
+      sCtTy := NIL;
+      ctorD := record.statics.a[index](Id.PrcId);
+      out.RecMakeInit(record, ctorD);
+     (*
+      *  Copy args for super constructors with args.
+      *)
+      IF ctorD # NIL THEN
+        sCtor := ctorD.basCll.sprCtor(Id.PrcId);
+        IF sCtor # NIL THEN
+          sCtTy := sCtor.type(Ty.Procedure);
+          IF sCtTy.xName = NIL THEN J.MkCallAttr(sCtor, sCtTy) END;
+          FOR parIx := 0 TO ctorD.basCll.actuals.tide-1 DO
+            form := sCtTy.formals.a[parIx];
+            expr := ctorD.basCll.actuals.a[parIx];
+            this.PushArg(expr, form, ctorD.basCll.actuals);
+          END;
+        END;
+      END;
+     (*
+      *  Now call the super constructor
+      *)
+      out.CallSuperCtor(record, sCtTy);
+      IF (ctorD # NIL) & (ctorD.body # NIL) THEN
+        IF ctorD.rescue # NIL THEN out.Try END;
+        this.EmitStat(ctorD.body, live); 
+        IF ctorD.rescue # NIL THEN
+          out.Catch(ctorD);
+          this.EmitStat(ctorD.rescue, live);
+        END;
+      END;
+      out.EndProc();
+    END;
+    IF ~(D.noCpy IN record.xAttr) THEN this.CopyProc() END;
+   (*
+    *  Emit all the (non-forward) methods ...
+    *)
+    FOR index := 0 TO record.methods.tide-1 DO
+      ident  := record.methods.a[index];
+      method := ident(Id.MthId);
+      IF method.kind = Id.conMth THEN
+        this.EmitProc(method)
+      END;
+    END;
+  END EmitBody;
+
+(* ============================================================ *)
+
+  PROCEDURE (this : JavaModEmitter)EmitBody(out : J.JavaFile);
+  (** Create the assembler for a class file for this module. *)
+    VAR index : INTEGER;
+        objIx : INTEGER;
+        proc  : Id.Procs;
+        recT  : D.Type;
+        varId : Id.VarId;
+        returned : BOOLEAN;
+  BEGIN
+    out.StartModClass(this.mod);
+    FOR index := 0 TO this.mod.procs.tide-1 DO
+     (*
+      *  Create the mangled name for all non-forward procedures
+      *)
+      proc := this.mod.procs.a[index];
+      IF (proc.kind = Id.conPrc) OR 
+         (proc.kind = Id.conMth) THEN
+        J.MkProcName(proc);
+        J.RenumberLocals(proc);
+      END;
+    END;
+   (* 
+    *  Do all the fields (ie. static vars) 
+    *)
+    out.InitFields(this.mod.locals.tide);
+    FOR index := 0 TO this.mod.locals.tide-1 DO
+      varId := this.mod.locals.a[index](Id.VarId);
+      out.EmitField(varId);  
+    END;
+   (* 
+    *  Do all the procs, including <init> and <clinit> 
+    *)
+    out.InitMethods(this.mod.procs.tide+3);
+    out.ModNoArgInit();
+    out.ClinitHead();
+    out.InitVars(this.mod);
+    IF this.mod.main THEN
+     (*
+      *   Emit <clinit>, and module body as main() 
+      *)
+      out.VoidTail();
+      out.MainHead();
+      this.EmitStat(this.mod.modBody, returned);
+      IF returned THEN
+        this.EmitStat(this.mod.modClose, returned);
+      END;
+      out.VoidTail();
+    ELSE
+     (*
+      *   Emit single <clinit> incorporating module body
+      *)
+      this.EmitStat(this.mod.modBody, returned);
+      out.VoidTail();
+    END;
+   (* 
+    *  Emit all of the static procedures
+    *)
+    FOR index := 0 TO this.mod.procs.tide-1 DO
+      proc := this.mod.procs.a[index];
+      IF (proc.kind = Id.conPrc) &
+         (proc.dfScp.kind = Id.modId) THEN this.EmitProc(proc) END;
+    END;
+   (* 
+    *  And now, just in case exported types have been missed ...
+    *)
+    FOR index := 0 TO this.mod.expRecs.tide-1 DO
+      recT := this.mod.expRecs.a[index];
+      IF recT.xName = NIL THEN J.MkRecName(recT(Ty.Record)) END;
+    END;
+  END EmitBody;
+
+(* ============================================================ *)
+
+  PROCEDURE (this : JavaEmitter)Emit*();
+  (** Create the assembler for a class file for this module. *)
+  VAR fileName  : FileNames.NameString;
+      cf : ClassUtil.ClassFile;
+      jf : JsmnUtil.JsmnFile;
+  BEGIN
+   (*
+    *  Create the classFile structure, and open the output file.
+    *)
+    IF CompState.doCode & ~CompState.doJsmn THEN
+      WITH this : JavaModEmitter DO
+          L.ToStr(this.mod.xName, fileName);
+      | this : JavaRecEmitter DO
+          L.ToStr(this.recT.xName, fileName);
+      END;
+      fileName := fileName + ".class";
+      cf := ClassUtil.newClassFile(fileName);
+      this.outF := cf;
+    ELSE
+      WITH this : JavaModEmitter DO
+          D.getName.Of(this.mod, fileName);
+      | this : JavaRecEmitter DO
+          FileNames.StripUpToLast("/", this.recT.xName, fileName);
+      END;
+      fileName := fileName + ".j";
+      jf := JsmnUtil.newJsmnFile(fileName);
+      this.outF := jf;
+     (*
+      *   Add this file to the list to assemble
+      *)
+      LitValue.AppendCharOpen(asmList, LitValue.strToCharOpen(fileName));
+    END;
+    IF this.outF = NIL THEN
+      CPascalS.SemError.Report(177, 0, 0);
+      Error.WriteString("Cannot create out-file <" + fileName + ">");
+      Error.WriteLn;
+      RETURN;
+    ELSE
+      IF CompState.verbose THEN CompState.Message("Created "+ fileName) END;
+      this.outF.Header(CompState.srcNam);
+      this.EmitBody(this.outF);
+      this.outF.Dump();
+    END; 
+  END Emit;
+
+(* ============================================================ *)
+(*		Shared code-emission methods			*)
+(* ============================================================ *)
+
+  PROCEDURE (e : JavaEmitter)EmitProc(proc : Id.Procs),NEW;
+    VAR out  : J.JavaFile;
+        live : BOOLEAN;
+        retn : D.Type;
+        indx : INTEGER;
+        nest : Id.Procs;
+        procName : FileNames.NameString;
+  BEGIN
+   (*
+    *   Recursively emit nested procedures first.
+    *)
+    FOR indx := 0 TO proc.nestPs.tide-1 DO 
+      nest := proc.nestPs.a[indx];
+      IF nest.kind = Id.conPrc THEN e.EmitProc(nest) END;
+    END;
+    out := e.outF;
+    out.theP := proc;
+    out.StartProc(proc);
+   (*
+    *  Output the body if not ABSTRACT
+    *)
+    IF ~out.isAbstract() THEN
+     (*
+      *  Initialize any locals which need this.
+      *)
+      out.InitVars(proc);
+      IF proc.rescue # NIL THEN out.Try END;
+     (*
+      *  Finally! Emit the method body.
+      *)
+      e.EmitStat(proc.body, live);
+     (*
+      *  For proper procedure which reach the fall-
+      *  through ending, copy OUT params and return.
+      *)
+      IF live & proc.type.isProperProcType() THEN
+        out.FixOutPars(proc, retn);
+        out.Return(retn);
+      END;
+      IF proc.rescue # NIL THEN
+        out.Catch(proc);
+        e.EmitStat(proc.rescue, live);
+        IF live & proc.type.isProperProcType() THEN
+          out.FixOutPars(proc, retn);
+          out.Return(retn);
+        END;
+      END;
+    END;
+    out.EndProc();
+  END EmitProc;
+
+(* ============================================================ *)
+(*		    Expression Handling Methods			*)
+(* ============================================================ *)
+
+  PROCEDURE longValue(lit : D.Expr) : LONGINT;
+  BEGIN
+    RETURN lit(Xp.LeafX).value.long();
+  END longValue;
+
+  PROCEDURE intValue(lit : D.Expr) : INTEGER;
+  BEGIN
+    RETURN lit(Xp.LeafX).value.int();
+  END intValue;
+
+  PROCEDURE isStrExp(exp : D.Expr) : BOOLEAN;
+  BEGIN
+    RETURN (exp.type = G.strTp) & 
+           (exp.kind # Xp.mkStr) OR 
+            exp.type.isNativeStr();
+  END isStrExp;
+
+(* ============================================================ *)
+
+  PROCEDURE (e : JavaEmitter)UbyteClear(),NEW;
+    VAR out  : J.JavaFile;
+  BEGIN
+    out  := e.outF;
+    out.PushInt(255);
+    out.Code(Jvm.opc_iand);
+  END UbyteClear;
+
+(* ============================================================ *)
+
+  PROCEDURE (e : JavaEmitter)newLeaf(rd : INTEGER; tp : D.Type) : Xp.IdLeaf,NEW;
+    VAR id : Id.LocId;
+  BEGIN
+    id := Id.newLocId();
+    id.varOrd := rd;
+    id.type   := tp;
+    id.dfScp  := e.outF.getScope();
+    RETURN Xp.mkIdLeaf(id);
+  END newLeaf;
+
+(* ============================================================ *)
+
+   PROCEDURE RevTest(tst : INTEGER) : INTEGER;
+   BEGIN
+     CASE tst OF
+     | Xp.equal  : RETURN Xp.notEq;
+     | Xp.notEq  : RETURN Xp.equal;
+     | Xp.greT   : RETURN Xp.lessEq;
+     | Xp.lessT  : RETURN Xp.greEq;
+     | Xp.greEq  : RETURN Xp.lessT;
+     | Xp.lessEq : RETURN Xp.greT;
+     END;
+   END RevTest;
+
+(* ============================================================ *)
+
+  PROCEDURE (e : JavaEmitter)DoCmp(cmpE : INTEGER;
+                                   tLab : J.Label;
+                                   type : D.Type),NEW;
+   (**  Compare two TOS elems and jump to tLab if true. *)
+   (* ------------------------------------------------- *)
+    VAR out  : J.JavaFile;
+        code : INTEGER;
+        tNum : INTEGER;
+   (* ------------------------------------------------- *)
+    PROCEDURE test(t : INTEGER) : INTEGER;
+    BEGIN
+      CASE t OF
+      | Xp.greT   : RETURN Jvm.opc_ifgt;
+      | Xp.greEq  : RETURN Jvm.opc_ifge;
+      | Xp.notEq  : RETURN Jvm.opc_ifne;
+      | Xp.lessEq : RETURN Jvm.opc_ifle;
+      | Xp.lessT  : RETURN Jvm.opc_iflt;
+      | Xp.equal  : RETURN Jvm.opc_ifeq;
+      END;
+    END test;
+   (* ------------------------------------------------- *)
+  BEGIN
+    out  := e.outF;
+    code := test(cmpE);		(* default code *)
+    WITH type : Ty.Base DO
+      tNum := type.tpOrd;
+      CASE tNum OF
+      | Ty.strN, Ty.sStrN : out.CallRTS(J.StrCmp,2,1);
+      | Ty.realN : out.Code(Jvm.opc_dcmpl);
+      | Ty.sReaN : out.Code(Jvm.opc_fcmpl);
+      | Ty.lIntN : out.Code(Jvm.opc_lcmp);
+      | Ty.anyRec, Ty.anyPtr :
+          CASE cmpE OF
+          | Xp.notEq  : code := Jvm.opc_if_acmpne;
+          | Xp.equal  : code := Jvm.opc_if_acmpeq;
+          END;
+      ELSE (* Ty.boolN,Ty.sChrN,Ty.charN,Ty.byteN,Ty.sIntN,Ty.intN,Ty.setN *)
+          CASE cmpE OF
+          | Xp.greT   : code := Jvm.opc_if_icmpgt; (* override default code *)
+          | Xp.greEq  : code := Jvm.opc_if_icmpge;
+          | Xp.notEq  : code := Jvm.opc_if_icmpne;
+          | Xp.lessEq : code := Jvm.opc_if_icmple;
+          | Xp.lessT  : code := Jvm.opc_if_icmplt;
+          | Xp.equal  : code := Jvm.opc_if_icmpeq;
+          END;
+      END;
+    ELSE  (* This must be a reference or string comparison *)
+      IF type.isCharArrayType() THEN out.CallRTS(J.StrCmp,2,1);
+      ELSIF cmpE = Xp.equal     THEN code := Jvm.opc_if_acmpeq;
+      ELSIF cmpE = Xp.notEq     THEN code := Jvm.opc_if_acmpne;
+      END;
+    END;
+    out.CodeLb(code, tLab);
+  END DoCmp;
+
+(* ================= old code =========================== *
+ *  IF type IS Ty.Base THEN
+ *    tNum := type(Ty.Base).tpOrd;
+ *    IF (tNum = Ty.strN) OR (tNum = Ty.sStrN) THEN
+ *      out.CallRTS(J.StrCmp,2,1);
+ *    ELSIF tNum = Ty.realN THEN
+ *      out.Code(Jvm.opc_dcmpl);
+ *    ELSIF tNum = Ty.sReaN THEN
+ *      out.Code(Jvm.opc_fcmpl);
+ *    ELSIF tNum = Ty.lIntN THEN
+ *      out.Code(Jvm.opc_lcmp);
+ *    ELSE		(* Common, integer cases use separate instructions  *)
+ *      CASE cmpE OF
+ *      | Xp.greT   : code := Jvm.opc_if_icmpgt;	(* override default *)
+ *      | Xp.greEq  : code := Jvm.opc_if_icmpge;
+ *      | Xp.notEq  : code := Jvm.opc_if_icmpne;
+ *      | Xp.lessEq : code := Jvm.opc_if_icmple;
+ *      | Xp.lessT  : code := Jvm.opc_if_icmplt;
+ *      | Xp.equal  : code := Jvm.opc_if_icmpeq;
+ *      END;
+ *    END;
+ *  ELSE  (* This must be a reference or string comparison *)
+ *    IF type.isCharArrayType() THEN
+ *      out.CallRTS(J.StrCmp,2,1);
+ *    ELSIF cmpE = Xp.equal THEN
+ *      code := Jvm.opc_if_acmpeq;
+ *    ELSIF cmpE = Xp.notEq THEN
+ *      code := Jvm.opc_if_acmpne;
+ *    END;
+ *  END;
+ *  out.CodeLb(code, tLab);
+ *END DoCmp;
+ * ================= old code =========================== *)
+
+(* ---------------------------------------------------- *)
+
+  PROCEDURE (e : JavaEmitter)SetCmp(lOp,rOp : D.Expr; 
+                                    theLabl : J.Label;
+                                    theTest : INTEGER),NEW;
+    VAR out : J.JavaFile;
+        l,r : INTEGER;
+        xit : J.Label;
+  BEGIN
+    out := e.outF;
+    e.PushValue(lOp, G.setTp);
+    CASE theTest OF
+    (* ---------------------------------- *)
+    | Xp.equal: 
+        e.PushValue(rOp, G.setTp);
+        out.CodeLb(Jvm.opc_if_icmpeq, theLabl);
+    (* ---------------------------------- *)
+    | Xp.notEq : 
+        e.PushValue(rOp, G.setTp);
+        out.CodeLb(Jvm.opc_if_icmpne, theLabl);
+    (* ---------------------------------- *)
+    | Xp.greEq, Xp.lessEq : 
+       (*
+        *   The semantics are implemented by the identities
+        *
+        *   (L <= R) == (L AND R = L)
+        *   (L >= R) == (L OR  R = L)
+        *)
+        out.Code(Jvm.opc_dup);
+        e.PushValue(rOp, G.setTp);
+        IF theTest = Xp.greEq THEN
+          out.Code(Jvm.opc_ior);
+        ELSE
+          out.Code(Jvm.opc_iand);
+        END;
+        out.CodeLb(Jvm.opc_if_icmpeq, theLabl);
+    (* ---------------------------------- *)
+    | Xp.greT, Xp.lessT : 
+       (*
+        *   The semantics are implemented by the identities
+        *
+        *   (L < R) == (L AND R = L) AND NOT (L = R)
+        *   (L > R) == (L OR  R = L) AND NOT (L = R)
+        *)
+        l := out.newLocal();
+        r := out.newLocal();
+        xit := out.newLabel();
+        out.Code(Jvm.opc_dup);            (* ... L,L       *)
+        out.Code(Jvm.opc_dup);            (* ... L,L,L     *)
+        out.StoreLocal(l, G.setTp);       (* ... L,L,      *)
+        e.PushValue(rOp, G.setTp);        (* ... L,L,R     *)
+        out.Code(Jvm.opc_dup);            (* ... L,L,R,R   *)
+        out.StoreLocal(r, G.setTp);       (* ... L,L,R     *)
+        IF theTest = Xp.greT THEN        
+          out.Code(Jvm.opc_ior);          (* ... L,LvR     *)
+        ELSE
+          out.Code(Jvm.opc_iand);         (* ... L,L^R     *)
+        END; 
+        out.CodeLb(Jvm.opc_if_icmpne, xit);
+        out.LoadLocal(l, G.setTp);        (* ... L@R,l     *)
+        out.LoadLocal(r, G.setTp);        (* ... L@R,l,r   *)
+        out.CodeLb(Jvm.opc_if_icmpne, theLabl);
+        out.ReleaseLocal(r);
+        out.ReleaseLocal(l);
+        out.DefLab(xit);
+    END;
+  END SetCmp;
+
+(* ---------------------------------------------------- *)
+
+  PROCEDURE (e : JavaEmitter)BinCmp(exp : D.Expr; 
+        	                    tst : INTEGER;
+                                    rev : BOOLEAN;  (* reverse sense *)
+        			    lab : J.Label),NEW;
+    VAR binOp : Xp.BinaryX;
+        lType : D.Type;
+  BEGIN
+    binOp := exp(Xp.BinaryX);
+    lType := binOp.lKid.type;
+    IF rev THEN tst := RevTest(tst) END;
+    IF  lType = G.setTp THEN (* only partially ordered *)
+      e.SetCmp(binOp.lKid, binOp.rKid, lab, tst);
+    ELSE                      (* a totally ordered type *)
+      e.PushValue(binOp.lKid, lType);
+      IF isStrExp(binOp.lKid) THEN
+        e.outF.CallRTS(J.StrToChrOpen,1,1);
+      END;
+      e.PushValue(binOp.rKid, binOp.rKid.type);
+      IF isStrExp(binOp.rKid) THEN
+        e.outF.CallRTS(J.StrToChrOpen,1,1);
+      END;
+      e.DoCmp(tst, lab, lType);
+    END;
+  END BinCmp;
+
+(* ---------------------------------------------------- *)
+
+  PROCEDURE (e : JavaEmitter)FallTrue(exp : D.Expr; fLb : J.Label),NEW;
+   (** Evaluate exp, fall through if true, jump to fLab otherwise *)
+    VAR binOp : Xp.BinaryX;
+        label : J.Label;
+        out   : J.JavaFile;
+  BEGIN
+    out := e.outF;
+    CASE exp.kind OF
+    | Xp.tBool :				(* just do nothing *)
+    | Xp.fBool : 
+        out.CodeLb(Jvm.opc_goto, fLb);
+    | Xp.blNot :
+        e.FallFalse(exp(Xp.UnaryX).kid, fLb);
+    | Xp.greT, Xp.greEq, Xp.notEq, Xp.lessEq, Xp.lessT, Xp.equal :
+        e.BinCmp(exp, exp.kind, TRUE, fLb);
+    | Xp.blOr :
+        binOp := exp(Xp.BinaryX);
+        label := out.newLabel();
+        e.FallFalse(binOp.lKid, label);
+        e.FallTrue(binOp.rKid, fLb);
+        out.DefLab(label);
+    | Xp.blAnd :
+        binOp := exp(Xp.BinaryX);
+        e.FallTrue(binOp.lKid, fLb);
+        e.FallTrue(binOp.rKid, fLb);
+    | Xp.isOp :
+        binOp := exp(Xp.BinaryX);
+        e.PushValue(binOp.lKid, binOp.lKid.type);
+        out.CodeT(Jvm.opc_instanceof, binOp.rKid(Xp.IdLeaf).ident.type);
+        out.CodeLb(Jvm.opc_ifeq, fLb);
+    | Xp.inOp :
+        binOp := exp(Xp.BinaryX);
+        out.Code(Jvm.opc_iconst_1);
+        e.PushValue(binOp.lKid, binOp.lKid.type);
+        out.Code(Jvm.opc_ishl);
+        out.Code(Jvm.opc_dup);
+        e.PushValue(binOp.rKid, binOp.rKid.type);
+        out.Code(Jvm.opc_iand);
+        out.CodeLb(Jvm.opc_if_icmpne, fLb);
+    ELSE (* Xp.fnCll, Xp.qualId, Xp.index, Xp.selct  *)
+      e.PushValue(exp, exp.type);		(* boolean variable *)
+      out.CodeLb(Jvm.opc_ifeq, fLb);
+    END;
+  END FallTrue;
+
+(* ---------------------------------------------------- *)
+
+  PROCEDURE (e : JavaEmitter)FallFalse(exp : D.Expr; tLb : J.Label),NEW;
+   (** Evaluate exp, fall through if false, jump to tLb otherwise *)
+    VAR binOp : Xp.BinaryX;
+        label : J.Label;
+        out   : J.JavaFile;
+  BEGIN
+    out := e.outF;
+    CASE exp.kind OF
+    | Xp.fBool :				(* just do nothing *)
+    | Xp.tBool : 
+        out.CodeLb(Jvm.opc_goto, tLb);
+    | Xp.blNot :
+        e.FallTrue(exp(Xp.UnaryX).kid, tLb);
+    | Xp.greT, Xp.greEq, Xp.notEq, Xp.lessEq, Xp.lessT, Xp.equal :
+        e.BinCmp(exp, exp.kind, FALSE, tLb);
+    | Xp.blOr :
+        binOp := exp(Xp.BinaryX);
+        e.FallFalse(binOp.lKid, tLb);
+        e.FallFalse(binOp.rKid, tLb);
+    | Xp.blAnd :
+        label := out.newLabel();
+        binOp := exp(Xp.BinaryX);
+        e.FallTrue(binOp.lKid, label);
+        e.FallFalse(binOp.rKid, tLb);
+        out.DefLab(label);
+    | Xp.isOp :
+        binOp := exp(Xp.BinaryX);
+        e.PushValue(binOp.lKid, binOp.lKid.type);
+        out.CodeT(Jvm.opc_instanceof, binOp.rKid(Xp.IdLeaf).ident.type);
+        out.CodeLb(Jvm.opc_ifne, tLb);
+    | Xp.inOp :
+        binOp := exp(Xp.BinaryX);
+        out.Code(Jvm.opc_iconst_1);
+        e.PushValue(binOp.lKid, binOp.lKid.type);
+        out.Code(Jvm.opc_ishl);
+        out.Code(Jvm.opc_dup);
+        e.PushValue(binOp.rKid, binOp.rKid.type);
+        out.Code(Jvm.opc_iand);
+        out.CodeLb(Jvm.opc_if_icmpeq, tLb);
+    ELSE (* Xp.fnCll, Xp.qualId, Xp.index, Xp.selct  *)
+      e.PushValue(exp, exp.type);		(* boolean variable *)
+      out.CodeLb(Jvm.opc_ifne, tLb);
+    END;
+  END FallFalse;
+
+(* ============================================================ *)
+
+  PROCEDURE (e : JavaEmitter)PushUnary(exp : Xp.UnaryX; dst : D.Type),NEW;
+    VAR dNum : INTEGER;
+        code : INTEGER;
+        labl : J.Label;
+        out  : J.JavaFile;
+  (* ------------------------------------- *)
+    PROCEDURE MkBox(emt : JavaEmitter; exp : Xp.UnaryX);
+      VAR dst : D.Type;
+          src : D.Type;
+          out : J.JavaFile;
+    BEGIN
+      out := emt.outF;
+      src := exp.kid.type;
+      dst := exp.type(Ty.Pointer).boundTp;
+      IF isStrExp(exp.kid) THEN
+        emt.PushValue(exp.kid, src);
+        out.CallRTS(J.StrToChrOpen,1,1);
+      ELSE 
+        emt.ValueCopy(exp.kid, dst);
+      END;
+    END MkBox;
+  (* ------------------------------------- *)
+  BEGIN
+    IF exp.kind = Xp.mkBox THEN MkBox(e,exp); RETURN END; (* PRE-EMPTIVE RET *)
+    e.PushValue(exp.kid, exp.kid.type);
+    out := e.outF;
+    CASE exp.kind OF
+    | Xp.mkStr, Xp.deref : (* skip *)
+    | Xp.tCheck :
+  	out.CodeT(Jvm.opc_checkcast, exp.type.boundRecTp()(Ty.Record));
+    | Xp.mkNStr :
+        IF ~isStrExp(exp.kid) THEN 
+          out.CallRTS(J.ChrsToStr,1,1);
+        END;
+    | Xp.strChk :			(* Some range checks required *)
+        out.Code(Jvm.opc_dup);
+        out.CallRTS(J.StrCheck,1,0);	
+    | Xp.compl :
+        out.Code(Jvm.opc_iconst_m1);
+        out.Code(Jvm.opc_ixor);
+    | Xp.neg :
+        dNum := dst(Ty.Base).tpOrd;
+        IF    dNum = Ty.realN THEN
+          code := Jvm.opc_dneg;
+        ELSIF dNum = Ty.sReaN THEN
+          code := Jvm.opc_fneg;
+        ELSIF dNum = Ty.lIntN THEN
+          code := Jvm.opc_lneg;
+        ELSE 				(* all INTEGER cases *)
+          code := Jvm.opc_ineg;
+        END;
+        out.Code(code);
+    | Xp.absVl :
+        dNum := dst(Ty.Base).tpOrd;
+        IF    dNum = Ty.realN THEN
+          out.Code(Jvm.opc_dup2);
+          out.Code(Jvm.opc_dconst_0);
+          out.Code(Jvm.opc_dcmpg);
+          code := Jvm.opc_dneg;
+        ELSIF dNum = Ty.sReaN THEN
+          out.Code(Jvm.opc_dup);
+          out.Code(Jvm.opc_fconst_0);
+          out.Code(Jvm.opc_fcmpg);
+          code := Jvm.opc_fneg;
+        ELSIF dNum = Ty.lIntN THEN
+          out.Code(Jvm.opc_dup2);
+          out.Code(Jvm.opc_lconst_0);
+          out.Code(Jvm.opc_lcmp);
+          code := Jvm.opc_lneg;
+        ELSE 				(* all INTEGER cases *)
+          out.Code(Jvm.opc_dup);
+          code := Jvm.opc_ineg; 
+        END;
+        labl := out.newLabel();
+        out.CodeLb(Jvm.opc_ifge, labl);	(* NOT ifle, Aug2001 *)
+        out.Code(code);
+        out.DefLab(labl);
+    | Xp.entVl :
+        dNum := dst(Ty.Base).tpOrd;
+        IF dNum = Ty.sReaN THEN out.Code(Jvm.opc_f2d) END;
+         (*
+         // We _could_ check if the value is >= 0.0, and 
+         // skip the call in that case, falling through
+         // into the round-to-zero mode opc_d2l.
+         *)
+          out.CallRTS(J.DFloor,1,1);	
+          out.Code(Jvm.opc_d2l);
+    | Xp.capCh :
+        out.CallRTS(J.ToUpper,1,1);	
+    | Xp.blNot :
+        out.Code(Jvm.opc_iconst_1);
+        out.Code(Jvm.opc_ixor); 
+    | Xp.strLen :
+        out.CallRTS(J.StrLen,1,1);	
+    | Xp.oddTst :
+        IF exp.kid.type.isLongType() THEN out.Code(Jvm.opc_l2i) END;
+        out.Code(Jvm.opc_iconst_1);
+        out.Code(Jvm.opc_iand); 
+    | Xp.getTp :
+        out.CallGetClass();
+    END;
+  END PushUnary;
+
+(* ============================================================ *)
+
+  PROCEDURE (e : JavaEmitter)PushVecElemHandle(lOp,rOp : D.Expr),NEW;
+    VAR vTp : Ty.Vector;
+        eTp : D.Type;
+        tde : INTEGER;
+        out : J.JavaFile;
+        xLb : J.Label;
+  BEGIN
+    out := e.outF;
+    vTp := lOp.type(Ty.Vector);
+    eTp := vTp.elemTp;
+    tde := out.newLocal();
+    xLb := out.newLabel();
+
+    e.PushValue(lOp, eTp);              (* vRef ...                *)
+    out.Code(Jvm.opc_dup);              (* vRef, vRef ...          *)
+    out.GetVecLen();                    (* tide, vRef ...          *)
+    out.StoreLocal(tde, G.intTp);       (* vRef ...                *)
+
+    e.outF.GetVecArr(eTp);              (* arr ...                 *)
+    e.PushValue(rOp, G.intTp);          (* idx, arr ...            *)
+    out.Code(Jvm.opc_dup);              (* idx, idx, arr ...       *)
+    out.LoadLocal(tde, G.intTp);        (* tide, idx, idx, arr ... *)
+
+    out.CodeLb(Jvm.opc_if_icmplt, xLb);
+    out.Trap("Vector index out of bounds");
+
+    out.DefLab(xLb);                    (* idx, arr ...            *)
+    out.ReleaseLocal(tde);
+  END PushVecElemHandle;
+
+(* ============================================================ *)
+
+  PROCEDURE (e : JavaEmitter)PushBinary(exp : Xp.BinaryX; dst : D.Type),NEW;
+    VAR out  : J.JavaFile;
+        lOp  : D.Expr;
+        rOp  : D.Expr;
+        eTp  : D.Type;
+
+        dNum : INTEGER;
+        sNum : INTEGER;
+        code : INTEGER;
+        indx : INTEGER;
+        rLit : LONGINT;
+        exLb : J.Label;
+        tpLb : J.Label;
+        long : BOOLEAN;
+    (* -------------------------------- *)
+    PROCEDURE plusCode(tNnm : INTEGER) : INTEGER;
+    BEGIN
+      CASE tNnm OF
+      | Ty.realN : RETURN Jvm.opc_dadd;
+      | Ty.sReaN : RETURN Jvm.opc_fadd;
+      | Ty.lIntN : RETURN Jvm.opc_ladd;
+      ELSE         RETURN Jvm.opc_iadd;
+      END;
+    END plusCode;
+    (* -------------------------------- *)
+    PROCEDURE minusCode(tNnm : INTEGER) : INTEGER;
+    BEGIN
+      CASE tNnm OF
+      | Ty.realN : RETURN Jvm.opc_dsub;
+      | Ty.sReaN : RETURN Jvm.opc_fsub;
+      | Ty.lIntN : RETURN Jvm.opc_lsub;
+      ELSE         RETURN Jvm.opc_isub;
+      END;
+    END minusCode;
+    (* -------------------------------- *)
+    PROCEDURE multCode(tNnm : INTEGER) : INTEGER;
+    BEGIN
+      CASE tNnm OF
+      | Ty.realN : RETURN Jvm.opc_dmul;
+      | Ty.sReaN : RETURN Jvm.opc_fmul;
+      | Ty.lIntN : RETURN Jvm.opc_lmul;
+      ELSE         RETURN Jvm.opc_imul;
+      END;
+    END multCode;
+    (* -------------------------------- *)
+  BEGIN (* PushBinary *)
+    out := e.outF;
+    lOp := exp.lKid;
+    rOp := exp.rKid;
+    CASE exp.kind OF
+    (* -------------------------------- *)
+    | Xp.index :
+        IF exp.lKid.type IS Ty.Vector THEN
+          e.PushVecElemHandle(lOp, rOp);
+          out.GetVecElement(dst);                 (* load the element   *)
+(* 
+ *        vTp := lOp.type(Ty.Vector);
+ *        e.PushValue(lOp, lOp.type);             (* push array designator*)
+ *        out.GetVecArr(vTp.elemTp);
+ *        e.PushValue(rOp, rOp.type);             (* push index value   *)
+ *        out.GetVecElement(vTp.elemTp);          (* load the element   *)
+ *)
+        ELSE
+          e.PushValue(lOp, lOp.type);             (* push arr. desig.   *)
+          e.PushValue(rOp, rOp.type);             (* push index value   *)
+(*
+ *        out.GetElement(dst);                    (* load the element   *)
+ *)
+          out.GetElement(lOp.type(Ty.Array).elemTp);  (* load the element   *)
+          IF dst = Builtin.uBytTp THEN e.UbyteClear() END;
+        END;
+    (* -------------------------------- *)
+    | Xp.range :                                (* set i..j range ...	*)
+       (* We want to create an integer with bits--	*)
+       (*      [0...01...10...0]			*)
+       (* MSB==31    j   i    0==LSB			*)
+       (* One method is A				*)
+       (* 1)   [0..010........0]  1 << (j+1)		*)
+       (* 2)   [1..110........0]  negate(1)		*)
+       (* 3)   [0.......010...0]  1 << i		*)
+       (* 4)   [1.......110...0]  negate(3)		*)
+       (* 5)   [0...01...10...0]  (2)xor(4)		*)
+       (* Another method is B				*)
+       (* 1)   [1.............1]  -1			*)
+       (* 2)   [0...01........1]  (1) >>> (31-j)	*)
+       (* 3)   [0........01...1]  (2) >> i		*)
+       (* 4)   [0...01...10...0]  (3) << i		*)
+       (* --------------------------------------------- *
+        *      (*					*
+        *	* Method A				*
+        *	*)					*
+        *	out.Code(Jvm.opc_iconst_1);		*
+        *	out.Code(Jvm.opc_iconst_1);		*
+        *	e.PushValue(rOp, G.intTp);		*
+        *      (* Do unsigned less than 32 test here *)	*
+        *	out.Code(Jvm.opc_iadd);			*
+        *	out.Code(Jvm.opc_ishl);			*
+        *	out.Code(Jvm.opc_ineg);			*
+        *	out.Code(Jvm.opc_iconst_1);		*
+        *	e.PushValue(lOp, G.intTp);		*
+        *      (* Do unsigned less than 32 test here *) *
+        *	out.Code(Jvm.opc_ishl);			*
+        *	out.Code(Jvm.opc_ineg);			*
+        *	out.Code(Jvm.opc_ixor);			*
+        * -------------------------------------------- *)
+       (*
+        * Method B
+        *)
+        IF rOp.kind = Xp.numLt THEN
+          (* out.PushInt(-1 >>> (31 - intValue(rOp))); *)
+          out.PushInt(ORD({0 .. intValue(rOp)}));
+        ELSE
+          out.Code(Jvm.opc_iconst_m1);
+          out.PushInt(31);
+          e.PushValue(rOp, G.intTp);
+         (* Do unsigned less than 32 test here ...*)
+          out.Code(Jvm.opc_isub);
+          out.Code(Jvm.opc_iushr);
+        END;
+        IF lOp.kind = Xp.numLt THEN
+          (* out.PushInt(-1 << intValue(lOp)); *)
+          out.PushInt(ORD({intValue(lOp) .. 31}));
+          out.Code(Jvm.opc_iand);
+        ELSE
+          e.PushValue(lOp, G.intTp);
+         (* Do unsigned less than 32 test here ...*)
+          out.Code(Jvm.opc_dup_x1);
+          out.Code(Jvm.opc_ishr);
+          out.Code(Jvm.opc_swap);
+          out.Code(Jvm.opc_ishl);
+        END;
+    (* -------------------------------- *)
+    | Xp.lenOf :
+        e.PushValue(lOp, lOp.type);
+        IF lOp.type IS Ty.Vector THEN
+          out.GetVecLen();
+        ELSE
+          FOR indx := 0 TO intValue(rOp) - 1 DO
+            out.Code(Jvm.opc_iconst_0);
+            out.Code(Jvm.opc_aaload);
+          END;
+          out.Code(Jvm.opc_arraylength);
+        END;
+    (* -------------------------------- *)
+    | Xp.maxOf, Xp.minOf :
+        long := dst.isLongType();
+        tpLb := out.newLabel();
+        exLb := out.newLabel();
+       (*
+        * Push left operand, duplicate
+        * stack is (top) lOp lOp ...
+        *)
+        e.PushValue(lOp, dst);
+        IF long THEN 
+          out.Code(Jvm.opc_dup2);
+        ELSE 
+          out.Code(Jvm.opc_dup);
+        END;
+       (*
+        * Push right operand
+        * stack is (top) rOp lOp lOp ...
+        *)
+        e.PushValue(rOp, dst); 
+       (*
+        * Duplicate and stow
+        * stack is (top) rOp lOp rOp lOp ...
+        *)
+        IF long THEN 
+          out.Code(Jvm.opc_dup2_x2);
+        ELSE 
+          out.Code(Jvm.opc_dup_x1);
+        END;
+       (*
+        *  Compare two top items and jump
+        *  stack is (top) rOp lOp ...
+        *)
+        IF exp.kind = Xp.maxOf THEN
+          e.DoCmp(Xp.lessT, tpLb, dst);
+        ELSE
+          e.DoCmp(Xp.greT, tpLb, dst);
+        END;
+        indx := out.getDepth();
+       (*
+        *  Discard top item
+        *  stack is (top) lOp ...
+        *)
+        IF long THEN 
+          out.Code(Jvm.opc_pop2);
+        ELSE 
+          out.Code(Jvm.opc_pop);
+        END;
+        out.CodeLb(Jvm.opc_goto, exLb);
+        out.DefLab(tpLb);
+        out.setDepth(indx);
+       (*
+        *  Swap top two items and discard top
+        *  stack is (top) rOp ...
+        *)
+        IF long THEN
+          out.Code(Jvm.opc_dup2_x2);
+          out.Code(Jvm.opc_pop2);
+          out.Code(Jvm.opc_pop2);
+        ELSE
+          out.Code(Jvm.opc_swap);
+          out.Code(Jvm.opc_pop);
+        END;
+        out.DefLab(exLb);
+    (* -------------------------------- *)
+    | Xp.bitAnd :
+        e.PushValue(lOp, dst);
+        e.PushValue(rOp, dst);
+       (*
+        *  A literal bitAnd might be a long
+        *  operation, from a folded MOD.
+        *)
+        IF dst.isLongType() THEN
+          out.Code(Jvm.opc_land);
+        ELSE
+          out.Code(Jvm.opc_iand);
+        END;
+    (* -------------------------------- *)
+    | Xp.bitOr :
+        e.PushValue(lOp, dst);
+        e.PushValue(rOp, dst);
+        out.Code(Jvm.opc_ior);
+    (* -------------------------------- *)
+    | Xp.bitXor :
+        e.PushValue(lOp, dst);
+        e.PushValue(rOp, dst);
+        out.Code(Jvm.opc_ixor);
+    (* -------------------------------- *)
+    | Xp.plus :
+        dNum := dst(Ty.Base).tpOrd;
+        e.PushValue(lOp, dst);
+        e.PushValue(rOp, dst);
+        out.Code(plusCode(dNum));
+    (* -------------------------------- *)
+    | Xp.minus :
+        dNum := dst(Ty.Base).tpOrd;
+        e.PushValue(lOp, dst);
+        e.PushValue(rOp, dst);
+        out.Code(minusCode(dNum));
+    (* -------------------------------- *)
+    | Xp.mult :
+        dNum := dst(Ty.Base).tpOrd;
+        e.PushValue(lOp, dst);
+        e.PushValue(rOp, dst);
+        out.Code(multCode(dNum));
+    (* -------------------------------- *)
+    | Xp.slash :
+        e.PushValue(lOp, dst);
+        e.PushValue(rOp, dst);
+        out.Code(Jvm.opc_ddiv);
+    (* -------------------------------- *)
+    | Xp.modOp :
+        dNum := dst(Ty.Base).tpOrd;
+        e.PushValue(lOp, dst);
+        e.PushValue(rOp, dst);
+        IF dNum = Ty.lIntN THEN
+          out.CallRTS(J.ModL,4,2);
+        ELSE
+          out.CallRTS(J.ModI,2,1);
+        END;
+    (* -------------------------------- *)
+    | Xp.divOp :
+(*
+ *	dNum := dst(Ty.Base).tpOrd;
+ *	e.PushValue(lOp, dst);
+ *	e.PushValue(rOp, dst);
+ *	IF dNum = Ty.lIntN THEN
+ *	  out.CallRTS(J.DivL,4,2);
+ *	ELSE
+ *	  out.CallRTS(J.DivI,2,1);
+ *	END;
+ *
+ *  Alternative, inline code ...
+ *)
+        e.PushValue(lOp, dst);
+        long := dst(Ty.Base).tpOrd = Ty.lIntN;
+        IF (rOp.kind = Xp.numLt) & (longValue(rOp) > 0) THEN
+          tpLb := out.newLabel();
+          IF long THEN
+            rLit := longValue(rOp);
+            out.Code(Jvm.opc_dup2);
+            out.PushLong(0);
+            out.Code(Jvm.opc_lcmp);
+            out.CodeLb(Jvm.opc_ifge, tpLb);
+            out.PushLong(rLit-1);
+            out.Code(Jvm.opc_lsub);
+            out.DefLab(tpLb);
+            out.PushLong(rLit);
+            out.Code(Jvm.opc_ldiv);
+          ELSE
+            indx := intValue(rOp);
+            out.Code(Jvm.opc_dup);
+            out.CodeLb(Jvm.opc_ifge, tpLb);
+            out.PushInt(indx-1);
+            out.Code(Jvm.opc_isub);
+            out.DefLab(tpLb);
+            out.PushInt(indx);
+            out.Code(Jvm.opc_idiv);
+          END;
+        ELSE
+          e.PushValue(rOp, dst);
+          IF long THEN
+            out.CallRTS(J.DivL,4,2);
+          ELSE
+            out.CallRTS(J.DivI,2,1);
+          END;
+        END;
+    (* -------------------------------- *)
+    | Xp.rem0op :
+        dNum := dst(Ty.Base).tpOrd;
+        e.PushValue(lOp, dst);
+        e.PushValue(rOp, dst);
+        IF dNum = Ty.lIntN THEN
+          out.Code(Jvm.opc_lrem);
+        ELSE
+          out.Code(Jvm.opc_irem);
+        END;
+    (* -------------------------------- *)
+    | Xp.div0op :
+        dNum := dst(Ty.Base).tpOrd;
+        e.PushValue(lOp, dst);
+        e.PushValue(rOp, dst);
+        IF dNum = Ty.lIntN THEN
+          out.Code(Jvm.opc_ldiv);
+        ELSE
+          out.Code(Jvm.opc_idiv);
+        END;
+    (* -------------------------------- *)
+    | Xp.blOr,  Xp.blAnd,  Xp.greT,  Xp.greEq, 
+      Xp.notEq, Xp.lessEq, Xp.lessT, Xp.equal, Xp.inOp :
+        tpLb := out.newLabel();
+        exLb := out.newLabel();
+       (* 
+        *  Jumping code is mandated for blOr and blAnd...
+        * 
+        *  For the Relational Ops this next seems crude, but
+        *  appears to be the only way that the JVM allows
+        *  construction of boolean values.
+        *)
+        e.FallTrue(exp, tpLb);
+        out.Code(Jvm.opc_iconst_1);
+        out.CodeLb(Jvm.opc_goto, exLb);
+        out.DefLab(tpLb);
+        out.Code(Jvm.opc_iconst_0);
+        out.DefLab(exLb);
+    (* -------------------------------- *)
+    | Xp.isOp :
+        e.PushValue(lOp, lOp.type);
+        out.CodeT(Jvm.opc_instanceof, rOp(Xp.IdLeaf).ident.type);
+    (* -------------------------------- *)
+    | Xp.ashInt :
+        e.PushValue(lOp, lOp.type);
+        IF rOp.kind = Xp.numLt THEN
+          indx := intValue(rOp);
+          IF indx = 0 THEN  (* skip *)
+          ELSIF indx < 0 THEN
+            out.PushInt(-indx);
+           (*
+            *  A literal, negative ASH might be
+            *  a long operation from a folded DIV.
+            *)
+            IF dst.isLongType() THEN out.Code(Jvm.opc_lshr);
+            ELSE out.Code(Jvm.opc_ishr);
+            END;
+          ELSE
+            out.PushInt(indx);
+            out.Code(Jvm.opc_ishl);
+          END;
+        ELSE
+          tpLb := out.newLabel();
+          exLb := out.newLabel();
+         (*
+          *  This is a variable shift. Do it the hard way.
+          *  First, check the sign of the right hand op.
+          *)
+          e.PushValue(rOp, rOp.type);
+          out.Code(Jvm.opc_dup);
+          out.CodeLb(Jvm.opc_iflt, tpLb);
+         (*
+          *  Positive selector ==> shift left;
+          *)
+          out.Code(Jvm.opc_ishl);
+          out.CodeLb(Jvm.opc_goto, exLb);
+         (*
+          *  Negative selector ==> shift right;
+          *)
+          out.DefLab(tpLb);
+          out.Code(Jvm.opc_ineg);
+          out.Code(Jvm.opc_ishr);
+          out.DefLab(exLb);
+        END;
+    (* -------------------------------- *)
+    | Xp.strCat :
+        e.PushValue(lOp, lOp.type);
+        e.PushValue(rOp, rOp.type);
+        IF (lOp.type = G.strTp) &
+           (lOp.kind # Xp.mkStr) OR 
+            lOp.type.isNativeStr() THEN
+          IF (rOp.type = G.strTp) &
+             (rOp.kind # Xp.mkStr) OR 
+              rOp.type.isNativeStr() THEN
+            out.CallRTS(J.StrCatSS,2,1);
+          ELSE
+            out.CallRTS(J.StrCatSA, 2, 1);
+          END;
+        ELSE
+          IF (rOp.type = G.strTp) &
+             (rOp.kind # Xp.mkStr) OR 
+              rOp.type.isNativeStr() THEN
+            out.CallRTS(J.StrCatAS, 2, 1);
+          ELSE
+            out.CallRTS(J.StrCatAA, 2, 1);
+          END;
+        END;
+    (* -------------------------------- *)
+    END;
+  END PushBinary;
+
+(* ============================================================ *)
+
+  PROCEDURE (e : JavaEmitter)PushValue(exp : D.Expr; typ : D.Type),NEW;
+    VAR out : J.JavaFile;
+        rec : Ty.Record;
+        ix  : INTEGER;
+        elm : D.Expr;
+        emt : BOOLEAN;		(* ==> more than one set element expr *)
+  BEGIN
+    out := e.outF;
+    WITH exp : Xp.IdLeaf DO
+        IF exp.isProcLit() THEN
+          ASSERT(FALSE);
+        ELSIF exp.kind = Xp.typOf THEN
+          out.LoadType(exp.ident);
+        ELSE
+          out.GetVar(exp.ident);
+          IF typ = Builtin.uBytTp THEN e.UbyteClear() END;
+        END;
+    | exp : Xp.SetExp DO
+        emt := TRUE;
+       (*
+        *   Write out the constant part, if there is one.
+        *)
+        IF exp.value # NIL THEN
+          out.PushInt(exp.value.int()); (* const part *)
+          emt := FALSE;
+        END;
+       (*
+        *   Write out the element expressions.
+        *   taking the union with any part emitted already.
+        *)
+        FOR ix := 0 TO exp.varSeq.tide-1 DO
+          elm := exp.varSeq.a[ix];
+          IF elm.kind = Xp.range THEN
+            e.PushValue(elm, G.intTp);
+          ELSE
+            out.PushInt(1);
+            e.PushValue(exp.varSeq.a[ix], G.intTp);
+            out.Code(Jvm.opc_ishl);
+          END;
+          IF ~emt THEN out.Code(Jvm.opc_ior) END;
+          emt := FALSE;
+        END;
+       (*
+        *   If neither of the above emitted anything, emit zero!
+        *)
+        IF emt THEN out.Code(Jvm.opc_iconst_0) END;
+    | exp : Xp.LeafX DO
+        CASE exp.kind OF
+        | Xp.tBool  : out.Code(Jvm.opc_iconst_1);
+        | Xp.fBool  : out.Code(Jvm.opc_iconst_0);
+        | Xp.nilLt  : out.Code(Jvm.opc_aconst_null);
+        | Xp.charLt : out.PushInt(ORD(exp.value.char()));
+        | Xp.setLt  : out.PushInt(exp.value.int());
+        | Xp.numLt  : 
+            IF typ = G.lIntTp THEN
+              out.PushLong(exp.value.long());
+            ELSE
+              out.PushInt(exp.value.int());
+            END;
+        | Xp.realLt : 
+            IF typ = G.realTp THEN
+              out.PushReal(exp.value.real());
+            ELSE
+              out.PushSReal(exp.value.real());
+            END;
+        | Xp.strLt  :
+            IF typ = G.charTp THEN
+              out.PushInt(ORD(exp.value.chr0()));
+            ELSE
+              out.PushStr(exp.value.chOpen());
+            END;
+        | Xp.infLt  :
+            IF typ = G.realTp THEN
+              out.GetVar(CompState.dblInf);
+            ELSE
+              out.GetVar(CompState.fltInf);
+            END;
+        | Xp.nInfLt :
+            IF typ = G.realTp THEN
+              out.GetVar(CompState.dblNInf);
+            ELSE
+              out.GetVar(CompState.fltNInf);
+            END;
+        END;
+    | exp : Xp.CallX DO
+        e.PushCall(exp);
+    | exp : Xp.IdentX DO
+        e.PushValue(exp.kid, exp.kid.type);
+        IF exp.kind = Xp.selct THEN
+          rec := exp.kid.type(Ty.Record);
+          out.PutGetF(Jvm.opc_getfield, rec, exp.ident(Id.FldId));
+          IF typ = Builtin.uBytTp THEN e.UbyteClear() END;
+        ELSIF exp.kind = Xp.cvrtUp THEN
+          out.ConvertUp(exp.kid.type, typ);
+        ELSIF exp.kind = Xp.cvrtDn THEN
+          out.ConvertDn(exp.kid.type, typ);
+  	END;
+    | exp : Xp.UnaryX DO
+        e.PushUnary(exp, typ);
+    | exp : Xp.BinaryX DO
+        e.PushBinary(exp, typ);
+    END;
+  END PushValue;
+
+(* ---------------------------------------------------- *)
+
+  PROCEDURE SwapHandle(out : J.JavaFile; exp : D.Expr; long : BOOLEAN);
+   (* Precondition: exp must be a variable designator 		*)
+   (* A value is below a handle of 0,1,2 words. Swap val to top *)
+    VAR hSiz : INTEGER;
+        idnt : D.Idnt;
+        type : D.Type;
+  BEGIN
+    type := exp.type;
+    IF (type IS Ty.Record) OR 
+       ((type IS Ty.Array) & (type.kind # Ty.vecTp)) THEN
+      hSiz := 1;
+    ELSE
+      WITH exp : Xp.IdLeaf DO
+        idnt := exp.ident;
+        WITH idnt : Id.LocId DO
+          IF Id.uplevA IN idnt.locAtt THEN hSiz := 1 ELSE hSiz := 0 END;
+        ELSE 
+          hSiz := 0;
+        END;
+      | exp : Xp.BinaryX DO
+        hSiz := 2;
+      ELSE
+        hSiz := 1;
+      END;					(* -------------------- *)
+    END;					(* -------------------- *)
+        					(*  Before ==>  After	*)
+    IF hSiz = 1 THEN				(* -------------------- *)
+      IF ~long THEN 				(* [hndl]  ==>	[valu]	*)
+        out.Code(Jvm.opc_swap);			(* [valu]	[hndl]	*)
+        					(* -------------------- *)
+      ELSE  					(* [hndl]  ==>	[val2]	*)
+        out.Code(Jvm.opc_dup_x2);		(* [val2]	[val1]	*)
+        out.Code(Jvm.opc_pop);			(* [val1]	[hndl]	*)
+      END;					(* -------------------- *)
+    ELSIF hSiz = 2 THEN				(* -------------------- *)
+      IF ~long THEN 				(* [indx]  ==>	[valu]	*)
+        out.Code(Jvm.opc_dup2_x1);		(* [hndl]	[indx]	*)
+        out.Code(Jvm.opc_pop2);			(* [valu]	[hndl]	*)
+        					(* -------------------- *)
+      ELSE  					(* [indx]  ==>	[val2]	*)
+        out.Code(Jvm.opc_dup2_x2);		(* [hdnl]	[val1]	*)
+        out.Code(Jvm.opc_pop2);			(* [val2]	[indx]	*)
+      END;					(* [val1]	[hndl]	*)
+    (* ELSE nothing to do *) 			(* -------------------- *)
+    END;
+  END SwapHandle;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE (e : JavaEmitter)PushHandle(exp : D.Expr; typ : D.Type),NEW;
+   (* Precondition: exp must be a variable designator 		*)
+    VAR idnt : D.Idnt;
+  BEGIN
+    ASSERT(exp.isVarDesig());
+    IF (typ IS Ty.Record) OR ((typ IS Ty.Array) & (typ.kind # Ty.vecTp)) THEN
+      e.PushValue(exp, typ);
+    ELSE
+      WITH exp : Xp.IdentX DO
+          e.PushValue(exp.kid, exp.kid.type);
+      | exp : Xp.BinaryX DO
+          IF exp.lKid.type IS Ty.Vector THEN
+            e.PushVecElemHandle(exp.lKid, exp.rKid);
+(*
+ *          e.PushValue(exp.lKid, exp.lKid.type);
+ *          e.outF.GetVecArr(exp.lKid.type(Ty.Vector).elemTp);
+ *          e.PushValue(exp.rKid, G.intTp);
+ *)
+          ELSE
+            e.PushValue(exp.lKid, exp.lKid.type);
+            e.PushValue(exp.rKid, G.intTp);
+          END;
+      | exp : Xp.IdLeaf DO
+          idnt := exp.ident;
+          WITH idnt : Id.LocId DO (* check if implemented inside XHR *)
+            IF Id.uplevA IN idnt.locAtt THEN e.outF.XhrHandle(idnt) END;
+          ELSE (* skip *)
+          END;
+      END;
+    END;
+  END PushHandle;
+
+(* ---------------------------------------------------- *)
+
+  PROCEDURE (e : JavaEmitter)ScalarAssign(exp : D.Expr),NEW;
+    VAR out : J.JavaFile;
+        rec : Ty.Record;
+  BEGIN
+    out := e.outF;
+    WITH exp : Xp.IdLeaf DO
+        (* stack has ... value, (top)	*)
+        out.PutVar(exp.ident);
+    | exp : Xp.IdentX DO
+        (* stack has ... obj-ref, value, (top)	*)
+        rec := exp.kid.type(Ty.Record);
+        out.PutGetF(Jvm.opc_putfield, rec, exp.ident(Id.FldId));
+    | exp : Xp.BinaryX DO
+        (* stack has ... arr-ref, index, value, (top)	*)
+        IF exp.lKid.type IS Ty.Vector THEN
+          out.PutVecElement(exp.type);
+        ELSE
+          out.PutElement(exp.type);
+        END;
+    ELSE
+      Console.WriteString("BAD SCALAR ASSIGN"); Console.WriteLn;
+      exp.Diagnose(0);
+      ASSERT(FALSE);
+    END;
+  END ScalarAssign;
+
+(* ---------------------------------------------------- *)
+
+  PROCEDURE (e : JavaEmitter)ValueCopy(act : D.Expr; fmT : D.Type),NEW;
+    VAR out : J.JavaFile;
+  BEGIN
+   (*
+    *  Copy this actual, where fmT is either an array or record.
+    *)
+    out := e.outF;
+    WITH fmT : Ty.Record DO
+      out.MkNewRecord(fmT);			(* (top) dst...		*)
+      out.Code(Jvm.opc_dup);			(* (top) dst,dst...	*)
+      e.PushValue(act, fmT);			(* (top) src,dst,dst...	*)
+      out.ValRecCopy(fmT);			(* (top) dst...		*)
+    | fmT : Ty.Array DO
+     (*
+      *  Array case: ordinary value copy
+      *)
+      IF fmT.length = 0 THEN 			(* open array case	*)
+        e.PushValue(act, fmT);			(* (top) src...		*)
+        out.Code(Jvm.opc_dup);			(* (top) src,src...	*)
+        IF act.kind = Xp.mkStr THEN
+          out.CallRTS(J.StrLP1,1,1);		(* (top) len,src...	*)
+          out.Alloc1d(G.charTp);		(* (top) dst,src...	*)
+        ELSE
+          out.MkArrayCopy(fmT);			(* (top) dst,src...	*)
+        END;
+        out.Code(Jvm.opc_dup_x1);    		(* dst,src,dst...	*)
+        out.Code(Jvm.opc_swap);			(* (top) src,dst,dst...	*)
+      ELSE 					(* fixed array case 	*)
+        out.MkNewFixedArray(fmT.elemTp, fmT.length);	
+        out.Code(Jvm.opc_dup);			(* (top) dst,dst...	*)
+        e.PushValue(act, fmT);			(* (top) src,dst,dst...	*)
+      END;
+      IF act.kind = Xp.mkStr THEN
+        out.CallRTS(J.StrVal, 2, 0);		(* (top) dst...		*)
+      ELSE
+        out.ValArrCopy(fmT);			(* (top) dst...		*)
+      END;
+    ELSE
+      e.PushValue(act, fmT);
+    END;
+  END ValueCopy;
+
+(* ---------------------------------------------------- *)
+
+  PROCEDURE (e : JavaEmitter)StringCopy(act : D.Expr; fmT : Ty.Array),NEW;
+    VAR out : J.JavaFile;
+  BEGIN
+    out := e.outF;
+    IF act.kind = Xp.mkStr THEN
+      e.ValueCopy(act, fmT);
+    ELSIF fmT.length = 0 THEN 		(* str passed to open array 	*)
+      e.PushValue(act, fmT);
+      out.CallRTS(J.StrToChrOpen,1,1);
+    ELSE				(* str passed to fixed array	*)
+      out.MkNewFixedArray(G.charTp, fmT.length);	
+      out.Code(Jvm.opc_dup);
+      e.PushValue(act, fmT); 
+      out.CallRTS(J.StrToChrs,2,0);
+    END;
+  END StringCopy;
+
+(* ============================================================ *)
+
+  PROCEDURE (e : JavaEmitter)Invoke(exp : D.Expr; typ : Ty.Procedure),NEW;
+    VAR code : INTEGER;
+        prcI : Id.PrcId;
+        mthI : Id.MthId;
+  BEGIN
+    WITH exp : Xp.IdLeaf DO (* qualid *)
+        prcI := exp.ident(Id.PrcId);
+        IF prcI.kind = Id.ctorP THEN
+          code := Jvm.opc_invokespecial;
+        ELSE
+          code := Jvm.opc_invokestatic;
+        END;
+        e.outF.CallIT(code, prcI, typ);
+    | exp : Xp.IdentX DO (* selct *)
+        mthI := exp.ident(Id.MthId);
+        IF exp.kind = Xp.sprMrk THEN 
+          code := Jvm.opc_invokespecial;
+        ELSIF mthI.bndType.isInterfaceType() THEN
+          code := Jvm.opc_invokeinterface;
+        ELSE 
+          code := Jvm.opc_invokevirtual;
+        END;
+        e.outF.CallIT(code, mthI, typ);
+        IF Id.covar IN mthI.mthAtt THEN
+          e.outF.CodeT(Jvm.opc_checkcast, typ.retType);
+        END;
+    END;
+  END Invoke;
+
+(* ---------------------------------------------------- *)
+
+  PROCEDURE (e : JavaEmitter)PushAndGetReturn(act : D.Expr;
+        					typ : D.Type;
+        			            OUT ret : D.Expr),NEW;
+   (* ------------------------- *)
+    VAR out   : J.JavaFile;
+        local : INTEGER;
+        recXp : D.Expr;
+        array : D.Expr;
+        index : D.Expr;
+   (* ----------------------------------------- *)
+    PROCEDURE simple(x : D.Expr) : BOOLEAN;
+    BEGIN
+      IF x.kind = Xp.deref THEN x := x(Xp.UnaryX).kid END;
+      RETURN x IS Xp.LeafX;	(* IdLeaf or LeafX *)
+    END simple;
+   (* ----------------------------------------- *)
+  BEGIN
+   (*
+    *  Assert: the expression is a (possibly complex)
+    *  variable designator. Is some part of the handle
+    *  worth saving? Note saving is mandatory for calls.
+    *)
+    out := e.outF;
+    ret := act;
+    WITH act : Xp.IdLeaf DO
+       (*
+        *  This is a simple variable. Result will be
+        *  stored directly using the same expression.
+        *)
+        e.PushValue(act, typ); 
+    | act : Xp.IdentX DO
+        ASSERT(act.kind = Xp.selct);
+       (*
+        *  This is a field select.  If the handle is
+        *  sufficiently complicated it will be saved.
+        *)
+        recXp := act.kid;
+        e.PushValue(recXp, recXp.type);
+        IF ~simple(recXp) THEN 
+          local := out.newLocal();
+          out.Code(Jvm.opc_dup);
+          out.StoreLocal(local, NIL);
+         (*
+          *  The restore expression is a mutated 
+          *  version of the original expression.
+          *)
+          act.kid := e.newLeaf(local, recXp.type);
+          act.kid.type := recXp.type;
+        END;
+        out.PutGetF(Jvm.opc_getfield, 
+        			recXp.type(Ty.Record), act.ident(Id.FldId));
+    | act : Xp.BinaryX DO
+        ASSERT(act.kind = Xp.index);
+       (*
+        *  This is an index select.  If the handle, or
+        *  index (or both) are complicated they are saved.
+        *)
+        array := act.lKid;
+        index := act.rKid;
+        e.PushValue(array, array.type);
+        IF simple(array) THEN		(* don't save handle  *)
+          e.PushValue(index, G.intTp);
+          IF ~simple(index) THEN	(* must save index    *)
+            local := out.newLocal();
+            out.Code(Jvm.opc_dup);
+            out.StoreLocal(local, G.intTp); (* #### *)
+            act.rKid := e.newLeaf(local, G.intTp);
+            act.rKid.type := G.intTp;
+          END;
+        ELSE				(* must save handle   *)
+          local := out.newLocal();
+          out.Code(Jvm.opc_dup);
+          out.StoreLocal(local, NIL);
+          act.lKid := e.newLeaf(local, array.type);
+          act.lKid.type := array.type;
+          e.PushValue(index, G.intTp);
+          IF ~simple(index) THEN	(* save index as well *)
+            local := out.newLocal();
+            out.Code(Jvm.opc_dup);
+            out.StoreLocal(local, G.intTp); (* #### *)
+            act.rKid := e.newLeaf(local, G.intTp);
+            act.rKid.type := G.intTp;
+          END;
+        END;
+        out.GetElement(typ);
+    ELSE
+      act.Diagnose(0); THROW("Bad PushAndGetReturn");
+    END;
+  END PushAndGetReturn;
+
+(* ---------------------------------------------------- *)
+
+  PROCEDURE (e : JavaEmitter)PushArg(act : D.Expr;
+        			     frm : Id.ParId;
+        			 VAR seq : D.ExprSeq),NEW;
+   (* ------------------------- *)
+    VAR idExp : Xp.IdentX;
+        out   : J.JavaFile;
+        local : INTEGER;
+   (* ----------------------------------------- *)
+    PROCEDURE boxNumber(exp : D.Expr) : INTEGER;
+    BEGIN
+      RETURN exp(Xp.IdLeaf).ident(Id.ParId).boxOrd;
+    END boxNumber;
+   (* ----------------------------------------- *)
+    PROCEDURE boxedPar(exp : D.Expr) : BOOLEAN;
+      VAR idnt : D.Idnt;
+    BEGIN
+      WITH exp : Xp.IdLeaf DO
+        idnt := exp.ident;
+        WITH idnt : Id.ParId DO
+          RETURN (idnt.boxOrd # J.retMarker) & J.needsBox(idnt);
+        ELSE 
+          RETURN FALSE;
+        END;
+      ELSE 
+        RETURN FALSE;
+      END;
+    END boxedPar;
+   (* ----------------------------------------- *)
+  BEGIN
+    out := e.outF;
+    IF J.needsBox(frm) THEN (* value is returned *)
+      NEW(idExp);
+      idExp.ident := frm;
+      IF frm.parMod = D.out THEN (* no value push *)
+        idExp.kid := act;
+      ELSE
+        e.PushAndGetReturn(act, frm.type, idExp.kid);
+      END;
+      IF frm.boxOrd # J.retMarker THEN 
+       (* ==> out value but not in return slot *)
+        frm.rtsTmp := out.newLocal();
+        IF boxedPar(act) THEN
+          out.LoadLocal(boxNumber(act), NIL);
+        ELSE
+          out.MkNewFixedArray(frm.type, 1);
+        END;
+        out.Code(Jvm.opc_dup);
+        out.StoreLocal(frm.rtsTmp, NIL);
+      END;
+      D.AppendExpr(seq, idExp);
+    ELSIF (frm.type IS Ty.Array) &
+          ((act.type = G.strTp) OR act.type.isNativeStr()) THEN
+      e.StringCopy(act, frm.type(Ty.Array));    (* special string case	*)
+    ELSIF (frm.parMod = D.val) &
+          ((frm.type IS Ty.Record) OR 
+(*
+           (frm.type IS Ty.Array)) THEN		(* value-par copy case	*)
+ *)
+(* #### *)
+           ((frm.type IS Ty.Array) & (frm.type.kind # Ty.vecTp))) THEN
+(* #### *)
+      e.ValueCopy(act, frm.type);
+    ELSE
+      e.PushValue(act, frm.type);
+    END;
+  END PushArg;
+
+(* ---------------------------------------------------- *)
+
+  PROCEDURE (e : JavaEmitter)CopyOut(exp : D.Expr; idD : D.Idnt),NEW;
+    VAR out : J.JavaFile;
+        par : Id.ParId;
+  BEGIN
+   (* Assert : this is an unboxed type *)
+    out := e.outF;
+    par := idD(Id.ParId);
+    e.PushHandle(exp, par.type);
+    IF par.boxOrd # J.retMarker THEN 
+      out.LoadLocal(par.rtsTmp, NIL);
+      out.Code(Jvm.opc_iconst_0);
+      out.GetElement(par.type);
+    ELSE (* result is below handle *)
+      SwapHandle(out, exp, par.type.isLongType());
+    END;
+    e.ScalarAssign(exp);
+  END CopyOut;
+
+(* ============================================================ *)
+(*    Possible structures of procedure call expressions are:	*)
+(* ============================================================ *)
+(*	    o				    o			*)
+(*   	   /			   	   /			*)
+(*	[CallX] 			[CallX] 		*)
+(*	 / +--- actuals --> ...          / +--- actuals 	*)
+(*	/				/			*)
+(*    [IdentX]			    [IdLeaf]			*)
+(*      /  +--- ident ---> [Procs]      +--- ident ---> [PrcId]	*)
+(*     /							*)
+(* kid expr							*)
+(*								*)
+(* ============================================================ *)
+(*  only the right hand case can be a standard proc or function	*)
+(* ============================================================ *)
+
+  PROCEDURE (e : JavaEmitter)PushCall(callX : Xp.CallX),NEW;
+    VAR jFile : J.JavaFile;
+        mark0 : INTEGER;	(* local ord limit on entry *)
+        tide0 : INTEGER;	(* parameter tide on entry  *)
+        index : INTEGER;	(* just a counter for loops *)
+        formT : Ty.Procedure;	(* formal type of procedure *)
+        formP : Id.ParId;	(* current formal parameter *)
+        prExp : D.Expr;
+        idExp : Xp.IdentX;
+ (* ---------------------------------------------------- *)
+    PROCEDURE CheckCall(expr : D.Expr; pTyp : Ty.Procedure);
+      VAR prcI : Id.PrcId;
+          mthI : Id.MthId;
+    BEGIN
+      WITH expr : Xp.IdLeaf DO (* qualid *)
+          prcI := expr.ident(Id.PrcId);
+          IF pTyp.xName = NIL THEN J.MkCallAttr(prcI, pTyp) END;
+      | expr : Xp.IdentX DO (* selct *)
+          mthI := expr.ident(Id.MthId);
+          IF pTyp.xName = NIL THEN J.MkCallAttr(mthI, pTyp) END;
+      END;
+    END CheckCall;
+ (* ---------------------------------------------------- *)
+    PROCEDURE isNested(exp : Xp.IdLeaf) : BOOLEAN;
+    BEGIN
+      RETURN exp.ident(Id.PrcId).lxDepth > 0;
+    END isNested;
+ (* ---------------------------------------------------- *)
+  BEGIN
+    jFile := e.outF;
+    mark0 := jFile.markTop();
+    tide0 := callX.actuals.tide;
+    prExp := callX.kid;
+    formT := prExp.type(Ty.Procedure);
+   (*
+    *  Before we push any arguments, we must ensure that
+    *  the formal-type name is computed, and the first
+    *  out-value is moved to the return-slot, if possible.
+    *)
+    CheckCall(prExp, formT);
+   (*
+    *  We must first deal with the receiver if this is a method.
+    *)
+    IF formT.receiver # NIL THEN
+      idExp := prExp(Xp.IdentX);
+      formP := idExp.ident(Id.MthId).rcvFrm;
+      e.PushArg(idExp.kid, formP, callX.actuals);
+    ELSE
+      WITH prExp : Xp.IdLeaf DO
+        IF prExp.ident.kind = Id.ctorP THEN
+          jFile.CodeT(Jvm.opc_new, callX.type);
+          jFile.Code(Jvm.opc_dup);
+        ELSIF isNested(prExp) THEN
+          jFile.PushStaticLink(prExp.ident(Id.Procs));
+        END;
+      ELSE (* skip *)
+      END;
+    END;
+   (*
+    *  We push the arguments from left to right.
+    *  New IdentX expressions are appended to the argument 
+    *  list to describe how to save any returned values.
+    *)
+    FOR index := 0 TO tide0-1 DO
+      formP := formT.formals.a[index];
+      e.PushArg(callX.actuals.a[index], formP, callX.actuals);
+    END;
+   (*
+    *  Now emit the actual call instruction(s)
+    *)
+    e.Invoke(prExp, formT);
+   (*
+    *  Now we save any out arguments from the appended exprs.
+    *)
+    FOR index := tide0 TO callX.actuals.tide-1 DO
+      prExp := callX.actuals.a[index]; 
+      idExp := prExp(Xp.IdentX);
+      e.CopyOut(idExp.kid, idExp.ident);
+    END;
+    jFile.ReleaseAll(mark0);
+   (*
+    *  Normally an CallX expression can only be evaluated once,
+    *  so it does not matter if PushCall() is not idempotent.
+    *  However, there is a pathological case if a predicate in a
+    *  while loop has a function call with OUT formals. Since the
+    *  GPCP method of laying out while loops evaluates the test 
+    *  twice, the actual list must be reset to its original length.
+    *)
+    callX.actuals.ResetTo(tide0);
+  END PushCall;
+
+(* ---------------------------------------------------- *)
+
+  PROCEDURE IncByLit(out : J.JavaFile; ord : INTEGER; inc : INTEGER);
+  BEGIN
+    IF (ord < 256) & (inc >= -128) & (inc <= 127) THEN
+      out.CodeInc(ord, inc);
+    ELSE
+      out.LoadLocal(ord, G.intTp);
+      out.PushInt(inc);
+      out.Code(Jvm.opc_iadd);
+      out.StoreLocal(ord, G.intTp);
+    END;
+  END IncByLit;
+
+  PROCEDURE LitIncLocal(out : J.JavaFile; proc, vOrd, incr : INTEGER);
+  BEGIN
+    IF proc = G.decP THEN incr := -incr END;
+    IncByLit(out, vOrd, incr);
+  END LitIncLocal;
+
+  (* ------------------------------------------ *)
+
+  PROCEDURE (e : JavaEmitter)EmitStdProc(callX : Xp.CallX),NEW;
+    CONST fMsg = "Assertion failure ";
+    VAR out  : J.JavaFile;
+        prId : Id.PrcId;
+        flId : Id.FldId;
+        pOrd : INTEGER;
+        arg0 : D.Expr;
+        argX : D.Expr;
+        dstT : D.Type;
+        idX0 : D.Idnt;
+        argN : INTEGER;
+        numL : INTEGER;
+        incr : INTEGER;
+        vRef : INTEGER;
+        tide : INTEGER;
+        okLb : J.Label;
+        long : BOOLEAN;
+        c    : INTEGER;
+  BEGIN
+    out  := e.outF;
+    prId := callX.kid(Xp.IdLeaf).ident(Id.PrcId);
+    arg0 := callX.actuals.a[0];	(* Always need at least one arg *)
+    argN := callX.actuals.tide;
+
+    pOrd := prId.stdOrd;
+    CASE pOrd OF
+   (* --------------------------- *)
+    | G.asrtP :
+        okLb := out.newLabel();
+        e.FallFalse(arg0, okLb);
+       (*
+        *   If expression evaluates to false, fall
+        *   into the error code, else skip to okLb.
+        *)
+        IF argN > 1 THEN
+          numL := intValue(callX.actuals.a[1]);
+          out.Trap(fMsg + LitValue.intToCharOpen(numL)^);
+        ELSE
+          numL := callX.token.lin;
+          out.Trap(fMsg + CompState.srcNam +":"+ LitValue.intToCharOpen(numL)^);
+        END;
+        out.DefLab(okLb);
+   (* --------------------------- *)
+    | G.incP, G.decP :
+        argX := callX.actuals.a[1];
+        dstT := arg0.type;
+        long := dstT.isLongType();
+       (*
+        *   Is this a local variable?
+        *   There is a special instruction for incrementing
+        *   word-sized local variables, provided the increment is 
+        *   by a literal 8-bit amount, and local index is 8-bit.
+        *)
+        e.PushHandle(arg0, dstT);
+        WITH arg0 : Xp.IdLeaf DO
+
+            idX0 := arg0.ident;
+            WITH idX0 : Id.LocId DO
+              IF Id.uplevA IN idX0.locAtt THEN (* uplevel addressing case *)
+                out.Code(Jvm.opc_dup);	(* handle is one slot only *)
+                out.PutGetX(Jvm.opc_getfield, idX0);
+              ELSIF (argX.kind = Xp.numLt) & ~long THEN (* PREMATURE EXIT *)
+        	LitIncLocal(out, pOrd, idX0.varOrd, intValue(argX)); RETURN;
+              ELSE
+                out.LoadLocal(idX0.varOrd, dstT);
+              END;
+            ELSE
+              e.PushValue(arg0, dstT);
+            END;
+(*
+ *	    IF (argX.kind = Xp.numLt) & ~long & arg0.ident.isLocalVar() THEN
+ *   	      numL := arg0.ident(Id.LocId).varOrd;
+ *	      incr := intValue(argX);
+ *	      IF pOrd = G.decP THEN incr := -incr END;
+ *	      IncByLit(out, numL, incr); RETURN;	(* PREMATURE EXIT *)
+ *	    ELSE
+ *	      e.PushValue(arg0, dstT);
+ *	    END;
+ *)
+        | arg0 : Xp.IdentX DO
+            flId := arg0.ident(Id.FldId);
+            out.Code(Jvm.opc_dup);	(* handle is one slot only *)
+            out.PutGetF(Jvm.opc_getfield, arg0.kid.type(Ty.Record), flId);
+        | arg0 : Xp.BinaryX DO
+            out.Code(Jvm.opc_dup2);	(* handle is two slots here *)
+            out.GetElement(dstT);
+        END;
+        e.PushValue(argX, dstT);
+        IF long THEN
+          IF pOrd = G.incP THEN c := Jvm.opc_ladd ELSE c := Jvm.opc_lsub END;
+        ELSE
+          IF pOrd = G.incP THEN c := Jvm.opc_iadd ELSE c := Jvm.opc_isub END;
+        END;
+        out.Code(c);
+        e.ScalarAssign(arg0);
+   (* --------------------------- *)
+    | G.cutP :
+       (* ------------------------------------- *
+        *  Emit the code ...
+        *     <push vector ref>
+        *     dup
+        *     getfield CP/CPJvec/VecBase/tide I // tide, vRef ...
+        *     <push arg1>                       // arg1, tide, vRef ...
+        *     dup_x1                            // arg1, tide, arg1, vRef ...
+        *     if_icmpge okLb                    // arg1, vRef ...
+        *     <throw index trap>
+        *  okLb:                                // arg1, vRef ...
+        *     putfield CP/CPJvec/VecBase/tide I // (empty)
+        * ------------------------------------- *)
+        argX := callX.actuals.a[1];
+        okLb := out.newLabel();
+        e.PushValue(arg0, arg0.type);
+        out.Code(Jvm.opc_dup);
+        out.GetVecLen();
+        e.PushValue(argX, G.intTp);
+        out.Code(Jvm.opc_dup_x1);
+
+        out.Code(Jvm.opc_iconst_1); (* Chop the sign bit *)
+        out.Code(Jvm.opc_ishl);     (* asserting, for    *)
+        out.Code(Jvm.opc_iconst_1); (* correctness, that *)
+        out.Code(Jvm.opc_iushr);    (* argX >> minInt.   *)
+
+        out.CodeLb(Jvm.opc_if_icmpge, okLb);
+        out.Trap("Vector index out of bounds");
+        out.DefLab(okLb);
+        out.PutVecLen();
+   (* --------------------------- *)
+    | G.apndP :  
+       (* -------------------------------------- *
+        *  Emit the code ...
+        *     <push vector ref>
+        *     dup
+        *     astore R                           // vRef ...
+        *     getfield CP/CPJvec/VecBase/tide I  // tide ...
+        *     istore T
+        *     aload  R                           // vRef ...
+        *     getfield CP/CPJvec/VecXXX/elems [X // elems ...
+        *     arraylength                        // aLen ...
+        *     iload  T                           // tide, aLen ...
+        *     if_icmpgt okLb                     
+        *     aload  R                           // vRef
+        *     <call expand()>
+        *  okLb:
+        *     aload  R                           // vRef
+        *     getfield CP/CPJvec/VecXXX/elems [X // elems ...
+        *     iload  T                           // tide, elems ...
+        *     <push arg1>                        // arg1, tide, elems ...
+        *     Xastore 
+        *     aload  R                           // vRef ...
+        *     iload  T                           // tide, vRef ...
+        *     iconst_1                           // 1, tide, vRef ...
+        *     iadd                               // tide', vRef ...
+        *     putfield CP/CPJvec/VecBase/tide I  // (empty)
+        * -------------------------------------- *)
+        argX := callX.actuals.a[1];
+        dstT := arg0.type(Ty.Vector).elemTp;
+        vRef := out.newLocal();
+        tide := out.newLocal();
+        okLb := out.newLabel();
+        e.PushValue(arg0, arg0.type);
+        out.Code(Jvm.opc_dup);
+        out.StoreLocal(vRef, NIL);
+        out.GetVecLen();
+        out.StoreLocal(tide, G.intTp);
+        out.LoadLocal(vRef, NIL);
+        out.GetVecArr(dstT);
+        out.Code(Jvm.opc_arraylength);
+        out.LoadLocal(tide, G.intTp);
+        out.CodeLb(Jvm.opc_if_icmpgt, okLb);
+        out.LoadLocal(vRef, NIL);
+        out.InvokeExpand(dstT);
+        out.DefLab(okLb);
+        out.LoadLocal(vRef, NIL);
+        out.GetVecArr(dstT);
+        out.LoadLocal(tide, G.intTp);
+(*
+ *      e.PushValue(argX, argX.type);
+ *)
+        e.ValueCopy(argX, argX.type);
+        out.PutVecElement(dstT);
+        out.LoadLocal(vRef, NIL);
+        out.LoadLocal(tide, G.intTp);
+        out.Code(Jvm.opc_iconst_1);
+        out.Code(Jvm.opc_iadd);
+        out.PutVecLen();
+        out.ReleaseLocal(tide);
+        out.ReleaseLocal(vRef);
+   (* --------------------------- *)
+    | G.exclP, G.inclP :
+        dstT := arg0.type;
+        argX := callX.actuals.a[1];
+
+        e.PushHandle(arg0, dstT);
+        WITH arg0 : Xp.IdLeaf DO
+            idX0 := arg0.ident;
+            WITH idX0 : Id.LocId DO
+              IF Id.uplevA IN idX0.locAtt THEN (* uplevel addressing case *)
+                out.Code(Jvm.opc_dup);	(* handle is one slot only *)
+                out.PutGetX(Jvm.opc_getfield, idX0);
+              ELSE
+                out.LoadLocal(idX0.varOrd, dstT);
+              END;
+            ELSE
+              e.PushValue(arg0, dstT);
+            END;
+        | arg0 : Xp.BinaryX DO
+            ASSERT(arg0.kind = Xp.index);
+            out.Code(Jvm.opc_dup2);
+            out.GetElement(dstT);
+        | arg0 : Xp.IdentX DO
+            ASSERT(arg0.kind = Xp.selct);
+            out.Code(Jvm.opc_dup);
+            out.PutGetF(Jvm.opc_getfield, 
+        		arg0.kid.type(Ty.Record), arg0.ident(Id.FldId));
+        END;
+(*
+ *      IF arg0 IS Xp.IdLeaf THEN
+ *	  e.PushValue(arg0, dstT);
+ *	ELSE
+ *	  e.PushHandle(arg0, dstT);
+ *	  WITH arg0 : Xp.BinaryX DO
+ *	      ASSERT(arg0.kind = Xp.index);
+ *	      out.Code(Jvm.opc_dup2);
+ *	      out.GetElement(dstT);
+ *	  | arg0 : Xp.IdentX DO
+ *	      ASSERT(arg0.kind = Xp.selct);
+ *	      out.Code(Jvm.opc_dup);
+ *	      out.PutGetF(Jvm.opc_getfield, 
+ *			arg0.kid.type(Ty.Record), arg0.ident(Id.FldId));
+ *	  END;
+ *	END;
+ *)
+        IF argX.kind = Xp.numLt THEN
+          out.PushInt(ORD({intValue(argX)}));
+        ELSE
+          out.Code(Jvm.opc_iconst_1);
+          e.PushValue(argX, G.intTp);
+          out.Code(Jvm.opc_ishl);
+        END;
+        IF pOrd = G.inclP THEN
+          out.Code(Jvm.opc_ior);
+        ELSE
+          out.Code(Jvm.opc_iconst_m1);
+          out.Code(Jvm.opc_ixor);
+          out.Code(Jvm.opc_iand);
+        END;
+        e.ScalarAssign(arg0);
+   (* --------------------------- *)
+    | G.haltP :
+        out.PushInt(intValue(arg0));
+        out.CallRTS(J.SysExit,1,0);
+        out.PushJunkAndReturn();
+   (* --------------------------- *)
+    | G.throwP :
+        IF CompState.ntvExc.assignCompat(arg0) THEN
+          e.PushValue(arg0, CompState.ntvExc);
+          out.Code(Jvm.opc_athrow);
+        ELSE
+          out.MkNewException();
+          out.Code(Jvm.opc_dup);
+          e.PushValue(arg0, CompState.ntvStr);
+          out.InitException();
+          out.Code(Jvm.opc_athrow);
+        END;
+   (* --------------------------- *)
+    | G.newP :
+       (*
+        *   arg0 is a pointer to a Record or Array, or else a vector type.
+        *)
+        e.PushHandle(arg0, arg0.type);
+        IF argN = 1 THEN
+         (*
+          *  No LEN argument implies either:
+          *	pointer to record, OR
+          *	pointer to a fixed array.
+          *)
+          dstT := arg0.type(Ty.Pointer).boundTp;
+          WITH dstT : Ty.Record DO
+              out.MkNewRecord(dstT);
+          | dstT : Ty.Array DO
+              out.MkNewFixedArray(dstT.elemTp, dstT.length);
+          END;
+        ELSIF arg0.type.kind = Ty.ptrTp THEN
+          FOR numL := 1 TO argN-1 DO
+            argX := callX.actuals.a[numL];
+            e.PushValue(argX, G.intTp);
+          END;
+          dstT := arg0.type(Ty.Pointer).boundTp;
+          out.MkNewOpenArray(dstT(Ty.Array), argN-1);
+        ELSE (* must be a vector type *)
+          dstT := arg0.type(Ty.Vector).elemTp;
+          out.MkVecRec(dstT);
+          out.Code(Jvm.opc_dup);
+          e.PushValue(callX.actuals.a[1], G.intTp);
+          out.MkVecArr(dstT);
+        END;
+        e.ScalarAssign(arg0);
+   (* --------------------------- *)
+    END;
+  END EmitStdProc;
+
+(* ============================================================ *)
+(*		    Statement Handling Methods			*)
+(* ============================================================ *)
+
+  PROCEDURE (e : JavaEmitter)EmitAssign(stat : St.Assign),NEW;
+    VAR lhTyp : D.Type;
+  BEGIN
+   (*
+    *  This is a value assign in CP.
+    *)
+    lhTyp := stat.lhsX.type;
+    e.PushHandle(stat.lhsX, lhTyp);
+    e.PushValue(stat.rhsX, lhTyp);
+    WITH lhTyp : Ty.Array DO 
+        IF stat.rhsX.kind = Xp.mkStr THEN
+          e.outF.CallRTS(J.StrVal, 2, 0);
+        ELSIF stat.rhsX.type = G.strTp THEN
+          e.outF.CallRTS(J.StrToChrs,2, 0);
+        ELSE
+          e.outF.ValArrCopy(lhTyp);
+        END;
+    | lhTyp : Ty.Record DO
+        e.outF.ValRecCopy(lhTyp);
+    ELSE
+      e.ScalarAssign(stat.lhsX);
+    END;
+  END EmitAssign;
+
+(* ---------------------------------------------------- *)
+
+  PROCEDURE (e : JavaEmitter)EmitCall(stat : St.ProcCall),NEW;
+    VAR expr : Xp.CallX;	(* the stat call expression *)
+  BEGIN
+    expr := stat.expr(Xp.CallX);
+    IF (expr.kind = Xp.prCall) & expr.kid.isStdProc() THEN
+      e.EmitStdProc(expr);
+    ELSE
+      e.PushCall(expr);
+    END;
+  END EmitCall;
+
+(* ---------------------------------------------------- *)
+
+  PROCEDURE (e : JavaEmitter)EmitIf(stat : St.Choice; OUT ok : BOOLEAN),NEW;
+    VAR out  : J.JavaFile;
+        high : INTEGER;			(* Branch count.  *)
+        exLb : J.Label;			(* Exit label	  *)
+        nxtP : J.Label;			(* Next predicate *)
+        indx : INTEGER;
+        live : BOOLEAN;			(* then is live   *)
+        else : BOOLEAN;			(* else not seen  *)
+        then : D.Stmt;
+        pred : D.Expr;
+  BEGIN
+    ok := FALSE;
+    out := e.outF;
+    exLb := out.newLabel();
+    else := FALSE;
+    high := stat.preds.tide - 1;
+    FOR indx := 0 TO high DO
+      live := TRUE;
+      pred := stat.preds.a[indx];
+      then := stat.blocks.a[indx];
+      nxtP := out.newLabel();
+      IF pred = NIL THEN else := TRUE ELSE e.FallTrue(pred, nxtP) END;
+      IF then # NIL THEN e.EmitStat(then, live) END;
+      IF live THEN 
+        ok := TRUE;
+        IF indx < high THEN out.CodeLb(Jvm.opc_goto, exLb) END;
+      END;
+      out.DefLab(nxtP);
+    END;
+   (*
+    *   If not ELSE has been seen, then control flow is still live!
+    *)
+    IF ~else THEN ok := TRUE END;
+    out.DefLab(exLb);
+  END EmitIf;
+
+(* ---------------------------------------------------- *)
+
+  PROCEDURE (e : JavaEmitter)EmitRanges
+        	       (locV : INTEGER;   	(* select Var   *)
+        		stat : St.CaseSt;  	(* case stat    *)
+        		minR : INTEGER;  	(* min rng-ix   *)
+        		maxR : INTEGER;  	(* max rng-ix   *)
+        		minI : INTEGER;  	(* min index    *)
+        		maxI : INTEGER;  	(* max index    *)
+        		labs : ARRAY OF J.Label),NEW;
+   (* --------------------------------------------------------- * 
+    *   This procedure emits the code for a single,
+    *   dense range of selector values in the label-list.
+    * --------------------------------------------------------- *)
+    VAR out  : J.JavaFile;
+        loIx : INTEGER;		(* low selector value for dense range  *)
+        hiIx : INTEGER;		(* high selector value for dense range *)
+        rNum : INTEGER;		(* total number of ranges in the group *)
+        peel : INTEGER;		(* max index of range to be peeled off *)
+        indx : INTEGER;
+        pos  : INTEGER;
+        rnge : St.Triple;
+        dfLb : J.Label;
+        lab  : J.Label;
+  BEGIN
+    out := e.outF;
+    dfLb := labs[0];
+    rNum := maxR - minR + 1;
+    rnge := stat.labels.a[minR];
+    IF rNum = 1 THEN		(* single range only *)
+      lab := labs[rnge.ord+1]; 
+      out.EmitOneRange(locV, rnge.loC, rnge.hiC, minI, maxI, dfLb, lab);
+    ELSIF rNum < 4 THEN	
+     (*
+      *    Two or three ranges only.
+      *    Peel off the lowest of the ranges, and recurse.
+      *)
+      loIx := rnge.loC;
+      peel := rnge.hiC;
+      out.LoadLocal(locV, G.intTp);
+     (*
+      *   There are a number of special cases
+      *   that can benefit from special code.
+      *)
+      IF loIx = peel THEN 
+       (* 
+        *   A singleton.  Leave minI unchanged, unless peel = minI.
+        *)
+        out.PushInt(peel);
+        out.CodeLb(Jvm.opc_if_icmpeq, labs[rnge.ord + 1]);
+        IF minI = peel THEN minI := peel+1 END;
+        INC(minR);
+      ELSIF loIx = minI THEN
+       (* 
+        *   A range starting at the minimum selector value.
+        *)
+        out.PushInt(peel);
+        out.CodeLb(Jvm.opc_if_icmple, labs[rnge.ord + 1]);
+        minI := peel+1;
+        INC(minR);
+      ELSE
+       (* 
+        *   We must peel the default range from minI to loIx.
+        *)
+        out.PushInt(loIx);
+        out.CodeLb(Jvm.opc_if_icmplt, dfLb);
+        minI := loIx;	(* and minR is unchanged! *)
+      END;
+      e.EmitRanges(locV, stat, minR, maxR, minI, maxI, labs);
+    ELSE 
+     (*
+      *   Four or more ranges.  Emit a dispatch table.
+      *)
+      loIx := rnge.loC;			(* low of min-range  *)
+      hiIx := stat.labels.a[maxR].hiC;	(* high of max-range *)
+      out.LoadLocal(locV, G.intTp);
+      out.CodeSwitch(loIx, hiIx, dfLb);
+      pos := 0;
+      FOR indx := minR TO maxR DO
+        rnge := stat.labels.a[indx];
+        WHILE loIx < rnge.loC DO 
+          out.AddSwitchLab(labs[0],pos); INC(pos); INC(loIx);
+        END;
+        WHILE loIx <= rnge.hiC DO 
+          out.AddSwitchLab(labs[rnge.ord+1],pos); INC(pos); INC(loIx);
+        END;
+      END;
+      out.LstDef(labs[0]);
+    END;
+  END EmitRanges;
+
+(* ---------------------------------------------------- *)
+
+  PROCEDURE (e : JavaEmitter)EmitGroups
+        	       (locV : INTEGER;		(* select vOrd  *)
+        		stat : St.CaseSt;  	(* case stat  	*)
+        		minG : INTEGER;  	(* min grp-indx	*)
+        		maxG : INTEGER;  	(* max grp-indx	*)
+        		minI : INTEGER;  	(* min index  	*)
+        		maxI : INTEGER;  	(* max index  	*)
+        		labs : ARRAY OF J.Label),NEW;
+   (* --------------------------------------------------------- * 
+    *  This function emits the branching code which sits on top
+    *  of the selection code for each dense range of case values.
+    * --------------------------------------------------------- *)
+    VAR out   : J.JavaFile;
+        newLb : J.Label;
+        midPt : INTEGER;
+        group : St.Triple;
+        range : St.Triple;
+  BEGIN
+    IF maxG = -1 THEN RETURN; (* Empty case statment *)
+    ELSIF minG = maxG THEN (* only one remaining dense group *)
+      group := stat.groups.a[minG];
+      e.EmitRanges(locV, stat, group.loC, group.hiC, minI, maxI, labs);
+    ELSE
+     (*
+      *   We must bifurcate the group range, and recurse.
+      *   We will split the value range at the lower limit 
+      *   of the low-range of the upper half-group.
+      *)
+      midPt := (minG + maxG + 1) DIV 2;
+      group := stat.groups.a[midPt];
+      range := stat.labels.a[group.loC];
+     (*
+      *  Test and branch at range.loC
+      *)
+      out := e.outF;
+      newLb := out.newLabel();
+      out.LoadLocal(locV, G.intTp);
+      out.PushInt(range.loC);
+      out.CodeLb(Jvm.opc_if_icmpge, newLb);
+     (*
+      *    Recurse!
+      *)
+      e.EmitGroups(locV, stat, minG, midPt-1, minI, range.loC-1, labs);
+      out.DefLab(newLb);
+      e.EmitGroups(locV, stat, midPt, maxG, range.loC, maxI, labs);
+    END;
+  END EmitGroups;
+
+(* ---------------------------------------------------- *)
+
+  PROCEDURE (e : JavaEmitter)EmitCase(stat : St.CaseSt; OUT ok : BOOLEAN),NEW;
+    VAR out  : J.JavaFile;
+        indx : INTEGER;
+        dfLb : J.Label;
+        exLb : J.Label;
+        selV : INTEGER;
+        live : BOOLEAN;
+        minI : INTEGER;
+        maxI : INTEGER;
+        labs : POINTER TO ARRAY OF J.Label;
+  BEGIN
+   (* ---------------------------------------------------------- *
+    *  CaseSt* = POINTER TO RECORD (D.Stmt)
+    *	     (* ----------------------------------------- *
+    *	      *	kind-  : INTEGER;	(* tag for unions *)
+    *	      *	token* : S.Token;	(* stmt first tok *)
+    *	      * ----------------------------------------- *)
+    *		select* : D.Expr;	(* case selector  *)
+    *		chrSel* : BOOLEAN;	(* ==> use chars  *)
+    *		blocks* : D.StmtSeq;	(* case bodies    *)
+    *		elsBlk* : D.Stmt;	(* elseCase | NIL *)
+    *		labels* : TripleSeq;	(* label seqence  *)
+    *		groups- : TripleSeq;	(* dense groups   *)
+    *	      END;
+    * --------------------------------------------------------- *
+    *  Notes on the semantics of this structure. "blocks" holds	*
+    *  an ordered list of case statement code blocks. "labels"	*
+    *  is a list of ranges, intially in textual order,with flds	*
+    *  loC, hiC and ord corresponding to the range min, max and	*
+    *  the selected block ordinal number.  This list is later 	*
+    *  sorted on the loC value, and adjacent values merged if 	*
+    *  they select the same block. The "groups" list of triples *
+    *  groups ranges into dense subranges in the selector space	*
+    *  The fields loC, hiC, and ord to hold the lower and upper	*
+    *  indices into the labels list, and the number of non-	*
+    *  default values in the group. Groups are guaranteed to	*
+    *  have density (nonDefN / (max-min+1)) > DENSITY		*
+    * --------------------------------------------------------- *)
+    ok := FALSE;
+    out := e.outF;
+    exLb := out.newLabel();
+    NEW(labs,stat.blocks.tide+1);
+    out.getLabelRange(labs);
+    selV := out.newLocal();
+
+    IF stat.chrSel THEN 
+      minI := 0; maxI := ORD(MAX(CHAR));
+    ELSE 
+      minI := MIN(INTEGER); 
+      maxI := MAX(INTEGER);
+    END;
+
+   (*
+    *    Push the selector value, and save in local variable;
+    *)
+    e.PushValue(stat.select, stat.select.type);
+    out.StoreLocal(selV, G.intTp);
+    e.EmitGroups(selV, stat, 0, stat.groups.tide-1, minI, maxI, labs);
+   (*
+    *    Now we emit the code for the cases.
+    *    If any branch returns, then exLb is reachable.
+    *)
+    FOR indx := 0 TO stat.blocks.tide-1 DO
+      out.DefLab(labs[indx + 1]);
+      e.EmitStat(stat.blocks.a[indx], live);
+      IF live THEN
+        ok := TRUE;
+        out.CodeLb(Jvm.opc_goto, exLb);
+      END;
+    END;
+   (*
+    *    Now we emit the code for the elespart.
+    *    If the elsepart returns then exLb is reachable.
+    *)
+    out.DefLabC(labs[0], "Default case");
+    IF stat.elsBlk # NIL THEN
+      e.EmitStat(stat.elsBlk, live);
+      IF live THEN ok := TRUE END;
+    ELSE
+      out.CaseTrap(selV);
+    END;
+    out.ReleaseLocal(selV);
+    IF ok THEN out.DefLabC(exLb, "Case exit label") END;
+  END EmitCase;
+ 
+(* ---------------------------------------------------- *)
+
+  PROCEDURE (e : JavaEmitter)
+        		EmitWhile(stat : St.TestLoop; OUT ok : BOOLEAN),NEW;
+    VAR out  : J.JavaFile;
+        lpLb : J.Label;
+        exLb : J.Label;
+  BEGIN
+    out := e.outF;
+    lpLb := out.newLabel();
+    exLb := out.newLabel();
+    e.FallTrue(stat.test, exLb);	(* goto exLb if eval false *)
+    out.DefLabC(lpLb, "Loop header");
+    e.EmitStat(stat.body, ok);
+    IF ok THEN e.FallFalse(stat.test, lpLb) END;
+    out.DefLabC(exLb, "Loop exit");
+  END EmitWhile;
+
+(* ---------------------------------------------------- *)
+
+  PROCEDURE (e : JavaEmitter)
+        		EmitRepeat(stat : St.TestLoop; OUT ok : BOOLEAN),NEW;
+    VAR out  : J.JavaFile;
+        lpLb : J.Label; 
+  BEGIN
+    out := e.outF;
+    lpLb := out.newLabel();
+    out.DefLabC(lpLb, "Loop header");
+    e.EmitStat(stat.body, ok);
+    IF ok THEN e.FallTrue(stat.test, lpLb) END; (* exit on eval true *)
+  END EmitRepeat;
+
+(* ---------------------------------------------------- *)
+
+  PROCEDURE (e : JavaEmitter)EmitFor(stat : St.ForLoop; OUT ok : BOOLEAN),NEW;
+   (* ----------------------------------------------------------- *
+    *   This code has been split into the four cases:
+    *   -	long control variable, counting up;
+    *   -	long control variable, counting down;
+    *   -	int control variable, counting up;
+    *   -	int control variable, counting down;
+    *   Of course, it is possible to fold all of this, and have 
+    *   tests everywhere, but the following is cleaner, and easier 
+    *   to enhance in the future.
+    *
+    *   Note carefully the use of ForLoop::isSimple().  It is 
+    *   essential to use exactly the same function here as is
+    *   used by ForLoop::flowAttr() for initialization analysis.
+    *   If this were not the case, the verifier could barf.
+    * ----------------------------------------------------------- *)
+    PROCEDURE SetVar(cv : Id.AbVar; ln : BOOLEAN; ou : J.JavaFile);
+    BEGIN
+      WITH cv : Id.LocId DO (* check if implemented inside XHR *)
+        IF Id.uplevA IN cv.locAtt THEN 
+          ou.XhrHandle(cv);
+          IF ~ln THEN 
+            ou.Code(Jvm.opc_swap);
+          ELSE
+            ou.Code(Jvm.opc_dup_x2);
+            ou.Code(Jvm.opc_pop);
+          END;
+        END;
+      ELSE (* skip *)
+      END;
+      ou.PutVar(cv);
+    END SetVar;
+   (* ----------------------------------------------------------- *)
+    PROCEDURE LongForUp(e: JavaEmitter; stat: St.ForLoop; OUT ok: BOOLEAN);
+      VAR out  : J.JavaFile;
+          cVar : Id.AbVar;
+          top1 : INTEGER;
+          top2 : INTEGER;
+          exLb : J.Label;
+          lpLb : J.Label;
+          step : LONGINT;
+          smpl : BOOLEAN;
+    BEGIN
+      out := e.outF;
+      lpLb := out.newLabel();
+      exLb := out.newLabel();
+      cVar := stat.cVar(Id.AbVar);
+      step := longValue(stat.byXp); 
+      smpl := stat.isSimple();
+      IF smpl THEN
+        out.PushLong(longValue(stat.loXp));
+        SetVar(cVar, TRUE, out);
+        top1 := -1;			(* keep the verifier happy! *)
+        top2 := -1;			(* keep the verifier happy! *)
+      ELSE
+        top1 := out.newLocal();	(* actually a pair of locals *)
+        top2 := out.newLocal();
+        e.PushValue(stat.hiXp, G.lIntTp);
+        out.Code(Jvm.opc_dup2);
+        out.StoreLocal(top1, G.lIntTp);
+        e.PushValue(stat.loXp, G.lIntTp);
+        out.Code(Jvm.opc_dup2);
+        SetVar(cVar, TRUE, out);
+       (*
+        *   The top test is NEVER inside the loop.
+        *)
+        e.DoCmp(Xp.lessT, exLb, G.lIntTp);
+      END;
+      out.DefLabC(lpLb, "Loop header");
+     (*
+      *   Emit the code body.
+      *   Stack contents are (top) hi, ...
+      *   and exactly the same on the backedge.
+      *)
+      e.EmitStat(stat.body, ok);
+     (*
+      *   If the body returns ... do an exit test.
+      *)
+      IF ok THEN 
+        IF smpl THEN
+          out.PushLong(longValue(stat.hiXp));
+        ELSE
+          out.LoadLocal(top1, G.lIntTp);
+        END;
+        out.GetVar(cVar);			(* (top) cv,hi		*)
+        out.PushLong(step);
+        out.Code(Jvm.opc_ladd);			(* (top) cv',hi		*)
+        out.Code(Jvm.opc_dup2);			(* (top) cv',cv',hi	*)
+        SetVar(cVar, TRUE, out);
+        e.DoCmp(Xp.greEq,  lpLb, G.lIntTp);
+      END;
+     (*
+      *   The exit label.
+      *)
+      out.DefLabC(exLb, "Loop trailer");
+    END LongForUp;
+
+   (* ----------------------------------------- *)
+
+    PROCEDURE LongForDn(e: JavaEmitter; stat: St.ForLoop; OUT ok: BOOLEAN);
+      VAR out  : J.JavaFile;
+          cVar : Id.AbVar;
+          top1 : INTEGER;
+          top2 : INTEGER;
+          exLb : J.Label;
+          lpLb : J.Label;
+          step : LONGINT;
+          smpl : BOOLEAN;
+    BEGIN
+      out := e.outF;
+      lpLb := out.newLabel();
+      exLb := out.newLabel();
+      cVar := stat.cVar(Id.AbVar);
+      step := longValue(stat.byXp);
+      smpl := stat.isSimple();
+      IF smpl THEN
+        out.PushLong(longValue(stat.loXp));
+        SetVar(cVar, TRUE, out);
+        top1 := -1;			(* keep the verifier happy! *)
+        top2 := -1;			(* keep the verifier happy! *)
+      ELSE
+        top1 := out.newLocal();	(* actually a pair of locals *)
+        top2 := out.newLocal();
+        e.PushValue(stat.hiXp, G.lIntTp);
+        out.Code(Jvm.opc_dup2);
+        out.StoreLocal(top1, G.lIntTp);
+        e.PushValue(stat.loXp, G.lIntTp);
+        out.Code(Jvm.opc_dup2);
+        SetVar(cVar, TRUE, out);
+       (*
+        *   The top test is NEVER inside the loop.
+        *)
+        e.DoCmp(Xp.greT,  exLb, G.lIntTp);
+      END;
+      out.DefLabC(lpLb, "Loop header");
+     (*
+      *   Emit the code body.
+      *   Stack contents are (top) hi, ...
+      *   and exactly the same on the backedge.
+      *)
+      e.EmitStat(stat.body, ok);
+     (*
+      *   If the body returns ... do an exit test.
+      *)
+      IF ok THEN 
+        IF smpl THEN
+          out.PushLong(longValue(stat.hiXp));
+        ELSE
+          out.LoadLocal(top1, G.lIntTp);
+        END;
+        out.GetVar(cVar);			(* (top) cv,hi		*)
+        out.PushLong(step);
+        out.Code(Jvm.opc_ladd);			(* (top) cv',hi		*)
+        out.Code(Jvm.opc_dup2);			(* (top) cv',cv',hi	*)
+        SetVar(cVar, TRUE, out);
+        e.DoCmp(Xp.lessEq, lpLb, G.lIntTp);
+      END;
+     (*
+      *   The exit label.
+      *)
+      out.DefLabC(exLb, "Loop trailer");
+    END LongForDn;
+
+   (* ----------------------------------------- *)
+
+    PROCEDURE IntForUp(e: JavaEmitter; stat: St.ForLoop; OUT ok: BOOLEAN);
+      VAR out  : J.JavaFile;
+          cVar : Id.AbVar;
+          topV : INTEGER;
+          exLb : J.Label;
+          lpLb : J.Label;
+          step : INTEGER;
+          smpl : BOOLEAN;
+    BEGIN
+     (*
+      *    This is the common case, so we work a bit harder.
+      *)
+      out := e.outF;
+      lpLb := out.newLabel();
+      exLb := out.newLabel();
+      cVar := stat.cVar(Id.AbVar);
+      step := intValue(stat.byXp);
+      smpl := stat.isSimple();
+      IF smpl THEN
+        out.PushInt(intValue(stat.loXp));
+        SetVar(cVar, FALSE, out);
+        topV := -1;			(* keep the verifier happy! *)
+      ELSE
+        topV := out.newLocal();
+        e.PushValue(stat.hiXp, G.intTp);
+        out.Code(Jvm.opc_dup);
+        out.StoreLocal(topV, G.intTp);
+        e.PushValue(stat.loXp, G.intTp);
+        out.Code(Jvm.opc_dup);
+        SetVar(cVar, FALSE, out);
+       (*
+        *   The top test is NEVER inside the loop.
+        *)
+        e.DoCmp(Xp.lessT, exLb, G.intTp);
+      END;
+      out.DefLabC(lpLb, "Loop header");
+     (*
+      *   Emit the code body.
+      *)
+      e.EmitStat(stat.body, ok);
+     (*
+      *   If the body returns ... do an exit test.
+      *)
+      IF ok THEN 
+        IF smpl THEN
+          out.PushInt(intValue(stat.hiXp));
+        ELSE
+          out.LoadLocal(topV, G.intTp);
+        END;
+        out.GetVar(cVar);			(* (top) cv,hi		*)
+        out.PushInt(step);
+        out.Code(Jvm.opc_iadd);			(* (top) cv',hi		*)
+        out.Code(Jvm.opc_dup);			(* (top) cv',cv',hi	*)
+        SetVar(cVar, FALSE, out);
+        e.DoCmp(Xp.greEq, lpLb, G.intTp);
+      END;
+     (*
+      *   The exit label.
+      *)
+      out.DefLabC(exLb, "Loop trailer");
+    END IntForUp;
+  
+   (* ----------------------------------------- *)
+
+    PROCEDURE IntForDn(e: JavaEmitter; stat: St.ForLoop; OUT ok: BOOLEAN);
+      VAR out  : J.JavaFile;
+          cVar : Id.AbVar;
+          topV : INTEGER;
+          exLb : J.Label; 
+          lpLb : J.Label;
+          step : INTEGER;
+          smpl : BOOLEAN;
+    BEGIN
+      out := e.outF;
+      lpLb := out.newLabel();
+      exLb := out.newLabel();
+      cVar := stat.cVar(Id.AbVar);
+      step := intValue(stat.byXp);
+      topV := out.newLocal();
+      smpl := stat.isSimple();
+      IF smpl THEN
+        out.PushInt(intValue(stat.loXp));
+        SetVar(cVar, FALSE, out);
+        topV := -1;			(* keep the verifier happy! *)
+      ELSE
+        e.PushValue(stat.hiXp, G.intTp);
+        out.Code(Jvm.opc_dup);
+        out.StoreLocal(topV, G.intTp);
+        e.PushValue(stat.loXp, G.intTp);
+        out.Code(Jvm.opc_dup);
+        SetVar(cVar, FALSE, out);
+       (*
+        *   The top test is NEVER inside the loop.
+        *)
+        e.DoCmp(Xp.greT, exLb, G.intTp);
+      END;
+      out.DefLabC(lpLb, "Loop header");
+     (*
+      *   Emit the code body.
+      *)
+      e.EmitStat(stat.body, ok);
+     (*
+      *   If the body returns ... do an exit test.
+      *)
+      IF ok THEN 
+        IF smpl THEN
+          out.PushInt(intValue(stat.hiXp));
+        ELSE
+          out.LoadLocal(topV, G.intTp);
+        END;
+        out.GetVar(cVar);			(* (top) cv,hi		*)
+        out.PushInt(step);
+        out.Code(Jvm.opc_iadd);			(* (top) cv',hi		*)
+        out.Code(Jvm.opc_dup);			(* (top) cv',cv',hi	*)
+        SetVar(cVar, FALSE, out);
+        e.DoCmp(Xp.lessEq, lpLb, G.intTp);
+      END;
+     (*
+      *   The exit label.
+      *)
+      out.DefLabC(exLb, "Loop trailer");
+    END IntForDn;
+
+   (* ----------------------------------------- *)
+  BEGIN (* body of EmitFor *)
+    IF stat.cVar.type.isLongType() THEN 
+      IF longValue(stat.byXp) > 0 THEN LongForUp(e, stat, ok);
+      ELSE LongForDn(e, stat, ok);
+      END;
+    ELSE
+      IF longValue(stat.byXp) > 0 THEN IntForUp(e, stat, ok);
+      ELSE IntForDn(e, stat, ok);
+      END;
+    END;
+  END EmitFor;
+
+(* ---------------------------------------------------- *)
+
+  PROCEDURE (e : JavaEmitter)
+        		EmitLoop(stat : St.TestLoop; OUT ok : BOOLEAN),NEW;
+    VAR out  : J.JavaFile;
+        lpLb : J.Label;
+        tmpLb : J.Label;
+  BEGIN
+    out := e.outF;
+    lpLb  := out.newLabel();
+    tmpLb := currentLoopLabel;
+    currentLoopLabel := out.newLabel();
+    out.DefLabC(lpLb, "Loop header");
+    e.EmitStat(stat.body, ok);
+    IF ok THEN out.CodeLb(Jvm.opc_goto, lpLb) END;
+    out.DefLabC(currentLoopLabel, "Loop exit");
+    currentLoopLabel := tmpLb;
+  END EmitLoop;
+
+(* ---------------------------------------------------- *)
+
+  PROCEDURE (e : JavaEmitter)EmitWith(stat : St.Choice; OUT ok : BOOLEAN),NEW;
+    VAR out  : J.JavaFile;
+        high : INTEGER;			(* Branch count.  *)
+        exLb : J.Label;			(* Exit label	  *)
+        nxtP : J.Label;			(* Next predicate *)
+        indx : INTEGER;
+        live : BOOLEAN;
+        then : D.Stmt;
+        pred : D.Expr;
+        tVar : Id.LocId;
+   (* --------------------------- *)
+    PROCEDURE WithTest(je : JavaEmitter; 
+        	       os : J.JavaFile; 
+        	       pr : D.Expr; 
+        	       nx : J.Label;
+        	       tm : INTEGER);
+      VAR bX : Xp.BinaryX;
+          ty : D.Type;
+    BEGIN
+      bX := pr(Xp.BinaryX);
+      ty := bX.rKid(Xp.IdLeaf).ident.type;
+      je.PushValue(bX.lKid, bX.lKid.type);
+      os.CodeT(Jvm.opc_instanceof, ty);
+      os.CodeLb(Jvm.opc_ifeq, nx);
+     (*
+      *   We must also generate a checkcast, because the verifier
+      *   seems to understand the typeflow consequences of the
+      *   checkcast bytecode, but not instanceof.
+      *)
+      je.PushValue(bX.lKid, bX.lKid.type);
+      os.CodeT(Jvm.opc_checkcast, ty);
+      os.StoreLocal(tm, ty);
+    END WithTest;
+   (* --------------------------- *)
+  BEGIN
+    tVar := NIL;
+    pred := NIL;
+    ok := FALSE;
+    out := e.outF;
+    exLb := out.newLabel();
+    high := stat.preds.tide - 1;
+    FOR indx := 0 TO high DO
+      live := TRUE;
+      pred := stat.preds.a[indx];
+      then := stat.blocks.a[indx];
+      tVar := stat.temps.a[indx](Id.LocId);
+      nxtP := out.newLabel();
+      IF pred # NIL THEN 
+        tVar.varOrd := out.newLocal();
+        WithTest(e, out, pred, nxtP, tVar.varOrd);
+      END;
+      IF then # NIL THEN e.EmitStat(then, live) END;
+      IF live THEN 
+        ok := TRUE;
+       (*
+        *  If this is not the else case, skip over the
+        *  later cases, or jump over the WITH ELSE trap.
+        *)
+        IF pred # NIL THEN out.CodeLb(Jvm.opc_goto, exLb) END;
+      END;
+      IF tVar # NIL THEN out.ReleaseLocal(tVar.varOrd) END;
+      out.DefLab(nxtP);
+    END;
+    IF pred # NIL THEN out.WithTrap(pred(Xp.BinaryX).lKid(Xp.IdLeaf).ident) END;
+    out.DefLab(exLb);
+  END EmitWith;
+
+(* ---------------------------------------------------- *)
+
+  PROCEDURE (e : JavaEmitter)EmitExit(stat : St.ExitSt),NEW;
+  BEGIN
+    e.outF.CodeLb(Jvm.opc_goto, currentLoopLabel);
+  END EmitExit;
+
+(* ---------------------------------------------------- *)
+
+  PROCEDURE (e : JavaEmitter)EmitReturn(stat : St.Return),NEW;
+    VAR out : J.JavaFile;
+        pId : Id.Procs;
+        ret : D.Type;
+  BEGIN
+    out := e.outF;
+    pId := out.getScope()(Id.Procs);
+   (*
+    *  Because the return slot may be used for the first
+    *  OUT or VAR parameter, the real return type might
+    *  be different to that shown in the formal type.
+    *  FixOutPars() returns this real return type.
+    *)
+    IF (stat.retX # NIL) &
+       (pId.kind # Id.ctorP) THEN e.PushValue(stat.retX, stat.retX.type) END;
+    out.FixOutPars(pId, ret);
+    out.Return(ret);
+  END EmitReturn;
+
+(* ---------------------------------------------------- *)
+
+  PROCEDURE (e : JavaEmitter)EmitBlock(stat : St.Block; OUT ok : BOOLEAN),NEW;
+    VAR index, limit : INTEGER;
+  BEGIN
+    ok := TRUE;
+    index := 0;
+    limit := stat.sequ.tide;
+    WHILE ok & (index < limit) DO
+      e.EmitStat(stat.sequ.a[index], ok);
+      INC(index);
+    END;
+  END EmitBlock;
+
+(* ---------------------------------------------------- *)
+(* ---------------------------------------------------- *)
+
+  PROCEDURE (e : JavaEmitter)EmitStat(stat : D.Stmt; OUT ok : BOOLEAN),NEW;
+    VAR depth : INTEGER;
+  BEGIN
+    IF (stat = NIL) OR (stat.kind = St.emptyS) THEN ok := TRUE; RETURN END;
+    IF stat.kind # St.blockS THEN 
+      e.outF.Line(stat.token.lin);
+    END;
+    depth := e.outF.getDepth();
+    CASE stat.kind OF
+    | St.assignS  : e.EmitAssign(stat(St.Assign)); ok := TRUE;
+    | St.procCall : e.EmitCall(stat(St.ProcCall)); ok := TRUE; 
+    | St.ifStat   : e.EmitIf(stat(St.Choice), ok);
+    | St.caseS    : e.EmitCase(stat(St.CaseSt), ok); 
+    | St.whileS   : e.EmitWhile(stat(St.TestLoop), ok);
+    | St.repeatS  : e.EmitRepeat(stat(St.TestLoop), ok); 
+    | St.forStat  : e.EmitFor(stat(St.ForLoop), ok); 
+    | St.loopS    : e.EmitLoop(stat(St.TestLoop), ok);
+    | St.withS    : e.EmitWith(stat(St.Choice), ok);
+    | St.exitS    : e.EmitExit(stat(St.ExitSt)); ok := TRUE;
+    | St.returnS  : e.EmitReturn(stat(St.Return)); ok := FALSE;
+    | St.blockS   : e.EmitBlock(stat(St.Block), ok);
+    END;
+    e.outF.setDepth(depth);
+  END EmitStat;
+
+
+(* ============================================================ *)
+(* ============================================================ *)
+END JavaMaker.
+(* ============================================================ *)
+(* ============================================================ *)

gpcp/JavaUtil.cp

@@ -0,0 +1,2000 @@
+
+(*  JavaUtil is the module which writes java classs file        *)
+(*  structures  						*)
+(*  Copyright (c) John Gough 1999, 2000.			*)
+(*  Modified DWC September, 2000.				*)
+(* ============================================================ *)
+
+MODULE JavaUtil;
+
+  IMPORT 
+	GPCPcopyright,
+	RTS,
+	Console,
+        GPFiles,
+	L   := LitValue,
+	JavaBase,
+        NameHash,
+        FileNames,
+	CompState,
+	ClassMaker,
+        F   := GPBinFiles,
+	Jvm := JVMcodes,
+	D   := Symbols,
+	G   := Builtin,
+	Id  := IdDesc,
+	Ty  := TypeDesc;
+
+(* ============================================================ *)
+
+  CONST
+       initStr* = "<init>";
+       classPrefix* = "CP";
+       retMarker* = -1;   (* ==> out param is func-return *)
+       StrCmp* = 1;       (* indexes for rts procs *)
+       StrToChrOpen* = 2;
+       StrToChrs* = 3;
+       ChrsToStr* = 4;
+       StrCheck* = 5;
+       StrLen* = 6;
+       ToUpper* = 7;
+       DFloor* = 8;
+       ModI* = 9;
+       ModL* = 10;
+       DivI* = 11;
+       DivL* = 12;
+       StrCatAA* = 13; 
+       StrCatSA* = 14; 
+       StrCatAS* = 15; 
+       StrCatSS* = 16; 
+       StrLP1* = 17; 
+       StrVal* = 18;
+       SysExit* = 19;
+       LoadTp1* = 20;	(* getClassByOrd  *)
+       LoadTp2* = 21;	(* getClassByName *)
+       GetTpM* = 22;
+
+(* ============================================================ *)
+
+  TYPE JavaFile* = POINTER TO ABSTRACT RECORD
+		     theP* : Id.Procs;
+                   END;
+
+(* ============================================================ *)
+
+  TYPE Label* = POINTER TO RECORD
+                  defIx* : INTEGER;
+                END;
+
+(* ============================================================ *)
+
+  VAR
+	typeRetn-  : ARRAY 16 OF INTEGER;
+	typeLoad-  : ARRAY 16 OF INTEGER;
+	typeStore- : ARRAY 16 OF INTEGER;
+	typePutE-  : ARRAY 16 OF INTEGER;
+	typeGetE-  : ARRAY 16 OF INTEGER;
+
+  VAR	nmArray*   : L.CharOpenSeq;
+	fmArray*   : L.CharOpenSeq;
+
+  VAR   semi-,lPar-,rPar-,rParV-,brac-,lCap-,
+	void-,lowL-,dlar-,slsh-,prfx- : L.CharOpen;
+
+(* ============================================================ *)
+
+  VAR   xhrIx : INTEGER;
+        xhrDl : L.CharOpen;
+        xhrMk : L.CharOpen;
+
+(* ============================================================ *)
+
+  VAR   vecBlkId  : Id.BlkId;
+        vecBase   : Id.TypId;
+        vecTypes  : ARRAY Ty.anyPtr+1 OF Id.TypId;
+        vecTide   : Id.FldId;
+        vecElms   : ARRAY Ty.anyPtr+1 OF Id.FldId;
+        vecExpnd  : ARRAY Ty.anyPtr+1 OF Id.MthId;
+
+(* ============================================================ *)
+
+  PROCEDURE (jf : JavaFile)StartModClass*(mod : Id.BlkId),NEW,ABSTRACT;
+  PROCEDURE (jf : JavaFile)StartRecClass*(rec : Ty.Record),NEW,ABSTRACT;
+  PROCEDURE (jf : JavaFile)StartProc*(proc : Id.Procs),NEW,ABSTRACT;
+  PROCEDURE (jf : JavaFile)EndProc*(),NEW,EMPTY;
+  PROCEDURE (jf : JavaFile)isAbstract*():BOOLEAN,NEW,ABSTRACT;
+
+  PROCEDURE (jf : JavaFile)getScope*():D.Scope,NEW,ABSTRACT;
+
+  PROCEDURE (jf : JavaFile) EmitField*(field : Id.AbVar),NEW,ABSTRACT;
+
+  PROCEDURE (jf : JavaFile)MkNewRecord*(typ : Ty.Record),NEW,ABSTRACT;
+  PROCEDURE (jf : JavaFile)MkNewFixedArray*(topE : D.Type;
+                                            len0 : INTEGER),NEW,ABSTRACT;
+  PROCEDURE (jf : JavaFile)MkNewOpenArray*(arrT : Ty.Array;
+                                           dims : INTEGER),NEW,ABSTRACT;
+  PROCEDURE (jf : JavaFile)MkArrayCopy*(arrT : Ty.Array),NEW,ABSTRACT;
+
+  PROCEDURE (jf : JavaFile)newLocal*() : INTEGER,NEW,ABSTRACT;
+  PROCEDURE (jf : JavaFile)ReleaseLocal*(i : INTEGER),NEW,ABSTRACT;
+  PROCEDURE (jf : JavaFile)ReleaseAll*(m : INTEGER),NEW,ABSTRACT;
+
+  PROCEDURE (jf : JavaFile)markTop*() : INTEGER,NEW,ABSTRACT;
+  PROCEDURE (jf : JavaFile)getDepth*() : INTEGER,NEW,ABSTRACT;
+  PROCEDURE (jf : JavaFile)setDepth*(i : INTEGER),NEW,ABSTRACT;
+
+  PROCEDURE (jf : JavaFile)newLabel*() : Label,NEW,ABSTRACT;
+  PROCEDURE (jf : JavaFile)getLabelRange*(VAR labs:ARRAY OF Label),NEW,ABSTRACT;
+  PROCEDURE (jf : JavaFile)AddSwitchLab*(lab : Label; 
+                                         pos : INTEGER),NEW,ABSTRACT;
+
+
+  PROCEDURE (jf : JavaFile)Comment*(IN msg : ARRAY OF CHAR),NEW,EMPTY;
+  PROCEDURE (jf : JavaFile)Header*(IN str : ARRAY OF CHAR),NEW,EMPTY;
+
+  PROCEDURE (jf : JavaFile)Code*(code : INTEGER),NEW,ABSTRACT;
+  PROCEDURE (jf : JavaFile)CodeI*(code,val : INTEGER),NEW,ABSTRACT;
+  PROCEDURE (jf : JavaFile)CodeL*(code : INTEGER; num : LONGINT),NEW,ABSTRACT;
+  PROCEDURE (jf : JavaFile)CodeC*(code : INTEGER; 
+                                  IN str : ARRAY OF CHAR),NEW,ABSTRACT;
+  PROCEDURE (jf : JavaFile)CodeR*(code : INTEGER; 
+                                  num : REAL; short : BOOLEAN),NEW,ABSTRACT;
+  PROCEDURE (jf : JavaFile)CodeLb*(code : INTEGER; lab : Label),NEW,ABSTRACT;
+  PROCEDURE (jf : JavaFile)LstDef*(l : Label),NEW,EMPTY;
+  PROCEDURE (jf : JavaFile)DefLab*(lab : Label),NEW,ABSTRACT;
+  PROCEDURE (jf : JavaFile)DefLabC*(lab : Label; 
+                                    IN c : ARRAY OF CHAR),NEW,ABSTRACT;
+  PROCEDURE (jf : JavaFile)CodeInc*(localIx,incVal : INTEGER),NEW,ABSTRACT;
+  PROCEDURE (jf : JavaFile)CodeT*(code : INTEGER; ty : D.Type),NEW,ABSTRACT;
+  PROCEDURE (jf : JavaFile)CodeSwitch*(low,high : INTEGER; 
+                                       defLab : Label),NEW,ABSTRACT;
+
+  PROCEDURE (jf : JavaFile)PushStr*(IN str : L.CharOpen),NEW,ABSTRACT;
+  PROCEDURE (jf : JavaFile)LoadConst*(num : INTEGER),NEW,ABSTRACT;
+
+
+  PROCEDURE (jf : JavaFile)CallGetClass*(),NEW,ABSTRACT; 
+  PROCEDURE (jf : JavaFile)CallRTS*(ix,args,ret : INTEGER),NEW,ABSTRACT; 
+  PROCEDURE (jf : JavaFile)CallIT*(code : INTEGER; 
+				   proc : Id.Procs; 
+				   type : Ty.Procedure),NEW,ABSTRACT;
+
+
+  PROCEDURE (jf : JavaFile)ClinitHead*(),NEW,ABSTRACT;
+  PROCEDURE (jf : JavaFile)MainHead*(),NEW,ABSTRACT;
+  PROCEDURE (jf : JavaFile)VoidTail*(),NEW,ABSTRACT;
+  PROCEDURE (jf : JavaFile)ModNoArgInit*(),NEW,ABSTRACT;
+  PROCEDURE (jf : JavaFile)RecMakeInit*(rec : Ty.Record;
+					prc : Id.PrcId),NEW,ABSTRACT;
+  PROCEDURE (jf : JavaFile)CallSuperCtor*(rec : Ty.Record;
+                                          pTy : Ty.Procedure),NEW,ABSTRACT;
+  PROCEDURE (jf : JavaFile)CopyProcHead*(rec : Ty.Record),NEW,ABSTRACT;
+  PROCEDURE (jf : JavaFile)ValRecCopy*(typ : Ty.Record),NEW,ABSTRACT;
+
+  PROCEDURE (jf : JavaFile)InitFields*(num : INTEGER),NEW,EMPTY;
+  PROCEDURE (jf : JavaFile)InitMethods*(num : INTEGER),NEW,EMPTY;
+
+  PROCEDURE (jf : JavaFile)Try*(),NEW,ABSTRACT;
+  PROCEDURE (jf : JavaFile)Catch*(prc : Id.Procs),NEW,ABSTRACT;
+  PROCEDURE (jf : JavaFile)MkNewException*(),NEW,ABSTRACT;
+  PROCEDURE (jf : JavaFile)InitException*(),NEW,ABSTRACT;
+
+  PROCEDURE (jf : JavaFile)Dump*(),NEW,ABSTRACT;
+
+(* ============================================================ *)
+
+  PROCEDURE (jf : JavaFile)PutGetS*(code : INTEGER;
+				    blk  : Id.BlkId;
+				    fld  : Id.VarId),NEW,ABSTRACT;
+  PROCEDURE (jf : JavaFile)PutGetF*(code : INTEGER;
+				    rec  : Ty.Record;
+				    fld  : Id.AbVar),NEW,ABSTRACT;
+
+(* ============================================================ *)
+
+  PROCEDURE (jf : JavaFile)Alloc1d*(elTp : D.Type),NEW,ABSTRACT;
+  PROCEDURE (jf : JavaFile)VarInit*(var : D.Idnt),NEW,ABSTRACT;
+  PROCEDURE (jf : JavaFile)Trap*(IN str : ARRAY OF CHAR),NEW,ABSTRACT;
+  PROCEDURE (jf : JavaFile)CaseTrap*(i : INTEGER),NEW,ABSTRACT;
+  PROCEDURE (jf : JavaFile)WithTrap*(id : D.Idnt),NEW,ABSTRACT;
+  PROCEDURE (jf : JavaFile)Line*(nm : INTEGER),NEW,ABSTRACT;
+
+(* ============================================================ *)
+(*			Some XHR utilities			*)
+(* ============================================================ *)
+
+  PROCEDURE^ (jf : JavaFile)PutUplevel*(var : Id.LocId),NEW;
+  PROCEDURE^ (jf : JavaFile)GetUplevel*(var : Id.LocId),NEW;
+  PROCEDURE^ (jf : JavaFile)PushInt*(num : INTEGER),NEW;
+  PROCEDURE^ (jf : JavaFile)PutElement*(typ : D.Type),NEW;
+  PROCEDURE^ (jf : JavaFile)GetElement*(typ : D.Type),NEW;
+  PROCEDURE^ (jf : JavaFile)ConvertDn*(inT, outT : D.Type),NEW;
+
+  PROCEDURE^ cat2*(i,j : L.CharOpen) : L.CharOpen;
+  PROCEDURE^ MkRecName*(typ : Ty.Record);
+  PROCEDURE^ MkProcName*(proc : Id.Procs);
+  PROCEDURE^ NumberParams(pIdn : Id.Procs; pTyp : Ty.Procedure);
+
+(* ============================================================ *)
+
+  PROCEDURE xhrCount(tgt, ths : Id.Procs) : INTEGER;
+    VAR count : INTEGER;
+  BEGIN
+    IF ths.lxDepth = 0 THEN RETURN 0 END;
+   (*
+    *  "ths" is the calling procedure.
+    *  "tgt" is the procedure with the uplevel data.
+    *)
+    count := 0;
+    REPEAT
+      ths := ths.dfScp(Id.Procs);
+      IF Id.hasXHR IN ths.pAttr THEN INC(count) END;
+    UNTIL (ths.lxDepth = 0) OR
+	  ((ths.lxDepth <= tgt.lxDepth) & (Id.hasXHR  IN ths.pAttr));
+    RETURN count;
+  END xhrCount;
+
+  PROCEDURE newXHR() : L.CharOpen;
+  BEGIN
+    INC(xhrIx);
+    RETURN cat2(xhrDl, L.intToCharOpen(xhrIx));
+  END newXHR;
+
+  PROCEDURE MkXHR(scp : Id.Procs);
+    VAR typId : Id.TypId;
+	recTp : Ty.Record;
+	index : INTEGER;
+	locVr : Id.LocId;
+	fldVr : Id.FldId;
+  BEGIN
+    G.MkDummyClass(newXHR(), CompState.thisMod, Ty.noAtt, typId);
+    typId.SetMode(D.prvMode);
+    scp.xhrType := typId.type;
+    recTp := typId.type.boundRecTp()(Ty.Record);
+    recTp.baseTp := CompState.rtsXHR.boundRecTp();
+    INCL(recTp.xAttr, D.noCpy);
+
+    FOR index := 0 TO scp.locals.tide-1 DO
+      locVr := scp.locals.a[index](Id.LocId);
+      IF Id.uplevA IN locVr.locAtt THEN
+        fldVr := Id.newFldId();
+        fldVr.hash := locVr.hash;
+        fldVr.type := locVr.type;
+        fldVr.recTyp := recTp;
+	D.AppendIdnt(recTp.fields, fldVr);
+      END;
+    END;
+  END MkXHR;
+
+(* ============================================================ *)
+(*			Some vector utilities			*)
+(* ============================================================ *)
+
+  PROCEDURE mapVecElTp(typ : D.Type) : INTEGER;
+  BEGIN
+    WITH typ : Ty.Base DO
+      CASE typ.tpOrd OF
+      | Ty.sChrN : RETURN Ty.charN;
+      | Ty.boolN, Ty.byteN, Ty.sIntN, Ty.setN, Ty.uBytN : RETURN Ty.intN;
+      | Ty.charN, Ty.intN, Ty.lIntN, Ty.sReaN, Ty.realN : RETURN typ.tpOrd;
+      ELSE RETURN Ty.anyPtr;
+      END;
+    ELSE RETURN Ty.anyPtr;
+    END;
+  END mapVecElTp;
+
+  PROCEDURE mapOrdRepT(ord : INTEGER) : D.Type;
+  BEGIN
+    CASE ord OF
+    | Ty.charN  : RETURN G.charTp;
+    | Ty.intN   : RETURN G.intTp;
+    | Ty.lIntN  : RETURN G.lIntTp;
+    | Ty.sReaN  : RETURN G.sReaTp;
+    | Ty.realN  : RETURN G.realTp;
+    | Ty.anyPtr : RETURN G.anyPtr;
+    END;
+  END mapOrdRepT;
+
+(* ------------------------------------------------------------ *)
+
+  PROCEDURE InitVecDescriptors;
+    VAR i : INTEGER;
+  BEGIN
+    vecBlkId := NIL;
+    vecBase  := NIL;
+    vecTide  := NIL;
+    FOR i := 0 TO Ty.anyPtr DO
+      vecTypes[i] := NIL;
+      vecElms[i]  := NIL;
+      vecExpnd[i] := NIL;
+    END;
+  END InitVecDescriptors;
+
+  PROCEDURE vecModId() : Id.BlkId;
+  BEGIN
+    IF vecBlkId = NIL THEN
+      G.MkDummyImport("$CPJvec$", "CP.CPJvec", vecBlkId);
+      G.MkDummyClass("VecBase", vecBlkId, Ty.noAtt, vecBase);
+     (*
+      *  Initialize vecTide while we are at it ...
+      *)
+      vecTide := Id.newFldId();
+      vecTide.hash := NameHash.enterStr("tide");
+      vecTide.dfScp := vecBlkId;
+      vecTide.recTyp := vecBase.type.boundRecTp();
+      vecTide.type := G.intTp;
+      MkRecName(vecTide.recTyp(Ty.Record)); 
+    END;
+    RETURN vecBlkId;
+  END vecModId;
+
+  PROCEDURE vecClsTyId(ord : INTEGER) : Id.TypId;
+    VAR str : ARRAY 8 OF CHAR;
+        tId : Id.TypId;
+        rcT : Ty.Record;
+  BEGIN
+    IF vecTypes[ord] = NIL THEN
+      CASE ord OF
+      | Ty.charN  : str := "VecChr";
+      | Ty.intN   : str := "VecI32";
+      | Ty.lIntN  : str := "VecI64";
+      | Ty.sReaN  : str := "VecR32";
+      | Ty.realN  : str := "VecR64";
+      | Ty.anyPtr : str := "VecRef";
+      END;
+      G.MkDummyClass(str, vecModId(), Ty.noAtt, tId);
+      rcT := tId.type.boundRecTp()(Ty.Record);
+(*
+ *    rcT.baseTp := vecBase.type.boundRecTp();
+ *)
+      rcT.baseTp := vecTide.recTyp;
+      vecTypes[ord] := tId;
+    END;
+    RETURN vecTypes[ord];
+  END vecClsTyId;
+
+  PROCEDURE vecRecTyp(ord : INTEGER) : Ty.Record;
+  BEGIN
+    RETURN vecClsTyId(ord).type.boundRecTp()(Ty.Record);
+  END vecRecTyp;
+
+  PROCEDURE vecArrFlId(ord : INTEGER) : Id.FldId;
+    VAR fld : Id.FldId;
+  BEGIN
+    IF vecElms[ord] = NIL THEN
+      fld := Id.newFldId();
+      fld.hash := NameHash.enterStr("elms");
+      fld.dfScp := vecModId();
+      fld.recTyp := vecRecTyp(ord);
+      fld.type := Ty.mkArrayOf(mapOrdRepT(ord));
+      vecElms[ord] := fld;
+    END;
+    RETURN vecElms[ord];
+  END vecArrFlId;
+
+(* ------------------------------------------------------------ *)
+
+  PROCEDURE (jf : JavaFile)MkVecRec*(eTp : D.Type),NEW;
+    VAR ord : INTEGER;
+  BEGIN
+    ord := mapVecElTp(eTp);
+    jf.MkNewRecord(vecRecTyp(ord));
+  END MkVecRec;
+
+(* ------------------------------- *)
+
+  PROCEDURE (jf : JavaFile)MkVecArr*(eTp : D.Type),NEW;
+    VAR ord : INTEGER;
+        vTp : D.Type;
+  BEGIN
+    ord := mapVecElTp(eTp);
+    jf.Alloc1d(mapOrdRepT(ord));
+    jf.PutGetF(Jvm.opc_putfield, vecRecTyp(ord), vecArrFlId(ord));
+  END MkVecArr;
+
+(* ------------------------------------------------------------ *)
+
+  PROCEDURE (jf : JavaFile)GetVecArr*(eTp : D.Type),NEW;
+    VAR ord : INTEGER;
+        fId : Id.FldId;
+  BEGIN
+    ord := mapVecElTp(eTp);
+    fId := vecArrFlId(ord);
+    jf.PutGetF(Jvm.opc_getfield, fId.recTyp(Ty.Record), fId);
+  END GetVecArr;
+
+(* ------------------------------- *)
+
+  PROCEDURE (jf : JavaFile)GetVecLen*(),NEW;
+  BEGIN
+    jf.PutGetF(Jvm.opc_getfield, vecTide.recTyp(Ty.Record), vecTide);
+  END GetVecLen;
+
+(* ------------------------------- *)
+
+  PROCEDURE (jf : JavaFile)PutVecLen*(),NEW;
+  BEGIN
+    jf.PutGetF(Jvm.opc_putfield, vecTide.recTyp(Ty.Record), vecTide);
+  END PutVecLen;
+
+(* ------------------------------- *)
+
+  PROCEDURE (jf : JavaFile)InvokeExpand*(eTp : D.Type),NEW;
+    VAR ord : INTEGER;
+        mth : Id.MthId;
+        typ : Ty.Procedure;
+  BEGIN
+    ord := mapVecElTp(eTp);
+    IF vecExpnd[ord] = NIL THEN
+      mth := Id.newMthId();
+      mth.hash := G.xpndBk;
+      mth.dfScp := vecModId();
+      typ := Ty.newPrcTp();
+      typ.idnt := mth;
+      typ.receiver := vecClsTyId(ord).type;
+      mth.bndType  := typ.receiver.boundRecTp();
+      MkProcName(mth);
+      NumberParams(mth, typ);
+      mth.type := typ;
+      vecExpnd[ord] := mth;
+    ELSE
+      mth := vecExpnd[ord];
+      typ := mth.type(Ty.Procedure);
+    END;
+    jf.CallIT(Jvm.opc_invokevirtual, mth, typ);
+  END InvokeExpand;
+
+(* ------------------------------- *)
+
+  PROCEDURE (jf : JavaFile)PutVecElement*(eTp : D.Type),NEW;
+  BEGIN
+    jf.PutElement(mapOrdRepT(mapVecElTp(eTp)));
+  END PutVecElement;
+
+(* ------------------------------- *)
+
+  PROCEDURE (jf : JavaFile)GetVecElement*(eTp : D.Type),NEW;
+    VAR rTp : D.Type; (* representation type *)
+  BEGIN
+    rTp := mapOrdRepT(mapVecElTp(eTp));
+   (*
+    *  If rTp and eTp are not equal, then must restore erased type
+    *)
+    jf.GetElement(rTp);
+    IF rTp # eTp THEN
+      IF rTp = G.anyPtr THEN
+        jf.CodeT(Jvm.opc_checkcast, eTp);
+      ELSE
+        jf.ConvertDn(rTp, eTp);
+      END;
+    END;
+  END GetVecElement;
+
+(* ============================================================ *)
+(*			Some static utilities			*)
+(* ============================================================ *)
+
+  PROCEDURE jvmSize*(t : D.Type) : INTEGER;
+  BEGIN
+    IF t.isLongType() THEN RETURN 2 ELSE RETURN 1 END;
+  END jvmSize;
+
+(* ------------------------------------------------------------ *)
+
+  PROCEDURE needsBox*(i : Id.ParId) : BOOLEAN;
+  (*   A parameter needs to be boxed if it has non-reference 	*)
+  (*   representation in the JVM, and is OUT or VAR mode.	*)
+  BEGIN
+    RETURN ((i.parMod = D.var) OR (i.parMod = D.out)) & 
+	   i.type.isScalarType();
+  END needsBox;
+
+(* ============================================================ *)
+
+  PROCEDURE cat2*(i,j : L.CharOpen) : L.CharOpen;
+  BEGIN
+    L.ResetCharOpenSeq(nmArray);
+    L.AppendCharOpen(nmArray, i);
+    L.AppendCharOpen(nmArray, j);
+    RETURN L.arrayCat(nmArray); 
+  END cat2;
+
+  PROCEDURE cat3*(i,j,k : L.CharOpen) : L.CharOpen;
+  BEGIN
+    L.ResetCharOpenSeq(nmArray);
+    L.AppendCharOpen(nmArray, i);
+    L.AppendCharOpen(nmArray, j);
+    L.AppendCharOpen(nmArray, k);
+    RETURN L.arrayCat(nmArray);
+  END cat3;
+
+(* ------------------------------------------------------------ *)
+
+  PROCEDURE MkBlkName*(mod : Id.BlkId);
+    VAR mNm : L.CharOpen;
+  (* -------------------------------------------------- *)
+    PROCEDURE dotToSlash(arr : L.CharOpen) : L.CharOpen;
+      VAR ix : INTEGER;
+    BEGIN
+      FOR ix := 0 TO LEN(arr)-1 DO
+	IF arr[ix] = "." THEN arr[ix] := "/" END;
+      END;
+      RETURN arr;
+    END dotToSlash;
+  (* -------------------------------------------------- * 
+   * PROCEDURE defaultClass(arr : L.CharOpen) : L.CharOpen;
+   *   VAR ix : INTEGER;
+   *       ln : INTEGER;
+   *       ch : CHAR;
+   * BEGIN
+   *  (*
+   *   *  The incoming literal package name has a name
+   *   *  of the form "blah/.../final".  We want the 
+   *   *  default class name to be "final".
+   *   *)
+   *   ln := 0;
+   *   FOR ix := 0 TO LEN(arr)-1 DO
+   *     IF arr[ix] = "/" THEN ln := ix+1 END;
+   *   END;
+   *   RETURN L.subChOToChO(arr, ln, LEN(arr) - ln);
+   * END defaultClass;
+ * ---------------------------------------------------- *
+ * BEGIN
+ *   IF mod.xName # NIL THEN RETURN END;
+ *   IF mod.scopeNm # NIL THEN 
+ *     mod.scopeNm := dotToSlash(mod.scopeNm);
+ *     mod.xName   := defaultClass(mod.scopeNm);
+ *   ELSE
+ *     mNm := D.getName.ChPtr(mod);
+ *     mod.scopeNm := cat3(prfx, slsh, mNm); (* "CP/<modname>" *)
+ *     IF CompState.doCode & ~CompState.doJsmn THEN
+ *       mod.xName := cat3(mod.scopeNm, slsh, mNm);
+ *     ELSE
+ *       mod.xName   := mNm;
+ *     END;
+ *   END;
+ * ---------------------------------------------------- *)
+  BEGIN
+    IF mod.xName # NIL THEN RETURN END;
+    mNm := D.getName.ChPtr(mod);
+    IF mod.scopeNm # NIL THEN 
+      mod.scopeNm := dotToSlash(mod.scopeNm);
+    ELSE
+      mod.scopeNm := cat3(prfx, slsh, mNm); (* "CP/<modname>" *)
+    END;
+    IF ~CompState.doCode         (* Only doing Jasmin output       *)
+        OR CompState.doJsmn      (* Forcing assembly via Jasmin    *)
+        OR (mod.scopeNm[0] = 0X) (* Explicitly forcing no package! *) THEN
+      mod.xName   := mNm;
+    ELSE (* default case *)
+      mod.xName := cat3(mod.scopeNm, slsh, mNm);
+    END;
+  END MkBlkName;
+
+(* ------------------------------------------------------------ *)
+
+  PROCEDURE scopeName(scp : D.Scope) : L.CharOpen;
+  BEGIN
+    WITH scp : Id.BlkId DO
+        IF scp.xName = NIL THEN MkBlkName(scp) END;
+        IF CompState.doCode & ~CompState.doJsmn THEN
+          RETURN D.getName.ChPtr(scp);
+        ELSE
+          RETURN scp.xName; 
+        END;
+    | scp : Id.Procs DO
+        IF scp.prcNm = NIL THEN MkProcName(scp) END;
+	RETURN scp.prcNm;
+    END;
+  END scopeName;
+
+(* ------------------------------------------------------------ *)
+
+  PROCEDURE qualScopeName(scp : D.Scope) : L.CharOpen;
+  BEGIN
+    WITH scp : Id.BlkId DO
+        IF scp.xName = NIL THEN MkBlkName(scp) END;
+	RETURN scp.scopeNm;
+    | scp : Id.Procs DO
+        IF scp.prcNm = NIL THEN MkProcName(scp) END;
+	RETURN scp.scopeNm;
+    END;
+  END qualScopeName;
+
+(* ------------------------------------------------------------ *)
+
+  PROCEDURE MkRecName*(typ : Ty.Record);
+    VAR mNm : L.CharOpen;
+	qNm : L.CharOpen;
+	rNm : L.CharOpen;
+	tId : D.Idnt;
+  BEGIN
+    IF typ.xName # NIL THEN RETURN END;
+    IF typ.bindTp # NIL THEN		(* Synthetically named rec'd *)
+      tId := typ.bindTp.idnt;
+      rNm := D.getName.ChPtr(tId);
+    ELSE				(* Normal, named record type *)
+      IF typ.idnt = NIL THEN		(* Anonymous record type     *)
+        typ.idnt := Id.newAnonId(typ.serial);
+      END;
+      tId := typ.idnt;
+      rNm := D.getName.ChPtr(tId);
+    END;
+
+    IF tId.dfScp = NIL THEN tId.dfScp := CompState.thisMod END;
+
+    mNm := scopeName(tId.dfScp);
+    qNm := qualScopeName(tId.dfScp);
+   (*
+    *  At this point:
+    *	    rNm holds the simple record name
+    *	    mNm holds the qualifying module name
+    *	    qNm holds the qualifying scope name
+    *	    If extrnNm = NIL, the default mangling is used.
+    *  At exit we want:
+    *	    xName to hold the fully qualified name
+    *	    extrnNm to hold the simple name
+    *	    scopeNm to hold the "L<qualid>;" name
+    *)
+    IF typ.extrnNm # NIL THEN
+      typ.extrnNm := rNm;
+    ELSE
+      typ.extrnNm := cat3(mNm, lowL, rNm);
+    END;
+    IF qNm[0] # 0X THEN
+      typ.xName := cat3(qNm, slsh, typ.extrnNm);
+    ELSE
+      typ.xName := typ.extrnNm;
+    END;
+    typ.scopeNm := cat3(lCap, typ.xName, semi);
+
+   (*
+    *   It is at this point that we link records into the
+    *   class-emission worklist.
+    *)
+    IF tId.dfScp.kind # Id.impId THEN
+      JavaBase.worklist.AddNewRecEmitter(typ);
+    END;
+  END MkRecName;
+
+(* ------------------------------------------------------------ *)
+
+  PROCEDURE MkVecName*(typ : Ty.Vector);
+    VAR ord : INTEGER;
+        rTp : Ty.Record;
+  BEGIN
+    ord := mapVecElTp(typ.elemTp);
+    rTp := vecRecTyp(ord);
+    IF rTp.xName = NIL THEN MkRecName(rTp) END;
+    typ.xName := rTp.scopeNm;
+  END MkVecName;
+
+(* ------------------------------------------------------------ *)
+
+  PROCEDURE MkProcName*(proc : Id.Procs);
+    VAR pNm : L.CharOpen;
+	res : Id.Procs;
+	scp : D.Scope;
+	bTp : Ty.Record;
+  (* -------------------------------------------------- *)
+    PROCEDURE clsNmFromRec(typ : D.Type) : L.CharOpen;
+    BEGIN
+      IF CompState.doCode & ~CompState.doJsmn THEN
+        RETURN typ(Ty.Record).xName;
+      ELSE
+        RETURN typ(Ty.Record).extrnNm;
+      END;
+    END clsNmFromRec;
+  (* -------------------------------------------------- *)
+    PROCEDURE className(p : Id.Procs) : L.CharOpen;
+    BEGIN
+      WITH p : Id.PrcId DO RETURN p.clsNm;
+      |    p : Id.MthId DO RETURN clsNmFromRec(p.bndType);
+      END;
+    END className;
+  (* -------------------------------------------------- *)
+    PROCEDURE GetClassName(pr : Id.PrcId; bl : Id.BlkId);
+      VAR nm : L.CharOpen;
+    BEGIN
+      nm := D.getName.ChPtr(pr);
+      IF pr.bndType = NIL THEN	(* normal case  *)
+        pr.clsNm := bl.xName;
+        IF pr.prcNm = NIL THEN pr.prcNm := nm END;
+      ELSE			(* static method *)
+	IF pr.bndType.xName = NIL THEN MkRecName(pr.bndType(Ty.Record)) END;
+	pr.clsNm := clsNmFromRec(pr.bndType);
+        IF pr.prcNm = NIL THEN
+          pr.prcNm := nm;
+        ELSIF pr.prcNm^ = initStr THEN
+          pr.SetKind(Id.ctorP);
+        END;
+      END;
+    END GetClassName;
+  (* -------------------------------------------------- *)
+    PROCEDURE MkPrcNm(prc : Id.PrcId);
+      VAR res : Id.PrcId;
+	  scp : D.Scope;
+	  blk : Id.BlkId;
+	  rTp : Ty.Record;
+    BEGIN
+      IF prc.scopeNm # NIL THEN RETURN;
+      ELSIF prc.kind = Id.fwdPrc THEN
+        res := prc.resolve(Id.PrcId); MkPrcNm(res);
+        prc.prcNm := res.prcNm;
+        prc.clsNm := res.clsNm;
+        prc.scopeNm := res.scopeNm;
+      ELSIF prc.kind = Id.conPrc THEN
+        scp := prc.dfScp;
+        WITH scp : Id.BlkId DO
+            IF scp.xName = NIL THEN MkBlkName(scp) END;
+            IF  D.isFn IN scp.xAttr THEN
+              GetClassName(prc, scp);
+            ELSE
+              prc.clsNm := scp.xName;
+              IF prc.prcNm = NIL THEN prc.prcNm := D.getName.ChPtr(prc) END;
+            END;
+        | scp : Id.Procs DO
+            MkProcName(scp);
+            prc.clsNm := className(scp);
+            prc.prcNm   := cat3(D.getName.ChPtr(prc), dlar, scp.prcNm);
+        END;
+        prc.scopeNm := scp.scopeNm;
+      ELSE (* prc.kind = Id.ctorP *)
+        blk := prc.dfScp(Id.BlkId);
+	rTp := prc.type.returnType().boundRecTp()(Ty.Record);
+        IF blk.xName = NIL THEN MkBlkName(blk) END;
+        IF rTp.xName = NIL THEN MkRecName(rTp) END;
+        prc.clsNm := clsNmFromRec(rTp);
+        prc.prcNm := L.strToCharOpen(initStr);
+        prc.scopeNm := blk.scopeNm;
+      END;
+    END MkPrcNm;
+  (* -------------------------------------------------- *)
+    PROCEDURE MkMthNm(mth : Id.MthId);
+      VAR res : Id.MthId;
+          scp : Id.BlkId;
+          typ : D.Type;
+    BEGIN
+      IF mth.scopeNm # NIL THEN RETURN;
+      ELSIF mth.kind = Id.fwdMth THEN
+        res := mth.resolve(Id.MthId); MkMthNm(res);
+        mth.prcNm := res.prcNm; mth.scopeNm := res.scopeNm;
+      ELSE
+        scp := mth.dfScp(Id.BlkId);
+        typ := mth.bndType;
+        IF typ.xName = NIL THEN MkRecName(typ(Ty.Record)) END;
+        IF scp.xName = NIL THEN MkBlkName(scp) END;
+
+        mth.scopeNm := scp.scopeNm;
+        IF mth.prcNm = NIL THEN mth.prcNm := D.getName.ChPtr(mth) END;
+      END;
+    END MkMthNm;
+  (* -------------------------------------------------- *)
+  BEGIN (* MkProcName *)
+    WITH proc : Id.MthId DO MkMthNm(proc);
+    |    proc : Id.PrcId DO MkPrcNm(proc);
+    END;
+  END MkProcName;
+
+(* ------------------------------------------------------------ *)
+
+  PROCEDURE MkAliasName*(typ : Ty.Opaque);
+    VAR mNm : L.CharOpen;
+	rNm : L.CharOpen;
+	sNm : L.CharOpen;
+  BEGIN
+   (* 
+    * This was almost certainly broken,  
+    * at least for foreign explicit names 
+    *)
+    IF typ.xName # NIL THEN RETURN END;
+    rNm := D.getName.ChPtr(typ.idnt);
+   (* 
+    * old code --
+    *  mNm := scopeName(typ.idnt.dfScp);
+    *  sNm := cat3(mNm, lowL, rNm);
+    *  typ.xName   := cat3(qualScopeName(typ.idnt.dfScp), slsh, sNm);
+    *
+    * replaced by ...
+    *)
+    typ.xName   := cat3(qualScopeName(typ.idnt.dfScp), slsh, rNm);
+   (* end *)
+    typ.scopeNm := cat3(lCap, typ.xName, semi);
+  END MkAliasName;
+
+(* ------------------------------------------------------------ *)
+
+  PROCEDURE MkVarName*(var : Id.VarId);
+    VAR mod : Id.BlkId;
+  BEGIN
+    IF var.varNm # NIL THEN RETURN END;
+    mod := var.dfScp(Id.BlkId);
+    var.varNm := D.getName.ChPtr(var);
+    IF var.recTyp = NIL THEN	(* normal case *)
+      var.clsNm := mod.xName;
+    ELSE			(* static field *)
+      IF var.recTyp.xName = NIL THEN MkRecName(var.recTyp(Ty.Record)) END;
+      var.clsNm := var.recTyp(Ty.Record).extrnNm;
+    END;
+  END MkVarName;
+
+(* ------------------------------------------------------------ *)
+
+  PROCEDURE NumberParams(pIdn : Id.Procs; pTyp : Ty.Procedure);
+    VAR parId : Id.ParId;
+	index : INTEGER;
+	count : INTEGER;
+	retTp : D.Type;
+   (* ----------------------------------------- *)
+    PROCEDURE AppendTypeName(VAR lst : L.CharOpenSeq; typ : D.Type);
+    BEGIN
+      WITH typ : Ty.Base DO
+	  L.AppendCharOpen(lst, typ.xName);
+      | typ : Ty.Vector DO
+	  IF typ.xName = NIL THEN MkVecName(typ) END;
+	  L.AppendCharOpen(lst, typ.xName);
+      | typ : Ty.Array DO
+	  L.AppendCharOpen(lst, brac);
+	  AppendTypeName(lst, typ.elemTp);
+      | typ : Ty.Record DO
+	  IF typ.xName = NIL THEN MkRecName(typ) END;
+	  L.AppendCharOpen(lst, typ.scopeNm);
+      | typ : Ty.Enum DO
+	  AppendTypeName(lst, G.intTp);
+      | typ : Ty.Pointer DO
+	  AppendTypeName(lst, typ.boundTp);
+      | typ : Ty.Opaque DO
+	  IF typ.xName = NIL THEN MkAliasName(typ) END;
+	  L.AppendCharOpen(lst, typ.scopeNm);
+      END;
+    END AppendTypeName;
+   (* ----------------------------------------- *)
+  BEGIN
+   (*
+    *  The parameter numbering scheme tries to use the return
+    *  value for the first OUT or VAR parameter.  The variable
+    *  hasRt, notes whether this possiblity has been used up. If
+    *  this is a value returning function hasRt is true at entry.
+    *)
+    count := pIdn.rtsFram;
+    retTp := pTyp.retType;
+    IF pIdn.kind = Id.ctorP THEN 
+      INC(count);
+    ELSIF retTp # NIL THEN	(* and not a constructor... *)
+      pTyp.retN := jvmSize(pTyp.retType);
+    END;
+    L.ResetCharOpenSeq(fmArray);
+    L.AppendCharOpen(fmArray, lPar);
+    IF pIdn.lxDepth > 0 THEN
+      LitValue.AppendCharOpen(fmArray, xhrMk); INC(count);
+    END;
+    FOR index := 0 TO pTyp.formals.tide-1 DO
+      parId := pTyp.formals.a[index];
+      IF needsBox(parId) THEN
+	IF parId.parMod = D.var THEN (* pass value as well *)
+	  parId.varOrd := count;
+	  INC(count, jvmSize(parId.type));
+	  AppendTypeName(fmArray, parId.type);
+	END;
+	IF retTp = NIL THEN
+	 (*
+	  *  Return slot is not already used, use it now.
+	  *)
+	  parId.boxOrd := retMarker;
+	  pTyp.retN := jvmSize(parId.type);
+	  retTp := parId.type;
+	ELSE
+	 (*
+	  *  Return slot is already used, use a boxed variable.
+	  *)
+	  parId.boxOrd := count;
+	  INC(count);
+	  L.AppendCharOpen(fmArray, brac);
+	  AppendTypeName(fmArray, parId.type);
+	END;
+      ELSE  (* could be two slots ... *)
+	parId.varOrd := count;
+	INC(count, jvmSize(parId.type));
+	AppendTypeName(fmArray, parId.type);
+      END;
+    END;
+    L.AppendCharOpen(fmArray, rPar);
+    IF (retTp = NIL) OR (pIdn.kind = Id.ctorP) THEN 
+      L.AppendCharOpen(fmArray, void);
+    ELSIF (pIdn IS Id.MthId) & (Id.covar IN pIdn(Id.MthId).mthAtt) THEN
+     (*
+      *  This is a method with a covariant return type. We must
+      *  erase the declared type, substituting the non-covariant
+      *  upper-bound. Calls will cast the result to the real type.
+      *)
+      AppendTypeName(fmArray, pIdn.retTypBound());
+    ELSE
+      AppendTypeName(fmArray, retTp);
+    END;
+    pTyp.xName := L.arrayCat(fmArray);
+   (*
+    *   We must now set the argsize and retsize.
+    *   The current info.lNum (before the locals
+    *   have been added) is the argsize.
+    *)
+    pTyp.argN := count;
+    pIdn.rtsFram := count;
+  END NumberParams;
+
+(* ------------------------------------------------------------ *)
+
+  PROCEDURE NumberProxies(pIdn : Id.Procs; IN pars : Id.ParSeq);
+  (* Proxies are the local variables corresponding to boxed	*)
+  (* arguments that are not also passed by value i.e. OUT mode. *)
+    VAR parId : Id.ParId;
+	index : INTEGER;
+  BEGIN
+   (* ------------------ *
+    *  Allocate an activation record slot for the XHR,
+    *  if this is needed.  The XHR reference will be local
+    *  number pIdn.type.argN.
+    *)
+    IF Id.hasXHR IN pIdn.pAttr THEN MkXHR(pIdn); INC(pIdn.rtsFram) END;
+   (* ------------------ *)
+    FOR index := 0 TO pars.tide-1 DO
+      parId := pars.a[index];
+      IF parId.parMod # D.var THEN
+	IF needsBox(parId) THEN
+	  parId.varOrd := pIdn.rtsFram;
+	  INC(pIdn.rtsFram, jvmSize(parId.type));
+	END;
+      END;
+    END;
+  END NumberProxies;
+
+(* ------------------------------------------------------------ *)
+
+  PROCEDURE NumberLocals(pIdn : Id.Procs; IN locs : D.IdSeq);
+    VAR ident : D.Idnt;
+	index : INTEGER;
+	count : INTEGER;
+  BEGIN
+    count := pIdn.rtsFram;
+    FOR index := 0 TO locs.tide-1 DO
+      ident := locs.a[index];
+      WITH ident : Id.ParId DO (* skip *)
+      | ident : Id.LocId DO
+	  ident.varOrd := count;
+	  INC(count, jvmSize(ident.type));
+      END;
+    END;
+    pIdn.rtsFram := count;
+  END NumberLocals;
+
+(* ------------------------------------------------------------ *)
+
+  PROCEDURE MkCallAttr*(pIdn : D.Idnt; pTyp : Ty.Procedure);
+  BEGIN
+    WITH pIdn : Id.MthId DO
+	IF ~needsBox(pIdn.rcvFrm) THEN 
+	  pIdn.rtsFram := 1;	(* count one for "this" *)
+	ELSE
+	  pIdn.rtsFram := 2;	(* this plus the retbox *)
+	END;
+	MkProcName(pIdn);
+	NumberParams(pIdn, pTyp);
+    | pIdn : Id.PrcId DO 
+        pIdn.rtsFram := 0;
+	MkProcName(pIdn);
+	NumberParams(pIdn, pTyp);
+    END;
+  END MkCallAttr;
+
+(* ------------------------------------------------------------ *)
+
+  PROCEDURE RenumberLocals*(prcId : Id.Procs);
+    VAR parId : Id.ParId;
+	frmTp : Ty.Procedure;
+	funcT : BOOLEAN;
+  BEGIN
+   (*
+    * Rules:
+    * 	(i)   The receiver (if any) must be #0
+    * 	(ii)  Params are #1 .. #N, or #0 .. for statics
+    * 	(iii) Locals are #(N+1) ...
+    * 	(iv)  doubles and longs take two slots.
+    * 
+    *   This procedure computes the number of local slots. It
+    *   renumbers the varOrd fields, and initializes rtsFram.
+    *   The procedure also computes the formal name for the JVM.
+    *) 
+    prcId.rtsFram := 0;
+    frmTp := prcId.type(Ty.Procedure);
+    funcT := (frmTp.retType # NIL);
+    WITH prcId : Id.MthId DO
+      parId := prcId.rcvFrm;
+      parId.varOrd := 0;   prcId.rtsFram := 1;	(* count one for "this" *)
+      ASSERT(~needsBox(parId));
+(*
+ *  Receivers are never boxed in Component Pascal
+ *
+ *    IF needsBox(parId) THEN 
+ *      parId.boxOrd := 1; prcId.rtsFram := 2;	(* count one for retbox *)
+ *    END;
+ *)
+    ELSE (* skip static procedures *)
+    END;
+   (*
+    *   Assert: params do not appear in the local array.
+    *   Count params (and boxes if needed).
+    *)
+    NumberParams(prcId, frmTp);
+    IF prcId.body # NIL THEN
+      NumberProxies(prcId, frmTp.formals);
+      NumberLocals(prcId, prcId.locals);
+    END;
+  END RenumberLocals;
+
+(* ------------------------------------------------------------ *)
+
+  PROCEDURE (jf : JavaFile)LoadLocal*(ord : INTEGER; typ : D.Type),NEW;
+    VAR code : INTEGER;
+  BEGIN
+    IF (typ # NIL) & (typ IS Ty.Base) THEN 
+      code := typeLoad[typ(Ty.Base).tpOrd];
+    ELSE
+      code := Jvm.opc_aload;
+    END;
+    IF ord < 4 THEN
+      CASE code OF
+      | Jvm.opc_iload : code := Jvm.opc_iload_0 + ord;
+      | Jvm.opc_lload : code := Jvm.opc_lload_0 + ord;
+      | Jvm.opc_fload : code := Jvm.opc_fload_0 + ord;
+      | Jvm.opc_dload : code := Jvm.opc_dload_0 + ord;
+      | Jvm.opc_aload : code := Jvm.opc_aload_0 + ord;
+      END;
+      jf.Code(code);
+    ELSE
+      jf.CodeI(code, ord);
+    END;
+  END LoadLocal;
+
+(* ---------------------------------------------------- *)
+
+  PROCEDURE (jf : JavaFile)GetLocal*(var : Id.LocId),NEW;
+  BEGIN
+    IF Id.uplevA IN var.locAtt THEN jf.GetUplevel(var);
+    ELSE jf.LoadLocal(var.varOrd, var.type);
+    END;
+  END GetLocal;
+
+(* ---------------------------------------------------- *)
+
+  PROCEDURE typeToChOpen(typ : D.Type) : L.CharOpen;
+   (* --------------------------------------------- *)
+    PROCEDURE slashToDot(a : L.CharOpen) : L.CharOpen;
+      VAR nw : L.CharOpen; ix : INTEGER; ch : CHAR;
+    BEGIN
+      NEW(nw, LEN(a));
+      FOR ix := 0 TO LEN(a)-1 DO
+	ch := a[ix]; IF ch = "/" THEN nw[ix] := "." ELSE nw[ix] := ch  END;
+      END;
+      RETURN nw;
+    END slashToDot;
+   (* --------------------------------------------- *)
+    PROCEDURE typeTag(typ : D.Type) : L.CharOpen;
+    BEGIN
+      WITH typ : Ty.Base DO
+          RETURN typ.xName;
+      | typ : Ty.Array DO
+          RETURN cat2(brac, typeTag(typ.elemTp));
+      | typ : Ty.Record DO
+	  IF typ.xName = NIL THEN MkRecName(typ) END;
+          RETURN slashToDot(typ.scopeNm);
+      | typ : Ty.Enum DO
+          RETURN G.intTp.xName;
+      | typ : Ty.Pointer DO
+          RETURN typeTag(typ.boundTp);
+      | typ : Ty.Opaque DO
+	  IF typ.xName = NIL THEN MkAliasName(typ) END;
+          RETURN slashToDot(typ.scopeNm);
+      END;
+    END typeTag;
+   (* --------------------------------------------- *)
+  BEGIN 
+    WITH typ : Ty.Array DO
+        RETURN cat2(brac, typeTag(typ.elemTp));
+    | typ : Ty.Record DO
+	IF typ.xName = NIL THEN MkRecName(typ) END;
+        RETURN slashToDot(typ.xName);
+    | typ : Ty.Pointer DO
+        RETURN typeToChOpen(typ.boundTp);
+    | typ : Ty.Opaque DO
+	IF typ.xName = NIL THEN MkAliasName(typ) END;
+        RETURN slashToDot(typ.xName);
+    END;
+  END typeToChOpen;
+
+(* ---------------------------------------------------- *)
+
+  PROCEDURE (jf : JavaFile)LoadType*(id : D.Idnt),NEW;
+    VAR tp : D.Type;
+  BEGIN
+    ASSERT(id IS Id.TypId);
+    tp := id.type;
+    WITH tp : Ty.Base DO
+      jf.PushInt(tp.tpOrd);
+      jf.CallRTS(LoadTp1, 1, 1);
+    ELSE
+     (*
+      *  First we get the string-name of the 
+      *  type, and then we push the string.
+      *)
+      jf.PushStr(typeToChOpen(id.type));
+     (*
+      *  Then we call getClassByName
+      *)
+      jf.CallRTS(LoadTp2, 1, 1);
+    END;
+  END LoadType;
+
+(* ---------------------------------------------------- *)
+
+  PROCEDURE (jf : JavaFile)GetVar*(id : D.Idnt),NEW;
+    VAR var : Id.AbVar;
+        scp : D.Scope;
+  BEGIN
+    var := id(Id.AbVar);
+    IF var.kind = Id.conId THEN
+      jf.GetLocal(var(Id.LocId));
+    ELSE
+      scp := var.dfScp;
+      WITH scp : Id.BlkId DO
+        jf.PutGetS(Jvm.opc_getstatic, scp, var(Id.VarId));
+      ELSE (* must be local *)
+        jf.GetLocal(var(Id.LocId));
+      END;
+    END;
+  END GetVar;
+
+(* ------------------------------------------------------------ *)
+
+  PROCEDURE (jf : JavaFile)StoreLocal*(ord : INTEGER; typ : D.Type),NEW;
+    VAR code : INTEGER;
+  BEGIN
+    IF (typ # NIL) & (typ IS Ty.Base) THEN 
+      code := typeStore[typ(Ty.Base).tpOrd];
+    ELSE
+      code := Jvm.opc_astore;
+    END;
+    IF ord < 4 THEN
+      CASE code OF
+      | Jvm.opc_istore : code := Jvm.opc_istore_0 + ord;
+      | Jvm.opc_lstore : code := Jvm.opc_lstore_0 + ord;
+      | Jvm.opc_fstore : code := Jvm.opc_fstore_0 + ord;
+      | Jvm.opc_dstore : code := Jvm.opc_dstore_0 + ord;
+      | Jvm.opc_astore : code := Jvm.opc_astore_0 + ord;
+      END;
+      jf.Code(code);
+    ELSE
+      jf.CodeI(code, ord);
+    END;
+  END StoreLocal;
+
+(* ---------------------------------------------------- *)
+
+  PROCEDURE (jf : JavaFile)PutLocal*(var : Id.LocId),NEW;
+  BEGIN
+    IF Id.uplevA IN var.locAtt THEN jf.PutUplevel(var);
+    ELSE jf.StoreLocal(var.varOrd, var.type);
+    END;
+  END PutLocal;
+
+(* ---------------------------------------------------- *)
+
+  PROCEDURE (jf : JavaFile)PutVar*(id : D.Idnt),NEW;
+    VAR var : Id.AbVar;
+	scp : D.Scope;
+  BEGIN
+    var := id(Id.AbVar);
+    scp := var.dfScp;
+    WITH scp : Id.BlkId DO
+      jf.PutGetS(Jvm.opc_putstatic, scp, var(Id.VarId));
+    ELSE (* could be in an XHR *)
+      jf.PutLocal(var(Id.LocId));
+    END;
+  END PutVar;
+
+(* ------------------------------------------------------------ *)
+
+  PROCEDURE (jf : JavaFile)PutElement*(typ : D.Type),NEW;
+    VAR code : INTEGER;
+  BEGIN
+    IF (typ # NIL) & (typ IS Ty.Base) THEN
+      code := typePutE[typ(Ty.Base).tpOrd];
+    ELSE
+      code := Jvm.opc_aastore;
+    END;
+    jf.Code(code);
+  END PutElement;
+
+(* ------------------------------------------------------------ *)
+
+  PROCEDURE (jf : JavaFile)GetElement*(typ : D.Type),NEW;
+    VAR code : INTEGER;
+  BEGIN
+    IF (typ # NIL) & (typ IS Ty.Base) THEN
+      code := typeGetE[typ(Ty.Base).tpOrd];
+    ELSE
+      code := Jvm.opc_aaload;
+    END;
+    jf.Code(code);
+  END GetElement;
+
+(* ------------------------------------------------------------ *)
+
+  PROCEDURE (jf : JavaFile)PushInt*(num : INTEGER),NEW;
+  VAR
+    conIx : INTEGER;
+  BEGIN
+    IF (num >= MIN(BYTE)) & (num <= MAX(BYTE)) THEN
+      CASE num OF
+      | -1 : jf.Code(Jvm.opc_iconst_m1);
+      |  0 : jf.Code(Jvm.opc_iconst_0);
+      |  1 : jf.Code(Jvm.opc_iconst_1);
+      |  2 : jf.Code(Jvm.opc_iconst_2);
+      |  3 : jf.Code(Jvm.opc_iconst_3);
+      |  4 : jf.Code(Jvm.opc_iconst_4);
+      |  5 : jf.Code(Jvm.opc_iconst_5);
+      ELSE
+        jf.CodeI(Jvm.opc_bipush, num);
+      END;
+    ELSE
+      jf.LoadConst(num);
+    END;
+  END PushInt;
+
+(* ------------------------------------------------------------ *)
+
+  PROCEDURE (jf : JavaFile)PushLong*(num : LONGINT),NEW;
+  BEGIN
+    IF num = 0 THEN
+      jf.Code(Jvm.opc_lconst_0);
+    ELSIF num = 1 THEN
+      jf.Code(Jvm.opc_lconst_1);
+    ELSIF (num >= MIN(INTEGER)) & (num <= MAX(INTEGER)) THEN
+      jf.PushInt(SHORT(num));
+      jf.Code(Jvm.opc_i2l);
+    ELSE
+      jf.CodeL(Jvm.opc_ldc2_w, num);
+    END;
+  END PushLong;
+
+(* ------------------------------------------------------------ *)
+
+  PROCEDURE (jf : JavaFile)PushReal*(num : REAL),NEW;
+  BEGIN
+    IF num = 0.0 THEN
+      jf.Code(Jvm.opc_dconst_0);
+    ELSIF num = 1.0 THEN
+      jf.Code(Jvm.opc_dconst_1);
+    ELSE
+      jf.CodeR(Jvm.opc_ldc2_w, num, FALSE);
+    END;
+  END PushReal;
+
+(* ------------------------------------------------------------ *)
+
+  PROCEDURE (jf : JavaFile)PushSReal*(num : REAL),NEW;
+  VAR
+    conIx : INTEGER;
+  BEGIN
+    IF num = 0.0 THEN
+      jf.Code(Jvm.opc_fconst_0);
+    ELSIF num = 1.0 THEN
+      jf.Code(Jvm.opc_fconst_1);
+    ELSIF num = 2.0 THEN
+      jf.Code(Jvm.opc_fconst_2);
+    ELSE
+      jf.CodeR(Jvm.opc_ldc, num, TRUE);
+    END;
+  END PushSReal;
+
+(* ------------------------------------------------------------ *)
+
+  PROCEDURE (jf : JavaFile)PushStaticLink*(tgt : Id.Procs),NEW;
+    VAR lxDel : INTEGER;
+	clr   : Id.Procs;
+	pTp   : Ty.Procedure;
+  BEGIN
+    clr   := jf.theP;
+    lxDel := tgt.lxDepth - clr.lxDepth;
+    pTp   := clr.type(Ty.Procedure);
+
+    CASE lxDel OF
+    | 0 : jf.Code(Jvm.opc_aload_0);
+    | 1 : IF Id.hasXHR IN clr.pAttr THEN
+            jf.LoadLocal(pTp.argN, NIL);
+          ELSIF clr.lxDepth = 0 THEN
+            jf.Code(Jvm.opc_aconst_null);
+          ELSE
+            jf.Code(Jvm.opc_aload_0);
+          END;
+    ELSE
+      jf.Code(Jvm.opc_aload_0);
+      REPEAT
+        clr := clr.dfScp(Id.Procs);
+        IF Id.hasXHR IN clr.pAttr THEN 
+	  jf.PutGetF(Jvm.opc_getfield, 
+		CompState.rtsXHR.boundRecTp()(Ty.Record), CompState.xhrId);
+        END;
+      UNTIL clr.lxDepth = tgt.lxDepth;
+    END;
+  END PushStaticLink;
+
+(* ------------------------------------------------------------ *)
+
+  PROCEDURE (jf : JavaFile)GetXHR(var : Id.LocId),NEW;
+    VAR scp : Id.Procs; (* the scope holding the datum *)
+	clr : Id.Procs; (* the scope making the call   *)
+        pTp : Ty.Procedure;
+	del : INTEGER;
+  BEGIN
+    scp := var.dfScp(Id.Procs);
+    clr := jf.theP;
+    pTp := clr.type(Ty.Procedure);
+   (*
+    *  Check if this is an own local
+    *)
+    IF scp = clr THEN
+      jf.LoadLocal(pTp.argN, NIL);
+    ELSE
+      del := xhrCount(scp, clr);
+     (*
+      *  First, load the static link
+      *)
+      jf.Code(Jvm.opc_aload_0);
+     (*
+      *  Next, load the XHR pointer.
+      *)
+      WHILE del > 1 DO
+	jf.PutGetF(Jvm.opc_getfield, 
+		CompState.rtsXHR.boundRecTp()(Ty.Record), CompState.xhrId);
+        DEC(del);
+      END;
+     (*
+      *  Finally, cast to concrete type
+      *)
+      jf.CodeT(Jvm.opc_checkcast, scp.xhrType);
+    END;
+  END GetXHR;
+
+(* ------------------------------------------------------------ *)
+
+  PROCEDURE (jf : JavaFile)PutGetX*(cde : INTEGER; var : Id.LocId),NEW;
+    VAR pTyp : D.Type;
+  BEGIN
+    pTyp := var.dfScp(Id.Procs).xhrType;
+    jf.PutGetF(cde, pTyp.boundRecTp()(Ty.Record), var);
+  END PutGetX;
+
+(* ------------------------------------------------------------ *)
+
+  PROCEDURE (jf : JavaFile)XhrHandle*(var : Id.LocId),NEW;
+  BEGIN
+    jf.GetXHR(var);
+  END XhrHandle;
+
+(* ------------------------------------------------------------ *)
+
+  PROCEDURE (jf : JavaFile)GetUplevel*(var : Id.LocId),NEW;
+  BEGIN
+    jf.GetXHR(var);
+    jf.PutGetX(Jvm.opc_getfield, var);
+  END GetUplevel;
+
+(* ------------------------------------------------------------ *)
+
+  PROCEDURE (jf : JavaFile)PutUplevel*(var : Id.LocId),NEW;
+  BEGIN
+    jf.PutGetX(Jvm.opc_putfield, var);
+  END PutUplevel;
+
+(* ------------------------------------------------------------ *)
+
+  PROCEDURE (jf : JavaFile)ConvertUp*(inT, outT : D.Type),NEW;
+   (* Conversion "up" is always safe at runtime. Many are nop.	*)
+    VAR inB, outB, code : INTEGER;
+  BEGIN
+    inB  := inT(Ty.Base).tpOrd;
+    outB := outT(Ty.Base).tpOrd;
+    IF inB = outB THEN RETURN END;		(* PREMATURE RETURN! *)
+    CASE outB OF
+    | Ty.realN :
+	IF    inB = Ty.sReaN THEN code := Jvm.opc_f2d;
+	ELSIF inB = Ty.lIntN THEN code := Jvm.opc_l2d;
+	ELSE 			  code := Jvm.opc_i2d;
+        END;
+    | Ty.sReaN :
+	IF    inB = Ty.lIntN THEN code := Jvm.opc_l2f;
+	ELSE 			  code := Jvm.opc_i2f;
+        END;
+    | Ty.lIntN :
+	code := Jvm.opc_i2l;
+    ELSE RETURN;				(* PREMATURE RETURN! *)
+    END;
+    jf.Code(code);
+  END ConvertUp;
+
+(* ------------------------------------------------------------ *)
+
+  PROCEDURE (jf : JavaFile)ConvertDn*(inT, outT : D.Type),NEW;
+   (* Conversion "down" often needs a runtime check. *)
+    VAR inB, outB, code : INTEGER;
+  BEGIN
+    inB  := inT(Ty.Base).tpOrd;
+    outB := outT(Ty.Base).tpOrd;
+    IF inB = outB THEN RETURN END;		(* PREMATURE RETURN! *)
+    CASE outB OF
+    | Ty.realN : RETURN;			(* PREMATURE RETURN! *)
+    | Ty.sReaN : 
+	code := Jvm.opc_d2f;
+    | Ty.lIntN :
+	IF    inB = Ty.realN THEN code := Jvm.opc_d2l;
+	ELSIF inB = Ty.sReaN THEN code := Jvm.opc_f2l;
+	ELSE  RETURN;				(* PREMATURE RETURN! *)
+        END;
+    | Ty.intN  :
+	IF    inB = Ty.realN THEN code := Jvm.opc_d2i;
+	ELSIF inB = Ty.sReaN THEN code := Jvm.opc_f2i;
+	ELSIF inB = Ty.lIntN THEN 
+	  (* jf.RangeCheck(...); STILL TO DO *)
+	  code := Jvm.opc_l2i;
+	ELSE  RETURN;				(* PREMATURE RETURN! *)
+        END;
+    | Ty.sIntN :
+	jf.ConvertDn(inT, G.intTp);
+	(* jf.RangeCheck(...); STILL TO DO *)
+	code := Jvm.opc_i2s;
+    | Ty.uBytN :
+	jf.ConvertDn(inT, G.intTp);
+	(* jf.RangeCheck(...); STILL TO DO *)
+        jf.PushInt(255);
+	code := Jvm.opc_iand;
+    | Ty.byteN :
+	jf.ConvertDn(inT, G.intTp);
+	(* jf.RangeCheck(...); STILL TO DO *)
+	code := Jvm.opc_i2b;
+    | Ty.setN  : 
+	jf.ConvertDn(inT, G.intTp); RETURN;	(* PREMATURE RETURN! *)
+    | Ty.charN, Ty.sChrN  : 
+	jf.ConvertDn(inT, G.intTp);
+	(* jf.RangeCheck(...); STILL TO DO *)
+	code := Jvm.opc_i2c;
+    END;
+    jf.Code(code);
+  END ConvertDn;
+
+(* ------------------------------------------------------------ *)
+
+  PROCEDURE (jf : JavaFile)EmitOneRange*
+	       (var : INTEGER;		(* local variable index *)
+		loC : INTEGER;		(* low-value of range   *)
+		hiC : INTEGER;		(* high-value of range  *)
+		min : INTEGER;		(* minimun selector val *)
+		max : INTEGER;		(* maximum selector val *)
+		def : Label;          (* default code label   *)
+                target : Label),NEW;	
+  (* ---------------------------------------------------------- *
+   *  The selector value is known to be in the range min .. max *
+   *  and we wish to send values between loC and hiC to the     *
+   *  target code label. All otherwise go to def.               *
+   *  A range is "compact" if it is hard against min/max limits *
+   * ---------------------------------------------------------- *)
+  BEGIN
+   (*
+    *    Deal with several special cases...
+    *)
+    IF (min = loC) & (max = hiC) THEN	(* fully compact: just GOTO *)
+      jf.CodeLb(Jvm.opc_goto, target);
+    ELSE
+      jf.LoadLocal(var, G.intTp);
+      IF loC = hiC THEN (* a singleton *)
+	jf.PushInt(loC);
+	jf.CodeLb(Jvm.opc_if_icmpeq, target);
+      ELSIF min = loC THEN		(* compact at low end only  *)
+	jf.PushInt(hiC);
+	jf.CodeLb(Jvm.opc_if_icmple, target);
+      ELSIF max = hiC THEN		(* compact at high end only *)
+	jf.PushInt(loC);
+	jf.CodeLb(Jvm.opc_if_icmpge, target);
+      ELSE				(* Shucks! The general case *)
+	jf.PushInt(loC);
+	jf.CodeLb(Jvm.opc_if_icmplt, def);
+	jf.LoadLocal(var, G.intTp);
+	jf.PushInt(hiC);
+	jf.CodeLb(Jvm.opc_if_icmple, target);
+      END;
+      jf.CodeLb(Jvm.opc_goto, def);
+    END;
+  END EmitOneRange;
+
+(* ------------------------------------------------------------ *)
+
+  PROCEDURE (jf : JavaFile)Return*(ret : D.Type),NEW;
+  BEGIN
+    IF ret = NIL THEN
+      jf.Code(Jvm.opc_return);
+    ELSIF ret IS Ty.Base THEN
+      jf.Code(typeRetn[ret(Ty.Base).tpOrd]);
+    ELSE
+      jf.Code(Jvm.opc_areturn);
+    END;
+  END Return;
+
+(* ------------------------------------------------------------ *)
+
+  PROCEDURE (jf : JavaFile)FixPar(par : Id.ParId),NEW;
+  BEGIN
+   (*
+    *   Load up the actual into boxVar[0];
+    *)
+    jf.LoadLocal(par.boxOrd, NIL);
+    jf.Code(Jvm.opc_iconst_0);
+   (* 
+    *   The param might be an XHR field, so 
+    *   jf.LoadLocal(par.varOrd, par.type) breaks.
+    *)
+    jf.GetLocal(par);
+    jf.PutElement(par.type);
+  END FixPar;
+
+(* ------------------------------------------------------------ *)
+
+  PROCEDURE (jf : JavaFile)FixOutPars*(pId : Id.Procs; OUT ret : D.Type),NEW;
+    VAR frm : Ty.Procedure;
+	par : Id.ParId;
+	idx : INTEGER;
+  BEGIN
+    ret := NIL;
+(*
+ *  Receivers are never boxed in Component Pascal.
+ *
+ *  WITH pId : Id.MthId DO
+ *    par := pId.rcvFrm;
+ *    IF par.boxOrd # 0 THEN jf.FixPar(par) END;
+ *  ELSE (* nothing *)
+ *  END;
+ *)
+    frm := pId.type(Ty.Procedure);
+    FOR idx := 0 TO frm.formals.tide-1 DO
+      par := frm.formals.a[idx];
+      IF par.boxOrd = retMarker THEN 
+	ret := par.type;
+       (* 
+        *   The param might be an XHR field, so 
+        *   jf.LoadLocal(par.varOrd, ret) breaks.
+        *)
+        jf.GetLocal(par);
+      ELSIF needsBox(par) THEN 
+	jf.FixPar(par);
+      END;
+    END;
+   (*
+    *  If ret is still NIL, then either there is an explicit
+    *  return type, or there was no OUT or VAR parameters here. 
+    *  So...
+    *)
+    IF (ret = NIL) & (pId.kind # Id.ctorP) THEN ret := frm.retType END;
+  END FixOutPars;
+
+(* ------------------------------------------------------------ *)
+
+  PROCEDURE (jf : JavaFile)PushJunkAndReturn*(),NEW;
+    VAR frm : Ty.Procedure;
+        ret : D.Type;
+        idx : INTEGER;
+        par : Id.ParId;
+  BEGIN
+   (*
+    *  This procedure pushes a dummy return value 
+    *  if that is necessary, and calls return.
+    *)
+    ret := NIL;
+    IF jf.theP = NIL THEN RETURN END;         (* PREMATURE EXIT FOR MOD BODY *)
+    frm := jf.theP.type(Ty.Procedure);
+   (*
+    *  First, we must find the (jvm) return type.
+    *  It would have been nice to store this in out.info!
+    *)
+    FOR idx := 0 TO frm.formals.tide-1 DO
+      par := frm.formals.a[idx];
+      IF par.boxOrd = retMarker THEN ret := par.type END;
+    END;
+    IF ret = NIL THEN ret := frm.retType END;
+   (*
+    *  Now push a "zero" if necessary, then return.
+    *  If this is a void function in the JVM, then we
+    *  may safely leave things to the fall through return.
+    *)
+    IF ret # NIL THEN
+      WITH ret : Ty.Base DO
+        CASE ret.tpOrd OF
+        |  Ty.boolN .. Ty.intN : jf.Code(Jvm.opc_iconst_0);
+        |  Ty.lIntN            : jf.Code(Jvm.opc_lconst_0);
+        |  Ty.sReaN            : jf.Code(Jvm.opc_fconst_0);
+        |  Ty.realN            : jf.Code(Jvm.opc_dconst_0);
+        ELSE                     jf.Code(Jvm.opc_aconst_null);
+        END;
+      ELSE
+        jf.Code(Jvm.opc_aconst_null);
+      END;
+      jf.Return(ret);
+    END;
+  END PushJunkAndReturn;
+
+(* ------------------------------------------------------------ *)
+
+  PROCEDURE (jf : JavaFile)Init1dArray*(elTp : D.Type; leng : INTEGER),NEW;
+    CONST inlineLimit = 4;
+    VAR indx : INTEGER;
+	labl : Label;
+	arrT : Ty.Array;
+  BEGIN
+   (*
+    *   Precondition: elTp is either a record or fixed array.
+    *	At entry stack is (top) arrayRef, unchanged at exit.
+    *	(len == 0) ==> take length from runtime descriptor.
+    *)
+    IF (leng < 4) & (leng # 0) & (elTp.kind = Ty.recTp) THEN
+     (*
+      *    Do a compile-time loop ...
+      *)
+      FOR indx := 0 TO leng-1 DO
+	jf.Code(Jvm.opc_dup);
+	jf.PushInt(indx);
+	jf.MkNewRecord(elTp(Ty.Record));
+	jf.Code(Jvm.opc_aastore);
+      END;
+    ELSE
+     (* ------------------------------------------------------ *
+      *    Do a runtime loop ...
+      *
+      *		push-len>	; (top) len, ref,...
+      *	 loop: 
+      *		iconst_1	; (top) 1, len, ref,...
+      *		isub		; (top) len*, ref,...
+      *		dup2		; (top) len*, ref, len*, ref,...
+      *		<newElem>	; (top) new, len*, ref, len*, ref,...
+      *		aastore		; (top) len*, ref,...
+      *		dup		; (top) len*, len*, ref,...
+      *		ifne loop	; (top) len*, ref,...
+      *		pop		; (top) ref, ...
+      * ------------------------------------------------------ *)
+      IF leng = 0 THEN (* find the length from the descriptor  *)
+	jf.Code(Jvm.opc_dup);
+	jf.Code(Jvm.opc_arraylength);
+      ELSE
+	jf.PushInt(leng);
+      END;
+      labl := jf.newLabel();
+      jf.DefLabC(labl, "1-d init loop");
+      jf.Code(Jvm.opc_iconst_1);
+      jf.Code(Jvm.opc_isub);
+      jf.Code(Jvm.opc_dup2);
+      IF elTp.kind = Ty.recTp THEN
+        jf.MkNewRecord(elTp(Ty.Record));
+      ELSE
+        arrT := elTp(Ty.Array); 
+        jf.MkNewFixedArray(arrT.elemTp, arrT.length);
+      END;
+      jf.Code(Jvm.opc_aastore);
+      jf.Code(Jvm.opc_dup);
+      jf.CodeLb(Jvm.opc_ifne, labl);
+      jf.CodeC(Jvm.opc_pop, "	; end 1-d loop");
+    END;
+  END Init1dArray;
+
+(* ============================================================ *)
+	
+  PROCEDURE (jf : JavaFile)InitNdArray*(desc : D.Type; elTp : D.Type),NEW;
+    VAR labl : Label;
+  BEGIN
+   (* ------------------------------------------------------ *
+    *	Initialize multi-dimensional array, using 
+    *	the runtime array descriptors to generate lengths.
+    *   Here, desc is the outer element type; elTp 
+    *   most nested type.
+    *
+    *	At entry stack is (top) arrayRef, unchanged at exit.
+    *
+    *		dup		; (top) ref,ref...
+    *		arraylength	; (top) len,ref...
+    *	  loop:      	
+    *		iconst_1	; (top) 1,len,ref...
+    *		isub		; (top) len',ref...
+    *		dup2 		; (top) hi,ref,hi,ref...
+    *		if (desc == elTp)
+    *		   <eleminit>	; (top) rec,ref[i],hi,ref...
+    *		   aastore	; (top) hi,ref...
+    *		else
+    *		   aaload	; (top) ref[i],hi,ref...
+    *		   <recurse>	; (top) ref[i],hi,ref...
+    *		   pop		; (top) hi,ref...
+    *		endif
+    *		dup		; (top) hi,hi,ref...
+    *		ifne loop	; (top) hi,ref...
+    *		pop		; (top) ref...
+    * ------------------------------------------------------ *)
+    labl := jf.newLabel();
+    jf.Code(Jvm.opc_dup);
+    jf.Code(Jvm.opc_arraylength);
+    jf.DefLabC(labl, "Element init loop");
+    jf.Code(Jvm.opc_iconst_1);
+    jf.Code(Jvm.opc_isub);
+    jf.Code(Jvm.opc_dup2);
+    IF desc = elTp THEN
+     (*
+      *    This is the innermost loop!
+      *)
+      WITH elTp : Ty.Array DO
+         (*
+	  *  Must be switching from open to fixed arrays...
+	  *)
+	  jf.MkNewFixedArray(elTp.elemTp, elTp.length);
+      | elTp : Ty.Record DO
+         (*
+	  *  Element type is some record type.
+	  *)
+	  jf.MkNewRecord(elTp);
+      END;
+      jf.Code(Jvm.opc_aastore);
+    ELSE
+     (*
+      *    There are more dimensions to go ... so recurse down.
+      *)
+      jf.Code(Jvm.opc_aaload);
+      jf.InitNdArray(desc(Ty.Array).elemTp, elTp);
+      jf.Code(Jvm.opc_pop);
+    END;
+    jf.Code(Jvm.opc_dup);
+    jf.CodeLb(Jvm.opc_ifne, labl);
+    jf.CodeC(Jvm.opc_pop, "	; end loop");
+  END InitNdArray;
+
+(* ============================================================ *)
+
+  PROCEDURE (jf : JavaFile)ValArrCopy*(typ : Ty.Array),NEW;
+    VAR	local : INTEGER;
+	sTemp : INTEGER;
+	label : Label;
+	elTyp : D.Type;
+  BEGIN
+   (*
+    *    Stack at entry is (top) srcRef, dstRef...
+    *)
+    label := jf.newLabel();
+    local := jf.newLocal();
+    IF typ.length = 0 THEN (* open array, get length from source desc *)
+      jf.Code(Jvm.opc_dup);
+      jf.Code(Jvm.opc_arraylength);
+    ELSE 
+      jf.PushInt(typ.length);
+    END;
+    jf.StoreLocal(local, G.intTp);
+   (*
+    *      <get length>	; (top) n,rr,lr...
+    *      store(n)	; (top) rr,lr...
+    * lab:
+    *      dup2		; (top) rr,lr,rr,lr...
+    *      iinc n -1	; (top) rr,lr...
+    *      load(n)	; (top) n,rr,lr,rr,lr...
+    *      dup_x1	; (top) n,rr,n,lr,rr,lr...
+    *      <doassign>   ; (top) rr,lr
+    *      load(n)	; (top) n,rr,lr...
+    *      ifne lab     ; (top) rr,lr...
+    *      pop2		; (top) ...
+    *)
+    jf.DefLab(label);
+    jf.Code(Jvm.opc_dup2);
+    jf.CodeInc(local, -1);
+    jf.LoadLocal(local, G.intTp);
+    jf.Code(Jvm.opc_dup_x1);
+   (*
+    *    Assign the element
+    *)
+    elTyp := typ.elemTp;
+    jf.GetElement(elTyp);		(* (top) r[n],n,lr,rr,lr...	*)
+    IF  (elTyp.kind = Ty.arrTp) OR
+	(elTyp.kind = Ty.recTp) THEN
+      sTemp := jf.newLocal();	(* must recurse in copy code	*)
+      jf.StoreLocal(sTemp, elTyp);	(* (top) n,lr,rr,lr...		*)
+      jf.GetElement(elTyp);		(* (top) l{n],rr,lr...		*)
+      jf.LoadLocal(sTemp, elTyp);	(* (top) r[n],l[n],rr,lr...     *)
+      jf.ReleaseLocal(sTemp);
+      WITH elTyp : Ty.Record DO
+	  jf.ValRecCopy(elTyp);
+      | elTyp : Ty.Array DO
+	  jf.ValArrCopy(elTyp);
+      END;
+    ELSE
+      jf.PutElement(elTyp);
+    END;
+   (*
+    *    stack is (top) rr,lr...
+    *)
+    jf.LoadLocal(local, G.intTp);
+    jf.CodeLb(Jvm.opc_ifne, label);
+    jf.Code(Jvm.opc_pop2);
+    jf.ReleaseLocal(local);
+  END ValArrCopy;
+
+(* ============================================================ *)
+
+  PROCEDURE (jf : JavaFile)InitVars*(scp : D.Scope),NEW;
+    VAR index : INTEGER;
+        xhrNo : INTEGER;
+	ident : D.Idnt;
+        scalr : BOOLEAN;
+  BEGIN
+    xhrNo := 0;
+   (* 
+    *  Create the explicit activation record, if needed.
+    *)
+    WITH scp : Id.Procs DO
+      IF Id.hasXHR IN scp.pAttr THEN 
+        xhrNo := scp.type(Ty.Procedure).argN;
+        jf.Comment("create XHR record");
+	jf.MkNewRecord(scp.xhrType.boundRecTp()(Ty.Record));
+	IF scp.lxDepth > 0 THEN
+          jf.Code(Jvm.opc_dup);
+          jf.Code(Jvm.opc_aload_0);
+          jf.PutGetF(Jvm.opc_putfield, 
+		CompState.rtsXHR.boundRecTp()(Ty.Record), CompState.xhrId);
+	END;
+        jf.StoreLocal(xhrNo, NIL);
+      END;
+    ELSE (* skip *)
+    END;
+   (* 
+    *  Initialize local fields, if needed
+    *)
+    FOR index := 0 TO scp.locals.tide-1 DO
+      ident := scp.locals.a[index];
+      scalr := ident.type.isScalarType();
+      WITH ident : Id.ParId DO
+         (*
+          *   If any args are uplevel addressed, they must
+          *   be copied to the correct field of the XHR.
+          *   The test "varOrd < xhrNo" excludes out params.
+          *)
+          IF (Id.uplevA IN ident.locAtt) & (ident.varOrd < xhrNo) THEN 
+            jf.LoadLocal(xhrNo, NIL);
+            jf.LoadLocal(ident.varOrd, ident.type);
+            jf.PutGetX(Jvm.opc_putfield, ident);
+	  END;
+      | ident : Id.LocId DO
+          IF ~scalr THEN
+            IF Id.uplevA IN ident.locAtt THEN jf.LoadLocal(xhrNo, NIL) END;
+            jf.VarInit(ident);
+            jf.PutLocal(ident);
+	  END;
+      | ident : Id.VarId DO
+          IF ~scalr THEN
+            jf.VarInit(ident);
+	    jf.PutGetS(Jvm.opc_putstatic, scp(Id.BlkId), ident);
+	  END;
+      END;
+    END;
+  END InitVars;
+
+(* ============================================================ *)
+
+  PROCEDURE Init*();
+  BEGIN
+    xhrIx := 0;
+    InitVecDescriptors();
+  END Init;
+
+(* ============================================================ *)
+(* ============================================================ *)
+
+BEGIN
+  L.InitCharOpenSeq(fmArray, 8);
+  L.InitCharOpenSeq(nmArray, 8);
+
+  typeRetn[ Ty.boolN] := Jvm.opc_ireturn;
+  typeRetn[ Ty.sChrN] := Jvm.opc_ireturn;
+  typeRetn[ Ty.charN] := Jvm.opc_ireturn;
+  typeRetn[ Ty.byteN] := Jvm.opc_ireturn;
+  typeRetn[ Ty.sIntN] := Jvm.opc_ireturn;
+  typeRetn[  Ty.intN] := Jvm.opc_ireturn;
+  typeRetn[ Ty.lIntN] := Jvm.opc_lreturn;
+  typeRetn[ Ty.sReaN] := Jvm.opc_freturn;
+  typeRetn[ Ty.realN] := Jvm.opc_dreturn;
+  typeRetn[  Ty.setN] := Jvm.opc_ireturn;
+  typeRetn[Ty.anyPtr] := Jvm.opc_areturn;
+  typeRetn[ Ty.uBytN] := Jvm.opc_ireturn;
+
+  typeLoad[ Ty.boolN] := Jvm.opc_iload;
+  typeLoad[ Ty.sChrN] := Jvm.opc_iload;
+  typeLoad[ Ty.charN] := Jvm.opc_iload;
+  typeLoad[ Ty.byteN] := Jvm.opc_iload;
+  typeLoad[ Ty.sIntN] := Jvm.opc_iload;
+  typeLoad[  Ty.intN] := Jvm.opc_iload;
+  typeLoad[ Ty.lIntN] := Jvm.opc_lload;
+  typeLoad[ Ty.sReaN] := Jvm.opc_fload;
+  typeLoad[ Ty.realN] := Jvm.opc_dload;
+  typeLoad[  Ty.setN] := Jvm.opc_iload;
+  typeLoad[Ty.anyPtr] := Jvm.opc_aload;
+  typeLoad[Ty.anyRec] := Jvm.opc_aload;
+  typeLoad[ Ty.uBytN] := Jvm.opc_iload;
+
+  typeStore[ Ty.boolN] := Jvm.opc_istore;
+  typeStore[ Ty.sChrN] := Jvm.opc_istore;
+  typeStore[ Ty.charN] := Jvm.opc_istore;
+  typeStore[ Ty.byteN] := Jvm.opc_istore;
+  typeStore[ Ty.sIntN] := Jvm.opc_istore;
+  typeStore[  Ty.intN] := Jvm.opc_istore;
+  typeStore[ Ty.lIntN] := Jvm.opc_lstore;
+  typeStore[ Ty.sReaN] := Jvm.opc_fstore;
+  typeStore[ Ty.realN] := Jvm.opc_dstore;
+  typeStore[  Ty.setN] := Jvm.opc_istore;
+  typeStore[Ty.anyPtr] := Jvm.opc_astore;
+  typeStore[Ty.anyRec] := Jvm.opc_astore;
+  typeStore[ Ty.uBytN] := Jvm.opc_istore;
+
+  typePutE[ Ty.boolN] := Jvm.opc_bastore;
+  typePutE[ Ty.sChrN] := Jvm.opc_castore;
+  typePutE[ Ty.charN] := Jvm.opc_castore;
+  typePutE[ Ty.byteN] := Jvm.opc_bastore;
+  typePutE[ Ty.sIntN] := Jvm.opc_sastore;
+  typePutE[  Ty.intN] := Jvm.opc_iastore;
+  typePutE[ Ty.lIntN] := Jvm.opc_lastore;
+  typePutE[ Ty.sReaN] := Jvm.opc_fastore;
+  typePutE[ Ty.realN] := Jvm.opc_dastore;
+  typePutE[  Ty.setN] := Jvm.opc_iastore;
+  typePutE[Ty.anyPtr] := Jvm.opc_aastore;
+  typePutE[Ty.anyRec] := Jvm.opc_aastore;
+  typePutE[ Ty.uBytN] := Jvm.opc_bastore;
+
+  typeGetE[ Ty.boolN] := Jvm.opc_baload;
+  typeGetE[ Ty.sChrN] := Jvm.opc_caload;
+  typeGetE[ Ty.charN] := Jvm.opc_caload;
+  typeGetE[ Ty.byteN] := Jvm.opc_baload;
+  typeGetE[ Ty.sIntN] := Jvm.opc_saload;
+  typeGetE[  Ty.intN] := Jvm.opc_iaload;
+  typeGetE[ Ty.lIntN] := Jvm.opc_laload;
+  typeGetE[ Ty.sReaN] := Jvm.opc_faload;
+  typeGetE[ Ty.realN] := Jvm.opc_daload;
+  typeGetE[  Ty.setN] := Jvm.opc_iaload;
+  typeGetE[Ty.anyPtr] := Jvm.opc_aaload;
+  typeGetE[Ty.anyRec] := Jvm.opc_aaload;
+  typeGetE[ Ty.uBytN] := Jvm.opc_baload;
+
+  semi := L.strToCharOpen(";"); 
+  lPar := L.strToCharOpen("("); 
+  rPar := L.strToCharOpen(")"); 
+  brac := L.strToCharOpen("["); 
+  lCap := L.strToCharOpen("L"); 
+  void := L.strToCharOpen("V"); 
+  rParV:= L.strToCharOpen(")V");
+  lowL := L.strToCharOpen("_"); 
+  slsh := L.strToCharOpen("/"); 
+  dlar := L.strToCharOpen("$"); 
+  prfx := L.strToCharOpen(classPrefix); 
+  xhrDl := L.strToCharOpen("XHR$");
+  xhrMk := L.strToCharOpen("LCP/CPJrts/XHR;");
+
+  G.setTp.xName := L.strToCharOpen("I");
+  G.intTp.xName := L.strToCharOpen("I");
+  G.boolTp.xName := L.strToCharOpen("Z");
+  G.byteTp.xName := L.strToCharOpen("B");
+  G.uBytTp.xName := L.strToCharOpen("B");  (* same as BYTE *)
+  G.charTp.xName := L.strToCharOpen("C");
+  G.sChrTp.xName := L.strToCharOpen("C");
+  G.sIntTp.xName := L.strToCharOpen("S");
+  G.lIntTp.xName := L.strToCharOpen("J");
+  G.realTp.xName := L.strToCharOpen("D");
+  G.sReaTp.xName := L.strToCharOpen("F");
+  G.anyRec.xName := L.strToCharOpen("Ljava/lang/Object;");
+  G.anyPtr.xName := G.anyRec.xName;
+END JavaUtil.
+(* ============================================================ *)
+(* ============================================================ *)
+

gpcp/JsmnUtil.cp

@@ -0,0 +1,1481 @@
+(* ============================================================ *)
+(*  JsmnUtil is the module which writes jasmin file structures  *)
+(*  Copyright (c) John Gough 1999, 2000.			*)
+(* ============================================================ *)
+
+MODULE JsmnUtil;
+
+  IMPORT 
+	GPCPcopyright,
+	RTS, ASCII,
+	Console,
+	GPText,
+	LitValue,
+        FileNames,
+	GPTextFiles,
+	CompState,
+        J := JavaUtil,
+	D := Symbols,
+	G := Builtin,
+	Id := IdDesc,
+	Ty := TypeDesc,
+	Jvm := JVMcodes;
+
+(* ============================================================ *)
+
+   CONST
+	classPrefix = "CP";
+        pubStat     = Jvm.att_public + Jvm.att_static;
+        modAttrib   = Jvm.att_public + Jvm.att_final;
+
+   CONST
+	(* various Java-specific runtime name strings *)
+	initStr     = "<init>";
+	initSuffix* = "/<init>()V";
+	object*     = "java/lang/Object";
+	objectInit* = "java/lang/Object/<init>()V";
+	mainStr*    = "main([Ljava/lang/String;)V";
+	jlExcept*   = "java/lang/Exception";
+(*
+ *	jlError*    = "java/lang/Error";
+ *)
+	jlError*    = jlExcept;
+	mkExcept*   = "java/lang/Exception/<init>(Ljava/lang/String;)V";
+(*
+ *	mkError*    = "java/lang/Error/<init>(Ljava/lang/String;)V";
+ *)
+	mkError*    = mkExcept;
+	putArgStr*  = "CP/CPmain/CPmain/PutArgs([Ljava/lang/String;)V";
+
+(* ============================================================ *)
+(* ============================================================ *)
+
+  TYPE ProcInfo*  = POINTER TO RECORD
+		      prId- : D.Scope;  (* mth., prc. or mod.	*)
+		      lMax  : INTEGER;	(* max locals for proc  *)
+		      lNum  : INTEGER;	(* current locals proc  *)
+		      dMax  : INTEGER;	(* max depth for proc.  *)
+		      dNum  : INTEGER;  (* current depth proc.  *)
+                      attr  : SET;      (* access attributes    *)
+		      exLb  : J.Label;
+		      hnLb  : J.Label;
+		    END;
+
+(* ============================================================ *)
+
+  TYPE JsmnFile*  = POINTER TO RECORD (J.JavaFile)
+                      file* : GPTextFiles.FILE;
+		      proc* : ProcInfo;
+		      nxtLb : INTEGER;
+                    END;
+
+(* ============================================================ *)
+
+  TYPE  TypeNameString = ARRAY 12 OF CHAR;
+        ProcNameString = ARRAY 90 OF CHAR;
+
+(* ============================================================ *)
+
+  VAR   typeName  : ARRAY 15 OF TypeNameString;	(* base type names *)
+	typeChar  : ARRAY 15 OF CHAR;		(* base type chars *)
+        rtsProcs  : ARRAY 24 OF ProcNameString; 
+
+(* ============================================================ *)
+(*			Constructor Method			*)
+(* ============================================================ *)
+
+  PROCEDURE newJsmnFile*(fileName : ARRAY OF CHAR) : JsmnFile;
+    VAR f : JsmnFile;
+  BEGIN
+    NEW(f);
+    f.file := GPTextFiles.createFile(fileName);
+    IF f.file = NIL THEN RETURN NIL; END;
+    RETURN f;
+  END newJsmnFile;
+
+(* ============================================================ *)
+
+  PROCEDURE^ (os : JsmnFile)Directive(dir : INTEGER),NEW;
+  PROCEDURE^ (os : JsmnFile)DirectiveS(dir : INTEGER;
+				   IN str : ARRAY OF CHAR),NEW;
+  PROCEDURE^ (os : JsmnFile)DirectiveIS(dir : INTEGER; att : SET;
+				     IN str : ARRAY OF CHAR),NEW;
+  PROCEDURE^ (os : JsmnFile)DirectiveISS(dir : INTEGER; att : SET;
+				      IN s1  : ARRAY OF CHAR;
+				      IN s2  : ARRAY OF CHAR),NEW;
+  PROCEDURE^ (os : JsmnFile)Call2*(code : INTEGER; 
+				IN st1 : ARRAY OF CHAR;
+				IN st2 : ARRAY OF CHAR;
+				argL,retL : INTEGER),NEW;
+
+(* ============================================================ *)
+(* ============================================================ *)
+(*			ProcInfo Methods			*)
+(* ============================================================ *)
+
+  PROCEDURE newProcInfo*(proc : D.Scope) : ProcInfo;
+    VAR p : ProcInfo;
+  BEGIN
+    NEW(p);
+    p.prId := proc;
+    WITH proc : Id.Procs DO
+      p.lNum := proc.rtsFram;
+      p.lMax := MAX(proc.rtsFram, 1);
+    ELSE	(* Id.BlkId *)
+      p.lNum := 0;
+      p.lMax := 1;
+    END;
+    p.dNum := 0;
+    p.dMax := 0;
+    p.attr := {};
+    RETURN p;
+  END newProcInfo;
+
+(* ------------------------------------------------------------ *)
+
+  PROCEDURE (os : JsmnFile)StartProc* (proc : Id.Procs);
+  VAR
+    attr : SET;
+    method : Id.MthId;
+    procName : FileNames.NameString;
+  BEGIN
+    os.proc := newProcInfo(proc);
+    os.Comment("PROCEDURE " + D.getName.ChPtr(proc)^);
+   (*
+    *  Compute the method attributes
+    *)
+    IF proc.kind = Id.conMth THEN
+      method := proc(Id.MthId);
+      attr := {};
+      IF method.mthAtt * Id.mask = {} THEN attr := Jvm.att_final END;
+      IF method.mthAtt * Id.mask = Id.isAbs THEN 
+        attr := attr + Jvm.att_abstract; 
+      END;
+      IF Id.widen IN method.mthAtt THEN attr := attr + Jvm.att_public END; 
+    ELSE
+      attr := Jvm.att_static;
+    END;
+(*
+ *  The following code fails for "implement-only" methods
+ *  since the JVM places the "override method" in a different 
+ *  slot! We must thus live with the insecurity of public mode.
+ *
+ *  IF proc.vMod = D.pubMode THEN	(* explicitly public *)
+ *)
+    IF (proc.vMod = D.pubMode) OR	(* explicitly public *)
+       (proc.vMod = D.rdoMode) THEN     (* "implement only"  *)
+      attr := attr + Jvm.att_public;
+    ELSIF proc.dfScp IS Id.PrcId THEN	(* nested procedure  *)
+      attr := attr + Jvm.att_private;
+    END;
+    FileNames.StripUpToLast("/", proc.prcNm, procName);
+    os.DirectiveISS(Jvm.dot_method, attr, procName$, proc.type.xName);
+    os.proc.attr := attr
+  END StartProc;
+
+(* ------------------------------------------------------------ *)
+
+  PROCEDURE^ (os : JsmnFile)Locals(),NEW;
+  PROCEDURE^ (os : JsmnFile)Stack(),NEW;
+  PROCEDURE^ (os : JsmnFile)Blank(),NEW;
+
+  PROCEDURE (os : JsmnFile)EndProc*();
+  BEGIN
+    IF (os.proc.attr * Jvm.att_abstract # {}) THEN
+      os.Comment("Abstract method");
+    ELSE
+      os.Locals();
+      os.Stack();
+    END;
+    os.Directive(Jvm.dot_end);
+    os.Blank();
+  END EndProc;
+
+  PROCEDURE (os : JsmnFile)isAbstract*() : BOOLEAN;
+  BEGIN
+    RETURN (os.proc.attr * Jvm.att_abstract # {});
+  END isAbstract;
+
+(* ------------------------------------------------------------ *)
+
+  PROCEDURE (os : JsmnFile)getScope*() : D.Scope;
+  BEGIN
+    RETURN os.proc.prId; 
+  END getScope;
+
+(* ------------------------------------------------------------ *)
+
+  PROCEDURE (os : JsmnFile)newLocal*() : INTEGER;
+    VAR ord : INTEGER;
+        info : ProcInfo;
+  BEGIN
+    info := os.proc; 
+    ord := info.lNum;
+    INC(info.lNum);
+    IF info.lNum > info.lMax THEN info.lMax := info.lNum END;
+    RETURN ord;
+  END newLocal;
+
+(* ------------------------------------------------------------ *)
+
+  PROCEDURE (os : JsmnFile)ReleaseLocal*(i : INTEGER);
+  BEGIN
+   (*
+    *  If you try to release not in LIFO order, the 
+    *  location will not be made free again. This is safe!
+    *)
+    IF i+1 = os.proc.lNum THEN DEC(os.proc.lNum) END;
+  END ReleaseLocal;
+
+(* ------------------------------------------------------------ *)
+
+  PROCEDURE (info : ProcInfo)numLocals*() : INTEGER,NEW;
+  BEGIN
+    IF info.lNum = 0 THEN RETURN 1 ELSE RETURN info.lNum END;
+  END numLocals;
+
+(* ------------------------------------------------------------ *)
+
+  PROCEDURE (os : JsmnFile)markTop*() : INTEGER;
+  BEGIN
+    RETURN os.proc.lNum;
+  END markTop;
+
+(* ------------------------------------------------------------ *)
+
+  PROCEDURE (os : JsmnFile)ReleaseAll*(m : INTEGER);
+  BEGIN
+    os.proc.lNum := m;
+  END ReleaseAll;
+
+(* ------------------------------------------------------------ *)
+
+  PROCEDURE (os : JsmnFile)getDepth*() : INTEGER;
+  BEGIN RETURN os.proc.dNum END getDepth;
+
+  (* ------------------------------------------ *)
+
+  PROCEDURE (os : JsmnFile)setDepth*(i : INTEGER);
+  BEGIN os.proc.dNum := i END setDepth;
+
+(* ============================================================ *)
+(*			Init Methods				*)
+(* ============================================================ *)
+
+  PROCEDURE (os : JsmnFile) ClinitHead*();
+  BEGIN
+    os.proc := newProcInfo(NIL);
+    os.Comment("Class initializer");
+    os.DirectiveIS(Jvm.dot_method, pubStat, "<clinit>()V");
+  END ClinitHead;
+
+(* ============================================================ *)
+
+  PROCEDURE (os: JsmnFile)VoidTail*();
+  BEGIN
+    os.Code(Jvm.opc_return);
+    os.Locals();
+    os.Stack();
+    os.Directive(Jvm.dot_end);
+    os.Blank();
+  END VoidTail;
+
+(* ============================================================ *)
+
+  PROCEDURE^ (os : JsmnFile)CallS*(code : INTEGER; IN str : ARRAY OF CHAR;
+				   argL,retL : INTEGER),NEW;
+
+  PROCEDURE (os : JsmnFile)MainHead*();
+  BEGIN
+    os.proc := newProcInfo(NIL);
+    os.Comment("Main entry point");
+    os.DirectiveIS(Jvm.dot_method, pubStat, mainStr);
+   (*
+    *  Save the command-line arguments to the RTS.
+    *)
+    os.Code(Jvm.opc_aload_0);
+    os.CallS(Jvm.opc_invokestatic, putArgStr, 1, 0);
+  END MainHead;
+
+(* ============================================================ *)
+
+  PROCEDURE (os : JsmnFile)ModNoArgInit*();
+  BEGIN
+    os.Blank();
+    os.proc := newProcInfo(NIL);
+    os.Comment("Standard no-arg constructor");
+    os.DirectiveIS(Jvm.dot_method, Jvm.att_public, "<init>()V");
+    os.Code(Jvm.opc_aload_0);
+    os.CallS(Jvm.opc_invokespecial, objectInit, 1, 0);
+    os.Code(Jvm.opc_return);
+    os.Stack();
+    os.Directive(Jvm.dot_end);
+    os.Blank();
+  END ModNoArgInit;
+
+(* ---------------------------------------------------- *)
+
+  PROCEDURE (os : JsmnFile)RecMakeInit*(rec : Ty.Record;
+					prc : Id.PrcId);
+    VAR	pTp : Ty.Procedure;
+  BEGIN
+    os.Blank();
+    IF prc = NIL THEN
+      IF D.noNew IN rec.xAttr THEN 
+        os.Comment("There is no no-arg constructor for this class");
+        os.Blank();
+        RETURN;					(* PREMATURE RETURN HERE *)
+      ELSIF D.xCtor IN rec.xAttr THEN 
+        os.Comment("There is an explicit no-arg constructor for this class");
+        os.Blank();
+        RETURN;					(* PREMATURE RETURN HERE *)
+      END;
+    END;
+    os.proc := newProcInfo(prc);
+   (*
+    *  Get the procedure type, if any.
+    *)
+    IF prc # NIL THEN 
+      pTp := prc.type(Ty.Procedure);
+      J.MkCallAttr(prc, pTp);
+      os.DirectiveISS(Jvm.dot_method, Jvm.att_public, initStr, pTp.xName);
+    ELSE
+      os.Comment("Standard no-arg constructor");
+      pTp := NIL;
+      os.DirectiveIS(Jvm.dot_method, Jvm.att_public, "<init>()V");
+    END;
+    os.Code(Jvm.opc_aload_0);
+  END RecMakeInit;
+
+(*
+    IF pTp # NIL THEN
+     (*
+      *  Copy the args to the super-constructor
+      *)
+      FOR idx := 0 TO pNm-1 DO os.GetLocal(pTp.formals.a[idx]) END;
+
+    END;
+ *)
+
+  PROCEDURE (os : JsmnFile)CallSuperCtor*(rec : Ty.Record;
+                                          pTy : Ty.Procedure);
+    VAR	idx : INTEGER;
+	fld : D.Idnt;
+	pNm : INTEGER;
+	string2 : LitValue.CharOpen;
+  BEGIN
+   (*
+    *    Initialize the embedded superclass object.
+    *)
+    IF (rec.baseTp # NIL) & (rec.baseTp # G.anyRec) THEN
+      IF pTy # NIL THEN
+        string2 := LitValue.strToCharOpen("/" + initStr + pTy.xName^);
+        pNm := pTy.formals.tide;
+      ELSE
+        string2 := LitValue.strToCharOpen(initSuffix);
+        pNm := 0;
+      END;
+      os.Call2(Jvm.opc_invokespecial,
+		 rec.baseTp(Ty.Record).xName, string2, pNm+1, 0);
+    ELSE
+      os.CallS(Jvm.opc_invokespecial, objectInit, 1, 0);
+    END;
+   (*
+    *    Initialize fields, as necessary.
+    *)
+    FOR idx := 0 TO rec.fields.tide-1 DO
+      fld := rec.fields.a[idx];
+      IF (fld.type IS Ty.Record) OR (fld.type IS Ty.Array) THEN
+        os.Comment("Initialize embedded object");
+	os.Code(Jvm.opc_aload_0);
+	os.VarInit(fld);
+        os.PutGetF(Jvm.opc_putfield, rec, fld(Id.FldId));
+      END;
+    END;
+(*
+ *  os.Code(Jvm.opc_return);
+ *  os.Stack();
+ *  os.Directive(Jvm.dot_end);
+ *  os.Blank();
+ *)
+  END CallSuperCtor;
+
+(* ---------------------------------------------------- *)
+
+  PROCEDURE (os : JsmnFile)CopyProcHead*(rec : Ty.Record);
+  BEGIN
+    os.proc := newProcInfo(NIL);
+    os.Comment("standard record copy method");
+    os.DirectiveIS(Jvm.dot_method, Jvm.att_public, 
+				"__copy__(" + rec.scopeNm^ + ")V");
+  END CopyProcHead;
+
+(* ============================================================ *)
+(*			Private Methods				*)
+(* ============================================================ *)
+
+  PROCEDURE (os : JsmnFile)Mark(),NEW;
+  BEGIN
+    GPTextFiles.WriteChar(os.file, ";");
+    GPText.WriteInt(os.file, os.proc.dNum, 3);
+    GPText.WriteInt(os.file, os.proc.dMax, 3);
+    GPTextFiles.WriteEOL(os.file);
+  END Mark;
+
+(* ============================================================ *)
+
+  PROCEDURE (os : JsmnFile)CatStr(IN str : ARRAY OF CHAR),NEW;
+  BEGIN
+    GPTextFiles.WriteNChars(os.file, str, LEN(str$));
+  END CatStr;
+
+(* ============================================================ *)
+
+  PROCEDURE (os : JsmnFile)Tstring(IN str : ARRAY OF CHAR),NEW;
+  BEGIN
+    GPTextFiles.WriteChar(os.file, ASCII.HT);
+    GPTextFiles.WriteNChars(os.file, str, LEN(str$));
+  END Tstring;
+
+(* ============================================================ *)
+
+  PROCEDURE (os : JsmnFile)Tint(int : INTEGER),NEW;
+  BEGIN
+    GPTextFiles.WriteChar(os.file, ASCII.HT);
+    GPText.WriteInt(os.file, int, 1);
+  END Tint;
+
+(* ============================================================ *)
+
+  PROCEDURE (os : JsmnFile)Tlong(long : LONGINT),NEW;
+  BEGIN
+    GPTextFiles.WriteChar(os.file, ASCII.HT);
+    GPText.WriteLong(os.file, long, 1);
+  END Tlong;
+
+(* ============================================================ *)
+
+  PROCEDURE (os : JsmnFile)QuoteStr(IN str : ARRAY OF CHAR),NEW;
+    VAR ix : INTEGER;
+	ch : CHAR;
+  BEGIN
+    ix := 0;
+    ch := str[0];
+    GPTextFiles.WriteChar(os.file, '"');
+    WHILE ch # 0X DO
+      CASE ch OF
+      | "\",'"' : GPTextFiles.WriteChar(os.file, "\");
+		  GPTextFiles.WriteChar(os.file, ch);
+      | 9X	: GPTextFiles.WriteChar(os.file, "\");
+		  GPTextFiles.WriteChar(os.file, "t");
+      | 0AX	: GPTextFiles.WriteChar(os.file, "\");
+		  GPTextFiles.WriteChar(os.file, "n");
+      ELSE
+	GPTextFiles.WriteChar(os.file, ch);
+      END;
+      INC(ix);
+      ch := str[ix];
+    END;
+    GPTextFiles.WriteChar(os.file, '"');
+  END QuoteStr;
+
+(* ============================================================ *)
+
+  PROCEDURE (os : JsmnFile)Prefix(code : INTEGER),NEW;
+  BEGIN
+    GPTextFiles.WriteChar(os.file, ASCII.HT);
+    GPTextFiles.WriteNChars(os.file,Jvm.op[code],LEN(Jvm.op[code]$));
+  END Prefix;
+
+(* ============================================================ *)
+
+  PROCEDURE (os : JsmnFile)Suffix(code : INTEGER),NEW;
+  BEGIN
+    GPTextFiles.WriteEOL(os.file);
+    INC(os.proc.dNum, Jvm.dl[code]);
+    IF os.proc.dNum > os.proc.dMax THEN os.proc.dMax := os.proc.dNum END;
+    IF CompState.verbose THEN os.Mark() END;
+  END Suffix;
+
+(* ============================================================ *)
+
+  PROCEDURE (os : JsmnFile)Access(acc : SET),NEW;
+    VAR att : INTEGER;
+  BEGIN
+    FOR att := 0 TO 10 DO
+      IF att IN acc THEN
+	GPText.WriteString(os.file, Jvm.access[att]);
+	GPTextFiles.WriteChar(os.file, ' ');
+      END;
+    END;
+  END Access;
+
+(* ============================================================ *)
+
+  PROCEDURE (os : JsmnFile)RefLab(l : J.Label),NEW;
+  BEGIN
+    GPTextFiles.WriteChar(os.file, ASCII.HT);
+    GPTextFiles.WriteChar(os.file, "l");
+    GPTextFiles.WriteChar(os.file, "b");
+    GPText.WriteInt(os.file, l.defIx, 1);
+  END RefLab;
+
+  PROCEDURE (os : JsmnFile)AddSwitchLab*(l : J.Label; pos : INTEGER);
+  BEGIN
+    os.RefLab(l);
+    GPTextFiles.WriteEOL(os.file);
+  END AddSwitchLab;
+
+  PROCEDURE (os : JsmnFile)LstDef*(l : J.Label);
+  BEGIN
+    GPText.WriteString(os.file, "default:");
+    os.RefLab(l);
+    GPTextFiles.WriteEOL(os.file);
+  END LstDef;
+
+(* ============================================================ *)
+
+  PROCEDURE (os : JsmnFile)Idnt(idD : D.Idnt),NEW;
+  BEGIN
+    GPText.WriteString(os.file, D.getName.ChPtr(idD));
+  END Idnt;
+
+(* ============================================================ *)
+
+  PROCEDURE (os : JsmnFile)Type(typ : D.Type),NEW;
+  BEGIN
+    WITH typ : Ty.Base DO
+	GPText.WriteString(os.file, typ.xName);
+    | typ : Ty.Vector DO
+	IF typ.xName = NIL THEN J.MkVecName(typ) END;
+	GPText.WriteString(os.file, typ.xName);
+    | typ : Ty.Array DO
+	GPTextFiles.WriteChar(os.file, "[");
+	os.Type(typ.elemTp);
+    | typ : Ty.Record DO
+	IF typ.xName = NIL THEN J.MkRecName(typ) END;
+	GPText.WriteString(os.file, typ.scopeNm);
+    | typ : Ty.Enum DO
+	GPText.WriteString(os.file, G.intTp.xName);
+    | typ : Ty.Pointer DO
+	os.Type(typ.boundTp);
+    | typ : Ty.Opaque DO
+	IF typ.xName = NIL THEN J.MkAliasName(typ) END;
+	GPText.WriteString(os.file, typ.scopeNm);
+    END;
+  END Type;
+
+(* ============================================================ *)
+
+  PROCEDURE (os : JsmnFile)TypeTag(typ : D.Type),NEW;
+  BEGIN
+    WITH typ : Ty.Base DO
+	GPText.WriteString(os.file, typ.xName);
+    | typ : Ty.Array DO
+	GPTextFiles.WriteChar(os.file, "[");
+	os.TypeTag(typ.elemTp);
+    | typ : Ty.Record DO
+	IF typ.xName = NIL THEN J.MkRecName(typ) END;
+	GPText.WriteString(os.file, typ.xName);
+    | typ : Ty.Pointer DO
+	os.TypeTag(typ.boundTp);
+    | typ : Ty.Opaque DO
+	IF typ.xName = NIL THEN J.MkAliasName(typ) END;
+	GPText.WriteString(os.file, typ.xName);
+    END;
+  END TypeTag;
+
+(* ============================================================ *)
+(*			Exported Methods			*)
+(* ============================================================ *)
+
+  PROCEDURE (os : JsmnFile)newLabel*() : J.Label;
+  VAR
+    lab : J.Label;
+  BEGIN
+    NEW(lab);
+    INC(os.nxtLb); 
+    lab.defIx := os.nxtLb;
+    RETURN lab;
+  END newLabel;
+
+(* ============================================================ *)
+
+  PROCEDURE (os : JsmnFile)getLabelRange*(VAR labs : ARRAY OF J.Label);
+    VAR labNo : INTEGER;
+        count : INTEGER;
+        i     : INTEGER;
+        
+  BEGIN
+    count := LEN(labs); 
+    labNo := os.nxtLb + 1;
+    INC(os.nxtLb, count); 
+    FOR i := 0 TO count-1 DO
+      NEW(labs[i]);
+      labs[i].defIx := labNo;
+      INC(labNo);
+    END;
+  END getLabelRange;
+
+(* ============================================================ *)
+
+  PROCEDURE (os : JsmnFile)Blank*(),NEW;
+  BEGIN
+    GPTextFiles.WriteEOL(os.file);
+  END Blank;
+
+(* ============================================================ *)
+
+  PROCEDURE (os : JsmnFile)Directive(dir : INTEGER),NEW;
+  BEGIN
+    os.CatStr(Jvm.dirStr[dir]);
+    GPTextFiles.WriteEOL(os.file);
+  END Directive;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE (os : JsmnFile)DirectiveS(dir : INTEGER;
+				   IN str : ARRAY OF CHAR),NEW;
+  BEGIN
+    os.CatStr(Jvm.dirStr[dir]);
+    GPTextFiles.WriteChar(os.file, " ");
+    GPTextFiles.WriteNChars(os.file, str, LEN(str$));
+    GPTextFiles.WriteEOL(os.file);
+  END DirectiveS;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE (os : JsmnFile)DirectiveIS(dir : INTEGER;
+				        att : SET;
+				     IN str : ARRAY OF CHAR),NEW;
+  BEGIN
+    os.CatStr(Jvm.dirStr[dir]);
+    GPTextFiles.WriteChar(os.file, " ");
+    os.Access(att);
+    GPTextFiles.WriteNChars(os.file, str, LEN(str$));
+    GPTextFiles.WriteEOL(os.file);
+  END DirectiveIS;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE (os : JsmnFile)DirectiveISS(dir : INTEGER;
+				         att : SET;
+				      IN s1  : ARRAY OF CHAR;
+				      IN s2  : ARRAY OF CHAR),NEW;
+  BEGIN
+    os.CatStr(Jvm.dirStr[dir]);
+    GPTextFiles.WriteChar(os.file, " ");
+    os.Access(att);
+    GPTextFiles.WriteNChars(os.file, s1, LEN(s1$));
+    GPTextFiles.WriteNChars(os.file, s2, LEN(s2$));
+    GPTextFiles.WriteEOL(os.file);
+  END DirectiveISS;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE (os : JsmnFile)Comment*(IN s : ARRAY OF CHAR);
+  BEGIN
+    GPTextFiles.WriteChar(os.file, ";");
+    GPTextFiles.WriteChar(os.file, " ");
+    GPTextFiles.WriteNChars(os.file, s, LEN(s$));
+    GPTextFiles.WriteEOL(os.file);
+  END Comment;
+
+(* ============================================================ *)
+
+  PROCEDURE (os : JsmnFile)DefLab*(l : J.Label);
+  BEGIN
+    GPTextFiles.WriteChar(os.file, "l");
+    GPTextFiles.WriteChar(os.file, "b");
+    GPText.WriteInt(os.file, l.defIx, 1);
+    GPTextFiles.WriteChar(os.file, ":");
+    GPTextFiles.WriteEOL(os.file);
+  END DefLab;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE (os : JsmnFile)DefLabC*(l : J.Label; IN c : ARRAY OF CHAR);
+  BEGIN
+    GPTextFiles.WriteChar(os.file, "l");
+    GPTextFiles.WriteChar(os.file, "b");
+    GPText.WriteInt(os.file, l.defIx, 1);
+    GPTextFiles.WriteChar(os.file, ":");
+    GPTextFiles.WriteChar(os.file, ASCII.HT);
+    os.Comment(c);
+  END DefLabC;
+
+(* ============================================================ *)
+
+  PROCEDURE (os : JsmnFile)Code*(code : INTEGER);
+  BEGIN
+    os.Prefix(code);
+    os.Suffix(code);
+  END Code;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE (os : JsmnFile)CodeI*(code,int : INTEGER);
+  BEGIN
+    os.Prefix(code);
+    os.Tint(int);
+    os.Suffix(code);
+  END CodeI;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE (os : JsmnFile)CodeT*(code : INTEGER; type : D.Type);
+  BEGIN
+    os.Prefix(code);
+    GPTextFiles.WriteChar(os.file, ASCII.HT);
+    os.TypeTag(type);
+    os.Suffix(code);
+  END CodeT;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE (os : JsmnFile)CodeL*(code : INTEGER; long : LONGINT);
+  BEGIN
+    os.Prefix(code);
+    os.Tlong(long);
+    os.Suffix(code);
+  END CodeL;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE (os : JsmnFile)CodeR*(code : INTEGER; real : REAL; short : BOOLEAN);
+    VAR nam : ARRAY 64 OF CHAR;
+  BEGIN
+    os.Prefix(code);
+    RTS.RealToStr(real, nam);
+    os.Tstring(nam$);
+    os.Suffix(code);
+  END CodeR;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE (os : JsmnFile)CodeLb*(code : INTEGER; i2 : J.Label);
+  BEGIN
+    os.Prefix(code);
+    os.RefLab(i2);
+    os.Suffix(code);
+  END CodeLb;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE (os : JsmnFile)CodeII*(code,i1,i2 : INTEGER),NEW;
+  BEGIN
+    os.Prefix(code);
+    os.Tint(i1);
+    os.Tint(i2);
+    os.Suffix(code);
+  END CodeII;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE (os : JsmnFile)CodeInc*(localIx, incVal : INTEGER);
+  BEGIN
+    os.CodeII(Jvm.opc_iinc, localIx, incVal);
+  END CodeInc;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE (os : JsmnFile)CodeS*(code : INTEGER; IN str : ARRAY OF CHAR),NEW;
+  BEGIN
+    os.Prefix(code);
+    os.Tstring(str);
+    os.Suffix(code);
+  END CodeS;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE (os : JsmnFile)CodeC*(code : INTEGER; IN str : ARRAY OF CHAR);
+  BEGIN
+    os.Prefix(code);
+    GPTextFiles.WriteNChars(os.file, str, LEN(str$));
+    os.Suffix(code);
+  END CodeC;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE (os : JsmnFile)CodeSwitch*(loIx,hiIx : INTEGER; dfLb : J.Label);
+  BEGIN
+    os.CodeII(Jvm.opc_tableswitch,loIx,hiIx);
+  END CodeSwitch;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE (os : JsmnFile)PushStr*(IN str : LitValue.CharOpen);
+  (* Use target quoting conventions for the literal string *)
+  BEGIN
+    os.Prefix(Jvm.opc_ldc);
+    GPTextFiles.WriteChar(os.file, ASCII.HT);
+    os.QuoteStr(str^);
+    os.Suffix(Jvm.opc_ldc);
+  END PushStr;
+
+(* ============================================================ *)
+
+  PROCEDURE (os : JsmnFile)CallS*(code : INTEGER; 
+				IN str : ARRAY OF CHAR;
+				argL,retL : INTEGER),NEW;
+  BEGIN
+    os.Prefix(code);
+    os.Tstring(str);
+    IF code = Jvm.opc_invokeinterface THEN os.Tint(argL) END;
+    GPTextFiles.WriteEOL(os.file);
+    INC(os.proc.dNum, retL-argL);
+    IF os.proc.dNum > os.proc.dMax THEN os.proc.dMax := os.proc.dNum END;
+    IF CompState.verbose THEN os.Mark() END;
+  END CallS;
+
+(* ============================================================ *)
+
+  PROCEDURE (os : JsmnFile)CallIT*(code : INTEGER; 
+				   proc : Id.Procs; 
+				   type : Ty.Procedure);
+    VAR argL, retL : INTEGER;
+	clsNam : LitValue.CharOpen;
+  BEGIN
+    os.Prefix(code);
+    IF proc.scopeNm = NIL THEN J.MkProcName(proc) END;
+    os.Tstring(proc.scopeNm);
+    GPTextFiles.WriteChar(os.file, "/");
+    WITH proc : Id.PrcId DO clsNam := proc.clsNm;
+    |    proc : Id.MthId DO clsNam := proc.bndType(Ty.Record).extrnNm;
+    END;
+    os.CatStr(clsNam);
+    GPTextFiles.WriteChar(os.file, "/");
+    os.CatStr(proc.prcNm);
+    os.CatStr(type.xName);
+    argL := type.argN;
+    retL := type.retN;
+    IF code = Jvm.opc_invokeinterface THEN os.Tint(type.argN) END;
+    GPTextFiles.WriteEOL(os.file);
+    INC(os.proc.dNum, retL-argL);
+    IF os.proc.dNum > os.proc.dMax THEN os.proc.dMax := os.proc.dNum END;
+    IF CompState.verbose THEN os.Mark() END;
+  END CallIT;
+
+(* ============================================================ *)
+
+  PROCEDURE (os : JsmnFile)Call2*(code : INTEGER; 
+				IN st1 : ARRAY OF CHAR;
+				IN st2 : ARRAY OF CHAR;
+				argL,retL : INTEGER),NEW;
+  BEGIN
+    os.Prefix(code);
+    os.Tstring(st1);
+    os.CatStr(st2);
+    IF code = Jvm.opc_invokeinterface THEN os.Tint(argL) END;
+    GPTextFiles.WriteEOL(os.file);
+    INC(os.proc.dNum, retL-argL);
+    IF os.proc.dNum > os.proc.dMax THEN os.proc.dMax := os.proc.dNum END;
+    IF CompState.verbose THEN os.Mark() END;
+  END Call2;
+
+(* ============================================================ *)
+
+  PROCEDURE (os : JsmnFile)MultiNew*(elT : D.Type;
+				     dms : INTEGER),NEW;
+   (* dsc is the array descriptor, dms the number of dimensions *)
+    VAR i : INTEGER;
+  BEGIN
+    os.Prefix(Jvm.opc_multianewarray);
+    GPTextFiles.WriteChar(os.file, ASCII.HT);
+    FOR i := 1 TO dms DO GPTextFiles.WriteChar(os.file, "[") END;
+    os.TypeTag(elT);
+    os.Tint(dms);
+    GPTextFiles.WriteEOL(os.file);
+    DEC(os.proc.dNum, dms-1);
+  END MultiNew;
+
+(* ============================================================ *)
+
+  PROCEDURE (os : JsmnFile)PutGetS*(code : INTEGER;
+				    blk  : Id.BlkId;
+				    fld  : Id.VarId);
+    VAR size : INTEGER;
+  (* Emit putstatic and getstatic for static field *)
+  BEGIN
+    os.Prefix(code);
+    IF blk.xName = NIL THEN J.MkBlkName(blk) END;
+    IF fld.varNm = NIL THEN J.MkVarName(fld) END;
+    os.Tstring(blk.scopeNm);
+    GPTextFiles.WriteChar(os.file, "/");
+    os.CatStr(fld.clsNm);
+    GPTextFiles.WriteChar(os.file, "/");
+    os.CatStr(fld.varNm);
+    GPTextFiles.WriteChar(os.file, " ");
+    os.Type(fld.type);
+    GPTextFiles.WriteEOL(os.file);
+    size := J.jvmSize(fld.type);
+    IF    code = Jvm.opc_getstatic THEN INC(os.proc.dNum, size);
+    ELSIF code = Jvm.opc_putstatic THEN DEC(os.proc.dNum, size);
+    END;
+    IF os.proc.dNum > os.proc.dMax THEN os.proc.dMax := os.proc.dNum END;
+    IF CompState.verbose THEN os.Mark() END;
+  END PutGetS;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE (os : JsmnFile)PutGetF*(code : INTEGER;
+				    rec  : Ty.Record;
+				    fld  : Id.AbVar);
+(*
+				    fld  : Id.FldId);
+ *)
+    VAR size : INTEGER;
+  (* Emit putfield and getfield for record field *)
+  BEGIN
+    os.Prefix(code);
+    GPTextFiles.WriteChar(os.file, ASCII.HT);
+    os.TypeTag(rec);
+    GPTextFiles.WriteChar(os.file, "/");
+    os.Idnt(fld);
+    GPTextFiles.WriteChar(os.file, " ");
+    os.Type(fld.type);
+    GPTextFiles.WriteEOL(os.file);
+    size := J.jvmSize(fld.type);
+    IF    code = Jvm.opc_getfield THEN INC(os.proc.dNum, size-1);
+    ELSIF code = Jvm.opc_putfield THEN DEC(os.proc.dNum, size+1);
+    END;
+    IF os.proc.dNum > os.proc.dMax THEN os.proc.dMax := os.proc.dNum END;
+    IF CompState.verbose THEN os.Mark() END;
+  END PutGetF;
+
+(* ============================================================ *)
+
+  PROCEDURE (os : JsmnFile)Alloc1d*(elTp : D.Type);
+  BEGIN
+    WITH elTp : Ty.Base DO
+      IF (elTp.tpOrd < Ty.anyRec) THEN
+        os.CodeS(Jvm.opc_newarray, typeName[elTp.tpOrd]);
+      ELSE
+        os.Prefix(Jvm.opc_anewarray);
+        os.Tstring(object);
+        os.Suffix(Jvm.opc_anewarray);
+      END;
+    ELSE
+      os.Prefix(Jvm.opc_anewarray);
+      GPTextFiles.WriteChar(os.file, ASCII.HT);
+      os.TypeTag(elTp);
+      os.Suffix(Jvm.opc_anewarray);
+    END;
+  END Alloc1d;
+
+(* ============================================================ *)
+
+  PROCEDURE (os : JsmnFile)MkNewRecord*(typ : Ty.Record);
+  BEGIN
+    os.CodeT(Jvm.opc_new, typ);
+    os.Code(Jvm.opc_dup);
+    os.Prefix(Jvm.opc_invokespecial);
+    os.Tstring(typ.xName);
+    os.CatStr(initSuffix);
+    os.Suffix(Jvm.opc_invokespecial);
+  END MkNewRecord;
+
+(* ============================================================ *)
+
+  PROCEDURE (os : JsmnFile)MkNewFixedArray*(topE : D.Type; len0 : INTEGER);
+    VAR dims : INTEGER;
+	arTp : Ty.Array;
+	elTp : D.Type;
+  BEGIN
+    (*
+    //  Fixed-size, possibly multi-dimensional arrays.
+    //  The code relies on the semantic property in CP
+    //  that the element-type of a fixed array type cannot
+    //  be an open array. This simplifies the code somewhat.
+    *)
+    os.PushInt(len0);
+    dims := 1;
+    elTp := topE;
+   (*
+    *  Find the number of dimensions ...
+    *)
+    LOOP
+      WITH elTp : Ty.Array DO arTp := elTp ELSE EXIT END;
+      elTp := arTp.elemTp;
+      os.PushInt(arTp.length);
+      INC(dims);
+    END;
+    IF dims = 1 THEN
+      os.Alloc1d(elTp);
+     (*
+      *  Stack is (top) len0, ref...
+      *)
+      IF elTp.kind = Ty.recTp THEN os.Init1dArray(elTp, len0) END;
+    ELSE
+     (*
+      *  Allocate the array headers for all dimensions.
+      *  Stack is (top) lenN, ... len0, ref...
+      *)
+      os.MultiNew(elTp, dims);
+     (*
+      *  Stack is (top) ref...
+      *)
+      IF elTp.kind = Ty.recTp THEN os.InitNdArray(topE, elTp) END;
+    END;
+  END MkNewFixedArray;
+
+(* ============================================================ *)
+
+  PROCEDURE (os : JsmnFile)MkNewOpenArray*(arrT : Ty.Array; dims : INTEGER);
+    VAR elTp : D.Type;
+	indx : INTEGER;
+  BEGIN
+   (* 
+    *  Assert: lengths are pushed already...
+    *  and we know from semantic analysis that
+    *  the number of open array dimensions match
+    *  the number of integer LENs in dims.
+    *)
+    elTp := arrT;
+   (*
+    *   Find the number of dimensions ...
+    *)
+    FOR indx := 0 TO dims-1 DO
+      elTp := elTp(Ty.Array).elemTp;
+    END;
+   (*
+    *   Allocate the array headers for all _open_ dimensions.
+    *)
+    IF dims = 1 THEN
+      os.Alloc1d(elTp);
+     (*
+      *  Stack is now (top) ref ...
+      *  and we _might_ need to initialize the elements.
+      *)
+      IF (elTp.kind = Ty.recTp) OR 
+	 (elTp.kind = Ty.arrTp) THEN 
+	os.Init1dArray(elTp, 0);
+      END;
+    ELSE
+      os.MultiNew(elTp, dims);
+     (*
+      *    Stack is now (top) ref ...
+      *    Now we _might_ need to initialize the elements.
+      *)
+      IF (elTp.kind = Ty.recTp) OR 
+	 (elTp.kind = Ty.arrTp) THEN 
+	os.InitNdArray(arrT.elemTp, elTp);
+      END;
+    END;
+  END MkNewOpenArray;
+
+
+(* ============================================================ *)
+
+  PROCEDURE (os : JsmnFile)MkArrayCopy*(arrT : Ty.Array);
+    VAR dims : INTEGER;
+        elTp : D.Type;
+  BEGIN
+   (*
+    *	Assert: we must find the lengths from the runtime 
+    *   descriptors.  Find the number of dimensions.  The 
+    *   array to copy is on the top of stack, which reads -
+    *		(top) aRef, ...
+    *)
+    elTp := arrT.elemTp;
+    IF elTp.kind # Ty.arrTp THEN
+      os.Code(Jvm.opc_arraylength);     (* (top) len0, aRef,...	*)
+      os.Alloc1d(elTp);			     (* (top) aRef, ...		*)
+      IF elTp.kind = Ty.recTp THEN os.Init1dArray(elTp, 0) END; (*0 ==> open*)
+    ELSE
+      dims := 1;
+      REPEAT
+       (* 
+        *  Invariant: an array reference is on the top of
+        *  of the stack, which reads:
+        *		(top) [arRf, lengths,] arRf ...
+	*)
+	INC(dims);
+        elTp := elTp(Ty.Array).elemTp;
+        os.Code(Jvm.opc_dup);	     (*          arRf, arRf,... *)
+        os.Code(Jvm.opc_arraylength);   (*    len0, arRf, arRf,... *)
+        os.Code(Jvm.opc_swap);	     (*    arRf, len0, arRf,... *)
+        os.Code(Jvm.opc_iconst_0);	     (* 0, arRf, len0, arRf,... *)
+        os.Code(Jvm.opc_aaload);	     (*    arRf, len0, arRf,... *)
+       (* 
+        *  Stack reads:	(top) arRf, lenN, [lengths,] arRf ...
+	*)
+      UNTIL  elTp.kind # Ty.arrTp;
+     (*
+      *  Now get the final length...
+      *)
+      os.Code(Jvm.opc_arraylength);  
+     (* 
+      *   Stack reads:	(top) lenM, lenN, [lengths,] arRf ...
+      *   Allocate the array headers for all dimensions.
+      *)
+      os.MultiNew(elTp, dims);
+     (*
+      *  Stack is (top) ref...
+      *)
+      IF elTp.kind = Ty.recTp THEN os.InitNdArray(arrT.elemTp, elTp) END;
+    END;
+  END MkArrayCopy;
+
+(* ============================================================ *)
+
+  PROCEDURE (os : JsmnFile)VarInit*(var : D.Idnt);
+    VAR typ : D.Type;
+  BEGIN
+   (*
+    *  Precondition: var is of a type that needs initialization
+    *)
+    typ := var.type;
+    WITH typ : Ty.Record DO
+	os.MkNewRecord(typ);
+    | typ : Ty.Array DO
+	os.MkNewFixedArray(typ.elemTp, typ.length);
+    ELSE
+      os.Code(Jvm.opc_aconst_null);
+    END;
+  END VarInit;
+
+(* ============================================================ *)
+
+  PROCEDURE (os : JsmnFile)ValRecCopy*(typ : Ty.Record);
+    VAR nam : LitValue.CharOpen;
+  BEGIN
+   (*
+    *     Stack at entry is (top) srcRef, dstRef...
+    *)
+    IF typ.xName = NIL THEN J.MkRecName(typ) END;
+    nam := typ.xName;
+    os.CallS(Jvm.opc_invokevirtual, 
+			nam^ + "/__copy__(L" + nam^ + ";)V", 2, 0);
+  END ValRecCopy;
+
+
+(* ============================================================ *)
+
+  PROCEDURE (os : JsmnFile)CallRTS*(ix,args,ret : INTEGER);
+  BEGIN
+    os.CallS(Jvm.opc_invokestatic, rtsProcs[ix], args, ret);
+  END CallRTS;
+
+(* ============================================================ *)
+
+  PROCEDURE (os : JsmnFile)CallGetClass*();
+  BEGIN
+    os.CallS(Jvm.opc_invokevirtual, rtsProcs[J.GetTpM], 1, 1);
+  END CallGetClass;
+
+(* ============================================================ *)
+
+  PROCEDURE (os : JsmnFile)Trap*(IN str : ARRAY OF CHAR);
+  BEGIN
+    os.CodeS(Jvm.opc_new, jlError);
+    os.Code(Jvm.opc_dup);
+(* Do we need the quotes? *)
+    os.PushStr(LitValue.strToCharOpen('"' + str + '"'));
+    os.CallS(Jvm.opc_invokespecial, mkError,2,0);
+    os.Code(Jvm.opc_athrow);
+  END Trap;
+
+(* ============================================================ *)
+
+  PROCEDURE (os : JsmnFile)CaseTrap*(i : INTEGER);
+  BEGIN
+    os.CodeS(Jvm.opc_new, jlError);
+    os.Code(Jvm.opc_dup);
+    os.LoadLocal(i, G.intTp);
+    os.CallS(Jvm.opc_invokestatic, 
+		"CP/CPJrts/CPJrts/CaseMesg(I)Ljava/lang/String;",1,1);
+    os.CallS(Jvm.opc_invokespecial, mkError,2,0);
+    os.Code(Jvm.opc_athrow);
+  END CaseTrap;
+
+(* ============================================================ *)
+
+  PROCEDURE (os : JsmnFile)WithTrap*(id : D.Idnt);
+  BEGIN
+    os.CodeS(Jvm.opc_new, jlError);
+    os.Code(Jvm.opc_dup);
+    os.GetVar(id);
+    os.CallS(Jvm.opc_invokestatic, 
+	"CP/CPJrts/CPJrts/WithMesg(Ljava/lang/Object;)Ljava/lang/String;",1,1);
+    os.CallS(Jvm.opc_invokespecial, mkError,2,0);
+    os.Code(Jvm.opc_athrow);
+  END WithTrap;
+
+(* ============================================================ *)
+
+  PROCEDURE (os : JsmnFile)Header*(IN str : ARRAY OF CHAR);
+    VAR date : ARRAY 64 OF CHAR;
+  BEGIN
+    RTS.GetDateString(date);
+    os.Comment("Jasmin output produced by CPascal compiler (" + 
+					RTS.defaultTarget + " version)");
+    os.Comment("at date: " + date);
+    os.Comment("from source file <" + str + '>');
+  END Header;
+
+(* ============================================================ *)
+ 
+  PROCEDURE (os : JsmnFile)StartRecClass*(rec : Ty.Record);
+  VAR
+    baseT  : D.Type;
+    attSet : SET;
+    clsId  : D.Idnt;
+    impRec : D.Type;
+    index  : INTEGER;
+  BEGIN
+    os.Blank();
+    os.DirectiveS(Jvm.dot_source, CompState.srcNam);
+   (*
+    *   Account for the record attributes.
+    *)
+    CASE rec.recAtt OF
+    | Ty.noAtt : attSet := Jvm.att_final;
+    | Ty.isAbs : attSet := Jvm.att_abstract;
+    | Ty.limit : attSet := Jvm.att_empty;
+    | Ty.extns : attSet := Jvm.att_empty;
+    END;
+   (*
+    *   Get the pointer IdDesc, if this is anonymous.
+    *)
+    IF rec.bindTp # NIL THEN 
+      clsId := rec.bindTp.idnt;
+    ELSE 
+      clsId := rec.idnt;
+    END;
+   (*
+    *   Account for the identifier visibility.
+    *)
+    IF clsId # NIL THEN
+      IF clsId.vMod = D.pubMode THEN
+	attSet := attSet + Jvm.att_public;
+      ELSIF clsId.vMod = D.prvMode THEN
+	attSet := attSet + Jvm.att_private;
+      END;
+    END;
+    os.DirectiveIS(Jvm.dot_class, attSet, rec.xName);
+   (*
+    *   Compute the super class attribute.
+    *)
+    baseT := rec.baseTp;
+    WITH baseT : Ty.Record DO
+      IF baseT.xName = NIL THEN J.MkRecName(baseT) END;
+      os.DirectiveS(Jvm.dot_super, baseT.xName);
+    ELSE
+      os.DirectiveS(Jvm.dot_super, object);
+    END;
+   (*
+    *   Emit interface declarations (if any)
+    *)
+    IF rec.interfaces.tide > 0 THEN
+      FOR index := 0 TO rec.interfaces.tide-1 DO
+	impRec := rec.interfaces.a[index];
+	baseT  := impRec.boundRecTp();
+        IF baseT.xName = NIL THEN J.MkRecName(baseT(Ty.Record)) END;
+	os.DirectiveS(Jvm.dot_implements, baseT.xName);
+      END;
+    END;
+    os.Blank();
+  END StartRecClass;
+
+  PROCEDURE (os : JsmnFile)StartModClass*(mod : Id.BlkId);
+  BEGIN
+    IF mod.main THEN os.Comment("This module implements CPmain") END;
+    os.Blank();
+    os.DirectiveS(Jvm.dot_source, CompState.srcNam);
+    IF mod.scopeNm[0] = 0X THEN
+      os.DirectiveIS(Jvm.dot_class, modAttrib, mod.xName);
+    ELSE
+      os.DirectiveISS(Jvm.dot_class, modAttrib, mod.scopeNm^ + '/', mod.xName);
+    END;
+    os.DirectiveS(Jvm.dot_super, object);
+    os.Blank();
+  END StartModClass;
+
+(* ============================================================ *)
+
+  PROCEDURE (os : JsmnFile)EmitField*(id : Id.AbVar);
+  VAR
+    att : SET;
+  BEGIN
+    IF id IS Id.FldId THEN att := Jvm.att_empty; 
+    ELSE att := Jvm.att_static; END;
+    IF id.vMod # D.prvMode THEN (* any export ==> public in JVM *)
+      att := att + Jvm.att_public;
+    END;
+    os.CatStr(Jvm.dirStr[Jvm.dot_field]);
+    GPTextFiles.WriteChar(os.file, " ");
+    os.Access(att);
+    GPTextFiles.WriteChar(os.file, " ");
+    os.Idnt(id);
+    GPTextFiles.WriteChar(os.file, " ");
+    os.Type(id.type);
+    GPTextFiles.WriteEOL(os.file);
+  END EmitField;
+
+(* ============================================================ *)
+
+  PROCEDURE (os : JsmnFile)Line*(nm : INTEGER);
+  BEGIN
+    os.CatStr(Jvm.dirStr[Jvm.dot_line]); 
+    os.Tint(nm);
+    GPTextFiles.WriteEOL(os.file);
+  END Line;
+
+(* ============================================================ *)
+
+  PROCEDURE (os : JsmnFile)Locals(),NEW;
+  BEGIN
+    os.CatStr(Jvm.dirStr[Jvm.dot_limit]); 
+    os.CatStr(" locals");
+    os.Tint(os.proc.lMax);
+    GPTextFiles.WriteEOL(os.file);
+  END Locals;
+
+(* ============================================================ *)
+
+  PROCEDURE (os : JsmnFile)Stack(),NEW;
+  BEGIN
+    os.CatStr(Jvm.dirStr[Jvm.dot_limit]); 
+    os.CatStr(" stack");
+    os.Tint(os.proc.dMax);
+    GPTextFiles.WriteEOL(os.file);
+  END Stack;
+
+(* ============================================================ *)
+(*			Namehandling Methods			*)
+(* ============================================================ *)
+
+  PROCEDURE (os : JsmnFile)LoadConst*(num : INTEGER);
+  BEGIN
+    IF (num >= MIN(SHORTINT)) & (num <= MAX(SHORTINT)) THEN
+      os.CodeI(Jvm.opc_sipush, num);
+    ELSE
+      os.CodeI(Jvm.opc_ldc, num);
+    END;
+  END LoadConst;
+
+(* ------------------------------------------------------------ *)
+
+  PROCEDURE (os : JsmnFile)Try*();
+    VAR start : J.Label;
+  BEGIN
+    start := os.newLabel();
+    os.proc.exLb := os.newLabel();
+    os.proc.hnLb := os.newLabel();
+    os.CatStr(Jvm.dirStr[Jvm.dot_catch]);
+    os.CatStr(" java/lang/Exception from lb");
+    GPText.WriteInt(os.file, start.defIx, 1);
+    os.CatStr(" to lb");
+    GPText.WriteInt(os.file, os.proc.exLb.defIx, 1);
+    os.CatStr(" using lb");
+    GPText.WriteInt(os.file, os.proc.hnLb.defIx, 1);
+    GPTextFiles.WriteEOL(os.file);
+    os.DefLab(start);
+  END Try;
+
+(* ------------------------------------------------------------ *)
+
+  PROCEDURE (os : JsmnFile)MkNewException*();
+  BEGIN
+    os.CodeS(Jvm.opc_new, jlExcept);
+  END MkNewException;
+
+  PROCEDURE (os : JsmnFile)InitException*();
+  BEGIN
+    os.CallS(Jvm.opc_invokespecial, mkExcept, 2,0);
+  END InitException;
+
+(* ------------------------------------------------------------ *)
+
+  PROCEDURE (os : JsmnFile)Catch*(prc : Id.Procs);
+  BEGIN
+    os.DefLab(os.proc.exLb);
+    os.DefLab(os.proc.hnLb);
+    os.StoreLocal(prc.except.varOrd, NIL);
+   (*
+    *  Now make sure that the overall stack
+    *  depth computation is correctly initialized
+    *)
+    IF os.proc.dMax < 1 THEN os.proc.dMax := 1 END;
+    os.proc.dNum := 0;
+  END Catch;
+
+(* ============================================================ *)
+
+  PROCEDURE (jf : JsmnFile)Dump*();
+  BEGIN
+    jf.Blank();
+    jf.Comment("end output produced by CPascal");
+    GPTextFiles.CloseFile(jf.file);
+  END Dump;
+
+(* ============================================================ *)
+(* ============================================================ *)
+BEGIN
+
+  typeChar[       0] := "?";		
+  typeChar[ Ty.boolN] := "Z";
+  typeChar[ Ty.sChrN] := "C";
+  typeChar[ Ty.charN] := "C";
+  typeChar[ Ty.byteN] := "B";
+  typeChar[ Ty.sIntN] := "S";
+  typeChar[  Ty.intN] := "I";
+  typeChar[ Ty.lIntN] := "J";
+  typeChar[ Ty.sReaN] := "F";
+  typeChar[ Ty.realN] := "D";
+  typeChar[  Ty.setN] := "I";
+  typeChar[Ty.anyRec] := "?";
+  typeChar[Ty.anyPtr] := "?";
+  typeChar[  Ty.strN] := "?";
+  typeChar[ Ty.sStrN] := "?";
+
+  typeName[     0] := "";		
+  typeName[ Ty.boolN] := "boolean";
+  typeName[ Ty.sChrN] := "char";
+  typeName[ Ty.charN] := "char";
+  typeName[ Ty.byteN] := "byte";
+  typeName[ Ty.sIntN] := "short";
+  typeName[  Ty.intN] := "int";
+  typeName[ Ty.lIntN] := "long";
+  typeName[ Ty.sReaN] := "float";
+  typeName[ Ty.realN] := "double";
+  typeName[  Ty.setN] := "int";
+  typeName[Ty.anyRec] := "";
+  typeName[Ty.anyPtr] := "";
+  typeName[  Ty.strN] := "";
+  typeName[ Ty.sStrN] := "";
+
+  rtsProcs[J.StrCmp] := "CP/CPJrts/CPJrts/strCmp([C[C)I";
+  rtsProcs[J.StrToChrOpen] := 
+	"CP/CPJrts/CPJrts/JavaStrToChrOpen(Ljava/lang/String;)[C";
+  rtsProcs[J.StrToChrs] := 
+	"CP/CPJrts/CPJrts/JavaStrToFixChr([CLjava/lang/String;)V";
+  rtsProcs[J.ChrsToStr] := 
+	"CP/CPJrts/CPJrts/FixChToJavaStr([C)Ljava/lang/String;";
+  rtsProcs[J.StrCheck] := "CP/CPJrts/CPJrts/ChrArrCheck([C)V";
+  rtsProcs[J.StrLen] := "CP/CPJrts/CPJrts/ChrArrLength([C)I";
+  rtsProcs[J.ToUpper] := "java/lang/Character/toUpperCase(C)C";
+  rtsProcs[J.DFloor] := "java/lang/Math/floor(D)D";
+  rtsProcs[J.ModI] := "CP/CPJrts/CPJrts/CpModI(II)I";
+  rtsProcs[J.ModL] := "CP/CPJrts/CPJrts/CpModL(JJ)J";
+  rtsProcs[J.DivI] := "CP/CPJrts/CPJrts/CpDivI(II)I";
+  rtsProcs[J.DivL] := "CP/CPJrts/CPJrts/CpDivL(JJ)J";
+  rtsProcs[J.StrCatAA] := 
+	"CP/CPJrts/CPJrts/ArrArrToString([C[C)Ljava/lang/String;";
+  rtsProcs[J.StrCatSA] := 
+"CP/CPJrts/CPJrts/StrArrToString(Ljava/lang/String;[C)Ljava/lang/String;";
+  rtsProcs[J.StrCatAS] := 
+"CP/CPJrts/CPJrts/ArrStrToString([CLjava/lang/String;)Ljava/lang/String;";
+  rtsProcs[J.StrCatSS] := "CP/CPJrts/CPJrts/StrStrToString(Ljava/lang/String;Ljava/lang/String;)Ljava/lang/String;";
+  rtsProcs[J.StrLP1] := "CP/CPJrts/CPJrts/ChrArrLplus1([C)I";
+  rtsProcs[J.StrVal] := "CP/CPJrts/CPJrts/ChrArrStrCopy([C[C)V";
+  rtsProcs[J.SysExit] := "java/lang/System/exit(I)V";
+  rtsProcs[J.LoadTp1] := "CP/CPJrts/CPJrts/getClassByOrd(I)Ljava/lang/Class;";
+  rtsProcs[J.LoadTp2] := 
+	"CP/CPJrts/CPJrts/getClassByName(Ljava/lang/String;)Ljava/lang/Class;";
+  rtsProcs[J.GetTpM] := "java/lang/Object/getClass()Ljava/lang/Class;";
+END JsmnUtil.
+(* ============================================================ *)
+(* ============================================================ *)
+

gpcp/LitValue.cp

@@ -0,0 +1,424 @@
+(* ==================================================================== *)
+(*									*)
+(*  Literal Valuehandler Module for the Gardens Point Component 	*)
+(*  Pascal Compiler. Exports the open character array type CharOpen	*)
+(*	Copyright (c) John Gough 1999, 2000.				*)
+(*									*)
+(* ==================================================================== *)
+
+MODULE LitValue;
+
+  IMPORT 
+	GPCPcopyright,
+	Console,
+	GPText,
+	CPascalS;
+
+(* ============================================================ *)
+
+  TYPE
+    CharOpen*    = POINTER TO ARRAY OF CHAR;
+    CharOpenSeq* = RECORD
+		     high  : INTEGER;
+		     tide- : INTEGER;
+		     a-    : POINTER TO ARRAY OF CharOpen;
+		   END;
+
+(* ============================================================ *)
+
+  TYPE
+    Value*    = POINTER TO RECORD		(* All opaque.	*)
+		  ord : LONGINT;
+		  flt : REAL;
+		  str : CharOpen;
+		END;
+
+(* ============================================================ *)
+  PROCEDURE^ strToCharOpen*(IN str : ARRAY OF CHAR) : CharOpen;
+  PROCEDURE^ subStrToCharOpen*(pos,len : INTEGER) : CharOpen;
+(* ============================================================ *)
+
+  PROCEDURE  newChrVal*(ch : CHAR) : Value;
+    VAR val : Value;
+  BEGIN
+    NEW(val); val.ord := ORD(ch); RETURN val;
+  END newChrVal;
+
+  PROCEDURE  newIntVal*(nm : LONGINT) : Value;
+    VAR val : Value;
+  BEGIN
+    NEW(val); val.ord := nm; RETURN val;
+  END newIntVal;
+
+  PROCEDURE  newFltVal*(rv : REAL) : Value;
+    VAR val : Value;
+  BEGIN
+    NEW(val); val.flt := rv; RETURN val;
+  END newFltVal;
+
+  PROCEDURE  newSetVal*(st : SET) : Value;
+    VAR val : Value;
+  BEGIN
+    NEW(val); val.ord := ORD(st); RETURN val;
+  END newSetVal;
+
+  PROCEDURE  newStrVal*(IN sv : ARRAY OF CHAR) : Value;
+    VAR val : Value;
+  BEGIN
+    NEW(val); 
+    val.ord := LEN(sv$);
+    val.str := strToCharOpen(sv);
+    RETURN val;
+  END newStrVal;
+
+  PROCEDURE  newBufVal*(p,l : INTEGER) : Value;
+    VAR val : Value;
+  BEGIN
+    NEW(val); 
+    val.ord := l;
+    val.str := subStrToCharOpen(p,l);
+    RETURN val;
+  END newBufVal;
+
+(* ============================================================ *)
+
+  PROCEDURE (v : Value)char*() : CHAR,NEW;	(* final method *)
+  BEGIN
+    RETURN CHR(v.ord);
+  END char;
+
+  PROCEDURE (v : Value)int*() : INTEGER,NEW;	(* final method *)
+  BEGIN
+    RETURN SHORT(v.ord);
+  END int;
+
+  PROCEDURE (v : Value)set*() : SET,NEW;	(* final method *)
+  BEGIN
+    RETURN BITS(SHORT(v.ord));
+  END set;
+
+  PROCEDURE (v : Value)long*() : LONGINT,NEW;	(* final method *)
+  BEGIN
+    RETURN v.ord;
+  END long;
+
+  PROCEDURE (v : Value)real*() : REAL,NEW;	(* final method *)
+  BEGIN
+    RETURN v.flt;
+  END real;
+
+  PROCEDURE (v : Value)chOpen*() : CharOpen,NEW;	(*final *)
+  BEGIN
+    RETURN v.str;
+  END chOpen;
+
+  PROCEDURE (v : Value)len*() : INTEGER,NEW;	(* final method *)
+  BEGIN
+    RETURN SHORT(v.ord);
+  END len;
+
+  PROCEDURE (v : Value)chr0*() : CHAR,NEW;	(* final method *)
+  BEGIN
+    RETURN v.str[0];
+  END chr0;
+
+  PROCEDURE (v : Value)GetStr*(OUT str : ARRAY OF CHAR),NEW;
+  BEGIN						(* final method *)
+    GPText.Assign(v.str^, str);
+  END GetStr;
+
+(* ============================================================ *)
+
+  PROCEDURE isShortStr*(in : Value) : BOOLEAN;
+    VAR idx : INTEGER;
+	chr : CHAR;
+  BEGIN
+    FOR idx := 0 TO LEN(in.str$) - 1 DO
+      chr := in.str[idx];
+      IF chr > 0FFX THEN RETURN FALSE END;
+    END;
+    RETURN TRUE;
+  END isShortStr;
+
+(* ============================================================ *)
+(* 		     Various CharOpen Utilities 		*)
+(* ============================================================ *)
+
+  PROCEDURE InitCharOpenSeq*(VAR seq : CharOpenSeq; capacity : INTEGER); 
+  BEGIN
+    NEW(seq.a, capacity); seq.tide := 0; seq.high := capacity-1;
+  END InitCharOpenSeq;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE ResetCharOpenSeq*(VAR seq : CharOpenSeq);
+  BEGIN
+    seq.tide := 0;
+  END ResetCharOpenSeq;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE AppendCharOpen*(VAR seq : CharOpenSeq; elem : CharOpen);
+    VAR temp : POINTER TO ARRAY OF CharOpen;
+	i    : INTEGER;
+  BEGIN
+    IF seq.a = NIL THEN 
+      InitCharOpenSeq(seq, 8);
+    ELSIF seq.tide > seq.high THEN (* must expand *)
+      temp := seq.a;
+      seq.high := seq.high * 2 + 1;
+      NEW(seq.a, seq.high+1);
+      FOR i := 0 TO seq.tide-1 DO seq.a[i] := temp[i] END;
+    END;
+    seq.a[seq.tide] := elem; INC(seq.tide);
+  END AppendCharOpen;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE strToCharOpen*(IN str : ARRAY OF CHAR) : CharOpen;
+    VAR i : INTEGER;
+        h : INTEGER;
+        p : CharOpen;
+  BEGIN
+    h := LEN(str$);
+    NEW(p,h+1);
+    FOR i := 0 TO h DO
+      p[i] := str[i];
+    END;
+    RETURN p;
+  END strToCharOpen;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE subChOToChO*(str : CharOpen;
+			 off : INTEGER;
+			 len : INTEGER) : CharOpen;
+    VAR i : INTEGER;
+        h : INTEGER;
+        p : CharOpen;
+  BEGIN
+    NEW(p, len+1);
+    FOR i := 0 TO len-1 DO
+      p[i] := str[i+off];
+    END;
+    RETURN p;
+  END subChOToChO;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE posOf*(ch : CHAR; op : CharOpen) : INTEGER;
+    VAR i : INTEGER;
+  BEGIN
+    FOR i := 0 TO LEN(op) - 1 DO
+      IF op[i] = ch THEN RETURN i END;
+    END;
+    RETURN LEN(op);
+  END posOf;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE subStrToCharOpen*(pos,len : INTEGER) : CharOpen;
+    VAR i : INTEGER;
+        p : CharOpen;
+  BEGIN
+    NEW(p,len+1);
+    FOR i := 0 TO len-1 DO
+      p[i] := CPascalS.charAt(pos+i);
+    END;
+    p[len] := 0X;
+    RETURN p;
+  END subStrToCharOpen;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE intToCharOpen*(i : INTEGER) : CharOpen;
+    VAR arr : ARRAY 16 OF CHAR;
+  BEGIN
+    GPText.IntToStr(i, arr);
+    RETURN strToCharOpen(arr);
+  END intToCharOpen;   
+
+(* -------------------------------------------- *)
+
+  PROCEDURE ToStr*(in : CharOpen; OUT out : ARRAY OF CHAR);
+  BEGIN
+    IF in = NIL THEN out := "<NIL>" ELSE GPText.Assign(in^, out) END;
+  END ToStr;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE arrayCat*(IN in : CharOpenSeq) : CharOpen;
+    VAR i,j,k : INTEGER;
+	len : INTEGER;
+	chO : CharOpen;
+	ret : CharOpen;
+	chr : CHAR;
+  BEGIN
+    len := 1;
+    FOR i := 0 TO in.tide-1 DO INC(len, LEN(in.a[i]) - 1) END;
+    NEW(ret, len);
+    k := 0;
+    FOR i := 0 TO in.tide-1 DO 
+      chO := in.a[i];
+      j := 0;
+      WHILE (j < LEN(chO)-1) & (chO[j] # 0X) DO 
+	ret[k] := chO[j]; INC(k); INC(j);
+      END;
+    END;
+    ret[k] := 0X;
+    RETURN ret;
+  END arrayCat;
+
+(* ============================================================ *)
+(* 		     Safe Operations on Values			*)
+(* ============================================================ *)
+(* 		     Well, will be safe later!			*)
+(* ============================================================ *)
+
+  PROCEDURE concat*(a,b : Value) : Value;
+    VAR c : Value;
+	i : INTEGER;
+	j : INTEGER;
+  BEGIN
+    j := SHORT(a.ord);
+    NEW(c);
+    c.ord := a.ord + b.ord;
+    NEW(c.str, SHORT(c.ord) + 1);
+    FOR i := 0 TO j - 1 DO
+      c.str[i] := a.str[i];
+    END;
+    FOR i := 0 TO SHORT(b.ord) DO
+      c.str[i+j] := b.str[i];
+    END;
+    RETURN c;
+  END concat;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE entV*(a : Value) : Value;
+    VAR c : Value;
+  BEGIN
+    IF (a.flt >= MAX(LONGINT) + 1.0) OR 
+       (a.flt < MIN(LONGINT)) THEN RETURN NIL;
+    ELSE NEW(c); c.ord := ENTIER(a.flt); RETURN c;
+    END; 
+  END entV;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE absV*(a : Value) : Value;
+    VAR c : Value;
+  BEGIN
+    IF a.ord = MIN(LONGINT) THEN RETURN NIL;
+    ELSE NEW(c); c.ord := ABS(a.ord); RETURN c;
+    END; 
+  END absV;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE negV*(a : Value) : Value;
+    VAR c : Value;
+  BEGIN
+    IF a.ord = MIN(LONGINT) THEN RETURN NIL;
+    ELSE NEW(c); c.ord := -a.ord; RETURN c;
+    END; 
+  END negV;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE addV*(a,b : Value) : Value;
+    VAR c : Value;
+  BEGIN
+    NEW(c); c.ord := a.ord + b.ord; RETURN c;
+  END addV;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE subV*(a,b : Value) : Value;
+    VAR c : Value;
+  BEGIN
+    NEW(c); c.ord := a.ord - b.ord; RETURN c;
+  END subV;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE mulV*(a,b : Value) : Value;
+    VAR c : Value;
+  BEGIN
+    NEW(c); c.ord := a.ord * b.ord; RETURN c;
+  END mulV;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE slashV*(a,b : Value) : Value;
+    VAR c : Value;
+  BEGIN
+    NEW(c); c.flt := a.ord / b.ord; RETURN c;
+  END slashV;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE divV*(a,b : Value) : Value;
+    VAR c : Value;
+  BEGIN
+    NEW(c); c.ord := a.ord DIV b.ord; RETURN c;
+  END divV;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE modV*(a,b : Value) : Value;
+    VAR c : Value;
+  BEGIN
+    NEW(c); c.ord := a.ord MOD b.ord; RETURN c;
+  END modV;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE div0V*(a,b : Value) : Value;
+    VAR c : Value;
+  BEGIN
+    NEW(c); c.ord := a.ord DIV0 b.ord; RETURN c;
+  END div0V;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE rem0V*(a,b : Value) : Value;
+    VAR c : Value;
+  BEGIN
+    NEW(c); c.ord := a.ord REM0 b.ord; RETURN c;
+  END rem0V;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE strCmp*(l,r : Value) : INTEGER;
+   (* warning: this routine is not unicode aware *)
+    VAR index   : INTEGER;
+	lch,rch : CHAR;
+  BEGIN
+    FOR index := 0 TO MIN(SHORT(l.ord), SHORT(r.ord)) + 1 DO
+      lch := l.str[index];
+      rch := r.str[index];
+      IF lch < rch    THEN RETURN -1
+      ELSIF lch > rch THEN RETURN 1
+      ELSIF lch = 0X  THEN RETURN 0
+      END;
+    END;
+    RETURN 0;
+  END strCmp;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE DiagCharOpen*(ptr : CharOpen);
+  BEGIN
+    IF ptr = NIL THEN 
+      Console.WriteString("<nil>");
+    ELSE 
+      Console.WriteString(ptr);
+    END;
+  END DiagCharOpen;
+
+(* ============================================================ *)
+BEGIN (* ====================================================== *)
+END LitValue.  (* ============================================== *)
+(* ============================================================ *)
+

gpcp/ModuleHandler.cp

@@ -0,0 +1,165 @@
+(***********************************************************************)
+(*                     Component Pascal Make Tool                      *)
+(*                                                                     *)
+(*           Diane Corney, 20th July 1999                              *)
+(*           Modifications:                                            *)
+(*                                                                     *)
+(*                                                                     *)
+(***********************************************************************)
+MODULE ModuleHandler;
+
+IMPORT  GPCPcopyright,
+	FileNames;
+
+CONST
+  listIncrement = 10;
+
+TYPE
+
+  ModName* = FileNames.NameString;
+
+  ModInfo* = POINTER TO ModInfoRec;
+
+  ModList*  = RECORD
+                tide* : INTEGER;
+                list* : POINTER TO ARRAY OF ModInfo; 
+              END; 
+               
+  KeyList* = POINTER TO ARRAY OF INTEGER;
+
+  ModInfoRec* = RECORD
+                  name*       : ModName;
+                  imports*    : ModList;
+                  importedBy* : ModList;
+                  importKeys* : KeyList;
+                  key*        : INTEGER;
+                  compile*    : BOOLEAN;
+                  done*       : BOOLEAN;
+                  isForeign*  : BOOLEAN;
+                  importsLinked* : BOOLEAN;
+                END;
+
+  ModTree* = POINTER TO RECORD
+               module : ModInfo;
+               left,right : ModTree;
+             END;
+
+  
+VAR
+  modules : ModTree;
+
+PROCEDURE Add* (VAR modList : ModList; mod : ModInfo);
+VAR
+  tmp : POINTER TO ARRAY OF ModInfo; 
+  i : INTEGER;
+BEGIN
+  IF modList.list = NIL THEN
+    NEW(modList.list,listIncrement);
+    modList.tide := 0;
+  ELSE
+    FOR i := 0 TO modList.tide - 1 DO
+      IF mod = modList.list[i] THEN RETURN; END;
+    END;
+    IF modList.tide >= LEN(modList.list) THEN
+      tmp := modList.list;
+      NEW(modList.list,(LEN(modList.list) + listIncrement)); 
+      FOR i := 0 TO modList.tide - 1 DO
+        modList.list[i] := tmp[i];
+      END;
+    END;
+  END;
+  modList.list[modList.tide] := mod;
+  INC(modList.tide);
+END Add;
+
+PROCEDURE AddKey*(thisMod, impMod : ModInfo; impKey : INTEGER); 
+VAR
+  i : INTEGER;
+  mods : ModList;
+  tmp : POINTER TO ARRAY OF INTEGER;
+BEGIN
+  mods := thisMod.imports;
+  IF (thisMod.importKeys = NIL) OR 
+     (LEN(thisMod.importKeys) < LEN(mods.list)) THEN
+    tmp := thisMod.importKeys;
+    NEW(thisMod.importKeys,LEN(mods.list));
+    IF (tmp # NIL) THEN
+      FOR i := 0 TO LEN(tmp)-1 DO
+        thisMod.importKeys[i] := tmp[i];
+      END; 
+    END; 
+  END;
+  i := 0;
+  WHILE (i < LEN (mods.list)) & (mods.list[i] # impMod) DO INC(i); END;
+  IF (i < LEN (mods.list)) THEN thisMod.importKeys[i] := impKey; END;
+END AddKey;
+
+PROCEDURE GetKey*(thisMod : ModInfo; impMod : ModInfo) : INTEGER;
+VAR
+  ix : INTEGER;
+BEGIN
+  (* Assert:  impMod is in imports list of thisMod *)
+  ix := 0;
+  WHILE (thisMod.imports.list[ix] # impMod) DO INC(ix); END;
+  RETURN thisMod.importKeys[ix];
+END GetKey;
+
+PROCEDURE NewModInfo(modName : ModName) : ModInfo;
+VAR
+  mod : ModInfo;
+BEGIN
+  NEW(mod);
+  mod.name := modName;
+  mod.key := 0;
+  mod.compile := FALSE;
+  mod.done := FALSE;
+  mod.isForeign := FALSE;
+  mod.importsLinked := FALSE;
+  mod.imports.tide := 0;
+  NEW(mod.imports.list, listIncrement);
+  mod.importedBy.tide := 0;
+  RETURN mod;
+END NewModInfo;
+
+PROCEDURE GetModule*(modName : ModName) : ModInfo; 
+VAR
+  mod : ModInfo;
+  node, parent : ModTree;
+  found : BOOLEAN;
+BEGIN
+  IF (modules = NIL) THEN
+    NEW (modules);
+    modules.module := NewModInfo(modName);
+    RETURN modules.module;
+  END;
+  mod := NIL;
+  node := modules; 
+  parent := NIL;
+  found := FALSE; 
+  WHILE (node # NIL) & (~found) DO
+    parent := node;
+    IF node.module.name = modName THEN
+      found := TRUE;
+      mod := node.module;
+    ELSIF modName < node.module.name THEN
+      node := node.left;
+    ELSE
+      node := node.right;
+    END;
+  END;
+  IF ~found THEN
+    ASSERT(parent # NIL);
+    NEW(node);
+    mod := NewModInfo(modName);
+    node.module := mod; 
+    IF modName < parent.module.name THEN
+      parent.left := node;
+    ELSE
+      parent.right := node;
+    END;
+  END;
+  RETURN mod;
+END GetModule;
+
+
+END ModuleHandler.

gpcp/MsilAsm.cp

@@ -0,0 +1,26 @@
+(* ============================================================ *)
+(**	Interface to the ILASM Byte-code assembler.		*)
+(*      Copyright (c) John Gough 1999, 2000.			*)
+(*	K John Gough, 10th June 1999				*)
+(*	Modifications:						*)
+(*		Version for GPCP V0.3 April 2000 (kjg)		*)
+(* ============================================================ *)
+(*	The real code is in MsilAsm.cs				*)	
+(* ============================================================ *)
+
+FOREIGN MODULE MsilAsm;
+  IMPORT GPCPcopyright;
+
+  PROCEDURE Init*();
+
+  PROCEDURE Assemble*(IN file : ARRAY OF CHAR; 
+		      IN optn : ARRAY OF CHAR;	(* "/debug" or "" *)
+			 main : BOOLEAN); 	(* /exe or /dll   *)
+
+  PROCEDURE DoAsm*(IN file : ARRAY OF CHAR; 
+		   IN optn : ARRAY OF CHAR;	(* "/debug" or "" *)
+		      main : BOOLEAN; 		(* /exe or /dll   *)
+		      vbse : BOOLEAN; 		(* verbose or not *)
+		  OUT rslt : INTEGER);		(* ilasm ret-code *)
+
+END MsilAsm.

gpcp/MsilAsmForeign.cp

@@ -0,0 +1,26 @@
+(* ============================================================ *)
+(**	Interface to the ILASM Byte-code assembler.		*)
+(*      Copyright (c) John Gough 1999, 2000.			*)
+(*	K John Gough, 10th June 1999				*)
+(*	Modifications:						*)
+(*		Version for GPCP V0.3 April 2000 (kjg)		*)
+(* ============================================================ *)
+(*	The real code is in MsilAsm.cs				*)	
+(* ============================================================ *)
+
+FOREIGN MODULE MsilAsm;
+  IMPORT GPCPcopyright;
+
+  PROCEDURE Init*();
+
+  PROCEDURE Assemble*(IN file : ARRAY OF CHAR; 
+		     IN optn : ARRAY OF CHAR; (* "/debug" or "" *)
+			    main : BOOLEAN); 	  (* /exe or /dll   *)
+
+  PROCEDURE DoAsm*(IN file : ARRAY OF CHAR; 
+		   IN optn : ARRAY OF CHAR;	(* "/debug" or "" *)
+		      main : BOOLEAN; 		(* /exe or /dll   *)
+		      vbse : BOOLEAN; 		(* verbose or not *)
+		  OUT rslt : INTEGER);		(* ilasm ret-code *)
+
+END MsilAsm.

gpcp/MsilAsmNative.cp

@@ -0,0 +1,90 @@
+(* ============================================================ *)
+(**	Interface to the ILASM Byte-code assembler.		*)
+(*      Copyright (c) John Gough 1999 -- 2002.			*)
+(*	K John Gough, 10th June 1999				*)
+(*	Modifications:						*)
+(*		Version for GPCP V0.3 April 2000 (kjg)		*)
+(* ============================================================ *)
+
+MODULE MsilAsm;
+  IMPORT 
+      RTS,
+      Console,
+      CompState,
+      GPCPcopyright,
+      Diag := "[System]System.Diagnostics";
+
+  VAR asm  : Diag.Process;
+
+  PROCEDURE Init*();
+  BEGIN
+    IF asm = NIL THEN
+      NEW(asm);
+      asm.get_StartInfo().set_FileName("ilasm");
+      asm.get_StartInfo().set_CreateNoWindow(TRUE);
+      asm.get_StartInfo().set_UseShellExecute(FALSE);
+    END;
+  END Init;
+
+  PROCEDURE Assemble*(IN file : ARRAY OF CHAR; 
+		      IN optn : ARRAY OF CHAR;	(* "/debug" or "" *)
+			 main : BOOLEAN); 	(* /exe or /dll   *)
+    VAR retCode : INTEGER;
+        optNm   : RTS.NativeString;
+        suffx   : RTS.NativeString;
+        fName   : RTS.NativeString;
+        ignore  : BOOLEAN;
+  BEGIN
+    fName := MKSTR(file);
+    IF main THEN
+      optNm := "/exe "; suffx := ".exe";
+    ELSE
+      optNm := "/dll "; suffx := ".dll";
+    END;
+    optNm := optNm + MKSTR(optn) + " ";
+    asm.get_StartInfo().set_Arguments(optNm+"/nologo /quiet "+fName+".il");
+    ignore := asm.Start();
+    asm.WaitForExit();
+    retCode := asm.get_ExitCode();
+    IF retCode # 0 THEN
+      Console.WriteString("#gpcp: ilasm FAILED");
+      Console.WriteInt(retCode, 0);
+    ELSIF ~CompState.quiet THEN
+      Console.WriteString("#gpcp: Created " + fName + suffx);
+    END;
+    Console.WriteLn;
+  END Assemble;
+
+  PROCEDURE DoAsm*(IN file : ARRAY OF CHAR; 
+		   IN optn : ARRAY OF CHAR;	(* "/debug" or "" *)
+		      main : BOOLEAN; 		(* /exe or /dll   *)
+		      vbse : BOOLEAN; 		(* verbose or not *)
+		  OUT rslt : INTEGER);		(* ilasm ret-code *)
+    VAR optNm   : RTS.NativeString;
+        suffx   : RTS.NativeString;
+        fName   : RTS.NativeString;
+        ignore  : BOOLEAN;
+  BEGIN
+    fName := MKSTR(file);
+    IF main THEN
+      optNm := "/exe "; suffx := ".exe";
+    ELSE
+      optNm := "/dll "; suffx := ".dll";
+    END;
+    optNm := optNm + MKSTR(optn) + " ";
+    IF vbse THEN
+      asm.get_StartInfo().set_CreateNoWindow(FALSE);
+      asm.get_StartInfo().set_Arguments(optNm + "/nologo " + fName + ".il");
+    ELSE
+      asm.get_StartInfo().set_CreateNoWindow(TRUE);
+      asm.get_StartInfo().set_Arguments(optNm+"/nologo /quiet "+fName+".il");
+    END;
+    ignore := asm.Start();
+    asm.WaitForExit();
+    rslt := asm.get_ExitCode();
+    IF rslt = 0 THEN
+      Console.WriteString("#gpcp: Created " + fName + suffx); Console.WriteLn;
+    END;
+  END DoAsm;
+
+END MsilAsm.

gpcp/MsilBase.cp

@@ -0,0 +1,35 @@
+(* ============================================================ *)
+(*  MsilBase is the abstract class for MSIL code		*)
+(*  emitters. The method Target.Select(mod, <name>) will 	*)
+(*  allocate a ClassMaker  object of an appropriate kind, and 	*)
+(*  will call classMaker.Emit()					*)
+(*  Copyright (c) John Gough 1999, 2000.			*)
+(* ============================================================ *)
+
+MODULE MsilBase;
+
+  IMPORT 
+	GPCPcopyright,
+	Console,
+	Sy := Symbols,
+	ClassMaker;
+	
+
+(* ============================================================ *)
+
+  TYPE
+    ClassEmitter* = POINTER TO ABSTRACT 
+ 		      RECORD (ClassMaker.ClassEmitter) END;
+
+(* ============================================================ *)
+(*  Not very elegant, but we need to get at the worklist from   *)
+(*  inside static procedures in IlasmUtil.			*)
+(* ============================================================ *)
+
+  VAR emitter* : ClassEmitter;
+
+  PROCEDURE (list : ClassEmitter)AddNewRecEmitter*(inTp : Sy.Type),NEW,EMPTY;
+
+(* ============================================================ *)
+END MsilBase.
+(* ============================================================ *)

gpcp/MsilMaker.cp

@@ -0,0 +1,3664 @@
+(* ============================================================ *)
+(*  MsilMaker is the concrete class for emitting COM2+          *)
+(*  intermediate language for the VOS.                          *)
+(*  Copyright (c) John Gough 1999, 2000.                        *)
+(*      Ugly kludge for covariant OUT params comes out          *)
+(*  next time. Search "fixup".  (kjg, 19 May 2001)              *)
+(* ============================================================ *)
+
+MODULE MsilMaker;
+
+  IMPORT
+        GPCPcopyright,
+        Error,
+        GPText,
+        Console,
+        FileNames,
+        MsilAsm,
+        MsilBase,
+        ClassMaker,
+        GPFiles,
+        GPBinFiles,
+        GPTextFiles,
+        PeUtil,
+        IlasmUtil,
+        Scn := CPascalS,
+        CSt := CompState,
+        Asm := IlasmCodes,
+        Mu  := MsilUtil,
+        Lv  := LitValue,
+        Bi  := Builtin,
+        Sy  := Symbols,
+        Id  := IdDesc ,
+        Ty  := TypeDesc,
+        Xp  := ExprDesc,
+        St  := StatDesc;
+
+(* ============================================================ *)
+
+  CONST pubStat     = Asm.att_public + Asm.att_static;
+        staticAtt   = Asm.att_static;
+        extern      = Asm.att_extern;
+
+  CONST inlineLimit = 4; (* limit for inline expansion of element copies *)
+
+(* ============================================================ *)
+
+  TYPE MsilEmitter* =
+        POINTER TO
+          RECORD (MsilBase.ClassEmitter)
+         (* --------------------------- *
+          * mod* : Id.BlkId;            *
+          * --------------------------- *)
+            work : Sy.IdSeq;
+            outF : Mu.MsilFile;
+          END;
+
+(* ------------------------------------ *)
+
+  TYPE MsilAssembler* =
+        POINTER TO
+          RECORD (ClassMaker.Assembler)
+            emit : Mu.MsilFile;
+          END;
+
+(* ------------------------------------ *)
+
+  VAR  asmName   : Lv.CharOpen;
+       asmExe    : BOOLEAN;
+
+(* ============================================================ *)
+(* ============================================================ *)
+
+  PROCEDURE newMsilEmitter*(mod : Id.BlkId) : MsilEmitter;
+    VAR emitter : MsilEmitter;
+  BEGIN
+    NEW(emitter);
+    emitter.mod := mod;
+    MsilBase.emitter := emitter;
+    Sy.InitIdSeq(emitter.work, 4);
+    Sy.AppendIdnt(emitter.work, mod);
+    RETURN emitter;
+  END newMsilEmitter;
+
+(* ============================================================ *)
+
+  PROCEDURE newMsilAsm*() : MsilAssembler;
+    VAR asm : MsilAssembler;
+  BEGIN
+    NEW(asm);
+    MsilAsm.Init();
+    RETURN asm;
+  END newMsilAsm;
+
+(* ============================================================ *)
+
+  PROCEDURE IdentOf(x : Sy.Expr) : Sy.Idnt;
+  BEGIN
+    WITH x : Xp.IdLeaf DO RETURN x.ident;
+       | x : Xp.IdentX DO RETURN x.ident;
+    ELSE      RETURN NIL;
+    END;
+  END IdentOf;
+
+(* ============================================================ *)
+
+  PROCEDURE fieldAttr(id : Sy.Idnt; in : SET) : SET;
+  BEGIN
+    IF id.type IS Ty.Event THEN (* backing field of event *)
+      RETURN in + Asm.att_private;   
+    ELSIF id.vMod # Sy.prvMode THEN
+      RETURN in + Asm.att_public;
+    ELSE
+      RETURN in + Asm.att_assembly;
+    END;
+  END fieldAttr;
+
+(* ============================================================ *)
+(*  Creates basic imports for System, and inserts a few type  *)
+(*  descriptors for Object, Exception, and String.              *)
+(* ============================================================ *)
+
+  PROCEDURE (this : MsilEmitter)Init*();
+    VAR tId : Id.TypId;
+        blk : Id.BlkId;
+        obj : Id.TypId;
+        str : Id.TypId;
+        exc : Id.TypId;
+        typ : Id.TypId;
+        del : Id.TypId;
+        evt : Id.TypId;
+  BEGIN
+   (*
+    *  Create import descriptor for [mscorlib]System
+    *)
+    Builtin.MkDummyImport("mscorlib_System", "[mscorlib]System", blk);
+   (*
+    *  Create various classes.
+    *)
+    Builtin.MkDummyClass("Object", blk, Ty.isAbs, obj);
+    CSt.ntvObj := obj.type;
+    Builtin.MkDummyClass("String", blk, Ty.noAtt, str);
+    Builtin.SetPtrBase(str, obj);
+    CSt.ntvStr := str.type;
+    Builtin.MkDummyClass("Exception", blk, Ty.extns, exc);
+    Builtin.SetPtrBase(exc, obj);
+    CSt.ntvExc := exc.type;
+    Builtin.MkDummyClass("Type", blk, Ty.isAbs, typ);
+    Builtin.SetPtrBase(typ, obj);
+    CSt.ntvTyp := typ.type;
+
+    Builtin.MkDummyClass("Delegate", blk, Ty.extns, del);
+    Builtin.SetPtrBase(del, obj);
+    Builtin.MkDummyClass("MulticastDelegate", blk, Ty.extns, evt);
+    Builtin.SetPtrBase(evt, del);
+    CSt.ntvEvt := evt.type;
+
+    (* NEED SOME WORK HERE?? *)
+
+    Builtin.MkDummyClass("ValueType", blk, Ty.extns, del);
+    Builtin.SetPtrBase(del, obj);
+    CSt.ntvVal := del.type.boundRecTp();
+
+    Mu.SetNativeNames();
+
+   (*
+    *  Create import descriptor for [RTS]RTS
+    *)
+    Builtin.MkDummyImport("RTS", "[RTS]", blk);
+    Builtin.MkDummyAlias("NativeType", blk, typ.type, CSt.clsId);
+    Builtin.MkDummyAlias("NativeObject", blk, obj.type, CSt.objId);
+    Builtin.MkDummyAlias("NativeString", blk, str.type, CSt.strId);
+    Builtin.MkDummyAlias("NativeException", blk, exc.type, CSt.excId);
+    INCL(blk.xAttr, Sy.need);
+    CSt.rtsBlk := blk;
+   (*
+    *  Uplevel addressing stuff. This is part of RTS assembly.
+    *)
+    Builtin.MkDummyClass("XHR", blk, Ty.isAbs, typ);
+    CSt.rtsXHR := typ.type;
+    CSt.xhrId.recTyp := CSt.rtsXHR.boundRecTp();
+    CSt.xhrId.type   := CSt.rtsXHR;
+   (*
+    *  Access to [RTS]RTS::dblPosInfinity, etc.
+    *)
+    Builtin.MkDummyVar("dblPosInfinity", blk, Bi.realTp, CSt.dblInf);
+    Builtin.MkDummyVar("dblNegInfinity", blk, Bi.realTp, CSt.dblNInf);
+    Builtin.MkDummyVar("fltPosInfinity", blk, Bi.sReaTp, CSt.fltInf);
+    Builtin.MkDummyVar("fltNegInfinity", blk, Bi.sReaTp, CSt.fltNInf);
+   (*
+    *  Access to [RTS]ProgArgs::argList
+    *)
+    Builtin.MkDummyImport("ProgArgs", "", blk);
+    Builtin.MkDummyVar("argList", blk, Ty.mkArrayOf(CSt.ntvStr), CSt.argLst);
+    INCL(blk.xAttr, Sy.rtsMd);
+    CSt.prgArg := blk;
+  END Init;
+
+(* ============================================================ *)
+
+  PROCEDURE (this : MsilAssembler)Assemble*();
+  (** Overrides EMPTY method in ClassMaker *)
+    VAR rslt : INTEGER;
+        optA : Lv.CharOpen;
+   (* ------------------------------------ *)
+    PROCEDURE buildOption(isExe : BOOLEAN) : Lv.CharOpen;
+      VAR str : Lv.CharOpen;
+          ext : ARRAY 5 OF CHAR;
+    BEGIN
+      str := NIL;
+      IF isExe THEN ext := ".exe" ELSE ext := ".dll" END;
+      IF CSt.binDir # "" THEN
+        str := BOX("/OUT=" + CSt.binDir);
+        IF str[LEN(str) - 2] = GPFiles.fileSep THEN
+          str := BOX(str^ + asmName^ + ext);
+        ELSE
+          str := BOX(str^ + "\" + asmName^ + ext);
+        END;
+      END;
+      IF CSt.debug THEN
+        IF str = NIL THEN str := BOX("/debug");
+        ELSE str := BOX(str^ + " /debug");
+        END;
+      END;
+      IF str = NIL THEN RETURN BOX(" ") ELSE RETURN str END;
+    END buildOption;
+   (* ------------------------------------ *)
+  BEGIN
+    IF asmName # NIL THEN
+      MsilAsm.DoAsm(asmName, buildOption(asmExe), asmExe, CSt.verbose, rslt);
+      IF rslt # 0 THEN CSt.thisMod.IdError(298) END;
+    END;
+  END Assemble;
+
+(* ============================================================ *)
+
+  PROCEDURE (this : MsilEmitter)AddNewRecEmitter*(inTp : Sy.Type);
+  (* Overrides AddNewRecEmitter() in MsilBase. *)
+    VAR idnt : Sy.Idnt;
+  BEGIN
+    idnt := NIL;
+    WITH inTp : Ty.Record DO
+      IF inTp.bindTp # NIL THEN idnt := inTp.bindTp.idnt;
+      ELSIF inTp.idnt # NIL THEN idnt := inTp.idnt;
+      ELSE ASSERT(FALSE);
+      END;
+    ELSE
+      idnt := inTp.idnt;
+    END;
+    Sy.AppendIdnt(this.work, idnt);
+  END AddNewRecEmitter;
+
+(* ============================================================ *)
+
+  PROCEDURE^ (e : MsilEmitter)ValueCopy(act : Sy.Expr; fmT : Sy.Type),NEW;
+  PROCEDURE^ (e : MsilEmitter)EmitProc(proc : Id.Procs; attr : SET),NEW;
+  PROCEDURE^ (e : MsilEmitter)PushValue(exp : Sy.Expr; typ : Sy.Type),NEW;
+  PROCEDURE^ (e : MsilEmitter)PushHandle(exp : Sy.Expr; typ : Sy.Type),NEW;
+  PROCEDURE^ (e : MsilEmitter)PushRef(exp : Sy.Expr; typ : Sy.Type),NEW;
+  PROCEDURE^ (e : MsilEmitter)EmitStat(stat : Sy.Stmt; OUT ok : BOOLEAN),NEW;
+  PROCEDURE^ (e : MsilEmitter)PushCall(callX : Xp.CallX),NEW;
+  PROCEDURE^ (e : MsilEmitter)FallFalse(exp : Sy.Expr; tLb : Mu.Label),NEW;
+
+  PROCEDURE^ (e : MsilEmitter)RefRecCopy(typ : Ty.Record),NEW;
+  PROCEDURE^ (e : MsilEmitter)RefArrCopy(typ : Ty.Array),NEW;
+  PROCEDURE^ (e : MsilEmitter)GetArgP(act : Sy.Expr; frm : Id.ParId),NEW;
+
+(* ============================================================ *)
+
+  PROCEDURE (t : MsilEmitter)MakeInit(rec : Ty.Record;
+                                      prc : Id.PrcId),NEW;
+    VAR out : Mu.MsilFile;
+        idx : INTEGER;
+        fld : Sy.Idnt;
+        spr : Id.PrcId;
+        frm : Id.ParId;
+        exp : Sy.Expr;
+        spT : Ty.Procedure;
+        lve : BOOLEAN;
+  BEGIN
+    spr := NIL;
+    out := t.outF;
+    out.Blank();
+    IF prc = NIL THEN
+      IF Sy.noNew IN rec.xAttr THEN
+        out.Comment("There is no no-arg constructor for this class");
+        out.Blank();
+        RETURN;                                    (* PREMATURE RETURN HERE *)
+      ELSIF Sy.xCtor IN rec.xAttr THEN
+        out.Comment("There is an explicit no-arg constructor for this class");
+        out.Blank();
+        RETURN;                                    (* PREMATURE RETURN HERE *)
+      END;
+    END;
+    out.MkNewProcInfo(prc);
+    out.InitHead(rec, prc);
+    IF prc # NIL THEN
+      spr := prc.basCll.sprCtor(Id.PrcId);
+      IF spr # NIL THEN
+        spT := spr.type(Ty.Procedure);
+        IF spT.xName = NIL THEN Mu.MkCallAttr(spr, out) END;
+        FOR idx := 0 TO prc.basCll.actuals.tide - 1 DO
+          frm := spT.formals.a[idx];
+          exp := prc.basCll.actuals.a[idx];
+          t.GetArgP(exp, frm);
+        END;
+      END;
+    END;
+    out.CallSuper(rec, spr);
+   (*
+    *    Initialize fields, as necessary.
+    *)
+    IF rec # NIL THEN
+      FOR idx := 0 TO rec.fields.tide-1 DO
+        fld := rec.fields.a[idx];
+        IF Mu.needsInit(fld.type) THEN
+          out.CommentT("Initialize embedded object");
+          out.Code(Asm.opc_ldarg_0);
+          out.StructInit(fld);
+        END;
+      END;
+    END;
+    IF (prc # NIL) & (prc.body # NIL) THEN
+      IF prc.rescue # NIL THEN out.Try END;
+      t.EmitStat(prc.body, lve);
+      IF lve THEN out.DoReturn END;
+      IF prc.rescue # NIL THEN
+        out.Catch(prc);
+        t.EmitStat(prc.rescue, lve);
+        IF lve THEN out.DoReturn END;
+        out.EndCatch;
+      END;
+    ELSE
+      out.Code(Asm.opc_ret);
+    END;
+    out.InitTail(rec);
+  END MakeInit;
+
+(* ============================================================ *)
+
+  PROCEDURE (t : MsilEmitter)CopyProc(recT : Ty.Record),NEW;
+    VAR out  : Mu.MsilFile;
+        indx : INTEGER;
+        fTyp : Sy.Type;
+        idnt : Id.FldId;
+  BEGIN
+   (*
+    *   Emit the copy procedure "__copy__()
+    *)
+    out := t.outF;
+    out.Blank();
+    out.MkNewProcInfo(t.mod);
+    out.CopyHead(recT);
+   (*
+    *    Recurse to super class, if necessary.
+    *)
+    IF (recT.baseTp # NIL) &
+       ~recT.baseTp.isNativeObj() THEN
+(*
+ *     (recT.baseTp IS Ty.Record) THEN
+ *)
+      out.Code(Asm.opc_ldarg_0);
+      out.Code(Asm.opc_ldarg_1);
+      t.RefRecCopy(recT.baseTp(Ty.Record));
+    END;
+   (*
+    *    Emit field-by-field copy.
+    *)
+    FOR indx := 0 TO recT.fields.tide-1 DO
+      idnt := recT.fields.a[indx](Id.FldId);
+      fTyp := idnt.type;
+      out.Code(Asm.opc_ldarg_0);
+      IF Mu.hasValueRep(fTyp) THEN
+        out.Code(Asm.opc_ldarg_1);
+        out.GetField(idnt);
+        out.PutField(idnt);
+      ELSE
+        out.GetField(idnt);
+        out.Code(Asm.opc_ldarg_1);
+        out.GetField(idnt);
+        WITH fTyp : Ty.Array DO
+            t.RefArrCopy(fTyp);
+        | fTyp : Ty.Record DO
+            t.RefRecCopy(fTyp);
+        END;
+      END;
+    END;
+    out.Code(Asm.opc_ret);
+    out.CopyTail;
+  END CopyProc;
+
+(* ============================================================ *)
+
+  PROCEDURE (this : MsilEmitter)
+      EmitMethod(out : Mu.MsilFile; method : Id.MthId),NEW;
+    VAR mthSet : SET;
+        attSet : SET;
+  BEGIN
+    mthSet := method.mthAtt * Id.mask;
+   (*
+    *  Get the extension bits:
+    *     {} == att_final ==> inextensible, ie. final AND virtual
+    *    {1} == att_isAbs ==> abstract AND virtual
+    *    {2} == att_empty ==> empty, and thus virtual
+    *  {1,2} == att_extns ==> extensible, thus virtual
+    *)
+    IF mthSet = {} THEN
+      IF Id.newBit IN method.mthAtt THEN
+        attSet :=  Asm.att_instance;
+      ELSE
+        attSet :=  Asm.att_final + Asm.att_virtual;
+      END;
+    ELSIF mthSet = Id.isAbs THEN
+      attSet := Asm.att_virtual + Asm.att_abstract;
+      IF Id.newBit IN method.mthAtt THEN
+          attSet := attSet + Asm.att_newslot END;
+    ELSE
+      attSet := Asm.att_virtual;
+      IF Id.newBit IN method.mthAtt THEN
+          attSet := attSet + Asm.att_newslot END;
+    END;
+    IF Id.widen IN method.mthAtt THEN attSet := attSet + Asm.att_public END;
+    this.EmitProc(method, attSet)
+  END EmitMethod;
+
+(* ============================================================ *)
+
+  PROCEDURE (this : MsilEmitter)
+                         EmitRecBody(out : Mu.MsilFile; typId : Id.TypId),NEW;
+  (** Create the assembler for a class file for this record. *)
+    VAR index  : INTEGER;
+        ident  : Sy.Idnt;
+        baseT  : Sy.Type;
+        field  : Id.FldId;
+        method : Id.MthId;
+        attSet : SET;
+        clsSet : SET;
+        mthSet : SET;
+        record : Ty.Record;
+        valRec : BOOLEAN;
+        mkInit : BOOLEAN;
+        mkCopy : BOOLEAN;
+        boxMth : Sy.IdSeq;
+
+  BEGIN
+    out.Blank();
+    record := typId.type.boundRecTp()(Ty.Record);
+    mkInit := Sy.clsTp IN record.xAttr;
+    mkCopy := ~(Sy.noCpy IN record.xAttr);
+    valRec := ~(Sy.clsTp IN record.xAttr);
+   (*
+    *   Account for the record attributes.
+    *)
+    CASE record.recAtt OF
+    | Ty.noAtt : attSet := Asm.att_sealed;
+    | Ty.isAbs : attSet := Asm.att_abstract;
+    | Ty.cmpnd : attSet := Asm.att_abstract;
+    | Ty.limit : attSet := Asm.att_empty;
+    | Ty.extns : attSet := Asm.att_empty;
+    | Ty.iFace : attSet := Asm.att_interface;
+     mkInit := FALSE;
+     mkCopy := FALSE;
+    END;
+   (*
+    *   Account for the identifier visibility.
+    *   It appears that the VOS only supports two kinds:
+    *   "public" == exported from this assembly
+    *   <empty>  == not exported from this assembly
+    *   Note that private is enforced by the name mangling
+    *   for types that are local to a procedure.
+    *)
+    IF typId.vMod = Sy.pubMode THEN
+      attSet := attSet + Asm.att_public;
+    END;
+    clsSet := attSet;
+    IF valRec THEN attSet := attSet + Asm.att_value END;
+    out.Comment("RECORD " + record.name()^);
+   (*
+    *   Emit header with optional super class attribute.
+    *)
+    out.ClassHead(attSet, record, record.superType());
+   (*
+    *  List the interfaces, if any.
+    *)
+    IF record.interfaces.tide > 0 THEN
+      out.MarkInterfaces(record.interfaces);
+    END;
+    out.OpenBrace(2);
+   (*
+    *  Emit all the fields ...
+    *)
+    FOR index := 0 TO record.fields.tide-1 DO
+      ident := record.fields.a[index];
+      field := ident(Id.FldId);
+      out.EmitField(field, fieldAttr(field, Asm.att_empty));
+    END;
+   (*
+    *  Emit any constructors.
+    *)
+    IF mkInit THEN this.MakeInit(record, NIL) END;
+    FOR index := 0 TO record.statics.tide-1 DO
+      ident  := record.statics.a[index];
+      this.MakeInit(record, ident(Id.PrcId));
+    END;
+    IF mkCopy THEN this.CopyProc(record) END;
+   (*
+    *  Emit all the (non-forward) methods ...
+    *)
+    FOR index := 0 TO record.methods.tide-1 DO
+      ident  := record.methods.a[index];
+      method := ident(Id.MthId);
+      IF (method.kind = Id.conMth) THEN
+        IF valRec & (method.rcvFrm.type IS Ty.Pointer) THEN
+          Sy.AppendIdnt(boxMth, method);
+        ELSE
+          this.EmitMethod(out, method);
+        END;
+      END;
+    END;
+    FOR index := 0 TO record.events.tide-1 DO
+      out.EmitEventMethods(record.events.a[index](Id.AbVar));
+    END;
+    out.CloseBrace(2);
+    out.ClassTail();
+    IF valRec THEN (* emit boxed class type *)
+      out.StartBoxClass(record, clsSet, this.mod);
+      FOR index := 0 TO boxMth.tide-1 DO
+        ident  := boxMth.a[index];
+        method := ident(Id.MthId);
+        this.EmitMethod(out, method);
+      END;
+      out.CloseBrace(2);
+      out.ClassTail();
+    END;
+  END EmitRecBody;
+
+(* ============================================================ *)
+
+  PROCEDURE (this : MsilEmitter)EmitModBody(out : Mu.MsilFile; 
+                                            mod : Id.BlkId),NEW;
+  (** Create the assembler for a class file for this module. *)
+    VAR index : INTEGER;
+        proc  : Id.Procs;
+        recT  : Sy.Type;
+        varId : Sy.Idnt;
+        cfLive : BOOLEAN; (* Control Flow is (still) live *)
+  BEGIN
+    out.MkBodyClass(mod);
+
+    out.OpenBrace(2);
+    FOR index := 0 TO this.mod.procs.tide-1 DO
+     (*
+      *  Create the mangled name for all procedures 
+      *  (including static and type-bound methods).
+      *)
+      proc := this.mod.procs.a[index];
+      Mu.MkProcName(proc, out);
+      Mu.RenumberLocals(proc, out);
+    END;
+   (*
+    *  Emit all of the static fields
+    *)
+    FOR index := 0 TO this.mod.locals.tide-1 DO
+      varId := this.mod.locals.a[index];
+      out.EmitField(varId(Id.VarId), fieldAttr(varId, Asm.att_static));
+    END;
+   (*
+    *  Emit all of the static event methods
+    *)
+    FOR index := 0 TO this.mod.locals.tide-1 DO
+      varId := this.mod.locals.a[index];
+      IF varId.type IS Ty.Event THEN out.EmitEventMethods(varId(Id.AbVar)) END;
+    END;
+   (*
+    *  No constructor for the module "class",
+    *  there are never any instances created.
+    *)
+    out.MkNewProcInfo(this.mod);
+    asmExe := this.mod.main;    (* Boolean flag for assembler *)
+    IF asmExe THEN
+     (*
+      *   Emit '<clinit>' with variable initialization
+      *)
+      out.Blank();
+      out.ClinitHead();
+      out.InitVars(this.mod);
+      out.Code(Asm.opc_ret);
+      out.ClinitTail();
+      out.Blank();
+     (*
+      *   Emit module body as 'CPmain()'
+      *)
+      out.MkNewProcInfo(this.mod);
+      out.MainHead(this.mod.xAttr);
+      this.EmitStat(this.mod.modBody, cfLive);
+      IF cfLive THEN
+        out.Comment("Continuing directly to CLOSE");
+        this.EmitStat(this.mod.modClose, cfLive);
+        (* Sequence point for the implicit RETURN *)
+        out.LineSpan(Scn.mkSpanT(this.mod.endTok));       
+        IF cfLive THEN out.Code(Asm.opc_ret) END;
+      END;
+      out.MainTail();
+    ELSE
+     (*
+      *   Emit single <clinit> incorporating module body
+      *)
+      out.ClinitHead();
+      out.InitVars(this.mod);
+      this.EmitStat(this.mod.modBody, cfLive);
+      IF cfLive THEN out.Code(Asm.opc_ret) END;
+      out.ClinitTail();
+    END;
+   (*
+    *  Emit all of the static procedures
+    *)
+    out.Blank();
+    FOR index := 0 TO this.mod.procs.tide-1 DO
+      proc := this.mod.procs.a[index];
+      IF (proc.kind = Id.conPrc) &
+         (proc.dfScp.kind = Id.modId) THEN this.EmitProc(proc, staticAtt) END;
+    END;
+   (*
+    *  And now, just in case exported types that
+    *  have class representation have been missed ...
+    *)
+    FOR index := 0 TO this.mod.expRecs.tide-1 DO
+      recT := this.mod.expRecs.a[index];
+      IF recT.xName = NIL THEN Mu.MkTypeName(recT, out) END;
+    END;
+    out.CloseBrace(2);
+    out.ClassTail();
+  END EmitModBody;
+
+(* ============================================================ *)
+(*  Mainline emitter, consumes worklist emitting assembler      *)
+(*  files until the worklist is empty.                          *)
+(* ============================================================ *)
+
+  PROCEDURE (this : MsilEmitter)MakeAbsName(),NEW;
+    VAR nPtr : POINTER TO ARRAY OF CHAR;
+        dPtr : POINTER TO ARRAY OF CHAR;
+  BEGIN
+    IF this.mod.main THEN 
+      nPtr := BOX(this.mod.pkgNm$ + ".EXE");
+    ELSE
+      nPtr := BOX(this.mod.pkgNm$ + ".DLL");
+    END;
+    IF CSt.binDir # "" THEN
+      dPtr := BOX(CSt.binDir$); 
+      IF dPtr[LEN(dPtr) - 2] = GPFiles.fileSep THEN
+        nPtr := BOX(dPtr^ + nPtr^);
+      ELSE
+        nPtr := BOX(dPtr^ + "\" + nPtr^);
+      END;
+    END;
+    CSt.outNam := nPtr;
+  END MakeAbsName;
+  
+  PROCEDURE (this : MsilEmitter)Emit*();
+  (** Create the file-state structure for this output
+      module: overrides EMPTY method in ClassMaker  *)
+    VAR out       : Mu.MsilFile; 
+        classIx   : INTEGER;
+        idDesc    : Sy.Idnt;
+        impElem   : Id.BlkId;
+        callApi   : BOOLEAN;
+  BEGIN
+(*
+ *  callApi := CSt.doCode & ~CSt.debug;
+ *)
+    callApi := CSt.doCode & ~CSt.doIlasm;
+    Mu.MkBlkName(this.mod);
+    IF callApi THEN
+      out := PeUtil.newPeFile(this.mod.pkgNm, ~this.mod.main);
+      this.outF := out;
+    ELSE (* just produce a textual IL file *)
+      out := IlasmUtil.newIlasmFile(this.mod.pkgNm);
+      this.outF := out;
+    END;
+
+    IF ~out.fileOk() THEN
+      Scn.SemError.Report(177, 0, 0);
+      Error.WriteString("Cannot create out-file <" + out.outN^ + ">");
+      Error.WriteLn;
+      RETURN;
+    END;
+    IF CSt.verbose THEN CSt.Message("Created "+ out.outN^) END;
+    out.Header(CSt.srcNam);
+    IF this.mod.main THEN out.Comment("This module implements CPmain") END;
+    out.Blank();
+(*
+ *  out.AsmDef(this.mod.pkgNm); (* Define this assembly  *)
+ *)
+    out.RefRTS();               (* Reference runtime asm *)
+    out.ExternList();           (* Reference import list *)
+    out.AsmDef(this.mod.pkgNm); (* Define this assembly  *)
+    out.Blank();
+    out.SubSys(this.mod.xAttr);
+
+    IF Sy.wMain IN this.mod.xAttr THEN
+      out.Comment("WinMain entry");
+    ELSIF Sy.cMain IN this.mod.xAttr THEN
+      out.Comment("CPmain entry");
+    END;
+
+    IF LEN(this.mod.xName$) # 0 THEN
+      out.StartNamespace(this.mod.xName);
+      out.OpenBrace(0);
+    ELSE
+      out.Comment("No Namespace");
+    END;
+    classIx := 0;
+   (*
+    *  Emit all classes on worklist until empty.
+    *)
+    WHILE classIx < this.work.tide DO
+      idDesc := this.work.a[classIx];
+      WITH idDesc : Id.BlkId DO
+          this.EmitModBody(out, idDesc);
+      | idDesc : Id.TypId DO
+          IF idDesc.type IS Ty.Procedure THEN
+            out.EmitPTypeBody(idDesc);
+          ELSE
+            this.EmitRecBody(out, idDesc);
+          END;
+      END;
+      INC(classIx);
+    END;
+    IF callApi THEN
+      out.Finish();
+      IF ~CSt.quiet THEN CSt.Message("Emitted "+ out.outN^) END;
+    ELSE (* just produce a textual IL file *)
+      out.Blank();
+      IF LEN(this.mod.xName$) # 0 THEN
+        out.CloseBrace(0);
+        out.Comment("end namespace " + this.mod.xName^);
+      END;
+      out.Comment("end output produced by gpcp");
+      out.Finish();
+     (*
+      *   Store the filename for the assembler.
+      *)
+      asmName := this.mod.pkgNm;
+    END;
+    (* Set the output name for MSBuild *)
+    this.MakeAbsName();
+  END Emit;
+
+(* ============================================================ *)
+(*    Shared code-emission methods      *)
+(* ============================================================ *)
+
+  PROCEDURE (e : MsilEmitter)EmitProc(proc : Id.Procs; attr : SET),NEW;
+    VAR out  : Mu.MsilFile;
+        live : BOOLEAN;
+        retn : Sy.Type;
+        indx : INTEGER;
+        nest : Id.Procs;
+  BEGIN
+   (*
+    *   Recursively emit nested procedures first.
+    *)
+    FOR indx := 0 TO proc.nestPs.tide-1 DO
+      nest := proc.nestPs.a[indx];
+      IF nest.kind = Id.conPrc THEN e.EmitProc(nest, staticAtt) END;
+    END;
+    out := e.outF;
+    out.MkNewProcInfo(proc);
+    out.Blank();
+    out.Comment("PROCEDURE " + proc.prcNm^);
+   (*
+    *  Compute the method attributes
+    *)
+    IF proc.vMod = Sy.pubMode THEN (* explicitly public *)
+      attr := attr + Asm.att_public;
+    ELSIF proc.dfScp IS Id.Procs THEN (* nested procedure  *)
+      attr := attr + Asm.att_private;
+    ELSIF Asm.att_public * attr = {} THEN 
+     (* 
+      *  method visiblibity could have been widened 
+      *  to match the demanded semantics of the CLR.
+      *)
+      attr := attr + Asm.att_assembly;
+    END;
+    out.MethodDecl(attr, proc);
+   (*
+    *  Output the body if not ABSTRACT
+    *)
+    IF attr * Asm.att_abstract = {} THEN
+      out.OpenBrace(4);
+      out.LineSpan(Scn.mkSpanT(proc.token));
+      out.Code(Asm.opc_nop);
+     (*
+      *  Initialize any locals which need this.
+      *)
+      out.InitVars(proc);
+      IF proc.rescue # NIL THEN out.Try END;
+     (*
+      *  Finally! Emit the method body.
+      *)
+      e.EmitStat(proc.body, live);
+     (*
+      *  For proper procedure which reach the fall-
+      *  through ending just return.
+      *)
+      IF live & proc.type.isProperProcType() THEN
+        out.LineSpan(proc.endSpan);
+        out.DoReturn;
+      END;
+      IF proc.rescue # NIL THEN
+        out.Catch(proc);
+        e.EmitStat(proc.rescue, live);
+        IF live & proc.type.isProperProcType() THEN
+          out.LineSpan(proc.endSpan);
+          out.DoReturn;
+        END;
+        out.EndCatch;
+      END;
+      out.MethodTail(proc);
+    END;
+  END EmitProc;
+
+(* ============================================================ *)
+(*        Expression Handling Methods     *)
+(* ============================================================ *)
+
+  PROCEDURE longValue(lit : Sy.Expr) : LONGINT;
+  BEGIN
+    RETURN lit(Xp.LeafX).value.long();
+  END longValue;
+
+  PROCEDURE intValue(lit : Sy.Expr) : INTEGER;
+  BEGIN
+    RETURN lit(Xp.LeafX).value.int();
+  END intValue;
+
+  PROCEDURE isStrExp(exp : Sy.Expr) : BOOLEAN;
+  BEGIN
+    RETURN (exp.type = Bi.strTp) & 
+           (exp.kind # Xp.mkStr) OR 
+            exp.type.isNativeStr();
+  END isStrExp;
+
+  PROCEDURE isNilExp(exp : Sy.Expr) : BOOLEAN;
+  BEGIN
+    RETURN exp.kind = Xp.nilLt;
+  END isNilExp;
+
+(* ============================================================ *)
+
+  PROCEDURE (e : MsilEmitter)PushSetCmp(lOp,rOp : Sy.Expr;
+                                        theTest : INTEGER),NEW;
+    VAR out  : Mu.MsilFile;
+        l,r  : INTEGER;
+  BEGIN
+    out  := e.outF;
+    e.PushValue(lOp, Bi.setTp);
+    CASE theTest OF
+    (* ---------------------------------- *)
+    | Xp.equal, Xp.notEq : 
+        e.PushValue(rOp, Bi.setTp);
+        out.Code(Asm.opc_ceq);
+        IF theTest = Xp.notEq THEN
+          out.Code(Asm.opc_ldc_i4_1);
+          out.Code(Asm.opc_xor);
+        END;
+    (* ---------------------------------- *)
+    | Xp.greEq, Xp.lessEq : 
+       (*
+        *   The semantics are implemented by the identities
+        *
+        *   (L <= R) == (L AND R = L)
+        *   (L >= R) == (L OR  R = L)
+        *)
+        out.Code(Asm.opc_dup);
+        e.PushValue(rOp, Bi.setTp);
+        IF theTest = Xp.greEq THEN
+          out.Code(Asm.opc_or);
+        ELSE
+          out.Code(Asm.opc_and);
+        END;
+        out.Code(Asm.opc_ceq);
+    (* ---------------------------------- *)
+    | Xp.greT, Xp.lessT : 
+        l := out.proc.newLocal(Bi.setTp);
+        r := out.proc.newLocal(Bi.setTp);
+       (*
+        *   The semantics are implemented by the identities
+        *
+        *   (L < R) == (L AND R = L) AND NOT (L = R)
+        *   (L > R) == (L OR  R = L) AND NOT (L = R)
+        *)
+        out.Code(Asm.opc_dup);            (* ... L,L       *)
+        out.Code(Asm.opc_dup);            (* ... L,L,L     *)
+        out.StoreLocal(l);                (* ... L,L,      *)
+        e.PushValue(rOp, Bi.setTp);       (* ... L,L,R     *)
+        out.Code(Asm.opc_dup);            (* ... L,L,R,R   *)
+        out.StoreLocal(r);                (* ... L,L,R     *)
+        IF theTest = Xp.greT THEN        
+          out.Code(Asm.opc_or);           (* ... L,LvR     *)
+        ELSE
+          out.Code(Asm.opc_and);          (* ... L,L^R     *)
+        END; 
+        out.Code(Asm.opc_ceq);            (* ... L@R       *)
+        out.PushLocal(l);                 (* ... L@R,l     *)
+        out.PushLocal(r);                 (* ... L@R,l,r   *)
+        out.Code(Asm.opc_ceq);            (* ... L@R,l=r   *)
+        out.Code(Asm.opc_ldc_i4_1);       (* ... L@R,l=r,1 *)
+        out.Code(Asm.opc_xor);            (* ... L@R,l#r   *)
+        out.Code(Asm.opc_and);            (* ... result    *)
+        out.proc.ReleaseLocal(r);
+        out.proc.ReleaseLocal(l);
+    END;
+  END PushSetCmp;
+
+(* ---------------------------------------------------- *)
+
+  PROCEDURE (e : MsilEmitter)DoCmp(cmpE : INTEGER;
+                                   tLab : Mu.Label;
+                                   type : Sy.Type),NEW;
+   (**  Compare two TOS elems and jump to tLab if true. *)
+   (* ------------------------------------------------- *)
+    VAR out  : Mu.MsilFile;
+   (* ------------------------------------------------- *)
+    PROCEDURE test(t : INTEGER; r : BOOLEAN) : INTEGER;
+    BEGIN
+      CASE t OF
+      | Xp.equal  : RETURN Asm.opc_beq;
+      | Xp.notEq  : RETURN Asm.opc_bne_un;
+      | Xp.greT   : RETURN Asm.opc_bgt;
+      | Xp.lessT  : RETURN Asm.opc_blt;
+      | Xp.greEq  : IF r THEN RETURN Asm.opc_bge_un ELSE RETURN Asm.opc_bge END;
+      | Xp.lessEq : IF r THEN RETURN Asm.opc_ble_un ELSE RETURN Asm.opc_ble END;
+      END;
+    END test;
+   (* ------------------------------------------------- *)
+  BEGIN
+    out  := e.outF;
+    IF (type IS Ty.Base) &
+       ((type = Bi.strTp) OR (type = Bi.sStrTp)) OR
+       ~(type IS Ty.Base) & type.isCharArrayType() THEN
+     (*
+      *  For strings and character arrays, we simply
+      *  call the compare function, then compare the
+      *  result with zero. Instructions are polymorphic.
+      *)
+      out.StaticCall(Mu.aaStrCmp, -1);
+     (*
+      *   function will have returned ...
+      *   lessT : -1, equal : 0, greT : 1;
+      *)
+      IF cmpE = Xp.equal THEN
+        out.CodeLb(Asm.opc_brfalse, tLab);
+      ELSIF cmpE = Xp.notEq THEN
+        out.CodeLb(Asm.opc_brtrue, tLab);
+      ELSE
+        out.PushInt(0);
+        out.CodeLb(test(cmpE, FALSE), tLab);
+      END;
+    ELSE
+      out.CodeLb(test(cmpE, type.isRealType()), tLab);
+    END;
+  END DoCmp;
+
+(* ---------------------------------------------------- *)
+
+  PROCEDURE (e : MsilEmitter)BinCmp(exp : Xp.BinaryX;
+                                    tst : INTEGER;
+                                    rev : BOOLEAN;
+                                    lab : Mu.Label),NEW;
+    VAR lType : Sy.Type;
+  BEGIN
+    lType := exp.lKid.type;
+    IF lType = Bi.setTp THEN (* partially ordered type *)
+      e.PushSetCmp(exp.lKid, exp.rKid, tst);
+      IF rev THEN
+        e.outF.CodeLb(Asm.opc_brfalse, lab); 
+      ELSE
+        e.outF.CodeLb(Asm.opc_brtrue, lab); 
+      END;
+    ELSE  (* totally ordered type *)
+      e.PushValue(exp.lKid, lType);
+      IF isStrExp(exp.lKid) & ~isNilExp(exp.rKid) THEN
+       (*
+        *  If this is a string, convert to a character array.
+        *)
+        e.outF.StaticCall(Mu.vStr2ChO, 0);
+        lType := Bi.chrArr;
+      END;
+
+      e.PushValue(exp.rKid, exp.rKid.type);
+      IF isStrExp(exp.rKid) & ~isNilExp(exp.lKid) THEN
+       (*
+        *  If this is a string, convert to a character array.
+        *)
+        e.outF.StaticCall(Mu.vStr2ChO, 0);
+      END;
+      IF rev THEN
+        CASE tst OF
+        | Xp.equal  : tst := Xp.notEq;
+        | Xp.notEq  : tst := Xp.equal;
+        | Xp.greT   : tst := Xp.lessEq;
+        | Xp.lessT  : tst := Xp.greEq;
+        | Xp.greEq  : tst := Xp.lessT;
+        | Xp.lessEq : tst := Xp.greT;
+        END;
+      END;
+      e.DoCmp(tst, lab, lType);
+    END;
+  END BinCmp;
+
+(* ---------------------------------------------------- *)
+
+  PROCEDURE (e : MsilEmitter)PushCmpBool(lOp,rOp : Sy.Expr; tst : INTEGER),NEW;
+    VAR lType : Sy.Type;
+  (* ------------------------------------- *)
+    PROCEDURE test(t : INTEGER; r : BOOLEAN) : INTEGER;
+    BEGIN
+      CASE t OF
+      | Xp.equal  : RETURN Asm.opc_ceq;
+      | Xp.notEq  : RETURN Asm.opc_ceq;
+      | Xp.lessT  : RETURN Asm.opc_clt;
+      | Xp.greT   : RETURN Asm.opc_cgt;
+      | Xp.lessEq : IF r THEN RETURN Asm.opc_cgt_un ELSE RETURN Asm.opc_cgt END;
+      | Xp.greEq  : IF r THEN RETURN Asm.opc_clt_un ELSE RETURN Asm.opc_clt END;
+      END;
+    END test;
+  (* ------------------------------------- *)
+    PROCEDURE MkBool(tst : INTEGER; typ : Sy.Type; out : Mu.MsilFile);
+    BEGIN
+      IF (typ IS Ty.Base) &
+         ((typ = Bi.strTp) OR (typ = Bi.sStrTp)) OR
+         ~(typ IS Ty.Base) & typ.isCharArrayType() THEN
+        out.StaticCall(Mu.aaStrCmp, -1);
+        (*
+         *   function will have returned ...
+         *   lessT : -1, equal : 0, greT : 1;
+         *)
+        out.Code(Asm.opc_ldc_i4_0);
+      END;
+      out.Code(test(tst, typ.isRealType()));
+      IF (tst = Xp.lessEq) OR (tst = Xp.greEq) OR (tst = Xp.notEq) THEN
+        out.Code(Asm.opc_ldc_i4_1);
+        out.Code(Asm.opc_xor);
+      END;
+    END MkBool;
+  (* ------------------------------------- *)
+  BEGIN
+    IF lOp.isSetExpr() THEN e.PushSetCmp(lOp, rOp, tst); RETURN END;
+
+    lType := lOp.type;
+    e.PushValue(lOp, lOp.type);
+    IF isStrExp(lOp) & ~isNilExp(rOp) THEN
+     (*
+      *  If this is a string, convert to a character array.
+      *)
+      e.outF.StaticCall(Mu.vStr2ChO, 0);
+      lType := Bi.chrArr;
+    END;
+
+    e.PushValue(rOp, rOp.type);
+    IF isStrExp(rOp) & ~isNilExp(lOp) THEN
+     (*
+      *  If this is a string, convert to a character array.
+      *)
+      e.outF.StaticCall(Mu.vStr2ChO, 0);
+    END;
+
+    MkBool(tst, lType, e.outF);
+  END PushCmpBool;
+
+(* ---------------------------------------------------- *)
+(* ---------------------------------------------------- *)
+
+  PROCEDURE (e : MsilEmitter)FallTrue(exp : Sy.Expr; fLb : Mu.Label),NEW;
+   (** Evaluate exp, fall through if true, jump to fLab otherwise *)
+    VAR binOp : Xp.BinaryX;
+        label : Mu.Label;
+        out   : Mu.MsilFile;
+  BEGIN
+    out := e.outF;
+    CASE exp.kind OF
+    | Xp.tBool :        (* just do nothing *)
+    | Xp.fBool :
+        out.CodeLb(Asm.opc_br, fLb);
+    | Xp.blNot :
+        e.FallFalse(exp(Xp.UnaryX).kid, fLb);
+    | Xp.greT, Xp.greEq, Xp.notEq, Xp.lessEq, Xp.lessT, Xp.equal :
+        e.BinCmp(exp(Xp.BinaryX), exp.kind, TRUE, fLb);
+    | Xp.blOr :
+        binOp := exp(Xp.BinaryX);
+        label := out.newLabel();
+        e.FallFalse(binOp.lKid, label);
+        e.FallTrue(binOp.rKid, fLb);
+        out.DefLab(label);
+    | Xp.blAnd :
+        binOp := exp(Xp.BinaryX);
+        e.FallTrue(binOp.lKid, fLb);
+        e.FallTrue(binOp.rKid, fLb);
+    | Xp.isOp :
+        binOp := exp(Xp.BinaryX);
+        e.PushValue(binOp.lKid, binOp.lKid.type);
+        out.CodeT(Asm.opc_isinst, binOp.rKid(Xp.IdLeaf).ident.type);
+        (* if NIL then FALSE... *)
+        out.CodeLb(Asm.opc_brfalse, fLb);
+    | Xp.inOp :
+        binOp := exp(Xp.BinaryX);
+        out.Code(Asm.opc_ldc_i4_1);
+        e.PushValue(binOp.lKid, binOp.lKid.type);
+        out.Code(Asm.opc_shl);
+        out.Code(Asm.opc_dup);
+        e.PushValue(binOp.rKid, binOp.rKid.type);
+        out.Code(Asm.opc_and);
+        out.CodeLb(Asm.opc_bne_un, fLb);
+    ELSE (* Xp.fnCll, Xp.qualId, Xp.index, Xp.selct  *)
+      e.PushValue(exp, exp.type);   (* boolean variable *)
+      out.CodeLb(Asm.opc_brfalse, fLb);
+    END;
+  END FallTrue;
+
+(* ---------------------------------------------------- *)
+
+  PROCEDURE (e : MsilEmitter)FallFalse(exp : Sy.Expr; tLb : Mu.Label),NEW;
+   (** Evaluate exp, fall through if false, jump to tLb otherwise *)
+    VAR binOp : Xp.BinaryX;
+        label : Mu.Label;
+        out   : Mu.MsilFile;
+  BEGIN
+    out := e.outF;
+    CASE exp.kind OF
+    | Xp.fBool :        (* just do nothing *)
+    | Xp.tBool :
+        out.CodeLb(Asm.opc_br, tLb);
+    | Xp.blNot :
+        e.FallTrue(exp(Xp.UnaryX).kid, tLb);
+    | Xp.greT, Xp.greEq, Xp.notEq, Xp.lessEq, Xp.lessT, Xp.equal :
+        e.BinCmp(exp(Xp.BinaryX), exp.kind, FALSE, tLb);
+    | Xp.blOr :
+        binOp := exp(Xp.BinaryX);
+        e.FallFalse(binOp.lKid, tLb);
+        e.FallFalse(binOp.rKid, tLb);
+    | Xp.blAnd :
+        label := out.newLabel();
+        binOp := exp(Xp.BinaryX);
+        e.FallTrue(binOp.lKid, label);
+        e.FallFalse(binOp.rKid, tLb);
+        out.DefLab(label);
+    | Xp.isOp :
+        binOp := exp(Xp.BinaryX);
+        e.PushValue(binOp.lKid, binOp.lKid.type);
+        out.CodeT(Asm.opc_isinst, binOp.rKid(Xp.IdLeaf).ident.type);
+        (* if non-NIL then TRUE... *)
+        out.CodeLb(Asm.opc_brtrue, tLb);
+    | Xp.inOp :
+        binOp := exp(Xp.BinaryX);
+        out.Code(Asm.opc_ldc_i4_1);
+        e.PushValue(binOp.lKid, binOp.lKid.type);
+        out.Code(Asm.opc_shl);
+        out.Code(Asm.opc_dup);
+        e.PushValue(binOp.rKid, binOp.rKid.type);
+        out.Code(Asm.opc_and);
+        out.CodeLb(Asm.opc_beq, tLb);
+    ELSE (* Xp.fnCll, Xp.qualId, Xp.index, Xp.selct  *)
+      e.PushValue(exp, exp.type);   (* boolean variable *)
+      out.CodeLb(Asm.opc_brtrue, tLb);
+    END;
+  END FallFalse;
+
+(* ============================================================ *)
+
+  PROCEDURE (e : MsilEmitter)PushUnary(exp : Xp.UnaryX; dst : Sy.Type),NEW;
+    VAR dNum : INTEGER;
+        code : INTEGER;
+        labl : Mu.Label;
+        out  : Mu.MsilFile;
+        ovfl : BOOLEAN;
+  (* ------------------------------------- *)
+    PROCEDURE MkBox(emt : MsilEmitter; exp : Xp.UnaryX);
+      VAR dst : Sy.Type;
+          src : Sy.Type;
+          out : Mu.MsilFile;
+          rcT : Ty.Record;
+    BEGIN
+      out := emt.outF;
+      src := exp.kid.type;
+      dst := exp.type(Ty.Pointer).boundTp;
+      IF isStrExp(exp.kid) THEN
+        emt.PushValue(exp.kid, src);
+        out.StaticCall(Mu.vStr2ChO, 0);
+      ELSIF exp.kid.kind = Xp.mkStr THEN
+        emt.ValueCopy(exp.kid, dst);
+      ELSIF Mu.isRefSurrogate(src) THEN
+        emt.ValueCopy(exp.kid, dst);
+      ELSE 
+        rcT := src(Ty.Record);
+       (*
+        *  We want to know if this is a
+        *  foreign value type.  If so it
+        *  must be boxed, since there is 
+        *  no CP-defined Boxed_Rec type.
+        *)
+        IF Sy.isFn IN rcT.xAttr THEN
+          emt.PushValue(exp.kid, src);
+          out.CodeT(Asm.opc_box, src);
+        ELSE (* normal case *)
+          out.MkNewRecord(rcT); 
+          out.Code(Asm.opc_dup);     
+          out.GetValA(exp.type(Ty.Pointer));
+          emt.PushValue(exp.kid, src);
+          out.CodeT(Asm.opc_stobj, dst);
+        END;
+      END;
+    END MkBox;
+  (* ------------------------------------- *)
+    PROCEDURE MkAdr(emt : MsilEmitter; exp : Sy.Expr);
+    BEGIN
+      IF Mu.isRefSurrogate(exp.type) THEN
+        emt.PushValue(exp, exp.type); 
+      ELSE
+        emt.PushRef(exp, exp.type); 
+      END;
+      emt.outF.Code(Asm.opc_conv_i4);
+    END MkAdr;
+  (* ------------------------------------- *)
+  BEGIN
+   (* Eliminte special cases first *)
+    IF exp.kind = Xp.mkBox THEN MkBox(e,exp); RETURN END; (* PRE-EMPTIVE RET *)
+    IF exp.kind = Xp.adrOf THEN MkAdr(e,exp.kid); RETURN END; (* PRE-EMPTIVE *)
+   (* Now do the mainstream cases  *)
+    e.PushValue(exp.kid, exp.kid.type);
+    out := e.outF;
+    ovfl := out.proc.prId.ovfChk;
+    CASE exp.kind OF
+    | Xp.mkStr  : (* skip *)
+    | Xp.deref  :
+        IF Mu.isValRecord(dst) THEN    (* unbox field 'v$' *)
+          out.GetVal(exp.kid.type(Ty.Pointer));
+        END;
+    | Xp.tCheck :
+        IF Mu.isValRecord(exp.type) THEN
+          out.CodeT(Asm.opc_unbox, exp.type.boundRecTp()(Ty.Record));
+          out.CodeT(Asm.opc_ldobj, exp.type.boundRecTp()(Ty.Record));
+        ELSE
+          out.CodeT(Asm.opc_castclass, exp.type);
+        END;
+(*
+ *      out.CodeT(Asm.opc_castclass, exp.type.boundRecTp()(Ty.Record));
+ *)
+    | Xp.mkNStr :
+	IF ~isStrExp(exp.kid) THEN out.StaticCall(Mu.chs2Str, 0) END;
+    | Xp.strChk :
+        out.Code(Asm.opc_dup);
+        out.StaticCall(Mu.aStrChk, -1);  (* Do some range checks *)
+    | Xp.compl :
+        out.Code(Asm.opc_ldc_i4_M1);
+        out.Code(Asm.opc_xor);
+    | Xp.neg :
+        out.Code(Asm.opc_neg);
+    | Xp.absVl :
+        dNum := dst(Ty.Base).tpOrd;
+        IF ~ovfl THEN
+         (*
+          *  This is the code to use for non-trapping cases
+          *)
+          out.Code(Asm.opc_dup);
+          out.Code(Asm.opc_ldc_i4_0);
+          IF    dNum = Ty.realN THEN
+            out.Code(Asm.opc_conv_r8);
+          ELSIF dNum = Ty.sReaN THEN
+            out.Code(Asm.opc_conv_r4);
+          ELSIF dNum = Ty.lIntN THEN
+            out.Code(Asm.opc_conv_i8);
+          (* ELSE do nothing for all INTEGER cases *)
+          END;
+          labl := out.newLabel();
+          out.CodeLb(Asm.opc_bge, labl);
+          out.Code(Asm.opc_neg);
+          out.DefLab(labl);
+        ELSE
+         (*
+          *  The following is the safe but slow code.
+          *)
+          IF    dNum = Ty.realN THEN
+            out.StaticCall(Mu.dAbs, 0);
+          ELSIF dNum = Ty.sReaN THEN
+            out.StaticCall(Mu.fAbs, 0);
+          ELSIF dNum = Ty.lIntN THEN
+            out.StaticCall(Mu.lAbs, 0);
+          ELSE
+            out.StaticCall(Mu.iAbs, 0);
+          END;
+        END;
+    | Xp.entVl :
+        dNum := dst(Ty.Base).tpOrd;
+        IF dNum = Ty.sReaN THEN out.Code(Asm.opc_conv_r8) END;
+        (*
+        // We _could_ check if the value is >= 0.0, and
+        // skip the call in that case, falling through
+        // into the round-to-zero mode opc_d2l.
+        *)
+        out.StaticCall(Mu.dFloor, 0);
+        IF ~ovfl THEN
+          out.Code(Asm.opc_conv_i8);
+        ELSE
+          out.Code(Asm.opc_conv_ovf_i8);
+        END;
+    | Xp.capCh :
+        out.StaticCall(Mu.toUpper, 0);
+    | Xp.blNot :
+        out.Code(Asm.opc_ldc_i4_1);
+        out.Code(Asm.opc_xor);
+    | Xp.strLen :
+        out.StaticCall(Mu.aStrLen, 0);
+    | Xp.oddTst :
+        IF exp.kid.type.isLongType() THEN out.Code(Asm.opc_conv_i4) END;
+        out.Code(Asm.opc_ldc_i4_1);
+        out.Code(Asm.opc_and);
+    | Xp.getTp :
+(*
+ *    Currently value records cannot arise here, since all TYPEOF()
+ *    calls are folded to their statically known type by ExprDesc.
+ *    If ever this changes, the following code is needed (and has
+ *    been checked against a non-folding version of ExprDesc.
+ * 
+ *      IF Mu.isValRecord(exp.kid.type) THEN        (* box the value... *)
+ *        out.CodeT(Asm.opc_box, exp.kid.type);     (* CodeTn works too *)
+ *      END;
+ *)
+        out.StaticCall(Mu.getTpM, 0);
+    END;
+  END PushUnary;
+
+(* ============================================================ *)
+
+  PROCEDURE (e : MsilEmitter)
+      PushBinary(exp : Xp.BinaryX; dst : Sy.Type),NEW;
+    VAR out  : Mu.MsilFile;
+        lOp  : Sy.Expr;
+        rOp  : Sy.Expr;
+        dNum : INTEGER;
+        sNum : INTEGER;
+        code : INTEGER;
+        indx : INTEGER;
+        rLit : LONGINT;
+        long : BOOLEAN;
+        rasd : BOOLEAN;  (* Element type is erased *)
+        temp : INTEGER;
+        ovfl : BOOLEAN;
+        exLb : Mu.Label;
+        tpLb : Mu.Label;
+        rpTp : Sy.Type;
+        elTp : Sy.Type;
+  BEGIN
+    out := e.outF;
+    lOp := exp.lKid;
+    rOp := exp.rKid;
+    ovfl := out.proc.prId.ovfChk & dst.isIntType();
+    CASE exp.kind OF
+    (* -------------------------------- *)
+    | Xp.index :
+        rasd := exp(Xp.BinaryX).lKid.type IS Ty.Vector;
+        IF rasd THEN
+          rpTp := Mu.vecRepElTp(exp.lKid.type(Ty.Vector));
+        ELSE
+          (* rpTp := dst; *)
+          rpTp := lOp.type(Ty.Array).elemTp;
+        END;
+        e.PushHandle(exp, rpTp);
+        out.GetElem(rpTp);     (* load the element *)
+        IF rasd & (dst # rpTp) THEN
+          IF Mu.isValRecord(dst) THEN 
+            out.CodeT(Asm.opc_unbox, dst);
+            out.CodeT(Asm.opc_ldobj, dst);
+          ELSIF rpTp = Bi.anyPtr THEN
+            out.CodeT(Asm.opc_castclass, dst);
+          ELSE
+            out.ConvertDn(rpTp, dst);
+          END;
+        END;
+       (*
+        * previous code ---
+        *
+        *   e.PushHandle(exp, dst);
+        *   out.GetElem(dst);     (* load the element *)
+        *)
+    (* -------------------------------- *)
+    | Xp.range :        (* set i..j range ... *)
+       (* We want to create an integer with bits--  *)
+       (*      [0...01...10...0]      *)
+       (* MSB==31    j   i    0==LSB      *)
+       (* One method is A       *)
+       (* 1)   [0..010........0]  1 << (j+1)    *)
+       (* 2)   [1..110........0]  negate(1)   *)
+       (* 3)   [0.......010...0]  1 << i    *)
+       (* 4)   [1.......110...0]  negate(3)   *)
+       (* 5)   [0...01...10...0]  (2)xor(4)   *)
+       (* Another method is B       *)
+       (* 1)   [1.............1]  -1      *)
+       (* 2)   [0...01........1]  (1) >>> (31-j)  *)
+       (* 3)   [0........01...1]  (2) >> i    *)
+       (* 4)   [0...01...10...0]  (3) << i    *)
+       (* --------------------------------------------- *
+        *      (*         *
+        * * Method A        *
+        * *)          *
+        * out.Code(Asm.opc_ldc_i4_1);   *
+        * out.Code(Asm.opc_ldc_i4_1);   *
+        * e.PushValue(rOp, Bi.intTp);    *
+        *      (* Do unsigned less than 32 test here *) *
+        * out.Code(Asm.opc_add);      *
+        * out.Code(Asm.opc_shl);      *
+        * out.Code(Asm.opc_neg);      *
+        * out.Code(Asm.opc_ldc_i4_1);   *
+        * e.PushValue(lOp, Bi.intTp);    *
+        *      (* Do unsigned less than 32 test here *) *
+        * out.Code(Asm.opc_shl);      *
+        * out.Code(Asm.opc_neg);      *
+        * out.Code(Asm.opc_xor);      *
+        * -------------------------------------------- *)
+       (*
+        * Method B
+        *)
+        IF rOp.kind = Xp.numLt THEN
+          indx := intValue(rOp);
+          IF indx = 31 THEN
+            out.Code(Asm.opc_ldc_i4_M1);
+          ELSE
+            temp := ORD({0 .. indx});
+            out.PushInt(temp);
+          END;
+        ELSE
+          out.Code(Asm.opc_ldc_i4_M1);
+          out.PushInt(31);
+          e.PushValue(rOp, Bi.intTp);
+         (* Do unsigned less than 32 test here ...*)
+          out.Code(Asm.opc_sub);
+          out.Code(Asm.opc_shr_un);
+        END;
+        IF lOp.kind = Xp.numLt THEN
+          indx := intValue(lOp);
+          IF indx > 0 THEN
+            temp := ORD({indx .. 31});
+            out.PushInt(temp);
+            out.Code(Asm.opc_and);
+          END;
+        ELSE
+          e.PushValue(lOp, Bi.intTp);
+         (* Do unsigned less than 32 test here ...*)
+          out.Code(Asm.opc_dup);
+          temp := out.proc.newLocal(Bi.intTp);
+          out.StoreLocal(temp);
+          out.Code(Asm.opc_shr);
+          out.PushLocal(temp);
+          out.Code(Asm.opc_shl);
+          out.proc.ReleaseLocal(temp);
+        END;
+    (* -------------------------------- *)
+    | Xp.lenOf :
+        e.PushValue(lOp, lOp.type);
+        (* conventional arrays here *)
+        IF lOp.type IS Ty.Vector THEN
+          out.GetField(Mu.vecLeng(out));
+        ELSE
+          FOR indx := 0 TO intValue(rOp) - 1 DO
+            out.Code(Asm.opc_ldc_i4_0);
+            out.Code(Asm.opc_ldelem_ref);
+          END;
+          out.Code(Asm.opc_ldlen);
+        END;
+    (* -------------------------------- *)
+    | Xp.maxOf, Xp.minOf :
+        tpLb := out.newLabel();
+        exLb := out.newLabel();
+       (*
+        * Push left operand, duplicate
+        * stack is (top) lOp lOp...
+        *)
+        e.PushValue(lOp, dst);
+        out.Code(Asm.opc_dup);
+       (*
+        * Push right operand, duplicate
+        * stack is (top) rOp rOp lOp lOp ...
+        *)
+        e.PushValue(rOp, dst);
+        out.Code(Asm.opc_dup);
+       (*
+        * Store rOp to temp
+        * stack is (top) rOp lOp lOp ...
+        *)
+        temp := out.proc.newLocal(dst);
+        out.StoreLocal(temp);
+       (*
+        *  Compare two top items and jump
+        *  stack is (top) lOp ...
+        *)
+        IF exp.kind = Xp.maxOf THEN
+          e.DoCmp(Xp.greT, exLb, dst);    (* leaving lOp on stack *)
+        ELSE
+          e.DoCmp(Xp.lessT, exLb, dst);   (* leaving lOp on stack *)
+        END;
+       (*
+        *  Else: discard top item
+        *  and push stored rOp instead
+        *)
+        out.Code(Asm.opc_pop);
+        out.PushLocal(temp);
+        out.DefLab(exLb);
+        out.proc.ReleaseLocal(temp);
+    (* -------------------------------- *)
+    | Xp.bitAnd :
+        e.PushValue(lOp, dst);
+        e.PushValue(rOp, dst);
+        out.Code(Asm.opc_and);
+    (* -------------------------------- *)
+    | Xp.bitOr :
+        e.PushValue(lOp, dst);
+        e.PushValue(rOp, dst);
+        out.Code(Asm.opc_or);
+    (* -------------------------------- *)
+    | Xp.bitXor :
+        e.PushValue(lOp, dst);
+        e.PushValue(rOp, dst);
+        out.Code(Asm.opc_xor);
+    (* -------------------------------- *)
+    | Xp.plus :
+        e.PushValue(lOp, dst);
+        e.PushValue(rOp, dst);
+        IF ovfl THEN out.Code(Asm.opc_add_ovf) ELSE out.Code(Asm.opc_add) END;
+    (* -------------------------------- *)
+    | Xp.minus :
+        e.PushValue(lOp, dst);
+        e.PushValue(rOp, dst);
+        IF ovfl THEN out.Code(Asm.opc_sub_ovf) ELSE out.Code(Asm.opc_sub) END;
+    (* -------------------------------- *)
+    | Xp.mult :
+        e.PushValue(lOp, dst);
+        e.PushValue(rOp, dst);
+        IF ovfl THEN out.Code(Asm.opc_mul_ovf) ELSE out.Code(Asm.opc_mul) END;
+    (* -------------------------------- *)
+    | Xp.slash :
+        e.PushValue(lOp, dst);
+        e.PushValue(rOp, dst);
+        out.Code(Asm.opc_div);
+    (* -------------------------------- *)
+    | Xp.rem0op :
+        dNum := dst(Ty.Base).tpOrd;
+        e.PushValue(lOp, dst);
+        e.PushValue(rOp, dst);
+        out.Code(Asm.opc_rem);
+    (* -------------------------------- *)
+    | Xp.modOp :
+        long := dst(Ty.Base).tpOrd = Ty.lIntN;
+        e.PushValue(lOp, dst);
+        e.PushValue(rOp, dst);
+        IF (rOp.kind = Xp.numLt) & (intValue(rOp) > 0) THEN
+          indx := intValue(rOp);
+          tpLb := out.newLabel();
+          out.Code(Asm.opc_rem);
+          out.Code(Asm.opc_dup);
+          IF long THEN out.PushLong(0) ELSE out.PushInt(0) END;
+          out.CodeLb(Asm.opc_bge, tpLb);
+          IF long THEN out.PushLong(indx) ELSE out.PushInt(indx) END;
+          out.Code(Asm.opc_add);
+          out.DefLab(tpLb);
+        ELSIF long THEN
+          out.StaticCall(Mu.CpModL, -1);
+        ELSE
+          out.StaticCall(Mu.CpModI, -1);
+        END;
+    (* -------------------------------- *)
+    | Xp.div0op :
+        dNum := dst(Ty.Base).tpOrd;
+        e.PushValue(lOp, dst);
+        e.PushValue(rOp, dst);
+        out.Code(Asm.opc_div);
+    (* -------------------------------- *)
+    | Xp.divOp :
+        long := dst(Ty.Base).tpOrd = Ty.lIntN;
+        e.PushValue(lOp, dst);
+        IF (rOp.kind = Xp.numLt) & (longValue(rOp) > 0) THEN
+          tpLb := out.newLabel();
+          out.Code(Asm.opc_dup);
+          IF long THEN
+            rLit := longValue(rOp);
+            out.PushLong(0);
+            out.CodeLb(Asm.opc_bge, tpLb);
+            out.PushLong(rLit-1);
+            out.Code(Asm.opc_sub);
+            out.DefLab(tpLb);
+            out.PushLong(rLit);
+          ELSE
+            indx := intValue(rOp);
+            out.PushInt(0);
+            out.CodeLb(Asm.opc_bge, tpLb);
+            out.PushInt(indx-1);
+            out.Code(Asm.opc_sub);
+            out.DefLab(tpLb);
+            out.PushInt(indx);
+          END;
+          out.Code(Asm.opc_div);
+        ELSE
+          e.PushValue(rOp, dst);
+          IF long THEN
+            out.StaticCall(Mu.CpDivL, -1);
+          ELSE
+            out.StaticCall(Mu.CpDivI, -1);
+          END;
+        END;
+    (* -------------------------------- *)
+    | Xp.blOr,  Xp.blAnd :
+        tpLb := out.newLabel();
+        exLb := out.newLabel();
+       (*
+        *  Jumping code is mandated for blOr and blAnd...
+        *)
+        e.FallTrue(exp, tpLb);
+        out.Code(Asm.opc_ldc_i4_1);
+        out.CodeLb(Asm.opc_br, exLb);
+        out.DefLab(tpLb);
+        out.Code(Asm.opc_ldc_i4_0);
+        out.DefLab(exLb);
+    (* -------------------------------- *)
+    | Xp.greT,  Xp.greEq, Xp.notEq,
+      Xp.lessEq, Xp.lessT, Xp.equal :
+        e.PushCmpBool(lOp, rOp, exp.kind);
+    (* -------------------------------- *)
+    | Xp.inOp :
+        e.PushValue(rOp, rOp.type);
+        e.PushValue(lOp, lOp.type);
+        out.Code(Asm.opc_shr_un);
+        out.Code(Asm.opc_ldc_i4_1);
+        out.Code(Asm.opc_and);
+    (* -------------------------------- *)
+    | Xp.isOp :
+        e.PushValue(lOp, lOp.type);
+        out.CodeT(Asm.opc_isinst, rOp(Xp.IdLeaf).ident.type);
+        out.Code(Asm.opc_ldnull);
+        out.Code(Asm.opc_cgt_un);
+    (* -------------------------------- *)
+    | Xp.ashInt :
+        e.PushValue(lOp, lOp.type);
+        IF rOp.kind = Xp.numLt THEN
+          indx := intValue(rOp);
+          IF indx = 0 THEN (* skip *)
+          ELSIF indx < 0 THEN
+            out.PushInt(-indx);
+            out.Code(Asm.opc_shr);
+          ELSE
+            out.PushInt(indx);
+            out.Code(Asm.opc_shl);
+          END;
+        ELSE
+          tpLb := out.newLabel();
+          exLb := out.newLabel();
+         (*
+          *  This is a variable shift. Do it the hard way.
+          *  First, check the sign of the right hand op.
+          *)
+          e.PushValue(rOp, rOp.type);
+          out.Code(Asm.opc_dup);
+          out.PushInt(0);
+          out.CodeLb(Asm.opc_blt, tpLb);
+         (*
+          *  Positive selector ==> shift left;
+          *)
+          out.Code(Asm.opc_shl);
+          out.CodeLb(Asm.opc_br, exLb);
+         (*
+          *  Negative selector ==> shift right;
+          *)
+          out.DefLab(tpLb);
+          out.Code(Asm.opc_neg);
+          out.Code(Asm.opc_shr);
+          out.DefLab(exLb);
+        END;
+    (* -------------------------------- *)
+    | Xp.strCat :
+        e.PushValue(lOp, lOp.type);
+        e.PushValue(rOp, rOp.type);
+        IF isStrExp(lOp) THEN
+          IF isStrExp(rOp) THEN
+            out.StaticCall(Mu.CPJstrCatSS, -1);
+          ELSE
+            out.StaticCall(Mu.CPJstrCatSA, -1);
+          END;
+        ELSE
+          IF isStrExp(rOp) THEN
+            out.StaticCall(Mu.CPJstrCatAS, -1);
+          ELSE
+            out.StaticCall(Mu.CPJstrCatAA, -1);
+          END;
+        END;
+    (* -------------------------------- *)
+    END;
+  END PushBinary;
+
+(* ============================================================ *)
+
+  PROCEDURE (e : MsilEmitter)PushValue(exp : Sy.Expr; typ : Sy.Type),NEW;
+    VAR out : Mu.MsilFile;
+        rec : Ty.Record;
+        ix  : INTEGER;
+        elm : Sy.Expr;
+        emt : BOOLEAN;    (* ==> more than one set element expr *)
+  BEGIN
+    out := e.outF;
+    WITH exp : Xp.IdLeaf DO
+        IF exp.isProcLit() THEN
+          out.Code(Asm.opc_ldnull);
+          out.MkNewProcVal(exp.ident, typ);
+        ELSIF exp.kind = Xp.typOf THEN
+          out.LoadType(exp.ident);
+        ELSE
+          out.GetVar(exp.ident);
+        END;
+    | exp : Xp.SetExp DO
+        emt := TRUE;
+       (*
+        *   Write out the constant part, if there is one.
+        *)
+        IF exp.value # NIL THEN
+          out.PushInt(exp.value.int()); (* const part *)
+          emt := FALSE;
+        END;
+       (*
+        *   Write out the element expressions.
+        *   taking the union with any part emitted already.
+        *)
+        FOR ix := 0 TO exp.varSeq.tide-1 DO
+          elm := exp.varSeq.a[ix];
+          IF elm.kind = Xp.range THEN
+            e.PushValue(elm, Bi.intTp);
+          ELSE
+            out.PushInt(1);
+            e.PushValue(exp.varSeq.a[ix], Bi.intTp);
+            out.Code(Asm.opc_shl);
+          END;
+          IF ~emt THEN out.Code(Asm.opc_or) END;
+          emt := FALSE;
+        END;
+       (*
+        *   If neither of the above emitted anything, emit zero!
+        *)
+        IF emt THEN out.Code(Asm.opc_ldc_i4_0) END;
+    | exp : Xp.LeafX DO
+        CASE exp.kind OF
+        | Xp.tBool  : out.Code(Asm.opc_ldc_i4_1);
+        | Xp.fBool  : out.Code(Asm.opc_ldc_i4_0);
+        | Xp.nilLt  : out.Code(Asm.opc_ldnull);
+        | Xp.charLt : out.PushInt(ORD(exp.value.char()));
+        | Xp.setLt  : out.PushInt(exp.value.int());
+        | Xp.numLt  :
+            IF typ = Bi.lIntTp THEN
+              out.PushLong(exp.value.long());
+            ELSE
+              out.PushInt(exp.value.int());
+            END;
+        | Xp.realLt :
+            IF typ = Bi.realTp THEN
+              out.PushReal(exp.value.real());
+            ELSE
+              out.PushSReal(exp.value.real());
+            END;
+        | Xp.strLt  :
+            IF typ = Bi.charTp THEN
+              out.PushInt(ORD(exp.value.chr0()));
+            ELSE
+              out.PushStr(exp.value.chOpen());
+            END;
+        | Xp.infLt  : 
+            IF typ = Bi.realTp THEN
+              out.GetVar(CSt.dblInf);
+            ELSE
+              out.GetVar(CSt.fltInf);
+            END;
+        | Xp.nInfLt : 
+            IF typ = Bi.realTp THEN
+              out.GetVar(CSt.dblNInf);
+            ELSE
+              out.GetVar(CSt.fltNInf);
+            END;
+        END;
+    | exp : Xp.CallX DO
+       (* 
+        *  EXPERIMENTAL debug marker ...
+        *)
+        (*out.LinePlus(exp.token.lin, exp.token.col + exp.token.len);*)
+        e.PushCall(exp);
+    | exp : Xp.IdentX DO
+        IF exp.kind = Xp.selct THEN
+          IF exp.isProcLit() THEN
+            out.Comment("Make event value");
+            e.PushValue(exp.kid, exp.kid.type);
+            out.MkNewProcVal(exp.ident, typ);
+          ELSE
+            e.PushHandle(exp, exp.type);
+            out.GetField(exp.ident(Id.FldId));
+          END;
+        ELSE
+          e.PushValue(exp.kid, exp.kid.type);
+          IF exp.kind = Xp.cvrtUp THEN
+            out.ConvertUp(exp.kid.type, typ);
+          ELSIF exp.kind = Xp.cvrtDn THEN
+            out.ConvertDn(exp.kid.type, typ);
+          END;
+        END;
+    | exp : Xp.UnaryX DO
+        e.PushUnary(exp, typ);
+    | exp : Xp.BinaryX DO
+        e.PushBinary(exp, typ);
+    END;
+  END PushValue;
+
+(* ---------------------------------------------------- *)
+(* ---------------------------------------------------- *
+ *
+ *PROCEDURE (e : MsilEmitter)PushObjRef(exp : Sy.Expr),NEW;
+ *BEGIN
+ *  IF Mu.isValRecord(exp.type) THEN
+ *    e.PushRef(exp,exp.type);
+ *  ELSE
+ *    e.PushValue(exp,exp.type);
+ *  END;
+ *END PushObjRef;
+ *
+ * ---------------------------------------------------- *)
+(* ---------------------------------------------------- *)
+
+  PROCEDURE (e : MsilEmitter)PushVectorIndex(exp : Xp.BinaryX),NEW;
+    VAR out  : Mu.MsilFile;
+        tide : INTEGER;
+        okLb : Mu.Label;
+        vecT : Ty.Vector;
+  BEGIN
+    out := e.outF;
+    okLb := out.newLabel();
+    vecT := exp.lKid.type(Ty.Vector);
+    tide := out.proc.newLocal(Bi.intTp);
+    out.Code(Asm.opc_dup);                (* ... vec, vec           *)
+    out.GetField(Mu.vecLeng(out));        (* ... vec, len           *)
+    out.StoreLocal(tide);                 (* ... vec                *)
+    out.GetField(Mu.vecArrFld(vecT,out)); (* ... aRf                *)
+    e.PushValue(exp.rKid, Bi.intTp);      (* ... aRf, idx           *)
+    out.Code(Asm.opc_dup);                (* ... vec, idx, idx      *)
+    out.PushLocal(tide);                  (* ... vec, idx, idx, len *)
+    out.CodeLb(Asm.opc_blt, okLb);        (* ... vec, idx           *)
+    out.IndexTrap();
+    out.DefLab(okLb);
+    out.proc.ReleaseLocal(tide);
+  END PushVectorIndex;
+
+(* ---------------------------------------------------- *)
+
+  PROCEDURE (e : MsilEmitter)PushHandle(exp : Sy.Expr; typ : Sy.Type),NEW;
+   (* Pre:  exp must be a variable designator     *)
+   (* Post: Reference to containing object is on TOS. *)
+    VAR idnt : Sy.Idnt;
+        out  : Mu.MsilFile;
+        cTmp : INTEGER;
+        kid  : Sy.Expr;
+  BEGIN
+    out := e.outF;
+    ASSERT(exp.isVarDesig());
+    WITH exp : Xp.IdentX DO
+        kid := exp.kid;
+        IF Mu.isValRecord(kid.type) THEN
+          e.PushRef(kid, kid.type);
+        ELSE
+          e.PushValue(kid, kid.type);
+        END;
+    | exp : Xp.BinaryX DO
+        e.PushValue(exp.lKid, exp.lKid.type);
+        IF exp.lKid.isVectorExpr() THEN
+          e.PushVectorIndex(exp);
+        ELSE
+          e.PushValue(exp.rKid, Bi.intTp);
+          IF Mu.isValRecord(typ) THEN out.CodeTn(Asm.opc_ldelema, typ) END;
+        END;
+    | exp : Xp.IdLeaf DO
+        IF Mu.isRefSurrogate(typ) THEN
+          e.PushValue(exp, typ);
+        ELSE
+          idnt := exp.ident;
+          WITH idnt : Id.LocId DO
+            IF Id.uplevA IN idnt.locAtt THEN
+              out.XhrHandle(idnt);
+            ELSE
+              WITH idnt : Id.ParId DO
+                IF idnt.boxOrd # Sy.val THEN out.PushArg(idnt.varOrd) END;
+              ELSE (* skip *)
+              END;
+            END;
+          ELSE (* skip *)
+          END;
+        END;
+    | exp : Xp.UnaryX DO
+        ASSERT(exp.kind = Xp.deref);
+        e.PushValue(exp.kid, exp.kid.type);
+        IF Mu.isValRecord(typ) THEN    (* get adr of boxed field *)
+          out.GetValA(exp.kid.type(Ty.Pointer));
+        END;
+      (*
+       *  ELSE
+       *    e.PushValue(exp, typ);
+       *)
+    END;
+  END PushHandle;
+
+(* ---------------------------------------------------- *)
+
+  PROCEDURE (e : MsilEmitter)PushRef(exp : Sy.Expr; typ : Sy.Type),NEW;
+    VAR out : Mu.MsilFile;
+        sav : INTEGER;
+  BEGIN
+    out := e.outF;
+    WITH exp : Xp.IdLeaf DO (* A scalar variable *)
+        out.GetVarA(exp.ident);
+    | exp : Xp.IdentX DO  (* A field reference *)
+        e.PushHandle(exp, typ);
+        out.GetFieldAdr(exp.ident(Id.FldId));
+    | exp : Xp.BinaryX DO (* An array element  *)
+        e.PushValue(exp.lKid, exp.lKid.type);
+(*
+ *      e.PushValue(exp.rKid, Bi.intTp);
+ *      out.CodeTn(Asm.opc_ldelema, typ);
+ *)
+        IF exp.lKid.isVectorExpr() THEN
+          e.PushVectorIndex(exp);
+          IF Mu.isValRecord(typ) THEN
+            out.Code(Asm.opc_ldelem_ref);  (* ???? *)
+            out.CodeT(Asm.opc_unbox, typ);
+          ELSE
+            out.CodeTn(Asm.opc_ldelema, typ);  (* ???? *)
+          END;
+        ELSE
+          e.PushValue(exp.rKid, Bi.intTp);
+          out.CodeTn(Asm.opc_ldelema, typ);  (* ???? *)
+        END;
+
+    | exp : Xp.CallX DO 
+       (* 
+        *   This case occurs where a (foreign) method is
+        *   bound to a value class.  In CP, there would
+        *   be a corresponding boxed type instead.
+        *)
+        sav := out.proc.newLocal(typ);
+        e.PushValue(exp, typ);
+        out.StoreLocal(sav);		(* Store in new local variable *)
+	out.PushLocalA(sav);            (* Now take address of local   *)
+        out.proc.ReleaseLocal(sav);
+    | exp : Xp.UnaryX DO  (* Dereference node  *)
+       (* 
+        *  It is not always the case that typ and exp.type
+        *  denote the same type.  In one usage exp is an
+        *  actual argument, and typ is the type of the formal.
+        *)
+        e.PushValue(exp.kid, exp.kid.type);
+        IF exp.kind = Xp.deref THEN
+          IF Mu.isValRecord(typ) THEN
+            out.GetValA(exp.kid.type(Ty.Pointer));
+          END;
+        ELSE 
+          ASSERT(exp.kind = Xp.tCheck);
+          IF Mu.isValRecord(typ) THEN 
+            out.CodeT(Asm.opc_unbox, exp.type);
+          END;
+        END;
+        (* e.PushHandle(exp, typ); *)
+    ELSE (* skip *)
+    END;
+  END PushRef;
+
+(* ---------------------------------------------------- *)
+
+  PROCEDURE (e : MsilEmitter)ValueAssign(exp : Sy.Expr),NEW;
+    VAR out : Mu.MsilFile;
+  BEGIN
+    out := e.outF;
+    WITH exp : Xp.IdLeaf DO
+        (* stack has ... value, (top) *)
+        out.PutVar(exp.ident);
+    | exp : Xp.IdentX DO
+        (* stack has ... obj-ref, value, (top)  *)
+        out.PutField(exp.ident(Id.FldId));
+    | exp : Xp.BinaryX DO
+       (*
+        *  IF element type is a value-rec,
+        *  THEN Stack: ... elem-adr, value, (top)
+        *  ELSE  ... arr-ref, index, value, (top)
+        *)
+        out.PutElem(exp.type);
+    | exp : Xp.UnaryX DO
+       (*
+        *  This is a deref of a value record
+        *  and Stack: ... handle, value, (top)
+        *)
+        out.CodeT(Asm.opc_stobj, exp.type);
+    ELSE
+      Console.WriteString("BAD VALUE ASSIGN"); Console.WriteLn;
+      exp.Diagnose(0);
+      ASSERT(FALSE);
+    END;
+  END ValueAssign;
+
+(* ---------------------------------------------------- *)
+
+  PROCEDURE (e : MsilEmitter)EraseAndAssign(eT : Sy.Type; vT : Ty.Vector),NEW;
+    VAR out : Mu.MsilFile;
+        rT  : Sy.Type;   (* CLR representation elem type  *)
+  BEGIN
+    out := e.outF;
+
+    rT := Mu.vecRepElTp(vT);
+
+    IF eT # rT THEN  (* value of elTp is sitting TOS, vector needs rpTp *)
+     (*
+      *  For the gpcp-1.2.x design all rpTp uses of 
+      *  int32, char use default conversions. All 
+      *  other base types represent themselves
+      *)
+      IF Mu.isValRecord(eT) THEN out.CodeT(Asm.opc_box, eT) END;
+    END;
+    out.PutElem(rT);
+  END EraseAndAssign;
+
+(* ---------------------------------------------------- *)
+
+  PROCEDURE (e : MsilEmitter)RefRecCopy(typ : Ty.Record),NEW;
+    VAR nam : Lv.CharOpen;
+  BEGIN
+   (*
+    *  We should use a builtin here for value type, but
+    *  seem to need an element by element copy for classes.
+    *
+    *     Stack at entry is (top) srcRef, dstRef...
+    *)
+    IF typ.xName = NIL THEN Mu.MkRecName(typ, e.outF) END;
+    e.outF.CopyCall(typ);
+  END RefRecCopy;
+
+(* ---------------------------------------------------- *)
+
+  PROCEDURE (e : MsilEmitter)RefArrCopy(typ : Ty.Array),NEW;
+    VAR out   : Mu.MsilFile;
+        count : INTEGER;
+        cardN : INTEGER;
+        dstLc : INTEGER;
+        srcLc : INTEGER;
+        sTemp : INTEGER;
+        elTyp : Sy.Type;
+        label : Mu.Label;
+  BEGIN
+    elTyp := typ.elemTp;
+   (*
+    *    Stack at entry is (top) srcRef, dstRef...
+    *)
+    out := e.outF;
+    label := out.newLabel();
+   (*
+    *   Allocate two local variables.
+    *)
+    dstLc := out.proc.newLocal(typ);
+    srcLc := out.proc.newLocal(typ);
+   (*
+    *   Initialize the two locals.
+    *)
+    out.StoreLocal(srcLc);
+    out.StoreLocal(dstLc);      (* Stack is now empty.  *)
+    cardN := typ.length;
+   (*
+    *   Compute the length, either now or at runtime...
+    *)
+    IF  (cardN > 0) &                 (* ... not open array  *)
+        (cardN <= inlineLimit) &      (* ... not too long    *)
+        Mu.hasValueRep(elTyp) THEN    (* ... outer dimension *)
+     (*
+      *   Do inline <element assign> using a compile-time loop
+      *)
+      FOR count := 0 TO cardN-1 DO
+        out.PushLocal(dstLc);
+        out.PushInt(count);
+        IF Mu.isValRecord(elTyp) THEN
+          out.CodeTn(Asm.opc_ldelema, elTyp);
+          out.PushLocal(srcLc);
+          out.PushInt(count);
+          out.CodeTn(Asm.opc_ldelema, elTyp);
+          out.CodeT(Asm.opc_ldobj, elTyp);
+          out.CodeT(Asm.opc_stobj, elTyp);
+        ELSE
+          IF (elTyp IS Ty.Array) OR
+             (elTyp IS Ty.Record) THEN out.GetElem(elTyp) END;
+          out.PushLocal(srcLc);
+          out.PushInt(count);
+          out.GetElem(elTyp);
+          WITH elTyp : Ty.Record DO
+              e.RefRecCopy(elTyp);
+          | elTyp : Ty.Array DO
+              e.RefArrCopy(elTyp);
+          ELSE  (* scalar element type *)
+            out.PutElem(elTyp);
+          END;
+        END;
+      END;
+    ELSE (* Do array copy using a runtime loop *)
+      IF cardN = 0 THEN (* open array, get length from source desc *)
+        out.PushLocal(srcLc);
+        out.Code(Asm.opc_ldlen);
+      ELSE
+        out.PushInt(cardN);
+      END;
+     (*
+      *   Allocate an extra local variable
+      *)
+      count := out.proc.newLocal(Bi.intTp);
+      out.StoreLocal(count);
+      out.DefLab(label);      (* The back-edge target *)
+     (*
+      *   Decrement the loop count.
+      *)
+      out.DecTemp(count);       (* Stack is now empty.  *)
+     (*
+      *   We now do the one-per-loop <element assign>
+      *)
+      out.PushLocal(dstLc);
+      out.PushLocal(count);
+      IF Mu.isValRecord(elTyp) THEN
+        out.CodeTn(Asm.opc_ldelema, elTyp);
+        out.PushLocal(srcLc);
+        out.PushLocal(count);
+        out.CodeTn(Asm.opc_ldelema, elTyp);
+        out.CodeT(Asm.opc_ldobj, elTyp);
+        out.CodeT(Asm.opc_stobj, elTyp);
+      ELSE
+        IF (elTyp IS Ty.Array) OR
+           (elTyp IS Ty.Record) THEN out.GetElem(elTyp) END;
+        out.PushLocal(srcLc);
+        out.PushLocal(count);
+        out.GetElem(elTyp);
+        WITH elTyp : Ty.Record DO
+            e.RefRecCopy(elTyp);
+        | elTyp : Ty.Array DO
+            e.RefArrCopy(elTyp);
+        ELSE  (* scalar element type *)
+          out.PutElem(elTyp);
+        END;
+      END;
+     (*
+      *   Loop back to label if count non-zero.
+      *)
+      out.PushLocal(count);
+      out.CodeLb(Asm.opc_brtrue, label);
+     (*
+      *   release the extra local.
+      *)
+      out.proc.ReleaseLocal(count);
+    END;
+   (*
+    *   ... and release the two locals.
+    *)
+    out.proc.ReleaseLocal(srcLc);
+    out.proc.ReleaseLocal(dstLc);
+  END RefArrCopy;
+
+(* ---------------------------------------------------- *)
+
+  PROCEDURE (e : MsilEmitter)ValueCopy(act : Sy.Expr; fmT : Sy.Type),NEW;
+   (**  Make a copy of the value of expression act, into a newly  *)
+   (*   allocated destination.  Leave dst reference on top of stack.  *)
+    VAR out  : Mu.MsilFile;
+        dTmp : INTEGER;
+        sTmp : INTEGER;
+  BEGIN
+   (*
+    *  Copy this actual, where fmT is either an array or record.
+    *)
+    out := e.outF;
+    WITH fmT : Ty.Record DO
+      out.MkNewRecord(fmT);       (* (top) dst...   *)
+      out.Code(Asm.opc_dup);      (* (top) dst,dst... *)
+      e.PushValue(act, fmT);      (* (top) src,dst,dst... *)
+      e.RefRecCopy(fmT);          (* (top) dst...   *)
+    | fmT : Ty.Array DO
+     (*
+      *  Array case: ordinary value copy
+      *)
+      dTmp := out.proc.newLocal(fmT);   (* Holds dst reference. *)
+      sTmp := out.proc.newLocal(fmT);   (* Holds src reference. *)
+      IF fmT.length = 0 THEN
+       (*
+        *   This is the open array destination case.
+        *   Compute length of actual parameter and
+        *   allocate an array of the needed length.
+        *)
+        e.PushValue(act, fmT);      (* (top) src...   *)
+        out.Code(Asm.opc_dup);      (* (top) src,src... *)
+        out.StoreLocal(sTmp);     (* (top) src...   *)
+
+        IF act.kind = Xp.mkStr THEN   (* (top) src...   *)
+          out.StaticCall(Mu.aStrLp1, 0); (* (top) len...   *)
+          out.CodeTn(Asm.opc_newarr, Bi.charTp); (* (top) dst...   *)
+        ELSE          (* (top) src...   *)
+          out.MkArrayCopy(fmT);     (* (top) dst...   *)
+        END;
+        out.Code(Asm.opc_dup);      (* (top) dst,dst... *)
+        out.StoreLocal(dTmp);     (* (top) dst...   *)
+        out.PushLocal(sTmp);      (* (top) src,dst... *)
+      ELSE
+       (*
+        *   This is the fixed-length destination case.
+        *   We allocate an array of the needed length.
+        *)
+        out.MkFixedArray(fmT);
+        out.Code(Asm.opc_dup);      (* (top) dst,dst... *)
+        out.StoreLocal(dTmp);     (* (top) dst...   *)
+        e.PushValue(act, fmT);      (* (top) src,dst... *)
+      END;
+      IF act.kind = Xp.mkStr THEN
+        out.StaticCall(Mu.aaStrCopy, -2);  (* (top) ...    *)
+      ELSE
+        e.RefArrCopy(fmT);      (* (top) ...    *)
+      END;
+      out.PushLocal(dTmp);      (* (top) dst...   *)
+      out.proc.ReleaseLocal(dTmp);
+      out.proc.ReleaseLocal(sTmp);
+    END;
+  END ValueCopy;
+
+(* ---------------------------------------------------- *)
+
+  PROCEDURE (e : MsilEmitter)StringCopy(act : Sy.Expr; fmT : Ty.Array),NEW;
+    VAR out : Mu.MsilFile;
+  BEGIN
+    out := e.outF;
+    IF act.kind = Xp.mkStr THEN
+      e.ValueCopy(act, fmT);
+    ELSIF fmT.length = 0 THEN     (* str passed to open array   *)
+      e.PushValue(act, fmT);
+      e.outF.StaticCall(Mu.vStr2ChO, 0);
+    ELSE        (* str passed to fixed array  *)
+      out.PushInt(fmT.length);
+      out.MkOpenArray(Ty.mkArrayOf(Bi.charTp));
+      out.Code(Asm.opc_dup);
+      e.PushValue(act, fmT);
+      e.outF.StaticCall(Mu.vStr2ChF, -2);
+    END;
+  END StringCopy;
+
+(* ============================================================ *)
+
+  PROCEDURE (e : MsilEmitter)Invoke(exp : Sy.Expr; typ : Ty.Procedure),NEW;
+    VAR code : INTEGER;
+        prcI : Id.PrcId;
+        mthI : Id.MthId;
+  BEGIN
+    IF exp.isProcVar() THEN
+      e.outF.CallDelegate(typ);
+    ELSE
+      WITH exp : Xp.IdLeaf DO (* qualid *)
+          code := Asm.opc_call;
+          prcI := exp.ident(Id.PrcId);
+          IF prcI.kind # Id.ctorP THEN
+            e.outF.CallIT(code, prcI, typ);
+          ELSE
+            e.outF.CallCT(prcI, typ);
+          END;
+      | exp : Xp.IdentX DO (* selct *)
+          mthI := exp.ident(Id.MthId);
+          IF exp.kind = Xp.sprMrk THEN
+            code := Asm.opc_call;
+          ELSIF mthI.bndType.isInterfaceType() THEN
+            code := Asm.opc_callvirt;
+          
+          ELSIF (mthI.mthAtt * Id.mask = Id.final) OR
+                ~mthI.bndType.isExtnRecType() THEN
+                (* Non-extensible record types can still have virtual *)
+                (* methods (inherited from Object, say). It is a      *)
+                (* verify error to callvirt on these. kjg April 2006  *)
+            code := Asm.opc_call;
+          ELSE
+            code := Asm.opc_callvirt;
+          END;
+          e.outF.CallIT(code, mthI, typ);
+          IF Id.covar IN mthI.mthAtt THEN
+            e.outF.CodeT(Asm.opc_castclass, typ.retType);
+          END;
+      END;
+    END;
+  END Invoke;
+
+(* ---------------------------------------------------- *)
+
+  PROCEDURE (e : MsilEmitter)GetArgP(act : Sy.Expr;
+                                     frm : Id.ParId),NEW;
+    VAR out   : Mu.MsilFile;
+  BEGIN
+    out := e.outF;
+    IF (frm.boxOrd # Sy.val) OR (Id.cpVarP IN frm.locAtt) THEN
+      e.PushRef(act, frm.type);
+    ELSIF (frm.type IS Ty.Array) &
+          ((act.type = Bi.strTp) OR act.type.isNativeStr()) THEN (* a string *)
+      e.StringCopy(act, frm.type(Ty.Array));
+    ELSIF (frm.parMod = Sy.val) & Mu.isRefSurrogate(frm.type) THEN
+      e.ValueCopy(act, frm.type);
+    ELSE
+      e.PushValue(act, frm.type);
+    END;
+  END GetArgP;
+
+(* ============================================================ *)
+(*    Possible structures of procedure call expressions are:    *)
+(* ============================================================ *)
+(*          o                               o                   *)
+(*         /                               /                    *)
+(*      [CallX]                         [CallX]                 *)
+(*       / +--- actuals --> ...          / +--- actuals         *)
+(*      /                               /                       *)
+(*    [IdentX]                      [IdLeaf]                    *)
+(*      /  +--- ident ---> [Procs]      +--- ident ---> [Procs] *)
+(*     /                                                        *)
+(* kid expr                                                     *)
+(*                                                              *)
+(* ============================================================ *)
+(*  only the right hand case can be a standard proc or function *)
+(* ============================================================ *)
+
+  PROCEDURE (e : MsilEmitter)PushCall(callX : Xp.CallX),NEW;
+    VAR iFile : Mu.MsilFile;
+        index : INTEGER;  (* just a counter for loops *)
+        formT : Ty.Procedure; (* formal type of procedure *)
+        formP : Id.ParId; (* current formal parameter *)
+        prExp : Sy.Expr;
+        idExp : Xp.IdentX;
+        dummy : BOOLEAN;  (* outPar for EmitStat call *)
+        prVar : BOOLEAN;  (* ==> expr is a proc-var   *)
+ (* ---------------------------------------------------- *)
+    PROCEDURE CheckCall(expr : Sy.Expr; os : Mu.MsilFile);
+      VAR prcI : Id.PrcId;
+          mthI : Id.MthId;
+    BEGIN
+      WITH expr : Xp.IdLeaf DO (* qualid *)
+          prcI := expr.ident(Id.PrcId);
+          IF prcI.type.xName = NIL THEN Mu.MkCallAttr(prcI, os) END;
+          expr.type := prcI.type;
+      | expr : Xp.IdentX DO (* selct *)
+          mthI := expr.ident(Id.MthId);
+          IF mthI.type.xName = NIL THEN Mu.MkCallAttr(mthI, os) END;
+          expr.type := mthI.type;
+      END;
+    END CheckCall;
+ (* ---------------------------------------------------- *)
+    PROCEDURE isNested(exp : Sy.Expr) : BOOLEAN;
+    BEGIN
+      WITH exp : Xp.IdLeaf DO (* qualid *)
+        RETURN exp.ident(Id.PrcId).lxDepth > 0;
+      ELSE RETURN FALSE;
+      END;
+    END isNested;
+ (* ---------------------------------------------------- *)
+  BEGIN
+    iFile := e.outF;
+    prExp := callX.kid;
+    formT := prExp.type(Ty.Procedure);
+   (*
+    *  Before we push any arguments, we must make
+    *  sure that the formal-type name is computed.
+    *)
+    prVar := prExp.isProcVar();
+    IF ~prVar THEN CheckCall(prExp, iFile) END;
+    formT := prExp.type(Ty.Procedure);
+    IF prVar THEN
+      iFile.CommentT("Start delegate call sequence");
+      e.PushValue(prExp, prExp.type);
+    ELSIF formT.receiver # NIL THEN
+     (*
+      *  We must first deal with the receiver if this is a method.
+      *)
+      iFile.CommentT("Start dispatch sequence");
+      idExp := prExp(Xp.IdentX);
+      formP := idExp.ident(Id.MthId).rcvFrm;
+      e.GetArgP(idExp.kid, formP);
+    ELSE
+      iFile.CommentT("Start static call sequence");
+      IF isNested(prExp) THEN
+        iFile.PushStaticLink(prExp(Xp.IdLeaf).ident(Id.Procs));
+      END;
+    END;
+   (*
+    *  We push the arguments from left to right.
+    *)
+    FOR index := 0 TO callX.actuals.tide-1 DO
+      formP := formT.formals.a[index];
+      e.GetArgP(callX.actuals.a[index], formP);
+    END;
+   (*
+    *  Now emit the actual call instruction(s)
+    *)
+    e.Invoke(prExp, formT);
+   (*
+    *  Now clean up.
+    *)
+    iFile.CommentT("End call sequence");
+  END PushCall;
+
+(* ---------------------------------------------------- *)
+
+  PROCEDURE (e : MsilEmitter)EmitStdProc(callX : Xp.CallX),NEW;
+    CONST fMsg = "Assertion failure ";
+    VAR out  : Mu.MsilFile;
+        cTmp : INTEGER;
+        rTmp : INTEGER;
+        prId : Id.PrcId;
+        vrId : Id.FldId;
+        pOrd : INTEGER;
+        arg0 : Sy.Expr;
+        argX : Sy.Expr;
+        dstT : Sy.Type;
+        argN : INTEGER;
+        numL : INTEGER;
+        incr : INTEGER;
+        long : BOOLEAN;
+        ovfl : BOOLEAN;
+        subs : BOOLEAN;
+        c    : INTEGER;
+        okLb : Mu.Label;
+        vecT : Ty.Vector;
+   (* --------------------------- *)
+  BEGIN
+    out  := e.outF;
+    prId := callX.kid(Xp.IdLeaf).ident(Id.PrcId);
+    arg0 := callX.actuals.a[0]; (* Always need at least one arg *)
+    argN := callX.actuals.tide;
+    pOrd := prId.stdOrd;
+    CASE pOrd OF
+   (* --------------------------- *)
+    | Bi.asrtP :
+        okLb := out.newLabel();
+        e.FallFalse(arg0, okLb);
+       (*
+        *   If expression evaluates to false, fall
+        *   into the error code, else skip to okLb.
+        *)
+        IF argN > 1 THEN
+          numL := intValue(callX.actuals.a[1]);
+          out.Trap(fMsg + Lv.intToCharOpen(numL)^);
+        ELSE
+          numL := callX.token.lin;
+          out.Trap(fMsg + CSt.srcNam +":"+ Lv.intToCharOpen(numL)^);
+        END;
+        out.DefLab(okLb);
+   (* --------------------------- *)
+    | Bi.incP, Bi.decP :
+        argX := callX.actuals.a[1];
+        dstT := arg0.type;
+        ovfl := out.proc.prId.ovfChk;
+        e.PushHandle(arg0, dstT);
+        WITH arg0 : Xp.IdLeaf DO
+            e.PushValue(arg0, dstT);
+        | arg0 : Xp.IdentX DO
+            vrId := arg0.ident(Id.FldId);
+            out.Code(Asm.opc_dup);
+            out.GetField(vrId);
+        | arg0 : Xp.BinaryX DO
+(*
+ *  Here is the decision point: the stack is currently
+ *      (top) index,arrRef,...
+ *  we might reduce the 2-slot handle to an address, then go
+ *      dup; ldind; <add-n>; stind
+ *  but would this verify?
+ *  Alternatively, we can wimp out, and store both the ref
+ *  and the index then go
+ *      ldloc ref; ldloc idx; ldloc ref; ldloc idx; ldelem; <add-n>; stelem
+ *)
+            rTmp := out.proc.newLocal(arg0.lKid.type);
+            cTmp := out.proc.newLocal(Bi.intTp);
+            out.StoreLocal(cTmp); (* (top) ref,...    *)
+            out.Code(Asm.opc_dup);  (* (top) ref,ref,...    *)
+            out.StoreLocal(rTmp); (* (top) ref,...    *)
+            out.PushLocal(cTmp);  (* (top) idx,ref,...    *)
+            out.PushLocal(rTmp);  (* (top) ref,idx,ref,...  *)
+            out.PushLocal(cTmp);  (* (top) idx,ref,idx,ref,...  *)
+            out.GetElem(dstT);    (* (top) idx,ref,...    *)
+            out.proc.ReleaseLocal(cTmp);
+            out.proc.ReleaseLocal(rTmp);
+        END;
+        e.PushValue(argX, dstT);
+        IF pOrd = Bi.incP THEN
+          IF ovfl THEN c := Asm.opc_add_ovf ELSE c := Asm.opc_add END;
+        ELSE
+          IF ovfl THEN c := Asm.opc_sub_ovf ELSE c := Asm.opc_sub END;
+        END;
+        out.Code(c);
+        e.ValueAssign(arg0);
+   (* --------------------------- *)
+    | Bi.cutP  :
+        argX := callX.actuals.a[1];
+        vecT := arg0.type(Ty.Vector);
+        cTmp := out.proc.newLocal(Bi.intTp);
+        okLb := out.newLabel();
+       (* 
+        *  Push vector ref, and save tide
+        *)
+        e.PushValue(arg0, arg0.type);
+        out.Code(Asm.opc_dup);
+        out.GetField(Mu.vecLeng(out));
+        out.StoreLocal(cTmp);
+       (* 
+        *  Push new leng, and check against tide
+        *)
+        e.PushValue(argX, Bi.intTp);
+        out.Code(Asm.opc_dup);
+        out.PushLocal(cTmp);
+        out.CodeLb(Asm.opc_ble_un, okLb);
+        out.IndexTrap();
+       (* 
+        *  If no trap, then assign the new tide
+        *)
+        out.DefLab(okLb);
+        out.PutField(Mu.vecLeng(out));
+        out.proc.ReleaseLocal(cTmp);
+   (* --------------------------- *) 
+    | Bi.apndP :  
+        argX := callX.actuals.a[1];
+        vecT := arg0.type(Ty.Vector);
+        okLb := out.newLabel();
+        cTmp := out.proc.newLocal(Bi.intTp);
+        rTmp := out.proc.newLocal(Mu.vecRepTyp(vecT));
+       (* 
+        *  Push vector ref, and save ref and tide
+        *)
+        e.PushValue(arg0, vecT);
+        out.Code(Asm.opc_dup);
+        out.StoreLocal(rTmp);
+        out.GetField(Mu.vecLeng(out));
+        out.StoreLocal(cTmp);
+       (*
+        *  Fetch capacity and compare with tide
+        *)
+        out.PushLocal(rTmp);
+        out.GetField(Mu.vecArrFld(vecT, out));
+        out.Code(Asm.opc_ldlen);
+        out.PushLocal(cTmp);
+        out.CodeLb(Asm.opc_bgt, okLb);
+       (*
+        *  Call the RTS expand() method
+        *)
+        out.PushLocal(rTmp);
+        out.InvokeExpand(vecT);
+       (*
+        *  Now insert the element
+        *)
+        out.DefLab(okLb);
+        out.PushLocal(rTmp);
+        out.GetField(Mu.vecArrFld(vecT, out));
+        out.PushLocal(cTmp);
+        IF Mu.isRefSurrogate(argX.type) THEN 
+          e.ValueCopy(argX, argX.type);
+        ELSE
+          e.PushValue(argX, argX.type);
+        END;
+        e.EraseAndAssign(argX.type, vecT);
+       (*
+        *  Now increment tide;
+        *)
+        out.PushLocal(rTmp);
+        out.PushLocal(cTmp);
+        out.Code(Asm.opc_ldc_i4_1);
+        out.Code(Asm.opc_add);
+        out.PutField(Mu.vecLeng(out));
+
+        out.proc.ReleaseLocal(rTmp);
+        out.proc.ReleaseLocal(cTmp);
+   (* --------------------------- *)
+    | Bi.exclP, Bi.inclP :
+        dstT := arg0.type;
+        argX := callX.actuals.a[1];
+        e.PushHandle(arg0, dstT);
+        IF arg0 IS Xp.IdLeaf THEN
+          e.PushValue(arg0, dstT);
+        ELSE
+          WITH arg0 : Xp.BinaryX DO
+              ASSERT(arg0.kind = Xp.index);
+              rTmp := out.proc.newLocal(arg0.lKid.type);
+              cTmp := out.proc.newLocal(Bi.intTp);
+              out.StoreLocal(cTmp);
+              out.Code(Asm.opc_dup);
+              out.StoreLocal(rTmp);
+              out.PushLocal(cTmp);  (* (top) idx,ref,...    *)
+              out.PushLocal(rTmp);  (* (top) ref,idx,ref,...  *)
+              out.PushLocal(cTmp);  (* (top) idx,ref,idx,ref,...  *)
+              out.GetElem(dstT);  (* (top) idx,ref,...    *)
+              out.proc.ReleaseLocal(cTmp);
+              out.proc.ReleaseLocal(rTmp);
+          | arg0 : Xp.IdentX DO
+              ASSERT(arg0.kind = Xp.selct);
+              out.Code(Asm.opc_dup);
+              out.GetField(arg0.ident(Id.FldId));
+          END;
+        END;
+        IF argX.kind = Xp.numLt THEN
+          out.PushInt(ORD({intValue(argX)}));
+        ELSE
+          out.Code(Asm.opc_ldc_i4_1);
+          e.PushValue(argX, Bi.intTp);
+          out.Code(Asm.opc_shl);
+        END;
+        IF pOrd = Bi.inclP THEN
+          out.Code(Asm.opc_or);
+        ELSE
+          out.Code(Asm.opc_ldc_i4_M1);
+          out.Code(Asm.opc_xor);
+          out.Code(Asm.opc_and);
+        END;
+        e.ValueAssign(arg0);
+   (* --------------------------- *)
+    | Bi.subsP, Bi.unsbP :
+        dstT := arg0.type;
+        argX := callX.actuals.a[1];
+        subs := pOrd = Bi.subsP;
+        e.PushHandle(arg0, dstT);
+        WITH argX : Xp.IdLeaf DO
+            out.Code(Asm.opc_ldnull);
+            out.MkAndLinkDelegate(argX.ident, IdentOf(arg0), dstT, subs);
+        | argX : Xp.IdentX DO
+            e.PushValue(argX.kid, CSt.ntvObj);
+            out.MkAndLinkDelegate(argX.ident, IdentOf(arg0), dstT, subs);
+        END;
+   (* --------------------------- *)
+    | Bi.haltP :
+        out.PushInt(intValue(arg0));
+        out.StaticCall(Mu.sysExit, -1);
+       (*
+        *  We now do a dummy return to signal
+        *  the verifier that control exits here.
+        *)
+        out.PushJunkAndQuit(out.proc.prId);
+   (* --------------------------- *)
+    | Bi.throwP :
+        IF CSt.ntvExc.assignCompat(arg0) THEN
+          e.PushValue(arg0, CSt.ntvExc);
+          out.Code(Asm.opc_throw);
+        ELSE
+          e.PushValue(arg0, CSt.ntvStr);
+          out.Throw();
+        END;
+   (* --------------------------- *)
+    | Bi.newP :
+       (*
+        *   arg0 is a a vector, or a pointer to a Record or Array type.
+        *)
+        e.PushHandle(arg0, arg0.type);
+        IF argN = 1 THEN
+         (*
+          *  No LEN argument implies either:
+          * pointer to record, OR
+          * pointer to a fixed array.
+          *)
+          dstT := arg0.type(Ty.Pointer).boundTp;
+          WITH dstT : Ty.Record DO
+              out.MkNewRecord(dstT);
+          | dstT : Ty.Array DO
+              out.MkFixedArray(dstT);
+          END;
+        ELSIF arg0.type.kind = Ty.ptrTp THEN
+          FOR numL := argN-1 TO 1 BY -1 DO
+            argX := callX.actuals.a[numL];
+            e.PushValue(argX, Bi.intTp);
+          END;
+          dstT := arg0.type(Ty.Pointer).boundTp;
+          out.MkOpenArray(dstT(Ty.Array));
+        ELSE (* must be a vector *)
+          dstT := arg0.type(Ty.Vector).elemTp;
+          out.MkVecRec(dstT);
+          out.Code(Asm.opc_dup);
+          e.PushValue(callX.actuals.a[1], Bi.intTp);
+          out.MkVecArr(dstT);
+        END;
+        e.ValueAssign(arg0);
+   (* --------------------------- *)
+    | Bi.getP :
+       (*
+        *   arg0 is an integer value 
+        *)
+        argX := callX.actuals.a[1];
+        e.PushHandle(argX, argX.type);
+        e.PushValue(arg0, Bi.intTp);
+        out.LoadIndirect(argX.type);
+        e.ValueAssign(argX);
+   (* --------------------------- *)
+    | Bi.putP :
+       (*
+        *   arg0 is an integer value 
+        *)
+        argX := callX.actuals.a[1];
+        e.PushValue(arg0, Bi.intTp);
+        e.PushValue(argX, argX.type);
+        out.StoreIndirect(argX.type);
+   (* --------------------------- *)
+    END;
+  END EmitStdProc;
+
+(* ============================================================ *)
+(*        Statement Handling Methods      *)
+(* ============================================================ *)
+
+  PROCEDURE (e : MsilEmitter)EmitAssign(stat : St.Assign),NEW;
+    VAR lhTyp : Sy.Type;
+        erasd : BOOLEAN;
+  BEGIN
+   (*
+    *  This is a value assign in CP.
+    *)
+    lhTyp := stat.lhsX.type;
+
+    erasd := (stat.lhsX.kind = Xp.index) & 
+             (stat.lhsX(Xp.BinaryX).lKid.type IS Ty.Vector);
+
+    IF Mu.hasValueRep(lhTyp) THEN
+      e.PushHandle(stat.lhsX, lhTyp);
+      e.PushValue(stat.rhsX, lhTyp);
+      IF erasd THEN
+        e.EraseAndAssign(lhTyp, stat.lhsX(Xp.BinaryX).lKid.type(Ty.Vector));
+      ELSE
+        e.ValueAssign(stat.lhsX);
+      END;
+    ELSE (* a reference type *)
+      e.PushValue(stat.lhsX, lhTyp);
+      e.PushValue(stat.rhsX, lhTyp);
+      WITH lhTyp : Ty.Array DO
+        IF stat.rhsX.kind = Xp.mkStr THEN
+          e.outF.StaticCall(Mu.aaStrCopy, -2);
+        ELSIF isStrExp(stat.rhsX) THEN
+          e.outF.StaticCall(Mu.vStr2ChF, -2);
+        ELSE
+          e.RefArrCopy(lhTyp);
+        END;
+      | lhTyp : Ty.Record DO
+          e.RefRecCopy(lhTyp);
+      END;
+    END;
+  END EmitAssign;
+
+(* ---------------------------------------------------- *)
+
+  PROCEDURE (e : MsilEmitter)EmitCall(stat : St.ProcCall),NEW;
+    VAR expr : Xp.CallX;  (* the stat call expression *)
+  BEGIN
+    expr := stat.expr(Xp.CallX);
+    IF (expr.kind = Xp.prCall) & expr.kid.isStdProc() THEN
+      e.EmitStdProc(expr);
+    ELSE (*  EXPERIMENTAL debug marking *)
+      e.PushCall(expr);
+      IF CSt.debug THEN e.outF.Code(Asm.opc_nop) END;
+    END;
+  END EmitCall;
+
+(* ---------------------------------------------------- *)
+
+  PROCEDURE (e : MsilEmitter)
+                        EmitIf(stat : St.Choice; OUT ok : BOOLEAN),NEW;
+    VAR out  : Mu.MsilFile;
+        high : INTEGER;     (* Branch count.  *)
+        indx : INTEGER;
+        live : BOOLEAN;     (* then is live   *)
+        else : BOOLEAN;     (* else not seen  *)
+        then : Sy.Stmt;
+        pred : Sy.Expr;
+        nxtP : Mu.Label;   (* Next predicate *)
+        exLb : Mu.Label;   (* Exit label   *)
+  BEGIN
+    ok := FALSE;
+    out := e.outF;
+    exLb := out.newLabel();
+    else := FALSE;
+    high := stat.preds.tide - 1;
+    IF CSt.debug THEN out.Code(Asm.opc_nop) END;
+    FOR indx := 0 TO high DO
+      live := TRUE;
+      pred := stat.preds.a[indx];
+      then := stat.blocks.a[indx];
+      nxtP := out.newLabel();
+      IF pred = NIL THEN 
+        else := TRUE;
+      ELSE 
+        out.LineSpan(pred.tSpan);
+        e.FallTrue(pred, nxtP);
+      END;
+      IF then # NIL THEN e.EmitStat(then, live) END;
+      IF live THEN
+        ok := TRUE;
+        IF indx < high THEN out.CodeLb(Asm.opc_br, exLb) END;
+      END;
+      out.DefLab(nxtP);
+    END;
+   (*
+    *   If not ELSE has been seen, then control flow is still live!
+    *)
+    IF ~else THEN ok := TRUE END;
+    out.DefLab(exLb);
+  END EmitIf;
+
+(* ---------------------------------------------------- *)
+
+  PROCEDURE (e : MsilEmitter)EmitRanges
+                       (locV : INTEGER;     (* select Var   *)
+                        stat : St.CaseSt;   (* case stat    *)
+                        minR : INTEGER;   (* min rng-ix   *)
+                        maxR : INTEGER;   (* max rng-ix   *)
+                        minI : INTEGER;   (* min index    *)
+                        maxI : INTEGER;   (* max index    *)
+                        dfLb : Mu.LbArr),NEW;  (* default Lb   *)
+   (* --------------------------------------------------------- *
+    *   This procedure emits the code for a single,
+    *   dense range of selector values in the label-list.
+    * --------------------------------------------------------- *)
+    VAR out  : Mu.MsilFile;
+        loIx : INTEGER;   (* low selector value for dense range  *)
+        hiIx : INTEGER;   (* high selector value for dense range *)
+        rNum : INTEGER;   (* total number of ranges in the group *)
+        peel : INTEGER;   (* max index of range to be peeled off *)
+        indx : INTEGER;
+        rnge : St.Triple;
+  BEGIN
+    out := e.outF;
+    rNum := maxR - minR + 1;
+    rnge := stat.labels.a[minR];
+    IF rNum = 1 THEN    (* single range only *)
+      out.EmitOneRange(locV, rnge.loC, rnge.hiC, rnge.ord, minI, maxI, dfLb);
+    ELSIF rNum < 4 THEN
+     (*
+      *    Two or three ranges only.
+      *    Peel off the lowest of the ranges, and recurse.
+      *)
+      loIx := rnge.loC;
+      peel := rnge.hiC;
+      out.PushLocal(locV);
+     (*
+      *   There are a number of special cases
+      *   that can benefit from special code.
+      *)
+      IF loIx = peel THEN
+       (*
+        *   A singleton.  Leave minI unchanged, unless peel = minI.
+        *)
+        out.PushInt(peel);
+        out.CodeLb(Asm.opc_beq, dfLb[rnge.ord+1]);
+        IF minI = peel THEN minI := peel+1 END;
+      ELSIF loIx = minI THEN
+       (*
+        *   A range starting at the minimum selector value.
+        *)
+        out.PushInt(peel);
+        out.CodeLb(Asm.opc_ble, dfLb[rnge.ord+1]);
+        minI := peel+1;
+      ELSE
+        out.PushInt(loIx);
+        out.Code(Asm.opc_sub);
+        out.PushInt(peel-loIx);
+        out.CodeLb(Asm.opc_ble_un, dfLb[rnge.ord+1]);
+        (* leaving minI unchanged! *)
+      END;
+      e.EmitRanges(locV, stat, (minR+1), maxR, minI, maxI, dfLb);
+    ELSE
+     (*
+      *   Four or more ranges.  Emit a dispatch table.
+      *)
+      loIx := rnge.loC;     (* low of min-range  *)
+      hiIx := stat.labels.a[maxR].hiC;  (* high of max-range *)
+      out.PushLocal(locV);
+      IF loIx # 0 THEN
+        out.PushInt(loIx);
+        out.Code(Asm.opc_sub);
+      END;
+      out.SwitchHead(hiIx - loIx + 1);
+      (* ---- *)
+      FOR indx := minR TO maxR DO
+        rnge := stat.labels.a[indx];
+        WHILE loIx < rnge.loC DO
+          out.LstLab(dfLb[0]); INC(loIx);
+        END;
+        WHILE loIx <= rnge.hiC DO
+          out.LstLab(dfLb[rnge.ord+1]); INC(loIx);
+        END;
+      END;
+      (* ---- *)
+      out.SwitchTail();
+      out.CodeLb(Asm.opc_br, dfLb[0])
+    END;
+  END EmitRanges;
+
+(* ---------------------------------------------------- *)
+
+  PROCEDURE (e : MsilEmitter)EmitGroups
+                        (locV : INTEGER;   (* select vOrd  *)
+                         stat : St.CaseSt; (* case stat    *)
+                         minG : INTEGER;   (* min grp-indx *)
+                         maxG : INTEGER;   (* max grp-indx *)
+                         minI : INTEGER;   (* min index    *)
+                         maxI : INTEGER;   (* max index    *)
+                         dfLb : Mu.LbArr),NEW;  (* default lab  *)
+   (* --------------------------------------------------------- *
+    *  This function emits the branching code which sits on top
+    *  of the selection code for each dense range of case values.
+    * --------------------------------------------------------- *)
+    VAR out   : Mu.MsilFile;
+        newLb : Mu.Label;
+        midPt : INTEGER;
+        group : St.Triple;
+        range : St.Triple;
+  BEGIN
+    IF maxG = -1 THEN RETURN (* This is an empty case statement *)
+    ELSIF minG = maxG THEN   (* Only one remaining dense group  *)
+      group := stat.groups.a[minG];
+      e.EmitRanges(locV, stat, group.loC, group.hiC, minI, maxI, dfLb);
+    ELSE
+     (*
+      *   We must bifurcate the group range, and recurse.
+      *   We will split the value range at the lower limit
+      *   of the low-range of the upper half-group.
+      *)
+      midPt := (minG + maxG + 1) DIV 2;
+      group := stat.groups.a[midPt];
+      range := stat.labels.a[group.loC];
+     (*
+      *  Test and branch at range.loC
+      *)
+      out := e.outF;
+      newLb := out.newLabel();
+      out.PushLocal(locV);
+      out.PushInt(range.loC);
+      out.CodeLb(Asm.opc_bge, newLb);
+     (*
+      *    Recurse!
+      *)
+      e.EmitGroups(locV, stat, minG, midPt-1, minI, range.loC-1, dfLb);
+      out.DefLab(newLb);
+      e.EmitGroups(locV, stat, midPt, maxG, range.loC, maxI, dfLb);
+    END;
+  END EmitGroups;
+
+(* ---------------------------------------------------- *)
+
+  PROCEDURE (e : MsilEmitter)
+                        EmitCase(stat : St.CaseSt; OUT ok : BOOLEAN),NEW;
+    VAR out  : Mu.MsilFile;
+        indx : INTEGER;
+        selV : INTEGER;
+        live : BOOLEAN;
+        minI : INTEGER;
+        maxI : INTEGER;
+        dfLb : Mu.LbArr;
+        exLb : Mu.Label;
+  BEGIN
+   (* ---------------------------------------------------------- *
+    *  CaseSt* = POINTER TO RECORD (Sy.Stmt)
+    *      (* ----------------------------------------- *
+    *       * kind-  : INTEGER; (* tag for unions *)
+    *       * token* : S.Token; (* stmt first tok *)
+    *       * ----------------------------------------- *)
+    *   select* : Sy.Expr; (* case selector  *)
+    *   chrSel* : BOOLEAN;  (* ==> use chars  *)
+    *   blocks* : Sy.StmtSeq;  (* case bodies    *)
+    *   elsBlk* : Sy.Stmt; (* elseCase | NIL *)
+    *   labels* : TripleSeq;  (* label seqence  *)
+    *   groups- : TripleSeq;  (* dense groups   *)
+    *       END;
+    * --------------------------------------------------------- *
+    *  Notes on the semantics of this structure. "blocks" holds *
+    *  an ordered list of case statement code blocks. "labels"  *
+    *  is a list of ranges, intially in textual order,with flds *
+    *  loC, hiC and ord corresponding to the range min, max and *
+    *  the selected block ordinal number.  This list is later   *
+    *  sorted on the loC value, and adjacent values merged if   *
+    *  they select the same block. The "groups" list of triples *
+    *  groups ranges into dense subranges in the selector space *
+    *  The fields loC, hiC, and ord to hold the lower and upper *
+    *  indices into the labels list, and the number of non- *
+    *  default values in the group. Groups are guaranteed to  *
+    *  have density (nonDefN / (max-min+1)) > DENSITY   *
+    * --------------------------------------------------------- *)
+    ok := FALSE;
+    out := e.outF;
+    exLb := out.newLabel();
+    dfLb := out.getLabelRange(stat.blocks.tide+1);
+    IF stat.chrSel THEN
+      minI := 0; maxI := ORD(MAX(CHAR));
+      selV := out.proc.newLocal(Bi.charTp);
+    ELSE
+      minI := MIN(INTEGER);
+      maxI := MAX(INTEGER);
+      selV := out.proc.newLocal(Bi.intTp);
+    END;
+
+   (*
+    *    Push the selector value, and save in local variable;
+    *)
+    e.PushValue(stat.select, stat.select.type);
+    out.StoreLocal(selV);
+    e.EmitGroups(selV, stat, 0, stat.groups.tide-1, minI, maxI, dfLb);
+   (*
+    *    Now we emit the code for the cases.
+    *    If any branch returns, then exLb is reachable.
+    *)
+    FOR indx := 0 TO stat.blocks.tide-1 DO
+      out.DefLab(dfLb[indx+1]);
+      e.EmitStat(stat.blocks.a[indx], live);
+      IF live THEN
+        ok := TRUE;
+        out.CodeLb(Asm.opc_br, exLb);
+      END;
+    END;
+   (*
+    *    Now we emit the code for the elespart.
+    *    If the elsepart returns then exLb is reachable.
+    *)
+    out.DefLabC(dfLb[0], "Default case");
+    IF stat.elsBlk # NIL THEN
+      e.EmitStat(stat.elsBlk, live);
+      IF live THEN ok := TRUE END;
+    ELSE
+      out.CaseTrap(selV);
+    END;
+    out.proc.ReleaseLocal(selV);
+    IF ok THEN out.DefLabC(exLb, "Case exit label") END;
+  END EmitCase;
+
+(* ---------------------------------------------------- *)
+
+  PROCEDURE (e : MsilEmitter)
+                        EmitWhile(stat : St.TestLoop; OUT ok : BOOLEAN),NEW;
+    VAR out  : Mu.MsilFile;
+        lpLb : Mu.Label;
+        exLb : Mu.Label;
+  BEGIN
+    out := e.outF;
+    lpLb := out.newLabel();
+    exLb := out.newLabel();
+    IF CSt.debug THEN out.Code(Asm.opc_nop) END;
+    out.LineSpan(stat.test.tSpan);
+    e.FallTrue(stat.test, exLb);  (* goto exLb if eval false *)
+    out.DefLabC(lpLb, "Loop header");
+    e.EmitStat(stat.body, ok);
+    IF ok THEN
+      out.LineSpan(stat.test.tSpan); 
+      e.FallFalse(stat.test, lpLb); 
+    END;
+    out.DefLabC(exLb, "Loop exit");
+  END EmitWhile;
+
+(* ---------------------------------------------------- *)
+
+  PROCEDURE (e : MsilEmitter)
+                        EmitRepeat(stat : St.TestLoop; OUT ok : BOOLEAN),NEW;
+    VAR out  : Mu.MsilFile;
+        lpLb : Mu.Label;
+  BEGIN
+    out := e.outF;
+    lpLb := out.newLabel();
+    out.DefLabC(lpLb, "Loop header");
+    e.EmitStat(stat.body, ok);
+    IF ok THEN
+      out.LineSpan(stat.test.tSpan);
+      e.FallTrue(stat.test, lpLb); 
+    END; (* exit on eval true *)
+    out.CommentT("Loop exit");
+  END EmitRepeat;
+
+(* ---------------------------------------------------- *)
+
+  PROCEDURE (e : MsilEmitter)
+                        EmitFor(stat : St.ForLoop; OUT ok : BOOLEAN),NEW;
+   (* ----------------------------------------------------------- *
+    *   This code has been split into the four cases:
+    *   - long control variable, counting up;
+    *   - long control variable, counting down;
+    *   - int control variable, counting up;
+    *   - int control variable, counting down;
+    *   Of course, it is possible to fold all of this, and have
+    *   tests everywhere, but the following is cleaner, and easier
+    *   to enhance in the future.
+    *
+    *   Note carefully the use of ForLoop::isSimple().  It is
+    *   essential to use exactly the same function here as is
+    *   used by ForLoop::flowAttr() for initialization analysis.
+    *   If this were not the case, the verifier could barf.
+    *
+    *   23 August 2001 -- correcting error when reference
+    *   param is used as a FOR-loop control variable (kjg)
+    *
+    *   07 February 2002 -- correcting error when control
+    *   variable is stored in an XHR (uplevel) record (kjg)
+    * ----------------------------------------------------------- *)
+    PROCEDURE LongForUp(e: MsilEmitter; stat: St.ForLoop; OUT ok: BOOLEAN);
+      VAR out  : Mu.MsilFile;
+          cVar : Id.AbVar;
+          step : LONGINT;
+          smpl : BOOLEAN;
+          isRP : BOOLEAN;
+          isUl : BOOLEAN;        (* ==> cVar is an uplevel local var. *)
+          indr : BOOLEAN;        (* ==> cVar is indirectly accessed   *)
+          tmpL : INTEGER;
+          topL : INTEGER;
+          exLb : Mu.Label;
+          lpLb : Mu.Label;
+    BEGIN
+      out := e.outF;
+      lpLb := out.newLabel();
+      exLb := out.newLabel();
+      cVar := stat.cVar(Id.AbVar);
+      step := longValue(stat.byXp); 
+      smpl := stat.isSimple();
+      isRP := (cVar IS Id.ParId) & (cVar(Id.ParId).boxOrd # Sy.val);
+      isUl := (cVar IS Id.LocId) & (Id.uplevA IN cVar(Id.LocId).locAtt);
+      indr := isRP OR isUl;
+
+      IF indr THEN
+        tmpL := out.proc.newLocal(Bi.lIntTp);
+      ELSE
+        tmpL := -1;                        (* keep the verifier happy! *)
+      END;
+      IF ~smpl THEN
+        topL := out.proc.newLocal(Bi.lIntTp);
+      ELSE
+        topL := -1;                        (* keep the verifier happy! *)
+      END;
+
+      IF smpl THEN
+        IF isRP THEN 
+          out.PushArg(cVar.varOrd);
+        ELSIF isUl THEN 
+          out.XhrHandle(cVar(Id.LocId));
+        END;
+        out.PushLong(longValue(stat.loXp));
+        out.PutVar(cVar);
+      ELSE
+        e.PushValue(stat.hiXp, Bi.lIntTp);
+        out.Code(Asm.opc_dup);
+        out.StoreLocal(topL);
+        IF isRP THEN 
+          out.PushArg(cVar.varOrd);
+        ELSIF isUl THEN 
+          out.XhrHandle(cVar(Id.LocId));
+        END;
+        e.PushValue(stat.loXp, Bi.lIntTp);
+        out.Code(Asm.opc_dup);
+        IF indr THEN out.StoreLocal(tmpL) END;
+        out.PutVar(cVar);
+        IF indr THEN out.PushLocal(tmpL) END;
+       (*
+        *   The top test is NEVER inside the loop.
+        *)
+        e.DoCmp(Xp.lessT, exLb, Bi.lIntTp);
+      END;
+      out.DefLabC(lpLb, "Loop header");
+     (*
+      *   Emit the code body.
+      *   Stack contents are (top) hi, ...
+      *   and exactly the same on the backedge.
+      *)
+      e.EmitStat(stat.body, ok);
+     (*
+      *   If the body returns ... do an exit test.
+      *)
+      IF ok THEN 
+        IF smpl THEN
+          out.PushLong(longValue(stat.hiXp));
+        ELSE
+          out.PushLocal(topL);
+        END;
+        IF isRP THEN 
+          out.PushArg(cVar.varOrd);
+        ELSIF isUl THEN 
+          out.XhrHandle(cVar(Id.LocId));
+        END;
+        out.GetVar(cVar);                       (* (top) cv,hi       *)
+        out.PushLong(step);
+        out.Code(Asm.opc_add_ovf);              (* (top) cv',hi      *)
+        out.Code(Asm.opc_dup);                  (* (top) cv',cv',hi  *)
+        IF indr THEN out.StoreLocal(tmpL) END;
+        out.PutVar(cVar);                       (* (top) cv',hi      *)
+        IF indr THEN out.PushLocal(tmpL) END;
+        e.DoCmp(Xp.greEq,  lpLb, Bi.lIntTp);
+      END;
+      IF indr THEN out.proc.ReleaseLocal(tmpL) END;
+      IF ~smpl THEN out.proc.ReleaseLocal(topL) END;
+     (*
+      *   The exit label.
+      *)
+      out.DefLabC(exLb, "Loop trailer");
+    END LongForUp;
+
+   (* ----------------------------------------- *)
+
+    PROCEDURE LongForDn(e: MsilEmitter; stat: St.ForLoop; OUT ok: BOOLEAN);
+      VAR out  : Mu.MsilFile;
+          cVar : Id.AbVar;
+          tmpL : INTEGER;
+          topL : INTEGER;
+          step : LONGINT;
+          smpl : BOOLEAN;
+          isRP : BOOLEAN;
+          isUl : BOOLEAN;        (* ==> cVar is an uplevel local var. *)
+          indr : BOOLEAN;        (* ==> cVar is indirectly accessed   *)
+          exLb : Mu.Label;
+          lpLb : Mu.Label;
+    BEGIN
+      out := e.outF;
+      lpLb := out.newLabel();
+      exLb := out.newLabel();
+      cVar := stat.cVar(Id.AbVar);
+      step := longValue(stat.byXp);
+      smpl := stat.isSimple();
+      isRP := (cVar IS Id.ParId) & (cVar(Id.ParId).boxOrd # Sy.val);
+      isUl := (cVar IS Id.LocId) & (Id.uplevA IN cVar(Id.LocId).locAtt);
+      indr := isRP OR isUl;
+
+      IF indr THEN
+        tmpL := out.proc.newLocal(Bi.lIntTp);
+      ELSE
+        tmpL := -1;                        (* keep the verifier happy! *)
+      END;
+      IF ~smpl THEN
+        topL := out.proc.newLocal(Bi.lIntTp);
+      ELSE
+        topL := -1;                        (* keep the verifier happy! *)
+      END;
+
+      IF smpl THEN
+        IF isRP THEN 
+          out.PushArg(cVar.varOrd);
+        ELSIF isUl THEN 
+          out.XhrHandle(cVar(Id.LocId));
+        END;
+        out.PushLong(longValue(stat.loXp));
+        out.PutVar(cVar);
+      ELSE
+        e.PushValue(stat.hiXp, Bi.lIntTp);
+        out.Code(Asm.opc_dup);
+        out.StoreLocal(topL);
+        IF isRP THEN 
+          out.PushArg(cVar.varOrd);
+        ELSIF isUl THEN 
+          out.XhrHandle(cVar(Id.LocId));
+        END;
+        e.PushValue(stat.loXp, Bi.lIntTp);
+        out.Code(Asm.opc_dup);
+        IF indr THEN  out.StoreLocal(tmpL) END;
+        out.PutVar(cVar);
+        IF indr THEN out.PushLocal(tmpL) END;
+       (*
+        *   The top test is NEVER inside the loop.
+        *)
+        e.DoCmp(Xp.greT,  exLb, Bi.lIntTp);
+      END;
+      out.DefLabC(lpLb, "Loop header");
+     (*
+      *   Emit the code body.
+      *   Stack contents are (top) hi, ...
+      *   and exactly the same on the backedge.
+      *)
+      e.EmitStat(stat.body, ok);
+     (*
+      *   If the body returns ... do an exit test.
+      *)
+      IF ok THEN 
+        IF smpl THEN
+          out.PushLong(longValue(stat.hiXp));
+        ELSE
+          out.PushLocal(topL);
+        END;
+        IF isRP THEN 
+          out.PushArg(cVar.varOrd);
+        ELSIF isUl THEN 
+          out.XhrHandle(cVar(Id.LocId));
+        END;
+        out.GetVar(cVar);                      (* (top) cv,hi      *)
+        out.PushLong(step);
+        out.Code(Asm.opc_add_ovf);             (* (top) cv',hi     *)
+        out.Code(Asm.opc_dup);                 (* (top) cv',cv',hi *)
+        IF indr THEN out.StoreLocal(tmpL) END;
+        out.PutVar(cVar);                      (* (top) cv',hi     *)
+        IF indr THEN out.PushLocal(tmpL) END;
+        e.DoCmp(Xp.lessEq, lpLb, Bi.lIntTp);
+      END;
+      IF indr THEN out.proc.ReleaseLocal(tmpL) END;
+      IF ~smpl THEN out.proc.ReleaseLocal(topL) END;
+     (*
+      *   The exit label.
+      *)
+      out.DefLabC(exLb, "Loop trailer");
+    END LongForDn;
+
+   (* ----------------------------------------- *)
+
+    PROCEDURE IntForUp(e: MsilEmitter; stat: St.ForLoop; OUT ok: BOOLEAN);
+      VAR out  : Mu.MsilFile;
+          cVar : Id.AbVar;
+          topV : INTEGER;
+          tmpV : INTEGER;
+          step : INTEGER;
+          smpl : BOOLEAN;
+          isRP : BOOLEAN;        (* ==> cVar is a reference parameter *)
+          isUl : BOOLEAN;        (* ==> cVar is an uplevel local var. *)
+          indr : BOOLEAN;        (* ==> cVar is indirectly accessed   *)
+          exLb : Mu.Label;
+          lpLb : Mu.Label;
+    BEGIN
+     (*
+      *    This is the common case, so we work a bit harder.
+      *)
+      out := e.outF;
+      lpLb := out.newLabel();
+      exLb := out.newLabel();
+      cVar := stat.cVar(Id.AbVar);
+      step := intValue(stat.byXp);
+      smpl := stat.isSimple();
+      isRP := (cVar IS Id.ParId) & (cVar(Id.ParId).boxOrd # Sy.val);
+      isUl := (cVar IS Id.LocId) & (Id.uplevA IN cVar(Id.LocId).locAtt);
+      indr := isRP OR isUl;
+
+      IF indr THEN
+        tmpV := out.proc.newLocal(Bi.intTp);
+      ELSE
+        tmpV := -1;                        (* keep the verifier happy! *)
+      END;
+      IF ~smpl THEN
+        topV := out.proc.newLocal(Bi.intTp);
+      ELSE
+        topV := -1;                        (* keep the verifier happy! *)
+      END;
+
+      IF smpl THEN
+        IF isRP THEN 
+          out.PushArg(cVar.varOrd);
+        ELSIF isUl THEN 
+          out.XhrHandle(cVar(Id.LocId));
+        END;
+        out.PushInt(intValue(stat.loXp));
+        out.PutVar(cVar);
+      ELSE
+        e.PushValue(stat.hiXp, Bi.intTp);
+        out.Code(Asm.opc_dup);
+        out.StoreLocal(topV);
+        IF isRP THEN
+          out.PushArg(cVar.varOrd);
+        ELSIF isUl THEN
+          out.XhrHandle(cVar(Id.LocId));
+        END;
+        e.PushValue(stat.loXp, Bi.intTp);
+        out.Code(Asm.opc_dup);
+        IF indr THEN out.StoreLocal(tmpV) END;
+        out.PutVar(cVar);
+        IF indr THEN out.PushLocal(tmpV) END;
+       (*
+        *   The top test is NEVER inside the loop.
+        *)
+        e.DoCmp(Xp.lessT, exLb, Bi.intTp);
+      END;
+      out.DefLabC(lpLb, "Loop header");
+     (*
+      *   Emit the code body.
+      *)
+      e.EmitStat(stat.body, ok);
+     (*
+      *   If the body returns ... do an exit test.
+      *)
+      IF ok THEN 
+        IF smpl THEN
+          out.PushInt(intValue(stat.hiXp));
+        ELSE
+          out.PushLocal(topV);
+        END;
+        IF isRP THEN 
+          out.PushArg(cVar.varOrd);
+        ELSIF isUl THEN 
+          out.XhrHandle(cVar(Id.LocId));
+        END;
+        out.GetVar(cVar);                       (* (top) cv,hi       *)
+        out.PushInt(step);
+        out.Code(Asm.opc_add_ovf);              (* (top) cv',hi      *)
+        out.Code(Asm.opc_dup);                  (* (top) cv',cv',hi  *)
+        IF indr THEN out.StoreLocal(tmpV) END;
+        out.PutVar(cVar);                       (* (top) cv',hi      *)
+        IF indr THEN out.PushLocal(tmpV) END;
+        e.DoCmp(Xp.greEq, lpLb, Bi.intTp);
+      END;
+      IF indr THEN out.proc.ReleaseLocal(tmpV) END;
+      IF ~smpl THEN out.proc.ReleaseLocal(topV) END;
+     (*
+      *   The exit label.
+      *)
+      out.DefLabC(exLb, "Loop trailer");
+    END IntForUp;
+  
+   (* ----------------------------------------- *)
+
+    PROCEDURE IntForDn(e: MsilEmitter; stat: St.ForLoop; OUT ok: BOOLEAN);
+      VAR out  : Mu.MsilFile;
+          cVar : Id.AbVar;
+          tmpV : INTEGER;
+          topV : INTEGER;
+          step : INTEGER;
+          smpl : BOOLEAN;
+          isRP : BOOLEAN;        (* ==> cVar is a reference parameter *)
+          isUl : BOOLEAN;        (* ==> cVar is an uplevel local var. *)
+          indr : BOOLEAN;        (* ==> cVar is indirectly accessed   *)
+          exLb : Mu.Label;
+          lpLb : Mu.Label;
+    BEGIN
+      out := e.outF;
+      lpLb := out.newLabel();
+      exLb := out.newLabel();
+      cVar := stat.cVar(Id.AbVar);
+      step := intValue(stat.byXp);
+      smpl := stat.isSimple();
+      isRP := (cVar IS Id.ParId) & (cVar(Id.ParId).boxOrd # Sy.val);
+      isUl := (cVar IS Id.LocId) & (Id.uplevA IN cVar(Id.LocId).locAtt);
+      indr := isRP OR isUl;
+
+      IF indr THEN
+        tmpV := out.proc.newLocal(Bi.intTp);
+      ELSE
+        tmpV := -1;                        (* keep the verifier happy! *)
+      END;
+      IF ~smpl THEN
+        topV := out.proc.newLocal(Bi.intTp);
+      ELSE
+        topV := -1;                        (* keep the verifier happy! *)
+      END;
+
+      IF smpl THEN
+        IF isRP THEN 
+          out.PushArg(cVar.varOrd);
+        ELSIF isUl THEN 
+          out.XhrHandle(cVar(Id.LocId));
+        END;
+        out.PushInt(intValue(stat.loXp));
+        out.PutVar(cVar);
+      ELSE
+        e.PushValue(stat.hiXp, Bi.intTp);
+        out.Code(Asm.opc_dup);
+        out.StoreLocal(topV);
+        IF isRP THEN
+          out.PushArg(cVar.varOrd);
+        ELSIF isUl THEN
+          out.XhrHandle(cVar(Id.LocId));
+        END;
+        e.PushValue(stat.loXp, Bi.intTp);
+        out.Code(Asm.opc_dup);
+        IF indr THEN out.StoreLocal(tmpV) END;
+        out.PutVar(cVar);
+        IF indr THEN out.PushLocal(tmpV) END;
+       (*
+        *   The top test is NEVER inside the loop.
+        *)
+        e.DoCmp(Xp.greT, exLb, Bi.intTp);
+      END;
+      out.DefLabC(lpLb, "Loop header");
+     (*
+      *   Emit the code body.
+      *)
+      e.EmitStat(stat.body, ok);
+     (*
+      *   If the body returns ... do an exit test.
+      *)
+      IF ok THEN 
+      IF smpl THEN
+          out.PushInt(intValue(stat.hiXp));
+      ELSE
+          out.PushLocal(topV);
+      END;
+        IF isRP THEN 
+          out.PushArg(cVar.varOrd);
+        ELSIF isUl THEN
+          out.XhrHandle(cVar(Id.LocId));
+        END;
+        out.GetVar(cVar);                       (* (top) cv,hi       *)
+        out.PushInt(step);
+        out.Code(Asm.opc_add_ovf);              (* (top) cv',hi      *)
+        out.Code(Asm.opc_dup);                  (* (top) cv',cv',hi  *)
+        IF indr THEN out.StoreLocal(tmpV) END;
+        out.PutVar(cVar);                       (* (top) cv',hi      *)
+        IF indr THEN out.PushLocal(tmpV) END;
+        e.DoCmp(Xp.lessEq, lpLb, Bi.intTp);
+      END;
+      IF indr THEN out.proc.ReleaseLocal(tmpV) END;
+      IF ~smpl THEN out.proc.ReleaseLocal(topV) END;
+     (*
+      *   The exit label.
+      *)
+      out.DefLabC(exLb, "Loop trailer");
+    END IntForDn;
+
+   (* ----------------------------------------- *)
+  BEGIN (* body of EmitFor *)
+    IF stat.cVar.type.isLongType() THEN
+      IF longValue(stat.byXp) > 0 THEN LongForUp(e, stat, ok);
+      ELSE LongForDn(e, stat, ok);
+      END;
+    ELSE
+      IF longValue(stat.byXp) > 0 THEN IntForUp(e, stat, ok);
+      ELSE IntForDn(e, stat, ok);
+      END;
+    END;
+  END EmitFor;
+
+(* ---------------------------------------------------- *)
+
+  PROCEDURE (e : MsilEmitter)
+                        EmitLoop(stat : St.TestLoop; OUT ok : BOOLEAN),NEW;
+    VAR out  : Mu.MsilFile;
+        lpLb : Mu.Label;
+        exLb : Mu.Label;
+  BEGIN
+    out := e.outF;
+    lpLb := out.newLabel();
+    exLb := out.newLabel();
+    stat.tgLbl := exLb;
+    out.DefLabC(lpLb, "Loop header");
+    e.EmitStat(stat.body, ok);
+    IF ok THEN out.CodeLb(Asm.opc_br, lpLb) END;
+    out.DefLabC(exLb, "Loop exit");
+  END EmitLoop;
+
+(* ---------------------------------------------------- *)
+
+  PROCEDURE (e : MsilEmitter)
+                        EmitWith(stat : St.Choice; OUT ok : BOOLEAN),NEW;
+    VAR out  : Mu.MsilFile;
+        high : INTEGER;     (* Branch count.  *)
+        indx : INTEGER;
+        live : BOOLEAN;
+        then : Sy.Stmt;
+        pred : Xp.BinaryX;
+        tVar : Id.LocId;
+        exLb : Mu.Label;   (* Exit label     *)
+        nxtP : Mu.Label;   (* Next predicate *)
+   (* --------------------------- *)
+    PROCEDURE WithTest(je : MsilEmitter;
+                       os : Mu.MsilFile;
+                       pr : Xp.BinaryX;
+                       nx : Mu.Label;
+                       to : INTEGER);
+                   VAR ty : Sy.Type;
+    BEGIN
+      ty := pr.rKid(Xp.IdLeaf).ident.type;
+      je.PushValue(pr.lKid, pr.lKid.type);
+      os.CodeT(Asm.opc_isinst, ty);
+     (*
+      *  isinst returns the cast type, or NIL
+      *  We save this to the allocated temp or needed type.
+      *)
+      os.StoreLocal(to);
+      os.PushLocal(to);
+      os.CodeLb(Asm.opc_brfalse, nx);  (* branch on NIL *)
+    END WithTest;
+   (* --------------------------- *)
+  BEGIN
+    tVar := NIL;
+    pred := NIL;
+    ok := FALSE;
+    out := e.outF;
+    exLb := out.newLabel();
+    high := stat.preds.tide - 1;
+    IF CSt.debug THEN out.Code(Asm.opc_nop) END;
+    FOR indx := 0 TO high DO
+      live := TRUE;
+      then := stat.blocks.a[indx];
+      pred := stat.preds.a[indx](Xp.BinaryX);
+      tVar := stat.temps.a[indx](Id.LocId);
+      nxtP := out.newLabel();
+      IF pred # NIL THEN
+        tVar.varOrd := out.proc.newLocal(tVar.type);
+        WithTest(e, out, pred, nxtP, tVar.varOrd);
+      END;
+      IF then # NIL THEN e.EmitStat(then, live) END;
+      IF live THEN
+        ok := TRUE;
+       (*
+        *  If this is not the else case, skip over the
+        *  later cases, or jump over the WITH ELSE trap.
+        *)
+        IF pred # NIL THEN out.CodeLb(Asm.opc_br, exLb) END;
+      END;
+      out.DefLab(nxtP);
+      IF tVar # NIL THEN out.proc.ReleaseLocal(tVar.varOrd) END;
+    END;
+    IF pred # NIL THEN out.WithTrap(pred(Xp.BinaryX).lKid(Xp.IdLeaf).ident) END;
+    out.DefLab(exLb);
+  END EmitWith;
+
+(* ---------------------------------------------------- *)
+
+  PROCEDURE (e : MsilEmitter)EmitExit(stat : St.ExitSt),NEW;
+  BEGIN
+    e.outF.CodeLb(Asm.opc_br, stat.loop(St.TestLoop).tgLbl(Mu.Label));
+  END EmitExit;
+
+(* ---------------------------------------------------- *)
+
+  PROCEDURE (e : MsilEmitter)EmitReturn(stat : St.Return),NEW;
+    VAR out : Mu.MsilFile;
+        ret : Sy.Expr;
+  BEGIN
+    out := e.outF;
+    IF CSt.debug THEN
+      out.Code(Asm.opc_nop);
+      out.LineSpan(stat.prId(Id.Procs).endSpan);
+    END;
+    ret := stat.retX;
+    IF (stat.retX # NIL) & 
+       (out.proc.prId.kind # Id.ctorP) THEN e.PushValue(ret, ret.type) END;
+    out.DoReturn;
+  END EmitReturn;
+
+(* ---------------------------------------------------- *)
+
+  PROCEDURE (e : MsilEmitter)
+                        EmitBlock(stat : St.Block; OUT ok : BOOLEAN),NEW;
+    VAR index, limit : INTEGER;
+  BEGIN
+    ok := TRUE;
+    index := 0;
+    limit := stat.sequ.tide;
+    WHILE ok & (index < limit) DO
+      e.EmitStat(stat.sequ.a[index], ok);
+      INC(index);
+    END;
+  END EmitBlock;
+
+(* ---------------------------------------------------- *)
+(* ---------------------------------------------------- *)
+
+  PROCEDURE (e : MsilEmitter)EmitStat(stat : Sy.Stmt; OUT ok : BOOLEAN),NEW;
+    VAR depth : INTEGER;
+        out   : Mu.MsilFile;
+  BEGIN
+    IF (stat = NIL) OR (stat.kind = St.emptyS) THEN ok := TRUE; RETURN END;
+    out := e.outF;
+    out.LineSpan(stat.Span());
+    depth := out.proc.getDepth();
+    CASE stat.kind OF
+    | St.assignS  : e.EmitAssign(stat(St.Assign)); ok := TRUE;
+    | St.procCall : e.EmitCall(stat(St.ProcCall)); ok := TRUE;
+    | St.ifStat   : e.EmitIf(stat(St.Choice), ok);
+    | St.caseS    : e.EmitCase(stat(St.CaseSt), ok);
+    | St.whileS   : e.EmitWhile(stat(St.TestLoop), ok);
+    | St.repeatS  : e.EmitRepeat(stat(St.TestLoop), ok);
+    | St.forStat  : e.EmitFor(stat(St.ForLoop), ok);
+    | St.loopS    : e.EmitLoop(stat(St.TestLoop), ok);
+    | St.withS    : e.EmitWith(stat(St.Choice), ok);
+    | St.exitS    : e.EmitExit(stat(St.ExitSt)); ok := TRUE;
+    | St.returnS  : e.EmitReturn(stat(St.Return)); ok := FALSE;
+    | St.blockS   : e.EmitBlock(stat(St.Block), ok);
+    END;
+    IF CSt.verbose & (depth # out.proc.getDepth()) THEN
+          out.Comment("Depth adjustment") END;
+    out.proc.SetDepth(depth);
+  END EmitStat;
+
+(* ============================================================ *)
+(* ============================================================ *)
+END MsilMaker.
+(* ============================================================ *)
+(* ============================================================ *)

gpcp/MsilUtil.cp

@@ -0,0 +1,2673 @@
+(* ============================================================ *)
+(*  MsilUtil is the module which writes ILASM file structures   *)
+(*  Copyright (c) John Gough 1999, 2000.                        *)
+(* ============================================================ *)
+
+MODULE MsilUtil;
+
+  IMPORT 
+        GPCPcopyright,
+        RTS, 
+        Console,
+        MsilBase,
+        NameHash,
+        Scn := CPascalS,
+        CSt := CompState,
+        Lv  := LitValue,
+        Sy  := Symbols,
+        Bi  := Builtin,
+        Id  := IdDesc,
+        Ty  := TypeDesc,
+        Asm := IlasmCodes;
+
+(* ============================================================ *)
+
+   CONST
+        (* various ILASM-specific runtime name strings *)
+        initString  = ".ctor";
+
+   CONST
+       (* Conversions from System.String to char[]    *)
+        vStr2ChO*  = 1;
+        vStr2ChF*  = 2;
+       (* Runtime support for CP's MOD,DIV operations *)
+        sysExit*    = 3;
+        toUpper*    = 4;
+        dFloor*     = 5;
+        dAbs*       = 6;
+        fAbs*       = 7;
+        iAbs*       = 8;
+        lAbs*       = 9;
+        getTpM*     = 10;
+        CpModI*     = 11;
+        CpDivI*     = 12;
+        CpModL*     = 13;
+        CpDivL*     = 14;
+       (* various ILASM-specific runtime name strings *)
+        aStrLen*    = 15;
+        aStrChk*    = 16;
+        aStrLp1*    = 17;
+        aaStrCmp*   = 18;
+        aaStrCopy*  = 19;
+       (* Error reporting facilities ................ *)
+        caseMesg*   = 20;
+        withMesg*   = 21;
+        mkExcept*   = 22;
+       (* Conversions from char[] to System.String    *)
+        chs2Str*    =  23;
+       (* various CPJ-specific concatenation helpers  *)
+        CPJstrCatAA*   = 24;
+        CPJstrCatSA*   = 25;
+        CPJstrCatAS*   = 26;
+        CPJstrCatSS*   = 27;
+        rtsLen*        = 28;
+
+(* ============================================================ *)
+(* ============================================================ *)
+
+  TYPE Label*     = POINTER TO ABSTRACT RECORD END;
+       LbArr*     = POINTER TO ARRAY OF Label;
+
+  TYPE ProcInfo*  = POINTER TO (* EXTENSIBLE *) RECORD
+                      prId- : Sy.Scope; (* mth., prc. or mod.   *)
+                      rtLc* : INTEGER;  (* return value local # *)
+                      (* ---- depth tracking ------ *)
+                      dNum- : INTEGER;  (* current stack depth  *)
+                      dMax- : INTEGER;  (* maximum stack depth  *)
+                      (* ---- temp-var manager ---- *)
+                      lNum- : INTEGER;         (* prog vars     *)
+                      tLst- : Sy.TypeSeq;      (* type list     *)
+                      fLst- : Sy.TypeSeq;      (* free list     *)
+                      (* ---- end temp manager ---- *)
+                      exLb* : Label;    (* exception exit label *)
+                    END;
+
+(* ============================================================ *)
+
+  TYPE MsilFile* =  POINTER TO ABSTRACT RECORD
+                      srcS* : Lv.CharOpen;(* source file name   *)
+                      outN* : Lv.CharOpen;
+                      proc* : ProcInfo;
+                    END;
+
+(* ============================================================ *)
+
+  VAR   nmArray   : Lv.CharOpenSeq;
+
+
+  VAR   lPar, rPar, lBrk,               (* ( ) {    *)
+        rBrk, dotS, rfMk,               (* } . &    *)
+        atSg, cmma,                     (* @ ,      *)
+        vFld,                           (* "v$"     *)
+        brks,                           (* "[]"     *)
+        rtsS,                           (* "RTS"    *)
+        prev,                           (* "prev"   *)
+        body,                           (* ".body"  *)
+        ouMk : Lv.CharOpen;             (* "[out]"  *)
+
+        evtAdd, evtRem : Lv.CharOpen;
+        pVarSuffix     : Lv.CharOpen;
+        xhrMk          : Lv.CharOpen;
+        xhrDl          : Lv.CharOpen;
+        vecPrefix      : Lv.CharOpen;
+
+  VAR   boxedObj  : Lv.CharOpen;
+        corlibAsm : Lv.CharOpen;
+        xhrIx     : INTEGER;
+
+(* ============================================================ *)
+
+  VAR   vecBlkId  : Id.BlkId;
+        vecBase   : Id.TypId;
+        vecTypes  : ARRAY Ty.anyPtr+1 OF Id.TypId; (* pointers *)
+        vecTide   : Id.FldId;
+        vecElms   : ARRAY Ty.anyPtr+1 OF Id.FldId;
+        vecExpnd  : ARRAY Ty.anyPtr+1 OF Id.MthId;
+
+(* ============================================================ *)
+
+  VAR   typeGetE  : ARRAY 16 OF INTEGER;
+        typePutE  : ARRAY 16 OF INTEGER;
+        typeStInd : ARRAY 16 OF INTEGER;
+        typeLdInd : ARRAY 16 OF INTEGER;
+
+(* ============================================================ *)
+
+  PROCEDURE (t : MsilFile)fileOk*() : BOOLEAN,NEW,ABSTRACT;
+  (* Test if file was opened successfully *)
+
+(* ============================================================ *)
+(*   EMPTY text format Procedures only overidden in IlasmUtil   *)
+(* ============================================================ *)
+
+  PROCEDURE (os : MsilFile)MkNewProcInfo*(s : Sy.Scope),NEW,ABSTRACT;
+  PROCEDURE (os : MsilFile)Comment*(IN s : ARRAY OF CHAR),NEW,EMPTY;
+  PROCEDURE (os : MsilFile)CommentT*(IN s : ARRAY OF CHAR),NEW,EMPTY;
+  PROCEDURE (os : MsilFile)OpenBrace*(i : INTEGER),NEW,EMPTY;
+  PROCEDURE (os : MsilFile)CloseBrace*(i : INTEGER),NEW,EMPTY;
+  PROCEDURE (os : MsilFile)Blank*(),NEW,EMPTY;
+
+(* ============================================================ *)
+(*       ABSTRACT Procedures overidden in both subclasses       *)
+(* ============================================================ *)
+(*       Various code emission methods                          *)
+(* ============================================================ *)
+
+  PROCEDURE (os : MsilFile)Code*(code : INTEGER),NEW,ABSTRACT;
+
+  PROCEDURE (os : MsilFile)CodeI*(code,int : INTEGER),NEW,ABSTRACT;
+
+  PROCEDURE (os : MsilFile)CodeT*(code : INTEGER; type : Sy.Type),NEW,ABSTRACT;
+
+  PROCEDURE (os : MsilFile)CodeTn*(code : INTEGER; type : Sy.Type),NEW,ABSTRACT;
+
+  PROCEDURE (os : MsilFile)CodeL*(code : INTEGER; long : LONGINT),NEW,ABSTRACT;
+
+  PROCEDURE (os : MsilFile)CodeR*(code : INTEGER; real : REAL),NEW,ABSTRACT;
+
+  PROCEDURE (os : MsilFile)CodeLb*(code : INTEGER; i2 : Label),NEW,ABSTRACT;
+
+  PROCEDURE (os : MsilFile)CodeS*(code : INTEGER; 
+                                  str  : INTEGER),NEW,ABSTRACT;
+
+  PROCEDURE (os : MsilFile)MkNewRecord*(typ : Ty.Record),NEW,ABSTRACT;
+  (* emit constructor call ... *)
+
+  PROCEDURE (os : MsilFile)LoadType*(id : Sy.Idnt),NEW,ABSTRACT;
+  (* load runtime type descriptor *)
+
+  PROCEDURE (os : MsilFile)PushStr*(IN str : ARRAY OF CHAR),NEW,ABSTRACT;
+  (* load a literal string *)
+
+  PROCEDURE (os : MsilFile)NumberParams*(pId : Id.Procs; 
+                                         pTp : Ty.Procedure),NEW,ABSTRACT;
+
+  PROCEDURE (os : MsilFile)Finish*(),NEW,ABSTRACT;
+
+(* ============================================================ *)
+
+  PROCEDURE (os : MsilFile)MkBodyClass*(mod : Id.BlkId),NEW,ABSTRACT;
+  PROCEDURE (os : MsilFile)ClassHead*(attSet : SET;
+                                      thisRc : Ty.Record;
+                                      superT : Ty.Record),NEW,ABSTRACT;
+  PROCEDURE (os : MsilFile)StartBoxClass*(rec : Ty.Record;
+                                          att : SET;
+                                          blk : Id.BlkId),NEW,ABSTRACT;
+  PROCEDURE (os : MsilFile)ClassTail*(),NEW,EMPTY;
+
+(* ============================================================ *)
+
+  PROCEDURE (os : MsilFile)StartNamespace*(nm : Lv.CharOpen),NEW,ABSTRACT;
+  PROCEDURE (os : MsilFile)RefRTS*(),NEW,ABSTRACT;
+
+  PROCEDURE (os : MsilFile)MkBasX*(t : Ty.Base),NEW,EMPTY;
+  PROCEDURE (os : MsilFile)MkArrX*(t : Ty.Array),NEW,EMPTY;
+  PROCEDURE (os : MsilFile)MkPtrX*(t : Ty.Pointer),NEW,EMPTY;
+  PROCEDURE (os : MsilFile)MkVecX*(t : Sy.Type; s : Id.BlkId),NEW,EMPTY;
+  PROCEDURE (os : MsilFile)MkEnuX*(t : Ty.Enum; s : Sy.Scope),NEW,EMPTY;
+  PROCEDURE (os : MsilFile)MkRecX*(t : Ty.Record; s : Sy.Scope),NEW,EMPTY;
+  PROCEDURE (os : MsilFile)AsmDef*(IN pkNm : ARRAY OF CHAR),NEW,EMPTY;
+  PROCEDURE (os : MsilFile)SubSys*(xAtt : SET),NEW,ABSTRACT;
+
+(* ============================================================ *)
+(*   Calling a static (usually runtime helper) method           *)
+(* ============================================================ *)
+
+  PROCEDURE (os : MsilFile)StaticCall*(s : INTEGER;
+                                       d : INTEGER),NEW,ABSTRACT;
+
+  PROCEDURE (os : MsilFile)CopyCall*(typ : Ty.Record),NEW,ABSTRACT;
+
+(* ============================================================ *)
+(*   Calling a user defined method, constructor or delegate     *)
+(* ============================================================ *)
+
+  PROCEDURE (os : MsilFile)CallIT*(code : INTEGER; 
+                                   proc : Id.Procs; 
+                                   type : Ty.Procedure),NEW,ABSTRACT;
+
+  PROCEDURE (os : MsilFile)CallCT*(proc : Id.Procs; 
+                                   type : Ty.Procedure),NEW,ABSTRACT;
+
+  PROCEDURE (os : MsilFile)CallDelegate*(typ : Ty.Procedure),NEW,ABSTRACT;
+
+
+(* ============================================================ *)
+(*   Various element access abstractions                        *)
+(* ============================================================ *)
+
+  PROCEDURE (os : MsilFile)PutGetS*(code : INTEGER;
+                                    blk  : Id.BlkId;
+                                    fld  : Id.VarId),NEW,ABSTRACT;
+
+  PROCEDURE (os : MsilFile)PutGetF*(code : INTEGER;
+                                    fld  : Id.FldId),NEW,ABSTRACT;
+
+  PROCEDURE (os : MsilFile)GetValObj*(code : INTEGER; 
+                                    ptrT : Ty.Pointer),NEW,ABSTRACT;
+
+  PROCEDURE (os : MsilFile)PutGetXhr*(code : INTEGER;
+                                      proc : Id.Procs;
+                                      locD : Id.LocId),NEW,ABSTRACT;
+
+(* ============================================================ *)
+(*   Line and Label handling                                    *)
+(* ============================================================ *)
+
+  PROCEDURE (os : MsilFile)Line*(nm : INTEGER),NEW,ABSTRACT;
+
+  PROCEDURE (os : MsilFile)LinePlus*(l,w : INTEGER),NEW,EMPTY;
+  
+  PROCEDURE (os : MsilFile)LineSpan*(span : Scn.Span),NEW,EMPTY; 
+
+  PROCEDURE (os : MsilFile)LstLab*(l : Label),NEW,ABSTRACT;
+
+  PROCEDURE (os : MsilFile)DefLab*(l : Label),NEW,ABSTRACT;
+
+  PROCEDURE (os : MsilFile)DefLabC*(l : Label; 
+                                 IN c : ARRAY OF CHAR),NEW,ABSTRACT;
+
+(* ============================================================ *)
+(*   Declaration utilities                                      *)
+(* ============================================================ *)
+
+  PROCEDURE (os : MsilFile)EmitField*(id : Id.AbVar; att : SET),NEW,ABSTRACT;
+
+  PROCEDURE (os : MsilFile)ExternList*(),NEW,ABSTRACT;
+
+  PROCEDURE (os : MsilFile)MarkInterfaces*(IN seq : Sy.TypeSeq),NEW,ABSTRACT;
+
+(* ============================================================ *)
+(*    Start and finish various structures                       *)
+(* ============================================================ *)
+
+  PROCEDURE (os : MsilFile)SwitchHead*(num : INTEGER),NEW,ABSTRACT;
+
+  PROCEDURE (os : MsilFile)SwitchTail*(),NEW,ABSTRACT;
+
+(* ------------------------------------------------------------ *)
+
+  PROCEDURE (os : MsilFile)Try*(),NEW,ABSTRACT;
+  PROCEDURE (os : MsilFile)Catch*(proc : Id.Procs),NEW,ABSTRACT;
+  PROCEDURE (os : MsilFile)CloseCatch*(),NEW,ABSTRACT;
+
+(* ------------------------------------------------------------ *)
+
+  PROCEDURE (os : MsilFile)MkNewProcVal*(p : Sy.Idnt; t : Sy.Type),NEW,ABSTRACT;
+
+(* ------------------------------------------------------------ *)
+
+  PROCEDURE (os : MsilFile)InitHead*(typ : Ty.Record;
+                                     prc : Id.PrcId),NEW,ABSTRACT;
+
+  PROCEDURE (os : MsilFile)CallSuper*(typ : Ty.Record;
+                                      prc : Id.PrcId),NEW,ABSTRACT;
+
+  PROCEDURE (os : MsilFile)InitTail*(typ : Ty.Record),NEW,ABSTRACT;
+
+(* ------------------------------------------------------------ *)
+
+  PROCEDURE (os : MsilFile)CopyHead*(typ : Ty.Record),NEW,ABSTRACT;
+
+  PROCEDURE (os : MsilFile)CopyTail*(),NEW,ABSTRACT;
+
+(* ------------------------------------------------------------ *)
+
+  PROCEDURE (os : MsilFile)MainHead*(xAtt : SET),NEW,ABSTRACT;
+
+  PROCEDURE (os : MsilFile)MainTail*(),NEW,ABSTRACT;
+
+(* ------------------------------------------------------------ *)
+
+  PROCEDURE (os : MsilFile)ClinitHead*(),NEW,ABSTRACT;
+
+  PROCEDURE (os : MsilFile)ClinitTail*(),NEW,ABSTRACT;
+
+(* ------------------------------------------------------------ *)
+
+  PROCEDURE (os : MsilFile)MethodDecl*(attr : SET; 
+                                       proc : Id.Procs),NEW,ABSTRACT;
+
+  PROCEDURE (os : MsilFile)MethodTail*(id : Id.Procs),NEW,ABSTRACT;
+
+(* ============================================================ *)
+(*       Start of Procedure Variable and Event Stuff            *)
+(* ============================================================ *)
+
+  PROCEDURE (os : MsilFile)EmitEventMethods*(id : Id.AbVar),NEW,ABSTRACT;
+
+  PROCEDURE (os : MsilFile)EmitPTypeBody*(tId : Id.TypId),NEW,ABSTRACT;
+
+  PROCEDURE (os : MsilFile)MkAndLinkDelegate*(dl : Sy.Idnt;
+                                              id : Sy.Idnt;
+                                              ty : Sy.Type;
+                                             add : BOOLEAN),NEW,ABSTRACT;
+
+(* ============================================================ *)
+(*            End of Procedure Variable and Event Stuff         *)
+(* ============================================================ *)
+
+(* ==================================================================== *
+ *             A word on naming for the ILASM version.                  *
+ * ==================================================================== *
+ *  Part one: module-level declarations, in Module Mmm.                 *
+ *              TYPE Ttt = POINTER TO RECORD ... END;                   *
+ *        has ilasm class name                                          *
+ *              .class <attr> Mmm.Ttt { ... }                           *
+ *        Similarly the static procedure                                *
+ *              PROCEDURE Ppp(); END Ppp;                               *
+ *        has ilasm method name (inside static class Mmm)               *
+ *              .method <attr> void Ppp() {...}                         *
+ *        which is referenced as                                        *
+ *              Ppp(...)                within the static class, &      *
+ *              Mmm::Ppp(...)           elswhere inside the module, &   *
+ *              [Mmm]Mmm::Ppp(...)      from outside the module.        *
+ *        Likewise, methods bound to Ttt will be referenced as          *
+ *              Ppp(...)                inside the dynamic class, &     *
+ *              Mmm.Ttt::Ppp(...)       elsewhere inside the module, &  *
+ *              [Mmm]Mmm.Ttt::Ppp(...)  from outside the module.        *
+ *                                                                      *
+ * ==================================================================== *
+ *  Part two: declarations nested inside procedure Outer (say).         *
+ *              PROCEDURE Ppp(); END Ppp;                               *
+ *        will have ilasm name (inside Mmm)                             *
+ *              .method <attr> void Outer@Ppp() {...}                   *
+ *        which is referenced as                                        *
+ *              Outer@Ppp(...)                                          *
+ *        Nested type Ttt will have name                                *
+ *              .struct(?) <attr> Mmm.Outer@Ttt {...}                   *
+ *        and cannot have type bound procedures, or be exported.        *
+ *                                                                      *
+ * ==================================================================== *
+ *  Where are these names stored?                                       *
+ *  The principle is: every identifier has its class name stored in     *
+ *  in d.scopeNm, and its simple name is stored in d.xName.             *
+ *  Thus, for names defined in this module:                             *
+ * ==================================================================== *
+ *        The name for BlkId Mmm is stored in desc.xName, as            *
+ *              desc.xName   = "Mmm"                                    *
+ *              desc.scopeNm = "Mmm"                                    *
+ *        The names for PrcId Ppp are stored as                         *
+ *              desc.xName   = "Ppp"                                    *
+ *              desc.scopeNm = "Mmm"                                    *
+ *        or in the nested case...                                      *
+ *              desc.xName   = "Outer@Ppp"                              *
+ *              desc.scopeNm = "Mmm"                                    *
+ *        The names for (non-nested) MthId Ppp are stored as            *
+ *              desc.xName   = "Ppp"                                    *
+ *              desc.scopeNm = "Mmm.Ttt"                                *
+ *                                                                      *
+ * For types, the names are stored thuswise.                            *
+ *        The name for Record descriptor Ttt will be                    *
+ *              recT.xName   = "Mmm_Ttt"                                *
+ *              recT.scopeNm = "Mmm_Ttt"                                *
+ *        or in the nested case ...                                     *
+ *              recT.xName   = "Mmm_Ppp@Ttt"                            *
+ *              recT.scopeNm = "Mmm_Ppp@Ttt"                            *
+ *                                                                      *
+ * ==================================================================== *
+ *  Where are these names stored?  For external names:                  *
+ * ==================================================================== *
+ *        The name for BlkId Mmm is stored in desc.xName, as            *
+ *              desc.xName   = "Mmm"                                    *
+ *              desc.scopeNm = "[Mmm]Mmm"                               *
+ *        The names for PrcId Ppp are stored as                         *
+ *              desc.xName   = "Ppp"                                    *
+ *              desc.scopeNm = "[Mmm]Mmm"                               *
+ *        The names for (non-nested) MthId Ppp are stored as            *
+ *              desc.xName   = "Ppp"                                    *
+ *              desc.scopeNm = "[Mmm]Mmm_Ttt"                           *
+ *                                                                      *
+ * For types, the names are stored thuswise.                            *
+ *        The name for Record descriptor Ttt will be                    *
+ *              recT.xName   = "Mmm_Ttt"                                *
+ *              recT.scopeNm = "[Mmm]Mmm_Ttt"                           *
+ * ==================================================================== *
+ * ==================================================================== *)
+
+
+(* ============================================================ *)
+(*                    Some static utilities                     *)
+(* ============================================================ *)
+
+  PROCEDURE cat2*(i,j : Lv.CharOpen) : Lv.CharOpen;
+  BEGIN
+    Lv.ResetCharOpenSeq(nmArray);
+    Lv.AppendCharOpen(nmArray, i);
+    Lv.AppendCharOpen(nmArray, j);
+    RETURN Lv.arrayCat(nmArray); 
+  END cat2;
+
+(* ============================================================ *)
+
+  PROCEDURE cat3*(i,j,k : Lv.CharOpen) : Lv.CharOpen;
+  BEGIN
+    Lv.ResetCharOpenSeq(nmArray);
+    Lv.AppendCharOpen(nmArray, i);
+    Lv.AppendCharOpen(nmArray, j);
+    Lv.AppendCharOpen(nmArray, k);
+    RETURN Lv.arrayCat(nmArray); 
+  END cat3;
+
+(* ============================================================ *)
+
+  PROCEDURE cat4*(i,j,k,l : Lv.CharOpen) : Lv.CharOpen;
+  BEGIN
+    Lv.ResetCharOpenSeq(nmArray);
+    Lv.AppendCharOpen(nmArray, i);
+    Lv.AppendCharOpen(nmArray, j);
+    Lv.AppendCharOpen(nmArray, k);
+    Lv.AppendCharOpen(nmArray, l);
+    RETURN Lv.arrayCat(nmArray); 
+  END cat4;
+
+(* ============================================================ *)
+
+  PROCEDURE mapVecElTp(typ : Sy.Type) : INTEGER;
+  BEGIN
+    WITH typ : Ty.Base DO
+      CASE typ.tpOrd OF
+      | Ty.sChrN : RETURN Ty.charN;
+      | Ty.boolN, Ty.byteN, Ty.sIntN, Ty.setN, Ty.uBytN : RETURN Ty.intN;
+      | Ty.charN, Ty.intN, Ty.lIntN, Ty.sReaN, Ty.realN : RETURN typ.tpOrd;
+      ELSE RETURN Ty.anyPtr;
+      END;
+    ELSE RETURN Ty.anyPtr;
+    END;
+  END mapVecElTp;
+
+
+  PROCEDURE mapOrdRepT(ord : INTEGER) : Sy.Type;
+  BEGIN
+    CASE ord OF
+    | Ty.charN  : RETURN Bi.charTp;
+    | Ty.intN   : RETURN Bi.intTp;
+    | Ty.lIntN  : RETURN Bi.lIntTp;
+    | Ty.sReaN  : RETURN Bi.sReaTp;
+    | Ty.realN  : RETURN Bi.realTp;
+    | Ty.anyPtr : RETURN Bi.anyPtr;
+    END;
+  END mapOrdRepT;
+
+(* ============================================================ *)
+
+  PROCEDURE^ MkProcName*(proc : Id.Procs; os : MsilFile);
+  PROCEDURE^ MkAliasName*(typ : Ty.Opaque; os : MsilFile);
+  PROCEDURE^ MkEnumName*(typ : Ty.Enum; os : MsilFile);
+  PROCEDURE^ MkTypeName*(typ : Sy.Type; fil : MsilFile);
+  PROCEDURE^ MkRecName*(typ : Ty.Record; os : MsilFile);
+  PROCEDURE^ MkPtrName*(typ : Ty.Pointer; os : MsilFile);
+  PROCEDURE^ MkPTypeName*(typ : Ty.Procedure; os : MsilFile);
+  PROCEDURE^ MkIdName*(id : Sy.Idnt; os : MsilFile);
+  PROCEDURE^ MkBasName(typ : Ty.Base; os : MsilFile);
+  PROCEDURE^ MkArrName(typ : Ty.Array; os : MsilFile);
+  PROCEDURE^ MkVecName(typ : Ty.Vector; os : MsilFile);
+
+  PROCEDURE^ (os : MsilFile)PutUplevel*(var : Id.LocId),NEW;
+  PROCEDURE^ (os : MsilFile)PushInt*(num : INTEGER),NEW;
+  PROCEDURE^ (os : MsilFile)GetVar*(id : Sy.Idnt),NEW;
+  PROCEDURE^ (os : MsilFile)GetVarA*(id : Sy.Idnt),NEW;
+  PROCEDURE^ (os : MsilFile)PushLocal*(ord : INTEGER),NEW;
+  PROCEDURE^ (os : MsilFile)StoreLocal*(ord : INTEGER),NEW;
+  PROCEDURE^ (os : MsilFile)FixCopies(prId : Sy.Idnt),NEW;
+  PROCEDURE^ (os : MsilFile)DecTemp(ord : INTEGER),NEW;
+  PROCEDURE^ (os : MsilFile)PutElem*(typ : Sy.Type),NEW;
+  PROCEDURE^ (os : MsilFile)GetElem*(typ : Sy.Type),NEW;
+
+(* ------------------------------------------------------------ *)
+
+  PROCEDURE takeAdrs*(i : Id.ParId) : BOOLEAN;
+  (*  A parameter needs to have its address taken iff      *)
+  (*  * Param Mode is VAL & FALSE                          *)
+  (*  * Param Mode is VAR & type is value class or scalar  *)
+  (*  * Param Mode is OUT & type is value class or scalar  *)
+  (*  * Param Mode is IN  & type is value class            *)
+  (*    (IN Scalars get treated as VAL on the caller side) *)
+    VAR type : Sy.Type;
+  BEGIN
+    IF i.parMod = Sy.val THEN RETURN FALSE END;
+
+    IF i.type IS Ty.Opaque THEN i.type := i.type(Ty.Opaque).resolved END;
+
+    type := i.type;
+    WITH type : Ty.Vector DO RETURN i.parMod # Sy.in;
+    |    type : Ty.Array  DO RETURN FALSE;
+    |    type : Ty.Record DO RETURN ~(Sy.clsTp IN type.xAttr);
+    ELSE (* scalar type *)   RETURN i.parMod # Sy.in;
+    END;
+  END takeAdrs;
+
+(* ------------------------------------------------------------ *)
+
+  PROCEDURE needsInit*(type : Sy.Type) : BOOLEAN;
+  BEGIN
+    WITH type : Ty.Vector DO RETURN FALSE;
+    |    type : Ty.Array  DO RETURN type.length # 0;
+    |    type : Ty.Record DO RETURN Sy.clsTp IN type.xAttr;
+    ELSE (* scalar type *)   RETURN FALSE;
+    END;
+  END needsInit;
+
+(* ------------------------------------------------------------ *)
+
+  PROCEDURE isRefSurrogate*(type : Sy.Type) : BOOLEAN;
+  BEGIN
+    WITH type : Ty.Array  DO RETURN type.kind # Ty.vecTp;
+    |    type : Ty.Record DO RETURN Sy.clsTp IN type.xAttr;
+    ELSE (* scalar type *)   RETURN FALSE;
+    END;
+  END isRefSurrogate;
+
+(* ------------------------------------------------------------ *)
+
+  PROCEDURE hasValueRep*(type : Sy.Type) : BOOLEAN;
+  BEGIN
+    WITH type : Ty.Array  DO RETURN type.kind = Ty.vecTp;
+    |    type : Ty.Record DO RETURN ~(Sy.clsTp IN type.xAttr);
+    ELSE (* scalar type *)   RETURN TRUE;
+    END;
+  END hasValueRep;
+
+(* ------------------------------------------------------------ *)
+
+  PROCEDURE isValRecord*(type : Sy.Type) : BOOLEAN;
+  BEGIN
+    WITH type : Ty.Array  DO RETURN FALSE;
+    |    type : Ty.Record DO RETURN ~(Sy.clsTp IN type.xAttr);
+    ELSE (* scalar type *)   RETURN FALSE;
+    END;
+  END isValRecord;
+
+(* ------------------------------------------------------------ *)
+
+  PROCEDURE vecMod() : Id.BlkId;
+  BEGIN
+    IF vecBlkId = NIL THEN
+      Bi.MkDummyImport("RTS_Vectors", "[RTS]Vectors", vecBlkId);
+      Bi.MkDummyClass("VecBase", vecBlkId, Ty.noAtt, vecBase);
+    END;
+    RETURN vecBlkId;
+  END vecMod;
+
+  PROCEDURE vecClass(ord : INTEGER) : Id.TypId;
+    VAR str : ARRAY 8 OF CHAR;
+        tId : Id.TypId;
+        rcT : Ty.Record;
+  BEGIN
+    IF vecTypes[ord] = NIL THEN
+      CASE ord OF
+      | Ty.charN  : str := "VecChr";
+      | Ty.intN   : str := "VecI32";
+      | Ty.lIntN  : str := "VecI64";
+      | Ty.sReaN  : str := "VecR32";
+      | Ty.realN  : str := "VecR64";
+      | Ty.anyPtr : str := "VecRef";
+      END;
+      Bi.MkDummyClass(str, vecMod(), Ty.noAtt, tId);
+      rcT := tId.type.boundRecTp()(Ty.Record);
+      rcT.baseTp := vecBase.type.boundRecTp();
+      vecTypes[ord] := tId;
+    END;
+    RETURN vecTypes[ord];
+  END vecClass;
+
+  PROCEDURE vecRecord(ord : INTEGER) : Ty.Record;
+  BEGIN
+    RETURN vecClass(ord).type.boundRecTp()(Ty.Record);
+  END vecRecord;
+
+  PROCEDURE vecArray(ord : INTEGER) : Id.FldId;
+    VAR fld : Id.FldId;
+  BEGIN
+    IF vecElms[ord] = NIL THEN
+      fld := Id.newFldId();
+      fld.hash := NameHash.enterStr("elms");
+      fld.dfScp := vecMod();
+      fld.recTyp := vecRecord(ord);
+      fld.type := Ty.mkArrayOf(mapOrdRepT(ord));
+      vecElms[ord] := fld;
+    END;
+    RETURN vecElms[ord];
+  END vecArray;
+
+(* ------------------------------------------------------------ *)
+
+  PROCEDURE vecArrFld*(typ : Ty.Vector; os : MsilFile) : Id.FldId;
+    VAR fld : Id.FldId;
+  BEGIN
+    fld := vecArray(mapVecElTp(typ.elemTp));
+    IF fld.recTyp.xName = NIL THEN MkRecName(fld.recTyp(Ty.Record), os) END;
+    RETURN fld;
+  END vecArrFld;
+
+  PROCEDURE vecRepTyp*(typ : Ty.Vector) : Sy.Type;
+  BEGIN
+    RETURN vecClass(mapVecElTp(typ.elemTp)).type;
+  END vecRepTyp;
+
+  PROCEDURE vecRepElTp*(typ : Ty.Vector) : Sy.Type;
+  BEGIN
+    RETURN mapOrdRepT(mapVecElTp(typ.elemTp));
+  END vecRepElTp;
+
+  PROCEDURE vecLeng*(os : MsilFile) : Id.FldId;
+  BEGIN
+    IF vecTide = NIL THEN
+      vecTide := Id.newFldId();
+      vecTide.hash := NameHash.enterStr("tide");
+      vecTide.dfScp := vecMod();
+      vecTide.recTyp := vecBase.type.boundRecTp();
+      vecTide.type  := Bi.intTp;
+      MkRecName(vecTide.recTyp(Ty.Record), os);
+    END;
+    RETURN vecTide;
+  END vecLeng;
+
+(* ------------------------------------------------------------ *)
+
+  PROCEDURE (os : MsilFile)InvokeExpand*(typ : Ty.Vector),NEW;
+  (*  Assert: vector ref is on stack *)
+    VAR ord : INTEGER;
+        xpd : Id.MthId;
+        xpT : Ty.Procedure;
+  BEGIN
+    ord := mapVecElTp(typ.elemTp);
+    xpd := vecExpnd[ord];
+    IF xpd = NIL THEN
+      xpd := Id.newMthId();
+      xpd.hash := Bi.xpndBk;
+      xpd.dfScp := vecMod();
+      xpT := Ty.newPrcTp();
+      xpT.idnt := xpd;
+      xpT.receiver := vecClass(ord).type;
+      xpd.bndType  := xpT.receiver.boundRecTp();
+      MkProcName(xpd, os);
+      os.NumberParams(xpd, xpT);
+      xpd.type := xpT;
+      vecExpnd[ord] := xpd;
+    END;
+    os.CallIT(Asm.opc_callvirt, xpd, xpd.type(Ty.Procedure));
+  END InvokeExpand;
+
+(* ------------------------------------------------------------ *)
+(* ------------------------------------------------------------ *)
+
+  PROCEDURE xhrCount(tgt, ths : Id.Procs) : INTEGER;
+    VAR count : INTEGER;
+  BEGIN
+    IF ths.lxDepth = 0 THEN RETURN 0 END;
+   (*
+    *  "ths" is the calling procedure.
+    *  "tgt" is the procedure with the uplevel data.
+    *)
+    count := 0;
+    REPEAT
+      ths := ths.dfScp(Id.Procs);
+      IF Id.hasXHR IN ths.pAttr THEN INC(count) END;
+    UNTIL (ths.lxDepth = 0) OR
+        ((ths.lxDepth <= tgt.lxDepth) & (Id.hasXHR  IN ths.pAttr));
+    RETURN count;
+  END xhrCount;
+
+  PROCEDURE newXHR() : Lv.CharOpen;
+  BEGIN
+    INC(xhrIx);
+    RETURN cat2(xhrDl, Lv.intToCharOpen(xhrIx));
+  END newXHR;
+
+  PROCEDURE MkXHR(scp : Id.Procs);
+    VAR typId : Id.TypId;
+      recTp : Ty.Record;
+      index : INTEGER;
+      locVr : Id.LocId;
+      fldVr : Id.FldId;
+  BEGIN
+   (*
+    *  Create a type descriptor for the eXplicit 
+    *  Heap-allocated activation Record.  This is
+    *  an extension of the [RTS]XHR system type.
+    *)
+    Bi.MkDummyClass(newXHR(), CSt.thisMod, Ty.noAtt, typId);
+    typId.SetMode(Sy.prvMode);
+    scp.xhrType := typId.type;
+    recTp := typId.type.boundRecTp()(Ty.Record);
+    recTp.baseTp := CSt.rtsXHR.boundRecTp();
+    INCL(recTp.xAttr, Sy.noCpy);
+
+    FOR index := 0 TO scp.locals.tide-1 DO
+      locVr := scp.locals.a[index](Id.LocId);
+      IF Id.uplevA IN locVr.locAtt THEN
+        fldVr := Id.newFldId();
+        fldVr.hash := locVr.hash;
+        fldVr.type := locVr.type;
+        fldVr.recTyp := recTp;
+        Sy.AppendIdnt(recTp.fields, fldVr);
+      END;
+    END;
+  END MkXHR;
+
+(* ============================================================ *)
+(*                    ProcInfo Methods                          *)
+(* ============================================================ *)
+
+  PROCEDURE InitProcInfo*(info : ProcInfo; proc : Sy.Scope);
+    VAR i : INTEGER;
+  BEGIN
+   (*
+    *  Assert: the locals have already been numbered
+    *               by a call to NumberLocals(), and 
+    *               rtsFram has been set accordingly.
+    *)
+    info.prId := proc;
+    WITH proc : Id.Procs DO
+      info.lNum := proc.rtsFram;
+      IF info.lNum > 0 THEN
+        Sy.InitTypeSeq(info.tLst, info.lNum * 2);    (* the (t)ypeList *)
+        Sy.InitTypeSeq(info.fLst, info.lNum * 2);    (* the (f)reeList *)
+        FOR i := 0 TO info.lNum-1 DO 
+          Sy.AppendType(info.tLst, NIL);
+          Sy.AppendType(info.fLst, NIL);
+        END;
+      END;
+    ELSE (* Id.BlkId *)
+      info.lNum := 0;
+    END;
+    info.dNum := 0;
+    info.dMax := 0;
+    info.rtLc := -1;   (* maybe different for IlasmUtil and PeUtil? *)
+  END InitProcInfo;
+
+(* ------------------------------------------------------------ *)
+
+  PROCEDURE (info : ProcInfo)newLocal*(typ : Sy.Type) : INTEGER,NEW;
+    VAR ord : INTEGER;
+  BEGIN
+   (*
+    *   We try to find a previously allocated, but
+    *   currently free slot of the identical type.
+    *)
+    FOR ord := info.lNum TO info.tLst.tide-1 DO
+      IF typ.equalType(info.fLst.a[ord]) THEN
+        info.fLst.a[ord] := NIL;      (* mark ord as used *)
+        RETURN ord;
+      END;
+    END;
+   (* Free slot of correct type not found *)
+    ord := info.tLst.tide;
+    Sy.AppendType(info.tLst, typ);
+    Sy.AppendType(info.fLst, NIL);
+    RETURN ord;
+  END newLocal;
+
+(* ------------------------------------------------------------ *)
+
+  PROCEDURE (info : ProcInfo)ReleaseLocal*(ord : INTEGER),NEW;
+  BEGIN
+    info.fLst.a[ord] := info.tLst.a[ord];
+  END ReleaseLocal;
+
+(* ------------------------------------------------------------ *)
+
+  PROCEDURE (info : ProcInfo)numLocals*() : INTEGER,NEW;
+  BEGIN
+    RETURN info.tLst.tide;
+  END numLocals;
+
+(* ------------------------------------------------------------ *)
+
+  PROCEDURE (info : ProcInfo)SetDepth*(d : INTEGER),NEW;
+  BEGIN
+    info.dNum := d;
+  END SetDepth;
+
+(* ------------------------------------------------------------ *)
+
+  PROCEDURE (info : ProcInfo)getDepth*() : INTEGER,NEW;
+  BEGIN
+    RETURN info.dNum;
+  END getDepth;
+
+(* ============================================================ *)
+(*                    Private Methods                           *)
+(* ============================================================ *)
+
+
+  PROCEDURE typeName*(typ : Sy.Type; os : MsilFile) : Lv.CharOpen;
+  BEGIN
+    IF typ.xName = NIL THEN MkTypeName(typ, os) END;
+    WITH typ : Ty.Base DO
+        RETURN typ.xName;
+    | typ : Ty.Array DO
+        RETURN typ.xName;
+    | typ : Ty.Record DO
+        RETURN typ.scopeNm;
+    | typ : Ty.Pointer DO
+        RETURN typ.xName;
+    | typ : Ty.Opaque DO
+        RETURN typ.xName;
+    | typ : Ty.Enum DO
+        RETURN typ.xName;
+    | typ : Ty.Procedure DO
+        RETURN typ.tName;
+    END;
+  END typeName;
+
+(* ============================================================ *)
+
+  PROCEDURE boxedName*(typ : Ty.Record; os : MsilFile) : Lv.CharOpen;
+  BEGIN
+    IF typ.xName = NIL THEN MkRecName(typ, os) END;
+    RETURN cat3(typ.idnt.dfScp.scopeNm, boxedObj, typ.xName);
+  END boxedName;
+
+(* ============================================================ *)
+
+  PROCEDURE MkTypeName*(typ : Sy.Type; fil : MsilFile);
+  BEGIN
+    WITH typ : Ty.Vector  DO MkVecName(typ, fil);
+      |  typ : Ty.Array   DO MkArrName(typ, fil);
+      |  typ : Ty.Base    DO MkBasName(typ, fil);
+      |  typ : Ty.Record  DO MkRecName(typ, fil);
+      |  typ : Ty.Pointer DO MkPtrName(typ, fil);
+      |  typ : Ty.Opaque  DO MkAliasName(typ, fil);
+      |  typ : Ty.Enum    DO MkEnumName(typ, fil);
+      |  typ : Ty.Procedure DO MkPTypeName(typ, fil);
+    END;
+  END MkTypeName;
+
+(* ============================================================ *)
+(*                    Exported Methods                          *)
+(* ============================================================ *)
+
+  PROCEDURE (os : MsilFile)Adjust*(delta : INTEGER),NEW;
+  BEGIN
+    INC(os.proc.dNum, delta); 
+    IF os.proc.dNum > os.proc.dMax THEN os.proc.dMax := os.proc.dNum END;
+  END Adjust;
+
+(* ============================================================ *)
+
+  PROCEDURE (os : MsilFile)newLabel*() : Label,NEW,ABSTRACT;
+
+(* ============================================================ *)
+
+  PROCEDURE (os : MsilFile)getLabelRange*(num : INTEGER) : LbArr,NEW;
+    VAR arr : LbArr;
+        idx : INTEGER;
+  BEGIN
+    NEW(arr, num);
+    FOR idx := 0 TO num-1 DO arr[idx] := os.newLabel() END;
+    RETURN arr;
+  END getLabelRange;
+
+(* ============================================================ *)
+
+  PROCEDURE (os : MsilFile)EndCatch*(),NEW,EXTENSIBLE;
+  BEGIN
+    os.CloseCatch(); 
+    os.DefLab(os.proc.exLb);
+    IF os.proc.rtLc # -1 THEN os.PushLocal(os.proc.rtLc) END;
+    os.FixCopies(os.proc.prId);
+    os.Code(Asm.opc_ret);
+  END EndCatch;
+
+(* ============================================================ *)
+
+  PROCEDURE (os : MsilFile)DoReturn*(),NEW;
+    VAR pTyp : Sy.Type;
+  BEGIN
+    IF os.proc.exLb = NIL THEN
+      os.FixCopies(os.proc.prId);
+      os.Code(Asm.opc_ret);
+      pTyp := os.proc.prId.type;
+      IF (pTyp # NIL) & (pTyp.returnType() # NIL) THEN DEC(os.proc.dNum) END;
+    ELSE
+      IF os.proc.rtLc # -1 THEN os.StoreLocal(os.proc.rtLc) END;
+      os.CodeLb(Asm.opc_leave, os.proc.exLb);
+    END;
+  END DoReturn;
+
+
+(* ============================================================ *)
+
+  PROCEDURE (os : MsilFile)MkFixedArray*(arTp : Ty.Array),NEW;
+    VAR cTmp : INTEGER;                    (* card'ty of this dim. *)
+        aTmp : INTEGER;                  (* array reference temp *)
+        labl : Label;
+        elTp : Sy.Type;
+        aLen : INTEGER;
+  BEGIN
+    ASSERT(arTp.length # 0);
+    elTp := arTp.elemTp;
+    aLen := arTp.length;
+    os.PushInt(aLen);
+    os.CodeTn(Asm.opc_newarr, elTp);
+   (*
+    *   Do we need an initialization loop?
+    *)
+    IF ~hasValueRep(elTp) THEN
+      labl := os.newLabel();
+      cTmp := os.proc.newLocal(Bi.intTp);
+      aTmp := os.proc.newLocal(arTp);
+      os.StoreLocal(aTmp);              (* (top)...             *)
+      os.PushInt(aLen);
+      os.StoreLocal(cTmp);
+     (*
+      *  Now the allocation loop
+      *)
+      os.DefLab(labl);
+      os.DecTemp(cTmp);
+      os.PushLocal(aTmp);
+      os.PushLocal(cTmp);
+      WITH elTp : Ty.Array DO
+          os.MkFixedArray(elTp);
+      | elTp : Ty.Record DO
+          os.MkNewRecord(elTp);
+      END;                              (* (top)elem,ix,ref,... *)
+      os.PutElem(elTp);
+     (*
+      *  Now the termination test
+      *)
+      os.PushLocal(cTmp);
+      os.CodeLb(Asm.opc_brtrue, labl);
+      os.PushLocal(aTmp);
+      os.proc.ReleaseLocal(cTmp);
+      os.proc.ReleaseLocal(aTmp);
+    END;
+  END MkFixedArray;
+
+(* ============================================================ *)
+
+  PROCEDURE (os : MsilFile)MkVecRec*(eTp : Sy.Type),NEW;
+    VAR ord : INTEGER;
+  BEGIN
+    ord := mapVecElTp(eTp);
+    os.MkNewRecord(vecRecord(ord));
+  END MkVecRec;
+
+  PROCEDURE (os : MsilFile)MkVecArr*(eTp : Sy.Type),NEW;
+    VAR ord : INTEGER;
+        vTp : Sy.Type;
+  BEGIN
+    ord := mapVecElTp(eTp);
+    os.CodeTn(Asm.opc_newarr, mapOrdRepT(ord));
+    os.PutGetF(Asm.opc_stfld, vecArray(ord));
+  END MkVecArr;
+
+(* ============================================================ *)
+
+  PROCEDURE (os : MsilFile)MkOpenArray*(arTp : Ty.Array),NEW;
+    VAR lens : ARRAY 32 OF INTEGER;
+        elTp : Sy.Type;
+   (* ----------------------------------------- *)
+    PROCEDURE GetLengths(os  : MsilFile;
+                     dim : INTEGER;
+                     typ : Sy.Type;
+                   VAR lAr : ARRAY OF INTEGER);
+      VAR tmp : INTEGER;
+    BEGIN
+      ASSERT(dim < 31);
+      WITH typ : Ty.Array DO
+        IF typ.length = 0 THEN      (* another open dimension *)
+          tmp := os.proc.newLocal(Bi.intTp);
+          lAr[dim] := tmp;
+          os.StoreLocal(tmp);
+          GetLengths(os, dim+1, typ.elemTp, lAr);
+        END;
+      ELSE
+      END;
+    END GetLengths;
+   (* ----------------------------------------- *)
+    PROCEDURE InitLoop(os  : MsilFile;
+                     dim : INTEGER;
+                     typ : Ty.Array;
+                  IN lAr : ARRAY OF INTEGER);
+      VAR aEl : INTEGER;
+          lab : Label;
+          elT : Sy.Type;
+    BEGIN
+     (*
+      *  Pre  : the uninitialized array is on the stack
+      *)
+      elT := typ.elemTp;
+      IF ~hasValueRep(elT) THEN
+        aEl := os.proc.newLocal(typ);
+        os.StoreLocal(aEl);
+        lab := os.newLabel();
+       (*
+        *  Start of initialization loop
+        *)
+        os.DefLab(lab);
+       (*
+        *  Decrement the loop counter
+        *)
+        os.DecTemp(lAr[dim]);
+       (*
+        *  Assign the array element
+        *)
+        os.PushLocal(aEl);
+        os.PushLocal(lAr[dim]);
+        WITH elT : Ty.Record DO
+            os.MkNewRecord(elT);
+        | elT : Ty.Array DO
+            IF elT.length > 0 THEN
+              os.MkFixedArray(elT);
+            ELSE
+              os.PushLocal(lAr[dim+1]);
+              os.CodeTn(Asm.opc_newarr, elT.elemTp);
+              InitLoop(os, dim+1, elT, lAr);
+            END;
+        END;
+        os.PutElem(elT);
+       (*
+        *  Test and branch to loop header
+        *)
+        os.PushLocal(lAr[dim]);
+        os.CodeLb(Asm.opc_brtrue, lab);
+       (*
+        *  Reload the original array
+        *)
+        os.PushLocal(aEl);
+        os.proc.ReleaseLocal(aEl);
+        os.proc.ReleaseLocal(lAr[dim]);
+      END;
+     (*
+      *  Post : the initialized array is on the stack
+      *)
+    END InitLoop;
+   (* ----------------------------------------- *)
+  BEGIN
+    elTp := arTp.elemTp;
+    IF (elTp IS Ty.Array) OR (elTp IS Ty.Record) THEN
+      GetLengths(os, 0, arTp, lens);
+      os.PushLocal(lens[0]);
+      os.CodeTn(Asm.opc_newarr, elTp);
+      InitLoop(os, 0, arTp, lens);
+    ELSE
+      os.CodeTn(Asm.opc_newarr, elTp);
+    END; 
+  END MkOpenArray;
+
+(* ============================================================ *)
+
+  PROCEDURE (os : MsilFile)MkArrayCopy*(arrT : Ty.Array),NEW;
+    VAR dims : INTEGER;
+        elTp : Sy.Type;
+ (* ----------------------------------- *)
+    PROCEDURE PushLengths(os : MsilFile; aT : Ty.Array);
+    BEGIN
+      IF aT.elemTp IS Ty.Array THEN
+        os.Code(Asm.opc_dup);
+        os.Code(Asm.opc_ldc_i4_0);
+        os.GetElem(aT.elemTp);
+        PushLengths(os, aT.elemTp(Ty.Array));
+      END;
+      os.Code(Asm.opc_ldlen);
+    END PushLengths;
+ (* ----------------------------------- *)
+  BEGIN
+   (*
+    *        Assert: we must find the lengths from the runtime 
+    *   descriptors. The array to copy is on the top of 
+    *   stack, which reads -         (top) aRef, ...
+    *)
+    PushLengths(os, arrT);
+    os.MkOpenArray(arrT);
+  END MkArrayCopy;
+
+(* ============================================================ *)
+
+  PROCEDURE (os : MsilFile)StructInit*(var : Sy.Idnt),NEW;
+    VAR typ : Sy.Type;
+        fld : Sy.Idnt;
+        idx : INTEGER;
+        lnk : BOOLEAN;
+   (* ------------------------------------------------- *)
+    PROCEDURE Assign(os : MsilFile; id : Sy.Idnt);
+      VAR md : Id.BlkId;
+    BEGIN
+      WITH id : Id.LocId DO
+          IF id.varOrd # Id.xMark THEN
+            os.StoreLocal(id.varOrd);
+          ELSE
+            os.PutUplevel(id);
+          END;
+      | id : Id.FldId DO
+          os.PutGetF(Asm.opc_stfld, id);
+      | id : Id.VarId DO
+          md := id.dfScp(Id.BlkId);
+          os.PutGetS(Asm.opc_stsfld, md, id);
+      END;
+    END Assign;
+   (* ------------------------------------------------- *)
+  BEGIN
+    os.Comment("initialize " + Sy.getName.ChPtr(var)^);
+   (*
+    *  Precondition: var is of a type that needs initialization,
+    *)
+    typ := var.type;
+    lnk := (var IS Id.LocId) & (var(Id.LocId).varOrd = Id.xMark);
+    WITH typ : Ty.Array DO
+        IF lnk THEN os.Code(Asm.opc_ldloc_0) END;
+        os.MkFixedArray(typ);
+        Assign(os, var);
+    | typ : Ty.Record DO
+        IF Sy.clsTp IN typ.xAttr THEN
+         (*
+          *  Reference record type
+          *)
+          IF lnk THEN os.Code(Asm.opc_ldloc_0) END;
+          os.MkNewRecord(typ);
+          Assign(os, var);
+        ELSE
+         (*
+          *  Value record type
+          *)
+          os.GetVarA(var);
+          os.CodeTn(Asm.opc_initobj, typ);
+        END;
+    ELSE
+      IF lnk THEN os.Code(Asm.opc_ldloc_0) END;
+      os.Code(Asm.opc_ldnull);
+      Assign(os, var);
+    END;
+  END StructInit;
+
+(* ============================================================ *)
+
+  PROCEDURE (os : MsilFile)PushZero(typ : Sy.Type),NEW;
+    VAR cde : INTEGER;
+  BEGIN
+    WITH typ : Ty.Base DO
+      CASE typ.tpOrd OF
+      | Ty.sReaN : os.CodeR(Asm.opc_ldc_r4, 0.0);
+      | Ty.realN : os.CodeR(Asm.opc_ldc_r8, 0.0);
+      | Ty.lIntN : os.CodeL(Asm.opc_ldc_i8, 0);
+      | Ty.charN,
+        Ty.sChrN : os.Code(Asm.opc_ldc_i4_0);
+      ELSE           os.Code(Asm.opc_ldc_i4_0);
+      END;
+    ELSE
+      os.Code(Asm.opc_ldnull);
+    END;
+  END PushZero;
+
+ (* ----------------------------------- *)
+
+  PROCEDURE (os : MsilFile)ScalarInit*(var : Sy.Idnt),NEW;
+    VAR typ : Sy.Type;
+        cde : INTEGER;
+  BEGIN
+    os.Comment("initialize " + Sy.getName.ChPtr(var)^);
+    typ := var.type;
+   (*
+    *  Precondition: var is of a scalar type that is referenced
+    *)
+    os.PushZero(typ);
+  END ScalarInit;
+
+(* ============================================================ *)
+
+  PROCEDURE (os : MsilFile)Throw*(),NEW;
+  BEGIN
+    os.CodeS(Asm.opc_newobj, mkExcept);
+    os.Code(Asm.opc_throw);
+  END Throw;
+
+(* ============================================================ *)
+
+  PROCEDURE (os : MsilFile)Trap*(IN str : ARRAY OF CHAR),NEW;
+  BEGIN
+    os.PushStr('"' + str + '"');
+    os.Throw();
+  END Trap;
+
+(* ============================================================ *)
+
+  PROCEDURE (os : MsilFile)IndexTrap*(),NEW;
+  BEGIN
+    os.Comment("IndexTrap");
+    os.Trap("Vector index out of bounds");
+  END IndexTrap;
+
+(* ============================================================ *)
+
+  PROCEDURE (os : MsilFile)CaseTrap*(i : INTEGER),NEW;
+  BEGIN
+    os.Comment("CaseTrap");
+    os.PushLocal(i);
+    os.CodeS(Asm.opc_call, caseMesg);
+    os.CodeS(Asm.opc_newobj, mkExcept);
+    os.Code(Asm.opc_throw);
+  END CaseTrap;
+
+(* ============================================================ *)
+
+  PROCEDURE (os : MsilFile)WithTrap*(id : Sy.Idnt),NEW;
+  BEGIN
+    os.Comment("WithTrap " + Sy.getName.ChPtr(id)^);
+    os.GetVar(id);
+    os.CodeS(Asm.opc_call, withMesg);
+    os.CodeS(Asm.opc_newobj, mkExcept);
+    os.Code(Asm.opc_throw);
+  END WithTrap;
+
+(* ============================================================ *)
+
+  PROCEDURE EliminatePathFromSrcName(str : Lv.CharOpen): Lv.CharOpen;
+  VAR
+    i, idx, len: INTEGER;
+    rslt: Lv.CharOpen;
+  BEGIN
+    FOR idx := LEN(str)-1 TO 0 BY - 1 DO
+      IF str[idx] = '\' THEN
+        len := LEN(str) - idx - 1;
+	NEW (rslt, len);
+	FOR i := 0 TO len - 2 DO rslt[i] := str[idx+i+1]; END;
+	rslt[len-1] := 0X;
+        RETURN rslt;
+      END;
+    END; (* FOR *)
+    RETURN str;
+  END EliminatePathFromSrcName;
+
+  PROCEDURE (os : MsilFile)Header*(IN str : ARRAY OF CHAR),NEW;
+    VAR date : ARRAY 64 OF CHAR;
+  BEGIN
+    os.srcS := Lv.strToCharOpen(
+          "'" + EliminatePathFromSrcName(Lv.strToCharOpen(str))^ + "'");
+    RTS.GetDateString(date);
+    os.Comment("ILASM output produced by GPCP compiler (" +
+                                RTS.defaultTarget + " version)");
+    os.Comment("at date: " + date);
+    os.Comment("from source file <" + str + '>');
+  END Header;
+
+
+(* ============================================================ *)
+(*                    Namehandling Methods                      *)
+(* ============================================================ *)
+
+  PROCEDURE MkBlkName*(mod : Id.BlkId);
+    VAR mNm : Lv.CharOpen;
+  (* -------------------------------------------------- *)
+    PROCEDURE scpMangle(mod : Id.BlkId) : Lv.CharOpen;
+      VAR outS : Lv.CharOpen;
+    BEGIN
+      IF mod.kind = Id.impId THEN
+        outS := cat4(lBrk,mod.pkgNm,rBrk,mod.xName);
+      ELSE
+        outS := mod.xName;
+      END;
+      IF LEN(mod.xName$) > 0 THEN outS := cat2(outS, dotS) END;
+      RETURN outS;
+    END scpMangle;
+  (* -------------------------------------------------- *)
+    PROCEDURE nmSpaceOf(mod : Id.BlkId) : Lv.CharOpen;
+      VAR ix : INTEGER;
+          ln : INTEGER;
+          ch : CHAR;
+          inS : Lv.CharOpen;
+    BEGIN
+      inS := mod.scopeNm;
+      IF inS[0] # '[' THEN 
+        RETURN inS;
+      ELSE
+        ln := LEN(inS);
+        ix := 0;
+        REPEAT
+          ch := inS[ix]; 
+          INC(ix);
+        UNTIL (ix = LEN(inS)) OR (ch = ']');
+        RETURN Lv.subChOToChO(inS, ix, ln-ix);
+      END;
+    END nmSpaceOf;
+  (* -------------------------------------------------- *)
+    PROCEDURE pkgNameOf(mod : Id.BlkId) : Lv.CharOpen;
+      VAR ix : INTEGER;
+          ln : INTEGER;
+          ch : CHAR;
+          inS : Lv.CharOpen;
+    BEGIN
+      inS := mod.scopeNm;
+      IF inS[0] # '[' THEN 
+        RETURN mod.clsNm;
+      ELSE
+        ln := LEN(inS);
+        ix := 0;
+        REPEAT
+          ch := inS[ix]; 
+          INC(ix);
+        UNTIL (ix = LEN(inS)) OR (ch = ']');
+        RETURN Lv.subChOToChO(inS, 1, ix-2);
+      END;
+    END pkgNameOf;
+  (* -------------------------------------------------- *)
+  BEGIN
+    IF mod.xName # NIL THEN RETURN END;
+    mNm := Sy.getName.ChPtr(mod);
+    IF mod.scopeNm # NIL THEN 
+      IF mod.clsNm = NIL THEN
+        mod.clsNm   := mNm;            (* dummy class name  *)
+      END;
+      mod.pkgNm   := pkgNameOf(mod);   (* assembly filename *)
+      mod.xName   := nmSpaceOf(mod);   (* namespace name    *)
+      mod.scopeNm := scpMangle(mod);   (* class prefix name *)
+    ELSE
+      mod.clsNm   := mNm;              (* dummy class name  *)
+      mod.pkgNm   := mNm;              (* assembly filename *)
+      mod.xName   := mNm;              (* namespace name    *)
+     (*
+      *  In the normal case, the assembly name is the
+      *  same as the module name.  However, system 
+      *  modules always have the assembly name "RTS".
+      *)
+      IF Sy.rtsMd IN mod.xAttr THEN 
+        mod.scopeNm := cat3(lBrk, rtsS, rBrk);
+      ELSE
+        mod.scopeNm := scpMangle(mod); (* class prefix name *)
+      END;
+    END;
+  END MkBlkName;
+
+(* ------------------------------------------------------------ *)
+
+  PROCEDURE (os : MsilFile)CheckNestedClass*(typ : Ty.Record;
+                                             scp : Sy.Scope;
+                                             rNm : Lv.CharOpen),NEW,ABSTRACT;
+
+(* ------------------------------------------------------------ *
+ *
+ *PROCEDURE StrSubChr(str: Lv.CharOpen; 
+ *                    ch1, ch2: CHAR): Lv.CharOpen;
+ *  VAR i, len: INTEGER;
+ *      rslt: Lv.CharOpen;
+ *BEGIN
+ * (* 
+ *  *  copy str to rslt with all occurences of 
+ *  *  ch1 replaced by ch2, except at index 0  
+ *  *)
+ *  len := LEN(str); NEW(rslt, len);
+ *  rslt[0] := str[0];
+ *  FOR i := 1 TO len-1 DO
+ *    IF str[i] # ch1 THEN rslt[i] := str[i] ELSE rslt[i] := ch2 END;
+ *  END; (* FOR *)
+ *  RETURN rslt;
+ *END StrSubChr;
+ *
+ * ------------------------------------------------------------ *)
+
+  PROCEDURE MkRecName*(typ : Ty.Record; os : MsilFile);
+    VAR mNm : Lv.CharOpen;      (* prefix scope name    *)
+        rNm : Lv.CharOpen;      (* simple name of type  *)
+        tId : Sy.Idnt;
+        scp : Sy.Scope;
+  (* ---------------------------------- *
+   * The choice below may need revision *
+   * depending on any decison about the *
+   * format of foreign type-names       *
+   * extracted from the metadata.       *
+   * ---------------------------------- *)
+    PROCEDURE unmangle(arr : Lv.CharOpen) : Lv.CharOpen;
+    BEGIN
+      RETURN arr;
+    END unmangle;
+  (* ---------------------------------------------------------- *)
+  BEGIN
+    IF typ.xName # NIL THEN RETURN END;
+
+    IF (typ.baseTp IS Ty.Record) &
+       (typ.baseTp.xName = NIL) THEN MkRecName(typ.baseTp(Ty.Record), os) END;
+
+    IF typ.bindTp # NIL THEN              (* Synthetically named rec'd *)
+      tId := typ.bindTp.idnt;
+      rNm := Sy.getName.ChPtr(tId);
+    ELSE                                  (* Normal, named record type *)
+      IF typ.idnt = NIL THEN              (* Anonymous record type     *)
+        typ.idnt := Id.newAnonId(typ.serial);
+        typ.idnt.type := typ;
+      END;
+      tId := typ.idnt;
+      rNm := Sy.getName.ChPtr(tId);
+    END;
+
+    IF tId.dfScp = NIL THEN tId.dfScp := CSt.thisMod END;
+    scp := tId.dfScp;
+
+    IF typ.extrnNm # NIL THEN
+      typ.scopeNm := unmangle(typ.extrnNm);
+     (*
+      * This is an external class, so it might be a nested class!
+      *)
+      os.CheckNestedClass(typ, scp, rNm);
+(*
+ *    Console.WriteString(typ.name());
+ *    Console.WriteLn;
+ *
+ *    rNm := StrSubChr(rNm,'$','/');
+ *)
+    END;
+
+   (*
+    *  At this program point the situation is as follows:
+    *  rNm holds the simple name of the record. The scope
+    *  in which the record is defined is scp.
+    *)
+    WITH scp : Id.Procs DO
+        IF scp.prcNm = NIL THEN MkProcName(scp, os) END;
+        rNm         := cat3(scp.prcNm, atSg, rNm);
+        typ.xName   := rNm;
+        typ.scopeNm := cat2(scp.scopeNm, rNm);
+    | scp : Id.BlkId DO
+        IF scp.xName = NIL THEN MkBlkName(scp) END;
+        typ.xName   := rNm;
+        typ.scopeNm := cat2(scp.scopeNm, rNm);
+    END;
+   (*
+    *   It is at this point that we link records into the
+    *   class-emission worklist.
+    *)
+    IF typ.tgXtn = NIL THEN os.MkRecX(typ, scp) END;
+    IF tId.dfScp.kind # Id.impId THEN
+      MsilBase.emitter.AddNewRecEmitter(typ);
+    END;
+  END MkRecName;
+
+(* ------------------------------------------------------------ *)
+
+  PROCEDURE MkEnumName*(typ : Ty.Enum; os : MsilFile);
+    VAR mNm : Lv.CharOpen;      (* prefix scope name    *)
+        rNm : Lv.CharOpen;      (* simple name of type  *)
+        tId : Sy.Idnt;
+        scp : Sy.Scope;
+  (* ---------------------------------------------------------- *)
+  BEGIN
+   (* Assert: Enums are always imported ... *)
+    IF typ.xName # NIL THEN RETURN END;
+
+    tId := typ.idnt;
+    rNm := Sy.getName.ChPtr(tId);
+    scp := tId.dfScp;
+   (*
+    *  At this program point the situation is at follows:
+    *  rNm holds the simple name of the type. The scope
+    *  in which the record is defined is scp.
+    *)
+    WITH  scp : Id.BlkId DO
+      IF scp.xName = NIL THEN MkBlkName(scp) END;
+      typ.xName := cat2(scp.scopeNm, rNm);
+    END;
+    os.MkEnuX(typ, scp);
+  END MkEnumName;
+
+(* ------------------------------------------------------------ *)
+
+  PROCEDURE MkBasName(typ : Ty.Base; os : MsilFile);
+  BEGIN
+    ASSERT(typ.xName # NIL);
+    os.MkBasX(typ);
+  END MkBasName;
+
+(* ------------------------------------------------------------ *)
+
+  PROCEDURE MkArrName(typ : Ty.Array; os : MsilFile);
+  BEGIN
+    typ.xName := cat2(typeName(typ.elemTp, os), brks);
+    os.MkArrX(typ);
+  END MkArrName;
+
+(* ------------------------------------------------------------ *)
+
+  PROCEDURE MkVecName(typ : Ty.Vector; os : MsilFile);
+    VAR ord : INTEGER;
+        cls : Id.TypId;
+  BEGIN
+    ord := mapVecElTp(typ.elemTp);
+    CASE ord OF
+    | Ty.charN  : typ.xName := cat2(vecPrefix, BOX("VecChr"));
+    | Ty.intN   : typ.xName := cat2(vecPrefix, BOX("VecI32"));
+    | Ty.lIntN  : typ.xName := cat2(vecPrefix, BOX("VecI64"));
+    | Ty.sReaN  : typ.xName := cat2(vecPrefix, BOX("VecR32"));
+    | Ty.realN  : typ.xName := cat2(vecPrefix, BOX("VecR64"));
+    | Ty.anyPtr : typ.xName := cat2(vecPrefix, BOX("VecRef"));
+    END;
+    cls := vecClass(ord);
+    IF cls.type.tgXtn = NIL THEN os.MkVecX(cls.type, vecMod()) END;
+    typ.tgXtn := cls.type.tgXtn;
+  END MkVecName;
+
+(* ------------------------------------------------------------ *)
+
+  PROCEDURE MkPtrName*(typ : Ty.Pointer; os : MsilFile);
+    VAR bndTp : Sy.Type;
+        bndNm : Lv.CharOpen;
+  BEGIN
+    bndTp := typ.boundTp;
+    bndNm := typeName(bndTp, os); (* recurse with MkTypeName *)
+    IF isValRecord(bndTp) THEN
+      typ.xName := boxedName(bndTp(Ty.Record), os);
+    ELSE
+      typ.xName := bndNm;
+    END;
+    os.MkPtrX(typ);
+  END MkPtrName;
+
+(* ------------------------------------------------------------ *)
+
+  PROCEDURE MkPTypeName*(typ : Ty.Procedure; os : MsilFile);
+    VAR tNm : Lv.CharOpen;
+        sNm : Lv.CharOpen;
+  BEGIN
+    IF typ.xName # NIL THEN RETURN END;
+   (*
+    *  Set the eName field
+    *)
+    IF typ.idnt = NIL THEN              (* Anonymous procedure type *)
+      typ.idnt := Id.newAnonId(typ.serial);
+      typ.idnt.type := typ;
+    END;
+    IF typ.idnt.dfScp = NIL THEN typ.idnt.dfScp := CSt.thisMod END;
+
+    MkIdName(typ.idnt.dfScp, os);
+    os.NumberParams(NIL, typ); 
+
+    sNm := typ.idnt.dfScp.scopeNm;
+    tNm := Sy.getName.ChPtr(typ.idnt);
+    typ.tName := cat2(sNm, tNm);
+
+    WITH typ : Ty.Event DO 
+      typ.bndRec.xName := tNm;
+      typ.bndRec.scopeNm := typ.tName 
+    ELSE (* skip *) 
+    END;
+   (*
+    *   os.MkTyXtn(...); // called from inside NumberParams().
+    *
+    *   It is at this point that we link events into the
+    *   class-emission worklist.
+    *)
+    IF typ.idnt.dfScp.kind # Id.impId THEN
+      MsilBase.emitter.AddNewRecEmitter(typ);
+    END;
+  END MkPTypeName;
+
+(* ------------------------------------------------------------ *)
+
+  PROCEDURE MkProcName*(proc : Id.Procs; os : MsilFile);
+    VAR pNm : Lv.CharOpen;
+        res : Id.Procs;
+        scp : Id.BlkId;
+        bTp : Ty.Record;
+  (* -------------------------------------------------- *)
+    PROCEDURE MkMthNm(mth : Id.MthId; os : MsilFile);
+      VAR res : Id.MthId;
+          scp : Id.BlkId;
+          typ : Sy.Type;
+    BEGIN
+      IF mth.scopeNm # NIL THEN RETURN;
+      ELSIF mth.kind = Id.fwdMth THEN
+        res := mth.resolve(Id.MthId); MkMthNm(res, os);
+        mth.prcNm := res.prcNm; mth.scopeNm := res.scopeNm;
+      ELSE
+        scp := mth.dfScp(Id.BlkId);
+        typ := mth.bndType;
+        IF typ.xName = NIL THEN MkRecName(typ(Ty.Record), os) END;
+        IF scp.xName = NIL THEN MkBlkName(scp) END;
+        mth.scopeNm := scp.scopeNm;
+        IF mth.prcNm = NIL THEN mth.prcNm := Sy.getName.ChPtr(mth) END;
+        IF ~(Sy.clsTp IN typ(Ty.Record).xAttr) &
+           (mth.rcvFrm.type IS Ty.Pointer) THEN INCL(mth.mthAtt, Id.boxRcv) END;
+      END;
+    END MkMthNm;
+  (* -------------------------------------------------- *)
+    PROCEDURE className(p : Id.Procs) : Lv.CharOpen;
+    BEGIN
+      WITH p : Id.PrcId DO RETURN p.clsNm;
+      |    p : Id.MthId DO RETURN p.bndType.xName;
+      END;
+    END className;
+  (* -------------------------------------------------- *)
+    PROCEDURE GetClassName(pr : Id.PrcId; bl : Id.BlkId; os : MsilFile);
+      VAR nm : Lv.CharOpen;
+    BEGIN
+      nm := Sy.getName.ChPtr(pr);
+      IF pr.bndType = NIL THEN   (* normal procedure *)
+        pr.clsNm := bl.clsNm;
+        IF pr.prcNm = NIL THEN pr.prcNm := nm END;
+      ELSE                       (* static method    *)
+        IF pr.bndType.xName = NIL THEN MkRecName(pr.bndType(Ty.Record), os) END;
+        pr.clsNm := pr.bndType.xName; 
+        IF pr.prcNm = NIL THEN 
+          pr.prcNm := nm;
+        ELSIF pr.prcNm^ = initString THEN 
+          pr.SetKind(Id.ctorP);
+        END;
+      END;
+    END GetClassName;
+  (* -------------------------------------------------- *)
+    PROCEDURE MkPrcNm(prc : Id.PrcId; os : MsilFile);
+      VAR scp : Sy.Scope;
+          res : Id.PrcId;
+          blk : Id.BlkId;
+          rTp : Sy.Type;
+    BEGIN
+      IF prc.scopeNm # NIL THEN RETURN;
+      ELSIF prc.kind = Id.fwdPrc THEN
+        res := prc.resolve(Id.PrcId); MkPrcNm(res, os);
+        prc.prcNm := res.prcNm; 
+        prc.clsNm := res.clsNm;
+        prc.scopeNm := res.scopeNm;
+      ELSIF prc.kind = Id.conPrc THEN
+        scp := prc.dfScp;
+        WITH scp : Id.BlkId DO
+            IF scp.xName = NIL THEN MkBlkName(scp) END;
+            IF  Sy.isFn IN scp.xAttr THEN
+              GetClassName(prc, scp, os);
+            ELSE
+              prc.clsNm := scp.clsNm;
+              IF prc.prcNm = NIL THEN prc.prcNm := Sy.getName.ChPtr(prc) END;
+            END;
+        | scp : Id.Procs DO
+            MkProcName(scp, os);
+            prc.clsNm := className(scp);
+            prc.prcNm   := cat3(Sy.getName.ChPtr(prc), atSg, scp.prcNm);
+        END;
+        prc.scopeNm := scp.scopeNm;
+      ELSE (* prc.kind = Id.ctorP *)
+        blk := prc.dfScp(Id.BlkId);
+        rTp := prc.type.returnType();
+        IF blk.xName = NIL THEN MkBlkName(blk) END;
+        IF rTp.xName = NIL THEN MkTypeName(rTp, os) END;
+        prc.clsNm := rTp.boundRecTp().xName;
+        prc.prcNm := Lv.strToCharOpen(initString); 
+        prc.scopeNm := blk.scopeNm;
+
+        prc.bndType := rTp.boundRecTp();
+        prc.type(Ty.Procedure).retType := NIL;
+
+      END;
+    END MkPrcNm;
+  (* -------------------------------------------------- *)
+  BEGIN
+    WITH proc : Id.MthId DO MkMthNm(proc, os);
+    |    proc : Id.PrcId DO MkPrcNm(proc, os);
+    END;
+   (*
+    *    In this case proc.tgXtn is set in NumberParams 
+    *)
+  END MkProcName;
+
+(* ------------------------------------------------------------ *)
+
+  PROCEDURE MkAliasName*(typ : Ty.Opaque; os : MsilFile);
+    VAR tNm : Lv.CharOpen;
+        sNm : Lv.CharOpen;
+  BEGIN
+    IF typ.xName # NIL THEN RETURN END;
+    MkBlkName(typ.idnt.dfScp(Id.BlkId));
+    tNm := Sy.getName.ChPtr(typ.idnt);
+    sNm := typ.idnt.dfScp.scopeNm;
+    typ.xName   := cat2(sNm, tNm);
+    typ.scopeNm := sNm;
+  END MkAliasName;
+
+(* ------------------------------------------------------------ *)
+
+  PROCEDURE MkVarName*(var : Id.VarId; os : MsilFile);
+  BEGIN
+    var.varNm := Sy.getName.ChPtr(var);
+    IF var.recTyp = NIL THEN     (* normal case  *)
+      var.clsNm := var.dfScp(Id.BlkId).clsNm;
+    ELSE                         (* static field *)
+      IF var.recTyp.xName = NIL THEN MkTypeName(var.recTyp, os) END;
+      var.clsNm := var.recTyp.xName; 
+    END;
+  END MkVarName;
+
+(* ------------------------------------------------------------ *)
+
+  PROCEDURE MkFldName*(id : Id.FldId; os : MsilFile);
+  BEGIN 
+    id.fldNm := Sy.getName.ChPtr(id);
+  END MkFldName;
+
+(* ------------------------------------------------------------ *)
+
+  PROCEDURE MkIdName*(id : Sy.Idnt; os : MsilFile);
+  BEGIN
+    WITH id : Id.Procs DO IF id.scopeNm = NIL THEN MkProcName(id, os) END;
+    |    id : Id.BlkId DO IF id.scopeNm = NIL THEN MkBlkName(id)      END;
+    |    id : Id.VarId DO IF id.varNm   = NIL THEN MkVarName(id, os)  END;
+    |    id : Id.FldId DO IF id.fldNm   = NIL THEN MkFldName(id, os)  END;
+    |    id : Id.LocId DO (* skip *)
+    END;
+  END MkIdName;
+ 
+(* ------------------------------------------------------------ *)
+
+  PROCEDURE NumberLocals(pIdn : Id.Procs; IN locs : Sy.IdSeq);
+    VAR ident : Sy.Idnt;
+        index : INTEGER;
+        count : INTEGER;
+  BEGIN
+    count := 0;
+    (* ------------------ *)
+    IF Id.hasXHR IN pIdn.pAttr THEN MkXHR(pIdn); INC(count) END;
+    (* ------------------ *)
+    FOR index := 0 TO locs.tide-1 DO
+      ident := locs.a[index];
+      WITH ident : Id.ParId DO (* skip *)
+      | ident : Id.LocId DO
+          IF Id.uplevA IN ident.locAtt THEN
+            ident.varOrd := Id.xMark;
+          ELSE
+            ident.varOrd := count;
+            INC(count);
+          END;
+      END;
+    END;
+    pIdn.rtsFram := count;
+  END NumberLocals;
+
+(* ------------------------------------------------------------ *)
+
+  PROCEDURE MkCallAttr*(pIdn : Sy.Idnt; os : MsilFile); 
+    VAR pTyp : Ty.Procedure;
+        rcvP : Id.ParId;
+  BEGIN
+   (*  
+    *  This is only called for imported methods.  
+    *  All local methods have been already fixed 
+    *  by the call from RenumberLocals() 
+    *)
+    pTyp := pIdn.type(Ty.Procedure);
+    WITH pIdn : Id.MthId DO
+        pTyp.argN := 1;            (* count one for "this" *)
+        rcvP := pIdn.rcvFrm;
+        MkProcName(pIdn, os);
+        IF takeAdrs(rcvP) THEN rcvP.boxOrd := rcvP.parMod END;
+        os.NumberParams(pIdn, pTyp);
+    | pIdn : Id.PrcId DO 
+        pTyp.argN := 0;
+        MkProcName(pIdn, os);
+        os.NumberParams(pIdn, pTyp);
+    END;
+  END MkCallAttr;
+
+(* ------------------------------------------------------------ *)
+
+  PROCEDURE RenumberLocals*(prcId : Id.Procs; os : MsilFile);
+    VAR parId : Id.ParId;
+        frmTp : Ty.Procedure;
+        funcT : BOOLEAN;
+  BEGIN
+   (*  
+    *  This is only called for local methods.
+    *  Imported methods do not have visible locals,
+    *  and get their signatures computed by the 
+    *  call of NumberParams() in MkCallAttr()
+    *
+    *  Numbering Rules:
+    *         (i)   The receiver (if any) must be #0
+    *         (ii)  Params are #0 .. #N for statics, 
+    *               or #1 .. #N for methods.
+    *         (iii) Incoming static link is #0 if this is
+    *               a nested procedure (methods are not nested)
+    *         (iv)  Locals separately number from zero.
+    *) 
+    frmTp := prcId.type(Ty.Procedure);
+    funcT := (frmTp.retType # NIL);
+    WITH prcId : Id.MthId DO
+      parId := prcId.rcvFrm;
+      parId.varOrd := 0;   
+      IF takeAdrs(parId) THEN parId.boxOrd := parId.parMod END;
+      frmTp.argN := 1;              (* count one for "this" *)
+    ELSE (* static procedures *)
+      IF (prcId.kind = Id.ctorP) OR
+         (prcId.lxDepth > 0) THEN frmTp.argN := 1 ELSE frmTp.argN := 0 END;
+    END;
+   (*
+    *   Assert: params do not appear in the local array.
+    *   Count params.
+    *)
+    os.NumberParams(prcId, frmTp); (* Make signature method defined here *)
+(*
+ *  If NumberLocals is NOT called on a procedure that
+ *  has locals but no body, then PeUtil pulls an index
+ *  exception. Such a program may be silly, but is legal. (kjg)
+ *
+ *  IF prcId.body # NIL THEN
+ *    NumberLocals(prcId, prcId.locals);
+ *  END;
+ *)
+    NumberLocals(prcId, prcId.locals);
+  END RenumberLocals;
+
+(* ------------------------------------------------------------ *)
+(* ------------------------------------------------------------ *)
+
+  PROCEDURE (os : MsilFile)LoadIndirect*(typ : Sy.Type),NEW;
+    VAR code : INTEGER;
+  BEGIN
+    IF (typ # NIL) & (typ IS Ty.Base) THEN
+      os.Code(typeLdInd[typ(Ty.Base).tpOrd]);
+    ELSIF isValRecord(typ) THEN
+      os.CodeT(Asm.opc_ldobj, typ);
+    ELSE
+      os.Code(Asm.opc_ldind_ref);
+    END;
+  END LoadIndirect;
+
+(* ------------------------------------------------------------ *)
+
+  PROCEDURE (os : MsilFile)StoreIndirect*(typ : Sy.Type),NEW;
+    VAR code : INTEGER;
+  BEGIN
+    IF (typ # NIL) & (typ IS Ty.Base) THEN
+      os.Code(typeStInd[typ(Ty.Base).tpOrd]);
+    ELSIF isValRecord(typ) THEN
+      os.CodeT(Asm.opc_stobj, typ);
+    ELSE
+      os.Code(Asm.opc_stind_ref);
+    END;
+  END StoreIndirect;
+
+(* ------------------------------------------------------------ *)
+(* ------------------------------------------------------------ *)
+
+  PROCEDURE (os : MsilFile)PushArg*(ord : INTEGER),NEW;
+  BEGIN
+    IF ord < 256 THEN
+      CASE ord OF
+      | 0 : os.Code(Asm.opc_ldarg_0);
+      | 1 : os.Code(Asm.opc_ldarg_1);
+      | 2 : os.Code(Asm.opc_ldarg_2);
+      | 3 : os.Code(Asm.opc_ldarg_3);
+      ELSE
+        os.CodeI(Asm.opc_ldarg_s, ord);
+      END;
+    ELSE
+      os.CodeI(Asm.opc_ldarg, ord);
+    END;
+  END PushArg;
+
+(* ------------------------------------------------------------ *)
+
+  PROCEDURE (os : MsilFile)PushStaticLink*(tgt : Id.Procs),NEW;
+    VAR lxDel : INTEGER;
+        clr   : Id.Procs;
+  BEGIN
+    clr   := os.proc.prId(Id.Procs);
+    lxDel := tgt.lxDepth - clr.lxDepth;
+
+    CASE lxDel OF
+    | 0 : os.Code(Asm.opc_ldarg_0);
+    | 1 : IF Id.hasXHR IN clr.pAttr THEN
+            os.Code(Asm.opc_ldloc_0);
+          ELSIF clr.lxDepth = 0 THEN
+            os.Code(Asm.opc_ldnull);
+          ELSE
+            os.Code(Asm.opc_ldarg_0);
+          END;
+    ELSE
+      os.Code(Asm.opc_ldarg_0);
+      REPEAT
+        clr := clr.dfScp(Id.Procs);
+        IF Id.hasXHR IN clr.pAttr THEN 
+          os.PutGetF(Asm.opc_ldfld, CSt.xhrId);
+        END;
+      UNTIL clr.lxDepth = tgt.lxDepth;
+    END;
+  END PushStaticLink;
+
+(* ---------------------------------------------------- *)
+
+  PROCEDURE (os : MsilFile)GetXHR(var : Id.LocId),NEW;
+    VAR scp : Id.Procs; (* the scope holding the datum *)
+        clr : Id.Procs; (* the scope making the call   *)
+        del : INTEGER;
+  BEGIN
+    scp := var.dfScp(Id.Procs);
+    clr := os.proc.prId(Id.Procs);
+   (*
+    *  Check if this is an own local
+    *)
+    IF scp = clr THEN
+      os.Code(Asm.opc_ldloc_0);
+    ELSE
+      del := xhrCount(scp, clr);
+     (*
+      *  First, load the static link
+      *)
+      os.Code(Asm.opc_ldarg_0);
+     (*
+      *  Next, load the XHR pointer.
+      *)
+      WHILE del > 1 DO
+        os.PutGetF(Asm.opc_ldfld, CSt.xhrId);
+        DEC(del);
+      END;
+     (*
+      *  Finally, cast to concrete type
+      *)
+      os.CodeT(Asm.opc_castclass, scp.xhrType);
+    END;
+  END GetXHR;
+
+(* ------------------------------------------------------------ *)
+
+  PROCEDURE (os : MsilFile)PushLocal*(ord : INTEGER),NEW;
+  BEGIN
+    IF ord < 256 THEN
+      CASE ord OF
+      | 0 : os.Code(Asm.opc_ldloc_0);
+      | 1 : os.Code(Asm.opc_ldloc_1);
+      | 2 : os.Code(Asm.opc_ldloc_2);
+      | 3 : os.Code(Asm.opc_ldloc_3);
+      ELSE
+        os.CodeI(Asm.opc_ldloc_s, ord);
+      END;
+    ELSE
+      os.CodeI(Asm.opc_ldloc, ord);
+    END;
+  END PushLocal;
+
+(* ---------------------------------------------------- *)
+
+  PROCEDURE (os : MsilFile)PushLocalA*(ord : INTEGER),NEW;
+  BEGIN
+    IF ord < 256 THEN
+      os.CodeI(Asm.opc_ldloca_s, ord);
+    ELSE
+      os.CodeI(Asm.opc_ldloca, ord);
+    END;
+  END PushLocalA;
+
+(* ---------------------------------------------------- *)
+
+  PROCEDURE (os : MsilFile)PushArgA*(ord : INTEGER),NEW;
+  BEGIN
+    IF ord < 256 THEN
+      os.CodeI(Asm.opc_ldarga_s, ord);
+    ELSE
+      os.CodeI(Asm.opc_ldarga, ord);
+    END;
+  END PushArgA;
+
+(* ---------------------------------------------------- *)
+
+  PROCEDURE (os : MsilFile)GetXhrField(cde : INTEGER; var : Id.LocId),NEW;
+    VAR proc : Id.Procs;
+  BEGIN
+    proc := var.dfScp(Id.Procs);
+    os.PutGetXhr(cde, proc, var);
+  END GetXhrField;
+
+(* ---------------------------------------------------- *)
+
+  PROCEDURE (os : MsilFile)XhrHandle*(var : Id.LocId),NEW;
+  BEGIN
+    os.GetXHR(var);
+    IF var.boxOrd # Sy.val THEN os.GetXhrField(Asm.opc_ldfld, var) END; 
+  END XhrHandle;
+
+(* ---------------------------------------------------- *)
+
+  PROCEDURE (os : MsilFile)GetUplevel(var : Id.LocId),NEW;
+  BEGIN
+    os.GetXHR(var);
+   (*
+    *  If var is a LocId do "ldfld FT XT::'vname'"
+    *  If var is a ParId then
+    *    if not a byref then "ldfld FT XT::'vname'"
+    *    elsif is a byref then "ldfld FT& XT::'vname'; ldind.TT"
+    *)
+    os.GetXhrField(Asm.opc_ldfld, var); 
+    IF var.boxOrd # Sy.val THEN os.LoadIndirect(var.type) END;
+  END GetUplevel;
+
+(* ---------------------------------------------------- *)
+
+  PROCEDURE (os : MsilFile)GetUplevelA(var : Id.LocId),NEW;
+  BEGIN
+    os.GetXHR(var);
+   (*
+    *  If var is a LocId do "ldflda FT XT::'vname'"
+    *  If var is a ParId then
+    *    if not a byref then "ldflda FT XT::'vname'"
+    *    elsif is a byref then "ldfld FT& XT::'vname'"
+    *)
+    IF var.boxOrd # Sy.val THEN         (* byref case ... *)
+      os.GetXhrField(Asm.opc_ldfld, var); 
+    ELSE                               (* value case ... *)
+      os.GetXhrField(Asm.opc_ldflda, var); 
+    END;
+  END GetUplevelA;
+
+(* ---------------------------------------------------- *)
+
+  PROCEDURE (os : MsilFile)PutUplevel*(var : Id.LocId),NEW;
+  BEGIN
+   (*
+    *  If var is a LocId do "stfld FT XT::'vname'"
+    *  If var is a ParId then
+    *    if not a byref then "stfld FT XT::'vname'"
+    *    elsif is a byref then "ldfld FT& XT::'vname'; stind.TT"
+    *)
+    IF var.boxOrd # Sy.val THEN         (* byref case ... *)
+      os.StoreIndirect(var.type);
+    ELSE                               (* value case ... *)
+      os.GetXhrField(Asm.opc_stfld, var); 
+    END;
+  END PutUplevel;
+
+(* ---------------------------------------------------- *)
+
+  PROCEDURE (os : MsilFile)GetLocal*(var : Id.LocId),NEW;
+  BEGIN
+    IF Id.uplevA IN var.locAtt THEN os.GetUplevel(var); RETURN END;
+    WITH var : Id.ParId DO
+      os.PushArg(var.varOrd);
+      IF var.boxOrd # Sy.val THEN os.LoadIndirect(var.type) END;
+    ELSE
+      os.PushLocal(var.varOrd);
+    END;
+  END GetLocal;
+
+(* ---------------------------------------------------- *)
+
+  PROCEDURE (os : MsilFile)DecTemp*(ord : INTEGER),NEW;
+  BEGIN
+    os.PushLocal(ord);
+    os.Code(Asm.opc_ldc_i4_1);
+    os.Code(Asm.opc_sub);
+    os.StoreLocal(ord);
+  END DecTemp;
+
+(* ---------------------------------------------------- *)
+
+  PROCEDURE (os : MsilFile)GetVar*(id : Sy.Idnt),NEW;
+    VAR scp : Sy.Scope;
+  BEGIN
+    WITH id : Id.AbVar DO
+      IF id.kind = Id.conId THEN
+        os.GetLocal(id(Id.LocId));
+      ELSE
+        scp := id.dfScp;
+        WITH scp : Id.BlkId DO
+          os.PutGetS(Asm.opc_ldsfld, scp, id(Id.VarId));
+        ELSE
+          os.GetLocal(id(Id.LocId));
+        END;
+      END;
+    END;
+  END GetVar;
+
+(* ------------------------------------------------------------ *)
+(* ------------------------------------------------------------ *)
+
+  PROCEDURE (os : MsilFile)GetLocalA(var : Id.LocId),NEW;
+    VAR ord : INTEGER;
+  BEGIN
+    ord := var.varOrd;
+    IF Id.uplevA IN var.locAtt THEN os.GetUplevelA(var); RETURN END;
+    IF ~(var IS Id.ParId) THEN              (* local var *)
+      os.PushLocalA(ord);
+    ELSIF var.boxOrd # Sy.val THEN        (* ref param *)
+      os.PushArg(ord);
+    ELSE                          (* val param *)
+      os.PushArgA(ord);
+    END;
+  END GetLocalA;
+
+(* ---------------------------------------------------- *)
+
+  PROCEDURE (os : MsilFile)GetVarA*(id : Sy.Idnt),NEW;
+    VAR var : Id.AbVar;
+        scp : Sy.Scope;
+  BEGIN
+   (*
+    *  Assert:  the handle is NOT pushed on the tos yet.
+    *)
+    var := id(Id.AbVar);
+    scp := var.dfScp;
+    WITH scp : Id.BlkId DO
+      os.PutGetS(Asm.opc_ldsflda, scp, var(Id.VarId));
+    ELSE
+      os.GetLocalA(var(Id.LocId));
+    END;
+  END GetVarA;
+
+(* ------------------------------------------------------------ *)
+(* ------------------------------------------------------------ *)
+
+  PROCEDURE (os : MsilFile)StoreArg*(ord : INTEGER),NEW;
+  BEGIN
+    IF ord < 256 THEN
+      os.CodeI(Asm.opc_starg_s, ord);
+    ELSE
+      os.CodeI(Asm.opc_starg, ord);
+    END;
+  END StoreArg;
+
+(* ---------------------------------------------------- *)
+
+  PROCEDURE (os : MsilFile)StoreLocal*(ord : INTEGER),NEW;
+  BEGIN
+    IF ord < 256 THEN
+      CASE ord OF
+      | 0 : os.Code(Asm.opc_stloc_0);
+      | 1 : os.Code(Asm.opc_stloc_1);
+      | 2 : os.Code(Asm.opc_stloc_2);
+      | 3 : os.Code(Asm.opc_stloc_3);
+      ELSE
+        os.CodeI(Asm.opc_stloc_s, ord);
+      END;
+    ELSE
+      os.CodeI(Asm.opc_stloc, ord);
+    END;
+  END StoreLocal;
+
+(* ---------------------------------------------------- *)
+
+  PROCEDURE (os : MsilFile)PutLocal*(var : Id.LocId),NEW;
+  BEGIN
+    IF Id.uplevA IN var.locAtt THEN os.PutUplevel(var); RETURN END;
+    WITH var : Id.ParId DO
+      IF var.boxOrd = Sy.val THEN 
+        os.StoreArg(var.varOrd);
+      ELSE
+       (*
+        *  stack goes (top) value, reference, ... so
+        *  os.PushArg(var.varOrd);
+        *)
+        os.StoreIndirect(var.type);
+      END;
+    ELSE
+      os.StoreLocal(var.varOrd);
+    END;
+  END PutLocal;
+
+(* ---------------------------------------------------- *)
+
+  PROCEDURE (os : MsilFile)PutVar*(id : Sy.Idnt),NEW;
+    VAR var : Id.AbVar;
+        scp : Sy.Scope;
+  BEGIN
+    var := id(Id.AbVar);
+    scp := var.dfScp;
+    WITH scp : Id.BlkId DO
+      os.PutGetS(Asm.opc_stsfld, scp, var(Id.VarId));
+    ELSE (* must be local *)
+      os.PutLocal(var(Id.LocId));
+    END;
+  END PutVar;
+
+(* ------------------------------------------------------------ *)
+
+  PROCEDURE (os : MsilFile)PutElem*(typ : Sy.Type),NEW;
+  (* typ is element type *)
+  BEGIN
+    IF (typ # NIL) & (typ IS Ty.Base) THEN
+      os.Code(typePutE[typ(Ty.Base).tpOrd]);
+    ELSIF isValRecord(typ) THEN
+      os.CodeT(Asm.opc_stobj, typ);
+    ELSIF typ IS Ty.Enum THEN
+      os.Code(typePutE[Ty.intN]);  (* assume enum <==> int32 *)
+    ELSE
+      os.Code(Asm.opc_stelem_ref);
+    END;
+  END PutElem;
+
+(* ------------------------------------------------------------ *)
+
+  PROCEDURE (os : MsilFile)GetElem*(typ : Sy.Type),NEW;
+  BEGIN
+    IF (typ # NIL) & (typ IS Ty.Base) THEN
+      os.Code(typeGetE[typ(Ty.Base).tpOrd]);
+    ELSIF isValRecord(typ) THEN
+      os.CodeT(Asm.opc_ldobj, typ);
+    ELSIF typ IS Ty.Enum THEN
+      os.Code(typeGetE[Ty.intN]);  (* assume enum <==> int32 *)
+    ELSE
+      os.Code(Asm.opc_ldelem_ref);
+    END;
+  END GetElem;
+
+(* ------------------------------------------------------------ *)
+
+  PROCEDURE (os : MsilFile)GetField*(fld : Id.FldId),NEW;
+  BEGIN
+    os.PutGetF(Asm.opc_ldfld, fld);
+  END GetField;
+
+(* ------------------------------------------------------------ *)
+
+  PROCEDURE (os : MsilFile)GetFieldAdr*(fld : Id.FldId),NEW;
+  BEGIN
+    os.PutGetF(Asm.opc_ldflda, fld);
+  END GetFieldAdr;
+
+(* ------------------------------------------------------------ *)
+
+  PROCEDURE (os : MsilFile)PutField*(fld : Id.FldId),NEW;
+  BEGIN
+    os.PutGetF(Asm.opc_stfld, fld);
+  END PutField;
+
+(* ------------------------------------------------------------ *)
+
+  PROCEDURE (os : MsilFile)GetElemA*(typ : Sy.Type),NEW;
+  BEGIN
+    os.CodeTn(Asm.opc_ldelema, typ);
+  END GetElemA;
+
+(* ------------------------------------------------------------ *)
+
+  PROCEDURE (os : MsilFile)GetVal*(typ : Ty.Pointer),NEW;
+  BEGIN
+    os.GetValObj(Asm.opc_ldfld, typ);
+  END GetVal;
+
+(* ------------------------------------------------------------ *)
+
+  PROCEDURE (os : MsilFile)GetValA*(typ : Ty.Pointer),NEW;
+  BEGIN
+    os.GetValObj(Asm.opc_ldflda, typ);
+  END GetValA;
+
+(* ------------------------------------------------------------ *)
+
+  PROCEDURE (os : MsilFile)PushInt*(num : INTEGER),NEW;
+  BEGIN
+    IF (-128 <= num) & (num <= 127) THEN
+      CASE num OF
+      | -1 : os.Code(Asm.opc_ldc_i4_M1);
+      |  0 : os.Code(Asm.opc_ldc_i4_0);
+      |  1 : os.Code(Asm.opc_ldc_i4_1);
+      |  2 : os.Code(Asm.opc_ldc_i4_2);
+      |  3 : os.Code(Asm.opc_ldc_i4_3);
+      |  4 : os.Code(Asm.opc_ldc_i4_4);
+      |  5 : os.Code(Asm.opc_ldc_i4_5);
+      |  6 : os.Code(Asm.opc_ldc_i4_6);
+      |  7 : os.Code(Asm.opc_ldc_i4_7);
+      |  8 : os.Code(Asm.opc_ldc_i4_8);
+      ELSE
+        os.CodeI(Asm.opc_ldc_i4_s, num);
+      END;
+    ELSE
+      os.CodeI(Asm.opc_ldc_i4, num);
+    END;
+  END PushInt;
+
+(* ------------------------------------------------------------ *)
+
+  PROCEDURE (os : MsilFile)PushLong*(num : LONGINT),NEW;
+  BEGIN
+   (*
+    *  IF num is short we could do PushInt, then i2l!
+    *)
+    os.CodeL(Asm.opc_ldc_i8, num);
+  END PushLong;
+
+(* ------------------------------------------------------------ *)
+
+  PROCEDURE (os : MsilFile)PushReal*(num : REAL),NEW;
+  BEGIN
+    os.CodeR(Asm.opc_ldc_r8, num);
+  END PushReal;
+
+(* ------------------------------------------------------------ *)
+
+  PROCEDURE (os : MsilFile)PushSReal*(num : REAL),NEW;
+  BEGIN
+    os.CodeR(Asm.opc_ldc_r4, num);
+  END PushSReal;
+
+(* ------------------------------------------------------------ *)
+
+  PROCEDURE (os : MsilFile)PushJunkAndQuit*(prc : Sy.Scope),NEW;
+    VAR pTyp : Ty.Procedure;
+  BEGIN
+    IF (prc # NIL) & (prc.type # NIL) THEN
+      pTyp := prc.type(Ty.Procedure);
+      IF pTyp.retType # NIL THEN os.PushZero(pTyp.retType) END;
+    END;
+    os.DoReturn();
+  END PushJunkAndQuit;
+
+(* ------------------------------------------------------------ *)
+
+  PROCEDURE (os : MsilFile)ConvertUp*(inT, outT : Sy.Type),NEW;
+   (* Conversion "up" is always safe at runtime. Many are nop. *)
+    VAR inB, outB, code : INTEGER;
+  BEGIN
+    inB  := inT(Ty.Base).tpOrd;
+    outB := outT(Ty.Base).tpOrd;
+    IF inB = outB THEN RETURN END;                     (* PREMATURE RETURN! *)
+    CASE outB OF
+    | Ty.realN : code := Asm.opc_conv_r8;
+    | Ty.sReaN : code := Asm.opc_conv_r4;
+    | Ty.lIntN : code := Asm.opc_conv_i8;
+    ELSE               RETURN;                         (* PREMATURE RETURN! *)
+    END;
+    os.Code(code);
+  END ConvertUp;
+
+(* ------------------------------------------------------------ *)
+
+  PROCEDURE (os : MsilFile)ConvertDn*(inT, outT : Sy.Type),NEW;
+   (* Conversion "down" often needs a runtime check. *)
+    VAR inB, outB, code : INTEGER;
+  BEGIN
+    inB  := inT(Ty.Base).tpOrd;
+    outB := outT(Ty.Base).tpOrd;
+    IF inB = Ty.setN THEN inB := Ty.intN END;
+    IF inB = outB THEN RETURN END;                     (* PREMATURE RETURN! *)
+    IF os.proc.prId.ovfChk THEN
+      CASE outB OF
+      | Ty.realN : RETURN;                             (* PREMATURE RETURN! *)
+      | Ty.sReaN : code := Asm.opc_conv_r4; (* No check possible *)
+      | Ty.lIntN : code := Asm.opc_conv_ovf_i8;
+      | Ty.intN  : code := Asm.opc_conv_ovf_i4;
+      | Ty.sIntN : code := Asm.opc_conv_ovf_i2;
+      | Ty.uBytN : code := Asm.opc_conv_ovf_u1;
+      | Ty.byteN : code := Asm.opc_conv_ovf_i1;
+      | Ty.setN  : code := Asm.opc_conv_u4; (* no check here! *)
+      | Ty.charN : code := Asm.opc_conv_ovf_u2;
+      | Ty.sChrN : code := Asm.opc_conv_ovf_u1;
+      END;
+    ELSE
+      CASE outB OF
+      | Ty.realN : RETURN;                             (* PREMATURE RETURN! *)
+      | Ty.sReaN : code := Asm.opc_conv_r4; (* No check possible *)
+      | Ty.lIntN : code := Asm.opc_conv_i8;
+      | Ty.intN  : code := Asm.opc_conv_i4;
+      | Ty.sIntN : code := Asm.opc_conv_i2;
+      | Ty.byteN : code := Asm.opc_conv_i1;
+      | Ty.uBytN : code := Asm.opc_conv_u1;
+      | Ty.setN  : code := Asm.opc_conv_u4; (* no check here! *)
+      | Ty.charN : code := Asm.opc_conv_u2;
+      | Ty.sChrN : code := Asm.opc_conv_u1;
+      END;
+    END;
+    os.Code(code);
+  END ConvertDn;
+
+(* ------------------------------------------------------------ *)
+
+  PROCEDURE (os : MsilFile)EmitOneRange*
+             (var : INTEGER;            (* local variable index *)
+              loC : INTEGER;            (* low-value of range   *)
+              hiC : INTEGER;            (* high-value of range  *)
+              ord : INTEGER;            (* case-index of range  *)
+              min : INTEGER;            (* minimun selector val *)
+              max : INTEGER;            (* maximum selector val *)
+              def : LbArr),NEW;         (* default code label   *)
+  (* ---------------------------------------------------------- *
+   *  The selector value is known to be in the range min .. max *
+   *  and we wish to send values between loC and hiC to the     *
+   *  code label associated with ord. All otherwise go to def.  *
+   *  A range is "compact" if it is hard against min/max limits *
+   * ---------------------------------------------------------- *)
+    VAR target : INTEGER;
+  BEGIN
+   (*
+    *    Deal with several special cases...
+    *)
+    target := ord + 1;
+    IF (min = loC) & (max = hiC) THEN      (* fully compact: just GOTO *)
+      os.CodeLb(Asm.opc_br, def[target]);
+    ELSE
+      os.PushLocal(var);
+      IF loC = hiC THEN (* a singleton *)
+        os.PushInt(loC);
+        os.CodeLb(Asm.opc_beq, def[target]);
+      ELSIF min = loC THEN                 (* compact at low end only  *)
+        os.PushInt(hiC);
+        os.CodeLb(Asm.opc_ble, def[target]);
+      ELSIF max = hiC THEN                 (* compact at high end only *)
+        os.PushInt(loC);
+        os.CodeLb(Asm.opc_bge, def[target]);
+      ELSE                                 (* Shucks! The general case *)
+        IF loC # 0 THEN
+          os.PushInt(loC);
+          os.Code(Asm.opc_sub);
+        END;
+        os.PushInt(hiC-loC);
+        os.CodeLb(Asm.opc_ble_un, def[target]);
+      END;
+      os.CodeLb(Asm.opc_br, def[0]);
+    END;
+  END EmitOneRange;
+
+(* ------------------------------------------------------------ *)
+(* ------------------------------------------------------------ *)
+
+  PROCEDURE (os : MsilFile)InitVars*(scp : Sy.Scope),NEW;
+    VAR index : INTEGER;
+        ident : Sy.Idnt;
+  BEGIN
+   (* 
+    *  Create the explicit activation record, if needed.
+    *)
+    WITH scp : Id.Procs DO
+      IF Id.hasXHR IN scp.pAttr THEN 
+        os.Comment("create XHR record");
+        os.MkNewRecord(scp.xhrType.boundRecTp()(Ty.Record));
+        IF scp.lxDepth > 0 THEN
+          os.Code(Asm.opc_dup);
+          os.Code(Asm.opc_ldarg_0);
+          os.PutGetF(Asm.opc_stfld, CSt.xhrId);
+        END;
+        os.Code(Asm.opc_stloc_0);
+      END;
+    ELSE (* skip *)
+    END;
+   (* 
+    *  Initialize local fields, if needed
+    *)
+    FOR index := 0 TO scp.locals.tide-1 DO
+      ident := scp.locals.a[index];
+      WITH ident : Id.ParId DO
+        IF Id.uplevA IN ident.locAtt THEN  (* copy to XHR *)
+          os.GetXHR(ident);
+          os.PushArg(ident.varOrd);
+          IF Id.cpVarP IN ident.locAtt THEN os.LoadIndirect(ident.type) END;
+          os.GetXhrField(Asm.opc_stfld, ident);
+        END; (* else skip *)
+      ELSE
+        IF ~ident.type.isScalarType() THEN 
+          os.StructInit(ident);
+        ELSE
+          WITH ident : Id.LocId DO
+           (*
+            *  Special code to step around deficiency in the the
+            *  verifier. Verifier does not understand OUT semantics.
+            *
+            *  IF Id.addrsd IN ident.locAtt THEN
+            *)
+            IF (Id.addrsd IN ident.locAtt) & ~(Id.uplevA IN ident.locAtt) THEN
+              ASSERT(~(scp IS Id.BlkId));
+              os.ScalarInit(ident); 
+              os.StoreLocal(ident.varOrd);
+            END;
+          ELSE
+          END;
+        END;
+      END;
+    END;
+  END InitVars;
+
+(* ============================================================ *)
+
+  PROCEDURE (os : MsilFile)FixCopies(prId : Sy.Idnt),NEW;
+    VAR index : INTEGER;
+        pType : Ty.Procedure;
+        formP : Id.ParId;
+  BEGIN
+    IF prId # NIL THEN 
+      WITH prId : Id.Procs DO
+        pType := prId.type(Ty.Procedure);
+        FOR index := 0 TO pType.formals.tide - 1 DO
+          formP := pType.formals.a[index];
+          IF Id.cpVarP IN formP.locAtt THEN
+            os.PushArg(formP.varOrd);
+            os.GetXHR(formP);
+            os.GetXhrField(Asm.opc_ldfld, formP);
+            os.StoreIndirect(formP.type);
+          END;
+        END;
+      ELSE (* skip *)
+      END; (* with *)
+    END;
+  END FixCopies;
+
+(* ============================================================ *)
+
+  PROCEDURE InitVectorDescriptors();
+    VAR idx : INTEGER;
+  BEGIN
+    vecBlkId := NIL;
+    vecBase  := NIL;
+    vecTide  := NIL;
+    FOR idx := 0 TO Ty.anyPtr DO
+      vecElms[idx] := NIL;
+      vecTypes[idx] := NIL;
+      vecExpnd[idx] := NIL;
+    END;
+  END InitVectorDescriptors;
+
+(* ============================================================ *)
+
+  PROCEDURE SetNativeNames*();
+    VAR sRec, oRec : Ty.Record;
+  BEGIN
+    xhrIx := 0;
+    oRec := CSt.ntvObj.boundRecTp()(Ty.Record);
+    sRec := CSt.ntvStr.boundRecTp()(Ty.Record);
+
+    InitVectorDescriptors();
+(*
+ *  From release 1.2, only the RTM version is supported
+ *)
+    INCL(oRec.xAttr, Sy.spshl);
+    INCL(sRec.xAttr, Sy.spshl);
+    oRec.xName := Lv.strToCharOpen("object");
+    sRec.xName := Lv.strToCharOpen("string");
+    oRec.scopeNm := oRec.xName;
+    sRec.scopeNm := sRec.xName;
+    pVarSuffix   := Lv.strToCharOpen(".ctor($O, native int) ");
+
+    CSt.ntvObj.xName := oRec.scopeNm;
+    CSt.ntvStr.xName := sRec.scopeNm;
+
+  END SetNativeNames;
+
+(* ============================================================ *)
+(* ============================================================ *)
+BEGIN
+  Lv.InitCharOpenSeq(nmArray, 8);
+
+  rtsS := Lv.strToCharOpen("RTS"); 
+  brks := Lv.strToCharOpen("[]"); 
+  dotS := Lv.strToCharOpen("."); 
+  cmma := Lv.strToCharOpen(","); 
+  lPar := Lv.strToCharOpen("("); 
+  rPar := Lv.strToCharOpen(")"); 
+  lBrk := Lv.strToCharOpen("["); 
+  rBrk := Lv.strToCharOpen("]"); 
+  atSg := Lv.strToCharOpen("@"); 
+  rfMk := Lv.strToCharOpen("&"); 
+  vFld := Lv.strToCharOpen("v$"); 
+  ouMk := Lv.strToCharOpen("[out] ");
+  prev := Lv.strToCharOpen("prev"); 
+  body := Lv.strToCharOpen("$static"); 
+  xhrDl := Lv.strToCharOpen("XHR@"); 
+  xhrMk := Lv.strToCharOpen("class [RTS]XHR"); 
+  boxedObj := Lv.strToCharOpen("Boxed_"); 
+  corlibAsm := Lv.strToCharOpen("[mscorlib]System."); 
+
+  vecPrefix := Lv.strToCharOpen("[RTS]Vectors."); 
+  evtAdd := Lv.strToCharOpen("add_"); 
+  evtRem := Lv.strToCharOpen("remove_"); 
+
+  Bi.setTp.xName  := Lv.strToCharOpen("int32");
+  Bi.boolTp.xName := Lv.strToCharOpen("bool");
+  Bi.byteTp.xName := Lv.strToCharOpen("int8");
+  Bi.uBytTp.xName := Lv.strToCharOpen("unsigned int8");
+  Bi.charTp.xName := Lv.strToCharOpen("wchar");
+  Bi.sChrTp.xName := Lv.strToCharOpen("char");
+  Bi.sIntTp.xName := Lv.strToCharOpen("int16");
+  Bi.lIntTp.xName := Lv.strToCharOpen("int64");
+  Bi.realTp.xName := Lv.strToCharOpen("float64");
+  Bi.sReaTp.xName := Lv.strToCharOpen("float32");
+  Bi.intTp.xName  := Bi.setTp.xName;
+  Bi.anyRec.xName := Lv.strToCharOpen("class System.Object");
+  Bi.anyPtr.xName := Bi.anyRec.xName;
+
+  typeGetE[ Ty.boolN] := Asm.opc_ldelem_i1;
+(*
+ * typeGetE[ Ty.sChrN] := Asm.opc_ldelem_u1;
+ *)
+  typeGetE[ Ty.sChrN] := Asm.opc_ldelem_u2;
+  typeGetE[ Ty.charN] := Asm.opc_ldelem_u2;
+  typeGetE[ Ty.byteN] := Asm.opc_ldelem_i1;
+  typeGetE[ Ty.uBytN] := Asm.opc_ldelem_u1;
+  typeGetE[ Ty.sIntN] := Asm.opc_ldelem_i2;
+  typeGetE[  Ty.intN] := Asm.opc_ldelem_i4;
+  typeGetE[ Ty.lIntN] := Asm.opc_ldelem_i8;
+  typeGetE[ Ty.sReaN] := Asm.opc_ldelem_r4;
+  typeGetE[ Ty.realN] := Asm.opc_ldelem_r8;
+  typeGetE[  Ty.setN] := Asm.opc_ldelem_i4;
+  typeGetE[Ty.anyPtr] := Asm.opc_ldelem_ref;
+  typeGetE[Ty.anyRec] := Asm.opc_ldelem_ref;
+
+  typePutE[ Ty.boolN] := Asm.opc_stelem_i1;
+(*
+ * typePutE[ Ty.sChrN] := Asm.opc_stelem_i1;
+ *)
+  typePutE[ Ty.sChrN] := Asm.opc_stelem_i2;
+  typePutE[ Ty.charN] := Asm.opc_stelem_i2;
+  typePutE[ Ty.byteN] := Asm.opc_stelem_i1;
+  typePutE[ Ty.uBytN] := Asm.opc_stelem_i1;
+  typePutE[ Ty.sIntN] := Asm.opc_stelem_i2;
+  typePutE[  Ty.intN] := Asm.opc_stelem_i4;
+  typePutE[ Ty.lIntN] := Asm.opc_stelem_i8;
+  typePutE[ Ty.sReaN] := Asm.opc_stelem_r4;
+  typePutE[ Ty.realN] := Asm.opc_stelem_r8;
+  typePutE[  Ty.setN] := Asm.opc_stelem_i4;
+  typePutE[Ty.anyPtr] := Asm.opc_stelem_ref;
+  typePutE[Ty.anyRec] := Asm.opc_stelem_ref;
+
+  typeLdInd[ Ty.boolN] := Asm.opc_ldind_u1;
+  typeLdInd[ Ty.sChrN] := Asm.opc_ldind_u2;
+  typeLdInd[ Ty.charN] := Asm.opc_ldind_u2;
+  typeLdInd[ Ty.byteN] := Asm.opc_ldind_i1;
+  typeLdInd[ Ty.uBytN] := Asm.opc_ldind_u1;
+  typeLdInd[ Ty.sIntN] := Asm.opc_ldind_i2;
+  typeLdInd[  Ty.intN] := Asm.opc_ldind_i4;
+  typeLdInd[ Ty.lIntN] := Asm.opc_ldind_i8;
+  typeLdInd[ Ty.sReaN] := Asm.opc_ldind_r4;
+  typeLdInd[ Ty.realN] := Asm.opc_ldind_r8;
+  typeLdInd[  Ty.setN] := Asm.opc_ldind_i4;
+  typeLdInd[Ty.anyPtr] := Asm.opc_ldind_ref;
+  typeLdInd[Ty.anyRec] := Asm.opc_ldind_ref;
+
+  typeStInd[ Ty.boolN] := Asm.opc_stind_i1;
+  typeStInd[ Ty.sChrN] := Asm.opc_stind_i2;
+  typeStInd[ Ty.charN] := Asm.opc_stind_i2;
+  typeStInd[ Ty.byteN] := Asm.opc_stind_i1;
+  typeStInd[ Ty.uBytN] := Asm.opc_stind_i1;
+  typeStInd[ Ty.sIntN] := Asm.opc_stind_i2;
+  typeStInd[  Ty.intN] := Asm.opc_stind_i4;
+  typeStInd[ Ty.lIntN] := Asm.opc_stind_i8;
+  typeStInd[ Ty.sReaN] := Asm.opc_stind_r4;
+  typeStInd[ Ty.realN] := Asm.opc_stind_r8;
+  typeStInd[  Ty.setN] := Asm.opc_stind_i4;
+  typeStInd[Ty.anyPtr] := Asm.opc_stind_ref;
+  typeStInd[Ty.anyRec] := Asm.opc_stind_ref;
+
+(* ============================================================ *)
+END MsilUtil.
+(* ============================================================ *)

gpcp/NameHash.cp

@@ -0,0 +1,195 @@
+(* ==================================================================== *)
+(*									*)
+(*  NameHash Module for the Gardens Point Component Pascal Compiler.	*)
+(*  Implements the main symbol hash table. Uses closed hashing algrthm  *)
+(*	Copyright (c) John Gough 1999, 2000.				*)
+(*									*)
+(* ==================================================================== *)
+
+MODULE NameHash;
+
+  IMPORT 
+	GPCPcopyright,
+	Console,
+	GPText,
+	V := LitValue,
+	CPascalS,
+	RTS;
+
+(* ============================================================ *)
+
+  VAR
+    name      : POINTER TO ARRAY OF V.CharOpen;
+    size-     : INTEGER;
+    entries-  : INTEGER;
+    mainBkt*  : INTEGER;
+    winMain*  : INTEGER;
+
+(* ============================================================ *)
+  PROCEDURE^ enterStr*(IN str : ARRAY OF CHAR) : INTEGER;
+(* ============================================================ *)
+
+  PROCEDURE Reset;
+    VAR i : INTEGER;
+  BEGIN
+    FOR i := 0 TO size-1 DO name[i] := NIL END;
+  END Reset;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE InitNameHash*(nElem : INTEGER);
+  BEGIN
+    IF    nElem <=  4099 THEN nElem :=  4099;
+    ELSIF nElem <=  8209 THEN nElem :=  8209;
+    ELSIF nElem <= 12289 THEN nElem := 12289;
+    ELSIF nElem <= 18433 THEN nElem := 18433;
+    ELSIF nElem <= 32833 THEN nElem := 32833;
+    ELSIF nElem <= 46691 THEN nElem := 46691;
+    ELSE  nElem := 65521;
+    END;
+    IF (name # NIL) & (size >= nElem) THEN
+      Reset();
+    ELSE
+      size := nElem;
+      NEW(name, nElem); 
+    END;
+    entries := 0;
+    mainBkt := enterStr("CPmain");
+    winMain := enterStr("WinMain");
+  END InitNameHash;
+
+(* ============================================================ *)
+
+  PROCEDURE HashtableOverflow();
+    CONST str = "Overflow: Use -hsize > current ";
+  BEGIN
+    RTS.Throw(str + V.intToCharOpen(size)^);
+  END HashtableOverflow;
+
+(* ============================================================ *)
+
+  PROCEDURE hashStr(IN str : ARRAY OF CHAR) : INTEGER;
+    VAR tot : INTEGER;
+	idx : INTEGER;
+	len : INTEGER;
+  BEGIN [UNCHECKED_ARITHMETIC]
+    (* need to turn off overflow checking *)
+    len := LEN(str$);
+    tot := 0;
+    FOR idx := 0 TO len-1 DO
+      INC(tot, tot);
+      IF tot < 0 THEN INC(tot) END;
+      INC(tot, ORD(str[idx]));
+    END;
+    RETURN tot MOD size; 
+  END hashStr;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE hashSubStr(pos,len : INTEGER) : INTEGER;
+    VAR tot : INTEGER;
+	idx : INTEGER;
+  BEGIN [UNCHECKED_ARITHMETIC]
+    (* need to turn off overflow checking *)
+    tot := 0;
+    FOR idx := 0 TO len-1 DO
+      INC(tot, tot);
+      IF tot < 0 THEN INC(tot) END;
+      INC(tot, ORD(CPascalS.charAt(pos+idx)));
+    END;
+    RETURN tot MOD size; 
+  END hashSubStr;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE equalSubStr(val : V.CharOpen; pos,len : INTEGER) : BOOLEAN;
+    VAR i : INTEGER;
+  BEGIN
+   (* 
+    * LEN(val) includes the terminating nul character.
+    *)
+    IF LEN(val) # len+1 THEN RETURN FALSE END;
+    FOR i := 0 TO len-1 DO
+      IF CPascalS.charAt(pos+i) # val[i] THEN RETURN FALSE END;
+    END;
+    RETURN TRUE;
+  END equalSubStr;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE equalStr(val : V.CharOpen; IN str : ARRAY OF CHAR) : BOOLEAN;
+    VAR i : INTEGER;
+  BEGIN
+   (*
+    * LEN(val) includes the terminating nul character.
+    * LEN(str$) does not include the nul character.
+    *)
+    IF LEN(val) # LEN(str$)+1 THEN RETURN FALSE END;
+    FOR i := 0 TO LEN(val)-1 DO
+      IF str[i] # val[i] THEN RETURN FALSE END;
+    END;
+    RETURN TRUE;
+  END equalStr;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE enterStr*(IN str : ARRAY OF CHAR) : INTEGER;
+    VAR step : INTEGER;
+	key  : INTEGER;
+	val  : V.CharOpen;
+  BEGIN
+    step := 1;
+    key  := hashStr(str);
+    val  := name[key];
+    WHILE (val # NIL) & ~equalStr(val,str) DO
+      INC(key, step);
+      INC(step,2); 
+      IF step >= size THEN HashtableOverflow() END;
+      IF key >= size THEN DEC(key,size) END; (* wrap-around *)
+      val := name[key];
+    END;
+   (* Loop has been exitted. But for which reason? *)
+    IF val = NIL THEN
+      INC(entries);
+      name[key] := V.strToCharOpen(str);
+    END;				(* ELSE val already in table ... *)
+    RETURN key;
+  END enterStr;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE enterSubStr*(pos,len : INTEGER) : INTEGER;
+    VAR step : INTEGER;
+	key  : INTEGER;
+	val  : V.CharOpen;
+  BEGIN
+    step := 1;
+    key  := hashSubStr(pos,len);
+    val  := name[key];
+    WHILE (val # NIL) & ~equalSubStr(val,pos,len) DO
+      INC(key, step);
+      INC(step,2); 
+      IF step >= size THEN HashtableOverflow() END;
+      IF key >= size THEN DEC(key,size) END; (* wrap-around *)
+      val := name[key];
+    END;
+   (* Loop has been exitted. But for which reason? *)
+    IF val = NIL THEN
+      INC(entries);
+      name[key] := V.subStrToCharOpen(pos,len);
+    END;				(* ELSE val already in table ... *)
+    RETURN key;
+  END enterSubStr;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE charOpenOfHash*(hsh : INTEGER) : V.CharOpen;
+  BEGIN
+    RETURN name[hsh];
+  END charOpenOfHash;
+
+(* ============================================================ *)
+BEGIN (* ====================================================== *)
+END NameHash. (* =========================================== *)
+(* ============================================================ *)
+

gpcp/NewSymFileRW.cp

@@ -0,0 +1,2114 @@
+
+(* ==================================================================== *)
+(*									*)
+(*  SymFileRW:  Symbol-file reading and writing for GPCP.		*)
+(*	Copyright (c) John Gough 1999, 2000.				*)
+(*									*)
+(* ==================================================================== *)
+
+MODULE NewSymFileRW;
+
+  IMPORT 
+        GPCPcopyright,
+        RTS,
+        Error,
+        Console,
+        GF := GPFiles,
+        BF := GPBinFiles,
+        Id := IdDesc,
+        D  := Symbols,
+        Lt := LitValue,
+        Visitor,
+        ExprDesc,
+        Ty := TypeDesc,
+        B  := Builtin,
+        S  := CPascalS,
+        CSt:= CompState,
+        Nh := NameHash,
+        FileNames;
+
+(* ========================================================================= *
+// Collected syntax ---
+// 
+// SymFile    = Header [String (falSy | truSy | <other attribute>)]
+//              [ VersionName ]
+//		{Import | Constant | Variable | Type | Procedure} 
+//		TypeList Key.
+//	-- optional String is external name.
+//	-- falSy ==> Java class
+//	-- truSy ==> Java interface
+//	-- others ...
+// Header     = magic modSy Name.
+// VersionName= numSy longint numSy longint numSy longint.
+//      --            mj# mn#       bld rv#    8xbyte extract
+// Import     = impSy Name [String] Key.
+//	-- optional string is explicit external name of class
+// Constant   = conSy Name Literal.
+// Variable   = varSy Name TypeOrd.
+// Type       = typSy Name TypeOrd.
+// Procedure  = prcSy Name [String] FormalType.
+//	-- optional string is explicit external name of procedure
+// Method     = mthSy Name byte byte TypeOrd [String] [Name] FormalType.
+//	-- optional string is explicit external name of method
+// FormalType = [retSy TypeOrd] frmSy {parSy byte TypeOrd [String]} endFm.
+//	-- optional phrase is return type for proper procedures
+// TypeOrd    = ordinal.
+// TypeHeader = tDefS Ord [fromS Ord Name].
+//	-- optional phrase occurs if:
+//	-- type not from this module, i.e. indirect export
+// TypeList   = start { Array | Record | Pointer | ProcType | 
+//                Enum | Vector | NamedType } close.
+// Array      = TypeHeader arrSy TypeOrd (Byte | Number | <empty>) endAr.
+//	-- nullable phrase is array length for fixed length arrays
+// Vector     = TypeHeader vecSy TypeOrd endAr.
+// Pointer    = TypeHeader ptrSy TypeOrd.
+// Event      = TypeHeader evtSy FormalType.
+// ProcType   = TypeHeader pTpSy FormalType.
+// Record     = TypeHeader recSy recAtt [truSy | falSy] 
+//		[basSy TypeOrd] [iFcSy {basSy TypeOrd}]
+//		{Name TypeOrd} {Method} {Statics} endRc.
+//	-- truSy ==> is an extension of external interface
+//	-- falSy ==> is an extension of external class
+// 	-- basSy option defines base type, if not ANY / j.l.Object
+// Statics    = ( Constant | Variable | Procedure ).
+// Enum       = TypeHeader eTpSy { Constant } endRc.
+// NamedType  = TypeHeader.
+// Name	      = namSy byte UTFstring.
+// Literal    = Number | String | Set | Char | Real | falSy | truSy.
+// Byte       = bytSy byte.
+// String     = strSy UTFstring.
+// Number     = numSy longint.
+// Real       = fltSy ieee-double.
+// Set        = setSy integer.
+// Key        = keySy integer..
+// Char       = chrSy unicode character.
+//
+// Notes on the syntax:
+// All record types must have a Name field, even though this is often
+// redundant.  The issue is that every record type (including those that
+// are anonymous in CP) corresponds to a IR class, and the definer 
+// and the user of the class _must_ agree on the IR name of the class.
+// The same reasoning applies to procedure types, which must have equal
+// interface names in all modules.
+// ======================================================================== *)
+
+  CONST
+        modSy = ORD('H'); namSy = ORD('$'); bytSy = ORD('\');
+        numSy = ORD('#'); chrSy = ORD('c'); strSy = ORD('s');
+        fltSy = ORD('r'); falSy = ORD('0'); truSy = ORD('1');
+        impSy = ORD('I'); setSy = ORD('S'); keySy = ORD('K');
+        conSy = ORD('C'); typSy = ORD('T'); tDefS = ORD('t');
+        prcSy = ORD('P'); retSy = ORD('R'); mthSy = ORD('M');
+        varSy = ORD('V'); parSy = ORD('p'); start = ORD('&');
+        close = ORD('!'); recSy = ORD('{'); endRc = ORD('}');
+        frmSy = ORD('('); fromS = ORD('@'); endFm = ORD(')');
+        arrSy = ORD('['); endAr = ORD(']'); pTpSy = ORD('%');
+        ptrSy = ORD('^'); basSy = ORD('+'); eTpSy = ORD('e');
+        iFcSy = ORD('~'); evtSy = ORD('v'); vecSy = ORD('*');
+
+  CONST
+        magic   = 0DEADD0D0H;
+        syMag   = 0D0D0DEADH;
+        dumped* = -1;
+
+(* ============================================================ *)
+
+  TYPE
+        SymFile = POINTER TO RECORD 
+        	    file : BF.FILE;
+        	    cSum : INTEGER;
+        	    modS : Id.BlkId;
+        	    iNxt : INTEGER;
+        	    oNxt : INTEGER;
+        	    work : D.TypeSeq;
+        	  END;
+
+  TYPE
+        SymFileReader* = POINTER TO RECORD
+        	    file  : BF.FILE;
+        	    modS  : Id.BlkId;
+        	    impS  : Id.BlkId;
+        	    sSym  : INTEGER;
+        	    cAtt  : CHAR;
+        	    iAtt  : INTEGER;
+        	    lAtt  : LONGINT;
+        	    rAtt  : REAL;
+        	    sAtt  : FileNames.NameString;
+                    rScp  : ImpResScope;
+                    oArray : D.IdSeq;
+        	    sArray : D.ScpSeq;		(* These two sequences	*)
+  		    tArray : D.TypeSeq;		(* must be private as   *)
+        	  END;				(* file parses overlap. *)
+
+(* ============================================================ *)
+
+  TYPE ImpResScope   = POINTER TO RECORD
+                         work : D.ScpSeq;       (* Direct and ind imps. *)
+                         host : Id.BlkId;       (* Compilation module.  *)
+                       END;
+
+(* ============================================================ *)
+
+  TYPE	TypeLinker*  = POINTER TO RECORD (D.SymForAll) sym : SymFileReader END;
+  TYPE	SymFileSFA*  = POINTER TO RECORD (D.SymForAll) sym : SymFile END;
+  TYPE	ResolveAll*  = POINTER TO RECORD (D.SymForAll) END;
+
+(* ============================================================ *)
+
+  VAR   lastKey : INTEGER;	(* private state for CPMake *)
+        fSepArr : ARRAY 2 OF CHAR;
+
+(* ============================================================ *)
+
+  PROCEDURE GetLastKeyVal*() : INTEGER;
+  BEGIN
+    RETURN lastKey;
+  END GetLastKeyVal;
+
+(* ============================================================ *)
+(* ========	Various writing utility procedures	======= *)
+(* ============================================================ *)
+
+  PROCEDURE newSymFile(mod : Id.BlkId) : SymFile;
+    VAR new : SymFile;
+  BEGIN
+    NEW(new);
+   (*
+    *  Initialization: cSum starts at zero. Since impOrd of
+    *  the module is zero, impOrd of the imports starts at 1.
+    *)
+    new.cSum := 0;
+    new.iNxt := 1;
+    new.oNxt := D.tOffset;
+    new.modS := mod;
+    D.InitTypeSeq(new.work, 32);
+    RETURN new;
+  END newSymFile;
+
+(* ======================================= *)
+
+  PROCEDURE (f : SymFile)Write(chr : INTEGER),NEW;
+    VAR tmp : INTEGER;
+  BEGIN [UNCHECKED_ARITHMETIC]
+   (* need to turn off overflow checking here *)
+    tmp := f.cSum * 2 + chr;
+    IF f.cSum < 0 THEN INC(tmp) END;
+    f.cSum := tmp;
+    BF.WriteByte(f.file, chr);
+  END Write;
+
+(* ======================================= *)
+
+  PROCEDURE (f : SymFile)WriteStrUTF(IN nam : ARRAY OF CHAR),NEW;
+    VAR buf : ARRAY 256 OF INTEGER;
+        num : INTEGER;
+        idx : INTEGER;
+        chr : INTEGER;
+  BEGIN
+    num := 0;
+    idx := 0;
+    chr := ORD(nam[idx]);
+    WHILE chr # 0H DO
+      IF    chr <= 7FH THEN 		(* [0xxxxxxx] *)
+        buf[num] := chr; INC(num);
+      ELSIF chr <= 7FFH THEN 		(* [110xxxxx,10xxxxxx] *)
+        buf[num+1] := 080H + chr MOD 64; chr := chr DIV 64;
+        buf[num  ] := 0C0H + chr; INC(num, 2);
+      ELSE 				(* [1110xxxx,10xxxxxx,10xxxxxxx] *)
+        buf[num+2] := 080H + chr MOD 64; chr := chr DIV 64;
+        buf[num+1] := 080H + chr MOD 64; chr := chr DIV 64;
+        buf[num  ] := 0E0H + chr; INC(num, 3);
+      END;
+      INC(idx); chr := ORD(nam[idx]);
+    END;
+    f.Write(num DIV 256);
+    f.Write(num MOD 256);
+    FOR idx := 0 TO num-1 DO f.Write(buf[idx]) END;
+  END WriteStrUTF;
+
+(* ======================================= *)
+
+  PROCEDURE (f : SymFile)WriteOpenUTF(chOp : Lt.CharOpen),NEW;
+    VAR buf : ARRAY 256 OF INTEGER;
+        num : INTEGER;
+        idx : INTEGER;
+        chr : INTEGER;
+  BEGIN
+    num := 0;
+    idx := 0;
+    chr := ORD(chOp[0]);
+    WHILE chr # 0H DO
+      IF    chr <= 7FH THEN 		(* [0xxxxxxx] *)
+        buf[num] := chr; INC(num);
+      ELSIF chr <= 7FFH THEN 		(* [110xxxxx,10xxxxxx] *)
+        buf[num+1] := 080H + chr MOD 64; chr := chr DIV 64;
+        buf[num  ] := 0C0H + chr; INC(num, 2);
+      ELSE 				(* [1110xxxx,10xxxxxx,10xxxxxxx] *)
+        buf[num+2] := 080H + chr MOD 64; chr := chr DIV 64;
+        buf[num+1] := 080H + chr MOD 64; chr := chr DIV 64;
+        buf[num  ] := 0E0H + chr; INC(num, 3);
+      END;
+      INC(idx);
+      chr := ORD(chOp[idx]);
+    END;
+    f.Write(num DIV 256);
+    f.Write(num MOD 256);
+    FOR idx := 0 TO num-1 DO f.Write(buf[idx]) END;
+  END WriteOpenUTF;
+
+(* ======================================= *)
+
+  PROCEDURE (f : SymFile)WriteString(IN nam : ARRAY OF CHAR),NEW;
+  BEGIN
+    f.Write(strSy); 
+    f.WriteStrUTF(nam);
+  END WriteString;
+
+(* ======================================= *)
+
+  PROCEDURE (f : SymFile)WriteName(idD : D.Idnt),NEW;
+  BEGIN
+    f.Write(namSy); 
+    f.Write(idD.vMod); 
+    f.WriteOpenUTF(Nh.charOpenOfHash(idD.hash));
+  END WriteName;
+
+(* ======================================= *)
+
+  PROCEDURE (f : SymFile)WriteChar(chr : CHAR),NEW;
+    CONST mask = {0 .. 7};
+    VAR   a,b,int : INTEGER;
+  BEGIN
+    f.Write(chrSy);
+    int := ORD(chr);
+    b := ORD(BITS(int) * mask); int := ASH(int, -8);
+    a := ORD(BITS(int) * mask); 
+    f.Write(a); 
+    f.Write(b); 
+  END WriteChar;
+
+(* ======================================= *)
+
+  PROCEDURE (f : SymFile)Write4B(int : INTEGER),NEW;
+    CONST mask = {0 .. 7};
+    VAR   a,b,c,d : INTEGER;
+  BEGIN
+    d := ORD(BITS(int) * mask); int := ASH(int, -8);
+    c := ORD(BITS(int) * mask); int := ASH(int, -8);
+    b := ORD(BITS(int) * mask); int := ASH(int, -8);
+    a := ORD(BITS(int) * mask); 
+    f.Write(a); 
+    f.Write(b); 
+    f.Write(c); 
+    f.Write(d); 
+  END Write4B;
+
+(* ======================================= *)
+
+  PROCEDURE (f : SymFile)Write8B(val : LONGINT),NEW;
+  BEGIN
+    f.Write4B(RTS.hiInt(val));
+    f.Write4B(RTS.loInt(val));
+  END Write8B;
+
+(* ======================================= *)
+
+  PROCEDURE (f : SymFile)WriteNum(val : LONGINT),NEW;
+  BEGIN
+    f.Write(numSy);
+    f.Write8B(val);
+  END WriteNum;
+
+(* ======================================= *)
+
+  PROCEDURE (f : SymFile)WriteReal(flt : REAL),NEW;
+    VAR rslt : LONGINT;
+  BEGIN
+    f.Write(fltSy);
+    rslt := RTS.realToLongBits(flt);
+    f.Write8B(rslt);
+  END WriteReal;
+
+(* ======================================= *)
+
+  PROCEDURE (f : SymFile)WriteOrd(ord : INTEGER),NEW;
+  BEGIN
+    IF ord <= 7FH THEN 
+      f.Write(ord);
+    ELSIF ord <= 7FFFH THEN
+      f.Write(128 + ord MOD 128);	(* LS7-bits first *)
+      f.Write(ord DIV 128);		(* MS8-bits next  *)
+    ELSE
+      ASSERT(FALSE);
+    END;
+  END WriteOrd;
+
+(* ======================================= *)
+
+  PROCEDURE (f : SymFile)EmitTypeOrd(t : D.Type),NEW;
+  (*
+   *  This proceedure facilitates the naming rules
+   *  for records and (runtime) classes: -
+   *
+   *  (1)  Classes derived from named record types have
+   *       names synthesized from the record typename.
+   *  (2)  If a named pointer is bound to an anon record
+   *       the class takes its name from the pointer name.
+   *  (3)  If both the pointer and the record types have
+   *       names, the class is named from the record.
+   *)
+    VAR recT : Ty.Record;
+   (* ------------------------------------ *)
+    PROCEDURE AddToWorklist(syF :SymFile; tyD : D.Type);
+    BEGIN
+      tyD.dump := syF.oNxt; INC(syF.oNxt);
+      D.AppendType(syF.work, tyD);
+      IF tyD.idnt = NIL THEN 
+        tyD.idnt := Id.newSfAnonId(tyD.dump);
+        tyD.idnt.type := tyD;
+      END;
+    END AddToWorklist;
+   (* ------------------------------------ *)
+  BEGIN
+    IF t.dump = 0 THEN (* type is not dumped yet *)
+      WITH t : Ty.Record DO
+       (*
+        *   We wish to ensure that anonymous records are
+        *   never emitted before their binding pointer
+        *   types.  This ensures that we do not need to
+        *   merge types when reading the files.
+        *)
+        IF (t.bindTp # NIL) & 
+           (t.bindTp.dump = 0) THEN 
+          AddToWorklist(f, t.bindTp);		(* First the pointer...  *)
+        END;
+        AddToWorklist(f, t);			(* Then this record type *)
+      | t : Ty.Pointer DO
+       (*
+        *  If a pointer to record is being emitted, and 
+        *  the pointer is NOT anonymous, then the class
+        *  is known by the name of the record.  Thus the
+        *  record name must be emitted, at least opaquely.
+        *  Furthermore, we must indicate the binding
+        *  relationship between the pointer and record.
+        *  (It is possible that DCode need record size.)
+        *)
+        AddToWorklist(f, t);			(* First this pointer... *)
+        IF (t.boundTp # NIL) & 
+           (t.boundTp.dump = 0) &
+           (t.boundTp IS Ty.Record) THEN
+          recT := t.boundTp(Ty.Record);
+          IF recT.bindTp = NIL THEN
+            AddToWorklist(f, t.boundTp);	(* Then the record type  *)
+          END;
+        END;
+      ELSE (* All others *)
+        AddToWorklist(f, t);			(* Just add the type.    *)
+      END;
+    END;
+    f.WriteOrd(t.dump);
+  END EmitTypeOrd;
+
+(* ============================================================ *)
+(* ========	    Various writing procedures		======= *)
+(* ============================================================ *)
+
+  PROCEDURE (f : SymFile)FormalType(t : Ty.Procedure),NEW;
+  (*
+  ** FormalType = [retSy TypeOrd] frmSy {parSy Byte TypeOrd [String]} endFm.
+  *)
+    VAR indx : INTEGER;
+        parI : Id.ParId;
+  BEGIN
+    IF t.retType # NIL THEN
+      f.Write(retSy);
+      f.EmitTypeOrd(t.retType);
+    END;
+    f.Write(frmSy);
+    FOR indx := 0 TO t.formals.tide-1 DO
+      parI := t.formals.a[indx];
+      f.Write(parSy);
+      f.Write(parI.parMod);
+      f.EmitTypeOrd(parI.type);
+     (*
+      *   Emit Optional Parameter name 
+      *)
+      IF ~CSt.legacy & (parI.hash # 0) THEN
+        f.WriteString(Nh.charOpenOfHash(parI.hash));
+      END;
+    END;
+    f.Write(endFm);
+  END FormalType;
+
+(* ======================================= *)
+
+  PROCEDURE (f : SymFile)EmitConstId(id : Id.ConId),NEW;
+    VAR conX : ExprDesc.LeafX;
+        cVal : Lt.Value;
+        sVal : INTEGER;
+  (*
+  ** Constant = conSy Name Literal.
+  ** Literal  = Number | String | Set | Char | Real | falSy | truSy.
+  *)
+  BEGIN
+    conX := id.conExp(ExprDesc.LeafX);
+    cVal := conX.value;
+    f.Write(conSy);
+    f.WriteName(id);
+    CASE conX.kind OF
+    | ExprDesc.tBool  : f.Write(truSy);
+    | ExprDesc.fBool  : f.Write(falSy);
+    | ExprDesc.numLt  : f.WriteNum(cVal.long());
+    | ExprDesc.charLt : f.WriteChar(cVal.char());
+    | ExprDesc.realLt : f.WriteReal(cVal.real());
+    | ExprDesc.strLt  : f.WriteString(cVal.chOpen());
+    | ExprDesc.setLt  : 
+        f.Write(setSy); 
+        IF cVal # NIL THEN sVal := cVal.int() ELSE sVal := 0 END;
+        f.Write4B(sVal);
+    END;
+  END EmitConstId;
+
+(* ======================================= *)
+
+  PROCEDURE (f : SymFile)EmitTypeId(id : Id.TypId),NEW;
+  (*
+  **  Type = TypeSy Name TypeOrd.
+  *)
+  BEGIN
+    f.Write(typSy);
+    f.WriteName(id);
+    f.EmitTypeOrd(id.type);
+  END EmitTypeId;
+
+(* ======================================= *)
+
+  PROCEDURE (f : SymFile)EmitVariableId(id : Id.VarId),NEW;
+  (*
+  ** Variable = varSy Name TypeOrd.
+  *)
+  BEGIN
+    f.Write(varSy);
+    f.WriteName(id);
+    f.EmitTypeOrd(id.type);
+  END EmitVariableId;
+
+(* ======================================= *)
+
+  PROCEDURE (f : SymFile)EmitImportId(id : Id.BlkId),NEW;
+  (*
+  ** Import = impSy Name.
+  *)
+  BEGIN
+    IF D.need IN id.xAttr THEN
+      f.Write(impSy);
+      f.WriteName(id);
+      IF id.scopeNm # NIL THEN f.WriteString(id.scopeNm) END;
+      f.Write(keySy);
+      f.Write4B(id.modKey);
+      id.impOrd := f.iNxt; INC(f.iNxt);
+    END;
+  END EmitImportId;
+
+(* ======================================= *)
+
+  PROCEDURE (f : SymFile)EmitProcedureId(id : Id.PrcId),NEW;
+  (*
+  ** Procedure = prcSy Name FormalType.
+  *)
+  BEGIN
+    f.Write(prcSy);
+    f.WriteName(id);
+    IF id.prcNm # NIL THEN f.WriteString(id.prcNm) END;
+    IF id.kind = Id.ctorP THEN f.Write(truSy) END;
+    f.FormalType(id.type(Ty.Procedure));
+  END EmitProcedureId;
+
+(* ======================================= *)
+
+  PROCEDURE (f : SymFile)EmitMethodId(id : Id.MthId),NEW;
+  (*
+  ** Method = mthSy Name Byte Byte TypeOrd [strSy ] FormalType.
+  *)
+  BEGIN
+    IF id.kind = Id.fwdMth THEN id := id.resolve(Id.MthId) END;
+    f.Write(mthSy);
+    f.WriteName(id);
+    f.Write(ORD(id.mthAtt));
+    f.Write(id.rcvFrm.parMod);
+    f.EmitTypeOrd(id.rcvFrm.type);
+    IF id.prcNm # NIL THEN f.WriteString(id.prcNm) END;
+    IF ~CSt.legacy & (id.rcvFrm.hash # 0) THEN f.WriteName(id.rcvFrm) END;
+    f.FormalType(id.type(Ty.Procedure));
+  END EmitMethodId;
+
+(* ======================================= *)
+
+  PROCEDURE moduleOrd(tpId : D.Idnt) : INTEGER;
+    VAR impM : Id.BlkId;
+  BEGIN
+    IF  (tpId = NIL) OR 
+        (tpId.dfScp = NIL) OR 
+        (tpId.dfScp.kind = Id.modId) THEN
+      RETURN 0;
+    ELSE
+      impM := tpId.dfScp(Id.BlkId);
+      IF impM.impOrd = 0 THEN RETURN -1 ELSE RETURN impM.impOrd END;
+    END;
+  END moduleOrd;
+
+(* ======================================= *)
+
+  PROCEDURE (f : SymFile)isImportedPointer(ptr : Ty.Pointer) : BOOLEAN,NEW;
+  BEGIN
+    RETURN (ptr.idnt # NIL) & 
+           (ptr.idnt.dfScp # NIL) & 
+           (ptr.idnt.dfScp # f.modS);
+  END isImportedPointer;
+
+  PROCEDURE (f : SymFile)isImportedRecord(rec : Ty.Record) : BOOLEAN,NEW;
+  BEGIN
+    IF rec.bindTp # NIL THEN (* bindTp takes precedence *)
+      RETURN f.isImportedPointer(rec.bindTp(Ty.Pointer));
+    ELSIF rec.idnt # NIL THEN 
+      RETURN (rec.idnt.dfScp # NIL) & (rec.idnt.dfScp # f.modS);
+    ELSE 
+      RETURN FALSE;
+    END;
+  END isImportedRecord;
+
+  PROCEDURE (f : SymFile)isImportedArray(arr : Ty.Array) : BOOLEAN,NEW;
+  BEGIN
+    RETURN (arr.idnt # NIL) & 
+           (arr.idnt.dfScp # NIL) & 
+           (arr.idnt.dfScp # f.modS);
+  END isImportedArray; 
+
+(* ======================================= *)
+
+  PROCEDURE (f : SymFile)EmitTypeHeader(t : D.Type),NEW;
+  (*
+  **  TypeHeader = typSy Ord [fromS Ord Name].
+  *)
+    VAR mod : INTEGER;
+        idt : D.Idnt;
+   (* =================================== *)
+    PROCEDURE warp(id : D.Idnt) : D.Idnt;
+    BEGIN
+      IF    id.type = CSt.ntvObj THEN RETURN CSt.objId;
+      ELSIF id.type = CSt.ntvStr THEN RETURN CSt.strId;
+      ELSIF id.type = CSt.ntvExc THEN RETURN CSt.excId;
+      ELSIF id.type = CSt.ntvTyp THEN RETURN CSt.clsId;
+      ELSE  RETURN NIL;
+      END;
+    END warp;
+   (* =================================== *)
+  BEGIN
+    WITH t : Ty.Record DO
+      IF t.bindTp = NIL THEN 
+        idt := t.idnt;
+      ELSIF t.bindTp.dump = 0 THEN
+        ASSERT(FALSE);
+        idt := NIL;
+      ELSE
+        idt := t.bindTp.idnt;
+      END;
+    ELSE
+      idt := t.idnt;
+    END;
+(*
+ *  mod := moduleOrd(t.idnt);
+ *)
+    mod := moduleOrd(idt);
+    f.Write(tDefS);
+    f.WriteOrd(t.dump);
+   (*
+    *  Convert native types back to RTS.nativeXXX, if necessary.
+    *  That is ... if the native module is not explicitly imported.
+    *)
+    IF mod = -1 THEN idt := warp(idt); mod := moduleOrd(idt) END;
+    IF mod # 0 THEN
+      f.Write(fromS);
+      f.WriteOrd(mod);
+      f.WriteName(idt);
+    END;
+  END EmitTypeHeader;
+
+(* ======================================= *)
+
+  PROCEDURE (f : SymFile)EmitArrOrVecType(t : Ty.Array),NEW;
+  BEGIN
+    f.EmitTypeHeader(t);
+    IF ~f.isImportedArray(t) THEN
+(*
+ *  IF t.force # D.noEmit THEN	(* Don't emit structure unless forced *)
+ *)
+      IF t.kind = Ty.vecTp THEN f.Write(vecSy) ELSE f.Write(arrSy) END;
+      f.EmitTypeOrd(t.elemTp);
+      IF t.length > 127 THEN
+        f.Write(numSy);
+        f.Write8B(t.length);
+      ELSIF t.length > 0 THEN
+        f.Write(bytSy);
+        f.Write(t.length);
+      END;
+      f.Write(endAr);
+    END;
+  END EmitArrOrVecType;
+
+(* ======================================= *)
+
+  PROCEDURE (f : SymFile)EmitRecordType(t : Ty.Record),NEW;
+    VAR index  : INTEGER;
+        field  : D.Idnt;
+        method : D.Idnt;
+  (*
+  **  Record = TypeHeader recSy recAtt [truSy | falSy | <others>] 
+  **		[basSy TypeOrd] [iFcSy {basSy TypeOrd}]
+  **		{Name TypeOrd} {Method} {Statics} endRc.
+  *)
+  BEGIN
+    f.EmitTypeHeader(t);
+    IF ~f.isImportedRecord(t) THEN
+(*
+ *  IF t.force # D.noEmit THEN	(* Don't emit structure unless forced *)
+ *)
+      f.Write(recSy);
+      index := t.recAtt; 
+      IF D.noNew IN t.xAttr THEN INC(index, Ty.noNew) END;
+      IF D.clsTp IN t.xAttr THEN INC(index, Ty.clsRc) END;
+      f.Write(index);
+   (* ########## *)
+      IF t.recAtt = Ty.iFace THEN
+  	f.Write(truSy);
+      ELSIF CSt.special OR (D.isFn IN t.xAttr) THEN  
+        f.Write(falSy);
+      END;
+   (* ########## *)
+      IF t.baseTp # NIL THEN			(* this is the parent type *)
+        f.Write(basSy);
+        f.EmitTypeOrd(t.baseTp);
+      END;
+   (* ########## *)
+      IF t.interfaces.tide > 0 THEN
+        f.Write(iFcSy);
+        FOR index := 0 TO t.interfaces.tide-1 DO	(* any interfaces  *)
+          f.Write(basSy);
+          f.EmitTypeOrd(t.interfaces.a[index]);
+        END;
+      END;
+   (* ########## *)
+      FOR index := 0 TO t.fields.tide-1 DO
+        field := t.fields.a[index];
+        IF (field.vMod # D.prvMode) & (field.type # NIL) THEN
+          f.WriteName(field);
+          f.EmitTypeOrd(field.type);
+        END;
+      END;
+      FOR index := 0 TO t.methods.tide-1 DO
+        method := t.methods.a[index];
+        IF method.vMod # D.prvMode THEN
+          f.EmitMethodId(method(Id.MthId));
+        END;
+      END;
+      FOR index := 0 TO t.statics.tide-1 DO
+        field := t.statics.a[index];
+        IF field.vMod # D.prvMode THEN
+          CASE field.kind OF
+          | Id.conId  : f.EmitConstId(field(Id.ConId));
+          | Id.varId  : f.EmitVariableId(field(Id.VarId));
+          | Id.ctorP,
+            Id.conPrc : f.EmitProcedureId(field(Id.PrcId));
+          END;
+        END;
+      END;
+      f.Write(endRc);
+    END;
+    D.AppendType(f.modS.expRecs, t);
+  END EmitRecordType;
+
+(* ======================================= *)
+
+  PROCEDURE (f : SymFile)EmitEnumType(t : Ty.Enum),NEW;
+    VAR index  : INTEGER;
+        const  : D.Idnt;
+  (*
+  **  Enum = TypeHeader eTpSy { constant } endRc.
+  *)
+  BEGIN
+    f.EmitTypeHeader(t);
+    f.Write(eTpSy);
+    FOR index := 0 TO t.statics.tide-1 DO
+      const := t.statics.a[index];
+      IF const.vMod # D.prvMode THEN f.EmitConstId(const(Id.ConId)) END;
+    END;
+    f.Write(endRc);
+    (* D.AppendType(f.modS.expRecs, t); *)
+  END EmitEnumType;
+
+(* ======================================= *)
+
+  PROCEDURE (f : SymFile)EmitOpaqueType(t : Ty.Opaque),NEW;
+  BEGIN
+    f.EmitTypeHeader(t);
+  END EmitOpaqueType;
+
+(* ======================================= *)
+
+  PROCEDURE (f : SymFile)EmitPointerType(t : Ty.Pointer),NEW;
+  BEGIN
+    f.EmitTypeHeader(t);
+    IF ~f.isImportedPointer(t) THEN
+(*
+ *  IF (t.force # D.noEmit) OR 			(* Only emit structure if *)
+ *     (t.boundTp.force # D.noEmit) THEN	(* ptr or boundTp forced. *)
+ *)
+      f.Write(ptrSy);
+      f.EmitTypeOrd(t.boundTp);
+    END;
+  END EmitPointerType;
+
+(* ======================================= *)
+
+  PROCEDURE (f : SymFile)EmitProcedureType(t : Ty.Procedure),NEW;
+  BEGIN
+    f.EmitTypeHeader(t);
+    IF t.isEventType() THEN f.Write(evtSy) ELSE f.Write(pTpSy) END;
+    f.FormalType(t);
+    D.AppendType(f.modS.expRecs, t);
+  END EmitProcedureType;
+
+(* ======================================= *)
+
+  PROCEDURE (f : SymFile)EmitTypeList(),NEW;
+    VAR indx : INTEGER;
+        type : D.Type;
+  BEGIN
+   (*
+    *   We cannot use a FOR loop here, as the tide changes
+    *   during evaluation, as a result of reaching new types.
+    *)
+    indx := 0;
+    WHILE indx < f.work.tide DO
+      type := f.work.a[indx];
+      WITH type : Ty.Array     DO f.EmitArrOrVecType(type);
+      |    type : Ty.Record    DO f.EmitRecordType(type);
+      |    type : Ty.Opaque    DO f.EmitOpaqueType(type);
+      |    type : Ty.Pointer   DO f.EmitPointerType(type);
+      |    type : Ty.Procedure DO f.EmitProcedureType(type);
+      |    type : Ty.Enum      DO f.EmitEnumType(type);
+      END;
+      INC(indx);
+    END;
+  END EmitTypeList;
+
+(* ======================================= *)
+
+  PROCEDURE EmitSymfile*(m : Id.BlkId);
+
+    VAR symVisit : SymFileSFA;
+        symfile  : SymFile;
+        marker   : INTEGER;
+        fNamePtr : Lt.CharOpen;
+  (* ----------------------------------- *)
+    PROCEDURE mkPathName(m : D.Idnt) : Lt.CharOpen;
+      VAR str : Lt.CharOpen;
+    BEGIN
+      str := BOX(CSt.symDir);
+      IF str[LEN(str) - 2] = GF.fileSep THEN
+        str := BOX(str^ + D.getName.ChPtr(m)^ + ".cps");
+      ELSE
+        str := BOX(str^ + fSepArr + D.getName.ChPtr(m)^ + ".cps");
+      END;
+      RETURN str;
+    END mkPathName;
+  (* ----------------------------------- *)
+  (*
+  ** SymFile = Header [String (falSy | truSy | <others>)]
+  **            [ VersionName]
+  **		{Import | Constant | Variable
+  **                 | Type | Procedure | Method} TypeList.
+  ** Header = magic modSy Name.
+  ** VersionName= numSy longint numSy longint numSy longint.
+  **      --            mj# mn#       bld rv#        8xbyte extract
+  *)
+  BEGIN
+   (*
+    *  Create the SymFile structure, and open the output file.
+    *)
+    symfile := newSymFile(m);
+   (* Start of alternative gpcp1.2 code *)
+    IF CSt.symDir # "" THEN
+      fNamePtr := mkPathName(m);
+      symfile.file := BF.createPath(fNamePtr);
+    ELSE
+      fNamePtr := BOX(D.getName.ChPtr(m)^ + ".cps");
+      symfile.file := BF.createFile(fNamePtr);
+    END;
+    IF symfile.file = NIL THEN
+      S.SemError.Report(177, 0, 0);
+      Error.WriteString("Cannot create file <" + fNamePtr^ + ">"); 
+      Error.WriteLn;
+      RETURN;
+    ELSE
+     (*
+      *  Emit the symbol file header
+      *)
+      IF CSt.verbose THEN CSt.Message("Created " + fNamePtr^) END;
+     (* End of alternative gpcp1.2 code *)
+      IF D.rtsMd IN m.xAttr THEN
+        marker := RTS.loInt(syMag);	(* ==> a system module *)
+      ELSE
+        marker := RTS.loInt(magic);	(* ==> a normal module *)
+      END;
+      symfile.Write4B(RTS.loInt(marker));
+      symfile.Write(modSy);
+      symfile.WriteName(m);
+      IF m.scopeNm # NIL THEN (* explicit name *)
+        symfile.WriteString(m.scopeNm);
+        symfile.Write(falSy);
+      END;
+     (*
+      *  Emit the optional TypeName, if required.
+      *
+      *  VersionName= numSy longint numSy longint numSy longint.
+      *       --            mj# mn#       bld rv#        8xbyte extract
+      *)
+      IF m.verNm # NIL THEN
+        symfile.WriteNum(m.verNm[0] * 100000000L + m.verNm[1]);
+        symfile.WriteNum(m.verNm[2] * 100000000L + m.verNm[3]);
+        symfile.WriteNum(m.verNm[4] * 100000000L + m.verNm[5]);
+      END;
+     (*
+      *  Create the symbol table visitor, an extension of 
+      *  Symbols.SymForAll type.  Emit symbols from the scope.
+      *)
+      NEW(symVisit);
+      symVisit.sym := symfile;
+      symfile.modS.symTb.Apply(symVisit); 
+     (*
+      *  Now emit the types on the worklist.
+      *)
+      symfile.Write(start);
+      symfile.EmitTypeList();
+      symfile.Write(close);
+     (*
+      *  Now emit the accumulated checksum key symbol.
+      *)
+      symfile.Write(keySy);
+      lastKey := symfile.cSum;
+      IF CSt.special THEN symfile.Write4B(0) ELSE symfile.Write4B(lastKey) END;
+      BF.CloseFile(symfile.file);
+    END;
+  END EmitSymfile;
+
+(* ============================================================ *)
+(* ========	Various reading utility procedures	======= *)
+(* ============================================================ *)
+
+  PROCEDURE read(f : BF.FILE) : INTEGER;
+  BEGIN
+    RETURN BF.readByte(f);
+  END read;
+
+(* ======================================= *)
+
+  PROCEDURE ReadUTF(f : BF.FILE; OUT nam : ARRAY OF CHAR);
+    CONST
+        bad = "Bad UTF-8 string";
+    VAR num : INTEGER;
+        bNm : INTEGER;
+        idx : INTEGER;
+        chr : INTEGER;
+  BEGIN
+    num := 0;
+    bNm := read(f) * 256 + read(f);
+    FOR idx := 0 TO bNm-1 DO
+      chr := read(f);
+      IF chr <= 07FH THEN		(* [0xxxxxxx] *)
+        nam[num] := CHR(chr); INC(num);
+      ELSIF chr DIV 32 = 06H THEN	(* [110xxxxx,10xxxxxx] *)
+        bNm := chr MOD 32 * 64;
+        chr := read(f);
+        IF chr DIV 64 = 02H THEN
+          nam[num] := CHR(bNm + chr MOD 64); INC(num);
+        ELSE
+          RTS.Throw(bad);
+        END;
+      ELSIF chr DIV 16 = 0EH THEN	(* [1110xxxx,10xxxxxx,10xxxxxxx] *)
+        bNm := chr MOD 16 * 64;
+        chr := read(f);
+        IF chr DIV 64 = 02H THEN
+          bNm := (bNm + chr MOD 64) * 64; 
+          chr := read(f);
+          IF chr DIV 64 = 02H THEN
+            nam[num] := CHR(bNm + chr MOD 64); INC(num);
+          ELSE 
+            RTS.Throw(bad);
+          END;
+        ELSE
+          RTS.Throw(bad);
+        END;
+      ELSE
+        RTS.Throw(bad);
+      END;
+    END;
+    nam[num] := 0X;
+  END ReadUTF;
+
+(* ======================================= *)
+
+  PROCEDURE readChar(f : BF.FILE) : CHAR;
+  BEGIN
+    RETURN CHR(read(f) * 256 + read(f));
+  END readChar;
+
+(* ======================================= *)
+
+  PROCEDURE readInt(f : BF.FILE) : INTEGER;
+  BEGIN [UNCHECKED_ARITHMETIC]
+    (* overflow checking off here *)
+    RETURN ((read(f) * 256 + read(f)) * 256 + read(f)) * 256 + read(f);
+  END readInt;
+
+(* ======================================= *)
+
+  PROCEDURE readLong(f : BF.FILE) : LONGINT;
+    VAR result : LONGINT;
+        index  : INTEGER;
+  BEGIN [UNCHECKED_ARITHMETIC]
+    (* overflow checking off here *)
+    result := read(f);
+    FOR index := 1 TO 7 DO
+      result := result * 256 + read(f);
+    END;
+    RETURN result;
+  END readLong;
+
+(* ======================================= *)
+
+  PROCEDURE readReal(f : BF.FILE) : REAL;
+    VAR result : LONGINT;
+  BEGIN
+    result := readLong(f);
+    RETURN RTS.longBitsToReal(result);
+  END readReal;
+
+(* ======================================= *)
+
+  PROCEDURE readOrd(f : BF.FILE) : INTEGER;
+    VAR chr : INTEGER;
+  BEGIN
+    chr := read(f);
+    IF chr <= 07FH THEN RETURN chr;
+    ELSE
+      DEC(chr, 128);
+      RETURN chr + read(f) * 128;
+    END;
+  END readOrd;
+
+(* ============================================================ *)
+(* ========		Symbol File Reader		======= *)
+(* ============================================================ *)
+
+  PROCEDURE newSymFileReader*(mod : Id.BlkId) : SymFileReader;
+    VAR new : SymFileReader;
+  BEGIN
+    NEW(new);
+    new.modS := mod;
+    D.InitIdSeq(new.oArray, 4);
+    D.InitTypeSeq(new.tArray, 8);
+    D.InitScpSeq(new.sArray, 8);
+    RETURN new;
+  END newSymFileReader;
+
+(* ======================================= *)
+  PROCEDURE^ (f : SymFileReader)SymFile(IN nm : ARRAY OF CHAR),NEW;
+(* ======================================= *)
+
+  PROCEDURE Abandon(f : SymFileReader);
+  BEGIN
+    RTS.Throw("Bad symbol file format" + 
+              Nh.charOpenOfHash(f.impS.hash)^); 
+  END Abandon;
+
+(* ======================================= *)
+
+  PROCEDURE (f : SymFileReader)GetSym(),NEW;
+    VAR file : BF.FILE;
+  BEGIN
+    file := f.file;
+    f.sSym := read(file);
+    CASE f.sSym OF
+    | namSy : 
+        f.iAtt := read(file); ReadUTF(file, f.sAtt);
+    | strSy : 
+        ReadUTF(file, f.sAtt);
+    | retSy, fromS, tDefS, basSy :
+        f.iAtt := readOrd(file);
+    | bytSy :
+        f.iAtt := read(file);
+    | keySy, setSy :
+        f.iAtt := readInt(file);
+    | numSy :
+        f.lAtt := readLong(file);
+    | fltSy :
+        f.rAtt := readReal(file);
+    | chrSy :
+        f.cAtt := readChar(file);
+    ELSE (* nothing to do *)
+    END;
+  END GetSym;
+
+(* ======================================= *)
+
+  PROCEDURE (f : SymFileReader)ReadPast(sym : INTEGER),NEW;
+  BEGIN
+    IF f.sSym # sym THEN Abandon(f) END;
+    f.GetSym();
+  END ReadPast;
+
+(* ======================================= *)
+
+  PROCEDURE (f : SymFileReader)Parse*(scope : Id.BlkId),NEW;
+    VAR filNm    : Lt.CharOpen;
+        fileName : Lt.CharOpen;
+        message  : Lt.CharOpen;
+        marker   : INTEGER;
+        token    : S.Token;
+        index    : INTEGER;
+        
+    PROCEDURE NameAndKey(idnt : D.Scope) : Lt.CharOpen;
+      VAR name : Lt.CharOpen;
+          keyV : INTEGER;
+    BEGIN
+      WITH idnt : Id.BlkId DO
+        RETURN BOX(Nh.charOpenOfHash(idnt.hash)^ + 
+                   " : "  + Lt.intToCharOpen(idnt.modKey)^);
+      ELSE
+        RETURN BOX("bad idnt");
+      END; 
+    END NameAndKey;
+    
+  BEGIN
+    message := NIL;
+    token := scope.token;
+    IF token = NIL THEN token := S.prevTok END;
+    filNm := Nh.charOpenOfHash(scope.hash);
+
+    f.impS := scope;
+    D.AppendScope(f.sArray, scope);
+    fileName := BOX(filNm^ + ".cps");
+    f.file := BF.findOnPath(CSt.cpSymX$, fileName);
+   (* #### *)
+    IF f.file = NIL THEN
+      fileName := BOX("__" + fileName^);
+      f.file := BF.findOnPath(CSt.cpSymX$, fileName);
+      IF f.file # NIL THEN
+        S.SemError.RepSt2(309, filNm, fileName, token.lin, token.col);
+        filNm := BOX("__" + filNm^);
+        scope.clsNm := filNm;
+      END;
+    END;
+   (* #### *)
+    IF f.file = NIL THEN
+      (* S.SemError.Report(129, token.lin, token.col); *)
+      S.SemError.RepSt1(129, BOX(filNm^ + ".cps"), token.lin, token.col); 
+      RETURN;
+    ELSE
+      IF CSt.verbose THEN 
+        IF D.weak IN scope.xAttr THEN
+          message := BOX("Implicit import " + filNm^);
+        ELSE
+          message := BOX("Explicit import " + filNm^);
+        END;
+      END;
+      marker := readInt(f.file);
+      IF marker = RTS.loInt(magic) THEN
+        (* normal case, nothing to do *)
+      ELSIF marker = RTS.loInt(syMag) THEN
+        INCL(scope.xAttr, D.rtsMd);
+      ELSE
+        (* S.SemError.Report(130, token.lin, token.col); *)
+        S.SemError.RepSt1(130, BOX(filNm^ + ".cps"), token.lin, token.col); 
+        RETURN;
+      END;
+      f.GetSym();
+      f.SymFile(filNm);
+      IF CSt.verbose THEN 
+        CSt.Message(message^ + ", Key: " + Lt.intToCharOpen(f.impS.modKey)^);
+        FOR index := 0 TO f.sArray.tide - 1 DO
+          CSt.Message("  imports " + NameAndKey(f.sArray.a[index])^);
+        END;
+      END;
+      BF.CloseFile(f.file);
+    END;
+  END Parse;
+
+(* ============================================ *)
+
+  PROCEDURE testInsert(id : D.Idnt; sc : D.Scope) : D.Idnt;
+    VAR ident : D.Idnt;
+
+    PROCEDURE Report(i,s : D.Idnt);
+      VAR iS, sS : FileNames.NameString;
+    BEGIN
+      D.getName.Of(i, iS);
+      D.getName.Of(s, sS);
+      S.SemError.RepSt2(172, iS, sS, S.line, S.col);
+    END Report;
+
+  BEGIN
+    IF sc.symTb.enter(id.hash, id) THEN
+      ident := id;
+    ELSE
+      ident := sc.symTb.lookup(id.hash);	(* Warp the return Idnt	*)
+      IF ident.kind # id.kind THEN Report(id, sc); ident := id END;
+    END;
+    RETURN ident;
+  END testInsert;
+
+(* ============================================ *)
+
+  PROCEDURE Insert(id : D.Idnt; VAR tb : D.SymbolTable);
+    VAR ident : D.Idnt;
+
+    PROCEDURE Report(i : D.Idnt);
+      VAR iS : FileNames.NameString;
+    BEGIN
+      D.getName.Of(i, iS);
+      S.SemError.RepSt1(172, iS, 1, 1);
+    END Report;
+
+  BEGIN
+    IF ~tb.enter(id.hash, id) THEN
+      ident := tb.lookup(id.hash);		(* and test isForeign? *)
+      IF ident.kind # id.kind THEN Report(id) END;
+    END;
+  END Insert;
+
+(* ============================================ *)
+ 
+  PROCEDURE InsertInRec(id : D.Idnt; rec : Ty.Record; sfr : SymFileReader);
+  (* insert, taking into account possible overloaded methods. *)
+  VAR
+    ok : BOOLEAN;
+    oId : Id.OvlId;
+
+    PROCEDURE Report(i : D.Idnt; IN s : ARRAY OF CHAR);
+      VAR iS, sS : FileNames.NameString;
+    BEGIN
+      D.getName.Of(i, iS);
+(*
+ *    D.getName.Of(s, sS);
+ *    S.SemError.RepSt2(172, iS, sS, S.line, S.col);
+ *)
+      S.SemError.RepSt2(172, iS, s, S.line, S.col);
+    END Report;
+
+  BEGIN
+    Ty.InsertInRec(id,rec,TRUE,oId,ok);
+    IF oId # NIL THEN D.AppendIdnt(sfr.oArray,oId); END;
+(*
+    IF ~ok THEN Report(id,rec.idnt); END;
+ *)
+    IF ~ok THEN Report(id, rec.name()) END;
+  END InsertInRec;
+
+(* ============================================ *)
+
+  PROCEDURE (f : SymFileReader)getLiteral() : D.Expr,NEW;
+    VAR expr : D.Expr;
+  BEGIN
+    CASE f.sSym OF
+    | truSy : expr := ExprDesc.mkTrueX();
+    | falSy : expr := ExprDesc.mkFalseX();
+    | numSy : expr := ExprDesc.mkNumLt(f.lAtt);
+    | chrSy : expr := ExprDesc.mkCharLt(f.cAtt);
+    | fltSy : expr := ExprDesc.mkRealLt(f.rAtt);
+    | setSy : expr := ExprDesc.mkSetLt(BITS(f.iAtt));
+    | strSy : expr := ExprDesc.mkStrLt(f.sAtt);		(* implicit f.sAtt^ *)
+    END;
+    f.GetSym();						(* read past value  *)
+    RETURN expr;
+  END getLiteral;
+
+(* ============================================ *)
+
+  PROCEDURE (f : SymFileReader)typeOf(ord : INTEGER) : D.Type,NEW;
+    VAR newT : D.Type;
+        indx : INTEGER;
+  BEGIN
+    IF ord < D.tOffset THEN				(* builtin type	*)	
+      RETURN B.baseTypeArray[ord];
+    ELSIF ord - D.tOffset < f.tArray.tide THEN
+      RETURN f.tArray.a[ord - D.tOffset];
+    ELSE 
+      indx := f.tArray.tide + D.tOffset;
+      REPEAT
+        newT := Ty.newTmpTp();
+        newT.dump := indx; INC(indx);
+        D.AppendType(f.tArray, newT);
+      UNTIL indx > ord;
+      RETURN newT;
+    END;
+  END typeOf;
+
+(* ============================================ *)
+
+  PROCEDURE (f : SymFileReader)getTypeFromOrd() : D.Type,NEW;
+    VAR ord : INTEGER;
+  BEGIN
+    ord := readOrd(f.file);
+    f.GetSym();
+    RETURN f.typeOf(ord);
+  END getTypeFromOrd;
+
+(* ============================================ *)
+
+  PROCEDURE (f : SymFileReader)getFormalType(rslt : Ty.Procedure;
+        				     indx : INTEGER) : D.Type,NEW;
+  (*
+  ** FormalType = [retSy TypeOrd] frmSy {parSy Byte TypeOrd [String]} endFm.
+  //	-- optional phrase is return type for proper procedures
+  *)
+    VAR parD : Id.ParId;
+        byte : INTEGER;
+  BEGIN
+    IF f.sSym = retSy THEN 
+      rslt.retType := f.typeOf(f.iAtt);
+      f.GetSym();
+    END;
+    f.ReadPast(frmSy);
+    WHILE f.sSym = parSy DO
+      byte := read(f.file);
+      parD := Id.newParId();
+      parD.parMod := byte;
+      parD.varOrd := indx; 
+      parD.type := f.getTypeFromOrd();
+     (* Skip over optional parameter name string *)
+      IF f.sSym = strSy THEN (* parD.hash := Nh.enterStr(f.sAtt); *)
+        f.GetSym;
+      END;
+      Id.AppendParam(rslt.formals, parD);
+      INC(indx);
+    END;
+    f.ReadPast(endFm);
+    RETURN rslt;
+  END getFormalType;
+
+(* ============================================ *)
+
+  PROCEDURE (f : SymFileReader)pointerType(old : D.Type) : D.Type,NEW;
+  (* Assert: the current symbol ptrSy 		*)
+  (* Pointer   = TypeHeader ptrSy TypeOrd.	*)
+    VAR rslt : Ty.Pointer;
+        indx : INTEGER;
+        junk : D.Type;
+        isEvt: BOOLEAN;
+  BEGIN
+    isEvt := (f.sSym = evtSy);
+    indx := readOrd(f.file);
+    WITH old : Ty.Pointer DO
+      rslt := old;
+     (*
+      *  Check if there is space in the tArray for this
+      *  element, otherwise expand using typeOf().
+      *)
+      IF indx - D.tOffset >= f.tArray.tide THEN
+        junk := f.typeOf(indx);
+      END;
+      f.tArray.a[indx - D.tOffset] := rslt.boundTp;
+    ELSE
+      rslt := Ty.newPtrTp();
+      rslt.boundTp := f.typeOf(indx);
+      IF isEvt THEN rslt.SetKind(Ty.evtTp) END;
+    END;
+    f.GetSym();
+    RETURN rslt;
+  END pointerType;
+
+(* ============================================ *)
+
+  PROCEDURE (f : SymFileReader)procedureType() : D.Type,NEW;
+  (* Assert: the current symbol is pTpSy.	*)
+  (* ProcType  = TypeHeader pTpSy FormalType.	*)
+  BEGIN
+    f.GetSym();		(* read past pTpSy *)
+    RETURN f.getFormalType(Ty.newPrcTp(), 0);
+  END procedureType;
+
+(* ============================================ *)
+
+  PROCEDURE (f : SymFileReader)eventType() : D.Type,NEW;
+  (* Assert: the current symbol is evtSy.	*)
+  (* EventType = TypeHeader evtSy FormalType.	*)
+  BEGIN
+    f.GetSym();		(* read past evtSy *)
+    RETURN f.getFormalType(Ty.newEvtTp(), 0);
+  END eventType;
+
+(* ============================================ *)
+
+  PROCEDURE (f : SymFileReader)arrayType() : Ty.Array,NEW;
+  (* Assert: at entry the current symbol is arrSy.		     *)
+  (* Array      = TypeHeader arrSy TypeOrd (Byte | Number | ) endAr. *)
+  (*	-- nullable phrase is array length for fixed length arrays   *)
+    VAR rslt : Ty.Array;
+        eTyp : D.Type;
+  BEGIN
+    rslt := Ty.newArrTp();
+    rslt.elemTp := f.typeOf(readOrd(f.file));
+    f.GetSym();
+    IF f.sSym = bytSy THEN
+      rslt.length := f.iAtt;
+      f.GetSym();
+    ELSIF f.sSym = numSy THEN
+      rslt.length := SHORT(f.lAtt);
+      f.GetSym();
+    (* ELSE length := 0 *)
+    END;
+    f.ReadPast(endAr);
+    RETURN rslt;
+  END arrayType;
+
+(* ============================================ *)
+
+  PROCEDURE (f : SymFileReader)vectorType() : Ty.Vector,NEW;
+  (* Assert: at entry the current symbol is vecSy.                   *)
+  (* Vector     = TypeHeader vecSy TypeOrd endAr.                    *)
+    VAR rslt : Ty.Vector;
+        eTyp : D.Type;
+  BEGIN
+    rslt := Ty.newVecTp();
+    rslt.elemTp := f.typeOf(readOrd(f.file));
+    f.GetSym();
+    f.ReadPast(endAr);
+    RETURN rslt;
+  END vectorType;
+
+(* ============================================ *)
+  PROCEDURE^ (f : SymFileReader)procedure() : Id.PrcId,NEW;
+  PROCEDURE^ (f : SymFileReader)method()    : Id.MthId,NEW;
+  PROCEDURE^ (f : SymFileReader)constant()  : Id.ConId,NEW;
+  PROCEDURE^ (f : SymFileReader)variable()  : Id.VarId,NEW;
+(* ============================================ *)
+
+  PROCEDURE (f : SymFileReader)recordType(old  : D.Type) : D.Type,NEW;
+  (* Assert: at entry the current symbol is recSy.			*)
+  (* Record     = TypeHeader recSy recAtt [truSy | falSy | <others>] 	*)
+  (*	[basSy TypeOrd] [iFcSy {basSy TypeOrd}]				*)
+  (*	{Name TypeOrd} {Method} {Statics} endRc.			*)
+    CONST 
+        vlTp = Ty.valRc;
+    VAR rslt : Ty.Record;
+        fldD : Id.FldId;
+        varD : Id.VarId;
+        mthD : Id.MthId;
+        conD : Id.ConId;
+        prcD : Id.PrcId;
+        typD : Id.TypId;
+        oldS : INTEGER;
+        attr : INTEGER;
+        mskd : INTEGER;
+  BEGIN
+    WITH old : Ty.Record DO rslt := old ELSE rslt := Ty.newRecTp() END;
+    attr := read(f.file);
+    mskd := attr MOD 8;
+   (*
+    *  The recAtt field has two other bits piggy-backed onto it.
+    *  The noNew Field of xAttr is just added on in the writing 
+    *  and is stripped off here.  The valRc field is used to lock
+    *  in foreign value classes, even though they have basTp # NIL.
+    *)
+    IF attr >= Ty.clsRc THEN DEC(attr,Ty.clsRc); INCL(rslt.xAttr,D.clsTp) END;
+    IF attr >= Ty.noNew THEN DEC(attr,Ty.noNew); INCL(rslt.xAttr,D.noNew) END;
+
+    rslt.recAtt := attr;
+    f.GetSym();				(* Get past recSy rAtt	*)
+    IF f.sSym = falSy THEN
+      INCL(rslt.xAttr, D.isFn);
+      f.GetSym();
+    ELSIF f.sSym = truSy THEN
+      INCL(rslt.xAttr, D.isFn);
+      INCL(rslt.xAttr, D.fnInf);
+      INCL(rslt.xAttr, D.noCpy);
+      f.GetSym();
+    END;
+    IF f.impS.scopeNm # NIL THEN rslt.extrnNm := f.impS.scopeNm END;
+
+    IF f.sSym = basSy THEN
+      rslt.baseTp := f.typeOf(f.iAtt);
+      IF f.iAtt # Ty.anyRec THEN INCL(rslt.xAttr, D.clsTp) END;
+      f.GetSym();
+    END;
+    IF f.sSym = iFcSy THEN
+      f.GetSym();
+      WHILE f.sSym = basSy DO
+        typD := Id.newSfAnonId(f.iAtt);
+        typD.type := f.typeOf(f.iAtt);
+        D.AppendType(rslt.interfaces, typD.type);
+        f.GetSym();
+      END;
+    END;
+    WHILE f.sSym = namSy DO
+      fldD := Id.newFldId();
+      fldD.SetMode(f.iAtt);
+      fldD.hash := Nh.enterStr(f.sAtt);
+      fldD.type := f.typeOf(readOrd(f.file));
+      fldD.recTyp := rslt;
+      f.GetSym();
+      IF rslt.symTb.enter(fldD.hash, fldD) THEN 
+        D.AppendIdnt(rslt.fields, fldD);
+      END;
+    END;
+
+    WHILE (f.sSym = mthSy) OR
+          (f.sSym = prcSy) OR
+          (f.sSym = varSy) OR
+          (f.sSym = conSy) DO
+      oldS := f.sSym; f.GetSym();
+      IF oldS = mthSy THEN
+        mthD := f.method();
+        mthD.bndType := rslt;
+        mthD.type(Ty.Procedure).receiver := rslt;
+        InsertInRec(mthD,rslt,f);
+        D.AppendIdnt(rslt.methods, mthD);
+      ELSIF oldS = prcSy THEN
+        prcD := f.procedure();
+        prcD.bndType := rslt;
+        InsertInRec(prcD,rslt,f);
+        D.AppendIdnt(rslt.statics, prcD);
+      ELSIF oldS = varSy THEN
+        varD := f.variable();
+        varD.recTyp := rslt;
+        InsertInRec(varD,rslt,f);
+        D.AppendIdnt(rslt.statics, varD);
+      ELSIF oldS = conSy THEN
+        conD := f.constant();
+        conD.recTyp := rslt;
+        InsertInRec(conD,rslt,f);
+      ELSE
+        Abandon(f);
+      END;
+    END;
+(* #### *)
+    IF attr >= Ty.valRc THEN 
+      DEC(attr, Ty.valRc); 
+      EXCL(rslt.xAttr, D.clsTp);
+      EXCL(rslt.xAttr, D.noCpy);
+    END;
+(* #### *)
+    f.ReadPast(endRc); 
+    RETURN rslt;
+  END recordType;
+
+(* ============================================ *)
+
+  PROCEDURE (f : SymFileReader)enumType() : D.Type,NEW;
+  (* Assert: at entry the current symbol is eTpSy.			*)
+  (* Enum  = TypeHeader eTpSy { Constant} endRc.			*)
+    VAR rslt : Ty.Enum;
+        cnst : D.Idnt;
+  BEGIN
+    rslt := Ty.newEnuTp();
+    f.GetSym();				(* Get past recSy 	*)
+    WHILE f.sSym = conSy DO
+      f.GetSym();
+      cnst := f.constant();
+      Insert(cnst, rslt.symTb);
+      D.AppendIdnt(rslt.statics, cnst);
+    END;
+    f.ReadPast(endRc); 
+    RETURN rslt;
+  END enumType;
+
+(* ============================================ *)
+
+  PROCEDURE (f : SymFileReader)Type(),NEW;
+  (* Type       = typSy Name TypeOrd.		*)
+    VAR newI : Id.TypId;
+        oldI : D.Idnt;
+        type : D.Type;
+  BEGIN
+   (* 
+    * Post: every previously unknown typId 'id'
+    *	has the property:  id.type.idnt = id.
+    *   If oldI # newT, then the new typId has
+    *   newT.type.idnt = oldI.
+    *)
+    newI := Id.newTypId(NIL);
+    newI.SetMode(f.iAtt);
+    newI.hash := Nh.enterStr(f.sAtt);
+    newI.type := f.getTypeFromOrd(); 
+    newI.dfScp := f.impS;
+    oldI := testInsert(newI, f.impS);
+
+    IF oldI # newI THEN 
+      f.tArray.a[newI.type.dump - D.tOffset] := oldI.type;
+    END;
+
+    IF newI.type.idnt = NIL THEN newI.type.idnt := oldI END;
+  END Type;
+
+(* ============================================ *)
+
+  PROCEDURE (f : SymFileReader)Import(),NEW;
+  (* Import     = impSy Name [String] Key.	*)
+  (*	-- optional string is external name	*)
+  (* first symbol should be namSy here.		*)
+    VAR impD : Id.BlkId;
+        oldS : Id.BlkId;
+        oldD : D.Idnt;
+  BEGIN
+    impD := Id.newImpId();
+    impD.dfScp := impD;			(* ImpId define their own scope *)
+
+    INCL(impD.xAttr, D.weak);
+    impD.SetMode(f.iAtt);
+    impD.hash := Nh.enterStr(f.sAtt);
+    f.ReadPast(namSy); 
+    IF impD.hash = f.modS.hash THEN	(* Importing own imp indirectly	*)
+        				(* Shouldn't this be an error?  *)
+      D.AppendScope(f.sArray, f.modS);
+      IF f.sSym = strSy THEN 
+        (* probably don't need to do anything here ... *)
+        f.GetSym();
+      END;
+    ELSE				(* Importing some other module.	*)
+      oldD := testInsert(impD, f.modS);
+      IF f.sSym = strSy THEN 
+        impD.scopeNm := Lt.strToCharOpen(f.sAtt);
+        f.GetSym();
+      END;
+      IF (oldD # impD) & (oldD.kind = Id.impId) THEN
+        oldS := oldD(Id.BlkId);
+        D.AppendScope(f.sArray, oldS);
+        IF (oldS.modKey # 0) & (f.iAtt # oldS.modKey) THEN
+          S.SemError.RepSt1(133,		(* Detected bad KeyVal	*)
+        	Nh.charOpenOfHash(impD.hash)^, 
+        	S.line, S.col);
+        END;
+      ELSE
+        D.AppendScope(f.sArray, impD);
+      END;
+      impD.modKey := f.iAtt;
+    END;
+    f.ReadPast(keySy);
+  END Import;
+
+(* ============================================ *)
+
+  PROCEDURE (f : SymFileReader)constant() : Id.ConId,NEW;
+  (* Constant   = conSy Name Literal.		*)
+  (* Assert: f.sSym = namSy.			*)
+    VAR newC : Id.ConId;
+        anyI : D.Idnt;
+  BEGIN
+    newC := Id.newConId();
+    newC.SetMode(f.iAtt);
+    newC.hash := Nh.enterStr(f.sAtt);
+    newC.dfScp := f.impS;
+    f.ReadPast(namSy);
+    newC.conExp := f.getLiteral();
+    newC.type := newC.conExp.type;
+    RETURN newC;
+  END constant;
+
+(* ============================================ *)
+
+  PROCEDURE (f : SymFileReader)variable() : Id.VarId,NEW;
+  (* Variable   = varSy Name TypeOrd.		*)
+    VAR newV : Id.VarId;
+        anyI : D.Idnt;
+  BEGIN
+    newV := Id.newVarId();
+    newV.SetMode(f.iAtt);
+    newV.hash := Nh.enterStr(f.sAtt);
+    newV.type := f.getTypeFromOrd();
+    newV.dfScp := f.impS;
+    RETURN newV;
+  END variable;
+
+(* ============================================ *)
+
+  PROCEDURE (f : SymFileReader)procedure() : Id.PrcId,NEW;
+  (* Procedure  = prcSy Name[String]FormalType. *)
+  (* This is a static proc, mths come with Recs *)
+    VAR newP : Id.PrcId;
+        anyI : D.Idnt;
+  BEGIN
+    newP := Id.newPrcId();
+    newP.setPrcKind(Id.conPrc);
+    newP.SetMode(f.iAtt);
+    newP.hash := Nh.enterStr(f.sAtt);
+    newP.dfScp := f.impS;
+    f.ReadPast(namSy);
+    IF f.sSym = strSy THEN 
+      newP.prcNm := Lt.strToCharOpen(f.sAtt);
+     (* and leave scopeNm = NIL *)
+      f.GetSym();
+    END;
+    IF f.sSym = truSy THEN	(* ### this is a constructor ### *)
+      f.GetSym();
+      newP.setPrcKind(Id.ctorP);
+    END;			(* ### this is a constructor ### *)
+    newP.type := f.getFormalType(Ty.newPrcTp(), 0);
+    (* IF this is a java module, do some semantic checks *)
+    (* ... *)
+    RETURN newP;
+  END procedure;
+
+(* ============================================ *)
+
+  PROCEDURE (f : SymFileReader)method() : Id.MthId,NEW;
+  (* Method     = mthSy Name byte byte TypeOrd [String][Name] FormalType. *)
+    VAR newM : Id.MthId;
+        rcvD : Id.ParId;
+        rFrm : INTEGER;
+        mAtt : SET;
+  BEGIN
+    newM := Id.newMthId();
+    newM.SetMode(f.iAtt);
+    newM.setPrcKind(Id.conMth);
+    newM.hash := Nh.enterStr(f.sAtt);
+    newM.dfScp := f.impS;
+    rcvD := Id.newParId();
+    rcvD.varOrd := 0;
+   (* byte1 is the method attributes  *)
+    mAtt := BITS(read(f.file));
+   (* byte2 is param form of receiver *)
+    rFrm := read(f.file);
+   (* next 1 or 2 bytes are rcv-type  *)
+    rcvD.type := f.typeOf(readOrd(f.file));
+    f.GetSym();
+    rcvD.parMod := rFrm;
+    IF f.sSym = strSy THEN 
+      newM.prcNm := Lt.strToCharOpen(f.sAtt);
+     (* and leave scopeNm = NIL *)
+      f.GetSym();
+    END;
+   (* Skip over optional receiver name string *)
+    IF f.sSym = namSy THEN (* rcvD.hash := Nh.enterString(f.sAtt); *)
+      f.GetSym();
+    END;
+   (* End skip over optional receiver name *)
+    newM.type := f.getFormalType(Ty.newPrcTp(), 1);
+    newM.type.idnt := newM;
+    newM.mthAtt := mAtt;
+    newM.rcvFrm := rcvD;
+   (* IF this is a java module, do some semantic checks *)
+    RETURN newM;
+  END method;
+
+(* ============================================ *)
+
+  PROCEDURE (f : SymFileReader)TypeList(),NEW;
+  (* TypeList   = start { Array | Record | Pointer      *)
+  (*		  | ProcType | Vector} close.           *)
+  (* TypeHeader = tDefS Ord [fromS Ord Name].           *)
+    VAR modOrd : INTEGER;
+        typOrd : INTEGER;
+        typIdx : INTEGER;
+        tpDesc : D.Type;
+        tpIdnt : Id.TypId;
+        prevTp : D.Type;
+        impScp : D.Scope;
+        basBlk : Id.BlkId;
+        linkIx : INTEGER;
+        bndTyp : D.Type;
+        typeFA : TypeLinker;
+
+   (* ================================ *)
+    PROCEDURE getDetails(f : SymFileReader; p : D.Type) : D.Type;
+    BEGIN
+      CASE f.sSym OF
+      | arrSy : RETURN f.arrayType();
+      | vecSy : RETURN f.vectorType();
+      | recSy : RETURN f.recordType(p);
+      | pTpSy : RETURN f.procedureType();
+      | evtSy : RETURN f.eventType();
+      | eTpSy : RETURN f.enumType();
+      | ptrSy : RETURN f.pointerType(p);
+      ELSE 
+                RETURN Ty.newNamTp();
+      END;
+    END getDetails;
+   (* ================================ *)
+  BEGIN
+    WHILE f.sSym = tDefS DO
+      linkIx := 0;
+      tpIdnt := NIL;
+      impScp := NIL;
+
+     (* Do type header *)
+      typOrd := f.iAtt;
+      typIdx := typOrd - D.tOffset;
+      prevTp := f.tArray.a[typIdx];
+      f.ReadPast(tDefS);
+     (*
+      *  The [fromS modOrd typNam] appears if the type is imported.
+      *  There are two cases:
+      *  (1) this is the first time that "mod.typNam" has been 
+      *      seen during this compilation 
+      *                   ==> insert a new typId descriptor in mod.symTb
+      *  (2) this name is already in the mod.symTb table
+      *                   ==> fetch the previous descriptor
+      *)
+      IF f.sSym = fromS THEN
+        modOrd := f.iAtt;
+        impScp := f.sArray.a[modOrd];
+        f.GetSym();
+        tpIdnt := Id.newTypId(NIL);
+        tpIdnt.SetMode(f.iAtt);
+        tpIdnt.hash := Nh.enterStr(f.sAtt);
+        tpIdnt.dfScp := impScp;
+        tpIdnt := testInsert(tpIdnt, impScp)(Id.TypId);
+        f.ReadPast(namSy);
+        tpDesc := getDetails(f, prevTp);
+       (*
+        *  In the new symbol table format we do not wish
+        *  to include details of indirectly imported types.
+        *  However, there may be a reference to the bound
+        *  type of an indirectly imported pointer.  In this
+        *  case we need to make sure that the otherwise
+        *  bound type declaration catches the same opaque
+        *  type descriptor.
+        *)
+        IF tpDesc # NIL THEN
+          WITH tpDesc : Ty.Pointer DO
+            bndTyp := tpDesc.boundTp;
+            IF (bndTyp # NIL) & (bndTyp.kind = Ty.tmpTp) THEN
+              linkIx := bndTyp.dump - D.tOffset;
+            END;
+          ELSE (* skip *)
+          END;
+        END;
+        tpDesc := Ty.newNamTp();
+        tpDesc.idnt := tpIdnt;
+        IF linkIx # 0 THEN 
+          ASSERT(linkIx > typIdx);
+          f.tArray.a[linkIx] := tpDesc;
+        END;
+       (*
+        *  A name has been declared for this type, tpIdnt is
+        *  the (possibly previously known) id descriptor, and
+        *  tpDesc is the newly parsed descriptor of the type.
+        *) 
+        IF tpIdnt.type = NIL THEN
+          tpIdnt.type := tpDesc;
+        ELSE
+          tpDesc := tpIdnt.type;
+        END;
+        IF tpDesc.idnt = NIL THEN tpDesc.idnt := tpIdnt END;
+      ELSE
+        tpDesc := getDetails(f, prevTp); 
+        ASSERT(tpDesc # NIL);
+        IF (prevTp # NIL) &
+           (prevTp.idnt # NIL) THEN
+          IF (prevTp.kind = Ty.namTp) &
+             (prevTp.idnt.dfScp # f.impS) THEN
+           (*
+            *  This is the special case of an anonymous
+            *  bound type of an imported pointer.  In the
+            *  new type resolver we want this to remain
+            *  as an opaque type until *all* symbol files
+            *  have been fully processed.
+            *  So ... override the parsed type.
+            *)
+            tpDesc := prevTp;
+          ELSE 
+            prevTp.idnt.type := tpDesc;  (* override opaque *)
+            tpDesc.idnt := prevTp.idnt;
+          END;
+        END;
+       (* 
+        *  This is the normal case
+        *)
+        WITH tpDesc : Ty.Pointer DO
+          bndTyp := tpDesc.boundTp;
+          IF (bndTyp # NIL) & (bndTyp.kind = Ty.tmpTp) THEN
+            linkIx := bndTyp.dump - D.tOffset;
+            IF linkIx # 0 THEN 
+              ASSERT(linkIx > typIdx);
+              f.tArray.a[linkIx] := tpDesc.boundTp;
+            END;
+          END;
+        ELSE (* skip *)
+        END;
+      END;
+      f.tArray.a[typIdx] := tpDesc;
+    END; (* while *)
+    FOR linkIx := 0 TO f.tArray.tide - 1 DO
+      tpDesc := f.tArray.a[linkIx];
+     (*
+      *  First we fix up all symbolic references in the
+      *  the type array.  Postcondition is : no element
+      *  of the type array directly or indirectly refers
+      *  to a temporary type.
+      *)
+      tpDesc.TypeFix(f.tArray);
+    END;
+    FOR linkIx := 0 TO f.tArray.tide - 1 DO
+      tpDesc := f.tArray.a[linkIx];
+     (*
+      *  At this stage we want to check the base types
+      *  of every defined record type.  If the base type
+      *  is imported then we check. 
+      *  Define 'set' := dfScp.xAttr * {weak, need}; then ...
+      *
+      *    set = {D.need}            ==> module is explicitly imported
+      *
+      *    set = {D.weak}            ==> module must be imported, but is not
+      *                                   on the import worklist at this stage
+      *    set = {D.weak, D.need}   ==> module must be imported, and is 
+      *                                   already on the import worklist.
+      *)
+      IF tpDesc # NIL THEN
+        WITH tpDesc : Ty.Record DO
+          IF tpDesc.baseTp # NIL THEN
+            prevTp := tpDesc.baseTp;
+            IF (prevTp.kind = Ty.namTp) &
+               (prevTp.idnt # NIL) &
+               (prevTp.idnt.dfScp # NIL) THEN
+              basBlk := prevTp.idnt.dfScp(Id.BlkId);
+              IF basBlk.xAttr * {D.weak, D.need} = {D.weak} THEN
+                INCL(basBlk.xAttr, D.need);
+                D.AppendScope(f.rScp.work, prevTp.idnt.dfScp);
+              END;
+            END;
+          END;
+        ELSE (* skip *)
+        END; (* with *)
+      END;
+    END; (* for linkIx do *)
+   (*
+    *  We now fix up all references in the symbol table
+    *  that still refer to temporary symbol-file types.
+    *)
+    NEW(typeFA);
+    typeFA.sym := f;
+    f.impS.symTb.Apply(typeFA); 
+    f.ReadPast(close);
+   (*
+    *  Now check that all overloaded ids are necessary
+    *)
+    FOR linkIx := 0 TO f.oArray.tide - 1 DO
+      f.oArray.a[linkIx].OverloadFix();
+      f.oArray.a[linkIx] := NIL;
+    END;
+  END TypeList;
+
+(* ============================================ *)
+
+  PROCEDURE (f : SymFileReader)SymFile(IN nm : ARRAY OF CHAR),NEW;
+   (*
+   // SymFile    = Header [String (falSy | truSy | <others>)]
+   //		{Import | Constant | Variable | Type | Procedure} 
+   //		TypeList Key.
+   // Header     = magic modSy Name.
+   //
+   //  magic has already been recognized.
+   *)
+    VAR oldS : INTEGER;
+  BEGIN
+    f.ReadPast(modSy);
+    IF f.sSym = namSy THEN (* do something with f.sAtt *)
+      IF nm # f.sAtt THEN
+        Error.WriteString("Wrong name in symbol file. Expected <");
+        Error.WriteString(nm + ">, found <");
+        Error.WriteString(f.sAtt + ">"); 
+        Error.WriteLn;
+        HALT(1);
+      END;
+      f.GetSym();
+    ELSE RTS.Throw("Bad symfile header");
+    END;
+    IF f.sSym = strSy THEN (* optional name *)
+      f.impS.scopeNm := Lt.strToCharOpen(f.sAtt);
+      f.GetSym();
+      IF f.sSym = falSy THEN 
+        INCL(f.impS.xAttr, D.isFn);
+        f.GetSym();
+      ELSIF f.sSym = truSy THEN
+        INCL(f.impS.xAttr, D.isFn);
+        INCL(f.impS.xAttr, D.fnInf);
+        f.GetSym();
+      ELSE RTS.Throw("Bad explicit name");
+      END; 
+    END; 
+    IF f.sSym = numSy THEN (* optional strong name info.    *)
+      NEW(f.impS.verNm);   (* POINTER TO ARRAY 6 OF INTEGER *)
+      f.impS.verNm[0] := RTS.hiInt(f.lAtt);
+      f.impS.verNm[1] := RTS.loInt(f.lAtt);
+      f.GetSym();
+      f.impS.verNm[2] := RTS.hiInt(f.lAtt);
+      f.impS.verNm[3] := RTS.loInt(f.lAtt);
+      f.GetSym();
+      f.impS.verNm[4] := RTS.hiInt(f.lAtt);
+      f.impS.verNm[5] := RTS.loInt(f.lAtt);
+      f.GetSym();
+      IF CSt.verbose THEN
+        Console.WriteString("version:"); 
+        Console.WriteInt(f.impS.verNm[0],1); Console.Write(".");
+        Console.WriteInt(f.impS.verNm[1],1); Console.Write(".");
+        Console.WriteInt(f.impS.verNm[2],1); Console.Write(".");
+        Console.WriteInt(f.impS.verNm[3],1); 
+        Console.WriteHex(f.impS.verNm[4],9);
+        Console.WriteHex(f.impS.verNm[5],9); Console.WriteLn;
+      END;
+      (*
+      //  The CPS format only provides for version information if
+      //  there is also a strong key token. Do not propagate random
+      //  junk with PeToCps from assemblies with version info only
+      *)
+      IF (f.impS.verNm[4] = 0) OR (f.impS.verNm[5] = 0) THEN
+        f.impS := NIL;
+      END;
+    END;
+    LOOP
+      oldS := f.sSym;
+      f.GetSym();
+      CASE oldS OF
+      | start : EXIT;
+      | typSy : f.Type();                             (* Declare public tp *)
+      | impSy : f.Import();                           (* Declare an import *)
+      | conSy : Insert(f.constant(),  f.impS.symTb);  (* Const. definition *)
+      | varSy : Insert(f.variable(),  f.impS.symTb);  (* Var. declaration  *)
+      | prcSy : Insert(f.procedure(), f.impS.symTb);  (* Proc. declaration *)
+      ELSE RTS.Throw("Bad object");
+      END;
+    END;
+   (* 
+    *  Now read the typelist. 
+    *)
+    f.TypeList();
+   (* 
+    *  Now check the module key.
+    *)
+    IF f.sSym = keySy THEN
+      IF f.impS.modKey = 0 THEN 
+        f.impS.modKey := f.iAtt;
+      ELSIF f.impS.modKey # f.iAtt THEN
+        S.SemError.Report(173, S.line, S.col);	(* Detected bad KeyVal	*)
+      END;
+    ELSE RTS.Throw("Missing keySy");
+    END; 
+  END SymFile;
+
+(* ============================================================ *)
+(* ========	     SymFileSFA visitor method		======= *)
+(* ============================================================ *)
+
+  PROCEDURE (t : SymFileSFA)Op*(id : D.Idnt);
+  BEGIN
+    IF (id.kind = Id.impId) OR (id.vMod # D.prvMode) THEN
+      CASE id.kind OF
+      | Id.typId  : t.sym.EmitTypeId(id(Id.TypId));
+      | Id.conId  : t.sym.EmitConstId(id(Id.ConId));
+      | Id.impId  : t.sym.EmitImportId(id(Id.BlkId));
+      | Id.varId  : t.sym.EmitVariableId(id(Id.VarId));
+      | Id.conPrc : t.sym.EmitProcedureId(id(Id.PrcId));
+      ELSE (* skip *)
+      END;
+    END;
+  END Op;
+
+(* ============================================================ *)
+(* ========	     TypeLinker visitor method		======= *)
+(* ============================================================ *)
+
+  PROCEDURE (t : TypeLinker)Op*(id : D.Idnt);
+  BEGIN
+    IF id.type = NIL THEN RETURN
+    ELSIF id.type.kind = Ty.tmpTp THEN
+      id.type := Ty.update(t.sym.tArray, id.type);
+    ELSE
+      id.type.TypeFix(t.sym.tArray);
+    END;
+    IF  (id IS Id.TypId) & 
+        (id.type.idnt = NIL) THEN id.type.idnt := id END;
+  END Op;
+
+(* ============================================================ *)
+(* ========	     ResolveAll visitor method		======= *)
+(* ============================================================ *)
+
+  PROCEDURE (t : ResolveAll)Op*(id : D.Idnt);
+  BEGIN
+    IF id.type # NIL THEN id.type := id.type.resolve(1) END;
+  END Op;
+
+(* ============================================================ *)
+(* ========	    Symbol file parser method		======= *)
+(* ============================================================ *)
+
+  PROCEDURE (res : ImpResScope)ReadThisImport(imp : Id.BlkId),NEW;
+    VAR syFil : SymFileReader;
+  BEGIN
+    INCL(imp.xAttr, D.fixd);
+    syFil := newSymFileReader(res.host);
+    syFil.rScp := res;
+    syFil.Parse(imp);
+  END ReadThisImport;
+
+(* ============================================ *)
+
+  PROCEDURE WalkImports*(VAR imps : D.ScpSeq; modI : Id.BlkId);
+    VAR indx : INTEGER;
+        blkI : Id.BlkId;
+        fScp : ImpResScope;
+        rAll : ResolveAll;
+(*
+ *  str : RTS.NativeString;
+ *)
+  BEGIN
+   (*
+    *  The list of scopes has been constructed by
+    *  the parser, while reading the import list.
+    *  In the case of already known scopes the list
+    *  references the original descriptor.
+    *
+    *  Unlike the previous version (SymFileRW) this
+    *  routine may mutate the length of the sequence.
+    *)
+    NEW(fScp);
+   (*
+    *  Copy the incoming sequence.
+    *)
+    fScp.work := imps;
+    fScp.host := modI;
+   (*
+    *  Now import modules on the list.
+    *)
+    indx := 0;
+    WHILE indx < fScp.work.tide DO
+      blkI := fScp.work.a[indx](Id.BlkId);
+      IF blkI.kind = Id.alias THEN
+        blkI.symTb  := blkI.dfScp.symTb;
+      ELSIF ~(D.fixd IN blkI.xAttr) THEN 
+        fScp.ReadThisImport(blkI);
+      END;
+      INC(indx);
+    END;
+    FOR indx := 0 TO fScp.work.tide-1 DO
+      blkI := fScp.work.a[indx](Id.BlkId);
+(*
+ *    str := MKSTR(Nh.charOpenOfHash(blkI.hash)^);
+ *    blkI.symTb.Apply(Visitor.newResolver());
+ *)
+      NEW(rAll);
+      blkI.symTb.Apply(rAll);
+    END;
+   (*
+    *  Copy the (possibly mutated) sequence out.
+    *)
+    imps := fScp.work;
+  END WalkImports;
+
+(* ============================================================ *)
+BEGIN
+  lastKey := 0;
+  fSepArr[0] := GF.fileSep;
+END NewSymFileRW.
+(* ============================================================ *)

gpcp/OldSymFileRW.cp

@@ -0,0 +1,2045 @@
+(* ==================================================================== *)
+(*									*)
+(*  SymFileRW:  Symbol-file reading and writing for GPCP.		*)
+(*	Copyright (c) John Gough 1999, 2000.				*)
+(*									*)
+(* ==================================================================== *)
+
+MODULE OldSymFileRW;
+
+  IMPORT 
+        GPCPcopyright,
+        RTS,
+        Error,
+        Console,
+        GF := GPFiles,
+        BF := GPBinFiles,
+        Id := IdDesc,
+        D  := Symbols,
+        LitValue,
+        Visitor,
+        ExprDesc,
+        Ty := TypeDesc,
+        B  := Builtin,
+        S  := CPascalS,
+        G  := CompState,
+        Nh := NameHash,
+        FileNames;
+
+(* ========================================================================= *
+// Collected syntax ---
+// 
+// SymFile    = Header [String (falSy | truSy | <other attribute>)]
+//              [ VersionName ]
+//		{Import | Constant | Variable | Type | Procedure} 
+//		TypeList Key.
+//	-- optional String is external name.
+//	-- falSy ==> Java class
+//	-- truSy ==> Java interface
+//	-- others ...
+// Header     = magic modSy Name.
+// VersionName= numSy longint numSy longint numSy longint.
+//      --            mj# mn#       bld rv#    8xbyte extract
+// Import     = impSy Name [String] Key.
+//	-- optional string is explicit external name of class
+// Constant   = conSy Name Literal.
+// Variable   = varSy Name TypeOrd.
+// Type       = typSy Name TypeOrd.
+// Procedure  = prcSy Name [String] FormalType.
+//	-- optional string is explicit external name of procedure
+// Method     = mthSy Name byte byte TypeOrd [String] [Name] FormalType.
+//	-- optional string is explicit external name of method
+// FormalType = [retSy TypeOrd] frmSy {parSy byte TypeOrd [String]} endFm.
+//	-- optional phrase is return type for proper procedures
+// TypeOrd    = ordinal.
+// TypeHeader = tDefS Ord [fromS Ord Name].
+//	-- optional phrase occurs if:
+//	-- type not from this module, i.e. indirect export
+// TypeList   = start { Array | Record | Pointer | ProcType | 
+//                Enum | Vector | NamedType } close.
+// Array      = TypeHeader arrSy TypeOrd (Byte | Number | <empty>) endAr.
+//	-- nullable phrase is array length for fixed length arrays
+// Vector     = TypeHeader vecSy TypeOrd endAr.
+// Pointer    = TypeHeader ptrSy TypeOrd.
+// Event      = TypeHeader evtSy FormalType.
+// ProcType   = TypeHeader pTpSy FormalType.
+// Record     = TypeHeader recSy recAtt [truSy | falSy] 
+//		[basSy TypeOrd] [iFcSy {basSy TypeOrd}]
+//		{Name TypeOrd} {Method} {Statics} endRc.
+//	-- truSy ==> is an extension of external interface
+//	-- falSy ==> is an extension of external class
+// 	-- basSy option defines base type, if not ANY / j.l.Object
+// Statics    = ( Constant | Variable | Procedure ).
+// Enum       = TypeHeader eTpSy { Constant } endRc.
+// NamedType  = TypeHeader.
+// Name	      = namSy byte UTFstring.
+// Literal    = Number | String | Set | Char | Real | falSy | truSy.
+// Byte       = bytSy byte.
+// String     = strSy UTFstring.
+// Number     = numSy longint.
+// Real       = fltSy ieee-double.
+// Set        = setSy integer.
+// Key        = keySy integer..
+// Char       = chrSy unicode character.
+//
+// Notes on the syntax:
+// All record types must have a Name field, even though this is often
+// redundant.  The issue is that every record type (including those that
+// are anonymous in CP) corresponds to a IR class, and the definer 
+// and the user of the class _must_ agree on the IR name of the class.
+// The same reasoning applies to procedure types, which must have equal
+// interface names in all modules.
+// ======================================================================== *)
+
+  CONST
+        modSy = ORD('H'); namSy = ORD('$'); bytSy = ORD('\');
+        numSy = ORD('#'); chrSy = ORD('c'); strSy = ORD('s');
+        fltSy = ORD('r'); falSy = ORD('0'); truSy = ORD('1');
+        impSy = ORD('I'); setSy = ORD('S'); keySy = ORD('K');
+        conSy = ORD('C'); typSy = ORD('T'); tDefS = ORD('t');
+        prcSy = ORD('P'); retSy = ORD('R'); mthSy = ORD('M');
+        varSy = ORD('V'); parSy = ORD('p'); start = ORD('&');
+        close = ORD('!'); recSy = ORD('{'); endRc = ORD('}');
+        frmSy = ORD('('); fromS = ORD('@'); endFm = ORD(')');
+        arrSy = ORD('['); endAr = ORD(']'); pTpSy = ORD('%');
+        ptrSy = ORD('^'); basSy = ORD('+'); eTpSy = ORD('e');
+        iFcSy = ORD('~'); evtSy = ORD('v'); vecSy = ORD('*');
+
+  CONST
+        magic   = 0DEADD0D0H;
+        syMag   = 0D0D0DEADH;
+        dumped* = -1;
+
+(* ============================================================ *)
+
+  TYPE
+        SymFile = POINTER TO RECORD 
+        	    file : BF.FILE;
+        	    cSum : INTEGER;
+        	    modS : Id.BlkId;
+        	    iNxt : INTEGER;
+        	    oNxt : INTEGER;
+        	    work : D.TypeSeq;
+        	  END;
+
+  TYPE
+        SymFileReader* = POINTER TO RECORD
+        	    file  : BF.FILE;
+        	    modS  : Id.BlkId;
+        	    impS  : Id.BlkId;
+        	    sSym  : INTEGER;
+        	    cAtt  : CHAR;
+        	    iAtt  : INTEGER;
+        	    lAtt  : LONGINT;
+        	    rAtt  : REAL;
+        	    sAtt  : FileNames.NameString;
+                    oArray : D.IdSeq;
+        	    sArray : D.ScpSeq;		(* These two sequences	*)
+  		    tArray : D.TypeSeq;		(* must be private as   *)
+        	  END;				(* file parses overlap. *)
+
+(* ============================================================ *)
+
+  TYPE	TypeLinker*  = POINTER TO RECORD (D.SymForAll) sym : SymFileReader END;
+  TYPE	SymFileSFA*  = POINTER TO RECORD (D.SymForAll) sym : SymFile END;
+
+(* ============================================================ *)
+
+  VAR   lastKey : INTEGER;	(* private state for CPMake *)
+        fSepArr : ARRAY 2 OF CHAR;
+
+(* ============================================================ *)
+(* ========	     Import Stack Implementation	======= *)
+(* ============================================================ *)
+
+   VAR	stack	: ARRAY 32 OF Id.BlkId;
+        topIx	: INTEGER;
+
+   PROCEDURE InitStack;
+   BEGIN
+     topIx := 0; G.impMax := 0;
+   END InitStack;
+
+   PROCEDURE PushStack(b : Id.BlkId);
+   BEGIN
+     stack[topIx] := b; 
+     INC(topIx);
+     IF topIx > G.impMax THEN G.impMax := topIx END; 
+   END PushStack;
+
+   PROCEDURE PopStack;
+   BEGIN
+     DEC(topIx);
+   END PopStack;
+
+(* ============================================================ *)
+
+  PROCEDURE GetLastKeyVal*() : INTEGER;
+  BEGIN
+    RETURN lastKey;
+  END GetLastKeyVal;
+
+(* ============================================================ *)
+(* ========	Various writing utility procedures	======= *)
+(* ============================================================ *)
+
+  PROCEDURE newSymFile(mod : Id.BlkId) : SymFile;
+    VAR new : SymFile;
+  BEGIN
+    NEW(new);
+   (*
+    *  Initialization: cSum starts at zero. Since impOrd of
+    *  the module is zero, impOrd of the imports starts at 1.
+    *)
+    new.cSum := 0;
+    new.iNxt := 1;
+    new.oNxt := D.tOffset;
+    new.modS := mod;
+    D.InitTypeSeq(new.work, 32);
+    RETURN new;
+  END newSymFile;
+
+(* ======================================= *)
+
+  PROCEDURE (f : SymFile)Write(chr : INTEGER),NEW;
+    VAR tmp : INTEGER;
+  BEGIN [UNCHECKED_ARITHMETIC]
+   (* need to turn off overflow checking here *)
+    tmp := f.cSum * 2 + chr;
+    IF f.cSum < 0 THEN INC(tmp) END;
+    f.cSum := tmp;
+    BF.WriteByte(f.file, chr);
+  END Write;
+
+(* ======================================= *)
+
+  PROCEDURE (f : SymFile)WriteStrUTF(IN nam : ARRAY OF CHAR),NEW;
+    VAR buf : ARRAY 256 OF INTEGER;
+        num : INTEGER;
+        idx : INTEGER;
+        chr : INTEGER;
+  BEGIN
+    num := 0;
+    idx := 0;
+    chr := ORD(nam[idx]);
+    WHILE chr # 0H DO
+      IF    chr <= 7FH THEN 		(* [0xxxxxxx] *)
+        buf[num] := chr; INC(num);
+      ELSIF chr <= 7FFH THEN 		(* [110xxxxx,10xxxxxx] *)
+        buf[num+1] := 080H + chr MOD 64; chr := chr DIV 64;
+        buf[num  ] := 0C0H + chr; INC(num, 2);
+      ELSE 				(* [1110xxxx,10xxxxxx,10xxxxxxx] *)
+        buf[num+2] := 080H + chr MOD 64; chr := chr DIV 64;
+        buf[num+1] := 080H + chr MOD 64; chr := chr DIV 64;
+        buf[num  ] := 0E0H + chr; INC(num, 3);
+      END;
+      INC(idx); chr := ORD(nam[idx]);
+    END;
+    f.Write(num DIV 256);
+    f.Write(num MOD 256);
+    FOR idx := 0 TO num-1 DO f.Write(buf[idx]) END;
+  END WriteStrUTF;
+
+(* ======================================= *)
+
+  PROCEDURE (f : SymFile)WriteOpenUTF(chOp : LitValue.CharOpen),NEW;
+    VAR buf : ARRAY 256 OF INTEGER;
+        num : INTEGER;
+        idx : INTEGER;
+        chr : INTEGER;
+  BEGIN
+    num := 0;
+    idx := 0;
+    chr := ORD(chOp[0]);
+    WHILE chr # 0H DO
+      IF    chr <= 7FH THEN 		(* [0xxxxxxx] *)
+        buf[num] := chr; INC(num);
+      ELSIF chr <= 7FFH THEN 		(* [110xxxxx,10xxxxxx] *)
+        buf[num+1] := 080H + chr MOD 64; chr := chr DIV 64;
+        buf[num  ] := 0C0H + chr; INC(num, 2);
+      ELSE 				(* [1110xxxx,10xxxxxx,10xxxxxxx] *)
+        buf[num+2] := 080H + chr MOD 64; chr := chr DIV 64;
+        buf[num+1] := 080H + chr MOD 64; chr := chr DIV 64;
+        buf[num  ] := 0E0H + chr; INC(num, 3);
+      END;
+      INC(idx);
+      chr := ORD(chOp[idx]);
+    END;
+    f.Write(num DIV 256);
+    f.Write(num MOD 256);
+    FOR idx := 0 TO num-1 DO f.Write(buf[idx]) END;
+  END WriteOpenUTF;
+
+(* ======================================= *)
+
+  PROCEDURE (f : SymFile)WriteString(IN nam : ARRAY OF CHAR),NEW;
+  BEGIN
+    f.Write(strSy); 
+    f.WriteStrUTF(nam);
+  END WriteString;
+
+(* ======================================= *)
+
+  PROCEDURE (f : SymFile)WriteName(idD : D.Idnt),NEW;
+  BEGIN
+    f.Write(namSy); 
+    f.Write(idD.vMod); 
+    f.WriteOpenUTF(Nh.charOpenOfHash(idD.hash));
+  END WriteName;
+
+(* ======================================= *)
+
+  PROCEDURE (f : SymFile)WriteChar(chr : CHAR),NEW;
+    CONST mask = {0 .. 7};
+    VAR   a,b,int : INTEGER;
+  BEGIN
+    f.Write(chrSy);
+    int := ORD(chr);
+    b := ORD(BITS(int) * mask); int := ASH(int, -8);
+    a := ORD(BITS(int) * mask); 
+    f.Write(a); 
+    f.Write(b); 
+  END WriteChar;
+
+(* ======================================= *)
+
+  PROCEDURE (f : SymFile)Write4B(int : INTEGER),NEW;
+    CONST mask = {0 .. 7};
+    VAR   a,b,c,d : INTEGER;
+  BEGIN
+    d := ORD(BITS(int) * mask); int := ASH(int, -8);
+    c := ORD(BITS(int) * mask); int := ASH(int, -8);
+    b := ORD(BITS(int) * mask); int := ASH(int, -8);
+    a := ORD(BITS(int) * mask); 
+    f.Write(a); 
+    f.Write(b); 
+    f.Write(c); 
+    f.Write(d); 
+  END Write4B;
+
+(* ======================================= *)
+
+  PROCEDURE (f : SymFile)Write8B(val : LONGINT),NEW;
+  BEGIN
+    f.Write4B(RTS.hiInt(val));
+    f.Write4B(RTS.loInt(val));
+  END Write8B;
+
+(* ======================================= *)
+
+  PROCEDURE (f : SymFile)WriteNum(val : LONGINT),NEW;
+  BEGIN
+    f.Write(numSy);
+    f.Write8B(val);
+  END WriteNum;
+
+(* ======================================= *)
+
+  PROCEDURE (f : SymFile)WriteReal(flt : REAL),NEW;
+    VAR rslt : LONGINT;
+  BEGIN
+    f.Write(fltSy);
+    rslt := RTS.realToLongBits(flt);
+    f.Write8B(rslt);
+  END WriteReal;
+
+(* ======================================= *)
+
+  PROCEDURE (f : SymFile)WriteOrd(ord : INTEGER),NEW;
+  BEGIN
+    IF ord <= 7FH THEN 
+      f.Write(ord);
+    ELSIF ord <= 7FFFH THEN
+      f.Write(128 + ord MOD 128);	(* LS7-bits first *)
+      f.Write(ord DIV 128);		(* MS8-bits next  *)
+    ELSE
+      ASSERT(FALSE);
+    END;
+  END WriteOrd;
+
+(* ======================================= *)
+
+  PROCEDURE (f : SymFile)EmitTypeOrd(t : D.Type),NEW;
+  (*
+   *  This proceedure facilitates the naming rules
+   *  for records and (runtime) classes: -
+   *
+   *  (1)  Classes derived from named record types have
+   *       names synthesized from the record typename.
+   *  (2)  If a named pointer is bound to an anon record
+   *       the class takes its name from the pointer name.
+   *  (3)  If both the pointer and the record types have
+   *       names, the class is named from the record.
+   *)
+    VAR recT : Ty.Record;
+   (* ------------------------------------ *)
+    PROCEDURE AddToWorklist(syF :SymFile; tyD : D.Type);
+    BEGIN
+      tyD.dump := syF.oNxt; INC(syF.oNxt);
+      D.AppendType(syF.work, tyD);
+      IF tyD.idnt = NIL THEN 
+        tyD.idnt := Id.newSfAnonId(tyD.dump);
+        tyD.idnt.type := tyD;
+      END;
+    END AddToWorklist;
+   (* ------------------------------------ *)
+  BEGIN
+    IF t.dump = 0 THEN (* type is not dumped yet *)
+      WITH t : Ty.Record DO
+       (*
+        *   We wish to ensure that anonymous records are
+        *   never emitted before their binding pointer
+        *   types.  This ensures that we do not need to
+        *   merge types when reading the files.
+        *)
+        IF (t.bindTp # NIL) & 
+           (t.bindTp.dump = 0) THEN 
+          AddToWorklist(f, t.bindTp);		(* First the pointer...  *)
+        END;
+        AddToWorklist(f, t);			(* Then this record type *)
+      | t : Ty.Pointer DO
+       (*
+        *  If a pointer to record is being emitted, and 
+        *  the pointer is NOT anonymous, then the class
+        *  is known by the name of the record.  Thus the
+        *  record name must be emitted, at least opaquely.
+        *  Furthermore, we must indicate the binding
+        *  relationship between the pointer and record.
+        *  (It is possible that DCode need record size.)
+        *)
+        AddToWorklist(f, t);			(* First this pointer... *)
+        IF (t.boundTp # NIL) & 
+           (t.boundTp.dump = 0) &
+           (t.boundTp IS Ty.Record) THEN
+          recT := t.boundTp(Ty.Record);
+          IF recT.bindTp = NIL THEN
+            t.force := D.forced;
+            AddToWorklist(f, t.boundTp);	(* Then the record type  *)
+          END;
+        END;
+      ELSE (* All others *)
+        AddToWorklist(f, t);			(* Just add the type.    *)
+      END;
+    END;
+    f.WriteOrd(t.dump);
+  END EmitTypeOrd;
+
+(* ============================================================ *)
+(* ========	    Various writing procedures		======= *)
+(* ============================================================ *)
+
+  PROCEDURE (f : SymFile)FormalType(t : Ty.Procedure),NEW;
+  (*
+  ** FormalType = [retSy TypeOrd] frmSy {parSy Byte TypeOrd [String]} endFm.
+  *)
+    VAR indx : INTEGER;
+        parI : Id.ParId;
+  BEGIN
+    IF t.retType # NIL THEN
+      f.Write(retSy);
+      f.EmitTypeOrd(t.retType);
+     (*
+      *   The structure of this type must be
+      *   emitted, unless it is an imported type.
+      *)
+      t.retType.ConditionalMark();
+    END;
+    f.Write(frmSy);
+    FOR indx := 0 TO t.formals.tide-1 DO
+      parI := t.formals.a[indx];
+      f.Write(parSy);
+      f.Write(parI.parMod);
+      f.EmitTypeOrd(parI.type);
+     (*
+      *   Emit Optional Parameter name 
+      *)
+      IF ~G.legacy & (parI.hash # 0) THEN
+        f.WriteString(Nh.charOpenOfHash(parI.hash));
+      END;
+     (*
+      *   The structure of this type must be
+      *   emitted, unless it is an imported type.
+      *)
+      parI.type.ConditionalMark();
+    END;
+    f.Write(endFm);
+  END FormalType;
+
+(* ======================================= *)
+
+  PROCEDURE (f : SymFile)EmitConstId(id : Id.ConId),NEW;
+    VAR conX : ExprDesc.LeafX;
+        cVal : LitValue.Value;
+        sVal : INTEGER;
+  (*
+  ** Constant = conSy Name Literal.
+  ** Literal  = Number | String | Set | Char | Real | falSy | truSy.
+  *)
+  BEGIN
+    conX := id.conExp(ExprDesc.LeafX);
+    cVal := conX.value;
+    f.Write(conSy);
+    f.WriteName(id);
+    CASE conX.kind OF
+    | ExprDesc.tBool  : f.Write(truSy);
+    | ExprDesc.fBool  : f.Write(falSy);
+    | ExprDesc.numLt  : f.WriteNum(cVal.long());
+    | ExprDesc.charLt : f.WriteChar(cVal.char());
+    | ExprDesc.realLt : f.WriteReal(cVal.real());
+    | ExprDesc.strLt  : f.WriteString(cVal.chOpen());
+    | ExprDesc.setLt  : 
+        f.Write(setSy); 
+        IF cVal # NIL THEN sVal := cVal.int() ELSE sVal := 0 END;
+        f.Write4B(sVal);
+    END;
+  END EmitConstId;
+
+(* ======================================= *)
+
+  PROCEDURE (f : SymFile)EmitTypeId(id : Id.TypId),NEW;
+  (*
+  **  Type = TypeSy Name TypeOrd.
+  *)
+  BEGIN
+    f.Write(typSy);
+    f.WriteName(id);
+    f.EmitTypeOrd(id.type);
+   (*
+    *   The structure of this type must be
+    *   emitted, even if it is an imported type.
+    *)
+    id.type.UnconditionalMark();
+  END EmitTypeId;
+
+(* ======================================= *)
+
+  PROCEDURE (f : SymFile)EmitVariableId(id : Id.VarId),NEW;
+  (*
+  ** Variable = varSy Name TypeOrd.
+  *)
+  BEGIN
+    f.Write(varSy);
+    f.WriteName(id);
+    f.EmitTypeOrd(id.type);
+   (*
+    *   The structure of this type must be
+    *   emitted, unless it is an imported type.
+    *)
+    id.type.ConditionalMark();
+  END EmitVariableId;
+
+(* ======================================= *)
+
+  PROCEDURE (f : SymFile)EmitImportId(id : Id.BlkId),NEW;
+  (*
+  ** Import = impSy Name.
+  *)
+  BEGIN
+    IF D.need IN id.xAttr THEN
+      f.Write(impSy);
+      f.WriteName(id);
+      IF id.scopeNm # NIL THEN f.WriteString(id.scopeNm) END;
+      f.Write(keySy);
+      f.Write4B(id.modKey);
+      id.impOrd := f.iNxt; INC(f.iNxt);
+    END;
+  END EmitImportId;
+
+(* ======================================= *)
+
+  PROCEDURE (f : SymFile)EmitProcedureId(id : Id.PrcId),NEW;
+  (*
+  ** Procedure = prcSy Name FormalType.
+  *)
+  BEGIN
+    f.Write(prcSy);
+    f.WriteName(id);
+    IF id.prcNm # NIL THEN f.WriteString(id.prcNm) END;
+    IF id.kind = Id.ctorP THEN f.Write(truSy) END;
+    f.FormalType(id.type(Ty.Procedure));
+  END EmitProcedureId;
+
+(* ======================================= *)
+
+  PROCEDURE (f : SymFile)EmitMethodId(id : Id.MthId),NEW;
+  (*
+  ** Method = mthSy Name Byte Byte TypeOrd [strSy ] FormalType.
+  *)
+  BEGIN
+    IF id.kind = Id.fwdMth THEN id := id.resolve(Id.MthId) END;
+    f.Write(mthSy);
+    f.WriteName(id);
+    f.Write(ORD(id.mthAtt));
+    f.Write(id.rcvFrm.parMod);
+    f.EmitTypeOrd(id.rcvFrm.type);
+    IF id.prcNm # NIL THEN f.WriteString(id.prcNm) END;
+    IF ~G.legacy & (id.rcvFrm.hash # 0) THEN f.WriteName(id.rcvFrm) END;
+    f.FormalType(id.type(Ty.Procedure));
+  END EmitMethodId;
+
+(* ======================================= *)
+
+  PROCEDURE moduleOrd(tpId : D.Idnt) : INTEGER;
+    VAR impM : Id.BlkId;
+  BEGIN
+    IF  (tpId = NIL) OR 
+        (tpId.dfScp = NIL) OR 
+        (tpId.dfScp.kind = Id.modId) THEN
+      RETURN 0;
+    ELSE
+      impM := tpId.dfScp(Id.BlkId);
+      IF impM.impOrd = 0 THEN RETURN -1 ELSE RETURN impM.impOrd END;
+    END;
+  END moduleOrd;
+
+(* ======================================= *)
+
+  PROCEDURE (f : SymFile)EmitTypeHeader(t : D.Type),NEW;
+  (*
+  **  TypeHeader = typSy Ord [fromS Ord Name].
+  *)
+    VAR mod : INTEGER;
+        idt : D.Idnt;
+   (* =================================== *)
+    PROCEDURE warp(id : D.Idnt) : D.Idnt;
+    BEGIN
+      IF    id.type = G.ntvObj THEN RETURN G.objId;
+      ELSIF id.type = G.ntvStr THEN RETURN G.strId;
+      ELSIF id.type = G.ntvExc THEN RETURN G.excId;
+      ELSIF id.type = G.ntvTyp THEN RETURN G.clsId;
+      ELSE  RETURN NIL;
+      END;
+    END warp;
+   (* =================================== *)
+  BEGIN
+    WITH t : Ty.Record DO
+      IF t.bindTp = NIL THEN 
+        idt := t.idnt;
+      ELSIF t.bindTp.dump = 0 THEN
+        ASSERT(FALSE);
+        idt := NIL;
+      ELSE
+        idt := t.bindTp.idnt;
+      END;
+    ELSE
+      idt := t.idnt;
+    END;
+    mod := moduleOrd(t.idnt);
+    f.Write(tDefS);
+    f.WriteOrd(t.dump);
+   (*
+    *  Convert native types back to RTS.nativeXXX, if necessary.
+    *  That is ... if the native module is not explicitly imported.
+    *)
+    IF mod = -1 THEN idt := warp(idt); mod := moduleOrd(idt) END;
+    IF mod # 0 THEN
+      f.Write(fromS);
+      f.WriteOrd(mod);
+      f.WriteName(idt);
+    END;
+  END EmitTypeHeader;
+
+(* ======================================= *)
+
+  PROCEDURE (f : SymFile)EmitArrOrVecType(t : Ty.Array),NEW;
+  BEGIN
+    f.EmitTypeHeader(t);
+    IF t.force # D.noEmit THEN	(* Don't emit structure unless forced *)
+      IF t.kind = Ty.vecTp THEN f.Write(vecSy) ELSE f.Write(arrSy) END;
+      f.EmitTypeOrd(t.elemTp);
+      IF t.length > 127 THEN
+        f.Write(numSy);
+        f.Write8B(t.length);
+      ELSIF t.length > 0 THEN
+        f.Write(bytSy);
+        f.Write(t.length);
+      END;
+      f.Write(endAr);
+    END;
+  END EmitArrOrVecType;
+
+(* ======================================= *)
+
+  PROCEDURE (f : SymFile)EmitRecordType(t : Ty.Record),NEW;
+    VAR index  : INTEGER;
+        field  : D.Idnt;
+        method : D.Idnt;
+  (*
+  **  Record = TypeHeader recSy recAtt [truSy | falSy | <others>] 
+  **		[basSy TypeOrd] [iFcSy {basSy TypeOrd}]
+  **		{Name TypeOrd} {Method} {Statics} endRc.
+  *)
+  BEGIN
+    f.EmitTypeHeader(t);
+    IF t.force # D.noEmit THEN	(* Don't emit structure unless forced *)
+      f.Write(recSy);
+      index := t.recAtt; 
+      IF D.noNew IN t.xAttr THEN INC(index, Ty.noNew) END;
+      IF D.clsTp IN t.xAttr THEN INC(index, Ty.clsRc) END;
+      f.Write(index);
+   (* ########## *)
+      IF t.recAtt = Ty.iFace THEN
+  	f.Write(truSy);
+      ELSIF G.special OR (D.isFn IN t.xAttr) THEN  
+        f.Write(falSy);
+      END;
+   (* ########## *)
+      IF t.baseTp # NIL THEN			(* this is the parent type *)
+        f.Write(basSy);
+        f.EmitTypeOrd(t.baseTp);
+      END;
+   (* ########## *)
+      IF t.interfaces.tide > 0 THEN
+        f.Write(iFcSy);
+        FOR index := 0 TO t.interfaces.tide-1 DO	(* any interfaces  *)
+          f.Write(basSy);
+          f.EmitTypeOrd(t.interfaces.a[index]);
+        END;
+      END;
+   (* ########## *)
+      FOR index := 0 TO t.fields.tide-1 DO
+        field := t.fields.a[index];
+        IF field.vMod # D.prvMode THEN
+          f.WriteName(field);
+          f.EmitTypeOrd(field.type);
+        END;
+      END;
+      IF t.force = D.forced THEN  (* Don't emit methods unless forced *)
+        FOR index := 0 TO t.methods.tide-1 DO
+          method := t.methods.a[index];
+          IF method.vMod # D.prvMode THEN
+            f.EmitMethodId(method(Id.MthId));
+          END;
+        END;
+(*
+ *      IF G.special THEN  (* we might need to emit static stuff *)
+ *
+ *  From 1.2.0 this provides for contructors that do not
+ *  extend imported foreign record types.
+ *)
+          FOR index := 0 TO t.statics.tide-1 DO
+            field := t.statics.a[index];
+            IF field.vMod # D.prvMode THEN
+              CASE field.kind OF
+              | Id.conId  : f.EmitConstId(field(Id.ConId));
+              | Id.varId  : f.EmitVariableId(field(Id.VarId));
+              | Id.ctorP,
+                Id.conPrc : f.EmitProcedureId(field(Id.PrcId));
+              END;
+            END;
+          END;
+        END;
+(*
+ *    END;
+ *)
+      f.Write(endRc);
+    END;
+    D.AppendType(f.modS.expRecs, t);
+  END EmitRecordType;
+
+(* ======================================= *)
+
+  PROCEDURE (f : SymFile)EmitEnumType(t : Ty.Enum),NEW;
+    VAR index  : INTEGER;
+        const  : D.Idnt;
+  (*
+  **  Enum = TypeHeader eTpSy { constant } endRc.
+  *)
+  BEGIN
+    f.EmitTypeHeader(t);
+    f.Write(eTpSy);
+    FOR index := 0 TO t.statics.tide-1 DO
+      const := t.statics.a[index];
+      IF const.vMod # D.prvMode THEN f.EmitConstId(const(Id.ConId)) END;
+    END;
+    f.Write(endRc);
+    (* D.AppendType(f.modS.expRecs, t); *)
+  END EmitEnumType;
+
+(* ======================================= *)
+
+  PROCEDURE (f : SymFile)EmitOpaqueType(t : Ty.Opaque),NEW;
+  BEGIN
+    f.EmitTypeHeader(t);
+  END EmitOpaqueType;
+
+(* ======================================= *)
+
+  PROCEDURE (f : SymFile)EmitPointerType(t : Ty.Pointer),NEW;
+  BEGIN
+    f.EmitTypeHeader(t);
+    IF (t.force # D.noEmit) OR 			(* Only emit structure if *)
+       (t.boundTp.force # D.noEmit) THEN	(* ptr or boundTp forced. *)
+      f.Write(ptrSy);
+      f.EmitTypeOrd(t.boundTp);
+    END;
+  END EmitPointerType;
+
+(* ======================================= *)
+
+  PROCEDURE (f : SymFile)EmitProcedureType(t : Ty.Procedure),NEW;
+  BEGIN
+    f.EmitTypeHeader(t);
+    IF t.isEventType() THEN f.Write(evtSy) ELSE f.Write(pTpSy) END;
+    f.FormalType(t);
+    D.AppendType(f.modS.expRecs, t);
+  END EmitProcedureType;
+
+(* ======================================= *)
+
+  PROCEDURE (f : SymFile)EmitTypeList(),NEW;
+    VAR indx : INTEGER;
+        type : D.Type;
+  BEGIN
+   (*
+    *   We cannot use a FOR loop here, as the tide changes
+    *   during evaluation, as a result of reaching new types.
+    *)
+    indx := 0;
+    WHILE indx < f.work.tide DO
+      type := f.work.a[indx];
+
+      WITH type : Ty.Array     DO f.EmitArrOrVecType(type);
+      |    type : Ty.Record    DO f.EmitRecordType(type);
+      |    type : Ty.Opaque    DO f.EmitOpaqueType(type);
+      |    type : Ty.Pointer   DO f.EmitPointerType(type);
+      |    type : Ty.Procedure DO f.EmitProcedureType(type);
+      |    type : Ty.Enum      DO f.EmitEnumType(type);
+      END;
+      INC(indx);
+    END;
+  END EmitTypeList;
+
+(* ======================================= *)
+
+  PROCEDURE EmitSymfile*(m : Id.BlkId);
+
+    VAR symVisit : SymFileSFA;
+        symfile  : SymFile;
+        marker   : INTEGER;
+(*
+ *      fileName : FileNames.NameString;
+ *)
+        fNamePtr : LitValue.CharOpen;
+  (* ----------------------------------- *)
+    PROCEDURE mkPathName(m : D.Idnt) : LitValue.CharOpen;
+      VAR str : LitValue.CharOpen;
+    BEGIN
+      str := BOX(G.symDir);
+      IF str[LEN(str) - 2] = GF.fileSep THEN
+        str := BOX(str^ + D.getName.ChPtr(m)^ + ".cps");
+      ELSE
+        str := BOX(str^ + fSepArr + D.getName.ChPtr(m)^ + ".cps");
+      END;
+      RETURN str;
+    END mkPathName;
+  (* ----------------------------------- *)
+  (*
+  ** SymFile = Header [String (falSy | truSy | <others>)]
+  **            [ VersionName]
+  **		{Import | Constant | Variable
+  **                 | Type | Procedure | Method} TypeList.
+  ** Header = magic modSy Name.
+  ** VersionName= numSy longint numSy longint numSy longint.
+  **      --            mj# mn#       bld rv#        8xbyte extract
+  *)
+  BEGIN
+   (*
+    *  Create the SymFile structure, and open the output file.
+    *)
+    symfile := newSymFile(m);
+   (* Start of alternative gpcp1.2 code *)
+    IF G.symDir # "" THEN
+      fNamePtr := mkPathName(m);
+      symfile.file := BF.createPath(fNamePtr);
+    ELSE
+      fNamePtr := BOX(D.getName.ChPtr(m)^ + ".cps");
+      symfile.file := BF.createFile(fNamePtr);
+    END;
+    IF symfile.file = NIL THEN
+      S.SemError.Report(177, 0, 0);
+      Error.WriteString("Cannot create file <" + fNamePtr^ + ">"); 
+      Error.WriteLn;
+      RETURN;
+    ELSE
+     (*
+      *  Emit the symbol file header
+      *)
+      IF G.verbose THEN G.Message("Created " + fNamePtr^) END;
+     (* End of alternative gpcp1.2 code *)
+      IF D.rtsMd IN m.xAttr THEN
+        marker := RTS.loInt(syMag);	(* ==> a system module *)
+      ELSE
+        marker := RTS.loInt(magic);	(* ==> a normal module *)
+      END;
+      symfile.Write4B(RTS.loInt(marker));
+      symfile.Write(modSy);
+      symfile.WriteName(m);
+      IF m.scopeNm # NIL THEN (* explicit name *)
+        symfile.WriteString(m.scopeNm);
+        symfile.Write(falSy);
+      END;
+     (*
+      *  Emit the optional TypeName, if required.
+      *
+      *  VersionName= numSy longint numSy longint numSy longint.
+      *       --            mj# mn#       bld rv#        8xbyte extract
+      *)
+      IF m.verNm # NIL THEN
+        symfile.WriteNum(m.verNm[0] * 100000000L + m.verNm[1]);
+        symfile.WriteNum(m.verNm[2] * 100000000L + m.verNm[3]);
+        symfile.WriteNum(m.verNm[4] * 100000000L + m.verNm[5]);
+      END;
+     (*
+      *  Create the symbol table visitor, an extension of 
+      *  Symbols.SymForAll type.  Emit symbols from the scope.
+      *)
+      NEW(symVisit);
+      symVisit.sym := symfile;
+      symfile.modS.symTb.Apply(symVisit); 
+     (*
+      *  Now emit the types on the worklist.
+      *)
+      symfile.Write(start);
+      symfile.EmitTypeList();
+      symfile.Write(close);
+     (*
+      *  Now emit the accumulated checksum key symbol.
+      *)
+      symfile.Write(keySy);
+      lastKey := symfile.cSum;
+      IF G.special THEN symfile.Write4B(0) ELSE symfile.Write4B(lastKey) END;
+      BF.CloseFile(symfile.file);
+    END;
+  END EmitSymfile;
+
+(* ============================================================ *)
+(* ========	Various reading utility procedures	======= *)
+(* ============================================================ *)
+
+  PROCEDURE read(f : BF.FILE) : INTEGER;
+  BEGIN
+    RETURN BF.readByte(f);
+  END read;
+
+(* ======================================= *)
+
+  PROCEDURE ReadUTF(f : BF.FILE; OUT nam : ARRAY OF CHAR);
+    CONST
+        bad = "Bad UTF-8 string";
+    VAR num : INTEGER;
+        bNm : INTEGER;
+        idx : INTEGER;
+        chr : INTEGER;
+  BEGIN
+    num := 0;
+    bNm := read(f) * 256 + read(f);
+    FOR idx := 0 TO bNm-1 DO
+      chr := read(f);
+      IF chr <= 07FH THEN		(* [0xxxxxxx] *)
+        nam[num] := CHR(chr); INC(num);
+      ELSIF chr DIV 32 = 06H THEN	(* [110xxxxx,10xxxxxx] *)
+        bNm := chr MOD 32 * 64;
+        chr := read(f);
+        IF chr DIV 64 = 02H THEN
+          nam[num] := CHR(bNm + chr MOD 64); INC(num);
+        ELSE
+          RTS.Throw(bad);
+        END;
+      ELSIF chr DIV 16 = 0EH THEN	(* [1110xxxx,10xxxxxx,10xxxxxxx] *)
+        bNm := chr MOD 16 * 64;
+        chr := read(f);
+        IF chr DIV 64 = 02H THEN
+          bNm := (bNm + chr MOD 64) * 64; 
+          chr := read(f);
+          IF chr DIV 64 = 02H THEN
+            nam[num] := CHR(bNm + chr MOD 64); INC(num);
+          ELSE 
+            RTS.Throw(bad);
+          END;
+        ELSE
+          RTS.Throw(bad);
+        END;
+      ELSE
+        RTS.Throw(bad);
+      END;
+    END;
+    nam[num] := 0X;
+  END ReadUTF;
+
+(* ======================================= *)
+
+  PROCEDURE readChar(f : BF.FILE) : CHAR;
+  BEGIN
+    RETURN CHR(read(f) * 256 + read(f));
+  END readChar;
+
+(* ======================================= *)
+
+  PROCEDURE readInt(f : BF.FILE) : INTEGER;
+  BEGIN [UNCHECKED_ARITHMETIC]
+    (* overflow checking off here *)
+    RETURN ((read(f) * 256 + read(f)) * 256 + read(f)) * 256 + read(f);
+  END readInt;
+
+(* ======================================= *)
+
+  PROCEDURE readLong(f : BF.FILE) : LONGINT;
+    VAR result : LONGINT;
+        index  : INTEGER;
+  BEGIN [UNCHECKED_ARITHMETIC]
+    (* overflow checking off here *)
+    result := read(f);
+    FOR index := 1 TO 7 DO
+      result := result * 256 + read(f);
+    END;
+    RETURN result;
+  END readLong;
+
+(* ======================================= *)
+
+  PROCEDURE readReal(f : BF.FILE) : REAL;
+    VAR result : LONGINT;
+  BEGIN
+    result := readLong(f);
+    RETURN RTS.longBitsToReal(result);
+  END readReal;
+
+(* ======================================= *)
+
+  PROCEDURE readOrd(f : BF.FILE) : INTEGER;
+    VAR chr : INTEGER;
+  BEGIN
+    chr := read(f);
+    IF chr <= 07FH THEN RETURN chr;
+    ELSE
+      DEC(chr, 128);
+      RETURN chr + read(f) * 128;
+    END;
+  END readOrd;
+
+(* ============================================================ *)
+(* ========		Symbol File Reader		======= *)
+(* ============================================================ *)
+
+  PROCEDURE newSymFileReader*(mod : Id.BlkId) : SymFileReader;
+    VAR new : SymFileReader;
+  BEGIN
+    NEW(new);
+    new.modS := mod;
+    D.InitIdSeq(new.oArray, 4);
+    D.InitTypeSeq(new.tArray, 8);
+    D.InitScpSeq(new.sArray, 8);
+    RETURN new;
+  END newSymFileReader;
+
+(* ======================================= *)
+  PROCEDURE^ (f : SymFileReader)SymFile(IN nm : ARRAY OF CHAR),NEW;
+  PROCEDURE^ WalkThisImport(imp, mod : Id.BlkId);
+(* ======================================= *)
+
+  PROCEDURE Abandon(f : SymFileReader);
+  BEGIN
+    RTS.Throw("Bad symbol file format" + 
+              Nh.charOpenOfHash(f.impS.hash)^); 
+  END Abandon;
+
+(* ======================================= *)
+
+  PROCEDURE (f : SymFileReader)GetSym(),NEW;
+    VAR file : BF.FILE;
+  BEGIN
+    file := f.file;
+    f.sSym := read(file);
+    CASE f.sSym OF
+    | namSy : 
+        f.iAtt := read(file); ReadUTF(file, f.sAtt);
+    | strSy : 
+        ReadUTF(file, f.sAtt);
+    | retSy, fromS, tDefS, basSy :
+        f.iAtt := readOrd(file);
+    | bytSy :
+        f.iAtt := read(file);
+    | keySy, setSy :
+        f.iAtt := readInt(file);
+    | numSy :
+        f.lAtt := readLong(file);
+    | fltSy :
+        f.rAtt := readReal(file);
+    | chrSy :
+        f.cAtt := readChar(file);
+    ELSE (* nothing to do *)
+    END;
+  END GetSym;
+
+(* ======================================= *)
+
+  PROCEDURE (f : SymFileReader)ReadPast(sym : INTEGER),NEW;
+  BEGIN
+    IF f.sSym # sym THEN Abandon(f) END;
+    f.GetSym();
+  END ReadPast;
+
+(* ======================================= *)
+
+  PROCEDURE (f : SymFileReader)Parse*(scope : Id.BlkId;
+                                      filNm : FileNames.NameString),NEW;
+    VAR fileName : FileNames.NameString;
+        marker   : INTEGER;
+        token    : S.Token;
+  BEGIN
+    token := scope.token;
+
+    f.impS := scope;
+    D.AppendScope(f.sArray, scope);
+    fileName := filNm + ".cps";
+    f.file := BF.findOnPath("CPSYM", fileName);
+   (* #### *)
+    IF f.file = NIL THEN
+      fileName := "__" + fileName;
+      f.file := BF.findOnPath("CPSYM", fileName);
+      IF f.file # NIL THEN
+        S.SemError.RepSt2(309, filNm, fileName, token.lin, token.col);
+        filNm := "__" + filNm;
+        scope.clsNm := LitValue.strToCharOpen(filNm);
+      END;
+    END;
+   (* #### *)
+    IF f.file = NIL THEN
+      S.SemError.Report(129, token.lin, token.col); RETURN;
+    ELSE
+      IF G.verbose THEN G.Message("Opened " + fileName) END;
+      marker := readInt(f.file);
+      IF marker = RTS.loInt(magic) THEN
+        (* normal case, nothing to do *)
+      ELSIF marker = RTS.loInt(syMag) THEN
+        INCL(scope.xAttr, D.rtsMd);
+      ELSE
+        S.SemError.Report(130, token.lin, token.col); RETURN;
+      END;
+      f.GetSym();
+      f.SymFile(filNm);
+      IF G.verbose THEN 
+        G.Message("Ended " + fileName + ", Key: " 
+        		+ LitValue.intToCharOpen(f.impS.modKey)^);
+      END;
+      BF.CloseFile(f.file);
+    END;
+  END Parse;
+
+(* ============================================ *)
+
+  PROCEDURE testInsert(id : D.Idnt; sc : D.Scope) : D.Idnt;
+    VAR ident : D.Idnt;
+
+    PROCEDURE Report(i,s : D.Idnt);
+      VAR iS, sS : FileNames.NameString;
+    BEGIN
+      D.getName.Of(i, iS);
+      D.getName.Of(s, sS);
+      S.SemError.RepSt2(172, iS, sS, S.line, S.col);
+    END Report;
+
+  BEGIN
+    IF sc.symTb.enter(id.hash, id) THEN
+      ident := id;
+    ELSE
+      ident := sc.symTb.lookup(id.hash);	(* Warp the return Idnt	*)
+      IF ident.kind # id.kind THEN Report(id, sc); ident := id END;
+    END;
+    RETURN ident;
+  END testInsert;
+
+(* ============================================ *)
+
+  PROCEDURE Insert(id : D.Idnt; VAR tb : D.SymbolTable);
+    VAR ident : D.Idnt;
+
+    PROCEDURE Report(i : D.Idnt);
+      VAR iS : FileNames.NameString;
+    BEGIN
+      D.getName.Of(i, iS);
+      S.SemError.RepSt1(172, iS, 1, 1);
+    END Report;
+
+  BEGIN
+    IF ~tb.enter(id.hash, id) THEN
+      ident := tb.lookup(id.hash);		(* and test isForeign? *)
+      IF ident.kind # id.kind THEN Report(id) END;
+    END;
+  END Insert;
+
+(* ============================================ *)
+ 
+  PROCEDURE InsertInRec(id : D.Idnt; rec : Ty.Record; sfr : SymFileReader);
+  (* insert, taking into account possible overloaded methods. *)
+  VAR
+    ok : BOOLEAN;
+    oId : Id.OvlId;
+
+    PROCEDURE Report(i : D.Idnt; IN s : ARRAY OF CHAR);
+      VAR iS, sS : FileNames.NameString;
+    BEGIN
+      D.getName.Of(i, iS);
+(*
+ *    D.getName.Of(s, sS);
+ *    S.SemError.RepSt2(172, iS, sS, S.line, S.col);
+ *)
+      S.SemError.RepSt2(172, iS, s, S.line, S.col);
+    END Report;
+
+  BEGIN
+    Ty.InsertInRec(id,rec,TRUE,oId,ok);
+    IF oId # NIL THEN D.AppendIdnt(sfr.oArray,oId); END;
+(*
+    IF ~ok THEN Report(id,rec.idnt); END;
+ *)
+    IF ~ok THEN Report(id, rec.name()) END;
+  END InsertInRec;
+
+(* ============================================ *)
+
+  PROCEDURE (f : SymFileReader)getLiteral() : D.Expr,NEW;
+    VAR expr : D.Expr;
+  BEGIN
+    CASE f.sSym OF
+    | truSy : expr := ExprDesc.mkTrueX();
+    | falSy : expr := ExprDesc.mkFalseX();
+    | numSy : expr := ExprDesc.mkNumLt(f.lAtt);
+    | chrSy : expr := ExprDesc.mkCharLt(f.cAtt);
+    | fltSy : expr := ExprDesc.mkRealLt(f.rAtt);
+    | setSy : expr := ExprDesc.mkSetLt(BITS(f.iAtt));
+    | strSy : expr := ExprDesc.mkStrLt(f.sAtt);		(* implicit f.sAtt^ *)
+    END;
+    f.GetSym();						(* read past value  *)
+    RETURN expr;
+  END getLiteral;
+
+(* ============================================ *)
+
+  PROCEDURE (f : SymFileReader)typeOf(ord : INTEGER) : D.Type,NEW;
+    VAR newT : D.Type;
+        indx : INTEGER;
+  BEGIN
+    IF ord < D.tOffset THEN				(* builtin type	*)	
+      RETURN B.baseTypeArray[ord];
+    ELSIF ord - D.tOffset < f.tArray.tide THEN
+      RETURN f.tArray.a[ord - D.tOffset];
+    ELSE 
+      indx := f.tArray.tide + D.tOffset;
+      REPEAT
+        newT := Ty.newTmpTp();
+        newT.dump := indx; INC(indx);
+        D.AppendType(f.tArray, newT);
+      UNTIL indx > ord;
+      RETURN newT;
+    END;
+  END typeOf;
+
+(* ============================================ *)
+
+  PROCEDURE (f : SymFileReader)getTypeFromOrd() : D.Type,NEW;
+    VAR ord : INTEGER;
+  BEGIN
+    ord := readOrd(f.file);
+    f.GetSym();
+    RETURN f.typeOf(ord);
+  END getTypeFromOrd;
+
+(* ============================================ *)
+
+  PROCEDURE (f : SymFileReader)getFormalType(rslt : Ty.Procedure;
+        				     indx : INTEGER) : D.Type,NEW;
+  (*
+  ** FormalType = [retSy TypeOrd] frmSy {parSy Byte TypeOrd [String]} endFm.
+  //	-- optional phrase is return type for proper procedures
+  *)
+    VAR parD : Id.ParId;
+        byte : INTEGER;
+  BEGIN
+    IF f.sSym = retSy THEN 
+      rslt.retType := f.typeOf(f.iAtt);
+      f.GetSym();
+    END;
+    f.ReadPast(frmSy);
+    WHILE f.sSym = parSy DO
+      byte := read(f.file);
+      parD := Id.newParId();
+      parD.parMod := byte;
+      parD.varOrd := indx; 
+      parD.type := f.getTypeFromOrd();
+     (* Skip over optional parameter name string *)
+      IF f.sSym = strSy THEN (* parD.hash := Nh.enterStr(f.sAtt); *)
+        f.GetSym;
+      END;
+      Id.AppendParam(rslt.formals, parD);
+      INC(indx);
+    END;
+    f.ReadPast(endFm);
+    RETURN rslt;
+  END getFormalType;
+
+(* ============================================ *)
+
+  PROCEDURE (f : SymFileReader)pointerType(old : D.Type) : D.Type,NEW;
+  (* Assert: the current symbol ptrSy 		*)
+  (* Pointer   = TypeHeader ptrSy TypeOrd.	*)
+    VAR rslt : Ty.Pointer;
+        indx : INTEGER;
+        junk : D.Type;
+        isEvt: BOOLEAN;
+  BEGIN
+    isEvt := (f.sSym = evtSy);
+    indx := readOrd(f.file);
+    WITH old : Ty.Pointer DO
+      rslt := old;
+     (*
+      *  Check if there is space in the tArray for this
+      *  element, otherwise expand using typeOf().
+      *)
+      IF indx - D.tOffset >= f.tArray.tide THEN
+        junk := f.typeOf(indx);
+      END;
+      f.tArray.a[indx - D.tOffset] := rslt.boundTp;
+    ELSE
+      rslt := Ty.newPtrTp();
+      rslt.boundTp := f.typeOf(indx);
+      IF isEvt THEN rslt.SetKind(Ty.evtTp) END;
+    END;
+    f.GetSym();
+    RETURN rslt;
+  END pointerType;
+
+(* ============================================ *)
+
+  PROCEDURE (f : SymFileReader)procedureType() : D.Type,NEW;
+  (* Assert: the current symbol is pTpSy.	*)
+  (* ProcType  = TypeHeader pTpSy FormalType.	*)
+  BEGIN
+    f.GetSym();		(* read past pTpSy *)
+    RETURN f.getFormalType(Ty.newPrcTp(), 0);
+  END procedureType;
+
+(* ============================================ *)
+
+  PROCEDURE (f : SymFileReader)eventType() : D.Type,NEW;
+  (* Assert: the current symbol is evtSy.	*)
+  (* EventType = TypeHeader evtSy FormalType.	*)
+  BEGIN
+    f.GetSym();		(* read past evtSy *)
+    RETURN f.getFormalType(Ty.newEvtTp(), 0);
+  END eventType;
+
+(* ============================================ *)
+
+  PROCEDURE (f : SymFileReader)arrayType() : Ty.Array,NEW;
+  (* Assert: at entry the current symbol is arrSy.		     *)
+  (* Array      = TypeHeader arrSy TypeOrd (Byte | Number | ) endAr. *)
+  (*	-- nullable phrase is array length for fixed length arrays   *)
+    VAR rslt : Ty.Array;
+        eTyp : D.Type;
+  BEGIN
+    rslt := Ty.newArrTp();
+    rslt.elemTp := f.typeOf(readOrd(f.file));
+    f.GetSym();
+    IF f.sSym = bytSy THEN
+      rslt.length := f.iAtt;
+      f.GetSym();
+    ELSIF f.sSym = numSy THEN
+      rslt.length := SHORT(f.lAtt);
+      f.GetSym();
+    (* ELSE length := 0 *)
+    END;
+    f.ReadPast(endAr);
+    RETURN rslt;
+  END arrayType;
+
+(* ============================================ *)
+
+  PROCEDURE (f : SymFileReader)vectorType() : Ty.Vector,NEW;
+  (* Assert: at entry the current symbol is vecSy.                   *)
+  (* Vector     = TypeHeader vecSy TypeOrd endAr.                    *)
+    VAR rslt : Ty.Vector;
+        eTyp : D.Type;
+  BEGIN
+    rslt := Ty.newVecTp();
+    rslt.elemTp := f.typeOf(readOrd(f.file));
+    f.GetSym();
+    f.ReadPast(endAr);
+    RETURN rslt;
+  END vectorType;
+
+(* ============================================ *)
+  PROCEDURE^ (f : SymFileReader)procedure() : Id.PrcId,NEW;
+  PROCEDURE^ (f : SymFileReader)method()    : Id.MthId,NEW;
+  PROCEDURE^ (f : SymFileReader)constant()  : Id.ConId,NEW;
+  PROCEDURE^ (f : SymFileReader)variable()  : Id.VarId,NEW;
+(* ============================================ *)
+
+  PROCEDURE (f : SymFileReader)recordType(old  : D.Type) : D.Type,NEW;
+  (* Assert: at entry the current symbol is recSy.			*)
+  (* Record     = TypeHeader recSy recAtt [truSy | falSy | <others>] 	*)
+  (*	[basSy TypeOrd] [iFcSy {basSy TypeOrd}]				*)
+  (*	{Name TypeOrd} {Method} {Statics} endRc.			*)
+    CONST 
+        vlTp = Ty.valRc;
+    VAR rslt : Ty.Record;
+        fldD : Id.FldId;
+        varD : Id.VarId;
+        mthD : Id.MthId;
+        conD : Id.ConId;
+        prcD : Id.PrcId;
+        typD : Id.TypId;
+        oldS : INTEGER;
+        attr : INTEGER;
+        mskd : INTEGER;
+  BEGIN
+    WITH old : Ty.Record DO rslt := old ELSE rslt := Ty.newRecTp() END;
+    attr := read(f.file);
+    mskd := attr MOD 8;
+   (*
+    *  The recAtt field has two other bits piggy-backed onto it.
+    *  The noNew Field of xAttr is just added on in the writing 
+    *  and is stripped off here.  The valRc field is used to lock
+    *  in foreign value classes, even though they have basTp # NIL.
+    *)
+(*
+ *  IF mskd # Ty.noAtt THEN INCL(rslt.xAttr, D.clsTp) END;
+ *  IF attr >= noNw THEN DEC(attr, noNw); INCL(rslt.xAttr, D.noNew) END;
+ *)
+    IF attr >= Ty.clsRc THEN DEC(attr,Ty.clsRc); INCL(rslt.xAttr,D.clsTp) END;
+    IF attr >= Ty.noNew THEN DEC(attr,Ty.noNew); INCL(rslt.xAttr,D.noNew) END;
+
+    rslt.recAtt := attr;
+    f.GetSym();				(* Get past recSy rAtt	*)
+    IF f.sSym = falSy THEN
+      INCL(rslt.xAttr, D.isFn);
+      f.GetSym();
+    ELSIF f.sSym = truSy THEN
+      INCL(rslt.xAttr, D.isFn);
+      INCL(rslt.xAttr, D.fnInf);
+      INCL(rslt.xAttr, D.noCpy);
+      f.GetSym();
+    END;
+    IF f.impS.scopeNm # NIL THEN rslt.extrnNm := f.impS.scopeNm END;
+
+    IF f.sSym = basSy THEN
+      rslt.baseTp := f.typeOf(f.iAtt);
+      IF f.iAtt # Ty.anyRec THEN INCL(rslt.xAttr, D.clsTp) END;
+      f.GetSym();
+    END;
+    IF f.sSym = iFcSy THEN
+      f.GetSym();
+      WHILE f.sSym = basSy DO
+        typD := Id.newSfAnonId(f.iAtt);
+        typD.type := f.typeOf(f.iAtt);
+        D.AppendType(rslt.interfaces, typD.type);
+        f.GetSym();
+      END;
+    END;
+    WHILE f.sSym = namSy DO
+      fldD := Id.newFldId();
+      fldD.SetMode(f.iAtt);
+      fldD.hash := Nh.enterStr(f.sAtt);
+      fldD.type := f.typeOf(readOrd(f.file));
+      fldD.recTyp := rslt;
+      f.GetSym();
+      IF rslt.symTb.enter(fldD.hash, fldD) THEN 
+        D.AppendIdnt(rslt.fields, fldD);
+      END;
+    END;
+
+    WHILE (f.sSym = mthSy) OR
+          (f.sSym = prcSy) OR
+          (f.sSym = varSy) OR
+          (f.sSym = conSy) DO
+      oldS := f.sSym; f.GetSym();
+      IF oldS = mthSy THEN
+        mthD := f.method();
+        mthD.bndType := rslt;
+        mthD.type(Ty.Procedure).receiver := rslt;
+        InsertInRec(mthD,rslt,f);
+        D.AppendIdnt(rslt.methods, mthD);
+      ELSIF oldS = prcSy THEN
+        prcD := f.procedure();
+        prcD.bndType := rslt;
+        InsertInRec(prcD,rslt,f);
+        D.AppendIdnt(rslt.statics, prcD);
+      ELSIF oldS = varSy THEN
+        varD := f.variable();
+        varD.recTyp := rslt;
+        InsertInRec(varD,rslt,f);
+        D.AppendIdnt(rslt.statics, varD);
+      ELSIF oldS = conSy THEN
+        conD := f.constant();
+        conD.recTyp := rslt;
+        InsertInRec(conD,rslt,f);
+      ELSE
+        Abandon(f);
+      END;
+    END;
+(* #### *)
+    IF attr >= Ty.valRc THEN 
+      DEC(attr, Ty.valRc); 
+      EXCL(rslt.xAttr, D.clsTp);
+      EXCL(rslt.xAttr, D.noCpy);
+    END;
+(* #### *)
+    f.ReadPast(endRc); 
+    RETURN rslt;
+  END recordType;
+
+(* ============================================ *)
+
+  PROCEDURE (f : SymFileReader)enumType() : D.Type,NEW;
+  (* Assert: at entry the current symbol is eTpSy.			*)
+  (* Enum  = TypeHeader eTpSy { Constant} endRc.			*)
+    VAR rslt : Ty.Enum;
+        cnst : D.Idnt;
+  BEGIN
+    rslt := Ty.newEnuTp();
+    f.GetSym();				(* Get past recSy 	*)
+    WHILE f.sSym = conSy DO
+      f.GetSym();
+      cnst := f.constant();
+      Insert(cnst, rslt.symTb);
+      D.AppendIdnt(rslt.statics, cnst);
+    END;
+    f.ReadPast(endRc); 
+    RETURN rslt;
+  END enumType;
+
+(* ============================================ *)
+
+  PROCEDURE (f : SymFileReader)Type(),NEW;
+  (* Type       = typSy Name TypeOrd.		*)
+    VAR newI : Id.TypId;
+        oldI : D.Idnt;
+        type : D.Type;
+  BEGIN
+   (* 
+    * Post: every previously unknown typId id
+    *	has the property:  id.type.idnt = id.
+    *   If oldI # newT, then the new typId has
+    *   newT.type.idnt = oldI.
+    *)
+    newI := Id.newTypId(NIL);
+    newI.SetMode(f.iAtt);
+    newI.hash := Nh.enterStr(f.sAtt);
+    newI.type := f.getTypeFromOrd(); 
+    newI.dfScp := f.impS;
+    oldI := testInsert(newI, f.impS);
+
+    IF oldI # newI THEN 
+      f.tArray.a[newI.type.dump - D.tOffset] := oldI.type;
+    END;
+
+    IF newI.type.idnt = NIL THEN newI.type.idnt := oldI END;
+  END Type;
+
+(* ============================================ *)
+
+  PROCEDURE (f : SymFileReader)Import(),NEW;
+  (* Import     = impSy Name [String] Key.	*)
+  (*	-- optional string is external name	*)
+  (* first symbol should be namSy here.		*)
+    VAR impD : Id.BlkId;
+        oldS : Id.BlkId;
+        oldD : D.Idnt;
+  BEGIN
+    impD := Id.newImpId();
+    impD.dfScp := impD;			(* ImpId define their own scope *)
+
+    INCL(impD.xAttr, D.weak);
+    impD.SetMode(f.iAtt);
+    impD.hash := Nh.enterStr(f.sAtt);
+    f.ReadPast(namSy); 
+    IF impD.hash = f.modS.hash THEN	(* Importing own imp indirectly	*)
+        				(* Shouldn't this be an error?  *)
+      D.AppendScope(f.sArray, f.modS);
+      IF f.sSym = strSy THEN 
+        (* probably don't need to do anything here ... *)
+        f.GetSym();
+      END;
+    ELSE				(* Importing some other module.	*)
+      oldD := testInsert(impD, f.modS);
+      IF f.sSym = strSy THEN 
+        impD.scopeNm := LitValue.strToCharOpen(f.sAtt);
+        f.GetSym();
+      END;
+      IF (oldD # impD) & (oldD.kind = Id.impId) THEN
+        oldS := oldD(Id.BlkId);
+        D.AppendScope(f.sArray, oldS);
+        IF (oldS.modKey # 0) & (f.iAtt # oldS.modKey) THEN
+          S.SemError.RepSt1(133,		(* Detected bad KeyVal	*)
+        	Nh.charOpenOfHash(impD.hash)^, 
+        	S.line, S.col);
+        END;
+(* should not be necessary anymore *)
+        IF ~(D.weak IN oldS.xAttr) &
+           ~(D.fixd IN oldS.xAttr) THEN
+         (*
+          *   This recursively reads the symbol files for 
+          *   any imports of this file which are on the
+          *   list to be imported later anyhow.
+          *)
+          WalkThisImport(oldS, f.modS);
+        END;
+      ELSE
+        D.AppendScope(f.sArray, impD);
+      END;
+      impD.modKey := f.iAtt;
+    END;
+    f.ReadPast(keySy);
+  END Import;
+
+(* ============================================ *)
+
+  PROCEDURE (f : SymFileReader)constant() : Id.ConId,NEW;
+  (* Constant   = conSy Name Literal.		*)
+  (* Assert: f.sSym = namSy.			*)
+    VAR newC : Id.ConId;
+        anyI : D.Idnt;
+  BEGIN
+    newC := Id.newConId();
+    newC.SetMode(f.iAtt);
+    newC.hash := Nh.enterStr(f.sAtt);
+    newC.dfScp := f.impS;
+    f.ReadPast(namSy);
+    newC.conExp := f.getLiteral();
+    newC.type := newC.conExp.type;
+    RETURN newC;
+  END constant;
+
+(* ============================================ *)
+
+  PROCEDURE (f : SymFileReader)variable() : Id.VarId,NEW;
+  (* Variable   = varSy Name TypeOrd.		*)
+    VAR newV : Id.VarId;
+        anyI : D.Idnt;
+  BEGIN
+    newV := Id.newVarId();
+    newV.SetMode(f.iAtt);
+    newV.hash := Nh.enterStr(f.sAtt);
+    newV.type := f.getTypeFromOrd();
+    newV.dfScp := f.impS;
+    RETURN newV;
+  END variable;
+
+(* ============================================ *)
+
+  PROCEDURE (f : SymFileReader)procedure() : Id.PrcId,NEW;
+  (* Procedure  = prcSy Name[String]FormalType. *)
+  (* This is a static proc, mths come with Recs *)
+    VAR newP : Id.PrcId;
+        anyI : D.Idnt;
+  BEGIN
+    newP := Id.newPrcId();
+    newP.setPrcKind(Id.conPrc);
+    newP.SetMode(f.iAtt);
+    newP.hash := Nh.enterStr(f.sAtt);
+    newP.dfScp := f.impS;
+    f.ReadPast(namSy);
+    IF f.sSym = strSy THEN 
+      newP.prcNm := LitValue.strToCharOpen(f.sAtt);
+     (* and leave scopeNm = NIL *)
+      f.GetSym();
+    END;
+    IF f.sSym = truSy THEN	(* ### this is a constructor ### *)
+      f.GetSym();
+      newP.setPrcKind(Id.ctorP);
+    END;			(* ### this is a constructor ### *)
+    newP.type := f.getFormalType(Ty.newPrcTp(), 0);
+    (* IF this is a java module, do some semantic checks *)
+    (* ... *)
+    RETURN newP;
+  END procedure;
+
+(* ============================================ *)
+
+  PROCEDURE (f : SymFileReader)method() : Id.MthId,NEW;
+  (* Method     = mthSy Name byte byte TypeOrd [String][Name] FormalType. *)
+    VAR newM : Id.MthId;
+        rcvD : Id.ParId;
+        rFrm : INTEGER;
+        mAtt : SET;
+  BEGIN
+    newM := Id.newMthId();
+    newM.SetMode(f.iAtt);
+    newM.setPrcKind(Id.conMth);
+    newM.hash := Nh.enterStr(f.sAtt);
+    newM.dfScp := f.impS;
+    rcvD := Id.newParId();
+    rcvD.varOrd := 0;
+   (* byte1 is the method attributes  *)
+    mAtt := BITS(read(f.file));
+   (* byte2 is param form of receiver *)
+    rFrm := read(f.file);
+   (* next 1 or 2 bytes are rcv-type  *)
+    rcvD.type := f.typeOf(readOrd(f.file));
+    f.GetSym();
+    rcvD.parMod := rFrm;
+    IF f.sSym = strSy THEN 
+      newM.prcNm := LitValue.strToCharOpen(f.sAtt);
+     (* and leave scopeNm = NIL *)
+      f.GetSym();
+    END;
+   (* Skip over optional receiver name string *)
+    IF f.sSym = namSy THEN (* rcvD.hash := Nh.enterString(f.sAtt); *)
+      f.GetSym();
+    END;
+   (* End skip over optional receiver name *)
+    newM.type := f.getFormalType(Ty.newPrcTp(), 1);
+    newM.mthAtt := mAtt;
+    newM.rcvFrm := rcvD;
+   (* IF this is a java module, do some semantic checks *)
+    RETURN newM;
+  END method;
+
+(* ============================================ *)
+
+  PROCEDURE (f : SymFileReader)TypeList(),NEW;
+  (* TypeList   = start { Array | Record | Pointer      *)
+  (*		  | ProcType | Vector} close.           *)
+  (* TypeHeader = tDefS Ord [fromS Ord Name].           *)
+    VAR modOrd : INTEGER;
+        typOrd : INTEGER;
+        typIdx : INTEGER;
+        tpDesc : D.Type;
+        tpTemp : D.Type;
+        tpIdnt : Id.TypId;
+        prevId : D.Idnt;
+        prevTp : D.Type;
+        impScp : D.Scope;
+        linkIx : INTEGER;
+        bndTyp : D.Type;
+        typeFA : TypeLinker;
+  BEGIN
+    WHILE f.sSym = tDefS DO
+      linkIx := 0;
+      tpIdnt := NIL;
+     (* Do type header *)
+      typOrd := f.iAtt;
+      typIdx := typOrd - D.tOffset;
+      tpTemp := f.tArray.a[typIdx];
+      impScp := NIL;
+      f.ReadPast(tDefS);
+     (*
+      *  The [fromS modOrd typNam] appears if the type is imported.
+      *  There are two cases:
+      *     this is the first time that "mod.typNam" has been 
+      *     seen during this compilation 
+      *                   ==> insert a new typId descriptor in mod.symTb
+      *     this name is already in the mod.symTb table
+      *                   ==> fetch the previous descriptor
+      *)
+      IF f.sSym = fromS THEN
+        modOrd := f.iAtt;
+        impScp := f.sArray.a[modOrd];
+        f.GetSym();
+        tpIdnt := Id.newTypId(NIL);
+        tpIdnt.SetMode(f.iAtt);
+        tpIdnt.hash := Nh.enterStr(f.sAtt);
+        tpIdnt.dfScp := impScp;
+        tpIdnt := testInsert(tpIdnt, impScp)(Id.TypId);
+        f.ReadPast(namSy);
+      END;
+
+     (* Get type info. *)
+      CASE f.sSym OF
+      | arrSy : tpDesc := f.arrayType();
+      | vecSy : tpDesc := f.vectorType();
+      | recSy : tpDesc := f.recordType(tpTemp);
+      | pTpSy : tpDesc := f.procedureType();
+      | evtSy : tpDesc := f.eventType();
+      | eTpSy : tpDesc := f.enumType();
+      | ptrSy : tpDesc := f.pointerType(tpTemp);
+                IF tpDesc # NIL THEN 
+                  bndTyp := tpDesc(Ty.Pointer).boundTp;
+                  IF (bndTyp # NIL) & 
+                     (bndTyp.kind = Ty.tmpTp) THEN
+                    linkIx := bndTyp.dump - D.tOffset;
+                  END;
+                END;
+      ELSE 
+        tpDesc := Ty.newNamTp();
+      END;
+      IF tpIdnt # NIL THEN
+       (*
+        *  A name has been declared for this type, tpIdnt is
+        *  the (possibly previously known) id descriptor, and
+        *  tpDesc is the newly parsed descriptor of the type.
+        *) 
+        IF  tpIdnt.type = NIL THEN 
+         (*
+          *  Case #1: no previous type.
+          *  This is the first time the compiler has seen this type
+          *)
+          tpIdnt.type := tpDesc;
+          tpDesc.idnt := tpIdnt;
+        ELSIF tpDesc IS Ty.Opaque THEN
+         (* 
+          *  Case #2: previous type exists, new type is opaque.
+          *  Throw away the newly parsed opaque type desc, and
+          *  use the previously known type *even* if it is opaque!
+          *)
+          tpDesc := tpIdnt.type;
+        ELSIF tpIdnt.type IS Ty.Opaque THEN
+         (*
+          *  Case #3: previous type is opaque, new type is non-opaque.
+          *  This type had been seen opaquely, but now has a 
+          *  non-opaque definition
+          *)
+          tpIdnt.type(Ty.Opaque).resolved := tpDesc;
+          tpIdnt.type := tpDesc;
+          tpDesc.idnt := tpIdnt;
+        ELSE
+         (*
+          *  Case #4: previous type is non-opaque, new type is non-opaque.
+          *  This type already has a non-opaque descriptor.
+          *  We shall keep the original copy.
+          *)
+          tpDesc := tpIdnt.type;
+        END;
+       (*
+        *  Normally, imported types cannot be anonymous.
+        *  However, there is one special case here. Anon
+        *  records can be record base types, but are always 
+        *  preceeded by the binding pointer type. A typical
+        *  format of output from SymDec might be ---
+        *
+        *       T18 = SomeMod.BasePtr
+        *             POINTER TO T19;
+        *       T19 = EXTENSIBLE RECORD  (T11) ... END;
+        *
+        *  in this case T19 is an anon record from SomeMod,
+        *  not the current module.
+        *
+        *  Thus we pre-override the future record declaration
+        *  by the bound type of the pointer.  This ensures
+        *  uniqueness of the record descriptor, even if it is
+        *  imported indirectly multiple times.
+        *)
+        WITH tpDesc : Ty.Pointer DO
+          IF linkIx # 0 THEN f.tArray.a[linkIx] := tpDesc.boundTp END;
+        ELSE (* skip *)
+        END;
+        f.tArray.a[typIdx] := tpDesc;
+      ELSE  
+       (* 
+        *  tpIdnt is NIL ==> type is from this import,
+        *  except for the special case above.  In the usual
+        *  case we replace the tmpTp by tpDesc. In the special
+        *  case the tmpTp has been already been overridden by 
+        *  the previously imported bound type.
+        *)
+        prevTp := f.tArray.a[typIdx];
+        prevId := prevTp.idnt;
+        IF (prevId # NIL) &
+           (prevId.type.kind = Ty.namTp) THEN
+          prevId.type(Ty.Opaque).resolved := tpDesc;
+          prevId.type := tpDesc;
+        END;
+        tpDesc.idnt := prevId;
+        f.tArray.a[typIdx] := tpDesc;
+      END;
+    END; (* while *)
+   (*
+    *  First we fix up all symbolic references in the
+    *  the type array.  Postcondition is : no element
+    *  of the type array directly or indirectly refers
+    *  to a temporary type.
+    *)
+    FOR linkIx := 0 TO f.tArray.tide - 1 DO
+      f.tArray.a[linkIx].TypeFix(f.tArray);
+    END;
+   (*
+    *  We now fix up all references in the symbol table
+    *  that still refer to temporary symbol-file types.
+    *)
+    NEW(typeFA);
+    typeFA.sym := f;
+    f.impS.symTb.Apply(typeFA); 
+    f.ReadPast(close);
+   (*
+    *  Now check that all overloaded ids are necessary
+    *)
+    FOR linkIx := 0 TO f.oArray.tide - 1 DO
+      f.oArray.a[linkIx].OverloadFix();
+      f.oArray.a[linkIx] := NIL;
+    END;
+  END TypeList;
+
+(* ============================================ *)
+
+  PROCEDURE (f : SymFileReader)SymFile(IN nm : ARRAY OF CHAR),NEW;
+   (*
+   // SymFile    = Header [String (falSy | truSy | <others>)]
+   //		{Import | Constant | Variable | Type | Procedure} 
+   //		TypeList Key.
+   // Header     = magic modSy Name.
+   //
+   //  magic has already been recognized.
+   *)
+    VAR oldS : INTEGER;
+  BEGIN
+    f.ReadPast(modSy);
+    IF f.sSym = namSy THEN (* do something with f.sAtt *)
+      IF nm # f.sAtt THEN
+        Error.WriteString("Wrong name in symbol file. Expected <");
+        Error.WriteString(nm + ">, found <");
+        Error.WriteString(f.sAtt + ">"); 
+        Error.WriteLn;
+        HALT(1);
+      END;
+      f.GetSym();
+    ELSE RTS.Throw("Bad symfile header");
+    END;
+    IF f.sSym = strSy THEN (* optional name *)
+      f.impS.scopeNm := LitValue.strToCharOpen(f.sAtt);
+      f.GetSym();
+      IF f.sSym = falSy THEN 
+        INCL(f.impS.xAttr, D.isFn);
+        f.GetSym();
+      ELSIF f.sSym = truSy THEN
+        INCL(f.impS.xAttr, D.isFn);
+        INCL(f.impS.xAttr, D.fnInf);
+        f.GetSym();
+      ELSE RTS.Throw("Bad explicit name");
+      END; 
+    END; 
+    IF f.sSym = numSy THEN (* optional strong name info.    *)
+      NEW(f.impS.verNm);   (* POINTER TO ARRAY 6 OF INTEGER *)
+      f.impS.verNm[0] := RTS.hiInt(f.lAtt);
+      f.impS.verNm[1] := RTS.loInt(f.lAtt);
+      f.GetSym();
+      f.impS.verNm[2] := RTS.hiInt(f.lAtt);
+      f.impS.verNm[3] := RTS.loInt(f.lAtt);
+      f.GetSym();
+      f.impS.verNm[4] := RTS.hiInt(f.lAtt);
+      f.impS.verNm[5] := RTS.loInt(f.lAtt);
+      f.GetSym();
+      IF G.verbose THEN
+        Console.WriteString("version:"); 
+        Console.WriteInt(f.impS.verNm[0],1); Console.Write(".");
+        Console.WriteInt(f.impS.verNm[1],1); Console.Write(".");
+        Console.WriteInt(f.impS.verNm[2],1); Console.Write(".");
+        Console.WriteInt(f.impS.verNm[3],1); 
+        Console.WriteHex(f.impS.verNm[4],9);
+        Console.WriteHex(f.impS.verNm[5],9); Console.WriteLn;
+      END;
+    END;
+    LOOP
+      oldS := f.sSym;
+      f.GetSym();
+      CASE oldS OF
+      | start : EXIT;
+      | typSy : f.Type();
+      | impSy : f.Import();
+      | conSy : Insert(f.constant(),  f.impS.symTb);
+      | varSy : Insert(f.variable(),  f.impS.symTb);
+      | prcSy : Insert(f.procedure(), f.impS.symTb);
+      ELSE RTS.Throw("Bad object");
+      END;
+    END;
+   (* Now read the typelist *)
+    f.TypeList();
+    IF f.sSym = keySy THEN
+      IF f.impS.modKey = 0 THEN 
+        f.impS.modKey := f.iAtt;
+      ELSIF f.impS.modKey # f.iAtt THEN
+        S.SemError.Report(173, S.line, S.col);	(* Detected bad KeyVal	*)
+      END;
+    ELSE RTS.Throw("Missing keySy");
+    END; 
+  END SymFile;
+
+(* ============================================================ *)
+(* ========	     SymFileSFA visitor method		======= *)
+(* ============================================================ *)
+
+  PROCEDURE (t : SymFileSFA)Op*(id : D.Idnt);
+  BEGIN
+    IF (id.kind = Id.impId) OR (id.vMod # D.prvMode) THEN
+      CASE id.kind OF
+      | Id.typId  : t.sym.EmitTypeId(id(Id.TypId));
+      | Id.conId  : t.sym.EmitConstId(id(Id.ConId));
+      | Id.impId  : t.sym.EmitImportId(id(Id.BlkId));
+      | Id.varId  : t.sym.EmitVariableId(id(Id.VarId));
+(* new *)
+      | Id.conPrc : t.sym.EmitProcedureId(id(Id.PrcId));
+(*
+ * old ... we used to emit the constructor as a static method.
+ *         Now it appears as a static in the bound record decl.
+ *
+ *    | Id.ctorP,
+ *      Id.conPrc : t.sym.EmitProcedureId(id(Id.PrcId));
+ *)
+      ELSE (* skip *)
+      END;
+    END;
+  END Op;
+
+(* ============================================================ *)
+(* ========	     TypeLinker visitor method		======= *)
+(* ============================================================ *)
+
+  PROCEDURE (t : TypeLinker)Op*(id : D.Idnt);
+  BEGIN
+    IF id.type = NIL THEN RETURN
+    ELSIF id.type.kind = Ty.tmpTp THEN
+      id.type := Ty.update(t.sym.tArray, id.type);
+    ELSE
+      id.type.TypeFix(t.sym.tArray);
+    END;
+    IF  (id IS Id.TypId) & 
+        (id.type.idnt = NIL) THEN id.type.idnt := id END;
+  END Op;
+
+(* ============================================================ *)
+(* ========	    Symbol file parser method		======= *)
+(* ============================================================ *)
+
+  PROCEDURE WalkThisImport(imp, mod : Id.BlkId);
+    VAR syFil : SymFileReader;
+        filNm : FileNames.NameString;
+  BEGIN
+    PushStack(imp);
+    INCL(imp.xAttr, D.fixd);
+    S.GetString(imp.token.pos, imp.token.len, filNm);
+    syFil := newSymFileReader(mod);
+    syFil.Parse(imp, filNm);
+    PopStack;
+  END WalkThisImport;
+ 
+(* ============================================ *)
+
+  PROCEDURE WalkImports*(IN imps : D.ScpSeq; modI : Id.BlkId);
+    VAR indx : INTEGER;
+        scpI : D.Scope;
+        blkI : Id.BlkId;
+  BEGIN
+   (*
+    *  The list of scopes has been constructed by
+    *  the parser, while reading the import list.
+    *  In the case of already known scopes the list
+    *  references the original descriptor.
+    *)
+    InitStack;
+    FOR indx := 0 TO imps.tide-1 DO
+      scpI := imps.a[indx];
+      blkI := scpI(Id.BlkId);
+      IF blkI.kind = Id.alias THEN
+        blkI.symTb  := blkI.dfScp.symTb;
+      ELSIF ~(D.fixd IN blkI.xAttr) THEN 
+        WalkThisImport(blkI,modI);
+      END;
+    END;
+  END WalkImports;
+
+(* ============================================================ *)
+BEGIN
+  lastKey := 0;
+  fSepArr[0] := GF.fileSep;
+END OldSymFileRW.
+(* ============================================================ *)

gpcp/PeToCps.cp

@@ -0,0 +1,203 @@
+
+(* ================================================================ *)
+(*                                                                  *)
+(*  Module of the V1.4+ gpcp tool to create symbol files from       *)
+(*  the metadata of .NET assemblies, using the PERWAPI interface.   *)
+(*                                                                  *)
+(*  Copyright QUT 2004 - 2005.                                      *)
+(*                                                                  *)
+(*  This code released under the terms of the GPCP licence.         *)
+(*                                                                  *)
+(*  This Module:   <PeToCps>                                        *)
+(*       Base module. Command line processing etcetera.             *)
+(*       Original module, kjg December 2004                         *)
+(*                                                                  *)
+(* ================================================================ *)
+
+MODULE PeToCps;
+  IMPORT CPmain, RTS, GPCPcopyright, ProgArgs, 
+     GPFiles,
+     FileNames,
+     Glb := N2State,
+     C2T := ClsToType,
+     Per := "[QUT.PERWAPI]QUT.PERWAPI",
+     Sys := "[mscorlib]System",
+     IdDesc;
+
+  TYPE
+    ArgS = ARRAY 256 OF CHAR;
+
+  VAR
+    chr0 : CHAR;
+    argN : INTEGER;
+    filN : INTEGER;
+    okNm : INTEGER;
+    errs : INTEGER;
+    tim0 : LONGINT;
+    timS : LONGINT;
+    timE : LONGINT;
+    argS : ArgS;
+    resS : Glb.CharOpen;
+
+(* ==================================================================== *)
+
+  PROCEDURE resStr(res : INTEGER) : Glb.CharOpen;
+    VAR tmp : Glb.CharOpen;
+  BEGIN
+    CASE res OF
+    | 0 : tmp := BOX("succeeded");
+    | 1 : tmp := BOX("input not found");
+    | 2 : tmp := BOX("output not created");
+    | 3 : tmp := BOX("failed");
+    | 4 : tmp := BOX("error <" + resS^ + ">");
+    END;
+    RETURN tmp;
+  END resStr;
+
+(* ------------------------------------------------------- *)
+
+  PROCEDURE ExceptionName(x : RTS.NativeException) : Glb.CharOpen;
+    VAR ptr : Glb.CharOpen;
+        idx : INTEGER;
+  BEGIN
+    ptr := RTS.getStr(x);
+    FOR idx := 0 TO LEN(ptr^) - 1 DO
+      IF ptr[idx] <= " " THEN ptr[idx] := 0X; RETURN ptr END;
+    END;
+    RETURN ptr;
+  END ExceptionName;
+
+(* ------------------------------------------------------- *)
+
+  PROCEDURE GetVersionInfo(pef : Per.PEFile; 
+                       OUT inf : POINTER TO ARRAY OF INTEGER);
+    CONST tag = "PublicKeyToken=";
+    VAR   asm : Per.Assembly;
+          str : Sys.String;
+          arr : Glb.CharOpen;
+          idx : INTEGER;
+          tok : LONGINT;
+  BEGIN
+    asm := pef.GetThisAssembly();
+    IF (asm.MajorVersion() # 0) & (LEN(asm.Key()) > 0) THEN
+      NEW(inf, 6);
+      tok := asm.KeyTokenAsLong(); 
+      inf[4] := RTS.hiInt(tok);
+      inf[5] := RTS.loInt(tok);
+
+      inf[0] := asm.MajorVersion();
+      inf[1] := asm.MinorVersion();
+      inf[2] := asm.BuildNumber();
+      inf[3] := asm.RevisionNumber();
+
+    ELSE
+      inf := NIL;
+    END;
+  END GetVersionInfo;
+
+(* ------------------------------------------------------- *)
+
+  PROCEDURE CopyVersionInfo(inf : POINTER TO ARRAY OF INTEGER;
+                            blk : IdDesc.BlkId);
+    VAR ix : INTEGER;
+  BEGIN
+    IF inf # NIL THEN
+      NEW(blk.verNm);
+      FOR ix := 0 TO 5 DO
+        blk.verNm[ix] := inf[ix];
+      END;
+    END;
+  END CopyVersionInfo;
+
+(* ==================================================================== *)
+
+  PROCEDURE Process(IN  nam : ARRAY OF CHAR;
+                    OUT rVl : INTEGER);       (* return value *)
+    VAR peFl : Per.PEFile;
+        clss : POINTER TO ARRAY OF Per.ClassDef;
+        indx : INTEGER;
+        nSpc : VECTOR OF C2T.DefNamespace;
+        basS : ArgS;
+        vrsn : POINTER TO ARRAY OF INTEGER;
+  BEGIN
+    rVl := 0;
+    FileNames.StripExt(nam, basS);
+
+    Glb.CondMsg(" Reading PE file");
+    peFl := Per.PEFile.ReadPublicClasses(MKSTR(nam));
+
+    Glb.GlobInit(nam, basS);
+
+    IF ~Glb.isCorLib THEN C2T.InitCorLibTypes() END;
+
+    Glb.CondMsg(" Processing PE file");
+    clss := peFl.GetClasses();
+    C2T.Classify(clss, nSpc);
+   (*
+    *  Define BlkId for every namespace
+    *)
+    GetVersionInfo(peFl, vrsn);
+    FOR indx := 0 TO LEN(nSpc) - 1 DO
+      C2T.MakeBlkId(nSpc[indx], Glb.basNam);
+      CopyVersionInfo(vrsn, nSpc[indx].bloc);
+    END;
+
+   (*
+    *  Define TypIds in every namespace
+    *)
+    FOR indx := 0 TO LEN(nSpc) - 1 DO
+      IF ~Glb.isCorLib THEN C2T.ImportCorlib(nSpc[indx]) END;
+      C2T.MakeTypIds(nSpc[indx]); 
+    END;
+    IF Glb.isCorLib THEN C2T.BindSystemTypes() END;
+   (*
+    *  Define structure of every class
+    *)
+    FOR indx := 0 TO LEN(nSpc) - 1 DO
+      C2T.DefineClss(nSpc[indx]); 
+    END;
+   (*
+    *  Write out symbol file(s)
+    *)
+    FOR indx := 0 TO LEN(nSpc) - 1 DO
+      Glb.ResetBlkIdFlags(nSpc[indx].bloc);
+      Glb.EmitSymbolfile(nSpc[indx].bloc);
+    END;
+    Glb.CondMsg(" Completing normally");
+  RESCUE (sysX)
+    resS := ExceptionName(sysX);
+    Glb.Message(" " + resS^);
+    Glb.Message(" " + RTS.getStr(sysX)^);
+    rVl := 4;
+  END Process;
+
+(* ==================================================================== *)
+(*			      Main Argument Loop			*)
+(* ==================================================================== *)
+
+BEGIN
+  filN := 0;
+  tim0 := RTS.GetMillis();
+  Glb.Message(GPCPcopyright.verStr);
+  FOR argN := 0 TO ProgArgs.ArgNumber()-1 DO
+    ProgArgs.GetArg(argN, argS);
+    chr0 := argS[0];
+    IF (chr0 = '-') OR (chr0 = GPFiles.optChar) THEN (* option string *)
+      argS[0] := "-";
+      Glb.ParseOption(argS$);
+    ELSE
+      timS := RTS.GetMillis();
+      Process(argS$, errs); 
+      INC(filN); 
+      IF errs = 0 THEN INC(okNm) END;
+      timE := RTS.GetMillis();
+
+      Glb.Report(argS$, resStr(errs), timE - timS);
+    END;
+  END;
+  Glb.Summary(filN, okNm, timE - tim0);
+ (*
+  *  Return the result code of the final compilation
+  *)
+  IF errs # 0 THEN HALT(1) END;
+END PeToCps.

gpcp/PeToCps/MakeNetSystem.bat

@@ -0,0 +1,96 @@
+REM This batch file for .NET Version 2.0 +
+REM build the .NET system CP symbol files
+..\..\..\bin\PeToCps mscorlib.dll
+..\..\..\bin\PeToCps System.dll
+..\..\..\bin\PeToCps System.Drawing.dll
+..\..\..\bin\PeToCps System.Security.dll
+..\..\..\bin\PeToCps /big System.Windows.Forms.dll
+..\..\..\bin\PeToCps System.XML.dll
+..\..\..\bin\PeToCps System.Data.dll
+..\..\..\bin\PeToCps System.Configuration.dll
+REM and then the corresponding HTML Browse files
+..\..\..\bin\Browse /html /sort mscorlib_Microsoft_Win32.cps
+..\..\..\bin\Browse /html /sort mscorlib_System.cps
+..\..\..\bin\Browse /html /sort mscorlib_System_Collections.cps
+..\..\..\bin\Browse /html /sort mscorlib_System_Configuration_Assemblies.cps
+..\..\..\bin\Browse /html /sort mscorlib_System_Diagnostics.cps
+..\..\..\bin\Browse /html /sort mscorlib_System_Diagnostics_SymbolStore.cps
+..\..\..\bin\Browse /html /sort mscorlib_System_Globalization.cps
+..\..\..\bin\Browse /html /sort mscorlib_System_IO.cps
+..\..\..\bin\Browse /html /sort mscorlib_System_IO_IsolatedStorage.cps
+..\..\..\bin\Browse /html /sort mscorlib_System_Reflection.cps
+..\..\..\bin\Browse /html /sort mscorlib_System_Reflection_Emit.cps
+..\..\..\bin\Browse /html /sort mscorlib_System_Resources.cps
+..\..\..\bin\Browse /html /sort mscorlib_System_Runtime_CompilerServices.cps
+..\..\..\bin\Browse /html /sort mscorlib_System_Runtime_InteropServices.cps
+..\..\..\bin\Browse /html /sort mscorlib_System_Runtime_InteropServices_Expando.cps
+..\..\..\bin\Browse /html /sort mscorlib_System_Runtime_Remoting.cps
+..\..\..\bin\Browse /html /sort mscorlib_System_Runtime_Remoting_Activation.cps
+..\..\..\bin\Browse /html /sort mscorlib_System_Runtime_Remoting_Channels.cps
+..\..\..\bin\Browse /html /sort mscorlib_System_Runtime_Remoting_Contexts.cps
+..\..\..\bin\Browse /html /sort mscorlib_System_Runtime_Remoting_Lifetime.cps
+..\..\..\bin\Browse /html /sort mscorlib_System_Runtime_Remoting_Messaging.cps
+..\..\..\bin\Browse /html /sort mscorlib_System_Runtime_Remoting_Metadata.cps
+..\..\..\bin\Browse /html /sort mscorlib_System_Runtime_Remoting_Metadata_W3cXsd2001.cps
+..\..\..\bin\Browse /html /sort mscorlib_System_Runtime_Remoting_Proxies.cps
+..\..\..\bin\Browse /html /sort mscorlib_System_Runtime_Remoting_Services.cps
+..\..\..\bin\Browse /html /sort mscorlib_System_Runtime_Serialization.cps
+..\..\..\bin\Browse /html /sort mscorlib_System_Runtime_Serialization_Formatters.cps
+..\..\..\bin\Browse /html /sort mscorlib_System_Runtime_Serialization_Formatters_Binary.cps
+..\..\..\bin\Browse /html /sort mscorlib_System_Security.cps
+..\..\..\bin\Browse /html /sort mscorlib_System_Security_Cryptography.cps
+..\..\..\bin\Browse /html /sort mscorlib_System_Security_Cryptography_X509Certificates.cps
+..\..\..\bin\Browse /html /sort mscorlib_System_Security_Permissions.cps
+..\..\..\bin\Browse /html /sort mscorlib_System_Security_Policy.cps
+..\..\..\bin\Browse /html /sort mscorlib_System_Security_Principal.cps
+..\..\..\bin\Browse /html /sort mscorlib_System_Text.cps
+..\..\..\bin\Browse /html /sort mscorlib_System_Threading.cps
+..\..\..\bin\Browse /html /sort System_.cps
+..\..\..\bin\Browse /html /sort System_Drawing_.cps
+..\..\..\bin\Browse /html /sort System_Drawing__Design.cps
+..\..\..\bin\Browse /html /sort System_Drawing__Drawing2D.cps
+..\..\..\bin\Browse /html /sort System_Drawing__Imaging.cps
+..\..\..\bin\Browse /html /sort System_Drawing__Printing.cps
+..\..\..\bin\Browse /html /sort System_Drawing__Text.cps
+..\..\..\bin\Browse /html /sort System_Microsoft_CSharp.cps
+..\..\..\bin\Browse /html /sort System_Microsoft_VisualBasic.cps
+..\..\..\bin\Browse /html /sort System_Microsoft_Win32.cps
+..\..\..\bin\Browse /html /sort System_Security__Cryptography_Xml.cps
+..\..\..\bin\Browse /html /sort System_Windows_Forms_.cps
+..\..\..\bin\Browse /html /sort System_Windows_Forms_System_Resources.cps
+..\..\..\bin\Browse /html /sort System_Windows_Forms__ComponentModel_Com2Interop.cps
+..\..\..\bin\Browse /html /sort System_Windows_Forms__Design.cps
+..\..\..\bin\Browse /html /sort System_Windows_Forms__PropertyGridInternal.cps
+..\..\..\bin\Browse /html /sort System__CodeDom.cps
+..\..\..\bin\Browse /html /sort System__CodeDom_Compiler.cps
+..\..\..\bin\Browse /html /sort System__Collections_Specialized.cps
+..\..\..\bin\Browse /html /sort System__ComponentModel.cps
+..\..\..\bin\Browse /html /sort System__ComponentModel_Design.cps
+..\..\..\bin\Browse /html /sort System__ComponentModel_Design_Serialization.cps
+..\..\..\bin\Browse /html /sort System__Configuration.cps
+..\..\..\bin\Browse /html /sort System__Diagnostics.cps
+..\..\..\bin\Browse /html /sort System__IO.cps
+..\..\..\bin\Browse /html /sort System__Net.cps
+..\..\..\bin\Browse /html /sort System__Net_Sockets.cps
+..\..\..\bin\Browse /html /sort System__Security_Cryptography_X509Certificates.cps
+..\..\..\bin\Browse /html /sort System__Security_Permissions.cps
+..\..\..\bin\Browse /html /sort System__Text_RegularExpressions.cps
+..\..\..\bin\Browse /html /sort System__Threading.cps
+..\..\..\bin\Browse /html /sort System__Timers.cps
+..\..\..\bin\Browse /html /sort System__Web.cps
+..\..\..\bin\Browse /html /sort System_Xml_.cps
+..\..\..\bin\Browse /html /sort System_Xml__Schema.cps
+..\..\..\bin\Browse /html /sort System_Xml__XPath.cps
+..\..\..\bin\Browse /html /sort System_Xml__Xsl.cps
+..\..\..\bin\Browse /html /sort System_Xml__Serialization.cps
+..\..\..\bin\Browse /html /sort System_Xml__Serialization_Advanced.cps
+..\..\..\bin\Browse /html /sort System_Xml__Serialization_Configuration.cps
+..\..\..\bin\Browse /html /sort System_Data_.cps
+..\..\..\bin\Browse /html /sort System_Data__Common.cps
+..\..\..\bin\Browse /html /sort System_Data__Odbc.cps
+..\..\..\bin\Browse /html /sort System_Data__OleDb.cps
+..\..\..\bin\Browse /html /sort System_Data__SqlClient.cps
+..\..\..\bin\Browse /html /sort System_Data__SqlTypes.cps
+..\..\..\bin\Browse /html /sort System_Data_System_Xml.cps
+..\..\..\bin\Browse /html /sort System_Configuration_.cps
+

gpcp/PeUtil.cp

@@ -0,0 +1,2521 @@
+(* ============================================================ *)
+(*  PeUtil is the module which writes PE files using the        *)
+(*  managed interface.                                          *)
+(*  Copyright (c) John Gough 1999, 2002.                        *)
+(*  Copyright (c) Queensland University of Technology 2002-2006 *)
+(*  This is the PERWAPI-based prototype, March 2005             *)
+(*    previous versions used the PE-file <writer> PEAPI.        *)
+(* ============================================================ *)
+
+MODULE PeUtil;
+
+  IMPORT 
+        GPCPcopyright,
+        RTS, ASCII,
+        Console,
+        GPText,
+        GPBinFiles,
+        GPTextFiles,
+        FileNames,
+        ClassMaker,
+        MsilBase,
+        NameHash,
+        Mu  := MsilUtil,
+        Lv  := LitValue,
+        Sy  := Symbols,
+        Bi  := Builtin,
+        Id  := IdDesc,
+        Ty  := TypeDesc,
+        Api := "[QUT.PERWAPI]QUT.PERWAPI",
+        Scn := CPascalS,
+        Asm := IlasmCodes,
+        CSt := CompState,
+        Sys := "[mscorlib]System";
+
+(* ============================================================ *)
+
+(*
+ * CONST
+ *      (* various ILASM-specific runtime name strings *)
+ *      initPrefix  = "instance void ";
+ *      initSuffix  = ".ctor() ";
+ *      managedStr  = "il managed";
+ *      specialStr  = "public specialname rtspecialname ";
+ *      cctorStr    = "static void .cctor() ";
+ *      objectInit  = "instance void $o::.ctor() ";
+ *
+ * CONST
+ *      catchStr    = "      catch [mscorlib]System.Exception";
+ *)
+
+(* ============================================================ *)
+(* ============================================================ *)
+
+  TYPE PeFile*    = POINTER TO RECORD (Mu.MsilFile)
+                 (*   Fields inherited from MsilFile *
+                  *   srcS* : LitValue.CharOpen; (* source file name   *)
+                  *   outN* : LitValue.CharOpen; (* output file name   *)
+                  *   proc* : ProcInfo;
+                  *)
+                      peFl  : Api.PEFile;          (* Includes AssemblyDef  *)
+                      clsS  : Api.ClassDef;        (* Dummy static ClassDef *)
+                      clsD  : Api.ClassDef;        (* The current ClassDef  *)
+                      pePI  : PProcInfo;
+                      nmSp  : RTS.NativeString;
+                     (*
+                      *  Friendly access for system classes.
+                      *)
+                      rts      : Api.AssemblyRef;  (* "[RTS]"               *)
+                      cprts    : Api.ClassRef;     (* "[RTS]CP_rts"         *)
+                      progArgs : Api.ClassRef;     (* "[RTS]ProgArgs"       *)
+                    END;
+
+(* ============================================================ *)
+
+  TYPE PProcInfo  = POINTER TO RECORD 
+                      mthD  : Api.MethodDef;
+                      code  : Api.CILInstructions;
+                      tryB  : Api.TryBlock;
+                    END;
+
+(* ============================================================ *)
+
+  TYPE PeLab     = POINTER TO RECORD (Mu.Label)
+                      labl : Api.CILLabel;
+                   END;
+
+  TYPE TypArr    = POINTER TO ARRAY OF Api.Type;
+
+(* ============================================================ *)
+
+  VAR   cln2,                           (* "::"     *) 
+        evtAdd,
+        evtRem,
+        boxedObj       : Lv.CharOpen;
+
+(* ============================================================ *)
+
+  VAR   ctAtt,                          (* public + special + RTspecial *)
+        psAtt,                          (* public + static              *)
+        rmAtt,                          (* runtime managed              *)
+        ilAtt          : INTEGER;       (* cil managed                  *)
+
+  VAR   xhrCl          : Api.ClassRef;  (* the [RTS]XHR class reference *)
+        voidD          : Api.Type;      (* Api.PrimitiveType.Void       *)
+        objtD          : Api.Type;      (* Api.PrimitiveType.Object     *)
+        strgD          : Api.Type;      (* Api.PrimitiveType.String     *)
+        charD          : Api.Type;      (* Api.PrimitiveType.Char       *)
+        charA          : Api.Type;      (* Api.PrimitiveType.Char[]     *)
+        int4D          : Api.Type;      (* Api.PrimitiveType.Int32      *)
+        int8D          : Api.Type;      (* Api.PrimitiveType.Int64      *)
+        flt4D          : Api.Type;      (* Api.PrimitiveType.Float32    *)
+        flt8D          : Api.Type;      (* Api.PrimitiveType.Float64    *)
+        nIntD          : Api.Type;      (* Api.PrimitiveType.NativeInt  *)
+
+  VAR   vfldS          : RTS.NativeString;   (* "v$"    *)
+        copyS          : RTS.NativeString;   (* "copy"  *)
+        ctorS          : RTS.NativeString;   (* ".ctor" *)
+        invkS          : RTS.NativeString;   (* Invoke  *)
+        
+  VAR   defSrc : Api.SourceFile;
+
+  VAR   rHelper : ARRAY Mu.rtsLen OF Api.MethodRef;
+        mathCls : Api.ClassRef;
+        envrCls : Api.ClassRef;
+        excpCls : Api.ClassRef;
+        rtTpHdl : Api.ClassRef;
+        loadTyp : Api.MethodRef;
+        newObjt : Api.MethodRef;
+        multiCD : Api.ClassRef;     (* System.MulticastDelegate *)
+        delegat : Api.ClassRef;     (* System.Delegate          *)
+        combine : Api.MethodRef;    (* System.Delegate::Combine *)
+        remove  : Api.MethodRef;    (* System.Delegate::Remove  *)
+        corlib  : Api.AssemblyRef;  (* [mscorlib]               *)
+        
+(* ============================================================ *)
+(*      Data Structure for tgXtn field of BlkId descriptors     *)
+(* ============================================================ *)
+
+  TYPE BlkXtn = POINTER TO RECORD
+                  asmD : Api.AssemblyRef; (* This AssemblyRef   *)
+                  dscD : Api.Class;       (* Dummy Static Class *)
+                END;
+
+(* ============================================================ *)
+(*          Data Structure for Switch Statement Encoding        *)
+(* ============================================================ *)
+
+  TYPE Switch = RECORD
+                  list : POINTER TO ARRAY OF Api.CILLabel;
+                  next : INTEGER;
+                END;
+
+  VAR  switch : Switch;
+
+(* ============================================================ *)
+(*      Data Structure for tgXtn field of procedure types       *)
+(* ============================================================ *)
+
+  TYPE DelXtn = POINTER TO RECORD
+                  clsD : Api.Class;      (* Implementing class  *)
+                  newD : Api.Method;     (* Constructor method  *)
+                  invD : Api.Method;     (* The Invoke method   *)
+                END;
+
+(* ============================================================ *)
+(*      Data Structure for tgXtn field of event variables       *)
+(* ============================================================ *)
+
+  TYPE EvtXtn = POINTER TO RECORD
+                  fldD : Api.Field;      (* Field descriptor    *)
+                  addD : Api.Method;     (* add_<field> method  *)
+                  remD : Api.Method;     (* rem_<field> method  *)
+                END;
+
+(* ============================================================ *)
+(*      Data Structure for tgXtn field of Record types          *)
+(* ============================================================ *)
+
+  TYPE RecXtn = POINTER TO RECORD
+                  clsD : Api.Class;
+                  boxD : Api.Class;
+                  newD : Api.Method;
+                  cpyD : Api.Method;
+                  vDlr : Api.Field;
+                END;
+
+(* ============================================================ *)
+(*                    Constructor Method                        *)
+(* ============================================================ *)
+
+  PROCEDURE newPeFile*(IN nam : ARRAY OF CHAR; isDll : BOOLEAN) : PeFile;
+    VAR f : PeFile;
+        ver : INTEGER;
+   (* ------------------------------------------------------- *)
+    PROCEDURE file(IN f,a : ARRAY OF CHAR; d : BOOLEAN) : Api.PEFile;
+      VAR pef : Api.PEFile;
+    BEGIN 
+      pef := Api.PEFile.init(MKSTR(f), MKSTR(a));
+      pef.SetIsDLL(d);
+      IF CSt.binDir # "" THEN
+        pef.SetOutputDirectory(MKSTR(CSt.binDir));
+      END;
+      RETURN pef;
+    RESCUE (x) 
+      RETURN NIL;
+    END file;
+   (* ------------------------------------------------------- *)
+  BEGIN
+    NEW(f);
+(*
+ *  f.peFl := file(nam, isDll);
+ *)
+    IF isDll THEN
+      f.outN := BOX(nam + ".DLL");
+    ELSE
+      f.outN := BOX(nam + ".EXE");
+    END;
+(* -- start replacement -- *)
+    f.peFl := file(f.outN, nam, isDll);
+(* --- end replacement --- *)
+   (*
+    *  Initialize local variables holding common attributes.
+    *)
+    ctAtt := Api.MethAttr.Public + Api.MethAttr.SpecialRTSpecialName;
+    psAtt := Api.MethAttr.Public + Api.MethAttr.Static;
+    ilAtt := Api.ImplAttr.IL;
+    rmAtt := Api.ImplAttr.Runtime;
+   (*
+    *  Initialize local variables holding primitive type-enums.
+    *)
+    voidD := Api.PrimitiveType.Void;
+    objtD := Api.PrimitiveType.Object;
+    strgD := Api.PrimitiveType.String;
+    int4D := Api.PrimitiveType.Int32;
+    int8D := Api.PrimitiveType.Int64;
+    flt4D := Api.PrimitiveType.Float32;
+    flt8D := Api.PrimitiveType.Float64;
+    charD := Api.PrimitiveType.Char;
+    charA := Api.ZeroBasedArray.init(Api.PrimitiveType.Char);
+    nIntD := Api.PrimitiveType.IntPtr;
+
+    f.peFl.SetNetVersion(Api.NetVersion.Version2);
+
+    (*ver := f.peFl.GetNetVersion();*)
+
+    RETURN f;
+  END newPeFile;
+
+(* ============================================================ *)
+
+  PROCEDURE (t : PeFile)fileOk*() : BOOLEAN;
+  BEGIN
+    RETURN t.peFl # NIL;
+  END fileOk;
+
+(* ============================================================ *)
+
+  PROCEDURE (os : PeFile)MkNewProcInfo*(proc : Sy.Scope);
+    VAR p : PProcInfo;
+  BEGIN
+    NEW(os.proc);
+    NEW(os.pePI);
+    Mu.InitProcInfo(os.proc, proc);
+  END MkNewProcInfo;
+
+(* ============================================================ *)
+
+  PROCEDURE (os : PeFile)newLabel*() : Mu.Label;
+    VAR label : PeLab;
+  BEGIN
+    NEW(label); 
+    label.labl := os.pePI.code.NewLabel();
+    RETURN label;
+  END newLabel;
+
+(* ============================================================ *)
+(*                    Various utilities                         *)
+(* ============================================================ *)
+
+  PROCEDURE^ (os : PeFile)CallCombine(typ : Sy.Type; add : BOOLEAN),NEW;
+  PROCEDURE^ (os : PeFile)CodeLb*(code : INTEGER; labl : Mu.Label);
+  PROCEDURE^ (os : PeFile)DefLabC*(l : Mu.Label; IN c : ARRAY OF CHAR);
+  PROCEDURE^ (os : PeFile)Locals(),NEW;
+
+  PROCEDURE^ MkMthDef(os  : PeFile;
+                      xhr : BOOLEAN;
+                      pTp : Ty.Procedure;
+                      cls : Api.ClassDef;
+                      str : RTS.NativeString)  : Api.MethodDef;
+
+  PROCEDURE^ MkMthRef(os  : PeFile;
+                      pTp : Ty.Procedure;
+                      cls : Api.ClassRef;
+                      str : RTS.NativeString) : Api.MethodRef;
+
+  PROCEDURE^ (os : PeFile)mth(pId : Id.Procs)  : Api.Method,NEW;
+  PROCEDURE^ (os : PeFile)fld(fId : Id.AbVar)  : Api.Field,NEW;
+  PROCEDURE^ (os : PeFile)add(fId : Id.AbVar)  : Api.Method,NEW;
+  PROCEDURE^ (os : PeFile)rem(fId : Id.AbVar)  : Api.Method,NEW;
+  PROCEDURE^ (os : PeFile)asm(bId : Id.BlkId)  : Api.AssemblyRef,NEW;
+  PROCEDURE^ (os : PeFile)dsc(bId : Id.BlkId)  : Api.Class,NEW;
+  PROCEDURE^ (os : PeFile)cls(rTy : Ty.Record) : Api.Class,NEW;
+  PROCEDURE^ (os : PeFile)new(rTy : Ty.Record) : Api.Method,NEW;
+  PROCEDURE^ (os : PeFile)cpy(rTy : Ty.Record) : Api.Method,NEW;
+  PROCEDURE^ (os : PeFile)typ(tTy : Sy.Type)   : Api.Type,NEW;
+  PROCEDURE^ (os : PeFile)vDl(rTy : Ty.Record) : Api.Field,NEW;
+  PROCEDURE^ (os : PeFile)dxt(pTy : Ty.Procedure) : DelXtn,NEW;
+  PROCEDURE^ (os : PeFile)mcd() : Api.ClassRef,NEW;
+  PROCEDURE^ (os : PeFile)rmv() : Api.MethodRef,NEW;
+  PROCEDURE^ (os : PeFile)cmb() : Api.MethodRef,NEW;
+(*
+ *  PROCEDURE^ box(os : PeFile; rTy : Ty.Record) : Api.Class;
+ *)
+(* ============================================================ *)
+(*                    Private Methods                        *)
+(* ============================================================ *)
+
+  PROCEDURE boxedName(typ : Ty.Record) : RTS.NativeString;
+  BEGIN
+    ASSERT(typ.xName # NIL);
+    RETURN MKSTR(boxedObj^ + typ.xName^);
+  END boxedName;
+
+(* ============================================================ *)
+
+  PROCEDURE nms(idD : Sy.Idnt) : RTS.NativeString;
+  BEGIN
+    RETURN MKSTR(Sy.getName.ChPtr(idD)^);
+  END nms;
+
+(* ============================================================ *)
+
+  PROCEDURE toTypeAttr(attr : SET) : INTEGER;
+    VAR result : INTEGER;
+  BEGIN
+    CASE ORD(attr * {0 .. 3}) OF
+    | ORD(Asm.att_public)  : result := Api.TypeAttr.Public;
+    | ORD(Asm.att_empty)   : result := Api.TypeAttr.Private;
+    END;
+    IF attr * Asm.att_sealed # {}    THEN 
+      INC(result, Api.TypeAttr.Sealed);
+    END;
+    IF attr * Asm.att_abstract # {}  THEN 
+      INC(result, Api.TypeAttr.Abstract);
+    END;
+    IF attr * Asm.att_interface # {} THEN 
+      INC(result, Api.TypeAttr.Interface + Api.TypeAttr.Abstract);
+    END;
+(*
+ *  what are "Import, AutoClass, UnicodeClass, *SpecialName" ? 
+ *)
+    RETURN result;
+  END toTypeAttr;
+
+  
+(* ------------------------------------------------ *)
+(*              New code for PERWAPI                *)
+(* ------------------------------------------------ *)
+
+  PROCEDURE getOrAddClass(mod : Api.ReferenceScope; 
+                          nms : RTS.NativeString;
+                          nam : RTS.NativeString) : Api.ClassRef;
+    VAR cls : Api.Class;
+  BEGIN
+    cls := mod.GetClass(nms, nam);
+    IF cls = NIL THEN cls := mod.AddClass(nms, nam) END;
+    RETURN cls(Api.ClassRef);
+  END getOrAddClass;
+
+  PROCEDURE getOrAddValueClass(mod : Api.ReferenceScope; 
+                               nms : RTS.NativeString;
+                               nam : RTS.NativeString) : Api.ClassRef;
+    VAR cls : Api.Class;
+  BEGIN
+    cls := mod.GetClass(nms, nam);
+    IF cls = NIL THEN cls := mod.AddValueClass(nms, nam) END;
+    RETURN cls(Api.ClassRef);
+  END getOrAddValueClass;
+
+  PROCEDURE getOrAddMethod(cls : Api.ClassRef; 
+                           nam : RTS.NativeString;
+                           ret : Api.Type;
+                           prs : TypArr) : Api.MethodRef;
+    VAR mth : Api.Method;
+  BEGIN
+    mth := cls.GetMethod(nam, prs);
+    IF mth = NIL THEN mth := cls.AddMethod(nam, ret, prs) END;
+    RETURN mth(Api.MethodRef);
+  END getOrAddMethod;
+
+  PROCEDURE getOrAddField(cls : Api.ClassRef; 
+                          nam : RTS.NativeString;
+                          typ : Api.Type) : Api.FieldRef;
+    VAR fld : Api.FieldRef;
+  BEGIN
+    fld := cls.GetField(nam);
+    IF fld = NIL THEN fld := cls.AddField(nam, typ) END;
+    RETURN fld(Api.FieldRef);
+  END getOrAddField;
+
+(* ------------------------------------------------ *)
+
+  PROCEDURE toMethAttr(attr : SET) : INTEGER;
+    VAR result : INTEGER;
+  BEGIN
+    CASE ORD(attr * {0 .. 3}) OF
+    | ORD(Asm.att_assembly)  : result := Api.MethAttr.Assembly;
+    | ORD(Asm.att_public)    : result := Api.MethAttr.Public;
+    | ORD(Asm.att_private)   : result := Api.MethAttr.Private;
+    | ORD(Asm.att_protected) : result := Api.MethAttr.Family;
+    END;
+    IF  5 IN attr THEN INC(result, Api.MethAttr.Static) END;
+    IF  6 IN attr THEN INC(result, Api.MethAttr.Final) END;
+    IF  8 IN attr THEN INC(result, Api.MethAttr.Abstract) END;
+    IF  9 IN attr THEN INC(result, Api.MethAttr.NewSlot) END;
+    IF 13 IN attr THEN INC(result, Api.MethAttr.Virtual) END;
+    RETURN result;
+  END toMethAttr;
+
+(* ------------------------------------------------ *)
+
+  PROCEDURE toFieldAttr(attr : SET) : INTEGER;
+    VAR result : INTEGER;
+  BEGIN
+    CASE ORD(attr * {0 .. 3}) OF
+    | ORD(Asm.att_empty)     : result := Api.FieldAttr.Default;
+    | ORD(Asm.att_assembly)  : result := Api.FieldAttr.Assembly;
+    | ORD(Asm.att_public)    : result := Api.FieldAttr.Public;
+    | ORD(Asm.att_private)   : result := Api.FieldAttr.Private;
+    | ORD(Asm.att_protected) : result := Api.FieldAttr.Family;
+    END;
+    IF  5 IN attr THEN INC(result, Api.FieldAttr.Static) END;
+   (* what about Initonly? *)
+    RETURN result;
+  END toFieldAttr;
+
+(* ------------------------------------------------ *)
+
+  PROCEDURE (os : PeFile)MkCodeBuffer(),NEW;
+  BEGIN
+    ASSERT((defSrc # NIL) & (os.pePI.mthD # NIL));
+    os.pePI.code := os.pePI.mthD.CreateCodeBuffer();
+    os.pePI.code.OpenScope();
+    os.pePI.code.set_DefaultSourceFile(defSrc);
+  END MkCodeBuffer;
+
+(* ============================================================ *)
+(*                    Exported Methods                  *)
+(* ============================================================ *)
+
+  PROCEDURE (os : PeFile)MethodDecl*(attr : SET; proc : Id.Procs);
+    VAR prcT : Ty.Procedure; (* NOT NEEDED? *)
+        prcD : Api.MethodDef;
+  BEGIN
+   (*
+    *   Set the various attributes
+    *)
+    prcD := os.mth(proc)(Api.MethodDef);
+    prcD.AddMethAttribute(toMethAttr(attr));
+    prcD.AddImplAttribute(ilAtt);
+    os.pePI.mthD := prcD;
+    IF attr * Asm.att_abstract = {} THEN os.MkCodeBuffer() END;
+  END MethodDecl;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE (os : PeFile)DoExtern(blk : Id.BlkId),NEW;
+ (*
+  *  Add references to all imported assemblies.
+  *)
+    VAR  asmRef  : Api.AssemblyRef;
+         blkXtn  : BlkXtn;
+   (* ----------------------------------------- *)
+    PROCEDURE AsmName(bk : Id.BlkId) : Lv.CharOpen;
+      VAR ix : INTEGER;
+          ln : INTEGER;
+          ch : CHAR;
+          cp : Lv.CharOpen;
+    BEGIN
+      IF Sy.isFn IN bk.xAttr THEN
+        ln := 0;
+        FOR ix := LEN(bk.scopeNm) - 1 TO 1 BY -1 DO
+          IF bk.scopeNm[ix] = "]" THEN ln := ix END;
+        END;
+        IF (ln = 0 ) OR (bk.scopeNm[0] # '[') THEN 
+                          RTS.Throw("bad extern name "+bk.scopeNm^) END;
+        NEW(cp, ln);
+        FOR ix := 1 TO ln-1 DO cp[ix-1] := bk.scopeNm[ix] END;
+        cp[ln-1] := 0X;
+        RETURN cp;
+      ELSE
+        RETURN bk.xName;
+      END;
+    END AsmName;
+   (* ----------------------------------------- *)
+    PROCEDURE MkBytes(t1, t2 : INTEGER) : POINTER TO ARRAY OF UBYTE;
+      VAR bIx : INTEGER;
+          tok : POINTER TO ARRAY OF UBYTE;
+    BEGIN [UNCHECKED_ARITHMETIC]
+      NEW(tok, 8);
+      FOR bIx := 3 TO 0 BY -1 DO
+        tok[bIx] := USHORT(t1 MOD 256);
+        t1 := t1 DIV 256;
+      END;
+      FOR bIx := 7 TO 4 BY -1 DO
+        tok[bIx] := USHORT(t2 MOD 256);
+        t2 := t2 DIV 256;
+      END;
+      RETURN tok;
+    END MkBytes;
+   (* ----------------------------------------- *)
+  BEGIN
+    IF blk.xName = NIL THEN Mu.MkBlkName(blk) END;
+    asmRef := os.peFl.MakeExternAssembly(MKSTR(AsmName(blk)^));
+    NEW(blkXtn);
+    blk.tgXtn := blkXtn;
+    blkXtn.asmD := asmRef;
+    blkXtn.dscD := getOrAddClass(asmRef, 
+                                 MKSTR(blk.pkgNm^), 
+                                 MKSTR(blk.clsNm^));
+    IF blk.verNm # NIL THEN
+      asmRef.AddVersionInfo(blk.verNm[0], blk.verNm[1], 
+                            blk.verNm[2], blk.verNm[3]);
+      IF (blk.verNm[4] # 0) OR (blk.verNm[5] # 0) THEN
+        asmRef.AddKeyToken(MkBytes(blk.verNm[4], blk.verNm[5]));
+      END;
+    END;
+  END DoExtern;
+
+(* ============================================================ *)
+
+  PROCEDURE (os : PeFile)DoRtsMod(blk : Id.BlkId),NEW;
+ (*
+  *  Add references to all imported assemblies.
+  *)
+    VAR blkD : BlkXtn;
+  BEGIN
+    IF blk.xName = NIL THEN Mu.MkBlkName(blk) END;
+    NEW(blkD);
+    blkD.asmD := os.rts;
+    blkD.dscD := os.rts.AddClass("", MKSTR(blk.clsNm^));
+    blk.tgXtn := blkD;
+  END DoRtsMod;
+
+(* ============================================================ *)
+
+  PROCEDURE (os : PeFile)CheckNestedClass*(typ : Ty.Record;
+                                           scp : Sy.Scope;
+                                           str : Lv.CharOpen);
+    VAR len : INTEGER;
+        idx : INTEGER;
+        jdx : INTEGER;
+        kdx : INTEGER;
+        hsh : INTEGER;
+        tId : Sy.Idnt;
+  BEGIN
+   (* 
+    *  Find last occurrence of '$', except at index 0  
+    *  
+    *  We seek the last occurrence because this method might
+    *  be called recursively for a deeply nested class A$B$C.
+    *)
+    len := LEN(str$); (* LEN(x$) doen't count nul, therefore str[len] = 0X *)
+    FOR idx := len TO 1 BY -1 DO
+      IF str[idx] = '$' THEN (* a nested class *)
+        str[idx] := 0X; (* terminate the string early *)
+        hsh := NameHash.enterStr(str);
+        tId := Sy.bind(hsh, scp);
+        
+        IF (tId = NIL) OR ~(tId IS Id.TypId) THEN 
+          RTS.Throw(
+             "Foreign Class <" + str^ + "> not found in <" + typ.extrnNm^ + ">"
+          );
+        ELSE
+          typ.encCls := tId.type.boundRecTp();
+          jdx := 0; kdx := idx+1;
+          WHILE kdx <= len DO str[jdx] := str[kdx]; INC(kdx); INC(jdx) END;
+        END;
+        RETURN;
+      END;
+    END;
+  END CheckNestedClass;
+
+(* ============================================================ *)
+
+  PROCEDURE (os : PeFile)ExternList*();
+    VAR idx : INTEGER;
+        blk : Id.BlkId;
+  BEGIN
+    FOR idx := 0 TO CSt.impSeq.tide-1 DO
+      blk := CSt.impSeq.a[idx](Id.BlkId);
+      IF (Sy.need IN blk.xAttr)  &
+         (blk.tgXtn = NIL) THEN 
+        IF ~(Sy.rtsMd IN blk.xAttr) THEN 
+          os.DoExtern(blk);
+        ELSE
+          os.DoRtsMod(blk);
+        END;
+      END;
+    END;
+  END ExternList;
+
+(* ============================================================ *)
+
+  PROCEDURE (os : PeFile)DefLab*(l : Mu.Label);
+  BEGIN
+    os.pePI.code.CodeLabel(l(PeLab).labl);
+  END DefLab;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE (os : PeFile)DefLabC*(l : Mu.Label; IN c : ARRAY OF CHAR);
+  BEGIN
+    os.pePI.code.CodeLabel(l(PeLab).labl);
+  END DefLabC;
+
+(* ============================================================ *)
+
+  PROCEDURE (os : PeFile)Code*(code : INTEGER);
+  BEGIN
+    os.pePI.code.Inst(Asm.cd[code]);
+    os.Adjust(Asm.dl[code]);
+  END Code;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE (os : PeFile)CodeF(code : INTEGER;
+                               fld  : Api.Field), NEW;
+  BEGIN
+    os.pePI.code.FieldInst(Asm.cd[code], fld);
+    os.Adjust(Asm.dl[code]);
+  END CodeF;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE (os : PeFile)CodeI*(code,int : INTEGER);
+  BEGIN
+    os.pePI.code.IntInst(Asm.cd[code],int);
+    os.Adjust(Asm.dl[code]);
+  END CodeI;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE (os : PeFile)CodeT*(code : INTEGER; type : Sy.Type);
+    VAR xtn : Api.Type;
+  BEGIN
+    xtn := os.typ(type);
+    os.pePI.code.TypeInst(Asm.cd[code], xtn);
+    os.Adjust(Asm.dl[code]);
+  END CodeT;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE (os : PeFile)CodeTn*(code : INTEGER; type : Sy.Type);
+    VAR xtn : Api.Type;
+  BEGIN
+    xtn := os.typ(type);
+    os.pePI.code.TypeInst(Asm.cd[code], xtn);
+    os.Adjust(Asm.dl[code]);
+  END CodeTn;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE (os : PeFile)CodeL*(code : INTEGER; long : LONGINT);
+  BEGIN
+    ASSERT(code = Asm.opc_ldc_i8);
+    os.pePI.code.ldc_i8(long);
+    os.Adjust(1);
+  END CodeL;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE (os : PeFile)CodeR*(code : INTEGER; real : REAL);
+  BEGIN
+    IF code = Asm.opc_ldc_r8 THEN
+      os.pePI.code.ldc_r8(real);
+    ELSIF code = Asm.opc_ldc_r4 THEN
+      os.pePI.code.ldc_r4(SHORT(real));
+    ELSE
+      ASSERT(FALSE);
+    END;
+    os.Adjust(1);
+  END CodeR;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE (os : PeFile)CodeLb*(code : INTEGER; labl : Mu.Label);
+  BEGIN
+    os.pePI.code.Branch(Asm.cd[code], labl(PeLab).labl);
+  END CodeLb;
+
+(* ============================================================ *)
+
+  PROCEDURE (os : PeFile)getMethod(s : INTEGER) : Api.Method,NEW;
+    VAR  mth : Api.MethodRef;
+         cpr : Api.ClassRef;
+         msc : Api.ClassRef;
+         sys : Api.ClassRef;
+  (* ----------------------------------- *)
+    PROCEDURE p1(p : Api.Type) : TypArr;
+      VAR a : TypArr;
+    BEGIN
+      NEW(a,1);
+      a[0] := p;
+      RETURN a;
+    END p1;
+  (* ----------------------------------- *)
+    PROCEDURE p2(p,q : Api.Type) : TypArr;
+      VAR a : TypArr;
+    BEGIN
+      NEW(a,2);
+      a[0] := p;
+      a[1] := q;
+      RETURN a;
+    END p2;
+  (* ----------------------------------- *)
+  BEGIN
+   (*
+    *  Lazy evaluation of array elements
+    *)
+    mth := rHelper[s];
+    IF mth = NIL THEN
+      cpr := os.cprts;
+      CASE s OF
+      | Mu.vStr2ChO  : mth := cpr.AddMethod("strToChO",charA,p1(strgD));
+      | Mu.vStr2ChF  : mth := cpr.AddMethod("StrToChF",voidD,p2(charA,strgD));
+      | Mu.aStrLen   : mth := cpr.AddMethod("chrArrLength",int4D,p1(charA));
+      | Mu.aStrChk   : mth := cpr.AddMethod("ChrArrCheck",voidD,p1(charA));
+      | Mu.aStrLp1   : mth := cpr.AddMethod("chrArrLplus1",int4D,p1(charA));
+      | Mu.aaStrCmp  : mth := cpr.AddMethod("strCmp",int4D,p2(charA,charA));
+      | Mu.aaStrCopy : mth := cpr.AddMethod("Stringify",voidD,p2(charA,charA));
+      | Mu.CpModI    : mth := cpr.AddMethod("CpModI",int4D,p2(int4D,int4D));
+      | Mu.CpDivI    : mth := cpr.AddMethod("CpDivI",int4D,p2(int4D,int4D));
+      | Mu.CpModL    : mth := cpr.AddMethod("CpModL",int8D,p2(int8D,int8D));
+      | Mu.CpDivL    : mth := cpr.AddMethod("CpDivL",int8D,p2(int8D,int8D));
+      | Mu.caseMesg  : mth := cpr.AddMethod("caseMesg",strgD,p1(int4D));
+      | Mu.withMesg  : mth := cpr.AddMethod("withMesg",strgD,p1(objtD));
+      | Mu.chs2Str   : mth :=  cpr.AddMethod("mkStr",strgD,p1(charA));
+      | Mu.CPJstrCatAA : mth := cpr.AddMethod("aaToStr",strgD,p2(charA,charA));
+      | Mu.CPJstrCatSA : mth := cpr.AddMethod("saToStr",strgD,p2(strgD,charA));
+      | Mu.CPJstrCatAS : mth := cpr.AddMethod("asToStr",strgD,p2(charA,strgD));
+      | Mu.CPJstrCatSS : mth := cpr.AddMethod("ssToStr",strgD,p2(strgD,strgD));
+
+      | Mu.toUpper   :  sys := getOrAddClass(corlib, "System", "Char");
+                        mth := getOrAddMethod(sys,"ToUpper",charD,p1(charD));
+
+      | Mu.sysExit   :  IF envrCls = NIL THEN
+                          envrCls := 
+                               getOrAddClass(corlib, "System", "Environment");
+                        END;
+                        mth := getOrAddMethod(envrCls,"Exit",voidD,p1(int4D));
+
+      | Mu.mkExcept  :  IF excpCls = NIL THEN
+                          IF CSt.ntvExc.tgXtn = NIL THEN
+                            excpCls := 
+                                  getOrAddClass(corlib, "System", "Exception");
+                            CSt.ntvExc.tgXtn := excpCls;
+                          ELSE
+                            excpCls := CSt.ntvExc.tgXtn(Api.ClassRef);
+                          END;
+                        END;
+                        sys := CSt.ntvExc.tgXtn(Api.ClassRef);
+(*
+ *                      mth := sys.AddMethod(ctorS,voidD,p1(strgD));
+ *)
+                        mth := getOrAddMethod(sys,ctorS,voidD,p1(strgD));
+                        mth.AddCallConv(Api.CallConv.Instance);
+
+      | Mu.getTpM    :  IF CSt.ntvTyp.tgXtn = NIL THEN
+                          CSt.ntvTyp.tgXtn := 
+                                  getOrAddClass(corlib, "System", "Type");
+                        END;
+                        sys := CSt.ntvTyp.tgXtn(Api.ClassRef);
+                        mth := getOrAddMethod(sys,"GetType",sys,NIL);
+                        mth.AddCallConv(Api.CallConv.Instance);
+
+      | Mu.dFloor, Mu.dAbs, Mu.fAbs, Mu.iAbs, Mu.lAbs :
+          IF mathCls = NIL THEN
+            mathCls := getOrAddClass(corlib, "System", "Math");
+          END;
+          rHelper[Mu.dFloor] := getOrAddMethod(mathCls,"Floor",flt8D,p1(flt8D));
+          rHelper[Mu.dAbs]   := getOrAddMethod(mathCls,"Abs",flt8D,p1(flt8D));
+          rHelper[Mu.fAbs]   := getOrAddMethod(mathCls,"Abs",flt4D,p1(flt4D));
+          rHelper[Mu.iAbs]   := getOrAddMethod(mathCls,"Abs",int4D,p1(int4D));
+          rHelper[Mu.lAbs]   := getOrAddMethod(mathCls,"Abs",int8D,p1(int8D));
+          mth := rHelper[s];
+      END;
+      rHelper[s] := mth;
+    END;
+    RETURN mth;
+  END getMethod;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE (os : PeFile)StaticCall*(s : INTEGER; d : INTEGER);
+    VAR mth : Api.Method;
+  BEGIN
+    mth := os.getMethod(s);
+    os.pePI.code.MethInst(Asm.cd[Asm.opc_call], mth);
+    os.Adjust(d);
+  END StaticCall;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE (os : PeFile)CodeS*(code : INTEGER; str : INTEGER);
+    VAR mth : Api.Method;
+  BEGIN
+    mth := os.getMethod(str);
+    os.pePI.code.MethInst(Asm.cd[code], mth);
+  END CodeS;
+
+(* ============================================================ *)
+
+  PROCEDURE (os : PeFile)Try*();
+    VAR retT : Sy.Type;
+  BEGIN
+    os.proc.exLb := os.newLabel();
+    retT := os.proc.prId.type.returnType();
+    IF retT # NIL THEN os.proc.rtLc := os.proc.newLocal(retT) END;
+    os.pePI.code.StartBlock();
+  END Try;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE (os : PeFile)Catch*(proc : Id.Procs);
+  BEGIN
+    os.pePI.tryB := os.pePI.code.EndTryBlock();
+    os.pePI.code.StartBlock();
+    os.Adjust(1);	(* allow for incoming exception reference *)
+    os.StoreLocal(proc.except.varOrd);
+  END Catch;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE (os : PeFile)CloseCatch*();
+  BEGIN
+    IF excpCls = NIL THEN
+      IF CSt.ntvExc.tgXtn = NIL THEN
+        excpCls := getOrAddClass(corlib, "System", "Exception");
+        CSt.ntvExc.tgXtn := excpCls;
+      ELSE
+        excpCls := CSt.ntvExc.tgXtn(Api.ClassRef);
+      END;
+    END;
+    os.pePI.code.EndCatchBlock(excpCls, os.pePI.tryB);
+  END CloseCatch;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE (os : PeFile)CopyCall*(typ : Ty.Record);
+  BEGIN
+    os.pePI.code.MethInst(Asm.cd[Asm.opc_call], os.cpy(typ));
+    os.Adjust(-2);
+  END CopyCall;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE (os : PeFile)PushStr*(IN str : ARRAY OF CHAR);
+  (* Use target quoting conventions for the literal string *)
+  BEGIN
+    os.pePI.code.ldstr(MKSTR(str));
+    os.Adjust(1);
+  END PushStr;
+
+(* ============================================================ *)
+
+  PROCEDURE (os : PeFile)CallIT*(code : INTEGER; 
+                                 proc : Id.Procs; 
+                                 type : Ty.Procedure);
+    VAR xtn : Api.Method;
+  BEGIN
+    xtn := os.mth(proc);
+    os.pePI.code.MethInst(Asm.cd[code], xtn);
+    os.Adjust(type.retN - type.argN);        
+  END CallIT;
+
+(* ============================================================ *)
+
+  PROCEDURE (os : PeFile)CallCT*(proc : Id.Procs; 
+                                 type : Ty.Procedure);
+    VAR xtn : Api.Method;
+  BEGIN
+    ASSERT(proc.tgXtn # NIL);
+    xtn := proc.tgXtn(Api.Method);
+    os.pePI.code.MethInst(Asm.cd[Asm.opc_newobj], xtn);
+    os.Adjust(-type.argN);        
+  END CallCT;
+
+(* ============================================================ *)
+
+  PROCEDURE (os : PeFile)CallDelegate*(typ : Ty.Procedure);
+    VAR xtn : Api.Method;
+  BEGIN
+    ASSERT(typ.tgXtn # NIL);
+(*
+ *  xtn := typ.tgXtn(DelXtn).invD;
+ *)
+    xtn := os.dxt(typ).invD;
+    os.pePI.code.MethInst(Asm.cd[Asm.opc_callvirt], xtn);
+    os.Adjust(-typ.argN + typ.retN);        
+  END CallDelegate;
+
+(* ============================================================ *)
+
+  PROCEDURE (os : PeFile)PutGetS*(code : INTEGER;
+                                  blk  : Id.BlkId;
+                                  fId  : Id.VarId);
+  (* Emit putstatic and getstatic for static field *)
+  BEGIN
+    os.pePI.code.FieldInst(Asm.cd[code], os.fld(fId));
+    os.Adjust(Asm.dl[code]);
+  END PutGetS;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE (os : PeFile)GetValObj*(code : INTEGER; ptrT : Ty.Pointer);
+    VAR rTp : Ty.Record;
+  BEGIN
+    rTp := ptrT.boundRecTp()(Ty.Record);
+    os.pePI.code.FieldInst(Asm.cd[code], os.vDl(rTp));
+    os.Adjust(Asm.dl[code]);
+  END GetValObj;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE (os : PeFile)PutGetXhr*(code : INTEGER; 
+                                    proc : Id.Procs; 
+                                    locl : Id.LocId);
+    VAR ix   : INTEGER;
+        name : Lv.CharOpen;
+        recT : Ty.Record;
+        fldI : Id.FldId;
+  BEGIN
+    ix := 0;
+    recT := proc.xhrType.boundRecTp()(Ty.Record);
+    WHILE recT.fields.a[ix].hash # locl.hash DO INC(ix) END;;
+    os.pePI.code.FieldInst(Asm.cd[code], os.fld(recT.fields.a[ix](Id.FldId)));
+  END PutGetXhr;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE (os : PeFile)PutGetF*(code : INTEGER;
+                                  fId  : Id.FldId);
+  BEGIN
+    os.pePI.code.FieldInst(Asm.cd[code], os.fld(fId));
+    os.Adjust(Asm.dl[code]);
+  END PutGetF;
+
+(* ============================================================ *)
+(* ============================================================ *)
+
+  PROCEDURE (os : PeFile)MkNewRecord*(typ : Ty.Record);
+    CONST code = Asm.opc_newobj;
+    VAR   name : Lv.CharOpen;
+  BEGIN
+   (*
+    *  We need "newobj instance void <name>::.ctor()"
+    *)
+    os.pePI.code.MethInst(Asm.cd[code], os.new(typ));
+    os.Adjust(1);
+  END MkNewRecord;
+
+(* ============================================================ *)
+(* ============================================================ *)
+
+  PROCEDURE (os : PeFile)MkNewProcVal*(p : Sy.Idnt;   (* src Proc *)
+                                       t : Sy.Type);  (* dst Type *)
+    VAR ctor : Api.Method;
+        ldfi : INTEGER;
+        pTyp : Ty.Procedure;
+        proc : Id.Procs;
+  BEGIN
+(*
+ *  ctor := t.tgXtn(DelXtn).newD;
+ *)
+    proc := p(Id.Procs);
+    pTyp := t(Ty.Procedure);
+    ctor := os.dxt(pTyp).newD;
+   (*
+    *  We need "ldftn [instance] <retType> <procName>
+    *)
+    WITH p : Id.MthId DO
+      IF p.bndType.isInterfaceType() THEN
+        ldfi := Asm.opc_ldvirtftn;
+      ELSIF p.mthAtt * Id.mask = Id.final THEN
+        ldfi := Asm.opc_ldftn;
+      ELSE
+        ldfi := Asm.opc_ldvirtftn;
+      END;
+    ELSE
+      ldfi := Asm.opc_ldftn;
+    END;
+   (*
+    *  These next are needed for imported events
+    *)
+    Mu.MkProcName(proc, os);
+    os.NumberParams(proc, pTyp);
+   (*
+    *   If this will be a virtual method call, then we
+    *   must duplicate the receiver, since the call of
+    *   ldvirtftn uses up one copy.
+    *)
+    IF ldfi = Asm.opc_ldvirtftn THEN os.Code(Asm.opc_dup) END;
+    os.pePI.code.MethInst(Asm.cd[ldfi], os.mth(proc));
+    os.Adjust(1);
+   (*
+    *  Now we need "newobj instance void <name>::.ctor(...)"
+    *)
+    os.pePI.code.MethInst(Asm.cd[Asm.opc_newobj], ctor);
+    os.Adjust(-2);
+  END MkNewProcVal;
+
+(* ============================================================ *)
+
+  PROCEDURE (os : PeFile)CallSuper*(rTp : Ty.Record;
+                                    prc : Id.PrcId);
+    VAR pNm : INTEGER;
+        spr : Api.Method;
+  (* ---------------------------------------- *)
+    PROCEDURE getSuperCtor(os  : PeFile; 
+                           rTp : Ty.Record; 
+                           prc : Id.Procs) : Api.Method;
+      VAR bas : Ty.Record;
+          pTp : Ty.Procedure;
+          bcl : Api.Class;
+          mth : Api.Method;
+    BEGIN
+      bas := rTp.superType();
+      IF prc # NIL THEN
+       (*
+        *  This constructor has arguments.
+        *  The super constructor is prc.basCll.sprCtor
+        *)
+        pTp := prc.type(Ty.Procedure);
+        IF prc.tgXtn = NIL THEN
+          bcl := os.cls(bas);
+          WITH bcl : Api.ClassDef DO
+              mth := MkMthDef(os, FALSE, pTp, bcl, ctorS);
+              mth(Api.MethodDef).AddMethAttribute(ctAtt);
+          | bcl : Api.ClassRef DO
+              mth := MkMthRef(os, pTp, bcl, ctorS);
+          END;
+          mth.AddCallConv(Api.CallConv.Instance);
+          prc.tgXtn := mth;
+          RETURN mth;
+        ELSE
+          RETURN prc.tgXtn(Api.Method);
+        END;
+      ELSIF (bas # NIL) & (rTp.baseTp # Bi.anyRec) THEN
+       (*
+        * This is the explicit noarg constructor of the supertype.
+        *)
+        RETURN os.new(bas);
+      ELSE
+       (*
+        *  This is System.Object::.ctor()
+        *)
+        RETURN newObjt;
+      END;
+    END getSuperCtor;
+  (* ---------------------------------------- *)
+  BEGIN
+    IF prc # NIL THEN 
+      pNm := prc.type(Ty.Procedure).formals.tide;
+    ELSE 
+      pNm := 0;
+    END;
+    spr := getSuperCtor(os, rTp, prc);
+    os.pePI.code.MethInst(Asm.cd[Asm.opc_call], spr);
+    os.Adjust(-(pNm+1));
+  END CallSuper;
+
+(* ============================================================ *)
+
+  PROCEDURE (os : PeFile)InitHead*(rTp : Ty.Record;
+                                   prc : Id.PrcId);
+    VAR mDf : Api.MethodDef;
+        cDf : Api.ClassDef;
+  BEGIN
+    cDf := os.cls(rTp)(Api.ClassDef);
+
+    IF prc # NIL THEN
+      mDf := prc.tgXtn(Api.MethodDef);
+      mDf.AddMethAttribute(ctAtt);
+    ELSE
+      mDf := os.new(rTp)(Api.MethodDef);
+    END;
+    os.pePI.mthD := mDf;
+    os.MkCodeBuffer();
+    mDf.AddCallConv(Api.CallConv.Instance);
+   (*
+    *   Now we initialize the supertype;
+    *)
+    os.Code(Asm.opc_ldarg_0);
+  END InitHead;
+
+(* ============================================================ *)
+
+  PROCEDURE (os : PeFile)CopyHead*(typ : Ty.Record);
+    VAR mDf : Api.MethodDef;
+        cDf : Api.ClassDef;
+        par : Id.ParId;
+        prs : POINTER TO ARRAY OF Id.ParId;
+  BEGIN
+    cDf := os.cls(typ)(Api.ClassDef);
+    mDf := os.cpy(typ)(Api.MethodDef);
+    mDf.AddMethAttribute(Api.MethAttr.Public);
+    mDf.AddImplAttribute(ilAtt);
+    mDf.AddCallConv(Api.CallConv.Instance);
+    os.pePI.mthD := mDf;
+    os.MkCodeBuffer();
+  END CopyHead;
+
+(* ============================================================ *)
+
+  PROCEDURE (os : PeFile)MarkInterfaces*(IN seq : Sy.TypeSeq);
+    VAR index  : INTEGER;
+        tideX  : INTEGER;
+        implT  : Ty.Record;
+  BEGIN
+    tideX := seq.tide-1;
+    ASSERT(tideX >= 0);
+    FOR index := 0 TO tideX DO
+      implT := seq.a[index].boundRecTp()(Ty.Record);
+      os.clsD.AddImplementedInterface(os.cls(implT));
+    END;
+  END MarkInterfaces;
+
+(* ============================================================ *)
+
+  PROCEDURE (os : PeFile)MainHead*(xAtt : SET);
+    VAR mthD : Api.MethodDef;
+
+    VAR strA : Api.Type;
+        list : Api.Field;
+        pars : POINTER TO ARRAY OF Api.Param;
+  BEGIN 
+    NEW(pars, 1);
+    strA := Api.ZeroBasedArray.init(strgD);
+    pars[0] := Api.Param.init(0, "@args", strA);
+
+    IF Sy.wMain IN xAtt THEN
+      mthD := os.clsS.AddMethod(psAtt, ilAtt, ".WinMain", voidD, pars);
+    ELSE (* Sy.cMain IN xAtt THEN *)
+      mthD := os.clsS.AddMethod(psAtt, ilAtt, ".CPmain", voidD, pars);
+    END;
+    os.pePI.mthD := mthD;
+    os.MkCodeBuffer();
+    mthD.DeclareEntryPoint();
+    IF CSt.debug THEN os.LineSpan(Scn.mkSpanT(CSt.thisMod.begTok)) END;
+   (*
+    *  Save the command-line arguments to the RTS.
+    *)
+    os.Code(Asm.opc_ldarg_0);
+    os.CodeF(Asm.opc_stsfld, os.fld(CSt.argLst));
+  END MainHead;
+
+(* ============================================================ *)
+
+  PROCEDURE (os : PeFile)SubSys*(xAtt : SET);
+  BEGIN
+    IF Sy.wMain IN xAtt THEN os.peFl.SetSubSystem(2) END;
+  END SubSys;
+
+(* ============================================================ *)
+
+  PROCEDURE (os : PeFile)StartBoxClass*(rec : Ty.Record;
+                                        att : SET;
+                                        blk : Id.BlkId);
+    VAR mthD : Api.MethodDef;
+        sprC : Api.Method;
+        boxC : Api.ClassDef;
+  BEGIN
+    boxC := rec.tgXtn(RecXtn).boxD(Api.ClassDef);
+    boxC.AddAttribute(toTypeAttr(att));
+
+   (*
+    *   Emit the no-arg constructor
+    *)
+    os.MkNewProcInfo(blk);
+    mthD := os.new(rec)(Api.MethodDef);
+    os.pePI.mthD := mthD;
+    os.MkCodeBuffer();
+    mthD.AddCallConv(Api.CallConv.Instance);
+
+    os.Code(Asm.opc_ldarg_0);
+    sprC := newObjt;
+
+    os.pePI.code.MethInst(Asm.cd[Asm.opc_call], sprC);
+    os.InitHead(rec, NIL);
+    os.CallSuper(rec, NIL);
+    os.Code(Asm.opc_ret);
+    os.Locals();
+    os.InitTail(rec);
+    os.pePI := NIL;
+    os.proc := NIL;
+   (*
+    *   Copies of value classes are always done inline.
+    *)
+  END StartBoxClass;
+
+(* ============================================================ *)
+
+  PROCEDURE (os : PeFile)Tail(),NEW;
+  BEGIN
+    os.Locals();
+    os.pePI.code.CloseScope();  (* Needed for PERWAPI pdb files *)
+    os.pePI := NIL;
+    os.proc := NIL;
+  END Tail;
+
+(* ============================================================ *)
+
+  PROCEDURE (os : PeFile)MainTail*();
+  BEGIN os.Tail() END MainTail;
+
+(* ------------------------------------------------------------ *)
+
+  PROCEDURE (os : PeFile)MethodTail*(id : Id.Procs);
+  BEGIN os.Tail() END MethodTail;
+
+(* ------------------------------------------------------------ *)
+
+  PROCEDURE (os : PeFile)ClinitTail*();
+  BEGIN os.Tail() END ClinitTail;
+
+(* ------------------------------------------------------------ *)
+
+  PROCEDURE (os : PeFile)CopyTail*();
+  BEGIN os.Tail() END CopyTail;
+
+(* ------------------------------------------------------------ *)
+
+  PROCEDURE (os : PeFile)InitTail*(typ : Ty.Record);
+  BEGIN os.Tail() END InitTail;
+
+(* ============================================================ *)
+
+  PROCEDURE (os : PeFile)ClinitHead*();
+    VAR mAtt : INTEGER;
+  BEGIN
+    mAtt := ctAtt + Api.MethAttr.Static;
+    os.pePI.mthD := os.clsS.AddMethod(mAtt, ilAtt, ".cctor", voidD, NIL);
+    os.MkCodeBuffer();
+    IF CSt.debug THEN
+      os.pePI.code.IntLine(CSt.thisMod.token.lin, 
+                           CSt.thisMod.token.col, 
+                           CSt.thisMod.token.lin,
+                           CSt.thisMod.token.col + CSt.thisMod.token.len);
+      os.Code(Asm.opc_nop);
+    END; 
+  END ClinitHead;
+
+(* ============================================================ *)
+
+  PROCEDURE (os : PeFile)EmitField*(id : Id.AbVar; att : SET);
+    VAR fDf : Api.FieldDef;
+  BEGIN
+    fDf := os.fld(id)(Api.FieldDef);
+    fDf.AddFieldAttr(toFieldAttr(att));
+  END EmitField;
+
+(* ============================================================ *)
+(*           Start of Procedure Variable and Event Stuff            *)
+(* ============================================================ *)
+
+  PROCEDURE MkAddRem(os : PeFile; fId : Id.AbVar);
+    VAR xtn : EvtXtn;
+        fXt : Api.Field;
+        clD : Api.Class;
+        namS : Lv.CharOpen;
+        typA : POINTER TO ARRAY OF Api.Type;
+        parA : POINTER TO ARRAY OF Api.Param;
+   (* -------------------------------- *)
+    PROCEDURE GetClass(os : PeFile; 
+                       id : Id.AbVar;
+                   OUT cl : Api.Class;
+                   OUT nm : Lv.CharOpen);
+    BEGIN
+      WITH id : Id.FldId DO
+           cl := os.cls(id.recTyp(Ty.Record));
+           nm := id.fldNm;
+      | id : Id.VarId DO
+           IF id.recTyp # NIL THEN cl:= os.cls(id.recTyp(Ty.Record));
+           ELSE cl:= os.dsc(id.dfScp(Id.BlkId));
+           END;
+           nm := id.varNm;
+      END;
+    END GetClass;
+   (* -------------------------------- *)
+  BEGIN
+   (*
+    *  First, need to ensure that there is a field 
+    *  descriptor created for this variable.
+    *)
+    IF fId.tgXtn = NIL THEN 
+      fXt := os.fld(fId);
+    ELSE 
+      fXt := fId.tgXtn(Api.Field);
+    END;
+   (*
+    *  Now allocate the Event Extension object.
+    *)
+    NEW(xtn);
+    xtn.fldD := fXt;
+   (*
+    *  Now create the MethodRef or MethodDef descriptors
+    *  for add_<fieldname>() and remove_<fieldname>()
+    *)
+    GetClass(os, fId, clD, namS);
+    WITH clD : Api.ClassDef DO
+          NEW(parA, 1);
+          parA[0] := Api.Param.init(0, "ev", os.typ(fId.type)); 
+          xtn.addD := clD.AddMethod(MKSTR(evtAdd^ + namS^), voidD, parA);
+          xtn.remD := clD.AddMethod(MKSTR(evtRem^ + namS^), voidD, parA);
+    | clD : Api.ClassRef DO
+          NEW(typA, 1);
+          typA[0] := os.typ(fId.type); 
+          xtn.addD := clD.AddMethod(MKSTR(evtAdd^ + namS^), voidD, typA);
+          xtn.remD := clD.AddMethod(MKSTR(evtRem^ + namS^), voidD, typA);
+    END;
+    fId.tgXtn := xtn;
+  END MkAddRem;
+
+(* ============================================================ *)
+
+  PROCEDURE (os : PeFile)EmitEventMethods*(id : Id.AbVar);
+    CONST att  = Api.MethAttr.Public + Api.MethAttr.SpecialName;
+    VAR   eTp  : Ty.Event;
+          evt  : Api.Event;
+          addD  : Api.MethodDef;
+          remD  : Api.MethodDef;
+   (* ------------------------------------------------- *)
+    PROCEDURE EmitEvtMth(os  : PeFile; 
+                         id  : Id.AbVar;
+                         add : BOOLEAN; 
+                         mth : Api.MethodDef);
+      VAR pFix : Lv.CharOpen;
+          mStr : RTS.NativeString;
+          mthD : Api.MethodDef;
+          parA : POINTER TO ARRAY OF Api.Param;
+    BEGIN
+      os.MkNewProcInfo(NIL);
+      WITH id : Id.FldId DO
+          mth.AddMethAttribute(att);
+          mth.AddCallConv(Api.CallConv.Instance);
+          mth.AddImplAttribute(ilAtt + Api.ImplAttr.Synchronised);
+          os.pePI.mthD := mth;
+          os.MkCodeBuffer();
+          os.Code(Asm.opc_ldarg_0);
+          os.Code(Asm.opc_ldarg_0);
+          os.PutGetF(Asm.opc_ldfld, id);
+          os.Code(Asm.opc_ldarg_1);
+          os.CallCombine(id.type, add);
+          os.PutGetF(Asm.opc_stfld, id);
+      | id : Id.VarId DO
+          mth.AddMethAttribute(att + Api.MethAttr.Static);
+          mth.AddImplAttribute(ilAtt + Api.ImplAttr.Synchronised);
+          os.pePI.mthD := mth;
+          os.MkCodeBuffer(); 
+          os.PutGetS(Asm.opc_ldsfld, id.dfScp(Id.BlkId), id);
+          os.Code(Asm.opc_ldarg_0);
+          os.CallCombine(id.type, add);
+          os.PutGetS(Asm.opc_stsfld, id.dfScp(Id.BlkId),id);
+      END;
+      os.Code(Asm.opc_ret);
+      os.Tail();
+    END EmitEvtMth;
+   (* ------------------------------------------------- *)
+  BEGIN
+   (*
+    *  Emit the "add_*" method
+    *)
+    addD := os.add(id)(Api.MethodDef);
+    EmitEvtMth(os, id, TRUE, addD);
+   (*
+    *  Emit the "remove_*" method
+    *)
+    remD := os.rem(id)(Api.MethodDef);
+    EmitEvtMth(os, id, FALSE, remD);
+   (*
+    *  Emit the .event declaration" 
+    *)
+    WITH id : Id.FldId DO
+        evt := os.clsD.AddEvent(MKSTR(id.fldNm^), os.typ(id.type));
+    | id : Id.VarId DO
+        evt := os.clsD.AddEvent(MKSTR(id.varNm^), os.typ(id.type));
+    END;
+    evt.AddMethod(addD, Api.MethodType.AddOn);
+    evt.AddMethod(remD, Api.MethodType.RemoveOn);
+  END EmitEventMethods;
+
+(* ============================================================ *)
+
+  PROCEDURE (os : PeFile)CallCombine(typ : Sy.Type;
+                                     add : BOOLEAN),NEW;
+    VAR xtn : Api.Method;
+  BEGIN
+    IF add THEN xtn := os.cmb() ELSE xtn := os.rmv() END; 
+    os.pePI.code.MethInst(Asm.cd[Asm.opc_call], xtn);
+    os.Adjust(-1);        
+    os.CodeT(Asm.opc_castclass, typ);
+  END CallCombine;
+
+(* ============================================================ *)
+
+  PROCEDURE (os : PeFile)MkAndLinkDelegate*(dl  : Sy.Idnt;
+                                            id  : Sy.Idnt;
+                                            ty  : Sy.Type;
+                                            isA : BOOLEAN);
+   (* --------------------------------------------------------- *)
+    VAR rcv : INTEGER;
+        mth : Api.Method;
+   (* --------------------------------------------------------- *)
+  BEGIN
+    WITH id : Id.FldId DO
+       (*
+        *      <push handle>                  // ... already done
+        *      <push receiver (or nil)>       // ... already done
+        *      <make new proc value>          // ... still to do
+        *      call      instance void A.B::add_fld(class tyName)
+        *)
+        os.MkNewProcVal(dl, ty);
+        IF isA THEN mth := os.add(id) ELSE mth := os.rem(id) END;
+        mth.AddCallConv(Api.CallConv.Instance);
+        os.pePI.code.MethInst(Asm.cd[Asm.opc_call], mth);
+    | id : Id.VarId DO
+       (*
+        *      <push receiver (or nil)>      // ... already done
+        *      <make new proc value>            // ... still to do
+        *      call      void A.B::add_fld(class tyName)
+        *)
+        os.MkNewProcVal(dl, ty);
+        IF isA THEN mth := os.add(id) ELSE mth := os.rem(id) END;
+        os.pePI.code.MethInst(Asm.cd[Asm.opc_call], mth);
+    | id : Id.LocId DO
+       (*
+        *      <save receiver>      
+        *      ldloc      'local'
+        *      <restore receiver>      
+        *      <make new proc value>            // ... still to do
+        *      call      class D D::Combine(class D, class D)
+        *)
+        rcv := os.proc.newLocal(CSt.ntvObj);
+        os.StoreLocal(rcv);
+        os.GetLocal(id);
+        os.PushLocal(rcv);
+        os.MkNewProcVal(dl, ty);
+        os.CallCombine(ty, isA);
+        os.PutLocal(id); 
+    END;
+  END MkAndLinkDelegate;
+
+(* ============================================================ *)
+(* ============================================================ *)
+
+  PROCEDURE (os : PeFile)EmitPTypeBody*(tId : Id.TypId);
+  BEGIN
+    ASSERT(tId.tgXtn # NIL);
+  END EmitPTypeBody;
+
+(* ============================================================ *)
+(*          End of Procedure Variable and Event Stuff           *)
+(* ============================================================ *)
+
+  PROCEDURE (os : PeFile)Line*(nm : INTEGER);
+  BEGIN
+    os.pePI.code.IntLine(nm,1,nm,100);
+    (*IF CSt.debug THEN os.Code(Asm.opc_nop) END;*)
+  END Line;
+ 
+  PROCEDURE (os : PeFile)LinePlus*(lin, col : INTEGER); 
+  BEGIN
+    (*IF CSt.debug THEN os.Code(Asm.opc_nop) END;*)
+    os.pePI.code.IntLine(lin,1,lin,col); 
+  END LinePlus;
+  
+  PROCEDURE (os : PeFile)LineSpan*(s : Scn.Span);
+  BEGIN
+    IF s # NIL THEN 
+         os.pePI.code.IntLine(s.sLin, s.sCol, s.eLin, s.eCol) END;     
+  END LineSpan;
+
+(* ============================================================ *)
+
+  PROCEDURE (os : PeFile)Locals(),NEW;
+  (** Declare the local of this method. *)
+    VAR count : INTEGER;
+        index : INTEGER;
+        prcId : Sy.Scope;
+        locId : Id.LocId;
+        methD : Api.MethodDef;
+        loclA : POINTER TO ARRAY OF Api.Local;
+        boolA : POINTER TO ARRAY OF BOOLEAN;
+        lBind : Api.LocalBinding;
+  BEGIN
+    methD := os.pePI.mthD;
+   (*
+    *   If dMax < 8, leave maxstack as default 
+    *)
+    IF os.proc.dMax > 8 THEN 
+      methD.SetMaxStack(os.proc.dMax);
+    ELSE
+      methD.SetMaxStack(8);
+    END;
+    NEW(loclA, os.proc.tLst.tide);
+    NEW(boolA, os.proc.tLst.tide);
+
+    count := 0;
+    IF os.proc.prId # NIL THEN 
+      prcId := os.proc.prId;
+      WITH prcId : Id.Procs DO
+        IF Id.hasXHR IN prcId.pAttr THEN
+          loclA[count] := Api.Local.init("", os.typ(prcId.xhrType)); 
+          INC(count);
+        END;
+        FOR index := 0 TO prcId.locals.tide-1 DO
+          locId := prcId.locals.a[index](Id.LocId);
+          IF ~(locId IS Id.ParId) & (locId.varOrd # Id.xMark) THEN
+            loclA[count] := Api.Local.init(nms(locId), os.typ(locId.type));
+            IF CSt.debug THEN boolA[count] := TRUE END;
+            INC(count);
+          END;
+        END;
+      ELSE (* nothing for module blocks *)
+      END;
+    END;
+    WHILE count < os.proc.tLst.tide DO 
+      loclA[count] := Api.Local.init("", os.typ(os.proc.tLst.a[count])); 
+      INC(count);
+    END;
+    IF count > 0 THEN methD.AddLocals(loclA, TRUE) END;
+    FOR index := 0 TO count-1 DO
+      IF boolA[index] THEN lBind := os.pePI.code.BindLocal(loclA[index]) END;
+    END;
+  END Locals;
+
+(* ============================================================ *)
+
+  PROCEDURE (os : PeFile)LoadType*(id : Sy.Idnt);
+   (* ---------------------------------- *)
+    PROCEDURE getLdTyp(os : PeFile) : Api.MethodRef;
+      VAR typD : Api.ClassRef;
+          rthA : POINTER TO ARRAY OF Api.Type;
+    BEGIN
+      IF loadTyp = NIL THEN
+       (*
+        *  Make params for the call
+        *)
+        NEW(rthA, 1);
+        IF rtTpHdl = NIL THEN
+          rtTpHdl := getOrAddClass(corlib, "System", "RuntimeTypeHandle");
+        END;
+        rthA[0] := rtTpHdl;
+       (*
+        *  Make receiver/result type descriptor
+        *)
+        IF CSt.ntvTyp.tgXtn = NIL THEN
+          CSt.ntvTyp.tgXtn := getOrAddClass(corlib, "System", "Type");
+        END;
+        typD := CSt.ntvTyp.tgXtn(Api.ClassRef);
+        loadTyp := getOrAddMethod(typD, "GetTypeFromHandle", typD, rthA);
+      END;
+      RETURN loadTyp;
+    END getLdTyp;
+   (* ---------------------------------- *)
+  BEGIN
+   (*
+    *    ldtoken <Type>
+    *    call class [mscorlib]System.Type 
+    *           [mscorlib]System.Type::GetTypeFromHandle(
+    *                     value class [mscorlib]System.RuntimeTypeHandle)
+    *)
+    os.CodeT(Asm.opc_ldtoken, id.type);
+    os.pePI.code.MethInst(Asm.cd[Asm.opc_call], getLdTyp(os));
+  END LoadType;
+
+(* ============================================================ *)
+
+  PROCEDURE (os : PeFile)Finish*();
+   (*(* ------------------------------------ *)
+    PROCEDURE MakeDebuggable(pef : Api.PEFile);
+      VAR thisAssm : Api.Assembly;
+          debugRef : Api.ClassRef;
+          dbugCtor : Api.MethodRef;
+          trueCnst : Api.BoolConst;
+          twoBools : TypArr;
+          dbugArgs : POINTER TO ARRAY OF Api.Constant;
+    BEGIN
+      thisAssm := pef.GetThisAssembly();
+      debugRef := getOrAddClass(corlib, "System.Diagnostics", "DebuggableAttribute");
+      NEW(twoBools, 2);
+      NEW(dbugArgs, 2);
+      twoBools[0] := Api.PrimitiveType.Boolean;
+      twoBools[1] := Api.PrimitiveType.Boolean;
+      dbugArgs[0] := Api.BoolConst.init(TRUE);
+      dbugArgs[1] := Api.BoolConst.init(TRUE);
+      dbugCtor := getOrAddMethod(debugRef, ctorS, voidD, twoBools)(Api.MethodRef);
+      dbugCtor.AddCallConv(Api.CallConv.Instance);
+      thisAssm.AddCustomAttribute(dbugCtor, dbugArgs);  
+    END MakeDebuggable;
+   (* ------------------------------------ *)*)
+  BEGIN
+    IF CSt.debug THEN os.peFl.MakeDebuggable(TRUE, TRUE) END; 
+    (* bake the assembly ... *)
+    os.peFl.WritePEFile(CSt.debug); 
+  END Finish;
+
+(* ============================================================ *)
+
+  PROCEDURE (os : PeFile)RefRTS*();
+    VAR i : INTEGER;
+        xhrRc : Ty.Record;
+        xhrNw : Api.Method;
+        xhrXt : RecXtn;
+        rtsXt : BlkXtn;
+        recXt : RecXtn;
+  BEGIN
+   (*
+    *  Reset the descriptor pool.
+    *  Note that descriptors cannot persist between
+    *  compilation unit, since the token sequence
+    *  is reset in PEAPI.
+    *)
+    mathCls := NIL;
+    envrCls := NIL;
+    excpCls := NIL;
+    rtTpHdl := NIL;
+    loadTyp := NIL;
+    FOR i := 0 TO Mu.rtsLen-1 DO rHelper[i] := NIL END;
+   (*
+    *  Now we need to create tgXtn fields
+    *  for some of the system types.   All 
+    *  others are only allocated on demand.
+    *)
+    corlib := os.peFl.MakeExternAssembly("mscorlib");
+   (*
+    *  Must put xtn markers on both the pointer AND the record
+    *)
+    NEW(recXt);
+    CSt.ntvStr(Ty.Pointer).boundTp.tgXtn := recXt;      (* the record  *)
+(*
+ *  recXt.clsD := corlib.AddClass("System", "String");
+ *)
+(* -- start replacement -- *)
+    recXt.clsD := getOrAddClass(corlib, "System", "String");
+(* --- end replacement --- *)
+    CSt.ntvStr.tgXtn := recXt.clsD;                     (* the pointer *)
+   (*
+    *  Must put xtn markers on both the pointer AND the record
+    *)
+    NEW(recXt);
+    CSt.ntvObj(Ty.Pointer).boundTp.tgXtn := recXt;      (* the record  *)
+(*
+ *  recXt.clsD := corlib.AddClass("System", "Object");
+ *)
+(* -- start replacement -- *)
+    recXt.clsD := getOrAddClass(corlib, "System", "Object");
+(* --- end replacement --- *)
+    CSt.ntvObj.tgXtn := recXt.clsD;                     (* the pointer *)
+   (*
+    *  CSt.ntvVal IS a record descriptor, not a pointer
+    *)
+    NEW(recXt);
+    CSt.ntvVal.tgXtn := recXt;                          (* the record  *)
+(*
+ *  recXt.clsD := corlib.AddClass("System", "ValueType");
+ *)
+(* -- start replacement -- *)
+    recXt.clsD := getOrAddClass(corlib, "System", "ValueType");
+(* --- end replacement --- *)
+
+    newObjt := getOrAddMethod(CSt.ntvObj.tgXtn(Api.ClassRef),ctorS,voidD,NIL);
+    newObjt.AddCallConv(Api.CallConv.Instance);
+   (*
+    *  Create Api.AssemblyRef for "RTS"
+    *  Create Api.ClassRef for "[RTS]RTS"
+    *  Create Api.ClassRef for "[RTS]Cp_rts"
+    *)
+    IF CSt.rtsBlk.xName = NIL THEN Mu.MkBlkName(CSt.rtsBlk) END;
+    os.rts   := os.peFl.MakeExternAssembly("RTS");
+    NEW(rtsXt);
+    rtsXt.asmD := os.rts;
+    rtsXt.dscD := os.rts.AddClass("", "RTS");
+    CSt.rtsBlk.tgXtn := rtsXt;
+    os.cprts    := os.rts.AddClass("", "CP_rts");
+   (*
+    *  Create Api.AssemblyRef for "ProgArgs" (same as RTS)
+    *  Create Api.ClassRef for "[RTS]ProgArgs"
+    *)
+    os.DoRtsMod(CSt.prgArg);
+    os.progArgs := CSt.prgArg.tgXtn(BlkXtn).dscD(Api.ClassRef);
+   (*
+    *  Create Api.ClassRef for "[RTS]XHR"
+    *  Create method "[RTS]XHR::.ctor()"
+    *)
+    xhrCl := os.rts.AddClass("", "XHR");
+    xhrNw := xhrCl.AddMethod(ctorS, voidD, NIL);
+    xhrNw.AddCallConv(Api.CallConv.Instance);
+    xhrRc := CSt.rtsXHR.boundRecTp()(Ty.Record);
+    NEW(xhrXt);
+    xhrRc.tgXtn := xhrXt;
+    xhrXt.clsD := xhrCl;
+    xhrXt.newD := xhrNw;
+  END RefRTS;
+
+(* ============================================================ *)
+
+  PROCEDURE (os : PeFile)StartNamespace*(nm : Lv.CharOpen);
+  BEGIN
+    os.nmSp := MKSTR(nm^);
+  END StartNamespace;
+
+(* ============================================================ *)
+
+  PROCEDURE (os : PeFile)MkBodyClass*(mod : Id.BlkId);
+   (*
+    *   Instantiate a ClassDef object for the synthetic
+    *   static class, and assign to the PeFile::clsS field.
+    *   Of course, for the time being it is also the 
+    *   "current class" held in the PeFile::clsD field.
+    *)
+    VAR namStr : RTS.NativeString;
+        clsAtt : INTEGER;
+        modXtn : BlkXtn;
+  BEGIN
+    defSrc := Api.SourceFile.GetSourceFile(
+        MKSTR(CSt.srcNam), Sys.Guid.Empty, Sys.Guid.Empty, Sys.Guid.Empty);
+    namStr  := MKSTR(mod.clsNm^);
+    clsAtt  := toTypeAttr(Asm.modAttr);
+    os.clsS := os.peFl.AddClass(clsAtt, os.nmSp, namStr);
+    os.clsD := os.clsS; 
+    NEW(modXtn);
+    modXtn.asmD := NIL;
+    modXtn.dscD := os.clsS;
+    mod.tgXtn := modXtn;
+  END MkBodyClass;
+
+(* ============================================================ *)
+
+  PROCEDURE (os : PeFile)ClassHead*(attSet : SET; 
+                                    thisRc : Ty.Record;
+                                    superT : Ty.Record);
+    VAR clsAtt : INTEGER;
+        clsDef : Api.ClassDef;
+  BEGIN
+    clsAtt := toTypeAttr(attSet);
+    clsDef := os.cls(thisRc)(Api.ClassDef);
+    clsDef.AddAttribute(clsAtt);
+    os.clsD := clsDef;
+  END ClassHead;
+
+(* ============================================================ *)
+
+  PROCEDURE (os : PeFile)ClassTail*();
+  BEGIN
+    os.clsD := NIL;
+  END ClassTail;
+
+(* ============================================================ *)
+
+  PROCEDURE (os : PeFile)MkRecX*(t : Ty.Record; s : Sy.Scope);
+   (* -------------------------------- *
+    *  Create a ClassDef or a ClassRef for this type.
+    *  The type attributes are set to a default value
+    *  and are modified later for a ClassDef.
+    * -------------------------------- *)
+    VAR indx : INTEGER;
+        valR : BOOLEAN;               (* is a value record  *)
+        noNw : BOOLEAN;               (* no constructor...  *)
+        base : Ty.Record;
+        xAsm : Api.AssemblyRef;
+        xCls : Api.ClassRef;
+        cDef : Api.ClassDef;
+        cRef : Api.ClassRef;
+        nStr : RTS.NativeString;      (* record name string *)
+        aStr : RTS.NativeString;      (* imported namespace *)
+        recX : RecXtn;
+   (* -------------------------------- *)
+    PROCEDURE DoBoxDef(o : PeFile; t : Ty.Record);
+      VAR nStr : RTS.NativeString;
+          cDef : Api.ClassDef;
+          cFld : Api.FieldDef;
+          nMth : Api.MethodDef;
+          tXtn : RecXtn;
+    BEGIN
+      nStr := boxedName(t);
+      tXtn := t.tgXtn(RecXtn);
+      cDef := o.peFl.AddClass(0, o.nmSp, nStr);
+      cFld := cDef.AddField(vfldS, tXtn.clsD);
+      nMth := cDef.AddMethod(ctAtt,ilAtt,ctorS,voidD,NIL);
+
+      nMth.AddCallConv(Api.CallConv.Instance);
+      cFld.AddFieldAttr(Api.FieldAttr.Public);
+
+      tXtn.boxD := cDef;
+      tXtn.newD := nMth;
+      tXtn.vDlr := cFld;
+    END DoBoxDef;
+   (* -------------------------------- *)
+    PROCEDURE DoBoxRef(o : PeFile; t : Ty.Record; c : Api.ClassRef);
+      VAR cFld : Api.FieldRef;
+          nMth : Api.MethodRef;
+          tXtn : RecXtn;
+    BEGIN
+      tXtn := t.tgXtn(RecXtn);
+      cFld := getOrAddField(c, vfldS, tXtn.clsD);
+(*
+ *    nMth := c.AddMethod(ctorS,voidD,NIL);
+ *)
+      nMth := getOrAddMethod(c, ctorS, voidD, NIL);
+      nMth.AddCallConv(Api.CallConv.Instance);
+
+      tXtn.boxD := c;
+      tXtn.newD := nMth;
+      tXtn.vDlr := cFld;
+    END DoBoxRef;
+   (* -------------------------------- *)
+  BEGIN
+    nStr := MKSTR(t.xName^);
+    valR := Mu.isValRecord(t);
+    NEW(recX);
+    t.tgXtn := recX;
+   (*
+    *  No default no-arg constructor is defined if this
+    *  is an abstract record, an interface, or extends a
+    *  foreign record that does not export a no-arg ctor.
+    *)
+    noNw := t.isInterfaceType() OR (Sy.noNew IN t.xAttr);
+
+    IF s.kind # Id.impId THEN (* this is a classDEF *)
+      base := t.superType();  (* might return System.ValueType *)
+      IF base = NIL THEN
+        cDef := os.peFl.AddClass(0, os.nmSp, nStr);
+      ELSIF valR THEN
+        cDef := os.peFl.AddValueClass(0, os.nmSp, nStr);
+      ELSE
+        cDef := os.peFl.AddClass(0, os.nmSp, nStr, os.cls(base));
+      END;
+      recX.clsD := cDef; (* this field needed for MkFldName() *)
+      IF valR THEN 
+       (*
+        *  Create the boxed version of this value record
+        *  AND create a constructor for the boxed class
+        *)
+        DoBoxDef(os, t);
+      ELSIF ~noNw THEN
+       (*
+        *  Create a constructor for this reference class.
+        *)
+        recX.newD := cDef.AddMethod(ctAtt, ilAtt, ctorS, voidD, NIL);
+        recX.newD.AddCallConv(Api.CallConv.Instance);
+      END;
+      FOR indx := 0 TO t.fields.tide-1 DO
+        Mu.MkFldName(t.fields.a[indx](Id.FldId), os);
+      END;
+    ELSE                      (* this is a classREF *)
+      IF t.encCls # NIL THEN  (* ... a nested classREF *)
+        base := t.encCls(Ty.Record);
+        xCls := os.cls(base)(Api.ClassRef);
+        cRef := xCls.AddNestedClass(nStr);
+        recX.clsD := cRef;
+      ELSE                    (* ... a normal classREF *)
+        xAsm := os.asm(s(Id.BlkId));
+        aStr := MKSTR(s(Id.BlkId).xName^);
+        IF valR THEN
+          cRef := getOrAddValueClass(xAsm, aStr, nStr);
+        ELSE
+          cRef := getOrAddClass(xAsm, aStr, nStr);
+        END;
+        recX.clsD := cRef;
+        IF valR & ~(Sy.isFn IN t.xAttr) THEN
+          DoBoxRef(os, t, xAsm.AddClass(aStr, boxedName(t)));
+        END;
+      END;
+
+      IF ~noNw & ~valR THEN
+        recX.newD := getOrAddMethod(cRef, ctorS, voidD, NIL);
+        recX.newD.AddCallConv(Api.CallConv.Instance);
+      END;
+    END;
+  END MkRecX;
+
+(* ============================================================ *)
+
+  PROCEDURE (os : PeFile)MkVecX*(t : Sy.Type; m : Id.BlkId);
+    VAR xAsm : Api.AssemblyRef;
+        recX : RecXtn;
+        nStr : RTS.NativeString;      (* record name string *)
+        aStr : RTS.NativeString;      (* imported namespace *)
+        cRef : Api.ClassRef;
+  BEGIN
+    NEW(recX);
+    t.tgXtn := recX;
+
+    IF m.tgXtn = NIL THEN os.DoRtsMod(m) END;
+    IF t.xName = NIL THEN Mu.MkTypeName(t, os) END;
+
+    aStr := MKSTR(m.xName^);
+    nStr := MKSTR(t.xName^);
+
+    xAsm := os.asm(m);
+    cRef := xAsm.AddClass(aStr, nStr);
+    recX.clsD := cRef;
+    recX.newD := cRef.AddMethod(ctorS, voidD, NIL);
+    recX.newD.AddCallConv(Api.CallConv.Instance);
+  END MkVecX;
+
+(* ============================================================ *)
+
+  PROCEDURE (os : PeFile)MkDelX(t : Ty.Procedure;
+                                s : Sy.Scope),NEW;
+   (* -------------------------------- *)
+    CONST dAtt = Asm.att_public + Asm.att_sealed;
+    VAR   xtn : DelXtn;             (* The created descriptor   *)
+          str : RTS.NativeString;   (* The proc-type nameString *)
+          att : Api.TypeAttr;       (* public,sealed (for Def)  *)
+          asN : RTS.NativeString;   (* Assembly name (for Ref)  *)
+          asR : Api.AssemblyRef;    (* Assembly ref  (for Ref)  *)
+          rtT : Sy.Type;            (* AST return type of proc  *)
+          rtD : Api.Type;           (* Api return type of del.  *)
+          clD : Api.ClassDef;
+          clR : Api.ClassRef;
+          mtD : Api.MethodDef;
+   (* -------------------------------- *)
+    PROCEDURE t2() : POINTER TO ARRAY OF Api.Type;
+      VAR a : POINTER TO ARRAY OF Api.Type;
+    BEGIN 
+      NEW(a,2); a[0] := objtD; a[1] := nIntD; RETURN a; 
+    END t2;
+   (* -------------------------------- *)
+    PROCEDURE p2() : POINTER TO ARRAY OF Api.Param;
+      VAR a : POINTER TO ARRAY OF Api.Param;
+    BEGIN
+      NEW(a,2);
+      a[0] := Api.Param.init(0, "obj", objtD); 
+      a[1] := Api.Param.init(0, "mth", nIntD); 
+      RETURN a;
+    END p2;
+   (* -------------------------------- *)
+    PROCEDURE tArr(t: Ty.Procedure; o: PeFile) : POINTER TO ARRAY OF Api.Type;
+      VAR a : POINTER TO ARRAY OF Api.Type;
+          i : INTEGER;
+          p : Id.ParId;
+          d : Api.Type;
+    BEGIN
+      NEW(a, t.formals.tide);
+      FOR i := 0 TO t.formals.tide-1 DO
+        p := t.formals.a[i];
+        d := o.typ(p.type);
+        IF Mu.takeAdrs(p) THEN 
+          p.boxOrd := p.parMod;
+          d := Api.ManagedPointer.init(d);
+        END; 
+        a[i] := d; 
+      END;
+      RETURN a;
+    END tArr;
+   (* -------------------------------- *)
+    PROCEDURE pArr(t: Ty.Procedure; o: PeFile) : POINTER TO ARRAY OF Api.Param;
+      VAR a : POINTER TO ARRAY OF Api.Param;
+          i : INTEGER;
+          p : Id.ParId;
+          d : Api.Type;
+    BEGIN
+      NEW(a, t.formals.tide);
+      FOR i := 0 TO t.formals.tide-1 DO
+        p := t.formals.a[i];
+        d := o.typ(p.type);
+        IF Mu.takeAdrs(p) THEN 
+          p.boxOrd := p.parMod;
+          d := Api.ManagedPointer.init(d);
+        END; 
+        a[i] := Api.Param.init(0, nms(p), d); 
+      END;
+      RETURN a;
+    END pArr;
+   (* -------------------------------- *)
+  BEGIN
+    IF t.tgXtn # NIL THEN RETURN END;
+    NEW(xtn);
+    str := MKSTR(Sy.getName.ChPtr(t.idnt)^);
+    rtT := t.retType;
+    IF rtT = NIL THEN rtD := voidD ELSE rtD := os.typ(rtT) END;
+
+    IF s.kind # Id.impId THEN (* this is a classDEF *)
+      att := toTypeAttr(dAtt);
+      clD := os.peFl.AddClass(att, os.nmSp, str, os.mcd());
+      mtD := clD.AddMethod(ctorS, voidD, p2());
+      mtD.AddMethAttribute(ctAtt);
+      mtD.AddImplAttribute(rmAtt);
+      xtn.newD := mtD;
+      mtD := clD.AddMethod(invkS, rtD, pArr(t, os));
+      mtD.AddMethAttribute(Api.MethAttr.Public);
+      mtD.AddImplAttribute(rmAtt);
+      xtn.invD := mtD;
+      xtn.clsD := clD;
+    ELSE                      (* this is a classREF *)
+      asR := os.asm(s(Id.BlkId));
+      asN := MKSTR(s(Id.BlkId).xName^);
+      clR := getOrAddClass(asR, asN, str);
+      xtn.newD := clR.AddMethod(ctorS, voidD, t2());
+      xtn.invD := clR.AddMethod(invkS, rtD, tArr(t, os));
+      xtn.clsD := clR;
+    END;
+    xtn.newD.AddCallConv(Api.CallConv.Instance);
+    xtn.invD.AddCallConv(Api.CallConv.Instance);
+    t.tgXtn := xtn;
+    IF (t.idnt # NIL) & (t.idnt.tgXtn = NIL) THEN t.idnt.tgXtn := xtn END;
+  END MkDelX;
+
+(* ============================================================ *)
+
+  PROCEDURE (os : PeFile)MkPtrX*(t : Ty.Pointer);
+    VAR bTyp : Sy.Type;
+        recX : RecXtn;
+  BEGIN
+    bTyp := t.boundTp;
+    IF bTyp.tgXtn = NIL THEN Mu.MkTypeName(bTyp, os) END;
+    WITH bTyp : Ty.Record DO
+        recX := bTyp.tgXtn(RecXtn);
+        IF recX.boxD # NIL THEN t.tgXtn := recX.boxD;
+        ELSE t.tgXtn := recX.clsD;
+        END;
+    | bTyp : Ty.Array DO
+        t.tgXtn := bTyp.tgXtn;
+    END;
+  END MkPtrX;
+
+(* ============================================================ *)
+
+  PROCEDURE (os : PeFile)MkArrX*(t : Ty.Array);
+  BEGIN
+    t.tgXtn := Api.ZeroBasedArray.init(os.typ(t.elemTp));
+  END MkArrX;
+
+(* ============================================================ *)
+
+  PROCEDURE (os : PeFile)MkBasX*(t : Ty.Base);
+  BEGIN
+    CASE t.tpOrd OF
+    | Ty.uBytN            : t.tgXtn := Api.PrimitiveType.UInt8;
+    | Ty.byteN            : t.tgXtn := Api.PrimitiveType.Int8;
+    | Ty.sIntN            : t.tgXtn := Api.PrimitiveType.Int16;
+    | Ty.intN,Ty.setN     : t.tgXtn := Api.PrimitiveType.Int32;
+    | Ty.lIntN            : t.tgXtn := Api.PrimitiveType.Int64;
+    | Ty.boolN            : t.tgXtn := Api.PrimitiveType.Boolean;
+    | Ty.charN,Ty.sChrN   : t.tgXtn := Api.PrimitiveType.Char;
+    | Ty.realN            : t.tgXtn := Api.PrimitiveType.Float64;
+    | Ty.sReaN            : t.tgXtn := Api.PrimitiveType.Float32;
+    | Ty.anyRec,Ty.anyPtr : t.tgXtn := Api.PrimitiveType.Object;
+    END;
+  END MkBasX;
+
+(* ============================================================ *)
+
+  PROCEDURE (os : PeFile)MkEnuX*(t : Ty.Enum; s : Sy.Scope);
+    VAR scNs : RTS.NativeString;
+        enNm : RTS.NativeString;
+  BEGIN
+    ASSERT(s.kind = Id.impId);
+    scNs := MKSTR(s(Id.BlkId).xName^);
+    enNm := MKSTR(Sy.getName.ChPtr(t.idnt)^);
+    t.tgXtn := getOrAddValueClass(os.asm(s(Id.BlkId)), scNs, enNm);
+  END MkEnuX;
+
+(* ============================================================ *)
+(*
+  PROCEDURE (os : PeFile)MkTyXtn*(t : Sy.Type; s : Sy.Scope);
+  BEGIN
+    IF t.tgXtn # NIL THEN RETURN END;
+    WITH t : Ty.Record    DO os.MkRecX(t, s);
+    |    t : Ty.Enum      DO os.MkEnuX(t, s);
+    |    t : Ty.Procedure DO os.MkDelX(t, s);
+    |    t : Ty.Base      DO os.MkBasX(t);
+    |    t : Ty.Pointer   DO os.MkPtrX(t);
+    |    t : Ty.Array     DO os.MkArrX(t);
+    END;
+  END MkTyXtn;
+ *)
+(* ============================================================ *)
+
+  PROCEDURE MkMthDef(os  : PeFile;
+                     xhr : BOOLEAN;
+                     pTp : Ty.Procedure;
+                     cls : Api.ClassDef;
+                     str : RTS.NativeString)  : Api.MethodDef;
+    VAR par : Id.ParId;
+        prd : Api.Type;
+        prs : POINTER TO ARRAY OF Api.Param;
+        rtT : Sy.Type;
+        rtd : Api.Type;
+        pId : Sy.Idnt;
+
+        idx : INTEGER;       (* index into formal array *)
+        prX : INTEGER;       (* index into param. array *)
+        prO : INTEGER;       (* runtime ordinal of arg. *)
+        num : INTEGER;       (* length of formal array  *)
+        len : INTEGER;       (* length of param array   *)
+  BEGIN
+    pId := pTp.idnt;
+    IF (pId # NIL) & (pId IS Id.MthId) & (Id.covar IN pId(Id.MthId).mthAtt) THEN 
+      rtT := pId(Id.MthId).retTypBound();
+    ELSE
+      rtT := pTp.retType;
+    END;
+    num := pTp.formals.tide;
+    IF xhr THEN len := num + 1 ELSE len := num END;
+    NEW(prs, len);
+    IF rtT = NIL THEN rtd := voidD ELSE rtd := os.typ(rtT) END;
+
+    prO := pTp.argN; (* count from 1 if xhr OR has this *)
+    IF xhr THEN
+      prs[0] := Api.Param.init(0, "", xhrCl); prX := 1;
+    ELSE
+      prX := 0;
+    END;
+    FOR idx := 0 TO num-1 DO
+      par := pTp.formals.a[idx];
+      par.varOrd := prO; 
+      prd := os.typ(par.type);
+      IF Mu.takeAdrs(par) THEN 
+        par.boxOrd := par.parMod;
+        prd := Api.ManagedPointer.init(prd);
+        IF Id.uplevA IN par.locAtt THEN 
+          par.boxOrd := Sy.val;
+          ASSERT(Id.cpVarP IN par.locAtt);
+        END;
+      END; (* just mark *)
+      prs[prX] := Api.Param.init(par.boxOrd, nms(par), prd); 
+      INC(prX); INC(prO);
+    END;
+   (*
+    *  Add attributes, Impl, Meth, CallConv in MethodDecl()
+    *)
+    RETURN cls.AddMethod(str, rtd, prs);
+  END MkMthDef;
+
+(* ============================================================ *)
+
+  PROCEDURE MkMthRef(os  : PeFile;
+                     pTp : Ty.Procedure;
+                     cls : Api.ClassRef;
+                     str : RTS.NativeString) : Api.MethodRef;
+    VAR par : Id.ParId;
+        tpD : Api.Type;
+        prs : POINTER TO ARRAY OF Api.Type;
+        rtT : Sy.Type;
+        rtd : Api.Type;
+        pId : Sy.Idnt;
+
+        idx : INTEGER;       (* index into formal array *)
+        prO : INTEGER;       (* runtime ordinal of arg. *)
+        num : INTEGER;       (* length of formal array  *)
+  BEGIN
+    pId := pTp.idnt;
+    IF (pId # NIL) & (pId IS Id.MthId) & (Id.covar IN pId(Id.MthId).mthAtt) THEN 
+      rtT := pId(Id.MthId).retTypBound();
+    ELSE
+      rtT := pTp.retType;
+    END;
+    num := pTp.formals.tide;
+    NEW(prs, num);
+    IF rtT = NIL THEN rtd := voidD ELSE rtd := os.typ(rtT) END;
+
+    prO := pTp.argN;
+    FOR idx := 0 TO num-1 DO
+      par := pTp.formals.a[idx];
+      tpD := os.typ(par.type);
+      par.varOrd := prO; (* if hasThis, then is (idx+1) *)
+      IF Mu.takeAdrs(par) THEN 
+        par.boxOrd := par.parMod;
+        tpD := Api.ManagedPointer.init(tpD);
+      END; (* just mark *)
+      prs[idx] := tpD; INC(prO);
+    END;
+    RETURN getOrAddMethod(cls, str, rtd, prs);
+  END MkMthRef;
+
+(* ============================================================ *)
+
+  PROCEDURE (os : PeFile)NumberParams*(pId : Id.Procs; 
+                                       pTp : Ty.Procedure);
+   (*
+    *   (1) Generate signature information for this procedure
+    *   (2) Generate the target extension Method(Def | Ref)
+    *)
+    VAR class : Api.Class;
+        methD : Api.Method;
+        namSt : RTS.NativeString;
+        xhrMk : BOOLEAN;
+        pLeng : INTEGER;
+   (* ----------------- *)
+    PROCEDURE classOf(os : PeFile; id : Id.Procs) : Api.Class;
+      VAR scp : Sy.Scope;
+    BEGIN
+      scp := id.dfScp;
+     (*
+      *  Check for methods bound to explicit classes
+      *)
+      IF id.bndType # NIL THEN RETURN os.cls(id.bndType(Ty.Record)) END;
+     (*
+      *  Or associate static methods with the dummy class
+      *)
+      WITH scp : Id.BlkId DO
+        RETURN os.dsc(scp);
+      | scp : Id.Procs DO (* Nested procs take class from scope *)
+        RETURN classOf(os, scp);
+      END;
+    END classOf;
+   (* ----------------- *)
+  BEGIN
+    IF pId = NIL THEN 
+      os.MkDelX(pTp, pTp.idnt.dfScp); RETURN;       (* PREMATURE RETURN HERE *)
+    END;
+    IF pId.tgXtn # NIL THEN RETURN END;             (* PREMATURE RETURN HERE *)
+
+    class := classOf(os, pId);    
+    namSt := MKSTR(pId.prcNm^);
+    xhrMk := pId.lxDepth > 0;
+   (*
+    *  The incoming argN counts one for a receiver,
+    *  and also counts one for nested procedures.
+    *)
+    IF pId IS Id.MthId THEN pLeng := pTp.argN-1 ELSE pLeng := pTp.argN END;
+   (*
+    *  Now create either a MethodDef or MethodRef
+    *)
+    WITH class : Api.ClassDef DO
+        methD :=  MkMthDef(os, xhrMk, pTp, class, namSt);
+    | class : Api.ClassRef DO
+        methD :=  MkMthRef(os, pTp, class, namSt);
+    END;
+    INC(pTp.argN, pTp.formals.tide);
+    IF pTp.retType # NIL THEN pTp.retN := 1 END;
+    IF (pId.kind = Id.ctorP) OR
+       (pId IS Id.MthId) THEN methD.AddCallConv(Api.CallConv.Instance) END;
+
+    pId.tgXtn := methD;
+    pTp.xName := cln2;  (* an arbitrary "done" marker *)
+
+    IF (pId.kind = Id.fwdPrc) OR (pId.kind = Id.fwdMth) THEN
+      pId.resolve.tgXtn := methD;
+    END;
+  END NumberParams;
+ 
+(* ============================================================ *)
+
+  PROCEDURE (os : PeFile)SwitchHead*(num : INTEGER);
+  BEGIN
+    switch.next := 0;
+    NEW(switch.list, num);
+  END SwitchHead;
+
+  PROCEDURE (os : PeFile)SwitchTail*();
+  BEGIN
+    os.pePI.code.Switch(switch.list);
+    switch.list := NIL;
+  END SwitchTail;
+
+  PROCEDURE (os : PeFile)LstLab*(l : Mu.Label);
+  BEGIN
+    WITH l : PeLab DO
+      switch.list[switch.next] := l.labl; 
+      INC(switch.next);
+    END;
+  END LstLab;
+
+(* ============================================================ *)
+
+  PROCEDURE (os : PeFile)mth(pId : Id.Procs) : Api.Method,NEW;
+  BEGIN
+    ASSERT(pId.tgXtn # NIL);
+    RETURN pId.tgXtn(Api.Method);
+  END mth;
+
+(* -------------------------------- *)
+
+  PROCEDURE (os : PeFile)fld(fId : Id.AbVar)  : Api.Field,NEW;
+    VAR cDf : Api.Class;
+        fNm : Lv.CharOpen;
+        obj : ANYPTR;
+   (* ---------------- *)
+    PROCEDURE AddField(os : PeFile;
+                       cl : Api.Class; 
+                       fn : Lv.CharOpen; 
+                       ty : Sy.Type) : Api.Field;
+      VAR fs : RTS.NativeString;
+    BEGIN
+      fs := MKSTR(fn^);
+      WITH cl : Api.ClassDef DO
+        RETURN cl.AddField(fs, os.typ(ty));
+      |    cl : Api.ClassRef DO
+        RETURN getOrAddField(cl, fs, os.typ(ty));
+      END;
+    END AddField;
+   (* ---------------- *)
+  BEGIN
+    IF fId.tgXtn = NIL THEN
+      WITH fId : Id.VarId DO
+          IF fId.varNm = NIL THEN Mu.MkVarName(fId,os) END;
+          IF fId.recTyp = NIL THEN (* module variable *)
+            cDf := os.dsc(fId.dfScp(Id.BlkId));
+          ELSE                     (* static field    *)
+            cDf := os.cls(fId.recTyp(Ty.Record));
+          END;
+          fNm := fId.varNm;
+      | fId : Id.FldId DO
+          IF fId.fldNm = NIL THEN Mu.MkFldName(fId,os) END;
+          cDf := os.cls(fId.recTyp(Ty.Record));
+          fNm := fId.fldNm;
+      END;
+      fId.tgXtn := AddField(os, cDf, fNm, fId.type);
+    END;
+    obj := fId.tgXtn;
+    WITH obj : Api.Field DO RETURN obj;
+    |    obj : EvtXtn    DO RETURN obj.fldD;
+    END;
+  END fld;
+
+(* -------------------------------- *)
+
+  PROCEDURE (os : PeFile)add(fId : Id.AbVar) : Api.Method,NEW;
+  BEGIN (* returns the descriptor of add_<fieldname> *)
+    IF (fId.tgXtn = NIL) OR ~(fId.tgXtn IS EvtXtn) THEN MkAddRem(os, fId) END;
+    RETURN fId.tgXtn(EvtXtn).addD;
+  END add;
+
+(* -------------------------------- *)
+
+  PROCEDURE (os : PeFile)rem(fId : Id.AbVar) : Api.Method,NEW;
+  BEGIN (* returns the descriptor of remove_<fieldname> *)
+    IF (fId.tgXtn = NIL) OR ~(fId.tgXtn IS EvtXtn) THEN MkAddRem(os, fId) END;
+    RETURN fId.tgXtn(EvtXtn).remD;
+  END rem;
+
+(* -------------------------------- *)
+
+  PROCEDURE (os : PeFile)asm(bId : Id.BlkId) : Api.AssemblyRef,NEW;
+  BEGIN (* returns the assembly reference of this module *)
+    IF bId.tgXtn = NIL THEN os.DoExtern(bId) END;
+    RETURN bId.tgXtn(BlkXtn).asmD;
+  END asm;
+
+(* -------------------------------- *)
+
+  PROCEDURE (os : PeFile)dsc(bId : Id.BlkId) : Api.Class,NEW;
+  BEGIN (* returns descriptor of dummy static class of this module *)
+    IF bId.tgXtn = NIL THEN os.DoExtern(bId) END;
+    RETURN bId.tgXtn(BlkXtn).dscD;
+  END dsc;
+
+(* -------------------------------- *)
+
+  PROCEDURE (os : PeFile)cls(rTy : Ty.Record) : Api.Class,NEW;
+  BEGIN (* returns descriptor for this class *)
+    IF rTy.tgXtn = NIL THEN Mu.MkRecName(rTy, os) END;
+    RETURN rTy.tgXtn(RecXtn).clsD;
+  END cls;
+
+(* -------------------------------- *)
+(*
+ *  PROCEDURE (os : PeFile)box(rTy : Ty.Record) : Api.Class,NEW;
+ *  BEGIN
+ *    IF rTy.tgXtn = NIL THEN Mu.MkRecName(rTy, os) END;
+ *    RETURN rTy.tgXtn(RecXtn).boxD;
+ *  END box;
+ *)
+(* -------------------------------- *)
+
+  PROCEDURE (os : PeFile)new(rTy : Ty.Record) : Api.Method,NEW;
+  BEGIN (* returns the ctor for this reference class *)
+    IF rTy.tgXtn = NIL THEN Mu.MkRecName(rTy, os) END;
+    RETURN rTy.tgXtn(RecXtn).newD;
+  END new;
+
+(* -------------------------------- *)
+
+  PROCEDURE (os : PeFile)dxt(pTy : Ty.Procedure) : DelXtn,NEW;
+  BEGIN (* returns the DelXtn extension for this delegate type *)
+    IF pTy.tgXtn = NIL THEN os.MkDelX(pTy, pTy.idnt.dfScp) END;
+    RETURN pTy.tgXtn(DelXtn);
+  END dxt;
+
+(* -------------------------------- *)
+
+  PROCEDURE mkCopyDef(cDf : Api.ClassDef; val : BOOLEAN) : Api.Method;
+    VAR pra : POINTER TO ARRAY OF Api.Param;
+        prd : Api.Type;
+  BEGIN
+    NEW(pra, 1);
+    prd := cDf;
+    IF val THEN prd := Api.ManagedPointer.init(prd) END;
+    pra[0] := Api.Param.init(0, "src", prd);
+    RETURN cDf.AddMethod(copyS, voidD, pra);
+  END mkCopyDef;
+
+(* -------------------------------- *)
+
+  PROCEDURE (os : PeFile)cpy(rTy : Ty.Record) : Api.Method,NEW;
+    VAR tXtn : RecXtn;
+        tCls : Api.Class;
+        mthX : Api.Method;
+        typA : POINTER TO ARRAY OF Api.Type;
+        valR : BOOLEAN;
+  BEGIN
+    tXtn := rTy.tgXtn(RecXtn);
+    tCls := tXtn.clsD;
+    IF tXtn.cpyD = NIL THEN
+      valR := Mu.isValRecord(rTy);
+      WITH tCls : Api.ClassDef DO
+          mthX := mkCopyDef(tCls, valR);
+      | tCls : Api.ClassRef DO
+          NEW(typA, 1);
+          IF valR THEN 
+            typA[0] := Api.ManagedPointer.init(tCls);
+          ELSE
+            typA[0] := tCls;
+          END;
+          mthX := tCls.AddMethod(copyS, voidD, typA);
+          mthX.AddCallConv(Api.CallConv.Instance);
+      END;
+      tXtn.cpyD := mthX;
+    ELSE
+      mthX := tXtn.cpyD;
+    END;
+    RETURN mthX;
+  END cpy;
+
+(* -------------------------------- *)
+
+  PROCEDURE (os : PeFile)vDl(rTy : Ty.Record) : Api.Field,NEW;
+  BEGIN (* returns descriptor of field "v$" for this boxed value type *)
+    IF rTy.tgXtn = NIL THEN Mu.MkRecName(rTy, os) END;
+    RETURN rTy.tgXtn(RecXtn).vDlr;
+  END vDl;
+
+(* -------------------------------- *)
+
+  PROCEDURE (os : PeFile)typ(tTy : Sy.Type) : Api.Type,NEW;
+    VAR xtn : ANYPTR;
+  BEGIN (* returns Api.Type descriptor for this type *)
+    IF tTy.tgXtn = NIL THEN Mu.MkTypeName(tTy, os) END;
+    xtn := tTy.tgXtn;
+    WITH xtn : Api.Type DO
+        RETURN xtn;
+    | xtn : RecXtn DO
+        RETURN xtn.clsD;
+    | xtn : DelXtn DO
+        RETURN xtn.clsD;
+    END;
+  END typ;
+
+(* ============================================================ *)
+
+  PROCEDURE (os : PeFile)mcd() : Api.ClassRef,NEW;
+  BEGIN (* returns System.MulticastDelegate *)
+    IF multiCD = NIL THEN 
+      multiCD := getOrAddClass(corlib, "System", "MulticastDelegate");
+    END;
+    RETURN multiCD;
+  END mcd;
+
+(* ============================================================ *)
+
+  PROCEDURE (os : PeFile)del() : Api.ClassRef,NEW;
+  BEGIN (* returns System.Delegate *)
+    IF delegat = NIL THEN 
+      delegat := getOrAddClass(corlib, "System", "Delegate");
+    END;
+    RETURN delegat;
+  END del;
+
+(* ============================================================ *)
+
+  PROCEDURE (os : PeFile)rmv() : Api.MethodRef,NEW;
+    VAR prs : POINTER TO ARRAY OF Api.Type;
+        dlg : Api.ClassRef;
+  BEGIN (* returns System.Delegate::Remove *)
+    IF remove = NIL THEN 
+      dlg := os.del();
+      NEW(prs, 2);
+      prs[0] := dlg; 
+      prs[1] := dlg;
+      remove := dlg.AddMethod("Remove", dlg, prs);
+    END;
+    RETURN remove;
+  END rmv;
+
+(* ============================================================ *)
+
+  PROCEDURE (os : PeFile)cmb() : Api.MethodRef,NEW;
+    VAR prs : POINTER TO ARRAY OF Api.Type;
+        dlg : Api.ClassRef;
+  BEGIN (* returns System.Delegate::Combine *)
+    IF combine = NIL THEN 
+      dlg := os.del();
+      NEW(prs, 2);
+      prs[0] := dlg; 
+      prs[1] := dlg;
+      combine := dlg.AddMethod("Combine", dlg, prs);
+    END;
+    RETURN combine;
+  END cmb;
+
+(* ============================================================ *)
+(* ============================================================ *)
+BEGIN
+  evtAdd   := Lv.strToCharOpen("add_"); 
+  evtRem   := Lv.strToCharOpen("remove_"); 
+  cln2     := Lv.strToCharOpen("::"); 
+  boxedObj := Lv.strToCharOpen("Boxed_"); 
+
+  vfldS  := MKSTR("v$");
+  ctorS  := MKSTR(".ctor");
+  invkS  := MKSTR("Invoke");
+  copyS  := MKSTR("__copy__");
+END PeUtil.
+(* ============================================================ *)
+(* ============================================================ *)
+

gpcp/PeUtilForJVM.cp

@@ -0,0 +1,396 @@
+(* ============================================================ *)
+(*  PeUtil is the module which writes PE files using the        *)
+(*  managed interface.                                          *)
+(*  Copyright (c) John Gough 1999, 2000.                        *)
+(* ============================================================ *)
+(* ============================================================ *)
+(*  THIS IS THE EMPTY VERSION, THAT IS REQUIRED TO BOOTSTRAP    *)
+(*  THE JVM VERSION WITHOUT THE MSCORLIB ASSEMBLY AVAILABLE.    *)
+(* ============================================================ *)
+(* ============================================================ *)
+
+MODULE PeUtil;
+
+  IMPORT 
+        GPCPcopyright,
+        Mu  := MsilUtil,
+        Id  := IdDesc,
+        Lv  := LitValue,
+        Sy  := Symbols,
+        Ty  := TypeDesc;
+
+(* ============================================================ *)
+
+  TYPE PeFile*    = POINTER TO RECORD (Mu.MsilFile)
+                 (*   Fields inherited from MsilFile *
+                  *   srcS* : LitValue.CharOpen; (* source file name   *)
+                  *   outN* : LitValue.CharOpen; (* output file name   *)
+                  *   proc* : ProcInfo;
+                  *)
+                    END;
+
+(* ============================================================ *)
+(*                    Constructor Method                        *)
+(* ============================================================ *)
+
+  PROCEDURE newPeFile*(IN nam : ARRAY OF CHAR; isDll : BOOLEAN) : PeFile;
+  BEGIN
+    RETURN NIL;
+  END newPeFile;
+
+(* ============================================================ *)
+
+  PROCEDURE (t : PeFile)fileOk*() : BOOLEAN;
+  BEGIN
+    RETURN FALSE;
+  END fileOk;
+
+(* ============================================================ *)
+
+  PROCEDURE (os : PeFile)MkNewProcInfo*(proc : Sy.Scope);
+  BEGIN
+  END MkNewProcInfo;
+
+(* ============================================================ *)
+
+  PROCEDURE (os : PeFile)newLabel*() : Mu.Label;
+  BEGIN
+    RETURN NIL;
+  END newLabel;
+
+(* ============================================================ *)
+(*                    Exported Methods                  *)
+(* ============================================================ *)
+
+  PROCEDURE (os : PeFile)MethodDecl*(attr : SET; proc : Id.Procs);
+  END MethodDecl;
+
+(* ============================================================ *)
+
+  PROCEDURE (os : PeFile)ExternList*();
+  END ExternList;
+
+(* ============================================================ *)
+
+  PROCEDURE (os : PeFile)DefLab*(l : Mu.Label);
+  END DefLab;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE (os : PeFile)DefLabC*(l : Mu.Label; IN c : ARRAY OF CHAR);
+  END DefLabC;
+
+(* ============================================================ *)
+
+  PROCEDURE (os : PeFile)Code*(code : INTEGER);
+  END Code;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE (os : PeFile)CodeI*(code,int : INTEGER);
+  END CodeI;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE (os : PeFile)CodeT*(code : INTEGER; type : Sy.Type);
+  END CodeT;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE (os : PeFile)CodeTn*(code : INTEGER; type : Sy.Type);
+  END CodeTn;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE (os : PeFile)CodeL*(code : INTEGER; long : LONGINT);
+  END CodeL;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE (os : PeFile)CodeR*(code : INTEGER; real : REAL);
+  END CodeR;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE (os : PeFile)CodeLb*(code : INTEGER; labl : Mu.Label);
+  END CodeLb;
+
+(* ============================================================ *)
+
+  PROCEDURE (os : PeFile)StaticCall*(s : INTEGER; d : INTEGER);
+  END StaticCall;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE (os : PeFile)CodeS*(code : INTEGER; str : INTEGER);
+  END CodeS;
+
+(* ============================================================ *)
+
+  PROCEDURE (os : PeFile)Try*();
+  END Try;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE (os : PeFile)Catch*(proc : Id.Procs);
+  END Catch;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE (os : PeFile)CloseCatch*();
+  END CloseCatch;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE (os : PeFile)CopyCall*(typ : Ty.Record);
+  END CopyCall;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE (os : PeFile)PushStr*(IN str : ARRAY OF CHAR);
+  END PushStr;
+
+(* ============================================================ *)
+
+  PROCEDURE (os : PeFile)CallIT*(code : INTEGER; 
+                                 proc : Id.Procs; 
+                                 type : Ty.Procedure);
+  END CallIT;
+
+(* ============================================================ *)
+
+  PROCEDURE (os : PeFile)CallCT*(proc : Id.Procs; 
+                                 type : Ty.Procedure);
+  END CallCT;
+
+(* ============================================================ *)
+
+  PROCEDURE (os : PeFile)CallDelegate*(typ : Ty.Procedure);
+  END CallDelegate;
+
+(* ============================================================ *)
+
+  PROCEDURE (os : PeFile)PutGetS*(code : INTEGER;
+                                  blk  : Id.BlkId;
+                                  fId  : Id.VarId);
+  END PutGetS;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE (os : PeFile)GetValObj*(code : INTEGER; ptrT : Ty.Pointer);
+  END GetValObj;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE (os : PeFile)PutGetXhr*(code : INTEGER; 
+                                    proc : Id.Procs; 
+                                    locl : Id.LocId);
+  END PutGetXhr;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE (os : PeFile)PutGetF*(code : INTEGER;
+                                  fId  : Id.FldId);
+  END PutGetF;
+
+(* ============================================================ *)
+(* ============================================================ *)
+
+  PROCEDURE (os : PeFile)MkNewRecord*(typ : Ty.Record);
+  END MkNewRecord;
+
+(* ============================================================ *)
+(* ============================================================ *)
+
+  PROCEDURE (os : PeFile)MkNewProcVal*(p : Sy.Idnt;   (* src Proc *)
+                                       t : Sy.Type);  (* dst Type *)
+  END MkNewProcVal;
+
+(* ============================================================ *)
+
+  PROCEDURE (os : PeFile)CallSuper*(rTp : Ty.Record;
+                                    prc : Id.PrcId);
+  END CallSuper;
+
+(* ============================================================ *)
+
+  PROCEDURE (os : PeFile)InitHead*(rTp : Ty.Record;
+                                   prc : Id.PrcId);
+  END InitHead;
+
+(* ============================================================ *)
+
+  PROCEDURE (os : PeFile)CopyHead*(typ : Ty.Record);
+  END CopyHead;
+
+(* ============================================================ *)
+
+  PROCEDURE (os : PeFile)MarkInterfaces*(IN seq : Sy.TypeSeq);
+  END MarkInterfaces;
+
+(* ============================================================ *)
+
+  PROCEDURE (os : PeFile)MainHead*(xAtt : SET);
+  END MainHead;
+
+  PROCEDURE (os : PeFile)SubSys*(xAtt : SET);
+  END SubSys;
+
+(* ============================================================ *)
+
+  PROCEDURE (os : PeFile)StartBoxClass*(rec : Ty.Record;
+                                        att : SET;
+                                        blk : Id.BlkId);
+  END StartBoxClass;
+
+
+  PROCEDURE (os : PeFile)MainTail*();
+  END MainTail;
+
+(* ------------------------------------------------------------ *)
+
+  PROCEDURE (os : PeFile)MethodTail*(id : Id.Procs);
+  END MethodTail;
+
+(* ------------------------------------------------------------ *)
+
+  PROCEDURE (os : PeFile)ClinitTail*();
+  END ClinitTail;
+
+(* ------------------------------------------------------------ *)
+
+  PROCEDURE (os : PeFile)CopyTail*();
+  END CopyTail;
+
+(* ------------------------------------------------------------ *)
+
+  PROCEDURE (os : PeFile)InitTail*(typ : Ty.Record);
+  END InitTail;
+
+(* ============================================================ *)
+
+  PROCEDURE (os : PeFile)ClinitHead*();
+  END ClinitHead;
+
+(* ============================================================ *)
+
+  PROCEDURE (os : PeFile)EmitField*(id : Id.AbVar; att : SET);
+  END EmitField;
+
+(* ============================================================ *)
+
+  PROCEDURE (os : PeFile)EmitEventMethods*(id : Id.AbVar);
+  END EmitEventMethods;
+
+(* ============================================================ *)
+
+  PROCEDURE (os : PeFile)MkAndLinkDelegate*(dl  : Sy.Idnt;
+                                            id  : Sy.Idnt;
+                                            ty  : Sy.Type;
+                                            isA : BOOLEAN);
+  END MkAndLinkDelegate;
+
+(* ============================================================ *)
+(* ============================================================ *)
+
+  PROCEDURE (os : PeFile)EmitPTypeBody*(tId : Id.TypId);
+  END EmitPTypeBody;
+
+(* ============================================================ *)
+(*          End of Procedure Variable and Event Stuff           *)
+(* ============================================================ *)
+
+  PROCEDURE (os : PeFile)Line*(nm : INTEGER),EMPTY;
+
+(* ============================================================ *)
+
+  PROCEDURE (os : PeFile)LoadType*(id : Sy.Idnt);
+  END LoadType;
+
+(* ============================================================ *)
+
+  PROCEDURE (os : PeFile)Finish*();
+  END Finish;
+
+(* ============================================================ *)
+
+  PROCEDURE (os : PeFile)RefRTS*();
+  END RefRTS;
+
+(* ============================================================ *)
+
+  PROCEDURE (os : PeFile)StartNamespace*(nm : Lv.CharOpen);
+  END StartNamespace;
+
+(* ============================================================ *)
+
+  PROCEDURE (os : PeFile)MkBodyClass*(mod : Id.BlkId);
+  END MkBodyClass;
+
+(* ============================================================ *)
+
+  PROCEDURE (os : PeFile)ClassHead*(attSet : SET; 
+                                    thisRc : Ty.Record;
+                                    superT : Ty.Record);
+  END ClassHead;
+
+(* ============================================================ *)
+
+  PROCEDURE (os : PeFile)CheckNestedClass*(typ : Ty.Record;
+                                           scp : Sy.Scope;
+                                           rNm : Lv.CharOpen);
+  END CheckNestedClass;
+
+(* ============================================================ *)
+
+  PROCEDURE (os : PeFile)ClassTail*();
+  END ClassTail;
+
+(* ============================================================ *)
+
+  PROCEDURE (os : PeFile)MkRecX*(t : Ty.Record; s : Sy.Scope);
+  END MkRecX;
+
+(* ============================================================ *)
+
+  PROCEDURE (os : PeFile)MkPtrX*(t : Ty.Pointer);
+  END MkPtrX;
+
+(* ============================================================ *)
+
+  PROCEDURE (os : PeFile)MkArrX*(t : Ty.Array);
+  END MkArrX;
+
+(* ============================================================ *)
+
+  PROCEDURE (os : PeFile)MkBasX*(t : Ty.Base);
+  END MkBasX;
+
+(* ============================================================ *)
+
+  PROCEDURE (os : PeFile)MkEnuX*(t : Ty.Enum; s : Sy.Scope);
+  END MkEnuX;
+
+(* ============================================================ *)
+
+  PROCEDURE (os : PeFile)NumberParams*(pId : Id.Procs; 
+                                       pTp : Ty.Procedure);
+  END NumberParams;
+ 
+(* ============================================================ *)
+
+  PROCEDURE (os : PeFile)SwitchHead*(num : INTEGER);
+  END SwitchHead;
+
+  PROCEDURE (os : PeFile)SwitchTail*();
+  END SwitchTail;
+
+  PROCEDURE (os : PeFile)LstLab*(l : Mu.Label);
+  END LstLab;
+
+(* ============================================================ *)
+(* ============================================================ *)
+END PeUtil.
+(* ============================================================ *)
+(* ============================================================ *)
+

gpcp/PeUtilForNET.cp

@@ -0,0 +1,2521 @@
+(* ============================================================ *)
+(*  PeUtil is the module which writes PE files using the        *)
+(*  managed interface.                                          *)
+(*  Copyright (c) John Gough 1999, 2002.                        *)
+(*  Copyright (c) Queensland University of Technology 2002-2006 *)
+(*  This is the PERWAPI-based prototype, March 2005             *)
+(*    previous versions used the PE-file <writer> PEAPI.        *)
+(* ============================================================ *)
+
+MODULE PeUtil;
+
+  IMPORT 
+        GPCPcopyright,
+        RTS, ASCII,
+        Console,
+        GPText,
+        GPBinFiles,
+        GPTextFiles,
+        FileNames,
+        ClassMaker,
+        MsilBase,
+        NameHash,
+        Mu  := MsilUtil,
+        Lv  := LitValue,
+        Sy  := Symbols,
+        Bi  := Builtin,
+        Id  := IdDesc,
+        Ty  := TypeDesc,
+        Api := "[QUT.PERWAPI]QUT.PERWAPI",
+        Scn := CPascalS,
+        Asm := IlasmCodes,
+        CSt := CompState,
+        Sys := "[mscorlib]System";
+
+(* ============================================================ *)
+
+(*
+ * CONST
+ *      (* various ILASM-specific runtime name strings *)
+ *      initPrefix  = "instance void ";
+ *      initSuffix  = ".ctor() ";
+ *      managedStr  = "il managed";
+ *      specialStr  = "public specialname rtspecialname ";
+ *      cctorStr    = "static void .cctor() ";
+ *      objectInit  = "instance void $o::.ctor() ";
+ *
+ * CONST
+ *      catchStr    = "      catch [mscorlib]System.Exception";
+ *)
+
+(* ============================================================ *)
+(* ============================================================ *)
+
+  TYPE PeFile*    = POINTER TO RECORD (Mu.MsilFile)
+                 (*   Fields inherited from MsilFile *
+                  *   srcS* : LitValue.CharOpen; (* source file name   *)
+                  *   outN* : LitValue.CharOpen; (* output file name   *)
+                  *   proc* : ProcInfo;
+                  *)
+                      peFl  : Api.PEFile;          (* Includes AssemblyDef  *)
+                      clsS  : Api.ClassDef;        (* Dummy static ClassDef *)
+                      clsD  : Api.ClassDef;        (* The current ClassDef  *)
+                      pePI  : PProcInfo;
+                      nmSp  : RTS.NativeString;
+                     (*
+                      *  Friendly access for system classes.
+                      *)
+                      rts      : Api.AssemblyRef;  (* "[RTS]"               *)
+                      cprts    : Api.ClassRef;     (* "[RTS]CP_rts"         *)
+                      progArgs : Api.ClassRef;     (* "[RTS]ProgArgs"       *)
+                    END;
+
+(* ============================================================ *)
+
+  TYPE PProcInfo  = POINTER TO RECORD 
+                      mthD  : Api.MethodDef;
+                      code  : Api.CILInstructions;
+                      tryB  : Api.TryBlock;
+                    END;
+
+(* ============================================================ *)
+
+  TYPE PeLab     = POINTER TO RECORD (Mu.Label)
+                      labl : Api.CILLabel;
+                   END;
+
+  TYPE TypArr    = POINTER TO ARRAY OF Api.Type;
+
+(* ============================================================ *)
+
+  VAR   cln2,                           (* "::"     *) 
+        evtAdd,
+        evtRem,
+        boxedObj       : Lv.CharOpen;
+
+(* ============================================================ *)
+
+  VAR   ctAtt,                          (* public + special + RTspecial *)
+        psAtt,                          (* public + static              *)
+        rmAtt,                          (* runtime managed              *)
+        ilAtt          : INTEGER;       (* cil managed                  *)
+
+  VAR   xhrCl          : Api.ClassRef;  (* the [RTS]XHR class reference *)
+        voidD          : Api.Type;      (* Api.PrimitiveType.Void       *)
+        objtD          : Api.Type;      (* Api.PrimitiveType.Object     *)
+        strgD          : Api.Type;      (* Api.PrimitiveType.String     *)
+        charD          : Api.Type;      (* Api.PrimitiveType.Char       *)
+        charA          : Api.Type;      (* Api.PrimitiveType.Char[]     *)
+        int4D          : Api.Type;      (* Api.PrimitiveType.Int32      *)
+        int8D          : Api.Type;      (* Api.PrimitiveType.Int64      *)
+        flt4D          : Api.Type;      (* Api.PrimitiveType.Float32    *)
+        flt8D          : Api.Type;      (* Api.PrimitiveType.Float64    *)
+        nIntD          : Api.Type;      (* Api.PrimitiveType.NativeInt  *)
+
+  VAR   vfldS          : RTS.NativeString;   (* "v$"    *)
+        copyS          : RTS.NativeString;   (* "copy"  *)
+        ctorS          : RTS.NativeString;   (* ".ctor" *)
+        invkS          : RTS.NativeString;   (* Invoke  *)
+        
+  VAR   defSrc : Api.SourceFile;
+
+  VAR   rHelper : ARRAY Mu.rtsLen OF Api.MethodRef;
+        mathCls : Api.ClassRef;
+        envrCls : Api.ClassRef;
+        excpCls : Api.ClassRef;
+        rtTpHdl : Api.ClassRef;
+        loadTyp : Api.MethodRef;
+        newObjt : Api.MethodRef;
+        multiCD : Api.ClassRef;     (* System.MulticastDelegate *)
+        delegat : Api.ClassRef;     (* System.Delegate          *)
+        combine : Api.MethodRef;    (* System.Delegate::Combine *)
+        remove  : Api.MethodRef;    (* System.Delegate::Remove  *)
+        corlib  : Api.AssemblyRef;  (* [mscorlib]               *)
+        
+(* ============================================================ *)
+(*      Data Structure for tgXtn field of BlkId descriptors     *)
+(* ============================================================ *)
+
+  TYPE BlkXtn = POINTER TO RECORD
+                  asmD : Api.AssemblyRef; (* This AssemblyRef   *)
+                  dscD : Api.Class;       (* Dummy Static Class *)
+                END;
+
+(* ============================================================ *)
+(*          Data Structure for Switch Statement Encoding        *)
+(* ============================================================ *)
+
+  TYPE Switch = RECORD
+                  list : POINTER TO ARRAY OF Api.CILLabel;
+                  next : INTEGER;
+                END;
+
+  VAR  switch : Switch;
+
+(* ============================================================ *)
+(*      Data Structure for tgXtn field of procedure types       *)
+(* ============================================================ *)
+
+  TYPE DelXtn = POINTER TO RECORD
+                  clsD : Api.Class;      (* Implementing class  *)
+                  newD : Api.Method;     (* Constructor method  *)
+                  invD : Api.Method;     (* The Invoke method   *)
+                END;
+
+(* ============================================================ *)
+(*      Data Structure for tgXtn field of event variables       *)
+(* ============================================================ *)
+
+  TYPE EvtXtn = POINTER TO RECORD
+                  fldD : Api.Field;      (* Field descriptor    *)
+                  addD : Api.Method;     (* add_<field> method  *)
+                  remD : Api.Method;     (* rem_<field> method  *)
+                END;
+
+(* ============================================================ *)
+(*      Data Structure for tgXtn field of Record types          *)
+(* ============================================================ *)
+
+  TYPE RecXtn = POINTER TO RECORD
+                  clsD : Api.Class;
+                  boxD : Api.Class;
+                  newD : Api.Method;
+                  cpyD : Api.Method;
+                  vDlr : Api.Field;
+                END;
+
+(* ============================================================ *)
+(*                    Constructor Method                        *)
+(* ============================================================ *)
+
+  PROCEDURE newPeFile*(IN nam : ARRAY OF CHAR; isDll : BOOLEAN) : PeFile;
+    VAR f : PeFile;
+        ver : INTEGER;
+   (* ------------------------------------------------------- *)
+    PROCEDURE file(IN f,a : ARRAY OF CHAR; d : BOOLEAN) : Api.PEFile;
+      VAR pef : Api.PEFile;
+    BEGIN 
+      pef := Api.PEFile.init(MKSTR(f), MKSTR(a));
+      pef.SetIsDLL(d);
+      IF CSt.binDir # "" THEN
+        pef.SetOutputDirectory(MKSTR(CSt.binDir));
+      END;
+      RETURN pef;
+    RESCUE (x) 
+      RETURN NIL;
+    END file;
+   (* ------------------------------------------------------- *)
+  BEGIN
+    NEW(f);
+(*
+ *  f.peFl := file(nam, isDll);
+ *)
+    IF isDll THEN
+      f.outN := BOX(nam + ".DLL");
+    ELSE
+      f.outN := BOX(nam + ".EXE");
+    END;
+(* -- start replacement -- *)
+    f.peFl := file(f.outN, nam, isDll);
+(* --- end replacement --- *)
+   (*
+    *  Initialize local variables holding common attributes.
+    *)
+    ctAtt := Api.MethAttr.Public + Api.MethAttr.SpecialRTSpecialName;
+    psAtt := Api.MethAttr.Public + Api.MethAttr.Static;
+    ilAtt := Api.ImplAttr.IL;
+    rmAtt := Api.ImplAttr.Runtime;
+   (*
+    *  Initialize local variables holding primitive type-enums.
+    *)
+    voidD := Api.PrimitiveType.Void;
+    objtD := Api.PrimitiveType.Object;
+    strgD := Api.PrimitiveType.String;
+    int4D := Api.PrimitiveType.Int32;
+    int8D := Api.PrimitiveType.Int64;
+    flt4D := Api.PrimitiveType.Float32;
+    flt8D := Api.PrimitiveType.Float64;
+    charD := Api.PrimitiveType.Char;
+    charA := Api.ZeroBasedArray.init(Api.PrimitiveType.Char);
+    nIntD := Api.PrimitiveType.IntPtr;
+
+    f.peFl.SetNetVersion(Api.NetVersion.Version2);
+
+    (*ver := f.peFl.GetNetVersion();*)
+
+    RETURN f;
+  END newPeFile;
+
+(* ============================================================ *)
+
+  PROCEDURE (t : PeFile)fileOk*() : BOOLEAN;
+  BEGIN
+    RETURN t.peFl # NIL;
+  END fileOk;
+
+(* ============================================================ *)
+
+  PROCEDURE (os : PeFile)MkNewProcInfo*(proc : Sy.Scope);
+    VAR p : PProcInfo;
+  BEGIN
+    NEW(os.proc);
+    NEW(os.pePI);
+    Mu.InitProcInfo(os.proc, proc);
+  END MkNewProcInfo;
+
+(* ============================================================ *)
+
+  PROCEDURE (os : PeFile)newLabel*() : Mu.Label;
+    VAR label : PeLab;
+  BEGIN
+    NEW(label); 
+    label.labl := os.pePI.code.NewLabel();
+    RETURN label;
+  END newLabel;
+
+(* ============================================================ *)
+(*                    Various utilities                         *)
+(* ============================================================ *)
+
+  PROCEDURE^ (os : PeFile)CallCombine(typ : Sy.Type; add : BOOLEAN),NEW;
+  PROCEDURE^ (os : PeFile)CodeLb*(code : INTEGER; labl : Mu.Label);
+  PROCEDURE^ (os : PeFile)DefLabC*(l : Mu.Label; IN c : ARRAY OF CHAR);
+  PROCEDURE^ (os : PeFile)Locals(),NEW;
+
+  PROCEDURE^ MkMthDef(os  : PeFile;
+                      xhr : BOOLEAN;
+                      pTp : Ty.Procedure;
+                      cls : Api.ClassDef;
+                      str : RTS.NativeString)  : Api.MethodDef;
+
+  PROCEDURE^ MkMthRef(os  : PeFile;
+                      pTp : Ty.Procedure;
+                      cls : Api.ClassRef;
+                      str : RTS.NativeString) : Api.MethodRef;
+
+  PROCEDURE^ (os : PeFile)mth(pId : Id.Procs)  : Api.Method,NEW;
+  PROCEDURE^ (os : PeFile)fld(fId : Id.AbVar)  : Api.Field,NEW;
+  PROCEDURE^ (os : PeFile)add(fId : Id.AbVar)  : Api.Method,NEW;
+  PROCEDURE^ (os : PeFile)rem(fId : Id.AbVar)  : Api.Method,NEW;
+  PROCEDURE^ (os : PeFile)asm(bId : Id.BlkId)  : Api.AssemblyRef,NEW;
+  PROCEDURE^ (os : PeFile)dsc(bId : Id.BlkId)  : Api.Class,NEW;
+  PROCEDURE^ (os : PeFile)cls(rTy : Ty.Record) : Api.Class,NEW;
+  PROCEDURE^ (os : PeFile)new(rTy : Ty.Record) : Api.Method,NEW;
+  PROCEDURE^ (os : PeFile)cpy(rTy : Ty.Record) : Api.Method,NEW;
+  PROCEDURE^ (os : PeFile)typ(tTy : Sy.Type)   : Api.Type,NEW;
+  PROCEDURE^ (os : PeFile)vDl(rTy : Ty.Record) : Api.Field,NEW;
+  PROCEDURE^ (os : PeFile)dxt(pTy : Ty.Procedure) : DelXtn,NEW;
+  PROCEDURE^ (os : PeFile)mcd() : Api.ClassRef,NEW;
+  PROCEDURE^ (os : PeFile)rmv() : Api.MethodRef,NEW;
+  PROCEDURE^ (os : PeFile)cmb() : Api.MethodRef,NEW;
+(*
+ *  PROCEDURE^ box(os : PeFile; rTy : Ty.Record) : Api.Class;
+ *)
+(* ============================================================ *)
+(*                    Private Methods                        *)
+(* ============================================================ *)
+
+  PROCEDURE boxedName(typ : Ty.Record) : RTS.NativeString;
+  BEGIN
+    ASSERT(typ.xName # NIL);
+    RETURN MKSTR(boxedObj^ + typ.xName^);
+  END boxedName;
+
+(* ============================================================ *)
+
+  PROCEDURE nms(idD : Sy.Idnt) : RTS.NativeString;
+  BEGIN
+    RETURN MKSTR(Sy.getName.ChPtr(idD)^);
+  END nms;
+
+(* ============================================================ *)
+
+  PROCEDURE toTypeAttr(attr : SET) : INTEGER;
+    VAR result : INTEGER;
+  BEGIN
+    CASE ORD(attr * {0 .. 3}) OF
+    | ORD(Asm.att_public)  : result := Api.TypeAttr.Public;
+    | ORD(Asm.att_empty)   : result := Api.TypeAttr.Private;
+    END;
+    IF attr * Asm.att_sealed # {}    THEN 
+      INC(result, Api.TypeAttr.Sealed);
+    END;
+    IF attr * Asm.att_abstract # {}  THEN 
+      INC(result, Api.TypeAttr.Abstract);
+    END;
+    IF attr * Asm.att_interface # {} THEN 
+      INC(result, Api.TypeAttr.Interface + Api.TypeAttr.Abstract);
+    END;
+(*
+ *  what are "Import, AutoClass, UnicodeClass, *SpecialName" ? 
+ *)
+    RETURN result;
+  END toTypeAttr;
+
+  
+(* ------------------------------------------------ *)
+(*              New code for PERWAPI                *)
+(* ------------------------------------------------ *)
+
+  PROCEDURE getOrAddClass(mod : Api.ReferenceScope; 
+                          nms : RTS.NativeString;
+                          nam : RTS.NativeString) : Api.ClassRef;
+    VAR cls : Api.Class;
+  BEGIN
+    cls := mod.GetClass(nms, nam);
+    IF cls = NIL THEN cls := mod.AddClass(nms, nam) END;
+    RETURN cls(Api.ClassRef);
+  END getOrAddClass;
+
+  PROCEDURE getOrAddValueClass(mod : Api.ReferenceScope; 
+                               nms : RTS.NativeString;
+                               nam : RTS.NativeString) : Api.ClassRef;
+    VAR cls : Api.Class;
+  BEGIN
+    cls := mod.GetClass(nms, nam);
+    IF cls = NIL THEN cls := mod.AddValueClass(nms, nam) END;
+    RETURN cls(Api.ClassRef);
+  END getOrAddValueClass;
+
+  PROCEDURE getOrAddMethod(cls : Api.ClassRef; 
+                           nam : RTS.NativeString;
+                           ret : Api.Type;
+                           prs : TypArr) : Api.MethodRef;
+    VAR mth : Api.Method;
+  BEGIN
+    mth := cls.GetMethod(nam, prs);
+    IF mth = NIL THEN mth := cls.AddMethod(nam, ret, prs) END;
+    RETURN mth(Api.MethodRef);
+  END getOrAddMethod;
+
+  PROCEDURE getOrAddField(cls : Api.ClassRef; 
+                          nam : RTS.NativeString;
+                          typ : Api.Type) : Api.FieldRef;
+    VAR fld : Api.FieldRef;
+  BEGIN
+    fld := cls.GetField(nam);
+    IF fld = NIL THEN fld := cls.AddField(nam, typ) END;
+    RETURN fld(Api.FieldRef);
+  END getOrAddField;
+
+(* ------------------------------------------------ *)
+
+  PROCEDURE toMethAttr(attr : SET) : INTEGER;
+    VAR result : INTEGER;
+  BEGIN
+    CASE ORD(attr * {0 .. 3}) OF
+    | ORD(Asm.att_assembly)  : result := Api.MethAttr.Assembly;
+    | ORD(Asm.att_public)    : result := Api.MethAttr.Public;
+    | ORD(Asm.att_private)   : result := Api.MethAttr.Private;
+    | ORD(Asm.att_protected) : result := Api.MethAttr.Family;
+    END;
+    IF  5 IN attr THEN INC(result, Api.MethAttr.Static) END;
+    IF  6 IN attr THEN INC(result, Api.MethAttr.Final) END;
+    IF  8 IN attr THEN INC(result, Api.MethAttr.Abstract) END;
+    IF  9 IN attr THEN INC(result, Api.MethAttr.NewSlot) END;
+    IF 13 IN attr THEN INC(result, Api.MethAttr.Virtual) END;
+    RETURN result;
+  END toMethAttr;
+
+(* ------------------------------------------------ *)
+
+  PROCEDURE toFieldAttr(attr : SET) : INTEGER;
+    VAR result : INTEGER;
+  BEGIN
+    CASE ORD(attr * {0 .. 3}) OF
+    | ORD(Asm.att_empty)     : result := Api.FieldAttr.Default;
+    | ORD(Asm.att_assembly)  : result := Api.FieldAttr.Assembly;
+    | ORD(Asm.att_public)    : result := Api.FieldAttr.Public;
+    | ORD(Asm.att_private)   : result := Api.FieldAttr.Private;
+    | ORD(Asm.att_protected) : result := Api.FieldAttr.Family;
+    END;
+    IF  5 IN attr THEN INC(result, Api.FieldAttr.Static) END;
+   (* what about Initonly? *)
+    RETURN result;
+  END toFieldAttr;
+
+(* ------------------------------------------------ *)
+
+  PROCEDURE (os : PeFile)MkCodeBuffer(),NEW;
+  BEGIN
+    ASSERT((defSrc # NIL) & (os.pePI.mthD # NIL));
+    os.pePI.code := os.pePI.mthD.CreateCodeBuffer();
+    os.pePI.code.OpenScope();
+    os.pePI.code.set_DefaultSourceFile(defSrc);
+  END MkCodeBuffer;
+
+(* ============================================================ *)
+(*                    Exported Methods                  *)
+(* ============================================================ *)
+
+  PROCEDURE (os : PeFile)MethodDecl*(attr : SET; proc : Id.Procs);
+    VAR prcT : Ty.Procedure; (* NOT NEEDED? *)
+        prcD : Api.MethodDef;
+  BEGIN
+   (*
+    *   Set the various attributes
+    *)
+    prcD := os.mth(proc)(Api.MethodDef);
+    prcD.AddMethAttribute(toMethAttr(attr));
+    prcD.AddImplAttribute(ilAtt);
+    os.pePI.mthD := prcD;
+    IF attr * Asm.att_abstract = {} THEN os.MkCodeBuffer() END;
+  END MethodDecl;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE (os : PeFile)DoExtern(blk : Id.BlkId),NEW;
+ (*
+  *  Add references to all imported assemblies.
+  *)
+    VAR  asmRef  : Api.AssemblyRef;
+         blkXtn  : BlkXtn;
+   (* ----------------------------------------- *)
+    PROCEDURE AsmName(bk : Id.BlkId) : Lv.CharOpen;
+      VAR ix : INTEGER;
+          ln : INTEGER;
+          ch : CHAR;
+          cp : Lv.CharOpen;
+    BEGIN
+      IF Sy.isFn IN bk.xAttr THEN
+        ln := 0;
+        FOR ix := LEN(bk.scopeNm) - 1 TO 1 BY -1 DO
+          IF bk.scopeNm[ix] = "]" THEN ln := ix END;
+        END;
+        IF (ln = 0 ) OR (bk.scopeNm[0] # '[') THEN 
+                          RTS.Throw("bad extern name "+bk.scopeNm^) END;
+        NEW(cp, ln);
+        FOR ix := 1 TO ln-1 DO cp[ix-1] := bk.scopeNm[ix] END;
+        cp[ln-1] := 0X;
+        RETURN cp;
+      ELSE
+        RETURN bk.xName;
+      END;
+    END AsmName;
+   (* ----------------------------------------- *)
+    PROCEDURE MkBytes(t1, t2 : INTEGER) : POINTER TO ARRAY OF UBYTE;
+      VAR bIx : INTEGER;
+          tok : POINTER TO ARRAY OF UBYTE;
+    BEGIN [UNCHECKED_ARITHMETIC]
+      NEW(tok, 8);
+      FOR bIx := 3 TO 0 BY -1 DO
+        tok[bIx] := USHORT(t1 MOD 256);
+        t1 := t1 DIV 256;
+      END;
+      FOR bIx := 7 TO 4 BY -1 DO
+        tok[bIx] := USHORT(t2 MOD 256);
+        t2 := t2 DIV 256;
+      END;
+      RETURN tok;
+    END MkBytes;
+   (* ----------------------------------------- *)
+  BEGIN
+    IF blk.xName = NIL THEN Mu.MkBlkName(blk) END;
+    asmRef := os.peFl.MakeExternAssembly(MKSTR(AsmName(blk)^));
+    NEW(blkXtn);
+    blk.tgXtn := blkXtn;
+    blkXtn.asmD := asmRef;
+    blkXtn.dscD := getOrAddClass(asmRef, 
+                                 MKSTR(blk.pkgNm^), 
+                                 MKSTR(blk.clsNm^));
+    IF blk.verNm # NIL THEN
+      asmRef.AddVersionInfo(blk.verNm[0], blk.verNm[1], 
+                            blk.verNm[2], blk.verNm[3]);
+      IF (blk.verNm[4] # 0) OR (blk.verNm[5] # 0) THEN
+        asmRef.AddKeyToken(MkBytes(blk.verNm[4], blk.verNm[5]));
+      END;
+    END;
+  END DoExtern;
+
+(* ============================================================ *)
+
+  PROCEDURE (os : PeFile)DoRtsMod(blk : Id.BlkId),NEW;
+ (*
+  *  Add references to all imported assemblies.
+  *)
+    VAR blkD : BlkXtn;
+  BEGIN
+    IF blk.xName = NIL THEN Mu.MkBlkName(blk) END;
+    NEW(blkD);
+    blkD.asmD := os.rts;
+    blkD.dscD := os.rts.AddClass("", MKSTR(blk.clsNm^));
+    blk.tgXtn := blkD;
+  END DoRtsMod;
+
+(* ============================================================ *)
+
+  PROCEDURE (os : PeFile)CheckNestedClass*(typ : Ty.Record;
+                                           scp : Sy.Scope;
+                                           str : Lv.CharOpen);
+    VAR len : INTEGER;
+        idx : INTEGER;
+        jdx : INTEGER;
+        kdx : INTEGER;
+        hsh : INTEGER;
+        tId : Sy.Idnt;
+  BEGIN
+   (* 
+    *  Find last occurrence of '$', except at index 0  
+    *  
+    *  We seek the last occurrence because this method might
+    *  be called recursively for a deeply nested class A$B$C.
+    *)
+    len := LEN(str$); (* LEN(x$) doen't count nul, therefore str[len] = 0X *)
+    FOR idx := len TO 1 BY -1 DO
+      IF str[idx] = '$' THEN (* a nested class *)
+        str[idx] := 0X; (* terminate the string early *)
+        hsh := NameHash.enterStr(str);
+        tId := Sy.bind(hsh, scp);
+        
+        IF (tId = NIL) OR ~(tId IS Id.TypId) THEN 
+          RTS.Throw(
+             "Foreign Class <" + str^ + "> not found in <" + typ.extrnNm^ + ">"
+          );
+        ELSE
+          typ.encCls := tId.type.boundRecTp();
+          jdx := 0; kdx := idx+1;
+          WHILE kdx <= len DO str[jdx] := str[kdx]; INC(kdx); INC(jdx) END;
+        END;
+        RETURN;
+      END;
+    END;
+  END CheckNestedClass;
+
+(* ============================================================ *)
+
+  PROCEDURE (os : PeFile)ExternList*();
+    VAR idx : INTEGER;
+        blk : Id.BlkId;
+  BEGIN
+    FOR idx := 0 TO CSt.impSeq.tide-1 DO
+      blk := CSt.impSeq.a[idx](Id.BlkId);
+      IF (Sy.need IN blk.xAttr)  &
+         (blk.tgXtn = NIL) THEN 
+        IF ~(Sy.rtsMd IN blk.xAttr) THEN 
+          os.DoExtern(blk);
+        ELSE
+          os.DoRtsMod(blk);
+        END;
+      END;
+    END;
+  END ExternList;
+
+(* ============================================================ *)
+
+  PROCEDURE (os : PeFile)DefLab*(l : Mu.Label);
+  BEGIN
+    os.pePI.code.CodeLabel(l(PeLab).labl);
+  END DefLab;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE (os : PeFile)DefLabC*(l : Mu.Label; IN c : ARRAY OF CHAR);
+  BEGIN
+    os.pePI.code.CodeLabel(l(PeLab).labl);
+  END DefLabC;
+
+(* ============================================================ *)
+
+  PROCEDURE (os : PeFile)Code*(code : INTEGER);
+  BEGIN
+    os.pePI.code.Inst(Asm.cd[code]);
+    os.Adjust(Asm.dl[code]);
+  END Code;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE (os : PeFile)CodeF(code : INTEGER;
+                               fld  : Api.Field), NEW;
+  BEGIN
+    os.pePI.code.FieldInst(Asm.cd[code], fld);
+    os.Adjust(Asm.dl[code]);
+  END CodeF;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE (os : PeFile)CodeI*(code,int : INTEGER);
+  BEGIN
+    os.pePI.code.IntInst(Asm.cd[code],int);
+    os.Adjust(Asm.dl[code]);
+  END CodeI;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE (os : PeFile)CodeT*(code : INTEGER; type : Sy.Type);
+    VAR xtn : Api.Type;
+  BEGIN
+    xtn := os.typ(type);
+    os.pePI.code.TypeInst(Asm.cd[code], xtn);
+    os.Adjust(Asm.dl[code]);
+  END CodeT;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE (os : PeFile)CodeTn*(code : INTEGER; type : Sy.Type);
+    VAR xtn : Api.Type;
+  BEGIN
+    xtn := os.typ(type);
+    os.pePI.code.TypeInst(Asm.cd[code], xtn);
+    os.Adjust(Asm.dl[code]);
+  END CodeTn;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE (os : PeFile)CodeL*(code : INTEGER; long : LONGINT);
+  BEGIN
+    ASSERT(code = Asm.opc_ldc_i8);
+    os.pePI.code.ldc_i8(long);
+    os.Adjust(1);
+  END CodeL;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE (os : PeFile)CodeR*(code : INTEGER; real : REAL);
+  BEGIN
+    IF code = Asm.opc_ldc_r8 THEN
+      os.pePI.code.ldc_r8(real);
+    ELSIF code = Asm.opc_ldc_r4 THEN
+      os.pePI.code.ldc_r4(SHORT(real));
+    ELSE
+      ASSERT(FALSE);
+    END;
+    os.Adjust(1);
+  END CodeR;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE (os : PeFile)CodeLb*(code : INTEGER; labl : Mu.Label);
+  BEGIN
+    os.pePI.code.Branch(Asm.cd[code], labl(PeLab).labl);
+  END CodeLb;
+
+(* ============================================================ *)
+
+  PROCEDURE (os : PeFile)getMethod(s : INTEGER) : Api.Method,NEW;
+    VAR  mth : Api.MethodRef;
+         cpr : Api.ClassRef;
+         msc : Api.ClassRef;
+         sys : Api.ClassRef;
+  (* ----------------------------------- *)
+    PROCEDURE p1(p : Api.Type) : TypArr;
+      VAR a : TypArr;
+    BEGIN
+      NEW(a,1);
+      a[0] := p;
+      RETURN a;
+    END p1;
+  (* ----------------------------------- *)
+    PROCEDURE p2(p,q : Api.Type) : TypArr;
+      VAR a : TypArr;
+    BEGIN
+      NEW(a,2);
+      a[0] := p;
+      a[1] := q;
+      RETURN a;
+    END p2;
+  (* ----------------------------------- *)
+  BEGIN
+   (*
+    *  Lazy evaluation of array elements
+    *)
+    mth := rHelper[s];
+    IF mth = NIL THEN
+      cpr := os.cprts;
+      CASE s OF
+      | Mu.vStr2ChO  : mth := cpr.AddMethod("strToChO",charA,p1(strgD));
+      | Mu.vStr2ChF  : mth := cpr.AddMethod("StrToChF",voidD,p2(charA,strgD));
+      | Mu.aStrLen   : mth := cpr.AddMethod("chrArrLength",int4D,p1(charA));
+      | Mu.aStrChk   : mth := cpr.AddMethod("ChrArrCheck",voidD,p1(charA));
+      | Mu.aStrLp1   : mth := cpr.AddMethod("chrArrLplus1",int4D,p1(charA));
+      | Mu.aaStrCmp  : mth := cpr.AddMethod("strCmp",int4D,p2(charA,charA));
+      | Mu.aaStrCopy : mth := cpr.AddMethod("Stringify",voidD,p2(charA,charA));
+      | Mu.CpModI    : mth := cpr.AddMethod("CpModI",int4D,p2(int4D,int4D));
+      | Mu.CpDivI    : mth := cpr.AddMethod("CpDivI",int4D,p2(int4D,int4D));
+      | Mu.CpModL    : mth := cpr.AddMethod("CpModL",int8D,p2(int8D,int8D));
+      | Mu.CpDivL    : mth := cpr.AddMethod("CpDivL",int8D,p2(int8D,int8D));
+      | Mu.caseMesg  : mth := cpr.AddMethod("caseMesg",strgD,p1(int4D));
+      | Mu.withMesg  : mth := cpr.AddMethod("withMesg",strgD,p1(objtD));
+      | Mu.chs2Str   : mth :=  cpr.AddMethod("mkStr",strgD,p1(charA));
+      | Mu.CPJstrCatAA : mth := cpr.AddMethod("aaToStr",strgD,p2(charA,charA));
+      | Mu.CPJstrCatSA : mth := cpr.AddMethod("saToStr",strgD,p2(strgD,charA));
+      | Mu.CPJstrCatAS : mth := cpr.AddMethod("asToStr",strgD,p2(charA,strgD));
+      | Mu.CPJstrCatSS : mth := cpr.AddMethod("ssToStr",strgD,p2(strgD,strgD));
+
+      | Mu.toUpper   :  sys := getOrAddClass(corlib, "System", "Char");
+                        mth := getOrAddMethod(sys,"ToUpper",charD,p1(charD));
+
+      | Mu.sysExit   :  IF envrCls = NIL THEN
+                          envrCls := 
+                               getOrAddClass(corlib, "System", "Environment");
+                        END;
+                        mth := getOrAddMethod(envrCls,"Exit",voidD,p1(int4D));
+
+      | Mu.mkExcept  :  IF excpCls = NIL THEN
+                          IF CSt.ntvExc.tgXtn = NIL THEN
+                            excpCls := 
+                                  getOrAddClass(corlib, "System", "Exception");
+                            CSt.ntvExc.tgXtn := excpCls;
+                          ELSE
+                            excpCls := CSt.ntvExc.tgXtn(Api.ClassRef);
+                          END;
+                        END;
+                        sys := CSt.ntvExc.tgXtn(Api.ClassRef);
+(*
+ *                      mth := sys.AddMethod(ctorS,voidD,p1(strgD));
+ *)
+                        mth := getOrAddMethod(sys,ctorS,voidD,p1(strgD));
+                        mth.AddCallConv(Api.CallConv.Instance);
+
+      | Mu.getTpM    :  IF CSt.ntvTyp.tgXtn = NIL THEN
+                          CSt.ntvTyp.tgXtn := 
+                                  getOrAddClass(corlib, "System", "Type");
+                        END;
+                        sys := CSt.ntvTyp.tgXtn(Api.ClassRef);
+                        mth := getOrAddMethod(sys,"GetType",sys,NIL);
+                        mth.AddCallConv(Api.CallConv.Instance);
+
+      | Mu.dFloor, Mu.dAbs, Mu.fAbs, Mu.iAbs, Mu.lAbs :
+          IF mathCls = NIL THEN
+            mathCls := getOrAddClass(corlib, "System", "Math");
+          END;
+          rHelper[Mu.dFloor] := getOrAddMethod(mathCls,"Floor",flt8D,p1(flt8D));
+          rHelper[Mu.dAbs]   := getOrAddMethod(mathCls,"Abs",flt8D,p1(flt8D));
+          rHelper[Mu.fAbs]   := getOrAddMethod(mathCls,"Abs",flt4D,p1(flt4D));
+          rHelper[Mu.iAbs]   := getOrAddMethod(mathCls,"Abs",int4D,p1(int4D));
+          rHelper[Mu.lAbs]   := getOrAddMethod(mathCls,"Abs",int8D,p1(int8D));
+          mth := rHelper[s];
+      END;
+      rHelper[s] := mth;
+    END;
+    RETURN mth;
+  END getMethod;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE (os : PeFile)StaticCall*(s : INTEGER; d : INTEGER);
+    VAR mth : Api.Method;
+  BEGIN
+    mth := os.getMethod(s);
+    os.pePI.code.MethInst(Asm.cd[Asm.opc_call], mth);
+    os.Adjust(d);
+  END StaticCall;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE (os : PeFile)CodeS*(code : INTEGER; str : INTEGER);
+    VAR mth : Api.Method;
+  BEGIN
+    mth := os.getMethod(str);
+    os.pePI.code.MethInst(Asm.cd[code], mth);
+  END CodeS;
+
+(* ============================================================ *)
+
+  PROCEDURE (os : PeFile)Try*();
+    VAR retT : Sy.Type;
+  BEGIN
+    os.proc.exLb := os.newLabel();
+    retT := os.proc.prId.type.returnType();
+    IF retT # NIL THEN os.proc.rtLc := os.proc.newLocal(retT) END;
+    os.pePI.code.StartBlock();
+  END Try;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE (os : PeFile)Catch*(proc : Id.Procs);
+  BEGIN
+    os.pePI.tryB := os.pePI.code.EndTryBlock();
+    os.pePI.code.StartBlock();
+    os.Adjust(1);	(* allow for incoming exception reference *)
+    os.StoreLocal(proc.except.varOrd);
+  END Catch;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE (os : PeFile)CloseCatch*();
+  BEGIN
+    IF excpCls = NIL THEN
+      IF CSt.ntvExc.tgXtn = NIL THEN
+        excpCls := getOrAddClass(corlib, "System", "Exception");
+        CSt.ntvExc.tgXtn := excpCls;
+      ELSE
+        excpCls := CSt.ntvExc.tgXtn(Api.ClassRef);
+      END;
+    END;
+    os.pePI.code.EndCatchBlock(excpCls, os.pePI.tryB);
+  END CloseCatch;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE (os : PeFile)CopyCall*(typ : Ty.Record);
+  BEGIN
+    os.pePI.code.MethInst(Asm.cd[Asm.opc_call], os.cpy(typ));
+    os.Adjust(-2);
+  END CopyCall;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE (os : PeFile)PushStr*(IN str : ARRAY OF CHAR);
+  (* Use target quoting conventions for the literal string *)
+  BEGIN
+    os.pePI.code.ldstr(MKSTR(str));
+    os.Adjust(1);
+  END PushStr;
+
+(* ============================================================ *)
+
+  PROCEDURE (os : PeFile)CallIT*(code : INTEGER; 
+                                 proc : Id.Procs; 
+                                 type : Ty.Procedure);
+    VAR xtn : Api.Method;
+  BEGIN
+    xtn := os.mth(proc);
+    os.pePI.code.MethInst(Asm.cd[code], xtn);
+    os.Adjust(type.retN - type.argN);        
+  END CallIT;
+
+(* ============================================================ *)
+
+  PROCEDURE (os : PeFile)CallCT*(proc : Id.Procs; 
+                                 type : Ty.Procedure);
+    VAR xtn : Api.Method;
+  BEGIN
+    ASSERT(proc.tgXtn # NIL);
+    xtn := proc.tgXtn(Api.Method);
+    os.pePI.code.MethInst(Asm.cd[Asm.opc_newobj], xtn);
+    os.Adjust(-type.argN);        
+  END CallCT;
+
+(* ============================================================ *)
+
+  PROCEDURE (os : PeFile)CallDelegate*(typ : Ty.Procedure);
+    VAR xtn : Api.Method;
+  BEGIN
+    ASSERT(typ.tgXtn # NIL);
+(*
+ *  xtn := typ.tgXtn(DelXtn).invD;
+ *)
+    xtn := os.dxt(typ).invD;
+    os.pePI.code.MethInst(Asm.cd[Asm.opc_callvirt], xtn);
+    os.Adjust(-typ.argN + typ.retN);        
+  END CallDelegate;
+
+(* ============================================================ *)
+
+  PROCEDURE (os : PeFile)PutGetS*(code : INTEGER;
+                                  blk  : Id.BlkId;
+                                  fId  : Id.VarId);
+  (* Emit putstatic and getstatic for static field *)
+  BEGIN
+    os.pePI.code.FieldInst(Asm.cd[code], os.fld(fId));
+    os.Adjust(Asm.dl[code]);
+  END PutGetS;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE (os : PeFile)GetValObj*(code : INTEGER; ptrT : Ty.Pointer);
+    VAR rTp : Ty.Record;
+  BEGIN
+    rTp := ptrT.boundRecTp()(Ty.Record);
+    os.pePI.code.FieldInst(Asm.cd[code], os.vDl(rTp));
+    os.Adjust(Asm.dl[code]);
+  END GetValObj;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE (os : PeFile)PutGetXhr*(code : INTEGER; 
+                                    proc : Id.Procs; 
+                                    locl : Id.LocId);
+    VAR ix   : INTEGER;
+        name : Lv.CharOpen;
+        recT : Ty.Record;
+        fldI : Id.FldId;
+  BEGIN
+    ix := 0;
+    recT := proc.xhrType.boundRecTp()(Ty.Record);
+    WHILE recT.fields.a[ix].hash # locl.hash DO INC(ix) END;;
+    os.pePI.code.FieldInst(Asm.cd[code], os.fld(recT.fields.a[ix](Id.FldId)));
+  END PutGetXhr;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE (os : PeFile)PutGetF*(code : INTEGER;
+                                  fId  : Id.FldId);
+  BEGIN
+    os.pePI.code.FieldInst(Asm.cd[code], os.fld(fId));
+    os.Adjust(Asm.dl[code]);
+  END PutGetF;
+
+(* ============================================================ *)
+(* ============================================================ *)
+
+  PROCEDURE (os : PeFile)MkNewRecord*(typ : Ty.Record);
+    CONST code = Asm.opc_newobj;
+    VAR   name : Lv.CharOpen;
+  BEGIN
+   (*
+    *  We need "newobj instance void <name>::.ctor()"
+    *)
+    os.pePI.code.MethInst(Asm.cd[code], os.new(typ));
+    os.Adjust(1);
+  END MkNewRecord;
+
+(* ============================================================ *)
+(* ============================================================ *)
+
+  PROCEDURE (os : PeFile)MkNewProcVal*(p : Sy.Idnt;   (* src Proc *)
+                                       t : Sy.Type);  (* dst Type *)
+    VAR ctor : Api.Method;
+        ldfi : INTEGER;
+        pTyp : Ty.Procedure;
+        proc : Id.Procs;
+  BEGIN
+(*
+ *  ctor := t.tgXtn(DelXtn).newD;
+ *)
+    proc := p(Id.Procs);
+    pTyp := t(Ty.Procedure);
+    ctor := os.dxt(pTyp).newD;
+   (*
+    *  We need "ldftn [instance] <retType> <procName>
+    *)
+    WITH p : Id.MthId DO
+      IF p.bndType.isInterfaceType() THEN
+        ldfi := Asm.opc_ldvirtftn;
+      ELSIF p.mthAtt * Id.mask = Id.final THEN
+        ldfi := Asm.opc_ldftn;
+      ELSE
+        ldfi := Asm.opc_ldvirtftn;
+      END;
+    ELSE
+      ldfi := Asm.opc_ldftn;
+    END;
+   (*
+    *  These next are needed for imported events
+    *)
+    Mu.MkProcName(proc, os);
+    os.NumberParams(proc, pTyp);
+   (*
+    *   If this will be a virtual method call, then we
+    *   must duplicate the receiver, since the call of
+    *   ldvirtftn uses up one copy.
+    *)
+    IF ldfi = Asm.opc_ldvirtftn THEN os.Code(Asm.opc_dup) END;
+    os.pePI.code.MethInst(Asm.cd[ldfi], os.mth(proc));
+    os.Adjust(1);
+   (*
+    *  Now we need "newobj instance void <name>::.ctor(...)"
+    *)
+    os.pePI.code.MethInst(Asm.cd[Asm.opc_newobj], ctor);
+    os.Adjust(-2);
+  END MkNewProcVal;
+
+(* ============================================================ *)
+
+  PROCEDURE (os : PeFile)CallSuper*(rTp : Ty.Record;
+                                    prc : Id.PrcId);
+    VAR pNm : INTEGER;
+        spr : Api.Method;
+  (* ---------------------------------------- *)
+    PROCEDURE getSuperCtor(os  : PeFile; 
+                           rTp : Ty.Record; 
+                           prc : Id.Procs) : Api.Method;
+      VAR bas : Ty.Record;
+          pTp : Ty.Procedure;
+          bcl : Api.Class;
+          mth : Api.Method;
+    BEGIN
+      bas := rTp.superType();
+      IF prc # NIL THEN
+       (*
+        *  This constructor has arguments.
+        *  The super constructor is prc.basCll.sprCtor
+        *)
+        pTp := prc.type(Ty.Procedure);
+        IF prc.tgXtn = NIL THEN
+          bcl := os.cls(bas);
+          WITH bcl : Api.ClassDef DO
+              mth := MkMthDef(os, FALSE, pTp, bcl, ctorS);
+              mth(Api.MethodDef).AddMethAttribute(ctAtt);
+          | bcl : Api.ClassRef DO
+              mth := MkMthRef(os, pTp, bcl, ctorS);
+          END;
+          mth.AddCallConv(Api.CallConv.Instance);
+          prc.tgXtn := mth;
+          RETURN mth;
+        ELSE
+          RETURN prc.tgXtn(Api.Method);
+        END;
+      ELSIF (bas # NIL) & (rTp.baseTp # Bi.anyRec) THEN
+       (*
+        * This is the explicit noarg constructor of the supertype.
+        *)
+        RETURN os.new(bas);
+      ELSE
+       (*
+        *  This is System.Object::.ctor()
+        *)
+        RETURN newObjt;
+      END;
+    END getSuperCtor;
+  (* ---------------------------------------- *)
+  BEGIN
+    IF prc # NIL THEN 
+      pNm := prc.type(Ty.Procedure).formals.tide;
+    ELSE 
+      pNm := 0;
+    END;
+    spr := getSuperCtor(os, rTp, prc);
+    os.pePI.code.MethInst(Asm.cd[Asm.opc_call], spr);
+    os.Adjust(-(pNm+1));
+  END CallSuper;
+
+(* ============================================================ *)
+
+  PROCEDURE (os : PeFile)InitHead*(rTp : Ty.Record;
+                                   prc : Id.PrcId);
+    VAR mDf : Api.MethodDef;
+        cDf : Api.ClassDef;
+  BEGIN
+    cDf := os.cls(rTp)(Api.ClassDef);
+
+    IF prc # NIL THEN
+      mDf := prc.tgXtn(Api.MethodDef);
+      mDf.AddMethAttribute(ctAtt);
+    ELSE
+      mDf := os.new(rTp)(Api.MethodDef);
+    END;
+    os.pePI.mthD := mDf;
+    os.MkCodeBuffer();
+    mDf.AddCallConv(Api.CallConv.Instance);
+   (*
+    *   Now we initialize the supertype;
+    *)
+    os.Code(Asm.opc_ldarg_0);
+  END InitHead;
+
+(* ============================================================ *)
+
+  PROCEDURE (os : PeFile)CopyHead*(typ : Ty.Record);
+    VAR mDf : Api.MethodDef;
+        cDf : Api.ClassDef;
+        par : Id.ParId;
+        prs : POINTER TO ARRAY OF Id.ParId;
+  BEGIN
+    cDf := os.cls(typ)(Api.ClassDef);
+    mDf := os.cpy(typ)(Api.MethodDef);
+    mDf.AddMethAttribute(Api.MethAttr.Public);
+    mDf.AddImplAttribute(ilAtt);
+    mDf.AddCallConv(Api.CallConv.Instance);
+    os.pePI.mthD := mDf;
+    os.MkCodeBuffer();
+  END CopyHead;
+
+(* ============================================================ *)
+
+  PROCEDURE (os : PeFile)MarkInterfaces*(IN seq : Sy.TypeSeq);
+    VAR index  : INTEGER;
+        tideX  : INTEGER;
+        implT  : Ty.Record;
+  BEGIN
+    tideX := seq.tide-1;
+    ASSERT(tideX >= 0);
+    FOR index := 0 TO tideX DO
+      implT := seq.a[index].boundRecTp()(Ty.Record);
+      os.clsD.AddImplementedInterface(os.cls(implT));
+    END;
+  END MarkInterfaces;
+
+(* ============================================================ *)
+
+  PROCEDURE (os : PeFile)MainHead*(xAtt : SET);
+    VAR mthD : Api.MethodDef;
+
+    VAR strA : Api.Type;
+        list : Api.Field;
+        pars : POINTER TO ARRAY OF Api.Param;
+  BEGIN 
+    NEW(pars, 1);
+    strA := Api.ZeroBasedArray.init(strgD);
+    pars[0] := Api.Param.init(0, "@args", strA);
+
+    IF Sy.wMain IN xAtt THEN
+      mthD := os.clsS.AddMethod(psAtt, ilAtt, ".WinMain", voidD, pars);
+    ELSE (* Sy.cMain IN xAtt THEN *)
+      mthD := os.clsS.AddMethod(psAtt, ilAtt, ".CPmain", voidD, pars);
+    END;
+    os.pePI.mthD := mthD;
+    os.MkCodeBuffer();
+    mthD.DeclareEntryPoint();
+    IF CSt.debug THEN os.LineSpan(Scn.mkSpanT(CSt.thisMod.begTok)) END;
+   (*
+    *  Save the command-line arguments to the RTS.
+    *)
+    os.Code(Asm.opc_ldarg_0);
+    os.CodeF(Asm.opc_stsfld, os.fld(CSt.argLst));
+  END MainHead;
+
+(* ============================================================ *)
+
+  PROCEDURE (os : PeFile)SubSys*(xAtt : SET);
+  BEGIN
+    IF Sy.wMain IN xAtt THEN os.peFl.SetSubSystem(2) END;
+  END SubSys;
+
+(* ============================================================ *)
+
+  PROCEDURE (os : PeFile)StartBoxClass*(rec : Ty.Record;
+                                        att : SET;
+                                        blk : Id.BlkId);
+    VAR mthD : Api.MethodDef;
+        sprC : Api.Method;
+        boxC : Api.ClassDef;
+  BEGIN
+    boxC := rec.tgXtn(RecXtn).boxD(Api.ClassDef);
+    boxC.AddAttribute(toTypeAttr(att));
+
+   (*
+    *   Emit the no-arg constructor
+    *)
+    os.MkNewProcInfo(blk);
+    mthD := os.new(rec)(Api.MethodDef);
+    os.pePI.mthD := mthD;
+    os.MkCodeBuffer();
+    mthD.AddCallConv(Api.CallConv.Instance);
+
+    os.Code(Asm.opc_ldarg_0);
+    sprC := newObjt;
+
+    os.pePI.code.MethInst(Asm.cd[Asm.opc_call], sprC);
+    os.InitHead(rec, NIL);
+    os.CallSuper(rec, NIL);
+    os.Code(Asm.opc_ret);
+    os.Locals();
+    os.InitTail(rec);
+    os.pePI := NIL;
+    os.proc := NIL;
+   (*
+    *   Copies of value classes are always done inline.
+    *)
+  END StartBoxClass;
+
+(* ============================================================ *)
+
+  PROCEDURE (os : PeFile)Tail(),NEW;
+  BEGIN
+    os.Locals();
+    os.pePI.code.CloseScope();  (* Needed for PERWAPI pdb files *)
+    os.pePI := NIL;
+    os.proc := NIL;
+  END Tail;
+
+(* ============================================================ *)
+
+  PROCEDURE (os : PeFile)MainTail*();
+  BEGIN os.Tail() END MainTail;
+
+(* ------------------------------------------------------------ *)
+
+  PROCEDURE (os : PeFile)MethodTail*(id : Id.Procs);
+  BEGIN os.Tail() END MethodTail;
+
+(* ------------------------------------------------------------ *)
+
+  PROCEDURE (os : PeFile)ClinitTail*();
+  BEGIN os.Tail() END ClinitTail;
+
+(* ------------------------------------------------------------ *)
+
+  PROCEDURE (os : PeFile)CopyTail*();
+  BEGIN os.Tail() END CopyTail;
+
+(* ------------------------------------------------------------ *)
+
+  PROCEDURE (os : PeFile)InitTail*(typ : Ty.Record);
+  BEGIN os.Tail() END InitTail;
+
+(* ============================================================ *)
+
+  PROCEDURE (os : PeFile)ClinitHead*();
+    VAR mAtt : INTEGER;
+  BEGIN
+    mAtt := ctAtt + Api.MethAttr.Static;
+    os.pePI.mthD := os.clsS.AddMethod(mAtt, ilAtt, ".cctor", voidD, NIL);
+    os.MkCodeBuffer();
+    IF CSt.debug THEN
+      os.pePI.code.IntLine(CSt.thisMod.token.lin, 
+                           CSt.thisMod.token.col, 
+                           CSt.thisMod.token.lin,
+                           CSt.thisMod.token.col + CSt.thisMod.token.len);
+      os.Code(Asm.opc_nop);
+    END; 
+  END ClinitHead;
+
+(* ============================================================ *)
+
+  PROCEDURE (os : PeFile)EmitField*(id : Id.AbVar; att : SET);
+    VAR fDf : Api.FieldDef;
+  BEGIN
+    fDf := os.fld(id)(Api.FieldDef);
+    fDf.AddFieldAttr(toFieldAttr(att));
+  END EmitField;
+
+(* ============================================================ *)
+(*           Start of Procedure Variable and Event Stuff            *)
+(* ============================================================ *)
+
+  PROCEDURE MkAddRem(os : PeFile; fId : Id.AbVar);
+    VAR xtn : EvtXtn;
+        fXt : Api.Field;
+        clD : Api.Class;
+        namS : Lv.CharOpen;
+        typA : POINTER TO ARRAY OF Api.Type;
+        parA : POINTER TO ARRAY OF Api.Param;
+   (* -------------------------------- *)
+    PROCEDURE GetClass(os : PeFile; 
+                       id : Id.AbVar;
+                   OUT cl : Api.Class;
+                   OUT nm : Lv.CharOpen);
+    BEGIN
+      WITH id : Id.FldId DO
+           cl := os.cls(id.recTyp(Ty.Record));
+           nm := id.fldNm;
+      | id : Id.VarId DO
+           IF id.recTyp # NIL THEN cl:= os.cls(id.recTyp(Ty.Record));
+           ELSE cl:= os.dsc(id.dfScp(Id.BlkId));
+           END;
+           nm := id.varNm;
+      END;
+    END GetClass;
+   (* -------------------------------- *)
+  BEGIN
+   (*
+    *  First, need to ensure that there is a field 
+    *  descriptor created for this variable.
+    *)
+    IF fId.tgXtn = NIL THEN 
+      fXt := os.fld(fId);
+    ELSE 
+      fXt := fId.tgXtn(Api.Field);
+    END;
+   (*
+    *  Now allocate the Event Extension object.
+    *)
+    NEW(xtn);
+    xtn.fldD := fXt;
+   (*
+    *  Now create the MethodRef or MethodDef descriptors
+    *  for add_<fieldname>() and remove_<fieldname>()
+    *)
+    GetClass(os, fId, clD, namS);
+    WITH clD : Api.ClassDef DO
+          NEW(parA, 1);
+          parA[0] := Api.Param.init(0, "ev", os.typ(fId.type)); 
+          xtn.addD := clD.AddMethod(MKSTR(evtAdd^ + namS^), voidD, parA);
+          xtn.remD := clD.AddMethod(MKSTR(evtRem^ + namS^), voidD, parA);
+    | clD : Api.ClassRef DO
+          NEW(typA, 1);
+          typA[0] := os.typ(fId.type); 
+          xtn.addD := clD.AddMethod(MKSTR(evtAdd^ + namS^), voidD, typA);
+          xtn.remD := clD.AddMethod(MKSTR(evtRem^ + namS^), voidD, typA);
+    END;
+    fId.tgXtn := xtn;
+  END MkAddRem;
+
+(* ============================================================ *)
+
+  PROCEDURE (os : PeFile)EmitEventMethods*(id : Id.AbVar);
+    CONST att  = Api.MethAttr.Public + Api.MethAttr.SpecialName;
+    VAR   eTp  : Ty.Event;
+          evt  : Api.Event;
+          addD  : Api.MethodDef;
+          remD  : Api.MethodDef;
+   (* ------------------------------------------------- *)
+    PROCEDURE EmitEvtMth(os  : PeFile; 
+                         id  : Id.AbVar;
+                         add : BOOLEAN; 
+                         mth : Api.MethodDef);
+      VAR pFix : Lv.CharOpen;
+          mStr : RTS.NativeString;
+          mthD : Api.MethodDef;
+          parA : POINTER TO ARRAY OF Api.Param;
+    BEGIN
+      os.MkNewProcInfo(NIL);
+      WITH id : Id.FldId DO
+          mth.AddMethAttribute(att);
+          mth.AddCallConv(Api.CallConv.Instance);
+          mth.AddImplAttribute(ilAtt + Api.ImplAttr.Synchronised);
+          os.pePI.mthD := mth;
+          os.MkCodeBuffer();
+          os.Code(Asm.opc_ldarg_0);
+          os.Code(Asm.opc_ldarg_0);
+          os.PutGetF(Asm.opc_ldfld, id);
+          os.Code(Asm.opc_ldarg_1);
+          os.CallCombine(id.type, add);
+          os.PutGetF(Asm.opc_stfld, id);
+      | id : Id.VarId DO
+          mth.AddMethAttribute(att + Api.MethAttr.Static);
+          mth.AddImplAttribute(ilAtt + Api.ImplAttr.Synchronised);
+          os.pePI.mthD := mth;
+          os.MkCodeBuffer(); 
+          os.PutGetS(Asm.opc_ldsfld, id.dfScp(Id.BlkId), id);
+          os.Code(Asm.opc_ldarg_0);
+          os.CallCombine(id.type, add);
+          os.PutGetS(Asm.opc_stsfld, id.dfScp(Id.BlkId),id);
+      END;
+      os.Code(Asm.opc_ret);
+      os.Tail();
+    END EmitEvtMth;
+   (* ------------------------------------------------- *)
+  BEGIN
+   (*
+    *  Emit the "add_*" method
+    *)
+    addD := os.add(id)(Api.MethodDef);
+    EmitEvtMth(os, id, TRUE, addD);
+   (*
+    *  Emit the "remove_*" method
+    *)
+    remD := os.rem(id)(Api.MethodDef);
+    EmitEvtMth(os, id, FALSE, remD);
+   (*
+    *  Emit the .event declaration" 
+    *)
+    WITH id : Id.FldId DO
+        evt := os.clsD.AddEvent(MKSTR(id.fldNm^), os.typ(id.type));
+    | id : Id.VarId DO
+        evt := os.clsD.AddEvent(MKSTR(id.varNm^), os.typ(id.type));
+    END;
+    evt.AddMethod(addD, Api.MethodType.AddOn);
+    evt.AddMethod(remD, Api.MethodType.RemoveOn);
+  END EmitEventMethods;
+
+(* ============================================================ *)
+
+  PROCEDURE (os : PeFile)CallCombine(typ : Sy.Type;
+                                     add : BOOLEAN),NEW;
+    VAR xtn : Api.Method;
+  BEGIN
+    IF add THEN xtn := os.cmb() ELSE xtn := os.rmv() END; 
+    os.pePI.code.MethInst(Asm.cd[Asm.opc_call], xtn);
+    os.Adjust(-1);        
+    os.CodeT(Asm.opc_castclass, typ);
+  END CallCombine;
+
+(* ============================================================ *)
+
+  PROCEDURE (os : PeFile)MkAndLinkDelegate*(dl  : Sy.Idnt;
+                                            id  : Sy.Idnt;
+                                            ty  : Sy.Type;
+                                            isA : BOOLEAN);
+   (* --------------------------------------------------------- *)
+    VAR rcv : INTEGER;
+        mth : Api.Method;
+   (* --------------------------------------------------------- *)
+  BEGIN
+    WITH id : Id.FldId DO
+       (*
+        *      <push handle>                  // ... already done
+        *      <push receiver (or nil)>       // ... already done
+        *      <make new proc value>          // ... still to do
+        *      call      instance void A.B::add_fld(class tyName)
+        *)
+        os.MkNewProcVal(dl, ty);
+        IF isA THEN mth := os.add(id) ELSE mth := os.rem(id) END;
+        mth.AddCallConv(Api.CallConv.Instance);
+        os.pePI.code.MethInst(Asm.cd[Asm.opc_call], mth);
+    | id : Id.VarId DO
+       (*
+        *      <push receiver (or nil)>      // ... already done
+        *      <make new proc value>            // ... still to do
+        *      call      void A.B::add_fld(class tyName)
+        *)
+        os.MkNewProcVal(dl, ty);
+        IF isA THEN mth := os.add(id) ELSE mth := os.rem(id) END;
+        os.pePI.code.MethInst(Asm.cd[Asm.opc_call], mth);
+    | id : Id.LocId DO
+       (*
+        *      <save receiver>      
+        *      ldloc      'local'
+        *      <restore receiver>      
+        *      <make new proc value>            // ... still to do
+        *      call      class D D::Combine(class D, class D)
+        *)
+        rcv := os.proc.newLocal(CSt.ntvObj);
+        os.StoreLocal(rcv);
+        os.GetLocal(id);
+        os.PushLocal(rcv);
+        os.MkNewProcVal(dl, ty);
+        os.CallCombine(ty, isA);
+        os.PutLocal(id); 
+    END;
+  END MkAndLinkDelegate;
+
+(* ============================================================ *)
+(* ============================================================ *)
+
+  PROCEDURE (os : PeFile)EmitPTypeBody*(tId : Id.TypId);
+  BEGIN
+    ASSERT(tId.tgXtn # NIL);
+  END EmitPTypeBody;
+
+(* ============================================================ *)
+(*          End of Procedure Variable and Event Stuff           *)
+(* ============================================================ *)
+
+  PROCEDURE (os : PeFile)Line*(nm : INTEGER);
+  BEGIN
+    os.pePI.code.IntLine(nm,1,nm,100);
+    (*IF CSt.debug THEN os.Code(Asm.opc_nop) END;*)
+  END Line;
+ 
+  PROCEDURE (os : PeFile)LinePlus*(lin, col : INTEGER); 
+  BEGIN
+    (*IF CSt.debug THEN os.Code(Asm.opc_nop) END;*)
+    os.pePI.code.IntLine(lin,1,lin,col); 
+  END LinePlus;
+  
+  PROCEDURE (os : PeFile)LineSpan*(s : Scn.Span);
+  BEGIN
+    IF s # NIL THEN 
+         os.pePI.code.IntLine(s.sLin, s.sCol, s.eLin, s.eCol) END;     
+  END LineSpan;
+
+(* ============================================================ *)
+
+  PROCEDURE (os : PeFile)Locals(),NEW;
+  (** Declare the local of this method. *)
+    VAR count : INTEGER;
+        index : INTEGER;
+        prcId : Sy.Scope;
+        locId : Id.LocId;
+        methD : Api.MethodDef;
+        loclA : POINTER TO ARRAY OF Api.Local;
+        boolA : POINTER TO ARRAY OF BOOLEAN;
+        lBind : Api.LocalBinding;
+  BEGIN
+    methD := os.pePI.mthD;
+   (*
+    *   If dMax < 8, leave maxstack as default 
+    *)
+    IF os.proc.dMax > 8 THEN 
+      methD.SetMaxStack(os.proc.dMax);
+    ELSE
+      methD.SetMaxStack(8);
+    END;
+    NEW(loclA, os.proc.tLst.tide);
+    NEW(boolA, os.proc.tLst.tide);
+
+    count := 0;
+    IF os.proc.prId # NIL THEN 
+      prcId := os.proc.prId;
+      WITH prcId : Id.Procs DO
+        IF Id.hasXHR IN prcId.pAttr THEN
+          loclA[count] := Api.Local.init("", os.typ(prcId.xhrType)); 
+          INC(count);
+        END;
+        FOR index := 0 TO prcId.locals.tide-1 DO
+          locId := prcId.locals.a[index](Id.LocId);
+          IF ~(locId IS Id.ParId) & (locId.varOrd # Id.xMark) THEN
+            loclA[count] := Api.Local.init(nms(locId), os.typ(locId.type));
+            IF CSt.debug THEN boolA[count] := TRUE END;
+            INC(count);
+          END;
+        END;
+      ELSE (* nothing for module blocks *)
+      END;
+    END;
+    WHILE count < os.proc.tLst.tide DO 
+      loclA[count] := Api.Local.init("", os.typ(os.proc.tLst.a[count])); 
+      INC(count);
+    END;
+    IF count > 0 THEN methD.AddLocals(loclA, TRUE) END;
+    FOR index := 0 TO count-1 DO
+      IF boolA[index] THEN lBind := os.pePI.code.BindLocal(loclA[index]) END;
+    END;
+  END Locals;
+
+(* ============================================================ *)
+
+  PROCEDURE (os : PeFile)LoadType*(id : Sy.Idnt);
+   (* ---------------------------------- *)
+    PROCEDURE getLdTyp(os : PeFile) : Api.MethodRef;
+      VAR typD : Api.ClassRef;
+          rthA : POINTER TO ARRAY OF Api.Type;
+    BEGIN
+      IF loadTyp = NIL THEN
+       (*
+        *  Make params for the call
+        *)
+        NEW(rthA, 1);
+        IF rtTpHdl = NIL THEN
+          rtTpHdl := getOrAddClass(corlib, "System", "RuntimeTypeHandle");
+        END;
+        rthA[0] := rtTpHdl;
+       (*
+        *  Make receiver/result type descriptor
+        *)
+        IF CSt.ntvTyp.tgXtn = NIL THEN
+          CSt.ntvTyp.tgXtn := getOrAddClass(corlib, "System", "Type");
+        END;
+        typD := CSt.ntvTyp.tgXtn(Api.ClassRef);
+        loadTyp := getOrAddMethod(typD, "GetTypeFromHandle", typD, rthA);
+      END;
+      RETURN loadTyp;
+    END getLdTyp;
+   (* ---------------------------------- *)
+  BEGIN
+   (*
+    *    ldtoken <Type>
+    *    call class [mscorlib]System.Type 
+    *           [mscorlib]System.Type::GetTypeFromHandle(
+    *                     value class [mscorlib]System.RuntimeTypeHandle)
+    *)
+    os.CodeT(Asm.opc_ldtoken, id.type);
+    os.pePI.code.MethInst(Asm.cd[Asm.opc_call], getLdTyp(os));
+  END LoadType;
+
+(* ============================================================ *)
+
+  PROCEDURE (os : PeFile)Finish*();
+   (*(* ------------------------------------ *)
+    PROCEDURE MakeDebuggable(pef : Api.PEFile);
+      VAR thisAssm : Api.Assembly;
+          debugRef : Api.ClassRef;
+          dbugCtor : Api.MethodRef;
+          trueCnst : Api.BoolConst;
+          twoBools : TypArr;
+          dbugArgs : POINTER TO ARRAY OF Api.Constant;
+    BEGIN
+      thisAssm := pef.GetThisAssembly();
+      debugRef := getOrAddClass(corlib, "System.Diagnostics", "DebuggableAttribute");
+      NEW(twoBools, 2);
+      NEW(dbugArgs, 2);
+      twoBools[0] := Api.PrimitiveType.Boolean;
+      twoBools[1] := Api.PrimitiveType.Boolean;
+      dbugArgs[0] := Api.BoolConst.init(TRUE);
+      dbugArgs[1] := Api.BoolConst.init(TRUE);
+      dbugCtor := getOrAddMethod(debugRef, ctorS, voidD, twoBools)(Api.MethodRef);
+      dbugCtor.AddCallConv(Api.CallConv.Instance);
+      thisAssm.AddCustomAttribute(dbugCtor, dbugArgs);  
+    END MakeDebuggable;
+   (* ------------------------------------ *)*)
+  BEGIN
+    IF CSt.debug THEN os.peFl.MakeDebuggable(TRUE, TRUE) END; 
+    (* bake the assembly ... *)
+    os.peFl.WritePEFile(CSt.debug); 
+  END Finish;
+
+(* ============================================================ *)
+
+  PROCEDURE (os : PeFile)RefRTS*();
+    VAR i : INTEGER;
+        xhrRc : Ty.Record;
+        xhrNw : Api.Method;
+        xhrXt : RecXtn;
+        rtsXt : BlkXtn;
+        recXt : RecXtn;
+  BEGIN
+   (*
+    *  Reset the descriptor pool.
+    *  Note that descriptors cannot persist between
+    *  compilation unit, since the token sequence
+    *  is reset in PEAPI.
+    *)
+    mathCls := NIL;
+    envrCls := NIL;
+    excpCls := NIL;
+    rtTpHdl := NIL;
+    loadTyp := NIL;
+    FOR i := 0 TO Mu.rtsLen-1 DO rHelper[i] := NIL END;
+   (*
+    *  Now we need to create tgXtn fields
+    *  for some of the system types.   All 
+    *  others are only allocated on demand.
+    *)
+    corlib := os.peFl.MakeExternAssembly("mscorlib");
+   (*
+    *  Must put xtn markers on both the pointer AND the record
+    *)
+    NEW(recXt);
+    CSt.ntvStr(Ty.Pointer).boundTp.tgXtn := recXt;      (* the record  *)
+(*
+ *  recXt.clsD := corlib.AddClass("System", "String");
+ *)
+(* -- start replacement -- *)
+    recXt.clsD := getOrAddClass(corlib, "System", "String");
+(* --- end replacement --- *)
+    CSt.ntvStr.tgXtn := recXt.clsD;                     (* the pointer *)
+   (*
+    *  Must put xtn markers on both the pointer AND the record
+    *)
+    NEW(recXt);
+    CSt.ntvObj(Ty.Pointer).boundTp.tgXtn := recXt;      (* the record  *)
+(*
+ *  recXt.clsD := corlib.AddClass("System", "Object");
+ *)
+(* -- start replacement -- *)
+    recXt.clsD := getOrAddClass(corlib, "System", "Object");
+(* --- end replacement --- *)
+    CSt.ntvObj.tgXtn := recXt.clsD;                     (* the pointer *)
+   (*
+    *  CSt.ntvVal IS a record descriptor, not a pointer
+    *)
+    NEW(recXt);
+    CSt.ntvVal.tgXtn := recXt;                          (* the record  *)
+(*
+ *  recXt.clsD := corlib.AddClass("System", "ValueType");
+ *)
+(* -- start replacement -- *)
+    recXt.clsD := getOrAddClass(corlib, "System", "ValueType");
+(* --- end replacement --- *)
+
+    newObjt := getOrAddMethod(CSt.ntvObj.tgXtn(Api.ClassRef),ctorS,voidD,NIL);
+    newObjt.AddCallConv(Api.CallConv.Instance);
+   (*
+    *  Create Api.AssemblyRef for "RTS"
+    *  Create Api.ClassRef for "[RTS]RTS"
+    *  Create Api.ClassRef for "[RTS]Cp_rts"
+    *)
+    IF CSt.rtsBlk.xName = NIL THEN Mu.MkBlkName(CSt.rtsBlk) END;
+    os.rts   := os.peFl.MakeExternAssembly("RTS");
+    NEW(rtsXt);
+    rtsXt.asmD := os.rts;
+    rtsXt.dscD := os.rts.AddClass("", "RTS");
+    CSt.rtsBlk.tgXtn := rtsXt;
+    os.cprts    := os.rts.AddClass("", "CP_rts");
+   (*
+    *  Create Api.AssemblyRef for "ProgArgs" (same as RTS)
+    *  Create Api.ClassRef for "[RTS]ProgArgs"
+    *)
+    os.DoRtsMod(CSt.prgArg);
+    os.progArgs := CSt.prgArg.tgXtn(BlkXtn).dscD(Api.ClassRef);
+   (*
+    *  Create Api.ClassRef for "[RTS]XHR"
+    *  Create method "[RTS]XHR::.ctor()"
+    *)
+    xhrCl := os.rts.AddClass("", "XHR");
+    xhrNw := xhrCl.AddMethod(ctorS, voidD, NIL);
+    xhrNw.AddCallConv(Api.CallConv.Instance);
+    xhrRc := CSt.rtsXHR.boundRecTp()(Ty.Record);
+    NEW(xhrXt);
+    xhrRc.tgXtn := xhrXt;
+    xhrXt.clsD := xhrCl;
+    xhrXt.newD := xhrNw;
+  END RefRTS;
+
+(* ============================================================ *)
+
+  PROCEDURE (os : PeFile)StartNamespace*(nm : Lv.CharOpen);
+  BEGIN
+    os.nmSp := MKSTR(nm^);
+  END StartNamespace;
+
+(* ============================================================ *)
+
+  PROCEDURE (os : PeFile)MkBodyClass*(mod : Id.BlkId);
+   (*
+    *   Instantiate a ClassDef object for the synthetic
+    *   static class, and assign to the PeFile::clsS field.
+    *   Of course, for the time being it is also the 
+    *   "current class" held in the PeFile::clsD field.
+    *)
+    VAR namStr : RTS.NativeString;
+        clsAtt : INTEGER;
+        modXtn : BlkXtn;
+  BEGIN
+    defSrc := Api.SourceFile.GetSourceFile(
+        MKSTR(CSt.srcNam), Sys.Guid.Empty, Sys.Guid.Empty, Sys.Guid.Empty);
+    namStr  := MKSTR(mod.clsNm^);
+    clsAtt  := toTypeAttr(Asm.modAttr);
+    os.clsS := os.peFl.AddClass(clsAtt, os.nmSp, namStr);
+    os.clsD := os.clsS; 
+    NEW(modXtn);
+    modXtn.asmD := NIL;
+    modXtn.dscD := os.clsS;
+    mod.tgXtn := modXtn;
+  END MkBodyClass;
+
+(* ============================================================ *)
+
+  PROCEDURE (os : PeFile)ClassHead*(attSet : SET; 
+                                    thisRc : Ty.Record;
+                                    superT : Ty.Record);
+    VAR clsAtt : INTEGER;
+        clsDef : Api.ClassDef;
+  BEGIN
+    clsAtt := toTypeAttr(attSet);
+    clsDef := os.cls(thisRc)(Api.ClassDef);
+    clsDef.AddAttribute(clsAtt);
+    os.clsD := clsDef;
+  END ClassHead;
+
+(* ============================================================ *)
+
+  PROCEDURE (os : PeFile)ClassTail*();
+  BEGIN
+    os.clsD := NIL;
+  END ClassTail;
+
+(* ============================================================ *)
+
+  PROCEDURE (os : PeFile)MkRecX*(t : Ty.Record; s : Sy.Scope);
+   (* -------------------------------- *
+    *  Create a ClassDef or a ClassRef for this type.
+    *  The type attributes are set to a default value
+    *  and are modified later for a ClassDef.
+    * -------------------------------- *)
+    VAR indx : INTEGER;
+        valR : BOOLEAN;               (* is a value record  *)
+        noNw : BOOLEAN;               (* no constructor...  *)
+        base : Ty.Record;
+        xAsm : Api.AssemblyRef;
+        xCls : Api.ClassRef;
+        cDef : Api.ClassDef;
+        cRef : Api.ClassRef;
+        nStr : RTS.NativeString;      (* record name string *)
+        aStr : RTS.NativeString;      (* imported namespace *)
+        recX : RecXtn;
+   (* -------------------------------- *)
+    PROCEDURE DoBoxDef(o : PeFile; t : Ty.Record);
+      VAR nStr : RTS.NativeString;
+          cDef : Api.ClassDef;
+          cFld : Api.FieldDef;
+          nMth : Api.MethodDef;
+          tXtn : RecXtn;
+    BEGIN
+      nStr := boxedName(t);
+      tXtn := t.tgXtn(RecXtn);
+      cDef := o.peFl.AddClass(0, o.nmSp, nStr);
+      cFld := cDef.AddField(vfldS, tXtn.clsD);
+      nMth := cDef.AddMethod(ctAtt,ilAtt,ctorS,voidD,NIL);
+
+      nMth.AddCallConv(Api.CallConv.Instance);
+      cFld.AddFieldAttr(Api.FieldAttr.Public);
+
+      tXtn.boxD := cDef;
+      tXtn.newD := nMth;
+      tXtn.vDlr := cFld;
+    END DoBoxDef;
+   (* -------------------------------- *)
+    PROCEDURE DoBoxRef(o : PeFile; t : Ty.Record; c : Api.ClassRef);
+      VAR cFld : Api.FieldRef;
+          nMth : Api.MethodRef;
+          tXtn : RecXtn;
+    BEGIN
+      tXtn := t.tgXtn(RecXtn);
+      cFld := getOrAddField(c, vfldS, tXtn.clsD);
+(*
+ *    nMth := c.AddMethod(ctorS,voidD,NIL);
+ *)
+      nMth := getOrAddMethod(c, ctorS, voidD, NIL);
+      nMth.AddCallConv(Api.CallConv.Instance);
+
+      tXtn.boxD := c;
+      tXtn.newD := nMth;
+      tXtn.vDlr := cFld;
+    END DoBoxRef;
+   (* -------------------------------- *)
+  BEGIN
+    nStr := MKSTR(t.xName^);
+    valR := Mu.isValRecord(t);
+    NEW(recX);
+    t.tgXtn := recX;
+   (*
+    *  No default no-arg constructor is defined if this
+    *  is an abstract record, an interface, or extends a
+    *  foreign record that does not export a no-arg ctor.
+    *)
+    noNw := t.isInterfaceType() OR (Sy.noNew IN t.xAttr);
+
+    IF s.kind # Id.impId THEN (* this is a classDEF *)
+      base := t.superType();  (* might return System.ValueType *)
+      IF base = NIL THEN
+        cDef := os.peFl.AddClass(0, os.nmSp, nStr);
+      ELSIF valR THEN
+        cDef := os.peFl.AddValueClass(0, os.nmSp, nStr);
+      ELSE
+        cDef := os.peFl.AddClass(0, os.nmSp, nStr, os.cls(base));
+      END;
+      recX.clsD := cDef; (* this field needed for MkFldName() *)
+      IF valR THEN 
+       (*
+        *  Create the boxed version of this value record
+        *  AND create a constructor for the boxed class
+        *)
+        DoBoxDef(os, t);
+      ELSIF ~noNw THEN
+       (*
+        *  Create a constructor for this reference class.
+        *)
+        recX.newD := cDef.AddMethod(ctAtt, ilAtt, ctorS, voidD, NIL);
+        recX.newD.AddCallConv(Api.CallConv.Instance);
+      END;
+      FOR indx := 0 TO t.fields.tide-1 DO
+        Mu.MkFldName(t.fields.a[indx](Id.FldId), os);
+      END;
+    ELSE                      (* this is a classREF *)
+      IF t.encCls # NIL THEN  (* ... a nested classREF *)
+        base := t.encCls(Ty.Record);
+        xCls := os.cls(base)(Api.ClassRef);
+        cRef := xCls.AddNestedClass(nStr);
+        recX.clsD := cRef;
+      ELSE                    (* ... a normal classREF *)
+        xAsm := os.asm(s(Id.BlkId));
+        aStr := MKSTR(s(Id.BlkId).xName^);
+        IF valR THEN
+          cRef := getOrAddValueClass(xAsm, aStr, nStr);
+        ELSE
+          cRef := getOrAddClass(xAsm, aStr, nStr);
+        END;
+        recX.clsD := cRef;
+        IF valR & ~(Sy.isFn IN t.xAttr) THEN
+          DoBoxRef(os, t, xAsm.AddClass(aStr, boxedName(t)));
+        END;
+      END;
+
+      IF ~noNw & ~valR THEN
+        recX.newD := getOrAddMethod(cRef, ctorS, voidD, NIL);
+        recX.newD.AddCallConv(Api.CallConv.Instance);
+      END;
+    END;
+  END MkRecX;
+
+(* ============================================================ *)
+
+  PROCEDURE (os : PeFile)MkVecX*(t : Sy.Type; m : Id.BlkId);
+    VAR xAsm : Api.AssemblyRef;
+        recX : RecXtn;
+        nStr : RTS.NativeString;      (* record name string *)
+        aStr : RTS.NativeString;      (* imported namespace *)
+        cRef : Api.ClassRef;
+  BEGIN
+    NEW(recX);
+    t.tgXtn := recX;
+
+    IF m.tgXtn = NIL THEN os.DoRtsMod(m) END;
+    IF t.xName = NIL THEN Mu.MkTypeName(t, os) END;
+
+    aStr := MKSTR(m.xName^);
+    nStr := MKSTR(t.xName^);
+
+    xAsm := os.asm(m);
+    cRef := xAsm.AddClass(aStr, nStr);
+    recX.clsD := cRef;
+    recX.newD := cRef.AddMethod(ctorS, voidD, NIL);
+    recX.newD.AddCallConv(Api.CallConv.Instance);
+  END MkVecX;
+
+(* ============================================================ *)
+
+  PROCEDURE (os : PeFile)MkDelX(t : Ty.Procedure;
+                                s : Sy.Scope),NEW;
+   (* -------------------------------- *)
+    CONST dAtt = Asm.att_public + Asm.att_sealed;
+    VAR   xtn : DelXtn;             (* The created descriptor   *)
+          str : RTS.NativeString;   (* The proc-type nameString *)
+          att : Api.TypeAttr;       (* public,sealed (for Def)  *)
+          asN : RTS.NativeString;   (* Assembly name (for Ref)  *)
+          asR : Api.AssemblyRef;    (* Assembly ref  (for Ref)  *)
+          rtT : Sy.Type;            (* AST return type of proc  *)
+          rtD : Api.Type;           (* Api return type of del.  *)
+          clD : Api.ClassDef;
+          clR : Api.ClassRef;
+          mtD : Api.MethodDef;
+   (* -------------------------------- *)
+    PROCEDURE t2() : POINTER TO ARRAY OF Api.Type;
+      VAR a : POINTER TO ARRAY OF Api.Type;
+    BEGIN 
+      NEW(a,2); a[0] := objtD; a[1] := nIntD; RETURN a; 
+    END t2;
+   (* -------------------------------- *)
+    PROCEDURE p2() : POINTER TO ARRAY OF Api.Param;
+      VAR a : POINTER TO ARRAY OF Api.Param;
+    BEGIN
+      NEW(a,2);
+      a[0] := Api.Param.init(0, "obj", objtD); 
+      a[1] := Api.Param.init(0, "mth", nIntD); 
+      RETURN a;
+    END p2;
+   (* -------------------------------- *)
+    PROCEDURE tArr(t: Ty.Procedure; o: PeFile) : POINTER TO ARRAY OF Api.Type;
+      VAR a : POINTER TO ARRAY OF Api.Type;
+          i : INTEGER;
+          p : Id.ParId;
+          d : Api.Type;
+    BEGIN
+      NEW(a, t.formals.tide);
+      FOR i := 0 TO t.formals.tide-1 DO
+        p := t.formals.a[i];
+        d := o.typ(p.type);
+        IF Mu.takeAdrs(p) THEN 
+          p.boxOrd := p.parMod;
+          d := Api.ManagedPointer.init(d);
+        END; 
+        a[i] := d; 
+      END;
+      RETURN a;
+    END tArr;
+   (* -------------------------------- *)
+    PROCEDURE pArr(t: Ty.Procedure; o: PeFile) : POINTER TO ARRAY OF Api.Param;
+      VAR a : POINTER TO ARRAY OF Api.Param;
+          i : INTEGER;
+          p : Id.ParId;
+          d : Api.Type;
+    BEGIN
+      NEW(a, t.formals.tide);
+      FOR i := 0 TO t.formals.tide-1 DO
+        p := t.formals.a[i];
+        d := o.typ(p.type);
+        IF Mu.takeAdrs(p) THEN 
+          p.boxOrd := p.parMod;
+          d := Api.ManagedPointer.init(d);
+        END; 
+        a[i] := Api.Param.init(0, nms(p), d); 
+      END;
+      RETURN a;
+    END pArr;
+   (* -------------------------------- *)
+  BEGIN
+    IF t.tgXtn # NIL THEN RETURN END;
+    NEW(xtn);
+    str := MKSTR(Sy.getName.ChPtr(t.idnt)^);
+    rtT := t.retType;
+    IF rtT = NIL THEN rtD := voidD ELSE rtD := os.typ(rtT) END;
+
+    IF s.kind # Id.impId THEN (* this is a classDEF *)
+      att := toTypeAttr(dAtt);
+      clD := os.peFl.AddClass(att, os.nmSp, str, os.mcd());
+      mtD := clD.AddMethod(ctorS, voidD, p2());
+      mtD.AddMethAttribute(ctAtt);
+      mtD.AddImplAttribute(rmAtt);
+      xtn.newD := mtD;
+      mtD := clD.AddMethod(invkS, rtD, pArr(t, os));
+      mtD.AddMethAttribute(Api.MethAttr.Public);
+      mtD.AddImplAttribute(rmAtt);
+      xtn.invD := mtD;
+      xtn.clsD := clD;
+    ELSE                      (* this is a classREF *)
+      asR := os.asm(s(Id.BlkId));
+      asN := MKSTR(s(Id.BlkId).xName^);
+      clR := getOrAddClass(asR, asN, str);
+      xtn.newD := clR.AddMethod(ctorS, voidD, t2());
+      xtn.invD := clR.AddMethod(invkS, rtD, tArr(t, os));
+      xtn.clsD := clR;
+    END;
+    xtn.newD.AddCallConv(Api.CallConv.Instance);
+    xtn.invD.AddCallConv(Api.CallConv.Instance);
+    t.tgXtn := xtn;
+    IF (t.idnt # NIL) & (t.idnt.tgXtn = NIL) THEN t.idnt.tgXtn := xtn END;
+  END MkDelX;
+
+(* ============================================================ *)
+
+  PROCEDURE (os : PeFile)MkPtrX*(t : Ty.Pointer);
+    VAR bTyp : Sy.Type;
+        recX : RecXtn;
+  BEGIN
+    bTyp := t.boundTp;
+    IF bTyp.tgXtn = NIL THEN Mu.MkTypeName(bTyp, os) END;
+    WITH bTyp : Ty.Record DO
+        recX := bTyp.tgXtn(RecXtn);
+        IF recX.boxD # NIL THEN t.tgXtn := recX.boxD;
+        ELSE t.tgXtn := recX.clsD;
+        END;
+    | bTyp : Ty.Array DO
+        t.tgXtn := bTyp.tgXtn;
+    END;
+  END MkPtrX;
+
+(* ============================================================ *)
+
+  PROCEDURE (os : PeFile)MkArrX*(t : Ty.Array);
+  BEGIN
+    t.tgXtn := Api.ZeroBasedArray.init(os.typ(t.elemTp));
+  END MkArrX;
+
+(* ============================================================ *)
+
+  PROCEDURE (os : PeFile)MkBasX*(t : Ty.Base);
+  BEGIN
+    CASE t.tpOrd OF
+    | Ty.uBytN            : t.tgXtn := Api.PrimitiveType.UInt8;
+    | Ty.byteN            : t.tgXtn := Api.PrimitiveType.Int8;
+    | Ty.sIntN            : t.tgXtn := Api.PrimitiveType.Int16;
+    | Ty.intN,Ty.setN     : t.tgXtn := Api.PrimitiveType.Int32;
+    | Ty.lIntN            : t.tgXtn := Api.PrimitiveType.Int64;
+    | Ty.boolN            : t.tgXtn := Api.PrimitiveType.Boolean;
+    | Ty.charN,Ty.sChrN   : t.tgXtn := Api.PrimitiveType.Char;
+    | Ty.realN            : t.tgXtn := Api.PrimitiveType.Float64;
+    | Ty.sReaN            : t.tgXtn := Api.PrimitiveType.Float32;
+    | Ty.anyRec,Ty.anyPtr : t.tgXtn := Api.PrimitiveType.Object;
+    END;
+  END MkBasX;
+
+(* ============================================================ *)
+
+  PROCEDURE (os : PeFile)MkEnuX*(t : Ty.Enum; s : Sy.Scope);
+    VAR scNs : RTS.NativeString;
+        enNm : RTS.NativeString;
+  BEGIN
+    ASSERT(s.kind = Id.impId);
+    scNs := MKSTR(s(Id.BlkId).xName^);
+    enNm := MKSTR(Sy.getName.ChPtr(t.idnt)^);
+    t.tgXtn := getOrAddValueClass(os.asm(s(Id.BlkId)), scNs, enNm);
+  END MkEnuX;
+
+(* ============================================================ *)
+(*
+  PROCEDURE (os : PeFile)MkTyXtn*(t : Sy.Type; s : Sy.Scope);
+  BEGIN
+    IF t.tgXtn # NIL THEN RETURN END;
+    WITH t : Ty.Record    DO os.MkRecX(t, s);
+    |    t : Ty.Enum      DO os.MkEnuX(t, s);
+    |    t : Ty.Procedure DO os.MkDelX(t, s);
+    |    t : Ty.Base      DO os.MkBasX(t);
+    |    t : Ty.Pointer   DO os.MkPtrX(t);
+    |    t : Ty.Array     DO os.MkArrX(t);
+    END;
+  END MkTyXtn;
+ *)
+(* ============================================================ *)
+
+  PROCEDURE MkMthDef(os  : PeFile;
+                     xhr : BOOLEAN;
+                     pTp : Ty.Procedure;
+                     cls : Api.ClassDef;
+                     str : RTS.NativeString)  : Api.MethodDef;
+    VAR par : Id.ParId;
+        prd : Api.Type;
+        prs : POINTER TO ARRAY OF Api.Param;
+        rtT : Sy.Type;
+        rtd : Api.Type;
+        pId : Sy.Idnt;
+
+        idx : INTEGER;       (* index into formal array *)
+        prX : INTEGER;       (* index into param. array *)
+        prO : INTEGER;       (* runtime ordinal of arg. *)
+        num : INTEGER;       (* length of formal array  *)
+        len : INTEGER;       (* length of param array   *)
+  BEGIN
+    pId := pTp.idnt;
+    IF (pId # NIL) & (pId IS Id.MthId) & (Id.covar IN pId(Id.MthId).mthAtt) THEN 
+      rtT := pId(Id.MthId).retTypBound();
+    ELSE
+      rtT := pTp.retType;
+    END;
+    num := pTp.formals.tide;
+    IF xhr THEN len := num + 1 ELSE len := num END;
+    NEW(prs, len);
+    IF rtT = NIL THEN rtd := voidD ELSE rtd := os.typ(rtT) END;
+
+    prO := pTp.argN; (* count from 1 if xhr OR has this *)
+    IF xhr THEN
+      prs[0] := Api.Param.init(0, "", xhrCl); prX := 1;
+    ELSE
+      prX := 0;
+    END;
+    FOR idx := 0 TO num-1 DO
+      par := pTp.formals.a[idx];
+      par.varOrd := prO; 
+      prd := os.typ(par.type);
+      IF Mu.takeAdrs(par) THEN 
+        par.boxOrd := par.parMod;
+        prd := Api.ManagedPointer.init(prd);
+        IF Id.uplevA IN par.locAtt THEN 
+          par.boxOrd := Sy.val;
+          ASSERT(Id.cpVarP IN par.locAtt);
+        END;
+      END; (* just mark *)
+      prs[prX] := Api.Param.init(par.boxOrd, nms(par), prd); 
+      INC(prX); INC(prO);
+    END;
+   (*
+    *  Add attributes, Impl, Meth, CallConv in MethodDecl()
+    *)
+    RETURN cls.AddMethod(str, rtd, prs);
+  END MkMthDef;
+
+(* ============================================================ *)
+
+  PROCEDURE MkMthRef(os  : PeFile;
+                     pTp : Ty.Procedure;
+                     cls : Api.ClassRef;
+                     str : RTS.NativeString) : Api.MethodRef;
+    VAR par : Id.ParId;
+        tpD : Api.Type;
+        prs : POINTER TO ARRAY OF Api.Type;
+        rtT : Sy.Type;
+        rtd : Api.Type;
+        pId : Sy.Idnt;
+
+        idx : INTEGER;       (* index into formal array *)
+        prO : INTEGER;       (* runtime ordinal of arg. *)
+        num : INTEGER;       (* length of formal array  *)
+  BEGIN
+    pId := pTp.idnt;
+    IF (pId # NIL) & (pId IS Id.MthId) & (Id.covar IN pId(Id.MthId).mthAtt) THEN 
+      rtT := pId(Id.MthId).retTypBound();
+    ELSE
+      rtT := pTp.retType;
+    END;
+    num := pTp.formals.tide;
+    NEW(prs, num);
+    IF rtT = NIL THEN rtd := voidD ELSE rtd := os.typ(rtT) END;
+
+    prO := pTp.argN;
+    FOR idx := 0 TO num-1 DO
+      par := pTp.formals.a[idx];
+      tpD := os.typ(par.type);
+      par.varOrd := prO; (* if hasThis, then is (idx+1) *)
+      IF Mu.takeAdrs(par) THEN 
+        par.boxOrd := par.parMod;
+        tpD := Api.ManagedPointer.init(tpD);
+      END; (* just mark *)
+      prs[idx] := tpD; INC(prO);
+    END;
+    RETURN getOrAddMethod(cls, str, rtd, prs);
+  END MkMthRef;
+
+(* ============================================================ *)
+
+  PROCEDURE (os : PeFile)NumberParams*(pId : Id.Procs; 
+                                       pTp : Ty.Procedure);
+   (*
+    *   (1) Generate signature information for this procedure
+    *   (2) Generate the target extension Method(Def | Ref)
+    *)
+    VAR class : Api.Class;
+        methD : Api.Method;
+        namSt : RTS.NativeString;
+        xhrMk : BOOLEAN;
+        pLeng : INTEGER;
+   (* ----------------- *)
+    PROCEDURE classOf(os : PeFile; id : Id.Procs) : Api.Class;
+      VAR scp : Sy.Scope;
+    BEGIN
+      scp := id.dfScp;
+     (*
+      *  Check for methods bound to explicit classes
+      *)
+      IF id.bndType # NIL THEN RETURN os.cls(id.bndType(Ty.Record)) END;
+     (*
+      *  Or associate static methods with the dummy class
+      *)
+      WITH scp : Id.BlkId DO
+        RETURN os.dsc(scp);
+      | scp : Id.Procs DO (* Nested procs take class from scope *)
+        RETURN classOf(os, scp);
+      END;
+    END classOf;
+   (* ----------------- *)
+  BEGIN
+    IF pId = NIL THEN 
+      os.MkDelX(pTp, pTp.idnt.dfScp); RETURN;       (* PREMATURE RETURN HERE *)
+    END;
+    IF pId.tgXtn # NIL THEN RETURN END;             (* PREMATURE RETURN HERE *)
+
+    class := classOf(os, pId);    
+    namSt := MKSTR(pId.prcNm^);
+    xhrMk := pId.lxDepth > 0;
+   (*
+    *  The incoming argN counts one for a receiver,
+    *  and also counts one for nested procedures.
+    *)
+    IF pId IS Id.MthId THEN pLeng := pTp.argN-1 ELSE pLeng := pTp.argN END;
+   (*
+    *  Now create either a MethodDef or MethodRef
+    *)
+    WITH class : Api.ClassDef DO
+        methD :=  MkMthDef(os, xhrMk, pTp, class, namSt);
+    | class : Api.ClassRef DO
+        methD :=  MkMthRef(os, pTp, class, namSt);
+    END;
+    INC(pTp.argN, pTp.formals.tide);
+    IF pTp.retType # NIL THEN pTp.retN := 1 END;
+    IF (pId.kind = Id.ctorP) OR
+       (pId IS Id.MthId) THEN methD.AddCallConv(Api.CallConv.Instance) END;
+
+    pId.tgXtn := methD;
+    pTp.xName := cln2;  (* an arbitrary "done" marker *)
+
+    IF (pId.kind = Id.fwdPrc) OR (pId.kind = Id.fwdMth) THEN
+      pId.resolve.tgXtn := methD;
+    END;
+  END NumberParams;
+ 
+(* ============================================================ *)
+
+  PROCEDURE (os : PeFile)SwitchHead*(num : INTEGER);
+  BEGIN
+    switch.next := 0;
+    NEW(switch.list, num);
+  END SwitchHead;
+
+  PROCEDURE (os : PeFile)SwitchTail*();
+  BEGIN
+    os.pePI.code.Switch(switch.list);
+    switch.list := NIL;
+  END SwitchTail;
+
+  PROCEDURE (os : PeFile)LstLab*(l : Mu.Label);
+  BEGIN
+    WITH l : PeLab DO
+      switch.list[switch.next] := l.labl; 
+      INC(switch.next);
+    END;
+  END LstLab;
+
+(* ============================================================ *)
+
+  PROCEDURE (os : PeFile)mth(pId : Id.Procs) : Api.Method,NEW;
+  BEGIN
+    ASSERT(pId.tgXtn # NIL);
+    RETURN pId.tgXtn(Api.Method);
+  END mth;
+
+(* -------------------------------- *)
+
+  PROCEDURE (os : PeFile)fld(fId : Id.AbVar)  : Api.Field,NEW;
+    VAR cDf : Api.Class;
+        fNm : Lv.CharOpen;
+        obj : ANYPTR;
+   (* ---------------- *)
+    PROCEDURE AddField(os : PeFile;
+                       cl : Api.Class; 
+                       fn : Lv.CharOpen; 
+                       ty : Sy.Type) : Api.Field;
+      VAR fs : RTS.NativeString;
+    BEGIN
+      fs := MKSTR(fn^);
+      WITH cl : Api.ClassDef DO
+        RETURN cl.AddField(fs, os.typ(ty));
+      |    cl : Api.ClassRef DO
+        RETURN getOrAddField(cl, fs, os.typ(ty));
+      END;
+    END AddField;
+   (* ---------------- *)
+  BEGIN
+    IF fId.tgXtn = NIL THEN
+      WITH fId : Id.VarId DO
+          IF fId.varNm = NIL THEN Mu.MkVarName(fId,os) END;
+          IF fId.recTyp = NIL THEN (* module variable *)
+            cDf := os.dsc(fId.dfScp(Id.BlkId));
+          ELSE                     (* static field    *)
+            cDf := os.cls(fId.recTyp(Ty.Record));
+          END;
+          fNm := fId.varNm;
+      | fId : Id.FldId DO
+          IF fId.fldNm = NIL THEN Mu.MkFldName(fId,os) END;
+          cDf := os.cls(fId.recTyp(Ty.Record));
+          fNm := fId.fldNm;
+      END;
+      fId.tgXtn := AddField(os, cDf, fNm, fId.type);
+    END;
+    obj := fId.tgXtn;
+    WITH obj : Api.Field DO RETURN obj;
+    |    obj : EvtXtn    DO RETURN obj.fldD;
+    END;
+  END fld;
+
+(* -------------------------------- *)
+
+  PROCEDURE (os : PeFile)add(fId : Id.AbVar) : Api.Method,NEW;
+  BEGIN (* returns the descriptor of add_<fieldname> *)
+    IF (fId.tgXtn = NIL) OR ~(fId.tgXtn IS EvtXtn) THEN MkAddRem(os, fId) END;
+    RETURN fId.tgXtn(EvtXtn).addD;
+  END add;
+
+(* -------------------------------- *)
+
+  PROCEDURE (os : PeFile)rem(fId : Id.AbVar) : Api.Method,NEW;
+  BEGIN (* returns the descriptor of remove_<fieldname> *)
+    IF (fId.tgXtn = NIL) OR ~(fId.tgXtn IS EvtXtn) THEN MkAddRem(os, fId) END;
+    RETURN fId.tgXtn(EvtXtn).remD;
+  END rem;
+
+(* -------------------------------- *)
+
+  PROCEDURE (os : PeFile)asm(bId : Id.BlkId) : Api.AssemblyRef,NEW;
+  BEGIN (* returns the assembly reference of this module *)
+    IF bId.tgXtn = NIL THEN os.DoExtern(bId) END;
+    RETURN bId.tgXtn(BlkXtn).asmD;
+  END asm;
+
+(* -------------------------------- *)
+
+  PROCEDURE (os : PeFile)dsc(bId : Id.BlkId) : Api.Class,NEW;
+  BEGIN (* returns descriptor of dummy static class of this module *)
+    IF bId.tgXtn = NIL THEN os.DoExtern(bId) END;
+    RETURN bId.tgXtn(BlkXtn).dscD;
+  END dsc;
+
+(* -------------------------------- *)
+
+  PROCEDURE (os : PeFile)cls(rTy : Ty.Record) : Api.Class,NEW;
+  BEGIN (* returns descriptor for this class *)
+    IF rTy.tgXtn = NIL THEN Mu.MkRecName(rTy, os) END;
+    RETURN rTy.tgXtn(RecXtn).clsD;
+  END cls;
+
+(* -------------------------------- *)
+(*
+ *  PROCEDURE (os : PeFile)box(rTy : Ty.Record) : Api.Class,NEW;
+ *  BEGIN
+ *    IF rTy.tgXtn = NIL THEN Mu.MkRecName(rTy, os) END;
+ *    RETURN rTy.tgXtn(RecXtn).boxD;
+ *  END box;
+ *)
+(* -------------------------------- *)
+
+  PROCEDURE (os : PeFile)new(rTy : Ty.Record) : Api.Method,NEW;
+  BEGIN (* returns the ctor for this reference class *)
+    IF rTy.tgXtn = NIL THEN Mu.MkRecName(rTy, os) END;
+    RETURN rTy.tgXtn(RecXtn).newD;
+  END new;
+
+(* -------------------------------- *)
+
+  PROCEDURE (os : PeFile)dxt(pTy : Ty.Procedure) : DelXtn,NEW;
+  BEGIN (* returns the DelXtn extension for this delegate type *)
+    IF pTy.tgXtn = NIL THEN os.MkDelX(pTy, pTy.idnt.dfScp) END;
+    RETURN pTy.tgXtn(DelXtn);
+  END dxt;
+
+(* -------------------------------- *)
+
+  PROCEDURE mkCopyDef(cDf : Api.ClassDef; val : BOOLEAN) : Api.Method;
+    VAR pra : POINTER TO ARRAY OF Api.Param;
+        prd : Api.Type;
+  BEGIN
+    NEW(pra, 1);
+    prd := cDf;
+    IF val THEN prd := Api.ManagedPointer.init(prd) END;
+    pra[0] := Api.Param.init(0, "src", prd);
+    RETURN cDf.AddMethod(copyS, voidD, pra);
+  END mkCopyDef;
+
+(* -------------------------------- *)
+
+  PROCEDURE (os : PeFile)cpy(rTy : Ty.Record) : Api.Method,NEW;
+    VAR tXtn : RecXtn;
+        tCls : Api.Class;
+        mthX : Api.Method;
+        typA : POINTER TO ARRAY OF Api.Type;
+        valR : BOOLEAN;
+  BEGIN
+    tXtn := rTy.tgXtn(RecXtn);
+    tCls := tXtn.clsD;
+    IF tXtn.cpyD = NIL THEN
+      valR := Mu.isValRecord(rTy);
+      WITH tCls : Api.ClassDef DO
+          mthX := mkCopyDef(tCls, valR);
+      | tCls : Api.ClassRef DO
+          NEW(typA, 1);
+          IF valR THEN 
+            typA[0] := Api.ManagedPointer.init(tCls);
+          ELSE
+            typA[0] := tCls;
+          END;
+          mthX := tCls.AddMethod(copyS, voidD, typA);
+          mthX.AddCallConv(Api.CallConv.Instance);
+      END;
+      tXtn.cpyD := mthX;
+    ELSE
+      mthX := tXtn.cpyD;
+    END;
+    RETURN mthX;
+  END cpy;
+
+(* -------------------------------- *)
+
+  PROCEDURE (os : PeFile)vDl(rTy : Ty.Record) : Api.Field,NEW;
+  BEGIN (* returns descriptor of field "v$" for this boxed value type *)
+    IF rTy.tgXtn = NIL THEN Mu.MkRecName(rTy, os) END;
+    RETURN rTy.tgXtn(RecXtn).vDlr;
+  END vDl;
+
+(* -------------------------------- *)
+
+  PROCEDURE (os : PeFile)typ(tTy : Sy.Type) : Api.Type,NEW;
+    VAR xtn : ANYPTR;
+  BEGIN (* returns Api.Type descriptor for this type *)
+    IF tTy.tgXtn = NIL THEN Mu.MkTypeName(tTy, os) END;
+    xtn := tTy.tgXtn;
+    WITH xtn : Api.Type DO
+        RETURN xtn;
+    | xtn : RecXtn DO
+        RETURN xtn.clsD;
+    | xtn : DelXtn DO
+        RETURN xtn.clsD;
+    END;
+  END typ;
+
+(* ============================================================ *)
+
+  PROCEDURE (os : PeFile)mcd() : Api.ClassRef,NEW;
+  BEGIN (* returns System.MulticastDelegate *)
+    IF multiCD = NIL THEN 
+      multiCD := getOrAddClass(corlib, "System", "MulticastDelegate");
+    END;
+    RETURN multiCD;
+  END mcd;
+
+(* ============================================================ *)
+
+  PROCEDURE (os : PeFile)del() : Api.ClassRef,NEW;
+  BEGIN (* returns System.Delegate *)
+    IF delegat = NIL THEN 
+      delegat := getOrAddClass(corlib, "System", "Delegate");
+    END;
+    RETURN delegat;
+  END del;
+
+(* ============================================================ *)
+
+  PROCEDURE (os : PeFile)rmv() : Api.MethodRef,NEW;
+    VAR prs : POINTER TO ARRAY OF Api.Type;
+        dlg : Api.ClassRef;
+  BEGIN (* returns System.Delegate::Remove *)
+    IF remove = NIL THEN 
+      dlg := os.del();
+      NEW(prs, 2);
+      prs[0] := dlg; 
+      prs[1] := dlg;
+      remove := dlg.AddMethod("Remove", dlg, prs);
+    END;
+    RETURN remove;
+  END rmv;
+
+(* ============================================================ *)
+
+  PROCEDURE (os : PeFile)cmb() : Api.MethodRef,NEW;
+    VAR prs : POINTER TO ARRAY OF Api.Type;
+        dlg : Api.ClassRef;
+  BEGIN (* returns System.Delegate::Combine *)
+    IF combine = NIL THEN 
+      dlg := os.del();
+      NEW(prs, 2);
+      prs[0] := dlg; 
+      prs[1] := dlg;
+      combine := dlg.AddMethod("Combine", dlg, prs);
+    END;
+    RETURN combine;
+  END cmb;
+
+(* ============================================================ *)
+(* ============================================================ *)
+BEGIN
+  evtAdd   := Lv.strToCharOpen("add_"); 
+  evtRem   := Lv.strToCharOpen("remove_"); 
+  cln2     := Lv.strToCharOpen("::"); 
+  boxedObj := Lv.strToCharOpen("Boxed_"); 
+
+  vfldS  := MKSTR("v$");
+  ctorS  := MKSTR(".ctor");
+  invkS  := MKSTR("Invoke");
+  copyS  := MKSTR("__copy__");
+END PeUtil.
+(* ============================================================ *)
+(* ============================================================ *)
+

gpcp/RTS.cp

@@ -0,0 +1,178 @@
+(** This is the user accessible static methods of the CP runtime system.
+  * These are the environment-independent ones. Others are in CP*.cp
+  * Note:  the bodies of these procedures are dummies, this module is
+  *        compiled with -special.  The real code is in RTS.java or other.
+  *
+  * Version:     7 July     1999 (kjg).
+  *             20 February 2000 (kjg)  Default target ...
+  *              4 July     2000 (kjg)  Native types ...
+  *              4 August   2001 (syc,kjg)  more methods...
+  *                         2004 (kjg) vector support and globalization
+  *)
+
+(* ============================================================ *)
+SYSTEM MODULE RTS;
+
+  VAR defaultTarget- : ARRAY 4 OF CHAR;
+      fltNegInfinity-   : SHORTREAL;
+      fltPosInfinity-   : SHORTREAL;
+      dblNegInfinity-   : REAL;
+      dblPosInfinity-   : REAL;
+
+  TYPE  CharOpen*       = POINTER TO ARRAY OF CHAR;
+
+  TYPE  NativeType*	= POINTER TO ABSTRACT RECORD END;
+        NativeObject*   = POINTER TO ABSTRACT RECORD END;  
+        NativeString*   = POINTER TO RECORD END;
+        NativeException*= POINTER TO EXTENSIBLE RECORD END;
+
+  VAR   eol- : POINTER TO ARRAY OF CHAR; (* OS-specific end of line string *)
+
+  (* ========================================================== *)
+  (* ============= Support for native exceptions ==============	*)
+  (* ========================================================== *)
+  PROCEDURE getStr*(x : NativeException) : CharOpen; 
+
+  PROCEDURE Throw*(IN s : ARRAY OF CHAR);
+  (** Abort execution with an error *)
+
+  (* ========================================================== *)
+  (* ============= Conversions FROM array of char ============= *)
+  (* ========================================================== *)
+  PROCEDURE StrToBool*(IN s : ARRAY OF CHAR; OUT b : BOOLEAN; OUT ok : BOOLEAN);
+  (** Parse array into a BOOLEAN TRUE/FALSE *)
+
+  PROCEDURE StrToByte*(IN s : ARRAY OF CHAR; OUT b : BYTE; OUT ok : BOOLEAN);
+  (** Parse array into a BYTE integer *)
+
+  PROCEDURE StrToUByte*(IN s : ARRAY OF CHAR; OUT b : BYTE; OUT ok : BOOLEAN);
+  (** Parse array into a BYTE integer *)
+
+  PROCEDURE StrToShort*(IN s : ARRAY OF CHAR; OUT si : SHORTINT; OUT ok : BOOLEAN);
+  (** Parse an array into a CP LONGINT *)
+
+  PROCEDURE StrToUShort*(IN s:ARRAY OF CHAR; OUT si:SHORTINT; OUT ok:BOOLEAN);
+  (** Parse an array into a CP LONGINT *)
+
+  PROCEDURE StrToInt*(IN s:ARRAY OF CHAR; OUT i:INTEGER; OUT ok:BOOLEAN);
+  (** Parse an array into a CP INTEGER *)
+
+  PROCEDURE StrToUInt*(IN s:ARRAY OF CHAR; OUT i:INTEGER; OUT ok:BOOLEAN);
+  (** Parse an array into a CP INTEGER *)
+
+  PROCEDURE StrToLong*(IN s:ARRAY OF CHAR; OUT i:LONGINT; OUT ok:BOOLEAN);
+  (** Parse an array into a CP LONGINT *)
+
+  PROCEDURE StrToULong*(IN s:ARRAY OF CHAR; OUT i:LONGINT; OUT ok:BOOLEAN);
+  (** Parse an array into a CP LONGINT *)
+
+  PROCEDURE HexStrToUByte*(IN s:ARRAY OF CHAR; OUT b:BYTE; OUT ok:BOOLEAN);
+  (** Parse hexadecimal array into a BYTE integer *)
+
+(* ------------------- Low-level String Conversions -------------------- *)
+(* Three versions for different cultures.  *Invar uses invariant culture *)
+(*                                         *Local uses current locale    *)
+(* StrToReal & RealToStr do not behave the same on JVM and CLR.          *)
+(* They is provided for compatability with versions < 1.3.1              *)
+(* ------------------- Low-level String Conversions -------------------- *)
+
+  PROCEDURE StrToReal*(IN  s  : ARRAY OF CHAR; 
+                       OUT r  : REAL; 
+                       OUT ok : BOOLEAN);
+  (** Parse array into an ieee double REAL *)
+
+  PROCEDURE StrToRealInvar*(IN  s  : ARRAY OF CHAR; 
+                            OUT r  : REAL; 
+                            OUT ok : BOOLEAN);
+  (** Parse array using invariant culture, into an ieee double REAL *)
+
+  PROCEDURE StrToRealLocal*(IN  s  : ARRAY OF CHAR; 
+                            OUT r  : REAL; 
+                            OUT ok : BOOLEAN);
+  (** Parse array using current locale, into an ieee double REAL *)
+
+  PROCEDURE StrToSReal*(IN  s  : ARRAY OF CHAR; 
+                        OUT r  : SHORTREAL; 
+                        OUT ok : BOOLEAN);
+  PROCEDURE StrToSRealInvar*(IN  s  : ARRAY OF CHAR; 
+                        OUT r  : SHORTREAL; 
+                        OUT ok : BOOLEAN);
+  PROCEDURE StrToSRealLocal*(IN  s  : ARRAY OF CHAR; 
+                        OUT r  : SHORTREAL; 
+                        OUT ok : BOOLEAN);
+  (** Parse array into a short REAL *)
+
+  (* ========================================================== *)
+  (* ============== Conversions TO array of char ============== *)
+  (* ========================================================== *)
+  PROCEDURE RealToStr*(r : REAL; OUT s : ARRAY OF CHAR);
+  (** Decode a CP REAL into an array *)
+
+  PROCEDURE RealToStrInvar*(r : REAL; OUT s : ARRAY OF CHAR);
+  (** Decode a CP REAL into an array in invariant culture *)
+
+  PROCEDURE RealToStrLocal*(r : REAL; OUT s : ARRAY OF CHAR);
+  (** Decode a CP REAL into an array in the current locale *)
+
+  PROCEDURE SRealToStr*(r : SHORTREAL; OUT s : ARRAY OF CHAR);
+  PROCEDURE SRealToStrInvar*(r : SHORTREAL; OUT s : ARRAY OF CHAR);
+  PROCEDURE SRealToStrLocal*(r : SHORTREAL; OUT s : ARRAY OF CHAR);
+  (** Decode a CP SHORTREAL into an array *)
+  (* ========================================================== *)
+
+  PROCEDURE IntToStr*(i : INTEGER; OUT s : ARRAY OF CHAR);
+  (** Decode a CP INTEGER into an array *)
+
+  PROCEDURE ObjToStr*(obj : ANYPTR; OUT s : ARRAY OF CHAR);
+  (** Decode a CP INTEGER into an array *)
+
+  PROCEDURE LongToStr*(i : LONGINT; OUT s : ARRAY OF CHAR);
+  (** Decode a CP INTEGER into an array *)
+
+  (* ========================================================== *)
+  (* ========== Casts with no representation change =========== *)
+  (* ========================================================== *)
+  PROCEDURE realToLongBits*(r : REAL) : LONGINT;
+  (** Convert an ieee double into a longint with same bit pattern *)
+
+  PROCEDURE longBitsToReal*(l : LONGINT) : REAL;
+  (** Convert an ieee double into a longint with same bit pattern *)
+
+  PROCEDURE shortRealToIntBits*(r : SHORTREAL) : INTEGER;
+  (** Convert an ieee float into an int with same bit pattern *)
+
+  PROCEDURE intBitsToShortReal*(i : INTEGER) : SHORTREAL;
+  (** Convert an int into an ieee float with same bit pattern *)
+
+  PROCEDURE hiByte*(i : SHORTINT) : BYTE;
+  (** Get hi-significant word of short *)
+
+  PROCEDURE loByte*(i : SHORTINT) : BYTE;
+  (** Get lo-significant word of short *)
+
+  PROCEDURE hiShort*(i : INTEGER) : SHORTINT;
+  (** Get hi-significant word of integer *)
+
+  PROCEDURE loShort*(i : INTEGER) : SHORTINT;
+  (** Get lo-significant word of integer *)
+
+  PROCEDURE hiInt*(l : LONGINT) : INTEGER;
+  (** Get hi-significant word of long integer *)
+
+  PROCEDURE loInt*(l : LONGINT) : INTEGER;
+  (** Get lo-significant word of long integer *)
+
+  (* ========================================================== *)
+  (* ============= Various utility procedures ================= *)
+  (* ========================================================== *)
+  PROCEDURE GetMillis*() : LONGINT;
+  (** Get time in milliseconds *)
+
+  PROCEDURE GetDateString*(OUT str : ARRAY OF CHAR);
+  (** Get a date string in some native format *)
+
+  PROCEDURE ClassMarker*(o : ANYPTR);
+  (** Write class name to standard output *)
+
+(* ============================================================ *)
+END RTS.

gpcp/StatDesc.cp

@@ -0,0 +1,1249 @@
+(* ==================================================================== *)
+(*                                                                      *)
+(*  StatDesc Module for the Gardens Point Component Pascal Compiler.    *)
+(*  Implements statement descriptors that are extensions of             *)
+(*  Symbols.Stmt                                                        *)
+(*                                                                      *)
+(*  Copyright (c) John Gough 1999, 2000.                                *)
+(*                                                                      *)
+(* ==================================================================== *)
+(* Empty Assign Return Block ProcCall ForLoop Choice ExitSt TestLoop CaseSt *)
+(* ==================================================================== *)
+
+MODULE StatDesc;
+
+  IMPORT
+        GPCPcopyright,
+        GPText,
+        Console,
+        FileNames,
+        LitValue,
+        B := Builtin,
+        V := VarSets,
+        S := CPascalS,
+        D := Symbols ,
+        I := IdDesc  ,
+        T := TypeDesc,
+        E := ExprDesc,
+        G := CompState,
+        H := DiagHelper;
+
+(* ============================================================ *)
+
+  CONST (* stmt-kinds *)
+    emptyS* = 0;  assignS* = 1; procCall* = 2;  ifStat*  = 3;
+    caseS*  = 4;  whileS*  = 5; repeatS*  = 6;  forStat* = 7;
+    loopS*  = 8;  withS*   = 9; exitS*    = 10; returnS* = 11;
+    blockS* = 12;
+
+(* ============================================================ *)
+
+  CONST (* case statement density *)
+    DENSITY = 0.7;
+
+
+(* ============================================================ *)
+
+  TYPE
+    Empty*  = POINTER TO RECORD (D.Stmt)
+             (* ----------------------------------------- *
+              * kind-  : INTEGER; (* tag for unions *)
+              * token* : S.Token; (* stmt first tok *)
+              * ----------------------------------------- *)
+              END;
+
+(* ============================================================ *)
+
+  TYPE
+    Return* = POINTER TO RECORD (D.Stmt)
+             (* ----------------------------------------- *
+              * kind-  : INTEGER; (* tag for unions *)
+              * token* : S.Token; (* stmt first tok *)
+              * ----------------------------------------- *)
+                retX*  : D.Expr;  (* NIL ==> void   *)
+                prId*  : D.Scope; (* Parent Ident   *)
+              END;
+
+(* ============================================================ *)
+
+  TYPE
+    Block* = POINTER TO RECORD (D.Stmt)
+             (* ----------------------------------------- *
+              * kind-  : INTEGER; (* tag for unions *)
+              * token* : S.Token; (* stmt first tok *)
+              * ----------------------------------------- *)
+                sequ*  : D.StmtSeq;
+              END;
+
+(* ============================================================ *)
+
+  TYPE
+    Assign* = POINTER TO RECORD (D.Stmt)
+             (* ----------------------------------------- *
+              * kind-  : INTEGER; (* tag for unions *)
+              * token* : S.Token; (* stmt first tok *)
+              * ----------------------------------------- *)
+                lhsX*  : D.Expr;
+                rhsX*  : D.Expr;
+              END;
+
+(* ============================================================ *)
+
+  TYPE
+    ProcCall* = POINTER TO RECORD (D.Stmt)
+               (* ----------------------------------------- *
+                * kind-  : INTEGER; (* tag for unions *)
+                * token* : S.Token; (* stmt first tok *)
+                * ----------------------------------------- *)
+                  expr*  : D.Expr;
+                END;
+
+(* ============================================================ *)
+
+  TYPE
+    ForLoop* = POINTER TO RECORD (D.Stmt)
+              (* ----------------------------------------- *
+               * kind-  : INTEGER; (* tag for unions *)
+               * token* : S.Token; (* stmt first tok *)
+               * ----------------------------------------- *)
+                 cVar*  : D.Idnt;  (* c'trl variable *)
+                 loXp*  : D.Expr;  (* low limit expr *)
+                 hiXp*  : D.Expr;  (* high limit exp *)
+                 byXp*  : D.Expr;  (* must be numLt  *)
+                 body*  : D.Stmt;  (* possibly block *)
+               END;
+
+(* ============================================================ *)
+
+  TYPE
+    Choice* = POINTER TO RECORD (D.Stmt)
+             (* ----------------------------------------- *
+              * kind-  : INTEGER; (* tag for unions *)
+              * token* : S.Token; (* stmt first tok *)
+              * ----------------------------------------- *
+              *  This descriptor is used for IF and WITH. *
+              *  In the case of IF each predicate in the  *
+              *  sequence has a boolean type, and the     *
+              *  "predicate" corresponding to else is NIL *
+              *  For the WITH statement, each predicate   *
+              *  syntactically denoted as <id> ":" <tp>   *
+              *  is represented by an IS binary nodetype. *
+              * ----------------------------------------- *)
+                preds*  : D.ExprSeq;  (* else test NIL  *)
+                blocks* : D.StmtSeq;  (* stmt choices   *)
+                temps*  : D.IdSeq;    (* with tempvars  *)
+              END;
+
+(* ============================================================ *)
+
+  TYPE
+    ExitSt* = POINTER TO RECORD (D.Stmt)
+             (* ----------------------------------------- *
+              * kind-  : INTEGER; (* tag for unions *)
+              * token* : S.Token; (* stmt first tok *)
+              * ----------------------------------------- *)
+                loop*  : TestLoop;  (* enclosing loop *)
+              END;
+
+(* ============================================================ *)
+
+  TYPE
+    TestLoop* = POINTER TO RECORD (D.Stmt)
+               (* ----------------------------------------- *
+                * kind-  : INTEGER; (* tag for unions *)
+                * token* : S.Token; (* stmt first tok *)
+                * ----------------------------------------- *
+                *  This descriptor is used for WHILE and    *
+                *  REPEAT loops.  These are distinguished   *
+                *  by the different tag values in v.kind    *
+                *  LOOPs use the structure with a NIL test  *
+                * ----------------------------------------- *)
+                  test*  : D.Expr;  (* the loop test  *)
+                  body*  : D.Stmt;  (* possibly block *)
+                  label* : INTEGER; (* readonly field *)
+                  tgLbl* : ANYPTR;
+                  merge  : V.VarSet;
+                END;
+
+(* ============================================================ *)
+
+  TYPE
+    Triple* = POINTER TO RECORD
+                loC- : INTEGER;   (* low of range   *)
+                hiC- : INTEGER;   (* high of range  *)
+                ord- : INTEGER;   (* case block ord *)
+              END;
+
+  (* ---------------------------------- *)
+
+  TYPE
+    TripleSeq* = RECORD
+                   tide- : INTEGER;
+                   high : INTEGER;
+                   a- : POINTER TO ARRAY OF Triple;
+                 END;
+
+  (* ---------------------------------- *)
+
+  TYPE
+    CaseSt* = POINTER TO RECORD (D.Stmt)
+             (* ----------------------------------------- *
+              * kind-  : INTEGER; (* tag for unions *)
+              * token* : S.Token; (* stmt first tok *)
+              * ----------------------------------------- *)
+                select* : D.Expr; (* case selector  *)
+                chrSel* : BOOLEAN;  (* ==> use chars  *)
+                blocks* : D.StmtSeq;  (* case bodies    *)
+                elsBlk* : D.Stmt; (* elseCase | NIL *)
+                labels* : TripleSeq;  (* label seqence  *)
+                groups- : TripleSeq;  (* dense groups   *)
+              END;
+  (* ---------------------------------------------------------- *
+   *  Notes on the semantics of this structure. "blocks" holds  *
+   *  an ordered list of case statement code blocks. "labels" *
+   *  is a list of ranges, intially in textual order, with flds *
+   *  loC, hiC and ord corresponding to the range min, max and  *
+   *  the selected block ordinal number.  This list is later  *
+   *  sorted on the loC value, and adjacent values merged if  *
+   *  they select the same block.  The "groups" list of triples *
+   *  groups ranges into dense subranges in the selector space. *
+   *  The fields loC, hiC, and ord to hold the lower and upper  *
+   *  indices into the labels list, and the number of non-  *
+   *  default values in the group. Groups are guaranteed to *
+   *  have density (nonDefN / (max-min+1)) > DENSITY    *
+   * ---------------------------------------------------------- *)
+
+(* ============================================================ *)
+
+  PROCEDURE newTriple*(lo,hi,ord : INTEGER) : Triple;
+    VAR new : Triple;
+  BEGIN
+    NEW(new); new.loC := lo; new.hiC := hi; new.ord := ord; RETURN new;
+  END newTriple;
+
+  (* ---------------------------------- *)
+
+  PROCEDURE InitTripleSeq*(VAR seq : TripleSeq; capacity : INTEGER);
+  BEGIN
+    NEW(seq.a, capacity); seq.tide := 0; seq.high := capacity-1;
+  END InitTripleSeq;
+
+  (* ---------------------------------- *)
+
+  PROCEDURE (VAR seq : TripleSeq)ResetTo(newTide : INTEGER),NEW;
+  BEGIN
+    ASSERT(newTide <= seq.tide);
+    seq.tide := newTide;
+  END ResetTo;
+
+  (* ---------------------------------- *)
+
+  PROCEDURE AppendTriple*(VAR seq : TripleSeq; elem : Triple);
+    VAR temp : POINTER TO ARRAY OF Triple;
+        i    : INTEGER;
+  BEGIN
+    IF seq.a = NIL THEN
+      InitTripleSeq(seq, 8);
+    ELSIF seq.tide > seq.high THEN (* must expand *)
+      temp := seq.a;
+      seq.high := seq.high * 2 + 1;
+      NEW(seq.a, seq.high+1);
+      FOR i := 0 TO seq.tide-1 DO seq.a[i] := temp[i] END;
+    END;
+    seq.a[seq.tide] := elem; INC(seq.tide);
+  END AppendTriple;
+
+  (* ---------------------------------- *)
+
+(*
+ *PROCEDURE (VAR seq : TripleSeq)Diagnose(IN str : ARRAY OF CHAR),NEW;
+ *  VAR index : INTEGER;
+ *BEGIN
+ *  Console.WriteString("Diagnose TripleSeq " + str); Console.WriteLn;
+ *  FOR index := 0 TO seq.tide-1 DO
+ *    Console.WriteInt(index, 3);
+ *    Console.WriteInt(seq.a[index].loC, 8);
+ *    Console.WriteInt(seq.a[index].hiC, 8);
+ *    Console.WriteInt(seq.a[index].ord, 8);
+ *    Console.WriteLn;
+ *  END;
+ *END Diagnose;
+ *)
+
+(* ============================================================ *)
+(*            Various Statement Text-Span Constructors          *)
+(* ============================================================ *)
+
+  PROCEDURE (s : Empty)Span*() : S.Span;
+  BEGIN
+    RETURN NIL;
+  END Span;
+  
+  PROCEDURE (s : Return)Span*() : S.Span;
+    VAR rslt : S.Span;
+  BEGIN
+    rslt := S.mkSpanT(s.token);
+    IF s.retX # NIL THEN rslt := S.Merge(rslt, s.retX.tSpan) END;
+    RETURN rslt; 
+  END Span;
+  
+  PROCEDURE (s : Block)Span*() : S.Span;
+  BEGIN
+    RETURN NIL;
+  END Span;
+  
+  PROCEDURE (s : Assign)Span*() : S.Span;
+  BEGIN
+    RETURN S.Merge(s.lhsX.tSpan, s.rhsX.tSpan);
+  END Span;
+  
+  PROCEDURE (s : ProcCall)Span*() : S.Span;
+  BEGIN
+    RETURN s.expr.tSpan;
+  END Span;
+  
+  (*PROCEDURE (s : ProcCall)Span*() : S.Span;
+  BEGIN
+    RETURN s.expr.tSpan;
+  END Span;*)
+  
+  
+(* ============================================================ *)
+(*      Various Statement Descriptor Constructors   *)
+(* ============================================================ *)
+
+  PROCEDURE newEmptyS*() : Empty;
+    VAR new : Empty;
+  BEGIN
+    NEW(new); new.SetKind(emptyS);
+    new.token := S.prevTok; RETURN new;
+  END newEmptyS;
+
+  (* ---------------------------------- *)
+
+  PROCEDURE newBlockS*(t : S.Token) : Block;
+    VAR new : Block;
+  BEGIN
+    NEW(new); new.SetKind(blockS);
+    new.token := t; RETURN new;
+  END newBlockS;
+
+  (* ---------------------------------- *)
+
+  PROCEDURE newReturnS*(retX : D.Expr) : Return;
+    VAR new : Return;
+  BEGIN
+    NEW(new); new.token := S.prevTok;
+    new.retX := retX; new.SetKind(returnS); RETURN new;
+  END newReturnS;
+
+  (* ---------------------------------- *)
+
+  PROCEDURE newAssignS*() : Assign;
+    VAR new : Assign;
+  BEGIN
+    NEW(new); new.SetKind(assignS);
+    new.token := S.prevTok; RETURN new;
+  END newAssignS;
+
+  (* ---------------------------------- *)
+
+  PROCEDURE newWhileS*() : TestLoop;
+    VAR new : TestLoop;
+  BEGIN
+    NEW(new); new.SetKind(whileS);
+    new.token := S.prevTok; RETURN new;
+  END newWhileS;
+
+  (* ---------------------------------- *)
+
+  PROCEDURE newRepeatS*() : TestLoop;
+    VAR new : TestLoop;
+  BEGIN
+    NEW(new); new.SetKind(repeatS);
+    new.token := S.prevTok; RETURN new;
+  END newRepeatS;
+
+  (* ---------------------------------- *)
+
+  PROCEDURE newIfStat*() : Choice;
+    VAR new : Choice;
+  BEGIN
+    NEW(new); new.SetKind(ifStat);
+    new.token := S.prevTok; RETURN new;
+  END newIfStat;
+
+  (* ---------------------------------- *)
+
+  PROCEDURE newWithS*() : Choice;
+    VAR new : Choice;
+  BEGIN
+    NEW(new); new.SetKind(withS);
+    new.token := S.prevTok; RETURN new;
+  END newWithS;
+
+  (* ---------------------------------- *)
+
+  PROCEDURE newForStat*() : ForLoop;
+    VAR new : ForLoop;
+  BEGIN
+    NEW(new); new.SetKind(forStat);
+    new.token := S.prevTok; RETURN new;
+  END newForStat;
+
+  (* ---------------------------------- *)
+
+  PROCEDURE newProcCall*() : ProcCall;
+    VAR new : ProcCall;
+  BEGIN
+    NEW(new); new.token := S.prevTok;
+    new.SetKind(procCall); RETURN new;
+  END newProcCall;
+
+  (* ---------------------------------- *)
+
+  PROCEDURE newExitS*(loop : D.Stmt) : ExitSt;
+    VAR new : ExitSt;
+  BEGIN
+    NEW(new); new.token := S.prevTok;
+    new.loop  := loop(TestLoop); new.SetKind(exitS); RETURN new;
+  END newExitS;
+
+  (* ---------------------------------- *)
+
+  PROCEDURE newLoopS*() : TestLoop;
+    VAR new : TestLoop;
+  BEGIN
+    NEW(new); new.SetKind(loopS);
+    new.token := S.prevTok; RETURN new;
+  END newLoopS;
+
+  (* ---------------------------------- *)
+
+  PROCEDURE newCaseS*() : CaseSt;
+    VAR new : CaseSt;
+  BEGIN
+    NEW(new); new.SetKind(caseS);
+    new.token := S.prevTok; RETURN new;
+  END newCaseS;
+
+(* ============================================================ *)
+
+  PROCEDURE (for : ForLoop)isSimple*() : BOOLEAN,NEW;
+  (* A for loop is simple if it always executes at least once. *)
+    VAR loVal : LONGINT;
+        hiVal : LONGINT;
+        byVal : LONGINT;
+  BEGIN
+    IF  (for.loXp.kind = E.numLt) &
+        (for.hiXp.kind = E.numLt) THEN
+      loVal := for.loXp(E.LeafX).value.long();
+      hiVal := for.hiXp(E.LeafX).value.long();
+      byVal := for.byXp(E.LeafX).value.long();
+      IF byVal > 0 THEN
+        RETURN hiVal >= loVal;
+      ELSE
+        RETURN hiVal <= loVal;
+      END;
+    ELSE
+      RETURN FALSE;
+    END;
+  END isSimple;
+
+(* ============================================================ *)
+(*          Type Erasure                                        *)
+(* ============================================================ *)
+  PROCEDURE (s : Empty)TypeErase*(t : D.Scope); BEGIN END TypeErase;
+
+  PROCEDURE (s : Block)TypeErase*(t : D.Scope);
+      VAR index : INTEGER;
+    BEGIN
+      FOR index := 0 TO s.sequ.tide - 1 DO
+        s.sequ.a[index].TypeErase(t);
+      END;
+  END TypeErase;
+
+  PROCEDURE (s : Assign)TypeErase*(t : D.Scope);
+  BEGIN
+    s.rhsX := s.rhsX.TypeErase();
+  END TypeErase;
+
+  PROCEDURE (s : Return)TypeErase*(t : D.Scope); BEGIN END TypeErase;
+  PROCEDURE (s : ProcCall)TypeErase*(t : D.Scope); BEGIN END TypeErase;
+  PROCEDURE (s : ForLoop)TypeErase*(t : D.Scope); BEGIN END TypeErase;
+  PROCEDURE (s : Choice)TypeErase*(t : D.Scope); BEGIN END TypeErase;
+  PROCEDURE (s : ExitSt)TypeErase*(t : D.Scope); BEGIN END TypeErase;
+  PROCEDURE (s : TestLoop)TypeErase*(t : D.Scope); BEGIN END TypeErase;
+  PROCEDURE (s : CaseSt)TypeErase*(t : D.Scope); BEGIN END TypeErase;
+
+(* ============================================================ *)
+(*          Statement Attribution     *)
+(* ============================================================ *)
+
+  PROCEDURE (s : Empty)StmtAttr*(scope : D.Scope);
+  BEGIN END StmtAttr;
+
+  (* ---------------------------------- *)
+
+  PROCEDURE (s : Block)StmtAttr*(scope : D.Scope);
+    VAR index : INTEGER;
+  BEGIN
+    FOR index := 0 TO s.sequ.tide - 1 DO
+      s.sequ.a[index].StmtAttr(scope);
+    END;
+  END StmtAttr;
+
+  (* ---------------------------------- *)
+
+  PROCEDURE (s : Assign)StmtAttr*(scope : D.Scope);
+    VAR lTp, rTp : D.Type;
+        eNm : INTEGER;
+  BEGIN
+   (*
+    * Assert: lhsX is a designator, it has been
+    * attributed during parsing, and has a non-null type.
+    *
+    * First: attribute the right-hand-side expression.
+    *)
+    s.rhsX := s.rhsX.exprAttr();
+   (*
+    * First check: is the designator writeable.
+    *)
+    s.lhsX.CheckWriteable();
+
+    IF (s.rhsX # NIL) & (s.rhsX.type # NIL) THEN
+      lTp := s.lhsX.type;
+      rTp := s.rhsX.type;
+     (*
+      * Second check: does the expression need dereferencing.
+      *)
+      IF (lTp.kind = T.recTp) & (rTp.kind = T.ptrTp) THEN
+        s.rhsX := E.mkDeref(s.rhsX);
+        rTp := s.rhsX.type;
+      END;
+      IF lTp.assignCompat(s.rhsX) THEN
+       (*
+        * Third check: does the expression need type coercion.
+        *)
+        IF (rTp # lTp) & (rTp IS T.Base) THEN
+          s.rhsX := E.coerceUp(s.rhsX, lTp);
+          rTp := lTp;
+        END;
+       (*
+        * Fourth check: are value copies allowed here.
+        *)
+        IF ~rTp.valCopyOK() THEN s.rhsX.ExprError(152) END;
+        IF rTp IS T.Procedure THEN
+          s.StmtError(301);
+          IF G.targetIsJVM() THEN s.StmtError(213);
+          ELSIF (rTp # lTp) & ~s.rhsX.isProcLit() THEN s.StmtError(191);
+          END;
+        END;
+      ELSE (* sort out which error to report *)
+        IF    rTp.isOpenArrType() THEN eNm := 142;
+        ELSIF rTp.isExtnRecType() THEN eNm := 143;
+        ELSIF (rTp.kind = T.prcTp) &
+              (s.rhsX.kind = E.qualId) &
+              ~s.rhsX.isProcVar() THEN eNm := 165;
+        ELSIF lTp.isCharArrayType() &
+              rTp.isStringType() THEN  eNm :=  27;
+        ELSE             eNm :=  83;
+        END;
+        IF eNm # 83 THEN s.rhsX.ExprError(eNm);
+        ELSE D.RepTypesErrTok(83, lTp, rTp, s.token);
+        END;
+      END;
+    END;
+  END StmtAttr;
+
+  (* ---------------------------------- *)
+
+  PROCEDURE (s : Return)StmtAttr*(scope : D.Scope);
+    VAR prId : IdDesc.Procs;
+        rTyp : D.Type;
+        xTyp : D.Type;
+        rExp : D.Expr;
+  BEGIN
+    IF scope.kind = IdDesc.modId THEN
+      s.StmtError(73);
+    ELSE
+      prId := scope(IdDesc.Procs);
+      s.prId := prId;
+      rTyp := prId.type(TypeDesc.Procedure).retType;
+      IF rTyp = NIL THEN
+        IF s.retX # NIL THEN s.retX.ExprError(74) END;
+      ELSE
+        IF s.retX = NIL THEN
+          s.StmtError(75);
+        ELSE
+          rExp := s.retX.exprAttr();
+          s.retX := rExp;
+          xTyp := rExp.type;
+          IF rExp # NIL THEN (* fixed 28 July 2001 *)
+            IF ~rTyp.assignCompat(rExp) THEN
+              D.RepTypesErrTok(76, rTyp, xTyp, s.token);
+            ELSIF rTyp # xTyp THEN
+              IF xTyp IS T.Base THEN
+                rExp := E.coerceUp(rExp, rTyp);
+                s.retX := rExp;
+              ELSIF rTyp IS T.Procedure THEN
+                rExp.type := rTyp;
+              END;
+            END;
+            IF scope.kind = IdDesc.ctorP THEN
+              WITH rExp : E.IdLeaf DO
+                IF rExp.ident.hash # B.selfBk THEN rExp.ExprError(225) END;
+              ELSE rExp.ExprError(225);
+              END;
+            END;
+          END;
+        END;
+      END;
+    END;
+  END StmtAttr;
+
+  (* ---------------------------------- *)
+
+  PROCEDURE (s : ProcCall)StmtAttr*(scope : D.Scope);
+    VAR callX : E.CallX;
+        tempX : D.Expr;
+        idntX : E.IdentX;
+  BEGIN
+    callX  := s.expr(E.CallX);
+    s.expr := E.checkCall(callX);
+    IF (s.expr # NIL) &
+       (callX.kid.kind = E.sprMrk) THEN E.CheckSuper(callX, scope) END;
+  END StmtAttr;
+
+  (* ---------------------------------- *)
+
+  PROCEDURE (s : ForLoop)StmtAttr*(scope : D.Scope);
+  BEGIN
+    s.loXp := s.loXp.exprAttr();
+    s.hiXp := s.hiXp.exprAttr();
+    IF (s.loXp # NIL) & ~s.loXp.isIntExpr() THEN s.loXp.ExprError(37) END;
+    IF (s.hiXp # NIL) & ~s.hiXp.isIntExpr() THEN s.hiXp.ExprError(37) END;
+    s.body.StmtAttr(scope);
+  END StmtAttr;
+
+  (* ---------------------------------- *)
+
+  PROCEDURE (s : Choice)StmtAttr*(scope : D.Scope);
+    VAR index : INTEGER;
+        predN : D.Expr;
+        nextN : D.Expr;
+        blokN : D.Stmt;
+  BEGIN
+    FOR index := 0 TO s.preds.tide - 1 DO
+      predN := s.preds.a[index];
+      blokN := s.blocks.a[index];
+      IF predN # NIL THEN
+        nextN := predN.exprAttr();
+        IF nextN # NIL THEN
+          IF nextN # predN THEN s.preds.a[index] := nextN END;
+          IF ~nextN.isBooleanExpr() THEN predN.ExprError(36) END;
+        END;
+      END;
+      IF blokN # NIL THEN blokN.StmtAttr(scope) END;
+    END;
+  END StmtAttr;
+
+  (* ---------------------------------- *)
+
+  PROCEDURE (s : ExitSt)StmtAttr*(scope : D.Scope);
+  BEGIN END StmtAttr; (* nothing to do *)
+
+  (* ---------------------------------- *)
+
+  PROCEDURE (s : TestLoop)StmtAttr*(scope : D.Scope);
+  BEGIN
+    IF s.test # NIL THEN s.test := s.test.exprAttr() END;
+    IF (s.test # NIL) & ~s.test.isBooleanExpr() THEN s.test.ExprError(36) END;
+    s.body.StmtAttr(scope);
+  END StmtAttr;
+
+  (* ---------------------------------- *)
+
+  PROCEDURE (s : CaseSt)StmtAttr*(scope : D.Scope);
+  (* At this point the select expression has already been attributed  *)
+  (* during parsing, and the raw case ordinals have been checked. *)
+    VAR index : INTEGER;
+
+  (* ------------------------- *)
+
+    PROCEDURE QuickSort(VAR array : TripleSeq; min, max : INTEGER);
+      VAR i,j : INTEGER;
+          key : INTEGER;
+          tmp : Triple;
+    BEGIN
+      i := min; j := max;
+      key := array.a[(min+max) DIV 2].loC;
+      REPEAT
+        WHILE array.a[i].loC < key DO INC(i) END;
+        WHILE array.a[j].loC > key DO DEC(j) END;
+        IF i <= j THEN
+          tmp := array.a[i]; array.a[i] := array.a[j]; array.a[j] := tmp;
+          INC(i); DEC(j);
+        END;
+      UNTIL i > j;
+      IF min < j THEN QuickSort(array, min,j) END;
+      IF i < max THEN QuickSort(array, i,max) END;
+    END QuickSort;
+
+  (* ------------------------- *)
+
+    PROCEDURE DoErr89(cs : CaseSt; ix,mx : INTEGER);
+      VAR n1, n2 : ARRAY 32 OF CHAR;
+          lo, hi : INTEGER;
+          o1, o2 : INTEGER;
+          tr     : Triple;
+          s1,s2  : D.Stmt;
+    BEGIN
+      tr := cs.labels.a[ix];
+      lo := tr.loC; hi := tr.hiC; o1 := tr.ord;
+      (* overlap is from "lo" to MIN(mx, hi) ... *)
+      hi := MIN(hi, mx);
+      GPText.IntToStr(lo, n1);
+      IF lo # hi THEN (* range overlap *)
+        GPText.IntToStr(hi, n2);
+        n1 := n1 + " .. " + n2;
+      END;
+      o2 := cs.labels.a[ix-1].ord;
+     (*
+      *  We want to place a full diagnostic on the earlier
+      *  of the two cases, if there are two. Place a simple
+      *  diagnostic on the second of the two cases.
+      *)
+      s1 := cs.blocks.a[o1];
+      s2 := cs.blocks.a[o2];
+      IF o1 < o2 THEN
+        S.SemError.RepSt1(89, n1, s1.token.lin, s1.token.col);
+        S.SemError.Report(89, s2.token.lin, s2.token.col);
+      ELSIF o1 > o2 THEN
+        S.SemError.RepSt1(89, n1, s2.token.lin, s2.token.col);
+        S.SemError.Report(89, s1.token.lin, s1.token.col);
+      ELSE  (* list once only *)
+        S.SemError.RepSt1(89, n1, s1.token.lin, s1.token.col);
+      END;
+    END DoErr89;
+
+  (* ------------------------- *)
+
+    PROCEDURE Compact(cs : CaseSt);
+      VAR index : INTEGER;    (* read index on sequence *)
+          write : INTEGER;    (* write index on new seq *)
+          nextI : INTEGER;    (* adjacent selector val  *)
+          crOrd : INTEGER;    (* current case ordinal   *)
+          thisT : Triple;
+    BEGIN
+      write := -1;
+      nextI := MIN(INTEGER);
+      crOrd := MIN(INTEGER);
+      FOR index := 0 TO cs.labels.tide - 1 DO
+        thisT := cs.labels.a[index];
+        (* test for overlaps ! *)
+        IF thisT.loC < nextI THEN DoErr89(cs, index, nextI-1) END;
+        IF (thisT.loC = nextI) & (thisT.ord = crOrd) THEN (* merge *)
+          cs.labels.a[write].hiC := thisT.hiC;
+        ELSE
+          INC(write);
+          crOrd := thisT.ord;
+          cs.labels.a[write].loC := thisT.loC;
+          cs.labels.a[write].hiC := thisT.hiC;
+          cs.labels.a[write].ord := thisT.ord;
+        END;
+        nextI := thisT.hiC + 1;
+      END;
+      cs.labels.ResetTo(write+1);
+    END Compact;
+
+  (* ------------------------- *)
+
+    PROCEDURE FindGroups(cs : CaseSt);
+      VAR index : INTEGER;    (* read index on sequence *)
+          sm,sM : INTEGER;    (* group min/Max selector *)
+          nextN : INTEGER;    (* updated group ordNum.  *)
+          dense : BOOLEAN;
+          crGrp : Triple;   (* current group triple   *)
+          crRng : Triple;   (* triple to cond. add on *)
+          p1Grp : TripleSeq;    (* temporary sequence.    *)
+    BEGIN
+   (* IF G.verbose THEN cs.labels.Diagnose("selector labels") END; *)
+     (*
+      *  Perform the backward pass, merging dense groups.
+      *  Indices are between cs.labels.tide-1 and 0.
+      *)
+      index := cs.labels.tide-1; dense := FALSE; crGrp := NIL;
+      WHILE (index >= 0) & ~dense  DO
+       (* Invariant: all ranges with index > "index" have been  *
+        * grouped and appended to the first pass list p1Grp.  *)
+        dense := TRUE;
+        crRng := cs.labels.a[index];
+        sM := crRng.hiC;
+        crGrp := newTriple(index, index, sM - crRng.loC + 1);
+        WHILE (index > 0) & dense DO
+         (* Invariant: crGrp groups info on all ranges with   *
+          * index >= "index" not already appended to tempGP *)
+          DEC(index);
+          crRng := cs.labels.a[index];
+          nextN := crGrp.ord + crRng.hiC -crRng.loC + 1;
+          IF nextN / (sM - crRng.loC + 1) > DENSITY THEN
+            crGrp.loC := index; crGrp.ord := nextN; (* add to crGrp *)
+          ELSE
+            AppendTriple(p1Grp, crGrp); dense := FALSE; (* append; exit *)
+          END;
+        END;
+      END;
+      IF dense THEN AppendTriple(p1Grp, crGrp) END;
+   (* IF G.verbose THEN p1Grp.Diagnose("first pass groups") END; *)
+     (*
+      *  Perform the forward pass, merging dense groups.
+      *  Indices are between 0 and p1Grp.tide-1.
+      *  Note the implicit list reversal here.
+      *)
+      index := p1Grp.tide-1; dense := FALSE;
+      WHILE (index >= 0) & ~dense DO
+       (* Invariant: all groups with index > "index" have been  *
+        * grouped and appended to the final list cs.groups. *)
+        dense := TRUE;
+        crGrp := p1Grp.a[index];
+        sm := cs.labels.a[crGrp.loC].loC;
+        WHILE (index > 0) & dense DO
+         (* Invariant: crGrp contains info on all groups with   *
+          * index >= "index" not already appended to tempGP *)
+          DEC(index);
+          crRng := p1Grp.a[index];
+          sM := cs.labels.a[crRng.hiC].hiC;
+          nextN := crGrp.ord + crRng.ord;
+          IF nextN / (sM - sm + 1) > DENSITY THEN
+            crGrp.hiC := crRng.hiC; crGrp.ord := nextN; (* add to crGrp *)
+          ELSE
+            AppendTriple(cs.groups, crGrp);     (* append; exit *)
+            dense := FALSE;
+          END;
+        END;
+      END;
+      IF dense THEN AppendTriple(cs.groups, crGrp) END;
+   (* IF G.verbose THEN cs.groups.Diagnose("final groups") END; *)
+    END FindGroups;
+
+  (* ------------------------- *)
+
+  BEGIN
+    IF s.blocks.tide = 0 THEN RETURN END; (* Empty case statement *)
+   (*
+    *  First: do all controlled statement attribution.
+    *)
+    FOR index := 0 TO s.blocks.tide - 1 DO
+      s.blocks.a[index].StmtAttr(scope);
+    END;
+    IF s.elsBlk # NIL THEN s.elsBlk.StmtAttr(scope) END;
+   (*
+    *  Next: sort all triples on the loC value.
+    *)
+ (* IF G.verbose THEN s.labels.Diagnose("unsorted labels") END; *)
+    QuickSort(s.labels, 0, s.labels.tide - 1);
+ (* IF G.verbose THEN s.labels.Diagnose("sorted labels") END; *)
+   (*
+    *  Next: compact adjacent cases with same block-ord.
+    *)
+    Compact(s);
+   (*
+    *  Next: create lists of dense subranges.
+    *)
+    FindGroups(s);
+  END StmtAttr;
+
+(* ============================================================ *)
+(*  Flow attribute evaluation for all statement types *)
+(* ============================================================ *)
+
+  PROCEDURE (s : Block)flowAttr*(t : D.Scope; i : V.VarSet) : V.VarSet;
+    VAR ix : INTEGER;
+  BEGIN
+    FOR ix := 0 TO s.sequ.tide-1 DO
+      i := s.sequ.a[ix].flowAttr(t, i);
+    END;
+    RETURN i;
+  END flowAttr;
+
+  (* ---------------------------------- *)
+
+  PROCEDURE (s : Assign)flowAttr*(t : D.Scope; lvIn : V.VarSet) : V.VarSet;
+   (* Invariant: param lvIn is unchanged by this procedure *)
+    VAR lhLv, rhLv : V.VarSet;
+  BEGIN
+    rhLv := s.rhsX.checkLive(t, lvIn);
+    lhLv := s.lhsX.assignLive(t, lvIn); (* specialized for Assign | others *)
+    RETURN lhLv.cup(rhLv);
+  END flowAttr;
+
+  (* ---------------------------------- *)
+
+  PROCEDURE (s : Empty)flowAttr*(t : D.Scope; i : V.VarSet) : V.VarSet;
+  BEGIN
+    RETURN i;
+  END flowAttr;
+
+  (* ---------------------------------- *)
+
+  PROCEDURE (s : Return)flowAttr*(t : D.Scope; live : V.VarSet) : V.VarSet;
+  BEGIN
+    IF s.retX # NIL THEN live := s.retX.checkLive(t, live) END;
+    t.type.OutCheck(live);
+    RETURN V.newUniv(live.cardinality());
+  END flowAttr;
+
+  (* ---------------------------------- *)
+
+  PROCEDURE (s : ProcCall)flowAttr*(t : D.Scope; i : V.VarSet) : V.VarSet;
+  BEGIN
+    RETURN s.expr.checkLive(t, i);
+  END flowAttr;
+
+  (* ---------------------------------- *)
+
+  PROCEDURE (s : ForLoop)flowAttr*(t : D.Scope; live : V.VarSet) : V.VarSet;
+    VAR junk : V.VarSet;
+  BEGIN
+   (*
+    *   The limits are evaluated in a prescribed order,
+    *   chaining the live set. The body may or may not
+    *   be evaluated.  [We might later test this for static
+    *   evaluation, but might need to emit different code
+    *   for the two cases, to keep the verifier happy.]
+    *   [This is now done, 30-Mar-2000, (kjg)]
+    *)
+    live := s.loXp.checkLive(t, live);
+    live := s.hiXp.checkLive(t, live);
+    live := live.newCopy();
+    live.Incl(s.cVar(I.AbVar).varOrd);
+    junk := s.body.flowAttr(t,live);
+    IF s.isSimple() THEN
+     (*
+      *   If this for loop is simple, it will be executed
+      *   at least once.  Thus the flow-attribution consequences
+      *   of execution will be included in live-out var-set.
+      *)
+      live := live.cup(junk);
+    END;
+    RETURN live;
+  END flowAttr;
+
+  (* ---------------------------------- *)
+
+  PROCEDURE (s : Choice)flowAttr*(t : D.Scope; live : V.VarSet) : V.VarSet;
+    VAR idx : INTEGER;
+        out : V.VarSet;
+        tru : V.VarSet;
+        fal : V.VarSet;
+        pred : D.Expr;
+        else : BOOLEAN;
+  BEGIN
+    out := V.newUniv(live.cardinality());
+    tru := live;
+    fal := live;
+    IF s.kind = ifStat THEN
+     (*
+      *  In the case of IF statements there is always the possiblity
+      *  that a predicate evaluation will have a side-effect. Thus ...
+      *)
+      else := FALSE;
+      FOR idx := 0 TO s.preds.tide-1 DO
+        pred := s.preds.a[idx];
+        IF pred # NIL THEN
+          pred.BoolLive(t, fal, tru, fal);
+          out  := out.cap(s.blocks.a[idx].flowAttr(t, tru));
+        ELSE (* must be elsepart *)
+          else := TRUE;
+          out  := out.cap(s.blocks.a[idx].flowAttr(t, fal));
+        END;
+      END;
+     (*
+      *   If we did not find an elsepart, then we must
+      *   merge the result of executing the implicit "skip".
+      *)
+      IF ~else THEN out  := out.cap(fal) END;
+    ELSE
+     (*
+      *  In the case of WITH statements there is no evaluation
+      *  involved in the predicate test, and hence no side-effect.
+      *)
+      FOR idx := 0 TO s.preds.tide-1 DO
+        pred := s.preds.a[idx];
+        IF pred # NIL THEN
+          tru := pred(E.BinaryX).lKid.checkLive(t, live);
+        END;
+        out := out.cap(s.blocks.a[idx].flowAttr(t, tru));
+      END;
+    END;
+    RETURN out;
+  END flowAttr;
+
+  (* ---------------------------------- *)
+
+  PROCEDURE (s : ExitSt)flowAttr*(t : D.Scope; live : V.VarSet) : V.VarSet;
+  (* Merge all exit sets into the "merge" set of the enclosing  *)
+  (* LOOP.  Return the input live set, unchanged.   *)
+  BEGIN
+    s.loop.merge := live.cap(s.loop.merge);
+    RETURN V.newUniv(live.cardinality());
+  END flowAttr;
+
+  (* ---------------------------------- *)
+
+  PROCEDURE (s : TestLoop)flowAttr*(t : D.Scope; live : V.VarSet) : V.VarSet;
+    VAR tSet, fSet, junk : V.VarSet;
+  BEGIN
+    IF s.kind = whileS THEN
+     (*
+      *  For a WHILE statement, the expression is evaluated first.
+      *)
+      s.test.BoolLive(t, live, tSet, fSet);
+      junk := s.body.flowAttr(t, tSet);
+      RETURN fSet;
+    ELSIF s.kind = repeatS THEN
+     (*
+      *  For a REPEAT statement, the expression is evaluated last.
+      *)
+      junk := s.body.flowAttr(t, live);
+      s.test.BoolLive(t, junk, tSet, fSet);
+      RETURN fSet;
+    ELSE (* must be loopS *)
+      s.merge := V.newUniv(live.cardinality());
+      junk := s.body.flowAttr(t, live);
+      RETURN s.merge;
+    END;
+    RETURN live;
+  END flowAttr;
+
+  (* ---------------------------------- *)
+
+  PROCEDURE (s : CaseSt)flowAttr*(t : D.Scope; live : V.VarSet) : V.VarSet;
+    VAR lvOu : V.VarSet;
+        indx : INTEGER;
+        tmp : V.VarSet;
+  BEGIN
+    lvOu := V.newUniv(live.cardinality());
+    live := s.select.checkLive(t, live);
+   (*
+    *  The live-out set of this statement is the intersection
+    *  of the live-out of all of the components of the CASE.
+    *  All cases receive the same input set: the result of the
+    *  evaluation of the select expression.
+    *)
+    FOR indx := 0 TO s.blocks.tide-1 DO
+      lvOu := lvOu.cap(s.blocks.a[indx].flowAttr(t, live));
+    END;
+   (*
+    *  In the event that there is no ELSE case, and unlike the
+    *  case of the IF statement, the program aborts and does
+    *  not effect the accumulated live-out set, lvOu.
+    *)
+    IF s.elsBlk # NIL THEN
+      lvOu := lvOu.cap(s.elsBlk.flowAttr(t, live));
+    END;
+    RETURN lvOu;
+  END flowAttr;
+
+(* ============================================================ *)
+(*          Diagnostic Procedures     *)
+(* ============================================================ *)
+
+  PROCEDURE WriteTag(t : D.Stmt; ind : INTEGER);
+  BEGIN
+    H.Indent(ind);
+    CASE t.kind OF
+    | emptyS   : Console.WriteString("emptyS   ");
+    | assignS  : Console.WriteString("assignS  ");
+    | procCall : Console.WriteString("procCall ");
+    | ifStat   : Console.WriteString("ifStat   ");
+    | caseS    : Console.WriteString("caseS    ");
+    | whileS   : Console.WriteString("whileS   ");
+    | repeatS  : Console.WriteString("repeatS  ");
+    | forStat  : Console.WriteString("forStat  ");
+    | loopS    : Console.WriteString("loopS    ");
+    | withS    : Console.WriteString("withS    ");
+    | exitS    : Console.WriteString("exitS    ");
+    | returnS  : Console.WriteString("returnS  ");
+    | blockS   : Console.WriteString("blockS   ");
+    ELSE
+      Console.WriteString("unknown stmt, tag="); Console.WriteInt(t.kind,1);
+    END;
+    IF t.token # NIL THEN
+      Console.WriteString("(lin:col ");
+      Console.WriteInt(t.token.lin, 1); Console.Write(":");
+      Console.WriteInt(t.token.col, 1); Console.Write(")");
+    END;
+  END WriteTag;
+
+  (* ---------------------------------- *)
+
+  PROCEDURE (t : Empty)Diagnose*(i : INTEGER);
+  BEGIN
+    WriteTag(t, i); Console.WriteLn;
+  END Diagnose;
+
+  (* ---------------------------------- *)
+
+  PROCEDURE (t : Return)Diagnose*(i : INTEGER);
+  BEGIN
+    WriteTag(t, i); Console.WriteLn;
+    IF t.retX # NIL THEN t.retX.Diagnose(i+4) END;
+  END Diagnose;
+
+  (* ---------------------------------- *)
+
+  PROCEDURE (t : Block)Diagnose*(i : INTEGER);
+    VAR index : INTEGER;
+  BEGIN
+    WriteTag(t, i);
+    Console.WriteString(" {"); Console.WriteLn;
+    FOR index := 0 TO t.sequ.tide - 1 DO
+      t.sequ.a[index].Diagnose(i+4);
+    END;
+    H.Indent(i); Console.Write("}"); Console.WriteLn;
+  END Diagnose;
+
+  (* ---------------------------------- *)
+
+  PROCEDURE (t : Assign)Diagnose*(i : INTEGER);
+  BEGIN
+    WriteTag(t, i); Console.WriteLn;
+    IF t.lhsX # NIL THEN t.lhsX.Diagnose(i+4) END;
+    IF t.rhsX # NIL THEN t.rhsX.Diagnose(i+4) END;
+  END Diagnose;
+
+  (* ---------------------------------- *)
+
+  PROCEDURE (t : ProcCall)Diagnose*(i : INTEGER);
+  BEGIN
+    WriteTag(t, i); Console.WriteLn;
+    IF t.expr # NIL THEN t.expr.Diagnose(i+4) END;
+  END Diagnose;
+
+  (* ---------------------------------- *)
+
+  PROCEDURE (t : ForLoop)Diagnose*(i : INTEGER);
+  BEGIN
+    WriteTag(t, i);
+    IF t.cVar # NIL THEN t.cVar.WriteName END;
+    Console.WriteLn;
+    IF t.loXp # NIL THEN t.loXp.Diagnose(i+2) END;
+    IF t.hiXp # NIL THEN t.hiXp.Diagnose(i+2) END;
+    H.Indent(i); Console.Write("{"); Console.WriteLn;
+    t.body.Diagnose(i+4);
+    H.Indent(i); Console.Write("}"); Console.WriteLn;
+  END Diagnose;
+
+  (* ---------------------------------- *)
+
+  PROCEDURE (t : Choice)Diagnose*(i : INTEGER);
+    CONST nil = "<nil>";
+    VAR index : INTEGER;
+        stmt  : D.Stmt;
+        expr  : D.Expr;
+  BEGIN
+    WriteTag(t, i); Console.Write("{"); Console.WriteLn;
+    FOR index := 0 TO t.preds.tide - 1 DO
+      expr := t.preds.a[index];
+      stmt := t.blocks.a[index];
+      IF expr = NIL THEN
+        H.Indent(i); Console.WriteString(nil); Console.WriteLn;
+      ELSE
+        expr.Diagnose(i);
+      END;
+      IF stmt = NIL THEN
+        H.Indent(i+4); Console.WriteString(nil); Console.WriteLn;
+      ELSE
+        stmt.Diagnose(i+4);
+      END;
+    END;
+    H.Indent(i); Console.Write("}"); Console.WriteLn;
+  END Diagnose;
+
+  (* ---------------------------------- *)
+
+  PROCEDURE (t : ExitSt)Diagnose*(i : INTEGER);
+  BEGIN
+    WriteTag(t, i); Console.WriteLn;
+  END Diagnose;
+
+  (* ---------------------------------- *)
+
+  PROCEDURE (t : TestLoop)Diagnose*(i : INTEGER);
+  BEGIN
+    WriteTag(t, i); Console.WriteLn;
+    IF t.test # NIL THEN t.test.Diagnose(i) END;
+    H.Indent(i); Console.Write("{"); Console.WriteLn;
+    t.body.Diagnose(i+4);
+    H.Indent(i); Console.Write("}"); Console.WriteLn;
+  END Diagnose;
+
+  (* ---------------------------------- *)
+
+  PROCEDURE (t : CaseSt)Diagnose*(i : INTEGER);
+    VAR index : INTEGER;
+        trio  : Triple;
+        next  : Triple;
+        stIx  : INTEGER;
+
+  (* ------------------------- *)
+    PROCEDURE WriteTrio(p : Triple);
+    BEGIN
+      Console.WriteInt(p.loC, 0);
+      IF p.loC # p.hiC THEN
+        Console.WriteString(" ..");
+        Console.WriteInt(p.hiC, 0);
+      END;
+    END WriteTrio;
+  (* ------------------------- *)
+
+  BEGIN
+    WriteTag(t, i); Console.WriteLn;
+    IF t.select # NIL THEN t.select.Diagnose(i) END;
+    H.Indent(i); Console.Write("{"); Console.WriteLn;
+    index := 0;
+    IF t.labels.tide > 0 THEN
+      H.Indent(i); Console.Write("|");
+      trio := t.labels.a[index]; stIx := trio.ord; INC(index);
+      WHILE index < t.labels.tide DO
+        next := t.labels.a[index]; INC(index);
+        IF next.ord = stIx THEN (* write out previous label *)
+          WriteTrio(trio);
+          trio := next;
+          Console.WriteString(", ");
+        ELSE (* next label belongs to the next case *)
+          WriteTrio(trio);
+          Console.WriteString(" : #");
+          Console.WriteInt(trio.ord, 1); Console.WriteLn;
+          H.Indent(i); Console.Write("|");
+          trio := next; stIx := trio.ord;
+        END;
+      END;
+      (* write out last label and case *)
+      WriteTrio(trio);
+      Console.WriteString(" : #");
+      Console.WriteInt(trio.ord, 1); Console.WriteLn;
+      FOR index := 0 TO t.blocks.tide - 1 DO
+        H.Indent(i); Console.Write("#"); Console.WriteInt(index, 1);
+        Console.WriteString(" -->"); Console.WriteLn;
+        t.blocks.a[index].Diagnose(i+4);
+      END;
+    END;
+    H.Indent(i); Console.WriteString("else");
+    IF t.elsBlk # NIL THEN
+      Console.WriteLn;
+      t.elsBlk.Diagnose(i+4);
+    ELSE
+      Console.WriteString(" trap here");
+      Console.WriteLn;
+    END;
+    H.Indent(i); Console.Write("}"); Console.WriteLn;
+  END Diagnose;
+
+(* ============================================================ *)
+BEGIN (* ====================================================== *)
+END StatDesc. (* ============================================== *)
+(* ============================================================ *)
+

gpcp/SymReader.cp

@@ -0,0 +1,1506 @@
+MODULE SymReader;
+(* ========================================================================= *)
+(*                                                                           *)
+(*  Symbol file reading module for the .NET to Gardens Point Component       *)
+(*  Pascal Symbols tool.                                                     *)
+(*      Copyright (c) Siu-Yuen Chan 2001.                                    *)
+(*                                                                           *)
+(*  This module reads Gardens Point Component Pascal (GPCP) symbol files     *)
+(*  and stores all meta information read into METASTORE (defined by          *)
+(*  MetaStore module).                                                       *)
+(* ========================================================================= *)
+
+IMPORT
+    Error,
+    GPFiles,
+    GF := GPBinFiles,
+    MS := MetaStore,
+    MP := MetaParser,
+    ST := AscString,
+    RTS;
+
+(* ========================================================================= *
+// Collected syntax ---
+// 
+// SymFile    = Header [String (falSy | truSy | <other attribute>)]
+//              {Import | Constant | Variable | Type | Procedure} 
+//              TypeList Key.
+//      -- optional String is external name.
+//      -- falSy ==> Java class
+//      -- truSy ==> Java interface
+//      -- others ...
+// Header     = magic modSy Name.
+// VersionName= numSy longint numSy longint numSy longint.
+//      --            mj# mn#       bld rv#    8xbyte extract
+// Import     = impSy Name [String] Key.
+//      -- optional string is explicit external name of class
+// Constant   = conSy Name Literal.
+// Variable   = varSy Name TypeOrd.
+// Type       = typSy Name TypeOrd.
+// Procedure  = prcSy Name [String] FormalType.
+//      -- optional string is explicit external name of procedure
+// Method     = mthSy Name byte byte TypeOrd [String] FormalType.
+//      -- optional string is explicit external name of method
+// FormalType = [retSy TypeOrd] frmSy {parSy byte TypeOrd} endFm.
+//      -- optional phrase is return type for proper procedures
+// TypeOrd    = ordinal.
+// TypeHeader = tDefS Ord [fromS Ord Name].
+//      -- optional phrase occurs if:
+//      -- type not from this module, i.e. indirect export
+// TypeList   = start { Array | Record | Pointer | ProcType } close.
+// Array      = TypeHeader arrSy TypeOrd (Byte | Number | <empty>) endAr.
+//      -- nullable phrase is array length for fixed length arrays
+// Pointer    = TypeHeader ptrSy TypeOrd.
+// Event      = TypeHeader evtSy FormalType.
+// ProcType   = TypeHeader pTpSy FormalType.
+// Record     = TypeHeader recSy recAtt [truSy | falSy]
+//              [basSy TypeOrd] [iFcSy {basSy TypeOrd}]
+//              {Name TypeOrd} {Method} endRc.
+//      -- truSy ==> is an extension of external interface
+//      -- falSy ==> is an extension of external class
+//      -- basSy option defines base type, if not ANY / j.l.Object
+// NamedType  = TypeHeader
+// Name       = namSy byte UTFstring.
+// Literal    = Number | String | Set | Char | Real | falSy | truSy.
+// Byte       = bytSy byte.
+// String     = strSy UTFstring.
+// Number     = numSy longint.
+// Real       = fltSy ieee-double.
+// Set        = setSy integer.
+// Key        = keySy integer..
+// Char       = chrSy unicode character.
+//
+// Notes on the syntax:
+// All record types must have a Name field, even though this is often
+// redundant.  The issue is that every record type (including those that
+// are anonymous in CP) corresponds to a IR class, and the definer 
+// and the user of the class _must_ agree on the IR name of the class.
+// The same reasoning applies to procedure types, which must have equal
+// interface names in all modules.
+// ======================================================================== *)
+
+
+CONST
+    modSy = ORD('H');  namSy = ORD('$');  bytSy = ORD('\');
+    numSy = ORD('#');  chrSy = ORD('c');  strSy = ORD('s');
+    fltSy = ORD('r');  falSy = ORD('0');  truSy = ORD('1');
+    impSy = ORD('I');  setSy = ORD('S');  keySy = ORD('K');
+    conSy = ORD('C');  typSy = ORD('T');  tDefS = ORD('t');
+    prcSy = ORD('P');  retSy = ORD('R');  mthSy = ORD('M');
+    varSy = ORD('V');  parSy = ORD('p');  start = ORD('&');
+    close = ORD('!');  recSy = ORD('{');  endRc = ORD('}');
+    frmSy = ORD('(');  fromS = ORD('@');  endFm = ORD(')');
+    arrSy = ORD('[');  endAr = ORD(']');  pTpSy = ORD('%');
+    ptrSy = ORD('^');  basSy = ORD('+');  eTpSy = ORD('e');
+    iFcSy = ORD('~');  evtSy = ORD('v');
+
+CONST
+    tOffset*  = 16; (* backward compatibility with JavaVersion *)
+    iOffset   = 1;
+
+CONST
+    magic   = 0DEADD0D0H;
+    syMag   = 0D0D0DEADH;
+    dumped* = -1;
+
+CONST (* record attributes *)
+    noAtt* = ORD(MS.noAtt);  (* no attribute *)
+    abstr* = ORD(MS.Rabstr); (* Is ABSTRACT *)
+    limit* = ORD(MS.Rlimit); (* Is LIMIT *)
+    extns* = ORD(MS.Rextns); (* Is EXTENSIBLE *)
+    iFace* = ORD(MS.RiFace); (* Is INTERFACE *) 
+    nnarg* = ORD(MS.Rnnarg); (* Has NO NoArg Constructor ( cannot use NEW() ) *)
+    valTp* = ORD(MS.RvalTp); (* ValueType *)
+
+
+TYPE
+(*
+    CharOpen* = POINTER TO ARRAY OF CHAR;
+*)
+    CharOpen* = ST.CharOpen;
+
+    TypeSeq = POINTER TO
+        RECORD 
+            tide: INTEGER;
+            high: INTEGER;
+            a: POINTER TO ARRAY OF MS.Type;
+        END;
+
+    ScopeSeq = POINTER TO
+        RECORD 
+            tide: INTEGER;
+            high: INTEGER;
+            a: POINTER TO ARRAY OF MS.Namespace;
+        END;
+
+    Reader* = POINTER TO 
+        RECORD
+            file: GF.FILE;
+            fasb: MS.Assembly;
+            fns : MS.Namespace;
+            sSym  : INTEGER;            (* the symbol read in *)
+            cAtt  : CHAR;               (* character attribute *)
+            iAtt  : INTEGER;            (* integer attribute *)
+            lAtt  : LONGINT;            (* long attribute *)
+            rAtt  : REAL;               (* real attribute *)
+            sAtt  : ARRAY 128 OF CHAR;  (* string attribute *)
+            sArray: ScopeSeq;
+            tArray: TypeSeq;
+            tNxt  : INTEGER;
+        END;
+
+    (* for building temporary formal list *)
+    FmlList = POINTER TO
+        RECORD
+            fml: MS.Formal;
+            nxt: FmlList;
+        END;
+
+
+
+PROCEDURE InitTypeSeq(seq: TypeSeq; capacity : INTEGER); 
+BEGIN
+    NEW(seq.a, capacity);
+    seq.high := capacity-1;
+    seq.tide := 0;
+END InitTypeSeq;
+
+
+PROCEDURE AppendType(VAR seq : TypeSeq; elem : MS.Type);
+VAR
+    temp : POINTER TO ARRAY OF MS.Type;
+    i    : INTEGER;
+BEGIN
+    IF seq.a = NIL THEN 
+      InitTypeSeq(seq, 2);
+    ELSIF seq.tide > seq.high THEN (* must expand *)
+      temp := seq.a;
+      seq.high := seq.high * 2 + 1;
+      NEW(seq.a, (seq.high+1));
+      FOR i := 0 TO seq.tide-1 DO seq.a[i] := temp[i] END;
+    END; (* IF *)
+    seq.a[seq.tide] := elem; INC(seq.tide); 
+END AppendType;
+
+
+PROCEDURE InitScopeSeq(seq: ScopeSeq; capacity : INTEGER); 
+BEGIN
+    NEW(seq.a, capacity);
+    seq.high := capacity-1;
+    seq.tide := 0;
+END InitScopeSeq;
+
+
+PROCEDURE AppendScope(VAR seq : ScopeSeq; elem : MS.Namespace);
+VAR
+    temp : POINTER TO ARRAY OF MS.Namespace;
+    i    : INTEGER;
+BEGIN
+    IF seq.a = NIL THEN 
+      InitScopeSeq(seq, 2);
+    ELSIF seq.tide > seq.high THEN (* must expand *)
+      temp := seq.a;
+      seq.high := seq.high * 2 + 1;
+      NEW(seq.a, (seq.high+1));
+      FOR i := 0 TO seq.tide-1 DO seq.a[i] := temp[i] END;
+    END; (* IF *)
+    seq.a[seq.tide] := elem; INC(seq.tide); 
+END AppendScope;
+
+
+PROCEDURE (rd: Reader) Read(): INTEGER, NEW;
+BEGIN
+    RETURN GF.readByte(rd.file);
+END Read;
+
+
+PROCEDURE (rd: Reader) ReadChar(): CHAR, NEW;
+BEGIN
+    RETURN CHR(rd.Read() * 256 + rd.Read());
+END ReadChar;
+
+
+PROCEDURE (rd: Reader) ReadInt(): INTEGER, NEW;
+BEGIN [UNCHECKED_ARITHMETIC]
+    (* overflow checking off here *)
+    RETURN ((rd.Read() * 256 + rd.Read()) * 256 + rd.Read()) * 256 + rd.Read();
+END ReadInt;
+
+
+PROCEDURE (rd: Reader) ReadLong(): LONGINT, NEW;
+VAR
+    result : LONGINT;
+    index  : INTEGER;
+BEGIN [UNCHECKED_ARITHMETIC]
+    (* overflow checking off here *)
+    result := rd.Read();
+    FOR index := 1 TO 7 DO
+      result := result * 256 + rd.Read();
+    END; (* FOR *)
+    RETURN result;
+END ReadLong;
+
+
+PROCEDURE (rd: Reader) ReadReal(): REAL, NEW;
+VAR
+    result : LONGINT;
+BEGIN
+    result := rd.ReadLong();
+    RETURN RTS.longBitsToReal(result);
+END ReadReal;
+
+
+PROCEDURE (rd: Reader) ReadOrd(): INTEGER, NEW;
+VAR
+    chr : INTEGER;
+BEGIN
+    chr := rd.Read();
+    IF chr <= 07FH THEN RETURN chr;
+    ELSE
+        DEC(chr, 128);
+        RETURN chr + rd.Read() * 128;
+    END; (* IF *)
+END ReadOrd;
+
+
+PROCEDURE (rd: Reader) ReadUTF(OUT nam : ARRAY OF CHAR), NEW;
+CONST
+    bad = "Bad UTF-8 string";
+VAR
+    num : INTEGER;
+    bNm : INTEGER;
+    idx : INTEGER;
+    chr : INTEGER;
+BEGIN
+    num := 0;
+    bNm := rd.Read() * 256 + rd.Read();
+    FOR idx := 0 TO bNm-1 DO
+        chr := rd.Read();
+        IF chr <= 07FH THEN                   (* [0xxxxxxx] *)
+            nam[num] := CHR(chr); INC(num);
+        ELSIF chr DIV 32 = 06H THEN           (* [110xxxxx,10xxxxxx] *)
+            bNm := chr MOD 32 * 64;
+            chr := rd.Read();
+            IF chr DIV 64 = 02H THEN
+                nam[num] := CHR(bNm + chr MOD 64); INC(num);
+            ELSE
+                RTS.Throw(bad);
+            END; (* IF *)
+        ELSIF chr DIV 16 = 0EH THEN           (* [1110xxxx,10xxxxxx,10xxxxxx] *)
+            bNm := chr MOD 16 * 64;
+            chr := rd.Read();
+            IF chr DIV 64 = 02H THEN
+                bNm := (bNm + chr MOD 64) * 64; 
+                chr := rd.Read();
+                IF chr DIV 64 = 02H THEN
+                    nam[num] := CHR(bNm + chr MOD 64); INC(num);
+                ELSE 
+                    RTS.Throw(bad);
+                END; (* IF *)
+            ELSE
+                RTS.Throw(bad);
+            END; (* IF *)
+        ELSE
+            RTS.Throw(bad);
+        END; (* IF *)
+    END; (* FOR *)
+    nam[num] := 0X;
+END ReadUTF;
+
+
+PROCEDURE (rd: Reader) GetSym(), NEW;
+BEGIN
+    rd.sSym := rd.Read();
+    CASE rd.sSym OF
+    | namSy : 
+        rd.iAtt := rd.Read(); rd.ReadUTF(rd.sAtt);
+    | strSy : 
+        rd.ReadUTF(rd.sAtt);
+    | retSy, fromS, tDefS, basSy :
+        rd.iAtt := rd.ReadOrd();
+    | bytSy :
+        rd.iAtt := rd.Read();
+    | keySy, setSy :
+        rd.iAtt := rd.ReadInt();
+    | numSy :
+        rd.lAtt := rd.ReadLong();
+    | fltSy :
+        rd.rAtt := rd.ReadReal();
+    | chrSy :
+        rd.cAtt := rd.ReadChar();
+    ELSE (* nothing to do *)
+    END; (* CASE *)
+END GetSym;
+
+
+PROCEDURE (rd: Reader) Abandon(), NEW;
+BEGIN
+    RTS.Throw(ST.StrCat(ST.ToChrOpen("Bad symbol file format - "),
+                        ST.ToChrOpen(GF.getFullPathName(rd.file))));
+END Abandon;
+
+
+PROCEDURE (rd: Reader) ReadPast(sym : INTEGER), NEW;
+BEGIN
+    IF rd.sSym # sym THEN rd.Abandon(); END;
+    rd.GetSym();
+END ReadPast;
+
+
+PROCEDURE NewReader*(file: GF.FILE) : Reader;
+VAR
+    new: Reader;
+BEGIN
+    NEW(new);
+    NEW(new.tArray);
+    NEW(new.sArray);
+    new.file := file;
+    InitTypeSeq(new.tArray, 8);
+    InitScopeSeq(new.sArray, 8);
+    new.tNxt := tOffset;
+    RETURN new;
+END NewReader;
+
+
+PROCEDURE (rd: Reader) TypeOf(ord : INTEGER): MS.Type, NEW;
+VAR
+    newT : MS.TempType;
+    indx : INTEGER;
+    rslt : MS.Type;
+BEGIN
+    IF ord < tOffset THEN                               (* builtin type *)
+        rslt := MS.baseTypeArray[ord];
+        IF rslt = NIL THEN
+            rslt := MS.MakeDummyPrimitive(ord);
+        END; (* IF *)
+        RETURN rslt;
+    ELSIF ord - tOffset < rd.tArray.tide THEN           (* type already read *)
+        RETURN rd.tArray.a[ord - tOffset];
+    ELSE 
+        indx := rd.tArray.tide + tOffset;
+        REPEAT
+            (* create types and append to tArray until ord is reached *)
+            (* details of these types are to be fixed later *)
+            newT := MS.NewTempType();
+            newT.SetTypeOrd(indx); INC(indx);
+            AppendType(rd.tArray, newT);
+        UNTIL indx > ord;
+        RETURN newT;
+    END; (* IF *)
+END TypeOf;
+
+
+PROCEDURE (rd: Reader) GetTypeFromOrd(): MS.Type, NEW;
+VAR
+    ord : INTEGER;
+BEGIN
+    ord := rd.ReadOrd();
+    rd.GetSym();
+    RETURN rd.TypeOf(ord);
+END GetTypeFromOrd;
+
+
+PROCEDURE (rd: Reader) GetHeader(modname: CharOpen), NEW;
+VAR
+    marker: INTEGER;
+    idx1, idx2: INTEGER;
+    scopeNm: CharOpen;
+    str: CharOpen;
+BEGIN
+    marker := rd.ReadInt();
+    IF marker = RTS.loInt(magic) THEN
+        (* normal case, nothing to do *)
+    ELSIF marker = RTS.loInt(syMag) THEN
+        (* should never reach here for foreign module *)
+    ELSE
+        (* Error *)
+        Error.WriteString("File <");
+        Error.WriteString(GF.getFullPathName(rd.file));
+        Error.WriteString("> wrong format"); Error.WriteLn;
+        RETURN;
+    END; (* IF *)
+    rd.GetSym();
+    rd.ReadPast(modSy);
+    IF rd.sSym = namSy THEN
+        IF modname^ # ST.ToChrOpen(rd.sAtt)^ THEN
+            Error.WriteString("Wrong name in symbol file. Expected <");
+            Error.WriteString(modname); Error.WriteString(">, found <");
+            Error.WriteString(rd.sAtt); Error.WriteString(">"); Error.WriteLn;
+            HALT(1);
+        END; (* IF *)
+        rd.GetSym();
+    ELSE
+        RTS.Throw("Bad symfile header");
+    END; (* IF *)
+    IF rd.sSym = strSy THEN (* optional name *)
+        (* non-GPCP module *)
+        scopeNm := ST.ToChrOpen(rd.sAtt);
+        idx1 := ST.StrChr(scopeNm, '['); idx2 := ST.StrChr(scopeNm, ']');
+        str := ST.SubStr(scopeNm,idx1+1, idx2-1);
+        rd.fasb := MS.GetAssemblyByName(ST.StrSubChr(str,'.','_'));
+        ASSERT(rd.fasb # NIL);
+        str := ST.SubStr(scopeNm, idx2+1, LEN(scopeNm)-1);
+        rd.fns  := rd.fasb.GetNamespace(str);
+        ASSERT(rd.fns # NIL);
+
+        rd.GetSym();
+        IF (rd.sSym = falSy) OR (rd.sSym = truSy) THEN
+            rd.GetSym();
+        ELSE
+            RTS.Throw("Bad explicit name");
+        END; (* IF *)
+    ELSE
+        (* GPCP module *)
+        rd.fasb := MS.GetAssemblyByName(modname);
+        ASSERT(rd.fasb # NIL);
+        rd.fns  := rd.fasb.GetNamespace(modname);
+        ASSERT(rd.fns # NIL);
+    END; (* IF *)
+END GetHeader;
+
+
+PROCEDURE (rd: Reader) GetVersionName(), NEW;
+VAR
+    i: INTEGER;
+    version: MS.Version;
+    token: MS.PublicKeyToken;
+BEGIN
+    (* get the assembly version *)
+    ASSERT(rd.sSym = numSy); NEW(version);
+    version[MS.Major] := RTS.loShort(RTS.hiInt(rd.lAtt));
+    version[MS.Minor] := RTS.loShort(RTS.loInt(rd.lAtt));
+    rd.GetSym();
+    version[MS.Build] := RTS.loShort(RTS.hiInt(rd.lAtt));
+    version[MS.Revis] := RTS.loShort(RTS.loInt(rd.lAtt));
+    rd.fasb.SetVersion(version);
+    (* get the assembly public key token *)
+    rd.sSym := rd.Read();
+    ASSERT(rd.sSym = numSy); NEW(token);
+    FOR i := 0 TO 7 DO
+        token[i] := RTS.loByte(RTS.loShort(rd.Read()));
+    END;
+    rd.fasb.SetPublicKeyToken(token);
+    (* get next symbol *)
+    rd.GetSym();
+END GetVersionName;
+
+
+PROCEDURE (rd: Reader)GetLiteral(): MS.Literal, NEW;
+VAR
+    lit: MS.Literal;
+BEGIN
+    CASE rd.sSym OF
+    | truSy :
+        lit := MS.MakeBoolLiteral(TRUE);
+    | falSy :
+        lit := MS.MakeBoolLiteral(FALSE);
+    | numSy :
+        lit := MS.MakeLIntLiteral(rd.lAtt);
+    | chrSy :
+        lit := MS.MakeCharLiteral(rd.cAtt);
+    | fltSy :
+        lit := MS.MakeRealLiteral(rd.rAtt);
+    | setSy :
+        lit := MS.MakeSetLiteral(BITS(rd.iAtt));
+    | strSy :
+        lit := MS.MakeStrLiteral(ST.ToChrOpen(rd.sAtt));        (* implicit rd.sAtt^ *)
+    ELSE
+        RETURN NIL;
+    END; (* CASE *)
+    rd.GetSym();                                        (* read past value  *)
+    RETURN lit;
+END GetLiteral;
+
+
+PROCEDURE (rd: Reader) Import, NEW;
+VAR
+    mname: CharOpen;
+    asbname: CharOpen;
+    asbfile: CharOpen;
+    nsname: CharOpen;
+    scopeNm: CharOpen;
+    idx1, idx2: INTEGER;
+    len: INTEGER;
+    asb: MS.Assembly;
+    ns: MS.Namespace;
+BEGIN
+    rd.ReadPast(namSy);
+    mname := ST.ToChrOpen(rd.sAtt);
+    IF rd.sSym = strSy THEN
+        (* non-GPCP module *)
+        scopeNm := ST.ToChrOpen(rd.sAtt);
+        idx1 := ST.StrChr(scopeNm, '['); idx2 := ST.StrChr(scopeNm, ']');
+        asbfile := ST.SubStr(scopeNm,idx1+1, idx2-1);
+        nsname := ST.SubStr(scopeNm, idx2+1, LEN(scopeNm)-1);
+        rd.GetSym();
+    ELSE
+        (* possible GPCP module *)
+        len := LEN(mname);
+        IF mname[len-2] = '_' THEN mname := ST.SubStr(mname, 0, len-3); END;
+        asbfile := mname;
+        nsname  := mname;  (* or it can be assigned as MS.NULLSPACE *)
+    END; (* IF *)
+    (* need to get the assembly real name here *)
+    asbname := MP.GetAssemblyRealName(asbfile);
+    asb := MS.InsertAssembly(asbname, asbfile);
+    ns := asb.InsertNamespace(nsname);
+    AppendScope(rd.sArray, ns);
+    rd.ReadPast(keySy);
+END Import;
+
+
+PROCEDURE (rd: Reader) ParseType, NEW;
+VAR
+    typ: MS.TempType;
+    ord: INTEGER;
+BEGIN
+    typ := MS.NewTempType();    (* this is a temporay type, not the final type *)
+    typ.SetName(ST.ToChrOpen(rd.sAtt));
+    typ.SetFullName(ST.StrCat(ST.StrCatChr(rd.fns.GetName(),'.'),typ.GetName()));
+    typ.SetVisibility(rd.iAtt);
+    ord := rd.ReadOrd();
+    IF ord >= tOffset THEN
+        ASSERT(rd.tNxt = ord);
+        typ.SetTypeOrd(ord);
+        AppendType(rd.tArray, typ); INC(rd.tNxt);
+        typ.SetNamespace(rd.fns);
+    ELSE
+        (* primitive types *)
+    END; (* IF *)
+    rd.GetSym();
+END ParseType;
+
+
+PROCEDURE (rd: Reader) GetFormalTypes(): MS.FormalList, NEW;
+(*
+// FormalType = [retSy TypeOrd] frmSy {parSy byte TypeOrd} endFm.
+//      -- optional phrase is return type for proper procedures
+ *)
+CONST
+    FNAME = "arg";
+VAR
+    rslt: MS.FormalList;
+    ftype: MS.Type;
+    fmode: INTEGER;
+    count: INTEGER;
+    temp: FmlList;
+    head: FmlList;
+    last: FmlList;
+    fml: MS.Formal;
+    pos: INTEGER;
+    str: CharOpen;
+    nametype: MS.Type;
+    unresolved: INTEGER;
+BEGIN
+    head := NIL; last := NIL; count := 0; ftype := NIL; NEW(str,3); unresolved := 0;
+    rd.ReadPast(frmSy);
+    WHILE rd.sSym = parSy DO
+        fmode := rd.Read();
+        ftype := rd.GetTypeFromOrd();
+        RTS.IntToStr(count, str);
+        WITH ftype: MS.NamedType DO
+            fml := MS.MakeFormal(ST.StrCat(ST.ToChrOpen(FNAME),str), ftype, fmode);
+        | ftype: MS.TempType DO
+            fml := MS.MakeFormal(ST.StrCat(ST.ToChrOpen(FNAME),str), MS.dmyTyp, fmode);
+            (* collect reference if TempType/NamedType *)
+            ftype.AddReferenceFormal(fml);
+            INC(unresolved);
+        ELSE
+            fml := MS.MakeFormal(ST.StrCat(ST.ToChrOpen(FNAME),str), ftype, fmode);
+        END; (* WITH *)
+
+        (* add the formal to a temporary formals linkedlist *)
+        NEW(temp); temp.nxt := NIL; temp.fml := fml;
+        IF last # NIL THEN last.nxt := temp; last := temp; ELSE last := temp; head := temp; END;
+        INC(count);
+    END; (* WHILE *)
+    rd.ReadPast(endFm);
+
+    (* now I know how many formals for the method *)
+    rslt := MS.CreateFormalList(count);
+    temp := head; pos := 0;
+    WHILE temp # NIL DO
+        rslt.AddFormal(temp.fml, pos);
+        temp := temp.nxt; INC(pos);
+    END; (* WHILE *)
+    rslt.ostd := unresolved;
+    RETURN rslt;
+END GetFormalTypes;
+
+
+PROCEDURE FixProcTypes(rec: MS.RecordType; newM: MS.Method; fl: MS.FormalList; rtype: MS.Type);
+VAR
+    newF: MS.Method;
+BEGIN
+    IF MS.WithoutMethodNameMangling() THEN
+        newF := newM;
+        WITH newF: MS.Function DO
+            WITH rtype: MS.TempType DO
+                (* not a concrete return type *)
+                WITH rtype: MS.NamedType DO
+                    (* return type name is resolved *)
+                    IF fl.ostd = 0 THEN
+                        (* no unresolved formal types names *)
+                        newM.FixSigCode();               (* fix the sigcode of newM *)
+                        newM := rec.AddMethod(newM);
+                    ELSE
+                        (* need to AddMethod after formal type names resolved *)
+                    END; (* IF *)
+                ELSE
+                    (* return type name is unresolved *)
+                    INC(newF.ostd);
+                    (* need to AddMethod after return type name and formal type names resolved *)
+                END; (* IF *)
+
+                (* collect reference if TempType/NamedType *)
+                rtype.AddReferenceFunction(newF);
+            ELSE
+                (* concrete return type ==> type name is solved *)
+                IF fl.ostd = 0 THEN
+                    (* no unresolved formal types names *)
+                    newM.FixSigCode();               (* fix the sigcode of newM *)
+                    newM := rec.AddMethod(newM);
+                ELSE
+                    (* need to AddMethod after formal type names resolved *)
+                END; (* IF *)
+            END; (* WITH *)
+        ELSE
+            (* not a function *)
+            IF fl.ostd = 0 THEN
+                (* no unresolved formal types names *)
+                newM.FixSigCode();               (* fix the sigcode of newM *)
+                newM := rec.AddMethod(newM);
+            ELSE
+                (* need to AddMethod after formal type names resolved *)
+            END; (* IF *)
+        END; (* WITH *)
+    ELSE
+        newM.FixSigCode();               (* fix the sigcode of newM *)
+        newM := rec.AddMethod(newM);
+        WITH newM: MS.Function DO
+            WITH rtype: MS.TempType DO
+                (* collect reference if TempType/NamedType *)
+                rtype.AddReferenceFunction(newM);
+            ELSE
+            END; (* WITH *)
+        ELSE
+        END; (* IF *)
+    END; (* IF *)
+END FixProcTypes;
+
+
+PROCEDURE (rd: Reader) ParseMethod(rec: MS.RecordType), NEW;
+VAR
+    newM: MS.Method;
+    newF: MS.Method;
+    mAtt: SET;
+    vMod: INTEGER;
+    rFrm: INTEGER;
+    fl: MS.FormalList;
+    rtype: MS.Type;
+    rectyp: MS.Type;
+    mname: CharOpen;
+    ovlname: CharOpen;
+BEGIN
+    NEW(newM);
+    mname := ST.ToChrOpen(rd.sAtt);
+    vMod := rd.iAtt;
+    (* byte1 is the method attributes *)
+    mAtt := BITS(rd.Read());
+    (* byte2 is param form of receiver *)
+    rFrm := rd.Read();
+    (* next 1 or 2 bytes are rcv-type  *)
+    rectyp := rd.TypeOf(rd.ReadOrd());
+    rd.GetSym();
+    ovlname := NIL;
+
+    IF ~MS.WithoutMethodNameMangling() THEN
+        IF rd.sSym = strSy THEN
+            (* optional invoking method name *)
+            ovlname := mname;
+            mname := ST.ToChrOpen(rd.sAtt);
+            rd.GetSym();
+        END; (* IF *)
+    END; (* IF *)
+
+    rtype := NIL;
+    IF rd.sSym = retSy THEN
+        rtype := rd.TypeOf(rd.iAtt);
+        rd.GetSym();
+    END; (* IF *)
+    fl := rd.GetFormalTypes();
+
+    newM := rec.MakeMethod(mname, MS.Mnonstatic, rtype, fl);
+    IF (rectyp # NIL) & (rectyp # rec) THEN newM.SetDeclaringType(rectyp); END;
+
+    IF MS.WithoutMethodNameMangling() THEN
+    ELSE
+        IF ovlname # NIL THEN
+            newM.SetOverload(ovlname);    (* fix the sigcode of newM *)
+        ELSE
+        END;
+    END; (* IF *)
+
+    newM.SetVisibility(vMod);
+    newM.InclAttributes(mAtt);
+    FixProcTypes(rec, newM, fl, rtype);
+END ParseMethod;
+
+
+PROCEDURE (rd: Reader) ParseProcedure(rec: MS.RecordType), NEW;
+VAR
+    newP: MS.Method;
+    newF: MS.Method;
+    vMod: INTEGER;
+    rFrm: INTEGER;
+    fl: MS.FormalList;
+    rtype: MS.Type;
+    rectyp: MS.Type;
+    pname: CharOpen;
+    ivkname: CharOpen;
+    ovlname: CharOpen;
+    isCtor: BOOLEAN;
+    idx: INTEGER;
+BEGIN
+    NEW(newP);
+    pname := ST.ToChrOpen(rd.sAtt);
+    vMod := rd.iAtt;
+
+    rd.ReadPast(namSy);
+    ivkname := NIL; ovlname := NIL; isCtor := FALSE;
+
+    IF rd.sSym = strSy THEN
+        (* optional string of invoke name if overloaded method OR Constructor *)
+        ivkname := ST.ToChrOpen(rd.sAtt);
+        rd.GetSym();
+
+        IF rd.sSym = truSy THEN
+            (* optional truSy shows that procedure is a constructor *)
+            isCtor := TRUE;
+            IF LEN(pname) > LEN(MS.replCtor) THEN
+                (* overload constructor name is in the form of "init_..." *)
+                ovlname := pname;
+                idx := ST.StrChr(ovlname,'_');
+                IF idx # ST.NotExist THEN
+                    pname := ST.SubStr(ovlname, 0, idx-1);
+                ELSE
+                    ASSERT(FALSE);
+                END; (* IF *)
+            ELSE
+                (* constructor is not overloaded *)
+            END; (* IF *)
+            rd.GetSym();
+        ELSE
+            (* not a constructor *)
+            ovlname := pname;
+            pname := ivkname;
+        END; (* IF *)
+    END; (* IF *)
+
+    rtype := NIL;
+    IF rd.sSym = retSy THEN
+        rtype := rd.TypeOf(rd.iAtt);
+        rd.GetSym();
+    END; (* IF *)
+    fl := rd.GetFormalTypes();
+
+    newP := rec.MakeMethod(pname, MS.Mstatic, rtype, fl);
+    IF isCtor THEN
+        newP.SetConstructor();
+        newP.SetInvokeName(ivkname);
+    END; (* IF *)
+
+    IF MS.WithoutMethodNameMangling() THEN
+    ELSE
+        IF ovlname # NIL THEN
+            newP.SetOverload(ovlname);    (* fix the sigcode of newM *)
+        END;
+    END; (* IF *)
+
+    newP.SetVisibility(vMod);
+    FixProcTypes(rec, newP, fl, rtype);
+END ParseProcedure;
+
+
+PROCEDURE (rd: Reader) ParseRecordField(rec: MS.RecordType), NEW;
+VAR
+    fldname: CharOpen;
+    fvmod: INTEGER;
+    ftyp: MS.Type;
+    fld: MS.Field;
+BEGIN
+    fldname := ST.ToChrOpen(rd.sAtt);
+    fvmod := rd.iAtt;
+    ftyp := rd.TypeOf(rd.ReadOrd());
+
+    WITH ftyp: MS.NamedType DO
+        fld := rec(MS.ValueType).MakeField(fldname, ftyp, FALSE);
+    | ftyp: MS.TempType DO
+        fld := rec(MS.ValueType).MakeField(fldname, MS.dmyTyp, FALSE);
+        (* collect reference if TempType/NamedType *)
+        ftyp.AddReferenceField(fld);
+    ELSE
+        fld := rec(MS.ValueType).MakeField(fldname, ftyp, FALSE);
+    END; (* WITH *)
+
+    fld.SetVisibility(fvmod);
+    WITH rec: MS.PrimType DO            (* for IntPtr and UIntPtr, otherwise StrucType *)
+        ASSERT(rec.AddField(fld, FALSE));
+    ELSE  (* IntfcType should not has data member *)
+        ASSERT(FALSE);
+    END; (* WITH *)
+END ParseRecordField;
+
+
+PROCEDURE (rd: Reader) ParseStaticVariable(rec: MS.RecordType), NEW;
+(* Variable   = varSy Name TypeOrd.             *)
+VAR
+    varname: CharOpen;
+    vvmod: INTEGER;
+    vtyp: MS.Type;
+    newV : MS.Field;
+BEGIN
+    varname := ST.ToChrOpen(rd.sAtt);
+    vvmod := rd.iAtt;
+    vtyp := rd.TypeOf(rd.ReadOrd());
+
+    WITH vtyp: MS.NamedType DO
+        newV := rec(MS.ValueType).MakeField(varname, vtyp, FALSE);
+    | vtyp: MS.TempType DO
+        newV := rec(MS.ValueType).MakeField(varname, MS.dmyTyp, FALSE);
+        (* collect reference if TempType/NamedType *)
+        vtyp.AddReferenceField(newV);
+    ELSE
+        newV := rec(MS.ValueType).MakeField(varname, vtyp, FALSE);
+    END; (* WITH *)
+
+    newV.SetVisibility(vvmod);
+    WITH rec: MS.PrimType DO            (* for IntPtr and UIntPtr, otherwise StrucType *)
+        ASSERT(rec.AddField(newV, TRUE));
+    ELSE  (* IntfcType should not has data member *)
+        ASSERT(FALSE);
+    END; (* WITH *)
+    rd.GetSym();
+END ParseStaticVariable;
+
+
+PROCEDURE (rd: Reader) ParseConstant(rec: MS.RecordType), NEW;
+(* Constant   = conSy Name Literal.             *)
+(* Assert: f.sSym = namSy.                      *)
+VAR
+    cname: CharOpen;
+    cvmod: INTEGER;
+    ctyp: MS.Type;
+    cvalue: MS.Literal;
+    newC : MS.Field;
+    tord: INTEGER;
+BEGIN
+    cname := ST.ToChrOpen(rd.sAtt);
+    cvmod := rd.iAtt;
+    rd.ReadPast(namSy);
+    cvalue := rd.GetLiteral();
+
+    IF cvalue IS MS.BoolLiteral THEN
+        tord := MS.boolN;
+    ELSIF cvalue IS MS.LIntLiteral THEN
+        tord := MS.lIntN;
+    ELSIF cvalue IS MS.CharLiteral THEN
+        tord := MS.charN;
+    ELSIF cvalue IS MS.RealLiteral THEN
+        tord := MS.realN;
+    ELSIF cvalue IS MS.SetLiteral THEN
+        tord := MS.setN;
+    ELSIF cvalue IS MS.StrLiteral THEN
+        tord := MS.strN;
+    ELSE
+        tord := MS.unCertain;
+    END; (* IF *)
+    ctyp := MS.baseTypeArray[tord];
+    IF ctyp = NIL THEN
+        ctyp := MS.MakeDummyPrimitive(tord);
+    END; (* IF *)
+    newC := rec(MS.ValueType).MakeConstant(cname, ctyp, cvalue);
+
+    newC.SetVisibility(cvmod);
+    WITH rec: MS.ValueType DO
+        ASSERT(rec.AddField(newC, TRUE));
+    ELSE  (* IntfcType should not has data member *)
+        ASSERT(FALSE);
+    END; (* WITH *)
+
+END ParseConstant;
+
+
+PROCEDURE (rd: Reader) ParsePointerType(old: MS.Type): MS.Type, NEW;
+VAR
+    indx: INTEGER;
+    rslt: MS.PointerType;
+    junk: MS.Type;
+    ns: MS.Namespace;
+    tname: CharOpen;
+    ftname: CharOpen;
+    target: MS.Type;
+BEGIN
+    (* read the target type ordinal *)
+    indx := rd.ReadOrd();
+    WITH old: MS.PointerType DO
+        rslt := old;
+        (*
+         *  Check if there is space in the tArray for this
+         *  element, otherwise expand using typeOf().
+         *)
+        IF indx - tOffset >= rd.tArray.tide THEN
+            junk := rd.TypeOf(indx);
+        END; (* IF *)
+        rd.tArray.a[indx-tOffset] := rslt.GetTarget();
+    | old: MS.TempType DO
+        ns := old.GetNamespace();
+	IF ns = NIL THEN
+	    (* it is an anonymous pointer to array type *)
+            old.SetAnonymous();
+            target := rd.TypeOf(indx);
+            rslt := MS.MakeAnonymousPointerType(target);
+	ELSE
+            tname := old.GetName();
+            ftname := old.GetFullName();
+            target := rd.TypeOf(indx);
+            target.SetNamespace(ns);        (* the the default namespace of the target *)
+            rslt := ns.InsertPointer(tname,ftname,target);
+            rslt.SetVisibility(old.GetVisibility());
+        END; (* IF *)
+
+        (* changed from TempType to PointerType, so fix all references to the type *)
+        MS.FixReferences(old, rslt);
+
+        IF target.GetName() = NIL THEN
+            target.SetAnonymous();
+            target.SetVisibility(MS.Vprivate);
+            (* collect reference if TempType/NamedType *)
+            target(MS.TempType).AddSrcPointerType(rslt);                (* <== should that be for all TempType target?? *)
+        ELSE
+        END; (* IF *)
+    ELSE
+        ASSERT(FALSE); rslt := NIL;
+    END; (* WITH *)
+    rd.GetSym();
+    RETURN rslt;
+END ParsePointerType;
+
+
+PROCEDURE (rd: Reader) ParseArrayType(tpTemp: MS.Type): MS.Type, NEW;
+VAR
+    rslt: MS.Type;
+    ns: MS.Namespace;
+    elemTp: MS.Type;
+    length: INTEGER;
+    tname: CharOpen;
+    ftname: CharOpen;
+    sptr: MS.PointerType;
+    sptrname: CharOpen;
+    typOrd: INTEGER;
+BEGIN
+    typOrd := rd.ReadOrd();
+    elemTp := rd.TypeOf(typOrd);
+    ns := tpTemp.GetNamespace();
+    IF ns = NIL THEN
+        (* its name (currently "DummyType") can only be fixed after its element type is determined *)
+        tpTemp.SetAnonymous();
+        IF typOrd < tOffset THEN
+            (* element type is primitive, and was already create by TypeOf() calling MakeDummyPrimitive() *)
+            tname := elemTp.GetName();
+            tname := ST.StrCat(tname, MS.anonArr);             (* append "_arr" *)
+            ns := elemTp.GetNamespace();                       (* []SYSTEM  - for dummy primitives *)
+            ftname := ST.StrCatChr(ns.GetName(), '.');
+            ftname := ST.StrCat(ftname, tname);
+        ELSE
+            ns := elemTp.GetNamespace();
+            IF ns # NIL THEN
+                (* the anonymous array element is already known *)
+                tname := elemTp.GetName();
+                tname := ST.StrCat(tname, MS.anonArr);             (* append "_arr" *)
+                ftname := ST.StrCatChr(ns.GetName(), '.');
+                ftname := ST.StrCat(ftname, tname);
+            ELSE
+                (* cannot insert this type as its element type is still unknown, and so is its namespace ??? *)
+                tname := ST.NullString;
+                ftname := tname;
+            END; (* IF *)
+        END; (* IF *)
+    ELSE
+        IF ~tpTemp.IsAnonymous() THEN
+            tname := tpTemp.GetName();
+            ftname := tpTemp.GetFullName();
+        ELSE
+            (* if array is anonymous and has namespace, 
+               then either its element type has been parsed (ARRAY OF ParsedElement), 
+                        or it has a src pointer type (Arr1AnonymousArray = POINTER TO ARRAY OF something) *)
+            tname := elemTp.GetName();
+            IF tname # NIL THEN
+                tname := ST.StrCat(tname, MS.anonArr);             (* append "_arr" *)
+            ELSE
+                sptr := tpTemp(MS.TempType).GetNonAnonymousPTCrossRef();
+                sptrname := sptr.GetName();
+                tname := ST.SubStr(sptrname, 4, LEN(sptrname)-1);  (* get rid of "Arr1" *)
+                tname := ST.StrCat(tname, MS.anonArr);             (* append "_arr" *)
+            END; (* IF *)
+            ftname := ST.StrCatChr(ns.GetName(), '.');
+            ftname := ST.StrCat(ftname, tname);
+        END; (* IF *)
+    END; (* IF *)
+    rd.GetSym();
+    IF rd.sSym = bytSy THEN
+        length := rd.iAtt;
+        rd.GetSym();
+    ELSIF rd.sSym = numSy THEN
+        length := SHORT(rd.lAtt);
+        rd.GetSym();
+    ELSE
+        length := 0;
+    END; (* IF *)
+
+    IF ns # NIL THEN
+        rslt := ns.InsertArray(tname, ftname, 1, length, elemTp);
+        rslt.SetVisibility(tpTemp.GetVisibility());
+
+        (* changed from TempType to ArrayType, so fix all references to the type *)
+        MS.FixReferences(tpTemp, rslt);
+
+        IF tpTemp.IsAnonymous() THEN
+            rslt.SetAnonymous();
+        ELSE
+            rslt.NotAnonymous();
+        END; (* IF *)
+    ELSE
+        (* add this to defer anonymous array insertion list*)
+        tpTemp(MS.TempType).SetDimension(1);
+        tpTemp(MS.TempType).SetLength(length);
+        elemTp(MS.TempType).AddAnonymousArrayType(tpTemp(MS.TempType));
+        rslt := tpTemp;
+    END; (* IF *)
+
+    rd.ReadPast(endAr);
+    RETURN rslt;
+END ParseArrayType;
+
+
+PROCEDURE (rd: Reader) ParseRecordType(old: MS.Type; typIdx: INTEGER): MS.RecordType, NEW;
+(* Assert: at entry the current symbol is recSy.                        *)
+(* Record     = TypeHeader recSy recAtt [truSy | falSy | <others>]      *)
+(*      [basSy TypeOrd] [iFcSy {basSy TypeOrd}]                         *)
+(*      {Name TypeOrd} {Method} {Statics} endRc.                        *)
+VAR
+    rslt: MS.RecordType;
+    recAtt: INTEGER;
+    oldS: INTEGER;
+    fldD: MS.Field;
+    mthD: MS.Method;
+    conD: MS.Constant;
+    isValueType: BOOLEAN; (* is ValueType *)
+    hasNarg: BOOLEAN;     (* has noarg constructor ( can use NEW() ) *)
+    ns: MS.Namespace;
+    tname: CharOpen;
+    ftname: CharOpen;
+    attr: MS.Attribute;
+    tt: INTEGER;
+    sptr: MS.PointerType;
+    base: MS.Type;
+    itfc: MS.Type;
+    tord: INTEGER;    (* temporary type storage *)
+    ttyp: MS.Type;    (* temporary type storage *)
+    fldname: CharOpen;
+    fvmod: INTEGER;
+BEGIN
+    WITH old: MS.RecordType DO
+        rslt := old;
+        recAtt := rd.Read();    (* record attribute *)                          (* <==== *)
+        rd.GetSym();            (* falSy *)
+        rd.GetSym();            (* optional basSy *)
+        IF rd.sSym = basSy THEN rd.GetSym() END;
+    | old: MS.TempType DO
+
+        ns := old.GetNamespace();
+        IF ~old.IsAnonymous() THEN
+            tname := old.GetName();
+            ftname := old.GetFullName();
+        ELSE
+            (* if record is anonymous, it has only one src pointer type *)
+            sptr := old(MS.TempType).GetFirstPTCrossRef();
+            tname := ST.StrCat(sptr.GetName(), MS.anonRec);
+            ftname := ST.StrCatChr(ns.GetName(), '.');
+            ftname := ST.StrCat(ftname, tname);
+        END; (* IF *)
+
+        recAtt := rd.Read();                                                    (* <==== *)
+        (* check for ValueType *)
+        IF recAtt >= valTp THEN
+            isValueType := TRUE; recAtt := recAtt MOD valTp;
+        ELSE
+            isValueType := FALSE;
+        END; (* IF *)
+
+        (* check for no NOARG constructor *)
+        IF recAtt >= nnarg THEN
+            hasNarg := FALSE; recAtt := recAtt MOD nnarg;
+        ELSE
+            hasNarg := TRUE;
+        END; (* IF *)
+
+        (* Record default to Struct, change to Class if found to be ClassType later (when it has event?) *)
+        tt := MS.Struct;
+        IF recAtt = iFace THEN tt := MS.Interface; END;
+
+        rd.GetSym();
+        IF rd.sSym = falSy THEN
+        ELSIF rd.sSym = truSy THEN
+        END; (* IF *)
+
+        rslt := ns.InsertRecord(tname, ftname, tt);
+        rslt.SetVisibility(old.GetVisibility());
+
+        IF isValueType THEN rslt.InclAttributes(MS.RvalTp); END;
+        IF hasNarg THEN rslt.SetHasNoArgConstructor(); END;
+
+        CASE recAtt OF
+          abstr : rslt.InclAttributes(MS.Rabstr);
+        | limit : (* foreign has no LIMITED attribute *)
+        | extns : rslt.InclAttributes(MS.Rextns);
+        ELSE
+            (* noAtt *)
+        END; (* CASE *)
+
+        rd.GetSym();
+        IF rd.sSym = basSy THEN
+            base := rd.TypeOf(rd.iAtt);
+            WITH base: MS.NamedType DO
+                rslt.SetBaseType(base);
+            | base: MS.TempType DO
+                (* base is a temp type *)
+                (* collect reference if TempType/NamedType *)
+                base(MS.TempType).AddDeriveRecordType(rslt);
+            ELSE
+                (* base has already been parsed *)
+                rslt.SetBaseType(base);
+            END; (* WITH *)
+            rd.GetSym();
+        END; (* IF *)
+
+        IF rd.sSym = iFcSy THEN
+            rd.GetSym();
+            WHILE rd.sSym = basSy DO
+
+                itfc := rd.TypeOf(rd.iAtt);
+                WITH itfc: MS.NamedType DO
+                    (* add to interface list of rslt *)
+                     rslt.AddInterface(itfc);
+                | itfc: MS.TempType DO
+                    (* itfc is a temp type *)
+                    (* collect reference *)
+                    itfc(MS.TempType).AddImplRecordType(rslt);
+                ELSE
+                    (* itfc has already been parsed *)
+                    (* add to interface list of rslt *)
+                     rslt.AddInterface(itfc);
+                END; (* WITH *)
+                rd.GetSym();
+            END; (* WHILE *)
+        END; (* IF *)
+
+        (* changed from TempType to RecordType, so fix all references to the type *)
+        MS.FixReferences(old, rslt);
+        (* need to be here as its methods, fields, etc. may reference to this new type *)
+        rd.tArray.a[typIdx] := rslt;
+    ELSE
+        ASSERT(FALSE); rslt := NIL;
+    END; (* WITH *)
+
+    WHILE rd.sSym = namSy DO
+        (* check for record fields *)
+        rd.ParseRecordField(rslt);
+        rd.GetSym();
+        (* insert the field to the record's field list *)
+    END; (* WHILE *)
+
+    WHILE (rd.sSym = mthSy) OR (rd.sSym = prcSy) OR
+          (rd.sSym = varSy) OR (rd.sSym = conSy) DO
+        oldS := rd.sSym; rd.GetSym();
+        IF oldS = mthSy THEN
+            rd.ParseMethod(rslt);
+        ELSIF oldS = prcSy THEN
+            rd.ParseProcedure(rslt);
+        ELSIF oldS = varSy THEN
+            rd.ParseStaticVariable(rslt);
+        ELSIF oldS = conSy THEN
+            rd.ParseConstant(rslt);
+        ELSE
+            rd.Abandon();
+        END; (* IF *)
+    END; (* WHILE *)
+    rd.ReadPast(endRc);
+    RETURN rslt;
+END ParseRecordType;
+
+
+PROCEDURE (rd: Reader) ParseEnumType(tpTemp: MS.Type): MS.Type, NEW;
+VAR
+    rslt: MS.EnumType;
+    const: MS.Constant;
+    ns: MS.Namespace;
+    tname: CharOpen;
+    ftname: CharOpen;
+BEGIN
+    rslt := NIL;
+    ns := tpTemp.GetNamespace();
+    tname := tpTemp.GetName();
+    ftname := tpTemp.GetFullName();
+    rslt := ns.InsertRecord(tname, ftname, MS.Enum)(MS.EnumType);
+    rslt.SetVisibility(tpTemp.GetVisibility());
+
+    (* changed from TempType to EnumType, so fix all references to the type *)
+    MS.FixReferences(tpTemp, rslt);
+
+    rd.GetSym();
+    WHILE rd.sSym = conSy DO
+        rd.GetSym();
+        rd.ParseConstant(rslt);
+    END; (* WHILE *)
+    rd.ReadPast(endRc);
+    RETURN rslt;
+END ParseEnumType;
+
+
+PROCEDURE (rd: Reader) ParseDelegType(old: MS.Type; isMul: BOOLEAN): MS.Type, NEW;
+VAR
+    rslt: MS.PointerType;
+    ns: MS.Namespace;
+    tname: CharOpen;
+    ftname: CharOpen;
+    ttname: CharOpen;
+    tftname: CharOpen;
+    target: MS.RecordType;
+    rtype: MS.Type;
+    fl: MS.FormalList;
+    newM: MS.Method;
+    newF: MS.Method;
+BEGIN
+    (* create the pointer *)
+    WITH old: MS.PointerType DO
+        rslt := old;
+    | old: MS.TempType DO
+        ns := old.GetNamespace();
+
+        (* pointer name *)
+        tname := old.GetName();
+        ftname := old.GetFullName();
+
+        (* target name *)
+        ttname := ST.StrCat(tname, MS.anonRec);
+        tftname := ST.StrCatChr(ns.GetName(), '.');
+        tftname := ST.StrCat(tftname, ttname);
+
+        (* create the target record *)
+        target := ns.InsertRecord(ttname, tftname, MS.Delegate);
+        target.SetNamespace(ns);        (* the the default namespace of the target *)
+        target.SetAnonymous();
+        IF isMul THEN target.SetMulticast() END;
+
+        (* target visibility *)
+        target.SetVisibility(MS.Vprivate);
+        (* Delegate is not value type *)
+        (* Delegate has no noarg constructor *)
+        (* Delegate is neither abstract, nor extensible *)
+        (* lost information on base type of Delegate *)
+        (* lost information on interface implemented by Delegate *)
+
+        rslt := ns.InsertPointer(tname,ftname,target);
+        rslt.SetVisibility(old.GetVisibility());
+
+        (* changed from TempType to PointerType, so fix all references to the type *)
+        MS.FixReferences(old, rslt);
+
+        (* the "Invoke" method of delegate *)
+        rd.GetSym();
+
+        rtype := NIL;
+        IF rd.sSym = retSy THEN
+            rtype := rd.TypeOf(rd.iAtt);
+            rd.GetSym();
+        END; (* IF *)
+
+        fl := rd.GetFormalTypes();
+
+        newM := target.MakeMethod(ST.ToChrOpen("Invoke"), MS.Mnonstatic, rtype, fl);
+        newM.SetVisibility(MS.Vpublic);                 (* "Invoke" method has Public visiblilty *)
+
+        (* "Invoke" method has final {} attribute (or should it has NEW attribute) *) 
+        (* newM.InclAttributes(MS.Mnew); *)
+
+        FixProcTypes(target, newM, fl, rtype);
+    ELSE
+        ASSERT(FALSE); rslt := NIL;
+    END; (* WITH *)
+
+    RETURN rslt;
+END ParseDelegType;
+
+
+PROCEDURE (rd: Reader) ParseTypeList*(), NEW;
+(* TypeList   = start { Array | Record | Pointer        *)
+(*                | ProcType } close.                   *)
+(* TypeHeader = tDefS Ord [fromS Ord Name].             *)
+VAR
+    typOrd: INTEGER;
+    typIdx: INTEGER;
+    tpTemp : MS.Type;
+    modOrd : INTEGER;
+    impMod : MS.Namespace;
+    tpDesc : MS.Type;
+BEGIN
+    impMod := NIL;
+    WHILE rd.sSym = tDefS DO
+        (* Do type header *)
+        typOrd := rd.iAtt;
+        typIdx := typOrd - tOffset;
+        tpTemp := rd.tArray.a[typIdx];
+
+        rd.ReadPast(tDefS);
+        (* The fromS symbol appears if the type is imported *)
+        IF rd.sSym = fromS THEN
+            modOrd := rd.iAtt;
+            impMod := rd.sArray.a[modOrd-1];
+            rd.GetSym();
+            (* With the strict ordering of the imports,
+             * it may be unnecessary to create this object
+             * in case the other module has been fully read
+             * already?
+             * It is also possible that the type has 
+             * been imported already, but just as an opaque.
+             *)
+            tpTemp.SetNamespace(impMod);
+            rd.ReadPast(namSy);
+
+
+            IF tpTemp.GetName() = NIL THEN
+                tpTemp.SetName(ST.ToChrOpen(rd.sAtt));
+            ELSE
+            END; (* IF *)
+            tpTemp.SetFullName(ST.StrCat(ST.StrCatChr(impMod.GetName(),'.'), tpTemp.GetName()));
+        END; (* IF *)
+
+        (* GetTypeinfo *)
+        CASE rd.sSym OF 
+        | arrSy :
+                  tpDesc := rd.ParseArrayType(tpTemp);
+                  rd.tArray.a[typIdx] := tpDesc;
+        | recSy :
+                  tpDesc := rd.ParseRecordType(tpTemp, typIdx);
+                  rd.tArray.a[typIdx] := tpDesc;
+        | ptrSy :
+                  tpDesc := rd.ParsePointerType(tpTemp);
+                  rd.tArray.a[typIdx] := tpDesc;
+        | evtSy :
+                  tpDesc := rd.ParseDelegType(tpTemp, TRUE);
+                  rd.tArray.a[typIdx] := tpDesc;
+        | pTpSy :
+                  tpDesc := rd.ParseDelegType(tpTemp, FALSE);
+                  rd.tArray.a[typIdx] := tpDesc;
+        | eTpSy :
+                  tpDesc := rd.ParseEnumType(tpTemp);
+                  rd.tArray.a[typIdx] := tpDesc;
+        ELSE 
+            (* NamedTypes come here *)
+            IF impMod = NIL THEN impMod := rd.fns; END;
+            (* the outcome could be a PointerType, ArrayType or RecordType if it already exist *)
+            tpDesc := impMod.InsertNamedType(tpTemp.GetName(), tpTemp.GetFullName());
+            rd.tArray.a[typIdx] := tpDesc;
+            (* changed from TempType to NamedType, so fix all references to the type *)
+            MS.FixReferences(tpTemp, tpDesc);
+        END; (* CASE *)
+    END; (* WHILE *)
+    rd.ReadPast(close);
+END ParseTypeList;
+
+
+PROCEDURE (rd: Reader) InsertMainClass(): MS.PointerType, NEW;
+VAR
+    tname  : ST.CharOpen;
+    tgtname: ST.CharOpen;
+    target : MS.RecordType;
+    rslt   : MS.PointerType;
+    base   : MS.Type;
+    ns     : MS.Namespace;
+    asb    : MS.Assembly;
+BEGIN
+    ASSERT(ST.StrCmp(rd.fasb.GetName(), rd.fns.GetName()) = ST.Equal);
+    tname := rd.fns.GetName();
+    tgtname := ST.StrCat(tname, MS.anonRec);
+    target := rd.fns.InsertRecord(tgtname, tgtname, MS.Struct);
+    target.SetVisibility(MS.Vpublic);
+    target.SetHasNoArgConstructor();
+    base := MS.GetTypeByName(ST.ToChrOpen("mscorlib"),ST.ToChrOpen("System"),ST.ToChrOpen("Object"));
+    ASSERT(base # NIL);              (* mscorlib_System.Object should always exist *)
+    target.SetBaseType(base);
+    rslt := rd.fns.InsertPointer(tname,tname,target);
+    rslt.SetVisibility(MS.Vpublic);
+    RETURN rslt;
+END InsertMainClass;
+
+
+PROCEDURE ParseSymbolFile*(symfile: GF.FILE; modname: CharOpen);
+VAR
+    rd: Reader;
+    oldS: INTEGER;
+    class: MS.PointerType;
+    rec: MS.Type;
+BEGIN
+    rec := NIL;
+    rd := NewReader(symfile);
+    rd.GetHeader(modname);
+    IF rd.sSym = numSy THEN rd.GetVersionName(); END; (* optional strong name info. *)
+    LOOP
+        oldS := rd.sSym;
+        rd.GetSym();
+        CASE oldS OF
+        | start : EXIT;
+        | impSy : rd.Import();
+        | typSy : rd.ParseType();
+        | conSy : (* a global variable belongs to an GPCP module, e.g. ["[GPFiles]GPFiles"] *)
+                  IF rec = NIL THEN
+                      class := rd.InsertMainClass();
+                      rec := class.GetTarget();
+                  END; (* IF *)
+                  WITH rec: MS.RecordType DO
+                      rd.ParseConstant(rec);
+                  ELSE
+                      ASSERT(FALSE);
+                  END; (* WITH *)
+        | prcSy : (* a global variable belongs to an GPCP module, e.g. ["[GPFiles]GPFiles"] *)
+                  IF rec = NIL THEN
+                      class := rd.InsertMainClass();
+                      rec := class.GetTarget();
+                  END; (* IF *)
+                  WITH rec: MS.RecordType DO
+                      rd.ParseProcedure(rec);
+                  ELSE
+                      ASSERT(FALSE);
+                  END; (* WITH *)
+        | varSy : (* a global variable belongs to an GPCP module, e.g. ["[GPFiles]GPFiles"] *)
+                  IF rec = NIL THEN
+                      class := rd.InsertMainClass();
+                      rec := class.GetTarget();
+                  END; (* IF *)
+                  WITH rec: MS.RecordType DO
+                      rd.ParseStaticVariable(rec);
+                  ELSE
+                      ASSERT(FALSE);
+                  END; (* WITH *)
+        ELSE
+            RTS.Throw("Bad object");
+        END; (* CASE *)
+    END; (* LOOP *)
+    rd.ParseTypeList();
+    IF rd.sSym # keySy THEN RTS.Throw("Missing keySy"); END;
+END ParseSymbolFile;
+
+
+END SymReader.
+

gpcp/SymWriter.cp

@@ -0,0 +1,1452 @@
+MODULE SymWriter;
+(* ========================================================================= *)
+(*                                                                           *)
+(*  Symbol file writing module for the .NET to Gardens Point Component       *)
+(*  Pascal Symbols tool.                                                     *)
+(*      Copyright (c) Siu-Yuen Chan 2001.                                    *)
+(*                                                                           *)
+(*  This module converts all meta information inside METASTORE (defined by   *)
+(*  MetaStore module) into Gardens Point Component Pascal (GPCP) recognized  *)
+(*  symbols, then writes the symbols to files in GPCP symbol file format.    *)
+(* ========================================================================= *)
+
+IMPORT
+    ST := AscString,
+    Error,
+    RTS,
+    MS := MetaStore,
+    GF := GPBinFiles;
+
+CONST
+    SymbolExt* = ".cps";
+
+CONST
+    (* ModulesName Types *)
+    (* assembly name same as namespace name, and contains only one word,
+       e.g. Accessibility.dll has only a namespace named Accessibility,
+            and the module name should be:
+                Accessibility_["[Accessibility]Accessibility"] *)
+    SingleWord = 0;     
+
+    (* assembly name same as namespace name, and contains multiple word,
+       e.g. Microsoft.Win32.InterOp.dll has a namespace named Microsoft.Win32.InterOp,
+            and the module name shoulle be:
+                Microsoft_Win32_InterOp_["[Microsoft.Win32.InterOp]Microsoft.Win32.InterOp"] *)
+    MultipleWord = 1;
+
+    (* assembly name different form namespace name, contains multiple word, and 
+       with namespace name includes the entire assembly name
+       e.g. Microsoft.Win32.InterOp.dll has a namespace named Microsoft.Win32.InterOp.Trident,
+            and the module name shoulle be:
+                Microsoft_Win32_InterOp__Trident["[Microsoft.Win32.InterOp]Microsoft.Win32.InterOp.Trident"] *)
+    IncludeWord = 3;
+
+    (* assembly name different from namespace name, contains multiple word, and
+       with no relationship between assembly name and namespace name
+       e.g. mscorlib.dll has a namespace named System.Reflection,
+            and the module name should be:
+                mscorlib_System_Reflection["[mscorlib]System.Reflection"] *)
+    DifferentWord = 2;
+(* ========================================================================= *
+// Collected syntax ---
+// 
+// SymFile    = Header [String (falSy | truSy | <other attribute>)]
+//              [ VersionName ]
+//              {Import | Constant | Variable | Type | Procedure} 
+//              TypeList Key.
+//      -- optional String is external name.
+//      -- falSy ==> Java class
+//      -- truSy ==> Java interface
+//      -- others ...
+// Header     = magic modSy Name.
+// VersionName= numSy longint numSy longint numSy longint.
+//      --            mj# mn#       bld rv#    8xbyte extract
+// Import     = impSy Name [String] Key.
+//      -- optional string is explicit external name of class
+// Constant   = conSy Name Literal.
+// Variable   = varSy Name TypeOrd.
+// Type       = typSy Name TypeOrd.
+// Procedure  = prcSy Name [String] FormalType.
+//      -- optional string is explicit external name of procedure
+// Method     = mthSy Name byte byte TypeOrd [String] FormalType.
+//      -- optional string is explicit external name of method
+// FormalType = [retSy TypeOrd] frmSy {parSy byte TypeOrd} endFm.
+//      -- optional phrase is return type for proper procedures
+// TypeOrd    = ordinal.
+// TypeHeader = tDefS Ord [fromS Ord Name].
+//      -- optional phrase occurs if:
+//      -- type not from this module, i.e. indirect export
+// TypeList   = start { Array | Record | Pointer | ProcType } close.
+// Array      = TypeHeader arrSy TypeOrd (Byte | Number | <empty>) endAr.
+//      -- nullable phrase is array length for fixed length arrays
+// Pointer    = TypeHeader ptrSy TypeOrd.
+// Event      = TypeHeader evtSy FormalType.
+// ProcType   = TypeHeader pTpSy FormalType.
+// Record     = TypeHeader recSy recAtt [truSy | falSy]
+//              [basSy TypeOrd] [iFcSy {basSy TypeOrd}]
+//              {Name TypeOrd} {Method} endRc.
+//      -- truSy ==> is an extension of external interface
+//      -- falSy ==> is an extension of external class
+//      -- basSy option defines base type, if not ANY / j.l.Object
+// NamedType  = TypeHeader
+// Name       = namSy byte UTFstring.
+// Literal    = Number | String | Set | Char | Real | falSy | truSy.
+// Byte       = bytSy byte.
+// String     = strSy UTFstring.
+// Number     = numSy longint.
+// Real       = fltSy ieee-double.
+// Set        = setSy integer.
+// Key        = keySy integer..
+// Char       = chrSy unicode character.
+//
+// Notes on the syntax:
+// All record types must have a Name field, even though this is often
+// redundant.  The issue is that every record type (including those that
+// are anonymous in CP) corresponds to a IR class, and the definer 
+// and the user of the class _must_ agree on the IR name of the class.
+// The same reasoning applies to procedure types, which must have equal
+// interface names in all modules.
+// ======================================================================== *)
+
+CONST
+    modSy = ORD('H');  namSy = ORD('$');  bytSy = ORD('\');
+    numSy = ORD('#');  chrSy = ORD('c');  strSy = ORD('s');
+    fltSy = ORD('r');  falSy = ORD('0');  truSy = ORD('1');
+    impSy = ORD('I');  setSy = ORD('S');  keySy = ORD('K');
+    conSy = ORD('C');  typSy = ORD('T');  tDefS = ORD('t');
+    prcSy = ORD('P');  retSy = ORD('R');  mthSy = ORD('M');
+    varSy = ORD('V');  parSy = ORD('p');  start = ORD('&');
+    close = ORD('!');  recSy = ORD('{');  endRc = ORD('}');
+    frmSy = ORD('(');  fromS = ORD('@');  endFm = ORD(')');
+    arrSy = ORD('[');  endAr = ORD(']');  pTpSy = ORD('%');
+    ptrSy = ORD('^');  basSy = ORD('+');  eTpSy = ORD('e');
+    iFcSy = ORD('~');  evtSy = ORD('v');
+
+CONST
+    magic   = 0DEADD0D0H;
+    syMag   = 0D0D0DEADH;
+    MAXMODULE = 64;
+    MAXTYPE = 256;
+
+CONST
+    tOffset*  = 16; (* backward compatibility with JavaVersion *)
+
+CONST (* mode-kinds *)(* should follow exactly as defined in Symbol.cp *)
+      (* used in describing Type *)
+    prvMode = MS.Vprivate;
+    pubMode = MS.Vpublic;
+    rdoMode = MS.Vreadonly;
+    protect = MS.Vprotected;
+
+CONST (* base-ordinals *)
+    notBs   = MS.notBs;
+    boolN*  = MS.boolN;      (* BOOLEAN *)
+    sChrN*  = MS.sChrN;      (* SHORTCHAR *)
+    charN*  = MS.charN;      (* CHAR *)
+    uBytN*  = MS.uBytN;      (* UBYTE *)
+    byteN*  = MS.byteN;      (* BYTE *)
+    sIntN*  = MS.sIntN;      (* SHORTINT *)
+    intN*   = MS.intN;       (* INTEGER *)
+    lIntN*  = MS.lIntN;      (* LONGING *)
+    sReaN*  = MS.sReaN;      (* SHORTREAL *)
+    realN*  = MS.realN;      (* REAL *)
+    setN*   = MS.setN;       (* SET *)
+    anyRec* = MS.anyRec;     (* ANYREC *)
+    anyPtr* = MS.anyPtr;     (* ANYPTR *)
+    strN*   = MS.strN;       (* STRING (ARRAY OF CHAR) *)
+    sStrN*  = MS.sStrN;      (* SHORTSTRING (ARRAY OF SHORTCHAR) *)
+    metaN*  = MS.metaN;      (* META *)
+
+CONST (* record attributes *)
+    noAtt* = ORD(MS.noAtt);  (* no attribute *)
+    abstr* = ORD(MS.Rabstr); (* Is ABSTRACT *)
+    limit* = ORD(MS.Rlimit); (* Is LIMIT *)
+    extns* = ORD(MS.Rextns); (* Is EXTENSIBLE *)
+    iFace* = ORD(MS.RiFace); (* Is INTERFACE *)
+    nnarg* = ORD(MS.Rnnarg); (* Has NO NoArg Constructor ( cannot use NEW() ) *)
+    valTp* = ORD(MS.RvalTp); (* ValueType *)
+
+CONST (* method attributes *)
+    newBit* = 0;
+    final*  = MS.Mfinal;
+    isNew*  = MS.Mnew;
+    isAbs*  = MS.Mabstr; 
+    empty*  = MS.Mempty;
+    isExt*  = MS.MisExt;
+    mask*   = MS.Mmask;
+    covar*  = MS.Mcovar;     (* ==> covariant return type *)
+
+CONST (* param-modes *)
+    val*    = MS.IsVal;      (* value parameter *)
+    in*     = MS.IsIn;       (* IN parameter *)
+    out*    = MS.IsOut;      (* OUT parameter *)
+    var*    = MS.IsVar;      (* VAR parameter *)
+    notPar* = MS.NotPar;
+
+TYPE
+(*
+    CharOpen = POINTER TO ARRAY OF CHAR;
+*)
+    CharOpen = ST.CharOpen;
+
+    TypeSeq = POINTER TO
+        RECORD 
+            tide: INTEGER;
+            high: INTEGER;
+            a: POINTER TO ARRAY OF MS.Type;
+        END;
+
+    ModuleSeq = POINTER TO
+        RECORD 
+            tide: INTEGER;
+            high: INTEGER;
+            a: POINTER TO ARRAY OF MS.Namespace;
+        END;
+
+    Emiter = POINTER TO
+        RECORD
+            asbname: CharOpen;
+            asbfile: CharOpen;
+            nsname: CharOpen;
+            modname: CharOpen;
+            version: MS.Version;
+            token: MS.PublicKeyToken;
+            ns: MS.Namespace;
+            mnameKind: INTEGER;
+            maintyp: MS.Type;
+            file: GF.FILE;
+            cSum: INTEGER;
+            iNxt: INTEGER;    (* next IMPORT Ord *)
+            oNxt: INTEGER;    (* next TypeOrd *)
+            work: TypeSeq;
+            impo: ModuleSeq;
+         END;
+
+VAR
+    PreEmit: BOOLEAN;
+
+
+PROCEDURE ^ (et: Emiter) EmitDelegate(t: MS.DelegType), NEW;
+
+
+PROCEDURE MakeTypeName(typ: MS.Type): CharOpen;
+(* for handling the '+' sign inside the Beta2 nested type name *)
+VAR
+    name: CharOpen;
+    idx: INTEGER;
+BEGIN
+    name := typ.GetName();
+    IF typ.IsNested() THEN
+        idx := ST.StrChr(name, '+');
+        IF idx # ST.NotExist THEN
+            name[idx] := '$';
+        END; (* IF *)
+        ASSERT(ST.StrChr(name, '+') = ST.NotExist);
+    ELSE
+    END; (* IF *)
+    RETURN name;
+END MakeTypeName;
+
+
+PROCEDURE (et: Emiter) MakeFullTypeName(typ: MS.Type): CharOpen, NEW;
+VAR
+    tnsname: CharOpen;
+    tasbname: CharOpen;
+    tmodname: CharOpen;
+    tname: CharOpen;
+    dim: INTEGER;
+    elm: MS.Type;
+BEGIN
+    tnsname := typ.GetNamespaceName();
+    tasbname := typ.GetAssemblyName();
+    IF (tnsname^ = et.nsname^) & (tasbname^ = et.asbname^) THEN
+        (* local type *)
+        tname := MakeTypeName(typ);
+    ELSE
+        (* foreign type *)
+        tmodname := MS.MakeModuleName(tasbname, tnsname);
+        tmodname := ST.StrCatChr(tmodname, '.');
+        tname := ST.StrCat(tmodname, MakeTypeName(typ));
+    END; (* IF *)
+    RETURN tname;
+END MakeFullTypeName;
+
+
+PROCEDURE InitTypeSeq(seq: TypeSeq; capacity : INTEGER); 
+BEGIN
+    NEW(seq.a, capacity);
+    seq.high := capacity-1;
+    seq.tide := 0;
+END InitTypeSeq;
+
+
+PROCEDURE InitModuleSeq(seq: ModuleSeq; capacity : INTEGER); 
+BEGIN
+    NEW(seq.a, capacity);
+    seq.high := capacity-1;
+    seq.tide := 0;
+END InitModuleSeq;
+
+
+PROCEDURE ResetTypeSeq(VAR seq : TypeSeq);
+VAR
+    i: INTEGER;
+    type: MS.Type;
+BEGIN
+    IF seq.a = NIL THEN
+        InitTypeSeq(seq, 2);
+    ELSE
+        FOR i := 0 TO seq.tide-1 DO
+            type := seq.a[i]; seq.a[i] := NIL;
+            type.ClearTypeOrd();
+            type.ClearInHierarchy();
+        END; (* FOR *)
+        seq.tide := 0; 
+    END; (* IF *)
+END ResetTypeSeq;
+
+
+PROCEDURE ResetModuleSeq(VAR seq : ModuleSeq);
+VAR
+    i: INTEGER;
+    ns: MS.Namespace;
+BEGIN
+    IF seq.a = NIL THEN
+        InitModuleSeq(seq, 2);
+    ELSE
+        FOR i := 0 TO seq.tide-1 DO
+            ns := seq.a[i]; seq.a[i] := NIL;
+            ns.ClearModuleOrd();
+        END; (* FOR *)
+        seq.tide := 0; 
+    END; (* IF *)
+END ResetModuleSeq;
+
+
+PROCEDURE AppendType(VAR seq : TypeSeq; elem : MS.Type);
+VAR
+    temp : POINTER TO ARRAY OF MS.Type;
+    i    : INTEGER;
+BEGIN
+    IF seq.a = NIL THEN 
+      InitTypeSeq(seq, 2);
+    ELSIF seq.tide > seq.high THEN (* must expand *)
+      temp := seq.a;
+      seq.high := seq.high * 2 + 1;
+      NEW(seq.a, (seq.high+1));
+      FOR i := 0 TO seq.tide-1 DO seq.a[i] := temp[i] END;
+    END;
+    seq.a[seq.tide] := elem; INC(seq.tide); 
+END AppendType;
+
+
+PROCEDURE AppendModule(VAR seq : ModuleSeq; elem : MS.Namespace);
+VAR
+    temp : POINTER TO ARRAY OF MS.Namespace;
+    i    : INTEGER;
+BEGIN
+    IF seq.a = NIL THEN 
+      InitModuleSeq(seq, 2);
+    ELSIF seq.tide > seq.high THEN (* must expand *)
+      temp := seq.a;
+      seq.high := seq.high * 2 + 1;
+      NEW(seq.a, (seq.high+1));
+      FOR i := 0 TO seq.tide-1 DO seq.a[i] := temp[i] END;
+    END;
+    seq.a[seq.tide] := elem; INC(seq.tide); 
+END AppendModule;
+
+
+PROCEDURE (et: Emiter) AddToImpolist(ns: MS.Namespace), NEW;
+BEGIN
+    IF (ns # et.ns) & ~ns.Dumped() THEN
+        ns.SetModuleOrd(et.iNxt); INC(et.iNxt);
+        AppendModule(et.impo, ns);
+    END; (* IF *)
+END AddToImpolist;
+
+
+PROCEDURE NewEmiter(): Emiter;
+VAR
+    et: Emiter;
+BEGIN
+    NEW(et);
+   (*
+    *  Initialization: cSum starts at zero. Since impOrd of
+    *  the module is zero, impOrd of the imports starts at 1.
+    *)
+    et.version := NIL;
+    et.token := NIL;
+    et.cSum := 0;
+    et.iNxt := 1;
+    et.oNxt := tOffset;         (* 1-15 are reserved for base types *)
+    NEW(et.work);
+    InitTypeSeq(et.work, MAXTYPE);
+    NEW(et.impo);
+    InitModuleSeq(et.impo, MAXMODULE);
+    RETURN et;
+END NewEmiter;
+
+
+PROCEDURE (et: Emiter) Reset(), NEW;
+BEGIN
+    et.cSum := 0;
+    et.iNxt := 1;
+    et.oNxt := tOffset;         (* 1-15 are reserved for base types *)
+    ResetTypeSeq(et.work);
+    ResetModuleSeq(et.impo);
+END Reset;
+
+(* ================================================================ *)
+
+PROCEDURE (et: Emiter) Write(chr: INTEGER), NEW;
+VAR
+    tmp: INTEGER;
+BEGIN [UNCHECKED_ARITHMETIC]
+   (* need to turn off overflow checking here *)
+    IF ~PreEmit THEN
+        tmp := et.cSum * 2 + chr;
+        IF et.cSum < 0 THEN INC(tmp) END;
+        et.cSum := tmp;
+        GF.WriteByte(et.file, chr);
+    END; (* IF *)
+END Write;
+
+
+PROCEDURE (et: Emiter) WriteByte(byt: INTEGER), NEW;
+BEGIN
+    IF ~PreEmit THEN
+        ASSERT((byt <= 127) & (byt > 0));
+        et.Write(bytSy);
+        et.Write(byt);
+    END; (* IF *)
+END WriteByte;
+
+
+PROCEDURE (et: Emiter) WriteChar(chr: CHAR), NEW;
+CONST
+    mask = {0 .. 7};
+VAR
+    a, b, int: INTEGER;
+BEGIN
+    IF ~PreEmit THEN
+        et.Write(chrSy);
+        int := ORD(chr);
+        b := ORD(BITS(int) * mask); int := ASH(int, -8);
+        a := ORD(BITS(int) * mask);
+        et.Write(a); et.Write(b);
+    END; (* IF *)
+END WriteChar;
+
+
+PROCEDURE (et: Emiter) Write4B(int: INTEGER), NEW;
+CONST mask = {0 .. 7};
+VAR   a,b,c,d : INTEGER;
+BEGIN
+    IF ~PreEmit THEN
+        d := ORD(BITS(int) * mask); int := ASH(int, -8);
+        c := ORD(BITS(int) * mask); int := ASH(int, -8);
+        b := ORD(BITS(int) * mask); int := ASH(int, -8);
+        a := ORD(BITS(int) * mask); 
+        et.Write(a); 
+        et.Write(b); 
+        et.Write(c); 
+        et.Write(d); 
+    END; (* IF *)
+END Write4B;
+
+
+PROCEDURE (et: Emiter) Write8B(val: LONGINT), NEW;
+BEGIN
+    IF ~PreEmit THEN
+        et.Write4B(RTS.hiInt(val));
+        et.Write4B(RTS.loInt(val));
+    END; (* IF *)
+END Write8B;
+
+
+PROCEDURE (et: Emiter) WriteNum(num: LONGINT), NEW;
+BEGIN
+    IF ~PreEmit THEN
+        et.Write(numSy);
+        et.Write8B(num);
+    END; (* IF *)
+END WriteNum;
+
+
+PROCEDURE (et: Emiter) WriteReal(flt: REAL), NEW;
+VAR
+    rslt: LONGINT;
+BEGIN
+    IF ~PreEmit THEN
+        et.Write(fltSy);
+        rslt := RTS.realToLongBits(flt);
+        et.Write8B(rslt);
+    END; (* IF *)
+END WriteReal;
+
+
+PROCEDURE (et: Emiter) WriteOrd(ord: INTEGER), NEW;
+BEGIN
+    IF ~PreEmit THEN
+        IF ord <= 7FH THEN 
+            et.Write(ord);
+        ELSIF ord <= 7FFFH THEN
+            et.Write(128 + ord MOD 128);        (* LS7-bits first *)
+            et.Write(ord DIV 128);              (* MS8-bits next  *)
+        ELSE
+            ASSERT(FALSE);
+        END; (* IF *)
+    END; (* IF *)
+END WriteOrd;
+
+
+PROCEDURE (et: Emiter) WriteStrUTF(IN nam: ARRAY OF CHAR), NEW;
+VAR
+    buf : ARRAY 256 OF INTEGER;
+    num : INTEGER;
+    idx : INTEGER;
+    chr : INTEGER;
+BEGIN
+    IF ~PreEmit THEN
+        num := 0;
+        idx := 0;
+        chr := ORD(nam[idx]);
+        WHILE chr # 0H DO
+            IF    chr <= 7FH THEN               (* [0xxxxxxx] *)
+                buf[num] := chr; INC(num);
+            ELSIF chr <= 7FFH THEN              (* [110xxxxx,10xxxxxx] *)
+                buf[num+1] := 080H + chr MOD 64; chr := chr DIV 64;
+                buf[num  ] := 0C0H + chr; INC(num, 2);
+            ELSE                                (* [1110xxxx,10xxxxxx,10xxxxxx] *)
+                buf[num+2] := 080H + chr MOD 64; chr := chr DIV 64;
+                buf[num+1] := 080H + chr MOD 64; chr := chr DIV 64;
+                buf[num  ] := 0E0H + chr; INC(num, 3);
+            END; (* IF *)
+            INC(idx); chr := ORD(nam[idx]);
+        END; (* WHILE *)
+        et.Write(num DIV 256);
+        et.Write(num MOD 256);
+        FOR idx := 0 TO num-1 DO et.Write(buf[idx]) END;
+    END; (* IF *)
+END WriteStrUTF;
+
+
+PROCEDURE (et: Emiter) WriteOpenUTF(chOp: CharOpen), NEW;
+VAR
+    buf : ARRAY 256 OF INTEGER;
+    num : INTEGER;
+    idx : INTEGER;
+    chr : INTEGER;
+BEGIN
+    IF ~PreEmit THEN
+        num := 0;
+        idx := 0;
+        chr := ORD(chOp[0]);
+        WHILE chr # 0H DO
+            IF chr <= 7FH THEN                  (* [0xxxxxxx] *)
+                buf[num] := chr; INC(num);
+            ELSIF chr <= 7FFH THEN              (* [110xxxxx,10xxxxxx] *)
+                buf[num+1] := 080H + chr MOD 64; chr := chr DIV 64;
+                buf[num  ] := 0C0H + chr; INC(num, 2);
+            ELSE                                (* [1110xxxx,10xxxxxx,10xxxxxx] *)
+                buf[num+2] := 080H + chr MOD 64; chr := chr DIV 64;
+                buf[num+1] := 080H + chr MOD 64; chr := chr DIV 64;
+                buf[num  ] := 0E0H + chr; INC(num, 3);
+            END; (* IF *)
+            INC(idx);
+            chr := ORD(chOp[idx]);
+        END; (* WHILE *)
+        et.Write(num DIV 256);
+        et.Write(num MOD 256);
+        FOR idx := 0 TO num-1 DO et.Write(buf[idx]) END;
+    END; (* IF *)
+END WriteOpenUTF;
+
+
+PROCEDURE (et: Emiter) WriteString(IN str: ARRAY OF CHAR), NEW;
+BEGIN
+    IF ~PreEmit THEN
+        et.Write(strSy);
+        et.WriteStrUTF(str);
+    END; (* IF *)
+END WriteString;
+
+
+PROCEDURE (et: Emiter) IsTypeForeign(t: MS.Type): BOOLEAN, NEW;
+VAR
+    tnsname: CharOpen;
+    tasbname: CharOpen;
+BEGIN
+    IF t.GetNamespace() # NIL THEN
+        tnsname := t.GetNamespaceName();
+        tasbname := t.GetAssemblyName();
+        IF (tnsname^ = et.nsname^) & (tasbname^ = et.asbname^) THEN
+            (* local type *)
+            RETURN FALSE;
+        ELSE
+            RETURN TRUE;
+        END; (* IF *)
+    ELSE
+        RETURN FALSE;
+    END; (* IF *)
+END IsTypeForeign;
+
+(* ================================================================ *)
+
+PROCEDURE (et: Emiter) EmitKey(key: INTEGER), NEW;
+BEGIN
+    et.Write(keySy);
+    et.Write4B(key);
+END EmitKey;
+
+
+PROCEDURE (et: Emiter) EmitName(name: CharOpen; vMod: INTEGER), NEW;
+BEGIN
+    et.Write(namSy);
+    et.Write(vMod);
+    et.WriteOpenUTF(name);
+END EmitName;
+
+
+PROCEDURE (et: Emiter) EmitString(IN nam: ARRAY OF CHAR), NEW;
+BEGIN
+    et.Write(strSy); 
+    et.WriteStrUTF(nam);
+END EmitString;
+
+
+PROCEDURE (et: Emiter) EmitScopeName(asbname: CharOpen; nsname: CharOpen), NEW;
+VAR
+    scopeNm: CharOpen;
+BEGIN
+    scopeNm := ST.StrCat(ST.ToChrOpen("["),asbname);
+    scopeNm := ST.StrCatChr(scopeNm,"]");
+    IF nsname^ # MS.NULLSPACE THEN
+        scopeNm := ST.StrCat(scopeNm,nsname);
+    END; (* IF *)
+    et.EmitString(scopeNm);
+END EmitScopeName;
+
+
+PROCEDURE (et: Emiter) EmitHeader(), NEW;
+BEGIN
+    et.Write4B(RTS.loInt(magic));
+    et.Write(modSy);
+    et.EmitName(et.modname, prvMode);  (* hardcode to prvMode doesn't matter for Module *)
+    et.EmitScopeName(et.asbfile, et.nsname);        (* <== should be asbfile or asbname? *)
+    et.Write(falSy);
+END EmitHeader;
+
+
+PROCEDURE (et: Emiter) EmitVersion(), NEW;
+VAR
+    i: INTEGER;
+BEGIN
+    IF et.version # NIL THEN
+        (* pack major and minor into a longint *)
+        et.Write(numSy);
+        et.Write4B(et.version[MS.Major]);
+        et.Write4B(et.version[MS.Minor]);
+        (* pack build and revision into a longint *)
+        et.Write(numSy);
+        et.Write4B(et.version[MS.Build]);
+        et.Write4B(et.version[MS.Revis]);
+        (* pack public key token into a longint *)
+        IF et.token # NIL THEN
+            et.Write(numSy);
+            FOR i := 0 TO 7 DO et.Write(et.token[i]); END;
+        ELSE
+            et.WriteNum(0);
+        END; (* IF *)
+    END; (* IF *)
+END EmitVersion;
+
+
+PROCEDURE (et: Emiter) DirectImports(), NEW;
+VAR
+    fns: MS.Namespace;
+    nstv: MS.OTraverser;
+BEGIN
+    IF et.ns.HasForeignSpaces() THEN
+        NEW(nstv);
+        nstv.Initialize(et.ns.GetForeignSpaces());
+        fns := nstv.GetNextNamespace();
+        WHILE fns # NIL DO
+            (* assigns import modules ordinal *)
+            et.AddToImpolist(fns);
+            fns := nstv.GetNextNamespace();
+        END; (* WHILE *)
+    END; (* IF *)
+END DirectImports;
+
+
+PROCEDURE (et: Emiter) EmitImports(), NEW;
+VAR
+    indx: INTEGER;
+    fns: MS.Namespace;
+    fasbname: CharOpen;
+    fasbfile: CharOpen;
+    fnsname: CharOpen;
+    fmodname: CharOpen;
+BEGIN
+    indx := 0;
+    WHILE indx < et.impo.tide DO
+        et.Write(impSy);
+        fns := et.impo.a[indx];
+        fnsname := fns.GetName();
+        fasbfile := fns.GetAssemblyFile();
+        fasbname := fns.GetAssemblyName();
+        fmodname := MS.MakeModuleName(fasbname, fnsname);
+        et.EmitName(fmodname, prvMode); (* hardcode vMode to prvMode
+                                           doesn't matter for Imports *)
+        IF (ST.StrChr(fnsname,'.') # ST.NotExist) OR
+           (fasbname^ # fnsname^) THEN
+            et.EmitScopeName(fasbfile, fnsname);
+        END; (* IF *)
+        et.EmitKey(0);  (* key is zero for foreigns *)
+        INC(indx);
+    END; (* WHILE *)
+END EmitImports;
+
+
+PROCEDURE (et: Emiter) AddToWorklist(typ: MS.Type), NEW;
+BEGIN
+    typ.SetTypeOrd(et.oNxt); INC(et.oNxt);
+    AppendType(et.work, typ);
+END AddToWorklist;
+
+
+PROCEDURE (et: Emiter) EmitTypeOrd(t: MS.Type), NEW;
+BEGIN
+    IF ~t.Dumped() THEN et.AddToWorklist(t); END;
+    et.WriteOrd(t.GetTypeOrd());
+END EmitTypeOrd;
+
+
+PROCEDURE (et: Emiter) EmitLocalTypeName(typ: MS.Type), NEW;
+VAR
+    tname: CharOpen;
+BEGIN
+    typ.SetInHierarchy();
+    tname := et.MakeFullTypeName(typ);
+    et.Write(typSy);
+    et.EmitName(tname, pubMode);
+    et.EmitTypeOrd(typ);
+END EmitLocalTypeName;
+
+
+PROCEDURE (et: Emiter) EmitLocalTypes(), NEW;
+VAR
+    tv: MS.OTraverser;
+    t: MS.Type;
+    tname: CharOpen;
+    tord: INTEGER;
+    ntv: MS.OTraverser;
+    nt: MS.Type;
+BEGIN
+    NEW(tv); tv.Initialize(et.ns.GetTypes());
+    t := tv.GetNextType();
+    WHILE t # NIL DO
+        IF t.IsExported() THEN
+            IF (et.mnameKind = SingleWord) & (t.GetName()^ = et.nsname^) THEN
+                IF t.IsInterface() THEN
+                    (* if 't' is POINTER TO INTERFACE, it cannot be main type *)
+                    et.EmitLocalTypeName(t);
+                ELSE
+                    (* a gpcp module main type, don't emit this type *)
+                    et.maintyp := t;
+                END; (* IF *)
+            ELSE
+                et.EmitLocalTypeName(t);
+            END; (* IF *)
+        END; (* IF *)
+        t := tv.GetNextType();
+    END; (* WHILE *)
+END EmitLocalTypes;
+
+
+PROCEDURE (et: Emiter) EmitTypes(), NEW;
+BEGIN
+    et.EmitLocalTypes();
+END EmitTypes;
+
+
+PROCEDURE (et: Emiter) EmitTypeHeader(t: MS.Type), NEW;
+BEGIN
+    et.Write(tDefS);
+    et.WriteOrd(t.GetTypeOrd());
+    IF et.IsTypeForeign(t) & ~t.IsAnonymous() THEN
+        et.Write(fromS);
+        et.WriteOrd(t.GetNamespace().GetModuleOrd());
+        et.EmitName(MakeTypeName(t), pubMode);
+    END; (* IF *)
+END EmitTypeHeader;
+
+
+PROCEDURE (et: Emiter) EmitNamedType(t: MS.Type), NEW;
+BEGIN
+    et.EmitTypeHeader(t);
+END EmitNamedType;
+
+
+PROCEDURE (et: Emiter) EmitArrayType(t: MS.ArrayType), NEW;
+VAR
+    elm: MS.Type;
+    len: INTEGER;
+BEGIN
+    et.EmitTypeHeader(t);
+    et.Write(arrSy);
+    et.EmitTypeOrd(t.GetElement());
+    len := t.GetLength();
+    IF len > 127 THEN
+        et.WriteNum(len);
+    ELSIF len > 0 THEN
+        et.WriteByte(len);
+    ELSE
+    END; (* IF *)
+    et.Write(endAr);
+END EmitArrayType;
+
+
+PROCEDURE (et: Emiter) EmitPointerType(t: MS.PointerType), NEW;
+VAR
+    tgt: MS.Type;
+BEGIN
+    IF t.IsDelegate() THEN
+        tgt := t.GetTarget();
+        WITH tgt: MS.DelegType DO
+            tgt.SetTypeOrd(t.GetTypeOrd());
+            et.EmitDelegate(tgt);
+            tgt.ClearTypeOrd();
+        ELSE
+            ASSERT(FALSE);
+        END; (* WITH *)
+
+    ELSE
+        et.EmitTypeHeader(t);
+        et.Write(ptrSy);
+        tgt := t.GetTarget();
+        IF t.IsInHierarchy() THEN
+            tgt.SetInHierarchy();
+        ELSE
+        END; (* IF *)
+        et.EmitTypeOrd(tgt);
+    END; (* IF *)
+END EmitPointerType;
+
+
+PROCEDURE (et: Emiter) EmitMethodAttribute(m: MS.Method), NEW;
+VAR
+    mthAtt: SET;
+    dt: MS.Type;
+BEGIN
+    mthAtt := {};
+    IF m.IsNew() THEN
+        mthAtt := isNew;
+    END; (* IF *)
+    dt := m.GetDeclaringType();
+    IF m.IsAbstract() THEN
+        mthAtt := mthAtt + isAbs;
+    ELSIF (dt.IsAbstract() OR dt.IsExtensible()) & m.IsExtensible() THEN
+        mthAtt := mthAtt + isExt;
+    END; (* IF *)
+    et.Write(ORD(mthAtt));
+END EmitMethodAttribute;
+
+
+PROCEDURE (et: Emiter) EmitReceiverInfo (m: MS.Method), NEW;
+VAR
+    rcvr: MS.Type;
+BEGIN
+    rcvr := m.GetDeclaringType();
+    IF rcvr IS MS.ValueType THEN
+        et.Write(in);        (* IN par mode for value type in dll's sym *) 
+    ELSE
+        et.Write(val);       (* value par mode for obj ref type in dll's sym *) 
+    END; (* IF *)
+    et.EmitTypeOrd(rcvr);
+END EmitReceiverInfo;
+
+
+PROCEDURE (et: Emiter)EmitAnonymousArrayPointerType(t: MS.PointerType): MS.PointerType, NEW;
+VAR
+    ptype: MS.PointerType;
+    tgt: MS.Type;
+BEGIN
+    ptype := NIL;
+    tgt := t.GetTarget();
+    WITH tgt: MS.ArrayType DO
+        ptype := tgt.GetAnonymousPointerType();
+        IF ptype = NIL THEN
+            ptype := MS.MakeAnonymousPointerType(tgt);
+        END; (* IF *)
+    ELSE
+        ASSERT(FALSE);
+    END; (* IF *)
+
+    et.EmitTypeOrd(ptype);
+    RETURN ptype;
+END EmitAnonymousArrayPointerType;
+
+
+PROCEDURE (et: Emiter) EmitFormals(m: MS.Method), NEW;
+VAR
+    rtype: MS.Type;
+    tv: MS.FTraverser;
+    formals: MS.FormalList;
+    f: MS.Formal;
+    ftype: MS.Type;
+    dmyPType: MS.PointerType;
+BEGIN
+    WITH m: MS.Function DO 
+        rtype := m.GetReturnType();
+        et.Write(retSy);
+        et.EmitTypeOrd(rtype);
+    ELSE
+    END; (* WITH *)
+    et.Write(frmSy);
+    formals := m.GetFormals();
+    IF formals.Length() # 0 THEN
+        NEW(tv); tv.Initialize(formals);
+        f := tv.GetNextFormal();
+        WHILE f # NIL DO
+            et.Write(parSy);
+            et.Write(f.GetParameterMode());
+            ftype := f.GetType();
+            WITH ftype: MS.PointerType DO
+                IF ftype.IsArrayPointer() THEN
+                    dmyPType := et.EmitAnonymousArrayPointerType(ftype);     (* what if the formal type is array pointer but not anonymous (created by GPCP) *)
+                    f.SetType(dmyPType, FALSE);
+                ELSE
+                    et.EmitTypeOrd(ftype);
+                END; (* IF *)
+            ELSE
+                et.EmitTypeOrd(ftype);
+            END; (* IF *)
+
+            f := tv.GetNextFormal();
+        END; (* WHILE *)
+    END; (* IF *)
+    et.Write(endFm);
+END EmitFormals;
+
+
+PROCEDURE RequireInvokeName(mth: MS.Method): BOOLEAN;
+BEGIN
+    IF mth.IsConstructor() THEN
+        (* constructors always require invoke name *)
+        RETURN TRUE;
+    ELSE
+        IF MS.WithoutMethodNameMangling() THEN
+            RETURN FALSE
+        ELSE
+            RETURN mth.IsOverload();
+        END;
+    END; (* IF *)
+END RequireInvokeName;
+
+
+PROCEDURE (et: Emiter) EmitVirtMethods(t: MS.Type), NEW;
+VAR
+    tv: MS.OTraverser;
+    m : MS.Method;
+    mname: CharOpen;
+    vMod: INTEGER;
+BEGIN
+    NEW(tv); tv.Initialize(t.GetVirtualMethods());
+    m := tv.GetNextMethod();
+    WHILE m # NIL DO
+        IF m.IsExported() THEN
+            mname := m.GetName();
+            et.Write(mthSy);
+            vMod := pubMode;
+            IF m.IsProtected() THEN
+                vMod := protect;
+            END; (* IF *)
+            et.EmitName(mname, vMod);
+            et.EmitMethodAttribute(m);
+            et.EmitReceiverInfo(m);
+            IF RequireInvokeName(m) THEN
+                et.EmitString(m.GetInvokeName());
+            END; (* IF *)
+            et.EmitFormals(m);
+        END; (* IF *)
+        m := tv.GetNextMethod();
+    END; (* WHILE *)
+END EmitVirtMethods;
+
+
+PROCEDURE (et: Emiter) EmitImplInterfaces(t: MS.Type), NEW;
+(*             [iFcSy {basSy TypeOrd}]
+ *)
+VAR
+    tv: MS.OTraverser;
+    it: MS.Type;
+BEGIN
+    et.Write(iFcSy);
+    NEW(tv); tv.Initialize(t.GetInterfaces());
+    it := tv.GetNextType();
+    WHILE it # NIL DO
+        IF it.IsExported() THEN
+            et.Write(basSy);
+            et.EmitTypeOrd(it);
+            IF t.IsInterface() THEN
+                (* interface (t) inherits other interface (it) *)
+                it.SetInHierarchy();    (* to force emiting of parent interface (it) methods *)
+            END; (* IF *)
+        END; (* IF *)
+        it := tv.GetNextType();
+    END; (* WHILE *)
+END EmitImplInterfaces;
+
+
+PROCEDURE (et: Emiter) EmitInterfaceType(t: MS.IntfcType), NEW;
+VAR
+    recAtt: INTEGER;
+    base: MS.Type;
+BEGIN
+    recAtt := iFace;
+    et.EmitTypeHeader(t);
+    et.Write(recSy);
+    et.Write(recAtt);
+    et.Write(truSy);
+    base := t.GetBaseType();
+    IF base # NIL THEN
+        et.Write(basSy);
+        et.EmitTypeOrd(base);
+    END; (* IF *)
+
+    IF t.HasImplInterfaces() THEN
+        et.EmitImplInterfaces(t);
+    END; (* IF *)
+
+    IF t.HasVirtualMethods() THEN
+        et.EmitVirtMethods(t);
+    END; (* IF *)
+    et.Write(endRc);
+END EmitInterfaceType;
+
+
+PROCEDURE (et: Emiter)EmitFields(t: MS.Type), NEW;
+VAR
+    tv: MS.OTraverser;
+    flist: MS.OrderList;
+    f: MS.Field;
+    vMod: INTEGER;
+    ftype: MS.Type;
+    dmyPType: MS.PointerType;
+BEGIN
+    flist := t.GetInstanceFields();
+    IF flist = NIL THEN RETURN END;
+    NEW(tv); tv.Initialize(flist);
+    f := tv.GetNextField();
+    WHILE f # NIL DO
+        IF f.IsExported() THEN
+            vMod := pubMode;
+            IF f.IsProtected() THEN
+                vMod := protect;
+            END; (* IF *)
+            et.EmitName(f.GetName(), vMod);
+            ftype := f.GetType();
+            WITH ftype: MS.PointerType DO
+                IF ftype.IsArrayPointer() THEN
+                    dmyPType := et.EmitAnonymousArrayPointerType(ftype);     (* what if the field type is array pointer but not anonymous (created by GPCP) *)
+                    f.SetType(dmyPType);
+                ELSE
+                    et.EmitTypeOrd(ftype);
+                END; (* IF *)
+            ELSE
+                et.EmitTypeOrd(ftype);
+            END; (* IF *)
+        END; (* IF *)
+        f := tv.GetNextField();
+    END; (* WHILE *)
+END EmitFields;
+
+
+PROCEDURE (et: Emiter) EmitEventFields(t: MS.Type), NEW;
+VAR
+    tv: MS.OTraverser;
+    elist: MS.OrderList;
+    e: MS.Event;
+
+    ename: CharOpen;
+    htype: MS.Type;
+    tname: CharOpen;
+BEGIN
+    NEW(tv); tv.Initialize(t.GetEventList());
+    e := tv.GetNextEvent();
+    WHILE e # NIL DO
+        et.EmitName(e.GetName(), pubMode);        (* event always be exported for an public record *)
+        et.EmitTypeOrd(e.GetHandlerType());       (* we put the handler type(as .NET does) *)
+        e := tv.GetNextEvent();
+    END; (* WHILE *)
+END EmitEventFields;
+
+
+PROCEDURE (et: Emiter) EmitVariables(t: MS.Type), NEW;
+VAR
+    tv: MS.OTraverser;
+    flist: MS.OrderList;
+    f: MS.Field;
+    vMod: INTEGER;
+    ftype: MS.Type;
+    dmyPType: MS.PointerType;
+BEGIN
+    flist := t.GetStaticFields();
+    IF flist = NIL THEN RETURN END;
+    NEW(tv); tv.Initialize(flist);
+    f := tv.GetNextField();
+    WHILE f # NIL DO
+        IF f.IsExported() THEN
+            et.Write(varSy);
+            vMod := pubMode;
+            IF f.IsProtected() THEN
+                vMod := protect;
+            END; (* IF *)
+            et.EmitName(f.GetName(), vMod);
+            ftype := f.GetType();
+            WITH ftype: MS.PointerType DO
+                IF ftype.IsArrayPointer() THEN
+                    dmyPType := et.EmitAnonymousArrayPointerType(ftype);     (* what if the field type is array pointer but not anonymous (created by GPCP) *)
+                    f.SetType(dmyPType);
+                ELSE
+                    et.EmitTypeOrd(ftype);
+                END; (* IF *)
+            ELSE
+                et.EmitTypeOrd(ftype);
+            END; (* IF *)
+        END; (* IF *)
+        f := tv.GetNextField();
+    END; (* WHILE *)
+END EmitVariables;
+
+
+PROCEDURE (et: Emiter) EmitValue(lit: MS.Literal), NEW;
+BEGIN
+    WITH lit: MS.BoolLiteral DO
+              IF lit.GetValue() THEN et.Write(truSy); ELSE et.Write(falSy); END;
+    |    lit: MS.CharLiteral DO
+              et.WriteChar(lit.GetValue());
+    |    lit: MS.StrLiteral DO
+              et.WriteString(lit.GetValue());
+    |    lit: MS.NumLiteral DO
+              et.WriteNum(lit.GetValue());
+    |    lit: MS.FloatLiteral DO
+              et.WriteReal(lit.GetValue());
+    ELSE
+    END; (* WITH *)
+END EmitValue;
+
+
+PROCEDURE (et: Emiter) EmitConstants(t: MS.Type), NEW;
+VAR
+    tv: MS.OTraverser;
+    c: MS.Constant;
+    vMod: INTEGER;
+BEGIN
+    NEW(tv); tv.Initialize(t.GetConstants());
+    c := tv.GetNextConstant();
+    WHILE c # NIL DO
+        IF c.IsExported() THEN
+            et.Write(conSy);
+            vMod := pubMode;
+            IF c.IsProtected() THEN
+                vMod := protect;
+            END; (* IF *)
+            et.EmitName(c.GetName(), vMod);
+            et.EmitValue(c.GetValue());
+        END; (* IF *)
+        c := tv.GetNextConstant();
+    END; (* WHILE *)
+END EmitConstants;
+
+
+PROCEDURE (et: Emiter) EmitStaticMethods(t: MS.Type), NEW;
+VAR
+    tv: MS.OTraverser;
+    m : MS.Method;
+    mname: CharOpen;
+    vMod: INTEGER;
+BEGIN
+    NEW(tv); tv.Initialize(t.GetStaticMethods());
+    m := tv.GetNextMethod();
+    WHILE m # NIL DO
+        IF (m.GetDeclaringType() = et.maintyp) & (m.IsConstructor()) THEN
+            (* don't emit any maintyp's constructor for a GPCP module *)
+        ELSE
+            IF m.IsExported() THEN
+                mname := m.GetName();
+                IF mname^ # "Main" THEN
+                    et.Write(prcSy);
+                    vMod := pubMode;
+                    IF m.IsProtected() THEN vMod := protect; END;
+                    et.EmitName(mname, vMod);
+                    IF RequireInvokeName(m) THEN et.EmitString(m.GetInvokeName()); END;
+                    IF m.IsConstructor() THEN et.Write(truSy); END;
+                    et.EmitFormals(m);
+                END; (* IF *)
+            END; (* IF *)
+        END; (* IF *)
+        m := tv.GetNextMethod();
+    END; (* WHILE *)
+END EmitStaticMethods;
+
+
+PROCEDURE (et: Emiter) EmitStrucType(t: MS.ValueType), NEW;
+(*
+ **  Record = TypeHeader recSy recAtt [truSy | falSy | <others>] 
+ *              [basSy TypeOrd] [iFcSy {basSy TypeOrd}]
+ **             {Name TypeOrd} {Method} {Statics} endRc.
+ *)
+VAR
+    recAtt: INTEGER;
+    base: MS.Type;
+    basevalue: MS.Type;
+BEGIN
+    recAtt := noAtt;
+    IF t.IsAbstract() THEN
+        recAtt := abstr;
+    ELSIF t.IsExtensible() THEN
+        recAtt := extns;
+    END; (* IF *)
+    IF ~t.HasNoArgConstructor() THEN INC(recAtt, nnarg); END;
+    IF t.IsValueType() THEN INC(recAtt, valTp); END;
+    et.EmitTypeHeader(t);
+    et.Write(recSy);
+    et.Write(recAtt);
+    et.Write(falSy);
+    base := t.GetBaseType();
+    IF (base # NIL) & (base # MS.baseTypeArray[anyRec]) THEN   (* <== *)
+        et.Write(basSy);
+        WITH base: MS.PointerType DO
+            basevalue := base.GetTarget();
+            IF t.IsInHierarchy() THEN
+                base.SetInHierarchy();
+                basevalue.SetInHierarchy();
+                IF ~base.Dumped() THEN
+                    et.AddToWorklist(base);
+                ELSE
+                END; (* IF *)
+            ELSE
+            END; (* IF *)
+            (* request by Diane, base type is class, rather than record *)
+            et.EmitTypeOrd(base);
+        ELSE
+            ASSERT(base.GetTypeOrd() = anyRec);
+        END; (* WITH *)
+    ELSE
+        (* no base type declared, so use ANYREC as its base type *)
+        et.Write(basSy);
+        et.Write(anyRec);
+    END; (* IF *)
+
+    IF t.HasImplInterfaces() THEN et.EmitImplInterfaces(t); END;
+    IF t.HasInstanceFields() THEN et.EmitFields(t); END;
+    IF t.HasEvents() THEN et.EmitEventFields(t); END;
+    IF t.HasVirtualMethods() THEN et.EmitVirtMethods(t); END;
+    IF t.HasConstants() THEN et.EmitConstants(t); END;
+    IF t.HasStaticFields() THEN et.EmitVariables(t); END;
+    IF t.HasStaticMethods() THEN et.EmitStaticMethods(t); END;
+
+    et.Write(endRc);
+END EmitStrucType;
+
+
+PROCEDURE (et: Emiter) EmitEnumType(t: MS.EnumType), NEW;
+BEGIN
+    et.EmitTypeHeader(t);
+    et.Write(eTpSy);
+    et.EmitConstants(t);
+    et.Write(endRc);
+END EmitEnumType;
+
+
+PROCEDURE (et: Emiter) EmitDelegate(t: MS.DelegType), NEW;
+VAR
+    imth: MS.Method;
+BEGIN
+    et.EmitTypeHeader(t);
+    IF t.IsMulticast() THEN
+        et.Write(evtSy);
+    ELSE
+        et.Write(pTpSy);
+    END; (* IF *)
+    imth := t.GetInvokeMethod();
+    et.EmitFormals(imth);
+END EmitDelegate;
+
+
+PROCEDURE (et: Emiter) EmitTypeList(), NEW;
+VAR
+    indx: INTEGER;
+    type: MS.Type;
+    ns: MS.Namespace;
+    nt: MS.Type;
+    ntv: MS.OTraverser;
+    tgt: MS.Type;
+BEGIN
+    et.Write(start);
+    indx := 0;
+    WHILE indx < et.work.tide DO
+        type := et.work.a[indx];
+        ns := type.GetNamespace();
+        IF ns # NIL THEN et.AddToImpolist(ns); END; 
+        WITH type: MS.PointerType DO
+            tgt := type.GetTarget();
+            WITH tgt: MS.RecordType DO
+                IF type.IsInHierarchy() THEN
+                    et.EmitPointerType(type);
+                ELSIF ~et.IsTypeForeign(type) THEN
+                    (* a non-Exported type but referenced by other type *)
+                    et.EmitPointerType(type);
+                ELSE
+                    et.EmitNamedType(type);
+                END; (* IF *)
+            | tgt: MS.ArrayType DO
+                et.EmitPointerType(type);
+            ELSE
+            END; (* WITH *)
+        | type: MS.ArrayType DO
+            et.EmitArrayType(type);
+        | type: MS.RecordType DO
+            WITH type: MS.IntfcType DO
+                et.EmitInterfaceType(type);
+            | type: MS.ValueType DO
+                WITH type: MS.EnumType DO
+                    et.EmitEnumType(type);
+                | type: MS.PrimType DO                (* for IntPtr and UIntPtr *)
+                    IF type.IsInHierarchy() THEN
+                        et.EmitStrucType(type);
+                    ELSIF ~et.IsTypeForeign(type) THEN
+                        (* a non-Exported type but referenced by other type *)
+                        et.EmitStrucType(type);
+                    ELSE
+                        et.EmitNamedType(type);
+                    END; (* IF *)
+                ELSE
+                END; (* WITH *)
+            ELSE
+            END; (* WITH *)
+        | type: MS.NamedType DO 
+            et.EmitNamedType(type);
+        ELSE
+        END; (* WITH *)
+        INC(indx);
+    END; (* WHILE *)
+    et.Write(close);
+END EmitTypeList;
+
+
+PROCEDURE (et: Emiter) EmitModule(), NEW;
+(*
+ * SymFile = 
+ *   Header [String (falSy | truSy | <others>)]
+ *   {Import | Constant | Variable | Type | Procedure | Method} TypeList.
+ * Header = magic modSy Name.
+ *)
+BEGIN
+    (* Walk through all types to gather info about import modules *)
+    PreEmit := TRUE;
+    et.DirectImports();
+    et.EmitTypes();
+    IF et.maintyp # NIL THEN
+        IF et.maintyp.HasStaticFields() THEN
+            et.EmitVariables(et.maintyp);
+        END; (* IF *)
+        IF et.maintyp.HasStaticMethods() THEN
+            et.EmitStaticMethods(et.maintyp);
+        END; (* IF *)
+    END; (* IF *)
+    et.EmitTypeList();
+
+
+    (* Now really emit type info *)
+    PreEmit := FALSE;
+    et.EmitHeader();
+    et.EmitVersion();
+    et.EmitImports();
+    et.EmitTypes();
+    IF et.maintyp # NIL THEN
+        IF et.maintyp.HasConstants() THEN
+            et.EmitConstants(et.maintyp);
+        END; (* IF *)
+        IF et.maintyp.HasStaticFields() THEN
+            et.EmitVariables(et.maintyp);
+        END; (* IF *)
+        IF et.maintyp.HasStaticMethods() THEN
+            et.EmitStaticMethods(et.maintyp);
+        END; (* IF *)
+    END; (* IF *)
+    et.EmitTypeList();
+    et.EmitKey(0);
+END EmitModule;
+
+
+PROCEDURE EmitSymbolFiles*(asb: MS.Assembly);
+VAR
+    et: Emiter;
+    filename: CharOpen;
+    tv: MS.OTraverser;
+    onewordname: BOOLEAN;
+    samewordname: BOOLEAN;
+    inclwordname: BOOLEAN;
+BEGIN
+    NEW(tv); tv.Initialize(asb.GetNamespaces());
+    et := NewEmiter();
+    et.asbname := asb.GetName();
+    et.asbfile := asb.GetFileName();
+    et.version := asb.GetVersion();
+    et.token := asb.GetPublicKeyToken();
+    et.ns := tv.GetNextNamespace();
+    IF et.ns # NIL THEN
+        et.nsname := et.ns.GetName();
+        onewordname := MS.IsOneWordName(et.asbname, et.nsname);
+        samewordname := MS.IsSameWordName(et.asbname, et.nsname);
+        IF onewordname & samewordname & (asb.NamespaceCount() = 1) THEN
+            (* It is very likely to be a GPCP compiled DLL or exe *)
+            et.mnameKind := SingleWord;
+            et.modname := MS.MakeModuleName(et.asbname, et.nsname);
+            filename := ST.StrCat(et.modname, ST.ToChrOpen(SymbolExt));
+            et.file := GF.createFile(filename);
+            IF et.file = NIL THEN
+                Error.WriteString("Cannot create file <" + filename^ + ">"); Error.WriteLn;
+                ASSERT(FALSE);
+                RETURN;
+            END; (* IF *)
+            et.EmitModule();
+            GF.CloseFile(et.file);
+            et.Reset();
+        ELSE
+            REPEAT
+                IF ~onewordname & samewordname THEN
+                    (* cannot be null namespace here *)
+                    et.mnameKind := MultipleWord;
+                ELSE
+                    et.mnameKind := DifferentWord;
+                END; (* IF *)
+                et.modname := MS.MakeModuleName(et.asbname, et.nsname);
+                filename := ST.StrCat(et.modname, ST.ToChrOpen(SymbolExt));
+                et.file := GF.createFile(filename);
+                IF et.file = NIL THEN
+                    Error.WriteString("Cannot create file <" + filename^ + ">"); Error.WriteLn;
+                    ASSERT(FALSE);
+                    RETURN;
+                END; (* IF *)
+                et.EmitModule();
+                GF.CloseFile(et.file);
+                et.Reset();
+                et.ns := tv.GetNextNamespace();
+
+                IF et.ns # NIL THEN
+                    et.nsname := et.ns.GetName();
+                    onewordname := (ST.StrChr(et.nsname,'.') = ST.NotExist);
+                    samewordname := (et.asbname^ = ST.StrSubChr(et.nsname,'.','_')^);
+                 END; (* IF *)
+            UNTIL et.ns = NIL;
+         END; (* IF *)
+    END; (* IF *)
+END EmitSymbolFiles;
+
+END SymWriter.

gpcp/SymbolFile.cp

@@ -0,0 +1,478 @@
+(* ==================================================================== *)
+(*                                                                      *)
+(*  SymFileRW:  Symbol-file reading and writing for GPCP.               *)
+(*      Copyright (c) John Gough 1999, 2000.                            *)
+(*                                                                      *)
+(* ==================================================================== *)
+
+MODULE SymbolFile;
+
+  IMPORT 
+        GPCPcopyright,
+        RTS,
+        Error,
+        GPBinFiles,
+        FileNames,
+        CompState,
+        MH := ModuleHandler;
+
+(* ========================================================================= *
+// Collected syntax ---
+// 
+// SymFile    = Header [String (falSy | truSy | <other attribute>)]
+//              [ VersionName ]
+//              {Import | Constant | Variable | Type | Procedure} 
+//              TypeList Key.
+//      -- optional String is external name.
+//      -- falSy ==> Java class
+//      -- truSy ==> Java interface
+//      -- others ...
+// Header     = magic modSy Name.
+// VersionName= numSy longint numSy longint numSy longint.
+//      --            mj# mn#       bld rv#    8xbyte extract
+// Import     = impSy Name [String] Key.
+//      -- optional string is explicit external name of class
+// Constant   = conSy Name Literal.
+// Variable   = varSy Name TypeOrd.
+// Type       = typSy Name TypeOrd.
+// Procedure  = prcSy Name [String] FormalType.
+//      -- optional string is explicit external name of procedure
+// Method     = mthSy Name byte byte TypeOrd [String] FormalType.
+//      -- optional string is explicit external name of method
+// FormalType = [retSy TypeOrd] frmSy {parSy byte TypeOrd} endFm.
+//      -- optional phrase is return type for proper procedures
+// TypeOrd    = ordinal.
+// TypeHeader = tDefS Ord [fromS Ord Name].
+//      -- optional phrase occurs if:
+//      -- type not from this module, i.e. indirect export
+// TypeList   = start { Array | Record | Pointer | ProcType } close.
+// Array      = TypeHeader arrSy TypeOrd (Byte | Number | <empty>) endAr.
+//      -- nullable phrase is array length for fixed length arrays
+// Vector     = TypeHeader vecSy TypeOrd endAr.
+// Pointer    = TypeHeader ptrSy TypeOrd.
+// EventType  = TypeHeader evtSy FormalType.
+// ProcType   = TypeHeader pTpSy FormalType.
+// Record     = TypeHeader recSy recAtt [truSy | falSy] 
+//              [basSy TypeOrd] [ iFcSy {basSy TypeOrd}]
+//              {Name TypeOrd} {OtherStuff} endRc.
+//      -- truSy ==> is an extension of external interface
+//      -- falSy ==> is an extension of external class
+//      -- basSy option defines base type, if not ANY / j.l.Object
+// OtherStuff = Method | Procedure | Variable | Constant.
+// Enum       = TypeHeader eTpSy { Constant } endRc.
+// Name       = namSy byte UTFstring.
+// Literal    = Number | String | Set | Char | Real | falSy | truSy.
+// Byte       = bytSy byte.
+// String     = strSy UTFstring.
+// Number     = numSy longint.
+// Real       = fltSy ieee-double.
+// Set        = setSy integer.
+// Key        = keySy integer..
+// Char       = chrSy unicode character.
+//
+// Notes on the syntax:
+// All record types must have a Name field, even though this is often
+// redundant.  The issue is that every record type (including those that
+// are anonymous in CP) corresponds to a IR class, and the definer 
+// and the user of the class _must_ agree on the IR name of the class.
+// The same reasoning applies to procedure types, which must have equal
+// interface names in all modules.
+// ======================================================================== *)
+
+  CONST
+        modSy = ORD('H'); namSy = ORD('$'); bytSy = ORD('\');
+        numSy = ORD('#'); chrSy = ORD('c'); strSy = ORD('s');
+        fltSy = ORD('r'); falSy = ORD('0'); truSy = ORD('1');
+        impSy = ORD('I'); setSy = ORD('S'); keySy = ORD('K');
+        conSy = ORD('C'); typSy = ORD('T'); tDefS = ORD('t');
+        prcSy = ORD('P'); retSy = ORD('R'); mthSy = ORD('M');
+        varSy = ORD('V'); parSy = ORD('p'); start = ORD('&');
+        close = ORD('!'); recSy = ORD('{'); endRc = ORD('}');
+        frmSy = ORD('('); fromS = ORD('@'); endFm = ORD(')');
+        arrSy = ORD('['); endAr = ORD(']'); pTpSy = ORD('%');
+        ptrSy = ORD('^'); basSy = ORD('+'); eTpSy = ORD('e');
+        iFcSy = ORD('~'); evtSy = ORD('v'); vecSy = ORD('*');
+
+  CONST
+        magic   = 0DEADD0D0H;
+        syMag   = 0D0D0DEADH;
+
+  VAR
+    file* : GPBinFiles.FILE;
+    fileName* : FileNames.NameString;
+    sSym : INTEGER;
+    cAtt : CHAR;
+    iAtt : INTEGER;
+    lAtt : LONGINT;
+    rAtt : REAL;
+    sAtt : FileNames.NameString;
+
+(* ============================================================ *)
+(* ========     Various reading utility procedures      ======= *)
+(* ============================================================ *)
+
+  PROCEDURE read() : INTEGER;
+  BEGIN
+    RETURN GPBinFiles.readByte(file);
+  END read;
+
+(* ======================================= *)
+
+  PROCEDURE ReadUTF(OUT nam : ARRAY OF CHAR);
+    CONST
+        bad = "Bad UTF-8 string";
+    VAR num : INTEGER;
+        bNm : INTEGER;
+        idx : INTEGER;
+        chr : INTEGER;
+  BEGIN
+    num := 0;
+    bNm := read() * 256 + read();
+    FOR idx := 0 TO bNm-1 DO
+      chr := read();
+      IF chr <= 07FH THEN
+        nam[num] := CHR(chr); INC(num);
+      ELSIF chr DIV 32 = 06H THEN
+        bNm := chr MOD 32 * 64;
+        chr := read();
+        IF chr DIV 64 = 02H THEN
+          nam[num] := CHR(bNm + chr MOD 64); INC(num);
+        ELSE
+          RTS.Throw(bad);
+        END;
+      ELSIF chr DIV 16 = 0EH THEN
+        bNm := chr MOD 16 * 64;
+        chr := read();
+        IF chr DIV 64 = 02H THEN
+          bNm := (bNm + chr MOD 64) * 64; 
+          chr := read();
+          IF chr DIV 64 = 02H THEN
+            nam[num] := CHR(bNm + chr MOD 64); INC(num);
+          ELSE 
+            RTS.Throw(bad);
+          END;
+        ELSE
+          RTS.Throw(bad);
+        END;
+      ELSE
+        RTS.Throw(bad);
+      END;
+    END;
+    nam[num] := 0X;
+  END ReadUTF;
+
+(* ======================================= *)
+
+  PROCEDURE readChar() : CHAR;
+  BEGIN
+    RETURN CHR(read() * 256 + read());
+  END readChar;
+
+(* ======================================= *)
+
+  PROCEDURE readInt() : INTEGER;
+  BEGIN [UNCHECKED_ARITHMETIC]
+    (* overflow checking off here *)
+    RETURN ((read() * 256 + read()) * 256 + read()) * 256 + read();
+  END readInt;
+
+(* ======================================= *)
+
+  PROCEDURE readLong() : LONGINT;
+    VAR result : LONGINT;
+        index  : INTEGER;
+  BEGIN [UNCHECKED_ARITHMETIC]
+    (* overflow checking off here *)
+    result := read();
+    FOR index := 1 TO 7 DO
+      result := result * 256 + read();
+    END;
+    RETURN result;
+  END readLong;
+
+(* ======================================= *)
+
+  PROCEDURE readReal() : REAL;
+    VAR result : LONGINT;
+  BEGIN
+    result := readLong();
+    RETURN RTS.longBitsToReal(result);
+  END readReal;
+
+(* ======================================= *)
+
+  PROCEDURE readOrd() : INTEGER;
+    VAR chr : INTEGER;
+  BEGIN
+    chr := read();
+    IF chr <= 07FH THEN RETURN chr;
+    ELSE
+      DEC(chr, 128);
+      RETURN chr + read() * 128;
+    END;
+  END readOrd;
+
+(* ============================================================ *)
+(* ========             Symbol File Reader              ======= *)
+(* ============================================================ *)
+
+  PROCEDURE SymError(IN msg : ARRAY OF CHAR);
+  BEGIN
+    Error.WriteString("Error in <" + fileName + "> : ");
+    Error.WriteString(msg); Error.WriteLn;
+  END SymError;
+
+(* ======================================= *)
+
+  PROCEDURE GetSym();
+  BEGIN
+    sSym := read();
+    CASE sSym OF
+    | namSy : 
+        iAtt := read(); ReadUTF(sAtt);
+    | strSy : 
+        ReadUTF(sAtt);
+    | retSy, fromS, tDefS, basSy :
+        iAtt := readOrd();
+    | bytSy :
+        iAtt := read();
+    | keySy, setSy :
+        iAtt := readInt();
+    | numSy :
+        lAtt := readLong();
+    | fltSy :
+        rAtt := readReal();
+    | chrSy :
+        cAtt := readChar();
+    ELSE (* nothing to do *)
+    END;
+  END GetSym;
+
+(* ======================================= *)
+
+  PROCEDURE Check(sym : INTEGER);
+  BEGIN
+    IF sSym # sym THEN
+      Error.WriteString("Expected " );
+      Error.WriteInt(sym,0);
+      Error.WriteString(" but got " );
+      Error.WriteInt(sSym,0);
+      Error.WriteLn;
+      THROW("Bad symbol file format");
+    END;
+  END Check;
+
+  PROCEDURE CheckAndGet(sym : INTEGER);
+  VAR
+    ok : BOOLEAN;
+  BEGIN
+    IF sSym # sym THEN
+      Error.WriteString("Expected " );
+      Error.WriteInt(sym,0);
+      Error.WriteString(" but got " );
+      Error.WriteInt(sSym,0);
+      Error.WriteLn;
+      THROW("Bad symbol file format");
+    END;
+    GetSym();
+  END CheckAndGet;
+
+(* ======================================= *)
+
+  PROCEDURE OpenSymbolFile*(IN name : ARRAY OF CHAR; onPath : BOOLEAN);
+  BEGIN
+    fileName := name + ".cps";
+    IF onPath THEN
+      file := GPBinFiles.findOnPath(CompState.cpSymX, fileName);
+    ELSE
+      file := GPBinFiles.findLocal(fileName);
+    END;
+  END OpenSymbolFile;
+
+(* ======================================= *)
+
+
+  PROCEDURE SkipFormalType();
+  (*
+  // FormalType = [retSy TypeOrd] frmSy {parSy byte TypeOrd} endFm.
+  //    -- optional phrase is return type for proper procedures
+  *)
+    VAR 
+        byte : INTEGER;
+  BEGIN
+    IF sSym = retSy THEN GetSym(); END;
+    CheckAndGet(frmSy);
+    WHILE sSym = parSy DO
+      byte := read();
+      byte := readOrd();
+      GetSym();
+      IF sSym = strSy THEN GetSym() END;
+    END;
+    CheckAndGet(endFm);
+  END SkipFormalType;
+
+(* ============================================ *)
+
+  PROCEDURE TypeList();
+  (* TypeList   = start { Array | Record | Pointer | ProcType } close. *)
+  (* TypeHeader = tDefS Ord [fromS Ord Name].                          *)
+    VAR 
+      num, oldS : INTEGER;
+      tmp : INTEGER;
+  BEGIN
+    WHILE sSym = tDefS DO
+      GetSym(); 
+      IF sSym = fromS THEN
+        GetSym();  (* fromS *)
+        GetSym();  (* Name *)
+      END;
+     (* Get type info. *)
+      CASE sSym OF
+      | arrSy : num := readOrd();
+                GetSym(); 
+                IF (sSym = bytSy) OR (sSym = numSy) THEN GetSym(); END;
+                CheckAndGet(endAr);
+      | vecSy : num := readOrd();
+                GetSym();
+                CheckAndGet(endAr);
+      | eTpSy : GetSym();
+                WHILE sSym = conSy DO
+                  GetSym();  (* read past conSy *)
+                  CheckAndGet(namSy);
+                  GetSym();  (* read past literal *)
+                END;
+                CheckAndGet(endRc);
+      | recSy : num := read(); 
+                GetSym();
+                IF (sSym = falSy) OR (sSym = truSy) THEN GetSym(); END;
+                IF (sSym = basSy) THEN GetSym(); END;
+                IF sSym = iFcSy THEN
+                  GetSym();
+                  WHILE sSym = basSy DO GetSym() END;
+                END;
+                WHILE sSym = namSy DO num := readOrd(); GetSym(); END;
+                WHILE (sSym = mthSy) OR (sSym = conSy) OR 
+                      (sSym = prcSy) OR (sSym = varSy) DO
+                  oldS := sSym; GetSym();
+                  IF oldS = mthSy THEN 
+                    (* mthSy Name byte byte TypeOrd [String] FormalType. *)
+                     Check(namSy);
+                     num := read();
+                     num := read();
+                     num := readOrd();
+                     GetSym();
+                     IF sSym = strSy THEN GetSym(); END;
+                     IF sSym = namSy THEN GetSym(); END;
+                     SkipFormalType();
+                  ELSIF oldS = conSy THEN (* Name Literal *)
+                     CheckAndGet(namSy);
+                     GetSym();  
+                  ELSIF oldS = prcSy THEN (* Name [String] FormalType. *)
+                     CheckAndGet(namSy);   
+                     IF sSym = strSy THEN GetSym(); END;
+                     IF sSym = truSy THEN GetSym(); END;
+                     SkipFormalType();
+                  ELSE (* Name TypeOrd. *)
+                    Check(namSy);
+                    tmp := readOrd(); 
+                    GetSym(); 
+                  END;
+                END;
+                CheckAndGet(endRc);
+      | ptrSy : num := readOrd(); GetSym(); 
+      | pTpSy, evtSy : GetSym(); SkipFormalType();
+      ELSE (* skip *)
+      END;
+    END;
+    GetSym();
+  END TypeList;
+
+(* ============================================ *)
+
+  PROCEDURE ReadSymbolFile*(mod : MH.ModInfo; addKeys : BOOLEAN);
+  (*
+  // SymFile    = Header [String (falSy | truSy | <others>)]
+  //            {Import | Constant | Variable | Type | Procedure} 
+  //            TypeList Key.
+  // Header     = magic modSy Name.
+  //
+  *)
+  VAR 
+    marker   : INTEGER;
+    oldS,tmp : INTEGER;
+    impMod   : MH.ModInfo;
+  BEGIN
+    impMod := NIL;
+    marker := readInt();
+    IF (marker = RTS.loInt(magic)) OR (marker = RTS.loInt(syMag)) THEN
+      (* normal case, nothing to do *)
+    ELSE
+      SymError("Bad symbol file format."); 
+      RETURN;
+    END;
+    GetSym();
+    CheckAndGet(modSy);
+    Check(namSy);
+    IF mod.name # sAtt THEN 
+      SymError("Wrong name in symbol file. Expected <" + mod.name + 
+                ">, found <" + sAtt + ">"); 
+      RETURN;
+    END;
+    GetSym();
+    IF sSym = strSy THEN (* optional name *)
+      GetSym();
+      IF (sSym = falSy) OR (sSym = truSy) THEN 
+        GetSym();
+      ELSE 
+        SymError("Bad explicit name in symbol file.");
+        RETURN;
+      END; 
+    END; 
+
+    IF sSym = numSy THEN   (* optional strong name info.    *)
+      (* ignore major, minor and get next symbol *)
+      GetSym();
+      (* ignore build, revision and get next symbol *)
+      GetSym();
+      (* ignore assembly publickeytoken and get next symbol *)
+      GetSym();
+    END;
+
+    LOOP
+      oldS := sSym;
+      GetSym();
+      CASE oldS OF
+      | start : EXIT;
+      | typSy, varSy : tmp := readOrd(); GetSym(); (* Name typeOrd *)
+      | impSy : IF addKeys THEN impMod := MH.GetModule(sAtt); END;
+                GetSym();
+                IF sSym = strSy THEN GetSym(); END;
+                Check(keySy);
+                IF addKeys THEN MH.AddKey(mod,impMod,iAtt); END;
+                GetSym();
+      | conSy : GetSym(); GetSym();  (* Name Literal *)
+      | prcSy : (* Name [String] FormalType *);
+                GetSym(); 
+                IF sSym = strSy THEN GetSym(); END;
+                SkipFormalType();
+      ELSE SymError("Bad symbol file format."); EXIT;
+      END;
+    END;
+    TypeList();
+    IF sSym = keySy THEN
+      mod.key := iAtt;
+    ELSE 
+      SymError("Missing keySy");
+    END; 
+    GPBinFiles.CloseFile(file);
+  END ReadSymbolFile;
+
+  PROCEDURE CloseSymFile*();
+  BEGIN
+    IF file # NIL THEN GPBinFiles.CloseFile(file) END;
+  END CloseSymFile;
+
+(* ============================================================ *)
+BEGIN
+END SymbolFile.
+(* ============================================================ *)

gpcp/Symbols.cp

@@ -0,0 +1,1520 @@
+(* ==================================================================== *)
+(*                                                                      *)
+(*  Symbol Module for the Gardens Point Component Pascal Compiler.      *)
+(*  Implements the abstract base classes for all descriptor types.      *)
+(*  Copyright (c) John Gough 1999, 2000.                                *)
+(*                                                                      *)
+(* ==================================================================== *)
+
+MODULE Symbols;
+
+  IMPORT
+        GPCPcopyright,
+        GPText,
+        Console,
+        FileNames,
+        NameHash,
+        L := LitValue,
+        V := VarSets,
+        S := CPascalS,
+        H := DiagHelper;
+
+(* ============================================================ *)
+
+  CONST (* mode-kinds *)
+    prvMode* = 0; pubMode* = 1; rdoMode* = 2; protect* = 3;
+
+  CONST (* param-modes *)
+    val* = 0; in* = 1; out* = 2; var* = 3; notPar* = 4;
+
+  CONST (* force-kinds *)
+    noEmit* = 0; partEmit* = 1; forced* = 2;
+
+  CONST
+    standard* = 0;
+
+  CONST
+    tOffset*  = 16; (* backward compatibility with JavaVersion *)
+
+(* ============================================================ *)
+(*    Foreign attributes for modules, procedures and classes  *)
+(* ============================================================ *)
+
+  CONST (* module and type attributes for xAttr *)
+    mMsk*  = { 0 ..  7};  main*   =  0; weak*  =  1; need*  =  2;
+                          fixd*   =  3; rtsMd* =  4; anon*  =  5;
+                          clsTp*  =  6; frnMd* =  7;
+    rMsk*  = { 8 .. 15};  noNew*  =  8; asgnd* =  9; noCpy* = 10;
+                          spshl*  = 11; xCtor* = 12;
+    fMsk*  = {16 .. 23};  isFn*   = 16; extFn* = 17; fnInf* = 18;
+    dMsk*  = {24 .. 31};  cMain*  = 24; wMain* = 25;
+
+(* ============================================================ *)
+
+  TYPE NameStr* = ARRAY 64 OF CHAR;
+
+(* ============================================================ *)
+
+  TYPE
+    Idnt*   = POINTER TO ABSTRACT RECORD
+                kind-  : INTEGER;   (* tag for unions *)
+                token* : S.Token;   (* scanner token  *)
+                type*  : Type;      (* typ-desc | NIL *)
+                hash*  : INTEGER;   (* hash bucket no *)
+                vMod-  : INTEGER;   (* visibility tag *)
+                dfScp* : Scope;     (* defining scope *)
+                tgXtn* : ANYPTR;    (* target stuff   *)
+              END;   (* For fields: record-decl scope *)
+
+    IdSeq*  = RECORD
+                tide-, high : INTEGER;
+                a- : POINTER TO ARRAY OF Idnt;
+              END;
+
+    Scope*  = POINTER TO ABSTRACT RECORD (Idnt)
+                symTb*   : SymbolTable; (* symbol scope   *)
+                endDecl* : BOOLEAN;
+                ovfChk*  : BOOLEAN;
+                locals*  : IdSeq;
+                scopeNm* : L.CharOpen   (* external name  *)
+              END;
+
+    ScpSeq*  = RECORD
+                tide-, high : INTEGER;
+                a- : POINTER TO ARRAY OF Scope;
+              END;
+
+(* ============================================================ *)
+
+  TYPE
+    Type*   = POINTER TO ABSTRACT RECORD
+                idnt*   : Idnt;         (* Id of typename *)
+                kind-   : INTEGER;      (* tag for unions *)
+                serial- : INTEGER;      (* type serial-nm *)
+                force*  : INTEGER;      (* force sym-emit *)
+                xName*  : L.CharOpen;   (* full ext name  *)
+                dump*,depth* : INTEGER; (* scratch loc'ns *)
+                tgXtn*  : ANYPTR;       (* target stuff   *)
+              END;
+
+    TypeSeq*  = RECORD
+                  tide-, high : INTEGER;
+                  a- : POINTER TO ARRAY OF Type;
+                END;
+
+(* ============================================================ *)
+
+  TYPE
+    Stmt*   = POINTER TO ABSTRACT RECORD
+                kind-  : INTEGER; (* tag for unions *)
+                token* : S.Token; (* stmt first tok *)
+              END;
+
+    StmtSeq*  = RECORD
+                  tide-, high : INTEGER;
+                  a- : POINTER TO ARRAY OF Stmt;
+                END;
+
+(* ============================================================ *)
+
+  TYPE
+    Expr*   = POINTER TO ABSTRACT RECORD
+                kind-  : INTEGER; (* tag for unions *)
+                token* : S.Token; (* exp marker tok *)
+                tSpan* : S.Span;  (* start expr tok *)
+                type*  : Type;
+              END;
+
+    ExprSeq*  = RECORD
+                  tide-, high : INTEGER;
+                  a- : POINTER TO ARRAY OF Expr;
+                END;
+
+(* ============================================================ *)
+
+  TYPE  (* Symbol tables are implemented by a binary tree *)
+    SymInfo = POINTER TO RECORD         (* private stuff  *)
+                key : INTEGER;          (* hash key value *)
+                val : Idnt;             (* id-desc. value *)
+                lOp : SymInfo;          (* left child     *)
+                rOp : SymInfo;          (* right child    *)
+              END;
+
+    SymbolTable* = RECORD
+                     root : SymInfo;
+                   END;
+
+(* ============================================================ *)
+(*  SymForAll is the base type of a visitor type.               *)
+(*  Instances of extensions of SymForAll type are passed to     *)
+(*  SymbolTables using                                          *)
+(*    symTab.Apply(sfa : SymForAll);                            *)
+(*  This recurses over the table, applying sfa.Op(id) to each   *)
+(*  Idnt descriptor in the scope.                               *)
+(* ============================================================ *)
+
+  TYPE
+    SymForAll*  = POINTER TO ABSTRACT RECORD END;
+
+    SymTabDump* = POINTER TO RECORD (SymForAll)
+                    indent : INTEGER;
+                  END;
+
+    NameDump*   = POINTER TO RECORD (SymForAll)
+                    tide, high : INTEGER;
+                    a : L.CharOpen;
+                  END;
+
+(* ============================================================ *)
+
+  TYPE
+    SccTable*  = POINTER TO RECORD
+                   symTab*  : SymbolTable;
+                   target*  : Type;
+                   reached* : BOOLEAN;
+                 END;
+
+(* ============================================================ *)
+
+  TYPE
+    NameFetch* = POINTER TO RECORD END;
+    (** This type exports two methods only:       *)
+    (*  (g : NameFetch)Of*(i : Idnt; OUT s : ARRAY OF CHAR);    *)
+    (*  (g : NameFetch)ChPtr*(id : Idnt) : L.CharOpen;   *)
+
+(* ============================================================ *)
+
+  VAR modStr-  : ARRAY 4 OF ARRAY 5 OF CHAR;
+      modMrk-  : ARRAY 5 OF CHAR;
+      anonMrk- : ARRAY 3 OF CHAR;
+      trgtNET- : BOOLEAN;
+      getName* : NameFetch;
+      next     : INTEGER; (* private: next serial number. *)
+
+(* ============================================================ *)
+
+  PROCEDURE SetTargetIsNET*(p : BOOLEAN);
+  BEGIN
+    trgtNET := p;
+    IF p THEN anonMrk := "@T" ELSE anonMrk := "$T" END;
+  END SetTargetIsNET;
+
+(* ============================================================ *)
+(*             Abstract attribution methods                     *)
+(* ============================================================ *)
+
+  PROCEDURE (i : Expr)exprAttr*() : Expr,NEW,ABSTRACT;
+  PROCEDURE (s : Stmt)StmtAttr*(t : Scope),NEW,ABSTRACT;
+  PROCEDURE (s : Stmt)flowAttr*(t : Scope; i : V.VarSet):V.VarSet,NEW,ABSTRACT;
+
+(* ============================================================ *)
+(*             Abstract type erase methods                      *)
+(* ============================================================ *)
+
+  PROCEDURE (s : Stmt)TypeErase*(t : Scope), NEW, ABSTRACT;
+  PROCEDURE (s : Expr)TypeErase*() : Expr, NEW, ABSTRACT;
+  PROCEDURE (i : Type)TypeErase*() : Type, NEW, ABSTRACT;
+
+(* ============================================================ *)
+(*             Abstract diagnostic methods                      *)
+(* ============================================================ *)
+
+  PROCEDURE (t : Idnt)Diagnose*(i : INTEGER),NEW,ABSTRACT;
+  PROCEDURE (t : Type)Diagnose*(i : INTEGER),NEW,ABSTRACT;
+  PROCEDURE (t : Expr)Diagnose*(i : INTEGER),NEW,ABSTRACT;
+  PROCEDURE (t : Stmt)Diagnose*(i : INTEGER),NEW,ABSTRACT;
+  PROCEDURE (t : Type)name*() : L.CharOpen,NEW,ABSTRACT;
+  
+(* ============================================================ *)
+(*             Base Class text-span method                      *)
+(* ============================================================ *)
+
+  PROCEDURE (s : Stmt)Span*() : S.Span,NEW,EXTENSIBLE;
+  BEGIN
+    RETURN S.mkSpanT(s.token);
+  END Span;
+
+(* ============================================================ *)
+(*    Base predicates on Idnt extensions                        *)
+(* If the predicate needs a different implementation for each   *)
+(* of the direct subclasses, then it is ABSTRACT, otherwise it  *)
+(* should be implemented here with a default return value.      *)
+(* ============================================================ *)
+
+  PROCEDURE (s : Idnt)isImport*() : BOOLEAN,NEW,EXTENSIBLE;
+  BEGIN RETURN FALSE END isImport;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE (s : Idnt)isImported*() : BOOLEAN,NEW,EXTENSIBLE;
+  BEGIN
+    RETURN (s.dfScp # NIL) & s.dfScp.isImport();
+  END isImported;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE (s : Type)isImportedType*() : BOOLEAN,NEW,EXTENSIBLE;
+  BEGIN
+    RETURN (s.idnt # NIL) &
+     (s.idnt.dfScp # NIL) &
+      s.idnt.dfScp.isImport();
+  END isImportedType;
+
+(* -------------------------------------------- *)
+  PROCEDURE^ (xp : Expr)ExprError*(n : INTEGER),NEW;
+
+  PROCEDURE (s : Idnt)mutable*() : BOOLEAN,NEW,EXTENSIBLE;
+  BEGIN RETURN FALSE END mutable;
+
+  PROCEDURE (s : Idnt)CheckMutable*(x : Expr),NEW,EXTENSIBLE;
+  BEGIN x.ExprError(181) END CheckMutable;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE (s : Idnt)isStatic*() : BOOLEAN,NEW,EXTENSIBLE;
+  BEGIN RETURN FALSE END isStatic;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE (s : Idnt)isLocalVar*() : BOOLEAN,NEW,EXTENSIBLE;
+  BEGIN RETURN FALSE END isLocalVar;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE (s : Idnt)isWeak*() : BOOLEAN,NEW,EXTENSIBLE;
+  BEGIN RETURN FALSE END isWeak;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE (s : Idnt)isDynamic*() : BOOLEAN,NEW,EXTENSIBLE;
+  BEGIN RETURN FALSE END isDynamic;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE (s : Idnt)isAbstract*() : BOOLEAN,NEW,EXTENSIBLE;
+  BEGIN RETURN FALSE END isAbstract;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE (s : Idnt)isEmpty*() : BOOLEAN,NEW,EXTENSIBLE;
+  BEGIN RETURN FALSE END isEmpty;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE (i : Idnt)parMode*() : INTEGER,NEW,EXTENSIBLE;
+  BEGIN RETURN notPar END parMode;
+
+(* -------------------------------------------- *)
+(* ????
+  PROCEDURE (s : Idnt)isRcv*() : BOOLEAN,NEW,EXTENSIBLE;
+  BEGIN RETURN FALSE END isRcv;
+ *)
+(* -------------------------------------------- *)
+(* ????
+  PROCEDURE (s : Idnt)isAssignProc*() : BOOLEAN,NEW,EXTENSIBLE;
+  BEGIN RETURN FALSE END isAssignProc;
+ *)
+(* ============================================================ *)
+(*    Base predicates on Type extensions                        *)
+(* ============================================================ *)
+
+  PROCEDURE (l : Type)equalOpenOrVector*(r : Type) : BOOLEAN,NEW,EXTENSIBLE;
+  BEGIN RETURN FALSE END equalOpenOrVector;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE (l : Type)procMatch*(r : Type) : BOOLEAN,NEW,EXTENSIBLE;
+  BEGIN RETURN FALSE END procMatch;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE (l : Type)namesMatch*(r : Type) : BOOLEAN,NEW,EXTENSIBLE;
+  BEGIN RETURN FALSE END namesMatch;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE (l : Type)sigsMatch*(r : Type) : BOOLEAN,NEW,EXTENSIBLE;
+  BEGIN RETURN FALSE END sigsMatch;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE (l : Type)equalPointers*(r : Type) : BOOLEAN,NEW,EXTENSIBLE;
+  BEGIN RETURN FALSE END equalPointers;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE (i : Type)isAnonType*() : BOOLEAN,NEW;
+  BEGIN RETURN (i.idnt = NIL) OR (i.idnt.dfScp = NIL) END isAnonType;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE (i : Type)isBaseType*() : BOOLEAN,NEW,EXTENSIBLE;
+  BEGIN RETURN FALSE END isBaseType;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE (i : Type)isIntType*() : BOOLEAN,NEW,EXTENSIBLE;
+  BEGIN RETURN FALSE END isIntType;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE (s : Idnt)isIn*(set : V.VarSet) : BOOLEAN,NEW,EXTENSIBLE;
+  BEGIN RETURN TRUE END isIn;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE (i : Type)isNumType*() : BOOLEAN,NEW,EXTENSIBLE;
+  BEGIN RETURN FALSE END isNumType;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE (i : Type)isScalarType*() : BOOLEAN,NEW,EXTENSIBLE;
+  BEGIN RETURN TRUE END isScalarType; (* all except arrays, records *)
+
+(* -------------------------------------------- *)
+
+  PROCEDURE (i : Type)isSetType*() : BOOLEAN,NEW,EXTENSIBLE;
+  BEGIN RETURN FALSE END isSetType;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE (i : Type)isRealType*() : BOOLEAN,NEW,EXTENSIBLE;
+  BEGIN RETURN FALSE END isRealType;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE (i : Type)isCharType*() : BOOLEAN,NEW,EXTENSIBLE;
+  BEGIN RETURN FALSE END isCharType;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE (i : Type)isBooleanType*() : BOOLEAN,NEW,EXTENSIBLE;
+  BEGIN RETURN FALSE END isBooleanType;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE (i : Type)isStringType*() : BOOLEAN,NEW,EXTENSIBLE;
+  BEGIN RETURN FALSE END isStringType;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE (i : Type)nativeCompat*() : BOOLEAN,NEW,EXTENSIBLE;
+  BEGIN RETURN FALSE END nativeCompat;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE (i : Type)isCharArrayType*() : BOOLEAN,NEW,EXTENSIBLE;
+  BEGIN RETURN FALSE END isCharArrayType;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE (s : Type)isRefSurrogate*() : BOOLEAN,NEW,EXTENSIBLE;
+  BEGIN RETURN FALSE END isRefSurrogate;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE (i : Type)isPointerType*() : BOOLEAN,NEW,EXTENSIBLE;
+  BEGIN RETURN FALSE END isPointerType;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE (i : Type)isRecordType*() : BOOLEAN,NEW,EXTENSIBLE;
+  BEGIN RETURN FALSE END isRecordType;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE (i : Type)isProcType*() : BOOLEAN,NEW,EXTENSIBLE;
+  BEGIN RETURN FALSE END isProcType;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE (i : Type)isProperProcType*() : BOOLEAN,NEW,EXTENSIBLE;
+  BEGIN RETURN FALSE END isProperProcType;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE (i : Type)isDynamicType*() : BOOLEAN,NEW,EXTENSIBLE;
+  BEGIN RETURN FALSE END isDynamicType;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE (i : Type)isAbsRecType*() : BOOLEAN,NEW,EXTENSIBLE;
+  BEGIN RETURN FALSE END isAbsRecType;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE (i : Type)isLimRecType*() : BOOLEAN,NEW,EXTENSIBLE;
+  BEGIN RETURN FALSE END isLimRecType;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE (i : Type)isExtnRecType*() : BOOLEAN,NEW,EXTENSIBLE;
+  BEGIN RETURN FALSE END isExtnRecType;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE (i : Type)isOpenArrType*() : BOOLEAN,NEW,EXTENSIBLE;
+  BEGIN RETURN FALSE END isOpenArrType;
+
+  PROCEDURE (i : Type)isVectorType*() : BOOLEAN,NEW,EXTENSIBLE;
+  BEGIN RETURN FALSE END isVectorType;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE (i : Type)needsInit*() : BOOLEAN,NEW,EXTENSIBLE;
+  BEGIN RETURN TRUE END needsInit;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE (i : Type)isForeign*() : BOOLEAN,NEW,EXTENSIBLE;
+  BEGIN RETURN FALSE END isForeign;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE (i : Type)valCopyOK*() : BOOLEAN,NEW,EXTENSIBLE;
+  BEGIN RETURN TRUE END valCopyOK;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE (i : Type)isInterfaceType*() : BOOLEAN,NEW,EXTENSIBLE;
+  BEGIN RETURN FALSE END isInterfaceType;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE (i : Type)isEventType*() : BOOLEAN,NEW,EXTENSIBLE;
+  BEGIN RETURN FALSE END isEventType;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE (i : Type)isCompoundType*() : BOOLEAN,NEW,EXTENSIBLE;
+  (* Returns TRUE if the type is a compound type *)
+  BEGIN RETURN FALSE END isCompoundType;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE (i : Type)ImplementationType*() : Type,NEW,EXTENSIBLE;
+  (* Returns the type that this type will be implemented
+   * as. Usually this is just an identity function, but
+   * for types that can be erased, it may be a different
+   * type. *)
+  BEGIN RETURN i END ImplementationType;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE (i : Type)implements*(x : Type) : BOOLEAN,NEW,EXTENSIBLE;
+  BEGIN RETURN FALSE END implements;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE (i : Type)implementsAll*(x : Type) : BOOLEAN,NEW,EXTENSIBLE;
+  (* Returns true iff i is a type that implements all of the
+   * interfaces of x. x and i must be types that are capable of
+   * implementing interfaces (a record or pointer) *)
+  BEGIN RETURN FALSE END implementsAll;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE (b : Type)isBaseOf*(x : Type) : BOOLEAN,NEW,EXTENSIBLE;
+  BEGIN RETURN FALSE END isBaseOf;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE (i : Type)isLongType*() : BOOLEAN,NEW,EXTENSIBLE;
+  BEGIN RETURN FALSE END isLongType;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE (i : Type)isNativeObj*() : BOOLEAN,NEW,EXTENSIBLE;
+  BEGIN RETURN FALSE END isNativeObj;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE (i : Type)isNativeStr*() : BOOLEAN,NEW,EXTENSIBLE;
+  BEGIN RETURN FALSE END isNativeStr;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE (i : Type)isNativeExc*() : BOOLEAN,NEW,EXTENSIBLE;
+  BEGIN RETURN FALSE END isNativeExc;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE (b : Type)includes*(x : Type) : BOOLEAN,NEW,EXTENSIBLE;
+  BEGIN RETURN FALSE END includes;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE (i : Type)boundRecTp*() : Type,NEW,EXTENSIBLE;
+  BEGIN RETURN NIL END boundRecTp;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE (i : Type)superType*() : Type,NEW,EXTENSIBLE;
+  BEGIN RETURN NIL END superType;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE (i : Type)elaboration*() : Type,NEW,EXTENSIBLE;
+  BEGIN RETURN i END elaboration;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE (i : Type)inheritedFeature*(m : Idnt) : Idnt,NEW,EXTENSIBLE;
+  BEGIN
+    RETURN NIL;
+  END inheritedFeature;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE (i : Type)returnType*() : Type,NEW,EXTENSIBLE;
+  BEGIN RETURN NIL END returnType;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE (recT : Type)AppendCtor*(prcI : Idnt),NEW,EMPTY;
+  PROCEDURE (oldT : Type)CheckCovariance*(newI : Idnt),NEW,EMPTY;
+  PROCEDURE (mthT : Type)CheckEmptyOK*(),NEW,EMPTY;
+  PROCEDURE (theT : Type)ConditionalMark*(),NEW,ABSTRACT;
+  PROCEDURE (theT : Type)UnconditionalMark*(),NEW,ABSTRACT;
+  PROCEDURE (prcT : Type)OutCheck*(s : V.VarSet),NEW,EMPTY;
+  PROCEDURE (s : Scope)LiveInitialize*(i : V.VarSet),NEW,EMPTY;
+  PROCEDURE (s : Scope)UplevelInitialize*(i : V.VarSet),NEW,EMPTY;
+  PROCEDURE (o : Idnt)OverloadFix*(),NEW,EMPTY;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE (i : Type)resolve*(d : INTEGER) : Type,NEW,ABSTRACT;
+  PROCEDURE (i : Type)TypeFix*(IN a : TypeSeq),NEW,ABSTRACT;
+  PROCEDURE (i : Type)InsertMethod*(m : Idnt),NEW,EMPTY;
+  PROCEDURE (i : Type)SccTab*(t : SccTable),NEW,ABSTRACT;
+
+(* ============================================================ *)
+(*    Base predicates on Expr extensions                        *)
+(* ============================================================ *)
+
+  PROCEDURE (i : Expr)isNil*() : BOOLEAN,NEW,EXTENSIBLE;
+  BEGIN RETURN FALSE END isNil;
+
+(* -------------------------------------------- *)
+  PROCEDURE (i : Expr)isInf*() : BOOLEAN,NEW,EXTENSIBLE;
+  BEGIN RETURN FALSE END isInf;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE (x : Expr)isWriteable*() : BOOLEAN,NEW,EXTENSIBLE;
+  BEGIN RETURN FALSE END isWriteable;
+
+  PROCEDURE (x : Expr)CheckWriteable*(),NEW,EXTENSIBLE;
+  BEGIN x.ExprError(103) END CheckWriteable;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE (x : Expr)isVarDesig*() : BOOLEAN,NEW,EXTENSIBLE;
+  BEGIN RETURN FALSE END isVarDesig;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE (x : Expr)isProcVar*() : BOOLEAN,NEW,EXTENSIBLE;
+  BEGIN RETURN FALSE END isProcVar;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE (x : Expr)isJavaInit*() : BOOLEAN,NEW,EXTENSIBLE;
+  BEGIN RETURN FALSE END isJavaInit;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE (x : Expr)isSetExpr*() : BOOLEAN,NEW;
+  BEGIN RETURN (x.type # NIL) & (x.type.isSetType()) END isSetExpr;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE (x : Expr)isBooleanExpr*() : BOOLEAN,NEW;
+  BEGIN RETURN (x.type # NIL) & (x.type.isBooleanType()) END isBooleanExpr;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE (x : Expr)isCharArray*() : BOOLEAN,NEW;
+  BEGIN RETURN (x.type # NIL) & (x.type.isCharArrayType()) END isCharArray;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE (x : Expr)isCharLit*() : BOOLEAN,NEW,EXTENSIBLE;
+  (** A literal character, or a literal string of length = 1. *)
+  BEGIN RETURN FALSE END isCharLit;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE (x : Expr)isCharExpr*() : BOOLEAN,NEW;
+  BEGIN
+    RETURN x.isCharLit() OR
+    (x.type # NIL) & (x.type.isCharType());
+  END isCharExpr;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE (x : Expr)isString*() : BOOLEAN,NEW;
+  (** A literal string or the result of a string concatenation. *)
+  BEGIN RETURN (x.type # NIL) & (x.type.isStringType()) END isString;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE (x : Expr)isNumLit*() : BOOLEAN,NEW,EXTENSIBLE;
+  (** Any literal integer. *)
+  BEGIN RETURN FALSE END isNumLit;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE (x : Expr)isStrLit*() : BOOLEAN,NEW,EXTENSIBLE;
+  (** Any literal string. *)
+  BEGIN RETURN FALSE END isStrLit;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE (x : Expr)isProcLit*() : BOOLEAN,NEW,EXTENSIBLE;
+  (** Any literal procedure. *)
+  BEGIN RETURN FALSE END isProcLit;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE (x : Expr)isPointerExpr*() : BOOLEAN,NEW;
+  BEGIN RETURN (x.type # NIL) & x.type.isPointerType() END isPointerExpr;
+
+  PROCEDURE (x : Expr)isVectorExpr*() : BOOLEAN,NEW;
+  BEGIN RETURN (x.type # NIL) & x.type.isVectorType() END isVectorExpr;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE (x : Expr)isProcExpr*() : BOOLEAN,NEW;
+  BEGIN RETURN (x.type # NIL) & x.type.isProcType() END isProcExpr;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE (x : Expr)isIntExpr*() : BOOLEAN,NEW;
+  BEGIN RETURN (x.type # NIL) & x.type.isIntType() END isIntExpr;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE (x : Expr)isRealExpr*() : BOOLEAN,NEW;
+  BEGIN RETURN (x.type # NIL) & x.type.isRealType() END isRealExpr;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE (x : Expr)isNumericExpr*() : BOOLEAN,NEW;
+  BEGIN RETURN (x.type # NIL) & x.type.isNumType() END isNumericExpr;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE (x : Expr)isStdFunc*() : BOOLEAN,NEW,EXTENSIBLE;
+  BEGIN RETURN FALSE END isStdFunc;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE (x : Expr)hasDynamicType*() : BOOLEAN,NEW,EXTENSIBLE;
+  (* overridden for IdLeaf extension of LeafX expression type *)
+  BEGIN
+    RETURN (x.type # NIL) & x.type.isDynamicType();
+  END hasDynamicType;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE (x : Expr)isStdProc*() : BOOLEAN,NEW,EXTENSIBLE;
+  BEGIN RETURN FALSE END isStdProc;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE (x : Expr)inRangeOf*(t : Type) : BOOLEAN,NEW,EXTENSIBLE;
+  (* If t is an ordinal type, return x in range, or for array *
+   * type  t return x is within the index range.    *)
+  BEGIN RETURN FALSE END inRangeOf;
+
+(* ============================================================ *)
+
+  PROCEDURE RepTypesError*(n : INTEGER; lT,rT : Type; ln,cl : INTEGER);
+  BEGIN
+    S.SemError.RepSt2(n, lT.name(), rT.name(), ln, cl);
+  END RepTypesError;
+
+  PROCEDURE RepTypesErrTok*(n : INTEGER; lT,rT : Type; tk : S.Token);
+  BEGIN
+    S.SemError.RepSt2(n, lT.name(), rT.name(), tk.lin, tk.col);
+  END RepTypesErrTok;
+
+(* ============================================================ *)
+(*    Various Type Compatability tests.                         *)
+(* ============================================================ *)
+
+  PROCEDURE (lhT : Type)equalType*(rhT : Type) : BOOLEAN,NEW,EXTENSIBLE;
+  BEGIN
+    RETURN (lhT = rhT)
+        OR lhT.equalPointers(rhT)
+        OR lhT.equalOpenOrVector(rhT)
+        OR lhT.procMatch(rhT);
+  END equalType;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE (lhT : Type)assignCompat*(x : Expr) : BOOLEAN,NEW;
+    VAR rhT : Type;
+  BEGIN
+    IF (x = NIL) OR (x.type = NIL) THEN RETURN TRUE; END;
+    rhT := x.type;
+
+    (* Compound type compatibility. *)
+    IF lhT.isCompoundType() THEN
+      IF ~lhT.isBaseOf(rhT) THEN RETURN FALSE END;
+      IF (rhT.isExtnRecType()) THEN RETURN TRUE END;
+      (* rhT is not extensible. It must support all of lhT's interfaces
+       * statically *)
+      RETURN rhT.implementsAll(lhT);
+    END;
+
+    IF lhT.equalType(rhT) & ~lhT.isExtnRecType() & ~lhT.isOpenArrType() THEN
+        RETURN TRUE END;
+    IF lhT.includes(rhT) THEN
+        RETURN TRUE END;
+    IF lhT.isPointerType() & lhT.isBaseOf(rhT) THEN
+        RETURN TRUE END;
+    IF x.isNil() THEN
+        RETURN lhT.isPointerType() OR lhT.isProcType() END;
+    IF x.isNumLit()  & lhT.isIntType() OR
+       x.isCharLit() & lhT.isCharType() OR
+       x.isStrLit()  & lhT.isCharArrayType() THEN
+        RETURN x.inRangeOf(lhT) END;
+    IF x.isString() THEN
+        RETURN  lhT.nativeCompat() OR lhT.isCharArrayType() END;
+    IF lhT.isInterfaceType() THEN
+        RETURN  rhT.implements(lhT) END;
+    RETURN FALSE;
+  END assignCompat;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE (formal : Idnt)paramCompat*(actual : Expr) : BOOLEAN,NEW;
+    VAR acType : Type;
+        fmType : Type;
+  BEGIN
+    IF (actual = NIL) OR (actual.type = NIL) OR (formal.type = NIL) THEN
+      RETURN TRUE;
+    ELSE
+      acType := actual.type;
+      fmType := formal.type;
+    END;
+
+    IF fmType.equalType(acType) THEN RETURN TRUE;
+    ELSE
+      CASE formal.parMode() OF
+      | val : RETURN fmType.assignCompat(actual);
+      | out : RETURN fmType.isPointerType() & acType.isBaseOf(fmType);
+      | var : RETURN fmType.isExtnRecType() & fmType.isBaseOf(acType);
+      | in  : RETURN fmType.isExtnRecType() & fmType.isBaseOf(acType) OR
+                     fmType.isPointerType() & fmType.assignCompat(actual);
+      (* Special case:  CP-strings ok with IN-mode NativeString/Object *)
+      ELSE RETURN FALSE;
+      END;
+    END;
+  END paramCompat;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE (lhT : Type)arrayCompat*(rhT : Type) : BOOLEAN,NEW,EXTENSIBLE;
+  BEGIN
+    RETURN lhT.equalType(rhT);  (* unless it is an array *)
+  END arrayCompat;
+
+(* ============================================================ *)
+(*        Various Appends, for the abstract types.              *)
+(* ============================================================ *)
+
+  PROCEDURE InitIdSeq*(VAR seq : IdSeq; capacity : INTEGER);
+  BEGIN
+    NEW(seq.a, capacity); seq.tide := 0; seq.high := capacity-1;
+  END InitIdSeq;
+
+  (* ---------------------------------- *)
+
+  PROCEDURE ResetIdSeq*(VAR seq : IdSeq);
+  BEGIN
+    seq.tide := 0;
+    IF seq.a = NIL THEN InitIdSeq(seq, 2) END;
+  END ResetIdSeq;
+
+  (* ---------------------------------- *)
+
+  PROCEDURE (VAR seq : IdSeq)ResetTo*(newTide : INTEGER),NEW;
+  BEGIN
+    ASSERT(newTide <= seq.tide);
+    seq.tide := newTide;
+  END ResetTo;
+
+  (* ---------------------------------- *)
+
+  PROCEDURE AppendIdnt*(VAR seq : IdSeq; elem : Idnt);
+    VAR temp : POINTER TO ARRAY OF Idnt;
+        i    : INTEGER;
+  BEGIN
+    IF seq.a = NIL THEN
+      InitIdSeq(seq, 2);
+    ELSIF seq.tide > seq.high THEN (* must expand *)
+      temp := seq.a;
+      seq.high := seq.high * 2 + 1;
+      NEW(seq.a, seq.high+1);
+      FOR i := 0 TO seq.tide-1 DO seq.a[i] := temp[i] END;
+    END;
+    seq.a[seq.tide] := elem; INC(seq.tide);
+  END AppendIdnt;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE InitTypeSeq*(VAR seq : TypeSeq; capacity : INTEGER);
+  BEGIN
+    NEW(seq.a, capacity); seq.tide := 0; seq.high := capacity-1;
+  END InitTypeSeq;
+
+  PROCEDURE ResetTypeSeq*(VAR seq : TypeSeq);
+  BEGIN
+    seq.tide := 0;
+    IF seq.a = NIL THEN InitTypeSeq(seq, 2) END;
+  END ResetTypeSeq;
+
+  PROCEDURE AppendType*(VAR seq : TypeSeq; elem : Type);
+    VAR temp : POINTER TO ARRAY OF Type;
+        i    : INTEGER;
+  BEGIN
+    IF seq.a = NIL THEN
+      InitTypeSeq(seq, 2);
+    ELSIF seq.tide > seq.high THEN (* must expand *)
+      temp := seq.a;
+      seq.high := seq.high * 2 + 1;
+      NEW(seq.a, (seq.high+1));
+      FOR i := 0 TO seq.tide-1 DO seq.a[i] := temp[i] END;
+    END;
+    seq.a[seq.tide] := elem; INC(seq.tide);
+  END AppendType;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE InitScpSeq*(VAR seq : ScpSeq; capacity : INTEGER);
+  BEGIN
+    NEW(seq.a, capacity); seq.tide := 0; seq.high := capacity-1;
+  END InitScpSeq;
+
+  PROCEDURE ResetScpSeq*(VAR seq : ScpSeq);
+  BEGIN
+    seq.tide := 0;
+    IF seq.a = NIL THEN InitScpSeq(seq, 2) END;
+  END ResetScpSeq;
+
+  PROCEDURE AppendScope*(VAR seq : ScpSeq; elem : Scope);
+    VAR temp : POINTER TO ARRAY OF Scope;
+        i    : INTEGER;
+  BEGIN
+    IF seq.a = NIL THEN
+      InitScpSeq(seq, 2);
+    ELSIF seq.tide > seq.high THEN (* must expand *)
+      temp := seq.a;
+      seq.high := seq.high * 2 + 1;
+      NEW(seq.a, (seq.high+1));
+      FOR i := 0 TO seq.tide-1 DO seq.a[i] := temp[i] END;
+    END;
+    seq.a[seq.tide] := elem; INC(seq.tide);
+  END AppendScope;
+
+(* ============================================================ *)
+
+  PROCEDURE InitExprSeq*(VAR seq : ExprSeq; capacity : INTEGER);
+  BEGIN
+    NEW(seq.a, capacity); seq.tide := 0; seq.high := capacity-1;
+  END InitExprSeq;
+
+  (* ---------------------------------- *)
+
+  PROCEDURE ResetExprSeq*(VAR seq : ExprSeq);
+  BEGIN
+    seq.tide := 0;
+    IF seq.a = NIL THEN InitExprSeq(seq, 2) END;
+  END ResetExprSeq;
+
+  (* ---------------------------------- *)
+
+  PROCEDURE (VAR seq : ExprSeq)ResetTo*(newTide : INTEGER),NEW;
+  BEGIN
+    ASSERT(newTide <= seq.tide);
+    seq.tide := newTide;
+  END ResetTo;
+
+  (* ---------------------------------- *)
+
+  PROCEDURE AppendExpr*(VAR seq : ExprSeq; elem : Expr);
+    VAR temp : POINTER TO ARRAY OF Expr;
+        i    : INTEGER;
+  BEGIN
+    IF seq.a = NIL THEN
+      InitExprSeq(seq, 2);
+    ELSIF seq.tide > seq.high THEN (* must expand *)
+      temp := seq.a;
+      seq.high := seq.high * 2 + 1;
+      NEW(seq.a, (seq.high+1));
+      FOR i := 0 TO seq.tide-1 DO seq.a[i] := temp[i] END;
+    END;
+    seq.a[seq.tide] := elem; INC(seq.tide);
+  END AppendExpr;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE InitStmtSeq*(VAR seq : StmtSeq; capacity : INTEGER);
+  BEGIN
+    NEW(seq.a, capacity); seq.tide := 0; seq.high := capacity-1;
+  END InitStmtSeq;
+
+  PROCEDURE AppendStmt*(VAR seq : StmtSeq; elem : Stmt);
+    VAR temp : POINTER TO ARRAY OF Stmt;
+        i    : INTEGER;
+  BEGIN
+    IF seq.a = NIL THEN
+      InitStmtSeq(seq, 2);
+    ELSIF seq.tide > seq.high THEN (* must expand *)
+      temp := seq.a;
+      seq.high := seq.high * 2 + 1;
+      NEW(seq.a, (seq.high+1));
+      FOR i := 0 TO seq.tide-1 DO seq.a[i] := temp[i] END;
+    END;
+    seq.a[seq.tide] := elem; INC(seq.tide);
+  END AppendStmt;
+
+(* ============================================================ *)
+
+  PROCEDURE (p : Expr)NoteCall*(s : Scope),NEW,EMPTY;
+
+(* ============================================================ *)
+
+  PROCEDURE (p : Expr)enterGuard*(tmp : Idnt) : Idnt,NEW,EXTENSIBLE;
+  BEGIN RETURN NIL END enterGuard;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE (p : Expr)ExitGuard*(sav : Idnt; tmp : Idnt),NEW,EXTENSIBLE;
+  BEGIN END ExitGuard;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE (p : Expr)checkLive*(s : Scope;
+                                 l : V.VarSet) : V.VarSet,NEW,EXTENSIBLE;
+  BEGIN RETURN l END checkLive;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE (p : Expr)assignLive*(s : Scope;
+                                  l : V.VarSet) : V.VarSet,NEW,EXTENSIBLE;
+  BEGIN RETURN p.checkLive(s,l) END assignLive;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE (p : Expr)BoolLive*(scpe : Scope;
+                                lvIn : V.VarSet;
+                            OUT tSet : V.VarSet;
+                            OUT fSet : V.VarSet),NEW,EXTENSIBLE;
+  BEGIN
+    tSet := p.checkLive(scpe, lvIn);
+    fSet := tSet;
+  END BoolLive;
+
+(* ============================================================ *)
+(*    Set methods for the read-only fields                      *)
+(* ============================================================ *)
+
+  PROCEDURE (s : Idnt)SetMode*(m : INTEGER),NEW;
+  BEGIN s.vMod := m END SetMode;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE (s : Idnt)SetKind*(m : INTEGER),NEW;
+  BEGIN s.kind := m END SetKind;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE (s : Type)SetKind*(m : INTEGER),NEW;
+  (** set the "kind" field AND allocate a serial#. *)
+  BEGIN
+    s.kind := m;
+    IF m # standard THEN s.serial := next; INC(next) END;
+  END SetKind;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE (s : Expr)SetKind*(m : INTEGER),NEW;
+  BEGIN s.kind := m END SetKind;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE (s : Stmt)SetKind*(m : INTEGER),NEW;
+  BEGIN s.kind := m END SetKind;
+
+(* ============================================================ *)
+(*  Abstract method of the SymForAll visitor base type          *)
+(* ============================================================ *)
+
+  PROCEDURE (s : SymForAll)Op*(id : Idnt),NEW,ABSTRACT;
+
+(* ============================================================ *)
+(*  Name-fetch methods for type-name diagnostic strings         *)
+(* ============================================================ *)
+
+  PROCEDURE (g : NameFetch)Of*(id : Idnt; OUT s : ARRAY OF CHAR),NEW;
+    VAR chO : L.CharOpen;
+  BEGIN
+    chO := NameHash.charOpenOfHash(id.hash);
+    IF chO = NIL THEN s := "<NIL>" ELSE GPText.Assign(chO^,s) END;
+  END Of;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE (g : NameFetch)ChPtr*(id : Idnt) : L.CharOpen,NEW;
+  BEGIN
+    RETURN NameHash.charOpenOfHash(id.hash);
+  END ChPtr;
+
+(* ============================================================ *)
+(*  Private methods of the symbol-table info-blocks             *)
+(* ============================================================ *)
+
+  PROCEDURE mkSymInfo(h : INTEGER; d : Idnt) : SymInfo;
+    VAR rtrn : SymInfo;
+  BEGIN
+    NEW(rtrn); rtrn.key := h; rtrn.val := d; RETURN rtrn;
+  END mkSymInfo;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE (i : SymInfo)enter(h : INTEGER; d : Idnt) : BOOLEAN,NEW;
+  BEGIN
+    IF h < i.key THEN
+      IF i.lOp = NIL THEN i.lOp := mkSymInfo(h,d); RETURN TRUE;
+      ELSE RETURN i.lOp.enter(h,d);
+      END;
+    ELSIF h > i.key THEN
+      IF i.rOp = NIL THEN i.rOp := mkSymInfo(h,d); RETURN TRUE;
+      ELSE RETURN i.rOp.enter(h,d);
+      END;
+    ELSE (* h must equal i.key *) RETURN FALSE;
+    END;
+  END enter;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE (i : SymInfo)rmLeaf(h : INTEGER) : SymInfo,NEW;
+  BEGIN
+    IF h < i.key THEN    i.lOp := i.lOp.rmLeaf(h);
+    ELSIF h > i.key THEN i.rOp := i.rOp.rmLeaf(h);
+    ELSE (* h must equal i.key *) RETURN NIL;
+    END;
+    RETURN i;
+  END rmLeaf;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE (i : SymInfo)write(h : INTEGER; d : Idnt) : SymInfo,NEW;
+    VAR rtrn : SymInfo;
+  BEGIN
+    rtrn := i;      (* default: return self *)
+    IF    h < i.key THEN i.lOp := i.lOp.write(h,d);
+    ELSIF h > i.key THEN i.rOp := i.rOp.write(h,d);
+    ELSE  rtrn.val := d;
+    END;
+    RETURN rtrn;
+  END write;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE (i : SymInfo)lookup(h : INTEGER) : Idnt,NEW;
+  BEGIN
+    IF h < i.key THEN
+      IF i.lOp = NIL THEN RETURN NIL ELSE RETURN i.lOp.lookup(h) END;
+    ELSIF h > i.key THEN
+      IF i.rOp = NIL THEN RETURN NIL ELSE RETURN i.rOp.lookup(h) END;
+    ELSE (* h must equal i.key *)
+      RETURN i.val;
+    END;
+  END lookup;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE (i : SymInfo)Apply(s : SymForAll),NEW;
+  BEGIN
+    s.Op(i.val);        (* Apply Op() to this node  *)
+    IF i.lOp # NIL THEN i.lOp.Apply(s) END; (* Recurse to left subtree  *)
+    IF i.rOp # NIL THEN i.rOp.Apply(s) END; (* Recurse to right subtree *)
+  END Apply;
+
+(* ============================================================ *)
+(*      Public methods of the symbol-table type                 *)
+(* ============================================================ *)
+
+  PROCEDURE (IN s : SymbolTable)isEmpty*() : BOOLEAN,NEW;
+  BEGIN RETURN s.root = NIL END isEmpty;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE (VAR s : SymbolTable)enter*(hsh : INTEGER; id : Idnt) : BOOLEAN,NEW;
+  (* Enter value in SymbolTable; Return value signals successful insertion. *)
+  BEGIN
+    IF s.root = NIL THEN
+      s.root := mkSymInfo(hsh,id); RETURN TRUE;
+    ELSE
+      RETURN s.root.enter(hsh,id);
+    END;
+  END enter;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE (VAR s : SymbolTable)Overwrite*(hsh : INTEGER; id : Idnt),NEW;
+  (* Overwrite value in SymbolTable; value must be present. *)
+  BEGIN
+    s.root := s.root.write(hsh,id);
+  END Overwrite;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE (VAR s : SymbolTable)RemoveLeaf*(hsh : INTEGER),NEW;
+  (* Remove value in SymbolTable; value must be a leaf. *)
+  BEGIN
+    s.root := s.root.rmLeaf(hsh);
+  END RemoveLeaf;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE (IN s : SymbolTable)lookup*(h : INTEGER) : Idnt,NEW;
+  (* Find value in symbol table, else return NIL. *)
+  BEGIN
+    IF s.root = NIL THEN RETURN NIL ELSE RETURN s.root.lookup(h) END;
+  END lookup;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE (IN tab : SymbolTable)Apply*(sfa : SymForAll),NEW;
+  (* Apply sfa.Op() to each entry in the symbol table. *)
+  BEGIN
+    IF tab.root # NIL THEN tab.root.Apply(sfa) END;
+  END Apply;
+
+(* ============================================================ *)
+(*      Public static methods on symbol-tables                  *)
+(* ============================================================ *)
+
+  PROCEDURE refused*(id : Idnt; scp : Scope) : BOOLEAN;
+    VAR fail  : BOOLEAN;
+        clash : Idnt;
+  BEGIN
+    fail := ~scp.symTb.enter(id.hash, id);
+    IF fail THEN
+      clash := scp.symTb.lookup(id.hash);
+      IF clash.isImport() & clash.isWeak() THEN
+        scp.symTb.Overwrite(id.hash, id); fail := FALSE;
+      END;
+    END;
+    RETURN fail;
+  END refused;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE bindLocal*(hash : INTEGER; scp : Scope) : Idnt;
+  BEGIN
+    RETURN scp.symTb.lookup(hash);
+  END bindLocal;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE bind*(hash : INTEGER; scp : Scope) : Idnt;
+    VAR resId : Idnt;
+  BEGIN
+    resId := scp.symTb.lookup(hash);
+    IF resId = NIL THEN
+      scp := scp.dfScp;
+      WHILE (resId = NIL) & (scp # NIL) DO
+        resId := scp.symTb.lookup(hash);
+        scp := scp.dfScp;
+      END;
+    END;
+    RETURN resId;
+  END bind;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE maxMode*(i,j : INTEGER) : INTEGER;
+  BEGIN
+    IF    (i = pubMode) OR (j = pubMode) THEN RETURN pubMode;
+    ELSIF (i = rdoMode) OR (j = rdoMode) THEN RETURN rdoMode;
+    ELSE RETURN prvMode;
+    END;
+  END maxMode;
+
+(* ============================================================ *)
+(*        Various diagnostic methods                            *)
+(* ============================================================ *)
+
+  PROCEDURE (IN tab : SymbolTable)Dump*(i : INTEGER),NEW;
+    VAR sfa : SymTabDump;
+  BEGIN
+    H.Indent(i);
+    Console.WriteString("+-------- Symtab dump ---------"); Console.WriteLn;
+    NEW(sfa);
+    sfa.indent := i;
+    tab.Apply(sfa);
+    H.Indent(i);
+    Console.WriteString("+-------- dump ended ----------"); Console.WriteLn;
+  END Dump;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE (id : Idnt)IdError*(n : INTEGER),NEW;
+    VAR l,c : INTEGER;
+  BEGIN
+    IF id.token # NIL THEN l := id.token.lin; c := id.token.col;
+    ELSE l := S.line; c := S.col;
+    END;
+    S.SemError.Report(n, l, c);
+  END IdError;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE (id : Idnt)IdErrorStr*(n : INTEGER;
+                                IN s : ARRAY OF CHAR),NEW;
+    VAR l,c : INTEGER;
+  BEGIN
+    IF id.token # NIL THEN l := id.token.lin; c := id.token.col;
+    ELSE l := S.line; c := S.col;
+    END;
+    S.SemError.RepSt1(n,s,l,c);
+  END IdErrorStr;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE (ty : Type)TypeError*(n : INTEGER),NEW,EXTENSIBLE;
+    VAR l,c : INTEGER;
+  BEGIN
+    IF (ty.idnt # NIL) & (ty.idnt.token # NIL) THEN
+      l := ty.idnt.token.lin; c := ty.idnt.token.col;
+    ELSE l := S.line; c := S.col;
+    END;
+    S.SemError.Report(n,l,c);
+  END TypeError;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE (ty : Type)TypeErrStr*(n : INTEGER;
+                                IN s : ARRAY OF CHAR),NEW,EXTENSIBLE;
+    VAR l,c : INTEGER;
+  BEGIN
+    IF ty.idnt # NIL THEN l := ty.idnt.token.lin; c := ty.idnt.token.col;
+    ELSE l := S.line; c := S.col;
+    END;
+    S.SemError.RepSt1(n,s,l,c);
+  END TypeErrStr;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE (xp : Expr)ExprError*(n : INTEGER),NEW;
+    VAR l,c : INTEGER;
+  BEGIN
+    IF xp.token # NIL THEN l := xp.token.lin; c := xp.token.col;
+    ELSE l := S.line; c := S.col;
+    END;
+    S.SemError.Report(n,l,c);
+  END ExprError;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE (st : Stmt)StmtError*(n : INTEGER),NEW;
+    VAR l,c : INTEGER;
+  BEGIN
+    IF st.token # NIL THEN l := st.token.lin; c := st.token.col;
+    ELSE l := S.line; c := S.col;
+    END;
+    S.SemError.Report(n,l,c);
+  END StmtError;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE (id : Idnt)name*() : L.CharOpen, NEW;
+  BEGIN
+    RETURN NameHash.charOpenOfHash(id.hash);
+  END name;
+
+  PROCEDURE (t : Idnt)WriteName*(),NEW;
+    VAR name : FileNames.NameString;
+  BEGIN
+    getName.Of(t, name);
+    Console.WriteString(name$);
+  END WriteName;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE DoXName*(i : INTEGER; s : L.CharOpen);
+  BEGIN
+    H.Indent(i);
+    Console.WriteString("name = ");
+    IF s # NIL THEN Console.WriteString(s) ELSE
+                                        Console.WriteString("<nil>") END;
+    Console.WriteLn;
+  END DoXName;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE (t : Idnt)SuperDiag*(i : INTEGER),NEW;
+    VAR dump : INTEGER;
+  BEGIN
+    dump := 0;
+    (* H.Class("Idnt",t,i); *)
+    H.Indent(i); Console.WriteString("Idnt: name = ");
+    Console.WriteString(getName.ChPtr(t));
+    Console.Write(modMrk[t.vMod]);
+    Console.WriteString(" (");
+    IF t.type = NIL THEN
+      Console.WriteString("no type");
+    ELSE
+      dump := t.type.dump;
+      Console.WriteString(t.type.name());
+    END;
+    IF dump # 0 THEN
+      Console.WriteString(") t$");
+      Console.WriteInt(dump, 1);
+    ELSE
+      Console.Write(")");
+    END;
+    Console.Write("#"); Console.WriteInt(t.hash,1);
+    Console.WriteLn;
+  END SuperDiag;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE (t : Type)SuperDiag*(i : INTEGER),NEW;
+  BEGIN
+    (* H.Class("Type",t,i); *)
+    H.Indent(i); Console.WriteString("Type: ");
+    Console.WriteString(t.name());
+    IF t.dump # 0 THEN
+      Console.WriteString(" t$");
+      Console.WriteInt(t.dump, 1);
+      Console.Write(",");
+    END;
+    Console.WriteString(" s#");
+    Console.WriteInt(t.serial, 1);
+    Console.WriteLn;
+  END SuperDiag;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE (t : Expr)SuperDiag*(i : INTEGER),NEW;
+  BEGIN
+    H.Class("Expr",t,i);
+  END SuperDiag;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE (t : Stmt)SuperDiag*(i : INTEGER),NEW;
+  BEGIN
+    H.Class("Stmt",t,i);
+    IF t.token # NIL THEN
+      H.Indent(i);
+      Console.WriteString("(lin:col ");
+      Console.WriteInt(t.token.lin, 1); Console.Write(":");
+      Console.WriteInt(t.token.col, 1); Console.Write(")");
+      Console.WriteLn;
+    END;
+  END SuperDiag;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE (s : SymTabDump)Op*(id : Idnt);
+  BEGIN
+    id.Diagnose(s.indent);
+  END Op;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE (s : Type)DiagFormalType*(i : INTEGER),NEW,EMPTY;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE (x : Expr)DiagSrcLoc*(),NEW;
+  BEGIN
+    IF x.token # NIL THEN
+      Console.WriteString("Expr at ");
+      Console.WriteInt(x.token.lin,1);
+      Console.Write(":");
+      Console.WriteInt(x.token.col,1);
+    ELSE
+      Console.WriteString("no src token");
+    END;
+    Console.WriteLn;
+  END DiagSrcLoc;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE newNameDump() : NameDump;
+    VAR dump : NameDump;
+  BEGIN
+    NEW(dump);
+    NEW(dump.a, 32);
+    dump.high := 31;
+    dump.tide := 0;
+    RETURN dump;
+  END newNameDump;
+
+ (* --------------------------- *)
+
+  PROCEDURE (sfa : NameDump)Op*(id : Idnt);
+    VAR name : L.CharOpen;
+        temp : L.CharOpen;
+        indx : INTEGER;
+        newH : INTEGER;
+        char : CHAR;
+  BEGIN
+    name := NameHash.charOpenOfHash(id.hash);
+(*
+ *  IF sfa.tide + LEN(name) >= sfa.tide THEN         OOPS!
+ *)
+    IF sfa.tide + LEN(name) >= sfa.high THEN
+      temp := sfa.a;
+      newH := sfa.high + 3 * LEN(name);
+      NEW(sfa.a, newH+1);
+      FOR indx := 0 TO sfa.tide - 1 DO
+        sfa.a[indx] := temp[indx];
+      END;
+      sfa.high := newH;
+    END;
+    IF sfa.tide > 0 THEN
+      sfa.a[sfa.tide-1] := ",";
+      sfa.a[sfa.tide  ] := " ";
+      INC(sfa.tide);
+    END;
+    indx := 0;
+    REPEAT
+      char := name[indx];
+      sfa.a[sfa.tide] := char;
+      INC(sfa.tide);
+      INC(indx);
+    UNTIL char = 0X;
+  END Op;
+
+ (* --------------------------- *)
+
+  PROCEDURE dumpList*(s : SymbolTable) : L.CharOpen;
+    VAR sfa : NameDump;
+  BEGIN
+    sfa := newNameDump();
+    s.Apply(sfa);
+    RETURN sfa.a;
+  END dumpList;
+
+(* ============================================================ *)
+BEGIN (* ====================================================== *)
+  NEW(getName);
+  modMrk      := " *-!";
+  modStr[val] := "";
+  modStr[in ] := "IN ";
+  modStr[out] := "OUT ";
+  modStr[var] := "VAR ";
+END Symbols.  (* ============================================== *)
+(* ============================================================ *)
+

gpcp/Target.cp

@@ -0,0 +1,69 @@
+(* ============================================================ *)
+(*  Target is the module which selects the target ClassMaker.	*)
+(*  Copyright (c) John Gough 1999, 2000.			*)
+(* ============================================================ *)
+
+MODULE Target;
+
+  IMPORT 
+	GPCPcopyright,
+	Symbols,
+	CompState,
+	ClassMaker,
+	JavaMaker,
+(*
+ *	DCodeMaker,
+ *)
+	MsilMaker,
+	IdDesc;
+
+(* ============================================================ *)
+
+  VAR
+    maker : ClassMaker.ClassEmitter;
+    assmb : ClassMaker.Assembler;
+
+(* ============================================================ *)
+
+  PROCEDURE Select*(mod : IdDesc.BlkId; 
+		 IN str : ARRAY OF CHAR);
+  BEGIN
+    IF str = "jvm" THEN
+      maker := JavaMaker.newJavaEmitter(mod);
+      assmb := JavaMaker.newJavaAsm();
+      Symbols.SetTargetIsNET(FALSE);
+    ELSIF str = "net" THEN
+      maker := MsilMaker.newMsilEmitter(mod);
+      assmb := MsilMaker.newMsilAsm();
+      Symbols.SetTargetIsNET(TRUE);
+(*
+ *  ELSIF str = "dcf" THEN
+ *    maker := DCodeMaker.newDCodeEmitter(mod);		(* write DCode	*)
+ *    assmb := DCodeMaker.newDCodeAsm();		(* call dgen	*)
+ *  ELSIF ...
+ *)
+    ELSE
+      CompState.Message("Unknown emitter name <" + str + ">");
+    END;
+  END Select;
+
+(* ============================================================ *)
+
+  PROCEDURE Init*();
+  BEGIN
+    maker.Init();
+  END Init;
+
+  PROCEDURE Emit*();
+  BEGIN
+    maker.Emit();
+  END Emit;
+
+  PROCEDURE Assemble*();
+  BEGIN
+    assmb.Assemble();
+  END Assemble;
+
+(* ============================================================ *)
+END Target.
+(* ============================================================ *)

gpcp/TypeDesc.cp

@@ -0,0 +1,3006 @@
+(* ==================================================================== *)
+(*                                                                      *)
+(*  TypeDesc Module for the Gardens Point Component Pascal Compiler.    *)
+(*  Implements type descriptors that are extensions of Symbols.Type     *)
+(*                                                                      *)
+(*  Copyright (c) John Gough 1999, 2000.                                *)
+(*           version 1.1.4 2002:Jan:14                                  *)
+(*                                                                      *)
+(* ==================================================================== *)
+
+MODULE TypeDesc;
+
+  IMPORT
+        GPCPcopyright,
+        Con := Console,
+        GPText,
+        VarSets,
+        NameHash,
+        FileNames,
+        CSt := CompState,
+        Id  := IdDesc,
+        Sy  := Symbols,
+        Lv  := LitValue,
+        S   := CPascalS,
+        H   := DiagHelper;
+
+(* ============================================================ *)
+
+  CONST (* type-kinds *)
+    basTp* = Symbols.standard;
+    tmpTp* = 1;  namTp* = 2; arrTp* = 3;
+    recTp* = 4;  ptrTp* = 5; prcTp* = 6;
+    enuTp* = 7;  evtTp* = 8; ovlTp* = 9;
+    vecTp* = 10;
+
+  CONST (* base-ordinals *)
+  (* WARNING:  these are locked in.  If they are changed, there *)
+  (* is a consequential change in CPJrts for the JVM version.   *)
+    notBs   =  0;
+    boolN*  =  1;
+    sChrN*  =  2; charN*  = 3;
+    byteN*  =  4; sIntN*  = 5;  intN*  =  6; lIntN* =  7;
+    sReaN*  =  8; realN*  = 9;
+    setN*   = 10;
+    anyRec* = 11; anyPtr* = 12;
+    strN*   = 13; sStrN*  = 14; uBytN* = 15;
+    metaN*  = 16;
+
+  CONST (* record attributes *)
+    noAtt* = 0; isAbs* = 1; limit* = 2;
+    extns* = 3; iFace* = 4;
+    cmpnd* = 5;   (* Marker for Compound Types                  *)
+    noNew* = 8;   (* These two attributes are really for xAttr, *)
+    valRc* = 16;  (* but piggy-back on recAtt in the symbolfile *)
+    clsRc* = 32;  (* but piggy-back on recAtt in the symbolfile *)
+
+(* ============================================================ *)
+
+  CONST (* traversal depth markers *)
+    initialMark = 0;
+    finishMark  = -1;
+    errorMark   = 0FFFFFH;
+
+(* ============================================================ *)
+
+   (* ------------------------------------------------------- *
+    *  Overloadeds do not occur in pure Component Pascal.     *
+    *  They appear transiently as descriptors of types of     *
+    *  idents bound to overloaded members from foriegn libs.  *
+    * ------------------------------------------------------- *)
+  TYPE
+    Overloaded* = POINTER TO EXTENSIBLE RECORD (Sy.Type)
+                 (* ... inherited from Type ... ------------- *
+                  * idnt*   : Idnt;         (* Id of typename *)
+                  * kind-   : INTEGER;      (* tag for unions *)
+                  * serial- : INTEGER;      (* type serial-nm *)
+                  * force*  : INTEGER;      (* force sym-emit *)
+                  * xName*  : Lv.CharOpen;  (* proc signature *)
+                  * dump*,depth* : INTEGER; (* scratch loc'ns *)
+                  * tgXtn*  : ANYPTR;       (* target stuff   *)
+                  * ----------------------------------------- *)
+                  END;
+
+(* ============================================================ *)
+
+  TYPE
+    Base*   = POINTER TO RECORD (Sy.Type)
+             (* ... inherited from Type ... ------------- *
+              * idnt*   : Idnt;         (* Id of typename *)
+              * kind-   : INTEGER;      (* tag for unions *)
+              * serial- : INTEGER;      (* type serial-nm *)
+              * force*  : INTEGER;      (* force sym-emit *)
+              * xName*  : Lv.CharOpen;  (* full ext name  *)
+              * dump*,depth* : INTEGER; (* scratch loc'ns *)
+              * tgXtn*  : ANYPTR;       (* target stuff   *)
+              * ----------------------------------------- *)
+                tpOrd* : INTEGER;
+              END;      (* ------------------------------ *)
+
+(* ============================================================ *)
+
+  VAR anyRecTp- : Base; (* Descriptor for the base type ANYREC. *)
+      anyPtrTp- : Base; (* Descriptor for the base type ANYPTR. *)
+      integerT* : Sy.Type;
+      nilStr    : Lv.CharOpen;
+
+(* ============================================================ *)
+
+  TYPE
+    Opaque* = POINTER TO RECORD (Sy.Type)
+             (* ... inherited from Type ... ------------- *
+              * idnt*   : Idnt;         (* Id of typename *)
+              * kind-   : INTEGER;      (* tag for unions *)
+              * serial- : INTEGER;      (* type serial-nm *)
+              * force*  : INTEGER;      (* force sym-emit *)
+              * xName*  : Lv.CharOpen;  (* full ext name  *)
+              * dump*,depth* : INTEGER; (* scratch loc'ns *)
+              * tgXtn*  : ANYPTR;       (* target stuff   *)
+              * ----------------------------------------- *)
+                resolved* : Sy.Type;    (* ptr to real-Tp *)
+                scopeNm*  : Lv.CharOpen;
+              END;      (* ------------------------------ *)
+
+(* ============================================================ *)
+
+  TYPE
+    Array*  = POINTER TO EXTENSIBLE RECORD (Sy.Type)
+             (* ... inherited from Type ... ------------- *
+              * idnt*   : Idnt;         (* Id of typename *)
+              * kind-   : INTEGER;      (* tag for unions *)
+              * serial- : INTEGER;      (* type serial-nm *)
+              * force*  : INTEGER;      (* force sym-emit *)
+              * xName*  : Lv.CharOpen;  (* full ext name  *)
+              * dump*,depth* : INTEGER; (* scratch loc'ns *)
+              * tgXtn*  : ANYPTR;       (* target stuff   *)
+              * ----------------------------------------- *)
+                elemTp* : Sy.Type;      (* element tpDesc *)
+                length* : INTEGER;      (* 0 for open-arr *)
+              END;      (* ------------------------------ *)
+
+(* ============================================================ *)
+
+  TYPE
+    Vector* = POINTER TO RECORD (Array)
+             (* ... inherited from Type ... ------------- *
+              * idnt*   : Idnt;         (* Id of typename *)
+              * kind-   : INTEGER;      (* tag for unions *)
+              * serial- : INTEGER;      (* type serial-nm *)
+              * force*  : INTEGER;      (* force sym-emit *)
+              * xName*  : Lv.CharOpen;  (* full ext name  *)
+              * dump*,depth* : INTEGER; (* scratch loc'ns *)
+              * tgXtn*  : ANYPTR;       (* target stuff   *)
+              * ... inherited from Array ... ------------ *
+              * elemTp* : Sy.Type;      (* element tpDesc *)
+              * length* : INTEGER;      (* unused for Vec *)
+              * ----------------------------------------- *)
+              END;      (* ------------------------------ *)
+
+(* ============================================================ *)
+
+  TYPE
+   (* ====================================================== *
+    * When should a record type be implemented as a          *
+    * reference class?   When any of the following is true:- *
+    *  >  It is extensible or abstract                       *
+    *  >  It extends a type other than System.ValueType      *
+    *  >  It has an embedded non-value structure             *
+    *  >  It is only declared as a pointer target            *
+    *  >  If the target does not support value records       *
+    * ====================================================== *)
+    Record*    = POINTER TO RECORD (Sy.Type)
+                (* ... inherited from Type ... ------------- *
+                 * idnt*   : Idnt;         (* Id of typename *)
+                 * kind-   : INTEGER;      (* tag for unions *)
+                 * serial- : INTEGER;      (* type serial-nm *)
+                 * force*  : INTEGER;      (* force sym-emit *)
+                 * xName*  : Lv.CharOpen;  (* full ext name  *)
+                 * dump*,depth* : INTEGER; (* scratch loc'ns *)
+                 * tgXtn*  : ANYPTR;       (* target stuff   *)
+                 * ----------------------------------------- *)
+                   baseTp*     : Sy.Type;  (* immediate base *)
+                   bindTp*     : Sy.Type;  (* ptrTo if anon. *)
+                   encCls*     : Sy.Type;  (* if nested cls. *)
+                   recAtt*     : INTEGER;
+                   symTb*      : Sy.SymbolTable;
+                   extrnNm*    : Lv.CharOpen;
+                   scopeNm*    : Lv.CharOpen;
+                   fields*     : Sy.IdSeq; (* list of fields *)
+                   methods*    : Sy.IdSeq; (* list of meth's *)
+                   statics*    : Sy.IdSeq; (* list of stat's *)
+                   interfaces* : Sy.TypeSeq;(* impl-sequence *)
+                   events*     : Sy.IdSeq; (* event-sequence *)
+                   xAttr*      : SET;      (* external attrs *)
+                 END;      (* ------------------------------ *)
+
+(* ============================================================ *)
+
+  TYPE
+    Enum*      = POINTER TO RECORD (Sy.Type)
+                (* ... inherited from Type ... ------------- *
+                 * idnt*   : Idnt;         (* Id of typename *)
+                 * kind-   : INTEGER;      (* tag for unions *)
+                 * serial- : INTEGER;      (* type serial-nm *)
+                 * force*  : INTEGER;      (* force sym-emit *)
+                 * xName*  : Lv.CharOpen;  (* full ext name  *)
+                 * dump*,depth* : INTEGER; (* scratch loc'ns *)
+                 * tgXtn*  : ANYPTR;       (* target stuff   *)
+                 * ----------------------------------------- *)
+                   symTb*      : Sy.SymbolTable;
+                   statics*    : Sy.IdSeq; (* list of stat's *)
+                 END;      (* ------------------------------ *)
+
+(* ============================================================ *)
+
+  TYPE
+    Pointer*   = POINTER TO EXTENSIBLE RECORD (Sy.Type)
+                (* ... inherited from Type ... ------------- *
+                 * idnt*   : Idnt;         (* Id of typename *)
+                 * kind-   : INTEGER;      (* tag for unions *)
+                 * serial- : INTEGER;      (* type serial-nm *)
+                 * force*  : INTEGER;      (* force sym-emit *)
+                 * xName*  : Lv.CharOpen;  (* full ext name  *)
+                 * dump*,depth* : INTEGER; (* scratch loc'ns *)
+                 * tgXtn*  : ANYPTR;       (* target stuff   *)
+                 * ----------------------------------------- *)
+                   boundTp* : Sy.Type;     (* ptr bound type *)
+                 END;      (* ------------------------------ *)
+
+(* ============================================================ *)
+
+  TYPE
+    Procedure* = POINTER TO EXTENSIBLE RECORD (Sy.Type)
+                (* ... inherited from Type ... ------------- *
+                 * idnt*   : Idnt;         (* Id of typename *)
+                 * kind-   : INTEGER;      (* tag for unions *)
+                 * serial- : INTEGER;      (* type serial-nm *)
+                 * force*  : INTEGER;      (* force sym-emit *)
+                 * xName*  : Lv.CharOpen;  (* proc signature *)
+                 * dump*,depth* : INTEGER; (* scratch loc'ns *)
+                 * tgXtn*  : ANYPTR;       (* target stuff   *)
+                 * ----------------------------------------- *)
+                   tName*    : Lv.CharOpen;(* proc-type name *)
+                   retType*  : Sy.Type;    (* ret-type | NIL *)
+                   receiver* : Sy.Type;    (* element tpDesc *)
+                   formals*  : Id.ParSeq;  (* formal params  *)
+                   retN*,argN* : INTEGER;
+                END;       (* ------------------------------ *)
+
+(* ============================================================ *)
+
+  TYPE
+    Event*     = POINTER TO RECORD (Procedure)
+                (* ... inherited from Type ... ------------- *
+                 * xName*  : Lv.CharOpen;  (* proc signature *)
+                 * tName*  : Lv.CharOpen;  (* proc-type name *)
+                 * tgXtn*  : ANYPTR;       (* target stuff   *)
+                 * ----------------------------------------- *
+                 * ... inherited from Procedure ... -------- *
+                 * tName*    : Lv.CharOpen;(* proc-type name *)
+                 * retType*  : Sy.Type;    (* ret-type | NIL *)
+                 * receiver* : Sy.Type;    (* element tpDesc *)
+                 * formals*  : Id.ParSeq;  (* formal params  *)
+                 * retN*,argN* : INTEGER;
+                 * ----------------------------------------- *)
+                   bndRec- : Record;
+                 END;
+
+(* ============================================================ *)
+(*               Predicates on Type extensions                  *)
+(* ============================================================ *)
+
+  PROCEDURE (t : Base)isBooleanType*() : BOOLEAN;
+  BEGIN RETURN t.tpOrd = boolN END isBooleanType;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE (t : Base)isNumType*() : BOOLEAN;
+  BEGIN 
+    RETURN 
+     (t.tpOrd <= realN) & (t.tpOrd >= byteN) OR (t.tpOrd =  uBytN);
+  END isNumType;
+
+  PROCEDURE (t : Enum)isNumType*() : BOOLEAN;
+  BEGIN RETURN TRUE END isNumType;
+
+
+(* -------------------------------------------- *)
+
+  PROCEDURE (t : Base)isBaseType*() : BOOLEAN;
+  BEGIN RETURN TRUE END isBaseType;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE (t : Base)isIntType*() : BOOLEAN;
+  BEGIN 
+    RETURN 
+      (t.tpOrd <= lIntN) & (t.tpOrd >= byteN) OR (t.tpOrd = uBytN);
+  END isIntType;
+
+  PROCEDURE (t : Enum)isIntType*() : BOOLEAN;
+  BEGIN RETURN TRUE END isIntType;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE (t : Base)isScalarType*() : BOOLEAN;
+  BEGIN RETURN t.tpOrd # anyRec END isScalarType;
+
+  PROCEDURE (t : Enum)isScalarType*() : BOOLEAN;
+  BEGIN RETURN TRUE END isScalarType;
+
+  PROCEDURE (t : Array)isScalarType*() : BOOLEAN, EXTENSIBLE;
+  BEGIN RETURN FALSE END isScalarType;
+
+  PROCEDURE (t : Vector)isScalarType*() : BOOLEAN;
+  BEGIN RETURN TRUE END isScalarType;
+
+  PROCEDURE (t : Record)isScalarType*() : BOOLEAN;
+  BEGIN RETURN FALSE END isScalarType;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE (t : Record)isImportedType*() : BOOLEAN;
+  BEGIN
+    IF t.bindTp # NIL THEN
+      RETURN t.bindTp.isImportedType();
+    ELSE
+      RETURN (t.idnt # NIL) & (t.idnt.dfScp # NIL) & t.idnt.dfScp.isImport();
+    END;
+  END isImportedType;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE (t : Base)isSetType*() : BOOLEAN;
+  BEGIN RETURN t.tpOrd = setN END isSetType;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE (t : Base)isRealType*() : BOOLEAN;
+  BEGIN RETURN (t.tpOrd = realN) OR (t.tpOrd = sReaN) END isRealType;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE (t : Base)isCharType*() : BOOLEAN;
+  BEGIN RETURN (t.tpOrd = charN) OR (t.tpOrd = sChrN) END isCharType;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE (t : Base)isNativeObj*() : BOOLEAN;
+  BEGIN RETURN (t = anyRecTp) OR (t = anyPtrTp) END isNativeObj;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE (t : Pointer)isNativeObj*() : BOOLEAN;
+  BEGIN RETURN t = CSt.ntvObj END isNativeObj;
+
+  PROCEDURE (t : Pointer)isNativeStr*() : BOOLEAN;
+  BEGIN RETURN t = CSt.ntvStr END isNativeStr;
+
+  PROCEDURE (t : Pointer)isNativeExc*() : BOOLEAN;
+  BEGIN RETURN t = CSt.ntvExc END isNativeExc;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE (t : Record)isNativeObj*() : BOOLEAN;
+  BEGIN RETURN t = CSt.ntvObj(Pointer).boundTp END isNativeObj;
+
+  PROCEDURE (t : Record)isNativeStr*() : BOOLEAN;
+  BEGIN RETURN t = CSt.ntvStr(Pointer).boundTp END isNativeStr;
+
+  PROCEDURE (t : Record)isNativeExc*() : BOOLEAN;
+  BEGIN RETURN t = CSt.ntvExc(Pointer).boundTp END isNativeExc;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE (t : Base)isStringType*() : BOOLEAN;
+  BEGIN RETURN (t.tpOrd = strN) OR (t.tpOrd = sStrN) END isStringType;
+
+  PROCEDURE (t : Pointer)isStringType*() : BOOLEAN;
+  BEGIN RETURN t = CSt.ntvStr END isStringType;
+
+  PROCEDURE (t : Record)isStringType*() : BOOLEAN;
+  BEGIN RETURN t = CSt.ntvStr(Pointer).boundTp END isStringType;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE (t : Pointer)nativeCompat*() : BOOLEAN;
+  BEGIN RETURN (t = CSt.ntvStr) OR (t = CSt.ntvObj) END nativeCompat;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE (t : Array)isCharArrayType*() : BOOLEAN;
+  BEGIN RETURN (t.elemTp # NIL) & t.elemTp.isCharType() END isCharArrayType;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE (t : Pointer)isDynamicType*() : BOOLEAN;
+  (** A type is dynamic if it is a pointer to any     *
+   *  record. Overrides isDynamicType method in Symbols.Type. *)
+  BEGIN RETURN (t.boundTp # NIL) & (t.boundTp IS Record) END isDynamicType;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE (t : Base)isPointerType*() : BOOLEAN;
+  BEGIN RETURN t.tpOrd = anyPtr END isPointerType;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE (t : Pointer)isPointerType*() : BOOLEAN;
+  BEGIN RETURN TRUE END isPointerType;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE (t : Record)isRecordType*() : BOOLEAN;
+  BEGIN RETURN TRUE END isRecordType;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE (t : Procedure)isProcType*() : BOOLEAN;
+  BEGIN RETURN TRUE END isProcType;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE (t : Base)isProcType*() : BOOLEAN;
+  BEGIN RETURN t.tpOrd = anyPtr END isProcType;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE (t : Base)isDynamicType*() : BOOLEAN;
+  BEGIN RETURN t.tpOrd = anyPtr END isDynamicType;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE (t : Procedure)isProperProcType*() : BOOLEAN;
+  BEGIN RETURN t.retType = NIL END isProperProcType;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE (t : Procedure)returnType*() : Sy.Type;
+  BEGIN RETURN t.retType END returnType;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE (t : Record)isAbsRecType*() : BOOLEAN;
+  (** A record is absolute if it is declared to be an absolute  *
+   *  record, or is a compound type.                            *
+   *  Overrides isAbsRecType method in Symbols.Type.            *)
+  BEGIN
+    RETURN (isAbs = t.recAtt) OR
+           (iFace = t.recAtt) OR
+           (cmpnd = t.recAtt);
+  END isAbsRecType;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE (t : Record)isExtnRecType*() : BOOLEAN;
+  (** A record is extensible if declared absolute or extensible *
+   *  record. Overrides isExtnRecType method in Symbols.Type.   *)
+  BEGIN
+    RETURN (extns = t.recAtt) OR (isAbs = t.recAtt);
+  END isExtnRecType;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE (t : Base)isExtnRecType*() : BOOLEAN;
+  (** A base type is extensible if it is ANYREC or ANYPTR * 
+   *  Overrides isExtnRecType method in Symbols.Type.     *)
+  BEGIN
+    RETURN t.tpOrd = anyRec;
+  END isExtnRecType;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE (t : Record)isLimRecType*() : BOOLEAN;
+  (** A record is limited if it is declared to be limited *
+   *  record. Overrides isLimRec method in Symbols.Type.  *)
+  BEGIN RETURN limit = t.recAtt END isLimRecType;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE (t : Array)isOpenArrType*() : BOOLEAN;
+  BEGIN RETURN (t.kind = arrTp) & (t.length = 0) END isOpenArrType;
+
+  PROCEDURE (t : Vector)isVectorType*() : BOOLEAN;
+  BEGIN RETURN TRUE END isVectorType;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE (t : Base)needsInit*() : BOOLEAN;
+  BEGIN RETURN FALSE END needsInit;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE (t : Base)isLongType*() : BOOLEAN;
+  BEGIN RETURN (t.tpOrd = realN) OR (t.tpOrd = lIntN) END isLongType;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE (r : Record)compoundCompat*(e : Sy.Type) : BOOLEAN, NEW;
+  (** Returns TRUE iff e is a type that could possibly be assignment
+   *   compatible with the compound type r (i.e. r := e).
+   *  If e is an extensible record type, it is sufficient that
+   *   its base type is a subtype of the base type of r.
+   *   Because the type is extensible, compatibility may not
+   *   be determinable statically. Assertions may need to be
+   *   inserted to determine compatibility at runtime.
+   *  If e is not extensible then it must be a subtype of the
+   *   base type of r and implement all of the interfaces of
+   *   r. *)
+  BEGIN
+    ASSERT(r.isCompoundType());
+    (* Not compatible if r is not a base of e *)
+    IF (~r.isBaseOf(e)) THEN RETURN FALSE END;
+    (* Dynamically compatible if e is an extensible record type *)
+    IF (e.isExtnRecType()) THEN RETURN TRUE END;
+    (* d is not extensible. It must support all of r's interfaces
+     * statically *)
+    RETURN e.implementsAll(r);
+  END compoundCompat;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE (b : Base)includes*(x : Sy.Type) : BOOLEAN;
+    VAR xBas : Base;
+        xOrd : INTEGER;
+        bOrd : INTEGER;
+  BEGIN
+    IF x IS Enum THEN x := integerT;
+    ELSIF ~(x IS Base) THEN RETURN FALSE;
+    END;
+
+    xBas := x(Base);
+    xOrd := xBas.tpOrd;
+    bOrd := b.tpOrd;
+    CASE bOrd OF
+    | uBytN, byteN, sChrN : (* only equality here *)
+        RETURN xOrd = bOrd;
+(*
+ *  | byteN : (* only equality here *)
+ *      RETURN xOrd = bOrd; 
+ *  | uBytN, sChrN : (* only equality here *)
+ *      RETURN (xOrd = uBytN) OR (xOrd = sChrN);
+ *)
+    | charN :
+        RETURN (xOrd = charN) OR (xOrd = sChrN) OR (xOrd = uBytN);
+    | sIntN .. realN :
+        RETURN (xOrd <= bOrd) & (xOrd >= byteN) OR (xOrd =  uBytN);
+    ELSE
+        RETURN FALSE;
+    END;
+  END includes;
+
+  PROCEDURE (b : Enum)includes*(x : Sy.Type) : BOOLEAN;
+    VAR xBas : Base;
+  BEGIN
+    RETURN integerT.includes(x);
+  END includes;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE (b : Base)isBaseOf*(e : Sy.Type) : BOOLEAN;
+  (** Find if e is an extension of base type b.   *
+   *  Overrides the isBaseOf method in Symbols.Type   *)
+  BEGIN
+    IF    e.kind = recTp THEN RETURN b.tpOrd = anyRec;
+    ELSIF e.kind = ptrTp THEN RETURN b.tpOrd = anyPtr;
+    ELSE (* all others *)     RETURN b = e;
+    END;
+  END isBaseOf;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE (b : Record)isBaseOf*(e : Sy.Type) : BOOLEAN;
+  (** Find if e is an extension of record type b.   *
+   *  Overrides the isBaseOf method in Symbols.Type   *)
+    VAR ext : Record;
+        i   : INTEGER;
+  BEGIN
+    e := e.boundRecTp();  (* FIXME? kjg *)
+
+    IF (e = NIL) OR (e.kind # recTp) THEN RETURN FALSE;
+    ELSIF e = b THEN RETURN TRUE;               (* Trivially! *)
+    END;                                        (* Not a record *)
+    ext := e(Record);                           (* Cast to Rec. *)
+
+    (* Compound type test: returns true if b is
+     * a compound type and its base is a base of
+     * e *)
+    IF b.isCompoundType() THEN
+      RETURN b.baseTp.isBaseOf(e);
+    END;
+
+    RETURN b.isBaseOf(ext.baseTp);              (* Recurse up!  *)
+  END isBaseOf;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE (b : Pointer)isBaseOf*(e : Sy.Type) : BOOLEAN;
+  (** Find if e is an extension of pointer type b.    *
+   *  Overrides the isBaseOf method in Symbols.Type   *)
+    VAR ext : Pointer;
+  BEGIN
+    IF (e = NIL) OR (e.kind # ptrTp)  THEN RETURN FALSE;
+    ELSIF (e = b) OR (b = CSt.ntvObj) THEN RETURN TRUE;   (* Trivially! *)
+    END;
+    ext := e(Pointer);                        (* Cast to Ptr. *)
+    RETURN (b.boundTp # NIL)                  (* Go to bnd-tp *)
+          & b.boundTp.isBaseOf(ext.boundTp);  (* for decision *)
+  END isBaseOf;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE (s : Array)isRefSurrogate*() : BOOLEAN;
+  BEGIN RETURN TRUE END isRefSurrogate;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE (s : Record)isRefSurrogate*() : BOOLEAN;
+  BEGIN
+    RETURN (Sy.clsTp IN s.xAttr) OR CSt.targetIsJVM();
+  END isRefSurrogate;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE (lhT : Array)arrayCompat*(rhT : Sy.Type) : BOOLEAN;
+  BEGIN
+    IF lhT.length = 0 THEN      (* An open array type *)
+      IF rhT.kind = arrTp THEN
+        RETURN lhT.elemTp.arrayCompat(rhT(Array).elemTp);
+      ELSE
+        RETURN lhT.isCharArrayType() & rhT.isStringType();
+      END;
+    ELSE
+      RETURN FALSE;
+    END;
+  END arrayCompat;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE (lhT : Enum)equalType*(rhT : Sy.Type) : BOOLEAN;
+  BEGIN
+    IF lhT = rhT THEN RETURN TRUE END;
+    WITH rhT : Base DO
+      RETURN rhT = integerT;
+    ELSE
+      RETURN FALSE;
+    END;
+  END equalType;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE (t : Record)isForeign*() : BOOLEAN;
+  BEGIN
+    RETURN Sy.isFn IN t.xAttr;
+  END isForeign;
+
+  PROCEDURE (t : Pointer)isForeign*() : BOOLEAN;
+  BEGIN
+    RETURN t.boundTp.isForeign();
+  END isForeign;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE (t : Record)isCompoundType*() : BOOLEAN;
+  (* Returns true iff the record is a compound type *)
+  BEGIN
+    RETURN t.recAtt = cmpnd;
+  END isCompoundType;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE (t : Pointer)isCompoundType*() : BOOLEAN;
+  (* Returns true iff the pointer points to a compound type *)
+  BEGIN
+    RETURN (t.boundTp # NIL) & t.boundTp.isCompoundType();
+  END isCompoundType;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE (t : Record)ImplementationType*() : Sy.Type;
+  (* For compound types, this returns the base type of the compound
+   * unless it is ANNYREC in which case it returns the first
+   * interface in the list *)
+  BEGIN
+    IF t.isCompoundType() THEN
+      IF t.baseTp # anyRecTp THEN
+         RETURN t.baseTp(Record).bindTp;
+      ELSE
+         RETURN t.interfaces.a[0];
+      END;
+    ELSE
+      RETURN t;
+    END;
+  END ImplementationType;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE (t : Record)valCopyOK*() : BOOLEAN;
+  BEGIN
+    RETURN ~(Sy.noCpy IN t.xAttr);
+  END valCopyOK;
+
+  PROCEDURE (t : Array)valCopyOK*() : BOOLEAN;
+  BEGIN
+    RETURN t.elemTp.valCopyOK();
+  END valCopyOK;
+
+(* ============================================ *)
+
+  PROCEDURE (t : Record)isInterfaceType*() : BOOLEAN;
+  BEGIN
+    RETURN (t.recAtt = iFace) OR
+           ( (t.recAtt = cmpnd) &
+             ( (t.baseTp = NIL) OR (t.baseTp = anyRecTp) ) );
+  END isInterfaceType;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE (t : Pointer)isInterfaceType*() : BOOLEAN;
+  BEGIN
+    RETURN (t.boundTp # NIL) & t.boundTp.isInterfaceType();
+  END isInterfaceType;
+
+(* ============================================ *)
+
+  PROCEDURE (t : Event)isEventType*() : BOOLEAN;
+  BEGIN RETURN TRUE END isEventType;
+
+(* ============================================ *)
+
+  PROCEDURE (t : Record)implements*(x : Sy.Type) : BOOLEAN;
+   (* Assert: x.isInterfaceType is true *)
+    VAR i : INTEGER; d : Sy.Type;
+  BEGIN
+    FOR i := 0 TO t.interfaces.tide - 1 DO
+      d := t.interfaces.a[i];
+      IF (d # NIL) &
+   ((d = x) OR d.implements(x)) THEN RETURN TRUE END;
+    END;
+   (* else ... *)
+    RETURN (t.baseTp # NIL) & t.baseTp.implements(x);
+  END implements;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE (t : Pointer)implements*(x : Sy.Type) : BOOLEAN;
+  BEGIN
+    RETURN (t.boundTp # NIL) & t.boundTp.implements(x);
+  END implements;
+
+(* ============================================ *)
+
+  PROCEDURE (r : Record)implementsAll*(x : Sy.Type) : BOOLEAN;
+  (* Returns true iff r implements all of the interfaces of x.*)
+    VAR
+      i: INTEGER;
+  BEGIN
+    WITH x : Pointer DO
+            RETURN r.implementsAll(x.boundTp);
+         | x : Record DO
+            FOR i := 0 TO x.interfaces.tide - 1 DO
+              IF ~r.implements(x.interfaces.a[i]) THEN RETURN FALSE END;
+            END;
+            RETURN TRUE;
+         ELSE
+            RETURN FALSE;
+    END;
+    RETURN FALSE;
+  END implementsAll;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE (i : Pointer)implementsAll*(x : Sy.Type) : BOOLEAN;
+  (* Returns true iff p implements all of the interfaces of x.*)
+  BEGIN
+    RETURN i.boundTp.implementsAll(x);
+  END implementsAll;
+
+(* ============================================ *)
+
+  PROCEDURE (lhsT : Procedure)formsMatch(rhsT : Procedure) : BOOLEAN,NEW;
+    VAR index : INTEGER;
+        lP,rP : Id.ParId;
+  BEGIN
+    IF lhsT.formals.tide # rhsT.formals.tide THEN RETURN FALSE;
+    ELSE
+      FOR index := 0 TO lhsT.formals.tide-1 DO
+        lP := lhsT.formals.a[index];
+        rP := rhsT.formals.a[index];
+        IF (lP.type # NIL) & ~lP.type.equalType(rP.type) THEN RETURN FALSE END;
+        IF lP.parMod # rP.parMod THEN RETURN FALSE END;
+      END;
+    END;
+    RETURN TRUE;
+  END formsMatch;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE (lT : Array)equalOpenOrVector*(r : Sy.Type) : BOOLEAN, EXTENSIBLE;
+    VAR rT : Array;
+  BEGIN
+    IF ~(r IS Array) THEN RETURN FALSE;
+    ELSE
+      rT := r(Array);
+      RETURN (lT.length = 0) & (rT.length = 0) &
+              lT.elemTp.equalType(rT.elemTp);
+    END;
+  END equalOpenOrVector;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE (lT : Vector)equalOpenOrVector*(rT : Sy.Type) : BOOLEAN;
+  BEGIN
+    WITH rT : Vector DO
+      RETURN lT.elemTp.equalType(rT.elemTp);
+    ELSE 
+      RETURN FALSE;
+    END;
+  END equalOpenOrVector;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE (lT : Pointer)equalPointers*(r : Sy.Type) : BOOLEAN;
+    VAR rT : Pointer;
+        rO : Opaque;
+  BEGIN
+    IF r IS Opaque THEN
+      rO := r(Opaque);
+      IF rO.resolved # NIL THEN r := rO.resolved END;
+    END;
+    IF ~(r IS Pointer) THEN RETURN FALSE;
+    ELSE
+      rT := r(Pointer);
+      RETURN lT.boundTp.equalType(rT.boundTp);
+    END;
+  END equalPointers;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE (i : Record)InstantiateCheck*(tok : S.Token),NEW;
+  BEGIN
+    IF i.recAtt = isAbs THEN
+      S.SemError.Report(90, tok.lin, tok.col);
+    ELSIF i.recAtt = iFace THEN
+      S.SemError.Report(131, tok.lin, tok.col);
+    ELSIF (i.recAtt = limit) & i.isImportedType() THEN
+      S.SemError.Report(71, tok.lin, tok.col);
+    ELSIF (Sy.clsTp IN i.xAttr) & (Sy.noNew IN i.xAttr) THEN
+      S.SemError.Report(155, tok.lin, tok.col);
+    END;
+  END InstantiateCheck;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE (lhsT : Procedure)procMatch*(rT : Sy.Type) : BOOLEAN;
+    VAR rhsT : Procedure;
+  BEGIN
+    IF ~(rT IS Procedure) THEN RETURN FALSE;
+    ELSE
+      rhsT := rT(Procedure);
+      IF (lhsT.retType = NIL) # (rhsT.retType = NIL) THEN RETURN FALSE END;
+      IF (lhsT.retType # NIL) &
+         ~lhsT.retType.equalType(rhsT.retType) THEN RETURN FALSE END;
+      RETURN lhsT.formsMatch(rhsT);
+    END;
+  END procMatch;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE (lhsT : Procedure)namesMatch*(rT : Sy.Type) : BOOLEAN;
+    VAR rhsT  : Procedure;
+        index : INTEGER;
+  BEGIN
+    IF ~(rT IS Procedure) THEN  RETURN FALSE;
+    ELSE
+      rhsT := rT(Procedure);
+      IF lhsT.formals.tide # rhsT.formals.tide THEN RETURN FALSE END;
+      FOR index := 0 TO lhsT.formals.tide-1 DO
+        IF lhsT.formals.a[index].hash #
+           rhsT.formals.a[index].hash THEN RETURN FALSE END;
+      END;
+      RETURN TRUE;
+    END;
+  END namesMatch;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE (lhsT : Procedure)sigsMatch*(rT : Sy.Type) : BOOLEAN;
+    VAR rhsT : Procedure;
+  BEGIN
+    IF ~(rT IS Procedure) THEN
+      RETURN FALSE;
+    ELSE
+      rhsT := rT(Procedure);
+      RETURN lhsT.formsMatch(rhsT);
+    END;
+  END sigsMatch;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE (oldT : Procedure)CheckCovariance*(newI : Sy.Idnt);
+  (* When a method is overidden, the formals must match, except *
+   * that the return type may vary covariantly with the recvr.  *)
+    VAR newT : Procedure;
+  BEGIN
+    IF newI IS Id.Procs THEN
+      newT := newI.type(Procedure);
+      IF (oldT.retType = NIL) # (newT.retType = NIL) THEN newI.IdError(116);
+      ELSIF ~newT.formsMatch(oldT) THEN
+        newI.IdError(160);
+      ELSIF (oldT.retType # NIL) & (oldT.retType # newT.retType) THEN
+        IF ~oldT.retType.isBaseOf(newT.retType) THEN
+          Sy.RepTypesErrTok(116, oldT, newT, newI.token);
+        ELSIF newI IS Id.MthId THEN
+          INCL(newI(Id.MthId).mthAtt, Id.covar);
+        END;
+      END;
+    END;
+  END CheckCovariance;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE (desc : Procedure)CheckEmptyOK*();
+    VAR idx : INTEGER;
+        frm : Id.ParId;
+  BEGIN
+    FOR idx := 0 TO desc.formals.tide - 1 DO
+      frm := desc.formals.a[idx];
+      IF frm.parMod = Sy.out THEN frm.IdError(114) END;
+    END;
+    IF desc.retType # NIL THEN desc.TypeError(115) END;
+  END CheckEmptyOK;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE (rec : Record)defBlk() : Id.BlkId, NEW;
+    VAR scp : Sy.Scope;
+  BEGIN
+    scp := NIL;
+    IF rec.idnt # NIL THEN 
+      scp := rec.idnt.dfScp;
+    ELSIF rec.bindTp # NIL THEN
+      IF rec.bindTp.idnt # NIL THEN scp := rec.bindTp.idnt.dfScp END;
+    END;
+    IF scp # NIL THEN
+      WITH scp : Id.BlkId DO RETURN scp ELSE RETURN NIL END;
+    ELSE
+      RETURN NIL;
+    END;
+  END defBlk;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE^ (recT : Record)bindField*(hash : INTEGER) : Sy.Idnt,NEW;
+
+  PROCEDURE (recT : Record)interfaceBind(hash : INTEGER) : Sy.Idnt,NEW;
+    VAR idnt : Sy.Idnt;
+        intT : Sy.Type;
+        indx : INTEGER;
+  BEGIN
+    FOR indx := 0 TO recT.interfaces.tide-1 DO
+      intT := recT.interfaces.a[indx].boundRecTp();
+      idnt := intT(Record).bindField(hash);
+      IF idnt # NIL THEN RETURN idnt END;
+    END;
+    RETURN NIL;
+  END interfaceBind;
+
+  PROCEDURE AddIndirectImport(id : Sy.Idnt);
+    VAR dBlk : Id.BlkId;
+        rTyp : Record;
+  BEGIN
+    IF id = NIL THEN RETURN END;
+   (*
+    *  This additional code checks for indirectly imported modules.
+    *  For the .NET framework references to inherited fields of
+    *  objects name the defining class.  If that class comes from
+    *  an assembly that is not explicitly imported into the CP, 
+    *  then the IL must nevertheless make an explicit reference 
+    *  to that assembly.
+    *)
+    WITH id : Id.FldId DO
+          rTyp := id.recTyp(Record);
+          dBlk := rTyp.defBlk();
+          IF Sy.weak IN rTyp.xAttr THEN
+            IF CSt.verbose THEN
+              Console.WriteString(rTyp.name());
+              Console.Write(".");
+              Console.WriteString(Sy.getName.ChPtr(id));
+              Console.WriteString(
+                        ": defining module of field imported only indirectly");
+              Console.WriteLn;
+            END;
+            INCL(dBlk.xAttr, Sy.need);
+            EXCL(rTyp.xAttr, Sy.weak);
+            Sy.AppendScope(CSt.impSeq, dBlk);
+          END;
+    | id : Id.MthId DO
+          rTyp := id.bndType(Record);
+          dBlk := rTyp.defBlk();
+          IF Sy.weak IN rTyp.xAttr THEN
+            IF CSt.verbose THEN
+              Console.WriteString(rTyp.name());
+              Console.Write(".");
+              Console.WriteString(Sy.getName.ChPtr(id));
+              Console.WriteString(
+                       ": defining module of method imported only indirectly");
+              Console.WriteLn;
+            END;
+            INCL(dBlk.xAttr, Sy.need);
+            EXCL(rTyp.xAttr, Sy.weak);
+            Sy.AppendScope(CSt.impSeq, dBlk);
+          END;
+    | id : Id.OvlId DO
+          IF (id.dfScp # NIL) & 
+             (id.dfScp IS Id.BlkId) THEN
+            dBlk := id.dfScp(Id.BlkId);
+            IF Sy.weak IN dBlk.xAttr THEN
+              IF CSt.verbose THEN
+                Console.WriteString(Sy.getName.ChPtr(dBlk));
+                Console.Write(".");
+                Console.WriteString(Sy.getName.ChPtr(id));
+                Console.WriteString(
+                        ": defining module of field imported only indirectly");
+                Console.WriteLn;
+              END;
+              INCL(dBlk.xAttr, Sy.need);
+              Sy.AppendScope(CSt.impSeq, dBlk);
+            END;
+          END;
+    ELSE (* skip *)
+    END;
+  END AddIndirectImport;
+
+  PROCEDURE (recT : Record)bindField*(hash : INTEGER) : Sy.Idnt,NEW;
+    VAR idnt : Sy.Idnt;
+        base : Sy.Type;
+  BEGIN
+    idnt := recT.symTb.lookup(hash);
+    IF (idnt = NIL) &
+       (recT.recAtt = iFace) &
+       (recT.interfaces.tide > 0) THEN idnt := recT.interfaceBind(hash);
+    END;
+    WHILE (idnt = NIL) &                (* while not found yet *)
+          (recT.baseTp # NIL) &         (* while base is known *)
+          (recT.baseTp # anyRecTp) DO   (* while base # ANYREC *)
+      base := recT.baseTp;
+      WITH base : Record DO
+        recT := base;
+        idnt := base.symTb.lookup(hash);
+      ELSE
+        recT.baseTp := base.boundRecTp();
+      END;
+    END;
+    AddIndirectImport(idnt);
+    RETURN idnt;
+  END bindField;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE (desc : Procedure)OutCheck*(v : VarSets.VarSet);
+    VAR idx : INTEGER;
+        frm : Id.ParId;
+        msg : POINTER TO FileNames.NameString;
+  BEGIN
+    msg := NIL;
+    FOR idx := 0 TO desc.formals.tide - 1 DO
+      frm := desc.formals.a[idx];
+      IF (frm.parMod = Sy.out) & ~v.includes(frm.varOrd) THEN
+        IF msg = NIL THEN
+          NEW(msg);
+          Sy.getName.Of(frm, msg);
+        ELSE
+          GPText.Assign(msg^ + "," + Sy.getName.ChPtr(frm)^, msg);
+        END;
+      END;
+    END;
+    IF msg # NIL THEN desc.TypeErrStr(139, msg) END;
+  END OutCheck;
+
+(* ============================================================ *)
+(*       Record error reporting methods   *)
+(* ============================================================ *)
+
+  PROCEDURE (ty : Record)TypeError*(n : INTEGER);
+  BEGIN
+    IF ty.bindTp # NIL THEN
+      ty.bindTp.TypeError(n);
+    ELSE
+      ty.TypeError^(n);
+    END;
+  END TypeError;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE (ty : Record)TypeErrStr*(n : INTEGER;
+          IN s : ARRAY OF CHAR);
+  BEGIN
+    IF ty.bindTp # NIL THEN
+      ty.bindTp.TypeErrStr(n,s);
+    ELSE
+      ty.TypeErrStr^(n,s);
+    END;
+  END TypeErrStr;
+
+(* ============================================================ *)
+(*      Constructor methods     *)
+(* ============================================================ *)
+
+  PROCEDURE newBasTp*() : Base;
+    VAR rslt : Base;
+  BEGIN
+    NEW(rslt);
+    rslt.SetKind(basTp);
+    RETURN rslt;
+  END newBasTp;
+
+(* ---------------------------- *)
+
+  PROCEDURE newNamTp*() : Opaque;
+    VAR rslt : Opaque;
+  BEGIN
+    NEW(rslt);
+    rslt.SetKind(namTp);
+    RETURN rslt;
+  END newNamTp;
+
+(* ---------------------------- *)
+
+  PROCEDURE newTmpTp*() : Opaque;
+    VAR rslt : Opaque;
+  BEGIN
+    NEW(rslt);
+    rslt.SetKind(tmpTp);
+    RETURN rslt;
+  END newTmpTp;
+
+(* ---------------------------- *)
+
+  PROCEDURE newArrTp*() : Array;
+    VAR rslt : Array;
+  BEGIN
+    NEW(rslt);
+    rslt.SetKind(arrTp);
+    RETURN rslt;
+  END newArrTp;
+
+  PROCEDURE mkArrayOf*(e : Sy.Type) : Array;
+    VAR rslt : Array;
+  BEGIN
+    NEW(rslt);
+    rslt.SetKind(arrTp);
+    rslt.elemTp := e;
+    RETURN rslt;
+  END mkArrayOf;
+
+(* ---------------------------- *)
+
+  PROCEDURE newVecTp*() : Vector;
+    VAR rslt : Vector;
+  BEGIN
+    NEW(rslt);
+    rslt.SetKind(vecTp);
+    RETURN rslt;
+  END newVecTp;
+
+  PROCEDURE mkVectorOf*(e : Sy.Type) : Vector;
+    VAR rslt : Vector;
+  BEGIN
+    NEW(rslt);
+    rslt.SetKind(vecTp);
+    rslt.elemTp := e;
+    RETURN rslt;
+  END mkVectorOf;
+
+(* ---------------------------- *)
+
+  PROCEDURE newRecTp*() : Record;
+    VAR rslt : Record;
+  BEGIN
+    NEW(rslt);
+    rslt.SetKind(recTp);
+    RETURN rslt;
+  END newRecTp;
+
+(* ---------------------------- *)
+
+  PROCEDURE newEnuTp*() : Enum;
+    VAR rslt : Enum;
+  BEGIN
+    NEW(rslt);
+    rslt.SetKind(enuTp);
+    RETURN rslt;
+  END newEnuTp;
+
+(* ---------------------------- *)
+
+  PROCEDURE newPtrTp*() : Pointer;
+    VAR rslt : Pointer;
+  BEGIN
+    NEW(rslt);
+    rslt.SetKind(ptrTp);
+    RETURN rslt;
+  END newPtrTp;
+
+  PROCEDURE mkPtrTo*(e : Sy.Type) : Pointer;
+    VAR rslt : Pointer;
+  BEGIN
+    NEW(rslt);
+    rslt.SetKind(ptrTp);
+    rslt.boundTp := e;
+    RETURN rslt;
+  END mkPtrTo;
+
+(* ---------------------------- *)
+
+  PROCEDURE newEvtTp*() : Procedure;
+    VAR rslt : Event;
+  BEGIN
+    NEW(rslt);
+    rslt.SetKind(evtTp);
+    rslt.bndRec := newRecTp();
+    rslt.bndRec.bindTp := rslt;
+    rslt.bndRec.baseTp := CSt.ntvEvt;
+    RETURN rslt;
+  END newEvtTp;
+
+(* ---------------------------- *)
+
+  PROCEDURE newPrcTp*() : Procedure;
+    VAR rslt : Procedure;
+  BEGIN
+    NEW(rslt);
+    rslt.SetKind(prcTp);
+    RETURN rslt;
+  END newPrcTp;
+
+(* ---------------------------- *)
+
+  PROCEDURE newOvlTp*() : Overloaded;
+    VAR rslt : Overloaded;
+  BEGIN
+    NEW(rslt);
+    rslt.SetKind(ovlTp);
+    RETURN rslt;
+  END newOvlTp;
+
+(* ============================================================ *)
+(*          Some Helper procedures      *)
+(* ============================================================ *)
+
+  PROCEDURE baseRecTp*(rec : Record) : Record;
+  VAR
+    base : Sy.Type;
+  BEGIN
+    IF (rec.baseTp = NIL) OR (rec.baseTp = anyRecTp) THEN RETURN NIL; END;
+    base := rec.baseTp;
+    WITH base : Record DO
+      RETURN base;
+    ELSE
+      RETURN base.boundRecTp()(Record);
+    END;
+  END baseRecTp;
+
+(* ---------------------------- *)
+
+  PROCEDURE newOvlIdent*(id : Sy.Idnt; rec : Record) : Id.OvlId;
+  VAR
+    oId : Id.OvlId;
+  BEGIN
+    oId := Id.newOvlId();
+    oId.type := newOvlTp();
+    oId.hash := id.hash;
+    oId.dfScp := id.dfScp;
+    oId.type.idnt := oId;
+    oId.rec := rec;
+    WITH id : Id.Procs DO
+      Id.AppendProc(oId.list,id);
+    ELSE
+      oId.fld := id;
+    END;
+    RETURN oId;
+  END newOvlIdent;
+
+(* ---------------------------- *)
+
+  PROCEDURE needOvlId*(id : Id.Procs; rec : Record) : BOOLEAN;
+  VAR
+     ident : Sy.Idnt;
+     base : Sy.Type;
+  BEGIN
+    rec := baseRecTp(rec);
+    WHILE (rec # NIL) DO
+      ident := rec.symTb.lookup(id.hash);
+      IF ident # NIL THEN
+        IF ident IS Id.OvlId THEN RETURN TRUE; END;
+        IF ident IS Id.Procs THEN
+          RETURN ~id.type(Procedure).formsMatch(ident.type(Procedure));
+        END;
+        (* allow declaration of new overloaded method *)
+      END;
+      rec := baseRecTp(rec);
+    END;
+    RETURN FALSE;
+  END needOvlId;
+
+(* ---------------------------- *)
+
+  PROCEDURE GetInheritedFeature*(hsh : INTEGER; 
+                             OUT id  : Sy.Idnt;
+                             VAR rec : Record);
+  BEGIN
+    id := rec.symTb.lookup(hsh);
+    WHILE (id = NIL) & (rec.baseTp # NIL) &
+          (rec.baseTp # anyRecTp) & (rec.baseTp # anyPtrTp) DO
+      rec := baseRecTp(rec);
+      IF rec = NIL THEN RETURN; END;
+      id := rec.symTb.lookup(hsh);
+    END;
+  END GetInheritedFeature;
+
+(* ---------------------------- *)
+
+  PROCEDURE findOverriddenProc*(proc : Id.Procs) : Id.Procs;
+  VAR
+    id : Sy.Idnt;
+    rec : Record;
+    ty : Sy.Type;
+    pId : Id.Procs;
+  BEGIN
+    ty := proc.type.boundRecTp();
+    IF ty = NIL THEN RETURN NIL; END;
+    rec := baseRecTp(ty(Record));
+    WHILE (rec # NIL) & (rec # anyRecTp) & (rec # anyPtrTp) DO
+      id := rec.symTb.lookup(proc.hash);
+      WITH id : Id.OvlId DO
+        pId := id.findProc(proc);
+        IF pId # NIL THEN RETURN pId; END;
+      | id : Id.Procs DO
+        IF proc.type.sigsMatch(id.type) THEN RETURN id; END;
+        RETURN NIL;
+      ELSE
+        RETURN NIL;
+      END;
+      IF (rec.baseTp = NIL) THEN
+        rec := NIL;
+      ELSE
+        rec := baseRecTp(rec);
+      END;
+    END;
+    RETURN NIL;
+  END findOverriddenProc;
+
+(* ---------------------------- *)
+
+  PROCEDURE AddToOvlIdent(id : Sy.Idnt; oId : Id.OvlId; doKindCheck : BOOLEAN;
+                          VAR ok : BOOLEAN);
+  BEGIN
+    ok := TRUE;
+    WITH id : Id.Procs DO
+      Id.AppendProc(oId.list,id);
+    ELSE
+      IF oId.fld = NIL THEN 
+        oId.fld := id; 
+      ELSE
+        ok := (doKindCheck & (oId.fld.kind = id.kind));
+      END;
+    END;
+  END AddToOvlIdent;
+
+(* ---------------------------- *)
+
+  PROCEDURE isBoxedStruct*(ptr : Sy.Type; dst : Sy.Type) : BOOLEAN;
+  BEGIN
+    RETURN ptr.isNativeObj() & dst.isRecordType() & ~dst.isExtnRecType();
+  END isBoxedStruct;
+
+(* ---------------------------- *)
+
+  PROCEDURE InsertInRec*(id  : Sy.Idnt; 
+                         rec : Record; 
+                         doKindCheck : BOOLEAN; 
+                     OUT oId : Id.OvlId; 
+                     OUT ok  : BOOLEAN); 
+  VAR
+    existingId : Sy.Idnt;
+    recScp : Record;
+
+  BEGIN
+    oId := NIL;
+    ok  := TRUE;
+    recScp := rec;
+    GetInheritedFeature(id.hash, existingId, recScp);
+   (*
+    *  If existingId = NIL (the usual case) all is ok.
+    *)
+    IF (Sy.isFn IN rec.xAttr) & (existingId # NIL) THEN
+     (*
+      *  This is a foreign record, so that different rules
+      *  apply.  Overloading is ok, and obscuring of 
+      *  inherited field by local fields is allowed.
+      *)
+      IF recScp = rec THEN
+       (* 
+        *  The ident is for the same scope :
+        *  - if it is a method, and has same params then ... ok,
+        *  - else this is an overload, and must be marked,
+        *  - else if this is the same kind, then ... ok,
+        *  - else this is an error.
+        *)
+        WITH existingId : Id.Procs DO
+            IF ~existingId.type.sigsMatch(id.type) THEN
+              oId := newOvlIdent(existingId,rec);
+              AddToOvlIdent(id,oId,doKindCheck,ok);
+              rec.symTb.Overwrite(oId.hash,oId);
+            END; (* and ok stays true! *)
+(*
+ *      | existingId : Id.FldId DO
+ *)
+        | existingId : Id.AbVar DO
+            oId := newOvlIdent(existingId,rec);
+            AddToOvlIdent(id,oId,doKindCheck,ok);
+            rec.symTb.Overwrite(oId.hash,oId);
+        | existingId : Id.OvlId DO
+            oId := existingId;
+            AddToOvlIdent(id,existingId,doKindCheck,ok);
+        ELSE
+         (*
+          *  Check if this is actually the same feature
+          *)
+          IF existingId.type IS Opaque THEN existingId.type := id.type;
+          ELSIF id.type IS Opaque THEN id.type := existingId.type;
+          END;
+          ok := (existingId.kind = id.kind) &
+                 existingId.type.equalType(id.type);
+        
+        END;
+      ELSE 
+       (* 
+        *  The ident is from enclosing scope : 
+        *  - if it is a field ID then ... ok,
+        *  - if it is a method, and has same params then ... ok,
+        *  - else this is an overload, and must be marked.
+        *)
+        WITH existingId : Id.FldId DO
+            ok := rec.symTb.enter(id.hash, id);
+        | existingId : Id.Procs DO
+            IF existingId.type.sigsMatch(id.type) THEN
+              ok := rec.symTb.enter(id.hash, id);
+            ELSE
+              oId := newOvlIdent(id,rec);
+              ok := rec.symTb.enter(oId.hash,oId);
+            END;
+        | existingId : Id.OvlId DO
+            oId := existingId;
+            AddToOvlIdent(id,existingId,doKindCheck,ok);
+        ELSE (* must be a field *)
+            ok := rec.symTb.enter(id.hash, id);
+        END;
+      END;
+    ELSIF ~rec.symTb.enter(id.hash, id) THEN
+      existingId := rec.symTb.lookup(id.hash);
+      ok := doKindCheck & (existingId.kind = id.kind); 
+    END;
+  END InsertInRec;
+
+(* ---------------------------- *)
+
+  PROCEDURE Error145(start : Sy.Type);
+    VAR sccTab : Sy.SccTable;
+  BEGIN
+    NEW(sccTab);
+    sccTab.target := start;
+    start.SccTab(sccTab);
+    start.TypeErrStr(145, Sy.dumpList(sccTab.symTab));
+  END Error145;
+
+(* ============================================================ *)
+(*    Implementation of Abstract methods    *)
+(* ============================================================ *)
+
+  PROCEDURE (i : Base)resolve*(d : INTEGER) : Sy.Type;
+  BEGIN RETURN i END resolve;
+
+(* ---------------------------- *)
+
+  PROCEDURE (i : Enum)resolve*(d : INTEGER) : Sy.Type;
+  BEGIN RETURN i END resolve;
+
+(* ---------------------------- *)
+
+  PROCEDURE (i : Opaque)resolve*(d : INTEGER) : Sy.Type;
+    VAR newTpId : Sy.Idnt;
+        oldTpId : Sy.Idnt;
+  BEGIN
+    IF i.depth = initialMark THEN
+     (*
+      *  If i.kind=tmpTp, this is a forward type, or
+      *  a sym-file temporary.  If we cannot resolve
+      *  this to a real type, it is an error.
+      *
+      *  If i.kind=namTp, this is a named opaque type,
+      *  we must look it up in the symTab.  If we
+      *  do not find it, the type just stays opaque.
+      *)
+      i.depth := finishMark;
+      oldTpId := i.idnt;
+      newTpId := oldTpId.dfScp.symTb.lookup(oldTpId.hash);
+      IF newTpId = NIL THEN
+        oldTpId.IdError(2);
+      ELSIF newTpId.kind # Id.typId THEN
+        oldTpId.IdError(5);
+      ELSIF newTpId.type # NIL THEN
+       (*
+        *   This particular method might recurse, even for
+        *   correct programs, such as
+        * TYPE A = POINTER TO B;
+        * TYPE B = RECORD c : C END;
+        * TYPE C = RECORD(A) ... END;
+        *   Thus we must not recurse until we have set the
+        *   resolved field, since we have now set the depth
+        *   mark and will not reenter the binding code again.
+        *)
+        i.resolved := newTpId.type;
+        i.resolved := newTpId.type.resolve(d);  (* Recurse! *)
+        IF i.kind = tmpTp THEN
+          IF i.resolved = i THEN oldTpId.IdError(125) END;
+        ELSIF i.kind = namTp THEN
+          IF (i.resolved = NIL) OR
+             (i.resolved.kind = namTp) THEN i.resolved := i END;
+        END;
+      END;
+    END;
+    RETURN i.resolved;
+  END resolve;
+
+(* ---------------------------- *)
+
+  PROCEDURE (i : Array)resolve*(d : INTEGER) : Sy.Type, EXTENSIBLE;
+    VAR e137,e145 : BOOLEAN;
+  BEGIN
+    IF i.depth = initialMark THEN
+      e145 := FALSE;
+      e137 := FALSE;
+      i.depth := d;
+      IF i.elemTp # NIL THEN i.elemTp := i.elemTp.resolve(d) END;
+      IF (i.length # 0) &
+         (i.elemTp # NIL) &
+          i.elemTp.isOpenArrType() THEN
+        i.TypeError(69);
+      END;
+      IF i.depth = errorMark THEN
+        IF i.elemTp = i THEN e137 := TRUE ELSE e145 := TRUE END;
+        i.TypeError(126);
+      END;
+      i.depth := finishMark;
+      IF    e145 THEN Error145(i);
+      ELSIF e137 THEN i.TypeError(137);
+      END;
+    ELSIF i.depth = d THEN (* recursion through value types *)
+      i.depth := errorMark;
+    END;
+    RETURN i;
+  END resolve;
+
+(* ---------------------------- *)
+
+  PROCEDURE (i : Vector)resolve*(d : INTEGER) : Sy.Type;
+    VAR e137,e145 : BOOLEAN;
+  BEGIN
+    IF i.depth = initialMark THEN
+      IF i.elemTp # NIL THEN i.elemTp := i.elemTp.resolve(d) END;
+      i.depth := finishMark;
+    END;
+    RETURN i;
+  END resolve;
+
+(* ---------------------------- *)
+
+  PROCEDURE (x: Record)CopyFieldsOf(b : Sy.Type),NEW; (* final *)
+    VAR bRecT : Record;
+        nextF : Sy.Idnt;
+        index : INTEGER;
+  BEGIN
+    IF (b # anyRecTp) & (b.depth # errorMark) THEN
+      bRecT := b.boundRecTp()(Record);
+     (*
+      *   First get the fields of the higher ancestors.
+      *)
+      IF bRecT.baseTp # NIL THEN x.CopyFieldsOf(bRecT.baseTp) END;
+     (*
+      *   Now add the fields of the immediate base type
+      *)
+      FOR index := 0 TO bRecT.fields.tide-1 DO
+        nextF := bRecT.fields.a[index];
+        IF ~x.symTb.enter(nextF.hash, nextF) & ~(Sy.isFn IN bRecT.xAttr) THEN
+          x.symTb.lookup(nextF.hash).IdError(82);
+        END;
+      END;
+    END;
+  END CopyFieldsOf;
+
+(* ---------------------------- *)
+
+  PROCEDURE (i : Record)resolve*(d : INTEGER) : Sy.Type;
+  (** Resolve this type, and any used in this type *)
+    VAR baseT : Record;
+        field : Sy.Idnt;
+        index : INTEGER;
+        hashN : INTEGER;
+        nameS : Lv.CharOpen;
+        ident : Sy.Idnt;
+        intId : Sy.Idnt;
+        intTp : Sy.Type;
+        recId : Sy.Idnt;
+        dBlk  : Id.BlkId;
+        e137,e145 : BOOLEAN;
+   (* ----------------------------------------- *)
+    PROCEDURE refInNET(t : Sy.Type) : BOOLEAN;
+     (*
+      *  This predicate is used for the .NET
+      *  platform, to set the "clsTp" attribute.
+      *  It implies that this type will have a
+      *  reference representation in .NET
+      *)
+    BEGIN
+      IF t = NIL THEN
+          RETURN FALSE;     (* Actually we don't care here. *)
+      ELSE 
+        WITH t : Record DO
+          RETURN Sy.clsTp IN t.xAttr;
+        | t : Array DO
+          RETURN TRUE;      (* arrays are references in NET *)
+        | t : Event DO
+          RETURN TRUE;      (* events are references in NET *)
+        ELSE RETURN FALSE;  (* all others are value types.  *)
+        END;
+      END;
+    END refInNET;
+   (* ----------------------------------------- *)
+  BEGIN (* resolve *)
+    IF i.depth = initialMark THEN
+(*
+ *    IF i.idnt # NIL THEN
+ *      recId := i.idnt;
+ *      nameS := Sy.getName.ChPtr(recId);
+ *    END;
+ *)
+      i.depth := d;
+      e145 := FALSE;
+      e137 := FALSE;
+     (*
+      *  First: resolve the base type, if any,
+      *  or set the base type to the type ANYREC.
+      *)
+      baseT := NIL;
+      IF i.baseTp = NIL THEN
+        i.baseTp := anyRecTp;
+      ELSIF i.baseTp = anyPtrTp THEN
+        i.baseTp := anyRecTp;
+     (*
+      *  Special case of baseTp of POINTER TO RTS.NativeObject ...
+      *)
+      ELSIF i.baseTp.isNativeObj() THEN
+        IF i.baseTp IS Pointer THEN i.baseTp := i.baseTp.boundRecTp() END;
+      ELSE (* the normal case *)
+        i.baseTp := i.baseTp.resolve(d);
+       (*
+        *  There is a special case here. If the base type
+        *  is an unresolved opaque from an unimported module
+        *  then leave well alone.
+        *)
+        IF i.baseTp # NIL THEN
+          IF i.baseTp IS Opaque THEN 
+            i.baseTp := anyRecTp;
+          ELSE 
+            i.baseTp := i.baseTp.boundRecTp();
+            IF i.baseTp IS Record THEN baseT := i.baseTp(Record) END;
+            IF i.baseTp = NIL THEN i.TypeError(14) END; (* not rec or ptr *)
+            IF i.depth = errorMark THEN
+              IF i.baseTp = i THEN e137 := TRUE ELSE e145 := TRUE END;
+              i.TypeError(123);
+            END;
+          END;
+        END;
+        IF baseT # NIL THEN
+         (*
+          *  Base is resolved, now check some semantic constraints.
+          *)
+          IF (isAbs = i.recAtt) &
+             ~baseT.isAbsRecType() &
+             ~(Sy.isFn IN baseT.xAttr) THEN
+            i.TypeError(102); (* abstract record must have abstract base *)
+          ELSIF baseT.isExtnRecType() THEN
+            i.CopyFieldsOf(baseT);
+            IF Sy.noNew IN baseT.xAttr THEN INCL(i.xAttr, Sy.noNew) END;
+(* ----- Code for extensible limited records ----- *)
+          ELSIF baseT.isLimRecType() THEN
+            IF ~i.isLimRecType() THEN
+              i.TypeError(234); (* abstract record must have abstract base *)
+            ELSIF i.isImportedType() # baseT.isImportedType() THEN
+              i.TypeError(235); (* abstract record must have abstract base *)
+            END;
+(* --- End code for extensible limited records --- *)
+          ELSIF baseT.isInterfaceType() THEN
+            i.TypeErrStr(154, baseT.name()); (* cannot extend interfaces *)
+          ELSE
+            i.TypeError(16);  (* base type is not an extensible record   *)
+          END;
+          IF (iFace = i.recAtt) &
+             ~baseT.isNativeObj() THEN i.TypeError(156) END;
+         (*
+          *  Propagate no-block-copy attribute to extensions.
+          *  Note the special case here: in .NET extensions 
+          *  of System.ValueType may be copied freely.
+          *)
+          IF (Sy.noCpy IN baseT.xAttr) &
+             (baseT # CSt.ntvVal) THEN INCL(i.xAttr, Sy.noCpy) END;
+        END;
+      END;
+     (*
+      *   Interface types must be exported.
+      *)
+      IF i.recAtt = iFace THEN
+        IF i.idnt # NIL THEN
+          IF i.idnt.vMod = Sy.prvMode THEN i.TypeError(215) END;
+        ELSIF (i.bindTp # NIL) & (i.bindTp.idnt # NIL) THEN
+          IF i.bindTp.idnt.vMod = Sy.prvMode THEN i.TypeError(215) END;
+        ELSE
+          i.TypeError(214);
+        END;
+      END;
+     (*
+      *   Now check semantics of interface implementation.
+      *)
+      IF (i.interfaces.tide > 0) & (baseT # NIL) THEN
+(*
+ *      (* Use this code to allow only direct foreign types. *)
+ *      IF ~(Sy.isFn IN baseT.xAttr) &
+ *         ~i.isImportedType() THEN i.TypeErrStr(157, baseT.name()) END;
+ *)
+
+(*
+ *      (* Use this code to allow only extensions of foreign types. *)
+ *      IF ~(Sy.noCpy IN baseT.xAttr) &
+ *         ~i.isImportedType() THEN i.TypeErrStr(157, baseT.name()) END;
+ *)
+        (* Remove both to allow all code to define interfaces *)
+
+        FOR index := 0 TO i.interfaces.tide-1 DO
+          intTp := i.interfaces.a[index].resolve(d);
+          IF intTp # NIL THEN
+            intTp := intTp.boundRecTp();
+            IF (intTp # NIL) &
+               ~intTp.isInterfaceType() THEN
+              i.TypeErrStr(158, intTp.name());
+            END;
+          END;
+        END;
+      END;
+      i.depth := d;
+     (*
+      *  Next: set basis of no-block-copy flag
+      *)
+      IF (Sy.isFn IN i.xAttr) &
+         (Sy.clsTp IN i.xAttr) THEN INCL(i.xAttr, Sy.noCpy);
+      END;
+     (*
+      *  Next: resolve all field types.
+      *)
+      FOR index := 0 TO i.fields.tide-1 DO
+        field := i.fields.a[index];
+        IF field.type # NIL THEN field.type := field.type.resolve(d) END;
+        IF i.depth = errorMark THEN
+          IF field.type = i THEN e137 := TRUE ELSE e145 := TRUE END;
+          field.IdError(124);
+          i.depth := d;
+        END;
+        IF refInNET(field.type) THEN INCL(i.xAttr,Sy.clsTp) END;
+        IF field.type IS Event THEN Sy.AppendIdnt(i.events, field) END;
+      END;
+
+     (*
+      *  Next: resolve all method types.       NEW!
+      *)
+      FOR index := 0 TO i.methods.tide-1 DO
+        field := i.methods.a[index];
+        IF field.type # NIL THEN field.type := field.type.resolve(d) END;
+      END;
+
+     (*
+      *  Next: resolve types of all static members.
+      *)
+      FOR index := 0 TO i.statics.tide-1 DO
+        field := i.statics.a[index];
+        IF field.type # NIL THEN field.type := field.type.resolve(d) END;
+      END;
+
+      i.depth := finishMark;
+      IF    e145 THEN Error145(i);
+      ELSIF e137 THEN i.TypeError(137);
+      END;
+    ELSIF i.depth = d THEN (* recursion through value types *)
+      i.depth := errorMark;
+    END;
+   (* ##### *)
+    dBlk := i.defBlk();
+    IF (dBlk # NIL) & (Sy.weak IN dBlk.xAttr) THEN INCL(i.xAttr, Sy.weak) END;
+   (* ##### *)
+    RETURN i;
+  END resolve;
+
+(* ---------------------------- *)
+
+  PROCEDURE (i : Record)FixDefScope*(s : Sy.Scope),NEW;
+    VAR idx : INTEGER;
+        idD : Sy.Idnt;
+  BEGIN
+    FOR idx := 0 TO i.methods.tide-1 DO
+      idD := i.methods.a[idx];
+      IF idD.dfScp # s THEN
+        idD.dfScp := s;
+        IF CSt.verbose THEN
+           Console.WriteString("Fixing method module:");
+           Console.WriteString(Sy.getName.ChPtr(idD));
+           Console.WriteLn;
+        END;
+      ELSE
+        RETURN
+      END;
+    END;
+    FOR idx := 0 TO i.statics.tide-1 DO
+      idD := i.statics.a[idx];
+      IF idD.dfScp # s THEN
+        idD.dfScp := s;
+        IF CSt.verbose THEN
+          Console.WriteString("Fixing static module:");
+          Console.WriteString(Sy.getName.ChPtr(idD));
+          Console.WriteLn;
+        END;
+      ELSE
+        RETURN
+      END;
+    END;
+  END FixDefScope;
+
+(* ---------------------------- *)
+
+  PROCEDURE (i : Pointer)resolve*(d : INTEGER) : Sy.Type;
+    VAR bndT : Sy.Type;
+  BEGIN
+    IF i.depth = initialMark THEN
+      i.depth := d;
+      bndT := i.boundTp;
+      IF (bndT # NIL) &           (*==> bound type is OK  *)
+         (bndT.idnt = NIL) THEN   (*==> anon. bound type  *)
+        WITH bndT : Record DO
+          IF bndT.bindTp = NIL THEN
+            INCL(bndT.xAttr, Sy.clsTp);
+            INCL(bndT.xAttr, Sy.anon);
+            IF i.idnt # NIL THEN    (*==> named ptr type  *)
+             (*
+              *  The anon record should have the same name as the
+              *  pointer type.  The record is marked so that the
+              *  synthetic name <ptrName>"^" can be derived.
+              *  The visibility mode is the same as the pointer.
+              *)
+              bndT.bindTp := i;
+            END;
+          END;
+          IF bndT.isForeign() THEN bndT.FixDefScope(i.idnt.dfScp) END;
+        ELSE (* skip pointers to arrays *)
+        END;
+      END;
+      IF bndT # NIL THEN 
+        i.boundTp := bndT.resolve(d+1);
+        IF (i.boundTp # NIL) &
+           ~(i.boundTp IS Array) &
+           ~(i.boundTp IS Record) THEN i.TypeError(140) END;
+      END;
+      i.depth := finishMark;
+    END;
+    RETURN i;
+  END resolve;
+
+(* ---------------------------- *)
+
+  PROCEDURE (i : Procedure)resolve*(d : INTEGER) : Sy.Type;
+    VAR idx : INTEGER;
+        frm : Sy.Idnt;
+  BEGIN
+    IF i.depth = initialMark THEN
+      i.depth := d;
+      FOR idx := 0 TO i.formals.tide-1 DO
+        frm := i.formals.a[idx];
+        IF frm.type # NIL THEN frm.type := frm.type.resolve(d+1) END;
+      END;
+
+      IF i.retType # NIL THEN i.retType := i.retType.resolve(d+1) END;
+      i.depth := finishMark;
+    END;
+    RETURN i
+  END resolve;
+
+(* ---------------------------- *)
+
+  PROCEDURE (i : Overloaded)resolve*(d : INTEGER) : Sy.Type;
+  BEGIN
+    ASSERT(FALSE);
+    RETURN NIL;
+  END resolve;
+
+(* ---------------------------- *)
+
+  PROCEDURE (i : Opaque)elaboration*() : Sy.Type;
+  BEGIN
+    IF i.resolved # NIL THEN RETURN i.resolved ELSE RETURN i END;
+  END elaboration;
+
+(* ============================================================ *)
+
+  PROCEDURE (i : Base)TypeErase*() : Sy.Type;
+  BEGIN RETURN i END TypeErase;
+
+(* ---------------------------- *)
+
+  PROCEDURE (i : Enum)TypeErase*() : Sy.Type;
+  BEGIN RETURN i END TypeErase;
+
+(* ---------------------------- *)
+
+  PROCEDURE (i : Opaque)TypeErase*() : Sy.Type;
+  BEGIN RETURN i END TypeErase;
+
+(* ---------------------------- *)
+
+  PROCEDURE (i : Array)TypeErase*() : Sy.Type;
+  BEGIN RETURN i END TypeErase;
+
+(* ---------------------------- *)
+
+  PROCEDURE (i : Record)TypeErase*() : Sy.Type;
+  (* If the Record type is a compound type, return
+   * its implementation type, otherwise erase the types
+   * from the fields and methods of the record *)
+    VAR
+      index : INTEGER;
+      id    : Sy.Idnt;
+    BEGIN
+      IF i.isCompoundType() THEN
+        RETURN i.ImplementationType();
+      END;
+
+      (* Process the fields *)
+      FOR index := 0 TO i.fields.tide-1 DO
+        id := i.fields.a[index];
+        IF id.type # NIL THEN
+          i.fields.a[index].type := id.type.TypeErase();
+        END;
+      END;
+
+      (* Process the methods *)
+      FOR index := 0 TO i.methods.tide-1 DO
+        id := i.methods.a[index];
+        IF id.type # NIL THEN
+          i.methods.a[index].type := id.type.TypeErase();
+        END;
+      END;
+
+      RETURN i;
+  END TypeErase;
+
+(* ---------------------------- *)
+
+  PROCEDURE (i : Pointer)TypeErase*() : Sy.Type;
+    (* Erase the bound type *)
+    VAR bndT : Sy.Type;
+  BEGIN
+    bndT := i.boundTp;
+    IF (bndT # NIL) THEN
+      i.boundTp := bndT.TypeErase();
+    END;
+    RETURN i;
+  END TypeErase;
+
+(* ---------------------------- *)
+
+  PROCEDURE (i : Procedure)TypeErase*() : Sy.Type;
+  (* Erase the types of the formals *)
+    VAR
+      index : INTEGER;
+      id    : Sy.Idnt;
+    BEGIN
+      (* Process the fields *)
+      FOR index := 0 TO i.formals.tide-1 DO
+        id := i.formals.a[index];
+        IF id.type # NIL THEN
+          i.formals.a[index].type := id.type.TypeErase();
+        END;
+      END;
+    RETURN i
+  END TypeErase;
+
+(* ---------------------------- *)
+
+  PROCEDURE (i : Overloaded)TypeErase*() : Sy.Type;
+  BEGIN RETURN i END TypeErase;
+
+(* ============================================================ *)
+
+  PROCEDURE Insert(VAR s : Sy.SymbolTable; t : Sy.Type);
+    VAR junk : BOOLEAN;
+  BEGIN
+    IF t.idnt # NIL THEN junk := s.enter(t.idnt.hash, t.idnt) END;
+  END Insert;
+
+(* ---------------------------------------------------- *)
+
+  PROCEDURE (i : Array)SccTab*(t : Sy.SccTable);
+  BEGIN
+    i.depth := initialMark;
+    t.reached := FALSE;
+    IF i.elemTp # NIL THEN
+      IF i.elemTp = t.target THEN
+        t.reached := TRUE;
+      ELSIF i.elemTp.depth # initialMark THEN
+        t.reached := FALSE;
+        i.elemTp.SccTab(t);
+      END;
+      IF t.reached THEN Insert(t.symTab, i) END;
+    END;
+    i.depth := finishMark;
+  END SccTab;
+
+(* ---------------------------------------------------- *)
+
+  PROCEDURE (i : Record)SccTab*(t : Sy.SccTable);
+    VAR index : INTEGER;
+        found : BOOLEAN;
+        field : Sy.Idnt;
+        fldTp : Sy.Type;
+  BEGIN
+    i.depth := initialMark;
+    found := FALSE;
+    IF i.baseTp # NIL THEN
+      fldTp := i.baseTp;
+      IF fldTp = t.target THEN
+        t.reached := TRUE;
+      ELSIF fldTp.depth # initialMark THEN
+        t.reached := FALSE;
+        fldTp.SccTab(t);
+      END;
+      IF t.reached THEN found := TRUE END;
+    END;
+    FOR index := 0 TO i.fields.tide-1 DO
+      field := i.fields.a[index];
+      fldTp := field.type;
+      IF fldTp # NIL THEN
+        IF fldTp = t.target THEN
+          t.reached := TRUE;
+        ELSIF fldTp.depth # initialMark THEN
+          t.reached := FALSE;
+          fldTp.SccTab(t);
+        END;
+        IF t.reached THEN found := TRUE END;
+      END;
+    END;
+    IF found THEN Insert(t.symTab, i); t.reached := TRUE END;
+    i.depth := finishMark;
+  END SccTab;
+
+(* ---------------------------------------------------- *)
+
+  PROCEDURE (i : Base)SccTab*(t : Sy.SccTable);
+  BEGIN (* skip *) END SccTab;
+
+(* ---------------------------------------------------- *)
+
+  PROCEDURE (i : Opaque)SccTab*(t : Sy.SccTable);
+  BEGIN (* skip *) END SccTab;
+
+(* ---------------------------------------------------- *)
+
+  PROCEDURE (i : Pointer)SccTab*(t : Sy.SccTable);
+  BEGIN (* skip *) END SccTab;
+
+(* ---------------------------------------------------- *)
+
+  PROCEDURE (i : Enum)SccTab*(t : Sy.SccTable);
+  BEGIN (* skip *) END SccTab;
+
+(* ---------------------------------------------------- *)
+
+  PROCEDURE (i : Procedure)SccTab*(t : Sy.SccTable);
+  BEGIN (* skip *) END SccTab;
+
+(* ---------------------------------------------------- *)
+
+  PROCEDURE (i : Overloaded)SccTab*(t : Sy.SccTable);
+  BEGIN ASSERT(FALSE); END SccTab;
+
+(* ============================================================ *)
+
+  PROCEDURE update*(IN a : Sy.TypeSeq; t : Sy.Type) : Sy.Type;
+  BEGIN
+    IF t.dump-Sy.tOffset >= a.tide THEN
+      Console.WriteInt(t.dump,0);
+      Console.WriteInt(a.tide+Sy.tOffset,0);
+      Console.WriteLn;
+    END;
+    IF t.kind = tmpTp THEN RETURN a.a[t.dump - Sy.tOffset] ELSE RETURN t END;
+  END update;
+
+(* ============================================================ *)
+
+  PROCEDURE (t : Base)TypeFix*(IN a : Sy.TypeSeq);
+  BEGIN END TypeFix;
+
+(* ---------------------------- *)
+
+  PROCEDURE (t : Enum)TypeFix*(IN a : Sy.TypeSeq);
+  BEGIN END TypeFix;
+
+(* ---------------------------- *)
+
+  PROCEDURE (t : Opaque)TypeFix*(IN a : Sy.TypeSeq);
+  BEGIN END TypeFix;
+
+(* ---------------------------- *)
+
+  PROCEDURE (t : Array)TypeFix*(IN a : Sy.TypeSeq);
+  BEGIN
+    t.elemTp := update(a, t.elemTp);
+  END TypeFix;
+
+(* ---------------------------- *)
+
+  PROCEDURE (t : Record)TypeFix*(IN a : Sy.TypeSeq);
+    VAR i : INTEGER;
+        f : Sy.Idnt;
+        m : Id.MthId;
+        b : Sy.Type;
+  BEGIN
+    IF t.baseTp # NIL THEN
+      IF t.baseTp IS Pointer THEN t.baseTp := t.baseTp.boundRecTp() END;
+      t.baseTp := update(a, t.baseTp);
+    END;
+    FOR i := 0 TO t.interfaces.tide - 1 DO
+      b := t.interfaces.a[i];
+      t.interfaces.a[i] := update(a, b);
+    END;
+    FOR i := 0 TO t.fields.tide - 1 DO
+      f := t.fields.a[i];
+      f.type := update(a, f.type);
+    END;
+    FOR i := 0 TO t.methods.tide - 1 DO
+      f := t.methods.a[i];
+      m := f(Id.MthId);
+      m.bndType := update(a, m.bndType);
+      b := update(a, m.rcvFrm.type);
+      m.rcvFrm.type := b;
+      f.type.TypeFix(a);  (* recurse to param-types etc.  *)
+    END;
+    FOR i := 0 TO t.statics.tide - 1 DO
+      f := t.statics.a[i];
+      f.type := update(a, f.type);
+      IF f.type IS Procedure THEN f.type.TypeFix(a) END;
+    END;
+  END TypeFix;
+
+(* ---------------------------- *)
+
+  PROCEDURE (t : Pointer)TypeFix*(IN a : Sy.TypeSeq);
+    VAR bndT : Sy.Type;
+  BEGIN
+    bndT := update(a, t.boundTp);
+    t.boundTp := bndT;
+    IF  bndT.idnt = NIL THEN
+      WITH bndT : Record DO
+        INCL(bndT.xAttr, Sy.clsTp);
+        INCL(bndT.xAttr, Sy.anon);
+        IF bndT.bindTp = NIL THEN bndT.bindTp := t END;
+      ELSE (* ptr to array : skip *)
+      END;
+    END;
+  END TypeFix;
+
+(* ---------------------------- *)
+
+  PROCEDURE (t : Procedure)TypeFix*(IN a : Sy.TypeSeq);
+    VAR i : INTEGER;
+        f : Id.ParId;
+  BEGIN
+    IF t.retType # NIL  THEN t.retType := update(a, t.retType) END;
+    IF t.receiver # NIL THEN t.receiver := update(a, t.receiver) END;
+    FOR i := 0 TO t.formals.tide - 1 DO
+      f := t.formals.a[i];
+      f.type := update(a, f.type);
+    END;
+  END TypeFix;
+
+(* ---------------------------- *)
+
+  PROCEDURE (t : Overloaded)TypeFix*(IN a : Sy.TypeSeq);
+  BEGIN
+    ASSERT(FALSE);
+  END TypeFix;
+
+(* ============================================================ *)
+(*  A type is "forced", i.e. must have its type     *)
+(*  structure emitted to the symbol file if it is any of ...  *)
+(*  i   : a local type with an exported TypId,    *)
+(*  ii  : an imported type with an exported local alias,  *)
+(*  iii : the base-type of a forced record,     *)
+(*      iv  : a type with value semantics.      *)
+(*  Partly forced types have structure but not methods emitted. *)
+(* ============================================================ *)
+
+  PROCEDURE MarkModule(ty : Sy.Type);
+  BEGIN
+    IF (ty.idnt # NIL) & (ty.idnt.dfScp # NIL) THEN
+      INCL(ty.idnt.dfScp(Id.BlkId).xAttr, Sy.need);
+    END;
+  END MarkModule;
+
+(* ---------------------------- *)
+
+  PROCEDURE (i : Base)ConditionalMark*();
+  BEGIN END ConditionalMark;
+
+(* ---------------------------- *)
+
+  PROCEDURE (i : Enum)ConditionalMark*();
+  BEGIN END ConditionalMark;
+
+(* ---------------------------- *)
+
+  PROCEDURE (i : Opaque)ConditionalMark*();
+  BEGIN
+    MarkModule(i);
+  END ConditionalMark;
+
+(* ---------------------------- *)
+
+  PROCEDURE (i : Pointer)ConditionalMark*();
+  BEGIN
+    IF i.force = Sy.noEmit THEN
+      IF ~i.isImportedType() THEN
+        i.force := Sy.forced;
+        i.boundTp.ConditionalMark();
+      ELSE
+        MarkModule(i);
+      END;
+    END;
+  END ConditionalMark;
+
+(* ---------------------------- *)
+
+  PROCEDURE (i : Record)ConditionalMark*();
+    VAR idx : INTEGER;
+        fTp : Sy.Type;
+   (* ---------------------------- *)
+    PROCEDURE blockOf(r : Record) : Id.BlkId;
+    BEGIN
+      IF r.bindTp # NIL THEN
+        RETURN r.bindTp.idnt.dfScp(Id.BlkId);
+      ELSE
+        RETURN r.idnt.dfScp(Id.BlkId);
+      END;
+    END blockOf;
+   (* ---------------------------- *)
+    PROCEDURE ForceInterfaces(r : Record);
+      VAR i : INTEGER;
+          p : Sy.Type;
+    BEGIN
+      FOR i := 0 TO r.interfaces.tide-1 DO
+        p := r.interfaces.a[i];
+        p.force := Sy.forced;
+(*
+ *      WITH p : Pointer DO p.boundTp.force := Sy.forced END;
+ *)
+        WITH p : Pointer DO p.boundTp.force := Sy.forced ELSE END;
+      END;
+    END ForceInterfaces;
+   (* ---------------------------- *)
+  BEGIN
+    IF (i.force = Sy.noEmit) THEN
+      IF i.isImportedType() THEN
+        i.force := Sy.partEmit;
+(*
+ *      IF ~CSt.special THEN i.force := Sy.partEmit END;
+ *)
+        INCL(blockOf(i).xAttr, Sy.need);
+        IF i.bindTp # NIL THEN i.bindTp.ConditionalMark() END;
+        IF (i.baseTp # NIL) &
+           ~(i.baseTp IS Base) THEN i.baseTp.ConditionalMark() END;
+      ELSE
+        i.force := Sy.forced;
+        IF i.bindTp # NIL THEN i.bindTp.UnconditionalMark() END;
+
+        IF (i.baseTp # NIL) & ~(i.baseTp IS Base) THEN 
+          i.baseTp.UnconditionalMark();
+(*
+ *        IF CSt.special THEN
+ *          i.baseTp.ConditionalMark();
+ *        ELSE
+ *          i.baseTp.UnconditionalMark();
+ *        END;
+ *)
+        END;
+
+(*
+        IF (i.baseTp # NIL) &
+           ~(i.baseTp IS Base) THEN i.baseTp.UnconditionalMark() END;
+ *)
+        IF (i.interfaces.tide > 0) &
+            i.isInterfaceType() THEN ForceInterfaces(i) END;
+      END;
+      FOR idx := 0 TO i.fields.tide-1 DO
+        fTp := i.fields.a[idx].type;
+        fTp.ConditionalMark();
+      END;
+    END;
+  END ConditionalMark;
+
+(* ---------------------------- *)
+
+  PROCEDURE (i : Array)ConditionalMark*();
+  BEGIN
+    IF (i.force = Sy.noEmit) THEN
+      IF i.isImportedType() THEN
+        INCL(i.idnt.dfScp(Id.BlkId).xAttr, Sy.need);
+      ELSE
+        i.force := Sy.forced;
+        i.elemTp.ConditionalMark();
+      END;
+    END;
+  END ConditionalMark;
+
+(* ---------------------------- *)
+
+  PROCEDURE (i : Procedure)ConditionalMark*();
+  BEGIN
+  END ConditionalMark;
+
+(* ---------------------------- *)
+
+  PROCEDURE (i : Overloaded)ConditionalMark*();
+  BEGIN
+    ASSERT(FALSE);
+  END ConditionalMark;
+
+(* ============================================================ *)
+(*   Rules for unconditional marking don't care about imports.  *)
+(* ============================================================ *)
+
+  PROCEDURE (i : Base)UnconditionalMark*();
+  BEGIN END UnconditionalMark;
+
+(* ---------------------------- *)
+
+  PROCEDURE (i : Opaque)UnconditionalMark*();
+  BEGIN
+    MarkModule(i);
+  END UnconditionalMark;
+
+(* ---------------------------- *)
+
+  PROCEDURE (i : Enum)UnconditionalMark*();
+  BEGIN
+    MarkModule(i);
+  END UnconditionalMark;
+
+(* ---------------------------- *)
+
+  PROCEDURE (i : Pointer)UnconditionalMark*();
+  BEGIN
+    i.boundTp.ConditionalMark();
+    IF (i.force # Sy.forced) THEN
+      i.force := Sy.forced;
+      i.boundTp.ConditionalMark();
+      MarkModule(i);
+    END;
+  END UnconditionalMark;
+
+(* ---------------------------- *)
+
+  PROCEDURE (i : Record)UnconditionalMark*();
+    VAR idx : INTEGER;
+        fTp : Sy.Type;
+  BEGIN
+    IF (i.force # Sy.forced) THEN
+      i.force := Sy.forced;
+      IF i.baseTp # NIL THEN i.baseTp.UnconditionalMark() END;
+      IF i.bindTp # NIL THEN i.bindTp.UnconditionalMark() END;
+      FOR idx := 0 TO i.fields.tide-1 DO
+        fTp := i.fields.a[idx].type;
+        fTp.ConditionalMark();
+      END;
+      MarkModule(i);
+    END;
+  END UnconditionalMark;
+
+(* ---------------------------- *)
+
+  PROCEDURE (i : Array)UnconditionalMark*();
+  BEGIN
+    IF (i.force # Sy.forced) THEN
+      i.force := Sy.forced;
+      i.elemTp.ConditionalMark();
+      MarkModule(i);
+    END;
+  END UnconditionalMark;
+
+(* ---------------------------- *)
+
+  PROCEDURE (i : Procedure)UnconditionalMark*();
+  BEGIN
+  END UnconditionalMark;
+
+(* ---------------------------- *)
+
+  PROCEDURE (i : Overloaded)UnconditionalMark*();
+  BEGIN
+    ASSERT(FALSE);
+  END UnconditionalMark;
+
+(* ============================================================ *)
+
+  PROCEDURE (i : Pointer)superType*() : Sy.Type;
+  BEGIN
+    IF i.boundTp = NIL THEN RETURN NIL ELSE RETURN i.boundTp.superType() END;
+  END superType;
+
+(* ---------------------------- *)
+
+  PROCEDURE (i : Record)superType*() : Record;
+    VAR valRec : BOOLEAN;
+        baseT  : Sy.Type;
+        baseR  : Record;
+  BEGIN
+    valRec := ~(Sy.clsTp IN i.xAttr);
+    baseR := NIL;
+    baseT := i.baseTp;
+    IF valRec THEN
+      baseR := CSt.ntvVal(Record);
+    ELSIF ~baseT.isNativeObj() THEN
+      WITH baseT : Record DO
+        baseR := baseT;
+      ELSE (* skip *)
+      END;
+    END; 
+    RETURN baseR;
+  END superType;
+
+(* ---------------------------- *)
+
+  PROCEDURE (i : Procedure)superType*() : Sy.Type;
+  BEGIN
+    RETURN NIL (* for the moment *)
+  END superType;
+
+(* ============================================================ *)
+
+  PROCEDURE (i : Pointer)boundRecTp*() : Sy.Type;
+  BEGIN
+    IF i.boundTp = NIL THEN RETURN NIL ELSE RETURN i.boundTp.boundRecTp() END;
+  END boundRecTp;
+
+(* ---------------------------- *)
+
+  PROCEDURE (i : Record)boundRecTp*() : Sy.Type;
+  BEGIN
+    RETURN i;
+  END boundRecTp;
+
+(* ---------------------------- *)
+
+  PROCEDURE (i : Event)boundRecTp*() : Sy.Type;
+  BEGIN
+    RETURN i.bndRec;
+  END boundRecTp;
+
+(* ---------------------------- *)
+
+  PROCEDURE (i : Opaque)boundRecTp*() : Sy.Type;
+  BEGIN
+    IF (i.resolved = NIL) OR
+       (i.resolved IS Opaque) THEN
+      RETURN NIL;
+    ELSE
+      RETURN i.resolved.boundRecTp();
+    END;
+  END boundRecTp;
+
+(* ============================================================ *)
+
+  PROCEDURE (rec : Record)InsertMethod*(m : Sy.Idnt);
+    VAR fwd : Sy.Idnt;
+        mth : Id.MthId;
+        ovl : Id.OvlId;
+  BEGIN
+    mth := m(Id.MthId);
+    IF ~rec.symTb.enter(m.hash, m) THEN (* refused *)
+      fwd := rec.symTb.lookup(m.hash);
+      IF fwd IS Id.OvlId THEN
+        ovl := fwd(Id.OvlId);
+        fwd := ovl.findProc(mth);
+        IF fwd = NIL THEN fwd := ovl; END;
+      END;
+      IF fwd.kind = Id.fwdMth THEN
+        mth.CheckElab(fwd);
+        rec.symTb.Overwrite(m.hash, m);
+      ELSIF fwd.kind = Id.fwdPrc THEN
+        fwd.IdError(63);
+      ELSIF fwd IS Id.OvlId THEN
+        ovl := fwd(Id.OvlId);
+        (* currently disallow declaration of new overloaded method *)
+        (* for name which is already overloaded *)
+        fwd := findOverriddenProc(mth);
+        IF fwd # NIL THEN
+          Id.AppendProc(fwd(Id.OvlId).list,mth);
+        ELSE
+          m.IdErrorStr(207, rec.name());
+        END;
+      (* currently disallow declaration of new overloaded method *)
+      (* for name which is NOT currently overloaded *)
+      ELSE
+        m.IdErrorStr(207, rec.name());
+      END;
+    ELSIF (Sy.noCpy IN rec.xAttr) & needOvlId(mth,rec) THEN
+      ovl := newOvlIdent(mth,rec);
+      rec.symTb.Overwrite(ovl.hash, ovl);
+    END;
+   (* 
+    *  Special attribute processing for implement-only methods.
+    *)
+    IF (mth.kind = Id.conMth) &
+       (*  (mth.vMod = Sy.rdoMode) & *)
+       ~(Id.newBit IN mth.mthAtt) THEN
+      fwd := rec.inheritedFeature(mth);
+     (*
+      * Console.WriteString("Checking callable ");
+      * Console.WriteString(rec.name());
+      * Console.WriteString("::");
+      * Console.WriteString(Sy.getName.ChPtr(mth));
+      * Console.WriteLn;
+      *)
+      IF (fwd # NIL) & fwd(Id.MthId).callForbidden() THEN
+        INCL(mth.mthAtt, Id.noCall);
+       (*
+        * Console.WriteString("Marking noCall on ");
+        * Console.WriteString(rec.name());
+        * Console.WriteString("::");
+        * Console.WriteString(Sy.getName.ChPtr(mth));
+        * Console.WriteLn;
+        *)
+      END;
+    END;
+    Sy.AppendIdnt(rec.methods, m);
+  END InsertMethod;
+
+(* ---------------------------- *)
+
+  PROCEDURE (bas : Record)superCtor*(pTp : Procedure) : Id.PrcId,NEW;
+    VAR inx : INTEGER;
+        stI : Sy.Idnt;
+  BEGIN
+    FOR inx := 0 TO bas.statics.tide-1 DO
+      stI := bas.statics.a[inx];
+      IF (stI.kind = Id.ctorP) &
+         pTp.formsMatch(stI.type(Procedure)) THEN RETURN stI(Id.PrcId) END;
+    END;
+    RETURN NIL;
+  END superCtor;
+
+
+  PROCEDURE (rec : Record)AppendCtor*(p : Sy.Idnt);
+    VAR prc : Id.Procs;
+   (* ----------------------------- *)
+    PROCEDURE onList(IN lst : Sy.IdSeq; proc : Id.Procs) : BOOLEAN;
+      VAR inx : INTEGER;
+          stI : Sy.Idnt;
+          pTp : Procedure;
+    BEGIN
+      pTp := proc.type(Procedure);
+     (*
+      *  Return true if the proc is already on the list.
+      *  Signal error if a different matching proc exists.
+      *
+      *  The matching constructor in the list could
+      *  have any name.  So we simply search the list
+      *  looking for *any* constructor which matches.
+      *)
+      FOR inx := 0 TO lst.tide-1 DO
+        stI := lst.a[inx];
+        IF (stI.kind = Id.ctorP) & pTp.formsMatch(stI.type(Procedure)) THEN 
+          IF stI = proc THEN RETURN TRUE ELSE proc.IdError(148) END;
+        END;
+      END;
+      RETURN FALSE;
+    END onList;
+   (* ----------------------------- *)
+    PROCEDURE mustList(recT : Record; proc : Id.Procs) : BOOLEAN;
+      VAR prcT : Procedure;
+          prcN : INTEGER;
+          base : Sy.Type;
+          list : BOOLEAN;
+    BEGIN
+      prcT := proc.type(Procedure);
+      base := recT.baseTp;
+     (*
+      *  Check for duplicate constructors with same signature
+      *)
+      list := onList(recT.statics, proc);
+      IF (proc.basCll = NIL) OR 
+         (proc.basCll.actuals.tide = 0) THEN 
+       (*
+        *  Trying to call the noarg constructor
+        *  of the super type.
+        *)
+        prcN := prcT.formals.tide;
+        WITH base : Record DO
+           (*
+            *  This is allowed, unless the noNew flag is set 
+            *  in the supertype.
+            *)
+            IF Sy.noNew IN base.xAttr THEN proc.IdError(203) END;
+            RETURN ~list & (prcN # 0); (* never list a no-arg constructor *)
+        | base : Base DO
+           (*
+            *  This record extends the ANYREC type.  As
+            *  a concession we allow no-arg constructors. 
+            *)
+            RETURN ~list & (prcN # 0); (* never list a no-arg constructor *)
+        END;
+      ELSE 
+       (*
+        *  This calls an explicit constructor.
+        *)
+        RETURN ~list & (proc.basCll.sprCtor # NIL);
+      END;
+    END mustList;
+   (* ----------------------------- *)
+  BEGIN
+    prc := p(Id.Procs);
+   (*
+    *  First, we must check that there is a super
+    *  constructor with the correct signature.
+    *)
+    IF mustList(rec, prc) THEN Sy.AppendIdnt(rec.statics, p) END;
+    IF prc.body # NIL THEN prc.body.StmtAttr(prc) END;;
+    IF prc.rescue # NIL THEN prc.rescue.StmtAttr(prc) END;;
+  END AppendCtor;
+
+(* ---------------------------- *)
+
+  PROCEDURE (i : Procedure)boundRecTp*() : Sy.Type, EXTENSIBLE;
+  BEGIN
+    IF i.receiver = NIL THEN RETURN NIL ELSE RETURN i.receiver.boundRecTp() END
+  END boundRecTp;
+
+(* ============================================================ *)
+
+  PROCEDURE (i : Record)inheritedFeature*(id : Sy.Idnt) : Sy.Idnt;
+  VAR
+    rec : Record;
+    idnt : Sy.Idnt;
+  BEGIN
+    rec := i; idnt := NIL;
+    rec := baseRecTp(rec);
+    WHILE (idnt = NIL) & (rec # NIL) DO
+      idnt := rec.symTb.lookup(id.hash);
+      IF (idnt # NIL) & (idnt IS Id.OvlId) & (id IS Id.Procs) THEN
+        idnt := idnt(Id.OvlId).findProc(id(Id.Procs));
+      END;
+      rec := baseRecTp(rec);
+    END;
+    RETURN idnt;
+  END inheritedFeature;
+
+(* ============================================================ *)
+(*                     Diagnostic methods                       *)
+(* ============================================================ *)
+
+  PROCEDURE (s : Base)Diagnose*(i : INTEGER);
+  BEGIN
+    s.SuperDiag(i);
+  END Diagnose;
+
+(* ---------------------------------------------------- *)
+
+  PROCEDURE (s : Opaque)Diagnose*(i : INTEGER);
+    VAR name : Lv.CharOpen;
+  BEGIN
+    s.SuperDiag(i);
+    IF s.resolved # NIL THEN
+      name := s.resolved.name();
+      H.Indent(i+2); Con.WriteString("alias of " + name^);
+      s.resolved.SuperDiag(i+2);
+    ELSE
+      H.Indent(i+2); Con.WriteString("opaque not resolved"); Con.WriteLn;
+    END;
+  END Diagnose;
+
+(* ---------------------------------------------------- *)
+
+  PROCEDURE (s : Array)Diagnose*(i : INTEGER);
+  BEGIN
+    s.SuperDiag(i);
+    H.Indent(i+2); Con.WriteString("Element type");
+    IF s.elemTp # NIL THEN
+      Con.WriteLn;
+      s.elemTp.Diagnose(i+2);
+    ELSE
+      Con.WriteString(" NIL"); Con.WriteLn;
+    END;
+  END Diagnose;
+
+(* ---------------------------------------------------- *)
+
+  PROCEDURE (s : Record)Diagnose*(i : INTEGER);
+    VAR ix : INTEGER;
+        id : Sy.Idnt;
+        nm : FileNames.NameString;
+  BEGIN
+    s.SuperDiag(i);
+    CASE s.recAtt OF
+    | isAbs : Console.WriteString(" ABSTRACT"); Console.WriteLn;
+    | limit : Console.WriteString(" LIMITED");  Console.WriteLn;
+    | extns : Console.WriteString(" EXTENSIBLE"); Console.WriteLn;
+    | iFace : Console.WriteString(" INTERFACE");  Console.WriteLn;
+    ELSE
+    END;
+    IF Sy.fnInf IN s.xAttr THEN
+      Console.WriteString(" [foreign-interface]"); Console.WriteLn;
+    ELSIF Sy.isFn IN s.xAttr THEN
+      Console.WriteString(" [foreign-class]"); Console.WriteLn;
+    END;
+    H.Indent(i); Console.WriteString("fields"); Console.WriteLn;
+    FOR ix := 0 TO s.fields.tide-1 DO
+      id := s.fields.a[ix];
+      IF id # NIL THEN id.Diagnose(i+4) END;
+    END;
+    IF CSt.verbose THEN
+      H.Indent(i); Console.WriteString("methods"); Console.WriteLn;
+      FOR ix := 0 TO s.methods.tide-1 DO
+        id := s.methods.a[ix];
+        IF id # NIL THEN id.Diagnose(i+4) END;
+      END;
+      H.Indent(i); Console.WriteString("names"); Console.WriteLn;
+      s.symTb.Dump(i+4);
+    END;
+    IF s.baseTp # NIL THEN
+      H.Indent(i); Console.WriteString("base type"); Console.WriteLn;
+      s.baseTp.Diagnose(i+4);
+    END;
+    Sy.DoXName(i, s.xName);
+    Sy.DoXName(i, s.extrnNm);
+    Sy.DoXName(i, s.scopeNm);
+  END Diagnose;
+
+(* ---------------------------------------------------- *)
+
+  PROCEDURE (s : Enum)Diagnose*(i : INTEGER);
+    VAR ix : INTEGER;
+        id : Sy.Idnt;
+        nm : FileNames.NameString;
+  BEGIN
+    s.SuperDiag(i);
+    H.Indent(i); Console.WriteString("consts"); Console.WriteLn;
+    FOR ix := 0 TO s.statics.tide-1 DO
+      id := s.statics.a[ix];
+      IF id # NIL THEN id.Diagnose(i+4) END;
+    END;
+    Sy.DoXName(i, s.xName);
+  END Diagnose;
+
+(* ---------------------------------------------------- *)
+
+  PROCEDURE (s : Pointer)Diagnose*(i : INTEGER);
+  BEGIN
+    s.SuperDiag(i);
+    H.Indent(i+2); Con.WriteString("Bound type");
+    IF s.boundTp # NIL THEN
+      Con.WriteLn;
+      s.boundTp.Diagnose(i+2);
+    ELSE
+      Con.WriteString(" NIL"); Con.WriteLn;
+    END;
+    Sy.DoXName(i, s.xName);
+  END Diagnose;
+
+(* ---------------------------------------------------- *)
+  PROCEDURE^ qualname(id : Sy.Idnt) : Lv.CharOpen;
+(* ---------------------------------------------------- *)
+
+  PROCEDURE (s : Procedure)DiagFormalType*(i : INTEGER);
+    VAR ix : INTEGER;
+        nm : FileNames.NameString;
+  BEGIN
+    IF s.formals.tide = 0 THEN
+      Console.WriteString("()");
+    ELSE
+      Console.Write("(");
+      Console.WriteLn;
+      FOR ix := 0 TO s.formals.tide-1 DO
+        H.Indent(i+4);
+        s.formals.a[ix].DiagPar();
+        IF ix < s.formals.tide-1 THEN Console.Write(";"); Console.WriteLn END;
+      END;
+      Console.Write(")");
+    END;
+    IF s.retType # NIL THEN
+      Console.WriteString(" : ");
+      Console.WriteString(qualname(s.retType.idnt));
+    END;
+  END DiagFormalType;
+
+(* ---------------------------------------------------- *)
+
+  PROCEDURE (s : Procedure)Diagnose*(i : INTEGER);
+    VAR ix : INTEGER;
+  BEGIN
+    H.Indent(i);
+    IF s.receiver # NIL THEN
+      Console.Write("(");
+      Console.WriteString(s.name());
+      Console.Write(")");
+    END;
+    Console.WriteString("PROC");
+    s.DiagFormalType(i+4);
+    Console.WriteLn;
+    Sy.DoXName(i, s.xName);
+  END Diagnose;
+
+(* ---------------------------------------------------- *)
+
+  PROCEDURE (s : Overloaded)Diagnose*(i : INTEGER);
+  BEGIN
+    H.Indent(i);
+    Console.WriteString("Overloaded Type");
+    Console.WriteLn;
+  END Diagnose;
+
+(* ---------------------------------------------------- *)
+(* ---------------------------------------------------- *)
+
+  PROCEDURE qualname(id : Sy.Idnt) : Lv.CharOpen;
+  BEGIN
+    IF id = NIL THEN
+      RETURN nilStr;
+    ELSIF (id.dfScp = NIL) OR (id.dfScp.kind = Id.modId) THEN
+      RETURN Sy.getName.ChPtr(id);
+    ELSE
+      RETURN Lv.strToCharOpen
+    (Sy.getName.ChPtr(id.dfScp)^ + "." + Sy.getName.ChPtr(id)^);
+    END;
+  END qualname;
+
+(* ---------------------------------------------------- *)
+
+  PROCEDURE (s : Base)name*() : Lv.CharOpen;
+  BEGIN
+    IF s.idnt = NIL THEN
+      RETURN Lv.strToCharOpen("Anon-base-type");
+    ELSE
+      RETURN Sy.getName.ChPtr(s.idnt);
+    END;
+  END name;
+
+(* ---------------------------------------------------- *)
+
+  PROCEDURE (s : Enum)name*() : Lv.CharOpen;
+  BEGIN
+    IF s.idnt = NIL THEN
+      RETURN Lv.strToCharOpen("Anon-enum-type");
+    ELSE
+      RETURN Sy.getName.ChPtr(s.idnt);
+    END;
+  END name;
+
+(* ---------------------------------------------------- *)
+
+  PROCEDURE (s : Opaque)name*() : Lv.CharOpen;
+  BEGIN
+    IF s.idnt = NIL THEN
+      IF s.kind = namTp THEN
+        RETURN Lv.strToCharOpen("Anon-opaque");
+      ELSE
+        RETURN Lv.strToCharOpen("Anon-temporary");
+      END;
+    ELSE
+      RETURN qualname(s.idnt);
+    END;
+  END name;
+
+(* ---------------------------------------------------- *)
+
+  PROCEDURE (s : Array)name*() : Lv.CharOpen, EXTENSIBLE;
+    VAR elNm : Lv.CharOpen;
+  BEGIN
+    IF s.idnt = NIL THEN
+      IF s.elemTp = NIL THEN elNm := nilStr ELSE elNm := s.elemTp.name() END;
+      IF s.length = 0 THEN
+        RETURN Lv.strToCharOpen("ARRAY OF " + elNm^);
+      ELSE
+        RETURN Lv.strToCharOpen("ARRAY " + 
+                                Lv.intToCharOpen(s.length)^ +
+                                " OF " + 
+                                elNm^);
+      END;
+    ELSE
+      RETURN qualname(s.idnt);
+    END;
+  END name;
+
+(* ---------------------------------------------------- *)
+
+  PROCEDURE (s : Vector)name*() : Lv.CharOpen;
+    VAR elNm : Lv.CharOpen;
+  BEGIN
+    IF s.idnt = NIL THEN
+      IF s.elemTp = NIL THEN elNm := nilStr ELSE elNm := s.elemTp.name() END;
+      RETURN Lv.strToCharOpen("VECTOR OF " + elNm^);
+    ELSE
+      RETURN qualname(s.idnt);
+    END;
+  END name;
+
+(* ---------------------------------------------------- *)
+
+  PROCEDURE cmpndName(s : Record) : Lv.CharOpen;
+  (* Returns the name of a compound type as a list
+   * of its (optional) class and its interfaces *)
+    VAR
+      itfList : Lv.CharOpen;
+      i : INTEGER;
+  BEGIN
+    itfList := Lv.strToCharOpen("(");
+    IF s.baseTp # NIL THEN
+      itfList := Lv.strToCharOpen(itfList^ + s.baseTp.name()^ + ",");
+    END;
+    FOR i := 0 TO s.interfaces.tide - 1 DO
+      itfList := Lv.strToCharOpen(itfList^ + s.interfaces.a[i].name()^);
+      IF i # s.interfaces.tide - 1 THEN
+        itfList := Lv.strToCharOpen(itfList^ + ",");
+      END;
+    END;
+    RETURN Lv.strToCharOpen(itfList^ + ")");
+  END cmpndName;
+
+(* ---------------------------------------------------- *)
+
+  PROCEDURE (s : Record)name*() : Lv.CharOpen;
+  BEGIN
+    IF s.bindTp # NIL THEN
+      RETURN Lv.strToCharOpen(s.bindTp.name()^ + "^");
+    ELSIF s.idnt = NIL THEN
+      IF s.recAtt = cmpnd THEN
+        RETURN cmpndName(s);
+      ELSE
+        RETURN Lv.strToCharOpen("Anon-record");
+      END;
+    ELSE
+      RETURN qualname(s.idnt);
+    END;
+  END name;
+
+(* ---------------------------------------------------- *)
+
+  PROCEDURE (s : Pointer)name*() : Lv.CharOpen;
+    VAR elNm : Lv.CharOpen;
+  BEGIN
+    IF s.idnt = NIL THEN
+      IF s.boundTp = NIL THEN elNm := nilStr ELSE elNm := s.boundTp.name() END;
+      RETURN Lv.strToCharOpen("POINTER TO " + elNm^);
+    ELSE
+      RETURN qualname(s.idnt);
+    END;
+  END name;
+
+(* ---------------------------------------------------- *)
+
+  PROCEDURE (s : Procedure)name*() : Lv.CharOpen;
+  BEGIN
+    IF s.idnt = NIL THEN
+      RETURN Lv.strToCharOpen("Anon-opaque-type");
+    ELSE
+      RETURN qualname(s.idnt);
+    END;
+  END name;
+
+(* ---------------------------------------------------- *)
+
+  PROCEDURE (s : Overloaded)name*() : Lv.CharOpen;
+  BEGIN
+    RETURN Lv.strToCharOpen("Overloaded-type");
+  END name;
+
+(* ============================================================ *)
+BEGIN (* ====================================================== *)
+  NEW(anyRecTp);
+  NEW(anyPtrTp);
+  nilStr := Lv.strToCharOpen("<nil>");
+END TypeDesc. (* ============================================== *)
+(* ============================================================ *)

gpcp/VarSets.cp

@@ -0,0 +1,289 @@
+(* ==================================================================== *)
+(*									*)
+(*  VarSet Module for the Gardens Point Component Pascal Compiler.	*)
+(*  Implements operations on variable length bitsets.			*)
+(*	Copyright (c) John Gough 1999, 2000.				*)
+(*									*)
+(* ==================================================================== *)
+
+MODULE VarSets;
+
+  IMPORT 
+	GPCPcopyright,
+	Console;
+
+(* ============================================================ *)
+
+  CONST bits = 32;
+	iMax = bits-1;
+
+(* ============================================================ *)
+
+  TYPE
+    VarSet* = POINTER TO RECORD
+		vars : POINTER TO ARRAY OF SET;
+		size : INTEGER;
+	      END;
+
+(* ============================================================ *)
+(* =======  Implementation of VarSet abstract data type ======= *)
+(* ============================================================ *)
+
+  PROCEDURE newSet*(size : INTEGER) : VarSet;
+    VAR tmp : VarSet;
+	len : INTEGER;
+  BEGIN
+    NEW(tmp);
+    tmp.size := size;
+    IF size = 0 THEN len := 1 ELSE len := (size + iMax) DIV bits END;
+    NEW(tmp.vars, len);
+    RETURN tmp;
+  END newSet;
+
+(* ======================================= *)
+
+  PROCEDURE newUniv*(size : INTEGER) : VarSet;
+    VAR tmp : VarSet;
+	rem : INTEGER;
+	idx : INTEGER;
+  BEGIN
+    idx := 0;
+    rem := size;
+    tmp := newSet(size);
+    WHILE rem > 32 DO
+      tmp.vars[idx] := {0 .. iMax};
+      INC(idx); DEC(rem,bits);
+    END;
+    tmp.vars[idx] := {0 .. (rem-1)};
+    RETURN tmp;
+  END newUniv;
+
+(* ======================================= *)
+
+  PROCEDURE newEmpty*(size : INTEGER) : VarSet;
+    VAR tmp : VarSet;
+	idx : INTEGER;
+  BEGIN
+    tmp := newSet(size);
+    FOR idx := 0 TO LEN(tmp.vars^)-1 DO tmp.vars[idx] := {} END;
+    RETURN tmp;
+  END newEmpty;
+
+(* ======================================= *)
+
+  PROCEDURE (self : VarSet)newCopy*() : VarSet,NEW;
+    VAR tmp : VarSet;
+	idx : INTEGER;
+  BEGIN
+    tmp := newSet(self.size);
+    FOR idx := 0 TO LEN(tmp.vars)-1 DO tmp.vars[idx] := self.vars[idx] END;
+    RETURN tmp;
+  END newCopy;
+
+(* ======================================= *)
+
+  PROCEDURE (self : VarSet)cardinality*() : INTEGER,NEW;
+  BEGIN RETURN self.size END cardinality;
+
+(* ============================================================ *)
+
+  PROCEDURE (self : VarSet)includes*(elem : INTEGER) : BOOLEAN, NEW;
+  BEGIN
+    RETURN (elem < self.size) & 
+		((elem MOD bits) IN self.vars[elem DIV bits]);
+  END includes;
+
+(* ============================================================ *)
+
+  PROCEDURE (self : VarSet)Incl*(elem : INTEGER),NEW;
+  BEGIN
+    INCL(self.vars[elem DIV bits], elem MOD bits);
+  END Incl;
+
+(* ======================================= *)
+
+  PROCEDURE (self : VarSet)InclSet*(add : VarSet),NEW;
+    VAR i : INTEGER;
+  BEGIN
+    ASSERT(self.size = add.size);
+    FOR i := 0 TO LEN(self.vars)-1 DO
+      self.vars[i] := self.vars[i] + add.vars[i];
+    END;
+  END InclSet;
+
+(* ============================================================ *)
+
+  PROCEDURE (self : VarSet)Excl*(elem : INTEGER),NEW;
+  BEGIN
+    EXCL(self.vars[elem DIV bits], elem MOD bits);
+  END Excl;
+
+(* ======================================= *)
+
+  PROCEDURE (self : VarSet)ExclSet*(sub : VarSet),NEW;
+    VAR i : INTEGER;
+  BEGIN
+    ASSERT(self.size = sub.size);
+    FOR i := 0 TO LEN(self.vars)-1 DO
+      self.vars[i] := self.vars[i] - sub.vars[i];
+    END;
+  END ExclSet;
+
+(* ============================================================ *)
+
+  PROCEDURE (self : VarSet)isUniv*() : BOOLEAN, NEW;
+    VAR i,r : INTEGER; s : SET;
+  BEGIN
+    i := 0; r := self.size;
+    WHILE r > bits DO
+      IF self.vars[i] # {0 .. iMax} THEN RETURN FALSE END;
+      INC(i); DEC(r,bits);
+    END;
+    RETURN self.vars[i] = {0 .. (r-1)};
+  END isUniv;
+
+(* ============================================================ *)
+
+  PROCEDURE (self : VarSet)isEmpty*() : BOOLEAN, NEW;
+    VAR i : INTEGER;
+  BEGIN
+    IF self.size <= 32 THEN RETURN self.vars[0] = {} END;
+    FOR i := 0 TO LEN(self.vars)-1 DO
+      IF self.vars[i] # {} THEN RETURN FALSE END;
+    END;
+    RETURN TRUE;
+  END isEmpty;
+
+(* ============================================================ *)
+
+  PROCEDURE (self : VarSet)not*() : VarSet, NEW;
+    VAR tmp : VarSet;
+	rem : INTEGER;
+	idx : INTEGER;
+  BEGIN
+    idx := 0; 
+    rem := self.size;
+    tmp := newSet(rem);
+    WHILE rem > 32 DO
+      tmp.vars[idx] := {0 .. iMax} - self.vars[idx];
+      INC(idx); DEC(rem,bits);
+    END;
+    tmp.vars[idx] := {0 .. (rem-1)} - self.vars[idx];
+    RETURN tmp;
+  END not;
+
+(* ======================================= *)
+
+  PROCEDURE (self : VarSet)Neg*(),NEW;
+    VAR rem : INTEGER;
+	idx : INTEGER;
+  BEGIN
+    idx := 0; 
+    rem := self.size;
+    WHILE rem > 32 DO
+      self.vars[idx] := {0 .. iMax} - self.vars[idx];
+      INC(idx); DEC(rem,bits);
+    END;
+    self.vars[idx] := {0 .. (rem-1)} - self.vars[idx];
+  END Neg;
+
+(* ============================================================ *)
+
+  PROCEDURE (self : VarSet)cup*(rhs : VarSet) : VarSet,NEW;
+    VAR tmp : VarSet;
+    VAR i   : INTEGER;
+  BEGIN
+    ASSERT(self.size = rhs.size);
+    tmp := newSet(self.size);
+    FOR i := 0 TO LEN(self.vars)-1 DO
+      tmp.vars[i] := self.vars[i] + rhs.vars[i];
+    END;
+    RETURN tmp;
+  END cup;
+
+(* ======================================= *)
+
+  PROCEDURE (self : VarSet)Union*(rhs : VarSet),NEW;
+  BEGIN
+    self.InclSet(rhs);
+  END Union;
+
+(* ============================================================ *)
+
+  PROCEDURE (self : VarSet)cap*(rhs : VarSet) : VarSet,NEW;
+    VAR tmp : VarSet;
+    VAR i   : INTEGER;
+  BEGIN
+    ASSERT(self.size = rhs.size);
+    tmp := newSet(self.size);
+    FOR i := 0 TO LEN(self.vars)-1 DO
+      tmp.vars[i] := self.vars[i] * rhs.vars[i];
+    END;
+    RETURN tmp;
+  END cap;
+
+(* ======================================= *)
+
+  PROCEDURE (self : VarSet)Intersect*(rhs : VarSet),NEW;
+    VAR i   : INTEGER;
+  BEGIN
+    ASSERT(self.size = rhs.size);
+    FOR i := 0 TO LEN(self.vars)-1 DO
+      self.vars[i] := self.vars[i] * rhs.vars[i];
+    END;
+  END Intersect;
+
+(* ============================================================ *)
+
+  PROCEDURE (self : VarSet)xor*(rhs : VarSet) : VarSet,NEW;
+    VAR tmp : VarSet;
+	i   : INTEGER;
+  BEGIN
+    ASSERT(self.size = rhs.size);
+    tmp := newSet(self.size);
+    FOR i := 0 TO LEN(self.vars)-1 DO
+      tmp.vars[i] := self.vars[i] / rhs.vars[i];
+    END;
+    RETURN tmp;
+  END xor;
+
+(* ======================================= *)
+
+  PROCEDURE (self : VarSet)SymDiff*(rhs : VarSet),NEW;
+    VAR i   : INTEGER;
+  BEGIN
+    ASSERT(self.size = rhs.size);
+    FOR i := 0 TO LEN(self.vars)-1 DO
+      self.vars[i] := self.vars[i] / rhs.vars[i];
+    END;
+  END SymDiff;
+
+(* ============================================================ *)
+
+  PROCEDURE (self : VarSet)Diagnose*(),NEW;
+    VAR i,j : INTEGER;
+	lim : INTEGER;
+	chr : CHAR;
+  BEGIN
+    j := 0;
+    lim := self.size-1;
+    Console.Write('{'); 
+    FOR i := 0 TO self.size-1 DO
+      chr := CHR(i MOD 10 + ORD('0'));
+      IF self.includes(i) THEN 
+	Console.Write(chr);
+      ELSE
+	Console.Write('.');
+      END;
+      IF (chr = '9') & (i < lim) THEN 
+	IF j < 6 THEN INC(j) ELSE Console.WriteLn; j := 0 END;
+	Console.Write('|');
+      END;
+    END;
+    Console.Write('}');
+  END Diagnose;
+
+(* ============================================================ *)
+END VarSets.  (* ============================================== *)
+(* ============================================================ *)
+

gpcp/Visitor.cp

@@ -0,0 +1,240 @@
+(* ==================================================================== *)
+(*                                                                      *)
+(*  Visitor pattern for the Gardens Point Component Pascal Compiler.    *)
+(*  This module defines various extensions of type Symbols.SymForAll    *)
+(*  Copyright (c) John Gough 1999, 2000.                                *)
+(*                                                                      *)
+(* ==================================================================== *)
+
+MODULE Visitor;
+
+  IMPORT
+        GPCPcopyright,
+        Console,
+        Symbols,
+        CPascalS,
+        LitValue,
+        Id := IdDesc,
+        Ty := TypeDesc,
+        NameHash;
+
+(* ============================================================ *)
+
+  TYPE
+    Resolver* = POINTER TO RECORD (Symbols.SymForAll) END;
+
+(* -------------------------------------------- *)
+
+  TYPE
+    ImplementedCheck* = POINTER TO RECORD (Symbols.SymForAll) END;
+
+(* -------------------------------------------- *)
+
+  TYPE
+    TypeEraser* = POINTER TO RECORD (Symbols.SymForAll) END;
+
+(* -------------------------------------------- *)
+
+  TYPE
+    Accumulator* = POINTER TO RECORD (Symbols.SymForAll)
+         missing  : Symbols.SymbolTable;
+         recordTb : Ty.Record;
+         isIntrfc : BOOLEAN;
+       END;
+
+(* ============================================================ *)
+
+  PROCEDURE newAccumulator(target : Ty.Record) : Accumulator;
+  (** Create a new symbol table and add to it all of the abstract *)
+  (*  methods which are not concrete in the target scope space.   *)
+    VAR tmp : Accumulator;
+  BEGIN
+    NEW(tmp);
+    tmp.recordTb := target;
+    tmp.isIntrfc := FALSE;  (* not an interface *)
+    RETURN tmp;
+  END newAccumulator;
+
+ (* --------------------------- *)
+
+  PROCEDURE newInterfaceCheck(target : Ty.Record) : Accumulator;
+  (** Create a new symbol table and add to it all of the abstract *)
+  (*  methods which are not concrete in the target scope space.   *)
+    VAR tmp : Accumulator;
+  BEGIN
+    NEW(tmp);
+    tmp.recordTb := target;
+    tmp.isIntrfc := TRUE; (* is an interface *)
+    RETURN tmp;
+  END newInterfaceCheck;
+
+ (* --------------------------- *)
+
+  PROCEDURE (sfa : Accumulator)Op*(id : Symbols.Idnt);
+    VAR anyId : Symbols.Idnt;
+        pType : Ty.Procedure;
+        junk  : BOOLEAN;
+  BEGIN
+    IF id.isAbstract() THEN
+     (*
+      *  Lookup the id in the original record name-scope
+      *  If id implements some interface method, we must
+      *  force it to be virtual by getting rid of newBit.
+      *)
+      anyId := sfa.recordTb.bindField(id.hash);
+      IF (anyId = NIL) OR anyId.isAbstract() THEN
+        junk := sfa.missing.enter(id.hash, id);
+      ELSIF sfa.isIntrfc & (anyId.kind = Id.conMth) THEN
+        EXCL(anyId(Id.MthId).mthAtt, Id.newBit);
+        pType := id.type(Ty.Procedure);
+        pType.CheckCovariance(anyId);
+        IF id.vMod # anyId.vMod THEN anyId.IdError(163) END;
+        IF id(Id.Procs).prcNm # NIL THEN
+            anyId(Id.Procs).prcNm := id(Id.Procs).prcNm END;
+      END;
+    END;
+  END Op;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE newImplementedCheck*() : ImplementedCheck;
+    VAR tmp : ImplementedCheck;
+  BEGIN NEW(tmp); RETURN tmp END newImplementedCheck;
+
+ (* --------------------------- *)
+
+  PROCEDURE (sfa : ImplementedCheck)Op*(id : Symbols.Idnt);
+    VAR acc : Accumulator;
+        rTp : Ty.Record;
+        nTp : Ty.Record;
+        bTp : Symbols.Type;
+        idx : INTEGER;
+   (* ----------------------------------------- *)
+    PROCEDURE InterfaceIterate(r : Ty.Record;
+             a : Accumulator);
+      VAR i : INTEGER;
+          x : Ty.Record;
+    BEGIN
+      FOR i := 0 TO r.interfaces.tide - 1 DO
+        x := r.interfaces.a[i].boundRecTp()(Ty.Record);
+        x.symTb.Apply(a);
+        InterfaceIterate(x, a); (* recurse to inherited interfaces *)
+      END;
+    END InterfaceIterate;
+   (* ----------------------------------------- *)
+  BEGIN
+    IF id.kind = Id.typId THEN
+      rTp := id.type.boundRecTp()(Ty.Record);
+      IF (rTp # NIL) &      (* ==> this is a record type  *)
+         ~rTp.isAbsRecType() &    (* ==> this rec is NOT abstract *)
+         ~rTp.isImportedType() &  (* ==> this rec is NOT imported *)
+         (rTp.baseTp # NIL) THEN  (* ==> this extends some type   *)
+        bTp := rTp.baseTp;
+        IF bTp.isAbsRecType() THEN  (* ==> and base _is_ abstract.  *)
+         (*
+          *  This is a concrete record extending an abstract record.
+          *  By now, all inherited abstract methods must have been
+          *  resolved to concrete methods.  Traverse up the base
+          *  hierarchy accumulating unimplemented methods.
+          *)
+          acc := newAccumulator(rTp);
+          REPEAT
+            nTp := bTp(Ty.Record);  (* guaranteed for first time  *)
+            bTp := nTp.baseTp;
+            nTp.symTb.Apply(acc);
+          UNTIL (bTp = NIL) OR bTp.isBaseType();
+         (*
+          *  Now we turn the missing table into a list.
+          *)
+          IF ~acc.missing.isEmpty() THEN
+            CPascalS.SemError.RepSt1(121, Symbols.dumpList(acc.missing),
+            id.token.lin, id.token.col);
+          END;
+        END;
+        IF rTp.interfaces.tide > 0 THEN
+         (*
+          *   The record rTp claims to implement interfaces.
+          *   We must check conformance to the contract.
+          *)
+          acc := newInterfaceCheck(rTp);
+          InterfaceIterate(rTp, acc);
+         (*
+          *  Now we turn the missing table into a list.
+          *)
+          IF ~acc.missing.isEmpty() THEN
+            CPascalS.SemError.RepSt1(159, Symbols.dumpList(acc.missing),
+            id.token.lin, id.token.col);
+          END;
+        END;
+      END;
+    END;
+  END Op;
+
+(* -------------------------------------------- *)
+
+  PROCEDURE newResolver*() : Resolver;
+    VAR tmp : Resolver;
+  BEGIN
+    NEW(tmp);
+    RETURN tmp;
+  END newResolver;
+
+ (* --------------------------- *)
+
+  PROCEDURE (sfa : Resolver)Op*(id : Symbols.Idnt);
+    VAR idTp : Symbols.Type;
+  BEGIN
+    IF (id.kind = Id.typId) OR (id.kind = Id.varId) THEN
+      idTp := id.type;
+      IF idTp # NIL THEN
+        idTp := idTp.resolve(1);
+(* ------------------------------------------------- *
+ *      IF idTp # NIL THEN
+ *        WITH idTp : Ty.Array DO
+ *           IF idTp.isOpenArrType() THEN id.IdError(67) END;
+ *        | idTp : Ty.Record DO
+ *           IF id.kind = Id.varId THEN idTp.InstantiateCheck(id.token) END;
+ *        ELSE
+ *        END;
+ *      END;
+ * ------------------------------------------------- *)
+        IF (idTp # NIL) & (id.kind = Id.varId) THEN
+          WITH idTp : Ty.Array DO (* only for varIds, kjg 2004 *)
+             IF idTp.isOpenArrType() THEN id.IdError(67) END;
+          | idTp : Ty.Record DO
+             idTp.InstantiateCheck(id.token);
+          ELSE
+          END;
+        END;
+(* ------------------------------------------------- *)
+      END;
+      id.type := idTp;
+    END;
+  END Op;
+
+ (* --------------------------- *)
+
+  PROCEDURE newTypeEraser*() : TypeEraser;
+    VAR tmp : TypeEraser;
+  BEGIN
+    NEW(tmp);
+    RETURN tmp;
+  END newTypeEraser;
+
+ (* --------------------------- *)
+
+  PROCEDURE (sfa : TypeEraser)Op*(id : Symbols.Idnt);
+  (* Erases any compound types found in the symbol table. These
+   *  are converted to their implementation types *)
+    VAR idTp : Symbols.Type;
+        ct   : Ty.Record;
+  BEGIN
+    IF id.type # NIL THEN
+      id.type := id.type.TypeErase();
+    END;
+  END Op;
+
+(* ============================================================ *)
+END Visitor.  (* ============================================== *)
+(* ============================================================ *)
+

gpcp/csharp/MsilAsm.cs

@@ -0,0 +1,126 @@
+// (* ========================================================= *)
+// (**	Interface to the ILASM Byte-code assembler.		*)
+// (*	K John Gough, 10th June 1999				*)
+// (*	Modifications:						*)
+// (*		Version for GPCP V0.3 April 2000 (kjg)		*)
+// (* ========================================================= *)
+// (*	The real code is in MsilAsm.cs				*)	
+// (* ========================================================= *)
+//
+//MODULE MsilAsm;
+//
+//  PROCEDURE Init*(); BEGIN END Init;
+//
+//  PROCEDURE Assemble*(IN fil, opt : ARRAY OF CHAR; main : BOOLEAN); 
+//  BEGIN END Assemble;
+//
+//END MsilAsm.
+// 
+// 
+//  NOTE: this needs (as at 13-Jun-2000) to be compiled using
+//
+//  $ csc /t:library /r:System.Diagnostics.dll /r:RTS.dll MsilAsm.cs
+//
+//  NOTE: for Beta2 this finds System.Diagnostics in mscorlib.dll
+//
+//  $ csc /t:library /r:RTS.dll MsilAsm.cs
+// 
+#if !BETA1
+  #define BETA2
+#endif
+
+using System.Diagnostics;
+
+namespace MsilAsm {
+
+public class MsilAsm {
+
+    private static Process asm = null;
+
+
+    public static string GetDotNetRuntimeInstallDirectory() 
+    {
+        // Get the path to mscorlib.dll
+        string s = typeof(object).Module.FullyQualifiedName;
+
+        // Remove the file part to get the directory
+        return System.IO.Directory.GetParent(s).ToString() + "\\";
+    }
+
+    public static void Init() {
+	if (asm == null) {
+	    asm = new Process();
+	    asm.StartInfo.FileName = GetDotNetRuntimeInstallDirectory() + "ilasm";
+#if BETA1
+	    asm.StartInfo.WindowStyle = ProcessWindowStyle.Minimized;
+#else //BETA2
+	    asm.StartInfo.CreateNoWindow = true;
+	    asm.StartInfo.UseShellExecute = false;
+#endif
+	}
+    }
+
+    public static void Assemble(char[] fil, char[] opt, bool hasMain) {
+	int retCode;
+	System.String optNm;
+	System.String suffx;
+	System.String fName = CP_rts.mkStr(fil);
+	if (hasMain) {
+	    optNm ="/exe ";
+	    suffx = ".exe";
+	} else {
+	    optNm = "/dll ";
+	    suffx = ".dll";
+	}
+	optNm = optNm + CP_rts.mkStr(opt) + ' ';
+	asm.StartInfo.Arguments = optNm + "/nologo /quiet " + fName + ".il";
+	asm.Start();
+	asm.WaitForExit();
+	retCode = asm.ExitCode;
+	if (retCode != 0)
+	    System.Console.WriteLine("#gpcp: ilasm FAILED " + retCode);
+	else
+	    System.Console.WriteLine("#gpcp: created " + fName + suffx);
+    }
+    
+    public static void DoAsm(char[] fil, char[] opt, 
+				bool hasMain, 
+				bool verbose, 
+				ref int rslt) {
+	System.String optNm;
+	System.String suffx;
+	System.String fName = CP_rts.mkStr(fil);
+	if (hasMain) {
+	    optNm ="/exe ";
+	    suffx = ".exe";
+	} else {
+	    optNm = "/dll ";
+	    suffx = ".dll";
+	}
+	optNm = optNm + CP_rts.mkStr(opt) + ' ';
+	if (verbose) {
+#if BETA2
+	    asm.StartInfo.CreateNoWindow = false;
+#endif
+	    asm.StartInfo.Arguments = optNm + "/nologo " + fName + ".il";
+	} else {
+#if BETA2
+	    asm.StartInfo.CreateNoWindow = true;
+#endif
+	    asm.StartInfo.Arguments = optNm + "/nologo /quiet " + fName + ".il";
+	}
+	asm.Start();
+	asm.WaitForExit();
+	rslt = asm.ExitCode;
+	if (rslt == 0)
+	    System.Console.WriteLine("#gpcp: Created " + fName + suffx);
+    }
+
+    
+    public static void Assemble(char[] fil, bool hasMain) {
+        char[] opt = {'/', 'd', 'e', 'b', 'u', 'g', '\0' };
+        Assemble(fil, opt, hasMain);
+    }
+
+  }
+}

gpcp/gpcp.cp

@@ -0,0 +1,50 @@
+(* ==================================================================== *)
+(*									*)
+(*  Driver Module for the Gardens Point Component Pascal Compiler.	*)
+(*	Copyright (c) John Gough 1999, 2000.				*)
+(*	This module was extensively modified from the driver		*)
+(*	automatically produced by the M2 version of COCO/R, using	*)
+(*	the CPascal.atg grammar used for the JVM version of GPCP.	*)
+(*									*)
+(* ==================================================================== *)
+
+MODULE gpcp;
+  IMPORT 
+	GPCPcopyright,
+	CPmain,
+	GPFiles,
+	ProgArgs,
+	Main := CPascal;
+
+(* ==================================================================== *)
+
+  VAR
+    chr0 : CHAR;
+    parN : INTEGER;
+    filN : INTEGER;
+    junk : INTEGER;
+    argN : ARRAY 256 OF CHAR;
+
+(* ==================================================================== *)
+(*			      Main Argument Loop			*)
+(* ==================================================================== *)
+
+BEGIN
+  filN := 0;
+  FOR parN := 0 TO ProgArgs.ArgNumber()-1 DO
+    ProgArgs.GetArg(parN, argN);
+    chr0 := argN[0];
+    IF (chr0 = '-') OR (chr0 = GPFiles.optChar) THEN (* option string *)
+      Main.DoOption(argN$);
+    ELSE
+      Main.Compile(argN$, junk); INC(filN);
+    END;
+  END;
+  IF filN = 0 THEN Main.Message("No input files specified") END;
+ (*
+  *  Return the result code of the final compilation
+  *)
+  IF junk # 0 THEN HALT(1) END;
+END gpcp.
+
+(* ==================================================================== *)

gpcp/n2state.cp

@@ -0,0 +1,324 @@
+
+(* ================================================================ *)
+(*                                                                  *)
+(*  Module of the V1.4+ gpcp tool to create symbol files from       *)
+(*  the metadata of .NET assemblies, using the PERWAPI interface.   *)
+(*                                                                  *)
+(*  Copyright QUT 2004 - 2005.                                      *)
+(*                                                                  *)
+(*  This code released under the terms of the GPCP licence.         *)
+(*                                                                  *)
+(*  This Module:   <N2State>                                        *)
+(*       Holds global state for the process, plus utilities.        *)
+(*       Original module, kjg December 2004                         *)
+(*                                                                  *)
+(* ================================================================ *)
+
+MODULE N2State;
+  IMPORT GPCPcopyright, 
+         CompState,
+         LitValue,
+         ProgArgs,
+         Console, 
+         Error,
+         GPText,
+         ForeignName,
+         RW := NewSymFileRW,
+         Id := IdDesc,
+         Ty := TypeDesc,
+         Sy := Symbols,
+         Nh := NameHash,
+         Sys := "[mscorlib]System",
+         RTS; 
+
+ (* ---------------------------------------------------------- *)
+
+  CONST prefix = "PeToCps: ";
+        abtMsg = " ... Aborting";
+        usgMsg = 'Usage: "PeToCps [options] filenames"';
+
+ (* ---------------------------------------------------------- *)
+
+  TYPE  CharOpen* = POINTER TO ARRAY OF CHAR;
+
+ (* ---------------------------------------------------------- *)
+
+  TYPE  CleanDump = POINTER TO RECORD (Sy.SymForAll) END;
+
+ (* ---------------------------------------------------------- *)
+
+  VAR   netDflt-  : BOOLEAN;
+        verbose-  : BOOLEAN;
+        Verbose-  : BOOLEAN;
+        superVb-  : BOOLEAN;
+        generics- : BOOLEAN;
+        legacy-   : BOOLEAN;
+        cpCmpld-  : BOOLEAN;
+
+ (* ---------------------------------------------------------- *)
+
+  VAR   thisMod-  : Id.BlkId;
+        isCorLib- : BOOLEAN;
+        hashSize- : INTEGER;
+        ctorBkt-  : INTEGER;
+        initBkt-  : INTEGER;
+        srcNam-   : CharOpen;
+        basNam-   : CharOpen;
+        impSeq*   : Sy.ScpSeq;
+        typSeq-   : Sy.TypeSeq;
+
+ (* ---------------------------------------------------------- *)
+
+  PROCEDURE^ AbortMsg*(IN str : ARRAY OF CHAR);
+  PROCEDURE^ Message*(IN str : ARRAY OF CHAR);
+
+ (* ---------------------------------------------------------- *)
+
+  PROCEDURE ListTy*(ty : Sy.Type);
+  BEGIN
+    Sy.AppendType(typSeq, ty);
+  END ListTy;
+
+ (* ---------------------------------------------------------- *)
+
+  PROCEDURE AddMangledNames(mod : Id.BlkId; asm, nms : CharOpen);
+  BEGIN
+    mod.hash    := Nh.enterStr(ForeignName.MangledName(asm, nms));
+    mod.scopeNm := ForeignName.QuotedName(asm, nms);
+  END AddMangledNames;
+
+ (* ---------------------------------------------------------- *)
+
+  PROCEDURE GlobInit*(IN src, bas : ARRAY OF CHAR);
+  BEGIN
+    Nh.InitNameHash(hashSize);
+    srcNam := BOX(src$);
+    basNam := BOX(bas$);
+    isCorLib := (bas = "mscorlib");
+
+    CompState.CreateThisMod;
+    thisMod := CompState.thisMod;
+
+    Sy.ResetScpSeq(impSeq);
+    ctorBkt := Nh.enterStr(".ctor");
+    initBkt := Nh.enterStr("init");
+  END GlobInit;
+
+ (* ------------------------------------- *)
+
+  PROCEDURE BlkIdInit*(blk : Id.BlkId; asm, nms : CharOpen);
+  BEGIN
+    blk.SetKind(Id.impId);
+    AddMangledNames(blk, asm, nms);
+    IF Sy.refused(blk, thisMod) THEN 
+      AbortMsg("BlkId insert failure -- " + Nh.charOpenOfHash(blk.hash)^);
+    END;
+    Sy.AppendScope(impSeq, blk)
+  END BlkIdInit;
+
+ (* ------------------------------------- *)
+
+  PROCEDURE InsertImport*(blk : Id.BlkId);
+  BEGIN
+    IF Sy.refused(blk, thisMod) THEN 
+      AbortMsg("BlkId insert failure in <thisMod>");
+    END;
+    Sy.AppendScope(impSeq, blk)
+  END InsertImport;
+
+ (* ------------------------------------- *)
+
+  PROCEDURE (dmpr : CleanDump)Op*(id : Sy.Idnt);
+  BEGIN
+    WITH id : Id.TypId DO
+      IF id.type.dump >= Sy.tOffset THEN id.type.dump := 0 END;
+    ELSE
+    END;
+  END Op;
+
+ (* ------------------------------------- *)
+
+  PROCEDURE ResetBlkIdFlags*(mod : Id.BlkId);
+    VAR indx : INTEGER;
+        impB : Sy.Scope;
+        dmpr : CleanDump;
+        typI : Sy.Type;
+  BEGIN
+   (*
+    *   Clear the "dump" marker from non built-in types
+    *)
+    FOR indx := 0 TO typSeq.tide - 1 DO
+      typI := typSeq.a[indx];
+      IF typI.dump >= Sy.tOffset THEN 
+        typI.dump := 0;
+        typI.force := Sy.noEmit;
+      END;
+    END;
+    mod.SetKind(Id.modId);
+
+    IF superVb THEN
+      Message("Preparing symfile <" + Nh.charOpenOfHash(mod.hash)^ + ">");
+    END;
+    FOR indx := 0 TO impSeq.tide - 1 DO
+      impB := impSeq.a[indx];
+      IF impB # mod THEN
+        impB.SetKind(Id.impId);
+      END;
+    END;
+  END ResetBlkIdFlags;
+
+ (* ---------------------------------------------------------- *)
+
+  PROCEDURE WLn(IN str : ARRAY OF CHAR);
+  BEGIN
+    Console.WriteString(str); Console.WriteLn;
+  END WLn;
+
+  PROCEDURE Message*(IN str : ARRAY OF CHAR);
+  BEGIN
+    Console.WriteString(prefix);
+    Console.WriteString(str);
+    Console.WriteLn;
+  END Message;
+
+  PROCEDURE CondMsg*(IN str : ARRAY OF CHAR);
+  BEGIN
+    IF verbose THEN Message(str) END;
+  END CondMsg;
+
+  PROCEDURE AbortMsg*(IN str : ARRAY OF CHAR);
+  BEGIN
+    Error.WriteString(prefix);
+    Error.WriteString(str);
+    Error.WriteLn;
+    HALT(1); 
+  END AbortMsg;
+    
+  PROCEDURE Usage();
+  BEGIN
+    Message(usgMsg); 
+    Message("filenames should have explicit .EXE or .DLL extension"); 
+    IF netDflt THEN
+      WLn("Options: /big       ==> allocate huge hash table");
+      WLn("         /copyright ==> display copyright notice");
+      WLn("         /generics  ==> enable CLI v2.0 generics");
+      WLn("         /help      ==> display this message");
+      WLn("         /legacy    ==> produce compatible symbol file");
+      WLn("         /verbose   ==> chatter on about progress"); 
+      WLn("         /Verbose   ==> go on and on and on about progress"); 
+    ELSE
+      WLn("Options: -big       ==> allocate huge hash table");
+      WLn("         -copyright ==> display copyright notice");
+      WLn("         -generics  ==> enable CLI v2.0 generics");
+      WLn("         -help      ==> display this message");
+      WLn("         -legacy    ==> produce compatible symbol file");
+      WLn("         -verbose   ==> chatter on about progress"); 
+      WLn("         -Verbose   ==> go on and on and on about progress"); 
+    END;
+  END Usage;
+
+ (* ---------------------------------------------------------- *)
+
+  PROCEDURE ReportTim(tim : LONGINT);
+    CONST millis = " mSec";
+  BEGIN
+    Console.WriteInt(SHORT(tim), 0);
+    Console.WriteString(millis);
+  END ReportTim;
+
+  PROCEDURE Report*(IN nam, res : ARRAY OF CHAR; tim : LONGINT);
+  BEGIN
+    Console.WriteString(prefix);
+    Console.WriteString(" Input file <");
+    Console.WriteString(nam);
+    Console.WriteString("> ");
+    Console.WriteString(res);
+    IF verbose THEN
+      Console.WriteString(", time: ");
+      ReportTim(tim);
+    END;
+    Console.WriteLn;
+  END Report;
+
+  PROCEDURE Summary*(flNm, okNm : INTEGER; tim : LONGINT);
+    CONST sumPre = " Summary: ";
+  BEGIN
+    Console.WriteString(prefix);
+    Console.WriteString(sumPre);
+    IF flNm = 0 THEN
+      Console.WriteString(" No input files specified");
+    ELSE
+      Console.WriteInt(flNm,1); 
+      Console.WriteString(" input files");
+      IF okNm < flNm THEN
+        Console.WriteInt(flNm - okNm, 0); 
+        Console.WriteString(" failed");
+      END;
+      IF verbose THEN
+        Console.WriteLn;
+        Console.WriteString(prefix);
+        Console.WriteString(sumPre);
+        Console.WriteString("Total elapsed time: ");
+        ReportTim(tim);
+      END;
+    END;
+    Console.WriteLn;
+  END Summary;
+
+ (* ---------------------------------------------------------- *)
+
+  PROCEDURE ParseOption*(IN arg : ARRAY OF CHAR);
+  BEGIN
+    IF    arg = "-big" THEN
+        hashSize := 40000;
+    ELSIF arg = "-verbose" THEN
+        verbose := TRUE;
+        Verbose := FALSE;
+        superVb := FALSE;
+    ELSIF arg = "-Verbose" THEN
+        verbose := TRUE;
+        Verbose := TRUE;
+        superVb := FALSE;
+    ELSIF arg = "-generics" THEN
+        generics := TRUE;
+    ELSIF arg = "-legacy" THEN
+        legacy := TRUE;
+        CompState.legacy := TRUE;
+    ELSIF arg = "-VERBOSE" THEN
+        verbose := TRUE;
+        Verbose := TRUE;
+        superVb := TRUE;
+    ELSIF arg = "-help" THEN
+        Usage();
+    ELSIF arg = "-copyright" THEN
+        GPCPcopyright.Write();
+    ELSE  
+        Message("Bad Option " + arg); Usage;
+    END;
+  END ParseOption;
+
+ (* ---------------------------------------------------------- *)
+
+  PROCEDURE EmitSymbolfile*(blk : Id.BlkId);
+  BEGIN
+    RW.EmitSymfile(blk);
+    Message(" Output file <" +
+            Nh.charOpenOfHash(blk.hash)^ + 
+            ".cps> created");
+  END EmitSymbolfile;
+
+ (* ---------------------------------------------------------- *)
+
+BEGIN
+  netDflt  := (RTS.defaultTarget = "net");
+  generics := FALSE;
+  verbose  := FALSE;
+  Verbose  := FALSE;
+  superVb  := FALSE;
+  legacy   := FALSE;
+  cpCmpld  := FALSE; (* pending the custom attribute *)
+  hashSize := 5000;
+  Sy.InitScpSeq(impSeq, 10);
+  Sy.InitTypeSeq(typSeq, 10);
+  CompState.ParseOption("/special");
+END N2State.

libs/cpascal/ASCII.cp

@@ -0,0 +1,45 @@
+(** This is the dummy module that sits in the runtime system, 
+  * or will do if it ever gets a body.
+  *
+  * Version:	19 May      2001 (kjg).
+  *)
+
+SYSTEM MODULE ASCII;
+
+  CONST
+    NUL* = 00X;
+    SOH* = 01X;
+    STX* = 02X;
+    ETX* = 03X;
+    EOT* = 04X;
+    ENQ* = 05X;
+    ACK* = 06X;
+    BEL* = 07X;
+    BS*  = 08X;		(* backspace character *)
+    HT*  = 09X;		(* horizontal tab character *)
+    LF*  = 0AX;		(* line feed character *)
+    VT*  = 0BX;
+    FF*  = 0CX;
+    CR*  = 0DX; 	(* carriage return character *)
+    SO*  = 0EX;
+    SI*  = 0FX;
+    DLE* = 10X;
+    DC1* = 11X;
+    DC2* = 12X;
+    DC3* = 13X;
+    DC4* = 14X;
+    NAK* = 15X;
+    SYN* = 16X;
+    ETB* = 17X;
+    CAN* = 18X;
+    EM*  = 19X;
+    SUB* = 1AX;
+    ESC* = 1BX;		(* escape character *)
+    FS*  = 1CX;
+    GS*  = 1DX;
+    RS*  = 1EX;
+    US*  = 1FX;
+    SP*  = 20X;		(* space character  *)
+    DEL* = 7FX;		(* delete character *)
+
+END ASCII.

libs/cpascal/CPmain.cp

@@ -0,0 +1,19 @@
+(* 
+ *  Library module for GP Component Pascal.
+ *  This module name is "magic" in the sense that its name is known
+ *  to the compiler. If it is imported, the module will be compiled
+ *  so that its body is named "main" with an arglist, rather than
+ *  being in the static initializer <clinit>()V in JVM-speak.
+ *
+ *  Original : kjg November 1998
+ *
+ *  This is a dummy module, it exists only to cause the 
+ *  generation of a corresponding symbol file: CPmain.cps
+ *  when compiled with the -special flag.
+ *)
+SYSTEM MODULE CPmain;
+
+  PROCEDURE ArgNumber*() : INTEGER; 
+  PROCEDURE GetArg*(num : INTEGER; OUT arg : ARRAY OF CHAR); 
+
+END CPmain.

libs/cpascal/Console.cp

@@ -0,0 +1,23 @@
+(* 
+ *  Library module for GP Component Pascal.
+ *  Low level reading and writing to the command-line console.
+ *  Original : kjg November 1998
+ *
+ *
+ *  This is a dummy module, it exists only to cause the 
+ *  generation of a corresponding symbol file: Console.cps
+ *  when compiled with the -special flag.
+ *)
+SYSTEM MODULE Console;
+
+  PROCEDURE WriteLn*();
+
+  PROCEDURE Write*(ch : CHAR);
+
+  PROCEDURE WriteString*(IN str : ARRAY OF CHAR);
+
+  PROCEDURE WriteInt*(val : INTEGER; width : INTEGER); 
+
+  PROCEDURE WriteHex*(val : INTEGER; width : INTEGER);
+
+END Console.

libs/cpascal/Error.cp

@@ -0,0 +1,23 @@
+(* 
+ *  Library module for GP Component Pascal.
+ *  Low level reading and writing to the command-line console.
+ *  Original : kjg November 1998
+ *
+ *
+ *  This is a dummy module, it exists only to cause the 
+ *  generation of a corresponding symbol file: Error.cps
+ *  when compiled with the -special flag.
+ *)
+SYSTEM MODULE Error;
+
+  PROCEDURE WriteLn*(); 
+
+  PROCEDURE Write*(ch : CHAR); 
+
+  PROCEDURE WriteString*(IN str : ARRAY OF CHAR);
+
+  PROCEDURE WriteInt*(val : INTEGER; width : INTEGER); 
+
+  PROCEDURE WriteHex*(val : INTEGER; width : INTEGER);
+
+END Error.

libs/cpascal/GPBinFiles.cp

@@ -0,0 +1,39 @@
+FOREIGN MODULE GPBinFiles;
+
+IMPORT GPFiles;
+
+TYPE
+  FILE* = POINTER TO RECORD (GPFiles.FILE) END;
+
+
+PROCEDURE length*(f : FILE) : INTEGER;
+
+PROCEDURE findLocal*(IN fileName : ARRAY OF CHAR) : FILE;
+
+PROCEDURE findOnPath*(IN pathName : ARRAY OF CHAR;
+		      IN fileName : ARRAY OF CHAR) : FILE;
+
+PROCEDURE getFullPathName*(f : FILE) : GPFiles.FileNameArray;
+
+PROCEDURE openFile*(IN fileName : ARRAY OF CHAR) : FILE;
+PROCEDURE openFileRO*(IN fileName : ARRAY OF CHAR) : FILE;
+
+PROCEDURE CloseFile*(file : FILE);
+
+PROCEDURE createFile*(IN fileName : ARRAY OF CHAR) : FILE;
+
+PROCEDURE createPath*(IN pathName : ARRAY OF CHAR) : FILE;
+
+PROCEDURE EOF*(file : FILE) : BOOLEAN;
+
+PROCEDURE readByte*(file : FILE) : INTEGER;
+ 
+PROCEDURE readNBytes*(file : FILE; OUT buffPtr : ARRAY OF UBYTE;
+                     requestedBytes : INTEGER) : INTEGER;
+ 
+PROCEDURE WriteByte*(file : FILE; b : INTEGER);
+
+PROCEDURE WriteNBytes*(file : FILE; IN buffPtr : ARRAY OF UBYTE;
+                       requestedBytes : INTEGER);
+
+END GPBinFiles.

libs/cpascal/GPFiles.cp

@@ -0,0 +1,19 @@
+FOREIGN MODULE GPFiles;
+  TYPE
+	FILE* = POINTER TO ABSTRACT RECORD END;
+	FileNameArray* = POINTER TO ARRAY OF CHAR;
+
+  VAR
+	pathSep- : CHAR; (* path separator on this platform *)
+	fileSep- : CHAR; (* filename separator character    *)
+	optChar- : CHAR; (* option introduction character   *)
+
+PROCEDURE isOlder*(first : FILE; second : FILE) : BOOLEAN;
+
+PROCEDURE MakeDirectory*(dirName : ARRAY OF CHAR);
+
+PROCEDURE CurrentDirectory*(): FileNameArray;
+
+PROCEDURE exists*(fName : ARRAY OF CHAR) : BOOLEAN;
+
+END GPFiles.

libs/cpascal/GPTextFiles.cp

@@ -0,0 +1,46 @@
+FOREIGN MODULE GPTextFiles;
+
+IMPORT GPFiles;
+
+TYPE
+  FILE* = POINTER TO RECORD (GPFiles.FILE) END;
+
+
+PROCEDURE findLocal*(IN fileName : ARRAY OF CHAR) : FILE;
+(** Find file with given name in current directory *)
+
+PROCEDURE findOnPath*(IN pathName : ARRAY OF CHAR;
+		      IN fileName : ARRAY OF CHAR) : FILE;
+(** Find file with given name on path given as property *)
+
+PROCEDURE getFullPathName*(f : FILE) : GPFiles.FileNameArray;
+(** Return full name of file *)
+
+PROCEDURE openFile*(IN fileName : ARRAY OF CHAR) : FILE;
+(** Open file with given absolute name *)
+
+PROCEDURE openFileRO*(IN fileName : ARRAY OF CHAR) : FILE;
+(** Open file READ-ONLY with given absolute name *)
+
+PROCEDURE CloseFile*(file : FILE);
+
+PROCEDURE createFile*(IN fileName : ARRAY OF CHAR) : FILE;
+(** Create file and open for reading *)
+
+PROCEDURE createPath*(IN pathName : ARRAY OF CHAR) : FILE;
+(** Create file and any necessary directories and opens file for reading *)
+
+PROCEDURE readChar*(file : FILE) : CHAR;
+ 
+PROCEDURE readNChars*(file : FILE; OUT buffPtr : ARRAY OF CHAR;
+                     requestedChars : INTEGER) : INTEGER;
+(** Return value is number actually read *)
+ 
+PROCEDURE WriteEOL*(file : FILE);
+
+PROCEDURE WriteChar*(file : FILE; ch : CHAR);
+
+PROCEDURE WriteNChars*(file : FILE; IN buffPtr : ARRAY OF CHAR;
+                      requestedChars : INTEGER);
+
+END GPTextFiles.

libs/cpascal/MakeAll.bat

@@ -0,0 +1,23 @@
+gpcp /special ASCII.cp
+gpcp /special Console.cp
+gpcp /special CPmain.cp
+gpcp /special Error.cp
+gpcp /special GPBinFiles.cp
+gpcp /special GPFiles.cp
+gpcp /special GPTextFiles.cp
+gpcp /special ProgArgs.cp
+gpcp /special RTS.cp
+gpcp /special StdIn.cp
+gpcp RealStr.cp
+gpcp StringLib.cp
+Browse /html /sort ASCII.cps
+Browse /html /sort Console.cps
+Browse /html /sort Error.cps
+Browse /html /sort GPFiles.cps
+Browse /html /sort GPBinFiles.cps
+Browse /html /sort GPTextFiles.cps
+Browse /html /sort RTS.cps
+Browse /html /sort StdIn.cps
+Browse /html /sort RealStr.cps
+Browse /html /sort StringLib.cps
+

libs/cpascal/RTS.cp

@@ -0,0 +1,178 @@
+(** This is the user accessible static methods of the CP runtime system.
+  * These are the environment-independent ones. Others are in CP*.cp
+  * Note:  the bodies of these procedures are dummies, this module is
+  *        compiled with -special.  The real code is in RTS.java or other.
+  *
+  * Version:     7 July     1999 (kjg).
+  *             20 February 2000 (kjg)  Default target ...
+  *              4 July     2000 (kjg)  Native types ...
+  *              4 August   2001 (syc,kjg)  more methods...
+  *                         2004 (kjg) vector support and globalization
+  *)
+
+(* ============================================================ *)
+SYSTEM MODULE RTS;
+
+  VAR defaultTarget- : ARRAY 4 OF CHAR;
+      fltNegInfinity-   : SHORTREAL;
+      fltPosInfinity-   : SHORTREAL;
+      dblNegInfinity-   : REAL;
+      dblPosInfinity-   : REAL;
+
+  TYPE  CharOpen*       = POINTER TO ARRAY OF CHAR;
+
+  TYPE  NativeType*	= POINTER TO ABSTRACT RECORD END;
+        NativeObject*   = POINTER TO ABSTRACT RECORD END;  
+        NativeString*   = POINTER TO RECORD END;
+        NativeException*= POINTER TO EXTENSIBLE RECORD END;
+
+  VAR   eol- : POINTER TO ARRAY OF CHAR; (* OS-specific end of line string *)
+
+  (* ========================================================== *)
+  (* ============= Support for native exceptions ==============	*)
+  (* ========================================================== *)
+  PROCEDURE getStr*(x : NativeException) : CharOpen; 
+
+  PROCEDURE Throw*(IN s : ARRAY OF CHAR);
+  (** Abort execution with an error *)
+
+  (* ========================================================== *)
+  (* ============= Conversions FROM array of char ============= *)
+  (* ========================================================== *)
+  PROCEDURE StrToBool*(IN s : ARRAY OF CHAR; OUT b : BOOLEAN; OUT ok : BOOLEAN);
+  (** Parse array into a BOOLEAN TRUE/FALSE *)
+
+  PROCEDURE StrToByte*(IN s : ARRAY OF CHAR; OUT b : BYTE; OUT ok : BOOLEAN);
+  (** Parse array into a BYTE integer *)
+
+  PROCEDURE StrToUByte*(IN s : ARRAY OF CHAR; OUT b : BYTE; OUT ok : BOOLEAN);
+  (** Parse array into a BYTE integer *)
+
+  PROCEDURE StrToShort*(IN s : ARRAY OF CHAR; OUT si : SHORTINT; OUT ok : BOOLEAN);
+  (** Parse an array into a CP LONGINT *)
+
+  PROCEDURE StrToUShort*(IN s:ARRAY OF CHAR; OUT si:SHORTINT; OUT ok:BOOLEAN);
+  (** Parse an array into a CP LONGINT *)
+
+  PROCEDURE StrToInt*(IN s:ARRAY OF CHAR; OUT i:INTEGER; OUT ok:BOOLEAN);
+  (** Parse an array into a CP INTEGER *)
+
+  PROCEDURE StrToUInt*(IN s:ARRAY OF CHAR; OUT i:INTEGER; OUT ok:BOOLEAN);
+  (** Parse an array into a CP INTEGER *)
+
+  PROCEDURE StrToLong*(IN s:ARRAY OF CHAR; OUT i:LONGINT; OUT ok:BOOLEAN);
+  (** Parse an array into a CP LONGINT *)
+
+  PROCEDURE StrToULong*(IN s:ARRAY OF CHAR; OUT i:LONGINT; OUT ok:BOOLEAN);
+  (** Parse an array into a CP LONGINT *)
+
+  PROCEDURE HexStrToUByte*(IN s:ARRAY OF CHAR; OUT b:BYTE; OUT ok:BOOLEAN);
+  (** Parse hexadecimal array into a BYTE integer *)
+
+(* ------------------- Low-level String Conversions -------------------- *)
+(* Three versions for different cultures.  *Invar uses invariant culture *)
+(*                                         *Local uses current locale    *)
+(* StrToReal & RealToStr do not behave the same on JVM and CLR.          *)
+(* They is provided for compatability with versions < 1.3.1              *)
+(* ------------------- Low-level String Conversions -------------------- *)
+
+  PROCEDURE StrToReal*(IN  s  : ARRAY OF CHAR; 
+                       OUT r  : REAL; 
+                       OUT ok : BOOLEAN);
+  (** Parse array into an ieee double REAL *)
+
+  PROCEDURE StrToRealInvar*(IN  s  : ARRAY OF CHAR; 
+                            OUT r  : REAL; 
+                            OUT ok : BOOLEAN);
+  (** Parse array using invariant culture, into an ieee double REAL *)
+
+  PROCEDURE StrToRealLocal*(IN  s  : ARRAY OF CHAR; 
+                            OUT r  : REAL; 
+                            OUT ok : BOOLEAN);
+  (** Parse array using current locale, into an ieee double REAL *)
+
+  PROCEDURE StrToSReal*(IN  s  : ARRAY OF CHAR; 
+                        OUT r  : SHORTREAL; 
+                        OUT ok : BOOLEAN);
+  PROCEDURE StrToSRealInvar*(IN  s  : ARRAY OF CHAR; 
+                        OUT r  : SHORTREAL; 
+                        OUT ok : BOOLEAN);
+  PROCEDURE StrToSRealLocal*(IN  s  : ARRAY OF CHAR; 
+                        OUT r  : SHORTREAL; 
+                        OUT ok : BOOLEAN);
+  (** Parse array into a short REAL *)
+
+  (* ========================================================== *)
+  (* ============== Conversions TO array of char ============== *)
+  (* ========================================================== *)
+  PROCEDURE RealToStr*(r : REAL; OUT s : ARRAY OF CHAR);
+  (** Decode a CP REAL into an array *)
+
+  PROCEDURE RealToStrInvar*(r : REAL; OUT s : ARRAY OF CHAR);
+  (** Decode a CP REAL into an array in invariant culture *)
+
+  PROCEDURE RealToStrLocal*(r : REAL; OUT s : ARRAY OF CHAR);
+  (** Decode a CP REAL into an array in the current locale *)
+
+  PROCEDURE SRealToStr*(r : SHORTREAL; OUT s : ARRAY OF CHAR);
+  PROCEDURE SRealToStrInvar*(r : SHORTREAL; OUT s : ARRAY OF CHAR);
+  PROCEDURE SRealToStrLocal*(r : SHORTREAL; OUT s : ARRAY OF CHAR);
+  (** Decode a CP SHORTREAL into an array *)
+  (* ========================================================== *)
+
+  PROCEDURE IntToStr*(i : INTEGER; OUT s : ARRAY OF CHAR);
+  (** Decode a CP INTEGER into an array *)
+
+  PROCEDURE ObjToStr*(obj : ANYPTR; OUT s : ARRAY OF CHAR);
+  (** Decode a CP INTEGER into an array *)
+
+  PROCEDURE LongToStr*(i : LONGINT; OUT s : ARRAY OF CHAR);
+  (** Decode a CP INTEGER into an array *)
+
+  (* ========================================================== *)
+  (* ========== Casts with no representation change =========== *)
+  (* ========================================================== *)
+  PROCEDURE realToLongBits*(r : REAL) : LONGINT;
+  (** Convert an ieee double into a longint with same bit pattern *)
+
+  PROCEDURE longBitsToReal*(l : LONGINT) : REAL;
+  (** Convert an ieee double into a longint with same bit pattern *)
+
+  PROCEDURE shortRealToIntBits*(r : SHORTREAL) : INTEGER;
+  (** Convert an ieee float into an int with same bit pattern *)
+
+  PROCEDURE intBitsToShortReal*(i : INTEGER) : SHORTREAL;
+  (** Convert an int into an ieee float with same bit pattern *)
+
+  PROCEDURE hiByte*(i : SHORTINT) : BYTE;
+  (** Get hi-significant word of short *)
+
+  PROCEDURE loByte*(i : SHORTINT) : BYTE;
+  (** Get lo-significant word of short *)
+
+  PROCEDURE hiShort*(i : INTEGER) : SHORTINT;
+  (** Get hi-significant word of integer *)
+
+  PROCEDURE loShort*(i : INTEGER) : SHORTINT;
+  (** Get lo-significant word of integer *)
+
+  PROCEDURE hiInt*(l : LONGINT) : INTEGER;
+  (** Get hi-significant word of long integer *)
+
+  PROCEDURE loInt*(l : LONGINT) : INTEGER;
+  (** Get lo-significant word of long integer *)
+
+  (* ========================================================== *)
+  (* ============= Various utility procedures ================= *)
+  (* ========================================================== *)
+  PROCEDURE GetMillis*() : LONGINT;
+  (** Get time in milliseconds *)
+
+  PROCEDURE GetDateString*(OUT str : ARRAY OF CHAR);
+  (** Get a date string in some native format *)
+
+  PROCEDURE ClassMarker*(o : ANYPTR);
+  (** Write class name to standard output *)
+
+(* ============================================================ *)
+END RTS.

libs/cpascal/RealStr.cp

@@ -0,0 +1,442 @@
+MODULE RealStr;
+(*
+ * Purpose:
+ *   Provides REAL/string conversions
+ *
+ * Log:
+ *   April 96  jl  initial version
+ *
+ * Notes:
+ *   Complies with ISO/IEC 10514-1:1996  (as RealStr)
+ *
+ * Modified for Component Pascal by kjg, February 2004
+ *
+ *)
+
+  IMPORT RTS;
+
+(***************************************************************)
+(*                                                             *)
+(*                   PRIVATE - NOT EXPORTED                    *)
+(*                                                             *)
+(***************************************************************)
+
+  CONST
+     err = 9999;
+
+  TYPE
+     CharPtr  = POINTER TO ARRAY OF CHAR;
+     DigArray = ARRAY 28 OF CHAR;
+
+  (*===============================================================*)
+
+  PROCEDURE Message(OUT str : ARRAY OF CHAR; IN mss : ARRAY OF CHAR);
+    VAR idx : INTEGER;
+  BEGIN
+    idx := 0;
+    WHILE (idx < LEN(str)) & (idx < LEN(mss)) DO
+      str[idx] := mss[idx]; INC(idx);
+    END;
+    IF idx < LEN(str) THEN str[idx] := 0X END;
+  END Message;
+
+  (*===============================================================*)
+
+  PROCEDURE expLen(exp : INTEGER) : INTEGER;
+  BEGIN
+    exp := ABS(exp);
+    IF    exp < 10  THEN RETURN 3;
+    ELSIF exp < 100 THEN RETURN 4;
+    ELSE  RETURN 5;
+    END;
+  END expLen;
+
+  (*===============================================================*)
+
+  PROCEDURE  CopyCh(ch : CHAR;
+        	VAR ix : INTEGER;
+        	VAR st : ARRAY OF CHAR);
+  BEGIN
+    IF ix < LEN(st) THEN st[ix] := ch; INC(ix) END;
+  END CopyCh;
+
+  (*===============================================================*)
+
+  PROCEDURE CopyExp(ex : INTEGER;
+        	VAR ix : INTEGER;
+		VAR st : ARRAY OF CHAR);
+    VAR abX, val, len, idx, dHi : INTEGER;
+  BEGIN
+    dHi := LEN(st) - 1;
+    len := expLen(ex);
+    IF ix + len > dHi THEN ix := dHi - len END;
+    IF ix < 2 THEN
+      FOR idx := 0 TO MIN(ix+len, dHi-1) DO st[idx] := "*"; ix := idx+1 END;
+    ELSE
+      CopyCh("E",ix,st);
+      IF ex > 0 THEN CopyCh("+",ix,st) ELSE CopyCh("-",ix,st) END;
+      abX := ABS(ex); val := abX;
+      IF abX >= 100 THEN 
+        CopyCh(CHR(val DIV 100 + ORD("0")),ix,st);
+        val := val MOD 100;
+      END;
+      IF abX >= 10 THEN 
+        CopyCh(CHR(val DIV 10 + ORD("0")),ix,st);
+      END;
+      CopyCh(CHR(val MOD 10 + ORD("0")),ix,st);
+    END;
+  END CopyExp;
+
+  (*===============================================================*)
+
+  PROCEDURE GetDigits(real   : REAL;
+                  OUT digits : DigArray;
+                  OUT dPoint : INTEGER;
+                  OUT isNeg  : BOOLEAN);
+    VAR rIdx : INTEGER;      (* the read index   *)
+        wIdx : INTEGER;      (* the write index  *)
+        iLen : INTEGER;      (* integer part len *)
+        eVal : INTEGER;      (* exponent value   *)
+        buff : DigArray;     (* temporary buffer *)
+        eNeg : BOOLEAN;      (* exponent is neg. *)
+        rChr : CHAR;         (* last read char   *)
+  BEGIN
+   (* 
+    *  We want to assert that digit[0] # "0", 
+    *  unless real = zero. So to avoid a sack o'woe 
+    *)
+    IF real = 0.0 THEN
+      digits := "0";
+      dPoint := 1;
+      isNeg  := FALSE; RETURN;      (* PREEMPTIVE RETURN HERE *)
+    END;
+
+    RTS.RealToStrInvar(real, buff);
+    rIdx := 0;
+    wIdx := 0;
+    eVal := 0;
+   (* get optional sign *)
+    isNeg := (buff[0] = "-");
+    IF isNeg THEN INC(rIdx) END;
+    
+    rChr := buff[rIdx]; INC(rIdx);
+    WHILE rChr = "0" DO 
+      rChr := buff[rIdx]; INC(rIdx);
+    END;
+
+   (* get integer part *)
+    WHILE (rChr <= "9") & (rChr >= "0") DO
+      digits[wIdx] := rChr; INC(wIdx);
+      rChr := buff[rIdx];   INC(rIdx);
+    END;
+    iLen := wIdx;              (* integer part ended  *)
+
+    IF rChr = "." THEN         (* get fractional part *)
+      rChr := buff[rIdx];   INC(rIdx);
+      IF wIdx = 0 THEN
+       (* count any leading zeros *)
+        WHILE rChr = "0" DO 
+          rChr := buff[rIdx]; INC(rIdx); DEC(iLen);
+        END;
+      END;
+
+      WHILE (rChr <= "9") & (rChr >= "0") DO
+        digits[wIdx] := rChr; INC(wIdx);
+        rChr := buff[rIdx];   INC(rIdx);
+      END;
+    END;
+    digits[wIdx] := 0X;        (* terminate char arr. *)
+
+    IF (rChr = "E") OR (rChr = "e") THEN
+                               (* get fractional part *)
+      rChr := buff[rIdx];   INC(rIdx);
+      IF rChr = "-" THEN
+        eNeg := TRUE;
+        rChr := buff[rIdx]; INC(rIdx);
+      ELSE
+        eNeg := FALSE;
+        IF rChr = "+" THEN rChr := buff[rIdx]; INC(rIdx) END;
+      END;
+      WHILE (rChr <= "9") & (rChr >= "0") DO
+        eVal := eVal * 10;
+        INC(eVal, (ORD(rChr) - ORD("0")));
+        rChr := buff[rIdx]; INC(rIdx);
+      END;
+      IF eNeg THEN eVal := -eVal END;
+    END;
+
+   (* At this point, if we are not ended, we have a NaN *)
+    IF rChr # 0X THEN 
+      digits := buff; dPoint := err;
+    ELSE
+     (* Index of virtual decimal point is eVal + iLen *)
+      DEC(eVal);
+      dPoint := iLen + eVal;
+    END;
+  END GetDigits;
+
+(***************************************************************)
+
+  PROCEDURE RoundRelative(VAR str : DigArray;
+                          VAR exp : INTEGER;
+                              num : INTEGER);
+    VAR len : INTEGER;
+        idx : INTEGER;
+        chr : CHAR;
+  BEGIN
+    len := LEN(str$);   (* we want num+1 digits *)
+    IF num < 0 THEN
+      str[0] := 0X;
+    ELSIF num = 0 THEN
+      chr := str[0];
+      IF chr > "4" THEN 
+        str := "1"; INC(exp);
+      ELSE 
+        str[num] := 0X;
+      END;
+    ELSIF num < len THEN
+      chr := str[num];
+      IF chr > "4" THEN (* round up str[num-1]  *)
+        idx := num-1;
+        LOOP
+          str[idx] := CHR(ORD(str[idx]) + 1);
+          IF str[idx] <= "9" THEN EXIT;
+          ELSE
+            str[idx] := "0"; (* and propagate *)
+            IF idx = 0 THEN  (* need a shift  *)
+              FOR idx := num TO 0 BY -1 DO str[idx+1] := str[idx] END;
+              str[0] := "1"; INC(exp); EXIT;
+            END;
+          END;
+          DEC(idx);
+        END;
+      END;
+      str[num] := 0X;
+    END;
+  END RoundRelative;
+
+(***************************************************************)
+(*                                                             *)
+(*                     PUBLIC - EXPORTED                       *)
+(*                                                             *)
+(***************************************************************)
+
+ (*===============================================================*
+  *
+  * Ignores any leading spaces in str. If the subsequent characters in str 
+  * are in the format of a signed real number, assigns a corresponding value 
+  * to real.  Assigns a value indicating the format of str to res.
+  *)
+  PROCEDURE StrToReal*(str  : ARRAY OF CHAR; 
+                   OUT real : REAL; 
+                   OUT res  : BOOLEAN);
+
+    VAR clrStr : RTS.NativeString;
+  BEGIN
+    clrStr := MKSTR(str);
+    RTS.StrToRealInvar(clrStr, real, res);
+  END StrToReal;
+
+ (*===============================================================*
+  *
+  * Converts the value of real to floating-point string form, with sigFigs
+  * significant digits, and copies the possibly truncated result to str.
+  *)
+  PROCEDURE RealToFloat*(real    : REAL; 
+                         sigFigs : INTEGER; 
+                     OUT str     : ARRAY OF CHAR);
+
+    VAR len, fWid, index, ix : INTEGER;
+        dExp   : INTEGER; (* decimal exponent *)
+	neg    : BOOLEAN;
+	digits : DigArray;
+  BEGIN
+    GetDigits(real, digits, dExp, neg);
+    IF dExp = err THEN Message(str, digits); RETURN END;
+    RoundRelative(digits, dExp, sigFigs); 
+
+    index := 0;
+    IF neg THEN CopyCh("-", index, str) END;
+    fWid := LEN(digits$);
+    IF fWid = 0 THEN  (* result is 0 *)
+      CopyCh("0", index, str);
+      dExp := 0;
+    ELSE
+      CopyCh(digits[0], index, str);
+    END;
+    IF sigFigs > 1 THEN 
+      CopyCh(".",index,str);
+      IF fWid > 1 THEN
+        FOR ix := 1  TO fWid - 1    DO CopyCh(digits[ix], index, str) END;
+      END;
+      FOR ix := fWid TO sigFigs - 1 DO CopyCh("0", index, str) END;
+    END;
+(*
+ *  IF dExp # 0 THEN CopyExp(dExp,index,str) END;
+ *)
+    CopyExp(dExp,index,str);
+    IF index <= LEN(str)-1 THEN str[index] := 0X END;
+  END RealToFloat;
+
+ (*===============================================================*
+  *
+  * Converts the value of real to floating-point string form, with sigFigs
+  * significant digits, and copies the possibly truncated result to str.
+  * The number is scaled with one to three digits in the whole number part and
+  * with an exponent that is a multiple of three.
+  *)
+  PROCEDURE RealToEng*(real    : REAL; 
+                       sigFigs : INTEGER; 
+                   OUT str     : ARRAY OF CHAR);
+    VAR len, index, ix : INTEGER;
+        dExp   : INTEGER; (* decimal exponent *)
+        fact   : INTEGER;
+        neg    : BOOLEAN;
+	digits : DigArray;
+  BEGIN
+    GetDigits(real, digits, dExp, neg);
+    IF dExp = err THEN Message(str, digits); RETURN END;
+    RoundRelative(digits, dExp, sigFigs); 
+
+    len := LEN(digits$); INC(dExp);
+    IF len = 0 THEN dExp := 1 END;  (* result = 0 *)
+    fact := ((dExp - 1) MOD 3) + 1;
+    DEC(dExp,fact);	(* make exponent multiple of three *)
+
+    index := 0;
+    IF neg THEN CopyCh("-",index,str) END;
+    IF fact <= len THEN
+      FOR ix := 0   TO fact - 1 DO CopyCh(digits[ix],index,str) END;
+    ELSE
+      IF len > 0 THEN
+        FOR ix := 0 TO len  - 1 DO CopyCh(digits[ix],index,str) END;
+      END;
+      FOR ix := len TO fact - 1 DO CopyCh("0",index,str) END;
+    END;
+    IF fact < sigFigs THEN 
+      CopyCh(".",index,str);
+      IF fact < len THEN
+        FOR ix := fact TO len - 1 DO CopyCh(digits[ix],index,str) END;
+      ELSE
+        len := fact;
+      END;
+      FOR ix := len TO sigFigs - 1 DO CopyCh("0",index,str) END;
+    END;
+(*
+ *  IF dExp # 0 THEN CopyExp(dExp,index,str) END;
+ *)
+    CopyExp(dExp,index,str);
+    IF index <= LEN(str)-1 THEN str[index] := 0X END;
+  END RealToEng;
+
+ (*===============================================================*
+  *
+  * Converts the value of real to fixed-point string form, rounded to the 
+  * given place relative to the decimal point, and copies the result to str.
+  *)
+  PROCEDURE RealToFixed*(real  : REAL; 
+                         place : INTEGER; (* requested no of frac. places *)
+                     OUT str   : ARRAY OF CHAR);
+    VAR lWid   : INTEGER;     (* Leading digit-str width  *)
+        fWid   : INTEGER;     (* Width of fractional part *)
+        tWid   : INTEGER;     (* Total width of str-rep.  *)
+        zWid   : INTEGER;     (* Leading zeros in frac.   *)
+        len    : INTEGER;     (* Significant digit length *)
+        dExp   : INTEGER;     (* Pos. of rad. in dig-arr. *)
+        dLen   : INTEGER;     (* Length of dest. array    *)
+
+        index  : INTEGER;
+        ix     : INTEGER;
+        neg    : BOOLEAN;
+        radix  : BOOLEAN;
+	digits : DigArray;
+  BEGIN
+   (* the decimal point and fraction part *)
+   (* ["-"] "0" "." d^(fWid)       -- if dExp < 0 *)
+   (* ["-"] d^(lWid) "." d^(fWid)  -- if fWid > 0 *)
+   (* ["-"] d^(lWid)               -- if fWid = 0 *)
+  
+    tWid := 0;
+    dLen := LEN(str);
+    IF place >= 0 THEN fWid := place ELSE fWid := 0 END;
+    radix := (fWid > 0);
+
+    GetDigits(real, digits, dExp, neg);
+    IF dExp = err THEN Message(str, digits); RETURN END;
+
+    RoundRelative(digits, dExp, place+dExp+1); (* this can change dExp! *)
+
+    (* Semantics of dExp value    *)
+    (*  012345 ...  digit index   *)
+    (*  dddddd ...  digit content *)
+    (*    ^-------- dExp value    *)
+    (* "ddd.ddd..." result str.   *)
+
+    len := LEN(digits$); 
+    IF len = 0 THEN neg := FALSE END; (* don't print "-0" *)
+    IF dExp >= 0 THEN lWid := dExp+1 ELSE lWid := 1 END;
+
+    IF neg   THEN INC(tWid) END;
+    IF radix THEN INC(tWid) END;
+    INC(tWid, lWid);
+    INC(tWid, fWid);
+
+    IF tWid > dLen THEN tWid := dLen END;
+
+    index := 0;
+   (*
+    *  Now copy the optional signe
+    *)
+    IF neg THEN CopyCh("-",index,str) END;
+   (*
+    *  Now copy the integer part
+    *)
+    IF dExp < 0 THEN 
+      CopyCh("0",index,str);
+    ELSE
+      IF lWid <= len THEN
+        FOR ix := 0   TO lWid - 1 DO CopyCh(digits[ix],index,str) END;
+      ELSE
+        IF len > 0 THEN
+          FOR ix := 0 TO len - 1  DO CopyCh(digits[ix],index,str) END;
+        END;
+        FOR ix := len TO lWid - 1 DO CopyCh("0",index,str) END;
+      END;
+    END;
+   (*
+    *  Now copy the fractional part
+    *)
+    IF radix THEN 
+      CopyCh(".",index,str);
+      IF dExp < 0 THEN
+       (*   012345 ...  digit idx  *)
+       (*   dddddd ...  digit str. *)
+       (*  ^-------- dExp = -1     *)
+        zWid := MIN(-dExp-1, fWid); (* leading zero width *)
+        FOR ix := 0 TO zWid - 1 DO CopyCh("0",index,str) END;
+        FOR ix := 0 TO len - 1  DO CopyCh(digits[ix],index,str) END;
+      ELSIF lWid < len THEN
+        FOR ix := lWid TO len - 1 DO CopyCh(digits[ix],index,str) END;
+      END;
+      WHILE index < tWid DO CopyCh("0",index,str) END;
+    END;
+    IF index <= dLen-1 THEN str[index] := 0X END;
+  END RealToFixed;
+
+ (*===============================================================*
+  *
+  * Converts the value of real as RealToFixed if the sign and magnitude can be
+  * shown within the capacity of str, or otherwise as RealToFloat, and copies
+  * the possibly truncated result to str.
+  * The number of places or significant digits are implementation-defined.
+  *)
+  PROCEDURE RealToStr*(real: REAL; OUT str: ARRAY OF CHAR);
+  BEGIN
+    RTS.RealToStrInvar(real, str);
+  RESCUE (x);
+    RealToFloat(real, 16, str);
+  END RealToStr;
+
+(* ---------------------------------------- *)
+
+END RealStr.

libs/cpascal/StdIn.cp

@@ -0,0 +1,23 @@
+(* 
+ *  Library module for GP Component Pascal.
+ *  Low level reading and writing to the command-line console.
+ *  Original : kjg November 1998
+ *
+ *
+ *  This is a dummy module, it exists only to cause the 
+ *  generation of a corresponding symbol file: StdIn.cps
+ *  when compiled with the -special flag.
+ *)
+SYSTEM MODULE StdIn;
+
+  PROCEDURE SkipLn*();  
+  (* Read past next line marker *)
+
+  PROCEDURE ReadLn*(OUT arr : ARRAY OF CHAR); 
+  (* Read a line of text, discarding EOL *)
+
+  PROCEDURE More*() : BOOLEAN; (* Return TRUE in gpcp v1.3! *)
+
+  PROCEDURE Read*(OUT ch : CHAR); (* Get next character *)
+
+END StdIn.

libs/cpascal/StringLib.cp

@@ -0,0 +1,350 @@
+(* ============================================================= *)
+(* Preliminary library module for Gardens Point Component Pascal *)
+(* ============================================================= *)
+
+MODULE StringLib; (* from GPM module StdStrings.mod kjg june 1989 *)
+  IMPORT RTS;
+
+  CONST  nul = 0X;
+
+(* ============================================================ *)
+
+  PROCEDURE CanAssignAll*(sLen : INTEGER;
+                       IN dest : ARRAY OF CHAR) : BOOLEAN;
+ (**  Check if an assignment is possible without truncation.
+  *)
+  BEGIN
+    RETURN LEN(dest) > sLen; (* must leave room for nul *)
+  END CanAssignAll;
+
+  PROCEDURE Assign*   (IN  src : ARRAY OF CHAR;
+                       OUT dst : ARRAY OF CHAR);
+ (**  Assign as much as possible of src to dst,
+  *   leaving room for a terminating ASCII nul.
+  *)
+    VAR ix, hi : INTEGER; 
+        ch     : CHAR;
+  BEGIN
+    hi := MIN(LEN(src), LEN(dst)) - 1;
+    FOR ix := 0 TO hi DO
+      ch := src[ix];
+      dst[ix] := ch;
+      IF ch = nul THEN RETURN END;
+    END;
+   (*
+    *  We have copied up to index "hi"
+    *  without finding a nul in "src"
+    *)
+    dst[hi] := nul;
+  END Assign;
+
+(* ============================================================ *)
+
+  PROCEDURE CanExtractAll*(len : INTEGER;
+                           sIx : INTEGER;
+                           num : INTEGER;
+                       OUT dst : ARRAY OF CHAR) : BOOLEAN;
+ (**  Check if an extraction of "num" charcters,
+  *   starting at source index "sIx" is possible.
+  *)
+  BEGIN
+    RETURN  (sIx + num <= len) & 
+            (LEN(dst) > num);     (* leave room for nul *)
+  END CanExtractAll;
+
+  PROCEDURE Extract*  (IN  src : ARRAY OF CHAR;
+                           sIx : INTEGER;
+                           num : INTEGER;
+                       OUT dst : ARRAY OF CHAR);
+ (**  Extract "num" characters starting at index "sIx".  
+  *   Result is truncated if either there are fewer characters
+  *   left in the source, or the destination is too short.
+  *)
+    VAR ch  : CHAR; 
+        sLm : INTEGER;
+        dLm : INTEGER;
+        dIx : INTEGER;
+  BEGIN
+  
+    sLm := LEN(src$) - 1;  (* max index of source *)
+    dLm := LEN(dst) - 1;   (* max index of dest.  *)
+    IF sIx < 0 THEN RTS.Throw("StdStrings.Extract: Bad start index") END;
+    IF num < 0 THEN RTS.Throw("StdStrings.Extract: Bad char. count") END;
+
+    IF sIx > sLm THEN dst[0] := nul; RETURN END;
+    IF (sIx + num - 1) < sLm THEN sLm := sIx + num - 1 END;
+
+    dIx := 0;
+    FOR sIx := sIx TO sLm DO
+      IF dIx = dLm THEN dst[dIx] := nul; RETURN END;
+      ch := src[sIx];
+      dst[dIx] := ch; 
+      INC(dIx);
+    END;
+    dst[dIx] := nul;
+  END Extract;
+  
+(* ============================================================ *)
+
+  PROCEDURE CanDeleteAll*( len : INTEGER;
+                           sIx : INTEGER;
+                           num : INTEGER) : BOOLEAN;
+ (**  Check if "num" characters may be deleted starting
+  *   from index "sIx", when len is the source length.
+  *)
+  BEGIN
+    RETURN (sIx < len) & (sIx + num <= len);
+  END CanDeleteAll;
+    
+  PROCEDURE Delete*(VAR str : ARRAY OF CHAR;
+                        sIx : INTEGER;
+                        num : INTEGER);
+    VAR sLm, mIx : INTEGER;
+ (**  Delete "num" characters starting from index "sIx".
+  *   Less characters are deleted if there are less 
+  *   than "num" characters after "sIx".
+  *)
+  BEGIN
+    sLm := LEN(str$) - 1;
+    IF sIx < 0 THEN RTS.Throw("StdStrings.Delete: Bad start index") END;
+    IF num < 0 THEN RTS.Throw("StdStrings.Delete: Bad char. count") END;
+
+    (* post : lim is length of str *)
+    IF sIx < sLm THEN (* else do nothing *)
+      IF sIx + num <= sLm THEN (* else sIx is unchanged *)
+        mIx := sIx + num;
+        WHILE mIx <= sLm DO
+          str[sIx] := str[mIx]; INC(sIx); INC(mIx);
+        END;
+      END;
+      str[sIx] := nul;
+    END;
+  END Delete;
+
+
+(* ============================================================ *)
+
+  PROCEDURE CanInsertAll*(sLen : INTEGER;
+                          sIdx : INTEGER;
+                      VAR dest : ARRAY OF CHAR) : BOOLEAN;
+ (**  Check if "sLen" characters may be inserted into "dest"
+  *   starting from index "sIdx".
+  *)
+    VAR dLen : INTEGER;
+        dCap : INTEGER;
+  BEGIN
+    dCap := LEN(dest)-1; (* max chars in destination string  *)
+    dLen := LEN(dest$);  (* current chars in destination str *)
+    RETURN (sIdx < dLen) & 
+           (dLen + sLen < dCap);
+  END CanInsertAll;
+  
+  PROCEDURE Insert*   (IN  src : ARRAY OF CHAR;
+                           sIx : INTEGER;
+                       VAR dst : ARRAY OF CHAR);
+ (**  Insert "src" string into "dst" starting from index 
+  *   "sIx".  Less characters are inserted if there is not
+  *   sufficient space in the destination.  The destination is
+  *   unchanged if "sIx" is beyond the end of the initial string.
+  *)
+    VAR dLen, sLen, dCap, iEnd, cEnd : INTEGER; 
+        idx : INTEGER;
+  BEGIN
+    dCap := LEN(dst)-1;
+    sLen := LEN(src$);
+    dLen := LEN(dst$);  (* dst[dLen] is index of the nul *)
+    IF sIx < 0 THEN RTS.Throw("StdStrings.Insert: Bad start index") END;
+  
+    (* skip trivial case *)
+    IF (sIx > dLen) OR (sLen = 0) THEN RETURN END;
+  
+    iEnd := MIN(sIx + sLen,  dCap); (* next index after last insert position *)
+    cEnd := MIN(dLen + sLen, dCap); (* next index after last string position *)
+  
+    FOR idx := cEnd-1 TO iEnd BY -1 DO
+       dst[idx]  := dst[idx-sLen];
+    END;
+  
+    FOR idx := 0 TO sLen - 1 DO
+      dst[idx+sIx] := src[idx];
+    END;
+    dst[cEnd] := nul;
+  END Insert;
+
+(* ============================================================ *)
+
+  PROCEDURE CanReplaceAll*(len : INTEGER;
+                           sIx : INTEGER;
+                       VAR dst : ARRAY OF CHAR) : BOOLEAN;
+ (**  Check if "len" characters may be replaced in "dst"
+  *   starting from index "sIx".
+  *)
+  BEGIN
+    RETURN len + sIx <= LEN(dst$);
+  END CanReplaceAll;
+
+  PROCEDURE Replace*  (IN  src : ARRAY OF CHAR;
+                           sIx : INTEGER;
+                       VAR dst : ARRAY OF CHAR);
+ (**  Insert the characters of "src" string into "dst" starting 
+  *   from index "sIx".  Less characters are replaced if the
+  *   initial length of the destination string is insufficient.
+  *   The string length of "dst" is unchanged.
+  *)
+    VAR dLen, sLen, ix : INTEGER;
+  BEGIN
+    dLen := LEN(dst$);
+    sLen := LEN(src$);
+    IF sIx >= dLen THEN RETURN END;
+    IF sIx < 0 THEN RTS.Throw("StdStrings.Replace: Bad start index") END;
+
+    FOR ix := sIx TO MIN(sIx+sLen-1, dLen-1) DO
+      dst[ix] := src[ix-sIx]; 
+    END;
+  END Replace;
+
+(* ============================================================ *)
+
+  PROCEDURE CanAppendAll*(len : INTEGER;
+                      VAR dst : ARRAY OF CHAR) : BOOLEAN;
+ (**  Check if "len" characters may be appended to "dst"
+  *)
+    VAR dLen : INTEGER;
+        dCap : INTEGER;
+  BEGIN
+    dCap := LEN(dst)-1; (* max chars in destination string  *)
+    dLen := LEN(dst$);  (* current chars in destination str *)
+    RETURN dLen + len <= dCap;
+  END CanAppendAll;
+
+  PROCEDURE Append*(src : ARRAY OF CHAR;
+                VAR dst : ARRAY OF CHAR);
+ (**  Append the characters of "src" string onto "dst".
+  *   Less characters are appended if the length of the 
+  *   destination string is insufficient.
+  *)
+    VAR dLen, dCap, sLen : INTEGER;
+        idx : INTEGER;
+  BEGIN
+    dCap := LEN(dst)-1; (* max chars in destination string  *)
+    dLen := LEN(dst$);  (* current chars in destination str *)
+    sLen := LEN(src$);
+    FOR idx := 0 TO sLen-1 DO
+      IF dLen = dCap THEN dst[dCap] := nul; RETURN END;
+      dst[dLen] := src[idx]; INC(dLen);
+    END;
+    dst[dLen] := nul;
+  END Append;
+
+(* ============================================================ *)
+
+  PROCEDURE Capitalize*(VAR str : ARRAY OF CHAR);
+    VAR ix : INTEGER;
+  BEGIN
+    FOR ix := 0 TO LEN(str$)-1 DO str[ix] := CAP(str[ix]) END;
+  END Capitalize;
+
+(* ============================================================ *)
+
+  PROCEDURE FindNext*    (IN  pat : ARRAY OF CHAR;
+                          IN  str : ARRAY OF CHAR;
+                              bIx : INTEGER;  (* Begin index *)
+                          OUT fnd : BOOLEAN;
+                          OUT pos : INTEGER);
+ (**  Find the first occurrence of the pattern string "pat"
+  *   in "str" starting the search from index "bIx".
+  *   If no match is found "fnd" is set FALSE and "pos"
+  *   is set to "bIx".  Empty patterns match everywhere.
+  *)
+    VAR pIx, sIx : INTEGER;
+        pLn, sLn : INTEGER;
+        sCh      : CHAR;
+  BEGIN
+    pos := bIx;
+    pLn := LEN(pat$);
+    sLn := LEN(str$);
+
+    (* first check that string extends to bIx *)
+    IF bIx >= sLn - pLn THEN fnd := FALSE; RETURN END;
+    IF pLn = 0 THEN fnd := TRUE; RETURN END;
+    IF bIx < 0 THEN RTS.Throw("StdStrings.FindNext: Bad start index") END;
+
+    sCh := pat[0];
+    FOR sIx := bIx TO sLn - pLn - 1 DO
+      IF str[sIx] = sCh THEN (* possible starting point! *)
+        pIx := 0;
+        REPEAT
+          INC(pIx);   
+          IF pIx = pLn THEN fnd := TRUE; pos := sIx; RETURN END;
+        UNTIL str[sIx + pIx] # pat[pIx];
+      END;
+    END;
+    fnd := FALSE;
+  END FindNext;
+  
+(* ============================================================ *)
+
+  PROCEDURE FindPrev*(IN  pat : ARRAY OF CHAR;
+                      IN  str : ARRAY OF CHAR;
+                          bIx : INTEGER;  (* begin index *)
+                      OUT fnd : BOOLEAN;
+                      OUT pos : INTEGER);
+
+ (**  Find the previous occurrence of the pattern string "pat"
+  *   in "str" starting the search from index "bIx".
+  *   If no match is found "fnd" is set FALSE and "pos"
+  *   is set to "bIx".  A pattern starting from "bIx" is found.
+  *   Empty patterns match everywhere.
+  *)
+    VAR pIx, sIx : INTEGER;
+        pLn, sLn : INTEGER;
+        sCh      : CHAR;
+  BEGIN
+    pos := bIx;
+    pLn := LEN(pat$);
+    sLn := LEN(str$);
+
+    IF pLn = 0 THEN fnd := TRUE; RETURN END;
+    IF pLn > sLn THEN fnd := FALSE; RETURN END;
+    IF bIx < 0 THEN RTS.Throw("StdStrings.FindPrev: Bad start index") END;
+
+    (* start searching from bIx OR sLn - pLn *)
+    sCh := pat[0];
+    FOR sIx := MIN(bIx, sLn - pLn - 1) TO 0 BY - 1 DO
+      IF str[sIx] = sCh THEN (* possible starting point! *)
+        pIx := 0;
+        REPEAT 
+          INC(pIx);
+          IF pIx = pLn THEN fnd := TRUE; pos := sIx; RETURN END;
+        UNTIL str[sIx + pIx] # pat[pIx];
+      END;
+    END;
+    fnd := FALSE;
+  END FindPrev;
+  
+(* ============================================================ *)
+
+  PROCEDURE FindDiff*   (IN  str1 : ARRAY OF CHAR;
+                         IN  str2 : ARRAY OF CHAR;
+                         OUT diff : BOOLEAN;
+                         OUT dPos : INTEGER);
+ (**  Find the index of the first charater of difference 
+  *   between the two input strings.  If the strings are
+  *   identical "diff" is set FALSE, and "dPos" is zero.
+  *)
+    VAR ln1, ln2, idx : INTEGER;
+  BEGIN
+    ln1 := LEN(str1$);
+    ln2 := LEN(str2$);
+
+    FOR idx := 0 TO MIN(ln1, ln2) DO
+      IF str1[idx] # str2[idx] THEN
+        diff := TRUE; dPos := idx; RETURN;   (* PRE-EMPTIVE RETURN *)
+      END;
+    END;
+    dPos := 0;
+    diff := (ln1 # ln2);  (* default result *)
+  END FindDiff;
+  
+(* ============================================================ *)
+END StringLib.

libs/csharp/GPBinFiles.cs

@@ -0,0 +1,242 @@
+//
+// Body of GPBinFiles interface.
+// This file implements the code of the GPBinFiles.cp file.
+// dwc August 1999. COOL version kjg May 2000
+// kjg September 2000. Renamed from GPFiles to GPBinFiles.
+// kjg March 2001.  Version for Beta-2 libraries.
+// 
+// Compile with: csc /t:library /r:GPFiles.dll GPBinFiles.cs
+//
+/* ------------------------------------------------------------ */
+using System;
+using GPFiles;
+
+namespace GPBinFiles {
+public class GPBinFiles {
+
+  /* ----------------------------------	*/
+
+  private static System.String mkStr(char[] arr) {
+    int  ix = 0;
+    char ch;
+    do {
+	ch = arr[ix]; ix++;
+    } while (ch != '\0');
+    return new System.String(arr,0,ix-1);
+  }
+
+  /* ----------------------------------	*/
+
+  public static int length(FILE cpf) {
+    return (int) cpf.bufS.Length;
+  }
+
+  /* ----------------------------------	*/
+
+  private static FILE open(System.String name) {
+  // Opens buffered filestream for reading.
+    try {
+	FILE cpf = new FILE();
+	cpf.path = name;
+	System.IO.FileStream fStr = 
+			System.IO.File.Open(name, System.IO.FileMode.Open);
+	cpf.bufS = new System.IO.BufferedStream(fStr);
+	return cpf;
+    } catch {
+	return null;
+    }
+  }
+
+  private static FILE openRead(System.String name) {
+  // Opens buffered filestream for reading.
+    try {
+	FILE cpf = new FILE();
+	cpf.path = name;
+	System.IO.FileStream fStr = System.IO.File.OpenRead(name);
+	cpf.bufS = new System.IO.BufferedStream(fStr);
+	return cpf;
+    } catch {
+	return null;
+    }
+  }
+
+ /* =========================== */
+                               
+  /* ----------------------------------	*/
+
+  public static FILE findLocal(char[] fileName) 
+  {
+    System.String name = mkStr(fileName);
+    return open(name);
+  }
+                               
+  /* ----------------------------------	*/
+
+  public static FILE findOnPath(
+			char[] pathName, 
+			char[] fileName) 
+  { 
+    //
+    // Use mkStr, to trim space from end of char arrray.
+    //
+    System.String pName = mkStr(pathName);
+    System.String fName = mkStr(fileName);
+    System.String nName = "";
+
+    System.String nextDir;
+    System.String thisPath = System.Environment.GetEnvironmentVariable(pName);
+//
+//  System.Console.WriteLine(pName);
+//  System.Console.WriteLine(thisPath);
+//
+    FILE cpf = new FILE();
+    bool found = false; 
+    bool pathFinished = false;
+    int length = thisPath.Length;
+    int nextLength;
+    int nextPathStart;
+    int nextPathEnd   = -1;
+
+    while (!found && !pathFinished) {
+      nextPathStart = nextPathEnd + 1;
+      nextPathEnd   = thisPath.IndexOf(GPFiles.GPFiles.pathSep, nextPathStart);
+      if (nextPathEnd < 0)
+	  nextPathEnd = length;
+      nextLength    = nextPathEnd - nextPathStart;
+      nextDir = thisPath.Substring(nextPathStart, nextLength);
+      nName = nextDir + GPFiles.GPFiles.fileSep + fName;
+      found = System.IO.File.Exists(nName);
+      pathFinished = nextPathEnd >= length; 
+    } 
+    if (found) {
+        return openRead(nName);
+    } else
+        return null;
+  }
+   
+  /* ----------------------------------	*/
+
+  public static char[] getFullPathName(FILE cpf) {
+    return cpf.path.ToCharArray(); // not really correct!
+  }
+
+  /* ----------------------------------	*/
+
+  public static FILE openFile(char[] fileName) {
+    System.String name = mkStr(fileName);
+    return open(name);
+  }
+
+  public static FILE openFileRO(char[] fileName) {
+    System.String name = mkStr(fileName);
+    return openRead(name);
+  }
+                               
+  /* ----------------------------------	*/
+
+  public static void CloseFile(FILE cpf) {
+    if (cpf.bufS != null)
+	cpf.bufS.Close();
+  }
+
+  /* ----------------------------------	*/
+
+  public static FILE createFile(char[] arr) {
+    FILE cpf = new FILE();
+    try {
+	System.String name = mkStr(arr);
+	System.IO.FileStream fStr = System.IO.File.Create(name);
+      cpf.path = name;
+	cpf.bufS = new System.IO.BufferedStream(fStr);
+	return cpf;
+    } catch {
+	return null;
+    }
+  } 
+
+  /* ----------------------------------	*/
+
+  public static FILE createPath(char[] fileName)
+  {
+    System.String fName = mkStr(fileName);
+    try {
+	int ix = fName.LastIndexOf(GPFiles.GPFiles.fileSep);
+	if (ix > 0) {
+        System.String path = fName.Substring(0,ix);
+        // Check if exists first?
+	  if (!System.IO.Directory.Exists(path)) {
+	    System.IO.DirectoryInfo junk = System.IO.Directory.CreateDirectory(path);
+        }
+	}
+	FILE cpf = new FILE();
+      cpf.path = fName;
+	System.IO.FileStream fStr = System.IO.File.Create(fName);
+	cpf.bufS = new System.IO.BufferedStream(fStr);
+	return cpf;
+    } catch {
+	return null;
+    }
+  }
+
+  /* ----------------------------------	*/
+
+  public static bool EOF(FILE cpf) {
+    return cpf.bufS.Position >= cpf.bufS.Length;
+  }
+
+  /* ----------------------------------	*/
+
+  public static int readByte(FILE cpf) {
+    if (cpf.bufS != null)
+	return (int) cpf.bufS.ReadByte();
+    else
+	throw new System.Exception("File not open for reading");
+  } 
+
+  /* ----------------------------------	*/
+
+  public static int  readNBytes(FILE cpf, 
+				byte[] buff, 
+				int    want)
+  {
+    if (cpf.bufS != null)
+	return cpf.bufS.Read(buff, 0, want);
+    else
+	throw new System.Exception("File not open for reading");
+  } 
+
+  /* ----------------------------------	*/
+
+  public static void WriteByte(FILE cpf, int b) {
+    if (cpf.bufS != null)
+	cpf.bufS.WriteByte((byte) b);
+    else
+	throw new System.Exception("File not open for reading");
+  } 
+
+  /* ----------------------------------	*/
+
+  public static void WriteNBytes(FILE cpf,
+				 byte[] buff,
+				 int    want)
+  {
+    if (cpf.bufS != null)
+	cpf.bufS.Write(buff, 0, want);
+    else
+	throw new System.Exception("File not open for reading");
+  } 
+}	// end of class GPBinFiles
+
+/* ------------------------------------------------------------ */
+/*		File-descriptor for GPBinFiles			*/
+/* ------------------------------------------------------------ */
+
+  public class FILE : GPFiles.FILE
+  {
+     public System.IO.BufferedStream bufS;
+  }	// end of class FILE
+
+/* ------------------------------------------------------------ */
+} // end of GPBinFiles.
+/* ------------------------------------------------------------ */
+

libs/csharp/GPFiles.cs

@@ -0,0 +1,62 @@
+/* ------------------------------------------------------------ */
+// Body of GPFiles interface.
+// This file implements the code of the GPFiles.cp file.
+// dwc August 1999. COOL version kjg May 2000
+// kjg September 2000.  Stripped version as abstract base class.
+// kjg March 2001.  Version for Beta-2 libraries.
+/* ------------------------------------------------------------ */
+
+namespace GPFiles {
+public abstract class GPFiles {
+
+  public static char pathSep = ';';
+  public static char fileSep = '\\';
+  public static char optChar = '/';
+
+  /* ----------------------------------	*/
+
+  private static System.String mkStr(char[] arr) {
+    int  ix = 0;
+    char ch;
+    do {
+	ch = arr[ix]; ix++;
+    } while (ch != '\0');
+    return new System.String(arr,0,ix-1);
+  }
+
+  /* ----------------------------------	*/
+
+  public static bool isOlder(FILE first, FILE second) {
+	int comp = System.DateTime.Compare(
+		     System.IO.File.GetLastWriteTime(first.path),
+		     System.IO.File.GetLastWriteTime(second.path)
+		);
+	return comp == -1;
+    }
+
+  public static void MakeDirectory(char[] dirName) {
+	System.String path = mkStr(dirName);
+        System.IO.Directory.CreateDirectory(path);
+    }
+
+  public static char[] CurrentDirectory() {
+        return System.IO.Directory.GetCurrentDirectory().ToCharArray();
+  }
+  
+  public static bool exists(char[] filName) {
+	System.String path  = mkStr(filName);
+	return System.IO.File.Exists(path);
+    }
+
+  } // end of class GPFiles
+
+/* ------------------------------------------------------------ */
+
+public abstract class FILE {
+	public System.String path;
+  }  // end of class GPFiles.FILE
+
+/* ------------------------------------------------------------ */
+}  // end of NameSpace GPFiles
+/* ------------------------------------------------------------ */
+

libs/csharp/GPTextFiles.cs

@@ -0,0 +1,249 @@
+/* ------------------------------------------------------------	*/
+//
+// Body of GPTextFiles interface.
+// This file implements the code of the GPTextFiles.cp file.
+// dwc August 1999,  C# version May 2000, kjg.
+// dwc May 2001.  Version for Beta-2 libraries.
+//
+// Compile with : csc /t:library /r:GPFiles.dll GPTextFiles.cs
+//
+/* ------------------------------------------------------------	*/
+using System;
+using GPFiles;
+
+/* ------------------------------------------------------------	*/
+
+namespace GPTextFiles {
+public class GPTextFiles 
+{
+  /* ----------------------------------	*/
+
+  private static System.String mkStr(char[] arr) {
+    int  ix = 0;
+    char ch;
+    do {
+	ch = arr[ix]; ix++;
+    } while (ch != '\0');
+    return new System.String(arr,0,ix-1);
+  }
+
+  /* ----------------------------------	*/
+
+  private static FILE open(System.String name) {
+    try {
+      FILE cpf = new FILE();
+      cpf.path = name;
+      System.IO.FileStream fStr = 
+                           System.IO.File.Open(name, System.IO.FileMode.Open);
+      cpf.strR = new System.IO.StreamReader(fStr);
+      return cpf;
+    } catch {
+      return null;
+    }
+  }
+                               
+  private static FILE openRead(System.String name) {
+    try {
+      FILE cpf = new FILE();
+      cpf.path = name;
+      System.IO.FileStream fStr = System.IO.File.OpenRead(name);
+      cpf.strR = new System.IO.StreamReader(fStr);
+      return cpf;
+    } catch {
+      return null;
+    }
+  }
+                               
+  /* ----------------------------------	*/
+
+  public static FILE findLocal(char[] fileName) 
+  {
+    return open(mkStr(fileName));
+  }
+
+  /* ----------------------------------	*/
+
+  public static FILE findOnPath(
+			char[] pathName, char[] fileName) 
+  {
+    //
+    // Use mkStr, to trim space from end of char arrray.
+    //
+    System.String pName = mkStr(pathName);
+    System.String fName = mkStr(fileName);
+    System.String nName = "";
+
+    System.String nextDir;
+    System.String thisPath = System.Environment.GetEnvironmentVariable(pName);
+//
+//  System.Console.WriteLine(pName);
+//  System.Console.WriteLine(thisPath);
+//
+    FILE cpf = new FILE();
+    bool found = false; 
+    bool pathFinished = false;
+    int length = thisPath.Length;
+    int nextLength;
+    int nextPathStart;
+    int nextPathEnd   = -1;
+
+    while (!found && !pathFinished) {
+      nextPathStart = nextPathEnd + 1;
+      nextPathEnd   = thisPath.IndexOf(GPFiles.GPFiles.pathSep, nextPathStart);
+      if (nextPathEnd < 0)
+	  nextPathEnd = length;
+      nextLength    = nextPathEnd - nextPathStart;
+      nextDir = thisPath.Substring(nextPathStart, nextLength);
+      nName = nextDir + GPFiles.GPFiles.fileSep + fName;
+      found = System.IO.File.Exists(nName);
+      pathFinished = nextPathEnd >= length; 
+    } 
+    if (found) {
+        return open(nName);
+    } else
+        return null;
+  }
+   
+  /* ----------------------------------	*/
+
+  public static char[] getFullPathName(FILE cpf) {
+    return cpf.path.ToCharArray();
+  }
+
+  /* ----------------------------------	*/
+
+  public static FILE openFile(char[] fileName) 
+  {
+    return open(mkStr(fileName));
+  }
+
+  /* ----------------------------------	*/
+
+  public static FILE openFileRO(char[] fileName) 
+  {
+    return openRead(mkStr(fileName));
+  }
+
+  /* ----------------------------------	*/
+
+  public static void CloseFile(FILE cpf) 
+  {
+    if (cpf.strW != null) {
+      cpf.strW.Close();	// Close does automatic Flush()
+    }
+    if (cpf.strR != null) {
+      cpf.strR.Close();
+    }
+  }
+
+  /* ----------------------------------	*/
+
+  public static FILE createFile(char[] fileName) 
+  {
+    FILE cpf = new FILE();
+    try {
+      System.String name = mkStr(fileName);
+      System.IO.FileStream fStr = System.IO.File.Create(name);
+      cpf.path = name;
+	cpf.strW = new System.IO.StreamWriter(fStr);
+	return cpf;
+    } catch {
+	return null;
+    }
+  } 
+
+  /* ---------------------------------- */
+
+  public static FILE createPath(char[] fileName)
+  {
+    System.String fName = mkStr(fileName);
+    try {
+      int ix = fName.LastIndexOf(GPFiles.GPFiles.fileSep);
+      if (ix > 0) {
+        System.String path = fName.Substring(0,ix);
+        if (!System.IO.Directory.Exists(path)) {
+          System.IO.DirectoryInfo junk = System.IO.Directory.CreateDirectory(path);
+        }
+      }
+      FILE cpf = new FILE();
+      cpf.path = fName;
+      System.IO.FileStream fStr = System.IO.File.Create(fName);
+      cpf.strW = new System.IO.StreamWriter(fStr);
+      return cpf;
+    } catch {
+        return null;
+    }
+  }
+
+  /* ----------------------------------	*/
+
+  public static char readChar(FILE cpf)
+  {
+    if (cpf.strR != null) {
+	int chr = cpf.strR.Read();
+	if (chr == -1)
+	    return (char) 0;
+	else
+	    return (char) chr;
+    } else
+	throw new System.Exception("File not open for reading");
+  } 
+
+  /* ----------------------------------	*/
+
+  public static int readNChars(
+			FILE cpf, 
+			char[] buff, 
+			int    want) 
+  {
+    return cpf.strR.Read(buff,0,want);
+  } 
+
+  /* ----------------------------------	*/
+
+  public static void WriteChar(FILE cpf, char ch) 
+  {
+    if (cpf.strW != null) {
+	cpf.strW.Write(ch);
+    } else
+	throw new System.Exception("File not open for writing");
+  } 
+
+  /* ----------------------------------	*/
+
+  public static void WriteEOL(FILE cpf) 
+  {
+    if (cpf.strW != null) {
+	cpf.strW.Write(Environment.NewLine);
+    } else
+	throw new System.Exception("File not open for writing");
+  } 
+
+  /* ----------------------------------	*/
+
+  public static void WriteNChars(
+			FILE cpf, 
+			char[] buff, 
+			int    want)
+  {
+    if (cpf.strW != null) {
+	cpf.strW.Write(buff, 0, want);
+    } else
+	throw new System.Exception("File not open for writing");
+  } 
+}	// end of class GPTextFiles
+
+/* ------------------------------------------------------------ */
+/*		File-descriptor for GPTextFiles			*/
+/* ------------------------------------------------------------ */
+
+  public class FILE : GPFiles.FILE
+  {
+     public System.IO.StreamReader strR;
+     public System.IO.StreamWriter strW;
+  }	// end of class FILE
+
+/* ------------------------------------------------------------ */
+} // end of GPTextFiles.
+/* ------------------------------------------------------------ */
+

libs/csharp/MakeAll.bat

@@ -0,0 +1,4 @@
+csc /t:library /debug RTS.cs
+csc /t:library /debug GPFiles.cs
+csc /t:library /debug /r:GPFiles.dll GPBinFiles.cs
+csc /t:library /debug /r:GPFiles.dll GPTextFiles.cs

libs/csharp/RTS.cs

@@ -0,0 +1,1399 @@
+/** This is the body of the GPCP runtime support.
+ *
+ *  Written November 1998, John Gough. (for jdk version)
+ *  This version for Lightning, May 2000, John Gough.
+ *  Support for uplevel addressing RTS.XHR, Aug-2001.
+ *  Merged version for N2CPS, gpcp etc.  SYChan, KJGough. 19-Aug-2001.
+ */
+
+#if !BETA1
+  #define BETA2
+#endif
+
+public class RTS
+// Known in ILASM as [RTS]RTS
+{
+/** This is part of the body of the GPCP runtime support.
+ *
+ *  Written November 1998, John Gough.
+ *  This version for Lightning, May 2000, John Gough.
+ */
+
+/* ------------------------------------------------------------ */
+/* 		        Support for RTS.cp			*/
+/* ------------------------------------------------------------ */
+
+  public static char[] defaultTarget = {'n','e','t','\0'};
+  public static char[] eol = NativeStrings.mkArr(System.Environment.NewLine);
+
+  public static double dblPosInfinity = System.Double.PositiveInfinity;
+  public static double dblNegInfinity = System.Double.NegativeInfinity;
+  public static float  fltPosInfinity = System.Single.PositiveInfinity;
+  public static float  fltNegInfinity = System.Single.NegativeInfinity;
+
+  private static char[] ChrNaN    = {'N','a','N','\0'};
+  private static char[] ChrPosInf = {'I','n','f','i','n','i','t','y','\0'};
+  private static char[] ChrNegInf = {'-','I','n','f','i','n','i','t','y','\0'};
+  private static System.String StrNaN    = new System.String(ChrNaN); 
+  private static System.String StrPosInf = new System.String(ChrPosInf);
+  private static System.String StrNegInf = new System.String(ChrNegInf);
+
+  private static System.Type typDouble = System.Type.GetType("System.Double");
+  private static System.Type typSingle = System.Type.GetType("System.Single");
+
+  private static System.IFormatProvider invarCulture = 
+             (System.IFormatProvider) new System.Globalization.CultureInfo("");
+  private static System.IFormatProvider currentCulture = 
+      (System.IFormatProvider) System.Globalization.CultureInfo.CurrentCulture;
+
+/* -------------------------------------------------------------------- */
+//  PROCEDURE getStr*(x : NativeException) : RTS.CharOpen; END getStr;
+//
+    	// Known in ILASM as [RTS]RTS::getStr
+	public static char[] getStr(System.Exception inp)
+	{
+	    return CP_rts.strToChO(inp.ToString());
+	}
+
+/* ------------------------------------------------------------ */
+// PROCEDURE StrToBool(IN str : ARRAY OF CHAR;
+//                     OUT b  : BOOLEAN;
+//                     OUT ok : BOOLEAN);
+//
+	// Known in ILASM as [RTS]RTS::StrToBool
+	public static void StrToBool(char[]  str,
+				     out bool  o, 	// OUT param
+				     out bool  r)	// OUT param
+	{
+	    System.String bstr = new System.String(str);
+	    try {
+		o = System.Boolean.Parse(bstr);
+		r = true;
+	    } catch {
+		o = false;
+		r = false;
+	    }
+	}
+
+/* ------------------------------------------------------------ */
+// PROCEDURE StrToByte(IN str : ARRAY OF CHAR;
+//                     OUT b  : BYTE;
+//                     OUT ok : BOOLEAN);
+//
+	// Known in ILASM as [RTS]RTS::StrToByte
+	public static void StrToByte(char[]  str,
+				     out sbyte  o, 	// OUT param
+				     out bool  r)	// OUT param
+	{
+	    System.String bstr = new System.String(str);
+	    try {
+		o = System.SByte.Parse(bstr);
+		r = true;
+	    } catch {
+		o = 0;
+		r = false;
+	    }
+	}
+
+/* ------------------------------------------------------------ */
+// PROCEDURE StrToUByte(IN str : ARRAY OF CHAR;
+//                      OUT b  : BYTE;
+//                      OUT ok : BOOLEAN);
+//
+	// Known in ILASM as [RTS]RTS::StrToUByte
+	public static void StrToUByte(char[]  str,
+				     out sbyte  o, 	// OUT param
+				     out bool  r)	// OUT param
+	{
+	    System.String bstr = new System.String(str);
+	    try {
+		o = (sbyte)System.Byte.Parse(bstr);
+		r = true;
+	    } catch {
+		o = (sbyte)0;
+		r = false;
+	    }
+	}
+
+/* ------------------------------------------------------------ */
+// PROCEDURE HexStrToUByte(IN s : ARRAY OF CHAR; OUT b : BYTE; OUT ok : BOOLEAN);
+//
+	// Known in ILASM as [RTS]RTS::HexStrToUByte
+	public static void HexStrToUByte(char[]  str,
+				     out sbyte  o, 	// OUT param
+				     out bool  r)	// OUT param
+	{
+	    System.String bstr = new System.String(str);
+	    try {
+		o = (sbyte)System.Byte.Parse
+                           (bstr, System.Globalization.NumberStyles.HexNumber);
+		r = true;
+	    } catch {
+		o = (sbyte)0;
+		r = false;
+	    }
+	}
+
+/* ------------------------------------------------------------ */
+// PROCEDURE StrToShort(IN str : ARRAY OF CHAR;
+//                      OUT i  : SHORTINT;
+//                      OUT ok : BOOLEAN);
+//
+	// Known in ILASM as [RTS]RTS::StrToShort
+	public static void StrToShort(char[] str,
+				     out short  o,	// OUT param
+				     out bool r)	// OUT param
+	{
+	    System.String sstr = new System.String(str);
+	    try {
+		o = System.Int16.Parse(sstr);
+		r = true;
+	    } catch {
+		o = (short) 0;
+		r = false;
+	    }
+	}
+
+/* ------------------------------------------------------------ */
+// PROCEDURE StrToUShort(IN str : ARRAY OF CHAR;
+//                       OUT i  : SHORTINT;
+//                       OUT ok : BOOLEAN);
+//
+	// Known in ILASM as [RTS]RTS::StrToUShort
+	public static void StrToUShort(char[] str,
+				     out short  o,	// OUT param
+				     out bool r)	// OUT param
+	{
+	    System.String sstr = new System.String(str);
+	    try {
+		o = (short)System.UInt16.Parse(sstr);
+		r = true;
+	    } catch {
+		o = (short) 0;
+		r = false;
+	    }
+	}
+
+/* ------------------------------------------------------------ */
+// PROCEDURE StrToInt(IN str : ARRAY OF CHAR;
+//                    OUT i  : INTEGER;
+//                    OUT ok : BOOLEAN);
+//
+	// Known in ILASM as [RTS]RTS::StrToInt
+	public static void StrToInt(char[] str,
+				    out int  o,		// OUT param
+				    out bool r)		// OUT param
+	{
+	    System.String lstr = new System.String(str);
+	    try {
+		o = System.Int32.Parse(lstr);
+		r = true;
+	    } catch {
+		o = 0;
+		r = false;
+	    }
+	}
+
+/* ------------------------------------------------------------ */
+// PROCEDURE StrToUInt(IN str : ARRAY OF CHAR;
+//                     OUT i  : INTEGER;
+//                     OUT ok : BOOLEAN);
+//
+	// Known in ILASM as [RTS]RTS::StrToUInt
+	public static void StrToUInt(char[] str,
+				    out int o,		// OUT param
+				    out bool r)		// OUT param
+	{
+	    System.String lstr = new System.String(str);
+	    try {
+		o = (int)System.UInt32.Parse(lstr);
+		r = true;
+	    } catch {
+		o = (int)0;
+		r = false;
+	    }
+	}
+
+/* ------------------------------------------------------------ */
+// PROCEDURE StrToLong(IN str : ARRAY OF CHAR;
+//                     OUT l  : LONGINT;
+//                     OUT ok : BOOLEAN);
+//
+	// Known in ILASM as [RTS]RTS::StrToLong
+	public static void StrToLong(char[] str,
+				     out long  o,	// OUT param
+				     out bool r)	// OUT param
+	{
+	    System.String lstr = new System.String(str);
+	    try {
+		o = System.Int64.Parse(lstr);
+		r = true;
+	    } catch {
+		o = (long) 0;
+		r = false;
+	    }
+	}
+
+/* ------------------------------------------------------------ */
+// PROCEDURE StrToULong(IN str : ARRAY OF CHAR;
+//                      OUT l  : LONGINT;
+//                      OUT ok : BOOLEAN);
+//
+	// Known in ILASM as [RTS]RTS::StrToULong
+	public static void StrToULong(char[] str,
+				     out long o,	// OUT param
+				     out bool r)	// OUT param
+	{
+	    System.String lstr = new System.String(str);
+	    try {
+		o = (long)System.UInt64.Parse(lstr);
+		r = true;
+	    } catch {
+		o = (long) 0;
+		r = false;
+	    }
+	}
+
+/* ------------------------------------------------------------ */
+// PROCEDURE StrToSReal(IN str : ARRAY OF CHAR;
+//                      OUT r  : SHORTREAL;
+//                      OUT ok : BOOLEAN);
+//
+	// Known in ILASM as [RTS]RTS::StrToSReal
+	public static void StrToSReal(char[] str,
+				     out float  o, 	// OUT param
+				     out bool   r)	// OUT param
+	{
+	    System.String rstr = new System.String(str);
+	    try {
+		o = System.Single.Parse(rstr);
+		r = true;
+	    } catch {
+                if (System.String.Compare(rstr, StrPosInf) == 0) {
+                    o = System.Single.PositiveInfinity;
+                    r = true;
+                }
+                else if (System.String.Compare(rstr, StrNegInf) == 0) {
+                    o = System.Single.NegativeInfinity;
+                    r = true;
+                }
+                else if (System.String.Compare(rstr, StrNaN) == 0) {
+                    o = System.Single.NaN;
+                    r = true;
+                }
+                else {
+		    o = 0;
+		    r = false;
+                }
+	    }
+	}
+
+/* ------------------------------------------------------------ */
+// PROCEDURE StrToReal(IN str : ARRAY OF CHAR;
+//                     OUT r  : REAL;
+//                     OUT ok : BOOLEAN);
+//
+	// Known in ILASM as [RTS]RTS::StrToReal
+	public static void StrToReal(char[] str,
+				     out double o, 	// OUT param
+				     out bool   r)	// OUT param
+	{
+	    System.String rstr = new System.String(str);
+	    try {
+		o = System.Double.Parse(rstr);
+		r = true;
+	    } catch {
+                if (System.String.Compare(rstr, StrPosInf) == 0) {
+                    o = System.Double.PositiveInfinity;
+                    r = true;
+                }
+                else if (System.String.Compare(rstr, StrNegInf) == 0) {
+                    o = System.Double.NegativeInfinity;
+                    r = true;
+                }
+                else if (System.String.Compare(rstr, StrNaN) == 0) {
+                    o = System.Double.NaN;
+                    r = true;
+                }
+                else {
+		    o = 0.0;
+		    r = false;
+                }
+	    }
+	}
+
+/* ------------------------------------------------------------ */
+// PROCEDURE StrToRealInvar(IN str : ARRAY OF CHAR;
+//                          OUT r  : REAL;
+//                          OUT ok : BOOLEAN);
+//
+	// Known in ILASM as [RTS]RTS::StrToReal
+	public static void StrToRealInvar(char[] str,
+				      out double o, 	// OUT param
+				      out bool   r)	// OUT param
+	{
+	    System.String rstr = new System.String(str);
+	    try {
+		o = System.Double.Parse(rstr, invarCulture);
+		r = true;
+	    } catch {
+                if (System.String.Compare(rstr, StrPosInf) == 0) {
+                    o = System.Double.PositiveInfinity;
+                    r = true;
+                }
+                else if (System.String.Compare(rstr, StrNegInf) == 0) {
+                    o = System.Double.NegativeInfinity;
+                    r = true;
+                }
+                else if (System.String.Compare(rstr, StrNaN) == 0) {
+                    o = System.Double.NaN;
+                    r = true;
+                }
+                else {
+		    o = 0.0;
+		    r = false;
+                }
+	    }
+	}
+
+/* ------------------------------------------------------------ */
+// PROCEDURE StrToRealLocal(IN str : ARRAY OF CHAR;
+//                          OUT r  : REAL;
+//                          OUT ok : BOOLEAN);
+//
+	// Known in ILASM as [RTS]RTS::StrToReal
+	public static void StrToRealLocal(char[] str,
+				      out double o, 	// OUT param
+				      out bool   r)	// OUT param
+	{
+	    System.String rstr = new System.String(str);
+	    try {
+		o = System.Double.Parse(rstr, currentCulture);
+		r = true;
+	    } catch {
+                if (System.String.Compare(rstr, StrPosInf) == 0) {
+                    o = System.Double.PositiveInfinity;
+                    r = true;
+                }
+                else if (System.String.Compare(rstr, StrNegInf) == 0) {
+                    o = System.Double.NegativeInfinity;
+                    r = true;
+                }
+                else if (System.String.Compare(rstr, StrNaN) == 0) {
+                    o = System.Double.NaN;
+                    r = true;
+                }
+                else {
+		    o = 0.0;
+		    r = false;
+                }
+	    }
+	}
+
+/* ------------------------------------------------------------ */
+//  PROCEDURE ByteToStr*(i : BYTE; OUT s : ARRAY OF CHAR);
+//  (** Decode a CP BYTE into an array *)
+//  BEGIN END ByteToStr;
+//
+	// Known in ILASM as [RTS]RTS::ByteToStr
+	public static void ByteToStr(sbyte num,
+				    char[] str)
+	{
+	    System.String lls = System.Convert.ToString(num);
+            int    len = lls.Length;
+            if (len >= str.Length)
+                len = str.Length - 1;
+	    lls.CopyTo(0, str, 0, len);
+            str[len] = '\0';
+	}
+
+/* ------------------------------------------------------------ */
+//  PROCEDURE ShortToStr*(i : SHORTINT; OUT s : ARRAY OF CHAR);
+//  (** Decode a CP SHORTINT into an array *)
+//  BEGIN END ShortToStr;
+//
+	// Known in ILASM as [RTS]RTS::ShortToStr
+	public static void ShortToStr(short    num,
+				    char[] str)
+	{
+	    System.String lls = System.Convert.ToString(num);
+            int    len = lls.Length;
+            if (len >= str.Length)
+                len = str.Length - 1;
+	    lls.CopyTo(0, str, 0, len);
+            str[len] = '\0';
+	}
+
+/* ------------------------------------------------------------ */
+//  PROCEDURE IntToStr*(i : INTEGER; OUT s : ARRAY OF CHAR);
+//  (** Decode a CP INTEGER into an array *)
+//  BEGIN END IntToStr;
+//
+	// Known in ILASM as [RTS]RTS::IntToStr
+	public static void IntToStr(int    num,
+				    char[] str)
+	{
+	    System.String lls = System.Convert.ToString(num);
+            int    len = lls.Length;
+            if (len >= str.Length)
+                len = str.Length - 1;
+	    lls.CopyTo(0, str, 0, len);
+            str[len] = '\0';
+	}
+
+/* ------------------------------------------------------------ */
+//  PROCEDURE ObjToStr(obj: mscorlib_System.Object; OUT str: ARRAY OF CHAR);
+//  (** Decode an .NET object into an array of CHAR *)
+//  BEGIN END ObjToStr;
+//
+        // Known in ILASM as [RTS]RTS::ObjToStr
+        public static void ObjToStr(System.Object obj, char[] str)
+        {
+            System.String lls;
+            if (obj.GetType().IsEnum) {
+#if BETA1
+                lls = obj.ToString();
+#else //BETA2
+                lls = System.Convert.ToString(System.Convert.ToInt64(obj));
+#endif
+            }
+            else {
+                if (obj.GetType().Equals(typDouble)) {
+#if BETA1
+                    lls = System.Convert.ToDouble(obj).ToString();
+#else //BETA2
+                    lls = System.Convert.ToDouble(obj).ToString("R");
+#endif
+                }
+                else if (obj.GetType().Equals(typSingle)) {
+#if BETA1
+                    lls = System.Convert.ToSingle(obj).ToString();
+#else //BETA2
+                    lls = System.Convert.ToSingle(obj).ToString("R");
+#endif
+                }
+                else {
+                    lls = System.Convert.ToString(obj);
+                }
+            }
+
+            int    len = lls.Length;
+            if (len >= str.Length)
+                len = str.Length - 1;
+            lls.CopyTo(0, str, 0, len);
+            str[len] = '\0';
+        }
+
+/* ------------------------------------------------------------ */
+//  PROCEDURE LongToStr*(i : LONGINT; OUT s : ARRAY OF CHAR);
+//  (** Decode a CP LONGINT into an array *)
+//  BEGIN END LongToStr;
+//
+	// Known in ILASM as [RTS]RTS::LongToStr
+	public static void LongToStr(long   num,
+				     char[] str)
+	{
+	    System.String lls = System.Convert.ToString(num);
+            int    len = lls.Length;
+            if (len >= str.Length)
+                len = str.Length - 1;
+	    lls.CopyTo(0, str, 0, len);
+            str[len] = '\0';
+	}
+
+/* ------------------------------------------------------------ */
+//  PROCEDURE SRealToStr*(r : SHORTREAL; OUT s : ARRAY OF CHAR);
+//  (** Decode a CP REAL into an array *)
+//  BEGIN END SRealToStr;
+//
+	// Known in ILASM as [RTS]RTS::SRealToStr
+	public static void SRealToStr(float num,
+				     char[] str)
+	{
+	 // System.String lls = System.Convert.ToString(num);
+#if BETA1
+            System.String lls = ((System.Single) num).ToString();
+#else //BETA2
+            System.String lls = ((System.Single) num).ToString("R");
+#endif
+            int    len = lls.Length;
+            lls.CopyTo(0, str, 0, len);
+            str[len] = '\0';
+	}
+
+/* ------------------------------------------------------------ */
+//  PROCEDURE RealToStr*(r : REAL; OUT s : ARRAY OF CHAR);
+//  (** Decode a CP REAL into an array *)
+//  BEGIN END RealToStr;
+//
+	// Known in ILASM as [RTS]RTS::RealToStr
+	public static void RealToStr(double num,
+				     char[] str)
+	{
+#if BETA1
+	    System.String lls = System.Convert.ToString(num);
+#else //BETA2
+            System.String lls = ((System.Double) num).ToString("R");
+#endif
+            int    len = lls.Length;
+            lls.CopyTo(0, str, 0, len);
+            str[len] = '\0';
+	}
+
+/* ------------------------------------------------------------ */
+//  PROCEDURE RealToStrInvar*(r : REAL; OUT s : ARRAY OF CHAR);
+//  (** Decode a CP REAL into an array *)
+//  BEGIN END RealToStrInvar;
+//
+	// Known in ILASM as [RTS]RTS::RealToStrInvar
+	public static void RealToStrInvar(double num,
+				          char[] str)
+	{
+#if BETA1
+	    System.String lls = System.Convert.ToString(num);
+#else //BETA2
+            System.String lls = 
+                        ((System.Double) num).ToString("R", invarCulture);
+#endif
+            int    len = lls.Length;
+            lls.CopyTo(0, str, 0, len);
+            str[len] = '\0';
+	}
+
+/* ------------------------------------------------------------ */
+//  PROCEDURE RealToStrLocal*(r : REAL; OUT s : ARRAY OF CHAR);
+//  (** Decode a CP REAL into an array *)
+//  BEGIN END RealToStrInvar;
+//
+	// Known in ILASM as [RTS]RTS::RealToStrLocal
+	public static void RealToStrLocal(double num,
+				          char[] str)
+	{
+#if BETA1
+	    System.String lls = System.Convert.ToString(num);
+#else //BETA2
+            System.String lls = 
+                        ((System.Double) num).ToString("R", currentCulture);
+#endif
+            int    len = lls.Length;
+            lls.CopyTo(0, str, 0, len);
+            str[len] = '\0';
+	}
+
+/* ------------------------------------------------------------ */
+//
+//  PROCEDURE realToLongBits(r : REAL) : LONGINT;
+//  (** Convert an ieee double into a longint with same bit pattern *)
+//
+  	public static long realToLongBits(double r)
+  	{
+	    byte[] tmp = System.BitConverter.GetBytes(r);
+  	    return System.BitConverter.ToInt64(tmp,0);
+  	}
+//
+//  PROCEDURE longBitsToReal(l : LONGINT) : REAL;
+//  (** Convert a longint into an ieee double with same bit pattern *)
+//
+  	public static double longBitsToReal(long l)
+  	{
+	    byte[] tmp = System.BitConverter.GetBytes(l);
+  	    return System.BitConverter.ToDouble(tmp,0);
+  	}
+
+/* ------------------------------------------------------------ */
+//
+//  PROCEDURE shortRealToIntBits(r : SHORTREAL) : INTEGER;
+//  (** Convert an ieee double into a longint with same bit pattern *)
+//
+  	public static int shortRealToIntBits(float r)
+  	{
+	    byte[] tmp = System.BitConverter.GetBytes(r);
+  	    return System.BitConverter.ToInt32(tmp,0);
+  	}
+//
+//  PROCEDURE intBitsToShortReal(l : INTEGER) : SHORTREAL;
+//  (** Convert an int into an ieee float with same bit pattern *)
+//
+  	public static double intBitsToShortReal(int l)
+  	{
+	    byte[] tmp = System.BitConverter.GetBytes(l);
+  	    return System.BitConverter.ToSingle(tmp,0);
+  	}
+
+/* ------------------------------------------------------------ */
+//
+//  PROCEDURE hiByte(l : SHORTINT) : BYTE;
+//  (** Get hi-significant byte of short *)
+//
+	// Known in ILASM as [RTS]RTS::hiByte
+	public static sbyte hiByte(short i)
+	{
+	    return (sbyte) (i >> 8);
+	}
+//
+//  PROCEDURE loByte(l : SHORTINT) : BYTE;
+//  (** Get lo-significant byte of short *)
+//
+	// Known in ILASM as [RTS]RTS::loByte
+	public static sbyte loByte(short i)
+	{
+	    return (sbyte) i;
+	}
+//
+//  PROCEDURE hiShort(l : INTEGER) : SHORTINT;
+//  (** Get hi-significant word of integer *)
+//
+	// Known in ILASM as [RTS]RTS::hiShort
+	public static short hiShort(int i)
+	{
+	    return (short) (i >> 16);
+	}
+//
+//  PROCEDURE loShort(l : INTEGER) : SHORTINT;
+//  (** Get lo-significant word of integer *)
+//
+	// Known in ILASM as [RTS]RTS::loShort
+	public static short loShort(int i)
+	{
+	    return (short) i;
+	}
+//
+//  PROCEDURE hiInt(l : LONGINT) : INTEGER;
+//  (** Get hi-significant word of long integer *)
+//
+	// Known in ILASM as [RTS]RTS::hiInt
+	public static int hiInt(long l)
+	{
+	    return (int) (l >> 32);
+	}
+//
+//  PROCEDURE loInt(l : LONGINT) : INTEGER;
+//  (** Get lo-significant word of long integer *)
+//
+	// Known in ILASM as [RTS]RTS::loInt
+	public static int loInt(long l)
+	{
+	    return (int) l;
+	}
+//
+//  PROCEDURE Throw(IN s : ARRAY OF CHAR);
+//  (** Abort execution with an error *)
+//
+	// Known in ILASM as [RTS]RTS::Throw
+	public static void Throw(char[] s)
+	{
+		throw new System.Exception(new System.String(s));
+	}
+//
+//  PROCEDURE GetMillis() : LONGINT;
+//
+	// Known in ILASM as [RTS]RTS::GetMillis
+	public static long GetMillis()
+	{
+	    return (System.DateTime.Now.Ticks / 10000);
+	}
+//
+//  PROCEDURE GetDateString(OUT str : ARRAY OF CHAR);
+//
+	// Known in ILASM as [RTS]RTS::GetDateString
+	public static void GetDateString(char[] arr)
+	{
+	    System.String str = System.DateTime.Now.ToString();
+            int len = str.Length;
+            if (len >= arr.Length)
+                len = arr.Length - 1;
+	    str.CopyTo(0, arr, 0, len);
+            arr[len] = '\0';
+	}
+
+	public static void ClassMarker(System.Object o)
+	{
+	    System.Console.Write(o.GetType().ToString());
+	}
+}
+/* ------------------------------------------------------------ */
+/* ------------------------------------------------------------ */
+/* ------------------------------------------------------------ */
+
+
+public class ProgArgs
+// Known in ILASM as [RTS]ProgArgs
+/* 
+ *  Library module for GP Component Pascal.
+ *  This module allows access to the arguments in programs which
+ *  import CPmain.  It is accessible from modules which do NOT
+ *  import CPmain.
+ *
+ *  Original : kjg December 1999
+ */
+{
+	public static System.String[] argList = null;
+
+	// Known in ILASM as [RTS]ProgArgs::ArgNumber
+	// PROCEDURE ArgNumber*() : INTEGER
+	public static int ArgNumber()
+	{
+	    if (ProgArgs.argList == null)
+		return 0;
+	    else
+		return argList.Length;
+	}
+
+	// Known in ILASM as [RTS]ProgArgs::GetArg
+	// PROCEDURE GetArg*(num : INTEGER; OUT arg : ARRAY OF CHAR) 
+	public static void GetArg(int num, char[] arr)
+	{
+	    int i;
+	    if (argList == null) {
+		arr[0] = '\0';
+	    } else {
+		for (i = 0; 
+		     i < arr.Length && i < argList[num].Length;
+		     i++) {
+		    System.String str = argList[num];
+		    arr[i] = str[i];
+		}
+		if (i == arr.Length)
+		    i--;
+		arr[i] = '\0';
+	    }
+	}
+
+        public static void GetEnvVar(char[] name, char[] valu) {
+            System.String nam = CP_rts.mkStr(name);
+            System.String val = System.Environment.GetEnvironmentVariable(nam);
+            CP_rts.StrToChF(valu, val);
+        }
+
+} // end of public class ProgArgs
+
+/* ------------------------------------------------------------ */
+/* ------------------------------------------------------------ */
+/* ------------------------------------------------------------ */
+
+public class CP_rts	
+// Known in ILASM as [RTS]CP_rts
+/*
+ *  It is a fundamental principle that the facilities of CP_rts
+ *  are known to the particular compiler backend, but are
+ *  not accessible to the Programmer.  The programmer-accessible
+ *  parts of the runtime are known via the module RTS.
+ */
+{
+/* ==================================================================== *
+ *		MOD and DIV helpers. With correction factors		*
+ * ==================================================================== */
+
+	// Known in ILASM as [RTS]CP_rts::CpModI
+	public static int CpModI(int lVal, int rVal)
+	{
+           // A correction is required if the signs of
+           // the two operands are different, but the
+           // remainder is non-zero. Inc rem by rVal.
+	    int rslt = lVal % rVal;
+            if ((lVal < 0 != rVal < 0) && (rslt != 0))
+                            rslt += rVal;
+	    return rslt;
+	}
+
+	// Known in ILASM as [RTS]CP_rts::CpDivI
+	public static int CpDivI(int lVal, int rVal)
+	{
+           // A correction is required if the signs of
+           // the two operands are different, but the
+           // remainder is non-zero. Dec quo by 1.
+            int rslt = lVal / rVal;
+            int remV = lVal % rVal;
+            if ((lVal < 0 != rVal < 0) && (remV != 0))
+              rslt--;
+	    return rslt;
+	}
+
+	// Known in ILASM as [RTS]CP_rts::CpModL
+	public static long CpModL(long lVal, long rVal)
+	{
+           // A correction is required if the signs of
+           // the two operands are different, but the
+           // remainder is non-zero. Inc rem by rVal.
+	    long rslt = lVal % rVal;
+            if ((lVal < 0 != rVal < 0) && (rslt != 0))
+                            rslt += rVal;
+	    return rslt;
+	}
+
+	// Known in ILASM as [RTS]CP_rts::CpDivL
+	public static long CpDivL(long lVal, long rVal)
+	{
+           // A correction is required if the signs of
+           // the two operands are different, but the
+           // remainder is non-zero. Dec quo by 1.
+            long rslt = lVal / rVal;
+            long remV = lVal % rVal;
+            if ((lVal < 0 != rVal < 0) && (remV != 0))
+              rslt--;
+	    return rslt;
+	}
+
+/* ==================================================================== *
+ *		Various string and char-array helpers			*
+ * ==================================================================== */
+
+	// Known in ILASM as [RTS]CP_rts::mkStr
+	public static System.String mkStr(char[] arr) {
+	    int len = chrArrLength(arr);
+	    return new System.String(arr,0,len);
+	}
+
+/* -------------------------------------------------------------------- */
+
+	// Known in ILASM as [RTS]CP_rts::caseMesg
+	public static System.String caseMesg(int i)
+	{
+	    System.String s = "CASE-trap: selector = " + i;
+	    return s;
+	}
+
+/* -------------------------------------------------------------------- */
+
+	// Known in ILASM as [RTS]CP_rts::withMesg
+	public static System.String withMesg(System.Object o)
+	{
+	//    System.String c = o.getClass().getName();
+	//    c = c.substring(c.lastIndexOf('.') + 1);
+	//    c = "WITH else-trap: type = " + c;
+	//  NEEDS TO USE LIGHTNING REFLECTION SERVICES HERE
+	    string c = "WITH else-trap: type = " + o.ToString();
+	    return c;
+	}
+
+/* -------------------------------------------------------------------- */
+
+	// Known in ILASM as [RTS]CP_rts::chrArrLength
+	public static int chrArrLength(char[] src)
+	{
+	    int  ix = 0;
+	    char ch;
+	    do {
+		ch = src[ix];
+		ix++;
+	    } while (ch != '\0');
+// System.Console.Write(ix-1);
+// System.Console.Write(' ');
+// System.Console.WriteLine(src);
+	    return ix-1;
+	}
+
+/* -------------------------------------------------------------------- */
+
+	// Known in ILASM as [RTS]CP_rts::chrArrLplus1
+	public static int chrArrLplus1(char[] src)
+	{
+	    int  ix = 0;
+	    char ch;
+	    do {
+		ch = src[ix];
+		ix++;
+	    } while (ch != '\0');
+	    return ix;
+	}
+
+/* -------------------------------------------------------------------- */
+
+	// Known in ILASM as [RTS]CP_rts::strToChO
+	public static char[] strToChO(System.String input)
+	{
+            if (input == null) return null;
+
+	    int    len = input.Length;
+	    char[] arr = new char[len+1];
+	    input.CopyTo(0, arr, 0, len);
+	    arr[len] = '\0';
+	    return arr;
+	//  return input.ToCharArray();
+	}
+
+/* -------------------------------------------------------------------- */
+
+	// Known in ILASM as [RTS]CP_rts::StrToChF
+	public static void StrToChF(char[] res, System.String inp)
+	{
+            if (inp == null) {
+                res[0] = '\0'; return;
+            }
+	    int    len = inp.Length;
+	    inp.CopyTo(0, res, 0, len);
+	    res[len] = '\0';
+	}
+
+/* -------------------------------------------------------------------- */
+
+	// Known in ILASM as [RTS]CP_rts::Stringify
+	public static void Stringify(char[] dst, char[] src)
+	{
+	    int  ix = 0;
+	    char ch;
+	    do {
+		ch = src[ix];
+		dst[ix] = ch;
+		ix++;
+	    } while (ch != '\0');
+	}
+
+/* -------------------------------------------------------------------- */
+
+	// Known in ILASM as [RTS]CP_rts::ChrArrCheck
+	public static void ChrArrCheck(char[] src)
+	{
+	    int  ix = 0;
+	    char ch;
+	    do {
+		ch = src[ix];
+		if (ch > 0xFF) throw new 
+			System.Exception("error applying SHORT to array");
+		ix++;
+	    } while (ch != '\0');
+	}
+
+/* -------------------------------------------------------------------- */
+
+	// Known in ILASM as [RTS]CP_rts::strCmp
+        public static int strCmp(char[] l, char[] r)
+	{
+	    int minL;
+	    int lLen = chrArrLength(l);
+	    int rLen = chrArrLength(r);
+	    if (lLen < rLen) minL = lLen; else minL = rLen;
+// System.Console.WriteLine();
+	    for (int ix = 0; ix < minL; ix++) {
+		char lCh = l[ix];
+		char rCh = r[ix];
+		if (lCh < rCh) return -1;
+		else if (lCh > rCh) return 1;
+	    }
+	    if (lLen < rLen) return -1;
+	    else if (lLen > rLen) return 1;
+	    else return 0;
+	}
+
+/* ==================================================================== *
+ *		String concatenation helper methods			*
+ * ==================================================================== */
+
+	// Known in ILASM as [RTS]CP_rts::aaToStr
+	public static System.String aaToStr(char[] l, char[] r)
+	{
+	    int llen = chrArrLength(l);
+	    int rlen = chrArrLength(r);
+	    System.Text.StringBuilder buff = 
+				new System.Text.StringBuilder(llen + rlen);
+	    return buff.Append(l,0,llen).Append(r,0,rlen).ToString();
+	}
+
+	// Known in ILASM as [RTS]CP_rts::asToStr
+	public static System.String asToStr(char[] l, System.String r)
+	{
+	    int llen = chrArrLength(l);
+	    System.Text.StringBuilder buff = 
+				new System.Text.StringBuilder(3 * llen);
+	    return buff.Append(l,0,llen).Append(r).ToString();
+	}
+
+	// Known in ILASM as [RTS]CP_rts::saToStr
+	public static System.String saToStr(System.String l, char[] r)
+	{
+	    int rlen = chrArrLength(r);
+	    System.Text.StringBuilder buff = 
+				new System.Text.StringBuilder(3 * rlen);
+	    return buff.Append(l).Append(r,0,rlen).ToString();
+	}
+
+	// Known in ILASM as [RTS]CP_rts::ssToStr
+	public static System.String ssToStr(System.String l, System.String r)
+	{
+	    System.Text.StringBuilder buff = 
+				new System.Text.StringBuilder(l);
+	    return buff.Append(r).ToString();
+	}
+}
+
+/* ==================================================================== */
+/* ==================================================================== */
+/* ==================================================================== */
+/* ==================================================================== */
+
+public class NativeStrings	
+// Known in ILASM as [RTS]NativeStrings
+{
+/* -------------------------------------------------------------------- */
+//
+// PROCEDURE mkStr*(IN s : ARRAY OF CHAR) : String; BEGIN RETURN NIL END mkStr;
+//
+/* -------------------------------------------------------------------- */
+	// Known in ILASM as [RTS]NativeStrings::mkStr
+	public static System.String mkStr(char[] arr) {
+	    int len = CP_rts.chrArrLength(arr);
+	    return new System.String(arr,0,len);
+	}
+
+/* -------------------------------------------------------------------- */
+//
+//  PROCEDURE mkArr*(s : String) : RTS.CharOpen); END mkArr;
+//
+/* -------------------------------------------------------------------- */
+    	// Known in ILASM as [RTS]NativeStrings::mkArr
+	public static char[] mkArr(System.String inp)
+	{
+            if (inp == null) return null;
+
+	    int    len = inp.Length;
+	    char[] res = new char[len+1];
+	    inp.CopyTo(0, res, 0, len);
+	    res[len] = '\0';
+	    return res;
+	}
+}
+/* ==================================================================== */
+/* ==================================================================== */
+//
+// Body of Console interface.
+// This file implements the code of the Console.cp file.
+// kjg May 2000.
+//
+public class Console
+// Known in ILASM as [RTS]Console
+{
+	public static void WriteLn()
+	{
+	    System.Console.WriteLine();
+	}
+
+	public static void Write(char ch)
+	{
+	    System.Console.Write(ch);
+	}
+
+	private static char[] strRep(int val)
+	{
+	    if (val < 0) { // ==> must be minInt
+		char[] min = {' ',' ','2','1','4','7','4','8','3','6','4','8'};
+		return min;
+	    }
+
+	    char[] str = {' ',' ',' ',' ',' ',' ',' ',' ',' ',' ',' ',' '};
+	    str[11] = (char) (val % 10 + (int) '0'); val = val / 10;
+	    for (int i = 10; val != 0; i--) {
+		str[i] = (char) (val % 10 + (int) '0'); val = val / 10;
+	    }
+	    return str;
+	}
+
+	public static void WriteInt(int val, int fwd)
+	{
+	    char[] str = (val >= 0 ? strRep(val) : strRep(-val));
+
+	    int blank;
+	    for (blank = 0; str[blank] == ' '; blank++)
+		;
+	    if (val < 0) {
+		str[blank-1] = '-'; blank--;
+	    }
+	    // format ...
+	    // 01...............901
+	    // _________xxxxxxxxxxx
+	    // <-blank->< 12-blank>
+	    //     <-----fwd------>
+	    if (fwd == 0) // magic case, put out exactly one blank
+		System.Console.Write(str, blank-1, 13-blank);
+	    else if (fwd < (12-blank))
+		System.Console.Write(str, blank, 12-blank);
+	    else if (fwd <= 12)
+		System.Console.Write(str, 12-fwd, fwd);
+	    else { // fwd > 12
+		for (int i = fwd-12; i > 0; i--)
+		    System.Console.Write(" ");
+		System.Console.Write(str);
+	    }
+	}
+
+	public static void WriteHex(int val, int wid)
+	{
+	    char[] str = new char[9];
+	    int j;		// index of last blank
+	    int i = 8;
+	    do {
+		int dig = val & 0xF;
+		val = (int)((uint) val >> 4);
+		if (dig >= 10)
+		    str[i] = (char) (dig + ((int) 'A' - 10));
+		else
+		    str[i] = (char) (dig + (int) '0');
+		i--;
+	    } while (val != 0);
+	    j = i;
+	    while (i >= 0) {
+		str[i] = ' '; i--;
+	    }
+	    if (wid == 0)	// special case, exactly one blank
+	        System.Console.Write(str, j, 9-j);
+	    else if (wid < (8-j))
+	        System.Console.Write(str, j+1, 8-j);
+	    else if (wid <= 9)
+	        System.Console.Write(str, 9-wid, wid);
+	    else {
+		for (i = wid-9; i > 0; i--)
+			System.Console.Write(" ");
+	        System.Console.Write(str);
+	    }
+	}
+
+
+	public static void WriteString(char[] str)
+	{
+	   int len = str.Length;
+	   for (int i = 0; i < len && str[i] != '\0'; i++)
+		System.Console.Write(str[i]);
+	}
+} // end of public class Console
+/* ==================================================================== */
+/* ==================================================================== */
+//
+// Body of StdIn module.
+// This file implements the code of the StdIn.cp file.
+// kjg Sep 2004.
+//
+// Known in ILASM as [RTS]StdIn
+//
+public class StdIn
+{
+   public static void Read(ref char c) {
+       int chr = System.Console.Read();
+       if (chr == -1) { 
+           c = '\0';
+       } else {
+           c = (char) chr;
+       }
+   }
+
+   public static void ReadLn(char[] arr) {
+       string str = System.Console.ReadLine();
+       if (str == null) {
+           arr[0] = '\0'; return;
+       }
+       int dLen = arr.Length;
+       int sLen = str.Length;
+       int cLen = (sLen < dLen ? sLen : dLen-1);
+       str.CopyTo(0, arr, 0, cLen);
+       arr[cLen] = '\0';
+   }
+
+   public static void SkipLn() {
+       string str = System.Console.ReadLine();
+   }
+
+   public static bool More() {
+       return true; // temporary, until we figure out how to get the same
+   }                // semantics on .NET and the JVM (kjg Sep. 2004
+
+} // end of public class StdIn
+
+/* ==================================================================== */
+/* ==================================================================== */
+//
+// Body of Error interface.
+// This file implements the code of the Error.cp file.
+// kjg May 2000.
+//
+public class Error
+// Known in ILASM as [RTS]Error
+{
+	public static void WriteLn()
+	{
+	    System.Console.Error.Write(System.Environment.NewLine);
+	}
+
+	public static void Write(char ch)
+	{
+	    System.Console.Error.Write(ch);
+	}
+
+	private static char[] strRep(int val)
+	{
+	    if (val < 0) { // ==> must be minInt
+		char[] min = {' ',' ','2','1','4','7','4','8','3','6','4','8'};
+		return min;
+	    }
+
+	    char[] str = {' ',' ',' ',' ',' ',' ',' ',' ',' ',' ',' ',' '};
+	    str[11] = (char) (val % 10 + (int) '0'); val = val / 10;
+	    for (int i = 10; val != 0; i--) {
+		str[i] = (char) (val % 10 + (int) '0'); val = val / 10;
+	    }
+	    return str;
+	}
+
+	public static void WriteInt(int val, int fwd)
+	{
+	    char[] str = (val >= 0 ? strRep(val) : strRep(-val));
+
+	    int blank;
+	    for (blank = 0; str[blank] == ' '; blank++)
+		;
+	    if (val < 0) {
+		str[blank-1] = '-'; blank--;
+	    }
+	    // format ...
+	    // 01...............901
+	    // _________xxxxxxxxxxx
+	    // <-blank->< 12-blank>
+	    //     <-----fwd------>
+	    if (fwd == 0) // magic case, put out exactly one blank
+		System.Console.Error.Write(str, blank-1, 13-blank);
+	    else if (fwd < (12-blank))
+		System.Console.Error.Write(str, blank, 12-blank);
+	    else if (fwd <= 12)
+		System.Console.Error.Write(str, 12-fwd, fwd);
+	    else { // fwd > 12
+		for (int i = fwd-12; i > 0; i--)
+		    System.Console.Error.Write(" ");
+		System.Console.Error.Write(str);
+	    }
+	}
+
+	public static void WriteHex(int val, int wid)
+	{
+	    char[] str = new char[9];
+	    int j;		// index of last blank
+	    int i = 8;
+	    do {
+		int dig = val & 0xF;
+		val = (int)((uint) val >> 4);
+		if (dig >= 10)
+		    str[i] = (char) (dig + ((int) 'A' - 10));
+		else
+		    str[i] = (char) (dig + (int) '0');
+		i--;
+	    } while (val != 0);
+	    j = i;
+	    while (i >= 0) {
+		str[i] = ' '; i--;
+	    }
+	    if (wid == 0)	// special case, exactly one blank
+	        System.Console.Error.Write(str, j, 9-j);
+	    else if (wid < (8-j))
+	        System.Console.Error.Write(str, j+1, 8-j);
+	    else if (wid <= 9)
+	        System.Console.Error.Write(str, 9-wid, wid);
+	    else {
+		for (i = wid-9; i > 0; i--)
+			System.Console.Error.Write(" ");
+	        System.Console.Error.Write(str);
+	    }
+	}
+
+
+	public static void WriteString(char[] str)
+	{
+	   int len = str.Length;
+	   for (int i = 0; i < len && str[i] != '\0'; i++)
+		System.Console.Error.Write(str[i]);
+	}
+  } // end of public class Error
+
+/* ==================================================================== */
+
+abstract public class XHR
+// Known in ILASM as [RTS]XHR
+{
+/* ==================================================================== *
+ *		eXplicit Heap-allocated activation Record		*
+ * ==================================================================== */
+	public XHR prev;
+}
+/* ==================================================================== */
+
+namespace Vectors {
+    public abstract class VecBase {
+        public int tide;
+
+        public abstract void expand();
+    }
+
+    public class VecChr : VecBase {
+        public char[] elms;
+
+        public override void expand() {
+            char[] tmp = new char[this.elms.Length * 2];
+            for (int i = 0; i < this.tide; i++) {
+                tmp[i] = this.elms[i];
+            }
+            this.elms = tmp;
+        }
+    }
+
+    public class VecI32 : VecBase {
+        public int[] elms;
+
+        public override void expand() {
+            int[] tmp = new int[this.elms.Length * 2];
+            for (int i = 0; i < this.tide; i++) {
+                tmp[i] = this.elms[i];
+            }
+            this.elms = tmp;
+        }
+    }
+
+    public class VecI64 : VecBase {
+        public long[] elms;
+
+        public override void expand() {
+            long[] tmp = new long[this.elms.Length * 2];
+            for (int i = 0; i < this.tide; i++) {
+                tmp[i] = this.elms[i];
+            }
+            this.elms = tmp;
+        }
+    }
+
+    public class VecR32 : VecBase {
+        public float[] elms;
+
+        public override void expand() {
+            float[] tmp = new float[this.elms.Length * 2];
+            for (int i = 0; i < this.tide; i++) {
+                tmp[i] = this.elms[i];
+            }
+            this.elms = tmp;
+        }
+    }
+
+    public class VecR64 : VecBase {
+        public double[] elms;
+
+        public override void expand() {
+            double[] tmp = new double[this.elms.Length * 2];
+            for (int i = 0; i < this.tide; i++) {
+                tmp[i] = this.elms[i];
+            }
+            this.elms = tmp;
+        }
+    }
+
+    public class VecRef : VecBase {
+        public object[] elms;
+
+        public override void expand() {
+            object[] tmp = new object[this.elms.Length * 2];
+            for (int i = 0; i < this.tide; i++) {
+                tmp[i] = this.elms[i];
+            }
+            this.elms = tmp;
+        }
+    }
+
+}
+/* ==================================================================== */
+
+
+
+
+/* ==================================================================== */