gcc/fortran/array.c

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