home *** CD-ROM | disk | FTP | other *** search
/ Fresh Fish 10 / Fresh_Fish_10_2352.bin / new / dev / obero / oberon / projectoberonsrc / obh.mod (.txt) < prev    next >
Oberon Text  |  1994-10-17  |  18KB  |  496 lines
  1. Syntax10.Scn.Fnt
  2. MODULE OBH;    (*NW 7.6.87 / 11.7.93*)
  3.     IMPORT OBS, OBT, OBC;
  4.     CONST
  5.         (*instruction format prefixes*)
  6.             F6 = 4EH; F7 = 0CEH; F9 = 3EH; F11 = 0BEH;
  7.         (*object and item modes*)
  8.             Var   =  1; VarX  =  2; Ind   =  3; IndX  =  4; RegI  =  5;
  9.             RegX  =  6; Abs   =  7; Con   =  8; Stk   =  9; Stk0 = 10; Coc   = 11; Reg   = 12;
  10.             Fld   = 13; LProc = 15; CProc = 17; IProc = 18; Mod   = 19;
  11.         (*structure forms*)
  12.             Undef = 0; Byte = 1; Bool = 2; Char = 3; SInt = 4; Int = 5; LInt = 6;
  13.             Real = 7; LReal = 8; Set = 9; String = 10; NilTyp = 11; NoTyp = 12;
  14.             Pointer = 13; ProcTyp = 14; Array = 15; DynArr = 16; Record = 17;
  15.     TYPE LabelRange* = RECORD low*, high*: INTEGER; label*: INTEGER END ;
  16.     VAR clrchk*, stkchk*: BOOLEAN;
  17.         lengcode: ARRAY 18 OF INTEGER;
  18.     PROCEDURE setCC(VAR x: OBT.Item; cc: LONGINT);
  19.     BEGIN
  20.         x.typ := OBT.booltyp; x.mode := Coc; x.a0 := cc; x.a1 := 0; x.a2 := 0
  21.     END setCC;
  22.     PROCEDURE AdjustSP*(n: LONGINT);
  23.     BEGIN  (*ADJSPB n*)
  24.         IF n <= 127 THEN OBC.PutF3(-5A84H); OBC.PutByte(n)
  25.         ELSE OBC.PutF3(-5A83H); OBC.PutWord(n)
  26.         END
  27.     END AdjustSP;
  28.     PROCEDURE move(L: INTEGER; VAR x, y: OBT.Item);
  29.     BEGIN
  30.         IF (y.mode = Con) & (y.a0 <= 7) & (y.a0 >= -8) THEN OBC.PutF2(L+5CH, y.a0, x)  (*MOVQi*)
  31.         ELSE OBC.PutF4(L+14H, x, y)  (*MOVi*)
  32.         END
  33.     END move;
  34.     PROCEDURE load(VAR x: OBT.Item);
  35.         VAR y: OBT.Item;
  36.     BEGIN IF x.mode # Reg THEN y := x; OBC.GetReg(x); move(lengcode[x.typ.form], x, y) END
  37.     END load;
  38.     PROCEDURE moveBW(VAR x, y: OBT.Item);
  39.     BEGIN
  40.         IF (y.mode = Con) & (y.a0 <= 7) & (y.a0 >= -8) THEN OBC.PutF2(5DH, y.a0, x)
  41.         ELSE OBC.Put(F7, 10H, x, y)  (*MOVXBW*)
  42.         END
  43.     END moveBW;
  44.     PROCEDURE moveBD(VAR x, y: OBT.Item);
  45.     BEGIN
  46.         IF (y.mode = Con) & (y.a0 <= 7) & (y.a0 >= -8) THEN OBC.PutF2(5FH, y.a0, x)
  47.         ELSE OBC.Put(F7, 1CH, x, y)  (*MOVXBD*)
  48.         END
  49.     END moveBD;
  50.     PROCEDURE moveWD(VAR x, y: OBT.Item);
  51.     BEGIN
  52.         IF (y.mode = Con) & (y.a0 <= 7) & (y.a0 >= -8) THEN OBC.PutF2(5FH, y.a0, x)
  53.         ELSE OBC.Put(F7, 1DH, x, y)  (*MOVXWD*)
  54.         END
  55.     END moveWD;
  56.     PROCEDURE Leng(VAR x: OBT.Item; L: LONGINT);
  57.         VAR y: OBT.Item;
  58.     BEGIN
  59.         IF L <= 7 THEN OBC.PutF2(5FH, L, x)       (*MOVQD*)
  60.         ELSE y.mode := Con; y.a0 := L; y.typ := OBT.linttyp; OBC.PutF4(17H, x, y)
  61.         END
  62.     END Leng;
  63.     PROCEDURE MoveBlock(VAR x, y: OBT.Item; s: LONGINT; param: BOOLEAN);
  64.         VAR L: INTEGER; z: OBT.Item;
  65.     BEGIN
  66.         IF s > 0 THEN
  67.             IF param THEN s := (s+3) DIV 4 * 4; AdjustSP(s) END ;
  68.             IF s <= 16 THEN
  69.                 OBC.Put(F7, 0, x, y); OBC.PutDisp(s-1)   (*MOVMB*)
  70.             ELSE
  71.                 z.mode := Reg; z.a0 := 1; OBC.PutF4(27H, z, y);    (*ADDR y,R1*)
  72.                 z.a0 := 2; OBC.PutF4(27H, z, x); z.a0 := 0;        (*ADDR x,R2*)
  73.                 IF s MOD 4 = 0 THEN L := 3; s := s DIV 4
  74.                 ELSIF s MOD 2 = 0 THEN L := 1; s := s DIV 2
  75.                 ELSE L := 0
  76.                 END ;
  77.                 Leng(z, s);
  78.                 OBC.PutF1(14); OBC.PutByte(L); OBC.PutByte(0)      (*MOVS*)
  79.             END
  80.         END
  81.     END MoveBlock;
  82.     PROCEDURE DynArrBnd(ftyp, atyp: OBT.Struct; lev: INTEGER; adr: LONGINT; varpar: BOOLEAN);
  83.         VAR f: INTEGER; x, y, z: OBT.Item;
  84.     BEGIN (* ftyp.form = DynArr *)
  85.         x.mode := Stk; y.mode := Var;
  86.         IF varpar & (ftyp.BaseTyp.form = Byte) THEN
  87.             IF atyp.form # DynArr THEN
  88.                 IF (atyp.form # Array) OR (atyp.BaseTyp.size > 1) THEN OBS.Mark(-1) END ;
  89.                 Leng(x, atyp.size)
  90.             ELSE y.lev := lev; y.a0 := adr + atyp.adr; y.typ := OBT.linttyp;
  91.                 atyp := atyp.BaseTyp;
  92.                 IF atyp.form # DynArr THEN
  93.                     IF atyp.size > 1 THEN
  94.                         OBS.Mark(-1); z.mode := Con; z.typ := OBT.linttyp; z.a0 := atyp.size;
  95.                         load(y); OBC.Put(F7, 23H, y, z);    (* MULD z, Ry *)
  96.                         z.mode := Con; z.typ := OBT.linttyp; z.a0 := atyp.size
  97.                     END
  98.                 ELSE OBS.Mark(-1); load(y); OBC.PutF2(0FH, 1, y);
  99.                     REPEAT z.mode := Var; z.lev := lev; z.a0 := atyp.adr + adr; z.typ := OBT.linttyp;
  100.                         load(z); OBC.Put(F7, 23H, y, z);    (* MULD Rz, Ry *)
  101.                         atyp := atyp.BaseTyp
  102.                     UNTIL atyp.form # DynArr;
  103.                     IF atyp.size > 1 THEN
  104.                         z.mode := Con; z.typ := OBT.linttyp; z.a0 := atyp.size;
  105.                         OBC.Put(F7, 23H, y, z)    (* MULD z, Ry *)
  106.                     END
  107.                 END ;
  108.                 OBC.PutF4(17H, x, y)    (* MOVD apdynarrlen, TOS *)
  109.             END
  110.         ELSE
  111.             LOOP f := atyp.form;
  112.                 IF f = Array THEN Leng(x, atyp.size DIV atyp.BaseTyp.size)
  113.                 ELSIF f = DynArr THEN y.lev := lev; y.a0 := atyp.adr + adr; OBC.PutF4(17H, x, y)
  114.                 ELSE OBS.Mark(66); EXIT
  115.                 END ;
  116.                 ftyp := ftyp.BaseTyp; atyp := atyp.BaseTyp;
  117.                 IF ftyp.form # DynArr THEN
  118.                     IF ftyp # atyp THEN
  119.                         IF ~varpar & (ftyp.form = Pointer) & (atyp.form = Pointer) THEN
  120.                             ftyp := ftyp.BaseTyp; atyp := atyp.BaseTyp;
  121.                             IF (ftyp.form = Record) & (atyp.form = Record) THEN
  122.                                 WHILE (ftyp # atyp) & (atyp # NIL) DO atyp := atyp.BaseTyp END ;
  123.                                 IF atyp = NIL THEN OBS.Mark(113) END
  124.                             ELSE OBS.Mark(67)
  125.                             END
  126.                         ELSE OBS.Mark(67)
  127.                         END
  128.                     END ;
  129.                     EXIT
  130.                 END
  131.             END
  132.         END
  133.     END DynArrBnd;
  134.     PROCEDURE Trap*(n: INTEGER);
  135.     BEGIN OBC.PutF1(0F2H); OBC.PutByte(n)  (*BPT n*)
  136.     END Trap;
  137.     PROCEDURE CompareParLists*(x, y: OBT.Object);
  138.         VAR xt, yt: OBT.Struct;
  139.     BEGIN
  140.         WHILE x # NIL DO
  141.             IF y # NIL THEN
  142.                 xt := x.typ; yt := y.typ;
  143.                 WHILE (xt.form = DynArr) & (yt.form = DynArr) DO
  144.                     xt := xt.BaseTyp; yt := yt.BaseTyp
  145.                 END ;
  146.                 IF x.mode # y.mode THEN OBS.Mark(115)
  147.                 ELSIF xt # yt THEN
  148.                     IF (xt.form = ProcTyp) & (yt.form = ProcTyp) THEN
  149.                         CompareParLists(xt.link, yt.link)
  150.                     ELSE OBS.Mark(115)
  151.                     END
  152.                 END ;
  153.                 y := y.next
  154.             ELSE OBS.Mark(116)
  155.             END ;
  156.             x := x.next
  157.         END ;
  158.         IF (y # NIL) & (y.mode <= Ind) & (y.a0 > 0) THEN OBS.Mark(117) END
  159.     END CompareParLists;
  160.     PROCEDURE Assign*(VAR x, y: OBT.Item; param: BOOLEAN);
  161.         VAR f, g, L, u: INTEGER; s, vsz: LONGINT;
  162.                 p, q: OBT.Struct;
  163.                 tag, tdes: OBT.Item;
  164.     BEGIN f := x.typ.form; g := y.typ.form;
  165.         IF x.mode = Con THEN OBS.Mark(56)
  166.         ELSIF (x.mode IN {Var, VarX}) & (x.lev < 0) THEN OBS.Mark(-3)
  167.         END ;
  168.         CASE f OF
  169.         Undef, String:
  170.     | Byte: IF g IN {Undef, Byte, Char, SInt} THEN
  171.                         IF param THEN moveBD(x, y) ELSE move(0, x, y) END
  172.                     ELSE OBS.Mark(113)
  173.                     END
  174.     | Bool: IF param THEN u := 3 ELSE u := 0 END ;
  175.                     IF y.mode = Coc THEN
  176.                         IF (y.a1 = 0) & (y.a2 = 0) THEN OBC.PutF2(u+3CH, y.a0, x)
  177.                         ELSE
  178.                             IF ODD(y.a0) THEN OBC.PutF0(y.a0-1) ELSE OBC.PutF0(y.a0+1) END ;
  179.                             OBC.PutWord(y.a2); y.a2 := OBC.pc-2;
  180.                             OBC.FixLink(y.a1); OBC.PutF2(u+5CH, 1, x);
  181.                             OBC.PutF0(14); L := OBC.pc; OBC.PutWord(0);
  182.                             OBC.FixLink(y.a2); OBC.PutF2(u+5CH, 0, x); OBC.fixup(L)
  183.                         END
  184.                     ELSIF g = Bool THEN
  185.                         IF y.mode = Con THEN OBC.PutF2(u+5CH, y.a0, x)
  186.                         ELSIF param THEN OBC.Put(F7, 18H, x, y)  (*MOVZBD*)
  187.                         ELSE OBC.PutF4(14H, x, y)
  188.                         END
  189.                     ELSE OBS.Mark(113)
  190.                     END
  191.     | Char, SInt:
  192.                     IF g = f THEN
  193.                         IF param THEN moveBD(x, y) ELSE move(0, x, y) END
  194.                     ELSE OBS.Mark(113)
  195.                     END
  196.     | Int:  IF g = Int THEN
  197.                         IF param THEN moveWD(x, y) ELSE move(1, x, y) END
  198.                     ELSIF g = SInt THEN
  199.                         IF param THEN moveBD(x, y) ELSE moveBW(x, y) END
  200.                     ELSE OBS.Mark(113)
  201.                     END
  202.     | LInt: IF g = LInt THEN move(3, x, y)
  203.                     ELSIF g = Int THEN moveWD(x, y)
  204.                     ELSIF g = SInt THEN moveBD(x, y)
  205.                     ELSE OBS.Mark(113)
  206.                     END
  207.     | Real: IF g = Real THEN OBC.Put(F11, 5, x, y)
  208.                     ELSIF (SInt <= g) & (g <= LInt) THEN OBC.Put(F9, lengcode[g]+4, x, y)
  209.                     ELSE OBS.Mark(113)
  210.                     END
  211.     | LReal:IF g = LReal THEN OBC.Put(F11, 4, x, y)
  212.                     ELSIF g = Real THEN OBC.Put(F9, 1BH, x, y)
  213.                     ELSIF (SInt <= g) & (g <= LInt) THEN OBC.Put(F9, lengcode[g], x, y)
  214.                     ELSE OBS.Mark(113)
  215.                     END
  216.     | Set:  IF g = f THEN move(3, x, y) ELSE OBS.Mark(113) END
  217.     | Pointer:
  218.                     IF x.typ = y.typ THEN move(3, x, y)
  219.                     ELSIF g = NilTyp THEN OBC.PutF2(5FH, 0, x)
  220.                     ELSIF g = Pointer THEN
  221.                         p := x.typ.BaseTyp; q := y.typ.BaseTyp;
  222.                         IF (p.form = Record) & (q.form = Record) THEN
  223.                             WHILE (q # p) & (q # NIL) DO q := q.BaseTyp END ;
  224.                             IF q # NIL THEN move(3, x, y) ELSE OBS.Mark(113) END
  225.                         ELSE OBS.Mark(113)
  226.                         END
  227.                     ELSE OBS.Mark(113)
  228.                     END
  229.     | Array: s := x.typ.size;
  230.                     IF x.typ = y.typ THEN MoveBlock(x, y, s, param)
  231.                     ELSIF (g = String) & (x.typ.BaseTyp.form = Char) THEN
  232.                         s := y.a1; vsz := x.typ.size;  (*check length of string*)
  233.                         IF s > vsz THEN OBS.Mark(114) END ;
  234.                         IF param THEN
  235.                             vsz := (vsz+3) DIV 4