Branch data Line data Source code
1 : : /* m2convert.cc provides GCC tree conversion for the Modula-2 language.
2 : :
3 : : Copyright (C) 2012-2025 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 : :
27 : : #define m2convert_c
28 : : #include "m2assert.h"
29 : : #include "m2block.h"
30 : : #include "m2convert.h"
31 : : #include "m2decl.h"
32 : : #include "m2expr.h"
33 : : #include "m2expr.h"
34 : : #include "m2statement.h"
35 : : #include "m2tree.h"
36 : : #include "m2treelib.h"
37 : : #include "m2type.h"
38 : :
39 : : static tree const_to_ISO_type (location_t location, tree expr, tree iso_type);
40 : : static tree const_to_ISO_aggregate_type (location_t location, tree expr,
41 : : tree iso_type);
42 : :
43 : : /* These enumerators are possible types of unsafe conversions.
44 : : SAFE_CONVERSION The conversion is safe UNSAFE_OTHER Another type of
45 : : conversion with problems UNSAFE_SIGN Conversion between signed and
46 : : unsigned integers which are all warned about immediately, so this is
47 : : unused UNSAFE_REAL Conversions that reduce the precision of reals
48 : : including conversions from reals to integers. */
49 : : enum conversion_safety
50 : : {
51 : : SAFE_CONVERSION = 0,
52 : : UNSAFE_OTHER,
53 : : UNSAFE_SIGN,
54 : : UNSAFE_REAL
55 : : };
56 : :
57 : : /* ConvertString - converts string, expr, into a string of type,
58 : : type. */
59 : :
60 : : tree
61 : 3300 : m2convert_ConvertString (tree type, tree expr)
62 : : {
63 : 3300 : const char *str = TREE_STRING_POINTER (expr);
64 : 3300 : int len = TREE_STRING_LENGTH (expr);
65 : 3300 : return m2decl_BuildStringConstantType (len, str, type);
66 : : }
67 : :
68 : :
69 : : /* (Taken from c-common.cc and trimmed for Modula-2)
70 : :
71 : : Checks if expression EXPR of real/integer type cannot be converted to
72 : : the real/integer type TYPE. Function returns non-zero when:
73 : : EXPR is a constant which cannot be exactly converted to TYPE.
74 : : EXPR is not a constant and size of EXPR's type > than size of
75 : : TYPE, for EXPR type and TYPE being both integers or both real.
76 : : EXPR is not a constant of real type and TYPE is an integer.
77 : : EXPR is not a constant of integer type which cannot be exactly
78 : : converted to real type. Function allows conversions between types
79 : : of different signedness and can return SAFE_CONVERSION (zero) in
80 : : that case. Function can produce signedness warnings if
81 : : PRODUCE_WARNS is true. */
82 : :
83 : : enum conversion_safety
84 : 0 : unsafe_conversion_p (location_t loc, tree type, tree expr, bool produce_warns)
85 : : {
86 : 0 : enum conversion_safety give_warning = SAFE_CONVERSION; /* Is 0 or false. */
87 : 0 : tree expr_type = TREE_TYPE (expr);
88 : :
89 : 0 : if (TREE_CODE (expr) == REAL_CST || TREE_CODE (expr) == INTEGER_CST)
90 : : {
91 : :
92 : : /* Warn for real constant that is not an exact integer converted to
93 : : integer type. */
94 : 0 : if (SCALAR_FLOAT_TYPE_P (expr_type)
95 : 0 : && TREE_CODE (type) == INTEGER_TYPE)
96 : : {
97 : 0 : if (!real_isinteger (TREE_REAL_CST_PTR (expr),
98 : 0 : TYPE_MODE (expr_type)))
99 : 0 : give_warning = UNSAFE_REAL;
100 : : }
101 : : /* Warn for an integer constant that does not fit into integer type. */
102 : 0 : else if (TREE_CODE (expr_type) == INTEGER_TYPE
103 : 0 : && TREE_CODE (type) == INTEGER_TYPE
104 : 0 : && !int_fits_type_p (expr, type))
105 : : {
106 : 0 : if (TYPE_UNSIGNED (type) && !TYPE_UNSIGNED (expr_type)
107 : 0 : && tree_int_cst_sgn (expr) < 0)
108 : : {
109 : 0 : if (produce_warns)
110 : 0 : warning_at (loc, OPT_Wsign_conversion,
111 : : "negative integer"
112 : : " implicitly converted to unsigned type");
113 : : }
114 : 0 : else if (!TYPE_UNSIGNED (type) && TYPE_UNSIGNED (expr_type))
115 : : {
116 : 0 : if (produce_warns)
117 : 0 : warning_at (loc, OPT_Wsign_conversion,
118 : : "conversion of unsigned"
119 : : " constant value to negative integer");
120 : : }
121 : : else
122 : : give_warning = UNSAFE_OTHER;
123 : : }
124 : 0 : else if (SCALAR_FLOAT_TYPE_P (type))
125 : : {
126 : : /* Warn for an integer constant that does not fit into real type. */
127 : 0 : if (TREE_CODE (expr_type) == INTEGER_TYPE)
128 : : {
129 : 0 : REAL_VALUE_TYPE a = real_value_from_int_cst (0, expr);
130 : 0 : if (!exact_real_truncate (TYPE_MODE (type), &a))
131 : 0 : give_warning = UNSAFE_REAL;
132 : : }
133 : :
134 : : /* Warn for a real constant that does not fit into a smaller real
135 : : type. */
136 : 0 : else if (SCALAR_FLOAT_TYPE_P (expr_type)
137 : 0 : && TYPE_PRECISION (type) < TYPE_PRECISION (expr_type))
138 : : {
139 : 0 : REAL_VALUE_TYPE a = TREE_REAL_CST (expr);
140 : 0 : if (!exact_real_truncate (TYPE_MODE (type), &a))
141 : 0 : give_warning = UNSAFE_REAL;
142 : : }
143 : : }
144 : : }
145 : : else
146 : : {
147 : : /* Warn for real types converted to integer types. */
148 : 0 : if (SCALAR_FLOAT_TYPE_P (expr_type)
149 : 0 : && TREE_CODE (type) == INTEGER_TYPE)
150 : 0 : give_warning = UNSAFE_REAL;
151 : :
152 : : }
153 : :
154 : 0 : return give_warning;
155 : : }
156 : :
157 : : /* (Taken from c-common.cc and trimmed for Modula-2)
158 : :
159 : : Warns if the conversion of EXPR to TYPE may alter a value. This is
160 : : a helper function for warnings_for_convert_and_check. */
161 : :
162 : : static void
163 : 782859 : conversion_warning (location_t loc, tree type, tree expr)
164 : : {
165 : 782859 : tree expr_type = TREE_TYPE (expr);
166 : 782859 : enum conversion_safety conversion_kind;
167 : :
168 : 782859 : if (!warn_conversion && !warn_sign_conversion && !warn_float_conversion)
169 : : return;
170 : :
171 : 0 : switch (TREE_CODE (expr))
172 : : {
173 : 0 : case EQ_EXPR:
174 : 0 : case NE_EXPR:
175 : 0 : case LE_EXPR:
176 : 0 : case GE_EXPR:
177 : 0 : case LT_EXPR:
178 : 0 : case GT_EXPR:
179 : 0 : case TRUTH_ANDIF_EXPR:
180 : 0 : case TRUTH_ORIF_EXPR:
181 : 0 : case TRUTH_AND_EXPR:
182 : 0 : case TRUTH_OR_EXPR:
183 : 0 : case TRUTH_XOR_EXPR:
184 : 0 : case TRUTH_NOT_EXPR:
185 : :
186 : : /* Conversion from boolean to a signed:1 bit-field (which only can
187 : : hold the values 0 and -1) doesn't lose information - but it does
188 : : change the value. */
189 : 0 : if (TYPE_PRECISION (type) == 1 && !TYPE_UNSIGNED (type))
190 : 0 : warning_at (loc, OPT_Wconversion,
191 : : "conversion to %qT from boolean expression", type);
192 : : return;
193 : :
194 : 0 : case REAL_CST:
195 : 0 : case INTEGER_CST:
196 : 0 : conversion_kind = unsafe_conversion_p (loc, type, expr, true);
197 : 0 : if (conversion_kind == UNSAFE_REAL)
198 : 0 : warning_at (loc, OPT_Wfloat_conversion,
199 : : "conversion to %qT alters %qT constant value", type,
200 : : expr_type);
201 : 0 : else if (conversion_kind)
202 : 0 : warning_at (loc, OPT_Wconversion,
203 : : "conversion to %qT alters %qT constant value", type,
204 : : expr_type);
205 : : return;
206 : :
207 : 0 : case COND_EXPR:
208 : 0 : {
209 : :
210 : : /* In case of COND_EXPR, we do not care about the type of COND_EXPR,
211 : : only about the conversion of each operand. */
212 : 0 : tree op1 = TREE_OPERAND (expr, 1);
213 : 0 : tree op2 = TREE_OPERAND (expr, 2);
214 : :
215 : 0 : conversion_warning (loc, type, op1);
216 : 0 : conversion_warning (loc, type, op2);
217 : 0 : return;
218 : : }
219 : :
220 : 0 : default: /* 'expr' is not a constant. */
221 : 0 : conversion_kind = unsafe_conversion_p (loc, type, expr, true);
222 : 0 : if (conversion_kind == UNSAFE_REAL)
223 : 0 : warning_at (loc, OPT_Wfloat_conversion,
224 : : "conversion to %qT from %qT may alter its value", type,
225 : : expr_type);
226 : 0 : else if (conversion_kind)
227 : 0 : warning_at (loc, OPT_Wconversion,
228 : : "conversion to %qT from %qT may alter its value", type,
229 : : expr_type);
230 : : }
231 : : }
232 : :
233 : : /* (Taken from c-common.cc and trimmed for Modula-2)
234 : :
235 : : Produce warnings after a conversion. RESULT is the result of
236 : : converting EXPR to TYPE. This is a helper function for
237 : : convert_and_check and cp_convert_and_check. */
238 : :
239 : : void
240 : 782859 : warnings_for_convert_and_check (location_t loc, tree type, tree expr,
241 : : tree result)
242 : : {
243 : 782859 : if (TREE_CODE (expr) == INTEGER_CST && (TREE_CODE (type) == INTEGER_TYPE
244 : 7432 : || TREE_CODE (type) == ENUMERAL_TYPE)
245 : 737821 : && !int_fits_type_p (expr, type))
246 : : {
247 : :
248 : : /* Do not diagnose overflow in a constant expression merely because a
249 : : conversion overflowed. */
250 : 56 : if (TREE_OVERFLOW (result))
251 : 0 : TREE_OVERFLOW (result) = TREE_OVERFLOW (expr);
252 : :
253 : 56 : if (TYPE_UNSIGNED (type))
254 : : {
255 : :
256 : : /* This detects cases like converting -129 or 256 to unsigned
257 : : char. */
258 : 50 : if (!int_fits_type_p (expr, m2type_gm2_signed_type (type)))
259 : 0 : warning_at (loc, OPT_Woverflow,
260 : : "large integer implicitly truncated to unsigned type");
261 : : else
262 : 50 : conversion_warning (loc, type, expr);
263 : : }
264 : 6 : else if (!int_fits_type_p (expr, m2type_gm2_unsigned_type (type)))
265 : 0 : warning_at (loc, OPT_Woverflow,
266 : : "overflow in implicit constant conversion");
267 : : /* No warning for converting 0x80000000 to int. */
268 : 6 : else if (pedantic && (TREE_CODE (TREE_TYPE (expr)) != INTEGER_TYPE
269 : 0 : || TYPE_PRECISION (TREE_TYPE (expr))
270 : 0 : != TYPE_PRECISION (type)))
271 : 0 : warning_at (loc, OPT_Woverflow,
272 : : "overflow in implicit constant conversion");
273 : :
274 : : else
275 : 6 : conversion_warning (loc, type, expr);
276 : : }
277 : 782803 : else if ((TREE_CODE (result) == INTEGER_CST
278 : 42058 : || TREE_CODE (result) == FIXED_CST)
279 : 782803 : && TREE_OVERFLOW (result))
280 : 0 : warning_at (loc, OPT_Woverflow,
281 : : "overflow in implicit constant conversion");
282 : : else
283 : 782803 : conversion_warning (loc, type, expr);
284 : 782859 : }
285 : :
286 : : /* (Taken from c-common.cc and trimmed for Modula-2)
287 : :
288 : : Convert EXPR to TYPE, warning about conversion problems with
289 : : constants. Invoke this function on every expression that is
290 : : converted implicitly, i.e. because of language rules and not
291 : : because of an explicit cast. */
292 : :
293 : : static tree
294 : 1032540 : convert_and_check (location_t loc, tree type, tree expr)
295 : : {
296 : 1032540 : tree result;
297 : 1032540 : tree expr_for_warning;
298 : :
299 : : /* Convert from a value with possible excess precision rather than
300 : : via the semantic type, but do not warn about values not fitting
301 : : exactly in the semantic type. */
302 : 1032540 : if (TREE_CODE (expr) == EXCESS_PRECISION_EXPR)
303 : : {
304 : 0 : tree orig_type = TREE_TYPE (expr);
305 : 0 : expr = TREE_OPERAND (expr, 0);
306 : 0 : expr_for_warning = convert (orig_type, expr);
307 : 0 : if (orig_type == type)
308 : : return expr_for_warning;
309 : : }
310 : : else
311 : : expr_for_warning = expr;
312 : :
313 : 1032540 : if (TREE_TYPE (expr) == type)
314 : : return expr;
315 : :
316 : 782865 : result = convert_loc (loc, type, expr);
317 : :
318 : 782865 : if (!TREE_OVERFLOW_P (expr) && result != error_mark_node)
319 : 782859 : warnings_for_convert_and_check (loc, type, expr_for_warning, result);
320 : :
321 : : return result;
322 : : }
323 : :
324 : :
325 : : static tree
326 : 12 : doOrdinal (tree value)
327 : : {
328 : 12 : if (TREE_CODE (value) == STRING_CST && (m2expr_StringLength (value) <= 1))
329 : : {
330 : 12 : const char *p = TREE_STRING_POINTER (value);
331 : 12 : int i = p[0];
332 : :
333 : 12 : return m2decl_BuildIntegerConstant (i);
334 : : }
335 : : return value;
336 : : }
337 : :
338 : : static int
339 : 19180313 : same_size_types (location_t location, tree t1, tree t2)
340 : : {
341 : 19180313 : tree n1 = m2expr_GetSizeOf (location, t1);
342 : 19180313 : tree n2 = m2expr_GetSizeOf (location, t2);
343 : :
344 : 19180313 : return m2expr_CompareTrees (n1, n2) == 0;
345 : : }
346 : :
347 : : static int
348 : 43933608 : converting_ISO_generic (location_t location, tree type, tree value,
349 : : tree generic_type, tree *result)
350 : : {
351 : 43933608 : tree value_type = m2tree_skip_type_decl (TREE_TYPE (value));
352 : :
353 : 43933608 : if (value_type == type)
354 : : /* We let the caller deal with this. */
355 : : return false;
356 : :
357 : 19180481 : if ((TREE_CODE (value) == INTEGER_CST) && (type == generic_type))
358 : : {
359 : 168 : *result = const_to_ISO_type (location, value, generic_type);
360 : 168 : return true;
361 : : }
362 : :
363 : 19180313 : if (same_size_types (location, type, value_type))
364 : : {
365 : 13270132 : if (value_type == generic_type)
366 : : {
367 : 168 : tree pt = build_pointer_type (type);
368 : 168 : tree a = build1 (ADDR_EXPR, pt, value);
369 : 168 : tree t = build1 (INDIRECT_REF, type, a);
370 : 168 : *result = build1 (NOP_EXPR, type, t);
371 : 168 : return true;
372 : : }
373 : 13269964 : else if (type == generic_type)
374 : : {
375 : 168 : tree pt = build_pointer_type (type);
376 : 168 : tree a = build1 (ADDR_EXPR, pt, value);
377 : 168 : tree t = build1 (INDIRECT_REF, type, a);
378 : 168 : *result = build1 (NOP_EXPR, type, t);
379 : 168 : return true;
380 : : }
381 : : }
382 : : return false;
383 : : }
384 : :
385 : : /* convert_char_to_array - convert a single char, value, into an
386 : : type. The type will be array [..] of char. The array type
387 : : returned will have nuls appended to pad the single char to the
388 : : correct array length. */
389 : :
390 : : static tree
391 : 24 : convert_char_to_array (location_t location, tree type, tree value)
392 : : {
393 : 24 : tree i = m2decl_BuildIntegerConstant (0);
394 : 24 : struct struct_constructor *c
395 : 24 : = (struct struct_constructor *)m2type_BuildStartArrayConstructor (type);
396 : 24 : tree n = m2type_GetArrayNoOfElements (location, type);
397 : 24 : char nul[1];
398 : :
399 : 24 : nul[0] = (char)0;
400 : :
401 : : /* Store the initial char. */
402 : 24 : m2type_BuildArrayConstructorElement (c, value, i);
403 : 24 : i = m2expr_BuildAdd (location, i, m2decl_BuildIntegerConstant (1), false);
404 : :
405 : : /* Now pad out the remaining elements with nul chars. */
406 : 480 : while (m2expr_CompareTrees (i, n) < 0)
407 : : {
408 : 432 : m2type_BuildArrayConstructorElement (
409 : : c, m2type_BuildCharConstant (location, &nul[0]), i);
410 : 432 : i = m2expr_BuildAdd (location, i, m2decl_BuildIntegerConstant (1),
411 : : false);
412 : : }
413 : 24 : return m2type_BuildEndArrayConstructor (c);
414 : : }
415 : :
416 : : /* convert_string_to_array - convert a STRING_CST into an array type.
417 : : array [..] of char. The array constant returned will have nuls
418 : : appended to pad the contents to the correct length. */
419 : :
420 : : static tree
421 : 0 : convert_string_to_array (location_t location, tree type, tree value)
422 : : {
423 : 0 : tree n = m2type_GetArrayNoOfElements (location, type);
424 : :
425 : 0 : return m2type_BuildArrayStringConstructor (location, type, value, n);
426 : : }
427 : :
428 : : /* BuildConvert - build and return tree VAL (type, value).
429 : : checkOverflow determines whether we should suppress overflow
430 : : checking. */
431 : :
432 : : tree
433 : 6276646 : m2convert_BuildConvert (location_t location, tree type, tree value,
434 : : bool checkOverflow)
435 : : {
436 : 6276646 : type = m2tree_skip_type_decl (type);
437 : 6276646 : tree t;
438 : :
439 : 6276646 : value = fold (value);
440 : 6276646 : STRIP_NOPS (value);
441 : 6276646 : value = m2expr_FoldAndStrip (value);
442 : :
443 : 12 : if (TREE_CODE (value) == STRING_CST && (m2expr_StringLength (value) <= 1)
444 : 6276658 : && (m2tree_IsOrdinal (type)))
445 : 12 : value = doOrdinal (value);
446 : 6276634 : else if (TREE_CODE (value) == FUNCTION_DECL && TREE_TYPE (value) != type)
447 : 30 : value = m2expr_BuildAddr (0, value, false);
448 : :
449 : 6276646 : if (converting_ISO_generic (location, type, value, m2type_GetByteType (), &t)
450 : 6276252 : || converting_ISO_generic (location, type, value,
451 : : m2type_GetISOLocType (), &t)
452 : 6276142 : || converting_ISO_generic (location, type, value,
453 : : m2type_GetISOByteType (), &t)
454 : 6276142 : || converting_ISO_generic (location, type, value,
455 : : m2type_GetISOWordType (), &t)
456 : 6276142 : || converting_ISO_generic (location, type, value, m2type_GetM2Word16 (),
457 : : &t)
458 : 6276142 : || converting_ISO_generic (location, type, value, m2type_GetM2Word32 (),
459 : : &t)
460 : 12552788 : || converting_ISO_generic (location, type, value, m2type_GetM2Word64 (),
461 : : &t))
462 : 504 : return t;
463 : :
464 : 6276142 : if (TREE_CODE (type) == ARRAY_TYPE
465 : 6276142 : && TREE_TYPE (type) == m2type_GetM2CharType ())
466 : : {
467 : 66 : if (TREE_TYPE (value) == m2type_GetM2CharType ())
468 : :
469 : : /* Passing a const char to an array [..] of char. So we convert
470 : : const char into the correct length string. */
471 : 24 : return convert_char_to_array (location, type, value);
472 : 42 : if (TREE_CODE (value) == STRING_CST)
473 : : /* Convert a string into an array constant, padding with zeros if
474 : : necessary. */
475 : 0 : return convert_string_to_array (location, type, value);
476 : : }
477 : :
478 : 6276118 : if (checkOverflow)
479 : 526873 : return convert_and_check (location, type, value);
480 : : else
481 : 5749245 : return convert_loc (location, type, value);
482 : : }
483 : :
484 : : /* const_to_ISO_type - perform VAL (iso_type, expr). */
485 : :
486 : : static tree
487 : 202 : const_to_ISO_type (location_t location, tree expr, tree iso_type)
488 : : {
489 : 202 : tree n = m2expr_GetSizeOf (location, iso_type);
490 : :
491 : 202 : if ((m2expr_CompareTrees (n, m2decl_BuildIntegerConstant (1)) == 0)
492 : 202 : && (iso_type == m2type_GetByteType ()
493 : 102 : || iso_type == m2type_GetISOLocType ()
494 : 0 : || iso_type == m2type_GetISOByteType ()))
495 : 178 : return build1 (NOP_EXPR, iso_type, expr);
496 : 24 : return const_to_ISO_aggregate_type (location, expr, iso_type);
497 : : }
498 : :
499 : : /* const_to_ISO_aggregate_type - perform VAL (iso_type, expr). The
500 : : iso_type will be declared by the SYSTEM module as: TYPE iso_type =
501 : : ARRAY [0..n] OF LOC
502 : :
503 : : this function will store a constant into the iso_type in the correct
504 : : endian order. It converts the expr into a unsigned int or signed
505 : : int and then strips it a byte at a time. */
506 : :
507 : : static tree
508 : 24 : const_to_ISO_aggregate_type (location_t location, tree expr, tree iso_type)
509 : : {
510 : 24 : tree byte;
511 : 24 : m2type_Constructor c;
512 : 24 : tree i = m2decl_BuildIntegerConstant (0);
513 : 24 : tree n = m2expr_GetSizeOf (location, iso_type);
514 : 24 : tree max_uint = m2decl_BuildIntegerConstant (256);
515 : :
516 : 144 : while (m2expr_CompareTrees (i, n) < 0)
517 : : {
518 : 96 : max_uint = m2expr_BuildMult (location, max_uint,
519 : : m2decl_BuildIntegerConstant (256), false);
520 : 96 : i = m2expr_BuildAdd (location, i, m2decl_BuildIntegerConstant (1),
521 : : false);
522 : : }
523 : 24 : max_uint = m2expr_BuildDivFloor (location, max_uint,
524 : : m2decl_BuildIntegerConstant (2), false);
525 : :
526 : 24 : if (m2expr_CompareTrees (expr, m2decl_BuildIntegerConstant (0)) < 0)
527 : 0 : expr = m2expr_BuildAdd (location, expr, max_uint, false);
528 : :
529 : 24 : i = m2decl_BuildIntegerConstant (0);
530 : 24 : c = m2type_BuildStartArrayConstructor (iso_type);
531 : 144 : while (m2expr_CompareTrees (i, n) < 0)
532 : : {
533 : 96 : byte = m2expr_BuildModTrunc (location, expr,
534 : : m2decl_BuildIntegerConstant (256), false);
535 : 96 : if (BYTES_BIG_ENDIAN)
536 : : m2type_BuildArrayConstructorElement (
537 : : c, m2convert_ToLoc (location, byte),
538 : : m2expr_BuildSub (location, m2expr_BuildSub (location, n, i, false),
539 : : m2decl_BuildIntegerConstant (1), false));
540 : : else
541 : 96 : m2type_BuildArrayConstructorElement (
542 : : c, m2convert_ToLoc (location, byte), i);
543 : :
544 : 96 : i = m2expr_BuildAdd (location, i, m2decl_BuildIntegerConstant (1),
545 : : false);
546 : 96 : expr = m2expr_BuildDivFloor (location, expr,
547 : : m2decl_BuildIntegerConstant (256), false);
548 : : }
549 : :
550 : 24 : return m2type_BuildEndArrayConstructor (c);
551 : : }
552 : :
553 : : /* ConvertConstantAndCheck - in Modula-2 sementics: RETURN( VAL(type,
554 : : expr) ). Only to be used for a constant expr, overflow checking
555 : : is performed. */
556 : :
557 : : tree
558 : 1093329 : m2convert_ConvertConstantAndCheck (location_t location, tree type, tree expr)
559 : : {
560 : 1093329 : tree etype;
561 : 1093329 : expr = fold (expr);
562 : 1093329 : STRIP_NOPS (expr);
563 : 1093329 : expr = m2expr_FoldAndStrip (expr);
564 : 1093329 : etype = TREE_TYPE (expr);
565 : :
566 : 1093329 : m2assert_AssertLocation (location);
567 : 1093329 : if (etype == type)
568 : : return expr;
569 : :
570 : 505701 : if (TREE_CODE (expr) == FUNCTION_DECL)
571 : 0 : expr = m2expr_BuildAddr (location, expr, false);
572 : :
573 : 505701 : type = m2tree_skip_type_decl (type);
574 : 1011392 : if (type == m2type_GetByteType () || type == m2type_GetISOLocType ()
575 : 505691 : || type == m2type_GetISOByteType () || type == m2type_GetISOWordType ()
576 : 505667 : || type == m2type_GetM2Word16 () || type == m2type_GetM2Word32 ()
577 : 1011368 : || type == m2type_GetM2Word64 ())
578 : 34 : return const_to_ISO_type (location, expr, type);
579 : :
580 : 505667 : return convert_and_check (location, type, m2expr_FoldAndStrip (expr));
581 : : }
582 : :
583 : : /* ToWord - converts an expression (Integer or Ordinal type) into a
584 : : WORD. */
585 : :
586 : : tree
587 : 540172 : m2convert_ToWord (location_t location, tree expr)
588 : : {
589 : 540172 : return m2convert_BuildConvert (location, m2type_GetWordType (), expr, false);
590 : : }
591 : :
592 : : /* ToCardinal - convert an expression, expr, to a CARDINAL. */
593 : :
594 : : tree
595 : 101352 : m2convert_ToCardinal (location_t location, tree expr)
596 : : {
597 : 101352 : return m2convert_BuildConvert (location, m2type_GetCardinalType (), expr,
598 : 101352 : false);
599 : : }
600 : :
601 : : /* convertToPtr - if the type of tree, t, is not a ptr_type_node then
602 : : convert it. */
603 : :
604 : : tree
605 : 79639 : m2convert_convertToPtr (location_t location, tree type)
606 : : {
607 : 79639 : if (TREE_CODE (TREE_TYPE (type)) == POINTER_TYPE)
608 : : return type;
609 : : else
610 : 79167 : return m2convert_BuildConvert (location, m2type_GetPointerType (), type,
611 : 79167 : false);
612 : : }
613 : :
614 : : /* ToInteger - convert an expression, expr, to an INTEGER. */
615 : :
616 : : tree
617 : 129038 : m2convert_ToInteger (location_t location, tree expr)
618 : : {
619 : 129038 : return m2convert_BuildConvert (location, m2type_GetIntegerType (), expr,
620 : 129038 : false);
621 : : }
622 : :
623 : : /* ToBitset - convert an expression, expr, to a BITSET type. */
624 : :
625 : : tree
626 : 41052 : m2convert_ToBitset (location_t location, tree expr)
627 : : {
628 : 41052 : return m2convert_BuildConvert (location, m2type_GetBitsetType (), expr,
629 : 41052 : false);
630 : : }
631 : :
632 : : /* ToLoc - convert an expression, expr, to a LOC. */
633 : :
634 : : tree
635 : 96 : m2convert_ToLoc (location_t location, tree expr)
636 : : {
637 : 96 : return m2convert_BuildConvert (location, m2type_GetISOByteType (), expr,
638 : 96 : false);
639 : : }
640 : :
641 : : /* GenericToType - converts, expr, into, type, providing that expr is
642 : : a generic system type (byte, word etc). Otherwise expr is
643 : : returned unaltered. */
644 : :
645 : : tree
646 : 3334036 : m2convert_GenericToType (location_t location, tree type, tree expr)
647 : : {
648 : 3334036 : tree etype = TREE_TYPE (expr);
649 : :
650 : 3334036 : type = m2tree_skip_type_decl (type);
651 : 3334036 : if (type == etype)
652 : : return expr;
653 : :
654 : 6668072 : if (type == m2type_GetISOWordType () || type == m2type_GetM2Word16 ()
655 : 6668072 : || type == m2type_GetM2Word32 () || type == m2type_GetM2Word64 ())
656 : 0 : return const_to_ISO_type (location, expr, type);
657 : :
658 : : return expr;
659 : : }
|
