Line data Source code
1 : /* Simulate storage of variables into target memory.
2 : Copyright (C) 2007-2026 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 4110 : size_integer (int kind)
41 : {
42 4110 : 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 3899 : size_float (int kind)
53 : {
54 3899 : return GET_MODE_SIZE (SCALAR_FLOAT_TYPE_MODE (gfc_get_real_type (kind)));
55 : }
56 :
57 :
58 : static size_t
59 725 : size_complex (int kind)
60 : {
61 0 : return 2 * size_float (kind);
62 : }
63 :
64 :
65 : static size_t
66 953 : size_logical (int kind)
67 : {
68 953 : return GET_MODE_SIZE (SCALAR_INT_TYPE_MODE (gfc_get_logical_type (kind)));
69 : }
70 :
71 :
72 : static size_t
73 293779 : size_character (gfc_charlen_t length, int kind)
74 : {
75 293779 : int i = gfc_validate_kind (BT_CHARACTER, kind, false);
76 293779 : 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 6388 : gfc_element_size (gfc_expr *e, size_t *siz)
85 : {
86 6388 : tree type;
87 :
88 6388 : switch (e->ts.type)
89 : {
90 2542 : case BT_INTEGER:
91 2542 : *siz = size_integer (e->ts.kind);
92 2542 : return true;
93 6 : case BT_UNSIGNED:
94 6 : *siz = size_unsigned (e->ts.kind);
95 6 : return true;
96 1064 : case BT_REAL:
97 1064 : *siz = size_float (e->ts.kind);
98 1064 : return true;
99 725 : case BT_COMPLEX:
100 725 : *siz = size_complex (e->ts.kind);
101 725 : return true;
102 512 : case BT_LOGICAL:
103 512 : *siz = size_logical (e->ts.kind);
104 512 : 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 284 : case BT_DERIVED:
128 284 : case BT_CLASS:
129 284 : case BT_VOID:
130 284 : case BT_ASSUMED:
131 284 : case BT_PROCEDURE:
132 284 : {
133 : /* Determine type size without clobbering the typespec for ISO C
134 : binding types. */
135 284 : gfc_typespec ts;
136 284 : HOST_WIDE_INT size;
137 284 : ts = e->ts;
138 284 : type = gfc_typenode_for_spec (&ts);
139 284 : size = int_size_in_bytes (type);
140 284 : gcc_assert (size >= 0);
141 284 : *siz = size;
142 : }
143 284 : 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 4141 : gfc_target_expr_size (gfc_expr *e, size_t *size)
156 : {
157 4141 : mpz_t tmp;
158 4141 : size_t asz, el_size;
159 :
160 4141 : gcc_assert (e != NULL);
161 :
162 4141 : *size = 0;
163 4141 : 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 4141 : if (!gfc_element_size (e, &el_size))
176 : return false;
177 4140 : *size = asz * el_size;
178 4140 : 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 670 : encode_integer (int kind, mpz_t integer, unsigned char *buffer,
209 : size_t buffer_size)
210 : {
211 670 : return native_encode_expr (gfc_conv_mpz_to_tree (integer, kind),
212 670 : 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 23 : logical),
241 23 : buffer, buffer_size);
242 : }
243 :
244 :
245 : size_t
246 145369 : gfc_encode_character (int kind, size_t length, const gfc_char_t *string,
247 : unsigned char *buffer, size_t buffer_size)
248 : {
249 145369 : size_t elsize = size_character (1, kind);
250 145369 : tree type = gfc_get_char_type (kind);
251 :
252 145369 : gcc_assert (buffer_size >= size_character (length, kind));
253 :
254 2094986 : for (size_t i = 0; i < length; i++)
255 1949617 : native_encode_expr (build_int_cst (type, string[i]), &buffer[i*elsize],
256 : elsize);
257 :
258 145369 : 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 1507 : gfc_target_encode_expr (gfc_expr *source, unsigned char *buffer,
304 : size_t buffer_size)
305 : {
306 1507 : if (source == NULL)
307 : return 0;
308 :
309 1507 : if (source->expr_type == EXPR_ARRAY)
310 222 : return encode_array (source, buffer, buffer_size);
311 :
312 1285 : 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 1285 : 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 1171 : switch (source->ts.type)
326 : {
327 413 : case BT_INTEGER:
328 413 : return encode_integer (source->ts.kind, source->value.integer, buffer,
329 413 : 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 52 : for (;cmp; cmp = cmp->next)
539 : {
540 42 : gfc_constructor *c;
541 42 : gfc_expr *e = gfc_get_constant_expr (cmp->ts.type, cmp->ts.kind,
542 : &result->where);
543 42 : e->ts = cmp->ts;
544 :
545 : /* Copy shape, if needed. */
546 42 : 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 36 : c = gfc_constructor_append_expr (&result->value.constructor, e, NULL);
568 :
569 : /* The constructor points to the component. */
570 36 : 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 36 : gcc_assert (cmp->backend_decl);
579 36 : ptr = TREE_INT_CST_LOW (DECL_FIELD_BIT_OFFSET (cmp->backend_decl));
580 36 : gcc_assert (ptr % 8 == 0);
581 36 : ptr = ptr/8 + TREE_INT_CST_LOW (DECL_FIELD_OFFSET (cmp->backend_decl));
582 :
583 36 : gcc_assert (e->ts.type != BT_VOID || cmp->attr.caf_token);
584 36 : 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 496 : case BT_INTEGER:
602 992 : result->representation.length =
603 992 : gfc_interpret_integer (result->ts.kind, buffer, buffer_size,
604 496 : result->value.integer);
605 496 : 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 0 : case BT_VOID:
640 : /* This deals with caf_tokens. */
641 0 : result->representation.length =
642 0 : gfc_interpret_integer (result->ts.kind, buffer, buffer_size,
643 0 : result->value.integer);
644 0 : 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 : }
|
