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     default:
1348       gfc_error ("Only intrinsic operators can be used in expression at %L",
1349                  &e->where);
1350       return FAILURE;
1351     }
1352
1353   return SUCCESS;
1354
1355 not_numeric:
1356   gfc_error ("Numeric operands are required in expression at %L", &e->where);
1357
1358   return FAILURE;
1359 }
1360
1361
1362
1363 /* Certain inquiry functions are specifically allowed to have variable
1364    arguments, which is an exception to the normal requirement that an
1365    initialization function have initialization arguments.  We head off
1366    this problem here.  */
1367
1368 static try
1369 check_inquiry (gfc_expr * e, int not_restricted)
1370 {
1371   const char *name;
1372
1373   /* FIXME: This should be moved into the intrinsic definitions,
1374      to eliminate this ugly hack.  */
1375   static const char * const inquiry_function[] = {
1376     "digits", "epsilon", "huge", "kind", "len", "maxexponent", "minexponent",
1377     "precision", "radix", "range", "tiny", "bit_size", "size", "shape",
1378     "lbound", "ubound", NULL
1379   };
1380
1381   int i;
1382
1383   /* An undeclared parameter will get us here (PR25018).  */
1384   if (e->symtree == NULL)
1385     return FAILURE;
1386
1387   name = e->symtree->n.sym->name;
1388
1389   for (i = 0; inquiry_function[i]; i++)
1390     if (strcmp (inquiry_function[i], name) == 0)
1391       break;
1392
1393   if (inquiry_function[i] == NULL)
1394     return FAILURE;
1395
1396   e = e->value.function.actual->expr;
1397
1398   if (e == NULL || e->expr_type != EXPR_VARIABLE)
1399     return FAILURE;
1400
1401   /* At this point we have an inquiry function with a variable argument.  The
1402      type of the variable might be undefined, but we need it now, because the
1403      arguments of these functions are allowed to be undefined.  */
1404
1405   if (e->ts.type == BT_UNKNOWN)
1406     {
1407       if (e->symtree->n.sym->ts.type == BT_UNKNOWN
1408           && gfc_set_default_type (e->symtree->n.sym, 0, gfc_current_ns)
1409             == FAILURE)
1410         return FAILURE;
1411
1412       e->ts = e->symtree->n.sym->ts;
1413     }
1414
1415   /* Assumed character length will not reduce to a constant expression
1416      with LEN, as required by the standard.  */
1417   if (i == 4 && not_restricted
1418         && e->symtree->n.sym->ts.type == BT_CHARACTER
1419         && e->symtree->n.sym->ts.cl->length == NULL)
1420     gfc_notify_std (GFC_STD_GNU, "assumed character length "
1421                     "variable '%s' in constant expression at %L",
1422                     e->symtree->n.sym->name, &e->where);
1423
1424   return SUCCESS;
1425 }
1426
1427
1428 /* Verify that an expression is an initialization expression.  A side
1429    effect is that the expression tree is reduced to a single constant
1430    node if all goes well.  This would normally happen when the
1431    expression is constructed but function references are assumed to be
1432    intrinsics in the context of initialization expressions.  If
1433    FAILURE is returned an error message has been generated.  */
1434
1435 static try
1436 check_init_expr (gfc_expr * e)
1437 {
1438   gfc_actual_arglist *ap;
1439   match m;
1440   try t;
1441
1442   if (e == NULL)
1443     return SUCCESS;
1444
1445   switch (e->expr_type)
1446     {
1447     case EXPR_OP:
1448       t = check_intrinsic_op (e, check_init_expr);
1449       if (t == SUCCESS)
1450         t = gfc_simplify_expr (e, 0);
1451
1452       break;
1453
1454     case EXPR_FUNCTION:
1455       t = SUCCESS;
1456
1457       if (check_inquiry (e, 1) != SUCCESS)
1458         {
1459           t = SUCCESS;
1460           for (ap = e->value.function.actual; ap; ap = ap->next)
1461             if (check_init_expr (ap->expr) == FAILURE)
1462               {
1463                 t = FAILURE;
1464                 break;
1465               }
1466         }
1467
1468       if (t == SUCCESS)
1469         {
1470           m = gfc_intrinsic_func_interface (e, 0);
1471
1472           if (m == MATCH_NO)
1473             gfc_error ("Function '%s' in initialization expression at %L "
1474                        "must be an intrinsic function",
1475                        e->symtree->n.sym->name, &e->where);
1476
1477           if (m != MATCH_YES)
1478             t = FAILURE;
1479         }
1480
1481       break;
1482
1483     case EXPR_VARIABLE:
1484       t = SUCCESS;
1485
1486       if (gfc_check_iter_variable (e) == SUCCESS)
1487         break;
1488
1489       if (e->symtree->n.sym->attr.flavor == FL_PARAMETER)
1490         {
1491           t = simplify_parameter_variable (e, 0);
1492           break;
1493         }
1494
1495       gfc_error ("Parameter '%s' at %L has not been declared or is "
1496                  "a variable, which does not reduce to a constant "
1497                  "expression", e->symtree->n.sym->name, &e->where);
1498       t = FAILURE;
1499       break;
1500
1501     case EXPR_CONSTANT:
1502     case EXPR_NULL:
1503       t = SUCCESS;
1504       break;
1505
1506     case EXPR_SUBSTRING:
1507       t = check_init_expr (e->ref->u.ss.start);
1508       if (t == FAILURE)
1509         break;
1510
1511       t = check_init_expr (e->ref->u.ss.end);
1512       if (t == SUCCESS)
1513         t = gfc_simplify_expr (e, 0);
1514
1515       break;
1516
1517     case EXPR_STRUCTURE:
1518       t = gfc_check_constructor (e, check_init_expr);
1519       break;
1520
1521     case EXPR_ARRAY:
1522       t = gfc_check_constructor (e, check_init_expr);
1523       if (t == FAILURE)
1524         break;
1525
1526       t = gfc_expand_constructor (e);
1527       if (t == FAILURE)
1528         break;
1529
1530       t = gfc_check_constructor_type (e);
1531       break;
1532
1533     default:
1534       gfc_internal_error ("check_init_expr(): Unknown expression type");
1535     }
1536
1537   return t;
1538 }
1539
1540
1541 /* Match an initialization expression.  We work by first matching an
1542    expression, then reducing it to a constant.  */
1543
1544 match
1545 gfc_match_init_expr (gfc_expr ** result)
1546 {
1547   gfc_expr *expr;
1548   match m;
1549   try t;
1550
1551   m = gfc_match_expr (&expr);
1552   if (m != MATCH_YES)
1553     return m;
1554
1555   gfc_init_expr = 1;
1556   t = gfc_resolve_expr (expr);
1557   if (t == SUCCESS)
1558     t = check_init_expr (expr);
1559   gfc_init_expr = 0;
1560
1561   if (t == FAILURE)
1562     {
1563       gfc_free_expr (expr);
1564       return MATCH_ERROR;
1565     }
1566
1567   if (expr->expr_type == EXPR_ARRAY
1568       && (gfc_check_constructor_type (expr) == FAILURE
1569           || gfc_expand_constructor (expr) == FAILURE))
1570     {
1571       gfc_free_expr (expr);
1572       return MATCH_ERROR;
1573     }
1574
1575   /* Not all inquiry functions are simplified to constant expressions
1576      so it is necessary to call check_inquiry again.  */
1577   if (!gfc_is_constant_expr (expr)
1578         && check_inquiry (expr, 1) == FAILURE)
1579     {
1580       gfc_error ("Initialization expression didn't reduce %C");
1581       return MATCH_ERROR;
1582     }
1583
1584   *result = expr;
1585
1586   return MATCH_YES;
1587 }
1588
1589
1590
1591 static try check_restricted (gfc_expr *);
1592
1593 /* Given an actual argument list, test to see that each argument is a
1594    restricted expression and optionally if the expression type is
1595    integer or character.  */
1596
1597 static try
1598 restricted_args (gfc_actual_arglist * a)
1599 {
1600   for (; a; a = a->next)
1601     {
1602       if (check_restricted (a->expr) == FAILURE)
1603         return FAILURE;
1604     }
1605
1606   return SUCCESS;
1607 }
1608
1609
1610 /************* Restricted/specification expressions *************/
1611
1612
1613 /* Make sure a non-intrinsic function is a specification function.  */
1614
1615 static try
1616 external_spec_function (gfc_expr * e)
1617 {
1618   gfc_symbol *f;
1619
1620   f = e->value.function.esym;
1621
1622   if (f->attr.proc == PROC_ST_FUNCTION)
1623     {
1624       gfc_error ("Specification function '%s' at %L cannot be a statement "
1625                  "function", f->name, &e->where);
1626       return FAILURE;
1627     }
1628
1629   if (f->attr.proc == PROC_INTERNAL)
1630     {
1631       gfc_error ("Specification function '%s' at %L cannot be an internal "
1632                  "function", f->name, &e->where);
1633       return FAILURE;
1634     }
1635
1636   if (!f->attr.pure)
1637     {
1638       gfc_error ("Specification function '%s' at %L must be PURE", f->name,
1639                  &e->where);
1640       return FAILURE;
1641     }
1642
1643   if (f->attr.recursive)
1644     {
1645       gfc_error ("Specification function '%s' at %L cannot be RECURSIVE",
1646                  f->name, &e->where);
1647       return FAILURE;
1648     }
1649
1650   return restricted_args (e->value.function.actual);
1651 }
1652
1653
1654 /* Check to see that a function reference to an intrinsic is a
1655    restricted expression.  */
1656
1657 static try
1658 restricted_intrinsic (gfc_expr * e)
1659 {
1660   /* TODO: Check constraints on inquiry functions.  7.1.6.2 (7).  */
1661   if (check_inquiry (e, 0) == SUCCESS)
1662     return SUCCESS;
1663
1664   return restricted_args (e->value.function.actual);
1665 }
1666
1667
1668 /* Verify that an expression is a restricted expression.  Like its
1669    cousin check_init_expr(), an error message is generated if we
1670    return FAILURE.  */
1671
1672 static try
1673 check_restricted (gfc_expr * e)
1674 {
1675   gfc_symbol *sym;
1676   try t;
1677
1678   if (e == NULL)
1679     return SUCCESS;
1680
1681   switch (e->expr_type)
1682     {
1683     case EXPR_OP:
1684       t = check_intrinsic_op (e, check_restricted);
1685       if (t == SUCCESS)
1686         t = gfc_simplify_expr (e, 0);
1687
1688       break;
1689
1690     case EXPR_FUNCTION:
1691       t = e->value.function.esym ?
1692         external_spec_function (e) : restricted_intrinsic (e);
1693
1694       break;
1695
1696     case EXPR_VARIABLE:
1697       sym = e->symtree->n.sym;
1698       t = FAILURE;
1699
1700       if (sym->attr.optional)
1701         {
1702           gfc_error ("Dummy argument '%s' at %L cannot be OPTIONAL",
1703                      sym->name, &e->where);
1704           break;
1705         }
1706
1707       if (sym->attr.intent == INTENT_OUT)
1708         {
1709           gfc_error ("Dummy argument '%s' at %L cannot be INTENT(OUT)",
1710                      sym->name, &e->where);
1711           break;
1712         }
1713
1714       /* gfc_is_formal_arg broadcasts that a formal argument list is being processed
1715          in resolve.c(resolve_formal_arglist).  This is done so that host associated
1716          dummy array indices are accepted (PR23446).  */
1717       if (sym->attr.in_common
1718           || sym->attr.use_assoc
1719           || sym->attr.dummy
1720           || sym->ns != gfc_current_ns
1721           || (sym->ns->proc_name != NULL
1722               && sym->ns->proc_name->attr.flavor == FL_MODULE)
1723           || gfc_is_formal_arg ())
1724         {
1725           t = SUCCESS;
1726           break;
1727         }
1728
1729       gfc_error ("Variable '%s' cannot appear in the expression at %L",
1730                  sym->name, &e->where);
1731
1732       break;
1733
1734     case EXPR_NULL:
1735     case EXPR_CONSTANT:
1736       t = SUCCESS;
1737       break;
1738
1739     case EXPR_SUBSTRING:
1740       t = gfc_specification_expr (e->ref->u.ss.start);
1741       if (t == FAILURE)
1742         break;
1743
1744       t = gfc_specification_expr (e->ref->u.ss.end);
1745       if (t == SUCCESS)
1746         t = gfc_simplify_expr (e, 0);
1747
1748       break;
1749
1750     case EXPR_STRUCTURE:
1751       t = gfc_check_constructor (e, check_restricted);
1752       break;
1753
1754     case EXPR_ARRAY:
1755       t = gfc_check_constructor (e, check_restricted);
1756       break;
1757
1758     default:
1759       gfc_internal_error ("check_restricted(): Unknown expression type");
1760     }
1761
1762   return t;
1763 }
1764
1765
1766 /* Check to see that an expression is a specification expression.  If
1767    we return FAILURE, an error has been generated.  */
1768
1769 try
1770 gfc_specification_expr (gfc_expr * e)
1771 {
1772   if (e == NULL)
1773     return SUCCESS;
1774
1775   if (e->ts.type != BT_INTEGER)
1776     {
1777       gfc_error ("Expression at %L must be of INTEGER type", &e->where);
1778       return FAILURE;
1779     }
1780
1781   if (e->rank != 0)
1782     {
1783       gfc_error ("Expression at %L must be scalar", &e->where);
1784       return FAILURE;
1785     }
1786
1787   if (gfc_simplify_expr (e, 0) == FAILURE)
1788     return FAILURE;
1789
1790   return check_restricted (e);
1791 }
1792
1793
1794 /************** Expression conformance checks.  *************/
1795
1796 /* Given two expressions, make sure that the arrays are conformable.  */
1797
1798 try
1799 gfc_check_conformance (const char *optype_msgid,
1800                        gfc_expr * op1, gfc_expr * op2)
1801 {
1802   int op1_flag, op2_flag, d;
1803   mpz_t op1_size, op2_size;
1804   try t;
1805
1806   if (op1->rank == 0 || op2->rank == 0)
1807     return SUCCESS;
1808
1809   if (op1->rank != op2->rank)
1810     {
1811       gfc_error ("Incompatible ranks in %s at %L", _(optype_msgid),
1812                  &op1->where);
1813       return FAILURE;
1814     }
1815
1816   t = SUCCESS;
1817
1818   for (d = 0; d < op1->rank; d++)
1819     {
1820       op1_flag = gfc_array_dimen_size (op1, d, &op1_size) == SUCCESS;
1821       op2_flag = gfc_array_dimen_size (op2, d, &op2_size) == SUCCESS;
1822
1823       if (op1_flag && op2_flag && mpz_cmp (op1_size, op2_size) != 0)
1824         {
1825           gfc_error ("different shape for %s at %L on dimension %d (%d/%d)",
1826                      _(optype_msgid), &op1->where, d + 1,
1827                      (int) mpz_get_si (op1_size),
1828                      (int) mpz_get_si (op2_size));
1829
1830           t = FAILURE;
1831         }
1832
1833       if (op1_flag)
1834         mpz_clear (op1_size);
1835       if (op2_flag)
1836         mpz_clear (op2_size);
1837
1838       if (t == FAILURE)
1839         return FAILURE;
1840     }
1841
1842   return SUCCESS;
1843 }
1844
1845
1846 /* Given an assignable expression and an arbitrary expression, make
1847    sure that the assignment can take place.  */
1848
1849 try
1850 gfc_check_assign (gfc_expr * lvalue, gfc_expr * rvalue, int conform)
1851 {
1852   gfc_symbol *sym;
1853
1854   sym = lvalue->symtree->n.sym;
1855
1856   if (sym->attr.intent == INTENT_IN)
1857     {
1858       gfc_error ("Can't assign to INTENT(IN) variable '%s' at %L",
1859                  sym->name, &lvalue->where);
1860       return FAILURE;
1861     }
1862
1863   if (sym->attr.flavor == FL_PROCEDURE && sym->attr.use_assoc)
1864     {
1865       gfc_error ("'%s' in the assignment at %L cannot be an l-value "
1866                  "since it is a procedure", sym->name, &lvalue->where);
1867       return FAILURE;
1868     }
1869
1870
1871   if (rvalue->rank != 0 && lvalue->rank != rvalue->rank)
1872     {
1873       gfc_error ("Incompatible ranks %d and %d in assignment at %L",
1874                  lvalue->rank, rvalue->rank, &lvalue->where);
1875       return FAILURE;
1876     }
1877
1878   if (lvalue->ts.type == BT_UNKNOWN)
1879     {
1880       gfc_error ("Variable type is UNKNOWN in assignment at %L",
1881                  &lvalue->where);
1882       return FAILURE;
1883     }
1884
1885    if (rvalue->expr_type == EXPR_NULL)
1886      {
1887        gfc_error ("NULL appears on right-hand side in assignment at %L",
1888                   &rvalue->where);
1889        return FAILURE;
1890      }
1891
1892    if (sym->attr.cray_pointee
1893        && lvalue->ref != NULL
1894        && lvalue->ref->u.ar.type != AR_ELEMENT
1895        && lvalue->ref->u.ar.as->cp_was_assumed)
1896      {
1897        gfc_error ("Vector assignment to assumed-size Cray Pointee at %L"
1898                   " is illegal.", &lvalue->where);
1899        return FAILURE;
1900      }
1901
1902   /* This is possibly a typo: x = f() instead of x => f()  */
1903   if (gfc_option.warn_surprising
1904       && rvalue->expr_type == EXPR_FUNCTION
1905       && rvalue->symtree->n.sym->attr.pointer)
1906     gfc_warning ("POINTER valued function appears on right-hand side of "
1907                  "assignment at %L", &rvalue->where);
1908
1909   /* Check size of array assignments.  */
1910   if (lvalue->rank != 0 && rvalue->rank != 0
1911       && gfc_check_conformance ("Array assignment", lvalue, rvalue) != SUCCESS)
1912     return FAILURE;
1913
1914   if (gfc_compare_types (&lvalue->ts, &rvalue->ts))
1915     return SUCCESS;
1916
1917   if (!conform)
1918     {
1919       /* Numeric can be converted to any other numeric. And Hollerith can be
1920          converted to any other type.  */
1921       if ((gfc_numeric_ts (&lvalue->ts) && gfc_numeric_ts (&rvalue->ts))
1922           || rvalue->ts.type == BT_HOLLERITH)
1923         return SUCCESS;
1924
1925       if (lvalue->ts.type == BT_LOGICAL && rvalue->ts.type == BT_LOGICAL)
1926         return SUCCESS;
1927
1928       gfc_error ("Incompatible types in assignment at %L, %s to %s",
1929                  &rvalue->where, gfc_typename (&rvalue->ts),
1930                  gfc_typename (&lvalue->ts));
1931
1932       return FAILURE;
1933     }
1934
1935   return gfc_convert_type (rvalue, &lvalue->ts, 1);
1936 }
1937
1938
1939 /* Check that a pointer assignment is OK.  We first check lvalue, and
1940    we only check rvalue if it's not an assignment to NULL() or a
1941    NULLIFY statement.  */
1942
1943 try
1944 gfc_check_pointer_assign (gfc_expr * lvalue, gfc_expr * rvalue)
1945 {
1946   symbol_attribute attr;
1947   int is_pure;
1948
1949   if (lvalue->symtree->n.sym->ts.type == BT_UNKNOWN)
1950     {
1951       gfc_error ("Pointer assignment target is not a POINTER at %L",
1952                  &lvalue->where);
1953       return FAILURE;
1954     }
1955
1956   if (lvalue->symtree->n.sym->attr.flavor == FL_PROCEDURE
1957         && lvalue->symtree->n.sym->attr.use_assoc)
1958     {
1959       gfc_error ("'%s' in the pointer assignment at %L cannot be an "
1960                  "l-value since it is a procedure",
1961                  lvalue->symtree->n.sym->name, &lvalue->where);
1962       return FAILURE;
1963     }
1964
1965   attr = gfc_variable_attr (lvalue, NULL);
1966   if (!attr.pointer)
1967     {
1968       gfc_error ("Pointer assignment to non-POINTER at %L", &lvalue->where);
1969       return FAILURE;
1970     }
1971
1972   is_pure = gfc_pure (NULL);
1973
1974   if (is_pure && gfc_impure_variable (lvalue->symtree->n.sym))
1975     {
1976       gfc_error ("Bad pointer object in PURE procedure at %L",
1977                  &lvalue->where);
1978       return FAILURE;
1979     }
1980
1981   /* If rvalue is a NULL() or NULLIFY, we're done. Otherwise the type,
1982      kind, etc for lvalue and rvalue must match, and rvalue must be a
1983      pure variable if we're in a pure function.  */
1984   if (rvalue->expr_type == EXPR_NULL)
1985     return SUCCESS;
1986
1987   if (!gfc_compare_types (&lvalue->ts, &rvalue->ts))
1988     {
1989       gfc_error ("Different types in pointer assignment at %L",
1990                  &lvalue->where);
1991       return FAILURE;
1992     }
1993
1994   if (lvalue->ts.kind != rvalue->ts.kind)
1995     {
1996       gfc_error ("Different kind type parameters in pointer "
1997                  "assignment at %L", &lvalue->where);
1998       return FAILURE;
1999     }
2000
2001   if (lvalue->ts.type == BT_CHARACTER
2002         && lvalue->ts.cl->length && rvalue->ts.cl->length
2003         && abs (gfc_dep_compare_expr (lvalue->ts.cl->length,
2004                                       rvalue->ts.cl->length)) == 1)
2005     {
2006       gfc_error ("Different character lengths in pointer "
2007                  "assignment at %L", &lvalue->where);
2008       return FAILURE;
2009     }
2010
2011   attr = gfc_expr_attr (rvalue);
2012   if (!attr.target && !attr.pointer)
2013     {
2014       gfc_error ("Pointer assignment target is neither TARGET "
2015                  "nor POINTER at %L", &rvalue->where);
2016       return FAILURE;
2017     }
2018
2019   if (is_pure && gfc_impure_variable (rvalue->symtree->n.sym))
2020     {
2021       gfc_error ("Bad target in pointer assignment in PURE "
2022                  "procedure at %L", &rvalue->where);
2023     }
2024
2025   if (lvalue->rank != rvalue->rank)
2026     {
2027       gfc_error ("Unequal ranks %d and %d in pointer assignment at %L",
2028                  lvalue->rank, rvalue->rank, &rvalue->where);
2029       return FAILURE;
2030     }
2031
2032   if (gfc_has_vector_index (rvalue))
2033     {
2034       gfc_error ("Pointer assignment with vector subscript "
2035                  "on rhs at %L", &rvalue->where);
2036       return FAILURE;
2037     }
2038
2039   return SUCCESS;
2040 }
2041
2042
2043 /* Relative of gfc_check_assign() except that the lvalue is a single
2044    symbol.  Used for initialization assignments.  */
2045
2046 try
2047 gfc_check_assign_symbol (gfc_symbol * sym, gfc_expr * rvalue)
2048 {
2049   gfc_expr lvalue;
2050   try r;
2051
2052   memset (&lvalue, '\0', sizeof (gfc_expr));
2053
2054   lvalue.expr_type = EXPR_VARIABLE;
2055   lvalue.ts = sym->ts;
2056   if (sym->as)
2057     lvalue.rank = sym->as->rank;
2058   lvalue.symtree = (gfc_symtree *)gfc_getmem (sizeof (gfc_symtree));
2059   lvalue.symtree->n.sym = sym;
2060   lvalue.where = sym->declared_at;
2061
2062   if (sym->attr.pointer)
2063     r = gfc_check_pointer_assign (&lvalue, rvalue);
2064   else
2065     r = gfc_check_assign (&lvalue, rvalue, 1);
2066
2067   gfc_free (lvalue.symtree);
2068
2069   return r;
2070 }
2071
2072
2073 /* Get an expression for a default initializer.  */
2074
2075 gfc_expr *
2076 gfc_default_initializer (gfc_typespec *ts)
2077 {
2078   gfc_constructor *tail;
2079   gfc_expr *init;
2080   gfc_component *c;
2081
2082   init = NULL;
2083
2084   /* See if we have a default initializer.  */
2085   for (c = ts->derived->components; c; c = c->next)
2086     {
2087       if (c->initializer && init == NULL)
2088         init = gfc_get_expr ();
2089     }
2090
2091   if (init == NULL)
2092     return NULL;
2093
2094   /* Build the constructor.  */
2095   init->expr_type = EXPR_STRUCTURE;
2096   init->ts = *ts;
2097   init->where = ts->derived->declared_at;
2098   tail = NULL;
2099   for (c = ts->derived->components; c; c = c->next)
2100     {
2101       if (tail == NULL)
2102         init->value.constructor = tail = gfc_get_constructor ();
2103       else
2104         {
2105           tail->next = gfc_get_constructor ();
2106           tail = tail->next;
2107         }
2108
2109       if (c->initializer)
2110         tail->expr = gfc_copy_expr (c->initializer);
2111     }
2112   return init;
2113 }
2114
2115
2116 /* Given a symbol, create an expression node with that symbol as a
2117    variable. If the symbol is array valued, setup a reference of the
2118    whole array.  */
2119
2120 gfc_expr *
2121 gfc_get_variable_expr (gfc_symtree * var)
2122 {
2123   gfc_expr *e;
2124
2125   e = gfc_get_expr ();
2126   e->expr_type = EXPR_VARIABLE;
2127   e->symtree = var;
2128   e->ts = var->n.sym->ts;
2129
2130   if (var->n.sym->as != NULL)
2131     {
2132       e->rank = var->n.sym->as->rank;
2133       e->ref = gfc_get_ref ();
2134       e->ref->type = REF_ARRAY;
2135       e->ref->u.ar.type = AR_FULL;
2136     }
2137
2138   return e;
2139 }
2140
2141
2142 /* Traverse expr, marking all EXPR_VARIABLE symbols referenced.  */
2143
2144 void
2145 gfc_expr_set_symbols_referenced (gfc_expr * expr)
2146 {
2147   gfc_actual_arglist *arg;
2148   gfc_constructor *c;
2149   gfc_ref *ref;
2150   int i;
2151
2152   if (!expr) return;
2153
2154   switch (expr->expr_type)
2155     {
2156     case EXPR_OP:
2157       gfc_expr_set_symbols_referenced (expr->value.op.op1);
2158       gfc_expr_set_symbols_referenced (expr->value.op.op2);
2159       break;
2160
2161     case EXPR_FUNCTION:
2162       for (arg = expr->value.function.actual; arg; arg = arg->next)
2163         gfc_expr_set_symbols_referenced (arg->expr);
2164       break;
2165
2166     case EXPR_VARIABLE:
2167       gfc_set_sym_referenced (expr->symtree->n.sym);
2168       break;
2169
2170     case EXPR_CONSTANT:
2171     case EXPR_NULL:
2172     case EXPR_SUBSTRING:
2173       break;
2174
2175     case EXPR_STRUCTURE:
2176     case EXPR_ARRAY:
2177       for (c = expr->value.constructor; c; c = c->next)
2178         gfc_expr_set_symbols_referenced (c->expr);
2179       break;
2180
2181     default:
2182       gcc_unreachable ();
2183       break;
2184     }
2185
2186     for (ref = expr->ref; ref; ref = ref->next)
2187       switch (ref->type)
2188         {
2189         case REF_ARRAY:
2190           for (i = 0; i < ref->u.ar.dimen; i++)
2191             {
2192               gfc_expr_set_symbols_referenced (ref->u.ar.start[i]);
2193               gfc_expr_set_symbols_referenced (ref->u.ar.end[i]);
2194               gfc_expr_set_symbols_referenced (ref->u.ar.stride[i]);
2195             }
2196           break;
2197
2198         case REF_COMPONENT:
2199           break;
2200
2201         case REF_SUBSTRING:
2202           gfc_expr_set_symbols_referenced (ref->u.ss.start);
2203           gfc_expr_set_symbols_referenced (ref->u.ss.end);
2204           break;
2205
2206         default:
2207           gcc_unreachable ();
2208           break;
2209         }
2210 }