gcc/fortran/array.c

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