gcc/fortran/expr.c

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