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