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