gcc/fortran/expr.c

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