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

Subversion Repositories openrisc

[/] [openrisc/] [trunk/] [gnu-dev/] [or1k-gcc/] [gcc/] [fortran/] [array.c] - Blame information for rev 744

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

Line No. Rev Author Line
1 712 jeremybenn
/* Array things
2
   Copyright (C) 2000, 2001, 2002, 2004, 2005, 2006, 2007, 2008, 2009, 2010
3
   Free Software Foundation, Inc.
4
   Contributed by Andy Vaught
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 "gfortran.h"
25
#include "match.h"
26
#include "constructor.h"
27
 
28
/**************** Array reference matching subroutines *****************/
29
 
30
/* Copy an array reference structure.  */
31
 
32
gfc_array_ref *
33
gfc_copy_array_ref (gfc_array_ref *src)
34
{
35
  gfc_array_ref *dest;
36
  int i;
37
 
38
  if (src == NULL)
39
    return NULL;
40
 
41
  dest = gfc_get_array_ref ();
42
 
43
  *dest = *src;
44
 
45
  for (i = 0; i < GFC_MAX_DIMENSIONS; i++)
46
    {
47
      dest->start[i] = gfc_copy_expr (src->start[i]);
48
      dest->end[i] = gfc_copy_expr (src->end[i]);
49
      dest->stride[i] = gfc_copy_expr (src->stride[i]);
50
    }
51
 
52
  dest->offset = gfc_copy_expr (src->offset);
53
 
54
  return dest;
55
}
56
 
57
 
58
/* Match a single dimension of an array reference.  This can be a
59
   single element or an array section.  Any modifications we've made
60
   to the ar structure are cleaned up by the caller.  If the init
61
   is set, we require the subscript to be a valid initialization
62
   expression.  */
63
 
64
static match
65
match_subscript (gfc_array_ref *ar, int init, bool match_star)
66
{
67
  match m = MATCH_ERROR;
68
  bool star = false;
69
  int i;
70
 
71
  i = ar->dimen + ar->codimen;
72
 
73
  gfc_gobble_whitespace ();
74
  ar->c_where[i] = gfc_current_locus;
75
  ar->start[i] = ar->end[i] = ar->stride[i] = NULL;
76
 
77
  /* We can't be sure of the difference between DIMEN_ELEMENT and
78
     DIMEN_VECTOR until we know the type of the element itself at
79
     resolution time.  */
80
 
81
  ar->dimen_type[i] = DIMEN_UNKNOWN;
82
 
83
  if (gfc_match_char (':') == MATCH_YES)
84
    goto end_element;
85
 
86
  /* Get start element.  */
87
  if (match_star && (m = gfc_match_char ('*')) == MATCH_YES)
88
    star = true;
89
 
90
  if (!star && init)
91
    m = gfc_match_init_expr (&ar->start[i]);
92
  else if (!star)
93
    m = gfc_match_expr (&ar->start[i]);
94
 
95
  if (m == MATCH_NO && gfc_match_char ('*') == MATCH_YES)
96
    return MATCH_NO;
97
  else if (m == MATCH_NO)
98
    gfc_error ("Expected array subscript at %C");
99
  if (m != MATCH_YES)
100
    return MATCH_ERROR;
101
 
102
  if (gfc_match_char (':') == MATCH_NO)
103
    goto matched;
104
 
105
  if (star)
106
    {
107
      gfc_error ("Unexpected '*' in coarray subscript at %C");
108
      return MATCH_ERROR;
109
    }
110
 
111
  /* Get an optional end element.  Because we've seen the colon, we
112
     definitely have a range along this dimension.  */
113
end_element:
114
  ar->dimen_type[i] = DIMEN_RANGE;
115
 
116
  if (match_star && (m = gfc_match_char ('*')) == MATCH_YES)
117
    star = true;
118
  else if (init)
119
    m = gfc_match_init_expr (&ar->end[i]);
120
  else
121
    m = gfc_match_expr (&ar->end[i]);
122
 
123
  if (m == MATCH_ERROR)
124
    return MATCH_ERROR;
125
 
126
  /* See if we have an optional stride.  */
127
  if (gfc_match_char (':') == MATCH_YES)
128
    {
129
      if (star)
130
        {
131
          gfc_error ("Strides not allowed in coarray subscript at %C");
132
          return MATCH_ERROR;
133
        }
134
 
135
      m = init ? gfc_match_init_expr (&ar->stride[i])
136
               : gfc_match_expr (&ar->stride[i]);
137
 
138
      if (m == MATCH_NO)
139
        gfc_error ("Expected array subscript stride at %C");
140
      if (m != MATCH_YES)
141
        return MATCH_ERROR;
142
    }
143
 
144
matched:
145
  if (star)
146
    ar->dimen_type[i] = DIMEN_STAR;
147
 
148
  return MATCH_YES;
149
}
150
 
151
 
152
/* Match an array reference, whether it is the whole array or a
153
   particular elements or a section. If init is set, the reference has
154
   to consist of init expressions.  */
155
 
156
match
157
gfc_match_array_ref (gfc_array_ref *ar, gfc_array_spec *as, int init,
158
                     int corank)
159
{
160
  match m;
161
  bool matched_bracket = false;
162
 
163
  memset (ar, '\0', sizeof (ar));
164
 
165
  ar->where = gfc_current_locus;
166
  ar->as = as;
167
  ar->type = AR_UNKNOWN;
168
 
169
  if (gfc_match_char ('[') == MATCH_YES)
170
    {
171
       matched_bracket = true;
172
       goto coarray;
173
    }
174
 
175
  if (gfc_match_char ('(') != MATCH_YES)
176
    {
177
      ar->type = AR_FULL;
178
      ar->dimen = 0;
179
      return MATCH_YES;
180
    }
181
 
182
  for (ar->dimen = 0; ar->dimen < GFC_MAX_DIMENSIONS; ar->dimen++)
183
    {
184
      m = match_subscript (ar, init, false);
185
      if (m == MATCH_ERROR)
186
        return MATCH_ERROR;
187
 
188
      if (gfc_match_char (')') == MATCH_YES)
189
        {
190
          ar->dimen++;
191
          goto coarray;
192
        }
193
 
194
      if (gfc_match_char (',') != MATCH_YES)
195
        {
196
          gfc_error ("Invalid form of array reference at %C");
197
          return MATCH_ERROR;
198
        }
199
    }
200
 
201
  gfc_error ("Array reference at %C cannot have more than %d dimensions",
202
             GFC_MAX_DIMENSIONS);
203
  return MATCH_ERROR;
204
 
205
coarray:
206
  if (!matched_bracket && gfc_match_char ('[') != MATCH_YES)
207
    {
208
      if (ar->dimen > 0)
209
        return MATCH_YES;
210
      else
211
        return MATCH_ERROR;
212
    }
213
 
214
  if (gfc_option.coarray == GFC_FCOARRAY_NONE)
215
    {
216
      gfc_fatal_error ("Coarrays disabled at %C, use -fcoarray= to enable");
217
      return MATCH_ERROR;
218
    }
219
 
220
  if (corank == 0)
221
    {
222
        gfc_error ("Unexpected coarray designator at %C");
223
        return MATCH_ERROR;
224
    }
225
 
226
  for (ar->codimen = 0; ar->codimen + ar->dimen < GFC_MAX_DIMENSIONS; ar->codimen++)
227
    {
228
      m = match_subscript (ar, init, ar->codimen == (corank - 1));
229
      if (m == MATCH_ERROR)
230
        return MATCH_ERROR;
231
 
232
      if (gfc_match_char (']') == MATCH_YES)
233
        {
234
          ar->codimen++;
235
          if (ar->codimen < corank)
236
            {
237
              gfc_error ("Too few codimensions at %C, expected %d not %d",
238
                         corank, ar->codimen);
239
              return MATCH_ERROR;
240
            }
241
          if (ar->codimen > corank)
242
            {
243
              gfc_error ("Too many codimensions at %C, expected %d not %d",
244
                         corank, ar->codimen);
245
              return MATCH_ERROR;
246
            }
247
          return MATCH_YES;
248
        }
249
 
250
      if (gfc_match_char (',') != MATCH_YES)
251
        {
252
          if (gfc_match_char ('*') == MATCH_YES)
253
            gfc_error ("Unexpected '*' for codimension %d of %d at %C",
254
                       ar->codimen + 1, corank);
255
          else
256
            gfc_error ("Invalid form of coarray reference at %C");
257
          return MATCH_ERROR;
258
        }
259
      if (ar->codimen >= corank)
260
        {
261
          gfc_error ("Invalid codimension %d at %C, only %d codimensions exist",
262
                     ar->codimen + 1, corank);
263
          return MATCH_ERROR;
264
        }
265
    }
266
 
267
  gfc_error ("Array reference at %C cannot have more than %d dimensions",
268
             GFC_MAX_DIMENSIONS);
269
  return MATCH_ERROR;
270
 
271
}
272
 
273
 
274
/************** Array specification matching subroutines ***************/
275
 
276
/* Free all of the expressions associated with array bounds
277
   specifications.  */
278
 
279
void
280
gfc_free_array_spec (gfc_array_spec *as)
281
{
282
  int i;
283
 
284
  if (as == NULL)
285
    return;
286
 
287
  for (i = 0; i < as->rank + as->corank; i++)
288
    {
289
      gfc_free_expr (as->lower[i]);
290
      gfc_free_expr (as->upper[i]);
291
    }
292
 
293
  free (as);
294
}
295
 
296
 
297
/* Take an array bound, resolves the expression, that make up the
298
   shape and check associated constraints.  */
299
 
300
static gfc_try
301
resolve_array_bound (gfc_expr *e, int check_constant)
302
{
303
  if (e == NULL)
304
    return SUCCESS;
305
 
306
  if (gfc_resolve_expr (e) == FAILURE
307
      || gfc_specification_expr (e) == FAILURE)
308
    return FAILURE;
309
 
310
  if (check_constant && !gfc_is_constant_expr (e))
311
    {
312
      if (e->expr_type == EXPR_VARIABLE)
313
        gfc_error ("Variable '%s' at %L in this context must be constant",
314
                   e->symtree->n.sym->name, &e->where);
315
      else
316
        gfc_error ("Expression at %L in this context must be constant",
317
                   &e->where);
318
      return FAILURE;
319
    }
320
 
321
  return SUCCESS;
322
}
323
 
324
 
325
/* Takes an array specification, resolves the expressions that make up
326
   the shape and make sure everything is integral.  */
327
 
328
gfc_try
329
gfc_resolve_array_spec (gfc_array_spec *as, int check_constant)
330
{
331
  gfc_expr *e;
332
  int i;
333
 
334
  if (as == NULL)
335
    return SUCCESS;
336
 
337
  for (i = 0; i < as->rank + as->corank; i++)
338
    {
339
      e = as->lower[i];
340
      if (resolve_array_bound (e, check_constant) == FAILURE)
341
        return FAILURE;
342
 
343
      e = as->upper[i];
344
      if (resolve_array_bound (e, check_constant) == FAILURE)
345
        return FAILURE;
346
 
347
      if ((as->lower[i] == NULL) || (as->upper[i] == NULL))
348
        continue;
349
 
350
      /* If the size is negative in this dimension, set it to zero.  */
351
      if (as->lower[i]->expr_type == EXPR_CONSTANT
352
            && as->upper[i]->expr_type == EXPR_CONSTANT
353
            && mpz_cmp (as->upper[i]->value.integer,
354
                        as->lower[i]->value.integer) < 0)
355
        {
356
          gfc_free_expr (as->upper[i]);
357
          as->upper[i] = gfc_copy_expr (as->lower[i]);
358
          mpz_sub_ui (as->upper[i]->value.integer,
359
                      as->upper[i]->value.integer, 1);
360
        }
361
    }
362
 
363
  return SUCCESS;
364
}
365
 
366
 
367
/* Match a single array element specification.  The return values as
368
   well as the upper and lower bounds of the array spec are filled
369
   in according to what we see on the input.  The caller makes sure
370
   individual specifications make sense as a whole.
371
 
372
 
373
        Parsed       Lower   Upper  Returned
374
        ------------------------------------
375
          :           NULL    NULL   AS_DEFERRED (*)
376
          x            1       x     AS_EXPLICIT
377
          x:           x      NULL   AS_ASSUMED_SHAPE
378
          x:y          x       y     AS_EXPLICIT
379
          x:*          x      NULL   AS_ASSUMED_SIZE
380
          *            1      NULL   AS_ASSUMED_SIZE
381
 
382
  (*) For non-pointer dummy arrays this is AS_ASSUMED_SHAPE.  This
383
  is fixed during the resolution of formal interfaces.
384
 
385
   Anything else AS_UNKNOWN.  */
386
 
387
static array_type
388
match_array_element_spec (gfc_array_spec *as)
389
{
390
  gfc_expr **upper, **lower;
391
  match m;
392
 
393
  lower = &as->lower[as->rank + as->corank - 1];
394
  upper = &as->upper[as->rank + as->corank - 1];
395
 
396
  if (gfc_match_char ('*') == MATCH_YES)
397
    {
398
      *lower = gfc_get_int_expr (gfc_default_integer_kind, NULL, 1);
399
      return AS_ASSUMED_SIZE;
400
    }
401
 
402
  if (gfc_match_char (':') == MATCH_YES)
403
    return AS_DEFERRED;
404
 
405
  m = gfc_match_expr (upper);
406
  if (m == MATCH_NO)
407
    gfc_error ("Expected expression in array specification at %C");
408
  if (m != MATCH_YES)
409
    return AS_UNKNOWN;
410
  if (gfc_expr_check_typed (*upper, gfc_current_ns, false) == FAILURE)
411
    return AS_UNKNOWN;
412
 
413
  if (gfc_match_char (':') == MATCH_NO)
414
    {
415
      *lower = gfc_get_int_expr (gfc_default_integer_kind, NULL, 1);
416
      return AS_EXPLICIT;
417
    }
418
 
419
  *lower = *upper;
420
  *upper = NULL;
421
 
422
  if (gfc_match_char ('*') == MATCH_YES)
423
    return AS_ASSUMED_SIZE;
424
 
425
  m = gfc_match_expr (upper);
426
  if (m == MATCH_ERROR)
427
    return AS_UNKNOWN;
428
  if (m == MATCH_NO)
429
    return AS_ASSUMED_SHAPE;
430
  if (gfc_expr_check_typed (*upper, gfc_current_ns, false) == FAILURE)
431
    return AS_UNKNOWN;
432
 
433
  return AS_EXPLICIT;
434
}
435
 
436
 
437
/* Matches an array specification, incidentally figuring out what sort
438
   it is. Match either a normal array specification, or a coarray spec
439
   or both. Optionally allow [:] for coarrays.  */
440
 
441
match
442
gfc_match_array_spec (gfc_array_spec **asp, bool match_dim, bool match_codim)
443
{
444
  array_type current_type;
445
  gfc_array_spec *as;
446
  int i;
447
 
448
  as = gfc_get_array_spec ();
449
 
450
  if (!match_dim)
451
    goto coarray;
452
 
453
  if (gfc_match_char ('(') != MATCH_YES)
454
    {
455
      if (!match_codim)
456
        goto done;
457
      goto coarray;
458
    }
459
 
460
  for (;;)
461
    {
462
      as->rank++;
463
      current_type = match_array_element_spec (as);
464
 
465
      /* Note that current_type == AS_ASSUMED_SIZE for both assumed-size
466
         and implied-shape specifications.  If the rank is at least 2, we can
467
         distinguish between them.  But for rank 1, we currently return
468
         ASSUMED_SIZE; this gets adjusted later when we know for sure
469
         whether the symbol parsed is a PARAMETER or not.  */
470
 
471
      if (as->rank == 1)
472
        {
473
          if (current_type == AS_UNKNOWN)
474
            goto cleanup;
475
          as->type = current_type;
476
        }
477
      else
478
        switch (as->type)
479
          {             /* See how current spec meshes with the existing.  */
480
          case AS_UNKNOWN:
481
            goto cleanup;
482
 
483
          case AS_IMPLIED_SHAPE:
484
            if (current_type != AS_ASSUMED_SHAPE)
485
              {
486
                gfc_error ("Bad array specification for implied-shape"
487
                           " array at %C");
488
                goto cleanup;
489
              }
490
            break;
491
 
492
          case AS_EXPLICIT:
493
            if (current_type == AS_ASSUMED_SIZE)
494
              {
495
                as->type = AS_ASSUMED_SIZE;
496
                break;
497
              }
498
 
499
            if (current_type == AS_EXPLICIT)
500
              break;
501
 
502
            gfc_error ("Bad array specification for an explicitly shaped "
503
                       "array at %C");
504
 
505
            goto cleanup;
506
 
507
          case AS_ASSUMED_SHAPE:
508
            if ((current_type == AS_ASSUMED_SHAPE)
509
                || (current_type == AS_DEFERRED))
510
              break;
511
 
512
            gfc_error ("Bad array specification for assumed shape "
513
                       "array at %C");
514
            goto cleanup;
515
 
516
          case AS_DEFERRED:
517
            if (current_type == AS_DEFERRED)
518
              break;
519
 
520
            if (current_type == AS_ASSUMED_SHAPE)
521
              {
522
                as->type = AS_ASSUMED_SHAPE;
523
                break;
524
              }
525
 
526
            gfc_error ("Bad specification for deferred shape array at %C");
527
            goto cleanup;
528
 
529
          case AS_ASSUMED_SIZE:
530
            if (as->rank == 2 && current_type == AS_ASSUMED_SIZE)
531
              {
532
                as->type = AS_IMPLIED_SHAPE;
533
                break;
534
              }
535
 
536
            gfc_error ("Bad specification for assumed size array at %C");
537
            goto cleanup;
538
          }
539
 
540
      if (gfc_match_char (')') == MATCH_YES)
541
        break;
542
 
543
      if (gfc_match_char (',') != MATCH_YES)
544
        {
545
          gfc_error ("Expected another dimension in array declaration at %C");
546
          goto cleanup;
547
        }
548
 
549
      if (as->rank + as->corank >= GFC_MAX_DIMENSIONS)
550
        {
551
          gfc_error ("Array specification at %C has more than %d dimensions",
552
                     GFC_MAX_DIMENSIONS);
553
          goto cleanup;
554
        }
555
 
556
      if (as->corank + as->rank >= 7
557
          && gfc_notify_std (GFC_STD_F2008, "Fortran 2008: Array "
558
                             "specification at %C with more than 7 dimensions")
559
             == FAILURE)
560
        goto cleanup;
561
    }
562
 
563
  if (!match_codim)
564
    goto done;
565
 
566
coarray:
567
  if (gfc_match_char ('[')  != MATCH_YES)
568
    goto done;
569
 
570
  if (gfc_notify_std (GFC_STD_F2008, "Fortran 2008: Coarray declaration at %C")
571
      == FAILURE)
572
    goto cleanup;
573
 
574
  if (gfc_option.coarray == GFC_FCOARRAY_NONE)
575
    {
576
      gfc_fatal_error ("Coarrays disabled at %C, use -fcoarray= to enable");
577
      goto cleanup;
578
    }
579
 
580
  if (as->rank >= GFC_MAX_DIMENSIONS)
581
    {
582
      gfc_error ("Array specification at %C has more than %d "
583
                 "dimensions", GFC_MAX_DIMENSIONS);
584
      goto cleanup;
585
    }
586
 
587
  for (;;)
588
    {
589
      as->corank++;
590
      current_type = match_array_element_spec (as);
591
 
592
      if (current_type == AS_UNKNOWN)
593
        goto cleanup;
594
 
595
      if (as->corank == 1)
596
        as->cotype = current_type;
597
      else
598
        switch (as->cotype)
599
          { /* See how current spec meshes with the existing.  */
600
            case AS_IMPLIED_SHAPE:
601
            case AS_UNKNOWN:
602
              goto cleanup;
603
 
604
            case AS_EXPLICIT:
605
              if (current_type == AS_ASSUMED_SIZE)
606
                {
607
                  as->cotype = AS_ASSUMED_SIZE;
608
                  break;
609
                }
610
 
611
              if (current_type == AS_EXPLICIT)
612
                break;
613
 
614
              gfc_error ("Bad array specification for an explicitly "
615
                         "shaped array at %C");
616
 
617
              goto cleanup;
618
 
619
            case AS_ASSUMED_SHAPE:
620
              if ((current_type == AS_ASSUMED_SHAPE)
621
                  || (current_type == AS_DEFERRED))
622
                break;
623
 
624
              gfc_error ("Bad array specification for assumed shape "
625
                         "array at %C");
626
              goto cleanup;
627
 
628
            case AS_DEFERRED:
629
              if (current_type == AS_DEFERRED)
630
                break;
631
 
632
              if (current_type == AS_ASSUMED_SHAPE)
633
                {
634
                  as->cotype = AS_ASSUMED_SHAPE;
635
                  break;
636
                }
637
 
638
              gfc_error ("Bad specification for deferred shape array at %C");
639
              goto cleanup;
640
 
641
            case AS_ASSUMED_SIZE:
642
              gfc_error ("Bad specification for assumed size array at %C");
643
              goto cleanup;
644
          }
645
 
646
      if (gfc_match_char (']') == MATCH_YES)
647
        break;
648
 
649
      if (gfc_match_char (',') != MATCH_YES)
650
        {
651
          gfc_error ("Expected another dimension in array declaration at %C");
652
          goto cleanup;
653
        }
654
 
655
      if (as->rank + as->corank >= GFC_MAX_DIMENSIONS)
656
        {
657
          gfc_error ("Array specification at %C has more than %d "
658
                     "dimensions", GFC_MAX_DIMENSIONS);
659
          goto cleanup;
660
        }
661
    }
662
 
663
  if (current_type == AS_EXPLICIT)
664
    {
665
      gfc_error ("Upper bound of last coarray dimension must be '*' at %C");
666
      goto cleanup;
667
    }
668
 
669
  if (as->cotype == AS_ASSUMED_SIZE)
670
    as->cotype = AS_EXPLICIT;
671
 
672
  if (as->rank == 0)
673
    as->type = as->cotype;
674
 
675
done:
676
  if (as->rank == 0 && as->corank == 0)
677
    {
678
      *asp = NULL;
679
      gfc_free_array_spec (as);
680
      return MATCH_NO;
681
    }
682
 
683
  /* If a lower bounds of an assumed shape array is blank, put in one.  */
684
  if (as->type == AS_ASSUMED_SHAPE)
685
    {
686
      for (i = 0; i < as->rank + as->corank; i++)
687
        {
688
          if (as->lower[i] == NULL)
689
            as->lower[i] = gfc_get_int_expr (gfc_default_integer_kind, NULL, 1);
690
        }
691
    }
692
 
693
  *asp = as;
694
 
695
  return MATCH_YES;
696
 
697
cleanup:
698
  /* Something went wrong.  */
699
  gfc_free_array_spec (as);
700
  return MATCH_ERROR;
701
}
702
 
703
 
704
/* Given a symbol and an array specification, modify the symbol to
705
   have that array specification.  The error locus is needed in case
706
   something goes wrong.  On failure, the caller must free the spec.  */
707
 
708
gfc_try
709
gfc_set_array_spec (gfc_symbol *sym, gfc_array_spec *as, locus *error_loc)
710
{
711
  int i;
712
 
713
  if (as == NULL)
714
    return SUCCESS;
715
 
716
  if (as->rank
717
      && gfc_add_dimension (&sym->attr, sym->name, error_loc) == FAILURE)
718
    return FAILURE;
719
 
720
  if (as->corank
721
      && gfc_add_codimension (&sym->attr, sym->name, error_loc) == FAILURE)
722
    return FAILURE;
723
 
724
  if (sym->as == NULL)
725
    {
726
      sym->as = as;
727
      return SUCCESS;
728
    }
729
 
730
  if (as->corank)
731
    {
732
      /* The "sym" has no corank (checked via gfc_add_codimension). Thus
733
         the codimension is simply added.  */
734
      gcc_assert (as->rank == 0 && sym->as->corank == 0);
735
 
736
      sym->as->cotype = as->cotype;
737
      sym->as->corank = as->corank;
738
      for (i = 0; i < as->corank; i++)
739
        {
740
          sym->as->lower[sym->as->rank + i] = as->lower[i];
741
          sym->as->upper[sym->as->rank + i] = as->upper[i];
742
        }
743
    }
744
  else
745
    {
746
      /* The "sym" has no rank (checked via gfc_add_dimension). Thus
747
         the dimension is added - but first the codimensions (if existing
748
         need to be shifted to make space for the dimension.  */
749
      gcc_assert (as->corank == 0 && sym->as->rank == 0);
750
 
751
      sym->as->rank = as->rank;
752
      sym->as->type = as->type;
753
      sym->as->cray_pointee = as->cray_pointee;
754
      sym->as->cp_was_assumed = as->cp_was_assumed;
755
 
756
      for (i = 0; i < sym->as->corank; i++)
757
        {
758
          sym->as->lower[as->rank + i] = sym->as->lower[i];
759
          sym->as->upper[as->rank + i] = sym->as->upper[i];
760
        }
761
      for (i = 0; i < as->rank; i++)
762
        {
763
          sym->as->lower[i] = as->lower[i];
764
          sym->as->upper[i] = as->upper[i];
765
        }
766
    }
767
 
768
  free (as);
769
  return SUCCESS;
770
}
771
 
772
 
773
/* Copy an array specification.  */
774
 
775
gfc_array_spec *
776
gfc_copy_array_spec (gfc_array_spec *src)
777
{
778
  gfc_array_spec *dest;
779
  int i;
780
 
781
  if (src == NULL)
782
    return NULL;
783
 
784
  dest = gfc_get_array_spec ();
785
 
786
  *dest = *src;
787
 
788
  for (i = 0; i < dest->rank + dest->corank; i++)
789
    {
790
      dest->lower[i] = gfc_copy_expr (dest->lower[i]);
791
      dest->upper[i] = gfc_copy_expr (dest->upper[i]);
792
    }
793
 
794
  return dest;
795
}
796
 
797
 
798
/* Returns nonzero if the two expressions are equal.  Only handles integer
799
   constants.  */
800
 
801
static int
802
compare_bounds (gfc_expr *bound1, gfc_expr *bound2)
803
{
804
  if (bound1 == NULL || bound2 == NULL
805
      || bound1->expr_type != EXPR_CONSTANT
806
      || bound2->expr_type != EXPR_CONSTANT
807
      || bound1->ts.type != BT_INTEGER
808
      || bound2->ts.type != BT_INTEGER)
809
    gfc_internal_error ("gfc_compare_array_spec(): Array spec clobbered");
810
 
811
  if (mpz_cmp (bound1->value.integer, bound2->value.integer) == 0)
812
    return 1;
813
  else
814
    return 0;
815
}
816
 
817
 
818
/* Compares two array specifications.  They must be constant or deferred
819
   shape.  */
820
 
821
int
822
gfc_compare_array_spec (gfc_array_spec *as1, gfc_array_spec *as2)
823
{
824
  int i;
825
 
826
  if (as1 == NULL && as2 == NULL)
827
    return 1;
828
 
829
  if (as1 == NULL || as2 == NULL)
830
    return 0;
831
 
832
  if (as1->rank != as2->rank)
833
    return 0;
834
 
835
  if (as1->corank != as2->corank)
836
    return 0;
837
 
838
  if (as1->rank == 0)
839
    return 1;
840
 
841
  if (as1->type != as2->type)
842
    return 0;
843
 
844
  if (as1->type == AS_EXPLICIT)
845
    for (i = 0; i < as1->rank + as1->corank; i++)
846
      {
847
        if (compare_bounds (as1->lower[i], as2->lower[i]) == 0)
848
          return 0;
849
 
850
        if (compare_bounds (as1->upper[i], as2->upper[i]) == 0)
851
          return 0;
852
      }
853
 
854
  return 1;
855
}
856
 
857
 
858
/****************** Array constructor functions ******************/
859
 
860
 
861
/* Given an expression node that might be an array constructor and a
862
   symbol, make sure that no iterators in this or child constructors
863
   use the symbol as an implied-DO iterator.  Returns nonzero if a
864
   duplicate was found.  */
865
 
866
static int
867
check_duplicate_iterator (gfc_constructor_base base, gfc_symbol *master)
868
{
869
  gfc_constructor *c;
870
  gfc_expr *e;
871
 
872
  for (c = gfc_constructor_first (base); c; c = gfc_constructor_next (c))
873
    {
874
      e = c->expr;
875
 
876
      if (e->expr_type == EXPR_ARRAY
877
          && check_duplicate_iterator (e->value.constructor, master))
878
        return 1;
879
 
880
      if (c->iterator == NULL)
881
        continue;
882
 
883
      if (c->iterator->var->symtree->n.sym == master)
884
        {
885
          gfc_error ("DO-iterator '%s' at %L is inside iterator of the "
886
                     "same name", master->name, &c->where);
887
 
888
          return 1;
889
        }
890
    }
891
 
892
  return 0;
893
}
894
 
895
 
896
/* Forward declaration because these functions are mutually recursive.  */
897
static match match_array_cons_element (gfc_constructor_base *);
898
 
899
/* Match a list of array elements.  */
900
 
901
static match
902
match_array_list (gfc_constructor_base *result)
903
{
904
  gfc_constructor_base head;
905
  gfc_constructor *p;
906
  gfc_iterator iter;
907
  locus old_loc;
908
  gfc_expr *e;
909
  match m;
910
  int n;
911
 
912
  old_loc = gfc_current_locus;
913
 
914
  if (gfc_match_char ('(') == MATCH_NO)
915
    return MATCH_NO;
916
 
917
  memset (&iter, '\0', sizeof (gfc_iterator));
918
  head = NULL;
919
 
920
  m = match_array_cons_element (&head);
921
  if (m != MATCH_YES)
922
    goto cleanup;
923
 
924
  if (gfc_match_char (',') != MATCH_YES)
925
    {
926
      m = MATCH_NO;
927
      goto cleanup;
928
    }
929
 
930
  for (n = 1;; n++)
931
    {
932
      m = gfc_match_iterator (&iter, 0);
933
      if (m == MATCH_YES)
934
        break;
935
      if (m == MATCH_ERROR)
936
        goto cleanup;
937
 
938
      m = match_array_cons_element (&head);
939
      if (m == MATCH_ERROR)
940
        goto cleanup;
941
      if (m == MATCH_NO)
942
        {
943
          if (n > 2)
944
            goto syntax;
945
          m = MATCH_NO;
946
          goto cleanup;         /* Could be a complex constant */
947
        }
948
 
949
      if (gfc_match_char (',') != MATCH_YES)
950
        {
951
          if (n > 2)
952
            goto syntax;
953
          m = MATCH_NO;
954
          goto cleanup;
955
        }
956
    }
957
 
958
  if (gfc_match_char (')') != MATCH_YES)
959
    goto syntax;
960
 
961
  if (check_duplicate_iterator (head, iter.var->symtree->n.sym))
962
    {
963
      m = MATCH_ERROR;
964
      goto cleanup;
965
    }
966
 
967
  e = gfc_get_array_expr (BT_UNKNOWN, 0, &old_loc);
968
  e->value.constructor = head;
969
 
970
  p = gfc_constructor_append_expr (result, e, &gfc_current_locus);
971
  p->iterator = gfc_get_iterator ();
972
  *p->iterator = iter;
973
 
974
  return MATCH_YES;
975
 
976
syntax:
977
  gfc_error ("Syntax error in array constructor at %C");
978
  m = MATCH_ERROR;
979
 
980
cleanup:
981
  gfc_constructor_free (head);
982
  gfc_free_iterator (&iter, 0);
983
  gfc_current_locus = old_loc;
984
  return m;
985
}
986
 
987
 
988
/* Match a single element of an array constructor, which can be a
989
   single expression or a list of elements.  */
990
 
991
static match
992
match_array_cons_element (gfc_constructor_base *result)
993
{
994
  gfc_expr *expr;
995
  match m;
996
 
997
  m = match_array_list (result);
998
  if (m != MATCH_NO)
999
    return m;
1000
 
1001
  m = gfc_match_expr (&expr);
1002
  if (m != MATCH_YES)
1003
    return m;
1004
 
1005
  gfc_constructor_append_expr (result, expr, &gfc_current_locus);
1006
  return MATCH_YES;
1007
}
1008
 
1009
 
1010
/* Match an array constructor.  */
1011
 
1012
match
1013
gfc_match_array_constructor (gfc_expr **result)
1014
{
1015
  gfc_constructor_base head, new_cons;
1016
  gfc_expr *expr;
1017
  gfc_typespec ts;
1018
  locus where;
1019
  match m;
1020
  const char *end_delim;
1021
  bool seen_ts;
1022
 
1023
  if (gfc_match (" (/") == MATCH_NO)
1024
    {
1025
      if (gfc_match (" [") == MATCH_NO)
1026
        return MATCH_NO;
1027
      else
1028
        {
1029
          if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: [...] "
1030
                              "style array constructors at %C") == FAILURE)
1031
            return MATCH_ERROR;
1032
          end_delim = " ]";
1033
        }
1034
    }
1035
  else
1036
    end_delim = " /)";
1037
 
1038
  where = gfc_current_locus;
1039
  head = new_cons = NULL;
1040
  seen_ts = false;
1041
 
1042
  /* Try to match an optional "type-spec ::"  */
1043
  if (gfc_match_decl_type_spec (&ts, 0) == MATCH_YES)
1044
    {
1045
      seen_ts = (gfc_match (" ::") == MATCH_YES);
1046
 
1047
      if (seen_ts)
1048
        {
1049
          if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: Array constructor "
1050
                              "including type specification at %C") == FAILURE)
1051
            goto cleanup;
1052
 
1053
          if (ts.deferred)
1054
            {
1055
              gfc_error ("Type-spec at %L cannot contain a deferred "
1056
                         "type parameter", &where);
1057
              goto cleanup;
1058
            }
1059
        }
1060
    }
1061
 
1062
  if (! seen_ts)
1063
    gfc_current_locus = where;
1064
 
1065
  if (gfc_match (end_delim) == MATCH_YES)
1066
    {
1067
      if (seen_ts)
1068
        goto done;
1069
      else
1070
        {
1071
          gfc_error ("Empty array constructor at %C is not allowed");
1072
          goto cleanup;
1073
        }
1074
    }
1075
 
1076
  for (;;)
1077
    {
1078
      m = match_array_cons_element (&head);
1079
      if (m == MATCH_ERROR)
1080
        goto cleanup;
1081
      if (m == MATCH_NO)
1082
        goto syntax;
1083
 
1084
      if (gfc_match_char (',') == MATCH_NO)
1085
        break;
1086
    }
1087
 
1088
  if (gfc_match (end_delim) == MATCH_NO)
1089
    goto syntax;
1090
 
1091
done:
1092
  /* Size must be calculated at resolution time.  */
1093
  if (seen_ts)
1094
    {
1095
      expr = gfc_get_array_expr (ts.type, ts.kind, &where);
1096
      expr->ts = ts;
1097
    }
1098
  else
1099
    expr = gfc_get_array_expr (BT_UNKNOWN, 0, &where);
1100
 
1101
  expr->value.constructor = head;
1102
  if (expr->ts.u.cl)
1103
    expr->ts.u.cl->length_from_typespec = seen_ts;
1104
 
1105
  *result = expr;
1106
  return MATCH_YES;
1107
 
1108
syntax:
1109
  gfc_error ("Syntax error in array constructor at %C");
1110
 
1111
cleanup:
1112
  gfc_constructor_free (head);
1113
  return MATCH_ERROR;
1114
}
1115
 
1116
 
1117
 
1118
/************** Check array constructors for correctness **************/
1119
 
1120
/* Given an expression, compare it's type with the type of the current
1121
   constructor.  Returns nonzero if an error was issued.  The
1122
   cons_state variable keeps track of whether the type of the
1123
   constructor being read or resolved is known to be good, bad or just
1124
   starting out.  */
1125
 
1126
static gfc_typespec constructor_ts;
1127
static enum
1128
{ CONS_START, CONS_GOOD, CONS_BAD }
1129
cons_state;
1130
 
1131
static int
1132
check_element_type (gfc_expr *expr, bool convert)
1133
{
1134
  if (cons_state == CONS_BAD)
1135
    return 0;                    /* Suppress further errors */
1136
 
1137
  if (cons_state == CONS_START)
1138
    {
1139
      if (expr->ts.type == BT_UNKNOWN)
1140
        cons_state = CONS_BAD;
1141
      else
1142
        {
1143
          cons_state = CONS_GOOD;
1144
          constructor_ts = expr->ts;
1145
        }
1146
 
1147
      return 0;
1148
    }
1149
 
1150
  if (gfc_compare_types (&constructor_ts, &expr->ts))
1151
    return 0;
1152
 
1153
  if (convert)
1154
    return gfc_convert_type (expr, &constructor_ts, 1) == SUCCESS ? 0 : 1;
1155
 
1156
  gfc_error ("Element in %s array constructor at %L is %s",
1157
             gfc_typename (&constructor_ts), &expr->where,
1158
             gfc_typename (&expr->ts));
1159
 
1160
  cons_state = CONS_BAD;
1161
  return 1;
1162
}
1163
 
1164
 
1165
/* Recursive work function for gfc_check_constructor_type().  */
1166
 
1167
static gfc_try
1168
check_constructor_type (gfc_constructor_base base, bool convert)
1169
{
1170
  gfc_constructor *c;
1171
  gfc_expr *e;
1172
 
1173
  for (c = gfc_constructor_first (base); c; c = gfc_constructor_next (c))
1174
    {
1175
      e = c->expr;
1176
 
1177
      if (e->expr_type == EXPR_ARRAY)
1178
        {
1179
          if (check_constructor_type (e->value.constructor, convert) == FAILURE)
1180
            return FAILURE;
1181
 
1182
          continue;
1183
        }
1184
 
1185
      if (check_element_type (e, convert))
1186
        return FAILURE;
1187
    }
1188
 
1189
  return SUCCESS;
1190
}
1191
 
1192
 
1193
/* Check that all elements of an array constructor are the same type.
1194
   On FAILURE, an error has been generated.  */
1195
 
1196
gfc_try
1197
gfc_check_constructor_type (gfc_expr *e)
1198
{
1199
  gfc_try t;
1200
 
1201
  if (e->ts.type != BT_UNKNOWN)
1202
    {
1203
      cons_state = CONS_GOOD;
1204
      constructor_ts = e->ts;
1205
    }
1206
  else
1207
    {
1208
      cons_state = CONS_START;
1209
      gfc_clear_ts (&constructor_ts);
1210
    }
1211
 
1212
  /* If e->ts.type != BT_UNKNOWN, the array constructor included a
1213
     typespec, and we will now convert the values on the fly.  */
1214
  t = check_constructor_type (e->value.constructor, e->ts.type != BT_UNKNOWN);
1215
  if (t == SUCCESS && e->ts.type == BT_UNKNOWN)
1216
    e->ts = constructor_ts;
1217
 
1218
  return t;
1219
}
1220
 
1221
 
1222
 
1223
typedef struct cons_stack
1224
{
1225
  gfc_iterator *iterator;
1226
  struct cons_stack *previous;
1227
}
1228
cons_stack;
1229
 
1230
static cons_stack *base;
1231
 
1232
static gfc_try check_constructor (gfc_constructor_base, gfc_try (*) (gfc_expr *));
1233
 
1234
/* Check an EXPR_VARIABLE expression in a constructor to make sure
1235
   that that variable is an iteration variables.  */
1236
 
1237
gfc_try
1238
gfc_check_iter_variable (gfc_expr *expr)
1239
{
1240
  gfc_symbol *sym;
1241
  cons_stack *c;
1242
 
1243
  sym = expr->symtree->n.sym;
1244
 
1245
  for (c = base; c && c->iterator; c = c->previous)
1246
    if (sym == c->iterator->var->symtree->n.sym)
1247
      return SUCCESS;
1248
 
1249
  return FAILURE;
1250
}
1251
 
1252
 
1253
/* Recursive work function for gfc_check_constructor().  This amounts
1254
   to calling the check function for each expression in the
1255
   constructor, giving variables with the names of iterators a pass.  */
1256
 
1257
static gfc_try
1258
check_constructor (gfc_constructor_base ctor, gfc_try (*check_function) (gfc_expr *))
1259
{
1260
  cons_stack element;
1261
  gfc_expr *e;
1262
  gfc_try t;
1263
  gfc_constructor *c;
1264
 
1265
  for (c = gfc_constructor_first (ctor); c; c = gfc_constructor_next (c))
1266
    {
1267
      e = c->expr;
1268
 
1269
      if (e->expr_type != EXPR_ARRAY)
1270
        {
1271
          if ((*check_function) (e) == FAILURE)
1272
            return FAILURE;
1273
          continue;
1274
        }
1275
 
1276
      element.previous = base;
1277
      element.iterator = c->iterator;
1278
 
1279
      base = &element;
1280
      t = check_constructor (e->value.constructor, check_function);
1281
      base = element.previous;
1282
 
1283
      if (t == FAILURE)
1284
        return FAILURE;
1285
    }
1286
 
1287
  /* Nothing went wrong, so all OK.  */
1288
  return SUCCESS;
1289
}
1290
 
1291
 
1292
/* Checks a constructor to see if it is a particular kind of
1293
   expression -- specification, restricted, or initialization as
1294
   determined by the check_function.  */
1295
 
1296
gfc_try
1297
gfc_check_constructor (gfc_expr *expr, gfc_try (*check_function) (gfc_expr *))
1298
{
1299
  cons_stack *base_save;
1300
  gfc_try t;
1301
 
1302
  base_save = base;
1303
  base = NULL;
1304
 
1305
  t = check_constructor (expr->value.constructor, check_function);
1306
  base = base_save;
1307
 
1308
  return t;
1309
}
1310
 
1311
 
1312
 
1313
/**************** Simplification of array constructors ****************/
1314
 
1315
iterator_stack *iter_stack;
1316
 
1317
typedef struct
1318
{
1319
  gfc_constructor_base base;
1320
  int extract_count, extract_n;
1321
  gfc_expr *extracted;
1322
  mpz_t *count;
1323
 
1324
  mpz_t *offset;
1325
  gfc_component *component;
1326
  mpz_t *repeat;
1327
 
1328
  gfc_try (*expand_work_function) (gfc_expr *);
1329
}
1330
expand_info;
1331
 
1332
static expand_info current_expand;
1333
 
1334
static gfc_try expand_constructor (gfc_constructor_base);
1335
 
1336
 
1337
/* Work function that counts the number of elements present in a
1338
   constructor.  */
1339
 
1340
static gfc_try
1341
count_elements (gfc_expr *e)
1342
{
1343
  mpz_t result;
1344
 
1345
  if (e->rank == 0)
1346
    mpz_add_ui (*current_expand.count, *current_expand.count, 1);
1347
  else
1348
    {
1349
      if (gfc_array_size (e, &result) == FAILURE)
1350
        {
1351
          gfc_free_expr (e);
1352
          return FAILURE;
1353
        }
1354
 
1355
      mpz_add (*current_expand.count, *current_expand.count, result);
1356
      mpz_clear (result);
1357
    }
1358
 
1359
  gfc_free_expr (e);
1360
  return SUCCESS;
1361
}
1362
 
1363
 
1364
/* Work function that extracts a particular element from an array
1365
   constructor, freeing the rest.  */
1366
 
1367
static gfc_try
1368
extract_element (gfc_expr *e)
1369
{
1370
  if (e->rank != 0)
1371
    {                           /* Something unextractable */
1372
      gfc_free_expr (e);
1373
      return FAILURE;
1374
    }
1375
 
1376
  if (current_expand.extract_count == current_expand.extract_n)
1377
    current_expand.extracted = e;
1378
  else
1379
    gfc_free_expr (e);
1380
 
1381
  current_expand.extract_count++;
1382
 
1383
  return SUCCESS;
1384
}
1385
 
1386
 
1387
/* Work function that constructs a new constructor out of the old one,
1388
   stringing new elements together.  */
1389
 
1390
static gfc_try
1391
expand (gfc_expr *e)
1392
{
1393
  gfc_constructor *c = gfc_constructor_append_expr (&current_expand.base,
1394
                                                    e, &e->where);
1395
 
1396
  c->n.component = current_expand.component;
1397
  return SUCCESS;
1398
}
1399
 
1400
 
1401
/* Given an initialization expression that is a variable reference,
1402
   substitute the current value of the iteration variable.  */
1403
 
1404
void
1405
gfc_simplify_iterator_var (gfc_expr *e)
1406
{
1407
  iterator_stack *p;
1408
 
1409
  for (p = iter_stack; p; p = p->prev)
1410
    if (e->symtree == p->variable)
1411
      break;
1412
 
1413
  if (p == NULL)
1414
    return;             /* Variable not found */
1415
 
1416
  gfc_replace_expr (e, gfc_get_int_expr (gfc_default_integer_kind, NULL, 0));
1417
 
1418
  mpz_set (e->value.integer, p->value);
1419
 
1420
  return;
1421
}
1422
 
1423
 
1424
/* Expand an expression with that is inside of a constructor,
1425
   recursing into other constructors if present.  */
1426
 
1427
static gfc_try
1428
expand_expr (gfc_expr *e)
1429
{
1430
  if (e->expr_type == EXPR_ARRAY)
1431
    return expand_constructor (e->value.constructor);
1432
 
1433
  e = gfc_copy_expr (e);
1434
 
1435
  if (gfc_simplify_expr (e, 1) == FAILURE)
1436
    {
1437
      gfc_free_expr (e);
1438
      return FAILURE;
1439
    }
1440
 
1441
  return current_expand.expand_work_function (e);
1442
}
1443
 
1444
 
1445
static gfc_try
1446
expand_iterator (gfc_constructor *c)
1447
{
1448
  gfc_expr *start, *end, *step;
1449
  iterator_stack frame;
1450
  mpz_t trip;
1451
  gfc_try t;
1452
 
1453
  end = step = NULL;
1454
 
1455
  t = FAILURE;
1456
 
1457
  mpz_init (trip);
1458
  mpz_init (frame.value);
1459
  frame.prev = NULL;
1460
 
1461
  start = gfc_copy_expr (c->iterator->start);
1462
  if (gfc_simplify_expr (start, 1) == FAILURE)
1463
    goto cleanup;
1464
 
1465
  if (start->expr_type != EXPR_CONSTANT || start->ts.type != BT_INTEGER)
1466
    goto cleanup;
1467
 
1468
  end = gfc_copy_expr (c->iterator->end);
1469
  if (gfc_simplify_expr (end, 1) == FAILURE)
1470
    goto cleanup;
1471
 
1472
  if (end->expr_type != EXPR_CONSTANT || end->ts.type != BT_INTEGER)
1473
    goto cleanup;
1474
 
1475
  step = gfc_copy_expr (c->iterator->step);
1476
  if (gfc_simplify_expr (step, 1) == FAILURE)
1477
    goto cleanup;
1478
 
1479
  if (step->expr_type != EXPR_CONSTANT || step->ts.type != BT_INTEGER)
1480
    goto cleanup;
1481
 
1482
  if (mpz_sgn (step->value.integer) == 0)
1483
    {
1484
      gfc_error ("Iterator step at %L cannot be zero", &step->where);
1485
      goto cleanup;
1486
    }
1487
 
1488
  /* Calculate the trip count of the loop.  */
1489
  mpz_sub (trip, end->value.integer, start->value.integer);
1490
  mpz_add (trip, trip, step->value.integer);
1491
  mpz_tdiv_q (trip, trip, step->value.integer);
1492
 
1493
  mpz_set (frame.value, start->value.integer);
1494
 
1495
  frame.prev = iter_stack;
1496
  frame.variable = c->iterator->var->symtree;
1497
  iter_stack = &frame;
1498
 
1499
  while (mpz_sgn (trip) > 0)
1500
    {
1501
      if (expand_expr (c->expr) == FAILURE)
1502
        goto cleanup;
1503
 
1504
      mpz_add (frame.value, frame.value, step->value.integer);
1505
      mpz_sub_ui (trip, trip, 1);
1506
    }
1507
 
1508
  t = SUCCESS;
1509
 
1510
cleanup:
1511
  gfc_free_expr (start);
1512
  gfc_free_expr (end);
1513
  gfc_free_expr (step);
1514
 
1515
  mpz_clear (trip);
1516
  mpz_clear (frame.value);
1517
 
1518
  iter_stack = frame.prev;
1519
 
1520
  return t;
1521
}
1522
 
1523
 
1524
/* Expand a constructor into constant constructors without any
1525
   iterators, calling the work function for each of the expanded
1526
   expressions.  The work function needs to either save or free the
1527
   passed expression.  */
1528
 
1529
static gfc_try
1530
expand_constructor (gfc_constructor_base base)
1531
{
1532
  gfc_constructor *c;
1533
  gfc_expr *e;
1534
 
1535
  for (c = gfc_constructor_first (base); c; c = gfc_constructor_next(c))
1536
    {
1537
      if (c->iterator != NULL)
1538
        {
1539
          if (expand_iterator (c) == FAILURE)
1540
            return FAILURE;
1541
          continue;
1542
        }
1543
 
1544
      e = c->expr;
1545
 
1546
      if (e->expr_type == EXPR_ARRAY)
1547
        {
1548
          if (expand_constructor (e->value.constructor) == FAILURE)
1549
            return FAILURE;
1550
 
1551
          continue;
1552
        }
1553
 
1554
      e = gfc_copy_expr (e);
1555
      if (gfc_simplify_expr (e, 1) == FAILURE)
1556
        {
1557
          gfc_free_expr (e);
1558
          return FAILURE;
1559
        }
1560
      current_expand.offset = &c->offset;
1561
      current_expand.repeat = &c->repeat;
1562
      current_expand.component = c->n.component;
1563
      if (current_expand.expand_work_function (e) == FAILURE)
1564
        return FAILURE;
1565
    }
1566
  return SUCCESS;
1567
}
1568
 
1569
 
1570
/* Given an array expression and an element number (starting at zero),
1571
   return a pointer to the array element.  NULL is returned if the
1572
   size of the array has been exceeded.  The expression node returned
1573
   remains a part of the array and should not be freed.  Access is not
1574
   efficient at all, but this is another place where things do not
1575
   have to be particularly fast.  */
1576
 
1577
static gfc_expr *
1578
gfc_get_array_element (gfc_expr *array, int element)
1579
{
1580
  expand_info expand_save;
1581
  gfc_expr *e;
1582
  gfc_try rc;
1583
 
1584
  expand_save = current_expand;
1585
  current_expand.extract_n = element;
1586
  current_expand.expand_work_function = extract_element;
1587
  current_expand.extracted = NULL;
1588
  current_expand.extract_count = 0;
1589
 
1590
  iter_stack = NULL;
1591
 
1592
  rc = expand_constructor (array->value.constructor);
1593
  e = current_expand.extracted;
1594
  current_expand = expand_save;
1595
 
1596
  if (rc == FAILURE)
1597
    return NULL;
1598
 
1599
  return e;
1600
}
1601
 
1602
 
1603
/* Top level subroutine for expanding constructors.  We only expand
1604
   constructor if they are small enough.  */
1605
 
1606
gfc_try
1607
gfc_expand_constructor (gfc_expr *e, bool fatal)
1608
{
1609
  expand_info expand_save;
1610
  gfc_expr *f;
1611
  gfc_try rc;
1612
 
1613
  /* If we can successfully get an array element at the max array size then
1614
     the array is too big to expand, so we just return.  */
1615
  f = gfc_get_array_element (e, gfc_option.flag_max_array_constructor);
1616
  if (f != NULL)
1617
    {
1618
      gfc_free_expr (f);
1619
      if (fatal)
1620
        {
1621
          gfc_error ("The number of elements in the array constructor "
1622
                     "at %L requires an increase of the allowed %d "
1623
                     "upper limit.   See -fmax-array-constructor "
1624
                     "option", &e->where,
1625
                     gfc_option.flag_max_array_constructor);
1626
          return FAILURE;
1627
        }
1628
      return SUCCESS;
1629
    }
1630
 
1631
  /* We now know the array is not too big so go ahead and try to expand it.  */
1632
  expand_save = current_expand;
1633
  current_expand.base = NULL;
1634
 
1635
  iter_stack = NULL;
1636
 
1637
  current_expand.expand_work_function = expand;
1638
 
1639
  if (expand_constructor (e->value.constructor) == FAILURE)
1640
    {
1641
      gfc_constructor_free (current_expand.base);
1642
      rc = FAILURE;
1643
      goto done;
1644
    }
1645
 
1646
  gfc_constructor_free (e->value.constructor);
1647
  e->value.constructor = current_expand.base;
1648
 
1649
  rc = SUCCESS;
1650
 
1651
done:
1652
  current_expand = expand_save;
1653
 
1654
  return rc;
1655
}
1656
 
1657
 
1658
/* Work function for checking that an element of a constructor is a
1659
   constant, after removal of any iteration variables.  We return
1660
   FAILURE if not so.  */
1661
 
1662
static gfc_try
1663
is_constant_element (gfc_expr *e)
1664
{
1665
  int rv;
1666
 
1667
  rv = gfc_is_constant_expr (e);
1668
  gfc_free_expr (e);
1669
 
1670
  return rv ? SUCCESS : FAILURE;
1671
}
1672
 
1673
 
1674
/* Given an array constructor, determine if the constructor is
1675
   constant or not by expanding it and making sure that all elements
1676
   are constants.  This is a bit of a hack since something like (/ (i,
1677
   i=1,100000000) /) will take a while as* opposed to a more clever
1678
   function that traverses the expression tree. FIXME.  */
1679
 
1680
int
1681
gfc_constant_ac (gfc_expr *e)
1682
{
1683
  expand_info expand_save;
1684
  gfc_try rc;
1685
 
1686
  iter_stack = NULL;
1687
  expand_save = current_expand;
1688
  current_expand.expand_work_function = is_constant_element;
1689
 
1690
  rc = expand_constructor (e->value.constructor);
1691
 
1692
  current_expand = expand_save;
1693
  if (rc == FAILURE)
1694
    return 0;
1695
 
1696
  return 1;
1697
}
1698
 
1699
 
1700
/* Returns nonzero if an array constructor has been completely
1701
   expanded (no iterators) and zero if iterators are present.  */
1702
 
1703
int
1704
gfc_expanded_ac (gfc_expr *e)
1705
{
1706
  gfc_constructor *c;
1707
 
1708
  if (e->expr_type == EXPR_ARRAY)
1709
    for (c = gfc_constructor_first (e->value.constructor);
1710
         c; c = gfc_constructor_next (c))
1711
      if (c->iterator != NULL || !gfc_expanded_ac (c->expr))
1712
        return 0;
1713
 
1714
  return 1;
1715
}
1716
 
1717
 
1718
/*************** Type resolution of array constructors ***************/
1719
 
1720
/* Recursive array list resolution function.  All of the elements must
1721
   be of the same type.  */
1722
 
1723
static gfc_try
1724
resolve_array_list (gfc_constructor_base base)
1725
{
1726
  gfc_try t;
1727
  gfc_constructor *c;
1728
 
1729
  t = SUCCESS;
1730
 
1731
  for (c = gfc_constructor_first (base); c; c = gfc_constructor_next (c))
1732
    {
1733
      if (c->iterator != NULL
1734
          && gfc_resolve_iterator (c->iterator, false) == FAILURE)
1735
        t = FAILURE;
1736
 
1737
      if (gfc_resolve_expr (c->expr) == FAILURE)
1738
        t = FAILURE;
1739
    }
1740
 
1741
  return t;
1742
}
1743
 
1744
/* Resolve character array constructor. If it has a specified constant character
1745
   length, pad/truncate the elements here; if the length is not specified and
1746
   all elements are of compile-time known length, emit an error as this is
1747
   invalid.  */
1748
 
1749
gfc_try
1750
gfc_resolve_character_array_constructor (gfc_expr *expr)
1751
{
1752
  gfc_constructor *p;
1753
  int found_length;
1754
 
1755
  gcc_assert (expr->expr_type == EXPR_ARRAY);
1756
  gcc_assert (expr->ts.type == BT_CHARACTER);
1757
 
1758
  if (expr->ts.u.cl == NULL)
1759
    {
1760
      for (p = gfc_constructor_first (expr->value.constructor);
1761
           p; p = gfc_constructor_next (p))
1762
        if (p->expr->ts.u.cl != NULL)
1763
          {
1764
            /* Ensure that if there is a char_len around that it is
1765
               used; otherwise the middle-end confuses them!  */
1766
            expr->ts.u.cl = p->expr->ts.u.cl;
1767
            goto got_charlen;
1768
          }
1769
 
1770
      expr->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
1771
    }
1772
 
1773
got_charlen:
1774
 
1775
  found_length = -1;
1776
 
1777
  if (expr->ts.u.cl->length == NULL)
1778
    {
1779
      /* Check that all constant string elements have the same length until
1780
         we reach the end or find a variable-length one.  */
1781
 
1782
      for (p = gfc_constructor_first (expr->value.constructor);
1783
           p; p = gfc_constructor_next (p))
1784
        {
1785
          int current_length = -1;
1786
          gfc_ref *ref;
1787
          for (ref = p->expr->ref; ref; ref = ref->next)
1788
            if (ref->type == REF_SUBSTRING
1789
                && ref->u.ss.start->expr_type == EXPR_CONSTANT
1790
                && ref->u.ss.end->expr_type == EXPR_CONSTANT)
1791
              break;
1792
 
1793
          if (p->expr->expr_type == EXPR_CONSTANT)
1794
            current_length = p->expr->value.character.length;
1795
          else if (ref)
1796
            {
1797
              long j;
1798
              j = mpz_get_ui (ref->u.ss.end->value.integer)
1799
                - mpz_get_ui (ref->u.ss.start->value.integer) + 1;
1800
              current_length = (int) j;
1801
            }
1802
          else if (p->expr->ts.u.cl && p->expr->ts.u.cl->length
1803
                   && p->expr->ts.u.cl->length->expr_type == EXPR_CONSTANT)
1804
            {
1805
              long j;
1806
              j = mpz_get_si (p->expr->ts.u.cl->length->value.integer);
1807
              current_length = (int) j;
1808
            }
1809
          else
1810
            return SUCCESS;
1811
 
1812
          gcc_assert (current_length != -1);
1813
 
1814
          if (found_length == -1)
1815
            found_length = current_length;
1816
          else if (found_length != current_length)
1817
            {
1818
              gfc_error ("Different CHARACTER lengths (%d/%d) in array"
1819
                         " constructor at %L", found_length, current_length,
1820
                         &p->expr->where);
1821
              return FAILURE;
1822
            }
1823
 
1824
          gcc_assert (found_length == current_length);
1825
        }
1826
 
1827
      gcc_assert (found_length != -1);
1828
 
1829
      /* Update the character length of the array constructor.  */
1830
      expr->ts.u.cl->length = gfc_get_int_expr (gfc_default_integer_kind,
1831
                                                NULL, found_length);
1832
    }
1833
  else
1834
    {
1835
      /* We've got a character length specified.  It should be an integer,
1836
         otherwise an error is signalled elsewhere.  */
1837
      gcc_assert (expr->ts.u.cl->length);
1838
 
1839
      /* If we've got a constant character length, pad according to this.
1840
         gfc_extract_int does check for BT_INTEGER and EXPR_CONSTANT and sets
1841
         max_length only if they pass.  */
1842
      gfc_extract_int (expr->ts.u.cl->length, &found_length);
1843
 
1844
      /* Now pad/truncate the elements accordingly to the specified character
1845
         length.  This is ok inside this conditional, as in the case above
1846
         (without typespec) all elements are verified to have the same length
1847
         anyway.  */
1848
      if (found_length != -1)
1849
        for (p = gfc_constructor_first (expr->value.constructor);
1850
             p; p = gfc_constructor_next (p))
1851
          if (p->expr->expr_type == EXPR_CONSTANT)
1852
            {
1853
              gfc_expr *cl = NULL;
1854
              int current_length = -1;
1855
              bool has_ts;
1856
 
1857
              if (p->expr->ts.u.cl && p->expr->ts.u.cl->length)
1858
              {
1859
                cl = p->expr->ts.u.cl->length;
1860
                gfc_extract_int (cl, &current_length);
1861
              }
1862
 
1863
              /* If gfc_extract_int above set current_length, we implicitly
1864
                 know the type is BT_INTEGER and it's EXPR_CONSTANT.  */
1865
 
1866
              has_ts = (expr->ts.u.cl && expr->ts.u.cl->length_from_typespec);
1867
 
1868
              if (! cl
1869
                  || (current_length != -1 && current_length != found_length))
1870
                gfc_set_constant_character_len (found_length, p->expr,
1871
                                                has_ts ? -1 : found_length);
1872
            }
1873
    }
1874
 
1875
  return SUCCESS;
1876
}
1877
 
1878
 
1879
/* Resolve all of the expressions in an array list.  */
1880
 
1881
gfc_try
1882
gfc_resolve_array_constructor (gfc_expr *expr)
1883
{
1884
  gfc_try t;
1885
 
1886
  t = resolve_array_list (expr->value.constructor);
1887
  if (t == SUCCESS)
1888
    t = gfc_check_constructor_type (expr);
1889
 
1890
  /* gfc_resolve_character_array_constructor is called in gfc_resolve_expr after
1891
     the call to this function, so we don't need to call it here; if it was
1892
     called twice, an error message there would be duplicated.  */
1893
 
1894
  return t;
1895
}
1896
 
1897
 
1898
/* Copy an iterator structure.  */
1899
 
1900
gfc_iterator *
1901
gfc_copy_iterator (gfc_iterator *src)
1902
{
1903
  gfc_iterator *dest;
1904
 
1905
  if (src == NULL)
1906
    return NULL;
1907
 
1908
  dest = gfc_get_iterator ();
1909
 
1910
  dest->var = gfc_copy_expr (src->var);
1911
  dest->start = gfc_copy_expr (src->start);
1912
  dest->end = gfc_copy_expr (src->end);
1913
  dest->step = gfc_copy_expr (src->step);
1914
 
1915
  return dest;
1916
}
1917
 
1918
 
1919
/********* Subroutines for determining the size of an array *********/
1920
 
1921
/* These are needed just to accommodate RESHAPE().  There are no
1922
   diagnostics here, we just return a negative number if something
1923
   goes wrong.  */
1924
 
1925
 
1926
/* Get the size of single dimension of an array specification.  The
1927
   array is guaranteed to be one dimensional.  */
1928
 
1929
gfc_try
1930
spec_dimen_size (gfc_array_spec *as, int dimen, mpz_t *result)
1931
{
1932
  if (as == NULL)
1933
    return FAILURE;
1934
 
1935
  if (dimen < 0 || dimen > as->rank - 1)
1936
    gfc_internal_error ("spec_dimen_size(): Bad dimension");
1937
 
1938
  if (as->type != AS_EXPLICIT
1939
      || as->lower[dimen]->expr_type != EXPR_CONSTANT
1940
      || as->upper[dimen]->expr_type != EXPR_CONSTANT
1941
      || as->lower[dimen]->ts.type != BT_INTEGER
1942
      || as->upper[dimen]->ts.type != BT_INTEGER)
1943
    return FAILURE;
1944
 
1945
  mpz_init (*result);
1946
 
1947
  mpz_sub (*result, as->upper[dimen]->value.integer,
1948
           as->lower[dimen]->value.integer);
1949
 
1950
  mpz_add_ui (*result, *result, 1);
1951
 
1952
  return SUCCESS;
1953
}
1954
 
1955
 
1956
gfc_try
1957
spec_size (gfc_array_spec *as, mpz_t *result)
1958
{
1959
  mpz_t size;
1960
  int d;
1961
 
1962
  mpz_init_set_ui (*result, 1);
1963
 
1964
  for (d = 0; d < as->rank; d++)
1965
    {
1966
      if (spec_dimen_size (as, d, &size) == FAILURE)
1967
        {
1968
          mpz_clear (*result);
1969
          return FAILURE;
1970
        }
1971
 
1972
      mpz_mul (*result, *result, size);
1973
      mpz_clear (size);
1974
    }
1975
 
1976
  return SUCCESS;
1977
}
1978
 
1979
 
1980
/* Get the number of elements in an array section. Optionally, also supply
1981
   the end value.  */
1982
 
1983
gfc_try
1984
gfc_ref_dimen_size (gfc_array_ref *ar, int dimen, mpz_t *result, mpz_t *end)
1985
{
1986
  mpz_t upper, lower, stride;
1987
  gfc_try t;
1988
 
1989
  if (dimen < 0 || ar == NULL || dimen > ar->dimen - 1)
1990
    gfc_internal_error ("gfc_ref_dimen_size(): Bad dimension");
1991
 
1992
  switch (ar->dimen_type[dimen])
1993
    {
1994
    case DIMEN_ELEMENT:
1995
      mpz_init (*result);
1996
      mpz_set_ui (*result, 1);
1997
      t = SUCCESS;
1998
      break;
1999
 
2000
    case DIMEN_VECTOR:
2001
      t = gfc_array_size (ar->start[dimen], result);    /* Recurse! */
2002
      break;
2003
 
2004
    case DIMEN_RANGE:
2005
      mpz_init (upper);
2006
      mpz_init (lower);
2007
      mpz_init (stride);
2008
      t = FAILURE;
2009
 
2010
      if (ar->start[dimen] == NULL)
2011
        {
2012
          if (ar->as->lower[dimen] == NULL
2013
              || ar->as->lower[dimen]->expr_type != EXPR_CONSTANT)
2014
            goto cleanup;
2015
          mpz_set (lower, ar->as->lower[dimen]->value.integer);
2016
        }
2017
      else
2018
        {
2019
          if (ar->start[dimen]->expr_type != EXPR_CONSTANT)
2020
            goto cleanup;
2021
          mpz_set (lower, ar->start[dimen]->value.integer);
2022
        }
2023
 
2024
      if (ar->end[dimen] == NULL)
2025
        {
2026
          if (ar->as->upper[dimen] == NULL
2027
              || ar->as->upper[dimen]->expr_type != EXPR_CONSTANT)
2028
            goto cleanup;
2029
          mpz_set (upper, ar->as->upper[dimen]->value.integer);
2030
        }
2031
      else
2032
        {
2033
          if (ar->end[dimen]->expr_type != EXPR_CONSTANT)
2034
            goto cleanup;
2035
          mpz_set (upper, ar->end[dimen]->value.integer);
2036
        }
2037
 
2038
      if (ar->stride[dimen] == NULL)
2039
        mpz_set_ui (stride, 1);
2040
      else
2041
        {
2042
          if (ar->stride[dimen]->expr_type != EXPR_CONSTANT)
2043
            goto cleanup;
2044
          mpz_set (stride, ar->stride[dimen]->value.integer);
2045
        }
2046
 
2047
      mpz_init (*result);
2048
      mpz_sub (*result, upper, lower);
2049
      mpz_add (*result, *result, stride);
2050
      mpz_div (*result, *result, stride);
2051
 
2052
      /* Zero stride caught earlier.  */
2053
      if (mpz_cmp_ui (*result, 0) < 0)
2054
        mpz_set_ui (*result, 0);
2055
      t = SUCCESS;
2056
 
2057
      if (end)
2058
        {
2059
          mpz_init (*end);
2060
 
2061
          mpz_sub_ui (*end, *result, 1UL);
2062
          mpz_mul (*end, *end, stride);
2063
          mpz_add (*end, *end, lower);
2064
        }
2065
 
2066
    cleanup:
2067
      mpz_clear (upper);
2068
      mpz_clear (lower);
2069
      mpz_clear (stride);
2070
      return t;
2071
 
2072
    default:
2073
      gfc_internal_error ("gfc_ref_dimen_size(): Bad dimen_type");
2074
    }
2075
 
2076
  return t;
2077
}
2078
 
2079
 
2080
static gfc_try
2081
ref_size (gfc_array_ref *ar, mpz_t *result)
2082
{
2083
  mpz_t size;
2084
  int d;
2085
 
2086
  mpz_init_set_ui (*result, 1);
2087
 
2088
  for (d = 0; d < ar->dimen; d++)
2089
    {
2090
      if (gfc_ref_dimen_size (ar, d, &size, NULL) == FAILURE)
2091
        {
2092
          mpz_clear (*result);
2093
          return FAILURE;
2094
        }
2095
 
2096
      mpz_mul (*result, *result, size);
2097
      mpz_clear (size);
2098
    }
2099
 
2100
  return SUCCESS;
2101
}
2102
 
2103
 
2104
/* Given an array expression and a dimension, figure out how many
2105
   elements it has along that dimension.  Returns SUCCESS if we were
2106
   able to return a result in the 'result' variable, FAILURE
2107
   otherwise.  */
2108
 
2109
gfc_try
2110
gfc_array_dimen_size (gfc_expr *array, int dimen, mpz_t *result)
2111
{
2112
  gfc_ref *ref;
2113
  int i;
2114
 
2115
  if (array->ts.type == BT_CLASS)
2116
    return FAILURE;
2117
 
2118
  if (dimen < 0 || array == NULL || dimen > array->rank - 1)
2119
    gfc_internal_error ("gfc_array_dimen_size(): Bad dimension");
2120
 
2121
  switch (array->expr_type)
2122
    {
2123
    case EXPR_VARIABLE:
2124
    case EXPR_FUNCTION:
2125
      for (ref = array->ref; ref; ref = ref->next)
2126
        {
2127
          if (ref->type != REF_ARRAY)
2128
            continue;
2129
 
2130
          if (ref->u.ar.type == AR_FULL)
2131
            return spec_dimen_size (ref->u.ar.as, dimen, result);
2132
 
2133
          if (ref->u.ar.type == AR_SECTION)
2134
            {
2135
              for (i = 0; dimen >= 0; i++)
2136
                if (ref->u.ar.dimen_type[i] != DIMEN_ELEMENT)
2137
                  dimen--;
2138
 
2139
              return gfc_ref_dimen_size (&ref->u.ar, i - 1, result, NULL);
2140
            }
2141
        }
2142
 
2143
      if (array->shape && array->shape[dimen])
2144
        {
2145
          mpz_init_set (*result, array->shape[dimen]);
2146
          return SUCCESS;
2147
        }
2148
 
2149
      if (array->symtree->n.sym->attr.generic
2150
          && array->value.function.esym != NULL)
2151
        {
2152
          if (spec_dimen_size (array->value.function.esym->as, dimen, result)
2153
              == FAILURE)
2154
            return FAILURE;
2155
        }
2156
      else if (spec_dimen_size (array->symtree->n.sym->as, dimen, result)
2157
               == FAILURE)
2158
        return FAILURE;
2159
 
2160
      break;
2161
 
2162
    case EXPR_ARRAY:
2163
      if (array->shape == NULL) {
2164
        /* Expressions with rank > 1 should have "shape" properly set */
2165
        if ( array->rank != 1 )
2166
          gfc_internal_error ("gfc_array_dimen_size(): Bad EXPR_ARRAY expr");
2167
        return gfc_array_size(array, result);
2168
      }
2169
 
2170
      /* Fall through */
2171
    default:
2172
      if (array->shape == NULL)
2173
        return FAILURE;
2174
 
2175
      mpz_init_set (*result, array->shape[dimen]);
2176
 
2177
      break;
2178
    }
2179
 
2180
  return SUCCESS;
2181
}
2182
 
2183
 
2184
/* Given an array expression, figure out how many elements are in the
2185
   array.  Returns SUCCESS if this is possible, and sets the 'result'
2186
   variable.  Otherwise returns FAILURE.  */
2187
 
2188
gfc_try
2189
gfc_array_size (gfc_expr *array, mpz_t *result)
2190
{
2191
  expand_info expand_save;
2192
  gfc_ref *ref;
2193
  int i;
2194
  gfc_try t;
2195
 
2196
  if (array->ts.type == BT_CLASS)
2197
    return FAILURE;
2198
 
2199
  switch (array->expr_type)
2200
    {
2201
    case EXPR_ARRAY:
2202
      gfc_push_suppress_errors ();
2203
 
2204
      expand_save = current_expand;
2205
 
2206
      current_expand.count = result;
2207
      mpz_init_set_ui (*result, 0);
2208
 
2209
      current_expand.expand_work_function = count_elements;
2210
      iter_stack = NULL;
2211
 
2212
      t = expand_constructor (array->value.constructor);
2213
 
2214
      gfc_pop_suppress_errors ();
2215
 
2216
      if (t == FAILURE)
2217
        mpz_clear (*result);
2218
      current_expand = expand_save;
2219
      return t;
2220
 
2221
    case EXPR_VARIABLE:
2222
      for (ref = array->ref; ref; ref = ref->next)
2223
        {
2224
          if (ref->type != REF_ARRAY)
2225
            continue;
2226
 
2227
          if (ref->u.ar.type == AR_FULL)
2228
            return spec_size (ref->u.ar.as, result);
2229
 
2230
          if (ref->u.ar.type == AR_SECTION)
2231
            return ref_size (&ref->u.ar, result);
2232
        }
2233
 
2234
      return spec_size (array->symtree->n.sym->as, result);
2235
 
2236
 
2237
    default:
2238
      if (array->rank == 0 || array->shape == NULL)
2239
        return FAILURE;
2240
 
2241
      mpz_init_set_ui (*result, 1);
2242
 
2243
      for (i = 0; i < array->rank; i++)
2244
        mpz_mul (*result, *result, array->shape[i]);
2245
 
2246
      break;
2247
    }
2248
 
2249
  return SUCCESS;
2250
}
2251
 
2252
 
2253
/* Given an array reference, return the shape of the reference in an
2254
   array of mpz_t integers.  */
2255
 
2256
gfc_try
2257
gfc_array_ref_shape (gfc_array_ref *ar, mpz_t *shape)
2258
{
2259
  int d;
2260
  int i;
2261
 
2262
  d = 0;
2263
 
2264
  switch (ar->type)
2265
    {
2266
    case AR_FULL:
2267
      for (; d < ar->as->rank; d++)
2268
        if (spec_dimen_size (ar->as, d, &shape[d]) == FAILURE)
2269
          goto cleanup;
2270
 
2271
      return SUCCESS;
2272
 
2273
    case AR_SECTION:
2274
      for (i = 0; i < ar->dimen; i++)
2275
        {
2276
          if (ar->dimen_type[i] != DIMEN_ELEMENT)
2277
            {
2278
              if (gfc_ref_dimen_size (ar, i, &shape[d], NULL) == FAILURE)
2279
                goto cleanup;
2280
              d++;
2281
            }
2282
        }
2283
 
2284
      return SUCCESS;
2285
 
2286
    default:
2287
      break;
2288
    }
2289
 
2290
cleanup:
2291
  gfc_clear_shape (shape, d);
2292
  return FAILURE;
2293
}
2294
 
2295
 
2296
/* Given an array expression, find the array reference structure that
2297
   characterizes the reference.  */
2298
 
2299
gfc_array_ref *
2300
gfc_find_array_ref (gfc_expr *e)
2301
{
2302
  gfc_ref *ref;
2303
 
2304
  for (ref = e->ref; ref; ref = ref->next)
2305
    if (ref->type == REF_ARRAY
2306
        && (ref->u.ar.type == AR_FULL || ref->u.ar.type == AR_SECTION))
2307
      break;
2308
 
2309
  if (ref == NULL)
2310
    gfc_internal_error ("gfc_find_array_ref(): No ref found");
2311
 
2312
  return &ref->u.ar;
2313
}
2314
 
2315
 
2316
/* Find out if an array shape is known at compile time.  */
2317
 
2318
int
2319
gfc_is_compile_time_shape (gfc_array_spec *as)
2320
{
2321
  int i;
2322
 
2323
  if (as->type != AS_EXPLICIT)
2324
    return 0;
2325
 
2326
  for (i = 0; i < as->rank; i++)
2327
    if (!gfc_is_constant_expr (as->lower[i])
2328
        || !gfc_is_constant_expr (as->upper[i]))
2329
      return 0;
2330
 
2331
  return 1;
2332
}

powered by: WebSVN 2.1.0

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