?  search:
summary | log | graphiclog1 | graphiclog2 | commit | commitdiff | tree | refs | edit | fork
blame | history | raw | HEAD
Merge from mainline
[official-gcc.git] / gcc / fortran / expr.c
blob6db1c6bad7cca672fac0a0dcacd457e052009041
1 /* Routines for manipulation of expression nodes.
2 Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006 Free Software
3 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
38 gfc_clear_ts (&e->ts);
39 e->shape = NULL;
40 e->ref = NULL;
41 e->symtree = NULL;
42
43 return e;
44 }
45
46
47 /* Free an argument list and everything below it. */
48
49 void
50 gfc_free_actual_arglist (gfc_actual_arglist * a1)
51 {
52 gfc_actual_arglist *a2;
53
54 while (a1)
55 {
56 a2 = a1->next;
57 gfc_free_expr (a1->expr);
58 gfc_free (a1);
59 a1 = a2;
60 }
61 }
62
63
64 /* Copy an arglist structure and all of the arguments. */
65
66 gfc_actual_arglist *
67 gfc_copy_actual_arglist (gfc_actual_arglist * p)
68 {
69 gfc_actual_arglist *head, *tail, *new;
70
71 head = tail = NULL;
72
73 for (; p; p = p->next)
74 {
75 new = gfc_get_actual_arglist ();
76 *new = *p;
77
78 new->expr = gfc_copy_expr (p->expr);
79 new->next = NULL;
80
81 if (head == NULL)
82 head = new;
83 else
84 tail->next = new;
85
86 tail = new;
87 }
88
89 return head;
90 }
91
92
93 /* Free a list of reference structures. */
94
95 void
96 gfc_free_ref_list (gfc_ref * p)
97 {
98 gfc_ref *q;
99 int i;
100
101 for (; p; p = q)
102 {
103 q = p->next;
104
105 switch (p->type)
106 {
107 case REF_ARRAY:
108 for (i = 0; i < GFC_MAX_DIMENSIONS; i++)
109 {
110 gfc_free_expr (p->u.ar.start[i]);
111 gfc_free_expr (p->u.ar.end[i]);
112 gfc_free_expr (p->u.ar.stride[i]);
113 }
114
115 break;
116
117 case REF_SUBSTRING:
118 gfc_free_expr (p->u.ss.start);
119 gfc_free_expr (p->u.ss.end);
120 break;
121
122 case REF_COMPONENT:
123 break;
124 }
125
126 gfc_free (p);
127 }
128 }
129
130
131 /* Workhorse function for gfc_free_expr() that frees everything
132 beneath an expression node, but not the node itself. This is
133 useful when we want to simplify a node and replace it with
134 something else or the expression node belongs to another structure. */
135
136 static void
137 free_expr0 (gfc_expr * e)
138 {
139 int n;
140
141 switch (e->expr_type)
142 {
143 case EXPR_CONSTANT:
144 if (e->from_H)
145 {
146 gfc_free (e->value.character.string);
147 break;
148 }
149
150 switch (e->ts.type)
151 {
152 case BT_INTEGER:
153 mpz_clear (e->value.integer);
154 break;
155
156 case BT_REAL:
157 mpfr_clear (e->value.real);
158 break;
159
160 case BT_CHARACTER:
161 case BT_HOLLERITH:
162 gfc_free (e->value.character.string);
163 break;
164
165 case BT_COMPLEX:
166 mpfr_clear (e->value.complex.r);
167 mpfr_clear (e->value.complex.i);
168 break;
169
170 default:
171 break;
172 }
173
174 break;
175
176 case EXPR_OP:
177 if (e->value.op.op1 != NULL)
178 gfc_free_expr (e->value.op.op1);
179 if (e->value.op.op2 != NULL)
180 gfc_free_expr (e->value.op.op2);
181 break;
182
183 case EXPR_FUNCTION:
184 gfc_free_actual_arglist (e->value.function.actual);
185 break;
186
187 case EXPR_VARIABLE:
188 break;
189
190 case EXPR_ARRAY:
191 case EXPR_STRUCTURE:
192 gfc_free_constructor (e->value.constructor);
193 break;
194
195 case EXPR_SUBSTRING:
196 gfc_free (e->value.character.string);
197 break;
198
199 case EXPR_NULL:
200 break;
201
202 default:
203 gfc_internal_error ("free_expr0(): Bad expr type");
204 }
205
206 /* Free a shape array. */
207 if (e->shape != NULL)
208 {
209 for (n = 0; n < e->rank; n++)
210 mpz_clear (e->shape[n]);
211
212 gfc_free (e->shape);
213 }
214
215 gfc_free_ref_list (e->ref);
216
217 memset (e, '\0', sizeof (gfc_expr));
218 }
219
220
221 /* Free an expression node and everything beneath it. */
222
223 void
224 gfc_free_expr (gfc_expr * e)
225 {
226
227 if (e == NULL)
228 return;
229
230 free_expr0 (e);
231 gfc_free (e);
232 }
233
234
235 /* Graft the *src expression onto the *dest subexpression. */
236
237 void
238 gfc_replace_expr (gfc_expr * dest, gfc_expr * src)
239 {
240
241 free_expr0 (dest);
242 *dest = *src;
243
244 gfc_free (src);
245 }
246
247
248 /* Try to extract an integer constant from the passed expression node.
249 Returns an error message or NULL if the result is set. It is
250 tempting to generate an error and return SUCCESS or FAILURE, but
251 failure is OK for some callers. */
252
253 const char *
254 gfc_extract_int (gfc_expr * expr, int *result)
255 {
256
257 if (expr->expr_type != EXPR_CONSTANT)
258 return _("Constant expression required at %C");
259
260 if (expr->ts.type != BT_INTEGER)
261 return _("Integer expression required at %C");
262
263 if ((mpz_cmp_si (expr->value.integer, INT_MAX) > 0)
264 || (mpz_cmp_si (expr->value.integer, INT_MIN) < 0))
265 {
266 return _("Integer value too large in expression at %C");
267 }
268
269 *result = (int) mpz_get_si (expr->value.integer);
270
271 return NULL;
272 }
273
274
275 /* Recursively copy a list of reference structures. */
276
277 static gfc_ref *
278 copy_ref (gfc_ref * src)
279 {
280 gfc_array_ref *ar;
281 gfc_ref *dest;
282
283 if (src == NULL)
284 return NULL;
285
286 dest = gfc_get_ref ();
287 dest->type = src->type;
288
289 switch (src->type)
290 {
291 case REF_ARRAY:
292 ar = gfc_copy_array_ref (&src->u.ar);
293 dest->u.ar = *ar;
294 gfc_free (ar);
295 break;
296
297 case REF_COMPONENT:
298 dest->u.c = src->u.c;
299 break;
300
301 case REF_SUBSTRING:
302 dest->u.ss = src->u.ss;
303 dest->u.ss.start = gfc_copy_expr (src->u.ss.start);
304 dest->u.ss.end = gfc_copy_expr (src->u.ss.end);
305 break;
306 }
307
308 dest->next = copy_ref (src->next);
309
310 return dest;
311 }
312
313
314 /* Detect whether an expression has any vector index array
315 references. */
316
317 int
318 gfc_has_vector_index (gfc_expr *e)
319 {
320 gfc_ref * ref;
321 int i;
322 for (ref = e->ref; ref; ref = ref->next)
323 if (ref->type == REF_ARRAY)
324 for (i = 0; i < ref->u.ar.dimen; i++)
325 if (ref->u.ar.dimen_type[i] == DIMEN_VECTOR)
326 return 1;
327 return 0;
328 }
329
330
331 /* Copy a shape array. */
332
333 mpz_t *
334 gfc_copy_shape (mpz_t * shape, int rank)
335 {
336 mpz_t *new_shape;
337 int n;
338
339 if (shape == NULL)
340 return NULL;
341
342 new_shape = gfc_get_shape (rank);
343
344 for (n = 0; n < rank; n++)
345 mpz_init_set (new_shape[n], shape[n]);
346
347 return new_shape;
348 }
349
350
351 /* Copy a shape array excluding dimension N, where N is an integer
352 constant expression. Dimensions are numbered in fortran style --
353 starting with ONE.
354
355 So, if the original shape array contains R elements
356 { s1 ... sN-1 sN sN+1 ... sR-1 sR}
357 the result contains R-1 elements:
358 { s1 ... sN-1 sN+1 ... sR-1}
359
360 If anything goes wrong -- N is not a constant, its value is out
361 of range -- or anything else, just returns NULL.
362 */
363
364 mpz_t *
365 gfc_copy_shape_excluding (mpz_t * shape, int rank, gfc_expr * dim)
366 {
367 mpz_t *new_shape, *s;
368 int i, n;
369
370 if (shape == NULL
371 || rank <= 1
372 || dim == NULL
373 || dim->expr_type != EXPR_CONSTANT
374 || dim->ts.type != BT_INTEGER)
375 return NULL;
376
377 n = mpz_get_si (dim->value.integer);
378 n--; /* Convert to zero based index */
379 if (n < 0 || n >= rank)
380 return NULL;
381
382 s = new_shape = gfc_get_shape (rank-1);
383
384 for (i = 0; i < rank; i++)
385 {
386 if (i == n)
387 continue;
388 mpz_init_set (*s, shape[i]);
389 s++;
390 }
391
392 return new_shape;
393 }
394
395 /* Given an expression pointer, return a copy of the expression. This
396 subroutine is recursive. */
397
398 gfc_expr *
399 gfc_copy_expr (gfc_expr * p)
400 {
401 gfc_expr *q;
402 char *s;
403
404 if (p == NULL)
405 return NULL;
406
407 q = gfc_get_expr ();
408 *q = *p;
409
410 switch (q->expr_type)
411 {
412 case EXPR_SUBSTRING:
413 s = gfc_getmem (p->value.character.length + 1);
414 q->value.character.string = s;
415
416 memcpy (s, p->value.character.string, p->value.character.length + 1);
417 break;
418
419 case EXPR_CONSTANT:
420 if (p->from_H)
421 {
422 s = gfc_getmem (p->value.character.length + 1);
423 q->value.character.string = s;
424
425 memcpy (s, p->value.character.string,
426 p->value.character.length + 1);
427 break;
428 }
429 switch (q->ts.type)
430 {
431 case BT_INTEGER:
432 mpz_init_set (q->value.integer, p->value.integer);
433 break;
434
435 case BT_REAL:
436 gfc_set_model_kind (q->ts.kind);
437 mpfr_init (q->value.real);
438 mpfr_set (q->value.real, p->value.real, GFC_RND_MODE);
439 break;
440
441 case BT_COMPLEX:
442 gfc_set_model_kind (q->ts.kind);
443 mpfr_init (q->value.complex.r);
444 mpfr_init (q->value.complex.i);
445 mpfr_set (q->value.complex.r, p->value.complex.r, GFC_RND_MODE);
446 mpfr_set (q->value.complex.i, p->value.complex.i, GFC_RND_MODE);
447 break;
448
449 case BT_CHARACTER:
450 case BT_HOLLERITH:
451 s = gfc_getmem (p->value.character.length + 1);
452 q->value.character.string = s;
453
454 memcpy (s, p->value.character.string,
455 p->value.character.length + 1);
456 break;
457
458 case BT_LOGICAL:
459 case BT_DERIVED:
460 break; /* Already done */
461
462 case BT_PROCEDURE:
463 case BT_UNKNOWN:
464 gfc_internal_error ("gfc_copy_expr(): Bad expr node");
465 /* Not reached */
466 }
467
468 break;
469
470 case EXPR_OP:
471 switch (q->value.op.operator)
472 {
473 case INTRINSIC_NOT:
474 case INTRINSIC_UPLUS:
475 case INTRINSIC_UMINUS:
476 q->value.op.op1 = gfc_copy_expr (p->value.op.op1);
477 break;
478
479 default: /* Binary operators */
480 q->value.op.op1 = gfc_copy_expr (p->value.op.op1);
481 q->value.op.op2 = gfc_copy_expr (p->value.op.op2);
482 break;
483 }
484
485 break;
486
487 case EXPR_FUNCTION:
488 q->value.function.actual =
489 gfc_copy_actual_arglist (p->value.function.actual);
490 break;
491
492 case EXPR_STRUCTURE:
493 case EXPR_ARRAY:
494 q->value.constructor = gfc_copy_constructor (p->value.constructor);
495 break;
496
497 case EXPR_VARIABLE:
498 case EXPR_NULL:
499 break;
500 }
501
502 q->shape = gfc_copy_shape (p->shape, p->rank);
503
504 q->ref = copy_ref (p->ref);
505
506 return q;
507 }
508
509
510 /* Return the maximum kind of two expressions. In general, higher
511 kind numbers mean more precision for numeric types. */
512
513 int
514 gfc_kind_max (gfc_expr * e1, gfc_expr * e2)
515 {
516
517 return (e1->ts.kind > e2->ts.kind) ? e1->ts.kind : e2->ts.kind;
518 }
519
520
521 /* Returns nonzero if the type is numeric, zero otherwise. */
522
523 static int
524 numeric_type (bt type)
525 {
526
527 return type == BT_COMPLEX || type == BT_REAL || type == BT_INTEGER;
528 }
529
530
531 /* Returns nonzero if the typespec is a numeric type, zero otherwise. */
532
533 int
534 gfc_numeric_ts (gfc_typespec * ts)
535 {
536
537 return numeric_type (ts->type);
538 }
539
540
541 /* Returns an expression node that is an integer constant. */
542
543 gfc_expr *
544 gfc_int_expr (int i)
545 {
546 gfc_expr *p;
547
548 p = gfc_get_expr ();
549
550 p->expr_type = EXPR_CONSTANT;
551 p->ts.type = BT_INTEGER;
552 p->ts.kind = gfc_default_integer_kind;
553
554 p->where = gfc_current_locus;
555 mpz_init_set_si (p->value.integer, i);
556
557 return p;
558 }
559
560
561 /* Returns an expression node that is a logical constant. */
562
563 gfc_expr *
564 gfc_logical_expr (int i, locus * where)
565 {
566 gfc_expr *p;
567
568 p = gfc_get_expr ();
569
570 p->expr_type = EXPR_CONSTANT;
571 p->ts.type = BT_LOGICAL;
572 p->ts.kind = gfc_default_logical_kind;
573
574 if (where == NULL)
575 where = &gfc_current_locus;
576 p->where = *where;
577 p->value.logical = i;
578
579 return p;
580 }
581
582
583 /* Return an expression node with an optional argument list attached.
584 A variable number of gfc_expr pointers are strung together in an
585 argument list with a NULL pointer terminating the list. */
586
587 gfc_expr *
588 gfc_build_conversion (gfc_expr * e)
589 {
590 gfc_expr *p;
591
592 p = gfc_get_expr ();
593 p->expr_type = EXPR_FUNCTION;
594 p->symtree = NULL;
595 p->value.function.actual = NULL;
596
597 p->value.function.actual = gfc_get_actual_arglist ();
598 p->value.function.actual->expr = e;
599
600 return p;
601 }
602
603
604 /* Given an expression node with some sort of numeric binary
605 expression, insert type conversions required to make the operands
606 have the same type.
607
608 The exception is that the operands of an exponential don't have to
609 have the same type. If possible, the base is promoted to the type
610 of the exponent. For example, 1**2.3 becomes 1.0**2.3, but
611 1.0**2 stays as it is. */
612
613 void
614 gfc_type_convert_binary (gfc_expr * e)
615 {
616 gfc_expr *op1, *op2;
617
618 op1 = e->value.op.op1;
619 op2 = e->value.op.op2;
620
621 if (op1->ts.type == BT_UNKNOWN || op2->ts.type == BT_UNKNOWN)
622 {
623 gfc_clear_ts (&e->ts);
624 return;
625 }
626
627 /* Kind conversions of same type. */
628 if (op1->ts.type == op2->ts.type)
629 {
630
631 if (op1->ts.kind == op2->ts.kind)
632 {
633 /* No type conversions. */
634 e->ts = op1->ts;
635 goto done;
636 }
637
638 if (op1->ts.kind > op2->ts.kind)
639 gfc_convert_type (op2, &op1->ts, 2);
640 else
641 gfc_convert_type (op1, &op2->ts, 2);
642
643 e->ts = op1->ts;
644 goto done;
645 }
646
647 /* Integer combined with real or complex. */
648 if (op2->ts.type == BT_INTEGER)
649 {
650 e->ts = op1->ts;
651
652 /* Special case for ** operator. */
653 if (e->value.op.operator == INTRINSIC_POWER)
654 goto done;
655
656 gfc_convert_type (e->value.op.op2, &e->ts, 2);
657 goto done;
658 }
659
660 if (op1->ts.type == BT_INTEGER)
661 {
662 e->ts = op2->ts;
663 gfc_convert_type (e->value.op.op1, &e->ts, 2);
664 goto done;
665 }
666
667 /* Real combined with complex. */
668 e->ts.type = BT_COMPLEX;
669 if (op1->ts.kind > op2->ts.kind)
670 e->ts.kind = op1->ts.kind;
671 else
672 e->ts.kind = op2->ts.kind;
673 if (op1->ts.type != BT_COMPLEX || op1->ts.kind != e->ts.kind)
674 gfc_convert_type (e->value.op.op1, &e->ts, 2);
675 if (op2->ts.type != BT_COMPLEX || op2->ts.kind != e->ts.kind)
676 gfc_convert_type (e->value.op.op2, &e->ts, 2);
677
678 done:
679 return;
680 }
681
682
683 /* Function to determine if an expression is constant or not. This
684 function expects that the expression has already been simplified. */
685
686 int
687 gfc_is_constant_expr (gfc_expr * e)
688 {
689 gfc_constructor *c;
690 gfc_actual_arglist *arg;
691 int rv;
692
693 if (e == NULL)
694 return 1;
695
696 switch (e->expr_type)
697 {
698 case EXPR_OP:
699 rv = (gfc_is_constant_expr (e->value.op.op1)
700 && (e->value.op.op2 == NULL
701 || gfc_is_constant_expr (e->value.op.op2)));
702
703 break;
704
705 case EXPR_VARIABLE:
706 rv = 0;
707 break;
708
709 case EXPR_FUNCTION:
710 /* Call to intrinsic with at least one argument. */
711 rv = 0;
712 if (e->value.function.isym && e->value.function.actual)
713 {
714 for (arg = e->value.function.actual; arg; arg = arg->next)
715 {
716 if (!gfc_is_constant_expr (arg->expr))
717 break;
718 }
719 if (arg == NULL)
720 rv = 1;
721 }
722 break;
723
724 case EXPR_CONSTANT:
725 case EXPR_NULL:
726 rv = 1;
727 break;
728
729 case EXPR_SUBSTRING:
730 rv = (gfc_is_constant_expr (e->ref->u.ss.start)
731 && gfc_is_constant_expr (e->ref->u.ss.end));
732 break;
733
734 case EXPR_STRUCTURE:
735 rv = 0;
736 for (c = e->value.constructor; c; c = c->next)
737 if (!gfc_is_constant_expr (c->expr))
738 break;
739
740 if (c == NULL)
741 rv = 1;
742 break;
743
744 case EXPR_ARRAY:
745 rv = gfc_constant_ac (e);
746 break;
747
748 default:
749 gfc_internal_error ("gfc_is_constant_expr(): Unknown expression type");
750 }
751
752 return rv;
753 }
754
755
756 /* Try to collapse intrinsic expressions. */
757
758 static try
759 simplify_intrinsic_op (gfc_expr * p, int type)
760 {
761 gfc_expr *op1, *op2, *result;
762
763 if (p->value.op.operator == INTRINSIC_USER)
764 return SUCCESS;
765
766 op1 = p->value.op.op1;
767 op2 = p->value.op.op2;
768
769 if (gfc_simplify_expr (op1, type) == FAILURE)
770 return FAILURE;
771 if (gfc_simplify_expr (op2, type) == FAILURE)
772 return FAILURE;
773
774 if (!gfc_is_constant_expr (op1)
775 || (op2 != NULL && !gfc_is_constant_expr (op2)))
776 return SUCCESS;
777
778 /* Rip p apart */
779 p->value.op.op1 = NULL;
780 p->value.op.op2 = NULL;
781
782 switch (p->value.op.operator)
783 {
784 case INTRINSIC_UPLUS:
785 case INTRINSIC_PARENTHESES:
786 result = gfc_uplus (op1);
787 break;
788
789 case INTRINSIC_UMINUS:
790 result = gfc_uminus (op1);
791 break;
792
793 case INTRINSIC_PLUS:
794 result = gfc_add (op1, op2);
795 break;
796
797 case INTRINSIC_MINUS:
798 result = gfc_subtract (op1, op2);
799 break;
800
801 case INTRINSIC_TIMES:
802 result = gfc_multiply (op1, op2);
803 break;
804
805 case INTRINSIC_DIVIDE:
806 result = gfc_divide (op1, op2);
807 break;
808
809 case INTRINSIC_POWER:
810 result = gfc_power (op1, op2);
811 break;
812
813 case INTRINSIC_CONCAT:
814 result = gfc_concat (op1, op2);
815 break;
816
817 case INTRINSIC_EQ:
818 result = gfc_eq (op1, op2);
819 break;
820
821 case INTRINSIC_NE:
822 result = gfc_ne (op1, op2);
823 break;
824
825 case INTRINSIC_GT:
826 result = gfc_gt (op1, op2);
827 break;
828
829 case INTRINSIC_GE:
830 result = gfc_ge (op1, op2);
831 break;
832
833 case INTRINSIC_LT:
834 result = gfc_lt (op1, op2);
835 break;
836
837 case INTRINSIC_LE:
838 result = gfc_le (op1, op2);
839 break;
840
841 case INTRINSIC_NOT:
842 result = gfc_not (op1);
843 break;
844
845 case INTRINSIC_AND:
846 result = gfc_and (op1, op2);
847 break;
848
849 case INTRINSIC_OR:
850 result = gfc_or (op1, op2);
851 break;
852
853 case INTRINSIC_EQV:
854 result = gfc_eqv (op1, op2);
855 break;
856
857 case INTRINSIC_NEQV:
858 result = gfc_neqv (op1, op2);
859 break;
860
861 default:
862 gfc_internal_error ("simplify_intrinsic_op(): Bad operator");
863 }
864
865 if (result == NULL)
866 {
867 gfc_free_expr (op1);
868 gfc_free_expr (op2);
869 return FAILURE;
870 }
871
872 gfc_replace_expr (p, result);
873
874 return SUCCESS;
875 }
876
877
878 /* Subroutine to simplify constructor expressions. Mutually recursive
879 with gfc_simplify_expr(). */
880
881 static try
882 simplify_constructor (gfc_constructor * c, int type)
883 {
884
885 for (; c; c = c->next)
886 {
887 if (c->iterator
888 && (gfc_simplify_expr (c->iterator->start, type) == FAILURE
889 || gfc_simplify_expr (c->iterator->end, type) == FAILURE
890 || gfc_simplify_expr (c->iterator->step, type) == FAILURE))
891 return FAILURE;
892
893 if (c->expr && gfc_simplify_expr (c->expr, type) == FAILURE)
894 return FAILURE;
895 }
896
897 return SUCCESS;
898 }
899
900
901 /* Pull a single array element out of an array constructor. */
902
903 static gfc_constructor *
904 find_array_element (gfc_constructor * cons, gfc_array_ref * ar)
905 {
906 unsigned long nelemen;
907 int i;
908 mpz_t delta;
909 mpz_t offset;
910
911 mpz_init_set_ui (offset, 0);
912 mpz_init (delta);
913 for (i = 0; i < ar->dimen; i++)
914 {
915 if (ar->start[i]->expr_type != EXPR_CONSTANT)
916 {
917 cons = NULL;
918 break;
919 }
920 mpz_sub (delta, ar->start[i]->value.integer,
921 ar->as->lower[i]->value.integer);
922 mpz_add (offset, offset, delta);
923 }
924
925 if (cons)
926 {
927 if (mpz_fits_ulong_p (offset))
928 {
929 for (nelemen = mpz_get_ui (offset); nelemen > 0; nelemen--)
930 {
931 if (cons->iterator)
932 {
933 cons = NULL;
934 break;
935 }
936 cons = cons->next;
937 }
938 }
939 else
940 cons = NULL;
941 }
942
943 mpz_clear (delta);
944 mpz_clear (offset);
945
946 return cons;
947 }
948
949
950 /* Find a component of a structure constructor. */
951
952 static gfc_constructor *
953 find_component_ref (gfc_constructor * cons, gfc_ref * ref)
954 {
955 gfc_component *comp;
956 gfc_component *pick;
957
958 comp = ref->u.c.sym->components;
959 pick = ref->u.c.component;
960 while (comp != pick)
961 {
962 comp = comp->next;
963 cons = cons->next;
964 }
965
966 return cons;
967 }
968
969
970 /* Replace an expression with the contents of a constructor, removing
971 the subobject reference in the process. */
972
973 static void
974 remove_subobject_ref (gfc_expr * p, gfc_constructor * cons)
975 {
976 gfc_expr *e;
977
978 e = cons->expr;
979 cons->expr = NULL;
980 e->ref = p->ref->next;
981 p->ref->next = NULL;
982 gfc_replace_expr (p, e);
983 }
984
985
986 /* Simplify a subobject reference of a constructor. This occurs when
987 parameter variable values are substituted. */
988
989 static try
990 simplify_const_ref (gfc_expr * p)
991 {
992 gfc_constructor *cons;
993
994 while (p->ref)
995 {
996 switch (p->ref->type)
997 {
998 case REF_ARRAY:
999 switch (p->ref->u.ar.type)
1000 {
1001 case AR_ELEMENT:
1002 cons = find_array_element (p->value.constructor, &p->ref->u.ar);
1003 if (!cons)
1004 return SUCCESS;
1005 remove_subobject_ref (p, cons);
1006 break;
1007
1008 case AR_FULL:
1009 if (p->ref->next != NULL)
1010 {
1011 /* TODO: Simplify array subobject references. */
1012 return SUCCESS;
1013 }
1014 gfc_free_ref_list (p->ref);
1015 p->ref = NULL;
1016 break;
1017
1018 default:
1019 /* TODO: Simplify array subsections. */
1020 return SUCCESS;
1021 }
1022
1023 break;
1024
1025 case REF_COMPONENT:
1026 cons = find_component_ref (p->value.constructor, p->ref);
1027 remove_subobject_ref (p, cons);
1028 break;
1029
1030 case REF_SUBSTRING:
1031 /* TODO: Constant substrings. */
1032 return SUCCESS;
1033 }
1034 }
1035
1036 return SUCCESS;
1037 }
1038
1039
1040 /* Simplify a chain of references. */
1041
1042 static try
1043 simplify_ref_chain (gfc_ref * ref, int type)
1044 {
1045 int n;
1046
1047 for (; ref; ref = ref->next)
1048 {
1049 switch (ref->type)
1050 {
1051 case REF_ARRAY:
1052 for (n = 0; n < ref->u.ar.dimen; n++)
1053 {
1054 if (gfc_simplify_expr (ref->u.ar.start[n], type)
1055 == FAILURE)
1056 return FAILURE;
1057 if (gfc_simplify_expr (ref->u.ar.end[n], type)
1058 == FAILURE)
1059 return FAILURE;
1060 if (gfc_simplify_expr (ref->u.ar.stride[n], type)
1061 == FAILURE)
1062 return FAILURE;
1063 }
1064 break;
1065
1066 case REF_SUBSTRING:
1067 if (gfc_simplify_expr (ref->u.ss.start, type) == FAILURE)
1068 return FAILURE;
1069 if (gfc_simplify_expr (ref->u.ss.end, type) == FAILURE)
1070 return FAILURE;
1071 break;
1072
1073 default:
1074 break;
1075 }
1076 }
1077 return SUCCESS;
1078 }
1079
1080
1081 /* Try to substitute the value of a parameter variable. */
1082 static try
1083 simplify_parameter_variable (gfc_expr * p, int type)
1084 {
1085 gfc_expr *e;
1086 try t;
1087
1088 e = gfc_copy_expr (p->symtree->n.sym->value);
1089 /* Do not copy subobject refs for constant. */
1090 if (e->expr_type != EXPR_CONSTANT && p->ref != NULL)
1091 e->ref = copy_ref (p->ref);
1092 t = gfc_simplify_expr (e, type);
1093
1094 /* Only use the simplification if it eliminated all subobject
1095 references. */
1096 if (t == SUCCESS && ! e->ref)
1097 gfc_replace_expr (p, e);
1098 else
1099 gfc_free_expr (e);
1100
1101 return t;
1102 }
1103
1104 /* Given an expression, simplify it by collapsing constant
1105 expressions. Most simplification takes place when the expression
1106 tree is being constructed. If an intrinsic function is simplified
1107 at some point, we get called again to collapse the result against
1108 other constants.
1109
1110 We work by recursively simplifying expression nodes, simplifying
1111 intrinsic functions where possible, which can lead to further
1112 constant collapsing. If an operator has constant operand(s), we
1113 rip the expression apart, and rebuild it, hoping that it becomes
1114 something simpler.
1115
1116 The expression type is defined for:
1117 0 Basic expression parsing
1118 1 Simplifying array constructors -- will substitute
1119 iterator values.
1120 Returns FAILURE on error, SUCCESS otherwise.
1121 NOTE: Will return SUCCESS even if the expression can not be simplified. */
1122
1123 try
1124 gfc_simplify_expr (gfc_expr * p, int type)
1125 {
1126 gfc_actual_arglist *ap;
1127
1128 if (p == NULL)
1129 return SUCCESS;
1130
1131 switch (p->expr_type)
1132 {
1133 case EXPR_CONSTANT:
1134 case EXPR_NULL:
1135 break;
1136
1137 case EXPR_FUNCTION:
1138 for (ap = p->value.function.actual; ap; ap = ap->next)
1139 if (gfc_simplify_expr (ap->expr, type) == FAILURE)
1140 return FAILURE;
1141
1142 if (p->value.function.isym != NULL
1143 && gfc_intrinsic_func_interface (p, 1) == MATCH_ERROR)
1144 return FAILURE;
1145
1146 break;
1147
1148 case EXPR_SUBSTRING:
1149 if (simplify_ref_chain (p->ref, type) == FAILURE)
1150 return FAILURE;
1151
1152 if (gfc_is_constant_expr (p))
1153 {
1154 char *s;
1155 int start, end;
1156
1157 gfc_extract_int (p->ref->u.ss.start, &start);
1158 start--; /* Convert from one-based to zero-based. */
1159 gfc_extract_int (p->ref->u.ss.end, &end);
1160 s = gfc_getmem (end - start + 1);
1161 memcpy (s, p->value.character.string + start, end - start);
1162 s[end] = '\0'; /* TODO: C-style string for debugging. */
1163 gfc_free (p->value.character.string);
1164 p->value.character.string = s;
1165 p->value.character.length = end - start;
1166 p->ts.cl = gfc_get_charlen ();
1167 p->ts.cl->next = gfc_current_ns->cl_list;
1168 gfc_current_ns->cl_list = p->ts.cl;
1169 p->ts.cl->length = gfc_int_expr (p->value.character.length);
1170 gfc_free_ref_list (p->ref);
1171 p->ref = NULL;
1172 p->expr_type = EXPR_CONSTANT;
1173 }
1174 break;
1175
1176 case EXPR_OP:
1177 if (simplify_intrinsic_op (p, type) == FAILURE)
1178 return FAILURE;
1179 break;
1180
1181 case EXPR_VARIABLE:
1182 /* Only substitute array parameter variables if we are in an
1183 initialization expression, or we want a subsection. */
1184 if (p->symtree->n.sym->attr.flavor == FL_PARAMETER
1185 && (gfc_init_expr || p->ref
1186 || p->symtree->n.sym->value->expr_type != EXPR_ARRAY))
1187 {
1188 if (simplify_parameter_variable (p, type) == FAILURE)
1189 return FAILURE;
1190 break;
1191 }
1192
1193 if (type == 1)
1194 {
1195 gfc_simplify_iterator_var (p);
1196 }
1197
1198 /* Simplify subcomponent references. */
1199 if (simplify_ref_chain (p->ref, type) == FAILURE)
1200 return FAILURE;
1201
1202 break;
1203
1204 case EXPR_STRUCTURE:
1205 case EXPR_ARRAY:
1206 if (simplify_ref_chain (p->ref, type) == FAILURE)
1207 return FAILURE;
1208
1209 if (simplify_constructor (p->value.constructor, type) == FAILURE)
1210 return FAILURE;
1211
1212 if (p->expr_type == EXPR_ARRAY)
1213 gfc_expand_constructor (p);
1214
1215 if (simplify_const_ref (p) == FAILURE)
1216 return FAILURE;
1217
1218 break;
1219 }
1220
1221 return SUCCESS;
1222 }
1223
1224
1225 /* Returns the type of an expression with the exception that iterator
1226 variables are automatically integers no matter what else they may
1227 be declared as. */
1228
1229 static bt
1230 et0 (gfc_expr * e)
1231 {
1232
1233 if (e->expr_type == EXPR_VARIABLE && gfc_check_iter_variable (e) == SUCCESS)
1234 return BT_INTEGER;
1235
1236 return e->ts.type;
1237 }
1238
1239
1240 /* Check an intrinsic arithmetic operation to see if it is consistent
1241 with some type of expression. */
1242
1243 static try check_init_expr (gfc_expr *);
1244
1245 static try
1246 check_intrinsic_op (gfc_expr * e, try (*check_function) (gfc_expr *))
1247 {
1248 gfc_expr *op1 = e->value.op.op1;
1249 gfc_expr *op2 = e->value.op.op2;
1250
1251 if ((*check_function) (op1) == FAILURE)
1252 return FAILURE;
1253
1254 switch (e->value.op.operator)
1255 {
1256 case INTRINSIC_UPLUS:
1257 case INTRINSIC_UMINUS:
1258 if (!numeric_type (et0 (op1)))
1259 goto not_numeric;
1260 break;
1261
1262 case INTRINSIC_EQ:
1263 case INTRINSIC_NE:
1264 case INTRINSIC_GT:
1265 case INTRINSIC_GE:
1266 case INTRINSIC_LT:
1267 case INTRINSIC_LE:
1268 if ((*check_function) (op2) == FAILURE)
1269 return FAILURE;
1270
1271 if (!(et0 (op1) == BT_CHARACTER && et0 (op2) == BT_CHARACTER)
1272 && !(numeric_type (et0 (op1)) && numeric_type (et0 (op2))))
1273 {
1274 gfc_error ("Numeric or CHARACTER operands are required in "
1275 "expression at %L", &e->where);
1276 return FAILURE;
1277 }
1278 break;
1279
1280 case INTRINSIC_PLUS:
1281 case INTRINSIC_MINUS:
1282 case INTRINSIC_TIMES:
1283 case INTRINSIC_DIVIDE:
1284 case INTRINSIC_POWER:
1285 if ((*check_function) (op2) == FAILURE)
1286 return FAILURE;
1287
1288 if (!numeric_type (et0 (op1)) || !numeric_type (et0 (op2)))
1289 goto not_numeric;
1290
1291 if (e->value.op.operator == INTRINSIC_POWER
1292 && check_function == check_init_expr && et0 (op2) != BT_INTEGER)
1293 {
1294 gfc_error ("Exponent at %L must be INTEGER for an initialization "
1295 "expression", &op2->where);
1296 return FAILURE;
1297 }
1298
1299 break;
1300
1301 case INTRINSIC_CONCAT:
1302 if ((*check_function) (op2) == FAILURE)
1303 return FAILURE;
1304
1305 if (et0 (op1) != BT_CHARACTER || et0 (op2) != BT_CHARACTER)
1306 {
1307 gfc_error ("Concatenation operator in expression at %L "
1308 "must have two CHARACTER operands", &op1->where);
1309 return FAILURE;
1310 }
1311
1312 if (op1->ts.kind != op2->ts.kind)
1313 {
1314 gfc_error ("Concat operator at %L must concatenate strings of the "
1315 "same kind", &e->where);
1316 return FAILURE;
1317 }
1318
1319 break;
1320
1321 case INTRINSIC_NOT:
1322 if (et0 (op1) != BT_LOGICAL)
1323 {
1324 gfc_error (".NOT. operator in expression at %L must have a LOGICAL "
1325 "operand", &op1->where);
1326 return FAILURE;
1327 }
1328
1329 break;
1330
1331 case INTRINSIC_AND:
1332 case INTRINSIC_OR:
1333 case INTRINSIC_EQV:
1334 case INTRINSIC_NEQV:
1335 if ((*check_function) (op2) == FAILURE)
1336 return FAILURE;
1337
1338 if (et0 (op1) != BT_LOGICAL || et0 (op2) != BT_LOGICAL)
1339 {
1340 gfc_error ("LOGICAL operands are required in expression at %L",
1341 &e->where);
1342 return FAILURE;
1343 }
1344
1345 break;
1346
1347 case INTRINSIC_PARENTHESES:
1348 break;
1349
1350 default:
1351 gfc_error ("Only intrinsic operators can be used in expression at %L",
1352 &e->where);
1353 return FAILURE;
1354 }
1355
1356 return SUCCESS;
1357
1358 not_numeric:
1359 gfc_error ("Numeric operands are required in expression at %L", &e->where);
1360
1361 return FAILURE;
1362 }
1363
1364
1365
1366 /* Certain inquiry functions are specifically allowed to have variable
1367 arguments, which is an exception to the normal requirement that an
1368 initialization function have initialization arguments. We head off
1369 this problem here. */
1370
1371 static try
1372 check_inquiry (gfc_expr * e, int not_restricted)
1373 {
1374 const char *name;
1375
1376 /* FIXME: This should be moved into the intrinsic definitions,
1377 to eliminate this ugly hack. */
1378 static const char * const inquiry_function[] = {
1379 "digits", "epsilon", "huge", "kind", "len", "maxexponent", "minexponent",
1380 "precision", "radix", "range", "tiny", "bit_size", "size", "shape",
1381 "lbound", "ubound", NULL
1382 };
1383
1384 int i;
1385
1386 /* An undeclared parameter will get us here (PR25018). */
1387 if (e->symtree == NULL)
1388 return FAILURE;
1389
1390 name = e->symtree->n.sym->name;
1391
1392 for (i = 0; inquiry_function[i]; i++)
1393 if (strcmp (inquiry_function[i], name) == 0)
1394 break;
1395
1396 if (inquiry_function[i] == NULL)
1397 return FAILURE;
1398
1399 e = e->value.function.actual->expr;
1400
1401 if (e == NULL || e->expr_type != EXPR_VARIABLE)
1402 return FAILURE;
1403
1404 /* At this point we have an inquiry function with a variable argument. The
1405 type of the variable might be undefined, but we need it now, because the
1406 arguments of these functions are allowed to be undefined. */
1407
1408 if (e->ts.type == BT_UNKNOWN)
1409 {
1410 if (e->symtree->n.sym->ts.type == BT_UNKNOWN
1411 && gfc_set_default_type (e->symtree->n.sym, 0, gfc_current_ns)
1412 == FAILURE)
1413 return FAILURE;
1414
1415 e->ts = e->symtree->n.sym->ts;
1416 }
1417
1418 /* Assumed character length will not reduce to a constant expression
1419 with LEN, as required by the standard. */
1420 if (i == 4 && not_restricted
1421 && e->symtree->n.sym->ts.type == BT_CHARACTER
1422 && e->symtree->n.sym->ts.cl->length == NULL)
1423 gfc_notify_std (GFC_STD_GNU, "assumed character length "
1424 "variable '%s' in constant expression at %L",
1425 e->symtree->n.sym->name, &e->where);
1426
1427 return SUCCESS;
1428 }
1429
1430
1431 /* Verify that an expression is an initialization expression. A side
1432 effect is that the expression tree is reduced to a single constant
1433 node if all goes well. This would normally happen when the
1434 expression is constructed but function references are assumed to be
1435 intrinsics in the context of initialization expressions. If
1436 FAILURE is returned an error message has been generated. */
1437
1438 static try
1439 check_init_expr (gfc_expr * e)
1440 {
1441 gfc_actual_arglist *ap;
1442 match m;
1443 try t;
1444
1445 if (e == NULL)
1446 return SUCCESS;
1447
1448 switch (e->expr_type)
1449 {
1450 case EXPR_OP:
1451 t = check_intrinsic_op (e, check_init_expr);
1452 if (t == SUCCESS)
1453 t = gfc_simplify_expr (e, 0);
1454
1455 break;
1456
1457 case EXPR_FUNCTION:
1458 t = SUCCESS;
1459
1460 if (check_inquiry (e, 1) != SUCCESS)
1461 {
1462 t = SUCCESS;
1463 for (ap = e->value.function.actual; ap; ap = ap->next)
1464 if (check_init_expr (ap->expr) == FAILURE)
1465 {
1466 t = FAILURE;
1467 break;
1468 }
1469 }
1470
1471 if (t == SUCCESS)
1472 {
1473 m = gfc_intrinsic_func_interface (e, 0);
1474
1475 if (m == MATCH_NO)
1476 gfc_error ("Function '%s' in initialization expression at %L "
1477 "must be an intrinsic function",
1478 e->symtree->n.sym->name, &e->where);
1479
1480 if (m != MATCH_YES)
1481 t = FAILURE;
1482 }
1483
1484 break;
1485
1486 case EXPR_VARIABLE:
1487 t = SUCCESS;
1488
1489 if (gfc_check_iter_variable (e) == SUCCESS)
1490 break;
1491
1492 if (e->symtree->n.sym->attr.flavor == FL_PARAMETER)
1493 {
1494 t = simplify_parameter_variable (e, 0);
1495 break;
1496 }
1497
1498 gfc_error ("Parameter '%s' at %L has not been declared or is "
1499 "a variable, which does not reduce to a constant "
1500 "expression", e->symtree->n.sym->name, &e->where);
1501 t = FAILURE;
1502 break;
1503
1504 case EXPR_CONSTANT:
1505 case EXPR_NULL:
1506 t = SUCCESS;
1507 break;
1508
1509 case EXPR_SUBSTRING:
1510 t = check_init_expr (e->ref->u.ss.start);
1511 if (t == FAILURE)
1512 break;
1513
1514 t = check_init_expr (e->ref->u.ss.end);
1515 if (t == SUCCESS)
1516 t = gfc_simplify_expr (e, 0);
1517
1518 break;
1519
1520 case EXPR_STRUCTURE:
1521 t = gfc_check_constructor (e, check_init_expr);
1522 break;
1523
1524 case EXPR_ARRAY:
1525 t = gfc_check_constructor (e, check_init_expr);
1526 if (t == FAILURE)
1527 break;
1528
1529 t = gfc_expand_constructor (e);
1530 if (t == FAILURE)
1531 break;
1532
1533 t = gfc_check_constructor_type (e);
1534 break;
1535
1536 default:
1537 gfc_internal_error ("check_init_expr(): Unknown expression type");
1538 }
1539
1540 return t;
1541 }
1542
1543
1544 /* Match an initialization expression. We work by first matching an
1545 expression, then reducing it to a constant. */
1546
1547 match
1548 gfc_match_init_expr (gfc_expr ** result)
1549 {
1550 gfc_expr *expr;
1551 match m;
1552 try t;
1553
1554 m = gfc_match_expr (&expr);
1555 if (m != MATCH_YES)
1556 return m;
1557
1558 gfc_init_expr = 1;
1559 t = gfc_resolve_expr (expr);
1560 if (t == SUCCESS)
1561 t = check_init_expr (expr);
1562 gfc_init_expr = 0;
1563
1564 if (t == FAILURE)
1565 {
1566 gfc_free_expr (expr);
1567 return MATCH_ERROR;
1568 }
1569
1570 if (expr->expr_type == EXPR_ARRAY
1571 && (gfc_check_constructor_type (expr) == FAILURE
1572 || gfc_expand_constructor (expr) == FAILURE))
1573 {
1574 gfc_free_expr (expr);
1575 return MATCH_ERROR;
1576 }
1577
1578 /* Not all inquiry functions are simplified to constant expressions
1579 so it is necessary to call check_inquiry again. */
1580 if (!gfc_is_constant_expr (expr)
1581 && check_inquiry (expr, 1) == FAILURE)
1582 {
1583 gfc_error ("Initialization expression didn't reduce %C");
1584 return MATCH_ERROR;
1585 }
1586
1587 *result = expr;
1588
1589 return MATCH_YES;
1590 }
1591
1592
1593
1594 static try check_restricted (gfc_expr *);
1595
1596 /* Given an actual argument list, test to see that each argument is a
1597 restricted expression and optionally if the expression type is
1598 integer or character. */
1599
1600 static try
1601 restricted_args (gfc_actual_arglist * a)
1602 {
1603 for (; a; a = a->next)
1604 {
1605 if (check_restricted (a->expr) == FAILURE)
1606 return FAILURE;
1607 }
1608
1609 return SUCCESS;
1610 }
1611
1612
1613 /************* Restricted/specification expressions *************/
1614
1615
1616 /* Make sure a non-intrinsic function is a specification function. */
1617
1618 static try
1619 external_spec_function (gfc_expr * e)
1620 {
1621 gfc_symbol *f;
1622
1623 f = e->value.function.esym;
1624
1625 if (f->attr.proc == PROC_ST_FUNCTION)
1626 {
1627 gfc_error ("Specification function '%s' at %L cannot be a statement "
1628 "function", f->name, &e->where);
1629 return FAILURE;
1630 }
1631
1632 if (f->attr.proc == PROC_INTERNAL)
1633 {
1634 gfc_error ("Specification function '%s' at %L cannot be an internal "
1635 "function", f->name, &e->where);
1636 return FAILURE;
1637 }
1638
1639 if (!f->attr.pure)
1640 {
1641 gfc_error ("Specification function '%s' at %L must be PURE", f->name,
1642 &e->where);
1643 return FAILURE;
1644 }
1645
1646 if (f->attr.recursive)
1647 {
1648 gfc_error ("Specification function '%s' at %L cannot be RECURSIVE",
1649 f->name, &e->where);
1650 return FAILURE;
1651 }
1652
1653 return restricted_args (e->value.function.actual);
1654 }
1655
1656
1657 /* Check to see that a function reference to an intrinsic is a
1658 restricted expression. */
1659
1660 static try
1661 restricted_intrinsic (gfc_expr * e)
1662 {
1663 /* TODO: Check constraints on inquiry functions. 7.1.6.2 (7). */
1664 if (check_inquiry (e, 0) == SUCCESS)
1665 return SUCCESS;
1666
1667 return restricted_args (e->value.function.actual);
1668 }
1669
1670
1671 /* Verify that an expression is a restricted expression. Like its
1672 cousin check_init_expr(), an error message is generated if we
1673 return FAILURE. */
1674
1675 static try
1676 check_restricted (gfc_expr * e)
1677 {
1678 gfc_symbol *sym;
1679 try t;
1680
1681 if (e == NULL)
1682 return SUCCESS;
1683
1684 switch (e->expr_type)
1685 {
1686 case EXPR_OP:
1687 t = check_intrinsic_op (e, check_restricted);
1688 if (t == SUCCESS)
1689 t = gfc_simplify_expr (e, 0);
1690
1691 break;
1692
1693 case EXPR_FUNCTION:
1694 t = e->value.function.esym ?
1695 external_spec_function (e) : restricted_intrinsic (e);
1696
1697 break;
1698
1699 case EXPR_VARIABLE:
1700 sym = e->symtree->n.sym;
1701 t = FAILURE;
1702
1703 if (sym->attr.optional)
1704 {
1705 gfc_error ("Dummy argument '%s' at %L cannot be OPTIONAL",
1706 sym->name, &e->where);
1707 break;
1708 }
1709
1710 if (sym->attr.intent == INTENT_OUT)
1711 {
1712 gfc_error ("Dummy argument '%s' at %L cannot be INTENT(OUT)",
1713 sym->name, &e->where);
1714 break;
1715 }
1716
1717 /* gfc_is_formal_arg broadcasts that a formal argument list is being processed
1718 in resolve.c(resolve_formal_arglist). This is done so that host associated
1719 dummy array indices are accepted (PR23446). */
1720 if (sym->attr.in_common
1721 || sym->attr.use_assoc
1722 || sym->attr.dummy
1723 || sym->ns != gfc_current_ns
1724 || (sym->ns->proc_name != NULL
1725 && sym->ns->proc_name->attr.flavor == FL_MODULE)
1726 || gfc_is_formal_arg ())
1727 {
1728 t = SUCCESS;
1729 break;
1730 }
1731
1732 gfc_error ("Variable '%s' cannot appear in the expression at %L",
1733 sym->name, &e->where);
1734
1735 break;
1736
1737 case EXPR_NULL:
1738 case EXPR_CONSTANT:
1739 t = SUCCESS;
1740 break;
1741
1742 case EXPR_SUBSTRING:
1743 t = gfc_specification_expr (e->ref->u.ss.start);
1744 if (t == FAILURE)
1745 break;
1746
1747 t = gfc_specification_expr (e->ref->u.ss.end);
1748 if (t == SUCCESS)
1749 t = gfc_simplify_expr (e, 0);
1750
1751 break;
1752
1753 case EXPR_STRUCTURE:
1754 t = gfc_check_constructor (e, check_restricted);
1755 break;
1756
1757 case EXPR_ARRAY:
1758 t = gfc_check_constructor (e, check_restricted);
1759 break;
1760
1761 default:
1762 gfc_internal_error ("check_restricted(): Unknown expression type");
1763 }
1764
1765 return t;
1766 }
1767
1768
1769 /* Check to see that an expression is a specification expression. If
1770 we return FAILURE, an error has been generated. */
1771
1772 try
1773 gfc_specification_expr (gfc_expr * e)
1774 {
1775 if (e == NULL)
1776 return SUCCESS;
1777
1778 if (e->ts.type != BT_INTEGER)
1779 {
1780 gfc_error ("Expression at %L must be of INTEGER type", &e->where);
1781 return FAILURE;
1782 }
1783
1784 if (e->rank != 0)
1785 {
1786 gfc_error ("Expression at %L must be scalar", &e->where);
1787 return FAILURE;
1788 }
1789
1790 if (gfc_simplify_expr (e, 0) == FAILURE)
1791 return FAILURE;
1792
1793 return check_restricted (e);
1794 }
1795
1796
1797 /************** Expression conformance checks. *************/
1798
1799 /* Given two expressions, make sure that the arrays are conformable. */
1800
1801 try
1802 gfc_check_conformance (const char *optype_msgid,
1803 gfc_expr * op1, gfc_expr * op2)
1804 {
1805 int op1_flag, op2_flag, d;
1806 mpz_t op1_size, op2_size;
1807 try t;
1808
1809 if (op1->rank == 0 || op2->rank == 0)
1810 return SUCCESS;
1811
1812 if (op1->rank != op2->rank)
1813 {
1814 gfc_error ("Incompatible ranks in %s at %L", _(optype_msgid),
1815 &op1->where);
1816 return FAILURE;
1817 }
1818
1819 t = SUCCESS;
1820
1821 for (d = 0; d < op1->rank; d++)
1822 {
1823 op1_flag = gfc_array_dimen_size (op1, d, &op1_size) == SUCCESS;
1824 op2_flag = gfc_array_dimen_size (op2, d, &op2_size) == SUCCESS;
1825
1826 if (op1_flag && op2_flag && mpz_cmp (op1_size, op2_size) != 0)
1827 {
1828 gfc_error ("different shape for %s at %L on dimension %d (%d/%d)",
1829 _(optype_msgid), &op1->where, d + 1,
1830 (int) mpz_get_si (op1_size),
1831 (int) mpz_get_si (op2_size));
1832
1833 t = FAILURE;
1834 }
1835
1836 if (op1_flag)
1837 mpz_clear (op1_size);
1838 if (op2_flag)
1839 mpz_clear (op2_size);
1840
1841 if (t == FAILURE)
1842 return FAILURE;
1843 }
1844
1845 return SUCCESS;
1846 }
1847
1848
1849 /* Given an assignable expression and an arbitrary expression, make
1850 sure that the assignment can take place. */
1851
1852 try
1853 gfc_check_assign (gfc_expr * lvalue, gfc_expr * rvalue, int conform)
1854 {
1855 gfc_symbol *sym;
1856
1857 sym = lvalue->symtree->n.sym;
1858
1859 if (sym->attr.intent == INTENT_IN)
1860 {
1861 gfc_error ("Can't assign to INTENT(IN) variable '%s' at %L",
1862 sym->name, &lvalue->where);
1863 return FAILURE;
1864 }
1865
1866 if (sym->attr.flavor == FL_PROCEDURE && sym->attr.use_assoc)
1867 {
1868 gfc_error ("'%s' in the assignment at %L cannot be an l-value "
1869 "since it is a procedure", sym->name, &lvalue->where);
1870 return FAILURE;
1871 }
1872
1873
1874 if (rvalue->rank != 0 && lvalue->rank != rvalue->rank)
1875 {
1876 gfc_error ("Incompatible ranks %d and %d in assignment at %L",
1877 lvalue->rank, rvalue->rank, &lvalue->where);
1878 return FAILURE;
1879 }
1880
1881 if (lvalue->ts.type == BT_UNKNOWN)
1882 {
1883 gfc_error ("Variable type is UNKNOWN in assignment at %L",
1884 &lvalue->where);
1885 return FAILURE;
1886 }
1887
1888 if (rvalue->expr_type == EXPR_NULL)
1889 {
1890 gfc_error ("NULL appears on right-hand side in assignment at %L",
1891 &rvalue->where);
1892 return FAILURE;
1893 }
1894
1895 if (sym->attr.cray_pointee
1896 && lvalue->ref != NULL
1897 && lvalue->ref->u.ar.type != AR_ELEMENT
1898 && lvalue->ref->u.ar.as->cp_was_assumed)
1899 {
1900 gfc_error ("Vector assignment to assumed-size Cray Pointee at %L"
1901 " is illegal.", &lvalue->where);
1902 return FAILURE;
1903 }
1904
1905 /* This is possibly a typo: x = f() instead of x => f() */
1906 if (gfc_option.warn_surprising
1907 && rvalue->expr_type == EXPR_FUNCTION
1908 && rvalue->symtree->n.sym->attr.pointer)
1909 gfc_warning ("POINTER valued function appears on right-hand side of "
1910 "assignment at %L", &rvalue->where);
1911
1912 /* Check size of array assignments. */
1913 if (lvalue->rank != 0 && rvalue->rank != 0
1914 && gfc_check_conformance ("Array assignment", lvalue, rvalue) != SUCCESS)
1915 return FAILURE;
1916
1917 if (gfc_compare_types (&lvalue->ts, &rvalue->ts))
1918 return SUCCESS;
1919
1920 if (!conform)
1921 {
1922 /* Numeric can be converted to any other numeric. And Hollerith can be
1923 converted to any other type. */
1924 if ((gfc_numeric_ts (&lvalue->ts) && gfc_numeric_ts (&rvalue->ts))
1925 || rvalue->ts.type == BT_HOLLERITH)
1926 return SUCCESS;
1927
1928 if (lvalue->ts.type == BT_LOGICAL && rvalue->ts.type == BT_LOGICAL)
1929 return SUCCESS;
1930
1931 gfc_error ("Incompatible types in assignment at %L, %s to %s",
1932 &rvalue->where, gfc_typename (&rvalue->ts),
1933 gfc_typename (&lvalue->ts));
1934
1935 return FAILURE;
1936 }
1937
1938 return gfc_convert_type (rvalue, &lvalue->ts, 1);
1939 }
1940
1941
1942 /* Check that a pointer assignment is OK. We first check lvalue, and
1943 we only check rvalue if it's not an assignment to NULL() or a
1944 NULLIFY statement. */
1945
1946 try
1947 gfc_check_pointer_assign (gfc_expr * lvalue, gfc_expr * rvalue)
1948 {
1949 symbol_attribute attr;
1950 int is_pure;
1951
1952 if (lvalue->symtree->n.sym->ts.type == BT_UNKNOWN)
1953 {
1954 gfc_error ("Pointer assignment target is not a POINTER at %L",
1955 &lvalue->where);
1956 return FAILURE;
1957 }
1958
1959 if (lvalue->symtree->n.sym->attr.flavor == FL_PROCEDURE
1960 && lvalue->symtree->n.sym->attr.use_assoc)
1961 {
1962 gfc_error ("'%s' in the pointer assignment at %L cannot be an "
1963 "l-value since it is a procedure",
1964 lvalue->symtree->n.sym->name, &lvalue->where);
1965 return FAILURE;
1966 }
1967
1968 attr = gfc_variable_attr (lvalue, NULL);
1969 if (!attr.pointer)
1970 {
1971 gfc_error ("Pointer assignment to non-POINTER at %L", &lvalue->where);
1972 return FAILURE;
1973 }
1974
1975 is_pure = gfc_pure (NULL);
1976
1977 if (is_pure && gfc_impure_variable (lvalue->symtree->n.sym))
1978 {
1979 gfc_error ("Bad pointer object in PURE procedure at %L",
1980 &lvalue->where);
1981 return FAILURE;
1982 }
1983
1984 /* If rvalue is a NULL() or NULLIFY, we're done. Otherwise the type,
1985 kind, etc for lvalue and rvalue must match, and rvalue must be a
1986 pure variable if we're in a pure function. */
1987 if (rvalue->expr_type == EXPR_NULL && rvalue->ts.type == BT_UNKNOWN)
1988 return SUCCESS;
1989
1990 if (!gfc_compare_types (&lvalue->ts, &rvalue->ts))
1991 {
1992 gfc_error ("Different types in pointer assignment at %L",
1993 &lvalue->where);
1994 return FAILURE;
1995 }
1996
1997 if (lvalue->ts.kind != rvalue->ts.kind)
1998 {
1999 gfc_error ("Different kind type parameters in pointer "
2000 "assignment at %L", &lvalue->where);
2001 return FAILURE;
2002 }
2003
2004 if (lvalue->rank != rvalue->rank)
2005 {
2006 gfc_error ("Different ranks in pointer assignment at %L",
2007 &lvalue->where);
2008 return FAILURE;
2009 }
2010
2011 /* Now punt if we are dealing with a NULLIFY(X) or X = NULL(X). */
2012 if (rvalue->expr_type == EXPR_NULL)
2013 return SUCCESS;
2014
2015 if (lvalue->ts.type == BT_CHARACTER
2016 && lvalue->ts.cl->length && rvalue->ts.cl->length
2017 && abs (gfc_dep_compare_expr (lvalue->ts.cl->length,
2018 rvalue->ts.cl->length)) == 1)
2019 {
2020 gfc_error ("Different character lengths in pointer "
2021 "assignment at %L", &lvalue->where);
2022 return FAILURE;
2023 }
2024
2025 attr = gfc_expr_attr (rvalue);
2026 if (!attr.target && !attr.pointer)
2027 {
2028 gfc_error ("Pointer assignment target is neither TARGET "
2029 "nor POINTER at %L", &rvalue->where);
2030 return FAILURE;
2031 }
2032
2033 if (is_pure && gfc_impure_variable (rvalue->symtree->n.sym))
2034 {
2035 gfc_error ("Bad target in pointer assignment in PURE "
2036 "procedure at %L", &rvalue->where);
2037 }
2038
2039 if (gfc_has_vector_index (rvalue))
2040 {
2041 gfc_error ("Pointer assignment with vector subscript "
2042 "on rhs at %L", &rvalue->where);
2043 return FAILURE;
2044 }
2045
2046 return SUCCESS;
2047 }
2048
2049
2050 /* Relative of gfc_check_assign() except that the lvalue is a single
2051 symbol. Used for initialization assignments. */
2052
2053 try
2054 gfc_check_assign_symbol (gfc_symbol * sym, gfc_expr * rvalue)
2055 {
2056 gfc_expr lvalue;
2057 try r;
2058
2059 memset (&lvalue, '\0', sizeof (gfc_expr));
2060
2061 lvalue.expr_type = EXPR_VARIABLE;
2062 lvalue.ts = sym->ts;
2063 if (sym->as)
2064 lvalue.rank = sym->as->rank;
2065 lvalue.symtree = (gfc_symtree *)gfc_getmem (sizeof (gfc_symtree));
2066 lvalue.symtree->n.sym = sym;
2067 lvalue.where = sym->declared_at;
2068
2069 if (sym->attr.pointer)
2070 r = gfc_check_pointer_assign (&lvalue, rvalue);
2071 else
2072 r = gfc_check_assign (&lvalue, rvalue, 1);
2073
2074 gfc_free (lvalue.symtree);
2075
2076 return r;
2077 }
2078
2079
2080 /* Get an expression for a default initializer. */
2081
2082 gfc_expr *
2083 gfc_default_initializer (gfc_typespec *ts)
2084 {
2085 gfc_constructor *tail;
2086 gfc_expr *init;
2087 gfc_component *c;
2088
2089 init = NULL;
2090
2091 /* See if we have a default initializer. */
2092 for (c = ts->derived->components; c; c = c->next)
2093 {
2094 if (c->initializer && init == NULL)
2095 init = gfc_get_expr ();
2096 }
2097
2098 if (init == NULL)
2099 return NULL;
2100
2101 /* Build the constructor. */
2102 init->expr_type = EXPR_STRUCTURE;
2103 init->ts = *ts;
2104 init->where = ts->derived->declared_at;
2105 tail = NULL;
2106 for (c = ts->derived->components; c; c = c->next)
2107 {
2108 if (tail == NULL)
2109 init->value.constructor = tail = gfc_get_constructor ();
2110 else
2111 {
2112 tail->next = gfc_get_constructor ();
2113 tail = tail->next;
2114 }
2115
2116 if (c->initializer)
2117 tail->expr = gfc_copy_expr (c->initializer);
2118 }
2119 return init;
2120 }
2121
2122
2123 /* Given a symbol, create an expression node with that symbol as a
2124 variable. If the symbol is array valued, setup a reference of the
2125 whole array. */
2126
2127 gfc_expr *
2128 gfc_get_variable_expr (gfc_symtree * var)
2129 {
2130 gfc_expr *e;
2131
2132 e = gfc_get_expr ();
2133 e->expr_type = EXPR_VARIABLE;
2134 e->symtree = var;
2135 e->ts = var->n.sym->ts;
2136
2137 if (var->n.sym->as != NULL)
2138 {
2139 e->rank = var->n.sym->as->rank;
2140 e->ref = gfc_get_ref ();
2141 e->ref->type = REF_ARRAY;
2142 e->ref->u.ar.type = AR_FULL;
2143 }
2144
2145 return e;
2146 }
2147
2148
2149 /* Traverse expr, marking all EXPR_VARIABLE symbols referenced. */
2150
2151 void
2152 gfc_expr_set_symbols_referenced (gfc_expr * expr)
2153 {
2154 gfc_actual_arglist *arg;
2155 gfc_constructor *c;
2156 gfc_ref *ref;
2157 int i;
2158
2159 if (!expr) return;
2160
2161 switch (expr->expr_type)
2162 {
2163 case EXPR_OP:
2164 gfc_expr_set_symbols_referenced (expr->value.op.op1);
2165 gfc_expr_set_symbols_referenced (expr->value.op.op2);
2166 break;
2167
2168 case EXPR_FUNCTION:
2169 for (arg = expr->value.function.actual; arg; arg = arg->next)
2170 gfc_expr_set_symbols_referenced (arg->expr);
2171 break;
2172
2173 case EXPR_VARIABLE:
2174 gfc_set_sym_referenced (expr->symtree->n.sym);
2175 break;
2176
2177 case EXPR_CONSTANT:
2178 case EXPR_NULL:
2179 case EXPR_SUBSTRING:
2180 break;
2181
2182 case EXPR_STRUCTURE:
2183 case EXPR_ARRAY:
2184 for (c = expr->value.constructor; c; c = c->next)
2185 gfc_expr_set_symbols_referenced (c->expr);
2186 break;
2187
2188 default:
2189 gcc_unreachable ();
2190 break;
2191 }
2192
2193 for (ref = expr->ref; ref; ref = ref->next)
2194 switch (ref->type)
2195 {
2196 case REF_ARRAY:
2197 for (i = 0; i < ref->u.ar.dimen; i++)
2198 {
2199 gfc_expr_set_symbols_referenced (ref->u.ar.start[i]);
2200 gfc_expr_set_symbols_referenced (ref->u.ar.end[i]);
2201 gfc_expr_set_symbols_referenced (ref->u.ar.stride[i]);
2202 }
2203 break;
2204
2205 case REF_COMPONENT:
2206 break;
2207
2208 case REF_SUBSTRING:
2209 gfc_expr_set_symbols_referenced (ref->u.ss.start);
2210 gfc_expr_set_symbols_referenced (ref->u.ss.end);
2211 break;
2212
2213 default:
2214 gcc_unreachable ();
2215 break;
2216 }
2217 }
Mirror of the offical gcc git repository hosted at gcc.gnu.org