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
5This file is part of GCC.
6
7GCC is free software; you can redistribute it and/or modify it under
8the terms of the GNU General Public License as published by the Free
9Software Foundation; either version 3, or (at your option) any later
10version.
11
12GCC is distributed in the hope that it will be useful, but WITHOUT ANY
13WARRANTY; without even the implied warranty of MERCHANTABILITY or
14FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
15for more details.
16
17You should have received a copy of the GNU General Public License
18along 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
39static size_t
40size_integer (int kind)
41{
42 return GET_MODE_SIZE (SCALAR_INT_TYPE_MODE (gfc_get_int_type (kind)));
43}
44
45
46static size_t
47size_float (int kind)
48{
49 return GET_MODE_SIZE (SCALAR_FLOAT_TYPE_MODE (gfc_get_real_type (kind)));
50}
51
52
53static size_t
54size_complex (int kind)
55{
56 return 2 * size_float (kind);
57}
58
59
60static size_t
61size_logical (int kind)
62{
63 return GET_MODE_SIZE (SCALAR_INT_TYPE_MODE (gfc_get_logical_type (kind)));
64}
65
66
67static size_t
68size_character (gfc_charlen_t length, int kind)
69{
70 int i = gfc_validate_kind (BT_CHARACTER, kind, false);
71 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
78bool
79gfc_element_size (gfc_expr *e, size_t *siz)
80{
81 tree type;
82
83 switch (e->ts.type)
84 {
85 case BT_INTEGER:
86 *siz = size_integer (kind: e->ts.kind);
87 return true;
88 case BT_REAL:
89 *siz = size_float (kind: e->ts.kind);
90 return true;
91 case BT_COMPLEX:
92 *siz = size_complex (kind: e->ts.kind);
93 return true;
94 case BT_LOGICAL:
95 *siz = size_logical (kind: e->ts.kind);
96 return true;
97 case BT_CHARACTER:
98 if (e->expr_type == EXPR_CONSTANT)
99 *siz = size_character (length: e->value.character.length, kind: e->ts.kind);
100 else if (e->ts.u.cl != NULL && e->ts.u.cl->length != NULL
101 && e->ts.u.cl->length->expr_type == EXPR_CONSTANT
102 && e->ts.u.cl->length->ts.type == BT_INTEGER)
103 {
104 HOST_WIDE_INT length;
105
106 gfc_extract_hwi (e->ts.u.cl->length, &length);
107 *siz = size_character (length, kind: e->ts.kind);
108 }
109 else
110 {
111 *siz = 0;
112 return false;
113 }
114 return true;
115
116 case BT_HOLLERITH:
117 *siz = e->representation.length;
118 return true;
119 case BT_DERIVED:
120 case BT_CLASS:
121 case BT_VOID:
122 case BT_ASSUMED:
123 case BT_PROCEDURE:
124 {
125 /* Determine type size without clobbering the typespec for ISO C
126 binding types. */
127 gfc_typespec ts;
128 HOST_WIDE_INT size;
129 ts = e->ts;
130 type = gfc_typenode_for_spec (&ts);
131 size = int_size_in_bytes (type);
132 gcc_assert (size >= 0);
133 *siz = size;
134 }
135 return true;
136 default:
137 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
146bool
147gfc_target_expr_size (gfc_expr *e, size_t *size)
148{
149 mpz_t tmp;
150 size_t asz, el_size;
151
152 gcc_assert (e != NULL);
153
154 *size = 0;
155 if (e->rank)
156 {
157 if (gfc_array_size (e, &tmp))
158 asz = mpz_get_ui (gmp_z: tmp);
159 else
160 return false;
161 }
162 else
163 asz = 1;
164
165 if (!gfc_element_size (e, siz: &el_size))
166 return false;
167 *size = asz * el_size;
168 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
176static unsigned HOST_WIDE_INT
177encode_array (gfc_expr *expr, unsigned char *buffer, size_t buffer_size)
178{
179 mpz_t array_size;
180 int i;
181 int ptr = 0;
182
183 gfc_constructor_base ctor = expr->value.constructor;
184
185 gfc_array_size (expr, &array_size);
186 for (i = 0; i < (int)mpz_get_ui (gmp_z: array_size); i++)
187 {
188 ptr += gfc_target_encode_expr (gfc_constructor_lookup_expr (base: ctor, n: i),
189 &buffer[ptr], buffer_size - ptr);
190 }
191
192 mpz_clear (array_size);
193 return ptr;
194}
195
196
197static int
198encode_integer (int kind, mpz_t integer, unsigned char *buffer,
199 size_t buffer_size)
200{
201 return native_encode_expr (gfc_conv_mpz_to_tree (integer, kind),
202 buffer, buffer_size);
203}
204
205
206static int
207encode_float (int kind, mpfr_t real, unsigned char *buffer, size_t buffer_size)
208{
209 return native_encode_expr (gfc_conv_mpfr_to_tree (real, kind, 0), buffer,
210 buffer_size);
211}
212
213
214static int
215encode_complex (int kind, mpc_t cmplx,
216 unsigned char *buffer, size_t buffer_size)
217{
218 int size;
219 size = encode_float (kind, mpc_realref (cmplx), buffer: &buffer[0], buffer_size);
220 size += encode_float (kind, mpc_imagref (cmplx),
221 buffer: &buffer[size], buffer_size: buffer_size - size);
222 return size;
223}
224
225
226static int
227encode_logical (int kind, int logical, unsigned char *buffer, size_t buffer_size)
228{
229 return native_encode_expr (build_int_cst (gfc_get_logical_type (kind),
230 logical),
231 buffer, buffer_size);
232}
233
234
235size_t
236gfc_encode_character (int kind, size_t length, const gfc_char_t *string,
237 unsigned char *buffer, size_t buffer_size)
238{
239 size_t elsize = size_character (length: 1, kind);
240 tree type = gfc_get_char_type (kind);
241
242 gcc_assert (buffer_size >= size_character (length, kind));
243
244 for (size_t i = 0; i < length; i++)
245 native_encode_expr (build_int_cst (type, string[i]), &buffer[i*elsize],
246 elsize);
247
248 return length;
249}
250
251
252static unsigned HOST_WIDE_INT
253encode_derived (gfc_expr *source, unsigned char *buffer, size_t buffer_size)
254{
255 gfc_constructor *c;
256 gfc_component *cmp;
257 int ptr;
258 tree type;
259 HOST_WIDE_INT size;
260
261 type = gfc_typenode_for_spec (&source->ts);
262
263 for (c = gfc_constructor_first (base: source->value.constructor),
264 cmp = source->ts.u.derived->components;
265 c;
266 c = gfc_constructor_next (ctor: c), cmp = cmp->next)
267 {
268 gcc_assert (cmp);
269 if (!c->expr)
270 continue;
271 ptr = TREE_INT_CST_LOW(DECL_FIELD_OFFSET(cmp->backend_decl))
272 + TREE_INT_CST_LOW(DECL_FIELD_BIT_OFFSET(cmp->backend_decl))/8;
273
274 if (c->expr->expr_type == EXPR_NULL)
275 {
276 size = int_size_in_bytes (TREE_TYPE (cmp->backend_decl));
277 gcc_assert (size >= 0);
278 memset (s: &buffer[ptr], c: 0, n: size);
279 }
280 else
281 gfc_target_encode_expr (c->expr, &buffer[ptr],
282 buffer_size - ptr);
283 }
284
285 size = int_size_in_bytes (type);
286 gcc_assert (size >= 0);
287 return size;
288}
289
290
291/* Write a constant expression in binary form to a buffer. */
292unsigned HOST_WIDE_INT
293gfc_target_encode_expr (gfc_expr *source, unsigned char *buffer,
294 size_t buffer_size)
295{
296 if (source == NULL)
297 return 0;
298
299 if (source->expr_type == EXPR_ARRAY)
300 return encode_array (expr: source, buffer, buffer_size);
301
302 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 if (source->representation.string)
309 {
310 memcpy (dest: buffer, src: source->representation.string,
311 n: source->representation.length);
312 return source->representation.length;
313 }
314
315 switch (source->ts.type)
316 {
317 case BT_INTEGER:
318 return encode_integer (kind: source->ts.kind, integer: source->value.integer, buffer,
319 buffer_size);
320 case BT_REAL:
321 return encode_float (kind: source->ts.kind, real: source->value.real, buffer,
322 buffer_size);
323 case BT_COMPLEX:
324 return encode_complex (kind: source->ts.kind, cmplx: source->value.complex,
325 buffer, buffer_size);
326 case BT_LOGICAL:
327 return encode_logical (kind: source->ts.kind, logical: source->value.logical, buffer,
328 buffer_size);
329 case BT_CHARACTER:
330 if (source->expr_type == EXPR_CONSTANT || source->ref == NULL)
331 return gfc_encode_character (kind: source->ts.kind,
332 length: source->value.character.length,
333 string: source->value.character.string,
334 buffer, buffer_size);
335 else
336 {
337 HOST_WIDE_INT start, end;
338
339 gcc_assert (source->expr_type == EXPR_SUBSTRING);
340 gfc_extract_hwi (source->ref->u.ss.start, &start);
341 gfc_extract_hwi (source->ref->u.ss.end, &end);
342 return gfc_encode_character (kind: source->ts.kind, MAX(end - start + 1, 0),
343 string: &source->value.character.string[start-1],
344 buffer, buffer_size);
345 }
346
347 case BT_DERIVED:
348 if (source->ts.u.derived->ts.f90_type == BT_VOID)
349 {
350 gfc_constructor *c;
351 gcc_assert (source->expr_type == EXPR_STRUCTURE);
352 c = gfc_constructor_first (base: source->value.constructor);
353 gcc_assert (c->expr->expr_type == EXPR_CONSTANT
354 && c->expr->ts.type == BT_INTEGER);
355 return encode_integer (kind: gfc_index_integer_kind, integer: c->expr->value.integer,
356 buffer, buffer_size);
357 }
358
359 return encode_derived (source, buffer, buffer_size);
360 default:
361 gfc_internal_error ("Invalid expression in gfc_target_encode_expr.");
362 return 0;
363 }
364}
365
366
367static size_t
368interpret_array (unsigned char *buffer, size_t buffer_size, gfc_expr *result,
369 bool convert_widechar)
370{
371 gfc_constructor_base base = NULL;
372 size_t array_size = 1;
373 size_t ptr = 0;
374
375 /* Calculate array size from its shape and rank. */
376 gcc_assert (result->rank > 0 && result->shape);
377
378 for (int i = 0; i < result->rank; i++)
379 array_size *= mpz_get_ui (gmp_z: result->shape[i]);
380
381 /* Iterate over array elements, producing constructors. */
382 for (size_t i = 0; i < array_size; i++)
383 {
384 gfc_expr *e = gfc_get_constant_expr (result->ts.type, result->ts.kind,
385 &result->where);
386 e->ts = result->ts;
387
388 if (e->ts.type == BT_CHARACTER)
389 e->value.character.length = result->value.character.length;
390
391 gfc_constructor_append_expr (base: &base, e, where: &result->where);
392
393 ptr += gfc_target_interpret_expr (&buffer[ptr], buffer_size - ptr, e,
394 convert_widechar);
395 }
396
397 result->value.constructor = base;
398 return ptr;
399}
400
401
402int
403gfc_interpret_integer (int kind, unsigned char *buffer, size_t buffer_size,
404 mpz_t integer)
405{
406 mpz_init (integer);
407 gfc_conv_tree_to_mpz (integer,
408 native_interpret_expr (gfc_get_int_type (kind),
409 buffer, buffer_size));
410 return size_integer (kind);
411}
412
413
414int
415gfc_interpret_float (int kind, unsigned char *buffer, size_t buffer_size,
416 mpfr_t real)
417{
418 gfc_set_model_kind (kind);
419
420 tree source = native_interpret_expr (gfc_get_real_type (kind), buffer,
421 buffer_size);
422 if (!source)
423 return 0;
424
425 mpfr_init (real);
426 gfc_conv_tree_to_mpfr (real, source);
427 return size_float (kind);
428}
429
430
431int
432gfc_interpret_complex (int kind, unsigned char *buffer, size_t buffer_size,
433 mpc_t complex)
434{
435 int size;
436 size = gfc_interpret_float (kind, buffer: &buffer[0], buffer_size,
437 mpc_realref (complex));
438 size += gfc_interpret_float (kind, buffer: &buffer[size], buffer_size: buffer_size - size,
439 mpc_imagref (complex));
440 return size;
441}
442
443
444int
445gfc_interpret_logical (int kind, unsigned char *buffer, size_t buffer_size,
446 int *logical)
447{
448 tree t = native_interpret_expr (gfc_get_logical_type (kind), buffer,
449 buffer_size);
450 *logical = wi::to_wide (t) == 0 ? 0 : 1;
451 return size_logical (kind);
452}
453
454
455size_t
456gfc_interpret_character (unsigned char *buffer, size_t buffer_size,
457 gfc_expr *result)
458{
459 if (result->ts.u.cl && result->ts.u.cl->length)
460 result->value.character.length =
461 gfc_mpz_get_hwi (result->ts.u.cl->length->value.integer);
462
463 gcc_assert (buffer_size >= size_character (result->value.character.length,
464 result->ts.kind));
465 result->value.character.string =
466 gfc_get_wide_string (result->value.character.length + 1);
467
468 if (result->ts.kind == gfc_default_character_kind)
469 for (size_t i = 0; i < (size_t) result->value.character.length; i++)
470 result->value.character.string[i] = (gfc_char_t) buffer[i];
471 else
472 {
473 mpz_t integer;
474 size_t bytes = size_character (length: 1, kind: result->ts.kind);
475 mpz_init (integer);
476 gcc_assert (bytes <= sizeof (unsigned long));
477
478 for (size_t i = 0; i < (size_t) result->value.character.length; i++)
479 {
480 gfc_conv_tree_to_mpz (integer,
481 native_interpret_expr (gfc_get_char_type (result->ts.kind),
482 &buffer[bytes*i], buffer_size-bytes*i));
483 result->value.character.string[i]
484 = (gfc_char_t) mpz_get_ui (gmp_z: integer);
485 }
486
487 mpz_clear (integer);
488 }
489
490 result->value.character.string[result->value.character.length] = '\0';
491
492 return size_character (length: result->value.character.length, kind: result->ts.kind);
493}
494
495
496int
497gfc_interpret_derived (unsigned char *buffer, size_t buffer_size, gfc_expr *result)
498{
499 gfc_component *cmp;
500 int ptr;
501 tree type;
502
503 /* The attributes of the derived type need to be bolted to the floor. */
504 result->expr_type = EXPR_STRUCTURE;
505
506 cmp = result->ts.u.derived->components;
507
508 if (result->ts.u.derived->from_intmod == INTMOD_ISO_C_BINDING
509 && (result->ts.u.derived->intmod_sym_id == ISOCBINDING_PTR
510 || result->ts.u.derived->intmod_sym_id == ISOCBINDING_FUNPTR))
511 {
512 gfc_constructor *c;
513 gfc_expr *e;
514 /* Needed as gfc_typenode_for_spec as gfc_typenode_for_spec
515 sets this to BT_INTEGER. */
516 result->ts.type = BT_DERIVED;
517 e = gfc_get_constant_expr (cmp->ts.type, cmp->ts.kind, &result->where);
518 c = gfc_constructor_append_expr (base: &result->value.constructor, e, NULL);
519 c->n.component = cmp;
520 gfc_target_interpret_expr (buffer, buffer_size, e, true);
521 e->ts.is_iso_c = 1;
522 return int_size_in_bytes (ptr_type_node);
523 }
524
525 type = gfc_typenode_for_spec (&result->ts);
526
527 /* Run through the derived type components. */
528 for (;cmp; cmp = cmp->next)
529 {
530 gfc_constructor *c;
531 gfc_expr *e = gfc_get_constant_expr (cmp->ts.type, cmp->ts.kind,
532 &result->where);
533 e->ts = cmp->ts;
534
535 /* Copy shape, if needed. */
536 if (cmp->as && cmp->as->rank)
537 {
538 int n;
539
540 if (cmp->as->type != AS_EXPLICIT)
541 return 0;
542
543 e->expr_type = EXPR_ARRAY;
544 e->rank = cmp->as->rank;
545
546 e->shape = gfc_get_shape (e->rank);
547 for (n = 0; n < e->rank; n++)
548 {
549 mpz_init_set_ui (e->shape[n], 1);
550 mpz_add (e->shape[n], e->shape[n],
551 cmp->as->upper[n]->value.integer);
552 mpz_sub (e->shape[n], e->shape[n],
553 cmp->as->lower[n]->value.integer);
554 }
555 }
556
557 c = gfc_constructor_append_expr (base: &result->value.constructor, e, NULL);
558
559 /* The constructor points to the component. */
560 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 gcc_assert (cmp->backend_decl);
569 ptr = TREE_INT_CST_LOW (DECL_FIELD_BIT_OFFSET (cmp->backend_decl));
570 gcc_assert (ptr % 8 == 0);
571 ptr = ptr/8 + TREE_INT_CST_LOW (DECL_FIELD_OFFSET (cmp->backend_decl));
572
573 gcc_assert (e->ts.type != BT_VOID || cmp->attr.caf_token);
574 gfc_target_interpret_expr (&buffer[ptr], buffer_size - ptr, e, true);
575 }
576
577 return int_size_in_bytes (type);
578}
579
580
581/* Read a binary buffer to a constant expression. */
582size_t
583gfc_target_interpret_expr (unsigned char *buffer, size_t buffer_size,
584 gfc_expr *result, bool convert_widechar)
585{
586 if (result->expr_type == EXPR_ARRAY)
587 return interpret_array (buffer, buffer_size, result, convert_widechar);
588
589 switch (result->ts.type)
590 {
591 case BT_INTEGER:
592 result->representation.length =
593 gfc_interpret_integer (kind: result->ts.kind, buffer, buffer_size,
594 integer: result->value.integer);
595 break;
596
597 case BT_REAL:
598 result->representation.length =
599 gfc_interpret_float (kind: result->ts.kind, buffer, buffer_size,
600 real: result->value.real);
601 break;
602
603 case BT_COMPLEX:
604 result->representation.length =
605 gfc_interpret_complex (kind: result->ts.kind, buffer, buffer_size,
606 complex: result->value.complex);
607 break;
608
609 case BT_LOGICAL:
610 result->representation.length =
611 gfc_interpret_logical (kind: result->ts.kind, buffer, buffer_size,
612 logical: &result->value.logical);
613 break;
614
615 case BT_CHARACTER:
616 result->representation.length =
617 gfc_interpret_character (buffer, buffer_size, result);
618 break;
619
620 case BT_CLASS:
621 result->ts = CLASS_DATA (result)->ts;
622 /* Fall through. */
623 case BT_DERIVED:
624 result->representation.length =
625 gfc_interpret_derived (buffer, buffer_size, result);
626 gcc_assert (result->representation.length >= 0);
627 break;
628
629 case BT_VOID:
630 /* This deals with caf_tokens. */
631 result->representation.length =
632 gfc_interpret_integer (kind: result->ts.kind, buffer, buffer_size,
633 integer: result->value.integer);
634 break;
635
636 default:
637 gfc_internal_error ("Invalid expression in gfc_target_interpret_expr.");
638 break;
639 }
640
641 if (result->ts.type == BT_CHARACTER && convert_widechar)
642 result->representation.string
643 = gfc_widechar_to_char (result->value.character.string,
644 result->value.character.length);
645 else
646 {
647 result->representation.string =
648 XCNEWVEC (char, result->representation.length + 1);
649 memcpy (dest: result->representation.string, src: buffer,
650 n: result->representation.length);
651 result->representation.string[result->representation.length] = '\0';
652 }
653
654 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
668static size_t
669expr_to_char (gfc_expr *e, locus *loc,
670 unsigned char *data, unsigned char *chk, size_t len)
671{
672 int i;
673 int ptr;
674 gfc_constructor *c;
675 gfc_component *cmp;
676 unsigned char *buffer;
677
678 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 if (e->ts.type == BT_DERIVED)
684 {
685 for (c = gfc_constructor_first (base: e->value.constructor),
686 cmp = e->ts.u.derived->components;
687 c; c = gfc_constructor_next (ctor: c), cmp = cmp->next)
688 {
689 gcc_assert (cmp && cmp->backend_decl);
690 if (!c->expr)
691 continue;
692 ptr = TREE_INT_CST_LOW(DECL_FIELD_OFFSET(cmp->backend_decl))
693 + TREE_INT_CST_LOW(DECL_FIELD_BIT_OFFSET(cmp->backend_decl))/8;
694 expr_to_char (e: c->expr, loc, data: &data[ptr], chk: &chk[ptr], len);
695 }
696 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 gfc_target_expr_size (e, size: &len);
702 buffer = (unsigned char*)alloca (len);
703 len = gfc_target_encode_expr (source: e, buffer, buffer_size: len);
704
705 for (i = 0; i < (int)len; i++)
706 {
707 if (chk[i] && (buffer[i] != data[i]))
708 {
709 if (loc)
710 gfc_error ("Overlapping unequal initializers in EQUIVALENCE "
711 "at %L", loc);
712 else
713 gfc_error ("Overlapping unequal initializers in EQUIVALENCE "
714 "at %C");
715 return 0;
716 }
717 chk[i] = 0xFF;
718 }
719
720 memcpy (dest: data, src: buffer, n: len);
721 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
729size_t
730gfc_merge_initializers (gfc_typespec ts, gfc_expr *e, locus *loc,
731 unsigned char *data,
732 unsigned char *chk, size_t length)
733{
734 size_t len = 0;
735 gfc_constructor * c;
736
737 switch (e->expr_type)
738 {
739 case EXPR_CONSTANT:
740 case EXPR_STRUCTURE:
741 len = expr_to_char (e, loc, data: &data[0], chk: &chk[0], len: length);
742 break;
743
744 case EXPR_ARRAY:
745 for (c = gfc_constructor_first (base: e->value.constructor);
746 c; c = gfc_constructor_next (ctor: c))
747 {
748 size_t elt_size;
749
750 gfc_target_expr_size (e: c->expr, size: &elt_size);
751
752 if (mpz_cmp_si (c->offset, 0) != 0)
753 len = elt_size * (size_t)mpz_get_si (c->offset);
754
755 len = len + gfc_merge_initializers (ts, e: c->expr, loc, data: &data[len],
756 chk: &chk[len], length: 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
771bool
772gfc_convert_boz (gfc_expr *expr, gfc_typespec *ts)
773{
774 size_t buffer_size, boz_bit_size, ts_bit_size;
775 int index;
776 unsigned char *buffer;
777
778 if (expr->ts.type != BT_INTEGER)
779 return true;
780
781 /* Don't convert BOZ to logical, character, derived etc. */
782 gcc_assert (ts->type == BT_REAL);
783
784 buffer_size = size_float (kind: ts->kind);
785 ts_bit_size = buffer_size * 8;
786
787 /* Convert BOZ to the smallest possible integer kind. */
788 boz_bit_size = mpz_sizeinbase (expr->value.integer, 2);
789
790 gcc_assert (boz_bit_size <= ts_bit_size);
791
792 for (index = 0; gfc_integer_kinds[index].kind != 0; ++index)
793 if ((unsigned) gfc_integer_kinds[index].bit_size >= ts_bit_size)
794 break;
795
796 expr->ts.kind = gfc_integer_kinds[index].kind;
797 buffer_size = MAX (buffer_size, size_integer (expr->ts.kind));
798
799 buffer = (unsigned char*)alloca (buffer_size);
800 encode_integer (kind: expr->ts.kind, integer: expr->value.integer, buffer, buffer_size);
801 mpz_clear (expr->value.integer);
802
803 mpfr_init (expr->value.real);
804 gfc_interpret_float (kind: ts->kind, buffer, buffer_size, real: expr->value.real);
805
806 expr->ts.type = ts->type;
807 expr->ts.kind = ts->kind;
808
809 return true;
810}
811

source code of gcc/fortran/target-memory.cc