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