gcc/fortran/array.c

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