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 | 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 |
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 |
54 | size_complex (int kind) |
55 | { |
56 | return 2 * size_float (kind); |
57 | } |
58 | |
59 | |
60 | static size_t |
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 |
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 |
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 (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 | |
146 | bool |
147 | gfc_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 | |
176 | static unsigned HOST_WIDE_INT |
177 | encode_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 | |
197 | static int |
198 | encode_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 | |
206 | static int |
207 | encode_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 | |
214 | static int |
215 | encode_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 | |
226 | static int |
227 | encode_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 | |
235 | size_t |
236 | gfc_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 | |
252 | static unsigned HOST_WIDE_INT |
253 | encode_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. */ |
292 | unsigned HOST_WIDE_INT |
293 | gfc_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 | |
367 | static size_t |
368 | interpret_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 | |
402 | int |
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 |
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 | |
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 | |
431 | int |
432 | gfc_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 | |
444 | int |
445 | gfc_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 | |
455 | size_t |
456 | gfc_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 | |
496 | int |
497 | gfc_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. */ |
582 | size_t |
583 | gfc_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 | |
668 | static size_t |
669 | expr_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 | |
729 | size_t |
730 | gfc_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 | |
771 | bool |
772 | gfc_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 | |