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     case INTRINSIC_PARENTHESES:
 786       result = gfc_uplus (op1);
 787       break;
 788
 789     case INTRINSIC_UMINUS:
 790       result = gfc_uminus (op1);
 791       break;
 792
 793     case INTRINSIC_PLUS:
 794       result = gfc_add (op1, op2);
 795       break;
 796
 797     case INTRINSIC_MINUS:
 798       result = gfc_subtract (op1, op2);
 799       break;
 800
 801     case INTRINSIC_TIMES:
 802       result = gfc_multiply (op1, op2);
 803       break;
 804
 805     case INTRINSIC_DIVIDE:
 806       result = gfc_divide (op1, op2);
 807       break;
 808
 809     case INTRINSIC_POWER:
 810       result = gfc_power (op1, op2);
 811       break;
 812
 813     case INTRINSIC_CONCAT:
 814       result = gfc_concat (op1, op2);
 815       break;
 816
 817     case INTRINSIC_EQ:
 818       result = gfc_eq (op1, op2);
 819       break;
 820
 821     case INTRINSIC_NE:
 822       result = gfc_ne (op1, op2);
 823       break;
 824
 825     case INTRINSIC_GT:
 826       result = gfc_gt (op1, op2);
 827       break;
 828
 829     case INTRINSIC_GE:
 830       result = gfc_ge (op1, op2);
 831       break;
 832
 833     case INTRINSIC_LT:
 834       result = gfc_lt (op1, op2);
 835       break;
 836
 837     case INTRINSIC_LE:
 838       result = gfc_le (op1, op2);
 839       break;
 840
 841     case INTRINSIC_NOT:
 842       result = gfc_not (op1);
 843       break;
 844
 845     case INTRINSIC_AND:
 846       result = gfc_and (op1, op2);
 847       break;
 848
 849     case INTRINSIC_OR:
 850       result = gfc_or (op1, op2);
 851       break;
 852
 853     case INTRINSIC_EQV:
 854       result = gfc_eqv (op1, op2);
 855       break;
 856
 857     case INTRINSIC_NEQV:
 858       result = gfc_neqv (op1, op2);
 859       break;
 860
 861     default:
 862       gfc_internal_error ("simplify_intrinsic_op(): Bad operator");
 863     }
 864
 865   if (result == NULL)
 866     {
 867       gfc_free_expr (op1);
 868       gfc_free_expr (op2);
 869       return FAILURE;
 870     }
 871
 872   gfc_replace_expr (p, result);
 873
 874   return SUCCESS;
 875 }
 876
 877
 878 /* Subroutine to simplify constructor expressions.  Mutually recursive
 879    with gfc_simplify_expr().  */
 880
 881 static try
 882 simplify_constructor (gfc_constructor * c, int type)
 883 {
 884
 885   for (; c; c = c->next)
 886     {
 887       if (c->iterator
 888           && (gfc_simplify_expr (c->iterator->start, type) == FAILURE
 889               || gfc_simplify_expr (c->iterator->end, type) == FAILURE
 890               || gfc_simplify_expr (c->iterator->step, type) == FAILURE))
 891         return FAILURE;
 892
 893       if (c->expr && gfc_simplify_expr (c->expr, type) == FAILURE)
 894         return FAILURE;
 895     }
 896
 897   return SUCCESS;
 898 }
 899
 900
 901 /* Pull a single array element out of an array constructor.  */
 902
 903 static gfc_constructor *
 904 find_array_element (gfc_constructor * cons, gfc_array_ref * ar)
 905 {
 906   unsigned long nelemen;
 907   int i;
 908   mpz_t delta;
 909   mpz_t offset;
 910
 911   mpz_init_set_ui (offset, 0);
 912   mpz_init (delta);
 913   for (i = 0; i < ar->dimen; i++)
 914     {
 915       if (ar->start[i]->expr_type != EXPR_CONSTANT)
 916         {
 917           cons = NULL;
 918           break;
 919         }
 920       mpz_sub (delta, ar->start[i]->value.integer,
 921                ar->as->lower[i]->value.integer);
 922       mpz_add (offset, offset, delta);
 923     }
 924
 925   if (cons)
 926     {
 927       if (mpz_fits_ulong_p (offset))
 928         {
 929           for (nelemen = mpz_get_ui (offset); nelemen > 0; nelemen--)
 930             {
 931               if (cons->iterator)
 932                 {
 933                   cons = NULL;
 934                   break;
 935                 }
 936               cons = cons->next;
 937             }
 938         }
 939       else
 940         cons = NULL;
 941     }
 942
 943   mpz_clear (delta);
 944   mpz_clear (offset);
 945
 946   return cons;
 947 }
 948
 949
 950 /* Find a component of a structure constructor.  */
 951
 952 static gfc_constructor *
 953 find_component_ref (gfc_constructor * cons, gfc_ref * ref)
 954 {
 955   gfc_component *comp;
 956   gfc_component *pick;
 957
 958   comp = ref->u.c.sym->components;
 959   pick = ref->u.c.component;
 960   while (comp != pick)
 961     {
 962       comp = comp->next;
 963       cons = cons->next;
 964     }
 965
 966   return cons;
 967 }
 968
 969
 970 /* Replace an expression with the contents of a constructor, removing
 971    the subobject reference in the process.  */
 972
 973 static void
 974 remove_subobject_ref (gfc_expr * p, gfc_constructor * cons)
 975 {
 976   gfc_expr *e;
 977
 978   e = cons->expr;
 979   cons->expr = NULL;
 980   e->ref = p->ref->next;
 981   p->ref->next =  NULL;
 982   gfc_replace_expr (p, e);
 983 }
 984
 985
 986 /* Simplify a subobject reference of a constructor.  This occurs when
 987    parameter variable values are substituted.  */
 988
 989 static try
 990 simplify_const_ref (gfc_expr * p)
 991 {
 992   gfc_constructor *cons;
 993
 994   while (p->ref)
 995     {
 996       switch (p->ref->type)
 997         {
 998         case REF_ARRAY:
 999           switch (p->ref->u.ar.type)
1000             {
1001             case AR_ELEMENT:
1002               cons = find_array_element (p->value.constructor, &p->ref->u.ar);
1003               if (!cons)
1004                 return SUCCESS;
1005               remove_subobject_ref (p, cons);
1006               break;
1007
1008             case AR_FULL:
1009               if (p->ref->next != NULL)
1010                 {
1011                   /* TODO: Simplify array subobject references.  */
1012                   return SUCCESS;
1013                 }
1014                 gfc_free_ref_list (p->ref);
1015                 p->ref = NULL;
1016               break;
1017
1018             default:
1019               /* TODO: Simplify array subsections.  */
1020               return SUCCESS;
1021             }
1022
1023           break;
1024
1025         case REF_COMPONENT:
1026           cons = find_component_ref (p->value.constructor, p->ref);
1027           remove_subobject_ref (p, cons);
1028           break;
1029
1030         case REF_SUBSTRING:
1031           /* TODO: Constant substrings.  */
1032           return SUCCESS;
1033         }
1034     }
1035
1036   return SUCCESS;
1037 }
1038
1039
1040 /* Simplify a chain of references.  */
1041
1042 static try
1043 simplify_ref_chain (gfc_ref * ref, int type)
1044 {
1045   int n;
1046
1047   for (; ref; ref = ref->next)
1048     {
1049       switch (ref->type)
1050         {
1051         case REF_ARRAY:
1052           for (n = 0; n < ref->u.ar.dimen; n++)
1053             {
1054               if (gfc_simplify_expr (ref->u.ar.start[n], type)
1055                     == FAILURE)
1056                 return FAILURE;
1057               if (gfc_simplify_expr (ref->u.ar.end[n], type)
1058                      == FAILURE)
1059                 return FAILURE;
1060               if (gfc_simplify_expr (ref->u.ar.stride[n], type)
1061                      == FAILURE)
1062                 return FAILURE;
1063             }
1064           break;
1065
1066         case REF_SUBSTRING:
1067           if (gfc_simplify_expr (ref->u.ss.start, type) == FAILURE)
1068             return FAILURE;
1069           if (gfc_simplify_expr (ref->u.ss.end, type) == FAILURE)
1070             return FAILURE;
1071           break;
1072
1073         default:
1074           break;
1075         }
1076     }
1077   return SUCCESS;
1078 }
1079
1080
1081 /* Try to substitute the value of a parameter variable.  */
1082 static try
1083 simplify_parameter_variable (gfc_expr * p, int type)
1084 {
1085   gfc_expr *e;
1086   try t;
1087
1088   e = gfc_copy_expr (p->symtree->n.sym->value);
1089   /* Do not copy subobject refs for constant.  */
1090   if (e->expr_type != EXPR_CONSTANT && p->ref != NULL)
1091     e->ref = copy_ref (p->ref);
1092   t = gfc_simplify_expr (e, type);
1093
1094   /* Only use the simplification if it eliminated all subobject
1095      references.  */
1096   if (t == SUCCESS && ! e->ref)
1097     gfc_replace_expr (p, e);
1098   else
1099     gfc_free_expr (e);
1100
1101   return t;
1102 }
1103
1104 /* Given an expression, simplify it by collapsing constant
1105    expressions.  Most simplification takes place when the expression
1106    tree is being constructed.  If an intrinsic function is simplified
1107    at some point, we get called again to collapse the result against
1108    other constants.
1109
1110    We work by recursively simplifying expression nodes, simplifying
1111    intrinsic functions where possible, which can lead to further
1112    constant collapsing.  If an operator has constant operand(s), we
1113    rip the expression apart, and rebuild it, hoping that it becomes
1114    something simpler.
1115
1116    The expression type is defined for:
1117      0   Basic expression parsing
1118      1   Simplifying array constructors -- will substitute
1119          iterator values.
1120    Returns FAILURE on error, SUCCESS otherwise.
1121    NOTE: Will return SUCCESS even if the expression can not be simplified.  */
1122
1123 try
1124 gfc_simplify_expr (gfc_expr * p, int type)
1125 {
1126   gfc_actual_arglist *ap;
1127
1128   if (p == NULL)
1129     return SUCCESS;
1130
1131   switch (p->expr_type)
1132     {
1133     case EXPR_CONSTANT:
1134     case EXPR_NULL:
1135       break;
1136
1137     case EXPR_FUNCTION:
1138       for (ap = p->value.function.actual; ap; ap = ap->next)
1139         if (gfc_simplify_expr (ap->expr, type) == FAILURE)
1140           return FAILURE;
1141
1142       if (p->value.function.isym != NULL
1143           && gfc_intrinsic_func_interface (p, 1) == MATCH_ERROR)
1144         return FAILURE;
1145
1146       break;
1147
1148     case EXPR_SUBSTRING:
1149       if (simplify_ref_chain (p->ref, type) == FAILURE)
1150         return FAILURE;
1151
1152       if (gfc_is_constant_expr (p))
1153         {
1154           char *s;
1155           int start, end;
1156
1157           gfc_extract_int (p->ref->u.ss.start, &start);
1158           start--;  /* Convert from one-based to zero-based.  */
1159           gfc_extract_int (p->ref->u.ss.end, &end);
1160           s = gfc_getmem (end - start + 1);
1161           memcpy (s, p->value.character.string + start, end - start);
1162           s[end] = '\0';  /* TODO: C-style string for debugging.  */
1163           gfc_free (p->value.character.string);
1164           p->value.character.string = s;
1165           p->value.character.length = end - start;
1166           p->ts.cl = gfc_get_charlen ();
1167           p->ts.cl->next = gfc_current_ns->cl_list;
1168           gfc_current_ns->cl_list = p->ts.cl;
1169           p->ts.cl->length = gfc_int_expr (p->value.character.length);
1170           gfc_free_ref_list (p->ref);
1171           p->ref = NULL;
1172           p->expr_type = EXPR_CONSTANT;
1173         }
1174       break;
1175
1176     case EXPR_OP:
1177       if (simplify_intrinsic_op (p, type) == FAILURE)
1178         return FAILURE;
1179       break;
1180
1181     case EXPR_VARIABLE:
1182       /* Only substitute array parameter variables if we are in an
1183          initialization expression, or we want a subsection.  */
1184       if (p->symtree->n.sym->attr.flavor == FL_PARAMETER
1185           && (gfc_init_expr || p->ref
1186               || p->symtree->n.sym->value->expr_type != EXPR_ARRAY))
1187         {
1188           if (simplify_parameter_variable (p, type) == FAILURE)
1189             return FAILURE;
1190           break;
1191         }
1192
1193       if (type == 1)
1194         {
1195           gfc_simplify_iterator_var (p);
1196         }
1197
1198       /* Simplify subcomponent references.  */
1199       if (simplify_ref_chain (p->ref, type) == FAILURE)
1200         return FAILURE;
1201
1202       break;
1203
1204     case EXPR_STRUCTURE:
1205     case EXPR_ARRAY:
1206       if (simplify_ref_chain (p->ref, type) == FAILURE)
1207         return FAILURE;
1208
1209       if (simplify_constructor (p->value.constructor, type) == FAILURE)
1210         return FAILURE;
1211
1212       if (p->expr_type == EXPR_ARRAY)
1213           gfc_expand_constructor (p);
1214
1215       if (simplify_const_ref (p) == FAILURE)
1216         return FAILURE;
1217
1218       break;
1219     }
1220
1221   return SUCCESS;
1222 }
1223
1224
1225 /* Returns the type of an expression with the exception that iterator
1226    variables are automatically integers no matter what else they may
1227    be declared as.  */
1228
1229 static bt
1230 et0 (gfc_expr * e)
1231 {
1232
1233   if (e->expr_type == EXPR_VARIABLE && gfc_check_iter_variable (e) == SUCCESS)
1234     return BT_INTEGER;
1235
1236   return e->ts.type;
1237 }
1238
1239
1240 /* Check an intrinsic arithmetic operation to see if it is consistent
1241    with some type of expression.  */
1242
1243 static try check_init_expr (gfc_expr *);
1244
1245 static try
1246 check_intrinsic_op (gfc_expr * e, try (*check_function) (gfc_expr *))
1247 {
1248   gfc_expr *op1 = e->value.op.op1;
1249   gfc_expr *op2 = e->value.op.op2;
1250
1251   if ((*check_function) (op1) == FAILURE)
1252     return FAILURE;
1253
1254   switch (e->value.op.operator)
1255     {
1256     case INTRINSIC_UPLUS:
1257     case INTRINSIC_UMINUS:
1258       if (!numeric_type (et0 (op1)))
1259         goto not_numeric;
1260       break;
1261
1262     case INTRINSIC_EQ:
1263     case INTRINSIC_NE:
1264     case INTRINSIC_GT:
1265     case INTRINSIC_GE:
1266     case INTRINSIC_LT:
1267     case INTRINSIC_LE:
1268       if ((*check_function) (op2) == FAILURE)
1269         return FAILURE;
1270
1271       if (!(et0 (op1) == BT_CHARACTER && et0 (op2) == BT_CHARACTER)
1272           && !(numeric_type (et0 (op1)) && numeric_type (et0 (op2))))
1273         {
1274           gfc_error ("Numeric or CHARACTER operands are required in "
1275                      "expression at %L", &e->where);
1276          return FAILURE;
1277         }
1278       break;
1279
1280     case INTRINSIC_PLUS:
1281     case INTRINSIC_MINUS:
1282     case INTRINSIC_TIMES:
1283     case INTRINSIC_DIVIDE:
1284     case INTRINSIC_POWER:
1285       if ((*check_function) (op2) == FAILURE)
1286         return FAILURE;
1287
1288       if (!numeric_type (et0 (op1)) || !numeric_type (et0 (op2)))
1289         goto not_numeric;
1290
1291       if (e->value.op.operator == INTRINSIC_POWER
1292           && check_function == check_init_expr && et0 (op2) != BT_INTEGER)
1293         {
1294           gfc_error ("Exponent at %L must be INTEGER for an initialization "
1295                      "expression", &op2->where);
1296           return FAILURE;
1297         }
1298
1299       break;
1300
1301     case INTRINSIC_CONCAT:
1302       if ((*check_function) (op2) == FAILURE)
1303         return FAILURE;
1304
1305       if (et0 (op1) != BT_CHARACTER || et0 (op2) != BT_CHARACTER)
1306         {
1307           gfc_error ("Concatenation operator in expression at %L "
1308                      "must have two CHARACTER operands", &op1->where);
1309           return FAILURE;
1310         }
1311
1312       if (op1->ts.kind != op2->ts.kind)
1313         {
1314           gfc_error ("Concat operator at %L must concatenate strings of the "
1315                      "same kind", &e->where);
1316           return FAILURE;
1317         }
1318
1319       break;
1320
1321     case INTRINSIC_NOT:
1322       if (et0 (op1) != BT_LOGICAL)
1323         {
1324           gfc_error (".NOT. operator in expression at %L must have a LOGICAL "
1325                      "operand", &op1->where);
1326           return FAILURE;
1327         }
1328
1329       break;
1330
1331     case INTRINSIC_AND:
1332     case INTRINSIC_OR:
1333     case INTRINSIC_EQV:
1334     case INTRINSIC_NEQV:
1335       if ((*check_function) (op2) == FAILURE)
1336         return FAILURE;
1337
1338       if (et0 (op1) != BT_LOGICAL || et0 (op2) != BT_LOGICAL)
1339         {
1340           gfc_error ("LOGICAL operands are required in expression at %L",
1341                      &e->where);
1342           return FAILURE;
1343         }
1344
1345       break;
1346
1347     case INTRINSIC_PARENTHESES:
1348       break;
1349
1350     default:
1351       gfc_error ("Only intrinsic operators can be used in expression at %L",
1352                  &e->where);
1353       return FAILURE;
1354     }
1355
1356   return SUCCESS;
1357
1358 not_numeric:
1359   gfc_error ("Numeric operands are required in expression at %L", &e->where);
1360
1361   return FAILURE;
1362 }
1363
1364
1365
1366 /* Certain inquiry functions are specifically allowed to have variable
1367    arguments, which is an exception to the normal requirement that an
1368    initialization function have initialization arguments.  We head off
1369    this problem here.  */
1370
1371 static try
1372 check_inquiry (gfc_expr * e, int not_restricted)
1373 {
1374   const char *name;
1375
1376   /* FIXME: This should be moved into the intrinsic definitions,
1377      to eliminate this ugly hack.  */
1378   static const char * const inquiry_function[] = {
1379     "digits", "epsilon", "huge", "kind", "len", "maxexponent", "minexponent",
1380     "precision", "radix", "range", "tiny", "bit_size", "size", "shape",
1381     "lbound", "ubound", NULL
1382   };
1383
1384   int i;
1385
1386   /* An undeclared parameter will get us here (PR25018).  */
1387   if (e->symtree == NULL)
1388     return FAILURE;
1389
1390   name = e->symtree->n.sym->name;
1391
1392   for (i = 0; inquiry_function[i]; i++)
1393     if (strcmp (inquiry_function[i], name) == 0)
1394       break;
1395
1396   if (inquiry_function[i] == NULL)
1397     return FAILURE;
1398
1399   e = e->value.function.actual->expr;
1400
1401   if (e == NULL || e->expr_type != EXPR_VARIABLE)
1402     return FAILURE;
1403
1404   /* At this point we have an inquiry function with a variable argument.  The
1405      type of the variable might be undefined, but we need it now, because the
1406      arguments of these functions are allowed to be undefined.  */
1407
1408   if (e->ts.type == BT_UNKNOWN)
1409     {
1410       if (e->symtree->n.sym->ts.type == BT_UNKNOWN
1411           && gfc_set_default_type (e->symtree->n.sym, 0, gfc_current_ns)
1412             == FAILURE)
1413         return FAILURE;
1414
1415       e->ts = e->symtree->n.sym->ts;
1416     }
1417
1418   /* Assumed character length will not reduce to a constant expression
1419      with LEN, as required by the standard.  */
1420   if (i == 4 && not_restricted
1421         && e->symtree->n.sym->ts.type == BT_CHARACTER
1422         && e->symtree->n.sym->ts.cl->length == NULL)
1423     gfc_notify_std (GFC_STD_GNU, "assumed character length "
1424                     "variable '%s' in constant expression at %L",
1425                     e->symtree->n.sym->name, &e->where);
1426
1427   return SUCCESS;
1428 }
1429
1430
1431 /* Verify that an expression is an initialization expression.  A side
1432    effect is that the expression tree is reduced to a single constant
1433    node if all goes well.  This would normally happen when the
1434    expression is constructed but function references are assumed to be
1435    intrinsics in the context of initialization expressions.  If
1436    FAILURE is returned an error message has been generated.  */
1437
1438 static try
1439 check_init_expr (gfc_expr * e)
1440 {
1441   gfc_actual_arglist *ap;
1442   match m;
1443   try t;
1444
1445   if (e == NULL)
1446     return SUCCESS;
1447
1448   switch (e->expr_type)
1449     {
1450     case EXPR_OP:
1451       t = check_intrinsic_op (e, check_init_expr);
1452       if (t == SUCCESS)
1453         t = gfc_simplify_expr (e, 0);
1454
1455       break;
1456
1457     case EXPR_FUNCTION:
1458       t = SUCCESS;
1459
1460       if (check_inquiry (e, 1) != SUCCESS)
1461         {
1462           t = SUCCESS;
1463           for (ap = e->value.function.actual; ap; ap = ap->next)
1464             if (check_init_expr (ap->expr) == FAILURE)
1465               {
1466                 t = FAILURE;
1467                 break;
1468               }
1469         }
1470
1471       if (t == SUCCESS)
1472         {
1473           m = gfc_intrinsic_func_interface (e, 0);
1474
1475           if (m == MATCH_NO)
1476             gfc_error ("Function '%s' in initialization expression at %L "
1477                        "must be an intrinsic function",
1478                        e->symtree->n.sym->name, &e->where);
1479
1480           if (m != MATCH_YES)
1481             t = FAILURE;
1482         }
1483
1484       break;
1485
1486     case EXPR_VARIABLE:
1487       t = SUCCESS;
1488
1489       if (gfc_check_iter_variable (e) == SUCCESS)
1490         break;
1491
1492       if (e->symtree->n.sym->attr.flavor == FL_PARAMETER)
1493         {
1494           t = simplify_parameter_variable (e, 0);
1495           break;
1496         }
1497
1498       gfc_error ("Parameter '%s' at %L has not been declared or is "
1499                  "a variable, which does not reduce to a constant "
1500                  "expression", e->symtree->n.sym->name, &e->where);
1501       t = FAILURE;
1502       break;
1503
1504     case EXPR_CONSTANT:
1505     case EXPR_NULL:
1506       t = SUCCESS;
1507       break;
1508
1509     case EXPR_SUBSTRING:
1510       t = check_init_expr (e->ref->u.ss.start);
1511       if (t == FAILURE)
1512         break;
1513
1514       t = check_init_expr (e->ref->u.ss.end);
1515       if (t == SUCCESS)
1516         t = gfc_simplify_expr (e, 0);
1517
1518       break;
1519
1520     case EXPR_STRUCTURE:
1521       t = gfc_check_constructor (e, check_init_expr);
1522       break;
1523
1524     case EXPR_ARRAY:
1525       t = gfc_check_constructor (e, check_init_expr);
1526       if (t == FAILURE)
1527         break;
1528
1529       t = gfc_expand_constructor (e);
1530       if (t == FAILURE)
1531         break;
1532
1533       t = gfc_check_constructor_type (e);
1534       break;
1535
1536     default:
1537       gfc_internal_error ("check_init_expr(): Unknown expression type");
1538     }
1539
1540   return t;
1541 }
1542
1543
1544 /* Match an initialization expression.  We work by first matching an
1545    expression, then reducing it to a constant.  */
1546
1547 match
1548 gfc_match_init_expr (gfc_expr ** result)
1549 {
1550   gfc_expr *expr;
1551   match m;
1552   try t;
1553
1554   m = gfc_match_expr (&expr);
1555   if (m != MATCH_YES)
1556     return m;
1557
1558   gfc_init_expr = 1;
1559   t = gfc_resolve_expr (expr);
1560   if (t == SUCCESS)
1561     t = check_init_expr (expr);
1562   gfc_init_expr = 0;
1563
1564   if (t == FAILURE)
1565     {
1566       gfc_free_expr (expr);
1567       return MATCH_ERROR;
1568     }
1569
1570   if (expr->expr_type == EXPR_ARRAY
1571       && (gfc_check_constructor_type (expr) == FAILURE
1572           || gfc_expand_constructor (expr) == FAILURE))
1573     {
1574       gfc_free_expr (expr);
1575       return MATCH_ERROR;
1576     }
1577
1578   /* Not all inquiry functions are simplified to constant expressions
1579      so it is necessary to call check_inquiry again.  */
1580   if (!gfc_is_constant_expr (expr)
1581         && check_inquiry (expr, 1) == FAILURE)
1582     {
1583       gfc_error ("Initialization expression didn't reduce %C");
1584       return MATCH_ERROR;
1585     }
1586
1587   *result = expr;
1588
1589   return MATCH_YES;
1590 }
1591
1592
1593
1594 static try check_restricted (gfc_expr *);
1595
1596 /* Given an actual argument list, test to see that each argument is a
1597    restricted expression and optionally if the expression type is
1598    integer or character.  */
1599
1600 static try
1601 restricted_args (gfc_actual_arglist * a)
1602 {
1603   for (; a; a = a->next)
1604     {
1605       if (check_restricted (a->expr) == FAILURE)
1606         return FAILURE;
1607     }
1608
1609   return SUCCESS;
1610 }
1611
1612
1613 /************* Restricted/specification expressions *************/
1614
1615
1616 /* Make sure a non-intrinsic function is a specification function.  */
1617
1618 static try
1619 external_spec_function (gfc_expr * e)
1620 {
1621   gfc_symbol *f;
1622
1623   f = e->value.function.esym;
1624
1625   if (f->attr.proc == PROC_ST_FUNCTION)
1626     {
1627       gfc_error ("Specification function '%s' at %L cannot be a statement "
1628                  "function", f->name, &e->where);
1629       return FAILURE;
1630     }
1631
1632   if (f->attr.proc == PROC_INTERNAL)
1633     {
1634       gfc_error ("Specification function '%s' at %L cannot be an internal "
1635                  "function", f->name, &e->where);
1636       return FAILURE;
1637     }
1638
1639   if (!f->attr.pure && !f->attr.elemental)
1640     {
1641       gfc_error ("Specification function '%s' at %L must be PURE", f->name,
1642                  &e->where);
1643       return FAILURE;
1644     }
1645
1646   if (f->attr.recursive)
1647     {
1648       gfc_error ("Specification function '%s' at %L cannot be RECURSIVE",
1649                  f->name, &e->where);
1650       return FAILURE;
1651     }
1652
1653   return restricted_args (e->value.function.actual);
1654 }
1655
1656
1657 /* Check to see that a function reference to an intrinsic is a
1658    restricted expression.  */
1659
1660 static try
1661 restricted_intrinsic (gfc_expr * e)
1662 {
1663   /* TODO: Check constraints on inquiry functions.  7.1.6.2 (7).  */
1664   if (check_inquiry (e, 0) == SUCCESS)
1665     return SUCCESS;
1666
1667   return restricted_args (e->value.function.actual);
1668 }
1669
1670
1671 /* Verify that an expression is a restricted expression.  Like its
1672    cousin check_init_expr(), an error message is generated if we
1673    return FAILURE.  */
1674
1675 static try
1676 check_restricted (gfc_expr * e)
1677 {
1678   gfc_symbol *sym;
1679   try t;
1680
1681   if (e == NULL)
1682     return SUCCESS;
1683
1684   switch (e->expr_type)
1685     {
1686     case EXPR_OP:
1687       t = check_intrinsic_op (e, check_restricted);
1688       if (t == SUCCESS)
1689         t = gfc_simplify_expr (e, 0);
1690
1691       break;
1692
1693     case EXPR_FUNCTION:
1694       t = e->value.function.esym ?
1695         external_spec_function (e) : restricted_intrinsic (e);
1696
1697       break;
1698
1699     case EXPR_VARIABLE:
1700       sym = e->symtree->n.sym;
1701       t = FAILURE;
1702
1703       if (sym->attr.optional)
1704         {
1705           gfc_error ("Dummy argument '%s' at %L cannot be OPTIONAL",
1706                      sym->name, &e->where);
1707           break;
1708         }
1709
1710       if (sym->attr.intent == INTENT_OUT)
1711         {
1712           gfc_error ("Dummy argument '%s' at %L cannot be INTENT(OUT)",
1713                      sym->name, &e->where);
1714           break;
1715         }
1716
1717       /* gfc_is_formal_arg broadcasts that a formal argument list is being processed
1718          in resolve.c(resolve_formal_arglist).  This is done so that host associated
1719          dummy array indices are accepted (PR23446).  */
1720       if (sym->attr.in_common
1721           || sym->attr.use_assoc
1722           || sym->attr.dummy
1723           || sym->ns != gfc_current_ns
1724           || (sym->ns->proc_name != NULL
1725               && sym->ns->proc_name->attr.flavor == FL_MODULE)
1726           || gfc_is_formal_arg ())
1727         {
1728           t = SUCCESS;
1729           break;
1730         }
1731
1732       gfc_error ("Variable '%s' cannot appear in the expression at %L",
1733                  sym->name, &e->where);
1734
1735       break;
1736
1737     case EXPR_NULL:
1738     case EXPR_CONSTANT:
1739       t = SUCCESS;
1740       break;
1741
1742     case EXPR_SUBSTRING:
1743       t = gfc_specification_expr (e->ref->u.ss.start);
1744       if (t == FAILURE)
1745         break;
1746
1747       t = gfc_specification_expr (e->ref->u.ss.end);
1748       if (t == SUCCESS)
1749         t = gfc_simplify_expr (e, 0);
1750
1751       break;
1752
1753     case EXPR_STRUCTURE:
1754       t = gfc_check_constructor (e, check_restricted);
1755       break;
1756
1757     case EXPR_ARRAY:
1758       t = gfc_check_constructor (e, check_restricted);
1759       break;
1760
1761     default:
1762       gfc_internal_error ("check_restricted(): Unknown expression type");
1763     }
1764
1765   return t;
1766 }
1767
1768
1769 /* Check to see that an expression is a specification expression.  If
1770    we return FAILURE, an error has been generated.  */
1771
1772 try
1773 gfc_specification_expr (gfc_expr * e)
1774 {
1775   if (e == NULL)
1776     return SUCCESS;
1777
1778   if (e->ts.type != BT_INTEGER)
1779     {
1780       gfc_error ("Expression at %L must be of INTEGER type", &e->where);
1781       return FAILURE;
1782     }
1783
1784   if (e->rank != 0)
1785     {
1786       gfc_error ("Expression at %L must be scalar", &e->where);
1787       return FAILURE;
1788     }
1789
1790   if (gfc_simplify_expr (e, 0) == FAILURE)
1791     return FAILURE;
1792
1793   return check_restricted (e);
1794 }
1795
1796
1797 /************** Expression conformance checks.  *************/
1798
1799 /* Given two expressions, make sure that the arrays are conformable.  */
1800
1801 try
1802 gfc_check_conformance (const char *optype_msgid,
1803                        gfc_expr * op1, gfc_expr * op2)
1804 {
1805   int op1_flag, op2_flag, d;
1806   mpz_t op1_size, op2_size;
1807   try t;
1808
1809   if (op1->rank == 0 || op2->rank == 0)
1810     return SUCCESS;
1811
1812   if (op1->rank != op2->rank)
1813     {
1814       gfc_error ("Incompatible ranks in %s at %L", _(optype_msgid),
1815                  &op1->where);
1816       return FAILURE;
1817     }
1818
1819   t = SUCCESS;
1820
1821   for (d = 0; d < op1->rank; d++)
1822     {
1823       op1_flag = gfc_array_dimen_size (op1, d, &op1_size) == SUCCESS;
1824       op2_flag = gfc_array_dimen_size (op2, d, &op2_size) == SUCCESS;
1825
1826       if (op1_flag && op2_flag && mpz_cmp (op1_size, op2_size) != 0)
1827         {
1828           gfc_error ("different shape for %s at %L on dimension %d (%d/%d)",
1829                      _(optype_msgid), &op1->where, d + 1,
1830                      (int) mpz_get_si (op1_size),
1831                      (int) mpz_get_si (op2_size));
1832
1833           t = FAILURE;
1834         }
1835
1836       if (op1_flag)
1837         mpz_clear (op1_size);
1838       if (op2_flag)
1839         mpz_clear (op2_size);
1840
1841       if (t == FAILURE)
1842         return FAILURE;
1843     }
1844
1845   return SUCCESS;
1846 }
1847
1848
1849 /* Given an assignable expression and an arbitrary expression, make
1850    sure that the assignment can take place.  */
1851
1852 try
1853 gfc_check_assign (gfc_expr * lvalue, gfc_expr * rvalue, int conform)
1854 {
1855   gfc_symbol *sym;
1856
1857   sym = lvalue->symtree->n.sym;
1858
1859   if (sym->attr.intent == INTENT_IN)
1860     {
1861       gfc_error ("Can't assign to INTENT(IN) variable '%s' at %L",
1862                  sym->name, &lvalue->where);
1863       return FAILURE;
1864     }
1865
1866   if (sym->attr.flavor == FL_PROCEDURE && sym->attr.use_assoc)
1867     {
1868       gfc_error ("'%s' in the assignment at %L cannot be an l-value "
1869                  "since it is a procedure", sym->name, &lvalue->where);
1870       return FAILURE;
1871     }
1872
1873
1874   if (rvalue->rank != 0 && lvalue->rank != rvalue->rank)
1875     {
1876       gfc_error ("Incompatible ranks %d and %d in assignment at %L",
1877                  lvalue->rank, rvalue->rank, &lvalue->where);
1878       return FAILURE;
1879     }
1880
1881   if (lvalue->ts.type == BT_UNKNOWN)
1882     {
1883       gfc_error ("Variable type is UNKNOWN in assignment at %L",
1884                  &lvalue->where);
1885       return FAILURE;
1886     }
1887
1888    if (rvalue->expr_type == EXPR_NULL)
1889      {
1890        gfc_error ("NULL appears on right-hand side in assignment at %L",
1891                   &rvalue->where);
1892        return FAILURE;
1893      }
1894
1895    if (sym->attr.cray_pointee
1896        && lvalue->ref != NULL
1897        && lvalue->ref->u.ar.type == AR_FULL
1898        && lvalue->ref->u.ar.as->cp_was_assumed)
1899      {
1900        gfc_error ("Vector assignment to assumed-size Cray Pointee at %L"
1901                   " is illegal.", &lvalue->where);
1902        return FAILURE;
1903      }
1904
1905   /* This is possibly a typo: x = f() instead of x => f()  */
1906   if (gfc_option.warn_surprising
1907       && rvalue->expr_type == EXPR_FUNCTION
1908       && rvalue->symtree->n.sym->attr.pointer)
1909     gfc_warning ("POINTER valued function appears on right-hand side of "
1910                  "assignment at %L", &rvalue->where);
1911
1912   /* Check size of array assignments.  */
1913   if (lvalue->rank != 0 && rvalue->rank != 0
1914       && gfc_check_conformance ("Array assignment", lvalue, rvalue) != SUCCESS)
1915     return FAILURE;
1916
1917   if (gfc_compare_types (&lvalue->ts, &rvalue->ts))
1918     return SUCCESS;
1919
1920   if (!conform)
1921     {
1922       /* Numeric can be converted to any other numeric. And Hollerith can be
1923          converted to any other type.  */
1924       if ((gfc_numeric_ts (&lvalue->ts) && gfc_numeric_ts (&rvalue->ts))
1925           || rvalue->ts.type == BT_HOLLERITH)
1926         return SUCCESS;
1927
1928       if (lvalue->ts.type == BT_LOGICAL && rvalue->ts.type == BT_LOGICAL)
1929         return SUCCESS;
1930
1931       gfc_error ("Incompatible types in assignment at %L, %s to %s",
1932                  &rvalue->where, gfc_typename (&rvalue->ts),
1933                  gfc_typename (&lvalue->ts));
1934
1935       return FAILURE;
1936     }
1937
1938   return gfc_convert_type (rvalue, &lvalue->ts, 1);
1939 }
1940
1941
1942 /* Check that a pointer assignment is OK.  We first check lvalue, and
1943    we only check rvalue if it's not an assignment to NULL() or a
1944    NULLIFY statement.  */
1945
1946 try
1947 gfc_check_pointer_assign (gfc_expr * lvalue, gfc_expr * rvalue)
1948 {
1949   symbol_attribute attr;
1950   int is_pure;
1951
1952   if (lvalue->symtree->n.sym->ts.type == BT_UNKNOWN)
1953     {
1954       gfc_error ("Pointer assignment target is not a POINTER at %L",
1955                  &lvalue->where);
1956       return FAILURE;
1957     }
1958
1959   if (lvalue->symtree->n.sym->attr.flavor == FL_PROCEDURE
1960         && lvalue->symtree->n.sym->attr.use_assoc)
1961     {
1962       gfc_error ("'%s' in the pointer assignment at %L cannot be an "
1963                  "l-value since it is a procedure",
1964                  lvalue->symtree->n.sym->name, &lvalue->where);
1965       return FAILURE;
1966     }
1967
1968   attr = gfc_variable_attr (lvalue, NULL);
1969   if (!attr.pointer)
1970     {
1971       gfc_error ("Pointer assignment to non-POINTER at %L", &lvalue->where);
1972       return FAILURE;
1973     }
1974
1975   is_pure = gfc_pure (NULL);
1976
1977   if (is_pure && gfc_impure_variable (lvalue->symtree->n.sym))
1978     {
1979       gfc_error ("Bad pointer object in PURE procedure at %L",
1980                  &lvalue->where);
1981       return FAILURE;
1982     }
1983
1984   /* If rvalue is a NULL() or NULLIFY, we're done. Otherwise the type,
1985      kind, etc for lvalue and rvalue must match, and rvalue must be a
1986      pure variable if we're in a pure function.  */
1987   if (rvalue->expr_type == EXPR_NULL && rvalue->ts.type == BT_UNKNOWN)
1988     return SUCCESS;
1989
1990   if (!gfc_compare_types (&lvalue->ts, &rvalue->ts))
1991     {
1992       gfc_error ("Different types in pointer assignment at %L",
1993                  &lvalue->where);
1994       return FAILURE;
1995     }
1996
1997   if (lvalue->ts.kind != rvalue->ts.kind)
1998     {
1999       gfc_error ("Different kind type parameters in pointer "
2000                  "assignment at %L", &lvalue->where);
2001       return FAILURE;
2002     }
2003
2004   if (lvalue->rank != rvalue->rank)
2005     {
2006       gfc_error ("Different ranks in pointer assignment at %L",
2007                   &lvalue->where);
2008       return FAILURE;
2009     }
2010
2011   /* Now punt if we are dealing with a NULLIFY(X) or X = NULL(X).  */
2012   if (rvalue->expr_type == EXPR_NULL)
2013     return SUCCESS;
2014
2015   if (lvalue->ts.type == BT_CHARACTER
2016         && lvalue->ts.cl->length && rvalue->ts.cl->length
2017         && abs (gfc_dep_compare_expr (lvalue->ts.cl->length,
2018                                       rvalue->ts.cl->length)) == 1)
2019     {
2020       gfc_error ("Different character lengths in pointer "
2021                  "assignment at %L", &lvalue->where);
2022       return FAILURE;
2023     }
2024
2025   attr = gfc_expr_attr (rvalue);
2026   if (!attr.target && !attr.pointer)
2027     {
2028       gfc_error ("Pointer assignment target is neither TARGET "
2029                  "nor POINTER at %L", &rvalue->where);
2030       return FAILURE;
2031     }
2032
2033   if (is_pure && gfc_impure_variable (rvalue->symtree->n.sym))
2034     {
2035       gfc_error ("Bad target in pointer assignment in PURE "
2036                  "procedure at %L", &rvalue->where);
2037     }
2038
2039   if (gfc_has_vector_index (rvalue))
2040     {
2041       gfc_error ("Pointer assignment with vector subscript "
2042                  "on rhs at %L", &rvalue->where);
2043       return FAILURE;
2044     }
2045
2046   return SUCCESS;
2047 }
2048
2049
2050 /* Relative of gfc_check_assign() except that the lvalue is a single
2051    symbol.  Used for initialization assignments.  */
2052
2053 try
2054 gfc_check_assign_symbol (gfc_symbol * sym, gfc_expr * rvalue)
2055 {
2056   gfc_expr lvalue;
2057   try r;
2058
2059   memset (&lvalue, '\0', sizeof (gfc_expr));
2060
2061   lvalue.expr_type = EXPR_VARIABLE;
2062   lvalue.ts = sym->ts;
2063   if (sym->as)
2064     lvalue.rank = sym->as->rank;
2065   lvalue.symtree = (gfc_symtree *)gfc_getmem (sizeof (gfc_symtree));
2066   lvalue.symtree->n.sym = sym;
2067   lvalue.where = sym->declared_at;
2068
2069   if (sym->attr.pointer)
2070     r = gfc_check_pointer_assign (&lvalue, rvalue);
2071   else
2072     r = gfc_check_assign (&lvalue, rvalue, 1);
2073
2074   gfc_free (lvalue.symtree);
2075
2076   return r;
2077 }
2078
2079
2080 /* Get an expression for a default initializer.  */
2081
2082 gfc_expr *
2083 gfc_default_initializer (gfc_typespec *ts)
2084 {
2085   gfc_constructor *tail;
2086   gfc_expr *init;
2087   gfc_component *c;
2088
2089   init = NULL;
2090
2091   /* See if we have a default initializer.  */
2092   for (c = ts->derived->components; c; c = c->next)
2093     {
2094       if (c->initializer && init == NULL)
2095         init = gfc_get_expr ();
2096     }
2097
2098   if (init == NULL)
2099     return NULL;
2100
2101   /* Build the constructor.  */
2102   init->expr_type = EXPR_STRUCTURE;
2103   init->ts = *ts;
2104   init->where = ts->derived->declared_at;
2105   tail = NULL;
2106   for (c = ts->derived->components; c; c = c->next)
2107     {
2108       if (tail == NULL)
2109         init->value.constructor = tail = gfc_get_constructor ();
2110       else
2111         {
2112           tail->next = gfc_get_constructor ();
2113           tail = tail->next;
2114         }
2115
2116       if (c->initializer)
2117         tail->expr = gfc_copy_expr (c->initializer);
2118     }
2119   return init;
2120 }
2121
2122
2123 /* Given a symbol, create an expression node with that symbol as a
2124    variable. If the symbol is array valued, setup a reference of the
2125    whole array.  */
2126
2127 gfc_expr *
2128 gfc_get_variable_expr (gfc_symtree * var)
2129 {
2130   gfc_expr *e;
2131
2132   e = gfc_get_expr ();
2133   e->expr_type = EXPR_VARIABLE;
2134   e->symtree = var;
2135   e->ts = var->n.sym->ts;
2136
2137   if (var->n.sym->as != NULL)
2138     {
2139       e->rank = var->n.sym->as->rank;
2140       e->ref = gfc_get_ref ();
2141       e->ref->type = REF_ARRAY;
2142       e->ref->u.ar.type = AR_FULL;
2143     }
2144
2145   return e;
2146 }
2147
2148
2149 /* Traverse expr, marking all EXPR_VARIABLE symbols referenced.  */
2150
2151 void
2152 gfc_expr_set_symbols_referenced (gfc_expr * expr)
2153 {
2154   gfc_actual_arglist *arg;
2155   gfc_constructor *c;
2156   gfc_ref *ref;
2157   int i;
2158
2159   if (!expr) return;
2160
2161   switch (expr->expr_type)
2162     {
2163     case EXPR_OP:
2164       gfc_expr_set_symbols_referenced (expr->value.op.op1);
2165       gfc_expr_set_symbols_referenced (expr->value.op.op2);
2166       break;
2167
2168     case EXPR_FUNCTION:
2169       for (arg = expr->value.function.actual; arg; arg = arg->next)
2170         gfc_expr_set_symbols_referenced (arg->expr);
2171       break;
2172
2173     case EXPR_VARIABLE:
2174       gfc_set_sym_referenced (expr->symtree->n.sym);
2175       break;
2176
2177     case EXPR_CONSTANT:
2178     case EXPR_NULL:
2179     case EXPR_SUBSTRING:
2180       break;
2181
2182     case EXPR_STRUCTURE:
2183     case EXPR_ARRAY:
2184       for (c = expr->value.constructor; c; c = c->next)
2185         gfc_expr_set_symbols_referenced (c->expr);
2186       break;
2187
2188     default:
2189       gcc_unreachable ();
2190       break;
2191     }
2192
2193     for (ref = expr->ref; ref; ref = ref->next)
2194       switch (ref->type)
2195         {
2196         case REF_ARRAY:
2197           for (i = 0; i < ref->u.ar.dimen; i++)
2198             {
2199               gfc_expr_set_symbols_referenced (ref->u.ar.start[i]);
2200               gfc_expr_set_symbols_referenced (ref->u.ar.end[i]);
2201               gfc_expr_set_symbols_referenced (ref->u.ar.stride[i]);
2202             }
2203           break;
2204
2205         case REF_COMPONENT:
2206           break;
2207
2208         case REF_SUBSTRING:
2209           gfc_expr_set_symbols_referenced (ref->u.ss.start);
2210           gfc_expr_set_symbols_referenced (ref->u.ss.end);
2211           break;
2212
2213         default:
2214           gcc_unreachable ();
2215           break;
2216         }
2217 }