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