1 /* m2convert.c provides GCC tree conversion for the Modula-2 language.
3 Copyright (C) 2012-2022 Free Software Foundation, Inc.
4 Contributed by Gaius Mulley <gaius@glam.ac.uk>.
6 This file is part of GNU Modula-2.
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)
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.
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/>. */
22 #include "gcc-consolidation.h"
24 #include "../gm2-lang.h"
25 #include "../m2-tree.h"
30 #include "m2convert.h"
34 #include "m2statement.h"
36 #include "m2treelib.h"
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
,
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
57 /* ConvertString - converts string, expr, into a string of type,
61 m2convert_ConvertString (tree type
, tree expr
)
63 const char *str
= TREE_STRING_POINTER (expr
);
64 int len
= TREE_STRING_LENGTH (expr
);
65 return m2decl_BuildStringConstantType (len
, str
, type
);
69 /* (taken from c-common.c and trimmed for Modula-2)
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. */
83 enum conversion_safety
84 unsafe_conversion_p (location_t loc
, tree type
, tree expr
, bool produce_warns
)
86 enum conversion_safety give_warning
= SAFE_CONVERSION
; /* is 0 or false. */
87 tree expr_type
= TREE_TYPE (expr
);
89 if (TREE_CODE (expr
) == REAL_CST
|| TREE_CODE (expr
) == INTEGER_CST
)
92 /* Warn for real constant that is not an exact integer converted to
94 if (TREE_CODE (expr_type
) == REAL_TYPE
95 && TREE_CODE (type
) == INTEGER_TYPE
)
97 if (!real_isinteger (TREE_REAL_CST_PTR (expr
),
98 TYPE_MODE (expr_type
)))
99 give_warning
= UNSAFE_REAL
;
101 /* Warn for an integer constant that does not fit into integer type. */
102 else if (TREE_CODE (expr_type
) == INTEGER_TYPE
103 && TREE_CODE (type
) == INTEGER_TYPE
104 && !int_fits_type_p (expr
, type
))
106 if (TYPE_UNSIGNED (type
) && !TYPE_UNSIGNED (expr_type
)
107 && tree_int_cst_sgn (expr
) < 0)
110 warning_at (loc
, OPT_Wsign_conversion
,
112 " implicitly converted to unsigned type");
114 else if (!TYPE_UNSIGNED (type
) && TYPE_UNSIGNED (expr_type
))
117 warning_at (loc
, OPT_Wsign_conversion
,
118 "conversion of unsigned"
119 " constant value to negative integer");
122 give_warning
= UNSAFE_OTHER
;
124 else if (TREE_CODE (type
) == REAL_TYPE
)
126 /* Warn for an integer constant that does not fit into real type. */
127 if (TREE_CODE (expr_type
) == INTEGER_TYPE
)
129 REAL_VALUE_TYPE a
= real_value_from_int_cst (0, expr
);
130 if (!exact_real_truncate (TYPE_MODE (type
), &a
))
131 give_warning
= UNSAFE_REAL
;
134 /* Warn for a real constant that does not fit into a smaller real
136 else if (TREE_CODE (expr_type
) == REAL_TYPE
137 && TYPE_PRECISION (type
) < TYPE_PRECISION (expr_type
))
139 REAL_VALUE_TYPE a
= TREE_REAL_CST (expr
);
140 if (!exact_real_truncate (TYPE_MODE (type
), &a
))
141 give_warning
= UNSAFE_REAL
;
147 /* Warn for real types converted to integer types. */
148 if (TREE_CODE (expr_type
) == REAL_TYPE
149 && TREE_CODE (type
) == INTEGER_TYPE
)
150 give_warning
= UNSAFE_REAL
;
157 /* (taken from c-common.c and trimmed for Modula-2)
159 Warns if the conversion of EXPR to TYPE may alter a value. This is a
160 helper function for warnings_for_convert_and_check. */
163 conversion_warning (location_t loc
, tree type
, tree expr
)
165 tree expr_type
= TREE_TYPE (expr
);
166 enum conversion_safety conversion_kind
;
168 if (!warn_conversion
&& !warn_sign_conversion
&& !warn_float_conversion
)
171 switch (TREE_CODE (expr
))
179 case TRUTH_ANDIF_EXPR
:
180 case TRUTH_ORIF_EXPR
:
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
189 if (TYPE_PRECISION (type
) == 1 && !TYPE_UNSIGNED (type
))
190 warning_at (loc
, OPT_Wconversion
,
191 "conversion to %qT from boolean expression", type
);
196 conversion_kind
= unsafe_conversion_p (loc
, type
, expr
, true);
197 if (conversion_kind
== UNSAFE_REAL
)
198 warning_at (loc
, OPT_Wfloat_conversion
,
199 "conversion to %qT alters %qT constant value", type
,
201 else if (conversion_kind
)
202 warning_at (loc
, OPT_Wconversion
,
203 "conversion to %qT alters %qT constant value", type
,
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 tree op1
= TREE_OPERAND (expr
, 1);
213 tree op2
= TREE_OPERAND (expr
, 2);
215 conversion_warning (loc
, type
, op1
);
216 conversion_warning (loc
, type
, op2
);
220 default: /* 'expr' is not a constant. */
221 conversion_kind
= unsafe_conversion_p (loc
, type
, expr
, true);
222 if (conversion_kind
== UNSAFE_REAL
)
223 warning_at (loc
, OPT_Wfloat_conversion
,
224 "conversion to %qT from %qT may alter its value", type
,
226 else if (conversion_kind
)
227 warning_at (loc
, OPT_Wconversion
,
228 "conversion to %qT from %qT may alter its value", type
,
233 /* (taken from c-common.c and trimmed for Modula-2)
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. */
240 warnings_for_convert_and_check (location_t loc
, tree type
, tree expr
,
243 if (TREE_CODE (expr
) == INTEGER_CST
&& (TREE_CODE (type
) == INTEGER_TYPE
244 || TREE_CODE (type
) == ENUMERAL_TYPE
)
245 && !int_fits_type_p (expr
, type
))
248 /* Do not diagnose overflow in a constant expression merely because a
249 conversion overflowed. */
250 if (TREE_OVERFLOW (result
))
251 TREE_OVERFLOW (result
) = TREE_OVERFLOW (expr
);
253 if (TYPE_UNSIGNED (type
))
256 /* This detects cases like converting -129 or 256 to unsigned char.
258 if (!int_fits_type_p (expr
, m2type_gm2_signed_type (type
)))
259 warning_at (loc
, OPT_Woverflow
,
260 "large integer implicitly truncated to unsigned type");
262 conversion_warning (loc
, type
, expr
);
264 else if (!int_fits_type_p (expr
, m2type_gm2_unsigned_type (type
)))
265 warning_at (loc
, OPT_Woverflow
,
266 "overflow in implicit constant conversion");
267 /* No warning for converting 0x80000000 to int. */
268 else if (pedantic
&& (TREE_CODE (TREE_TYPE (expr
)) != INTEGER_TYPE
269 || TYPE_PRECISION (TREE_TYPE (expr
))
270 != TYPE_PRECISION (type
)))
271 warning_at (loc
, OPT_Woverflow
,
272 "overflow in implicit constant conversion");
275 conversion_warning (loc
, type
, expr
);
277 else if ((TREE_CODE (result
) == INTEGER_CST
278 || TREE_CODE (result
) == FIXED_CST
)
279 && TREE_OVERFLOW (result
))
280 warning_at (loc
, OPT_Woverflow
,
281 "overflow in implicit constant conversion");
283 conversion_warning (loc
, type
, expr
);
286 /* (taken from c-common.c and trimmed for Modula-2)
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. */
294 convert_and_check (location_t loc
, tree type
, tree expr
)
297 tree expr_for_warning
;
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 if (TREE_CODE (expr
) == EXCESS_PRECISION_EXPR
)
304 tree orig_type
= TREE_TYPE (expr
);
305 expr
= TREE_OPERAND (expr
, 0);
306 expr_for_warning
= convert (orig_type
, expr
);
307 if (orig_type
== type
)
308 return expr_for_warning
;
311 expr_for_warning
= expr
;
313 if (TREE_TYPE (expr
) == type
)
316 result
= convert_loc (loc
, type
, expr
);
318 if (!TREE_OVERFLOW_P (expr
) && result
!= error_mark_node
)
319 warnings_for_convert_and_check (loc
, type
, expr_for_warning
, result
);
326 doOrdinal (tree value
)
328 if (TREE_CODE (value
) == STRING_CST
&& (m2expr_StringLength (value
) <= 1))
330 const char *p
= TREE_STRING_POINTER (value
);
333 return m2decl_BuildIntegerConstant (i
);
339 same_size_types (location_t location
, tree t1
, tree t2
)
341 tree n1
= m2expr_GetSizeOf (location
, t1
);
342 tree n2
= m2expr_GetSizeOf (location
, t2
);
344 return m2expr_CompareTrees (n1
, n2
) == 0;
348 converting_ISO_generic (location_t location
, tree type
, tree value
,
349 tree generic_type
, tree
*result
)
351 tree value_type
= m2tree_skip_type_decl (TREE_TYPE (value
));
353 if (value_type
== type
)
354 /* we let the caller deal with this. */
357 if ((TREE_CODE (value
) == INTEGER_CST
) && (type
== generic_type
))
359 *result
= const_to_ISO_type (location
, value
, generic_type
);
363 if (same_size_types (location
, type
, value_type
))
365 if (value_type
== generic_type
)
367 tree pt
= build_pointer_type (type
);
368 tree a
= build1 (ADDR_EXPR
, pt
, value
);
369 tree t
= build1 (INDIRECT_REF
, type
, a
);
370 *result
= build1 (NOP_EXPR
, type
, t
);
373 else if (type
== generic_type
)
375 tree pt
= build_pointer_type (type
);
376 tree a
= build1 (ADDR_EXPR
, pt
, value
);
377 tree t
= build1 (INDIRECT_REF
, type
, a
);
378 *result
= build1 (NOP_EXPR
, type
, t
);
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. */
391 convert_char_to_array (location_t location
, tree type
, tree value
)
393 tree i
= m2decl_BuildIntegerConstant (0);
394 struct struct_constructor
*c
395 = (struct struct_constructor
*)m2type_BuildStartArrayConstructor (type
);
396 tree n
= m2type_GetArrayNoOfElements (location
, type
);
401 /* store the initial char. */
402 m2type_BuildArrayConstructorElement (c
, value
, i
);
403 i
= m2expr_BuildAdd (location
, i
, m2decl_BuildIntegerConstant (1), FALSE
);
405 /* now pad out the remaining elements with nul chars. */
406 while (m2expr_CompareTrees (i
, n
) < 0)
408 m2type_BuildArrayConstructorElement (
409 c
, m2type_BuildCharConstant (location
, &nul
[0]), i
);
410 i
= m2expr_BuildAdd (location
, i
, m2decl_BuildIntegerConstant (1),
413 return m2type_BuildEndArrayConstructor (c
);
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. */
421 convert_string_to_array (location_t location
, tree type
, tree value
)
423 tree n
= m2type_GetArrayNoOfElements (location
, type
);
425 return m2type_BuildArrayStringConstructor (location
, type
, value
, n
);
428 /* BuildConvert - build and return tree VAL (type, value).
429 checkOverflow determines whether we should suppress overflow
433 m2convert_BuildConvert (location_t location
, tree type
, tree value
,
436 type
= m2tree_skip_type_decl (type
);
439 value
= fold (value
);
441 value
= m2expr_FoldAndStrip (value
);
443 if (TREE_CODE (value
) == STRING_CST
&& (m2expr_StringLength (value
) <= 1)
444 && (m2tree_IsOrdinal (type
)))
445 value
= doOrdinal (value
);
446 else if (TREE_CODE (value
) == FUNCTION_DECL
&& TREE_TYPE (value
) != type
)
447 value
= m2expr_BuildAddr (0, value
, FALSE
);
449 if (converting_ISO_generic (location
, type
, value
, m2type_GetByteType (), &t
)
450 || converting_ISO_generic (location
, type
, value
,
451 m2type_GetISOLocType (), &t
)
452 || converting_ISO_generic (location
, type
, value
,
453 m2type_GetISOByteType (), &t
)
454 || converting_ISO_generic (location
, type
, value
,
455 m2type_GetISOWordType (), &t
)
456 || converting_ISO_generic (location
, type
, value
, m2type_GetM2Word16 (),
458 || converting_ISO_generic (location
, type
, value
, m2type_GetM2Word32 (),
460 || converting_ISO_generic (location
, type
, value
, m2type_GetM2Word64 (),
464 if (TREE_CODE (type
) == ARRAY_TYPE
465 && TREE_TYPE (type
) == m2type_GetM2CharType ())
467 if (TREE_TYPE (value
) == m2type_GetM2CharType ())
469 /* passing a const char to an array [..] of char. So we convert
470 const char into the correct length string. */
471 return convert_char_to_array (location
, type
, value
);
472 if (TREE_CODE (value
) == STRING_CST
)
473 /* convert a string into an array constant, padding with zeros if
475 return convert_string_to_array (location
, type
, value
);
479 return convert_and_check (location
, type
, value
);
481 return convert (type
, value
);
484 /* const_to_ISO_type - perform VAL (iso_type, expr). */
487 const_to_ISO_type (location_t location
, tree expr
, tree iso_type
)
489 tree n
= m2expr_GetSizeOf (location
, iso_type
);
491 if ((m2expr_CompareTrees (n
, m2decl_BuildIntegerConstant (1)) == 0)
492 && (iso_type
== m2type_GetByteType ()
493 || iso_type
== m2type_GetISOLocType ()
494 || iso_type
== m2type_GetISOByteType ()))
495 return build1 (NOP_EXPR
, iso_type
, expr
);
496 return const_to_ISO_aggregate_type (location
, expr
, iso_type
);
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 =
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. */
508 const_to_ISO_aggregate_type (location_t location
, tree expr
, tree iso_type
)
511 m2type_Constructor c
;
512 tree i
= m2decl_BuildIntegerConstant (0);
513 tree n
= m2expr_GetSizeOf (location
, iso_type
);
514 tree max_uint
= m2decl_BuildIntegerConstant (256);
516 while (m2expr_CompareTrees (i
, n
) < 0)
518 max_uint
= m2expr_BuildMult (location
, max_uint
,
519 m2decl_BuildIntegerConstant (256), FALSE
);
520 i
= m2expr_BuildAdd (location
, i
, m2decl_BuildIntegerConstant (1),
523 max_uint
= m2expr_BuildDivFloor (location
, max_uint
,
524 m2decl_BuildIntegerConstant (2), FALSE
);
526 if (m2expr_CompareTrees (expr
, m2decl_BuildIntegerConstant (0)) < 0)
527 expr
= m2expr_BuildAdd (location
, expr
, max_uint
, FALSE
);
529 i
= m2decl_BuildIntegerConstant (0);
530 c
= m2type_BuildStartArrayConstructor (iso_type
);
531 while (m2expr_CompareTrees (i
, n
) < 0)
533 byte
= m2expr_BuildModTrunc (location
, expr
,
534 m2decl_BuildIntegerConstant (256), FALSE
);
535 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
));
541 m2type_BuildArrayConstructorElement (
542 c
, m2convert_ToLoc (location
, byte
), i
);
544 i
= m2expr_BuildAdd (location
, i
, m2decl_BuildIntegerConstant (1),
546 expr
= m2expr_BuildDivFloor (location
, expr
,
547 m2decl_BuildIntegerConstant (256), FALSE
);
550 return m2type_BuildEndArrayConstructor (c
);
553 /* ConvertConstantAndCheck - in Modula-2 sementics: RETURN( VAL(type,
554 expr) ). Only to be used for a constant expr, overflow checking
558 m2convert_ConvertConstantAndCheck (location_t location
, tree type
, tree expr
)
563 expr
= m2expr_FoldAndStrip (expr
);
564 etype
= TREE_TYPE (expr
);
566 m2assert_AssertLocation (location
);
570 if (TREE_CODE (expr
) == FUNCTION_DECL
)
571 expr
= m2expr_BuildAddr (location
, expr
, FALSE
);
573 type
= m2tree_skip_type_decl (type
);
574 if (type
== m2type_GetByteType () || type
== m2type_GetISOLocType ()
575 || type
== m2type_GetISOByteType () || type
== m2type_GetISOWordType ()
576 || type
== m2type_GetM2Word16 () || type
== m2type_GetM2Word32 ()
577 || type
== m2type_GetM2Word64 ())
578 return const_to_ISO_type (location
, expr
, type
);
580 return convert_and_check (location
, type
, m2expr_FoldAndStrip (expr
));
583 /* ToWord - converts an expression (Integer or Ordinal type) into a
587 m2convert_ToWord (location_t location
, tree expr
)
589 return m2convert_BuildConvert (location
, m2type_GetWordType (), expr
, FALSE
);
592 /* ToCardinal - convert an expression, expr, to a CARDINAL. */
595 m2convert_ToCardinal (location_t location
, tree expr
)
597 return m2convert_BuildConvert (location
, m2type_GetCardinalType (), expr
,
601 /* convertToPtr - if the type of tree, t, is not a ptr_type_node then
605 m2convert_convertToPtr (location_t location
, tree type
)
607 if (TREE_CODE (TREE_TYPE (type
)) == POINTER_TYPE
)
610 return m2convert_BuildConvert (location
, m2type_GetPointerType (), type
,
614 /* ToInteger - convert an expression, expr, to an INTEGER. */
617 m2convert_ToInteger (location_t location
, tree expr
)
619 return m2convert_BuildConvert (location
, m2type_GetIntegerType (), expr
,
623 /* ToBitset - convert an expression, expr, to a BITSET type. */
626 m2convert_ToBitset (location_t location
, tree expr
)
628 return m2convert_BuildConvert (location
, m2type_GetBitsetType (), expr
,
632 /* ToLoc - convert an expression, expr, to a LOC. */
635 m2convert_ToLoc (location_t location
, tree expr
)
637 return m2convert_BuildConvert (location
, m2type_GetISOByteType (), expr
,
641 /* GenericToType - converts, expr, into, type, providing that expr is
642 a generic system type (byte, word etc). Otherwise expr is
643 returned unaltered. */
646 m2convert_GenericToType (location_t location
, tree type
, tree expr
)
648 tree etype
= TREE_TYPE (expr
);
650 type
= m2tree_skip_type_decl (type
);
654 if (type
== m2type_GetISOWordType () || type
== m2type_GetM2Word16 ()
655 || type
== m2type_GetM2Word32 () || type
== m2type_GetM2Word64 ())
656 return const_to_ISO_type (location
, expr
, type
);