home *** CD-ROM | disk | FTP | other *** search
/ Gold Fish 3 / goldfish_volume_3.bin / files / dev / obero / oberon / projectoberonsrc / obc.mod (.txt) < prev    next >
Encoding:
Oberon Text  |  1994-10-17  |  18.5 KB  |  547 lines
  1. Syntax10.Scn.Fnt
  2. MODULE OBC;  (*NW 30.5.87 / 28.3.93*)
  3.     IMPORT Files, OBS, OBT;
  4.     CONST ObjMark = 0F5X; CodeLength = 20000; LinkLength = 250;
  5.                 ConstLength = 3500; EntryLength = 96; MaxImps = 32;
  6.                 MaxPtrs = 64; MaxRecs = 32; MaxComs = 40; MaxExts = 7;
  7.         (*instruction prefixes*)
  8.             F6 = 4EH; F7 = 0CEH; F9 = 3EH; F11 = 0BEH;
  9.         (*object and item modes*)
  10.             Var   =  1; VarX  =  2; Ind   =  3; IndX  =  4; RegI  =  5;
  11.             RegX  =  6; Abs   =  7; Con   =  8; Stk   =  9; Stk0 = 10; Coc   = 11; Reg   = 12;
  12.             Fld   = 13; Typ   = 14; LProc = 15; SProc = 16; CProc = 17; IProc = 18; Mod   = 19; Head  = 20;
  13.         (*structure forms*)
  14.             Undef = 0; Byte = 1; Bool = 2; Char = 3; SInt = 4; Int = 5; LInt = 6;
  15.             Real = 7; LReal = 8; Set = 9; String = 10; NilTyp = 11; NoTyp = 12;
  16.             Pointer = 13; ProcTyp = 14; Array = 15; DynArr = 16; Record = 17;
  17.     TYPE Argument =
  18.             RECORD form, gen, inx: INTEGER;
  19.                 d1, d2: LONGINT
  20.             END ;
  21.     VAR pc*, Pc*, level*: INTEGER;
  22.             wasderef*: OBT.Object;
  23.             typchk*: BOOLEAN;
  24.             RegSet, FRegSet: SET;
  25.             StrOffset: LONGINT;
  26.             conx, nofrecs: INTEGER;
  27.             fixlist0: ARRAY MaxImps OF INTEGER;  (*abs adr*)
  28.             fixlist1: ARRAY MaxImps OF INTEGER;  (*PC-rel adr*)
  29.             RecTab: ARRAY MaxRecs OF OBT.Struct;
  30.             constant: ARRAY ConstLength OF CHAR;
  31.             code:  ARRAY CodeLength OF CHAR;
  32.     PROCEDURE SetStrOffset*(varsize: LONGINT);
  33.     BEGIN StrOffset := -ConstLength - varsize
  34.     END SetStrOffset;
  35.     PROCEDURE GetReg*(VAR x: OBT.Item);
  36.         VAR i: INTEGER;
  37.     BEGIN i := 7; x.mode := Reg;
  38.         LOOP IF ~(i IN RegSet) THEN x.a0 := i; INCL(RegSet,i); EXIT END ;
  39.                  IF i = 0 THEN x.a0 := 0; OBS.Mark(215); EXIT ELSE DEC(i) END ;
  40.         END
  41.     END GetReg;
  42.     PROCEDURE GetFReg*(VAR x: OBT.Item);
  43.         VAR i: INTEGER;
  44.     BEGIN i := 6; x.mode := Reg;
  45.         LOOP IF ~(i IN FRegSet) THEN x.a0 := i; INCL(FRegSet,i); EXIT END ;
  46.                  IF i = 0 THEN x.a0 := 0; OBS.Mark(216); EXIT ELSE i := i-2 END
  47.         END
  48.     END GetFReg;
  49.     PROCEDURE UsedRegisters*(): SET;
  50.     BEGIN RETURN RegSet
  51.     END UsedRegisters;
  52.     PROCEDURE FreeRegs*(r: SET);
  53.     BEGIN RegSet := r; FRegSet := {}
  54.     END FreeRegs;
  55.     PROCEDURE Release*(VAR x: OBT.Item);
  56.     BEGIN
  57.         IF x.mode = Reg THEN
  58.             IF x.typ.form IN {Real, LReal} THEN EXCL(FRegSet, x.a0) ELSE EXCL(RegSet, x.a0) END
  59.         ELSIF x.mode = RegI THEN EXCL(RegSet, x.a0)
  60.         ELSIF x.mode = RegX THEN EXCL(RegSet, x.a0); EXCL(RegSet, x.a2)
  61.         ELSIF x.mode IN {VarX, IndX} THEN EXCL(RegSet, x.a2)
  62.         END
  63.     END Release;
  64.     PROCEDURE CheckCodeSize*;
  65.     BEGIN
  66.         IF pc > CodeLength - 256 THEN OBS.Mark(210); pc := 4 END
  67.     END CheckCodeSize;
  68.     PROCEDURE AllocString*(VAR s: ARRAY OF CHAR; VAR x: OBT.Item);
  69.         VAR i: INTEGER; ch: CHAR;
  70.     BEGIN (*fill constant table backward*) i := 0;
  71.         REPEAT ch := s[i]; INC(i) UNTIL ch = 0X;
  72.         x.a1 := i;
  73.         IF i <= conx THEN
  74.             REPEAT DEC(i); DEC(conx); constant[conx] := s[i] UNTIL i = 0
  75.         ELSE OBS.Mark(230)
  76.         END ;
  77.         x.a0 := conx
  78.     END AllocString;
  79.     PROCEDURE PutByte*(x: LONGINT);
  80.     BEGIN code[pc] := CHR(x); INC(pc)
  81.     END PutByte;
  82.     PROCEDURE PutWord*(x: LONGINT); (*high byte first*)
  83.     BEGIN code[pc] := CHR(x DIV 100H); INC(pc); code[pc] := CHR(x); INC(pc)
  84.     END PutWord;
  85.     PROCEDURE PutDbl*(x: LONGINT);
  86.         VAR i: INTEGER;
  87.     BEGIN i := -32;
  88.         REPEAT INC(i, 8); code[pc] := CHR(ASH(x, i)); INC(pc) UNTIL i = 0
  89.     END PutDbl;
  90.     PROCEDURE PutF3*(op: INTEGER);
  91.     BEGIN code[pc] := CHR(op); INC(pc); code[pc] := CHR(op DIV 100H); INC(pc)
  92.     END PutF3;
  93.     PROCEDURE PutExtAdr*(mno: INTEGER; pno: LONGINT);
  94.     BEGIN PutWord(pno - 4000H); PutF3(fixlist1[mno]); fixlist1[mno] := pc - 4
  95.     END PutExtAdr;
  96.     PROCEDURE PutDisp*(x: LONGINT);
  97.     BEGIN
  98.         IF x < 0 THEN
  99.             IF x >= -40H THEN code[pc] := CHR(x+80H); INC(pc)
  100.             ELSIF x >= -2000H THEN PutWord(x+0C000H)
  101.             ELSE PutDbl(x)
  102.             END
  103.         ELSIF x < 40H THEN code[pc] := CHR(x); INC(pc)
  104.         ELSIF x < 2000H THEN PutWord(x+8000H)
  105.         ELSE PutDbl(x - 40000000H)
  106.         END
  107.     END PutDisp;
  108.     PROCEDURE PutArg(VAR z: Argument);
  109.     BEGIN
  110.         CASE z.form OF
  111.             0:   IF z.inx = 1 THEN code[pc] := CHR(z.d1); INC(pc)
  112.                     ELSIF z.inx = 2 THEN PutWord(z.d1)
  113.                     ELSIF z.inx = 4 THEN PutDbl(z.d1)
  114.                     ELSIF z.inx = 8 THEN PutDbl(z.d2); PutDbl(z.d1)
  115.                     END
  116.         | 1:
  117.         | 2,6: PutDisp(z.d1)
  118.         | 3,7: PutDisp(z.d1); PutDisp(z.d2)
  119.         | 4,8: PutDisp(z.d1 - Pc)
  120.         | 5,9: PutWord(z.d1 - 4000H); PutF3(fixlist0[z.d2]); fixlist0[z.d2] := pc - 4
  121.         END
  122.     END PutArg;
  123.     PROCEDURE Operand(VAR x: OBT.Item; VAR z: Argument);
  124.         PROCEDURE downlevel(VAR gen: INTEGER);
  125.             VAR n, op: INTEGER; b: OBT.Item;
  126.         BEGIN GetReg(b); n := level - x.lev; gen := SHORT(b.a0) + 8;
  127.             op := SHORT(b.a0)*40H - 3FE9H;
  128.             IF n = 1 THEN PutF3(op); PutDisp(8);  (*MOVD 8(FP) Rb*)
  129.             ELSE PutF3(op - 4000H); PutDisp(8); PutDisp(8);  (*MOVD 8(8(FP)) Rb*)
  130.                 WHILE n > 2 DO DEC(n);
  131.                     PutF3((SHORT(b.a0)*20H + SHORT(b.a0))*40H + 4017H); PutDisp(8)
  132.                 END
  133.             END ;
  134.         END downlevel;
  135.         PROCEDURE index;
  136.             VAR s: LONGINT;
  137.         BEGIN s := x.typ.size;
  138.             IF s = 1 THEN z.gen := 1CH
  139.             ELSIF s = 2 THEN z.gen := 1DH
  140.             ELSIF s = 4 THEN z.gen := 1EH
  141.             ELSIF s = 8 THEN z.gen := 1FH
  142.             ELSE z.gen := 1CH; PutByte(F7); PutByte(x.a2 MOD 4 * 40H + 23H);   (*MULD s, r*)
  143.                 PutByte(x.a2 DIV 4 + 0A0H); PutWord(0); PutWord(s)
  144.             END
  145.         END index;
  146.     BEGIN
  147.         CASE x.mode OF
  148.              Var:  IF x.lev = 0 THEN
  149.                              z.gen := 1BH; z.d1 := x.a0; z.form := 4
  150.                          ELSIF x.lev < 0 THEN
  151.                              z.gen := 15H; z.d1 := x.a0; z.d2 := -x.lev; z.form := 5
  152.                          ELSIF x.lev = level THEN
  153.                              z.gen := 18H; z.d1 := x.a0; z.form := 2
  154.                          ELSIF x.lev+1 = level THEN
  155.                              z.gen := 10H; z.d1 := 8; z.d2 := x.a0; z.form := 3
  156.                          ELSE downlevel(z.gen); z.d1 := x.a0; z.form := 2
  157.                          END
  158.          | Ind:  IF x.lev <= 0 THEN OBS.Mark(240)
  159.                          ELSIF x.lev = level THEN
  160.                              z.gen := 10H; z.d1 := x.a0; z.d2 := x.a1; z.form := 3
  161.                          ELSE downlevel(z.gen);
  162.                              PutF3((z.gen*20H + z.gen-8)*40H + 17H); PutDisp(x.a0);
  163.                              z.d1 := x.a1; z.form := 2
  164.                          END
  165.          | RegI: z.gen := SHORT(x.a0)+8; z.d1 := x.a1; z.form := 2
  166.          | VarX: index;
  167.                          IF x.lev = 0 THEN
  168.                              z.inx := 1BH; z.d1 := x.a0; z.form := 8
  169.                          ELSIF x.lev < 0 THEN
  170.                              z.inx := 15H; z.d1 := x.a0; z.d2 := -x.lev; z.form := 9
  171.                          ELSIF x.lev = level THEN
  172.                              z.inx := 18H; z.d1 := x.a0; z.form := 6
  173.                          ELSIF x.lev+1 = level THEN
  174.                              z.inx := 10H;  z.d1 := 8; z.d2 := x.a0; z.form := 7
  175.                          ELSE downlevel(z.inx); z.d1 := x.a0; z.form := 6
  176.                          END ;
  177.                          z.inx := z.inx*8 + SHORT(x.a2)
  178.          | IndX: index;
  179.                          IF x.lev <= 0 THEN OBS.Mark(240)
  180.                          ELSIF x.lev = level THEN
  181.                              z.inx := 10H; z.d1 := x.a0; z.d2 := x.a1; z.form := 7
  182.                          ELSE downlevel(z.inx);
  183.                              PutF3((z.inx*20H + z.inx-8)*40H + 17H); PutDisp(x.a0);
  184.                              z.d1 := x.a1; z.form := 6
  185.                          END ;
  186.                          z.inx := z.inx * 8 + SHORT(x.a2)
  187.          | RegX: index; z.inx := SHORT((x.a0+8)*8 + x.a2); z.d1 := x.a1; z.form := 6
  188.          | Con:  z.form := 0;
  189.                         CASE x.typ.form OF
  190.                              Undef, Byte, Bool, Char, SInt:
  191.                                  z.gen := 14H; z.inx := 1; z.d1 := x.a0
  192.                          | Int:
  193.                                  z.gen := 14H; z.inx := 2; z.d1 := x.a0
  194.                          | LInt, Real, Set, Pointer, ProcTyp, NilTyp:
  195.                                  z.gen := 14H; z.inx := 4; z.d1 := x.a0
  196.                          | LReal:
  197.                                  z.gen := 14H; z.inx := 8; z.d1 := x.a0; z.d2 := x.a1
  198.                          | String:
  199.                                  z.form := 4; z.gen := 1BH; z.d1 := x.a0 + StrOffset
  200.                          END
  201.          | Reg:  z.gen := SHORT(x.a0); z.form := 1
  202.          | Stk:  z.gen := 17H;  z.form := 1
  203.          | Stk0: z.gen := 19H; z.form := 2; z.d1 := 0
  204.          | Abs:  z.gen := 15H; z.form := 2; z.d1 := x.a0
  205.          | Coc, Fld .. Head: OBS.Mark(126); x.mode := Var; z.form := 0
  206.         END
  207.     END Operand;
  208.     PROCEDURE PutF0*(cond: LONGINT);
  209.     BEGIN code[pc] := CHR(cond*10H + 10); INC(pc)
  210.     END PutF0;
  211.     PROCEDURE PutF1*(op: INTEGER);
  212.     BEGIN code[pc] := CHR(op); INC(pc)
  213.     END PutF1;
  214.     PROCEDURE PutF2*(op: INTEGER; short: LONGINT; VAR x: OBT.Item);
  215.         VAR dst: Argument;
  216.     BEGIN Operand(x, dst); Pc := pc;
  217.         code[pc] := CHR(SHORT(short) MOD 2 * 80H + op); INC(pc);
  218.         code[pc] := CHR(dst.gen*8 + SHORT(short) MOD 10H DIV 2);
  219.         INC(pc);
  220.         IF dst.form >= 6 THEN code[pc] := CHR(dst.inx); INC(pc) END ;
  221.         PutArg(dst)
  222.     END PutF2;
  223.     PROCEDURE PutF4*(op: INTEGER; VAR x, y: OBT.Item);
  224.         VAR dst, src: Argument;
  225.     BEGIN Operand(x, dst); Operand(y, src); Pc := pc;
  226.         code[pc] := CHR(dst.gen MOD 4 * 40H + op); INC(pc);
  227.         code[pc] := CHR(src.gen*8 + dst.gen DIV 4); INC(pc);
  228.         IF src.form >= 6 THEN code[pc] := CHR(src.inx); INC(pc) END ;
  229.         IF dst.form >= 6 THEN code[pc] := CHR(dst.inx); INC(pc) END ;
  230.         PutArg(src); PutArg(dst)
  231.     END PutF4;
  232.     PROCEDURE Put*(F, op: INTEGER; VAR x, y: OBT.Item);
  233.         VAR dst, src: Argument;
  234.     BEGIN Operand(x, dst); Operand(y, src); Pc := pc; code[pc] := CHR(F); INC(pc);
  235.         code[pc] := CHR(dst.gen MOD 4 * 40H + op); INC(pc);
  236.         code[pc] := CHR(src.gen*8 + dst.gen DIV 4); INC(pc);
  237.         IF src.form >= 6 THEN code[pc] := CHR(src.inx); INC(pc) END ;
  238.         IF dst.form >= 6 THEN code[pc] := CHR(dst.inx); INC(pc) END ;
  239.         PutArg(src); PutArg(dst)
  240.     END Put;
  241.     PROCEDURE RegisterRecType*(typ: OBT.Struct);
  242.     BEGIN
  243.         IF typ.extlev > MaxExts THEN OBS.Mark(233)
  244.         ELSIF nofrecs < MaxRecs THEN
  245.             RecTab[nofrecs] := typ; INC(nofrecs);
  246.             IF level > 0 THEN DEC(conx, 4); typ.adr := conx + StrOffset END
  247.         ELSE OBS.Mark(223)
  248.         END
  249.     END RegisterRecType;
  250.     PROCEDURE SaveRegisters*(VAR gR, fR: SET; VAR x: OBT.Item);
  251.         VAR i, r, m: INTEGER; t: SET;
  252.     BEGIN t := RegSet;
  253.         IF x.mode IN {Reg, RegI, RegX} THEN EXCL(RegSet, x.a0) END ;
  254.         IF x.mode IN {VarX, IndX, RegX} THEN EXCL(RegSet, x.a2) END ;
  255.         gR := RegSet; fR := FRegSet;
  256.         IF RegSet # {} THEN
  257.             i := 0; r := 1; m := 0;
  258.             REPEAT
  259.                 IF i IN RegSet THEN INC(m, r) END ;
  260.                 INC(r, r); INC(i)
  261.             UNTIL i = 8;
  262.             PutF1(62H); PutByte(m)
  263.         END ;
  264.         RegSet := t - RegSet; i := 0;
  265.         WHILE FRegSet # {} DO
  266.             IF i IN FRegSet THEN
  267.                 PutF1(F11); PutF3(i*800H + 5C4H); EXCL(FRegSet, i)
  268.             END ;
  269.             INC(i, 2)
  270.         END
  271.     END SaveRegisters;
  272.     PROCEDURE RestoreRegisters*(gR, fR: SET; VAR x: OBT.Item);
  273.         VAR i, r, m: INTEGER; y: OBT.Item;
  274.     BEGIN RegSet := gR; FRegSet := fR; i := 8;
  275.         (*set result mode*) x.mode := Reg; x.a0 := 0;
  276.         IF (x.typ.form = Real) OR (x.typ.form = LReal) THEN
  277.             IF 0 IN fR THEN GetFReg(y); Put(F11, 4, y, x); x.a0 := y.a0 END ;
  278.             INCL(FRegSet, 0)
  279.         ELSE
  280.             IF 0 IN gR THEN GetReg(y); PutF4(17H, y, x); x.a0 := y.a0 END ;
  281.             INCL(RegSet, 0)
  282.         END ;
  283.         WHILE fR # {} DO
  284.             DEC(i, 2);
  285.             IF i IN fR THEN
  286.                 PutF1(F11); PutF3(i*40H - 47FCH); EXCL(fR, i)
  287.             END
  288.         END ;
  289.         IF gR # {} THEN
  290.             i := 8; r := 1; m := 0;
  291.             REPEAT DEC(i);
  292.                 IF i IN gR THEN INC(m, r) END ;
  293.                 INC(r, r)
  294.             UNTIL i = 0;
  295.             PutF1(72H); PutF1(m)
  296.         END
  297.     END RestoreRegisters;
  298.     PROCEDURE DynArrAdr*(VAR x, y: OBT.Item);    (* x := ADR(y) *)
  299.         VAR l, r: OBT.Item;
  300.     BEGIN
  301.         WHILE y.typ.form = DynArr DO    (* index with 0 *)
  302.             IF y.mode = IndX THEN
  303.                 l.mode := Var; l.a0 := y.a0 + y.typ.adr; l.lev := y.lev;
  304.                 (* l = actual dimension length *)
  305.                 r.mode := Reg; r.a0 := y.a2; Put(F7, 23H, r, l)   (*MULD len, r*)
  306.             END;
  307.             y.typ := y.typ.BaseTyp
  308.         END;
  309.         IF (y.mode = Var) OR (y.mode = Ind) & (y.a1 = 0) THEN
  310.             y.mode := Var; PutF4(17H, x, y)    (* MOVD *)
  311.         ELSE PutF4(27H, x, y); x.a1 := 0    (* ADDR *)
  312.         END
  313.     END DynArrAdr;
  314.     PROCEDURE fixup*(loc: LONGINT);  (*enter pc at loc*)
  315.         VAR x: LONGINT;
  316.     BEGIN x := pc - loc + 8001H;
  317.         code[loc] := CHR(x DIV 100H); code[loc+1] := CHR(x)
  318.     END fixup;
  319.     PROCEDURE fixupC*(loc: LONGINT);
  320.         VAR x: LONGINT;
  321.     BEGIN x := pc+1 - loc;
  322.         IF x > 3 THEN
  323.             IF x < 2000H THEN
  324.                 code[loc] := CHR(x DIV 100H + 80H); code[loc+1] := CHR(x)
  325.             ELSE OBS.Mark(211)
  326.             END
  327.         ELSE DEC(pc, 3)
  328.         END
  329.     END fixupC;
  330.     PROCEDURE fixupL*(loc: LONGINT);
  331.         VAR x: LONGINT;
  332.     BEGIN x := pc+1 - loc;
  333.         IF x > 5 THEN
  334.             code[loc+2] := CHR(x DIV 100H); code[loc+3] := CHR(x)
  335.         ELSE DEC(pc, 5)
  336.         END
  337.     END fixupL;
  338.     PROCEDURE FixLink*(L: LONGINT);
  339.         VAR L1: LONGINT;
  340.     BEGIN 
  341.         WHILE L # 0 DO
  342.             L1 := ORD(code[L])*100H + ORD(code[L+1]);
  343.             fixup(L); L := L1
  344.         END
  345.     END FixLink;
  346.     PROCEDURE FixupWith*(L, val: LONGINT);
  347.         VAR x: LONGINT;
  348.     BEGIN x := val MOD 4000H + 8000H;
  349.         IF ABS(val) >= 2000H THEN OBS.Mark(208) END ;
  350.         code[L] := CHR(x DIV 100H); code[L+1] := CHR(x)
  351.     END FixupWith;
  352.     PROCEDURE FixLinkWith*(L, val: LONGINT);
  353.         VAR L1: LONGINT;
  354.     BEGIN 
  355.         WHILE L # 0 DO
  356.             L1 := ORD(code[L])*100H + ORD(code[L+1]);
  357.             FixupWith(L, val+1 - L); L := L1
  358.         END
  359.     END FixLinkWith;
  360.     PROCEDURE FixupImm*(loc: INTEGER; val: LONGINT);
  361.         VAR i: INTEGER;
  362.     BEGIN i := 4;
  363.         REPEAT DEC(i); DEC(loc); code[loc] := CHR(val); val := val DIV 100H UNTIL i = 0
  364.     END FixupImm;
  365.     PROCEDURE MergedLinks*(L0, L1: LONGINT): LONGINT;
  366.         VAR L2, L3: LONGINT;
  367.     BEGIN (*merge chains of the two operands of AND and OR *)
  368.         IF L0 # 0 THEN L2 := L0;
  369.             LOOP L3 := ORD(code[L2])*100H + ORD(code[L2+1]);
  370.                 IF L3 = 0 THEN EXIT END ;
  371.                 L2 := L3
  372.             END ;
  373.             code[L2] := CHR(L1 DIV 100H); code[L2+1] := CHR(L1);
  374.             RETURN L0
  375.         ELSE RETURN L1
  376.         END
  377.     END MergedLinks;
  378.     PROCEDURE Init*;
  379.         VAR i: INTEGER;
  380.     BEGIN pc := 0; level := 0; conx := ConstLength; nofrecs := 0; RegSet := {}; FRegSet := {}; i := 0;
  381.         REPEAT fixlist0[i] := 0; fixlist1[i] := 0; INC(i) UNTIL i = MaxImps
  382.     END Init;
  383.     PROCEDURE FindPtrs(typ: OBT.Struct; badr: LONGINT;
  384.             VAR ptab: ARRAY OF LONGINT; VAR n: INTEGER);
  385.         (*find all pointers in typ and enter their offsets (+badr) in ptab*)
  386.         VAR fld: OBT.Object; btyp: OBT.Struct;
  387.             i, m, s: LONGINT;
  388.     BEGIN
  389.         IF typ.form = Pointer THEN
  390.             IF n < MaxPtrs THEN ptab[n] := badr; INC(n) ELSE OBS.Mark(222) END
  391.         ELSIF typ.form = Record THEN
  392.             btyp := typ.BaseTyp;
  393.             IF btyp # NIL THEN FindPtrs(btyp, badr, ptab, n) END ;
  394.             fld := typ.link;
  395.             WHILE fld # NIL DO
  396.                 IF fld.name # "" THEN FindPtrs(fld.typ, fld.a0 + badr, ptab, n)
  397.                 ELSIF n < MaxPtrs THEN ptab[n] := fld.a0 + badr; INC(n)
  398.                 ELSE OBS.Mark(222)
  399.                 END ;
  400.                 fld := fld.next
  401.             END
  402.         ELSIF typ.form = Array THEN
  403.             btyp := typ.BaseTyp; m := typ.size DIV btyp.size;
  404.             WHILE btyp.form = Array DO
  405.                 m := btyp.size DIV btyp.BaseTyp.size * m; btyp := btyp.BaseTyp
  406.             END ;
  407.             IF (btyp.form = Pointer) OR (btyp.form = Record) THEN
  408.                 i := 0; s := btyp.size;
  409.                 WHILE i < m DO FindPtrs(btyp, i*s + badr, ptab, n); INC(i) END
  410.             END
  411.         END
  412.     END FindPtrs;
  413.     PROCEDURE OutCode*(VAR name, progid: ARRAY OF CHAR;
  414.                     key: LONGINT; datasize: LONGINT);
  415.         VAR f, i, m, np, L, L1: INTEGER;
  416.             s, s0, refpos: LONGINT;
  417.             nofent, nofcom, nofptrs, comsize: INTEGER;
  418.             obj:    OBT.Object;
  419.             typ:    OBT.Struct;
  420.             ObjFile:   Files.File;
  421.             out:    Files.Rider;
  422.             PtrTab: ARRAY MaxPtrs OF LONGINT;
  423.             ComTab: ARRAY MaxComs OF OBT.Object;
  424.         PROCEDURE W(n: INTEGER);
  425.         BEGIN Files.Write(out, CHR(n)); Files.Write(out, CHR(n DIV 100H))
  426.         END W;
  427.         PROCEDURE WriteName(VAR name: ARRAY OF CHAR);
  428.             VAR i: INTEGER; ch: CHAR;
  429.         BEGIN i := 0;
  430.             REPEAT ch := name[i]; Files.Write(out, ch); INC(i) UNTIL ch = 0X
  431.         END WriteName;
  432.         PROCEDURE Collect;
  433.             (*collect commands, and pointers*)
  434.             VAR obj, par: OBT.Object; u: INTEGER;
  435.         BEGIN obj := OBT.topScope.next;
  436.             WHILE obj # NIL DO
  437.                 IF obj.mode = LProc THEN
  438.                     IF obj.a0 = 0 THEN OBS.Mark(129)
  439.                     ELSIF obj.marked & (obj.typ.form = NoTyp) THEN
  440.                         par := obj.dsc;
  441.                         IF (par = NIL) OR (par.mode > 3) OR (par.a0 < 0) THEN (*command*)
  442.                             u := 0;
  443.                             WHILE obj.name[u] > 0X DO INC(comsize); INC(u) END ;
  444.                             INC(comsize, 3);
  445.                             IF nofcom < MaxComs THEN ComTab[nofcom] := obj; INC(nofcom)
  446.                             ELSE OBS.Mark(232); nofcom := 0; comsize := 0
  447.                             END
  448.                         END
  449.                     END
  450.                 ELSIF obj.mode = Var THEN FindPtrs(obj.typ, obj.a0, PtrTab, nofptrs)
  451.                 END ;
  452.                 obj := obj.next
  453.             END
  454.         END Collect;
  455.         PROCEDURE OutBaseTypes(typ: OBT.Struct);
  456.         BEGIN
  457.             IF typ.BaseTyp # NIL THEN
  458.                 OutBaseTypes(typ.BaseTyp); Files.Write(out, CHR(typ.mno)); Files.WriteLInt(out, typ.adr)
  459.             END
  460.         END OutBaseTypes;
  461.         PROCEDURE OutRefBlk(first: OBT.Object; pc: INTEGER; name: ARRAY OF CHAR);
  462.             VAR obj: OBT.Object;
  463.         BEGIN obj := first;
  464.             WHILE obj # NIL DO
  465.                 IF obj.mode IN {LProc, IProc} THEN OutRefBlk(obj.dsc, obj.a2, obj.name) END ;
  466.                 obj := obj.next
  467.             END ;
  468.             Files.Write(out, 0F8X); Files.WriteInt(out, pc); Files.WriteString(out, name);
  469.             obj := first;
  470.             WHILE obj # NIL DO
  471.                 IF (obj.mode = Var) OR (obj.mode = Ind) THEN
  472.                     f := obj.typ.form;
  473.                     IF (f IN {Byte .. Set, Pointer})
  474.                         OR (f = Array) & (obj.typ.BaseTyp.form = Char) THEN
  475.                         Files.Write(out, CHR(obj.mode)); Files.Write(out, CHR(f));
  476.                         Files.WriteLInt(out, obj.a0); Files.WriteString(out, obj.name)
  477.                     END
  478.                 END ;
  479.                 obj:= obj.next
  480.             END
  481.         END OutRefBlk;
  482.     BEGIN ObjFile := Files.New(name);
  483.         IF ObjFile # NIL THEN
  484.             Files.Set(out, ObjFile, 0);
  485.             WHILE pc MOD 4 # 0 DO PutF1(0A2H) END ; (*NOP*)
  486.             DEC(conx, conx MOD 4);
  487.             nofcom := 0; comsize := 1; nofptrs := 0;
  488.             WHILE nofptrs < nofrecs DO PtrTab[nofptrs] := RecTab[nofptrs].adr; INC(nofptrs) END ;
  489.             Collect; L := fixlist0[0];
  490.         (*header block*)
  491.             Files.Write(out, ObjMark); Files.Write(out, "0"); Files.WriteLInt(out, refpos);
  492.             Files.WriteInt(out, OBT.nofGmod); Files.WriteInt(out, OBT.entno);
  493.             Files.WriteInt(out, nofptrs); Files.WriteInt(out, comsize);
  494.             Files.WriteInt(out, ConstLength - conx); Files.WriteLInt(out, datasize);
  495.             Files.WriteInt(out, pc); Files.WriteInt(out, nofrecs);
  496.             Files.WriteLInt(out, key); Files.WriteString(out, progid);
  497.         (*import block*)
  498.             i := 0;
  499.             WHILE i < OBT.nofGmod DO
  500.                 obj := OBT.GlbMod[i];
  501.                 Files.WriteLInt(out, obj.a1); Files.WriteString(out, obj.name); INC(i)
  502.             END ;
  503.         (*entry block*)
  504.             Files.WriteBytes(out, OBT.entry, 2*OBT.entno);
  505.         (*pointer block*) i := 0;
  506.             WHILE i < nofptrs DO
  507.                 IF PtrTab[i] < -4000H THEN OBS.Mark(225) END ;
  508.                 Files.WriteInt(out, SHORT(PtrTab[i])); INC(i)
  509.             END ;
  510.         (*command block*) i := 0;
  511.             WHILE i < nofcom DO
  512.                 obj := ComTab[i]; Files.WriteString(out, obj.name);
  513.                 Files.WriteInt(out, SHORT(obj.a0)); INC(i)
  514.             END ;
  515.             Files.Write(out, 0X);
  516.         (*constants block*) i := conx;
  517.             WHILE i < ConstLength DO Files.Write(out, constant[i]); INC(i) END ;
  518.         (*code block*)
  519.             Files.WriteBytes(out, code, pc);
  520.         (*fixups*) i := 0;
  521.             WHILE i < OBT.nofGmod DO
  522.                 INC(i); Files.WriteInt(out, fixlist0[i]); Files.WriteInt(out, fixlist1[i])
  523.             END ;
  524.         (*typdesc block*) i := 0;
  525.             WHILE i < nofrecs DO
  526.                 typ := RecTab[i]; RecTab[i] := NIL; INC(i);
  527.                 s := typ.size + 4; m := 4; s0 := 16;
  528.                 WHILE (m > 0) & (s > s0) DO INC(s0, s0); DEC(m) END ;
  529.                 IF s > s0 THEN s0 := (s+127) DIV 128 * 128 END ;
  530.                 np := 0; FindPtrs(typ, 0, PtrTab, np); s := np*2 + (MaxExts+1)*4;
  531.                 Files.WriteInt(out, SHORT(s)); Files.WriteInt(out, SHORT(typ.adr));   (*td size/adr*)
  532.                 s := LONG(np)*1000000H + s0; Files.WriteLInt(out, s);    (*head of typdesc*)
  533.                 Files.Write(out, CHR(typ.extlev)); OutBaseTypes(typ);
  534.                 Files.Write(out, CHR(np)); m := 0;
  535.                 WHILE m < np DO Files.WriteInt(out, SHORT(PtrTab[m])); INC(m) END
  536.             END ;
  537.         (*ref block*)
  538.             refpos := Files.Pos(out);
  539.             OutRefBlk(OBT.topScope.next, pc, "$$");
  540.             Files.Set(out, ObjFile, 2); Files.WriteLInt(out, refpos);
  541.             IF ~OBS.scanerr THEN Files.Register(ObjFile) END
  542.         ELSE OBS.Mark(153)
  543.         END
  544.     END OutCode;
  545. BEGIN NEW(wasderef)
  546. END OBC.
  547.