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   gfc_clear_ts (&e->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   frame.prev = NULL;
1286
1287   start = gfc_copy_expr (c->iterator->start);
1288   if (gfc_simplify_expr (start, 1) == FAILURE)
1289     goto cleanup;
1290
1291   if (start->expr_type != EXPR_CONSTANT || start->ts.type != BT_INTEGER)
1292     goto cleanup;
1293
1294   end = gfc_copy_expr (c->iterator->end);
1295   if (gfc_simplify_expr (end, 1) == FAILURE)
1296     goto cleanup;
1297
1298   if (end->expr_type != EXPR_CONSTANT || end->ts.type != BT_INTEGER)
1299     goto cleanup;
1300
1301   step = gfc_copy_expr (c->iterator->step);
1302   if (gfc_simplify_expr (step, 1) == FAILURE)
1303     goto cleanup;
1304
1305   if (step->expr_type != EXPR_CONSTANT || step->ts.type != BT_INTEGER)
1306     goto cleanup;
1307
1308   if (mpz_sgn (step->value.integer) == 0)
1309     {
1310       gfc_error ("Iterator step at %L cannot be zero", &step->where);
1311       goto cleanup;
1312     }
1313
1314   /* Calculate the trip count of the loop.  */
1315   mpz_sub (trip, end->value.integer, start->value.integer);
1316   mpz_add (trip, trip, step->value.integer);
1317   mpz_tdiv_q (trip, trip, step->value.integer);
1318
1319   mpz_set (frame.value, start->value.integer);
1320
1321   frame.prev = iter_stack;
1322   frame.variable = c->iterator->var->symtree;
1323   iter_stack = &frame;
1324
1325   while (mpz_sgn (trip) > 0)
1326     {
1327       if (expand_expr (c->expr) == FAILURE)
1328         goto cleanup;
1329
1330       mpz_add (frame.value, frame.value, step->value.integer);
1331       mpz_sub_ui (trip, trip, 1);
1332     }
1333
1334   t = SUCCESS;
1335
1336 cleanup:
1337   gfc_free_expr (start);
1338   gfc_free_expr (end);
1339   gfc_free_expr (step);
1340
1341   mpz_clear (trip);
1342   mpz_clear (frame.value);
1343
1344   iter_stack = frame.prev;
1345
1346   return t;
1347 }
1348
1349
1350 /* Expand a constructor into constant constructors without any
1351    iterators, calling the work function for each of the expanded
1352    expressions.  The work function needs to either save or free the
1353    passed expression.  */
1354
1355 static try
1356 expand_constructor (gfc_constructor *c)
1357 {
1358   gfc_expr *e;
1359
1360   for (; c; c = c->next)
1361     {
1362       if (c->iterator != NULL)
1363         {
1364           if (expand_iterator (c) == FAILURE)
1365             return FAILURE;
1366           continue;
1367         }
1368
1369       e = c->expr;
1370
1371       if (e->expr_type == EXPR_ARRAY)
1372         {
1373           if (expand_constructor (e->value.constructor) == FAILURE)
1374             return FAILURE;
1375
1376           continue;
1377         }
1378
1379       e = gfc_copy_expr (e);
1380       if (gfc_simplify_expr (e, 1) == FAILURE)
1381         {
1382           gfc_free_expr (e);
1383           return FAILURE;
1384         }
1385       current_expand.offset = &c->n.offset;
1386       current_expand.component = c->n.component;
1387       current_expand.repeat = &c->repeat;
1388       if (current_expand.expand_work_function (e) == FAILURE)
1389         return FAILURE;
1390     }
1391   return SUCCESS;
1392 }
1393
1394
1395 /* Top level subroutine for expanding constructors.  We only expand
1396    constructor if they are small enough.  */
1397
1398 try
1399 gfc_expand_constructor (gfc_expr *e)
1400 {
1401   expand_info expand_save;
1402   gfc_expr *f;
1403   try rc;
1404
1405   f = gfc_get_array_element (e, GFC_MAX_AC_EXPAND);
1406   if (f != NULL)
1407     {
1408       gfc_free_expr (f);
1409       return SUCCESS;
1410     }
1411
1412   expand_save = current_expand;
1413   current_expand.new_head = current_expand.new_tail = NULL;
1414
1415   iter_stack = NULL;
1416
1417   current_expand.expand_work_function = expand;
1418
1419   if (expand_constructor (e->value.constructor) == FAILURE)
1420     {
1421       gfc_free_constructor (current_expand.new_head);
1422       rc = FAILURE;
1423       goto done;
1424     }
1425
1426   gfc_free_constructor (e->value.constructor);
1427   e->value.constructor = current_expand.new_head;
1428
1429   rc = SUCCESS;
1430
1431 done:
1432   current_expand = expand_save;
1433
1434   return rc;
1435 }
1436
1437
1438 /* Work function for checking that an element of a constructor is a
1439    constant, after removal of any iteration variables.  We return
1440    FAILURE if not so.  */
1441
1442 static try
1443 constant_element (gfc_expr *e)
1444 {
1445   int rv;
1446
1447   rv = gfc_is_constant_expr (e);
1448   gfc_free_expr (e);
1449
1450   return rv ? SUCCESS : FAILURE;
1451 }
1452
1453
1454 /* Given an array constructor, determine if the constructor is
1455    constant or not by expanding it and making sure that all elements
1456    are constants.  This is a bit of a hack since something like (/ (i,
1457    i=1,100000000) /) will take a while as* opposed to a more clever
1458    function that traverses the expression tree. FIXME.  */
1459
1460 int
1461 gfc_constant_ac (gfc_expr *e)
1462 {
1463   expand_info expand_save;
1464   try rc;
1465
1466   iter_stack = NULL;
1467   expand_save = current_expand;
1468   current_expand.expand_work_function = constant_element;
1469
1470   rc = expand_constructor (e->value.constructor);
1471
1472   current_expand = expand_save;
1473   if (rc == FAILURE)
1474     return 0;
1475
1476   return 1;
1477 }
1478
1479
1480 /* Returns nonzero if an array constructor has been completely
1481    expanded (no iterators) and zero if iterators are present.  */
1482
1483 int
1484 gfc_expanded_ac (gfc_expr *e)
1485 {
1486   gfc_constructor *p;
1487
1488   if (e->expr_type == EXPR_ARRAY)
1489     for (p = e->value.constructor; p; p = p->next)
1490       if (p->iterator != NULL || !gfc_expanded_ac (p->expr))
1491         return 0;
1492
1493   return 1;
1494 }
1495
1496
1497 /*************** Type resolution of array constructors ***************/
1498
1499 /* Recursive array list resolution function.  All of the elements must
1500    be of the same type.  */
1501
1502 static try
1503 resolve_array_list (gfc_constructor *p)
1504 {
1505   try t;
1506
1507   t = SUCCESS;
1508
1509   for (; p; p = p->next)
1510     {
1511       if (p->iterator != NULL
1512           && gfc_resolve_iterator (p->iterator, false) == FAILURE)
1513         t = FAILURE;
1514
1515       if (gfc_resolve_expr (p->expr) == FAILURE)
1516         t = FAILURE;
1517     }
1518
1519   return t;
1520 }
1521
1522 /* Resolve character array constructor. If it is a constant character array and
1523    not specified character length, update character length to the maximum of
1524    its element constructors' length.  */
1525
1526 void
1527 gfc_resolve_character_array_constructor (gfc_expr *expr)
1528 {
1529   gfc_constructor *p;
1530   int max_length;
1531
1532   gcc_assert (expr->expr_type == EXPR_ARRAY);
1533   gcc_assert (expr->ts.type == BT_CHARACTER);
1534
1535   max_length = -1;
1536
1537   if (expr->ts.cl == NULL)
1538     {
1539       for (p = expr->value.constructor; p; p = p->next)
1540         if (p->expr->ts.cl != NULL)
1541           {
1542             /* Ensure that if there is a char_len around that it is
1543                used; otherwise the middle-end confuses them!  */
1544             expr->ts.cl = p->expr->ts.cl;
1545             goto got_charlen;
1546           }
1547
1548       expr->ts.cl = gfc_get_charlen ();
1549       expr->ts.cl->next = gfc_current_ns->cl_list;
1550       gfc_current_ns->cl_list = expr->ts.cl;
1551     }
1552
1553 got_charlen:
1554
1555   if (expr->ts.cl->length == NULL)
1556     {
1557       /* Find the maximum length of the elements. Do nothing for variable
1558          array constructor, unless the character length is constant or
1559          there is a constant substring reference.  */
1560
1561       for (p = expr->value.constructor; p; p = p->next)
1562         {
1563           gfc_ref *ref;
1564           for (ref = p->expr->ref; ref; ref = ref->next)
1565             if (ref->type == REF_SUBSTRING
1566                 && ref->u.ss.start->expr_type == EXPR_CONSTANT
1567                 && ref->u.ss.end->expr_type == EXPR_CONSTANT)
1568               break;
1569
1570           if (p->expr->expr_type == EXPR_CONSTANT)
1571             max_length = MAX (p->expr->value.character.length, max_length);
1572           else if (ref)
1573             {
1574               long j;
1575               j = mpz_get_ui (ref->u.ss.end->value.integer)
1576                 - mpz_get_ui (ref->u.ss.start->value.integer) + 1;
1577               max_length = MAX ((int) j, max_length);
1578             }
1579           else if (p->expr->ts.cl && p->expr->ts.cl->length
1580                    && p->expr->ts.cl->length->expr_type == EXPR_CONSTANT)
1581             {
1582               long j;
1583               j = mpz_get_si (p->expr->ts.cl->length->value.integer);
1584               max_length = MAX ((int) j, max_length);
1585             }
1586           else
1587             return;
1588         }
1589
1590       if (max_length != -1)
1591         {
1592           /* Update the character length of the array constructor.  */
1593           expr->ts.cl->length = gfc_int_expr (max_length);
1594           /* Update the element constructors.  */
1595           for (p = expr->value.constructor; p; p = p->next)
1596             if (p->expr->expr_type == EXPR_CONSTANT)
1597               gfc_set_constant_character_len (max_length, p->expr, true);
1598         }
1599     }
1600 }
1601
1602
1603 /* Resolve all of the expressions in an array list.  */
1604
1605 try
1606 gfc_resolve_array_constructor (gfc_expr *expr)
1607 {
1608   try t;
1609
1610   t = resolve_array_list (expr->value.constructor);
1611   if (t == SUCCESS)
1612     t = gfc_check_constructor_type (expr);
1613   if (t == SUCCESS && expr->ts.type == BT_CHARACTER)
1614     gfc_resolve_character_array_constructor (expr);
1615
1616   return t;
1617 }
1618
1619
1620 /* Copy an iterator structure.  */
1621
1622 static gfc_iterator *
1623 copy_iterator (gfc_iterator *src)
1624 {
1625   gfc_iterator *dest;
1626
1627   if (src == NULL)
1628     return NULL;
1629
1630   dest = gfc_get_iterator ();
1631
1632   dest->var = gfc_copy_expr (src->var);
1633   dest->start = gfc_copy_expr (src->start);
1634   dest->end = gfc_copy_expr (src->end);
1635   dest->step = gfc_copy_expr (src->step);
1636
1637   return dest;
1638 }
1639
1640
1641 /* Copy a constructor structure.  */
1642
1643 gfc_constructor *
1644 gfc_copy_constructor (gfc_constructor *src)
1645 {
1646   gfc_constructor *dest;
1647   gfc_constructor *tail;
1648
1649   if (src == NULL)
1650     return NULL;
1651
1652   dest = tail = NULL;
1653   while (src)
1654     {
1655       if (dest == NULL)
1656         dest = tail = gfc_get_constructor ();
1657       else
1658         {
1659           tail->next = gfc_get_constructor ();
1660           tail = tail->next;
1661         }
1662       tail->where = src->where;
1663       tail->expr = gfc_copy_expr (src->expr);
1664       tail->iterator = copy_iterator (src->iterator);
1665       mpz_set (tail->n.offset, src->n.offset);
1666       tail->n.component = src->n.component;
1667       mpz_set (tail->repeat, src->repeat);
1668       src = src->next;
1669     }
1670
1671   return dest;
1672 }
1673
1674
1675 /* Given an array expression and an element number (starting at zero),
1676    return a pointer to the array element.  NULL is returned if the
1677    size of the array has been exceeded.  The expression node returned
1678    remains a part of the array and should not be freed.  Access is not
1679    efficient at all, but this is another place where things do not
1680    have to be particularly fast.  */
1681
1682 gfc_expr *
1683 gfc_get_array_element (gfc_expr *array, int element)
1684 {
1685   expand_info expand_save;
1686   gfc_expr *e;
1687   try rc;
1688
1689   expand_save = current_expand;
1690   current_expand.extract_n = element;
1691   current_expand.expand_work_function = extract_element;
1692   current_expand.extracted = NULL;
1693   current_expand.extract_count = 0;
1694
1695   iter_stack = NULL;
1696
1697   rc = expand_constructor (array->value.constructor);
1698   e = current_expand.extracted;
1699   current_expand = expand_save;
1700
1701   if (rc == FAILURE)
1702     return NULL;
1703
1704   return e;
1705 }
1706
1707
1708 /********* Subroutines for determining the size of an array *********/
1709
1710 /* These are needed just to accommodate RESHAPE().  There are no
1711    diagnostics here, we just return a negative number if something
1712    goes wrong.  */
1713
1714
1715 /* Get the size of single dimension of an array specification.  The
1716    array is guaranteed to be one dimensional.  */
1717
1718 try
1719 spec_dimen_size (gfc_array_spec *as, int dimen, mpz_t *result)
1720 {
1721   if (as == NULL)
1722     return FAILURE;
1723
1724   if (dimen < 0 || dimen > as->rank - 1)
1725     gfc_internal_error ("spec_dimen_size(): Bad dimension");
1726
1727   if (as->type != AS_EXPLICIT
1728       || as->lower[dimen]->expr_type != EXPR_CONSTANT
1729       || as->upper[dimen]->expr_type != EXPR_CONSTANT
1730       || as->lower[dimen]->ts.type != BT_INTEGER
1731       || as->upper[dimen]->ts.type != BT_INTEGER)
1732     return FAILURE;
1733
1734   mpz_init (*result);
1735
1736   mpz_sub (*result, as->upper[dimen]->value.integer,
1737            as->lower[dimen]->value.integer);
1738
1739   mpz_add_ui (*result, *result, 1);
1740
1741   return SUCCESS;
1742 }
1743
1744
1745 try
1746 spec_size (gfc_array_spec *as, mpz_t *result)
1747 {
1748   mpz_t size;
1749   int d;
1750
1751   mpz_init_set_ui (*result, 1);
1752
1753   for (d = 0; d < as->rank; d++)
1754     {
1755       if (spec_dimen_size (as, d, &size) == FAILURE)
1756         {
1757           mpz_clear (*result);
1758           return FAILURE;
1759         }
1760
1761       mpz_mul (*result, *result, size);
1762       mpz_clear (size);
1763     }
1764
1765   return SUCCESS;
1766 }
1767
1768
1769 /* Get the number of elements in an array section.  */
1770
1771 static try
1772 ref_dimen_size (gfc_array_ref *ar, int dimen, mpz_t *result)
1773 {
1774   mpz_t upper, lower, stride;
1775   try t;
1776
1777   if (dimen < 0 || ar == NULL || dimen > ar->dimen - 1)
1778     gfc_internal_error ("ref_dimen_size(): Bad dimension");
1779
1780   switch (ar->dimen_type[dimen])
1781     {
1782     case DIMEN_ELEMENT:
1783       mpz_init (*result);
1784       mpz_set_ui (*result, 1);
1785       t = SUCCESS;
1786       break;
1787
1788     case DIMEN_VECTOR:
1789       t = gfc_array_size (ar->start[dimen], result);    /* Recurse! */
1790       break;
1791
1792     case DIMEN_RANGE:
1793       mpz_init (upper);
1794       mpz_init (lower);
1795       mpz_init (stride);
1796       t = FAILURE;
1797
1798       if (ar->start[dimen] == NULL)
1799         {
1800           if (ar->as->lower[dimen] == NULL
1801               || ar->as->lower[dimen]->expr_type != EXPR_CONSTANT)
1802             goto cleanup;
1803           mpz_set (lower, ar->as->lower[dimen]->value.integer);
1804         }
1805       else
1806         {
1807           if (ar->start[dimen]->expr_type != EXPR_CONSTANT)
1808             goto cleanup;
1809           mpz_set (lower, ar->start[dimen]->value.integer);
1810         }
1811
1812       if (ar->end[dimen] == NULL)
1813         {
1814           if (ar->as->upper[dimen] == NULL
1815               || ar->as->upper[dimen]->expr_type != EXPR_CONSTANT)
1816             goto cleanup;
1817           mpz_set (upper, ar->as->upper[dimen]->value.integer);
1818         }
1819       else
1820         {
1821           if (ar->end[dimen]->expr_type != EXPR_CONSTANT)
1822             goto cleanup;
1823           mpz_set (upper, ar->end[dimen]->value.integer);
1824         }
1825
1826       if (ar->stride[dimen] == NULL)
1827         mpz_set_ui (stride, 1);
1828       else
1829         {
1830           if (ar->stride[dimen]->expr_type != EXPR_CONSTANT)
1831             goto cleanup;
1832           mpz_set (stride, ar->stride[dimen]->value.integer);
1833         }
1834
1835       mpz_init (*result);
1836       mpz_sub (*result, upper, lower);
1837       mpz_add (*result, *result, stride);
1838       mpz_div (*result, *result, stride);
1839
1840       /* Zero stride caught earlier.  */
1841       if (mpz_cmp_ui (*result, 0) < 0)
1842         mpz_set_ui (*result, 0);
1843       t = SUCCESS;
1844
1845     cleanup:
1846       mpz_clear (upper);
1847       mpz_clear (lower);
1848       mpz_clear (stride);
1849       return t;
1850
1851     default:
1852       gfc_internal_error ("ref_dimen_size(): Bad dimen_type");
1853     }
1854
1855   return t;
1856 }
1857
1858
1859 static try
1860 ref_size (gfc_array_ref *ar, mpz_t *result)
1861 {
1862   mpz_t size;
1863   int d;
1864
1865   mpz_init_set_ui (*result, 1);
1866
1867   for (d = 0; d < ar->dimen; d++)
1868     {
1869       if (ref_dimen_size (ar, d, &size) == FAILURE)
1870         {
1871           mpz_clear (*result);
1872           return FAILURE;
1873         }
1874
1875       mpz_mul (*result, *result, size);
1876       mpz_clear (size);
1877     }
1878
1879   return SUCCESS;
1880 }
1881
1882
1883 /* Given an array expression and a dimension, figure out how many
1884    elements it has along that dimension.  Returns SUCCESS if we were
1885    able to return a result in the 'result' variable, FAILURE
1886    otherwise.  */
1887
1888 try
1889 gfc_array_dimen_size (gfc_expr *array, int dimen, mpz_t *result)
1890 {
1891   gfc_ref *ref;
1892   int i;
1893
1894   if (dimen < 0 || array == NULL || dimen > array->rank - 1)
1895     gfc_internal_error ("gfc_array_dimen_size(): Bad dimension");
1896
1897   switch (array->expr_type)
1898     {
1899     case EXPR_VARIABLE:
1900     case EXPR_FUNCTION:
1901       for (ref = array->ref; ref; ref = ref->next)
1902         {
1903           if (ref->type != REF_ARRAY)
1904             continue;
1905
1906           if (ref->u.ar.type == AR_FULL)
1907             return spec_dimen_size (ref->u.ar.as, dimen, result);
1908
1909           if (ref->u.ar.type == AR_SECTION)
1910             {
1911               for (i = 0; dimen >= 0; i++)
1912                 if (ref->u.ar.dimen_type[i] != DIMEN_ELEMENT)
1913                   dimen--;
1914
1915               return ref_dimen_size (&ref->u.ar, i - 1, result);
1916             }
1917         }
1918
1919       if (array->shape && array->shape[dimen])
1920         {
1921           mpz_init_set (*result, array->shape[dimen]);
1922           return SUCCESS;
1923         }
1924
1925       if (spec_dimen_size (array->symtree->n.sym->as, dimen, result) == FAILURE)
1926         return FAILURE;
1927
1928       break;
1929
1930     case EXPR_ARRAY:
1931       if (array->shape == NULL) {
1932         /* Expressions with rank > 1 should have "shape" properly set */
1933         if ( array->rank != 1 )
1934           gfc_internal_error ("gfc_array_dimen_size(): Bad EXPR_ARRAY expr");
1935         return gfc_array_size(array, result);
1936       }
1937
1938       /* Fall through */
1939     default:
1940       if (array->shape == NULL)
1941         return FAILURE;
1942
1943       mpz_init_set (*result, array->shape[dimen]);
1944
1945       break;
1946     }
1947
1948   return SUCCESS;
1949 }
1950
1951
1952 /* Given an array expression, figure out how many elements are in the
1953    array.  Returns SUCCESS if this is possible, and sets the 'result'
1954    variable.  Otherwise returns FAILURE.  */
1955
1956 try
1957 gfc_array_size (gfc_expr *array, mpz_t *result)
1958 {
1959   expand_info expand_save;
1960   gfc_ref *ref;
1961   int i, flag;
1962   try t;
1963
1964   switch (array->expr_type)
1965     {
1966     case EXPR_ARRAY:
1967       flag = gfc_suppress_error;
1968       gfc_suppress_error = 1;
1969
1970       expand_save = current_expand;
1971
1972       current_expand.count = result;
1973       mpz_init_set_ui (*result, 0);
1974
1975       current_expand.expand_work_function = count_elements;
1976       iter_stack = NULL;
1977
1978       t = expand_constructor (array->value.constructor);
1979       gfc_suppress_error = flag;
1980
1981       if (t == FAILURE)
1982         mpz_clear (*result);
1983       current_expand = expand_save;
1984       return t;
1985
1986     case EXPR_VARIABLE:
1987       for (ref = array->ref; ref; ref = ref->next)
1988         {
1989           if (ref->type != REF_ARRAY)
1990             continue;
1991
1992           if (ref->u.ar.type == AR_FULL)
1993             return spec_size (ref->u.ar.as, result);
1994
1995           if (ref->u.ar.type == AR_SECTION)
1996             return ref_size (&ref->u.ar, result);
1997         }
1998
1999       return spec_size (array->symtree->n.sym->as, result);
2000
2001
2002     default:
2003       if (array->rank == 0 || array->shape == NULL)
2004         return FAILURE;
2005
2006       mpz_init_set_ui (*result, 1);
2007
2008       for (i = 0; i < array->rank; i++)
2009         mpz_mul (*result, *result, array->shape[i]);
2010
2011       break;
2012     }
2013
2014   return SUCCESS;
2015 }
2016
2017
2018 /* Given an array reference, return the shape of the reference in an
2019    array of mpz_t integers.  */
2020
2021 try
2022 gfc_array_ref_shape (gfc_array_ref *ar, mpz_t *shape)
2023 {
2024   int d;
2025   int i;
2026
2027   d = 0;
2028
2029   switch (ar->type)
2030     {
2031     case AR_FULL:
2032       for (; d < ar->as->rank; d++)
2033         if (spec_dimen_size (ar->as, d, &shape[d]) == FAILURE)
2034           goto cleanup;
2035
2036       return SUCCESS;
2037
2038     case AR_SECTION:
2039       for (i = 0; i < ar->dimen; i++)
2040         {
2041           if (ar->dimen_type[i] != DIMEN_ELEMENT)
2042             {
2043               if (ref_dimen_size (ar, i, &shape[d]) == FAILURE)
2044                 goto cleanup;
2045               d++;
2046             }
2047         }
2048
2049       return SUCCESS;
2050
2051     default:
2052       break;
2053     }
2054
2055 cleanup:
2056   for (d--; d >= 0; d--)
2057     mpz_clear (shape[d]);
2058
2059   return FAILURE;
2060 }
2061
2062
2063 /* Given an array expression, find the array reference structure that
2064    characterizes the reference.  */
2065
2066 gfc_array_ref *
2067 gfc_find_array_ref (gfc_expr *e)
2068 {
2069   gfc_ref *ref;
2070
2071   for (ref = e->ref; ref; ref = ref->next)
2072     if (ref->type == REF_ARRAY
2073         && (ref->u.ar.type == AR_FULL || ref->u.ar.type == AR_SECTION))
2074       break;
2075
2076   if (ref == NULL)
2077     gfc_internal_error ("gfc_find_array_ref(): No ref found");
2078
2079   return &ref->u.ar;
2080 }
2081
2082
2083 /* Find out if an array shape is known at compile time.  */
2084
2085 int
2086 gfc_is_compile_time_shape (gfc_array_spec *as)
2087 {
2088   int i;
2089
2090   if (as->type != AS_EXPLICIT)
2091     return 0;
2092
2093   for (i = 0; i < as->rank; i++)
2094     if (!gfc_is_constant_expr (as->lower[i])
2095         || !gfc_is_constant_expr (as->upper[i]))
2096       return 0;
2097
2098   return 1;
2099 }