OBC.Mod

MODULE OBC;  (*NW 30.5.87 / 28.3.93*)

    IMPORT Files, OBS, OBT;

    CONST ObjMark = 0F5X; CodeLength = 20000; LinkLength = 250;
                ConstLength = 3500; EntryLength = 96; MaxImps = 32;
                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; Stk0 = 10; Coc   = 11; Reg   = 12;
            Fld   = 13; Typ   = 14; LProc = 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*, Pc*, level*: INTEGER;
        wasderef*: OBT.Object;
        typchk*: BOOLEAN;
        RegSet, FRegSet: SET;
        StrOffset: LONGINT;
        conx, nofrecs: INTEGER;
        fixlist0: ARRAY MaxImps OF INTEGER;  (*abs adr*)
        fixlist1: ARRAY MaxImps OF INTEGER;  (*PC-rel adr*)
        RecTab: ARRAY MaxRecs OF OBT.Struct;
        constant: ARRAY ConstLength OF CHAR;
        code:  ARRAY CodeLength OF CHAR;

    PROCEDURE SetStrOffset*(varsize: LONGINT);
    BEGIN StrOffset := -ConstLength - varsize
    END SetStrOffset;

    PROCEDURE GetReg*(VAR x: OBT.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; OBS.Mark(215); EXIT ELSE DEC(i) END ;
        END
    END GetReg;

    PROCEDURE GetFReg*(VAR x: OBT.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; OBS.Mark(216); EXIT ELSE i := i-2 END
        END
    END GetFReg;

    PROCEDURE UsedRegisters*(): SET;
    BEGIN RETURN RegSet
    END UsedRegisters;

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

    PROCEDURE Release*(VAR x: OBT.Item);
    BEGIN
        IF x.mode = Reg THEN
            IF x.typ.form IN {Real, LReal} THEN EXCL(FRegSet, x.a0) ELSE EXCL(RegSet, x.a0) END
        ELSIF x.mode = RegI THEN EXCL(RegSet, x.a0)
        ELSIF x.mode = RegX THEN EXCL(RegSet, x.a0); EXCL(RegSet, x.a2)
        ELSIF x.mode IN {VarX, IndX} THEN EXCL(RegSet, x.a2)
        END
    END Release;

    PROCEDURE CheckCodeSize*;
    BEGIN
        IF pc > CodeLength - 256 THEN OBS.Mark(210); pc := 4 END
    END CheckCodeSize;

    PROCEDURE AllocString*(VAR s: ARRAY OF CHAR; VAR x: OBT.Item);
        VAR i: INTEGER; ch: CHAR;
    BEGIN (*fill constant table backward*) i := 0;
        REPEAT ch := s[i]; INC(i) UNTIL ch = 0X;
        x.a1 := i;
        IF i <= conx THEN
            REPEAT DEC(i); DEC(conx); constant[conx] := s[i] UNTIL i = 0
        ELSE OBS.Mark(230)
        END ;
        x.a0 := conx
    END AllocString;

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

    PROCEDURE PutWord*(x: LONGINT); (*high byte first*)
    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 PutF3*(op: INTEGER);
    BEGIN code[pc] := CHR(op); INC(pc); code[pc] := CHR(op DIV 100H); INC(pc)
    END PutF3;

    PROCEDURE PutExtAdr*(mno: INTEGER; pno: LONGINT);
    BEGIN PutWord(pno - 4000H); PutF3(fixlist1[mno]); fixlist1[mno] := pc - 4
    END PutExtAdr;

    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)
                    ELSIF z.inx = 8 THEN PutDbl(z.d2); PutDbl(z.d1)
                    END
        | 1:
        | 2,6: PutDisp(z.d1)
        | 3,7: PutDisp(z.d1); PutDisp(z.d2)
        | 4,8: PutDisp(z.d1 - Pc)
        | 5,9: PutWord(z.d1 - 4000H); PutF3(fixlist0[z.d2]); fixlist0[z.d2] := pc - 4
        END
    END PutArg;

    PROCEDURE Operand(VAR x: OBT.Item; VAR z: Argument);

        PROCEDURE downlevel(VAR gen: INTEGER);
            VAR n, op: INTEGER; b: OBT.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);   (*MULD s, r*)
                PutByte(x.a2 DIV 4 + 0A0H); PutWord(0); PutWord(s)
            END
        END index;

    BEGIN
        CASE x.mode OF
             Var:  IF x.lev = 0 THEN
                             z.gen := 1BH; z.d1 := x.a0; z.form := 4
                         ELSIF x.lev < 0 THEN
                             z.gen := 15H; z.d1 := x.a0; z.d2 := -x.lev; z.form := 5
                         ELSIF x.lev = level THEN
                             z.gen := 18H; z.d1 := x.a0; z.form := 2
                         ELSIF x.lev+1 = level THEN
                             z.gen := 10H; z.d1 := 8; z.d2 := x.a0; z.form := 3
                         ELSE downlevel(z.gen); z.d1 := x.a0; z.form := 2
                         END
         | Ind:  IF x.lev <= 0 THEN OBS.Mark(240)
                         ELSIF x.lev = level THEN
                             z.gen := 10H; z.d1 := x.a0; z.d2 := x.a1; z.form := 3
                         ELSE downlevel(z.gen);
                             PutF3((z.gen*20H + z.gen-8)*40H + 17H); PutDisp(x.a0);
                             z.d1 := x.a1; z.form := 2
                         END
         | RegI: z.gen := SHORT(x.a0)+8; z.d1 := x.a1; z.form := 2
         | VarX: index;
                         IF x.lev = 0 THEN
                             z.inx := 1BH; z.d1 := x.a0; z.form := 8
                         ELSIF x.lev < 0 THEN
                             z.inx := 15H; z.d1 := x.a0; z.d2 := -x.lev; z.form := 9
                         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 OBS.Mark(240)
                         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:  z.form := 0;
                        CASE x.typ.form OF
                             Undef, Byte, Bool, Char, SInt:
                                 z.gen := 14H; z.inx := 1; z.d1 := x.a0
                         | Int:
                                 z.gen := 14H; z.inx := 2; z.d1 := x.a0
                         | LInt, Real, Set, Pointer, ProcTyp, NilTyp:
                                 z.gen := 14H; z.inx := 4; z.d1 := x.a0
                         | LReal:
                                 z.gen := 14H; z.inx := 8; z.d1 := x.a0; z.d2 := x.a1
                         | String:
                                 z.form := 4; z.gen := 1BH; z.d1 := x.a0 + StrOffset
                         END
         | Reg:  z.gen := SHORT(x.a0); z.form := 1
         | Stk:  z.gen := 17H;  z.form := 1
         | Stk0: z.gen := 19H; z.form := 2; z.d1 := 0
         | Abs:  z.gen := 15H; z.form := 2; z.d1 := x.a0
         | Coc, Fld .. Head: OBS.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: OBT.Item);
        VAR dst: Argument;
    BEGIN Operand(x, dst); Pc := pc;
        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 >= 6 THEN code[pc] := CHR(dst.inx); INC(pc) END ;
        PutArg(dst)
    END PutF2;

    PROCEDURE PutF4*(op: INTEGER; VAR x, y: OBT.Item);
        VAR dst, src: Argument;
    BEGIN Operand(x, dst); Operand(y, src); Pc := 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 >= 6 THEN code[pc] := CHR(src.inx); INC(pc) END ;
        IF dst.form >= 6 THEN code[pc] := CHR(dst.inx); INC(pc) END ;
        PutArg(src); PutArg(dst)
    END PutF4;

    PROCEDURE Put*(F, op: INTEGER; VAR x, y: OBT.Item);
        VAR dst, src: Argument;
    BEGIN Operand(x, dst); Operand(y, src); Pc := pc; 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 >= 6 THEN code[pc] := CHR(src.inx); INC(pc) END ;
        IF dst.form >= 6 THEN code[pc] := CHR(dst.inx); INC(pc) END ;
        PutArg(src); PutArg(dst)
    END Put;

    PROCEDURE RegisterRecType*(typ: OBT.Struct);
    BEGIN
        IF typ.extlev > MaxExts THEN OBS.Mark(233)
        ELSIF nofrecs < MaxRecs THEN
            RecTab[nofrecs] := typ; INC(nofrecs);
            IF level > 0 THEN DEC(conx, 4); typ.adr := conx + StrOffset END
        ELSE OBS.Mark(223)
        END
    END RegisterRecType;

    PROCEDURE SaveRegisters*(VAR gR, fR: SET; VAR x: OBT.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: OBT.Item);
        VAR i, r, m: INTEGER; y: OBT.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: OBT.Item);   (* x := ADR(y) *)
        VAR l, r: OBT.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 *)
                r.mode := Reg; r.a0 := y.a2; Put(F7, 23H, r, l)   (*MULD len, r*)
            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 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 OBS.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 OBS.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 FixupImm*(loc: INTEGER; val: LONGINT);
        VAR i: INTEGER;
    BEGIN i := 4;
        REPEAT DEC(i); DEC(loc); code[loc] := CHR(val); val := val DIV 100H UNTIL i = 0
    END FixupImm;

    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; conx := ConstLength; nofrecs := 0; RegSet := {}; FRegSet := {}; i := 0;
        REPEAT fixlist0[i] := 0; fixlist1[i] := 0; INC(i) UNTIL i = MaxImps
    END Init;

    PROCEDURE FindPtrs(typ: OBT.Struct; badr: LONGINT;
            VAR ptab: ARRAY OF LONGINT; VAR n: INTEGER);
        (*find all pointers in typ and enter their offsets (+badr) in ptab*)
        VAR fld: OBT.Object; btyp: OBT.Struct;
            i, m, s: LONGINT;
    BEGIN
        IF typ.form = Pointer THEN
            IF n < MaxPtrs THEN ptab[n] := badr; INC(n) ELSE OBS.Mark(222) END
        ELSIF typ.form = Record THEN
            btyp := typ.BaseTyp;
            IF btyp # NIL THEN FindPtrs(btyp, badr, ptab, n) END ;
            fld := typ.link;
            WHILE fld # NIL DO
                IF fld.name # "" THEN FindPtrs(fld.typ, fld.a0 + badr, ptab, n)
                ELSIF n < MaxPtrs THEN ptab[n] := fld.a0 + badr; INC(n)
                ELSE OBS.Mark(222)
                END ;
                fld := fld.next
            END
        ELSIF typ.form = Array THEN
            btyp := typ.BaseTyp; m := typ.size DIV btyp.size;
            WHILE btyp.form = Array DO
                m := btyp.size DIV btyp.BaseTyp.size * m; btyp := btyp.BaseTyp
            END ;
            IF (btyp.form = Pointer) OR (btyp.form = Record) THEN
                i := 0; s := btyp.size;
                WHILE i < m DO FindPtrs(btyp, i*s + badr, ptab, n); INC(i) END
            END
        END
    END FindPtrs;


    PROCEDURE OutCode*(VAR name, progid: ARRAY OF CHAR;
                    key: LONGINT; datasize: LONGINT);
        VAR f, i, m, np, L, L1: INTEGER;
            s, s0, refpos: LONGINT;
            nofent, nofcom, nofptrs, comsize: INTEGER;
            obj:    OBT.Object;
            typ:    OBT.Struct;
            ObjFile:   Files.File;
            out:    Files.Rider;
            PtrTab: ARRAY MaxPtrs OF LONGINT;
            ComTab: ARRAY MaxComs OF OBT.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);
            VAR i: INTEGER; ch: CHAR;
        BEGIN i := 0;
            REPEAT ch := name[i]; Files.Write(out, ch); INC(i) UNTIL ch = 0X
        END WriteName;

        PROCEDURE Collect;
            (*collect commands, and pointers*)
            VAR obj, par: OBT.Object; u: INTEGER;
        BEGIN obj := OBT.topScope.next;
            WHILE obj # NIL DO
                IF obj.mode = LProc THEN
                    IF obj.a0 = 0 THEN OBS.Mark(129)
                    ELSIF obj.marked & (obj.typ.form = NoTyp) THEN
                        par := obj.dsc;
                        IF (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 OBS.Mark(232); nofcom := 0; comsize := 0
                            END
                        END
                    END
                ELSIF obj.mode = Var THEN FindPtrs(obj.typ, obj.a0, PtrTab, nofptrs)
                END ;
                obj := obj.next
            END
        END Collect;

        PROCEDURE OutBaseTypes(typ: OBT.Struct);
        BEGIN
            IF typ.BaseTyp # NIL THEN
                OutBaseTypes(typ.BaseTyp); Files.Write(out, CHR(typ.mno)); Files.WriteLInt(out, typ.adr)
            END
        END OutBaseTypes;

        PROCEDURE OutRefBlk(first: OBT.Object; pc: INTEGER; name: ARRAY OF CHAR);
            VAR obj: OBT.Object;
        BEGIN obj := first;
            WHILE obj # NIL DO
                IF obj.mode IN {LProc, IProc} THEN OutRefBlk(obj.dsc, obj.a2, obj.name) END ;
                obj := obj.next
            END ;
            Files.Write(out, 0F8X); Files.WriteInt(out, pc); Files.WriteString(out, name);
            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.WriteLInt(out, obj.a0); Files.WriteString(out, obj.name)
                    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*)
            DEC(conx, conx MOD 4);
            nofcom := 0; comsize := 1; nofptrs := 0;
            WHILE nofptrs < nofrecs DO PtrTab[nofptrs] := RecTab[nofptrs].adr; INC(nofptrs) END ;
            Collect; L := fixlist0[0];
        (*header block*)
            Files.Write(out, ObjMark); Files.Write(out, "0"); Files.WriteLInt(out, refpos);
            Files.WriteInt(out, OBT.nofGmod); Files.WriteInt(out, OBT.entno);
            Files.WriteInt(out, nofptrs); Files.WriteInt(out, comsize);
            Files.WriteInt(out, ConstLength - conx); Files.WriteLInt(out, datasize);
            Files.WriteInt(out, pc); Files.WriteInt(out, nofrecs);
            Files.WriteLInt(out, key); Files.WriteString(out, progid);
        (*import block*)
            i := 0;
            WHILE i < OBT.nofGmod DO
                obj := OBT.GlbMod[i];
                Files.WriteLInt(out, obj.a1); Files.WriteString(out, obj.name); INC(i)
            END ;
        (*entry block*)
            Files.WriteBytes(out, OBT.entry, 2*OBT.entno);
        (*pointer block*) i := 0;
            WHILE i < nofptrs DO
                IF PtrTab[i] < -4000H THEN OBS.Mark(225) END ;
                Files.WriteInt(out, SHORT(PtrTab[i])); INC(i)
            END ;
        (*command block*) i := 0;
            WHILE i < nofcom DO
                obj := ComTab[i]; Files.WriteString(out, obj.name);
                Files.WriteInt(out, SHORT(obj.a0)); INC(i)
            END ;
            Files.Write(out, 0X);
        (*constants block*) i := conx;
            WHILE i < ConstLength DO Files.Write(out, constant[i]); INC(i) END ;
        (*code block*)
            Files.WriteBytes(out, code, pc);
        (*fixups*) i := 0;
            WHILE i < OBT.nofGmod DO
                INC(i); Files.WriteInt(out, fixlist0[i]); Files.WriteInt(out, fixlist1[i])
            END ;
        (*typdesc block*) i := 0;
            WHILE i < nofrecs DO
                typ := RecTab[i]; RecTab[i] := NIL; INC(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 ;
                np := 0; FindPtrs(typ, 0, PtrTab, np); s := np*2 + (MaxExts+1)*4;
                Files.WriteInt(out, SHORT(s)); Files.WriteInt(out, SHORT(typ.adr));   (*td size/adr*)
                s := LONG(np)*1000000H + s0; Files.WriteLInt(out, s);    (*head of typdesc*)
                Files.Write(out, CHR(typ.extlev)); OutBaseTypes(typ);
                Files.Write(out, CHR(np)); m := 0;
                WHILE m < np DO Files.WriteInt(out, SHORT(PtrTab[m])); INC(m) END
            END ;
        (*ref block*)
            refpos := Files.Pos(out);
            OutRefBlk(OBT.topScope.next, pc, "$$");
            Files.Set(out, ObjFile, 2); Files.WriteLInt(out, refpos);
        IF ~OBS.scanerr THEN Files.Register(ObjFile) END
        ELSE OBS.Mark(153)
        END
    END OutCode;

BEGIN NEW(wasderef)
END OBC.