OSDN Git Service

257349aaf0495f63e6f36f8481511441257d322f
[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             if (gfc_notify_std (GFC_STD_GNU, "assumed character length "
1970                                 "variable '%s' in constant expression at %L",
1971                                 e->symtree->n.sym->name, &e->where) == FAILURE)
1972               return MATCH_ERROR;
1973           }
1974         else if (not_restricted && check_init_expr (ap->expr) == FAILURE)
1975           return MATCH_ERROR;
1976     }
1977
1978   return MATCH_YES;
1979 }
1980
1981
1982 /* F95, 7.1.6.1, Initialization expressions, (5)
1983    F2003, 7.1.7 Initialization expression, (5)  */
1984
1985 static match
1986 check_transformational (gfc_expr *e)
1987 {
1988   static const char * const trans_func_f95[] = {
1989     "repeat", "reshape", "selected_int_kind",
1990     "selected_real_kind", "transfer", "trim", NULL
1991   };
1992
1993   int i;
1994   const char *name;
1995
1996   if (!e->value.function.isym
1997       || !e->value.function.isym->transformational)
1998     return MATCH_NO;
1999
2000   name = e->symtree->n.sym->name;
2001
2002   /* NULL() is dealt with below.  */
2003   if (strcmp ("null", name) == 0)
2004     return MATCH_NO;
2005
2006   for (i = 0; trans_func_f95[i]; i++)
2007     if (strcmp (trans_func_f95[i], name) == 0)
2008       break;
2009
2010   if (trans_func_f95[i] == NULL
2011       && gfc_notify_std (GFC_STD_F2003, 
2012                          "transformational intrinsic '%s' at %L is not permitted "
2013                          "in an initialization expression", name, &e->where) == FAILURE)
2014     return MATCH_ERROR;
2015
2016   return check_init_expr_arguments (e);
2017 }
2018
2019
2020 /* F95, 7.1.6.1, Initialization expressions, (6)
2021    F2003, 7.1.7 Initialization expression, (6)  */
2022
2023 static match
2024 check_null (gfc_expr *e)
2025 {
2026   if (strcmp ("null", e->symtree->n.sym->name) != 0)
2027     return MATCH_NO;
2028
2029   return check_init_expr_arguments (e);
2030 }
2031
2032
2033 static match
2034 check_elemental (gfc_expr *e)
2035 {
2036   if (!e->value.function.isym
2037       || !e->value.function.isym->elemental)
2038     return MATCH_NO;
2039
2040   if ((e->ts.type != BT_INTEGER || e->ts.type != BT_CHARACTER)
2041       && gfc_notify_std (GFC_STD_F2003, "Extension: Evaluation of "
2042                         "nonstandard initialization expression at %L",
2043                         &e->where) == FAILURE)
2044     return MATCH_ERROR;
2045
2046   return check_init_expr_arguments (e);
2047 }
2048
2049
2050 static match
2051 check_conversion (gfc_expr *e)
2052 {
2053   if (!e->value.function.isym
2054       || !e->value.function.isym->conversion)
2055     return MATCH_NO;
2056
2057   return check_init_expr_arguments (e);
2058 }
2059
2060
2061 /* Verify that an expression is an initialization expression.  A side
2062    effect is that the expression tree is reduced to a single constant
2063    node if all goes well.  This would normally happen when the
2064    expression is constructed but function references are assumed to be
2065    intrinsics in the context of initialization expressions.  If
2066    FAILURE is returned an error message has been generated.  */
2067
2068 static try
2069 check_init_expr (gfc_expr *e)
2070 {
2071   match m;
2072   try t;
2073   gfc_intrinsic_sym *isym;
2074
2075   if (e == NULL)
2076     return SUCCESS;
2077
2078   switch (e->expr_type)
2079     {
2080     case EXPR_OP:
2081       t = check_intrinsic_op (e, check_init_expr);
2082       if (t == SUCCESS)
2083         t = gfc_simplify_expr (e, 0);
2084
2085       break;
2086
2087     case EXPR_FUNCTION:
2088       t = FAILURE;
2089
2090       if ((m = check_specification_function (e)) != MATCH_YES)
2091         {
2092           if ((m = gfc_intrinsic_func_interface (e, 0)) != MATCH_YES)
2093             {
2094               gfc_error ("Function '%s' in initialization expression at %L "
2095                          "must be an intrinsic or a specification function",
2096                          e->symtree->n.sym->name, &e->where);
2097               break;
2098             }
2099
2100           if ((m = check_conversion (e)) == MATCH_NO
2101               && (m = check_inquiry (e, 1)) == MATCH_NO
2102               && (m = check_null (e)) == MATCH_NO
2103               && (m = check_transformational (e)) == MATCH_NO
2104               && (m = check_elemental (e)) == MATCH_NO)
2105             {
2106               gfc_error ("Intrinsic function '%s' at %L is not permitted "
2107                          "in an initialization expression",
2108                          e->symtree->n.sym->name, &e->where);
2109               m = MATCH_ERROR;
2110             }
2111
2112           /* Try to scalarize an elemental intrinsic function that has an
2113              array argument.  */
2114           isym = gfc_find_function (e->symtree->n.sym->name);
2115           if (isym && isym->elemental
2116               && e->value.function.actual->expr->expr_type == EXPR_ARRAY)
2117             {
2118                 if ((t = scalarize_intrinsic_call (e)) == SUCCESS)
2119                 break;
2120             }
2121         }
2122
2123       if (m == MATCH_YES)
2124         t = SUCCESS;
2125
2126       break;
2127
2128     case EXPR_VARIABLE:
2129       t = SUCCESS;
2130
2131       if (gfc_check_iter_variable (e) == SUCCESS)
2132         break;
2133
2134       if (e->symtree->n.sym->attr.flavor == FL_PARAMETER)
2135         {
2136           t = simplify_parameter_variable (e, 0);
2137           break;
2138         }
2139
2140       if (gfc_in_match_data ())
2141         break;
2142
2143       t = FAILURE;
2144
2145       if (e->symtree->n.sym->as)
2146         {
2147           switch (e->symtree->n.sym->as->type)
2148             {
2149               case AS_ASSUMED_SIZE:
2150                 gfc_error ("assumed size array '%s' at %L is not permitted "
2151                            "in an initialization expression",
2152                            e->symtree->n.sym->name, &e->where);
2153               break;
2154
2155               case AS_ASSUMED_SHAPE:
2156                 gfc_error ("assumed shape array '%s' at %L is not permitted "
2157                            "in an initialization expression",
2158                            e->symtree->n.sym->name, &e->where);
2159               break;
2160
2161               case AS_DEFERRED:
2162                 gfc_error ("deferred array '%s' at %L is not permitted "
2163                            "in an initialization expression",
2164                            e->symtree->n.sym->name, &e->where);
2165               break;
2166
2167               default:
2168                 gcc_unreachable();
2169           }
2170         }
2171       else
2172         gfc_error ("Parameter '%s' at %L has not been declared or is "
2173                    "a variable, which does not reduce to a constant "
2174                    "expression", e->symtree->n.sym->name, &e->where);
2175
2176       break;
2177
2178     case EXPR_CONSTANT:
2179     case EXPR_NULL:
2180       t = SUCCESS;
2181       break;
2182
2183     case EXPR_SUBSTRING:
2184       t = check_init_expr (e->ref->u.ss.start);
2185       if (t == FAILURE)
2186         break;
2187
2188       t = check_init_expr (e->ref->u.ss.end);
2189       if (t == SUCCESS)
2190         t = gfc_simplify_expr (e, 0);
2191
2192       break;
2193
2194     case EXPR_STRUCTURE:
2195       t = gfc_check_constructor (e, check_init_expr);
2196       break;
2197
2198     case EXPR_ARRAY:
2199       t = gfc_check_constructor (e, check_init_expr);
2200       if (t == FAILURE)
2201         break;
2202
2203       t = gfc_expand_constructor (e);
2204       if (t == FAILURE)
2205         break;
2206
2207       t = gfc_check_constructor_type (e);
2208       break;
2209
2210     default:
2211       gfc_internal_error ("check_init_expr(): Unknown expression type");
2212     }
2213
2214   return t;
2215 }
2216
2217
2218 /* Match an initialization expression.  We work by first matching an
2219    expression, then reducing it to a constant.  */
2220
2221 match
2222 gfc_match_init_expr (gfc_expr **result)
2223 {
2224   gfc_expr *expr;
2225   match m;
2226   try t;
2227
2228   m = gfc_match_expr (&expr);
2229   if (m != MATCH_YES)
2230     return m;
2231
2232   gfc_init_expr = 1;
2233   t = gfc_resolve_expr (expr);
2234   if (t == SUCCESS)
2235     t = check_init_expr (expr);
2236   gfc_init_expr = 0;
2237
2238   if (t == FAILURE)
2239     {
2240       gfc_free_expr (expr);
2241       return MATCH_ERROR;
2242     }
2243
2244   if (expr->expr_type == EXPR_ARRAY
2245       && (gfc_check_constructor_type (expr) == FAILURE
2246           || gfc_expand_constructor (expr) == FAILURE))
2247     {
2248       gfc_free_expr (expr);
2249       return MATCH_ERROR;
2250     }
2251
2252   /* Not all inquiry functions are simplified to constant expressions
2253      so it is necessary to call check_inquiry again.  */ 
2254   if (!gfc_is_constant_expr (expr) && check_inquiry (expr, 1) != MATCH_YES
2255       && !gfc_in_match_data ())
2256     {
2257       gfc_error ("Initialization expression didn't reduce %C");
2258       return MATCH_ERROR;
2259     }
2260
2261   *result = expr;
2262
2263   return MATCH_YES;
2264 }
2265
2266
2267 static try check_restricted (gfc_expr *);
2268
2269 /* Given an actual argument list, test to see that each argument is a
2270    restricted expression and optionally if the expression type is
2271    integer or character.  */
2272
2273 static try
2274 restricted_args (gfc_actual_arglist *a)
2275 {
2276   for (; a; a = a->next)
2277     {
2278       if (check_restricted (a->expr) == FAILURE)
2279         return FAILURE;
2280     }
2281
2282   return SUCCESS;
2283 }
2284
2285
2286 /************* Restricted/specification expressions *************/
2287
2288
2289 /* Make sure a non-intrinsic function is a specification function.  */
2290
2291 static try
2292 external_spec_function (gfc_expr *e)
2293 {
2294   gfc_symbol *f;
2295
2296   f = e->value.function.esym;
2297
2298   if (f->attr.proc == PROC_ST_FUNCTION)
2299     {
2300       gfc_error ("Specification function '%s' at %L cannot be a statement "
2301                  "function", f->name, &e->where);
2302       return FAILURE;
2303     }
2304
2305   if (f->attr.proc == PROC_INTERNAL)
2306     {
2307       gfc_error ("Specification function '%s' at %L cannot be an internal "
2308                  "function", f->name, &e->where);
2309       return FAILURE;
2310     }
2311
2312   if (!f->attr.pure && !f->attr.elemental)
2313     {
2314       gfc_error ("Specification function '%s' at %L must be PURE", f->name,
2315                  &e->where);
2316       return FAILURE;
2317     }
2318
2319   if (f->attr.recursive)
2320     {
2321       gfc_error ("Specification function '%s' at %L cannot be RECURSIVE",
2322                  f->name, &e->where);
2323       return FAILURE;
2324     }
2325
2326   return restricted_args (e->value.function.actual);
2327 }
2328
2329
2330 /* Check to see that a function reference to an intrinsic is a
2331    restricted expression.  */
2332
2333 static try
2334 restricted_intrinsic (gfc_expr *e)
2335 {
2336   /* TODO: Check constraints on inquiry functions.  7.1.6.2 (7).  */
2337   if (check_inquiry (e, 0) == MATCH_YES)
2338     return SUCCESS;
2339
2340   return restricted_args (e->value.function.actual);
2341 }
2342
2343
2344 /* Verify that an expression is a restricted expression.  Like its
2345    cousin check_init_expr(), an error message is generated if we
2346    return FAILURE.  */
2347
2348 static try
2349 check_restricted (gfc_expr *e)
2350 {
2351   gfc_symbol *sym;
2352   try t;
2353
2354   if (e == NULL)
2355     return SUCCESS;
2356
2357   switch (e->expr_type)
2358     {
2359     case EXPR_OP:
2360       t = check_intrinsic_op (e, check_restricted);
2361       if (t == SUCCESS)
2362         t = gfc_simplify_expr (e, 0);
2363
2364       break;
2365
2366     case EXPR_FUNCTION:
2367       t = e->value.function.esym ? external_spec_function (e)
2368                                  : restricted_intrinsic (e);
2369       break;
2370
2371     case EXPR_VARIABLE:
2372       sym = e->symtree->n.sym;
2373       t = FAILURE;
2374
2375       if (sym->attr.optional)
2376         {
2377           gfc_error ("Dummy argument '%s' at %L cannot be OPTIONAL",
2378                      sym->name, &e->where);
2379           break;
2380         }
2381
2382       if (sym->attr.intent == INTENT_OUT)
2383         {
2384           gfc_error ("Dummy argument '%s' at %L cannot be INTENT(OUT)",
2385                      sym->name, &e->where);
2386           break;
2387         }
2388
2389       /* gfc_is_formal_arg broadcasts that a formal argument list is being
2390          processed in resolve.c(resolve_formal_arglist).  This is done so
2391          that host associated dummy array indices are accepted (PR23446).
2392          This mechanism also does the same for the specification expressions
2393          of array-valued functions.  */
2394       if (sym->attr.in_common
2395           || sym->attr.use_assoc
2396           || sym->attr.dummy
2397           || sym->ns != gfc_current_ns
2398           || (sym->ns->proc_name != NULL
2399               && sym->ns->proc_name->attr.flavor == FL_MODULE)
2400           || (gfc_is_formal_arg () && (sym->ns == gfc_current_ns)))
2401         {
2402           t = SUCCESS;
2403           break;
2404         }
2405
2406       gfc_error ("Variable '%s' cannot appear in the expression at %L",
2407                  sym->name, &e->where);
2408
2409       break;
2410
2411     case EXPR_NULL:
2412     case EXPR_CONSTANT:
2413       t = SUCCESS;
2414       break;
2415
2416     case EXPR_SUBSTRING:
2417       t = gfc_specification_expr (e->ref->u.ss.start);
2418       if (t == FAILURE)
2419         break;
2420
2421       t = gfc_specification_expr (e->ref->u.ss.end);
2422       if (t == SUCCESS)
2423         t = gfc_simplify_expr (e, 0);
2424
2425       break;
2426
2427     case EXPR_STRUCTURE:
2428       t = gfc_check_constructor (e, check_restricted);
2429       break;
2430
2431     case EXPR_ARRAY:
2432       t = gfc_check_constructor (e, check_restricted);
2433       break;
2434
2435     default:
2436       gfc_internal_error ("check_restricted(): Unknown expression type");
2437     }
2438
2439   return t;
2440 }
2441
2442
2443 /* Check to see that an expression is a specification expression.  If
2444    we return FAILURE, an error has been generated.  */
2445
2446 try
2447 gfc_specification_expr (gfc_expr *e)
2448 {
2449
2450   if (e == NULL)
2451     return SUCCESS;
2452
2453   if (e->ts.type != BT_INTEGER)
2454     {
2455       gfc_error ("Expression at %L must be of INTEGER type", &e->where);
2456       return FAILURE;
2457     }
2458
2459   if (e->rank != 0)
2460     {
2461       gfc_error ("Expression at %L must be scalar", &e->where);
2462       return FAILURE;
2463     }
2464
2465   if (gfc_simplify_expr (e, 0) == FAILURE)
2466     return FAILURE;
2467
2468   return check_restricted (e);
2469 }
2470
2471
2472 /************** Expression conformance checks.  *************/
2473
2474 /* Given two expressions, make sure that the arrays are conformable.  */
2475
2476 try
2477 gfc_check_conformance (const char *optype_msgid, gfc_expr *op1, gfc_expr *op2)
2478 {
2479   int op1_flag, op2_flag, d;
2480   mpz_t op1_size, op2_size;
2481   try t;
2482
2483   if (op1->rank == 0 || op2->rank == 0)
2484     return SUCCESS;
2485
2486   if (op1->rank != op2->rank)
2487     {
2488       gfc_error ("Incompatible ranks in %s at %L", _(optype_msgid),
2489                  &op1->where);
2490       return FAILURE;
2491     }
2492
2493   t = SUCCESS;
2494
2495   for (d = 0; d < op1->rank; d++)
2496     {
2497       op1_flag = gfc_array_dimen_size (op1, d, &op1_size) == SUCCESS;
2498       op2_flag = gfc_array_dimen_size (op2, d, &op2_size) == SUCCESS;
2499
2500       if (op1_flag && op2_flag && mpz_cmp (op1_size, op2_size) != 0)
2501         {
2502           gfc_error ("different shape for %s at %L on dimension %d (%d/%d)",
2503                      _(optype_msgid), &op1->where, d + 1,
2504                      (int) mpz_get_si (op1_size),
2505                      (int) mpz_get_si (op2_size));
2506
2507           t = FAILURE;
2508         }
2509
2510       if (op1_flag)
2511         mpz_clear (op1_size);
2512       if (op2_flag)
2513         mpz_clear (op2_size);
2514
2515       if (t == FAILURE)
2516         return FAILURE;
2517     }
2518
2519   return SUCCESS;
2520 }
2521
2522
2523 /* Given an assignable expression and an arbitrary expression, make
2524    sure that the assignment can take place.  */
2525
2526 try
2527 gfc_check_assign (gfc_expr *lvalue, gfc_expr *rvalue, int conform)
2528 {
2529   gfc_symbol *sym;
2530   gfc_ref *ref;
2531   int has_pointer;
2532
2533   sym = lvalue->symtree->n.sym;
2534
2535   /* Check INTENT(IN), unless the object itself is the component or
2536      sub-component of a pointer.  */
2537   has_pointer = sym->attr.pointer;
2538
2539   for (ref = lvalue->ref; ref; ref = ref->next)
2540     if (ref->type == REF_COMPONENT && ref->u.c.component->pointer)
2541       {
2542         has_pointer = 1;
2543         break;
2544       }
2545
2546   if (!has_pointer && sym->attr.intent == INTENT_IN)
2547     {
2548       gfc_error ("Cannot assign to INTENT(IN) variable '%s' at %L",
2549                  sym->name, &lvalue->where);
2550       return FAILURE;
2551     }
2552
2553   /* 12.5.2.2, Note 12.26: The result variable is very similar to any other
2554      variable local to a function subprogram.  Its existence begins when
2555      execution of the function is initiated and ends when execution of the
2556      function is terminated...
2557      Therefore, the left hand side is no longer a variable, when it is:  */
2558   if (sym->attr.flavor == FL_PROCEDURE && sym->attr.proc != PROC_ST_FUNCTION
2559       && !sym->attr.external)
2560     {
2561       bool bad_proc;
2562       bad_proc = false;
2563
2564       /* (i) Use associated;  */
2565       if (sym->attr.use_assoc)
2566         bad_proc = true;
2567
2568       /* (ii) The assignment is in the main program; or  */
2569       if (gfc_current_ns->proc_name->attr.is_main_program)
2570         bad_proc = true;
2571
2572       /* (iii) A module or internal procedure...  */
2573       if ((gfc_current_ns->proc_name->attr.proc == PROC_INTERNAL
2574            || gfc_current_ns->proc_name->attr.proc == PROC_MODULE)
2575           && gfc_current_ns->parent
2576           && (!(gfc_current_ns->parent->proc_name->attr.function
2577                 || gfc_current_ns->parent->proc_name->attr.subroutine)
2578               || gfc_current_ns->parent->proc_name->attr.is_main_program))
2579         {
2580           /* ... that is not a function...  */ 
2581           if (!gfc_current_ns->proc_name->attr.function)
2582             bad_proc = true;
2583
2584           /* ... or is not an entry and has a different name.  */
2585           if (!sym->attr.entry && sym->name != gfc_current_ns->proc_name->name)
2586             bad_proc = true;
2587         }
2588
2589       if (bad_proc)
2590         {
2591           gfc_error ("'%s' at %L is not a VALUE", sym->name, &lvalue->where);
2592           return FAILURE;
2593         }
2594     }
2595
2596   if (rvalue->rank != 0 && lvalue->rank != rvalue->rank)
2597     {
2598       gfc_error ("Incompatible ranks %d and %d in assignment at %L",
2599                  lvalue->rank, rvalue->rank, &lvalue->where);
2600       return FAILURE;
2601     }
2602
2603   if (lvalue->ts.type == BT_UNKNOWN)
2604     {
2605       gfc_error ("Variable type is UNKNOWN in assignment at %L",
2606                  &lvalue->where);
2607       return FAILURE;
2608     }
2609
2610   if (rvalue->expr_type == EXPR_NULL)
2611     {  
2612       if (lvalue->symtree->n.sym->attr.pointer
2613           && lvalue->symtree->n.sym->attr.data)
2614         return SUCCESS;
2615       else
2616         {
2617           gfc_error ("NULL appears on right-hand side in assignment at %L",
2618                      &rvalue->where);
2619           return FAILURE;
2620         }
2621     }
2622
2623    if (sym->attr.cray_pointee
2624        && lvalue->ref != NULL
2625        && lvalue->ref->u.ar.type == AR_FULL
2626        && lvalue->ref->u.ar.as->cp_was_assumed)
2627      {
2628        gfc_error ("Vector assignment to assumed-size Cray Pointee at %L "
2629                   "is illegal", &lvalue->where);
2630        return FAILURE;
2631      }
2632
2633   /* This is possibly a typo: x = f() instead of x => f().  */
2634   if (gfc_option.warn_surprising 
2635       && rvalue->expr_type == EXPR_FUNCTION
2636       && rvalue->symtree->n.sym->attr.pointer)
2637     gfc_warning ("POINTER valued function appears on right-hand side of "
2638                  "assignment at %L", &rvalue->where);
2639
2640   /* Check size of array assignments.  */
2641   if (lvalue->rank != 0 && rvalue->rank != 0
2642       && gfc_check_conformance ("Array assignment", lvalue, rvalue) != SUCCESS)
2643     return FAILURE;
2644
2645   if (gfc_compare_types (&lvalue->ts, &rvalue->ts))
2646     return SUCCESS;
2647
2648   if (!conform)
2649     {
2650       /* Numeric can be converted to any other numeric. And Hollerith can be
2651          converted to any other type.  */
2652       if ((gfc_numeric_ts (&lvalue->ts) && gfc_numeric_ts (&rvalue->ts))
2653           || rvalue->ts.type == BT_HOLLERITH)
2654         return SUCCESS;
2655
2656       if (lvalue->ts.type == BT_LOGICAL && rvalue->ts.type == BT_LOGICAL)
2657         return SUCCESS;
2658
2659       gfc_error ("Incompatible types in assignment at %L, %s to %s",
2660                  &rvalue->where, gfc_typename (&rvalue->ts),
2661                  gfc_typename (&lvalue->ts));
2662
2663       return FAILURE;
2664     }
2665
2666   return gfc_convert_type (rvalue, &lvalue->ts, 1);
2667 }
2668
2669
2670 /* Check that a pointer assignment is OK.  We first check lvalue, and
2671    we only check rvalue if it's not an assignment to NULL() or a
2672    NULLIFY statement.  */
2673
2674 try
2675 gfc_check_pointer_assign (gfc_expr *lvalue, gfc_expr *rvalue)
2676 {
2677   symbol_attribute attr;
2678   gfc_ref *ref;
2679   int is_pure;
2680   int pointer, check_intent_in;
2681
2682   if (lvalue->symtree->n.sym->ts.type == BT_UNKNOWN)
2683     {
2684       gfc_error ("Pointer assignment target is not a POINTER at %L",
2685                  &lvalue->where);
2686       return FAILURE;
2687     }
2688
2689   if (lvalue->symtree->n.sym->attr.flavor == FL_PROCEDURE
2690       && lvalue->symtree->n.sym->attr.use_assoc)
2691     {
2692       gfc_error ("'%s' in the pointer assignment at %L cannot be an "
2693                  "l-value since it is a procedure",
2694                  lvalue->symtree->n.sym->name, &lvalue->where);
2695       return FAILURE;
2696     }
2697
2698
2699   /* Check INTENT(IN), unless the object itself is the component or
2700      sub-component of a pointer.  */
2701   check_intent_in = 1;
2702   pointer = lvalue->symtree->n.sym->attr.pointer;
2703
2704   for (ref = lvalue->ref; ref; ref = ref->next)
2705     {
2706       if (pointer)
2707         check_intent_in = 0;
2708
2709       if (ref->type == REF_COMPONENT && ref->u.c.component->pointer)
2710         pointer = 1;
2711     }
2712
2713   if (check_intent_in && lvalue->symtree->n.sym->attr.intent == INTENT_IN)
2714     {
2715       gfc_error ("Cannot assign to INTENT(IN) variable '%s' at %L",
2716                  lvalue->symtree->n.sym->name, &lvalue->where);
2717       return FAILURE;
2718     }
2719
2720   if (!pointer)
2721     {
2722       gfc_error ("Pointer assignment to non-POINTER at %L", &lvalue->where);
2723       return FAILURE;
2724     }
2725
2726   is_pure = gfc_pure (NULL);
2727
2728   if (is_pure && gfc_impure_variable (lvalue->symtree->n.sym))
2729     {
2730       gfc_error ("Bad pointer object in PURE procedure at %L", &lvalue->where);
2731       return FAILURE;
2732     }
2733
2734   /* If rvalue is a NULL() or NULLIFY, we're done. Otherwise the type,
2735      kind, etc for lvalue and rvalue must match, and rvalue must be a
2736      pure variable if we're in a pure function.  */
2737   if (rvalue->expr_type == EXPR_NULL && rvalue->ts.type == BT_UNKNOWN)
2738     return SUCCESS;
2739
2740   if (!gfc_compare_types (&lvalue->ts, &rvalue->ts))
2741     {
2742       gfc_error ("Different types in pointer assignment at %L",
2743                  &lvalue->where);
2744       return FAILURE;
2745     }
2746
2747   if (lvalue->ts.kind != rvalue->ts.kind)
2748     {
2749       gfc_error ("Different kind type parameters in pointer "
2750                  "assignment at %L", &lvalue->where);
2751       return FAILURE;
2752     }
2753
2754   if (lvalue->rank != rvalue->rank)
2755     {
2756       gfc_error ("Different ranks in pointer assignment at %L",
2757                  &lvalue->where);
2758       return FAILURE;
2759     }
2760
2761   /* Now punt if we are dealing with a NULLIFY(X) or X = NULL(X).  */
2762   if (rvalue->expr_type == EXPR_NULL)
2763     return SUCCESS;
2764
2765   if (lvalue->ts.type == BT_CHARACTER
2766       && lvalue->ts.cl && rvalue->ts.cl
2767       && lvalue->ts.cl->length && rvalue->ts.cl->length
2768       && abs (gfc_dep_compare_expr (lvalue->ts.cl->length,
2769                                     rvalue->ts.cl->length)) == 1)
2770     {
2771       gfc_error ("Different character lengths in pointer "
2772                  "assignment at %L", &lvalue->where);
2773       return FAILURE;
2774     }
2775
2776   attr = gfc_expr_attr (rvalue);
2777   if (!attr.target && !attr.pointer)
2778     {
2779       gfc_error ("Pointer assignment target is neither TARGET "
2780                  "nor POINTER at %L", &rvalue->where);
2781       return FAILURE;
2782     }
2783
2784   if (is_pure && gfc_impure_variable (rvalue->symtree->n.sym))
2785     {
2786       gfc_error ("Bad target in pointer assignment in PURE "
2787                  "procedure at %L", &rvalue->where);
2788     }
2789
2790   if (gfc_has_vector_index (rvalue))
2791     {
2792       gfc_error ("Pointer assignment with vector subscript "
2793                  "on rhs at %L", &rvalue->where);
2794       return FAILURE;
2795     }
2796
2797   if (attr.protected && attr.use_assoc)
2798     {
2799       gfc_error ("Pointer assigment target has PROTECTED "
2800                  "attribute at %L", &rvalue->where);
2801       return FAILURE;
2802     }
2803
2804   return SUCCESS;
2805 }
2806
2807
2808 /* Relative of gfc_check_assign() except that the lvalue is a single
2809    symbol.  Used for initialization assignments.  */
2810
2811 try
2812 gfc_check_assign_symbol (gfc_symbol *sym, gfc_expr *rvalue)
2813 {
2814   gfc_expr lvalue;
2815   try r;
2816
2817   memset (&lvalue, '\0', sizeof (gfc_expr));
2818
2819   lvalue.expr_type = EXPR_VARIABLE;
2820   lvalue.ts = sym->ts;
2821   if (sym->as)
2822     lvalue.rank = sym->as->rank;
2823   lvalue.symtree = (gfc_symtree *) gfc_getmem (sizeof (gfc_symtree));
2824   lvalue.symtree->n.sym = sym;
2825   lvalue.where = sym->declared_at;
2826
2827   if (sym->attr.pointer)
2828     r = gfc_check_pointer_assign (&lvalue, rvalue);
2829   else
2830     r = gfc_check_assign (&lvalue, rvalue, 1);
2831
2832   gfc_free (lvalue.symtree);
2833
2834   return r;
2835 }
2836
2837
2838 /* Get an expression for a default initializer.  */
2839
2840 gfc_expr *
2841 gfc_default_initializer (gfc_typespec *ts)
2842 {
2843   gfc_constructor *tail;
2844   gfc_expr *init;
2845   gfc_component *c;
2846
2847   init = NULL;
2848
2849   /* See if we have a default initializer.  */
2850   for (c = ts->derived->components; c; c = c->next)
2851     {
2852       if ((c->initializer || c->allocatable) && init == NULL)
2853         init = gfc_get_expr ();
2854     }
2855
2856   if (init == NULL)
2857     return NULL;
2858
2859   /* Build the constructor.  */
2860   init->expr_type = EXPR_STRUCTURE;
2861   init->ts = *ts;
2862   init->where = ts->derived->declared_at;
2863   tail = NULL;
2864   for (c = ts->derived->components; c; c = c->next)
2865     {
2866       if (tail == NULL)
2867         init->value.constructor = tail = gfc_get_constructor ();
2868       else
2869         {
2870           tail->next = gfc_get_constructor ();
2871           tail = tail->next;
2872         }
2873
2874       if (c->initializer)
2875         tail->expr = gfc_copy_expr (c->initializer);
2876
2877       if (c->allocatable)
2878         {
2879           tail->expr = gfc_get_expr ();
2880           tail->expr->expr_type = EXPR_NULL;
2881           tail->expr->ts = c->ts;
2882         }
2883     }
2884   return init;
2885 }
2886
2887
2888 /* Given a symbol, create an expression node with that symbol as a
2889    variable. If the symbol is array valued, setup a reference of the
2890    whole array.  */
2891
2892 gfc_expr *
2893 gfc_get_variable_expr (gfc_symtree *var)
2894 {
2895   gfc_expr *e;
2896
2897   e = gfc_get_expr ();
2898   e->expr_type = EXPR_VARIABLE;
2899   e->symtree = var;
2900   e->ts = var->n.sym->ts;
2901
2902   if (var->n.sym->as != NULL)
2903     {
2904       e->rank = var->n.sym->as->rank;
2905       e->ref = gfc_get_ref ();
2906       e->ref->type = REF_ARRAY;
2907       e->ref->u.ar.type = AR_FULL;
2908     }
2909
2910   return e;
2911 }
2912
2913
2914 /* Traverse expr, marking all EXPR_VARIABLE symbols referenced.  */
2915
2916 void
2917 gfc_expr_set_symbols_referenced (gfc_expr *expr)
2918 {
2919   gfc_actual_arglist *arg;
2920   gfc_constructor *c;
2921   gfc_ref *ref;
2922   int i;
2923
2924   if (!expr) return;
2925
2926   switch (expr->expr_type)
2927     {
2928     case EXPR_OP:
2929       gfc_expr_set_symbols_referenced (expr->value.op.op1);
2930       gfc_expr_set_symbols_referenced (expr->value.op.op2);
2931       break;
2932
2933     case EXPR_FUNCTION:
2934       for (arg = expr->value.function.actual; arg; arg = arg->next)
2935         gfc_expr_set_symbols_referenced (arg->expr);
2936       break;
2937
2938     case EXPR_VARIABLE:
2939       gfc_set_sym_referenced (expr->symtree->n.sym);
2940       break;
2941
2942     case EXPR_CONSTANT:
2943     case EXPR_NULL:
2944     case EXPR_SUBSTRING:
2945       break;
2946
2947     case EXPR_STRUCTURE:
2948     case EXPR_ARRAY:
2949       for (c = expr->value.constructor; c; c = c->next)
2950         gfc_expr_set_symbols_referenced (c->expr);
2951       break;
2952
2953     default:
2954       gcc_unreachable ();
2955       break;
2956     }
2957
2958     for (ref = expr->ref; ref; ref = ref->next)
2959       switch (ref->type)
2960         {
2961         case REF_ARRAY:
2962           for (i = 0; i < ref->u.ar.dimen; i++)
2963             {
2964               gfc_expr_set_symbols_referenced (ref->u.ar.start[i]);
2965               gfc_expr_set_symbols_referenced (ref->u.ar.end[i]);
2966               gfc_expr_set_symbols_referenced (ref->u.ar.stride[i]);
2967             }
2968           break;
2969            
2970         case REF_COMPONENT:
2971           break;
2972            
2973         case REF_SUBSTRING:
2974           gfc_expr_set_symbols_referenced (ref->u.ss.start);
2975           gfc_expr_set_symbols_referenced (ref->u.ss.end);
2976           break;
2977            
2978         default:
2979           gcc_unreachable ();
2980           break;
2981         }
2982 }