Branch data Line data Source code
1 : : /* Translation of constants
2 : : Copyright (C) 2002-2023 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 : 3007 : gfc_build_const (tree type, tree intval)
43 : : {
44 : 3007 : tree val;
45 : 3007 : tree zero;
46 : :
47 : 3007 : switch (TREE_CODE (type))
48 : : {
49 : 1586 : case INTEGER_TYPE:
50 : 1586 : val = convert (type, intval);
51 : 1586 : break;
52 : :
53 : 1219 : case REAL_TYPE:
54 : 1219 : val = build_real_from_int_cst (type, intval);
55 : 1219 : 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 : 3007 : return val;
67 : : }
68 : :
69 : : /* Build a string constant with C char type. */
70 : :
71 : : tree
72 : 223088 : gfc_build_string_const (size_t length, const char *s)
73 : : {
74 : 223088 : tree str;
75 : 223088 : tree len;
76 : :
77 : 223088 : str = build_string (length, s);
78 : 223088 : len = size_int (length);
79 : 223088 : TREE_TYPE (str) =
80 : 223088 : build_array_type (gfc_character1_type_node,
81 : : build_range_type (gfc_charlen_type_node,
82 : : size_one_node, len));
83 : 223088 : TYPE_STRING_FLAG (TREE_TYPE (str)) = 1;
84 : 223088 : 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 : 134774 : gfc_build_wide_string_const (int kind, size_t length, const gfc_char_t *string)
93 : : {
94 : 134774 : int i;
95 : 134774 : tree str, len;
96 : 134774 : size_t size;
97 : 134774 : char *s;
98 : :
99 : 134774 : i = gfc_validate_kind (BT_CHARACTER, kind, false);
100 : 134774 : size = length * gfc_character_kinds[i].bit_size / 8;
101 : :
102 : 134774 : s = XCNEWVAR (char, size);
103 : 134774 : gfc_encode_character (kind, length, string, (unsigned char *) s, size);
104 : :
105 : 134774 : str = build_string (size, s);
106 : 134774 : free (s);
107 : :
108 : 134774 : len = size_int (length);
109 : 134774 : TREE_TYPE (str) =
110 : 134774 : build_array_type (gfc_get_char_type (kind),
111 : : build_range_type (gfc_charlen_type_node,
112 : : size_one_node, len));
113 : 134774 : TYPE_STRING_FLAG (TREE_TYPE (str)) = 1;
114 : 134774 : 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 : 62468 : gfc_build_cstring_const (const char *string)
123 : : {
124 : 62468 : return gfc_build_string_const (strlen (string) + 1, string);
125 : : }
126 : :
127 : : tree
128 : 153094 : gfc_build_localized_cstring_const (const char *msgid)
129 : : {
130 : 153094 : const char *localized = _(msgid);
131 : 153094 : 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 : 2392 : gfc_conv_string_init (tree length, gfc_expr * expr)
141 : : {
142 : 2392 : gfc_char_t *s;
143 : 2392 : HOST_WIDE_INT len;
144 : 2392 : gfc_charlen_t slen;
145 : 2392 : tree str;
146 : 2392 : bool free_s = false;
147 : :
148 : 2392 : gcc_assert (expr->expr_type == EXPR_CONSTANT);
149 : 2392 : gcc_assert (expr->ts.type == BT_CHARACTER);
150 : 2392 : gcc_assert (tree_fits_uhwi_p (length));
151 : :
152 : 2392 : len = TREE_INT_CST_LOW (length);
153 : 2392 : slen = expr->value.character.length;
154 : :
155 : 2392 : 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 : 2392 : s = expr->value.character.string;
164 : :
165 : 2392 : str = gfc_build_wide_string_const (expr->ts.kind, len, s);
166 : :
167 : 2392 : if (free_s)
168 : 0 : free (s);
169 : :
170 : 2392 : return str;
171 : : }
172 : :
173 : :
174 : : /* Create a tree node for the string length if it is constant. */
175 : :
176 : : void
177 : 30870 : gfc_conv_const_charlen (gfc_charlen * cl)
178 : : {
179 : 30870 : if (!cl || cl->backend_decl)
180 : : return;
181 : :
182 : 26658 : if (cl->length && cl->length->expr_type == EXPR_CONSTANT)
183 : : {
184 : 15025 : cl->backend_decl = gfc_conv_mpz_to_tree (cl->length->value.integer,
185 : : cl->length->ts.kind);
186 : 15025 : cl->backend_decl = fold_convert (gfc_charlen_type_node,
187 : : cl->backend_decl);
188 : : }
189 : : }
190 : :
191 : : void
192 : 29002 : gfc_init_constants (void)
193 : : {
194 : 29002 : int n;
195 : :
196 : 493034 : for (n = 0; n <= GFC_MAX_DIMENSIONS; n++)
197 : 464032 : gfc_rank_cst[n] = build_int_cst (gfc_array_index_type, n);
198 : 29002 : }
199 : :
200 : : /* Converts a GMP integer into a backend tree node. */
201 : :
202 : : tree
203 : 1754217 : gfc_conv_mpz_to_tree (mpz_t i, int kind)
204 : : {
205 : 1754217 : wide_int val = wi::from_mpz (gfc_get_int_type (kind), i, true);
206 : 1754217 : return wide_int_to_tree (gfc_get_int_type (kind), val);
207 : : }
208 : :
209 : :
210 : : /* Convert a GMP integer into a tree node of type given by the type
211 : : argument. */
212 : :
213 : : tree
214 : 28 : gfc_conv_mpz_to_tree_type (mpz_t i, const tree type)
215 : : {
216 : 28 : const wide_int val = wi::from_mpz (type, i, true);
217 : 28 : return wide_int_to_tree (type, val);
218 : : }
219 : :
220 : :
221 : : /* Converts a backend tree into a GMP integer. */
222 : :
223 : : void
224 : 2195 : gfc_conv_tree_to_mpz (mpz_t i, tree source)
225 : : {
226 : 2195 : wi::to_mpz (wi::to_wide (source), i, TYPE_SIGN (TREE_TYPE (source)));
227 : 2195 : }
228 : :
229 : : /* Converts a real constant into backend form. */
230 : :
231 : : tree
232 : 130794 : gfc_conv_mpfr_to_tree (mpfr_t f, int kind, int is_snan)
233 : : {
234 : 130794 : tree type;
235 : 130794 : int n;
236 : 130794 : REAL_VALUE_TYPE real;
237 : :
238 : 130794 : n = gfc_validate_kind (BT_REAL, kind, false);
239 : 130794 : gcc_assert (gfc_real_kinds[n].radix == 2);
240 : :
241 : 130794 : type = gfc_get_real_type (kind);
242 : 130794 : if (mpfr_nan_p (f) && is_snan)
243 : 0 : real_from_string (&real, "SNaN");
244 : : else
245 : 130794 : real_from_mpfr (&real, f, type, GFC_RND_MODE);
246 : :
247 : 130794 : return build_real (type, real);
248 : : }
249 : :
250 : : /* Returns a real constant that is +Infinity if the target
251 : : supports infinities for this floating-point mode, and
252 : : +HUGE_VAL otherwise (the largest representable number). */
253 : :
254 : : tree
255 : 3141 : gfc_build_inf_or_huge (tree type, int kind)
256 : : {
257 : 3141 : if (HONOR_INFINITIES (TYPE_MODE (type)))
258 : : {
259 : 3141 : REAL_VALUE_TYPE real;
260 : 3141 : real_inf (&real);
261 : 3141 : return build_real (type, real);
262 : : }
263 : : else
264 : : {
265 : 0 : int k = gfc_validate_kind (BT_REAL, kind, false);
266 : 0 : return gfc_conv_mpfr_to_tree (gfc_real_kinds[k].huge, kind, 0);
267 : : }
268 : : }
269 : :
270 : : /* Returns a floating-point NaN of a given type. */
271 : :
272 : : tree
273 : 1632 : gfc_build_nan (tree type, const char *str)
274 : : {
275 : 1632 : REAL_VALUE_TYPE real;
276 : 1632 : real_nan (&real, str, 1, TYPE_MODE (type));
277 : 1632 : return build_real (type, real);
278 : : }
279 : :
280 : : /* Converts a backend tree into a real constant. */
281 : :
282 : : void
283 : 1953 : gfc_conv_tree_to_mpfr (mpfr_ptr f, tree source)
284 : : {
285 : 1953 : mpfr_from_real (f, TREE_REAL_CST_PTR (source), GFC_RND_MODE);
286 : 1953 : }
287 : :
288 : : /* Translate any literal constant to a tree. Constants never have
289 : : pre or post chains. Character literal constants are special
290 : : special because they have a value and a length, so they cannot be
291 : : returned as a single tree. It is up to the caller to set the
292 : : length somewhere if necessary.
293 : :
294 : : Returns the translated constant, or aborts if it gets a type it
295 : : can't handle. */
296 : :
297 : : tree
298 : 1283789 : gfc_conv_constant_to_tree (gfc_expr * expr)
299 : : {
300 : 1283789 : tree res;
301 : :
302 : 1283789 : gcc_assert (expr->expr_type == EXPR_CONSTANT);
303 : :
304 : : /* If it is has a prescribed memory representation, we build a string
305 : : constant and VIEW_CONVERT to its type. */
306 : :
307 : 1283789 : switch (expr->ts.type)
308 : : {
309 : 971927 : case BT_INTEGER:
310 : 971927 : if (expr->representation.string)
311 : 1297 : return fold_build1_loc (input_location, VIEW_CONVERT_EXPR,
312 : : gfc_get_int_type (expr->ts.kind),
313 : 1297 : gfc_build_string_const (expr->representation.length,
314 : 1297 : expr->representation.string));
315 : : else
316 : 970630 : return gfc_conv_mpz_to_tree (expr->value.integer, expr->ts.kind);
317 : :
318 : 106929 : case BT_REAL:
319 : 106929 : if (expr->representation.string)
320 : 764 : return fold_build1_loc (input_location, VIEW_CONVERT_EXPR,
321 : : gfc_get_real_type (expr->ts.kind),
322 : 764 : gfc_build_string_const (expr->representation.length,
323 : 764 : expr->representation.string));
324 : : else
325 : 106165 : return gfc_conv_mpfr_to_tree (expr->value.real, expr->ts.kind, expr->is_snan);
326 : :
327 : 60912 : case BT_LOGICAL:
328 : 60912 : if (expr->representation.string)
329 : : {
330 : 387 : tree tmp = fold_build1_loc (input_location, VIEW_CONVERT_EXPR,
331 : : gfc_get_int_type (expr->ts.kind),
332 : 387 : gfc_build_string_const (expr->representation.length,
333 : : expr->representation.string));
334 : 387 : if (!integer_zerop (tmp) && !integer_onep (tmp))
335 : 378 : gfc_warning (flag_dec_char_conversions ? OPT_Wsurprising : 0,
336 : : "Assigning value other than 0 or 1 to LOGICAL has "
337 : : "undefined result at %L", &expr->where);
338 : 387 : return fold_convert (gfc_get_logical_type (expr->ts.kind), tmp);
339 : : }
340 : : else
341 : 60525 : return build_int_cst (gfc_get_logical_type (expr->ts.kind),
342 : 60525 : expr->value.logical);
343 : :
344 : 11882 : case BT_COMPLEX:
345 : 11882 : if (expr->representation.string)
346 : 527 : return fold_build1_loc (input_location, VIEW_CONVERT_EXPR,
347 : : gfc_get_complex_type (expr->ts.kind),
348 : 527 : gfc_build_string_const (expr->representation.length,
349 : 527 : expr->representation.string));
350 : : else
351 : : {
352 : 22710 : tree real = gfc_conv_mpfr_to_tree (mpc_realref (expr->value.complex),
353 : 11355 : expr->ts.kind, expr->is_snan);
354 : 22710 : tree imag = gfc_conv_mpfr_to_tree (mpc_imagref (expr->value.complex),
355 : 11355 : expr->ts.kind, expr->is_snan);
356 : :
357 : 11355 : return build_complex (gfc_typenode_for_spec (&expr->ts),
358 : 11355 : real, imag);
359 : : }
360 : :
361 : 132108 : case BT_CHARACTER:
362 : 132108 : res = gfc_build_wide_string_const (expr->ts.kind,
363 : 132108 : expr->value.character.length,
364 : 132108 : expr->value.character.string);
365 : 132108 : return res;
366 : :
367 : 31 : case BT_HOLLERITH:
368 : 31 : return gfc_build_string_const (expr->representation.length,
369 : 31 : expr->representation.string);
370 : :
371 : 0 : default:
372 : 0 : gcc_unreachable ();
373 : : }
374 : : }
375 : :
376 : :
377 : : /* Like gfc_conv_constant_to_tree, but for a simplified expression.
378 : : We can handle character literal constants here as well. */
379 : :
380 : : void
381 : 1283034 : gfc_conv_constant (gfc_se * se, gfc_expr * expr)
382 : : {
383 : 1283034 : gfc_ss *ss;
384 : :
385 : : /* We may be receiving an expression for C_NULL_PTR or C_NULL_FUNPTR. If
386 : : so, the expr_type will not yet be an EXPR_CONSTANT. We need to make
387 : : it so here. */
388 : 1283034 : if (expr->ts.type == BT_DERIVED && expr->ts.u.derived
389 : 0 : && expr->ts.u.derived->attr.is_iso_c)
390 : : {
391 : 0 : if (expr->symtree->n.sym->intmod_sym_id == ISOCBINDING_NULL_PTR
392 : 0 : || expr->symtree->n.sym->intmod_sym_id == ISOCBINDING_NULL_FUNPTR)
393 : : {
394 : : /* Create a new EXPR_CONSTANT expression for our local uses. */
395 : 0 : expr = gfc_get_int_expr (gfc_default_integer_kind, NULL, 0);
396 : : }
397 : : }
398 : :
399 : 1283034 : if (expr->expr_type != EXPR_CONSTANT)
400 : : {
401 : 3 : gfc_expr *e = gfc_get_int_expr (gfc_default_integer_kind, NULL, 0);
402 : 3 : gfc_error ("non-constant initialization expression at %L", &expr->where);
403 : 3 : se->expr = gfc_conv_constant_to_tree (e);
404 : 3 : return;
405 : : }
406 : :
407 : 1283031 : ss = se->ss;
408 : 1283031 : if (ss != NULL)
409 : : {
410 : 0 : gfc_ss_info *ss_info;
411 : :
412 : 0 : ss_info = ss->info;
413 : 0 : gcc_assert (ss != gfc_ss_terminator);
414 : 0 : gcc_assert (ss_info->type == GFC_SS_SCALAR);
415 : 0 : gcc_assert (ss_info->expr == expr);
416 : :
417 : 0 : se->expr = ss_info->data.scalar.value;
418 : 0 : se->string_length = ss_info->string_length;
419 : 0 : gfc_advance_se_ss_chain (se);
420 : 0 : return;
421 : : }
422 : :
423 : : /* Translate the constant and put it in the simplifier structure. */
424 : 1283031 : se->expr = gfc_conv_constant_to_tree (expr);
425 : :
426 : : /* If this is a CHARACTER string, set its length in the simplifier
427 : : structure, too. */
428 : 1283031 : if (expr->ts.type == BT_CHARACTER)
429 : 132066 : se->string_length = TYPE_MAX_VALUE (TYPE_DOMAIN (TREE_TYPE (se->expr)));
430 : : }
|
