gcc/fortran/array.c

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