OpenCores
URL https://opencores.org/ocsvn/openrisc/openrisc/trunk

Subversion Repositories openrisc

[/] [openrisc/] [trunk/] [gnu-dev/] [or1k-gcc/] [gcc/] [fortran/] [target-memory.c] - Blame information for rev 858

Go to most recent revision | Details | Compare with Previous | View Log

Line No. Rev Author Line
1 712 jeremybenn
/* 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_CONSTANT)
107
        return size_character (e->value.character.length, e->ts.kind);
108
      else if (e->ts.u.cl != NULL && e->ts.u.cl->length != NULL
109
               && e->ts.u.cl->length->expr_type == EXPR_CONSTANT
110
               && e->ts.u.cl->length->ts.type == BT_INTEGER)
111
        {
112
          int length;
113
 
114
          gfc_extract_int (e->ts.u.cl->length, &length);
115
          return size_character (length, e->ts.kind);
116
        }
117
      else
118
        return 0;
119
 
120
    case BT_HOLLERITH:
121
      return e->representation.length;
122
    case BT_DERIVED:
123
      {
124
        /* Determine type size without clobbering the typespec for ISO C
125
           binding types.  */
126
        gfc_typespec ts;
127
        ts = e->ts;
128
        type = gfc_typenode_for_spec (&ts);
129
        return int_size_in_bytes (type);
130
      }
131
    default:
132
      gfc_internal_error ("Invalid expression in gfc_target_expr_size.");
133
      return 0;
134
    }
135
}
136
 
137
 
138
/* The encode_* functions export a value into a buffer, and
139
   return the number of bytes of the buffer that have been
140
   used.  */
141
 
142
static int
143
encode_array (gfc_expr *expr, unsigned char *buffer, size_t buffer_size)
144
{
145
  mpz_t array_size;
146
  int i;
147
  int ptr = 0;
148
 
149
  gfc_constructor_base ctor = expr->value.constructor;
150
 
151
  gfc_array_size (expr, &array_size);
152
  for (i = 0; i < (int)mpz_get_ui (array_size); i++)
153
    {
154
      ptr += gfc_target_encode_expr (gfc_constructor_lookup_expr (ctor, i),
155
                                     &buffer[ptr], buffer_size - ptr);
156
    }
157
 
158
  mpz_clear (array_size);
159
  return ptr;
160
}
161
 
162
 
163
static int
164
encode_integer (int kind, mpz_t integer, unsigned char *buffer,
165
                size_t buffer_size)
166
{
167
  return native_encode_expr (gfc_conv_mpz_to_tree (integer, kind),
168
                             buffer, buffer_size);
169
}
170
 
171
 
172
static int
173
encode_float (int kind, mpfr_t real, unsigned char *buffer, size_t buffer_size)
174
{
175
  return native_encode_expr (gfc_conv_mpfr_to_tree (real, kind, 0), buffer,
176
                             buffer_size);
177
}
178
 
179
 
180
static int
181
encode_complex (int kind, mpc_t cmplx,
182
                unsigned char *buffer, size_t buffer_size)
183
{
184
  int size;
185
  size = encode_float (kind, mpc_realref (cmplx), &buffer[0], buffer_size);
186
  size += encode_float (kind, mpc_imagref (cmplx),
187
                        &buffer[size], buffer_size - size);
188
  return size;
189
}
190
 
191
 
192
static int
193
encode_logical (int kind, int logical, unsigned char *buffer, size_t buffer_size)
194
{
195
  return native_encode_expr (build_int_cst (gfc_get_logical_type (kind),
196
                                            logical),
197
                             buffer, buffer_size);
198
}
199
 
200
 
201
int
202
gfc_encode_character (int kind, int length, const gfc_char_t *string,
203
                      unsigned char *buffer, size_t buffer_size)
204
{
205
  size_t elsize = size_character (1, kind);
206
  tree type = gfc_get_char_type (kind);
207
  int i;
208
 
209
  gcc_assert (buffer_size >= size_character (length, kind));
210
 
211
  for (i = 0; i < length; i++)
212
    native_encode_expr (build_int_cst (type, string[i]), &buffer[i*elsize],
213
                        elsize);
214
 
215
  return length;
216
}
217
 
218
 
219
static int
220
encode_derived (gfc_expr *source, unsigned char *buffer, size_t buffer_size)
221
{
222
  gfc_constructor *c;
223
  gfc_component *cmp;
224
  int ptr;
225
  tree type;
226
 
227
  type = gfc_typenode_for_spec (&source->ts);
228
 
229
  for (c = gfc_constructor_first (source->value.constructor),
230
       cmp = source->ts.u.derived->components;
231
       c;
232
       c = gfc_constructor_next (c), cmp = cmp->next)
233
    {
234
      gcc_assert (cmp);
235
      if (!c->expr)
236
        continue;
237
      ptr = TREE_INT_CST_LOW(DECL_FIELD_OFFSET(cmp->backend_decl))
238
            + TREE_INT_CST_LOW(DECL_FIELD_BIT_OFFSET(cmp->backend_decl))/8;
239
 
240
      if (c->expr->expr_type == EXPR_NULL)
241
        memset (&buffer[ptr], 0,
242
                int_size_in_bytes (TREE_TYPE (cmp->backend_decl)));
243
      else
244
        gfc_target_encode_expr (c->expr, &buffer[ptr],
245
                                buffer_size - ptr);
246
    }
247
 
248
  return int_size_in_bytes (type);
249
}
250
 
251
 
252
/* Write a constant expression in binary form to a buffer.  */
253
int
254
gfc_target_encode_expr (gfc_expr *source, unsigned char *buffer,
255
                        size_t buffer_size)
256
{
257
  if (source == NULL)
258
    return 0;
259
 
260
  if (source->expr_type == EXPR_ARRAY)
261
    return encode_array (source, buffer, buffer_size);
262
 
263
  gcc_assert (source->expr_type == EXPR_CONSTANT
264
              || source->expr_type == EXPR_STRUCTURE
265
              || source->expr_type == EXPR_SUBSTRING);
266
 
267
  /* If we already have a target-memory representation, we use that rather
268
     than recreating one.  */
269
  if (source->representation.string)
270
    {
271
      memcpy (buffer, source->representation.string,
272
              source->representation.length);
273
      return source->representation.length;
274
    }
275
 
276
  switch (source->ts.type)
277
    {
278
    case BT_INTEGER:
279
      return encode_integer (source->ts.kind, source->value.integer, buffer,
280
                             buffer_size);
281
    case BT_REAL:
282
      return encode_float (source->ts.kind, source->value.real, buffer,
283
                           buffer_size);
284
    case BT_COMPLEX:
285
      return encode_complex (source->ts.kind, source->value.complex,
286
                             buffer, buffer_size);
287
    case BT_LOGICAL:
288
      return encode_logical (source->ts.kind, source->value.logical, buffer,
289
                             buffer_size);
290
    case BT_CHARACTER:
291
      if (source->expr_type == EXPR_CONSTANT || source->ref == NULL)
292
        return gfc_encode_character (source->ts.kind,
293
                                     source->value.character.length,
294
                                     source->value.character.string,
295
                                     buffer, buffer_size);
296
      else
297
        {
298
          int start, end;
299
 
300
          gcc_assert (source->expr_type == EXPR_SUBSTRING);
301
          gfc_extract_int (source->ref->u.ss.start, &start);
302
          gfc_extract_int (source->ref->u.ss.end, &end);
303
          return gfc_encode_character (source->ts.kind, MAX(end - start + 1, 0),
304
                                       &source->value.character.string[start-1],
305
                                       buffer, buffer_size);
306
        }
307
 
308
    case BT_DERIVED:
309
      return encode_derived (source, buffer, buffer_size);
310
    default:
311
      gfc_internal_error ("Invalid expression in gfc_target_encode_expr.");
312
      return 0;
313
    }
314
}
315
 
316
 
317
static int
318
interpret_array (unsigned char *buffer, size_t buffer_size, gfc_expr *result)
319
{
320
  gfc_constructor_base base = NULL;
321
  int array_size = 1;
322
  int i;
323
  int ptr = 0;
324
 
325
  /* Calculate array size from its shape and rank.  */
326
  gcc_assert (result->rank > 0 && result->shape);
327
 
328
  for (i = 0; i < result->rank; i++)
329
    array_size *= (int)mpz_get_ui (result->shape[i]);
330
 
331
  /* Iterate over array elements, producing constructors.  */
332
  for (i = 0; i < array_size; i++)
333
    {
334
      gfc_expr *e = gfc_get_constant_expr (result->ts.type, result->ts.kind,
335
                                           &result->where);
336
      e->ts = result->ts;
337
 
338
      if (e->ts.type == BT_CHARACTER)
339
        e->value.character.length = result->value.character.length;
340
 
341
      gfc_constructor_append_expr (&base, e, &result->where);
342
 
343
      ptr += gfc_target_interpret_expr (&buffer[ptr], buffer_size - ptr, e,
344
                                        true);
345
    }
346
 
347
  result->value.constructor = base;
348
  return ptr;
349
}
350
 
351
 
352
int
353
gfc_interpret_integer (int kind, unsigned char *buffer, size_t buffer_size,
354
                   mpz_t integer)
355
{
356
  mpz_init (integer);
357
  gfc_conv_tree_to_mpz (integer,
358
                        native_interpret_expr (gfc_get_int_type (kind),
359
                                               buffer, buffer_size));
360
  return size_integer (kind);
361
}
362
 
363
 
364
int
365
gfc_interpret_float (int kind, unsigned char *buffer, size_t buffer_size,
366
                     mpfr_t real)
367
{
368
  gfc_set_model_kind (kind);
369
  mpfr_init (real);
370
  gfc_conv_tree_to_mpfr (real,
371
                         native_interpret_expr (gfc_get_real_type (kind),
372
                                                buffer, buffer_size));
373
 
374
  return size_float (kind);
375
}
376
 
377
 
378
int
379
gfc_interpret_complex (int kind, unsigned char *buffer, size_t buffer_size,
380
                       mpc_t complex)
381
{
382
  int size;
383
  size = gfc_interpret_float (kind, &buffer[0], buffer_size,
384
                              mpc_realref (complex));
385
  size += gfc_interpret_float (kind, &buffer[size], buffer_size - size,
386
                               mpc_imagref (complex));
387
  return size;
388
}
389
 
390
 
391
int
392
gfc_interpret_logical (int kind, unsigned char *buffer, size_t buffer_size,
393
                   int *logical)
394
{
395
  tree t = native_interpret_expr (gfc_get_logical_type (kind), buffer,
396
                                  buffer_size);
397
  *logical = double_int_zero_p (tree_to_double_int (t))
398
             ? 0 : 1;
399
  return size_logical (kind);
400
}
401
 
402
 
403
int
404
gfc_interpret_character (unsigned char *buffer, size_t buffer_size,
405
                         gfc_expr *result)
406
{
407
  int i;
408
 
409
  if (result->ts.u.cl && result->ts.u.cl->length)
410
    result->value.character.length =
411
      (int) mpz_get_ui (result->ts.u.cl->length->value.integer);
412
 
413
  gcc_assert (buffer_size >= size_character (result->value.character.length,
414
                                             result->ts.kind));
415
  result->value.character.string =
416
    gfc_get_wide_string (result->value.character.length + 1);
417
 
418
  if (result->ts.kind == gfc_default_character_kind)
419
    for (i = 0; i < result->value.character.length; i++)
420
      result->value.character.string[i] = (gfc_char_t) buffer[i];
421
  else
422
    {
423
      mpz_t integer;
424
      unsigned bytes = size_character (1, result->ts.kind);
425
      mpz_init (integer);
426
      gcc_assert (bytes <= sizeof (unsigned long));
427
 
428
      for (i = 0; i < result->value.character.length; i++)
429
        {
430
          gfc_conv_tree_to_mpz (integer,
431
            native_interpret_expr (gfc_get_char_type (result->ts.kind),
432
                                   &buffer[bytes*i], buffer_size-bytes*i));
433
          result->value.character.string[i]
434
            = (gfc_char_t) mpz_get_ui (integer);
435
        }
436
 
437
      mpz_clear (integer);
438
    }
439
 
440
  result->value.character.string[result->value.character.length] = '\0';
441
 
442
  return result->value.character.length;
443
}
444
 
445
 
446
int
447
gfc_interpret_derived (unsigned char *buffer, size_t buffer_size, gfc_expr *result)
448
{
449
  gfc_component *cmp;
450
  int ptr;
451
  tree type;
452
 
453
  /* The attributes of the derived type need to be bolted to the floor.  */
454
  result->expr_type = EXPR_STRUCTURE;
455
 
456
  cmp = result->ts.u.derived->components;
457
 
458
  if (result->ts.u.derived->from_intmod == INTMOD_ISO_C_BINDING
459
      && (result->ts.u.derived->intmod_sym_id == ISOCBINDING_PTR
460
          || result->ts.u.derived->intmod_sym_id == ISOCBINDING_FUNPTR))
461
    {
462
      gfc_constructor *c;
463
      gfc_expr *e;
464
      /* Needed as gfc_typenode_for_spec as gfc_typenode_for_spec
465
         sets this to BT_INTEGER.  */
466
      result->ts.type = BT_DERIVED;
467
      e = gfc_get_constant_expr (cmp->ts.type, cmp->ts.kind, &result->where);
468
      c = gfc_constructor_append_expr (&result->value.constructor, e, NULL);
469
      c->n.component = cmp;
470
      gfc_target_interpret_expr (buffer, buffer_size, e, true);
471
      e->ts.is_iso_c = 1;
472
      return int_size_in_bytes (ptr_type_node);
473
    }
474
 
475
  type = gfc_typenode_for_spec (&result->ts);
476
 
477
  /* Run through the derived type components.  */
478
  for (;cmp; cmp = cmp->next)
479
    {
480
      gfc_constructor *c;
481
      gfc_expr *e = gfc_get_constant_expr (cmp->ts.type, cmp->ts.kind,
482
                                           &result->where);
483
      e->ts = cmp->ts;
484
 
485
      /* Copy shape, if needed.  */
486
      if (cmp->as && cmp->as->rank)
487
        {
488
          int n;
489
 
490
          e->expr_type = EXPR_ARRAY;
491
          e->rank = cmp->as->rank;
492
 
493
          e->shape = gfc_get_shape (e->rank);
494
          for (n = 0; n < e->rank; n++)
495
             {
496
               mpz_init_set_ui (e->shape[n], 1);
497
               mpz_add (e->shape[n], e->shape[n],
498
                        cmp->as->upper[n]->value.integer);
499
               mpz_sub (e->shape[n], e->shape[n],
500
                        cmp->as->lower[n]->value.integer);
501
             }
502
        }
503
 
504
      c = gfc_constructor_append_expr (&result->value.constructor, e, NULL);
505
 
506
      /* The constructor points to the component.  */
507
      c->n.component = cmp;
508
 
509
      /* Calculate the offset, which consists of the FIELD_OFFSET in
510
         bytes, which appears in multiples of DECL_OFFSET_ALIGN-bit-sized,
511
         and additional bits of FIELD_BIT_OFFSET. The code assumes that all
512
         sizes of the components are multiples of BITS_PER_UNIT,
513
         i.e. there are, e.g., no bit fields.  */
514
 
515
      gcc_assert (cmp->backend_decl);
516
      ptr = TREE_INT_CST_LOW (DECL_FIELD_BIT_OFFSET (cmp->backend_decl));
517
      gcc_assert (ptr % 8 == 0);
518
      ptr = ptr/8 + TREE_INT_CST_LOW (DECL_FIELD_OFFSET (cmp->backend_decl));
519
 
520
      gfc_target_interpret_expr (&buffer[ptr], buffer_size - ptr, e, true);
521
    }
522
 
523
  return int_size_in_bytes (type);
524
}
525
 
526
 
527
/* Read a binary buffer to a constant expression.  */
528
int
529
gfc_target_interpret_expr (unsigned char *buffer, size_t buffer_size,
530
                           gfc_expr *result, bool convert_widechar)
531
{
532
  if (result->expr_type == EXPR_ARRAY)
533
    return interpret_array (buffer, buffer_size, result);
534
 
535
  switch (result->ts.type)
536
    {
537
    case BT_INTEGER:
538
      result->representation.length =
539
        gfc_interpret_integer (result->ts.kind, buffer, buffer_size,
540
                               result->value.integer);
541
      break;
542
 
543
    case BT_REAL:
544
      result->representation.length =
545
        gfc_interpret_float (result->ts.kind, buffer, buffer_size,
546
                             result->value.real);
547
      break;
548
 
549
    case BT_COMPLEX:
550
      result->representation.length =
551
        gfc_interpret_complex (result->ts.kind, buffer, buffer_size,
552
                               result->value.complex);
553
      break;
554
 
555
    case BT_LOGICAL:
556
      result->representation.length =
557
        gfc_interpret_logical (result->ts.kind, buffer, buffer_size,
558
                               &result->value.logical);
559
      break;
560
 
561
    case BT_CHARACTER:
562
      result->representation.length =
563
        gfc_interpret_character (buffer, buffer_size, result);
564
      break;
565
 
566
    case BT_DERIVED:
567
      result->representation.length =
568
        gfc_interpret_derived (buffer, buffer_size, result);
569
      break;
570
 
571
    default:
572
      gfc_internal_error ("Invalid expression in gfc_target_interpret_expr.");
573
      break;
574
    }
575
 
576
  if (result->ts.type == BT_CHARACTER && convert_widechar)
577
    result->representation.string
578
      = gfc_widechar_to_char (result->value.character.string,
579
                              result->value.character.length);
580
  else
581
    {
582
      result->representation.string =
583
        XCNEWVEC (char, result->representation.length + 1);
584
      memcpy (result->representation.string, buffer,
585
              result->representation.length);
586
      result->representation.string[result->representation.length] = '\0';
587
    }
588
 
589
  return result->representation.length;
590
}
591
 
592
 
593
/* --------------------------------------------------------------- */
594
/* Two functions used by trans-common.c to write overlapping
595
   equivalence initializers to a buffer.  This is added to the union
596
   and the original initializers freed.  */
597
 
598
 
599
/* Writes the values of a constant expression to a char buffer. If another
600
   unequal initializer has already been written to the buffer, this is an
601
   error.  */
602
 
603
static size_t
604
expr_to_char (gfc_expr *e, unsigned char *data, unsigned char *chk, size_t len)
605
{
606
  int i;
607
  int ptr;
608
  gfc_constructor *c;
609
  gfc_component *cmp;
610
  unsigned char *buffer;
611
 
612
  if (e == NULL)
613
    return 0;
614
 
615
  /* Take a derived type, one component at a time, using the offsets from the backend
616
     declaration.  */
617
  if (e->ts.type == BT_DERIVED)
618
    {
619
      for (c = gfc_constructor_first (e->value.constructor),
620
           cmp = e->ts.u.derived->components;
621
           c; c = gfc_constructor_next (c), cmp = cmp->next)
622
        {
623
          gcc_assert (cmp && cmp->backend_decl);
624
          if (!c->expr)
625
            continue;
626
            ptr = TREE_INT_CST_LOW(DECL_FIELD_OFFSET(cmp->backend_decl))
627
                        + TREE_INT_CST_LOW(DECL_FIELD_BIT_OFFSET(cmp->backend_decl))/8;
628
          expr_to_char (c->expr, &data[ptr], &chk[ptr], len);
629
        }
630
      return len;
631
    }
632
 
633
  /* Otherwise, use the target-memory machinery to write a bitwise image, appropriate
634
     to the target, in a buffer and check off the initialized part of the buffer.  */
635
  len = gfc_target_expr_size (e);
636
  buffer = (unsigned char*)alloca (len);
637
  len = gfc_target_encode_expr (e, buffer, len);
638
 
639
    for (i = 0; i < (int)len; i++)
640
    {
641
      if (chk[i] && (buffer[i] != data[i]))
642
        {
643
          gfc_error ("Overlapping unequal initializers in EQUIVALENCE "
644
                     "at %L", &e->where);
645
          return 0;
646
        }
647
      chk[i] = 0xFF;
648
    }
649
 
650
  memcpy (data, buffer, len);
651
  return len;
652
}
653
 
654
 
655
/* Writes the values from the equivalence initializers to a char* array
656
   that will be written to the constructor to make the initializer for
657
   the union declaration.  */
658
 
659
size_t
660
gfc_merge_initializers (gfc_typespec ts, gfc_expr *e, unsigned char *data,
661
                        unsigned char *chk, size_t length)
662
{
663
  size_t len = 0;
664
  gfc_constructor * c;
665
 
666
  switch (e->expr_type)
667
    {
668
    case EXPR_CONSTANT:
669
    case EXPR_STRUCTURE:
670
      len = expr_to_char (e, &data[0], &chk[0], length);
671
 
672
      break;
673
 
674
    case EXPR_ARRAY:
675
      for (c = gfc_constructor_first (e->value.constructor);
676
           c; c = gfc_constructor_next (c))
677
        {
678
          size_t elt_size = gfc_target_expr_size (c->expr);
679
 
680
          if (c->offset)
681
            len = elt_size * (size_t)mpz_get_si (c->offset);
682
 
683
          len = len + gfc_merge_initializers (ts, c->expr, &data[len],
684
                                              &chk[len], length - len);
685
        }
686
      break;
687
 
688
    default:
689
      return 0;
690
    }
691
 
692
  return len;
693
}
694
 
695
 
696
/* Transfer the bitpattern of a (integer) BOZ to real or complex variables.
697
   When successful, no BOZ or nothing to do, true is returned.  */
698
 
699
bool
700
gfc_convert_boz (gfc_expr *expr, gfc_typespec *ts)
701
{
702
  size_t buffer_size, boz_bit_size, ts_bit_size;
703
  int index;
704
  unsigned char *buffer;
705
 
706
  if (!expr->is_boz)
707
    return true;
708
 
709
  gcc_assert (expr->expr_type == EXPR_CONSTANT
710
              && expr->ts.type == BT_INTEGER);
711
 
712
  /* Don't convert BOZ to logical, character, derived etc.  */
713
  if (ts->type == BT_REAL)
714
    {
715
      buffer_size = size_float (ts->kind);
716
      ts_bit_size = buffer_size * 8;
717
    }
718
  else if (ts->type == BT_COMPLEX)
719
    {
720
      buffer_size = size_complex (ts->kind);
721
      ts_bit_size = buffer_size * 8 / 2;
722
    }
723
  else
724
    return true;
725
 
726
  /* Convert BOZ to the smallest possible integer kind.  */
727
  boz_bit_size = mpz_sizeinbase (expr->value.integer, 2);
728
 
729
  if (boz_bit_size > ts_bit_size)
730
    {
731
      gfc_error_now ("BOZ constant at %L is too large (%ld vs %ld bits)",
732
                     &expr->where, (long) boz_bit_size, (long) ts_bit_size);
733
      return false;
734
    }
735
 
736
  for (index = 0; gfc_integer_kinds[index].kind != 0; ++index)
737
    if ((unsigned) gfc_integer_kinds[index].bit_size >= ts_bit_size)
738
      break;
739
 
740
  expr->ts.kind = gfc_integer_kinds[index].kind;
741
  buffer_size = MAX (buffer_size, size_integer (expr->ts.kind));
742
 
743
  buffer = (unsigned char*)alloca (buffer_size);
744
  encode_integer (expr->ts.kind, expr->value.integer, buffer, buffer_size);
745
  mpz_clear (expr->value.integer);
746
 
747
  if (ts->type == BT_REAL)
748
    {
749
      mpfr_init (expr->value.real);
750
      gfc_interpret_float (ts->kind, buffer, buffer_size, expr->value.real);
751
    }
752
  else
753
    {
754
      mpc_init2 (expr->value.complex, mpfr_get_default_prec());
755
      gfc_interpret_complex (ts->kind, buffer, buffer_size,
756
                             expr->value.complex);
757
    }
758
  expr->is_boz = 0;
759
  expr->ts.type = ts->type;
760
  expr->ts.kind = ts->kind;
761
 
762
  return true;
763
}

powered by: WebSVN 2.1.0

© copyright 1999-2024 OpenCores.org, equivalent to Oliscience, all rights reserved. OpenCores®, registered trademark.