OSDN Git Service

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