Branch data Line data Source code
1 : : /* Simulate storage of variables into target memory.
2 : : Copyright (C) 2007-2025 Free Software Foundation, Inc.
3 : : Contributed by Paul Thomas and Brooks Moses
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 : : #include "config.h"
22 : : #include "system.h"
23 : : #include "coretypes.h"
24 : : #include "tree.h"
25 : : #include "gfortran.h"
26 : : #include "trans.h"
27 : : #include "fold-const.h"
28 : : #include "stor-layout.h"
29 : : #include "arith.h"
30 : : #include "constructor.h"
31 : : #include "trans-const.h"
32 : : #include "trans-types.h"
33 : : #include "target-memory.h"
34 : :
35 : : /* --------------------------------------------------------------- */
36 : : /* Calculate the size of an expression. */
37 : :
38 : :
39 : : static size_t
40 : 3945 : size_integer (int kind)
41 : : {
42 : 3945 : return GET_MODE_SIZE (SCALAR_INT_TYPE_MODE (gfc_get_int_type (kind)));
43 : : }
44 : :
45 : : static size_t
46 : 6 : size_unsigned (int kind)
47 : : {
48 : 6 : return GET_MODE_SIZE (SCALAR_INT_TYPE_MODE (gfc_get_unsigned_type (kind)));
49 : : }
50 : :
51 : : static size_t
52 : 3863 : size_float (int kind)
53 : : {
54 : 3863 : return GET_MODE_SIZE (SCALAR_FLOAT_TYPE_MODE (gfc_get_real_type (kind)));
55 : : }
56 : :
57 : :
58 : : static size_t
59 : 713 : size_complex (int kind)
60 : : {
61 : 0 : return 2 * size_float (kind);
62 : : }
63 : :
64 : :
65 : : static size_t
66 : 941 : size_logical (int kind)
67 : : {
68 : 941 : return GET_MODE_SIZE (SCALAR_INT_TYPE_MODE (gfc_get_logical_type (kind)));
69 : : }
70 : :
71 : :
72 : : static size_t
73 : 284607 : size_character (gfc_charlen_t length, int kind)
74 : : {
75 : 284607 : int i = gfc_validate_kind (BT_CHARACTER, kind, false);
76 : 284607 : return length * gfc_character_kinds[i].bit_size / 8;
77 : : }
78 : :
79 : :
80 : : /* Return the size of a single element of the given expression.
81 : : Equivalent to gfc_target_expr_size for scalars. */
82 : :
83 : : bool
84 : 6168 : gfc_element_size (gfc_expr *e, size_t *siz)
85 : : {
86 : 6168 : tree type;
87 : :
88 : 6168 : switch (e->ts.type)
89 : : {
90 : 2377 : case BT_INTEGER:
91 : 2377 : *siz = size_integer (e->ts.kind);
92 : 2377 : return true;
93 : 6 : case BT_UNSIGNED:
94 : 6 : *siz = size_unsigned (e->ts.kind);
95 : 6 : return true;
96 : 1040 : case BT_REAL:
97 : 1040 : *siz = size_float (e->ts.kind);
98 : 1040 : return true;
99 : 713 : case BT_COMPLEX:
100 : 713 : *siz = size_complex (e->ts.kind);
101 : 713 : return true;
102 : 500 : case BT_LOGICAL:
103 : 500 : *siz = size_logical (e->ts.kind);
104 : 500 : return true;
105 : 1248 : case BT_CHARACTER:
106 : 1248 : if (e->expr_type == EXPR_CONSTANT)
107 : 706 : *siz = size_character (e->value.character.length, e->ts.kind);
108 : 542 : else if (e->ts.u.cl != NULL && e->ts.u.cl->length != NULL
109 : 515 : && e->ts.u.cl->length->expr_type == EXPR_CONSTANT
110 : 515 : && e->ts.u.cl->length->ts.type == BT_INTEGER)
111 : : {
112 : 515 : HOST_WIDE_INT length;
113 : :
114 : 515 : gfc_extract_hwi (e->ts.u.cl->length, &length);
115 : 515 : *siz = size_character (length, e->ts.kind);
116 : 515 : }
117 : : else
118 : : {
119 : 27 : *siz = 0;
120 : 27 : return false;
121 : : }
122 : : return true;
123 : :
124 : 7 : case BT_HOLLERITH:
125 : 7 : *siz = e->representation.length;
126 : 7 : return true;
127 : 277 : case BT_DERIVED:
128 : 277 : case BT_CLASS:
129 : 277 : case BT_VOID:
130 : 277 : case BT_ASSUMED:
131 : 277 : case BT_PROCEDURE:
132 : 277 : {
133 : : /* Determine type size without clobbering the typespec for ISO C
134 : : binding types. */
135 : 277 : gfc_typespec ts;
136 : 277 : HOST_WIDE_INT size;
137 : 277 : ts = e->ts;
138 : 277 : type = gfc_typenode_for_spec (&ts);
139 : 277 : size = int_size_in_bytes (type);
140 : 277 : gcc_assert (size >= 0);
141 : 277 : *siz = size;
142 : : }
143 : 277 : return true;
144 : 0 : default:
145 : 0 : gfc_internal_error ("Invalid expression in gfc_element_size.");
146 : : *siz = 0;
147 : : return false;
148 : : }
149 : : }
150 : :
151 : :
152 : : /* Return the size of an expression in its target representation. */
153 : :
154 : : bool
155 : 4080 : gfc_target_expr_size (gfc_expr *e, size_t *size)
156 : : {
157 : 4080 : mpz_t tmp;
158 : 4080 : size_t asz, el_size;
159 : :
160 : 4080 : gcc_assert (e != NULL);
161 : :
162 : 4080 : *size = 0;
163 : 4080 : if (e->rank)
164 : : {
165 : 409 : if (gfc_array_size (e, &tmp))
166 : 409 : asz = mpz_get_ui (tmp);
167 : : else
168 : : return false;
169 : :
170 : 409 : mpz_clear (tmp);
171 : : }
172 : : else
173 : : asz = 1;
174 : :
175 : 4080 : if (!gfc_element_size (e, &el_size))
176 : : return false;
177 : 4079 : *size = asz * el_size;
178 : 4079 : return true;
179 : : }
180 : :
181 : :
182 : : /* The encode_* functions export a value into a buffer, and
183 : : return the number of bytes of the buffer that have been
184 : : used. */
185 : :
186 : : static unsigned HOST_WIDE_INT
187 : 222 : encode_array (gfc_expr *expr, unsigned char *buffer, size_t buffer_size)
188 : : {
189 : 222 : mpz_t array_size;
190 : 222 : int i;
191 : 222 : int ptr = 0;
192 : :
193 : 222 : gfc_constructor_base ctor = expr->value.constructor;
194 : :
195 : 222 : gfc_array_size (expr, &array_size);
196 : 909 : for (i = 0; i < (int)mpz_get_ui (array_size); i++)
197 : : {
198 : 453 : ptr += gfc_target_encode_expr (gfc_constructor_lookup_expr (ctor, i),
199 : 453 : &buffer[ptr], buffer_size - ptr);
200 : : }
201 : :
202 : 222 : mpz_clear (array_size);
203 : 222 : return ptr;
204 : : }
205 : :
206 : :
207 : : static int
208 : 669 : encode_integer (int kind, mpz_t integer, unsigned char *buffer,
209 : : size_t buffer_size)
210 : : {
211 : 669 : return native_encode_expr (gfc_conv_mpz_to_tree (integer, kind),
212 : 669 : buffer, buffer_size);
213 : : }
214 : :
215 : :
216 : : static int
217 : 92 : encode_float (int kind, mpfr_t real, unsigned char *buffer, size_t buffer_size)
218 : : {
219 : 92 : return native_encode_expr (gfc_conv_mpfr_to_tree (real, kind, 0), buffer,
220 : 92 : buffer_size);
221 : : }
222 : :
223 : :
224 : : static int
225 : 18 : encode_complex (int kind, mpc_t cmplx,
226 : : unsigned char *buffer, size_t buffer_size)
227 : : {
228 : 18 : int size;
229 : 18 : size = encode_float (kind, mpc_realref (cmplx), &buffer[0], buffer_size);
230 : 36 : size += encode_float (kind, mpc_imagref (cmplx),
231 : 18 : &buffer[size], buffer_size - size);
232 : 18 : return size;
233 : : }
234 : :
235 : :
236 : : static int
237 : 23 : encode_logical (int kind, int logical, unsigned char *buffer, size_t buffer_size)
238 : : {
239 : 23 : return native_encode_expr (build_int_cst (gfc_get_logical_type (kind),
240 : : logical),
241 : 23 : buffer, buffer_size);
242 : : }
243 : :
244 : :
245 : : size_t
246 : 140783 : gfc_encode_character (int kind, size_t length, const gfc_char_t *string,
247 : : unsigned char *buffer, size_t buffer_size)
248 : : {
249 : 140783 : size_t elsize = size_character (1, kind);
250 : 140783 : tree type = gfc_get_char_type (kind);
251 : :
252 : 140783 : gcc_assert (buffer_size >= size_character (length, kind));
253 : :
254 : 2055548 : for (size_t i = 0; i < length; i++)
255 : 1914765 : native_encode_expr (build_int_cst (type, string[i]), &buffer[i*elsize],
256 : : elsize);
257 : :
258 : 140783 : return length;
259 : : }
260 : :
261 : :
262 : : static unsigned HOST_WIDE_INT
263 : 4 : encode_derived (gfc_expr *source, unsigned char *buffer, size_t buffer_size)
264 : : {
265 : 4 : gfc_constructor *c;
266 : 4 : gfc_component *cmp;
267 : 4 : int ptr;
268 : 4 : tree type;
269 : 4 : HOST_WIDE_INT size;
270 : :
271 : 4 : type = gfc_typenode_for_spec (&source->ts);
272 : :
273 : 4 : for (c = gfc_constructor_first (source->value.constructor),
274 : 4 : cmp = source->ts.u.derived->components;
275 : 9 : c;
276 : 5 : c = gfc_constructor_next (c), cmp = cmp->next)
277 : : {
278 : 5 : gcc_assert (cmp);
279 : 5 : if (!c->expr)
280 : 0 : continue;
281 : 5 : ptr = TREE_INT_CST_LOW(DECL_FIELD_OFFSET(cmp->backend_decl))
282 : 5 : + TREE_INT_CST_LOW(DECL_FIELD_BIT_OFFSET(cmp->backend_decl))/8;
283 : :
284 : 5 : if (c->expr->expr_type == EXPR_NULL)
285 : : {
286 : 1 : size = int_size_in_bytes (TREE_TYPE (cmp->backend_decl));
287 : 1 : gcc_assert (size >= 0);
288 : 1 : memset (&buffer[ptr], 0, size);
289 : : }
290 : : else
291 : 4 : gfc_target_encode_expr (c->expr, &buffer[ptr],
292 : 4 : buffer_size - ptr);
293 : : }
294 : :
295 : 4 : size = int_size_in_bytes (type);
296 : 4 : gcc_assert (size >= 0);
297 : 4 : return size;
298 : : }
299 : :
300 : :
301 : : /* Write a constant expression in binary form to a buffer. */
302 : : unsigned HOST_WIDE_INT
303 : 1506 : gfc_target_encode_expr (gfc_expr *source, unsigned char *buffer,
304 : : size_t buffer_size)
305 : : {
306 : 1506 : if (source == NULL)
307 : : return 0;
308 : :
309 : 1506 : if (source->expr_type == EXPR_ARRAY)
310 : 222 : return encode_array (source, buffer, buffer_size);
311 : :
312 : 1284 : gcc_assert (source->expr_type == EXPR_CONSTANT
313 : : || source->expr_type == EXPR_STRUCTURE
314 : : || source->expr_type == EXPR_SUBSTRING);
315 : :
316 : : /* If we already have a target-memory representation, we use that rather
317 : : than recreating one. */
318 : 1284 : if (source->representation.string)
319 : : {
320 : 114 : memcpy (buffer, source->representation.string,
321 : 114 : source->representation.length);
322 : 114 : return source->representation.length;
323 : : }
324 : :
325 : 1170 : switch (source->ts.type)
326 : : {
327 : 412 : case BT_INTEGER:
328 : 412 : return encode_integer (source->ts.kind, source->value.integer, buffer,
329 : 412 : buffer_size);
330 : 56 : case BT_REAL:
331 : 56 : return encode_float (source->ts.kind, source->value.real, buffer,
332 : 56 : buffer_size);
333 : 18 : case BT_COMPLEX:
334 : 18 : return encode_complex (source->ts.kind, source->value.complex,
335 : 18 : buffer, buffer_size);
336 : 23 : case BT_LOGICAL:
337 : 23 : return encode_logical (source->ts.kind, source->value.logical, buffer,
338 : 23 : buffer_size);
339 : 654 : case BT_CHARACTER:
340 : 654 : if (source->expr_type == EXPR_CONSTANT || source->ref == NULL)
341 : 624 : return gfc_encode_character (source->ts.kind,
342 : 624 : source->value.character.length,
343 : 624 : source->value.character.string,
344 : 624 : buffer, buffer_size);
345 : : else
346 : : {
347 : 30 : HOST_WIDE_INT start, end;
348 : :
349 : 30 : gcc_assert (source->expr_type == EXPR_SUBSTRING);
350 : 30 : gfc_extract_hwi (source->ref->u.ss.start, &start);
351 : 30 : gfc_extract_hwi (source->ref->u.ss.end, &end);
352 : 30 : return gfc_encode_character (source->ts.kind, MAX(end - start + 1, 0),
353 : 30 : &source->value.character.string[start-1],
354 : : buffer, buffer_size);
355 : : }
356 : :
357 : 7 : case BT_DERIVED:
358 : 7 : if (source->ts.u.derived->ts.f90_type == BT_VOID)
359 : : {
360 : 3 : gfc_constructor *c;
361 : 3 : gcc_assert (source->expr_type == EXPR_STRUCTURE);
362 : 3 : c = gfc_constructor_first (source->value.constructor);
363 : 3 : gcc_assert (c->expr->expr_type == EXPR_CONSTANT
364 : : && c->expr->ts.type == BT_INTEGER);
365 : 3 : return encode_integer (gfc_index_integer_kind, c->expr->value.integer,
366 : 3 : buffer, buffer_size);
367 : : }
368 : :
369 : 4 : return encode_derived (source, buffer, buffer_size);
370 : 0 : default:
371 : 0 : gfc_internal_error ("Invalid expression in gfc_target_encode_expr.");
372 : : return 0;
373 : : }
374 : : }
375 : :
376 : :
377 : : static size_t
378 : 275 : interpret_array (unsigned char *buffer, size_t buffer_size, gfc_expr *result,
379 : : bool convert_widechar)
380 : : {
381 : 275 : gfc_constructor_base base = NULL;
382 : 275 : size_t array_size = 1;
383 : 275 : size_t ptr = 0;
384 : :
385 : : /* Calculate array size from its shape and rank. */
386 : 275 : gcc_assert (result->rank > 0 && result->shape);
387 : :
388 : 550 : for (int i = 0; i < result->rank; i++)
389 : 310 : array_size *= mpz_get_ui (result->shape[i]);
390 : :
391 : : /* Iterate over array elements, producing constructors. */
392 : 1036 : for (size_t i = 0; i < array_size; i++)
393 : : {
394 : 761 : gfc_expr *e = gfc_get_constant_expr (result->ts.type, result->ts.kind,
395 : : &result->where);
396 : 761 : e->ts = result->ts;
397 : :
398 : 761 : if (e->ts.type == BT_CHARACTER)
399 : 464 : e->value.character.length = result->value.character.length;
400 : :
401 : 761 : gfc_constructor_append_expr (&base, e, &result->where);
402 : :
403 : 761 : ptr += gfc_target_interpret_expr (&buffer[ptr], buffer_size - ptr, e,
404 : : convert_widechar);
405 : : }
406 : :
407 : 275 : result->value.constructor = base;
408 : 275 : return ptr;
409 : : }
410 : :
411 : :
412 : : int
413 : 1060 : gfc_interpret_integer (int kind, unsigned char *buffer, size_t buffer_size,
414 : : mpz_t integer)
415 : : {
416 : 1060 : mpz_init (integer);
417 : 1060 : gfc_conv_tree_to_mpz (integer,
418 : : native_interpret_expr (gfc_get_int_type (kind),
419 : : buffer, buffer_size));
420 : 1060 : return size_integer (kind);
421 : : }
422 : :
423 : :
424 : : int
425 : 1856 : gfc_interpret_float (int kind, unsigned char *buffer, size_t buffer_size,
426 : : mpfr_t real)
427 : : {
428 : 1856 : gfc_set_model_kind (kind);
429 : :
430 : 1856 : tree source = native_interpret_expr (gfc_get_real_type (kind), buffer,
431 : : buffer_size);
432 : 1856 : if (!source)
433 : : return 0;
434 : :
435 : 1856 : mpfr_init (real);
436 : 1856 : gfc_conv_tree_to_mpfr (real, source);
437 : 1856 : return size_float (kind);
438 : : }
439 : :
440 : :
441 : : int
442 : 492 : gfc_interpret_complex (int kind, unsigned char *buffer, size_t buffer_size,
443 : : mpc_t complex)
444 : : {
445 : 492 : int size;
446 : 984 : size = gfc_interpret_float (kind, &buffer[0], buffer_size,
447 : 492 : mpc_realref (complex));
448 : 984 : size += gfc_interpret_float (kind, &buffer[size], buffer_size - size,
449 : 492 : mpc_imagref (complex));
450 : 492 : return size;
451 : : }
452 : :
453 : :
454 : : int
455 : 441 : gfc_interpret_logical (int kind, unsigned char *buffer, size_t buffer_size,
456 : : int *logical)
457 : : {
458 : 441 : tree t = native_interpret_expr (gfc_get_logical_type (kind), buffer,
459 : : buffer_size);
460 : 441 : *logical = wi::to_wide (t) == 0 ? 0 : 1;
461 : 441 : return size_logical (kind);
462 : : }
463 : :
464 : :
465 : : size_t
466 : 688 : gfc_interpret_character (unsigned char *buffer, size_t buffer_size,
467 : : gfc_expr *result)
468 : : {
469 : 688 : if (result->ts.u.cl && result->ts.u.cl->length)
470 : 688 : result->value.character.length =
471 : 688 : gfc_mpz_get_hwi (result->ts.u.cl->length->value.integer);
472 : :
473 : 688 : gcc_assert (buffer_size >= size_character (result->value.character.length,
474 : : result->ts.kind));
475 : 1376 : result->value.character.string =
476 : 688 : gfc_get_wide_string (result->value.character.length + 1);
477 : :
478 : 688 : if (result->ts.kind == gfc_default_character_kind)
479 : 789 : for (size_t i = 0; i < (size_t) result->value.character.length; i++)
480 : 545 : result->value.character.string[i] = (gfc_char_t) buffer[i];
481 : : else
482 : : {
483 : 444 : mpz_t integer;
484 : 444 : size_t bytes = size_character (1, result->ts.kind);
485 : 444 : mpz_init (integer);
486 : 444 : gcc_assert (bytes <= sizeof (unsigned long));
487 : :
488 : 1346 : for (size_t i = 0; i < (size_t) result->value.character.length; i++)
489 : : {
490 : 902 : gfc_conv_tree_to_mpz (integer,
491 : : native_interpret_expr (gfc_get_char_type (result->ts.kind),
492 : 902 : &buffer[bytes*i], buffer_size-bytes*i));
493 : 902 : result->value.character.string[i]
494 : 902 : = (gfc_char_t) mpz_get_ui (integer);
495 : : }
496 : :
497 : 444 : mpz_clear (integer);
498 : : }
499 : :
500 : 688 : result->value.character.string[result->value.character.length] = '\0';
501 : :
502 : 688 : return size_character (result->value.character.length, result->ts.kind);
503 : : }
504 : :
505 : :
506 : : int
507 : 31 : gfc_interpret_derived (unsigned char *buffer, size_t buffer_size, gfc_expr *result)
508 : : {
509 : 31 : gfc_component *cmp;
510 : 31 : int ptr;
511 : 31 : tree type;
512 : :
513 : : /* The attributes of the derived type need to be bolted to the floor. */
514 : 31 : result->expr_type = EXPR_STRUCTURE;
515 : :
516 : 31 : cmp = result->ts.u.derived->components;
517 : :
518 : 31 : if (result->ts.u.derived->from_intmod == INTMOD_ISO_C_BINDING
519 : 15 : && (result->ts.u.derived->intmod_sym_id == ISOCBINDING_PTR
520 : 1 : || result->ts.u.derived->intmod_sym_id == ISOCBINDING_FUNPTR))
521 : : {
522 : 15 : gfc_constructor *c;
523 : 15 : gfc_expr *e;
524 : : /* Needed as gfc_typenode_for_spec as gfc_typenode_for_spec
525 : : sets this to BT_INTEGER. */
526 : 15 : result->ts.type = BT_DERIVED;
527 : 15 : e = gfc_get_constant_expr (cmp->ts.type, cmp->ts.kind, &result->where);
528 : 15 : c = gfc_constructor_append_expr (&result->value.constructor, e, NULL);
529 : 15 : c->n.component = cmp;
530 : 15 : gfc_target_interpret_expr (buffer, buffer_size, e, true);
531 : 15 : e->ts.is_iso_c = 1;
532 : 15 : return int_size_in_bytes (ptr_type_node);
533 : : }
534 : :
535 : 16 : type = gfc_typenode_for_spec (&result->ts);
536 : :
537 : : /* Run through the derived type components. */
538 : 53 : for (;cmp; cmp = cmp->next)
539 : : {
540 : 43 : gfc_constructor *c;
541 : 43 : gfc_expr *e = gfc_get_constant_expr (cmp->ts.type, cmp->ts.kind,
542 : : &result->where);
543 : 43 : e->ts = cmp->ts;
544 : :
545 : : /* Copy shape, if needed. */
546 : 43 : if (cmp->as && cmp->as->rank)
547 : : {
548 : 8 : int n;
549 : :
550 : 8 : if (cmp->as->type != AS_EXPLICIT)
551 : : return 0;
552 : :
553 : 2 : e->expr_type = EXPR_ARRAY;
554 : 2 : e->rank = cmp->as->rank;
555 : :
556 : 2 : e->shape = gfc_get_shape (e->rank);
557 : 4 : for (n = 0; n < e->rank; n++)
558 : : {
559 : 2 : mpz_init_set_ui (e->shape[n], 1);
560 : 2 : mpz_add (e->shape[n], e->shape[n],
561 : 2 : cmp->as->upper[n]->value.integer);
562 : 2 : mpz_sub (e->shape[n], e->shape[n],
563 : 2 : cmp->as->lower[n]->value.integer);
564 : : }
565 : : }
566 : :
567 : 37 : c = gfc_constructor_append_expr (&result->value.constructor, e, NULL);
568 : :
569 : : /* The constructor points to the component. */
570 : 37 : c->n.component = cmp;
571 : :
572 : : /* Calculate the offset, which consists of the FIELD_OFFSET in
573 : : bytes, which appears in multiples of DECL_OFFSET_ALIGN-bit-sized,
574 : : and additional bits of FIELD_BIT_OFFSET. The code assumes that all
575 : : sizes of the components are multiples of BITS_PER_UNIT,
576 : : i.e. there are, e.g., no bit fields. */
577 : :
578 : 37 : gcc_assert (cmp->backend_decl);
579 : 37 : ptr = TREE_INT_CST_LOW (DECL_FIELD_BIT_OFFSET (cmp->backend_decl));
580 : 37 : gcc_assert (ptr % 8 == 0);
581 : 37 : ptr = ptr/8 + TREE_INT_CST_LOW (DECL_FIELD_OFFSET (cmp->backend_decl));
582 : :
583 : 37 : gcc_assert (e->ts.type != BT_VOID || cmp->attr.caf_token);
584 : 37 : gfc_target_interpret_expr (&buffer[ptr], buffer_size - ptr, e, true);
585 : : }
586 : :
587 : 10 : return int_size_in_bytes (type);
588 : : }
589 : :
590 : :
591 : : /* Read a binary buffer to a constant expression. */
592 : : size_t
593 : 1671 : gfc_target_interpret_expr (unsigned char *buffer, size_t buffer_size,
594 : : gfc_expr *result, bool convert_widechar)
595 : : {
596 : 1671 : if (result->expr_type == EXPR_ARRAY)
597 : 275 : return interpret_array (buffer, buffer_size, result, convert_widechar);
598 : :
599 : 1396 : switch (result->ts.type)
600 : : {
601 : 495 : case BT_INTEGER:
602 : 990 : result->representation.length =
603 : 990 : gfc_interpret_integer (result->ts.kind, buffer, buffer_size,
604 : 495 : result->value.integer);
605 : 495 : break;
606 : :
607 : 104 : case BT_REAL:
608 : 208 : result->representation.length =
609 : 208 : gfc_interpret_float (result->ts.kind, buffer, buffer_size,
610 : 104 : result->value.real);
611 : 104 : break;
612 : :
613 : 17 : case BT_COMPLEX:
614 : 34 : result->representation.length =
615 : 34 : gfc_interpret_complex (result->ts.kind, buffer, buffer_size,
616 : 17 : result->value.complex);
617 : 17 : break;
618 : :
619 : 60 : case BT_LOGICAL:
620 : 120 : result->representation.length =
621 : 60 : gfc_interpret_logical (result->ts.kind, buffer, buffer_size,
622 : : &result->value.logical);
623 : 60 : break;
624 : :
625 : 688 : case BT_CHARACTER:
626 : 1376 : result->representation.length =
627 : 688 : gfc_interpret_character (buffer, buffer_size, result);
628 : 688 : break;
629 : :
630 : 0 : case BT_CLASS:
631 : 0 : result->ts = CLASS_DATA (result)->ts;
632 : : /* Fall through. */
633 : 31 : case BT_DERIVED:
634 : 62 : result->representation.length =
635 : 31 : gfc_interpret_derived (buffer, buffer_size, result);
636 : 31 : gcc_assert (result->representation.length >= 0);
637 : : break;
638 : :
639 : 1 : case BT_VOID:
640 : : /* This deals with caf_tokens. */
641 : 2 : result->representation.length =
642 : 2 : gfc_interpret_integer (result->ts.kind, buffer, buffer_size,
643 : 1 : result->value.integer);
644 : 1 : break;
645 : :
646 : 0 : default:
647 : 0 : gfc_internal_error ("Invalid expression in gfc_target_interpret_expr.");
648 : 1396 : break;
649 : : }
650 : :
651 : 1396 : if (result->ts.type == BT_CHARACTER && convert_widechar)
652 : 0 : result->representation.string
653 : 0 : = gfc_widechar_to_char (result->value.character.string,
654 : 0 : result->value.character.length);
655 : : else
656 : : {
657 : 2792 : result->representation.string =
658 : 1396 : XCNEWVEC (char, result->representation.length + 1);
659 : 1396 : memcpy (result->representation.string, buffer,
660 : 1396 : result->representation.length);
661 : 1396 : result->representation.string[result->representation.length] = '\0';
662 : : }
663 : :
664 : 1396 : return result->representation.length;
665 : : }
666 : :
667 : :
668 : : /* --------------------------------------------------------------- */
669 : : /* Two functions used by trans-common.cc to write overlapping
670 : : equivalence initializers to a buffer. This is added to the union
671 : : and the original initializers freed. */
672 : :
673 : :
674 : : /* Writes the values of a constant expression to a char buffer. If another
675 : : unequal initializer has already been written to the buffer, this is an
676 : : error. */
677 : :
678 : : static size_t
679 : 206 : expr_to_char (gfc_expr *e, locus *loc,
680 : : unsigned char *data, unsigned char *chk, size_t len)
681 : : {
682 : 206 : int i;
683 : 206 : int ptr;
684 : 206 : gfc_constructor *c;
685 : 206 : gfc_component *cmp;
686 : 206 : unsigned char *buffer;
687 : :
688 : 206 : if (e == NULL)
689 : : return 0;
690 : :
691 : : /* Take a derived type, one component at a time, using the offsets from the backend
692 : : declaration. */
693 : 206 : if (e->ts.type == BT_DERIVED)
694 : : {
695 : 15 : for (c = gfc_constructor_first (e->value.constructor),
696 : 15 : cmp = e->ts.u.derived->components;
697 : 54 : c; c = gfc_constructor_next (c), cmp = cmp->next)
698 : : {
699 : 39 : gcc_assert (cmp && cmp->backend_decl);
700 : 39 : if (!c->expr)
701 : 12 : continue;
702 : 27 : ptr = TREE_INT_CST_LOW(DECL_FIELD_OFFSET(cmp->backend_decl))
703 : 27 : + TREE_INT_CST_LOW(DECL_FIELD_BIT_OFFSET(cmp->backend_decl))/8;
704 : 27 : expr_to_char (c->expr, loc, &data[ptr], &chk[ptr], len);
705 : : }
706 : 15 : return len;
707 : : }
708 : :
709 : : /* Otherwise, use the target-memory machinery to write a bitwise image, appropriate
710 : : to the target, in a buffer and check off the initialized part of the buffer. */
711 : 191 : gfc_target_expr_size (e, &len);
712 : 191 : buffer = (unsigned char*)alloca (len);
713 : 191 : len = gfc_target_encode_expr (e, buffer, len);
714 : :
715 : 1009 : for (i = 0; i < (int)len; i++)
716 : : {
717 : 821 : if (chk[i] && (buffer[i] != data[i]))
718 : : {
719 : 3 : if (loc)
720 : 3 : gfc_error ("Overlapping unequal initializers in EQUIVALENCE "
721 : : "at %L", loc);
722 : : else
723 : 0 : gfc_error ("Overlapping unequal initializers in EQUIVALENCE "
724 : : "at %C");
725 : 3 : return 0;
726 : : }
727 : 818 : chk[i] = 0xFF;
728 : : }
729 : :
730 : 188 : memcpy (data, buffer, len);
731 : 188 : return len;
732 : : }
733 : :
734 : :
735 : : /* Writes the values from the equivalence initializers to a char* array
736 : : that will be written to the constructor to make the initializer for
737 : : the union declaration. */
738 : :
739 : : size_t
740 : 239 : gfc_merge_initializers (gfc_typespec ts, gfc_expr *e, locus *loc,
741 : : unsigned char *data,
742 : : unsigned char *chk, size_t length)
743 : : {
744 : 239 : size_t len = 0;
745 : 239 : gfc_constructor * c;
746 : :
747 : 239 : switch (e->expr_type)
748 : : {
749 : 179 : case EXPR_CONSTANT:
750 : 179 : case EXPR_STRUCTURE:
751 : 179 : len = expr_to_char (e, loc, &data[0], &chk[0], length);
752 : 179 : break;
753 : :
754 : 60 : case EXPR_ARRAY:
755 : 60 : for (c = gfc_constructor_first (e->value.constructor);
756 : 203 : c; c = gfc_constructor_next (c))
757 : : {
758 : 143 : size_t elt_size;
759 : :
760 : 143 : gfc_target_expr_size (c->expr, &elt_size);
761 : :
762 : 143 : if (mpz_cmp_si (c->offset, 0) != 0)
763 : 83 : len = elt_size * (size_t)mpz_get_si (c->offset);
764 : :
765 : 143 : len = len + gfc_merge_initializers (ts, c->expr, loc, &data[len],
766 : : &chk[len], length - len);
767 : : }
768 : : break;
769 : :
770 : : default:
771 : : return 0;
772 : : }
773 : :
774 : : return len;
775 : : }
776 : :
777 : :
778 : : /* Transfer the bitpattern of a (integer) BOZ to real or complex variables.
779 : : When successful, no BOZ or nothing to do, true is returned. */
780 : :
781 : : bool
782 : 254 : gfc_convert_boz (gfc_expr *expr, gfc_typespec *ts)
783 : : {
784 : 254 : size_t buffer_size, boz_bit_size, ts_bit_size;
785 : 254 : int index;
786 : 254 : unsigned char *buffer;
787 : :
788 : 254 : if (expr->ts.type != BT_INTEGER)
789 : : return true;
790 : :
791 : : /* Don't convert BOZ to logical, character, derived etc. */
792 : 254 : gcc_assert (ts->type == BT_REAL);
793 : :
794 : 254 : buffer_size = size_float (ts->kind);
795 : 254 : ts_bit_size = buffer_size * 8;
796 : :
797 : : /* Convert BOZ to the smallest possible integer kind. */
798 : 254 : boz_bit_size = mpz_sizeinbase (expr->value.integer, 2);
799 : :
800 : 254 : gcc_assert (boz_bit_size <= ts_bit_size);
801 : :
802 : 880 : for (index = 0; gfc_integer_kinds[index].kind != 0; ++index)
803 : 880 : if ((unsigned) gfc_integer_kinds[index].bit_size >= ts_bit_size)
804 : : break;
805 : :
806 : 254 : expr->ts.kind = gfc_integer_kinds[index].kind;
807 : 254 : buffer_size = MAX (buffer_size, size_integer (expr->ts.kind));
808 : :
809 : 254 : buffer = (unsigned char*)alloca (buffer_size);
810 : 254 : encode_integer (expr->ts.kind, expr->value.integer, buffer, buffer_size);
811 : 254 : mpz_clear (expr->value.integer);
812 : :
813 : 254 : mpfr_init (expr->value.real);
814 : 254 : gfc_interpret_float (ts->kind, buffer, buffer_size, expr->value.real);
815 : :
816 : 254 : expr->ts.type = ts->type;
817 : 254 : expr->ts.kind = ts->kind;
818 : :
819 : 254 : return true;
820 : : }
|
