Branch data Line data Source code
1 : : /* Translation of constants
2 : : Copyright (C) 2002-2024 Free Software Foundation, Inc.
3 : : Contributed by Paul Brook
4 : :
5 : : This file is part of GCC.
6 : :
7 : : GCC is free software; you can redistribute it and/or modify it under
8 : : the terms of the GNU General Public License as published by the Free
9 : : Software Foundation; either version 3, or (at your option) any later
10 : : version.
11 : :
12 : : GCC is distributed in the hope that it will be useful, but WITHOUT ANY
13 : : WARRANTY; without even the implied warranty of MERCHANTABILITY or
14 : : FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
15 : : for more details.
16 : :
17 : : You should have received a copy of the GNU General Public License
18 : : along with GCC; see the file COPYING3. If not see
19 : : <http://www.gnu.org/licenses/>. */
20 : :
21 : : /* trans-const.cc -- convert constant values */
22 : :
23 : : #include "config.h"
24 : : #include "system.h"
25 : : #include "coretypes.h"
26 : : #include "tree.h"
27 : : #include "gfortran.h"
28 : : #include "options.h"
29 : : #include "trans.h"
30 : : #include "fold-const.h"
31 : : #include "stor-layout.h"
32 : : #include "realmpfr.h"
33 : : #include "trans-const.h"
34 : : #include "trans-types.h"
35 : : #include "target-memory.h"
36 : :
37 : : tree gfc_rank_cst[GFC_MAX_DIMENSIONS + 1];
38 : :
39 : : /* Build a constant with given type from an int_cst. */
40 : :
41 : : tree
42 : 3166 : gfc_build_const (tree type, tree intval)
43 : : {
44 : 3166 : tree val;
45 : 3166 : tree zero;
46 : :
47 : 3166 : switch (TREE_CODE (type))
48 : : {
49 : 1721 : case INTEGER_TYPE:
50 : 1721 : val = convert (type, intval);
51 : 1721 : break;
52 : :
53 : 1243 : case REAL_TYPE:
54 : 1243 : val = build_real_from_int_cst (type, intval);
55 : 1243 : break;
56 : :
57 : 202 : case COMPLEX_TYPE:
58 : 202 : val = build_real_from_int_cst (TREE_TYPE (type), intval);
59 : 202 : zero = build_real_from_int_cst (TREE_TYPE (type), integer_zero_node);
60 : 202 : val = build_complex (type, val, zero);
61 : 202 : break;
62 : :
63 : 0 : default:
64 : 0 : gcc_unreachable ();
65 : : }
66 : 3166 : return val;
67 : : }
68 : :
69 : : /* Build a string constant with C char type. */
70 : :
71 : : tree
72 : 242264 : gfc_build_string_const (size_t length, const char *s)
73 : : {
74 : 242264 : tree str;
75 : 242264 : tree len;
76 : :
77 : 242264 : str = build_string (length, s);
78 : 242264 : len = size_int (length);
79 : 242264 : TREE_TYPE (str) =
80 : 242264 : build_array_type (gfc_character1_type_node,
81 : : build_range_type (gfc_charlen_type_node,
82 : : size_one_node, len));
83 : 242264 : TYPE_STRING_FLAG (TREE_TYPE (str)) = 1;
84 : 242264 : return str;
85 : : }
86 : :
87 : :
88 : : /* Build a string constant with a type given by its kind; take care of
89 : : non-default character kinds. */
90 : :
91 : : tree
92 : 140693 : gfc_build_wide_string_const (int kind, size_t length, const gfc_char_t *string)
93 : : {
94 : 140693 : int i;
95 : 140693 : tree str, len;
96 : 140693 : size_t size;
97 : 140693 : char *s;
98 : :
99 : 140693 : i = gfc_validate_kind (BT_CHARACTER, kind, false);
100 : 140693 : size = length * gfc_character_kinds[i].bit_size / 8;
101 : :
102 : 140693 : s = XCNEWVAR (char, size);
103 : 140693 : gfc_encode_character (kind, length, string, (unsigned char *) s, size);
104 : :
105 : 140693 : str = build_string (size, s);
106 : 140693 : free (s);
107 : :
108 : 140693 : len = size_int (length);
109 : 140693 : TREE_TYPE (str) =
110 : 140693 : build_array_type (gfc_get_char_type (kind),
111 : : build_range_type (gfc_charlen_type_node,
112 : : size_one_node, len));
113 : 140693 : TYPE_STRING_FLAG (TREE_TYPE (str)) = 1;
114 : 140693 : return str;
115 : : }
116 : :
117 : :
118 : : /* Build a Fortran character constant from a zero-terminated string.
119 : : There a two version of this function, one that translates the string
120 : : and one that doesn't. */
121 : : tree
122 : 67837 : gfc_build_cstring_const (const char *string)
123 : : {
124 : 67837 : return gfc_build_string_const (strlen (string) + 1, string);
125 : : }
126 : :
127 : : tree
128 : 166742 : gfc_build_localized_cstring_const (const char *msgid)
129 : : {
130 : 166742 : const char *localized = _(msgid);
131 : 166742 : return gfc_build_string_const (strlen (localized) + 1, localized);
132 : : }
133 : :
134 : :
135 : : /* Return a string constant with the given length. Used for static
136 : : initializers. The constant will be padded or truncated to match
137 : : length. */
138 : :
139 : : tree
140 : 2551 : gfc_conv_string_init (tree length, gfc_expr * expr)
141 : : {
142 : 2551 : gfc_char_t *s;
143 : 2551 : HOST_WIDE_INT len;
144 : 2551 : gfc_charlen_t slen;
145 : 2551 : tree str;
146 : 2551 : bool free_s = false;
147 : :
148 : 2551 : gcc_assert (expr->expr_type == EXPR_CONSTANT);
149 : 2551 : gcc_assert (expr->ts.type == BT_CHARACTER);
150 : 2551 : gcc_assert (tree_fits_uhwi_p (length));
151 : :
152 : 2551 : len = TREE_INT_CST_LOW (length);
153 : 2551 : slen = expr->value.character.length;
154 : :
155 : 2551 : if (len > slen)
156 : : {
157 : 0 : s = gfc_get_wide_string (len);
158 : 0 : memcpy (s, expr->value.character.string, slen * sizeof (gfc_char_t));
159 : 0 : gfc_wide_memset (&s[slen], ' ', len - slen);
160 : 0 : free_s = true;
161 : : }
162 : : else
163 : 2551 : s = expr->value.character.string;
164 : :
165 : 2551 : str = gfc_build_wide_string_const (expr->ts.kind, len, s);
166 : :
167 : 2551 : if (free_s)
168 : 0 : free (s);
169 : :
170 : 2551 : return str;
171 : : }
172 : :
173 : :
174 : : /* Create a tree node for the string length if it is constant. */
175 : :
176 : : void
177 : 34222 : gfc_conv_const_charlen (gfc_charlen * cl)
178 : : {
179 : 34222 : if (!cl || cl->backend_decl)
180 : : return;
181 : :
182 : 31734 : if (cl->length && cl->length->expr_type == EXPR_CONSTANT)
183 : : {
184 : 18473 : cl->backend_decl = gfc_conv_mpz_to_tree (cl->length->value.integer,
185 : : cl->length->ts.kind);
186 : 18473 : cl->backend_decl = fold_convert (gfc_charlen_type_node,
187 : : cl->backend_decl);
188 : : }
189 : : }
190 : :
191 : : void
192 : 30446 : gfc_init_constants (void)
193 : : {
194 : 30446 : int n;
195 : :
196 : 517582 : for (n = 0; n <= GFC_MAX_DIMENSIONS; n++)
197 : 487136 : gfc_rank_cst[n] = build_int_cst (gfc_array_index_type, n);
198 : 30446 : }
199 : :
200 : : /* Converts a GMP integer into a backend tree node. */
201 : :
202 : : tree
203 : 2065617 : gfc_conv_mpz_to_tree (mpz_t i, int kind)
204 : : {
205 : 2065617 : wide_int val = wi::from_mpz (gfc_get_int_type (kind), i, true);
206 : 2065617 : return wide_int_to_tree (gfc_get_int_type (kind), val);
207 : 2065617 : }
208 : :
209 : : /* Same, but for unsigned. */
210 : :
211 : : tree
212 : 2987 : gfc_conv_mpz_unsigned_to_tree (mpz_t i, int kind)
213 : : {
214 : 2987 : wide_int val = wi:: from_mpz (gfc_get_unsigned_type (kind), i, true);
215 : 2987 : return wide_int_to_tree (gfc_get_unsigned_type (kind), val);
216 : 2987 : }
217 : :
218 : : /* Convert a GMP integer into a tree node of type given by the type
219 : : argument. */
220 : :
221 : : tree
222 : 28 : gfc_conv_mpz_to_tree_type (mpz_t i, const tree type)
223 : : {
224 : 28 : const wide_int val = wi::from_mpz (type, i, true);
225 : 28 : return wide_int_to_tree (type, val);
226 : 28 : }
227 : :
228 : :
229 : : /* Converts a backend tree into a GMP integer. */
230 : :
231 : : void
232 : 2202 : gfc_conv_tree_to_mpz (mpz_t i, tree source)
233 : : {
234 : 2202 : wi::to_mpz (wi::to_wide (source), i, TYPE_SIGN (TREE_TYPE (source)));
235 : 2202 : }
236 : :
237 : : /* Converts a real constant into backend form. */
238 : :
239 : : tree
240 : 134871 : gfc_conv_mpfr_to_tree (mpfr_t f, int kind, int is_snan)
241 : : {
242 : 134871 : tree type;
243 : 134871 : int n;
244 : 134871 : REAL_VALUE_TYPE real;
245 : :
246 : 134871 : n = gfc_validate_kind (BT_REAL, kind, false);
247 : 134871 : gcc_assert (gfc_real_kinds[n].radix == 2);
248 : :
249 : 134871 : type = gfc_get_real_type (kind);
250 : 134871 : if (mpfr_nan_p (f) && is_snan)
251 : 0 : real_from_string (&real, "SNaN");
252 : : else
253 : 134871 : real_from_mpfr (&real, f, type, GFC_RND_MODE);
254 : :
255 : 134871 : return build_real (type, real);
256 : : }
257 : :
258 : : /* Returns a real constant that is +Infinity if the target
259 : : supports infinities for this floating-point mode, and
260 : : +HUGE_VAL otherwise (the largest representable number). */
261 : :
262 : : tree
263 : 4596 : gfc_build_inf_or_huge (tree type, int kind)
264 : : {
265 : 4596 : if (HONOR_INFINITIES (TYPE_MODE (type)))
266 : : {
267 : 4596 : REAL_VALUE_TYPE real;
268 : 4596 : real_inf (&real);
269 : 4596 : return build_real (type, real);
270 : : }
271 : : else
272 : : {
273 : 0 : int k = gfc_validate_kind (BT_REAL, kind, false);
274 : 0 : return gfc_conv_mpfr_to_tree (gfc_real_kinds[k].huge, kind, 0);
275 : : }
276 : : }
277 : :
278 : : /* Returns a floating-point NaN of a given type. */
279 : :
280 : : tree
281 : 1632 : gfc_build_nan (tree type, const char *str)
282 : : {
283 : 1632 : REAL_VALUE_TYPE real;
284 : 1632 : real_nan (&real, str, 1, TYPE_MODE (type));
285 : 1632 : return build_real (type, real);
286 : : }
287 : :
288 : : /* Converts a backend tree into a real constant. */
289 : :
290 : : void
291 : 1956 : gfc_conv_tree_to_mpfr (mpfr_ptr f, tree source)
292 : : {
293 : 1956 : mpfr_from_real (f, TREE_REAL_CST_PTR (source), GFC_RND_MODE);
294 : 1956 : }
295 : :
296 : : /* Translate any literal constant to a tree. Constants never have
297 : : pre or post chains. Character literal constants are special
298 : : special because they have a value and a length, so they cannot be
299 : : returned as a single tree. It is up to the caller to set the
300 : : length somewhere if necessary.
301 : :
302 : : Returns the translated constant, or aborts if it gets a type it
303 : : can't handle. */
304 : :
305 : : tree
306 : 1468543 : gfc_conv_constant_to_tree (gfc_expr * expr)
307 : : {
308 : 1468543 : tree res;
309 : :
310 : 1468543 : gcc_assert (expr->expr_type == EXPR_CONSTANT);
311 : :
312 : : /* If it is has a prescribed memory representation, we build a string
313 : : constant and VIEW_CONVERT to its type. */
314 : :
315 : 1468543 : switch (expr->ts.type)
316 : : {
317 : 1112042 : case BT_INTEGER:
318 : 1112042 : if (expr->representation.string)
319 : 1304 : return fold_build1_loc (input_location, VIEW_CONVERT_EXPR,
320 : : gfc_get_int_type (expr->ts.kind),
321 : 1304 : gfc_build_string_const (expr->representation.length,
322 : 1304 : expr->representation.string));
323 : : else
324 : 1110738 : return gfc_conv_mpz_to_tree (expr->value.integer, expr->ts.kind);
325 : :
326 : 2921 : case BT_UNSIGNED:
327 : 2921 : return gfc_conv_mpz_unsigned_to_tree (expr->value.integer, expr->ts.kind);
328 : :
329 : 110644 : case BT_REAL:
330 : 110644 : if (expr->representation.string)
331 : 764 : return fold_build1_loc (input_location, VIEW_CONVERT_EXPR,
332 : : gfc_get_real_type (expr->ts.kind),
333 : 764 : gfc_build_string_const (expr->representation.length,
334 : 764 : expr->representation.string));
335 : : else
336 : 109880 : return gfc_conv_mpfr_to_tree (expr->value.real, expr->ts.kind, expr->is_snan);
337 : :
338 : 92975 : case BT_LOGICAL:
339 : 92975 : if (expr->representation.string)
340 : : {
341 : 387 : tree tmp = fold_build1_loc (input_location, VIEW_CONVERT_EXPR,
342 : : gfc_get_int_type (expr->ts.kind),
343 : 387 : gfc_build_string_const (expr->representation.length,
344 : : expr->representation.string));
345 : 387 : if (!integer_zerop (tmp) && !integer_onep (tmp))
346 : 378 : gfc_warning (flag_dec_char_conversions ? OPT_Wsurprising : 0,
347 : : "Assigning value other than 0 or 1 to LOGICAL has "
348 : : "undefined result at %L", &expr->where);
349 : 387 : return fold_convert (gfc_get_logical_type (expr->ts.kind), tmp);
350 : : }
351 : : else
352 : 92588 : return build_int_cst (gfc_get_logical_type (expr->ts.kind),
353 : 92588 : expr->value.logical);
354 : :
355 : 12062 : case BT_COMPLEX:
356 : 12062 : if (expr->representation.string)
357 : 527 : return fold_build1_loc (input_location, VIEW_CONVERT_EXPR,
358 : : gfc_get_complex_type (expr->ts.kind),
359 : 527 : gfc_build_string_const (expr->representation.length,
360 : 527 : expr->representation.string));
361 : : else
362 : : {
363 : 23070 : tree real = gfc_conv_mpfr_to_tree (mpc_realref (expr->value.complex),
364 : 11535 : expr->ts.kind, expr->is_snan);
365 : 23070 : tree imag = gfc_conv_mpfr_to_tree (mpc_imagref (expr->value.complex),
366 : 11535 : expr->ts.kind, expr->is_snan);
367 : :
368 : 11535 : return build_complex (gfc_typenode_for_spec (&expr->ts),
369 : 11535 : real, imag);
370 : : }
371 : :
372 : 137868 : case BT_CHARACTER:
373 : 137868 : res = gfc_build_wide_string_const (expr->ts.kind,
374 : 137868 : expr->value.character.length,
375 : 137868 : expr->value.character.string);
376 : 137868 : return res;
377 : :
378 : 31 : case BT_HOLLERITH:
379 : 31 : return gfc_build_string_const (expr->representation.length,
380 : 31 : expr->representation.string);
381 : :
382 : 0 : default:
383 : 0 : gcc_unreachable ();
384 : : }
385 : : }
386 : :
387 : :
388 : : /* Like gfc_conv_constant_to_tree, but for a simplified expression.
389 : : We can handle character literal constants here as well. */
390 : :
391 : : void
392 : 1467752 : gfc_conv_constant (gfc_se * se, gfc_expr * expr)
393 : : {
394 : 1467752 : gfc_ss *ss;
395 : :
396 : : /* We may be receiving an expression for C_NULL_PTR or C_NULL_FUNPTR. If
397 : : so, the expr_type will not yet be an EXPR_CONSTANT. We need to make
398 : : it so here. */
399 : 1467752 : if (expr->ts.type == BT_DERIVED && expr->ts.u.derived
400 : 0 : && expr->ts.u.derived->attr.is_iso_c)
401 : : {
402 : 0 : if (expr->symtree->n.sym->intmod_sym_id == ISOCBINDING_NULL_PTR
403 : 0 : || expr->symtree->n.sym->intmod_sym_id == ISOCBINDING_NULL_FUNPTR)
404 : : {
405 : : /* Create a new EXPR_CONSTANT expression for our local uses. */
406 : 0 : expr = gfc_get_int_expr (gfc_default_integer_kind, NULL, 0);
407 : : }
408 : : }
409 : :
410 : 1467752 : if (expr->expr_type != EXPR_CONSTANT)
411 : : {
412 : 3 : gfc_expr *e = gfc_get_int_expr (gfc_default_integer_kind, NULL, 0);
413 : 3 : gfc_error ("non-constant initialization expression at %L", &expr->where);
414 : 3 : se->expr = gfc_conv_constant_to_tree (e);
415 : 3 : return;
416 : : }
417 : :
418 : 1467749 : ss = se->ss;
419 : 1467749 : if (ss != NULL)
420 : : {
421 : 0 : gfc_ss_info *ss_info;
422 : :
423 : 0 : ss_info = ss->info;
424 : 0 : gcc_assert (ss != gfc_ss_terminator);
425 : 0 : gcc_assert (ss_info->type == GFC_SS_SCALAR);
426 : 0 : gcc_assert (ss_info->expr == expr);
427 : :
428 : 0 : se->expr = ss_info->data.scalar.value;
429 : 0 : se->string_length = ss_info->string_length;
430 : 0 : gfc_advance_se_ss_chain (se);
431 : 0 : return;
432 : : }
433 : :
434 : : /* Translate the constant and put it in the simplifier structure. */
435 : 1467749 : se->expr = gfc_conv_constant_to_tree (expr);
436 : :
437 : : /* If this is a CHARACTER string, set its length in the simplifier
438 : : structure, too. */
439 : 1467749 : if (expr->ts.type == BT_CHARACTER)
440 : 137823 : se->string_length = TYPE_MAX_VALUE (TYPE_DOMAIN (TREE_TYPE (se->expr)));
441 : : }
|
