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       if ((*check_function) (e->op2) == FAILURE)
1171         return FAILURE;
1172
1173       if (!(et0 (e->op1) == BT_CHARACTER && et0 (e->op2) == BT_CHARACTER)
1174           && !(numeric_type (et0 (e->op1)) && numeric_type (et0 (e->op2))))
1175         {
1176           gfc_error ("Numeric or CHARACTER operands are required in "
1177                      "expression at %L", &e->where);
1178          return FAILURE;
1179         }
1180       break;
1181
1182     case INTRINSIC_PLUS:
1183     case INTRINSIC_MINUS:
1184     case INTRINSIC_TIMES:
1185     case INTRINSIC_DIVIDE:
1186     case INTRINSIC_POWER:
1187       if ((*check_function) (e->op2) == FAILURE)
1188         return FAILURE;
1189
1190       if (!numeric_type (et0 (e->op1)) || !numeric_type (et0 (e->op2)))
1191         goto not_numeric;
1192
1193       if (e->operator == INTRINSIC_POWER
1194           && check_function == check_init_expr && et0 (e->op2) != BT_INTEGER)
1195         {
1196           gfc_error ("Exponent at %L must be INTEGER for an initialization "
1197                      "expression", &e->op2->where);
1198           return FAILURE;
1199         }
1200
1201       break;
1202
1203     case INTRINSIC_CONCAT:
1204       if ((*check_function) (e->op2) == FAILURE)
1205         return FAILURE;
1206
1207       if (et0 (e->op1) != BT_CHARACTER || et0 (e->op2) != BT_CHARACTER)
1208         {
1209           gfc_error ("Concatenation operator in expression at %L "
1210                      "must have two CHARACTER operands", &e->op1->where);
1211           return FAILURE;
1212         }
1213
1214       if (e->op1->ts.kind != e->op2->ts.kind)
1215         {
1216           gfc_error ("Concat operator at %L must concatenate strings of the "
1217                      "same kind", &e->where);
1218           return FAILURE;
1219         }
1220
1221       break;
1222
1223     case INTRINSIC_NOT:
1224       if (et0 (e->op1) != BT_LOGICAL)
1225         {
1226           gfc_error (".NOT. operator in expression at %L must have a LOGICAL "
1227                      "operand", &e->op1->where);
1228           return FAILURE;
1229         }
1230
1231       break;
1232
1233     case INTRINSIC_AND:
1234     case INTRINSIC_OR:
1235     case INTRINSIC_EQV:
1236     case INTRINSIC_NEQV:
1237       if ((*check_function) (e->op2) == FAILURE)
1238         return FAILURE;
1239
1240       if (et0 (e->op1) != BT_LOGICAL || et0 (e->op2) != BT_LOGICAL)
1241         {
1242           gfc_error ("LOGICAL operands are required in expression at %L",
1243                      &e->where);
1244           return FAILURE;
1245         }
1246
1247       break;
1248
1249     default:
1250       gfc_error ("Only intrinsic operators can be used in expression at %L",
1251                  &e->where);
1252       return FAILURE;
1253     }
1254
1255   return SUCCESS;
1256
1257 not_numeric:
1258   gfc_error ("Numeric operands are required in expression at %L", &e->where);
1259
1260   return FAILURE;
1261 }
1262
1263
1264
1265 /* Certain inquiry functions are specifically allowed to have variable
1266    arguments, which is an exception to the normal requirement that an
1267    initialization function have initialization arguments.  We head off
1268    this problem here.  */
1269
1270 static try
1271 check_inquiry (gfc_expr * e)
1272 {
1273   const char *name;
1274
1275   /* FIXME: This should be moved into the intrinsic definitions,
1276      to eliminate this ugly hack.  */
1277   static const char * const inquiry_function[] = {
1278     "digits", "epsilon", "huge", "kind", "maxexponent", "minexponent",
1279     "precision", "radix", "range", "tiny", "bit_size", "size", "shape",
1280     "lbound", "ubound", NULL
1281   };
1282
1283   int i;
1284
1285   name = e->symtree->n.sym->name;
1286
1287   for (i = 0; inquiry_function[i]; i++)
1288     if (strcmp (inquiry_function[i], name) == 0)
1289       break;
1290
1291   if (inquiry_function[i] == NULL)
1292     return FAILURE;
1293
1294   e = e->value.function.actual->expr;
1295
1296   if (e == NULL || e->expr_type != EXPR_VARIABLE)
1297     return FAILURE;
1298
1299   /* At this point we have a numeric inquiry function with a variable
1300      argument.  The type of the variable might be undefined, but we
1301      need it now, because the arguments of these functions are allowed
1302      to be undefined.  */
1303
1304   if (e->ts.type == BT_UNKNOWN)
1305     {
1306       if (e->symtree->n.sym->ts.type == BT_UNKNOWN
1307           && gfc_set_default_type (e->symtree->n.sym, 0, gfc_current_ns)
1308             == FAILURE)
1309         return FAILURE;
1310
1311       e->ts = e->symtree->n.sym->ts;
1312     }
1313
1314   return SUCCESS;
1315 }
1316
1317
1318 /* Verify that an expression is an initialization expression.  A side
1319    effect is that the expression tree is reduced to a single constant
1320    node if all goes well.  This would normally happen when the
1321    expression is constructed but function references are assumed to be
1322    intrinsics in the context of initialization expressions.  If
1323    FAILURE is returned an error message has been generated.  */
1324
1325 static try
1326 check_init_expr (gfc_expr * e)
1327 {
1328   gfc_actual_arglist *ap;
1329   match m;
1330   try t;
1331
1332   if (e == NULL)
1333     return SUCCESS;
1334
1335   switch (e->expr_type)
1336     {
1337     case EXPR_OP:
1338       t = check_intrinsic_op (e, check_init_expr);
1339       if (t == SUCCESS)
1340         t = gfc_simplify_expr (e, 0);
1341
1342       break;
1343
1344     case EXPR_FUNCTION:
1345       t = SUCCESS;
1346
1347       if (check_inquiry (e) != SUCCESS)
1348         {
1349           t = SUCCESS;
1350           for (ap = e->value.function.actual; ap; ap = ap->next)
1351             if (check_init_expr (ap->expr) == FAILURE)
1352               {
1353                 t = FAILURE;
1354                 break;
1355               }
1356         }
1357
1358       if (t == SUCCESS)
1359         {
1360           m = gfc_intrinsic_func_interface (e, 0);
1361
1362           if (m == MATCH_NO)
1363             gfc_error ("Function '%s' in initialization expression at %L "
1364                        "must be an intrinsic function",
1365                        e->symtree->n.sym->name, &e->where);
1366
1367           if (m != MATCH_YES)
1368             t = FAILURE;
1369         }
1370
1371       break;
1372
1373     case EXPR_VARIABLE:
1374       t = SUCCESS;
1375
1376       if (gfc_check_iter_variable (e) == SUCCESS)
1377         break;
1378
1379       if (e->symtree->n.sym->attr.flavor == FL_PARAMETER)
1380         {
1381           t = simplify_parameter_variable (e, 0);
1382           break;
1383         }
1384
1385       gfc_error ("Variable '%s' at %L cannot appear in an initialization "
1386                  "expression", e->symtree->n.sym->name, &e->where);
1387       t = FAILURE;
1388       break;
1389
1390     case EXPR_CONSTANT:
1391     case EXPR_NULL:
1392       t = SUCCESS;
1393       break;
1394
1395     case EXPR_SUBSTRING:
1396       t = check_init_expr (e->op1);
1397       if (t == FAILURE)
1398         break;
1399
1400       t = check_init_expr (e->op2);
1401       if (t == SUCCESS)
1402         t = gfc_simplify_expr (e, 0);
1403
1404       break;
1405
1406     case EXPR_STRUCTURE:
1407       t = gfc_check_constructor (e, check_init_expr);
1408       break;
1409
1410     case EXPR_ARRAY:
1411       t = gfc_check_constructor (e, check_init_expr);
1412       if (t == FAILURE)
1413         break;
1414
1415       t = gfc_expand_constructor (e);
1416       if (t == FAILURE)
1417         break;
1418
1419       t = gfc_check_constructor_type (e);
1420       break;
1421
1422     default:
1423       gfc_internal_error ("check_init_expr(): Unknown expression type");
1424     }
1425
1426   return t;
1427 }
1428
1429
1430 /* Match an initialization expression.  We work by first matching an
1431    expression, then reducing it to a constant.  */
1432
1433 match
1434 gfc_match_init_expr (gfc_expr ** result)
1435 {
1436   gfc_expr *expr;
1437   match m;
1438   try t;
1439
1440   m = gfc_match_expr (&expr);
1441   if (m != MATCH_YES)
1442     return m;
1443
1444   gfc_init_expr = 1;
1445   t = gfc_resolve_expr (expr);
1446   if (t == SUCCESS)
1447     t = check_init_expr (expr);
1448   gfc_init_expr = 0;
1449
1450   if (t == FAILURE)
1451     {
1452       gfc_free_expr (expr);
1453       return MATCH_ERROR;
1454     }
1455
1456   if (expr->expr_type == EXPR_ARRAY
1457       && (gfc_check_constructor_type (expr) == FAILURE
1458           || gfc_expand_constructor (expr) == FAILURE))
1459     {
1460       gfc_free_expr (expr);
1461       return MATCH_ERROR;
1462     }
1463
1464   if (!gfc_is_constant_expr (expr))
1465     gfc_internal_error ("Initialization expression didn't reduce %C");
1466
1467   *result = expr;
1468
1469   return MATCH_YES;
1470 }
1471
1472
1473
1474 static try check_restricted (gfc_expr *);
1475
1476 /* Given an actual argument list, test to see that each argument is a
1477    restricted expression and optionally if the expression type is
1478    integer or character.  */
1479
1480 static try
1481 restricted_args (gfc_actual_arglist * a)
1482 {
1483   for (; a; a = a->next)
1484     {
1485       if (check_restricted (a->expr) == FAILURE)
1486         return FAILURE;
1487     }
1488
1489   return SUCCESS;
1490 }
1491
1492
1493 /************* Restricted/specification expressions *************/
1494
1495
1496 /* Make sure a non-intrinsic function is a specification function.  */
1497
1498 static try
1499 external_spec_function (gfc_expr * e)
1500 {
1501   gfc_symbol *f;
1502
1503   f = e->value.function.esym;
1504
1505   if (f->attr.proc == PROC_ST_FUNCTION)
1506     {
1507       gfc_error ("Specification function '%s' at %L cannot be a statement "
1508                  "function", f->name, &e->where);
1509       return FAILURE;
1510     }
1511
1512   if (f->attr.proc == PROC_INTERNAL)
1513     {
1514       gfc_error ("Specification function '%s' at %L cannot be an internal "
1515                  "function", f->name, &e->where);
1516       return FAILURE;
1517     }
1518
1519   if (!f->attr.pure)
1520     {
1521       gfc_error ("Specification function '%s' at %L must be PURE", f->name,
1522                  &e->where);
1523       return FAILURE;
1524     }
1525
1526   if (f->attr.recursive)
1527     {
1528       gfc_error ("Specification function '%s' at %L cannot be RECURSIVE",
1529                  f->name, &e->where);
1530       return FAILURE;
1531     }
1532
1533   return restricted_args (e->value.function.actual);
1534 }
1535
1536
1537 /* Check to see that a function reference to an intrinsic is a
1538    restricted expression.  */
1539
1540 static try
1541 restricted_intrinsic (gfc_expr * e)
1542 {
1543   /* TODO: Check constraints on inquiry functions.  7.1.6.2 (7).  */
1544   if (check_inquiry (e) == SUCCESS)
1545     return SUCCESS;
1546
1547   return restricted_args (e->value.function.actual);
1548 }
1549
1550
1551 /* Verify that an expression is a restricted expression.  Like its
1552    cousin check_init_expr(), an error message is generated if we
1553    return FAILURE.  */
1554
1555 static try
1556 check_restricted (gfc_expr * e)
1557 {
1558   gfc_symbol *sym;
1559   try t;
1560
1561   if (e == NULL)
1562     return SUCCESS;
1563
1564   switch (e->expr_type)
1565     {
1566     case EXPR_OP:
1567       t = check_intrinsic_op (e, check_restricted);
1568       if (t == SUCCESS)
1569         t = gfc_simplify_expr (e, 0);
1570
1571       break;
1572
1573     case EXPR_FUNCTION:
1574       t = e->value.function.esym ?
1575         external_spec_function (e) : restricted_intrinsic (e);
1576
1577       break;
1578
1579     case EXPR_VARIABLE:
1580       sym = e->symtree->n.sym;
1581       t = FAILURE;
1582
1583       if (sym->attr.optional)
1584         {
1585           gfc_error ("Dummy argument '%s' at %L cannot be OPTIONAL",
1586                      sym->name, &e->where);
1587           break;
1588         }
1589
1590       if (sym->attr.intent == INTENT_OUT)
1591         {
1592           gfc_error ("Dummy argument '%s' at %L cannot be INTENT(OUT)",
1593                      sym->name, &e->where);
1594           break;
1595         }
1596
1597       if (sym->attr.in_common
1598           || sym->attr.use_assoc
1599           || sym->attr.dummy
1600           || sym->ns != gfc_current_ns
1601           || (sym->ns->proc_name != NULL
1602               && sym->ns->proc_name->attr.flavor == FL_MODULE))
1603         {
1604           t = SUCCESS;
1605           break;
1606         }
1607
1608       gfc_error ("Variable '%s' cannot appear in the expression at %L",
1609                  sym->name, &e->where);
1610
1611       break;
1612
1613     case EXPR_NULL:
1614     case EXPR_CONSTANT:
1615       t = SUCCESS;
1616       break;
1617
1618     case EXPR_SUBSTRING:
1619       t = gfc_specification_expr (e->op1);
1620       if (t == FAILURE)
1621         break;
1622
1623       t = gfc_specification_expr (e->op2);
1624       if (t == SUCCESS)
1625         t = gfc_simplify_expr (e, 0);
1626
1627       break;
1628
1629     case EXPR_STRUCTURE:
1630       t = gfc_check_constructor (e, check_restricted);
1631       break;
1632
1633     case EXPR_ARRAY:
1634       t = gfc_check_constructor (e, check_restricted);
1635       break;
1636
1637     default:
1638       gfc_internal_error ("check_restricted(): Unknown expression type");
1639     }
1640
1641   return t;
1642 }
1643
1644
1645 /* Check to see that an expression is a specification expression.  If
1646    we return FAILURE, an error has been generated.  */
1647
1648 try
1649 gfc_specification_expr (gfc_expr * e)
1650 {
1651
1652   if (e->ts.type != BT_INTEGER)
1653     {
1654       gfc_error ("Expression at %L must be of INTEGER type", &e->where);
1655       return FAILURE;
1656     }
1657
1658   if (e->rank != 0)
1659     {
1660       gfc_error ("Expression at %L must be scalar", &e->where);
1661       return FAILURE;
1662     }
1663
1664   if (gfc_simplify_expr (e, 0) == FAILURE)
1665     return FAILURE;
1666
1667   return check_restricted (e);
1668 }
1669
1670
1671 /************** Expression conformance checks.  *************/
1672
1673 /* Given two expressions, make sure that the arrays are conformable.  */
1674
1675 try
1676 gfc_check_conformance (const char *optype, gfc_expr * op1, gfc_expr * op2)
1677 {
1678   int op1_flag, op2_flag, d;
1679   mpz_t op1_size, op2_size;
1680   try t;
1681
1682   if (op1->rank == 0 || op2->rank == 0)
1683     return SUCCESS;
1684
1685   if (op1->rank != op2->rank)
1686     {
1687       gfc_error ("Incompatible ranks in %s at %L", optype, &op1->where);
1688       return FAILURE;
1689     }
1690
1691   t = SUCCESS;
1692
1693   for (d = 0; d < op1->rank; d++)
1694     {
1695       op1_flag = gfc_array_dimen_size (op1, d, &op1_size) == SUCCESS;
1696       op2_flag = gfc_array_dimen_size (op2, d, &op2_size) == SUCCESS;
1697
1698       if (op1_flag && op2_flag && mpz_cmp (op1_size, op2_size) != 0)
1699         {
1700           gfc_error ("%s at %L has different shape on dimension %d (%d/%d)",
1701                      optype, &op1->where, d + 1, (int) mpz_get_si (op1_size),
1702                      (int) mpz_get_si (op2_size));
1703
1704           t = FAILURE;
1705         }
1706
1707       if (op1_flag)
1708         mpz_clear (op1_size);
1709       if (op2_flag)
1710         mpz_clear (op2_size);
1711
1712       if (t == FAILURE)
1713         return FAILURE;
1714     }
1715
1716   return SUCCESS;
1717 }
1718
1719
1720 /* Given an assignable expression and an arbitrary expression, make
1721    sure that the assignment can take place.  */
1722
1723 try
1724 gfc_check_assign (gfc_expr * lvalue, gfc_expr * rvalue, int conform)
1725 {
1726   gfc_symbol *sym;
1727
1728   sym = lvalue->symtree->n.sym;
1729
1730   if (sym->attr.intent == INTENT_IN)
1731     {
1732       gfc_error ("Can't assign to INTENT(IN) variable '%s' at %L",
1733                  sym->name, &lvalue->where);
1734       return FAILURE;
1735     }
1736
1737   if (rvalue->rank != 0 && lvalue->rank != rvalue->rank)
1738     {
1739       gfc_error ("Incompatible ranks in assignment at %L", &lvalue->where);
1740       return FAILURE;
1741     }
1742
1743   if (lvalue->ts.type == BT_UNKNOWN)
1744     {
1745       gfc_error ("Variable type is UNKNOWN in assignment at %L",
1746                  &lvalue->where);
1747       return FAILURE;
1748     }
1749
1750   /* Check size of array assignments.  */
1751   if (lvalue->rank != 0 && rvalue->rank != 0
1752       && gfc_check_conformance ("Array assignment", lvalue, rvalue) != SUCCESS)
1753     return FAILURE;
1754
1755   if (gfc_compare_types (&lvalue->ts, &rvalue->ts))
1756     return SUCCESS;
1757
1758   if (!conform)
1759     {
1760       if (gfc_numeric_ts (&lvalue->ts) && gfc_numeric_ts (&rvalue->ts))
1761         return SUCCESS;
1762
1763       gfc_error ("Incompatible types in assignment at %L, %s to %s",
1764                  &rvalue->where, gfc_typename (&rvalue->ts),
1765                  gfc_typename (&lvalue->ts));
1766
1767       return FAILURE;
1768     }
1769
1770   return gfc_convert_type (rvalue, &lvalue->ts, 1);
1771 }
1772
1773
1774 /* Check that a pointer assignment is OK.  We first check lvalue, and
1775    we only check rvalue if it's not an assignment to NULL() or a
1776    NULLIFY statement.  */
1777
1778 try
1779 gfc_check_pointer_assign (gfc_expr * lvalue, gfc_expr * rvalue)
1780 {
1781   symbol_attribute attr;
1782   int is_pure;
1783
1784   if (lvalue->symtree->n.sym->ts.type == BT_UNKNOWN)
1785     {
1786       gfc_error ("Pointer assignment target is not a POINTER at %L",
1787                  &lvalue->where);
1788       return FAILURE;
1789     }
1790
1791   attr = gfc_variable_attr (lvalue, NULL);
1792   if (!attr.pointer)
1793     {
1794       gfc_error ("Pointer assignment to non-POINTER at %L", &lvalue->where);
1795       return FAILURE;
1796     }
1797
1798   is_pure = gfc_pure (NULL);
1799
1800   if (is_pure && gfc_impure_variable (lvalue->symtree->n.sym))
1801     {
1802       gfc_error ("Bad pointer object in PURE procedure at %L",
1803                  &lvalue->where);
1804       return FAILURE;
1805     }
1806
1807   /* If rvalue is a NULL() or NULLIFY, we're done. Otherwise the type,
1808      kind, etc for lvalue and rvalue must match, and rvalue must be a
1809      pure variable if we're in a pure function.  */
1810   if (rvalue->expr_type != EXPR_NULL)
1811     {
1812
1813       if (!gfc_compare_types (&lvalue->ts, &rvalue->ts))
1814         {
1815           gfc_error ("Different types in pointer assignment at %L",
1816                      &lvalue->where);
1817           return FAILURE;
1818         }
1819
1820       if (lvalue->ts.kind != rvalue->ts.kind)
1821         {
1822           gfc_error
1823             ("Different kind type parameters in pointer assignment at %L",
1824              &lvalue->where);
1825           return FAILURE;
1826         }
1827
1828       attr = gfc_expr_attr (rvalue);
1829       if (!attr.target && !attr.pointer)
1830         {
1831           gfc_error
1832             ("Pointer assignment target is neither TARGET nor POINTER at "
1833              "%L", &rvalue->where);
1834           return FAILURE;
1835         }
1836
1837       if (is_pure && gfc_impure_variable (rvalue->symtree->n.sym))
1838         {
1839           gfc_error
1840             ("Bad target in pointer assignment in PURE procedure at %L",
1841              &rvalue->where);
1842         }
1843     }
1844
1845   return SUCCESS;
1846 }
1847
1848
1849 /* Relative of gfc_check_assign() except that the lvalue is a single
1850    symbol.  */
1851
1852 try
1853 gfc_check_assign_symbol (gfc_symbol * sym, gfc_expr * rvalue)
1854 {
1855   gfc_expr lvalue;
1856   try r;
1857
1858   memset (&lvalue, '\0', sizeof (gfc_expr));
1859
1860   lvalue.expr_type = EXPR_VARIABLE;
1861   lvalue.ts = sym->ts;
1862   if (sym->as)
1863     lvalue.rank = sym->as->rank;
1864   lvalue.symtree = (gfc_symtree *)gfc_getmem (sizeof (gfc_symtree));
1865   lvalue.symtree->n.sym = sym;
1866   lvalue.where = sym->declared_at;
1867
1868   r = gfc_check_assign (&lvalue, rvalue, 1);
1869
1870   gfc_free (lvalue.symtree);
1871
1872   return r;
1873 }
1874
1875
1876 /* Get an expression for a default initializer.  */
1877
1878 gfc_expr *
1879 gfc_default_initializer (gfc_typespec *ts)
1880 {
1881   gfc_constructor *tail;
1882   gfc_expr *init;
1883   gfc_component *c;
1884
1885   init = NULL;
1886
1887   /* See if we have a default initializer.  */
1888   for (c = ts->derived->components; c; c = c->next)
1889     {
1890       if (c->initializer && init == NULL)
1891         init = gfc_get_expr ();
1892     }
1893
1894   if (init == NULL)
1895     return NULL;
1896
1897   /* Build the constructor.  */
1898   init->expr_type = EXPR_STRUCTURE;
1899   init->ts = *ts;
1900   init->where = ts->derived->declared_at;
1901   tail = NULL;
1902   for (c = ts->derived->components; c; c = c->next)
1903     {
1904       if (tail == NULL)
1905         init->value.constructor = tail = gfc_get_constructor ();
1906       else
1907         {
1908           tail->next = gfc_get_constructor ();
1909           tail = tail->next;
1910         }
1911
1912       if (c->initializer)
1913         tail->expr = gfc_copy_expr (c->initializer);
1914     }
1915   return init;
1916 }