Trurl-based/Dev/Mod/CPH.txt

   1 MODULE DevCPH;
   2
   3         (* THIS IS TEXT COPY OF BlackBox 1.6-rc6 Dev/Mod/CPH.odc *)
   4         (* DO NOT EDIT *)
   5
   6         IMPORT DevCPT;
   7
   8         CONST
   9                 (* UseCalls options *)
  10                 longMop* = 0; longDop* = 1; longConv* = 2; longOdd* = 3;
  11                 realMop* = 8; realDop* = 9; realConv* = 10;
  12                 intMulDiv* = 11;
  13                 force = 16; hide = 17;
  14
  15                 (* nodes classes *)
  16                 Nvar = 0; Nvarpar = 1; Nfield = 2; Nderef = 3; Nindex = 4; Nguard = 5; Neguard = 6;
  17                 Nconst = 7; Ntype = 8; Nproc = 9; Nupto = 10; Nmop = 11; Ndop = 12; Ncall = 13;
  18                 Ninittd = 14; Nif = 15; Ncaselse = 16; Ncasedo = 17; Nenter = 18; Nassign = 19;
  19                 Nifelse =20; Ncase = 21; Nwhile = 22; Nrepeat = 23; Nloop = 24; Nexit = 25;
  20                 Nreturn = 26; Nwith = 27; Ntrap = 28; Ncomp = 30;
  21                 Ndrop = 50; Nlabel = 51; Ngoto = 52; Njsr = 53; Nret = 54; Ncmp = 55;
  22
  23                 (*function number*)
  24                 assign = 0; newfn = 1; incfn = 13; decfn = 14;
  25                 inclfn = 15; exclfn = 16; copyfn = 18; assertfn = 32;
  26                 getfn = 24; putfn = 25; getrfn = 26; putrfn = 27; sysnewfn = 30; movefn = 31;
  27
  28                 (* symbol values and ops *)
  29                 times = 1; slash = 2; div = 3; mod = 4;
  30                 and = 5; plus = 6; minus = 7; or = 8; eql = 9;
  31                 neq = 10; lss = 11; leq = 12; gtr = 13; geq = 14;
  32                 in = 15; is = 16; ash = 17; msk = 18; len = 19;
  33                 conv = 20; abs = 21; cap = 22; odd = 23; not = 33;
  34                 adr = 24; cc = 25; bit = 26; lsh = 27; rot = 28; val = 29;
  35                 min = 34; max = 35; typfn = 36;
  36                 thisrecfn = 45; thisarrfn = 46;
  37                 shl = 50; shr = 51; lshr = 52; xor = 53;
  38
  39                 (* structure forms *)
  40                 Undef = 0; Byte = 1; Bool = 2; Char8 = 3; Int8 = 4; Int16 = 5; Int32 = 6;
  41                 Real32 = 7; Real64 = 8; Set = 9; String8 = 10; NilTyp = 11; NoTyp = 12;
  42                 Pointer = 13; ProcTyp = 14; Comp = 15;
  43                 Char16 = 16; String16 = 17; Int64 = 18;
  44                 VString16to8 = 29; VString8 = 30; VString16 = 31;
  45                 realSet = {Real32, Real64};
  46                 Basic = 1; Array = 2; DynArr = 3; Record = 4;
  47
  48
  49
  50         PROCEDURE UseThisCall (n: DevCPT.Node; IN name: ARRAY OF SHORTCHAR);
  51                 VAR mod, nm, moda: DevCPT.Name; mobj, obj: DevCPT.Object; done: BOOLEAN;
  52         BEGIN
  53                 IF (n.typ.form = Real64) OR (n.left.typ.form = Real64) THEN mod := "Real"
  54                 ELSIF (n.typ.form = Real32) OR (n.left.typ.form = Real32) THEN mod := "SReal"
  55                 ELSIF (n.typ.form = Int64) OR (n.left.typ.form = Int64) THEN mod := "Long"
  56                 ELSE mod := "Int"
  57                 END;
  58                 moda := mod + "%";
  59                 DevCPT.Find(moda, mobj);
  60                 IF mobj = NIL THEN
  61                         DevCPT.Import(moda, mod, done);
  62                         IF done THEN DevCPT.Find(moda, mobj) END
  63                 END;
  64                 nm := name$; DevCPT.FindImport(nm, mobj, obj);
  65                 n.class := Ncall; n.subcl := 0; n.obj := obj.link;
  66                 n.left.link := n.right; n.right := n.left;
  67                 n.left := DevCPT.NewNode(Nproc);
  68                 n.left.obj := obj; n.left.typ := obj.typ;
  69                 ASSERT(n.typ.form = obj.typ.form)
  70         END UseThisCall;
  71
  72         PROCEDURE Convert (n: DevCPT.Node; typ: DevCPT.Struct);
  73                 VAR new: DevCPT.Node; r: REAL;
  74         BEGIN
  75                 IF n.class = Nconst THEN
  76                         ASSERT((n.typ.form IN {Int32, Int64}) & (typ = DevCPT.intrealtyp));
  77                         r := n.conval.realval + n.conval.intval;
  78                         IF r = n.conval.realval + n.conval.intval THEN
  79                                 n.conval.realval := r; n.conval.intval := -1; n.typ := typ; n.obj := NIL
  80                         END
  81                 END;
  82                 IF (n.typ # typ)
  83                         & ((n.class # Nmop) OR (n.subcl # conv)
  84                                 OR ~DevCPT.Includes(n.typ.form, n.left.typ.form) & ~DevCPT.Includes(n.typ.form, typ.form)) THEN
  85                         new := DevCPT.NewNode(0); new^ := n^;
  86                         n.class := Nmop; n.subcl := conv; n.left := new; n.right := NIL; n.obj := NIL
  87                 END;
  88                 n.typ := typ
  89         END Convert;
  90
  91         PROCEDURE UseCallForComp (n: DevCPT.Node);
  92                 VAR new: DevCPT.Node;
  93         BEGIN
  94                 new := DevCPT.NewNode(0);
  95                 new.left := n.left; new.right := n.right;
  96                 new.typ := DevCPT.int32typ;
  97                 UseThisCall(new, "Comp");
  98                 n.left := new;
  99                 n.right := DevCPT.NewNode(Nconst); n.right.conval := DevCPT.NewConst();
 100                 n.right.conval.intval := 0; n.right.conval.realval := 0; n.right.typ := DevCPT.int32typ;
 101         END UseCallForComp;
 102
 103         PROCEDURE UseCallForConv (n: DevCPT.Node; opts: SET);
 104                 VAR f, g: INTEGER; typ: DevCPT.Struct;
 105         BEGIN
 106                 typ := n.typ; f := typ.form; g := n.left.typ.form;
 107                 IF realConv IN opts THEN
 108                         IF f IN realSet THEN
 109                                 IF g = Real32 THEN UseThisCall(n, "Long")
 110                                 ELSIF g = Real64 THEN UseThisCall(n, "Short")
 111                                 ELSIF g = Int64 THEN UseThisCall(n, "LFloat")
 112                                 ELSIF g = Int32 THEN UseThisCall(n, "Float")
 113                                 ELSE Convert(n.left, DevCPT.int32typ); UseThisCall(n, "Float")
 114                                 END
 115                         ELSIF g IN realSet THEN
 116                                 IF f = Int64 THEN UseThisCall(n, "LFloor")
 117                                 ELSIF f = Int32 THEN UseThisCall(n, "Floor")
 118                                 ELSE n.typ := DevCPT.int32typ; UseThisCall(n, "Floor"); Convert(n, typ)
 119                                 END
 120                         END
 121                 END;
 122                 IF longConv IN opts THEN
 123                         IF f = Int64 THEN
 124                                 IF g = Int32 THEN UseThisCall(n, "Long")
 125                                 ELSIF ~(g IN realSet) THEN Convert(n.left, DevCPT.int32typ); UseThisCall(n, "IntToLong")
 126                                 END
 127                         ELSIF g = Int64 THEN
 128                                 IF f = Int32 THEN UseThisCall(n, "Short")
 129                                 ELSIF ~(f IN realSet) THEN n.typ := DevCPT.int32typ; UseThisCall(n, "LongToInt"); Convert(n, typ)
 130                                 END
 131                         END
 132                 END
 133         END UseCallForConv;
 134
 135         PROCEDURE UseCallForMop (n: DevCPT.Node; opts: SET);
 136         BEGIN
 137                 CASE n.subcl OF
 138                 | minus:
 139                         IF (realMop IN opts) & (n.typ.form IN realSet) OR (longMop IN opts) & (n.typ.form = Int64) THEN
 140                                 UseThisCall(n, "Neg")
 141                         END
 142                 | abs:
 143                         IF (realMop IN opts) & (n.typ.form IN realSet) OR (longMop IN opts) & (n.typ.form = Int64) THEN
 144                                 UseThisCall(n, "Abs")
 145                         END
 146                 | odd:
 147                         IF (longOdd IN opts) & (n.left.typ.form = Int64) THEN UseThisCall(n, "Odd") END
 148                 | conv:
 149                         UseCallForConv(n, opts)
 150                 ELSE
 151                 END
 152         END UseCallForMop;
 153
 154         PROCEDURE UseCallForDop (n: DevCPT.Node; opts: SET);
 155         BEGIN
 156                 IF (realDop IN opts) & (n.left.typ.form IN realSet)
 157                                 OR (longDop IN opts) & (n.left.typ.form = Int64)
 158                                 OR (intMulDiv IN opts) & (n.subcl IN {times, div, mod}) & (n.typ.form = Int32) THEN
 159                         CASE n.subcl OF
 160                         | times: UseThisCall(n, "Mul")
 161                         | slash: UseThisCall(n, "Div")
 162                         | div: UseThisCall(n, "Div")
 163                         | mod: UseThisCall(n, "Mod")
 164                         | plus: UseThisCall(n, "Add")
 165                         | minus: UseThisCall(n, "Sub")
 166                         | ash: UseThisCall(n, "Ash")
 167                         | min: UseThisCall(n, "Min")
 168                         | max: UseThisCall(n, "Max")
 169                         | eql..geq: UseCallForComp(n)
 170                         ELSE
 171                         END
 172                 END
 173         END UseCallForDop;
 174
 175         PROCEDURE UseCallForMove (n: DevCPT.Node; typ: DevCPT.Struct; opts: SET);
 176                 VAR f, g: INTEGER;
 177         BEGIN
 178                 f := n.typ.form; g := typ.form;
 179                 IF f # g THEN
 180                         IF (realConv IN opts) & ((f IN realSet) OR (g IN realSet))
 181                                         OR (longConv IN opts) & ((f = Int64) OR (g = Int64)) THEN
 182                                 Convert(n, typ);
 183                                 UseCallForConv(n, opts)
 184                         END
 185                 END
 186         END UseCallForMove;
 187
 188         PROCEDURE UseCallForAssign (n: DevCPT.Node; opts: SET);
 189         BEGIN
 190                 IF n.subcl = assign THEN UseCallForMove(n.right, n.left.typ, opts) END
 191         END UseCallForAssign;
 192
 193         PROCEDURE UseCallForReturn (n: DevCPT.Node; opts: SET);
 194         BEGIN
 195                 IF (n.left # NIL) & (n.obj # NIL) THEN UseCallForMove(n.left, n.obj.typ, opts) END
 196         END UseCallForReturn;
 197
 198         PROCEDURE UseCallForParam (n: DevCPT.Node; fp: DevCPT.Object; opts: SET);
 199         BEGIN
 200                 WHILE n # NIL DO
 201                         UseCallForMove(n, fp.typ, opts);
 202                         n := n.link; fp := fp.link
 203                 END
 204         END UseCallForParam;
 205
 206         PROCEDURE UseCalls* (n: DevCPT.Node; opts: SET);
 207         BEGIN
 208                 WHILE n # NIL DO
 209                         CASE n.class OF
 210                         | Nmop:
 211                                 UseCalls(n.left, opts); UseCallForMop(n, opts)
 212                         | Ndop:
 213                                 UseCalls(n.left, opts); UseCalls(n.right, opts); UseCallForDop(n, opts)
 214                         | Ncase:
 215                                 UseCalls(n.left, opts); UseCalls(n.right.left, opts); UseCalls(n.right.right, opts)
 216                         | Nassign:
 217                                 UseCalls(n.left, opts); UseCalls(n.right, opts); UseCallForAssign(n, opts)
 218                         | Ncall:
 219                                 UseCalls(n.left, opts); UseCalls(n.right, opts); UseCallForParam(n.right, n.obj, opts)
 220                         | Nreturn:
 221                                 UseCalls(n.left, opts); UseCallForReturn(n, opts)
 222                         | Ncasedo:
 223                                 UseCalls(n.right, opts)
 224                         | Ngoto, Ndrop, Nloop, Nfield, Nderef, Nguard:
 225                                 UseCalls(n.left, opts)
 226                         | Nenter, Nifelse, Nif, Nwhile, Nrepeat, Nwith, Ncomp, Nupto, Nindex:
 227                                 UseCalls(n.left, opts); UseCalls(n.right, opts)
 228                         | Njsr, Nret, Nlabel, Ntrap, Nexit, Ninittd, Ntype, Nproc, Nconst, Nvar, Nvarpar:
 229                         END;
 230                         n := n.link
 231                 END
 232         END UseCalls;
 233
 234
 235         PROCEDURE UseReals* (n: DevCPT.Node; opts: SET);
 236         BEGIN
 237                 WHILE n # NIL DO
 238                         CASE n.class OF
 239                         | Nmop:
 240                                 IF (longMop IN opts) & (n.typ.form = Int64) & ((n.subcl = abs) OR (n.subcl = minus)) THEN
 241                                         UseReals(n.left, opts - {hide} + {force}); n.typ := DevCPT.intrealtyp
 242                                 ELSIF n.subcl = conv THEN UseReals(n.left, opts - {force} + {hide})
 243                                 ELSE UseReals(n.left, opts - {force, hide})
 244                                 END
 245                         | Ndop:
 246                                 IF (longDop IN opts) & (n.left.typ.form = Int64) THEN
 247                                         UseReals(n.left, opts - {hide} + {force}); UseReals(n.right, opts - {hide} + {force});
 248                                         IF n.typ.form = Int64 THEN n.typ := DevCPT.intrealtyp END
 249                                 ELSE UseReals(n.left, opts - {force, hide}); UseReals(n.right, opts - {force, hide})
 250                                 END
 251                         | Ncase:
 252                                 UseReals(n.left, opts - {force, hide}); UseReals(n.right.left, opts - {force, hide});
 253                                 UseReals(n.right.right, opts - {force, hide})
 254                         | Ncasedo:
 255                                 UseReals(n.right, opts - {force, hide})
 256                         | Ngoto, Ndrop, Nloop, Nreturn, Nfield, Nderef, Nguard:
 257                                 UseReals(n.left, opts - {force, hide})
 258                         | Nenter, Nassign, Ncall, Nifelse, Nif, Nwhile, Nrepeat, Nwith, Ncomp, Nupto, Nindex:
 259                                 UseReals(n.left, opts - {force, hide}); UseReals(n.right, opts - {force, hide})
 260                         | Njsr, Nret, Nlabel, Ntrap, Nexit, Ninittd, Ntype, Nproc, Nconst, Nvar, Nvarpar:
 261                         END;
 262                         IF force IN opts THEN Convert(n, DevCPT.intrealtyp)
 263                         ELSIF ~(hide IN opts) & (n.typ = DevCPT.intrealtyp) THEN Convert(n, DevCPT.int64typ)
 264                         END;
 265                         n := n.link
 266                 END
 267         END UseReals;
 268
 269 END DevCPH.
 270
 271
 272
 273
 274         PROCEDURE Traverse (n: DevCPT.Node; opts: SET);
 275         BEGIN
 276                 WHILE n # NIL DO
 277                         CASE n.class OF
 278                         | Ncase:
 279                                 Traverse(n.left, opts); Traverse(n.right.left, opts); Traverse(n.right.right, opts)
 280                         | Ncasedo:
 281                                 Traverse(n.right, opts)
 282                         | Ngoto, Ndrop, Nloop, Nreturn, Nmop, Nfield, Nderef, Nguard:
 283                                 Traverse(n.left, opts)
 284                         | Nenter, Nassign, Ncall, Nifelse, Nif, Nwhile, Nrepeat, Nwith, Ncomp, Ndop, Nupto, Nindex:
 285                                 Traverse(n.left, opts); Traverse(n.right, opts)
 286                         | Njsr, Nret, Nlabel, Ntrap, Nexit, Ninittd, Ntype, Nproc, Nconst, Nvar, Nvarpar:
 287                         END;
 288                         n := n.link
 289                 END
 290         END Traverse;
 291