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