Oberon/V2/OCC
< Oberon
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 format 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 THEN364
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 (*OutCode*) 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.