gcc/fortran/expr.c

   1 /* Routines for manipulation of expression nodes.
   2    Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008
   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       e = gfc_copy_expr (ar->start[i]);
1032       if (e->expr_type != EXPR_CONSTANT)
1033         {
1034           cons = NULL;
1035           goto depart;
1036         }
1037
1038       /* Check the bounds.  */
1039       if ((ar->as->upper[i]
1040            && ar->as->upper[i]->expr_type == EXPR_CONSTANT
1041            && mpz_cmp (e->value.integer,
1042                        ar->as->upper[i]->value.integer) > 0)
1043           || (ar->as->lower[i]->expr_type == EXPR_CONSTANT
1044               && mpz_cmp (e->value.integer,
1045                           ar->as->lower[i]->value.integer) < 0))
1046         {
1047           gfc_error ("Index in dimension %d is out of bounds "
1048                      "at %L", i + 1, &ar->c_where[i]);
1049           cons = NULL;
1050           t = FAILURE;
1051           goto depart;
1052         }
1053
1054       mpz_sub (delta, e->value.integer, ar->as->lower[i]->value.integer);
1055       mpz_mul (delta, delta, span);
1056       mpz_add (offset, offset, delta);
1057
1058       mpz_set_ui (tmp, 1);
1059       mpz_add (tmp, tmp, ar->as->upper[i]->value.integer);
1060       mpz_sub (tmp, tmp, ar->as->lower[i]->value.integer);
1061       mpz_mul (span, span, tmp);
1062     }
1063
1064   for (nelemen = mpz_get_ui (offset); nelemen > 0; nelemen--)
1065     {
1066       if (cons)
1067         {
1068           if (cons->iterator)
1069             {
1070               cons = NULL;
1071               goto depart;
1072             }
1073           cons = cons->next;
1074         }
1075     }
1076
1077 depart:
1078   mpz_clear (delta);
1079   mpz_clear (offset);
1080   mpz_clear (span);
1081   mpz_clear (tmp);
1082   if (e)
1083     gfc_free_expr (e);
1084   *rval = cons;
1085   return t;
1086 }
1087
1088
1089 /* Find a component of a structure constructor.  */
1090
1091 static gfc_constructor *
1092 find_component_ref (gfc_constructor *cons, gfc_ref *ref)
1093 {
1094   gfc_component *comp;
1095   gfc_component *pick;
1096
1097   comp = ref->u.c.sym->components;
1098   pick = ref->u.c.component;
1099   while (comp != pick)
1100     {
1101       comp = comp->next;
1102       cons = cons->next;
1103     }
1104
1105   return cons;
1106 }
1107
1108
1109 /* Replace an expression with the contents of a constructor, removing
1110    the subobject reference in the process.  */
1111
1112 static void
1113 remove_subobject_ref (gfc_expr *p, gfc_constructor *cons)
1114 {
1115   gfc_expr *e;
1116
1117   e = cons->expr;
1118   cons->expr = NULL;
1119   e->ref = p->ref->next;
1120   p->ref->next =  NULL;
1121   gfc_replace_expr (p, e);
1122 }
1123
1124
1125 /* Pull an array section out of an array constructor.  */
1126
1127 static gfc_try
1128 find_array_section (gfc_expr *expr, gfc_ref *ref)
1129 {
1130   int idx;
1131   int rank;
1132   int d;
1133   int shape_i;
1134   long unsigned one = 1;
1135   bool incr_ctr;
1136   mpz_t start[GFC_MAX_DIMENSIONS];
1137   mpz_t end[GFC_MAX_DIMENSIONS];
1138   mpz_t stride[GFC_MAX_DIMENSIONS];
1139   mpz_t delta[GFC_MAX_DIMENSIONS];
1140   mpz_t ctr[GFC_MAX_DIMENSIONS];
1141   mpz_t delta_mpz;
1142   mpz_t tmp_mpz;
1143   mpz_t nelts;
1144   mpz_t ptr;
1145   mpz_t index;
1146   gfc_constructor *cons;
1147   gfc_constructor *base;
1148   gfc_expr *begin;
1149   gfc_expr *finish;
1150   gfc_expr *step;
1151   gfc_expr *upper;
1152   gfc_expr *lower;
1153   gfc_constructor *vecsub[GFC_MAX_DIMENSIONS], *c;
1154   gfc_try t;
1155
1156   t = SUCCESS;
1157
1158   base = expr->value.constructor;
1159   expr->value.constructor = NULL;
1160
1161   rank = ref->u.ar.as->rank;
1162
1163   if (expr->shape == NULL)
1164     expr->shape = gfc_get_shape (rank);
1165
1166   mpz_init_set_ui (delta_mpz, one);
1167   mpz_init_set_ui (nelts, one);
1168   mpz_init (tmp_mpz);
1169
1170   /* Do the initialization now, so that we can cleanup without
1171      keeping track of where we were.  */
1172   for (d = 0; d < rank; d++)
1173     {
1174       mpz_init (delta[d]);
1175       mpz_init (start[d]);
1176       mpz_init (end[d]);
1177       mpz_init (ctr[d]);
1178       mpz_init (stride[d]);
1179       vecsub[d] = NULL;
1180     }
1181
1182   /* Build the counters to clock through the array reference.  */
1183   shape_i = 0;
1184   for (d = 0; d < rank; d++)
1185     {
1186       /* Make this stretch of code easier on the eye!  */
1187       begin = ref->u.ar.start[d];
1188       finish = ref->u.ar.end[d];
1189       step = ref->u.ar.stride[d];
1190       lower = ref->u.ar.as->lower[d];
1191       upper = ref->u.ar.as->upper[d];
1192
1193       if (ref->u.ar.dimen_type[d] == DIMEN_VECTOR)  /* Vector subscript.  */
1194         {
1195           gcc_assert (begin);
1196
1197           if (begin->expr_type != EXPR_ARRAY || !gfc_is_constant_expr (begin))
1198             {
1199               t = FAILURE;
1200               goto cleanup;
1201             }
1202
1203           gcc_assert (begin->rank == 1);
1204           gcc_assert (begin->shape);
1205
1206           vecsub[d] = begin->value.constructor;
1207           mpz_set (ctr[d], vecsub[d]->expr->value.integer);
1208           mpz_mul (nelts, nelts, begin->shape[0]);
1209           mpz_set (expr->shape[shape_i++], begin->shape[0]);
1210
1211           /* Check bounds.  */
1212           for (c = vecsub[d]; c; c = c->next)
1213             {
1214               if (mpz_cmp (c->expr->value.integer, upper->value.integer) > 0
1215                   || mpz_cmp (c->expr->value.integer,
1216                               lower->value.integer) < 0)
1217                 {
1218                   gfc_error ("index in dimension %d is out of bounds "
1219                              "at %L", d + 1, &ref->u.ar.c_where[d]);
1220                   t = FAILURE;
1221                   goto cleanup;
1222                 }
1223             }
1224         }
1225       else
1226         {
1227           if ((begin && begin->expr_type != EXPR_CONSTANT)
1228               || (finish && finish->expr_type != EXPR_CONSTANT)
1229               || (step && step->expr_type != EXPR_CONSTANT))
1230             {
1231               t = FAILURE;
1232               goto cleanup;
1233             }
1234
1235           /* Obtain the stride.  */
1236           if (step)
1237             mpz_set (stride[d], step->value.integer);
1238           else
1239             mpz_set_ui (stride[d], one);
1240
1241           if (mpz_cmp_ui (stride[d], 0) == 0)
1242             mpz_set_ui (stride[d], one);
1243
1244           /* Obtain the start value for the index.  */
1245           if (begin)
1246             mpz_set (start[d], begin->value.integer);
1247           else
1248             mpz_set (start[d], lower->value.integer);
1249
1250           mpz_set (ctr[d], start[d]);
1251
1252           /* Obtain the end value for the index.  */
1253           if (finish)
1254             mpz_set (end[d], finish->value.integer);
1255           else
1256             mpz_set (end[d], upper->value.integer);
1257
1258           /* Separate 'if' because elements sometimes arrive with
1259              non-null end.  */
1260           if (ref->u.ar.dimen_type[d] == DIMEN_ELEMENT)
1261             mpz_set (end [d], begin->value.integer);
1262
1263           /* Check the bounds.  */
1264           if (mpz_cmp (ctr[d], upper->value.integer) > 0
1265               || mpz_cmp (end[d], upper->value.integer) > 0
1266               || mpz_cmp (ctr[d], lower->value.integer) < 0
1267               || mpz_cmp (end[d], lower->value.integer) < 0)
1268             {
1269               gfc_error ("index in dimension %d is out of bounds "
1270                          "at %L", d + 1, &ref->u.ar.c_where[d]);
1271               t = FAILURE;
1272               goto cleanup;
1273             }
1274
1275           /* Calculate the number of elements and the shape.  */
1276           mpz_set (tmp_mpz, stride[d]);
1277           mpz_add (tmp_mpz, end[d], tmp_mpz);
1278           mpz_sub (tmp_mpz, tmp_mpz, ctr[d]);
1279           mpz_div (tmp_mpz, tmp_mpz, stride[d]);
1280           mpz_mul (nelts, nelts, tmp_mpz);
1281
1282           /* An element reference reduces the rank of the expression; don't
1283              add anything to the shape array.  */
1284           if (ref->u.ar.dimen_type[d] != DIMEN_ELEMENT)
1285             mpz_set (expr->shape[shape_i++], tmp_mpz);
1286         }
1287
1288       /* Calculate the 'stride' (=delta) for conversion of the
1289          counter values into the index along the constructor.  */
1290       mpz_set (delta[d], delta_mpz);
1291       mpz_sub (tmp_mpz, upper->value.integer, lower->value.integer);
1292       mpz_add_ui (tmp_mpz, tmp_mpz, one);
1293       mpz_mul (delta_mpz, delta_mpz, tmp_mpz);
1294     }
1295
1296   mpz_init (index);
1297   mpz_init (ptr);
1298   cons = base;
1299
1300   /* Now clock through the array reference, calculating the index in
1301      the source constructor and transferring the elements to the new
1302      constructor.  */
1303   for (idx = 0; idx < (int) mpz_get_si (nelts); idx++)
1304     {
1305       if (ref->u.ar.offset)
1306         mpz_set (ptr, ref->u.ar.offset->value.integer);
1307       else
1308         mpz_init_set_ui (ptr, 0);
1309
1310       incr_ctr = true;
1311       for (d = 0; d < rank; d++)
1312         {
1313           mpz_set (tmp_mpz, ctr[d]);
1314           mpz_sub (tmp_mpz, tmp_mpz, ref->u.ar.as->lower[d]->value.integer);
1315           mpz_mul (tmp_mpz, tmp_mpz, delta[d]);
1316           mpz_add (ptr, ptr, tmp_mpz);
1317
1318           if (!incr_ctr) continue;
1319
1320           if (ref->u.ar.dimen_type[d] == DIMEN_VECTOR) /* Vector subscript.  */
1321             {
1322               gcc_assert(vecsub[d]);
1323
1324               if (!vecsub[d]->next)
1325                 vecsub[d] = ref->u.ar.start[d]->value.constructor;
1326               else
1327                 {
1328                   vecsub[d] = vecsub[d]->next;
1329                   incr_ctr = false;
1330                 }
1331               mpz_set (ctr[d], vecsub[d]->expr->value.integer);
1332             }
1333           else
1334             {
1335               mpz_add (ctr[d], ctr[d], stride[d]);
1336
1337               if (mpz_cmp_ui (stride[d], 0) > 0
1338                   ? mpz_cmp (ctr[d], end[d]) > 0
1339                   : mpz_cmp (ctr[d], end[d]) < 0)
1340                 mpz_set (ctr[d], start[d]);
1341               else
1342                 incr_ctr = false;
1343             }
1344         }
1345
1346       /* There must be a better way of dealing with negative strides
1347          than resetting the index and the constructor pointer!  */
1348       if (mpz_cmp (ptr, index) < 0)
1349         {
1350           mpz_set_ui (index, 0);
1351           cons = base;
1352         }
1353
1354       while (cons && cons->next && mpz_cmp (ptr, index) > 0)
1355         {
1356           mpz_add_ui (index, index, one);
1357           cons = cons->next;
1358         }
1359
1360       gfc_append_constructor (expr, gfc_copy_expr (cons->expr));
1361     }
1362
1363   mpz_clear (ptr);
1364   mpz_clear (index);
1365
1366 cleanup:
1367
1368   mpz_clear (delta_mpz);
1369   mpz_clear (tmp_mpz);
1370   mpz_clear (nelts);
1371   for (d = 0; d < rank; d++)
1372     {
1373       mpz_clear (delta[d]);
1374       mpz_clear (start[d]);
1375       mpz_clear (end[d]);
1376       mpz_clear (ctr[d]);
1377       mpz_clear (stride[d]);
1378     }
1379   gfc_free_constructor (base);
1380   return t;
1381 }
1382
1383 /* Pull a substring out of an expression.  */
1384
1385 static gfc_try
1386 find_substring_ref (gfc_expr *p, gfc_expr **newp)
1387 {
1388   int end;
1389   int start;
1390   int length;
1391   gfc_char_t *chr;
1392
1393   if (p->ref->u.ss.start->expr_type != EXPR_CONSTANT
1394       || p->ref->u.ss.end->expr_type != EXPR_CONSTANT)
1395     return FAILURE;
1396
1397   *newp = gfc_copy_expr (p);
1398   gfc_free ((*newp)->value.character.string);
1399
1400   end = (int) mpz_get_ui (p->ref->u.ss.end->value.integer);
1401   start = (int) mpz_get_ui (p->ref->u.ss.start->value.integer);
1402   length = end - start + 1;
1403
1404   chr = (*newp)->value.character.string = gfc_get_wide_string (length + 1);
1405   (*newp)->value.character.length = length;
1406   memcpy (chr, &p->value.character.string[start - 1],
1407           length * sizeof (gfc_char_t));
1408   chr[length] = '\0';
1409   return SUCCESS;
1410 }
1411
1412
1413
1414 /* Simplify a subobject reference of a constructor.  This occurs when
1415    parameter variable values are substituted.  */
1416
1417 static gfc_try
1418 simplify_const_ref (gfc_expr *p)
1419 {
1420   gfc_constructor *cons;
1421   gfc_expr *newp;
1422
1423   while (p->ref)
1424     {
1425       switch (p->ref->type)
1426         {
1427         case REF_ARRAY:
1428           switch (p->ref->u.ar.type)
1429             {
1430             case AR_ELEMENT:
1431               if (find_array_element (p->value.constructor, &p->ref->u.ar,
1432                                       &cons) == FAILURE)
1433                 return FAILURE;
1434
1435               if (!cons)
1436                 return SUCCESS;
1437
1438               remove_subobject_ref (p, cons);
1439               break;
1440
1441             case AR_SECTION:
1442               if (find_array_section (p, p->ref) == FAILURE)
1443                 return FAILURE;
1444               p->ref->u.ar.type = AR_FULL;
1445
1446             /* Fall through.  */
1447
1448             case AR_FULL:
1449               if (p->ref->next != NULL
1450                   && (p->ts.type == BT_CHARACTER || p->ts.type == BT_DERIVED))
1451                 {
1452                   cons = p->value.constructor;
1453                   for (; cons; cons = cons->next)
1454                     {
1455                       cons->expr->ref = gfc_copy_ref (p->ref->next);
1456                       if (simplify_const_ref (cons->expr) == FAILURE)
1457                         return FAILURE;
1458                     }
1459
1460                   /* If this is a CHARACTER array and we possibly took a
1461                      substring out of it, update the type-spec's character
1462                      length according to the first element (as all should have
1463                      the same length).  */
1464                   if (p->ts.type == BT_CHARACTER)
1465                     {
1466                       int string_len;
1467
1468                       gcc_assert (p->ref->next);
1469                       gcc_assert (!p->ref->next->next);
1470                       gcc_assert (p->ref->next->type == REF_SUBSTRING);
1471
1472                       if (p->value.constructor)
1473                         {
1474                           const gfc_expr* first = p->value.constructor->expr;
1475                           gcc_assert (first->expr_type == EXPR_CONSTANT);
1476                           gcc_assert (first->ts.type == BT_CHARACTER);
1477                           string_len = first->value.character.length;
1478                         }
1479                       else
1480                         string_len = 0;
1481
1482                       if (!p->ts.cl)
1483                         {
1484                           p->ts.cl = gfc_get_charlen ();
1485                           p->ts.cl->next = NULL;
1486                           p->ts.cl->length = NULL;
1487                         }
1488                       gfc_free_expr (p->ts.cl->length);
1489                       p->ts.cl->length = gfc_int_expr (string_len);
1490                     }
1491                 }
1492               gfc_free_ref_list (p->ref);
1493               p->ref = NULL;
1494               break;
1495
1496             default:
1497               return SUCCESS;
1498             }
1499
1500           break;
1501
1502         case REF_COMPONENT:
1503           cons = find_component_ref (p->value.constructor, p->ref);
1504           remove_subobject_ref (p, cons);
1505           break;
1506
1507         case REF_SUBSTRING:
1508           if (find_substring_ref (p, &newp) == FAILURE)
1509             return FAILURE;
1510
1511           gfc_replace_expr (p, newp);
1512           gfc_free_ref_list (p->ref);
1513           p->ref = NULL;
1514           break;
1515         }
1516     }
1517
1518   return SUCCESS;
1519 }
1520
1521
1522 /* Simplify a chain of references.  */
1523
1524 static gfc_try
1525 simplify_ref_chain (gfc_ref *ref, int type)
1526 {
1527   int n;
1528
1529   for (; ref; ref = ref->next)
1530     {
1531       switch (ref->type)
1532         {
1533         case REF_ARRAY:
1534           for (n = 0; n < ref->u.ar.dimen; n++)
1535             {
1536               if (gfc_simplify_expr (ref->u.ar.start[n], type) == FAILURE)
1537                 return FAILURE;
1538               if (gfc_simplify_expr (ref->u.ar.end[n], type) == FAILURE)
1539                 return FAILURE;
1540               if (gfc_simplify_expr (ref->u.ar.stride[n], type) == FAILURE)
1541                 return FAILURE;
1542             }
1543           break;
1544
1545         case REF_SUBSTRING:
1546           if (gfc_simplify_expr (ref->u.ss.start, type) == FAILURE)
1547             return FAILURE;
1548           if (gfc_simplify_expr (ref->u.ss.end, type) == FAILURE)
1549             return FAILURE;
1550           break;
1551
1552         default:
1553           break;
1554         }
1555     }
1556   return SUCCESS;
1557 }
1558
1559
1560 /* Try to substitute the value of a parameter variable.  */
1561
1562 static gfc_try
1563 simplify_parameter_variable (gfc_expr *p, int type)
1564 {
1565   gfc_expr *e;
1566   gfc_try t;
1567
1568   e = gfc_copy_expr (p->symtree->n.sym->value);
1569   if (e == NULL)
1570     return FAILURE;
1571
1572   e->rank = p->rank;
1573
1574   /* Do not copy subobject refs for constant.  */
1575   if (e->expr_type != EXPR_CONSTANT && p->ref != NULL)
1576     e->ref = gfc_copy_ref (p->ref);
1577   t = gfc_simplify_expr (e, type);
1578
1579   /* Only use the simplification if it eliminated all subobject references.  */
1580   if (t == SUCCESS && !e->ref)
1581     gfc_replace_expr (p, e);
1582   else
1583     gfc_free_expr (e);
1584
1585   return t;
1586 }
1587
1588 /* Given an expression, simplify it by collapsing constant
1589    expressions.  Most simplification takes place when the expression
1590    tree is being constructed.  If an intrinsic function is simplified
1591    at some point, we get called again to collapse the result against
1592    other constants.
1593
1594    We work by recursively simplifying expression nodes, simplifying
1595    intrinsic functions where possible, which can lead to further
1596    constant collapsing.  If an operator has constant operand(s), we
1597    rip the expression apart, and rebuild it, hoping that it becomes
1598    something simpler.
1599
1600    The expression type is defined for:
1601      0   Basic expression parsing
1602      1   Simplifying array constructors -- will substitute
1603          iterator values.
1604    Returns FAILURE on error, SUCCESS otherwise.
1605    NOTE: Will return SUCCESS even if the expression can not be simplified.  */
1606
1607 gfc_try
1608 gfc_simplify_expr (gfc_expr *p, int type)
1609 {
1610   gfc_actual_arglist *ap;
1611
1612   if (p == NULL)
1613     return SUCCESS;
1614
1615   switch (p->expr_type)
1616     {
1617     case EXPR_CONSTANT:
1618     case EXPR_NULL:
1619       break;
1620
1621     case EXPR_FUNCTION:
1622       for (ap = p->value.function.actual; ap; ap = ap->next)
1623         if (gfc_simplify_expr (ap->expr, type) == FAILURE)
1624           return FAILURE;
1625
1626       if (p->value.function.isym != NULL
1627           && gfc_intrinsic_func_interface (p, 1) == MATCH_ERROR)
1628         return FAILURE;
1629
1630       break;
1631
1632     case EXPR_SUBSTRING:
1633       if (simplify_ref_chain (p->ref, type) == FAILURE)
1634         return FAILURE;
1635
1636       if (gfc_is_constant_expr (p))
1637         {
1638           gfc_char_t *s;
1639           int start, end;
1640
1641           if (p->ref && p->ref->u.ss.start)
1642             {
1643               gfc_extract_int (p->ref->u.ss.start, &start);
1644               start--;  /* Convert from one-based to zero-based.  */
1645             }
1646           else
1647             start = 0;
1648
1649           if (p->ref && p->ref->u.ss.end)
1650             gfc_extract_int (p->ref->u.ss.end, &end);
1651           else
1652             end = p->value.character.length;
1653
1654           s = gfc_get_wide_string (end - start + 2);
1655           memcpy (s, p->value.character.string + start,
1656                   (end - start) * sizeof (gfc_char_t));
1657           s[end - start + 1] = '\0';  /* TODO: C-style string.  */
1658           gfc_free (p->value.character.string);
1659           p->value.character.string = s;
1660           p->value.character.length = end - start;
1661           p->ts.cl = gfc_get_charlen ();
1662           p->ts.cl->next = gfc_current_ns->cl_list;
1663           gfc_current_ns->cl_list = p->ts.cl;
1664           p->ts.cl->length = gfc_int_expr (p->value.character.length);
1665           gfc_free_ref_list (p->ref);
1666           p->ref = NULL;
1667           p->expr_type = EXPR_CONSTANT;
1668         }
1669       break;
1670
1671     case EXPR_OP:
1672       if (simplify_intrinsic_op (p, type) == FAILURE)
1673         return FAILURE;
1674       break;
1675
1676     case EXPR_VARIABLE:
1677       /* Only substitute array parameter variables if we are in an
1678          initialization expression, or we want a subsection.  */
1679       if (p->symtree->n.sym->attr.flavor == FL_PARAMETER
1680           && (gfc_init_expr || p->ref
1681               || p->symtree->n.sym->value->expr_type != EXPR_ARRAY))
1682         {
1683           if (simplify_parameter_variable (p, type) == FAILURE)
1684             return FAILURE;
1685           break;
1686         }
1687
1688       if (type == 1)
1689         {
1690           gfc_simplify_iterator_var (p);
1691         }
1692
1693       /* Simplify subcomponent references.  */
1694       if (simplify_ref_chain (p->ref, type) == FAILURE)
1695         return FAILURE;
1696
1697       break;
1698
1699     case EXPR_STRUCTURE:
1700     case EXPR_ARRAY:
1701       if (simplify_ref_chain (p->ref, type) == FAILURE)
1702         return FAILURE;
1703
1704       if (simplify_constructor (p->value.constructor, type) == FAILURE)
1705         return FAILURE;
1706
1707       if (p->expr_type == EXPR_ARRAY && p->ref && p->ref->type == REF_ARRAY
1708           && p->ref->u.ar.type == AR_FULL)
1709           gfc_expand_constructor (p);
1710
1711       if (simplify_const_ref (p) == FAILURE)
1712         return FAILURE;
1713
1714       break;
1715
1716     case EXPR_COMPCALL:
1717       gcc_unreachable ();
1718       break;
1719     }
1720
1721   return SUCCESS;
1722 }
1723
1724
1725 /* Returns the type of an expression with the exception that iterator
1726    variables are automatically integers no matter what else they may
1727    be declared as.  */
1728
1729 static bt
1730 et0 (gfc_expr *e)
1731 {
1732   if (e->expr_type == EXPR_VARIABLE && gfc_check_iter_variable (e) == SUCCESS)
1733     return BT_INTEGER;
1734
1735   return e->ts.type;
1736 }
1737
1738
1739 /* Check an intrinsic arithmetic operation to see if it is consistent
1740    with some type of expression.  */
1741
1742 static gfc_try check_init_expr (gfc_expr *);
1743
1744
1745 /* Scalarize an expression for an elemental intrinsic call.  */
1746
1747 static gfc_try
1748 scalarize_intrinsic_call (gfc_expr *e)
1749 {
1750   gfc_actual_arglist *a, *b;
1751   gfc_constructor *args[5], *ctor, *new_ctor;
1752   gfc_expr *expr, *old;
1753   int n, i, rank[5], array_arg;
1754
1755   /* Find which, if any, arguments are arrays.  Assume that the old
1756      expression carries the type information and that the first arg
1757      that is an array expression carries all the shape information.*/
1758   n = array_arg = 0;
1759   a = e->value.function.actual;
1760   for (; a; a = a->next)
1761     {
1762       n++;
1763       if (a->expr->expr_type != EXPR_ARRAY)
1764         continue;
1765       array_arg = n;
1766       expr = gfc_copy_expr (a->expr);
1767       break;
1768     }
1769
1770   if (!array_arg)
1771     return FAILURE;
1772
1773   old = gfc_copy_expr (e);
1774
1775   gfc_free_constructor (expr->value.constructor);
1776   expr->value.constructor = NULL;
1777
1778   expr->ts = old->ts;
1779   expr->where = old->where;
1780   expr->expr_type = EXPR_ARRAY;
1781
1782   /* Copy the array argument constructors into an array, with nulls
1783      for the scalars.  */
1784   n = 0;
1785   a = old->value.function.actual;
1786   for (; a; a = a->next)
1787     {
1788       /* Check that this is OK for an initialization expression.  */
1789       if (a->expr && check_init_expr (a->expr) == FAILURE)
1790         goto cleanup;
1791
1792       rank[n] = 0;
1793       if (a->expr && a->expr->rank && a->expr->expr_type == EXPR_VARIABLE)
1794         {
1795           rank[n] = a->expr->rank;
1796           ctor = a->expr->symtree->n.sym->value->value.constructor;
1797           args[n] = gfc_copy_constructor (ctor);
1798         }
1799       else if (a->expr && a->expr->expr_type == EXPR_ARRAY)
1800         {
1801           if (a->expr->rank)
1802             rank[n] = a->expr->rank;
1803           else
1804             rank[n] = 1;
1805           args[n] = gfc_copy_constructor (a->expr->value.constructor);
1806         }
1807       else
1808         args[n] = NULL;
1809       n++;
1810     }
1811
1812
1813   /* Using the array argument as the master, step through the array
1814      calling the function for each element and advancing the array
1815      constructors together.  */
1816   ctor = args[array_arg - 1];
1817   new_ctor = NULL;
1818   for (; ctor; ctor = ctor->next)
1819     {
1820           if (expr->value.constructor == NULL)
1821             expr->value.constructor
1822                 = new_ctor = gfc_get_constructor ();
1823           else
1824             {
1825               new_ctor->next = gfc_get_constructor ();
1826               new_ctor = new_ctor->next;
1827             }
1828           new_ctor->expr = gfc_copy_expr (old);
1829           gfc_free_actual_arglist (new_ctor->expr->value.function.actual);
1830           a = NULL;
1831           b = old->value.function.actual;
1832           for (i = 0; i < n; i++)
1833             {
1834               if (a == NULL)
1835                 new_ctor->expr->value.function.actual
1836                         = a = gfc_get_actual_arglist ();
1837               else
1838                 {
1839                   a->next = gfc_get_actual_arglist ();
1840                   a = a->next;
1841                 }
1842               if (args[i])
1843                 a->expr = gfc_copy_expr (args[i]->expr);
1844               else
1845                 a->expr = gfc_copy_expr (b->expr);
1846
1847               b = b->next;
1848             }
1849
1850           /* Simplify the function calls.  If the simplification fails, the
1851              error will be flagged up down-stream or the library will deal
1852              with it.  */
1853           gfc_simplify_expr (new_ctor->expr, 0);
1854
1855           for (i = 0; i < n; i++)
1856             if (args[i])
1857               args[i] = args[i]->next;
1858
1859           for (i = 1; i < n; i++)
1860             if (rank[i] && ((args[i] != NULL && args[array_arg - 1] == NULL)
1861                          || (args[i] == NULL && args[array_arg - 1] != NULL)))
1862               goto compliance;
1863     }
1864
1865   free_expr0 (e);
1866   *e = *expr;
1867   gfc_free_expr (old);
1868   return SUCCESS;
1869
1870 compliance:
1871   gfc_error_now ("elemental function arguments at %C are not compliant");
1872
1873 cleanup:
1874   gfc_free_expr (expr);
1875   gfc_free_expr (old);
1876   return FAILURE;
1877 }
1878
1879
1880 static gfc_try
1881 check_intrinsic_op (gfc_expr *e, gfc_try (*check_function) (gfc_expr *))
1882 {
1883   gfc_expr *op1 = e->value.op.op1;
1884   gfc_expr *op2 = e->value.op.op2;
1885
1886   if ((*check_function) (op1) == FAILURE)
1887     return FAILURE;
1888
1889   switch (e->value.op.op)
1890     {
1891     case INTRINSIC_UPLUS:
1892     case INTRINSIC_UMINUS:
1893       if (!numeric_type (et0 (op1)))
1894         goto not_numeric;
1895       break;
1896
1897     case INTRINSIC_EQ:
1898     case INTRINSIC_EQ_OS:
1899     case INTRINSIC_NE:
1900     case INTRINSIC_NE_OS:
1901     case INTRINSIC_GT:
1902     case INTRINSIC_GT_OS:
1903     case INTRINSIC_GE:
1904     case INTRINSIC_GE_OS:
1905     case INTRINSIC_LT:
1906     case INTRINSIC_LT_OS:
1907     case INTRINSIC_LE:
1908     case INTRINSIC_LE_OS:
1909       if ((*check_function) (op2) == FAILURE)
1910         return FAILURE;
1911
1912       if (!(et0 (op1) == BT_CHARACTER && et0 (op2) == BT_CHARACTER)
1913           && !(numeric_type (et0 (op1)) && numeric_type (et0 (op2))))
1914         {
1915           gfc_error ("Numeric or CHARACTER operands are required in "
1916                      "expression at %L", &e->where);
1917          return FAILURE;
1918         }
1919       break;
1920
1921     case INTRINSIC_PLUS:
1922     case INTRINSIC_MINUS:
1923     case INTRINSIC_TIMES:
1924     case INTRINSIC_DIVIDE:
1925     case INTRINSIC_POWER:
1926       if ((*check_function) (op2) == FAILURE)
1927         return FAILURE;
1928
1929       if (!numeric_type (et0 (op1)) || !numeric_type (et0 (op2)))
1930         goto not_numeric;
1931
1932       if (e->value.op.op == INTRINSIC_POWER
1933           && check_function == check_init_expr && et0 (op2) != BT_INTEGER)
1934         {
1935           if (gfc_notify_std (GFC_STD_F2003,"Fortran 2003: Noninteger "
1936                               "exponent in an initialization "
1937                               "expression at %L", &op2->where)
1938               == FAILURE)
1939             return FAILURE;
1940         }
1941
1942       break;
1943
1944     case INTRINSIC_CONCAT:
1945       if ((*check_function) (op2) == FAILURE)
1946         return FAILURE;
1947
1948       if (et0 (op1) != BT_CHARACTER || et0 (op2) != BT_CHARACTER)
1949         {
1950           gfc_error ("Concatenation operator in expression at %L "
1951                      "must have two CHARACTER operands", &op1->where);
1952           return FAILURE;
1953         }
1954
1955       if (op1->ts.kind != op2->ts.kind)
1956         {
1957           gfc_error ("Concat operator at %L must concatenate strings of the "
1958                      "same kind", &e->where);
1959           return FAILURE;
1960         }
1961
1962       break;
1963
1964     case INTRINSIC_NOT:
1965       if (et0 (op1) != BT_LOGICAL)
1966         {
1967           gfc_error (".NOT. operator in expression at %L must have a LOGICAL "
1968                      "operand", &op1->where);
1969           return FAILURE;
1970         }
1971
1972       break;
1973
1974     case INTRINSIC_AND:
1975     case INTRINSIC_OR:
1976     case INTRINSIC_EQV:
1977     case INTRINSIC_NEQV:
1978       if ((*check_function) (op2) == FAILURE)
1979         return FAILURE;
1980
1981       if (et0 (op1) != BT_LOGICAL || et0 (op2) != BT_LOGICAL)
1982         {
1983           gfc_error ("LOGICAL operands are required in expression at %L",
1984                      &e->where);
1985           return FAILURE;
1986         }
1987
1988       break;
1989
1990     case INTRINSIC_PARENTHESES:
1991       break;
1992
1993     default:
1994       gfc_error ("Only intrinsic operators can be used in expression at %L",
1995                  &e->where);
1996       return FAILURE;
1997     }
1998
1999   return SUCCESS;
2000
2001 not_numeric:
2002   gfc_error ("Numeric operands are required in expression at %L", &e->where);
2003
2004   return FAILURE;
2005 }
2006
2007
2008 static match
2009 check_init_expr_arguments (gfc_expr *e)
2010 {
2011   gfc_actual_arglist *ap;
2012
2013   for (ap = e->value.function.actual; ap; ap = ap->next)
2014     if (check_init_expr (ap->expr) == FAILURE)
2015       return MATCH_ERROR;
2016
2017   return MATCH_YES;
2018 }
2019
2020 static gfc_try check_restricted (gfc_expr *);
2021
2022 /* F95, 7.1.6.1, Initialization expressions, (7)
2023    F2003, 7.1.7 Initialization expression, (8)  */
2024
2025 static match
2026 check_inquiry (gfc_expr *e, int not_restricted)
2027 {
2028   const char *name;
2029   const char *const *functions;
2030
2031   static const char *const inquiry_func_f95[] = {
2032     "lbound", "shape", "size", "ubound",
2033     "bit_size", "len", "kind",
2034     "digits", "epsilon", "huge", "maxexponent", "minexponent",
2035     "precision", "radix", "range", "tiny",
2036     NULL
2037   };
2038
2039   static const char *const inquiry_func_f2003[] = {
2040     "lbound", "shape", "size", "ubound",
2041     "bit_size", "len", "kind",
2042     "digits", "epsilon", "huge", "maxexponent", "minexponent",
2043     "precision", "radix", "range", "tiny",
2044     "new_line", NULL
2045   };
2046
2047   int i;
2048   gfc_actual_arglist *ap;
2049
2050   if (!e->value.function.isym
2051       || !e->value.function.isym->inquiry)
2052     return MATCH_NO;
2053
2054   /* An undeclared parameter will get us here (PR25018).  */
2055   if (e->symtree == NULL)
2056     return MATCH_NO;
2057
2058   name = e->symtree->n.sym->name;
2059
2060   functions = (gfc_option.warn_std & GFC_STD_F2003)
2061                 ? inquiry_func_f2003 : inquiry_func_f95;
2062
2063   for (i = 0; functions[i]; i++)
2064     if (strcmp (functions[i], name) == 0)
2065       break;
2066
2067   if (functions[i] == NULL)
2068     return MATCH_ERROR;
2069
2070   /* At this point we have an inquiry function with a variable argument.  The
2071      type of the variable might be undefined, but we need it now, because the
2072      arguments of these functions are not allowed to be undefined.  */
2073
2074   for (ap = e->value.function.actual; ap; ap = ap->next)
2075     {
2076       if (!ap->expr)
2077         continue;
2078
2079       if (ap->expr->ts.type == BT_UNKNOWN)
2080         {
2081           if (ap->expr->symtree->n.sym->ts.type == BT_UNKNOWN
2082               && gfc_set_default_type (ap->expr->symtree->n.sym, 0, gfc_current_ns)
2083               == FAILURE)
2084             return MATCH_NO;
2085
2086           ap->expr->ts = ap->expr->symtree->n.sym->ts;
2087         }
2088
2089         /* Assumed character length will not reduce to a constant expression
2090            with LEN, as required by the standard.  */
2091         if (i == 5 && not_restricted
2092             && ap->expr->symtree->n.sym->ts.type == BT_CHARACTER
2093             && ap->expr->symtree->n.sym->ts.cl->length == NULL)
2094           {
2095             gfc_error ("Assumed character length variable '%s' in constant "
2096                        "expression at %L", e->symtree->n.sym->name, &e->where);
2097               return MATCH_ERROR;
2098           }
2099         else if (not_restricted && check_init_expr (ap->expr) == FAILURE)
2100           return MATCH_ERROR;
2101
2102         if (not_restricted == 0
2103               && ap->expr->expr_type != EXPR_VARIABLE
2104               && check_restricted (ap->expr) == FAILURE)
2105           return MATCH_ERROR;
2106     }
2107
2108   return MATCH_YES;
2109 }
2110
2111
2112 /* F95, 7.1.6.1, Initialization expressions, (5)
2113    F2003, 7.1.7 Initialization expression, (5)  */
2114
2115 static match
2116 check_transformational (gfc_expr *e)
2117 {
2118   static const char * const trans_func_f95[] = {
2119     "repeat", "reshape", "selected_int_kind",
2120     "selected_real_kind", "transfer", "trim", NULL
2121   };
2122
2123   int i;
2124   const char *name;
2125
2126   if (!e->value.function.isym
2127       || !e->value.function.isym->transformational)
2128     return MATCH_NO;
2129
2130   name = e->symtree->n.sym->name;
2131
2132   /* NULL() is dealt with below.  */
2133   if (strcmp ("null", name) == 0)
2134     return MATCH_NO;
2135
2136   for (i = 0; trans_func_f95[i]; i++)
2137     if (strcmp (trans_func_f95[i], name) == 0)
2138       break;
2139
2140   /* FIXME, F2003: implement translation of initialization
2141      expressions before enabling this check. For F95, error
2142      out if the transformational function is not in the list.  */
2143 #if 0
2144   if (trans_func_f95[i] == NULL
2145       && gfc_notify_std (GFC_STD_F2003,
2146                          "transformational intrinsic '%s' at %L is not permitted "
2147                          "in an initialization expression", name, &e->where) == FAILURE)
2148     return MATCH_ERROR;
2149 #else
2150   if (trans_func_f95[i] == NULL)
2151     {
2152       gfc_error("transformational intrinsic '%s' at %L is not permitted "
2153                 "in an initialization expression", name, &e->where);
2154       return MATCH_ERROR;
2155     }
2156 #endif
2157
2158   return check_init_expr_arguments (e);
2159 }
2160
2161
2162 /* F95, 7.1.6.1, Initialization expressions, (6)
2163    F2003, 7.1.7 Initialization expression, (6)  */
2164
2165 static match
2166 check_null (gfc_expr *e)
2167 {
2168   if (strcmp ("null", e->symtree->n.sym->name) != 0)
2169     return MATCH_NO;
2170
2171   return check_init_expr_arguments (e);
2172 }
2173
2174
2175 static match
2176 check_elemental (gfc_expr *e)
2177 {
2178   if (!e->value.function.isym
2179       || !e->value.function.isym->elemental)
2180     return MATCH_NO;
2181
2182   if (e->ts.type != BT_INTEGER
2183       && e->ts.type != BT_CHARACTER
2184       && gfc_notify_std (GFC_STD_F2003, "Extension: Evaluation of "
2185                         "nonstandard initialization expression at %L",
2186                         &e->where) == FAILURE)
2187     return MATCH_ERROR;
2188
2189   return check_init_expr_arguments (e);
2190 }
2191
2192
2193 static match
2194 check_conversion (gfc_expr *e)
2195 {
2196   if (!e->value.function.isym
2197       || !e->value.function.isym->conversion)
2198     return MATCH_NO;
2199
2200   return check_init_expr_arguments (e);
2201 }
2202
2203
2204 /* Verify that an expression is an initialization expression.  A side
2205    effect is that the expression tree is reduced to a single constant
2206    node if all goes well.  This would normally happen when the
2207    expression is constructed but function references are assumed to be
2208    intrinsics in the context of initialization expressions.  If
2209    FAILURE is returned an error message has been generated.  */
2210
2211 static gfc_try
2212 check_init_expr (gfc_expr *e)
2213 {
2214   match m;
2215   gfc_try t;
2216
2217   if (e == NULL)
2218     return SUCCESS;
2219
2220   switch (e->expr_type)
2221     {
2222     case EXPR_OP:
2223       t = check_intrinsic_op (e, check_init_expr);
2224       if (t == SUCCESS)
2225         t = gfc_simplify_expr (e, 0);
2226
2227       break;
2228
2229     case EXPR_FUNCTION:
2230       t = FAILURE;
2231
2232       if ((m = check_specification_function (e)) != MATCH_YES)
2233         {
2234           gfc_intrinsic_sym* isym;
2235           gfc_symbol* sym;
2236
2237           sym = e->symtree->n.sym;
2238           if (!gfc_is_intrinsic (sym, 0, e->where)
2239               || (m = gfc_intrinsic_func_interface (e, 0)) != MATCH_YES)
2240             {
2241               gfc_error ("Function '%s' in initialization expression at %L "
2242                          "must be an intrinsic or a specification function",
2243                          e->symtree->n.sym->name, &e->where);
2244               break;
2245             }
2246
2247           if ((m = check_conversion (e)) == MATCH_NO
2248               && (m = check_inquiry (e, 1)) == MATCH_NO
2249               && (m = check_null (e)) == MATCH_NO
2250               && (m = check_transformational (e)) == MATCH_NO
2251               && (m = check_elemental (e)) == MATCH_NO)
2252             {
2253               gfc_error ("Intrinsic function '%s' at %L is not permitted "
2254                          "in an initialization expression",
2255                          e->symtree->n.sym->name, &e->where);
2256               m = MATCH_ERROR;
2257             }
2258
2259           /* Try to scalarize an elemental intrinsic function that has an
2260              array argument.  */
2261           isym = gfc_find_function (e->symtree->n.sym->name);
2262           if (isym && isym->elemental
2263                 && (t = scalarize_intrinsic_call (e)) == SUCCESS)
2264             break;
2265         }
2266
2267       if (m == MATCH_YES)
2268         t = gfc_simplify_expr (e, 0);
2269
2270       break;
2271
2272     case EXPR_VARIABLE:
2273       t = SUCCESS;
2274
2275       if (gfc_check_iter_variable (e) == SUCCESS)
2276         break;
2277
2278       if (e->symtree->n.sym->attr.flavor == FL_PARAMETER)
2279         {
2280           /* A PARAMETER shall not be used to define itself, i.e.
2281                 REAL, PARAMETER :: x = transfer(0, x)
2282              is invalid.  */
2283           if (!e->symtree->n.sym->value)
2284             {
2285               gfc_error("PARAMETER '%s' is used at %L before its definition "
2286                         "is complete", e->symtree->n.sym->name, &e->where);
2287               t = FAILURE;
2288             }
2289           else
2290             t = simplify_parameter_variable (e, 0);
2291
2292           break;
2293         }
2294
2295       if (gfc_in_match_data ())
2296         break;
2297
2298       t = FAILURE;
2299
2300       if (e->symtree->n.sym->as)
2301         {
2302           switch (e->symtree->n.sym->as->type)
2303             {
2304               case AS_ASSUMED_SIZE:
2305                 gfc_error ("Assumed size array '%s' at %L is not permitted "
2306                            "in an initialization expression",
2307                            e->symtree->n.sym->name, &e->where);
2308                 break;
2309
2310               case AS_ASSUMED_SHAPE:
2311                 gfc_error ("Assumed shape array '%s' at %L is not permitted "
2312                            "in an initialization expression",
2313                            e->symtree->n.sym->name, &e->where);
2314                 break;
2315
2316               case AS_DEFERRED:
2317                 gfc_error ("Deferred array '%s' at %L is not permitted "
2318                            "in an initialization expression",
2319                            e->symtree->n.sym->name, &e->where);
2320                 break;
2321
2322               case AS_EXPLICIT:
2323                 gfc_error ("Array '%s' at %L is a variable, which does "
2324                            "not reduce to a constant expression",
2325                            e->symtree->n.sym->name, &e->where);
2326                 break;
2327
2328               default:
2329                 gcc_unreachable();
2330           }
2331         }
2332       else
2333         gfc_error ("Parameter '%s' at %L has not been declared or is "
2334                    "a variable, which does not reduce to a constant "
2335                    "expression", e->symtree->n.sym->name, &e->where);
2336
2337       break;
2338
2339     case EXPR_CONSTANT:
2340     case EXPR_NULL:
2341       t = SUCCESS;
2342       break;
2343
2344     case EXPR_SUBSTRING:
2345       t = check_init_expr (e->ref->u.ss.start);
2346       if (t == FAILURE)
2347         break;
2348
2349       t = check_init_expr (e->ref->u.ss.end);
2350       if (t == SUCCESS)
2351         t = gfc_simplify_expr (e, 0);
2352
2353       break;
2354
2355     case EXPR_STRUCTURE:
2356       if (e->ts.is_iso_c)
2357         t = SUCCESS;
2358       else
2359         t = gfc_check_constructor (e, check_init_expr);
2360       break;
2361
2362     case EXPR_ARRAY:
2363       t = gfc_check_constructor (e, check_init_expr);
2364       if (t == FAILURE)
2365         break;
2366
2367       t = gfc_expand_constructor (e);
2368       if (t == FAILURE)
2369         break;
2370
2371       t = gfc_check_constructor_type (e);
2372       break;
2373
2374     default:
2375       gfc_internal_error ("check_init_expr(): Unknown expression type");
2376     }
2377
2378   return t;
2379 }
2380
2381
2382 /* Match an initialization expression.  We work by first matching an
2383    expression, then reducing it to a constant.  */
2384
2385 match
2386 gfc_match_init_expr (gfc_expr **result)
2387 {
2388   gfc_expr *expr;
2389   match m;
2390   gfc_try t;
2391
2392   m = gfc_match_expr (&expr);
2393   if (m != MATCH_YES)
2394     return m;
2395
2396   gfc_init_expr = 1;
2397   t = gfc_resolve_expr (expr);
2398   if (t == SUCCESS)
2399     t = check_init_expr (expr);
2400   gfc_init_expr = 0;
2401
2402   if (t == FAILURE)
2403     {
2404       gfc_free_expr (expr);
2405       return MATCH_ERROR;
2406     }
2407
2408   if (expr->expr_type == EXPR_ARRAY
2409       && (gfc_check_constructor_type (expr) == FAILURE
2410           || gfc_expand_constructor (expr) == FAILURE))
2411     {
2412       gfc_free_expr (expr);
2413       return MATCH_ERROR;
2414     }
2415
2416   /* Not all inquiry functions are simplified to constant expressions
2417      so it is necessary to call check_inquiry again.  */
2418   if (!gfc_is_constant_expr (expr) && check_inquiry (expr, 1) != MATCH_YES
2419       && !gfc_in_match_data ())
2420     {
2421       gfc_error ("Initialization expression didn't reduce %C");
2422       return MATCH_ERROR;
2423     }
2424
2425   *result = expr;
2426
2427   return MATCH_YES;
2428 }
2429
2430
2431 /* Given an actual argument list, test to see that each argument is a
2432    restricted expression and optionally if the expression type is
2433    integer or character.  */
2434
2435 static gfc_try
2436 restricted_args (gfc_actual_arglist *a)
2437 {
2438   for (; a; a = a->next)
2439     {
2440       if (check_restricted (a->expr) == FAILURE)
2441         return FAILURE;
2442     }
2443
2444   return SUCCESS;
2445 }
2446
2447
2448 /************* Restricted/specification expressions *************/
2449
2450
2451 /* Make sure a non-intrinsic function is a specification function.  */
2452
2453 static gfc_try
2454 external_spec_function (gfc_expr *e)
2455 {
2456   gfc_symbol *f;
2457
2458   f = e->value.function.esym;
2459
2460   if (f->attr.proc == PROC_ST_FUNCTION)
2461     {
2462       gfc_error ("Specification function '%s' at %L cannot be a statement "
2463                  "function", f->name, &e->where);
2464       return FAILURE;
2465     }
2466
2467   if (f->attr.proc == PROC_INTERNAL)
2468     {
2469       gfc_error ("Specification function '%s' at %L cannot be an internal "
2470                  "function", f->name, &e->where);
2471       return FAILURE;
2472     }
2473
2474   if (!f->attr.pure && !f->attr.elemental)
2475     {
2476       gfc_error ("Specification function '%s' at %L must be PURE", f->name,
2477                  &e->where);
2478       return FAILURE;
2479     }
2480
2481   if (f->attr.recursive)
2482     {
2483       gfc_error ("Specification function '%s' at %L cannot be RECURSIVE",
2484                  f->name, &e->where);
2485       return FAILURE;
2486     }
2487
2488   return restricted_args (e->value.function.actual);
2489 }
2490
2491
2492 /* Check to see that a function reference to an intrinsic is a
2493    restricted expression.  */
2494
2495 static gfc_try
2496 restricted_intrinsic (gfc_expr *e)
2497 {
2498   /* TODO: Check constraints on inquiry functions.  7.1.6.2 (7).  */
2499   if (check_inquiry (e, 0) == MATCH_YES)
2500     return SUCCESS;
2501
2502   return restricted_args (e->value.function.actual);
2503 }
2504
2505
2506 /* Check the expressions of an actual arglist.  Used by check_restricted.  */
2507
2508 static gfc_try
2509 check_arglist (gfc_actual_arglist* arg, gfc_try (*checker) (gfc_expr*))
2510 {
2511   for (; arg; arg = arg->next)
2512     if (checker (arg->expr) == FAILURE)
2513       return FAILURE;
2514
2515   return SUCCESS;
2516 }
2517
2518
2519 /* Check the subscription expressions of a reference chain with a checking
2520    function; used by check_restricted.  */
2521
2522 static gfc_try
2523 check_references (gfc_ref* ref, gfc_try (*checker) (gfc_expr*))
2524 {
2525   int dim;
2526
2527   if (!ref)
2528     return SUCCESS;
2529
2530   switch (ref->type)
2531     {
2532     case REF_ARRAY:
2533       for (dim = 0; dim != ref->u.ar.dimen; ++dim)
2534         {
2535           if (checker (ref->u.ar.start[dim]) == FAILURE)
2536             return FAILURE;
2537           if (checker (ref->u.ar.end[dim]) == FAILURE)
2538             return FAILURE;
2539           if (checker (ref->u.ar.stride[dim]) == FAILURE)
2540             return FAILURE;
2541         }
2542       break;
2543
2544     case REF_COMPONENT:
2545       /* Nothing needed, just proceed to next reference.  */
2546       break;
2547
2548     case REF_SUBSTRING:
2549       if (checker (ref->u.ss.start) == FAILURE)
2550         return FAILURE;
2551       if (checker (ref->u.ss.end) == FAILURE)
2552         return FAILURE;
2553       break;
2554
2555     default:
2556       gcc_unreachable ();
2557       break;
2558     }
2559
2560   return check_references (ref->next, checker);
2561 }
2562
2563
2564 /* Verify that an expression is a restricted expression.  Like its
2565    cousin check_init_expr(), an error message is generated if we
2566    return FAILURE.  */
2567
2568 static gfc_try
2569 check_restricted (gfc_expr *e)
2570 {
2571   gfc_symbol* sym;
2572   gfc_try t;
2573
2574   if (e == NULL)
2575     return SUCCESS;
2576
2577   switch (e->expr_type)
2578     {
2579     case EXPR_OP:
2580       t = check_intrinsic_op (e, check_restricted);
2581       if (t == SUCCESS)
2582         t = gfc_simplify_expr (e, 0);
2583
2584       break;
2585
2586     case EXPR_FUNCTION:
2587       if (e->value.function.esym)
2588         {
2589           t = check_arglist (e->value.function.actual, &check_restricted);
2590           if (t == SUCCESS)
2591             t = external_spec_function (e);
2592         }
2593       else
2594         {
2595           if (e->value.function.isym && e->value.function.isym->inquiry)
2596             t = SUCCESS;
2597           else
2598             t = check_arglist (e->value.function.actual, &check_restricted);
2599
2600           if (t == SUCCESS)
2601             t = restricted_intrinsic (e);
2602         }
2603       break;
2604
2605     case EXPR_VARIABLE:
2606       sym = e->symtree->n.sym;
2607       t = FAILURE;
2608
2609       /* If a dummy argument appears in a context that is valid for a
2610          restricted expression in an elemental procedure, it will have
2611          already been simplified away once we get here.  Therefore we
2612          don't need to jump through hoops to distinguish valid from
2613          invalid cases.  */
2614       if (sym->attr.dummy && sym->ns == gfc_current_ns
2615           && sym->ns->proc_name && sym->ns->proc_name->attr.elemental)
2616         {
2617           gfc_error ("Dummy argument '%s' not allowed in expression at %L",
2618                      sym->name, &e->where);
2619           break;
2620         }
2621
2622       if (sym->attr.optional)
2623         {
2624           gfc_error ("Dummy argument '%s' at %L cannot be OPTIONAL",
2625                      sym->name, &e->where);
2626           break;
2627         }
2628
2629       if (sym->attr.intent == INTENT_OUT)
2630         {
2631           gfc_error ("Dummy argument '%s' at %L cannot be INTENT(OUT)",
2632                      sym->name, &e->where);
2633           break;
2634         }
2635
2636       /* Check reference chain if any.  */
2637       if (check_references (e->ref, &check_restricted) == FAILURE)
2638         break;
2639
2640       /* gfc_is_formal_arg broadcasts that a formal argument list is being
2641          processed in resolve.c(resolve_formal_arglist).  This is done so
2642          that host associated dummy array indices are accepted (PR23446).
2643          This mechanism also does the same for the specification expressions
2644          of array-valued functions.  */
2645       if (e->error
2646             || sym->attr.in_common
2647             || sym->attr.use_assoc
2648             || sym->attr.dummy
2649             || sym->attr.implied_index
2650             || sym->attr.flavor == FL_PARAMETER
2651             || (sym->ns && sym->ns == gfc_current_ns->parent)
2652             || (sym->ns && gfc_current_ns->parent
2653                   && sym->ns == gfc_current_ns->parent->parent)
2654             || (sym->ns->proc_name != NULL
2655                   && sym->ns->proc_name->attr.flavor == FL_MODULE)
2656             || (gfc_is_formal_arg () && (sym->ns == gfc_current_ns)))
2657         {
2658           t = SUCCESS;
2659           break;
2660         }
2661
2662       gfc_error ("Variable '%s' cannot appear in the expression at %L",
2663                  sym->name, &e->where);
2664       /* Prevent a repetition of the error.  */
2665       e->error = 1;
2666       break;
2667
2668     case EXPR_NULL:
2669     case EXPR_CONSTANT:
2670       t = SUCCESS;
2671       break;
2672
2673     case EXPR_SUBSTRING:
2674       t = gfc_specification_expr (e->ref->u.ss.start);
2675       if (t == FAILURE)
2676         break;
2677
2678       t = gfc_specification_expr (e->ref->u.ss.end);
2679       if (t == SUCCESS)
2680         t = gfc_simplify_expr (e, 0);
2681
2682       break;
2683
2684     case EXPR_STRUCTURE:
2685       t = gfc_check_constructor (e, check_restricted);
2686       break;
2687
2688     case EXPR_ARRAY:
2689       t = gfc_check_constructor (e, check_restricted);
2690       break;
2691
2692     default:
2693       gfc_internal_error ("check_restricted(): Unknown expression type");
2694     }
2695
2696   return t;
2697 }
2698
2699
2700 /* Check to see that an expression is a specification expression.  If
2701    we return FAILURE, an error has been generated.  */
2702
2703 gfc_try
2704 gfc_specification_expr (gfc_expr *e)
2705 {
2706
2707   if (e == NULL)
2708     return SUCCESS;
2709
2710   if (e->ts.type != BT_INTEGER)
2711     {
2712       gfc_error ("Expression at %L must be of INTEGER type, found %s",
2713                  &e->where, gfc_basic_typename (e->ts.type));
2714       return FAILURE;
2715     }
2716
2717   if (e->expr_type == EXPR_FUNCTION
2718           && !e->value.function.isym
2719           && !e->value.function.esym
2720           && !gfc_pure (e->symtree->n.sym))
2721     {
2722       gfc_error ("Function '%s' at %L must be PURE",
2723                  e->symtree->n.sym->name, &e->where);
2724       /* Prevent repeat error messages.  */
2725       e->symtree->n.sym->attr.pure = 1;
2726       return FAILURE;
2727     }
2728
2729   if (e->rank != 0)
2730     {
2731       gfc_error ("Expression at %L must be scalar", &e->where);
2732       return FAILURE;
2733     }
2734
2735   if (gfc_simplify_expr (e, 0) == FAILURE)
2736     return FAILURE;
2737
2738   return check_restricted (e);
2739 }
2740
2741
2742 /************** Expression conformance checks.  *************/
2743
2744 /* Given two expressions, make sure that the arrays are conformable.  */
2745
2746 gfc_try
2747 gfc_check_conformance (const char *optype_msgid, gfc_expr *op1, gfc_expr *op2)
2748 {
2749   int op1_flag, op2_flag, d;
2750   mpz_t op1_size, op2_size;
2751   gfc_try t;
2752
2753   if (op1->rank == 0 || op2->rank == 0)
2754     return SUCCESS;
2755
2756   if (op1->rank != op2->rank)
2757     {
2758       gfc_error ("Incompatible ranks in %s (%d and %d) at %L", _(optype_msgid),
2759                  op1->rank, op2->rank, &op1->where);
2760       return FAILURE;
2761     }
2762
2763   t = SUCCESS;
2764
2765   for (d = 0; d < op1->rank; d++)
2766     {
2767       op1_flag = gfc_array_dimen_size (op1, d, &op1_size) == SUCCESS;
2768       op2_flag = gfc_array_dimen_size (op2, d, &op2_size) == SUCCESS;
2769
2770       if (op1_flag && op2_flag && mpz_cmp (op1_size, op2_size) != 0)
2771         {
2772           gfc_error ("Different shape for %s at %L on dimension %d "
2773                      "(%d and %d)", _(optype_msgid), &op1->where, d + 1,
2774                      (int) mpz_get_si (op1_size),
2775                      (int) mpz_get_si (op2_size));
2776
2777           t = FAILURE;
2778         }
2779
2780       if (op1_flag)
2781         mpz_clear (op1_size);
2782       if (op2_flag)
2783         mpz_clear (op2_size);
2784
2785       if (t == FAILURE)
2786         return FAILURE;
2787     }
2788
2789   return SUCCESS;
2790 }
2791
2792
2793 /* Given an assignable expression and an arbitrary expression, make
2794    sure that the assignment can take place.  */
2795
2796 gfc_try
2797 gfc_check_assign (gfc_expr *lvalue, gfc_expr *rvalue, int conform)
2798 {
2799   gfc_symbol *sym;
2800   gfc_ref *ref;
2801   int has_pointer;
2802
2803   sym = lvalue->symtree->n.sym;
2804
2805   /* Check INTENT(IN), unless the object itself is the component or
2806      sub-component of a pointer.  */
2807   has_pointer = sym->attr.pointer;
2808
2809   for (ref = lvalue->ref; ref; ref = ref->next)
2810     if (ref->type == REF_COMPONENT && ref->u.c.component->attr.pointer)
2811       {
2812         has_pointer = 1;
2813         break;
2814       }
2815
2816   if (!has_pointer && sym->attr.intent == INTENT_IN)
2817     {
2818       gfc_error ("Cannot assign to INTENT(IN) variable '%s' at %L",
2819                  sym->name, &lvalue->where);
2820       return FAILURE;
2821     }
2822
2823   /* 12.5.2.2, Note 12.26: The result variable is very similar to any other
2824      variable local to a function subprogram.  Its existence begins when
2825      execution of the function is initiated and ends when execution of the
2826      function is terminated...
2827      Therefore, the left hand side is no longer a variable, when it is:  */
2828   if (sym->attr.flavor == FL_PROCEDURE && sym->attr.proc != PROC_ST_FUNCTION
2829       && !sym->attr.external)
2830     {
2831       bool bad_proc;
2832       bad_proc = false;
2833
2834       /* (i) Use associated;  */
2835       if (sym->attr.use_assoc)
2836         bad_proc = true;
2837
2838       /* (ii) The assignment is in the main program; or  */
2839       if (gfc_current_ns->proc_name->attr.is_main_program)
2840         bad_proc = true;
2841
2842       /* (iii) A module or internal procedure...  */
2843       if ((gfc_current_ns->proc_name->attr.proc == PROC_INTERNAL
2844            || gfc_current_ns->proc_name->attr.proc == PROC_MODULE)
2845           && gfc_current_ns->parent
2846           && (!(gfc_current_ns->parent->proc_name->attr.function
2847                 || gfc_current_ns->parent->proc_name->attr.subroutine)
2848               || gfc_current_ns->parent->proc_name->attr.is_main_program))
2849         {
2850           /* ... that is not a function...  */
2851           if (!gfc_current_ns->proc_name->attr.function)
2852             bad_proc = true;
2853
2854           /* ... or is not an entry and has a different name.  */
2855           if (!sym->attr.entry && sym->name != gfc_current_ns->proc_name->name)
2856             bad_proc = true;
2857         }
2858
2859       /* (iv) Host associated and not the function symbol or the
2860               parent result.  This picks up sibling references, which
2861               cannot be entries.  */
2862       if (!sym->attr.entry
2863             && sym->ns == gfc_current_ns->parent
2864             && sym != gfc_current_ns->proc_name
2865             && sym != gfc_current_ns->parent->proc_name->result)
2866         bad_proc = true;
2867
2868       if (bad_proc)
2869         {
2870           gfc_error ("'%s' at %L is not a VALUE", sym->name, &lvalue->where);
2871           return FAILURE;
2872         }
2873     }
2874
2875   if (rvalue->rank != 0 && lvalue->rank != rvalue->rank)
2876     {
2877       gfc_error ("Incompatible ranks %d and %d in assignment at %L",
2878                  lvalue->rank, rvalue->rank, &lvalue->where);
2879       return FAILURE;
2880     }
2881
2882   if (lvalue->ts.type == BT_UNKNOWN)
2883     {
2884       gfc_error ("Variable type is UNKNOWN in assignment at %L",
2885                  &lvalue->where);
2886       return FAILURE;
2887     }
2888
2889   if (rvalue->expr_type == EXPR_NULL)
2890     {
2891       if (lvalue->symtree->n.sym->attr.pointer
2892           && lvalue->symtree->n.sym->attr.data)
2893         return SUCCESS;
2894       else
2895         {
2896           gfc_error ("NULL appears on right-hand side in assignment at %L",
2897                      &rvalue->where);
2898           return FAILURE;
2899         }
2900     }
2901
2902    if (sym->attr.cray_pointee
2903        && lvalue->ref != NULL
2904        && lvalue->ref->u.ar.type == AR_FULL
2905        && lvalue->ref->u.ar.as->cp_was_assumed)
2906      {
2907        gfc_error ("Vector assignment to assumed-size Cray Pointee at %L "
2908                   "is illegal", &lvalue->where);
2909        return FAILURE;
2910      }
2911
2912   /* This is possibly a typo: x = f() instead of x => f().  */
2913   if (gfc_option.warn_surprising
2914       && rvalue->expr_type == EXPR_FUNCTION
2915       && rvalue->symtree->n.sym->attr.pointer)
2916     gfc_warning ("POINTER valued function appears on right-hand side of "
2917                  "assignment at %L", &rvalue->where);
2918
2919   /* Check size of array assignments.  */
2920   if (lvalue->rank != 0 && rvalue->rank != 0
2921       && gfc_check_conformance ("array assignment", lvalue, rvalue) != SUCCESS)
2922     return FAILURE;
2923
2924   if (rvalue->is_boz && lvalue->ts.type != BT_INTEGER
2925       && lvalue->symtree->n.sym->attr.data
2926       && gfc_notify_std (GFC_STD_GNU, "Extension: BOZ literal at %L used to "
2927                          "initialize non-integer variable '%s'",
2928                          &rvalue->where, lvalue->symtree->n.sym->name)
2929          == FAILURE)
2930     return FAILURE;
2931   else if (rvalue->is_boz && !lvalue->symtree->n.sym->attr.data
2932       && gfc_notify_std (GFC_STD_GNU, "Extension: BOZ literal at %L outside "
2933                          "a DATA statement and outside INT/REAL/DBLE/CMPLX",
2934                          &rvalue->where) == FAILURE)
2935     return FAILURE;
2936
2937   /* Handle the case of a BOZ literal on the RHS.  */
2938   if (rvalue->is_boz && lvalue->ts.type != BT_INTEGER)
2939     {
2940       int rc;
2941       if (gfc_option.warn_surprising)
2942         gfc_warning ("BOZ literal at %L is bitwise transferred "
2943                      "non-integer symbol '%s'", &rvalue->where,
2944                      lvalue->symtree->n.sym->name);
2945       if (!gfc_convert_boz (rvalue, &lvalue->ts))
2946         return FAILURE;
2947       if ((rc = gfc_range_check (rvalue)) != ARITH_OK)
2948         {
2949           if (rc == ARITH_UNDERFLOW)
2950             gfc_error ("Arithmetic underflow of bit-wise transferred BOZ at %L"
2951                        ". This check can be disabled with the option "
2952                        "-fno-range-check", &rvalue->where);
2953           else if (rc == ARITH_OVERFLOW)
2954             gfc_error ("Arithmetic overflow of bit-wise transferred BOZ at %L"
2955                        ". This check can be disabled with the option "
2956                        "-fno-range-check", &rvalue->where);
2957           else if (rc == ARITH_NAN)
2958             gfc_error ("Arithmetic NaN of bit-wise transferred BOZ at %L"
2959                        ". This check can be disabled with the option "
2960                        "-fno-range-check", &rvalue->where);
2961           return FAILURE;
2962         }
2963     }
2964
2965   if (gfc_compare_types (&lvalue->ts, &rvalue->ts))
2966     return SUCCESS;
2967
2968   /* Only DATA Statements come here.  */
2969   if (!conform)
2970     {
2971       /* Numeric can be converted to any other numeric. And Hollerith can be
2972          converted to any other type.  */
2973       if ((gfc_numeric_ts (&lvalue->ts) && gfc_numeric_ts (&rvalue->ts))
2974           || rvalue->ts.type == BT_HOLLERITH)
2975         return SUCCESS;
2976
2977       if (lvalue->ts.type == BT_LOGICAL && rvalue->ts.type == BT_LOGICAL)
2978         return SUCCESS;
2979
2980       gfc_error ("Incompatible types in DATA statement at %L; attempted "
2981                  "conversion of %s to %s", &lvalue->where,
2982                  gfc_typename (&rvalue->ts), gfc_typename (&lvalue->ts));
2983
2984       return FAILURE;
2985     }
2986
2987   /* Assignment is the only case where character variables of different
2988      kind values can be converted into one another.  */
2989   if (lvalue->ts.type == BT_CHARACTER && rvalue->ts.type == BT_CHARACTER)
2990     {
2991       if (lvalue->ts.kind != rvalue->ts.kind)
2992         gfc_convert_chartype (rvalue, &lvalue->ts);
2993
2994       return SUCCESS;
2995     }
2996
2997   return gfc_convert_type (rvalue, &lvalue->ts, 1);
2998 }
2999
3000
3001 /* Check that a pointer assignment is OK.  We first check lvalue, and
3002    we only check rvalue if it's not an assignment to NULL() or a
3003    NULLIFY statement.  */
3004
3005 gfc_try
3006 gfc_check_pointer_assign (gfc_expr *lvalue, gfc_expr *rvalue)
3007 {
3008   symbol_attribute attr;
3009   gfc_ref *ref;
3010   int is_pure;
3011   int pointer, check_intent_in;
3012
3013   if (lvalue->symtree->n.sym->ts.type == BT_UNKNOWN
3014       && !lvalue->symtree->n.sym->attr.proc_pointer)
3015     {
3016       gfc_error ("Pointer assignment target is not a POINTER at %L",
3017                  &lvalue->where);
3018       return FAILURE;
3019     }
3020
3021   if (lvalue->symtree->n.sym->attr.flavor == FL_PROCEDURE
3022       && lvalue->symtree->n.sym->attr.use_assoc)
3023     {
3024       gfc_error ("'%s' in the pointer assignment at %L cannot be an "
3025                  "l-value since it is a procedure",
3026                  lvalue->symtree->n.sym->name, &lvalue->where);
3027       return FAILURE;
3028     }
3029
3030
3031   /* Check INTENT(IN), unless the object itself is the component or
3032      sub-component of a pointer.  */
3033   check_intent_in = 1;
3034   pointer = lvalue->symtree->n.sym->attr.pointer
3035               | lvalue->symtree->n.sym->attr.proc_pointer;
3036
3037   for (ref = lvalue->ref; ref; ref = ref->next)
3038     {
3039       if (pointer)
3040         check_intent_in = 0;
3041
3042       if (ref->type == REF_COMPONENT && ref->u.c.component->attr.pointer)
3043         pointer = 1;
3044
3045       if (ref->type == REF_ARRAY && ref->next == NULL)
3046         {
3047           if (ref->u.ar.type == AR_FULL)
3048             break;
3049
3050           if (ref->u.ar.type != AR_SECTION)
3051             {
3052               gfc_error ("Expected bounds specification for '%s' at %L",
3053                          lvalue->symtree->n.sym->name, &lvalue->where);
3054               return FAILURE;
3055             }
3056
3057           if (gfc_notify_std (GFC_STD_F2003,"Fortran 2003: Bounds "
3058                               "specification for '%s' in pointer assignment "
3059                               "at %L", lvalue->symtree->n.sym->name,
3060                               &lvalue->where) == FAILURE)
3061             return FAILURE;
3062
3063           gfc_error ("Pointer bounds remapping at %L is not yet implemented "
3064                      "in gfortran", &lvalue->where);
3065           /* TODO: See PR 29785. Add checks that all lbounds are specified and
3066              either never or always the upper-bound; strides shall not be
3067              present.  */
3068           return FAILURE;
3069         }
3070     }
3071
3072   if (check_intent_in && lvalue->symtree->n.sym->attr.intent == INTENT_IN)
3073     {
3074       gfc_error ("Cannot assign to INTENT(IN) variable '%s' at %L",
3075                  lvalue->symtree->n.sym->name, &lvalue->where);
3076       return FAILURE;
3077     }
3078
3079   if (!pointer)
3080     {
3081       gfc_error ("Pointer assignment to non-POINTER at %L", &lvalue->where);
3082       return FAILURE;
3083     }
3084
3085   is_pure = gfc_pure (NULL);
3086
3087   if (is_pure && gfc_impure_variable (lvalue->symtree->n.sym)
3088         && lvalue->symtree->n.sym->value != rvalue)
3089     {
3090       gfc_error ("Bad pointer object in PURE procedure at %L", &lvalue->where);
3091       return FAILURE;
3092     }
3093
3094   /* If rvalue is a NULL() or NULLIFY, we're done. Otherwise the type,
3095      kind, etc for lvalue and rvalue must match, and rvalue must be a
3096      pure variable if we're in a pure function.  */
3097   if (rvalue->expr_type == EXPR_NULL && rvalue->ts.type == BT_UNKNOWN)
3098     return SUCCESS;
3099
3100   /* TODO checks on rvalue for a procedure pointer assignment.  */
3101   if (lvalue->symtree->n.sym->attr.proc_pointer)
3102     return SUCCESS;
3103
3104   if (!gfc_compare_types (&lvalue->ts, &rvalue->ts))
3105     {
3106       gfc_error ("Different types in pointer assignment at %L; attempted "
3107                  "assignment of %s to %s", &lvalue->where,
3108                  gfc_typename (&rvalue->ts), gfc_typename (&lvalue->ts));
3109       return FAILURE;
3110     }
3111
3112   if (lvalue->ts.kind != rvalue->ts.kind)
3113     {
3114       gfc_error ("Different kind type parameters in pointer "
3115                  "assignment at %L", &lvalue->where);
3116       return FAILURE;
3117     }
3118
3119   if (lvalue->rank != rvalue->rank)
3120     {
3121       gfc_error ("Different ranks in pointer assignment at %L",
3122                  &lvalue->where);
3123       return FAILURE;
3124     }
3125
3126   /* Now punt if we are dealing with a NULLIFY(X) or X = NULL(X).  */
3127   if (rvalue->expr_type == EXPR_NULL)
3128     return SUCCESS;
3129
3130   if (lvalue->ts.type == BT_CHARACTER
3131       && lvalue->ts.cl && rvalue->ts.cl
3132       && lvalue->ts.cl->length && rvalue->ts.cl->length
3133       && abs (gfc_dep_compare_expr (lvalue->ts.cl->length,
3134                                     rvalue->ts.cl->length)) == 1)
3135     {
3136       gfc_error ("Different character lengths in pointer "
3137                  "assignment at %L", &lvalue->where);
3138       return FAILURE;
3139     }
3140
3141   if (rvalue->expr_type == EXPR_VARIABLE && is_subref_array (rvalue))
3142     lvalue->symtree->n.sym->attr.subref_array_pointer = 1;
3143
3144   attr = gfc_expr_attr (rvalue);
3145   if (!attr.target && !attr.pointer)
3146     {
3147       gfc_error ("Pointer assignment target is neither TARGET "
3148                  "nor POINTER at %L", &rvalue->where);
3149       return FAILURE;
3150     }
3151
3152   if (is_pure && gfc_impure_variable (rvalue->symtree->n.sym))
3153     {
3154       gfc_error ("Bad target in pointer assignment in PURE "
3155                  "procedure at %L", &rvalue->where);
3156     }
3157
3158   if (gfc_has_vector_index (rvalue))
3159     {
3160       gfc_error ("Pointer assignment with vector subscript "
3161                  "on rhs at %L", &rvalue->where);
3162       return FAILURE;
3163     }
3164
3165   if (attr.is_protected && attr.use_assoc
3166       && !(attr.pointer || attr.proc_pointer))
3167     {
3168       gfc_error ("Pointer assignment target has PROTECTED "
3169                  "attribute at %L", &rvalue->where);
3170       return FAILURE;
3171     }
3172
3173   return SUCCESS;
3174 }
3175
3176
3177 /* Relative of gfc_check_assign() except that the lvalue is a single
3178    symbol.  Used for initialization assignments.  */
3179
3180 gfc_try
3181 gfc_check_assign_symbol (gfc_symbol *sym, gfc_expr *rvalue)
3182 {
3183   gfc_expr lvalue;
3184   gfc_try r;
3185
3186   memset (&lvalue, '\0', sizeof (gfc_expr));
3187
3188   lvalue.expr_type = EXPR_VARIABLE;
3189   lvalue.ts = sym->ts;
3190   if (sym->as)
3191     lvalue.rank = sym->as->rank;
3192   lvalue.symtree = (gfc_symtree *) gfc_getmem (sizeof (gfc_symtree));
3193   lvalue.symtree->n.sym = sym;
3194   lvalue.where = sym->declared_at;
3195
3196   if (sym->attr.pointer || sym->attr.proc_pointer)
3197     r = gfc_check_pointer_assign (&lvalue, rvalue);
3198   else
3199     r = gfc_check_assign (&lvalue, rvalue, 1);
3200
3201   gfc_free (lvalue.symtree);
3202
3203   return r;
3204 }
3205
3206
3207 /* Get an expression for a default initializer.  */
3208
3209 gfc_expr *
3210 gfc_default_initializer (gfc_typespec *ts)
3211 {
3212   gfc_constructor *tail;
3213   gfc_expr *init;
3214   gfc_component *c;
3215
3216   /* See if we have a default initializer.  */
3217   for (c = ts->derived->components; c; c = c->next)
3218     if (c->initializer || c->attr.allocatable)
3219       break;
3220
3221   if (!c)
3222     return NULL;
3223
3224   /* Build the constructor.  */
3225   init = gfc_get_expr ();
3226   init->expr_type = EXPR_STRUCTURE;
3227   init->ts = *ts;
3228   init->where = ts->derived->declared_at;
3229
3230   tail = NULL;
3231   for (c = ts->derived->components; c; c = c->next)
3232     {
3233       if (tail == NULL)
3234         init->value.constructor = tail = gfc_get_constructor ();
3235       else
3236         {
3237           tail->next = gfc_get_constructor ();
3238           tail = tail->next;
3239         }
3240
3241       if (c->initializer)
3242         tail->expr = gfc_copy_expr (c->initializer);
3243
3244       if (c->attr.allocatable)
3245         {
3246           tail->expr = gfc_get_expr ();
3247           tail->expr->expr_type = EXPR_NULL;
3248           tail->expr->ts = c->ts;
3249         }
3250     }
3251   return init;
3252 }
3253
3254
3255 /* Given a symbol, create an expression node with that symbol as a
3256    variable. If the symbol is array valued, setup a reference of the
3257    whole array.  */
3258
3259 gfc_expr *
3260 gfc_get_variable_expr (gfc_symtree *var)
3261 {
3262   gfc_expr *e;
3263
3264   e = gfc_get_expr ();
3265   e->expr_type = EXPR_VARIABLE;
3266   e->symtree = var;
3267   e->ts = var->n.sym->ts;
3268
3269   if (var->n.sym->as != NULL)
3270     {
3271       e->rank = var->n.sym->as->rank;
3272       e->ref = gfc_get_ref ();
3273       e->ref->type = REF_ARRAY;
3274       e->ref->u.ar.type = AR_FULL;
3275     }
3276
3277   return e;
3278 }
3279
3280
3281 /* General expression traversal function.  */
3282
3283 bool
3284 gfc_traverse_expr (gfc_expr *expr, gfc_symbol *sym,
3285                    bool (*func)(gfc_expr *, gfc_symbol *, int*),
3286                    int f)
3287 {
3288   gfc_array_ref ar;
3289   gfc_ref *ref;
3290   gfc_actual_arglist *args;
3291   gfc_constructor *c;
3292   int i;
3293
3294   if (!expr)
3295     return false;
3296
3297   if ((*func) (expr, sym, &f))
3298     return true;
3299
3300   if (expr->ts.type == BT_CHARACTER
3301         && expr->ts.cl
3302         && expr->ts.cl->length
3303         && expr->ts.cl->length->expr_type != EXPR_CONSTANT
3304         && gfc_traverse_expr (expr->ts.cl->length, sym, func, f))
3305     return true;
3306
3307   switch (expr->expr_type)
3308     {
3309     case EXPR_FUNCTION:
3310       for (args = expr->value.function.actual; args; args = args->next)
3311         {
3312           if (gfc_traverse_expr (args->expr, sym, func, f))
3313             return true;
3314         }
3315       break;
3316
3317     case EXPR_VARIABLE:
3318     case EXPR_CONSTANT:
3319     case EXPR_NULL:
3320     case EXPR_SUBSTRING:
3321       break;
3322
3323     case EXPR_STRUCTURE:
3324     case EXPR_ARRAY:
3325       for (c = expr->value.constructor; c; c = c->next)
3326         {
3327           if (gfc_traverse_expr (c->expr, sym, func, f))
3328             return true;
3329           if (c->iterator)
3330             {
3331               if (gfc_traverse_expr (c->iterator->var, sym, func, f))
3332                 return true;
3333               if (gfc_traverse_expr (c->iterator->start, sym, func, f))
3334                 return true;
3335               if (gfc_traverse_expr (c->iterator->end, sym, func, f))
3336                 return true;
3337               if (gfc_traverse_expr (c->iterator->step, sym, func, f))
3338                 return true;
3339             }
3340         }
3341       break;
3342
3343     case EXPR_OP:
3344       if (gfc_traverse_expr (expr->value.op.op1, sym, func, f))
3345         return true;
3346       if (gfc_traverse_expr (expr->value.op.op2, sym, func, f))
3347         return true;
3348       break;
3349
3350     default:
3351       gcc_unreachable ();
3352       break;
3353     }
3354
3355   ref = expr->ref;
3356   while (ref != NULL)
3357     {
3358       switch (ref->type)
3359         {
3360         case  REF_ARRAY:
3361           ar = ref->u.ar;
3362           for (i = 0; i < GFC_MAX_DIMENSIONS; i++)
3363             {
3364               if (gfc_traverse_expr (ar.start[i], sym, func, f))
3365                 return true;
3366               if (gfc_traverse_expr (ar.end[i], sym, func, f))
3367                 return true;
3368               if (gfc_traverse_expr (ar.stride[i], sym, func, f))
3369                 return true;
3370             }
3371           break;
3372
3373         case REF_SUBSTRING:
3374           if (gfc_traverse_expr (ref->u.ss.start, sym, func, f))
3375             return true;
3376           if (gfc_traverse_expr (ref->u.ss.end, sym, func, f))
3377             return true;
3378           break;
3379
3380         case REF_COMPONENT:
3381           if (ref->u.c.component->ts.type == BT_CHARACTER
3382                 && ref->u.c.component->ts.cl
3383                 && ref->u.c.component->ts.cl->length
3384                 && ref->u.c.component->ts.cl->length->expr_type
3385                      != EXPR_CONSTANT
3386                 && gfc_traverse_expr (ref->u.c.component->ts.cl->length,
3387                                       sym, func, f))
3388             return true;
3389
3390           if (ref->u.c.component->as)
3391             for (i = 0; i < ref->u.c.component->as->rank; i++)
3392               {
3393                 if (gfc_traverse_expr (ref->u.c.component->as->lower[i],
3394                                        sym, func, f))
3395                   return true;
3396                 if (gfc_traverse_expr (ref->u.c.component->as->upper[i],
3397                                        sym, func, f))
3398                   return true;
3399               }
3400           break;
3401
3402         default:
3403           gcc_unreachable ();
3404         }
3405       ref = ref->next;
3406     }
3407   return false;
3408 }
3409
3410 /* Traverse expr, marking all EXPR_VARIABLE symbols referenced.  */
3411
3412 static bool
3413 expr_set_symbols_referenced (gfc_expr *expr,
3414                              gfc_symbol *sym ATTRIBUTE_UNUSED,
3415                              int *f ATTRIBUTE_UNUSED)
3416 {
3417   if (expr->expr_type != EXPR_VARIABLE)
3418     return false;
3419   gfc_set_sym_referenced (expr->symtree->n.sym);
3420   return false;
3421 }
3422
3423 void
3424 gfc_expr_set_symbols_referenced (gfc_expr *expr)
3425 {
3426   gfc_traverse_expr (expr, NULL, expr_set_symbols_referenced, 0);
3427 }
3428
3429
3430 /* Walk an expression tree and check each variable encountered for being typed.
3431    If strict is not set, a top-level variable is tolerated untyped in -std=gnu
3432    mode; this is for things in legacy-code like:
3433
3434      INTEGER :: arr(n), n
3435
3436    The namespace is needed for IMPLICIT typing.  */
3437
3438 static gfc_namespace* check_typed_ns;
3439
3440 static bool
3441 expr_check_typed_help (gfc_expr* e, gfc_symbol* sym ATTRIBUTE_UNUSED,
3442                        int* f ATTRIBUTE_UNUSED)
3443 {
3444   gfc_try t;
3445
3446   if (e->expr_type != EXPR_VARIABLE)
3447     return false;
3448
3449   gcc_assert (e->symtree);
3450   t = gfc_check_symbol_typed (e->symtree->n.sym, check_typed_ns,
3451                               true, e->where);
3452
3453   return (t == FAILURE);
3454 }
3455
3456 gfc_try
3457 gfc_expr_check_typed (gfc_expr* e, gfc_namespace* ns, bool strict)
3458 {
3459   bool error_found;
3460
3461   /* If this is a top-level variable, do the check with strict given to us.  */
3462   if (!strict && e->expr_type == EXPR_VARIABLE && !e->ref)
3463     return gfc_check_symbol_typed (e->symtree->n.sym, ns, strict, e->where);
3464
3465   /* Otherwise, walk the expression and do it strictly.  */
3466   check_typed_ns = ns;
3467   error_found = gfc_traverse_expr (e, NULL, &expr_check_typed_help, 0);
3468
3469   return error_found ? FAILURE : SUCCESS;
3470 }