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", "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 a numeric inquiry function with a variable
1380      argument.  The type of the variable might be undefined, but we
1381      need it now, because the arguments of these functions are allowed
1382      to be undefined.  */
1383
1384   if (e->ts.type == BT_UNKNOWN)
1385     {
1386       if (e->symtree->n.sym->ts.type == BT_UNKNOWN
1387           && gfc_set_default_type (e->symtree->n.sym, 0, gfc_current_ns)
1388             == FAILURE)
1389         return FAILURE;
1390
1391       e->ts = e->symtree->n.sym->ts;
1392     }
1393
1394   return SUCCESS;
1395 }
1396
1397
1398 /* Verify that an expression is an initialization expression.  A side
1399    effect is that the expression tree is reduced to a single constant
1400    node if all goes well.  This would normally happen when the
1401    expression is constructed but function references are assumed to be
1402    intrinsics in the context of initialization expressions.  If
1403    FAILURE is returned an error message has been generated.  */
1404
1405 static try
1406 check_init_expr (gfc_expr * e)
1407 {
1408   gfc_actual_arglist *ap;
1409   match m;
1410   try t;
1411
1412   if (e == NULL)
1413     return SUCCESS;
1414
1415   switch (e->expr_type)
1416     {
1417     case EXPR_OP:
1418       t = check_intrinsic_op (e, check_init_expr);
1419       if (t == SUCCESS)
1420         t = gfc_simplify_expr (e, 0);
1421
1422       break;
1423
1424     case EXPR_FUNCTION:
1425       t = SUCCESS;
1426
1427       if (check_inquiry (e) != SUCCESS)
1428         {
1429           t = SUCCESS;
1430           for (ap = e->value.function.actual; ap; ap = ap->next)
1431             if (check_init_expr (ap->expr) == FAILURE)
1432               {
1433                 t = FAILURE;
1434                 break;
1435               }
1436         }
1437
1438       if (t == SUCCESS)
1439         {
1440           m = gfc_intrinsic_func_interface (e, 0);
1441
1442           if (m == MATCH_NO)
1443             gfc_error ("Function '%s' in initialization expression at %L "
1444                        "must be an intrinsic function",
1445                        e->symtree->n.sym->name, &e->where);
1446
1447           if (m != MATCH_YES)
1448             t = FAILURE;
1449         }
1450
1451       break;
1452
1453     case EXPR_VARIABLE:
1454       t = SUCCESS;
1455
1456       if (gfc_check_iter_variable (e) == SUCCESS)
1457         break;
1458
1459       if (e->symtree->n.sym->attr.flavor == FL_PARAMETER)
1460         {
1461           t = simplify_parameter_variable (e, 0);
1462           break;
1463         }
1464
1465       gfc_error ("Variable '%s' at %L cannot appear in an initialization "
1466                  "expression", e->symtree->n.sym->name, &e->where);
1467       t = FAILURE;
1468       break;
1469
1470     case EXPR_CONSTANT:
1471     case EXPR_NULL:
1472       t = SUCCESS;
1473       break;
1474
1475     case EXPR_SUBSTRING:
1476       t = check_init_expr (e->ref->u.ss.start);
1477       if (t == FAILURE)
1478         break;
1479
1480       t = check_init_expr (e->ref->u.ss.end);
1481       if (t == SUCCESS)
1482         t = gfc_simplify_expr (e, 0);
1483
1484       break;
1485
1486     case EXPR_STRUCTURE:
1487       t = gfc_check_constructor (e, check_init_expr);
1488       break;
1489
1490     case EXPR_ARRAY:
1491       t = gfc_check_constructor (e, check_init_expr);
1492       if (t == FAILURE)
1493         break;
1494
1495       t = gfc_expand_constructor (e);
1496       if (t == FAILURE)
1497         break;
1498
1499       t = gfc_check_constructor_type (e);
1500       break;
1501
1502     default:
1503       gfc_internal_error ("check_init_expr(): Unknown expression type");
1504     }
1505
1506   return t;
1507 }
1508
1509
1510 /* Match an initialization expression.  We work by first matching an
1511    expression, then reducing it to a constant.  */
1512
1513 match
1514 gfc_match_init_expr (gfc_expr ** result)
1515 {
1516   gfc_expr *expr;
1517   match m;
1518   try t;
1519
1520   m = gfc_match_expr (&expr);
1521   if (m != MATCH_YES)
1522     return m;
1523
1524   gfc_init_expr = 1;
1525   t = gfc_resolve_expr (expr);
1526   if (t == SUCCESS)
1527     t = check_init_expr (expr);
1528   gfc_init_expr = 0;
1529
1530   if (t == FAILURE)
1531     {
1532       gfc_free_expr (expr);
1533       return MATCH_ERROR;
1534     }
1535
1536   if (expr->expr_type == EXPR_ARRAY
1537       && (gfc_check_constructor_type (expr) == FAILURE
1538           || gfc_expand_constructor (expr) == FAILURE))
1539     {
1540       gfc_free_expr (expr);
1541       return MATCH_ERROR;
1542     }
1543
1544   if (!gfc_is_constant_expr (expr))
1545     gfc_internal_error ("Initialization expression didn't reduce %C");
1546
1547   *result = expr;
1548
1549   return MATCH_YES;
1550 }
1551
1552
1553
1554 static try check_restricted (gfc_expr *);
1555
1556 /* Given an actual argument list, test to see that each argument is a
1557    restricted expression and optionally if the expression type is
1558    integer or character.  */
1559
1560 static try
1561 restricted_args (gfc_actual_arglist * a)
1562 {
1563   for (; a; a = a->next)
1564     {
1565       if (check_restricted (a->expr) == FAILURE)
1566         return FAILURE;
1567     }
1568
1569   return SUCCESS;
1570 }
1571
1572
1573 /************* Restricted/specification expressions *************/
1574
1575
1576 /* Make sure a non-intrinsic function is a specification function.  */
1577
1578 static try
1579 external_spec_function (gfc_expr * e)
1580 {
1581   gfc_symbol *f;
1582
1583   f = e->value.function.esym;
1584
1585   if (f->attr.proc == PROC_ST_FUNCTION)
1586     {
1587       gfc_error ("Specification function '%s' at %L cannot be a statement "
1588                  "function", f->name, &e->where);
1589       return FAILURE;
1590     }
1591
1592   if (f->attr.proc == PROC_INTERNAL)
1593     {
1594       gfc_error ("Specification function '%s' at %L cannot be an internal "
1595                  "function", f->name, &e->where);
1596       return FAILURE;
1597     }
1598
1599   if (!f->attr.pure)
1600     {
1601       gfc_error ("Specification function '%s' at %L must be PURE", f->name,
1602                  &e->where);
1603       return FAILURE;
1604     }
1605
1606   if (f->attr.recursive)
1607     {
1608       gfc_error ("Specification function '%s' at %L cannot be RECURSIVE",
1609                  f->name, &e->where);
1610       return FAILURE;
1611     }
1612
1613   return restricted_args (e->value.function.actual);
1614 }
1615
1616
1617 /* Check to see that a function reference to an intrinsic is a
1618    restricted expression.  */
1619
1620 static try
1621 restricted_intrinsic (gfc_expr * e)
1622 {
1623   /* TODO: Check constraints on inquiry functions.  7.1.6.2 (7).  */
1624   if (check_inquiry (e) == SUCCESS)
1625     return SUCCESS;
1626
1627   return restricted_args (e->value.function.actual);
1628 }
1629
1630
1631 /* Verify that an expression is a restricted expression.  Like its
1632    cousin check_init_expr(), an error message is generated if we
1633    return FAILURE.  */
1634
1635 static try
1636 check_restricted (gfc_expr * e)
1637 {
1638   gfc_symbol *sym;
1639   try t;
1640
1641   if (e == NULL)
1642     return SUCCESS;
1643
1644   switch (e->expr_type)
1645     {
1646     case EXPR_OP:
1647       t = check_intrinsic_op (e, check_restricted);
1648       if (t == SUCCESS)
1649         t = gfc_simplify_expr (e, 0);
1650
1651       break;
1652
1653     case EXPR_FUNCTION:
1654       t = e->value.function.esym ?
1655         external_spec_function (e) : restricted_intrinsic (e);
1656
1657       break;
1658
1659     case EXPR_VARIABLE:
1660       sym = e->symtree->n.sym;
1661       t = FAILURE;
1662
1663       if (sym->attr.optional)
1664         {
1665           gfc_error ("Dummy argument '%s' at %L cannot be OPTIONAL",
1666                      sym->name, &e->where);
1667           break;
1668         }
1669
1670       if (sym->attr.intent == INTENT_OUT)
1671         {
1672           gfc_error ("Dummy argument '%s' at %L cannot be INTENT(OUT)",
1673                      sym->name, &e->where);
1674           break;
1675         }
1676
1677       if (sym->attr.in_common
1678           || sym->attr.use_assoc
1679           || sym->attr.dummy
1680           || sym->ns != gfc_current_ns
1681           || (sym->ns->proc_name != NULL
1682               && sym->ns->proc_name->attr.flavor == FL_MODULE))
1683         {
1684           t = SUCCESS;
1685           break;
1686         }
1687
1688       gfc_error ("Variable '%s' cannot appear in the expression at %L",
1689                  sym->name, &e->where);
1690
1691       break;
1692
1693     case EXPR_NULL:
1694     case EXPR_CONSTANT:
1695       t = SUCCESS;
1696       break;
1697
1698     case EXPR_SUBSTRING:
1699       t = gfc_specification_expr (e->ref->u.ss.start);
1700       if (t == FAILURE)
1701         break;
1702
1703       t = gfc_specification_expr (e->ref->u.ss.end);
1704       if (t == SUCCESS)
1705         t = gfc_simplify_expr (e, 0);
1706
1707       break;
1708
1709     case EXPR_STRUCTURE:
1710       t = gfc_check_constructor (e, check_restricted);
1711       break;
1712
1713     case EXPR_ARRAY:
1714       t = gfc_check_constructor (e, check_restricted);
1715       break;
1716
1717     default:
1718       gfc_internal_error ("check_restricted(): Unknown expression type");
1719     }
1720
1721   return t;
1722 }
1723
1724
1725 /* Check to see that an expression is a specification expression.  If
1726    we return FAILURE, an error has been generated.  */
1727
1728 try
1729 gfc_specification_expr (gfc_expr * e)
1730 {
1731
1732   if (e->ts.type != BT_INTEGER)
1733     {
1734       gfc_error ("Expression at %L must be of INTEGER type", &e->where);
1735       return FAILURE;
1736     }
1737
1738   if (e->rank != 0)
1739     {
1740       gfc_error ("Expression at %L must be scalar", &e->where);
1741       return FAILURE;
1742     }
1743
1744   if (gfc_simplify_expr (e, 0) == FAILURE)
1745     return FAILURE;
1746
1747   return check_restricted (e);
1748 }
1749
1750
1751 /************** Expression conformance checks.  *************/
1752
1753 /* Given two expressions, make sure that the arrays are conformable.  */
1754
1755 try
1756 gfc_check_conformance (const char *optype_msgid,
1757                        gfc_expr * op1, gfc_expr * op2)
1758 {
1759   int op1_flag, op2_flag, d;
1760   mpz_t op1_size, op2_size;
1761   try t;
1762
1763   if (op1->rank == 0 || op2->rank == 0)
1764     return SUCCESS;
1765
1766   if (op1->rank != op2->rank)
1767     {
1768       gfc_error ("Incompatible ranks in %s at %L", _(optype_msgid),
1769                  &op1->where);
1770       return FAILURE;
1771     }
1772
1773   t = SUCCESS;
1774
1775   for (d = 0; d < op1->rank; d++)
1776     {
1777       op1_flag = gfc_array_dimen_size (op1, d, &op1_size) == SUCCESS;
1778       op2_flag = gfc_array_dimen_size (op2, d, &op2_size) == SUCCESS;
1779
1780       if (op1_flag && op2_flag && mpz_cmp (op1_size, op2_size) != 0)
1781         {
1782           gfc_error ("%s at %L has different shape on dimension %d (%d/%d)",
1783                      _(optype_msgid), &op1->where, d + 1,
1784                      (int) mpz_get_si (op1_size),
1785                      (int) mpz_get_si (op2_size));
1786
1787           t = FAILURE;
1788         }
1789
1790       if (op1_flag)
1791         mpz_clear (op1_size);
1792       if (op2_flag)
1793         mpz_clear (op2_size);
1794
1795       if (t == FAILURE)
1796         return FAILURE;
1797     }
1798
1799   return SUCCESS;
1800 }
1801
1802
1803 /* Given an assignable expression and an arbitrary expression, make
1804    sure that the assignment can take place.  */
1805
1806 try
1807 gfc_check_assign (gfc_expr * lvalue, gfc_expr * rvalue, int conform)
1808 {
1809   gfc_symbol *sym;
1810
1811   sym = lvalue->symtree->n.sym;
1812
1813   if (sym->attr.intent == INTENT_IN)
1814     {
1815       gfc_error ("Can't assign to INTENT(IN) variable '%s' at %L",
1816                  sym->name, &lvalue->where);
1817       return FAILURE;
1818     }
1819
1820   if (rvalue->rank != 0 && lvalue->rank != rvalue->rank)
1821     {
1822       gfc_error ("Incompatible ranks %d and %d in assignment at %L",
1823                  lvalue->rank, rvalue->rank, &lvalue->where);
1824       return FAILURE;
1825     }
1826
1827   if (lvalue->ts.type == BT_UNKNOWN)
1828     {
1829       gfc_error ("Variable type is UNKNOWN in assignment at %L",
1830                  &lvalue->where);
1831       return FAILURE;
1832     }
1833
1834    if (rvalue->expr_type == EXPR_NULL)
1835      {
1836        gfc_error ("NULL appears on right-hand side in assignment at %L",
1837                   &rvalue->where);
1838        return FAILURE;
1839      }
1840
1841   /* This is possibly a typo: x = f() instead of x => f()  */
1842   if (gfc_option.warn_surprising
1843       && rvalue->expr_type == EXPR_FUNCTION
1844       && rvalue->symtree->n.sym->attr.pointer)
1845     gfc_warning ("POINTER valued function appears on right-hand side of "
1846                  "assignment at %L", &rvalue->where);
1847
1848   /* Check size of array assignments.  */
1849   if (lvalue->rank != 0 && rvalue->rank != 0
1850       && gfc_check_conformance ("Array assignment", lvalue, rvalue) != SUCCESS)
1851     return FAILURE;
1852
1853   if (gfc_compare_types (&lvalue->ts, &rvalue->ts))
1854     return SUCCESS;
1855
1856   if (!conform)
1857     {
1858       /* Numeric can be converted to any other numeric. And Hollerith can be
1859          converted to any other type.  */
1860       if ((gfc_numeric_ts (&lvalue->ts) && gfc_numeric_ts (&rvalue->ts))
1861           || rvalue->ts.type == BT_HOLLERITH)
1862         return SUCCESS;
1863
1864       if (lvalue->ts.type == BT_LOGICAL && rvalue->ts.type == BT_LOGICAL)
1865         return SUCCESS;
1866
1867       gfc_error ("Incompatible types in assignment at %L, %s to %s",
1868                  &rvalue->where, gfc_typename (&rvalue->ts),
1869                  gfc_typename (&lvalue->ts));
1870
1871       return FAILURE;
1872     }
1873
1874   return gfc_convert_type (rvalue, &lvalue->ts, 1);
1875 }
1876
1877
1878 /* Check that a pointer assignment is OK.  We first check lvalue, and
1879    we only check rvalue if it's not an assignment to NULL() or a
1880    NULLIFY statement.  */
1881
1882 try
1883 gfc_check_pointer_assign (gfc_expr * lvalue, gfc_expr * rvalue)
1884 {
1885   symbol_attribute attr;
1886   int is_pure;
1887
1888   if (lvalue->symtree->n.sym->ts.type == BT_UNKNOWN)
1889     {
1890       gfc_error ("Pointer assignment target is not a POINTER at %L",
1891                  &lvalue->where);
1892       return FAILURE;
1893     }
1894
1895   attr = gfc_variable_attr (lvalue, NULL);
1896   if (!attr.pointer)
1897     {
1898       gfc_error ("Pointer assignment to non-POINTER at %L", &lvalue->where);
1899       return FAILURE;
1900     }
1901
1902   is_pure = gfc_pure (NULL);
1903
1904   if (is_pure && gfc_impure_variable (lvalue->symtree->n.sym))
1905     {
1906       gfc_error ("Bad pointer object in PURE procedure at %L",
1907                  &lvalue->where);
1908       return FAILURE;
1909     }
1910
1911   /* If rvalue is a NULL() or NULLIFY, we're done. Otherwise the type,
1912      kind, etc for lvalue and rvalue must match, and rvalue must be a
1913      pure variable if we're in a pure function.  */
1914   if (rvalue->expr_type == EXPR_NULL)
1915     return SUCCESS;
1916
1917   if (!gfc_compare_types (&lvalue->ts, &rvalue->ts))
1918     {
1919       gfc_error ("Different types in pointer assignment at %L",
1920                  &lvalue->where);
1921       return FAILURE;
1922     }
1923
1924   if (lvalue->ts.kind != rvalue->ts.kind)
1925     {
1926       gfc_error ("Different kind type parameters in pointer "
1927                  "assignment at %L", &lvalue->where);
1928       return FAILURE;
1929     }
1930
1931   attr = gfc_expr_attr (rvalue);
1932   if (!attr.target && !attr.pointer)
1933     {
1934       gfc_error ("Pointer assignment target is neither TARGET "
1935                  "nor POINTER at %L", &rvalue->where);
1936       return FAILURE;
1937     }
1938
1939   if (is_pure && gfc_impure_variable (rvalue->symtree->n.sym))
1940     {
1941       gfc_error ("Bad target in pointer assignment in PURE "
1942                  "procedure at %L", &rvalue->where);
1943     }
1944
1945   if (lvalue->rank != rvalue->rank)
1946     {
1947       gfc_error ("Unequal ranks %d and %d in pointer assignment at %L",
1948                  lvalue->rank, rvalue->rank, &rvalue->where);
1949       return FAILURE;
1950     }
1951
1952   return SUCCESS;
1953 }
1954
1955
1956 /* Relative of gfc_check_assign() except that the lvalue is a single
1957    symbol.  Used for initialization assignments.  */
1958
1959 try
1960 gfc_check_assign_symbol (gfc_symbol * sym, gfc_expr * rvalue)
1961 {
1962   gfc_expr lvalue;
1963   try r;
1964
1965   memset (&lvalue, '\0', sizeof (gfc_expr));
1966
1967   lvalue.expr_type = EXPR_VARIABLE;
1968   lvalue.ts = sym->ts;
1969   if (sym->as)
1970     lvalue.rank = sym->as->rank;
1971   lvalue.symtree = (gfc_symtree *)gfc_getmem (sizeof (gfc_symtree));
1972   lvalue.symtree->n.sym = sym;
1973   lvalue.where = sym->declared_at;
1974
1975   if (sym->attr.pointer)
1976     r = gfc_check_pointer_assign (&lvalue, rvalue);
1977   else
1978     r = gfc_check_assign (&lvalue, rvalue, 1);
1979
1980   gfc_free (lvalue.symtree);
1981
1982   return r;
1983 }
1984
1985
1986 /* Get an expression for a default initializer.  */
1987
1988 gfc_expr *
1989 gfc_default_initializer (gfc_typespec *ts)
1990 {
1991   gfc_constructor *tail;
1992   gfc_expr *init;
1993   gfc_component *c;
1994
1995   init = NULL;
1996
1997   /* See if we have a default initializer.  */
1998   for (c = ts->derived->components; c; c = c->next)
1999     {
2000       if (c->initializer && init == NULL)
2001         init = gfc_get_expr ();
2002     }
2003
2004   if (init == NULL)
2005     return NULL;
2006
2007   /* Build the constructor.  */
2008   init->expr_type = EXPR_STRUCTURE;
2009   init->ts = *ts;
2010   init->where = ts->derived->declared_at;
2011   tail = NULL;
2012   for (c = ts->derived->components; c; c = c->next)
2013     {
2014       if (tail == NULL)
2015         init->value.constructor = tail = gfc_get_constructor ();
2016       else
2017         {
2018           tail->next = gfc_get_constructor ();
2019           tail = tail->next;
2020         }
2021
2022       if (c->initializer)
2023         tail->expr = gfc_copy_expr (c->initializer);
2024     }
2025   return init;
2026 }
2027
2028
2029 /* Given a symbol, create an expression node with that symbol as a
2030    variable. If the symbol is array valued, setup a reference of the
2031    whole array.  */
2032
2033 gfc_expr *
2034 gfc_get_variable_expr (gfc_symtree * var)
2035 {
2036   gfc_expr *e;
2037
2038   e = gfc_get_expr ();
2039   e->expr_type = EXPR_VARIABLE;
2040   e->symtree = var;
2041   e->ts = var->n.sym->ts;
2042
2043   if (var->n.sym->as != NULL)
2044     {
2045       e->rank = var->n.sym->as->rank;
2046       e->ref = gfc_get_ref ();
2047       e->ref->type = REF_ARRAY;
2048       e->ref->u.ar.type = AR_FULL;
2049     }
2050
2051   return e;
2052 }
2053