gcc/fortran/array.c

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