gcc/fortran/array.c

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