OSDN Git Service

12a46a9cbed546b818b5399ea3bea0ccfe6caa07
[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, 2007, 2008,
3    2009, 2010
4    Free Software Foundation, Inc.
5    Contributed by Andy Vaught
6
7 This file is part of GCC.
8
9 GCC is free software; you can redistribute it and/or modify it under
10 the terms of the GNU General Public License as published by the Free
11 Software Foundation; either version 3, or (at your option) any later
12 version.
13
14 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
15 WARRANTY; without even the implied warranty of MERCHANTABILITY or
16 FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
17 for more details.
18
19 You should have received a copy of the GNU General Public License
20 along with GCC; see the file COPYING3.  If not see
21 <http://www.gnu.org/licenses/>.  */
22
23 #include "config.h"
24 #include "system.h"
25 #include "gfortran.h"
26 #include "arith.h"
27 #include "match.h"
28 #include "target-memory.h" /* for gfc_convert_boz */
29 #include "constructor.h"
30
31
32 /* The following set of functions provide access to gfc_expr* of
33    various types - actual all but EXPR_FUNCTION and EXPR_VARIABLE.
34
35    There are two functions available elsewhere that provide
36    slightly different flavours of variables.  Namely:
37      expr.c (gfc_get_variable_expr)
38      symbol.c (gfc_lval_expr_from_sym)
39    TODO: Merge these functions, if possible.  */
40
41 /* Get a new expression node.  */
42
43 gfc_expr *
44 gfc_get_expr (void)
45 {
46   gfc_expr *e;
47
48   e = XCNEW (gfc_expr);
49   gfc_clear_ts (&e->ts);
50   e->shape = NULL;
51   e->ref = NULL;
52   e->symtree = NULL;
53   return e;
54 }
55
56
57 /* Get a new expression node that is an array constructor
58    of given type and kind.  */
59
60 gfc_expr *
61 gfc_get_array_expr (bt type, int kind, locus *where)
62 {
63   gfc_expr *e;
64
65   e = gfc_get_expr ();
66   e->expr_type = EXPR_ARRAY;
67   e->value.constructor = NULL;
68   e->rank = 1;
69   e->shape = NULL;
70
71   e->ts.type = type;
72   e->ts.kind = kind;
73   if (where)
74     e->where = *where;
75
76   return e;
77 }
78
79
80 /* Get a new expression node that is the NULL expression.  */
81
82 gfc_expr *
83 gfc_get_null_expr (locus *where)
84 {
85   gfc_expr *e;
86
87   e = gfc_get_expr ();
88   e->expr_type = EXPR_NULL;
89   e->ts.type = BT_UNKNOWN;
90
91   if (where)
92     e->where = *where;
93
94   return e;
95 }
96
97
98 /* Get a new expression node that is an operator expression node.  */
99
100 gfc_expr *
101 gfc_get_operator_expr (locus *where, gfc_intrinsic_op op,
102                       gfc_expr *op1, gfc_expr *op2)
103 {
104   gfc_expr *e;
105
106   e = gfc_get_expr ();
107   e->expr_type = EXPR_OP;
108   e->value.op.op = op;
109   e->value.op.op1 = op1;
110   e->value.op.op2 = op2;
111
112   if (where)
113     e->where = *where;
114
115   return e;
116 }
117
118
119 /* Get a new expression node that is an structure constructor
120    of given type and kind.  */
121
122 gfc_expr *
123 gfc_get_structure_constructor_expr (bt type, int kind, locus *where)
124 {
125   gfc_expr *e;
126
127   e = gfc_get_expr ();
128   e->expr_type = EXPR_STRUCTURE;
129   e->value.constructor = NULL;
130
131   e->ts.type = type;
132   e->ts.kind = kind;
133   if (where)
134     e->where = *where;
135
136   return e;
137 }
138
139
140 /* Get a new expression node that is an constant of given type and kind.  */
141
142 gfc_expr *
143 gfc_get_constant_expr (bt type, int kind, locus *where)
144 {
145   gfc_expr *e;
146
147   if (!where)
148     gfc_internal_error ("gfc_get_constant_expr(): locus 'where' cannot be NULL");
149
150   e = gfc_get_expr ();
151
152   e->expr_type = EXPR_CONSTANT;
153   e->ts.type = type;
154   e->ts.kind = kind;
155   e->where = *where;
156
157   switch (type)
158     {
159     case BT_INTEGER:
160       mpz_init (e->value.integer);
161       break;
162
163     case BT_REAL:
164       gfc_set_model_kind (kind);
165       mpfr_init (e->value.real);
166       break;
167
168     case BT_COMPLEX:
169       gfc_set_model_kind (kind);
170       mpc_init2 (e->value.complex, mpfr_get_default_prec());
171       break;
172
173     default:
174       break;
175     }
176
177   return e;
178 }
179
180
181 /* Get a new expression node that is an string constant.
182    If no string is passed, a string of len is allocated,
183    blanked and null-terminated.  */
184
185 gfc_expr *
186 gfc_get_character_expr (int kind, locus *where, const char *src, int len)
187 {
188   gfc_expr *e;
189   gfc_char_t *dest;
190
191   if (!src)
192     {
193       dest = gfc_get_wide_string (len + 1);
194       gfc_wide_memset (dest, ' ', len);
195       dest[len] = '\0';
196     }
197   else
198     dest = gfc_char_to_widechar (src);
199
200   e = gfc_get_constant_expr (BT_CHARACTER, kind,
201                             where ? where : &gfc_current_locus);
202   e->value.character.string = dest;
203   e->value.character.length = len;
204
205   return e;
206 }
207
208
209 /* Get a new expression node that is an integer constant.  */
210
211 gfc_expr *
212 gfc_get_int_expr (int kind, locus *where, int value)
213 {
214   gfc_expr *p;
215   p = gfc_get_constant_expr (BT_INTEGER, kind,
216                              where ? where : &gfc_current_locus);
217
218   mpz_init_set_si (p->value.integer, value);
219
220   return p;
221 }
222
223
224 /* Get a new expression node that is a logical constant.  */
225
226 gfc_expr *
227 gfc_get_logical_expr (int kind, locus *where, bool value)
228 {
229   gfc_expr *p;
230   p = gfc_get_constant_expr (BT_LOGICAL, kind,
231                              where ? where : &gfc_current_locus);
232
233   p->value.logical = value;
234
235   return p;
236 }
237
238
239 gfc_expr *
240 gfc_get_iokind_expr (locus *where, io_kind k)
241 {
242   gfc_expr *e;
243
244   /* Set the types to something compatible with iokind. This is needed to
245      get through gfc_free_expr later since iokind really has no Basic Type,
246      BT, of its own.  */
247
248   e = gfc_get_expr ();
249   e->expr_type = EXPR_CONSTANT;
250   e->ts.type = BT_LOGICAL;
251   e->value.iokind = k;
252   e->where = *where;
253
254   return e;
255 }
256
257
258 /* Given an expression pointer, return a copy of the expression.  This
259    subroutine is recursive.  */
260
261 gfc_expr *
262 gfc_copy_expr (gfc_expr *p)
263 {
264   gfc_expr *q;
265   gfc_char_t *s;
266   char *c;
267
268   if (p == NULL)
269     return NULL;
270
271   q = gfc_get_expr ();
272   *q = *p;
273
274   switch (q->expr_type)
275     {
276     case EXPR_SUBSTRING:
277       s = gfc_get_wide_string (p->value.character.length + 1);
278       q->value.character.string = s;
279       memcpy (s, p->value.character.string,
280               (p->value.character.length + 1) * sizeof (gfc_char_t));
281       break;
282
283     case EXPR_CONSTANT:
284       /* Copy target representation, if it exists.  */
285       if (p->representation.string)
286         {
287           c = XCNEWVEC (char, p->representation.length + 1);
288           q->representation.string = c;
289           memcpy (c, p->representation.string, (p->representation.length + 1));
290         }
291
292       /* Copy the values of any pointer components of p->value.  */
293       switch (q->ts.type)
294         {
295         case BT_INTEGER:
296           mpz_init_set (q->value.integer, p->value.integer);
297           break;
298
299         case BT_REAL:
300           gfc_set_model_kind (q->ts.kind);
301           mpfr_init (q->value.real);
302           mpfr_set (q->value.real, p->value.real, GFC_RND_MODE);
303           break;
304
305         case BT_COMPLEX:
306           gfc_set_model_kind (q->ts.kind);
307           mpc_init2 (q->value.complex, mpfr_get_default_prec());
308           mpc_set (q->value.complex, p->value.complex, GFC_MPC_RND_MODE);
309           break;
310
311         case BT_CHARACTER:
312           if (p->representation.string)
313             q->value.character.string
314               = gfc_char_to_widechar (q->representation.string);
315           else
316             {
317               s = gfc_get_wide_string (p->value.character.length + 1);
318               q->value.character.string = s;
319
320               /* This is the case for the C_NULL_CHAR named constant.  */
321               if (p->value.character.length == 0
322                   && (p->ts.is_c_interop || p->ts.is_iso_c))
323                 {
324                   *s = '\0';
325                   /* Need to set the length to 1 to make sure the NUL
326                      terminator is copied.  */
327                   q->value.character.length = 1;
328                 }
329               else
330                 memcpy (s, p->value.character.string,
331                         (p->value.character.length + 1) * sizeof (gfc_char_t));
332             }
333           break;
334
335         case BT_HOLLERITH:
336         case BT_LOGICAL:
337         case BT_DERIVED:
338         case BT_CLASS:
339           break;                /* Already done.  */
340
341         case BT_PROCEDURE:
342         case BT_VOID:
343            /* Should never be reached.  */
344         case BT_UNKNOWN:
345           gfc_internal_error ("gfc_copy_expr(): Bad expr node");
346           /* Not reached.  */
347         }
348
349       break;
350
351     case EXPR_OP:
352       switch (q->value.op.op)
353         {
354         case INTRINSIC_NOT:
355         case INTRINSIC_PARENTHESES:
356         case INTRINSIC_UPLUS:
357         case INTRINSIC_UMINUS:
358           q->value.op.op1 = gfc_copy_expr (p->value.op.op1);
359           break;
360
361         default:                /* Binary operators.  */
362           q->value.op.op1 = gfc_copy_expr (p->value.op.op1);
363           q->value.op.op2 = gfc_copy_expr (p->value.op.op2);
364           break;
365         }
366
367       break;
368
369     case EXPR_FUNCTION:
370       q->value.function.actual =
371         gfc_copy_actual_arglist (p->value.function.actual);
372       break;
373
374     case EXPR_COMPCALL:
375     case EXPR_PPC:
376       q->value.compcall.actual =
377         gfc_copy_actual_arglist (p->value.compcall.actual);
378       q->value.compcall.tbp = p->value.compcall.tbp;
379       break;
380
381     case EXPR_STRUCTURE:
382     case EXPR_ARRAY:
383       q->value.constructor = gfc_constructor_copy (p->value.constructor);
384       break;
385
386     case EXPR_VARIABLE:
387     case EXPR_NULL:
388       break;
389     }
390
391   q->shape = gfc_copy_shape (p->shape, p->rank);
392
393   q->ref = gfc_copy_ref (p->ref);
394
395   return q;
396 }
397
398
399 /* Workhorse function for gfc_free_expr() that frees everything
400    beneath an expression node, but not the node itself.  This is
401    useful when we want to simplify a node and replace it with
402    something else or the expression node belongs to another structure.  */
403
404 static void
405 free_expr0 (gfc_expr *e)
406 {
407   int n;
408
409   switch (e->expr_type)
410     {
411     case EXPR_CONSTANT:
412       /* Free any parts of the value that need freeing.  */
413       switch (e->ts.type)
414         {
415         case BT_INTEGER:
416           mpz_clear (e->value.integer);
417           break;
418
419         case BT_REAL:
420           mpfr_clear (e->value.real);
421           break;
422
423         case BT_CHARACTER:
424           gfc_free (e->value.character.string);
425           break;
426
427         case BT_COMPLEX:
428           mpc_clear (e->value.complex);
429           break;
430
431         default:
432           break;
433         }
434
435       /* Free the representation.  */
436       if (e->representation.string)
437         gfc_free (e->representation.string);
438
439       break;
440
441     case EXPR_OP:
442       if (e->value.op.op1 != NULL)
443         gfc_free_expr (e->value.op.op1);
444       if (e->value.op.op2 != NULL)
445         gfc_free_expr (e->value.op.op2);
446       break;
447
448     case EXPR_FUNCTION:
449       gfc_free_actual_arglist (e->value.function.actual);
450       break;
451
452     case EXPR_COMPCALL:
453     case EXPR_PPC:
454       gfc_free_actual_arglist (e->value.compcall.actual);
455       break;
456
457     case EXPR_VARIABLE:
458       break;
459
460     case EXPR_ARRAY:
461     case EXPR_STRUCTURE:
462       gfc_constructor_free (e->value.constructor);
463       break;
464
465     case EXPR_SUBSTRING:
466       gfc_free (e->value.character.string);
467       break;
468
469     case EXPR_NULL:
470       break;
471
472     default:
473       gfc_internal_error ("free_expr0(): Bad expr type");
474     }
475
476   /* Free a shape array.  */
477   if (e->shape != NULL)
478     {
479       for (n = 0; n < e->rank; n++)
480         mpz_clear (e->shape[n]);
481
482       gfc_free (e->shape);
483     }
484
485   gfc_free_ref_list (e->ref);
486
487   memset (e, '\0', sizeof (gfc_expr));
488 }
489
490
491 /* Free an expression node and everything beneath it.  */
492
493 void
494 gfc_free_expr (gfc_expr *e)
495 {
496   if (e == NULL)
497     return;
498   free_expr0 (e);
499   gfc_free (e);
500 }
501
502
503 /* Free an argument list and everything below it.  */
504
505 void
506 gfc_free_actual_arglist (gfc_actual_arglist *a1)
507 {
508   gfc_actual_arglist *a2;
509
510   while (a1)
511     {
512       a2 = a1->next;
513       gfc_free_expr (a1->expr);
514       gfc_free (a1);
515       a1 = a2;
516     }
517 }
518
519
520 /* Copy an arglist structure and all of the arguments.  */
521
522 gfc_actual_arglist *
523 gfc_copy_actual_arglist (gfc_actual_arglist *p)
524 {
525   gfc_actual_arglist *head, *tail, *new_arg;
526
527   head = tail = NULL;
528
529   for (; p; p = p->next)
530     {
531       new_arg = gfc_get_actual_arglist ();
532       *new_arg = *p;
533
534       new_arg->expr = gfc_copy_expr (p->expr);
535       new_arg->next = NULL;
536
537       if (head == NULL)
538         head = new_arg;
539       else
540         tail->next = new_arg;
541
542       tail = new_arg;
543     }
544
545   return head;
546 }
547
548
549 /* Free a list of reference structures.  */
550
551 void
552 gfc_free_ref_list (gfc_ref *p)
553 {
554   gfc_ref *q;
555   int i;
556
557   for (; p; p = q)
558     {
559       q = p->next;
560
561       switch (p->type)
562         {
563         case REF_ARRAY:
564           for (i = 0; i < GFC_MAX_DIMENSIONS; i++)
565             {
566               gfc_free_expr (p->u.ar.start[i]);
567               gfc_free_expr (p->u.ar.end[i]);
568               gfc_free_expr (p->u.ar.stride[i]);
569             }
570
571           break;
572
573         case REF_SUBSTRING:
574           gfc_free_expr (p->u.ss.start);
575           gfc_free_expr (p->u.ss.end);
576           break;
577
578         case REF_COMPONENT:
579           break;
580         }
581
582       gfc_free (p);
583     }
584 }
585
586
587 /* Graft the *src expression onto the *dest subexpression.  */
588
589 void
590 gfc_replace_expr (gfc_expr *dest, gfc_expr *src)
591 {
592   free_expr0 (dest);
593   *dest = *src;
594   gfc_free (src);
595 }
596
597
598 /* Try to extract an integer constant from the passed expression node.
599    Returns an error message or NULL if the result is set.  It is
600    tempting to generate an error and return SUCCESS or FAILURE, but
601    failure is OK for some callers.  */
602
603 const char *
604 gfc_extract_int (gfc_expr *expr, int *result)
605 {
606   if (expr->expr_type != EXPR_CONSTANT)
607     return _("Constant expression required at %C");
608
609   if (expr->ts.type != BT_INTEGER)
610     return _("Integer expression required at %C");
611
612   if ((mpz_cmp_si (expr->value.integer, INT_MAX) > 0)
613       || (mpz_cmp_si (expr->value.integer, INT_MIN) < 0))
614     {
615       return _("Integer value too large in expression at %C");
616     }
617
618   *result = (int) mpz_get_si (expr->value.integer);
619
620   return NULL;
621 }
622
623
624 /* Recursively copy a list of reference structures.  */
625
626 gfc_ref *
627 gfc_copy_ref (gfc_ref *src)
628 {
629   gfc_array_ref *ar;
630   gfc_ref *dest;
631
632   if (src == NULL)
633     return NULL;
634
635   dest = gfc_get_ref ();
636   dest->type = src->type;
637
638   switch (src->type)
639     {
640     case REF_ARRAY:
641       ar = gfc_copy_array_ref (&src->u.ar);
642       dest->u.ar = *ar;
643       gfc_free (ar);
644       break;
645
646     case REF_COMPONENT:
647       dest->u.c = src->u.c;
648       break;
649
650     case REF_SUBSTRING:
651       dest->u.ss = src->u.ss;
652       dest->u.ss.start = gfc_copy_expr (src->u.ss.start);
653       dest->u.ss.end = gfc_copy_expr (src->u.ss.end);
654       break;
655     }
656
657   dest->next = gfc_copy_ref (src->next);
658
659   return dest;
660 }
661
662
663 /* Detect whether an expression has any vector index array references.  */
664
665 int
666 gfc_has_vector_index (gfc_expr *e)
667 {
668   gfc_ref *ref;
669   int i;
670   for (ref = e->ref; ref; ref = ref->next)
671     if (ref->type == REF_ARRAY)
672       for (i = 0; i < ref->u.ar.dimen; i++)
673         if (ref->u.ar.dimen_type[i] == DIMEN_VECTOR)
674           return 1;
675   return 0;
676 }
677
678
679 /* Copy a shape array.  */
680
681 mpz_t *
682 gfc_copy_shape (mpz_t *shape, int rank)
683 {
684   mpz_t *new_shape;
685   int n;
686
687   if (shape == NULL)
688     return NULL;
689
690   new_shape = gfc_get_shape (rank);
691
692   for (n = 0; n < rank; n++)
693     mpz_init_set (new_shape[n], shape[n]);
694
695   return new_shape;
696 }
697
698
699 /* Copy a shape array excluding dimension N, where N is an integer
700    constant expression.  Dimensions are numbered in fortran style --
701    starting with ONE.
702
703    So, if the original shape array contains R elements
704       { s1 ... sN-1  sN  sN+1 ... sR-1 sR}
705    the result contains R-1 elements:
706       { s1 ... sN-1  sN+1    ...  sR-1}
707
708    If anything goes wrong -- N is not a constant, its value is out
709    of range -- or anything else, just returns NULL.  */
710
711 mpz_t *
712 gfc_copy_shape_excluding (mpz_t *shape, int rank, gfc_expr *dim)
713 {
714   mpz_t *new_shape, *s;
715   int i, n;
716
717   if (shape == NULL 
718       || rank <= 1
719       || dim == NULL
720       || dim->expr_type != EXPR_CONSTANT 
721       || dim->ts.type != BT_INTEGER)
722     return NULL;
723
724   n = mpz_get_si (dim->value.integer);
725   n--; /* Convert to zero based index.  */
726   if (n < 0 || n >= rank)
727     return NULL;
728
729   s = new_shape = gfc_get_shape (rank - 1);
730
731   for (i = 0; i < rank; i++)
732     {
733       if (i == n)
734         continue;
735       mpz_init_set (*s, shape[i]);
736       s++;
737     }
738
739   return new_shape;
740 }
741
742
743 /* Return the maximum kind of two expressions.  In general, higher
744    kind numbers mean more precision for numeric types.  */
745
746 int
747 gfc_kind_max (gfc_expr *e1, gfc_expr *e2)
748 {
749   return (e1->ts.kind > e2->ts.kind) ? e1->ts.kind : e2->ts.kind;
750 }
751
752
753 /* Returns nonzero if the type is numeric, zero otherwise.  */
754
755 static int
756 numeric_type (bt type)
757 {
758   return type == BT_COMPLEX || type == BT_REAL || type == BT_INTEGER;
759 }
760
761
762 /* Returns nonzero if the typespec is a numeric type, zero otherwise.  */
763
764 int
765 gfc_numeric_ts (gfc_typespec *ts)
766 {
767   return numeric_type (ts->type);
768 }
769
770
771 /* Return an expression node with an optional argument list attached.
772    A variable number of gfc_expr pointers are strung together in an
773    argument list with a NULL pointer terminating the list.  */
774
775 gfc_expr *
776 gfc_build_conversion (gfc_expr *e)
777 {
778   gfc_expr *p;
779
780   p = gfc_get_expr ();
781   p->expr_type = EXPR_FUNCTION;
782   p->symtree = NULL;
783   p->value.function.actual = NULL;
784
785   p->value.function.actual = gfc_get_actual_arglist ();
786   p->value.function.actual->expr = e;
787
788   return p;
789 }
790
791
792 /* Given an expression node with some sort of numeric binary
793    expression, insert type conversions required to make the operands
794    have the same type. Conversion warnings are disabled if wconversion
795    is set to 0.
796
797    The exception is that the operands of an exponential don't have to
798    have the same type.  If possible, the base is promoted to the type
799    of the exponent.  For example, 1**2.3 becomes 1.0**2.3, but
800    1.0**2 stays as it is.  */
801
802 void
803 gfc_type_convert_binary (gfc_expr *e, int wconversion)
804 {
805   gfc_expr *op1, *op2;
806
807   op1 = e->value.op.op1;
808   op2 = e->value.op.op2;
809
810   if (op1->ts.type == BT_UNKNOWN || op2->ts.type == BT_UNKNOWN)
811     {
812       gfc_clear_ts (&e->ts);
813       return;
814     }
815
816   /* Kind conversions of same type.  */
817   if (op1->ts.type == op2->ts.type)
818     {
819       if (op1->ts.kind == op2->ts.kind)
820         {
821           /* No type conversions.  */
822           e->ts = op1->ts;
823           goto done;
824         }
825
826       if (op1->ts.kind > op2->ts.kind)
827         gfc_convert_type_warn (op2, &op1->ts, 2, wconversion);
828       else
829         gfc_convert_type_warn (op1, &op2->ts, 2, wconversion);
830
831       e->ts = op1->ts;
832       goto done;
833     }
834
835   /* Integer combined with real or complex.  */
836   if (op2->ts.type == BT_INTEGER)
837     {
838       e->ts = op1->ts;
839
840       /* Special case for ** operator.  */
841       if (e->value.op.op == INTRINSIC_POWER)
842         goto done;
843
844       gfc_convert_type_warn (e->value.op.op2, &e->ts, 2, wconversion);
845       goto done;
846     }
847
848   if (op1->ts.type == BT_INTEGER)
849     {
850       e->ts = op2->ts;
851       gfc_convert_type_warn (e->value.op.op1, &e->ts, 2, wconversion);
852       goto done;
853     }
854
855   /* Real combined with complex.  */
856   e->ts.type = BT_COMPLEX;
857   if (op1->ts.kind > op2->ts.kind)
858     e->ts.kind = op1->ts.kind;
859   else
860     e->ts.kind = op2->ts.kind;
861   if (op1->ts.type != BT_COMPLEX || op1->ts.kind != e->ts.kind)
862     gfc_convert_type_warn (e->value.op.op1, &e->ts, 2, wconversion);
863   if (op2->ts.type != BT_COMPLEX || op2->ts.kind != e->ts.kind)
864     gfc_convert_type_warn (e->value.op.op2, &e->ts, 2, wconversion);
865
866 done:
867   return;
868 }
869
870
871 static match
872 check_specification_function (gfc_expr *e)
873 {
874   gfc_symbol *sym;
875
876   if (!e->symtree)
877     return MATCH_NO;
878
879   sym = e->symtree->n.sym;
880
881   /* F95, 7.1.6.2; F2003, 7.1.7  */
882   if (sym
883       && sym->attr.function
884       && sym->attr.pure
885       && !sym->attr.intrinsic
886       && !sym->attr.recursive
887       && sym->attr.proc != PROC_INTERNAL
888       && sym->attr.proc != PROC_ST_FUNCTION
889       && sym->attr.proc != PROC_UNKNOWN
890       && sym->formal == NULL)
891     return MATCH_YES;
892
893   return MATCH_NO;
894 }
895
896 /* Function to determine if an expression is constant or not.  This
897    function expects that the expression has already been simplified.  */
898
899 int
900 gfc_is_constant_expr (gfc_expr *e)
901 {
902   gfc_constructor *c;
903   gfc_actual_arglist *arg;
904
905   if (e == NULL)
906     return 1;
907
908   switch (e->expr_type)
909     {
910     case EXPR_OP:
911       return (gfc_is_constant_expr (e->value.op.op1)
912               && (e->value.op.op2 == NULL
913                   || gfc_is_constant_expr (e->value.op.op2)));
914
915     case EXPR_VARIABLE:
916       return 0;
917
918     case EXPR_FUNCTION:
919     case EXPR_PPC:
920     case EXPR_COMPCALL:
921       /* Specification functions are constant.  */
922       if (check_specification_function (e) == MATCH_YES)
923         return 1;
924
925       /* Call to intrinsic with at least one argument.  */
926       if (e->value.function.isym && e->value.function.actual)
927         {
928           for (arg = e->value.function.actual; arg; arg = arg->next)
929             if (!gfc_is_constant_expr (arg->expr))
930               return 0;
931
932           return 1;
933         }
934       else
935         return 0;
936
937     case EXPR_CONSTANT:
938     case EXPR_NULL:
939       return 1;
940
941     case EXPR_SUBSTRING:
942       return e->ref == NULL || (gfc_is_constant_expr (e->ref->u.ss.start)
943                                 && gfc_is_constant_expr (e->ref->u.ss.end));
944
945     case EXPR_STRUCTURE:
946       for (c = gfc_constructor_first (e->value.constructor);
947            c; c = gfc_constructor_next (c))
948         if (!gfc_is_constant_expr (c->expr))
949           return 0;
950
951       return 1;
952
953     case EXPR_ARRAY:
954       return gfc_constant_ac (e);
955
956     default:
957       gfc_internal_error ("gfc_is_constant_expr(): Unknown expression type");
958       return 0;
959     }
960 }
961
962
963 /* Is true if an array reference is followed by a component or substring
964    reference.  */
965 bool
966 is_subref_array (gfc_expr * e)
967 {
968   gfc_ref * ref;
969   bool seen_array;
970
971   if (e->expr_type != EXPR_VARIABLE)
972     return false;
973
974   if (e->symtree->n.sym->attr.subref_array_pointer)
975     return true;
976
977   seen_array = false;
978   for (ref = e->ref; ref; ref = ref->next)
979     {
980       if (ref->type == REF_ARRAY
981             && ref->u.ar.type != AR_ELEMENT)
982         seen_array = true;
983
984       if (seen_array
985             && ref->type != REF_ARRAY)
986         return seen_array;
987     }
988   return false;
989 }
990
991
992 /* Try to collapse intrinsic expressions.  */
993
994 static gfc_try
995 simplify_intrinsic_op (gfc_expr *p, int type)
996 {
997   gfc_intrinsic_op op;
998   gfc_expr *op1, *op2, *result;
999
1000   if (p->value.op.op == INTRINSIC_USER)
1001     return SUCCESS;
1002
1003   op1 = p->value.op.op1;
1004   op2 = p->value.op.op2;
1005   op  = p->value.op.op;
1006
1007   if (gfc_simplify_expr (op1, type) == FAILURE)
1008     return FAILURE;
1009   if (gfc_simplify_expr (op2, type) == FAILURE)
1010     return FAILURE;
1011
1012   if (!gfc_is_constant_expr (op1)
1013       || (op2 != NULL && !gfc_is_constant_expr (op2)))
1014     return SUCCESS;
1015
1016   /* Rip p apart.  */
1017   p->value.op.op1 = NULL;
1018   p->value.op.op2 = NULL;
1019
1020   switch (op)
1021     {
1022     case INTRINSIC_PARENTHESES:
1023       result = gfc_parentheses (op1);
1024       break;
1025
1026     case INTRINSIC_UPLUS:
1027       result = gfc_uplus (op1);
1028       break;
1029
1030     case INTRINSIC_UMINUS:
1031       result = gfc_uminus (op1);
1032       break;
1033
1034     case INTRINSIC_PLUS:
1035       result = gfc_add (op1, op2);
1036       break;
1037
1038     case INTRINSIC_MINUS:
1039       result = gfc_subtract (op1, op2);
1040       break;
1041
1042     case INTRINSIC_TIMES:
1043       result = gfc_multiply (op1, op2);
1044       break;
1045
1046     case INTRINSIC_DIVIDE:
1047       result = gfc_divide (op1, op2);
1048       break;
1049
1050     case INTRINSIC_POWER:
1051       result = gfc_power (op1, op2);
1052       break;
1053
1054     case INTRINSIC_CONCAT:
1055       result = gfc_concat (op1, op2);
1056       break;
1057
1058     case INTRINSIC_EQ:
1059     case INTRINSIC_EQ_OS:
1060       result = gfc_eq (op1, op2, op);
1061       break;
1062
1063     case INTRINSIC_NE:
1064     case INTRINSIC_NE_OS:
1065       result = gfc_ne (op1, op2, op);
1066       break;
1067
1068     case INTRINSIC_GT:
1069     case INTRINSIC_GT_OS:
1070       result = gfc_gt (op1, op2, op);
1071       break;
1072
1073     case INTRINSIC_GE:
1074     case INTRINSIC_GE_OS:
1075       result = gfc_ge (op1, op2, op);
1076       break;
1077
1078     case INTRINSIC_LT:
1079     case INTRINSIC_LT_OS:
1080       result = gfc_lt (op1, op2, op);
1081       break;
1082
1083     case INTRINSIC_LE:
1084     case INTRINSIC_LE_OS:
1085       result = gfc_le (op1, op2, op);
1086       break;
1087
1088     case INTRINSIC_NOT:
1089       result = gfc_not (op1);
1090       break;
1091
1092     case INTRINSIC_AND:
1093       result = gfc_and (op1, op2);
1094       break;
1095
1096     case INTRINSIC_OR:
1097       result = gfc_or (op1, op2);
1098       break;
1099
1100     case INTRINSIC_EQV:
1101       result = gfc_eqv (op1, op2);
1102       break;
1103
1104     case INTRINSIC_NEQV:
1105       result = gfc_neqv (op1, op2);
1106       break;
1107
1108     default:
1109       gfc_internal_error ("simplify_intrinsic_op(): Bad operator");
1110     }
1111
1112   if (result == NULL)
1113     {
1114       gfc_free_expr (op1);
1115       gfc_free_expr (op2);
1116       return FAILURE;
1117     }
1118
1119   result->rank = p->rank;
1120   result->where = p->where;
1121   gfc_replace_expr (p, result);
1122
1123   return SUCCESS;
1124 }
1125
1126
1127 /* Subroutine to simplify constructor expressions.  Mutually recursive
1128    with gfc_simplify_expr().  */
1129
1130 static gfc_try
1131 simplify_constructor (gfc_constructor_base base, int type)
1132 {
1133   gfc_constructor *c;
1134   gfc_expr *p;
1135
1136   for (c = gfc_constructor_first (base); c; c = gfc_constructor_next (c))
1137     {
1138       if (c->iterator
1139           && (gfc_simplify_expr (c->iterator->start, type) == FAILURE
1140               || gfc_simplify_expr (c->iterator->end, type) == FAILURE
1141               || gfc_simplify_expr (c->iterator->step, type) == FAILURE))
1142         return FAILURE;
1143
1144       if (c->expr)
1145         {
1146           /* Try and simplify a copy.  Replace the original if successful
1147              but keep going through the constructor at all costs.  Not
1148              doing so can make a dog's dinner of complicated things.  */
1149           p = gfc_copy_expr (c->expr);
1150
1151           if (gfc_simplify_expr (p, type) == FAILURE)
1152             {
1153               gfc_free_expr (p);
1154               continue;
1155             }
1156
1157           gfc_replace_expr (c->expr, p);
1158         }
1159     }
1160
1161   return SUCCESS;
1162 }
1163
1164
1165 /* Pull a single array element out of an array constructor.  */
1166
1167 static gfc_try
1168 find_array_element (gfc_constructor_base base, gfc_array_ref *ar,
1169                     gfc_constructor **rval)
1170 {
1171   unsigned long nelemen;
1172   int i;
1173   mpz_t delta;
1174   mpz_t offset;
1175   mpz_t span;
1176   mpz_t tmp;
1177   gfc_constructor *cons;
1178   gfc_expr *e;
1179   gfc_try t;
1180
1181   t = SUCCESS;
1182   e = NULL;
1183
1184   mpz_init_set_ui (offset, 0);
1185   mpz_init (delta);
1186   mpz_init (tmp);
1187   mpz_init_set_ui (span, 1);
1188   for (i = 0; i < ar->dimen; i++)
1189     {
1190       if (gfc_reduce_init_expr (ar->as->lower[i]) == FAILURE
1191           || gfc_reduce_init_expr (ar->as->upper[i]) == FAILURE)
1192         {
1193           t = FAILURE;
1194           cons = NULL;
1195           goto depart;
1196         }
1197
1198       e = gfc_copy_expr (ar->start[i]);
1199       if (e->expr_type != EXPR_CONSTANT)
1200         {
1201           cons = NULL;
1202           goto depart;
1203         }
1204
1205       gcc_assert (ar->as->upper[i]->expr_type == EXPR_CONSTANT
1206                   && ar->as->lower[i]->expr_type == EXPR_CONSTANT);
1207
1208       /* Check the bounds.  */
1209       if ((ar->as->upper[i]
1210            && mpz_cmp (e->value.integer,
1211                        ar->as->upper[i]->value.integer) > 0)
1212           || (mpz_cmp (e->value.integer,
1213                        ar->as->lower[i]->value.integer) < 0))
1214         {
1215           gfc_error ("Index in dimension %d is out of bounds "
1216                      "at %L", i + 1, &ar->c_where[i]);
1217           cons = NULL;
1218           t = FAILURE;
1219           goto depart;
1220         }
1221
1222       mpz_sub (delta, e->value.integer, ar->as->lower[i]->value.integer);
1223       mpz_mul (delta, delta, span);
1224       mpz_add (offset, offset, delta);
1225
1226       mpz_set_ui (tmp, 1);
1227       mpz_add (tmp, tmp, ar->as->upper[i]->value.integer);
1228       mpz_sub (tmp, tmp, ar->as->lower[i]->value.integer);
1229       mpz_mul (span, span, tmp);
1230     }
1231
1232   for (cons = gfc_constructor_first (base), nelemen = mpz_get_ui (offset);
1233        cons && nelemen > 0; cons = gfc_constructor_next (cons), nelemen--)
1234     {
1235       if (cons->iterator)
1236         {
1237           cons = NULL;
1238           goto depart;
1239         }
1240     }
1241
1242 depart:
1243   mpz_clear (delta);
1244   mpz_clear (offset);
1245   mpz_clear (span);
1246   mpz_clear (tmp);
1247   if (e)
1248     gfc_free_expr (e);
1249   *rval = cons;
1250   return t;
1251 }
1252
1253
1254 /* Find a component of a structure constructor.  */
1255
1256 static gfc_constructor *
1257 find_component_ref (gfc_constructor_base base, gfc_ref *ref)
1258 {
1259   gfc_component *comp;
1260   gfc_component *pick;
1261   gfc_constructor *c = gfc_constructor_first (base);
1262
1263   comp = ref->u.c.sym->components;
1264   pick = ref->u.c.component;
1265   while (comp != pick)
1266     {
1267       comp = comp->next;
1268       c = gfc_constructor_next (c);
1269     }
1270
1271   return c;
1272 }
1273
1274
1275 /* Replace an expression with the contents of a constructor, removing
1276    the subobject reference in the process.  */
1277
1278 static void
1279 remove_subobject_ref (gfc_expr *p, gfc_constructor *cons)
1280 {
1281   gfc_expr *e;
1282
1283   if (cons)
1284     {
1285       e = cons->expr;
1286       cons->expr = NULL;
1287     }
1288   else
1289     e = gfc_copy_expr (p);
1290   e->ref = p->ref->next;
1291   p->ref->next =  NULL;
1292   gfc_replace_expr (p, e);
1293 }
1294
1295
1296 /* Pull an array section out of an array constructor.  */
1297
1298 static gfc_try
1299 find_array_section (gfc_expr *expr, gfc_ref *ref)
1300 {
1301   int idx;
1302   int rank;
1303   int d;
1304   int shape_i;
1305   int limit;
1306   long unsigned one = 1;
1307   bool incr_ctr;
1308   mpz_t start[GFC_MAX_DIMENSIONS];
1309   mpz_t end[GFC_MAX_DIMENSIONS];
1310   mpz_t stride[GFC_MAX_DIMENSIONS];
1311   mpz_t delta[GFC_MAX_DIMENSIONS];
1312   mpz_t ctr[GFC_MAX_DIMENSIONS];
1313   mpz_t delta_mpz;
1314   mpz_t tmp_mpz;
1315   mpz_t nelts;
1316   mpz_t ptr;
1317   gfc_constructor_base base;
1318   gfc_constructor *cons, *vecsub[GFC_MAX_DIMENSIONS];
1319   gfc_expr *begin;
1320   gfc_expr *finish;
1321   gfc_expr *step;
1322   gfc_expr *upper;
1323   gfc_expr *lower;
1324   gfc_try t;
1325
1326   t = SUCCESS;
1327
1328   base = expr->value.constructor;
1329   expr->value.constructor = NULL;
1330
1331   rank = ref->u.ar.as->rank;
1332
1333   if (expr->shape == NULL)
1334     expr->shape = gfc_get_shape (rank);
1335
1336   mpz_init_set_ui (delta_mpz, one);
1337   mpz_init_set_ui (nelts, one);
1338   mpz_init (tmp_mpz);
1339
1340   /* Do the initialization now, so that we can cleanup without
1341      keeping track of where we were.  */
1342   for (d = 0; d < rank; d++)
1343     {
1344       mpz_init (delta[d]);
1345       mpz_init (start[d]);
1346       mpz_init (end[d]);
1347       mpz_init (ctr[d]);
1348       mpz_init (stride[d]);
1349       vecsub[d] = NULL;
1350     }
1351
1352   /* Build the counters to clock through the array reference.  */
1353   shape_i = 0;
1354   for (d = 0; d < rank; d++)
1355     {
1356       /* Make this stretch of code easier on the eye!  */
1357       begin = ref->u.ar.start[d];
1358       finish = ref->u.ar.end[d];
1359       step = ref->u.ar.stride[d];
1360       lower = ref->u.ar.as->lower[d];
1361       upper = ref->u.ar.as->upper[d];
1362
1363       if (ref->u.ar.dimen_type[d] == DIMEN_VECTOR)  /* Vector subscript.  */
1364         {
1365           gfc_constructor *ci;
1366           gcc_assert (begin);
1367
1368           if (begin->expr_type != EXPR_ARRAY || !gfc_is_constant_expr (begin))
1369             {
1370               t = FAILURE;
1371               goto cleanup;
1372             }
1373
1374           gcc_assert (begin->rank == 1);
1375           /* Zero-sized arrays have no shape and no elements, stop early.  */
1376           if (!begin->shape) 
1377             {
1378               mpz_init_set_ui (nelts, 0);
1379               break;
1380             }
1381
1382           vecsub[d] = gfc_constructor_first (begin->value.constructor);
1383           mpz_set (ctr[d], vecsub[d]->expr->value.integer);
1384           mpz_mul (nelts, nelts, begin->shape[0]);
1385           mpz_set (expr->shape[shape_i++], begin->shape[0]);
1386
1387           /* Check bounds.  */
1388           for (ci = vecsub[d]; ci; ci = gfc_constructor_next (ci))
1389             {
1390               if (mpz_cmp (ci->expr->value.integer, upper->value.integer) > 0
1391                   || mpz_cmp (ci->expr->value.integer,
1392                               lower->value.integer) < 0)
1393                 {
1394                   gfc_error ("index in dimension %d is out of bounds "
1395                              "at %L", d + 1, &ref->u.ar.c_where[d]);
1396                   t = FAILURE;
1397                   goto cleanup;
1398                 }
1399             }
1400         }
1401       else
1402         {
1403           if ((begin && begin->expr_type != EXPR_CONSTANT)
1404               || (finish && finish->expr_type != EXPR_CONSTANT)
1405               || (step && step->expr_type != EXPR_CONSTANT))
1406             {
1407               t = FAILURE;
1408               goto cleanup;
1409             }
1410
1411           /* Obtain the stride.  */
1412           if (step)
1413             mpz_set (stride[d], step->value.integer);
1414           else
1415             mpz_set_ui (stride[d], one);
1416
1417           if (mpz_cmp_ui (stride[d], 0) == 0)
1418             mpz_set_ui (stride[d], one);
1419
1420           /* Obtain the start value for the index.  */
1421           if (begin)
1422             mpz_set (start[d], begin->value.integer);
1423           else
1424             mpz_set (start[d], lower->value.integer);
1425
1426           mpz_set (ctr[d], start[d]);
1427
1428           /* Obtain the end value for the index.  */
1429           if (finish)
1430             mpz_set (end[d], finish->value.integer);
1431           else
1432             mpz_set (end[d], upper->value.integer);
1433
1434           /* Separate 'if' because elements sometimes arrive with
1435              non-null end.  */
1436           if (ref->u.ar.dimen_type[d] == DIMEN_ELEMENT)
1437             mpz_set (end [d], begin->value.integer);
1438
1439           /* Check the bounds.  */
1440           if (mpz_cmp (ctr[d], upper->value.integer) > 0
1441               || mpz_cmp (end[d], upper->value.integer) > 0
1442               || mpz_cmp (ctr[d], lower->value.integer) < 0
1443               || mpz_cmp (end[d], lower->value.integer) < 0)
1444             {
1445               gfc_error ("index in dimension %d is out of bounds "
1446                          "at %L", d + 1, &ref->u.ar.c_where[d]);
1447               t = FAILURE;
1448               goto cleanup;
1449             }
1450
1451           /* Calculate the number of elements and the shape.  */
1452           mpz_set (tmp_mpz, stride[d]);
1453           mpz_add (tmp_mpz, end[d], tmp_mpz);
1454           mpz_sub (tmp_mpz, tmp_mpz, ctr[d]);
1455           mpz_div (tmp_mpz, tmp_mpz, stride[d]);
1456           mpz_mul (nelts, nelts, tmp_mpz);
1457
1458           /* An element reference reduces the rank of the expression; don't
1459              add anything to the shape array.  */
1460           if (ref->u.ar.dimen_type[d] != DIMEN_ELEMENT) 
1461             mpz_set (expr->shape[shape_i++], tmp_mpz);
1462         }
1463
1464       /* Calculate the 'stride' (=delta) for conversion of the
1465          counter values into the index along the constructor.  */
1466       mpz_set (delta[d], delta_mpz);
1467       mpz_sub (tmp_mpz, upper->value.integer, lower->value.integer);
1468       mpz_add_ui (tmp_mpz, tmp_mpz, one);
1469       mpz_mul (delta_mpz, delta_mpz, tmp_mpz);
1470     }
1471
1472   mpz_init (ptr);
1473   cons = gfc_constructor_first (base);
1474
1475   /* Now clock through the array reference, calculating the index in
1476      the source constructor and transferring the elements to the new
1477      constructor.  */  
1478   for (idx = 0; idx < (int) mpz_get_si (nelts); idx++)
1479     {
1480       if (ref->u.ar.offset)
1481         mpz_set (ptr, ref->u.ar.offset->value.integer);
1482       else
1483         mpz_init_set_ui (ptr, 0);
1484
1485       incr_ctr = true;
1486       for (d = 0; d < rank; d++)
1487         {
1488           mpz_set (tmp_mpz, ctr[d]);
1489           mpz_sub (tmp_mpz, tmp_mpz, ref->u.ar.as->lower[d]->value.integer);
1490           mpz_mul (tmp_mpz, tmp_mpz, delta[d]);
1491           mpz_add (ptr, ptr, tmp_mpz);
1492
1493           if (!incr_ctr) continue;
1494
1495           if (ref->u.ar.dimen_type[d] == DIMEN_VECTOR) /* Vector subscript.  */
1496             {
1497               gcc_assert(vecsub[d]);
1498
1499               if (!gfc_constructor_next (vecsub[d]))
1500                 vecsub[d] = gfc_constructor_first (ref->u.ar.start[d]->value.constructor);
1501               else
1502                 {
1503                   vecsub[d] = gfc_constructor_next (vecsub[d]);
1504                   incr_ctr = false;
1505                 }
1506               mpz_set (ctr[d], vecsub[d]->expr->value.integer);
1507             }
1508           else
1509             {
1510               mpz_add (ctr[d], ctr[d], stride[d]); 
1511
1512               if (mpz_cmp_ui (stride[d], 0) > 0
1513                   ? mpz_cmp (ctr[d], end[d]) > 0
1514                   : mpz_cmp (ctr[d], end[d]) < 0)
1515                 mpz_set (ctr[d], start[d]);
1516               else
1517                 incr_ctr = false;
1518             }
1519         }
1520
1521       limit = mpz_get_ui (ptr);
1522       if (limit >= gfc_option.flag_max_array_constructor)
1523         {
1524           gfc_error ("The number of elements in the array constructor "
1525                      "at %L requires an increase of the allowed %d "
1526                      "upper limit.   See -fmax-array-constructor "
1527                      "option", &expr->where,
1528                      gfc_option.flag_max_array_constructor);
1529           return FAILURE;
1530         }
1531
1532       cons = gfc_constructor_lookup (base, limit);
1533       gcc_assert (cons);
1534       gfc_constructor_append_expr (&expr->value.constructor,
1535                                    gfc_copy_expr (cons->expr), NULL);
1536     }
1537
1538   mpz_clear (ptr);
1539
1540 cleanup:
1541
1542   mpz_clear (delta_mpz);
1543   mpz_clear (tmp_mpz);
1544   mpz_clear (nelts);
1545   for (d = 0; d < rank; d++)
1546     {
1547       mpz_clear (delta[d]);
1548       mpz_clear (start[d]);
1549       mpz_clear (end[d]);
1550       mpz_clear (ctr[d]);
1551       mpz_clear (stride[d]);
1552     }
1553   gfc_constructor_free (base);
1554   return t;
1555 }
1556
1557 /* Pull a substring out of an expression.  */
1558
1559 static gfc_try
1560 find_substring_ref (gfc_expr *p, gfc_expr **newp)
1561 {
1562   int end;
1563   int start;
1564   int length;
1565   gfc_char_t *chr;
1566
1567   if (p->ref->u.ss.start->expr_type != EXPR_CONSTANT
1568       || p->ref->u.ss.end->expr_type != EXPR_CONSTANT)
1569     return FAILURE;
1570
1571   *newp = gfc_copy_expr (p);
1572   gfc_free ((*newp)->value.character.string);
1573
1574   end = (int) mpz_get_ui (p->ref->u.ss.end->value.integer);
1575   start = (int) mpz_get_ui (p->ref->u.ss.start->value.integer);
1576   length = end - start + 1;
1577
1578   chr = (*newp)->value.character.string = gfc_get_wide_string (length + 1);
1579   (*newp)->value.character.length = length;
1580   memcpy (chr, &p->value.character.string[start - 1],
1581           length * sizeof (gfc_char_t));
1582   chr[length] = '\0';
1583   return SUCCESS;
1584 }
1585
1586
1587
1588 /* Simplify a subobject reference of a constructor.  This occurs when
1589    parameter variable values are substituted.  */
1590
1591 static gfc_try
1592 simplify_const_ref (gfc_expr *p)
1593 {
1594   gfc_constructor *cons, *c;
1595   gfc_expr *newp;
1596   gfc_ref *last_ref;
1597
1598   while (p->ref)
1599     {
1600       switch (p->ref->type)
1601         {
1602         case REF_ARRAY:
1603           switch (p->ref->u.ar.type)
1604             {
1605             case AR_ELEMENT:
1606               /* <type/kind spec>, parameter :: x(<int>) = scalar_expr
1607                  will generate this.  */
1608               if (p->expr_type != EXPR_ARRAY)
1609                 {
1610                   remove_subobject_ref (p, NULL);
1611                   break;
1612                 }
1613               if (find_array_element (p->value.constructor, &p->ref->u.ar,
1614                                       &cons) == FAILURE)
1615                 return FAILURE;
1616
1617               if (!cons)
1618                 return SUCCESS;
1619
1620               remove_subobject_ref (p, cons);
1621               break;
1622
1623             case AR_SECTION:
1624               if (find_array_section (p, p->ref) == FAILURE)
1625                 return FAILURE;
1626               p->ref->u.ar.type = AR_FULL;
1627
1628             /* Fall through.  */
1629
1630             case AR_FULL:
1631               if (p->ref->next != NULL
1632                   && (p->ts.type == BT_CHARACTER || p->ts.type == BT_DERIVED))
1633                 {
1634                   for (c = gfc_constructor_first (p->value.constructor);
1635                        c; c = gfc_constructor_next (c))
1636                     {
1637                       c->expr->ref = gfc_copy_ref (p->ref->next);
1638                       if (simplify_const_ref (c->expr) == FAILURE)
1639                         return FAILURE;
1640                     }
1641
1642                   if (p->ts.type == BT_DERIVED
1643                         && p->ref->next
1644                         && (c = gfc_constructor_first (p->value.constructor)))
1645                     {
1646                       /* There may have been component references.  */
1647                       p->ts = c->expr->ts;
1648                     }
1649
1650                   last_ref = p->ref;
1651                   for (; last_ref->next; last_ref = last_ref->next) {};
1652
1653                   if (p->ts.type == BT_CHARACTER
1654                         && last_ref->type == REF_SUBSTRING)
1655                     {
1656                       /* If this is a CHARACTER array and we possibly took
1657                          a substring out of it, update the type-spec's
1658                          character length according to the first element
1659                          (as all should have the same length).  */
1660                       int string_len;
1661                       if ((c = gfc_constructor_first (p->value.constructor)))
1662                         {
1663                           const gfc_expr* first = c->expr;
1664                           gcc_assert (first->expr_type == EXPR_CONSTANT);
1665                           gcc_assert (first->ts.type == BT_CHARACTER);
1666                           string_len = first->value.character.length;
1667                         }
1668                       else
1669                         string_len = 0;
1670
1671                       if (!p->ts.u.cl)
1672                         p->ts.u.cl = gfc_new_charlen (p->symtree->n.sym->ns,
1673                                                       NULL);
1674                       else
1675                         gfc_free_expr (p->ts.u.cl->length);
1676
1677                       p->ts.u.cl->length
1678                         = gfc_get_int_expr (gfc_default_integer_kind,
1679                                             NULL, string_len);
1680                     }
1681                 }
1682               gfc_free_ref_list (p->ref);
1683               p->ref = NULL;
1684               break;
1685
1686             default:
1687               return SUCCESS;
1688             }
1689
1690           break;
1691
1692         case REF_COMPONENT:
1693           cons = find_component_ref (p->value.constructor, p->ref);
1694           remove_subobject_ref (p, cons);
1695           break;
1696
1697         case REF_SUBSTRING:
1698           if (find_substring_ref (p, &newp) == FAILURE)
1699             return FAILURE;
1700
1701           gfc_replace_expr (p, newp);
1702           gfc_free_ref_list (p->ref);
1703           p->ref = NULL;
1704           break;
1705         }
1706     }
1707
1708   return SUCCESS;
1709 }
1710
1711
1712 /* Simplify a chain of references.  */
1713
1714 static gfc_try
1715 simplify_ref_chain (gfc_ref *ref, int type)
1716 {
1717   int n;
1718
1719   for (; ref; ref = ref->next)
1720     {
1721       switch (ref->type)
1722         {
1723         case REF_ARRAY:
1724           for (n = 0; n < ref->u.ar.dimen; n++)
1725             {
1726               if (gfc_simplify_expr (ref->u.ar.start[n], type) == FAILURE)
1727                 return FAILURE;
1728               if (gfc_simplify_expr (ref->u.ar.end[n], type) == FAILURE)
1729                 return FAILURE;
1730               if (gfc_simplify_expr (ref->u.ar.stride[n], type) == FAILURE)
1731                 return FAILURE;
1732             }
1733           break;
1734
1735         case REF_SUBSTRING:
1736           if (gfc_simplify_expr (ref->u.ss.start, type) == FAILURE)
1737             return FAILURE;
1738           if (gfc_simplify_expr (ref->u.ss.end, type) == FAILURE)
1739             return FAILURE;
1740           break;
1741
1742         default:
1743           break;
1744         }
1745     }
1746   return SUCCESS;
1747 }
1748
1749
1750 /* Try to substitute the value of a parameter variable.  */
1751
1752 static gfc_try
1753 simplify_parameter_variable (gfc_expr *p, int type)
1754 {
1755   gfc_expr *e;
1756   gfc_try t;
1757
1758   e = gfc_copy_expr (p->symtree->n.sym->value);
1759   if (e == NULL)
1760     return FAILURE;
1761
1762   e->rank = p->rank;
1763
1764   /* Do not copy subobject refs for constant.  */
1765   if (e->expr_type != EXPR_CONSTANT && p->ref != NULL)
1766     e->ref = gfc_copy_ref (p->ref);
1767   t = gfc_simplify_expr (e, type);
1768
1769   /* Only use the simplification if it eliminated all subobject references.  */
1770   if (t == SUCCESS && !e->ref)
1771     gfc_replace_expr (p, e);
1772   else
1773     gfc_free_expr (e);
1774
1775   return t;
1776 }
1777
1778 /* Given an expression, simplify it by collapsing constant
1779    expressions.  Most simplification takes place when the expression
1780    tree is being constructed.  If an intrinsic function is simplified
1781    at some point, we get called again to collapse the result against
1782    other constants.
1783
1784    We work by recursively simplifying expression nodes, simplifying
1785    intrinsic functions where possible, which can lead to further
1786    constant collapsing.  If an operator has constant operand(s), we
1787    rip the expression apart, and rebuild it, hoping that it becomes
1788    something simpler.
1789
1790    The expression type is defined for:
1791      0   Basic expression parsing
1792      1   Simplifying array constructors -- will substitute
1793          iterator values.
1794    Returns FAILURE on error, SUCCESS otherwise.
1795    NOTE: Will return SUCCESS even if the expression can not be simplified.  */
1796
1797 gfc_try
1798 gfc_simplify_expr (gfc_expr *p, int type)
1799 {
1800   gfc_actual_arglist *ap;
1801
1802   if (p == NULL)
1803     return SUCCESS;
1804
1805   switch (p->expr_type)
1806     {
1807     case EXPR_CONSTANT:
1808     case EXPR_NULL:
1809       break;
1810
1811     case EXPR_FUNCTION:
1812       for (ap = p->value.function.actual; ap; ap = ap->next)
1813         if (gfc_simplify_expr (ap->expr, type) == FAILURE)
1814           return FAILURE;
1815
1816       if (p->value.function.isym != NULL
1817           && gfc_intrinsic_func_interface (p, 1) == MATCH_ERROR)
1818         return FAILURE;
1819
1820       break;
1821
1822     case EXPR_SUBSTRING:
1823       if (simplify_ref_chain (p->ref, type) == FAILURE)
1824         return FAILURE;
1825
1826       if (gfc_is_constant_expr (p))
1827         {
1828           gfc_char_t *s;
1829           int start, end;
1830
1831           start = 0;
1832           if (p->ref && p->ref->u.ss.start)
1833             {
1834               gfc_extract_int (p->ref->u.ss.start, &start);
1835               start--;  /* Convert from one-based to zero-based.  */
1836             }
1837
1838           end = p->value.character.length;
1839           if (p->ref && p->ref->u.ss.end)
1840             gfc_extract_int (p->ref->u.ss.end, &end);
1841
1842           s = gfc_get_wide_string (end - start + 2);
1843           memcpy (s, p->value.character.string + start,
1844                   (end - start) * sizeof (gfc_char_t));
1845           s[end - start + 1] = '\0';  /* TODO: C-style string.  */
1846           gfc_free (p->value.character.string);
1847           p->value.character.string = s;
1848           p->value.character.length = end - start;
1849           p->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
1850           p->ts.u.cl->length = gfc_get_int_expr (gfc_default_integer_kind,
1851                                                  NULL,
1852                                                  p->value.character.length);
1853           gfc_free_ref_list (p->ref);
1854           p->ref = NULL;
1855           p->expr_type = EXPR_CONSTANT;
1856         }
1857       break;
1858
1859     case EXPR_OP:
1860       if (simplify_intrinsic_op (p, type) == FAILURE)
1861         return FAILURE;
1862       break;
1863
1864     case EXPR_VARIABLE:
1865       /* Only substitute array parameter variables if we are in an
1866          initialization expression, or we want a subsection.  */
1867       if (p->symtree->n.sym->attr.flavor == FL_PARAMETER
1868           && (gfc_init_expr_flag || p->ref
1869               || p->symtree->n.sym->value->expr_type != EXPR_ARRAY))
1870         {
1871           if (simplify_parameter_variable (p, type) == FAILURE)
1872             return FAILURE;
1873           break;
1874         }
1875
1876       if (type == 1)
1877         {
1878           gfc_simplify_iterator_var (p);
1879         }
1880
1881       /* Simplify subcomponent references.  */
1882       if (simplify_ref_chain (p->ref, type) == FAILURE)
1883         return FAILURE;
1884
1885       break;
1886
1887     case EXPR_STRUCTURE:
1888     case EXPR_ARRAY:
1889       if (simplify_ref_chain (p->ref, type) == FAILURE)
1890         return FAILURE;
1891
1892       if (simplify_constructor (p->value.constructor, type) == FAILURE)
1893         return FAILURE;
1894
1895       if (p->expr_type == EXPR_ARRAY && p->ref && p->ref->type == REF_ARRAY
1896           && p->ref->u.ar.type == AR_FULL)
1897           gfc_expand_constructor (p, false);
1898
1899       if (simplify_const_ref (p) == FAILURE)
1900         return FAILURE;
1901
1902       break;
1903
1904     case EXPR_COMPCALL:
1905     case EXPR_PPC:
1906       gcc_unreachable ();
1907       break;
1908     }
1909
1910   return SUCCESS;
1911 }
1912
1913
1914 /* Returns the type of an expression with the exception that iterator
1915    variables are automatically integers no matter what else they may
1916    be declared as.  */
1917
1918 static bt
1919 et0 (gfc_expr *e)
1920 {
1921   if (e->expr_type == EXPR_VARIABLE && gfc_check_iter_variable (e) == SUCCESS)
1922     return BT_INTEGER;
1923
1924   return e->ts.type;
1925 }
1926
1927
1928 /* Check an intrinsic arithmetic operation to see if it is consistent
1929    with some type of expression.  */
1930
1931 static gfc_try check_init_expr (gfc_expr *);
1932
1933
1934 /* Scalarize an expression for an elemental intrinsic call.  */
1935
1936 static gfc_try
1937 scalarize_intrinsic_call (gfc_expr *e)
1938 {
1939   gfc_actual_arglist *a, *b;
1940   gfc_constructor_base ctor;
1941   gfc_constructor *args[5];
1942   gfc_constructor *ci, *new_ctor;
1943   gfc_expr *expr, *old;
1944   int n, i, rank[5], array_arg;
1945   
1946   /* Find which, if any, arguments are arrays.  Assume that the old
1947      expression carries the type information and that the first arg
1948      that is an array expression carries all the shape information.*/
1949   n = array_arg = 0;
1950   a = e->value.function.actual;
1951   for (; a; a = a->next)
1952     {
1953       n++;
1954       if (a->expr->expr_type != EXPR_ARRAY)
1955         continue;
1956       array_arg = n;
1957       expr = gfc_copy_expr (a->expr);
1958       break;
1959     }
1960
1961   if (!array_arg)
1962     return FAILURE;
1963
1964   old = gfc_copy_expr (e);
1965
1966   gfc_constructor_free (expr->value.constructor);
1967   expr->value.constructor = NULL;
1968   expr->ts = old->ts;
1969   expr->where = old->where;
1970   expr->expr_type = EXPR_ARRAY;
1971
1972   /* Copy the array argument constructors into an array, with nulls
1973      for the scalars.  */
1974   n = 0;
1975   a = old->value.function.actual;
1976   for (; a; a = a->next)
1977     {
1978       /* Check that this is OK for an initialization expression.  */
1979       if (a->expr && check_init_expr (a->expr) == FAILURE)
1980         goto cleanup;
1981
1982       rank[n] = 0;
1983       if (a->expr && a->expr->rank && a->expr->expr_type == EXPR_VARIABLE)
1984         {
1985           rank[n] = a->expr->rank;
1986           ctor = a->expr->symtree->n.sym->value->value.constructor;
1987           args[n] = gfc_constructor_first (ctor);
1988         }
1989       else if (a->expr && a->expr->expr_type == EXPR_ARRAY)
1990         {
1991           if (a->expr->rank)
1992             rank[n] = a->expr->rank;
1993           else
1994             rank[n] = 1;
1995           ctor = gfc_constructor_copy (a->expr->value.constructor);
1996           args[n] = gfc_constructor_first (ctor);
1997         }
1998       else
1999         args[n] = NULL;
2000
2001       n++;
2002     }
2003
2004
2005   /* Using the array argument as the master, step through the array
2006      calling the function for each element and advancing the array
2007      constructors together.  */
2008   for (ci = args[array_arg - 1]; ci; ci = gfc_constructor_next (ci))
2009     {
2010       new_ctor = gfc_constructor_append_expr (&expr->value.constructor,
2011                                               gfc_copy_expr (old), NULL);
2012
2013       gfc_free_actual_arglist (new_ctor->expr->value.function.actual);
2014       a = NULL;
2015       b = old->value.function.actual;
2016       for (i = 0; i < n; i++)
2017         {
2018           if (a == NULL)
2019             new_ctor->expr->value.function.actual
2020                         = a = gfc_get_actual_arglist ();
2021           else
2022             {
2023               a->next = gfc_get_actual_arglist ();
2024               a = a->next;
2025             }
2026
2027           if (args[i])
2028             a->expr = gfc_copy_expr (args[i]->expr);
2029           else
2030             a->expr = gfc_copy_expr (b->expr);
2031
2032           b = b->next;
2033         }
2034
2035       /* Simplify the function calls.  If the simplification fails, the
2036          error will be flagged up down-stream or the library will deal
2037          with it.  */
2038       gfc_simplify_expr (new_ctor->expr, 0);
2039
2040       for (i = 0; i < n; i++)
2041         if (args[i])
2042           args[i] = gfc_constructor_next (args[i]);
2043
2044       for (i = 1; i < n; i++)
2045         if (rank[i] && ((args[i] != NULL && args[array_arg - 1] == NULL)
2046                         || (args[i] == NULL && args[array_arg - 1] != NULL)))
2047           goto compliance;
2048     }
2049
2050   free_expr0 (e);
2051   *e = *expr;
2052   gfc_free_expr (old);
2053   return SUCCESS;
2054
2055 compliance:
2056   gfc_error_now ("elemental function arguments at %C are not compliant");
2057
2058 cleanup:
2059   gfc_free_expr (expr);
2060   gfc_free_expr (old);
2061   return FAILURE;
2062 }
2063
2064
2065 static gfc_try
2066 check_intrinsic_op (gfc_expr *e, gfc_try (*check_function) (gfc_expr *))
2067 {
2068   gfc_expr *op1 = e->value.op.op1;
2069   gfc_expr *op2 = e->value.op.op2;
2070
2071   if ((*check_function) (op1) == FAILURE)
2072     return FAILURE;
2073
2074   switch (e->value.op.op)
2075     {
2076     case INTRINSIC_UPLUS:
2077     case INTRINSIC_UMINUS:
2078       if (!numeric_type (et0 (op1)))
2079         goto not_numeric;
2080       break;
2081
2082     case INTRINSIC_EQ:
2083     case INTRINSIC_EQ_OS:
2084     case INTRINSIC_NE:
2085     case INTRINSIC_NE_OS:
2086     case INTRINSIC_GT:
2087     case INTRINSIC_GT_OS:
2088     case INTRINSIC_GE:
2089     case INTRINSIC_GE_OS:
2090     case INTRINSIC_LT:
2091     case INTRINSIC_LT_OS:
2092     case INTRINSIC_LE:
2093     case INTRINSIC_LE_OS:
2094       if ((*check_function) (op2) == FAILURE)
2095         return FAILURE;
2096       
2097       if (!(et0 (op1) == BT_CHARACTER && et0 (op2) == BT_CHARACTER)
2098           && !(numeric_type (et0 (op1)) && numeric_type (et0 (op2))))
2099         {
2100           gfc_error ("Numeric or CHARACTER operands are required in "
2101                      "expression at %L", &e->where);
2102          return FAILURE;
2103         }
2104       break;
2105
2106     case INTRINSIC_PLUS:
2107     case INTRINSIC_MINUS:
2108     case INTRINSIC_TIMES:
2109     case INTRINSIC_DIVIDE:
2110     case INTRINSIC_POWER:
2111       if ((*check_function) (op2) == FAILURE)
2112         return FAILURE;
2113
2114       if (!numeric_type (et0 (op1)) || !numeric_type (et0 (op2)))
2115         goto not_numeric;
2116
2117       break;
2118
2119     case INTRINSIC_CONCAT:
2120       if ((*check_function) (op2) == FAILURE)
2121         return FAILURE;
2122
2123       if (et0 (op1) != BT_CHARACTER || et0 (op2) != BT_CHARACTER)
2124         {
2125           gfc_error ("Concatenation operator in expression at %L "
2126                      "must have two CHARACTER operands", &op1->where);
2127           return FAILURE;
2128         }
2129
2130       if (op1->ts.kind != op2->ts.kind)
2131         {
2132           gfc_error ("Concat operator at %L must concatenate strings of the "
2133                      "same kind", &e->where);
2134           return FAILURE;
2135         }
2136
2137       break;
2138
2139     case INTRINSIC_NOT:
2140       if (et0 (op1) != BT_LOGICAL)
2141         {
2142           gfc_error (".NOT. operator in expression at %L must have a LOGICAL "
2143                      "operand", &op1->where);
2144           return FAILURE;
2145         }
2146
2147       break;
2148
2149     case INTRINSIC_AND:
2150     case INTRINSIC_OR:
2151     case INTRINSIC_EQV:
2152     case INTRINSIC_NEQV:
2153       if ((*check_function) (op2) == FAILURE)
2154         return FAILURE;
2155
2156       if (et0 (op1) != BT_LOGICAL || et0 (op2) != BT_LOGICAL)
2157         {
2158           gfc_error ("LOGICAL operands are required in expression at %L",
2159                      &e->where);
2160           return FAILURE;
2161         }
2162
2163       break;
2164
2165     case INTRINSIC_PARENTHESES:
2166       break;
2167
2168     default:
2169       gfc_error ("Only intrinsic operators can be used in expression at %L",
2170                  &e->where);
2171       return FAILURE;
2172     }
2173
2174   return SUCCESS;
2175
2176 not_numeric:
2177   gfc_error ("Numeric operands are required in expression at %L", &e->where);
2178
2179   return FAILURE;
2180 }
2181
2182 /* F2003, 7.1.7 (3): In init expression, allocatable components
2183    must not be data-initialized.  */
2184 static gfc_try
2185 check_alloc_comp_init (gfc_expr *e)
2186 {
2187   gfc_component *comp;
2188   gfc_constructor *ctor;
2189
2190   gcc_assert (e->expr_type == EXPR_STRUCTURE);
2191   gcc_assert (e->ts.type == BT_DERIVED);
2192
2193   for (comp = e->ts.u.derived->components,
2194        ctor = gfc_constructor_first (e->value.constructor);
2195        comp; comp = comp->next, ctor = gfc_constructor_next (ctor))
2196     {
2197       if (comp->attr.allocatable
2198           && ctor->expr->expr_type != EXPR_NULL)
2199         {
2200           gfc_error("Invalid initialization expression for ALLOCATABLE "
2201                     "component '%s' in structure constructor at %L",
2202                     comp->name, &ctor->expr->where);
2203           return FAILURE;
2204         }
2205     }
2206
2207   return SUCCESS;
2208 }
2209
2210 static match
2211 check_init_expr_arguments (gfc_expr *e)
2212 {
2213   gfc_actual_arglist *ap;
2214
2215   for (ap = e->value.function.actual; ap; ap = ap->next)
2216     if (check_init_expr (ap->expr) == FAILURE)
2217       return MATCH_ERROR;
2218
2219   return MATCH_YES;
2220 }
2221
2222 static gfc_try check_restricted (gfc_expr *);
2223
2224 /* F95, 7.1.6.1, Initialization expressions, (7)
2225    F2003, 7.1.7 Initialization expression, (8)  */
2226
2227 static match
2228 check_inquiry (gfc_expr *e, int not_restricted)
2229 {
2230   const char *name;
2231   const char *const *functions;
2232
2233   static const char *const inquiry_func_f95[] = {
2234     "lbound", "shape", "size", "ubound",
2235     "bit_size", "len", "kind",
2236     "digits", "epsilon", "huge", "maxexponent", "minexponent",
2237     "precision", "radix", "range", "tiny",
2238     NULL
2239   };
2240
2241   static const char *const inquiry_func_f2003[] = {
2242     "lbound", "shape", "size", "ubound",
2243     "bit_size", "len", "kind",
2244     "digits", "epsilon", "huge", "maxexponent", "minexponent",
2245     "precision", "radix", "range", "tiny",
2246     "new_line", NULL
2247   };
2248
2249   int i;
2250   gfc_actual_arglist *ap;
2251
2252   if (!e->value.function.isym
2253       || !e->value.function.isym->inquiry)
2254     return MATCH_NO;
2255
2256   /* An undeclared parameter will get us here (PR25018).  */
2257   if (e->symtree == NULL)
2258     return MATCH_NO;
2259
2260   name = e->symtree->n.sym->name;
2261
2262   functions = (gfc_option.warn_std & GFC_STD_F2003) 
2263                 ? inquiry_func_f2003 : inquiry_func_f95;
2264
2265   for (i = 0; functions[i]; i++)
2266     if (strcmp (functions[i], name) == 0)
2267       break;
2268
2269   if (functions[i] == NULL)
2270     return MATCH_ERROR;
2271
2272   /* At this point we have an inquiry function with a variable argument.  The
2273      type of the variable might be undefined, but we need it now, because the
2274      arguments of these functions are not allowed to be undefined.  */
2275
2276   for (ap = e->value.function.actual; ap; ap = ap->next)
2277     {
2278       if (!ap->expr)
2279         continue;
2280
2281       if (ap->expr->ts.type == BT_UNKNOWN)
2282         {
2283           if (ap->expr->symtree->n.sym->ts.type == BT_UNKNOWN
2284               && gfc_set_default_type (ap->expr->symtree->n.sym, 0, gfc_current_ns)
2285               == FAILURE)
2286             return MATCH_NO;
2287
2288           ap->expr->ts = ap->expr->symtree->n.sym->ts;
2289         }
2290
2291         /* Assumed character length will not reduce to a constant expression
2292            with LEN, as required by the standard.  */
2293         if (i == 5 && not_restricted
2294             && ap->expr->symtree->n.sym->ts.type == BT_CHARACTER
2295             && ap->expr->symtree->n.sym->ts.u.cl->length == NULL)
2296           {
2297             gfc_error ("Assumed character length variable '%s' in constant "
2298                        "expression at %L", e->symtree->n.sym->name, &e->where);
2299               return MATCH_ERROR;
2300           }
2301         else if (not_restricted && check_init_expr (ap->expr) == FAILURE)
2302           return MATCH_ERROR;
2303
2304         if (not_restricted == 0
2305               && ap->expr->expr_type != EXPR_VARIABLE
2306               && check_restricted (ap->expr) == FAILURE)
2307           return MATCH_ERROR;
2308     }
2309
2310   return MATCH_YES;
2311 }
2312
2313
2314 /* F95, 7.1.6.1, Initialization expressions, (5)
2315    F2003, 7.1.7 Initialization expression, (5)  */
2316
2317 static match
2318 check_transformational (gfc_expr *e)
2319 {
2320   static const char * const trans_func_f95[] = {
2321     "repeat", "reshape", "selected_int_kind",
2322     "selected_real_kind", "transfer", "trim", NULL
2323   };
2324
2325   static const char * const trans_func_f2003[] =  {
2326     "all", "any", "count", "dot_product", "matmul", "null", "pack",
2327     "product", "repeat", "reshape", "selected_char_kind", "selected_int_kind",
2328     "selected_real_kind", "spread", "sum", "transfer", "transpose",
2329     "trim", "unpack", NULL
2330   };
2331
2332   int i;
2333   const char *name;
2334   const char *const *functions;
2335
2336   if (!e->value.function.isym
2337       || !e->value.function.isym->transformational)
2338     return MATCH_NO;
2339
2340   name = e->symtree->n.sym->name;
2341
2342   functions = (gfc_option.allow_std & GFC_STD_F2003) 
2343                 ? trans_func_f2003 : trans_func_f95;
2344
2345   /* NULL() is dealt with below.  */
2346   if (strcmp ("null", name) == 0)
2347     return MATCH_NO;
2348
2349   for (i = 0; functions[i]; i++)
2350     if (strcmp (functions[i], name) == 0)
2351        break;
2352
2353   if (functions[i] == NULL)
2354     {
2355       gfc_error("transformational intrinsic '%s' at %L is not permitted "
2356                 "in an initialization expression", name, &e->where);
2357       return MATCH_ERROR;
2358     }
2359
2360   return check_init_expr_arguments (e);
2361 }
2362
2363
2364 /* F95, 7.1.6.1, Initialization expressions, (6)
2365    F2003, 7.1.7 Initialization expression, (6)  */
2366
2367 static match
2368 check_null (gfc_expr *e)
2369 {
2370   if (strcmp ("null", e->symtree->n.sym->name) != 0)
2371     return MATCH_NO;
2372
2373   return check_init_expr_arguments (e);
2374 }
2375
2376
2377 static match
2378 check_elemental (gfc_expr *e)
2379 {
2380   if (!e->value.function.isym
2381       || !e->value.function.isym->elemental)
2382     return MATCH_NO;
2383
2384   if (e->ts.type != BT_INTEGER
2385       && e->ts.type != BT_CHARACTER
2386       && gfc_notify_std (GFC_STD_F2003, "Extension: Evaluation of "
2387                         "nonstandard initialization expression at %L",
2388                         &e->where) == FAILURE)
2389     return MATCH_ERROR;
2390
2391   return check_init_expr_arguments (e);
2392 }
2393
2394
2395 static match
2396 check_conversion (gfc_expr *e)
2397 {
2398   if (!e->value.function.isym
2399       || !e->value.function.isym->conversion)
2400     return MATCH_NO;
2401
2402   return check_init_expr_arguments (e);
2403 }
2404
2405
2406 /* Verify that an expression is an initialization expression.  A side
2407    effect is that the expression tree is reduced to a single constant
2408    node if all goes well.  This would normally happen when the
2409    expression is constructed but function references are assumed to be
2410    intrinsics in the context of initialization expressions.  If
2411    FAILURE is returned an error message has been generated.  */
2412
2413 static gfc_try
2414 check_init_expr (gfc_expr *e)
2415 {
2416   match m;
2417   gfc_try t;
2418
2419   if (e == NULL)
2420     return SUCCESS;
2421
2422   switch (e->expr_type)
2423     {
2424     case EXPR_OP:
2425       t = check_intrinsic_op (e, check_init_expr);
2426       if (t == SUCCESS)
2427         t = gfc_simplify_expr (e, 0);
2428
2429       break;
2430
2431     case EXPR_FUNCTION:
2432       t = FAILURE;
2433
2434       {
2435         gfc_intrinsic_sym* isym;
2436         gfc_symbol* sym;
2437
2438         sym = e->symtree->n.sym;
2439         if (!gfc_is_intrinsic (sym, 0, e->where)
2440             || (m = gfc_intrinsic_func_interface (e, 0)) != MATCH_YES)
2441           {
2442             gfc_error ("Function '%s' in initialization expression at %L "
2443                        "must be an intrinsic function",
2444                        e->symtree->n.sym->name, &e->where);
2445             break;
2446           }
2447
2448         if ((m = check_conversion (e)) == MATCH_NO
2449             && (m = check_inquiry (e, 1)) == MATCH_NO
2450             && (m = check_null (e)) == MATCH_NO
2451             && (m = check_transformational (e)) == MATCH_NO
2452             && (m = check_elemental (e)) == MATCH_NO)
2453           {
2454             gfc_error ("Intrinsic function '%s' at %L is not permitted "
2455                        "in an initialization expression",
2456                        e->symtree->n.sym->name, &e->where);
2457             m = MATCH_ERROR;
2458           }
2459
2460         /* Try to scalarize an elemental intrinsic function that has an
2461            array argument.  */
2462         isym = gfc_find_function (e->symtree->n.sym->name);
2463         if (isym && isym->elemental
2464             && (t = scalarize_intrinsic_call (e)) == SUCCESS)
2465           break;
2466       }
2467
2468       if (m == MATCH_YES)
2469         t = gfc_simplify_expr (e, 0);
2470
2471       break;
2472
2473     case EXPR_VARIABLE:
2474       t = SUCCESS;
2475
2476       if (gfc_check_iter_variable (e) == SUCCESS)
2477         break;
2478
2479       if (e->symtree->n.sym->attr.flavor == FL_PARAMETER)
2480         {
2481           /* A PARAMETER shall not be used to define itself, i.e.
2482                 REAL, PARAMETER :: x = transfer(0, x)
2483              is invalid.  */
2484           if (!e->symtree->n.sym->value)
2485             {
2486               gfc_error("PARAMETER '%s' is used at %L before its definition "
2487                         "is complete", e->symtree->n.sym->name, &e->where);
2488               t = FAILURE;
2489             }
2490           else
2491             t = simplify_parameter_variable (e, 0);
2492
2493           break;
2494         }
2495
2496       if (gfc_in_match_data ())
2497         break;
2498
2499       t = FAILURE;
2500
2501       if (e->symtree->n.sym->as)
2502         {
2503           switch (e->symtree->n.sym->as->type)
2504             {
2505               case AS_ASSUMED_SIZE:
2506                 gfc_error ("Assumed size array '%s' at %L is not permitted "
2507                            "in an initialization expression",
2508                            e->symtree->n.sym->name, &e->where);
2509                 break;
2510
2511               case AS_ASSUMED_SHAPE:
2512                 gfc_error ("Assumed shape array '%s' at %L is not permitted "
2513                            "in an initialization expression",
2514                            e->symtree->n.sym->name, &e->where);
2515                 break;
2516
2517               case AS_DEFERRED:
2518                 gfc_error ("Deferred array '%s' at %L is not permitted "
2519                            "in an initialization expression",
2520                            e->symtree->n.sym->name, &e->where);
2521                 break;
2522
2523               case AS_EXPLICIT:
2524                 gfc_error ("Array '%s' at %L is a variable, which does "
2525                            "not reduce to a constant expression",
2526                            e->symtree->n.sym->name, &e->where);
2527                 break;
2528
2529               default:
2530                 gcc_unreachable();
2531           }
2532         }
2533       else
2534         gfc_error ("Parameter '%s' at %L has not been declared or is "
2535                    "a variable, which does not reduce to a constant "
2536                    "expression", e->symtree->n.sym->name, &e->where);
2537
2538       break;
2539
2540     case EXPR_CONSTANT:
2541     case EXPR_NULL:
2542       t = SUCCESS;
2543       break;
2544
2545     case EXPR_SUBSTRING:
2546       t = check_init_expr (e->ref->u.ss.start);
2547       if (t == FAILURE)
2548         break;
2549
2550       t = check_init_expr (e->ref->u.ss.end);
2551       if (t == SUCCESS)
2552         t = gfc_simplify_expr (e, 0);
2553
2554       break;
2555
2556     case EXPR_STRUCTURE:
2557       t = e->ts.is_iso_c ? SUCCESS : FAILURE;
2558       if (t == SUCCESS)
2559         break;
2560
2561       t = check_alloc_comp_init (e);
2562       if (t == FAILURE)
2563         break;
2564
2565       t = gfc_check_constructor (e, check_init_expr);
2566       if (t == FAILURE)
2567         break;
2568
2569       break;
2570
2571     case EXPR_ARRAY:
2572       t = gfc_check_constructor (e, check_init_expr);
2573       if (t == FAILURE)
2574         break;
2575
2576       t = gfc_expand_constructor (e, true);
2577       if (t == FAILURE)
2578         break;
2579
2580       t = gfc_check_constructor_type (e);
2581       break;
2582
2583     default:
2584       gfc_internal_error ("check_init_expr(): Unknown expression type");
2585     }
2586
2587   return t;
2588 }
2589
2590 /* Reduces a general expression to an initialization expression (a constant).
2591    This used to be part of gfc_match_init_expr.
2592    Note that this function doesn't free the given expression on FAILURE.  */
2593
2594 gfc_try
2595 gfc_reduce_init_expr (gfc_expr *expr)
2596 {
2597   gfc_try t;
2598
2599   gfc_init_expr_flag = true;
2600   t = gfc_resolve_expr (expr);
2601   if (t == SUCCESS)
2602     t = check_init_expr (expr);
2603   gfc_init_expr_flag = false;
2604
2605   if (t == FAILURE)
2606     return FAILURE;
2607
2608   if (expr->expr_type == EXPR_ARRAY)
2609     {
2610       if (gfc_check_constructor_type (expr) == FAILURE)
2611         return FAILURE;
2612       if (gfc_expand_constructor (expr, true) == FAILURE)
2613         return FAILURE;
2614     }
2615
2616   return SUCCESS;
2617 }
2618
2619
2620 /* Match an initialization expression.  We work by first matching an
2621    expression, then reducing it to a constant.  */
2622
2623 match
2624 gfc_match_init_expr (gfc_expr **result)
2625 {
2626   gfc_expr *expr;
2627   match m;
2628   gfc_try t;
2629
2630   expr = NULL;
2631
2632   gfc_init_expr_flag = true;
2633
2634   m = gfc_match_expr (&expr);
2635   if (m != MATCH_YES)
2636     {
2637       gfc_init_expr_flag = false;
2638       return m;
2639     }
2640
2641   t = gfc_reduce_init_expr (expr);
2642   if (t != SUCCESS)
2643     {
2644       gfc_free_expr (expr);
2645       gfc_init_expr_flag = false;
2646       return MATCH_ERROR;
2647     }
2648
2649   *result = expr;
2650   gfc_init_expr_flag = false;
2651
2652   return MATCH_YES;
2653 }
2654
2655
2656 /* Given an actual argument list, test to see that each argument is a
2657    restricted expression and optionally if the expression type is
2658    integer or character.  */
2659
2660 static gfc_try
2661 restricted_args (gfc_actual_arglist *a)
2662 {
2663   for (; a; a = a->next)
2664     {
2665       if (check_restricted (a->expr) == FAILURE)
2666         return FAILURE;
2667     }
2668
2669   return SUCCESS;
2670 }
2671
2672
2673 /************* Restricted/specification expressions *************/
2674
2675
2676 /* Make sure a non-intrinsic function is a specification function.  */
2677
2678 static gfc_try
2679 external_spec_function (gfc_expr *e)
2680 {
2681   gfc_symbol *f;
2682
2683   f = e->value.function.esym;
2684
2685   if (f->attr.proc == PROC_ST_FUNCTION)
2686     {
2687       gfc_error ("Specification function '%s' at %L cannot be a statement "
2688                  "function", f->name, &e->where);
2689       return FAILURE;
2690     }
2691
2692   if (f->attr.proc == PROC_INTERNAL)
2693     {
2694       gfc_error ("Specification function '%s' at %L cannot be an internal "
2695                  "function", f->name, &e->where);
2696       return FAILURE;
2697     }
2698
2699   if (!f->attr.pure && !f->attr.elemental)
2700     {
2701       gfc_error ("Specification function '%s' at %L must be PURE", f->name,
2702                  &e->where);
2703       return FAILURE;
2704     }
2705
2706   if (f->attr.recursive)
2707     {
2708       gfc_error ("Specification function '%s' at %L cannot be RECURSIVE",
2709                  f->name, &e->where);
2710       return FAILURE;
2711     }
2712
2713   return restricted_args (e->value.function.actual);
2714 }
2715
2716
2717 /* Check to see that a function reference to an intrinsic is a
2718    restricted expression.  */
2719
2720 static gfc_try
2721 restricted_intrinsic (gfc_expr *e)
2722 {
2723   /* TODO: Check constraints on inquiry functions.  7.1.6.2 (7).  */
2724   if (check_inquiry (e, 0) == MATCH_YES)
2725     return SUCCESS;
2726
2727   return restricted_args (e->value.function.actual);
2728 }
2729
2730
2731 /* Check the expressions of an actual arglist.  Used by check_restricted.  */
2732
2733 static gfc_try
2734 check_arglist (gfc_actual_arglist* arg, gfc_try (*checker) (gfc_expr*))
2735 {
2736   for (; arg; arg = arg->next)
2737     if (checker (arg->expr) == FAILURE)
2738       return FAILURE;
2739
2740   return SUCCESS;
2741 }
2742
2743
2744 /* Check the subscription expressions of a reference chain with a checking
2745    function; used by check_restricted.  */
2746
2747 static gfc_try
2748 check_references (gfc_ref* ref, gfc_try (*checker) (gfc_expr*))
2749 {
2750   int dim;
2751
2752   if (!ref)
2753     return SUCCESS;
2754
2755   switch (ref->type)
2756     {
2757     case REF_ARRAY:
2758       for (dim = 0; dim != ref->u.ar.dimen; ++dim)
2759         {
2760           if (checker (ref->u.ar.start[dim]) == FAILURE)
2761             return FAILURE;
2762           if (checker (ref->u.ar.end[dim]) == FAILURE)
2763             return FAILURE;
2764           if (checker (ref->u.ar.stride[dim]) == FAILURE)
2765             return FAILURE;
2766         }
2767       break;
2768
2769     case REF_COMPONENT:
2770       /* Nothing needed, just proceed to next reference.  */
2771       break;
2772
2773     case REF_SUBSTRING:
2774       if (checker (ref->u.ss.start) == FAILURE)
2775         return FAILURE;
2776       if (checker (ref->u.ss.end) == FAILURE)
2777         return FAILURE;
2778       break;
2779
2780     default:
2781       gcc_unreachable ();
2782       break;
2783     }
2784
2785   return check_references (ref->next, checker);
2786 }
2787
2788
2789 /* Verify that an expression is a restricted expression.  Like its
2790    cousin check_init_expr(), an error message is generated if we
2791    return FAILURE.  */
2792
2793 static gfc_try
2794 check_restricted (gfc_expr *e)
2795 {
2796   gfc_symbol* sym;
2797   gfc_try t;
2798
2799   if (e == NULL)
2800     return SUCCESS;
2801
2802   switch (e->expr_type)
2803     {
2804     case EXPR_OP:
2805       t = check_intrinsic_op (e, check_restricted);
2806       if (t == SUCCESS)
2807         t = gfc_simplify_expr (e, 0);
2808
2809       break;
2810
2811     case EXPR_FUNCTION:
2812       if (e->value.function.esym)
2813         {
2814           t = check_arglist (e->value.function.actual, &check_restricted);
2815           if (t == SUCCESS)
2816             t = external_spec_function (e);
2817         }
2818       else
2819         {
2820           if (e->value.function.isym && e->value.function.isym->inquiry)
2821             t = SUCCESS;
2822           else
2823             t = check_arglist (e->value.function.actual, &check_restricted);
2824
2825           if (t == SUCCESS)
2826             t = restricted_intrinsic (e);
2827         }
2828       break;
2829
2830     case EXPR_VARIABLE:
2831       sym = e->symtree->n.sym;
2832       t = FAILURE;
2833
2834       /* If a dummy argument appears in a context that is valid for a
2835          restricted expression in an elemental procedure, it will have
2836          already been simplified away once we get here.  Therefore we
2837          don't need to jump through hoops to distinguish valid from
2838          invalid cases.  */
2839       if (sym->attr.dummy && sym->ns == gfc_current_ns
2840           && sym->ns->proc_name && sym->ns->proc_name->attr.elemental)
2841         {
2842           gfc_error ("Dummy argument '%s' not allowed in expression at %L",
2843                      sym->name, &e->where);
2844           break;
2845         }
2846
2847       if (sym->attr.optional)
2848         {
2849           gfc_error ("Dummy argument '%s' at %L cannot be OPTIONAL",
2850                      sym->name, &e->where);
2851           break;
2852         }
2853
2854       if (sym->attr.intent == INTENT_OUT)
2855         {
2856           gfc_error ("Dummy argument '%s' at %L cannot be INTENT(OUT)",
2857                      sym->name, &e->where);
2858           break;
2859         }
2860
2861       /* Check reference chain if any.  */
2862       if (check_references (e->ref, &check_restricted) == FAILURE)
2863         break;
2864
2865       /* gfc_is_formal_arg broadcasts that a formal argument list is being
2866          processed in resolve.c(resolve_formal_arglist).  This is done so
2867          that host associated dummy array indices are accepted (PR23446).
2868          This mechanism also does the same for the specification expressions
2869          of array-valued functions.  */
2870       if (e->error
2871             || sym->attr.in_common
2872             || sym->attr.use_assoc
2873             || sym->attr.dummy
2874             || sym->attr.implied_index
2875             || sym->attr.flavor == FL_PARAMETER
2876             || (sym->ns && sym->ns == gfc_current_ns->parent)
2877             || (sym->ns && gfc_current_ns->parent
2878                   && sym->ns == gfc_current_ns->parent->parent)
2879             || (sym->ns->proc_name != NULL
2880                   && sym->ns->proc_name->attr.flavor == FL_MODULE)
2881             || (gfc_is_formal_arg () && (sym->ns == gfc_current_ns)))
2882         {
2883           t = SUCCESS;
2884           break;
2885         }
2886
2887       gfc_error ("Variable '%s' cannot appear in the expression at %L",
2888                  sym->name, &e->where);
2889       /* Prevent a repetition of the error.  */
2890       e->error = 1;
2891       break;
2892
2893     case EXPR_NULL:
2894     case EXPR_CONSTANT:
2895       t = SUCCESS;
2896       break;
2897
2898     case EXPR_SUBSTRING:
2899       t = gfc_specification_expr (e->ref->u.ss.start);
2900       if (t == FAILURE)
2901         break;
2902
2903       t = gfc_specification_expr (e->ref->u.ss.end);
2904       if (t == SUCCESS)
2905         t = gfc_simplify_expr (e, 0);
2906
2907       break;
2908
2909     case EXPR_STRUCTURE:
2910       t = gfc_check_constructor (e, check_restricted);
2911       break;
2912
2913     case EXPR_ARRAY:
2914       t = gfc_check_constructor (e, check_restricted);
2915       break;
2916
2917     default:
2918       gfc_internal_error ("check_restricted(): Unknown expression type");
2919     }
2920
2921   return t;
2922 }
2923
2924
2925 /* Check to see that an expression is a specification expression.  If
2926    we return FAILURE, an error has been generated.  */
2927
2928 gfc_try
2929 gfc_specification_expr (gfc_expr *e)
2930 {
2931   gfc_component *comp;
2932
2933   if (e == NULL)
2934     return SUCCESS;
2935
2936   if (e->ts.type != BT_INTEGER)
2937     {
2938       gfc_error ("Expression at %L must be of INTEGER type, found %s",
2939                  &e->where, gfc_basic_typename (e->ts.type));
2940       return FAILURE;
2941     }
2942
2943   if (e->expr_type == EXPR_FUNCTION
2944           && !e->value.function.isym
2945           && !e->value.function.esym
2946           && !gfc_pure (e->symtree->n.sym)
2947           && (!gfc_is_proc_ptr_comp (e, &comp)
2948               || !comp->attr.pure))
2949     {
2950       gfc_error ("Function '%s' at %L must be PURE",
2951                  e->symtree->n.sym->name, &e->where);
2952       /* Prevent repeat error messages.  */
2953       e->symtree->n.sym->attr.pure = 1;
2954       return FAILURE;
2955     }
2956
2957   if (e->rank != 0)
2958     {
2959       gfc_error ("Expression at %L must be scalar", &e->where);
2960       return FAILURE;
2961     }
2962
2963   if (gfc_simplify_expr (e, 0) == FAILURE)
2964     return FAILURE;
2965
2966   return check_restricted (e);
2967 }
2968
2969
2970 /************** Expression conformance checks.  *************/
2971
2972 /* Given two expressions, make sure that the arrays are conformable.  */
2973
2974 gfc_try
2975 gfc_check_conformance (gfc_expr *op1, gfc_expr *op2, const char *optype_msgid, ...)
2976 {
2977   int op1_flag, op2_flag, d;
2978   mpz_t op1_size, op2_size;
2979   gfc_try t;
2980
2981   va_list argp;
2982   char buffer[240];
2983
2984   if (op1->rank == 0 || op2->rank == 0)
2985     return SUCCESS;
2986
2987   va_start (argp, optype_msgid);
2988   vsnprintf (buffer, 240, optype_msgid, argp);
2989   va_end (argp);
2990
2991   if (op1->rank != op2->rank)
2992     {
2993       gfc_error ("Incompatible ranks in %s (%d and %d) at %L", _(buffer),
2994                  op1->rank, op2->rank, &op1->where);
2995       return FAILURE;
2996     }
2997
2998   t = SUCCESS;
2999
3000   for (d = 0; d < op1->rank; d++)
3001     {
3002       op1_flag = gfc_array_dimen_size (op1, d, &op1_size) == SUCCESS;
3003       op2_flag = gfc_array_dimen_size (op2, d, &op2_size) == SUCCESS;
3004
3005       if (op1_flag && op2_flag && mpz_cmp (op1_size, op2_size) != 0)
3006         {
3007           gfc_error ("Different shape for %s at %L on dimension %d "
3008                      "(%d and %d)", _(buffer), &op1->where, d + 1,
3009                      (int) mpz_get_si (op1_size),
3010                      (int) mpz_get_si (op2_size));
3011
3012           t = FAILURE;
3013         }
3014
3015       if (op1_flag)
3016         mpz_clear (op1_size);
3017       if (op2_flag)
3018         mpz_clear (op2_size);
3019
3020       if (t == FAILURE)
3021         return FAILURE;
3022     }
3023
3024   return SUCCESS;
3025 }
3026
3027
3028 /* Given an assignable expression and an arbitrary expression, make
3029    sure that the assignment can take place.  */
3030
3031 gfc_try
3032 gfc_check_assign (gfc_expr *lvalue, gfc_expr *rvalue, int conform)
3033 {
3034   gfc_symbol *sym;
3035   gfc_ref *ref;
3036   int has_pointer;
3037
3038   sym = lvalue->symtree->n.sym;
3039
3040   /* Check INTENT(IN), unless the object itself is the component or
3041      sub-component of a pointer.  */
3042   has_pointer = sym->attr.pointer;
3043
3044   for (ref = lvalue->ref; ref; ref = ref->next)
3045     if (ref->type == REF_COMPONENT && ref->u.c.component->attr.pointer)
3046       {
3047         has_pointer = 1;
3048         break;
3049       }
3050
3051   if (!has_pointer && sym->attr.intent == INTENT_IN)
3052     {
3053       gfc_error ("Cannot assign to INTENT(IN) variable '%s' at %L",
3054                  sym->name, &lvalue->where);
3055       return FAILURE;
3056     }
3057
3058   /* 12.5.2.2, Note 12.26: The result variable is very similar to any other
3059      variable local to a function subprogram.  Its existence begins when
3060      execution of the function is initiated and ends when execution of the
3061      function is terminated...
3062      Therefore, the left hand side is no longer a variable, when it is:  */
3063   if (sym->attr.flavor == FL_PROCEDURE && sym->attr.proc != PROC_ST_FUNCTION
3064       && !sym->attr.external)
3065     {
3066       bool bad_proc;
3067       bad_proc = false;
3068
3069       /* (i) Use associated;  */
3070       if (sym->attr.use_assoc)
3071         bad_proc = true;
3072
3073       /* (ii) The assignment is in the main program; or  */
3074       if (gfc_current_ns->proc_name->attr.is_main_program)
3075         bad_proc = true;
3076
3077       /* (iii) A module or internal procedure...  */
3078       if ((gfc_current_ns->proc_name->attr.proc == PROC_INTERNAL
3079            || gfc_current_ns->proc_name->attr.proc == PROC_MODULE)
3080           && gfc_current_ns->parent
3081           && (!(gfc_current_ns->parent->proc_name->attr.function
3082                 || gfc_current_ns->parent->proc_name->attr.subroutine)
3083               || gfc_current_ns->parent->proc_name->attr.is_main_program))
3084         {
3085           /* ... that is not a function...  */ 
3086           if (!gfc_current_ns->proc_name->attr.function)
3087             bad_proc = true;
3088
3089           /* ... or is not an entry and has a different name.  */
3090           if (!sym->attr.entry && sym->name != gfc_current_ns->proc_name->name)
3091             bad_proc = true;
3092         }
3093
3094       /* (iv) Host associated and not the function symbol or the
3095               parent result.  This picks up sibling references, which
3096               cannot be entries.  */
3097       if (!sym->attr.entry
3098             && sym->ns == gfc_current_ns->parent
3099             && sym != gfc_current_ns->proc_name
3100             && sym != gfc_current_ns->parent->proc_name->result)
3101         bad_proc = true;
3102
3103       if (bad_proc)
3104         {
3105           gfc_error ("'%s' at %L is not a VALUE", sym->name, &lvalue->where);
3106           return FAILURE;
3107         }
3108     }
3109
3110   if (rvalue->rank != 0 && lvalue->rank != rvalue->rank)
3111     {
3112       gfc_error ("Incompatible ranks %d and %d in assignment at %L",
3113                  lvalue->rank, rvalue->rank, &lvalue->where);
3114       return FAILURE;
3115     }
3116
3117   if (lvalue->ts.type == BT_UNKNOWN)
3118     {
3119       gfc_error ("Variable type is UNKNOWN in assignment at %L",
3120                  &lvalue->where);
3121       return FAILURE;
3122     }
3123
3124   if (rvalue->expr_type == EXPR_NULL)
3125     {  
3126       if (has_pointer && (ref == NULL || ref->next == NULL)
3127           && lvalue->symtree->n.sym->attr.data)
3128         return SUCCESS;
3129       else
3130         {
3131           gfc_error ("NULL appears on right-hand side in assignment at %L",
3132                      &rvalue->where);
3133           return FAILURE;
3134         }
3135     }
3136
3137   /* This is possibly a typo: x = f() instead of x => f().  */
3138   if (gfc_option.warn_surprising 
3139       && rvalue->expr_type == EXPR_FUNCTION
3140       && rvalue->symtree->n.sym->attr.pointer)
3141     gfc_warning ("POINTER valued function appears on right-hand side of "
3142                  "assignment at %L", &rvalue->where);
3143
3144   /* Check size of array assignments.  */
3145   if (lvalue->rank != 0 && rvalue->rank != 0
3146       && gfc_check_conformance (lvalue, rvalue, "array assignment") != SUCCESS)
3147     return FAILURE;
3148
3149   if (rvalue->is_boz && lvalue->ts.type != BT_INTEGER
3150       && lvalue->symtree->n.sym->attr.data
3151       && gfc_notify_std (GFC_STD_GNU, "Extension: BOZ literal at %L used to "
3152                          "initialize non-integer variable '%s'",
3153                          &rvalue->where, lvalue->symtree->n.sym->name)
3154          == FAILURE)
3155     return FAILURE;
3156   else if (rvalue->is_boz && !lvalue->symtree->n.sym->attr.data
3157       && gfc_notify_std (GFC_STD_GNU, "Extension: BOZ literal at %L outside "
3158                          "a DATA statement and outside INT/REAL/DBLE/CMPLX",
3159                          &rvalue->where) == FAILURE)
3160     return FAILURE;
3161
3162   /* Handle the case of a BOZ literal on the RHS.  */
3163   if (rvalue->is_boz && lvalue->ts.type != BT_INTEGER)
3164     {
3165       int rc;
3166       if (gfc_option.warn_surprising)
3167         gfc_warning ("BOZ literal at %L is bitwise transferred "
3168                      "non-integer symbol '%s'", &rvalue->where,
3169                      lvalue->symtree->n.sym->name);
3170       if (!gfc_convert_boz (rvalue, &lvalue->ts))
3171         return FAILURE;
3172       if ((rc = gfc_range_check (rvalue)) != ARITH_OK)
3173         {
3174           if (rc == ARITH_UNDERFLOW)
3175             gfc_error ("Arithmetic underflow of bit-wise transferred BOZ at %L"
3176                        ". This check can be disabled with the option "
3177                        "-fno-range-check", &rvalue->where);
3178           else if (rc == ARITH_OVERFLOW)
3179             gfc_error ("Arithmetic overflow of bit-wise transferred BOZ at %L"
3180                        ". This check can be disabled with the option "
3181                        "-fno-range-check", &rvalue->where);
3182           else if (rc == ARITH_NAN)
3183             gfc_error ("Arithmetic NaN of bit-wise transferred BOZ at %L"
3184                        ". This check can be disabled with the option "
3185                        "-fno-range-check", &rvalue->where);
3186           return FAILURE;
3187         }
3188     }
3189
3190   if (gfc_compare_types (&lvalue->ts, &rvalue->ts))
3191     return SUCCESS;
3192
3193   /* Only DATA Statements come here.  */
3194   if (!conform)
3195     {
3196       /* Numeric can be converted to any other numeric. And Hollerith can be
3197          converted to any other type.  */
3198       if ((gfc_numeric_ts (&lvalue->ts) && gfc_numeric_ts (&rvalue->ts))
3199           || rvalue->ts.type == BT_HOLLERITH)
3200         return SUCCESS;
3201
3202       if (lvalue->ts.type == BT_LOGICAL && rvalue->ts.type == BT_LOGICAL)
3203         return SUCCESS;
3204
3205       gfc_error ("Incompatible types in DATA statement at %L; attempted "
3206                  "conversion of %s to %s", &lvalue->where,
3207                  gfc_typename (&rvalue->ts), gfc_typename (&lvalue->ts));
3208
3209       return FAILURE;
3210     }
3211
3212   /* Assignment is the only case where character variables of different
3213      kind values can be converted into one another.  */
3214   if (lvalue->ts.type == BT_CHARACTER && rvalue->ts.type == BT_CHARACTER)
3215     {
3216       if (lvalue->ts.kind != rvalue->ts.kind)
3217         gfc_convert_chartype (rvalue, &lvalue->ts);
3218
3219       return SUCCESS;
3220     }
3221
3222   return gfc_convert_type (rvalue, &lvalue->ts, 1);
3223 }
3224
3225
3226 /* Check that a pointer assignment is OK.  We first check lvalue, and
3227    we only check rvalue if it's not an assignment to NULL() or a
3228    NULLIFY statement.  */
3229
3230 gfc_try
3231 gfc_check_pointer_assign (gfc_expr *lvalue, gfc_expr *rvalue)
3232 {
3233   symbol_attribute attr;
3234   gfc_ref *ref;
3235   int is_pure;
3236   int pointer, check_intent_in, proc_pointer;
3237
3238   if (lvalue->symtree->n.sym->ts.type == BT_UNKNOWN
3239       && !lvalue->symtree->n.sym->attr.proc_pointer)
3240     {
3241       gfc_error ("Pointer assignment target is not a POINTER at %L",
3242                  &lvalue->where);
3243       return FAILURE;
3244     }
3245
3246   if (lvalue->symtree->n.sym->attr.flavor == FL_PROCEDURE
3247       && lvalue->symtree->n.sym->attr.use_assoc
3248       && !lvalue->symtree->n.sym->attr.proc_pointer)
3249     {
3250       gfc_error ("'%s' in the pointer assignment at %L cannot be an "
3251                  "l-value since it is a procedure",
3252                  lvalue->symtree->n.sym->name, &lvalue->where);
3253       return FAILURE;
3254     }
3255
3256
3257   /* Check INTENT(IN), unless the object itself is the component or
3258      sub-component of a pointer.  */
3259   check_intent_in = 1;
3260   pointer = lvalue->symtree->n.sym->attr.pointer;
3261   proc_pointer = lvalue->symtree->n.sym->attr.proc_pointer;
3262
3263   for (ref = lvalue->ref; ref; ref = ref->next)
3264     {
3265       if (pointer)
3266         check_intent_in = 0;
3267
3268       if (ref->type == REF_COMPONENT)
3269         {
3270           pointer = ref->u.c.component->attr.pointer;
3271           proc_pointer = ref->u.c.component->attr.proc_pointer;
3272         }
3273
3274       if (ref->type == REF_ARRAY && ref->next == NULL)
3275         {
3276           if (ref->u.ar.type == AR_FULL)
3277             break;
3278
3279           if (ref->u.ar.type != AR_SECTION)
3280             {
3281               gfc_error ("Expected bounds specification for '%s' at %L",
3282                          lvalue->symtree->n.sym->name, &lvalue->where);
3283               return FAILURE;
3284             }
3285
3286           if (gfc_notify_std (GFC_STD_F2003,"Fortran 2003: Bounds "
3287                               "specification for '%s' in pointer assignment "
3288                               "at %L", lvalue->symtree->n.sym->name,
3289                               &lvalue->where) == FAILURE)
3290             return FAILURE;
3291
3292           gfc_error ("Pointer bounds remapping at %L is not yet implemented "
3293                      "in gfortran", &lvalue->where);
3294           /* TODO: See PR 29785. Add checks that all lbounds are specified and
3295              either never or always the upper-bound; strides shall not be
3296              present.  */
3297           return FAILURE;
3298         }
3299     }
3300
3301   if (check_intent_in && lvalue->symtree->n.sym->attr.intent == INTENT_IN)
3302     {
3303       gfc_error ("Cannot assign to INTENT(IN) variable '%s' at %L",
3304                  lvalue->symtree->n.sym->name, &lvalue->where);
3305       return FAILURE;
3306     }
3307
3308   if (!pointer && !proc_pointer
3309         && !(lvalue->ts.type == BT_CLASS && CLASS_DATA (lvalue)->attr.pointer))
3310     {
3311       gfc_error ("Pointer assignment to non-POINTER at %L", &lvalue->where);
3312       return FAILURE;
3313     }
3314
3315   is_pure = gfc_pure (NULL);
3316
3317   if (is_pure && gfc_impure_variable (lvalue->symtree->n.sym)
3318         && lvalue->symtree->n.sym->value != rvalue)
3319     {
3320       gfc_error ("Bad pointer object in PURE procedure at %L", &lvalue->where);
3321       return FAILURE;
3322     }
3323
3324   /* If rvalue is a NULL() or NULLIFY, we're done. Otherwise the type,
3325      kind, etc for lvalue and rvalue must match, and rvalue must be a
3326      pure variable if we're in a pure function.  */
3327   if (rvalue->expr_type == EXPR_NULL && rvalue->ts.type == BT_UNKNOWN)
3328     return SUCCESS;
3329
3330   /* F2008, C723 (pointer) and C726 (proc-pointer); for PURE also C1283.  */
3331   if (lvalue->expr_type == EXPR_VARIABLE
3332       && gfc_is_coindexed (lvalue))
3333     {
3334       gfc_ref *ref;
3335       for (ref = lvalue->ref; ref; ref = ref->next)
3336         if (ref->type == REF_ARRAY && ref->u.ar.codimen)
3337           {
3338             gfc_error ("Pointer object at %L shall not have a coindex",
3339                        &lvalue->where);
3340             return FAILURE;
3341           }
3342     }
3343
3344   /* Checks on rvalue for procedure pointer assignments.  */
3345   if (proc_pointer)
3346     {
3347       char err[200];
3348       gfc_symbol *s1,*s2;
3349       gfc_component *comp;
3350       const char *name;
3351
3352       attr = gfc_expr_attr (rvalue);
3353       if (!((rvalue->expr_type == EXPR_NULL)
3354             || (rvalue->expr_type == EXPR_FUNCTION && attr.proc_pointer)
3355             || (rvalue->expr_type == EXPR_VARIABLE && attr.proc_pointer)
3356             || (rvalue->expr_type == EXPR_VARIABLE
3357                 && attr.flavor == FL_PROCEDURE)))
3358         {
3359           gfc_error ("Invalid procedure pointer assignment at %L",
3360                      &rvalue->where);
3361           return FAILURE;
3362         }
3363       if (attr.abstract)
3364         {
3365           gfc_error ("Abstract interface '%s' is invalid "
3366                      "in procedure pointer assignment at %L",
3367                      rvalue->symtree->name, &rvalue->where);
3368           return FAILURE;
3369         }
3370       /* Check for C727.  */
3371       if (attr.flavor == FL_PROCEDURE)
3372         {
3373           if (attr.proc == PROC_ST_FUNCTION)
3374             {
3375               gfc_error ("Statement function '%s' is invalid "
3376                          "in procedure pointer assignment at %L",
3377                          rvalue->symtree->name, &rvalue->where);
3378               return FAILURE;
3379             }
3380           if (attr.proc == PROC_INTERNAL &&
3381               gfc_notify_std (GFC_STD_F2008, "Internal procedure '%s' is "
3382                               "invalid in procedure pointer assignment at %L",
3383                               rvalue->symtree->name, &rvalue->where) == FAILURE)
3384             return FAILURE;
3385         }
3386
3387       /* Ensure that the calling convention is the same. As other attributes
3388          such as DLLEXPORT may differ, one explicitly only tests for the
3389          calling conventions.  */
3390       if (rvalue->expr_type == EXPR_VARIABLE
3391           && lvalue->symtree->n.sym->attr.ext_attr
3392                != rvalue->symtree->n.sym->attr.ext_attr)
3393         {
3394           symbol_attribute calls;
3395
3396           calls.ext_attr = 0;
3397           gfc_add_ext_attribute (&calls, EXT_ATTR_CDECL, NULL);
3398           gfc_add_ext_attribute (&calls, EXT_ATTR_STDCALL, NULL);
3399           gfc_add_ext_attribute (&calls, EXT_ATTR_FASTCALL, NULL);
3400
3401           if ((calls.ext_attr & lvalue->symtree->n.sym->attr.ext_attr)
3402               != (calls.ext_attr & rvalue->symtree->n.sym->attr.ext_attr))
3403             {
3404               gfc_error ("Mismatch in the procedure pointer assignment "
3405                          "at %L: mismatch in the calling convention",
3406                          &rvalue->where);
3407           return FAILURE;
3408             }
3409         }
3410
3411       if (gfc_is_proc_ptr_comp (lvalue, &comp))
3412         s1 = comp->ts.interface;
3413       else
3414         s1 = lvalue->symtree->n.sym;
3415
3416       if (gfc_is_proc_ptr_comp (rvalue, &comp))
3417         {
3418           s2 = comp->ts.interface;
3419           name = comp->name;
3420         }
3421       else if (rvalue->expr_type == EXPR_FUNCTION)
3422         {
3423           s2 = rvalue->symtree->n.sym->result;
3424           name = rvalue->symtree->n.sym->result->name;
3425         }
3426       else
3427         {
3428           s2 = rvalue->symtree->n.sym;
3429           name = rvalue->symtree->n.sym->name;
3430         }
3431
3432       if (s1 && s2 && !gfc_compare_interfaces (s1, s2, name, 0, 1,
3433                                                err, sizeof(err)))
3434         {
3435           gfc_error ("Interface mismatch in procedure pointer assignment "
3436                      "at %L: %s", &rvalue->where, err);
3437           return FAILURE;
3438         }
3439
3440       return SUCCESS;
3441     }
3442
3443   if (!gfc_compare_types (&lvalue->ts, &rvalue->ts))
3444     {
3445       gfc_error ("Different types in pointer assignment at %L; attempted "
3446                  "assignment of %s to %s", &lvalue->where, 
3447                  gfc_typename (&rvalue->ts), gfc_typename (&lvalue->ts));
3448       return FAILURE;
3449     }
3450
3451   if (lvalue->ts.type != BT_CLASS && lvalue->ts.kind != rvalue->ts.kind)
3452     {
3453       gfc_error ("Different kind type parameters in pointer "
3454                  "assignment at %L", &lvalue->where);
3455       return FAILURE;
3456     }
3457
3458   if (lvalue->rank != rvalue->rank)
3459     {
3460       gfc_error ("Different ranks in pointer assignment at %L",
3461                  &lvalue->where);
3462       return FAILURE;
3463     }
3464
3465   /* Now punt if we are dealing with a NULLIFY(X) or X = NULL(X).  */
3466   if (rvalue->expr_type == EXPR_NULL)
3467     return SUCCESS;
3468
3469   if (lvalue->ts.type == BT_CHARACTER)
3470     {
3471       gfc_try t = gfc_check_same_strlen (lvalue, rvalue, "pointer assignment");
3472       if (t == FAILURE)
3473         return FAILURE;
3474     }
3475
3476   if (rvalue->expr_type == EXPR_VARIABLE && is_subref_array (rvalue))
3477     lvalue->symtree->n.sym->attr.subref_array_pointer = 1;
3478
3479   attr = gfc_expr_attr (rvalue);
3480   if (!attr.target && !attr.pointer)
3481     {
3482       gfc_error ("Pointer assignment target is neither TARGET "
3483                  "nor POINTER at %L", &rvalue->where);
3484       return FAILURE;
3485     }
3486
3487   if (is_pure && gfc_impure_variable (rvalue->symtree->n.sym))
3488     {
3489       gfc_error ("Bad target in pointer assignment in PURE "
3490                  "procedure at %L", &rvalue->where);
3491     }
3492
3493   if (gfc_has_vector_index (rvalue))
3494     {
3495       gfc_error ("Pointer assignment with vector subscript "
3496                  "on rhs at %L", &rvalue->where);
3497       return FAILURE;
3498     }
3499
3500   if (attr.is_protected && attr.use_assoc
3501       && !(attr.pointer || attr.proc_pointer))
3502     {
3503       gfc_error ("Pointer assignment target has PROTECTED "
3504                  "attribute at %L", &rvalue->where);
3505       return FAILURE;
3506     }
3507
3508   /* F2008, C725. For PURE also C1283.  */
3509   if (rvalue->expr_type == EXPR_VARIABLE
3510       && gfc_is_coindexed (rvalue))
3511     {
3512       gfc_ref *ref;
3513       for (ref = rvalue->ref; ref; ref = ref->next)
3514         if (ref->type == REF_ARRAY && ref->u.ar.codimen)
3515           {
3516             gfc_error ("Data target at %L shall not have a coindex",
3517                        &rvalue->where);
3518             return FAILURE;
3519           }
3520     }
3521
3522   return SUCCESS;
3523 }
3524
3525
3526 /* Relative of gfc_check_assign() except that the lvalue is a single
3527    symbol.  Used for initialization assignments.  */
3528
3529 gfc_try
3530 gfc_check_assign_symbol (gfc_symbol *sym, gfc_expr *rvalue)
3531 {
3532   gfc_expr lvalue;
3533   gfc_try r;
3534
3535   memset (&lvalue, '\0', sizeof (gfc_expr));
3536
3537   lvalue.expr_type = EXPR_VARIABLE;
3538   lvalue.ts = sym->ts;
3539   if (sym->as)
3540     lvalue.rank = sym->as->rank;
3541   lvalue.symtree = (gfc_symtree *) gfc_getmem (sizeof (gfc_symtree));
3542   lvalue.symtree->n.sym = sym;
3543   lvalue.where = sym->declared_at;
3544
3545   if (sym->attr.pointer || sym->attr.proc_pointer
3546       || (sym->ts.type == BT_CLASS && CLASS_DATA (sym)->attr.pointer
3547           && rvalue->expr_type == EXPR_NULL))
3548     r = gfc_check_pointer_assign (&lvalue, rvalue);
3549   else
3550     r = gfc_check_assign (&lvalue, rvalue, 1);
3551
3552   gfc_free (lvalue.symtree);
3553
3554   return r;
3555 }
3556
3557
3558 /* Check for default initializer; sym->value is not enough
3559    as it is also set for EXPR_NULL of allocatables.  */
3560
3561 bool
3562 gfc_has_default_initializer (gfc_symbol *der)
3563 {
3564   gfc_component *c;
3565
3566   gcc_assert (der->attr.flavor == FL_DERIVED);
3567   for (c = der->components; c; c = c->next)
3568     if (c->ts.type == BT_DERIVED)
3569       {
3570         if (!c->attr.pointer
3571              && gfc_has_default_initializer (c->ts.u.derived))
3572           return true;
3573       }
3574     else
3575       {
3576         if (c->initializer)
3577           return true;
3578       }
3579
3580   return false;
3581 }
3582
3583 /* Get an expression for a default initializer.  */
3584
3585 gfc_expr *
3586 gfc_default_initializer (gfc_typespec *ts)
3587 {
3588   gfc_expr *init;
3589   gfc_component *comp;
3590
3591   /* See if we have a default initializer in this, but not in nested
3592      types (otherwise we could use gfc_has_default_initializer()).  */
3593   for (comp = ts->u.derived->components; comp; comp = comp->next)
3594     if (comp->initializer || comp->attr.allocatable)
3595       break;
3596
3597   if (!comp)
3598     return NULL;
3599
3600   init = gfc_get_structure_constructor_expr (ts->type, ts->kind,
3601                                              &ts->u.derived->declared_at);
3602   init->ts = *ts;
3603
3604   for (comp = ts->u.derived->components; comp; comp = comp->next)
3605     {
3606       gfc_constructor *ctor = gfc_constructor_get();
3607
3608       if (comp->initializer)
3609         ctor->expr = gfc_copy_expr (comp->initializer);
3610
3611       if (comp->attr.allocatable)
3612         {
3613           ctor->expr = gfc_get_expr ();
3614           ctor->expr->expr_type = EXPR_NULL;
3615           ctor->expr->ts = comp->ts;
3616         }
3617
3618       gfc_constructor_append (&init->value.constructor, ctor);
3619     }
3620
3621   return init;
3622 }
3623
3624
3625 /* Given a symbol, create an expression node with that symbol as a
3626    variable. If the symbol is array valued, setup a reference of the
3627    whole array.  */
3628
3629 gfc_expr *
3630 gfc_get_variable_expr (gfc_symtree *var)
3631 {
3632   gfc_expr *e;
3633
3634   e = gfc_get_expr ();
3635   e->expr_type = EXPR_VARIABLE;
3636   e->symtree = var;
3637   e->ts = var->n.sym->ts;
3638
3639   if (var->n.sym->as != NULL)
3640     {
3641       e->rank = var->n.sym->as->rank;
3642       e->ref = gfc_get_ref ();
3643       e->ref->type = REF_ARRAY;
3644       e->ref->u.ar.type = AR_FULL;
3645     }
3646
3647   return e;
3648 }
3649
3650
3651 /* Returns the array_spec of a full array expression.  A NULL is
3652    returned otherwise.  */
3653 gfc_array_spec *
3654 gfc_get_full_arrayspec_from_expr (gfc_expr *expr)
3655 {
3656   gfc_array_spec *as;
3657   gfc_ref *ref;
3658
3659   if (expr->rank == 0)
3660     return NULL;
3661
3662   /* Follow any component references.  */
3663   if (expr->expr_type == EXPR_VARIABLE
3664       || expr->expr_type == EXPR_CONSTANT)
3665     {
3666       as = expr->symtree->n.sym->as;
3667       for (ref = expr->ref; ref; ref = ref->next)
3668         {
3669           switch (ref->type)
3670             {
3671             case REF_COMPONENT:
3672               as = ref->u.c.component->as;
3673               continue;
3674
3675             case REF_SUBSTRING:
3676               continue;
3677
3678             case REF_ARRAY:
3679               {
3680                 switch (ref->u.ar.type)
3681                   {
3682                   case AR_ELEMENT:
3683                   case AR_SECTION:
3684                   case AR_UNKNOWN:
3685                     as = NULL;
3686                     continue;
3687
3688                   case AR_FULL:
3689                     break;
3690                   }
3691                 break;
3692               }
3693             }
3694         }
3695     }
3696   else
3697     as = NULL;
3698
3699   return as;
3700 }
3701
3702
3703 /* General expression traversal function.  */
3704
3705 bool
3706 gfc_traverse_expr (gfc_expr *expr, gfc_symbol *sym,
3707                    bool (*func)(gfc_expr *, gfc_symbol *, int*),
3708                    int f)
3709 {
3710   gfc_array_ref ar;
3711   gfc_ref *ref;
3712   gfc_actual_arglist *args;
3713   gfc_constructor *c;
3714   int i;
3715
3716   if (!expr)
3717     return false;
3718
3719   if ((*func) (expr, sym, &f))
3720     return true;
3721
3722   if (expr->ts.type == BT_CHARACTER
3723         && expr->ts.u.cl
3724         && expr->ts.u.cl->length
3725         && expr->ts.u.cl->length->expr_type != EXPR_CONSTANT
3726         && gfc_traverse_expr (expr->ts.u.cl->length, sym, func, f))
3727     return true;
3728
3729   switch (expr->expr_type)
3730     {
3731     case EXPR_PPC:
3732     case EXPR_COMPCALL:
3733     case EXPR_FUNCTION:
3734       for (args = expr->value.function.actual; args; args = args->next)
3735         {
3736           if (gfc_traverse_expr (args->expr, sym, func, f))
3737             return true;
3738         }
3739       break;
3740
3741     case EXPR_VARIABLE:
3742     case EXPR_CONSTANT:
3743     case EXPR_NULL:
3744     case EXPR_SUBSTRING:
3745       break;
3746
3747     case EXPR_STRUCTURE:
3748     case EXPR_ARRAY:
3749       for (c = gfc_constructor_first (expr->value.constructor);
3750            c; c = gfc_constructor_next (c))
3751         {
3752           if (gfc_traverse_expr (c->expr, sym, func, f))
3753             return true;
3754           if (c->iterator)
3755             {
3756               if (gfc_traverse_expr (c->iterator->var, sym, func, f))
3757                 return true;
3758               if (gfc_traverse_expr (c->iterator->start, sym, func, f))
3759                 return true;
3760               if (gfc_traverse_expr (c->iterator->end, sym, func, f))
3761                 return true;
3762               if (gfc_traverse_expr (c->iterator->step, sym, func, f))
3763                 return true;
3764             }
3765         }
3766       break;
3767
3768     case EXPR_OP:
3769       if (gfc_traverse_expr (expr->value.op.op1, sym, func, f))
3770         return true;
3771       if (gfc_traverse_expr (expr->value.op.op2, sym, func, f))
3772         return true;
3773       break;
3774
3775     default:
3776       gcc_unreachable ();
3777       break;
3778     }
3779
3780   ref = expr->ref;
3781   while (ref != NULL)
3782     {
3783       switch (ref->type)
3784         {
3785         case  REF_ARRAY:
3786           ar = ref->u.ar;
3787           for (i = 0; i < GFC_MAX_DIMENSIONS; i++)
3788             {
3789               if (gfc_traverse_expr (ar.start[i], sym, func, f))
3790                 return true;
3791               if (gfc_traverse_expr (ar.end[i], sym, func, f))
3792                 return true;
3793               if (gfc_traverse_expr (ar.stride[i], sym, func, f))
3794                 return true;
3795             }
3796           break;
3797
3798         case REF_SUBSTRING:
3799           if (gfc_traverse_expr (ref->u.ss.start, sym, func, f))
3800             return true;
3801           if (gfc_traverse_expr (ref->u.ss.end, sym, func, f))
3802             return true;
3803           break;
3804
3805         case REF_COMPONENT:
3806           if (ref->u.c.component->ts.type == BT_CHARACTER
3807                 && ref->u.c.component->ts.u.cl
3808                 && ref->u.c.component->ts.u.cl->length
3809                 && ref->u.c.component->ts.u.cl->length->expr_type
3810                      != EXPR_CONSTANT
3811                 && gfc_traverse_expr (ref->u.c.component->ts.u.cl->length,
3812                                       sym, func, f))
3813             return true;
3814
3815           if (ref->u.c.component->as)
3816             for (i = 0; i < ref->u.c.component->as->rank
3817                             + ref->u.c.component->as->corank; i++)
3818               {
3819                 if (gfc_traverse_expr (ref->u.c.component->as->lower[i],
3820                                        sym, func, f))
3821                   return true;
3822                 if (gfc_traverse_expr (ref->u.c.component->as->upper[i],
3823                                        sym, func, f))
3824                   return true;
3825               }
3826           break;
3827
3828         default:
3829           gcc_unreachable ();
3830         }
3831       ref = ref->next;
3832     }
3833   return false;
3834 }
3835
3836 /* Traverse expr, marking all EXPR_VARIABLE symbols referenced.  */
3837
3838 static bool
3839 expr_set_symbols_referenced (gfc_expr *expr,
3840                              gfc_symbol *sym ATTRIBUTE_UNUSED,
3841                              int *f ATTRIBUTE_UNUSED)
3842 {
3843   if (expr->expr_type != EXPR_VARIABLE)
3844     return false;
3845   gfc_set_sym_referenced (expr->symtree->n.sym);
3846   return false;
3847 }
3848
3849 void
3850 gfc_expr_set_symbols_referenced (gfc_expr *expr)
3851 {
3852   gfc_traverse_expr (expr, NULL, expr_set_symbols_referenced, 0);
3853 }
3854
3855
3856 /* Determine if an expression is a procedure pointer component. If yes, the
3857    argument 'comp' will point to the component (provided that 'comp' was
3858    provided).  */
3859
3860 bool
3861 gfc_is_proc_ptr_comp (gfc_expr *expr, gfc_component **comp)
3862 {
3863   gfc_ref *ref;
3864   bool ppc = false;
3865
3866   if (!expr || !expr->ref)
3867     return false;
3868
3869   ref = expr->ref;
3870   while (ref->next)
3871     ref = ref->next;
3872
3873   if (ref->type == REF_COMPONENT)
3874     {
3875       ppc = ref->u.c.component->attr.proc_pointer;
3876       if (ppc && comp)
3877         *comp = ref->u.c.component;
3878     }
3879
3880   return ppc;
3881 }
3882
3883
3884 /* Walk an expression tree and check each variable encountered for being typed.
3885    If strict is not set, a top-level variable is tolerated untyped in -std=gnu
3886    mode as is a basic arithmetic expression using those; this is for things in
3887    legacy-code like:
3888
3889      INTEGER :: arr(n), n
3890      INTEGER :: arr(n + 1), n
3891
3892    The namespace is needed for IMPLICIT typing.  */
3893
3894 static gfc_namespace* check_typed_ns;
3895
3896 static bool
3897 expr_check_typed_help (gfc_expr* e, gfc_symbol* sym ATTRIBUTE_UNUSED,
3898                        int* f ATTRIBUTE_UNUSED)
3899 {
3900   gfc_try t;
3901
3902   if (e->expr_type != EXPR_VARIABLE)
3903     return false;
3904
3905   gcc_assert (e->symtree);
3906   t = gfc_check_symbol_typed (e->symtree->n.sym, check_typed_ns,
3907                               true, e->where);
3908
3909   return (t == FAILURE);
3910 }
3911
3912 gfc_try
3913 gfc_expr_check_typed (gfc_expr* e, gfc_namespace* ns, bool strict)
3914 {
3915   bool error_found;
3916
3917   /* If this is a top-level variable or EXPR_OP, do the check with strict given
3918      to us.  */
3919   if (!strict)
3920     {
3921       if (e->expr_type == EXPR_VARIABLE && !e->ref)
3922         return gfc_check_symbol_typed (e->symtree->n.sym, ns, strict, e->where);
3923
3924       if (e->expr_type == EXPR_OP)
3925         {
3926           gfc_try t = SUCCESS;
3927
3928           gcc_assert (e->value.op.op1);
3929           t = gfc_expr_check_typed (e->value.op.op1, ns, strict);
3930
3931           if (t == SUCCESS && e->value.op.op2)
3932             t = gfc_expr_check_typed (e->value.op.op2, ns, strict);
3933
3934           return t;
3935         }
3936     }
3937
3938   /* Otherwise, walk the expression and do it strictly.  */
3939   check_typed_ns = ns;
3940   error_found = gfc_traverse_expr (e, NULL, &expr_check_typed_help, 0);
3941
3942   return error_found ? FAILURE : SUCCESS;
3943 }
3944
3945 /* Walk an expression tree and replace all symbols with a corresponding symbol
3946    in the formal_ns of "sym". Needed for copying interfaces in PROCEDURE
3947    statements. The boolean return value is required by gfc_traverse_expr.  */
3948
3949 static bool
3950 replace_symbol (gfc_expr *expr, gfc_symbol *sym, int *i ATTRIBUTE_UNUSED)
3951 {
3952   if ((expr->expr_type == EXPR_VARIABLE 
3953        || (expr->expr_type == EXPR_FUNCTION
3954            && !gfc_is_intrinsic (expr->symtree->n.sym, 0, expr->where)))
3955       && expr->symtree->n.sym->ns == sym->ts.interface->formal_ns)
3956     {
3957       gfc_symtree *stree;
3958       gfc_namespace *ns = sym->formal_ns;
3959       /* Don't use gfc_get_symtree as we prefer to fail badly if we don't find
3960          the symtree rather than create a new one (and probably fail later).  */
3961       stree = gfc_find_symtree (ns ? ns->sym_root : gfc_current_ns->sym_root,
3962                                 expr->symtree->n.sym->name);
3963       gcc_assert (stree);
3964       stree->n.sym->attr = expr->symtree->n.sym->attr;
3965       expr->symtree = stree;
3966     }
3967   return false;
3968 }
3969
3970 void
3971 gfc_expr_replace_symbols (gfc_expr *expr, gfc_symbol *dest)
3972 {
3973   gfc_traverse_expr (expr, dest, &replace_symbol, 0);
3974 }
3975
3976 /* The following is analogous to 'replace_symbol', and needed for copying
3977    interfaces for procedure pointer components. The argument 'sym' must formally
3978    be a gfc_symbol, so that the function can be passed to gfc_traverse_expr.
3979    However, it gets actually passed a gfc_component (i.e. the procedure pointer
3980    component in whose formal_ns the arguments have to be).  */
3981
3982 static bool
3983 replace_comp (gfc_expr *expr, gfc_symbol *sym, int *i ATTRIBUTE_UNUSED)
3984 {
3985   gfc_component *comp;
3986   comp = (gfc_component *)sym;
3987   if ((expr->expr_type == EXPR_VARIABLE 
3988        || (expr->expr_type == EXPR_FUNCTION
3989            && !gfc_is_intrinsic (expr->symtree->n.sym, 0, expr->where)))
3990       && expr->symtree->n.sym->ns == comp->ts.interface->formal_ns)
3991     {
3992       gfc_symtree *stree;
3993       gfc_namespace *ns = comp->formal_ns;
3994       /* Don't use gfc_get_symtree as we prefer to fail badly if we don't find
3995          the symtree rather than create a new one (and probably fail later).  */
3996       stree = gfc_find_symtree (ns ? ns->sym_root : gfc_current_ns->sym_root,
3997                                 expr->symtree->n.sym->name);
3998       gcc_assert (stree);
3999       stree->n.sym->attr = expr->symtree->n.sym->attr;
4000       expr->symtree = stree;
4001     }
4002   return false;
4003 }
4004
4005 void
4006 gfc_expr_replace_comp (gfc_expr *expr, gfc_component *dest)
4007 {
4008   gfc_traverse_expr (expr, (gfc_symbol *)dest, &replace_comp, 0);
4009 }
4010
4011
4012 bool
4013 gfc_is_coindexed (gfc_expr *e)
4014 {
4015   gfc_ref *ref;
4016
4017   for (ref = e->ref; ref; ref = ref->next)
4018     if (ref->type == REF_ARRAY && ref->u.ar.codimen > 0)
4019       return true;
4020
4021   return false;
4022 }
4023
4024
4025 /* Check whether the expression has an ultimate allocatable component.
4026    Being itself allocatable does not count.  */
4027 bool
4028 gfc_has_ultimate_allocatable (gfc_expr *e)
4029 {
4030   gfc_ref *ref, *last = NULL;
4031
4032   if (e->expr_type != EXPR_VARIABLE)
4033     return false;
4034
4035   for (ref = e->ref; ref; ref = ref->next)
4036     if (ref->type == REF_COMPONENT)
4037       last = ref;
4038
4039   if (last && last->u.c.component->ts.type == BT_CLASS)
4040     return CLASS_DATA (last->u.c.component)->attr.alloc_comp;
4041   else if (last && last->u.c.component->ts.type == BT_DERIVED)
4042     return last->u.c.component->ts.u.derived->attr.alloc_comp;
4043   else if (last)
4044     return false;
4045
4046   if (e->ts.type == BT_CLASS)
4047     return CLASS_DATA (e)->attr.alloc_comp;
4048   else if (e->ts.type == BT_DERIVED)
4049     return e->ts.u.derived->attr.alloc_comp;
4050   else
4051     return false;
4052 }
4053
4054
4055 /* Check whether the expression has an pointer component.
4056    Being itself a pointer does not count.  */
4057 bool
4058 gfc_has_ultimate_pointer (gfc_expr *e)
4059 {
4060   gfc_ref *ref, *last = NULL;
4061
4062   if (e->expr_type != EXPR_VARIABLE)
4063     return false;
4064
4065   for (ref = e->ref; ref; ref = ref->next)
4066     if (ref->type == REF_COMPONENT)
4067       last = ref;
4068  
4069   if (last && last->u.c.component->ts.type == BT_CLASS)
4070     return CLASS_DATA (last->u.c.component)->attr.pointer_comp;
4071   else if (last && last->u.c.component->ts.type == BT_DERIVED)
4072     return last->u.c.component->ts.u.derived->attr.pointer_comp;
4073   else if (last)
4074     return false;
4075
4076   if (e->ts.type == BT_CLASS)
4077     return CLASS_DATA (e)->attr.pointer_comp;
4078   else if (e->ts.type == BT_DERIVED)
4079     return e->ts.u.derived->attr.pointer_comp;
4080   else
4081     return false;
4082 }
4083
4084
4085 /* Check whether an expression is "simply contiguous", cf. F2008, 6.5.4.
4086    Note: A scalar is not regarded as "simply contiguous" by the standard.
4087    if bool is not strict, some futher checks are done - for instance,
4088    a "(::1)" is accepted.  */
4089
4090 bool
4091 gfc_is_simply_contiguous (gfc_expr *expr, bool strict)
4092 {
4093   bool colon;
4094   int i;
4095   gfc_array_ref *ar = NULL;
4096   gfc_ref *ref, *part_ref = NULL;
4097
4098   if (expr->expr_type == EXPR_FUNCTION)
4099     return expr->value.function.esym
4100            ? expr->value.function.esym->result->attr.contiguous : false;
4101   else if (expr->expr_type != EXPR_VARIABLE)
4102     return false;
4103
4104   if (expr->rank == 0)
4105     return false;
4106
4107   for (ref = expr->ref; ref; ref = ref->next)
4108     {
4109       if (ar)
4110         return false; /* Array shall be last part-ref. */
4111
4112       if (ref->type == REF_COMPONENT)
4113         part_ref  = ref;
4114       else if (ref->type == REF_SUBSTRING)
4115         return false;
4116       else if (ref->u.ar.type != AR_ELEMENT)
4117         ar = &ref->u.ar;
4118     }
4119
4120   if ((part_ref && !part_ref->u.c.component->attr.contiguous
4121        && part_ref->u.c.component->attr.pointer)
4122       || (!part_ref && !expr->symtree->n.sym->attr.contiguous
4123           && (expr->symtree->n.sym->attr.pointer
4124               || expr->symtree->n.sym->as->type == AS_ASSUMED_SHAPE)))
4125     return false;
4126
4127   if (!ar || ar->type == AR_FULL)
4128     return true;
4129
4130   gcc_assert (ar->type == AR_SECTION);
4131
4132   /* Check for simply contiguous array */
4133   colon = true;
4134   for (i = 0; i < ar->dimen; i++)
4135     {
4136       if (ar->dimen_type[i] == DIMEN_VECTOR)
4137         return false;
4138
4139       if (ar->dimen_type[i] == DIMEN_ELEMENT)
4140         {
4141           colon = false;
4142           continue;
4143         }
4144
4145       gcc_assert (ar->dimen_type[i] == DIMEN_RANGE);
4146
4147
4148       /* If the previous section was not contiguous, that's an error,
4149          unless we have effective only one element and checking is not
4150          strict.  */
4151       if (!colon && (strict || !ar->start[i] || !ar->end[i]
4152                      || ar->start[i]->expr_type != EXPR_CONSTANT
4153                      || ar->end[i]->expr_type != EXPR_CONSTANT
4154                      || mpz_cmp (ar->start[i]->value.integer,
4155                                  ar->end[i]->value.integer) != 0))
4156         return false;
4157
4158       /* Following the standard, "(::1)" or - if known at compile time -
4159          "(lbound:ubound)" are not simply contigous; if strict
4160          is false, they are regarded as simply contiguous.  */
4161       if (ar->stride[i] && (strict || ar->stride[i]->expr_type != EXPR_CONSTANT
4162                             || ar->stride[i]->ts.type != BT_INTEGER
4163                             || mpz_cmp_si (ar->stride[i]->value.integer, 1) != 0))
4164         return false;
4165
4166       if (ar->start[i]
4167           && (strict || ar->start[i]->expr_type != EXPR_CONSTANT
4168               || !ar->as->lower[i]
4169               || ar->as->lower[i]->expr_type != EXPR_CONSTANT
4170               || mpz_cmp (ar->start[i]->value.integer,
4171                           ar->as->lower[i]->value.integer) != 0))
4172         colon = false;
4173
4174       if (ar->end[i]
4175           && (strict || ar->end[i]->expr_type != EXPR_CONSTANT
4176               || !ar->as->upper[i]
4177               || ar->as->upper[i]->expr_type != EXPR_CONSTANT
4178               || mpz_cmp (ar->end[i]->value.integer,
4179                           ar->as->upper[i]->value.integer) != 0))
4180         colon = false;
4181     }
4182   
4183   return true;
4184 }