OSDN Git Service

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