gcc/fortran/expr.c

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