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