gcc/fortran/expr.c

   1 /* Routines for manipulation of expression nodes.
   2    Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006 Free Software
   3    Foundation, Inc.
   4    Contributed by Andy Vaught
   5
   6 This file is part of GCC.
   7
   8 GCC is free software; you can redistribute it and/or modify it under
   9 the terms of the GNU General Public License as published by the Free
  10 Software Foundation; either version 2, or (at your option) any later
  11 version.
  12
  13 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
  14 WARRANTY; without even the implied warranty of MERCHANTABILITY or
  15 FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
  16 for more details.
  17
  18 You should have received a copy of the GNU General Public License
  19 along with GCC; see the file COPYING.  If not, write to the Free
  20 Software Foundation, 51 Franklin Street, Fifth Floor, Boston, MA
  21 02110-1301, USA.  */
  22
  23 #include "config.h"
  24 #include "system.h"
  25 #include "gfortran.h"
  26 #include "arith.h"
  27 #include "match.h"
  28
  29 /* Get a new expr node.  */
  30
  31 gfc_expr *
  32 gfc_get_expr (void)
  33 {
  34   gfc_expr *e;
  35
  36   e = gfc_getmem (sizeof (gfc_expr));
  37
  38   gfc_clear_ts (&e->ts);
  39   e->shape = NULL;
  40   e->ref = NULL;
  41   e->symtree = NULL;
  42
  43   return e;
  44 }
  45
  46
  47 /* Free an argument list and everything below it.  */
  48
  49 void
  50 gfc_free_actual_arglist (gfc_actual_arglist * a1)
  51 {
  52   gfc_actual_arglist *a2;
  53
  54   while (a1)
  55     {
  56       a2 = a1->next;
  57       gfc_free_expr (a1->expr);
  58       gfc_free (a1);
  59       a1 = a2;
  60     }
  61 }
  62
  63
  64 /* Copy an arglist structure and all of the arguments.  */
  65
  66 gfc_actual_arglist *
  67 gfc_copy_actual_arglist (gfc_actual_arglist * p)
  68 {
  69   gfc_actual_arglist *head, *tail, *new;
  70
  71   head = tail = NULL;
  72
  73   for (; p; p = p->next)
  74     {
  75       new = gfc_get_actual_arglist ();
  76       *new = *p;
  77
  78       new->expr = gfc_copy_expr (p->expr);
  79       new->next = NULL;
  80
  81       if (head == NULL)
  82         head = new;
  83       else
  84         tail->next = new;
  85
  86       tail = new;
  87     }
  88
  89   return head;
  90 }
  91
  92
  93 /* Free a list of reference structures.  */
  94
  95 void
  96 gfc_free_ref_list (gfc_ref * p)
  97 {
  98   gfc_ref *q;
  99   int i;
 100
 101   for (; p; p = q)
 102     {
 103       q = p->next;
 104
 105       switch (p->type)
 106         {
 107         case REF_ARRAY:
 108           for (i = 0; i < GFC_MAX_DIMENSIONS; i++)
 109             {
 110               gfc_free_expr (p->u.ar.start[i]);
 111               gfc_free_expr (p->u.ar.end[i]);
 112               gfc_free_expr (p->u.ar.stride[i]);
 113             }
 114
 115           break;
 116
 117         case REF_SUBSTRING:
 118           gfc_free_expr (p->u.ss.start);
 119           gfc_free_expr (p->u.ss.end);
 120           break;
 121
 122         case REF_COMPONENT:
 123           break;
 124         }
 125
 126       gfc_free (p);
 127     }
 128 }
 129
 130
 131 /* Workhorse function for gfc_free_expr() that frees everything
 132    beneath an expression node, but not the node itself.  This is
 133    useful when we want to simplify a node and replace it with
 134    something else or the expression node belongs to another structure.  */
 135
 136 static void
 137 free_expr0 (gfc_expr * e)
 138 {
 139   int n;
 140
 141   switch (e->expr_type)
 142     {
 143     case EXPR_CONSTANT:
 144       if (e->from_H)
 145         {
 146           gfc_free (e->value.character.string);
 147           break;
 148         }
 149
 150       switch (e->ts.type)
 151         {
 152         case BT_INTEGER:
 153           mpz_clear (e->value.integer);
 154           break;
 155
 156         case BT_REAL:
 157           mpfr_clear (e->value.real);
 158           break;
 159
 160         case BT_CHARACTER:
 161         case BT_HOLLERITH:
 162           gfc_free (e->value.character.string);
 163           break;
 164
 165         case BT_COMPLEX:
 166           mpfr_clear (e->value.complex.r);
 167           mpfr_clear (e->value.complex.i);
 168           break;
 169
 170         default:
 171           break;
 172         }
 173
 174       break;
 175
 176     case EXPR_OP:
 177       if (e->value.op.op1 != NULL)
 178         gfc_free_expr (e->value.op.op1);
 179       if (e->value.op.op2 != NULL)
 180         gfc_free_expr (e->value.op.op2);
 181       break;
 182
 183     case EXPR_FUNCTION:
 184       gfc_free_actual_arglist (e->value.function.actual);
 185       break;
 186
 187     case EXPR_VARIABLE:
 188       break;
 189
 190     case EXPR_ARRAY:
 191     case EXPR_STRUCTURE:
 192       gfc_free_constructor (e->value.constructor);
 193       break;
 194
 195     case EXPR_SUBSTRING:
 196       gfc_free (e->value.character.string);
 197       break;
 198
 199     case EXPR_NULL:
 200       break;
 201
 202     default:
 203       gfc_internal_error ("free_expr0(): Bad expr type");
 204     }
 205
 206   /* Free a shape array.  */
 207   if (e->shape != NULL)
 208     {
 209       for (n = 0; n < e->rank; n++)
 210         mpz_clear (e->shape[n]);
 211
 212       gfc_free (e->shape);
 213     }
 214
 215   gfc_free_ref_list (e->ref);
 216
 217   memset (e, '\0', sizeof (gfc_expr));
 218 }
 219
 220
 221 /* Free an expression node and everything beneath it.  */
 222
 223 void
 224 gfc_free_expr (gfc_expr * e)
 225 {
 226
 227   if (e == NULL)
 228     return;
 229
 230   free_expr0 (e);
 231   gfc_free (e);
 232 }
 233
 234
 235 /* Graft the *src expression onto the *dest subexpression.  */
 236
 237 void
 238 gfc_replace_expr (gfc_expr * dest, gfc_expr * src)
 239 {
 240
 241   free_expr0 (dest);
 242   *dest = *src;
 243
 244   gfc_free (src);
 245 }
 246
 247
 248 /* Try to extract an integer constant from the passed expression node.
 249    Returns an error message or NULL if the result is set.  It is
 250    tempting to generate an error and return SUCCESS or FAILURE, but
 251    failure is OK for some callers.  */
 252
 253 const char *
 254 gfc_extract_int (gfc_expr * expr, int *result)
 255 {
 256
 257   if (expr->expr_type != EXPR_CONSTANT)
 258     return _("Constant expression required at %C");
 259
 260   if (expr->ts.type != BT_INTEGER)
 261     return _("Integer expression required at %C");
 262
 263   if ((mpz_cmp_si (expr->value.integer, INT_MAX) > 0)
 264       || (mpz_cmp_si (expr->value.integer, INT_MIN) < 0))
 265     {
 266       return _("Integer value too large in expression at %C");
 267     }
 268
 269   *result = (int) mpz_get_si (expr->value.integer);
 270
 271   return NULL;
 272 }
 273
 274
 275 /* Recursively copy a list of reference structures.  */
 276
 277 static gfc_ref *
 278 copy_ref (gfc_ref * src)
 279 {
 280   gfc_array_ref *ar;
 281   gfc_ref *dest;
 282
 283   if (src == NULL)
 284     return NULL;
 285
 286   dest = gfc_get_ref ();
 287   dest->type = src->type;
 288
 289   switch (src->type)
 290     {
 291     case REF_ARRAY:
 292       ar = gfc_copy_array_ref (&src->u.ar);
 293       dest->u.ar = *ar;
 294       gfc_free (ar);
 295       break;
 296
 297     case REF_COMPONENT:
 298       dest->u.c = src->u.c;
 299       break;
 300
 301     case REF_SUBSTRING:
 302       dest->u.ss = src->u.ss;
 303       dest->u.ss.start = gfc_copy_expr (src->u.ss.start);
 304       dest->u.ss.end = gfc_copy_expr (src->u.ss.end);
 305       break;
 306     }
 307
 308   dest->next = copy_ref (src->next);
 309
 310   return dest;
 311 }
 312
 313
 314 /* Detect whether an expression has any vector index array
 315    references.  */
 316
 317 int
 318 gfc_has_vector_index (gfc_expr *e)
 319 {
 320   gfc_ref * ref;
 321   int i;
 322   for (ref = e->ref; ref; ref = ref->next)
 323     if (ref->type == REF_ARRAY)
 324       for (i = 0; i < ref->u.ar.dimen; i++)
 325         if (ref->u.ar.dimen_type[i] == DIMEN_VECTOR)
 326           return 1;
 327   return 0;
 328 }
 329
 330
 331 /* Copy a shape array.  */
 332
 333 mpz_t *
 334 gfc_copy_shape (mpz_t * shape, int rank)
 335 {
 336   mpz_t *new_shape;
 337   int n;
 338
 339   if (shape == NULL)
 340     return NULL;
 341
 342   new_shape = gfc_get_shape (rank);
 343
 344   for (n = 0; n < rank; n++)
 345     mpz_init_set (new_shape[n], shape[n]);
 346
 347   return new_shape;
 348 }
 349
 350
 351 /* Copy a shape array excluding dimension N, where N is an integer
 352    constant expression.  Dimensions are numbered in fortran style --
 353    starting with ONE.
 354
 355    So, if the original shape array contains R elements
 356       { s1 ... sN-1  sN  sN+1 ... sR-1 sR}
 357    the result contains R-1 elements:
 358       { s1 ... sN-1  sN+1    ...  sR-1}
 359
 360    If anything goes wrong -- N is not a constant, its value is out
 361    of range -- or anything else, just returns NULL.
 362 */
 363
 364 mpz_t *
 365 gfc_copy_shape_excluding (mpz_t * shape, int rank, gfc_expr * dim)
 366 {
 367   mpz_t *new_shape, *s;
 368   int i, n;
 369
 370   if (shape == NULL
 371       || rank <= 1
 372       || dim == NULL
 373       || dim->expr_type != EXPR_CONSTANT
 374       || dim->ts.type != BT_INTEGER)
 375     return NULL;
 376
 377   n = mpz_get_si (dim->value.integer);
 378   n--; /* Convert to zero based index */
 379   if (n < 0 || n >= rank)
 380     return NULL;
 381
 382   s = new_shape = gfc_get_shape (rank-1);
 383
 384   for (i = 0; i < rank; i++)
 385     {
 386       if (i == n)
 387         continue;
 388       mpz_init_set (*s, shape[i]);
 389       s++;
 390     }
 391
 392   return new_shape;
 393 }
 394
 395 /* Given an expression pointer, return a copy of the expression.  This
 396    subroutine is recursive.  */
 397
 398 gfc_expr *
 399 gfc_copy_expr (gfc_expr * p)
 400 {
 401   gfc_expr *q;
 402   char *s;
 403
 404   if (p == NULL)
 405     return NULL;
 406
 407   q = gfc_get_expr ();
 408   *q = *p;
 409
 410   switch (q->expr_type)
 411     {
 412     case EXPR_SUBSTRING:
 413       s = gfc_getmem (p->value.character.length + 1);
 414       q->value.character.string = s;
 415
 416       memcpy (s, p->value.character.string, p->value.character.length + 1);
 417       break;
 418
 419     case EXPR_CONSTANT:
 420       if (p->from_H)
 421         {
 422           s = gfc_getmem (p->value.character.length + 1);
 423           q->value.character.string = s;
 424
 425           memcpy (s, p->value.character.string,
 426                   p->value.character.length + 1);
 427           break;
 428         }
 429       switch (q->ts.type)
 430         {
 431         case BT_INTEGER:
 432           mpz_init_set (q->value.integer, p->value.integer);
 433           break;
 434
 435         case BT_REAL:
 436           gfc_set_model_kind (q->ts.kind);
 437           mpfr_init (q->value.real);
 438           mpfr_set (q->value.real, p->value.real, GFC_RND_MODE);
 439           break;
 440
 441         case BT_COMPLEX:
 442           gfc_set_model_kind (q->ts.kind);
 443           mpfr_init (q->value.complex.r);
 444           mpfr_init (q->value.complex.i);
 445           mpfr_set (q->value.complex.r, p->value.complex.r, GFC_RND_MODE);
 446           mpfr_set (q->value.complex.i, p->value.complex.i, GFC_RND_MODE);
 447           break;
 448
 449         case BT_CHARACTER:
 450         case BT_HOLLERITH:
 451           s = gfc_getmem (p->value.character.length + 1);
 452           q->value.character.string = s;
 453
 454           memcpy (s, p->value.character.string,
 455                   p->value.character.length + 1);
 456           break;
 457
 458         case BT_LOGICAL:
 459         case BT_DERIVED:
 460           break;                /* Already done */
 461
 462         case BT_PROCEDURE:
 463         case BT_UNKNOWN:
 464           gfc_internal_error ("gfc_copy_expr(): Bad expr node");
 465           /* Not reached */
 466         }
 467
 468       break;
 469
 470     case EXPR_OP:
 471       switch (q->value.op.operator)
 472         {
 473         case INTRINSIC_NOT:
 474         case INTRINSIC_UPLUS:
 475         case INTRINSIC_UMINUS:
 476           q->value.op.op1 = gfc_copy_expr (p->value.op.op1);
 477           break;
 478
 479         default:                /* Binary operators */
 480           q->value.op.op1 = gfc_copy_expr (p->value.op.op1);
 481           q->value.op.op2 = gfc_copy_expr (p->value.op.op2);
 482           break;
 483         }
 484
 485       break;
 486
 487     case EXPR_FUNCTION:
 488       q->value.function.actual =
 489         gfc_copy_actual_arglist (p->value.function.actual);
 490       break;
 491
 492     case EXPR_STRUCTURE:
 493     case EXPR_ARRAY:
 494       q->value.constructor = gfc_copy_constructor (p->value.constructor);
 495       break;
 496
 497     case EXPR_VARIABLE:
 498     case EXPR_NULL:
 499       break;
 500     }
 501
 502   q->shape = gfc_copy_shape (p->shape, p->rank);
 503
 504   q->ref = copy_ref (p->ref);
 505
 506   return q;
 507 }
 508
 509
 510 /* Return the maximum kind of two expressions.  In general, higher
 511    kind numbers mean more precision for numeric types.  */
 512
 513 int
 514 gfc_kind_max (gfc_expr * e1, gfc_expr * e2)
 515 {
 516
 517   return (e1->ts.kind > e2->ts.kind) ? e1->ts.kind : e2->ts.kind;
 518 }
 519
 520
 521 /* Returns nonzero if the type is numeric, zero otherwise.  */
 522
 523 static int
 524 numeric_type (bt type)
 525 {
 526
 527   return type == BT_COMPLEX || type == BT_REAL || type == BT_INTEGER;
 528 }
 529
 530
 531 /* Returns nonzero if the typespec is a numeric type, zero otherwise.  */
 532
 533 int
 534 gfc_numeric_ts (gfc_typespec * ts)
 535 {
 536
 537   return numeric_type (ts->type);
 538 }
 539
 540
 541 /* Returns an expression node that is an integer constant.  */
 542
 543 gfc_expr *
 544 gfc_int_expr (int i)
 545 {
 546   gfc_expr *p;
 547
 548   p = gfc_get_expr ();
 549
 550   p->expr_type = EXPR_CONSTANT;
 551   p->ts.type = BT_INTEGER;
 552   p->ts.kind = gfc_default_integer_kind;
 553
 554   p->where = gfc_current_locus;
 555   mpz_init_set_si (p->value.integer, i);
 556
 557   return p;
 558 }
 559
 560
 561 /* Returns an expression node that is a logical constant.  */
 562
 563 gfc_expr *
 564 gfc_logical_expr (int i, locus * where)
 565 {
 566   gfc_expr *p;
 567
 568   p = gfc_get_expr ();
 569
 570   p->expr_type = EXPR_CONSTANT;
 571   p->ts.type = BT_LOGICAL;
 572   p->ts.kind = gfc_default_logical_kind;
 573
 574   if (where == NULL)
 575     where = &gfc_current_locus;
 576   p->where = *where;
 577   p->value.logical = i;
 578
 579   return p;
 580 }
 581
 582
 583 /* Return an expression node with an optional argument list attached.
 584    A variable number of gfc_expr pointers are strung together in an
 585    argument list with a NULL pointer terminating the list.  */
 586
 587 gfc_expr *
 588 gfc_build_conversion (gfc_expr * e)
 589 {
 590   gfc_expr *p;
 591
 592   p = gfc_get_expr ();
 593   p->expr_type = EXPR_FUNCTION;
 594   p->symtree = NULL;
 595   p->value.function.actual = NULL;
 596
 597   p->value.function.actual = gfc_get_actual_arglist ();
 598   p->value.function.actual->expr = e;
 599
 600   return p;
 601 }
 602
 603
 604 /* Given an expression node with some sort of numeric binary
 605    expression, insert type conversions required to make the operands
 606    have the same type.
 607
 608    The exception is that the operands of an exponential don't have to
 609    have the same type.  If possible, the base is promoted to the type
 610    of the exponent.  For example, 1**2.3 becomes 1.0**2.3, but
 611    1.0**2 stays as it is.  */
 612
 613 void
 614 gfc_type_convert_binary (gfc_expr * e)
 615 {
 616   gfc_expr *op1, *op2;
 617
 618   op1 = e->value.op.op1;
 619   op2 = e->value.op.op2;
 620
 621   if (op1->ts.type == BT_UNKNOWN || op2->ts.type == BT_UNKNOWN)
 622     {
 623       gfc_clear_ts (&e->ts);
 624       return;
 625     }
 626
 627   /* Kind conversions of same type.  */
 628   if (op1->ts.type == op2->ts.type)
 629     {
 630
 631       if (op1->ts.kind == op2->ts.kind)
 632         {
 633           /* No type conversions.  */
 634           e->ts = op1->ts;
 635           goto done;
 636         }
 637
 638       if (op1->ts.kind > op2->ts.kind)
 639         gfc_convert_type (op2, &op1->ts, 2);
 640       else
 641         gfc_convert_type (op1, &op2->ts, 2);
 642
 643       e->ts = op1->ts;
 644       goto done;
 645     }
 646
 647   /* Integer combined with real or complex.  */
 648   if (op2->ts.type == BT_INTEGER)
 649     {
 650       e->ts = op1->ts;
 651
 652       /* Special case for ** operator.  */
 653       if (e->value.op.operator == INTRINSIC_POWER)
 654         goto done;
 655
 656       gfc_convert_type (e->value.op.op2, &e->ts, 2);
 657       goto done;
 658     }
 659
 660   if (op1->ts.type == BT_INTEGER)
 661     {
 662       e->ts = op2->ts;
 663       gfc_convert_type (e->value.op.op1, &e->ts, 2);
 664       goto done;
 665     }
 666
 667   /* Real combined with complex.  */
 668   e->ts.type = BT_COMPLEX;
 669   if (op1->ts.kind > op2->ts.kind)
 670     e->ts.kind = op1->ts.kind;
 671   else
 672     e->ts.kind = op2->ts.kind;
 673   if (op1->ts.type != BT_COMPLEX || op1->ts.kind != e->ts.kind)
 674     gfc_convert_type (e->value.op.op1, &e->ts, 2);
 675   if (op2->ts.type != BT_COMPLEX || op2->ts.kind != e->ts.kind)
 676     gfc_convert_type (e->value.op.op2, &e->ts, 2);
 677
 678 done:
 679   return;
 680 }
 681
 682
 683 /* Function to determine if an expression is constant or not.  This
 684    function expects that the expression has already been simplified.  */
 685
 686 int
 687 gfc_is_constant_expr (gfc_expr * e)
 688 {
 689   gfc_constructor *c;
 690   gfc_actual_arglist *arg;
 691   int rv;
 692
 693   if (e == NULL)
 694     return 1;
 695
 696   switch (e->expr_type)
 697     {
 698     case EXPR_OP:
 699       rv = (gfc_is_constant_expr (e->value.op.op1)
 700             && (e->value.op.op2 == NULL
 701                 || gfc_is_constant_expr (e->value.op.op2)));
 702
 703       break;
 704
 705     case EXPR_VARIABLE:
 706       rv = 0;
 707       break;
 708
 709     case EXPR_FUNCTION:
 710       /* Call to intrinsic with at least one argument.  */
 711       rv = 0;
 712       if (e->value.function.isym && e->value.function.actual)
 713         {
 714           for (arg = e->value.function.actual; arg; arg = arg->next)
 715             {
 716               if (!gfc_is_constant_expr (arg->expr))
 717                 break;
 718             }
 719           if (arg == NULL)
 720             rv = 1;
 721         }
 722       break;
 723
 724     case EXPR_CONSTANT:
 725     case EXPR_NULL:
 726       rv = 1;
 727       break;
 728
 729     case EXPR_SUBSTRING:
 730       rv = (gfc_is_constant_expr (e->ref->u.ss.start)
 731             && gfc_is_constant_expr (e->ref->u.ss.end));
 732       break;
 733
 734     case EXPR_STRUCTURE:
 735       rv = 0;
 736       for (c = e->value.constructor; c; c = c->next)
 737         if (!gfc_is_constant_expr (c->expr))
 738           break;
 739
 740       if (c == NULL)
 741         rv = 1;
 742       break;
 743
 744     case EXPR_ARRAY:
 745       rv = gfc_constant_ac (e);
 746       break;
 747
 748     default:
 749       gfc_internal_error ("gfc_is_constant_expr(): Unknown expression type");
 750     }
 751
 752   return rv;
 753 }
 754
 755
 756 /* Try to collapse intrinsic expressions.  */
 757
 758 static try
 759 simplify_intrinsic_op (gfc_expr * p, int type)
 760 {
 761   gfc_expr *op1, *op2, *result;
 762
 763   if (p->value.op.operator == INTRINSIC_USER)
 764     return SUCCESS;
 765
 766   op1 = p->value.op.op1;
 767   op2 = p->value.op.op2;
 768
 769   if (gfc_simplify_expr (op1, type) == FAILURE)
 770     return FAILURE;
 771   if (gfc_simplify_expr (op2, type) == FAILURE)
 772     return FAILURE;
 773
 774   if (!gfc_is_constant_expr (op1)
 775       || (op2 != NULL && !gfc_is_constant_expr (op2)))
 776     return SUCCESS;
 777
 778   /* Rip p apart */
 779   p->value.op.op1 = NULL;
 780   p->value.op.op2 = NULL;
 781
 782   switch (p->value.op.operator)
 783     {
 784     case INTRINSIC_UPLUS:
 785       result = gfc_uplus (op1);
 786       break;
 787
 788     case INTRINSIC_UMINUS:
 789       result = gfc_uminus (op1);
 790       break;
 791
 792     case INTRINSIC_PLUS:
 793       result = gfc_add (op1, op2);
 794       break;
 795
 796     case INTRINSIC_MINUS:
 797       result = gfc_subtract (op1, op2);
 798       break;
 799
 800     case INTRINSIC_TIMES:
 801       result = gfc_multiply (op1, op2);
 802       break;
 803
 804     case INTRINSIC_DIVIDE:
 805       result = gfc_divide (op1, op2);
 806       break;
 807
 808     case INTRINSIC_POWER:
 809       result = gfc_power (op1, op2);
 810       break;
 811
 812     case INTRINSIC_CONCAT:
 813       result = gfc_concat (op1, op2);
 814       break;
 815
 816     case INTRINSIC_EQ:
 817       result = gfc_eq (op1, op2);
 818       break;
 819
 820     case INTRINSIC_NE:
 821       result = gfc_ne (op1, op2);
 822       break;
 823
 824     case INTRINSIC_GT:
 825       result = gfc_gt (op1, op2);
 826       break;
 827
 828     case INTRINSIC_GE:
 829       result = gfc_ge (op1, op2);
 830       break;
 831
 832     case INTRINSIC_LT:
 833       result = gfc_lt (op1, op2);
 834       break;
 835
 836     case INTRINSIC_LE:
 837       result = gfc_le (op1, op2);
 838       break;
 839
 840     case INTRINSIC_NOT:
 841       result = gfc_not (op1);
 842       break;
 843
 844     case INTRINSIC_AND:
 845       result = gfc_and (op1, op2);
 846       break;
 847
 848     case INTRINSIC_OR:
 849       result = gfc_or (op1, op2);
 850       break;
 851
 852     case INTRINSIC_EQV:
 853       result = gfc_eqv (op1, op2);
 854       break;
 855
 856     case INTRINSIC_NEQV:
 857       result = gfc_neqv (op1, op2);
 858       break;
 859
 860     default:
 861       gfc_internal_error ("simplify_intrinsic_op(): Bad operator");
 862     }
 863
 864   if (result == NULL)
 865     {
 866       gfc_free_expr (op1);
 867       gfc_free_expr (op2);
 868       return FAILURE;
 869     }
 870
 871   gfc_replace_expr (p, result);
 872
 873   return SUCCESS;
 874 }
 875
 876
 877 /* Subroutine to simplify constructor expressions.  Mutually recursive
 878    with gfc_simplify_expr().  */
 879
 880 static try
 881 simplify_constructor (gfc_constructor * c, int type)
 882 {
 883
 884   for (; c; c = c->next)
 885     {
 886       if (c->iterator
 887           && (gfc_simplify_expr (c->iterator->start, type) == FAILURE
 888               || gfc_simplify_expr (c->iterator->end, type) == FAILURE
 889               || gfc_simplify_expr (c->iterator->step, type) == FAILURE))
 890         return FAILURE;
 891
 892       if (c->expr && gfc_simplify_expr (c->expr, type) == FAILURE)
 893         return FAILURE;
 894     }
 895
 896   return SUCCESS;
 897 }
 898
 899
 900 /* Pull a single array element out of an array constructor.  */
 901
 902 static gfc_constructor *
 903 find_array_element (gfc_constructor * cons, gfc_array_ref * ar)
 904 {
 905   unsigned long nelemen;
 906   int i;
 907   mpz_t delta;
 908   mpz_t offset;
 909
 910   mpz_init_set_ui (offset, 0);
 911   mpz_init (delta);
 912   for (i = 0; i < ar->dimen; i++)
 913     {
 914       if (ar->start[i]->expr_type != EXPR_CONSTANT)
 915         {
 916           cons = NULL;
 917           break;
 918         }
 919       mpz_sub (delta, ar->start[i]->value.integer,
 920                ar->as->lower[i]->value.integer);
 921       mpz_add (offset, offset, delta);
 922     }
 923
 924   if (cons)
 925     {
 926       if (mpz_fits_ulong_p (offset))
 927         {
 928           for (nelemen = mpz_get_ui (offset); nelemen > 0; nelemen--)
 929             {
 930               if (cons->iterator)
 931                 {
 932                   cons = NULL;
 933                   break;
 934                 }
 935               cons = cons->next;
 936             }
 937         }
 938       else
 939         cons = NULL;
 940     }
 941
 942   mpz_clear (delta);
 943   mpz_clear (offset);
 944
 945   return cons;
 946 }
 947
 948
 949 /* Find a component of a structure constructor.  */
 950
 951 static gfc_constructor *
 952 find_component_ref (gfc_constructor * cons, gfc_ref * ref)
 953 {
 954   gfc_component *comp;
 955   gfc_component *pick;
 956
 957   comp = ref->u.c.sym->components;
 958   pick = ref->u.c.component;
 959   while (comp != pick)
 960     {
 961       comp = comp->next;
 962       cons = cons->next;
 963     }
 964
 965   return cons;
 966 }
 967
 968
 969 /* Replace an expression with the contents of a constructor, removing
 970    the subobject reference in the process.  */
 971
 972 static void
 973 remove_subobject_ref (gfc_expr * p, gfc_constructor * cons)
 974 {
 975   gfc_expr *e;
 976
 977   e = cons->expr;
 978   cons->expr = NULL;
 979   e->ref = p->ref->next;
 980   p->ref->next =  NULL;
 981   gfc_replace_expr (p, e);
 982 }
 983
 984
 985 /* Simplify a subobject reference of a constructor.  This occurs when
 986    parameter variable values are substituted.  */
 987
 988 static try
 989 simplify_const_ref (gfc_expr * p)
 990 {
 991   gfc_constructor *cons;
 992
 993   while (p->ref)
 994     {
 995       switch (p->ref->type)
 996         {
 997         case REF_ARRAY:
 998           switch (p->ref->u.ar.type)
 999             {
1000             case AR_ELEMENT:
1001               cons = find_array_element (p->value.constructor, &p->ref->u.ar);
1002               if (!cons)
1003                 return SUCCESS;
1004               remove_subobject_ref (p, cons);
1005               break;
1006
1007             case AR_FULL:
1008               if (p->ref->next != NULL)
1009                 {
1010                   /* TODO: Simplify array subobject references.  */
1011                   return SUCCESS;
1012                 }
1013                 gfc_free_ref_list (p->ref);
1014                 p->ref = NULL;
1015               break;
1016
1017             default:
1018               /* TODO: Simplify array subsections.  */
1019               return SUCCESS;
1020             }
1021
1022           break;
1023
1024         case REF_COMPONENT:
1025           cons = find_component_ref (p->value.constructor, p->ref);
1026           remove_subobject_ref (p, cons);
1027           break;
1028
1029         case REF_SUBSTRING:
1030           /* TODO: Constant substrings.  */
1031           return SUCCESS;
1032         }
1033     }
1034
1035   return SUCCESS;
1036 }
1037
1038
1039 /* Simplify a chain of references.  */
1040
1041 static try
1042 simplify_ref_chain (gfc_ref * ref, int type)
1043 {
1044   int n;
1045
1046   for (; ref; ref = ref->next)
1047     {
1048       switch (ref->type)
1049         {
1050         case REF_ARRAY:
1051           for (n = 0; n < ref->u.ar.dimen; n++)
1052             {
1053               if (gfc_simplify_expr (ref->u.ar.start[n], type)
1054                     == FAILURE)
1055                 return FAILURE;
1056               if (gfc_simplify_expr (ref->u.ar.end[n], type)
1057                      == FAILURE)
1058                 return FAILURE;
1059               if (gfc_simplify_expr (ref->u.ar.stride[n], type)
1060                      == FAILURE)
1061                 return FAILURE;
1062             }
1063           break;
1064
1065         case REF_SUBSTRING:
1066           if (gfc_simplify_expr (ref->u.ss.start, type) == FAILURE)
1067             return FAILURE;
1068           if (gfc_simplify_expr (ref->u.ss.end, type) == FAILURE)
1069             return FAILURE;
1070           break;
1071
1072         default:
1073           break;
1074         }
1075     }
1076   return SUCCESS;
1077 }
1078
1079
1080 /* Try to substitute the value of a parameter variable.  */
1081 static try
1082 simplify_parameter_variable (gfc_expr * p, int type)
1083 {
1084   gfc_expr *e;
1085   try t;
1086
1087   e = gfc_copy_expr (p->symtree->n.sym->value);
1088   /* Do not copy subobject refs for constant.  */
1089   if (e->expr_type != EXPR_CONSTANT && p->ref != NULL)
1090     e->ref = copy_ref (p->ref);
1091   t = gfc_simplify_expr (e, type);
1092
1093   /* Only use the simplification if it eliminated all subobject
1094      references.  */
1095   if (t == SUCCESS && ! e->ref)
1096     gfc_replace_expr (p, e);
1097   else
1098     gfc_free_expr (e);
1099
1100   return t;
1101 }
1102
1103 /* Given an expression, simplify it by collapsing constant
1104    expressions.  Most simplification takes place when the expression
1105    tree is being constructed.  If an intrinsic function is simplified
1106    at some point, we get called again to collapse the result against
1107    other constants.
1108
1109    We work by recursively simplifying expression nodes, simplifying
1110    intrinsic functions where possible, which can lead to further
1111    constant collapsing.  If an operator has constant operand(s), we
1112    rip the expression apart, and rebuild it, hoping that it becomes
1113    something simpler.
1114
1115    The expression type is defined for:
1116      0   Basic expression parsing
1117      1   Simplifying array constructors -- will substitute
1118          iterator values.
1119    Returns FAILURE on error, SUCCESS otherwise.
1120    NOTE: Will return SUCCESS even if the expression can not be simplified.  */
1121
1122 try
1123 gfc_simplify_expr (gfc_expr * p, int type)
1124 {
1125   gfc_actual_arglist *ap;
1126
1127   if (p == NULL)
1128     return SUCCESS;
1129
1130   switch (p->expr_type)
1131     {
1132     case EXPR_CONSTANT:
1133     case EXPR_NULL:
1134       break;
1135
1136     case EXPR_FUNCTION:
1137       for (ap = p->value.function.actual; ap; ap = ap->next)
1138         if (gfc_simplify_expr (ap->expr, type) == FAILURE)
1139           return FAILURE;
1140
1141       if (p->value.function.isym != NULL
1142           && gfc_intrinsic_func_interface (p, 1) == MATCH_ERROR)
1143         return FAILURE;
1144
1145       break;
1146
1147     case EXPR_SUBSTRING:
1148       if (simplify_ref_chain (p->ref, type) == FAILURE)
1149         return FAILURE;
1150
1151       if (gfc_is_constant_expr (p))
1152         {
1153           char *s;
1154           int start, end;
1155
1156           gfc_extract_int (p->ref->u.ss.start, &start);
1157           start--;  /* Convert from one-based to zero-based.  */
1158           gfc_extract_int (p->ref->u.ss.end, &end);
1159           s = gfc_getmem (end - start + 1);
1160           memcpy (s, p->value.character.string + start, end - start);
1161           s[end] = '\0';  /* TODO: C-style string for debugging.  */
1162           gfc_free (p->value.character.string);
1163           p->value.character.string = s;
1164           p->value.character.length = end - start;
1165           p->ts.cl = gfc_get_charlen ();
1166           p->ts.cl->next = gfc_current_ns->cl_list;
1167           gfc_current_ns->cl_list = p->ts.cl;
1168           p->ts.cl->length = gfc_int_expr (p->value.character.length);
1169           gfc_free_ref_list (p->ref);
1170           p->ref = NULL;
1171           p->expr_type = EXPR_CONSTANT;
1172         }
1173       break;
1174
1175     case EXPR_OP:
1176       if (simplify_intrinsic_op (p, type) == FAILURE)
1177         return FAILURE;
1178       break;
1179
1180     case EXPR_VARIABLE:
1181       /* Only substitute array parameter variables if we are in an
1182          initialization expression, or we want a subsection.  */
1183       if (p->symtree->n.sym->attr.flavor == FL_PARAMETER
1184           && (gfc_init_expr || p->ref
1185               || p->symtree->n.sym->value->expr_type != EXPR_ARRAY))
1186         {
1187           if (simplify_parameter_variable (p, type) == FAILURE)
1188             return FAILURE;
1189           break;
1190         }
1191
1192       if (type == 1)
1193         {
1194           gfc_simplify_iterator_var (p);
1195         }
1196
1197       /* Simplify subcomponent references.  */
1198       if (simplify_ref_chain (p->ref, type) == FAILURE)
1199         return FAILURE;
1200
1201       break;
1202
1203     case EXPR_STRUCTURE:
1204     case EXPR_ARRAY:
1205       if (simplify_ref_chain (p->ref, type) == FAILURE)
1206         return FAILURE;
1207
1208       if (simplify_constructor (p->value.constructor, type) == FAILURE)
1209         return FAILURE;
1210
1211       if (p->expr_type == EXPR_ARRAY)
1212           gfc_expand_constructor (p);
1213
1214       if (simplify_const_ref (p) == FAILURE)
1215         return FAILURE;
1216
1217       break;
1218     }
1219
1220   return SUCCESS;
1221 }
1222
1223
1224 /* Returns the type of an expression with the exception that iterator
1225    variables are automatically integers no matter what else they may
1226    be declared as.  */
1227
1228 static bt
1229 et0 (gfc_expr * e)
1230 {
1231
1232   if (e->expr_type == EXPR_VARIABLE && gfc_check_iter_variable (e) == SUCCESS)
1233     return BT_INTEGER;
1234
1235   return e->ts.type;
1236 }
1237
1238
1239 /* Check an intrinsic arithmetic operation to see if it is consistent
1240    with some type of expression.  */
1241
1242 static try check_init_expr (gfc_expr *);
1243
1244 static try
1245 check_intrinsic_op (gfc_expr * e, try (*check_function) (gfc_expr *))
1246 {
1247   gfc_expr *op1 = e->value.op.op1;
1248   gfc_expr *op2 = e->value.op.op2;
1249
1250   if ((*check_function) (op1) == FAILURE)
1251     return FAILURE;
1252
1253   switch (e->value.op.operator)
1254     {
1255     case INTRINSIC_UPLUS:
1256     case INTRINSIC_UMINUS:
1257       if (!numeric_type (et0 (op1)))
1258         goto not_numeric;
1259       break;
1260
1261     case INTRINSIC_EQ:
1262     case INTRINSIC_NE:
1263     case INTRINSIC_GT:
1264     case INTRINSIC_GE:
1265     case INTRINSIC_LT:
1266     case INTRINSIC_LE:
1267       if ((*check_function) (op2) == FAILURE)
1268         return FAILURE;
1269
1270       if (!(et0 (op1) == BT_CHARACTER && et0 (op2) == BT_CHARACTER)
1271           && !(numeric_type (et0 (op1)) && numeric_type (et0 (op2))))
1272         {
1273           gfc_error ("Numeric or CHARACTER operands are required in "
1274                      "expression at %L", &e->where);
1275          return FAILURE;
1276         }
1277       break;
1278
1279     case INTRINSIC_PLUS:
1280     case INTRINSIC_MINUS:
1281     case INTRINSIC_TIMES:
1282     case INTRINSIC_DIVIDE:
1283     case INTRINSIC_POWER:
1284       if ((*check_function) (op2) == FAILURE)
1285         return FAILURE;
1286
1287       if (!numeric_type (et0 (op1)) || !numeric_type (et0 (op2)))
1288         goto not_numeric;
1289
1290       if (e->value.op.operator == INTRINSIC_POWER
1291           && check_function == check_init_expr && et0 (op2) != BT_INTEGER)
1292         {
1293           gfc_error ("Exponent at %L must be INTEGER for an initialization "
1294                      "expression", &op2->where);
1295           return FAILURE;
1296         }
1297
1298       break;
1299
1300     case INTRINSIC_CONCAT:
1301       if ((*check_function) (op2) == FAILURE)
1302         return FAILURE;
1303
1304       if (et0 (op1) != BT_CHARACTER || et0 (op2) != BT_CHARACTER)
1305         {
1306           gfc_error ("Concatenation operator in expression at %L "
1307                      "must have two CHARACTER operands", &op1->where);
1308           return FAILURE;
1309         }
1310
1311       if (op1->ts.kind != op2->ts.kind)
1312         {
1313           gfc_error ("Concat operator at %L must concatenate strings of the "
1314                      "same kind", &e->where);
1315           return FAILURE;
1316         }
1317
1318       break;
1319
1320     case INTRINSIC_NOT:
1321       if (et0 (op1) != BT_LOGICAL)
1322         {
1323           gfc_error (".NOT. operator in expression at %L must have a LOGICAL "
1324                      "operand", &op1->where);
1325           return FAILURE;
1326         }
1327
1328       break;
1329
1330     case INTRINSIC_AND:
1331     case INTRINSIC_OR:
1332     case INTRINSIC_EQV:
1333     case INTRINSIC_NEQV:
1334       if ((*check_function) (op2) == FAILURE)
1335         return FAILURE;
1336
1337       if (et0 (op1) != BT_LOGICAL || et0 (op2) != BT_LOGICAL)
1338         {
1339           gfc_error ("LOGICAL operands are required in expression at %L",
1340                      &e->where);
1341           return FAILURE;
1342         }
1343
1344       break;
1345
1346     default:
1347       gfc_error ("Only intrinsic operators can be used in expression at %L",
1348                  &e->where);
1349       return FAILURE;
1350     }
1351
1352   return SUCCESS;
1353
1354 not_numeric:
1355   gfc_error ("Numeric operands are required in expression at %L", &e->where);
1356
1357   return FAILURE;
1358 }
1359
1360
1361
1362 /* Certain inquiry functions are specifically allowed to have variable
1363    arguments, which is an exception to the normal requirement that an
1364    initialization function have initialization arguments.  We head off
1365    this problem here.  */
1366
1367 static try
1368 check_inquiry (gfc_expr * e, int not_restricted)
1369 {
1370   const char *name;
1371
1372   /* FIXME: This should be moved into the intrinsic definitions,
1373      to eliminate this ugly hack.  */
1374   static const char * const inquiry_function[] = {
1375     "digits", "epsilon", "huge", "kind", "len", "maxexponent", "minexponent",
1376     "precision", "radix", "range", "tiny", "bit_size", "size", "shape",
1377     "lbound", "ubound", NULL
1378   };
1379
1380   int i;
1381
1382   /* An undeclared parameter will get us here (PR25018).  */
1383   if (e->symtree == NULL)
1384     return FAILURE;
1385
1386   name = e->symtree->n.sym->name;
1387
1388   for (i = 0; inquiry_function[i]; i++)
1389     if (strcmp (inquiry_function[i], name) == 0)
1390       break;
1391
1392   if (inquiry_function[i] == NULL)
1393     return FAILURE;
1394
1395   e = e->value.function.actual->expr;
1396
1397   if (e == NULL || e->expr_type != EXPR_VARIABLE)
1398     return FAILURE;
1399
1400   /* At this point we have an inquiry function with a variable argument.  The
1401      type of the variable might be undefined, but we need it now, because the
1402      arguments of these functions are allowed to be undefined.  */
1403
1404   if (e->ts.type == BT_UNKNOWN)
1405     {
1406       if (e->symtree->n.sym->ts.type == BT_UNKNOWN
1407           && gfc_set_default_type (e->symtree->n.sym, 0, gfc_current_ns)
1408             == FAILURE)
1409         return FAILURE;
1410
1411       e->ts = e->symtree->n.sym->ts;
1412     }
1413
1414   /* Assumed character length will not reduce to a constant expression
1415      with LEN, as required by the standard.  */
1416   if (i == 4 && not_restricted
1417         && e->symtree->n.sym->ts.type == BT_CHARACTER
1418         && e->symtree->n.sym->ts.cl->length == NULL)
1419     gfc_notify_std (GFC_STD_GNU, "assumed character length "
1420                     "variable '%s' in constant expression at %L",
1421                     e->symtree->n.sym->name, &e->where);
1422
1423   return SUCCESS;
1424 }
1425
1426
1427 /* Verify that an expression is an initialization expression.  A side
1428    effect is that the expression tree is reduced to a single constant
1429    node if all goes well.  This would normally happen when the
1430    expression is constructed but function references are assumed to be
1431    intrinsics in the context of initialization expressions.  If
1432    FAILURE is returned an error message has been generated.  */
1433
1434 static try
1435 check_init_expr (gfc_expr * e)
1436 {
1437   gfc_actual_arglist *ap;
1438   match m;
1439   try t;
1440
1441   if (e == NULL)
1442     return SUCCESS;
1443
1444   switch (e->expr_type)
1445     {
1446     case EXPR_OP:
1447       t = check_intrinsic_op (e, check_init_expr);
1448       if (t == SUCCESS)
1449         t = gfc_simplify_expr (e, 0);
1450
1451       break;
1452
1453     case EXPR_FUNCTION:
1454       t = SUCCESS;
1455
1456       if (check_inquiry (e, 1) != SUCCESS)
1457         {
1458           t = SUCCESS;
1459           for (ap = e->value.function.actual; ap; ap = ap->next)
1460             if (check_init_expr (ap->expr) == FAILURE)
1461               {
1462                 t = FAILURE;
1463                 break;
1464               }
1465         }
1466
1467       if (t == SUCCESS)
1468         {
1469           m = gfc_intrinsic_func_interface (e, 0);
1470
1471           if (m == MATCH_NO)
1472             gfc_error ("Function '%s' in initialization expression at %L "
1473                        "must be an intrinsic function",
1474                        e->symtree->n.sym->name, &e->where);
1475
1476           if (m != MATCH_YES)
1477             t = FAILURE;
1478         }
1479
1480       break;
1481
1482     case EXPR_VARIABLE:
1483       t = SUCCESS;
1484
1485       if (gfc_check_iter_variable (e) == SUCCESS)
1486         break;
1487
1488       if (e->symtree->n.sym->attr.flavor == FL_PARAMETER)
1489         {
1490           t = simplify_parameter_variable (e, 0);
1491           break;
1492         }
1493
1494       gfc_error ("Parameter '%s' at %L has not been declared or is "
1495                  "a variable, which does not reduce to a constant "
1496                  "expression", e->symtree->n.sym->name, &e->where);
1497       t = FAILURE;
1498       break;
1499
1500     case EXPR_CONSTANT:
1501     case EXPR_NULL:
1502       t = SUCCESS;
1503       break;
1504
1505     case EXPR_SUBSTRING:
1506       t = check_init_expr (e->ref->u.ss.start);
1507       if (t == FAILURE)
1508         break;
1509
1510       t = check_init_expr (e->ref->u.ss.end);
1511       if (t == SUCCESS)
1512         t = gfc_simplify_expr (e, 0);
1513
1514       break;
1515
1516     case EXPR_STRUCTURE:
1517       t = gfc_check_constructor (e, check_init_expr);
1518       break;
1519
1520     case EXPR_ARRAY:
1521       t = gfc_check_constructor (e, check_init_expr);
1522       if (t == FAILURE)
1523         break;
1524
1525       t = gfc_expand_constructor (e);
1526       if (t == FAILURE)
1527         break;
1528
1529       t = gfc_check_constructor_type (e);
1530       break;
1531
1532     default:
1533       gfc_internal_error ("check_init_expr(): Unknown expression type");
1534     }
1535
1536   return t;
1537 }
1538
1539
1540 /* Match an initialization expression.  We work by first matching an
1541    expression, then reducing it to a constant.  */
1542
1543 match
1544 gfc_match_init_expr (gfc_expr ** result)
1545 {
1546   gfc_expr *expr;
1547   match m;
1548   try t;
1549
1550   m = gfc_match_expr (&expr);
1551   if (m != MATCH_YES)
1552     return m;
1553
1554   gfc_init_expr = 1;
1555   t = gfc_resolve_expr (expr);
1556   if (t == SUCCESS)
1557     t = check_init_expr (expr);
1558   gfc_init_expr = 0;
1559
1560   if (t == FAILURE)
1561     {
1562       gfc_free_expr (expr);
1563       return MATCH_ERROR;
1564     }
1565
1566   if (expr->expr_type == EXPR_ARRAY
1567       && (gfc_check_constructor_type (expr) == FAILURE
1568           || gfc_expand_constructor (expr) == FAILURE))
1569     {
1570       gfc_free_expr (expr);
1571       return MATCH_ERROR;
1572     }
1573
1574   /* Not all inquiry functions are simplified to constant expressions
1575      so it is necessary to call check_inquiry again.  */
1576   if (!gfc_is_constant_expr (expr)
1577         && check_inquiry (expr, 1) == FAILURE)
1578     {
1579       gfc_error ("Initialization expression didn't reduce %C");
1580       return MATCH_ERROR;
1581     }
1582
1583   *result = expr;
1584
1585   return MATCH_YES;
1586 }
1587
1588
1589
1590 static try check_restricted (gfc_expr *);
1591
1592 /* Given an actual argument list, test to see that each argument is a
1593    restricted expression and optionally if the expression type is
1594    integer or character.  */
1595
1596 static try
1597 restricted_args (gfc_actual_arglist * a)
1598 {
1599   for (; a; a = a->next)
1600     {
1601       if (check_restricted (a->expr) == FAILURE)
1602         return FAILURE;
1603     }
1604
1605   return SUCCESS;
1606 }
1607
1608
1609 /************* Restricted/specification expressions *************/
1610
1611
1612 /* Make sure a non-intrinsic function is a specification function.  */
1613
1614 static try
1615 external_spec_function (gfc_expr * e)
1616 {
1617   gfc_symbol *f;
1618
1619   f = e->value.function.esym;
1620
1621   if (f->attr.proc == PROC_ST_FUNCTION)
1622     {
1623       gfc_error ("Specification function '%s' at %L cannot be a statement "
1624                  "function", f->name, &e->where);
1625       return FAILURE;
1626     }
1627
1628   if (f->attr.proc == PROC_INTERNAL)
1629     {
1630       gfc_error ("Specification function '%s' at %L cannot be an internal "
1631                  "function", f->name, &e->where);
1632       return FAILURE;
1633     }
1634
1635   if (!f->attr.pure)
1636     {
1637       gfc_error ("Specification function '%s' at %L must be PURE", f->name,
1638                  &e->where);
1639       return FAILURE;
1640     }
1641
1642   if (f->attr.recursive)
1643     {
1644       gfc_error ("Specification function '%s' at %L cannot be RECURSIVE",
1645                  f->name, &e->where);
1646       return FAILURE;
1647     }
1648
1649   return restricted_args (e->value.function.actual);
1650 }
1651
1652
1653 /* Check to see that a function reference to an intrinsic is a
1654    restricted expression.  */
1655
1656 static try
1657 restricted_intrinsic (gfc_expr * e)
1658 {
1659   /* TODO: Check constraints on inquiry functions.  7.1.6.2 (7).  */
1660   if (check_inquiry (e, 0) == SUCCESS)
1661     return SUCCESS;
1662
1663   return restricted_args (e->value.function.actual);
1664 }
1665
1666
1667 /* Verify that an expression is a restricted expression.  Like its
1668    cousin check_init_expr(), an error message is generated if we
1669    return FAILURE.  */
1670
1671 static try
1672 check_restricted (gfc_expr * e)
1673 {
1674   gfc_symbol *sym;
1675   try t;
1676
1677   if (e == NULL)
1678     return SUCCESS;
1679
1680   switch (e->expr_type)
1681     {
1682     case EXPR_OP:
1683       t = check_intrinsic_op (e, check_restricted);
1684       if (t == SUCCESS)
1685         t = gfc_simplify_expr (e, 0);
1686
1687       break;
1688
1689     case EXPR_FUNCTION:
1690       t = e->value.function.esym ?
1691         external_spec_function (e) : restricted_intrinsic (e);
1692
1693       break;
1694
1695     case EXPR_VARIABLE:
1696       sym = e->symtree->n.sym;
1697       t = FAILURE;
1698
1699       if (sym->attr.optional)
1700         {
1701           gfc_error ("Dummy argument '%s' at %L cannot be OPTIONAL",
1702                      sym->name, &e->where);
1703           break;
1704         }
1705
1706       if (sym->attr.intent == INTENT_OUT)
1707         {
1708           gfc_error ("Dummy argument '%s' at %L cannot be INTENT(OUT)",
1709                      sym->name, &e->where);
1710           break;
1711         }
1712
1713       /* gfc_is_formal_arg broadcasts that a formal argument list is being processed
1714          in resolve.c(resolve_formal_arglist).  This is done so that host associated
1715          dummy array indices are accepted (PR23446).  */
1716       if (sym->attr.in_common
1717           || sym->attr.use_assoc
1718           || sym->attr.dummy
1719           || sym->ns != gfc_current_ns
1720           || (sym->ns->proc_name != NULL
1721               && sym->ns->proc_name->attr.flavor == FL_MODULE)
1722           || gfc_is_formal_arg ())
1723         {
1724           t = SUCCESS;
1725           break;
1726         }
1727
1728       gfc_error ("Variable '%s' cannot appear in the expression at %L",
1729                  sym->name, &e->where);
1730
1731       break;
1732
1733     case EXPR_NULL:
1734     case EXPR_CONSTANT:
1735       t = SUCCESS;
1736       break;
1737
1738     case EXPR_SUBSTRING:
1739       t = gfc_specification_expr (e->ref->u.ss.start);
1740       if (t == FAILURE)
1741         break;
1742
1743       t = gfc_specification_expr (e->ref->u.ss.end);
1744       if (t == SUCCESS)
1745         t = gfc_simplify_expr (e, 0);
1746
1747       break;
1748
1749     case EXPR_STRUCTURE:
1750       t = gfc_check_constructor (e, check_restricted);
1751       break;
1752
1753     case EXPR_ARRAY:
1754       t = gfc_check_constructor (e, check_restricted);
1755       break;
1756
1757     default:
1758       gfc_internal_error ("check_restricted(): Unknown expression type");
1759     }
1760
1761   return t;
1762 }
1763
1764
1765 /* Check to see that an expression is a specification expression.  If
1766    we return FAILURE, an error has been generated.  */
1767
1768 try
1769 gfc_specification_expr (gfc_expr * e)
1770 {
1771   if (e == NULL)
1772     return SUCCESS;
1773
1774   if (e->ts.type != BT_INTEGER)
1775     {
1776       gfc_error ("Expression at %L must be of INTEGER type", &e->where);
1777       return FAILURE;
1778     }
1779
1780   if (e->rank != 0)
1781     {
1782       gfc_error ("Expression at %L must be scalar", &e->where);
1783       return FAILURE;
1784     }
1785
1786   if (gfc_simplify_expr (e, 0) == FAILURE)
1787     return FAILURE;
1788
1789   return check_restricted (e);
1790 }
1791
1792
1793 /************** Expression conformance checks.  *************/
1794
1795 /* Given two expressions, make sure that the arrays are conformable.  */
1796
1797 try
1798 gfc_check_conformance (const char *optype_msgid,
1799                        gfc_expr * op1, gfc_expr * op2)
1800 {
1801   int op1_flag, op2_flag, d;
1802   mpz_t op1_size, op2_size;
1803   try t;
1804
1805   if (op1->rank == 0 || op2->rank == 0)
1806     return SUCCESS;
1807
1808   if (op1->rank != op2->rank)
1809     {
1810       gfc_error ("Incompatible ranks in %s at %L", _(optype_msgid),
1811                  &op1->where);
1812       return FAILURE;
1813     }
1814
1815   t = SUCCESS;
1816
1817   for (d = 0; d < op1->rank; d++)
1818     {
1819       op1_flag = gfc_array_dimen_size (op1, d, &op1_size) == SUCCESS;
1820       op2_flag = gfc_array_dimen_size (op2, d, &op2_size) == SUCCESS;
1821
1822       if (op1_flag && op2_flag && mpz_cmp (op1_size, op2_size) != 0)
1823         {
1824           gfc_error ("%s at %L has different shape on dimension %d (%d/%d)",
1825                      _(optype_msgid), &op1->where, d + 1,
1826                      (int) mpz_get_si (op1_size),
1827                      (int) mpz_get_si (op2_size));
1828
1829           t = FAILURE;
1830         }
1831
1832       if (op1_flag)
1833         mpz_clear (op1_size);
1834       if (op2_flag)
1835         mpz_clear (op2_size);
1836
1837       if (t == FAILURE)
1838         return FAILURE;
1839     }
1840
1841   return SUCCESS;
1842 }
1843
1844
1845 /* Given an assignable expression and an arbitrary expression, make
1846    sure that the assignment can take place.  */
1847
1848 try
1849 gfc_check_assign (gfc_expr * lvalue, gfc_expr * rvalue, int conform)
1850 {
1851   gfc_symbol *sym;
1852
1853   sym = lvalue->symtree->n.sym;
1854
1855   if (sym->attr.intent == INTENT_IN)
1856     {
1857       gfc_error ("Can't assign to INTENT(IN) variable '%s' at %L",
1858                  sym->name, &lvalue->where);
1859       return FAILURE;
1860     }
1861
1862   if (sym->attr.flavor == FL_PROCEDURE && sym->attr.use_assoc)
1863     {
1864       gfc_error ("'%s' in the assignment at %L cannot be an l-value "
1865                  "since it is a procedure", sym->name, &lvalue->where);
1866       return FAILURE;
1867     }
1868
1869
1870   if (rvalue->rank != 0 && lvalue->rank != rvalue->rank)
1871     {
1872       gfc_error ("Incompatible ranks %d and %d in assignment at %L",
1873                  lvalue->rank, rvalue->rank, &lvalue->where);
1874       return FAILURE;
1875     }
1876
1877   if (lvalue->ts.type == BT_UNKNOWN)
1878     {
1879       gfc_error ("Variable type is UNKNOWN in assignment at %L",
1880                  &lvalue->where);
1881       return FAILURE;
1882     }
1883
1884    if (rvalue->expr_type == EXPR_NULL)
1885      {
1886        gfc_error ("NULL appears on right-hand side in assignment at %L",
1887                   &rvalue->where);
1888        return FAILURE;
1889      }
1890
1891    if (sym->attr.cray_pointee
1892        && lvalue->ref != NULL
1893        && lvalue->ref->u.ar.type != AR_ELEMENT
1894        && lvalue->ref->u.ar.as->cp_was_assumed)
1895      {
1896        gfc_error ("Vector assignment to assumed-size Cray Pointee at %L"
1897                   " is illegal.", &lvalue->where);
1898        return FAILURE;
1899      }
1900
1901   /* This is possibly a typo: x = f() instead of x => f()  */
1902   if (gfc_option.warn_surprising
1903       && rvalue->expr_type == EXPR_FUNCTION
1904       && rvalue->symtree->n.sym->attr.pointer)
1905     gfc_warning ("POINTER valued function appears on right-hand side of "
1906                  "assignment at %L", &rvalue->where);
1907
1908   /* Check size of array assignments.  */
1909   if (lvalue->rank != 0 && rvalue->rank != 0
1910       && gfc_check_conformance ("Array assignment", lvalue, rvalue) != SUCCESS)
1911     return FAILURE;
1912
1913   if (gfc_compare_types (&lvalue->ts, &rvalue->ts))
1914     return SUCCESS;
1915
1916   if (!conform)
1917     {
1918       /* Numeric can be converted to any other numeric. And Hollerith can be
1919          converted to any other type.  */
1920       if ((gfc_numeric_ts (&lvalue->ts) && gfc_numeric_ts (&rvalue->ts))
1921           || rvalue->ts.type == BT_HOLLERITH)
1922         return SUCCESS;
1923
1924       if (lvalue->ts.type == BT_LOGICAL && rvalue->ts.type == BT_LOGICAL)
1925         return SUCCESS;
1926
1927       gfc_error ("Incompatible types in assignment at %L, %s to %s",
1928                  &rvalue->where, gfc_typename (&rvalue->ts),
1929                  gfc_typename (&lvalue->ts));
1930
1931       return FAILURE;
1932     }
1933
1934   return gfc_convert_type (rvalue, &lvalue->ts, 1);
1935 }
1936
1937
1938 /* Check that a pointer assignment is OK.  We first check lvalue, and
1939    we only check rvalue if it's not an assignment to NULL() or a
1940    NULLIFY statement.  */
1941
1942 try
1943 gfc_check_pointer_assign (gfc_expr * lvalue, gfc_expr * rvalue)
1944 {
1945   symbol_attribute attr;
1946   int is_pure;
1947
1948   if (lvalue->symtree->n.sym->ts.type == BT_UNKNOWN)
1949     {
1950       gfc_error ("Pointer assignment target is not a POINTER at %L",
1951                  &lvalue->where);
1952       return FAILURE;
1953     }
1954
1955   if (lvalue->symtree->n.sym->attr.flavor == FL_PROCEDURE
1956         && lvalue->symtree->n.sym->attr.use_assoc)
1957     {
1958       gfc_error ("'%s' in the pointer assignment at %L cannot be an "
1959                  "l-value since it is a procedure",
1960                  lvalue->symtree->n.sym->name, &lvalue->where);
1961       return FAILURE;
1962     }
1963
1964   attr = gfc_variable_attr (lvalue, NULL);
1965   if (!attr.pointer)
1966     {
1967       gfc_error ("Pointer assignment to non-POINTER at %L", &lvalue->where);
1968       return FAILURE;
1969     }
1970
1971   is_pure = gfc_pure (NULL);
1972
1973   if (is_pure && gfc_impure_variable (lvalue->symtree->n.sym))
1974     {
1975       gfc_error ("Bad pointer object in PURE procedure at %L",
1976                  &lvalue->where);
1977       return FAILURE;
1978     }
1979
1980   /* If rvalue is a NULL() or NULLIFY, we're done. Otherwise the type,
1981      kind, etc for lvalue and rvalue must match, and rvalue must be a
1982      pure variable if we're in a pure function.  */
1983   if (rvalue->expr_type == EXPR_NULL)
1984     return SUCCESS;
1985
1986   if (!gfc_compare_types (&lvalue->ts, &rvalue->ts))
1987     {
1988       gfc_error ("Different types in pointer assignment at %L",
1989                  &lvalue->where);
1990       return FAILURE;
1991     }
1992
1993   if (lvalue->ts.kind != rvalue->ts.kind)
1994     {
1995       gfc_error ("Different kind type parameters in pointer "
1996                  "assignment at %L", &lvalue->where);
1997       return FAILURE;
1998     }
1999
2000   if (lvalue->ts.type == BT_CHARACTER
2001         && lvalue->ts.cl->length && rvalue->ts.cl->length
2002         && abs (gfc_dep_compare_expr (lvalue->ts.cl->length,
2003                                       rvalue->ts.cl->length)) == 1)
2004     {
2005       gfc_error ("Different character lengths in pointer "
2006                  "assignment at %L", &lvalue->where);
2007       return FAILURE;
2008     }
2009
2010   attr = gfc_expr_attr (rvalue);
2011   if (!attr.target && !attr.pointer)
2012     {
2013       gfc_error ("Pointer assignment target is neither TARGET "
2014                  "nor POINTER at %L", &rvalue->where);
2015       return FAILURE;
2016     }
2017
2018   if (is_pure && gfc_impure_variable (rvalue->symtree->n.sym))
2019     {
2020       gfc_error ("Bad target in pointer assignment in PURE "
2021                  "procedure at %L", &rvalue->where);
2022     }
2023
2024   if (lvalue->rank != rvalue->rank)
2025     {
2026       gfc_error ("Unequal ranks %d and %d in pointer assignment at %L",
2027                  lvalue->rank, rvalue->rank, &rvalue->where);
2028       return FAILURE;
2029     }
2030
2031   if (gfc_has_vector_index (rvalue))
2032     {
2033       gfc_error ("Pointer assignment with vector subscript "
2034                  "on rhs at %L", &rvalue->where);
2035       return FAILURE;
2036     }
2037
2038   return SUCCESS;
2039 }
2040
2041
2042 /* Relative of gfc_check_assign() except that the lvalue is a single
2043    symbol.  Used for initialization assignments.  */
2044
2045 try
2046 gfc_check_assign_symbol (gfc_symbol * sym, gfc_expr * rvalue)
2047 {
2048   gfc_expr lvalue;
2049   try r;
2050
2051   memset (&lvalue, '\0', sizeof (gfc_expr));
2052
2053   lvalue.expr_type = EXPR_VARIABLE;
2054   lvalue.ts = sym->ts;
2055   if (sym->as)
2056     lvalue.rank = sym->as->rank;
2057   lvalue.symtree = (gfc_symtree *)gfc_getmem (sizeof (gfc_symtree));
2058   lvalue.symtree->n.sym = sym;
2059   lvalue.where = sym->declared_at;
2060
2061   if (sym->attr.pointer)
2062     r = gfc_check_pointer_assign (&lvalue, rvalue);
2063   else
2064     r = gfc_check_assign (&lvalue, rvalue, 1);
2065
2066   gfc_free (lvalue.symtree);
2067
2068   return r;
2069 }
2070
2071
2072 /* Get an expression for a default initializer.  */
2073
2074 gfc_expr *
2075 gfc_default_initializer (gfc_typespec *ts)
2076 {
2077   gfc_constructor *tail;
2078   gfc_expr *init;
2079   gfc_component *c;
2080
2081   init = NULL;
2082
2083   /* See if we have a default initializer.  */
2084   for (c = ts->derived->components; c; c = c->next)
2085     {
2086       if (c->initializer && init == NULL)
2087         init = gfc_get_expr ();
2088     }
2089
2090   if (init == NULL)
2091     return NULL;
2092
2093   /* Build the constructor.  */
2094   init->expr_type = EXPR_STRUCTURE;
2095   init->ts = *ts;
2096   init->where = ts->derived->declared_at;
2097   tail = NULL;
2098   for (c = ts->derived->components; c; c = c->next)
2099     {
2100       if (tail == NULL)
2101         init->value.constructor = tail = gfc_get_constructor ();
2102       else
2103         {
2104           tail->next = gfc_get_constructor ();
2105           tail = tail->next;
2106         }
2107
2108       if (c->initializer)
2109         tail->expr = gfc_copy_expr (c->initializer);
2110     }
2111   return init;
2112 }
2113
2114
2115 /* Given a symbol, create an expression node with that symbol as a
2116    variable. If the symbol is array valued, setup a reference of the
2117    whole array.  */
2118
2119 gfc_expr *
2120 gfc_get_variable_expr (gfc_symtree * var)
2121 {
2122   gfc_expr *e;
2123
2124   e = gfc_get_expr ();
2125   e->expr_type = EXPR_VARIABLE;
2126   e->symtree = var;
2127   e->ts = var->n.sym->ts;
2128
2129   if (var->n.sym->as != NULL)
2130     {
2131       e->rank = var->n.sym->as->rank;
2132       e->ref = gfc_get_ref ();
2133       e->ref->type = REF_ARRAY;
2134       e->ref->u.ar.type = AR_FULL;
2135     }
2136
2137   return e;
2138 }
2139
2140
2141 /* Traverse expr, marking all EXPR_VARIABLE symbols referenced.  */
2142
2143 void
2144 gfc_expr_set_symbols_referenced (gfc_expr * expr)
2145 {
2146   gfc_actual_arglist *arg;
2147   gfc_constructor *c;
2148   gfc_ref *ref;
2149   int i;
2150
2151   if (!expr) return;
2152
2153   switch (expr->expr_type)
2154     {
2155     case EXPR_OP:
2156       gfc_expr_set_symbols_referenced (expr->value.op.op1);
2157       gfc_expr_set_symbols_referenced (expr->value.op.op2);
2158       break;
2159
2160     case EXPR_FUNCTION:
2161       for (arg = expr->value.function.actual; arg; arg = arg->next)
2162         gfc_expr_set_symbols_referenced (arg->expr);
2163       break;
2164
2165     case EXPR_VARIABLE:
2166       gfc_set_sym_referenced (expr->symtree->n.sym);
2167       break;
2168
2169     case EXPR_CONSTANT:
2170     case EXPR_NULL:
2171     case EXPR_SUBSTRING:
2172       break;
2173
2174     case EXPR_STRUCTURE:
2175     case EXPR_ARRAY:
2176       for (c = expr->value.constructor; c; c = c->next)
2177         gfc_expr_set_symbols_referenced (c->expr);
2178       break;
2179
2180     default:
2181       gcc_unreachable ();
2182       break;
2183     }
2184
2185     for (ref = expr->ref; ref; ref = ref->next)
2186       switch (ref->type)
2187         {
2188         case REF_ARRAY:
2189           for (i = 0; i < ref->u.ar.dimen; i++)
2190             {
2191               gfc_expr_set_symbols_referenced (ref->u.ar.start[i]);
2192               gfc_expr_set_symbols_referenced (ref->u.ar.end[i]);
2193               gfc_expr_set_symbols_referenced (ref->u.ar.stride[i]);
2194             }
2195           break;
2196
2197         case REF_COMPONENT:
2198           break;
2199
2200         case REF_SUBSTRING:
2201           gfc_expr_set_symbols_referenced (ref->u.ss.start);
2202           gfc_expr_set_symbols_referenced (ref->u.ss.end);
2203           break;
2204
2205         default:
2206           gcc_unreachable ();
2207           break;
2208         }
2209 }