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
 870   if (gfc_match (" (/") == MATCH_NO)
 871     return MATCH_NO;
 872
 873   where = gfc_current_locus;
 874   head = tail = NULL;
 875
 876   if (gfc_match (" /)") == MATCH_YES)
 877     goto empty;                 /* Special case */
 878
 879   for (;;)
 880     {
 881       m = match_array_cons_element (&new);
 882       if (m == MATCH_ERROR)
 883         goto cleanup;
 884       if (m == MATCH_NO)
 885         goto syntax;
 886
 887       if (head == NULL)
 888         head = new;
 889       else
 890         tail->next = new;
 891
 892       tail = new;
 893
 894       if (gfc_match_char (',') == MATCH_NO)
 895         break;
 896     }
 897
 898   if (gfc_match (" /)") == MATCH_NO)
 899     goto syntax;
 900
 901 empty:
 902   expr = gfc_get_expr ();
 903
 904   expr->expr_type = EXPR_ARRAY;
 905
 906   expr->value.constructor = head;
 907   /* Size must be calculated at resolution time.  */
 908
 909   expr->where = where;
 910   expr->rank = 1;
 911
 912   *result = expr;
 913   return MATCH_YES;
 914
 915 syntax:
 916   gfc_error ("Syntax error in array constructor at %C");
 917
 918 cleanup:
 919   gfc_free_constructor (head);
 920   return MATCH_ERROR;
 921 }
 922
 923
 924
 925 /************** Check array constructors for correctness **************/
 926
 927 /* Given an expression, compare it's type with the type of the current
 928    constructor.  Returns nonzero if an error was issued.  The
 929    cons_state variable keeps track of whether the type of the
 930    constructor being read or resolved is known to be good, bad or just
 931    starting out.  */
 932
 933 static gfc_typespec constructor_ts;
 934 static enum
 935 { CONS_START, CONS_GOOD, CONS_BAD }
 936 cons_state;
 937
 938 static int
 939 check_element_type (gfc_expr * expr)
 940 {
 941
 942   if (cons_state == CONS_BAD)
 943     return 0;                   /* Suppress further errors */
 944
 945   if (cons_state == CONS_START)
 946     {
 947       if (expr->ts.type == BT_UNKNOWN)
 948         cons_state = CONS_BAD;
 949       else
 950         {
 951           cons_state = CONS_GOOD;
 952           constructor_ts = expr->ts;
 953         }
 954
 955       return 0;
 956     }
 957
 958   if (gfc_compare_types (&constructor_ts, &expr->ts))
 959     return 0;
 960
 961   gfc_error ("Element in %s array constructor at %L is %s",
 962              gfc_typename (&constructor_ts), &expr->where,
 963              gfc_typename (&expr->ts));
 964
 965   cons_state = CONS_BAD;
 966   return 1;
 967 }
 968
 969
 970 /* Recursive work function for gfc_check_constructor_type().  */
 971
 972 static try
 973 check_constructor_type (gfc_constructor * c)
 974 {
 975   gfc_expr *e;
 976
 977   for (; c; c = c->next)
 978     {
 979       e = c->expr;
 980
 981       if (e->expr_type == EXPR_ARRAY)
 982         {
 983           if (check_constructor_type (e->value.constructor) == FAILURE)
 984             return FAILURE;
 985
 986           continue;
 987         }
 988
 989       if (check_element_type (e))
 990         return FAILURE;
 991     }
 992
 993   return SUCCESS;
 994 }
 995
 996
 997 /* Check that all elements of an array constructor are the same type.
 998    On FAILURE, an error has been generated.  */
 999
1000 try
1001 gfc_check_constructor_type (gfc_expr * e)
1002 {
1003   try t;
1004
1005   cons_state = CONS_START;
1006   gfc_clear_ts (&constructor_ts);
1007
1008   t = check_constructor_type (e->value.constructor);
1009   if (t == SUCCESS && e->ts.type == BT_UNKNOWN)
1010     e->ts = constructor_ts;
1011
1012   return t;
1013 }
1014
1015
1016
1017 typedef struct cons_stack
1018 {
1019   gfc_iterator *iterator;
1020   struct cons_stack *previous;
1021 }
1022 cons_stack;
1023
1024 static cons_stack *base;
1025
1026 static try check_constructor (gfc_constructor *, try (*)(gfc_expr *));
1027
1028 /* Check an EXPR_VARIABLE expression in a constructor to make sure
1029    that that variable is an iteration variables.  */
1030
1031 try
1032 gfc_check_iter_variable (gfc_expr * expr)
1033 {
1034
1035   gfc_symbol *sym;
1036   cons_stack *c;
1037
1038   sym = expr->symtree->n.sym;
1039
1040   for (c = base; c; c = c->previous)
1041     if (sym == c->iterator->var->symtree->n.sym)
1042       return SUCCESS;
1043
1044   return FAILURE;
1045 }
1046
1047
1048 /* Recursive work function for gfc_check_constructor().  This amounts
1049    to calling the check function for each expression in the
1050    constructor, giving variables with the names of iterators a pass.  */
1051
1052 static try
1053 check_constructor (gfc_constructor * c, try (*check_function) (gfc_expr *))
1054 {
1055   cons_stack element;
1056   gfc_expr *e;
1057   try t;
1058
1059   for (; c; c = c->next)
1060     {
1061       e = c->expr;
1062
1063       if (e->expr_type != EXPR_ARRAY)
1064         {
1065           if ((*check_function) (e) == FAILURE)
1066             return FAILURE;
1067           continue;
1068         }
1069
1070       element.previous = base;
1071       element.iterator = c->iterator;
1072
1073       base = &element;
1074       t = check_constructor (e->value.constructor, check_function);
1075       base = element.previous;
1076
1077       if (t == FAILURE)
1078         return FAILURE;
1079     }
1080
1081   /* Nothing went wrong, so all OK.  */
1082   return SUCCESS;
1083 }
1084
1085
1086 /* Checks a constructor to see if it is a particular kind of
1087    expression -- specification, restricted, or initialization as
1088    determined by the check_function.  */
1089
1090 try
1091 gfc_check_constructor (gfc_expr * expr, try (*check_function) (gfc_expr *))
1092 {
1093   cons_stack *base_save;
1094   try t;
1095
1096   base_save = base;
1097   base = NULL;
1098
1099   t = check_constructor (expr->value.constructor, check_function);
1100   base = base_save;
1101
1102   return t;
1103 }
1104
1105
1106
1107 /**************** Simplification of array constructors ****************/
1108
1109 iterator_stack *iter_stack;
1110
1111 typedef struct
1112 {
1113   gfc_constructor *new_head, *new_tail;
1114   int extract_count, extract_n;
1115   gfc_expr *extracted;
1116   mpz_t *count;
1117
1118   mpz_t *offset;
1119   gfc_component *component;
1120   mpz_t *repeat;
1121
1122   try (*expand_work_function) (gfc_expr *);
1123 }
1124 expand_info;
1125
1126 static expand_info current_expand;
1127
1128 static try expand_constructor (gfc_constructor *);
1129
1130
1131 /* Work function that counts the number of elements present in a
1132    constructor.  */
1133
1134 static try
1135 count_elements (gfc_expr * e)
1136 {
1137   mpz_t result;
1138
1139   if (e->rank == 0)
1140     mpz_add_ui (*current_expand.count, *current_expand.count, 1);
1141   else
1142     {
1143       if (gfc_array_size (e, &result) == FAILURE)
1144         {
1145           gfc_free_expr (e);
1146           return FAILURE;
1147         }
1148
1149       mpz_add (*current_expand.count, *current_expand.count, result);
1150       mpz_clear (result);
1151     }
1152
1153   gfc_free_expr (e);
1154   return SUCCESS;
1155 }
1156
1157
1158 /* Work function that extracts a particular element from an array
1159    constructor, freeing the rest.  */
1160
1161 static try
1162 extract_element (gfc_expr * e)
1163 {
1164
1165   if (e->rank != 0)
1166     {                           /* Something unextractable */
1167       gfc_free_expr (e);
1168       return FAILURE;
1169     }
1170
1171   if (current_expand.extract_count == current_expand.extract_n)
1172     current_expand.extracted = e;
1173   else
1174     gfc_free_expr (e);
1175
1176   current_expand.extract_count++;
1177   return SUCCESS;
1178 }
1179
1180
1181 /* Work function that constructs a new constructor out of the old one,
1182    stringing new elements together.  */
1183
1184 static try
1185 expand (gfc_expr * e)
1186 {
1187
1188   if (current_expand.new_head == NULL)
1189     current_expand.new_head = current_expand.new_tail =
1190       gfc_get_constructor ();
1191   else
1192     {
1193       current_expand.new_tail->next = gfc_get_constructor ();
1194       current_expand.new_tail = current_expand.new_tail->next;
1195     }
1196
1197   current_expand.new_tail->where = e->where;
1198   current_expand.new_tail->expr = e;
1199
1200   mpz_set (current_expand.new_tail->n.offset, *current_expand.offset);
1201   current_expand.new_tail->n.component = current_expand.component;
1202   mpz_set (current_expand.new_tail->repeat, *current_expand.repeat);
1203   return SUCCESS;
1204 }
1205
1206
1207 /* Given an initialization expression that is a variable reference,
1208    substitute the current value of the iteration variable.  */
1209
1210 void
1211 gfc_simplify_iterator_var (gfc_expr * e)
1212 {
1213   iterator_stack *p;
1214
1215   for (p = iter_stack; p; p = p->prev)
1216     if (e->symtree == p->variable)
1217       break;
1218
1219   if (p == NULL)
1220     return;             /* Variable not found */
1221
1222   gfc_replace_expr (e, gfc_int_expr (0));
1223
1224   mpz_set (e->value.integer, p->value);
1225
1226   return;
1227 }
1228
1229
1230 /* Expand an expression with that is inside of a constructor,
1231    recursing into other constructors if present.  */
1232
1233 static try
1234 expand_expr (gfc_expr * e)
1235 {
1236
1237   if (e->expr_type == EXPR_ARRAY)
1238     return expand_constructor (e->value.constructor);
1239
1240   e = gfc_copy_expr (e);
1241
1242   if (gfc_simplify_expr (e, 1) == FAILURE)
1243     {
1244       gfc_free_expr (e);
1245       return FAILURE;
1246     }
1247
1248   return current_expand.expand_work_function (e);
1249 }
1250
1251
1252 static try
1253 expand_iterator (gfc_constructor * c)
1254 {
1255   gfc_expr *start, *end, *step;
1256   iterator_stack frame;
1257   mpz_t trip;
1258   try t;
1259
1260   end = step = NULL;
1261
1262   t = FAILURE;
1263
1264   mpz_init (trip);
1265   mpz_init (frame.value);
1266
1267   start = gfc_copy_expr (c->iterator->start);
1268   if (gfc_simplify_expr (start, 1) == FAILURE)
1269     goto cleanup;
1270
1271   if (start->expr_type != EXPR_CONSTANT || start->ts.type != BT_INTEGER)
1272     goto cleanup;
1273
1274   end = gfc_copy_expr (c->iterator->end);
1275   if (gfc_simplify_expr (end, 1) == FAILURE)
1276     goto cleanup;
1277
1278   if (end->expr_type != EXPR_CONSTANT || end->ts.type != BT_INTEGER)
1279     goto cleanup;
1280
1281   step = gfc_copy_expr (c->iterator->step);
1282   if (gfc_simplify_expr (step, 1) == FAILURE)
1283     goto cleanup;
1284
1285   if (step->expr_type != EXPR_CONSTANT || step->ts.type != BT_INTEGER)
1286     goto cleanup;
1287
1288   if (mpz_sgn (step->value.integer) == 0)
1289     {
1290       gfc_error ("Iterator step at %L cannot be zero", &step->where);
1291       goto cleanup;
1292     }
1293
1294   /* Calculate the trip count of the loop.  */
1295   mpz_sub (trip, end->value.integer, start->value.integer);
1296   mpz_add (trip, trip, step->value.integer);
1297   mpz_tdiv_q (trip, trip, step->value.integer);
1298
1299   mpz_set (frame.value, start->value.integer);
1300
1301   frame.prev = iter_stack;
1302   frame.variable = c->iterator->var->symtree;
1303   iter_stack = &frame;
1304
1305   while (mpz_sgn (trip) > 0)
1306     {
1307       if (expand_expr (c->expr) == FAILURE)
1308         goto cleanup;
1309
1310       mpz_add (frame.value, frame.value, step->value.integer);
1311       mpz_sub_ui (trip, trip, 1);
1312     }
1313
1314   t = SUCCESS;
1315
1316 cleanup:
1317   gfc_free_expr (start);
1318   gfc_free_expr (end);
1319   gfc_free_expr (step);
1320
1321   mpz_clear (trip);
1322   mpz_clear (frame.value);
1323
1324   iter_stack = frame.prev;
1325
1326   return t;
1327 }
1328
1329
1330 /* Expand a constructor into constant constructors without any
1331    iterators, calling the work function for each of the expanded
1332    expressions.  The work function needs to either save or free the
1333    passed expression.  */
1334
1335 static try
1336 expand_constructor (gfc_constructor * c)
1337 {
1338   gfc_expr *e;
1339
1340   for (; c; c = c->next)
1341     {
1342       if (c->iterator != NULL)
1343         {
1344           if (expand_iterator (c) == FAILURE)
1345             return FAILURE;
1346           continue;
1347         }
1348
1349       e = c->expr;
1350
1351       if (e->expr_type == EXPR_ARRAY)
1352         {
1353           if (expand_constructor (e->value.constructor) == FAILURE)
1354             return FAILURE;
1355
1356           continue;
1357         }
1358
1359       e = gfc_copy_expr (e);
1360       if (gfc_simplify_expr (e, 1) == FAILURE)
1361         {
1362           gfc_free_expr (e);
1363           return FAILURE;
1364         }
1365       current_expand.offset = &c->n.offset;
1366       current_expand.component = c->n.component;
1367       current_expand.repeat = &c->repeat;
1368       if (current_expand.expand_work_function (e) == FAILURE)
1369         return FAILURE;
1370     }
1371   return SUCCESS;
1372 }
1373
1374
1375 /* Top level subroutine for expanding constructors.  We only expand
1376    constructor if they are small enough.  */
1377
1378 try
1379 gfc_expand_constructor (gfc_expr * e)
1380 {
1381   expand_info expand_save;
1382   gfc_expr *f;
1383   try rc;
1384
1385   f = gfc_get_array_element (e, GFC_MAX_AC_EXPAND);
1386   if (f != NULL)
1387     {
1388       gfc_free_expr (f);
1389       return SUCCESS;
1390     }
1391
1392   expand_save = current_expand;
1393   current_expand.new_head = current_expand.new_tail = NULL;
1394
1395   iter_stack = NULL;
1396
1397   current_expand.expand_work_function = expand;
1398
1399   if (expand_constructor (e->value.constructor) == FAILURE)
1400     {
1401       gfc_free_constructor (current_expand.new_head);
1402       rc = FAILURE;
1403       goto done;
1404     }
1405
1406   gfc_free_constructor (e->value.constructor);
1407   e->value.constructor = current_expand.new_head;
1408
1409   rc = SUCCESS;
1410
1411 done:
1412   current_expand = expand_save;
1413
1414   return rc;
1415 }
1416
1417
1418 /* Work function for checking that an element of a constructor is a
1419    constant, after removal of any iteration variables.  We return
1420    FAILURE if not so.  */
1421
1422 static try
1423 constant_element (gfc_expr * e)
1424 {
1425   int rv;
1426
1427   rv = gfc_is_constant_expr (e);
1428   gfc_free_expr (e);
1429
1430   return rv ? SUCCESS : FAILURE;
1431 }
1432
1433
1434 /* Given an array constructor, determine if the constructor is
1435    constant or not by expanding it and making sure that all elements
1436    are constants.  This is a bit of a hack since something like (/ (i,
1437    i=1,100000000) /) will take a while as* opposed to a more clever
1438    function that traverses the expression tree. FIXME.  */
1439
1440 int
1441 gfc_constant_ac (gfc_expr * e)
1442 {
1443   expand_info expand_save;
1444   try rc;
1445
1446   iter_stack = NULL;
1447   expand_save = current_expand;
1448   current_expand.expand_work_function = constant_element;
1449
1450   rc = expand_constructor (e->value.constructor);
1451
1452   current_expand = expand_save;
1453   if (rc == FAILURE)
1454     return 0;
1455
1456   return 1;
1457 }
1458
1459
1460 /* Returns nonzero if an array constructor has been completely
1461    expanded (no iterators) and zero if iterators are present.  */
1462
1463 int
1464 gfc_expanded_ac (gfc_expr * e)
1465 {
1466   gfc_constructor *p;
1467
1468   if (e->expr_type == EXPR_ARRAY)
1469     for (p = e->value.constructor; p; p = p->next)
1470       if (p->iterator != NULL || !gfc_expanded_ac (p->expr))
1471         return 0;
1472
1473   return 1;
1474 }
1475
1476
1477 /*************** Type resolution of array constructors ***************/
1478
1479 /* Recursive array list resolution function.  All of the elements must
1480    be of the same type.  */
1481
1482 static try
1483 resolve_array_list (gfc_constructor * p)
1484 {
1485   try t;
1486
1487   t = SUCCESS;
1488
1489   for (; p; p = p->next)
1490     {
1491       if (p->iterator != NULL
1492           && gfc_resolve_iterator (p->iterator, false) == FAILURE)
1493         t = FAILURE;
1494
1495       if (gfc_resolve_expr (p->expr) == FAILURE)
1496         t = FAILURE;
1497     }
1498
1499   return t;
1500 }
1501
1502 /* Resolve character array constructor. If it is a constant character array and
1503    not specified character length, update character length to the maximum of
1504    its element constructors' length.  */
1505
1506 static void
1507 resolve_character_array_constructor (gfc_expr * expr)
1508 {
1509   gfc_constructor * p;
1510   int max_length;
1511
1512   gcc_assert (expr->expr_type == EXPR_ARRAY);
1513   gcc_assert (expr->ts.type == BT_CHARACTER);
1514
1515   max_length = -1;
1516
1517   if (expr->ts.cl == NULL || expr->ts.cl->length == NULL)
1518     {
1519       /* Find the maximum length of the elements. Do nothing for variable array
1520          constructor.  */
1521       for (p = expr->value.constructor; p; p = p->next)
1522         if (p->expr->expr_type == EXPR_CONSTANT)
1523           max_length = MAX (p->expr->value.character.length, max_length);
1524         else
1525           return;
1526
1527       if (max_length != -1)
1528         {
1529           /* Update the character length of the array constructor.  */
1530           if (expr->ts.cl == NULL)
1531             expr->ts.cl = gfc_get_charlen ();
1532           expr->ts.cl->length = gfc_int_expr (max_length);
1533           /* Update the element constructors.  */
1534           for (p = expr->value.constructor; p; p = p->next)
1535             gfc_set_constant_character_len (max_length, p->expr);
1536         }
1537     }
1538 }
1539
1540 /* Resolve all of the expressions in an array list.  */
1541
1542 try
1543 gfc_resolve_array_constructor (gfc_expr * expr)
1544 {
1545   try t;
1546
1547   t = resolve_array_list (expr->value.constructor);
1548   if (t == SUCCESS)
1549     t = gfc_check_constructor_type (expr);
1550   if (t == SUCCESS && expr->ts.type == BT_CHARACTER)
1551     resolve_character_array_constructor (expr);
1552
1553   return t;
1554 }
1555
1556
1557 /* Copy an iterator structure.  */
1558
1559 static gfc_iterator *
1560 copy_iterator (gfc_iterator * src)
1561 {
1562   gfc_iterator *dest;
1563
1564   if (src == NULL)
1565     return NULL;
1566
1567   dest = gfc_get_iterator ();
1568
1569   dest->var = gfc_copy_expr (src->var);
1570   dest->start = gfc_copy_expr (src->start);
1571   dest->end = gfc_copy_expr (src->end);
1572   dest->step = gfc_copy_expr (src->step);
1573
1574   return dest;
1575 }
1576
1577
1578 /* Copy a constructor structure.  */
1579
1580 gfc_constructor *
1581 gfc_copy_constructor (gfc_constructor * src)
1582 {
1583   gfc_constructor *dest;
1584   gfc_constructor *tail;
1585
1586   if (src == NULL)
1587     return NULL;
1588
1589   dest = tail = NULL;
1590   while (src)
1591     {
1592       if (dest == NULL)
1593         dest = tail = gfc_get_constructor ();
1594       else
1595         {
1596           tail->next = gfc_get_constructor ();
1597           tail = tail->next;
1598         }
1599       tail->where = src->where;
1600       tail->expr = gfc_copy_expr (src->expr);
1601       tail->iterator = copy_iterator (src->iterator);
1602       mpz_set (tail->n.offset, src->n.offset);
1603       tail->n.component = src->n.component;
1604       mpz_set (tail->repeat, src->repeat);
1605       src = src->next;
1606     }
1607
1608   return dest;
1609 }
1610
1611
1612 /* Given an array expression and an element number (starting at zero),
1613    return a pointer to the array element.  NULL is returned if the
1614    size of the array has been exceeded.  The expression node returned
1615    remains a part of the array and should not be freed.  Access is not
1616    efficient at all, but this is another place where things do not
1617    have to be particularly fast.  */
1618
1619 gfc_expr *
1620 gfc_get_array_element (gfc_expr * array, int element)
1621 {
1622   expand_info expand_save;
1623   gfc_expr *e;
1624   try rc;
1625
1626   expand_save = current_expand;
1627   current_expand.extract_n = element;
1628   current_expand.expand_work_function = extract_element;
1629   current_expand.extracted = NULL;
1630   current_expand.extract_count = 0;
1631
1632   iter_stack = NULL;
1633
1634   rc = expand_constructor (array->value.constructor);
1635   e = current_expand.extracted;
1636   current_expand = expand_save;
1637
1638   if (rc == FAILURE)
1639     return NULL;
1640
1641   return e;
1642 }
1643
1644
1645 /********* Subroutines for determining the size of an array *********/
1646
1647 /* These are needed just to accommodate RESHAPE().  There are no
1648    diagnostics here, we just return a negative number if something
1649    goes wrong.  */
1650
1651
1652 /* Get the size of single dimension of an array specification.  The
1653    array is guaranteed to be one dimensional.  */
1654
1655 static try
1656 spec_dimen_size (gfc_array_spec * as, int dimen, mpz_t * result)
1657 {
1658
1659   if (as == NULL)
1660     return FAILURE;
1661
1662   if (dimen < 0 || dimen > as->rank - 1)
1663     gfc_internal_error ("spec_dimen_size(): Bad dimension");
1664
1665   if (as->type != AS_EXPLICIT
1666       || as->lower[dimen]->expr_type != EXPR_CONSTANT
1667       || as->upper[dimen]->expr_type != EXPR_CONSTANT)
1668     return FAILURE;
1669
1670   mpz_init (*result);
1671
1672   mpz_sub (*result, as->upper[dimen]->value.integer,
1673            as->lower[dimen]->value.integer);
1674
1675   mpz_add_ui (*result, *result, 1);
1676
1677   return SUCCESS;
1678 }
1679
1680
1681 try
1682 spec_size (gfc_array_spec * as, mpz_t * result)
1683 {
1684   mpz_t size;
1685   int d;
1686
1687   mpz_init_set_ui (*result, 1);
1688
1689   for (d = 0; d < as->rank; d++)
1690     {
1691       if (spec_dimen_size (as, d, &size) == FAILURE)
1692         {
1693           mpz_clear (*result);
1694           return FAILURE;
1695         }
1696
1697       mpz_mul (*result, *result, size);
1698       mpz_clear (size);
1699     }
1700
1701   return SUCCESS;
1702 }
1703
1704
1705 /* Get the number of elements in an array section.  */
1706
1707 static try
1708 ref_dimen_size (gfc_array_ref * ar, int dimen, mpz_t * result)
1709 {
1710   mpz_t upper, lower, stride;
1711   try t;
1712
1713   if (dimen < 0 || ar == NULL || dimen > ar->dimen - 1)
1714     gfc_internal_error ("ref_dimen_size(): Bad dimension");
1715
1716   switch (ar->dimen_type[dimen])
1717     {
1718     case DIMEN_ELEMENT:
1719       mpz_init (*result);
1720       mpz_set_ui (*result, 1);
1721       t = SUCCESS;
1722       break;
1723
1724     case DIMEN_VECTOR:
1725       t = gfc_array_size (ar->start[dimen], result);    /* Recurse! */
1726       break;
1727
1728     case DIMEN_RANGE:
1729       mpz_init (upper);
1730       mpz_init (lower);
1731       mpz_init (stride);
1732       t = FAILURE;
1733
1734       if (ar->start[dimen] == NULL)
1735         {
1736           if (ar->as->lower[dimen] == NULL
1737               || ar->as->lower[dimen]->expr_type != EXPR_CONSTANT)
1738             goto cleanup;
1739           mpz_set (lower, ar->as->lower[dimen]->value.integer);
1740         }
1741       else
1742         {
1743           if (ar->start[dimen]->expr_type != EXPR_CONSTANT)
1744             goto cleanup;
1745           mpz_set (lower, ar->start[dimen]->value.integer);
1746         }
1747
1748       if (ar->end[dimen] == NULL)
1749         {
1750           if (ar->as->upper[dimen] == NULL
1751               || ar->as->upper[dimen]->expr_type != EXPR_CONSTANT)
1752             goto cleanup;
1753           mpz_set (upper, ar->as->upper[dimen]->value.integer);
1754         }
1755       else
1756         {
1757           if (ar->end[dimen]->expr_type != EXPR_CONSTANT)
1758             goto cleanup;
1759           mpz_set (upper, ar->end[dimen]->value.integer);
1760         }
1761
1762       if (ar->stride[dimen] == NULL)
1763         mpz_set_ui (stride, 1);
1764       else
1765         {
1766           if (ar->stride[dimen]->expr_type != EXPR_CONSTANT)
1767             goto cleanup;
1768           mpz_set (stride, ar->stride[dimen]->value.integer);
1769         }
1770
1771       mpz_init (*result);
1772       mpz_sub (*result, upper, lower);
1773       mpz_add (*result, *result, stride);
1774       mpz_div (*result, *result, stride);
1775
1776       /* Zero stride caught earlier.  */
1777       if (mpz_cmp_ui (*result, 0) < 0)
1778         mpz_set_ui (*result, 0);
1779       t = SUCCESS;
1780
1781     cleanup:
1782       mpz_clear (upper);
1783       mpz_clear (lower);
1784       mpz_clear (stride);
1785       return t;
1786
1787     default:
1788       gfc_internal_error ("ref_dimen_size(): Bad dimen_type");
1789     }
1790
1791   return t;
1792 }
1793
1794
1795 static try
1796 ref_size (gfc_array_ref * ar, mpz_t * result)
1797 {
1798   mpz_t size;
1799   int d;
1800
1801   mpz_init_set_ui (*result, 1);
1802
1803   for (d = 0; d < ar->dimen; d++)
1804     {
1805       if (ref_dimen_size (ar, d, &size) == FAILURE)
1806         {
1807           mpz_clear (*result);
1808           return FAILURE;
1809         }
1810
1811       mpz_mul (*result, *result, size);
1812       mpz_clear (size);
1813     }
1814
1815   return SUCCESS;
1816 }
1817
1818
1819 /* Given an array expression and a dimension, figure out how many
1820    elements it has along that dimension.  Returns SUCCESS if we were
1821    able to return a result in the 'result' variable, FAILURE
1822    otherwise.  */
1823
1824 try
1825 gfc_array_dimen_size (gfc_expr * array, int dimen, mpz_t * result)
1826 {
1827   gfc_ref *ref;
1828   int i;
1829
1830   if (dimen < 0 || array == NULL || dimen > array->rank - 1)
1831     gfc_internal_error ("gfc_array_dimen_size(): Bad dimension");
1832
1833   switch (array->expr_type)
1834     {
1835     case EXPR_VARIABLE:
1836     case EXPR_FUNCTION:
1837       for (ref = array->ref; ref; ref = ref->next)
1838         {
1839           if (ref->type != REF_ARRAY)
1840             continue;
1841
1842           if (ref->u.ar.type == AR_FULL)
1843             return spec_dimen_size (ref->u.ar.as, dimen, result);
1844
1845           if (ref->u.ar.type == AR_SECTION)
1846             {
1847               for (i = 0; dimen >= 0; i++)
1848                 if (ref->u.ar.dimen_type[i] != DIMEN_ELEMENT)
1849                   dimen--;
1850
1851               return ref_dimen_size (&ref->u.ar, i - 1, result);
1852             }
1853         }
1854
1855       if (spec_dimen_size (array->symtree->n.sym->as, dimen, result) == FAILURE)
1856         return FAILURE;
1857
1858       break;
1859
1860     case EXPR_ARRAY:
1861       if (array->shape == NULL) {
1862         /* Expressions with rank > 1 should have "shape" properly set */
1863         if ( array->rank != 1 )
1864           gfc_internal_error ("gfc_array_dimen_size(): Bad EXPR_ARRAY expr");
1865         return gfc_array_size(array, result);
1866       }
1867
1868       /* Fall through */
1869     default:
1870       if (array->shape == NULL)
1871         return FAILURE;
1872
1873       mpz_init_set (*result, array->shape[dimen]);
1874
1875       break;
1876     }
1877
1878   return SUCCESS;
1879 }
1880
1881
1882 /* Given an array expression, figure out how many elements are in the
1883    array.  Returns SUCCESS if this is possible, and sets the 'result'
1884    variable.  Otherwise returns FAILURE.  */
1885
1886 try
1887 gfc_array_size (gfc_expr * array, mpz_t * result)
1888 {
1889   expand_info expand_save;
1890   gfc_ref *ref;
1891   int i, flag;
1892   try t;
1893
1894   switch (array->expr_type)
1895     {
1896     case EXPR_ARRAY:
1897       flag = gfc_suppress_error;
1898       gfc_suppress_error = 1;
1899
1900       expand_save = current_expand;
1901
1902       current_expand.count = result;
1903       mpz_init_set_ui (*result, 0);
1904
1905       current_expand.expand_work_function = count_elements;
1906       iter_stack = NULL;
1907
1908       t = expand_constructor (array->value.constructor);
1909       gfc_suppress_error = flag;
1910
1911       if (t == FAILURE)
1912         mpz_clear (*result);
1913       current_expand = expand_save;
1914       return t;
1915
1916     case EXPR_VARIABLE:
1917       for (ref = array->ref; ref; ref = ref->next)
1918         {
1919           if (ref->type != REF_ARRAY)
1920             continue;
1921
1922           if (ref->u.ar.type == AR_FULL)
1923             return spec_size (ref->u.ar.as, result);
1924
1925           if (ref->u.ar.type == AR_SECTION)
1926             return ref_size (&ref->u.ar, result);
1927         }
1928
1929       return spec_size (array->symtree->n.sym->as, result);
1930
1931
1932     default:
1933       if (array->rank == 0 || array->shape == NULL)
1934         return FAILURE;
1935
1936       mpz_init_set_ui (*result, 1);
1937
1938       for (i = 0; i < array->rank; i++)
1939         mpz_mul (*result, *result, array->shape[i]);
1940
1941       break;
1942     }
1943
1944   return SUCCESS;
1945 }
1946
1947
1948 /* Given an array reference, return the shape of the reference in an
1949    array of mpz_t integers.  */
1950
1951 try
1952 gfc_array_ref_shape (gfc_array_ref * ar, mpz_t * shape)
1953 {
1954   int d;
1955   int i;
1956
1957   d = 0;
1958
1959   switch (ar->type)
1960     {
1961     case AR_FULL:
1962       for (; d < ar->as->rank; d++)
1963         if (spec_dimen_size (ar->as, d, &shape[d]) == FAILURE)
1964           goto cleanup;
1965
1966       return SUCCESS;
1967
1968     case AR_SECTION:
1969       for (i = 0; i < ar->dimen; i++)
1970         {
1971           if (ar->dimen_type[i] != DIMEN_ELEMENT)
1972             {
1973               if (ref_dimen_size (ar, i, &shape[d]) == FAILURE)
1974                 goto cleanup;
1975               d++;
1976             }
1977         }
1978
1979       return SUCCESS;
1980
1981     default:
1982       break;
1983     }
1984
1985 cleanup:
1986   for (d--; d >= 0; d--)
1987     mpz_clear (shape[d]);
1988
1989   return FAILURE;
1990 }
1991
1992
1993 /* Given an array expression, find the array reference structure that
1994    characterizes the reference.  */
1995
1996 gfc_array_ref *
1997 gfc_find_array_ref (gfc_expr * e)
1998 {
1999   gfc_ref *ref;
2000
2001   for (ref = e->ref; ref; ref = ref->next)
2002     if (ref->type == REF_ARRAY
2003         && (ref->u.ar.type == AR_FULL
2004             || ref->u.ar.type == AR_SECTION))
2005       break;
2006
2007   if (ref == NULL)
2008     gfc_internal_error ("gfc_find_array_ref(): No ref found");
2009
2010   return &ref->u.ar;
2011 }
2012
2013
2014 /* Find out if an array shape is known at compile time.  */
2015
2016 int
2017 gfc_is_compile_time_shape (gfc_array_spec *as)
2018 {
2019   int i;
2020
2021   if (as->type != AS_EXPLICIT)
2022     return 0;
2023
2024   for (i = 0; i < as->rank; i++)
2025     if (!gfc_is_constant_expr (as->lower[i])
2026         || !gfc_is_constant_expr (as->upper[i]))
2027       return 0;
2028
2029   return 1;
2030 }