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