56a840a4857ac7b452842443cbfb3b0ab3dcbeb3
1 MODULE DevCPB;
3 (* THIS IS TEXT COPY OF BlackBox 1.6-rc6 Dev/Mod/CPB.odc *)
4 (* DO NOT EDIT *)
6 IMPORT DevCPT, DevCPM;
8 CONST
9 (* symbol values or ops *)
10 times = 1; slash = 2; div = 3; mod = 4;
11 and = 5; plus = 6; minus = 7; or = 8; eql = 9;
12 neq = 10; lss = 11; leq = 12; gtr = 13; geq = 14;
13 in = 15; is = 16; ash = 17; msk = 18; len = 19;
14 conv = 20; abs = 21; cap = 22; odd = 23; not = 33;
15 (*SYSTEM*)
16 adr = 24; cc = 25; bit = 26; lsh = 27; rot = 28; val = 29;
17 min = 34; max = 35; typfn = 36; size = 37;
19 (* object modes *)
20 Var = 1; VarPar = 2; Con = 3; Fld = 4; Typ = 5; LProc = 6; XProc = 7;
21 SProc = 8; CProc = 9; IProc = 10; Mod = 11; Head = 12; TProc = 13;
23 (* Structure forms *)
24 Undef = 0; Byte = 1; Bool = 2; Char8 = 3; Int8 = 4; Int16 = 5; Int32 = 6;
25 Real32 = 7; Real64 = 8; Set = 9; String8 = 10; NilTyp = 11; NoTyp = 12;
26 Pointer = 13; ProcTyp = 14; Comp = 15;
27 Char16 = 16; String16 = 17; Int64 = 18;
28 intSet = {Int8..Int32, Int64}; realSet = {Real32, Real64}; charSet = {Char8, Char16};
30 (* composite structure forms *)
31 Basic = 1; Array = 2; DynArr = 3; Record = 4;
33 (* nodes classes *)
34 Nvar = 0; Nvarpar = 1; Nfield = 2; Nderef = 3; Nindex = 4; Nguard = 5; Neguard = 6;
35 Nconst = 7; Ntype = 8; Nproc = 9; Nupto = 10; Nmop = 11; Ndop = 12; Ncall = 13;
36 Ninittd = 14; Nif = 15; Ncaselse = 16; Ncasedo = 17; Nenter = 18; Nassign = 19;
37 Nifelse = 20; Ncase = 21; Nwhile = 22; Nrepeat = 23; Nloop = 24; Nexit = 25;
38 Nreturn = 26; Nwith = 27; Ntrap = 28;
40 (*function number*)
41 assign = 0;
42 haltfn = 0; newfn = 1; absfn = 2; capfn = 3; ordfn = 4;
43 entierfn = 5; oddfn = 6; minfn = 7; maxfn = 8; chrfn = 9;
44 shortfn = 10; longfn = 11; sizefn = 12; incfn = 13; decfn = 14;
45 inclfn = 15; exclfn = 16; lenfn = 17; copyfn = 18; ashfn = 19; assertfn = 32;
46 lchrfn = 33; lentierfcn = 34; bitsfn = 37; bytesfn = 38;
48 (*SYSTEM function number*)
49 adrfn = 20; ccfn = 21; lshfn = 22; rotfn = 23;
50 getfn = 24; putfn = 25; getrfn = 26; putrfn = 27;
51 bitfn = 28; valfn = 29; sysnewfn = 30; movefn = 31;
52 thisrecfn = 45; thisarrfn = 46;
54 (* COM function number *)
55 validfn = 40; iidfn = 41; queryfn = 42;
57 (* module visibility of objects *)
58 internal = 0; external = 1; externalR = 2; inPar = 3; outPar = 4;
60 (* procedure flags (conval.setval) *)
61 hasBody = 1; isRedef = 2; slNeeded = 3; imVar = 4;
63 (* attribute flags (attr.adr, struct.attribute, proc.conval.setval)*)
64 newAttr = 16; absAttr = 17; limAttr = 18; empAttr = 19; extAttr = 20;
66 (* case statement flags (conval.setval) *)
67 useTable = 1; useTree = 2;
69 (* sysflags *)
70 nilBit = 1; inBit = 2; outBit = 4; newBit = 8; iidBit = 16; interface = 10; jint = -11; jstr = -13;
72 AssertTrap = 0; (* default trap number *)
74 covarOut = FALSE;
77 VAR
78 typSize*: PROCEDURE(typ: DevCPT.Struct);
79 zero, one, two, dummy, quot: DevCPT.Const;
81 PROCEDURE err(n: SHORTINT);
82 BEGIN DevCPM.err(n)
83 END err;
85 PROCEDURE NewLeaf*(obj: DevCPT.Object): DevCPT.Node;
86 VAR node: DevCPT.Node; typ: DevCPT.Struct;
87 BEGIN
88 typ := obj.typ;
89 CASE obj.mode OF
90 Var:
91 node := DevCPT.NewNode(Nvar); node.readonly := (obj.vis = externalR) & (obj.mnolev < 0)
92 | VarPar:
93 node := DevCPT.NewNode(Nvarpar); node.readonly := obj.vis = inPar;
94 | Con:
95 node := DevCPT.NewNode(Nconst); node.conval := DevCPT.NewConst();
96 node.conval^ := obj.conval^ (* string is not copied, only its ref *)
97 | Typ:
98 node := DevCPT.NewNode(Ntype)
99 | LProc..IProc, TProc:
100 node := DevCPT.NewNode(Nproc)
101 ELSE err(127); node := DevCPT.NewNode(Nvar); typ := DevCPT.notyp
102 END ;
103 node.obj := obj; node.typ := typ;
104 RETURN node
105 END NewLeaf;
107 PROCEDURE Construct*(class: BYTE; VAR x: DevCPT.Node; y: DevCPT.Node);
108 VAR node: DevCPT.Node;
109 BEGIN
110 node := DevCPT.NewNode(class); node.typ := DevCPT.notyp;
111 node.left := x; node.right := y; x := node
112 END Construct;
114 PROCEDURE Link*(VAR x, last: DevCPT.Node; y: DevCPT.Node);
115 BEGIN
116 IF x = NIL THEN x := y ELSE last.link := y END ;
117 WHILE y.link # NIL DO y := y.link END ;
118 last := y
119 END Link;
121 PROCEDURE BoolToInt(b: BOOLEAN): INTEGER;
122 BEGIN
123 IF b THEN RETURN 1 ELSE RETURN 0 END
124 END BoolToInt;
126 PROCEDURE IntToBool(i: INTEGER): BOOLEAN;
127 BEGIN
128 IF i = 0 THEN RETURN FALSE ELSE RETURN TRUE END
129 END IntToBool;
131 PROCEDURE NewBoolConst*(boolval: BOOLEAN): DevCPT.Node;
132 VAR x: DevCPT.Node;
133 BEGIN
134 x := DevCPT.NewNode(Nconst); x.typ := DevCPT.booltyp;
135 x.conval := DevCPT.NewConst(); x.conval.intval := BoolToInt(boolval); RETURN x
136 END NewBoolConst;
138 PROCEDURE OptIf*(VAR x: DevCPT.Node); (* x.link = NIL *)
139 VAR if, pred: DevCPT.Node;
140 BEGIN
141 if := x.left;
142 WHILE if.left.class = Nconst DO
143 IF IntToBool(if.left.conval.intval) THEN x := if.right; RETURN
144 ELSIF if.link = NIL THEN x := x.right; RETURN
145 ELSE if := if.link; x.left := if
146 END
147 END ;
148 pred := if; if := if.link;
149 WHILE if # NIL DO
150 IF if.left.class = Nconst THEN
151 IF IntToBool(if.left.conval.intval) THEN
152 pred.link := NIL; x.right := if.right; RETURN
153 ELSE if := if.link; pred.link := if
154 END
155 ELSE pred := if; if := if.link
156 END
157 END
158 END OptIf;
160 PROCEDURE Nil*(): DevCPT.Node;
161 VAR x: DevCPT.Node;
162 BEGIN
163 x := DevCPT.NewNode(Nconst); x.typ := DevCPT.niltyp;
164 x.conval := DevCPT.NewConst(); x.conval.intval := 0; RETURN x
165 END Nil;
167 PROCEDURE EmptySet*(): DevCPT.Node;
168 VAR x: DevCPT.Node;
169 BEGIN
170 x := DevCPT.NewNode(Nconst); x.typ := DevCPT.settyp;
171 x.conval := DevCPT.NewConst(); x.conval.setval := {}; RETURN x
172 END EmptySet;
174 PROCEDURE MarkAsUsed (node: DevCPT.Node);
175 VAR c: BYTE;
176 BEGIN
177 c := node.class;
178 WHILE (c = Nfield) OR (c = Nindex) OR (c = Nguard) OR (c = Neguard) DO node := node.left; c := node.class END;
179 IF (c = Nvar) & (node.obj.mnolev > 0) THEN node.obj.used := TRUE END
180 END MarkAsUsed;
183 PROCEDURE GetTempVar* (name: ARRAY OF SHORTCHAR; typ: DevCPT.Struct; VAR obj: DevCPT.Object);
184 VAR n: DevCPT.Name; o: DevCPT.Object;
185 BEGIN
186 n := "@@ "; DevCPT.Insert(n, obj); obj.name^ := name$; (* avoid err 1 *)
187 obj.mode := Var; obj.typ := typ;
188 o := DevCPT.topScope.scope;
189 IF o = NIL THEN DevCPT.topScope.scope := obj
190 ELSE
191 WHILE o.link # NIL DO o := o.link END;
192 o.link := obj
193 END
194 END GetTempVar;
197 (* ---------- constant operations ---------- *)
199 PROCEDURE Log (x: DevCPT.Node): INTEGER;
200 VAR val, exp: INTEGER;
201 BEGIN
202 exp := 0;
203 IF x.typ.form = Int64 THEN
204 RETURN -1
205 ELSE
206 val := x.conval.intval;
207 IF val > 0 THEN
208 WHILE ~ODD(val) DO val := val DIV 2; INC(exp) END
209 END;
210 IF val # 1 THEN exp := -1 END
211 END;
212 RETURN exp
213 END Log;
215 PROCEDURE Floor (x: REAL): REAL;
216 VAR y: REAL;
217 BEGIN
218 IF ABS(x) > 9007199254740992.0 (* 2^53 *) THEN RETURN x
219 ELSIF (x >= MAX(INTEGER) + 1.0) OR (x < MIN(INTEGER)) THEN
220 y := Floor(x / (MAX(INTEGER) + 1.0)) * (MAX(INTEGER) + 1.0);
221 RETURN SHORT(ENTIER(x - y)) + y
222 ELSE RETURN SHORT(ENTIER(x))
223 END
224 END Floor;
226 PROCEDURE SetToInt (s: SET): INTEGER;
227 VAR x, i: INTEGER;
228 BEGIN
229 i := 31; x := 0;
230 IF 31 IN s THEN x := -1 END;
231 WHILE i > 0 DO
232 x := x * 2; DEC(i);
233 IF i IN s THEN INC(x) END
234 END;
235 RETURN x
236 END SetToInt;
238 PROCEDURE IntToSet (x: INTEGER): SET;
239 VAR i: INTEGER; s: SET;
240 BEGIN
241 i := 0; s := {};
242 WHILE i < 32 DO
243 IF ODD(x) THEN INCL(s, i) END;
244 x := x DIV 2; INC(i)
245 END;
246 RETURN s
247 END IntToSet;
249 PROCEDURE GetConstType (x: DevCPT.Const; form: INTEGER; errno: SHORTINT; VAR typ: DevCPT.Struct);
250 CONST MAXL = 9223372036854775808.0; (* 2^63 *)
251 BEGIN
252 IF (form IN intSet + charSet) & (x.realval + x.intval >= MIN(INTEGER))
253 & (x.realval + x.intval <= MAX(INTEGER)) THEN
254 x.intval := SHORT(ENTIER(x.realval + x.intval)); x.realval := 0
255 END;
256 IF form IN intSet THEN
257 IF x.realval = 0 THEN typ := DevCPT.int32typ
258 ELSIF (x.intval >= -MAXL - x.realval) & (x.intval < MAXL - x.realval) THEN typ := DevCPT.int64typ
259 ELSE err(errno); x.intval := 1; x.realval := 0; typ := DevCPT.int32typ
260 END
261 ELSIF form IN realSet THEN (* SR *)
262 typ := DevCPT.real64typ
263 ELSIF form IN charSet THEN
264 IF x.intval <= 255 THEN typ := DevCPT.char8typ
265 ELSE typ := DevCPT.char16typ
266 END
267 ELSE typ := DevCPT.undftyp
268 END
269 END GetConstType;
271 PROCEDURE CheckConstType (x: DevCPT.Const; form: INTEGER; errno: SHORTINT);
272 VAR type: DevCPT.Struct;
273 BEGIN
274 GetConstType(x, form, errno, type);
275 IF ~DevCPT.Includes(form, type.form)
276 & ((form # Int8) OR (x.realval # 0) OR (x.intval < -128) OR (x.intval > 127))
277 & ((form # Int16) OR (x.realval # 0) OR (x.intval < -32768) OR (x.intval > 32767))
278 & ((form # Real32) OR (ABS(x.realval) > DevCPM.MaxReal32) & (ABS(x.realval) # DevCPM.InfReal)) THEN
279 err(errno); x.intval := 1; x.realval := 0
280 END
281 (*
282 IF (form IN intSet + charSet) & (x.realval + x.intval >= MIN(INTEGER))
283 & (x.realval + x.intval <= MAX(INTEGER)) THEN
284 x.intval := SHORT(ENTIER(x.realval + x.intval)); x.realval := 0
285 END;
286 IF (form = Int64) & ((x.intval < -MAXL - x.realval) OR (x.intval >= MAXL - x.realval))
287 OR (form = Int32) & (x.realval # 0)
288 OR (form = Int16) & ((x.realval # 0) OR (x.intval < -32768) OR (x.intval > 32767))
289 OR (form = Int8) & ((x.realval # 0) OR (x.intval < -128) OR (x.intval > 127))
290 OR (form = Char16) & ((x.realval # 0) OR (x.intval < 0) OR (x.intval > 65535))
291 OR (form = Char8) & ((x.realval # 0) OR (x.intval < 0) OR (x.intval > 255))
292 OR (form = Real32) & (ABS(x.realval) > DevCPM.MaxReal32) & (ABS(x.realval) # DevCPM.InfReal) THEN
293 err(errno); x.intval := 1; x.realval := 0
294 END
295 *)
296 END CheckConstType;
298 PROCEDURE ConvConst (x: DevCPT.Const; from, to: INTEGER);
299 VAR sr: SHORTREAL;
300 BEGIN
301 IF from = Set THEN
302 x.intval := SetToInt(x.setval); x.realval := 0; x.setval := {};
303 ELSIF from IN intSet + charSet THEN
304 IF to = Set THEN CheckConstType(x, Int32, 203); x.setval := IntToSet(x.intval)
305 ELSIF to IN intSet THEN CheckConstType(x, to, 203)
306 ELSIF to IN realSet THEN x.realval := x.realval + x.intval; x.intval := DevCPM.ConstNotAlloc
307 ELSE (*to IN charSet*) CheckConstType(x, to, 220)
308 END
309 ELSIF from IN realSet THEN
310 IF to IN realSet THEN CheckConstType(x, to, 203);
311 IF to = Real32 THEN sr := SHORT(x.realval); x.realval := sr END (* reduce precision *)
312 ELSE x.realval := Floor(x.realval); x.intval := 0; CheckConstType(x, to, 203)
313 END
314 END
315 END ConvConst;
317 PROCEDURE Prepare (x: DevCPT.Const);
318 VAR r: REAL;
319 BEGIN
320 x.realval := x.realval + x.intval DIV 32768 * 32768;
321 x.intval := x.intval MOD 32768;
322 r := Floor(x.realval / 4096) * 4096;
323 x.intval := x.intval + SHORT(ENTIER(x.realval - r));
324 x.realval := r
325 (* ABS(x.intval) < 2^15 & ABS(x.realval) MOD 2^12 = 0 *)
326 END Prepare;
328 PROCEDURE AddConst (x, y, z: DevCPT.Const; VAR type: DevCPT.Struct); (* z := x + y *)
329 BEGIN
330 IF type.form IN intSet THEN
331 Prepare(x); Prepare(y);
332 z.intval := x.intval + y.intval; z.realval := x.realval + y.realval
333 ELSIF type.form IN realSet THEN
334 IF (ABS(x.realval) = DevCPM.InfReal) & (x.realval = - y.realval) THEN err(212)
335 ELSE z.realval := x.realval + y.realval
336 END
337 ELSE HALT(100)
338 END;
339 GetConstType(z, type.form, 206, type)
340 END AddConst;
342 PROCEDURE NegateConst (y, z: DevCPT.Const; VAR type: DevCPT.Struct); (* z := - y *)
343 BEGIN
344 IF type.form IN intSet THEN Prepare(y); z.intval := -y.intval; z.realval := -y.realval
345 ELSIF type.form IN realSet THEN z.realval := -y.realval
346 ELSE HALT(100)
347 END;
348 GetConstType(z, type.form, 207, type)
349 END NegateConst;
351 PROCEDURE SubConst (x, y, z: DevCPT.Const; VAR type: DevCPT.Struct); (* z := x - y *)
352 BEGIN
353 IF type.form IN intSet THEN
354 Prepare(x); Prepare(y);
355 z.intval := x.intval - y.intval; z.realval := x.realval - y.realval
356 ELSIF type.form IN realSet THEN
357 IF (ABS(x.realval) = DevCPM.InfReal) & (x.realval = y.realval) THEN err(212)
358 ELSE z.realval := x.realval - y.realval
359 END
360 ELSE HALT(100)
361 END;
362 GetConstType(z, type.form, 207, type)
363 END SubConst;
365 PROCEDURE MulConst (x, y, z: DevCPT.Const; VAR type: DevCPT.Struct); (* z := x * y *)
366 BEGIN
367 IF type.form IN intSet THEN
368 Prepare(x); Prepare(y);
369 z.realval := x.realval * y.realval + x.intval * y.realval + x.realval * y.intval;
370 z.intval := x.intval * y.intval
371 ELSIF type.form IN realSet THEN
372 IF (ABS(x.realval) = DevCPM.InfReal) & ( y.realval = 0.0) THEN err(212)
373 ELSIF (ABS(y.realval) = DevCPM.InfReal) & (x.realval = 0.0) THEN err(212)
374 ELSE z.realval := x.realval * y.realval
375 END
376 ELSE HALT(100)
377 END;
378 GetConstType(z, type.form, 204, type)
379 END MulConst;
381 PROCEDURE DivConst (x, y, z: DevCPT.Const; VAR type: DevCPT.Struct); (* z := x / y *)
382 BEGIN
383 IF type.form IN realSet THEN
384 IF (x.realval = 0.0) & (y.realval = 0.0) THEN err(212)
385 ELSIF (ABS(x.realval) = DevCPM.InfReal) & (ABS(y.realval) = DevCPM.InfReal) THEN err(212)
386 ELSE z.realval := x.realval / y.realval
387 END
388 ELSE HALT(100)
389 END;
390 GetConstType(z, type.form, 204, type)
391 END DivConst;
393 PROCEDURE DivModConst (x, y: DevCPT.Const; div: BOOLEAN; VAR type: DevCPT.Struct);
394 (* x := x DIV y | x MOD y *)
395 BEGIN
396 IF type.form IN intSet THEN
397 IF y.realval + y.intval # 0 THEN
398 Prepare(x); Prepare(y);
399 quot.realval := Floor((x.realval + x.intval) / (y.realval + y.intval));
400 quot.intval := 0; Prepare(quot);
401 x.realval := x.realval - quot.realval * y.realval - quot.realval * y.intval - quot.intval * y.realval;
402 x.intval := x.intval - quot.intval * y.intval;
403 IF y.realval + y.intval > 0 THEN
404 WHILE x.realval + x.intval > 0 DO SubConst(x, y, x, type); INC(quot.intval) END;
405 WHILE x.realval + x.intval < 0 DO AddConst(x, y, x, type); DEC(quot.intval) END
406 ELSE
407 WHILE x.realval + x.intval < 0 DO SubConst(x, y, x, type); INC(quot.intval) END;
408 WHILE x.realval + x.intval > 0 DO AddConst(x, y, x, type); DEC(quot.intval) END
409 END;
410 IF div THEN x.realval := quot.realval; x.intval := quot.intval END;
411 GetConstType(x, type.form, 204, type)
412 ELSE err(205)
413 END
414 ELSE HALT(100)
415 END
416 END DivModConst;
418 PROCEDURE EqualConst (x, y: DevCPT.Const; form: INTEGER): BOOLEAN; (* x = y *)
419 VAR res: BOOLEAN;
420 BEGIN
421 CASE form OF
422 | Undef: res := TRUE
423 | Bool, Byte, Char8..Int32, Char16: res := x.intval = y.intval
424 | Int64: Prepare(x); Prepare(y); res := (x.realval - y.realval) + (x.intval - y.intval) = 0
425 | Real32, Real64: res := x.realval = y.realval
426 | Set: res := x.setval = y.setval
427 | String8, String16, Comp (* guid *): res := x.ext^ = y.ext^
428 | NilTyp, Pointer, ProcTyp: res := x.intval = y.intval
429 END;
430 RETURN res
431 END EqualConst;
433 PROCEDURE LessConst (x, y: DevCPT.Const; form: INTEGER): BOOLEAN; (* x < y *)
434 VAR res: BOOLEAN;
435 BEGIN
436 CASE form OF
437 | Undef: res := TRUE
438 | Byte, Char8..Int32, Char16: res := x.intval < y.intval
439 | Int64: Prepare(x); Prepare(y); res := (x.realval - y.realval) + (x.intval - y.intval) < 0
440 | Real32, Real64: res := x.realval < y.realval
441 | String8, String16: res := x.ext^ < y.ext^
442 | Bool, Set, NilTyp, Pointer, ProcTyp, Comp: err(108)
443 END;
444 RETURN res
445 END LessConst;
447 PROCEDURE IsNegConst (x: DevCPT.Const; form: INTEGER): BOOLEAN; (* x < 0 OR x = (-0.0) *)
448 VAR res: BOOLEAN;
449 BEGIN
450 CASE form OF
451 | Int8..Int32: res := x.intval < 0
452 | Int64: Prepare(x); res := x.realval + x.intval < 0
453 | Real32, Real64: res := (x.realval <= 0.) & (1. / x.realval <= 0.)
454 END;
455 RETURN res
456 END IsNegConst;
459 PROCEDURE NewIntConst*(intval: INTEGER): DevCPT.Node;
460 VAR x: DevCPT.Node;
461 BEGIN
462 x := DevCPT.NewNode(Nconst); x.conval := DevCPT.NewConst();
463 x.conval.intval := intval; x.conval.realval := 0; x.typ := DevCPT.int32typ; RETURN x
464 END NewIntConst;
466 PROCEDURE NewLargeIntConst* (intval: INTEGER; realval: REAL): DevCPT.Node;
467 VAR x: DevCPT.Node;
468 BEGIN
469 x := DevCPT.NewNode(Nconst); x.conval := DevCPT.NewConst();
470 x.conval.intval := intval; x.conval.realval := realval; x.typ := DevCPT.int64typ; RETURN x
471 END NewLargeIntConst;
473 PROCEDURE NewRealConst*(realval: REAL; typ: DevCPT.Struct): DevCPT.Node;
474 VAR x: DevCPT.Node;
475 BEGIN
476 x := DevCPT.NewNode(Nconst); x.conval := DevCPT.NewConst();
477 x.conval.realval := realval; x.conval.intval := DevCPM.ConstNotAlloc;
478 IF typ = NIL THEN typ := DevCPT.real64typ END;
479 x.typ := typ;
480 RETURN x
481 END NewRealConst;
483 PROCEDURE NewString*(str: DevCPT.String; lstr: POINTER TO ARRAY OF CHAR; len: INTEGER): DevCPT.Node;
484 VAR i, j, c: INTEGER; x: DevCPT.Node; ext: DevCPT.ConstExt;
485 BEGIN
486 x := DevCPT.NewNode(Nconst); x.conval := DevCPT.NewConst();
487 IF lstr # NIL THEN
488 x.typ := DevCPT.string16typ;
489 NEW(ext, 3 * len); i := 0; j := 0;
490 REPEAT c := ORD(lstr[i]); INC(i); DevCPM.PutUtf8(ext^, c, j) UNTIL c = 0;
491 x.conval.ext := ext
492 ELSE
493 x.typ := DevCPT.string8typ; x.conval.ext := str
494 END;
495 x.conval.intval := DevCPM.ConstNotAlloc; x.conval.intval2 := len;
496 RETURN x
497 END NewString;
499 PROCEDURE CharToString8(n: DevCPT.Node);
500 VAR ch: SHORTCHAR;
501 BEGIN
502 n.typ := DevCPT.string8typ; ch := SHORT(CHR(n.conval.intval)); NEW(n.conval.ext, 2);
503 IF ch = 0X THEN n.conval.intval2 := 1 ELSE n.conval.intval2 := 2; n.conval.ext[1] := 0X END ;
504 n.conval.ext[0] := ch; n.conval.intval := DevCPM.ConstNotAlloc; n.obj := NIL
505 END CharToString8;
507 PROCEDURE CharToString16 (n: DevCPT.Node);
508 VAR ch, ch1: SHORTCHAR; i: INTEGER;
509 BEGIN
510 n.typ := DevCPT.string16typ; NEW(n.conval.ext, 4);
511 IF n.conval.intval = 0 THEN
512 n.conval.ext[0] := 0X; n.conval.intval2 := 1
513 ELSE
514 i := 0; DevCPM.PutUtf8(n.conval.ext^, n.conval.intval, i);
515 n.conval.ext[i] := 0X; n.conval.intval2 := 2
516 END;
517 n.conval.intval := DevCPM.ConstNotAlloc; n.obj := NIL
518 END CharToString16;
520 PROCEDURE String8ToString16 (n: DevCPT.Node);
521 VAR i, j, x: INTEGER; ext, new: DevCPT.ConstExt;
522 BEGIN
523 n.typ := DevCPT.string16typ; ext := n.conval.ext;
524 NEW(new, 2 * n.conval.intval2); i := 0; j := 0;
525 REPEAT x := ORD(ext[i]); INC(i); DevCPM.PutUtf8(new^, x, j) UNTIL x = 0;
526 n.conval.ext := new; n.obj := NIL
527 END String8ToString16;
529 PROCEDURE String16ToString8 (n: DevCPT.Node);
530 VAR i, j, x: INTEGER; ext, new: DevCPT.ConstExt;
531 BEGIN
532 n.typ := DevCPT.string8typ; ext := n.conval.ext;
533 NEW(new, n.conval.intval2); i := 0; j := 0;
534 REPEAT DevCPM.GetUtf8(ext^, x, i); new[j] := SHORT(CHR(x MOD 256)); INC(j) UNTIL x = 0;
535 n.conval.ext := new; n.obj := NIL
536 END String16ToString8;
538 PROCEDURE StringToGuid (VAR n: DevCPT.Node);
539 BEGIN
540 ASSERT((n.class = Nconst) & (n.typ.form = String8));
541 IF ~DevCPM.ValidGuid(n.conval.ext^) THEN err(165) END;
542 n.typ := DevCPT.guidtyp
543 END StringToGuid;
545 PROCEDURE CheckString (n: DevCPT.Node; typ: DevCPT.Struct; e: SHORTINT);
546 VAR ntyp: DevCPT.Struct;
547 BEGIN
548 ntyp := n.typ;
549 IF (typ = DevCPT.guidtyp) & (n.class = Nconst) & (ntyp.form = String8) THEN StringToGuid(n)
550 ELSIF (typ.comp IN {Array, DynArr}) & (typ.BaseTyp.form = Char8) OR (typ.form = String8) THEN
551 IF (n.class = Nconst) & (ntyp.form = Char8) THEN CharToString8(n)
552 ELSIF (ntyp.comp IN {Array, DynArr}) & (ntyp.BaseTyp.form = Char8) OR (ntyp.form = String8) THEN (* ok *)
553 ELSE err(e)
554 END
555 ELSIF (typ.comp IN {Array, DynArr}) & (typ.BaseTyp.form = Char16) OR (typ.form = String16) THEN
556 IF (n.class = Nconst) & (ntyp.form IN charSet) THEN CharToString16(n)
557 ELSIF (n.class = Nconst) & (ntyp.form = String8) THEN String8ToString16(n)
558 ELSIF (ntyp.comp IN {Array, DynArr}) & (ntyp.BaseTyp.form = Char16) OR (ntyp.form = String16) THEN
559 (* ok *)
560 ELSE err(e)
561 END
562 ELSE err(e)
563 END
564 END CheckString;
567 PROCEDURE BindNodes(class: BYTE; typ: DevCPT.Struct; VAR x: DevCPT.Node; y: DevCPT.Node);
568 VAR node: DevCPT.Node;
569 BEGIN
570 node := DevCPT.NewNode(class); node.typ := typ;
571 node.left := x; node.right := y; x := node
572 END BindNodes;
574 PROCEDURE NotVar(x: DevCPT.Node): BOOLEAN;
575 BEGIN
576 RETURN (x.class >= Nconst) & ((x.class # Nmop) OR (x.subcl # val) OR (x.left.class >= Nconst))
577 OR (x.typ.form IN {String8, String16})
578 END NotVar;
581 PROCEDURE Convert(VAR x: DevCPT.Node; typ: DevCPT.Struct);
582 VAR node: DevCPT.Node; f, g: SHORTINT; k: INTEGER; r: REAL;
583 BEGIN f := x.typ.form; g := typ.form;
584 IF x.class = Nconst THEN
585 IF g = String8 THEN
586 IF f = String16 THEN String16ToString8(x)
587 ELSIF f IN charSet THEN CharToString8(x)
588 ELSE typ := DevCPT.undftyp
589 END
590 ELSIF g = String16 THEN
591 IF f = String8 THEN String8ToString16(x)
592 ELSIF f IN charSet THEN CharToString16(x)
593 ELSE typ := DevCPT.undftyp
594 END
595 ELSE ConvConst(x.conval, f, g)
596 END;
597 x.obj := NIL
598 ELSIF (x.class = Nmop) & (x.subcl = conv) & (DevCPT.Includes(f, x.left.typ.form) OR DevCPT.Includes(f, g))
599 THEN
600 (* don't create new node *)
601 IF x.left.typ.form = typ.form THEN (* and suppress existing node *) x := x.left END
602 ELSE
603 IF (x.class = Ndop) & (x.typ.form IN {String8, String16}) THEN (* propagate to leaf nodes *)
604 Convert(x.left, typ); Convert(x.right, typ)
605 ELSE
606 node := DevCPT.NewNode(Nmop); node.subcl := conv; node.left := x; x := node;
607 END
608 END;
609 x.typ := typ
610 END Convert;
612 PROCEDURE Promote (VAR left, right: DevCPT.Node; op: INTEGER); (* check expression compatibility *)
613 VAR f, g: INTEGER; new: DevCPT.Struct;
614 BEGIN
615 f := left.typ.form; g := right.typ.form; new := left.typ;
616 IF f IN intSet + realSet THEN
617 IF g IN intSet + realSet THEN
618 IF (f = Real32) & (right.class = Nconst) & (g IN realSet) & (left.class # Nconst)
619 (* & ((ABS(right.conval.realval) <= DevCPM.MaxReal32)
620 OR (ABS(right.conval.realval) = DevCPM.InfReal)) *)
621 OR (g = Real32) & (left.class = Nconst) & (f IN realSet) & (right.class # Nconst)
622 (* & ((ABS(left.conval.realval) <= DevCPM.MaxReal32)
623 OR (ABS(left.conval.realval) = DevCPM.InfReal)) *) THEN
624 new := DevCPT.real32typ (* SR *)
625 ELSIF (f = Real64) OR (g = Real64) THEN new := DevCPT.real64typ
626 ELSIF (f = Real32) OR (g = Real32) THEN new := DevCPT.real32typ (* SR *)
627 ELSIF op = slash THEN new := DevCPT.real64typ
628 ELSIF (f = Int64) OR (g = Int64) THEN new := DevCPT.int64typ
629 ELSE new := DevCPT.int32typ
630 END
631 ELSE err(100)
632 END
633 ELSIF (left.typ = DevCPT.guidtyp) OR (right.typ = DevCPT.guidtyp) THEN
634 IF f = String8 THEN StringToGuid(left) END;
635 IF g = String8 THEN StringToGuid(right) END;
636 IF left.typ # right.typ THEN err(100) END;
637 f := Comp
638 ELSIF f IN charSet + {String8, String16} THEN
639 IF g IN charSet + {String8, String16} THEN
640 IF (f = String16) OR (g = String16) OR (f = Char16) & (g = String8) OR (f = String8) & (g = Char16) THEN
641 new := DevCPT.string16typ
642 ELSIF (f = Char16) OR (g = Char16) THEN new := DevCPT.char16typ
643 ELSIF (f = String8) OR (g = String8) THEN new := DevCPT.string8typ
644 ELSIF op = plus THEN
645 IF (f = Char16) OR (g = Char16) THEN new := DevCPT.string16typ
646 ELSE new := DevCPT.string8typ
647 END
648 END;
649 IF (new.form IN {String8, String16})
650 & ((f IN charSet) & (left.class # Nconst) OR (g IN charSet) & (right.class # Nconst))
651 THEN
652 err(100)
653 END
654 ELSE err(100)
655 END
656 ELSIF (f IN {NilTyp, Pointer, ProcTyp}) & (g IN {NilTyp, Pointer, ProcTyp}) THEN
657 IF ~DevCPT.SameType(left.typ, right.typ) & (f # NilTyp) & (g # NilTyp)
658 & ~((f = Pointer) & (g = Pointer)
659 & (DevCPT.Extends(left.typ, right.typ) OR DevCPT.Extends(right.typ, left.typ))) THEN err(100) END
660 ELSIF f # g THEN err(100)
661 END;
662 IF ~(f IN {NilTyp, Pointer, ProcTyp, Comp}) THEN
663 IF g # new.form THEN Convert(right, new) END;
664 IF f # new.form THEN Convert(left, new) END
665 END
666 END Promote;
668 PROCEDURE CheckParameters* (fp, ap: DevCPT.Object; checkNames: BOOLEAN); (* checks par list match *)
669 VAR ft, at: DevCPT.Struct;
670 BEGIN
671 WHILE fp # NIL DO
672 IF ap # NIL THEN
673 ft := fp.typ; at := ap.typ;
674 IF fp.ptyp # NIL THEN ft := fp.ptyp END; (* get original formal type *)
675 IF ap.ptyp # NIL THEN at := ap.ptyp END; (* get original formal type *)
676 IF ~DevCPT.EqualType(ft, at)
677 OR (fp.mode # ap.mode) OR (fp.sysflag # ap.sysflag) OR (fp.vis # ap.vis)
678 OR checkNames & (fp.name^ # ap.name^) THEN err(115) END ;
679 ap := ap.link
680 ELSE err(116)
681 END;
682 fp := fp.link
683 END;
684 IF ap # NIL THEN err(116) END
685 END CheckParameters;
687 PROCEDURE CheckNewParamPair* (newPar, iidPar: DevCPT.Node);
688 VAR ityp, ntyp: DevCPT.Struct;
689 BEGIN
690 ntyp := newPar.typ.BaseTyp;
691 IF (newPar.class = Nvarpar) & ODD(newPar.obj.sysflag DIV newBit) THEN
692 IF (iidPar.class = Nvarpar) & ODD(iidPar.obj.sysflag DIV iidBit) & (iidPar.obj.mnolev = newPar.obj.mnolev)
693 THEN (* ok *)
694 ELSE err(168)
695 END
696 ELSIF ntyp.extlev = 0 THEN (* ok *)
697 ELSIF (iidPar.class = Nconst) & (iidPar.obj # NIL) & (iidPar.obj.mode = Typ) THEN
698 IF ~DevCPT.Extends(iidPar.obj.typ, ntyp) THEN err(168) END
699 ELSE err(168)
700 END
701 END CheckNewParamPair;
704 PROCEDURE DeRef*(VAR x: DevCPT.Node);
705 VAR strobj, bstrobj: DevCPT.Object; typ, btyp: DevCPT.Struct;
706 BEGIN
707 typ := x.typ;
708 IF (x.class = Nconst) OR (x.class = Ntype) OR (x.class = Nproc) THEN err(78)
709 ELSIF typ.form = Pointer THEN
710 btyp := typ.BaseTyp; strobj := typ.strobj; bstrobj := btyp.strobj;
711 IF (strobj # NIL) & (strobj.name # DevCPT.null) & (bstrobj # NIL) & (bstrobj.name # DevCPT.null) THEN
712 btyp.pbused := TRUE
713 END ;
714 BindNodes(Nderef, btyp, x, NIL); x.subcl := 0
715 ELSE err(84)
716 END
717 END DeRef;
719 PROCEDURE StrDeref*(VAR x: DevCPT.Node);
720 VAR typ, btyp: DevCPT.Struct;
721 BEGIN
722 typ := x.typ;
723 IF (x.class = Nconst) OR (x.class = Ntype) OR (x.class = Nproc) THEN err(78)
724 ELSIF ((typ.comp IN {Array, DynArr}) & (typ.BaseTyp.form IN charSet)) OR (typ.sysflag = jstr) THEN
725 IF (typ.BaseTyp # NIL) & (typ.BaseTyp.form = Char8) THEN btyp := DevCPT.string8typ
726 ELSE btyp := DevCPT.string16typ
727 END;
728 BindNodes(Nderef, btyp, x, NIL); x.subcl := 1
729 ELSE err(90)
730 END
731 END StrDeref;
733 PROCEDURE Index*(VAR x: DevCPT.Node; y: DevCPT.Node);
734 VAR f: SHORTINT; typ: DevCPT.Struct;
735 BEGIN
736 f := y.typ.form;
737 IF (x.class = Nconst) OR (x.class = Ntype) OR (x.class = Nproc) THEN err(79)
738 ELSIF ~(f IN intSet) OR (y.class IN {Nproc, Ntype}) THEN err(80); y.typ := DevCPT.int32typ END ;
739 IF f = Int64 THEN Convert(y, DevCPT.int32typ) END;
740 IF x.typ.comp = Array THEN typ := x.typ.BaseTyp;
741 IF (y.class = Nconst) & ((y.conval.intval < 0) OR (y.conval.intval >= x.typ.n)) THEN err(81) END
742 ELSIF x.typ.comp = DynArr THEN typ := x.typ.BaseTyp;
743 IF (y.class = Nconst) & (y.conval.intval < 0) THEN err(81) END
744 ELSE err(82); typ := DevCPT.undftyp
745 END ;
746 BindNodes(Nindex, typ, x, y); x.readonly := x.left.readonly
747 END Index;
749 PROCEDURE Field*(VAR x: DevCPT.Node; y: DevCPT.Object);
750 BEGIN (*x.typ.comp = Record*)
751 IF (x.class = Nconst) OR (x.class = Ntype) OR (x.class = Nproc) THEN err(77) END ;
752 IF (y # NIL) & (y.mode IN {Fld, TProc}) THEN
753 BindNodes(Nfield, y.typ, x, NIL); x.obj := y;
754 x.readonly := x.left.readonly OR ((y.vis = externalR) & (y.mnolev < 0))
755 ELSE err(83); x.typ := DevCPT.undftyp
756 END
757 END Field;
759 PROCEDURE TypTest*(VAR x: DevCPT.Node; obj: DevCPT.Object; guard: BOOLEAN);
761 PROCEDURE GTT(t0, t1: DevCPT.Struct);
762 VAR node: DevCPT.Node;
763 BEGIN
764 IF (t0 # NIL) & DevCPT.SameType(t0, t1) & (guard OR (x.class # Nguard)) THEN
765 IF ~guard THEN x := NewBoolConst(TRUE) END
766 ELSIF (t0 = NIL) OR DevCPT.Extends(t1, t0) OR (t0.sysflag = jint) OR (t1.sysflag = jint)
767 OR (t1.comp = DynArr) & (DevCPM.java IN DevCPM.options) THEN
768 IF guard THEN BindNodes(Nguard, NIL, x, NIL); x.readonly := x.left.readonly
769 ELSE node := DevCPT.NewNode(Nmop); node.subcl := is; node.left := x; node.obj := obj; x := node
770 END
771 ELSE err(85)
772 END
773 END GTT;
775 BEGIN
776 IF (x.class = Nconst) OR (x.class = Ntype) OR (x.class = Nproc) THEN err(112)
777 ELSIF x.typ.form = Pointer THEN
778 IF x.typ = DevCPT.sysptrtyp THEN
779 IF obj.typ.form = Pointer THEN GTT(NIL, obj.typ.BaseTyp)
780 ELSE err(86)
781 END
782 ELSIF x.typ.BaseTyp.comp # Record THEN err(85)
783 ELSIF obj.typ.form = Pointer THEN GTT(x.typ.BaseTyp, obj.typ.BaseTyp)
784 ELSE err(86)
785 END
786 ELSIF (x.typ.comp = Record) & (x.class = Nvarpar) & (x.obj.vis # outPar) & (obj.typ.comp = Record) THEN
787 GTT(x.typ, obj.typ)
788 ELSE err(87)
789 END ;
790 IF guard THEN x.typ := obj.typ ELSE x.typ := DevCPT.booltyp END
791 END TypTest;
793 PROCEDURE In*(VAR x: DevCPT.Node; y: DevCPT.Node);
794 VAR f: SHORTINT; k: INTEGER;
795 BEGIN f := x.typ.form;
796 IF (x.class = Ntype) OR (x.class = Nproc) OR (y.class = Ntype) OR (y.class = Nproc) THEN err(126)
797 ELSIF (f IN intSet) & (y.typ.form = Set) THEN
798 IF f = Int64 THEN Convert(x, DevCPT.int32typ) END;
799 IF x.class = Nconst THEN
800 k := x.conval.intval;
801 IF (k < 0) OR (k > DevCPM.MaxSet) THEN err(202)
802 ELSIF y.class = Nconst THEN x.conval.intval := BoolToInt(k IN y.conval.setval); x.obj := NIL
803 ELSE BindNodes(Ndop, DevCPT.booltyp, x, y); x.subcl := in
804 END
805 ELSE BindNodes(Ndop, DevCPT.booltyp, x, y); x.subcl := in
806 END
807 ELSE err(92)
808 END ;
809 x.typ := DevCPT.booltyp
810 END In;
812 PROCEDURE MOp*(op: BYTE; VAR x: DevCPT.Node);
813 VAR f: SHORTINT; typ: DevCPT.Struct; z: DevCPT.Node;
815 PROCEDURE NewOp(op: BYTE; typ: DevCPT.Struct; z: DevCPT.Node): DevCPT.Node;
816 VAR node: DevCPT.Node;
817 BEGIN
818 node := DevCPT.NewNode(Nmop); node.subcl := op; node.typ := typ;
819 node.left := z; RETURN node
820 END NewOp;
822 BEGIN z := x;
823 IF ((z.class = Ntype) OR (z.class = Nproc)) & (op # adr) & (op # typfn) & (op # size) THEN err(126) (* !!! *)
824 ELSE
825 typ := z.typ; f := typ.form;
826 CASE op OF
827 | not:
828 IF f = Bool THEN
829 IF z.class = Nconst THEN
830 z.conval.intval := BoolToInt(~IntToBool(z.conval.intval)); z.obj := NIL
831 ELSE z := NewOp(op, typ, z)
832 END
833 ELSE err(98)
834 END
835 | plus:
836 IF ~(f IN intSet + realSet) THEN err(96) END
837 | minus:
838 IF f IN intSet + realSet + {Set} THEN
839 IF z.class = Nconst THEN
840 IF f = Set THEN z.conval.setval := -z.conval.setval
841 ELSE NegateConst(z.conval, z.conval, z.typ)
842 END;
843 z.obj := NIL
844 ELSE
845 IF f < Int32 THEN Convert(z, DevCPT.int32typ) END;
846 z := NewOp(op, z.typ, z)
847 END
848 ELSE err(97)
849 END
850 | abs:
851 IF f IN intSet + realSet THEN
852 IF z.class = Nconst THEN
853 IF IsNegConst(z.conval, f) THEN NegateConst(z.conval, z.conval, z.typ) END;
854 z.obj := NIL
855 ELSE
856 IF f < Int32 THEN Convert(z, DevCPT.int32typ) END;
857 z := NewOp(op, z.typ, z)
858 END
859 ELSE err(111)
860 END
861 | cap:
862 IF f IN charSet THEN
863 IF z.class = Nconst THEN
864 IF ODD(z.conval.intval DIV 32) THEN DEC(z.conval.intval, 32) END;
865 z.obj := NIL
866 ELSE z := NewOp(op, typ, z)
867 END
868 ELSE err(111); z.typ := DevCPT.char8typ
869 END
870 | odd:
871 IF f IN intSet THEN
872 IF z.class = Nconst THEN
873 DivModConst(z.conval, two, FALSE, z.typ); (* z MOD 2 *)
874 z.obj := NIL
875 ELSE z := NewOp(op, typ, z)
876 END
877 ELSE err(111)
878 END ;
879 z.typ := DevCPT.booltyp
880 | adr: (*ADR*)
881 IF z.class = Nproc THEN
882 IF z.obj.mnolev > 0 THEN err(73)
883 ELSIF z.obj.mode = LProc THEN z.obj.mode := XProc
884 END;
885 z := NewOp(op, typ, z)
886 ELSIF z.class = Ntype THEN
887 IF z.obj.typ.untagged THEN err(111) END;
888 z := NewOp(op, typ, z)
889 ELSIF (z.class < Nconst) OR (z.class = Nconst) & (f IN {String8, String16}) THEN
890 z := NewOp(op, typ, z)
891 ELSE err(127)
892 END ;
893 z.typ := DevCPT.int32typ
894 | typfn, size: (*TYP, SIZE*)
895 z := NewOp(op, typ, z);
896 z.typ := DevCPT.int32typ
897 | cc: (*SYSTEM.CC*)
898 IF (f IN intSet) & (z.class = Nconst) THEN
899 IF (0 <= z.conval.intval) & (z.conval.intval <= DevCPM.MaxCC) & (z.conval.realval = 0) THEN
900 z := NewOp(op, typ, z)
901 ELSE err(219)
902 END
903 ELSE err(69)
904 END;
905 z.typ := DevCPT.booltyp
906 END
907 END;
908 x := z
909 END MOp;
911 PROCEDURE ConstOp(op: SHORTINT; x, y: DevCPT.Node);
912 VAR f: SHORTINT; i, j: INTEGER; xval, yval: DevCPT.Const; ext: DevCPT.ConstExt; t: DevCPT.Struct;
913 BEGIN
914 f := x.typ.form;
915 IF f = y.typ.form THEN
916 xval := x.conval; yval := y.conval;
917 CASE op OF
918 | times:
919 IF f IN intSet + realSet THEN MulConst(xval, yval, xval, x.typ)
920 ELSIF f = Set THEN xval.setval := xval.setval * yval.setval
921 ELSIF f # Undef THEN err(101)
922 END
923 | slash:
924 IF f IN realSet THEN DivConst(xval, yval, xval, x.typ)
925 ELSIF f = Set THEN xval.setval := xval.setval / yval.setval
926 ELSIF f # Undef THEN err(102)
927 END
928 | div:
929 IF f IN intSet THEN DivModConst(xval, yval, TRUE, x.typ)
930 ELSIF f # Undef THEN err(103)
931 END
932 | mod:
933 IF f IN intSet THEN DivModConst(xval, yval, FALSE, x.typ)
934 ELSIF f # Undef THEN err(104)
935 END
936 | and:
937 IF f = Bool THEN xval.intval := BoolToInt(IntToBool(xval.intval) & IntToBool(yval.intval))
938 ELSE err(94)
939 END
940 | plus:
941 IF f IN intSet + realSet THEN AddConst(xval, yval, xval, x.typ)
942 ELSIF f = Set THEN xval.setval := xval.setval + yval.setval
943 ELSIF (f IN {String8, String16}) & (xval.ext # NIL) & (yval.ext # NIL) THEN
944 NEW(ext, LEN(xval.ext^) + LEN(yval.ext^));
945 i := 0; WHILE xval.ext[i] # 0X DO ext[i] := xval.ext[i]; INC(i) END;
946 j := 0; WHILE yval.ext[j] # 0X DO ext[i] := yval.ext[j]; INC(i); INC(j) END;
947 ext[i] := 0X; xval.ext := ext; INC(xval.intval2, yval.intval2 - 1)
948 ELSIF f # Undef THEN err(105)
949 END
950 | minus:
951 IF f IN intSet + realSet THEN SubConst(xval, yval, xval, x.typ)
952 ELSIF f = Set THEN xval.setval := xval.setval - yval.setval
953 ELSIF f # Undef THEN err(106)
954 END
955 | min:
956 IF f IN intSet + realSet THEN
957 IF LessConst(yval, xval, f) THEN xval^ := yval^ END
958 ELSIF f # Undef THEN err(111)
959 END
960 | max:
961 IF f IN intSet + realSet THEN
962 IF LessConst(xval, yval, f) THEN xval^ := yval^ END
963 ELSIF f # Undef THEN err(111)
964 END
965 | or:
966 IF f = Bool THEN xval.intval := BoolToInt(IntToBool(xval.intval) OR IntToBool(yval.intval))
967 ELSE err(95)
968 END
969 | eql: xval.intval := BoolToInt(EqualConst(xval, yval, f)); x.typ := DevCPT.booltyp
970 | neq: xval.intval := BoolToInt(~EqualConst(xval, yval, f)); x.typ := DevCPT.booltyp
971 | lss: xval.intval := BoolToInt(LessConst(xval, yval, f)); x.typ := DevCPT.booltyp
972 | leq: xval.intval := BoolToInt(~LessConst(yval, xval, f)); x.typ := DevCPT.booltyp
973 | gtr: xval.intval := BoolToInt(LessConst(yval, xval, f)); x.typ := DevCPT.booltyp
974 | geq: xval.intval := BoolToInt(~LessConst(xval, yval, f)); x.typ := DevCPT.booltyp
975 END
976 ELSE err(100)
977 END;
978 x.obj := NIL
979 END ConstOp;
981 PROCEDURE Op*(op: BYTE; VAR x: DevCPT.Node; y: DevCPT.Node);
982 VAR f, g: SHORTINT; t, z: DevCPT.Node; typ: DevCPT.Struct; do: BOOLEAN; val: INTEGER;
984 PROCEDURE NewOp(op: BYTE; typ: DevCPT.Struct; VAR x: DevCPT.Node; y: DevCPT.Node);
985 VAR node: DevCPT.Node;
986 BEGIN
987 node := DevCPT.NewNode(Ndop); node.subcl := op; node.typ := typ;
988 node.left := x; node.right := y; x := node
989 END NewOp;
991 BEGIN z := x;
992 IF (z.class = Ntype) OR (z.class = Nproc) OR (y.class = Ntype) OR (y.class = Nproc) THEN err(126)
993 ELSE
994 Promote(z, y, op);
995 IF (z.class = Nconst) & (y.class = Nconst) THEN ConstOp(op, z, y)
996 ELSE
997 typ := z.typ; f := typ.form; g := y.typ.form;
998 CASE op OF
999 | times:
1000 do := TRUE;
1001 IF f IN intSet THEN
1002 IF z.class = Nconst THEN
1003 IF EqualConst(z.conval, one, f) THEN do := FALSE; z := y
1004 ELSIF EqualConst(z.conval, zero, f) THEN do := FALSE
1005 ELSE val := Log(z);
1006 IF val >= 0 THEN
1007 t := y; y := z; z := t;
1008 op := ash; y.typ := DevCPT.int32typ; y.conval.intval := val; y.obj := NIL
1009 END
1010 END
1011 ELSIF y.class = Nconst THEN
1012 IF EqualConst(y.conval, one, f) THEN do := FALSE
1013 ELSIF EqualConst(y.conval, zero, f) THEN do := FALSE; z := y
1014 ELSE val := Log(y);
1015 IF val >= 0 THEN
1016 op := ash; y.typ := DevCPT.int32typ; y.conval.intval := val; y.obj := NIL
1017 END
1018 END
1019 END
1020 ELSIF ~(f IN {Undef, Real32..Set}) THEN err(105); typ := DevCPT.undftyp
1021 END ;
1022 IF do THEN NewOp(op, typ, z, y) END;
1023 | slash:
1024 IF f IN realSet THEN (* OK *)
1025 ELSIF (f # Set) & (f # Undef) THEN err(102); typ := DevCPT.undftyp
1026 END ;
1027 NewOp(op, typ, z, y)
1028 | div:
1029 do := TRUE;
1030 IF f IN intSet THEN
1031 IF y.class = Nconst THEN
1032 IF EqualConst(y.conval, zero, f) THEN err(205)
1033 ELSIF EqualConst(y.conval, one, f) THEN do := FALSE
1034 ELSE val := Log(y);
1035 IF val >= 0 THEN
1036 op := ash; y.typ := DevCPT.int32typ; y.conval.intval := -val; y.obj := NIL
1037 END
1038 END
1039 END
1040 ELSIF f # Undef THEN err(103); typ := DevCPT.undftyp
1041 END ;
1042 IF do THEN NewOp(op, typ, z, y) END;
1043 | mod:
1044 IF f IN intSet THEN
1045 IF y.class = Nconst THEN
1046 IF EqualConst(y.conval, zero, f) THEN err(205)
1047 ELSE val := Log(y);
1048 IF val >= 0 THEN
1049 op := msk; y.conval.intval := ASH(-1, val); y.obj := NIL
1050 END
1051 END
1052 END
1053 ELSIF f # Undef THEN err(104); typ := DevCPT.undftyp
1054 END ;
1055 NewOp(op, typ, z, y);
1056 | and:
1057 IF f = Bool THEN
1058 IF z.class = Nconst THEN
1059 IF IntToBool(z.conval.intval) THEN z := y END
1060 ELSIF (y.class = Nconst) & IntToBool(y.conval.intval) THEN (* optimize z & TRUE -> z *)
1061 ELSE NewOp(op, typ, z, y)
1062 END
1063 ELSIF f # Undef THEN err(94); z.typ := DevCPT.undftyp
1064 END
1065 | plus:
1066 IF ~(f IN {Undef, Int8..Set, Int64, String8, String16}) THEN err(105); typ := DevCPT.undftyp END;
1067 do := TRUE;
1068 IF f IN intSet THEN
1069 IF (z.class = Nconst) & EqualConst(z.conval, zero, f) THEN do := FALSE; z := y END ;
1070 IF (y.class = Nconst) & EqualConst(y.conval, zero, f) THEN do := FALSE END
1071 ELSIF f IN {String8, String16} THEN
1072 IF (z.class = Nconst) & (z.conval.intval2 = 1) THEN do := FALSE; z := y END ;
1073 IF (y.class = Nconst) & (y.conval.intval2 = 1) THEN do := FALSE END;
1074 IF do THEN
1075 IF z.class = Ndop THEN
1076 t := z; WHILE t.right.class = Ndop DO t := t.right END;
1077 IF (t.right.class = Nconst) & (y.class = Nconst) THEN
1078 ConstOp(op, t.right, y); do := FALSE
1079 ELSIF (t.right.class = Nconst) & (y.class = Ndop) & (y.left.class = Nconst) THEN
1080 ConstOp(op, t.right, y.left); y.left := t.right; t.right := y; do := FALSE
1081 ELSE
1082 NewOp(op, typ, t.right, y); do := FALSE
1083 END
1084 ELSE
1085 IF (z.class = Nconst) & (y.class = Ndop) & (y.left.class = Nconst) THEN
1086 ConstOp(op, z, y.left); y.left := z; z := y; do := FALSE
1087 END
1088 END
1089 END
1090 END ;
1091 IF do THEN NewOp(op, typ, z, y) END;
1092 | minus:
1093 IF ~(f IN {Undef, Int8..Set, Int64}) THEN err(106); typ := DevCPT.undftyp END;
1094 IF ~(f IN intSet) OR (y.class # Nconst) OR ~EqualConst(y.conval, zero, f) THEN NewOp(op, typ, z, y)
1095 END;
1096 | min, max:
1097 IF ~(f IN {Undef} + intSet + realSet + charSet) THEN err(111); typ := DevCPT.undftyp END;
1098 NewOp(op, typ, z, y);
1099 | or:
1100 IF f = Bool THEN
1101 IF z.class = Nconst THEN
1102 IF ~IntToBool(z.conval.intval) THEN z := y END
1103 ELSIF (y.class = Nconst) & ~IntToBool(y.conval.intval) THEN (* optimize z OR FALSE -> z *)
1104 ELSE NewOp(op, typ, z, y)
1105 END
1106 ELSIF f # Undef THEN err(95); z.typ := DevCPT.undftyp
1107 END
1108 | eql, neq, lss, leq, gtr, geq:
1109 IF f IN {String8, String16} THEN
1110 IF (f = String16) & (z.class = Nmop) & (z.subcl = conv) & (y.class = Nmop) & (y.subcl = conv) THEN
1111 z := z.left; y := y.left (* remove LONG on both sides *)
1112 ELSIF (z.class = Nconst) & (z.conval.intval2 = 1) & (y.class = Nderef) THEN (* y$ = "" -> y[0] = 0X *)
1113 y := y.left; Index(y, NewIntConst(0)); z.typ := y.typ; z.conval.intval := 0
1114 ELSIF (y.class = Nconst) & (y.conval.intval2 = 1) & (z.class = Nderef) THEN (* z$ = "" -> z[0] = 0X *)
1115 z := z.left; Index(z, NewIntConst(0)); y.typ := z.typ; y.conval.intval := 0
1116 END;
1117 typ := DevCPT.booltyp
1118 ELSIF (f IN {Undef, Char8..Real64, Char16, Int64})
1119 OR (op <= neq) & ((f IN {Bool, Set, NilTyp, Pointer, ProcTyp}) OR (typ = DevCPT.guidtyp)) THEN
1120 typ := DevCPT.booltyp
1121 ELSE err(107); typ := DevCPT.undftyp
1122 END;
1123 NewOp(op, typ, z, y)
1124 END
1125 END
1126 END;
1127 x := z
1128 END Op;
1130 PROCEDURE SetRange*(VAR x: DevCPT.Node; y: DevCPT.Node);
1131 VAR k, l: INTEGER;
1132 BEGIN
1133 IF (x.class = Ntype) OR (x.class = Nproc) OR (y.class = Ntype) OR (y.class = Nproc) THEN err(126)
1134 ELSIF (x.typ.form IN intSet) & (y.typ.form IN intSet) THEN
1135 IF x.typ.form = Int64 THEN Convert(x, DevCPT.int32typ) END;
1136 IF y.typ.form = Int64 THEN Convert(y, DevCPT.int32typ) END;
1137 IF x.class = Nconst THEN
1138 k := x.conval.intval;
1139 IF (0 > k) OR (k > DevCPM.MaxSet) OR (x.conval.realval # 0) THEN err(202) END
1140 END ;
1141 IF y.class = Nconst THEN
1142 l := y.conval.intval;
1143 IF (0 > l) OR (l > DevCPM.MaxSet) OR (y.conval.realval # 0) THEN err(202) END
1144 END ;
1145 IF (x.class = Nconst) & (y.class = Nconst) THEN
1146 IF k <= l THEN
1147 x.conval.setval := {k..l}
1148 ELSE err(201); x.conval.setval := {l..k}
1149 END ;
1150 x.obj := NIL
1151 ELSE BindNodes(Nupto, DevCPT.settyp, x, y)
1152 END
1153 ELSE err(93)
1154 END ;
1155 x.typ := DevCPT.settyp
1156 END SetRange;
1158 PROCEDURE SetElem*(VAR x: DevCPT.Node);
1159 VAR k: INTEGER;
1160 BEGIN
1161 IF (x.class = Ntype) OR (x.class = Nproc) THEN err(126) END;
1162 IF x.typ.form IN intSet THEN
1163 IF x.typ.form = Int64 THEN Convert(x, DevCPT.int32typ) END;
1164 IF x.class = Nconst THEN
1165 k := x.conval.intval;
1166 IF (0 <= k) & (k <= DevCPM.MaxSet) & (x.conval.realval = 0) THEN x.conval.setval := {k}
1167 ELSE err(202)
1168 END ;
1169 x.obj := NIL
1170 ELSE BindNodes(Nmop, DevCPT.settyp, x, NIL); x.subcl := bit
1171 END ;
1172 ELSE err(93)
1173 END;
1174 x.typ := DevCPT.settyp
1175 END SetElem;
1177 PROCEDURE CheckAssign* (x: DevCPT.Struct; VAR ynode: DevCPT.Node);
1178 (* x := y, checks assignment compatibility *)
1179 VAR f, g: SHORTINT; y, b: DevCPT.Struct;
1180 BEGIN
1181 y := ynode.typ; f := x.form; g := y.form;
1182 IF (ynode.class = Ntype) OR (ynode.class = Nproc) & (f # ProcTyp) THEN err(126) END ;
1183 CASE f OF
1184 | Undef, String8, String16, Byte:
1185 | Bool, Set:
1186 IF g # f THEN err(113) END
1187 | Int8, Int16, Int32, Int64, Real32, Real64: (* SR *)
1188 IF (g IN intSet) OR (g IN realSet) & (f IN realSet) THEN
1189 IF ynode.class = Nconst THEN Convert(ynode, x)
1190 ELSIF ~DevCPT.Includes(f, g) THEN err(113)
1191 END
1192 ELSE err(113)
1193 END
1194 (*
1195 IF ~(g IN intSet + realSet) OR ~DevCPT.Includes(f, g) & (~(g IN intSet) OR (ynode.class # Nconst)) THEN
1196 err(113)
1197 ELSIF ynode.class = Nconst THEN Convert(ynode, x)
1198 END
1199 *)
1200 | Char8, Char16:
1201 IF ~(g IN charSet) OR ~DevCPT.Includes(f, g) THEN err(113)
1202 ELSIF ynode.class = Nconst THEN Convert(ynode, x)
1203 END
1204 | Pointer:
1205 b := x.BaseTyp;
1206 IF DevCPT.Extends(y, x)
1207 OR (g = NilTyp)
1208 OR (g = Pointer)
1209 & ((x = DevCPT.sysptrtyp) OR (DevCPM.java IN DevCPM.options) & (x = DevCPT.anyptrtyp))
1210 THEN (* ok *)
1211 ELSIF (b.comp = DynArr) & b.untagged THEN (* pointer to untagged open array *)
1212 IF ynode.class = Nconst THEN CheckString(ynode, b, 113)
1213 ELSIF ~(y.comp IN {Array, DynArr}) OR ~DevCPT.EqualType(b.BaseTyp, y.BaseTyp) THEN err(113)
1214 END
1215 ELSIF b.untagged & (ynode.class = Nmop) & (ynode.subcl = adr) THEN (* p := ADR(r) *)
1216 IF (b.comp = DynArr) & (ynode.left.class = Nconst) THEN CheckString(ynode.left, b, 113)
1217 ELSIF ~DevCPT.Extends(ynode.left.typ, b) THEN err(113)
1218 END
1219 ELSIF (b.sysflag = jstr) & ((g = String16) OR (ynode.class = Nconst) & (g IN {Char8, Char16, String8}))
1220 THEN
1221 IF g # String16 THEN Convert(ynode, DevCPT.string16typ) END
1222 ELSE err(113)
1223 END
1224 | ProcTyp:
1225 IF DevCPT.EqualType(x, y) OR (g = NilTyp) THEN (* ok *)
1226 ELSIF (ynode.class = Nproc) & (ynode.obj.mode IN {XProc, IProc, LProc}) THEN
1227 IF ynode.obj.mode = LProc THEN
1228 IF ynode.obj.mnolev = 0 THEN ynode.obj.mode := XProc ELSE err(73) END
1229 END;
1230 IF (x.sysflag = 0) & (ynode.obj.sysflag >= 0) OR (x.sysflag = ynode.obj.sysflag) THEN
1231 IF DevCPT.EqualType(x.BaseTyp, ynode.obj.typ) THEN CheckParameters(x.link, ynode.obj.link, FALSE)
1232 ELSE err(117)
1233 END
1234 ELSE err(113)
1235 END
1236 ELSE err(113)
1237 END
1238 | NoTyp, NilTyp: err(113)
1239 | Comp:
1240 x.pvused := TRUE; (* idfp of y guarantees assignment compatibility with x *)
1241 IF x.comp = Record THEN
1242 IF ~DevCPT.EqualType(x, y) OR (x.attribute # 0) THEN err(113) END
1243 ELSIF g IN {Char8, Char16, String8, String16} THEN
1244 IF (x.BaseTyp.form = Char16) & (g = String8) THEN Convert(ynode, DevCPT.string16typ)
1245 ELSE CheckString(ynode, x, 113);
1246 END;
1247 IF (x # DevCPT.guidtyp) & (x.comp = Array) & (ynode.class = Nconst) & (ynode.conval.intval2 > x.n) THEN
1248 err(114)
1249 END
1250 ELSIF (x.comp = Array) & DevCPT.EqualType(x, y) THEN (* ok *)
1251 ELSE err(113)
1252 END
1253 END
1254 END CheckAssign;
1256 PROCEDURE AssignString (VAR x: DevCPT.Node; str: DevCPT.Node); (* x := str or x[0] := 0X *)
1257 BEGIN
1258 ASSERT((str.class = Nconst) & (str.typ.form IN {String8, String16}));
1259 IF (x.typ.comp IN {Array, DynArr}) & (str.conval.intval2 = 1) THEN (* x := "" -> x[0] := 0X *)
1260 Index(x, NewIntConst(0));
1261 str.typ := x.typ; str.conval.intval := 0;
1262 END;
1263 BindNodes(Nassign, DevCPT.notyp, x, str); x.subcl := assign
1264 END AssignString;
1266 PROCEDURE CheckLeaf(x: DevCPT.Node; dynArrToo: BOOLEAN);
1267 BEGIN
1268 IF (x.class = Nmop) & (x.subcl = val) THEN x := x.left END ;
1269 IF x.class = Nguard THEN x := x.left END ; (* skip last (and unique) guard *)
1270 IF (x.class = Nvar) & (dynArrToo OR (x.typ.comp # DynArr)) THEN x.obj.leaf := FALSE END
1271 END CheckLeaf;
1273 PROCEDURE CheckOldType (x: DevCPT.Node);
1274 BEGIN
1275 IF ~(DevCPM.oberon IN DevCPM.options)
1276 & ((x.typ = DevCPT.lreal64typ) OR (x.typ = DevCPT.lint64typ) OR (x.typ = DevCPT.lchar16typ)) THEN
1277 err(198)
1278 END
1279 END CheckOldType;
1281 PROCEDURE StPar0*(VAR par0: DevCPT.Node; fctno: SHORTINT); (* par0: first param of standard proc *)
1282 VAR f: SHORTINT; typ: DevCPT.Struct; x, t: DevCPT.Node;
1283 BEGIN x := par0; f := x.typ.form;
1284 CASE fctno OF
1285 haltfn: (*HALT*)
1286 IF (f IN intSet - {Int64}) & (x.class = Nconst) THEN
1287 IF (DevCPM.MinHaltNr <= x.conval.intval) & (x.conval.intval <= DevCPM.MaxHaltNr) THEN
1288 BindNodes(Ntrap, DevCPT.notyp, x, x)
1289 ELSE err(218)
1290 END
1291 ELSIF (DevCPM.java IN DevCPM.options)
1292 & ((x.class = Ntype) OR (x.class = Nvar))
1293 & (x.typ.form = Pointer)
1294 THEN
1295 BindNodes(Ntrap, DevCPT.notyp, x, x)
1296 ELSE err(69)
1297 END ;
1298 x.typ := DevCPT.notyp
1299 | newfn: (*NEW*)
1300 typ := DevCPT.notyp;
1301 IF NotVar(x) THEN err(112)
1302 ELSIF f = Pointer THEN
1303 IF DevCPM.NEWusingAdr THEN CheckLeaf(x, TRUE) END ;
1304 IF x.readonly THEN err(76)
1305 ELSIF (x.typ.BaseTyp.attribute = absAttr)
1306 OR (x.typ.BaseTyp.attribute = limAttr) & (x.typ.BaseTyp.mno # 0) THEN err(193)
1307 ELSIF (x.obj # NIL) & ODD(x.obj.sysflag DIV newBit) THEN err(167)
1308 END ;
1309 MarkAsUsed(x);
1310 f := x.typ.BaseTyp.comp;
1311 IF f IN {Record, DynArr, Array} THEN
1312 IF f = DynArr THEN typ := x.typ.BaseTyp END ;
1313 BindNodes(Nassign, DevCPT.notyp, x, NIL); x.subcl := newfn
1314 ELSE err(111)
1315 END
1316 ELSE err(111)
1317 END ;
1318 x.typ := typ
1319 | absfn: (*ABS*)
1320 MOp(abs, x)
1321 | capfn: (*CAP*)
1322 MOp(cap, x)
1323 | ordfn: (*ORD*)
1324 IF (x.class = Ntype) OR (x.class = Nproc) THEN err(126)
1325 ELSIF f = Char8 THEN Convert(x, DevCPT.int16typ)
1326 ELSIF f = Char16 THEN Convert(x, DevCPT.int32typ)
1327 ELSIF f = Set THEN Convert(x, DevCPT.int32typ)
1328 ELSE err(111)
1329 END
1330 | bitsfn: (*BITS*)
1331 IF (x.class = Ntype) OR (x.class = Nproc) THEN err(126)
1332 ELSIF f IN {Int8, Int16, Int32} THEN Convert(x, DevCPT.settyp)
1333 ELSE err(111)
1334 END
1335 | entierfn: (*ENTIER*)
1336 IF (x.class = Ntype) OR (x.class = Nproc) THEN err(126)
1337 ELSIF f IN realSet THEN Convert(x, DevCPT.int64typ)
1338 ELSE err(111)
1339 END ;
1340 x.typ := DevCPT.int64typ
1341 | lentierfcn: (* LENTIER *)
1342 IF ~(DevCPM.oberon IN DevCPM.options) THEN err(199) END;
1343 IF (x.class = Ntype) OR (x.class = Nproc) THEN err(126)
1344 ELSIF f IN realSet THEN Convert(x, DevCPT.int64typ)
1345 ELSE err(111)
1346 END ;
1347 x.typ := DevCPT.int64typ
1348 | oddfn: (*ODD*)
1349 MOp(odd, x)
1350 | minfn: (*MIN*)
1351 IF x.class = Ntype THEN
1352 CheckOldType(x);
1353 CASE f OF
1354 Bool: x := NewBoolConst(FALSE)
1355 | Char8: x := NewIntConst(0); x.typ := DevCPT.char8typ
1356 | Char16: x := NewIntConst(0); x.typ := DevCPT.char8typ
1357 | Int8: x := NewIntConst(-128)
1358 | Int16: x := NewIntConst(-32768)
1359 | Int32: x := NewIntConst(-2147483648)
1360 | Int64: x := NewLargeIntConst(0, -9223372036854775808.0E0) (* -2^63 *)
1361 | Set: x := NewIntConst(0) (*; x.typ := DevCPT.int16typ *)
1362 | Real32: x := NewRealConst(DevCPM.MinReal32, DevCPT.real64typ)
1363 | Real64: x := NewRealConst(DevCPM.MinReal64, DevCPT.real64typ)
1364 ELSE err(111)
1365 END;
1366 x.hint := 1
1367 ELSIF ~(f IN intSet + realSet + charSet) THEN err(111)
1368 END
1369 | maxfn: (*MAX*)
1370 IF x.class = Ntype THEN
1371 CheckOldType(x);
1372 CASE f OF
1373 Bool: x := NewBoolConst(TRUE)
1374 | Char8: x := NewIntConst(0FFH); x.typ := DevCPT.char8typ
1375 | Char16: x := NewIntConst(0FFFFH); x.typ := DevCPT.char16typ
1376 | Int8: x := NewIntConst(127)
1377 | Int16: x := NewIntConst(32767)
1378 | Int32: x := NewIntConst(2147483647)
1379 | Int64: x := NewLargeIntConst(-1, 9223372036854775808.0E0) (* 2^63 - 1 *)
1380 | Set: x := NewIntConst(31) (*; x.typ := DevCPT.int16typ *)
1381 | Real32: x := NewRealConst(DevCPM.MaxReal32, DevCPT.real64typ)
1382 | Real64: x := NewRealConst(DevCPM.MaxReal64, DevCPT.real64typ)
1383 ELSE err(111)
1384 END;
1385 x.hint := 1
1386 ELSIF ~(f IN intSet + realSet + charSet) THEN err(111)
1387 END
1388 | chrfn: (*CHR*)
1389 IF (x.class = Ntype) OR (x.class = Nproc) THEN err(126)
1390 ELSIF f IN {Undef, Int8..Int32, Int64} THEN Convert(x, DevCPT.char16typ)
1391 ELSE err(111); x.typ := DevCPT.char16typ
1392 END
1393 | lchrfn: (* LCHR *)
1394 IF ~(DevCPM.oberon IN DevCPM.options) THEN err(199) END;
1395 IF (x.class = Ntype) OR (x.class = Nproc) THEN err(126)
1396 ELSIF f IN {Undef, Int8..Int32, Int64} THEN Convert(x, DevCPT.char16typ)
1397 ELSE err(111); x.typ := DevCPT.char16typ
1398 END
1399 | shortfn: (*SHORT*)
1400 IF (x.class = Ntype) OR (x.class = Nproc) THEN err(126)
1401 ELSE
1402 IF (x.typ.comp IN {Array, DynArr}) & (x.typ.BaseTyp.form IN charSet) THEN StrDeref(x); f := x.typ.form
1403 END;
1404 IF f = Int16 THEN Convert(x, DevCPT.int8typ)
1405 ELSIF f = Int32 THEN Convert(x, DevCPT.int16typ)
1406 ELSIF f = Int64 THEN Convert(x, DevCPT.int32typ)
1407 ELSIF f = Real64 THEN Convert(x, DevCPT.real32typ)
1408 ELSIF f = Char16 THEN Convert(x, DevCPT.char8typ)
1409 ELSIF f = String16 THEN Convert(x, DevCPT.string8typ)
1410 ELSE err(111)
1411 END
1412 END
1413 | longfn: (*LONG*)
1414 IF (x.class = Ntype) OR (x.class = Nproc) THEN err(126)
1415 ELSE
1416 IF (x.typ.comp IN {Array, DynArr}) & (x.typ.BaseTyp.form IN charSet) THEN StrDeref(x); f := x.typ.form
1417 END;
1418 IF f = Int8 THEN Convert(x, DevCPT.int16typ)
1419 ELSIF f = Int16 THEN Convert(x, DevCPT.int32typ)
1420 ELSIF f = Int32 THEN Convert(x, DevCPT.int64typ)
1421 ELSIF f = Real32 THEN Convert(x, DevCPT.real64typ)
1422 ELSIF f = Char8 THEN Convert(x, DevCPT.char16typ)
1423 ELSIF f = String8 THEN Convert(x, DevCPT.string16typ)
1424 ELSE err(111)
1425 END
1426 END
1427 | incfn, decfn: (*INC, DEC*)
1428 IF NotVar(x) THEN err(112)
1429 ELSIF ~(f IN intSet) THEN err(111)
1430 ELSIF x.readonly THEN err(76)
1431 END;
1432 MarkAsUsed(x)
1433 | inclfn, exclfn: (*INCL, EXCL*)
1434 IF NotVar(x) THEN err(112)
1435 ELSIF f # Set THEN err(111); x.typ := DevCPT.settyp
1436 ELSIF x.readonly THEN err(76)
1437 END;
1438 MarkAsUsed(x)
1439 | lenfn: (*LEN*)
1440 IF (* (x.class = Ntype) OR *) (x.class = Nproc) THEN err(126) (* !!! *)
1441 (* ELSIF x.typ.sysflag = jstr THEN StrDeref(x) *)
1442 ELSE
1443 IF x.typ.form = Pointer THEN DeRef(x) END;
1444 IF x.class = Nconst THEN
1445 IF x.typ.form = Char8 THEN CharToString8(x)
1446 ELSIF x.typ.form = Char16 THEN CharToString16(x)
1447 END
1448 END;
1449 IF ~(x.typ.comp IN {DynArr, Array}) & ~(x.typ.form IN {String8, String16}) THEN err(131) END
1450 END
1451 | copyfn: (*COPY*)
1452 IF ~(DevCPM.oberon IN DevCPM.options) THEN err(199) END;
1453 IF (x.class = Ntype) OR (x.class = Nproc) THEN err(126) END
1454 | ashfn: (*ASH*)
1455 IF (x.class = Ntype) OR (x.class = Nproc) THEN err(126)
1456 ELSIF f IN intSet THEN
1457 IF f < Int32 THEN Convert(x, DevCPT.int32typ) END
1458 ELSE err(111); x.typ := DevCPT.int32typ
1459 END
1460 | adrfn: (*ADR*)
1461 IF x.class = Ntype THEN CheckOldType(x) END;
1462 CheckLeaf(x, FALSE); MOp(adr, x)
1463 | typfn: (*TYP*)
1464 CheckLeaf(x, FALSE);
1465 IF x.class = Ntype THEN
1466 CheckOldType(x);
1467 IF x.typ.form = Pointer THEN x := NewLeaf(x.typ.BaseTyp.strobj) END;
1468 IF x.typ.comp # Record THEN err(111) END;
1469 MOp(adr, x)
1470 ELSE
1471 IF x.typ.form = Pointer THEN DeRef(x) END;
1472 IF x.typ.comp # Record THEN err(111) END;
1473 MOp(typfn, x)
1474 END
1475 | sizefn: (*SIZE*)
1476 IF x.class # Ntype THEN err(110); x := NewIntConst(1)
1477 ELSIF (f IN {Byte..Set, Pointer, ProcTyp, Char16, Int64}) OR (x.typ.comp IN {Array, Record}) THEN
1478 CheckOldType(x); x.typ.pvused := TRUE;
1479 IF typSize # NIL THEN
1480 typSize(x.typ); x := NewIntConst(x.typ.size)
1481 ELSE
1482 MOp(size, x)
1483 END
1484 ELSE err(111); x := NewIntConst(1)
1485 END
1486 | thisrecfn, (*THISRECORD*)
1487 thisarrfn: (*THISARRAY*)
1488 IF (x.class = Ntype) OR (x.class = Nproc) THEN err(126)
1489 ELSIF f IN {Int8, Int16} THEN Convert(x, DevCPT.int32typ)
1490 ELSIF f # Int32 THEN err(111)
1491 END
1492 | ccfn: (*SYSTEM.CC*)
1493 MOp(cc, x)
1494 | lshfn, rotfn: (*SYSTEM.LSH, SYSTEM.ROT*)
1495 IF (x.class = Ntype) OR (x.class = Nproc) THEN err(126)
1496 ELSIF ~(f IN intSet + charSet + {Byte, Set}) THEN err(111)
1497 END
1498 | getfn, putfn, bitfn, movefn: (*SYSTEM.GET, SYSTEM.PUT, SYSTEM.BIT, SYSTEM.MOVE*)
1499 IF (x.class = Ntype) OR (x.class = Nproc) THEN err(126)
1500 ELSIF (x.class = Nconst) & (f IN {Int8, Int16}) THEN Convert(x, DevCPT.int32typ)
1501 ELSIF ~(f IN {Int32, Pointer}) THEN err(111); x.typ := DevCPT.int32typ
1502 END
1503 | getrfn, putrfn: (*SYSTEM.GETREG, SYSTEM.PUTREG*)
1504 IF (f IN intSet) & (x.class = Nconst) THEN
1505 IF (x.conval.intval < DevCPM.MinRegNr) OR (x.conval.intval > DevCPM.MaxRegNr) THEN err(220)
1506 END
1507 ELSE err(69)
1508 END
1509 | valfn: (*SYSTEM.VAL*)
1510 IF x.class # Ntype THEN err(110)
1511 ELSIF (f IN {Undef, String8, String16, NoTyp, NilTyp}) (* OR (x.typ.comp = DynArr) *) THEN err(111)
1512 ELSE CheckOldType(x)
1513 END
1514 | assertfn: (*ASSERT*)
1515 IF (x.class = Ntype) OR (x.class = Nproc) THEN err(126); x := NewBoolConst(FALSE)
1516 ELSIF f # Bool THEN err(120); x := NewBoolConst(FALSE)
1517 ELSE MOp(not, x)
1518 END
1519 | validfn: (* VALID *)
1520 IF (x.class = Nvarpar) & ODD(x.obj.sysflag DIV nilBit) THEN
1521 MOp(adr, x); x.typ := DevCPT.sysptrtyp; Op(neq, x, Nil())
1522 ELSE err(111)
1523 END;
1524 x.typ := DevCPT.booltyp
1525 | iidfn: (* COM.IID *)
1526 IF (x.class = Nconst) & (f = String8) THEN StringToGuid(x)
1527 ELSE
1528 typ := x.typ;
1529 IF typ.form = Pointer THEN typ := typ.BaseTyp END;
1530 IF (typ.sysflag = interface) & (typ.ext # NIL) & (typ.strobj # NIL) THEN
1531 IF x.obj # typ.strobj THEN x := NewLeaf(typ.strobj) END
1532 ELSE err(111)
1533 END;
1534 x.class := Nconst; x.typ := DevCPT.guidtyp
1535 END
1536 | queryfn: (* COM.QUERY *)
1537 IF (x.class = Ntype) OR (x.class = Nproc) THEN err(126)
1538 ELSIF f # Pointer THEN err(111)
1539 END
1540 END ;
1541 par0 := x
1542 END StPar0;
1544 PROCEDURE StPar1*(VAR par0: DevCPT.Node; x: DevCPT.Node; fctno: BYTE);
1545 (* x: second parameter of standard proc *)
1546 VAR f, n, L, i: INTEGER; typ, tp1: DevCPT.Struct; p, t: DevCPT.Node;
1548 PROCEDURE NewOp(class, subcl: BYTE; left, right: DevCPT.Node): DevCPT.Node;
1549 VAR node: DevCPT.Node;
1550 BEGIN
1551 node := DevCPT.NewNode(class); node.subcl := subcl;
1552 node.left := left; node.right := right; RETURN node
1553 END NewOp;
1555 BEGIN p := par0; f := x.typ.form;
1556 CASE fctno OF
1557 incfn, decfn: (*INC DEC*)
1558 IF (x.class = Ntype) OR (x.class = Nproc) THEN err(126); p.typ := DevCPT.notyp
1559 ELSE
1560 IF f # p.typ.form THEN
1561 IF f IN intSet THEN Convert(x, p.typ)
1562 ELSE err(111)
1563 END
1564 END ;
1565 p := NewOp(Nassign, fctno, p, x);
1566 p.typ := DevCPT.notyp
1567 END
1568 | inclfn, exclfn: (*INCL, EXCL*)
1569 IF (x.class = Ntype) OR (x.class = Nproc) THEN err(126)
1570 ELSIF f IN intSet THEN
1571 IF f = Int64 THEN Convert(x, DevCPT.int32typ) END;
1572 IF (x.class = Nconst) & ((0 > x.conval.intval) OR (x.conval.intval > DevCPM.MaxSet)) THEN err(202)
1573 END ;
1574 p := NewOp(Nassign, fctno, p, x)
1575 ELSE err(111)
1576 END ;
1577 p.typ := DevCPT.notyp
1578 | lenfn: (*LEN*)
1579 IF ~(f IN intSet) OR (x.class # Nconst) THEN err(69)
1580 ELSE
1581 IF f = Int64 THEN Convert(x, DevCPT.int32typ) END;
1582 L := SHORT(x.conval.intval); typ := p.typ;
1583 WHILE (L > 0) & (typ.comp IN {DynArr, Array}) DO typ := typ.BaseTyp; DEC(L) END ;
1584 IF (L # 0) OR ~(typ.comp IN {DynArr, Array}) THEN err(132)
1585 ELSE x.obj := NIL;
1586 IF typ.comp = DynArr THEN
1587 WHILE p.class = Nindex DO
1588 p := p.left; INC(x.conval.intval) (* possible side effect ignored *)
1589 END;
1590 p := NewOp(Ndop, len, p, x); p.typ := DevCPT.int32typ
1591 ELSE p := x; p.conval.intval := typ.n; p.typ := DevCPT.int32typ
1592 END
1593 END
1594 END
1595 | copyfn: (*COPY*)
1596 IF NotVar(x) THEN err(112)
1597 ELSIF x.readonly THEN err(76)
1598 ELSE
1599 CheckString(p, x.typ, 111); t := x; x := p; p := t;
1600 IF (x.class = Nconst) & (x.typ.form IN {String8, String16}) THEN AssignString(p, x)
1601 ELSE p := NewOp(Nassign, copyfn, p, x)
1602 END
1603 END ;
1604 p.typ := DevCPT.notyp; MarkAsUsed(x)
1605 | ashfn: (*ASH*)
1606 IF (x.class = Ntype) OR (x.class = Nproc) THEN err(126)
1607 ELSIF f IN intSet THEN
1608 IF (x.class = Nconst) & ((x.conval.intval > 64) OR (x.conval.intval < -64)) THEN err(208)
1609 ELSIF (p.class = Nconst) & (x.class = Nconst) THEN
1610 n := x.conval.intval;
1611 IF n > 0 THEN
1612 WHILE n > 0 DO MulConst(p.conval, two, p.conval, p.typ); DEC(n) END
1613 ELSE
1614 WHILE n < 0 DO DivModConst(p.conval, two, TRUE, p.typ); INC(n) END
1615 END;
1616 p.obj := NIL
1617 ELSE
1618 IF f = Int64 THEN Convert(x, DevCPT.int32typ) END;
1619 typ := p.typ; p := NewOp(Ndop, ash, p, x); p.typ := typ
1620 END
1621 ELSE err(111)
1622 END
1623 | minfn: (*MIN*)
1624 IF p.class # Ntype THEN Op(min, p, x) ELSE err(64) END
1625 | maxfn: (*MAX*)
1626 IF p.class # Ntype THEN Op(max, p, x) ELSE err(64) END
1627 | newfn: (*NEW(p, x...)*)
1628 IF (x.class = Ntype) OR (x.class = Nproc) THEN err(126)
1629 ELSIF p.typ.comp = DynArr THEN
1630 IF f IN intSet THEN
1631 IF f = Int64 THEN Convert(x, DevCPT.int32typ) END;
1632 IF (x.class = Nconst) & (x.conval.intval <= 0)
1633 & (~(DevCPM.java IN DevCPM.options) OR (x.conval.intval < 0))THEN err(63) END
1634 ELSE err(111)
1635 END ;
1636 p.right := x; p.typ := p.typ.BaseTyp
1637 ELSIF (p.left # NIL) & (p.left.typ.form = Pointer) THEN
1638 typ := p.left.typ;
1639 WHILE (typ # DevCPT.undftyp) & (typ.BaseTyp # NIL) DO typ := typ.BaseTyp END;
1640 IF typ.sysflag = interface THEN
1641 typ := x.typ;
1642 WHILE (typ # DevCPT.undftyp) & (typ.BaseTyp # NIL) DO typ := typ.BaseTyp END;
1643 IF (f = Pointer) & (typ.sysflag = interface) THEN
1644 p.right := x
1645 ELSE err(169)
1646 END
1647 ELSE err(64)
1648 END
1649 ELSE err(111)
1650 END
1651 | thisrecfn, (*THISRECORD*)
1652 thisarrfn: (*THISARRAY*)
1653 IF (x.class = Ntype) OR (x.class = Nproc) THEN err(126)
1654 ELSIF f IN {Int8, Int16, Int32} THEN
1655 IF f < Int32 THEN Convert(x, DevCPT.int32typ) END;
1656 p := NewOp(Ndop, fctno, p, x); p.typ := DevCPT.undftyp
1657 ELSE err(111)
1658 END
1659 | lshfn, rotfn: (*SYSTEM.LSH, SYSTEM.ROT*)
1660 IF (x.class = Ntype) OR (x.class = Nproc) THEN err(126)
1661 ELSIF ~(f IN intSet) THEN err(111)
1662 ELSE
1663 IF fctno = lshfn THEN p := NewOp(Ndop, lsh, p, x) ELSE p := NewOp(Ndop, rot, p, x) END ;
1664 p.typ := p.left.typ
1665 END
1666 | getfn, putfn, getrfn, putrfn: (*SYSTEM.GET, SYSTEM.PUT, SYSTEM.GETREG, SYSTEM.PUTREG*)
1667 IF (x.class = Ntype) OR (x.class = Nproc) THEN err(126)
1668 ELSIF f IN {Undef..Set, NilTyp, Pointer, ProcTyp, Char16, Int64} THEN
1669 IF (fctno = getfn) OR (fctno = getrfn) THEN
1670 IF NotVar(x) THEN err(112) END ;
1671 t := x; x := p; p := t
1672 END ;
1673 p := NewOp(Nassign, fctno, p, x)
1674 ELSE err(111)
1675 END ;
1676 p.typ := DevCPT.notyp
1677 | bitfn: (*SYSTEM.BIT*)
1678 IF (x.class = Ntype) OR (x.class = Nproc) THEN err(126)
1679 ELSIF f IN intSet THEN
1680 p := NewOp(Ndop, bit, p, x)
1681 ELSE err(111)
1682 END ;
1683 p.typ := DevCPT.booltyp
1684 | valfn: (*SYSTEM.VAL*) (* type is changed without considering the byte ordering on the target machine *)
1685 IF (x.class = Ntype) OR (x.class = Nproc) THEN err(126)
1686 ELSIF x.typ.comp = DynArr THEN
1687 IF x.typ.untagged & ((p.typ.comp # DynArr) OR p.typ.untagged) THEN (* ok *)
1688 ELSIF (p.typ.comp = DynArr) & (x.typ.n = p.typ.n) THEN
1689 typ := x.typ;
1690 WHILE typ.comp = DynArr DO typ := typ.BaseTyp END;
1691 tp1 := p.typ;
1692 WHILE tp1.comp = DynArr DO tp1 := tp1.BaseTyp END;
1693 IF typ.size # tp1.size THEN err(115) END
1694 ELSE err(115)
1695 END
1696 ELSIF p.typ.comp = DynArr THEN err(115)
1697 ELSIF (x.class = Nconst) & (f = String8) & (p.typ.form = Int32) & (x.conval.intval2 <= 5) THEN
1698 i := 0; n := 0;
1699 WHILE i < x.conval.intval2 - 1 DO n := 256 * n + ORD(x.conval.ext[i]); INC(i) END;
1700 x := NewIntConst(n)
1701 ELSIF (f IN {Undef, NoTyp, NilTyp}) OR (f IN {String8, String16}) & ~(DevCPM.java IN DevCPM.options) THEN err(111)
1702 END ;
1703 IF (x.class = Nconst) & (x.typ = p.typ) THEN (* ok *)
1704 ELSIF (x.class >= Nconst) OR ((f IN realSet) # (p.typ.form IN realSet))
1705 OR (DevCPM.options * {DevCPM.java, DevCPM.allSysVal} # {}) THEN
1706 t := DevCPT.NewNode(Nmop); t.subcl := val; t.left := x; x := t
1707 ELSE x.readonly := FALSE
1708 END ;
1709 x.typ := p.typ; p := x
1710 | movefn: (*SYSTEM.MOVE*)
1711 IF (x.class = Ntype) OR (x.class = Nproc) THEN err(126)
1712 ELSIF (x.class = Nconst) & (f IN {Int8, Int16}) THEN Convert(x, DevCPT.int32typ)
1713 ELSIF ~(f IN {Int32, Pointer}) THEN err(111); x.typ := DevCPT.int32typ
1714 END ;
1715 p.link := x
1716 | assertfn: (*ASSERT*)
1717 IF (f IN intSet - {Int64}) & (x.class = Nconst) THEN
1718 IF (DevCPM.MinHaltNr <= x.conval.intval) & (x.conval.intval <= DevCPM.MaxHaltNr) THEN
1719 BindNodes(Ntrap, DevCPT.notyp, x, x);
1720 Construct(Nif, p, x); Construct(Nifelse, p, NIL); OptIf(p);
1721 ELSE err(218)
1722 END
1723 ELSIF
1724 (DevCPM.java IN DevCPM.options) & ((x.class = Ntype) OR (x.class = Nvar)) & (x.typ.form = Pointer)
1725 THEN
1726 BindNodes(Ntrap, DevCPT.notyp, x, x);
1727 Construct(Nif, p, x); Construct(Nifelse, p, NIL); OptIf(p);
1728 ELSE err(69)
1729 END;
1730 IF p = NIL THEN (* ASSERT(TRUE) *)
1731 ELSIF p.class = Ntrap THEN err(99)
1732 ELSE p.subcl := assertfn
1733 END
1734 | queryfn: (* COM.QUERY *)
1735 IF (x.class = Ntype) OR (x.class = Nproc) THEN err(126)
1736 ELSIF x.typ # DevCPT.guidtyp THEN err(111); x.typ := DevCPT.guidtyp
1737 END;
1738 p.link := x
1739 ELSE err(64)
1740 END ;
1741 par0 := p
1742 END StPar1;
1744 PROCEDURE StParN*(VAR par0: DevCPT.Node; x: DevCPT.Node; fctno, n: SHORTINT);
1745 (* x: n+1-th param of standard proc *)
1746 VAR node: DevCPT.Node; f: SHORTINT; p: DevCPT.Node; typ: DevCPT.Struct;
1747 BEGIN p := par0; f := x.typ.form;
1748 IF fctno = newfn THEN (*NEW(p, ..., x...*)
1749 IF (x.class = Ntype) OR (x.class = Nproc) THEN err(126)
1750 ELSIF p.typ.comp # DynArr THEN err(64)
1751 ELSIF f IN intSet THEN
1752 IF f = Int64 THEN Convert(x, DevCPT.int32typ) END;
1753 IF (x.class = Nconst) & (x.conval.intval <= 0) THEN err(63) END;
1754 node := p.right; WHILE node.link # NIL DO node := node.link END;
1755 node.link := x; p.typ := p.typ.BaseTyp
1756 ELSE err(111)
1757 END
1758 ELSIF (fctno = movefn) & (n = 2) THEN (*SYSTEM.MOVE*)
1759 IF (x.class = Ntype) OR (x.class = Nproc) THEN err(126)
1760 ELSIF f IN intSet THEN
1761 node := DevCPT.NewNode(Nassign); node.subcl := movefn; node.right := p;
1762 node.left := p.link; p.link := x; p := node
1763 ELSE err(111)
1764 END ;
1765 p.typ := DevCPT.notyp
1766 ELSIF (fctno = queryfn) & (n = 2) THEN (* COM.QUERY *)
1767 IF (x.class = Ntype) OR (x.class = Nproc) THEN err(126)
1768 ELSIF (x.class < Nconst) & (f = Pointer) & (x.typ.sysflag = interface) THEN
1769 IF ~DevCPT.Extends(p.typ, x.typ) THEN err(164) END;
1770 IF x.readonly THEN err(76) END;
1771 CheckNewParamPair(x, p.link);
1772 MarkAsUsed(x);
1773 node := DevCPT.NewNode(Ndop); node.subcl := queryfn;
1774 node.left := p; node.right := p.link; p.link := NIL; node.right.link := x; p := node
1775 ELSE err(111)
1776 END;
1777 p.typ := DevCPT.booltyp
1778 ELSE err(64)
1779 END ;
1780 par0 := p
1781 END StParN;
1783 PROCEDURE StFct*(VAR par0: DevCPT.Node; fctno: BYTE; parno: SHORTINT);
1784 VAR dim: SHORTINT; x, p: DevCPT.Node;
1785 BEGIN p := par0;
1786 IF fctno <= ashfn THEN
1787 IF (fctno = newfn) & (p.typ # DevCPT.notyp) THEN
1788 IF p.typ.comp = DynArr THEN err(65) END ;
1789 p.typ := DevCPT.notyp
1790 ELSIF (fctno = minfn) OR (fctno = maxfn) THEN
1791 IF (parno < 1) OR (parno = 1) & (p.hint # 1) THEN err(65) END;
1792 p.hint := 0
1793 ELSIF fctno <= sizefn THEN (* 1 param *)
1794 IF parno < 1 THEN err(65) END
1795 ELSE (* more than 1 param *)
1796 IF ((fctno = incfn) OR (fctno = decfn)) & (parno = 1) THEN (*INC, DEC*)
1797 BindNodes(Nassign, DevCPT.notyp, p, NewIntConst(1)); p.subcl := fctno; p.right.typ := p.left.typ
1798 ELSIF (fctno = lenfn) & (parno = 1) THEN (*LEN*)
1799 IF p.typ.form IN {String8, String16} THEN
1800 IF p.class = Nconst THEN p := NewIntConst(p.conval.intval2 - 1)
1801 ELSIF (p.class = Ndop) & (p.subcl = plus) THEN (* propagate to leaf nodes *)
1802 StFct(p.left, lenfn, 1); StFct(p.right, lenfn, 1); p.typ := DevCPT.int32typ
1803 ELSE
1804 WHILE (p.class = Nmop) & (p.subcl = conv) DO p := p.left END;
1805 IF DevCPM.errors = 0 THEN ASSERT(p.class = Nderef) END;
1806 BindNodes(Ndop, DevCPT.int32typ, p, NewIntConst(0)); p.subcl := len
1807 END
1808 ELSIF p.typ.comp = DynArr THEN dim := 0;
1809 WHILE p.class = Nindex DO p := p.left; INC(dim) END ; (* possible side effect ignored *)
1810 BindNodes(Ndop, DevCPT.int32typ, p, NewIntConst(dim)); p.subcl := len
1811 ELSE
1812 p := NewIntConst(p.typ.n)
1813 END
1814 ELSIF parno < 2 THEN err(65)
1815 END
1816 END
1817 ELSIF fctno = assertfn THEN
1818 IF parno = 1 THEN x := NIL;
1819 BindNodes(Ntrap, DevCPT.notyp, x, NewIntConst(AssertTrap));
1820 Construct(Nif, p, x); Construct(Nifelse, p, NIL); OptIf(p);
1821 IF p = NIL THEN (* ASSERT(TRUE) *)
1822 ELSIF p.class = Ntrap THEN err(99)
1823 ELSE p.subcl := assertfn
1824 END
1825 ELSIF parno < 1 THEN err(65)
1826 END
1827 ELSIF (fctno >= lchrfn) & (fctno <= bytesfn) THEN
1828 IF parno < 1 THEN err(65) END
1829 ELSIF fctno < validfn THEN (*SYSTEM*)
1830 IF (parno < 1) OR
1831 (fctno > ccfn) & (parno < 2) OR
1832 (fctno = movefn) & (parno < 3) THEN err(65)
1833 END
1834 ELSIF (fctno = thisrecfn) OR (fctno = thisarrfn) THEN
1835 IF parno < 2 THEN err(65) END
1836 ELSE (* COM *)
1837 IF fctno = queryfn THEN
1838 IF parno < 3 THEN err(65) END
1839 ELSE
1840 IF parno < 1 THEN err(65) END
1841 END
1842 END ;
1843 par0 := p
1844 END StFct;
1846 PROCEDURE DynArrParCheck (ftyp: DevCPT.Struct; VAR ap: DevCPT.Node; fvarpar: BOOLEAN);
1847 (* check array compatibility *)
1848 VAR atyp: DevCPT.Struct;
1849 BEGIN (* ftyp.comp = DynArr *)
1850 atyp := ap.typ;
1851 IF atyp.form IN {Char8, Char16, String8, String16} THEN
1852 IF ~fvarpar & (ftyp.BaseTyp.form = Char16) & (atyp.form = String8) THEN Convert(ap, DevCPT.string16typ)
1853 ELSE CheckString(ap, ftyp, 67)
1854 END
1855 ELSE
1856 WHILE (ftyp.comp = DynArr) & ((atyp.comp IN {Array, DynArr}) OR (atyp.form IN {String8, String16})) DO
1857 ftyp := ftyp.BaseTyp; atyp := atyp.BaseTyp
1858 END;
1859 IF ftyp.comp = DynArr THEN err(67)
1860 ELSIF ~fvarpar & (ftyp.form = Pointer) & DevCPT.Extends(atyp, ftyp) THEN (* ok *)
1861 ELSIF ~DevCPT.EqualType(ftyp, atyp) THEN err(66)
1862 END
1863 END
1864 END DynArrParCheck;
1866 PROCEDURE PrepCall*(VAR x: DevCPT.Node; VAR fpar: DevCPT.Object);
1867 BEGIN
1868 IF (x.obj # NIL) & (x.obj.mode IN {LProc, XProc, TProc, CProc}) THEN
1869 fpar := x.obj.link;
1870 IF x.obj.mode = TProc THEN
1871 IF fpar.typ.form = Pointer THEN
1872 IF x.left.class = Nderef THEN x.left := x.left.left (*undo DeRef*) ELSE err(71) END
1873 END;
1874 fpar := fpar.link
1875 END
1876 ELSIF (x.class # Ntype) & (x.typ # NIL) & (x.typ.form = ProcTyp) THEN
1877 fpar := x.typ.link
1878 ELSE err(121); fpar := NIL; x.typ := DevCPT.undftyp
1879 END
1880 END PrepCall;
1882 PROCEDURE Param* (VAR ap: DevCPT.Node; fp: DevCPT.Object); (* checks parameter compatibilty *)
1883 VAR at, ft: DevCPT.Struct;
1884 BEGIN
1885 at := ap.typ; ft := fp.typ;
1886 IF fp.ptyp # NIL THEN ft := fp.ptyp END; (* get original formal type *)
1887 IF ft.form # Undef THEN
1888 IF (ap.class = Ntype) OR (ap.class = Nproc) & (ft.form # ProcTyp) THEN err(126) END;
1889 IF fp.mode = VarPar THEN
1890 IF ODD(fp.sysflag DIV nilBit) & (at = DevCPT.niltyp) THEN (* ok *)
1891 ELSIF (ft.comp = Record) & ~ft.untagged & (ap.class = Ndop) & (ap.subcl = thisrecfn) THEN (* ok *)
1892 ELSIF (ft.comp = DynArr) & ~ft.untagged & (ft.n = 0) & (ap.class = Ndop) & (ap.subcl = thisarrfn) THEN
1893 (* ok *)
1894 ELSE
1895 IF fp.vis = inPar THEN
1896 IF (ft = DevCPT.guidtyp) & (ap.class = Nconst) & (at.form = String8) THEN
1897 StringToGuid(ap); at := ap.typ
1898 (*
1899 ELSIF ((at.form IN charSet + {String8, String16}) OR (at = DevCPT.guidtyp))
1900 & ((ap.class = Nderef) OR (ap.class = Nconst)) THEN (* ok *)
1901 ELSIF NotVar(ap) THEN err(122)
1902 *)
1903 END;
1904 IF ~NotVar(ap) THEN CheckLeaf(ap, FALSE) END
1905 ELSE
1906 IF NotVar(ap) THEN err(122)
1907 ELSIF ap.readonly THEN err(76)
1908 ELSIF (ap.obj # NIL) & ODD(ap.obj.sysflag DIV newBit) & ~ODD(fp.sysflag DIV newBit) THEN
1909 err(167)
1910 ELSE MarkAsUsed(ap); CheckLeaf(ap, FALSE)
1911 END
1912 END;
1913 IF ft.comp = DynArr THEN DynArrParCheck(ft, ap, fp.vis # inPar)
1914 ELSIF ODD(fp.sysflag DIV newBit) THEN
1915 IF ~DevCPT.Extends(at, ft) THEN err(123) END
1916 ELSIF (ft = DevCPT.sysptrtyp) & (at.form = Pointer) THEN (* ok *)
1917 ELSIF (fp.vis # outPar) & (ft.comp = Record) & DevCPT.Extends(at, ft) THEN (* ok *)
1918 ELSIF covarOut & (fp.vis = outPar) & (ft.form = Pointer) & DevCPT.Extends(ft, at) THEN (* ok *)
1919 ELSIF fp.vis = inPar THEN CheckAssign(ft, ap)
1920 ELSIF ~DevCPT.EqualType(ft, at) THEN err(123)
1921 END
1922 END
1923 ELSIF ft.comp = DynArr THEN DynArrParCheck(ft, ap, FALSE)
1924 ELSE CheckAssign(ft, ap)
1925 END
1926 END
1927 END Param;
1929 PROCEDURE StaticLink*(dlev: BYTE; var: BOOLEAN);
1930 VAR scope: DevCPT.Object;
1931 BEGIN
1932 scope := DevCPT.topScope;
1933 WHILE dlev > 0 DO DEC(dlev);
1934 INCL(scope.link.conval.setval, slNeeded);
1935 scope := scope.left
1936 END;
1937 IF var THEN INCL(scope.link.conval.setval, imVar) END (* !!! *)
1938 END StaticLink;
1940 PROCEDURE Call*(VAR x: DevCPT.Node; apar: DevCPT.Node; fp: DevCPT.Object);
1941 VAR typ: DevCPT.Struct; p: DevCPT.Node; lev: BYTE;
1942 BEGIN
1943 IF x.class = Nproc THEN typ := x.typ;
1944 lev := x.obj.mnolev;
1945 IF lev > 0 THEN StaticLink(SHORT(SHORT(DevCPT.topScope.mnolev-lev)), FALSE) END ; (* !!! *)
1946 IF x.obj.mode = IProc THEN err(121) END
1947 ELSIF (x.class = Nfield) & (x.obj.mode = TProc) THEN typ := x.typ;
1948 x.class := Nproc; p := x.left; x.left := NIL; p.link := apar; apar := p; fp := x.obj.link
1949 ELSE typ := x.typ.BaseTyp
1950 END ;
1951 BindNodes(Ncall, typ, x, apar); x.obj := fp
1952 END Call;
1954 PROCEDURE Enter*(VAR procdec: DevCPT.Node; stat: DevCPT.Node; proc: DevCPT.Object);
1955 VAR x: DevCPT.Node;
1956 BEGIN
1957 x := DevCPT.NewNode(Nenter); x.typ := DevCPT.notyp; x.obj := proc;
1958 x.left := procdec; x.right := stat; procdec := x
1959 END Enter;
1961 PROCEDURE Return*(VAR x: DevCPT.Node; proc: DevCPT.Object);
1962 VAR node: DevCPT.Node;
1963 BEGIN
1964 IF proc = NIL THEN (* return from module *)
1965 IF x # NIL THEN err(124) END
1966 ELSE
1967 IF x # NIL THEN CheckAssign(proc.typ, x)
1968 ELSIF proc.typ # DevCPT.notyp THEN err(124)
1969 END
1970 END ;
1971 node := DevCPT.NewNode(Nreturn); node.typ := DevCPT.notyp; node.obj := proc; node.left := x; x := node
1972 END Return;
1974 PROCEDURE Assign*(VAR x: DevCPT.Node; y: DevCPT.Node);
1975 VAR z: DevCPT.Node;
1976 BEGIN
1977 IF (x.class >= Nconst) OR (x.typ.form IN {String8, String16}) THEN err(56) END ;
1978 CheckAssign(x.typ, y);
1979 IF x.readonly THEN err(76)
1980 ELSIF (x.obj # NIL) & ODD(x.obj.sysflag DIV newBit) THEN err(167)
1981 END ;
1982 MarkAsUsed(x);
1983 IF (y.class = Nconst) & (y.typ.form IN {String8, String16}) & (x.typ.form # Pointer) THEN AssignString(x, y)
1984 ELSE BindNodes(Nassign, DevCPT.notyp, x, y); x.subcl := assign
1985 END
1986 END Assign;
1988 PROCEDURE Inittd*(VAR inittd, last: DevCPT.Node; typ: DevCPT.Struct);
1989 VAR node: DevCPT.Node;
1990 BEGIN
1991 node := DevCPT.NewNode(Ninittd); node.typ := typ;
1992 node.conval := DevCPT.NewConst(); node.conval.intval := typ.txtpos;
1993 IF inittd = NIL THEN inittd := node ELSE last.link := node END ;
1994 last := node
1995 END Inittd;
1997 (* handling of temporary variables for string operations *)
1999 PROCEDURE Overlap (left, right: DevCPT.Node): BOOLEAN;
2000 BEGIN
2001 IF right.class = Nconst THEN
2002 RETURN FALSE
2003 ELSIF (right.class = Ndop) & (right.subcl = plus) THEN
2004 RETURN Overlap(left, right.left) OR Overlap(left, right.right)
2005 ELSE
2006 WHILE right.class = Nmop DO right := right.left END;
2007 IF right.class = Nderef THEN right := right.left END;
2008 IF left.typ.BaseTyp # right.typ.BaseTyp THEN RETURN FALSE END;
2009 LOOP
2010 IF left.class = Nvarpar THEN
2011 WHILE (right.class = Nindex) OR (right.class = Nfield) OR (right.class = Nguard) DO
2012 right := right.left
2013 END;
2014 RETURN (right.class # Nvar) OR (right.obj.mnolev < left.obj.mnolev)
2015 ELSIF right.class = Nvarpar THEN
2016 WHILE (left.class = Nindex) OR (left.class = Nfield) OR (left.class = Nguard) DO left := left.left END;
2017 RETURN (left.class # Nvar) OR (left.obj.mnolev < right.obj.mnolev)
2018 ELSIF (left.class = Nvar) & (right.class = Nvar) THEN
2019 RETURN left.obj = right.obj
2020 ELSIF (left.class = Nderef) & (right.class = Nderef) THEN
2021 RETURN TRUE
2022 ELSIF (left.class = Nindex) & (right.class = Nindex) THEN
2023 IF (left.right.class = Nconst) & (right.right.class = Nconst)
2024 & (left.right.conval.intval # right.right.conval.intval) THEN RETURN FALSE END;
2025 left := left.left; right := right.left
2026 ELSIF (left.class = Nfield) & (right.class = Nfield) THEN
2027 IF left.obj # right.obj THEN RETURN FALSE END;
2028 left := left.left; right := right.left;
2029 WHILE left.class = Nguard DO left := left.left END;
2030 WHILE right.class = Nguard DO right := right.left END
2031 ELSE
2032 RETURN FALSE
2033 END
2034 END
2035 END
2036 END Overlap;
2038 PROCEDURE GetStaticLength (n: DevCPT.Node; OUT length: INTEGER);
2039 VAR x: INTEGER;
2040 BEGIN
2041 IF n.class = Nconst THEN
2042 length := n.conval.intval2 - 1
2043 ELSIF (n.class = Ndop) & (n.subcl = plus) THEN
2044 GetStaticLength(n.left, length); GetStaticLength(n.right, x);
2045 IF (length >= 0) & (x >= 0) THEN length := length + x ELSE length := -1 END
2046 ELSE
2047 WHILE (n.class = Nmop) & (n.subcl = conv) DO n := n.left END;
2048 IF (n.class = Nderef) & (n.subcl = 1) THEN n := n.left END;
2049 IF n.typ.comp = Array THEN
2050 length := n.typ.n - 1
2051 ELSIF n.typ.comp = DynArr THEN
2052 length := -1
2053 ELSE (* error case *)
2054 length := 4
2055 END
2056 END
2057 END GetStaticLength;
2059 PROCEDURE GetMaxLength (n: DevCPT.Node; VAR stat, last: DevCPT.Node; OUT length: DevCPT.Node);
2060 VAR x: DevCPT.Node; d: INTEGER; obj: DevCPT.Object;
2061 BEGIN
2062 IF n.class = Nconst THEN
2063 length := NewIntConst(n.conval.intval2 - 1)
2064 ELSIF (n.class = Ndop) & (n.subcl = plus) THEN
2065 GetMaxLength(n.left, stat, last, length); GetMaxLength(n.right, stat, last, x);
2066 IF (length.class = Nconst) & (x.class = Nconst) THEN ConstOp(plus, length, x)
2067 ELSE BindNodes(Ndop, length.typ, length, x); length.subcl := plus
2068 END
2069 ELSE
2070 WHILE (n.class = Nmop) & (n.subcl = conv) DO n := n.left END;
2071 IF (n.class = Nderef) & (n.subcl = 1) THEN n := n.left END;
2072 IF n.typ.comp = Array THEN
2073 length := NewIntConst(n.typ.n - 1)
2074 ELSIF n.typ.comp = DynArr THEN
2075 d := 0;
2076 WHILE n.class = Nindex DO n := n.left; INC(d) END;
2077 ASSERT((n.class = Nderef) OR (n.class = Nvar) OR (n.class = Nvarpar));
2078 IF (n.class = Nderef) & (n.left.class # Nvar) & (n.left.class # Nvarpar) THEN
2079 GetTempVar("@tmp", n.left.typ, obj);
2080 x := NewLeaf(obj); Assign(x, n.left); Link(stat, last, x);
2081 n.left := NewLeaf(obj); (* tree is manipulated here *)
2082 n := NewLeaf(obj); DeRef(n)
2083 END;
2084 IF n.typ.untagged & (n.typ.comp = DynArr) & (n.typ.BaseTyp.form IN {Char8, Char16}) THEN
2085 StrDeref(n);
2086 BindNodes(Ndop, DevCPT.int32typ, n, NewIntConst(d)); n.subcl := len;
2087 BindNodes(Ndop, DevCPT.int32typ, n, NewIntConst(1)); n.subcl := plus
2088 ELSE
2089 BindNodes(Ndop, DevCPT.int32typ, n, NewIntConst(d)); n.subcl := len;
2090 END;
2091 length := n
2092 ELSE (* error case *)
2093 length := NewIntConst(4)
2094 END
2095 END
2096 END GetMaxLength;
2098 PROCEDURE CheckBuffering* (
2099 VAR n: DevCPT.Node; left: DevCPT.Node; par: DevCPT.Object; VAR stat, last: DevCPT.Node
2100 );
2101 VAR length, x: DevCPT.Node; obj: DevCPT.Object; typ: DevCPT.Struct; len, xlen: INTEGER;
2102 BEGIN
2103 IF (n.typ.form IN {String8, String16}) & ~(DevCPM.java IN DevCPM.options)
2104 & ((n.class = Ndop) & (n.subcl = plus) & ((left = NIL) OR Overlap(left, n.right))
2105 OR (n.class = Nmop) & (n.subcl = conv) & (left = NIL)
2106 OR (par # NIL) & (par.vis = inPar) & (par.typ.comp = Array)) THEN
2107 IF (par # NIL) & (par.typ.comp = Array) THEN
2108 len := par.typ.n - 1
2109 ELSE
2110 IF left # NIL THEN GetStaticLength(left, len) ELSE len := -1 END;
2111 GetStaticLength(n, xlen);
2112 IF (len = -1) OR (xlen # -1) & (xlen < len) THEN len := xlen END
2113 END;
2114 IF len # -1 THEN
2115 typ := DevCPT.NewStr(Comp, Array); typ.n := len + 1; typ.BaseTyp := n.typ.BaseTyp;
2116 GetTempVar("@str", typ, obj);
2117 x := NewLeaf(obj); Assign(x, n); Link(stat, last, x);
2118 n := NewLeaf(obj)
2119 ELSE
2120 IF left # NIL THEN GetMaxLength(left, stat, last, length)
2121 ELSE GetMaxLength(n, stat, last, length)
2122 END;
2123 typ := DevCPT.NewStr(Pointer, Basic);
2124 typ.BaseTyp := DevCPT.NewStr(Comp, DynArr); typ.BaseTyp.BaseTyp := n.typ.BaseTyp;
2125 GetTempVar("@ptr", typ, obj);
2126 x := NewLeaf(obj); Construct(Nassign, x, length); x.subcl := newfn; Link(stat, last, x);
2127 x := NewLeaf(obj); DeRef(x); Assign(x, n); Link(stat, last, x);
2128 n := NewLeaf(obj); DeRef(n)
2129 END;
2130 StrDeref(n)
2131 ELSIF (n.typ.form = Pointer) & (n.typ.sysflag = interface) & (left = NIL)
2132 & ((par # NIL) OR (n.class = Ncall))
2133 & ((n.class # Nvar) OR (n.obj.mnolev <= 0)) THEN
2134 GetTempVar("@cip", DevCPT.punktyp, obj);
2135 x := NewLeaf(obj); Assign(x, n); Link(stat, last, x);
2136 n := NewLeaf(obj)
2137 END
2138 END CheckBuffering;
2140 PROCEDURE CheckVarParBuffering* (VAR n: DevCPT.Node; VAR stat, last: DevCPT.Node);
2141 VAR x: DevCPT.Node; obj: DevCPT.Object;
2142 BEGIN
2143 IF (n.class # Nvar) OR (n.obj.mnolev <= 0) THEN
2144 GetTempVar("@ptr", n.typ, obj);
2145 x := NewLeaf(obj); Assign(x, n); Link(stat, last, x);
2146 n := NewLeaf(obj)
2147 END
2148 END CheckVarParBuffering;
2151 (* case optimization *)
2153 PROCEDURE Evaluate (n: DevCPT.Node; VAR min, max, num, dist: INTEGER; VAR head: DevCPT.Node);
2154 VAR a: INTEGER;
2155 BEGIN
2156 IF n.left # NIL THEN
2157 a := MIN(INTEGER); Evaluate(n.left, min, a, num, dist, head);
2158 IF n.conval.intval - a > dist THEN dist := n.conval.intval - a; head := n END
2159 ELSIF n.conval.intval < min THEN
2160 min := n.conval.intval
2161 END;
2162 IF n.right # NIL THEN
2163 a := MAX(INTEGER); Evaluate(n.right, a, max, num, dist, head);
2164 IF a - n.conval.intval2 > dist THEN dist := a - n.conval.intval2; head := n END
2165 ELSIF n.conval.intval2 > max THEN
2166 max := n.conval.intval2
2167 END;
2168 INC(num);
2169 IF n.conval.intval < n.conval.intval2 THEN
2170 INC(num);
2171 IF n.conval.intval2 - n.conval.intval > dist THEN dist := n.conval.intval2 - n.conval.intval; head := n END
2172 END
2173 END Evaluate;
2175 PROCEDURE Rebuild (VAR root: DevCPT.Node; head: DevCPT.Node);
2176 VAR n: DevCPT.Node;
2177 BEGIN
2178 IF root # head THEN
2179 IF head.conval.intval2 < root.conval.intval THEN
2180 Rebuild(root.left, head);
2181 root.left := head.right; head.right := root; root := head
2182 ELSE
2183 Rebuild(root.right, head);
2184 root.right := head.left; head.left := root; root := head
2185 END
2186 END
2187 END Rebuild;
2189 PROCEDURE OptimizeCase* (VAR n: DevCPT.Node);
2190 VAR min, max, num, dist, limit: INTEGER; head: DevCPT.Node;
2191 BEGIN
2192 IF n # NIL THEN
2193 min := MAX(INTEGER); max := MIN(INTEGER); num := 0; dist := 0; head := n;
2194 Evaluate(n, min, max, num, dist, head);
2195 limit := 6 * num;
2196 IF limit < 100 THEN limit := 100 END;
2197 IF (num > 4) & ((min > MAX(INTEGER) - limit) OR (max < min + limit)) THEN
2198 INCL(n.conval.setval, useTable)
2199 ELSE
2200 IF num > 4 THEN Rebuild(n, head) END;
2201 INCL(n.conval.setval, useTree);
2202 OptimizeCase(n.left);
2203 OptimizeCase(n.right)
2204 END
2205 END
2206 END OptimizeCase;
2207 (*
2208 PROCEDURE ShowTree (n: DevCPT.Node; opts: SET);
2209 BEGIN
2210 IF n # NIL THEN
2211 IF opts = {} THEN opts := n.conval.setval END;
2212 IF useTable IN opts THEN
2213 IF n.left # NIL THEN ShowTree(n.left, opts); DevCPM.LogW(",") END;
2214 DevCPM.LogWNum(n.conval.intval, 1);
2215 IF n.conval.intval2 > n.conval.intval THEN DevCPM.LogW("-"); DevCPM.LogWNum(n.conval.intval2, 1)
2216 END;
2217 IF n.right # NIL THEN DevCPM.LogW(","); ShowTree(n.right, opts) END
2218 ELSIF useTree IN opts THEN
2219 DevCPM.LogW("("); ShowTree(n.left, {}); DevCPM.LogW("|"); DevCPM.LogWNum(n.conval.intval, 1);
2220 IF n.conval.intval2 > n.conval.intval THEN DevCPM.LogW("-"); DevCPM.LogWNum(n.conval.intval2, 1)
2221 END;
2222 DevCPM.LogW("|"); ShowTree(n.right, {}); DevCPM.LogW(")")
2223 ELSE
2224 ShowTree(n.left, opts); DevCPM.LogW(" "); DevCPM.LogWNum(n.conval.intval, 1);
2225 IF n.conval.intval2 > n.conval.intval THEN DevCPM.LogW("-"); DevCPM.LogWNum(n.conval.intval2, 1)
2226 END;
2227 DevCPM.LogW(" "); ShowTree(n.right, opts)
2228 END
2229 END
2230 END ShowTree;
2231 *)
2232 BEGIN
2233 zero := DevCPT.NewConst(); zero.intval := 0; zero.realval := 0;
2234 one := DevCPT.NewConst(); one.intval := 1; one.realval := 0;
2235 two := DevCPT.NewConst(); two.intval := 2; two.realval := 0;
2236 dummy := DevCPT.NewConst();
2237 quot := DevCPT.NewConst()
2238 END DevCPB.