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