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 : 3312 : m2convert_ConvertString (tree type, tree expr)
62 : : {
63 : 3312 : const char *str = TREE_STRING_POINTER (expr);
64 : 3312 : int len = TREE_STRING_LENGTH (expr);
65 : 3312 : 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 : 1034725 : conversion_warning (location_t loc, tree type, tree expr)
164 : : {
165 : 1034725 : tree expr_type = TREE_TYPE (expr);
166 : 1034725 : enum conversion_safety conversion_kind;
167 : :
168 : 1034725 : 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 : 1034725 : warnings_for_convert_and_check (location_t loc, tree type, tree expr,
241 : : tree result)
242 : : {
243 : 1034725 : if (TREE_CODE (expr) == INTEGER_CST && (TREE_CODE (type) == INTEGER_TYPE
244 : 7420 : || TREE_CODE (type) == ENUMERAL_TYPE)
245 : 979879 : && !int_fits_type_p (expr, type))
246 : : {
247 : :
248 : : /* Do not diagnose overflow in a constant expression merely because a
249 : : conversion overflowed. */
250 : 104 : if (TREE_OVERFLOW (result))
251 : 0 : TREE_OVERFLOW (result) = TREE_OVERFLOW (expr);
252 : :
253 : 104 : 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 : 54 : 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 : 54 : 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 : 54 : conversion_warning (loc, type, expr);
276 : : }
277 : 1034621 : else if ((TREE_CODE (result) == INTEGER_CST
278 : 51530 : || TREE_CODE (result) == FIXED_CST)
279 : 1034621 : && TREE_OVERFLOW (result))
280 : 0 : warning_at (loc, OPT_Woverflow,
281 : : "overflow in implicit constant conversion");
282 : : else
283 : 1034621 : conversion_warning (loc, type, expr);
284 : 1034725 : }
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 : 1421227 : convert_and_check (location_t loc, tree type, tree expr)
295 : : {
296 : 1421227 : tree result;
297 : 1421227 : 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 : 1421227 : 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 : 1421227 : if (TREE_TYPE (expr) == type)
314 : : return expr;
315 : :
316 : 1034731 : result = convert_loc (loc, type, expr);
317 : :
318 : 1034731 : if (!TREE_OVERFLOW_P (expr) && result != error_mark_node)
319 : 1034725 : 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 : 3833355 : same_size_types (location_t location, tree t1, tree t2)
340 : : {
341 : 3833355 : tree n1 = m2expr_GetSizeOf (location, t1);
342 : 3833355 : tree n2 = m2expr_GetSizeOf (location, t2);
343 : :
344 : 3833355 : return m2expr_CompareTrees (n1, n2) == 0;
345 : : }
346 : :
347 : : /* converting_ISO_generic attempts to convert value to type and returns true
348 : : if successful. This is a helper function to BuildConvert which will try
349 : : each generic data type in turn.
350 : :
351 : : generic_type will be set to any of ISO BYTE, PIM BYTE WORD, etc.
352 : : If type == generic_type then specific conversion procedures
353 : : are applied. A constant will be converted via const_to_ISO_type
354 : : whereas non constants are converted by *(type *) &value.
355 : :
356 : : Remember that in ISO M2 BYTE is an ARRAY [0..0] OF LOC. */
357 : :
358 : : static int
359 : 54790652 : converting_ISO_generic (location_t location, tree type, tree value,
360 : : tree generic_type, tree *result)
361 : : {
362 : 54790652 : tree value_type = m2tree_skip_type_decl (TREE_TYPE (value));
363 : :
364 : 54790652 : if (value_type == type)
365 : : /* We let the caller deal with this. */
366 : : return false;
367 : :
368 : 24562874 : if (TREE_CODE (value) == INTEGER_CST)
369 : : {
370 : 20729519 : if (type == generic_type)
371 : : {
372 : 153856 : *result = const_to_ISO_type (location, value, generic_type);
373 : 153856 : return true;
374 : : }
375 : : /* We must not attempt to convert a constant by taking its
376 : : address below, so we bail out here. */
377 : : return false;
378 : : }
379 : :
380 : 3833355 : if (same_size_types (location, type, value_type))
381 : : {
382 : 3503921 : if (value_type == generic_type)
383 : : {
384 : 532 : tree pt = build_pointer_type (type);
385 : 532 : tree a = build1 (ADDR_EXPR, pt, value);
386 : 532 : tree t = build1 (INDIRECT_REF, type, a);
387 : 532 : *result = build1 (NOP_EXPR, type, t);
388 : 532 : return true;
389 : : }
390 : 3503389 : else if (type == generic_type)
391 : : {
392 : 812 : tree pt = build_pointer_type (type);
393 : 812 : tree a = build1 (ADDR_EXPR, pt, value);
394 : 812 : tree t = build1 (INDIRECT_REF, type, a);
395 : 812 : *result = build1 (NOP_EXPR, type, t);
396 : 812 : return true;
397 : : }
398 : : }
399 : : return false;
400 : : }
401 : :
402 : : /* convert_char_to_array convert a single char value into a type.
403 : : The type will be array [..] of char. The array type
404 : : returned will have nuls appended to pad the single char to the
405 : : correct array length. */
406 : :
407 : : static tree
408 : 24 : convert_char_to_array (location_t location, tree type, tree value)
409 : : {
410 : 24 : tree i = m2decl_BuildIntegerConstant (0);
411 : 24 : struct struct_constructor *c
412 : 24 : = (struct struct_constructor *)m2type_BuildStartArrayConstructor (type);
413 : 24 : tree n = m2type_GetArrayNoOfElements (location, type);
414 : 24 : char nul[1];
415 : :
416 : 24 : nul[0] = (char)0;
417 : :
418 : : /* Store the initial char. */
419 : 24 : m2type_BuildArrayConstructorElement (c, value, i);
420 : 24 : i = m2expr_BuildAdd (location, i, m2decl_BuildIntegerConstant (1), false);
421 : :
422 : : /* Now pad out the remaining elements with nul chars. */
423 : 480 : while (m2expr_CompareTrees (i, n) < 0)
424 : : {
425 : 432 : m2type_BuildArrayConstructorElement (
426 : : c, m2type_BuildCharConstant (location, &nul[0]), i);
427 : 432 : i = m2expr_BuildAdd (location, i, m2decl_BuildIntegerConstant (1),
428 : : false);
429 : : }
430 : 24 : return m2type_BuildEndArrayConstructor (c);
431 : : }
432 : :
433 : : /* convert_string_to_array - convert a STRING_CST into an array type.
434 : : array [..] of char. The array constant returned will have nuls
435 : : appended to pad the contents to the correct length. */
436 : :
437 : : static tree
438 : 0 : convert_string_to_array (location_t location, tree type, tree value)
439 : : {
440 : 0 : tree n = m2type_GetArrayNoOfElements (location, type);
441 : :
442 : 0 : return m2type_BuildArrayStringConstructor (location, type, value, n);
443 : : }
444 : :
445 : : /* BuildConvert - build and return tree VAL (type, value).
446 : : checkOverflow determines whether we should suppress overflow
447 : : checking. */
448 : :
449 : : tree
450 : 7950210 : m2convert_BuildConvert (location_t location, tree type, tree value,
451 : : bool checkOverflow)
452 : : {
453 : 7950210 : type = m2tree_skip_type_decl (type);
454 : 7950210 : tree t;
455 : :
456 : 7950210 : value = fold (value);
457 : 7950210 : STRIP_NOPS (value);
458 : 7950210 : value = m2expr_FoldAndStrip (value);
459 : :
460 : 12 : if (TREE_CODE (value) == STRING_CST && (m2expr_StringLength (value) <= 1)
461 : 7950222 : && (m2tree_IsOrdinal (type)))
462 : 12 : value = doOrdinal (value);
463 : 7950198 : else if (TREE_CODE (value) == FUNCTION_DECL && TREE_TYPE (value) != type)
464 : 30 : value = m2expr_BuildAddr (0, value, false);
465 : :
466 : 7950210 : if (converting_ISO_generic (location, type, value, m2type_GetByteType (), &t)
467 : 7865392 : || converting_ISO_generic (location, type, value,
468 : : m2type_GetISOLocType (), &t)
469 : 7795010 : || converting_ISO_generic (location, type, value,
470 : : m2type_GetISOByteType (), &t)
471 : 7795010 : || converting_ISO_generic (location, type, value,
472 : : m2type_GetISOWordType (), &t)
473 : 7795010 : || converting_ISO_generic (location, type, value, m2type_GetM2Word16 (),
474 : : &t)
475 : 7795010 : || converting_ISO_generic (location, type, value, m2type_GetM2Word32 (),
476 : : &t)
477 : 15745220 : || converting_ISO_generic (location, type, value, m2type_GetM2Word64 (),
478 : : &t))
479 : 155200 : return t;
480 : :
481 : 7795010 : if (TREE_CODE (type) == ARRAY_TYPE
482 : 7795010 : && TREE_TYPE (type) == m2type_GetM2CharType ())
483 : : {
484 : 66 : if (TREE_TYPE (value) == m2type_GetM2CharType ())
485 : :
486 : : /* Passing a const char to an array [..] of char. So we convert
487 : : const char into the correct length string. */
488 : 24 : return convert_char_to_array (location, type, value);
489 : 42 : if (TREE_CODE (value) == STRING_CST)
490 : : /* Convert a string into an array constant, padding with zeros if
491 : : necessary. */
492 : 0 : return convert_string_to_array (location, type, value);
493 : : }
494 : :
495 : 7794986 : if (checkOverflow)
496 : 688789 : return convert_and_check (location, type, value);
497 : : else
498 : 7106197 : return convert_loc (location, type, value);
499 : : }
500 : :
501 : : /* const_to_ISO_type - perform VAL (iso_type, expr). */
502 : :
503 : : static tree
504 : 153890 : const_to_ISO_type (location_t location, tree expr, tree iso_type)
505 : : {
506 : 153890 : tree n = m2expr_GetSizeOf (location, iso_type);
507 : :
508 : 153890 : if ((m2expr_CompareTrees (n, m2decl_BuildIntegerConstant (1)) == 0)
509 : 153890 : && (iso_type == m2type_GetByteType ()
510 : 70374 : || iso_type == m2type_GetISOLocType ()
511 : 0 : || iso_type == m2type_GetISOByteType ()))
512 : 153866 : return build1 (NOP_EXPR, iso_type, expr);
513 : 24 : return const_to_ISO_aggregate_type (location, expr, iso_type);
514 : : }
515 : :
516 : : /* const_to_ISO_aggregate_type - perform VAL (iso_type, expr). The
517 : : iso_type will be declared by the SYSTEM module as: TYPE iso_type =
518 : : ARRAY [0..n] OF LOC
519 : :
520 : : this function will store a constant into the iso_type in the correct
521 : : endian order. It converts the expr into a unsigned int or signed
522 : : int and then strips it a byte at a time. */
523 : :
524 : : static tree
525 : 24 : const_to_ISO_aggregate_type (location_t location, tree expr, tree iso_type)
526 : : {
527 : 24 : tree byte;
528 : 24 : m2type_Constructor c;
529 : 24 : tree i = m2decl_BuildIntegerConstant (0);
530 : 24 : tree n = m2expr_GetSizeOf (location, iso_type);
531 : 24 : tree max_uint = m2decl_BuildIntegerConstant (256);
532 : :
533 : 144 : while (m2expr_CompareTrees (i, n) < 0)
534 : : {
535 : 96 : max_uint = m2expr_BuildMult (location, max_uint,
536 : : m2decl_BuildIntegerConstant (256), false);
537 : 96 : i = m2expr_BuildAdd (location, i, m2decl_BuildIntegerConstant (1),
538 : : false);
539 : : }
540 : 24 : max_uint = m2expr_BuildDivFloor (location, max_uint,
541 : : m2decl_BuildIntegerConstant (2), false);
542 : :
543 : 24 : if (m2expr_CompareTrees (expr, m2decl_BuildIntegerConstant (0)) < 0)
544 : 0 : expr = m2expr_BuildAdd (location, expr, max_uint, false);
545 : :
546 : 24 : i = m2decl_BuildIntegerConstant (0);
547 : 24 : c = m2type_BuildStartArrayConstructor (iso_type);
548 : 144 : while (m2expr_CompareTrees (i, n) < 0)
549 : : {
550 : 96 : byte = m2expr_BuildModTrunc (location, expr,
551 : : m2decl_BuildIntegerConstant (256), false);
552 : 96 : if (BYTES_BIG_ENDIAN)
553 : : m2type_BuildArrayConstructorElement (
554 : : c, m2convert_ToLoc (location, byte),
555 : : m2expr_BuildSub (location, m2expr_BuildSub (location, n, i, false),
556 : : m2decl_BuildIntegerConstant (1), false));
557 : : else
558 : 96 : m2type_BuildArrayConstructorElement (
559 : : c, m2convert_ToLoc (location, byte), i);
560 : :
561 : 96 : i = m2expr_BuildAdd (location, i, m2decl_BuildIntegerConstant (1),
562 : : false);
563 : 96 : expr = m2expr_BuildDivFloor (location, expr,
564 : : m2decl_BuildIntegerConstant (256), false);
565 : : }
566 : :
567 : 24 : return m2type_BuildEndArrayConstructor (c);
568 : : }
569 : :
570 : : /* ConvertConstantAndCheck - in Modula-2 sementics: RETURN( VAL(type,
571 : : expr) ). Only to be used for a constant expr, overflow checking
572 : : is performed. */
573 : :
574 : : tree
575 : 1793754 : m2convert_ConvertConstantAndCheck (location_t location, tree type, tree expr)
576 : : {
577 : 1793754 : tree etype;
578 : 1793754 : expr = fold (expr);
579 : 1793754 : STRIP_NOPS (expr);
580 : 1793754 : expr = m2expr_FoldAndStrip (expr);
581 : 1793754 : etype = TREE_TYPE (expr);
582 : :
583 : 1793754 : m2assert_AssertLocation (location);
584 : 1793754 : if (etype == type)
585 : : return expr;
586 : :
587 : 732472 : if (TREE_CODE (expr) == FUNCTION_DECL)
588 : 0 : expr = m2expr_BuildAddr (location, expr, false);
589 : :
590 : 732472 : type = m2tree_skip_type_decl (type);
591 : 1464934 : if (type == m2type_GetByteType () || type == m2type_GetISOLocType ()
592 : 732462 : || type == m2type_GetISOByteType () || type == m2type_GetISOWordType ()
593 : 732438 : || type == m2type_GetM2Word16 () || type == m2type_GetM2Word32 ()
594 : 1464910 : || type == m2type_GetM2Word64 ())
595 : 34 : return const_to_ISO_type (location, expr, type);
596 : :
597 : 732438 : return convert_and_check (location, type, m2expr_FoldAndStrip (expr));
598 : : }
599 : :
600 : : /* ToWord - converts an expression (Integer or Ordinal type) into a
601 : : WORD. */
602 : :
603 : : tree
604 : 550958 : m2convert_ToWord (location_t location, tree expr)
605 : : {
606 : 550958 : return m2convert_BuildConvert (location, m2type_GetWordType (), expr, false);
607 : : }
608 : :
609 : : /* ToCardinal - convert an expression, expr, to a CARDINAL. */
610 : :
611 : : tree
612 : 197664 : m2convert_ToCardinal (location_t location, tree expr)
613 : : {
614 : 197664 : return m2convert_BuildConvert (location, m2type_GetCardinalType (), expr,
615 : 197664 : false);
616 : : }
617 : :
618 : : /* convertToPtr - if the type of tree, t, is not a ptr_type_node then
619 : : convert it. */
620 : :
621 : : tree
622 : 84077 : m2convert_convertToPtr (location_t location, tree type)
623 : : {
624 : 84077 : if (TREE_CODE (TREE_TYPE (type)) == POINTER_TYPE)
625 : : return type;
626 : : else
627 : 84077 : return m2convert_BuildConvert (location, m2type_GetPointerType (), type,
628 : 84077 : false);
629 : : }
630 : :
631 : : /* ToInteger - convert an expression, expr, to an INTEGER. */
632 : :
633 : : tree
634 : 500814 : m2convert_ToInteger (location_t location, tree expr)
635 : : {
636 : 500814 : return m2convert_BuildConvert (location, m2type_GetIntegerType (), expr,
637 : 500814 : false);
638 : : }
639 : :
640 : : /* ToBitset - convert an expression, expr, to a BITSET type. */
641 : :
642 : : tree
643 : 14978 : m2convert_ToBitset (location_t location, tree expr)
644 : : {
645 : 14978 : return m2convert_BuildConvert (location, m2type_GetBitsetType (), expr,
646 : 14978 : false);
647 : : }
648 : :
649 : : /* ToLoc - convert an expression, expr, to a LOC. */
650 : :
651 : : tree
652 : 96 : m2convert_ToLoc (location_t location, tree expr)
653 : : {
654 : 96 : return m2convert_BuildConvert (location, m2type_GetISOByteType (), expr,
655 : 96 : false);
656 : : }
657 : :
658 : : /* ToPIMByte - convert an expression expr to a PIM BYTE. */
659 : :
660 : : tree
661 : 83416 : m2convert_ToPIMByte (location_t location, tree expr)
662 : : {
663 : 83416 : return m2convert_BuildConvert (location, m2type_GetByteType (), expr,
664 : 83416 : false);
665 : : }
666 : :
667 : : /* GenericToType - converts, expr, into, type, providing that expr is
668 : : a generic system type (byte, word etc). Otherwise expr is
669 : : returned unaltered. */
670 : :
671 : : tree
672 : 4304946 : m2convert_GenericToType (location_t location, tree type, tree expr)
673 : : {
674 : 4304946 : tree etype = TREE_TYPE (expr);
675 : :
676 : 4304946 : type = m2tree_skip_type_decl (type);
677 : 4304946 : if (type == etype)
678 : : return expr;
679 : :
680 : 8609892 : if (type == m2type_GetISOWordType () || type == m2type_GetM2Word16 ()
681 : 8609892 : || type == m2type_GetM2Word32 () || type == m2type_GetM2Word64 ())
682 : 0 : return const_to_ISO_type (location, expr, type);
683 : :
684 : : return expr;
685 : : }
|
