OSDN Git Service

2010-11-24 Tobias Burnus <burnus@net-b.de>
[pf3gnuchains/gcc-fork.git] / gcc / fortran / target-memory.c
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
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
10 Software Foundation; either version 3, or (at your option) any later
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
19 along with GCC; see the file COPYING3.  If not see
20 <http://www.gnu.org/licenses/>.  */
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 "constructor.h"
30 #include "trans.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 static size_t
39 size_array (gfc_expr *e)
40 {
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);
44
45   gfc_array_size (e, &array_size);
46   return (size_t)mpz_get_ui (array_size) * elt_size;
47 }
48
49 static size_t
50 size_integer (int kind)
51 {
52   return GET_MODE_SIZE (TYPE_MODE (gfc_get_int_type (kind)));;
53 }
54
55
56 static size_t
57 size_float (int kind)
58 {
59   return GET_MODE_SIZE (TYPE_MODE (gfc_get_real_type (kind)));;
60 }
61
62
63 static size_t
64 size_complex (int kind)
65 {
66   return 2 * size_float (kind);
67 }
68
69
70 static size_t
71 size_logical (int kind)
72 {
73   return GET_MODE_SIZE (TYPE_MODE (gfc_get_logical_type (kind)));;
74 }
75
76
77 static size_t
78 size_character (int length, int kind)
79 {
80   int i = gfc_validate_kind (BT_CHARACTER, kind, false);
81   return length * gfc_character_kinds[i].bit_size / 8;
82 }
83
84
85 size_t
86 gfc_target_expr_size (gfc_expr *e)
87 {
88   tree type;
89
90   gcc_assert (e != NULL);
91
92   if (e->expr_type == EXPR_ARRAY)
93     return size_array (e);
94
95   switch (e->ts.type)
96     {
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)
107         {
108           int start, end;
109
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);
113         }
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;
124     }
125 }
126
127
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.  */
131
132 static int
133 encode_array (gfc_expr *expr, unsigned char *buffer, size_t buffer_size)
134 {
135   mpz_t array_size;
136   int i;
137   int ptr = 0;
138
139   gfc_constructor_base ctor = expr->value.constructor;
140
141   gfc_array_size (expr, &array_size);
142   for (i = 0; i < (int)mpz_get_ui (array_size); i++)
143     {
144       ptr += gfc_target_encode_expr (gfc_constructor_lookup_expr (ctor, i),
145                                      &buffer[ptr], buffer_size - ptr);
146     }
147
148   mpz_clear (array_size);
149   return ptr;
150 }
151
152
153 static int
154 encode_integer (int kind, mpz_t integer, unsigned char *buffer,
155                 size_t buffer_size)
156 {
157   return native_encode_expr (gfc_conv_mpz_to_tree (integer, kind),
158                              buffer, buffer_size);
159 }
160
161
162 static int
163 encode_float (int kind, mpfr_t real, unsigned char *buffer, size_t buffer_size)
164 {
165   return native_encode_expr (gfc_conv_mpfr_to_tree (real, kind, 0), buffer,
166                              buffer_size);
167 }
168
169
170 static int
171 encode_complex (int kind, mpc_t cmplx,
172                 unsigned char *buffer, size_t buffer_size)
173 {
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;
179 }
180
181
182 static int
183 encode_logical (int kind, int logical, unsigned char *buffer, size_t buffer_size)
184 {
185   return native_encode_expr (build_int_cst (gfc_get_logical_type (kind),
186                                             logical),
187                              buffer, buffer_size);
188 }
189
190
191 int
192 gfc_encode_character (int kind, int length, const gfc_char_t *string,
193                       unsigned char *buffer, size_t buffer_size)
194 {
195   size_t elsize = size_character (1, kind);
196   tree type = gfc_get_char_type (kind);
197   int i;
198
199   gcc_assert (buffer_size >= size_character (length, kind));
200
201   for (i = 0; i < length; i++)
202     native_encode_expr (build_int_cst (type, string[i]), &buffer[i*elsize],
203                         elsize);
204
205   return length;
206 }
207
208
209 static int
210 encode_derived (gfc_expr *source, unsigned char *buffer, size_t buffer_size)
211 {
212   gfc_constructor *c;
213   gfc_component *cmp;
214   int ptr;
215   tree type;
216
217   type = gfc_typenode_for_spec (&source->ts);
218
219   for (c = gfc_constructor_first (source->value.constructor),
220        cmp = source->ts.u.derived->components;
221        c;
222        c = gfc_constructor_next (c), cmp = cmp->next)
223     {
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;
229
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);
236     }
237
238   return int_size_in_bytes (type);
239 }
240
241
242 /* Write a constant expression in binary form to a buffer.  */
243 int
244 gfc_target_encode_expr (gfc_expr *source, unsigned char *buffer,
245                         size_t buffer_size)
246 {
247   if (source == NULL)
248     return 0;
249
250   if (source->expr_type == EXPR_ARRAY)
251     return encode_array (source, buffer, buffer_size);
252
253   gcc_assert (source->expr_type == EXPR_CONSTANT
254               || source->expr_type == EXPR_STRUCTURE
255               || source->expr_type == EXPR_SUBSTRING);
256
257   /* If we already have a target-memory representation, we use that rather 
258      than recreating one.  */
259   if (source->representation.string)
260     {
261       memcpy (buffer, source->representation.string,
262               source->representation.length);
263       return source->representation.length;
264     }
265
266   switch (source->ts.type)
267     {
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
287         {
288           int start, end;
289
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);
296         }
297
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;
303     }
304 }
305
306
307 static int
308 interpret_array (unsigned char *buffer, size_t buffer_size, gfc_expr *result)
309 {
310   gfc_constructor_base base = NULL;
311   int array_size = 1;
312   int i;
313   int ptr = 0;
314
315   /* Calculate array size from its shape and rank.  */
316   gcc_assert (result->rank > 0 && result->shape);
317
318   for (i = 0; i < result->rank; i++)
319     array_size *= (int)mpz_get_ui (result->shape[i]);
320
321   /* Iterate over array elements, producing constructors.  */
322   for (i = 0; i < array_size; i++)
323     {
324       gfc_expr *e = gfc_get_constant_expr (result->ts.type, result->ts.kind,
325                                            &result->where);
326       e->ts = result->ts;
327
328       if (e->ts.type == BT_CHARACTER)
329         e->value.character.length = result->value.character.length;
330
331       gfc_constructor_append_expr (&base, e, &result->where);
332
333       ptr += gfc_target_interpret_expr (&buffer[ptr], buffer_size - ptr, e);
334     }
335
336   result->value.constructor = base;
337   return ptr;
338 }
339
340
341 int
342 gfc_interpret_integer (int kind, unsigned char *buffer, size_t buffer_size,
343                    mpz_t integer)
344 {
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);
350 }
351
352
353 int
354 gfc_interpret_float (int kind, unsigned char *buffer, size_t buffer_size,
355                      mpfr_t real)
356 {
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));
362
363   return size_float (kind);
364 }
365
366
367 int
368 gfc_interpret_complex (int kind, unsigned char *buffer, size_t buffer_size,
369                        mpc_t complex)
370 {
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;
377 }
378
379
380 int
381 gfc_interpret_logical (int kind, unsigned char *buffer, size_t buffer_size,
382                    int *logical)
383 {
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);
389 }
390
391
392 int
393 gfc_interpret_character (unsigned char *buffer, size_t buffer_size,
394                          gfc_expr *result)
395 {
396   int i;
397
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);
401
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);
406
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
411     {
412       mpz_t integer;
413       unsigned bytes = size_character (1, result->ts.kind);
414       mpz_init (integer);
415       gcc_assert (bytes <= sizeof (unsigned long));
416
417       for (i = 0; i < result->value.character.length; i++)
418         {
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);
424         }
425
426       mpz_clear (integer);
427     }
428
429   result->value.character.string[result->value.character.length] = '\0';
430
431   return result->value.character.length;
432 }
433
434
435 int
436 gfc_interpret_derived (unsigned char *buffer, size_t buffer_size, gfc_expr *result)
437 {
438   gfc_component *cmp;
439   int ptr;
440   tree type;
441
442   /* The attributes of the derived type need to be bolted to the floor.  */
443   result->expr_type = EXPR_STRUCTURE;
444
445   type = gfc_typenode_for_spec (&result->ts);
446   cmp = result->ts.u.derived->components;
447
448   /* Run through the derived type components.  */
449   for (;cmp; cmp = cmp->next)
450     {
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;
455
456       /* Copy shape, if needed.  */
457       if (cmp->as && cmp->as->rank)
458         {
459           int n;
460
461           e->expr_type = EXPR_ARRAY;
462           e->rank = cmp->as->rank;
463
464           e->shape = gfc_get_shape (e->rank);
465           for (n = 0; n < e->rank; n++)
466              {
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);
472              }
473         }
474
475       c = gfc_constructor_append_expr (&result->value.constructor, e, NULL);
476
477       /* The constructor points to the component.  */
478       c->n.component = cmp;
479
480       /* Calculate the offset, which consists of the the FIELD_OFFSET in
481          bytes, which appears in multiples of DECL_OFFSET_ALIGN-bit-sized,
482          and additional bits of FIELD_BIT_OFFSET. The code assumes that all
483          sizes of the components are multiples of BITS_PER_UNIT,
484          i.e. there are, e.g., no bit fields.  */
485
486       ptr = TREE_INT_CST_LOW (DECL_FIELD_BIT_OFFSET (cmp->backend_decl));
487       gcc_assert (ptr % 8 == 0);
488       ptr = ptr/8 + TREE_INT_CST_LOW (DECL_FIELD_OFFSET (cmp->backend_decl));
489
490       gfc_target_interpret_expr (&buffer[ptr], buffer_size - ptr, e);
491     }
492     
493   return int_size_in_bytes (type);
494 }
495
496
497 /* Read a binary buffer to a constant expression.  */
498 int
499 gfc_target_interpret_expr (unsigned char *buffer, size_t buffer_size,
500                            gfc_expr *result)
501 {
502   if (result->expr_type == EXPR_ARRAY)
503     return interpret_array (buffer, buffer_size, result);
504
505   switch (result->ts.type)
506     {
507     case BT_INTEGER:
508       result->representation.length = 
509         gfc_interpret_integer (result->ts.kind, buffer, buffer_size,
510                                result->value.integer);
511       break;
512
513     case BT_REAL:
514       result->representation.length = 
515         gfc_interpret_float (result->ts.kind, buffer, buffer_size,
516                              result->value.real);
517       break;
518
519     case BT_COMPLEX:
520       result->representation.length = 
521         gfc_interpret_complex (result->ts.kind, buffer, buffer_size,
522                                result->value.complex);
523       break;
524
525     case BT_LOGICAL:
526       result->representation.length = 
527         gfc_interpret_logical (result->ts.kind, buffer, buffer_size,
528                                &result->value.logical);
529       break;
530
531     case BT_CHARACTER:
532       result->representation.length = 
533         gfc_interpret_character (buffer, buffer_size, result);
534       break;
535
536     case BT_DERIVED:
537       result->representation.length = 
538         gfc_interpret_derived (buffer, buffer_size, result);
539       break;
540
541     default:
542       gfc_internal_error ("Invalid expression in gfc_target_interpret_expr.");
543       break;
544     }
545
546   if (result->ts.type == BT_CHARACTER)
547     result->representation.string
548       = gfc_widechar_to_char (result->value.character.string,
549                               result->value.character.length);
550   else
551     {
552       result->representation.string =
553         (char *) gfc_getmem (result->representation.length + 1);
554       memcpy (result->representation.string, buffer,
555               result->representation.length);
556       result->representation.string[result->representation.length] = '\0';
557     }
558
559   return result->representation.length;
560 }
561
562
563 /* --------------------------------------------------------------- */ 
564 /* Two functions used by trans-common.c to write overlapping
565    equivalence initializers to a buffer.  This is added to the union
566    and the original initializers freed.  */
567
568
569 /* Writes the values of a constant expression to a char buffer. If another
570    unequal initializer has already been written to the buffer, this is an
571    error.  */
572
573 static size_t
574 expr_to_char (gfc_expr *e, unsigned char *data, unsigned char *chk, size_t len)
575 {
576   int i;
577   int ptr;
578   gfc_constructor *c;
579   gfc_component *cmp;
580   unsigned char *buffer;
581
582   if (e == NULL)
583     return 0;
584
585   /* Take a derived type, one component at a time, using the offsets from the backend
586      declaration.  */
587   if (e->ts.type == BT_DERIVED)
588     {
589       for (c = gfc_constructor_first (e->value.constructor),
590            cmp = e->ts.u.derived->components;
591            c; c = gfc_constructor_next (c), cmp = cmp->next)
592         {
593           gcc_assert (cmp && cmp->backend_decl);
594           if (!c->expr)
595             continue;
596             ptr = TREE_INT_CST_LOW(DECL_FIELD_OFFSET(cmp->backend_decl))
597                         + TREE_INT_CST_LOW(DECL_FIELD_BIT_OFFSET(cmp->backend_decl))/8;
598           expr_to_char (c->expr, &data[ptr], &chk[ptr], len);
599         }
600       return len;
601     }
602
603   /* Otherwise, use the target-memory machinery to write a bitwise image, appropriate
604      to the target, in a buffer and check off the initialized part of the buffer.  */
605   len = gfc_target_expr_size (e);
606   buffer = (unsigned char*)alloca (len);
607   len = gfc_target_encode_expr (e, buffer, len);
608
609     for (i = 0; i < (int)len; i++)
610     {
611       if (chk[i] && (buffer[i] != data[i]))
612         {
613           gfc_error ("Overlapping unequal initializers in EQUIVALENCE "
614                      "at %L", &e->where);
615           return 0;
616         }
617       chk[i] = 0xFF;
618     }
619
620   memcpy (data, buffer, len);
621   return len;
622 }
623
624
625 /* Writes the values from the equivalence initializers to a char* array
626    that will be written to the constructor to make the initializer for
627    the union declaration.  */
628
629 size_t
630 gfc_merge_initializers (gfc_typespec ts, gfc_expr *e, unsigned char *data,
631                         unsigned char *chk, size_t length)
632 {
633   size_t len = 0;
634   gfc_constructor * c;
635
636   switch (e->expr_type)
637     {
638     case EXPR_CONSTANT:
639     case EXPR_STRUCTURE:
640       len = expr_to_char (e, &data[0], &chk[0], length);
641
642       break;
643
644     case EXPR_ARRAY:
645       for (c = gfc_constructor_first (e->value.constructor);
646            c; c = gfc_constructor_next (c))
647         {
648           size_t elt_size = gfc_target_expr_size (c->expr);
649
650           if (c->offset)
651             len = elt_size * (size_t)mpz_get_si (c->offset);
652
653           len = len + gfc_merge_initializers (ts, c->expr, &data[len],
654                                               &chk[len], length - len);
655         }
656       break;
657
658     default:
659       return 0;
660     }
661
662   return len;
663 }
664
665
666 /* Transfer the bitpattern of a (integer) BOZ to real or complex variables.
667    When successful, no BOZ or nothing to do, true is returned.  */
668
669 bool
670 gfc_convert_boz (gfc_expr *expr, gfc_typespec *ts)
671 {
672   size_t buffer_size, boz_bit_size, ts_bit_size;
673   int index;
674   unsigned char *buffer;
675
676   if (!expr->is_boz)
677     return true;
678
679   gcc_assert (expr->expr_type == EXPR_CONSTANT
680               && expr->ts.type == BT_INTEGER);
681
682   /* Don't convert BOZ to logical, character, derived etc.  */
683   if (ts->type == BT_REAL)
684     {
685       buffer_size = size_float (ts->kind);
686       ts_bit_size = buffer_size * 8;
687     }
688   else if (ts->type == BT_COMPLEX)
689     {
690       buffer_size = size_complex (ts->kind);
691       ts_bit_size = buffer_size * 8 / 2;
692     }
693   else
694     return true;
695
696   /* Convert BOZ to the smallest possible integer kind.  */
697   boz_bit_size = mpz_sizeinbase (expr->value.integer, 2);
698
699   if (boz_bit_size > ts_bit_size)
700     {
701       gfc_error_now ("BOZ constant at %L is too large (%ld vs %ld bits)",
702                      &expr->where, (long) boz_bit_size, (long) ts_bit_size);
703       return false;
704     }
705
706   for (index = 0; gfc_integer_kinds[index].kind != 0; ++index)
707     if ((unsigned) gfc_integer_kinds[index].bit_size >= ts_bit_size)
708       break;
709
710   expr->ts.kind = gfc_integer_kinds[index].kind;
711   buffer_size = MAX (buffer_size, size_integer (expr->ts.kind));
712
713   buffer = (unsigned char*)alloca (buffer_size);
714   encode_integer (expr->ts.kind, expr->value.integer, buffer, buffer_size);
715   mpz_clear (expr->value.integer);
716
717   if (ts->type == BT_REAL)
718     {
719       mpfr_init (expr->value.real);
720       gfc_interpret_float (ts->kind, buffer, buffer_size, expr->value.real);
721     }
722   else
723     {
724       mpc_init2 (expr->value.complex, mpfr_get_default_prec());
725       gfc_interpret_complex (ts->kind, buffer, buffer_size,
726                              expr->value.complex);
727     }
728   expr->is_boz = 0;  
729   expr->ts.type = ts->type;
730   expr->ts.kind = ts->kind;
731
732   return true;
733 }