]> git.ipfire.org Git - thirdparty/gcc.git/blob - gcc/m2/gm2-gcc/m2expr.cc
Update copyright years.
[thirdparty/gcc.git] / gcc / m2 / gm2-gcc / m2expr.cc
1 /* m2expr.cc provides an interface to GCC expression trees.
2
3 Copyright (C) 2012-2023 Free Software Foundation, Inc.
4 Contributed by Gaius Mulley <gaius@glam.ac.uk>.
5
6 This file is part of GNU Modula-2.
7
8 GNU Modula-2 is free software; you can redistribute it and/or modify
9 it under the terms of the GNU General Public License as published by
10 the Free Software Foundation; either version 3, or (at your option)
11 any later version.
12
13 GNU Modula-2 is distributed in the hope that it will be useful, but
14 WITHOUT ANY WARRANTY; without even the implied warranty of
15 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
16 General Public License for more details.
17
18 You should have received a copy of the GNU General Public License
19 along with GNU Modula-2; see the file COPYING3. If not see
20 <http://www.gnu.org/licenses/>. */
21
22 #include "gcc-consolidation.h"
23
24 #include "../gm2-lang.h"
25 #include "../m2-tree.h"
26 #include "m2convert.h"
27
28 /* Prototypes. */
29
30 #define m2expr_c
31 #include "m2assert.h"
32 #include "m2builtins.h"
33 #include "m2convert.h"
34 #include "m2decl.h"
35 #include "m2expr.h"
36 #include "m2options.h"
37 #include "m2range.h"
38 #include "m2statement.h"
39 #include "m2tree.h"
40 #include "m2treelib.h"
41 #include "m2type.h"
42
43 static void m2expr_checkRealOverflow (location_t location, enum tree_code code,
44 tree result);
45 static tree checkWholeNegateOverflow (location_t location, tree i, tree lowest,
46 tree min, tree max);
47 // static tree m2expr_Build4LogicalAnd (location_t location, tree a, tree b,
48 // tree c, tree d);
49 static tree m2expr_Build4LogicalOr (location_t location, tree a, tree b,
50 tree c, tree d);
51 static tree m2expr_Build4TruthOrIf (location_t location, tree a, tree b,
52 tree c, tree d);
53 static tree m2expr_Build4TruthAndIf (location_t location, tree a, tree b,
54 tree c, tree d);
55
56 static int label_count = 0;
57 static GTY (()) tree set_full_complement;
58
59 /* CompareTrees returns -1 if e1 < e2, 0 if e1 == e2, and 1 if e1 > e2. */
60
61 int
62 m2expr_CompareTrees (tree e1, tree e2)
63 {
64 return tree_int_cst_compare (m2expr_FoldAndStrip (e1),
65 m2expr_FoldAndStrip (e2));
66 }
67
68 /* FoldAndStrip return expression, t, after it has been folded (if
69 possible). */
70
71 tree
72 m2expr_FoldAndStrip (tree t)
73 {
74 if (t != NULL)
75 {
76 t = fold (t);
77 if (TREE_CODE (t) == CONST_DECL)
78 return m2expr_FoldAndStrip (DECL_INITIAL (t));
79 }
80
81 return t;
82 }
83
84 /* StringLength returns an unsigned int which is the length of, string. */
85
86 unsigned int
87 m2expr_StringLength (tree string)
88 {
89 return TREE_STRING_LENGTH (string);
90 }
91
92 /* CheckAddressToCardinal if op is a pointer convert it to the ADDRESS type. */
93
94 static tree
95 CheckAddressToCardinal (location_t location, tree op)
96 {
97 if (m2type_IsAddress (TREE_TYPE (op)))
98 return m2convert_BuildConvert (location, m2type_GetCardinalAddressType (),
99 op, FALSE);
100 return op;
101 }
102
103 /* BuildTruthAndIf return TRUE if a && b. Retain order left to right. */
104
105 static tree
106 m2expr_BuildTruthAndIf (location_t location, tree a, tree b)
107 {
108 return m2expr_build_binary_op (location, TRUTH_ANDIF_EXPR, a, b, FALSE);
109 }
110
111 /* BuildTruthOrIf return TRUE if a || b. Retain order left to right. */
112
113 static tree
114 m2expr_BuildTruthOrIf (location_t location, tree a, tree b)
115 {
116 return m2expr_build_binary_op (location, TRUTH_ORIF_EXPR, a, b, FALSE);
117 }
118
119 /* BuildTruthNotIf inverts the boolean value of expr and returns the result. */
120
121 static tree
122 m2expr_BuildTruthNot (location_t location, tree expr)
123 {
124 return m2expr_build_unary_op (location, TRUTH_NOT_EXPR, expr, FALSE);
125 }
126
127 /* BuildPostInc builds a post increment tree, the second operand is
128 always one. */
129
130 static tree
131 m2expr_BuildPostInc (location_t location, tree op)
132 {
133 return m2expr_BuildAdd (location, op, build_int_cst (TREE_TYPE (op), 1), FALSE);
134 }
135
136 /* BuildPostDec builds a post decrement tree, the second operand is
137 always one. */
138
139 static tree
140 m2expr_BuildPostDec (location_t location, tree op)
141 {
142 return m2expr_BuildSub (location, op, build_int_cst (TREE_TYPE (op), 1), FALSE);
143 }
144
145 /* BuildAddCheck builds an addition tree. */
146
147 tree
148 m2expr_BuildAddCheck (location_t location, tree op1, tree op2, tree lowest,
149 tree min, tree max)
150 {
151 tree t;
152
153 m2assert_AssertLocation (location);
154
155 op1 = m2expr_FoldAndStrip (op1);
156 op2 = m2expr_FoldAndStrip (op2);
157
158 op1 = CheckAddressToCardinal (location, op1);
159 op2 = CheckAddressToCardinal (location, op2);
160
161 t = m2expr_build_binary_op_check (location, PLUS_EXPR, op1, op2, FALSE,
162 lowest, min, max);
163 return m2expr_FoldAndStrip (t);
164 }
165
166 /* BuildAdd builds an addition tree. */
167
168 tree
169 m2expr_BuildAdd (location_t location, tree op1, tree op2, int needconvert)
170 {
171 tree t;
172
173 m2assert_AssertLocation (location);
174
175 op1 = m2expr_FoldAndStrip (op1);
176 op2 = m2expr_FoldAndStrip (op2);
177
178 op1 = CheckAddressToCardinal (location, op1);
179 op2 = CheckAddressToCardinal (location, op2);
180
181 t = m2expr_build_binary_op (location, PLUS_EXPR, op1, op2, needconvert);
182 return m2expr_FoldAndStrip (t);
183 }
184
185 /* BuildSubCheck builds a subtraction tree. */
186
187 tree
188 m2expr_BuildSubCheck (location_t location, tree op1, tree op2, tree lowest,
189 tree min, tree max)
190 {
191 tree t;
192
193 m2assert_AssertLocation (location);
194
195 op1 = m2expr_FoldAndStrip (op1);
196 op2 = m2expr_FoldAndStrip (op2);
197
198 op1 = CheckAddressToCardinal (location, op1);
199 op2 = CheckAddressToCardinal (location, op2);
200
201 t = m2expr_build_binary_op_check (location, MINUS_EXPR, op1, op2, FALSE,
202 lowest, min, max);
203 return m2expr_FoldAndStrip (t);
204 }
205
206 /* BuildSub builds a subtraction tree. */
207
208 tree
209 m2expr_BuildSub (location_t location, tree op1, tree op2, int needconvert)
210 {
211 tree t;
212
213 m2assert_AssertLocation (location);
214
215 op1 = m2expr_FoldAndStrip (op1);
216 op2 = m2expr_FoldAndStrip (op2);
217
218 op1 = CheckAddressToCardinal (location, op1);
219 op2 = CheckAddressToCardinal (location, op2);
220
221 t = m2expr_build_binary_op (location, MINUS_EXPR, op1, op2, needconvert);
222 return m2expr_FoldAndStrip (t);
223 }
224
225 /* BuildDivTrunc builds a trunc division tree. */
226
227 tree
228 m2expr_BuildDivTrunc (location_t location, tree op1, tree op2, int needconvert)
229 {
230 tree t;
231
232 m2assert_AssertLocation (location);
233
234 op1 = m2expr_FoldAndStrip (op1);
235 op2 = m2expr_FoldAndStrip (op2);
236
237 op1 = CheckAddressToCardinal (location, op1);
238 op2 = CheckAddressToCardinal (location, op2);
239
240 t = m2expr_build_binary_op (location, TRUNC_DIV_EXPR, op1, op2, needconvert);
241 return m2expr_FoldAndStrip (t);
242 }
243
244 /* BuildDivTruncCheck builds a trunc division tree. */
245
246 tree
247 m2expr_BuildDivTruncCheck (location_t location, tree op1, tree op2, tree lowest,
248 tree min, tree max)
249 {
250 tree t;
251
252 m2assert_AssertLocation (location);
253
254 op1 = m2expr_FoldAndStrip (op1);
255 op2 = m2expr_FoldAndStrip (op2);
256
257 op1 = CheckAddressToCardinal (location, op1);
258 op2 = CheckAddressToCardinal (location, op2);
259
260 t = m2expr_build_binary_op_check (location, TRUNC_DIV_EXPR, op1, op2, FALSE,
261 lowest, min, max);
262 return m2expr_FoldAndStrip (t);
263 }
264
265 /* BuildModTruncCheck builds a trunc modulus tree. */
266
267 tree
268 m2expr_BuildModTruncCheck (location_t location, tree op1, tree op2, tree lowest,
269 tree min, tree max)
270 {
271 tree t;
272
273 m2assert_AssertLocation (location);
274
275 op1 = m2expr_FoldAndStrip (op1);
276 op2 = m2expr_FoldAndStrip (op2);
277
278 op1 = CheckAddressToCardinal (location, op1);
279 op2 = CheckAddressToCardinal (location, op2);
280
281 t = m2expr_build_binary_op_check (location, TRUNC_MOD_EXPR, op1, op2, FALSE,
282 lowest, min, max);
283 return m2expr_FoldAndStrip (t);
284 }
285
286 /* BuildModTrunc builds a trunc modulus tree. */
287
288 tree
289 m2expr_BuildModTrunc (location_t location, tree op1, tree op2, int needconvert)
290 {
291 tree t;
292
293 m2assert_AssertLocation (location);
294
295 op1 = m2expr_FoldAndStrip (op1);
296 op2 = m2expr_FoldAndStrip (op2);
297
298 op1 = CheckAddressToCardinal (location, op1);
299 op2 = CheckAddressToCardinal (location, op2);
300
301 t = m2expr_build_binary_op (location, TRUNC_MOD_EXPR, op1, op2, needconvert);
302 return m2expr_FoldAndStrip (t);
303 }
304
305 /* BuildModCeilCheck builds a ceil modulus tree. */
306
307 tree
308 m2expr_BuildModCeilCheck (location_t location, tree op1, tree op2, tree lowest,
309 tree min, tree max)
310 {
311 tree t;
312
313 m2assert_AssertLocation (location);
314
315 op1 = m2expr_FoldAndStrip (op1);
316 op2 = m2expr_FoldAndStrip (op2);
317
318 op1 = CheckAddressToCardinal (location, op1);
319 op2 = CheckAddressToCardinal (location, op2);
320
321 t = m2expr_build_binary_op_check (location, CEIL_MOD_EXPR, op1, op2, FALSE,
322 lowest, min, max);
323 return m2expr_FoldAndStrip (t);
324 }
325
326 /* BuildModFloorCheck builds a trunc modulus tree. */
327
328 tree
329 m2expr_BuildModFloorCheck (location_t location, tree op1, tree op2, tree lowest,
330 tree min, tree max)
331 {
332 tree t;
333
334 m2assert_AssertLocation (location);
335
336 op1 = m2expr_FoldAndStrip (op1);
337 op2 = m2expr_FoldAndStrip (op2);
338
339 op1 = CheckAddressToCardinal (location, op1);
340 op2 = CheckAddressToCardinal (location, op2);
341
342 t = m2expr_build_binary_op_check (location, FLOOR_MOD_EXPR, op1, op2, FALSE,
343 lowest, min, max);
344 return m2expr_FoldAndStrip (t);
345 }
346
347 /* BuildDivCeil builds a ceil division tree. */
348
349 tree
350 m2expr_BuildDivCeil (location_t location, tree op1, tree op2, int needconvert)
351 {
352 tree t;
353
354 m2assert_AssertLocation (location);
355
356 op1 = m2expr_FoldAndStrip (op1);
357 op2 = m2expr_FoldAndStrip (op2);
358
359 op1 = CheckAddressToCardinal (location, op1);
360 op2 = CheckAddressToCardinal (location, op2);
361
362 t = m2expr_build_binary_op (location, CEIL_DIV_EXPR, op1, op2, needconvert);
363 return m2expr_FoldAndStrip (t);
364 }
365
366 /* BuildDivCeilCheck builds a check ceil division tree. */
367
368 tree
369 m2expr_BuildDivCeilCheck (location_t location, tree op1, tree op2, tree lowest,
370 tree min, tree max)
371 {
372 tree t;
373
374 m2assert_AssertLocation (location);
375
376 op1 = m2expr_FoldAndStrip (op1);
377 op2 = m2expr_FoldAndStrip (op2);
378
379 op1 = CheckAddressToCardinal (location, op1);
380 op2 = CheckAddressToCardinal (location, op2);
381
382 t = m2expr_build_binary_op_check (location, CEIL_DIV_EXPR, op1, op2, FALSE,
383 lowest, min, max);
384 return m2expr_FoldAndStrip (t);
385 }
386
387 /* BuildModCeil builds a ceil modulus tree. */
388
389 tree
390 m2expr_BuildModCeil (location_t location, tree op1, tree op2, int needconvert)
391 {
392 tree t;
393
394 m2assert_AssertLocation (location);
395
396 op1 = m2expr_FoldAndStrip (op1);
397 op2 = m2expr_FoldAndStrip (op2);
398
399 op1 = CheckAddressToCardinal (location, op1);
400 op2 = CheckAddressToCardinal (location, op2);
401
402 t = m2expr_build_binary_op (location, CEIL_MOD_EXPR, op1, op2, needconvert);
403 return m2expr_FoldAndStrip (t);
404 }
405
406 /* BuildDivFloor builds a floor division tree. */
407
408 tree
409 m2expr_BuildDivFloor (location_t location, tree op1, tree op2, int needconvert)
410 {
411 tree t;
412
413 m2assert_AssertLocation (location);
414
415 op1 = m2expr_FoldAndStrip (op1);
416 op2 = m2expr_FoldAndStrip (op2);
417
418 op1 = CheckAddressToCardinal (location, op1);
419 op2 = CheckAddressToCardinal (location, op2);
420
421 t = m2expr_build_binary_op (location, FLOOR_DIV_EXPR, op1, op2, needconvert);
422 return m2expr_FoldAndStrip (t);
423 }
424
425 /* BuildDivFloorCheck builds a check floor division tree. */
426
427 tree
428 m2expr_BuildDivFloorCheck (location_t location, tree op1, tree op2, tree lowest,
429 tree min, tree max)
430 {
431 tree t;
432
433 m2assert_AssertLocation (location);
434
435 op1 = m2expr_FoldAndStrip (op1);
436 op2 = m2expr_FoldAndStrip (op2);
437
438 op1 = CheckAddressToCardinal (location, op1);
439 op2 = CheckAddressToCardinal (location, op2);
440
441 t = m2expr_build_binary_op_check (location, FLOOR_DIV_EXPR, op1, op2, FALSE,
442 lowest, min, max);
443 return m2expr_FoldAndStrip (t);
444 }
445
446 /* BuildRDiv builds a division tree (this should only be used for
447 REAL and COMPLEX types and NEVER for integer based types). */
448
449 tree
450 m2expr_BuildRDiv (location_t location, tree op1, tree op2, int needconvert)
451 {
452 tree t;
453
454 m2assert_AssertLocation (location);
455
456 op1 = m2expr_FoldAndStrip (op1);
457 op2 = m2expr_FoldAndStrip (op2);
458
459 t = m2expr_build_binary_op (location, RDIV_EXPR, op1, op2, needconvert);
460 return m2expr_FoldAndStrip (t);
461 }
462
463 /* BuildModFloor builds a modulus tree. */
464
465 tree
466 m2expr_BuildModFloor (location_t location, tree op1, tree op2, int needconvert)
467 {
468 tree t;
469
470 m2assert_AssertLocation (location);
471
472 op1 = m2expr_FoldAndStrip (op1);
473 op2 = m2expr_FoldAndStrip (op2);
474
475 op1 = CheckAddressToCardinal (location, op1);
476 op2 = CheckAddressToCardinal (location, op2);
477
478 t = m2expr_build_binary_op (location, FLOOR_MOD_EXPR, op1, op2, needconvert);
479 return m2expr_FoldAndStrip (t);
480 }
481
482 /* BuildLSL builds and returns tree (op1 << op2). */
483
484 tree
485 m2expr_BuildLSL (location_t location, tree op1, tree op2, int needconvert)
486 {
487 tree t;
488
489 m2assert_AssertLocation (location);
490
491 op1 = m2expr_FoldAndStrip (op1);
492 op2 = m2expr_FoldAndStrip (op2);
493
494 t = m2expr_build_binary_op (location, LSHIFT_EXPR, op1, op2, needconvert);
495 return m2expr_FoldAndStrip (t);
496 }
497
498 /* BuildLSR builds and returns tree (op1 >> op2). */
499
500 tree
501 m2expr_BuildLSR (location_t location, tree op1, tree op2, int needconvert)
502 {
503 tree t;
504
505 m2assert_AssertLocation (location);
506
507 op1 = m2expr_FoldAndStrip (op1);
508 op2 = m2expr_FoldAndStrip (op2);
509
510 t = m2expr_build_binary_op (location, RSHIFT_EXPR, op1, op2, needconvert);
511 return m2expr_FoldAndStrip (t);
512 }
513
514 /* createUniqueLabel returns a unique label which has been alloc'ed. */
515
516 static char *
517 createUniqueLabel (void)
518 {
519 int size, i;
520 char *label;
521
522 label_count++;
523 i = label_count;
524 size = strlen (".LSHIFT") + 2;
525 while (i > 0)
526 {
527 i /= 10;
528 size++;
529 }
530 label = (char *)ggc_alloc_atomic (size);
531 sprintf (label, ".LSHIFT%d", label_count);
532 return label;
533 }
534
535 /* BuildLogicalShift builds the ISO Modula-2 SHIFT operator for a
536 fundamental data type. */
537
538 void
539 m2expr_BuildLogicalShift (location_t location, tree op1, tree op2, tree op3,
540 tree nBits ATTRIBUTE_UNUSED, int needconvert)
541 {
542 tree res;
543
544 m2assert_AssertLocation (location);
545 op2 = m2expr_FoldAndStrip (op2);
546 op3 = m2expr_FoldAndStrip (op3);
547 if (TREE_CODE (op3) == INTEGER_CST)
548 {
549 op2 = m2convert_ToWord (location, op2);
550 if (tree_int_cst_sgn (op3) < 0)
551 res = m2expr_BuildLSR (
552 location, op2,
553 m2convert_ToWord (location,
554 m2expr_BuildNegate (location, op3, needconvert)),
555 needconvert);
556 else
557 res = m2expr_BuildLSL (location, op2, m2convert_ToWord (location, op3),
558 needconvert);
559 res = m2convert_BuildConvert (
560 location, m2tree_skip_type_decl (TREE_TYPE (op1)), res, FALSE);
561 m2statement_BuildAssignmentTree (location, op1, res);
562 }
563 else
564 {
565 char *labelElseName = createUniqueLabel ();
566 char *labelEndName = createUniqueLabel ();
567 tree is_less = m2expr_BuildLessThan (location,
568 m2convert_ToInteger (location, op3),
569 m2expr_GetIntegerZero (location));
570
571 m2statement_DoJump (location, is_less, NULL, labelElseName);
572 op2 = m2convert_ToWord (location, op2);
573 op3 = m2convert_ToWord (location, op3);
574 res = m2expr_BuildLSL (location, op2, op3, needconvert);
575 res = m2convert_BuildConvert (
576 location, m2tree_skip_type_decl (TREE_TYPE (op1)), res, FALSE);
577 m2statement_BuildAssignmentTree (location, op1, res);
578 m2statement_BuildGoto (location, labelEndName);
579 m2statement_DeclareLabel (location, labelElseName);
580 res = m2expr_BuildLSR (location, op2,
581 m2expr_BuildNegate (location, op3, needconvert),
582 needconvert);
583 res = m2convert_BuildConvert (
584 location, m2tree_skip_type_decl (TREE_TYPE (op1)), res, FALSE);
585 m2statement_BuildAssignmentTree (location, op1, res);
586 m2statement_DeclareLabel (location, labelEndName);
587 }
588 }
589
590 /* BuildLRL builds and returns tree (op1 rotate left by op2 bits). */
591
592 tree
593 m2expr_BuildLRL (location_t location, tree op1, tree op2, int needconvert)
594 {
595 tree t;
596
597 m2assert_AssertLocation (location);
598
599 op1 = m2expr_FoldAndStrip (op1);
600 op2 = m2expr_FoldAndStrip (op2);
601
602 t = m2expr_build_binary_op (location, LROTATE_EXPR, op1, op2, needconvert);
603 return m2expr_FoldAndStrip (t);
604 }
605
606 /* BuildLRR builds and returns tree (op1 rotate right by op2 bits). */
607
608 tree
609 m2expr_BuildLRR (location_t location, tree op1, tree op2, int needconvert)
610 {
611 tree t;
612
613 m2assert_AssertLocation (location);
614
615 op1 = m2expr_FoldAndStrip (op1);
616 op2 = m2expr_FoldAndStrip (op2);
617
618 t = m2expr_build_binary_op (location, RROTATE_EXPR, op1, op2, needconvert);
619 return m2expr_FoldAndStrip (t);
620 }
621
622 /* m2expr_BuildMask returns a tree for the mask of a set of nBits.
623 It assumes nBits is <= TSIZE (WORD). */
624
625 tree
626 m2expr_BuildMask (location_t location, tree nBits, int needconvert)
627 {
628 tree mask = m2expr_BuildLSL (location, m2expr_GetIntegerOne (location),
629 nBits, needconvert);
630 m2assert_AssertLocation (location);
631 return m2expr_BuildSub (location, mask, m2expr_GetIntegerOne (location),
632 needconvert);
633 }
634
635 /* m2expr_BuildLRotate returns a tree in which op1 has been left
636 rotated by nBits. It assumes nBits is <= TSIZE (WORD). */
637
638 tree
639 m2expr_BuildLRotate (location_t location, tree op1, tree nBits,
640 int needconvert)
641 {
642 tree t;
643
644 op1 = m2expr_FoldAndStrip (op1);
645 nBits = m2expr_FoldAndStrip (nBits);
646 t = m2expr_build_binary_op (location, LROTATE_EXPR, op1, nBits, needconvert);
647 return m2expr_FoldAndStrip (t);
648 }
649
650 /* m2expr_BuildRRotate returns a tree in which op1 has been left
651 rotated by nBits. It assumes nBits is <= TSIZE (WORD). */
652
653 tree
654 m2expr_BuildRRotate (location_t location, tree op1, tree nBits,
655 int needconvert)
656 {
657 tree t;
658
659 op1 = m2expr_FoldAndStrip (op1);
660 nBits = m2expr_FoldAndStrip (nBits);
661 t = m2expr_build_binary_op (location, RROTATE_EXPR, op1, nBits, needconvert);
662 return m2expr_FoldAndStrip (t);
663 }
664
665 /* BuildLRLn builds and returns tree (op1 rotate left by op2 bits) it
666 rotates a set of size, nBits. */
667
668 tree
669 m2expr_BuildLRLn (location_t location, tree op1, tree op2, tree nBits,
670 int needconvert)
671 {
672 tree op2min;
673
674 m2assert_AssertLocation (location);
675
676 /* Ensure we wrap the rotate. */
677
678 op2min = m2expr_BuildModTrunc (
679 location, m2convert_ToCardinal (location, op2),
680 m2convert_ToCardinal (location, nBits), needconvert);
681
682 /* Optimize if we are we going to rotate a TSIZE(BITSET) set. */
683
684 if (m2expr_CompareTrees (
685 m2decl_BuildIntegerConstant (m2decl_GetBitsPerBitset ()), nBits)
686 == 0)
687 return m2expr_BuildLRotate (location, op1, op2min, needconvert);
688 else
689 {
690 tree mask = m2expr_BuildMask (location, nBits, needconvert);
691 tree left, right;
692
693 /* Make absolutely sure there are no high order bits lying around. */
694
695 op1 = m2expr_BuildLogicalAnd (location, op1, mask, needconvert);
696 left = m2expr_BuildLSL (location, op1, op2min, needconvert);
697 left = m2expr_BuildLogicalAnd (location, left, mask, needconvert);
698 right = m2expr_BuildLSR (
699 location, op1,
700 m2expr_BuildSub (location, m2convert_ToCardinal (location, nBits),
701 op2min, needconvert),
702 needconvert);
703 return m2expr_BuildLogicalOr (location, left, right, needconvert);
704 }
705 }
706
707 /* BuildLRRn builds and returns tree (op1 rotate right by op2 bits).
708 It rotates a set of size, nBits. */
709
710 tree
711 m2expr_BuildLRRn (location_t location, tree op1, tree op2, tree nBits,
712 int needconvert)
713 {
714 tree op2min;
715
716 m2assert_AssertLocation (location);
717
718 /* Ensure we wrap the rotate. */
719
720 op2min = m2expr_BuildModTrunc (
721 location, m2convert_ToCardinal (location, op2),
722 m2convert_ToCardinal (location, nBits), needconvert);
723 /* Optimize if we are we going to rotate a TSIZE(BITSET) set. */
724
725 if (m2expr_CompareTrees (
726 m2decl_BuildIntegerConstant (m2decl_GetBitsPerBitset ()), nBits)
727 == 0)
728 return m2expr_BuildRRotate (location, op1, op2min, needconvert);
729 else
730 {
731 tree mask = m2expr_BuildMask (location, nBits, needconvert);
732 tree left, right;
733
734 /* Make absolutely sure there are no high order bits lying around. */
735
736 op1 = m2expr_BuildLogicalAnd (location, op1, mask, needconvert);
737 right = m2expr_BuildLSR (location, op1, op2min, needconvert);
738 left = m2expr_BuildLSL (
739 location, op1,
740 m2expr_BuildSub (location, m2convert_ToCardinal (location, nBits),
741 op2min, needconvert),
742 needconvert);
743 left = m2expr_BuildLogicalAnd (location, left, mask, needconvert);
744 return m2expr_BuildLogicalOr (location, left, right, needconvert);
745 }
746 }
747
748 /* BuildLogicalRotate build the ISO Modula-2 ROTATE operator for a
749 fundamental data type. */
750
751 void
752 m2expr_BuildLogicalRotate (location_t location, tree op1, tree op2, tree op3,
753 tree nBits, int needconvert)
754 {
755 tree res;
756
757 m2assert_AssertLocation (location);
758 op2 = m2expr_FoldAndStrip (op2);
759 op3 = m2expr_FoldAndStrip (op3);
760 if (TREE_CODE (op3) == INTEGER_CST)
761 {
762 if (tree_int_cst_sgn (op3) < 0)
763 res = m2expr_BuildLRRn (
764 location, op2, m2expr_BuildNegate (location, op3, needconvert),
765 nBits, needconvert);
766 else
767 res = m2expr_BuildLRLn (location, op2, op3, nBits, needconvert);
768 m2statement_BuildAssignmentTree (location, op1, res);
769 }
770 else
771 {
772 char *labelElseName = createUniqueLabel ();
773 char *labelEndName = createUniqueLabel ();
774 tree is_less = m2expr_BuildLessThan (location,
775 m2convert_ToInteger (location, op3),
776 m2expr_GetIntegerZero (location));
777
778 m2statement_DoJump (location, is_less, NULL, labelElseName);
779 res = m2expr_BuildLRLn (location, op2, op3, nBits, needconvert);
780 m2statement_BuildAssignmentTree (location, op1, res);
781 m2statement_BuildGoto (location, labelEndName);
782 m2statement_DeclareLabel (location, labelElseName);
783 res = m2expr_BuildLRRn (location, op2,
784 m2expr_BuildNegate (location, op3, needconvert),
785 nBits, needconvert);
786 m2statement_BuildAssignmentTree (location, op1, res);
787 m2statement_DeclareLabel (location, labelEndName);
788 }
789 }
790
791 /* buildUnboundedArrayOf construct an unbounded struct and returns
792 the gcc tree. The two fields of the structure are initialized to
793 contentsPtr and high. */
794
795 static tree
796 buildUnboundedArrayOf (tree unbounded, tree contentsPtr, tree high)
797 {
798 tree fields = TYPE_FIELDS (unbounded);
799 tree field_list = NULL_TREE;
800 tree constructor;
801
802 field_list = tree_cons (fields, contentsPtr, field_list);
803 fields = TREE_CHAIN (fields);
804
805 field_list = tree_cons (fields, high, field_list);
806
807 constructor = build_constructor_from_list (unbounded, nreverse (field_list));
808 TREE_CONSTANT (constructor) = 0;
809 TREE_STATIC (constructor) = 0;
810
811 return constructor;
812 }
813
814 /* BuildBinarySetDo if the size of the set is <= TSIZE(WORD) then op1
815 := binop(op2, op3) else call m2rtsprocedure(op1, op2, op3). */
816
817 void
818 m2expr_BuildBinarySetDo (location_t location, tree settype, tree op1, tree op2,
819 tree op3, void (*binop) (location_t, tree, tree, tree,
820 tree, int),
821 int is_op1lvalue, int is_op2lvalue, int is_op3lvalue,
822 tree nBits, tree unbounded, tree varproc,
823 tree leftproc, tree rightproc)
824 {
825 tree size = m2expr_GetSizeOf (location, settype);
826 int is_const = FALSE;
827 int is_left = FALSE;
828
829 m2assert_AssertLocation (location);
830
831 ASSERT_BOOL (is_op1lvalue);
832 ASSERT_BOOL (is_op2lvalue);
833 ASSERT_BOOL (is_op3lvalue);
834
835 if (m2expr_CompareTrees (
836 size, m2decl_BuildIntegerConstant (SET_WORD_SIZE / BITS_PER_UNIT))
837 <= 0)
838 /* Small set size <= TSIZE(WORD). */
839 (*binop) (location,
840 m2treelib_get_rvalue (location, op1, settype, is_op1lvalue),
841 m2treelib_get_rvalue (location, op2, settype, is_op2lvalue),
842 m2treelib_get_rvalue (location, op3, settype, is_op3lvalue),
843 nBits, FALSE);
844 else
845 {
846 tree result;
847 tree high = m2expr_BuildSub (
848 location,
849 m2convert_ToCardinal (
850 location,
851 m2expr_BuildDivTrunc (
852 location, size,
853 m2expr_GetSizeOf (location, m2type_GetBitsetType ()),
854 FALSE)),
855 m2expr_GetCardinalOne (location), FALSE);
856
857 /* If op3 is constant then make op3 positive and remember which
858 direction we are shifting. */
859
860 op3 = m2tree_skip_const_decl (op3);
861 if (TREE_CODE (op3) == INTEGER_CST)
862 {
863 is_const = TRUE;
864 if (tree_int_cst_sgn (op3) < 0)
865 op3 = m2expr_BuildNegate (location, op3, FALSE);
866 else
867 is_left = TRUE;
868 op3 = m2convert_BuildConvert (location, m2type_GetM2CardinalType (),
869 op3, FALSE);
870 }
871
872 /* These parameters must match the prototypes of the procedures:
873 ShiftLeft, ShiftRight, ShiftVal, RotateLeft, RotateRight, RotateVal
874 inside gm2-iso/SYSTEM.mod. */
875
876 /* Remember we must build the parameters in reverse. */
877
878 /* Parameter 4 amount. */
879 m2statement_BuildParam (
880 location,
881 m2convert_BuildConvert (
882 location, m2type_GetM2IntegerType (),
883 m2treelib_get_rvalue (location, op3,
884 m2tree_skip_type_decl (TREE_TYPE (op3)),
885 is_op3lvalue),
886 FALSE));
887
888 /* Parameter 3 nBits. */
889 m2statement_BuildParam (
890 location,
891 m2convert_BuildConvert (location, m2type_GetM2CardinalType (),
892 m2expr_FoldAndStrip (nBits), FALSE));
893
894 /* Parameter 2 destination set. */
895 m2statement_BuildParam (
896 location,
897 buildUnboundedArrayOf (
898 unbounded,
899 m2treelib_get_set_address (location, op1, is_op1lvalue), high));
900
901 /* Parameter 1 source set. */
902 m2statement_BuildParam (
903 location,
904 buildUnboundedArrayOf (
905 unbounded,
906 m2treelib_get_set_address (location, op2, is_op2lvalue), high));
907
908 /* Now call the appropriate procedure inside SYSTEM.mod. */
909 if (is_const)
910 if (is_left)
911 result = m2statement_BuildProcedureCallTree (location, leftproc,
912 NULL_TREE);
913 else
914 result = m2statement_BuildProcedureCallTree (location, rightproc,
915 NULL_TREE);
916 else
917 result = m2statement_BuildProcedureCallTree (location, varproc,
918 NULL_TREE);
919 add_stmt (location, result);
920 }
921 }
922
923 /* Print a warning if a constant expression had overflow in folding.
924 Invoke this function on every expression that the language requires
925 to be a constant expression. */
926
927 void
928 m2expr_ConstantExpressionWarning (tree value)
929 {
930 if ((TREE_CODE (value) == INTEGER_CST || TREE_CODE (value) == REAL_CST
931 || TREE_CODE (value) == FIXED_CST || TREE_CODE (value) == VECTOR_CST
932 || TREE_CODE (value) == COMPLEX_CST)
933 && TREE_OVERFLOW (value))
934 pedwarn (input_location, OPT_Woverflow, "overflow in constant expression");
935 }
936
937 /* TreeOverflow return TRUE if the contant expression, t, has caused
938 an overflow. No error message or warning is emitted and no
939 modification is made to, t. */
940
941 int
942 m2expr_TreeOverflow (tree t)
943 {
944 if ((TREE_CODE (t) == INTEGER_CST
945 || (TREE_CODE (t) == COMPLEX_CST
946 && TREE_CODE (TREE_REALPART (t)) == INTEGER_CST))
947 && TREE_OVERFLOW (t))
948 return TRUE;
949 else if ((TREE_CODE (t) == REAL_CST
950 || (TREE_CODE (t) == COMPLEX_CST
951 && TREE_CODE (TREE_REALPART (t)) == REAL_CST))
952 && TREE_OVERFLOW (t))
953 return TRUE;
954 else
955 return FALSE;
956 }
957
958 /* RemoveOverflow if tree, t, is a constant expression it removes any
959 overflow flag and returns, t. */
960
961 tree
962 m2expr_RemoveOverflow (tree t)
963 {
964 if (TREE_CODE (t) == INTEGER_CST
965 || (TREE_CODE (t) == COMPLEX_CST
966 && TREE_CODE (TREE_REALPART (t)) == INTEGER_CST))
967 TREE_OVERFLOW (t) = 0;
968 else if (TREE_CODE (t) == REAL_CST
969 || (TREE_CODE (t) == COMPLEX_CST
970 && TREE_CODE (TREE_REALPART (t)) == REAL_CST))
971 TREE_OVERFLOW (t) = 0;
972 return t;
973 }
974
975 /* BuildCoerce return a tree containing the expression, expr, after
976 it has been coersed to, type. */
977
978 tree
979 m2expr_BuildCoerce (location_t location, tree des, tree type, tree expr)
980 {
981 tree copy = copy_node (expr);
982 TREE_TYPE (copy) = type;
983
984 m2assert_AssertLocation (location);
985
986 return m2treelib_build_modify_expr (location, des, NOP_EXPR, copy);
987 }
988
989 /* BuildTrunc return an integer expression from a REAL or LONGREAL op1. */
990
991 tree
992 m2expr_BuildTrunc (tree op1)
993 {
994 return convert_to_integer (m2type_GetIntegerType (),
995 m2expr_FoldAndStrip (op1));
996 }
997
998 /* checkUnaryWholeOverflow decide if we can check this unary expression. */
999
1000 tree
1001 m2expr_checkUnaryWholeOverflow (location_t location, enum tree_code code,
1002 tree arg, tree lowest, tree min, tree max)
1003 {
1004 if (M2Options_GetWholeValueCheck () && (min != NULL))
1005 {
1006 lowest = m2tree_skip_type_decl (lowest);
1007 arg = fold_convert_loc (location, lowest, arg);
1008
1009 switch (code)
1010 {
1011 case NEGATE_EXPR:
1012 return checkWholeNegateOverflow (location, arg, lowest, min, max);
1013 default:
1014 return NULL;
1015 }
1016 }
1017 return NULL;
1018 }
1019
1020 /* build_unary_op return a unary tree node. */
1021
1022 tree
1023 m2expr_build_unary_op_check (location_t location, enum tree_code code,
1024 tree arg, tree lowest, tree min, tree max)
1025 {
1026 tree argtype = TREE_TYPE (arg);
1027 tree result;
1028 tree check = NULL;
1029
1030 m2assert_AssertLocation (location);
1031
1032 arg = m2expr_FoldAndStrip (arg);
1033
1034 if ((TREE_CODE (argtype) != REAL_TYPE) && (min != NULL))
1035 check = m2expr_checkUnaryWholeOverflow (location, code, arg, lowest, min, max);
1036
1037 result = build1 (code, argtype, arg);
1038 protected_set_expr_location (result, location);
1039
1040 if (check != NULL)
1041 result = build2 (COMPOUND_EXPR, argtype, check, result);
1042
1043 if (TREE_CODE (argtype) == REAL_TYPE)
1044 m2expr_checkRealOverflow (location, code, result);
1045
1046 return m2expr_FoldAndStrip (result);
1047 }
1048
1049 /* build_unary_op return a unary tree node. */
1050
1051 tree
1052 m2expr_build_unary_op (location_t location, enum tree_code code, tree arg,
1053 int flag ATTRIBUTE_UNUSED)
1054 {
1055 tree argtype = TREE_TYPE (arg);
1056 tree result;
1057
1058 m2assert_AssertLocation (location);
1059
1060 arg = m2expr_FoldAndStrip (arg);
1061 result = build1 (code, argtype, arg);
1062 protected_set_expr_location (result, location);
1063
1064 return m2expr_FoldAndStrip (result);
1065 }
1066
1067 /* build_binary_op is a heavily pruned version of the one found in
1068 c-typeck.cc. The Modula-2 expression rules are much more restricted
1069 than C. */
1070
1071 tree
1072 build_binary_op (location_t location, enum tree_code code, tree op1, tree op2,
1073 int convert ATTRIBUTE_UNUSED)
1074 {
1075 tree type1 = TREE_TYPE (op1);
1076 tree result;
1077
1078 m2assert_AssertLocation (location);
1079
1080 /* Strip NON_LVALUE_EXPRs, etc., since we aren't using as an lvalue. */
1081 STRIP_TYPE_NOPS (op1);
1082 STRIP_TYPE_NOPS (op2);
1083
1084 op1 = m2expr_FoldAndStrip (op1);
1085 op2 = m2expr_FoldAndStrip (op2);
1086
1087 result = build2 (code, type1, op1, op2);
1088 protected_set_expr_location (result, location);
1089
1090 return m2expr_FoldAndStrip (result);
1091 }
1092
1093 /* BuildLessThanZero - returns a tree containing (< value 0). It
1094 checks the min and max value to ensure that the test can be safely
1095 achieved and will short circuit the result otherwise. */
1096
1097 tree
1098 m2expr_BuildLessThanZero (location_t location, tree value, tree type, tree min,
1099 tree max)
1100 {
1101 if (m2expr_CompareTrees (min, m2expr_GetIntegerZero (location)) >= 0)
1102 /* min is greater than or equal to zero therefore value will always
1103 be >= 0. */
1104 return m2expr_GetIntegerZero (location);
1105 else if (m2expr_CompareTrees (max, m2expr_GetIntegerZero (location)) == -1)
1106 /* max is less than zero therefore value will always be < 0. */
1107 return m2expr_GetIntegerOne (location);
1108 /* We now know 0 lies in the range min..max so we can safely cast
1109 zero to type. */
1110 return m2expr_BuildLessThan (
1111 location, value,
1112 fold_convert_loc (location, type, m2expr_GetIntegerZero (location)));
1113 }
1114
1115 /* BuildGreaterThanZero - returns a tree containing (> value 0). It
1116 checks the min and max value to ensure that the test can be safely
1117 achieved and will short circuit the result otherwise. */
1118
1119 tree
1120 m2expr_BuildGreaterThanZero (location_t location, tree value, tree type,
1121 tree min, tree max)
1122 {
1123 if (m2expr_CompareTrees (min, m2expr_GetIntegerZero (location)) == 1)
1124 /* min is greater than zero therefore value will always be > 0. */
1125 return m2expr_GetIntegerOne (location);
1126 else if (m2expr_CompareTrees (max, m2expr_GetIntegerZero (location)) <= 0)
1127 /* max is less than or equal to zero therefore value will always be
1128 <= 0. */
1129 return m2expr_GetIntegerZero (location);
1130 /* We now know 0 lies in the range min..max so we can safely cast
1131 zero to type. */
1132 return m2expr_BuildGreaterThan (
1133 location, value,
1134 fold_convert_loc (location, type, m2expr_GetIntegerZero (location)));
1135 }
1136
1137 /* BuildEqualToZero - returns a tree containing (= value 0). It
1138 checks the min and max value to ensure that the test can be safely
1139 achieved and will short circuit the result otherwise. */
1140
1141 tree
1142 m2expr_BuildEqualToZero (location_t location, tree value, tree type, tree min,
1143 tree max)
1144 {
1145 if (m2expr_CompareTrees (min, m2expr_GetIntegerZero (location)) == 1)
1146 /* min is greater than zero therefore value will always be > 0. */
1147 return m2expr_GetIntegerZero (location);
1148 else if (m2expr_CompareTrees (max, m2expr_GetIntegerZero (location)) < 0)
1149 /* max is less than or equal to zero therefore value will always be <
1150 0. */
1151 return m2expr_GetIntegerZero (location);
1152 /* We now know 0 lies in the range min..max so we can safely cast
1153 zero to type. */
1154 return m2expr_BuildEqualTo (
1155 location, value,
1156 fold_convert_loc (location, type, m2expr_GetIntegerZero (location)));
1157 }
1158
1159 /* BuildNotEqualToZero - returns a tree containing (# value 0). It
1160 checks the min and max value to ensure that the test can be safely
1161 achieved and will short circuit the result otherwise. */
1162
1163 tree
1164 m2expr_BuildNotEqualToZero (location_t location, tree value, tree type,
1165 tree min, tree max)
1166 {
1167 if (m2expr_CompareTrees (min, m2expr_GetIntegerZero (location)) == 1)
1168 /* min is greater than zero therefore value will always be true. */
1169 return m2expr_GetIntegerOne (location);
1170 else if (m2expr_CompareTrees (max, m2expr_GetIntegerZero (location)) < 0)
1171 /* max is less than or equal to zero therefore value will always be
1172 true. */
1173 return m2expr_GetIntegerOne (location);
1174 /* We now know 0 lies in the range min..max so we can safely cast
1175 zero to type. */
1176 return m2expr_BuildNotEqualTo (
1177 location, value,
1178 fold_convert_loc (location, type, m2expr_GetIntegerZero (location)));
1179 }
1180
1181
1182 /* BuildGreaterThanOrEqualZero - returns a tree containing (>= value 0). It
1183 checks the min and max value to ensure that the test can be safely
1184 achieved and will short circuit the result otherwise. */
1185
1186 tree
1187 m2expr_BuildGreaterThanOrEqualZero (location_t location, tree value, tree type,
1188 tree min, tree max)
1189 {
1190 if (m2expr_CompareTrees (min, m2expr_GetIntegerZero (location)) >= 0)
1191 /* min is greater than or equal to zero therefore value will always be >= 0. */
1192 return m2expr_GetIntegerOne (location);
1193 else if (m2expr_CompareTrees (max, m2expr_GetIntegerZero (location)) < 0)
1194 /* max is less than zero therefore value will always be < 0. */
1195 return m2expr_GetIntegerZero (location);
1196 /* We now know 0 lies in the range min..max so we can safely cast
1197 zero to type. */
1198 return m2expr_BuildGreaterThan (
1199 location, value,
1200 fold_convert_loc (location, type, m2expr_GetIntegerZero (location)));
1201 }
1202
1203
1204 /* BuildLessThanOrEqualZero - returns a tree containing (<= value 0). It
1205 checks the min and max value to ensure that the test can be safely
1206 achieved and will short circuit the result otherwise. */
1207
1208 tree
1209 m2expr_BuildLessThanOrEqualZero (location_t location, tree value, tree type,
1210 tree min, tree max)
1211 {
1212 if (m2expr_CompareTrees (min, m2expr_GetIntegerZero (location)) > 0)
1213 /* min is greater than zero therefore value will always be > 0. */
1214 return m2expr_GetIntegerZero (location);
1215 else if (m2expr_CompareTrees (max, m2expr_GetIntegerZero (location)) <= 0)
1216 /* max is less than or equal to zero therefore value will always be <= 0. */
1217 return m2expr_GetIntegerOne (location);
1218 /* We now know 0 lies in the range min..max so we can safely cast
1219 zero to type. */
1220 return m2expr_BuildLessThanOrEqual (
1221 location, value,
1222 fold_convert_loc (location, type, m2expr_GetIntegerZero (location)));
1223 }
1224
1225
1226 /* get_current_function_name, return the name of the current function if
1227 it currently exists. NULL is returned if we are not inside a function. */
1228
1229 static const char *
1230 get_current_function_name (void)
1231 {
1232 if (current_function_decl != NULL
1233 && (DECL_NAME (current_function_decl) != NULL)
1234 && (IDENTIFIER_POINTER (DECL_NAME (current_function_decl)) != NULL))
1235 return IDENTIFIER_POINTER (DECL_NAME (current_function_decl));
1236 return NULL;
1237 }
1238
1239 /* checkWholeNegateOverflow - check to see whether -arg will overflow
1240 an integer.
1241
1242 PROCEDURE sneg (i: INTEGER) ;
1243 BEGIN
1244 IF i = MIN(INTEGER)
1245 THEN
1246 'integer overflow'
1247 END
1248 END sneg ;
1249
1250 general purpose subrange type, i, is currently legal, min is
1251 MIN(type) and max is MAX(type).
1252
1253 PROCEDURE sneg (i: type) ;
1254 BEGIN
1255 max := MAX (type) ;
1256 min := MIN (type) ;
1257 (* cannot overflow if i is 0 *)
1258 IF (i#0) AND
1259 (* will overflow if entire range is positive. *)
1260 ((min >= 0) OR
1261 (* will overflow if entire range is negative. *)
1262 (max <= 0) OR
1263 (* c7 and c8 and c9 and c10 -> c17 more units positive. *)
1264 ((min < 0) AND (max > 0) AND ((min + max) > 0) AND (i > -min)) OR
1265 (* c11 and c12 and c13 and c14 -> c18 more units negative. *)
1266 ((min < 0) AND (max > 0) AND ((min + max) < 0) AND (i < -max)))
1267 THEN
1268 'type overflow'
1269 END
1270 END sneg ; */
1271
1272 static tree
1273 checkWholeNegateOverflow (location_t location,
1274 tree i, tree type, tree min,
1275 tree max)
1276 {
1277 tree a1
1278 = m2expr_BuildNotEqualToZero (location, i, type, min, max); /* i # 0. */
1279 tree c1 = m2expr_BuildGreaterThanZero (location, min, type, min,
1280 max); /* min > 0. */
1281 tree c2 = m2expr_BuildEqualToZero (location, min, type, min,
1282 max); /* min == 0. */
1283 tree c4 = m2expr_BuildLessThanZero (location, max, type, min,
1284 max); /* max < 0. */
1285 tree c5 = m2expr_BuildEqualToZero (location, max, type, min,
1286 max); /* max == 0. */
1287 tree c7 = m2expr_BuildLessThanZero (location, min, type, min,
1288 max); /* min < 0. */
1289 tree c8 = m2expr_BuildGreaterThanZero (location, max, type, min,
1290 max); /* max > 0. */
1291 tree c9 = m2expr_BuildGreaterThanZero (
1292 location, m2expr_BuildAdd (location, min, max, FALSE), type, min,
1293 max); /* min + max > 0. */
1294 tree c10 = m2expr_BuildGreaterThan (
1295 location, i, m2expr_BuildNegate (location, min, FALSE)); /* i > -min. */
1296 tree c11 = m2expr_BuildLessThanZero (
1297 location, m2expr_BuildAdd (location, min, max, FALSE), type, min,
1298 max); /* min + max < 0. */
1299 tree c12 = m2expr_BuildLessThan (
1300 location, i, m2expr_BuildNegate (location, max, FALSE)); /* i < -max. */
1301
1302 tree b1 = m2expr_BuildTruthOrIf (location, c1, c2);
1303 tree b2 = m2expr_BuildTruthOrIf (location, c8, c5);
1304 tree o1 = m2expr_BuildTruthAndIf (location, b1, b2);
1305
1306 tree b3 = m2expr_BuildTruthOrIf (location, c7, c2);
1307 tree b4 = m2expr_BuildTruthOrIf (location, c4, c5);
1308 tree o2 = m2expr_BuildTruthAndIf (location, b3, b4);
1309
1310 tree o3 = m2expr_Build4TruthAndIf (location, c7, c8, c9, c10);
1311 tree o4 = m2expr_Build4TruthAndIf (location, c7, c8, c11, c12);
1312
1313 tree a2 = m2expr_Build4TruthOrIf (location, o1, o2, o3, o4);
1314 tree condition
1315 = m2expr_FoldAndStrip (m2expr_BuildTruthAndIf (location, a1, a2));
1316
1317 tree t = M2Range_BuildIfCallWholeHandlerLoc (location, condition,
1318 get_current_function_name (),
1319 "whole value unary minus will cause range overflow");
1320 return t;
1321 }
1322
1323 /* checkWholeAddOverflow - check to see whether op1 + op2 will
1324 overflow an integer.
1325
1326 PROCEDURE sadd (i, j: INTEGER) ;
1327 BEGIN
1328 IF ((j>0) AND (i > MAX(INTEGER)-j)) OR ((j<0) AND (i < MIN(INTEGER)-j))
1329 THEN
1330 'signed addition overflow'
1331 END
1332 END sadd. */
1333
1334 static tree
1335 checkWholeAddOverflow (location_t location, tree i, tree j, tree lowest,
1336 tree min, tree max)
1337 {
1338 tree j_gt_zero = m2expr_BuildGreaterThanZero (location, j, lowest, min, max);
1339 tree i_gt_max_sub_j = m2expr_BuildGreaterThan (
1340 location, i, m2expr_BuildSub (location, max, j, FALSE));
1341 tree j_lt_zero = m2expr_BuildLessThanZero (location, j, lowest, min, max);
1342 tree i_lt_min_sub_j = m2expr_BuildLessThan (location, i,
1343 m2expr_BuildSub (location, min, j, FALSE));
1344 tree lhs_or = m2expr_FoldAndStrip (m2expr_BuildTruthAndIf (location, j_gt_zero, i_gt_max_sub_j));
1345 tree rhs_or = m2expr_FoldAndStrip (m2expr_BuildTruthAndIf (location, j_lt_zero, i_lt_min_sub_j));
1346 tree condition
1347 = m2expr_FoldAndStrip (m2expr_BuildTruthOrIf (location, lhs_or, rhs_or));
1348 tree result = M2Range_BuildIfCallWholeHandlerLoc (location, condition,
1349 get_current_function_name (),
1350 "whole value addition will cause a range overflow");
1351 return result;
1352 }
1353
1354 /* checkWholeSubOverflow - check to see whether op1 - op2 will
1355 overflow an integer.
1356
1357 PROCEDURE ssub (i, j: INTEGER) ;
1358 BEGIN
1359 IF ((j>0) AND (i < MIN(INTEGER)+j)) OR ((j<0) AND (i > MAX(INTEGER)+j))
1360 THEN
1361 'signed subtraction overflow'
1362 END
1363 END ssub. */
1364
1365 static tree
1366 checkWholeSubOverflow (location_t location, tree i, tree j, tree lowest,
1367 tree min, tree max)
1368 {
1369 tree c1 = m2expr_BuildGreaterThanZero (location, j, lowest, min, max);
1370 tree c2 = m2expr_BuildLessThan (location, i,
1371 m2expr_BuildAdd (location, min, j, FALSE));
1372 tree c3 = m2expr_BuildLessThanZero (location, j, lowest, min, max);
1373 tree c4 = m2expr_BuildGreaterThan (location, i,
1374 m2expr_BuildAdd (location, max, j, FALSE));
1375 tree c5 = m2expr_FoldAndStrip (m2expr_BuildTruthAndIf (location, c1, c2));
1376 tree c6 = m2expr_FoldAndStrip (m2expr_BuildTruthAndIf (location, c3, c4));
1377 tree condition
1378 = m2expr_FoldAndStrip (m2expr_BuildTruthOrIf (location, c5, c6));
1379 tree t = M2Range_BuildIfCallWholeHandlerLoc (location, condition,
1380 get_current_function_name (),
1381 "whole value subtraction will cause a range overflow");
1382 return t;
1383 }
1384
1385 /* Build4TruthAndIf - return TRUE if a && b && c && d. Retain order left to
1386 * right. */
1387
1388 static tree
1389 m2expr_Build4TruthAndIf (location_t location, tree a, tree b, tree c, tree d)
1390 {
1391 tree t1 = m2expr_FoldAndStrip (m2expr_BuildTruthAndIf (location, a, b));
1392 tree t2 = m2expr_FoldAndStrip (m2expr_BuildTruthAndIf (location, t1, c));
1393 return m2expr_FoldAndStrip (m2expr_BuildTruthAndIf (location, t2, d));
1394 }
1395
1396 /* Build3TruthAndIf - return TRUE if a && b && c. Retain order left to right.
1397 */
1398
1399 static tree
1400 m2expr_Build3TruthAndIf (location_t location, tree op1, tree op2, tree op3)
1401 {
1402 tree t = m2expr_FoldAndStrip (m2expr_BuildTruthAndIf (location, op1, op2));
1403 return m2expr_FoldAndStrip (m2expr_BuildTruthAndIf (location, t, op3));
1404 }
1405
1406 /* Build3TruthOrIf - return TRUE if a || b || c. Retain order left to right.
1407 */
1408
1409 static tree
1410 m2expr_Build3TruthOrIf (location_t location, tree op1, tree op2, tree op3)
1411 {
1412 tree t = m2expr_FoldAndStrip (m2expr_BuildTruthOrIf (location, op1, op2));
1413 return m2expr_FoldAndStrip (m2expr_BuildTruthOrIf (location, t, op3));
1414 }
1415
1416 /* Build4TruthOrIf - return TRUE if op1 || op2 || op3 || op4. Retain order
1417 left to right. */
1418
1419 static tree
1420 m2expr_Build4TruthOrIf (location_t location, tree op1, tree op2, tree op3,
1421 tree op4)
1422 {
1423 tree t1 = m2expr_FoldAndStrip (m2expr_BuildTruthOrIf (location, op1, op2));
1424 tree t2 = m2expr_FoldAndStrip (m2expr_BuildTruthOrIf (location, t1, op3));
1425 return m2expr_FoldAndStrip (m2expr_BuildTruthOrIf (location, t2, op4));
1426 }
1427
1428 /* Build4LogicalOr - return TRUE if op1 || op2 || op3 || op4. */
1429
1430 static tree
1431 m2expr_Build4LogicalOr (location_t location, tree op1, tree op2, tree op3,
1432 tree op4)
1433 {
1434 tree t1 = m2expr_FoldAndStrip (
1435 m2expr_BuildLogicalOr (location, op1, op2, FALSE));
1436 tree t2
1437 = m2expr_FoldAndStrip (m2expr_BuildLogicalOr (location, t1, op3, FALSE));
1438 return m2expr_FoldAndStrip (
1439 m2expr_BuildLogicalOr (location, t2, op4, FALSE));
1440 }
1441
1442 /* checkWholeMultOverflow - check to see whether i * j will overflow
1443 an integer.
1444
1445 PROCEDURE smult (lhs, rhs: INTEGER) ;
1446 BEGIN
1447 IF ((lhs > 0) AND (rhs > 0) AND (lhs > max DIV rhs)) OR
1448 ((lhs > 0) AND (rhs < 0) AND (rhs < min DIV lhs)) OR
1449 ((lhs < 0) AND (rhs > 0) AND (lhs < min DIV rhs)) OR
1450 ((lhs < 0) AND (rhs < 0) AND (lhs < max DIV rhs))
1451 THEN
1452 error ('signed multiplication overflow')
1453 END
1454 END smult ;
1455
1456 if ((c1 && c3 && c4)
1457 || (c1 && c5 && c6)
1458 || (c2 && c3 && c7)
1459 || (c2 && c5 && c8))
1460 error ('signed subtraction overflow'). */
1461
1462 static tree
1463 testWholeMultOverflow (location_t location, tree lhs, tree rhs,
1464 tree lowest, tree min, tree max)
1465 {
1466 tree c1 = m2expr_BuildGreaterThanZero (location, lhs, lowest, min, max);
1467 tree c2 = m2expr_BuildLessThanZero (location, lhs, lowest, min, max);
1468
1469 tree c3 = m2expr_BuildGreaterThanZero (location, rhs, lowest, min, max);
1470 tree c4 = m2expr_BuildGreaterThan (
1471 location, lhs, m2expr_BuildDivTrunc (location, max, rhs, FALSE));
1472
1473 tree c5 = m2expr_BuildLessThanZero (location, rhs, lowest, min, max);
1474 tree c6 = m2expr_BuildLessThan (
1475 location, rhs, m2expr_BuildDivTrunc (location, min, lhs, FALSE));
1476 tree c7 = m2expr_BuildLessThan (
1477 location, lhs, m2expr_BuildDivTrunc (location, min, rhs, FALSE));
1478 tree c8 = m2expr_BuildLessThan (
1479 location, lhs, m2expr_BuildDivTrunc (location, max, rhs, FALSE));
1480
1481 tree c9 = m2expr_Build3TruthAndIf (location, c1, c3, c4);
1482 tree c10 = m2expr_Build3TruthAndIf (location, c1, c5, c6);
1483 tree c11 = m2expr_Build3TruthAndIf (location, c2, c3, c7);
1484 tree c12 = m2expr_Build3TruthAndIf (location, c2, c5, c8);
1485
1486 tree condition = m2expr_Build4LogicalOr (location, c9, c10, c11, c12);
1487 return condition;
1488 }
1489
1490
1491 static tree
1492 checkWholeMultOverflow (location_t location, tree i, tree j, tree lowest,
1493 tree min, tree max)
1494 {
1495 tree condition = testWholeMultOverflow (location, i, j, lowest, min, max);
1496 tree result = M2Range_BuildIfCallWholeHandlerLoc (location, condition,
1497 get_current_function_name (),
1498 "whole value multiplication will cause a range overflow");
1499 return result;
1500 }
1501
1502
1503 static tree
1504 divMinUnderflow (location_t location, tree value, tree lowest, tree min, tree max)
1505 {
1506 tree min2 = m2expr_BuildMult (location, min, min, FALSE);
1507 tree rhs = m2expr_BuildGreaterThanOrEqual (location, value, min2);
1508 tree lhs = testWholeMultOverflow (location, min, min, lowest, min, max);
1509 return m2expr_BuildTruthAndIf (location, lhs, rhs);
1510 }
1511
1512 /*
1513 divexpr - returns true if a DIV_TRUNC b will overflow.
1514 */
1515
1516 /* checkWholeDivOverflow - check to see whether i DIV_TRUNC j will overflow
1517 an integer. The Modula-2 implementation of the GCC trees follows:
1518
1519 PROCEDURE divtruncexpr (a, b: INTEGER) : BOOLEAN ;
1520 BEGIN
1521 (* Firstly catch division by 0. *)
1522 RETURN ((b = 0) OR
1523 (* Case 2 range is always negative. *)
1524 (* In which case a division will be illegal as result will be positive. *)
1525 (max < 0) OR
1526 (* Case 1 both min / max are positive, check for underflow. *)
1527 ((min >= 0) AND (max >= 0) AND (multMinOverflow (b) OR (a < b * min))) OR
1528 (* Case 1 both min / max are positive, check for overflow. *)
1529 ((min >= 0) AND (max >= 0) AND (divMinUnderflow (a) OR (b > a DIV min))) OR
1530 (* Case 3 mixed range, need to check underflow. *)
1531 ((min < 0) AND (max >= 0) AND (a < 0) AND (b < 0) AND (b >= a DIV min)) OR
1532 ((min < 0) AND (max >= 0) AND (a < 0) AND (b > 0) AND (b <= a DIV max)) OR
1533 ((min < 0) AND (max >= 0) AND (a >= 0) AND (b < 0) AND (a DIV b < min)))
1534 END divtruncexpr ;
1535
1536 s1 -> a DIV min
1537 s2 -> a DIV max
1538 s3 -> a DIV b
1539
1540 b4 -> (min >= 0) AND (max >= 0)
1541 b5 -> (min < 0) AND (max >= 0)
1542 a_lt_b_mult_min -> (a < b * min)
1543 b_mult_min_overflow -> testWholeMultOverflow (location, b, min, lowest, min, max)
1544 b6 -> (b_mult_min_overflow OR a_lt_b_mult_min)
1545 b_gt_s1 -> (b > s1)
1546 a_div_min_overflow -> divMinUnderflow (location, a, min, lowest, min, max)
1547 b7 -> (a_div_min_overflow OR b_gt_s1)
1548 b8 -> (a < 0)
1549 b9 -> (b < 0)
1550 b10 -> (b > 0)
1551 b11 -> (b >= s1)
1552 b12 -> (b <= s2)
1553 b13 -> (s3 < min)
1554 b14 -> a >= 0
1555
1556 c1 -> (b = 0)
1557 c2 -> (max < 0)
1558 c3 -> (b4 AND b6)
1559 c4 -> (b4 AND b7)
1560 c5 -> (b5 AND b8 AND b9 AND b11)
1561 c6 -> (b5 AND b8 AND b10 AND b12)
1562 c7 -> (b5 AND b14 AND b9 AND b13)
1563
1564 if (c1 || c2 || c3 || c4 || c5 || c6 || c7)
1565 error ('signed div trunc overflow'). */
1566
1567 static tree
1568 checkWholeDivTruncOverflow (location_t location, tree i, tree j, tree lowest,
1569 tree min, tree max)
1570 {
1571 tree b4a = m2expr_BuildGreaterThanOrEqualZero (location, min, lowest, min, max);
1572 tree b4b = m2expr_BuildGreaterThanOrEqualZero (location, max, lowest, min, max);
1573 tree b4 = m2expr_BuildTruthAndIf (location, b4a, b4b);
1574 tree b5a = m2expr_BuildLessThanZero (location, min, lowest, min, max);
1575 tree b5 = m2expr_BuildTruthAndIf (location, b5a, b4b);
1576 tree c1 = m2expr_BuildEqualToZero (location, j, lowest, min, max);
1577 tree c2 = m2expr_BuildLessThanZero (location, max, lowest, min, max);
1578 tree i_lt_j_mult_min = m2expr_BuildLessThan (location, i, m2expr_BuildMult (location, j, min, FALSE));
1579 tree j_mult_min_overflow = testWholeMultOverflow (location, j, min, lowest, min, max);
1580 tree b6 = m2expr_BuildTruthOrIf (location, j_mult_min_overflow, i_lt_j_mult_min);
1581 tree c3 = m2expr_BuildTruthAndIf (location, b4, b6);
1582 tree s1 = m2expr_BuildDivTrunc (location, i, min, FALSE);
1583 tree s2 = m2expr_BuildDivTrunc (location, i, max, FALSE);
1584 tree s3 = m2expr_BuildDivTrunc (location, i, j, FALSE);
1585
1586 tree j_gt_s1 = m2expr_BuildGreaterThan (location, j, s1);
1587 tree i_div_min_overflow = divMinUnderflow (location, i, lowest, min, max);
1588 tree b7 = m2expr_BuildTruthOrIf (location, i_div_min_overflow, j_gt_s1);
1589 tree c4 = m2expr_BuildTruthAndIf (location, b4, b7);
1590 tree b8 = m2expr_BuildLessThanZero (location, i, lowest, min, max);
1591 tree b9 = m2expr_BuildLessThanZero (location, j, lowest, min, max);
1592 tree b10 = m2expr_BuildGreaterThanZero (location, j, lowest, min, max);
1593 tree b11 = m2expr_BuildGreaterThanOrEqual (location, j, s1);
1594 tree b12 = m2expr_BuildLessThanOrEqual (location, j, s2);
1595 tree b13 = m2expr_BuildLessThan (location, s3, min);
1596 tree b14 = m2expr_BuildGreaterThanOrEqualZero (location, i, lowest, min, max);
1597 tree c5 = m2expr_Build4TruthAndIf (location, b5, b8, b9, b11);
1598 tree c6 = m2expr_Build4TruthAndIf (location, b5, b8, b10, b12);
1599 tree c7 = m2expr_Build4TruthAndIf (location, b5, b14, b9, b13);
1600 tree c8 = m2expr_Build4TruthOrIf (location, c1, c2, c3, c4);
1601 tree condition = m2expr_Build4TruthOrIf (location, c5, c6, c7, c8);
1602 tree t = M2Range_BuildIfCallWholeHandlerLoc (location, condition,
1603 get_current_function_name (),
1604 "whole value truncated division will cause a range overflow");
1605 return t;
1606 }
1607
1608 #if 0
1609 (*
1610 divexpr - returns true if a DIV_CEIL b will overflow.
1611 *)
1612
1613 (* checkWholeDivCeilOverflow - check to see whether i DIV_CEIL j will overflow
1614 an integer. *)
1615
1616 PROCEDURE divceilexpr (i, j: INTEGER) : BOOLEAN ;
1617 BEGIN
1618 RETURN ((j = 0) OR (* division by zero. *)
1619 (maxT < 0) OR (* both inputs are < 0 and max is < 0,
1620 therefore error. *)
1621 ((i # 0) AND (* first operand is legally zero,
1622 result is also legally zero. *)
1623 divCeilOverflowCases (i, j)))
1624 END divceilexpr ;
1625
1626
1627 (*
1628 divCeilOverflowCases - precondition: i, j are in range values.
1629 postcondition: TRUE is returned if i divceil will
1630 result in an overflow/underflow.
1631 *)
1632
1633 PROCEDURE divCeilOverflowCases (i, j: INTEGER) : BOOLEAN ;
1634 BEGIN
1635 RETURN (((i > 0) AND (j > 0) AND divCeilOverflowPosPos (i, j)) OR
1636 ((i < 0) AND (j < 0) AND divCeilOverflowNegNeg (i, j)) OR
1637 ((i > 0) AND (j < 0) AND divCeilOverflowPosNeg (i, j)) OR
1638 ((i < 0) AND (j > 0) AND divCeilOverflowNegPos (i, j)))
1639 END divCeilOverflowCases ;
1640
1641
1642 (*
1643 divCeilOverflowPosPos - precondition: i, j are legal and are both >= 0.
1644 postcondition: TRUE is returned if i divceil will
1645 result in an overflow/underflow.
1646 *)
1647
1648 PROCEDURE divCeilOverflowPosPos (i, j: INTEGER) : BOOLEAN ;
1649 BEGIN
1650 RETURN (((i MOD j = 0) AND (i < j * minT)) OR
1651 (((i MOD j # 0) AND (i < j * minT + 1))))
1652 END divCeilOverflowPosPos ;
1653
1654
1655 (*
1656 divCeilOverflowNegNeg - precondition: i, j are in range values and both < 0.
1657 postcondition: TRUE is returned if i divceil will
1658 result in an overflow/underflow.
1659 *)
1660
1661 PROCEDURE divCeilOverflowNegNeg (i, j: INTEGER) : BOOLEAN ;
1662 BEGIN
1663 RETURN ((maxT <= 0) OR (* signs will cause overflow. *)
1664 (* check for underflow. *)
1665 ((ABS (i) MOD ABS (j) = 0) AND (i >= j * minT)) OR
1666 ((ABS (i) MOD ABS (j) # 0) AND (i >= j * minT - 1)) OR
1667 (* check for overflow. *)
1668 (((ABS (i) MOD maxT) = 0) AND (ABS (i) DIV maxT > ABS (j))) OR
1669 (((ABS (i) MOD maxT) # 0) AND (ABS (i) DIV maxT > ABS (j) + 1)))
1670 END divCeilOverflowNegNeg ;
1671
1672
1673 (*
1674 divCeilOverflowNegPos - precondition: i, j are in range values. i < 0, j >= 0.
1675 postcondition: TRUE is returned if i divceil will
1676 result in an overflow/underflow.
1677 *)
1678
1679 PROCEDURE divCeilOverflowNegPos (i, j: INTEGER) : BOOLEAN ;
1680 BEGIN
1681 (* easier than might be initially expected. We know minT < 0 and maxT > 0.
1682 We know the result will be negative and therefore we only need to test
1683 against minT. *)
1684 RETURN (((ABS (i) MOD j = 0) AND (i < j * minT)) OR
1685 ((ABS (i) MOD j # 0) AND (i < j * minT - 1)))
1686 END divCeilOverflowNegPos ;
1687
1688
1689 (*
1690 divCeilOverflowPosNeg - precondition: i, j are in range values. i >= 0, j < 0.
1691 postcondition: TRUE is returned if i divceil will
1692 result in an overflow/underflow.
1693 *)
1694
1695 PROCEDURE divCeilOverflowPosNeg (i, j: INTEGER) : BOOLEAN ;
1696 BEGIN
1697 (* easier than might be initially expected. We know minT < 0 and maxT > 0.
1698 We know the result will be negative and therefore we only need to test
1699 against minT. *)
1700 RETURN (((i MOD ABS (j) = 0) AND (i > j * minT)) OR
1701 ((i MOD ABS (j) # 0) AND (i > j * minT - 1)))
1702 END divCeilOverflowPosNeg ;
1703 #endif
1704
1705 /* divCeilOverflowPosPos, precondition: lhs, rhs are legal and are both >= 0.
1706 Postcondition: TRUE is returned if lhs divceil rhs will result
1707 in an overflow/underflow.
1708
1709 A handbuilt expression of trees implementing:
1710
1711 RETURN (((lhs MOD rhs = 0) AND (min >= 0) AND (lhs < rhs * min)) OR (* check for underflow, no remainder. *)
1712 lhs_lt_rhs_mult_min
1713 (((lhs MOD rhs # 0) AND (lhs < rhs * min + 1)))) (* check for underflow with remainder. *)
1714 ((lhs > min) AND (lhs - 1 > rhs * min))
1715 lhs_gt_rhs_mult_min
1716
1717 a -> (lhs MOD rhs = 0) AND (lhs < rhs * min)
1718 b -> (lhs MOD rhs # 0) AND (lhs < rhs * min + 1)
1719 RETURN a OR b. */
1720
1721 static tree
1722 divCeilOverflowPosPos (location_t location, tree i, tree j, tree lowest,
1723 tree min, tree max)
1724 {
1725 tree i_mod_j = m2expr_BuildModTrunc (location, i, j, FALSE);
1726 tree i_mod_j_eq_zero = m2expr_BuildEqualToZero (location, i_mod_j, lowest, min, max);
1727 tree i_mod_j_ne_zero = m2expr_BuildNotEqualToZero (location, i_mod_j, lowest, min, max);
1728 tree j_min = m2expr_BuildMult (location, j, min, FALSE);
1729 tree j_min_1 = m2expr_BuildAdd (location, j_min, m2expr_GetIntegerOne (location), FALSE);
1730 tree i_lt_j_min = m2expr_BuildLessThan (location, i, j_min);
1731 tree i_lt_j_min_1 = m2expr_BuildLessThan (location, i, j_min_1);
1732 tree a = m2expr_BuildTruthAndIf (location, i_mod_j_eq_zero, i_lt_j_min);
1733 tree b = m2expr_BuildTruthAndIf (location, i_mod_j_ne_zero, i_lt_j_min_1);
1734 return m2expr_BuildTruthOrIf (location, a, b);
1735 }
1736
1737
1738 /* divCeilOverflowPosNeg precondition: i, j are in range values and i >=0, j < 0.
1739 Postcondition: TRUE is returned if i divceil j will result in an
1740 overflow/underflow.
1741
1742 A handbuilt expression of trees implementing:
1743
1744 RETURN (((i MOD ABS (j) = 0) AND (i > j * min)) OR
1745 ((i MOD ABS (j) # 0) AND (i > j * min - 1)))
1746
1747 abs_j -> (ABS (j))
1748 i_mod_abs_j -> (i MOD abs_j)
1749 i_mod_abs_j_eq_0 -> (i_mod_abs_j = 0)
1750 i_mod_abs_j_ne_0 -> (i_mod_abs_j # 0)
1751 j_mult_min -> (j * min)
1752 j_mult_min_1 -> (j_mult_min - 1)
1753 i_gt_j_mult_min -> (i > j_mult_min)
1754 i_gt_j_mult_min_1 -> (i > j_mult_min_1)
1755 a -> (i_mod_abs_j_eq_0 AND i_gt_j_mult_min)
1756 b -> (i_mod_abs_j_ne_0 AND i_gt_j_mult_min_1)
1757 c -> (a OR b). */
1758
1759 static tree
1760 divCeilOverflowPosNeg (location_t location, tree i, tree j, tree lowest, tree min, tree max)
1761 {
1762 tree abs_j = m2expr_BuildAbs (location, j);
1763 tree i_mod_abs_j = m2expr_BuildModFloor (location, i, abs_j, FALSE);
1764 tree i_mod_abs_j_eq_0 = m2expr_BuildEqualToZero (location, i_mod_abs_j, lowest, min, max);
1765 tree i_mod_abs_j_ne_0 = m2expr_BuildNotEqualToZero (location, i_mod_abs_j, lowest, min, max);
1766 tree j_mult_min = m2expr_BuildMult (location, j, min, FALSE);
1767 tree j_mult_min_1 = m2expr_BuildPostDec (location, j_mult_min);
1768 tree i_gt_j_mult_min = m2expr_BuildGreaterThan (location, i, j_mult_min);
1769 tree i_gt_j_mult_min_1 = m2expr_BuildGreaterThan (location, i, j_mult_min_1);
1770 tree a = m2expr_BuildTruthAndIf (location, i_mod_abs_j_eq_0, i_gt_j_mult_min);
1771 tree b = m2expr_BuildTruthAndIf (location, i_mod_abs_j_ne_0, i_gt_j_mult_min_1);
1772 tree c = m2expr_BuildTruthOrIf (location, a, b);
1773 return c;
1774 }
1775
1776
1777 /* divCeilOverflowNegPos precondition: i, j are in range values and i < 0, j >= 0.
1778 Postcondition: TRUE is returned if i divceil j will result in an
1779 overflow/underflow.
1780
1781 A handbuilt expression of trees implementing:
1782
1783 RETURN (((ABS (i) MOD j = 0) AND (i < j * min)) OR
1784 ((ABS (i) MOD j # 0) AND (i < j * min - 1)))
1785
1786 abs_i -> (ABS (i))
1787 abs_i_mod_j -> (abs_i MOD j)
1788 abs_i_mod_j_eq_0 -> (abs_i_mod_j = 0)
1789 abs_i_mod_j_ne_0 -> (abs_i_mod_j # 0)
1790 j_mult_min -> (j * min)
1791 j_mult_min_1 -> (j_mult_min - 1)
1792 i_lt_j_mult_min -> (i < j_mult_min)
1793 i_lt_j_mult_min_1 -> (i < j_mult_min_1)
1794 a = (abs_i_mod_j_eq_0 AND i_lt_j_mult_min)
1795 b = (abs_i_mod_j_ne_0 AND i_lt_j_mult_min_1)
1796 c -> (a OR b). */
1797
1798 static tree
1799 divCeilOverflowNegPos (location_t location, tree i, tree j, tree lowest, tree min, tree max)
1800 {
1801 tree abs_i = m2expr_BuildAbs (location, i);
1802 tree abs_i_mod_j = m2expr_BuildModFloor (location, abs_i, j, FALSE);
1803 tree abs_i_mod_j_eq_0 = m2expr_BuildEqualToZero (location, abs_i_mod_j, lowest, min, max);
1804 tree abs_i_mod_j_ne_0 = m2expr_BuildNotEqualToZero (location, abs_i_mod_j, lowest, min, max);
1805 tree j_mult_min = m2expr_BuildMult (location, j, min, FALSE);
1806 tree j_mult_min_1 = m2expr_BuildPostDec (location, j_mult_min);
1807 tree i_lt_j_mult_min = m2expr_BuildLessThan (location, i, j_mult_min);
1808 tree i_lt_j_mult_min_1 = m2expr_BuildLessThan (location, i, j_mult_min_1);
1809 tree a = m2expr_BuildTruthAndIf (location, abs_i_mod_j_eq_0, i_lt_j_mult_min);
1810 tree b = m2expr_BuildTruthAndIf (location, abs_i_mod_j_ne_0, i_lt_j_mult_min_1);
1811 tree c = m2expr_BuildTruthOrIf (location, a, b);
1812 return c;
1813 }
1814
1815
1816 /* divCeilOverflowNegNeg precondition: i, j are in range values and both < 0.
1817 Postcondition: TRUE is returned if i divceil j will result in an
1818 overflow/underflow.
1819
1820 A handbuilt expression of trees implementing:
1821
1822 RETURN ((max <= 0) OR (* signs will cause overflow. *)
1823 (* check for underflow. *)
1824 ((ABS (i) MOD ABS (j) = 0) AND (i >= j * min)) OR
1825 ((ABS (i) MOD ABS (j) # 0) AND (i >= j * min - 1)) OR
1826 (* check for overflow. *)
1827 (((ABS (i) MOD max) = 0) AND (ABS (i) DIV max > ABS (j))) OR
1828 (((ABS (i) MOD max) # 0) AND (ABS (i) DIV max > ABS (j) + 1)))
1829
1830 max_lte_0 -> (max <= 0)
1831 abs_i -> (ABS (i))
1832 abs_j -> (ABS (j))
1833 abs_i_mod_abs_j -> (abs_i MOD abs_j)
1834 abs_i_mod_abs_j_eq_0 -> (abs_i_mod_abs_j = 0)
1835 abs_i_mod_abs_j_ne_0 -> (abs_i_mod_abs_j # 0)
1836 j_mult_min -> (j * min)
1837 j_mult_min_1 -> (j_mult_min - 1)
1838 i_ge_j_mult_min -> (i >= j_mult_min)
1839 i_ge_j_mult_min_1 -> (i >= j_mult_min_1)
1840 abs_i_mod_max -> (abs_i mod max)
1841 abs_i_div_max -> (abs_i DIVfloor max)
1842 abs_j_1 -> (abs_j + 1)
1843 abs_i_mod_max_eq_0 -> (abs_i_mod_max = 0)
1844 abs_i_mod_max_ne_0 -> (abs_i_mod_max # 0)
1845 abs_i_div_max_gt_abs_j -> (abs_i_div_max > abs_j)
1846 abs_i_div_max_gt_abs_j_1 -> (abs_i_div_max > abs_j_1)
1847
1848 a -> (abs_i_mod_abs_j_eq_0 AND i_ge_j_mult_min)
1849 b -> (abs_i_mod_abs_j_ne_0 AND i_ge_j_mult_min_1)
1850 c -> (abs_i_mod_max_eq_0 AND abs_i_div_max_gt_abs_j)
1851 d -> (abs_i_mod_max_ne_0 AND abs_i_div_max_gt_abs_j_1)
1852 e -> (a OR b OR c OR d)
1853 return max_lte_0 OR e. */
1854
1855 static tree
1856 divCeilOverflowNegNeg (location_t location, tree i, tree j, tree lowest,
1857 tree min, tree max)
1858 {
1859 tree max_lte_0 = m2expr_BuildLessThanOrEqualZero (location, max, lowest, min, max);
1860 tree abs_i = m2expr_BuildAbs (location, i);
1861 tree abs_j = m2expr_BuildAbs (location, j);
1862 tree abs_i_mod_abs_j = m2expr_BuildModFloor (location, abs_i, abs_j, FALSE);
1863 tree abs_i_mod_abs_j_eq_0 = m2expr_BuildEqualToZero (location, abs_i_mod_abs_j,
1864 lowest, min, max);
1865 tree abs_i_mod_abs_j_ne_0 = m2expr_BuildNotEqualToZero (location, abs_i_mod_abs_j,
1866 lowest, min, max);
1867 tree j_mult_min = m2expr_BuildMult (location, j, min, FALSE);
1868 tree j_mult_min_1 = m2expr_BuildPostDec (location, j_mult_min);
1869 tree i_ge_j_mult_min = m2expr_BuildGreaterThanOrEqual (location, i, j_mult_min);
1870 tree i_ge_j_mult_min_1 = m2expr_BuildGreaterThanOrEqual (location, i, j_mult_min_1);
1871 tree abs_i_mod_max = m2expr_BuildModFloor (location, abs_i, max, FALSE);
1872 tree abs_i_div_max = m2expr_BuildDivFloor (location, abs_i, max, FALSE);
1873 tree abs_j_1 = m2expr_BuildPostInc (location, abs_j);
1874 tree abs_i_mod_max_eq_0 = m2expr_BuildEqualToZero (location, abs_i_mod_max, lowest, min, max);
1875 tree abs_i_mod_max_ne_0 = m2expr_BuildNotEqualToZero (location, abs_i_mod_max, lowest, min, max);
1876 tree abs_i_div_max_gt_abs_j = m2expr_BuildGreaterThan (location, abs_i_div_max, abs_j);
1877 tree abs_i_div_max_gt_abs_j_1 = m2expr_BuildGreaterThan (location, abs_i_div_max, abs_j_1);
1878
1879 tree a = m2expr_BuildTruthAndIf (location, abs_i_mod_abs_j_eq_0, i_ge_j_mult_min);
1880 tree b = m2expr_BuildTruthAndIf (location, abs_i_mod_abs_j_ne_0, i_ge_j_mult_min_1);
1881 tree c = m2expr_BuildTruthAndIf (location, abs_i_mod_max_eq_0, abs_i_div_max_gt_abs_j);
1882 tree d = m2expr_BuildTruthAndIf (location, abs_i_mod_max_ne_0, abs_i_div_max_gt_abs_j_1);
1883 tree e = m2expr_Build4TruthOrIf (location, a, b, c, d);
1884 return m2expr_BuildTruthOrIf (location, max_lte_0, e);
1885 }
1886
1887
1888 /* divCeilOverflowCases, precondition: i, j are in range values.
1889 Postcondition: TRUE is returned if i divceil will result in an
1890 overflow/underflow.
1891
1892 A handbuilt expression of trees implementing:
1893
1894 RETURN (((i > 0) AND (j > 0) AND divCeilOverflowPosPos (i, j)) OR
1895 ((i < 0) AND (j < 0) AND divCeilOverflowNegNeg (i, j)) OR
1896 ((i > 0) AND (j < 0) AND divCeilOverflowPosNeg (i, j)) OR
1897 ((i < 0) AND (j > 0) AND divCeilOverflowNegPos (i, j)))
1898
1899 a -> ((i > 0) AND (j > 0) AND divCeilOverflowPosPos (i, j))
1900 b -> ((i < 0) AND (j < 0) AND divCeilOverflowNegNeg (i, j))
1901 c -> ((i > 0) AND (j < 0) AND divCeilOverflowPosNeg (i, j))
1902 d -> ((i < 0) AND (j > 0) AND divCeilOverflowNegPos (i, j))
1903
1904 RETURN a AND b AND c AND d. */
1905
1906 static tree
1907 divCeilOverflowCases (location_t location, tree i, tree j, tree lowest,
1908 tree min, tree max)
1909 {
1910 tree i_gt_zero = m2expr_BuildGreaterThanZero (location, i, lowest, min, max);
1911 tree j_gt_zero = m2expr_BuildGreaterThanZero (location, j, lowest, min, max);
1912 tree i_lt_zero = m2expr_BuildLessThanZero (location, i, lowest, min, max);
1913 tree j_lt_zero = m2expr_BuildLessThanZero (location, j, lowest, min, max);
1914 tree a = m2expr_Build3TruthAndIf (location, i_gt_zero, j_gt_zero,
1915 divCeilOverflowPosPos (location, i, j, lowest, min, max));
1916 tree b = m2expr_Build3TruthAndIf (location, i_lt_zero, j_lt_zero,
1917 divCeilOverflowNegNeg (location, i, j, lowest, min, max));
1918 tree c = m2expr_Build3TruthAndIf (location, i_gt_zero, j_lt_zero,
1919 divCeilOverflowPosNeg (location, i, j, lowest, min, max));
1920 tree d = m2expr_Build3TruthAndIf (location, i_lt_zero, j_gt_zero,
1921 divCeilOverflowNegPos (location, i, j, lowest, min, max));
1922 return m2expr_Build4TruthOrIf (location, a, b, c, d);
1923 }
1924
1925
1926 /* checkWholeDivCeilOverflow check to see whether i DIV_CEIL j will overflow
1927 an integer. A handbuilt expression of trees implementing:
1928
1929 RETURN ((j = 0) OR (* division by zero. *)
1930 (maxT < 0) OR (* both inputs are < 0 and max is < 0,
1931 therefore error. *)
1932 ((i # 0) AND (* first operand is legally zero,
1933 result is also legally zero. *)
1934 divCeilOverflowCases (i, j)))
1935
1936 using the following subexpressions:
1937
1938 j_eq_zero -> (j == 0)
1939 max_lt_zero -> (max < 0)
1940 i_ne_zero -> (i # 0). */
1941
1942 static tree
1943 checkWholeDivCeilOverflow (location_t location, tree i, tree j, tree lowest,
1944 tree min, tree max)
1945 {
1946 tree j_eq_zero = m2expr_BuildEqualToZero (location, j, lowest, min, max);
1947 tree max_lt_zero = m2expr_BuildLessThanZero (location, max, lowest, min, max);
1948 tree i_ne_zero = m2expr_BuildNotEqualToZero (location, i, lowest, min, max);
1949 tree j_lt_zero;
1950 tree rhs = m2expr_BuildTruthAndIf (location,
1951 i_ne_zero,
1952 divCeilOverflowCases (location,
1953 i, j, lowest, min, max));
1954
1955 if (M2Options_GetISO ())
1956 j_lt_zero = m2expr_FoldAndStrip (m2expr_BuildLessThanZero (location, j, lowest, min, max));
1957 else
1958 j_lt_zero = m2expr_GetIntegerZero (location);
1959 j_eq_zero = m2expr_FoldAndStrip (j_eq_zero);
1960 max_lt_zero = m2expr_FoldAndStrip (max_lt_zero);
1961 i_ne_zero = m2expr_FoldAndStrip (i_ne_zero);
1962 rhs = m2expr_FoldAndStrip (rhs);
1963
1964 tree condition = m2expr_Build4TruthOrIf (location, j_eq_zero, max_lt_zero, rhs, j_lt_zero);
1965 tree t = M2Range_BuildIfCallWholeHandlerLoc (location, condition,
1966 get_current_function_name (),
1967 "whole value ceil division will cause a range overflow");
1968 return t;
1969 }
1970
1971
1972 /* checkWholeModTruncOverflow, the GCC tree.def defines TRUNC_MOD_EXPR to return
1973 the remainder which has the same sign as the dividend. In ISO Modula-2 the
1974 divisor must never be negative (or zero). The pseudo code for implementing these
1975 checks is given below:
1976
1977 IF j = 0
1978 THEN
1979 RETURN TRUE (* division by zero. *)
1980 ELSIF j < 0
1981 THEN
1982 RETURN TRUE (* modulus and division by negative (rhs) not allowed in ISO Modula-2. *)
1983 ELSIF i = 0
1984 THEN
1985 RETURN FALSE (* must be legal as result is same as operand. *)
1986 ELSIF i > 0
1987 THEN
1988 (* test for: i MOD j < minT *)
1989 IF j > i
1990 THEN
1991 RETURN FALSE
1992 END ;
1993 RETURN i - ((i DIV j) * j) < minT
1994 ELSIF i < 0
1995 THEN
1996 (* the result will always be positive and less than i, given that j is less than zero
1997 we know that minT must be < 0 as well and therefore the result of i MOD j will
1998 never underflow. *)
1999 RETURN FALSE
2000 END ;
2001 RETURN FALSE
2002
2003 which can be converted into a large expression:
2004
2005 RETURN (j = 0) OR ((j < 0) AND ISO) OR
2006 ((i # 0) AND (j <= i) AND (i - ((i DIVtrunc j) * j) < minT)
2007
2008 and into GCC trees:
2009
2010 c1 -> (j = 0)
2011 c2 -> (j < 0) (* only called from ISO or PIM4 or -fpositive-mod-floor *)
2012 c3 -> (i # 0)
2013 c4 -> (j <= i)
2014 c6 -> (i DIVtrunc j)
2015 c7 -> (i - (c6 * j))
2016 c5 -> c7 < minT
2017
2018 t -> (c1 OR c2 OR
2019 (c3 AND c4 AND c5)). */
2020
2021 static tree
2022 checkWholeModTruncOverflow (location_t location, tree i, tree j, tree lowest,
2023 tree min, tree max)
2024 {
2025 tree c1 = m2expr_BuildEqualToZero (location, j, lowest, min, max);
2026 tree c2 = m2expr_BuildLessThanZero (location, j, lowest, min, max);
2027 tree c3 = m2expr_BuildNotEqualToZero (location, i, lowest, min, max);
2028 tree c4 = m2expr_BuildLessThanOrEqual (location, j, i);
2029 tree c6 = m2expr_BuildDivTrunc (location, i, j, FALSE);
2030 tree c7 = m2expr_BuildSub (location, i, m2expr_BuildMult (location, c6, j, FALSE), FALSE);
2031 tree c5 = m2expr_BuildLessThan (location, c7, min);
2032 tree c8 = m2expr_Build3TruthAndIf (location, c3, c4, c5);
2033 tree condition = m2expr_Build3TruthOrIf (location, c1, c2, c8);
2034 tree t = M2Range_BuildIfCallWholeHandlerLoc (location, condition,
2035 get_current_function_name (),
2036 "whole value trunc modulus will cause a range overflow");
2037 return t;
2038 }
2039
2040
2041 /* checkWholeModCeilOverflow, the GCC tree.def defines CEIL_MOD_EXPR to return
2042 the remainder which has the same opposite of the divisor. In gm2 this is
2043 only called when the divisor is negative. The pseudo code for implementing
2044 these checks is given below:
2045
2046 IF j = 0
2047 THEN
2048 RETURN TRUE (* division by zero. *)
2049 END ;
2050 t := i - j * divceil (i, j) ;
2051 printf ("t = %d, i = %d, j = %d, %d / %d = %d\n",
2052 t, i, j, i, j, divceil (i, j));
2053 RETURN NOT ((t >= minT) AND (t <= maxT))
2054
2055 which can be converted into the expression:
2056
2057 t := i - j * divceil (i, j) ;
2058 RETURN (j = 0) OR (NOT ((t >= minT) AND (t <= maxT)))
2059
2060 and into GCC trees:
2061
2062 c1 -> (j = 0)
2063 c2 -> (i - j)
2064 c3 -> (i DIVceil j)
2065 t -> (c2 * c3)
2066 c4 -> (t >= minT)
2067 c5 -> (t <= maxT)
2068 c6 -> (c4 AND c5)
2069 c7 -> (NOT c6)
2070 c8 -> (c1 OR c7)
2071 return c8. */
2072
2073 static tree
2074 checkWholeModCeilOverflow (location_t location,
2075 tree i, tree j, tree lowest,
2076 tree min, tree max)
2077 {
2078 tree c1 = m2expr_BuildEqualToZero (location, j, lowest, min, max);
2079 tree c2 = m2expr_BuildSub (location, i, j, FALSE);
2080 tree c3 = m2expr_BuildDivCeil (location, i, j, FALSE);
2081 tree t = m2expr_BuildMult (location, c2, c3, FALSE);
2082 tree c4 = m2expr_BuildGreaterThanOrEqual (location, t, min);
2083 tree c5 = m2expr_BuildLessThanOrEqual (location, t, max);
2084 tree c6 = m2expr_BuildTruthAndIf (location, c4, c5);
2085 tree c7 = m2expr_BuildTruthNot (location, c6);
2086 tree condition = m2expr_BuildTruthOrIf (location, c1, c7);
2087 tree s = M2Range_BuildIfCallWholeHandlerLoc (location, condition,
2088 get_current_function_name (),
2089 "whole value ceil modulus will cause a range overflow");
2090 return s;
2091 }
2092
2093
2094 /* checkWholeModFloorOverflow, the GCC tree.def defines FLOOR_MOD_EXPR to return
2095 the remainder which has the same sign as the divisor. In gm2 this is
2096 only called when the divisor is positive. The pseudo code for implementing
2097 these checks is given below:
2098
2099 IF j = 0
2100 THEN
2101 RETURN TRUE (* division by zero. *)
2102 END ;
2103 t := i - j * divfloor (i, j) ;
2104 printf ("t = %d, i = %d, j = %d, %d / %d = %d\n",
2105 t, i, j, i, j, divfloor (i, j));
2106 RETURN NOT ((t >= minT) AND (t <= maxT))
2107
2108 which can be converted into the expression:
2109
2110 t := i - j * divfloor (i, j) ;
2111 RETURN (j = 0) OR (NOT ((t >= minT) AND (t <= maxT)))
2112
2113 and into GCC trees:
2114
2115 c1 -> (j = 0)
2116 c2 -> (i - j)
2117 c3 -> (i DIVfloor j)
2118 t -> (c2 * c3)
2119 c4 -> (t >= minT)
2120 c5 -> (t <= maxT)
2121 c6 -> (c4 AND c5)
2122 c7 -> (NOT c6)
2123 c8 -> (c1 OR c7)
2124 return c8. */
2125
2126 static tree
2127 checkWholeModFloorOverflow (location_t location,
2128 tree i, tree j, tree lowest,
2129 tree min, tree max)
2130 {
2131 tree c1 = m2expr_BuildEqualToZero (location, j, lowest, min, max);
2132 tree c2 = m2expr_BuildSub (location, i, j, FALSE);
2133 tree c3 = m2expr_BuildDivFloor (location, i, j, FALSE);
2134 tree t = m2expr_BuildMult (location, c2, c3, FALSE);
2135 tree c4 = m2expr_BuildGreaterThanOrEqual (location, t, min);
2136 tree c5 = m2expr_BuildLessThanOrEqual (location, t, max);
2137 tree c6 = m2expr_BuildTruthAndIf (location, c4, c5);
2138 tree c7 = m2expr_BuildTruthNot (location, c6);
2139 tree condition = m2expr_BuildTruthOrIf (location, c1, c7);
2140 tree s = M2Range_BuildIfCallWholeHandlerLoc (location, condition,
2141 get_current_function_name (),
2142 "whole value floor modulus will cause a range overflow");
2143 return s;
2144 }
2145
2146
2147 #if 0
2148 /* The following is a Modula-2 implementation of the C tree node code
2149 this code has been hand translated into GCC trees. */
2150
2151 (*
2152 divFloorOverflow2 - returns TRUE if an overflow will occur
2153 if i divfloor j is performed.
2154 *)
2155
2156 PROCEDURE divFloorOverflow (i, j: INTEGER) : BOOLEAN ;
2157 BEGIN
2158 RETURN ((j = 0) OR (* division by zero. *)
2159 (maxT < 0) OR (* both inputs are < 0 and max is < 0,
2160 therefore error. *)
2161 (* --fixme-- remember here to also check
2162 if ISO M2 dialect and j < 0
2163 which will also generate an error. *)
2164 ((i # 0) AND (* first operand is legally zero,
2165 result is also legally zero. *)
2166 divFloorOverflowCases (i, j)))
2167 END divFloorOverflow ;
2168
2169
2170 (*
2171 divFloorOverflowCases - precondition: i, j are in range values.
2172 postcondition: TRUE is returned if i divfloor will
2173 result in an overflow/underflow.
2174 *)
2175
2176 PROCEDURE divFloorOverflowCases (i, j: INTEGER) : BOOLEAN ;
2177 BEGIN
2178 RETURN (((i > 0) AND (j > 0) AND divFloorOverflowPosPos (i, j)) OR
2179 ((i < 0) AND (j < 0) AND divFloorOverflowNegNeg (i, j)) OR
2180 ((i > 0) AND (j < 0) AND divFloorOverflowPosNeg (i, j)) OR
2181 ((i < 0) AND (j > 0) AND divFloorOverflowNegPos (i, j)))
2182 END divFloorOverflowCases ;
2183
2184
2185 (*
2186 divFloorOverflowPosPos - precondition: lhs, rhs are legal and are both >= 0.
2187 postcondition: TRUE is returned if lhs divfloor rhs will
2188 result in an overflow/underflow.
2189 *)
2190
2191 PROCEDURE divFloorOverflowPosPos (lhs, rhs: INTEGER) : BOOLEAN ;
2192 BEGIN
2193 RETURN multMinOverflow (rhs) OR (lhs < rhs * min)
2194 END divFloorOverflowPosPos ;
2195
2196
2197 (*
2198 divFloorOverflowNegNeg - precondition: i, j are in range values and both < 0.
2199 postcondition: TRUE is returned if i divfloor will
2200 result in an overflow/underflow.
2201 *)
2202
2203 PROCEDURE divFloorOverflowNegNeg (i, j: INTEGER) : BOOLEAN ;
2204 BEGIN
2205 RETURN ((maxT <= 0) OR (* signs will cause overflow. *)
2206 (* check for underflow. *)
2207 (i >= j * minT) OR
2208 (* check for overflow. *)
2209 (ABS (i) DIV maxT > ABS (j)))
2210 END divFloorOverflowNegNeg ;
2211
2212
2213 (*
2214 divFloorOverflowNegPos - precondition: i, j are in range values. i < 0, j >= 0.
2215 postcondition: TRUE is returned if i divfloor will
2216 result in an overflow/underflow.
2217 *)
2218
2219 PROCEDURE divFloorOverflowNegPos (i, j: INTEGER) : BOOLEAN ;
2220 BEGIN
2221 (* easier than might be initially expected. We know minT < 0 and maxT > 0.
2222 We know the result will be negative and therefore we only need to test
2223 against minT. *)
2224 RETURN i < j * minT
2225 END divFloorOverflowNegPos ;
2226
2227
2228 (*
2229 divFloorOverflowPosNeg - precondition: i, j are in range values. i >= 0, j < 0.
2230 postcondition: TRUE is returned if i divfloor will
2231 result in an overflow/underflow.
2232 *)
2233
2234 PROCEDURE divFloorOverflowPosNeg (i, j: INTEGER) : BOOLEAN ;
2235 BEGIN
2236 (* easier than might be initially expected. We know minT < 0 and maxT > 0.
2237 We know the result will be negative and therefore we only need to test
2238 against minT. *)
2239 RETURN i >= j * minT - j (* is safer than i > j * minT -1 *)
2240 END divFloorOverflowPosNeg ;
2241 #endif
2242
2243
2244 /* divFloorOverflowPosPos, precondition: i, j are legal and are both >= 0.
2245 Postcondition: TRUE is returned if i divfloor will result in an overflow/underflow.
2246
2247 A handbuilt expression of trees implementing:
2248
2249 RETURN i < j * min
2250
2251 j_mult_min -> (j * min)
2252 RETURN i < j_mult_min. */
2253
2254 static tree
2255 divFloorOverflowPosPos (location_t location, tree i, tree j, tree min)
2256 {
2257 tree j_mult_min = m2expr_BuildMult (location, j, min, FALSE);
2258 tree i_lt_j_mult_min = m2expr_BuildLessThan (location, i, j_mult_min);
2259 return i_lt_j_mult_min;
2260 }
2261
2262
2263 /* divFloorOverflowNegNeg precondition: i, j are in range values and both < 0.
2264 Postcondition: TRUE is returned if i divfloor j will result in an
2265 overflow/underflow.
2266
2267 A handbuilt expression of trees implementing:
2268
2269 RETURN ((maxT <= 0) OR (* signs will cause overflow. *)
2270 (* check for underflow. *)
2271 (i >= j * min) OR
2272 (* check for overflow. *)
2273 (ABS (i) DIV max > ABS (j)))
2274
2275 max_lte_0 -> (max <= 0)
2276 abs_i -> (ABS (i))
2277 abs_j -> (ABS (j))
2278 j_mult_min -> (j * min)
2279 i_ge_j_mult_min -> (i >= j_mult_min)
2280 abs_i_div_max -> (abs_i divfloor max)
2281 abs_i_div_max_gt_abs_j -> (abs_i_div_max > abs_j)
2282
2283 return max_lte_0 OR
2284 i_ge_j_mult_min OR
2285 abs_i_div_max_gt_abs_j. */
2286
2287 static tree
2288 divFloorOverflowNegNeg (location_t location, tree i, tree j, tree lowest,
2289 tree min, tree max)
2290 {
2291 tree max_lte_0 = m2expr_BuildLessThanOrEqualZero (location, max, lowest, min, max);
2292 tree abs_i = m2expr_BuildAbs (location, i);
2293 tree abs_j = m2expr_BuildAbs (location, j);
2294 tree j_mult_min = m2expr_BuildMult (location, j, min, FALSE);
2295 tree i_ge_j_mult_min = m2expr_BuildGreaterThanOrEqual (location, i, j_mult_min);
2296 tree abs_i_div_max = m2expr_BuildDivFloor (location, abs_i, max, FALSE);
2297 tree abs_i_div_max_gt_abs_j = m2expr_BuildGreaterThan (location, abs_i_div_max, abs_j);
2298
2299 return m2expr_Build3TruthOrIf (location, max_lte_0, i_ge_j_mult_min, abs_i_div_max_gt_abs_j);
2300 }
2301
2302
2303 /* divFloorOverflowPosNeg precondition: i, j are in range values and i >=0, j < 0.
2304 Postcondition: TRUE is returned if i divfloor j will result in an
2305 overflow/underflow.
2306
2307 A handbuilt expression of trees implementing:
2308
2309 RETURN i >= j * min - j (* is safer than i > j * min -1 *)
2310
2311 j_mult_min -> (j * min)
2312 j_mult_min_sub_j -> (j_mult_min - j)
2313 i_ge_j_mult_min_sub_j -> (i >= j_mult_min_sub_j)
2314
2315 return i_ge_j_mult_min_sub_j. */
2316
2317 static tree
2318 divFloorOverflowPosNeg (location_t location, tree i, tree j, tree min)
2319 {
2320 tree j_mult_min = m2expr_BuildMult (location, j, min, FALSE);
2321 tree j_mult_min_sub_j = m2expr_BuildSub (location, j_mult_min, j, FALSE);
2322 tree i_ge_j_mult_min_sub_j = m2expr_BuildGreaterThanOrEqual (location, i, j_mult_min_sub_j);
2323 return i_ge_j_mult_min_sub_j;
2324 }
2325
2326
2327 /* divFloorOverflowNegPos precondition: i, j are in range values and i < 0, j > 0.
2328 Postcondition: TRUE is returned if i divfloor j will result in an
2329 overflow/underflow.
2330
2331 A handbuilt expression of trees implementing:
2332
2333 RETURN i < j * min
2334
2335 j_mult_min -> (j * min)
2336 RETURN i < j_mult_min. */
2337
2338 static tree
2339 divFloorOverflowNegPos (location_t location, tree i, tree j, tree min)
2340 {
2341 tree j_mult_min = m2expr_BuildMult (location, j, min, FALSE);
2342 tree i_lt_j_mult_min = m2expr_BuildLessThan (location, i, j_mult_min);
2343 return i_lt_j_mult_min;
2344 }
2345
2346
2347 /* divFloorOverflowCases, precondition: i, j are in range values.
2348 Postcondition: TRUE is returned if i divfloor will result in an
2349 overflow/underflow.
2350
2351 A handbuilt expression of trees implementing:
2352
2353 RETURN (((i > 0) AND (j > 0) AND divFloorOverflowPosPos (i, j)) OR
2354 ((i < 0) AND (j < 0) AND divFloorOverflowNegNeg (i, j)) OR
2355 ((i > 0) AND (j < 0) AND divFloorOverflowPosNeg (i, j)) OR
2356 ((i < 0) AND (j > 0) AND divFloorOverflowNegPos (i, j)))
2357
2358 a -> ((i > 0) AND (j > 0) AND divFloorOverflowPosPos (i, j))
2359 b -> ((i < 0) AND (j < 0) AND divFloorOverflowNegNeg (i, j))
2360 c -> ((i > 0) AND (j < 0) AND divFloorOverflowPosNeg (i, j))
2361 d -> ((i < 0) AND (j > 0) AND divFloorOverflowNegPos (i, j))
2362
2363 RETURN a AND b AND c AND d. */
2364
2365 static tree
2366 divFloorOverflowCases (location_t location, tree i, tree j, tree lowest,
2367 tree min, tree max)
2368 {
2369 tree i_gt_zero = m2expr_BuildGreaterThanZero (location, i, lowest, min, max);
2370 tree j_gt_zero = m2expr_BuildGreaterThanZero (location, j, lowest, min, max);
2371 tree i_lt_zero = m2expr_BuildLessThanZero (location, i, lowest, min, max);
2372 tree j_lt_zero = m2expr_BuildLessThanZero (location, j, lowest, min, max);
2373 tree a = m2expr_Build3TruthAndIf (location, i_gt_zero, j_gt_zero,
2374 divFloorOverflowPosPos (location, i, j, min));
2375 tree b = m2expr_Build3TruthAndIf (location, i_lt_zero, j_lt_zero,
2376 divFloorOverflowNegNeg (location, i, j, lowest, min, max));
2377 tree c = m2expr_Build3TruthAndIf (location, i_gt_zero, j_lt_zero,
2378 divFloorOverflowPosNeg (location, i, j, min));
2379 tree d = m2expr_Build3TruthAndIf (location, i_lt_zero, j_gt_zero,
2380 divFloorOverflowNegPos (location, i, j, min));
2381 return m2expr_Build4TruthOrIf (location, a, b, c, d);
2382 }
2383
2384
2385 /* checkWholeDivFloorOverflow check to see whether i DIV_FLOOR j will overflow
2386 an integer. A handbuilt expression of trees implementing:
2387
2388 RETURN ((j = 0) OR (* division by zero. *)
2389 (maxT < 0) OR (* both inputs are < 0 and max is < 0,
2390 therefore error. *)
2391 (* we also check
2392 if ISO M2 dialect and j < 0
2393 which will also generate an error. *)
2394 ((i # 0) AND (* first operand is legally zero,
2395 result is also legally zero. *)
2396 divFloorOverflowCases (i, j)))
2397
2398 using the following subexpressions:
2399
2400 j_eq_zero -> (j == 0)
2401 max_lt_zero -> (max < 0)
2402 i_ne_zero -> (i # 0). */
2403
2404 static tree
2405 checkWholeDivFloorOverflow (location_t location, tree i, tree j, tree lowest,
2406 tree min, tree max)
2407 {
2408 tree j_eq_zero = m2expr_BuildEqualToZero (location, j, lowest, min, max);
2409 tree max_lt_zero = m2expr_BuildLessThanZero (location, max, lowest, min, max);
2410 tree i_ne_zero = m2expr_BuildNotEqualToZero (location, i, lowest, min, max);
2411 tree j_lt_zero;
2412 tree rhs = m2expr_BuildTruthAndIf (location,
2413 i_ne_zero,
2414 divFloorOverflowCases (location,
2415 i, j, lowest, min, max));
2416
2417 if (M2Options_GetISO ())
2418 /* ISO Modula-2 raises an exception if the right hand operand is < 0. */
2419 j_lt_zero = m2expr_FoldAndStrip (m2expr_BuildLessThanZero (location, j, lowest, min, max));
2420 else
2421 j_lt_zero = m2expr_GetIntegerZero (location);
2422 j_eq_zero = m2expr_FoldAndStrip (j_eq_zero);
2423 max_lt_zero = m2expr_FoldAndStrip (max_lt_zero);
2424 i_ne_zero = m2expr_FoldAndStrip (i_ne_zero);
2425 rhs = m2expr_FoldAndStrip (rhs);
2426
2427 tree condition = m2expr_Build4TruthOrIf (location, j_eq_zero, max_lt_zero, rhs, j_lt_zero);
2428 tree t = M2Range_BuildIfCallWholeHandlerLoc (location, condition,
2429 get_current_function_name (),
2430 "whole value floor division will cause a range overflow");
2431 return t;
2432 }
2433
2434 /* checkWholeOverflow check to see if the binary operators will overflow
2435 ordinal types. */
2436
2437 static tree
2438 m2expr_checkWholeOverflow (location_t location, enum tree_code code, tree op1,
2439 tree op2, tree lowest, tree min, tree max)
2440 {
2441 if (M2Options_GetWholeValueCheck () && (min != NULL))
2442 {
2443 lowest = m2tree_skip_type_decl (lowest);
2444 op1 = fold_convert_loc (location, lowest, op1);
2445 op2 = fold_convert_loc (location, lowest, op2);
2446
2447 switch (code)
2448 {
2449 case PLUS_EXPR:
2450 return checkWholeAddOverflow (location, op1, op2, lowest, min, max);
2451 case MINUS_EXPR:
2452 return checkWholeSubOverflow (location, op1, op2, lowest, min, max);
2453 case MULT_EXPR:
2454 return checkWholeMultOverflow (location, op1, op2, lowest, min, max);
2455 case TRUNC_DIV_EXPR:
2456 return checkWholeDivTruncOverflow (location, op1, op2, lowest, min, max);
2457 case CEIL_DIV_EXPR:
2458 return checkWholeDivCeilOverflow (location, op1, op2, lowest, min, max);
2459 case FLOOR_DIV_EXPR:
2460 return checkWholeDivFloorOverflow (location, op1, op2, lowest, min, max);
2461 case TRUNC_MOD_EXPR:
2462 return checkWholeModTruncOverflow (location, op1, op2, lowest, min, max);
2463 case CEIL_MOD_EXPR:
2464 return checkWholeModCeilOverflow (location, op1, op2, lowest, min, max);
2465 case FLOOR_MOD_EXPR:
2466 return checkWholeModFloorOverflow (location, op1, op2, lowest, min, max);
2467 default:
2468 return NULL;
2469 }
2470 }
2471 return NULL;
2472 }
2473
2474 /* checkRealOverflow if we have enabled real value checking then
2475 generate an overflow check appropriate to the tree code being used. */
2476
2477 static void
2478 m2expr_checkRealOverflow (location_t location, enum tree_code code,
2479 tree result)
2480 {
2481 if (M2Options_GetFloatValueCheck ())
2482 {
2483 tree condition = m2expr_BuildEqualTo (
2484 location, m2builtins_BuiltInIsfinite (location, result),
2485 m2expr_GetIntegerZero (location));
2486 switch (code)
2487 {
2488 case PLUS_EXPR:
2489 m2type_AddStatement (location,
2490 M2Range_BuildIfCallRealHandlerLoc (
2491 location, condition,
2492 get_current_function_name (),
2493 "floating point + has caused an overflow"));
2494 break;
2495 case MINUS_EXPR:
2496 m2type_AddStatement (location,
2497 M2Range_BuildIfCallRealHandlerLoc (
2498 location, condition,
2499 get_current_function_name (),
2500 "floating point - has caused an overflow"));
2501 break;
2502 case RDIV_EXPR:
2503 case FLOOR_DIV_EXPR:
2504 case CEIL_DIV_EXPR:
2505 case TRUNC_DIV_EXPR:
2506 m2type_AddStatement (location,
2507 M2Range_BuildIfCallRealHandlerLoc (
2508 location, condition,
2509 get_current_function_name (),
2510 "floating point / has caused an overflow"));
2511 break;
2512 case MULT_EXPR:
2513 m2type_AddStatement (location,
2514 M2Range_BuildIfCallRealHandlerLoc (
2515 location, condition,
2516 get_current_function_name (),
2517 "floating point * has caused an overflow"));
2518 break;
2519 case NEGATE_EXPR:
2520 m2type_AddStatement (
2521 location, M2Range_BuildIfCallRealHandlerLoc (
2522 location, condition,
2523 get_current_function_name (),
2524 "floating point unary - has caused an overflow"));
2525 default:
2526 break;
2527 }
2528 }
2529 }
2530
2531 /* build_binary_op, a wrapper for the lower level build_binary_op
2532 above. */
2533
2534 tree
2535 m2expr_build_binary_op_check (location_t location, enum tree_code code,
2536 tree op1, tree op2, int needconvert, tree lowest,
2537 tree min, tree max)
2538 {
2539 tree type1, type2, result;
2540 tree check = NULL;
2541
2542 op1 = m2expr_FoldAndStrip (op1);
2543 op2 = m2expr_FoldAndStrip (op2);
2544
2545 type1 = m2tree_skip_type_decl (TREE_TYPE (op1));
2546 type2 = m2tree_skip_type_decl (TREE_TYPE (op2));
2547
2548 m2assert_AssertLocation (location);
2549
2550 if (code == PLUS_EXPR)
2551 {
2552 if (POINTER_TYPE_P (type1))
2553 {
2554 op2 = fold_convert_loc (location, sizetype, unshare_expr (op2));
2555 return fold_build2_loc (location, POINTER_PLUS_EXPR, TREE_TYPE (op1),
2556 op1, op2);
2557 }
2558 else if (POINTER_TYPE_P (type2))
2559 {
2560 op1 = fold_convert_loc (location, sizetype, unshare_expr (op1));
2561 return fold_build2_loc (location, POINTER_PLUS_EXPR, TREE_TYPE (op2),
2562 op2, op1);
2563 }
2564 }
2565 if (code == MINUS_EXPR)
2566 {
2567 if (POINTER_TYPE_P (type1))
2568 {
2569 op2 = fold_convert_loc (location, sizetype, unshare_expr (op2));
2570 op2 = fold_build1_loc (location, NEGATE_EXPR, sizetype, op2);
2571 return fold_build2_loc (location, POINTER_PLUS_EXPR, TREE_TYPE (op1),
2572 op1, op2);
2573 }
2574 else if (POINTER_TYPE_P (type2))
2575 {
2576 op2 = fold_convert_loc (location, sizetype, unshare_expr (op2));
2577 op2 = fold_build1_loc (location, NEGATE_EXPR, sizetype, op2);
2578 op1 = fold_convert_loc (location, sizetype, unshare_expr (op1));
2579 return fold_build2_loc (location, POINTER_PLUS_EXPR, TREE_TYPE (op2),
2580 op2, op1);
2581 }
2582 }
2583
2584 if ((code != LSHIFT_EXPR) && (code != RSHIFT_EXPR) && (code != LROTATE_EXPR)
2585 && (code == RROTATE_EXPR))
2586 if (type1 != type2)
2587 error_at (location, "not expecting different types to binary operator");
2588
2589 if ((TREE_CODE (type1) != REAL_TYPE) && (min != NULL))
2590 check = m2expr_checkWholeOverflow (location, code, op1, op2, lowest, min, max);
2591
2592 result = build_binary_op (location, code, op1, op2, needconvert);
2593 if (check != NULL)
2594 result = build2 (COMPOUND_EXPR, TREE_TYPE (result), check, result);
2595
2596 if (TREE_CODE (type1) == REAL_TYPE)
2597 m2expr_checkRealOverflow (location, code, result);
2598 return result;
2599 }
2600
2601 /* build_binary_op, a wrapper for the lower level build_binary_op
2602 above. */
2603
2604 tree
2605 m2expr_build_binary_op (location_t location, enum tree_code code, tree op1,
2606 tree op2, int convert)
2607 {
2608 return m2expr_build_binary_op_check (location, code, op1, op2, convert, NULL,
2609 NULL, NULL);
2610 }
2611
2612 /* BuildAddAddress return an expression op1+op2 where op1 is a
2613 pointer type and op2 is not a pointer type. */
2614
2615 tree
2616 m2expr_BuildAddAddress (location_t location, tree op1, tree op2)
2617 {
2618 tree type1, type2;
2619
2620 op1 = m2expr_FoldAndStrip (op1);
2621 op2 = m2expr_FoldAndStrip (op2);
2622
2623 type1 = m2tree_skip_type_decl (TREE_TYPE (op1));
2624 type2 = m2tree_skip_type_decl (TREE_TYPE (op2));
2625
2626 m2assert_AssertLocation (location);
2627 ASSERT_CONDITION (POINTER_TYPE_P (type1));
2628 ASSERT_CONDITION (!POINTER_TYPE_P (type2));
2629
2630 op2 = fold_convert_loc (location, sizetype, unshare_expr (op2));
2631 return fold_build2_loc (location, POINTER_PLUS_EXPR, TREE_TYPE (op1),
2632 m2expr_FoldAndStrip (op1),
2633 m2expr_FoldAndStrip (op2));
2634 }
2635
2636 /* BuildNegateCheck builds a negate tree. */
2637
2638 tree
2639 m2expr_BuildNegateCheck (location_t location, tree arg, tree lowest, tree min,
2640 tree max)
2641 {
2642 tree t;
2643
2644 m2assert_AssertLocation (location);
2645
2646 arg = m2expr_FoldAndStrip (arg);
2647 arg = CheckAddressToCardinal (location, arg);
2648
2649 t = m2expr_build_unary_op_check (location, NEGATE_EXPR, arg, lowest, min,
2650 max);
2651 return m2expr_FoldAndStrip (t);
2652 }
2653
2654 /* BuildNegate build a negate expression and returns the tree. */
2655
2656 tree
2657 m2expr_BuildNegate (location_t location, tree op1, int needconvert)
2658 {
2659 m2assert_AssertLocation (location);
2660 op1 = m2expr_FoldAndStrip (op1);
2661 op1 = CheckAddressToCardinal (location, op1);
2662
2663 return m2expr_build_unary_op (location, NEGATE_EXPR, op1, needconvert);
2664 }
2665
2666 /* BuildSetNegate build a set negate expression and returns the tree. */
2667
2668 tree
2669 m2expr_BuildSetNegate (location_t location, tree op1, int needconvert)
2670 {
2671 m2assert_AssertLocation (location);
2672
2673 return m2expr_build_binary_op (
2674 location, BIT_XOR_EXPR,
2675 m2convert_BuildConvert (location, m2type_GetWordType (),
2676 m2expr_FoldAndStrip (op1), FALSE),
2677 set_full_complement, needconvert);
2678 }
2679
2680 /* BuildMult build a multiplication tree. */
2681
2682 tree
2683 m2expr_BuildMult (location_t location, tree op1, tree op2, int needconvert)
2684 {
2685 op1 = m2expr_FoldAndStrip (op1);
2686 op2 = m2expr_FoldAndStrip (op2);
2687
2688 m2assert_AssertLocation (location);
2689
2690 op1 = CheckAddressToCardinal (location, op1);
2691 op2 = CheckAddressToCardinal (location, op2);
2692
2693 return m2expr_build_binary_op (location, MULT_EXPR, op1, op2, needconvert);
2694 }
2695
2696 /* BuildMultCheck builds a multiplication tree. */
2697
2698 tree
2699 m2expr_BuildMultCheck (location_t location, tree op1, tree op2, tree lowest,
2700 tree min, tree max)
2701 {
2702 tree t;
2703
2704 m2assert_AssertLocation (location);
2705
2706 op1 = m2expr_FoldAndStrip (op1);
2707 op2 = m2expr_FoldAndStrip (op2);
2708
2709 op1 = CheckAddressToCardinal (location, op1);
2710 op2 = CheckAddressToCardinal (location, op2);
2711
2712 t = m2expr_build_binary_op_check (location, MULT_EXPR, op1, op2, FALSE,
2713 lowest, min, max);
2714 return m2expr_FoldAndStrip (t);
2715 }
2716
2717 /* testLimits return the number of bits required to represent:
2718 min..max if it matches the, type. Otherwise NULL_TREE is returned. */
2719
2720 static tree
2721 testLimits (location_t location, tree type, tree min, tree max)
2722 {
2723 m2assert_AssertLocation (location);
2724
2725 if ((m2expr_CompareTrees (TYPE_MAX_VALUE (type), max) == 0)
2726 && (m2expr_CompareTrees (TYPE_MIN_VALUE (type), min) == 0))
2727 return m2expr_BuildMult (location, m2expr_GetSizeOf (location, type),
2728 m2decl_BuildIntegerConstant (BITS_PER_UNIT),
2729 FALSE);
2730 return NULL_TREE;
2731 }
2732
2733 /* noBitsRequired return the number of bits required to contain, values. */
2734
2735 static tree
2736 noBitsRequired (tree values)
2737 {
2738 int bits = tree_floor_log2 (values);
2739
2740 if (integer_pow2p (values))
2741 return m2decl_BuildIntegerConstant (bits + 1);
2742 else
2743 return m2decl_BuildIntegerConstant (bits + 1);
2744 }
2745
2746 /* getMax return the result of max(a, b). */
2747
2748 static tree
2749 getMax (tree a, tree b)
2750 {
2751 if (m2expr_CompareTrees (a, b) > 0)
2752 return a;
2753 else
2754 return b;
2755 }
2756
2757 /* calcNbits return the smallest number of bits required to
2758 represent: min..max. */
2759
2760 static tree
2761 calcNbits (location_t location, tree min, tree max)
2762 {
2763 int negative = FALSE;
2764 tree t = testLimits (location, m2type_GetIntegerType (), min, max);
2765
2766 m2assert_AssertLocation (location);
2767
2768 if (t == NULL)
2769 t = testLimits (location, m2type_GetCardinalType (), min, max);
2770
2771 if (t == NULL)
2772 {
2773 if (m2expr_CompareTrees (min, m2expr_GetIntegerZero (location)) < 0)
2774 {
2775 min = m2expr_BuildAdd (location, min,
2776 m2expr_GetIntegerOne (location), FALSE);
2777 min = fold (m2expr_BuildNegate (location, min, FALSE));
2778 negative = TRUE;
2779 }
2780 if (m2expr_CompareTrees (max, m2expr_GetIntegerZero (location)) < 0)
2781 {
2782 max = fold (m2expr_BuildNegate (location, max, FALSE));
2783 negative = TRUE;
2784 }
2785 t = noBitsRequired (getMax (min, max));
2786 if (negative)
2787 t = m2expr_BuildAdd (location, t, m2expr_GetIntegerOne (location),
2788 FALSE);
2789 }
2790 return t;
2791 }
2792
2793 /* BuildTBitSize return the minimum number of bits to represent, type. */
2794
2795 tree
2796 m2expr_BuildTBitSize (location_t location, tree type)
2797 {
2798 enum tree_code code = TREE_CODE (type);
2799 tree min;
2800 tree max;
2801 m2assert_AssertLocation (location);
2802
2803 switch (code)
2804 {
2805
2806 case TYPE_DECL:
2807 return m2expr_BuildTBitSize (location, TREE_TYPE (type));
2808 case INTEGER_TYPE:
2809 case ENUMERAL_TYPE:
2810 max = m2convert_BuildConvert (location, m2type_GetIntegerType (),
2811 TYPE_MAX_VALUE (type), FALSE);
2812 min = m2convert_BuildConvert (location, m2type_GetIntegerType (),
2813 TYPE_MIN_VALUE (type), FALSE);
2814 return calcNbits (location, min, max);
2815 case BOOLEAN_TYPE:
2816 return m2expr_GetIntegerOne (location);
2817 default:
2818 return m2expr_BuildMult (location, m2expr_GetSizeOf (location, type),
2819 m2decl_BuildIntegerConstant (BITS_PER_UNIT),
2820 FALSE);
2821 }
2822 }
2823
2824 /* BuildSize build a SIZE function expression and returns the tree. */
2825
2826 tree
2827 m2expr_BuildSize (location_t location, tree op1,
2828 int needconvert ATTRIBUTE_UNUSED)
2829 {
2830 m2assert_AssertLocation (location);
2831 return m2expr_GetSizeOf (location, op1);
2832 }
2833
2834 /* BuildAddr return an expression which calculates the address of op1
2835 and returns the tree. If use_generic is TRUE then create a generic
2836 pointer type. */
2837
2838 tree
2839 m2expr_BuildAddr (location_t location, tree op1, int use_generic)
2840 {
2841 tree type = m2tree_skip_type_decl (TREE_TYPE (op1));
2842 tree ptrType = build_pointer_type (type);
2843 tree result;
2844
2845 m2assert_AssertLocation (location);
2846
2847 if (!gm2_mark_addressable (op1))
2848 error_at (location, "cannot take the address of this expression");
2849
2850 if (use_generic)
2851 result = build1 (ADDR_EXPR, m2type_GetPointerType (), op1);
2852 else
2853 result = build1 (ADDR_EXPR, ptrType, op1);
2854 protected_set_expr_location (result, location);
2855 return result;
2856 }
2857
2858 /* BuildOffset1 build and return an expression containing the number
2859 of bytes the field is offset from the start of the record structure.
2860 This function is the same as the above, except that it derives the
2861 record from the field and then calls BuildOffset. */
2862
2863 tree
2864 m2expr_BuildOffset1 (location_t location, tree field,
2865 int needconvert ATTRIBUTE_UNUSED)
2866 {
2867 m2assert_AssertLocation (location);
2868 return m2expr_BuildOffset (location, DECL_CONTEXT (field), field,
2869 needconvert);
2870 }
2871
2872 /* determinePenultimateField return the field associated with the
2873 DECL_CONTEXT (field) within a record or varient. The record, is a
2874 record/varient but it maybe an outer nested record to the field that
2875 we are searching. Ie:
2876
2877 record = RECORD x: CARDINAL ; y: RECORD field: CARDINAL ; END END ;
2878
2879 determinePenultimateField (record, field) returns, y. We are
2880 assurred that the chain of records leading to field will be unique as
2881 they are built on the fly to implement varient records. */
2882
2883 static tree
2884 determinePenultimateField (tree record, tree field)
2885 {
2886 tree fieldlist = TYPE_FIELDS (record);
2887 tree x, r;
2888
2889 for (x = fieldlist; x; x = TREE_CHAIN (x))
2890 {
2891 if (DECL_CONTEXT (field) == TREE_TYPE (x))
2892 return x;
2893 switch (TREE_CODE (TREE_TYPE (x)))
2894 {
2895 case RECORD_TYPE:
2896 case UNION_TYPE:
2897 r = determinePenultimateField (TREE_TYPE (x), field);
2898 if (r != NULL)
2899 return r;
2900 break;
2901 default:
2902 break;
2903 }
2904 }
2905 return NULL_TREE;
2906 }
2907
2908 /* BuildOffset builds an expression containing the number of bytes
2909 the field is offset from the start of the record structure. The
2910 expression is returned. */
2911
2912 tree
2913 m2expr_BuildOffset (location_t location, tree record, tree field,
2914 int needconvert ATTRIBUTE_UNUSED)
2915 {
2916 m2assert_AssertLocation (location);
2917
2918 if (DECL_CONTEXT (field) == record)
2919 return m2convert_BuildConvert (
2920 location, m2type_GetIntegerType (),
2921 m2expr_BuildAdd (
2922 location, DECL_FIELD_OFFSET (field),
2923 m2expr_BuildDivTrunc (location, DECL_FIELD_BIT_OFFSET (field),
2924 m2decl_BuildIntegerConstant (BITS_PER_UNIT),
2925 FALSE),
2926 FALSE),
2927 FALSE);
2928 else
2929 {
2930 tree r1 = DECL_CONTEXT (field);
2931 tree r2 = determinePenultimateField (record, field);
2932 return m2convert_BuildConvert (
2933 location, m2type_GetIntegerType (),
2934 m2expr_BuildAdd (
2935 location, m2expr_BuildOffset (location, r1, field, needconvert),
2936 m2expr_BuildOffset (location, record, r2, needconvert), FALSE),
2937 FALSE);
2938 }
2939 }
2940
2941 /* BuildLogicalOrAddress build a logical or expressions and return the tree. */
2942
2943 tree
2944 m2expr_BuildLogicalOrAddress (location_t location, tree op1, tree op2,
2945 int needconvert)
2946 {
2947 m2assert_AssertLocation (location);
2948 return m2expr_build_binary_op (location, BIT_IOR_EXPR, op1, op2,
2949 needconvert);
2950 }
2951
2952 /* BuildLogicalOr build a logical or expressions and return the tree. */
2953
2954 tree
2955 m2expr_BuildLogicalOr (location_t location, tree op1, tree op2,
2956 int needconvert)
2957 {
2958 m2assert_AssertLocation (location);
2959 return m2expr_build_binary_op (
2960 location, BIT_IOR_EXPR,
2961 m2convert_BuildConvert (location, m2type_GetWordType (), op1, FALSE),
2962 m2convert_BuildConvert (location, m2type_GetWordType (), op2, FALSE),
2963 needconvert);
2964 }
2965
2966 /* BuildLogicalAnd build a logical and expression and return the tree. */
2967
2968 tree
2969 m2expr_BuildLogicalAnd (location_t location, tree op1, tree op2,
2970 int needconvert)
2971 {
2972 m2assert_AssertLocation (location);
2973 return m2expr_build_binary_op (
2974 location, BIT_AND_EXPR,
2975 m2convert_BuildConvert (location, m2type_GetWordType (), op1, FALSE),
2976 m2convert_BuildConvert (location, m2type_GetWordType (), op2, FALSE),
2977 needconvert);
2978 }
2979
2980 /* BuildSymmetricalDifference build a logical xor expression and return the
2981 * tree. */
2982
2983 tree
2984 m2expr_BuildSymmetricDifference (location_t location, tree op1, tree op2,
2985 int needconvert)
2986 {
2987 m2assert_AssertLocation (location);
2988 return m2expr_build_binary_op (
2989 location, BIT_XOR_EXPR,
2990 m2convert_BuildConvert (location, m2type_GetWordType (), op1, FALSE),
2991 m2convert_BuildConvert (location, m2type_GetWordType (), op2, FALSE),
2992 needconvert);
2993 }
2994
2995 /* BuildLogicalDifference build a logical difference expression and
2996 return the tree. (op1 and (not op2)). */
2997
2998 tree
2999 m2expr_BuildLogicalDifference (location_t location, tree op1, tree op2,
3000 int needconvert)
3001 {
3002 m2assert_AssertLocation (location);
3003 return m2expr_build_binary_op (
3004 location, BIT_AND_EXPR,
3005 m2convert_BuildConvert (location, m2type_GetWordType (), op1, FALSE),
3006 m2expr_BuildSetNegate (location, op2, needconvert), needconvert);
3007 }
3008
3009 /* base_type returns the base type of an ordinal subrange, or the
3010 type itself if it is not a subrange. */
3011
3012 static tree
3013 base_type (tree type)
3014 {
3015 if (type == error_mark_node)
3016 return error_mark_node;
3017
3018 /* Check for ordinal subranges. */
3019 if (m2tree_IsOrdinal (type) && TREE_TYPE (type))
3020 type = TREE_TYPE (type);
3021 return TYPE_MAIN_VARIANT (type);
3022 }
3023
3024 /* boolean_enum_to_unsigned convert a BOOLEAN_TYPE, t, or
3025 ENUMERAL_TYPE to an unsigned type. */
3026
3027 static tree
3028 boolean_enum_to_unsigned (location_t location, tree t)
3029 {
3030 tree type = TREE_TYPE (t);
3031
3032 if (TREE_CODE (base_type (type)) == BOOLEAN_TYPE)
3033 return m2convert_BuildConvert (location, unsigned_type_node, t, FALSE);
3034 else if (TREE_CODE (base_type (type)) == ENUMERAL_TYPE)
3035 return m2convert_BuildConvert (location, unsigned_type_node, t, FALSE);
3036 else
3037 return t;
3038 }
3039
3040 /* check_for_comparison check to see if, op, is of type, badType. If
3041 so then it returns op after it has been cast to, goodType. op will
3042 be an array so we take the address and cast the contents. */
3043
3044 static tree
3045 check_for_comparison (location_t location, tree op, tree badType,
3046 tree goodType)
3047 {
3048 m2assert_AssertLocation (location);
3049 if (m2tree_skip_type_decl (TREE_TYPE (op)) == badType)
3050 /* Cannot compare array contents in m2expr_build_binary_op. */
3051 return m2expr_BuildIndirect (
3052 location, m2expr_BuildAddr (location, op, FALSE), goodType);
3053 return op;
3054 }
3055
3056 /* convert_for_comparison return a tree which can be used as an
3057 argument during a comparison. */
3058
3059 static tree
3060 convert_for_comparison (location_t location, tree op)
3061 {
3062 m2assert_AssertLocation (location);
3063 op = boolean_enum_to_unsigned (location, op);
3064
3065 op = check_for_comparison (location, op, m2type_GetISOWordType (),
3066 m2type_GetWordType ());
3067 op = check_for_comparison (location, op, m2type_GetM2Word16 (),
3068 m2type_GetM2Cardinal16 ());
3069 op = check_for_comparison (location, op, m2type_GetM2Word32 (),
3070 m2type_GetM2Cardinal32 ());
3071 op = check_for_comparison (location, op, m2type_GetM2Word64 (),
3072 m2type_GetM2Cardinal64 ());
3073
3074 return op;
3075 }
3076
3077 /* BuildLessThan return a tree which computes <. */
3078
3079 tree
3080 m2expr_BuildLessThan (location_t location, tree op1, tree op2)
3081 {
3082 m2assert_AssertLocation (location);
3083 return m2expr_build_binary_op (
3084 location, LT_EXPR, boolean_enum_to_unsigned (location, op1),
3085 boolean_enum_to_unsigned (location, op2), TRUE);
3086 }
3087
3088 /* BuildGreaterThan return a tree which computes >. */
3089
3090 tree
3091 m2expr_BuildGreaterThan (location_t location, tree op1, tree op2)
3092 {
3093 m2assert_AssertLocation (location);
3094 return m2expr_build_binary_op (
3095 location, GT_EXPR, boolean_enum_to_unsigned (location, op1),
3096 boolean_enum_to_unsigned (location, op2), TRUE);
3097 }
3098
3099 /* BuildLessThanOrEqual return a tree which computes <. */
3100
3101 tree
3102 m2expr_BuildLessThanOrEqual (location_t location, tree op1, tree op2)
3103 {
3104 m2assert_AssertLocation (location);
3105 return m2expr_build_binary_op (
3106 location, LE_EXPR, boolean_enum_to_unsigned (location, op1),
3107 boolean_enum_to_unsigned (location, op2), TRUE);
3108 }
3109
3110 /* BuildGreaterThanOrEqual return a tree which computes >=. */
3111
3112 tree
3113 m2expr_BuildGreaterThanOrEqual (location_t location, tree op1, tree op2)
3114 {
3115 m2assert_AssertLocation (location);
3116 return m2expr_build_binary_op (
3117 location, GE_EXPR, boolean_enum_to_unsigned (location, op1),
3118 boolean_enum_to_unsigned (location, op2), TRUE);
3119 }
3120
3121 /* BuildEqualTo return a tree which computes =. */
3122
3123 tree
3124 m2expr_BuildEqualTo (location_t location, tree op1, tree op2)
3125 {
3126 m2assert_AssertLocation (location);
3127 return m2expr_build_binary_op (location, EQ_EXPR,
3128 convert_for_comparison (location, op1),
3129 convert_for_comparison (location, op2), TRUE);
3130 }
3131
3132 /* BuildEqualNotTo return a tree which computes #. */
3133
3134 tree
3135 m2expr_BuildNotEqualTo (location_t location, tree op1, tree op2)
3136 {
3137 m2assert_AssertLocation (location);
3138 return m2expr_build_binary_op (location, NE_EXPR,
3139 convert_for_comparison (location, op1),
3140 convert_for_comparison (location, op2), TRUE);
3141 }
3142
3143 /* BuildIsSuperset return a tree which computes: op1 & op2 == op2. */
3144
3145 tree
3146 m2expr_BuildIsSuperset (location_t location, tree op1, tree op2)
3147 {
3148 m2assert_AssertLocation (location);
3149 return m2expr_BuildEqualTo (
3150 location, op2, m2expr_BuildLogicalAnd (location, op1, op2, FALSE));
3151 }
3152
3153 /* BuildIsNotSuperset return a tree which computes: op1 & op2 != op2. */
3154
3155 tree
3156 m2expr_BuildIsNotSuperset (location_t location, tree op1, tree op2)
3157 {
3158 m2assert_AssertLocation (location);
3159 return m2expr_BuildNotEqualTo (
3160 location, op2, m2expr_BuildLogicalAnd (location, op1, op2, FALSE));
3161 }
3162
3163 /* BuildIsSubset return a tree which computes: op1 & op2 == op1. */
3164
3165 tree
3166 m2expr_BuildIsSubset (location_t location, tree op1, tree op2)
3167 {
3168 m2assert_AssertLocation (location);
3169 return m2expr_BuildEqualTo (
3170 location, op1, m2expr_BuildLogicalAnd (location, op1, op2, FALSE));
3171 }
3172
3173 /* BuildIsNotSubset return a tree which computes: op1 & op2 != op1. */
3174
3175 tree
3176 m2expr_BuildIsNotSubset (location_t location, tree op1, tree op2)
3177 {
3178 m2assert_AssertLocation (location);
3179 return m2expr_BuildNotEqualTo (
3180 location, op1, m2expr_BuildLogicalAnd (location, op1, op2, FALSE));
3181 }
3182
3183 /* BuildIfConstInVar generates: if constel in varset then goto label. */
3184
3185 void
3186 m2expr_BuildIfConstInVar (location_t location, tree type, tree varset,
3187 tree constel, int is_lvalue, int fieldno,
3188 char *label)
3189 {
3190 tree size = m2expr_GetSizeOf (location, type);
3191 m2assert_AssertLocation (location);
3192
3193 ASSERT_BOOL (is_lvalue);
3194 if (m2expr_CompareTrees (
3195 size, m2decl_BuildIntegerConstant (SET_WORD_SIZE / BITS_PER_UNIT))
3196 <= 0)
3197 /* Small set size <= TSIZE(WORD). */
3198 m2treelib_do_jump_if_bit (
3199 location, NE_EXPR,
3200 m2treelib_get_rvalue (location, varset, type, is_lvalue), constel,
3201 label);
3202 else
3203 {
3204 tree fieldlist = TYPE_FIELDS (type);
3205 tree field;
3206
3207 for (field = fieldlist; (field != NULL) && (fieldno > 0);
3208 field = TREE_CHAIN (field))
3209 fieldno--;
3210
3211 m2treelib_do_jump_if_bit (
3212 location, NE_EXPR,
3213 m2treelib_get_set_field_rhs (location, varset, field), constel,
3214 label);
3215 }
3216 }
3217
3218 /* BuildIfConstInVar generates: if not (constel in varset) then goto label. */
3219
3220 void
3221 m2expr_BuildIfNotConstInVar (location_t location, tree type, tree varset,
3222 tree constel, int is_lvalue, int fieldno,
3223 char *label)
3224 {
3225 tree size = m2expr_GetSizeOf (location, type);
3226
3227 m2assert_AssertLocation (location);
3228
3229 ASSERT_BOOL (is_lvalue);
3230 if (m2expr_CompareTrees (
3231 size, m2decl_BuildIntegerConstant (SET_WORD_SIZE / BITS_PER_UNIT))
3232 <= 0)
3233 /* Small set size <= TSIZE(WORD). */
3234 m2treelib_do_jump_if_bit (
3235 location, EQ_EXPR,
3236 m2treelib_get_rvalue (location, varset, type, is_lvalue), constel,
3237 label);
3238 else
3239 {
3240 tree fieldlist = TYPE_FIELDS (type);
3241 tree field;
3242
3243 for (field = fieldlist; (field != NULL) && (fieldno > 0);
3244 field = TREE_CHAIN (field))
3245 fieldno--;
3246
3247 m2treelib_do_jump_if_bit (
3248 location, EQ_EXPR,
3249 m2treelib_get_set_field_rhs (location, varset, field), constel,
3250 label);
3251 }
3252 }
3253
3254 /* BuildIfVarInVar generates: if varel in varset then goto label. */
3255
3256 void
3257 m2expr_BuildIfVarInVar (location_t location, tree type, tree varset,
3258 tree varel, int is_lvalue, tree low,
3259 tree high ATTRIBUTE_UNUSED, char *label)
3260 {
3261 tree size = m2expr_GetSizeOf (location, type);
3262 /* Calculate the index from the first bit, ie bit 0 represents low value. */
3263 tree index = m2expr_BuildSub (
3264 location, m2convert_BuildConvert (location, m2type_GetIntegerType (),
3265 varel, FALSE),
3266 m2convert_BuildConvert (location, m2type_GetIntegerType (), low, FALSE),
3267 FALSE);
3268
3269 m2assert_AssertLocation (location);
3270
3271 if (m2expr_CompareTrees (
3272 size, m2decl_BuildIntegerConstant (SET_WORD_SIZE / BITS_PER_UNIT))
3273 <= 0)
3274 /* Small set size <= TSIZE(WORD). */
3275 m2treelib_do_jump_if_bit (
3276 location, NE_EXPR,
3277 m2treelib_get_rvalue (location, varset, type, is_lvalue), index,
3278 label);
3279 else
3280 {
3281 tree p1 = m2treelib_get_set_address (location, varset, is_lvalue);
3282 /* Which word do we need to fetch? */
3283 tree word_index = m2expr_FoldAndStrip (m2expr_BuildDivTrunc (
3284 location, index, m2decl_BuildIntegerConstant (SET_WORD_SIZE),
3285 FALSE));
3286 /* Calculate the bit in this word. */
3287 tree offset_into_word = m2expr_FoldAndStrip (m2expr_BuildModTrunc (
3288 location, index, m2decl_BuildIntegerConstant (SET_WORD_SIZE),
3289 FALSE));
3290 tree p2 = m2expr_FoldAndStrip (m2expr_BuildMult (
3291 location, word_index,
3292 m2decl_BuildIntegerConstant (SET_WORD_SIZE / BITS_PER_UNIT), FALSE));
3293
3294 /* Calculate the address of the word we are interested in. */
3295 p1 = m2expr_BuildAddAddress (location,
3296 m2convert_convertToPtr (location, p1), p2);
3297
3298 /* Fetch the word, extract the bit and test for != 0. */
3299 m2treelib_do_jump_if_bit (
3300 location, NE_EXPR,
3301 m2expr_BuildIndirect (location, p1, m2type_GetBitsetType ()),
3302 offset_into_word, label);
3303 }
3304 }
3305
3306 /* BuildIfNotVarInVar generates: if not (varel in varset) then goto label. */
3307
3308 void
3309 m2expr_BuildIfNotVarInVar (location_t location, tree type, tree varset,
3310 tree varel, int is_lvalue, tree low,
3311 tree high ATTRIBUTE_UNUSED, char *label)
3312 {
3313 tree size = m2expr_GetSizeOf (location, type);
3314 /* Calculate the index from the first bit, ie bit 0 represents low value. */
3315 tree index = m2expr_BuildSub (
3316 location, m2convert_BuildConvert (location, m2type_GetIntegerType (),
3317 m2expr_FoldAndStrip (varel), FALSE),
3318 m2convert_BuildConvert (location, m2type_GetIntegerType (),
3319 m2expr_FoldAndStrip (low), FALSE),
3320 FALSE);
3321
3322 index = m2expr_FoldAndStrip (index);
3323 m2assert_AssertLocation (location);
3324
3325 if (m2expr_CompareTrees (
3326 size, m2decl_BuildIntegerConstant (SET_WORD_SIZE / BITS_PER_UNIT))
3327 <= 0)
3328 /* Small set size <= TSIZE(WORD). */
3329 m2treelib_do_jump_if_bit (
3330 location, EQ_EXPR,
3331 m2treelib_get_rvalue (location, varset, type, is_lvalue), index,
3332 label);
3333 else
3334 {
3335 tree p1 = m2treelib_get_set_address (location, varset, is_lvalue);
3336 /* Calculate the index from the first bit. */
3337
3338 /* Which word do we need to fetch? */
3339 tree word_index = m2expr_FoldAndStrip (m2expr_BuildDivTrunc (
3340 location, index, m2decl_BuildIntegerConstant (SET_WORD_SIZE),
3341 FALSE));
3342 /* Calculate the bit in this word. */
3343 tree offset_into_word = m2expr_FoldAndStrip (m2expr_BuildModTrunc (
3344 location, index, m2decl_BuildIntegerConstant (SET_WORD_SIZE),
3345 FALSE));
3346 tree p2 = m2expr_FoldAndStrip (m2expr_BuildMult (
3347 location, word_index,
3348 m2decl_BuildIntegerConstant (SET_WORD_SIZE / BITS_PER_UNIT), FALSE));
3349
3350 /* Calculate the address of the word we are interested in. */
3351 p1 = m2expr_BuildAddAddress (location, p1, p2);
3352
3353 /* Fetch the word, extract the bit and test for == 0. */
3354 m2treelib_do_jump_if_bit (
3355 location, EQ_EXPR,
3356 m2expr_BuildIndirect (location, p1, m2type_GetBitsetType ()),
3357 offset_into_word, label);
3358 }
3359 }
3360
3361 /* BuildForeachWordInSetDoIfExpr foreach word in set, type, compute
3362 the expression, expr, and if true goto label. */
3363
3364 void
3365 m2expr_BuildForeachWordInSetDoIfExpr (location_t location, tree type, tree op1,
3366 tree op2, int is_op1lvalue,
3367 int is_op2lvalue, int is_op1const,
3368 int is_op2const,
3369 tree (*expr) (location_t, tree, tree),
3370 char *label)
3371 {
3372 tree p1 = m2treelib_get_set_address_if_var (location, op1, is_op1lvalue,
3373 is_op1const);
3374 tree p2 = m2treelib_get_set_address_if_var (location, op2, is_op2lvalue,
3375 is_op2const);
3376 unsigned int fieldNo = 0;
3377 tree field1 = m2treelib_get_field_no (type, op1, is_op1const, fieldNo);
3378 tree field2 = m2treelib_get_field_no (type, op2, is_op2const, fieldNo);
3379
3380 m2assert_AssertLocation (location);
3381 ASSERT_CONDITION (TREE_CODE (TREE_TYPE (op1)) == RECORD_TYPE);
3382 ASSERT_CONDITION (TREE_CODE (TREE_TYPE (op2)) == RECORD_TYPE);
3383
3384 while (field1 != NULL && field2 != NULL)
3385 {
3386 m2statement_DoJump (
3387 location,
3388 (*expr) (location,
3389 m2treelib_get_set_value (location, p1, field1, is_op1const,
3390 is_op1lvalue, op1, fieldNo),
3391 m2treelib_get_set_value (location, p2, field2, is_op2const,
3392 is_op2lvalue, op2, fieldNo)),
3393 NULL, label);
3394 fieldNo++;
3395 field1 = m2treelib_get_field_no (type, op1, is_op1const, fieldNo);
3396 field2 = m2treelib_get_field_no (type, op2, is_op2const, fieldNo);
3397 }
3398 }
3399
3400 /* BuildIfInRangeGoto returns a tree containing if var is in the
3401 range low..high then goto label. */
3402
3403 void
3404 m2expr_BuildIfInRangeGoto (location_t location, tree var, tree low, tree high,
3405 char *label)
3406 {
3407 m2assert_AssertLocation (location);
3408
3409 if (m2expr_CompareTrees (low, high) == 0)
3410 m2statement_DoJump (location, m2expr_BuildEqualTo (location, var, low),
3411 NULL, label);
3412 else
3413 m2statement_DoJump (
3414 location,
3415 m2expr_build_binary_op (
3416 location, TRUTH_ANDIF_EXPR,
3417 m2expr_BuildGreaterThanOrEqual (location, var, low),
3418 m2expr_BuildLessThanOrEqual (location, var, high), FALSE),
3419 NULL, label);
3420 }
3421
3422 /* BuildIfNotInRangeGoto returns a tree containing if var is not in
3423 the range low..high then goto label. */
3424
3425 void
3426 m2expr_BuildIfNotInRangeGoto (location_t location, tree var, tree low,
3427 tree high, char *label)
3428 {
3429 m2assert_AssertLocation (location);
3430
3431 if (m2expr_CompareTrees (low, high) == 0)
3432 m2statement_DoJump (location, m2expr_BuildNotEqualTo (location, var, low),
3433 NULL, label);
3434 else
3435 m2statement_DoJump (
3436 location, m2expr_build_binary_op (
3437 location, TRUTH_ORIF_EXPR,
3438 m2expr_BuildLessThan (location, var, low),
3439 m2expr_BuildGreaterThan (location, var, high), FALSE),
3440 NULL, label);
3441 }
3442
3443 /* BuildArray - returns a tree which accesses array[index] given,
3444 lowIndice. */
3445
3446 tree
3447 m2expr_BuildArray (location_t location, tree type, tree array, tree index,
3448 tree low_indice)
3449 {
3450 tree array_type = m2tree_skip_type_decl (TREE_TYPE (array));
3451 tree index_type = TYPE_DOMAIN (array_type);
3452 type = m2tree_skip_type_decl (type);
3453 // ASSERT_CONDITION (low_indice == TYPE_MIN_VALUE (index_type));
3454
3455 low_indice
3456 = m2convert_BuildConvert (location, index_type, low_indice, FALSE);
3457 return build4_loc (location, ARRAY_REF, type, array, index, low_indice,
3458 NULL_TREE);
3459 }
3460
3461 /* BuildComponentRef - build a component reference tree which
3462 accesses record.field. If field does not belong to record it
3463 calls BuildComponentRef on the penultimate field. */
3464
3465 tree
3466 m2expr_BuildComponentRef (location_t location, tree record, tree field)
3467 {
3468 tree recordType = m2tree_skip_reference_type (
3469 m2tree_skip_type_decl (TREE_TYPE (record)));
3470
3471 if (DECL_CONTEXT (field) == recordType)
3472 return build3 (COMPONENT_REF, TREE_TYPE (field), record, field, NULL_TREE);
3473 else
3474 {
3475 tree f = determinePenultimateField (recordType, field);
3476 return m2expr_BuildComponentRef (
3477 location, m2expr_BuildComponentRef (location, record, f), field);
3478 }
3479 }
3480
3481 /* BuildIndirect - build: (*target) given that the object to be
3482 copied is of, type. */
3483
3484 tree
3485 m2expr_BuildIndirect (location_t location ATTRIBUTE_UNUSED, tree target,
3486 tree type)
3487 {
3488 /* Note that the second argument to build1 is:
3489
3490 TYPE_QUALS is a list of modifiers such as const or volatile to apply
3491 to the pointer type, represented as identifiers.
3492
3493 it also determines the type of arithmetic and size of the object to
3494 be indirectly moved. */
3495
3496 tree t1 = m2tree_skip_type_decl (type);
3497 tree t2 = build_pointer_type (t1);
3498
3499 m2assert_AssertLocation (location);
3500
3501 return build1 (INDIRECT_REF, t1,
3502 m2convert_BuildConvert (location, t2, target, FALSE));
3503 }
3504
3505 /* IsTrue - returns TRUE if, t, is known to be TRUE. */
3506
3507 int
3508 m2expr_IsTrue (tree t)
3509 {
3510 return (m2expr_FoldAndStrip (t) == m2type_GetBooleanTrue ());
3511 }
3512
3513 /* IsFalse - returns FALSE if, t, is known to be FALSE. */
3514
3515 int
3516 m2expr_IsFalse (tree t)
3517 {
3518 return (m2expr_FoldAndStrip (t) == m2type_GetBooleanFalse ());
3519 }
3520
3521 /* AreConstantsEqual - maps onto tree.cc (tree_int_cst_equal). It
3522 returns TRUE if the value of e1 is the same as e2. */
3523
3524 int
3525 m2expr_AreConstantsEqual (tree e1, tree e2)
3526 {
3527 return tree_int_cst_equal (e1, e2) != 0;
3528 }
3529
3530 /* AreRealOrComplexConstantsEqual - returns TRUE if constants, e1 and
3531 e2 are equal according to IEEE rules. This does not perform bit
3532 equivalence for example IEEE states that -0 == 0 and NaN != NaN. */
3533
3534 int
3535 m2expr_AreRealOrComplexConstantsEqual (tree e1, tree e2)
3536 {
3537 if (TREE_CODE (e1) == COMPLEX_CST)
3538 return (m2expr_AreRealOrComplexConstantsEqual (TREE_REALPART (e1),
3539 TREE_REALPART (e2))
3540 && m2expr_AreRealOrComplexConstantsEqual (TREE_IMAGPART (e1),
3541 TREE_IMAGPART (e2)));
3542 else
3543 return real_compare (EQ_EXPR, &TREE_REAL_CST (e1), &TREE_REAL_CST (e2));
3544 }
3545
3546 /* DetermineSign, returns -1 if e<0 0 if e==0 1 if e>0
3547 an unsigned constant will never return -1. */
3548
3549 int
3550 m2expr_DetermineSign (tree e)
3551 {
3552 return tree_int_cst_sgn (e);
3553 }
3554
3555 /* Similar to build_int_2 () but allows you to specify the type of
3556 the integer constant that you are creating. */
3557
3558 static tree
3559 build_int_2_type (HOST_WIDE_INT low, HOST_WIDE_INT hi, tree type)
3560 {
3561 tree value;
3562 HOST_WIDE_INT ival[3];
3563
3564 ival[0] = low;
3565 ival[1] = hi;
3566 ival[2] = 0;
3567
3568 widest_int wval = widest_int::from_array (ival, 3);
3569 value = wide_int_to_tree (type, wval);
3570
3571 return value;
3572 }
3573
3574 /* BuildCap - builds the Modula-2 function CAP(t) and returns the
3575 result in a gcc Tree. */
3576
3577 tree
3578 m2expr_BuildCap (location_t location, tree t)
3579 {
3580 tree tt;
3581 tree out_of_range, less_than, greater_than, translated;
3582
3583 m2assert_AssertLocation (location);
3584
3585 t = fold (t);
3586 if (t == error_mark_node)
3587 return error_mark_node;
3588
3589 tt = TREE_TYPE (t);
3590
3591 t = fold (convert (m2type_GetM2CharType (), t));
3592
3593 if (TREE_CODE (tt) == INTEGER_TYPE)
3594 {
3595 less_than = fold (m2expr_build_binary_op (
3596 location, LT_EXPR, t,
3597 build_int_2_type ('a', 0, m2type_GetM2CharType ()), 0));
3598 greater_than = fold (m2expr_build_binary_op (
3599 location, GT_EXPR, t,
3600 build_int_2_type ('z', 0, m2type_GetM2CharType ()), 0));
3601 out_of_range = fold (m2expr_build_binary_op (
3602 location, TRUTH_ORIF_EXPR, less_than, greater_than, 0));
3603
3604 translated = fold (convert (
3605 m2type_GetM2CharType (),
3606 m2expr_build_binary_op (
3607 location, MINUS_EXPR, t,
3608 build_int_2_type ('a' - 'A', 0, m2type_GetM2CharType ()), 0)));
3609
3610 return fold_build3 (COND_EXPR, m2type_GetM2CharType (), out_of_range, t,
3611 translated);
3612 }
3613
3614 error_at (location,
3615 "argument to CAP is not a constant or variable of type CHAR");
3616 return error_mark_node;
3617 }
3618
3619 /* BuildDivM2 if iso or pim4 then build and return ((op2 < 0) : (op1
3620 divceil op2) ? (op1 divfloor op2)) otherwise use divtrunc. */
3621
3622 tree
3623 m2expr_BuildDivM2 (location_t location, tree op1, tree op2,
3624 unsigned int needsconvert)
3625 {
3626 op1 = m2expr_FoldAndStrip (op1);
3627 op2 = m2expr_FoldAndStrip (op2);
3628 ASSERT_CONDITION (TREE_TYPE (op1) == TREE_TYPE (op2));
3629 if (M2Options_GetPIM4 () || M2Options_GetISO ()
3630 || M2Options_GetPositiveModFloor ())
3631 return fold_build3 (
3632 COND_EXPR, TREE_TYPE (op1),
3633 m2expr_BuildLessThan (
3634 location, op2,
3635 m2convert_BuildConvert (location, TREE_TYPE (op2),
3636 m2expr_GetIntegerZero (location), FALSE)),
3637 m2expr_BuildDivCeil (location, op1, op2, needsconvert),
3638 m2expr_BuildDivFloor (location, op1, op2, needsconvert));
3639 else
3640 return m2expr_BuildDivTrunc (location, op1, op2, needsconvert);
3641 }
3642
3643 /* BuildDivM2Check - build and
3644 return ((op2 < 0) : (op1 divtrunc op2) ? (op1 divfloor op2))
3645 when -fiso, -fpim4 or -fpositive-mod-floor-div is present else
3646 return op1 div trunc op2. Use the checking div equivalents. */
3647
3648 tree
3649 m2expr_BuildDivM2Check (location_t location, tree op1, tree op2,
3650 tree lowest, tree min, tree max)
3651 {
3652 op1 = m2expr_FoldAndStrip (op1);
3653 op2 = m2expr_FoldAndStrip (op2);
3654 ASSERT_CONDITION (TREE_TYPE (op1) == TREE_TYPE (op2));
3655 if (M2Options_GetISO ()
3656 || M2Options_GetPIM4 () || M2Options_GetPositiveModFloor ())
3657 return fold_build3 (
3658 COND_EXPR, TREE_TYPE (op1),
3659 m2expr_BuildLessThan (
3660 location, op2,
3661 m2convert_BuildConvert (location, TREE_TYPE (op2),
3662 m2expr_GetIntegerZero (location), FALSE)),
3663 m2expr_BuildDivCeilCheck (location, op1, op2, lowest, min, max),
3664 m2expr_BuildDivFloorCheck (location, op1, op2, lowest, min, max));
3665 else
3666 return m2expr_BuildDivTruncCheck (location, op1, op2, lowest, min, max);
3667 }
3668
3669 static
3670 tree
3671 m2expr_BuildISOModM2Check (location_t location,
3672 tree op1, tree op2, tree lowest, tree min, tree max)
3673 {
3674 tree cond = m2expr_BuildLessThan (location, op2,
3675 m2convert_BuildConvert (location, TREE_TYPE (op2),
3676 m2expr_GetIntegerZero (location), FALSE));
3677
3678 /* Return the result of the modulus. */
3679 return fold_build3 (COND_EXPR, TREE_TYPE (op1), cond,
3680 /* op2 < 0. */
3681 m2expr_BuildModCeilCheck (location, op1, op2, lowest, min, max),
3682 /* op2 >= 0. */
3683 m2expr_BuildModFloorCheck (location, op1, op2, lowest, min, max));
3684 }
3685
3686
3687 /* BuildModM2Check if iso or pim4 then build and return ((op2 < 0) : (op1
3688 modceil op2) ? (op1 modfloor op2)) otherwise use modtrunc.
3689 Use the checking mod equivalents. */
3690
3691 tree
3692 m2expr_BuildModM2Check (location_t location, tree op1, tree op2,
3693 tree lowest, tree min, tree max)
3694 {
3695 op1 = m2expr_FoldAndStrip (op1);
3696 op2 = m2expr_FoldAndStrip (op2);
3697 ASSERT_CONDITION (TREE_TYPE (op1) == TREE_TYPE (op2));
3698 if (M2Options_GetPIM4 () || M2Options_GetISO ()
3699 || M2Options_GetPositiveModFloor ())
3700 return m2expr_BuildISOModM2Check (location, op1, op2, lowest, min, max);
3701 else
3702 return m2expr_BuildModTruncCheck (location, op1, op2, lowest, min, max);
3703 }
3704
3705 /* BuildModM2 if iso or pim4 then build and return ((op2 < 0) : (op1
3706 modceil op2) ? (op1 modfloor op2)) otherwise use modtrunc. */
3707
3708 tree
3709 m2expr_BuildModM2 (location_t location, tree op1, tree op2,
3710 unsigned int needsconvert)
3711 {
3712 op1 = m2expr_FoldAndStrip (op1);
3713 op2 = m2expr_FoldAndStrip (op2);
3714 ASSERT_CONDITION (TREE_TYPE (op1) == TREE_TYPE (op2));
3715 if (M2Options_GetPIM4 () || M2Options_GetISO ()
3716 || M2Options_GetPositiveModFloor ())
3717 return fold_build3 (
3718 COND_EXPR, TREE_TYPE (op1),
3719 m2expr_BuildLessThan (
3720 location, op2,
3721 m2convert_BuildConvert (location, TREE_TYPE (op2),
3722 m2expr_GetIntegerZero (location), FALSE)),
3723 m2expr_BuildModCeil (location, op1, op2, needsconvert),
3724 m2expr_BuildModFloor (location, op1, op2, needsconvert));
3725 else
3726 return m2expr_BuildModTrunc (location, op1, op2, needsconvert);
3727 }
3728
3729 /* BuildAbs build the Modula-2 function ABS(t) and return the result
3730 in a gcc Tree. */
3731
3732 tree
3733 m2expr_BuildAbs (location_t location, tree t)
3734 {
3735 m2assert_AssertLocation (location);
3736
3737 return m2expr_build_unary_op (location, ABS_EXPR, t, 0);
3738 }
3739
3740 /* BuildRe build an expression for the function RE. */
3741
3742 tree
3743 m2expr_BuildRe (tree op1)
3744 {
3745 op1 = m2expr_FoldAndStrip (op1);
3746 if (TREE_CODE (op1) == COMPLEX_CST)
3747 return fold_build1 (REALPART_EXPR, TREE_TYPE (TREE_TYPE (op1)), op1);
3748 else
3749 return build1 (REALPART_EXPR, TREE_TYPE (TREE_TYPE (op1)), op1);
3750 }
3751
3752 /* BuildIm build an expression for the function IM. */
3753
3754 tree
3755 m2expr_BuildIm (tree op1)
3756 {
3757 op1 = m2expr_FoldAndStrip (op1);
3758 if (TREE_CODE (op1) == COMPLEX_CST)
3759 return fold_build1 (IMAGPART_EXPR, TREE_TYPE (TREE_TYPE (op1)), op1);
3760 else
3761 return build1 (IMAGPART_EXPR, TREE_TYPE (TREE_TYPE (op1)), op1);
3762 }
3763
3764 /* BuildCmplx build an expression for the function CMPLX. */
3765
3766 tree
3767 m2expr_BuildCmplx (location_t location, tree type, tree real, tree imag)
3768 {
3769 tree scalor;
3770 real = m2expr_FoldAndStrip (real);
3771 imag = m2expr_FoldAndStrip (imag);
3772 type = m2tree_skip_type_decl (type);
3773 scalor = TREE_TYPE (type);
3774
3775 if (scalor != TREE_TYPE (real))
3776 real = m2convert_BuildConvert (location, scalor, real, FALSE);
3777 if (scalor != TREE_TYPE (imag))
3778 imag = m2convert_BuildConvert (location, scalor, imag, FALSE);
3779
3780 if ((TREE_CODE (real) == REAL_CST) && (TREE_CODE (imag) == REAL_CST))
3781 return build_complex (type, real, imag);
3782 else
3783 return build2 (COMPLEX_EXPR, type, real, imag);
3784 }
3785
3786 /* BuildBinaryForeachWordDo implements the large set operators. Each
3787 word of the set can be calculated by binop. This function runs along
3788 each word of the large set invoking the binop. */
3789
3790 void
3791 m2expr_BuildBinaryForeachWordDo (location_t location, tree type, tree op1,
3792 tree op2, tree op3,
3793 tree (*binop) (location_t, tree, tree, int),
3794 int is_op1lvalue, int is_op2lvalue,
3795 int is_op3lvalue, int is_op1const,
3796 int is_op2const, int is_op3const)
3797 {
3798 tree size = m2expr_GetSizeOf (location, type);
3799
3800 m2assert_AssertLocation (location);
3801
3802 ASSERT_BOOL (is_op1lvalue);
3803 ASSERT_BOOL (is_op2lvalue);
3804 ASSERT_BOOL (is_op3lvalue);
3805 ASSERT_BOOL (is_op1const);
3806 ASSERT_BOOL (is_op2const);
3807 ASSERT_BOOL (is_op3const);
3808 if (m2expr_CompareTrees (
3809 size, m2decl_BuildIntegerConstant (SET_WORD_SIZE / BITS_PER_UNIT))
3810 <= 0)
3811 /* Small set size <= TSIZE(WORD). */
3812 m2statement_BuildAssignmentTree (
3813 location, m2treelib_get_rvalue (location, op1, type, is_op1lvalue),
3814 (*binop) (
3815 location, m2treelib_get_rvalue (location, op2, type, is_op2lvalue),
3816 m2treelib_get_rvalue (location, op3, type, is_op3lvalue), FALSE));
3817 else
3818 {
3819 /* Large set size > TSIZE(WORD). */
3820
3821 tree p2 = m2treelib_get_set_address_if_var (location, op2, is_op2lvalue,
3822 is_op2const);
3823 tree p3 = m2treelib_get_set_address_if_var (location, op3, is_op3lvalue,
3824 is_op3const);
3825 unsigned int fieldNo = 0;
3826 tree field1 = m2treelib_get_field_no (type, op1, is_op1const, fieldNo);
3827 tree field2 = m2treelib_get_field_no (type, op2, is_op2const, fieldNo);
3828 tree field3 = m2treelib_get_field_no (type, op3, is_op3const, fieldNo);
3829
3830 if (is_op1const)
3831 error_at (
3832 location,
3833 "internal error: not expecting operand1 to be a constant set");
3834
3835 while (field1 != NULL && field2 != NULL && field3 != NULL)
3836 {
3837 m2statement_BuildAssignmentTree (
3838 location, m2treelib_get_set_field_des (location, op1, field1),
3839 (*binop) (
3840 location,
3841 m2treelib_get_set_value (location, p2, field2, is_op2const,
3842 is_op2lvalue, op2, fieldNo),
3843 m2treelib_get_set_value (location, p3, field3, is_op3const,
3844 is_op3lvalue, op3, fieldNo),
3845 FALSE));
3846 fieldNo++;
3847 field1 = m2treelib_get_field_no (type, op1, is_op1const, fieldNo);
3848 field2 = m2treelib_get_field_no (type, op2, is_op2const, fieldNo);
3849 field3 = m2treelib_get_field_no (type, op3, is_op3const, fieldNo);
3850 }
3851 }
3852 }
3853
3854 /* Append DIGIT to NUM, a number of PRECISION bits being read in base
3855 BASE. */
3856
3857 static int
3858 append_digit (unsigned HOST_WIDE_INT *low, HOST_WIDE_INT *high,
3859 unsigned int digit, unsigned int base)
3860 {
3861 unsigned int shift;
3862 int overflow;
3863 HOST_WIDE_INT add_high, res_high, test_high;
3864 unsigned HOST_WIDE_INT add_low, res_low, test_low;
3865
3866 switch (base)
3867 {
3868
3869 case 2:
3870 shift = 1;
3871 break;
3872 case 8:
3873 shift = 3;
3874 break;
3875 case 10:
3876 shift = 3;
3877 break;
3878 case 16:
3879 shift = 4;
3880 break;
3881
3882 default:
3883 shift = 3;
3884 error ("internal error: not expecting this base value for a constant");
3885 }
3886
3887 /* Multiply by 2, 8 or 16. Catching this overflow here means we
3888 don't need to worry about add_high overflowing. */
3889 if (((*high) >> (INT_TYPE_SIZE - shift)) == 0)
3890 overflow = FALSE;
3891 else
3892 overflow = TRUE;
3893
3894 res_high = *high << shift;
3895 res_low = *low << shift;
3896 res_high |= (*low) >> (INT_TYPE_SIZE - shift);
3897
3898 if (base == 10)
3899 {
3900 add_low = (*low) << 1;
3901 add_high = ((*high) << 1) + ((*low) >> (INT_TYPE_SIZE - 1));
3902 }
3903 else
3904 add_high = add_low = 0;
3905
3906 test_low = add_low + digit;
3907 if (test_low < add_low)
3908 add_high++;
3909 add_low += digit;
3910
3911 test_low = res_low + add_low;
3912 if (test_low < res_low)
3913 add_high++;
3914 test_high = res_high + add_high;
3915 if (test_high < res_high)
3916 overflow = TRUE;
3917
3918 *low = res_low + add_low;
3919 *high = res_high + add_high;
3920
3921 return overflow;
3922 }
3923
3924 /* interpret_integer convert an integer constant into two integer
3925 constants. Heavily borrowed from gcc/cppexp.cc. */
3926
3927 int
3928 m2expr_interpret_integer (const char *str, unsigned int base,
3929 unsigned HOST_WIDE_INT *low, HOST_WIDE_INT *high)
3930 {
3931 unsigned const char *p, *end;
3932 int overflow = FALSE;
3933 int len;
3934
3935 *low = 0;
3936 *high = 0;
3937 p = (unsigned const char *)str;
3938 len = strlen (str);
3939 end = p + len;
3940
3941 /* Common case of a single digit. */
3942 if (len == 1)
3943 *low = p[0] - '0';
3944 else
3945 {
3946 unsigned int c = 0;
3947
3948 /* We can add a digit to numbers strictly less than this without
3949 needing the precision and slowness of double integers. */
3950
3951 unsigned HOST_WIDE_INT max = ~(unsigned HOST_WIDE_INT)0;
3952 max = (max - base + 1) / base + 1;
3953
3954 for (; p < end; p++)
3955 {
3956 c = *p;
3957
3958 if (ISDIGIT (c) || (base == 16 && ISXDIGIT (c)))
3959 c = hex_value (c);
3960 else
3961 return overflow;
3962
3963 /* Strict inequality for when max is set to zero. */
3964 if (*low < max)
3965 *low = (*low) * base + c;
3966 else
3967 {
3968 overflow = append_digit (low, high, c, base);
3969 max = 0; /* From now on we always use append_digit. */
3970 }
3971 }
3972 }
3973 return overflow;
3974 }
3975
3976 /* Append DIGIT to NUM, a number of PRECISION bits being read in base
3977 BASE. */
3978
3979 static int
3980 append_m2_digit (unsigned int *low, int *high, unsigned int digit,
3981 unsigned int base, int *needsUnsigned)
3982 {
3983 unsigned int shift;
3984 int overflow;
3985 int add_high, res_high, test_high;
3986 unsigned int add_low, res_low, test_low;
3987 unsigned int add_uhigh, res_uhigh, test_uhigh;
3988
3989 switch (base)
3990 {
3991
3992 case 2:
3993 shift = 1;
3994 break;
3995 case 8:
3996 shift = 3;
3997 break;
3998 case 10:
3999 shift = 3;
4000 break;
4001 case 16:
4002 shift = 4;
4003 break;
4004
4005 default:
4006 shift = 3;
4007 error ("internal error: not expecting this base value for a constant");
4008 }
4009
4010 /* Multiply by 2, 8 or 16. Catching this overflow here means we
4011 don't need to worry about add_high overflowing. */
4012 if (((*high) >> (INT_TYPE_SIZE - shift)) == 0)
4013 overflow = FALSE;
4014 else
4015 overflow = TRUE;
4016
4017 res_high = *high << shift;
4018 res_low = *low << shift;
4019 res_high |= (*low) >> (INT_TYPE_SIZE - shift);
4020
4021 if (base == 10)
4022 {
4023 add_low = (*low) << 1;
4024 add_high = ((*high) << 1) + ((*low) >> (INT_TYPE_SIZE - 1));
4025 }
4026 else
4027 add_high = add_low = 0;
4028
4029 test_low = add_low + digit;
4030 if (test_low < add_low)
4031 add_high++;
4032 add_low += digit;
4033
4034 test_low = res_low + add_low;
4035 if (test_low < res_low)
4036 add_high++;
4037 test_high = res_high + add_high;
4038 if (test_high < res_high)
4039 {
4040 res_uhigh = res_high;
4041 add_uhigh = add_high;
4042 test_uhigh = res_uhigh + add_uhigh;
4043 if (test_uhigh < res_uhigh)
4044 overflow = TRUE;
4045 else
4046 *needsUnsigned = TRUE;
4047 }
4048
4049 *low = res_low + add_low;
4050 *high = res_high + add_high;
4051
4052 return overflow;
4053 }
4054
4055 /* interpret_m2_integer convert an integer constant into two integer
4056 constants. Heavily borrowed from gcc/cppexp.cc. Note that this is a
4057 copy of the above code except that it uses `int' rather than
4058 HOST_WIDE_INT to allow gm2 to determine what Modula-2 base type to
4059 use for this constant and it also sets needsLong and needsUnsigned
4060 if an overflow can be avoided by using these techniques. */
4061
4062 int
4063 m2expr_interpret_m2_integer (const char *str, unsigned int base,
4064 unsigned int *low, int *high,
4065 int *needsLong, int *needsUnsigned)
4066 {
4067 const unsigned char *p, *end;
4068 int len;
4069 *needsLong = FALSE;
4070 *needsUnsigned = FALSE;
4071
4072 *low = 0;
4073 *high = 0;
4074 p = (unsigned const char *)str;
4075 len = strlen (str);
4076 end = p + len;
4077
4078 /* Common case of a single digit. */
4079 if (len == 1)
4080 *low = p[0] - '0';
4081 else
4082 {
4083 unsigned int c = 0;
4084
4085 /* We can add a digit to numbers strictly less than this without
4086 needing the precision and slowness of double integers. */
4087
4088 unsigned int max = ~(unsigned int)0;
4089 max = (max - base + 1) / base + 1;
4090
4091 for (; p < end; p++)
4092 {
4093 c = *p;
4094
4095 if (ISDIGIT (c) || (base == 16 && ISXDIGIT (c)))
4096 c = hex_value (c);
4097 else
4098 return FALSE; /* End of string and no overflow found. */
4099
4100 /* Strict inequality for when max is set to zero. */
4101 if (*low < max)
4102 *low = (*low) * base + c;
4103 else
4104 {
4105 *needsLong = TRUE;
4106 if (append_m2_digit (low, high, c, base,
4107 needsUnsigned))
4108 return TRUE; /* We have overflowed so bail out. */
4109 max = 0; /* From now on we always use append_digit. */
4110 }
4111 }
4112 }
4113 return FALSE;
4114 }
4115
4116 /* GetSizeOfInBits return the number of bits used to contain, type. */
4117
4118 tree
4119 m2expr_GetSizeOfInBits (tree type)
4120 {
4121 enum tree_code code = TREE_CODE (type);
4122
4123 if (code == FUNCTION_TYPE)
4124 return m2expr_GetSizeOfInBits (ptr_type_node);
4125
4126 if (code == VOID_TYPE)
4127 {
4128 error ("%qs applied to a void type", "sizeof");
4129 return size_one_node;
4130 }
4131
4132 if (code == VAR_DECL)
4133 return m2expr_GetSizeOfInBits (TREE_TYPE (type));
4134
4135 if (code == PARM_DECL)
4136 return m2expr_GetSizeOfInBits (TREE_TYPE (type));
4137
4138 if (code == TYPE_DECL)
4139 return m2expr_GetSizeOfInBits (TREE_TYPE (type));
4140
4141 if (code == COMPONENT_REF)
4142 return m2expr_GetSizeOfInBits (TREE_TYPE (type));
4143
4144 if (code == ERROR_MARK)
4145 return size_one_node;
4146
4147 if (!COMPLETE_TYPE_P (type))
4148 {
4149 error ("%qs applied to an incomplete type", "sizeof");
4150 return size_zero_node;
4151 }
4152
4153 return m2decl_BuildIntegerConstant (TYPE_PRECISION (type));
4154 }
4155
4156 /* GetSizeOf taken from c-typeck.cc (c_sizeof). */
4157
4158 tree
4159 m2expr_GetSizeOf (location_t location, tree type)
4160 {
4161 enum tree_code code = TREE_CODE (type);
4162 m2assert_AssertLocation (location);
4163
4164 if (code == FUNCTION_TYPE)
4165 return m2expr_GetSizeOf (location, m2type_GetPointerType ());
4166
4167 if (code == VOID_TYPE)
4168 return size_one_node;
4169
4170 if (code == VAR_DECL)
4171 return m2expr_GetSizeOf (location, TREE_TYPE (type));
4172
4173 if (code == PARM_DECL)
4174 return m2expr_GetSizeOf (location, TREE_TYPE (type));
4175
4176 if (code == TYPE_DECL)
4177 return m2expr_GetSizeOf (location, TREE_TYPE (type));
4178
4179 if (code == ERROR_MARK)
4180 return size_one_node;
4181
4182 if (code == CONSTRUCTOR)
4183 return m2expr_GetSizeOf (location, TREE_TYPE (type));
4184
4185 if (code == FIELD_DECL)
4186 return m2expr_GetSizeOf (location, TREE_TYPE (type));
4187
4188 if (code == COMPONENT_REF)
4189 return m2expr_GetSizeOf (location, TREE_TYPE (type));
4190
4191 if (!COMPLETE_TYPE_P (type))
4192 {
4193 error_at (location, "%qs applied to an incomplete type", "sizeof");
4194 return size_zero_node;
4195 }
4196
4197 /* Convert in case a char is more than one unit. */
4198 return size_binop_loc (
4199 location, CEIL_DIV_EXPR, TYPE_SIZE_UNIT (type),
4200 size_int (TYPE_PRECISION (char_type_node) / BITS_PER_UNIT));
4201 }
4202
4203 tree
4204 m2expr_GetIntegerZero (location_t location ATTRIBUTE_UNUSED)
4205 {
4206 return integer_zero_node;
4207 }
4208
4209 tree
4210 m2expr_GetIntegerOne (location_t location ATTRIBUTE_UNUSED)
4211 {
4212 return integer_one_node;
4213 }
4214
4215 tree
4216 m2expr_GetCardinalOne (location_t location)
4217 {
4218 return m2convert_ToCardinal (location, integer_one_node);
4219 }
4220
4221 tree
4222 m2expr_GetCardinalZero (location_t location)
4223 {
4224 return m2convert_ToCardinal (location, integer_zero_node);
4225 }
4226
4227 tree
4228 m2expr_GetWordZero (location_t location)
4229 {
4230 return m2convert_ToWord (location, integer_zero_node);
4231 }
4232
4233 tree
4234 m2expr_GetWordOne (location_t location)
4235 {
4236 return m2convert_ToWord (location, integer_one_node);
4237 }
4238
4239 tree
4240 m2expr_GetPointerZero (location_t location)
4241 {
4242 return m2convert_convertToPtr (location, integer_zero_node);
4243 }
4244
4245 tree
4246 m2expr_GetPointerOne (location_t location)
4247 {
4248 return m2convert_convertToPtr (location, integer_one_node);
4249 }
4250
4251 /* build_set_full_complement return a word size value with all bits
4252 set to one. */
4253
4254 static tree
4255 build_set_full_complement (location_t location)
4256 {
4257 tree value = integer_zero_node;
4258 int i;
4259
4260 m2assert_AssertLocation (location);
4261
4262 for (i = 0; i < SET_WORD_SIZE; i++)
4263 {
4264 value = m2expr_BuildLogicalOr (
4265 location, value,
4266 m2expr_BuildLSL (
4267 location, m2expr_GetWordOne (location),
4268 m2convert_BuildConvert (location, m2type_GetWordType (),
4269 m2decl_BuildIntegerConstant (i), FALSE),
4270 FALSE),
4271 FALSE);
4272 }
4273 return value;
4274 }
4275
4276 /* init initialise this module. */
4277
4278 void
4279 m2expr_init (location_t location)
4280 {
4281 m2assert_AssertLocation (location);
4282
4283 set_full_complement = build_set_full_complement (location);
4284 }
4285
4286 #include "gt-m2-m2expr.h"