gcc/fortran/expr.c

   1 /* Routines for manipulation of expression nodes.
   2    Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009
   3    Free Software Foundation, Inc.
   4    Contributed by Andy Vaught
   5
   6 This file is part of GCC.
   7
   8 GCC is free software; you can redistribute it and/or modify it under
   9 the terms of the GNU General Public License as published by the Free
  10 Software Foundation; either version 3, or (at your option) any later
  11 version.
  12
  13 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
  14 WARRANTY; without even the implied warranty of MERCHANTABILITY or
  15 FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
  16 for more details.
  17
  18 You should have received a copy of the GNU General Public License
  19 along with GCC; see the file COPYING3.  If not see
  20 <http://www.gnu.org/licenses/>.  */
  21
  22 #include "config.h"
  23 #include "system.h"
  24 #include "gfortran.h"
  25 #include "arith.h"
  26 #include "match.h"
  27 #include "target-memory.h" /* for gfc_convert_boz */
  28
  29 /* Get a new expr node.  */
  30
  31 gfc_expr *
  32 gfc_get_expr (void)
  33 {
  34   gfc_expr *e;
  35
  36   e = XCNEW (gfc_expr);
  37   gfc_clear_ts (&e->ts);
  38   e->shape = NULL;
  39   e->ref = NULL;
  40   e->symtree = NULL;
  41   e->con_by_offset = NULL;
  42   return e;
  43 }
  44
  45
  46 /* Free an argument list and everything below it.  */
  47
  48 void
  49 gfc_free_actual_arglist (gfc_actual_arglist *a1)
  50 {
  51   gfc_actual_arglist *a2;
  52
  53   while (a1)
  54     {
  55       a2 = a1->next;
  56       gfc_free_expr (a1->expr);
  57       gfc_free (a1);
  58       a1 = a2;
  59     }
  60 }
  61
  62
  63 /* Copy an arglist structure and all of the arguments.  */
  64
  65 gfc_actual_arglist *
  66 gfc_copy_actual_arglist (gfc_actual_arglist *p)
  67 {
  68   gfc_actual_arglist *head, *tail, *new_arg;
  69
  70   head = tail = NULL;
  71
  72   for (; p; p = p->next)
  73     {
  74       new_arg = gfc_get_actual_arglist ();
  75       *new_arg = *p;
  76
  77       new_arg->expr = gfc_copy_expr (p->expr);
  78       new_arg->next = NULL;
  79
  80       if (head == NULL)
  81         head = new_arg;
  82       else
  83         tail->next = new_arg;
  84
  85       tail = new_arg;
  86     }
  87
  88   return head;
  89 }
  90
  91
  92 /* Free a list of reference structures.  */
  93
  94 void
  95 gfc_free_ref_list (gfc_ref *p)
  96 {
  97   gfc_ref *q;
  98   int i;
  99
 100   for (; p; p = q)
 101     {
 102       q = p->next;
 103
 104       switch (p->type)
 105         {
 106         case REF_ARRAY:
 107           for (i = 0; i < GFC_MAX_DIMENSIONS; i++)
 108             {
 109               gfc_free_expr (p->u.ar.start[i]);
 110               gfc_free_expr (p->u.ar.end[i]);
 111               gfc_free_expr (p->u.ar.stride[i]);
 112             }
 113
 114           break;
 115
 116         case REF_SUBSTRING:
 117           gfc_free_expr (p->u.ss.start);
 118           gfc_free_expr (p->u.ss.end);
 119           break;
 120
 121         case REF_COMPONENT:
 122           break;
 123         }
 124
 125       gfc_free (p);
 126     }
 127 }
 128
 129
 130 /* Workhorse function for gfc_free_expr() that frees everything
 131    beneath an expression node, but not the node itself.  This is
 132    useful when we want to simplify a node and replace it with
 133    something else or the expression node belongs to another structure.  */
 134
 135 static void
 136 free_expr0 (gfc_expr *e)
 137 {
 138   int n;
 139
 140   switch (e->expr_type)
 141     {
 142     case EXPR_CONSTANT:
 143       /* Free any parts of the value that need freeing.  */
 144       switch (e->ts.type)
 145         {
 146         case BT_INTEGER:
 147           mpz_clear (e->value.integer);
 148           break;
 149
 150         case BT_REAL:
 151           mpfr_clear (e->value.real);
 152           break;
 153
 154         case BT_CHARACTER:
 155           gfc_free (e->value.character.string);
 156           break;
 157
 158         case BT_COMPLEX:
 159           mpfr_clear (e->value.complex.r);
 160           mpfr_clear (e->value.complex.i);
 161           break;
 162
 163         default:
 164           break;
 165         }
 166
 167       /* Free the representation.  */
 168       if (e->representation.string)
 169         gfc_free (e->representation.string);
 170
 171       break;
 172
 173     case EXPR_OP:
 174       if (e->value.op.op1 != NULL)
 175         gfc_free_expr (e->value.op.op1);
 176       if (e->value.op.op2 != NULL)
 177         gfc_free_expr (e->value.op.op2);
 178       break;
 179
 180     case EXPR_FUNCTION:
 181       gfc_free_actual_arglist (e->value.function.actual);
 182       break;
 183
 184     case EXPR_COMPCALL:
 185       gfc_free_actual_arglist (e->value.compcall.actual);
 186       break;
 187
 188     case EXPR_VARIABLE:
 189       break;
 190
 191     case EXPR_ARRAY:
 192     case EXPR_STRUCTURE:
 193       gfc_free_constructor (e->value.constructor);
 194       break;
 195
 196     case EXPR_SUBSTRING:
 197       gfc_free (e->value.character.string);
 198       break;
 199
 200     case EXPR_NULL:
 201       break;
 202
 203     default:
 204       gfc_internal_error ("free_expr0(): Bad expr type");
 205     }
 206
 207   /* Free a shape array.  */
 208   if (e->shape != NULL)
 209     {
 210       for (n = 0; n < e->rank; n++)
 211         mpz_clear (e->shape[n]);
 212
 213       gfc_free (e->shape);
 214     }
 215
 216   gfc_free_ref_list (e->ref);
 217
 218   memset (e, '\0', sizeof (gfc_expr));
 219 }
 220
 221
 222 /* Free an expression node and everything beneath it.  */
 223
 224 void
 225 gfc_free_expr (gfc_expr *e)
 226 {
 227   if (e == NULL)
 228     return;
 229   if (e->con_by_offset)
 230     splay_tree_delete (e->con_by_offset);
 231   free_expr0 (e);
 232   gfc_free (e);
 233 }
 234
 235
 236 /* Graft the *src expression onto the *dest subexpression.  */
 237
 238 void
 239 gfc_replace_expr (gfc_expr *dest, gfc_expr *src)
 240 {
 241   free_expr0 (dest);
 242   *dest = *src;
 243   gfc_free (src);
 244 }
 245
 246
 247 /* Try to extract an integer constant from the passed expression node.
 248    Returns an error message or NULL if the result is set.  It is
 249    tempting to generate an error and return SUCCESS or FAILURE, but
 250    failure is OK for some callers.  */
 251
 252 const char *
 253 gfc_extract_int (gfc_expr *expr, int *result)
 254 {
 255   if (expr->expr_type != EXPR_CONSTANT)
 256     return _("Constant expression required at %C");
 257
 258   if (expr->ts.type != BT_INTEGER)
 259     return _("Integer expression required at %C");
 260
 261   if ((mpz_cmp_si (expr->value.integer, INT_MAX) > 0)
 262       || (mpz_cmp_si (expr->value.integer, INT_MIN) < 0))
 263     {
 264       return _("Integer value too large in expression at %C");
 265     }
 266
 267   *result = (int) mpz_get_si (expr->value.integer);
 268
 269   return NULL;
 270 }
 271
 272
 273 /* Recursively copy a list of reference structures.  */
 274
 275 gfc_ref *
 276 gfc_copy_ref (gfc_ref *src)
 277 {
 278   gfc_array_ref *ar;
 279   gfc_ref *dest;
 280
 281   if (src == NULL)
 282     return NULL;
 283
 284   dest = gfc_get_ref ();
 285   dest->type = src->type;
 286
 287   switch (src->type)
 288     {
 289     case REF_ARRAY:
 290       ar = gfc_copy_array_ref (&src->u.ar);
 291       dest->u.ar = *ar;
 292       gfc_free (ar);
 293       break;
 294
 295     case REF_COMPONENT:
 296       dest->u.c = src->u.c;
 297       break;
 298
 299     case REF_SUBSTRING:
 300       dest->u.ss = src->u.ss;
 301       dest->u.ss.start = gfc_copy_expr (src->u.ss.start);
 302       dest->u.ss.end = gfc_copy_expr (src->u.ss.end);
 303       break;
 304     }
 305
 306   dest->next = gfc_copy_ref (src->next);
 307
 308   return dest;
 309 }
 310
 311
 312 /* Detect whether an expression has any vector index array references.  */
 313
 314 int
 315 gfc_has_vector_index (gfc_expr *e)
 316 {
 317   gfc_ref *ref;
 318   int i;
 319   for (ref = e->ref; ref; ref = ref->next)
 320     if (ref->type == REF_ARRAY)
 321       for (i = 0; i < ref->u.ar.dimen; i++)
 322         if (ref->u.ar.dimen_type[i] == DIMEN_VECTOR)
 323           return 1;
 324   return 0;
 325 }
 326
 327
 328 /* Copy a shape array.  */
 329
 330 mpz_t *
 331 gfc_copy_shape (mpz_t *shape, int rank)
 332 {
 333   mpz_t *new_shape;
 334   int n;
 335
 336   if (shape == NULL)
 337     return NULL;
 338
 339   new_shape = gfc_get_shape (rank);
 340
 341   for (n = 0; n < rank; n++)
 342     mpz_init_set (new_shape[n], shape[n]);
 343
 344   return new_shape;
 345 }
 346
 347
 348 /* Copy a shape array excluding dimension N, where N is an integer
 349    constant expression.  Dimensions are numbered in fortran style --
 350    starting with ONE.
 351
 352    So, if the original shape array contains R elements
 353       { s1 ... sN-1  sN  sN+1 ... sR-1 sR}
 354    the result contains R-1 elements:
 355       { s1 ... sN-1  sN+1    ...  sR-1}
 356
 357    If anything goes wrong -- N is not a constant, its value is out
 358    of range -- or anything else, just returns NULL.  */
 359
 360 mpz_t *
 361 gfc_copy_shape_excluding (mpz_t *shape, int rank, gfc_expr *dim)
 362 {
 363   mpz_t *new_shape, *s;
 364   int i, n;
 365
 366   if (shape == NULL
 367       || rank <= 1
 368       || dim == NULL
 369       || dim->expr_type != EXPR_CONSTANT
 370       || dim->ts.type != BT_INTEGER)
 371     return NULL;
 372
 373   n = mpz_get_si (dim->value.integer);
 374   n--; /* Convert to zero based index.  */
 375   if (n < 0 || n >= rank)
 376     return NULL;
 377
 378   s = new_shape = gfc_get_shape (rank - 1);
 379
 380   for (i = 0; i < rank; i++)
 381     {
 382       if (i == n)
 383         continue;
 384       mpz_init_set (*s, shape[i]);
 385       s++;
 386     }
 387
 388   return new_shape;
 389 }
 390
 391
 392 /* Given an expression pointer, return a copy of the expression.  This
 393    subroutine is recursive.  */
 394
 395 gfc_expr *
 396 gfc_copy_expr (gfc_expr *p)
 397 {
 398   gfc_expr *q;
 399   gfc_char_t *s;
 400   char *c;
 401
 402   if (p == NULL)
 403     return NULL;
 404
 405   q = gfc_get_expr ();
 406   *q = *p;
 407
 408   switch (q->expr_type)
 409     {
 410     case EXPR_SUBSTRING:
 411       s = gfc_get_wide_string (p->value.character.length + 1);
 412       q->value.character.string = s;
 413       memcpy (s, p->value.character.string,
 414               (p->value.character.length + 1) * sizeof (gfc_char_t));
 415       break;
 416
 417     case EXPR_CONSTANT:
 418       /* Copy target representation, if it exists.  */
 419       if (p->representation.string)
 420         {
 421           c = XCNEWVEC (char, p->representation.length + 1);
 422           q->representation.string = c;
 423           memcpy (c, p->representation.string, (p->representation.length + 1));
 424         }
 425
 426       /* Copy the values of any pointer components of p->value.  */
 427       switch (q->ts.type)
 428         {
 429         case BT_INTEGER:
 430           mpz_init_set (q->value.integer, p->value.integer);
 431           break;
 432
 433         case BT_REAL:
 434           gfc_set_model_kind (q->ts.kind);
 435           mpfr_init (q->value.real);
 436           mpfr_set (q->value.real, p->value.real, GFC_RND_MODE);
 437           break;
 438
 439         case BT_COMPLEX:
 440           gfc_set_model_kind (q->ts.kind);
 441           mpfr_init (q->value.complex.r);
 442           mpfr_init (q->value.complex.i);
 443           mpfr_set (q->value.complex.r, p->value.complex.r, GFC_RND_MODE);
 444           mpfr_set (q->value.complex.i, p->value.complex.i, GFC_RND_MODE);
 445           break;
 446
 447         case BT_CHARACTER:
 448           if (p->representation.string)
 449             q->value.character.string
 450               = gfc_char_to_widechar (q->representation.string);
 451           else
 452             {
 453               s = gfc_get_wide_string (p->value.character.length + 1);
 454               q->value.character.string = s;
 455
 456               /* This is the case for the C_NULL_CHAR named constant.  */
 457               if (p->value.character.length == 0
 458                   && (p->ts.is_c_interop || p->ts.is_iso_c))
 459                 {
 460                   *s = '\0';
 461                   /* Need to set the length to 1 to make sure the NUL
 462                      terminator is copied.  */
 463                   q->value.character.length = 1;
 464                 }
 465               else
 466                 memcpy (s, p->value.character.string,
 467                         (p->value.character.length + 1) * sizeof (gfc_char_t));
 468             }
 469           break;
 470
 471         case BT_HOLLERITH:
 472         case BT_LOGICAL:
 473         case BT_DERIVED:
 474           break;                /* Already done.  */
 475
 476         case BT_PROCEDURE:
 477         case BT_VOID:
 478            /* Should never be reached.  */
 479         case BT_UNKNOWN:
 480           gfc_internal_error ("gfc_copy_expr(): Bad expr node");
 481           /* Not reached.  */
 482         }
 483
 484       break;
 485
 486     case EXPR_OP:
 487       switch (q->value.op.op)
 488         {
 489         case INTRINSIC_NOT:
 490         case INTRINSIC_PARENTHESES:
 491         case INTRINSIC_UPLUS:
 492         case INTRINSIC_UMINUS:
 493           q->value.op.op1 = gfc_copy_expr (p->value.op.op1);
 494           break;
 495
 496         default:                /* Binary operators.  */
 497           q->value.op.op1 = gfc_copy_expr (p->value.op.op1);
 498           q->value.op.op2 = gfc_copy_expr (p->value.op.op2);
 499           break;
 500         }
 501
 502       break;
 503
 504     case EXPR_FUNCTION:
 505       q->value.function.actual =
 506         gfc_copy_actual_arglist (p->value.function.actual);
 507       break;
 508
 509     case EXPR_COMPCALL:
 510       q->value.compcall.actual =
 511         gfc_copy_actual_arglist (p->value.compcall.actual);
 512       q->value.compcall.tbp = p->value.compcall.tbp;
 513       break;
 514
 515     case EXPR_STRUCTURE:
 516     case EXPR_ARRAY:
 517       q->value.constructor = gfc_copy_constructor (p->value.constructor);
 518       break;
 519
 520     case EXPR_VARIABLE:
 521     case EXPR_NULL:
 522       break;
 523     }
 524
 525   q->shape = gfc_copy_shape (p->shape, p->rank);
 526
 527   q->ref = gfc_copy_ref (p->ref);
 528
 529   return q;
 530 }
 531
 532
 533 /* Return the maximum kind of two expressions.  In general, higher
 534    kind numbers mean more precision for numeric types.  */
 535
 536 int
 537 gfc_kind_max (gfc_expr *e1, gfc_expr *e2)
 538 {
 539   return (e1->ts.kind > e2->ts.kind) ? e1->ts.kind : e2->ts.kind;
 540 }
 541
 542
 543 /* Returns nonzero if the type is numeric, zero otherwise.  */
 544
 545 static int
 546 numeric_type (bt type)
 547 {
 548   return type == BT_COMPLEX || type == BT_REAL || type == BT_INTEGER;
 549 }
 550
 551
 552 /* Returns nonzero if the typespec is a numeric type, zero otherwise.  */
 553
 554 int
 555 gfc_numeric_ts (gfc_typespec *ts)
 556 {
 557   return numeric_type (ts->type);
 558 }
 559
 560
 561 /* Returns an expression node that is an integer constant.  */
 562
 563 gfc_expr *
 564 gfc_int_expr (int i)
 565 {
 566   gfc_expr *p;
 567
 568   p = gfc_get_expr ();
 569
 570   p->expr_type = EXPR_CONSTANT;
 571   p->ts.type = BT_INTEGER;
 572   p->ts.kind = gfc_default_integer_kind;
 573
 574   p->where = gfc_current_locus;
 575   mpz_init_set_si (p->value.integer, i);
 576
 577   return p;
 578 }
 579
 580
 581 /* Returns an expression node that is a logical constant.  */
 582
 583 gfc_expr *
 584 gfc_logical_expr (int i, locus *where)
 585 {
 586   gfc_expr *p;
 587
 588   p = gfc_get_expr ();
 589
 590   p->expr_type = EXPR_CONSTANT;
 591   p->ts.type = BT_LOGICAL;
 592   p->ts.kind = gfc_default_logical_kind;
 593
 594   if (where == NULL)
 595     where = &gfc_current_locus;
 596   p->where = *where;
 597   p->value.logical = i;
 598
 599   return p;
 600 }
 601
 602
 603 /* Return an expression node with an optional argument list attached.
 604    A variable number of gfc_expr pointers are strung together in an
 605    argument list with a NULL pointer terminating the list.  */
 606
 607 gfc_expr *
 608 gfc_build_conversion (gfc_expr *e)
 609 {
 610   gfc_expr *p;
 611
 612   p = gfc_get_expr ();
 613   p->expr_type = EXPR_FUNCTION;
 614   p->symtree = NULL;
 615   p->value.function.actual = NULL;
 616
 617   p->value.function.actual = gfc_get_actual_arglist ();
 618   p->value.function.actual->expr = e;
 619
 620   return p;
 621 }
 622
 623
 624 /* Given an expression node with some sort of numeric binary
 625    expression, insert type conversions required to make the operands
 626    have the same type.
 627
 628    The exception is that the operands of an exponential don't have to
 629    have the same type.  If possible, the base is promoted to the type
 630    of the exponent.  For example, 1**2.3 becomes 1.0**2.3, but
 631    1.0**2 stays as it is.  */
 632
 633 void
 634 gfc_type_convert_binary (gfc_expr *e)
 635 {
 636   gfc_expr *op1, *op2;
 637
 638   op1 = e->value.op.op1;
 639   op2 = e->value.op.op2;
 640
 641   if (op1->ts.type == BT_UNKNOWN || op2->ts.type == BT_UNKNOWN)
 642     {
 643       gfc_clear_ts (&e->ts);
 644       return;
 645     }
 646
 647   /* Kind conversions of same type.  */
 648   if (op1->ts.type == op2->ts.type)
 649     {
 650       if (op1->ts.kind == op2->ts.kind)
 651         {
 652           /* No type conversions.  */
 653           e->ts = op1->ts;
 654           goto done;
 655         }
 656
 657       if (op1->ts.kind > op2->ts.kind)
 658         gfc_convert_type (op2, &op1->ts, 2);
 659       else
 660         gfc_convert_type (op1, &op2->ts, 2);
 661
 662       e->ts = op1->ts;
 663       goto done;
 664     }
 665
 666   /* Integer combined with real or complex.  */
 667   if (op2->ts.type == BT_INTEGER)
 668     {
 669       e->ts = op1->ts;
 670
 671       /* Special case for ** operator.  */
 672       if (e->value.op.op == INTRINSIC_POWER)
 673         goto done;
 674
 675       gfc_convert_type (e->value.op.op2, &e->ts, 2);
 676       goto done;
 677     }
 678
 679   if (op1->ts.type == BT_INTEGER)
 680     {
 681       e->ts = op2->ts;
 682       gfc_convert_type (e->value.op.op1, &e->ts, 2);
 683       goto done;
 684     }
 685
 686   /* Real combined with complex.  */
 687   e->ts.type = BT_COMPLEX;
 688   if (op1->ts.kind > op2->ts.kind)
 689     e->ts.kind = op1->ts.kind;
 690   else
 691     e->ts.kind = op2->ts.kind;
 692   if (op1->ts.type != BT_COMPLEX || op1->ts.kind != e->ts.kind)
 693     gfc_convert_type (e->value.op.op1, &e->ts, 2);
 694   if (op2->ts.type != BT_COMPLEX || op2->ts.kind != e->ts.kind)
 695     gfc_convert_type (e->value.op.op2, &e->ts, 2);
 696
 697 done:
 698   return;
 699 }
 700
 701
 702 static match
 703 check_specification_function (gfc_expr *e)
 704 {
 705   gfc_symbol *sym;
 706
 707   if (!e->symtree)
 708     return MATCH_NO;
 709
 710   sym = e->symtree->n.sym;
 711
 712   /* F95, 7.1.6.2; F2003, 7.1.7  */
 713   if (sym
 714       && sym->attr.function
 715       && sym->attr.pure
 716       && !sym->attr.intrinsic
 717       && !sym->attr.recursive
 718       && sym->attr.proc != PROC_INTERNAL
 719       && sym->attr.proc != PROC_ST_FUNCTION
 720       && sym->attr.proc != PROC_UNKNOWN
 721       && sym->formal == NULL)
 722     return MATCH_YES;
 723
 724   return MATCH_NO;
 725 }
 726
 727 /* Function to determine if an expression is constant or not.  This
 728    function expects that the expression has already been simplified.  */
 729
 730 int
 731 gfc_is_constant_expr (gfc_expr *e)
 732 {
 733   gfc_constructor *c;
 734   gfc_actual_arglist *arg;
 735   int rv;
 736
 737   if (e == NULL)
 738     return 1;
 739
 740   switch (e->expr_type)
 741     {
 742     case EXPR_OP:
 743       rv = (gfc_is_constant_expr (e->value.op.op1)
 744             && (e->value.op.op2 == NULL
 745                 || gfc_is_constant_expr (e->value.op.op2)));
 746       break;
 747
 748     case EXPR_VARIABLE:
 749       rv = 0;
 750       break;
 751
 752     case EXPR_FUNCTION:
 753       /* Specification functions are constant.  */
 754       if (check_specification_function (e) == MATCH_YES)
 755         {
 756           rv = 1;
 757           break;
 758         }
 759
 760       /* Call to intrinsic with at least one argument.  */
 761       rv = 0;
 762       if (e->value.function.isym && e->value.function.actual)
 763         {
 764           for (arg = e->value.function.actual; arg; arg = arg->next)
 765             {
 766               if (!gfc_is_constant_expr (arg->expr))
 767                 break;
 768             }
 769           if (arg == NULL)
 770             rv = 1;
 771         }
 772       break;
 773
 774     case EXPR_CONSTANT:
 775     case EXPR_NULL:
 776       rv = 1;
 777       break;
 778
 779     case EXPR_SUBSTRING:
 780       rv = e->ref == NULL || (gfc_is_constant_expr (e->ref->u.ss.start)
 781                               && gfc_is_constant_expr (e->ref->u.ss.end));
 782       break;
 783
 784     case EXPR_STRUCTURE:
 785       rv = 0;
 786       for (c = e->value.constructor; c; c = c->next)
 787         if (!gfc_is_constant_expr (c->expr))
 788           break;
 789
 790       if (c == NULL)
 791         rv = 1;
 792       break;
 793
 794     case EXPR_ARRAY:
 795       rv = gfc_constant_ac (e);
 796       break;
 797
 798     default:
 799       gfc_internal_error ("gfc_is_constant_expr(): Unknown expression type");
 800     }
 801
 802   return rv;
 803 }
 804
 805
 806 /* Is true if an array reference is followed by a component or substring
 807    reference.  */
 808 bool
 809 is_subref_array (gfc_expr * e)
 810 {
 811   gfc_ref * ref;
 812   bool seen_array;
 813
 814   if (e->expr_type != EXPR_VARIABLE)
 815     return false;
 816
 817   if (e->symtree->n.sym->attr.subref_array_pointer)
 818     return true;
 819
 820   seen_array = false;
 821   for (ref = e->ref; ref; ref = ref->next)
 822     {
 823       if (ref->type == REF_ARRAY
 824             && ref->u.ar.type != AR_ELEMENT)
 825         seen_array = true;
 826
 827       if (seen_array
 828             && ref->type != REF_ARRAY)
 829         return seen_array;
 830     }
 831   return false;
 832 }
 833
 834
 835 /* Try to collapse intrinsic expressions.  */
 836
 837 static gfc_try
 838 simplify_intrinsic_op (gfc_expr *p, int type)
 839 {
 840   gfc_intrinsic_op op;
 841   gfc_expr *op1, *op2, *result;
 842
 843   if (p->value.op.op == INTRINSIC_USER)
 844     return SUCCESS;
 845
 846   op1 = p->value.op.op1;
 847   op2 = p->value.op.op2;
 848   op  = p->value.op.op;
 849
 850   if (gfc_simplify_expr (op1, type) == FAILURE)
 851     return FAILURE;
 852   if (gfc_simplify_expr (op2, type) == FAILURE)
 853     return FAILURE;
 854
 855   if (!gfc_is_constant_expr (op1)
 856       || (op2 != NULL && !gfc_is_constant_expr (op2)))
 857     return SUCCESS;
 858
 859   /* Rip p apart.  */
 860   p->value.op.op1 = NULL;
 861   p->value.op.op2 = NULL;
 862
 863   switch (op)
 864     {
 865     case INTRINSIC_PARENTHESES:
 866       result = gfc_parentheses (op1);
 867       break;
 868
 869     case INTRINSIC_UPLUS:
 870       result = gfc_uplus (op1);
 871       break;
 872
 873     case INTRINSIC_UMINUS:
 874       result = gfc_uminus (op1);
 875       break;
 876
 877     case INTRINSIC_PLUS:
 878       result = gfc_add (op1, op2);
 879       break;
 880
 881     case INTRINSIC_MINUS:
 882       result = gfc_subtract (op1, op2);
 883       break;
 884
 885     case INTRINSIC_TIMES:
 886       result = gfc_multiply (op1, op2);
 887       break;
 888
 889     case INTRINSIC_DIVIDE:
 890       result = gfc_divide (op1, op2);
 891       break;
 892
 893     case INTRINSIC_POWER:
 894       result = gfc_power (op1, op2);
 895       break;
 896
 897     case INTRINSIC_CONCAT:
 898       result = gfc_concat (op1, op2);
 899       break;
 900
 901     case INTRINSIC_EQ:
 902     case INTRINSIC_EQ_OS:
 903       result = gfc_eq (op1, op2, op);
 904       break;
 905
 906     case INTRINSIC_NE:
 907     case INTRINSIC_NE_OS:
 908       result = gfc_ne (op1, op2, op);
 909       break;
 910
 911     case INTRINSIC_GT:
 912     case INTRINSIC_GT_OS:
 913       result = gfc_gt (op1, op2, op);
 914       break;
 915
 916     case INTRINSIC_GE:
 917     case INTRINSIC_GE_OS:
 918       result = gfc_ge (op1, op2, op);
 919       break;
 920
 921     case INTRINSIC_LT:
 922     case INTRINSIC_LT_OS:
 923       result = gfc_lt (op1, op2, op);
 924       break;
 925
 926     case INTRINSIC_LE:
 927     case INTRINSIC_LE_OS:
 928       result = gfc_le (op1, op2, op);
 929       break;
 930
 931     case INTRINSIC_NOT:
 932       result = gfc_not (op1);
 933       break;
 934
 935     case INTRINSIC_AND:
 936       result = gfc_and (op1, op2);
 937       break;
 938
 939     case INTRINSIC_OR:
 940       result = gfc_or (op1, op2);
 941       break;
 942
 943     case INTRINSIC_EQV:
 944       result = gfc_eqv (op1, op2);
 945       break;
 946
 947     case INTRINSIC_NEQV:
 948       result = gfc_neqv (op1, op2);
 949       break;
 950
 951     default:
 952       gfc_internal_error ("simplify_intrinsic_op(): Bad operator");
 953     }
 954
 955   if (result == NULL)
 956     {
 957       gfc_free_expr (op1);
 958       gfc_free_expr (op2);
 959       return FAILURE;
 960     }
 961
 962   result->rank = p->rank;
 963   result->where = p->where;
 964   gfc_replace_expr (p, result);
 965
 966   return SUCCESS;
 967 }
 968
 969
 970 /* Subroutine to simplify constructor expressions.  Mutually recursive
 971    with gfc_simplify_expr().  */
 972
 973 static gfc_try
 974 simplify_constructor (gfc_constructor *c, int type)
 975 {
 976   gfc_expr *p;
 977
 978   for (; c; c = c->next)
 979     {
 980       if (c->iterator
 981           && (gfc_simplify_expr (c->iterator->start, type) == FAILURE
 982               || gfc_simplify_expr (c->iterator->end, type) == FAILURE
 983               || gfc_simplify_expr (c->iterator->step, type) == FAILURE))
 984         return FAILURE;
 985
 986       if (c->expr)
 987         {
 988           /* Try and simplify a copy.  Replace the original if successful
 989              but keep going through the constructor at all costs.  Not
 990              doing so can make a dog's dinner of complicated things.  */
 991           p = gfc_copy_expr (c->expr);
 992
 993           if (gfc_simplify_expr (p, type) == FAILURE)
 994             {
 995               gfc_free_expr (p);
 996               continue;
 997             }
 998
 999           gfc_replace_expr (c->expr, p);
1000         }
1001     }
1002
1003   return SUCCESS;
1004 }
1005
1006
1007 /* Pull a single array element out of an array constructor.  */
1008
1009 static gfc_try
1010 find_array_element (gfc_constructor *cons, gfc_array_ref *ar,
1011                     gfc_constructor **rval)
1012 {
1013   unsigned long nelemen;
1014   int i;
1015   mpz_t delta;
1016   mpz_t offset;
1017   mpz_t span;
1018   mpz_t tmp;
1019   gfc_expr *e;
1020   gfc_try t;
1021
1022   t = SUCCESS;
1023   e = NULL;
1024
1025   mpz_init_set_ui (offset, 0);
1026   mpz_init (delta);
1027   mpz_init (tmp);
1028   mpz_init_set_ui (span, 1);
1029   for (i = 0; i < ar->dimen; i++)
1030     {
1031       if (gfc_reduce_init_expr (ar->as->lower[i]) == FAILURE
1032           || gfc_reduce_init_expr (ar->as->upper[i]) == FAILURE)
1033         {
1034           t = FAILURE;
1035           cons = NULL;
1036           goto depart;
1037         }
1038
1039       e = gfc_copy_expr (ar->start[i]);
1040       if (e->expr_type != EXPR_CONSTANT)
1041         {
1042           cons = NULL;
1043           goto depart;
1044         }
1045
1046       gcc_assert (ar->as->upper[i]->expr_type == EXPR_CONSTANT
1047                   && ar->as->lower[i]->expr_type == EXPR_CONSTANT);
1048
1049       /* Check the bounds.  */
1050       if ((ar->as->upper[i]
1051            && mpz_cmp (e->value.integer,
1052                        ar->as->upper[i]->value.integer) > 0)
1053           || (mpz_cmp (e->value.integer,
1054                        ar->as->lower[i]->value.integer) < 0))
1055         {
1056           gfc_error ("Index in dimension %d is out of bounds "
1057                      "at %L", i + 1, &ar->c_where[i]);
1058           cons = NULL;
1059           t = FAILURE;
1060           goto depart;
1061         }
1062
1063       mpz_sub (delta, e->value.integer, ar->as->lower[i]->value.integer);
1064       mpz_mul (delta, delta, span);
1065       mpz_add (offset, offset, delta);
1066
1067       mpz_set_ui (tmp, 1);
1068       mpz_add (tmp, tmp, ar->as->upper[i]->value.integer);
1069       mpz_sub (tmp, tmp, ar->as->lower[i]->value.integer);
1070       mpz_mul (span, span, tmp);
1071     }
1072
1073   for (nelemen = mpz_get_ui (offset); nelemen > 0; nelemen--)
1074     {
1075       if (cons)
1076         {
1077           if (cons->iterator)
1078             {
1079               cons = NULL;
1080               goto depart;
1081             }
1082           cons = cons->next;
1083         }
1084     }
1085
1086 depart:
1087   mpz_clear (delta);
1088   mpz_clear (offset);
1089   mpz_clear (span);
1090   mpz_clear (tmp);
1091   if (e)
1092     gfc_free_expr (e);
1093   *rval = cons;
1094   return t;
1095 }
1096
1097
1098 /* Find a component of a structure constructor.  */
1099
1100 static gfc_constructor *
1101 find_component_ref (gfc_constructor *cons, gfc_ref *ref)
1102 {
1103   gfc_component *comp;
1104   gfc_component *pick;
1105
1106   comp = ref->u.c.sym->components;
1107   pick = ref->u.c.component;
1108   while (comp != pick)
1109     {
1110       comp = comp->next;
1111       cons = cons->next;
1112     }
1113
1114   return cons;
1115 }
1116
1117
1118 /* Replace an expression with the contents of a constructor, removing
1119    the subobject reference in the process.  */
1120
1121 static void
1122 remove_subobject_ref (gfc_expr *p, gfc_constructor *cons)
1123 {
1124   gfc_expr *e;
1125
1126   e = cons->expr;
1127   cons->expr = NULL;
1128   e->ref = p->ref->next;
1129   p->ref->next =  NULL;
1130   gfc_replace_expr (p, e);
1131 }
1132
1133
1134 /* Pull an array section out of an array constructor.  */
1135
1136 static gfc_try
1137 find_array_section (gfc_expr *expr, gfc_ref *ref)
1138 {
1139   int idx;
1140   int rank;
1141   int d;
1142   int shape_i;
1143   long unsigned one = 1;
1144   bool incr_ctr;
1145   mpz_t start[GFC_MAX_DIMENSIONS];
1146   mpz_t end[GFC_MAX_DIMENSIONS];
1147   mpz_t stride[GFC_MAX_DIMENSIONS];
1148   mpz_t delta[GFC_MAX_DIMENSIONS];
1149   mpz_t ctr[GFC_MAX_DIMENSIONS];
1150   mpz_t delta_mpz;
1151   mpz_t tmp_mpz;
1152   mpz_t nelts;
1153   mpz_t ptr;
1154   mpz_t index;
1155   gfc_constructor *cons;
1156   gfc_constructor *base;
1157   gfc_expr *begin;
1158   gfc_expr *finish;
1159   gfc_expr *step;
1160   gfc_expr *upper;
1161   gfc_expr *lower;
1162   gfc_constructor *vecsub[GFC_MAX_DIMENSIONS], *c;
1163   gfc_try t;
1164
1165   t = SUCCESS;
1166
1167   base = expr->value.constructor;
1168   expr->value.constructor = NULL;
1169
1170   rank = ref->u.ar.as->rank;
1171
1172   if (expr->shape == NULL)
1173     expr->shape = gfc_get_shape (rank);
1174
1175   mpz_init_set_ui (delta_mpz, one);
1176   mpz_init_set_ui (nelts, one);
1177   mpz_init (tmp_mpz);
1178
1179   /* Do the initialization now, so that we can cleanup without
1180      keeping track of where we were.  */
1181   for (d = 0; d < rank; d++)
1182     {
1183       mpz_init (delta[d]);
1184       mpz_init (start[d]);
1185       mpz_init (end[d]);
1186       mpz_init (ctr[d]);
1187       mpz_init (stride[d]);
1188       vecsub[d] = NULL;
1189     }
1190
1191   /* Build the counters to clock through the array reference.  */
1192   shape_i = 0;
1193   for (d = 0; d < rank; d++)
1194     {
1195       /* Make this stretch of code easier on the eye!  */
1196       begin = ref->u.ar.start[d];
1197       finish = ref->u.ar.end[d];
1198       step = ref->u.ar.stride[d];
1199       lower = ref->u.ar.as->lower[d];
1200       upper = ref->u.ar.as->upper[d];
1201
1202       if (ref->u.ar.dimen_type[d] == DIMEN_VECTOR)  /* Vector subscript.  */
1203         {
1204           gcc_assert (begin);
1205
1206           if (begin->expr_type != EXPR_ARRAY || !gfc_is_constant_expr (begin))
1207             {
1208               t = FAILURE;
1209               goto cleanup;
1210             }
1211
1212           gcc_assert (begin->rank == 1);
1213           /* Zero-sized arrays have no shape and no elements, stop early.  */
1214           if (!begin->shape)
1215             {
1216               mpz_init_set_ui (nelts, 0);
1217               break;
1218             }
1219
1220           vecsub[d] = begin->value.constructor;
1221           mpz_set (ctr[d], vecsub[d]->expr->value.integer);
1222           mpz_mul (nelts, nelts, begin->shape[0]);
1223           mpz_set (expr->shape[shape_i++], begin->shape[0]);
1224
1225           /* Check bounds.  */
1226           for (c = vecsub[d]; c; c = c->next)
1227             {
1228               if (mpz_cmp (c->expr->value.integer, upper->value.integer) > 0
1229                   || mpz_cmp (c->expr->value.integer,
1230                               lower->value.integer) < 0)
1231                 {
1232                   gfc_error ("index in dimension %d is out of bounds "
1233                              "at %L", d + 1, &ref->u.ar.c_where[d]);
1234                   t = FAILURE;
1235                   goto cleanup;
1236                 }
1237             }
1238         }
1239       else
1240         {
1241           if ((begin && begin->expr_type != EXPR_CONSTANT)
1242               || (finish && finish->expr_type != EXPR_CONSTANT)
1243               || (step && step->expr_type != EXPR_CONSTANT))
1244             {
1245               t = FAILURE;
1246               goto cleanup;
1247             }
1248
1249           /* Obtain the stride.  */
1250           if (step)
1251             mpz_set (stride[d], step->value.integer);
1252           else
1253             mpz_set_ui (stride[d], one);
1254
1255           if (mpz_cmp_ui (stride[d], 0) == 0)
1256             mpz_set_ui (stride[d], one);
1257
1258           /* Obtain the start value for the index.  */
1259           if (begin)
1260             mpz_set (start[d], begin->value.integer);
1261           else
1262             mpz_set (start[d], lower->value.integer);
1263
1264           mpz_set (ctr[d], start[d]);
1265
1266           /* Obtain the end value for the index.  */
1267           if (finish)
1268             mpz_set (end[d], finish->value.integer);
1269           else
1270             mpz_set (end[d], upper->value.integer);
1271
1272           /* Separate 'if' because elements sometimes arrive with
1273              non-null end.  */
1274           if (ref->u.ar.dimen_type[d] == DIMEN_ELEMENT)
1275             mpz_set (end [d], begin->value.integer);
1276
1277           /* Check the bounds.  */
1278           if (mpz_cmp (ctr[d], upper->value.integer) > 0
1279               || mpz_cmp (end[d], upper->value.integer) > 0
1280               || mpz_cmp (ctr[d], lower->value.integer) < 0
1281               || mpz_cmp (end[d], lower->value.integer) < 0)
1282             {
1283               gfc_error ("index in dimension %d is out of bounds "
1284                          "at %L", d + 1, &ref->u.ar.c_where[d]);
1285               t = FAILURE;
1286               goto cleanup;
1287             }
1288
1289           /* Calculate the number of elements and the shape.  */
1290           mpz_set (tmp_mpz, stride[d]);
1291           mpz_add (tmp_mpz, end[d], tmp_mpz);
1292           mpz_sub (tmp_mpz, tmp_mpz, ctr[d]);
1293           mpz_div (tmp_mpz, tmp_mpz, stride[d]);
1294           mpz_mul (nelts, nelts, tmp_mpz);
1295
1296           /* An element reference reduces the rank of the expression; don't
1297              add anything to the shape array.  */
1298           if (ref->u.ar.dimen_type[d] != DIMEN_ELEMENT)
1299             mpz_set (expr->shape[shape_i++], tmp_mpz);
1300         }
1301
1302       /* Calculate the 'stride' (=delta) for conversion of the
1303          counter values into the index along the constructor.  */
1304       mpz_set (delta[d], delta_mpz);
1305       mpz_sub (tmp_mpz, upper->value.integer, lower->value.integer);
1306       mpz_add_ui (tmp_mpz, tmp_mpz, one);
1307       mpz_mul (delta_mpz, delta_mpz, tmp_mpz);
1308     }
1309
1310   mpz_init (index);
1311   mpz_init (ptr);
1312   cons = base;
1313
1314   /* Now clock through the array reference, calculating the index in
1315      the source constructor and transferring the elements to the new
1316      constructor.  */
1317   for (idx = 0; idx < (int) mpz_get_si (nelts); idx++)
1318     {
1319       if (ref->u.ar.offset)
1320         mpz_set (ptr, ref->u.ar.offset->value.integer);
1321       else
1322         mpz_init_set_ui (ptr, 0);
1323
1324       incr_ctr = true;
1325       for (d = 0; d < rank; d++)
1326         {
1327           mpz_set (tmp_mpz, ctr[d]);
1328           mpz_sub (tmp_mpz, tmp_mpz, ref->u.ar.as->lower[d]->value.integer);
1329           mpz_mul (tmp_mpz, tmp_mpz, delta[d]);
1330           mpz_add (ptr, ptr, tmp_mpz);
1331
1332           if (!incr_ctr) continue;
1333
1334           if (ref->u.ar.dimen_type[d] == DIMEN_VECTOR) /* Vector subscript.  */
1335             {
1336               gcc_assert(vecsub[d]);
1337
1338               if (!vecsub[d]->next)
1339                 vecsub[d] = ref->u.ar.start[d]->value.constructor;
1340               else
1341                 {
1342                   vecsub[d] = vecsub[d]->next;
1343                   incr_ctr = false;
1344                 }
1345               mpz_set (ctr[d], vecsub[d]->expr->value.integer);
1346             }
1347           else
1348             {
1349               mpz_add (ctr[d], ctr[d], stride[d]);
1350
1351               if (mpz_cmp_ui (stride[d], 0) > 0
1352                   ? mpz_cmp (ctr[d], end[d]) > 0
1353                   : mpz_cmp (ctr[d], end[d]) < 0)
1354                 mpz_set (ctr[d], start[d]);
1355               else
1356                 incr_ctr = false;
1357             }
1358         }
1359
1360       /* There must be a better way of dealing with negative strides
1361          than resetting the index and the constructor pointer!  */
1362       if (mpz_cmp (ptr, index) < 0)
1363         {
1364           mpz_set_ui (index, 0);
1365           cons = base;
1366         }
1367
1368       while (cons && cons->next && mpz_cmp (ptr, index) > 0)
1369         {
1370           mpz_add_ui (index, index, one);
1371           cons = cons->next;
1372         }
1373
1374       gfc_append_constructor (expr, gfc_copy_expr (cons->expr));
1375     }
1376
1377   mpz_clear (ptr);
1378   mpz_clear (index);
1379
1380 cleanup:
1381
1382   mpz_clear (delta_mpz);
1383   mpz_clear (tmp_mpz);
1384   mpz_clear (nelts);
1385   for (d = 0; d < rank; d++)
1386     {
1387       mpz_clear (delta[d]);
1388       mpz_clear (start[d]);
1389       mpz_clear (end[d]);
1390       mpz_clear (ctr[d]);
1391       mpz_clear (stride[d]);
1392     }
1393   gfc_free_constructor (base);
1394   return t;
1395 }
1396
1397 /* Pull a substring out of an expression.  */
1398
1399 static gfc_try
1400 find_substring_ref (gfc_expr *p, gfc_expr **newp)
1401 {
1402   int end;
1403   int start;
1404   int length;
1405   gfc_char_t *chr;
1406
1407   if (p->ref->u.ss.start->expr_type != EXPR_CONSTANT
1408       || p->ref->u.ss.end->expr_type != EXPR_CONSTANT)
1409     return FAILURE;
1410
1411   *newp = gfc_copy_expr (p);
1412   gfc_free ((*newp)->value.character.string);
1413
1414   end = (int) mpz_get_ui (p->ref->u.ss.end->value.integer);
1415   start = (int) mpz_get_ui (p->ref->u.ss.start->value.integer);
1416   length = end - start + 1;
1417
1418   chr = (*newp)->value.character.string = gfc_get_wide_string (length + 1);
1419   (*newp)->value.character.length = length;
1420   memcpy (chr, &p->value.character.string[start - 1],
1421           length * sizeof (gfc_char_t));
1422   chr[length] = '\0';
1423   return SUCCESS;
1424 }
1425
1426
1427
1428 /* Simplify a subobject reference of a constructor.  This occurs when
1429    parameter variable values are substituted.  */
1430
1431 static gfc_try
1432 simplify_const_ref (gfc_expr *p)
1433 {
1434   gfc_constructor *cons;
1435   gfc_expr *newp;
1436
1437   while (p->ref)
1438     {
1439       switch (p->ref->type)
1440         {
1441         case REF_ARRAY:
1442           switch (p->ref->u.ar.type)
1443             {
1444             case AR_ELEMENT:
1445               if (find_array_element (p->value.constructor, &p->ref->u.ar,
1446                                       &cons) == FAILURE)
1447                 return FAILURE;
1448
1449               if (!cons)
1450                 return SUCCESS;
1451
1452               remove_subobject_ref (p, cons);
1453               break;
1454
1455             case AR_SECTION:
1456               if (find_array_section (p, p->ref) == FAILURE)
1457                 return FAILURE;
1458               p->ref->u.ar.type = AR_FULL;
1459
1460             /* Fall through.  */
1461
1462             case AR_FULL:
1463               if (p->ref->next != NULL
1464                   && (p->ts.type == BT_CHARACTER || p->ts.type == BT_DERIVED))
1465                 {
1466                   cons = p->value.constructor;
1467                   for (; cons; cons = cons->next)
1468                     {
1469                       cons->expr->ref = gfc_copy_ref (p->ref->next);
1470                       if (simplify_const_ref (cons->expr) == FAILURE)
1471                         return FAILURE;
1472                     }
1473
1474                   /* If this is a CHARACTER array and we possibly took a
1475                      substring out of it, update the type-spec's character
1476                      length according to the first element (as all should have
1477                      the same length).  */
1478                   if (p->ts.type == BT_CHARACTER)
1479                     {
1480                       int string_len;
1481
1482                       gcc_assert (p->ref->next);
1483                       gcc_assert (!p->ref->next->next);
1484                       gcc_assert (p->ref->next->type == REF_SUBSTRING);
1485
1486                       if (p->value.constructor)
1487                         {
1488                           const gfc_expr* first = p->value.constructor->expr;
1489                           gcc_assert (first->expr_type == EXPR_CONSTANT);
1490                           gcc_assert (first->ts.type == BT_CHARACTER);
1491                           string_len = first->value.character.length;
1492                         }
1493                       else
1494                         string_len = 0;
1495
1496                       if (!p->ts.cl)
1497                         {
1498                           p->ts.cl = gfc_get_charlen ();
1499                           p->ts.cl->next = NULL;
1500                           p->ts.cl->length = NULL;
1501                         }
1502                       gfc_free_expr (p->ts.cl->length);
1503                       p->ts.cl->length = gfc_int_expr (string_len);
1504                     }
1505                 }
1506               gfc_free_ref_list (p->ref);
1507               p->ref = NULL;
1508               break;
1509
1510             default:
1511               return SUCCESS;
1512             }
1513
1514           break;
1515
1516         case REF_COMPONENT:
1517           cons = find_component_ref (p->value.constructor, p->ref);
1518           remove_subobject_ref (p, cons);
1519           break;
1520
1521         case REF_SUBSTRING:
1522           if (find_substring_ref (p, &newp) == FAILURE)
1523             return FAILURE;
1524
1525           gfc_replace_expr (p, newp);
1526           gfc_free_ref_list (p->ref);
1527           p->ref = NULL;
1528           break;
1529         }
1530     }
1531
1532   return SUCCESS;
1533 }
1534
1535
1536 /* Simplify a chain of references.  */
1537
1538 static gfc_try
1539 simplify_ref_chain (gfc_ref *ref, int type)
1540 {
1541   int n;
1542
1543   for (; ref; ref = ref->next)
1544     {
1545       switch (ref->type)
1546         {
1547         case REF_ARRAY:
1548           for (n = 0; n < ref->u.ar.dimen; n++)
1549             {
1550               if (gfc_simplify_expr (ref->u.ar.start[n], type) == FAILURE)
1551                 return FAILURE;
1552               if (gfc_simplify_expr (ref->u.ar.end[n], type) == FAILURE)
1553                 return FAILURE;
1554               if (gfc_simplify_expr (ref->u.ar.stride[n], type) == FAILURE)
1555                 return FAILURE;
1556             }
1557           break;
1558
1559         case REF_SUBSTRING:
1560           if (gfc_simplify_expr (ref->u.ss.start, type) == FAILURE)
1561             return FAILURE;
1562           if (gfc_simplify_expr (ref->u.ss.end, type) == FAILURE)
1563             return FAILURE;
1564           break;
1565
1566         default:
1567           break;
1568         }
1569     }
1570   return SUCCESS;
1571 }
1572
1573
1574 /* Try to substitute the value of a parameter variable.  */
1575
1576 static gfc_try
1577 simplify_parameter_variable (gfc_expr *p, int type)
1578 {
1579   gfc_expr *e;
1580   gfc_try t;
1581
1582   e = gfc_copy_expr (p->symtree->n.sym->value);
1583   if (e == NULL)
1584     return FAILURE;
1585
1586   e->rank = p->rank;
1587
1588   /* Do not copy subobject refs for constant.  */
1589   if (e->expr_type != EXPR_CONSTANT && p->ref != NULL)
1590     e->ref = gfc_copy_ref (p->ref);
1591   t = gfc_simplify_expr (e, type);
1592
1593   /* Only use the simplification if it eliminated all subobject references.  */
1594   if (t == SUCCESS && !e->ref)
1595     gfc_replace_expr (p, e);
1596   else
1597     gfc_free_expr (e);
1598
1599   return t;
1600 }
1601
1602 /* Given an expression, simplify it by collapsing constant
1603    expressions.  Most simplification takes place when the expression
1604    tree is being constructed.  If an intrinsic function is simplified
1605    at some point, we get called again to collapse the result against
1606    other constants.
1607
1608    We work by recursively simplifying expression nodes, simplifying
1609    intrinsic functions where possible, which can lead to further
1610    constant collapsing.  If an operator has constant operand(s), we
1611    rip the expression apart, and rebuild it, hoping that it becomes
1612    something simpler.
1613
1614    The expression type is defined for:
1615      0   Basic expression parsing
1616      1   Simplifying array constructors -- will substitute
1617          iterator values.
1618    Returns FAILURE on error, SUCCESS otherwise.
1619    NOTE: Will return SUCCESS even if the expression can not be simplified.  */
1620
1621 gfc_try
1622 gfc_simplify_expr (gfc_expr *p, int type)
1623 {
1624   gfc_actual_arglist *ap;
1625
1626   if (p == NULL)
1627     return SUCCESS;
1628
1629   switch (p->expr_type)
1630     {
1631     case EXPR_CONSTANT:
1632     case EXPR_NULL:
1633       break;
1634
1635     case EXPR_FUNCTION:
1636       for (ap = p->value.function.actual; ap; ap = ap->next)
1637         if (gfc_simplify_expr (ap->expr, type) == FAILURE)
1638           return FAILURE;
1639
1640       if (p->value.function.isym != NULL
1641           && gfc_intrinsic_func_interface (p, 1) == MATCH_ERROR)
1642         return FAILURE;
1643
1644       break;
1645
1646     case EXPR_SUBSTRING:
1647       if (simplify_ref_chain (p->ref, type) == FAILURE)
1648         return FAILURE;
1649
1650       if (gfc_is_constant_expr (p))
1651         {
1652           gfc_char_t *s;
1653           int start, end;
1654
1655           if (p->ref && p->ref->u.ss.start)
1656             {
1657               gfc_extract_int (p->ref->u.ss.start, &start);
1658               start--;  /* Convert from one-based to zero-based.  */
1659             }
1660           else
1661             start = 0;
1662
1663           if (p->ref && p->ref->u.ss.end)
1664             gfc_extract_int (p->ref->u.ss.end, &end);
1665           else
1666             end = p->value.character.length;
1667
1668           s = gfc_get_wide_string (end - start + 2);
1669           memcpy (s, p->value.character.string + start,
1670                   (end - start) * sizeof (gfc_char_t));
1671           s[end - start + 1] = '\0';  /* TODO: C-style string.  */
1672           gfc_free (p->value.character.string);
1673           p->value.character.string = s;
1674           p->value.character.length = end - start;
1675           p->ts.cl = gfc_get_charlen ();
1676           p->ts.cl->next = gfc_current_ns->cl_list;
1677           gfc_current_ns->cl_list = p->ts.cl;
1678           p->ts.cl->length = gfc_int_expr (p->value.character.length);
1679           gfc_free_ref_list (p->ref);
1680           p->ref = NULL;
1681           p->expr_type = EXPR_CONSTANT;
1682         }
1683       break;
1684
1685     case EXPR_OP:
1686       if (simplify_intrinsic_op (p, type) == FAILURE)
1687         return FAILURE;
1688       break;
1689
1690     case EXPR_VARIABLE:
1691       /* Only substitute array parameter variables if we are in an
1692          initialization expression, or we want a subsection.  */
1693       if (p->symtree->n.sym->attr.flavor == FL_PARAMETER
1694           && (gfc_init_expr || p->ref
1695               || p->symtree->n.sym->value->expr_type != EXPR_ARRAY))
1696         {
1697           if (simplify_parameter_variable (p, type) == FAILURE)
1698             return FAILURE;
1699           break;
1700         }
1701
1702       if (type == 1)
1703         {
1704           gfc_simplify_iterator_var (p);
1705         }
1706
1707       /* Simplify subcomponent references.  */
1708       if (simplify_ref_chain (p->ref, type) == FAILURE)
1709         return FAILURE;
1710
1711       break;
1712
1713     case EXPR_STRUCTURE:
1714     case EXPR_ARRAY:
1715       if (simplify_ref_chain (p->ref, type) == FAILURE)
1716         return FAILURE;
1717
1718       if (simplify_constructor (p->value.constructor, type) == FAILURE)
1719         return FAILURE;
1720
1721       if (p->expr_type == EXPR_ARRAY && p->ref && p->ref->type == REF_ARRAY
1722           && p->ref->u.ar.type == AR_FULL)
1723           gfc_expand_constructor (p);
1724
1725       if (simplify_const_ref (p) == FAILURE)
1726         return FAILURE;
1727
1728       break;
1729
1730     case EXPR_COMPCALL:
1731       gcc_unreachable ();
1732       break;
1733     }
1734
1735   return SUCCESS;
1736 }
1737
1738
1739 /* Returns the type of an expression with the exception that iterator
1740    variables are automatically integers no matter what else they may
1741    be declared as.  */
1742
1743 static bt
1744 et0 (gfc_expr *e)
1745 {
1746   if (e->expr_type == EXPR_VARIABLE && gfc_check_iter_variable (e) == SUCCESS)
1747     return BT_INTEGER;
1748
1749   return e->ts.type;
1750 }
1751
1752
1753 /* Check an intrinsic arithmetic operation to see if it is consistent
1754    with some type of expression.  */
1755
1756 static gfc_try check_init_expr (gfc_expr *);
1757
1758
1759 /* Scalarize an expression for an elemental intrinsic call.  */
1760
1761 static gfc_try
1762 scalarize_intrinsic_call (gfc_expr *e)
1763 {
1764   gfc_actual_arglist *a, *b;
1765   gfc_constructor *args[5], *ctor, *new_ctor;
1766   gfc_expr *expr, *old;
1767   int n, i, rank[5], array_arg;
1768
1769   /* Find which, if any, arguments are arrays.  Assume that the old
1770      expression carries the type information and that the first arg
1771      that is an array expression carries all the shape information.*/
1772   n = array_arg = 0;
1773   a = e->value.function.actual;
1774   for (; a; a = a->next)
1775     {
1776       n++;
1777       if (a->expr->expr_type != EXPR_ARRAY)
1778         continue;
1779       array_arg = n;
1780       expr = gfc_copy_expr (a->expr);
1781       break;
1782     }
1783
1784   if (!array_arg)
1785     return FAILURE;
1786
1787   old = gfc_copy_expr (e);
1788
1789   gfc_free_constructor (expr->value.constructor);
1790   expr->value.constructor = NULL;
1791
1792   expr->ts = old->ts;
1793   expr->where = old->where;
1794   expr->expr_type = EXPR_ARRAY;
1795
1796   /* Copy the array argument constructors into an array, with nulls
1797      for the scalars.  */
1798   n = 0;
1799   a = old->value.function.actual;
1800   for (; a; a = a->next)
1801     {
1802       /* Check that this is OK for an initialization expression.  */
1803       if (a->expr && check_init_expr (a->expr) == FAILURE)
1804         goto cleanup;
1805
1806       rank[n] = 0;
1807       if (a->expr && a->expr->rank && a->expr->expr_type == EXPR_VARIABLE)
1808         {
1809           rank[n] = a->expr->rank;
1810           ctor = a->expr->symtree->n.sym->value->value.constructor;
1811           args[n] = gfc_copy_constructor (ctor);
1812         }
1813       else if (a->expr && a->expr->expr_type == EXPR_ARRAY)
1814         {
1815           if (a->expr->rank)
1816             rank[n] = a->expr->rank;
1817           else
1818             rank[n] = 1;
1819           args[n] = gfc_copy_constructor (a->expr->value.constructor);
1820         }
1821       else
1822         args[n] = NULL;
1823       n++;
1824     }
1825
1826
1827   /* Using the array argument as the master, step through the array
1828      calling the function for each element and advancing the array
1829      constructors together.  */
1830   ctor = args[array_arg - 1];
1831   new_ctor = NULL;
1832   for (; ctor; ctor = ctor->next)
1833     {
1834           if (expr->value.constructor == NULL)
1835             expr->value.constructor
1836                 = new_ctor = gfc_get_constructor ();
1837           else
1838             {
1839               new_ctor->next = gfc_get_constructor ();
1840               new_ctor = new_ctor->next;
1841             }
1842           new_ctor->expr = gfc_copy_expr (old);
1843           gfc_free_actual_arglist (new_ctor->expr->value.function.actual);
1844           a = NULL;
1845           b = old->value.function.actual;
1846           for (i = 0; i < n; i++)
1847             {
1848               if (a == NULL)
1849                 new_ctor->expr->value.function.actual
1850                         = a = gfc_get_actual_arglist ();
1851               else
1852                 {
1853                   a->next = gfc_get_actual_arglist ();
1854                   a = a->next;
1855                 }
1856               if (args[i])
1857                 a->expr = gfc_copy_expr (args[i]->expr);
1858               else
1859                 a->expr = gfc_copy_expr (b->expr);
1860
1861               b = b->next;
1862             }
1863
1864           /* Simplify the function calls.  If the simplification fails, the
1865              error will be flagged up down-stream or the library will deal
1866              with it.  */
1867           gfc_simplify_expr (new_ctor->expr, 0);
1868
1869           for (i = 0; i < n; i++)
1870             if (args[i])
1871               args[i] = args[i]->next;
1872
1873           for (i = 1; i < n; i++)
1874             if (rank[i] && ((args[i] != NULL && args[array_arg - 1] == NULL)
1875                          || (args[i] == NULL && args[array_arg - 1] != NULL)))
1876               goto compliance;
1877     }
1878
1879   free_expr0 (e);
1880   *e = *expr;
1881   gfc_free_expr (old);
1882   return SUCCESS;
1883
1884 compliance:
1885   gfc_error_now ("elemental function arguments at %C are not compliant");
1886
1887 cleanup:
1888   gfc_free_expr (expr);
1889   gfc_free_expr (old);
1890   return FAILURE;
1891 }
1892
1893
1894 static gfc_try
1895 check_intrinsic_op (gfc_expr *e, gfc_try (*check_function) (gfc_expr *))
1896 {
1897   gfc_expr *op1 = e->value.op.op1;
1898   gfc_expr *op2 = e->value.op.op2;
1899
1900   if ((*check_function) (op1) == FAILURE)
1901     return FAILURE;
1902
1903   switch (e->value.op.op)
1904     {
1905     case INTRINSIC_UPLUS:
1906     case INTRINSIC_UMINUS:
1907       if (!numeric_type (et0 (op1)))
1908         goto not_numeric;
1909       break;
1910
1911     case INTRINSIC_EQ:
1912     case INTRINSIC_EQ_OS:
1913     case INTRINSIC_NE:
1914     case INTRINSIC_NE_OS:
1915     case INTRINSIC_GT:
1916     case INTRINSIC_GT_OS:
1917     case INTRINSIC_GE:
1918     case INTRINSIC_GE_OS:
1919     case INTRINSIC_LT:
1920     case INTRINSIC_LT_OS:
1921     case INTRINSIC_LE:
1922     case INTRINSIC_LE_OS:
1923       if ((*check_function) (op2) == FAILURE)
1924         return FAILURE;
1925
1926       if (!(et0 (op1) == BT_CHARACTER && et0 (op2) == BT_CHARACTER)
1927           && !(numeric_type (et0 (op1)) && numeric_type (et0 (op2))))
1928         {
1929           gfc_error ("Numeric or CHARACTER operands are required in "
1930                      "expression at %L", &e->where);
1931          return FAILURE;
1932         }
1933       break;
1934
1935     case INTRINSIC_PLUS:
1936     case INTRINSIC_MINUS:
1937     case INTRINSIC_TIMES:
1938     case INTRINSIC_DIVIDE:
1939     case INTRINSIC_POWER:
1940       if ((*check_function) (op2) == FAILURE)
1941         return FAILURE;
1942
1943       if (!numeric_type (et0 (op1)) || !numeric_type (et0 (op2)))
1944         goto not_numeric;
1945
1946       break;
1947
1948     case INTRINSIC_CONCAT:
1949       if ((*check_function) (op2) == FAILURE)
1950         return FAILURE;
1951
1952       if (et0 (op1) != BT_CHARACTER || et0 (op2) != BT_CHARACTER)
1953         {
1954           gfc_error ("Concatenation operator in expression at %L "
1955                      "must have two CHARACTER operands", &op1->where);
1956           return FAILURE;
1957         }
1958
1959       if (op1->ts.kind != op2->ts.kind)
1960         {
1961           gfc_error ("Concat operator at %L must concatenate strings of the "
1962                      "same kind", &e->where);
1963           return FAILURE;
1964         }
1965
1966       break;
1967
1968     case INTRINSIC_NOT:
1969       if (et0 (op1) != BT_LOGICAL)
1970         {
1971           gfc_error (".NOT. operator in expression at %L must have a LOGICAL "
1972                      "operand", &op1->where);
1973           return FAILURE;
1974         }
1975
1976       break;
1977
1978     case INTRINSIC_AND:
1979     case INTRINSIC_OR:
1980     case INTRINSIC_EQV:
1981     case INTRINSIC_NEQV:
1982       if ((*check_function) (op2) == FAILURE)
1983         return FAILURE;
1984
1985       if (et0 (op1) != BT_LOGICAL || et0 (op2) != BT_LOGICAL)
1986         {
1987           gfc_error ("LOGICAL operands are required in expression at %L",
1988                      &e->where);
1989           return FAILURE;
1990         }
1991
1992       break;
1993
1994     case INTRINSIC_PARENTHESES:
1995       break;
1996
1997     default:
1998       gfc_error ("Only intrinsic operators can be used in expression at %L",
1999                  &e->where);
2000       return FAILURE;
2001     }
2002
2003   return SUCCESS;
2004
2005 not_numeric:
2006   gfc_error ("Numeric operands are required in expression at %L", &e->where);
2007
2008   return FAILURE;
2009 }
2010
2011
2012 static match
2013 check_init_expr_arguments (gfc_expr *e)
2014 {
2015   gfc_actual_arglist *ap;
2016
2017   for (ap = e->value.function.actual; ap; ap = ap->next)
2018     if (check_init_expr (ap->expr) == FAILURE)
2019       return MATCH_ERROR;
2020
2021   return MATCH_YES;
2022 }
2023
2024 static gfc_try check_restricted (gfc_expr *);
2025
2026 /* F95, 7.1.6.1, Initialization expressions, (7)
2027    F2003, 7.1.7 Initialization expression, (8)  */
2028
2029 static match
2030 check_inquiry (gfc_expr *e, int not_restricted)
2031 {
2032   const char *name;
2033   const char *const *functions;
2034
2035   static const char *const inquiry_func_f95[] = {
2036     "lbound", "shape", "size", "ubound",
2037     "bit_size", "len", "kind",
2038     "digits", "epsilon", "huge", "maxexponent", "minexponent",
2039     "precision", "radix", "range", "tiny",
2040     NULL
2041   };
2042
2043   static const char *const inquiry_func_f2003[] = {
2044     "lbound", "shape", "size", "ubound",
2045     "bit_size", "len", "kind",
2046     "digits", "epsilon", "huge", "maxexponent", "minexponent",
2047     "precision", "radix", "range", "tiny",
2048     "new_line", NULL
2049   };
2050
2051   int i;
2052   gfc_actual_arglist *ap;
2053
2054   if (!e->value.function.isym
2055       || !e->value.function.isym->inquiry)
2056     return MATCH_NO;
2057
2058   /* An undeclared parameter will get us here (PR25018).  */
2059   if (e->symtree == NULL)
2060     return MATCH_NO;
2061
2062   name = e->symtree->n.sym->name;
2063
2064   functions = (gfc_option.warn_std & GFC_STD_F2003)
2065                 ? inquiry_func_f2003 : inquiry_func_f95;
2066
2067   for (i = 0; functions[i]; i++)
2068     if (strcmp (functions[i], name) == 0)
2069       break;
2070
2071   if (functions[i] == NULL)
2072     return MATCH_ERROR;
2073
2074   /* At this point we have an inquiry function with a variable argument.  The
2075      type of the variable might be undefined, but we need it now, because the
2076      arguments of these functions are not allowed to be undefined.  */
2077
2078   for (ap = e->value.function.actual; ap; ap = ap->next)
2079     {
2080       if (!ap->expr)
2081         continue;
2082
2083       if (ap->expr->ts.type == BT_UNKNOWN)
2084         {
2085           if (ap->expr->symtree->n.sym->ts.type == BT_UNKNOWN
2086               && gfc_set_default_type (ap->expr->symtree->n.sym, 0, gfc_current_ns)
2087               == FAILURE)
2088             return MATCH_NO;
2089
2090           ap->expr->ts = ap->expr->symtree->n.sym->ts;
2091         }
2092
2093         /* Assumed character length will not reduce to a constant expression
2094            with LEN, as required by the standard.  */
2095         if (i == 5 && not_restricted
2096             && ap->expr->symtree->n.sym->ts.type == BT_CHARACTER
2097             && ap->expr->symtree->n.sym->ts.cl->length == NULL)
2098           {
2099             gfc_error ("Assumed character length variable '%s' in constant "
2100                        "expression at %L", e->symtree->n.sym->name, &e->where);
2101               return MATCH_ERROR;
2102           }
2103         else if (not_restricted && check_init_expr (ap->expr) == FAILURE)
2104           return MATCH_ERROR;
2105
2106         if (not_restricted == 0
2107               && ap->expr->expr_type != EXPR_VARIABLE
2108               && check_restricted (ap->expr) == FAILURE)
2109           return MATCH_ERROR;
2110     }
2111
2112   return MATCH_YES;
2113 }
2114
2115
2116 /* F95, 7.1.6.1, Initialization expressions, (5)
2117    F2003, 7.1.7 Initialization expression, (5)  */
2118
2119 static match
2120 check_transformational (gfc_expr *e)
2121 {
2122   static const char * const trans_func_f95[] = {
2123     "repeat", "reshape", "selected_int_kind",
2124     "selected_real_kind", "transfer", "trim", NULL
2125   };
2126
2127   int i;
2128   const char *name;
2129
2130   if (!e->value.function.isym
2131       || !e->value.function.isym->transformational)
2132     return MATCH_NO;
2133
2134   name = e->symtree->n.sym->name;
2135
2136   /* NULL() is dealt with below.  */
2137   if (strcmp ("null", name) == 0)
2138     return MATCH_NO;
2139
2140   for (i = 0; trans_func_f95[i]; i++)
2141     if (strcmp (trans_func_f95[i], name) == 0)
2142       break;
2143
2144   /* FIXME, F2003: implement translation of initialization
2145      expressions before enabling this check. For F95, error
2146      out if the transformational function is not in the list.  */
2147 #if 0
2148   if (trans_func_f95[i] == NULL
2149       && gfc_notify_std (GFC_STD_F2003,
2150                          "transformational intrinsic '%s' at %L is not permitted "
2151                          "in an initialization expression", name, &e->where) == FAILURE)
2152     return MATCH_ERROR;
2153 #else
2154   if (trans_func_f95[i] == NULL)
2155     {
2156       gfc_error("transformational intrinsic '%s' at %L is not permitted "
2157                 "in an initialization expression", name, &e->where);
2158       return MATCH_ERROR;
2159     }
2160 #endif
2161
2162   return check_init_expr_arguments (e);
2163 }
2164
2165
2166 /* F95, 7.1.6.1, Initialization expressions, (6)
2167    F2003, 7.1.7 Initialization expression, (6)  */
2168
2169 static match
2170 check_null (gfc_expr *e)
2171 {
2172   if (strcmp ("null", e->symtree->n.sym->name) != 0)
2173     return MATCH_NO;
2174
2175   return check_init_expr_arguments (e);
2176 }
2177
2178
2179 static match
2180 check_elemental (gfc_expr *e)
2181 {
2182   if (!e->value.function.isym
2183       || !e->value.function.isym->elemental)
2184     return MATCH_NO;
2185
2186   if (e->ts.type != BT_INTEGER
2187       && e->ts.type != BT_CHARACTER
2188       && gfc_notify_std (GFC_STD_F2003, "Extension: Evaluation of "
2189                         "nonstandard initialization expression at %L",
2190                         &e->where) == FAILURE)
2191     return MATCH_ERROR;
2192
2193   return check_init_expr_arguments (e);
2194 }
2195
2196
2197 static match
2198 check_conversion (gfc_expr *e)
2199 {
2200   if (!e->value.function.isym
2201       || !e->value.function.isym->conversion)
2202     return MATCH_NO;
2203
2204   return check_init_expr_arguments (e);
2205 }
2206
2207
2208 /* Verify that an expression is an initialization expression.  A side
2209    effect is that the expression tree is reduced to a single constant
2210    node if all goes well.  This would normally happen when the
2211    expression is constructed but function references are assumed to be
2212    intrinsics in the context of initialization expressions.  If
2213    FAILURE is returned an error message has been generated.  */
2214
2215 static gfc_try
2216 check_init_expr (gfc_expr *e)
2217 {
2218   match m;
2219   gfc_try t;
2220
2221   if (e == NULL)
2222     return SUCCESS;
2223
2224   switch (e->expr_type)
2225     {
2226     case EXPR_OP:
2227       t = check_intrinsic_op (e, check_init_expr);
2228       if (t == SUCCESS)
2229         t = gfc_simplify_expr (e, 0);
2230
2231       break;
2232
2233     case EXPR_FUNCTION:
2234       t = FAILURE;
2235
2236       if ((m = check_specification_function (e)) != MATCH_YES)
2237         {
2238           gfc_intrinsic_sym* isym;
2239           gfc_symbol* sym;
2240
2241           sym = e->symtree->n.sym;
2242           if (!gfc_is_intrinsic (sym, 0, e->where)
2243               || (m = gfc_intrinsic_func_interface (e, 0)) != MATCH_YES)
2244             {
2245               gfc_error ("Function '%s' in initialization expression at %L "
2246                          "must be an intrinsic or a specification function",
2247                          e->symtree->n.sym->name, &e->where);
2248               break;
2249             }
2250
2251           if ((m = check_conversion (e)) == MATCH_NO
2252               && (m = check_inquiry (e, 1)) == MATCH_NO
2253               && (m = check_null (e)) == MATCH_NO
2254               && (m = check_transformational (e)) == MATCH_NO
2255               && (m = check_elemental (e)) == MATCH_NO)
2256             {
2257               gfc_error ("Intrinsic function '%s' at %L is not permitted "
2258                          "in an initialization expression",
2259                          e->symtree->n.sym->name, &e->where);
2260               m = MATCH_ERROR;
2261             }
2262
2263           /* Try to scalarize an elemental intrinsic function that has an
2264              array argument.  */
2265           isym = gfc_find_function (e->symtree->n.sym->name);
2266           if (isym && isym->elemental
2267                 && (t = scalarize_intrinsic_call (e)) == SUCCESS)
2268             break;
2269         }
2270
2271       if (m == MATCH_YES)
2272         t = gfc_simplify_expr (e, 0);
2273
2274       break;
2275
2276     case EXPR_VARIABLE:
2277       t = SUCCESS;
2278
2279       if (gfc_check_iter_variable (e) == SUCCESS)
2280         break;
2281
2282       if (e->symtree->n.sym->attr.flavor == FL_PARAMETER)
2283         {
2284           /* A PARAMETER shall not be used to define itself, i.e.
2285                 REAL, PARAMETER :: x = transfer(0, x)
2286              is invalid.  */
2287           if (!e->symtree->n.sym->value)
2288             {
2289               gfc_error("PARAMETER '%s' is used at %L before its definition "
2290                         "is complete", e->symtree->n.sym->name, &e->where);
2291               t = FAILURE;
2292             }
2293           else
2294             t = simplify_parameter_variable (e, 0);
2295
2296           break;
2297         }
2298
2299       if (gfc_in_match_data ())
2300         break;
2301
2302       t = FAILURE;
2303
2304       if (e->symtree->n.sym->as)
2305         {
2306           switch (e->symtree->n.sym->as->type)
2307             {
2308               case AS_ASSUMED_SIZE:
2309                 gfc_error ("Assumed size array '%s' at %L is not permitted "
2310                            "in an initialization expression",
2311                            e->symtree->n.sym->name, &e->where);
2312                 break;
2313
2314               case AS_ASSUMED_SHAPE:
2315                 gfc_error ("Assumed shape array '%s' at %L is not permitted "
2316                            "in an initialization expression",
2317                            e->symtree->n.sym->name, &e->where);
2318                 break;
2319
2320               case AS_DEFERRED:
2321                 gfc_error ("Deferred array '%s' at %L is not permitted "
2322                            "in an initialization expression",
2323                            e->symtree->n.sym->name, &e->where);
2324                 break;
2325
2326               case AS_EXPLICIT:
2327                 gfc_error ("Array '%s' at %L is a variable, which does "
2328                            "not reduce to a constant expression",
2329                            e->symtree->n.sym->name, &e->where);
2330                 break;
2331
2332               default:
2333                 gcc_unreachable();
2334           }
2335         }
2336       else
2337         gfc_error ("Parameter '%s' at %L has not been declared or is "
2338                    "a variable, which does not reduce to a constant "
2339                    "expression", e->symtree->n.sym->name, &e->where);
2340
2341       break;
2342
2343     case EXPR_CONSTANT:
2344     case EXPR_NULL:
2345       t = SUCCESS;
2346       break;
2347
2348     case EXPR_SUBSTRING:
2349       t = check_init_expr (e->ref->u.ss.start);
2350       if (t == FAILURE)
2351         break;
2352
2353       t = check_init_expr (e->ref->u.ss.end);
2354       if (t == SUCCESS)
2355         t = gfc_simplify_expr (e, 0);
2356
2357       break;
2358
2359     case EXPR_STRUCTURE:
2360       if (e->ts.is_iso_c)
2361         t = SUCCESS;
2362       else
2363         t = gfc_check_constructor (e, check_init_expr);
2364       break;
2365
2366     case EXPR_ARRAY:
2367       t = gfc_check_constructor (e, check_init_expr);
2368       if (t == FAILURE)
2369         break;
2370
2371       t = gfc_expand_constructor (e);
2372       if (t == FAILURE)
2373         break;
2374
2375       t = gfc_check_constructor_type (e);
2376       break;
2377
2378     default:
2379       gfc_internal_error ("check_init_expr(): Unknown expression type");
2380     }
2381
2382   return t;
2383 }
2384
2385 /* Reduces a general expression to an initialization expression (a constant).
2386    This used to be part of gfc_match_init_expr.
2387    Note that this function doesn't free the given expression on FAILURE.  */
2388
2389 gfc_try
2390 gfc_reduce_init_expr (gfc_expr *expr)
2391 {
2392   gfc_try t;
2393
2394   gfc_init_expr = 1;
2395   t = gfc_resolve_expr (expr);
2396   if (t == SUCCESS)
2397     t = check_init_expr (expr);
2398   gfc_init_expr = 0;
2399
2400   if (t == FAILURE)
2401     return FAILURE;
2402
2403   if (expr->expr_type == EXPR_ARRAY
2404       && (gfc_check_constructor_type (expr) == FAILURE
2405       || gfc_expand_constructor (expr) == FAILURE))
2406     return FAILURE;
2407
2408   /* Not all inquiry functions are simplified to constant expressions
2409      so it is necessary to call check_inquiry again.  */
2410   if (!gfc_is_constant_expr (expr) && check_inquiry (expr, 1) != MATCH_YES
2411       && !gfc_in_match_data ())
2412     {
2413       gfc_error ("Initialization expression didn't reduce %C");
2414       return FAILURE;
2415     }
2416
2417   return SUCCESS;
2418 }
2419
2420
2421 /* Match an initialization expression.  We work by first matching an
2422    expression, then reducing it to a constant.  The reducing it to
2423    constant part requires a global variable to flag the prohibition
2424    of a non-integer exponent in -std=f95 mode.  */
2425
2426 bool init_flag = false;
2427
2428 match
2429 gfc_match_init_expr (gfc_expr **result)
2430 {
2431   gfc_expr *expr;
2432   match m;
2433   gfc_try t;
2434
2435   expr = NULL;
2436
2437   init_flag = true;
2438
2439   m = gfc_match_expr (&expr);
2440   if (m != MATCH_YES)
2441     {
2442       init_flag = false;
2443       return m;
2444     }
2445
2446   t = gfc_reduce_init_expr (expr);
2447   if (t != SUCCESS)
2448     {
2449       gfc_free_expr (expr);
2450       init_flag = false;
2451       return MATCH_ERROR;
2452     }
2453
2454   *result = expr;
2455   init_flag = false;
2456
2457   return MATCH_YES;
2458 }
2459
2460
2461 /* Given an actual argument list, test to see that each argument is a
2462    restricted expression and optionally if the expression type is
2463    integer or character.  */
2464
2465 static gfc_try
2466 restricted_args (gfc_actual_arglist *a)
2467 {
2468   for (; a; a = a->next)
2469     {
2470       if (check_restricted (a->expr) == FAILURE)
2471         return FAILURE;
2472     }
2473
2474   return SUCCESS;
2475 }
2476
2477
2478 /************* Restricted/specification expressions *************/
2479
2480
2481 /* Make sure a non-intrinsic function is a specification function.  */
2482
2483 static gfc_try
2484 external_spec_function (gfc_expr *e)
2485 {
2486   gfc_symbol *f;
2487
2488   f = e->value.function.esym;
2489
2490   if (f->attr.proc == PROC_ST_FUNCTION)
2491     {
2492       gfc_error ("Specification function '%s' at %L cannot be a statement "
2493                  "function", f->name, &e->where);
2494       return FAILURE;
2495     }
2496
2497   if (f->attr.proc == PROC_INTERNAL)
2498     {
2499       gfc_error ("Specification function '%s' at %L cannot be an internal "
2500                  "function", f->name, &e->where);
2501       return FAILURE;
2502     }
2503
2504   if (!f->attr.pure && !f->attr.elemental)
2505     {
2506       gfc_error ("Specification function '%s' at %L must be PURE", f->name,
2507                  &e->where);
2508       return FAILURE;
2509     }
2510
2511   if (f->attr.recursive)
2512     {
2513       gfc_error ("Specification function '%s' at %L cannot be RECURSIVE",
2514                  f->name, &e->where);
2515       return FAILURE;
2516     }
2517
2518   return restricted_args (e->value.function.actual);
2519 }
2520
2521
2522 /* Check to see that a function reference to an intrinsic is a
2523    restricted expression.  */
2524
2525 static gfc_try
2526 restricted_intrinsic (gfc_expr *e)
2527 {
2528   /* TODO: Check constraints on inquiry functions.  7.1.6.2 (7).  */
2529   if (check_inquiry (e, 0) == MATCH_YES)
2530     return SUCCESS;
2531
2532   return restricted_args (e->value.function.actual);
2533 }
2534
2535
2536 /* Check the expressions of an actual arglist.  Used by check_restricted.  */
2537
2538 static gfc_try
2539 check_arglist (gfc_actual_arglist* arg, gfc_try (*checker) (gfc_expr*))
2540 {
2541   for (; arg; arg = arg->next)
2542     if (checker (arg->expr) == FAILURE)
2543       return FAILURE;
2544
2545   return SUCCESS;
2546 }
2547
2548
2549 /* Check the subscription expressions of a reference chain with a checking
2550    function; used by check_restricted.  */
2551
2552 static gfc_try
2553 check_references (gfc_ref* ref, gfc_try (*checker) (gfc_expr*))
2554 {
2555   int dim;
2556
2557   if (!ref)
2558     return SUCCESS;
2559
2560   switch (ref->type)
2561     {
2562     case REF_ARRAY:
2563       for (dim = 0; dim != ref->u.ar.dimen; ++dim)
2564         {
2565           if (checker (ref->u.ar.start[dim]) == FAILURE)
2566             return FAILURE;
2567           if (checker (ref->u.ar.end[dim]) == FAILURE)
2568             return FAILURE;
2569           if (checker (ref->u.ar.stride[dim]) == FAILURE)
2570             return FAILURE;
2571         }
2572       break;
2573
2574     case REF_COMPONENT:
2575       /* Nothing needed, just proceed to next reference.  */
2576       break;
2577
2578     case REF_SUBSTRING:
2579       if (checker (ref->u.ss.start) == FAILURE)
2580         return FAILURE;
2581       if (checker (ref->u.ss.end) == FAILURE)
2582         return FAILURE;
2583       break;
2584
2585     default:
2586       gcc_unreachable ();
2587       break;
2588     }
2589
2590   return check_references (ref->next, checker);
2591 }
2592
2593
2594 /* Verify that an expression is a restricted expression.  Like its
2595    cousin check_init_expr(), an error message is generated if we
2596    return FAILURE.  */
2597
2598 static gfc_try
2599 check_restricted (gfc_expr *e)
2600 {
2601   gfc_symbol* sym;
2602   gfc_try t;
2603
2604   if (e == NULL)
2605     return SUCCESS;
2606
2607   switch (e->expr_type)
2608     {
2609     case EXPR_OP:
2610       t = check_intrinsic_op (e, check_restricted);
2611       if (t == SUCCESS)
2612         t = gfc_simplify_expr (e, 0);
2613
2614       break;
2615
2616     case EXPR_FUNCTION:
2617       if (e->value.function.esym)
2618         {
2619           t = check_arglist (e->value.function.actual, &check_restricted);
2620           if (t == SUCCESS)
2621             t = external_spec_function (e);
2622         }
2623       else
2624         {
2625           if (e->value.function.isym && e->value.function.isym->inquiry)
2626             t = SUCCESS;
2627           else
2628             t = check_arglist (e->value.function.actual, &check_restricted);
2629
2630           if (t == SUCCESS)
2631             t = restricted_intrinsic (e);
2632         }
2633       break;
2634
2635     case EXPR_VARIABLE:
2636       sym = e->symtree->n.sym;
2637       t = FAILURE;
2638
2639       /* If a dummy argument appears in a context that is valid for a
2640          restricted expression in an elemental procedure, it will have
2641          already been simplified away once we get here.  Therefore we
2642          don't need to jump through hoops to distinguish valid from
2643          invalid cases.  */
2644       if (sym->attr.dummy && sym->ns == gfc_current_ns
2645           && sym->ns->proc_name && sym->ns->proc_name->attr.elemental)
2646         {
2647           gfc_error ("Dummy argument '%s' not allowed in expression at %L",
2648                      sym->name, &e->where);
2649           break;
2650         }
2651
2652       if (sym->attr.optional)
2653         {
2654           gfc_error ("Dummy argument '%s' at %L cannot be OPTIONAL",
2655                      sym->name, &e->where);
2656           break;
2657         }
2658
2659       if (sym->attr.intent == INTENT_OUT)
2660         {
2661           gfc_error ("Dummy argument '%s' at %L cannot be INTENT(OUT)",
2662                      sym->name, &e->where);
2663           break;
2664         }
2665
2666       /* Check reference chain if any.  */
2667       if (check_references (e->ref, &check_restricted) == FAILURE)
2668         break;
2669
2670       /* gfc_is_formal_arg broadcasts that a formal argument list is being
2671          processed in resolve.c(resolve_formal_arglist).  This is done so
2672          that host associated dummy array indices are accepted (PR23446).
2673          This mechanism also does the same for the specification expressions
2674          of array-valued functions.  */
2675       if (e->error
2676             || sym->attr.in_common
2677             || sym->attr.use_assoc
2678             || sym->attr.dummy
2679             || sym->attr.implied_index
2680             || sym->attr.flavor == FL_PARAMETER
2681             || (sym->ns && sym->ns == gfc_current_ns->parent)
2682             || (sym->ns && gfc_current_ns->parent
2683                   && sym->ns == gfc_current_ns->parent->parent)
2684             || (sym->ns->proc_name != NULL
2685                   && sym->ns->proc_name->attr.flavor == FL_MODULE)
2686             || (gfc_is_formal_arg () && (sym->ns == gfc_current_ns)))
2687         {
2688           t = SUCCESS;
2689           break;
2690         }
2691
2692       gfc_error ("Variable '%s' cannot appear in the expression at %L",
2693                  sym->name, &e->where);
2694       /* Prevent a repetition of the error.  */
2695       e->error = 1;
2696       break;
2697
2698     case EXPR_NULL:
2699     case EXPR_CONSTANT:
2700       t = SUCCESS;
2701       break;
2702
2703     case EXPR_SUBSTRING:
2704       t = gfc_specification_expr (e->ref->u.ss.start);
2705       if (t == FAILURE)
2706         break;
2707
2708       t = gfc_specification_expr (e->ref->u.ss.end);
2709       if (t == SUCCESS)
2710         t = gfc_simplify_expr (e, 0);
2711
2712       break;
2713
2714     case EXPR_STRUCTURE:
2715       t = gfc_check_constructor (e, check_restricted);
2716       break;
2717
2718     case EXPR_ARRAY:
2719       t = gfc_check_constructor (e, check_restricted);
2720       break;
2721
2722     default:
2723       gfc_internal_error ("check_restricted(): Unknown expression type");
2724     }
2725
2726   return t;
2727 }
2728
2729
2730 /* Check to see that an expression is a specification expression.  If
2731    we return FAILURE, an error has been generated.  */
2732
2733 gfc_try
2734 gfc_specification_expr (gfc_expr *e)
2735 {
2736
2737   if (e == NULL)
2738     return SUCCESS;
2739
2740   if (e->ts.type != BT_INTEGER)
2741     {
2742       gfc_error ("Expression at %L must be of INTEGER type, found %s",
2743                  &e->where, gfc_basic_typename (e->ts.type));
2744       return FAILURE;
2745     }
2746
2747   if (e->expr_type == EXPR_FUNCTION
2748           && !e->value.function.isym
2749           && !e->value.function.esym
2750           && !gfc_pure (e->symtree->n.sym))
2751     {
2752       gfc_error ("Function '%s' at %L must be PURE",
2753                  e->symtree->n.sym->name, &e->where);
2754       /* Prevent repeat error messages.  */
2755       e->symtree->n.sym->attr.pure = 1;
2756       return FAILURE;
2757     }
2758
2759   if (e->rank != 0)
2760     {
2761       gfc_error ("Expression at %L must be scalar", &e->where);
2762       return FAILURE;
2763     }
2764
2765   if (gfc_simplify_expr (e, 0) == FAILURE)
2766     return FAILURE;
2767
2768   return check_restricted (e);
2769 }
2770
2771
2772 /************** Expression conformance checks.  *************/
2773
2774 /* Given two expressions, make sure that the arrays are conformable.  */
2775
2776 gfc_try
2777 gfc_check_conformance (const char *optype_msgid, gfc_expr *op1, gfc_expr *op2)
2778 {
2779   int op1_flag, op2_flag, d;
2780   mpz_t op1_size, op2_size;
2781   gfc_try t;
2782
2783   if (op1->rank == 0 || op2->rank == 0)
2784     return SUCCESS;
2785
2786   if (op1->rank != op2->rank)
2787     {
2788       gfc_error ("Incompatible ranks in %s (%d and %d) at %L", _(optype_msgid),
2789                  op1->rank, op2->rank, &op1->where);
2790       return FAILURE;
2791     }
2792
2793   t = SUCCESS;
2794
2795   for (d = 0; d < op1->rank; d++)
2796     {
2797       op1_flag = gfc_array_dimen_size (op1, d, &op1_size) == SUCCESS;
2798       op2_flag = gfc_array_dimen_size (op2, d, &op2_size) == SUCCESS;
2799
2800       if (op1_flag && op2_flag && mpz_cmp (op1_size, op2_size) != 0)
2801         {
2802           gfc_error ("Different shape for %s at %L on dimension %d "
2803                      "(%d and %d)", _(optype_msgid), &op1->where, d + 1,
2804                      (int) mpz_get_si (op1_size),
2805                      (int) mpz_get_si (op2_size));
2806
2807           t = FAILURE;
2808         }
2809
2810       if (op1_flag)
2811         mpz_clear (op1_size);
2812       if (op2_flag)
2813         mpz_clear (op2_size);
2814
2815       if (t == FAILURE)
2816         return FAILURE;
2817     }
2818
2819   return SUCCESS;
2820 }
2821
2822
2823 /* Given an assignable expression and an arbitrary expression, make
2824    sure that the assignment can take place.  */
2825
2826 gfc_try
2827 gfc_check_assign (gfc_expr *lvalue, gfc_expr *rvalue, int conform)
2828 {
2829   gfc_symbol *sym;
2830   gfc_ref *ref;
2831   int has_pointer;
2832
2833   sym = lvalue->symtree->n.sym;
2834
2835   /* Check INTENT(IN), unless the object itself is the component or
2836      sub-component of a pointer.  */
2837   has_pointer = sym->attr.pointer;
2838
2839   for (ref = lvalue->ref; ref; ref = ref->next)
2840     if (ref->type == REF_COMPONENT && ref->u.c.component->attr.pointer)
2841       {
2842         has_pointer = 1;
2843         break;
2844       }
2845
2846   if (!has_pointer && sym->attr.intent == INTENT_IN)
2847     {
2848       gfc_error ("Cannot assign to INTENT(IN) variable '%s' at %L",
2849                  sym->name, &lvalue->where);
2850       return FAILURE;
2851     }
2852
2853   /* 12.5.2.2, Note 12.26: The result variable is very similar to any other
2854      variable local to a function subprogram.  Its existence begins when
2855      execution of the function is initiated and ends when execution of the
2856      function is terminated...
2857      Therefore, the left hand side is no longer a variable, when it is:  */
2858   if (sym->attr.flavor == FL_PROCEDURE && sym->attr.proc != PROC_ST_FUNCTION
2859       && !sym->attr.external)
2860     {
2861       bool bad_proc;
2862       bad_proc = false;
2863
2864       /* (i) Use associated;  */
2865       if (sym->attr.use_assoc)
2866         bad_proc = true;
2867
2868       /* (ii) The assignment is in the main program; or  */
2869       if (gfc_current_ns->proc_name->attr.is_main_program)
2870         bad_proc = true;
2871
2872       /* (iii) A module or internal procedure...  */
2873       if ((gfc_current_ns->proc_name->attr.proc == PROC_INTERNAL
2874            || gfc_current_ns->proc_name->attr.proc == PROC_MODULE)
2875           && gfc_current_ns->parent
2876           && (!(gfc_current_ns->parent->proc_name->attr.function
2877                 || gfc_current_ns->parent->proc_name->attr.subroutine)
2878               || gfc_current_ns->parent->proc_name->attr.is_main_program))
2879         {
2880           /* ... that is not a function...  */
2881           if (!gfc_current_ns->proc_name->attr.function)
2882             bad_proc = true;
2883
2884           /* ... or is not an entry and has a different name.  */
2885           if (!sym->attr.entry && sym->name != gfc_current_ns->proc_name->name)
2886             bad_proc = true;
2887         }
2888
2889       /* (iv) Host associated and not the function symbol or the
2890               parent result.  This picks up sibling references, which
2891               cannot be entries.  */
2892       if (!sym->attr.entry
2893             && sym->ns == gfc_current_ns->parent
2894             && sym != gfc_current_ns->proc_name
2895             && sym != gfc_current_ns->parent->proc_name->result)
2896         bad_proc = true;
2897
2898       if (bad_proc)
2899         {
2900           gfc_error ("'%s' at %L is not a VALUE", sym->name, &lvalue->where);
2901           return FAILURE;
2902         }
2903     }
2904
2905   if (rvalue->rank != 0 && lvalue->rank != rvalue->rank)
2906     {
2907       gfc_error ("Incompatible ranks %d and %d in assignment at %L",
2908                  lvalue->rank, rvalue->rank, &lvalue->where);
2909       return FAILURE;
2910     }
2911
2912   if (lvalue->ts.type == BT_UNKNOWN)
2913     {
2914       gfc_error ("Variable type is UNKNOWN in assignment at %L",
2915                  &lvalue->where);
2916       return FAILURE;
2917     }
2918
2919   if (rvalue->expr_type == EXPR_NULL)
2920     {
2921       if (has_pointer && (ref == NULL || ref->next == NULL)
2922           && lvalue->symtree->n.sym->attr.data)
2923         return SUCCESS;
2924       else
2925         {
2926           gfc_error ("NULL appears on right-hand side in assignment at %L",
2927                      &rvalue->where);
2928           return FAILURE;
2929         }
2930     }
2931
2932    if (sym->attr.cray_pointee
2933        && lvalue->ref != NULL
2934        && lvalue->ref->u.ar.type == AR_FULL
2935        && lvalue->ref->u.ar.as->cp_was_assumed)
2936      {
2937        gfc_error ("Vector assignment to assumed-size Cray Pointee at %L "
2938                   "is illegal", &lvalue->where);
2939        return FAILURE;
2940      }
2941
2942   /* This is possibly a typo: x = f() instead of x => f().  */
2943   if (gfc_option.warn_surprising
2944       && rvalue->expr_type == EXPR_FUNCTION
2945       && rvalue->symtree->n.sym->attr.pointer)
2946     gfc_warning ("POINTER valued function appears on right-hand side of "
2947                  "assignment at %L", &rvalue->where);
2948
2949   /* Check size of array assignments.  */
2950   if (lvalue->rank != 0 && rvalue->rank != 0
2951       && gfc_check_conformance ("array assignment", lvalue, rvalue) != SUCCESS)
2952     return FAILURE;
2953
2954   if (rvalue->is_boz && lvalue->ts.type != BT_INTEGER
2955       && lvalue->symtree->n.sym->attr.data
2956       && gfc_notify_std (GFC_STD_GNU, "Extension: BOZ literal at %L used to "
2957                          "initialize non-integer variable '%s'",
2958                          &rvalue->where, lvalue->symtree->n.sym->name)
2959          == FAILURE)
2960     return FAILURE;
2961   else if (rvalue->is_boz && !lvalue->symtree->n.sym->attr.data
2962       && gfc_notify_std (GFC_STD_GNU, "Extension: BOZ literal at %L outside "
2963                          "a DATA statement and outside INT/REAL/DBLE/CMPLX",
2964                          &rvalue->where) == FAILURE)
2965     return FAILURE;
2966
2967   /* Handle the case of a BOZ literal on the RHS.  */
2968   if (rvalue->is_boz && lvalue->ts.type != BT_INTEGER)
2969     {
2970       int rc;
2971       if (gfc_option.warn_surprising)
2972         gfc_warning ("BOZ literal at %L is bitwise transferred "
2973                      "non-integer symbol '%s'", &rvalue->where,
2974                      lvalue->symtree->n.sym->name);
2975       if (!gfc_convert_boz (rvalue, &lvalue->ts))
2976         return FAILURE;
2977       if ((rc = gfc_range_check (rvalue)) != ARITH_OK)
2978         {
2979           if (rc == ARITH_UNDERFLOW)
2980             gfc_error ("Arithmetic underflow of bit-wise transferred BOZ at %L"
2981                        ". This check can be disabled with the option "
2982                        "-fno-range-check", &rvalue->where);
2983           else if (rc == ARITH_OVERFLOW)
2984             gfc_error ("Arithmetic overflow of bit-wise transferred BOZ at %L"
2985                        ". This check can be disabled with the option "
2986                        "-fno-range-check", &rvalue->where);
2987           else if (rc == ARITH_NAN)
2988             gfc_error ("Arithmetic NaN of bit-wise transferred BOZ at %L"
2989                        ". This check can be disabled with the option "
2990                        "-fno-range-check", &rvalue->where);
2991           return FAILURE;
2992         }
2993     }
2994
2995   if (gfc_compare_types (&lvalue->ts, &rvalue->ts))
2996     return SUCCESS;
2997
2998   /* Only DATA Statements come here.  */
2999   if (!conform)
3000     {
3001       /* Numeric can be converted to any other numeric. And Hollerith can be
3002          converted to any other type.  */
3003       if ((gfc_numeric_ts (&lvalue->ts) && gfc_numeric_ts (&rvalue->ts))
3004           || rvalue->ts.type == BT_HOLLERITH)
3005         return SUCCESS;
3006
3007       if (lvalue->ts.type == BT_LOGICAL && rvalue->ts.type == BT_LOGICAL)
3008         return SUCCESS;
3009
3010       gfc_error ("Incompatible types in DATA statement at %L; attempted "
3011                  "conversion of %s to %s", &lvalue->where,
3012                  gfc_typename (&rvalue->ts), gfc_typename (&lvalue->ts));
3013
3014       return FAILURE;
3015     }
3016
3017   /* Assignment is the only case where character variables of different
3018      kind values can be converted into one another.  */
3019   if (lvalue->ts.type == BT_CHARACTER && rvalue->ts.type == BT_CHARACTER)
3020     {
3021       if (lvalue->ts.kind != rvalue->ts.kind)
3022         gfc_convert_chartype (rvalue, &lvalue->ts);
3023
3024       return SUCCESS;
3025     }
3026
3027   return gfc_convert_type (rvalue, &lvalue->ts, 1);
3028 }
3029
3030
3031 /* Check that a pointer assignment is OK.  We first check lvalue, and
3032    we only check rvalue if it's not an assignment to NULL() or a
3033    NULLIFY statement.  */
3034
3035 gfc_try
3036 gfc_check_pointer_assign (gfc_expr *lvalue, gfc_expr *rvalue)
3037 {
3038   symbol_attribute attr;
3039   gfc_ref *ref;
3040   int is_pure;
3041   int pointer, check_intent_in;
3042
3043   if (lvalue->symtree->n.sym->ts.type == BT_UNKNOWN
3044       && !lvalue->symtree->n.sym->attr.proc_pointer)
3045     {
3046       gfc_error ("Pointer assignment target is not a POINTER at %L",
3047                  &lvalue->where);
3048       return FAILURE;
3049     }
3050
3051   if (lvalue->symtree->n.sym->attr.flavor == FL_PROCEDURE
3052       && lvalue->symtree->n.sym->attr.use_assoc
3053       && !lvalue->symtree->n.sym->attr.proc_pointer)
3054     {
3055       gfc_error ("'%s' in the pointer assignment at %L cannot be an "
3056                  "l-value since it is a procedure",
3057                  lvalue->symtree->n.sym->name, &lvalue->where);
3058       return FAILURE;
3059     }
3060
3061
3062   /* Check INTENT(IN), unless the object itself is the component or
3063      sub-component of a pointer.  */
3064   check_intent_in = 1;
3065   pointer = lvalue->symtree->n.sym->attr.pointer
3066               | lvalue->symtree->n.sym->attr.proc_pointer;
3067
3068   for (ref = lvalue->ref; ref; ref = ref->next)
3069     {
3070       if (pointer)
3071         check_intent_in = 0;
3072
3073       if (ref->type == REF_COMPONENT)
3074         pointer = ref->u.c.component->attr.pointer;
3075
3076       if (ref->type == REF_ARRAY && ref->next == NULL)
3077         {
3078           if (ref->u.ar.type == AR_FULL)
3079             break;
3080
3081           if (ref->u.ar.type != AR_SECTION)
3082             {
3083               gfc_error ("Expected bounds specification for '%s' at %L",
3084                          lvalue->symtree->n.sym->name, &lvalue->where);
3085               return FAILURE;
3086             }
3087
3088           if (gfc_notify_std (GFC_STD_F2003,"Fortran 2003: Bounds "
3089                               "specification for '%s' in pointer assignment "
3090                               "at %L", lvalue->symtree->n.sym->name,
3091                               &lvalue->where) == FAILURE)
3092             return FAILURE;
3093
3094           gfc_error ("Pointer bounds remapping at %L is not yet implemented "
3095                      "in gfortran", &lvalue->where);
3096           /* TODO: See PR 29785. Add checks that all lbounds are specified and
3097              either never or always the upper-bound; strides shall not be
3098              present.  */
3099           return FAILURE;
3100         }
3101     }
3102
3103   if (check_intent_in && lvalue->symtree->n.sym->attr.intent == INTENT_IN)
3104     {
3105       gfc_error ("Cannot assign to INTENT(IN) variable '%s' at %L",
3106                  lvalue->symtree->n.sym->name, &lvalue->where);
3107       return FAILURE;
3108     }
3109
3110   if (!pointer)
3111     {
3112       gfc_error ("Pointer assignment to non-POINTER at %L", &lvalue->where);
3113       return FAILURE;
3114     }
3115
3116   is_pure = gfc_pure (NULL);
3117
3118   if (is_pure && gfc_impure_variable (lvalue->symtree->n.sym)
3119         && lvalue->symtree->n.sym->value != rvalue)
3120     {
3121       gfc_error ("Bad pointer object in PURE procedure at %L", &lvalue->where);
3122       return FAILURE;
3123     }
3124
3125   /* If rvalue is a NULL() or NULLIFY, we're done. Otherwise the type,
3126      kind, etc for lvalue and rvalue must match, and rvalue must be a
3127      pure variable if we're in a pure function.  */
3128   if (rvalue->expr_type == EXPR_NULL && rvalue->ts.type == BT_UNKNOWN)
3129     return SUCCESS;
3130
3131   /* Checks on rvalue for procedure pointer assignments.  */
3132   if (lvalue->symtree->n.sym->attr.proc_pointer)
3133     {
3134       attr = gfc_expr_attr (rvalue);
3135       if (!((rvalue->expr_type == EXPR_NULL)
3136             || (rvalue->expr_type == EXPR_FUNCTION && attr.proc_pointer)
3137             || (rvalue->expr_type == EXPR_VARIABLE
3138                 && attr.flavor == FL_PROCEDURE)))
3139         {
3140           gfc_error ("Invalid procedure pointer assignment at %L",
3141                      &rvalue->where);
3142           return FAILURE;
3143         }
3144       if (attr.abstract)
3145         {
3146           gfc_error ("Abstract interface '%s' is invalid "
3147                      "in procedure pointer assignment at %L",
3148                      rvalue->symtree->name, &rvalue->where);
3149           return FAILURE;
3150         }
3151       if (rvalue->expr_type == EXPR_VARIABLE
3152           && !gfc_compare_interfaces (lvalue->symtree->n.sym,
3153                                       rvalue->symtree->n.sym, 0))
3154         {
3155           gfc_error ("Interfaces don't match "
3156                      "in procedure pointer assignment at %L", &rvalue->where);
3157           return FAILURE;
3158         }
3159       return SUCCESS;
3160     }
3161
3162   if (!gfc_compare_types (&lvalue->ts, &rvalue->ts))
3163     {
3164       gfc_error ("Different types in pointer assignment at %L; attempted "
3165                  "assignment of %s to %s", &lvalue->where,
3166                  gfc_typename (&rvalue->ts), gfc_typename (&lvalue->ts));
3167       return FAILURE;
3168     }
3169
3170   if (lvalue->ts.kind != rvalue->ts.kind)
3171     {
3172       gfc_error ("Different kind type parameters in pointer "
3173                  "assignment at %L", &lvalue->where);
3174       return FAILURE;
3175     }
3176
3177   if (lvalue->rank != rvalue->rank)
3178     {
3179       gfc_error ("Different ranks in pointer assignment at %L",
3180                  &lvalue->where);
3181       return FAILURE;
3182     }
3183
3184   /* Now punt if we are dealing with a NULLIFY(X) or X = NULL(X).  */
3185   if (rvalue->expr_type == EXPR_NULL)
3186     return SUCCESS;
3187
3188   if (lvalue->ts.type == BT_CHARACTER)
3189     {
3190       gfc_try t = gfc_check_same_strlen (lvalue, rvalue, "pointer assignment");
3191       if (t == FAILURE)
3192         return FAILURE;
3193     }
3194
3195   if (rvalue->expr_type == EXPR_VARIABLE && is_subref_array (rvalue))
3196     lvalue->symtree->n.sym->attr.subref_array_pointer = 1;
3197
3198   attr = gfc_expr_attr (rvalue);
3199   if (!attr.target && !attr.pointer)
3200     {
3201       gfc_error ("Pointer assignment target is neither TARGET "
3202                  "nor POINTER at %L", &rvalue->where);
3203       return FAILURE;
3204     }
3205
3206   if (is_pure && gfc_impure_variable (rvalue->symtree->n.sym))
3207     {
3208       gfc_error ("Bad target in pointer assignment in PURE "
3209                  "procedure at %L", &rvalue->where);
3210     }
3211
3212   if (gfc_has_vector_index (rvalue))
3213     {
3214       gfc_error ("Pointer assignment with vector subscript "
3215                  "on rhs at %L", &rvalue->where);
3216       return FAILURE;
3217     }
3218
3219   if (attr.is_protected && attr.use_assoc
3220       && !(attr.pointer || attr.proc_pointer))
3221     {
3222       gfc_error ("Pointer assignment target has PROTECTED "
3223                  "attribute at %L", &rvalue->where);
3224       return FAILURE;
3225     }
3226
3227   return SUCCESS;
3228 }
3229
3230
3231 /* Relative of gfc_check_assign() except that the lvalue is a single
3232    symbol.  Used for initialization assignments.  */
3233
3234 gfc_try
3235 gfc_check_assign_symbol (gfc_symbol *sym, gfc_expr *rvalue)
3236 {
3237   gfc_expr lvalue;
3238   gfc_try r;
3239
3240   memset (&lvalue, '\0', sizeof (gfc_expr));
3241
3242   lvalue.expr_type = EXPR_VARIABLE;
3243   lvalue.ts = sym->ts;
3244   if (sym->as)
3245     lvalue.rank = sym->as->rank;
3246   lvalue.symtree = (gfc_symtree *) gfc_getmem (sizeof (gfc_symtree));
3247   lvalue.symtree->n.sym = sym;
3248   lvalue.where = sym->declared_at;
3249
3250   if (sym->attr.pointer || sym->attr.proc_pointer)
3251     r = gfc_check_pointer_assign (&lvalue, rvalue);
3252   else
3253     r = gfc_check_assign (&lvalue, rvalue, 1);
3254
3255   gfc_free (lvalue.symtree);
3256
3257   return r;
3258 }
3259
3260
3261 /* Get an expression for a default initializer.  */
3262
3263 gfc_expr *
3264 gfc_default_initializer (gfc_typespec *ts)
3265 {
3266   gfc_constructor *tail;
3267   gfc_expr *init;
3268   gfc_component *c;
3269
3270   /* See if we have a default initializer.  */
3271   for (c = ts->derived->components; c; c = c->next)
3272     if (c->initializer || c->attr.allocatable)
3273       break;
3274
3275   if (!c)
3276     return NULL;
3277
3278   /* Build the constructor.  */
3279   init = gfc_get_expr ();
3280   init->expr_type = EXPR_STRUCTURE;
3281   init->ts = *ts;
3282   init->where = ts->derived->declared_at;
3283
3284   tail = NULL;
3285   for (c = ts->derived->components; c; c = c->next)
3286     {
3287       if (tail == NULL)
3288         init->value.constructor = tail = gfc_get_constructor ();
3289       else
3290         {
3291           tail->next = gfc_get_constructor ();
3292           tail = tail->next;
3293         }
3294
3295       if (c->initializer)
3296         tail->expr = gfc_copy_expr (c->initializer);
3297
3298       if (c->attr.allocatable)
3299         {
3300           tail->expr = gfc_get_expr ();
3301           tail->expr->expr_type = EXPR_NULL;
3302           tail->expr->ts = c->ts;
3303         }
3304     }
3305   return init;
3306 }
3307
3308
3309 /* Given a symbol, create an expression node with that symbol as a
3310    variable. If the symbol is array valued, setup a reference of the
3311    whole array.  */
3312
3313 gfc_expr *
3314 gfc_get_variable_expr (gfc_symtree *var)
3315 {
3316   gfc_expr *e;
3317
3318   e = gfc_get_expr ();
3319   e->expr_type = EXPR_VARIABLE;
3320   e->symtree = var;
3321   e->ts = var->n.sym->ts;
3322
3323   if (var->n.sym->as != NULL)
3324     {
3325       e->rank = var->n.sym->as->rank;
3326       e->ref = gfc_get_ref ();
3327       e->ref->type = REF_ARRAY;
3328       e->ref->u.ar.type = AR_FULL;
3329     }
3330
3331   return e;
3332 }
3333
3334
3335 /* General expression traversal function.  */
3336
3337 bool
3338 gfc_traverse_expr (gfc_expr *expr, gfc_symbol *sym,
3339                    bool (*func)(gfc_expr *, gfc_symbol *, int*),
3340                    int f)
3341 {
3342   gfc_array_ref ar;
3343   gfc_ref *ref;
3344   gfc_actual_arglist *args;
3345   gfc_constructor *c;
3346   int i;
3347
3348   if (!expr)
3349     return false;
3350
3351   if ((*func) (expr, sym, &f))
3352     return true;
3353
3354   if (expr->ts.type == BT_CHARACTER
3355         && expr->ts.cl
3356         && expr->ts.cl->length
3357         && expr->ts.cl->length->expr_type != EXPR_CONSTANT
3358         && gfc_traverse_expr (expr->ts.cl->length, sym, func, f))
3359     return true;
3360
3361   switch (expr->expr_type)
3362     {
3363     case EXPR_FUNCTION:
3364       for (args = expr->value.function.actual; args; args = args->next)
3365         {
3366           if (gfc_traverse_expr (args->expr, sym, func, f))
3367             return true;
3368         }
3369       break;
3370
3371     case EXPR_VARIABLE:
3372     case EXPR_CONSTANT:
3373     case EXPR_NULL:
3374     case EXPR_SUBSTRING:
3375       break;
3376
3377     case EXPR_STRUCTURE:
3378     case EXPR_ARRAY:
3379       for (c = expr->value.constructor; c; c = c->next)
3380         {
3381           if (gfc_traverse_expr (c->expr, sym, func, f))
3382             return true;
3383           if (c->iterator)
3384             {
3385               if (gfc_traverse_expr (c->iterator->var, sym, func, f))
3386                 return true;
3387               if (gfc_traverse_expr (c->iterator->start, sym, func, f))
3388                 return true;
3389               if (gfc_traverse_expr (c->iterator->end, sym, func, f))
3390                 return true;
3391               if (gfc_traverse_expr (c->iterator->step, sym, func, f))
3392                 return true;
3393             }
3394         }
3395       break;
3396
3397     case EXPR_OP:
3398       if (gfc_traverse_expr (expr->value.op.op1, sym, func, f))
3399         return true;
3400       if (gfc_traverse_expr (expr->value.op.op2, sym, func, f))
3401         return true;
3402       break;
3403
3404     default:
3405       gcc_unreachable ();
3406       break;
3407     }
3408
3409   ref = expr->ref;
3410   while (ref != NULL)
3411     {
3412       switch (ref->type)
3413         {
3414         case  REF_ARRAY:
3415           ar = ref->u.ar;
3416           for (i = 0; i < GFC_MAX_DIMENSIONS; i++)
3417             {
3418               if (gfc_traverse_expr (ar.start[i], sym, func, f))
3419                 return true;
3420               if (gfc_traverse_expr (ar.end[i], sym, func, f))
3421                 return true;
3422               if (gfc_traverse_expr (ar.stride[i], sym, func, f))
3423                 return true;
3424             }
3425           break;
3426
3427         case REF_SUBSTRING:
3428           if (gfc_traverse_expr (ref->u.ss.start, sym, func, f))
3429             return true;
3430           if (gfc_traverse_expr (ref->u.ss.end, sym, func, f))
3431             return true;
3432           break;
3433
3434         case REF_COMPONENT:
3435           if (ref->u.c.component->ts.type == BT_CHARACTER
3436                 && ref->u.c.component->ts.cl
3437                 && ref->u.c.component->ts.cl->length
3438                 && ref->u.c.component->ts.cl->length->expr_type
3439                      != EXPR_CONSTANT
3440                 && gfc_traverse_expr (ref->u.c.component->ts.cl->length,
3441                                       sym, func, f))
3442             return true;
3443
3444           if (ref->u.c.component->as)
3445             for (i = 0; i < ref->u.c.component->as->rank; i++)
3446               {
3447                 if (gfc_traverse_expr (ref->u.c.component->as->lower[i],
3448                                        sym, func, f))
3449                   return true;
3450                 if (gfc_traverse_expr (ref->u.c.component->as->upper[i],
3451                                        sym, func, f))
3452                   return true;
3453               }
3454           break;
3455
3456         default:
3457           gcc_unreachable ();
3458         }
3459       ref = ref->next;
3460     }
3461   return false;
3462 }
3463
3464 /* Traverse expr, marking all EXPR_VARIABLE symbols referenced.  */
3465
3466 static bool
3467 expr_set_symbols_referenced (gfc_expr *expr,
3468                              gfc_symbol *sym ATTRIBUTE_UNUSED,
3469                              int *f ATTRIBUTE_UNUSED)
3470 {
3471   if (expr->expr_type != EXPR_VARIABLE)
3472     return false;
3473   gfc_set_sym_referenced (expr->symtree->n.sym);
3474   return false;
3475 }
3476
3477 void
3478 gfc_expr_set_symbols_referenced (gfc_expr *expr)
3479 {
3480   gfc_traverse_expr (expr, NULL, expr_set_symbols_referenced, 0);
3481 }
3482
3483
3484 /* Walk an expression tree and check each variable encountered for being typed.
3485    If strict is not set, a top-level variable is tolerated untyped in -std=gnu
3486    mode as is a basic arithmetic expression using those; this is for things in
3487    legacy-code like:
3488
3489      INTEGER :: arr(n), n
3490      INTEGER :: arr(n + 1), n
3491
3492    The namespace is needed for IMPLICIT typing.  */
3493
3494 static gfc_namespace* check_typed_ns;
3495
3496 static bool
3497 expr_check_typed_help (gfc_expr* e, gfc_symbol* sym ATTRIBUTE_UNUSED,
3498                        int* f ATTRIBUTE_UNUSED)
3499 {
3500   gfc_try t;
3501
3502   if (e->expr_type != EXPR_VARIABLE)
3503     return false;
3504
3505   gcc_assert (e->symtree);
3506   t = gfc_check_symbol_typed (e->symtree->n.sym, check_typed_ns,
3507                               true, e->where);
3508
3509   return (t == FAILURE);
3510 }
3511
3512 gfc_try
3513 gfc_expr_check_typed (gfc_expr* e, gfc_namespace* ns, bool strict)
3514 {
3515   bool error_found;
3516
3517   /* If this is a top-level variable or EXPR_OP, do the check with strict given
3518      to us.  */
3519   if (!strict)
3520     {
3521       if (e->expr_type == EXPR_VARIABLE && !e->ref)
3522         return gfc_check_symbol_typed (e->symtree->n.sym, ns, strict, e->where);
3523
3524       if (e->expr_type == EXPR_OP)
3525         {
3526           gfc_try t = SUCCESS;
3527
3528           gcc_assert (e->value.op.op1);
3529           t = gfc_expr_check_typed (e->value.op.op1, ns, strict);
3530
3531           if (t == SUCCESS && e->value.op.op2)
3532             t = gfc_expr_check_typed (e->value.op.op2, ns, strict);
3533
3534           return t;
3535         }
3536     }
3537
3538   /* Otherwise, walk the expression and do it strictly.  */
3539   check_typed_ns = ns;
3540   error_found = gfc_traverse_expr (e, NULL, &expr_check_typed_help, 0);
3541
3542   return error_found ? FAILURE : SUCCESS;
3543 }
3544
3545 /* Walk an expression tree and replace all symbols with a corresponding symbol
3546    in the formal_ns of "sym". Needed for copying interfaces in PROCEDURE
3547    statements. The boolean return value is required by gfc_traverse_expr.  */
3548
3549 static bool
3550 replace_symbol (gfc_expr *expr, gfc_symbol *sym, int *i ATTRIBUTE_UNUSED)
3551 {
3552   if ((expr->expr_type == EXPR_VARIABLE
3553        || (expr->expr_type == EXPR_FUNCTION
3554            && !gfc_is_intrinsic (expr->symtree->n.sym, 0, expr->where)))
3555       && expr->symtree->n.sym->ns == sym->ts.interface->formal_ns)
3556     {
3557       gfc_symtree *stree;
3558       gfc_namespace *ns = sym->formal_ns;
3559       /* Don't use gfc_get_symtree as we prefer to fail badly if we don't find
3560          the symtree rather than create a new one (and probably fail later).  */
3561       stree = gfc_find_symtree (ns ? ns->sym_root : gfc_current_ns->sym_root,
3562                                 expr->symtree->n.sym->name);
3563       gcc_assert (stree);
3564       stree->n.sym->attr = expr->symtree->n.sym->attr;
3565       expr->symtree = stree;
3566     }
3567   return false;
3568 }
3569
3570 void
3571 gfc_expr_replace_symbols (gfc_expr *expr, gfc_symbol *dest)
3572 {
3573   gfc_traverse_expr (expr, dest, &replace_symbol, 0);
3574 }