OSDN Git Service

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