1 MODULE DevCPH;
3 (* THIS IS TEXT COPY OF BlackBox 1.6-rc6 Dev/Mod/CPH.odc *)
4 (* DO NOT EDIT *)
6 IMPORT DevCPT;
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;
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;
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;
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;
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;
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;
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;
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;
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;
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;
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;
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;
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;
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;
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;
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;
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;
269 END DevCPH.
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;