OSDN Git Service

ef516a4442d24bd143ba3cca3185cb2ffccacdd6
[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_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         if (not_restricted == 0
2310             && ap->expr->expr_type == EXPR_VARIABLE
2311             && ap->expr->symtree->n.sym->attr.dummy
2312             && ap->expr->symtree->n.sym->attr.optional)
2313           return MATCH_NO;
2314     }
2315
2316   return MATCH_YES;
2317 }
2318
2319
2320 /* F95, 7.1.6.1, Initialization expressions, (5)
2321    F2003, 7.1.7 Initialization expression, (5)  */
2322
2323 static match
2324 check_transformational (gfc_expr *e)
2325 {
2326   static const char * const trans_func_f95[] = {
2327     "repeat", "reshape", "selected_int_kind",
2328     "selected_real_kind", "transfer", "trim", NULL
2329   };
2330
2331   static const char * const trans_func_f2003[] =  {
2332     "all", "any", "count", "dot_product", "matmul", "null", "pack",
2333     "product", "repeat", "reshape", "selected_char_kind", "selected_int_kind",
2334     "selected_real_kind", "spread", "sum", "transfer", "transpose",
2335     "trim", "unpack", NULL
2336   };
2337
2338   int i;
2339   const char *name;
2340   const char *const *functions;
2341
2342   if (!e->value.function.isym
2343       || !e->value.function.isym->transformational)
2344     return MATCH_NO;
2345
2346   name = e->symtree->n.sym->name;
2347
2348   functions = (gfc_option.allow_std & GFC_STD_F2003) 
2349                 ? trans_func_f2003 : trans_func_f95;
2350
2351   /* NULL() is dealt with below.  */
2352   if (strcmp ("null", name) == 0)
2353     return MATCH_NO;
2354
2355   for (i = 0; functions[i]; i++)
2356     if (strcmp (functions[i], name) == 0)
2357        break;
2358
2359   if (functions[i] == NULL)
2360     {
2361       gfc_error("transformational intrinsic '%s' at %L is not permitted "
2362                 "in an initialization expression", name, &e->where);
2363       return MATCH_ERROR;
2364     }
2365
2366   return check_init_expr_arguments (e);
2367 }
2368
2369
2370 /* F95, 7.1.6.1, Initialization expressions, (6)
2371    F2003, 7.1.7 Initialization expression, (6)  */
2372
2373 static match
2374 check_null (gfc_expr *e)
2375 {
2376   if (strcmp ("null", e->symtree->n.sym->name) != 0)
2377     return MATCH_NO;
2378
2379   return check_init_expr_arguments (e);
2380 }
2381
2382
2383 static match
2384 check_elemental (gfc_expr *e)
2385 {
2386   if (!e->value.function.isym
2387       || !e->value.function.isym->elemental)
2388     return MATCH_NO;
2389
2390   if (e->ts.type != BT_INTEGER
2391       && e->ts.type != BT_CHARACTER
2392       && gfc_notify_std (GFC_STD_F2003, "Extension: Evaluation of "
2393                         "nonstandard initialization expression at %L",
2394                         &e->where) == FAILURE)
2395     return MATCH_ERROR;
2396
2397   return check_init_expr_arguments (e);
2398 }
2399
2400
2401 static match
2402 check_conversion (gfc_expr *e)
2403 {
2404   if (!e->value.function.isym
2405       || !e->value.function.isym->conversion)
2406     return MATCH_NO;
2407
2408   return check_init_expr_arguments (e);
2409 }
2410
2411
2412 /* Verify that an expression is an initialization expression.  A side
2413    effect is that the expression tree is reduced to a single constant
2414    node if all goes well.  This would normally happen when the
2415    expression is constructed but function references are assumed to be
2416    intrinsics in the context of initialization expressions.  If
2417    FAILURE is returned an error message has been generated.  */
2418
2419 static gfc_try
2420 check_init_expr (gfc_expr *e)
2421 {
2422   match m;
2423   gfc_try t;
2424
2425   if (e == NULL)
2426     return SUCCESS;
2427
2428   switch (e->expr_type)
2429     {
2430     case EXPR_OP:
2431       t = check_intrinsic_op (e, check_init_expr);
2432       if (t == SUCCESS)
2433         t = gfc_simplify_expr (e, 0);
2434
2435       break;
2436
2437     case EXPR_FUNCTION:
2438       t = FAILURE;
2439
2440       {
2441         gfc_intrinsic_sym* isym;
2442         gfc_symbol* sym;
2443
2444         sym = e->symtree->n.sym;
2445         if (!gfc_is_intrinsic (sym, 0, e->where)
2446             || (m = gfc_intrinsic_func_interface (e, 0)) != MATCH_YES)
2447           {
2448             gfc_error ("Function '%s' in initialization expression at %L "
2449                        "must be an intrinsic function",
2450                        e->symtree->n.sym->name, &e->where);
2451             break;
2452           }
2453
2454         if ((m = check_conversion (e)) == MATCH_NO
2455             && (m = check_inquiry (e, 1)) == MATCH_NO
2456             && (m = check_null (e)) == MATCH_NO
2457             && (m = check_transformational (e)) == MATCH_NO
2458             && (m = check_elemental (e)) == MATCH_NO)
2459           {
2460             gfc_error ("Intrinsic function '%s' at %L is not permitted "
2461                        "in an initialization expression",
2462                        e->symtree->n.sym->name, &e->where);
2463             m = MATCH_ERROR;
2464           }
2465
2466         /* Try to scalarize an elemental intrinsic function that has an
2467            array argument.  */
2468         isym = gfc_find_function (e->symtree->n.sym->name);
2469         if (isym && isym->elemental
2470             && (t = scalarize_intrinsic_call (e)) == SUCCESS)
2471           break;
2472       }
2473
2474       if (m == MATCH_YES)
2475         t = gfc_simplify_expr (e, 0);
2476
2477       break;
2478
2479     case EXPR_VARIABLE:
2480       t = SUCCESS;
2481
2482       if (gfc_check_iter_variable (e) == SUCCESS)
2483         break;
2484
2485       if (e->symtree->n.sym->attr.flavor == FL_PARAMETER)
2486         {
2487           /* A PARAMETER shall not be used to define itself, i.e.
2488                 REAL, PARAMETER :: x = transfer(0, x)
2489              is invalid.  */
2490           if (!e->symtree->n.sym->value)
2491             {
2492               gfc_error("PARAMETER '%s' is used at %L before its definition "
2493                         "is complete", e->symtree->n.sym->name, &e->where);
2494               t = FAILURE;
2495             }
2496           else
2497             t = simplify_parameter_variable (e, 0);
2498
2499           break;
2500         }
2501
2502       if (gfc_in_match_data ())
2503         break;
2504
2505       t = FAILURE;
2506
2507       if (e->symtree->n.sym->as)
2508         {
2509           switch (e->symtree->n.sym->as->type)
2510             {
2511               case AS_ASSUMED_SIZE:
2512                 gfc_error ("Assumed size 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_ASSUMED_SHAPE:
2518                 gfc_error ("Assumed shape 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_DEFERRED:
2524                 gfc_error ("Deferred array '%s' at %L is not permitted "
2525                            "in an initialization expression",
2526                            e->symtree->n.sym->name, &e->where);
2527                 break;
2528
2529               case AS_EXPLICIT:
2530                 gfc_error ("Array '%s' at %L is a variable, which does "
2531                            "not reduce to a constant expression",
2532                            e->symtree->n.sym->name, &e->where);
2533                 break;
2534
2535               default:
2536                 gcc_unreachable();
2537           }
2538         }
2539       else
2540         gfc_error ("Parameter '%s' at %L has not been declared or is "
2541                    "a variable, which does not reduce to a constant "
2542                    "expression", e->symtree->n.sym->name, &e->where);
2543
2544       break;
2545
2546     case EXPR_CONSTANT:
2547     case EXPR_NULL:
2548       t = SUCCESS;
2549       break;
2550
2551     case EXPR_SUBSTRING:
2552       t = check_init_expr (e->ref->u.ss.start);
2553       if (t == FAILURE)
2554         break;
2555
2556       t = check_init_expr (e->ref->u.ss.end);
2557       if (t == SUCCESS)
2558         t = gfc_simplify_expr (e, 0);
2559
2560       break;
2561
2562     case EXPR_STRUCTURE:
2563       t = e->ts.is_iso_c ? SUCCESS : FAILURE;
2564       if (t == SUCCESS)
2565         break;
2566
2567       t = check_alloc_comp_init (e);
2568       if (t == FAILURE)
2569         break;
2570
2571       t = gfc_check_constructor (e, check_init_expr);
2572       if (t == FAILURE)
2573         break;
2574
2575       break;
2576
2577     case EXPR_ARRAY:
2578       t = gfc_check_constructor (e, check_init_expr);
2579       if (t == FAILURE)
2580         break;
2581
2582       t = gfc_expand_constructor (e, true);
2583       if (t == FAILURE)
2584         break;
2585
2586       t = gfc_check_constructor_type (e);
2587       break;
2588
2589     default:
2590       gfc_internal_error ("check_init_expr(): Unknown expression type");
2591     }
2592
2593   return t;
2594 }
2595
2596 /* Reduces a general expression to an initialization expression (a constant).
2597    This used to be part of gfc_match_init_expr.
2598    Note that this function doesn't free the given expression on FAILURE.  */
2599
2600 gfc_try
2601 gfc_reduce_init_expr (gfc_expr *expr)
2602 {
2603   gfc_try t;
2604
2605   gfc_init_expr_flag = true;
2606   t = gfc_resolve_expr (expr);
2607   if (t == SUCCESS)
2608     t = check_init_expr (expr);
2609   gfc_init_expr_flag = false;
2610
2611   if (t == FAILURE)
2612     return FAILURE;
2613
2614   if (expr->expr_type == EXPR_ARRAY)
2615     {
2616       if (gfc_check_constructor_type (expr) == FAILURE)
2617         return FAILURE;
2618       if (gfc_expand_constructor (expr, true) == FAILURE)
2619         return FAILURE;
2620     }
2621
2622   return SUCCESS;
2623 }
2624
2625
2626 /* Match an initialization expression.  We work by first matching an
2627    expression, then reducing it to a constant.  */
2628
2629 match
2630 gfc_match_init_expr (gfc_expr **result)
2631 {
2632   gfc_expr *expr;
2633   match m;
2634   gfc_try t;
2635
2636   expr = NULL;
2637
2638   gfc_init_expr_flag = true;
2639
2640   m = gfc_match_expr (&expr);
2641   if (m != MATCH_YES)
2642     {
2643       gfc_init_expr_flag = false;
2644       return m;
2645     }
2646
2647   t = gfc_reduce_init_expr (expr);
2648   if (t != SUCCESS)
2649     {
2650       gfc_free_expr (expr);
2651       gfc_init_expr_flag = false;
2652       return MATCH_ERROR;
2653     }
2654
2655   *result = expr;
2656   gfc_init_expr_flag = false;
2657
2658   return MATCH_YES;
2659 }
2660
2661
2662 /* Given an actual argument list, test to see that each argument is a
2663    restricted expression and optionally if the expression type is
2664    integer or character.  */
2665
2666 static gfc_try
2667 restricted_args (gfc_actual_arglist *a)
2668 {
2669   for (; a; a = a->next)
2670     {
2671       if (check_restricted (a->expr) == FAILURE)
2672         return FAILURE;
2673     }
2674
2675   return SUCCESS;
2676 }
2677
2678
2679 /************* Restricted/specification expressions *************/
2680
2681
2682 /* Make sure a non-intrinsic function is a specification function.  */
2683
2684 static gfc_try
2685 external_spec_function (gfc_expr *e)
2686 {
2687   gfc_symbol *f;
2688
2689   f = e->value.function.esym;
2690
2691   if (f->attr.proc == PROC_ST_FUNCTION)
2692     {
2693       gfc_error ("Specification function '%s' at %L cannot be a statement "
2694                  "function", f->name, &e->where);
2695       return FAILURE;
2696     }
2697
2698   if (f->attr.proc == PROC_INTERNAL)
2699     {
2700       gfc_error ("Specification function '%s' at %L cannot be an internal "
2701                  "function", f->name, &e->where);
2702       return FAILURE;
2703     }
2704
2705   if (!f->attr.pure && !f->attr.elemental)
2706     {
2707       gfc_error ("Specification function '%s' at %L must be PURE", f->name,
2708                  &e->where);
2709       return FAILURE;
2710     }
2711
2712   if (f->attr.recursive)
2713     {
2714       gfc_error ("Specification function '%s' at %L cannot be RECURSIVE",
2715                  f->name, &e->where);
2716       return FAILURE;
2717     }
2718
2719   return restricted_args (e->value.function.actual);
2720 }
2721
2722
2723 /* Check to see that a function reference to an intrinsic is a
2724    restricted expression.  */
2725
2726 static gfc_try
2727 restricted_intrinsic (gfc_expr *e)
2728 {
2729   /* TODO: Check constraints on inquiry functions.  7.1.6.2 (7).  */
2730   if (check_inquiry (e, 0) == MATCH_YES)
2731     return SUCCESS;
2732
2733   return restricted_args (e->value.function.actual);
2734 }
2735
2736
2737 /* Check the expressions of an actual arglist.  Used by check_restricted.  */
2738
2739 static gfc_try
2740 check_arglist (gfc_actual_arglist* arg, gfc_try (*checker) (gfc_expr*))
2741 {
2742   for (; arg; arg = arg->next)
2743     if (checker (arg->expr) == FAILURE)
2744       return FAILURE;
2745
2746   return SUCCESS;
2747 }
2748
2749
2750 /* Check the subscription expressions of a reference chain with a checking
2751    function; used by check_restricted.  */
2752
2753 static gfc_try
2754 check_references (gfc_ref* ref, gfc_try (*checker) (gfc_expr*))
2755 {
2756   int dim;
2757
2758   if (!ref)
2759     return SUCCESS;
2760
2761   switch (ref->type)
2762     {
2763     case REF_ARRAY:
2764       for (dim = 0; dim != ref->u.ar.dimen; ++dim)
2765         {
2766           if (checker (ref->u.ar.start[dim]) == FAILURE)
2767             return FAILURE;
2768           if (checker (ref->u.ar.end[dim]) == FAILURE)
2769             return FAILURE;
2770           if (checker (ref->u.ar.stride[dim]) == FAILURE)
2771             return FAILURE;
2772         }
2773       break;
2774
2775     case REF_COMPONENT:
2776       /* Nothing needed, just proceed to next reference.  */
2777       break;
2778
2779     case REF_SUBSTRING:
2780       if (checker (ref->u.ss.start) == FAILURE)
2781         return FAILURE;
2782       if (checker (ref->u.ss.end) == FAILURE)
2783         return FAILURE;
2784       break;
2785
2786     default:
2787       gcc_unreachable ();
2788       break;
2789     }
2790
2791   return check_references (ref->next, checker);
2792 }
2793
2794
2795 /* Verify that an expression is a restricted expression.  Like its
2796    cousin check_init_expr(), an error message is generated if we
2797    return FAILURE.  */
2798
2799 static gfc_try
2800 check_restricted (gfc_expr *e)
2801 {
2802   gfc_symbol* sym;
2803   gfc_try t;
2804
2805   if (e == NULL)
2806     return SUCCESS;
2807
2808   switch (e->expr_type)
2809     {
2810     case EXPR_OP:
2811       t = check_intrinsic_op (e, check_restricted);
2812       if (t == SUCCESS)
2813         t = gfc_simplify_expr (e, 0);
2814
2815       break;
2816
2817     case EXPR_FUNCTION:
2818       if (e->value.function.esym)
2819         {
2820           t = check_arglist (e->value.function.actual, &check_restricted);
2821           if (t == SUCCESS)
2822             t = external_spec_function (e);
2823         }
2824       else
2825         {
2826           if (e->value.function.isym && e->value.function.isym->inquiry)
2827             t = SUCCESS;
2828           else
2829             t = check_arglist (e->value.function.actual, &check_restricted);
2830
2831           if (t == SUCCESS)
2832             t = restricted_intrinsic (e);
2833         }
2834       break;
2835
2836     case EXPR_VARIABLE:
2837       sym = e->symtree->n.sym;
2838       t = FAILURE;
2839
2840       /* If a dummy argument appears in a context that is valid for a
2841          restricted expression in an elemental procedure, it will have
2842          already been simplified away once we get here.  Therefore we
2843          don't need to jump through hoops to distinguish valid from
2844          invalid cases.  */
2845       if (sym->attr.dummy && sym->ns == gfc_current_ns
2846           && sym->ns->proc_name && sym->ns->proc_name->attr.elemental)
2847         {
2848           gfc_error ("Dummy argument '%s' not allowed in expression at %L",
2849                      sym->name, &e->where);
2850           break;
2851         }
2852
2853       if (sym->attr.optional)
2854         {
2855           gfc_error ("Dummy argument '%s' at %L cannot be OPTIONAL",
2856                      sym->name, &e->where);
2857           break;
2858         }
2859
2860       if (sym->attr.intent == INTENT_OUT)
2861         {
2862           gfc_error ("Dummy argument '%s' at %L cannot be INTENT(OUT)",
2863                      sym->name, &e->where);
2864           break;
2865         }
2866
2867       /* Check reference chain if any.  */
2868       if (check_references (e->ref, &check_restricted) == FAILURE)
2869         break;
2870
2871       /* gfc_is_formal_arg broadcasts that a formal argument list is being
2872          processed in resolve.c(resolve_formal_arglist).  This is done so
2873          that host associated dummy array indices are accepted (PR23446).
2874          This mechanism also does the same for the specification expressions
2875          of array-valued functions.  */
2876       if (e->error
2877             || sym->attr.in_common
2878             || sym->attr.use_assoc
2879             || sym->attr.dummy
2880             || sym->attr.implied_index
2881             || sym->attr.flavor == FL_PARAMETER
2882             || (sym->ns && sym->ns == gfc_current_ns->parent)
2883             || (sym->ns && gfc_current_ns->parent
2884                   && sym->ns == gfc_current_ns->parent->parent)
2885             || (sym->ns->proc_name != NULL
2886                   && sym->ns->proc_name->attr.flavor == FL_MODULE)
2887             || (gfc_is_formal_arg () && (sym->ns == gfc_current_ns)))
2888         {
2889           t = SUCCESS;
2890           break;
2891         }
2892
2893       gfc_error ("Variable '%s' cannot appear in the expression at %L",
2894                  sym->name, &e->where);
2895       /* Prevent a repetition of the error.  */
2896       e->error = 1;
2897       break;
2898
2899     case EXPR_NULL:
2900     case EXPR_CONSTANT:
2901       t = SUCCESS;
2902       break;
2903
2904     case EXPR_SUBSTRING:
2905       t = gfc_specification_expr (e->ref->u.ss.start);
2906       if (t == FAILURE)
2907         break;
2908
2909       t = gfc_specification_expr (e->ref->u.ss.end);
2910       if (t == SUCCESS)
2911         t = gfc_simplify_expr (e, 0);
2912
2913       break;
2914
2915     case EXPR_STRUCTURE:
2916       t = gfc_check_constructor (e, check_restricted);
2917       break;
2918
2919     case EXPR_ARRAY:
2920       t = gfc_check_constructor (e, check_restricted);
2921       break;
2922
2923     default:
2924       gfc_internal_error ("check_restricted(): Unknown expression type");
2925     }
2926
2927   return t;
2928 }
2929
2930
2931 /* Check to see that an expression is a specification expression.  If
2932    we return FAILURE, an error has been generated.  */
2933
2934 gfc_try
2935 gfc_specification_expr (gfc_expr *e)
2936 {
2937   gfc_component *comp;
2938
2939   if (e == NULL)
2940     return SUCCESS;
2941
2942   if (e->ts.type != BT_INTEGER)
2943     {
2944       gfc_error ("Expression at %L must be of INTEGER type, found %s",
2945                  &e->where, gfc_basic_typename (e->ts.type));
2946       return FAILURE;
2947     }
2948
2949   if (e->expr_type == EXPR_FUNCTION
2950           && !e->value.function.isym
2951           && !e->value.function.esym
2952           && !gfc_pure (e->symtree->n.sym)
2953           && (!gfc_is_proc_ptr_comp (e, &comp)
2954               || !comp->attr.pure))
2955     {
2956       gfc_error ("Function '%s' at %L must be PURE",
2957                  e->symtree->n.sym->name, &e->where);
2958       /* Prevent repeat error messages.  */
2959       e->symtree->n.sym->attr.pure = 1;
2960       return FAILURE;
2961     }
2962
2963   if (e->rank != 0)
2964     {
2965       gfc_error ("Expression at %L must be scalar", &e->where);
2966       return FAILURE;
2967     }
2968
2969   if (gfc_simplify_expr (e, 0) == FAILURE)
2970     return FAILURE;
2971
2972   return check_restricted (e);
2973 }
2974
2975
2976 /************** Expression conformance checks.  *************/
2977
2978 /* Given two expressions, make sure that the arrays are conformable.  */
2979
2980 gfc_try
2981 gfc_check_conformance (gfc_expr *op1, gfc_expr *op2, const char *optype_msgid, ...)
2982 {
2983   int op1_flag, op2_flag, d;
2984   mpz_t op1_size, op2_size;
2985   gfc_try t;
2986
2987   va_list argp;
2988   char buffer[240];
2989
2990   if (op1->rank == 0 || op2->rank == 0)
2991     return SUCCESS;
2992
2993   va_start (argp, optype_msgid);
2994   vsnprintf (buffer, 240, optype_msgid, argp);
2995   va_end (argp);
2996
2997   if (op1->rank != op2->rank)
2998     {
2999       gfc_error ("Incompatible ranks in %s (%d and %d) at %L", _(buffer),
3000                  op1->rank, op2->rank, &op1->where);
3001       return FAILURE;
3002     }
3003
3004   t = SUCCESS;
3005
3006   for (d = 0; d < op1->rank; d++)
3007     {
3008       op1_flag = gfc_array_dimen_size (op1, d, &op1_size) == SUCCESS;
3009       op2_flag = gfc_array_dimen_size (op2, d, &op2_size) == SUCCESS;
3010
3011       if (op1_flag && op2_flag && mpz_cmp (op1_size, op2_size) != 0)
3012         {
3013           gfc_error ("Different shape for %s at %L on dimension %d "
3014                      "(%d and %d)", _(buffer), &op1->where, d + 1,
3015                      (int) mpz_get_si (op1_size),
3016                      (int) mpz_get_si (op2_size));
3017
3018           t = FAILURE;
3019         }
3020
3021       if (op1_flag)
3022         mpz_clear (op1_size);
3023       if (op2_flag)
3024         mpz_clear (op2_size);
3025
3026       if (t == FAILURE)
3027         return FAILURE;
3028     }
3029
3030   return SUCCESS;
3031 }
3032
3033
3034 /* Given an assignable expression and an arbitrary expression, make
3035    sure that the assignment can take place.  */
3036
3037 gfc_try
3038 gfc_check_assign (gfc_expr *lvalue, gfc_expr *rvalue, int conform)
3039 {
3040   gfc_symbol *sym;
3041   gfc_ref *ref;
3042   int has_pointer;
3043
3044   sym = lvalue->symtree->n.sym;
3045
3046   /* See if this is the component or subcomponent of a pointer.  */
3047   has_pointer = sym->attr.pointer;
3048   for (ref = lvalue->ref; ref; ref = ref->next)
3049     if (ref->type == REF_COMPONENT && ref->u.c.component->attr.pointer)
3050       {
3051         has_pointer = 1;
3052         break;
3053       }
3054
3055   /* 12.5.2.2, Note 12.26: The result variable is very similar to any other
3056      variable local to a function subprogram.  Its existence begins when
3057      execution of the function is initiated and ends when execution of the
3058      function is terminated...
3059      Therefore, the left hand side is no longer a variable, when it is:  */
3060   if (sym->attr.flavor == FL_PROCEDURE && sym->attr.proc != PROC_ST_FUNCTION
3061       && !sym->attr.external)
3062     {
3063       bool bad_proc;
3064       bad_proc = false;
3065
3066       /* (i) Use associated;  */
3067       if (sym->attr.use_assoc)
3068         bad_proc = true;
3069
3070       /* (ii) The assignment is in the main program; or  */
3071       if (gfc_current_ns->proc_name->attr.is_main_program)
3072         bad_proc = true;
3073
3074       /* (iii) A module or internal procedure...  */
3075       if ((gfc_current_ns->proc_name->attr.proc == PROC_INTERNAL
3076            || gfc_current_ns->proc_name->attr.proc == PROC_MODULE)
3077           && gfc_current_ns->parent
3078           && (!(gfc_current_ns->parent->proc_name->attr.function
3079                 || gfc_current_ns->parent->proc_name->attr.subroutine)
3080               || gfc_current_ns->parent->proc_name->attr.is_main_program))
3081         {
3082           /* ... that is not a function...  */ 
3083           if (!gfc_current_ns->proc_name->attr.function)
3084             bad_proc = true;
3085
3086           /* ... or is not an entry and has a different name.  */
3087           if (!sym->attr.entry && sym->name != gfc_current_ns->proc_name->name)
3088             bad_proc = true;
3089         }
3090
3091       /* (iv) Host associated and not the function symbol or the
3092               parent result.  This picks up sibling references, which
3093               cannot be entries.  */
3094       if (!sym->attr.entry
3095             && sym->ns == gfc_current_ns->parent
3096             && sym != gfc_current_ns->proc_name
3097             && sym != gfc_current_ns->parent->proc_name->result)
3098         bad_proc = true;
3099
3100       if (bad_proc)
3101         {
3102           gfc_error ("'%s' at %L is not a VALUE", sym->name, &lvalue->where);
3103           return FAILURE;
3104         }
3105     }
3106
3107   if (rvalue->rank != 0 && lvalue->rank != rvalue->rank)
3108     {
3109       gfc_error ("Incompatible ranks %d and %d in assignment at %L",
3110                  lvalue->rank, rvalue->rank, &lvalue->where);
3111       return FAILURE;
3112     }
3113
3114   if (lvalue->ts.type == BT_UNKNOWN)
3115     {
3116       gfc_error ("Variable type is UNKNOWN in assignment at %L",
3117                  &lvalue->where);
3118       return FAILURE;
3119     }
3120
3121   if (rvalue->expr_type == EXPR_NULL)
3122     {  
3123       if (has_pointer && (ref == NULL || ref->next == NULL)
3124           && lvalue->symtree->n.sym->attr.data)
3125         return SUCCESS;
3126       else
3127         {
3128           gfc_error ("NULL appears on right-hand side in assignment at %L",
3129                      &rvalue->where);
3130           return FAILURE;
3131         }
3132     }
3133
3134   /* This is possibly a typo: x = f() instead of x => f().  */
3135   if (gfc_option.warn_surprising 
3136       && rvalue->expr_type == EXPR_FUNCTION
3137       && rvalue->symtree->n.sym->attr.pointer)
3138     gfc_warning ("POINTER valued function appears on right-hand side of "
3139                  "assignment at %L", &rvalue->where);
3140
3141   /* Check size of array assignments.  */
3142   if (lvalue->rank != 0 && rvalue->rank != 0
3143       && gfc_check_conformance (lvalue, rvalue, "array assignment") != SUCCESS)
3144     return FAILURE;
3145
3146   if (rvalue->is_boz && lvalue->ts.type != BT_INTEGER
3147       && lvalue->symtree->n.sym->attr.data
3148       && gfc_notify_std (GFC_STD_GNU, "Extension: BOZ literal at %L used to "
3149                          "initialize non-integer variable '%s'",
3150                          &rvalue->where, lvalue->symtree->n.sym->name)
3151          == FAILURE)
3152     return FAILURE;
3153   else if (rvalue->is_boz && !lvalue->symtree->n.sym->attr.data
3154       && gfc_notify_std (GFC_STD_GNU, "Extension: BOZ literal at %L outside "
3155                          "a DATA statement and outside INT/REAL/DBLE/CMPLX",
3156                          &rvalue->where) == FAILURE)
3157     return FAILURE;
3158
3159   /* Handle the case of a BOZ literal on the RHS.  */
3160   if (rvalue->is_boz && lvalue->ts.type != BT_INTEGER)
3161     {
3162       int rc;
3163       if (gfc_option.warn_surprising)
3164         gfc_warning ("BOZ literal at %L is bitwise transferred "
3165                      "non-integer symbol '%s'", &rvalue->where,
3166                      lvalue->symtree->n.sym->name);
3167       if (!gfc_convert_boz (rvalue, &lvalue->ts))
3168         return FAILURE;
3169       if ((rc = gfc_range_check (rvalue)) != ARITH_OK)
3170         {
3171           if (rc == ARITH_UNDERFLOW)
3172             gfc_error ("Arithmetic underflow of bit-wise transferred BOZ at %L"
3173                        ". This check can be disabled with the option "
3174                        "-fno-range-check", &rvalue->where);
3175           else if (rc == ARITH_OVERFLOW)
3176             gfc_error ("Arithmetic overflow of bit-wise transferred BOZ at %L"
3177                        ". This check can be disabled with the option "
3178                        "-fno-range-check", &rvalue->where);
3179           else if (rc == ARITH_NAN)
3180             gfc_error ("Arithmetic NaN of bit-wise transferred BOZ at %L"
3181                        ". This check can be disabled with the option "
3182                        "-fno-range-check", &rvalue->where);
3183           return FAILURE;
3184         }
3185     }
3186
3187   if (gfc_compare_types (&lvalue->ts, &rvalue->ts))
3188     return SUCCESS;
3189
3190   /* Only DATA Statements come here.  */
3191   if (!conform)
3192     {
3193       /* Numeric can be converted to any other numeric. And Hollerith can be
3194          converted to any other type.  */
3195       if ((gfc_numeric_ts (&lvalue->ts) && gfc_numeric_ts (&rvalue->ts))
3196           || rvalue->ts.type == BT_HOLLERITH)
3197         return SUCCESS;
3198
3199       if (lvalue->ts.type == BT_LOGICAL && rvalue->ts.type == BT_LOGICAL)
3200         return SUCCESS;
3201
3202       gfc_error ("Incompatible types in DATA statement at %L; attempted "
3203                  "conversion of %s to %s", &lvalue->where,
3204                  gfc_typename (&rvalue->ts), gfc_typename (&lvalue->ts));
3205
3206       return FAILURE;
3207     }
3208
3209   /* Assignment is the only case where character variables of different
3210      kind values can be converted into one another.  */
3211   if (lvalue->ts.type == BT_CHARACTER && rvalue->ts.type == BT_CHARACTER)
3212     {
3213       if (lvalue->ts.kind != rvalue->ts.kind)
3214         gfc_convert_chartype (rvalue, &lvalue->ts);
3215
3216       return SUCCESS;
3217     }
3218
3219   return gfc_convert_type (rvalue, &lvalue->ts, 1);
3220 }
3221
3222
3223 /* Check that a pointer assignment is OK.  We first check lvalue, and
3224    we only check rvalue if it's not an assignment to NULL() or a
3225    NULLIFY statement.  */
3226
3227 gfc_try
3228 gfc_check_pointer_assign (gfc_expr *lvalue, gfc_expr *rvalue)
3229 {
3230   symbol_attribute attr;
3231   gfc_ref *ref;
3232   bool is_pure, rank_remap;
3233   int proc_pointer;
3234
3235   if (lvalue->symtree->n.sym->ts.type == BT_UNKNOWN
3236       && !lvalue->symtree->n.sym->attr.proc_pointer)
3237     {
3238       gfc_error ("Pointer assignment target is not a POINTER at %L",
3239                  &lvalue->where);
3240       return FAILURE;
3241     }
3242
3243   if (lvalue->symtree->n.sym->attr.flavor == FL_PROCEDURE
3244       && lvalue->symtree->n.sym->attr.use_assoc
3245       && !lvalue->symtree->n.sym->attr.proc_pointer)
3246     {
3247       gfc_error ("'%s' in the pointer assignment at %L cannot be an "
3248                  "l-value since it is a procedure",
3249                  lvalue->symtree->n.sym->name, &lvalue->where);
3250       return FAILURE;
3251     }
3252
3253   proc_pointer = lvalue->symtree->n.sym->attr.proc_pointer;
3254
3255   rank_remap = false;
3256   for (ref = lvalue->ref; ref; ref = ref->next)
3257     {
3258       if (ref->type == REF_COMPONENT)
3259         proc_pointer = ref->u.c.component->attr.proc_pointer;
3260
3261       if (ref->type == REF_ARRAY && ref->next == NULL)
3262         {
3263           int dim;
3264
3265           if (ref->u.ar.type == AR_FULL)
3266             break;
3267
3268           if (ref->u.ar.type != AR_SECTION)
3269             {
3270               gfc_error ("Expected bounds specification for '%s' at %L",
3271                          lvalue->symtree->n.sym->name, &lvalue->where);
3272               return FAILURE;
3273             }
3274
3275           if (gfc_notify_std (GFC_STD_F2003,"Fortran 2003: Bounds "
3276                               "specification for '%s' in pointer assignment "
3277                               "at %L", lvalue->symtree->n.sym->name,
3278                               &lvalue->where) == FAILURE)
3279             return FAILURE;
3280
3281           /* When bounds are given, all lbounds are necessary and either all
3282              or none of the upper bounds; no strides are allowed.  If the
3283              upper bounds are present, we may do rank remapping.  */
3284           for (dim = 0; dim < ref->u.ar.dimen; ++dim)
3285             {
3286               if (!ref->u.ar.start[dim])
3287                 {
3288                   gfc_error ("Lower bound has to be present at %L",
3289                              &lvalue->where);
3290                   return FAILURE;
3291                 }
3292               if (ref->u.ar.stride[dim])
3293                 {
3294                   gfc_error ("Stride must not be present at %L",
3295                              &lvalue->where);
3296                   return FAILURE;
3297                 }
3298
3299               if (dim == 0)
3300                 rank_remap = (ref->u.ar.end[dim] != NULL);
3301               else
3302                 {
3303                   if ((rank_remap && !ref->u.ar.end[dim])
3304                       || (!rank_remap && ref->u.ar.end[dim]))
3305                     {
3306                       gfc_error ("Either all or none of the upper bounds"
3307                                  " must be specified at %L", &lvalue->where);
3308                       return FAILURE;
3309                     }
3310                 }
3311             }
3312         }
3313     }
3314
3315   is_pure = gfc_pure (NULL);
3316
3317   /* If rvalue is a NULL() or NULLIFY, we're done. Otherwise the type,
3318      kind, etc for lvalue and rvalue must match, and rvalue must be a
3319      pure variable if we're in a pure function.  */
3320   if (rvalue->expr_type == EXPR_NULL && rvalue->ts.type == BT_UNKNOWN)
3321     return SUCCESS;
3322
3323   /* F2008, C723 (pointer) and C726 (proc-pointer); for PURE also C1283.  */
3324   if (lvalue->expr_type == EXPR_VARIABLE
3325       && gfc_is_coindexed (lvalue))
3326     {
3327       gfc_ref *ref;
3328       for (ref = lvalue->ref; ref; ref = ref->next)
3329         if (ref->type == REF_ARRAY && ref->u.ar.codimen)
3330           {
3331             gfc_error ("Pointer object at %L shall not have a coindex",
3332                        &lvalue->where);
3333             return FAILURE;
3334           }
3335     }
3336
3337   /* Checks on rvalue for procedure pointer assignments.  */
3338   if (proc_pointer)
3339     {
3340       char err[200];
3341       gfc_symbol *s1,*s2;
3342       gfc_component *comp;
3343       const char *name;
3344
3345       attr = gfc_expr_attr (rvalue);
3346       if (!((rvalue->expr_type == EXPR_NULL)
3347             || (rvalue->expr_type == EXPR_FUNCTION && attr.proc_pointer)
3348             || (rvalue->expr_type == EXPR_VARIABLE && attr.proc_pointer)
3349             || (rvalue->expr_type == EXPR_VARIABLE
3350                 && attr.flavor == FL_PROCEDURE)))
3351         {
3352           gfc_error ("Invalid procedure pointer assignment at %L",
3353                      &rvalue->where);
3354           return FAILURE;
3355         }
3356       if (attr.abstract)
3357         {
3358           gfc_error ("Abstract interface '%s' is invalid "
3359                      "in procedure pointer assignment at %L",
3360                      rvalue->symtree->name, &rvalue->where);
3361           return FAILURE;
3362         }
3363       /* Check for C727.  */
3364       if (attr.flavor == FL_PROCEDURE)
3365         {
3366           if (attr.proc == PROC_ST_FUNCTION)
3367             {
3368               gfc_error ("Statement function '%s' is invalid "
3369                          "in procedure pointer assignment at %L",
3370                          rvalue->symtree->name, &rvalue->where);
3371               return FAILURE;
3372             }
3373           if (attr.proc == PROC_INTERNAL &&
3374               gfc_notify_std (GFC_STD_F2008, "Internal procedure '%s' is "
3375                               "invalid in procedure pointer assignment at %L",
3376                               rvalue->symtree->name, &rvalue->where) == FAILURE)
3377             return FAILURE;
3378         }
3379
3380       /* Ensure that the calling convention is the same. As other attributes
3381          such as DLLEXPORT may differ, one explicitly only tests for the
3382          calling conventions.  */
3383       if (rvalue->expr_type == EXPR_VARIABLE
3384           && lvalue->symtree->n.sym->attr.ext_attr
3385                != rvalue->symtree->n.sym->attr.ext_attr)
3386         {
3387           symbol_attribute calls;
3388
3389           calls.ext_attr = 0;
3390           gfc_add_ext_attribute (&calls, EXT_ATTR_CDECL, NULL);
3391           gfc_add_ext_attribute (&calls, EXT_ATTR_STDCALL, NULL);
3392           gfc_add_ext_attribute (&calls, EXT_ATTR_FASTCALL, NULL);
3393
3394           if ((calls.ext_attr & lvalue->symtree->n.sym->attr.ext_attr)
3395               != (calls.ext_attr & rvalue->symtree->n.sym->attr.ext_attr))
3396             {
3397               gfc_error ("Mismatch in the procedure pointer assignment "
3398                          "at %L: mismatch in the calling convention",
3399                          &rvalue->where);
3400           return FAILURE;
3401             }
3402         }
3403
3404       if (gfc_is_proc_ptr_comp (lvalue, &comp))
3405         s1 = comp->ts.interface;
3406       else
3407         s1 = lvalue->symtree->n.sym;
3408
3409       if (gfc_is_proc_ptr_comp (rvalue, &comp))
3410         {
3411           s2 = comp->ts.interface;
3412           name = comp->name;
3413         }
3414       else if (rvalue->expr_type == EXPR_FUNCTION)
3415         {
3416           s2 = rvalue->symtree->n.sym->result;
3417           name = rvalue->symtree->n.sym->result->name;
3418         }
3419       else
3420         {
3421           s2 = rvalue->symtree->n.sym;
3422           name = rvalue->symtree->n.sym->name;
3423         }
3424
3425       if (s1 && s2 && !gfc_compare_interfaces (s1, s2, name, 0, 1,
3426                                                err, sizeof(err)))
3427         {
3428           gfc_error ("Interface mismatch in procedure pointer assignment "
3429                      "at %L: %s", &rvalue->where, err);
3430           return FAILURE;
3431         }
3432
3433       return SUCCESS;
3434     }
3435
3436   if (!gfc_compare_types (&lvalue->ts, &rvalue->ts))
3437     {
3438       gfc_error ("Different types in pointer assignment at %L; attempted "
3439                  "assignment of %s to %s", &lvalue->where, 
3440                  gfc_typename (&rvalue->ts), gfc_typename (&lvalue->ts));
3441       return FAILURE;
3442     }
3443
3444   if (lvalue->ts.type != BT_CLASS && lvalue->ts.kind != rvalue->ts.kind)
3445     {
3446       gfc_error ("Different kind type parameters in pointer "
3447                  "assignment at %L", &lvalue->where);
3448       return FAILURE;
3449     }
3450
3451   if (lvalue->rank != rvalue->rank && !rank_remap)
3452     {
3453       gfc_error ("Different ranks in pointer assignment at %L", &lvalue->where);
3454       return FAILURE;
3455     }
3456
3457   /* Check rank remapping.  */
3458   if (rank_remap)
3459     {
3460       mpz_t lsize, rsize;
3461
3462       /* If this can be determined, check that the target must be at least as
3463          large as the pointer assigned to it is.  */
3464       if (gfc_array_size (lvalue, &lsize) == SUCCESS
3465           && gfc_array_size (rvalue, &rsize) == SUCCESS
3466           && mpz_cmp (rsize, lsize) < 0)
3467         {
3468           gfc_error ("Rank remapping target is smaller than size of the"
3469                      " pointer (%ld < %ld) at %L",
3470                      mpz_get_si (rsize), mpz_get_si (lsize),
3471                      &lvalue->where);
3472           return FAILURE;
3473         }
3474
3475       /* The target must be either rank one or it must be simply contiguous
3476          and F2008 must be allowed.  */
3477       if (rvalue->rank != 1)
3478         {
3479           if (!gfc_is_simply_contiguous (rvalue, true))
3480             {
3481               gfc_error ("Rank remapping target must be rank 1 or"
3482                          " simply contiguous at %L", &rvalue->where);
3483               return FAILURE;
3484             }
3485           if (gfc_notify_std (GFC_STD_F2008, "Fortran 2008: Rank remapping"
3486                               " target is not rank 1 at %L", &rvalue->where)
3487                 == FAILURE)
3488             return FAILURE;
3489         }
3490     }
3491
3492   /* Now punt if we are dealing with a NULLIFY(X) or X = NULL(X).  */
3493   if (rvalue->expr_type == EXPR_NULL)
3494     return SUCCESS;
3495
3496   if (lvalue->ts.type == BT_CHARACTER)
3497     {
3498       gfc_try t = gfc_check_same_strlen (lvalue, rvalue, "pointer assignment");
3499       if (t == FAILURE)
3500         return FAILURE;
3501     }
3502
3503   if (rvalue->expr_type == EXPR_VARIABLE && is_subref_array (rvalue))
3504     lvalue->symtree->n.sym->attr.subref_array_pointer = 1;
3505
3506   attr = gfc_expr_attr (rvalue);
3507   if (!attr.target && !attr.pointer)
3508     {
3509       gfc_error ("Pointer assignment target is neither TARGET "
3510                  "nor POINTER at %L", &rvalue->where);
3511       return FAILURE;
3512     }
3513
3514   if (is_pure && gfc_impure_variable (rvalue->symtree->n.sym))
3515     {
3516       gfc_error ("Bad target in pointer assignment in PURE "
3517                  "procedure at %L", &rvalue->where);
3518     }
3519
3520   if (gfc_has_vector_index (rvalue))
3521     {
3522       gfc_error ("Pointer assignment with vector subscript "
3523                  "on rhs at %L", &rvalue->where);
3524       return FAILURE;
3525     }
3526
3527   if (attr.is_protected && attr.use_assoc
3528       && !(attr.pointer || attr.proc_pointer))
3529     {
3530       gfc_error ("Pointer assignment target has PROTECTED "
3531                  "attribute at %L", &rvalue->where);
3532       return FAILURE;
3533     }
3534
3535   /* F2008, C725. For PURE also C1283.  */
3536   if (rvalue->expr_type == EXPR_VARIABLE
3537       && gfc_is_coindexed (rvalue))
3538     {
3539       gfc_ref *ref;
3540       for (ref = rvalue->ref; ref; ref = ref->next)
3541         if (ref->type == REF_ARRAY && ref->u.ar.codimen)
3542           {
3543             gfc_error ("Data target at %L shall not have a coindex",
3544                        &rvalue->where);
3545             return FAILURE;
3546           }
3547     }
3548
3549   return SUCCESS;
3550 }
3551
3552
3553 /* Relative of gfc_check_assign() except that the lvalue is a single
3554    symbol.  Used for initialization assignments.  */
3555
3556 gfc_try
3557 gfc_check_assign_symbol (gfc_symbol *sym, gfc_expr *rvalue)
3558 {
3559   gfc_expr lvalue;
3560   gfc_try r;
3561
3562   memset (&lvalue, '\0', sizeof (gfc_expr));
3563
3564   lvalue.expr_type = EXPR_VARIABLE;
3565   lvalue.ts = sym->ts;
3566   if (sym->as)
3567     lvalue.rank = sym->as->rank;
3568   lvalue.symtree = (gfc_symtree *) gfc_getmem (sizeof (gfc_symtree));
3569   lvalue.symtree->n.sym = sym;
3570   lvalue.where = sym->declared_at;
3571
3572   if (sym->attr.pointer || sym->attr.proc_pointer
3573       || (sym->ts.type == BT_CLASS && CLASS_DATA (sym)->attr.class_pointer
3574           && rvalue->expr_type == EXPR_NULL))
3575     r = gfc_check_pointer_assign (&lvalue, rvalue);
3576   else
3577     r = gfc_check_assign (&lvalue, rvalue, 1);
3578
3579   gfc_free (lvalue.symtree);
3580
3581   if (r == FAILURE)
3582     return r;
3583   
3584   if (sym->attr.pointer && rvalue->expr_type != EXPR_NULL)
3585     {
3586       /* F08:C461. Additional checks for pointer initialization.  */
3587       symbol_attribute attr;
3588       attr = gfc_expr_attr (rvalue);
3589       if (attr.allocatable)
3590         {
3591           gfc_error ("Pointer initialization target at %C "
3592                      "must not be ALLOCATABLE ");
3593           return FAILURE;
3594         }
3595       if (!attr.target)
3596         {
3597           gfc_error ("Pointer initialization target at %C "
3598                      "must have the TARGET attribute");
3599           return FAILURE;
3600         }
3601       if (!attr.save)
3602         {
3603           gfc_error ("Pointer initialization target at %C "
3604                      "must have the SAVE attribute");
3605           return FAILURE;
3606         }
3607     }
3608
3609   return SUCCESS;
3610 }
3611
3612
3613 /* Check for default initializer; sym->value is not enough
3614    as it is also set for EXPR_NULL of allocatables.  */
3615
3616 bool
3617 gfc_has_default_initializer (gfc_symbol *der)
3618 {
3619   gfc_component *c;
3620
3621   gcc_assert (der->attr.flavor == FL_DERIVED);
3622   for (c = der->components; c; c = c->next)
3623     if (c->ts.type == BT_DERIVED)
3624       {
3625         if (!c->attr.pointer
3626              && gfc_has_default_initializer (c->ts.u.derived))
3627           return true;
3628       }
3629     else
3630       {
3631         if (c->initializer)
3632           return true;
3633       }
3634
3635   return false;
3636 }
3637
3638 /* Get an expression for a default initializer.  */
3639
3640 gfc_expr *
3641 gfc_default_initializer (gfc_typespec *ts)
3642 {
3643   gfc_expr *init;
3644   gfc_component *comp;
3645
3646   /* See if we have a default initializer in this, but not in nested
3647      types (otherwise we could use gfc_has_default_initializer()).  */
3648   for (comp = ts->u.derived->components; comp; comp = comp->next)
3649     if (comp->initializer || comp->attr.allocatable)
3650       break;
3651
3652   if (!comp)
3653     return NULL;
3654
3655   init = gfc_get_structure_constructor_expr (ts->type, ts->kind,
3656                                              &ts->u.derived->declared_at);
3657   init->ts = *ts;
3658
3659   for (comp = ts->u.derived->components; comp; comp = comp->next)
3660     {
3661       gfc_constructor *ctor = gfc_constructor_get();
3662
3663       if (comp->initializer)
3664         ctor->expr = gfc_copy_expr (comp->initializer);
3665
3666       if (comp->attr.allocatable)
3667         {
3668           ctor->expr = gfc_get_expr ();
3669           ctor->expr->expr_type = EXPR_NULL;
3670           ctor->expr->ts = comp->ts;
3671         }
3672
3673       gfc_constructor_append (&init->value.constructor, ctor);
3674     }
3675
3676   return init;
3677 }
3678
3679
3680 /* Given a symbol, create an expression node with that symbol as a
3681    variable. If the symbol is array valued, setup a reference of the
3682    whole array.  */
3683
3684 gfc_expr *
3685 gfc_get_variable_expr (gfc_symtree *var)
3686 {
3687   gfc_expr *e;
3688
3689   e = gfc_get_expr ();
3690   e->expr_type = EXPR_VARIABLE;
3691   e->symtree = var;
3692   e->ts = var->n.sym->ts;
3693
3694   if (var->n.sym->as != NULL)
3695     {
3696       e->rank = var->n.sym->as->rank;
3697       e->ref = gfc_get_ref ();
3698       e->ref->type = REF_ARRAY;
3699       e->ref->u.ar.type = AR_FULL;
3700     }
3701
3702   return e;
3703 }
3704
3705
3706 /* Returns the array_spec of a full array expression.  A NULL is
3707    returned otherwise.  */
3708 gfc_array_spec *
3709 gfc_get_full_arrayspec_from_expr (gfc_expr *expr)
3710 {
3711   gfc_array_spec *as;
3712   gfc_ref *ref;
3713
3714   if (expr->rank == 0)
3715     return NULL;
3716
3717   /* Follow any component references.  */
3718   if (expr->expr_type == EXPR_VARIABLE
3719       || expr->expr_type == EXPR_CONSTANT)
3720     {
3721       as = expr->symtree->n.sym->as;
3722       for (ref = expr->ref; ref; ref = ref->next)
3723         {
3724           switch (ref->type)
3725             {
3726             case REF_COMPONENT:
3727               as = ref->u.c.component->as;
3728               continue;
3729
3730             case REF_SUBSTRING:
3731               continue;
3732
3733             case REF_ARRAY:
3734               {
3735                 switch (ref->u.ar.type)
3736                   {
3737                   case AR_ELEMENT:
3738                   case AR_SECTION:
3739                   case AR_UNKNOWN:
3740                     as = NULL;
3741                     continue;
3742
3743                   case AR_FULL:
3744                     break;
3745                   }
3746                 break;
3747               }
3748             }
3749         }
3750     }
3751   else
3752     as = NULL;
3753
3754   return as;
3755 }
3756
3757
3758 /* General expression traversal function.  */
3759
3760 bool
3761 gfc_traverse_expr (gfc_expr *expr, gfc_symbol *sym,
3762                    bool (*func)(gfc_expr *, gfc_symbol *, int*),
3763                    int f)
3764 {
3765   gfc_array_ref ar;
3766   gfc_ref *ref;
3767   gfc_actual_arglist *args;
3768   gfc_constructor *c;
3769   int i;
3770
3771   if (!expr)
3772     return false;
3773
3774   if ((*func) (expr, sym, &f))
3775     return true;
3776
3777   if (expr->ts.type == BT_CHARACTER
3778         && expr->ts.u.cl
3779         && expr->ts.u.cl->length
3780         && expr->ts.u.cl->length->expr_type != EXPR_CONSTANT
3781         && gfc_traverse_expr (expr->ts.u.cl->length, sym, func, f))
3782     return true;
3783
3784   switch (expr->expr_type)
3785     {
3786     case EXPR_PPC:
3787     case EXPR_COMPCALL:
3788     case EXPR_FUNCTION:
3789       for (args = expr->value.function.actual; args; args = args->next)
3790         {
3791           if (gfc_traverse_expr (args->expr, sym, func, f))
3792             return true;
3793         }
3794       break;
3795
3796     case EXPR_VARIABLE:
3797     case EXPR_CONSTANT:
3798     case EXPR_NULL:
3799     case EXPR_SUBSTRING:
3800       break;
3801
3802     case EXPR_STRUCTURE:
3803     case EXPR_ARRAY:
3804       for (c = gfc_constructor_first (expr->value.constructor);
3805            c; c = gfc_constructor_next (c))
3806         {
3807           if (gfc_traverse_expr (c->expr, sym, func, f))
3808             return true;
3809           if (c->iterator)
3810             {
3811               if (gfc_traverse_expr (c->iterator->var, sym, func, f))
3812                 return true;
3813               if (gfc_traverse_expr (c->iterator->start, sym, func, f))
3814                 return true;
3815               if (gfc_traverse_expr (c->iterator->end, sym, func, f))
3816                 return true;
3817               if (gfc_traverse_expr (c->iterator->step, sym, func, f))
3818                 return true;
3819             }
3820         }
3821       break;
3822
3823     case EXPR_OP:
3824       if (gfc_traverse_expr (expr->value.op.op1, sym, func, f))
3825         return true;
3826       if (gfc_traverse_expr (expr->value.op.op2, sym, func, f))
3827         return true;
3828       break;
3829
3830     default:
3831       gcc_unreachable ();
3832       break;
3833     }
3834
3835   ref = expr->ref;
3836   while (ref != NULL)
3837     {
3838       switch (ref->type)
3839         {
3840         case  REF_ARRAY:
3841           ar = ref->u.ar;
3842           for (i = 0; i < GFC_MAX_DIMENSIONS; i++)
3843             {
3844               if (gfc_traverse_expr (ar.start[i], sym, func, f))
3845                 return true;
3846               if (gfc_traverse_expr (ar.end[i], sym, func, f))
3847                 return true;
3848               if (gfc_traverse_expr (ar.stride[i], sym, func, f))
3849                 return true;
3850             }
3851           break;
3852
3853         case REF_SUBSTRING:
3854           if (gfc_traverse_expr (ref->u.ss.start, sym, func, f))
3855             return true;
3856           if (gfc_traverse_expr (ref->u.ss.end, sym, func, f))
3857             return true;
3858           break;
3859
3860         case REF_COMPONENT:
3861           if (ref->u.c.component->ts.type == BT_CHARACTER
3862                 && ref->u.c.component->ts.u.cl
3863                 && ref->u.c.component->ts.u.cl->length
3864                 && ref->u.c.component->ts.u.cl->length->expr_type
3865                      != EXPR_CONSTANT
3866                 && gfc_traverse_expr (ref->u.c.component->ts.u.cl->length,
3867                                       sym, func, f))
3868             return true;
3869
3870           if (ref->u.c.component->as)
3871             for (i = 0; i < ref->u.c.component->as->rank
3872                             + ref->u.c.component->as->corank; i++)
3873               {
3874                 if (gfc_traverse_expr (ref->u.c.component->as->lower[i],
3875                                        sym, func, f))
3876                   return true;
3877                 if (gfc_traverse_expr (ref->u.c.component->as->upper[i],
3878                                        sym, func, f))
3879                   return true;
3880               }
3881           break;
3882
3883         default:
3884           gcc_unreachable ();
3885         }
3886       ref = ref->next;
3887     }
3888   return false;
3889 }
3890
3891 /* Traverse expr, marking all EXPR_VARIABLE symbols referenced.  */
3892
3893 static bool
3894 expr_set_symbols_referenced (gfc_expr *expr,
3895                              gfc_symbol *sym ATTRIBUTE_UNUSED,
3896                              int *f ATTRIBUTE_UNUSED)
3897 {
3898   if (expr->expr_type != EXPR_VARIABLE)
3899     return false;
3900   gfc_set_sym_referenced (expr->symtree->n.sym);
3901   return false;
3902 }
3903
3904 void
3905 gfc_expr_set_symbols_referenced (gfc_expr *expr)
3906 {
3907   gfc_traverse_expr (expr, NULL, expr_set_symbols_referenced, 0);
3908 }
3909
3910
3911 /* Determine if an expression is a procedure pointer component. If yes, the
3912    argument 'comp' will point to the component (provided that 'comp' was
3913    provided).  */
3914
3915 bool
3916 gfc_is_proc_ptr_comp (gfc_expr *expr, gfc_component **comp)
3917 {
3918   gfc_ref *ref;
3919   bool ppc = false;
3920
3921   if (!expr || !expr->ref)
3922     return false;
3923
3924   ref = expr->ref;
3925   while (ref->next)
3926     ref = ref->next;
3927
3928   if (ref->type == REF_COMPONENT)
3929     {
3930       ppc = ref->u.c.component->attr.proc_pointer;
3931       if (ppc && comp)
3932         *comp = ref->u.c.component;
3933     }
3934
3935   return ppc;
3936 }
3937
3938
3939 /* Walk an expression tree and check each variable encountered for being typed.
3940    If strict is not set, a top-level variable is tolerated untyped in -std=gnu
3941    mode as is a basic arithmetic expression using those; this is for things in
3942    legacy-code like:
3943
3944      INTEGER :: arr(n), n
3945      INTEGER :: arr(n + 1), n
3946
3947    The namespace is needed for IMPLICIT typing.  */
3948
3949 static gfc_namespace* check_typed_ns;
3950
3951 static bool
3952 expr_check_typed_help (gfc_expr* e, gfc_symbol* sym ATTRIBUTE_UNUSED,
3953                        int* f ATTRIBUTE_UNUSED)
3954 {
3955   gfc_try t;
3956
3957   if (e->expr_type != EXPR_VARIABLE)
3958     return false;
3959
3960   gcc_assert (e->symtree);
3961   t = gfc_check_symbol_typed (e->symtree->n.sym, check_typed_ns,
3962                               true, e->where);
3963
3964   return (t == FAILURE);
3965 }
3966
3967 gfc_try
3968 gfc_expr_check_typed (gfc_expr* e, gfc_namespace* ns, bool strict)
3969 {
3970   bool error_found;
3971
3972   /* If this is a top-level variable or EXPR_OP, do the check with strict given
3973      to us.  */
3974   if (!strict)
3975     {
3976       if (e->expr_type == EXPR_VARIABLE && !e->ref)
3977         return gfc_check_symbol_typed (e->symtree->n.sym, ns, strict, e->where);
3978
3979       if (e->expr_type == EXPR_OP)
3980         {
3981           gfc_try t = SUCCESS;
3982
3983           gcc_assert (e->value.op.op1);
3984           t = gfc_expr_check_typed (e->value.op.op1, ns, strict);
3985
3986           if (t == SUCCESS && e->value.op.op2)
3987             t = gfc_expr_check_typed (e->value.op.op2, ns, strict);
3988
3989           return t;
3990         }
3991     }
3992
3993   /* Otherwise, walk the expression and do it strictly.  */
3994   check_typed_ns = ns;
3995   error_found = gfc_traverse_expr (e, NULL, &expr_check_typed_help, 0);
3996
3997   return error_found ? FAILURE : SUCCESS;
3998 }
3999
4000 /* Walk an expression tree and replace all symbols with a corresponding symbol
4001    in the formal_ns of "sym". Needed for copying interfaces in PROCEDURE
4002    statements. The boolean return value is required by gfc_traverse_expr.  */
4003
4004 static bool
4005 replace_symbol (gfc_expr *expr, gfc_symbol *sym, int *i ATTRIBUTE_UNUSED)
4006 {
4007   if ((expr->expr_type == EXPR_VARIABLE 
4008        || (expr->expr_type == EXPR_FUNCTION
4009            && !gfc_is_intrinsic (expr->symtree->n.sym, 0, expr->where)))
4010       && expr->symtree->n.sym->ns == sym->ts.interface->formal_ns)
4011     {
4012       gfc_symtree *stree;
4013       gfc_namespace *ns = sym->formal_ns;
4014       /* Don't use gfc_get_symtree as we prefer to fail badly if we don't find
4015          the symtree rather than create a new one (and probably fail later).  */
4016       stree = gfc_find_symtree (ns ? ns->sym_root : gfc_current_ns->sym_root,
4017                                 expr->symtree->n.sym->name);
4018       gcc_assert (stree);
4019       stree->n.sym->attr = expr->symtree->n.sym->attr;
4020       expr->symtree = stree;
4021     }
4022   return false;
4023 }
4024
4025 void
4026 gfc_expr_replace_symbols (gfc_expr *expr, gfc_symbol *dest)
4027 {
4028   gfc_traverse_expr (expr, dest, &replace_symbol, 0);
4029 }
4030
4031 /* The following is analogous to 'replace_symbol', and needed for copying
4032    interfaces for procedure pointer components. The argument 'sym' must formally
4033    be a gfc_symbol, so that the function can be passed to gfc_traverse_expr.
4034    However, it gets actually passed a gfc_component (i.e. the procedure pointer
4035    component in whose formal_ns the arguments have to be).  */
4036
4037 static bool
4038 replace_comp (gfc_expr *expr, gfc_symbol *sym, int *i ATTRIBUTE_UNUSED)
4039 {
4040   gfc_component *comp;
4041   comp = (gfc_component *)sym;
4042   if ((expr->expr_type == EXPR_VARIABLE 
4043        || (expr->expr_type == EXPR_FUNCTION
4044            && !gfc_is_intrinsic (expr->symtree->n.sym, 0, expr->where)))
4045       && expr->symtree->n.sym->ns == comp->ts.interface->formal_ns)
4046     {
4047       gfc_symtree *stree;
4048       gfc_namespace *ns = comp->formal_ns;
4049       /* Don't use gfc_get_symtree as we prefer to fail badly if we don't find
4050          the symtree rather than create a new one (and probably fail later).  */
4051       stree = gfc_find_symtree (ns ? ns->sym_root : gfc_current_ns->sym_root,
4052                                 expr->symtree->n.sym->name);
4053       gcc_assert (stree);
4054       stree->n.sym->attr = expr->symtree->n.sym->attr;
4055       expr->symtree = stree;
4056     }
4057   return false;
4058 }
4059
4060 void
4061 gfc_expr_replace_comp (gfc_expr *expr, gfc_component *dest)
4062 {
4063   gfc_traverse_expr (expr, (gfc_symbol *)dest, &replace_comp, 0);
4064 }
4065
4066
4067 bool
4068 gfc_is_coindexed (gfc_expr *e)
4069 {
4070   gfc_ref *ref;
4071
4072   for (ref = e->ref; ref; ref = ref->next)
4073     if (ref->type == REF_ARRAY && ref->u.ar.codimen > 0)
4074       return true;
4075
4076   return false;
4077 }
4078
4079
4080 bool
4081 gfc_get_corank (gfc_expr *e)
4082 {
4083   int corank;
4084   gfc_ref *ref;
4085   corank = e->symtree->n.sym->as ? e->symtree->n.sym->as->corank : 0;
4086   for (ref = e->ref; ref; ref = ref->next)
4087     {
4088       if (ref->type == REF_ARRAY)
4089         corank = ref->u.ar.as->corank;
4090       gcc_assert (ref->type != REF_SUBSTRING);
4091     }
4092   return corank;
4093 }
4094
4095
4096 /* Check whether the expression has an ultimate allocatable component.
4097    Being itself allocatable does not count.  */
4098 bool
4099 gfc_has_ultimate_allocatable (gfc_expr *e)
4100 {
4101   gfc_ref *ref, *last = NULL;
4102
4103   if (e->expr_type != EXPR_VARIABLE)
4104     return false;
4105
4106   for (ref = e->ref; ref; ref = ref->next)
4107     if (ref->type == REF_COMPONENT)
4108       last = ref;
4109
4110   if (last && last->u.c.component->ts.type == BT_CLASS)
4111     return CLASS_DATA (last->u.c.component)->attr.alloc_comp;
4112   else if (last && last->u.c.component->ts.type == BT_DERIVED)
4113     return last->u.c.component->ts.u.derived->attr.alloc_comp;
4114   else if (last)
4115     return false;
4116
4117   if (e->ts.type == BT_CLASS)
4118     return CLASS_DATA (e)->attr.alloc_comp;
4119   else if (e->ts.type == BT_DERIVED)
4120     return e->ts.u.derived->attr.alloc_comp;
4121   else
4122     return false;
4123 }
4124
4125
4126 /* Check whether the expression has an pointer component.
4127    Being itself a pointer does not count.  */
4128 bool
4129 gfc_has_ultimate_pointer (gfc_expr *e)
4130 {
4131   gfc_ref *ref, *last = NULL;
4132
4133   if (e->expr_type != EXPR_VARIABLE)
4134     return false;
4135
4136   for (ref = e->ref; ref; ref = ref->next)
4137     if (ref->type == REF_COMPONENT)
4138       last = ref;
4139  
4140   if (last && last->u.c.component->ts.type == BT_CLASS)
4141     return CLASS_DATA (last->u.c.component)->attr.pointer_comp;
4142   else if (last && last->u.c.component->ts.type == BT_DERIVED)
4143     return last->u.c.component->ts.u.derived->attr.pointer_comp;
4144   else if (last)
4145     return false;
4146
4147   if (e->ts.type == BT_CLASS)
4148     return CLASS_DATA (e)->attr.pointer_comp;
4149   else if (e->ts.type == BT_DERIVED)
4150     return e->ts.u.derived->attr.pointer_comp;
4151   else
4152     return false;
4153 }
4154
4155
4156 /* Check whether an expression is "simply contiguous", cf. F2008, 6.5.4.
4157    Note: A scalar is not regarded as "simply contiguous" by the standard.
4158    if bool is not strict, some futher checks are done - for instance,
4159    a "(::1)" is accepted.  */
4160
4161 bool
4162 gfc_is_simply_contiguous (gfc_expr *expr, bool strict)
4163 {
4164   bool colon;
4165   int i;
4166   gfc_array_ref *ar = NULL;
4167   gfc_ref *ref, *part_ref = NULL;
4168
4169   if (expr->expr_type == EXPR_FUNCTION)
4170     return expr->value.function.esym
4171            ? expr->value.function.esym->result->attr.contiguous : false;
4172   else if (expr->expr_type != EXPR_VARIABLE)
4173     return false;
4174
4175   if (expr->rank == 0)
4176     return false;
4177
4178   for (ref = expr->ref; ref; ref = ref->next)
4179     {
4180       if (ar)
4181         return false; /* Array shall be last part-ref. */
4182
4183       if (ref->type == REF_COMPONENT)
4184         part_ref  = ref;
4185       else if (ref->type == REF_SUBSTRING)
4186         return false;
4187       else if (ref->u.ar.type != AR_ELEMENT)
4188         ar = &ref->u.ar;
4189     }
4190
4191   if ((part_ref && !part_ref->u.c.component->attr.contiguous
4192        && part_ref->u.c.component->attr.pointer)
4193       || (!part_ref && !expr->symtree->n.sym->attr.contiguous
4194           && (expr->symtree->n.sym->attr.pointer
4195               || expr->symtree->n.sym->as->type == AS_ASSUMED_SHAPE)))
4196     return false;
4197
4198   if (!ar || ar->type == AR_FULL)
4199     return true;
4200
4201   gcc_assert (ar->type == AR_SECTION);
4202
4203   /* Check for simply contiguous array */
4204   colon = true;
4205   for (i = 0; i < ar->dimen; i++)
4206     {
4207       if (ar->dimen_type[i] == DIMEN_VECTOR)
4208         return false;
4209
4210       if (ar->dimen_type[i] == DIMEN_ELEMENT)
4211         {
4212           colon = false;
4213           continue;
4214         }
4215
4216       gcc_assert (ar->dimen_type[i] == DIMEN_RANGE);
4217
4218
4219       /* If the previous section was not contiguous, that's an error,
4220          unless we have effective only one element and checking is not
4221          strict.  */
4222       if (!colon && (strict || !ar->start[i] || !ar->end[i]
4223                      || ar->start[i]->expr_type != EXPR_CONSTANT
4224                      || ar->end[i]->expr_type != EXPR_CONSTANT
4225                      || mpz_cmp (ar->start[i]->value.integer,
4226                                  ar->end[i]->value.integer) != 0))
4227         return false;
4228
4229       /* Following the standard, "(::1)" or - if known at compile time -
4230          "(lbound:ubound)" are not simply contigous; if strict
4231          is false, they are regarded as simply contiguous.  */
4232       if (ar->stride[i] && (strict || ar->stride[i]->expr_type != EXPR_CONSTANT
4233                             || ar->stride[i]->ts.type != BT_INTEGER
4234                             || mpz_cmp_si (ar->stride[i]->value.integer, 1) != 0))
4235         return false;
4236
4237       if (ar->start[i]
4238           && (strict || ar->start[i]->expr_type != EXPR_CONSTANT
4239               || !ar->as->lower[i]
4240               || ar->as->lower[i]->expr_type != EXPR_CONSTANT
4241               || mpz_cmp (ar->start[i]->value.integer,
4242                           ar->as->lower[i]->value.integer) != 0))
4243         colon = false;
4244
4245       if (ar->end[i]
4246           && (strict || ar->end[i]->expr_type != EXPR_CONSTANT
4247               || !ar->as->upper[i]
4248               || ar->as->upper[i]->expr_type != EXPR_CONSTANT
4249               || mpz_cmp (ar->end[i]->value.integer,
4250                           ar->as->upper[i]->value.integer) != 0))
4251         colon = false;
4252     }
4253   
4254   return true;
4255 }
4256
4257
4258 /* Build call to an intrinsic procedure.  The number of arguments has to be
4259    passed (rather than ending the list with a NULL value) because we may
4260    want to add arguments but with a NULL-expression.  */
4261
4262 gfc_expr*
4263 gfc_build_intrinsic_call (const char* name, locus where, unsigned numarg, ...)
4264 {
4265   gfc_expr* result;
4266   gfc_actual_arglist* atail;
4267   gfc_intrinsic_sym* isym;
4268   va_list ap;
4269   unsigned i;
4270
4271   isym = gfc_find_function (name);
4272   gcc_assert (isym);
4273   
4274   result = gfc_get_expr ();
4275   result->expr_type = EXPR_FUNCTION;
4276   result->ts = isym->ts;
4277   result->where = where;
4278   result->value.function.name = name;
4279   result->value.function.isym = isym;
4280
4281   va_start (ap, numarg);
4282   atail = NULL;