OSDN Git Service

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