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