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