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
)
83 gfc_target_expr_size (gfc_expr
*e
)
87 gcc_assert (e
!= NULL
);
89 if (e
->expr_type
== EXPR_ARRAY
)
90 return size_array (e
);
95 return size_integer (e
->ts
.kind
);
97 return size_float (e
->ts
.kind
);
99 return size_complex (e
->ts
.kind
);
101 return size_logical (e
->ts
.kind
);
103 return size_character (e
->value
.character
.length
);
105 return e
->representation
.length
;
107 type
= gfc_typenode_for_spec (&e
->ts
);
108 return int_size_in_bytes (type
);
110 gfc_internal_error ("Invalid expression in gfc_target_expr_size.");
116 /* The encode_* functions export a value into a buffer, and
117 return the number of bytes of the buffer that have been
121 encode_array (gfc_expr
*expr
, unsigned char *buffer
, size_t buffer_size
)
127 gfc_array_size (expr
, &array_size
);
128 for (i
= 0; i
< (int)mpz_get_ui (array_size
); i
++)
130 ptr
+= gfc_target_encode_expr (gfc_get_array_element (expr
, i
),
131 &buffer
[ptr
], buffer_size
- ptr
);
134 mpz_clear (array_size
);
140 encode_integer (int kind
, mpz_t integer
, unsigned char *buffer
,
143 return native_encode_expr (gfc_conv_mpz_to_tree (integer
, kind
),
144 buffer
, buffer_size
);
149 encode_float (int kind
, mpfr_t real
, unsigned char *buffer
, size_t buffer_size
)
151 return native_encode_expr (gfc_conv_mpfr_to_tree (real
, kind
), buffer
,
157 encode_complex (int kind
, mpfr_t real
, mpfr_t imaginary
, unsigned char *buffer
,
161 size
= encode_float (kind
, real
, &buffer
[0], buffer_size
);
162 size
+= encode_float (kind
, imaginary
, &buffer
[size
], buffer_size
- size
);
168 encode_logical (int kind
, int logical
, unsigned char *buffer
, size_t buffer_size
)
170 return native_encode_expr (build_int_cst (gfc_get_logical_type (kind
),
172 buffer
, buffer_size
);
177 encode_character (int length
, char *string
, unsigned char *buffer
,
180 gcc_assert (buffer_size
>= size_character (length
));
181 memcpy (buffer
, string
, length
);
187 encode_derived (gfc_expr
*source
, unsigned char *buffer
, size_t buffer_size
)
189 gfc_constructor
*ctr
;
194 type
= gfc_typenode_for_spec (&source
->ts
);
196 ctr
= source
->value
.constructor
;
197 cmp
= source
->ts
.derived
->components
;
198 for (;ctr
; ctr
= ctr
->next
, cmp
= cmp
->next
)
203 ptr
= TREE_INT_CST_LOW(DECL_FIELD_OFFSET(cmp
->backend_decl
))
204 + TREE_INT_CST_LOW(DECL_FIELD_BIT_OFFSET(cmp
->backend_decl
))/8;
205 gfc_target_encode_expr (ctr
->expr
, &buffer
[ptr
],
209 return int_size_in_bytes (type
);
213 /* Write a constant expression in binary form to a buffer. */
215 gfc_target_encode_expr (gfc_expr
*source
, unsigned char *buffer
,
221 if (source
->expr_type
== EXPR_ARRAY
)
222 return encode_array (source
, buffer
, buffer_size
);
224 gcc_assert (source
->expr_type
== EXPR_CONSTANT
225 || source
->expr_type
== EXPR_STRUCTURE
);
227 /* If we already have a target-memory representation, we use that rather
228 than recreating one. */
229 if (source
->representation
.string
)
231 memcpy (buffer
, source
->representation
.string
,
232 source
->representation
.length
);
233 return source
->representation
.length
;
236 switch (source
->ts
.type
)
239 return encode_integer (source
->ts
.kind
, source
->value
.integer
, buffer
,
242 return encode_float (source
->ts
.kind
, source
->value
.real
, buffer
,
245 return encode_complex (source
->ts
.kind
, source
->value
.complex.r
,
246 source
->value
.complex.i
, buffer
, buffer_size
);
248 return encode_logical (source
->ts
.kind
, source
->value
.logical
, buffer
,
251 return encode_character (source
->value
.character
.length
,
252 source
->value
.character
.string
, buffer
,
255 return encode_derived (source
, buffer
, buffer_size
);
257 gfc_internal_error ("Invalid expression in gfc_target_encode_expr.");
264 interpret_array (unsigned char *buffer
, size_t buffer_size
, gfc_expr
*result
)
269 gfc_constructor
*head
= NULL
, *tail
= NULL
;
271 /* Calculate array size from its shape and rank. */
272 gcc_assert (result
->rank
> 0 && result
->shape
);
274 for (i
= 0; i
< result
->rank
; i
++)
275 array_size
*= (int)mpz_get_ui (result
->shape
[i
]);
277 /* Iterate over array elements, producing constructors. */
278 for (i
= 0; i
< array_size
; i
++)
281 head
= tail
= gfc_get_constructor ();
284 tail
->next
= gfc_get_constructor ();
288 tail
->where
= result
->where
;
289 tail
->expr
= gfc_constant_result (result
->ts
.type
,
290 result
->ts
.kind
, &result
->where
);
291 tail
->expr
->ts
= result
->ts
;
293 if (tail
->expr
->ts
.type
== BT_CHARACTER
)
294 tail
->expr
->value
.character
.length
= result
->value
.character
.length
;
296 ptr
+= gfc_target_interpret_expr (&buffer
[ptr
], buffer_size
- ptr
,
299 result
->value
.constructor
= head
;
306 gfc_interpret_integer (int kind
, unsigned char *buffer
, size_t buffer_size
,
310 gfc_conv_tree_to_mpz (integer
,
311 native_interpret_expr (gfc_get_int_type (kind
),
312 buffer
, buffer_size
));
313 return size_integer (kind
);
318 gfc_interpret_float (int kind
, unsigned char *buffer
, size_t buffer_size
,
322 gfc_conv_tree_to_mpfr (real
,
323 native_interpret_expr (gfc_get_real_type (kind
),
324 buffer
, buffer_size
));
326 return size_float (kind
);
331 gfc_interpret_complex (int kind
, unsigned char *buffer
, size_t buffer_size
,
332 mpfr_t real
, mpfr_t imaginary
)
335 size
= gfc_interpret_float (kind
, &buffer
[0], buffer_size
, real
);
336 size
+= gfc_interpret_float (kind
, &buffer
[size
], buffer_size
- size
, imaginary
);
342 gfc_interpret_logical (int kind
, unsigned char *buffer
, size_t buffer_size
,
345 tree t
= native_interpret_expr (gfc_get_logical_type (kind
), buffer
,
347 *logical
= double_int_zero_p (tree_to_double_int (t
))
349 return size_logical (kind
);
354 gfc_interpret_character (unsigned char *buffer
, size_t buffer_size
, gfc_expr
*result
)
356 if (result
->ts
.cl
&& result
->ts
.cl
->length
)
357 result
->value
.character
.length
=
358 (int)mpz_get_ui (result
->ts
.cl
->length
->value
.integer
);
360 gcc_assert (buffer_size
>= size_character (result
->value
.character
.length
));
361 result
->value
.character
.string
=
362 gfc_getmem (result
->value
.character
.length
+ 1);
363 memcpy (result
->value
.character
.string
, buffer
,
364 result
->value
.character
.length
);
365 result
->value
.character
.string
[result
->value
.character
.length
] = '\0';
367 return result
->value
.character
.length
;
372 gfc_interpret_derived (unsigned char *buffer
, size_t buffer_size
, gfc_expr
*result
)
375 gfc_constructor
*head
= NULL
, *tail
= NULL
;
379 /* The attributes of the derived type need to be bolted to the floor. */
380 result
->expr_type
= EXPR_STRUCTURE
;
382 type
= gfc_typenode_for_spec (&result
->ts
);
383 cmp
= result
->ts
.derived
->components
;
385 /* Run through the derived type components. */
386 for (;cmp
; cmp
= cmp
->next
)
389 head
= tail
= gfc_get_constructor ();
392 tail
->next
= gfc_get_constructor ();
396 /* The constructor points to the component. */
397 tail
->n
.component
= cmp
;
399 tail
->expr
= gfc_constant_result (cmp
->ts
.type
, cmp
->ts
.kind
,
401 tail
->expr
->ts
= cmp
->ts
;
403 /* Copy shape, if needed. */
404 if (cmp
->as
&& cmp
->as
->rank
)
408 tail
->expr
->expr_type
= EXPR_ARRAY
;
409 tail
->expr
->rank
= cmp
->as
->rank
;
411 tail
->expr
->shape
= gfc_get_shape (tail
->expr
->rank
);
412 for (n
= 0; n
< tail
->expr
->rank
; n
++)
414 mpz_init_set_ui (tail
->expr
->shape
[n
], 1);
415 mpz_add (tail
->expr
->shape
[n
], tail
->expr
->shape
[n
],
416 cmp
->as
->upper
[n
]->value
.integer
);
417 mpz_sub (tail
->expr
->shape
[n
], tail
->expr
->shape
[n
],
418 cmp
->as
->lower
[n
]->value
.integer
);
422 ptr
= TREE_INT_CST_LOW (DECL_FIELD_OFFSET (cmp
->backend_decl
));
423 gfc_target_interpret_expr (&buffer
[ptr
], buffer_size
- ptr
,
426 result
->value
.constructor
= head
;
429 return int_size_in_bytes (type
);
433 /* Read a binary buffer to a constant expression. */
435 gfc_target_interpret_expr (unsigned char *buffer
, size_t buffer_size
,
438 if (result
->expr_type
== EXPR_ARRAY
)
439 return interpret_array (buffer
, buffer_size
, result
);
441 switch (result
->ts
.type
)
444 result
->representation
.length
=
445 gfc_interpret_integer (result
->ts
.kind
, buffer
, buffer_size
,
446 result
->value
.integer
);
450 result
->representation
.length
=
451 gfc_interpret_float (result
->ts
.kind
, buffer
, buffer_size
,
456 result
->representation
.length
=
457 gfc_interpret_complex (result
->ts
.kind
, buffer
, buffer_size
,
458 result
->value
.complex.r
,
459 result
->value
.complex.i
);
463 result
->representation
.length
=
464 gfc_interpret_logical (result
->ts
.kind
, buffer
, buffer_size
,
465 &result
->value
.logical
);
469 result
->representation
.length
=
470 gfc_interpret_character (buffer
, buffer_size
, result
);
474 result
->representation
.length
=
475 gfc_interpret_derived (buffer
, buffer_size
, result
);
479 gfc_internal_error ("Invalid expression in gfc_target_interpret_expr.");
483 if (result
->ts
.type
== BT_CHARACTER
)
484 result
->representation
.string
= result
->value
.character
.string
;
487 result
->representation
.string
=
488 gfc_getmem (result
->representation
.length
+ 1);
489 memcpy (result
->representation
.string
, buffer
,
490 result
->representation
.length
);
491 result
->representation
.string
[result
->representation
.length
] = '\0';
494 return result
->representation
.length
;
498 /* --------------------------------------------------------------- */
499 /* Two functions used by trans-common.c to write overlapping
500 equivalence initializers to a buffer. This is added to the union
501 and the original initializers freed. */
504 /* Writes the values of a constant expression to a char buffer. If another
505 unequal initializer has already been written to the buffer, this is an
509 expr_to_char (gfc_expr
*e
, unsigned char *data
, unsigned char *chk
, size_t len
)
513 gfc_constructor
*ctr
;
515 unsigned char *buffer
;
520 /* Take a derived type, one component at a time, using the offsets from the backend
522 if (e
->ts
.type
== BT_DERIVED
)
524 ctr
= e
->value
.constructor
;
525 cmp
= e
->ts
.derived
->components
;
526 for (;ctr
; ctr
= ctr
->next
, cmp
= cmp
->next
)
528 gcc_assert (cmp
&& cmp
->backend_decl
);
531 ptr
= TREE_INT_CST_LOW(DECL_FIELD_OFFSET(cmp
->backend_decl
))
532 + TREE_INT_CST_LOW(DECL_FIELD_BIT_OFFSET(cmp
->backend_decl
))/8;
533 expr_to_char (ctr
->expr
, &data
[ptr
], &chk
[ptr
], len
);
538 /* Otherwise, use the target-memory machinery to write a bitwise image, appropriate
539 to the target, in a buffer and check off the initialized part of the buffer. */
540 len
= gfc_target_expr_size (e
);
541 buffer
= (unsigned char*)alloca (len
);
542 len
= gfc_target_encode_expr (e
, buffer
, len
);
544 for (i
= 0; i
< (int)len
; i
++)
546 if (chk
[i
] && (buffer
[i
] != data
[i
]))
548 gfc_error ("Overlapping unequal initializers in EQUIVALENCE "
555 memcpy (data
, buffer
, len
);
560 /* Writes the values from the equivalence initializers to a char* array
561 that will be written to the constructor to make the initializer for
562 the union declaration. */
565 gfc_merge_initializers (gfc_typespec ts
, gfc_expr
*e
, unsigned char *data
,
566 unsigned char *chk
, size_t length
)
571 switch (e
->expr_type
)
575 len
= expr_to_char (e
, &data
[0], &chk
[0], length
);
580 for (c
= e
->value
.constructor
; c
; c
= c
->next
)
582 size_t elt_size
= gfc_target_expr_size (c
->expr
);
585 len
= elt_size
* (size_t)mpz_get_si (c
->n
.offset
);
587 len
= len
+ gfc_merge_initializers (ts
, c
->expr
, &data
[len
],
588 &chk
[len
], length
- len
);
600 /* Transfer the bitpattern of a (integer) BOZ to real or complex variables.
601 When successful, no BOZ or nothing to do, true is returned. */
604 gfc_convert_boz (gfc_expr
*expr
, gfc_typespec
*ts
)
606 size_t buffer_size
, boz_bit_size
, ts_bit_size
;
608 unsigned char *buffer
;
613 gcc_assert (expr
->expr_type
== EXPR_CONSTANT
614 && expr
->ts
.type
== BT_INTEGER
);
616 /* Don't convert BOZ to logical, character, derived etc. */
617 if (ts
->type
== BT_REAL
)
619 buffer_size
= size_float (ts
->kind
);
620 ts_bit_size
= buffer_size
* 8;
622 else if (ts
->type
== BT_COMPLEX
)
624 buffer_size
= size_complex (ts
->kind
);
625 ts_bit_size
= buffer_size
* 8 / 2;
630 /* Convert BOZ to the smallest possible integer kind. */
631 boz_bit_size
= mpz_sizeinbase (expr
->value
.integer
, 2);
633 if (boz_bit_size
> ts_bit_size
)
635 gfc_error_now ("BOZ constant at %L is too large (%ld vs %ld bits)",
636 &expr
->where
, (long) boz_bit_size
, (long) ts_bit_size
);
640 for (index
= 0; gfc_integer_kinds
[index
].kind
!= 0; ++index
)
642 if ((unsigned) gfc_integer_kinds
[index
].bit_size
>= ts_bit_size
)
646 expr
->ts
.kind
= gfc_integer_kinds
[index
].kind
;
647 buffer_size
= MAX (buffer_size
, size_integer (expr
->ts
.kind
));
649 buffer
= (unsigned char*)alloca (buffer_size
);
650 encode_integer (expr
->ts
.kind
, expr
->value
.integer
, buffer
, buffer_size
);
651 mpz_clear (expr
->value
.integer
);
653 if (ts
->type
== BT_REAL
)
655 mpfr_init (expr
->value
.real
);
656 gfc_interpret_float (ts
->kind
, buffer
, buffer_size
, expr
->value
.real
);
660 mpfr_init (expr
->value
.complex.r
);
661 mpfr_init (expr
->value
.complex.i
);
662 gfc_interpret_complex (ts
->kind
, buffer
, buffer_size
,
663 expr
->value
.complex.r
, expr
->value
.complex.i
);
666 expr
->ts
.type
= ts
->type
;
667 expr
->ts
.kind
= ts
->kind
;