Merged r158229 through r158464 into branch.
[official-gcc.git] / gcc / fortran / target-memory.c
blob93e1c8c89bb70a829af41d0a4328d703a9db4076
1 /* Simulate storage of variables into target memory.
2 Copyright (C) 2007, 2008, 2009, 2010
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
11 version.
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
16 for more details.
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/>. */
22 #include "config.h"
23 #include "system.h"
24 #include "flags.h"
25 #include "machmode.h"
26 #include "tree.h"
27 #include "gfortran.h"
28 #include "arith.h"
29 #include "constructor.h"
30 #include "trans.h"
31 #include "trans-const.h"
32 #include "trans-types.h"
33 #include "target-memory.h"
35 /* --------------------------------------------------------------- */
36 /* Calculate the size of an expression. */
38 static size_t
39 size_array (gfc_expr *e)
41 mpz_t array_size;
42 gfc_constructor *c = gfc_constructor_first (e->value.constructor);
43 size_t elt_size = gfc_target_expr_size (c->expr);
45 gfc_array_size (e, &array_size);
46 return (size_t)mpz_get_ui (array_size) * elt_size;
49 static size_t
50 size_integer (int kind)
52 return GET_MODE_SIZE (TYPE_MODE (gfc_get_int_type (kind)));;
56 static size_t
57 size_float (int kind)
59 return GET_MODE_SIZE (TYPE_MODE (gfc_get_real_type (kind)));;
63 static size_t
64 size_complex (int kind)
66 return 2 * size_float (kind);
70 static size_t
71 size_logical (int kind)
73 return GET_MODE_SIZE (TYPE_MODE (gfc_get_logical_type (kind)));;
77 static size_t
78 size_character (int length, int kind)
80 int i = gfc_validate_kind (BT_CHARACTER, kind, false);
81 return length * gfc_character_kinds[i].bit_size / 8;
85 size_t
86 gfc_target_expr_size (gfc_expr *e)
88 tree type;
90 gcc_assert (e != NULL);
92 if (e->expr_type == EXPR_ARRAY)
93 return size_array (e);
95 switch (e->ts.type)
97 case BT_INTEGER:
98 return size_integer (e->ts.kind);
99 case BT_REAL:
100 return size_float (e->ts.kind);
101 case BT_COMPLEX:
102 return size_complex (e->ts.kind);
103 case BT_LOGICAL:
104 return size_logical (e->ts.kind);
105 case BT_CHARACTER:
106 if (e->expr_type == EXPR_SUBSTRING && e->ref)
108 int start, end;
110 gfc_extract_int (e->ref->u.ss.start, &start);
111 gfc_extract_int (e->ref->u.ss.end, &end);
112 return size_character (MAX(end - start + 1, 0), e->ts.kind);
114 else
115 return size_character (e->value.character.length, e->ts.kind);
116 case BT_HOLLERITH:
117 return e->representation.length;
118 case BT_DERIVED:
119 type = gfc_typenode_for_spec (&e->ts);
120 return int_size_in_bytes (type);
121 default:
122 gfc_internal_error ("Invalid expression in gfc_target_expr_size.");
123 return 0;
128 /* The encode_* functions export a value into a buffer, and
129 return the number of bytes of the buffer that have been
130 used. */
132 static int
133 encode_array (gfc_expr *expr, unsigned char *buffer, size_t buffer_size)
135 mpz_t array_size;
136 int i;
137 int ptr = 0;
139 gfc_constructor_base ctor = expr->value.constructor;
141 gfc_array_size (expr, &array_size);
142 for (i = 0; i < (int)mpz_get_ui (array_size); i++)
144 ptr += gfc_target_encode_expr (gfc_constructor_lookup_expr (ctor, i),
145 &buffer[ptr], buffer_size - ptr);
148 mpz_clear (array_size);
149 return ptr;
153 static int
154 encode_integer (int kind, mpz_t integer, unsigned char *buffer,
155 size_t buffer_size)
157 return native_encode_expr (gfc_conv_mpz_to_tree (integer, kind),
158 buffer, buffer_size);
162 static int
163 encode_float (int kind, mpfr_t real, unsigned char *buffer, size_t buffer_size)
165 return native_encode_expr (gfc_conv_mpfr_to_tree (real, kind, 0), buffer,
166 buffer_size);
170 static int
171 encode_complex (int kind, mpc_t cmplx,
172 unsigned char *buffer, size_t buffer_size)
174 int size;
175 size = encode_float (kind, mpc_realref (cmplx), &buffer[0], buffer_size);
176 size += encode_float (kind, mpc_imagref (cmplx),
177 &buffer[size], buffer_size - size);
178 return size;
182 static int
183 encode_logical (int kind, int logical, unsigned char *buffer, size_t buffer_size)
185 return native_encode_expr (build_int_cst (gfc_get_logical_type (kind),
186 logical),
187 buffer, buffer_size);
192 gfc_encode_character (int kind, int length, const gfc_char_t *string,
193 unsigned char *buffer, size_t buffer_size)
195 size_t elsize = size_character (1, kind);
196 tree type = gfc_get_char_type (kind);
197 int i;
199 gcc_assert (buffer_size >= size_character (length, kind));
201 for (i = 0; i < length; i++)
202 native_encode_expr (build_int_cst (type, string[i]), &buffer[i*elsize],
203 elsize);
205 return length;
209 static int
210 encode_derived (gfc_expr *source, unsigned char *buffer, size_t buffer_size)
212 gfc_constructor *c;
213 gfc_component *cmp;
214 int ptr;
215 tree type;
217 type = gfc_typenode_for_spec (&source->ts);
219 for (c = gfc_constructor_first (source->value.constructor),
220 cmp = source->ts.u.derived->components;
222 c = gfc_constructor_next (c), cmp = cmp->next)
224 gcc_assert (cmp);
225 if (!c->expr)
226 continue;
227 ptr = TREE_INT_CST_LOW(DECL_FIELD_OFFSET(cmp->backend_decl))
228 + TREE_INT_CST_LOW(DECL_FIELD_BIT_OFFSET(cmp->backend_decl))/8;
230 if (c->expr->expr_type == EXPR_NULL)
231 memset (&buffer[ptr], 0,
232 int_size_in_bytes (TREE_TYPE (cmp->backend_decl)));
233 else
234 gfc_target_encode_expr (c->expr, &buffer[ptr],
235 buffer_size - ptr);
238 return int_size_in_bytes (type);
242 /* Write a constant expression in binary form to a buffer. */
244 gfc_target_encode_expr (gfc_expr *source, unsigned char *buffer,
245 size_t buffer_size)
247 if (source == NULL)
248 return 0;
250 if (source->expr_type == EXPR_ARRAY)
251 return encode_array (source, buffer, buffer_size);
253 gcc_assert (source->expr_type == EXPR_CONSTANT
254 || source->expr_type == EXPR_STRUCTURE
255 || source->expr_type == EXPR_SUBSTRING);
257 /* If we already have a target-memory representation, we use that rather
258 than recreating one. */
259 if (source->representation.string)
261 memcpy (buffer, source->representation.string,
262 source->representation.length);
263 return source->representation.length;
266 switch (source->ts.type)
268 case BT_INTEGER:
269 return encode_integer (source->ts.kind, source->value.integer, buffer,
270 buffer_size);
271 case BT_REAL:
272 return encode_float (source->ts.kind, source->value.real, buffer,
273 buffer_size);
274 case BT_COMPLEX:
275 return encode_complex (source->ts.kind, source->value.complex,
276 buffer, buffer_size);
277 case BT_LOGICAL:
278 return encode_logical (source->ts.kind, source->value.logical, buffer,
279 buffer_size);
280 case BT_CHARACTER:
281 if (source->expr_type == EXPR_CONSTANT || source->ref == NULL)
282 return gfc_encode_character (source->ts.kind,
283 source->value.character.length,
284 source->value.character.string,
285 buffer, buffer_size);
286 else
288 int start, end;
290 gcc_assert (source->expr_type == EXPR_SUBSTRING);
291 gfc_extract_int (source->ref->u.ss.start, &start);
292 gfc_extract_int (source->ref->u.ss.end, &end);
293 return gfc_encode_character (source->ts.kind, MAX(end - start + 1, 0),
294 &source->value.character.string[start-1],
295 buffer, buffer_size);
298 case BT_DERIVED:
299 return encode_derived (source, buffer, buffer_size);
300 default:
301 gfc_internal_error ("Invalid expression in gfc_target_encode_expr.");
302 return 0;
307 static int
308 interpret_array (unsigned char *buffer, size_t buffer_size, gfc_expr *result)
310 gfc_constructor_base base = NULL;
311 int array_size = 1;
312 int i;
313 int ptr = 0;
315 /* Calculate array size from its shape and rank. */
316 gcc_assert (result->rank > 0 && result->shape);
318 for (i = 0; i < result->rank; i++)
319 array_size *= (int)mpz_get_ui (result->shape[i]);
321 /* Iterate over array elements, producing constructors. */
322 for (i = 0; i < array_size; i++)
324 gfc_expr *e = gfc_get_constant_expr (result->ts.type, result->ts.kind,
325 &result->where);
326 e->ts = result->ts;
328 if (e->ts.type == BT_CHARACTER)
329 e->value.character.length = result->value.character.length;
331 gfc_constructor_append_expr (&base, e, &result->where);
333 ptr += gfc_target_interpret_expr (&buffer[ptr], buffer_size - ptr, e);
336 result->value.constructor = base;
337 return ptr;
342 gfc_interpret_integer (int kind, unsigned char *buffer, size_t buffer_size,
343 mpz_t integer)
345 mpz_init (integer);
346 gfc_conv_tree_to_mpz (integer,
347 native_interpret_expr (gfc_get_int_type (kind),
348 buffer, buffer_size));
349 return size_integer (kind);
354 gfc_interpret_float (int kind, unsigned char *buffer, size_t buffer_size,
355 mpfr_t real)
357 gfc_set_model_kind (kind);
358 mpfr_init (real);
359 gfc_conv_tree_to_mpfr (real,
360 native_interpret_expr (gfc_get_real_type (kind),
361 buffer, buffer_size));
363 return size_float (kind);
368 gfc_interpret_complex (int kind, unsigned char *buffer, size_t buffer_size,
369 mpc_t complex)
371 int size;
372 size = gfc_interpret_float (kind, &buffer[0], buffer_size,
373 mpc_realref (complex));
374 size += gfc_interpret_float (kind, &buffer[size], buffer_size - size,
375 mpc_imagref (complex));
376 return size;
381 gfc_interpret_logical (int kind, unsigned char *buffer, size_t buffer_size,
382 int *logical)
384 tree t = native_interpret_expr (gfc_get_logical_type (kind), buffer,
385 buffer_size);
386 *logical = double_int_zero_p (tree_to_double_int (t))
387 ? 0 : 1;
388 return size_logical (kind);
393 gfc_interpret_character (unsigned char *buffer, size_t buffer_size,
394 gfc_expr *result)
396 int i;
398 if (result->ts.u.cl && result->ts.u.cl->length)
399 result->value.character.length =
400 (int) mpz_get_ui (result->ts.u.cl->length->value.integer);
402 gcc_assert (buffer_size >= size_character (result->value.character.length,
403 result->ts.kind));
404 result->value.character.string =
405 gfc_get_wide_string (result->value.character.length + 1);
407 if (result->ts.kind == gfc_default_character_kind)
408 for (i = 0; i < result->value.character.length; i++)
409 result->value.character.string[i] = (gfc_char_t) buffer[i];
410 else
412 mpz_t integer;
413 unsigned bytes = size_character (1, result->ts.kind);
414 mpz_init (integer);
415 gcc_assert (bytes <= sizeof (unsigned long));
417 for (i = 0; i < result->value.character.length; i++)
419 gfc_conv_tree_to_mpz (integer,
420 native_interpret_expr (gfc_get_char_type (result->ts.kind),
421 &buffer[bytes*i], buffer_size-bytes*i));
422 result->value.character.string[i]
423 = (gfc_char_t) mpz_get_ui (integer);
426 mpz_clear (integer);
429 result->value.character.string[result->value.character.length] = '\0';
431 return result->value.character.length;
436 gfc_interpret_derived (unsigned char *buffer, size_t buffer_size, gfc_expr *result)
438 gfc_component *cmp;
439 int ptr;
440 tree type;
442 /* The attributes of the derived type need to be bolted to the floor. */
443 result->expr_type = EXPR_STRUCTURE;
445 type = gfc_typenode_for_spec (&result->ts);
446 cmp = result->ts.u.derived->components;
448 /* Run through the derived type components. */
449 for (;cmp; cmp = cmp->next)
451 gfc_constructor *c;
452 gfc_expr *e = gfc_get_constant_expr (cmp->ts.type, cmp->ts.kind,
453 &result->where);
454 e->ts = cmp->ts;
456 /* Copy shape, if needed. */
457 if (cmp->as && cmp->as->rank)
459 int n;
461 e->expr_type = EXPR_ARRAY;
462 e->rank = cmp->as->rank;
464 e->shape = gfc_get_shape (e->rank);
465 for (n = 0; n < e->rank; n++)
467 mpz_init_set_ui (e->shape[n], 1);
468 mpz_add (e->shape[n], e->shape[n],
469 cmp->as->upper[n]->value.integer);
470 mpz_sub (e->shape[n], e->shape[n],
471 cmp->as->lower[n]->value.integer);
475 c = gfc_constructor_append_expr (&result->value.constructor, e, NULL);
477 /* The constructor points to the component. */
478 c->n.component = cmp;
480 ptr = TREE_INT_CST_LOW (DECL_FIELD_OFFSET (cmp->backend_decl));
481 gfc_target_interpret_expr (&buffer[ptr], buffer_size - ptr, e);
484 return int_size_in_bytes (type);
488 /* Read a binary buffer to a constant expression. */
490 gfc_target_interpret_expr (unsigned char *buffer, size_t buffer_size,
491 gfc_expr *result)
493 if (result->expr_type == EXPR_ARRAY)
494 return interpret_array (buffer, buffer_size, result);
496 switch (result->ts.type)
498 case BT_INTEGER:
499 result->representation.length =
500 gfc_interpret_integer (result->ts.kind, buffer, buffer_size,
501 result->value.integer);
502 break;
504 case BT_REAL:
505 result->representation.length =
506 gfc_interpret_float (result->ts.kind, buffer, buffer_size,
507 result->value.real);
508 break;
510 case BT_COMPLEX:
511 result->representation.length =
512 gfc_interpret_complex (result->ts.kind, buffer, buffer_size,
513 result->value.complex);
514 break;
516 case BT_LOGICAL:
517 result->representation.length =
518 gfc_interpret_logical (result->ts.kind, buffer, buffer_size,
519 &result->value.logical);
520 break;
522 case BT_CHARACTER:
523 result->representation.length =
524 gfc_interpret_character (buffer, buffer_size, result);
525 break;
527 case BT_DERIVED:
528 result->representation.length =
529 gfc_interpret_derived (buffer, buffer_size, result);
530 break;
532 default:
533 gfc_internal_error ("Invalid expression in gfc_target_interpret_expr.");
534 break;
537 if (result->ts.type == BT_CHARACTER)
538 result->representation.string
539 = gfc_widechar_to_char (result->value.character.string,
540 result->value.character.length);
541 else
543 result->representation.string =
544 (char *) gfc_getmem (result->representation.length + 1);
545 memcpy (result->representation.string, buffer,
546 result->representation.length);
547 result->representation.string[result->representation.length] = '\0';
550 return result->representation.length;
554 /* --------------------------------------------------------------- */
555 /* Two functions used by trans-common.c to write overlapping
556 equivalence initializers to a buffer. This is added to the union
557 and the original initializers freed. */
560 /* Writes the values of a constant expression to a char buffer. If another
561 unequal initializer has already been written to the buffer, this is an
562 error. */
564 static size_t
565 expr_to_char (gfc_expr *e, unsigned char *data, unsigned char *chk, size_t len)
567 int i;
568 int ptr;
569 gfc_constructor *c;
570 gfc_component *cmp;
571 unsigned char *buffer;
573 if (e == NULL)
574 return 0;
576 /* Take a derived type, one component at a time, using the offsets from the backend
577 declaration. */
578 if (e->ts.type == BT_DERIVED)
580 for (c = gfc_constructor_first (e->value.constructor),
581 cmp = e->ts.u.derived->components;
582 c; c = gfc_constructor_next (c), cmp = cmp->next)
584 gcc_assert (cmp && cmp->backend_decl);
585 if (!c->expr)
586 continue;
587 ptr = TREE_INT_CST_LOW(DECL_FIELD_OFFSET(cmp->backend_decl))
588 + TREE_INT_CST_LOW(DECL_FIELD_BIT_OFFSET(cmp->backend_decl))/8;
589 expr_to_char (c->expr, &data[ptr], &chk[ptr], len);
591 return len;
594 /* Otherwise, use the target-memory machinery to write a bitwise image, appropriate
595 to the target, in a buffer and check off the initialized part of the buffer. */
596 len = gfc_target_expr_size (e);
597 buffer = (unsigned char*)alloca (len);
598 len = gfc_target_encode_expr (e, buffer, len);
600 for (i = 0; i < (int)len; i++)
602 if (chk[i] && (buffer[i] != data[i]))
604 gfc_error ("Overlapping unequal initializers in EQUIVALENCE "
605 "at %L", &e->where);
606 return 0;
608 chk[i] = 0xFF;
611 memcpy (data, buffer, len);
612 return len;
616 /* Writes the values from the equivalence initializers to a char* array
617 that will be written to the constructor to make the initializer for
618 the union declaration. */
620 size_t
621 gfc_merge_initializers (gfc_typespec ts, gfc_expr *e, unsigned char *data,
622 unsigned char *chk, size_t length)
624 size_t len = 0;
625 gfc_constructor * c;
627 switch (e->expr_type)
629 case EXPR_CONSTANT:
630 case EXPR_STRUCTURE:
631 len = expr_to_char (e, &data[0], &chk[0], length);
633 break;
635 case EXPR_ARRAY:
636 for (c = gfc_constructor_first (e->value.constructor);
637 c; c = gfc_constructor_next (c))
639 size_t elt_size = gfc_target_expr_size (c->expr);
641 if (c->offset)
642 len = elt_size * (size_t)mpz_get_si (c->offset);
644 len = len + gfc_merge_initializers (ts, c->expr, &data[len],
645 &chk[len], length - len);
647 break;
649 default:
650 return 0;
653 return len;
657 /* Transfer the bitpattern of a (integer) BOZ to real or complex variables.
658 When successful, no BOZ or nothing to do, true is returned. */
660 bool
661 gfc_convert_boz (gfc_expr *expr, gfc_typespec *ts)
663 size_t buffer_size, boz_bit_size, ts_bit_size;
664 int index;
665 unsigned char *buffer;
667 if (!expr->is_boz)
668 return true;
670 gcc_assert (expr->expr_type == EXPR_CONSTANT
671 && expr->ts.type == BT_INTEGER);
673 /* Don't convert BOZ to logical, character, derived etc. */
674 if (ts->type == BT_REAL)
676 buffer_size = size_float (ts->kind);
677 ts_bit_size = buffer_size * 8;
679 else if (ts->type == BT_COMPLEX)
681 buffer_size = size_complex (ts->kind);
682 ts_bit_size = buffer_size * 8 / 2;
684 else
685 return true;
687 /* Convert BOZ to the smallest possible integer kind. */
688 boz_bit_size = mpz_sizeinbase (expr->value.integer, 2);
690 if (boz_bit_size > ts_bit_size)
692 gfc_error_now ("BOZ constant at %L is too large (%ld vs %ld bits)",
693 &expr->where, (long) boz_bit_size, (long) ts_bit_size);
694 return false;
697 for (index = 0; gfc_integer_kinds[index].kind != 0; ++index)
698 if ((unsigned) gfc_integer_kinds[index].bit_size >= ts_bit_size)
699 break;
701 expr->ts.kind = gfc_integer_kinds[index].kind;
702 buffer_size = MAX (buffer_size, size_integer (expr->ts.kind));
704 buffer = (unsigned char*)alloca (buffer_size);
705 encode_integer (expr->ts.kind, expr->value.integer, buffer, buffer_size);
706 mpz_clear (expr->value.integer);
708 if (ts->type == BT_REAL)
710 mpfr_init (expr->value.real);
711 gfc_interpret_float (ts->kind, buffer, buffer_size, expr->value.real);
713 else
715 mpc_init2 (expr->value.complex, mpfr_get_default_prec());
716 gfc_interpret_complex (ts->kind, buffer, buffer_size,
717 expr->value.complex);
719 expr->is_boz = 0;
720 expr->ts.type = ts->type;
721 expr->ts.kind = ts->kind;
723 return true;