MODULE OCC;  (*NW 30.5.87 / 16.3.91*)

 IMPORT Files, OCS, OCT;

 CONST CodeLength = 18000; LinkLength = 250;
    ConstLength = 3500; EntryLength = 64;
    CodeLim = CodeLength - 100;
    MaxPtrs = 64; MaxRecs = 32; MaxComs = 40; MaxExts = 7;
  (*instruction prefixes*)
   F6 = 4EH; F7 = 0CEH; F9 = 3EH; F11 = 0BEH;

  (*object and item modes*)
   Var   =  1; VarX  =  2; Ind   =  3; IndX  =  4; RegI  =  5;
   RegX  =  6; Abs   =  7; Con   =  8; Stk   =  9; Coc   = 10;
   Reg   = 11; Fld   = 12; Typ   = 13; LProc = 14; XProc = 15;
   SProc = 16; CProc = 17; IProc = 18; Mod   = 19; Head  = 20;

  (*structure forms*)
   Undef = 0; Byte = 1; Bool = 2; Char = 3; SInt = 4; Int = 5; LInt = 6;
   Real = 7; LReal = 8; Set = 9; String = 10; NilTyp = 11; NoTyp = 12;
   Pointer = 13; ProcTyp = 14; Array = 15; DynArr = 16; Record = 17;

 TYPE Argument =
   RECORD form, gen, inx: INTEGER;
    d1, d2: LONGINT
   END ;

 VAR pc*, level*: INTEGER;
   wasderef*: OCT.Object;
   typchk*: BOOLEAN;
   RegSet*, FRegSet: SET;
   lnkx, conx, nofptrs, nofrec: INTEGER;
   PtrTab: ARRAY MaxPtrs OF LONGINT;
   RecTab: ARRAY MaxRecs OF OCT.Struct;
   constant: ARRAY ConstLength OF CHAR;
   code:  ARRAY CodeLength OF CHAR;
   link:  ARRAY LinkLength OF INTEGER;
   entry: ARRAY EntryLength OF INTEGER;

 PROCEDURE GetReg*(VAR x: OCT.Item);
  VAR i: INTEGER;
 BEGIN i := 7; x.mode := Reg;
  LOOP IF ~(i IN RegSet) THEN x.a0 := i; INCL(RegSet,i); EXIT END ;
     IF i = 0 THEN x.a0 := 0; OCS.Mark(215); EXIT ELSE DEC(i) END ;
  END
 END GetReg;

 PROCEDURE GetFReg*(VAR x: OCT.Item);
  VAR i: INTEGER;
 BEGIN i := 6; x.mode := Reg;
  LOOP IF ~(i IN FRegSet) THEN x.a0 := i; INCL(FRegSet,i); EXIT END ;
     IF i = 0 THEN x.a0 := 0; OCS.Mark(216); EXIT ELSE i := i-2 END
  END
 END GetFReg;

 PROCEDURE FreeRegs*(r: SET);
 BEGIN RegSet := r; FRegSet := {}
 END FreeRegs;

 PROCEDURE AllocInt*(k: INTEGER);
 BEGIN
  IF conx < ConstLength-1 THEN
   constant[conx] := CHR(k); INC(conx);
   constant[conx] := CHR(k DIV 100H); INC(conx)
  ELSE OCS.Mark(230); conx := 0
  END
 END AllocInt;

 PROCEDURE AllocString*(VAR s: ARRAY OF CHAR; VAR x: OCT.Item);
  VAR i: INTEGER; ch: CHAR;
 BEGIN INC(conx, (-conx) MOD 4); i := 0;
  REPEAT ch := s[i]; INC(i);
   IF conx >= ConstLength THEN OCS.Mark(230); conx := 0 END ;
   constant[conx] := ch; INC(conx)
  UNTIL ch = 0X;
  x.lev := 0; x.a0 := conx - i; x.a1 := i
 END AllocString;

 PROCEDURE AllocBounds*(min, max: INTEGER; VAR adr: LONGINT);
 BEGIN INC(conx, (-conx) MOD 4); adr := conx;
  AllocInt(max); AllocInt(min)
 END AllocBounds;

 PROCEDURE PutByte*(x: LONGINT);
 BEGIN code[pc] := CHR(x); INC(pc)
 END PutByte;

 PROCEDURE PutWord*(x: LONGINT);
 BEGIN code[pc] := CHR(x DIV 100H); INC(pc); code[pc] := CHR(x); INC(pc)
 END PutWord;

 PROCEDURE PutDbl(x: LONGINT);
  VAR i: INTEGER;
 BEGIN i := -32;
  REPEAT INC(i, 8); code[pc] := CHR(ASH(x, i)); INC(pc) UNTIL i = 0
 END PutDbl;

 PROCEDURE PutDisp*(x: LONGINT);
 BEGIN
  IF x < 0 THEN
   IF x >= -40H THEN code[pc] := CHR(x+80H); INC(pc)
   ELSIF x >= -2000H THEN PutWord(x+0C000H)
   ELSE PutDbl(x)
   END
  ELSIF x < 40H THEN code[pc] := CHR(x); INC(pc)
  ELSIF x < 2000H THEN PutWord(x+8000H)
  ELSE PutDbl(x - 40000000H)
  END
 END PutDisp;

 PROCEDURE PutArg(VAR z: Argument);
 BEGIN
  CASE z.form OF
   0:   IF z.inx = 1 THEN code[pc] := CHR(z.d1); INC(pc)
     ELSIF z.inx = 2 THEN PutWord(z.d1)
     ELSIF z.inx = 4 THEN PutDbl(z.d1)
     ELSE PutDbl(z.d2); PutDbl(z.d1)
     END
  | 1:   PutDisp(z.d1)
  | 2,5:
  | 3,6: PutDisp(z.d1)
  | 4,7: PutDisp(z.d1); PutDisp(z.d2)
  END
 END PutArg;

 PROCEDURE PutF3*(op: INTEGER);
 BEGIN code[pc] := CHR(op); INC(pc); code[pc] := CHR(op DIV 100H); INC(pc)
 END PutF3;

 PROCEDURE Operand(VAR x: OCT.Item; VAR z: Argument);
  VAR F: INTEGER;

  PROCEDURE downlevel(VAR gen: INTEGER);
   VAR n, op: INTEGER; b: OCT.Item;
  BEGIN GetReg(b); n := level - x.lev; gen := SHORT(b.a0) + 8;
   op := SHORT(b.a0)*40H - 3FE9H;
   IF n = 1 THEN PutF3(op); PutDisp(8);  (*MOVD 8(FP) Rb*)
   ELSE PutF3(op - 4000H); PutDisp(8); PutDisp(8);  (*MOVD 8(8(FP)) Rb*)
    WHILE n > 2 DO DEC(n);
     PutF3((SHORT(b.a0)*20H + SHORT(b.a0))*40H + 4017H); PutDisp(8)
    END
   END ;
  END downlevel;

  PROCEDURE index;
   VAR s: LONGINT;
  BEGIN s := x.typ.size;
   IF s = 1 THEN z.gen := 1CH
   ELSIF s = 2 THEN z.gen := 1DH
   ELSIF s = 4 THEN z.gen := 1EH
   ELSIF s = 8 THEN z.gen := 1FH
   ELSE z.gen := 1CH; PutByte(F7); PutByte(x.a2 MOD 4 * 40H + 23H);
    PutByte(x.a2 DIV 4 + 0A0H); PutWord(0); PutWord(s)  (*MUL r s*)
   END ;
  END index;

 BEGIN F := x.mode;
  CASE x.mode OF
    Var:  IF x.lev = 0 THEN
        z.gen := 1AH; z.d1 := x.a0; z.form := 3
       ELSIF x.lev < 0 THEN (*EXT*)
        z.gen := 16H; z.d1 := -x.lev; z.d2 := x.a0; z.form := 4
       ELSIF x.lev = level THEN
        z.gen := 18H; z.d1 := x.a0; z.form := 3
       ELSIF x.lev+1 = level THEN
        z.gen := 10H; z.d1 := 8; z.d2 := x.a0; z.form := 4
       ELSE downlevel(z.gen); z.d1 := x.a0; z.form := 3
       END
   | Ind:  IF x.lev = 0 THEN
        z.gen := 12H; z.d1 := x.a0; z.d2 := x.a1; z.form := 4
       ELSIF x.lev = level THEN
        z.gen := 10H; z.d1 := x.a0; z.d2 := x.a1; z.form := 4
       ELSE downlevel(z.gen);
        PutF3((z.gen*20H + z.gen-8)*40H + 17H); PutDisp(x.a0);
        z.d1 := x.a1; z.form := 3
       END
   | RegI: z.gen := SHORT(x.a0)+8; z.d1 := x.a1; z.form := 3
   | VarX: index;
       IF x.lev = 0 THEN
        z.inx := 1AH; z.d1 := x.a0; z.form := 6
       ELSIF x.lev < 0 THEN (*EXT*)
        z.inx := 16H; z.d1 := -x.lev; z.d2 := x.a0; z.form := 7
       ELSIF x.lev = level THEN
        z.inx := 18H; z.d1 := x.a0; z.form := 6
       ELSIF x.lev+1 = level THEN
        z.inx := 10H;  z.d1 := 8; z.d2 := x.a0; z.form := 7
       ELSE downlevel(z.inx); z.d1 := x.a0; z.form := 6
       END ;
       z.inx := z.inx*8 + SHORT(x.a2)
   | IndX: index;
       IF x.lev = 0 THEN
        z.inx := 12H; z.d1 := x.a0; z.d2 := x.a1; z.form := 7
       ELSIF x.lev = level THEN
        z.inx := 10H; z.d1 := x.a0; z.d2 := x.a1; z.form := 7
       ELSE downlevel(z.inx);
        PutF3((z.inx*20H + z.inx-8)*40H + 17H); PutDisp(x.a0);
        z.d1 := x.a1; z.form := 6
       END ;
       z.inx := z.inx * 8 + SHORT(x.a2)
   | RegX: index; z.inx := SHORT((x.a0+8)*8 + x.a2); z.d1 := x.a1; z.form := 6
   | Con:  CASE x.typ.form OF
        Undef, Byte, Bool, Char, SInt:
         z.gen := 14H; z.inx := 1; z.d1 := x.a0; z.form := 0
       | Int:
         z.gen := 14H; z.inx := 2; z.d1 := x.a0; z.form := 0
       | LInt, Real, Set, Pointer, ProcTyp, NilTyp:
         z.gen := 14H; z.inx := 4; z.d1 := x.a0; z.form := 0
       | LReal:
         z.gen := 14H; z.inx := 8; z.d1 := x.a0; z.d2 := x.a1; z.form := 0
       | String:
         z.gen := 1AH; z.d1 := x.a0; z.form := 3
       END
   | Reg:  z.gen := SHORT(x.a0); z.form := 2
   | Stk:  z.gen := 17H;  z.form := 2
   | Abs:  z.gen := 15H; z.form := 1; z.d1 := x.a0
   | Coc, Fld .. Head: OCS.Mark(126); x.mode := Var; z.form := 0
  END
 END Operand;

 PROCEDURE PutF0*(cond: LONGINT);
 BEGIN code[pc] := CHR(cond*10H + 10); INC(pc)
 END PutF0;

 PROCEDURE PutF1*(op: INTEGER);
 BEGIN code[pc] := CHR(op); INC(pc)
 END PutF1;

 PROCEDURE PutF2*(op: INTEGER; short: LONGINT; VAR x: OCT.Item);
  VAR dst: Argument;
 BEGIN Operand(x, dst);
  code[pc] := CHR(SHORT(short) MOD 2 * 80H + op); INC(pc);
  code[pc] := CHR(dst.gen*8 + SHORT(short) MOD 10H DIV 2);
  INC(pc);
  IF dst.form > 4 THEN code[pc] := CHR(dst.inx); INC(pc) END ;
  PutArg(dst)
 END PutF2;

 PROCEDURE PutF4*(op: INTEGER; VAR x, y: OCT.Item);
  VAR dst, src: Argument;
 BEGIN Operand(x, dst); Operand(y, src);
  code[pc] := CHR(dst.gen MOD 4 * 40H + op); INC(pc);
  code[pc] := CHR(src.gen*8 + dst.gen DIV 4); INC(pc);
  IF src.form > 4 THEN code[pc] := CHR(src.inx); INC(pc) END ;
  IF dst.form > 4 THEN code[pc] := CHR(dst.inx); INC(pc) END ;
  PutArg(src); PutArg(dst)
 END PutF4;

 PROCEDURE Put*(F, op: INTEGER; VAR x, y: OCT.Item);
  VAR dst, src: Argument;
 BEGIN Operand(x, dst); Operand(y, src); code[pc] := CHR(F); INC(pc);
  code[pc] := CHR(dst.gen MOD 4 * 40H + op); INC(pc);
  code[pc] := CHR(src.gen*8 + dst.gen DIV 4); INC(pc);
  IF src.form > 4 THEN code[pc] := CHR(src.inx); INC(pc) END ;
  IF dst.form > 4 THEN code[pc] := CHR(dst.inx); INC(pc) END ;
  PutArg(src); PutArg(dst)
 END Put;

 PROCEDURE AllocTypDesc*(typ: OCT.Struct);   (* typ.form = Record *)
 BEGIN INC(conx, (-conx) MOD 4); typ.mno := 0; typ.adr := conx;
  IF typ.n > MaxExts THEN OCS.Mark(233)
  ELSIF nofrec < MaxRecs THEN
   PtrTab[nofptrs] := conx; INC(nofptrs);
   RecTab[nofrec] := typ; INC(nofrec);
   AllocInt(0); AllocInt(0)
  ELSE OCS.Mark(223)
  END
 END AllocTypDesc;

 PROCEDURE InitTypDescs*;
  VAR x, y: OCT.Item; i: INTEGER; typ: OCT.Struct;
 BEGIN
  x.mode := Ind; x.lev := 0; y.mode := Var; i := 0;
  WHILE i < nofrec DO typ := RecTab[i]; INC(i); x.a0 := typ.adr;
   WHILE typ.BaseTyp # NIL DO (*initialization of base tag fields*)
    x.a1 := typ.n * 4; y.lev := -typ.mno; y.a0 := typ.adr; PutF4(17H, x, y);
    typ := typ.BaseTyp
   END
  END
 END InitTypDescs;

 PROCEDURE SaveRegisters*(VAR gR, fR: SET; VAR x: OCT.Item);
  VAR i, r, m: INTEGER; t: SET;
 BEGIN t := RegSet;
  IF x.mode IN {Reg, RegI, RegX} THEN EXCL(RegSet, x.a0) END ;
  IF x.mode IN {VarX, IndX, RegX} THEN EXCL(RegSet, x.a2) END ;
  gR := RegSet; fR := FRegSet;
  IF RegSet # {} THEN
   i := 0; r := 1; m := 0;
   REPEAT
    IF i IN RegSet THEN INC(m, r) END ;
    INC(r, r); INC(i)
   UNTIL i = 8;
   PutF1(62H); PutByte(m)
  END ;
  RegSet := t - RegSet; i := 0;
  WHILE FRegSet # {} DO
   IF i IN FRegSet THEN
    PutF1(F11); PutF3(i*800H + 5C4H); EXCL(FRegSet, i)
   END ;
   INC(i, 2)
  END
 END SaveRegisters;

 PROCEDURE RestoreRegisters*(gR, fR: SET; VAR x: OCT.Item);
  VAR i, r, m: INTEGER; y: OCT.Item;
 BEGIN RegSet := gR; FRegSet := fR; i := 8;
  (*set result mode*) x.mode := Reg; x.a0 := 0;
  IF (x.typ.form = Real) OR (x.typ.form = LReal) THEN
   IF 0 IN fR THEN GetFReg(y); Put(F11, 4, y, x); x.a0 := y.a0 END ;
   INCL(FRegSet, 0)
  ELSE
   IF 0 IN gR THEN GetReg(y); PutF4(17H, y, x); x.a0 := y.a0 END ;
   INCL(RegSet, 0)
  END ;
  WHILE fR # {} DO
   DEC(i, 2);
   IF i IN fR THEN
    PutF1(F11); PutF3(i*40H - 47FCH); EXCL(fR, i)
   END
  END ;
  IF gR # {} THEN
   i := 8; r := 1; m := 0;
   REPEAT DEC(i);
    IF i IN gR THEN INC(m, r) END ;
    INC(r, r)
   UNTIL i = 0;
   PutF1(72H); PutF1(m)
  END
 END RestoreRegisters;

 PROCEDURE DynArrAdr*(VAR x, y: OCT.Item); (* x := ADR(y) *)
  VAR l, z: OCT.Item;
 BEGIN
  WHILE y.typ.form = DynArr DO (* index with 0 *)
   IF y.mode = IndX THEN
    l.mode := Var; l.a0 := y.a0 + y.typ.adr; l.lev := y.lev;
    (* l = actual dimension length - 1 *)
    z.mode := Con; z.a0 := 0; z.typ := OCT.inttyp;
    Put(2EH, SHORT(y.a2)*8+5, z, l) (* INDEXW inxreg, l, 0 *)
   END;
   y.typ := y.typ.BaseTyp
  END;
  IF (y.mode = Var) OR (y.mode = Ind) & (y.a1 = 0) THEN
   y.mode := Var; PutF4(17H, x, y) (* MOVD *)
  ELSE PutF4(27H, x, y); x.a1 := 0 (* ADDR *)
  END
 END DynArrAdr;
 

 PROCEDURE Entry*(i: INTEGER): INTEGER;
 BEGIN RETURN entry[i]
 END Entry;

 PROCEDURE SetEntry*(i: INTEGER);
 BEGIN entry[i] := pc
 END SetEntry;

 PROCEDURE LinkAdr*(m: INTEGER; n: LONGINT): INTEGER;
 BEGIN
  IF lnkx >= LinkLength THEN OCS.Mark(231); lnkx := 0 END ;
  link[lnkx] := m*100H + SHORT(n); INC(lnkx); RETURN lnkx-1
 END LinkAdr;

 PROCEDURE SetLinkTable*(n: INTEGER);
 BEGIN (*base addresses of imported modules*) lnkx := 0;
  WHILE lnkx < n DO link[lnkx] := lnkx*100H + 255; INC(lnkx) END
 END SetLinkTable;

 PROCEDURE fixup*(loc: LONGINT);  (*enter pc at loc*)
  VAR x: LONGINT;
 BEGIN x := pc - loc + 8001H;
  code[loc] := CHR(x DIV 100H); code[loc+1] := CHR(x)
 END fixup;

 PROCEDURE fixupC*(loc: LONGINT);
  VAR x: LONGINT;
 BEGIN x := pc+1 - loc;
  IF x > 3 THEN
   IF x < 2000H THEN
    code[loc] := CHR(x DIV 100H + 80H); code[loc+1] := CHR(x)
   ELSE OCS.Mark(211)
   END
  ELSE DEC(pc, 3)
  END
 END fixupC;

 PROCEDURE fixupL*(loc: LONGINT);
  VAR x: LONGINT;
 BEGIN x := pc+1 - loc;
  IF x > 5 THEN
   code[loc+2] := CHR(x DIV 100H); code[loc+3] := CHR(x)
  ELSE DEC(pc, 5)
  END
 END fixupL;

 PROCEDURE FixLink*(L: LONGINT);
  VAR L1: LONGINT;
 BEGIN 
  WHILE L # 0 DO
   L1 := ORD(code[L])*100H + ORD(code[L+1]);
   fixup(L); L := L1
  END
 END FixLink;

 PROCEDURE FixupWith*(L, val: LONGINT);
  VAR x: LONGINT;
 BEGIN x := val MOD 4000H + 8000H;
  IF ABS(val) >= 2000H THEN OCS.Mark(208) END ;
  code[L] := CHR(x DIV 100H); code[L+1] := CHR(x)
 END FixupWith;

 PROCEDURE FixLinkWith*(L, val: LONGINT);
  VAR L1: LONGINT;
 BEGIN 
  WHILE L # 0 DO
   L1 := ORD(code[L])*100H + ORD(code[L+1]);
   FixupWith(L, val+1 - L); L := L1
  END
 END FixLinkWith;

 PROCEDURE MergedLinks*(L0, L1: LONGINT): LONGINT;
  VAR L2, L3: LONGINT;
 BEGIN (*merge chains of the two operands of AND and OR *)
  IF L0 # 0 THEN L2 := L0;
   LOOP L3 := ORD(code[L2])*100H + ORD(code[L2+1]);
    IF L3 = 0 THEN EXIT END ;
    L2 := L3
   END ;
   code[L2] := CHR(L1 DIV 100H); code[L2+1] := CHR(L1);
   RETURN L0
  ELSE RETURN L1
  END
 END MergedLinks;

 PROCEDURE Init*;
  VAR i: INTEGER;
 BEGIN pc := 0; level := 0; lnkx := 0; conx := 0; nofptrs := 0; nofrec := 0;
  RegSet := {}; FRegSet := {}; i := 0;
  REPEAT entry[i] := 0; INC(i) UNTIL i = EntryLength
 END Init;

 PROCEDURE OutCode*(VAR name, progid: ARRAY OF CHAR;
      key: LONGINT; entno: INTEGER; datasize: LONGINT);
  CONST ObjMark = 0F8X;
  VAR ch: CHAR; f, i, m: INTEGER;
    K, s, s0, refpos: LONGINT;
    nofcom, comsize, align: INTEGER;
    obj:    OCT.Object;
    typ:    OCT.Struct;
    ObjFile:   Files.File;
    out:    Files.Rider;
    ComTab: ARRAY MaxComs OF OCT.Object;

  PROCEDURE W(n: INTEGER);
  BEGIN Files.Write(out, CHR(n)); Files.Write(out, CHR(n DIV 100H))
  END W;

  PROCEDURE WriteName(VAR name: ARRAY OF CHAR; n: INTEGER);
   VAR i: INTEGER; ch: CHAR;
  BEGIN i := 0;
   REPEAT ch := name[i]; Files.Write(out, ch); INC(i) UNTIL ch = 0X;
   WHILE i < n DO Files.Write(out, 0X); INC(i) END
  END WriteName;

  PROCEDURE FindPtrs(typ: OCT.Struct; adr: LONGINT);
   VAR fld: OCT.Object; btyp: OCT.Struct;
    i, n, s: LONGINT;
  BEGIN
   IF typ.form = Pointer THEN
    IF nofptrs < MaxPtrs THEN PtrTab[nofptrs] := adr; INC(nofptrs) ELSE OCS.Mark(222) END
   ELSIF typ.form = Record THEN
    btyp := typ.BaseTyp;
    IF btyp # NIL THEN FindPtrs(btyp, adr) END ;
    fld := typ.link;
    WHILE fld # NIL DO
     IF fld.name # "" THEN FindPtrs(fld.typ, fld.a0 + adr)
     ELSIF nofptrs < MaxPtrs THEN PtrTab[nofptrs] := fld.a0 + adr; INC(nofptrs)
     ELSE OCS.Mark(222)
     END ;
     fld := fld.next
    END
   ELSIF typ.form = Array THEN
    btyp := typ.BaseTyp; n := typ.n;
    WHILE btyp.form = Array DO n := btyp.n * n; btyp := btyp.BaseTyp END ;
    IF (btyp.form = Pointer) OR (btyp.form = Record) THEN
     i := 0; s := btyp.size;
     WHILE i < n DO FindPtrs(btyp, i*s + adr); INC(i) END
    END
   END
  END FindPtrs;

  PROCEDURE PtrsAndComs;
   VAR obj, par: OCT.Object; u: INTEGER;
  BEGIN obj := OCT.topScope.next;
   WHILE obj # NIL DO
    IF obj.mode = XProc THEN par := obj.dsc;
     IF entry[SHORT(obj.a0)] = 0 THEN OCS.Mark(129)
     ELSIF (obj.marked) & (obj.typ = OCT.notyp) &
       ((par = NIL) OR (par.mode > 3) OR (par.a0 < 0)) THEN (*command*)
      u := 0;
      WHILE obj.name[u] > 0X DO INC(comsize); INC(u) END ;
      INC(comsize, 3);
      IF nofcom < MaxComs THEN ComTab[nofcom] := obj; INC(nofcom)
      ELSE OCS.Mark(232); nofcom := 0; comsize := 0
      END
     END
    ELSIF obj.mode = Var THEN
     FindPtrs(obj.typ, obj.a0)
    END ;
    obj := obj.next
   END
  END PtrsAndComs;

  PROCEDURE OutRefBlk(first: OCT.Object; pc: INTEGER; name: ARRAY OF CHAR);
   VAR obj: OCT.Object;
  BEGIN obj := first;
   WHILE obj # NIL DO
    IF obj.mode IN {LProc, XProc, IProc} THEN OutRefBlk(obj.dsc, obj.a2, obj.name) END ;
    obj := obj.next
   END ;
   Files.Write(out, 0F8X); Files.WriteBytes(out, pc, 2); WriteName(name, 0);
   obj := first;
   WHILE obj # NIL DO
    IF (obj.mode = Var) OR (obj.mode = Ind) THEN
     f := obj.typ.form;
     IF (f IN {Byte .. Set, Pointer})
      OR (f = Array) & (obj.typ.BaseTyp.form = Char) THEN
      Files.Write(out, CHR(obj.mode)); Files.Write(out, CHR(f));
      Files.WriteBytes(out, obj.a0, 4); WriteName(obj.name, 0)
     END
    END ;
    obj:= obj.next
   END
  END OutRefBlk;

 BEGIN ObjFile := Files.New(name);
  IF ObjFile # NIL THEN
   Files.Set(out, ObjFile, 0);
   WHILE pc MOD 4 # 0 DO PutF1(0A2H) END ; (*NOP*)
   INC(conx, (-conx) MOD 4);
   nofcom := 0; comsize := 1;
   PtrsAndComs; align := comsize MOD 2; INC(comsize, align);
  (*header block*)
   Files.Write(out, ObjMark); Files.Write(out, "6"); W(0); W(0);
   W(entno); W(comsize); W(nofptrs); W(OCT.nofGmod);
   W(lnkx); Files.WriteBytes(out, datasize, 4); W(conx); W(pc);
   Files.WriteBytes(out, key, 4); WriteName(progid, 20);
  (*entry block*)
   Files.Write(out, 82X); Files.WriteBytes(out, entry, 2*entno);
  (*command block*)
   Files.Write(out, 83X);
   i := 0;  (*write command names and entry addresses*)
   WHILE i < nofcom DO
    obj := ComTab[i]; WriteName(obj.name, 0); W(entry[obj.a0]); INC(i)
   END ;
   Files.Write(out, 0X);
   IF align > 0 THEN Files.Write(out, 0FFX) END ;
  (*pointer block*)
   Files.Write(out, 84X); i := 0;
   WHILE i < nofptrs DO
    IF PtrTab[i] < -4000H THEN OCS.Mark(225) END ;
    Files.WriteBytes(out, PtrTab[i], 2); INC(i)
   END ;
  (*import block*)
   Files.Write(out, 85X); i := 0;
   WHILE i < OCT.nofGmod DO
    obj := OCT.GlbMod[i];
    Files.WriteBytes(out, obj.a1, 4); WriteName(obj.name, 0); Files.Write(out, 0X);
    INC(i)
   END ;
  (*link block*)
   Files.Write(out, 86X); Files.WriteBytes(out, link, 2*lnkx);
  (*data block*)
   Files.Write(out, 87X); Files.WriteBytes(out, constant, conx);
  (*code block*)
   Files.Write(out, 88X); Files.WriteBytes(out, code, pc);
  (*type block*)
   Files.Write(out, 89X); i := 0;
   WHILE i < nofrec DO
    typ := RecTab[i]; s := typ.size + 4; m := 4; s0 := 16;
    WHILE (m > 0) & (s > s0) DO INC(s0, s0); DEC(m) END ;
    IF s > s0 THEN s0 := (s+127) DIV 128 * 128 END ;
    nofptrs := 0; FindPtrs(typ, 0);
    s := nofptrs*2 + (MaxExts+1)*4; Files.WriteBytes(out, s, 2);  (*td size*)
    Files.WriteBytes(out, typ.adr, 2);               (*td adr*)
    K := LONG(nofptrs)*1000000H + s0; Files.WriteBytes(out, K, 4);
    K := 0; m := 0;
    REPEAT Files.WriteBytes(out, K, 4); INC(m) UNTIL m = MaxExts;
    m := 0;
    WHILE m < nofptrs DO
     Files.WriteBytes(out, PtrTab[m], 2); INC(m)
    END ;
    INC(i)
   END ;
  (*ref block*)
   refpos := Files.Pos(out); Files.Write(out, 8AX);
   OutRefBlk(OCT.topScope.next, pc, "$$");
   Files.Set(out, ObjFile, 2); Files.WriteBytes(out, refpos, 4);
      IF ~OCS.scanerr THEN Files.Register(ObjFile) END
  ELSE OCS.Mark(153)
  END
 END OutCode;

 PROCEDURE Close*;
  VAR i: INTEGER;
 BEGIN i := 0;
  WHILE i < MaxRecs DO RecTab[i] := NIL; INC(i) END
 END Close;
 
BEGIN NEW(wasderef)
END OCC.