gcc/fortran/expr.c

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