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 2, 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 COPYING.  If not, write to the Free
  20 Software Foundation, 51 Franklin Street, Fifth Floor, Boston, MA
  21 02110-1301, USA.  */
  22
  23 #include "config.h"
  24 #include "system.h"
  25 #include "gfortran.h"
  26 #include "match.h"
  27
  28 /* This parameter is the size of the largest array constructor that we
  29    will expand to an array constructor without iterators.
  30    Constructors larger than this will remain in the iterator form.  */
  31
  32 #define GFC_MAX_AC_EXPAND 65535
  33
  34
  35 /**************** Array reference matching subroutines *****************/
  36
  37 /* Copy an array reference structure.  */
  38
  39 gfc_array_ref *
  40 gfc_copy_array_ref (gfc_array_ref *src)
  41 {
  42   gfc_array_ref *dest;
  43   int i;
  44
  45   if (src == NULL)
  46     return NULL;
  47
  48   dest = gfc_get_array_ref ();
  49
  50   *dest = *src;
  51
  52   for (i = 0; i < GFC_MAX_DIMENSIONS; i++)
  53     {
  54       dest->start[i] = gfc_copy_expr (src->start[i]);
  55       dest->end[i] = gfc_copy_expr (src->end[i]);
  56       dest->stride[i] = gfc_copy_expr (src->stride[i]);
  57     }
  58
  59   dest->offset = gfc_copy_expr (src->offset);
  60
  61   return dest;
  62 }
  63
  64
  65 /* Match a single dimension of an array reference.  This can be a
  66    single element or an array section.  Any modifications we've made
  67    to the ar structure are cleaned up by the caller.  If the init
  68    is set, we require the subscript to be a valid initialization
  69    expression.  */
  70
  71 static match
  72 match_subscript (gfc_array_ref *ar, int init)
  73 {
  74   match m;
  75   int i;
  76
  77   i = ar->dimen;
  78
  79   ar->c_where[i] = gfc_current_locus;
  80   ar->start[i] = ar->end[i] = ar->stride[i] = NULL;
  81
  82   /* We can't be sure of the difference between DIMEN_ELEMENT and
  83      DIMEN_VECTOR until we know the type of the element itself at
  84      resolution time.  */
  85
  86   ar->dimen_type[i] = DIMEN_UNKNOWN;
  87
  88   if (gfc_match_char (':') == MATCH_YES)
  89     goto end_element;
  90
  91   /* Get start element.  */
  92   if (init)
  93     m = gfc_match_init_expr (&ar->start[i]);
  94   else
  95     m = gfc_match_expr (&ar->start[i]);
  96
  97   if (m == MATCH_NO)
  98     gfc_error ("Expected array subscript at %C");
  99   if (m != MATCH_YES)
 100     return MATCH_ERROR;
 101
 102   if (gfc_match_char (':') == MATCH_NO)
 103     return MATCH_YES;
 104
 105   /* Get an optional end element.  Because we've seen the colon, we
 106      definitely have a range along this dimension.  */
 107 end_element:
 108   ar->dimen_type[i] = DIMEN_RANGE;
 109
 110   if (init)
 111     m = gfc_match_init_expr (&ar->end[i]);
 112   else
 113     m = gfc_match_expr (&ar->end[i]);
 114
 115   if (m == MATCH_ERROR)
 116     return MATCH_ERROR;
 117
 118   /* See if we have an optional stride.  */
 119   if (gfc_match_char (':') == MATCH_YES)
 120     {
 121       m = init ? gfc_match_init_expr (&ar->stride[i])
 122                : gfc_match_expr (&ar->stride[i]);
 123
 124       if (m == MATCH_NO)
 125         gfc_error ("Expected array subscript stride at %C");
 126       if (m != MATCH_YES)
 127         return MATCH_ERROR;
 128     }
 129
 130   return MATCH_YES;
 131 }
 132
 133
 134 /* Match an array reference, whether it is the whole array or a
 135    particular elements or a section. If init is set, the reference has
 136    to consist of init expressions.  */
 137
 138 match
 139 gfc_match_array_ref (gfc_array_ref *ar, gfc_array_spec *as, int init)
 140 {
 141   match m;
 142
 143   memset (ar, '\0', sizeof (ar));
 144
 145   ar->where = gfc_current_locus;
 146   ar->as = as;
 147
 148   if (gfc_match_char ('(') != MATCH_YES)
 149     {
 150       ar->type = AR_FULL;
 151       ar->dimen = 0;
 152       return MATCH_YES;
 153     }
 154
 155   ar->type = AR_UNKNOWN;
 156
 157   for (ar->dimen = 0; ar->dimen < GFC_MAX_DIMENSIONS; ar->dimen++)
 158     {
 159       m = match_subscript (ar, init);
 160       if (m == MATCH_ERROR)
 161         goto error;
 162
 163       if (gfc_match_char (')') == MATCH_YES)
 164         goto matched;
 165
 166       if (gfc_match_char (',') != MATCH_YES)
 167         {
 168           gfc_error ("Invalid form of array reference at %C");
 169           goto error;
 170         }
 171     }
 172
 173   gfc_error ("Array reference at %C cannot have more than %d dimensions",
 174              GFC_MAX_DIMENSIONS);
 175
 176 error:
 177   return MATCH_ERROR;
 178
 179 matched:
 180   ar->dimen++;
 181
 182   return MATCH_YES;
 183 }
 184
 185
 186 /************** Array specification matching subroutines ***************/
 187
 188 /* Free all of the expressions associated with array bounds
 189    specifications.  */
 190
 191 void
 192 gfc_free_array_spec (gfc_array_spec *as)
 193 {
 194   int i;
 195
 196   if (as == NULL)
 197     return;
 198
 199   for (i = 0; i < as->rank; i++)
 200     {
 201       gfc_free_expr (as->lower[i]);
 202       gfc_free_expr (as->upper[i]);
 203     }
 204
 205   gfc_free (as);
 206 }
 207
 208
 209 /* Take an array bound, resolves the expression, that make up the
 210    shape and check associated constraints.  */
 211
 212 static try
 213 resolve_array_bound (gfc_expr *e, int check_constant)
 214 {
 215   if (e == NULL)
 216     return SUCCESS;
 217
 218   if (gfc_resolve_expr (e) == FAILURE
 219       || gfc_specification_expr (e) == FAILURE)
 220     return FAILURE;
 221
 222   if (check_constant && gfc_is_constant_expr (e) == 0)
 223     {
 224       gfc_error ("Variable '%s' at %L in this context must be constant",
 225                  e->symtree->n.sym->name, &e->where);
 226       return FAILURE;
 227     }
 228
 229   return SUCCESS;
 230 }
 231
 232
 233 /* Takes an array specification, resolves the expressions that make up
 234    the shape and make sure everything is integral.  */
 235
 236 try
 237 gfc_resolve_array_spec (gfc_array_spec *as, int check_constant)
 238 {
 239   gfc_expr *e;
 240   int i;
 241
 242   if (as == NULL)
 243     return SUCCESS;
 244
 245   for (i = 0; i < as->rank; i++)
 246     {
 247       e = as->lower[i];
 248       if (resolve_array_bound (e, check_constant) == FAILURE)
 249         return FAILURE;
 250
 251       e = as->upper[i];
 252       if (resolve_array_bound (e, check_constant) == FAILURE)
 253         return FAILURE;
 254     }
 255
 256   return SUCCESS;
 257 }
 258
 259
 260 /* Match a single array element specification.  The return values as
 261    well as the upper and lower bounds of the array spec are filled
 262    in according to what we see on the input.  The caller makes sure
 263    individual specifications make sense as a whole.
 264
 265
 266         Parsed       Lower   Upper  Returned
 267         ------------------------------------
 268           :           NULL    NULL   AS_DEFERRED (*)
 269           x            1       x     AS_EXPLICIT
 270           x:           x      NULL   AS_ASSUMED_SHAPE
 271           x:y          x       y     AS_EXPLICIT
 272           x:*          x      NULL   AS_ASSUMED_SIZE
 273           *            1      NULL   AS_ASSUMED_SIZE
 274
 275   (*) For non-pointer dummy arrays this is AS_ASSUMED_SHAPE.  This
 276   is fixed during the resolution of formal interfaces.
 277
 278    Anything else AS_UNKNOWN.  */
 279
 280 static array_type
 281 match_array_element_spec (gfc_array_spec *as)
 282 {
 283   gfc_expr **upper, **lower;
 284   match m;
 285
 286   lower = &as->lower[as->rank - 1];
 287   upper = &as->upper[as->rank - 1];
 288
 289   if (gfc_match_char ('*') == MATCH_YES)
 290     {
 291       *lower = gfc_int_expr (1);
 292       return AS_ASSUMED_SIZE;
 293     }
 294
 295   if (gfc_match_char (':') == MATCH_YES)
 296     return AS_DEFERRED;
 297
 298   m = gfc_match_expr (upper);
 299   if (m == MATCH_NO)
 300     gfc_error ("Expected expression in array specification at %C");
 301   if (m != MATCH_YES)
 302     return AS_UNKNOWN;
 303
 304   if (gfc_match_char (':') == MATCH_NO)
 305     {
 306       *lower = gfc_int_expr (1);
 307       return AS_EXPLICIT;
 308     }
 309
 310   *lower = *upper;
 311   *upper = NULL;
 312
 313   if (gfc_match_char ('*') == MATCH_YES)
 314     return AS_ASSUMED_SIZE;
 315
 316   m = gfc_match_expr (upper);
 317   if (m == MATCH_ERROR)
 318     return AS_UNKNOWN;
 319   if (m == MATCH_NO)
 320     return AS_ASSUMED_SHAPE;
 321
 322   /* If the size is negative in this dimension, set it to zero.  */
 323   if ((*lower)->expr_type == EXPR_CONSTANT
 324       && (*upper)->expr_type == EXPR_CONSTANT
 325       && mpz_cmp ((*upper)->value.integer, (*lower)->value.integer) < 0)
 326     {
 327       gfc_free_expr (*upper);
 328       *upper = gfc_copy_expr (*lower);
 329       mpz_sub_ui ((*upper)->value.integer, (*upper)->value.integer, 1);
 330     }
 331   return AS_EXPLICIT;
 332 }
 333
 334
 335 /* Matches an array specification, incidentally figuring out what sort
 336    it is.  */
 337
 338 match
 339 gfc_match_array_spec (gfc_array_spec **asp)
 340 {
 341   array_type current_type;
 342   gfc_array_spec *as;
 343   int i;
 344
 345   if (gfc_match_char ('(') != MATCH_YES)
 346     {
 347       *asp = NULL;
 348       return MATCH_NO;
 349     }
 350
 351   as = gfc_get_array_spec ();
 352
 353   for (i = 0; i < GFC_MAX_DIMENSIONS; i++)
 354     {
 355       as->lower[i] = NULL;
 356       as->upper[i] = NULL;
 357     }
 358
 359   as->rank = 1;
 360
 361   for (;;)
 362     {
 363       current_type = match_array_element_spec (as);
 364
 365       if (as->rank == 1)
 366         {
 367           if (current_type == AS_UNKNOWN)
 368             goto cleanup;
 369           as->type = current_type;
 370         }
 371       else
 372         switch (as->type)
 373           {             /* See how current spec meshes with the existing.  */
 374           case AS_UNKNOWN:
 375             goto cleanup;
 376
 377           case AS_EXPLICIT:
 378             if (current_type == AS_ASSUMED_SIZE)
 379               {
 380                 as->type = AS_ASSUMED_SIZE;
 381                 break;
 382               }
 383
 384             if (current_type == AS_EXPLICIT)
 385               break;
 386
 387             gfc_error ("Bad array specification for an explicitly shaped "
 388                        "array at %C");
 389
 390             goto cleanup;
 391
 392           case AS_ASSUMED_SHAPE:
 393             if ((current_type == AS_ASSUMED_SHAPE)
 394                 || (current_type == AS_DEFERRED))
 395               break;
 396
 397             gfc_error ("Bad array specification for assumed shape "
 398                        "array at %C");
 399             goto cleanup;
 400
 401           case AS_DEFERRED:
 402             if (current_type == AS_DEFERRED)
 403               break;
 404
 405             if (current_type == AS_ASSUMED_SHAPE)
 406               {
 407                 as->type = AS_ASSUMED_SHAPE;
 408                 break;
 409               }
 410
 411             gfc_error ("Bad specification for deferred shape array at %C");
 412             goto cleanup;
 413
 414           case AS_ASSUMED_SIZE:
 415             gfc_error ("Bad specification for assumed size array at %C");
 416             goto cleanup;
 417           }
 418
 419       if (gfc_match_char (')') == MATCH_YES)
 420         break;
 421
 422       if (gfc_match_char (',') != MATCH_YES)
 423         {
 424           gfc_error ("Expected another dimension in array declaration at %C");
 425           goto cleanup;
 426         }
 427
 428       if (as->rank >= GFC_MAX_DIMENSIONS)
 429         {
 430           gfc_error ("Array specification at %C has more than %d dimensions",
 431                      GFC_MAX_DIMENSIONS);
 432           goto cleanup;
 433         }
 434
 435       as->rank++;
 436     }
 437
 438   /* If a lower bounds of an assumed shape array is blank, put in one.  */
 439   if (as->type == AS_ASSUMED_SHAPE)
 440     {
 441       for (i = 0; i < as->rank; i++)
 442         {
 443           if (as->lower[i] == NULL)
 444             as->lower[i] = gfc_int_expr (1);
 445         }
 446     }
 447   *asp = as;
 448   return MATCH_YES;
 449
 450 cleanup:
 451   /* Something went wrong.  */
 452   gfc_free_array_spec (as);
 453   return MATCH_ERROR;
 454 }
 455
 456
 457 /* Given a symbol and an array specification, modify the symbol to
 458    have that array specification.  The error locus is needed in case
 459    something goes wrong.  On failure, the caller must free the spec.  */
 460
 461 try
 462 gfc_set_array_spec (gfc_symbol *sym, gfc_array_spec *as, locus *error_loc)
 463 {
 464   if (as == NULL)
 465     return SUCCESS;
 466
 467   if (gfc_add_dimension (&sym->attr, sym->name, error_loc) == FAILURE)
 468     return FAILURE;
 469
 470   sym->as = as;
 471
 472   return SUCCESS;
 473 }
 474
 475
 476 /* Copy an array specification.  */
 477
 478 gfc_array_spec *
 479 gfc_copy_array_spec (gfc_array_spec *src)
 480 {
 481   gfc_array_spec *dest;
 482   int i;
 483
 484   if (src == NULL)
 485     return NULL;
 486
 487   dest = gfc_get_array_spec ();
 488
 489   *dest = *src;
 490
 491   for (i = 0; i < dest->rank; i++)
 492     {
 493       dest->lower[i] = gfc_copy_expr (dest->lower[i]);
 494       dest->upper[i] = gfc_copy_expr (dest->upper[i]);
 495     }
 496
 497   return dest;
 498 }
 499
 500
 501 /* Returns nonzero if the two expressions are equal.  Only handles integer
 502    constants.  */
 503
 504 static int
 505 compare_bounds (gfc_expr *bound1, gfc_expr *bound2)
 506 {
 507   if (bound1 == NULL || bound2 == NULL
 508       || bound1->expr_type != EXPR_CONSTANT
 509       || bound2->expr_type != EXPR_CONSTANT
 510       || bound1->ts.type != BT_INTEGER
 511       || bound2->ts.type != BT_INTEGER)
 512     gfc_internal_error ("gfc_compare_array_spec(): Array spec clobbered");
 513
 514   if (mpz_cmp (bound1->value.integer, bound2->value.integer) == 0)
 515     return 1;
 516   else
 517     return 0;
 518 }
 519
 520
 521 /* Compares two array specifications.  They must be constant or deferred
 522    shape.  */
 523
 524 int
 525 gfc_compare_array_spec (gfc_array_spec *as1, gfc_array_spec *as2)
 526 {
 527   int i;
 528
 529   if (as1 == NULL && as2 == NULL)
 530     return 1;
 531
 532   if (as1 == NULL || as2 == NULL)
 533     return 0;
 534
 535   if (as1->rank != as2->rank)
 536     return 0;
 537
 538   if (as1->rank == 0)
 539     return 1;
 540
 541   if (as1->type != as2->type)
 542     return 0;
 543
 544   if (as1->type == AS_EXPLICIT)
 545     for (i = 0; i < as1->rank; i++)
 546       {
 547         if (compare_bounds (as1->lower[i], as2->lower[i]) == 0)
 548           return 0;
 549
 550         if (compare_bounds (as1->upper[i], as2->upper[i]) == 0)
 551           return 0;
 552       }
 553
 554   return 1;
 555 }
 556
 557
 558 /****************** Array constructor functions ******************/
 559
 560 /* Start an array constructor.  The constructor starts with zero
 561    elements and should be appended to by gfc_append_constructor().  */
 562
 563 gfc_expr *
 564 gfc_start_constructor (bt type, int kind, locus *where)
 565 {
 566   gfc_expr *result;
 567
 568   result = gfc_get_expr ();
 569
 570   result->expr_type = EXPR_ARRAY;
 571   result->rank = 1;
 572
 573   result->ts.type = type;
 574   result->ts.kind = kind;
 575   result->where = *where;
 576   return result;
 577 }
 578
 579
 580 /* Given an array constructor expression, append the new expression
 581    node onto the constructor.  */
 582
 583 void
 584 gfc_append_constructor (gfc_expr *base, gfc_expr *new)
 585 {
 586   gfc_constructor *c;
 587
 588   if (base->value.constructor == NULL)
 589     base->value.constructor = c = gfc_get_constructor ();
 590   else
 591     {
 592       c = base->value.constructor;
 593       while (c->next)
 594         c = c->next;
 595
 596       c->next = gfc_get_constructor ();
 597       c = c->next;
 598     }
 599
 600   c->expr = new;
 601
 602   if (new->ts.type != base->ts.type || new->ts.kind != base->ts.kind)
 603     gfc_internal_error ("gfc_append_constructor(): New node has wrong kind");
 604 }
 605
 606
 607 /* Given an array constructor expression, insert the new expression's
 608    constructor onto the base's one according to the offset.  */
 609
 610 void
 611 gfc_insert_constructor (gfc_expr *base, gfc_constructor *c1)
 612 {
 613   gfc_constructor *c, *pre;
 614   expr_t type;
 615   int t;
 616
 617   type = base->expr_type;
 618
 619   if (base->value.constructor == NULL)
 620     base->value.constructor = c1;
 621   else
 622     {
 623       c = pre = base->value.constructor;
 624       while (c)
 625         {
 626           if (type == EXPR_ARRAY)
 627             {
 628               t = mpz_cmp (c->n.offset, c1->n.offset);
 629               if (t < 0)
 630                 {
 631                   pre = c;
 632                   c = c->next;
 633                 }
 634               else if (t == 0)
 635                 {
 636                   gfc_error ("duplicated initializer");
 637                   break;
 638                 }
 639               else
 640                 break;
 641             }
 642           else
 643             {
 644               pre = c;
 645               c = c->next;
 646             }
 647         }
 648
 649       if (pre != c)
 650         {
 651           pre->next = c1;
 652           c1->next = c;
 653         }
 654       else
 655         {
 656           c1->next = c;
 657           base->value.constructor = c1;
 658         }
 659     }
 660 }
 661
 662
 663 /* Get a new constructor.  */
 664
 665 gfc_constructor *
 666 gfc_get_constructor (void)
 667 {
 668   gfc_constructor *c;
 669
 670   c = gfc_getmem (sizeof(gfc_constructor));
 671   c->expr = NULL;
 672   c->iterator = NULL;
 673   c->next = NULL;
 674   mpz_init_set_si (c->n.offset, 0);
 675   mpz_init_set_si (c->repeat, 0);
 676   return c;
 677 }
 678
 679
 680 /* Free chains of gfc_constructor structures.  */
 681
 682 void
 683 gfc_free_constructor (gfc_constructor *p)
 684 {
 685   gfc_constructor *next;
 686
 687   if (p == NULL)
 688     return;
 689
 690   for (; p; p = next)
 691     {
 692       next = p->next;
 693
 694       if (p->expr)
 695         gfc_free_expr (p->expr);
 696       if (p->iterator != NULL)
 697         gfc_free_iterator (p->iterator, 1);
 698       mpz_clear (p->n.offset);
 699       mpz_clear (p->repeat);
 700       gfc_free (p);
 701     }
 702 }
 703
 704
 705 /* Given an expression node that might be an array constructor and a
 706    symbol, make sure that no iterators in this or child constructors
 707    use the symbol as an implied-DO iterator.  Returns nonzero if a
 708    duplicate was found.  */
 709
 710 static int
 711 check_duplicate_iterator (gfc_constructor *c, gfc_symbol *master)
 712 {
 713   gfc_expr *e;
 714
 715   for (; c; c = c->next)
 716     {
 717       e = c->expr;
 718
 719       if (e->expr_type == EXPR_ARRAY
 720           && check_duplicate_iterator (e->value.constructor, master))
 721         return 1;
 722
 723       if (c->iterator == NULL)
 724         continue;
 725
 726       if (c->iterator->var->symtree->n.sym == master)
 727         {
 728           gfc_error ("DO-iterator '%s' at %L is inside iterator of the "
 729                      "same name", master->name, &c->where);
 730
 731           return 1;
 732         }
 733     }
 734
 735   return 0;
 736 }
 737
 738
 739 /* Forward declaration because these functions are mutually recursive.  */
 740 static match match_array_cons_element (gfc_constructor **);
 741
 742 /* Match a list of array elements.  */
 743
 744 static match
 745 match_array_list (gfc_constructor **result)
 746 {
 747   gfc_constructor *p, *head, *tail, *new;
 748   gfc_iterator iter;
 749   locus old_loc;
 750   gfc_expr *e;
 751   match m;
 752   int n;
 753
 754   old_loc = gfc_current_locus;
 755
 756   if (gfc_match_char ('(') == MATCH_NO)
 757     return MATCH_NO;
 758
 759   memset (&iter, '\0', sizeof (gfc_iterator));
 760   head = NULL;
 761
 762   m = match_array_cons_element (&head);
 763   if (m != MATCH_YES)
 764     goto cleanup;
 765
 766   tail = head;
 767
 768   if (gfc_match_char (',') != MATCH_YES)
 769     {
 770       m = MATCH_NO;
 771       goto cleanup;
 772     }
 773
 774   for (n = 1;; n++)
 775     {
 776       m = gfc_match_iterator (&iter, 0);
 777       if (m == MATCH_YES)
 778         break;
 779       if (m == MATCH_ERROR)
 780         goto cleanup;
 781
 782       m = match_array_cons_element (&new);
 783       if (m == MATCH_ERROR)
 784         goto cleanup;
 785       if (m == MATCH_NO)
 786         {
 787           if (n > 2)
 788             goto syntax;
 789           m = MATCH_NO;
 790           goto cleanup;         /* Could be a complex constant */
 791         }
 792
 793       tail->next = new;
 794       tail = new;
 795
 796       if (gfc_match_char (',') != MATCH_YES)
 797         {
 798           if (n > 2)
 799             goto syntax;
 800           m = MATCH_NO;
 801           goto cleanup;
 802         }
 803     }
 804
 805   if (gfc_match_char (')') != MATCH_YES)
 806     goto syntax;
 807
 808   if (check_duplicate_iterator (head, iter.var->symtree->n.sym))
 809     {
 810       m = MATCH_ERROR;
 811       goto cleanup;
 812     }
 813
 814   e = gfc_get_expr ();
 815   e->expr_type = EXPR_ARRAY;
 816   e->where = old_loc;
 817   e->value.constructor = head;
 818
 819   p = gfc_get_constructor ();
 820   p->where = gfc_current_locus;
 821   p->iterator = gfc_get_iterator ();
 822   *p->iterator = iter;
 823
 824   p->expr = e;
 825   *result = p;
 826
 827   return MATCH_YES;
 828
 829 syntax:
 830   gfc_error ("Syntax error in array constructor at %C");
 831   m = MATCH_ERROR;
 832
 833 cleanup:
 834   gfc_free_constructor (head);
 835   gfc_free_iterator (&iter, 0);
 836   gfc_current_locus = old_loc;
 837   return m;
 838 }
 839
 840
 841 /* Match a single element of an array constructor, which can be a
 842    single expression or a list of elements.  */
 843
 844 static match
 845 match_array_cons_element (gfc_constructor **result)
 846 {
 847   gfc_constructor *p;
 848   gfc_expr *expr;
 849   match m;
 850
 851   m = match_array_list (result);
 852   if (m != MATCH_NO)
 853     return m;
 854
 855   m = gfc_match_expr (&expr);
 856   if (m != MATCH_YES)
 857     return m;
 858
 859   p = gfc_get_constructor ();
 860   p->where = gfc_current_locus;
 861   p->expr = expr;
 862
 863   *result = p;
 864   return MATCH_YES;
 865 }
 866
 867
 868 /* Match an array constructor.  */
 869
 870 match
 871 gfc_match_array_constructor (gfc_expr **result)
 872 {
 873   gfc_constructor *head, *tail, *new;
 874   gfc_expr *expr;
 875   locus where;
 876   match m;
 877   const char *end_delim;
 878
 879   if (gfc_match (" (/") == MATCH_NO)
 880     {
 881       if (gfc_match (" [") == MATCH_NO)
 882         return MATCH_NO;
 883       else
 884         {
 885           if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: [...] "
 886                               "style array constructors at %C") == FAILURE)
 887             return MATCH_ERROR;
 888           end_delim = " ]";
 889         }
 890     }
 891   else
 892     end_delim = " /)";
 893
 894   where = gfc_current_locus;
 895   head = tail = NULL;
 896
 897   if (gfc_match (end_delim) == MATCH_YES)
 898     {
 899       gfc_error ("Empty array constructor at %C is not allowed");
 900       goto cleanup;
 901     }
 902
 903   for (;;)
 904     {
 905       m = match_array_cons_element (&new);
 906       if (m == MATCH_ERROR)
 907         goto cleanup;
 908       if (m == MATCH_NO)
 909         goto syntax;
 910
 911       if (head == NULL)
 912         head = new;
 913       else
 914         tail->next = new;
 915
 916       tail = new;
 917
 918       if (gfc_match_char (',') == MATCH_NO)
 919         break;
 920     }
 921
 922   if (gfc_match (end_delim) == MATCH_NO)
 923     goto syntax;
 924
 925   expr = gfc_get_expr ();
 926
 927   expr->expr_type = EXPR_ARRAY;
 928
 929   expr->value.constructor = head;
 930   /* Size must be calculated at resolution time.  */
 931
 932   expr->where = where;
 933   expr->rank = 1;
 934
 935   *result = expr;
 936   return MATCH_YES;
 937
 938 syntax:
 939   gfc_error ("Syntax error in array constructor at %C");
 940
 941 cleanup:
 942   gfc_free_constructor (head);
 943   return MATCH_ERROR;
 944 }
 945
 946
 947
 948 /************** Check array constructors for correctness **************/
 949
 950 /* Given an expression, compare it's type with the type of the current
 951    constructor.  Returns nonzero if an error was issued.  The
 952    cons_state variable keeps track of whether the type of the
 953    constructor being read or resolved is known to be good, bad or just
 954    starting out.  */
 955
 956 static gfc_typespec constructor_ts;
 957 static enum
 958 { CONS_START, CONS_GOOD, CONS_BAD }
 959 cons_state;
 960
 961 static int
 962 check_element_type (gfc_expr *expr)
 963 {
 964   if (cons_state == CONS_BAD)
 965     return 0;                   /* Suppress further errors */
 966
 967   if (cons_state == CONS_START)
 968     {
 969       if (expr->ts.type == BT_UNKNOWN)
 970         cons_state = CONS_BAD;
 971       else
 972         {
 973           cons_state = CONS_GOOD;
 974           constructor_ts = expr->ts;
 975         }
 976
 977       return 0;
 978     }
 979
 980   if (gfc_compare_types (&constructor_ts, &expr->ts))
 981     return 0;
 982
 983   gfc_error ("Element in %s array constructor at %L is %s",
 984              gfc_typename (&constructor_ts), &expr->where,
 985              gfc_typename (&expr->ts));
 986
 987   cons_state = CONS_BAD;
 988   return 1;
 989 }
 990
 991
 992 /* Recursive work function for gfc_check_constructor_type().  */
 993
 994 static try
 995 check_constructor_type (gfc_constructor *c)
 996 {
 997   gfc_expr *e;
 998
 999   for (; c; c = c->next)
1000     {
1001       e = c->expr;
1002
1003       if (e->expr_type == EXPR_ARRAY)
1004         {
1005           if (check_constructor_type (e->value.constructor) == FAILURE)
1006             return FAILURE;
1007
1008           continue;
1009         }
1010
1011       if (check_element_type (e))
1012         return FAILURE;
1013     }
1014
1015   return SUCCESS;
1016 }
1017
1018
1019 /* Check that all elements of an array constructor are the same type.
1020    On FAILURE, an error has been generated.  */
1021
1022 try
1023 gfc_check_constructor_type (gfc_expr *e)
1024 {
1025   try t;
1026
1027   cons_state = CONS_START;
1028   gfc_clear_ts (&constructor_ts);
1029
1030   t = check_constructor_type (e->value.constructor);
1031   if (t == SUCCESS && e->ts.type == BT_UNKNOWN)
1032     e->ts = constructor_ts;
1033
1034   return t;
1035 }
1036
1037
1038
1039 typedef struct cons_stack
1040 {
1041   gfc_iterator *iterator;
1042   struct cons_stack *previous;
1043 }
1044 cons_stack;
1045
1046 static cons_stack *base;
1047
1048 static try check_constructor (gfc_constructor *, try (*) (gfc_expr *));
1049
1050 /* Check an EXPR_VARIABLE expression in a constructor to make sure
1051    that that variable is an iteration variables.  */
1052
1053 try
1054 gfc_check_iter_variable (gfc_expr *expr)
1055 {
1056   gfc_symbol *sym;
1057   cons_stack *c;
1058
1059   sym = expr->symtree->n.sym;
1060
1061   for (c = base; c; c = c->previous)
1062     if (sym == c->iterator->var->symtree->n.sym)
1063       return SUCCESS;
1064
1065   return FAILURE;
1066 }
1067
1068
1069 /* Recursive work function for gfc_check_constructor().  This amounts
1070    to calling the check function for each expression in the
1071    constructor, giving variables with the names of iterators a pass.  */
1072
1073 static try
1074 check_constructor (gfc_constructor *c, try (*check_function) (gfc_expr *))
1075 {
1076   cons_stack element;
1077   gfc_expr *e;
1078   try t;
1079
1080   for (; c; c = c->next)
1081     {
1082       e = c->expr;
1083
1084       if (e->expr_type != EXPR_ARRAY)
1085         {
1086           if ((*check_function) (e) == FAILURE)
1087             return FAILURE;
1088           continue;
1089         }
1090
1091       element.previous = base;
1092       element.iterator = c->iterator;
1093
1094       base = &element;
1095       t = check_constructor (e->value.constructor, check_function);
1096       base = element.previous;
1097
1098       if (t == FAILURE)
1099         return FAILURE;
1100     }
1101
1102   /* Nothing went wrong, so all OK.  */
1103   return SUCCESS;
1104 }
1105
1106
1107 /* Checks a constructor to see if it is a particular kind of
1108    expression -- specification, restricted, or initialization as
1109    determined by the check_function.  */
1110
1111 try
1112 gfc_check_constructor (gfc_expr *expr, try (*check_function) (gfc_expr *))
1113 {
1114   cons_stack *base_save;
1115   try t;
1116
1117   base_save = base;
1118   base = NULL;
1119
1120   t = check_constructor (expr->value.constructor, check_function);
1121   base = base_save;
1122
1123   return t;
1124 }
1125
1126
1127
1128 /**************** Simplification of array constructors ****************/
1129
1130 iterator_stack *iter_stack;
1131
1132 typedef struct
1133 {
1134   gfc_constructor *new_head, *new_tail;
1135   int extract_count, extract_n;
1136   gfc_expr *extracted;
1137   mpz_t *count;
1138
1139   mpz_t *offset;
1140   gfc_component *component;
1141   mpz_t *repeat;
1142
1143   try (*expand_work_function) (gfc_expr *);
1144 }
1145 expand_info;
1146
1147 static expand_info current_expand;
1148
1149 static try expand_constructor (gfc_constructor *);
1150
1151
1152 /* Work function that counts the number of elements present in a
1153    constructor.  */
1154
1155 static try
1156 count_elements (gfc_expr *e)
1157 {
1158   mpz_t result;
1159
1160   if (e->rank == 0)
1161     mpz_add_ui (*current_expand.count, *current_expand.count, 1);
1162   else
1163     {
1164       if (gfc_array_size (e, &result) == FAILURE)
1165         {
1166           gfc_free_expr (e);
1167           return FAILURE;
1168         }
1169
1170       mpz_add (*current_expand.count, *current_expand.count, result);
1171       mpz_clear (result);
1172     }
1173
1174   gfc_free_expr (e);
1175   return SUCCESS;
1176 }
1177
1178
1179 /* Work function that extracts a particular element from an array
1180    constructor, freeing the rest.  */
1181
1182 static try
1183 extract_element (gfc_expr *e)
1184 {
1185
1186   if (e->rank != 0)
1187     {                           /* Something unextractable */
1188       gfc_free_expr (e);
1189       return FAILURE;
1190     }
1191
1192   if (current_expand.extract_count == current_expand.extract_n)
1193     current_expand.extracted = e;
1194   else
1195     gfc_free_expr (e);
1196
1197   current_expand.extract_count++;
1198   return SUCCESS;
1199 }
1200
1201
1202 /* Work function that constructs a new constructor out of the old one,
1203    stringing new elements together.  */
1204
1205 static try
1206 expand (gfc_expr *e)
1207 {
1208   if (current_expand.new_head == NULL)
1209     current_expand.new_head = current_expand.new_tail =
1210       gfc_get_constructor ();
1211   else
1212     {
1213       current_expand.new_tail->next = gfc_get_constructor ();
1214       current_expand.new_tail = current_expand.new_tail->next;
1215     }
1216
1217   current_expand.new_tail->where = e->where;
1218   current_expand.new_tail->expr = e;
1219
1220   mpz_set (current_expand.new_tail->n.offset, *current_expand.offset);
1221   current_expand.new_tail->n.component = current_expand.component;
1222   mpz_set (current_expand.new_tail->repeat, *current_expand.repeat);
1223   return SUCCESS;
1224 }
1225
1226
1227 /* Given an initialization expression that is a variable reference,
1228    substitute the current value of the iteration variable.  */
1229
1230 void
1231 gfc_simplify_iterator_var (gfc_expr *e)
1232 {
1233   iterator_stack *p;
1234
1235   for (p = iter_stack; p; p = p->prev)
1236     if (e->symtree == p->variable)
1237       break;
1238
1239   if (p == NULL)
1240     return;             /* Variable not found */
1241
1242   gfc_replace_expr (e, gfc_int_expr (0));
1243
1244   mpz_set (e->value.integer, p->value);
1245
1246   return;
1247 }
1248
1249
1250 /* Expand an expression with that is inside of a constructor,
1251    recursing into other constructors if present.  */
1252
1253 static try
1254 expand_expr (gfc_expr *e)
1255 {
1256   if (e->expr_type == EXPR_ARRAY)
1257     return expand_constructor (e->value.constructor);
1258
1259   e = gfc_copy_expr (e);
1260
1261   if (gfc_simplify_expr (e, 1) == FAILURE)
1262     {
1263       gfc_free_expr (e);
1264       return FAILURE;
1265     }
1266
1267   return current_expand.expand_work_function (e);
1268 }
1269
1270
1271 static try
1272 expand_iterator (gfc_constructor *c)
1273 {
1274   gfc_expr *start, *end, *step;
1275   iterator_stack frame;
1276   mpz_t trip;
1277   try t;
1278
1279   end = step = NULL;
1280
1281   t = FAILURE;
1282
1283   mpz_init (trip);
1284   mpz_init (frame.value);
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 static 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     return FAILURE;
1730
1731   mpz_init (*result);
1732
1733   mpz_sub (*result, as->upper[dimen]->value.integer,
1734            as->lower[dimen]->value.integer);
1735
1736   mpz_add_ui (*result, *result, 1);
1737
1738   return SUCCESS;
1739 }
1740
1741
1742 try
1743 spec_size (gfc_array_spec *as, mpz_t *result)
1744 {
1745   mpz_t size;
1746   int d;
1747
1748   mpz_init_set_ui (*result, 1);
1749
1750   for (d = 0; d < as->rank; d++)
1751     {
1752       if (spec_dimen_size (as, d, &size) == FAILURE)
1753         {
1754           mpz_clear (*result);
1755           return FAILURE;
1756         }
1757
1758       mpz_mul (*result, *result, size);
1759       mpz_clear (size);
1760     }
1761
1762   return SUCCESS;
1763 }
1764
1765
1766 /* Get the number of elements in an array section.  */
1767
1768 static try
1769 ref_dimen_size (gfc_array_ref *ar, int dimen, mpz_t *result)
1770 {
1771   mpz_t upper, lower, stride;
1772   try t;
1773
1774   if (dimen < 0 || ar == NULL || dimen > ar->dimen - 1)
1775     gfc_internal_error ("ref_dimen_size(): Bad dimension");
1776
1777   switch (ar->dimen_type[dimen])
1778     {
1779     case DIMEN_ELEMENT:
1780       mpz_init (*result);
1781       mpz_set_ui (*result, 1);
1782       t = SUCCESS;
1783       break;
1784
1785     case DIMEN_VECTOR:
1786       t = gfc_array_size (ar->start[dimen], result);    /* Recurse! */
1787       break;
1788
1789     case DIMEN_RANGE:
1790       mpz_init (upper);
1791       mpz_init (lower);
1792       mpz_init (stride);
1793       t = FAILURE;
1794
1795       if (ar->start[dimen] == NULL)
1796         {
1797           if (ar->as->lower[dimen] == NULL
1798               || ar->as->lower[dimen]->expr_type != EXPR_CONSTANT)
1799             goto cleanup;
1800           mpz_set (lower, ar->as->lower[dimen]->value.integer);
1801         }
1802       else
1803         {
1804           if (ar->start[dimen]->expr_type != EXPR_CONSTANT)
1805             goto cleanup;
1806           mpz_set (lower, ar->start[dimen]->value.integer);
1807         }
1808
1809       if (ar->end[dimen] == NULL)
1810         {
1811           if (ar->as->upper[dimen] == NULL
1812               || ar->as->upper[dimen]->expr_type != EXPR_CONSTANT)
1813             goto cleanup;
1814           mpz_set (upper, ar->as->upper[dimen]->value.integer);
1815         }
1816       else
1817         {
1818           if (ar->end[dimen]->expr_type != EXPR_CONSTANT)
1819             goto cleanup;
1820           mpz_set (upper, ar->end[dimen]->value.integer);
1821         }
1822
1823       if (ar->stride[dimen] == NULL)
1824         mpz_set_ui (stride, 1);
1825       else
1826         {
1827           if (ar->stride[dimen]->expr_type != EXPR_CONSTANT)
1828             goto cleanup;
1829           mpz_set (stride, ar->stride[dimen]->value.integer);
1830         }
1831
1832       mpz_init (*result);
1833       mpz_sub (*result, upper, lower);
1834       mpz_add (*result, *result, stride);
1835       mpz_div (*result, *result, stride);
1836
1837       /* Zero stride caught earlier.  */
1838       if (mpz_cmp_ui (*result, 0) < 0)
1839         mpz_set_ui (*result, 0);
1840       t = SUCCESS;
1841
1842     cleanup:
1843       mpz_clear (upper);
1844       mpz_clear (lower);
1845       mpz_clear (stride);
1846       return t;
1847
1848     default:
1849       gfc_internal_error ("ref_dimen_size(): Bad dimen_type");
1850     }
1851
1852   return t;
1853 }
1854
1855
1856 static try
1857 ref_size (gfc_array_ref *ar, mpz_t *result)
1858 {
1859   mpz_t size;
1860   int d;
1861
1862   mpz_init_set_ui (*result, 1);
1863
1864   for (d = 0; d < ar->dimen; d++)
1865     {
1866       if (ref_dimen_size (ar, d, &size) == FAILURE)
1867         {
1868           mpz_clear (*result);
1869           return FAILURE;
1870         }
1871
1872       mpz_mul (*result, *result, size);
1873       mpz_clear (size);
1874     }
1875
1876   return SUCCESS;
1877 }
1878
1879
1880 /* Given an array expression and a dimension, figure out how many
1881    elements it has along that dimension.  Returns SUCCESS if we were
1882    able to return a result in the 'result' variable, FAILURE
1883    otherwise.  */
1884
1885 try
1886 gfc_array_dimen_size (gfc_expr *array, int dimen, mpz_t *result)
1887 {
1888   gfc_ref *ref;
1889   int i;
1890
1891   if (dimen < 0 || array == NULL || dimen > array->rank - 1)
1892     gfc_internal_error ("gfc_array_dimen_size(): Bad dimension");
1893
1894   switch (array->expr_type)
1895     {
1896     case EXPR_VARIABLE:
1897     case EXPR_FUNCTION:
1898       for (ref = array->ref; ref; ref = ref->next)
1899         {
1900           if (ref->type != REF_ARRAY)
1901             continue;
1902
1903           if (ref->u.ar.type == AR_FULL)
1904             return spec_dimen_size (ref->u.ar.as, dimen, result);
1905
1906           if (ref->u.ar.type == AR_SECTION)
1907             {
1908               for (i = 0; dimen >= 0; i++)
1909                 if (ref->u.ar.dimen_type[i] != DIMEN_ELEMENT)
1910                   dimen--;
1911
1912               return ref_dimen_size (&ref->u.ar, i - 1, result);
1913             }
1914         }
1915
1916       if (array->shape && array->shape[dimen])
1917         {
1918           mpz_init_set (*result, array->shape[dimen]);
1919           return SUCCESS;
1920         }
1921
1922       if (spec_dimen_size (array->symtree->n.sym->as, dimen, result) == FAILURE)
1923         return FAILURE;
1924
1925       break;
1926
1927     case EXPR_ARRAY:
1928       if (array->shape == NULL) {
1929         /* Expressions with rank > 1 should have "shape" properly set */
1930         if ( array->rank != 1 )
1931           gfc_internal_error ("gfc_array_dimen_size(): Bad EXPR_ARRAY expr");
1932         return gfc_array_size(array, result);
1933       }
1934
1935       /* Fall through */
1936     default:
1937       if (array->shape == NULL)
1938         return FAILURE;
1939
1940       mpz_init_set (*result, array->shape[dimen]);
1941
1942       break;
1943     }
1944
1945   return SUCCESS;
1946 }
1947
1948
1949 /* Given an array expression, figure out how many elements are in the
1950    array.  Returns SUCCESS if this is possible, and sets the 'result'
1951    variable.  Otherwise returns FAILURE.  */
1952
1953 try
1954 gfc_array_size (gfc_expr *array, mpz_t *result)
1955 {
1956   expand_info expand_save;
1957   gfc_ref *ref;
1958   int i, flag;
1959   try t;
1960
1961   switch (array->expr_type)
1962     {
1963     case EXPR_ARRAY:
1964       flag = gfc_suppress_error;
1965       gfc_suppress_error = 1;
1966
1967       expand_save = current_expand;
1968
1969       current_expand.count = result;
1970       mpz_init_set_ui (*result, 0);
1971
1972       current_expand.expand_work_function = count_elements;
1973       iter_stack = NULL;
1974
1975       t = expand_constructor (array->value.constructor);
1976       gfc_suppress_error = flag;
1977
1978       if (t == FAILURE)
1979         mpz_clear (*result);
1980       current_expand = expand_save;
1981       return t;
1982
1983     case EXPR_VARIABLE:
1984       for (ref = array->ref; ref; ref = ref->next)
1985         {
1986           if (ref->type != REF_ARRAY)
1987             continue;
1988
1989           if (ref->u.ar.type == AR_FULL)
1990             return spec_size (ref->u.ar.as, result);
1991
1992           if (ref->u.ar.type == AR_SECTION)
1993             return ref_size (&ref->u.ar, result);
1994         }
1995
1996       return spec_size (array->symtree->n.sym->as, result);
1997
1998
1999     default:
2000       if (array->rank == 0 || array->shape == NULL)
2001         return FAILURE;
2002
2003       mpz_init_set_ui (*result, 1);
2004
2005       for (i = 0; i < array->rank; i++)
2006         mpz_mul (*result, *result, array->shape[i]);
2007
2008       break;
2009     }
2010
2011   return SUCCESS;
2012 }
2013
2014
2015 /* Given an array reference, return the shape of the reference in an
2016    array of mpz_t integers.  */
2017
2018 try
2019 gfc_array_ref_shape (gfc_array_ref *ar, mpz_t *shape)
2020 {
2021   int d;
2022   int i;
2023
2024   d = 0;
2025
2026   switch (ar->type)
2027     {
2028     case AR_FULL:
2029       for (; d < ar->as->rank; d++)
2030         if (spec_dimen_size (ar->as, d, &shape[d]) == FAILURE)
2031           goto cleanup;
2032
2033       return SUCCESS;
2034
2035     case AR_SECTION:
2036       for (i = 0; i < ar->dimen; i++)
2037         {
2038           if (ar->dimen_type[i] != DIMEN_ELEMENT)
2039             {
2040               if (ref_dimen_size (ar, i, &shape[d]) == FAILURE)
2041                 goto cleanup;
2042               d++;
2043             }
2044         }
2045
2046       return SUCCESS;
2047
2048     default:
2049       break;
2050     }
2051
2052 cleanup:
2053   for (d--; d >= 0; d--)
2054     mpz_clear (shape[d]);
2055
2056   return FAILURE;
2057 }
2058
2059
2060 /* Given an array expression, find the array reference structure that
2061    characterizes the reference.  */
2062
2063 gfc_array_ref *
2064 gfc_find_array_ref (gfc_expr *e)
2065 {
2066   gfc_ref *ref;
2067
2068   for (ref = e->ref; ref; ref = ref->next)
2069     if (ref->type == REF_ARRAY
2070         && (ref->u.ar.type == AR_FULL || ref->u.ar.type == AR_SECTION))
2071       break;
2072
2073   if (ref == NULL)
2074     gfc_internal_error ("gfc_find_array_ref(): No ref found");
2075
2076   return &ref->u.ar;
2077 }
2078
2079
2080 /* Find out if an array shape is known at compile time.  */
2081
2082 int
2083 gfc_is_compile_time_shape (gfc_array_spec *as)
2084 {
2085   int i;
2086
2087   if (as->type != AS_EXPLICIT)
2088     return 0;
2089
2090   for (i = 0; i < as->rank; i++)
2091     if (!gfc_is_constant_expr (as->lower[i])
2092         || !gfc_is_constant_expr (as->upper[i]))
2093       return 0;
2094
2095   return 1;
2096 }