OSDN Git Service

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