1 /* Simulate storage of variables into target memory.
2 Copyright (C) 2007, 2008
3 Free Software Foundation, Inc.
4 Contributed by Paul Thomas and Brooks Moses
6 This file is part of GCC.
8 GCC is free software; you can redistribute it and/or modify it under
9 the terms of the GNU General Public License as published by the Free
10 Software Foundation; either version 3, or (at your option) any later
13 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
14 WARRANTY; without even the implied warranty of MERCHANTABILITY or
15 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
18 You should have received a copy of the GNU General Public License
19 along with GCC; see the file COPYING3. If not see
20 <http://www.gnu.org/licenses/>. */
30 #include "trans-const.h"
31 #include "trans-types.h"
32 #include "target-memory.h"
34 /* --------------------------------------------------------------- */
35 /* Calculate the size of an expression. */
38 size_array (gfc_expr *e)
41 size_t elt_size = gfc_target_expr_size (e->value.constructor->expr);
43 gfc_array_size (e, &array_size);
44 return (size_t)mpz_get_ui (array_size) * elt_size;
48 size_integer (int kind)
50 return GET_MODE_SIZE (TYPE_MODE (gfc_get_int_type (kind)));;
57 return GET_MODE_SIZE (TYPE_MODE (gfc_get_real_type (kind)));;
62 size_complex (int kind)
64 return 2 * size_float (kind);
69 size_logical (int kind)
71 return GET_MODE_SIZE (TYPE_MODE (gfc_get_logical_type (kind)));;
76 size_character (int length, int kind)
78 int i = gfc_validate_kind (BT_CHARACTER, kind, false);
79 return length * gfc_character_kinds[i].bit_size / 8;
84 gfc_target_expr_size (gfc_expr *e)
88 gcc_assert (e != NULL);
90 if (e->expr_type == EXPR_ARRAY)
91 return size_array (e);
96 return size_integer (e->ts.kind);
98 return size_float (e->ts.kind);
100 return size_complex (e->ts.kind);
102 return size_logical (e->ts.kind);
104 if (e->expr_type == EXPR_SUBSTRING && e->ref)
108 gfc_extract_int (e->ref->u.ss.start, &start);
109 gfc_extract_int (e->ref->u.ss.end, &end);
110 return size_character (MAX(end - start + 1, 0), e->ts.kind);
113 return size_character (e->value.character.length, e->ts.kind);
115 return e->representation.length;
117 type = gfc_typenode_for_spec (&e->ts);
118 return int_size_in_bytes (type);
120 gfc_internal_error ("Invalid expression in gfc_target_expr_size.");
126 /* The encode_* functions export a value into a buffer, and
127 return the number of bytes of the buffer that have been
131 encode_array (gfc_expr *expr, unsigned char *buffer, size_t buffer_size)
137 gfc_array_size (expr, &array_size);
138 for (i = 0; i < (int)mpz_get_ui (array_size); i++)
140 ptr += gfc_target_encode_expr (gfc_get_array_element (expr, i),
141 &buffer[ptr], buffer_size - ptr);
144 mpz_clear (array_size);
150 encode_integer (int kind, mpz_t integer, unsigned char *buffer,
153 return native_encode_expr (gfc_conv_mpz_to_tree (integer, kind),
154 buffer, buffer_size);
159 encode_float (int kind, mpfr_t real, unsigned char *buffer, size_t buffer_size)
161 return native_encode_expr (gfc_conv_mpfr_to_tree (real, kind), buffer,
167 encode_complex (int kind, mpfr_t real, mpfr_t imaginary, unsigned char *buffer,
171 size = encode_float (kind, real, &buffer[0], buffer_size);
172 size += encode_float (kind, imaginary, &buffer[size], buffer_size - size);
178 encode_logical (int kind, int logical, unsigned char *buffer, size_t buffer_size)
180 return native_encode_expr (build_int_cst (gfc_get_logical_type (kind),
182 buffer, buffer_size);
187 gfc_encode_character (int kind, int length, const gfc_char_t *string,
188 unsigned char *buffer, size_t buffer_size)
190 size_t elsize = size_character (1, kind);
191 tree type = gfc_get_char_type (kind);
194 gcc_assert (buffer_size >= size_character (length, kind));
196 for (i = 0; i < length; i++)
197 native_encode_expr (build_int_cst (type, string[i]), &buffer[i*elsize],
205 encode_derived (gfc_expr *source, unsigned char *buffer, size_t buffer_size)
207 gfc_constructor *ctr;
212 type = gfc_typenode_for_spec (&source->ts);
214 ctr = source->value.constructor;
215 cmp = source->ts.derived->components;
216 for (;ctr; ctr = ctr->next, cmp = cmp->next)
221 ptr = TREE_INT_CST_LOW(DECL_FIELD_OFFSET(cmp->backend_decl))
222 + TREE_INT_CST_LOW(DECL_FIELD_BIT_OFFSET(cmp->backend_decl))/8;
223 gfc_target_encode_expr (ctr->expr, &buffer[ptr],
227 return int_size_in_bytes (type);
231 /* Write a constant expression in binary form to a buffer. */
233 gfc_target_encode_expr (gfc_expr *source, unsigned char *buffer,
239 if (source->expr_type == EXPR_ARRAY)
240 return encode_array (source, buffer, buffer_size);
242 gcc_assert (source->expr_type == EXPR_CONSTANT
243 || source->expr_type == EXPR_STRUCTURE
244 || source->expr_type == EXPR_SUBSTRING);
246 /* If we already have a target-memory representation, we use that rather
247 than recreating one. */
248 if (source->representation.string)
250 memcpy (buffer, source->representation.string,
251 source->representation.length);
252 return source->representation.length;
255 switch (source->ts.type)
258 return encode_integer (source->ts.kind, source->value.integer, buffer,
261 return encode_float (source->ts.kind, source->value.real, buffer,
264 return encode_complex (source->ts.kind, source->value.complex.r,
265 source->value.complex.i, buffer, buffer_size);
267 return encode_logical (source->ts.kind, source->value.logical, buffer,
270 if (source->expr_type == EXPR_CONSTANT || source->ref == NULL)
271 return gfc_encode_character (source->ts.kind,
272 source->value.character.length,
273 source->value.character.string,
274 buffer, buffer_size);
279 gcc_assert (source->expr_type == EXPR_SUBSTRING);
280 gfc_extract_int (source->ref->u.ss.start, &start);
281 gfc_extract_int (source->ref->u.ss.end, &end);
282 return gfc_encode_character (source->ts.kind, MAX(end - start + 1, 0),
283 &source->value.character.string[start-1],
284 buffer, buffer_size);
288 return encode_derived (source, buffer, buffer_size);
290 gfc_internal_error ("Invalid expression in gfc_target_encode_expr.");
297 interpret_array (unsigned char *buffer, size_t buffer_size, gfc_expr *result)
302 gfc_constructor *head = NULL, *tail = NULL;
304 /* Calculate array size from its shape and rank. */
305 gcc_assert (result->rank > 0 && result->shape);
307 for (i = 0; i < result->rank; i++)
308 array_size *= (int)mpz_get_ui (result->shape[i]);
310 /* Iterate over array elements, producing constructors. */
311 for (i = 0; i < array_size; i++)
314 head = tail = gfc_get_constructor ();
317 tail->next = gfc_get_constructor ();
321 tail->where = result->where;
322 tail->expr = gfc_constant_result (result->ts.type,
323 result->ts.kind, &result->where);
324 tail->expr->ts = result->ts;
326 if (tail->expr->ts.type == BT_CHARACTER)
327 tail->expr->value.character.length = result->value.character.length;
329 ptr += gfc_target_interpret_expr (&buffer[ptr], buffer_size - ptr,
332 result->value.constructor = head;
339 gfc_interpret_integer (int kind, unsigned char *buffer, size_t buffer_size,
343 gfc_conv_tree_to_mpz (integer,
344 native_interpret_expr (gfc_get_int_type (kind),
345 buffer, buffer_size));
346 return size_integer (kind);
351 gfc_interpret_float (int kind, unsigned char *buffer, size_t buffer_size,
354 gfc_set_model_kind (kind);
356 gfc_conv_tree_to_mpfr (real,
357 native_interpret_expr (gfc_get_real_type (kind),
358 buffer, buffer_size));
360 return size_float (kind);
365 gfc_interpret_complex (int kind, unsigned char *buffer, size_t buffer_size,
366 mpfr_t real, mpfr_t imaginary)
369 size = gfc_interpret_float (kind, &buffer[0], buffer_size, real);
370 size += gfc_interpret_float (kind, &buffer[size], buffer_size - size,
377 gfc_interpret_logical (int kind, unsigned char *buffer, size_t buffer_size,
380 tree t = native_interpret_expr (gfc_get_logical_type (kind), buffer,
382 *logical = double_int_zero_p (tree_to_double_int (t))
384 return size_logical (kind);
389 gfc_interpret_character (unsigned char *buffer, size_t buffer_size,
394 if (result->ts.cl && result->ts.cl->length)
395 result->value.character.length =
396 (int) mpz_get_ui (result->ts.cl->length->value.integer);
398 gcc_assert (buffer_size >= size_character (result->value.character.length,
400 result->value.character.string =
401 gfc_get_wide_string (result->value.character.length + 1);
403 if (result->ts.kind == gfc_default_character_kind)
404 for (i = 0; i < result->value.character.length; i++)
405 result->value.character.string[i] = (gfc_char_t) buffer[i];
409 unsigned bytes = size_character (1, result->ts.kind);
411 gcc_assert (bytes <= sizeof (unsigned long));
413 for (i = 0; i < result->value.character.length; i++)
415 gfc_conv_tree_to_mpz (integer,
416 native_interpret_expr (gfc_get_char_type (result->ts.kind),
417 &buffer[bytes*i], buffer_size-bytes*i));
418 result->value.character.string[i]
419 = (gfc_char_t) mpz_get_ui (integer);
425 result->value.character.string[result->value.character.length] = '\0';
427 return result->value.character.length;
432 gfc_interpret_derived (unsigned char *buffer, size_t buffer_size, gfc_expr *result)
435 gfc_constructor *head = NULL, *tail = NULL;
439 /* The attributes of the derived type need to be bolted to the floor. */
440 result->expr_type = EXPR_STRUCTURE;
442 type = gfc_typenode_for_spec (&result->ts);
443 cmp = result->ts.derived->components;
445 /* Run through the derived type components. */
446 for (;cmp; cmp = cmp->next)
449 head = tail = gfc_get_constructor ();
452 tail->next = gfc_get_constructor ();
456 /* The constructor points to the component. */
457 tail->n.component = cmp;
459 tail->expr = gfc_constant_result (cmp->ts.type, cmp->ts.kind,
461 tail->expr->ts = cmp->ts;
463 /* Copy shape, if needed. */
464 if (cmp->as && cmp->as->rank)
468 tail->expr->expr_type = EXPR_ARRAY;
469 tail->expr->rank = cmp->as->rank;
471 tail->expr->shape = gfc_get_shape (tail->expr->rank);
472 for (n = 0; n < tail->expr->rank; n++)
474 mpz_init_set_ui (tail->expr->shape[n], 1);
475 mpz_add (tail->expr->shape[n], tail->expr->shape[n],
476 cmp->as->upper[n]->value.integer);
477 mpz_sub (tail->expr->shape[n], tail->expr->shape[n],
478 cmp->as->lower[n]->value.integer);
482 ptr = TREE_INT_CST_LOW (DECL_FIELD_OFFSET (cmp->backend_decl));
483 gfc_target_interpret_expr (&buffer[ptr], buffer_size - ptr,
486 result->value.constructor = head;
489 return int_size_in_bytes (type);
493 /* Read a binary buffer to a constant expression. */
495 gfc_target_interpret_expr (unsigned char *buffer, size_t buffer_size,
498 if (result->expr_type == EXPR_ARRAY)
499 return interpret_array (buffer, buffer_size, result);
501 switch (result->ts.type)
504 result->representation.length =
505 gfc_interpret_integer (result->ts.kind, buffer, buffer_size,
506 result->value.integer);
510 result->representation.length =
511 gfc_interpret_float (result->ts.kind, buffer, buffer_size,
516 result->representation.length =
517 gfc_interpret_complex (result->ts.kind, buffer, buffer_size,
518 result->value.complex.r,
519 result->value.complex.i);
523 result->representation.length =
524 gfc_interpret_logical (result->ts.kind, buffer, buffer_size,
525 &result->value.logical);
529 result->representation.length =
530 gfc_interpret_character (buffer, buffer_size, result);
534 result->representation.length =
535 gfc_interpret_derived (buffer, buffer_size, result);
539 gfc_internal_error ("Invalid expression in gfc_target_interpret_expr.");
543 if (result->ts.type == BT_CHARACTER)
544 result->representation.string
545 = gfc_widechar_to_char (result->value.character.string,
546 result->value.character.length);
549 result->representation.string =
550 (char *) gfc_getmem (result->representation.length + 1);
551 memcpy (result->representation.string, buffer,
552 result->representation.length);
553 result->representation.string[result->representation.length] = '\0';
556 return result->representation.length;
560 /* --------------------------------------------------------------- */
561 /* Two functions used by trans-common.c to write overlapping
562 equivalence initializers to a buffer. This is added to the union
563 and the original initializers freed. */
566 /* Writes the values of a constant expression to a char buffer. If another
567 unequal initializer has already been written to the buffer, this is an
571 expr_to_char (gfc_expr *e, unsigned char *data, unsigned char *chk, size_t len)
575 gfc_constructor *ctr;
577 unsigned char *buffer;
582 /* Take a derived type, one component at a time, using the offsets from the backend
584 if (e->ts.type == BT_DERIVED)
586 ctr = e->value.constructor;
587 cmp = e->ts.derived->components;
588 for (;ctr; ctr = ctr->next, cmp = cmp->next)
590 gcc_assert (cmp && cmp->backend_decl);
593 ptr = TREE_INT_CST_LOW(DECL_FIELD_OFFSET(cmp->backend_decl))
594 + TREE_INT_CST_LOW(DECL_FIELD_BIT_OFFSET(cmp->backend_decl))/8;
595 expr_to_char (ctr->expr, &data[ptr], &chk[ptr], len);
600 /* Otherwise, use the target-memory machinery to write a bitwise image, appropriate
601 to the target, in a buffer and check off the initialized part of the buffer. */
602 len = gfc_target_expr_size (e);
603 buffer = (unsigned char*)alloca (len);
604 len = gfc_target_encode_expr (e, buffer, len);
606 for (i = 0; i < (int)len; i++)
608 if (chk[i] && (buffer[i] != data[i]))
610 gfc_error ("Overlapping unequal initializers in EQUIVALENCE "
617 memcpy (data, buffer, len);
622 /* Writes the values from the equivalence initializers to a char* array
623 that will be written to the constructor to make the initializer for
624 the union declaration. */
627 gfc_merge_initializers (gfc_typespec ts, gfc_expr *e, unsigned char *data,
628 unsigned char *chk, size_t length)
633 switch (e->expr_type)
637 len = expr_to_char (e, &data[0], &chk[0], length);
642 for (c = e->value.constructor; c; c = c->next)
644 size_t elt_size = gfc_target_expr_size (c->expr);
647 len = elt_size * (size_t)mpz_get_si (c->n.offset);
649 len = len + gfc_merge_initializers (ts, c->expr, &data[len],
650 &chk[len], length - len);
662 /* Transfer the bitpattern of a (integer) BOZ to real or complex variables.
663 When successful, no BOZ or nothing to do, true is returned. */
666 gfc_convert_boz (gfc_expr *expr, gfc_typespec *ts)
668 size_t buffer_size, boz_bit_size, ts_bit_size;
670 unsigned char *buffer;
675 gcc_assert (expr->expr_type == EXPR_CONSTANT
676 && expr->ts.type == BT_INTEGER);
678 /* Don't convert BOZ to logical, character, derived etc. */
679 if (ts->type == BT_REAL)
681 buffer_size = size_float (ts->kind);
682 ts_bit_size = buffer_size * 8;
684 else if (ts->type == BT_COMPLEX)
686 buffer_size = size_complex (ts->kind);
687 ts_bit_size = buffer_size * 8 / 2;
692 /* Convert BOZ to the smallest possible integer kind. */
693 boz_bit_size = mpz_sizeinbase (expr->value.integer, 2);
695 if (boz_bit_size > ts_bit_size)
697 gfc_error_now ("BOZ constant at %L is too large (%ld vs %ld bits)",
698 &expr->where, (long) boz_bit_size, (long) ts_bit_size);
702 for (index = 0; gfc_integer_kinds[index].kind != 0; ++index)
703 if ((unsigned) gfc_integer_kinds[index].bit_size >= ts_bit_size)
706 expr->ts.kind = gfc_integer_kinds[index].kind;
707 buffer_size = MAX (buffer_size, size_integer (expr->ts.kind));
709 buffer = (unsigned char*)alloca (buffer_size);
710 encode_integer (expr->ts.kind, expr->value.integer, buffer, buffer_size);
711 mpz_clear (expr->value.integer);
713 if (ts->type == BT_REAL)
715 mpfr_init (expr->value.real);
716 gfc_interpret_float (ts->kind, buffer, buffer_size, expr->value.real);
720 mpfr_init (expr->value.complex.r);
721 mpfr_init (expr->value.complex.i);
722 gfc_interpret_complex (ts->kind, buffer, buffer_size,
723 expr->value.complex.r, expr->value.complex.i);
726 expr->ts.type = ts->type;
727 expr->ts.kind = ts->kind;