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