OSDN Git Service

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