gcc/fortran/array.c

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