gcc/fortran/array.c

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