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