]>
Commit | Line | Data |
---|---|---|
7433458d PT |
1 | /* Simulate storage of variables into target memory. |
2 | Copyright (C) 2007 | |
3 | Free Software Foundation, Inc. | |
4 | Contributed by Paul Thomas and Brooks Moses | |
5 | ||
6 | This file is part of GCC. | |
7 | ||
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 | |
d234d788 | 10 | Software Foundation; either version 3, or (at your option) any later |
7433458d PT |
11 | version. |
12 | ||
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. | |
17 | ||
18 | You should have received a copy of the GNU General Public License | |
d234d788 NC |
19 | along with GCC; see the file COPYING3. If not see |
20 | <http://www.gnu.org/licenses/>. */ | |
7433458d PT |
21 | |
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 "trans.h" | |
30 | #include "trans-const.h" | |
31 | #include "trans-types.h" | |
32 | #include "target-memory.h" | |
33 | ||
34 | /* --------------------------------------------------------------- */ | |
35 | /* Calculate the size of an expression. */ | |
36 | ||
37 | static size_t | |
38 | size_array (gfc_expr *e) | |
39 | { | |
40 | mpz_t array_size; | |
41 | size_t elt_size = gfc_target_expr_size (e->value.constructor->expr); | |
42 | ||
43 | gfc_array_size (e, &array_size); | |
44 | return (size_t)mpz_get_ui (array_size) * elt_size; | |
45 | } | |
46 | ||
47 | static size_t | |
48 | size_integer (int kind) | |
49 | { | |
50 | return GET_MODE_SIZE (TYPE_MODE (gfc_get_int_type (kind)));; | |
51 | } | |
52 | ||
53 | ||
54 | static size_t | |
55 | size_float (int kind) | |
56 | { | |
57 | return GET_MODE_SIZE (TYPE_MODE (gfc_get_real_type (kind)));; | |
58 | } | |
59 | ||
60 | ||
61 | static size_t | |
62 | size_complex (int kind) | |
63 | { | |
64 | return 2 * size_float (kind); | |
65 | } | |
66 | ||
67 | ||
68 | static size_t | |
69 | size_logical (int kind) | |
70 | { | |
71 | return GET_MODE_SIZE (TYPE_MODE (gfc_get_logical_type (kind)));; | |
72 | } | |
73 | ||
74 | ||
75 | static size_t | |
76 | size_character (int length) | |
77 | { | |
78 | return length; | |
79 | } | |
80 | ||
81 | ||
82 | size_t | |
83 | gfc_target_expr_size (gfc_expr *e) | |
84 | { | |
85 | tree type; | |
86 | ||
87 | gcc_assert (e != NULL); | |
88 | ||
89 | if (e->expr_type == EXPR_ARRAY) | |
90 | return size_array (e); | |
91 | ||
92 | switch (e->ts.type) | |
93 | { | |
94 | case BT_INTEGER: | |
95 | return size_integer (e->ts.kind); | |
96 | case BT_REAL: | |
97 | return size_float (e->ts.kind); | |
98 | case BT_COMPLEX: | |
99 | return size_complex (e->ts.kind); | |
100 | case BT_LOGICAL: | |
101 | return size_logical (e->ts.kind); | |
102 | case BT_CHARACTER: | |
103 | return size_character (e->value.character.length); | |
3b45d6c4 BM |
104 | case BT_HOLLERITH: |
105 | return e->representation.length; | |
7433458d PT |
106 | case BT_DERIVED: |
107 | type = gfc_typenode_for_spec (&e->ts); | |
108 | return int_size_in_bytes (type); | |
109 | default: | |
110 | gfc_internal_error ("Invalid expression in gfc_target_expr_size."); | |
111 | return 0; | |
112 | } | |
113 | } | |
114 | ||
115 | ||
116 | /* The encode_* functions export a value into a buffer, and | |
117 | return the number of bytes of the buffer that have been | |
118 | used. */ | |
119 | ||
120 | static int | |
121 | encode_array (gfc_expr *expr, unsigned char *buffer, size_t buffer_size) | |
122 | { | |
123 | mpz_t array_size; | |
124 | int i; | |
125 | int ptr = 0; | |
126 | ||
127 | gfc_array_size (expr, &array_size); | |
128 | for (i = 0; i < (int)mpz_get_ui (array_size); i++) | |
129 | { | |
130 | ptr += gfc_target_encode_expr (gfc_get_array_element (expr, i), | |
131 | &buffer[ptr], buffer_size - ptr); | |
132 | } | |
133 | ||
134 | mpz_clear (array_size); | |
135 | return ptr; | |
136 | } | |
137 | ||
138 | ||
139 | static int | |
140 | encode_integer (int kind, mpz_t integer, unsigned char *buffer, | |
141 | size_t buffer_size) | |
142 | { | |
143 | return native_encode_expr (gfc_conv_mpz_to_tree (integer, kind), | |
144 | buffer, buffer_size); | |
145 | } | |
146 | ||
147 | ||
148 | static int | |
149 | encode_float (int kind, mpfr_t real, unsigned char *buffer, size_t buffer_size) | |
150 | { | |
151 | return native_encode_expr (gfc_conv_mpfr_to_tree (real, kind), buffer, | |
152 | buffer_size); | |
153 | } | |
154 | ||
155 | ||
156 | static int | |
157 | encode_complex (int kind, mpfr_t real, mpfr_t imaginary, unsigned char *buffer, | |
158 | size_t buffer_size) | |
159 | { | |
160 | int size; | |
161 | size = encode_float (kind, real, &buffer[0], buffer_size); | |
162 | size += encode_float (kind, imaginary, &buffer[size], buffer_size - size); | |
163 | return size; | |
164 | } | |
165 | ||
166 | ||
167 | static int | |
168 | encode_logical (int kind, int logical, unsigned char *buffer, size_t buffer_size) | |
169 | { | |
170 | return native_encode_expr (build_int_cst (gfc_get_logical_type (kind), | |
171 | logical), | |
172 | buffer, buffer_size); | |
173 | } | |
174 | ||
175 | ||
176 | static int | |
177 | encode_character (int length, char *string, unsigned char *buffer, | |
178 | size_t buffer_size) | |
179 | { | |
180 | gcc_assert (buffer_size >= size_character (length)); | |
181 | memcpy (buffer, string, length); | |
182 | return length; | |
183 | } | |
184 | ||
185 | ||
186 | static int | |
187 | encode_derived (gfc_expr *source, unsigned char *buffer, size_t buffer_size) | |
188 | { | |
189 | gfc_constructor *ctr; | |
190 | gfc_component *cmp; | |
191 | int ptr; | |
192 | tree type; | |
193 | ||
194 | type = gfc_typenode_for_spec (&source->ts); | |
195 | ||
196 | ctr = source->value.constructor; | |
197 | cmp = source->ts.derived->components; | |
198 | for (;ctr; ctr = ctr->next, cmp = cmp->next) | |
199 | { | |
9d99ee7b PT |
200 | gcc_assert (cmp); |
201 | if (!ctr->expr) | |
202 | continue; | |
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; | |
7433458d PT |
205 | gfc_target_encode_expr (ctr->expr, &buffer[ptr], |
206 | buffer_size - ptr); | |
207 | } | |
208 | ||
209 | return int_size_in_bytes (type); | |
210 | } | |
211 | ||
212 | ||
213 | /* Write a constant expression in binary form to a buffer. */ | |
214 | int | |
215 | gfc_target_encode_expr (gfc_expr *source, unsigned char *buffer, | |
216 | size_t buffer_size) | |
217 | { | |
218 | if (source == NULL) | |
219 | return 0; | |
220 | ||
221 | if (source->expr_type == EXPR_ARRAY) | |
222 | return encode_array (source, buffer, buffer_size); | |
223 | ||
224 | gcc_assert (source->expr_type == EXPR_CONSTANT | |
225 | || source->expr_type == EXPR_STRUCTURE); | |
226 | ||
20585ad6 BM |
227 | /* If we already have a target-memory representation, we use that rather |
228 | than recreating one. */ | |
229 | if (source->representation.string) | |
230 | { | |
231 | memcpy (buffer, source->representation.string, | |
232 | source->representation.length); | |
233 | return source->representation.length; | |
234 | } | |
235 | ||
7433458d PT |
236 | switch (source->ts.type) |
237 | { | |
238 | case BT_INTEGER: | |
239 | return encode_integer (source->ts.kind, source->value.integer, buffer, | |
240 | buffer_size); | |
241 | case BT_REAL: | |
242 | return encode_float (source->ts.kind, source->value.real, buffer, | |
243 | buffer_size); | |
244 | case BT_COMPLEX: | |
245 | return encode_complex (source->ts.kind, source->value.complex.r, | |
246 | source->value.complex.i, buffer, buffer_size); | |
247 | case BT_LOGICAL: | |
248 | return encode_logical (source->ts.kind, source->value.logical, buffer, | |
249 | buffer_size); | |
250 | case BT_CHARACTER: | |
251 | return encode_character (source->value.character.length, | |
252 | source->value.character.string, buffer, | |
253 | buffer_size); | |
254 | case BT_DERIVED: | |
255 | return encode_derived (source, buffer, buffer_size); | |
256 | default: | |
257 | gfc_internal_error ("Invalid expression in gfc_target_encode_expr."); | |
258 | return 0; | |
259 | } | |
260 | } | |
261 | ||
262 | ||
263 | static int | |
264 | interpret_array (unsigned char *buffer, size_t buffer_size, gfc_expr *result) | |
265 | { | |
266 | int array_size = 1; | |
267 | int i; | |
268 | int ptr = 0; | |
269 | gfc_constructor *head = NULL, *tail = NULL; | |
270 | ||
271 | /* Calculate array size from its shape and rank. */ | |
272 | gcc_assert (result->rank > 0 && result->shape); | |
273 | ||
274 | for (i = 0; i < result->rank; i++) | |
275 | array_size *= (int)mpz_get_ui (result->shape[i]); | |
276 | ||
277 | /* Iterate over array elements, producing constructors. */ | |
278 | for (i = 0; i < array_size; i++) | |
279 | { | |
280 | if (head == NULL) | |
281 | head = tail = gfc_get_constructor (); | |
282 | else | |
283 | { | |
284 | tail->next = gfc_get_constructor (); | |
285 | tail = tail->next; | |
286 | } | |
287 | ||
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; | |
292 | ||
293 | if (tail->expr->ts.type == BT_CHARACTER) | |
294 | tail->expr->value.character.length = result->value.character.length; | |
295 | ||
296 | ptr += gfc_target_interpret_expr (&buffer[ptr], buffer_size - ptr, | |
297 | tail->expr); | |
298 | } | |
299 | result->value.constructor = head; | |
300 | ||
301 | return ptr; | |
302 | } | |
303 | ||
304 | ||
20585ad6 BM |
305 | int |
306 | gfc_interpret_integer (int kind, unsigned char *buffer, size_t buffer_size, | |
7433458d PT |
307 | mpz_t integer) |
308 | { | |
309 | mpz_init (integer); | |
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); | |
314 | } | |
315 | ||
316 | ||
20585ad6 BM |
317 | int |
318 | gfc_interpret_float (int kind, unsigned char *buffer, size_t buffer_size, | |
7433458d PT |
319 | mpfr_t real) |
320 | { | |
321 | mpfr_init (real); | |
322 | gfc_conv_tree_to_mpfr (real, | |
323 | native_interpret_expr (gfc_get_real_type (kind), | |
324 | buffer, buffer_size)); | |
325 | ||
326 | return size_float (kind); | |
327 | } | |
328 | ||
329 | ||
20585ad6 BM |
330 | int |
331 | gfc_interpret_complex (int kind, unsigned char *buffer, size_t buffer_size, | |
7433458d PT |
332 | mpfr_t real, mpfr_t imaginary) |
333 | { | |
334 | int size; | |
20585ad6 BM |
335 | size = gfc_interpret_float (kind, &buffer[0], buffer_size, real); |
336 | size += gfc_interpret_float (kind, &buffer[size], buffer_size - size, imaginary); | |
7433458d PT |
337 | return size; |
338 | } | |
339 | ||
340 | ||
20585ad6 BM |
341 | int |
342 | gfc_interpret_logical (int kind, unsigned char *buffer, size_t buffer_size, | |
7433458d PT |
343 | int *logical) |
344 | { | |
345 | tree t = native_interpret_expr (gfc_get_logical_type (kind), buffer, | |
346 | buffer_size); | |
347 | *logical = double_int_zero_p (tree_to_double_int (t)) | |
348 | ? 0 : 1; | |
349 | return size_logical (kind); | |
350 | } | |
351 | ||
352 | ||
20585ad6 BM |
353 | int |
354 | gfc_interpret_character (unsigned char *buffer, size_t buffer_size, gfc_expr *result) | |
7433458d PT |
355 | { |
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); | |
359 | ||
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'; | |
366 | ||
367 | return result->value.character.length; | |
368 | } | |
369 | ||
370 | ||
20585ad6 BM |
371 | int |
372 | gfc_interpret_derived (unsigned char *buffer, size_t buffer_size, gfc_expr *result) | |
7433458d PT |
373 | { |
374 | gfc_component *cmp; | |
375 | gfc_constructor *head = NULL, *tail = NULL; | |
376 | int ptr; | |
377 | tree type; | |
378 | ||
379 | /* The attributes of the derived type need to be bolted to the floor. */ | |
380 | result->expr_type = EXPR_STRUCTURE; | |
381 | ||
382 | type = gfc_typenode_for_spec (&result->ts); | |
383 | cmp = result->ts.derived->components; | |
384 | ||
385 | /* Run through the derived type components. */ | |
386 | for (;cmp; cmp = cmp->next) | |
387 | { | |
388 | if (head == NULL) | |
389 | head = tail = gfc_get_constructor (); | |
390 | else | |
391 | { | |
392 | tail->next = gfc_get_constructor (); | |
393 | tail = tail->next; | |
394 | } | |
395 | ||
396 | /* The constructor points to the component. */ | |
397 | tail->n.component = cmp; | |
398 | ||
399 | tail->expr = gfc_constant_result (cmp->ts.type, cmp->ts.kind, | |
400 | &result->where); | |
401 | tail->expr->ts = cmp->ts; | |
402 | ||
403 | /* Copy shape, if needed. */ | |
404 | if (cmp->as && cmp->as->rank) | |
405 | { | |
406 | int n; | |
407 | ||
408 | tail->expr->expr_type = EXPR_ARRAY; | |
409 | tail->expr->rank = cmp->as->rank; | |
410 | ||
411 | tail->expr->shape = gfc_get_shape (tail->expr->rank); | |
412 | for (n = 0; n < tail->expr->rank; n++) | |
413 | { | |
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); | |
419 | } | |
420 | } | |
421 | ||
422 | ptr = TREE_INT_CST_LOW (DECL_FIELD_OFFSET (cmp->backend_decl)); | |
423 | gfc_target_interpret_expr (&buffer[ptr], buffer_size - ptr, | |
424 | tail->expr); | |
425 | ||
426 | result->value.constructor = head; | |
427 | } | |
428 | ||
429 | return int_size_in_bytes (type); | |
430 | } | |
431 | ||
432 | ||
433 | /* Read a binary buffer to a constant expression. */ | |
434 | int | |
435 | gfc_target_interpret_expr (unsigned char *buffer, size_t buffer_size, | |
436 | gfc_expr *result) | |
437 | { | |
438 | if (result->expr_type == EXPR_ARRAY) | |
439 | return interpret_array (buffer, buffer_size, result); | |
440 | ||
441 | switch (result->ts.type) | |
442 | { | |
443 | case BT_INTEGER: | |
20585ad6 BM |
444 | result->representation.length = |
445 | gfc_interpret_integer (result->ts.kind, buffer, buffer_size, | |
446 | result->value.integer); | |
447 | break; | |
448 | ||
7433458d | 449 | case BT_REAL: |
20585ad6 BM |
450 | result->representation.length = |
451 | gfc_interpret_float (result->ts.kind, buffer, buffer_size, | |
452 | result->value.real); | |
453 | break; | |
454 | ||
7433458d | 455 | case BT_COMPLEX: |
20585ad6 BM |
456 | result->representation.length = |
457 | gfc_interpret_complex (result->ts.kind, buffer, buffer_size, | |
458 | result->value.complex.r, | |
459 | result->value.complex.i); | |
460 | break; | |
461 | ||
7433458d | 462 | case BT_LOGICAL: |
20585ad6 BM |
463 | result->representation.length = |
464 | gfc_interpret_logical (result->ts.kind, buffer, buffer_size, | |
465 | &result->value.logical); | |
466 | break; | |
467 | ||
7433458d | 468 | case BT_CHARACTER: |
20585ad6 BM |
469 | result->representation.length = |
470 | gfc_interpret_character (buffer, buffer_size, result); | |
471 | break; | |
472 | ||
7433458d | 473 | case BT_DERIVED: |
20585ad6 BM |
474 | result->representation.length = |
475 | gfc_interpret_derived (buffer, buffer_size, result); | |
476 | break; | |
477 | ||
7433458d PT |
478 | default: |
479 | gfc_internal_error ("Invalid expression in gfc_target_interpret_expr."); | |
20585ad6 BM |
480 | break; |
481 | } | |
482 | ||
483 | if (result->ts.type == BT_CHARACTER) | |
484 | result->representation.string = result->value.character.string; | |
485 | else | |
486 | { | |
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'; | |
7433458d | 492 | } |
20585ad6 BM |
493 | |
494 | return result->representation.length; | |
7433458d | 495 | } |
9d99ee7b PT |
496 | |
497 | ||
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. */ | |
502 | ||
503 | ||
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 | |
506 | error. */ | |
507 | ||
508 | static size_t | |
509 | expr_to_char (gfc_expr *e, unsigned char *data, unsigned char *chk, size_t len) | |
510 | { | |
511 | int i; | |
512 | int ptr; | |
513 | gfc_constructor *ctr; | |
514 | gfc_component *cmp; | |
515 | unsigned char *buffer; | |
516 | ||
517 | if (e == NULL) | |
518 | return 0; | |
519 | ||
520 | /* Take a derived type, one component at a time, using the offsets from the backend | |
521 | declaration. */ | |
522 | if (e->ts.type == BT_DERIVED) | |
523 | { | |
524 | ctr = e->value.constructor; | |
525 | cmp = e->ts.derived->components; | |
526 | for (;ctr; ctr = ctr->next, cmp = cmp->next) | |
527 | { | |
528 | gcc_assert (cmp && cmp->backend_decl); | |
529 | if (!ctr->expr) | |
530 | continue; | |
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); | |
534 | } | |
535 | return len; | |
536 | } | |
537 | ||
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); | |
543 | ||
544 | for (i = 0; i < (int)len; i++) | |
545 | { | |
546 | if (chk[i] && (buffer[i] != data[i])) | |
547 | { | |
548 | gfc_error ("Overlapping unequal initializers in EQUIVALENCE " | |
549 | "at %L", &e->where); | |
550 | return 0; | |
551 | } | |
552 | chk[i] = 0xFF; | |
553 | } | |
554 | ||
555 | memcpy (data, buffer, len); | |
556 | return len; | |
557 | } | |
558 | ||
559 | ||
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. */ | |
563 | ||
564 | size_t | |
565 | gfc_merge_initializers (gfc_typespec ts, gfc_expr *e, unsigned char *data, | |
566 | unsigned char *chk, size_t length) | |
567 | { | |
568 | size_t len = 0; | |
569 | gfc_constructor * c; | |
570 | ||
571 | switch (e->expr_type) | |
572 | { | |
573 | case EXPR_CONSTANT: | |
574 | case EXPR_STRUCTURE: | |
575 | len = expr_to_char (e, &data[0], &chk[0], length); | |
576 | ||
577 | break; | |
578 | ||
579 | case EXPR_ARRAY: | |
580 | for (c = e->value.constructor; c; c = c->next) | |
581 | { | |
582 | size_t elt_size = gfc_target_expr_size (c->expr); | |
583 | ||
584 | if (c->n.offset) | |
585 | len = elt_size * (size_t)mpz_get_si (c->n.offset); | |
586 | ||
587 | len = len + gfc_merge_initializers (ts, c->expr, &data[len], | |
588 | &chk[len], length - len); | |
589 | } | |
590 | break; | |
591 | ||
592 | default: | |
593 | return 0; | |
594 | } | |
595 | ||
596 | return len; | |
597 | } |